Return to float.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/float.fs, revision 1.3

1.1       anton       1: \ High level floating point                            14jan94py
                      2: 
                      3: : faligned ( addr -- f-addr )
                      4:   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
                      5: 
1.2       anton       6: : falign ( -- )
                      7:   here dup aligned swap
1.1       anton       8:   ?DO  bl c,  LOOP ;
                      9: 
                     10: : f, ( f -- )  here 1 floats allot f! ;
                     11: 
1.2       anton      12: \ !! have create produce faligned pfas
1.1       anton      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
1.3     ! benschop   39:   IF  '- emit  THEN  dup >r 0<=
1.1       anton      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 ;
1.3     ! benschop   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?
1.1       anton      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