1 \ @(#) floats.fth 98/02/26 1.4 17:51:40
2 \ High Level Forth support for Floating Point
4 \ Author: Phil Burk and Darren Gibbs
5 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
7 \ Permission to use, copy, modify, and/or distribute this
8 \ software for any purpose with or without fee is hereby granted.
10 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
11 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
12 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
13 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
14 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
15 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
16 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
17 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
19 \ 19970702 PLB Drop 0.0 in REPRESENT to fix 0.0 F.
20 \ 19980220 PLB Added FG. , fixed up large and small formatting
21 \ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix 0.0 F. (!!!)
22 \ Fixed F~ by using (F.EXACTLY)
26 : FALIGNED ( addr -- a-addr )
32 : FALIGN ( -- , align DP )
36 \ account for size of create when aligning floats
39 fp-create-size swap - constant CREATE_SIZE
41 : FALIGN.CREATE ( -- , align DP for float after CREATE )
49 : FCREATE ( <name> -- , create with float aligned data )
54 : FVARIABLE ( <name> -- ) ( F: -- )
55 FCREATE 1 floats allot
59 FCREATE here 1 floats allot f!
63 : F0SP ( -- ) ( F: ? -- )
64 fdepth 0 max 0 ?DO fdrop LOOP
67 \ Convert between single precision and floating point
68 : S>F ( s -- ) ( F: -- r )
71 : F>S ( -- s ) ( F: r -- )
75 : (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells }
77 fsize cell 1- + cell 1- invert and \ round up to nearest multiple of stack size
78 cell / -> fcells ( number of cells per float )
79 \ make room on data stack for floats data
84 \ compare bit representation
87 caddr1 fsize caddr2 fsize compare 0=
88 >r fcells 2* 0 ?DO drop LOOP r> \ drop float bits
91 : F~ ( -0- flag ) ( r1 r2 r3 -f- )
94 frot frot ( -- r3 r1 r2 )
95 fover fover ( -- r3 r1 r2 r1 r2 )
96 f- fabs ( -- r3 r1 r2 |r1-r2| )
97 frot frot ( -- r3 |r1-r2| r1 r2 )
98 fabs fswap fabs f+ ( -- r3 |r1-r2| |r1|+|r2| )
99 frot fabs f* ( -- |r1-r2| |r1|+|r2|*|r3| )
105 (f.exactly) \ f- f0= \ 19980812 Used to cheat. Now actually compares bit patterns.
107 frot frot ( -- r3 r1 r2 )
108 f- fabs ( -- r3 |r1-r2| )
114 \ FP Output --------------------------------------------------------
115 fvariable FVAR-REP \ scratch var for represent
116 : REPRESENT { c-addr u | n flag1 flag2 -- n flag1 flag2 , FLOATING } ( F: r -- )
117 TRUE -> flag2 \ FIXME - need to check range
123 fvar-rep f@ fabs fvar-rep f! \ absolute value
130 \ fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F."
131 c-addr u [char] 0 fill
138 1 s>f f+ \ round up exponent
141 \ ." REP - n = " n . cr
142 \ normalize r to u digits
144 10 s>f u n - s>f f** f*
145 1 s>f 2 s>f f/ f+ \ round result
147 \ convert float to double_int then convert to text
149 \ ." REP - d = " over . dup . cr
150 <# u 1- 0 ?DO # loop #s #> \ ( -- addr cnt )
151 \ Adjust exponent if rounding caused number of digits to increase.
152 \ For example from 9999 to 10000.
160 variable FP-PRECISION
162 \ Set maximum digits that are meaningful for the precision that we use.
163 1 FLOATS 4 / 7 * constant FP_PRECISION_MAX
168 : SET-PRECISION ( u -- )
174 32 constant FP_REPRESENT_SIZE
175 64 constant FP_OUTPUT_SIZE
177 create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot \ used with REPRESENT
178 create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot \ used to assemble final output
179 variable FP-OUTPUT-PTR \ points into FP-OUTPUT-PAD
181 : FP.HOLD ( char -- , add char to output )
182 fp-output-ptr @ fp-output-pad 64 + <
184 fp-output-ptr @ tuck c!
190 : FP.APPEND { addr cnt -- , add string to output }
197 : FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output )
199 fp-output-ptr @ fp-output-pad u>
200 fp-output-ptr @ 1- c@ [char] 0 =
207 : FP.APPEND.ZEROS ( numZeros -- )
213 : FP.MOVE.DECIMAL { n prec -- , append with decimal point shifted }
214 fp-represent-pad n prec min fp.append
215 n prec - fp.append.zeros
218 prec n - 0 max fp.append
221 : (EXP.) ( n -- addr cnt , convert exponent to two digit value )
231 : FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- )
234 : (FS.) ( -- addr cnt ) ( F: r -- , scientific notation )
235 fp-output-pad fp-output-ptr ! \ setup pointer
236 fp-represent-pad precision represent
237 \ ." (FS.) - represent " fp-represent-pad precision type cr
242 1 precision fp.move.decimal
244 1- (exp.) fp.append \ n
247 s" <FP-OUT-OF-RANGE>" fp.append
249 fp-output-pad fp-output-ptr @ over -
252 : FS. ( F: r -- , scientific notation )
256 : (FE.) ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- }
257 fp-output-pad fp-output-ptr ! \ setup pointer
258 fp-represent-pad precision represent
263 \ convert exponent to multiple of three
265 n 1- s>d 3 fm/mod \ use floored divide
267 1+ precision fp.move.decimal \ amount to move decimal point
269 n3 (exp.) fp.append \ n
272 s" <FP-OUT-OF-RANGE>" fp.append
274 fp-output-pad fp-output-ptr @ over -
277 : FE. ( F: r -- , engineering notation )
281 : (FG.) ( F: r -- , normal or scientific ) { | n n3 ndiff -- }
282 fp-output-pad fp-output-ptr ! \ setup pointer
283 fp-represent-pad precision represent
288 \ compare n with precision to see whether we do scientific display
291 IF \ use exponential notation
292 1 precision fp.move.decimal
293 fp.strip.trailing.zeros
295 1- (exp.) fp.append \ n
299 \ POSITIVE EXPONENT - place decimal point in middle
300 precision fp.move.decimal
302 \ NEGATIVE EXPONENT - use 0.000????
304 \ output leading zeros
305 negate fp.append.zeros
306 fp-represent-pad precision fp.append
308 fp.strip.trailing.zeros
312 s" <FP-OUT-OF-RANGE>" fp.append
314 fp-output-pad fp-output-ptr @ over -
321 : (F.) ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- }
322 fp-output-pad fp-output-ptr ! \ setup pointer
323 fp-represent-pad \ place to put number
324 fdup flog 1 s>f f+ f>s precision max
325 fp_precision_max min dup -> prec'
329 \ add '-' sign if negative
332 \ compare n with precision to see whether we must do scientific display
333 dup fp_precision_max >
334 IF \ use exponential notation
335 1 precision fp.move.decimal
336 fp.strip.trailing.zeros
338 1- (exp.) fp.append \ n
342 \ POSITIVE EXPONENT - place decimal point in middle
343 prec' fp.move.decimal
345 \ NEGATIVE EXPONENT - use 0.000????
347 \ output leading zeros
348 dup negate precision min
350 fp-represent-pad precision rot + fp.append
355 s" <FP-OUT-OF-RANGE>" fp.append
357 fp-output-pad fp-output-ptr @ over -
364 : F.S ( -- , print FP stack )
371 fdepth i - 1- \ index of next float
380 \ FP Input ----------------------------------------------------------
381 variable FP-REQUIRE-E \ must we put an E in FP numbers?
382 false fp-require-e ! \ violate ANSI !!
384 : >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag }
385 u 0= IF false exit THEN
389 \ check for minus sign
390 c-addr c@ [char] - = dup -> fsign
391 c-addr c@ [char] + = OR
392 IF 1 +-> c-addr -1 +-> u \ skip char
395 \ convert first set of digits
396 0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo
399 \ convert optional second set of digits
402 dlo dhi c-addr 1+ u' 1- dup -> nshift >number
403 dup nshift - -> nshift
404 -> u' -> c-addr -> dhi -> dlo
410 c-addr c@ [char] e = OR
412 1 +-> c-addr -1 +-> u' \ skip E char
415 c-addr c@ [char] + = \ ignore + on exponent
417 1 +-> c-addr -1 +-> u' \ skip char
419 c-addr u' ((number?))
426 true -> flag \ allow "1E"
430 \ only require E field if this variable is true
431 fp-require-e @ not -> flag
434 \ convert double precision int to float
438 10 s>f nshift s>f f** f* \ apply exponent
447 3 constant NUM_TYPE_FLOAT \ possible return type for NUMBER?
449 : (FP.NUMBER?) ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number )
450 \ check to see if it is a valid float, if not use old (NUMBER?)
462 : FP.TERM ( -- , deinstall fp conversion )
465 what's fp.old.number? is number?
470 : FP.INIT ( -- , install FP converion )
472 what's number? is fp.old.number?
473 ['] (fp.number?) is number?
475 ." Floating point numeric conversion installed." cr
484 23.8e-9 fconstant fsmall
485 1.0 fsmall f- fconstant falmost1
486 ." Should be 1.0 = " falmost1 f. cr
488 : TSEGF ( r -f- , print in all formats )
489 ." --------------------------------" cr
492 fdup fs. 4 spaces fdup fe. 4 spaces
493 fdup fg. 4 spaces fdup f. cr
502 0.927 fsin 1.234e+22 f* tsegf