Annotation of gforth/float.fs, revision 1.4
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 ( -- )
1.4 ! pazsan 7: here dup faligned 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 -- )
1.4 ! pazsan 14: falign here f, Create A,
! 15: DOES> @ f@ ;
1.1 anton 16:
17: : fvariable
1.4 ! pazsan 18: falign here 0. d>f f, AConstant ;
1.1 anton 19:
20: : fdepth ( -- n ) f0 @ fp@ - [ 1 floats ] Literal / ;
21:
22: : FLit ( -- r ) r> faligned dup f@ float+ >r ;
23: : FLiteral ( r -- ) postpone FLit falign f, ; immediate
24:
25: &16 Value precision
26: : set-precision to precision ;
27:
28: : scratch ( r -- addr len )
29: pad precision - precision ;
30:
31: : zeros ( n -- ) 0 max 0 ?DO '0 emit LOOP ;
32:
33: : -zeros ( addr u -- addr' u' )
34: BEGIN dup WHILE 1- 2dup + c@ '0 <> UNTIL 1+ THEN ;
35:
1.4 ! pazsan 36: : f$ ( f -- n ) scratch represent 0=
! 37: IF 2drop scratch 3 min type rdrop EXIT THEN
! 38: IF '- emit THEN ;
! 39:
! 40: : f. ( r -- ) f$ dup >r 0<
! 41: IF '0 emit
1.1 anton 42: ELSE scratch r@ min type r@ precision - zeros THEN
43: '. emit r@ negate zeros
44: scratch r> 0 max /string 0 max -zeros type space ;
1.3 benschop 45: \ I'm afraid this does not really implement ansi semantics wrt precision.
46: \ Shouldn't precision indicate the number of places shown after the point?
1.1 anton 47:
1.4 ! pazsan 48: : fe. ( r -- ) f$ 1- s>d 3 fm/mod 3 * >r 1+ >r
1.1 anton 49: scratch r@ min type '. emit scratch r> /string type
50: 'E emit r> . ;
51:
1.4 ! pazsan 52: : fs. ( r -- ) f$ 1-
! 53: scratch over c@ emit '. emit 1 /string type
! 54: 'E emit . ;
! 55:
! 56: : fnumber ( string -- r / )
! 57: ?dup IF dup count >float 0=
! 58: IF defers notfound
! 59: ELSE drop state @
! 60: IF postpone FLiteral THEN THEN THEN ;
1.1 anton 61:
62: ' fnumber IS notfound
63:
64: 1e0 fasin 2e0 f* fconstant pi
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>