;
; 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

XADD:
	CALL	LD$OP2
	CALL	FPADD
	JMP	EXIT0
XSUB:
	CALL	LD$OP2
	CALL	FPSUB
	JMP	EXIT0
XMULT:
	CALL	LD$OP2
	CALL	FPMULT
	JMP	EXIT0

XDIV:
	CALL	LD$OP2
	CALL	FPDIV
	JMP	EXIT0

XFTOA:
	CALL	LD$OP1
	CALL	FTOA
	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

SHFT$MINUS:
	STC			;set carry
	CALL	SHFTR		;shift mantissa progatating sign
	RET			;exit

FPSUB:
	LXI	H,FPACC
	MVI	C,4
	CALL	NEGATE
	JMP	FPADD

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

DECEXD:
	CALL	FPD10
	JMP	DECREP	

DECOUT:
	LXI	H,FPACC
	LXI	D,ADJ
	MVI	C,4
	CALL	ADDER
	LXI	H,OUTAREA
	LXI	D,FPACC
	MVI	C,4
	CALL	MOVE
	LXI	H,OUTAREA+4
	MVI	M,0
	LXI	H,OUTAREA
	MVI	C,4
	CALL	SHIFTL
	CALL	OUTX10
COMPEN:
	LXI	H,FPACCX
	INR	M
	JZ	OUTDIG
	LXI	H,OUTAREA+4
	MVI	C,5
	CALL	SHIFTR
	JMP	COMPEN
OUTDIG:
	MVI	A,7
	STA	DIGCNT
	LXI	H,OUTAREA+4
	MOV	A,M
	ANA	A
	JZ	ZERODG
OUTDGS:
	LXI	H,OUTAREA+4
	MVI	A,'0'
	ADD	M
	LHLD	ASCII$PTR
	MOV	M,A
	INX	H
	SHLD	ASCII$PTR
DECRDG:
	LXI	H,DIGCNT
	DCR	M
	JZ	EXPOUT
	CALL	OUTX10
	JMP	OUTDGS

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

	DS	4
FPACC:	DS	4
FPACCX:	DS	1
	DS	4
FPOP:	DS	4
FPOPX:	DS	1
SIGN:	DS	1
WORK:	DS	8
WORK2:	DS	4
BITS:	DS	1
ASCII$PTR:	DS	2
EXP:	DS	1
OUTAREA:	DS	5
DIGCNT:	DS	1
ONE$TENTH:	DB	66H,66H,66H,66H,0FDH
TEN:	DB	0,0,0,50H,4
ADJ:	DB	5,0,0,0
ONE:	DB	80H,0,0,0

	ENDFUNC


.