Category : Forth Source Code
Archive   : VPSFP102.ZIP
Filename : FPCOM2.SEQ

\ FILE: FPCOM2.SEQ ROUTINES COMMON TO HFP AND SFP
\ VP-Planner floating point for F-PC.

/*
Kent Brothers and Stephenson Software Ltd. are making these floating
point routines available to the Forth language community to further the
growth of Forth as an application development language. It is licensed
for incorporation into programs (with or without modifications) with no
fee as long as the following notice is displayed on screen and in the
documentation:

VP-Planner floating point routines copyright 1985-1989
Kent Brothers, Stephenson Software Ltd.

The source code may be distributed free of charge provided this entire
message (including the notice) is left at the top.
*/


CR .( Loading FPCOM2.SEQ ... )

\ JWB 860201 Created file to hold common routines from HFPPRIM2 & SFPPRIM2.
\ KMB 860809 (E.), (..E.), and (..) changed to display a maximum of 15
\ digits instead of 16.
\ KMB 860809 (..) corrected for large numbers with fractional components.
\ KMB 861107 Definitions of +INF, -INF, FERR, FNA, DFERR, & DFNA changed.
\ KMB 861108 DFERR, DFNA, LDF!, and LDF@ commented out - NAN's now handled in
\ code versions.
\ KMB 861108 FLOAT changed to use 10.*.
\ KMB 861108 Colon version of /// moved to SFPPRIM2.
\ DJL 870306 I. changed to use 4DROP.
\ KMB 871101 FMIN, FMAX, and 1/X changed so as not to check for NANs.
\ KMB 871101 F,, FCONSTANT, FERR, and FNA moved to FPVECTOR.
\ DJL 880106 Moved F? to FTRACE
\ JWB 890327 Converted to F-PC.
\ JWB 890404 Made non user words headerless.
\ JWB 890514 Changed FVAR to FVALUE to conform to F-PC VALUE syntax
\ JWB 890514 Fixed FVALUES and added F+!> for incrementing FVALUES.
\ JWB 890514 Added Mark Smiley's FARRAY definition.

FORTH DEFINITIONS HEX

\ Move single integer from parameter stack to top of 8087 stack.
: S>F ( n -- ) ( F: -- r )
S>D D>F ;

HEADERLESS
0 0 D>F FCONSTANT |0. ' |0. IS 0.
1 0 D>F FCONSTANT |1. ' |1. IS 1.
2 0 D>F FCONSTANT |2. ' |2. IS 2.
A 0 D>F FCONSTANT |10. ' |10. IS 10.
1. 2. F/ FCONSTANT |.5 ' |.5 IS .5
HEADERS

1. FCONSTANT +INF 7FFF ' +INF >BODY 8 + !
1. FCONSTANT -INF FFFF ' -INF >BODY 8 + !


\ HEADERLESS
VARIABLE DATAFLAG
DATAFLAG OFF

CODE ?STORE ( -- flag )
XOR BX, BX
XCHG CS: BX, DATAFLAG
PUSH BX
NEXT
END-CODE

\ HEADERS

\ FVALUE assignment operator.
CODE F!> ( -- ) ( JWB 89 05 14 )
MOV CS: DATAFLAG # -1 WORD
NEXT
END-CODE

\ FVALUE increment operator.
CODE F+!> ( -- ) ( JWB 89 05 14 )
MOV CS: DATAFLAG # 1 WORD
NEXT
END-CODE

\ Create and initialize an FVALUE ( floating point "value" ) to the
\ top number on the floating point stack.
: FVALUE ( KMB 85 06 13 ) ( JWB 89 05 14 )
CREATE F, ( F: r -- )
DOES> ?STORE ?DUP
IF 1+ IF DUP EF@ F+ THEN EF!
ELSE EF@
THEN ;

\ Create n FVARS and initialize them to zero.
: FVALUES ( n -- ) ( KMB 85 06 06 )
0 ?DO 0. FVALUE LOOP ;

\ Create floating point variable
: FVARIABLE ( -- ; compiling )
( -- adr ; executing )
CREATE 0. F, ;


\ The following words are extensions Mark Smiley wrote for SFLOAT which
\ also work in the VP software floating point.
\ Real Array.
: FARRAY ( Comp: rn ... r1 r0 n+1 -- ) ( JWB 89 05 14 )
( Run: k -- rk_addr)
CREATE
DUP , 0 DO F, LOOP
DOES> ( index pfa )
SWAP DUP 0<
IF DROP @
ELSE FPSIZE * 2+ +
THEN ;


: FLOAT ( dn -- ) ( F: -- r ) ( uses DPL ) ( KMB 861108 )
D>F FDOUBLE?
IF DPL @ ?DUP
IF 1. DUP ABS 0 DO 10.* LOOP
0< IF F* ELSE F/ THEN
THEN
THEN ;


: FLITERAL ( F: r -- )
COMPILE FLIT XF, ; IMMEDIATE

HEADERLESS
\ Float entered number
: FFLITERAL ( F: r -- ) ( KMB 85 06 13 )
FLOAT STATE @
IF [COMPILE] FLITERAL
THEN ; IMMEDIATE

: INTERP-FP ( -- )
BEGIN ?STACK DEFINED
IF EXECUTE
ELSE NUMBER FDOUBLE?
IF FLOAT ELSE DROP THEN
THEN FALSE DONE?
UNTIL ;

: (]-FP) ( -- )
STATE ON
BEGIN ?STACK DEFINED DUP
IF 0> IF EXECUTE ELSE X, THEN
ELSE DROP NUMBER FDOUBLE?
IF [COMPILE] FFLITERAL
ELSE DROP [COMPILE] LITERAL THEN
THEN TRUE DONE?
UNTIL ;
HEADERS


\ ' FLIT 'FLIT !


: FLOATING ( -- )
['] (FNUMBER) IS NUMBER
['] INTERP-FP IS INTERPRET
['] (]-FP) IS ] ;

: DOUBLE ( -- )
['] (NUMBER) IS NUMBER
['] INTERP IS INTERPRET
['] (]) IS ] ;


: FCOMPDROP ( -- flag ) ( F: r1 r2 -- ) ( KMB 85 10 30 )
FCOMP FDROP FDROP ;

: F< FCOMPDROP 0< ; ( -- flag ) ( F: r1 r2 -- ) ( KMB 85 10 30 )
: F> FCOMPDROP 0> ; ( -- flag ) ( F: r1 r2 -- ) ( KMB 85 10 30 )
: F= FCOMPDROP 0= ; ( -- flag ) ( F: r1 r2 -- ) ( KMB 85 10 30 )

: DF! ?CS: SWAP LDF! ; ( adr -- ) ( F: r -- ) ( KMB 85 07 06 )
: DF@ ?CS: SWAP LDF@ ; ( adr -- ) ( F: r -- ) ( KMB 85 07 06 )

: FMIN ( F: r1 r2 -- r3 )( KMB 871101 )
FCOMP 0> IF FSWAP THEN FDROP ;

: FMAX ( F: r1 r2 -- r3 )( KMB 871101 )
FCOMP 0< IF FSWAP THEN FDROP ;

: F0< FSIGN 0< FDROP ; ( -- flag ) ( F: r -- )
: F0> FSIGN 0> FDROP ; ( -- flag ) ( F: r -- )
: F0= FSIGN 0= FDROP ; ( -- flag ) ( F: r -- )

: 1/X 1. FSWAP F/ ; ( F: r -- 1/X )( KMB 871101 )

: FMOD ( F: r1 r2 -- r3 ) ( KMB 85 10 30 )
?NONAN2
IF FABS FSIGN ?DUP
IF FSWAP FSIGN >R FABS FSIGN 2DUP <= ( FS2' FS1' F / FS1 | |r2| |r1| )
IF - NEGATE 0 SWAP ( 0 N / FS1 | |r2| |r1| )
DO FOVER I 2SCALE FCOMP 0<
IF FDROP ELSE F-
THEN -1 ( -1 / FS1 | |X2| |r3'| )
+LOOP
ELSE 2DROP
THEN R> 0< IF FNEGATE THEN FSWAP FDROP
ELSE FDROP FDROP FERR
THEN
THEN ;

: ZERO ( FS n -- adr len ) ( KMB 85 06 13 )
\ Returns a string consisting of a decimal point followed by N zeros,
\ preceded by a "-" if FS <> 0. The string returned is just below PAD.
\ If N=0, "0" is returned.
?DUP
IF DBL0 <# ROT N#S ASCII . HOLD ROT IF ASCII - HOLD THEN
ELSE DROP DBL0 <# #
THEN #> ;

: (.NAN) ( -- adr len ) ( F: r -- ) ( KMB 85 08 19 )
<# FNA F= IF " NA" ELSE " ERR" THEN "HOLD DBL0 #> ;


: ORIF COMPILE ?DUP COMPILE 0= [COMPILE] IF ; IMMEDIATE

: (F.) ( N -- adr len ) ( F: r -- ) ( KMB 85 08 18 )
( 0 )
\ Converts r to a string with N digits after the decimal point, unless
\ |r| > 2^64, in which case a single 0 is returned.
?NONAN1
IF 10 UMIN >R F->FIS ( QF QI S 0 / N2 or 0 -1 / N2 or S N3 -1 / N2 )
IF DUP
IF 1- IF R> 2DROP 0 ELSE R> ZERO THEN
ELSE R> ZERO
THEN
ELSE R> SWAP >R DUP >R FIROUND R@ <# ( QF' QI' N2 / N2 S )
IF R@ NEGATE HLD +! ASCII . HOLD ( QF' QI' / N2 S )
THEN
3 PICK ORIF 2 PICK ORIF OVER ORIF DUP ORIF R@ 0=
THEN THEN THEN THEN
( IF Q#S ELSE 2DROP THEN ) \ VP Q#S leaves only 0 0
IF Q#S THEN 2DROP
2DROP R> R>
IF ASCII - HOLD THEN
FDIGITS DBL0 #>
THEN
ELSE DROP (.NAN)
THEN ;

DECIMAL FLOATING
HEADERLESS
CREATE POWERS
1.E0001 F, 1.E0002 F, 1.E0004 F, 1.E0008 F, 1.E0016 F,
1.E0032 F, 1.E0064 F, 1.E0128 F, 1.E0256 F, 1.E0512 F,
1.E1024 F, 1.E2048 F, 1.E4096 F,

HEADERS

HEX

: EXP/MANT ( -- N ) ( F: r1 -- r2 ) ( KMB 85 06 13 )
\ Converts r1 into exponent/mantissa form: r1 = r2*10^N where 1 <= r2 < 10.
\ r1 is assumed to be positive.
FSIGN 7FFF AND 3FFF - DUP 0< DUP >R ( NE2 flag / NS | |r1| )
IF ( |r1|<1 ) DROP 1/X FSIGN 3FFF -
THEN 1+ 4 0D */ 1 SWAP 10 1 ( 1 NU 16 1 / NS | |r1| )
\ log10(x) = log2(x) * log10(2) <= ([log2(x)]+1)*4/13, so
\ N = [log10{x}] <= [([log2{x}]+1)*4/13] = NU
DO 2/ DUP 0= IF DROP I LEAVE ELSE SWAP 2* SWAP THEN
LOOP >R 0 SWAP ( 0 2^[log2[NU]] / [log2[NU]] NS | |r1| )
POWERS DUP R> 1- FPSIZE * + ( 0 2^[..] POWERS POWERS+ / NS | |r1| )
DO FDUP I EF@ F< NOT
IF TUCK + SWAP I EF@ F/
THEN 2/ [ FPSIZE NEGATE ] LITERAL
+LOOP DROP R> ( N' / NS XS | |X2| )
IF NEGATE 1- 1/X 10.*
THEN ;

DECIMAL


: (E.) ( n -- adr len ) ( F: r -- ) ( KMB 86 08 09 )
\ Converts r to a scientific-format string with N significant digits.
?NONAN1
IF 1 UMAX 15 UMIN 1- FSIGN ?DUP
IF ( X<>0 ) 0< >R >R FABS EXP/MANT ( NE / N2 S | XM )
F->FIS 2DROP R@ FIROUND 3DROP R> SWAP >R DUP >R FDIGITS ( NE / N2 NI S )
R> R@ SWAP >R 9 > IF 1+ THEN 4 OVER ABS 99 > ( NE 4 flag / N2 NI S )
IF 1+ OVER ABS 999 > IF 1+ THEN
THEN R@ 0= IF 1- THEN ( adjust for absence of decimal point )
PAD R@ - DUP ROT - R@ CMOVE ( NE / N2 NI S )
DUP >R ABS 0 ( |NE| 0 / SE N2 NI S )
<# # #S R> 0< IF " E-" ELSE " E+" THEN "HOLD
2DROP R@ NEGATE HLD +! R> IF ASCII . HOLD THEN ( / NI S )
R> DUP 9 > IF DROP 1 THEN 0 # R> IF ASCII - HOLD THEN #>
ELSE ( X=0 ) <# " E+00" "HOLD ASCII 0 NHOLD " 0." "HOLD F>D #>
THEN
ELSE DROP (.NAN)
THEN ;

: (..E.) ( n -- adr len ) ( F: r -- ) ( KMB 86 08 09 )
( 0 )
\ Converts r to a scientific format string of up to 15 significant digits or
\ up to N characters, whichever is less. If the string requires more than N
\ characters even with only 1 significant digit, then a single 0 is returned.
?NONAN1
IF DUP >R ( N / N | r )
BEGIN FSIGN 0< IF 1- THEN 5 - DUP 0> ( N2 flag / N | r )
IF FDUP (E.) DUP R@ <=
IF ( not more than N characters ) -1 ( adr len -1 / N | r )
ELSE ( more than N characters ) NIP R@ - R@ SWAP - 0
( N3 0 / N | r )
THEN
ELSE ( non-positive # of significant digits ) DROP 0 -1 ( 0 -1 )
THEN
UNTIL R> DROP FDROP
ELSE (.NAN) ROT OVER < IF 2DROP 0 THEN
THEN ;



: -ZEROS ( adr len1 -- adr len2 ) ( KMB 85 06 13 )
\ Trims trailing zeros. If after trimming the string ends with a decimal
\ point or a minus sign, they are also removed.
2DUP ASCII . CSCAN
IF ( string contains decimal point ) DROP 2DUP ASCII 0 - IF NIP DUP C@ ASCII . <> ( adr A2 flag )
IF ( trailing character is a digit ) 1+ ( adr A2+1 )
ELSE ( trailing character is a decimal point ) 2DUP U< ( adr A2 flag )
IF 1- DUP C@ ASCII - <> IF 1+ THEN ( A A2- )
THEN
THEN OVER -
THEN
THEN ;

HEX

: I. ( QF QI S -- adr len ) ( DJL 870305 ) ( JWB 890329 )
>R <# Q#S R>
IF ASCII - HOLD THEN
2DROP 2DROP 2DROP #> ; \ Extra 2DROP for F-PC

: (..) ( n -- adr len ) ( F: r -- ) ( KMB 86 08 09 )
( -1 0 if underflow )
( 0 0 if overflow )
\ Converts r to a string of up to 15 digits or N characters, whichever is less,
\ with trailing zeros after the decimal point suppressed. If the integer
\ portion of r requires more than N characters, two zeros are returned. If
\ r is non-zero but so small that its representation would consist solely of
\ zeros, then -1 and 0 are returned.
11 UMIN 1 UMAX >R F->FIS
( QF QI S 0 / N2 or 0 -1 / N2 or S N3 -1 / N2 )
IF DUP
IF ( overflow or underflow ) 2- SWAP R> 2DROP 0
ELSE ( zero ) 0 R> DROP <# # #>
THEN
ELSE >R #DIGITS R@ IF 1+ THEN DUP R> R@ SWAP >R > ( QF QI NI flag / S N2 )
IF ( overflow ) R> R> 0B NDROP DBL0
ELSE >R 7 PICK 7 PICK OR 6 PICK OR 5 PICK OR ( QF QI N4 / NI S N2 )
IF ( non-integer ) R> 1+ DUP R> R@ SWAP >R >= ( QF QI NI+1 flag / S N2 )
IF ( integer portion will fill field ) DROP 0 FIROUND R> I. R> DROP
ELSE 10 R@ - R> SWAP R@ MIN ROT - ( QF QI S ND / N2 )
DUP >R SWAP >R FIROUND ( QF' QI' / S ND N2 )
<# R> R@ SWAP >R NEGATE HLD +! ASCII . HOLD ( QF' QI' / S ND N2 )
3 PICK ORIF 2 PICK ORIF OVER ORIF DUP
THEN THEN THEN
( IF Q#S ELSE 2DROP THEN )
IF Q#S THEN 2DROP
2DROP ( QF' / S ND N2 )
R> IF ASCII - HOLD THEN ( QF' / ND N2 )
R> FDIGITS DBL0 #> R> MIN -ZEROS DUP 0= ( adr len flag )
IF ( underflow ) 2DROP -1 0
THEN
THEN
ELSE ( integer ) R> DROP R> I. R> DROP
THEN
THEN
THEN ;

: .. ( F: r -- ) ( KMB 85 08 18 )
FDUP 12 (..) ?DUP 0=
IF DROP ?NONAN1 IF 10 (E.) ELSE (.NAN) THEN
ELSE FDROP
THEN TYPE SPACE ;

VARIABLE DPLACES

\ Set number of decimal places in F. and E. display operators.
: PLACES ( n -- )
1 MAX F#PLACES MIN DPLACES ! ;

10 ( 16 ) PLACES

: F. ( F: r -- )
DPLACES @ (F.) TYPE SPACE ;

: E. ( F: r -- )
DPLACES @ (E.) TYPE SPACE ;

FORTH DEFINITIONS
DECIMAL
BEHEAD