home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
forth
/
compiler
/
fpc
/
source
/
ffloat.seq
< prev
next >
Wrap
Text File
|
1990-05-24
|
44KB
|
1,782 lines
\ FFLOAT.SEQ Faster Hardware Floating point for 8087
\ Enhancements by: Robert L. Smith
comment:
Based on HFLOAT by Steve Pollack and Mark Smiley and others.
Preliminary tests show a speed improvement by a factor of two!
Please send bug reports to:
Robert L. Smith
2300 St. Francis Dr.
Palo Alto, CA 94303
Tel: (415) 856-9321
Comments are especially welcome regarding compatibility among the
Intel variants: 8087, 80287, 80387, 80487 ...
Note that the value 8087NPU may be modified prior to loading this
file. If it is changed, some speed improvements may be noticed
in the more recent Floating Point Numeric Processors.
comment;
CR .( FFLOAT Version 2.01 05/24/90 17:14:16.74 )
\ CR .( 8087/80287 Assembler extensions..)
HEX
FORTH ALSO ASSEMBLER ALSO DEFINITIONS
VARIABLE WAIT? WAIT? ON
VARIABLE <FW>
TRUE VALUE 8087NPU \ Change this for shorter code with 80287 or 80387
: NOWAIT WAIT? OFF ;
: COMP-WAIT
8087NPU WAIT? @ [ FORTH ] AND
IF 9B C, ( WAIT ) THEN
WAIT? ON ;
: FPSTACK? ( -- f )
[ FORTH ] TS@ 6 = ;
\ Floating Point Source Registers
\ Reg Type W Name
0 6 1 SREG ST
0 6 1 SREG ST0
0 6 1 SREG ST(0)
1 6 1 SREG ST1
1 6 1 SREG ST(1)
2 6 1 SREG ST2
2 6 1 SREG ST(2)
3 6 1 SREG ST3
3 6 1 SREG ST(3)
4 6 1 SREG ST4
4 6 1 SREG ST(4)
5 6 1 SREG ST5
5 6 1 SREG ST(5)
6 6 1 SREG ST6
6 6 1 SREG ST(6)
7 6 1 SREG ST7
7 6 1 SREG ST(7)
\ Floating Point Destination Registers
\ Reg Type W Name
0 6 1 DREG ST,
0 6 1 DREG ST0,
0 6 1 DREG ST(0),
1 6 1 DREG ST1,
1 6 1 DREG ST(1),
2 6 1 DREG ST2,
2 6 1 DREG ST(2),
3 6 1 DREG ST3,
3 6 1 DREG ST(3),
4 6 1 DREG ST4,
4 6 1 DREG ST(4),
5 6 1 DREG ST5,
5 6 1 DREG ST(5),
6 6 1 DREG ST6,
6 6 1 DREG ST(6),
7 6 1 DREG ST7,
7 6 1 DREG ST(7),
: WORD-TYPE CREATE C, DOES> C@ <FW> ! ;
$007 WORD-TYPE INTEGER*2 $02F WORD-TYPE INTEGER*8
$003 WORD-TYPE INTEGER*4 $001 WORD-TYPE REAL*4
$005 WORD-TYPE REAL*8 $02B WORD-TYPE TEMP_REAL
$027 WORD-TYPE BCD
: MF ( -- n ) <FW> @ [ FORTH ] 6 AND ;
: ESC, ( n -- ) [ FORTH ] $D8 OR C, ;
: N1FPF
DUP 1+ C@ ESC, C@ C, RESET ;
: N1FP CREATE C, C, DOES> ['] N1FPF A;! A; ;
3 $0E2 N1FP FNCLEX 3 $0E3 N1FP FNINIT
3 $0E0 N1FP FNENI 3 $0E1 N1FP FNDISI
7 $0E0 N1FP FNSTWAX ( 80287 instruction )
: W1FPF $09B C, N1FPF ; \ Generate a WAIT before the instruction.
: W1FP CREATE C, C, DOES> ['] W1FPF A;! A; ;
3 $0E2 W1FP FCLEX 3 $0E3 W1FP FINIT
3 $0E0 W1FP FENI 3 $0E1 W1FP FDISI
7 $0E0 W1FP FSTWAX ( 80287 instruction )
: 1FP CREATE C, C, DOES> ['] N1FPF A;! A; COMP-WAIT ;
\ NON-VARIANT 8087 INSTRUCTIONS
6 $0D9 1FP FCOMPP 1 $0E4 1FP FTST 1 $0E5 1FP FXAM
1 $0EE 1FP FLDZ 1 $0E8 1FP FLD1 1 $0EB 1FP FLDPI
1 $0E9 1FP FLDL2T 1 $0EA 1FP FLDL2E 1 $0EC 1FP FLDLG2
1 $0ED 1FP FLDLN2 1 $0FA 1FP FSQRT, 1 $0FD 1FP FSCALE
1 $0F8 1FP FPREM 1 $0FC 1FP FRNDINT 1 $0F4 1FP FXTRACT
1 $0E1 1FP FABS, 1 $0E0 1FP FCHS 1 $0F2 1FP FPTAN
1 $0F3 1FP FPATAN 1 $0F0 1FP F2XM1 1 $0F1 1FP FYL2X
1 $0F9 1FP FYL2XP1 1 $0F7 1FP FINCSTP
1 $0F6 1FP FDECSTP 1 $0D0 1FP FNOP
( 3 $0E4 1FP FSETPM ) ( 80287 instruction )
: N2FPF
DUP 1+ C@ ESC, C@ M/RS, RESET ;
: N2FP
CREATE C, C, DOES> ['] N2FPF A;! A; ;
1 $038 N2FP FNSTCW 5 $038 N2FP FNSTSW
1 $020 N2FP FNSTENV 5 $030 N2FP FNSAVE
: W2FPF $09B C, N2FPF ; \ Generate a WAIT before the instruction.
: W2FP CREATE C, C, DOES> ['] W2FPF A;! A; ;
1 $038 W2FP FSTCW 5 $038 W2FP FSTSW
1 $020 W2FP FSTENV 5 $030 W2FP FSAVE
: 2FP
CREATE C, C,
DOES> ['] N2FPF A;! A; COMP-WAIT ;
WARNING OFF
1 $028 2FP FLDCW 1 $020 2FP FLDENV 5 $020 2FP FRSTOR
WARNING ON
: 3FPF
FPSTACK? [ FORTH ]
IF DUP 2+ C@ ESC, 1+ C@ RS@ OR C,
ELSE MF 1 OR ESC, C@ <FW> @ 7 >
IF $010 AND <FW> @ $028 AND OR THEN
M/RS,
THEN RESET ;
: 3FP
CREATE C, C, C,
DOES> ['] 3FPF A;! A; COMP-WAIT ;
01 $0C0 $000 3FP FLD
05 $0D8 $018 3FP FSTP
: 4FPF
[ FORTH ] DUP 1+ C@ ESC, C@ RS@ OR C, RESET ;
: 4FP
CREATE C, C,
DOES> ['] 4FPF A;! A; COMP-WAIT ;
01 $0C8 4FP FXCH
05 $0C0 4FP FFREE
: 5FPF
6 ESC, C@ RD@ [ FORTH ] OR C, RESET ;
: 5FP
CREATE C, DOES> ['] 5FPF A;! A; COMP-WAIT ;
$0C0 5FP FADDP
$0C8 5FP FMULP
$0E0 5FP FSUBP
$0E8 5FP FSUBRP
$0F0 5FP FDIVP
$0F8 5FP FDIVRP
: 6FPF
FPSTACK? [ FORTH ]
IF DUP C@ ESC, 1+ C@ RS@ OR C,
ELSE DUP 1+ C@ 1 AND MF OR ESC, C@ $038 AND M/RS,
THEN RESET ;
: 6FP
CREATE C, C,
DOES> ['] 6FPF A;! A; COMP-WAIT ;
$0D0 $000 6FP FCOM
$0D8 $000 6FP FCOMP
$0D1 $010 6FP FST
: 7FPF
[ FORTH ] FPSTACK?
IF RD@ 0=
IF 0 ESC, C@ RS@ OR C,
ELSE 4 ESC, C@ RD@ OR C,
THEN
ELSE MF ESC, 1+ C@ M/RS,
THEN RESET ;
: 7FP
CREATE C, C,
DOES> ['] 7FPF A;! A; COMP-WAIT ;
$000 $0C0 7FP FADD
$008 $0C8 7FP FMUL
$020 $0E0 7FP FSUB
$028 $0E8 7FP FSUBR
$030 $0F0 7FP FDIV
$038 $0F8 7FP FDIVR
DECIMAL
: WSS: ( -- ) WAIT SS: NOWAIT ;
: WCS: ( -- ) WAIT CS: NOWAIT ;
: WDS: ( -- ) WAIT DS: NOWAIT ;
: WES: ( -- ) WAIT ES: NOWAIT ;
ONLY FORTH DEFINITIONS ALSO
\ .( ..Loaded)
\ CR .( F83 8087/80287 Floating point support..)
comment:
These screens load the higher level 8087 support words. The floating
point assembler must be loaded prior to these words.
Unless otherwise specified, real is in the Intel 8087 64-bit floating
point (REAL*8) format.
In this version, floating point numbers are stored on the 8087 internal
stack, with the overflow going to a separate external stack.
comment;
DEFER FPERR
\ ALSO HIDDEN DEFINITIONS
: 2/? ( n1 -- n2 n3 ) \ n2 is n1 shifted right by 1.
\ n3 is least significant bit of n1 .
DUP >R 2/ $7FFF AND R> 1 AND ;
CODE OR! ( n addr -- ) \ Logical OR of contents at addr with n
POP BX
POP AX
OR 0 [BX], AX
NEXT
END-CODE
CREATE FPSTAT 0 , 0 ,
: .FP. ( -- ) ." Floating Point " ;
: .NAME ( n -- ) >NAME .ID ;
: .NAMES ( n1 n2 -- ) .NAME 2 SPACES SPACE 3 - .NAME CR ;
: (FPERR) ( F: r -- r ; n1 n2 n3 -- ) \ n2 is CFA, n3 is error flag.
\ n1 is a possible return address on the parameter stack.
DUP FPSTAT OR! CR BELL EMIT
( 1 ) 2/? IF DROP .FP. ." Division by zero in " .NAMES EXIT THEN
( 2 ) 2/? IF DROP .FP. ." Overflow in " .NAMES EXIT THEN
( 4 ) 2/? IF DROP .FP. ." argument is negative for " .NAMES EXIT THEN
( 8 ) 2/? IF DROP .FP. ." argument is zero for " .NAMES EXIT THEN
( 10 ) 2/? IF DROP .FP. ." argument out of range for " .NAMES EXIT THEN
( 20 ) 2/? IF DROP .FP. ." Overflow for Input in " .NAMES EXIT THEN
( 40 ) 2/? IF DROP .FP. ." Overflow for Output in " .NAMES EXIT THEN
( 80 ) 2/? IF DROP ." Integer overflow for " .NAMES EXIT THEN
( 100) 2/? IF DROP .FP. ." Underflow in " .NAMES EXIT THEN
( 200) 2/? IF DROP .FP. ." argument inaccurate for " .NAMES EXIT THEN
( 400) 2/? IF DROP .FP. ." Underflow for Input in " .NAMES EXIT THEN
( 800) 2/? IF DROP .FP. ." Underflow for Ouput in " .NAMES EXIT THEN
( 1000) 2/? IF DROP .FP. ." results inaccurate for " .NAMES EXIT THEN
( 2000) 2/? IF DROP .FP. ." stack underflow for " .NAMES EXIT THEN
( 4000) 2/? IF DROP .FP. ." stack overflow for " .NAMES EXIT THEN
IF ." Unspecified Error " THEN
DROP QUIT ;
' (FPERR) IS FPERR
CODE INITFP ( -- )
FINIT
WAIT
FDISI
WAIT
NEXT
END-CODE
CODE CLEARFP ( -- )
FCLEX
NEXT
END-CODE
64 CONSTANT FSTACK-SIZE
CREATE FSTACK FSTACK-SIZE 1+ 8* ALLOT 0 , 0 , 0 , 0 ,
FSTACK FSTACK-SIZE 8 * + CONSTANT FSP0
CREATE FLOAT-WORK 10 ALLOT
VARIABLE FVBOS \ Floating point Virtual Bottom of Stack
VARIABLE FVTOS \ Floating point Virtual Top of Stack
: FCLEAR ( -- )
FSP0 FVBOS ! FSP0 FVTOS ! INITFP ;
FCLEAR
CODE FDROP ( F: r -- )
CLEAR_LABELS
MOV AX, FVTOS
CMP AX, FVBOS
JAE 1 $
ADD AX, # 8
MOV FVTOS AX
FSTP REAL*8 ST(0)
NEXT
1 $: JNE 2 $
ADD AX, # 8
MOV FVTOS AX
MOV FVBOS AX
CMP AX, # FSP0
JA 2 $
NEXT
2 $: FINIT
FDISI
WAIT
MOV AX, # FSP0
MOV FVBOS AX
MOV FVTOS AX
MOV BX, # LAST @ NAME>
PUSH BX
MOV AX, # $2000
PUSH AX
MOV AX, # ' FPERR
JMP AX
END-CODE
GLOBAL_REF
LABEL (1VLOAD) \ If NPU stack is empty, load 1 oprnd from mem.
CLEAR_LABELS
MOV BX, FVBOS
CMP BX, FVTOS
JE 1 $
RET
1 $: CMP BX, # FSP0
JAE 2 $
FLD REAL*8 0 [BX]
ADD BX, # 8
MOV FVBOS BX
WAIT
RET
2 $: MOV AX, ES: -2 [SI]
PUSH AX
MOV AX, # $2000
PUSH AX
MOV AX, # ' FPERR
JMP AX
END-CODE
LABEL (2VLOAD) \ Possible load from memory stack up to 2 opnds.
MOV BX, FVBOS
MOV AX, FVTOS
CMP BX, AX
JE 3 $
ADD AX, # 8
CMP BX, AX
JE 4 $
RET
3 $: CMP BX, # FSP0 10 -
JA 2 $
FLD REAL*8 8 [BX]
FLD REAL*8 0 [BX]
ADD BX, # $10
MOV FVBOS BX
WAIT
RET
4 $: CMP BX, # FSP0 8 -
JA 2 $
FINCSTP
FINCSTP
FLD REAL*8 0 [BX]
FDECSTP
ADD BX, # 8
MOV FVBOS BX
WAIT
RET
END-CODE
CODE 1VLOAD
CALL (1VLOAD)
NEXT
END-CODE
LABEL (3VLOAD)
CLEAR_LABELS
MOV BX, FVBOS
MOV AX, FVTOS
ADD AX, # $18
CMP BX, AX
JB 4 $
RET
4 $: FINCSTP
FINCSTP
FINCSTP
SUB AX, # 8
CMP BX, AX
JE 2 $
SUB AX, # 8
JE 1 $
CMP BX, # FSP0 $18 +
JA 3 $
FLD $10 [BX] \ We need to load 3 fp words from virtual
FLD 8 [BX]
FLD 0 [BX]
ADD WORD FVBOS # $18
WAIT
RET
2 $: CMP BX, # FSP0 $10 +
JA 3 $
FLD 8 [BX]
FLD 0 [BX]
FDECSTP
ADD WORD FVBOS # $10
WAIT
RET
1 $: CMP BX, # FSP0 8 +
JA 3 $
FLD 0 [BX]
FDECSTP
FDECSTP
ADD WORD FVBOS # 8
RET
3 $: MOV AX, ES: -2 [SI]
PUSH AX
MOV AX, # $2000
PUSH AX
MOV AX, # ' FPERR
JMP AX
END-CODE
LABEL (1VEMPTY)
CLEAR_LABELS
1 $: MOV BX, FVTOS
ADD BX, # $40
CMP BX, FVBOS
JE 2 $
RET
2 $: CMP BX, # FSTACK
JB 4 $
FDECSTP
SUB BX, # 8
MOV FVBOS BX
FSTP REAL*8 0 [BX]
WAIT
RET
4 $: MOV AX, ES: -2 [SI]
PUSH AX
MOV AX, # $4000
PUSH AX
MOV AX, # ' FPERR
JMP AX
END-CODE
LABEL (1VL1VE) \ Equivalent to (1VLOAD) followed by (1VEMPTY)
MOV BX, FVBOS
CMP BX, FVTOS
JNE 1 $
CMP BX, # FSP0
JAE 3 $
FLD REAL*8 0 [BX]
ADD BX, # 8
MOV FVBOS BX
WAIT
JMP 1 $
3 $: MOV AX, ES: -2 [SI]
PUSH AX
MOV AX, # $2000
PUSH AX
MOV AX, # ' FPERR
JMP AX
END-CODE
LABEL (2VEMPTY)
MOV BX, FVTOS
ADD BX, # $40
MOV AX, FVBOS
CMP BX, AX
JE 6 $
SUB BX, # 8
CMP BX, AX
JE 5 $
RET
5 $: CMP BX, # FSTACK
JB 4 $
FDECSTP
FDECSTP
SUB BX, # 8
MOV FVBOS BX
FSTP REAL*8 0 [BX]
FINCSTP
RET
6 $: CMP BX, # FSTACK 8 +
JB 4 $
FDECSTP
FDECSTP
SUB BX, # $10
MOV FVBOS BX
FSTP 0 [BX]
FSTP 8 [BX]
WAIT
RET
END-CODE
LOCAL_REF
CODE F! ( F: r -- ; addr -- )
CALL (1VLOAD)
POP BX
FSTP REAL*8 0 [BX]
ADD FVTOS # 8 WORD
WAIT
NEXT
END-CODE
CODE F@ ( F: -- r ; addr -- )
CALL (1VEMPTY)
POP BX
FLD REAL*8 0 [BX]
SUB FVTOS # 8 WORD
WAIT
NEXT
END-CODE
: FCONSTANT ( F: r -- ) ( compiling)
( F: -- r ) ( run-time )
CREATE HERE 8 ALLOT F!
DOES> F@ ;
: FVARIABLE ( -- ) ( compiling)
( -- addr ) ( run-time )
CREATE 8 ALLOT
DOES> ;
CODE FP>DI ( F: r -- ; -- 32b )
SUB SP, # 4
MOV BX, SP
FRNDINT
FSTP INTEGER*4 0 [BX]
WAIT
ADD WORD FVTOS # 8
NEXT
END-CODE
CODE FP>QI ( F: r -- ; -- 64b)
CALL (1VLOAD)
SUB SP, # 8
MOV BX, SP
FRNDINT
FSTP INTEGER*8 0 [BX]
WAIT
ADD WORD FVTOS # 8
NEXT
END-CODE
CODE QI>FP ( F: -- r ; 64b -- )
CALL (1VEMPTY)
MOV BX, SP
FLD INTEGER*8 0 [BX]
WAIT
ADD SP, # 8
SUB WORD FVTOS # 8
NEXT
END-CODE
CODE FPSW> ( -- n )
SUB SP, # 2
MOV BX, SP
FSTSW 0 [BX]
WAIT
NEXT
END-CODE
CODE FEXAM ( F: r -- r ; -- n )
CLEAR_LABELS
MOV BX, FVBOS
CMP BX, # FSP0
JAE 1 $
CALL (1VLOAD)
1 $: FXAM
SUB SP, # 2
MOV BX, SP
FSTSW 0 [BX]
WAIT
AND 0 [BX], # $4700 WORD
NEXT
END-CODE
CODE FPCW> ( -- n )
SUB SP, # 2
MOV BX, SP
FSTCW 0 [BX]
WAIT
NEXT
END-CODE
CODE >FPCW ( n -- )
MOV BX, SP
FLDCW 0 [BX]
ADD SP, # 2
WAIT
NEXT
END-CODE
CODE >FREGS ( addr -- )
POP BX
WAIT
FRSTOR 0 [BX]
WAIT
NEXT
END-CODE
CODE >FREGS> ( addr -- )
POP BX
WAIT
FSAVE 0 [BX]
FRSTOR 0 [BX]
WAIT
NEXT
END-CODE
CODE PI ( F: -- pi )
CALL (1VEMPTY)
FLDPI
SUB FVTOS # 8 WORD
NEXT
END-CODE
CODE F1.0 ( F: -- 1.0 )
CALL (1VEMPTY)
FLD1
SUB FVTOS # 8 WORD
NEXT
END-CODE
CODE F0.0 ( F: -- 0.0 )
CALL (1VEMPTY)
FLDZ
SUB FVTOS # 8 WORD
NEXT
END-CODE
CODE F* ( F: r1 r2 -- r1*r2)
CALL (2VLOAD)
FMULP ST(1), ST
ADD FVTOS # 8 WORD
NEXT
END-CODE
CODE F+ ( F: r1 r2 -- r1+r2)
CALL (2VLOAD)
FADDP ST(1), ST
ADD FVTOS # 8 WORD
NEXT
END-CODE
CODE F- ( F: r1 r2 -- r1-r2)
CALL (2VLOAD)
FSUBRP ST(1), ST(0)
ADD WORD FVTOS # 8
NEXT
END-CODE
CODE F\- ( F: r1 r2 -- r1-r2)
CALL (2VLOAD)
FSUBP ST(1), ST(0)
ADD WORD FVTOS # 8
NEXT
END-CODE
CODE F/ ( F: r1 r2 -- r1/r2)
CALL (2VLOAD)
FDIVRP ST(1), ST(0)
ADD WORD FVTOS # 8
NEXT
END-CODE
CODE FABS ( F: r1 -- |r1|)
CALL (1VLOAD)
FABS,
NEXT
END-CODE
CODE FNEGATE ( F: r1 -- -r1 )
CALL (1VLOAD)
FCHS
NEXT
END-CODE
CODE FSQRT ( F: r1 -- SQRT[r1])
CALL (1VLOAD)
FSQRT,
NEXT
END-CODE
CODE FLOG ( F: r1 -- LOG10[r1])
CALL (1VL1VE)
FLDLG2
FXCH ST(1)
FYL2X
NEXT
END-CODE
CODE FLN ( F: r1 -- LN[r1])
CALL (1VL1VE)
FLDLN2
FXCH ST(1)
FYL2X
NEXT
END-CODE
CODE 1/F ( F: r -- r^-1)
CALL (1VL1VE)
FLD1
FDIVP ST(1), ST(0)
NEXT
END-CODE
CODE F2* ( F: r1 -- r2 )
CALL (1VL1VE)
FLD1
FXCH ST(1)
FSCALE
NEXT
END-CODE
CODE F2/ ( F: r1 -- r2 )
CALL (1VL1VE)
CALL (1VEMPTY)
FLD1
FCHS
FXCH ST(1)
FSCALE
NEXT
END-CODE
CODE F2**N* ( F: r1 -- r2 ; n -- )
CALL (1VL1VE)
MOV BX, SP
FLD INTEGER*2 0 [BX]
ADD SP, # 2
FXCH ST(1)
FSCALE
NEXT
END-CODE
CODE FLOAT ( F: -- r ; d -- )
CALL (1VEMPTY)
MOV BX, SP
MOV AX, 0 [BX]
MOV CX, 2 [BX]
MOV 2 [BX], AX
MOV 0 [BX], CX
FLD INTEGER*4 0 [BX]
ADD SP, # 4
SUB FVTOS # 8 WORD
WAIT
NEXT
END-CODE
: (ROUND) ( F: r -- ; n -- d )
FPCW> DUP >R $F3FF AND OR >FPCW
1VLOAD FP>DI SWAP R> >FPCW ;
: FIX ( F: r -- ; -- d ) $0000 (ROUND) ;
: INT ( F: r -- ; -- d ) $0C00 (ROUND) ;
: RND>+INF ( F: r -- ; -- d ) $0800 (ROUND) ;
: RND>-INF ( F: r -- ; -- d ) $0400 (ROUND) ;
CODE FDUP ( F: r -- r r )
CALL (1VL1VE)
FLD ST
SUB FVTOS # 8 WORD
NEXT
END-CODE
CODE FOVER ( F: r1 r2 -- r1 r2 r1 )
CALL (2VLOAD)
CALL (1VEMPTY)
FLD ST(1)
SUB FVTOS # 8 WORD
NEXT
END-CODE
CODE FSWAP ( F: r1 r2 -- r2 r1 )
CALL (2VLOAD)
FXCH ST(1)
NEXT
END-CODE
CODE FNSWAP ( F: rn rn-1 ... r1 r0 -- r0 rn-1 ... r1 rn ; n -- )
CLEAR_LABELS
CALL (1VLOAD)
POP BX
SHL BX, 1
JZ 10 $
SHL BX, 1
SHL BX, 1
MOV CX, FVTOS
MOV AX, FVBOS
SUB AX, CX
CMP BX, AX
JA 8 $
CMP BX, # 4 8 *
JA 6 $
JB 2 $
FXCH ST(4)
10 $: RET
2 $: CMP BX, # 2 8 *
JB 1 $
JA 3 $
FXCH ST(2)
RET
1 $: FXCH ST(1)
RET
3 $: FXCH ST(3)
RET
6 $: CMP BX, # 6 8 *
JB 5 $
JA 7 $
FXCH ST(6)
RET
5 $: FXCH ST(5)
RET
7 $: FXCH ST(7)
RET
8 $: ADD BX, CX
FSTP REAL*8 FLOAT-WORK
FLD REAL*8 0 [BX]
MOV BX, CX
MOV DI, # 7
9 $: MOV AL, FLOAT-WORK [DI]
MOV 0 [BX+DI], AL
DEC DI
JNS 9 $
RET
END-CODE
CODE FROT ( F: r1 r2 r3 -- r2 r3 r1 )
CALL (3VLOAD)
FXCH ST(1) \ r1 r3 r2
FXCH ST(2) \ r2 r3 r1
NEXT
END-CODE
CODE F-ROT ( F: r1 r2 r3 -- r3 r1 r2 )
CALL (3VLOAD)
FXCH ST(2) \ r3 r2 r1
FXCH ST(1) \ r3 r1 r2
NEXT
END-CODE
CODE FNIP ( F: r1 r2 -- r2 )
CALL (2VLOAD)
FXCH ST(1)
FSTP ST(0)
ADD WORD FVTOS # 8
NEXT
END-CODE
CODE FTUCK ( F: r1 r2 -- r2 r1 r2 )
CALL (2VLOAD)
CALL (1VEMPTY)
FXCH ST(1) \ r2 r1
FLD ST(1)
SUB WORD FVTOS # 8
NEXT
END-CODE
CODE FPICK ( F: rn ... r1 r0 -- rn ... r1 r0 rn ; n -- )
CLEAR_LABELS
CALL (1VEMPTY)
POP BX
SHL BX, 1
SHL BX, 1
SHL BX, 1
MOV CX, FVTOS
MOV AX, FVBOS
SUB WORD FVTOS # 8
SUB AX, CX
CMP BX, AX
JAE 8 $
CMP BX, # 3 8 *
JA 5 $
JB 1 $
FLD ST(3)
NEXT
1 $: CMP BX, # 1 8 *
JB 0 $
JA 2 $
FLD ST(1)
NEXT
0 $: FLD ST(0)
NEXT
2 $: FLD ST(2)
NEXT
5 $: CMP BX, # 5 8 *
JB 4 $
JA 6 $
FLD ST(5)
NEXT
4 $: FLD ST(4)
NEXT
6 $: FLD ST(6)
NEXT
8 $: ADD BX, CX
FLD REAL*8 0 [BX]
NEXT
END-CODE
CODE (RVS0) ( F: r -- ; -- fpsw )
CALL (1VLOAD)
FTST
SUB SP, # 2
MOV BX, SP
FSTSW 0 [BX]
FSTP ST(0)
ADD WORD FVTOS # 8
WAIT
NEXT
END-CODE
: C3C0X ( fpsw -- n )
DUP $04000 AND
IF 2
ELSE 0
THEN
SWAP $00100 AND
IF 1+
THEN ;
: F0= ( F: r -- ; -- f )
(RVS0) C3C0X 2 = ;
: FDUP0= ( F: r -- r ; -- f )
FDUP F0= ;
: F0< ( F: r -- ; -- f) (RVS0) C3C0X 1 = ;
: F0> ( F: r -- ; -- f) (RVS0) C3C0X 0= ;
CODE (RVSR) ( F: r1 r2 -- ; -- fpsw )
CALL (2VLOAD)
FXCH ST(1)
FCOMPP
ADD WORD FVTOS # $10
SUB SP, # 2
MOV BX, SP
FSTSW 0 [BX]
WAIT
NEXT
END-CODE
: F= ( F: r1 r2 -- ; -- f )
(RVSR) C3C0X 2 = ;
: F< ( F: r1 r2 -- ; -- f )
(RVSR) C3C0X 1 = ;
: F> ( F: r1 r2 -- ; -- f )
(RVSR) C3C0X 0= ;
: FMIN ( F: r1 r2 -- rmin )
FOVER FOVER F<
IF FDROP
ELSE
FNIP
THEN ;
: FMAX ( F: r1 r2 -- rmax )
FOVER FOVER F>
IF FDROP
ELSE
FNIP
THEN ;
CODE (FLIT) ( F: -- r )
CALL (1VEMPTY)
FLD REAL*8 ES: 0 [SI]
SUB WORD FVTOS # 8
WAIT
ADD SI, # 8
NEXT
END-CODE
: FLITERAL ( F: r -- )
COMPILE (FLIT) FLOAT-WORK F!
4 0 DO
FLOAT-WORK I 2* + @ X,
LOOP
; IMMEDIATE
VARIABLE TRIG-MODE TRIG-MODE OFF
: DEGREES ( -- )
TRIG-MODE ON ;
: RADIANS ( -- )
TRIG-MODE OFF ;
PI F2* FCONSTANT 2PI
PI F2/ F2/ FCONSTANT PI/4
PI F2/ FCONSTANT PI/2
: DEG->RAD ( F: r1 -- r2 )
[ 180. FLOAT ] FLITERAL F/
PI F* ;
: RAD->DEG ( F: r1 -- r2 )
[ 180. FLOAT ] FLITERAL F*
PI F/ ;
INITFP CLEARFP
CODE [SIN] ( F: r -- sin<r> )
CALL (1VLOAD) \ radian argument
CALL (2VEMPTY)
FLD1 \ Load F1.0
FCHS
FXCH ST(1)
FSCALE \ arg/2
FXCH ST(1)
FSTP ST(0)
FPTAN \ Partial tangent -> y, x
FXCH ST(1)
FDIVRP ST(1), ST(0) \ y/x
FLD ST(0) \ dup
FLD ST(0) \ dup
FMULP ST(1), ST(0)
FLD1
FADDP ST(1), ST(0) \ 1 + (y/x)**2
FXCH ST(1)
FLD1
FLD ST(0)
FADDP ST(1), ST(0) \ 2.0
FMULP ST(1), ST(0) \ 2(y/x)
FDIVP ST(1), ST(0) \ 2(y/x)/(1+(y/x)**2)
NEXT
END-CODE
CODE [COS] ( F: r -- cos<r> )
CALL (1VLOAD)
CALL (2VEMPTY)
FLD1
FCHS
FXCH ST(1)
FSCALE
FXCH ST(1)
FSTP ST(0)
FPTAN
FXCH ST(1)
FDIVRP ST(1), ST(0)
FLD ST(0)
FMULP ST(1), ST(0)
FLD ST(0)
FLD1
FADDP ST(1), ST(0)
FXCH ST(1)
FLD1
FSUBRP ST(1), ST(0)
FDIVP ST(1), ST(0)
NEXT
END-CODE
CODE [TAN] ( F: r -- tan<r> )
CALL (1VL1VE)
FPTAN
FXCH ST(1)
FDIVP ST(1), ST(0)
NEXT
END-CODE
: ?DEG->RAD ( F: r1 -- r2 )
TRIG-MODE @
IF DEG->RAD THEN ;
F1.0 -53 F2**N* FCONSTANT SMALL-ANGLE
: FSIN1 ( F: r1 -- r2 )
FDUP SMALL-ANGLE F>
IF [SIN] THEN ;
: FCOS1 ( F: r1 -- r2 )
FDUP SMALL-ANGLE F>
IF [COS]
ELSE FDROP F1.0
THEN ;
: FSIN ( F: r -- SIN<r> )
?DEG->RAD FDUP F0< FABS
FDUP PI/4 F/ INT 2DUP FLOAT PI/4 F* F- DROP
DUP 2/ 2/ 1 AND NEGATE SWAP 3 AND
DUP 0 = IF DROP FSIN1 ELSE
DUP 1 = IF DROP PI/4 FSWAP F- FCOS1 ELSE
2 = IF FCOS1 ELSE
PI/4 FSWAP F- FSIN1
THEN THEN THEN
XOR IF FNEGATE THEN ;
: FCOS ( F: r -- COS<r> )
?DEG->RAD
FABS FDUP PI/4 F/ INT 2DUP FLOAT PI/4 F* F- DROP
DUP 3 AND
DUP 0 = IF DROP FCOS1 ELSE
DUP 1 = IF DROP PI/4 FSWAP F- FSIN1 ELSE
2 = IF FSIN1 ELSE
PI/4 FSWAP F- FCOS1
THEN THEN THEN
2+ 2/ 2/ 1 AND
IF FNEGATE THEN ;
F0.0 1/F FCONSTANT INFINITY
: FINFINITY= ( F: r1 -- ; -- flag )
1VLOAD FEXAM FDROP $0D00 AND $0500 = ;
FCLEAR
: FTAN1 ( F: r1 -- r2 )
FDUP SMALL-ANGLE F>
IF [TAN] THEN ;
: TANARG<>0 ( F: r -- TAN<r> ; n -- )
[ FORTH ] 4 MOD
DUP 0 = IF DROP FTAN1 EXIT THEN
DUP 1 = IF DROP PI/4 FSWAP F- FTAN1 1/F EXIT THEN
DUP 2 = IF DROP FTAN1 FNEGATE 1/F EXIT THEN
DUP 3 = IF DROP PI/4 FSWAP F- FTAN1 FNEGATE EXIT THEN ;
: TANARG=0 ( F: -- TAN<r> ; n -- )
[ FORTH ] 4 MOD
DUP 0 = IF DROP F0.0 EXIT THEN
DUP 1 = IF DROP F1.0 EXIT THEN
DUP 2 = IF DROP INFINITY EXIT THEN
DUP 3 = IF DROP F1.0 FNEGATE EXIT THEN ;
: FTAN ( F: r -- TAN<r> )
?DEG->RAD FDUP F0< FABS
FDUP PI/4 F/ INT 2DUP FLOAT PI/4 F* F- DROP 4 MOD
FDUP F0=
IF FDROP TANARG=0
ELSE TANARG<>0 THEN
IF FNEGATE THEN ;
ASSEMBLER ALSO
LABEL (POWER) ( F: log2x y -- x^y )
FMULP ST(1), ST(0) \ x * y
FLD ST(0) \ DUP
FSTCW FLOAT-WORK \ Save current Control Word
MOV AX, FLOAT-WORK
MOV CX, AX
AND AX, # $0F3FF
OR AX, # $00400 \ Round toward neg. inf.
MOV FLOAT-WORK AX
FLDCW FLOAT-WORK
FRNDINT \ Take floor of x*y
MOV FLOAT-WORK CX
FLDCW FLOAT-WORK \ Restore Control word.
FST REAL*8 FLOAT-WORK \ Save copy of floored value.
FXCH ST(1)
FSUBP ST(1), ST(0) \ (x*y) - floor(x*y) -> fract
FLD1
FCHS
FXCH ST(1)
FSCALE \ fract/2
FXCH ST(1)
FSTP ST(0) \ Remove the -1.
F2XM1 \ 2^(fract/2) - 1
FLD1
FADDP ST(1), ST(0) \ 2^(fract/2)
FLD ST(0) \ DUP
FMULP ST(1), ST(0) \ 2^fract
FLD REAL*8 FLOAT-WORK
FXCH ST(1)
FSCALE \ 2^(x*y)
FXCH ST(1)
FSTP ST(0) \ Remove the floored value.
RET
END-CODE
PREVIOUS FORTH
CODE (FALN) ( F: r -- e^r )
CALL (1VL1VE)
FLDL2E
CALL (POWER)
NEXT
END-CODE
CODE (FALOG) ( F: r -- 10^r )
CALL (1VL1VE)
FLDL2T
CALL (POWER)
NEXT
END-CODE
: FEXP ( F: r -- e^r )
FDUP 699. FLOAT F>
IF ." FALN ARGUMENT TOO LARGE" FDROP QUIT
THEN
(FALN) ;
: FALN FEXP ;
: FALOG ( F: r -- 10^r )
FDUP 304. FLOAT F>
IF ." FALOG ARGUMENT TOO LARGE" FDROP QUIT
THEN
(FALOG) ;
: FLOATDPL ( F: -- r ; d -- ) \ Float a double, using DPL
FLOAT DPL @ 0 FLOAT FALOG F/ ;
: F** ( F: r1 r2 -- r1^r2 )
FSWAP FLOG F* FALOG ;
CREATE (PI/2) $18 C, $2D C, $44 C, $54 C, $FB C, $21 C, $F9 C, $FF C,
ASSEMBLER ALSO
LABEL (FATAN) ( F: z -- arctan )
FLD1
FCOM ST(1)
FSTSW FLOAT-WORK
MOV AX, FLOAT-WORK
AND AX, # $04100
0=
IF
FPATAN
ELSE
FXCH ST(1)
FPATAN
FLD REAL*8 (PI/2)
FSUBP ST(1), ST(0)
THEN
RET
END-CODE
PREVIOUS FORTH
CODE FATAN ( F: r -- arctan[r] )
CALL (1VL1VE)
FTST
FSTSW FLOAT-WORK
MOV AX, FLOAT-WORK
AND AX, # $04100
SUB AX, # $00100
0=
IF
FCHS
CALL (FATAN)
FCHS
ELSE
CALL (FATAN)
THEN
NEXT
END-CODE
: ARCRANGE ( F: r -- r ; -- f )
FDUP F1.0 F> FDUP F1.0 FNEGATE F< OR ;
: FASIN ( F: r -- arcsin[r] )
ARCRANGE
IF FDROP ." INVALID FASIN ARGUMENT" QUIT
ELSE
FDUP F0< FABS F1.0 FOVER FDUP F* F- FSQRT
F/ FATAN
IF FNEGATE THEN
THEN ;
: FACOS ( F: r -- arccos[r] )
ARCRANGE
IF FDROP ." INVALID FACOS ARGUMENT" QUIT
ELSE FDUP F0< FABS F1.0 FOVER FDUP F* F- FSQRT
FSWAP F/ FATAN
IF PI FSWAP F-
THEN
THEN ;
: XVALUE
CREATE , DOES> @ ;
FALSE VALUE FP?
: FLOATS ( -- )
TRUE IS FP? ;
: DOUBLES ( -- )
FALSE IS FP? ;
VARIABLE EXP? EXP? OFF
VARIABLE FLOATING FLOATING OFF
: FLOATING?
FLOATING @ ;
: (FP-CHECK) ( f addr -- f' addr )
[ FORTH ] DUP C@ DUP ASCII e =
IF DROP ASCII E OVER C! EXP? ON EXIT
THEN
DUP ASCII 0 ASCII 9 BETWEEN
IF DROP EXIT THEN
DUP ASCII E =
IF DROP EXP? ON EXIT THEN
DUP ASCII - =
IF DROP EXIT THEN
DUP ASCII + =
IF DROP EXIT THEN
ASCII . =
IF EXIT THEN
NIP 0 SWAP ;
: FP-CHECK ( addr -- addr f )
EXP? OFF DUP TRUE SWAP COUNT BOUNDS
DO
I (FP-CHECK) DROP
LOOP ;
CODE FMUL10 ( F: r1 -- r2 )
CALL (1VL1VE)
MOV FLOAT-WORK # 10 WORD
FLD INTEGER*2 FLOAT-WORK
FMULP ST(1), ST(0)
NEXT
END-CODE
CODE (FADDI) ( F: r1 -- r2 ; n -- )
CALL (1VL1VE)
MOV BX, SP
FLD INTEGER*2 0 [BX]
FADDP ST(1), ST(0)
ADD SP, # 2
NEXT
END-CODE
: QCONVERT ( +q1 adr1 -- +q2 adr2 )
>R QI>FP R>
BEGIN
1+ DUP >R C@ 10 DIGIT
WHILE
FMUL10 (FADDI) DOUBLE? IF 1 DPL +! THEN R>
REPEAT
DROP FP>QI R> ;
CODE QNEGATE ( +q -- -q )
MOV BX, SP
FLD 0 [BX] INTEGER*8
FCHS
FSTP 0 [BX]
NEXT
END-CODE
: QFLOAT ( F: -- r ; q -- )
DPL @ 0 MAX DPL !
QI>FP ( FP>R ) DPL @ S>D FLOAT FALOG F/ ;
: (MANTISSA) ( F: -- r ; addr1 -- addr2 )
DUP 1+ C@ ASCII + = ?MISSING ( lead "+" invalid)
DUP 1+ C@ ASCII - = DUP >R IF 1+ THEN ( check for lead "-")
-1 DPL ! >R 0 0 0 0 R>
BEGIN
QCONVERT DUP C@ ASCII . = ( convert till "E" )
WHILE
0 DPL ! ( reset DPL at "." )
REPEAT
R> SWAP >R
IF QNEGATE
THEN
QFLOAT R> ; ( set sign and float )
: (EXP) ( addr -- d )
1+ DUP C@ ASCII + =
IF 1+ THEN ( bypass "+" if present)
DUP C@ ASCII - = DUP >R
IF 1+ THEN ( check for "-")
0 DPL ! 0 0 ROT 1- CONVERT DROP ( convert it )
2DUP 308. DU< 0= ?MISSING R>
IF DNEGATE THEN 0 DPL ! ;
: FNUMBER ( addr -- r | n | d | ; )
[ FORTH ] FLOATING OFF FP-CHECK EXP? @ AND BASE @ 10 = AND 0=
IF ( not a valid FP, valid # ?)
(NUMBER) DOUBLE?
IF
FP? ( was double, if in FP mode, float it)
IF FLOATDPL FLOATING ON THEN
THEN
ELSE ( has exponent, so convert it)
(MANTISSA) (EXP) FLOAT FALOG F* DPL OFF FLOATING ON
THEN ;
' FNUMBER IS NUMBER
: F] ( -- )
STATE ON
BEGIN
?STACK DEFINED DUP
IF 0>
IF EXECUTE
ELSE X,
THEN
ELSE
DROP NUMBER FLOATING?
IF
[COMPILE] FLITERAL ELSE DOUBLE?
IF
[COMPILE] DLITERAL
ELSE
DROP [COMPILE] LITERAL
THEN
THEN
THEN
TRUE DONE?
UNTIL ;
' F] IS ]
: FMAG ( F: r -- r ; -- n )
FDUP FABS FLOG RND>-INF DROP ;
CREATE FLOAT-BCD 10 ALLOT
VARIABLE #BCD 17 #BCD !
CODE R>BCD! ( F: r -- ; n -- ; full precision bcd-string to FLOAT-BCD )
CALL (1VLOAD)
CALL (2VEMPTY)
MOV AX, #BCD
POP CX
SUB AX, CX
DEC AX WORD
PUSH AX
MOV BX, SP
FLD INTEGER*2 0 [BX]
ADD SP, # 2
FLDL2T
CALL (POWER)
FMULP ST(1), ST(0)
FSTP FLOAT-BCD BCD
WAIT
ADD WORD FVTOS # 8
NEXT
END-CODE
: .DIGITS ( last first -- )
2DUP > ABORT" FP I/O error. "
DO I 1- 2/ FLOAT-BCD + C@ 16 /MOD I 2 MOD
IF DROP ELSE NIP THEN
ASCII 0 + EMIT
-1 +LOOP ;
: FULL2 ( n -- )
0 <# # # #> TYPE ;
CREATE (I10) 10 ,
CODE FIXBCD ( n1 -- n2 | FLOAT-BCD possibly changed )
CLEAR_LABELS
CALL (2VEMPTY)
MOV AL, FLOAT-BCD 8 +
CMP AL, # $10
JB 1 $
MOV BX, SP
INC 0 [BX] WORD
FLD BCD FLOAT-BCD
FLD INTEGER*2 (I10)
FDIVRP ST(1), ST(0)
FSTP BCD FLOAT-BCD
WAIT
1 $: NEXT
END-CODE
: F.SPECIAL ( F: r -- ; cc n -- ) \ Display special f-p numbers.
SWAP DUP $0100 AND 0=
IF FDROP DROP SPACES EXIT THEN
DUP $4000 >
IF DROP " EMPTY"
ELSE DUP $0200 AND IF ." -" ELSE ." +" THEN
$0400 >
IF FDROP " INFINITY"
ELSE FLOAT-WORK F! FLOAT-WORK 2@ D0= >R
FLOAT-WORK 4 + 2@ SWAP
$7FFF AND 0 $7FF8 D= R> AND
IF " INDEFINITE" ELSE " NAN" THEN
THEN
THEN
ROT $.R ;
: E. ( F: r -- )
FEXAM DUP $0100 AND
IF 24 F.SPECIAL EXIT THEN
$4500 AND $4000 =
IF FDROP SPACE ." .00000000000000000E+00 " EXIT THEN
FMAG DUP R>BCD! FIXBCD FLOAT-BCD 9 + C@
IF ASCII - ELSE BL THEN
EMIT ASCII . EMIT
1 17 .DIGITS ASCII E EMIT 1+ DUP 0<
IF ASCII - ELSE ASCII + THEN
EMIT ABS DUP 99 <
IF FULL2 SPACE ELSE . THEN ;
VARIABLE #PLACES
: PLACES ( n -- )
17 MIN 1 MAX #PLACES ! ;
4 PLACES
CODE FPARSE ( F: r -- int-part frac-part )
CALL (1VLOAD)
CALL (2VEMPTY)
FLD ST0
FSTCW FLOAT-WORK
MOV AX, FLOAT-WORK
MOV CX, AX
OR AX, # $00C00
MOV FLOAT-WORK AX
FLDCW FLOAT-WORK
FRNDINT
MOV FLOAT-WORK CX
FLDCW FLOAT-WORK
FXCH ST(1)
FLD ST(1)
FSUBP ST1, ST0
SUB WORD FVTOS # 8
WAIT
NEXT
END-CODE
: .INT ( F: r -- )
FDUP F0=
IF
FDROP ASCII 0 EMIT
ELSE
#BCD @ DUP FMAG DUP R>BCD!
FIXBCD - SWAP .DIGITS
THEN ;
CREATE (F2.0) 0 , 0 , 0 , $4000 ,
CODE FRNDFRC ( F: +r1 -- +r2 )
CALL (1VLOAD)
CALL (2VEMPTY)
FLD INTEGER*2 #PLACES
FCHS
FLDL2T
CALL (POWER)
FLD REAL*8 (F2.0)
FDIVRP ST(1), ST(0)
FADDP ST(1), ST(0)
NEXT
END-CODE
: .FRAC ( F: r -- )
FDUP F0=
IF
FDROP #PLACES @ 0
DO ASCII 0 EMIT
LOOP
ELSE
-1 R>BCD! #BCD @ DUP #PLACES @ 1- - SWAP .DIGITS
THEN ;
: F. ( r -- )
FEXAM DUP $0100 AND
IF SPACE #PLACES @ 3 + F.SPECIAL EXIT THEN
DROP FDUP F0<
IF
ASCII - ELSE BL
THEN
EMIT FABS FPARSE FRNDFRC
FDUP INT FLOAT FROT F+ .INT ASCII . EMIT .FRAC SPACE ;
: E.R0 ( #dec #col -- )
OVER - 5 - SPACES ASCII . EMIT 0
DO
ASCII 0 EMIT
LOOP
." E+00" ;
: E.R# ( F: r -- ; #dec -- )
>R FDUP F0<
IF ASCII - ELSE BL THEN
EMIT ASCII . EMIT
FABS R> #PLACES @ >R PLACES FMAG DUP >R
1+ S>D FLOAT FALOG F/ FMAG >R FRNDFRC FMAG DUP R> - >R
R>BCD! #PLACES @ 17 DUP ROT - 1+ SWAP .DIGITS
ASCII E EMIT R> R> + 1+
DUP 0<
IF ASCII - ELSE ASCII + THEN
EMIT ABS DUP 100 <
IF FULL2 ELSE . THEN
R> PLACES ;
: E.R ( F: r -- ; #dec #col -- )
FEXAM DUP $0100 AND
IF -ROT NIP F.SPECIAL EXIT THEN
$4500 AND $4000 = \ Test for zero
IF FDROP E.R0 EXIT THEN
FDUP FABS FLOG FABS 100.E0 F< >R \ get exponent
2DUP SWAP - R@ IF 6 ELSE 7 THEN - 0< \ get # characters
IF
0 DO ASCII * EMIT LOOP DROP FDROP R> DROP \ too big, *'s
ELSE
OVER - R>
IF 6
ELSE 7
THEN
- SPACES E.R# \ ok, print it
THEN ;
: F.R0 ( #dec #col -- )
2DUP SWAP - 3 - 0<
IF
0 DO ASCII * EMIT LOOP
DROP
ELSE
OVER - 2- SPACES ." 0." 0
DO ASCII 0 EMIT LOOP
THEN ;
VARIABLE F.R+-
VARIABLE F.R#INT
: (F.R) ( |r| #dec #col -- +frac #dec )
F.R#INT @ - OVER - 2 - SPACES \ output lead blanks
F.R+- @
IF
ASCII -
ELSE
BL
THEN
EMIT \ output sign
>R FSWAP F.R#INT @ R>BCD! F.R#INT @ \ convert to BCD
#BCD @ DUP ROT - SWAP 1- .DIGITS R> ; \ output digits
: F.R ( F: r -- ; #dec #col -- )
FEXAM DUP $0100 AND
IF -ROT NIP F.SPECIAL EXIT THEN
$4500 AND $4000 = \ test for a zero
IF FDROP F.R0 EXIT THEN \ if found, handle specially
FDUP FINFINITY=
IF ." INFINITY " EXIT THEN
FDUP F0< F.R+- ! FDUP \ store the sign flag
FABS OVER #PLACES @ SWAP #PLACES !
>R FRNDFRC R> PLACES
\ round the number to the proper number of digits
FMAG 1+ 1 MAX DUP F.R#INT ! \ get exponent
>R 2DUP R> - SWAP - 2 - 0< \ get the digit count
IF
FDROP SPACE E.R \ too big, use E.R
ELSE
FNIP FPARSE (F.R) ASCII . EMIT \ output integer
>R 0 R>BCD! R> #BCD @ DUP ROT - SWAP 1- .DIGITS
THEN ; \ convert and output fractional part
: FDEPTH ( -- n )
FSP0 FVTOS @ - 8 / ;
: .FS ( -- )
FDEPTH ?DUP
IF CR 0
DO
FDEPTH I - 1- FPICK
8 ?LINE 3 10 F.R KEY? ?LEAVE
LOOP
ELSE ." Empty "
THEN ;
: ROUND ( F: r -- ; -- d )
FDUP F0>
IF RND>-INF
ELSE RND>+INF
THEN ;
: IFLOAT ( F: -- r ; n -- )
S>D FLOAT ;
: R>N ( F: r -- ; -- n )
ROUND ( INT ) DROP ;
( Like F>S in PLOT.BLK )
\ : F>S ( F: r -- ; -- n )
\ INT DROP ;
: F2DUP ( F: r1 r2 -- r1 r2 r1 r2 )
FOVER FOVER ;
: FMOD ( F: r1 r2 -- r3 )
F2DUP F/ INT FLOAT F* F- ;
: F, ( F: r -- )
HERE 8 ALLOT F! ;
: FARRAY ( Comp: rn ... r1 r0 n+1 -- ) ( Run: k -- rk_addr)
CREATE
DUP , 0 DO F, LOOP
DOES> ( index pfa )
SWAP DUP 0<
IF
DROP @
ELSE
8 * 2+ +
THEN ;
: ?FSTACK ( -- )
FVTOS @ FSP0 SWAP U<
IF FCLEAR TRUE ABORT" Floating Point Stack Underflow " THEN
FVTOS @ FSP0 FSTACK-SIZE 8 * - U<
IF FCLEAR TRUE ABORT" Floating point Stack Overflow " THEN
FPSW> DUP 1 AND
IF FCLEAR CR ." Invalid Floating Point Operation. " THEN
DUP 4 AND
IF FCLEAR CR ." Floating Point Divsion by zero. " THEN
8 AND
IF FCLEAR CR ." Floating Point Overflow. " THEN
(?STACK) ;
' ?FSTACK IS ?STACK
CREATE FR 94 ALLOT
: FFILL INITFP FR 14 + 80 -1 FILL FR >FREGS INITFP ;
: FR. ( -- )
FR >FREGS> BASE @ HEX CR 14 0
DO FR I + @ 0 <# # # # # #> SPACE TYPE 2 +LOOP
8 0 DO CR SPACE 10 0
DO FR 14 + J 10 * + I + C@ .2W LOOP
LOOP
CR ." FVTOS = " FVTOS @ H. ." FVBOS = " FVBOS @ H.
." FBASE = " FSP0 H. BASE ! ;
\ .( ..Loaded)