-\ @(#) floats.fth 98/02/26 1.4 17:51:40\r
-\ High Level Forth support for Floating Point\r
-\\r
-\ Author: Phil Burk and Darren Gibbs\r
-\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
-\\r
-\ The pForth software code is dedicated to the public domain,\r
-\ and any third party may reproduce, distribute and modify\r
-\ the pForth software code or any derivative works thereof\r
-\ without any compensation or license. The pForth software\r
-\ code is provided on an "as is" basis without any warranty\r
-\ of any kind, including, without limitation, the implied\r
-\ warranties of merchantability and fitness for a particular\r
-\ purpose and their equivalents under the laws of any jurisdiction.\r
-\\r
-\ 19970702 PLB Drop 0.0 in REPRESENT to fix 0.0 F.\r
-\ 19980220 PLB Added FG. , fixed up large and small formatting\r
-\ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix 0.0 F. (!!!)\r
-\ Fixed F~ by using (F.EXACTLY)\r
-\r
-ANEW TASK-FLOATS.FTH\r
-\r
-: FALIGNED ( addr -- a-addr )\r
- 1 floats 1- +\r
- 1 floats /\r
- 1 floats *\r
-;\r
-\r
-: FALIGN ( -- , align DP )\r
- dp @ faligned dp !\r
-;\r
-\r
-\ account for size of create when aligning floats\r
-here\r
-create fp-create-size\r
-fp-create-size swap - constant CREATE_SIZE\r
-\r
-: FALIGN.CREATE ( -- , align DP for float after CREATE )\r
- dp @\r
- CREATE_SIZE +\r
- faligned\r
- CREATE_SIZE -\r
- dp !\r
-;\r
-\r
-: FCREATE ( <name> -- , create with float aligned data )\r
- falign.create\r
- CREATE\r
-;\r
-\r
-: FVARIABLE ( <name> -- ) ( F: -- )\r
- FCREATE 1 floats allot\r
-;\r
-\r
-: FCONSTANT\r
- FCREATE here 1 floats allot f! \r
- DOES> f@ \r
-;\r
-\r
-: F0SP ( -- ) ( F: ? -- )\r
- fdepth 0 max 0 ?DO fdrop LOOP \r
-;\r
-\r
-\ Convert between single precision and floating point\r
-: S>F ( s -- ) ( F: -- r )\r
- s>d d>f\r
-;\r
-: F>S ( -- s ) ( F: r -- )\r
- f>d d>s\r
-; \r
-\r
-: (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells }\r
- 1 floats -> fsize\r
- fsize cell 1- + cell 1- invert and \ round up to nearest multiple of stack size\r
- cell / -> fcells ( number of cells per float )\r
-\ make room on data stack for floats data\r
- fcells 0 ?DO 0 LOOP\r
- sp@ -> caddr1\r
- fcells 0 ?DO 0 LOOP\r
- sp@ -> caddr2\r
-\ compare bit representation\r
- caddr1 f!\r
- caddr2 f!\r
- caddr1 fsize caddr2 fsize compare 0= \r
- >r fcells 2* 0 ?DO drop LOOP r> \ drop float bits\r
-;\r
-\r
-: F~ ( -0- flag ) ( r1 r2 r3 -f- )\r
- fdup F0<\r
- IF\r
- frot frot ( -- r3 r1 r2 )\r
- fover fover ( -- r3 r1 r2 r1 r2 )\r
- f- fabs ( -- r3 r1 r2 |r1-r2| )\r
- frot frot ( -- r3 |r1-r2| r1 r2 )\r
- fabs fswap fabs f+ ( -- r3 |r1-r2| |r1|+|r2| )\r
- frot fabs f* ( -- |r1-r2| |r1|+|r2|*|r3| )\r
- f<\r
- ELSE\r
- fdup f0=\r
- IF\r
- fdrop\r
- (f.exactly) \ f- f0= \ 19980812 Used to cheat. Now actually compares bit patterns.\r
- ELSE\r
- frot frot ( -- r3 r1 r2 )\r
- f- fabs ( -- r3 |r1-r2| )\r
- fswap f<\r
- THEN\r
- THEN\r
-;\r
-\r
-\ FP Output --------------------------------------------------------\r
-fvariable FVAR-REP \ scratch var for represent\r
-: REPRESENT { c-addr u | n flag1 flag2 -- n flag1 flag2 , FLOATING } ( F: r -- )\r
- TRUE -> flag2 \ FIXME - need to check range\r
- fvar-rep f!\r
-\\r
- fvar-rep f@ f0<\r
- IF\r
- -1 -> flag1\r
- fvar-rep f@ fabs fvar-rep f! \ absolute value\r
- ELSE\r
- 0 -> flag1\r
- THEN\r
-\\r
- fvar-rep f@ f0=\r
- IF\r
-\ fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F."\r
- c-addr u [char] 0 fill\r
- 0 -> n\r
- ELSE\r
- fvar-rep f@ \r
- flog\r
- fdup f0< not\r
- IF\r
- 1 s>f f+ \ round up exponent\r
- THEN\r
- f>s -> n \r
-\ ." REP - n = " n . cr\r
-\ normalize r to u digits\r
- fvar-rep f@\r
- 10 s>f u n - s>f f** f*\r
- 1 s>f 2 s>f f/ f+ \ round result\r
-\\r
-\ convert float to double_int then convert to text\r
- f>d\r
-\ ." REP - d = " over . dup . cr\r
- <# u 1- 0 ?DO # loop #s #> \ ( -- addr cnt )\r
-\ Adjust exponent if rounding caused number of digits to increase.\r
-\ For example from 9999 to 10000.\r
- u - +-> n \r
- c-addr u move\r
- THEN\r
-\\r
- n flag1 flag2\r
-;\r
-\r
-variable FP-PRECISION\r
-\r
-\ Set maximum digits that are meaningful for the precision that we use.\r
-1 FLOATS 4 / 7 * constant FP_PRECISION_MAX\r
-\r
-: PRECISION ( -- u )\r
- fp-precision @\r
-;\r
-: SET-PRECISION ( u -- )\r
- fp_precision_max min\r
- fp-precision !\r
-;\r
-7 set-precision\r
-\r
-32 constant FP_REPRESENT_SIZE\r
-64 constant FP_OUTPUT_SIZE\r
-\r
-create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot \ used with REPRESENT\r
-create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot \ used to assemble final output\r
-variable FP-OUTPUT-PTR \ points into FP-OUTPUT-PAD\r
-\r
-: FP.HOLD ( char -- , add char to output )\r
- fp-output-ptr @ fp-output-pad 64 + <\r
- IF\r
- fp-output-ptr @ tuck c!\r
- 1+ fp-output-ptr !\r
- ELSE\r
- drop\r
- THEN\r
-;\r
-: FP.APPEND { addr cnt -- , add string to output }\r
- cnt 0 max 0\r
- ?DO\r
- addr i + c@ fp.hold\r
- LOOP\r
-;\r
-\r
-: FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output )\r
- BEGIN\r
- fp-output-ptr @ fp-output-pad u>\r
- fp-output-ptr @ 1- c@ [char] 0 =\r
- and\r
- WHILE\r
- -1 fp-output-ptr +!\r
- REPEAT\r
-;\r
-\r
-: FP.APPEND.ZEROS ( numZeros -- )\r
- 0 max 0\r
- ?DO [char] 0 fp.hold\r
- LOOP\r
-;\r
-\r
-: FP.MOVE.DECIMAL { n prec -- , append with decimal point shifted }\r
- fp-represent-pad n prec min fp.append\r
- n prec - fp.append.zeros\r
- [char] . fp.hold\r
- fp-represent-pad n +\r
- prec n - 0 max fp.append\r
-;\r
-\r
-: (EXP.) ( n -- addr cnt , convert exponent to two digit value )\r
- dup abs 0\r
- <# # #s\r
- rot 0<\r
- IF [char] - HOLD\r
- ELSE [char] + hold\r
- THEN\r
- #>\r
-;\r
-\r
-: FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- )\r
-;\r
-\r
-: (FS.) ( -- addr cnt ) ( F: r -- , scientific notation )\r
- fp-output-pad fp-output-ptr ! \ setup pointer\r
- fp-represent-pad precision represent\r
-\ ." (FS.) - represent " fp-represent-pad precision type cr\r
- ( -- n flag1 flag2 )\r
- IF\r
- IF [char] - fp.hold\r
- THEN\r
- 1 precision fp.move.decimal\r
- [char] e fp.hold\r
- 1- (exp.) fp.append \ n\r
- ELSE\r
- 2drop\r
- s" <FP-OUT-OF-RANGE>" fp.append\r
- THEN\r
- fp-output-pad fp-output-ptr @ over -\r
-;\r
-\r
-: FS. ( F: r -- , scientific notation )\r
- (fs.) type space\r
-;\r
-\r
-: (FE.) ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- }\r
- fp-output-pad fp-output-ptr ! \ setup pointer\r
- fp-represent-pad precision represent\r
- ( -- n flag1 flag2 )\r
- IF\r
- IF [char] - fp.hold\r
- THEN\r
-\ convert exponent to multiple of three\r
- -> n\r
- n 1- s>d 3 fm/mod \ use floored divide\r
- 3 * -> n3\r
- 1+ precision fp.move.decimal \ amount to move decimal point\r
- [char] e fp.hold\r
- n3 (exp.) fp.append \ n\r
- ELSE\r
- 2drop\r
- s" <FP-OUT-OF-RANGE>" fp.append\r
- THEN\r
- fp-output-pad fp-output-ptr @ over -\r
-;\r
-\r
-: FE. ( F: r -- , engineering notation )\r
- (FE.) type space\r
-;\r
-\r
-: (FG.) ( F: r -- , normal or scientific ) { | n n3 ndiff -- }\r
- fp-output-pad fp-output-ptr ! \ setup pointer\r
- fp-represent-pad precision represent\r
- ( -- n flag1 flag2 )\r
- IF\r
- IF [char] - fp.hold\r
- THEN\r
-\ compare n with precision to see whether we do scientific display\r
- dup precision >\r
- over -3 < OR\r
- IF \ use exponential notation\r
- 1 precision fp.move.decimal\r
- fp.strip.trailing.zeros\r
- [char] e fp.hold\r
- 1- (exp.) fp.append \ n\r
- ELSE\r
- dup 0>\r
- IF\r
-\ POSITIVE EXPONENT - place decimal point in middle\r
- precision fp.move.decimal\r
- ELSE\r
-\ NEGATIVE EXPONENT - use 0.000????\r
- s" 0." fp.append\r
-\ output leading zeros\r
- negate fp.append.zeros\r
- fp-represent-pad precision fp.append\r
- THEN\r
- fp.strip.trailing.zeros\r
- THEN\r
- ELSE\r
- 2drop\r
- s" <FP-OUT-OF-RANGE>" fp.append\r
- THEN\r
- fp-output-pad fp-output-ptr @ over -\r
-;\r
-\r
-: FG. ( F: r -- )\r
- (fg.) type space\r
-;\r
-\r
-: (F.) ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- }\r
- fp-output-pad fp-output-ptr ! \ setup pointer\r
- fp-represent-pad \ place to put number\r
- fdup flog 1 s>f f+ f>s precision max\r
- fp_precision_max min dup -> prec'\r
- represent\r
- ( -- n flag1 flag2 )\r
- IF\r
-\ add '-' sign if negative\r
- IF [char] - fp.hold\r
- THEN\r
-\ compare n with precision to see whether we must do scientific display\r
- dup fp_precision_max >\r
- IF \ use exponential notation\r
- 1 precision fp.move.decimal\r
- fp.strip.trailing.zeros\r
- [char] e fp.hold\r
- 1- (exp.) fp.append \ n\r
- ELSE\r
- dup 0>\r
- IF\r
- \ POSITIVE EXPONENT - place decimal point in middle\r
- prec' fp.move.decimal\r
- ELSE\r
- \ NEGATIVE EXPONENT - use 0.000????\r
- s" 0." fp.append\r
- \ output leading zeros\r
- dup negate precision min\r
- fp.append.zeros\r
- fp-represent-pad precision rot + fp.append\r
- THEN\r
- THEN\r
- ELSE\r
- 2drop\r
- s" <FP-OUT-OF-RANGE>" fp.append\r
- THEN\r
- fp-output-pad fp-output-ptr @ over -\r
-;\r
-\r
-: F. ( F: r -- )\r
- (f.) type space\r
-;\r
-\r
-: F.S ( -- , print FP stack )\r
- ." FP> "\r
- fdepth 0>\r
- IF\r
- fdepth 0\r
- DO\r
- cr?\r
- fdepth i - 1- \ index of next float\r
- fpick f. cr?\r
- LOOP\r
- ELSE\r
- ." empty"\r
- THEN\r
- cr\r
-;\r
-\r
-\ FP Input ----------------------------------------------------------\r
-variable FP-REQUIRE-E \ must we put an E in FP numbers?\r
-false fp-require-e ! \ violate ANSI !!\r
-\r
-: >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag }\r
- u 0= IF false exit THEN\r
- false -> flag\r
- 0 -> nshift\r
-\\r
-\ check for minus sign\r
- c-addr c@ [char] - = dup -> fsign\r
- c-addr c@ [char] + = OR\r
- IF 1 +-> c-addr -1 +-> u \ skip char\r
- THEN\r
-\\r
-\ convert first set of digits\r
- 0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo\r
- u' 0>\r
- IF\r
-\ convert optional second set of digits\r
- c-addr c@ [char] . =\r
- IF\r
- dlo dhi c-addr 1+ u' 1- dup -> nshift >number\r
- dup nshift - -> nshift\r
- -> u' -> c-addr -> dhi -> dlo\r
- THEN\r
-\ convert exponent\r
- u' 0>\r
- IF\r
- c-addr c@ [char] E =\r
- c-addr c@ [char] e = OR\r
- IF\r
- 1 +-> c-addr -1 +-> u' \ skip E char
- u' 0>
- IF\r
- c-addr c@ [char] + = \ ignore + on exponent
- IF\r
- 1 +-> c-addr -1 +-> u' \ skip char\r
- THEN\r
- c-addr u' ((number?))\r
- num_type_single =\r
- IF\r
- nshift + -> nshift\r
- true -> flag\r
- THEN
- ELSE
- true -> flag \ allow "1E"
- THEN\r
- THEN\r
- ELSE\r
-\ only require E field if this variable is true\r
- fp-require-e @ not -> flag\r
- THEN\r
- THEN\r
-\ convert double precision int to float\r
- flag\r
- IF\r
- dlo dhi d>f\r
- 10 s>f nshift s>f f** f* \ apply exponent\r
- fsign\r
- IF\r
- fnegate\r
- THEN\r
- THEN\r
- flag\r
-;\r
-\r
-3 constant NUM_TYPE_FLOAT \ possible return type for NUMBER?\r
-\r
-: (FP.NUMBER?) ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number )\r
-\ check to see if it is a valid float, if not use old (NUMBER?)\r
- dup count >float\r
- IF\r
- drop NUM_TYPE_FLOAT\r
- ELSE\r
- (number?)\r
- THEN\r
-;\r
-\r
-defer fp.old.number?\r
-variable FP-IF-INIT\r
-\r
-: FP.TERM ( -- , deinstall fp conversion )\r
- fp-if-init @\r
- IF\r
- what's fp.old.number? is number?\r
- fp-if-init off\r
- THEN\r
-;\r
-\r
-: FP.INIT ( -- , install FP converion )\r
- fp.term\r
- what's number? is fp.old.number?\r
- ['] (fp.number?) is number?\r
- fp-if-init on\r
- ." Floating point numeric conversion installed." cr\r
-;\r
-\r
-FP.INIT\r
-if.forgotten fp.term\r
-\r
-\r
-0 [IF]\r
-\r
-23.8e-9 fconstant fsmall\r
-1.0 fsmall f- fconstant falmost1\r
-." Should be 1.0 = " falmost1 f. cr\r
-\r
-: TSEGF ( r -f- , print in all formats )\r
-." --------------------------------" cr\r
- 34 0\r
- DO\r
- fdup fs. 4 spaces fdup fe. 4 spaces\r
- fdup fg. 4 spaces fdup f. cr\r
- 10.0 f/\r
- LOOP\r
- fdrop\r
-;\r
-\r
-: TFP\r
- 1.234e+22 tsegf\r
- 1.23456789e+22 tsegf\r
- 0.927 fsin 1.234e+22 f* tsegf\r
-;\r
-\r
-[THEN]\r
+\ @(#) floats.fth 98/02/26 1.4 17:51:40
+\ High Level Forth support for Floating Point
+\
+\ Author: Phil Burk and Darren Gibbs
+\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
+\
+\ Permission to use, copy, modify, and/or distribute this
+\ software for any purpose with or without fee is hereby granted.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
+\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
+\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
+\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+\
+\ 19970702 PLB Drop 0.0 in REPRESENT to fix 0.0 F.
+\ 19980220 PLB Added FG. , fixed up large and small formatting
+\ 19980812 PLB Now don't drop 0.0 in REPRESENT to fix 0.0 F. (!!!)
+\ Fixed F~ by using (F.EXACTLY)
+
+ANEW TASK-FLOATS.FTH
+
+: FALIGNED ( addr -- a-addr )
+ 1 floats 1- +
+ 1 floats /
+ 1 floats *
+;
+
+: FALIGN ( -- , align DP )
+ dp @ faligned dp !
+;
+
+\ account for size of create when aligning floats
+here
+create fp-create-size
+fp-create-size swap - constant CREATE_SIZE
+
+: FALIGN.CREATE ( -- , align DP for float after CREATE )
+ dp @
+ CREATE_SIZE +
+ faligned
+ CREATE_SIZE -
+ dp !
+;
+
+: FCREATE ( <name> -- , create with float aligned data )
+ falign.create
+ CREATE
+;
+
+: FVARIABLE ( <name> -- ) ( F: -- )
+ FCREATE 1 floats allot
+;
+
+: FCONSTANT
+ FCREATE here 1 floats allot f!
+ DOES> f@
+;
+
+: F0SP ( -- ) ( F: ? -- )
+ fdepth 0 max 0 ?DO fdrop LOOP
+;
+
+\ Convert between single precision and floating point
+: S>F ( s -- ) ( F: -- r )
+ s>d d>f
+;
+: F>S ( -- s ) ( F: r -- )
+ f>d d>s
+;
+
+: (F.EXACTLY) ( r1 r2 -f- flag , return true if encoded equally ) { | caddr1 caddr2 fsize fcells }
+ 1 floats -> fsize
+ fsize cell 1- + cell 1- invert and \ round up to nearest multiple of stack size
+ cell / -> fcells ( number of cells per float )
+\ make room on data stack for floats data
+ fcells 0 ?DO 0 LOOP
+ sp@ -> caddr1
+ fcells 0 ?DO 0 LOOP
+ sp@ -> caddr2
+\ compare bit representation
+ caddr1 f!
+ caddr2 f!
+ caddr1 fsize caddr2 fsize compare 0=
+ >r fcells 2* 0 ?DO drop LOOP r> \ drop float bits
+;
+
+: F~ ( -0- flag ) ( r1 r2 r3 -f- )
+ fdup F0<
+ IF
+ frot frot ( -- r3 r1 r2 )
+ fover fover ( -- r3 r1 r2 r1 r2 )
+ f- fabs ( -- r3 r1 r2 |r1-r2| )
+ frot frot ( -- r3 |r1-r2| r1 r2 )
+ fabs fswap fabs f+ ( -- r3 |r1-r2| |r1|+|r2| )
+ frot fabs f* ( -- |r1-r2| |r1|+|r2|*|r3| )
+ f<
+ ELSE
+ fdup f0=
+ IF
+ fdrop
+ (f.exactly) \ f- f0= \ 19980812 Used to cheat. Now actually compares bit patterns.
+ ELSE
+ frot frot ( -- r3 r1 r2 )
+ f- fabs ( -- r3 |r1-r2| )
+ fswap f<
+ THEN
+ THEN
+;
+
+\ FP Output --------------------------------------------------------
+fvariable FVAR-REP \ scratch var for represent
+: REPRESENT { c-addr u | n flag1 flag2 -- n flag1 flag2 , FLOATING } ( F: r -- )
+ TRUE -> flag2 \ FIXME - need to check range
+ fvar-rep f!
+\
+ fvar-rep f@ f0<
+ IF
+ -1 -> flag1
+ fvar-rep f@ fabs fvar-rep f! \ absolute value
+ ELSE
+ 0 -> flag1
+ THEN
+\
+ fvar-rep f@ f0=
+ IF
+\ fdrop \ 19970702 \ 19980812 Remove FDROP to fix "0.0 F."
+ c-addr u [char] 0 fill
+ 0 -> n
+ ELSE
+ fvar-rep f@
+ flog
+ fdup f0< not
+ IF
+ 1 s>f f+ \ round up exponent
+ THEN
+ f>s -> n
+\ ." REP - n = " n . cr
+\ normalize r to u digits
+ fvar-rep f@
+ 10 s>f u n - s>f f** f*
+ 1 s>f 2 s>f f/ f+ \ round result
+\
+\ convert float to double_int then convert to text
+ f>d
+\ ." REP - d = " over . dup . cr
+ <# u 1- 0 ?DO # loop #s #> \ ( -- addr cnt )
+\ Adjust exponent if rounding caused number of digits to increase.
+\ For example from 9999 to 10000.
+ u - +-> n
+ c-addr u move
+ THEN
+\
+ n flag1 flag2
+;
+
+variable FP-PRECISION
+
+\ Set maximum digits that are meaningful for the precision that we use.
+1 FLOATS 4 / 7 * constant FP_PRECISION_MAX
+
+: PRECISION ( -- u )
+ fp-precision @
+;
+: SET-PRECISION ( u -- )
+ fp_precision_max min
+ fp-precision !
+;
+7 set-precision
+
+32 constant FP_REPRESENT_SIZE
+64 constant FP_OUTPUT_SIZE
+
+create FP-REPRESENT-PAD FP_REPRESENT_SIZE allot \ used with REPRESENT
+create FP-OUTPUT-PAD FP_OUTPUT_SIZE allot \ used to assemble final output
+variable FP-OUTPUT-PTR \ points into FP-OUTPUT-PAD
+
+: FP.HOLD ( char -- , add char to output )
+ fp-output-ptr @ fp-output-pad 64 + <
+ IF
+ fp-output-ptr @ tuck c!
+ 1+ fp-output-ptr !
+ ELSE
+ drop
+ THEN
+;
+: FP.APPEND { addr cnt -- , add string to output }
+ cnt 0 max 0
+ ?DO
+ addr i + c@ fp.hold
+ LOOP
+;
+
+: FP.STRIP.TRAILING.ZEROS ( -- , remove trailing zeros from fp output )
+ BEGIN
+ fp-output-ptr @ fp-output-pad u>
+ fp-output-ptr @ 1- c@ [char] 0 =
+ and
+ WHILE
+ -1 fp-output-ptr +!
+ REPEAT
+;
+
+: FP.APPEND.ZEROS ( numZeros -- )
+ 0 max 0
+ ?DO [char] 0 fp.hold
+ LOOP
+;
+
+: FP.MOVE.DECIMAL { n prec -- , append with decimal point shifted }
+ fp-represent-pad n prec min fp.append
+ n prec - fp.append.zeros
+ [char] . fp.hold
+ fp-represent-pad n +
+ prec n - 0 max fp.append
+;
+
+: (EXP.) ( n -- addr cnt , convert exponent to two digit value )
+ dup abs 0
+ <# # #s
+ rot 0<
+ IF [char] - HOLD
+ ELSE [char] + hold
+ THEN
+ #>
+;
+
+: FP.REPRESENT ( -- n flag1 flag2 ) ( r -f- )
+;
+
+: (FS.) ( -- addr cnt ) ( F: r -- , scientific notation )
+ fp-output-pad fp-output-ptr ! \ setup pointer
+ fp-represent-pad precision represent
+\ ." (FS.) - represent " fp-represent-pad precision type cr
+ ( -- n flag1 flag2 )
+ IF
+ IF [char] - fp.hold
+ THEN
+ 1 precision fp.move.decimal
+ [char] e fp.hold
+ 1- (exp.) fp.append \ n
+ ELSE
+ 2drop
+ s" <FP-OUT-OF-RANGE>" fp.append
+ THEN
+ fp-output-pad fp-output-ptr @ over -
+;
+
+: FS. ( F: r -- , scientific notation )
+ (fs.) type space
+;
+
+: (FE.) ( -- addr cnt ) ( F: r -- , engineering notation ) { | n n3 -- }
+ fp-output-pad fp-output-ptr ! \ setup pointer
+ fp-represent-pad precision represent
+ ( -- n flag1 flag2 )
+ IF
+ IF [char] - fp.hold
+ THEN
+\ convert exponent to multiple of three
+ -> n
+ n 1- s>d 3 fm/mod \ use floored divide
+ 3 * -> n3
+ 1+ precision fp.move.decimal \ amount to move decimal point
+ [char] e fp.hold
+ n3 (exp.) fp.append \ n
+ ELSE
+ 2drop
+ s" <FP-OUT-OF-RANGE>" fp.append
+ THEN
+ fp-output-pad fp-output-ptr @ over -
+;
+
+: FE. ( F: r -- , engineering notation )
+ (FE.) type space
+;
+
+: (FG.) ( F: r -- , normal or scientific ) { | n n3 ndiff -- }
+ fp-output-pad fp-output-ptr ! \ setup pointer
+ fp-represent-pad precision represent
+ ( -- n flag1 flag2 )
+ IF
+ IF [char] - fp.hold
+ THEN
+\ compare n with precision to see whether we do scientific display
+ dup precision >
+ over -3 < OR
+ IF \ use exponential notation
+ 1 precision fp.move.decimal
+ fp.strip.trailing.zeros
+ [char] e fp.hold
+ 1- (exp.) fp.append \ n
+ ELSE
+ dup 0>
+ IF
+\ POSITIVE EXPONENT - place decimal point in middle
+ precision fp.move.decimal
+ ELSE
+\ NEGATIVE EXPONENT - use 0.000????
+ s" 0." fp.append
+\ output leading zeros
+ negate fp.append.zeros
+ fp-represent-pad precision fp.append
+ THEN
+ fp.strip.trailing.zeros
+ THEN
+ ELSE
+ 2drop
+ s" <FP-OUT-OF-RANGE>" fp.append
+ THEN
+ fp-output-pad fp-output-ptr @ over -
+;
+
+: FG. ( F: r -- )
+ (fg.) type space
+;
+
+: (F.) ( F: r -- , normal or scientific ) { | n n3 ndiff prec' -- }
+ fp-output-pad fp-output-ptr ! \ setup pointer
+ fp-represent-pad \ place to put number
+ fdup flog 1 s>f f+ f>s precision max
+ fp_precision_max min dup -> prec'
+ represent
+ ( -- n flag1 flag2 )
+ IF
+\ add '-' sign if negative
+ IF [char] - fp.hold
+ THEN
+\ compare n with precision to see whether we must do scientific display
+ dup fp_precision_max >
+ IF \ use exponential notation
+ 1 precision fp.move.decimal
+ fp.strip.trailing.zeros
+ [char] e fp.hold
+ 1- (exp.) fp.append \ n
+ ELSE
+ dup 0>
+ IF
+ \ POSITIVE EXPONENT - place decimal point in middle
+ prec' fp.move.decimal
+ ELSE
+ \ NEGATIVE EXPONENT - use 0.000????
+ s" 0." fp.append
+ \ output leading zeros
+ dup negate precision min
+ fp.append.zeros
+ fp-represent-pad precision rot + fp.append
+ THEN
+ THEN
+ ELSE
+ 2drop
+ s" <FP-OUT-OF-RANGE>" fp.append
+ THEN
+ fp-output-pad fp-output-ptr @ over -
+;
+
+: F. ( F: r -- )
+ (f.) type space
+;
+
+: F.S ( -- , print FP stack )
+ ." FP> "
+ fdepth 0>
+ IF
+ fdepth 0
+ DO
+ cr?
+ fdepth i - 1- \ index of next float
+ fpick f. cr?
+ LOOP
+ ELSE
+ ." empty"
+ THEN
+ cr
+;
+
+\ FP Input ----------------------------------------------------------
+variable FP-REQUIRE-E \ must we put an E in FP numbers?
+false fp-require-e ! \ violate ANSI !!
+
+: >FLOAT { c-addr u | dlo dhi u' fsign flag nshift -- flag }
+ u 0= IF false exit THEN
+ false -> flag
+ 0 -> nshift
+\
+\ check for minus sign
+ c-addr c@ [char] - = dup -> fsign
+ c-addr c@ [char] + = OR
+ IF 1 +-> c-addr -1 +-> u \ skip char
+ THEN
+\
+\ convert first set of digits
+ 0 0 c-addr u >number -> u' -> c-addr -> dhi -> dlo
+ u' 0>
+ IF
+\ convert optional second set of digits
+ c-addr c@ [char] . =
+ IF
+ dlo dhi c-addr 1+ u' 1- dup -> nshift >number
+ dup nshift - -> nshift
+ -> u' -> c-addr -> dhi -> dlo
+ THEN
+\ convert exponent
+ u' 0>
+ IF
+ c-addr c@ [char] E =
+ c-addr c@ [char] e = OR
+ IF
+ 1 +-> c-addr -1 +-> u' \ skip E char
+ u' 0>
+ IF
+ c-addr c@ [char] + = \ ignore + on exponent
+ IF
+ 1 +-> c-addr -1 +-> u' \ skip char
+ THEN
+ c-addr u' ((number?))
+ num_type_single =
+ IF
+ nshift + -> nshift
+ true -> flag
+ THEN
+ ELSE
+ true -> flag \ allow "1E"
+ THEN
+ THEN
+ ELSE
+\ only require E field if this variable is true
+ fp-require-e @ not -> flag
+ THEN
+ THEN
+\ convert double precision int to float
+ flag
+ IF
+ dlo dhi d>f
+ 10 s>f nshift s>f f** f* \ apply exponent
+ fsign
+ IF
+ fnegate
+ THEN
+ THEN
+ flag
+;
+
+3 constant NUM_TYPE_FLOAT \ possible return type for NUMBER?
+
+: (FP.NUMBER?) ( $addr -- 0 | n 1 | d 2 | r 3 , convert string to number )
+\ check to see if it is a valid float, if not use old (NUMBER?)
+ dup count >float
+ IF
+ drop NUM_TYPE_FLOAT
+ ELSE
+ (number?)
+ THEN
+;
+
+defer fp.old.number?
+variable FP-IF-INIT
+
+: FP.TERM ( -- , deinstall fp conversion )
+ fp-if-init @
+ IF
+ what's fp.old.number? is number?
+ fp-if-init off
+ THEN
+;
+
+: FP.INIT ( -- , install FP converion )
+ fp.term
+ what's number? is fp.old.number?
+ ['] (fp.number?) is number?
+ fp-if-init on
+ ." Floating point numeric conversion installed." cr
+;
+
+FP.INIT
+if.forgotten fp.term
+
+
+0 [IF]
+
+23.8e-9 fconstant fsmall
+1.0 fsmall f- fconstant falmost1
+." Should be 1.0 = " falmost1 f. cr
+
+: TSEGF ( r -f- , print in all formats )
+." --------------------------------" cr
+ 34 0
+ DO
+ fdup fs. 4 spaces fdup fe. 4 spaces
+ fdup fg. 4 spaces fdup f. cr
+ 10.0 f/
+ LOOP
+ fdrop
+;
+
+: TFP
+ 1.234e+22 tsegf
+ 1.23456789e+22 tsegf
+ 0.927 fsin 1.234e+22 f* tsegf
+;
+
+[THEN]
projects / pforth / blobdiff