;
; FP and LONG functions for floating point and long packages
;
INCLUDE "bds.lib"
FUNCTION fp
CALL arghak
PUSH B ; save BC
LXI H,COMMON$EXIT
PUSH H ; save the common exit addr in the stack
LDA arg1 ;Get code ptr
RAL ;Multiply code by 2
MOV E,A
MVI D,0 ;Move result to DE
LXI H,JMPTAB ;Get JMPTAB addr
DAD D ;Add offset to it
XCHG ;Store result in DE
LDAX D
MOV L,A
INX D
LDAX D
MOV H,A ;Move table addr to HL
PCHL ;Jump to selected routine
JMPTAB:
DW XNORM
DW XADD
DW XSUB
DW XMULT
DW XDIV
DW XFTOA
COMMON$EXIT:
POP B ; restore BC
RET ; return to BDS C
XNORM:
CALL LD$OP1
CALL FPNORM
EXIT0:
CALL ST$ACC
RET
LD$OP1:
LHLD arg3
XCHG
LXI H,FPACC-1
MVI M,0
INX H
MVI C,5
CALL MOVE
RET
LD$OP2:
CALL LD$OP1
LHLD arg4
XCHG
LXI H,FPOP-1
MVI M,0
INX H
MVI C,5
CALL MOVE
RET
ST$ACC:
LHLD arg2
LXI D,FPACC
MVI C,5
CALL MOVE
RET
FPNORM:
LDA FPACC+3 ;Get MS byte of FPACC
STA SIGN ;Save SIGN byte of FPACC
ANA A ;If number is positive
JP NZERO$TEST ;.. go test for zero
LXI H,FPACC-1 ;Load addr of FPACC (+ xtra byte)
MVI C,5 ;Load precision register
CALL NEGATE ;Negate FPACC
NZERO$TEST:
LXI H,FPACC-1
MVI C,5
CALL ZERO$TEST ;If FPACC not zero
JNZ NOTZERO ;.. go normalize
STA FPACCX ;make sure exponent is zero
RET
NOTZERO:
LXI H,FPACC-1
MVI C,5
CALL SHIFTL ;shift FPACC left
LXI H,FPACCX
DCR M ;subtract 1 from FPACC exponent
LDA FPACC+3 ;get MS byte of FPACC
ANA A ;if high order bit not no
JP NOTZERO ;.. go do again
;compensate for last shift
LXI H,FPACCX
INR M
DCX H
MVI C,5
CALL SHIFTR
LDA SIGN ;fetch original sign
RAL ;shift sign bit into carry
RNC ;exit if orig # was positive
LXI H,FPACC-1
MVI C,5
CALL NEGATE ;2's complement FPACC
RET ;Exit FPNORM
FPADD:
LXI H,FPACC
MVI C,4
CALL ZERO$TEST ;if FPACC not = zero
JNZ TEST$FPOP ;.. go test FPOP for zero
LXI H,FPACC
LXI D,FPOP
MVI C,5
CALL MOVE ;Move FPOP to FPACC
RET ;Exit FPADD
TEST$FPOP:
LXI H,FPOP
MVI C,4
CALL ZERO$TEST ;if FPOP = 0
RZ ;.. exit FPADD
LDA FPACCX
LXI H,FPOPX
SUB M ;if exponents are equal
JZ ADD$SETUP ;.. go to add setup
JP RANGE$TEST ;if diff of exp >=0,goto range test
CMA
INR A ;ABS of difference
RANGE$TEST:
CPI 32 ;if diff < 32
JM ALGN$OPRNDS ;.. we can go align the operands
LXI H,FPACCX
LDA FPOPX
SUB M ;if exp of FPACC > exp of FPOP
RM ;.. exit FPADD
LXI D,FPOP
LXI H,FPACC
MVI C,5
CALL MOVE ;move FPOP to FPACC
RET ;Exit FPADD
ALGN$OPRNDS:
LDA FPACCX
LXI H,FPOPX
SUB M ;subt exponents
MOV B,A ;save difference of exponents
JM SHFT$FPACC ;if diff neg, go shift FPACC
ALGN$FPOP:
LXI H,FPOPX
CALL SHFT$LOOP ;shift FPOP & increment exponent
DCR B ;Decrement diff register
JNZ ALGN$FPOP ;loop until exponents are equal
JMP ADD$SETUP ;go to add setup
SHFT$FPACC:
LXI H,FPACCX
CALL SHFT$LOOP ;shift FPACC & increment exponent
INR B ;increment difference register
JNZ SHFT$FPACC ;loop until exponents are equal
ADD$SETUP:
XRA A
STA FPACC-1
STA FPOP-1
LXI H,FPACCX
CALL SHFT$LOOP ;shift FPACC right
LXI H,FPOPX
CALL SHFT$LOOP ;shift FPOP right
LXI H,FPACC-1
LXI D,FPOP-1
MVI C,5
CALL ADDER ;add FPOP to FPACC
CALL FPNORM ;normalize result
RET ;exit FPADD
SHFT$LOOP:
INR M ;increment exponent
DCX H ;decrement ptr
MVI C,4
MOV A,M ;get MS byte
ANA A ;if negative number
JM SHFT$MINUS ;.. goto negative shift
CALL SHIFTR ;shift mantissa
RET
FPMULT:
CALL SIGNJOB ;process the signs
LXI H,WORK
MVI C,8
CALL ZERO$MEMORY ;WORK := 0 (partial product)
LXI H,FPACCX
LDA FPOPX
ADD M
INR A ;compensate for algolrithm
MOV M,A ;add FPOP exp to FPACC exponent
LXI H,FPACC-4
MVI C,4
CALL ZERO$MEMORY ;clear multiplicand extra bytes
LXI H,BITS
MVI M,31
MULT$LOOP:
LXI H,FPOP+3
MVI C,4
CALL SHIFTR ;shift multiplier right
CC ADD$MULTIPLICAND ;add multiplicand if carry
LXI H,WORK+7
MVI C,8
CALL SHIFTR ;shift partial product right
LXI H,BITS
DCR M ;decrement BITS counter
JNZ MULT$LOOP ;if not zero, do again
LXI H,WORK+7
MVI C,8
CALL SHIFTR ;shift once more for rounding
LXI H,WORK+3
MOV A,M
RAL ;fetch 32th bit
ANA A ;if it is a 1
CM ROUND$IT ;.. round the result
LXI D,WORK+3
LXI H,FPACC-1
MVI C,5
EXMLDV:
CALL MOVE
LDA SIGN ;fetch SIGN and save it on the stack
PUSH PSW
CALL FPNORM
POP PSW
ANA A
RP
LXI H,FPACC
MVI C,4
CALL NEGATE
RET
ADD$MULTIPLICAND:
LXI H,WORK
LXI D,FPACC-4
MVI C,8
CALL ADDER
RET
ROUND$IT:
MVI A,40H
ADD M
MVI C,4
RND$LOOP:
MOV M,A
INX H
MVI A,0
ADC M
DCR C
JNZ RND$LOOP
MOV M,A
RET
FPDIV:
LXI H,FPOP
MVI C,4
CALL ZERO$TEST
JNZ DIV$SIGN
LXI H,FPACC
MVI C,5
CALL ZERO$MEMORY
RET
DIV$SIGN:
CALL SIGNJOB
LXI H,WORK
MVI C,12
CALL ZERO$MEMORY
MVI A,31
STA BITS
LXI H,FPACCX
LDA FPOPX
MOV B,A
MOV A,M
SUB B
INR A
MOV M,A
DIVIDE:
CALL SETSUB ;WORK2 := dividend - divisor
JM NOGO ;if minus, go put 0 in quotient
LXI H,FPACC
LXI D,WORK2
MVI C,4
CALL MOVE ;move subt results to dividend
STC
JMP QUOROT
NOGO:
ANA A
QUOROT:
LXI H,WORK+4
MVI C,4
CALL SHFTL ;Insert carry flag into quotient
LXI H,FPACC
MVI C,4
CALL SHFTL ;shift dividend left
LXI H,BITS
DCR M ;decrement BITS counter
JNZ DIVIDE ;loop until BITS = zero
CALL SETSUB ;1 more time for rounding
JM DVEXIT ;if 24th bit = 0, goto exit
LXI H,WORK+4
LXI D,ONE
MVI C,4
CALL ADDER
LXI H,WORK+7
MOV A,M
ANA A
JP DVEXIT
MVI C,4
CALL SHIFTR
LXI H,FPACCX
INR M
DVEXIT:
LXI H,FPACC
LXI D,WORK+4
MVI C,4
JMP EXMLDV
SETSUB:
LXI D,FPACC
LXI H,WORK2
MVI C,4
CALL MOVE ;move dividend to work2
LXI H,WORK2
LXI D,FPOP
MVI C,4
CALL SUBBER ;subtract divisor from work2
LDA WORK2+3
ANA A
RET
FTOA:
LHLD arg2
SHLD ASCII$PTR
MVI M,' '
LDA FPACC+3
ANA A
JP BYSIGN
MVI M,'-'
LXI H,FPACC
MVI C,4
CALL NEGATE
BYSIGN:
LHLD ASCII$PTR
INX H
MVI M,'0'
INX H
MVI M,'.'
INX H
SHLD ASCII$PTR
XRA A
STA EXP
LXI H,FPACC
MVI C,4
CALL ZERO$TEST
JNZ SU$FTOA
MVI C,7
LHLD ASCII$PTR
ZERO$LOOP:
MVI M,'0'
INX H
DCR C
JNZ ZERO$LOOP
SHLD ASCII$PTR
JMP EXPOUT
SU$FTOA:
LXI H,FPACCX
DCR M
DECEXT:
JP DECEXD
MVI A,4
ADD M
JP DECOUT
CALL FPX10
DECREP:
LXI H,FPACCX
MOV A,M
ANA A
JMP DECEXT
ZERODG:
LXI H,EXP
DCR M
LXI H,OUTAREA
MVI C,5
CALL ZERO$TEST
JNZ DECRDG
XRA A
STA DIGCNT
JMP DECRDG
OUTX10:
XRA A
STA OUTAREA+4
LXI H,WORK
LXI D,OUTAREA
MVI C,5
CALL MOVE
LXI H,OUTAREA
MVI C,5
CALL SHIFTL
LXI H,OUTAREA
MVI C,5
CALL SHIFTL
LXI D,WORK
LXI H,OUTAREA
MVI C,5
CALL ADDER
LXI H,OUTAREA
MVI C,5
CALL SHIFTL
RET
EXPOUT:
LHLD ASCII$PTR
MVI M,'E'
INX H
LDA EXP
ANA A
JP EXPOT
CMA
INR A
STA EXP
MVI M,'-'
INX H
LDA EXP
EXPOT:
MVI C,0
EXPLOOP:
SUI 10
JM TOMUCH
STA EXP
INR C
JMP EXPLOOP
TOMUCH:
MVI A,'0'
ADD C
MOV M,A
INX H
LDA EXP
ADI '0'
MOV M,A
INX H
MVI M,0
RET
FPX10:
LXI H,FPOP
LXI D,TEN
MVI C,5
CALL MOVE
CALL FPMULT
LXI H,EXP
DCR M
RET
FPD10:
LXI H,FPOP
LXI D,ONE$TENTH
MVI C,5
CALL MOVE
CALL FPMULT
LXI H,EXP
INR M
RET
NEGATE:
STC ;CARRY forces an add of 1
NEGAT$LOOP:
MOV A,M ;fetch byte
CMA ;complement it
ACI 0 ;make it two's complement
MOV M,A ;store the result
INX H ;bump ptr
DCR C ;decrement precision register
JNZ NEGAT$LOOP ;if not done, go do it again
RET ;Return to caller
ZERO$TEST:
XRA A ;clear A
ORA M ;'OR' A with next byte
INX H ;bump ptr
DCR C ;decrement precision register
JNZ ZERO$TEST+1 ;loop until done
ANA A ;set flags
RET
SHIFTL:
ANA A ;clear CARRY
SHFTL:
MOV A,M ;get next byte
RAL ;shift it left
MOV M,A ;store result
INX H ;bump ptr
DCR C ;decrement precision register
JNZ SHFTL ;loop until done
RET
SHIFTR:
ANA A
SHFTR:
MOV A,M
RAR
MOV M,A
DCX H
DCR C
JNZ SHFTR
RET
ADDER:
ANA A
ADD$LOOP:
LDAX D
ADC M
MOV M,A
INX D
INX H
DCR C
JNZ ADD$LOOP
RET
SUBBER:
ANA A
XCHG
SUB$LOOP:
LDAX D
SBB M
STAX D
INX D
INX H
DCR C
JNZ SUB$LOOP
XCHG
RET
ZERO$MEMORY:
MVI M,0
INX H
DCR C
JNZ ZERO$MEMORY
RET
MOVE:
LDAX D
MOV M,A
INX D
INX H
DCR C
JNZ MOVE
RET
SIGNJOB:
LDA FPACC+3
STA SIGN
ANA A
JP CKFPOP
LXI H,FPACC
MVI C,4
CALL NEGATE
CKFPOP:
LXI H,SIGN
LDA FPOP+3
XRA M
MOV M,A
LDA FPOP+3
ANA A
RP
LXI H,FPOP
MVI C,4
CALL NEGATE
RET
