Return to float.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: \ High level floating point                            14jan94py
    2: 
    3: \ Copyright (C) 1995,1997,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: \ 1 cells 4 = [IF]
   22: \ ' cells   Alias sfloats
   23: \ ' cell+   Alias sfloat+
   24: \ ' align   Alias sfalign
   25: \ ' aligned Alias sfaligned
   26: \ [ELSE]
   27: \ : sfloats  2* 2* ;
   28: \ : sfloat+  4 + ;
   29: \ : sfaligned ( addr -- addr' )  3 + -4 and ;
   30: \ : sfalign ( -- )  here dup sfaligned swap ?DO  bl c,  LOOP ;
   31: \ [THEN]
   32: 
   33: \ 1 floats 8 = [IF]
   34: \ ' floats   Alias dfloats
   35: \ ' float+   Alias dfloat+
   36: \ ' falign   Alias dfalign
   37: \ ' faligned Alias dfaligned
   38: \ [ELSE]
   39: \ : dfloats  2* 2* 2* ;
   40: \ : dfloat+  8 + ;
   41: \ : dfaligned ( addr -- addr' )  7 + -8 and ;
   42: \ : dfalign ( -- )  here dup dfaligned swap ?DO  bl c,  LOOP ;
   43: \ [THEN]
   44: 
   45: : sfalign ( -- ) \ float-ext s-f-align
   46:     \G If the data-space pointer is not single-float-aligned, reserve
   47:     \G enough space to align it.
   48:     here dup sfaligned swap ?DO  bl c,  LOOP ;
   49: : dfalign ( -- ) \ float-ext d-f-align
   50:     \G If the data-space pointer is not double-float-aligned, reserve
   51:     \G enough space to align it.
   52:     here dup dfaligned swap ?DO  bl c,  LOOP ;
   53: 
   54: 1 sfloats (Field) sfloat+ , ( sf-addr1 -- sf-addr2 ) \ float-ext s-float-plus
   55: \G @code{1 sfloats +}.
   56: 
   57: 1 dfloats (Field) dfloat+ , ( df-addr1 -- df-addr2 ) \ float-ext d-float-plus
   58: \G @code{1 dfloats +}.
   59: 
   60: : f, ( f -- ) \ gforth
   61:     \G Reserve data space for one floating-point number and store
   62:     \G @i{f} in the space.
   63:     here 1 floats allot f! ;
   64: 
   65: : fconstant  ( r "name" -- ) \ float f-constant
   66:     Create f,
   67: DOES> ( -- r )
   68:     f@ ;
   69: 
   70: : fdepth ( -- +n ) \ float f-depth
   71:     \G @i{+n} is the current number of (floating-point) values on the
   72:     \G floating-point stack.
   73:     fp0 @ fp@ - [ 1 floats ] Literal / ;
   74: 
   75: : FLiteral ( compilation r -- ; run-time -- r ) \ float f-literal
   76:     \G Compile appropriate code such that, at run-time, @i{r} is placed
   77:     \G on the (floating-point) stack. Interpretation semantics are undefined.
   78:     BEGIN  here cell+ cell+ dup faligned <>  WHILE  postpone noop  REPEAT
   79:     postpone ahead here >r f, postpone then
   80:     r> postpone literal postpone f@ ;  immediate
   81: 
   82: &15 Value precision ( -- u ) \ float-ext
   83: \G @i{u} is the number of significant digits currently used by
   84: \G @code{F.} @code{FE.} and @code{FS.} 
   85: : set-precision ( u -- ) \ float-ext
   86:     \G Set the number of significant digits currently used by
   87:     \G @code{F.} @code{FE.} and @code{FS.} to @i{u}.
   88:     to precision ;
   89: 
   90: : scratch ( r -- addr len )
   91:   pad precision - precision ;
   92: 
   93: : zeros ( n -- )   0 max 0 ?DO  '0 emit  LOOP ;
   94: 
   95: : -zeros ( addr u -- addr' u' )
   96:   BEGIN  dup  WHILE  1- 2dup + c@ '0 <>  UNTIL  1+  THEN ;
   97: 
   98: : f$ ( f -- n )  scratch represent 0=
   99:   IF  2drop  scratch 3 min type  rdrop  EXIT  THEN
  100:   IF  '- emit  THEN ;
  101: 
  102: : f.  ( r -- ) \ float-ext f-dot
  103: \G Display (the floating-point number) @i{r} without exponent,
  104: \G followed by a space.
  105:   f$ dup >r 0<=
  106:   IF    '0 emit
  107:   ELSE  scratch r@ min type  r@ precision - zeros  THEN
  108:   '. emit r@ negate zeros
  109:   scratch r> 0 max /string 0 max -zeros type space ;
  110: \ I'm afraid this does not really implement ansi semantics wrt precision.
  111: \ Shouldn't precision indicate the number of places shown after the point?
  112: 
  113: \ Why do you think so? ANS Forth appears ambiguous on this point. -anton.
  114: 
  115: : fe. ( r -- ) \ float-ext f-e-dot
  116: \G Display @i{r} using engineering notation (with exponent dividable
  117: \G by 3), followed by a space.
  118:   f$ 1- s>d 3 fm/mod 3 * >r 1+ >r
  119:   scratch r@ tuck min tuck - >r type r> zeros
  120:   '. emit scratch r> /string type
  121:   'E emit r> . ;
  122: 
  123: : fs. ( r -- ) \ float-ext f-s-dot
  124: \G Display @i{r} using scientific notation (with exponent), followed
  125: \G by a space.
  126:   f$ 1-
  127:   scratch over c@ emit '. emit 1 /string type
  128:   'E emit . ;
  129: 
  130: require debugs.fs
  131: 
  132: : sfnumber ( c-addr u -- r true | false )
  133:     2dup [CHAR] e scan ( c-addr u c-addr2 u2 )
  134:     dup 0=
  135:     IF
  136: 	2drop 2dup [CHAR] E scan ( c-addr u c-addr3 u3 )
  137:     THEN
  138:     nip
  139:     IF
  140: 	>float
  141:     ELSE
  142: 	2drop false
  143:     THEN ;
  144: 
  145: :noname ( c-addr u -- )
  146:     2dup sfnumber
  147:     IF
  148: 	2drop POSTPONE FLiteral
  149:     ELSE
  150: 	defers compiler-notfound
  151:     ENDIF ;
  152: IS compiler-notfound
  153: 
  154: :noname ( c-addr u -- r )
  155:     2dup sfnumber
  156:     IF
  157: 	2drop
  158:     ELSE
  159: 	defers interpreter-notfound
  160:     ENDIF ;
  161: IS interpreter-notfound
  162: 
  163: : fvariable ( "name" -- ) \ float f-variable
  164:     Create 0.0E0 f, ;
  165:     \ does> ( -- f-addr )
  166: 
  167: 1.0e0 fasin 2.0e0 f* fconstant pi ( -- r ) \ gforth
  168: \G @code{Fconstant} -- @i{r} is the value pi; the ratio of a circle's area
  169: \G to its diameter.
  170: 
  171: : f2* ( r1 -- r2 ) \ gforth
  172:     \G Multiply @i{r1} by 2.0e0
  173:     2.0e0 f* ;
  174: 
  175: : f2/ ( r1 -- r2 ) \ gforth
  176:     \G Multiply @i{r1} by 0.5e0
  177:     0.5e0 f* ;
  178: 
  179: : 1/f ( r1 -- r2 ) \ gforth
  180:     \G Divide 1.0e0 by @i{r1}.
  181:     1.0e0 fswap f/ ;
  182: 
  183: get-current environment-wordlist set-current
  184: 1.7976931348623157e308 FConstant max-float
  185: set-current
  186: 
  187: \ We now have primitives for these, so we need not define them
  188: 
  189: \ : falog ( f -- 10^f )  [ 10.0e0 fln ] FLiteral f* fexp ;
  190: 
  191: \ : fsinh    fexpm1 fdup fdup 1.0e0 f+ f/ f+ f2/ ;
  192: \ : fcosh    fexp fdup 1/f f+ f2/ ;
  193: \ : ftanh    f2* fexpm1 fdup 2.0e0 f+ f/ ;
  194: 
  195: \ : fatanh   fdup f0< >r fabs 1.0e0 fover f- f/  f2* flnp1 f2/
  196: \            r> IF  fnegate  THEN ;
  197: \ : facosh   fdup fdup f* 1.0e0 f- fsqrt f+ fln ;
  198: \ : fasinh   fdup fdup f* 1.0e0 f+ fsqrt f/ fatanh ;
  199: 
  200: : f~abs ( r1 r2 r3 -- flag ) \ gforth
  201:     \G Approximate equality with absolute error: |r1-r2|<r3.
  202:     frot frot f- fabs fswap f< ;
  203: 
  204: : f~rel ( r1 r2 r3 -- flag ) \ gforth
  205:     \G Approximate equality with relative error: |r1-r2|<r3*|r1+r2|.
  206: 	frot frot fover fabs fover fabs f+ frot frot
  207: 	f- fabs frot frot f* f< ;
  208: 
  209: : f~ ( r1 r2 r3 -- flag ) \ float-ext f-proximate
  210:     \G ANS Forth medley for comparing r1 and r2 for equality: r3>0:
  211:     \G @code{f~abs}; r3=0: bitwise comparison; r3<0: @code{fnegate f~rel}.
  212:     fdup f0=
  213:     IF \ bitwise comparison
  214: 	fp@ float+ 1 floats over float+ over str=
  215: 	fdrop fdrop fdrop
  216: 	EXIT
  217:     THEN
  218:     fdup f0>
  219:     IF
  220: 	f~abs
  221:     ELSE
  222: 	fnegate f~rel
  223:     THEN ;