Annotation of gforth/float.fs, revision 1.1.1.1

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: 
                      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

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