Annotation of gforth/float.fs, revision 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>