Return to stuff.fs CVS log

Up to [gforth] / gforth

added fsl-util.4th (IIRC from Kryshna Myeni)
made F.S output nicer and moved it from float.fs to stuff.fs
added CLEARSTACKS
exceptions caught by QUIT now clear the stacks (instead of resetting them to
  the depth when first entering QUIT)

    1: \ miscelleneous words
    2: 
    3: \ Copyright (C) 1996,1997,1998,2000,2003 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation; either version 2
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program; if not, write to the Free Software
   19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   20: 
   21: require glocals.fs
   22: 
   23: ' require alias needs ( ... "name" -- ... ) \ gforth
   24: \G An alias for @code{require}; exists on other systems (e.g., Win32Forth).
   25: \ needs is an F-PC name. we will probably switch to 'needs' in the future
   26: 
   27: \ a little more compiler security
   28: 
   29: \ currently not used by Gforth, but maybe by add-ons e.g., the 486asm
   30: AUser CSP
   31: 
   32: : !CSP ( -- )
   33:     sp@ csp ! ;
   34: 
   35: : ?CSP ( -- )
   36:     sp@ csp @ <> -22 and throw ;
   37: 
   38: \ DMIN and DMAX
   39: 
   40: : dmin ( d1 d2 -- d ) \ double d-min
   41:     2over 2over d> IF  2swap  THEN 2drop ;
   42: 
   43: 
   44: : dmax ( d1 d2 -- d ) \ double d-max
   45:     2over 2over d< IF  2swap  THEN 2drop ;
   46: 
   47: \ shell commands
   48: 
   49: 0 Value $? ( -- n ) \ gforth dollar-question
   50: \G @code{Value} -- the exit status returned by the most recently executed
   51: \G @code{system} command.
   52: 
   53: : system ( c-addr u -- ) \ gforth
   54: \G Pass the string specified by @var{c-addr u} to the host operating system
   55: \G for execution in a sub-shell.
   56:     (system) throw TO $? ;
   57: 
   58: : sh ( "..." -- ) \ gforth
   59: \G Parse a string and use @code{system} to pass it to the host
   60: \G operating system for execution in a sub-shell.
   61:     '# parse cr system ;
   62: 
   63: \ stuff
   64: 
   65: : ]L ( compilation: n -- ; run-time: -- n ) \ gforth
   66:     \G equivalent to @code{] literal}
   67:     ] postpone literal ;
   68: 
   69: [ifundef] in-dictionary?
   70: : in-dictionary? ( x -- f )
   71:     forthstart dictionary-end within ;
   72: [endif]
   73: 
   74: : in-return-stack? ( addr -- f )
   75:     rp0 @ swap - [ forthstart 6 cells + ]L @ u< ;
   76: 
   77: \ const-does>
   78: 
   79: : compile-literals ( w*u u -- ; run-time: -- w*u ) recursive
   80:     \ compile u literals, starting with the bottommost one
   81:     ?dup-if
   82: 	swap >r 1- compile-literals
   83: 	r> POSTPONE literal
   84:     endif ;
   85: 
   86: : compile-fliterals ( r*u u -- ; run-time: -- w*u ) recursive
   87:     \ compile u fliterals, starting with the bottommost one
   88:     ?dup-if
   89: 	{ F: r } 1- compile-fliterals
   90: 	r POSTPONE fliteral
   91:     endif ;
   92: 
   93: : (const-does>) ( w*uw r*ur uw ur target "name" -- )
   94:     \ define a colon definition "name" containing w*uw r*ur as
   95:     \ literals and a call to target.
   96:     { uw ur target }
   97:     header docol: cfa, \ start colon def without stack junk
   98:     ur compile-fliterals uw compile-literals
   99:     target compile, POSTPONE exit reveal ;
  100: 
  101: : const-does> ( run-time: w*uw r*ur uw ur "name" -- )
  102:     \G Defines @var{name} and returns.@sp 0
  103:     \G @var{name} execution: pushes @var{w*uw r*ur}, then performs the
  104:     \G code following the @code{const-does>}.
  105:     here >r 0 POSTPONE literal
  106:     POSTPONE (const-does>)
  107:     POSTPONE ;
  108:     noname : POSTPONE rdrop
  109:     latestxt r> cell+ ! \ patch the literal
  110: ; immediate
  111: 
  112: \ !! rewrite slurp-file using slurp-fid
  113: : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
  114:     \G @var{c-addr1 u1} is the filename, @var{c-addr2 u2} is the file's contents
  115:     r/o bin open-file throw >r
  116:     r@ file-size throw abort" file too large"
  117:     dup allocate throw swap
  118:     2dup r@ read-file throw over <> abort" could not read whole file"
  119:     r> close-file throw ;
  120: 
  121: : slurp-fid { fid -- addr u }
  122:     \G @var{addr u} is the content of the file @var{fid}
  123:     0 0 begin ( awhole uwhole )
  124: 	dup 1024 + dup >r extend-mem ( anew awhole uwhole R: unew )
  125: 	rot r@ fid read-file throw ( awhole uwhole uread R: unew )
  126: 	r> 2dup =
  127:     while ( awhole uwhole uread unew )
  128: 	2drop
  129:     repeat
  130:     - + dup >r resize throw r> ;
  131: 
  132: \ ]] ... [[
  133: 
  134: : compile-literal ( n -- )
  135:     postpone literal ;
  136: 
  137: : [[ ( -- )
  138: \G switch from postpone state to compile state
  139:     \ this is only a marker; it is never really interpreted
  140:     compile-only-error ; immediate
  141: 
  142: : postponer ( c-addr u -- )
  143:     2dup find-name dup if ( c-addr u nt )
  144: 	nip nip name>comp
  145: 	2dup [comp'] [[ d= if
  146: 	    2drop ['] compiler is parser
  147: 	else
  148: 	    postpone,
  149: 	endif
  150:     else
  151: 	drop
  152: 	2dup snumber? dup if
  153: 	    0> IF
  154: 		swap postpone literal postpone compile-literal
  155: 	    THEN
  156: 	    postpone Literal postpone compile-literal
  157: 	    2drop
  158: 	ELSE
  159: 	    drop no.extensions
  160: 	THEN
  161:     then ;
  162: 
  163: : ]] ( -- )
  164:     \ switch into postpone state
  165:     ['] postponer is parser state on ; immediate restrict
  166: 
  167: \ f.rdp
  168: 
  169: : push-right ( c-addr u1 u2 cfill -- )
  170:     \ move string at c-addr u1 right by u2 chars (without exceeding
  171:     \ the original bound); fill the gap with cfill
  172:     >r over min dup >r rot dup >r ( u1 u2 c-addr R: cfill u2 c-addr )
  173:     dup 2swap /string cmove>
  174:     r> r> r> fill ;
  175: 
  176: : f>buf-rdp-try { f: rf c-addr ur nd up um1 -- um2 }
  177:     \ um1 is the mantissa length to try, um2 is the actual mantissa length
  178:     c-addr ur um1 /string '0 fill
  179:     rf c-addr um1 represent if { nexp fsign }
  180: 	nd nexp + up >=
  181: 	ur nd - 1- dup { beforep } fsign + nexp 0 max >= and if
  182: 	    \ fixed-point notation
  183: 	    c-addr ur beforep nexp - dup { befored } '0 push-right
  184: 	    c-addr beforep 1- befored min dup { beforez } 0 max bl fill
  185: 	    fsign if
  186: 		'- c-addr beforez 1- 0 max + c!
  187: 	    endif
  188: 	    c-addr ur beforep /string 1 '. push-right
  189: 	    nexp nd +
  190: 	else \ exponential notation
  191: 	    c-addr ur 1 /string 1 '. push-right
  192: 	    fsign if
  193: 		c-addr ur 1 '- push-right
  194: 	    endif
  195: 	    nexp 1- s>d tuck dabs <<# #s rot sign 'E hold #> { explen }
  196: 	    ur explen - 1- fsign + { mantlen }
  197: 	    mantlen 0< if \ exponent too large
  198: 		drop c-addr ur '* fill
  199: 	    else
  200: 		c-addr ur + 0 explen negate /string move
  201: 	    endif
  202: 	    #>> mantlen
  203: 	endif
  204:     else \ inf or nan
  205: 	if \ negative
  206: 	    c-addr ur 1 '- push-right
  207: 	endif
  208: 	drop ur
  209: 	\ !! align in some way?
  210:     endif
  211:     1 max ur min ;
  212: 
  213: : f>buf-rdp ( rf c-addr +nr +nd +np -- ) \ gforth
  214: \G Convert @i{rf} into a string at @i{c-addr nr}.  The conversion
  215: \G rules and the meanings of @i{nr nd np} are the same as for
  216: \G @code{f.rdp}.
  217:     \ first, get the mantissa length, then convert for real.  The
  218:     \ mantissa length is wrong in a few cases because of different
  219:     \ rounding; In most cases this does not matter, because the
  220:     \ mantissa is shorter than expected and the final digits are 0;
  221:     \ but in a few cases the mantissa gets longer.  Then it is
  222:     \ conceivable that you will see a result that is rounded too much.
  223:     \ However, I have not been able to construct an example where this
  224:     \ leads to an unexpected result.
  225:     swap 0 max swap 0 max
  226:     fdup 2over 2over 2 pick f>buf-rdp-try f>buf-rdp-try drop ;
  227: 
  228: : f>str-rdp ( rf +nr +nd +np -- c-addr nr ) \ gforth
  229: \G Convert @i{rf} into a string at @i{c-addr nr}.  The conversion
  230: \G rules and the meanings of @i{nr +nd np} are the same as for
  231: \G @code{f.rdp}.  The result in in the pictured numeric output buffer
  232: \G and will be destroyed by anything destroying that buffer.
  233:     rot holdptr @ 1- 0 rot negate /string ( rf +nd np c-addr nr )
  234:     over holdbuf u< -&17 and throw
  235:     2tuck 2>r f>buf-rdp 2r> ;
  236: 
  237: : f.rdp ( rf +nr +nd +np -- ) \ gforth
  238: \G Print float @i{rf} formatted.  The total width of the output is
  239: \G @i{nr}.  For fixed-point notation, the number of digits after the
  240: \G decimal point is @i{+nd} and the minimum number of significant
  241: \G digits is @i{np}.  @code{Set-precision} has no effect on
  242: \G @code{f.rdp}.  Fixed-point notation is used if the number of
  243: \G siginicant digits would be at least @i{np} and if the number of
  244: \G digits before the decimal point would fit.  If fixed-point notation
  245: \G is not used, exponential notation is used, and if that does not
  246: \G fit, asterisks are printed.  We recommend using @i{nr}>=7 to avoid
  247: \G the risk of numbers not fitting at all.  We recommend
  248: \G @i{nr}>=@i{np}+5 to avoid cases where @code{f.rdp} switches to
  249: \G exponential notation because fixed-point notation would have too
  250: \G few significant digits, yet exponential notation offers fewer
  251: \G significant digits.  We recommend @i{nr}>=@i{nd}+2, if you want to
  252: \G have fixed-point notation for some numbers.  We recommend
  253: \G @i{np}>@i{nr}, if you want to have exponential notation for all
  254: \G numbers.
  255:     f>str-rdp type ;
  256: 
  257: 0 [if]
  258: : testx ( rf ur nd up -- )
  259:     '| emit f.rdp ;
  260: 
  261: : test ( -- )
  262:     -0.123456789123456789e-20
  263:     40 0 ?do
  264: 	cr
  265: 	fdup 7 3 1 testx
  266: 	fdup 7 3 4 testx
  267: 	fdup 7 3 0 testx
  268: 	fdup 7 7 1 testx
  269: 	fdup 7 5 1 testx
  270: 	fdup 7 0 2 testx
  271: 	fdup 5 2 1 testx
  272: 	fdup 4 2 1 testx
  273: 	fdup 18 8 5 testx
  274: 	'| emit
  275: 	10e f*
  276:     loop ;
  277: [then]
  278: 
  279: : f.s ( -- ) \ gforth f-dot-s
  280:     \G Display the number of items on the floating-point stack,
  281:     \G followed by a list of the items; TOS is the right-most item.
  282:     ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0 
  283:     ?DO  dup i - 1- floats fp@ + f@ 16 5 11 f.rdp space LOOP  drop ;