1 \ @(#) floats.fth 98/02/26 1.4 17:51:40
\r
2 \ High Level Forth support for Floating Point
\r
4 \ Author: Phil Burk and Darren Gibbs
\r
5 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\r
7 \ The pForth software code is dedicated to the public domain,
\r
8 \ and any third party may reproduce, distribute and modify
\r
9 \ the pForth software code or any derivative works thereof
\r
10 \ without any compensation or license. The pForth software
\r
11 \ code is provided on an "as is" basis without any warranty
\r
12 \ of any kind, including, without limitation, the implied
\r
13 \ warranties of merchantability and fitness for a particular
\r
14 \ purpose and their equivalents under the laws of any jurisdiction.
\r
16 \ 19970702 PLB Drop 0.0 in REPRESENT to fix 0.0 F.
\r
17 \ 19980220 PLB Added FG. , fixed up large and small formatting
\r
18 \ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix 0.0 F. (!!!)
\r
19 \ Fixed F~ by using (F.EXACTLY)
\r
21 ANEW TASK-FLOATS.FTH
\r
23 : FALIGNED ( addr -- a-addr )
\r
29 : FALIGN ( -- , align DP )
\r
33 \ account for size of create when aligning floats
\r
35 create fp-create-size
\r
36 fp-create-size swap - constant CREATE_SIZE
\r
38 : FALIGN.CREATE ( -- , align DP for float after CREATE )
\r
46 : FCREATE ( <name> -- , create with float aligned data )
\r
51 : FVARIABLE ( <name> -- ) ( F: -- )
\r
52 FCREATE 1 floats allot
\r
56 FCREATE here 1 floats allot f!
\r
60 : F0SP ( -- ) ( F: ? -- )
\r
61 fdepth 0 max 0 ?DO fdrop LOOP
\r
64 \ Convert between single precision and floating point
\r
65 : S>F ( s -- ) ( F: -- r )
\r
68 : F>S ( -- s ) ( F: r -- )
\r
72 : (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells }
\r
74 fsize cell 1- + cell 1- invert and \ round up to nearest multiple of stack size
\r
75 cell / -> fcells ( number of cells per float )
\r
76 \ make room on data stack for floats data
\r
81 \ compare bit representation
\r
84 caddr1 fsize caddr2 fsize compare 0=
\r
85 >r fcells 2* 0 ?DO drop LOOP r> \ drop float bits
\r
88 : F~ ( -0- flag ) ( r1 r2 r3 -f- )
\r
91 frot frot ( -- r3 r1 r2 )
\r
92 fover fover ( -- r3 r1 r2 r1 r2 )
\r
93 f- fabs ( -- r3 r1 r2 |r1-r2| )
\r
94 frot frot ( -- r3 |r1-r2| r1 r2 )
\r
95 fabs fswap fabs f+ ( -- r3 |r1-r2| |r1|+|r2| )
\r
96 frot fabs f* ( -- |r1-r2| |r1|+|r2|*|r3| )
\r
102 (f.exactly) \ f- f0= \ 19980812 Used to cheat. Now actually compares bit patterns.
\r
104 frot frot ( -- r3 r1 r2 )
\r
105 f- fabs ( -- r3 |r1-r2| )
\r
111 \ FP Output --------------------------------------------------------
\r
112 fvariable FVAR-REP \ scratch var for represent
\r
113 : REPRESENT { c-addr u | n flag1 flag2 -- n flag1 flag2 , FLOATING } ( F: r -- )
\r
114 TRUE -> flag2 \ FIXME - need to check range
\r
120 fvar-rep f@ fabs fvar-rep f! \ absolute value
\r
127 \ fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F."
\r
128 c-addr u [char] 0 fill
\r
135 1 s>f f+ \ round up exponent
\r
138 \ ." REP - n = " n . cr
\r
139 \ normalize r to u digits
\r
141 10 s>f u n - s>f f** f*
\r
142 1 s>f 2 s>f f/ f+ \ round result
\r
144 \ convert float to double_int then convert to text
\r
146 \ ." REP - d = " over . dup . cr
\r
147 <# u 1- 0 ?DO # loop #s #> \ ( -- addr cnt )
\r
148 \ Adjust exponent if rounding caused number of digits to increase.
\r
149 \ For example from 9999 to 10000.
\r
157 variable FP-PRECISION
\r
159 \ Set maximum digits that are meaningful for the precision that we use.
\r
160 1 FLOATS 4 / 7 * constant FP_PRECISION_MAX
\r
162 : PRECISION ( -- u )
\r
165 : SET-PRECISION ( u -- )
\r
166 fp_precision_max min
\r
171 32 constant FP_REPRESENT_SIZE
\r
172 64 constant FP_OUTPUT_SIZE
\r
174 create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot \ used with REPRESENT
\r
175 create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot \ used to assemble final output
\r
176 variable FP-OUTPUT-PTR \ points into FP-OUTPUT-PAD
\r
178 : FP.HOLD ( char -- , add char to output )
\r
179 fp-output-ptr @ fp-output-pad 64 + <
\r
181 fp-output-ptr @ tuck c!
\r
187 : FP.APPEND { addr cnt -- , add string to output }
\r
190 addr i + c@ fp.hold
\r
194 : FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output )
\r
196 fp-output-ptr @ fp-output-pad u>
\r
197 fp-output-ptr @ 1- c@ [char] 0 =
\r
200 -1 fp-output-ptr +!
\r
204 : FP.APPEND.ZEROS ( numZeros -- )
\r
206 ?DO [char] 0 fp.hold
\r
210 : FP.MOVE.DECIMAL { n prec -- , append with decimal point shifted }
\r
211 fp-represent-pad n prec min fp.append
\r
212 n prec - fp.append.zeros
\r
214 fp-represent-pad n +
\r
215 prec n - 0 max fp.append
\r
218 : (EXP.) ( n -- addr cnt , convert exponent to two digit value )
\r
228 : FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- )
\r
231 : (FS.) ( -- addr cnt ) ( F: r -- , scientific notation )
\r
232 fp-output-pad fp-output-ptr ! \ setup pointer
\r
233 fp-represent-pad precision represent
\r
234 \ ." (FS.) - represent " fp-represent-pad precision type cr
\r
235 ( -- n flag1 flag2 )
\r
237 IF [char] - fp.hold
\r
239 1 precision fp.move.decimal
\r
241 1- (exp.) fp.append \ n
\r
244 s" <FP-OUT-OF-RANGE>" fp.append
\r
246 fp-output-pad fp-output-ptr @ over -
\r
249 : FS. ( F: r -- , scientific notation )
\r
253 : (FE.) ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- }
\r
254 fp-output-pad fp-output-ptr ! \ setup pointer
\r
255 fp-represent-pad precision represent
\r
256 ( -- n flag1 flag2 )
\r
258 IF [char] - fp.hold
\r
260 \ convert exponent to multiple of three
\r
262 n 1- s>d 3 fm/mod \ use floored divide
\r
264 1+ precision fp.move.decimal \ amount to move decimal point
\r
266 n3 (exp.) fp.append \ n
\r
269 s" <FP-OUT-OF-RANGE>" fp.append
\r
271 fp-output-pad fp-output-ptr @ over -
\r
274 : FE. ( F: r -- , engineering notation )
\r
278 : (FG.) ( F: r -- , normal or scientific ) { | n n3 ndiff -- }
\r
279 fp-output-pad fp-output-ptr ! \ setup pointer
\r
280 fp-represent-pad precision represent
\r
281 ( -- n flag1 flag2 )
\r
283 IF [char] - fp.hold
\r
285 \ compare n with precision to see whether we do scientific display
\r
288 IF \ use exponential notation
\r
289 1 precision fp.move.decimal
\r
290 fp.strip.trailing.zeros
\r
292 1- (exp.) fp.append \ n
\r
296 \ POSITIVE EXPONENT - place decimal point in middle
\r
297 precision fp.move.decimal
\r
299 \ NEGATIVE EXPONENT - use 0.000????
\r
301 \ output leading zeros
\r
302 negate fp.append.zeros
\r
303 fp-represent-pad precision fp.append
\r
305 fp.strip.trailing.zeros
\r
309 s" <FP-OUT-OF-RANGE>" fp.append
\r
311 fp-output-pad fp-output-ptr @ over -
\r
318 : (F.) ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- }
\r
319 fp-output-pad fp-output-ptr ! \ setup pointer
\r
320 fp-represent-pad \ place to put number
\r
321 fdup flog 1 s>f f+ f>s precision max
\r
322 fp_precision_max min dup -> prec'
\r
324 ( -- n flag1 flag2 )
\r
326 \ add '-' sign if negative
\r
327 IF [char] - fp.hold
\r
329 \ compare n with precision to see whether we must do scientific display
\r
330 dup fp_precision_max >
\r
331 IF \ use exponential notation
\r
332 1 precision fp.move.decimal
\r
333 fp.strip.trailing.zeros
\r
335 1- (exp.) fp.append \ n
\r
339 \ POSITIVE EXPONENT - place decimal point in middle
\r
340 prec' fp.move.decimal
\r
342 \ NEGATIVE EXPONENT - use 0.000????
\r
344 \ output leading zeros
\r
345 dup negate precision min
\r
347 fp-represent-pad precision rot + fp.append
\r
352 s" <FP-OUT-OF-RANGE>" fp.append
\r
354 fp-output-pad fp-output-ptr @ over -
\r
361 : F.S ( -- , print FP stack )
\r
368 fdepth i - 1- \ index of next float
\r
377 \ FP Input ----------------------------------------------------------
\r
378 variable FP-REQUIRE-E \ must we put an E in FP numbers?
\r
379 false fp-require-e ! \ violate ANSI !!
\r
381 : >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag }
\r
382 u 0= IF false exit THEN
\r
386 \ check for minus sign
\r
387 c-addr c@ [char] - = dup -> fsign
\r
388 c-addr c@ [char] + = OR
\r
389 IF 1 +-> c-addr -1 +-> u \ skip char
\r
392 \ convert first set of digits
\r
393 0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo
\r
396 \ convert optional second set of digits
\r
397 c-addr c@ [char] . =
\r
399 dlo dhi c-addr 1+ u' 1- dup -> nshift >number
\r
400 dup nshift - -> nshift
\r
401 -> u' -> c-addr -> dhi -> dlo
\r
406 c-addr c@ [char] E =
\r
407 c-addr c@ [char] e = OR
\r
409 1 +-> c-addr -1 +-> u' \ skip E char
\r
412 c-addr c@ [char] + = \ ignore + on exponent
\r
414 1 +-> c-addr -1 +-> u' \ skip char
\r
416 c-addr u' ((number?))
\r
423 true -> flag \ allow "1E"
\r
427 \ only require E field if this variable is true
\r
428 fp-require-e @ not -> flag
\r
431 \ convert double precision int to float
\r
435 10 s>f nshift s>f f** f* \ apply exponent
\r
444 3 constant NUM_TYPE_FLOAT \ possible return type for NUMBER?
\r
446 : (FP.NUMBER?) ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number )
\r
447 \ check to see if it is a valid float, if not use old (NUMBER?)
\r
450 drop NUM_TYPE_FLOAT
\r
456 defer fp.old.number?
\r
457 variable FP-IF-INIT
\r
459 : FP.TERM ( -- , deinstall fp conversion )
\r
462 what's fp.old.number? is number?
\r
467 : FP.INIT ( -- , install FP converion )
\r
469 what's number? is fp.old.number?
\r
470 ['] (fp.number?) is number?
\r
472 ." Floating point numeric conversion installed." cr
\r
476 if.forgotten fp.term
\r
481 23.8e-9 fconstant fsmall
\r
482 1.0 fsmall f- fconstant falmost1
\r
483 ." Should be 1.0 = " falmost1 f. cr
\r
485 : TSEGF ( r -f- , print in all formats )
\r
486 ." --------------------------------" cr
\r
489 fdup fs. 4 spaces fdup fe. 4 spaces
\r
490 fdup fg. 4 spaces fdup f. cr
\r
498 1.23456789e+22 tsegf
\r
499 0.927 fsin 1.234e+22 f* tsegf
\r