Return to float.fs CVS log

Up to [gforth] / gforth

make 0e0 f. print one digit

    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: \ I'm afraid this does not really implement ansi semantics wrt precision.
   45: \ Shouldn't precision indicate the number of places shown after the point?
   46: 
   47: : fe. ( r -- )  scratch represent 0=
   48:   IF  2drop  scratch 3 min type  EXIT  THEN
   49:   IF  '- emit  THEN  1- s>d 3 fm/mod 3 * >r 1+ >r
   50:   scratch r@ min type '. emit  scratch r> /string type
   51:   'E emit r> . ;
   52: 
   53: : fs. ( r -- )  scratch represent 0=
   54:   IF  2drop  scratch 3 min type  EXIT  THEN
   55:   IF  '- emit  THEN  1- >r
   56:   scratch 1 min type '. emit  scratch 1 /string type
   57:   'E emit r> . ;
   58: 
   59: : fnumber ( string -- r / )  dup count >float 0=
   60:   IF  defers notfound  ELSE  drop  THEN ;
   61: 
   62: ' fnumber IS notfound
   63: 
   64: 1e0 fasin 2e0 f* fconstant pi