home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / ffloat.seq < prev    next >
Encoding:
Text File  |  1990-05-24  |  43.3 KB  |  1,782 lines
  1. \ FFLOAT.SEQ   Faster Hardware Floating point for 8087
  2. \    Enhancements by: Robert L. Smith
  3. comment:
  4.         Based on HFLOAT by Steve Pollack and Mark Smiley and others.
  5.         Preliminary tests show a speed improvement by a factor of two!
  6.         Please send bug reports to:
  7.  
  8.             Robert L. Smith
  9.             2300 St. Francis Dr.
  10.             Palo Alto, CA 94303
  11.  
  12.             Tel: (415) 856-9321
  13.  
  14.  
  15.         Comments are especially welcome regarding compatibility among the
  16.         Intel variants: 8087, 80287, 80387, 80487 ...
  17.         Note that the value 8087NPU may be modified prior to loading this
  18.         file.  If it is changed, some speed improvements may be noticed
  19.         in the more recent Floating Point Numeric Processors.
  20.  
  21. comment;
  22.  
  23. CR .( FFLOAT Version 2.01      05/24/90 17:14:16.74 )
  24. \ CR .( 8087/80287 Assembler extensions..)
  25.  
  26. HEX
  27. FORTH ALSO ASSEMBLER ALSO DEFINITIONS
  28.  
  29. VARIABLE WAIT? WAIT? ON
  30. VARIABLE <FW>
  31.  
  32. TRUE VALUE 8087NPU     \ Change this for shorter code with 80287 or 80387
  33.  
  34. : NOWAIT WAIT? OFF ;
  35.  
  36. : COMP-WAIT
  37.      8087NPU WAIT? @ [ FORTH ] AND
  38.      IF   9B C, ( WAIT )  THEN
  39.      WAIT? ON ;
  40.  
  41. : FPSTACK?   ( -- f )
  42.          [ FORTH ] TS@ 6 = ;
  43.  
  44. \ Floating Point Source Registers
  45.  
  46. \     Reg  Type  W        Name
  47.       0    6     1  SREG  ST
  48.       0    6     1  SREG  ST0
  49.       0    6     1  SREG  ST(0)
  50.       1    6     1  SREG  ST1
  51.       1    6     1  SREG  ST(1)
  52.       2    6     1  SREG  ST2
  53.       2    6     1  SREG  ST(2)
  54.       3    6     1  SREG  ST3
  55.       3    6     1  SREG  ST(3)
  56.       4    6     1  SREG  ST4
  57.       4    6     1  SREG  ST(4)
  58.       5    6     1  SREG  ST5
  59.       5    6     1  SREG  ST(5)
  60.       6    6     1  SREG  ST6
  61.       6    6     1  SREG  ST(6)
  62.       7    6     1  SREG  ST7
  63.       7    6     1  SREG  ST(7)
  64.  
  65. \ Floating Point Destination Registers
  66. \     Reg  Type  W        Name
  67.  
  68.       0    6     1  DREG  ST,
  69.       0    6     1  DREG  ST0,
  70.       0    6     1  DREG  ST(0),
  71.       1    6     1  DREG  ST1,
  72.       1    6     1  DREG  ST(1),
  73.       2    6     1  DREG  ST2,
  74.       2    6     1  DREG  ST(2),
  75.       3    6     1  DREG  ST3,
  76.       3    6     1  DREG  ST(3),
  77.       4    6     1  DREG  ST4,
  78.       4    6     1  DREG  ST(4),
  79.       5    6     1  DREG  ST5,
  80.       5    6     1  DREG  ST(5),
  81.       6    6     1  DREG  ST6,
  82.       6    6     1  DREG  ST(6),
  83.       7    6     1  DREG  ST7,
  84.       7    6     1  DREG  ST(7),
  85.  
  86. : WORD-TYPE CREATE C, DOES> C@ <FW> ! ;
  87.  
  88. $007 WORD-TYPE INTEGER*2     $02F WORD-TYPE INTEGER*8
  89. $003 WORD-TYPE INTEGER*4     $001 WORD-TYPE REAL*4
  90. $005 WORD-TYPE REAL*8        $02B WORD-TYPE TEMP_REAL
  91. $027 WORD-TYPE BCD
  92.  
  93. : MF    ( -- n )   <FW> @  [ FORTH ] 6 AND ;
  94.  
  95. : ESC,  ( n -- )   [ FORTH ] $D8 OR C, ;
  96.  
  97. : N1FPF
  98.         DUP 1+ C@ ESC, C@ C, RESET ;
  99.  
  100. : N1FP   CREATE C, C, DOES> ['] N1FPF A;! A; ;
  101.  
  102. 3 $0E2 N1FP FNCLEX    3 $0E3 N1FP FNINIT
  103. 3 $0E0 N1FP FNENI     3 $0E1 N1FP FNDISI
  104. 7 $0E0 N1FP FNSTWAX   ( 80287 instruction )
  105.  
  106. : W1FPF  $09B C, N1FPF ;   \ Generate a WAIT before the instruction.
  107.  
  108. : W1FP   CREATE C, C, DOES> ['] W1FPF A;! A; ;
  109.  
  110. 3 $0E2 W1FP FCLEX    3 $0E3 W1FP FINIT
  111. 3 $0E0 W1FP FENI     3 $0E1 W1FP FDISI
  112. 7 $0E0 W1FP FSTWAX   ( 80287 instruction )
  113.  
  114. : 1FP CREATE C, C, DOES> ['] N1FPF A;!  A; COMP-WAIT ;
  115.  
  116. \ NON-VARIANT 8087 INSTRUCTIONS 
  117.  
  118. 6 $0D9 1FP FCOMPP    1 $0E4 1FP FTST      1 $0E5 1FP FXAM
  119. 1 $0EE 1FP FLDZ      1 $0E8 1FP FLD1      1 $0EB 1FP FLDPI
  120. 1 $0E9 1FP FLDL2T    1 $0EA 1FP FLDL2E    1 $0EC 1FP FLDLG2
  121. 1 $0ED 1FP FLDLN2    1 $0FA 1FP FSQRT,    1 $0FD 1FP FSCALE
  122. 1 $0F8 1FP FPREM     1 $0FC 1FP FRNDINT   1 $0F4 1FP FXTRACT
  123. 1 $0E1 1FP FABS,     1 $0E0 1FP FCHS      1 $0F2 1FP FPTAN
  124. 1 $0F3 1FP FPATAN    1 $0F0 1FP F2XM1     1 $0F1 1FP FYL2X
  125. 1 $0F9 1FP FYL2XP1   1 $0F7 1FP FINCSTP
  126. 1 $0F6 1FP FDECSTP   1 $0D0 1FP FNOP
  127. ( 3 $0E4 1FP FSETPM ) ( 80287 instruction )
  128.  
  129. : N2FPF
  130.         DUP 1+ C@ ESC, C@ M/RS, RESET ;
  131.  
  132. : N2FP
  133.         CREATE C, C, DOES>  ['] N2FPF A;! A; ;
  134.  
  135. 1 $038 N2FP FNSTCW   5 $038 N2FP FNSTSW
  136. 1 $020 N2FP FNSTENV  5 $030 N2FP FNSAVE
  137.  
  138. : W2FPF $09B C, N2FPF ;     \ Generate a WAIT before the instruction.
  139.  
  140. : W2FP  CREATE C, C, DOES>  ['] W2FPF A;! A; ;
  141.  
  142. 1 $038 W2FP FSTCW    5 $038 W2FP FSTSW
  143. 1 $020 W2FP FSTENV   5 $030 W2FP FSAVE
  144.  
  145. : 2FP
  146.         CREATE C, C,
  147.         DOES>  ['] N2FPF A;! A; COMP-WAIT ;
  148.  
  149. WARNING OFF
  150.  
  151. 1 $028 2FP FLDCW    1 $020 2FP FLDENV    5 $020 2FP FRSTOR
  152.  
  153. WARNING ON
  154.  
  155. : 3FPF
  156.         FPSTACK? [ FORTH ]
  157.         IF     DUP 2+ C@ ESC, 1+ C@ RS@ OR C,
  158.         ELSE   MF 1 OR ESC, C@ <FW> @ 7 >
  159.                IF   $010 AND <FW> @ $028 AND OR   THEN
  160.                M/RS,
  161.         THEN RESET ;
  162.  
  163. : 3FP
  164.         CREATE C, C, C,
  165.         DOES>  ['] 3FPF A;! A; COMP-WAIT ;
  166.  
  167. 01  $0C0  $000  3FP  FLD
  168. 05  $0D8  $018  3FP  FSTP
  169.  
  170. : 4FPF
  171.         [ FORTH ] DUP 1+ C@ ESC, C@ RS@ OR C, RESET ;
  172.  
  173. : 4FP
  174.         CREATE C, C,
  175.         DOES>  ['] 4FPF A;! A; COMP-WAIT ;
  176.  
  177. 01  $0C8  4FP  FXCH
  178. 05  $0C0  4FP  FFREE
  179.  
  180. : 5FPF
  181.         6 ESC, C@ RD@ [ FORTH ] OR C, RESET ;
  182.  
  183. : 5FP
  184.         CREATE C,  DOES>  ['] 5FPF A;! A; COMP-WAIT ;
  185.  
  186. $0C0  5FP  FADDP
  187. $0C8  5FP  FMULP
  188. $0E0  5FP  FSUBP
  189. $0E8  5FP  FSUBRP
  190. $0F0  5FP  FDIVP
  191. $0F8  5FP  FDIVRP
  192.  
  193. : 6FPF
  194.         FPSTACK?  [ FORTH ]
  195.         IF   DUP C@ ESC, 1+ C@ RS@ OR C,
  196.         ELSE  DUP 1+ C@ 1 AND MF OR ESC,  C@ $038 AND M/RS,
  197.         THEN RESET ;
  198.  
  199. : 6FP
  200.         CREATE C, C,
  201.         DOES>  ['] 6FPF A;! A; COMP-WAIT ;
  202.  
  203. $0D0  $000  6FP  FCOM
  204. $0D8  $000  6FP  FCOMP
  205. $0D1  $010  6FP  FST
  206.  
  207. : 7FPF
  208.         [ FORTH ] FPSTACK?
  209.         IF      RD@ 0=
  210.                 IF    0 ESC, C@ RS@ OR C,
  211.                 ELSE  4 ESC, C@ RD@ OR C,
  212.                 THEN
  213.         ELSE    MF ESC, 1+ C@ M/RS,
  214.         THEN RESET ;
  215.  
  216. : 7FP
  217.         CREATE C, C,
  218.         DOES>  ['] 7FPF A;! A; COMP-WAIT ;
  219.  
  220. $000  $0C0  7FP  FADD
  221. $008  $0C8  7FP  FMUL
  222. $020  $0E0  7FP  FSUB
  223. $028  $0E8  7FP  FSUBR
  224. $030  $0F0  7FP  FDIV
  225. $038  $0F8  7FP  FDIVR
  226.  
  227. DECIMAL
  228.  
  229. : WSS: ( -- ) WAIT SS: NOWAIT ;
  230.  
  231. : WCS: ( -- ) WAIT CS: NOWAIT ;
  232.  
  233. : WDS: ( -- ) WAIT DS: NOWAIT ;
  234.  
  235. : WES: ( -- ) WAIT ES: NOWAIT ;
  236.  
  237. ONLY FORTH DEFINITIONS ALSO
  238.  
  239. \ .( ..Loaded)
  240.  
  241. \ CR .( F83 8087/80287 Floating point support..)
  242.  
  243. comment:
  244.  
  245. These screens load the higher level 8087 support words.  The floating
  246. point assembler must be loaded prior to these words.
  247.  
  248. Unless otherwise specified, real is in the Intel 8087 64-bit floating
  249. point (REAL*8) format.
  250.  
  251. In this version, floating point numbers are stored on the 8087 internal
  252. stack, with the overflow going to a separate external stack.
  253.  
  254. comment;
  255.  
  256. DEFER FPERR
  257.  
  258. \ ALSO HIDDEN DEFINITIONS
  259.  
  260. : 2/?   ( n1 -- n2 n3 )         \ n2 is n1 shifted right by 1.
  261.                                 \ n3 is least significant bit of n1 .
  262.         DUP >R 2/ $7FFF AND R> 1 AND ;
  263.  
  264. CODE OR!   ( n addr -- )        \ Logical OR of contents at addr with n
  265.         POP     BX
  266.         POP     AX
  267.         OR      0 [BX], AX
  268.         NEXT
  269.         END-CODE
  270.  
  271. CREATE FPSTAT 0 , 0 ,
  272.  
  273. : .FP.    ( -- )   ." Floating Point " ;
  274.  
  275. : .NAME   ( n -- )   >NAME .ID ;
  276.  
  277. : .NAMES   ( n1 n2 -- )   .NAME 2 SPACES SPACE 3 - .NAME CR ;
  278.  
  279. : (FPERR)  ( F: r -- r ; n1 n2 n3 --  )  \  n2 is CFA, n3 is error flag.
  280.          \ n1 is a possible return address on the parameter stack.
  281.         DUP FPSTAT OR!  CR  BELL EMIT
  282.  ( 1 )  2/? IF  DROP .FP. ." Division by zero in "         .NAMES EXIT THEN
  283.  ( 2 )  2/? IF  DROP .FP. ." Overflow in "                 .NAMES EXIT THEN
  284.  ( 4 )  2/? IF  DROP .FP. ." argument is negative for "    .NAMES EXIT THEN
  285.  ( 8 )  2/? IF  DROP .FP. ." argument is zero for "        .NAMES EXIT THEN
  286. ( 10 )  2/? IF  DROP .FP. ." argument out of range for "   .NAMES EXIT THEN
  287. ( 20 )  2/? IF  DROP .FP. ." Overflow for Input in "       .NAMES EXIT THEN
  288. ( 40 )  2/? IF  DROP .FP. ." Overflow for Output in "      .NAMES EXIT THEN
  289. ( 80 )  2/? IF  DROP      ." Integer overflow for "        .NAMES EXIT THEN
  290. ( 100)  2/? IF  DROP .FP. ." Underflow in "                .NAMES EXIT THEN
  291. ( 200)  2/? IF  DROP .FP. ." argument inaccurate for "     .NAMES EXIT THEN
  292. ( 400)  2/? IF  DROP .FP. ." Underflow for Input in "      .NAMES EXIT THEN
  293. ( 800)  2/? IF  DROP .FP. ." Underflow for Ouput in "      .NAMES EXIT THEN
  294. ( 1000) 2/? IF  DROP .FP. ." results inaccurate for "      .NAMES EXIT THEN
  295. ( 2000) 2/? IF  DROP .FP. ." stack underflow for "         .NAMES EXIT THEN
  296. ( 4000) 2/? IF  DROP .FP. ." stack overflow for "          .NAMES EXIT THEN
  297.         IF ." Unspecified Error " THEN
  298.         DROP QUIT ;
  299.  
  300. ' (FPERR) IS FPERR
  301.  
  302. CODE INITFP    ( -- )
  303.         FINIT
  304.         WAIT
  305.         FDISI
  306.         WAIT
  307.         NEXT
  308.         END-CODE
  309.  
  310. CODE CLEARFP    ( -- )
  311.         FCLEX
  312.         NEXT
  313.         END-CODE
  314.  
  315. 64   CONSTANT FSTACK-SIZE
  316.  
  317. CREATE FSTACK  FSTACK-SIZE 1+ 8* ALLOT  0 , 0 , 0 , 0 ,
  318.  
  319. FSTACK FSTACK-SIZE 8 * + CONSTANT FSP0
  320.  
  321. CREATE FLOAT-WORK 10 ALLOT
  322.  
  323. VARIABLE FVBOS       \ Floating point Virtual Bottom of Stack
  324. VARIABLE FVTOS       \ Floating point Virtual Top of Stack
  325.  
  326. : FCLEAR   ( -- )
  327.          FSP0 FVBOS !  FSP0 FVTOS !  INITFP ;
  328.  
  329. FCLEAR
  330.  
  331. CODE FDROP   ( F: r -- )
  332.         CLEAR_LABELS
  333.         MOV   AX, FVTOS
  334.         CMP   AX, FVBOS
  335.         JAE   1 $
  336.         ADD   AX, # 8
  337.         MOV   FVTOS AX
  338.         FSTP  REAL*8 ST(0)
  339.         NEXT
  340. 1 $:    JNE   2 $
  341.         ADD   AX, # 8
  342.         MOV   FVTOS AX
  343.         MOV   FVBOS AX
  344.         CMP   AX, # FSP0
  345.         JA    2 $
  346.         NEXT
  347. 2 $:    FINIT
  348.         FDISI
  349.         WAIT
  350.         MOV   AX, # FSP0
  351.         MOV   FVBOS AX
  352.         MOV   FVTOS AX
  353.         MOV   BX, # LAST @ NAME>
  354.         PUSH  BX
  355.         MOV   AX, # $2000
  356.         PUSH  AX
  357.         MOV   AX, # ' FPERR
  358.         JMP   AX
  359.         END-CODE
  360.  
  361. GLOBAL_REF
  362.  
  363. LABEL (1VLOAD)             \ If NPU stack is empty, load 1 oprnd from mem.
  364.         CLEAR_LABELS
  365.         MOV   BX, FVBOS
  366.         CMP   BX, FVTOS
  367.         JE    1 $
  368.         RET
  369. 1 $:    CMP   BX, # FSP0
  370.         JAE   2 $
  371.         FLD   REAL*8 0 [BX]
  372.         ADD   BX, # 8
  373.         MOV   FVBOS BX
  374.         WAIT
  375.         RET
  376. 2 $:    MOV   AX, ES: -2 [SI]
  377.         PUSH  AX
  378.         MOV   AX, # $2000
  379.         PUSH  AX
  380.         MOV   AX, # ' FPERR
  381.         JMP   AX
  382.         END-CODE
  383.  
  384. LABEL (2VLOAD)             \ Possible load from memory stack up to 2 opnds.
  385.         MOV   BX, FVBOS
  386.         MOV   AX, FVTOS
  387.         CMP   BX, AX
  388.         JE    3 $
  389.         ADD   AX, # 8
  390.         CMP   BX, AX
  391.         JE    4 $
  392.         RET
  393.  
  394. 3 $:    CMP   BX, # FSP0 10 -
  395.         JA    2 $
  396.         FLD   REAL*8 8 [BX]
  397.         FLD   REAL*8 0 [BX]
  398.         ADD   BX, # $10
  399.         MOV   FVBOS BX
  400.         WAIT
  401.         RET
  402.  
  403. 4 $:    CMP   BX, # FSP0 8 -
  404.         JA    2 $
  405.         FINCSTP
  406.         FINCSTP
  407.         FLD   REAL*8 0 [BX]
  408.         FDECSTP
  409.         ADD   BX, # 8
  410.         MOV   FVBOS BX
  411.         WAIT
  412.         RET
  413.         END-CODE
  414.  
  415. CODE 1VLOAD
  416.         CALL (1VLOAD)
  417.         NEXT
  418.         END-CODE
  419.  
  420. LABEL (3VLOAD)
  421.         CLEAR_LABELS
  422.         MOV   BX, FVBOS
  423.         MOV   AX, FVTOS
  424.         ADD   AX, # $18
  425.         CMP   BX, AX
  426.         JB    4 $
  427.         RET
  428. 4 $:    FINCSTP
  429.         FINCSTP
  430.         FINCSTP
  431.         SUB   AX, # 8
  432.         CMP   BX, AX
  433.         JE    2 $
  434.         SUB   AX, # 8
  435.         JE    1 $
  436.         CMP   BX, # FSP0 $18 +
  437.         JA    3 $
  438.         FLD   $10 [BX]        \ We need to load 3 fp words from virtual
  439.         FLD   8 [BX]
  440.         FLD   0 [BX]
  441.         ADD   WORD FVBOS # $18
  442.         WAIT
  443.         RET
  444. 2 $:    CMP   BX, # FSP0 $10 +
  445.         JA    3 $
  446.         FLD   8 [BX]
  447.         FLD   0 [BX]
  448.         FDECSTP
  449.         ADD   WORD FVBOS # $10
  450.         WAIT
  451.         RET
  452. 1 $:    CMP   BX, # FSP0 8 +
  453.         JA    3 $
  454.         FLD   0 [BX]
  455.         FDECSTP
  456.         FDECSTP
  457.         ADD   WORD FVBOS # 8
  458.         RET
  459. 3 $:    MOV   AX, ES: -2 [SI]
  460.         PUSH  AX
  461.         MOV   AX, # $2000
  462.         PUSH  AX
  463.         MOV   AX, # ' FPERR
  464.         JMP   AX
  465.         END-CODE
  466.  
  467. LABEL (1VEMPTY)
  468.         CLEAR_LABELS
  469. 1 $:    MOV   BX, FVTOS
  470.         ADD   BX, # $40
  471.         CMP   BX, FVBOS
  472.         JE    2 $
  473.         RET
  474. 2 $:    CMP   BX, # FSTACK
  475.         JB    4 $
  476.         FDECSTP
  477.         SUB   BX, # 8
  478.         MOV   FVBOS BX
  479.         FSTP  REAL*8 0 [BX]
  480.         WAIT
  481.         RET
  482. 4 $:    MOV   AX, ES: -2 [SI]
  483.         PUSH  AX
  484.         MOV   AX, # $4000
  485.         PUSH  AX
  486.         MOV   AX, # ' FPERR
  487.         JMP   AX
  488.         END-CODE
  489.  
  490. LABEL (1VL1VE)             \ Equivalent to (1VLOAD) followed by (1VEMPTY)
  491.         MOV   BX, FVBOS
  492.         CMP   BX, FVTOS
  493.         JNE   1 $
  494.         CMP   BX, # FSP0
  495.         JAE   3 $
  496.         FLD   REAL*8 0 [BX]
  497.         ADD   BX, # 8
  498.         MOV   FVBOS BX
  499.         WAIT
  500.         JMP   1 $
  501. 3 $:    MOV   AX, ES: -2 [SI]
  502.         PUSH  AX
  503.         MOV   AX, # $2000
  504.         PUSH  AX
  505.         MOV   AX, # ' FPERR
  506.         JMP   AX
  507.         END-CODE
  508.  
  509. LABEL (2VEMPTY)
  510.         MOV   BX, FVTOS
  511.         ADD   BX, # $40
  512.         MOV   AX, FVBOS
  513.         CMP   BX, AX
  514.         JE    6 $
  515.         SUB   BX, # 8
  516.         CMP   BX, AX
  517.         JE    5 $
  518.         RET
  519. 5 $:    CMP   BX, # FSTACK
  520.         JB    4 $
  521.         FDECSTP
  522.         FDECSTP
  523.         SUB   BX, # 8
  524.         MOV   FVBOS BX
  525.         FSTP  REAL*8 0 [BX]
  526.         FINCSTP
  527.         RET
  528. 6 $:    CMP   BX, # FSTACK 8 +
  529.         JB    4 $
  530.         FDECSTP
  531.         FDECSTP
  532.         SUB   BX, # $10
  533.         MOV   FVBOS BX
  534.         FSTP  0 [BX]
  535.         FSTP  8 [BX]
  536.         WAIT
  537.         RET
  538.         END-CODE
  539.  
  540. LOCAL_REF
  541.  
  542. CODE F!   ( F: r -- ; addr -- )
  543.         CALL  (1VLOAD)
  544.         POP   BX
  545.         FSTP  REAL*8 0 [BX]
  546.         ADD   FVTOS # 8 WORD
  547.         WAIT
  548.         NEXT
  549.         END-CODE
  550.  
  551. CODE F@    ( F: -- r ; addr -- )
  552.         CALL  (1VEMPTY)
  553.         POP   BX
  554.         FLD   REAL*8 0 [BX]
  555.         SUB   FVTOS # 8 WORD
  556.         WAIT
  557.         NEXT
  558.         END-CODE
  559.  
  560. : FCONSTANT ( F: r -- ) ( compiling)
  561.             ( F: -- r ) ( run-time )
  562.         CREATE HERE 8 ALLOT F!
  563.         DOES>  F@ ;
  564.  
  565. : FVARIABLE ( -- )      ( compiling)
  566.             ( -- addr ) ( run-time )
  567.         CREATE 8 ALLOT
  568.         DOES> ;
  569.  
  570. CODE FP>DI    ( F: r -- ; -- 32b )
  571.         SUB     SP, # 4
  572.         MOV     BX, SP
  573.         FRNDINT
  574.         FSTP    INTEGER*4 0 [BX]
  575.         WAIT
  576.         ADD     WORD FVTOS # 8
  577.         NEXT
  578.         END-CODE
  579.  
  580. CODE FP>QI    ( F: r -- ; -- 64b)
  581.         CALL    (1VLOAD)
  582.         SUB     SP, # 8
  583.         MOV     BX, SP
  584.         FRNDINT
  585.         FSTP    INTEGER*8 0 [BX]
  586.         WAIT
  587.         ADD     WORD FVTOS # 8
  588.         NEXT
  589.         END-CODE
  590.  
  591. CODE QI>FP    ( F: -- r ; 64b -- )
  592.         CALL    (1VEMPTY)
  593.         MOV     BX, SP
  594.         FLD     INTEGER*8 0 [BX]
  595.         WAIT
  596.         ADD     SP, # 8
  597.         SUB     WORD FVTOS # 8
  598.         NEXT
  599.         END-CODE
  600.  
  601. CODE FPSW>    ( -- n )
  602.         SUB     SP, # 2
  603.         MOV     BX, SP
  604.         FSTSW   0 [BX]
  605.         WAIT
  606.         NEXT
  607.         END-CODE
  608.  
  609. CODE FEXAM    ( F: r -- r ; -- n )
  610.         CLEAR_LABELS
  611.         MOV     BX, FVBOS
  612.         CMP     BX, # FSP0
  613.         JAE     1 $
  614.         CALL    (1VLOAD)
  615. 1 $:    FXAM
  616.         SUB     SP, # 2
  617.         MOV     BX, SP
  618.         FSTSW   0 [BX]
  619.         WAIT
  620.         AND     0 [BX], # $4700 WORD
  621.         NEXT
  622.         END-CODE
  623.  
  624. CODE FPCW>    ( -- n )
  625.         SUB     SP, # 2
  626.         MOV     BX, SP
  627.         FSTCW   0 [BX]
  628.         WAIT
  629.         NEXT
  630.         END-CODE
  631.  
  632. CODE >FPCW    ( n -- )
  633.         MOV     BX, SP
  634.         FLDCW   0 [BX]
  635.         ADD     SP, # 2
  636.         WAIT
  637.         NEXT
  638.         END-CODE
  639.  
  640. CODE >FREGS   ( addr -- )
  641.         POP     BX
  642.         WAIT
  643.         FRSTOR  0 [BX]
  644.         WAIT
  645.         NEXT
  646.         END-CODE
  647.  
  648. CODE >FREGS>   ( addr -- )
  649.         POP     BX
  650.         WAIT
  651.         FSAVE   0 [BX]
  652.         FRSTOR  0 [BX]
  653.         WAIT
  654.         NEXT
  655.         END-CODE
  656.  
  657. CODE PI    ( F: -- pi )
  658.         CALL    (1VEMPTY)
  659.         FLDPI
  660.         SUB     FVTOS # 8 WORD
  661.         NEXT
  662.         END-CODE
  663.  
  664. CODE F1.0    ( F: -- 1.0 )
  665.         CALL    (1VEMPTY)
  666.         FLD1
  667.         SUB     FVTOS # 8 WORD
  668.         NEXT
  669.         END-CODE
  670.  
  671. CODE F0.0    ( F: -- 0.0 )
  672.         CALL    (1VEMPTY)
  673.         FLDZ
  674.         SUB     FVTOS # 8 WORD
  675.         NEXT
  676.         END-CODE
  677.  
  678. CODE F*   ( F: r1 r2 -- r1*r2)
  679.         CALL    (2VLOAD)
  680.         FMULP   ST(1), ST
  681.         ADD     FVTOS # 8 WORD
  682.         NEXT
  683.         END-CODE
  684.  
  685.  
  686. CODE F+    ( F: r1 r2 -- r1+r2)
  687.         CALL    (2VLOAD)
  688.         FADDP   ST(1), ST
  689.         ADD     FVTOS # 8 WORD
  690.         NEXT
  691.         END-CODE
  692.  
  693. CODE F-    ( F: r1 r2 -- r1-r2)
  694.         CALL    (2VLOAD)
  695.         FSUBRP  ST(1), ST(0)
  696.         ADD     WORD FVTOS # 8
  697.         NEXT
  698.         END-CODE
  699.  
  700. CODE F\-    ( F: r1 r2 -- r1-r2)
  701.         CALL    (2VLOAD)
  702.         FSUBP   ST(1), ST(0)
  703.         ADD     WORD FVTOS # 8
  704.         NEXT
  705.         END-CODE
  706.  
  707. CODE F/    ( F: r1 r2 -- r1/r2)
  708.         CALL    (2VLOAD)
  709.         FDIVRP  ST(1), ST(0)
  710.         ADD     WORD FVTOS # 8
  711.         NEXT
  712.         END-CODE
  713.  
  714. CODE FABS    ( F: r1 -- |r1|)
  715.         CALL    (1VLOAD)
  716.         FABS,
  717.         NEXT
  718.         END-CODE
  719.  
  720. CODE FNEGATE    ( F: r1 -- -r1 )
  721.         CALL  (1VLOAD)
  722.         FCHS
  723.         NEXT
  724.         END-CODE
  725.  
  726. CODE FSQRT    ( F: r1 -- SQRT[r1])
  727.         CALL   (1VLOAD)
  728.         FSQRT,
  729.         NEXT
  730.         END-CODE
  731.  
  732. CODE FLOG    ( F: r1 -- LOG10[r1])
  733.         CALL   (1VL1VE)
  734.         FLDLG2
  735.         FXCH   ST(1)
  736.         FYL2X
  737.         NEXT
  738.         END-CODE
  739.  
  740. CODE FLN    ( F: r1 -- LN[r1])
  741.         CALL   (1VL1VE)
  742.         FLDLN2
  743.         FXCH   ST(1)
  744.         FYL2X
  745.         NEXT
  746.         END-CODE
  747.  
  748. CODE 1/F  ( F: r -- r^-1)
  749.         CALL  (1VL1VE)
  750.         FLD1
  751.         FDIVP ST(1), ST(0)
  752.         NEXT
  753.         END-CODE
  754.  
  755. CODE F2*   ( F: r1 -- r2 )
  756.         CALL    (1VL1VE)
  757.         FLD1
  758.         FXCH    ST(1)
  759.         FSCALE
  760.         NEXT
  761.         END-CODE
  762.  
  763. CODE F2/   ( F: r1 -- r2 )
  764.         CALL    (1VL1VE)
  765.         CALL    (1VEMPTY)
  766.         FLD1
  767.         FCHS
  768.         FXCH    ST(1)
  769.         FSCALE
  770.         NEXT
  771.         END-CODE
  772.  
  773. CODE F2**N*    ( F: r1 -- r2 ; n -- )
  774.         CALL    (1VL1VE)
  775.         MOV     BX, SP
  776.         FLD     INTEGER*2 0 [BX]
  777.         ADD     SP, # 2
  778.         FXCH    ST(1)
  779.         FSCALE
  780.         NEXT
  781.         END-CODE
  782.  
  783. CODE FLOAT    ( F: -- r ; d -- )
  784.         CALL    (1VEMPTY)
  785.         MOV     BX, SP
  786.         MOV     AX, 0 [BX]
  787.         MOV     CX, 2 [BX]
  788.         MOV     2 [BX], AX
  789.         MOV     0 [BX], CX
  790.         FLD     INTEGER*4 0 [BX]
  791.         ADD     SP, # 4
  792.         SUB     FVTOS # 8 WORD
  793.         WAIT
  794.         NEXT
  795.         END-CODE
  796.  
  797. : (ROUND)    ( F: r -- ; n -- d )
  798.         FPCW> DUP >R  $F3FF AND OR >FPCW
  799.         1VLOAD FP>DI SWAP R> >FPCW ;
  800.  
  801. : FIX   ( F: r -- ; -- d )  $0000 (ROUND) ;
  802.  
  803. : INT   ( F: r -- ; -- d )  $0C00 (ROUND) ;
  804.  
  805. : RND>+INF  ( F: r -- ; -- d )  $0800 (ROUND) ;
  806.  
  807. : RND>-INF  ( F: r -- ; -- d )  $0400 (ROUND) ;
  808.  
  809. CODE FDUP    ( F: r -- r r )
  810.         CALL  (1VL1VE)
  811.         FLD   ST
  812.         SUB   FVTOS # 8 WORD
  813.         NEXT
  814.         END-CODE
  815.  
  816. CODE FOVER    ( F: r1 r2 -- r1 r2 r1 )
  817.         CALL  (2VLOAD)
  818.         CALL  (1VEMPTY)
  819.         FLD   ST(1)
  820.         SUB   FVTOS # 8 WORD
  821.         NEXT
  822.         END-CODE
  823.  
  824. CODE FSWAP   ( F: r1 r2 -- r2 r1 )
  825.         CALL  (2VLOAD)
  826.         FXCH  ST(1)
  827.         NEXT
  828.         END-CODE
  829.  
  830. CODE FNSWAP   ( F: rn rn-1 ... r1 r0 -- r0 rn-1 ... r1 rn ; n -- )
  831.         CLEAR_LABELS
  832.         CALL  (1VLOAD)
  833.         POP   BX
  834.         SHL   BX, 1
  835.         JZ    10 $
  836.         SHL   BX, 1
  837.         SHL   BX, 1
  838.         MOV   CX, FVTOS
  839.         MOV   AX, FVBOS
  840.         SUB   AX, CX
  841.         CMP   BX, AX
  842.         JA    8 $
  843.         CMP   BX, # 4 8 *
  844.         JA    6 $
  845.         JB    2 $
  846.         FXCH  ST(4)
  847. 10 $:   RET
  848. 2 $:    CMP   BX, # 2 8 *
  849.         JB    1 $
  850.         JA    3 $
  851.         FXCH  ST(2)
  852.         RET
  853. 1 $:    FXCH  ST(1)
  854.         RET
  855. 3 $:    FXCH  ST(3)
  856.         RET
  857. 6 $:    CMP   BX, # 6 8 *
  858.         JB    5 $
  859.         JA    7 $
  860.         FXCH  ST(6)
  861.         RET
  862. 5 $:    FXCH  ST(5)
  863.         RET
  864. 7 $:    FXCH  ST(7)
  865.         RET
  866. 8 $:    ADD   BX, CX
  867.         FSTP  REAL*8 FLOAT-WORK
  868.         FLD   REAL*8 0 [BX]
  869.         MOV   BX, CX
  870.         MOV   DI, # 7
  871. 9 $:    MOV   AL, FLOAT-WORK [DI]
  872.         MOV   0 [BX+DI], AL
  873.         DEC   DI
  874.         JNS   9 $
  875.         RET
  876.         END-CODE
  877.  
  878. CODE FROT    ( F: r1 r2 r3 -- r2 r3 r1 )
  879.         CALL  (3VLOAD)
  880.         FXCH  ST(1)           \ r1 r3 r2
  881.         FXCH  ST(2)           \ r2 r3 r1
  882.         NEXT
  883.         END-CODE
  884.  
  885. CODE F-ROT    ( F: r1 r2 r3 -- r3 r1 r2 )
  886.         CALL  (3VLOAD)
  887.         FXCH  ST(2)           \ r3 r2 r1
  888.         FXCH  ST(1)           \ r3 r1 r2
  889.         NEXT
  890.         END-CODE
  891.  
  892. CODE FNIP    ( F: r1 r2 -- r2 )
  893.         CALL  (2VLOAD)
  894.         FXCH  ST(1)
  895.         FSTP  ST(0)
  896.         ADD   WORD FVTOS # 8
  897.         NEXT
  898.         END-CODE
  899.  
  900. CODE FTUCK    ( F: r1 r2 -- r2 r1 r2 )
  901.         CALL  (2VLOAD)
  902.         CALL  (1VEMPTY)
  903.         FXCH  ST(1)            \ r2 r1
  904.         FLD   ST(1)
  905.         SUB   WORD FVTOS # 8
  906.         NEXT
  907.         END-CODE
  908.  
  909. CODE FPICK    ( F: rn ... r1 r0 -- rn ... r1 r0 rn ; n -- )
  910.         CLEAR_LABELS
  911.         CALL  (1VEMPTY)
  912.         POP   BX
  913.         SHL   BX, 1
  914.         SHL   BX, 1
  915.         SHL   BX, 1
  916.         MOV   CX, FVTOS
  917.         MOV   AX, FVBOS
  918.         SUB   WORD FVTOS # 8
  919.         SUB   AX, CX
  920.         CMP   BX, AX
  921.         JAE   8 $
  922.         CMP   BX, # 3 8 *
  923.         JA    5 $
  924.         JB    1 $
  925.         FLD   ST(3)
  926.         NEXT
  927. 1 $:    CMP   BX, # 1 8 *
  928.         JB    0 $
  929.         JA    2 $
  930.         FLD   ST(1)
  931.         NEXT
  932. 0 $:    FLD   ST(0)
  933.         NEXT
  934. 2 $:    FLD   ST(2)
  935.         NEXT
  936. 5 $:    CMP   BX, # 5 8 *
  937.         JB    4 $
  938.         JA    6 $
  939.         FLD   ST(5)
  940.         NEXT
  941. 4 $:    FLD   ST(4)
  942.         NEXT
  943. 6 $:    FLD   ST(6)
  944.         NEXT
  945. 8 $:    ADD   BX, CX
  946.         FLD   REAL*8 0 [BX]
  947.         NEXT
  948.         END-CODE
  949.  
  950. CODE (RVS0)     ( F: r -- ; -- fpsw )
  951.         CALL    (1VLOAD)
  952.         FTST
  953.         SUB     SP, # 2
  954.         MOV     BX, SP
  955.         FSTSW   0 [BX]
  956.         FSTP    ST(0)
  957.         ADD     WORD FVTOS # 8
  958.         WAIT
  959.         NEXT
  960.         END-CODE
  961.  
  962. : C3C0X    ( fpsw -- n )
  963.         DUP  $04000 AND
  964.         IF   2
  965.         ELSE 0
  966.         THEN
  967.         SWAP $00100 AND
  968.         IF   1+
  969.         THEN ;
  970.  
  971. : F0=   ( F: r -- ; -- f )
  972.         (RVS0) C3C0X 2 = ;
  973.  
  974. : FDUP0=   ( F: r -- r ; -- f )
  975.         FDUP F0= ;
  976.  
  977. : F0<  ( F: r -- ; -- f)  (RVS0) C3C0X 1 = ;
  978.  
  979. : F0>  ( F: r -- ; -- f)  (RVS0) C3C0X 0= ;
  980.  
  981. CODE (RVSR)    ( F: r1 r2 -- ; -- fpsw )
  982.         CALL    (2VLOAD)
  983.         FXCH    ST(1)
  984.         FCOMPP
  985.         ADD     WORD FVTOS # $10
  986.         SUB     SP, # 2
  987.         MOV     BX, SP
  988.         FSTSW   0 [BX]
  989.         WAIT
  990.         NEXT
  991.         END-CODE
  992.  
  993. : F=    ( F: r1 r2 -- ; -- f )
  994.         (RVSR) C3C0X 2 = ;
  995.  
  996. : F<    ( F: r1 r2 -- ; -- f )
  997.         (RVSR) C3C0X 1 = ;
  998.  
  999. : F>    ( F: r1 r2 -- ; -- f )
  1000.         (RVSR) C3C0X 0=  ;
  1001.  
  1002. : FMIN   ( F: r1 r2 -- rmin )
  1003.         FOVER FOVER F<
  1004.         IF   FDROP
  1005.         ELSE
  1006.              FNIP
  1007.         THEN ;
  1008.  
  1009. : FMAX    ( F: r1 r2 -- rmax )
  1010.         FOVER FOVER F>
  1011.         IF    FDROP
  1012.         ELSE
  1013.               FNIP
  1014.         THEN ;
  1015.  
  1016. CODE (FLIT)   ( F: -- r )
  1017.         CALL  (1VEMPTY)
  1018.         FLD   REAL*8 ES: 0 [SI]
  1019.         SUB   WORD FVTOS # 8
  1020.         WAIT
  1021.         ADD   SI, # 8
  1022.         NEXT
  1023.         END-CODE
  1024.  
  1025. : FLITERAL  ( F: r -- )
  1026.         COMPILE (FLIT) FLOAT-WORK F!
  1027.         4 0 DO
  1028.                 FLOAT-WORK I 2* +  @ X,
  1029.         LOOP
  1030.         ; IMMEDIATE
  1031.  
  1032. VARIABLE TRIG-MODE     TRIG-MODE OFF
  1033.  
  1034. : DEGREES    ( -- )
  1035.         TRIG-MODE ON ;
  1036.  
  1037. : RADIANS    ( -- )
  1038.         TRIG-MODE OFF ;
  1039.  
  1040.       PI F2* FCONSTANT 2PI
  1041.  
  1042.   PI F2/ F2/ FCONSTANT PI/4
  1043.  
  1044.       PI F2/ FCONSTANT PI/2
  1045.  
  1046.  
  1047. : DEG->RAD   ( F: r1 -- r2 )
  1048.         [ 180. FLOAT ] FLITERAL F/
  1049.         PI F* ;
  1050.  
  1051. : RAD->DEG    ( F: r1 -- r2 )
  1052.         [ 180. FLOAT ] FLITERAL F*
  1053.         PI F/ ;
  1054.  
  1055. INITFP CLEARFP
  1056.  
  1057. CODE [SIN]    ( F: r -- sin<r> )
  1058.         CALL   (1VLOAD)          \ radian argument
  1059.         CALL   (2VEMPTY)
  1060.         FLD1                     \ Load F1.0
  1061.         FCHS
  1062.         FXCH   ST(1)
  1063.         FSCALE                   \ arg/2
  1064.         FXCH   ST(1)
  1065.         FSTP   ST(0)
  1066.         FPTAN                    \ Partial tangent -> y, x
  1067.         FXCH   ST(1)
  1068.         FDIVRP ST(1), ST(0)      \ y/x
  1069.         FLD    ST(0)             \ dup
  1070.         FLD    ST(0)             \ dup
  1071.         FMULP  ST(1), ST(0)
  1072.         FLD1
  1073.         FADDP  ST(1), ST(0)      \ 1 + (y/x)**2
  1074.         FXCH   ST(1)
  1075.         FLD1
  1076.         FLD    ST(0)
  1077.         FADDP  ST(1), ST(0)      \ 2.0
  1078.         FMULP  ST(1), ST(0)      \ 2(y/x)
  1079.         FDIVP  ST(1), ST(0)      \ 2(y/x)/(1+(y/x)**2)
  1080.         NEXT
  1081.         END-CODE
  1082.  
  1083. CODE [COS]    ( F: r -- cos<r> )
  1084.         CALL   (1VLOAD)
  1085.         CALL   (2VEMPTY)
  1086.         FLD1
  1087.         FCHS
  1088.         FXCH   ST(1)
  1089.         FSCALE
  1090.         FXCH   ST(1)
  1091.         FSTP   ST(0)
  1092.         FPTAN
  1093.         FXCH   ST(1)
  1094.         FDIVRP ST(1), ST(0)
  1095.         FLD    ST(0)
  1096.         FMULP  ST(1), ST(0)
  1097.         FLD    ST(0)
  1098.         FLD1
  1099.         FADDP  ST(1), ST(0)
  1100.         FXCH   ST(1)
  1101.         FLD1
  1102.         FSUBRP ST(1), ST(0)
  1103.         FDIVP  ST(1), ST(0)
  1104.         NEXT
  1105.         END-CODE
  1106.  
  1107. CODE [TAN]    ( F: r -- tan<r> )
  1108.         CALL  (1VL1VE)
  1109.         FPTAN
  1110.         FXCH  ST(1)
  1111.         FDIVP ST(1), ST(0)
  1112.         NEXT
  1113.         END-CODE
  1114.  
  1115. : ?DEG->RAD   ( F: r1 -- r2 )
  1116.         TRIG-MODE @
  1117.         IF      DEG->RAD   THEN ;
  1118.  
  1119. F1.0 -53 F2**N* FCONSTANT SMALL-ANGLE
  1120.  
  1121. : FSIN1   ( F: r1 -- r2 )
  1122.         FDUP SMALL-ANGLE F>
  1123.         IF      [SIN]  THEN ;
  1124.  
  1125. : FCOS1   ( F: r1 -- r2 )
  1126.         FDUP SMALL-ANGLE F>
  1127.         IF      [COS]
  1128.         ELSE    FDROP F1.0
  1129.         THEN ;
  1130.  
  1131. : FSIN   ( F: r  -- SIN<r> )
  1132.         ?DEG->RAD FDUP F0< FABS
  1133.         FDUP PI/4 F/ INT 2DUP FLOAT PI/4 F* F- DROP
  1134.         DUP 2/ 2/ 1 AND NEGATE SWAP 3 AND
  1135.         DUP 0 = IF  DROP FSIN1                ELSE
  1136.         DUP 1 = IF  DROP PI/4 FSWAP F- FCOS1  ELSE
  1137.             2 = IF  FCOS1                     ELSE
  1138.                     PI/4 FSWAP F- FSIN1
  1139.         THEN THEN THEN 
  1140.         XOR IF  FNEGATE THEN ;
  1141.  
  1142. : FCOS ( F: r -- COS<r> )
  1143.         ?DEG->RAD
  1144.         FABS FDUP PI/4 F/ INT 2DUP FLOAT PI/4 F* F- DROP
  1145.         DUP 3 AND
  1146.         DUP 0 = IF  DROP FCOS1                ELSE
  1147.         DUP 1 = IF  DROP PI/4 FSWAP F- FSIN1  ELSE
  1148.             2 = IF  FSIN1                     ELSE
  1149.                     PI/4 FSWAP F- FCOS1
  1150.         THEN THEN THEN 
  1151.         2+ 2/ 2/ 1 AND
  1152.         IF FNEGATE THEN ;
  1153.  
  1154. F0.0 1/F FCONSTANT INFINITY
  1155.  
  1156. : FINFINITY=   ( F: r1 -- ; -- flag )
  1157.      1VLOAD FEXAM FDROP $0D00 AND $0500 = ;
  1158.  
  1159. FCLEAR
  1160.  
  1161. : FTAN1   ( F: r1 -- r2 )
  1162.         FDUP SMALL-ANGLE F>
  1163.         IF      [TAN]  THEN ;
  1164.  
  1165. : TANARG<>0 ( F: r -- TAN<r> ; n -- )
  1166.         [ FORTH ] 4 MOD
  1167.         DUP 0 = IF DROP FTAN1                          EXIT THEN
  1168.         DUP 1 = IF DROP PI/4 FSWAP F- FTAN1 1/F        EXIT THEN
  1169.         DUP 2 = IF DROP FTAN1 FNEGATE 1/F              EXIT THEN
  1170.         DUP 3 = IF DROP PI/4 FSWAP F- FTAN1 FNEGATE    EXIT THEN ;
  1171.  
  1172. : TANARG=0    ( F: -- TAN<r> ; n -- )
  1173.         [ FORTH ] 4 MOD
  1174.         DUP 0 = IF DROP F0.0           EXIT THEN
  1175.         DUP 1 = IF DROP F1.0           EXIT THEN
  1176.         DUP 2 = IF DROP INFINITY       EXIT THEN
  1177.         DUP 3 = IF DROP F1.0 FNEGATE   EXIT THEN ;
  1178.  
  1179. : FTAN    ( F: r -- TAN<r> )
  1180.         ?DEG->RAD FDUP F0< FABS
  1181.         FDUP PI/4 F/ INT 2DUP FLOAT PI/4 F* F- DROP 4 MOD
  1182.         FDUP F0=
  1183.         IF  FDROP TANARG=0
  1184.         ELSE  TANARG<>0  THEN
  1185.         IF FNEGATE THEN ;
  1186.  
  1187. ASSEMBLER ALSO
  1188.  
  1189. LABEL (POWER)    ( F: log2x y -- x^y )
  1190.         FMULP ST(1), ST(0)      \ x * y
  1191.         FLD   ST(0)             \ DUP
  1192.         FSTCW FLOAT-WORK        \ Save current Control Word
  1193.         MOV   AX, FLOAT-WORK
  1194.         MOV   CX, AX
  1195.         AND   AX, # $0F3FF
  1196.         OR    AX, # $00400      \ Round toward neg. inf.
  1197.         MOV   FLOAT-WORK AX
  1198.         FLDCW FLOAT-WORK
  1199.         FRNDINT                 \ Take floor of x*y
  1200.         MOV   FLOAT-WORK CX
  1201.         FLDCW FLOAT-WORK        \ Restore Control word.
  1202.         FST   REAL*8 FLOAT-WORK \ Save copy of floored value.
  1203.         FXCH  ST(1)
  1204.         FSUBP ST(1), ST(0)      \ (x*y) - floor(x*y) -> fract
  1205.         FLD1
  1206.         FCHS
  1207.         FXCH  ST(1)
  1208.         FSCALE                  \ fract/2
  1209.         FXCH  ST(1)
  1210.         FSTP  ST(0)             \ Remove the -1.
  1211.         F2XM1                   \ 2^(fract/2) - 1
  1212.         FLD1
  1213.         FADDP ST(1), ST(0)      \ 2^(fract/2)
  1214.         FLD   ST(0)             \ DUP
  1215.         FMULP ST(1), ST(0)      \ 2^fract
  1216.         FLD   REAL*8 FLOAT-WORK
  1217.         FXCH  ST(1)
  1218.         FSCALE                  \ 2^(x*y)
  1219.         FXCH  ST(1)
  1220.         FSTP  ST(0)             \ Remove the floored value.
  1221.         RET
  1222.         END-CODE
  1223.  
  1224. PREVIOUS FORTH
  1225.  
  1226. CODE (FALN)    ( F: r -- e^r )
  1227.         CALL   (1VL1VE)
  1228.         FLDL2E
  1229.         CALL (POWER)
  1230.         NEXT
  1231.         END-CODE
  1232.  
  1233. CODE (FALOG)    ( F: r -- 10^r )
  1234.         CALL   (1VL1VE)
  1235.         FLDL2T
  1236.         CALL (POWER)
  1237.         NEXT
  1238.         END-CODE
  1239.  
  1240. : FEXP ( F: r -- e^r )
  1241.         FDUP  699. FLOAT  F>
  1242.         IF   ." FALN ARGUMENT TOO LARGE" FDROP QUIT
  1243.         THEN
  1244.         (FALN) ;
  1245.  
  1246. : FALN   FEXP ;
  1247.  
  1248. : FALOG    ( F: r -- 10^r )
  1249.         FDUP  304. FLOAT  F>
  1250.         IF   ." FALOG ARGUMENT TOO LARGE" FDROP QUIT
  1251.         THEN
  1252.         (FALOG) ;
  1253.  
  1254. : FLOATDPL    ( F: -- r ; d -- )        \ Float a double, using DPL
  1255.         FLOAT DPL @ 0 FLOAT FALOG F/ ;
  1256.  
  1257. : F**    ( F: r1 r2 -- r1^r2 )
  1258.         FSWAP FLOG F* FALOG ;
  1259.  
  1260. CREATE (PI/2)  $18 C, $2D C, $44 C, $54 C, $FB C, $21 C, $F9 C, $FF C,
  1261.  
  1262. ASSEMBLER ALSO
  1263.  
  1264. LABEL (FATAN)   ( F: z -- arctan )
  1265.         FLD1
  1266.         FCOM  ST(1)
  1267.         FSTSW FLOAT-WORK
  1268.         MOV   AX, FLOAT-WORK
  1269.         AND   AX, # $04100
  1270.         0=
  1271.         IF
  1272.                 FPATAN
  1273.         ELSE
  1274.                 FXCH  ST(1)
  1275.                 FPATAN
  1276.                 FLD   REAL*8 (PI/2)
  1277.                 FSUBP ST(1), ST(0)
  1278.          THEN
  1279.          RET
  1280.          END-CODE
  1281.  
  1282. PREVIOUS FORTH
  1283.  
  1284. CODE FATAN    ( F: r -- arctan[r] )
  1285.         CALL  (1VL1VE)
  1286.         FTST
  1287.         FSTSW FLOAT-WORK
  1288.         MOV   AX, FLOAT-WORK
  1289.         AND   AX, # $04100
  1290.         SUB   AX, # $00100
  1291.         0=
  1292.         IF
  1293.                 FCHS
  1294.                 CALL  (FATAN)
  1295.                 FCHS
  1296.         ELSE
  1297.                 CALL  (FATAN)
  1298.         THEN
  1299.         NEXT
  1300.         END-CODE
  1301.  
  1302. : ARCRANGE    ( F: r -- r ; -- f )
  1303.         FDUP  F1.0  F>   FDUP  F1.0 FNEGATE F< OR ;
  1304.  
  1305. : FASIN    ( F: r -- arcsin[r] )
  1306.         ARCRANGE
  1307.         IF      FDROP ." INVALID FASIN ARGUMENT" QUIT
  1308.         ELSE
  1309.                 FDUP  F0< FABS  F1.0  FOVER  FDUP  F*  F-  FSQRT
  1310.                 F/  FATAN
  1311.                 IF FNEGATE  THEN
  1312.         THEN ;
  1313.  
  1314. : FACOS    ( F: r -- arccos[r] )
  1315.         ARCRANGE
  1316.         IF      FDROP ." INVALID FACOS ARGUMENT" QUIT
  1317.         ELSE    FDUP  F0<   FABS  F1.0  FOVER  FDUP  F*  F-  FSQRT
  1318.                 FSWAP  F/  FATAN
  1319.                 IF      PI  FSWAP  F-
  1320.                 THEN
  1321.         THEN ;
  1322.  
  1323. : XVALUE
  1324.         CREATE , DOES> @ ;
  1325.  
  1326. FALSE VALUE FP?
  1327.  
  1328. : FLOATS    ( -- )
  1329.         TRUE IS FP?   ;
  1330.  
  1331. : DOUBLES    ( -- )
  1332.         FALSE IS FP? ;
  1333.  
  1334. VARIABLE EXP?  EXP? OFF
  1335.  
  1336. VARIABLE FLOATING   FLOATING OFF
  1337.  
  1338. : FLOATING?
  1339.         FLOATING @ ;
  1340.  
  1341. : (FP-CHECK)    ( f addr -- f' addr )
  1342.         [ FORTH ] DUP C@ DUP ASCII e =
  1343.         IF   DROP ASCII E OVER C!  EXP? ON  EXIT
  1344.         THEN
  1345.         DUP ASCII 0 ASCII 9 BETWEEN
  1346.         IF DROP EXIT THEN
  1347.         DUP ASCII E =
  1348.         IF DROP EXP? ON      EXIT THEN
  1349.         DUP ASCII - =
  1350.         IF DROP EXIT THEN
  1351.         DUP ASCII + =
  1352.         IF DROP EXIT THEN
  1353.         ASCII . =
  1354.         IF EXIT THEN
  1355.         NIP 0 SWAP ;
  1356.  
  1357. : FP-CHECK    ( addr -- addr f )
  1358.         EXP? OFF DUP TRUE SWAP COUNT BOUNDS
  1359.         DO
  1360.                 I (FP-CHECK) DROP
  1361.         LOOP ;
  1362.  
  1363. CODE FMUL10    ( F: r1 -- r2 )
  1364.         CALL    (1VL1VE)
  1365.         MOV     FLOAT-WORK # 10 WORD
  1366.         FLD     INTEGER*2 FLOAT-WORK
  1367.         FMULP   ST(1), ST(0)
  1368.         NEXT
  1369.         END-CODE
  1370.  
  1371. CODE (FADDI)    ( F: r1 -- r2 ; n -- )
  1372.         CALL    (1VL1VE)
  1373.         MOV     BX, SP
  1374.         FLD     INTEGER*2 0 [BX]
  1375.         FADDP   ST(1), ST(0)
  1376.         ADD     SP, # 2
  1377.         NEXT
  1378.         END-CODE
  1379.  
  1380. : QCONVERT    ( +q1 adr1 -- +q2 adr2 )
  1381.         >R QI>FP R>
  1382.         BEGIN
  1383.                 1+ DUP >R C@ 10 DIGIT
  1384.         WHILE
  1385.                 FMUL10  (FADDI) DOUBLE? IF 1 DPL +! THEN R>
  1386.         REPEAT
  1387.         DROP FP>QI R> ;
  1388.  
  1389. CODE QNEGATE    ( +q -- -q )
  1390.         MOV     BX, SP
  1391.         FLD     0 [BX] INTEGER*8
  1392.         FCHS
  1393.         FSTP    0 [BX]
  1394.         NEXT
  1395.         END-CODE
  1396.  
  1397. : QFLOAT    ( F: -- r ; q -- )
  1398.         DPL @ 0 MAX DPL !
  1399.         QI>FP ( FP>R ) DPL @ S>D FLOAT FALOG F/ ;
  1400.  
  1401. : (MANTISSA)   ( F: -- r ; addr1 -- addr2 )
  1402.         DUP 1+ C@ ASCII + = ?MISSING            ( lead "+" invalid)
  1403.         DUP 1+ C@ ASCII - = DUP >R IF 1+ THEN   ( check for lead "-")
  1404.         -1 DPL ! >R 0 0 0 0 R>
  1405.         BEGIN
  1406.                 QCONVERT DUP C@ ASCII . =       ( convert till "E" )
  1407.         WHILE
  1408.                 0 DPL !                         ( reset DPL at "." )
  1409.         REPEAT
  1410.         R> SWAP >R
  1411.         IF QNEGATE
  1412.         THEN
  1413.         QFLOAT R> ;                             ( set sign and float )
  1414.  
  1415. : (EXP)    ( addr -- d )
  1416.         1+ DUP C@ ASCII + =
  1417.         IF 1+ THEN                              ( bypass "+" if present)
  1418.         DUP C@ ASCII - = DUP >R
  1419.         IF 1+ THEN                              ( check for "-")
  1420.         0 DPL ! 0 0 ROT 1- CONVERT DROP         ( convert it )
  1421.         2DUP 308. DU< 0= ?MISSING R>
  1422.         IF DNEGATE THEN 0 DPL ! ;
  1423.  
  1424. : FNUMBER    ( addr -- r | n | d | ; )
  1425.         [ FORTH ] FLOATING OFF FP-CHECK EXP? @ AND BASE @ 10 = AND 0=
  1426.         IF                    ( not a valid FP, valid # ?)
  1427.                 (NUMBER) DOUBLE?
  1428.                 IF
  1429.                         FP?   ( was double, if in FP mode, float it)
  1430.                         IF FLOATDPL FLOATING ON THEN
  1431.                 THEN
  1432.         ELSE                  ( has exponent, so convert it)
  1433.         (MANTISSA) (EXP) FLOAT FALOG F* DPL OFF FLOATING ON
  1434.         THEN ;
  1435.  
  1436. ' FNUMBER IS NUMBER
  1437.  
  1438. : F]    ( -- )
  1439.         STATE ON
  1440.         BEGIN
  1441.                 ?STACK  DEFINED DUP
  1442.                 IF    0>
  1443.                         IF   EXECUTE
  1444.                         ELSE  X,
  1445.                         THEN
  1446.                 ELSE
  1447.                         DROP  NUMBER  FLOATING?
  1448.                         IF
  1449.                                 [COMPILE] FLITERAL ELSE DOUBLE?
  1450.                                 IF
  1451.                                         [COMPILE] DLITERAL
  1452.                                 ELSE
  1453.                                         DROP [COMPILE] LITERAL
  1454.                                 THEN
  1455.                         THEN
  1456.                 THEN
  1457.                 TRUE  DONE?
  1458.         UNTIL ;
  1459.  
  1460. ' F] IS ]
  1461.  
  1462. : FMAG   ( F: r -- r ; -- n )
  1463.         FDUP FABS FLOG RND>-INF DROP ;
  1464.  
  1465. CREATE FLOAT-BCD 10 ALLOT
  1466.  
  1467. VARIABLE #BCD   17 #BCD !
  1468.  
  1469. CODE R>BCD!    ( F: r -- ; n -- ; full precision bcd-string to FLOAT-BCD )
  1470.        CALL     (1VLOAD)
  1471.        CALL     (2VEMPTY)
  1472.        MOV      AX, #BCD
  1473.        POP      CX
  1474.        SUB      AX, CX
  1475.        DEC      AX WORD
  1476.        PUSH     AX
  1477.        MOV      BX, SP
  1478.        FLD      INTEGER*2 0 [BX]
  1479.        ADD      SP, # 2
  1480.        FLDL2T
  1481.        CALL     (POWER)
  1482.        FMULP    ST(1), ST(0)
  1483.        FSTP     FLOAT-BCD BCD
  1484.        WAIT
  1485.        ADD      WORD FVTOS # 8
  1486.        NEXT
  1487.        END-CODE
  1488.  
  1489. : .DIGITS    ( last first -- )
  1490.         2DUP > ABORT"  FP I/O error. "
  1491.         DO I 1- 2/ FLOAT-BCD + C@ 16 /MOD I 2 MOD
  1492.              IF   DROP  ELSE   NIP  THEN
  1493.              ASCII 0 + EMIT 
  1494.          -1 +LOOP ;
  1495.  
  1496. : FULL2    ( n -- )
  1497.         0 <# # # #> TYPE ;
  1498.  
  1499. CREATE (I10)  10 ,
  1500.  
  1501. CODE FIXBCD   ( n1 -- n2 | FLOAT-BCD possibly changed )
  1502.         CLEAR_LABELS
  1503.         CALL    (2VEMPTY)
  1504.         MOV     AL, FLOAT-BCD 8 +
  1505.         CMP     AL, # $10
  1506.         JB      1 $
  1507.         MOV     BX, SP
  1508.         INC     0 [BX] WORD
  1509.         FLD     BCD FLOAT-BCD
  1510.         FLD     INTEGER*2 (I10)
  1511.         FDIVRP  ST(1), ST(0)
  1512.         FSTP    BCD FLOAT-BCD
  1513.         WAIT
  1514. 1 $:    NEXT
  1515.         END-CODE
  1516.  
  1517. : F.SPECIAL   ( F: r -- ; cc n -- )  \ Display special f-p numbers.
  1518.         SWAP DUP $0100 AND 0=
  1519.         IF   FDROP DROP SPACES EXIT  THEN
  1520.         DUP $4000 >
  1521.         IF   DROP " EMPTY"
  1522.         ELSE DUP $0200 AND  IF  ." -"  ELSE  ." +"  THEN
  1523.              $0400 >
  1524.              IF    FDROP " INFINITY"
  1525.              ELSE  FLOAT-WORK F!  FLOAT-WORK 2@ D0= >R
  1526.                    FLOAT-WORK 4 + 2@ SWAP
  1527.                    $7FFF AND 0 $7FF8 D= R> AND
  1528.                    IF   " INDEFINITE"  ELSE   " NAN"   THEN
  1529.              THEN
  1530.         THEN
  1531.         ROT $.R ;
  1532.  
  1533. : E.    ( F: r -- )
  1534.         FEXAM DUP $0100 AND
  1535.         IF   24 F.SPECIAL EXIT  THEN
  1536.         $4500 AND $4000 =
  1537.         IF   FDROP SPACE ." .00000000000000000E+00 " EXIT  THEN
  1538.         FMAG DUP R>BCD! FIXBCD FLOAT-BCD 9 + C@
  1539.         IF   ASCII - ELSE BL  THEN
  1540.         EMIT ASCII . EMIT
  1541.         1 17 .DIGITS ASCII E EMIT 1+ DUP 0<
  1542.         IF   ASCII - ELSE ASCII +  THEN
  1543.         EMIT ABS DUP 99 <
  1544.         IF   FULL2 SPACE   ELSE  .  THEN ;
  1545.  
  1546. VARIABLE #PLACES
  1547.  
  1548. : PLACES    ( n -- )
  1549.         17 MIN 1 MAX #PLACES ! ;
  1550.  
  1551.         4 PLACES
  1552.  
  1553. CODE FPARSE    ( F: r -- int-part frac-part )
  1554.         CALL    (1VLOAD)
  1555.         CALL    (2VEMPTY)
  1556.         FLD     ST0
  1557.         FSTCW   FLOAT-WORK
  1558.         MOV     AX, FLOAT-WORK
  1559.         MOV     CX, AX
  1560.         OR      AX, # $00C00
  1561.         MOV     FLOAT-WORK AX
  1562.         FLDCW   FLOAT-WORK
  1563.         FRNDINT
  1564.         MOV     FLOAT-WORK CX
  1565.         FLDCW   FLOAT-WORK
  1566.         FXCH    ST(1)
  1567.         FLD     ST(1)
  1568.         FSUBP   ST1, ST0
  1569.         SUB     WORD FVTOS # 8
  1570.         WAIT
  1571.         NEXT
  1572.         END-CODE
  1573.  
  1574. : .INT    ( F: r -- )
  1575.         FDUP F0=
  1576.         IF
  1577.                 FDROP ASCII 0 EMIT
  1578.         ELSE
  1579.                 #BCD @ DUP FMAG DUP R>BCD!
  1580.                 FIXBCD - SWAP .DIGITS
  1581.         THEN ;
  1582.  
  1583. CREATE (F2.0)     0 , 0 , 0 , $4000 ,
  1584.  
  1585. CODE FRNDFRC    ( F: +r1 -- +r2 )
  1586.         CALL    (1VLOAD)
  1587.         CALL    (2VEMPTY)
  1588.         FLD    INTEGER*2 #PLACES
  1589.         FCHS
  1590.         FLDL2T
  1591.         CALL    (POWER)
  1592.         FLD     REAL*8 (F2.0)
  1593.         FDIVRP  ST(1), ST(0)
  1594.         FADDP   ST(1), ST(0)
  1595.         NEXT
  1596.         END-CODE
  1597.  
  1598. : .FRAC    ( F: r -- )
  1599.         FDUP F0=
  1600.         IF
  1601.                 FDROP #PLACES @ 0
  1602.                 DO ASCII 0 EMIT
  1603.                 LOOP
  1604.         ELSE
  1605.                 -1 R>BCD! #BCD @ DUP #PLACES @ 1- - SWAP .DIGITS
  1606.         THEN ;
  1607.  
  1608. : F.    ( r -- )
  1609.         FEXAM DUP $0100 AND
  1610.         IF   SPACE #PLACES @ 3 + F.SPECIAL EXIT  THEN
  1611.         DROP FDUP F0<
  1612.         IF
  1613.                 ASCII - ELSE BL
  1614.         THEN
  1615.         EMIT FABS FPARSE FRNDFRC
  1616.         FDUP INT FLOAT FROT F+ .INT ASCII . EMIT .FRAC SPACE ;
  1617.  
  1618. : E.R0    ( #dec   #col -- )
  1619.         OVER - 5 - SPACES ASCII . EMIT 0
  1620.         DO
  1621.                 ASCII 0 EMIT
  1622.         LOOP
  1623.         ." E+00" ;
  1624.  
  1625. : E.R#    ( F: r -- ; #dec -- )
  1626.         >R FDUP F0<
  1627.         IF   ASCII -  ELSE   BL   THEN
  1628.         EMIT ASCII . EMIT
  1629.         FABS R> #PLACES @ >R PLACES  FMAG DUP >R
  1630.         1+ S>D FLOAT FALOG F/ FMAG >R FRNDFRC FMAG DUP R> - >R
  1631.         R>BCD! #PLACES @ 17 DUP ROT - 1+ SWAP .DIGITS
  1632.         ASCII E EMIT R> R> + 1+
  1633.         DUP 0<
  1634.         IF   ASCII - ELSE ASCII +   THEN
  1635.         EMIT ABS DUP 100 <
  1636.         IF   FULL2   ELSE   .   THEN
  1637.         R> PLACES ;
  1638.  
  1639. : E.R    ( F: r -- ; #dec #col -- )
  1640.         FEXAM  DUP $0100 AND
  1641.         IF   -ROT NIP F.SPECIAL EXIT  THEN
  1642.         $4500 AND $4000 =                        \ Test for zero
  1643.         IF   FDROP E.R0 EXIT  THEN
  1644.         FDUP FABS FLOG FABS 100.E0 F< >R         \ get exponent
  1645.         2DUP SWAP - R@ IF 6 ELSE 7 THEN - 0<     \ get # characters
  1646.         IF
  1647.                 0 DO ASCII * EMIT LOOP DROP FDROP R> DROP \ too big, *'s
  1648.         ELSE
  1649.                 OVER - R>
  1650.                 IF 6
  1651.                 ELSE 7
  1652.                 THEN
  1653.                 - SPACES E.R# \ ok, print it
  1654.         THEN ;
  1655.  
  1656. : F.R0    ( #dec   #col -- )
  1657.         2DUP SWAP - 3 - 0<
  1658.         IF
  1659.                 0 DO ASCII * EMIT LOOP
  1660.                 DROP
  1661.         ELSE
  1662.                 OVER - 2- SPACES ." 0." 0
  1663.                 DO ASCII 0 EMIT LOOP
  1664.         THEN ;
  1665.  
  1666. VARIABLE F.R+-
  1667.  
  1668. VARIABLE F.R#INT
  1669.  
  1670. : (F.R)    ( |r| #dec   #col -- +frac #dec )
  1671.         F.R#INT @ - OVER - 2 - SPACES         \ output lead blanks
  1672.         F.R+- @
  1673.         IF
  1674.                 ASCII -
  1675.         ELSE
  1676.                 BL
  1677.         THEN
  1678.         EMIT                                  \ output sign
  1679.         >R FSWAP F.R#INT @  R>BCD! F.R#INT @  \ convert to BCD
  1680.         #BCD @ DUP ROT - SWAP 1- .DIGITS R> ; \ output digits
  1681.  
  1682. : F.R ( F: r -- ; #dec #col -- )
  1683.         FEXAM DUP $0100 AND
  1684.         IF   -ROT NIP F.SPECIAL EXIT  THEN
  1685.         $4500 AND $4000 =                       \ test for a zero
  1686.         IF   FDROP F.R0 EXIT   THEN             \ if found, handle specially
  1687.         FDUP FINFINITY=
  1688.         IF   ." INFINITY " EXIT   THEN
  1689.         FDUP F0< F.R+- ! FDUP                   \ store the sign flag
  1690.         FABS OVER #PLACES @ SWAP #PLACES !
  1691.         >R FRNDFRC R> PLACES
  1692.                         \ round the number to the proper number of digits
  1693.         FMAG 1+ 1 MAX DUP F.R#INT !             \ get exponent
  1694.         >R 2DUP R> - SWAP - 2 - 0<              \ get the digit count
  1695.         IF
  1696.                 FDROP SPACE E.R                 \ too big, use E.R
  1697.         ELSE
  1698.                 FNIP FPARSE (F.R) ASCII . EMIT  \ output integer
  1699.                 >R 0 R>BCD! R> #BCD @ DUP ROT - SWAP 1- .DIGITS
  1700.         THEN ;   \ convert and output fractional part
  1701.  
  1702. : FDEPTH     ( -- n )
  1703.         FSP0 FVTOS @ - 8 / ;
  1704.  
  1705. : .FS  ( -- )
  1706.         FDEPTH ?DUP
  1707.         IF      CR 0
  1708.                 DO
  1709.                         FDEPTH I - 1- FPICK
  1710.                         8 ?LINE 3 10 F.R  KEY? ?LEAVE
  1711.                 LOOP
  1712.         ELSE ." Empty "
  1713.         THEN ;
  1714.  
  1715. : ROUND    ( F: r -- ; -- d )
  1716.         FDUP  F0>
  1717.         IF      RND>-INF
  1718.         ELSE    RND>+INF
  1719.         THEN ;
  1720.  
  1721. : IFLOAT    ( F: -- r ; n -- )
  1722.         S>D  FLOAT  ;
  1723.  
  1724. : R>N    ( F: r -- ; -- n )
  1725.         ROUND  ( INT )  DROP  ;
  1726.         ( Like  F>S  in PLOT.BLK )
  1727.  
  1728. \ : F>S       ( F: r -- ; -- n )
  1729. \        INT  DROP  ;
  1730.  
  1731. : F2DUP    ( F: r1 r2 -- r1 r2 r1 r2 )
  1732.         FOVER  FOVER  ;
  1733.  
  1734. : FMOD    ( F: r1 r2 -- r3 )
  1735.         F2DUP F/  INT  FLOAT  F*  F-  ;
  1736.  
  1737. : F,    ( F: r -- )
  1738.     HERE  8 ALLOT  F!  ;
  1739.  
  1740. : FARRAY   ( Comp:  rn ... r1 r0 n+1 -- ) ( Run:  k -- rk_addr)
  1741.     CREATE
  1742.         DUP  ,   0   DO   F,   LOOP
  1743.     DOES>                               ( index pfa )
  1744.         SWAP DUP  0<
  1745.         IF
  1746.                 DROP  @
  1747.         ELSE
  1748.                 8 * 2+  +
  1749.         THEN    ;
  1750.  
  1751. : ?FSTACK  ( -- )
  1752.         FVTOS @ FSP0 SWAP U<
  1753.         IF   FCLEAR TRUE ABORT" Floating Point Stack Underflow "  THEN
  1754.         FVTOS @ FSP0 FSTACK-SIZE 8 * - U<
  1755.         IF   FCLEAR TRUE ABORT" Floating point Stack Overflow "   THEN
  1756.         FPSW> DUP 1 AND
  1757.         IF   FCLEAR  CR ." Invalid Floating Point Operation. "    THEN
  1758.         DUP 4 AND
  1759.         IF   FCLEAR  CR ." Floating Point Divsion by zero. "       THEN
  1760.         8 AND
  1761.         IF   FCLEAR  CR ." Floating Point Overflow. "              THEN
  1762.         (?STACK) ;
  1763.  
  1764. ' ?FSTACK IS ?STACK
  1765.  
  1766. CREATE FR 94 ALLOT
  1767.  
  1768. : FFILL  INITFP FR 14 + 80 -1 FILL  FR >FREGS INITFP ;
  1769.  
  1770. : FR.   ( -- )
  1771.         FR >FREGS> BASE @ HEX CR 14 0
  1772.         DO FR I + @ 0 <# # # # # #> SPACE TYPE 2 +LOOP
  1773.         8 0 DO  CR SPACE 10 0
  1774.                 DO  FR 14 + J 10 * + I + C@ .2W  LOOP
  1775.         LOOP
  1776.         CR ." FVTOS = " FVTOS @ H.  ."  FVBOS = " FVBOS @ H.
  1777.         ."  FBASE = " FSP0 H.  BASE ! ;
  1778.  
  1779. \ .( ..Loaded)
  1780.  
  1781.  
  1782.