Return to float.fs CVS log

Up to [gforth] / gforth

local variables
rewrote primitives2c.el in Forth (prims2x.el)
various small changes
Added Files:
 	from-cut-here gforth.el gforth.texi glocals.fs gray.fs
 	locals-test.fs prims2x.fs

    1: \ High level floating point                            14jan94py
    2: 
    3: : faligned ( addr -- f-addr )
    4:   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
    5: 
    6: : falign ( -- )
    7:   here dup aligned swap
    8:   ?DO  bl c,  LOOP ;
    9: 
   10: : f, ( f -- )  here 1 floats allot f! ;
   11: 
   12: \ !! have create produce faligned pfas
   13: : fconstant  ( r -- )
   14:   Create falign f,
   15:   DOES>  faligned f@ ;
   16: 
   17: : fvariable
   18:   Create falign 0 f,
   19:   DOES>  faligned ;
   20: 
   21: : fdepth  ( -- n )  f0 @ fp@ - [ 1 floats ] Literal / ;
   22: 
   23: : FLit ( -- r )  r> faligned dup f@ float+ >r ;
   24: : FLiteral ( r -- )  postpone FLit  falign f, ;  immediate
   25: 
   26: &16 Value precision
   27: : set-precision  to precision ;
   28: 
   29: : scratch ( r -- addr len )
   30:   pad precision - precision ;
   31: 
   32: : zeros ( n -- )   0 max 0 ?DO  '0 emit  LOOP ;
   33: 
   34: : -zeros ( addr u -- addr' u' )
   35:   BEGIN  dup  WHILE  1- 2dup + c@ '0 <>  UNTIL  1+  THEN ;
   36: 
   37: : f.  ( r -- )  scratch represent 0=
   38:   IF  2drop  scratch 3 min type  EXIT  THEN
   39:   IF  '- emit  THEN  dup >r 0<
   40:   IF  '0 emit
   41:   ELSE  scratch r@ min type  r@ precision - zeros  THEN
   42:   '. emit r@ negate zeros
   43:   scratch r> 0 max /string 0 max -zeros type space ;
   44: 
   45: : fe. ( r -- )  scratch represent 0=
   46:   IF  2drop  scratch 3 min type  EXIT  THEN
   47:   IF  '- emit  THEN  1- s>d 3 fm/mod 3 * >r 1+ >r
   48:   scratch r@ min type '. emit  scratch r> /string type
   49:   'E emit r> . ;
   50: 
   51: : fs. ( r -- )  scratch represent 0=
   52:   IF  2drop  scratch 3 min type  EXIT  THEN
   53:   IF  '- emit  THEN  1- >r
   54:   scratch 1 min type '. emit  scratch 1 /string type
   55:   'E emit r> . ;
   56: 
   57: : fnumber ( string -- r / )  dup count >float 0=
   58:   IF  defers notfound  ELSE  drop  THEN ;
   59: 
   60: ' fnumber IS notfound
   61: 
   62: 1e0 fasin 2e0 f* fconstant pi