;	===============================================================
;
;	REC module for the arithmetic operators.  These comprise:
;
;		+ :	sum/logical or
;		- :	difference/exclusive or
;		* :	product/logical and
;		/ :	remainder, quotient
;		^ :	increment
;		d :	decrement, false on zero
;		N :	comparison, false if top greater
;		% :	convert to next smaller type
;		\ :	convert to next larger type
;
;	---------------------------------------------------------------
;
;			ATH - Copyright (c) 1984
;		     Universidad Autonoma de Puebla
;			  All Rights Reserved
;
;		    [Gerardo Cisneros, 25 April 1984]
;
;	==================================================================
;	15 Aug 1984 - Entry point for ^^ - GCS
;	===============================================================

;	(+) Add top two arguments on PDL: <a, b, +> leaves (a+b).
;	If arguments are of different length, the smaller one gets
;	promoted to the type of the larger one.  A null string is
;	treated as a zero.
;		arg size		  result
;		   0			null string
;		   1			 a <or> b
;		   2		      (a+b)mod(65384)
;		   4		      (a+b)mod(2**32)
;		  5,8			   (a+b)

sum:	call	twchk		;fetch top into arg1, pointers of next
	jcxz	sum0
sum00:	mov	al,NSIZ
	test	al,al
	jnz	sum1
	ret			;top arg null, PDL has result
sum0:	jmp	xfb		;lower arg null, give arg1 as result

sum1:	cmp	al,cl		;compare with size of lower arg
	jz	sum2
	call	cnv		;promote smaller if different
sum2:	cmp	al,1		;is size 1?
	jnz	suma
	mov	al,ARG1H	;yes, do logical or
	or	al,[bx]
	mov	[bx],al
	ret

suma:	cmp	al,5		;FP arguments?
	jnc	sumb
	mov	ax,0713H	;no, set up integer sum (adc ax,[bx])
suma0:	mov	cs:word ptr suma2,ax
	mov	bp,bx		;low byte of arg left on PDL
	mov	bx,(offset ARGHH)	;next to high byte of top arg
	sub	bx,cx		;minus length gives pointer to LSbyte
	shr	cx,1		;compute by words
	clc
suma1:	mov	ax,ds:[bp]	;get word from low arg
suma2	dw	0000		;add/subtract word from top arg
	mov	ds:[bp],ax	;replace on PDL
	inc	bp		;continue to next word
	inc	bp
	inc	bx		;on both arguments
	inc	bx
	loop	suma1		;until done
	ret

sumb:	mov	di,(offset arg2)	;clear arg2
	call	zarg
	mov	cl,NSIZ		;reload size into count reg.
	mov	si,dx		;PY to source index
	call	mduc		;move lower arg to arg2
	call	unpak		;unpack arg1
	jc	sumb0a
	ret			;done if top=0, result is on PDL
sumb0a:	mov	al,DXSG		;save top's sign before unpacking arg2
	mov	byte ptr DCXPT,al
	mov	BINXPT,dx	;save arg1's exponent too
	mov	bx,(offset arg2h)	;point to arg2's high byte
	call	unpk1		;use unpak's alternate entry
	pushf
	mov	al,byte ptr DCXPT	;retrieve sgn(top)
	rcl	al,1		;put signs together
	mov	al,DXSG
	rcr	al,1		;[sgn(top), sgn(next)]
	and	al,0C0H		;mask rest off
	mov	DXSG,al
	mov	word ptr DCXPT,0000	;clear dec. expt. before proceeding
	popf			;get flags back
	jnc	sumd		;pack arg1 up as result if arg2=0
	mov	ax,BINXPT
	sub	ax,dx		;expt(top)-expt(next)
	pushf
	push	ax
	js	sumb0b
	call	xarg		;put arg with smaller expt in arg1
sumb0b:	pop	ax
	popf
	jns	sumb1
	mov	BINXPT,dx	;result will have the larger of the exponents
	neg	ax		;get abs(expt. difference)
sumb1:	cmp	NSIZ,8
	jz	sumc
	cmp	ax,32		;31 bits max shifts to align points
	jmps	sumb0
sumc:	cmp	ax,52		;51 max shifts for DP
sumb0:	jnc	sumd0		;if more required, we're done
	mov	dl,al		;shift count to DL
	call	shrc		;else shift right smaller (DL) bits
	mov	al,DXSG		;decide whether to add or subtract
	test	al,al
	jpo	subt		;signs different means subtract
	call	add8		;otherwise add
	jnc	sumd		;done if no carry from the addition
	call	halve		;else shift one down
	add	byte ptr ARG1H,80H	;and set the bit from the carry
	inc	word ptr BINXPT	;reflect the shift in the exponent
	jmps	sumd		;pack it up

subt:	call	xarg		;exchange args, indicate sign of (next)
	call	sub8		;get difference of mantissas
	jnc	subt0		;wrap it up if no leftmost borrow
	call	cop		;else result will have opposite sign
	call	zarg1
	call	sub8		;subtract arg1 from 0
	not	byte ptr DXSG	;and invert sign
subt0:	call	zach		;check if arg1=0
	jnz	sumd		;pack it up if non-null
	jmp	xfb		;return NSIZ null bytes if null	

sumd0:	mov	si,(offset arg2)	;move arg2 to arg1
	mov	di,(offset arg1)
	mov	cx,8
	call	xf1
sumd:	mov	dx,BINXPT	;pack arg1 up
	jmp	peb2

;	(-) Subtract top from next: <a, b, -> leaves (a-b).
;	Reverse subtraction can be accomplished by exchanging
;	arguments: write <a, b, &, -> to get (b-a).
;	If arguments are of different length, the smaller one gets
;	promoted to the type of the larger one.  A null string is
;	treated as a zero.
;		arg size		  result
;		   0			null string
;		   1			 a <xor> b
;		   2		      (a-b)mod(65384)
;		   4		      (a-b)mod(2**32)
;		  5,8			   (a-b)

dif:	call	twchk	;put top arg in arg1, get pointers to lower arg
	test	cl,cl
	jnz	difa	;is lower arg 0?
	call	xfb	;yes, leave top arg as result,
	cmp	byte ptr NSIZ,1
	jz	dif0
	jmp	comp	;but in negated form if size 2 bytes or longer
dif0:	ret

difa:	mov	al,NSIZ		;is top arg null?
	test	al,al
	jnz	difa0
	ret			;yes, leave lower one as result
difa0:	cmp	al,cl		;no, compare its size with the lower one's
	jz	difa1
	call	cnv		;and make them of equal type if needed
difa1:	cmp	al,1		;if size is one
	jnz	difb
	mov	al,arg1h	;do logical xor
	xor	al,[bx]
	mov	[bx],al
	ret

difb:	cmp	al,5		;FP args?
	jnc	difb0
	mov	ax,071BH	;prepare for integers (sbb ax,[bx])
	jmp	suma0		;no, use loop at sum for integers

difb0:	mov	bx,arg1b	;yes, invert sign of top operand
	test	bx,bx		;if it isn't 0
	jnz	difb1
	ret			;(return if top is zero)
difb1:	xor	byte ptr ARG1H,80H	;invert high bit of high byte
	jmp	sumb		;and use code at sum

;	(*) Multiply top two arguments on PDL: <a, b, *> leaves (a*b).
;	If arguments are of different lengths, the smaller one gets
;	promoted to the type of the larger one. A null string is treated
;	as a 0.
;		    arg size			  result
;			0			null string
;			1			 a <and> b
;			2			(a*b)mod(2**16)
;			4			(a*b)mod(2**32)
;		       5,8			    (a*b)

mpy:	call	twchk	;get top and pointers to next
	jcxz	mpy0
	mov	al,NSIZ
	test	al,al
	jnz	mpy1
	jmp	zres1	;return a 0 if top is the null string
mpy1:	cmp	al,cl
	jz	mpy2
	call	cnv	;promote smaller if not same size
mpy2:	cmp	al,1
	jnz	mpya
	mov	al,arg1h	;do logical op if size is 1
	and	al,[bx]
	mov	[bx],al
	ret
mpy0:	jmp	zres0	;return a 0 if lower is the null string

mpya:	cmp	al,4
	jnc	mpyb
	mov	ax,ARG1B	;2-byte integer prod here
	mul	word ptr [bx]
	mov	[bx],ax
	ret

mpyb:	cmp	al,5
	jnc	mpyc
	mov	si,(offset ARG1M)	;4-byte integers done here
	mov	di,(offset ARG2)	;move factor to lower 4 of arg2 
	mov	cx,4
	call	xf1		;4-byte integers done here
	call	zarg1		;factor in arg2, zero in arg1
	mov	dx,20H		;32 shifts needed
pr3:	mov	cx,2		;number of words
	call	twi0	;shift arg1 left
	mov	cx,2
	mov	bx,PX
	call	twi1	;shift lower factor left
	jnc	pr3a
	mov	cx,2
	call	adda		;add top factor to arg1 if bit shifted out
pr3a:	dec	dx
	jnz	pr3
	mov	si,(offset ARG1M)
	jmp	xfb1		;get number back from arg1 when done

mpyc:	mov	di,(offset arg2)	;floating point products done here
	call	zarg
	call	unpak		;unpack top
	jc	mpyc1
	jmp	zres0		;leave 0 if top is zero
mpyc1:	call	mpdv		;else unpack other and add exponents
	mov	si,PX		;low byte of unpacked other
	inc	si		;was shifted once by unpk1
	mov	al,NSIZ
	dec	al		;number of mantissa bytes
	mov	dl,al		;into DL
pr4:	cld
	lods	byte[si]	;examine next byte of factor on PDL
	test	al,al
	jnz	pr5
	call	shrby		;shift partial product a full byte if zero
	jmps	pr7
pr5:	mov	cx,8		;else shift and add according to 1s in A
pr6:	push	cx
	rcr	al,1
	mov	dh,al		;save A in C
	jnc	pr6a
	call	add8		;add other factor if there was a 1
pr6a:	mov	bx,(offset arg1h)
	call	halvc		;shift partial prod down one bit with carry
	mov	al,dh		;retrieve A
	pop	cx		;retrieve counters
	loop	pr6
pr7:	dec	dl		;count mantissa bytes
	jnz	pr4
	jmp	sumd		;go pack up result

;	(/)  Divide top: <a,b,/> leaves rem(a/b), int(a/b).
;	Reverse division is possible by exchanging arguments;
;	thus <b,a,&,/> leaves rem(b/a), int(b/a).  If just
;	the remainder is required, write <a,b,/,L>, while if
;	only the quotient is desired, write <a,b,/,&,L>, and
;	finally, if the order of the remainder and quotient is
;	not satisfactory, they can be exchanged.  The division
;	is unsigned integer division.  It can also be used to
;	split a two-byte word into two parts through division
;	by the corresponding power of two.
;	Floating point divisions leave only the quotient.

dvd:	call	twchk		;check top two args
	test	cl,cl
	jnz	dvd0		;leave two zeros if lower is null
	call	zres0
	mov	cx,PY
	sub	cx,PX
	call	narg
	mov	al,cl
	jmp	zres0

dvd0:	mov	al,NSIZ
	cmp	al,cl
	jz	dvd1
	call	cnv		;else make sure both are same length
dvd1:	cmp	al,1
	jnz	dvda
	call	ip		;promote one byte arg to 2 bytes
	mov	bx,(offset arg1h)	;shift down byte at arg1
	mov	ah,[bx]
	xor	al,al
	mov	[bx],al		;and make the upper byte zero
	dec	bx
	mov	[bx],ah
	mov	bx,PX		;run into dvda with appropriate A and HL
dvda:	cmp	al,4
	jnc	dvdb
	cmp	word ptr ARG1B,0000	;divisor
	jz	der
	mov	ax,[bx]
	mov	dx,0000		;32-byte dividend
	div	word ptr ARG1B
	mov	[bx],dx		;remainder
	mov	bp,ax
	mov	cx,0002
	call	narg		;close argument, open new
	mov	[bx],bp		;quotient
	add	bx,cx
	mov	PY,bx
	ret
der:	call	RER

dvdb:	cmp	al,5
	jc	dvdba
	jmp	dvdc
dvdba:	mov	al,ARG1H	;save sign of divisor
	mov	DXSG,al
	test	al,al		;and complement if negative
	jns	dvdb0
	mov	bx,(offset ARG1M)
	mov	cx,4
	call	ngn1
dvdb0:	call	cop	;copy divisor to arg2
	call	zarg1	;clear arg1
	mov	cx,2
	mov	bx,(offset arg2)
	mov	bp,(offset arg2m)
	call	subc	;subtract divisor from 0 (high end)
	mov	bx,PY
	mov	al,-1[bx]		;save sign of dividend
	mov	byte ptr DCXPT,al	;separately to give sign of remainder
	xor	DXSG,al		;and combined with sign of divisor
	mov	si,bx		;prepare pointer for transfer
	test	al,al
	jns	dvdb1
	mov	bx,PX
	mov	cx,4
	call	ngn1	;and complement dividend if negative
dvdb1:	mov	di,(offset arg1m)	;point to middle of arg1
	mov	cx,4	;set counter for mduc
	call	mduc	;and copy numerator to lower half of arg1
	mov	dh,20H	;32 shifts at most
qn4:	call	twice	;shift arg1 left
	mov	bx,(offset arg1m)
	mov	cx,2
	call	addb	;add arg2 to arg1 (high 4)
	jnc	qn5	;undo if denominator didn't fit
	inc	(byte ptr ARG1)		;else add one at LSbit of quotient
	jmps	qn6
qn5:	mov	bx,(offset arg1m) 
	mov	bp,(offset arg2m)	;positive copy of divisor
	mov	cx,2
	call	addc	;undo previous subtraction
qn6:	dec	dh	;shift count
	jnz	qn4
	mov	di,PY	;arg1 will be split into 2 4-byte values
	mov	si,(offset arghh)
	mov	cx,4
	call	mduc	;move remainder to the PDL
	mov	al,byte ptr DCXPT	;get sign of numerator
	test	al,al
	jns	dvdb2
	call	comp	;and complement remainder if numerator was <0
dvdb2:	call	rarg	;redo pointers
	mov	cx,4
	add	bx,cx	;add 4 to HL, which contains px
	mov	PY,bx
	mov	di,bx
	mov	si,(offset ARG1M)	;point to middle of arg1
	call	mduc	;put quotient on the PDL
	mov	al,DXSG	;get sign of quotient
	test	al,al
	jns	dvdb3
	call	comp	;and complement if necessary
dvdb3:	ret

overf:	call	ovf	;make a large number at arg1
	call	peb3	;and move it to the PDL
	call	rer	;but record error also

dvdc:	mov	di,(offset arg2)	;floating point division starts here
	call	zarg	;by clearing arg2
	call	unpak	;unpack divisor at arg1
	jnc	overf	;and return largest value if divisor=0
	neg	dx	;else negate the divisor's exponent
	inc	dx	;and add1 to align points
	call	mpdv	;move divisor to arg2, 0 to arg1, unpack num
	mov	bx,PX
	cmp	NSIZ,5
	jnz	dvdc1
	inc	bx
dvdc1:	mov	cs:numr,bx
	mov	cs:numr0,bx
	mov	cs:numr1,bx
	mov	al,8
	sub	al,(byte ptr NSIZ)	;offset of mantissa from arg1 or arg2
	mov	ah,0
	jz	dvdc2
	inc	ax
dvdc2:	mov	bx,(offset arg1)
	add	bx,ax
	mov	cs:quot,bx
	mov	bx,(offset arg2)	;and start of the divisor's mantissa
	add	bx,ax
	mov	cs:denr,bx
	mov	cs:denr0,bx
	mov	cl,NSIZ		;compute number of mantissa words
	mov	ch,0
	shr	cx,1
	mov	dh,ch
qn7:	mov	dl,cl	;and save in DL
	dw	1E8DH	;(lea bx,)
numr	dw	0000
	dw	2E8DH	;(lea bp,)
denr	dw	0000	;space for start of divisor mantissa
	call	subc	;do a trial subtraction
	mov	al,[bx]
	sbb	al,ch
	cmc
	jc	qn8	;do we have to undo the subtraction?
	dw	1E8DH	;(lea bx,)
numr0	dw	0000	
	dw	2E8DH	;(lea bp,)
denr0	dw	0000
	mov	cl,dl	;get a copy of mantissa byte count
	call	addc	;add divisor back
	clc
	jmps	qn9
qn8:	mov	[bx],al
	inc	dh	;indicate succesful subtraction in C
qn9:	mov	al,arg1h	;have we shifted a one into the MSbit?
	inc	al
	dec	al
	jns	qn10	;yes, we're done
	jmp	sumd
qn10:	nop
	dw	1E8DH	;(lea bx,) no, shift and loop
quot	dw	0000
	mov	cl,dl
	call	tw1	;shift the quotient left one bit
	dw	1E8DH
numr1	dw	0
	mov	cl,dl
	call	tw1	;shift the dividend left one bit
	rcl	byte ptr [bx],1	;shift also into the next byte up
	mov	cl,dl	;get counters ready for next iteration
	test	dh,dh
	jnz	qn7
	dec	BINXPT	;adjust expt if we shifted w/ no subtraction
	jmps	qn7

;	Routine to unpack second argument and add exponents
;	in floating point multiplication and division

mpdv:	mov	BINXPT,dx	;save exponent of multiplier/divisor
	mov	al,DXSG	;save sign before
	mov	byte ptr DCXPT,al	;unpacking lower arg
	call	xarg	;move multiplier/divisor to arg2 and 0 to arg1
	mov	bx,PY	;pointer
	mov	(byte ptr[bx]),ch	;clear high byte +1 of numerator
	dec	bx		; to high byte of multiplicand/dividend
	call	unpk1		;which we proceed to unpack
	pop	bp		;remove return address
	jc	mpdv0
	jmp	zres0		;in case we have 0 mult/dividend
mpdv0:	push	bp		;restore it
	add	dx,BINXPT		;add exponents together
	mov	BINXPT,dx	;save them
	mov	bx,(offset DCXPT)
	xor	al,al		;clear DCXPT
	mov	cl,[bx]		;but not before retrieving saved sign
	mov	[bx],al
	inc	bx
	mov	[bx],al
	inc	bx		;now we're pointing at DXSG
	xor	[bx],cl		;into which we combine the other sign
	ret			;and we're done here

;	(N) Numerical comparison of top two elements on PDL. <a,b,N>
;	is true if a .LE. b; both arguments are erased irrespective
;	of the result.  Assuming numerical arguments means they are
;	two byte integers in the machine representation of addresses.
;	In the case of single byte arguments, their logical AND is
;	calculated, but they are both popped from the pushdown list.
;	N is FALSE if the AND is zero, meaning that if the bit tested
;	in one argument by using the other as a mask was zero, then
;	N failed.

ucn:	call	twchk	;verify size of args
	mov	al,NSIZ
	cmp	al,cl
	jz	ucn0
	call	cnv	;make sizes equal
ucn0:	test	al,al
	jnz	ucn1
	jmp	skp	;TRUE if both null
ucn1:	cmp	al,01	;TEST one-byte arguments
	jnz	un2
un1:	mov	al,ARG1H	;TEST
	and	al,[bx]
	jnz	un0
	jmp	ucl		;false
un0:	jmp	cucl		;true

un2:	cmp	al,4
	jnc	un3
	mov	ax,ARG1B	;low byte of argument at arg1
	sub	ax,[bx]
	jnc	un2a
	jmp	ucl		;false, pdl.gt.arg1 
un2a:	jmp	cucl		;true, pdl.le.arg1

un3:	call	difb
	mov	bx,PY
	dec	bx
	dec	bx
	mov	ax,[bx]		;test hi bytes
	test	ax,ax
	js	un4
	dec	bx
	dec	bx
	or	ax,[bx]		;get next two lower bytes
	jz	un4
	jmp	ucl		;lift and FALSE if strictly positive
un4:	jmp	cucl		;lift and TRUE if minus or zero

;	(^) Increment the top of the PDL. A null string causes a
;	noop.  Other arguments cause a '+' operation to be performed
;	with a 1 of the proper size

intw:	call	incr		;Entry point for ^^

incr:	call	numchk
	test	cl,cl
	jnz	incr0
	ret		;leave null strings alone
incr0:	call	uno	;put a one in arg1
	jmp	sum00	;add it to the top

;	(d) False and lift if zero, otherwise decrement and exit true.
;	Always false on null strings; a one of the proper type is
;	subtracted in all other cases

decr:	call	numchk
	test	cl,cl
	jnz	dec0
	jmp	ucl	;Lift and exit FALSE if null
dec0:	mov	dl,cl	;save size of operand
	xor	al,al
	mov	ch,al
dec1:	or	al,(byte ptr[bx])	;jam operand bytes into A
	inc	bx
	loop	dec1
	or	al,al
	jnz	dec2
	jmp	ucl	;Lift and exit false if zero
dec2:	mov	cl,dl	;else restore size
	call	uno	;make a one in arg1
	call	difa	;subtract it
	jmp	skp	;and take the TRUE exit

;	Make a one in arg1

uno:	mov	NSIZ,cl
	mov	dl,cl
	call	zarg1
	cmp	dl,5
	jnc	unof
	xor	dh,dh	;compute address of byte
	neg	dx	;to receive the integer 1
	mov	bx,(offset arghh)
	add	bx,dx
	mov	(byte ptr[bx]),1	;store it
	jmps	uno2

unof:	jnz	unod	;decide whether SP or DP
	mov	bx,03F80H
	jmps	uno1
unod:	mov	bx,03FF0H
uno1:	mov	arg1b,bx	;upper two bytes of arg1
uno2:	mov	bx,PX		;redo pointers to top of PDL
	mov	cx,PY
	mov	dx,cx
	sub	cx,bx
	ret

;	(%) Convert numeric argument to next smaller type. DP=>SP may
;	produce overflow or underflow. SP=>4-byte integer is done by
;	dropping the fraction, truncating the integer part modulo (2**32)
;	and negating if the original was less than 0.  4-byte=>2-byte and
;	2-byte=>1-byte are done by truncating mod(2**16) and mod(2**8)
;	respectively.  The null string produces a noop.

pe:	call	numchk	;verify that argument is indeed numeric
	jz	peflt	;distinguish FP argument
	test	cl,cl
	jnz	pe0a
	ret		;leave null strings in peace
pe0a:	shr	cl,1	;else an integer, leave half of original
	add	bx,cx	;add to px
	mov	py,bx	;store as new limit of argument
	ret

peflt:	mov	NSIZ,cl	;save current size
	call	dsinit	;clear number buffers
	mov	si,dx
	mov	di,(offset arghh)	;set dest. addr
	mov	cl,NSIZ	;restore byte count
	call	mduc	;transfer from PDL to arg1
	call	unpak	;separate sign, exponent and mantissa
	jc	pea	;jump if argument is non-null
pe0:	mov	al,NSIZ	;produce 4-byte zero
	dec	al
	cmp	al,4	;if not 4, its a 7 and we want 5
	jnz	pe0b
	jmp	zres
pe0b:	sub	al,2
	jmp	zres

pea:	cmp	NSIZ,8
	jz	peb	;jump if DP=>SP
	dec	dx	;reduce exponent by one
	js	pe0	;no integer part if result negative
	inc	dx	;restored
	sub	dx,32	;integer overflow if expt gt 32
	jz	pesgn	;done if binary point at right end
	js	per	;shift right if less than 32

	mov	ax,0FFFFH	;set largest long integer (2**31 - 1)
	mov	word ptr ARG1M,ax
	shr	ax,1
	mov	word ptr ARG1B,ax
	jmps	pesgn

per:	neg	dx	;right shift
	call	shrc	;and shift right arg1 by count

pesgn:	mov	al,4	;set size
	mov	NSIZ,al
	call	xfb	;put operand on PDL
pesg1:	mov	al,DXSG	;check sign of original
	test	al,al
	jns	pesg2
	jmp	comp	;negate if original was negative
pesg2:	ret

peb:	mov	al,5	;size of final number
peb1:	mov	NSIZ,al	;saved
peb2:	mov	cx,0FBFFH	;add a bias
	add	dx,cx	;to the unpacked exponent
	call	dnd3	;repack it as SP or DP number
peb3:	mov	al,NSIZ	;compute source address + 1
	mov	cl,al	;since dnd3 leaves result
	mov	ch,0	;at low end of arg1
	mov	si,(offset arg1)
	add	si,cx
	call	xfb2	;transfer from low end of arg1
	jmp	pesg1	;set the proper sign

;	(\) Convert a numeric argument to the next higher type

ip:	call	numchk	;ensure arg has size of a numeric type
	jz	ipflt	;go to ipflt if arg is FP
	cmp	cl,4
	jz	iplf	;int to FP conv reqd for long integers
	add	cl,cl	;determine new size for 1 or 2-byte args
	jnz	ip0
	mov	(byte ptr[bx]),cl	;clear a byte if arg was null string
	inc	cl
ip0:	call	OARG	;check that space is available
	mov	dx,bx	;new py to DE
	mov	bx,PY	;old py to HL
	clc
	rcr	cl,1	;bytes to clear
	jc	ip2	;done if new arg has size 1
ip1:	mov	(byte ptr[bx]),0
	inc	bx
	loop	ip1
ip2:	mov	PY,dx	;and save
	ret

iplf:	inc	cl	;make size 5
	mov	NSIZ,cl
	mov	frst,cl	;preclude possibility of '-' in frst
	call	dsinit	;clear number buffers
	xchg	bx,dx
	mov	al,-1[bx]	;get high byte
	or	al,al	;ascertain sign
	jns	iplf1
	call	comp	;complement if negative and
	mov	al,'-'	;indicate a minus sign
	mov	frst,al
iplf1:	mov	cl,4	;and reset number of bytes to move
	mov	di,(offset arg1m)
	mov	si,bx
	call	mduc	;transfer from PDL into low end of arg1
	mov	cl,NSIZ	;put size in BC
	call	oarg	;ane check that space is available
	call	dsend	;invoke assembly of FP numbers
	mov	si,(offset arg1x)
	jmp	xfb1	;transfer from low end of arg1

ipflt:	cmp	cl,8
	jnz	ipfl0
	ret		;leave DP arg in peace
ipfl0:	mov	NSIZ,cl	;record size
	call	dsinit	;clear number buffers
	mov	di,(offset arghh)	;set dest addr + 1
	mov	si,dx
	mov	cl,5	;bytes to move
	call	mduc	;transfer from PDL
	call	unpak	;unpack sign, exponent and mantissa
	mov	al,8	;in case we go to zres
	jnc	zres	;go to zres if it was zero
	jmp	peb1	;else repack it as DP

;	---------------------------------------------------------------
;	Service routines for the preceding operators
;	---------------------------------------------------------------

;	Get top arg into arg1 and poinuers to lower arg into registers
;	Check also that both args are numeric
;	If succesful, numchk returns px in HL, py in DE, py-px in
;	BC and in A and zero flag on if arg is FP

twchk:	call	zarg1	;clear number buffer
	pop	ax	;remove return address from stack
	call	numchk	;check top arg
	mov	NSIZ,cl	;save its size
	mov	si,dx	;PY as source pointer
	mov	di,(offset arghh)	;dest+1 to di
	call	mduc	;move by decrement until count
	call	ucl	;lift it from the PDL
	call	numchk	;check top arg
	jmp	ax

;	Transfer arg1 back on the PDL

xfb:	mov	si,(offset arghh)	;source address + 1
xfb1:	mov	al,NSIZ	;get size
	mov	cl,al	;put it in BC
	mov	ch,0
xfb2:	mov	di,px	;compute dest address + 1
	add	di,cx
	mov	py,di	;and save it as end of argument
	call	mduc	;move by decrement until count
	ret

;	Return a zero of the proper size

zres0:	mov	cl,NSIZ
zres1:	mov	al,cl
zres:	mov	cl,al
	mov	di,px
	mov	ch,0	;clear upper byte of count
	jcxz	znul	;done if nothing to move
	call	zar1
znul:	mov	py,di	;keep py updated
	ret

;	Shift arg1 right one byte

shrby:	mov	bx,(offset arg1)
	mov	bp,bx
	inc	bp
	mov	cx,7
shrb1:	mov	al,ds:[bp]
	mov	[bx],al
	inc	bp
	inc	bx
	loop	shrb1
	mov	[bx],ch	;clear high byte
	ret

;	Convert to type of longer argument

cnv:	lahf
	push	ax	;save size and result of comparison
	inc	dx	;rebuild!top px and py
	inc	dx
	mov	px,dx	;top px
	mov	al,NSIZ	;size of top
	mov	cl,al
	add	dx,cx
	mov	py,dx	;top py
	pop	ax
	sahf
	pushf		;retrieve but save again comparison flag
	jc	cnv0
	call	exch	;exchange if lower smaller than upper
cnv0:	call	ip	;convert top to next bigger type
	popf
	jc	cnv1
	call	exch	;exchange back if necessary
cnv1:	call	twchk	;see if same size
	mov	al,NSIZ
	cmp	al,cl
	jnz	cnv	;repeat if not same size yet	
	ret

;	Subtract arg2 from arg1; leave result in arg1

sub8:	mov	cx,4
subb:	mov	bp,(offset arg2)
	mov	bx,(offset arg1)
subc:	clc
sb1:	mov	ax,[bx]
	sbb	ax,ds:[bp]
	mov	[bx],ax
	inc	bx
	inc	bx
	inc	bp
	inc	bp
	loop	sb1
	ret

;	Exchange arg1 and arg2; exchange high bits of DXSG

xarg:	mov	bx,(offset arg1)
	mov	bp,(offset arg2)
	mov	cx,4
xr1:	mov	ax,[bx]
	xchg	ds:[bp],ax
	mov	[bx],ax
	inc	bx
	inc	bx
	inc	bp
	inc	bp
	loop	xr1
	mov	al,DXSG
	mov	cl,al
	rcl	al,1
	rcl	al,1
	mov	al,cl
	rcr	al,1
	and	al,0C0H
	mov	DXSG,al
	ret

;	Shift right arg1 by count in DL

shrc:	test	dl,dl
	jnz	per0
	ret		;return immediately if count=0	
per0:	mov	cl,dl
	sub	dl,8
	js	per0a	;less than one byte to shift
	call	shrby	;no, shift a byte
	jmp	per0
per0a:	mov	dl,cl
per1:	call	halve	;shift right one bit
	dec	dl
	jnz	per1
	ret

	end