( 8 July 88 -- MFB )
off printload
( ******************************************** )
( *                                          * )
( *    FORTH DOUBLE PRECISION DEFINITIONS    * )
( *                                          * )
( ******************************************** )

: ,AND
  SWAP 4 PICK AND 3 POKE AND ;

: ,OR
  SWAP 4 PICK OR 3 POKE OR ;

: ,XOR
  SWAP 4 PICK XOR 3 POKE XOR ;

( NOTE THAT ,LDI IS IN BASIC )

CODE ,VLOAD ( LOAD DBL PREC CONSTANT)
  H POP, E M MOV, H INX, D M MOV, H INX,
  A M MOV, H INX, H M MOV, L A MOV, H PUSH, D PUSH, ;

CODE ,+ ( DBL PREC ADD)
  D POP, H POP, di, XTHL, ( HL,DE ARE LSBS)
  D DAD, D POP, XTHL, ei, ( HL,DE MSBS & TOS IS LSB SUM)
  IFC ( IF LSB SUM SET CY)
    H INX,
  THEN
  D DAD, di, XTHL, ei, ;PUSH ( ,TOS IS SUM)

CODE ,- ( DBL PREC SUBTRACT)
  H 4 LXI, di, SP DAD, ei, ( HL -> NOS) D POP, A M MOV, E SUB,
  M A MOV, H INX, A M MOV, D SBB, M A MOV, H INX, D POP,
  A M MOV, E SBB, M A MOV, H INX, A M MOV, D SBB, M A MOV, ;

CODE ,@ ( DBL PREC FETCH)
  H POP, E M MOV, H INX, D M MOV, H INX,
  A M MOV, H INX, H M MOV, L A MOV, H PUSH, D PUSH, ;

CODE ,! ( DBL PREC STORE)
  H POP, D POP, M E MOV, H INX, M D MOV, H INX,
  D POP, M E MOV, H INX, M D MOV, ;

CODE ,DUP
  H POP, D POP, D PUSH, H PUSH, D PUSH, ;PUSH

CODE ,DROP
 H POP, H POP, ;

CODE SINGLE ( CONVERT ,TOS TO TOS)
  D POP, H POP, D PUSH, ;

CODE DOUBLE ( CONVERT TOS TO ,TOS)
  H 0 LXI, D POP, D INR, D DCR, IFM ( IF TOS WAS < 0 )
    H DCX, ( SIGN EXTEND)
  THEN
  H PUSH, D PUSH, ;

CODE ,SWAP
  H POP, di, XTHL, XCHG, H 5 LXI, SP DAD, ei, A M MOV, M D MOV,
  D A MOV, H DCX, A M MOV, M E MOV, E A MOV,
  H POP, di, XTHL, ei, D PUSH, ;PUSH

CODE ,OVER
  H 7 LXI, di, SP DAD, ei, D M MOV, H DCX, E M MOV, D PUSH,
  H DCX, D M MOV, H DCX, E M MOV, D PUSH, ;

CODE ,>= ( TEST: ,NOS >= ,TOS ?)
  D POP, H POP, di, XTHL, ei, A L MOV, E SUB, A H MOV, D SBB,
  D POP, H POP, A L MOV, E SBB, A H MOV, D SBB,
  H 0 LXI, IFP
    L INR,
  THEN
  ;PUSH

CODE ,0> ( TEST: IS ,TOS > 0 ?)
  D POP, A E MOV, D ORA, D POP, E ORA, D ORA, IFNZ
    D INR, D DCR, D 0 LXI, IFP
      E INR,
    THEN
  THEN
  D PUSH, ;

CODE ,0= ( TEST: IS ,TOS = 0 ?)
  H POP, D POP, A L MOV, H ORA, E ORA, D ORA,
  H 0 LXI, IFZ
    L INR,
  THEN
  ;PUSH

CODE ,> ( TEST: IS ,NOS > ,TOS ?)
  D POP, H POP, di, XTHL, ei, A E MOV, L SUB, A D MOV, H SBB,
  D POP, H POP, A E MOV, L SBB, A D MOV, H SBB,
  H 0 LXI, IFM
    L INR,
  THEN
  ;PUSH

CODE ,< ( TEST: IS ,NOS < ,TOS ? )
  D POP, H POP, di, XTHL, ei, A L MOV, E SUB, A H MOV, D SBB,
  D POP, H POP, A L MOV, E SBB, A H MOV, D SBB,
  H 0 LXI, IFM
    L INR,
  THEN
  ;PUSH

CODE ,= ( TEST: ,NOS = ,TOS ? )
  D POP, H POP, di, XTHL, ei, A L MOV, E SUB, L A MOV,
  A H MOV, D SUB, L ORA, D POP, H POP, PSW PUSH,
  A L MOV, E SUB, L A MOV, A H MOV, D SUB, H A MOV,
  PSW POP, H ORA, L ORA, H 0 LXI, IFZ
    L INR,
  THEN
  ;PUSH

CODE %,CHSGN ( ASM LANG SUBROUTINE TO CHANGE SIGN)
            ( OF 32 BIT VALUE.  ON ENTRY HL -> LSB,)
            ( ON EXIT, HL=HL+4, DE=0, AFBC UNCHANGED)
  PSW PUSH, STC, ( CY=1) D 4 LXI, ( E IS COUNTER)
  BEGIN
    A M MOV, CMA, D ADC, M A MOV, H INX, E DCR,
  ENDZ
  PSW POP, RET, ;NOTHREAD ASM

CODE %,MKPOS ( ASM LANG SUBROUTINE TO MAKE 32 BIT)
            ( VAL POSITIVE. ON ENTRY HL -> MSB. )
            ( ON EXIT CARRY COMPLEMENTED IF SIGN)
            ( WAS NEG., DE=??, ABCHL UNCHANGED.)
  B PUSH, B M MOV, B INR, B DCR, IFM
           H DCX, H DCX, H DCX, ( HL-> LSB)
    ' %,CHSGN CALL, H DCX, CMC,
  THEN
  B POP, RET, ;NOTHREAD ASM

CODE ,ABS
  H 3 LXI, di, SP DAD, ei, ' %,MKPOS CALL, ;

CODE ,-1*
  H 0 LXI, di, SP DAD, ei, ' %,CHSGN CALL, ;

CODE %,DIVU ( ASM LANG. 32 BIT DIVIDE SUBROUTINE)
           ( ENTRY: HL -> 64 BIT DIVEDEND, DE -> 32 BIT)
           ( DIVISOR. EXIT: DE,HL UNCHANGED. RESULT IS)
           ( AT HL, REMAINDER AT HL+4)
  C 32 MVI, ( INIT LOOP COUNT)
  BEGIN
    H PUSH, B 8 MVI, A ORA, ( SHIFT DIV/ANS LEFT)
    BEGIN
      A M MOV, RAL, M A MOV, H INX, B DCR,
    ENDZ
    ( NOW SUBTRACT DIVISOR FROM UPPER PART OF DIVEDEND)
    H DCX, H DCX, H DCX, H DCX, 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 ( IF RESULT WAS NEGATIVE)
      D PUSH, B 4 MVI, A ORA, XCHG, ( UNDO SUBTRACTION)
      BEGIN
        D LDAX, M ADC, D STAX, H INX, D INX, B DCR,
      ENDZ
      D POP, H POP, ( HL,DE READY FOR NEXT PASS)
    ELSE
      ( SET LSB OF RESULT) H POP, M INR,
      ( HL ,DE READY FOR NEXT LOOP)
    THEN
    C DCR, ( ANY MORE?)
  ENDZ
  RET, ;NOTHREAD ASM

CODE %,CDIV ( ASM LANG COMMON DIVIDE SUBROUTINE)
           ( ON ENTRY ,TOS = 32 BIT DIVISOR AND)
           ( ,NOS = DIVEDEND. ON EXIT, ,TOS = QUOTIENT)
           ( AND ,NOS = REMAINDER)
  ' PSHBC# CALL, ( SAVE 4TH PC)
  B POP, ' PSHBC# CALL, ( SAVE MAC LANG RETURN)
  H -4 LXI, di, SP DAD, SPHL, ei, XCHG, ( GET 4 BYTES ON STACK)
  H 4 LXI, D DAD, C 8 MVI, ( HL -> DIVISOR)
  BEGIN ( MOVE EVERYTHING DOWN TO SET UP FOR %,DIVU)
    A M MOV, D STAX, H INX, D INX, C DCR,
  ENDZ
  ( NOW CLEAR UPPER PART OF 64 BIT DIVEDEND)
  A XRA, H DCX, M A MOV, H DCX, M A MOV, H DCX, M A MOV,
  H DCX, M A MOV, H DCX, ( HL -> DIVEDEND BITS 24-31)
  A ORA, ' %,MKPOS CALL, ( FIX AND GET SIGN OF DIVEDEND)
  H DCX, H DCX, H DCX, H DCX,  ( HL -> DIVISOR MSB)
  ' %,MKPOS CALL, ( FIX & GET SIGN)
  PSW PUSH, ( CY=SIGN OF RESULT) H INX, ( HL->DIVEDEND LSB)
  XCHG, H -4 LXI, D DAD, ( HL-> DIVISOR LSB)
  XCHG, ' %,DIVU CALL, ( DO DIVIDE)
  PSW POP, di, SPHL, ei, 
           ifc ' %,CHSGN call, then ( CC,) ( FIX SIGN OF RESULT)
  H INX, H INX, H INX, H INX, 
           ifc ' %,CHSGN call, then ( CC,) ( SIGN OF REM)
  ' POPBC# CALL, B PUSH, ( RESTORE ASM LANG RET)
  ' POPBC# JMP, ;NOTHREAD ASM ( EXIT THRU POPBC#)

CODE ,/MOD ( DOUBLE PREC /MOD)
  ' %,CDIV CALL, ;

CODE ,/ ( DOUBLE PREC DIVIDE)
  ' %,CDIV CALL, ( KILL REMAINDER) D POP, H POP,
  PSW POP, di, XTHL, ei, D PUSH, ;

CODE %,MPYU ( DOUBLE PRECISION MULTIPLY ASM LANG SUBR)
           ( ENTRY: HL -> MULTIPLIER EXTENDED TO 64 BITS)
           ( DE -> MULTIPLICAND.  EXIT:  HL,DE NO CHANGE)
           ( ANSWER REPLACES MULTIPLICAND)
  C 32 MVI, ( DO 32 TIMES)
  BEGIN
    A M MOV, RAR, ( TEST LSB OF MULTIPLIER)
        H INX, H INX, H INX, H INX,  IFC ( IF LSB WAS ONE)
      D PUSH, B 4 MVI, A ORA, ( ADD MULTIPLICAND TO ANSWER)
      BEGIN
        D LDAX, M ADC, M A MOV, H INX, D INX, B DCR,
      ENDZ
      D POP,
    ELSE
      H INX, H INX, H INX, H INX,
    THEN
    ( NOW 64 BIT RGT SHIFT OF MULTIPLIER/ANSWER)
    B 8 MVI, A ORA,
    BEGIN
      H DCX, A M MOV, RAR, M A MOV, B DCR,
    ENDZ
    C DCR,
  ENDZ
  RET, ;NOTHREAD ASM

CODE %,MULUTIL ( ASM LANG SUB USED BY ,* AND ,*/)
  ' %,MKPOS CALL, H INX, H INX, H INX, H INX,
  ' %,MKPOS CALL, A 0 MVI, ( GET MULTPLICAND)
  ( IN REGS AND REPLACE WITH ZEROS SO THAT)
  ( MULTIPLIER IS 64 BITS) D M MOV, M A MOV,
  H DCX, E M MOV, M A MOV, H DCX, B M MOV, M A MOV,
  H DCX, C M MOV, M A MOV, H POP, ( GET RETURN)
  D PUSH, B PUSH, ( PUSH MULTIPLICAND)
  PSW PUSH, ( CY=SIGN OF RESULT) XCHG,
  H 2 LXI, di, SP DAD, ei, XCHG, ( DE-> MULTIPLICAND)
  PCHL, ( RET TO CALLER) ;NOTHREAD ASM

CODE %,MULEXIT ( COMMON EXIT FOR ,* AND ,*/)
  PSW POP, ( GET RESULT SIGN)
  di, SPHL, ei, ( DUMP EXCESS) ifc ' %,CHSGN call, then ( CC,) ( FIX SIGN)
  ( NOW CHANGE 64 BIT RESULT TO 32 BIT)
  H POP, D POP, B POP, B POP, D PUSH, H PUSH,
  ' POPBC# CALL, ;

CODE ,* ( DBL PREC MULTIPLY)
  ' PSHBC# CALL, ( SAVE 4TH PC)
  H 3 LXI, di, SP DAD, ei, ( HL -> MULTIPLIER MSB)
  A ORA, ( CY=0) ' %,MULUTIL CALL, ( COMMON SETUP)
  H 4 LXI, D DAD, ( HL-> MULTIPLIER)
  ' %,MPYU CALL,
  ' %,MULEXIT JMP, ;NOTHREAD ( GO FINISH UP)

CODE ,*/ ( DBL PREC */)
  ' PSHBC# CALL, H 3 LXI, di, SP DAD, ei, A ORA,
  ( FIX SIGN OF DIVISOR)
  ' %,MKPOS CALL, H INX, H INX, H INX, H INX,
  ' %,MULUTIL CALL,
  H 8 LXI, D DAD, ( HL -> ANS/MULTIPLIER)
  ' %,MPYU CALL,
  D INX, D INX, D INX, D INX, ( DE-> DIVISOR)
  ' %,DIVU CALL,
  ' %,MULEXIT JMP, ;NOTHREAD ( GO FINISH)