; INTARITH.ASM
; ------------
;
; See FALCONER.WS4 for doc.
;
; (Retyped by Emmanuel ROCHE.)
;
;--------------------------------
; Allowable entry points
;
	entry	imul,idiv,mul.div
;
;--------------------------------
; Entry points for utility routines
;
	entry	stadr.ldes,lbcs.las	; Stack addressing
	entry	bclz,bclc,bcra,bcrc	; Shifts and complements
	entry	dhlz,dera,derc		; 
	entry	c2bc.c1bc,c2de,c1de,c2dhl
	entry	mul10,dten,dquik	; Fast arithmetic
;
;--------------------------------
; Macro definition
;
; "Return" and check stack level zero
;
rtn	macro
	if	.lvl
	error	"0"+.lvl
.lvl	set	0
	endif
	ret
	endm
;
;--------------------------------
; Utility routines
;--------------------------------
;
; Stack addressing routines operate on an input stack level,
; supplied via the A-register. This specifies the stack level
; with respect to the calling routine, derived by counting
; "pushes" since the item was pushed. If the item was stored
; by the last "push", its address is zero. The address may
; not exceed 252.
;
; Generate stack absolute address for stack addressing routines
; A,F,H,L
;
stadr:	lxi	h,3		; Allow for push H and 2 RETs
	add	l		; Max stack level is 252
	mov	l,a		; 
	dad	h		; Convert to byte address
	dad	sp		; Memory address formed
	rtn			; 
;
; Load (DE) from stack level (A)
; A,F,D,E
;
ldes:	push	h		; 
	call	stadr		; Get absolute address
	mov	e,m		; 
	inx	h		; 
	mov	d,m		; 
	pop	h		; 
	rtn			; 
;
; Load (BC) from stack level (A)
; (A) is stack level W.R.T. calling routine
; A,F,B,C
;
lbcs:	push	h		; 
	call	stadr		; Form absolute address
	mov	c,m		; 
	inx	h		; 
	mov	b,m		; 
	pop	h		; 
	rtn			; 
;
; Load (A) from stack level (A)
; Value was stored by push psw
; A,F
;
las:	push	h		; 
	call	stadr		; Form absolut address
	inx	h		; 
	mov	a,m		; 
	pop	h		; 
	rtn			; 
;
; Shift (DEHL) register left, insert 0
; Original high order bit to Carry
; A,F,D,E,H,L  (A=D on exit)
;
dhlz:	dad	h		; 
	mov	a,e		; 
	ral			; 
	mov	e,a		; 
	mov	a,d		; 
	ral			; 
	mov	d,a		; 
	rtn			; 
;
; (BC) left shift, zero insert, leave (B) in (A)
; A,F,B,C
;
bclz:	ora	a		; Clear Carry
;
; (BC) left shift, Carry insert, leave (B) in (A)
; A,F,B,C
;
bclc:	mov	a,c		; 
	ral			; 
	mov	c,a		; 
	mov	a,b		; 
	ral			; 
	mov	b,a		; 
	rtn			; 
;
; Arith shift right (BC), leave (C) in (A)
; A,F,B,C
;
bcra:	mov	a,b		; 
	ral			; 
;
; (BC) right shift, Carry in, leave (C) in (A)
; A,F,B,C
;
bcrc:	mov	a,b		; 
	rar			; 
	mov	b,a		; 
	mov	a,c		; 
	rar			; 
	mov	c,a		; 
	rtn			; 
;
; Arithmetic right shift (DE), leave (E) in (A)
; A,F,D,E
;
dera:	mov	a,d		; 
	ral			; 
;
; (DE) right shift, Carry insert, leave (E) in (A)
; A,F,D,E
;
derc:	mov	a,d		; 
	rar			; 
	mov	d,a		; 
	mov	a,e		; 
	rar			; 
	mov	e,a		; 
	rtn			; 
;
; 2's complement (BC), leave (B) in (A)
; A,B,C
;
c2bc:	dcx	b		; 
;
; 1's complement (DE), leave (B) in (A)
; A,D,E
;
c1bc:	mov	a,c		; 
	cma			; 
	mov	c,a		; 
	mov	a,b		; 
	cma			; 
	mov	b,a		; 
	rtn			; 
;
; 2's complement (DE), leave (D) in (A)
; A,D,E
;
c2de:	dcx	d		; 
;
; 1's complement (DE), leave (D) in (A)
; A,D,E
;
c1de:	mov	a,e		; 
	cma			; 
	mov	e,a		; 
	mov	a,d		; 
	cma			; 
	mov	d,a		; 
	rtn			; 
;
; 2's complement (DEHL)
; A,F,D,E,H,L
;
c2dhl:	xchg			; 
	call	c2de		; 
	xchg			; 
	call	c1de		; 
	mov	a,h		; 
	ora	l		; 
	rnz			; 
	inx	d		; Propagate Carry
	rtn			; 
;
; Multiply (HL) by 10 (modulo 65536)
; No overflow signal
; F,H,L
;
mul10:	push	d		; 
	mov	d,h		; 
	mov	e,l		; Copy HL to DE
	dad	d		; 2*
	dad	h		; 4*
	dad	d		; 5*
	dad	h		; 10*
	pop	d		; Restore DE
	rtn			; 
;
; Divide integer (HL) by 10
; Remainder appears in (A) with flags set
; A,F,H,L
;
dten:	push	b		; Save BC
	mvi	c,10		; Divisor
dten1:	xra	a		; Clear
	mvi	b,-16		; Iteration count
dten2:	dad	h		; 
	ral			; Shift off into (A)
	jc	dten3		; Allow for DQUIK
	cmp	c		; Test
	jc	dten4		; No bit
dten3:	sub	c		; Bit = 1
	inx	h		; 
dten4:	inr	b		; Done?
	jm	dten2		; No
	ora	a		; Set flags for RDR., clear Carry
	pop	b		; Restore
	rtn			; 
;
; *** This routine is not used in the FLTARITH system ***
; Integer divide 16 by 0 bit quantities
; (HL)/(A) => (HL); remainder => (A)
; Set Carry for division by zero. Preserve HL
; A,F,H,L
;
dquik:	ora	a		; 
	stc			; 
	rz			; Division by zero
	push	b		; 
.lvl	set	.lvl-1		; 
	mov	c,a		; 
	jmp	dten1		; 
;
; *** End utility routines ***
; ----------------------------
;
; Integer (pos.) multiply DE*BC -> DEHL
; Operand range 0 to 65535
; D,E,H,L
;
imul:	push	psw		; 
	lxi	h,0		; Clear Accumulator
	mvi	a,-16		; Iteration count
imul1:	push	psw		; Save iteration count
	dad	h		; Left shift, Carry out
	mov	a,e		; Left sh m'plier, insert o'flow
	ral			; 
	mov	e,a		; 
	mov	a,d		; 
	ral			; 
	mov	d,a		; 
	jnc	imul2		; No bit
	dad	b		; Add in multiplicand
	jnc	imul2		; No overflow
imul2:	pop	psw		; Iteration count
	inr	a		; 
	jm	imul1		; Do again
	pop	psw		; Restore
	rtn			; 
;
; Integer (pos.) divide (DEHL)/(BC)=>(DE)
; Remainder appears in (HL)
; Carry for overflow, when registers unchanged
; Divisor, remainder and quotient range 0 to 65535
; Dividend range 0 to 4295*10^6 (approx.)
; F,D,E,H,L
;
idiv:	push	psw		; 
	mov	a,e		; Check for overflow
	sub	c		; 
	mov	a,d		; 
	sbb	b		; 
	jc	idiv1		; No overflow
	pop	psw		; Restore (A)
	stc			; Mark overflow
	rtn			; 
.lvl	set	.lvl+1		; 
idiv1:	push	b		; 
	call	c2bc		; Change (BC) sign
	xchg			; Do arithmetic in (HL)
	mvi	a,-16		; Iteration count
idiv2:	push	psw		; Save iteration count
	dad	h		; Left shift (HLDE)
	rar			; Save Carry out
	xchg			; 
	dad	h		; 
	xchg			; 
	jnc	idiv3		; No Carry into L
	inx	h		; 
idiv3:	ral			; Regain Carry from H
	jc	idiv4		; Yes, generate quotient bit
	mov	a,l		; 
	add	c		; Test for quotient bit
	mov	a,h		; 
	adc	b		; 
	jnc	idiv5		; No bit
idiv4:	dad	b		; Subtract
	inx	d		; Insert quotient bit
idiv5:	pop	psw		; Get iteration count
	inr	a		; 
	jm	idiv2		; Not done
	pop	b		; Restore BC
	pop	psw		; Restore A
	ora	a		; Clear any Carry, no overflow
	rtn			; 
;
; *** This routine is not used in the FLTARITH system ***
; Signed multiply (DE)*(BC)->(DEHL)
; F,D,E,H,L
;
mul:	push	psw		; 
	push	b		; 
	mov	a,d		; 
	ora	a		; 
	jm	mul3		; (DE) -ve (negative)
	mov	a,b		; 
	ora	a		; 
	jp	mul4		; Both +ve (positive)
mul1:	call	c2bc		; 2's complement BC
mul2:	call	imul		; Result -ve
	call	c2dhl		; 2's complement DEHL
	jmp	mul5		; 
mul3:	call	c2de		; (DE) -ve
	mov	a,e		; 
	ora	a		; 
	jp	mul2		; (DE) -ve, (BC) +ve
	call	c2bc		; (DE) -ve, (BC) -ve
mul4:	call	imul		; Result +ve
mul5:	pop	b		; 
	pop	psw		; 
	ora	a		; Reset Carry, no overflow
	rtn			; 
;
; *** This routine is not used in the FLTARITH system ***
; Do IDIV on signed + ho's & check overflow
; Expecting +ve result
; A,F,D,E,H,L
;
idivq:	call	idiv		; 
	rc			; 
	mov	a,d		; 
	ral			; 
	rtn			; Result should be +ve
;
; *** This routine is not used in the FLTARITH system ***
; Do IDIV on signed + ho's & check overflow
; Inputs may include 8000H
; Expecting -ve result, allow 8000H
; A,F,D,E,H,L
;
idivn:	call	idiv		; 
	rc			; Overflow
	call	c2de		; Complement quotient
	ral			; Result should be -ve
	cmc			; 
	rtn			; 
;
; *** This routine is not used in the FLTARITH system ***
; Signed divide (DEHL)/(BC)->(DE)
; Remainder appears in (HL)
; Carry indicates overflow when
; inputs are preserved, except flags
; F,D,E,H,L  (9)
;
div:	push	psw		; 
	push	b		; 
	push	d		; 
	push	h		; Save in case of overflow
	mov	a,d		; 
	ora	d		; 
	jm	div4		; Dividend negative
	ora	b		; 
@01	set	.lvl		;
	jm	div2		; +/-
	call	idivq		; +/+
	jc	div3		; Overflow
div1:	pop	b		; Purge stack, no overflow
	pop	b		; 
	pop	b		; 
	pop	psw		; 
	ora	a		; Reset Carry, no overflow
	rtn			; 
.lvl	set	@01		; 
div2:	call	c2bc		; +/-, complement BC
	call	idivn		; 
	jnc	div1		; No overflow
div3:	pop	h		; Restore entry, overflow
	pop	d		; 
	pop	b		; 
	pop	psw		; 
	stc			; Mark overflow wit Carry
	rtn			; 
div4:	call	c2dhl		; -/?, complement DEHL
	mov	a,b		; 
	ora	a		; 
	jm	div7		; -/-
	call	idivn		; 
div5:	jc	div3		; Overflow
div6:	xchg			; 
	call	c2de		; 
	xchg			; Complement remainder
	jmp	div1		; 
div7:	call	c2bc		; -/-, complement BC
	call	idivq		; 
	jmp	div5		;
;
;--------------------------------
;
	END			; of INTARITH.ASM