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>