Annotation of gforth/float.fs, revision 1.14

1.1       anton       1: \ High level floating point                            14jan94py
                      2: 
1.6       pazsan      3: 1 cells 4 = [IF]
                      4: ' cells   Alias sfloats
                      5: ' cell+   Alias sfloat+
                      6: ' align   Alias sfalign
                      7: ' aligned Alias sfaligned
                      8: [ELSE]
1.8       pazsan      9: : sfloats  2* 2* ;
1.6       pazsan     10: : sfloat+  4 + ;
                     11: : sfaligned ( addr -- addr' )  3 + -4 and ;
                     12: : sfalign ( -- )  here dup sfaligned swap ?DO  bl c,  LOOP ;
                     13: [THEN]
                     14: 
                     15: 1 floats 8 = [IF]
                     16: ' floats   Alias dfloats
                     17: ' float+   Alias dfloat+
                     18: ' falign   Alias dfalign
                     19: ' faligned Alias dfaligned
                     20: [ELSE]
1.8       pazsan     21: : dfloats  2* 2* 2* ;
1.6       pazsan     22: : dfloat+  8 + ;
                     23: : dfaligned ( addr -- addr' )  7 + -8 and ;
                     24: : dfalign ( -- )  here dup dfaligned swap ?DO  bl c,  LOOP ;
                     25: [THEN]
                     26: 
1.1       anton      27: : f, ( f -- )  here 1 floats allot f! ;
                     28: 
                     29: : fconstant  ( r -- )
1.13      anton      30:     Create f,
                     31:     DOES> f@ ;
1.1       anton      32: 
                     33: : fdepth  ( -- n )  f0 @ fp@ - [ 1 floats ] Literal / ;
                     34: 
1.14    ! pazsan     35: : FLit ( -- r )  r> dup f@ float+ >r ;
        !            36: : FLiteral ( r -- )
        !            37:   BEGIN  here cell+ dup faligned <>  WHILE  postpone noop  REPEAT
        !            38:   postpone FLit  f, ;  immediate
1.1       anton      39: 
1.13      anton      40: &15 Value precision
1.1       anton      41: : set-precision  to precision ;
                     42: 
                     43: : scratch ( r -- addr len )
                     44:   pad precision - precision ;
                     45: 
                     46: : zeros ( n -- )   0 max 0 ?DO  '0 emit  LOOP ;
                     47: 
                     48: : -zeros ( addr u -- addr' u' )
                     49:   BEGIN  dup  WHILE  1- 2dup + c@ '0 <>  UNTIL  1+  THEN ;
                     50: 
1.4       pazsan     51: : f$ ( f -- n )  scratch represent 0=
                     52:   IF  2drop  scratch 3 min type  rdrop  EXIT  THEN
                     53:   IF  '- emit  THEN ;
                     54: 
                     55: : f.  ( r -- )  f$ dup >r 0<
                     56:   IF    '0 emit
1.1       anton      57:   ELSE  scratch r@ min type  r@ precision - zeros  THEN
                     58:   '. emit r@ negate zeros
                     59:   scratch r> 0 max /string 0 max -zeros type space ;
1.3       benschop   60: \ I'm afraid this does not really implement ansi semantics wrt precision.
                     61: \ Shouldn't precision indicate the number of places shown after the point?
1.1       anton      62: 
1.4       pazsan     63: : fe. ( r -- )  f$ 1- s>d 3 fm/mod 3 * >r 1+ >r
1.1       anton      64:   scratch r@ min type '. emit  scratch r> /string type
                     65:   'E emit r> . ;
                     66: 
1.4       pazsan     67: : fs. ( r -- )  f$ 1-
                     68:   scratch over c@ emit '. emit 1 /string type
                     69:   'E emit . ;
                     70: 
1.7       anton      71: : sfnumber ( c-addr u -- r / )
                     72:     2dup >float
                     73:     IF
                     74:        2drop state @
                     75:        IF
                     76:            postpone FLiteral
                     77:        THEN
                     78:     ELSE
                     79:        defers notfound
                     80:     THEN ;
1.1       anton      81: 
1.7       anton      82: ' sfnumber IS notfound
1.13      anton      83: 
                     84: : fvariable ( -- )
                     85:     Create 0e0 f, ;
                     86:     \ does> ( -- f-addr )
1.1       anton      87: 
                     88: 1e0 fasin 2e0 f* fconstant pi
1.6       pazsan     89: 
                     90: : f2*  2e0 f* ;
1.12      pazsan     91: : f2/  .5e0 f* ;
1.6       pazsan     92: : 1/f  1e0 fswap f/ ;
                     93: 
                     94: 
1.10      anton      95: \ We now have primitives for these, so we need not define them
1.6       pazsan     96: 
1.10      anton      97: \ : falog ( f -- 10^f )  [ 10e0 fln ] FLiteral f* fexp ;
                     98: 
                     99: \ : fsinh    fexpm1 fdup fdup 1e0 f+ f/ f+ f2/ ;
                    100: \ : fcosh    fexp fdup 1/f f+ f2/ ;
                    101: \ : ftanh    f2* fexpm1 fdup 2e0 f+ f/ ;
                    102: 
                    103: \ : fatanh   fdup f0< >r fabs 1e0 fover f- f/  f2* flnp1 f2/
                    104: \            r> IF  fnegate  THEN ;
                    105: \ : facosh   fdup fdup f* 1e0 f- fsqrt f+ fln ;
                    106: \ : fasinh   fdup fdup f* 1e0 f+ fsqrt f/ fatanh ;
1.9       pazsan    107: 
1.11      pazsan    108: : f~ ( f1 f2 f3 -- flag )  fdup f0= IF  fdrop f= EXIT  THEN
                    109:   fdup f0>   IF  frot frot f- fabs fswap
                    110:            ELSE  fnegate frot frot fover fabs fover fabs f+ frot frot
                    111:                  f- fabs frot frot f*  THEN  f< ;
                    112: 
1.9       pazsan    113: : f.s  ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0 
                    114:   ?DO  dup i - 1- floats fp@ + f@ f.  LOOP  drop ; 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>