;
;		ARITH.MAC - Arithmetic and Logical Functions
;
; 97/12/28
;
; AND  OR  XOR  NOT  S>D  NEGATE  ABS  DNEGATE  DABS  +  -  D+  D-  M+
; 1+  2+  1-  2-  UM*  M*  UM/MOD  FM/MOD  /MOD  /  MOD  */MOD  */  M*/
; 2*  2/  D2*  D2/  LSHIFT  RSHIFT
;

;	AND  ( x1 x2 -- x3 )

	hdr	3,'AND'
andd:	pop	de
	pop	hl
	ld	a,e
	and	l
	ld	l,a
	ld	a,d
	and	h
	ld	h,a
	jp	hpush

;	OR  ( x1 x2 -- x3 )

	hdr	2,'OR'
orr:	pop	de
	pop	hl
	ld	a,e
	or	l
	ld	l,a
	ld	a,d
	or	h
	ld	h,a
	jp	hpush

;	XOR  ( x1 x2 -- x3 )

	hdr	3,'XOR'
xorr:	pop	de
	pop	hl
	ld	a,e
	xor	l
	ld	l,a
	ld	a,d
	xor	h
	ld	h,a
	jp	hpush

	cseg

abss:	ld	a,h
	or	a
	ret	p

negg:	dec	hl		; two's complement
negg1:	ld	a,l
	cpl
	ld	l,a
	ld	a,h
	cpl
	ld	h,a
	ret

dabss:	ld	a,h
	or	a
	ret	p

dnegg:	sub	a		; 16 bit two's complement
	sub	e
	ld	e,a
	ld	a,0
	sbc	a,d
	ld	d,a
	ld	a,0
	sbc	a,l
	ld	l,a
	ld	a,0
	sbc	a,h
	ld	h,a
	ret

;	NOT  ( x1 -- x2 )	one's complement

	hdr	3,'NOT'
nott:	pop	hl
	call	negg1
	jp	hpush

;	S>D  ( n -- d )

	hdr	3,'S>D'
stod:	ld	hl,0
	pop	de
	ld	a,d
	or	a
	jp	p,dpush
	dec	hl
	jp	dpush

;	NEGATE  ( n1 -- n2 )

	hdr	6,'NEGATE'
negat:	pop	hl
	call	negg
	jp	hpush

;	ABS  ( n -- +n )

	hdr	3,'ABS'
abs:	pop	hl
	call	abss
	jp	hpush

;	DNEGATE  ( d1 -- d2 )

	hdr	7,'DNEGATE'
dnegat:	pop	hl
	pop	de
	call	dnegg
	jp	dpush

;	DABS  ( d -- +d )

	hdr	4,'DABS'
dabs:	pop	hl
	pop	de
	call	dabss
	jp	dpush

;	+  ( x1 x2 -- x3 )

	hdr	1,'+'
plus:	pop	de
	pop	hl
	add	hl,de
	jp	hpush

;	-  ( x1 x2 -- x3 )

	hdr	1,'-'
subb:	pop	de
	pop	hl
	call	ssub
	jp	hpush

;	D+  ( xd1 xd2 -- xd3 )

	hdr	2,'D+'
dplus:	ld	hl,6
	add	hl,sp
	ld	e,(hl)
	ld	(hl),c
	inc	hl
	ld	d,(hl)
	ld	(hl),b
	pop	bc
	pop	hl
	add	hl,de
	ex	de,hl
	pop	hl
	ld	a,l
	adc	a,c
	ld	l,a
	ld	a,h
	adc	a,b
	ld	h,a
	pop	bc
	jp	dpush

;	D-  ( xd1 xd2 -- xd3 )	dnegate d+

	hdr	2,'D-'
dsub:	call	docol
	dw	dnegat,dplus
	dw	exit

;	M+  ( xd1 n -- xd2 )	s>d d+

	hdr	2,'M+'		; ANS
mplus:	call	docol
	dw	stod,dplus
	dw	exit

;	1+  ( x1 -- x2 )

	hdr	2,'1+'
onep:	pop	hl
	inc	hl
	jp	hpush

;	2+  ( x1 -- x2 )

	hdr	2,'2+'
twop:	pop	hl
	inc	hl
	inc	hl
	jp	hpush

;	1-  ( x1 -- x2 )

	hdr	2,'1-'
onem:	pop	hl
	dec	hl
	jp	hpush

;	2-  ( x1 -- x2 )

	hdr	2,'2-'
twom:	pop	hl
	dec	hl
	dec	hl
	jp	hpush

;	multiplication primitives

	cseg

;	AHL <- A * DE

mpyx:	ld	hl,0
	ld	c,8
mpyx1:	add	hl,hl
	rla
	jp	nc,mpyx2
	add	hl,de
	adc	a,0
mpyx2:	dec	c
	jp	nz,mpyx1
	ret

;	Unsigned 16*16 multiply, 32 bit result

;	HLDE <- HL * DE

umstrr:	push	bc		; save IP
	ld	b,h
	ld	a,l
	call	mpyx
	push	hl
	ld	h,a
	ld	a,b
	ld	b,h
	call	mpyx
	pop	de
	ld	c,d
	add	hl,bc
	adc	a,0
	ld	d,l
	ld	l,h
	ld	h,a
	pop	bc		; restore IP
	ret

;	Signed 16*16 multiply, 32 bit result

;	HLDE <- HL * DE

mstarr:	ld	a,d
	xor	h
	rla
	push	af
	call	abss
	ex	de,hl
	call	abss
	call	umstrr
	pop	af
	ret	nc
	jp	dnegg

;	UM*  ( u1 u2 -- ud )

	hdr	3,'UM*'
umstr:	pop	de
	pop	hl
	call	umstrr
	jp	dpush

;	M*  ( n1 n2 -- d )	2dup xor >r abs swap abs um* r> ?dnegate

	hdr	2,'M*'		; ANS
mstar:	pop	de
	pop	hl
	call	mstarr
	jp	dpush

;	*  ( x1 x2 -- x3 )	um* drop

	hdr	1,'*'
star:	pop	de
	pop	hl
	call	umstrr		; faster than M*
	ex	de,hl
	jp	hpush

;	division primitives

	cseg

usl:	add	hl,hl
	rla
	ld	e,a
	ld	a,h
	jp	c,usl1
	sub	c
	ld	h,a
	ld	a,e
	sbc	a,b
	jp	nc,usl2
	ld	a,h
	add	a,c
	ld	h,a
	ld	a,e
	dec	d
	jp	nz,usl
	ret

usl1:	sub	c
	ld	h,a
	ld	a,e
	sbc	a,b
usl2:	inc	l
	dec	d
	jp	nz,usl
	ret

;	Unsigned 32/16 divide
;
;	entry	HLDE = dividend, BC = divisor
;	exit	HL = quotient, DE = remainder

umslmm:	ld	a,l		; if overflow
	sub	c
	ld	a,h
	sbc	a,b
	jp	c,umsl1
	ld	hl,-1		; set rem & quot to max
	ld	de,-1
	ret

umsl1:	ld	a,h
	ld	h,l
	ld	l,d
	ld	d,8		; loop counter
	push	de
	call	usl
	pop	de
	push	hl
	ld	l,e
	call	usl
	ld	d,a
	ld	e,h
	ld	a,l
	pop	hl
	ld	h,l
	ld	l,a
	ret

;	Signed 32/16 divide - floored
;
;	entry	HLDE = dividend, BC = divisor
;	exit	HL = quotient, DE = remainder

fmsmm:	ld	a,b		; sign of result
	xor	h
	push	af
	push	bc
	push	hl
	ld	l,c
	ld	h,b
	call	abss
	ld	c,l
	ld	b,h
	pop	hl
	call	dabss
	call	umslmm
	pop	bc		; apply divisor sign to rem
	ld	a,b
	or	a
	ex	de,hl
	call	m,negg
	ex	de,hl
	pop	af		; done if quotient positive
	or	a
	ret	p
	call	negg
	ld	a,d		; done if rem zero
	or	e
	ret	z
	dec	hl		; floor
	push	hl
	ld	l,c
	ld	h,b
	call	ssub
	ex	de,hl
	pop	hl
	ret

;	UM/MOD  ( ud u1 -- u2 u3 )

	hdr	6,'UM/MOD'
umslm:	ld	l,c
	ld	h,b
	pop	bc
	pop	de
	ex	(sp),hl
	ex	de,hl
	call	umslmm
	pop	bc
	jp	dpush

;	FM/MOD  ( d n1 -- n2 n3 )

	hdr	6,'FM/MOD'	; ANS
fmsmd:	ld	l,c
	ld	h,b
	pop	bc
	pop	de
	ex	(sp),hl
	ex	de,hl
fmsmd1:	call	fmsmm
	pop	bc
	jp	dpush

;	/MOD  ( n1 n2 -- n3 n4 )	>r s>d r> fm/mod

	hdr	4,'/MOD'
slmod:	pop	hl
	pop	de
	push	bc
	ld	c,l
	ld	b,h
	ld	hl,0		; s>d
	ld	a,d
	or	a
	jp	p,fmsmd1
	dec	hl
	jp	fmsmd1

;	/  ( n1 n2 -- n3 )		/mod swap drop

	hdr	1,'/'
slash:	call	docol
	dw	slmod,swap,drop
	dw	exit

;	MOD  ( n1 n2 -- n3 )		/mod drop

	hdr	3,'MOD'
modd:	call	docol
	dw	slmod,drop
	dw	exit

;	*/MOD  ( n1 n2 n3 -- n4 n5 )	>r m* r> fm/mod

	hdr	5,'*/MOD'
ssmod:	ld	l,c
	ld	h,b
	pop	bc
	pop	de
	ex	(sp),hl
	call	mstarr
	jp	fmsmd1

;	*/  ( n1 n2 n3 -- n4 )		*/mod swap drop

	hdr	2,'*/'
ssla:	call	docol
	dw	ssmod,swap,drop
	dw	exit

;	M*/  ( d1 n1 +n2 -- d2 )	abs >r 2dup xor swap abs >r rot rot
;					dabs swap r@ um* rot r> um* rot 0 d+
;					r@ um/mod rot rot r> um/mod swap drop
;					swap rot 0< if dnegate then

	hdr	3,'M*/'		; ANS
mssl:	call	docol
	dw	abs,tor
	dw	tdup,xorr
	dw	swap,abs,tor
	dw	rot,rot,dabs
	dw	swap,rat,umstr
	dw	rot,fromr,umstr
	dw	rot,zero,dplus
	dw	rat,umslm
	dw	rot,rot,fromr
	dw	umslm,swap,drop
	dw	swap
	dw	rot,zless
	dw	zbran,mssl1
	dw	dnegat
mssl1:	dw	exit

;	2*  ( x1 -- x2 )

	hdr	2,'2*'		; ANS
tstar:	pop	hl
	add	hl,hl
	jp	hpush

;	2/  ( n1 -- n2 )

	hdr	2,'2/'
twodiv:	pop	hl
	ld	a,h
	rlca
	rrca
	rra
	ld	h,a
	ld	a,l
	rra
	ld	l,a
	jp	hpush

;	D2*  ( xd1 -- xd2 )

	hdr	3,'D2*'		; ANS
dtstr:	pop	de
	pop	hl
	add	hl,hl
	ld	a,e
	rla
	ld	e,a
	ld	a,d
	rla
	ld	d,a
	ex	de,hl
	jp	dpush

;	D2/  ( d1 -- d2 )

	hdr	3,'D2/'
dtdiv:	pop	hl
	pop	de
	ld	a,h
	rlca
	rrca
	rra
	ld	h,a
	ld	a,l
	rra
	ld	l,a
	ld	a,d
	rra
	ld	d,a
	ld	a,e
	rra
	ld	e,a
	jp	dpush

;	LSHIFT  ( x1 u -- x2 )

	hdr	6,'LSHIFT'		; ANS
lsh:	pop	de
	pop	hl
	inc	e
lsh1:	dec	e
	jp	z,hpush
	add	hl,hl
	jp	lsh1

;	RSHIFT  ( x1 u -- x2 )

	hdr	6,'RSHIFT'		; ANS
rsh:	pop	de
	pop	hl
	inc	e
rsh1:	dec	e
	jp	z,hpush
	or	a
	ld	a,h
	rra
	ld	h,a
	ld	a,l
	rra
	ld	l,a
	jp	rsh1

;	end