( file: FPOINT2)
(
******************************************************
*           F L O A T I N G   P O I N T              *
******************************************************
)
(  floating point compatible with the 9512 floating point chip
  single precision floating point format:

    11111111 11111111
    fedcba98 76543210 fedcba98 76543210 
    seeeeeee emmmmmmm mmmmmmmm mmmmmmmm
)


(
The fp routines call FPSET# to unpack the arguments as
shown below (the displacements are from SP). Notes:
 - Mantissas have the implied bit restored.
 - sign1 is stored in upper bit of s1, sign2 in upper
   bit of s2.  Lower bit of s1 and s2 contains sign1 xor
   sign2.
 - Exponents still have their bias (127 => 0)

00000000 m1m1m1m1
m1m1m1m1 m1m1m1m1   +14 mantissa 1
00000000 00000000
00000000 00000000   +10 temp
00000000 m2m2m2m2
m2m2m2m2 m2m2m2m2   +6  mantissa
s1s1s1s1 s2s2s2s2   +4  signs
e1e1e1e1 e2e2e2e2   +2  exponents
00000000 0SZ0DUV0   +0  result sts  (this is top of stack)
)

( FPADEXP: add the biased exponent in C to e1 (see above),
  set the V or U flags if necessary )

CODE FPADEXP#
  H PUSH, H 7 LXI, di, SP DAD, ei, A M MOV, 127 SUI,
  IFC  C ADD, CMC,  ELSE  C ADD,  THEN
  M A MOV, IFC
    H DCX, H DCX, H DCX, A M MOV, C INR, C DCR,
    IFM  2 ORI,  ELSE  4 ORI,  THEN
    M A MOV,
  THEN
  H POP, RET, ;NOTHREAD ASM

( FPSET: input: SP+2 -> 2 floating point arguments.
  output: 2 arguments unpacked as shown above (SP ->
  result sts) input BC saved on control stack,
  hl-> e2  b=e1  c=e2  d=s1  e= s2 )

CODE FPSET#
  ' PSHBC# CALL, ( save interpreter PC) D POP, ( ret)
  H 0 LXI, H PUSH, H PUSH, H PUSH, H PUSH, H PUSH, ( alloc stk)
  D PUSH, ( RET)
  ( unpack fp1)  H 18 LXI, di, SP DAD, ei, A M MOV, B A MOV, 80H ORI,
  M A MOV,  A B MOV, RAL, H INX, A M MOV, RAL, B A MOV,
  A 0 MVI, M A MOV,  RAR,
  ( unpack fp2) D -5 LXI, D DAD, D A MOV, ( d=s1) A M MOV,
  RAL, H INX, A M MOV, RAL, C A MOV, A 0 MVI, M A MOV, RAR,
  E A MOV, D XRA, IFNZ E INR, D INR, THEN ( set s1 xor s2)
  D PUSH, ( save signs)
  ( move m2) H DCX, A M MOV, 80H ORI, M 0 MVI, H DCX,
  D M MOV, M 0 MVI, H DCX, E M MOV, M 0 MVI, H DCX, H DCX,
  M A MOV, H DCX, M D MOV, H DCX, M E MOV, D POP, ( get signs)
  H DCX, M D MOV, H DCX, M E MOV, H DCX, M B MOV, H DCX,
  M C MOV, RET, ;NOTHREAD ASM

( FPEXIT: input: A OR C has rounding bits.  HL -> mantissa
  that contains result. e1 = result exp. low bit of s1 has
  result sign. SP -> unpacked data as above.
  Output: result packed up to stack. S and Z bits in status
  set (also maybe overflow when rounding). Restores BC
  ( saved on control stack) and Jmps to  interpreter.
  Stack on output: fpreshi fpreslo ressts
  Note: this is jumped to (not called). )

CODE FPEXIT#
  C ORA, IFM ( rounding needed)
    B A MOV, C 3 MVI, STC, ( bump mantissa)
    BEGIN A M MOV, 0 ACI, M A MOV, H INX, C DCR, ENDZ
    H DCX, IFC ( mantissa overflow)
     M 80H MVI, C 128 MVI, ' FPADEXP# CALL, ( "rgt shft")
    THEN
    H DCX, H DCX, A B MOV, 80H CPI, ( round to even if 1/2)
    IFZ  A M MOV, 0FEH ANI, M A MOV, THEN
  THEN
  C M MOV, H INX, B M MOV, H INX, A M MOV, 7FH ANI, E A MOV,
  ( ebc=mantissa)
  H POP, ( ressts) A L MOV, H POP, ( h=exp) L A MOV,
  A H MOV, RRC, 80H ANI, E ORA, E A MOV, ( lsb of exp)
  D H MOV, di, XTHL, ( h=sign) ei, A H MOV, RAR, A D MOV, RAR, D A MOV,
  ( now debc = packed fp) H POP, A L MOV, ( a=sts)
  H 12 LXI, di, SP DAD, SPHL, ei, ( dump stk) D PUSH, B PUSH, ( fp)
  L A MOV, H 0 MVI, ( hl=sts)
  H PUSH, ' POPBC# CALL, H POP,
  ( *** fall into next routine *** ) ;NOTHREAD ASM

( SSEXIT: input: stack contains fpresult, hl has status bits
  output: set sign and zero  status, push status and jump
  to interpreter)

CODE SSEXIT#
  D POP, di, XTHL, ei, A D MOV, E ORA, H ORA, L ORA,
  IFZ di, XTHL, ei, A L MOV, 20H ORI, L A MOV, di, XTHL, ei, THEN
  A H MOV, A ORA, di, XTHL, ei, D PUSH,
  IFM A L MOV, 40H ORI, L A MOV, THEN  ;PUSH  ASM

( FP0CHK:  input: 2 fp nums on stack above return addr.
  output: E contains NOS fp zero status, A and flags
  contain TOS fp zero status:  0 for zero  ff for nonzero )

CODE FP0CHK#
  H 9 LXI, di, SP DAD, ei, B PUSH, A XRA, B 303H LXI,
  BEGIN M ORA, H DCX, C DCR, ENDM C ADD, A SBB, E A MOV, A XRA,
  BEGIN M ORA, H DCX, B DCR, ENDM C ADD, A SBB, B POP,
  RET, ;NOTHREAD ASM


CODE FP* ( fp1hi fp1lo fp2hi fp2lo -- fpprodhi fpprodlo sts)
  ' FP0CHK# CALL, E ANA, IFZ
    H 8 LXI, di, SP DAD, SPHL, ei, L A MOV, H A MOV, H PUSH, H PUSH,
    ' SSEXIT# JMP,
  THEN
  ' FPSET# CALL, ' FPADEXP# CALL, ( add the exponents)
  ( do 24 bit multiply)
  H 14 LXI, di, SP DAD, ei, XCHG, H -8 LXI, D DAD, C 24 MVI, BEGIN
    A M MOV, RAR, H INX, H INX, H INX, IFC
      B 3 MVI, A ORA, D PUSH,
      BEGIN D LDAX, M ADC, M A MOV, H INX, D INX, B DCR, ENDZ
      D POP,
    ELSE
      H INX, H INX, H INX,
    THEN
    B 6 MVI, ( 48 bit right shift) ( CY may be from add above)
    BEGIN H DCX, A M MOV, RAR, M A MOV, B DCR, ENDZ
    C DCR,
  ENDZ
  D 5 LXI, D DAD, A M MOV, A ORA, IFM ( mantissa ovrfl)
    C 128 MVI, ' FPADEXP# CALL, ( bump exp)
  ELSE ( normalize, note carry is clear)
    H DCX, H DCX, H DCX, C 4 MVI, ( include guard bit)
    BEGIN A M MOV, RAL, M A MOV, H INX, C DCR, ENDZ
  THEN
  H 6 LXI, di, SP DAD, ei, A M MOV, H INX, M ORA, ( sticky bits)
  C 0 MVI, IFNZ C INR, THEN
  H INX, A M MOV, ( guard bits)
  H INX, ' FPEXIT# JMP, ;NOTHREAD

CODE FP/
  ' FP0CHK# CALL, IFZ
    H POP, H POP, H 8 LXI, ' SSEXIT# JMP,
  THEN
  E ANA, IFZ
    H 8 LXI, di, SP DAD, SPHL, ei, L A MOV, H A MOV, H PUSH, H PUSH,
    ' SSEXIT# JMP,
  THEN
  ' FPSET# CALL, A C MOV, CMA, A DCR, C A MOV, A INR, IFNZ
    ' FPADEXP# CALL,
  ELSE ( exp was +128: special case)
    H 3 LXI, di, SP DAD, ei, A M MOV, 128 SUI, M A MOV,
    IFC H DCX, H DCX, H DCX, M 4 MVI, THEN ( if underflow)
  THEN
  H 6 LXI, di, SP DAD, ei, XCHG, H 8 LXI, D DAD, C 26 MVI,
  BEGIN
    ( de -> m2; hl -> m1) H PUSH, D PUSH, B 4 MVI, A ORA, XCHG,
    BEGIN D LDAX, M SBB, D STAX, H INX, D INX, B DCR, ENDZ
    D POP, H POP, IFC ( result was neg)
      H PUSH, D PUSH, B 4 MVI, A ORA, ( undo subtract)
      BEGIN D LDAX, M ADC, M A MOV, H INX, D INX, B DCR, ENDZ
      D POP, H POP, STC,
    THEN
    ( shift in next bit of answer and shift divedend)
    CMC, H DCX, H DCX, H DCX, H DCX, B 8 MVI,
    BEGIN A M MOV, RAL, M A MOV, H INX, B DCR, ENDZ
    C DCR, H 13 LXI, di, SP DAD, ei, A M MOV, H INX, 2 ANI,
  ENDNZ
  C INR, IFZ C 126 MVI, ' FPADEXP# CALL, THEN
  C 2 MVI, BEGIN
    B 4 MVI, A ORA, H PUSH,
    BEGIN H DCX, A M MOV, RAR, M A MOV, B DCR, ENDZ
    A D MOV, RAR, D A MOV, H POP, C DCR,
  ENDZ
  A D MOV, 0C0H ANI, C A MOV,
  A M MOV, H INX, M ORA, H INX, M ORA, H INX, M ORA,
  IFNZ C INR, THEN ( if remainder # 0 then set sticky bit)
  H 10 LXI, di, SP DAD, ei, A XRA, ' FPEXIT# JMP, ;NOTHREAD


CODE FPNEG#
  C 5 MVI, STC, BEGIN
    A M MOV, CMA, 0 ACI, M A MOV, H INX, C DCR,
  ENDZ
  RET, ;NOTHREAD ASM

CODE FP-
  ' FP0CHK# CALL, IFNZ
      H POP, D POP, A D MOV, 80H XRI, D A MOV, D PUSH, H PUSH,
    THEN
    ;NOTHREAD  ( *** fall into FP+ *** )

CODE FP+
  ' FP0CHK# CALL, IFZ ( nos zero?)
    PSW POP, PSW POP, H 0 LXI, ' SSEXIT# JMP,
  THEN
  E ANA, IFZ ( tos zero?)
    H POP, D POP, PSW POP, PSW POP, D PUSH, H PUSH,
    H 0 LXI, ' SSEXIT# JMP,
  THEN
  ' FPSET# CALL, H PUSH, B PUSH,
  H 10 LXI, di, SP DAD, ei, C M MOV, M 0 MVI, H INX, A M MOV, M C MOV,
  H INX, C M MOV, M A MOV, H INX, M C MOV,
  B POP, H POP, A C MOV, B CMP, IFC ( tos exp greater)
    C B MOV, B A MOV, H INX,
    H INX, M D MOV, H INX, M E MOV, H INX, H INX, XCHG,
    H 7 LXI, D DAD, B PUSH, C 3 MVI, BEGIN
      B M MOV, D LDAX, M A MOV, A B MOV, D STAX,
      H INX, D INX, C DCR,
    ENDZ
    B POP,
  ELSE
    H INX, M C MOV, ( set result exp in nos greater case)
  THEN
  ( now tos has smaller exp.)
  A C MOV, B SUB, IFNZ ( any to shift)
    26 CPI, IFNC ( big diff in magnitudes)
      A XRA, H 14 LXI, di, SP DAD, ei,
      M A MOV, H INX, M A MOV, H INX, M A MOV, H INX, M A MOV,
    ELSE ( need to shift)
      C A MOV, BEGIN
        H 17 LXI, di, SP DAD, ei, A ORA, B 4 MVI,
        BEGIN H DCX, A M MOV, RAR, M A MOV, B DCR, ENDZ
        IFC 1 ORI, M A MOV, THEN ( preserve sticky bits)
        C DCR,
      ENDZ
    THEN
  THEN
  H 4 LXI, di, SP DAD, ei, H PUSH, A M MOV, A ORA,
  IFM  H INX, H INX, ' FPNEG# CALL, THEN
  H POP, H INX, H PUSH, A M MOV, A ORA,
  IFM D 8 LXI, D DAD, ' FPNEG# CALL, THEN
  D POP, D INX, H 7 LXI, D DAD, H PUSH, A ORA, C 5 MVI,
  BEGIN D LDAX, M ADC, M A MOV, H INX, D INX, C DCR, ENDZ
  H POP, A ORA, IFM ( answer is negative)
    ' FPNEG# CALL, A 1 MVI,
  ELSE
    A XRA,
  THEN
  H 5 LXI, di, SP DAD, ei, M A MOV,
  H 13 LXI, di, SP DAD, ei, A M MOV, 80H ANI, H INX, M ORA,
  H INX, M ORA, H INX, M ORA, H INX, M ORA, IFZ
    H 3 LXI, di, SP DAD, ei, M A MOV, H INX, H INX, M A MOV,
  ELSE
    H 17 LXI, di, SP DAD,  ei, A M MOV, A ORA, IFNZ
      C 4 MVI, STC,
      BEGIN H DCX, A M MOV, RAR, M A MOV, C DCR, ENDZ
      IFC 1 ORI, M A MOV, THEN
      C 128 MVI, ' FPADEXP# CALL,
    ELSE
      REPEAT H DCX, A M MOV, A ORA, WHILEP
        D -3 LXI, D DAD, A M MOV, RAR, C 4 MVI,
        BEGIN A M MOV, RAL, M A MOV, H INX, C DCR, ENDZ
        C 126 MVI, ' FPADEXP# CALL,
      ENDWHILE
    THEN
  THEN
  H 13 LXI, di, SP DAD, ei, A M MOV, C A MOV, H INX, ' FPEXIT# JMP,
  ;NOTHREAD



( exception status bits:)
2 CONST OVFLW  4 CONST UNFLW  8 CONST DIV/0

: FPEXCEP
  FH AND ?DUP IF ( an exception occurred)
    CASE
      OVFLW OF " Overflow" ENDOF
      UNFLW OF ,DROP ,0 " Underflow" ENDOF
      DIV/0 OF " Divide by 0" ENDOF
      DROP
    ENDCASE
    CRLF " ** Floating point => " ." ."
  THEN ;

( ***** Normal primitive entry points ***** )

: F+ FP+ FPEXCEP ;
: F- FP- FPEXCEP ;
: F* FP* FPEXCEP ;
: F/ FP/ FPEXCEP ;

0,0         ,CONST  0.   ( common constants)
3F80,0000H  ,CONST  1.
4000,0000H  ,CONST  2.
4120,0000H  ,CONST 10.
3DCC,CCCDH  ,CONST   .1

( **** miscellaneous floating point operations ***** )

: FABS  SWAP 7FFFH AND SWAP ;  ( fp absolute value)
: F-1*  ,DUP OR IF SWAP 8000H XOR SWAP THEN ;  ( fp negate)
: F>    F- DROP 0> ;           ( fp greater than)
: F<    ,SWAP F> ;             ( fp less than)
  0FFFF,FFFCH ,CONST F=MASK     
: F=   ,XOR F=MASK ,AND ,0= ;  ( fp "nearly equal")


( ***** floating point input/output routines ***** )

CODE FPDRND ( decexp d7 d56 d34 d12 ... startadr count --
              decexp d7 d56 d34 d12 ... )
  D POP, H POP, A ORA, BEGIN
    A 0 MVI, CMC, M ADC, 10 CPI, IFNC A 0 MVI, THEN
    M A MOV, H DCX, E DCR,
  ENDZ
  ( if overflowed, then make string = 1000000
    and increment decimal exp)
  IFNC H INX, M 1 MVI, D 8 LXI, D DAD, M INR, ( exp) THEN ;

: FPOUT  ( fpnhi fpnlo -- dexp dig7 digs56 digs34 digs12 sign )
  0 0 0 0 6 PICK 6 PICK 0 7 POKE 0 8 POKE
  ( stk: 0 0 0 0 0 0 fp fp )
  ,DUP FABS OR  IF ( not zero or -(2EXP-127))
    OVER 0 < IF 1 3 POKE FABS THEN
    BEGIN
      ,DUP 3F80,0000H ,>= IF 
        .1 F*    0  1     ( case of >= 1.)
      ELSE
        3DCC,CCCDH ,OVER ,> IF 
          10. F*   0  -1   ( case of < .1)
        ELSE
          1  0          ( case of >= .1 and < 1.)
        THEN
      THEN
      10 PICK + 9 POKE ( inc, dec, or no change decimal exp)
    END
    OVER DUP 7FH AND 80H OR 3 POKE ( set implied bit)
    128 / 127 - ( -4 to -1) 5 + ( 1 to 4)
    1 SWAP 1 DO DUP + LOOP ( pwr of 2)
    DOUBLE ,* ( align by shifting left)
    6 0 DO ( generate 7 digits)
      ,10 ,* SWAP DUP F000H AND SHR8 16 / SP@ 8 + I + B!
      0FFFH AND SWAP
    LOOP
    DROP 2048 >= IF ( rounding needed)  SP@ 8 + 7 FPDRND  THEN
  ELSE
    ,DROP
  THEN ;

: PDIG ( val --) "0" + .C ;
: PEXP ( exp -- )
  "E" .C DUP 0 < IF ABS "-" ELSE "+" THEN .C 
  10 /MOD PDIG PDIG ;
: PDIGS ( addr cnt -- ) 1 DO DUPB@ PDIG 1+ LOOP DROP ;

: PSDIGS ( addr cnt -- )
  OVER OVER + OVER 1
  DO  1- DUPB@ IF EXIT ELSE SWAP 1- SWAP THEN LOOP
  DROP dup 6 swap - 3 pick 3 pick
  PDIGS spcs drop drop ;

: F. ( fpnhi fpnlo -- )
  32 .C FPOUT IF "-" .C THEN
  4 PICK 5 >= IF SP@ 5 + 6 FPDRND THEN
  5 PICK IF[ 0 THRU 6 ]
    SP@ 6 PICK OVER OVER PDIGS
    DUP 0= IF "0" .C THEN   "." .C
    SWAP OVER + SWAP 6 SWAP - PSDIGS
  ELSE
    DUP PDIG "." .C   SP@ 1+ 5 PSDIGS  5 PICK 1- PEXP 
  THEN
  5 KILL ;


CODE ,2* ( dphi dplo -- dphi dplo )
  H POP, D POP, H DAD, XCHG, RAR, H DAD, RAL,
  IFC H INX, THEN  H PUSH, D PUSH, ;

CODE ,2/ ( dphi dplo -- dphi dplo )
  H POP, D POP, A ORA, A D MOV, RAR, D A MOV, A E MOV, RAR,
  E A MOV, A H MOV, RAR, H A MOV, A L MOV, RAR, L A MOV,
  D PUSH, ;PUSH

: INTEGER ( fpnhi fpnlo -- dpnhi dpnlo)
  ,DUP OVER 7F80H AND 128 / 127 -
  3 PICK 7FH AND 80H OR 3 POKE CASE
    OF[  0 THRU 23 ]   22 SWAP DO ,2/ LOOP   ENDOF
    OF[ 24 THRU 30 ]   -24 SWAP -1* DO ,2* LOOP  ENDOF
    DROP ,DROP 0,
   ENDCASE
   ,SWAP ,0 ,< IF ,-1* THEN ;

: FLOAT ( dpnhi dpnlo -- fpnhi fpnlo)
  ,DUP OR IF ( not zero)
    4B00,0000H ,SWAP ,DUP ,0 ,< IF ,-1* CB00H 4 POKE THEN
    SWAP 7FFFH AND SWAP
    REPEAT OVER FF00H AND WHILE
      ,2/ 4 PICK 80H + 4 POKE ENDWHILE
    REPEAT OVER 0080H < WHILE
      ,2* 4 PICK 80H - 4 POKE ENDWHILE
    7F,FFFFH ,AND ,OR
  THEN ;


( FPEVAL converts a string to a floating point number.
  On exit, status flags are returned:
     bit 0: No mantissa digits encountered
     bit 1: Trailing characters ("invalid chars") in string
     bit 3: No decimal point encountered
  In the case of a null string, all three flags are set.
  The format is:
     1. Optional sign ("+" or "-")
     2. Digits before dec point
     3. Decimal Point
     4. Digits after dec point
     5. Optional "E"
        5a: Optional sign
        5b: Exponent digits
 
  Error conditions (flags set) are still evaluated correctly:
     "100"   returns  100.   sts 4 ( no d.p.)
     "E10"   returns  1.E+10 sts 1 ( no mantissa digs)
     ""      returns  0.0    sts 7 ( null)
     "100-"  returns  100.   sts 2 ( trailing chars)
  Strings that return no status flags set:
     1.E10   +4.  .7E+9  -3.3  4.E-15   6000000000000.
     .000000000001    9999999999999.
)

: FPEVAL ( straddr -- fpnhi fpnlo flags)
  0 07H 0,0 0 6 PICK B@ 1 DO
    ( stk: straddr exp flags acchi acclo sign )
    6 PICK I + B@ CASE  ( switch on next character)

      OF[ "0" THRU "9" ]
        ( add in only if significant)
        "0" - DOUBLE 5 PICK 5 PICK 214,748,364 ,OVER ,> IF
          ,10 ,* ,+ 3 POKE 3 POKE
          ( decrement exp if d.p. has been found)
          4 PICK 4 AND 0= IF 5 PICK 1- 5 POKE THEN
        ELSE ( not sig.)
          4 KILL 4 PICK 4 AND IF 5 PICK 1+ 5 POKE THEN
        THEN
        4 PICK 0EH AND 4 POKE ( clear no digs found flag)
      ENDOF

      OF[ "+" "-" ]
        ( update signflag if this is first char, else exit)
        I 1 = IF "-" = SWAP DROP ELSE DROP EXIT THEN
      ENDOF

      "." OF
        ( clear no dp flag if this is first dp, else exit)
        4 PICK DUP 4 AND IF 0BH AND 4 POKE ELSE DROP EXIT THEN
      ENDOF

      "E" OF
        1 0 8 PICK B@ I 1+ DO
          ( stk: addr exp flgs achi aclo sign Esign Eaccum )
          8 PICK I + B@ CASE
            OF[ "0" THRU "9" ]
              "0" - SWAP 10 * + ( add in digit)
            ENDOF
            OF[ "+" "-" ]
              ( update sign if first char, else exit)
              I J 1+ = IF
                "-" = IF -1 2 POKE THEN
              ELSE
                DROP EXIT
              THEN
            ENDOF
            DROP EXIT ( none of above so exit loop)
          ENDCASE
          ( clear trailing digits flag if loop max reached)
          8 PICK B@ I = IF 6 PICK 0DH AND 6 POKE THEN
        LOOP
        * ( set sign) 6 PICK + 5 POKE ( expaccum updated)
        EXIT ( exit outer loop)
      ENDOF

      DROP EXIT ( other case, not digit, ".", "+", "-", or "E")
    ENDCASE
    ( clear trailing digits flag if loop max reached)
    6 PICK B@ I = IF 4 PICK 0DH AND 4 POKE THEN
  LOOP
  IF ,-1* THEN ( change sign if sign flag set)
  ( convert to floating and exp adjust)
  FLOAT 4 PICK DUP 0> IF
    1 DO 10. F* LOOP
  ELSE
    ABS 1 DO 10. F/ LOOP
  THEN
  3 POKE 3 POKE ( stk: fpnhi fpnlo flags) ;