;
;  ARITH.MAC - Arithmetic and Logical Functions
;
;  AND  OR  XOR  INVERT  NOT  S>D  D>S  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	1,'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	1,'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	1,'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

abs:	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

sar:	ld	a,h		; shift arithmetic right
	rlca
	rrca
	rra
sar1:	ld	h,a
	ld	a,l
	rra
	ld	l,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

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

	hdr	1,'INVERT'
invert:	pop	hl
	call	negg1
	jp	hpush

;	NOT  ( x1 -- x2 )		aka 0= not

	hdr	1,'NOT',,,zequ		; F79 NOT
nott	equ	zequ

;	S>D  ( n -- d )

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

;	D>S  ( d -- n )			aka drop d>s

	hdr	1,'D>S',,,drop
dtos	equ	drop

;	NEGATE  ( n1 -- n2 )

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

;	ABS  ( n -- +n )

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

;	DNEGATE  ( d1 -- d2 )

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

;	DABS  ( d -- +d )

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

;	+  ( x1 x2 -- x3 )

	hdr	1,'+'
plus:	pop	de
plus1:	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	1,'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	1,'D-'
dsub:	call	docol
	dw	dnegat,dplus
	dw	exit

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

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

;	1+  ( x1 -- x2 )

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

;	2+  ( x1 -- x2 )

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

;	1-  ( x1 -- x2 )

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

;	2-  ( x1 -- x2 )

	hdr	1,'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	abs
	ex	de,hl
	call	abs
	call	umstrr
	pop	af
	ret	nc
	jp	dnegg

;	UM*  ( u1 u2 -- ud )

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

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

	hdr	1,'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
	push	de
	jp	next

;	division primitives

	cseg

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

usl3:	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,usl3
	ret

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

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

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

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

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

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

	cseg

msm:	push	bc		; save divisor
	ld	a,b
	xor	h
	push	af		; save quot sign
	push	hl		; save dividend
	push	hl
	ld	l,c
	ld	h,b
	call	abs
	ld	c,l
	ld	b,h
	pop	hl
	call	dabss
	call	mum
	pop	af		; sign remainder
	or	a
	ex	de,hl
	call	m,negg
	ex	de,hl
	pop	af
	pop	bc		; restore divisor
	or	a		; sign quot
	jp	p,msm1
	jp	negg

msm1:	pop	bc		; discard return
msm2:	pop	bc
	jp	dpush

;	SM/REM  ( d n1 -- n2 n3 )

	hdr	1,'SM/REM'	; ANS
smrem:	ld	l,c
	ld	h,b
	pop	bc
	pop	de
	ex	(sp),hl
	ex	de,hl
smrem1:	call	msm
	jp	msm2

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

	hdr	1,'FM/MOD'	; ANS
fmmod:	ld	l,c
	ld	h,b
	pop	bc
	pop	de
	ex	(sp),hl
	ex	de,hl
fmmod1:	call	msm
	ld	a,d
	or	e
	jp	z,msm2		; skip if remainder = 0
	dec	hl		; floor
	push	hl
	ex	de,hl
	add	hl,bc
	ex	de,hl
	pop	hl
	jp	msm2

;	M/MOD  ( d n1 -- n2 n3 )	fm/mod or sm/rem

	hdr	x,'M/MOD',,,msmod

	 if	floord
msmod	equ	fmmod
	 else
msmod	equ	smrem
	 endif

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

	hdr	1,'/MOD'
slmod:	call	docol
	dw	tor,stod
	dw	fromr,msmod
	dw	exit

;	/  ( n1 n2 -- n3 )		/mod nip

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

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

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

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

	hdr	1,'*/MOD'
ssmod:	call	docol
	dw	tor,mstar
	dw	fromr,msmod
	dw	exit

;	*/  ( n1 n2 n3 -- n4 )		*/mod nip

	hdr	1,'*/'
ssla:	call	docol
	dw	ssmod,nip
	dw	exit

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

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

;	2*  ( x1 -- x2 )

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

;	2/  ( n1 -- n2 )

	hdr	1,'2/'
twodiv:	pop	hl
	call	sar
	jp	hpush

;	D2*  ( xd1 -- xd2 )

	hdr	1,'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	1,'D2/'
dtdiv:	pop	hl
	pop	de
	call	sar
	ld	a,d
	rra
	ld	d,a
	ld	a,e
	rra
	ld	e,a
	jp	dpush

;	LSHIFT  ( x1 u -- x2 )

	hdr	1,'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	1,'RSHIFT'		; ANS
rsh:	pop	de
	pop	hl
	inc	e
rsh1:	dec	e
	jp	z,hpush
	or	a
	ld	a,h
	rra
	call	sar1
	jp	rsh1

;	end

