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