Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/FFB.ZIP/FFUTILS.ARC/SMITH.ARC/FLOAT.SEQ

Text File | 1987-12-12 | 35.5 KB | 1,578 lines

\ FLOAT.SEQ    Floating point for 8087    Enhancements by: Robert L. Smith
comment:
        Prepared by:

                 *******************
                 **  Mark Smiley  **
                 *******************

A fine blend of Steve Pollack's 8087 Assembler
and Floating-Point routines (from USER.BLK), combined with
R.L. Davies's Turtle Graphics (from GRAPHICS.BLK),
and Nathaniel Grossman's Polynomial Evaluation (from
FORTH Dimensions, Vol. VII, No. 5, p. 27-34);
with extra Floating Point Extensions, conversion
of Turtle Graphics to floating-point,
Function Plotting routines, and examples by:
             Mark Smiley

             Dept. of Math
             AUM
             Montgomery, AL
                     36193-0401

   5 LOAD \ ASM8087    \ Screens    5 -  16   8087 Assembler
  17 LOAD \ FPING      \ Screens   17 -  65   Floating-point
  66 LOAD \ FP-EXTN    \ Screens   66 -  67   Fl.-pt Extensions

comment;

WARNING OFF
CR .( 8087/80287 Assembler extentions..)

HEX
FORTH ALSO ASSEMBLER ALSO DEFINITIONS

VARIABLE WAIT? WAIT? ON
VARIABLE <FW>

: NOWAIT WAIT? OFF ;

: COMP-WAIT WAIT? @ [ FORTH ] 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> ! ;

07 WORD-TYPE INTEGER*2     2F WORD-TYPE INTEGER*8
03 WORD-TYPE INTEGER*4     01 WORD-TYPE REAL*4
05 WORD-TYPE REAL*8        2B WORD-TYPE TEMP_REAL
27 WORD-TYPE BCD

: MF    ( -- n )   <FW> @  [ FORTH ] 6 AND ;

: ESC,  ( n -- )   [ FORTH ] D8 OR C, ;

: 1FPF
        COMP-WAIT DUP 1+ C@ ESC,  C@ C, RESET ;

: 1FP CREATE C, C, DOES> ['] 1FPF A;!  A; ;

\ NON-VARIANT 8087 INSTRUCTIONS                    08Jun86RLS

6  D9 1FP FCOMPP    1 E4 1FP FTST      1 E5 1FP FXAM
1  EE 1FP FLDZ      1 E8 1FP FLD1      1 EB 1FP FLDPI
1  E9 1FP FLDL2T    1 EA 1FP FLDL2E    1 EC 1FP FLDLG2
1 0ED 1FP FLDLN2    1 FA 1FP FSQRT,    1 FD 1FP FSCALE
1  F8 1FP FPREM     1 FC 1FP FRNDINT   1 F4 1FP FXTRACT
1  E1 1FP FABS,     1 E0 1FP FCHS      1 F2 1FP FPTAN
1  F3 1FP FPATAN    1 F0 1FP F2XM1     1 F1 1FP FYL2X
1  F9 1FP FYL2XP1   3 E3 1FP FINIT     3 E0 1FP FENI
3  E1 1FP FDISI     1 E7 1FP FINCSTP   1 F6 1FP FDECSTP
1  D0 1FP FNOP      3 E2 1FP FCLEX

: 2FPF
        COMP-WAIT DUP 1+ C@ ESC, C@ M/RS, RESET ;

: 2FP
        CREATE C, C,
        DOES>  ['] 2FPF A;! A; ;

1 28 2FP FLDCW   1 38 2FP FSTCW   5 38 2FP FSTSW
1 30 2FP FSTENV  1 20 2FP FLDENV  5 30 2FP FSAVE
5 20 2FP FRSTOR

: 3FPF
        COMP-WAIT FPSTACK? [ FORTH ]
        IF     DUP 2+ C@ ESC, 1+ C@ RS@ OR C,
        ELSE   MF 1 OR ESC, C@ <FW> @ 7 >
               IF   10 AND <FW> @ 28 AND OR   THEN
               M/RS,
        THEN RESET ;

: 3FP
        CREATE C, C, C,
        DOES>  ['] 3FPF A;! A;  ;

01  C0  00  3FP  FLD
05  D8  18  3FP  FSTP

: 4FPF
        COMP-WAIT [ FORTH ] DUP 1+ C@ ESC, C@ RS@ OR C, RESET ;

: 4FP
        CREATE C, C,
        DOES>  ['] 4FPF A;! A;  ;

01  C8  4FP  FXCH
05  C0  4FP  FFREE

: 5FPF
        COMP-WAIT 6 ESC, C@ RD@ [ FORTH ] OR C, RESET ;

: 5FP
        CREATE C,  DOES>  ['] 5FPF A;! A; ;

C0  5FP  FADDP
C8  5FP  FMULP
E0  5FP  FSUBP
E8  5FP  FSUBRP
F0  5FP  FDIVP
F8  5FP  FDIVRP

: 6FPF
        COMP-WAIT FPSTACK?  [ FORTH ]
        IF   DUP C@ ESC, 1+ C@ RS@ OR C,
        ELSE  DUP 1+ C@ 1 AND MF OR ESC,  C@ 38 AND M/RS,
        THEN RESET ;

: 6FP
        CREATE C, C,
        DOES>  ['] 6FPF A;! A; ;

D0  00  6FP  FCOM
D8  00  6FP  FCOMP
D0  05  6FP  FST

: 7FPF
        [ FORTH ] COMP-WAIT 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; ;

00  C0  7FP  FADD
08  C8  7FP  FMUL
20  E0  7FP  FSUB
28  E8  7FP  FSUBR
30  F0  7FP  FDIV
38  F8  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 a separate
stack.

comment;

64   CONSTANT FSTACK-SIZE

CREATE FPSTACK  FSTACK-SIZE 2+ 8* ALLOT

FPSTACK FSTACK-SIZE 1+ 8 * + CONSTANT FSP0

CREATE FLOAT-WORK 10 ALLOT

VARIABLE FSP

: FSP@ ( -- u ) FSP @ ;

: FSP! ( u -- ) FSP ! ;    FSP0 FSP!

: ?FSTACK  ( -- )
        FSP@ FSP0 SWAP U< IF FSP0 FSP!
        TRUE ABORT" Floating Point Stack Underflow " THEN
        FSP@ FSP0 FSTACK-SIZE 8 * - U< IF FSP0 FSP!
        TRUE ABORT" Floating point Stack Overflow " THEN (?STACK) ;

' ?FSTACK IS ?STACK

CODE FPOP   ( -- )
        ADD   FSP # 8
        NEXT
        END-CODE

CODE FPUSH   ( -- )
        SUB   FSP # 8
        NEXT
        END-CODE

: FCONSTANT ( r -- ) ( compiling)
            ( -- r ) ( run-time )
        CREATE 8 0
                DO
                        FSP@ I + @ ,
                2 +LOOP
                FPOP
        DOES>   FPUSH 8 0
                DO
                        DUP @ FSP@ I + ! 2+ 2
                +LOOP
        DROP ;

: FVARIABLE ( -- )      ( compiling)
            ( -- addr ) ( run-time )
        CREATE 8 ALLOT
        DOES> ;

CODE FP>R    ( -- r )
        PUSH  BP
        MOV   BP, FSP
        SUB   BP, # 8
        MOV   FSP BP
        FSTP  REAL*8 0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE R>FP    ( r -- )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE FP>I    ( -- 16b)
        XCHG  BP, SP
        DEC   BP
        DEC   BP
        FRNDINT
        FSTP  INTEGER*2 0 [BP]
        XCHG  BP, SP
        NEXT
        END-CODE

CODE I>FP    ( 16b -- )
        XCHG  BP, SP
        FLD   INTEGER*2 0 [BP]
        INC   BP
        INC   BP
        XCHG  BP, SP
        NEXT
        END-CODE

CODE FP>DI    ( -- 32b )
        XCHG  BP, SP
        SUB   BP, # 4
        FRNDINT
        FSTP  INTEGER*4 0 [BP]
        XCHG  BP, SP
        NEXT
        END-CODE

CODE DI>FP    ( 32b -- )
        XCHG  BP, SP
        FLD   INTEGER*4 0 [BP]
        ADD   BP, # 4
        XCHG  BP, SP
        NEXT
        END-CODE

CODE FP>QI    ( -- 64b)
        XCHG  BP, SP
        SUB   BP, # 8
        FRNDINT
        FSTP  INTEGER*8 0 [BP]
        XCHG  BP, SP
        NEXT
        END-CODE

CODE QI>FP    ( 64b -- )
        XCHG  BP, SP
        FLD   INTEGER*8 0 [BP]
        ADD   BP, # 8
        XCHG  BP, SP
        NEXT
        END-CODE

CODE FP>SR    ( -- 32bit-real )
        XCHG  BP, SP
        SUB   BP, # 4
        FSTP  REAL*4 0 [BP]
        XCHG  BP, SP
        NEXT
        END-CODE

CODE SR>FP    ( 32bit-real -- )
        XCHG  BP, SP
        FLD   REAL*4 0 [BP]
        ADD   BP, # 4
        XCHG  BP, SP
        NEXT
        END-CODE

CODE FPSW>    ( -- n )
        XCHG  BP, SP
        DEC   BP
        DEC   BP
        FSTSW 0 [BP]
        XCHG  BP, SP
        NEXT
        END-CODE

CODE FPCW>    ( -- n )
        XCHG  BP, SP
        DEC   BP
        DEC   BP
        FSTCW 0 [BP]
        XCHG  BP, SP
        NEXT
        END-CODE

CODE >FPCW    ( n -- )
        XCHG  BP, SP
        FLDCW 0 [BP]
        INC   BP
        INC   BP
        XCHG  BP, SP
        NEXT
        END-CODE

CODE INITFP    ( -- )
        FINIT
        FDISI
        NEXT
        END-CODE

CODE CLEARFP    ( -- )
        FCLEX
        NEXT
        END-CODE

CODE PI    ( -- pi )
        PUSH  BP
        FLDPI
        MOV   BP, FSP
        SUB   BP, # 8
        MOV   FSP BP
        FSTP  REAL*8 0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE F1.0    ( -- 1.0 )
        PUSH  BP
        FLD1
        MOV   BP, FSP
        SUB   BP, # 8
        MOV   FSP BP
        FSTP  REAL*8 0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE F0.0    ( -- 0.0 )
        PUSH  BP
        FLDZ
        MOV   BP, FSP
        SUB   BP, # 8
        MOV   FSP BP
        FSTP  REAL*8 0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE F*   ( r1 r2 -- r1*r2)
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        FMUL  0 [BP]
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE F+    ( r1 r2 -- r1+r2)
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        FADD  0 [BP]
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE F-    ( r1 r2 -- r1-r2)
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        FLD   0 [BP]
        FSUB  ST(0), ST(1)
        FXCH  ST(1)
        FSTP  0 [BP]
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE F/    ( r1 r2 -- r1/r2)
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        FLD   0 [BP]
        FDIV  ST(0), ST(1)
        FXCH  ST(1)
        FSTP  0 [BP]
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE FABS    ( r1 -- |r1|)
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FABS,
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE FNEGATE    ( r1 -- -r1 )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FCHS
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE FSQRT    ( r1 -- SQRT[r1])
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FSQRT,
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE FLOG    ( r1 -- LOG10[r1])
        PUSH  BP
        MOV   BP, FSP
        FLDLG2
        FLD   REAL*8 0 [BP]
        FYL2X
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE FLN    ( r1 -- LN[r1])
        PUSH  BP
        MOV   BP, FSP
        FLDLN2
        FLD   REAL*8 0 [BP]
        FYL2X
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE 1/F  ( r -- r^-1)
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FLD1
        FDIVP ST(1), ST(0)
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

: D>R  ( d -- r )
        SWAP DI>FP FP>R ;
HEX
: (ROUND)    ( r n -- r )
        FPCW> DUP >R  F3FF AND OR >FPCW
        R>FP FP>DI SWAP R> >FPCW ;

: FIX   ( r -- d )  0000 (ROUND) ;

: INT   ( r -- d )  0C00 (ROUND) ;

: RND>+INF  ( r -- d )  0800 (ROUND) ;

: RND>-INF  ( r -- d )  0400 (ROUND) ;

: FDROP    ( r -- )  FPOP ;

DECIMAL

CODE FDUP    ( r -- r r )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        SUB   BP, # 8
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE FOVER    ( r1 r2 -- r1 r2 r1 )
        PUSH  BP
        MOV   BP, FSP
        ADD   8 # BP
        FLD   REAL*8 0 [BP]
        SUB   BP, # 16
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE FSWAP   ( r1 r2 -- r2 r1 )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        FLD   0 [BP]
        FXCH  ST(1)
        FSTP  0 [BP]
        SUB   BP, # 8
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE FROT    ( r1 r2 r3 -- r2 r3 r1 )
        PUSH  BP
        MOV   BP, FSP
        ADD   BP, # 8
        FLD   REAL*8 0 [BP]
        MOV   BP, FSP
        FLD   0 [BP]
        ADD   BP, # 16
        FLD   0 [BP]
        MOV   BP, FSP
        FSTP  0 [BP]
        ADD   BP, # 8
        FSTP  0 [BP]
        ADD   BP, # 8
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE FNIP    ( r1 r2 -- r2 )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE FTUCK    ( r1 r2 -- r2 r1 r2 )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        FLD   0 [BP]
        FXCH  ST1
        FST   0 [BP]
        FXCH  ST1
        SUB   BP, # 8
        FSTP  0 [BP]
        SUB   BP, # 8
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE FPICK    ( rX ... rn ... r2 r1 r0 n --- ... r1 r0 rn )
        POP   AX
        PUSH  BP
        MOV   8 # AH
        MUL   AH
        MOV   BP, FSP
        ADD   BP, AX
        FLD   REAL*8 0 [BP]
        MOV   BP, FSP
        SUB   BP, # 8
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE (RVS0)     ( r -- fpsw )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FTST
        FSTP  ST(0)
        ADD   BP, # 8
        MOV   FSP BP
        POP   BP
        XCHG  BP, SP
        DEC   BP
        DEC   BP
        FSTSW 0 [BP]
        XCHG  SP, BP
        NEXT
        END-CODE

HEX
: C3C0X    ( fpsw -- n )
        DUP  4000 AND 0= NOT
        IF   2
        ELSE 0
        THEN
        SWAP 0100 AND 0= NOT
        IF   1+
        THEN ;

DECIMAL

: F0=  ( r -- f )
        (RVS0) C3C0X 2 = ;

: F0<  ( r -- f)  (RVS0) C3C0X 1 = ;

: F0>  ( r -- f)  (RVS0) C3C0X 0= ;

CODE (RVSR)    ( r1 r2 -- fpsw )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        FLD   0 [BP]
        FCOMPP
        ADD   BP, # 8
        MOV   FSP BP
        POP   BP
        XCHG  BP, SP
        DEC   BP
        DEC   BP
        FSTSW 0 [BP]
        XCHG  SP, BP
        NEXT
        END-CODE

: F=    ( r1 r2 -- f )
        (RVSR) C3C0X 2 = ;

: F<    ( r1 r2 -- f )
        (RVSR) C3C0X 1 = ;

: F>    ( r1 r2 -- f )
        (RVSR) C3C0X 0=  ;

: FMIN   ( r1 r2 -- rmin )
        FOVER FOVER F<
        IF   FDROP
        ELSE
             FNIP
        THEN ;

: FMAX    ( r1 r2 -- rmax )
        FOVER FOVER F>
        IF    FDROP
        ELSE
              FNIP
        THEN ;

CODE F@    ( addr -- r )
        POP   BX
        PUSH  BP
        FLD   REAL*8 0 [BX]
        MOV   BP, FSP
        SUB   BP, # 8
        FSTP  0 [BP]
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

CODE F!   ( r addr -- )
        POP   BX
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        MOV   FSP BP
        FSTP  0 [BX]
        POP   BP
        NEXT

        END-CODE

CODE (FLIT)   ( -- r )
        PUSH  BP
        MOV   BP, FSP
        SUB   BP, # 8
        LODSW ES:
        MOV   0 [BP], AX
        LODSW ES:
        MOV   2 [BP], AX
        LODSW ES:
        MOV   4 [BP], AX
        LODSW ES:
        MOV   6 [BP], AX
        MOV   FSP BP
        POP   BP
        NEXT
        END-CODE

: FLITERAL  ( r -- )
        COMPILE (FLIT) FSP@
        4 0 DO
                DUP I 2* +  @ X,
        LOOP
        DROP FDROP ; IMMEDIATE

VARIABLE TRIG-MODE     TRIG-MODE ON

: DEGREES    ( -- )
        TRIG-MODE ON ;

: RADIANS    ( -- )
        TRIG-MODE OFF ;

: DEG->RAD   ( r -- r )
        [ 180. D>R ] FLITERAL F/
        [ PI ] FLITERAL F* ;

: RAD->DEG    ( r -- r )
        [ 180. D>R ] FLITERAL F*
        [ PI ] FLITERAL F/ ;

INITFP CLEARFP

FVARIABLE 2PI   PI PI F+ 2PI F!

FVARIABLE PI/4  PI 4. D>R  F/ PI/4 F!

FVARIABLE PI/2  PI 2. D>R  F/ PI/2 F!

: ANGLE->+    ( r -- r )
        TRIG-MODE @
        IF    DEG->RAD   THEN
        BEGIN FDUP F0<
        WHILE
              2PI F@ F+
        REPEAT ;

HEX

CODE OCTANT>    ( r -- n )
        MOV   DX, BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        ADD   BP, # 8
        MOV   FSP BP
        MOV   BP, SP
        DEC   BP
        DEC   BP
        FLD   2PI
        FXCH  ST(1)
        FPREM
        FXCH  ST(1)
        FSTP  ST(0)
        FSTCW 0 [BP]
        MOV   AX, 0 [BP]
        MOV   CX, AX
        OR    AX, # 0C00
        MOV   0 [BP], AX
        FLDCW 0 [BP]
        FLD   PI/4
        FXCH  ST(1)
        FDIVP ST(1), ST(0)
        FSTP  INTEGER*2 0 [BP]
        MOV   SP, BP
        MOV   FLOAT-WORK CX
        FLDCW FLOAT-WORK
        MOV   BP, DX
        NEXT
        END-CODE

DECIMAL

CODE TRIG-ARG>    ( r -- r )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FLD   PI/4
        FXCH  ST(1)
        FPREM
        FXCH  ST(1)
        FSTP  ST(0)
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE [SIN]    ( r -- sin<r> )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FLD1
        FLD   ST(0)
        FADDP ST(1), ST(0)
        FXCH  ST(1)
        FDIVP ST(1), ST(0)
        FPTAN
        FXCH  ST(1)
        FDIVP ST(1), ST(0)
        FLD   ST(0)
        FLD   ST(0)
        FMULP ST(1), ST(0)
        FLD1
        FADDP ST(1), ST(0)
        FXCH  ST(1)
        FLD1
        FLD   ST(0)
        FADDP ST(1), ST(0)
        FMULP ST(1), ST(0)
        FDIVP ST(1), ST(0)
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE [COS]    ( r -- cos<r> )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FLD1
        FLD1
        FADDP ST(1), ST(0)
        FXCH  ST(1)
        FDIVP ST(1), ST(0)
        FPTAN
        FXCH  ST(1)
        FDIVP 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
        FSUBP ST(1), ST(0)
        FDIVP ST(1), ST(0)
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

CODE [TAN]    ( r -- tan<r> )
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FPTAN
        FXCH  ST(1)
        FDIVP ST(1), ST(0)
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

: FSIN    ( r -- SIN<r> )
        [ FORTH ] ANGLE->+ FDUP OCTANT> TRIG-ARG> 4 /MOD SWAP
        DUP 0 =
        IF      DROP [SIN]                              ELSE
                DUP 1 = IF DROP PI/4 F@ FSWAP F- [COS]  ELSE
                DUP 2 = IF DROP [COS]                   ELSE
                DUP 3 = IF DROP PI/4 F@ FSWAP F- [SIN]  ELSE
        THEN THEN THEN THEN
        IF  FNEGATE THEN ;

: FCOS ( r -- COS<r> )    [ FORTH ]
    ANGLE->+ FDUP OCTANT> TRIG-ARG> DUP 4 MOD
      DUP 0 = IF DROP [COS]                   ELSE
      DUP 1 = IF DROP PI/4 F@ FSWAP F- [SIN]  ELSE
      DUP 2 = IF DROP [SIN]                   ELSE
      DUP 3 = IF DROP PI/4 F@ FSWAP F- [COS]  ELSE
      THEN THEN THEN THEN
      2+ 4 / 1 = IF FNEGATE THEN ;

F0.0 1/F FCONSTANT INFINITY

: TANARG<>0 ( r n -- TAN<r> )
        [ FORTH ] 4 MOD
        DUP 0 = IF DROP [TAN]                          EXIT THEN
        DUP 1 = IF DROP PI/4 F@ FSWAP F- [TAN] 1/F     EXIT THEN
        DUP 2 = IF DROP [TAN] FNEGATE 1/F              EXIT THEN
        DUP 3 = IF DROP PI/4 F@ FSWAP F- [TAN] FNEGATE EXIT THEN ;

: TANARG=0    ( n -- TAN<r> )
        [ 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    ( r -- TAN<r> )
        ANGLE->+ FDUP OCTANT> TRIG-ARG> FDUP F0=
        IF  FDROP TANARG=0
        ELSE  TANARG<>0  THEN ;

HEX

ASSEMBLER ALSO

LABEL (POWER)    ( -- )
        FMULP ST(1), ST(0)
        FLD   ST(0)
        FSTCW FLOAT-WORK
        MOV   AX, FLOAT-WORK
        MOV   CX, AX
        AND   AX, # F3FF
        OR    AX, # 0400
        MOV   FLOAT-WORK AX
        FLDCW FLOAT-WORK
        FRNDINT
        MOV   FLOAT-WORK CX
        FLDCW FLOAT-WORK
        FLD   ST(0)
        FSTP  REAL*8 FLOAT-WORK
        FXCH  ST(1)
        FSUBP ST(1), ST(0)
        FLD1
        FCHS
        FXCH  ST(1)
        FSCALE
        FXCH  ST(1)
        FSTP  ST(0)
        F2XM1
        FLD1
        FADDP ST(1), ST(0)
        FLD   ST(0)
        FMULP ST(1), ST(0)
        FLD   REAL*8 FLOAT-WORK
        FXCH  ST(1)
        FSCALE
        FXCH  ST(1)
        FSTP  ST(0)
        RET
        END-CODE

PREVIOUS FORTH
DECIMAL

CODE (FALN)    ( -- )
        FLDL2E
        CALL (POWER)
        NEXT
        END-CODE

CODE (FALOG)    ( -- )
        FLDL2T
        CALL (POWER)
        NEXT
        END-CODE

: FALN ( r -- e**r )
        FDUP  699. D>R  F>
        IF   ." FALN ARGUMENT TOO LARGE" FDROP QUIT
        THEN
        R>FP (FALN) FP>R ;

: FALOG    ( r -- 10**r )
        FDUP  304. D>R  F>
        IF   ." FALOG ARGUMENT TOO LARGE" FDROP QUIT
        THEN
        R>FP (FALOG) FP>R ;

: FLOAT    ( d -- r )
        D>R DPL @ 0 D>R FALOG F/ ;

: F**    ( r1 r2 -- r1^r2 )
        FSWAP FLOG F* FALOG ;

ASSEMBLER ALSO   HEX

LABEL (FATAN)
        FLD1
        FCOM  ST(1)
        FSTSW FLOAT-WORK
        MOV   AX, FLOAT-WORK
        AND   AX, # 4100
        0=
        IF
                FPATAN
        ELSE
                FXCH  ST(1)
                FPATAN
                FLD1
                FLD   ST(0)
                FADDP ST(1), ST(0)
                FLDPI
                FDIVP ST(1), ST(0)
                FSUBP ST(1), ST(0)
         THEN
         RET
         END-CODE

PREVIOUS FORTH

CODE FATAN    ( r -- arctan<r>)
        PUSH  BP
        MOV   BP, FSP
        FLD   REAL*8 0 [BP]
        FTST
        FSTSW FLOAT-WORK
        MOV   AX, FLOAT-WORK
        AND   AX, # 4100
        SUB   AX, # 0100
        0=
        IF
                FCHS
                CALL  (FATAN)
                FCHS
        ELSE
                CALL  (FATAN)
        THEN
        FSTP  0 [BP]
        POP   BP
        NEXT
        END-CODE

DECIMAL

: ARCRANGE    ( r -- r f )
        FDUP  F1.0  F>   FDUP  F1.0 FNEGATE F< OR ;

: FASIN    ( r -- SIN-1<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    ( r -- COS-1<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 ;

: VALUE
        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    ( -- )
        MOV   FLOAT-WORK # 10 WORD
        FLD   INTEGER*2 FLOAT-WORK
        FMULP ST(1), ST(0)
        NEXT
        END-CODE

CODE (FADDI)    ( n -- )
        XCHG  BP, SP
        FLD   INTEGER*2 0 [BP]
        FADDP ST(1), ST(0)
        INC   BP
        INC   BP
        XCHG  SP, BP
        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 )
        XCHG    BP, SP
        FLD     0 [BP] INTEGER*8
        FCHS
        FSTP    0 [BP]
        XCHG    BP, SP
        NEXT
        END-CODE

: QFLOAT    ( q -- r )
        DPL @ 0 MAX DPL !
        QI>FP FP>R DPL @ S>D D>R FALOG F/ ;

: (MANTISSA)   ( addr -- r addr | - )
        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 ! ;

DECIMAL

: 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 FLOAT 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   ( r -- r n )
        FDUP FLOG RND>-INF DROP ;

CREATE FLOAT-BCD 10 ALLOT

VARIABLE #BCD   17 #BCD !

CODE R>BCD!    ( r n -- ; full precision bcd-string to FLOAT-BCD )
       FLD    #BCD INTEGER*2
       XCHG   BP, SP
       FLD    INTEGER*2 0 [BP]
       INC    BP
       INC    BP
       XCHG   SP, BP
       PUSH   BP
       MOV    BP, FSP
       FSUBRP ST(1), ST(0)
       FLD1
       FSUBRP ST1, ST0
       FLDL2T
       CALL   (POWER)
       FLD    REAL*8 0 [BP]
       ADD    BP, # 8
       FMULP  ST(1), ST(0)
       FSTP   FLOAT-BCD BCD
       MOV    FSP BP
       POP    BP
       WAIT
       NEXT
       END-CODE

: .DIGITS    ( last first -- )
        2DUP > ABORT" FP I/O error, FP stack underflow"
        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 ;

: E.    ( r -- )
        FDUP F0=
        IF
                FDROP SPACE ." .00000000000000000E+00 " EXIT
        THEN
        FDUP INFINITY F=
        IF
                FDROP SPACE ." INFINITY               " EXIT
        THEN
        FMAG DUP >R R>BCD! FLOAT-BCD 9 + C@
        IF
                ASCII - ELSE BL
        THEN
        EMIT ASCII . EMIT
        1 17 .DIGITS ASCII E EMIT R> 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

HEX

CODE FPARSE    ( r -- int-part frac-part )
        PUSH    BP
        MOV     BP, FSP
        FLD     REAL*8 0 [BP]
        FLD     ST0
        FSTCW   FLOAT-WORK
        MOV     AX, FLOAT-WORK
        MOV     CX, AX
        OR      AX, # 0C00
        MOV     FLOAT-WORK AX
        FLDCW   FLOAT-WORK
        FRNDINT
        MOV     FLOAT-WORK CX
        FLDCW   FLOAT-WORK
        FLD     ST0
        FSTP    REAL*8 0 [BP]
        FSUBRP  ST1, ST0
        SUB     BP, # 8
        FSTP    REAL*8 0 [BP]
        MOV     FSP BP
        POP     BP
        NEXT
        END-CODE

DECIMAL

: .INT    ( r -- )
        FDUP F0=
        IF
                FDROP ASCII 0 EMIT
        ELSE
                FMAG DUP >R R>BCD!
                #BCD @ DUP R> - SWAP .DIGITS
        THEN ;

CODE FRNDFRC    ( +r -- +r )
        PUSH    BP
        FLD1
        FLD1
        FADDP   ST1, ST0       ( 2.0 ON TOP OF STACK )
        FLD    INTEGER*2 #PLACES
        FCHS
        FLDL2T
        CALL    (POWER)
        FDIVP   ST(1), ST(0)
        MOV     BP, FSP
        FLD     REAL*8 0 [BP]
        FADDP   ST(1), ST(0)
        FSTP    REAL*8 0 [BP]
        POP     BP
        NEXT
        END-CODE

: .FRAC    ( 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 -- )
        FDUP INFINITY F=
        IF
                FDROP ." INFINITY" EXIT
        THEN
        FDUP F0<
        IF
                ASCII - ELSE BL
        THEN
        EMIT FABS FPARSE FRNDFRC
        FDUP INT D>R 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#    ( r #DEC   -- )
        >R FDUP F0<
        IF
                ASCII -
        ELSE
                BL
        THEN
        EMIT ASCII . EMIT
        FABS R> #PLACES @ >R PLACES  FMAG DUP >R
        1+ S>D D>R 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    ( r #DEC   #col -- )
        FDUP F0=
        IF                            \ Handle zero.
                FDROP E.R0 EXIT
        THEN
        FDUP INFINITY F=
        IF FDROP ." INFINITY " EXIT THEN \ infinity
        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 ( r #dec #col -- )
        FDUP F0=   \ test for a zero
        IF                           \ if found, handle specially
                FDROP F.R0 EXIT      \ if found, handle specially
        THEN
        FDUP INFINITY F=
        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 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 )
        FSP@ FSP0 SWAP - 8 / ;

: .F  ( -- )
        FDEPTH ?DUP
        IF      0
                DO
                        FDEPTH I - 1- FPICK 3 10 F.R  KEY? ?LEAVE
                LOOP
        ELSE ." Empty "
        THEN ;

: ROUND    ( r -- d )
        FDUP  F0>
        IF      RND>-INF
        ELSE    RND>+INF
        THEN ;

: N>R    ( n -- r )
        S>D  D>R  ;

: R>N    ( r -- n )
        ROUND  ( INT )  DROP  ;
        ( Like  F>S  in PLOT.BLK )

: F>S       ( r -- n )
        INT  DROP  ;

: F2DUP    ( r1 r2 -- r1 r2 r1 r2 )
        FOVER  FOVER  ;

: FMOD    ( r1 r2 -- r3 )
        F2DUP F/  INT  D>R  F*  F-  ;

8 CONSTANT  F#BYTES

: F,    ( r -- )
    HERE  F#BYTES  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
                F#BYTES * 2+  +
        THEN    ;

.( ..Loaded)
WARNING ON