Return to float.fs CVS log

Up to [gforth] / gforth

Initial revision

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