Return to float.fs CVS log

Up to [gforth] / gforth

Major re-write of manual sections concerning text interpreter and
defining words. Much fine-tuning of other sections. The manual is
``nearly finished'' -- at least, all the major pieces of work that
I envisaged for the first mods (which were only going to take a
couple of weeks...). The manual has grown from 127 pages to 192
which is good news in terms of content but bad news in terms of the
time it takes to print out on my HP550C DeskJet.

Other changes are just tweaks to glossary entries.

    1: \ High level floating point                            14jan94py
    2: 
    3: \ Copyright (C) 1995,1997 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., 675 Mass Ave, Cambridge, MA 02139, 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 constant sfloat+ ( sf-addr1 -- sf-addr2 ) \ float-ext s-float-plus
   55: \G Increment @i{sf-addr1} by the number of address units corresponding to the size of
   56: \G a single-precision IEEE floating-point number, to give @i{sf-addr2}.""
   57: dofield: lastxt code-address! \ change the constant into a field
   58: 
   59: 1 dfloats constant dfloat+ ( df-addr1 -- df-addr2 ) \ float-ext d-float-plus
   60: \G Increment @i{df-addr1} by the number of address units corresponding to the size of
   61: \G a double-precision IEEE floating-point number, to give @i{df-addr2}.""
   62: dofield: lastxt code-address! \ change the constant into a field
   63: 
   64: : f, ( f -- ) \ gforth
   65:     \G Reserve data space for one floating-point number and store
   66:     \G @i{f} in the space.
   67:     here 1 floats allot f! ;
   68: 
   69: : fconstant  ( r "name" -- ) \ float
   70:     Create f,
   71: DOES> ( -- r )
   72:     f@ ;
   73: 
   74: : fdepth ( -- +n ) \ floating f-depth
   75:     \G @var{+n} is the current number of (floating-point) values on the
   76:     \G floating-point stack.
   77:     fp0 @ fp@ - [ 1 floats ] Literal / ;
   78: 
   79: : FLit ( -- r )  r> dup f@ float+ >r ;
   80: : FLiteral ( compilation r -- ; run-time -- r ) \ float
   81:     \G Compile appropriate code such that, at run-time, @var{r} is placed
   82:     \G on the (floating-point) stack. Interpretation semantics are undefined.
   83:     BEGIN  here cell+ dup faligned <>  WHILE  postpone noop  REPEAT
   84:     postpone FLit  f, ;  immediate
   85: 
   86: &15 Value precision ( -- u ) \ floating-ext
   87: \G @var{u} is the number of significant digits currently used by
   88: \G @code{F.} @code{FE.} and @code{FS.} 
   89: : set-precision ( u -- ) \ floating-ext
   90:     \G Set the number of significant digits currently used by
   91:     \G @code{F.} @code{FE.} and @code{FS.} to @var{u}.
   92:     to precision ;
   93: 
   94: : scratch ( r -- addr len )
   95:   pad precision - precision ;
   96: 
   97: : zeros ( n -- )   0 max 0 ?DO  '0 emit  LOOP ;
   98: 
   99: : -zeros ( addr u -- addr' u' )
  100:   BEGIN  dup  WHILE  1- 2dup + c@ '0 <>  UNTIL  1+  THEN ;
  101: 
  102: : f$ ( f -- n )  scratch represent 0=
  103:   IF  2drop  scratch 3 min type  rdrop  EXIT  THEN
  104:   IF  '- emit  THEN ;
  105: 
  106: : f.  ( r -- ) \ floating-ext f-dot
  107: \G Display (the floating-point number) @var{r} using fixed-point notation,
  108: \G followed by a space.
  109:   f$ dup >r 0<
  110:   IF    '0 emit
  111:   ELSE  scratch r@ min type  r@ precision - zeros  THEN
  112:   '. emit r@ negate zeros
  113:   scratch r> 0 max /string 0 max -zeros type space ;
  114: \ I'm afraid this does not really implement ansi semantics wrt precision.
  115: \ Shouldn't precision indicate the number of places shown after the point?
  116: 
  117: : fe. ( r -- ) \ floating-ext f-e-dot
  118: \G Display @var{r} using engineering notation, followed by a space.
  119:   f$ 1- s>d 3 fm/mod 3 * >r 1+ >r
  120:   scratch r@ min type '. emit  scratch r> /string type
  121:   'E emit r> . ;
  122: 
  123: : fs. ( r -- ) \ floating-ext f-s-dot
  124: \G Display @var{r} using scientific notation, followed by a space.
  125:   f$ 1-
  126:   scratch over c@ emit '. emit 1 /string type
  127:   'E emit . ;
  128: 
  129: require debugs.fs
  130: 
  131: : sfnumber ( c-addr u -- r true | false )
  132:     2dup [CHAR] e scan ( c-addr u c-addr2 u2 )
  133:     dup 0=
  134:     IF
  135: 	2drop 2dup [CHAR] E scan ( c-addr u c-addr3 u3 )
  136:     THEN
  137:     nip
  138:     IF
  139: 	>float
  140:     ELSE
  141: 	2drop false
  142:     THEN ;
  143: 
  144: :noname ( c-addr u -- )
  145:     2dup sfnumber
  146:     IF
  147: 	2drop POSTPONE FLiteral
  148:     ELSE
  149: 	defers compiler-notfound
  150:     ENDIF ;
  151: IS compiler-notfound
  152: 
  153: :noname ( c-addr u -- r )
  154:     2dup sfnumber
  155:     IF
  156: 	2drop
  157:     ELSE
  158: 	defers interpreter-notfound
  159:     ENDIF ;
  160: IS interpreter-notfound
  161: 
  162: : fvariable ( "name" -- ) \ float
  163:     Create 0.0E0 f, ;
  164:     \ does> ( -- f-addr )
  165: 
  166: 1.0e0 fasin 2.0e0 f* fconstant pi ( -- r ) \ gforth
  167: \G FCONSTANT: @var{r} is the value pi; the ratio of a circle's area
  168: \G to its diameter.
  169: 
  170: : f2* ( r1 -- r2 ) \ gforth
  171:     \G Multiply @var{r1} by 2.0e0
  172:     2.0e0 f* ;
  173: 
  174: : f2/ ( r1 -- r2 ) \ gforth
  175:     \G Multiply @var{r1} by 0.5e0
  176:     0.5e0 f* ;
  177: 
  178: : 1/f ( r1 -- r2 ) \ gforth
  179:     \G Divide 1.0e0 by @var{r1}.
  180:     1.0e0 fswap f/ ;
  181: 
  182: 
  183: \ We now have primitives for these, so we need not define them
  184: 
  185: \ : falog ( f -- 10^f )  [ 10.0e0 fln ] FLiteral f* fexp ;
  186: 
  187: \ : fsinh    fexpm1 fdup fdup 1.0e0 f+ f/ f+ f2/ ;
  188: \ : fcosh    fexp fdup 1/f f+ f2/ ;
  189: \ : ftanh    f2* fexpm1 fdup 2.0e0 f+ f/ ;
  190: 
  191: \ : fatanh   fdup f0< >r fabs 1.0e0 fover f- f/  f2* flnp1 f2/
  192: \            r> IF  fnegate  THEN ;
  193: \ : facosh   fdup fdup f* 1.0e0 f- fsqrt f+ fln ;
  194: \ : fasinh   fdup fdup f* 1.0e0 f+ fsqrt f/ fatanh ;
  195: 
  196: \ !! factor out parts
  197: : f~ ( f1 f2 f3 -- flag ) \ float-ext
  198:     fdup f0=
  199:     IF
  200: 	fdrop f= EXIT
  201:     THEN
  202:     fdup f0>
  203:     IF
  204: 	frot frot f- fabs fswap
  205:     ELSE
  206: 	fnegate frot frot fover fabs fover fabs f+ frot frot
  207: 	f- fabs frot frot f*
  208:     THEN
  209:     f< ;
  210: 
  211: : f.s ( -- ) \ gforth f-dot-s
  212:     \G Display the number of items on the floating-point stack,
  213:     \G followed by a list of the items; TOS is the right-most item.
  214:     ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0 
  215:     ?DO  dup i - 1- floats fp@ + f@ f.  LOOP  drop ;