; FLTARITH.ASM
; ------------
;
; See FALCONER.WS4 for doc.
;
; (Retyped by Emmanuel ROCHE.)
;
;--------------------------------
; External routines required
;
	extrn	aerc		; Arithmetic error trap
;
;--------------------------------
; External routine in INTARITH.ASM
;
	extrn	c1de,c2bc,c2de,derc,dhlz
	extrn	idiv,imul,stadr
;
;--------------------------------
; Allowable entry points
;
; Data manipulation
;
	entry	hlrd,fxchg
;
; Memory addressing
;
	entry	lfds,lfbs,fload,fstor
	entry	lfbis,lfdis,sfdis
;
; Arithmetic operators
;
	entry	fmult,fdivt,fmul
	entry	fdiv,fdivr,frcip
	entry	fadd,fsub,fsubr
;
; Testing, integer extraction
;
	entry	fcmp,fint
;
; Format conversion
;
	entry	flota,flotp,flotd,flot
	entry	fixt,fixr
;
;--------------------------------
; Macro definitions
;--------------------------------
;
; Change sign of real operand B or D
;
fsign	macro	reg
bc.l	equ	b
de.h	equ	d
	if	reg*(reg-d)
	error	"R"
	endif
	mov	a,reg
	xri	80H
	mov	reg,a
	endm
;
; Load (& pop) real (reg) from TOS, stored by SFTS macro
;
lfts	macro	reg
bc.l	equ	b
de.h	equ	d
	pop	reg
	mov	5-reg/2,reg
	pop	reg
	if	reg*(reg-d)
	error	"R"
	endif
	endm
;
; Load (reg) from TOS & leave on stack (reg)
;
ltos	macro	reg
	pop	reg
	push	reg
	endm
;
; Move operation on register pair B, D, or H
;
movd	macro	r1,r2
	if	((r1-d)*(r1-h)*r1) OR ((r2-d)*(r2-h)*r2)
	error	"R"
	endif
	mov	r1,r2
	mov	r1+1,r2+1
	endm
;
; Move floating operand from Reg1 to Reg2
;
movf	macro	r2,r1
bc.l	equ	b
de.h	equ	d
	if	(r1*(r1-d)) OR (r2*(r2-d))
	error	"R"
	endif
	mov	r2,r1
	mov	r2+1,r1+1
	mov	5-r2/2,5-r1/2
	endm
;
; Reload (BC.L), stored by PUSH B, PUSH H sequence
;
reload	macro	reg
bc.l	equ	b
	if	reg-B
	error	"R"
	db	0,0,0
	endif
	if	reg-b=0		; Was IFZ
	pop	b
	mov	l,c
	pop	b
	endif
	endm
;
; "Return" and check stack level zero
;
rtn	macro
	if	.lvl
	error	"0"+.lvl
.lvl	set	0
	endif
	ret
	endm
;
; Save (BC.L), to be restored by RELOAD BC.L later
;
save	macro	reg
bc.l	equ	b
	if	reg-b
	error	'R'
	db	0,0
	endif
	if	reg-b=0		; Was IFZ
	push	b
	push	h
	endif
	endm
;
; Store real value on top of stack; note SFTS B affects (A)
;
sfts	macro	r
bc.l	equ	b
de.h	equ	d
	if	r*(r-d)
	error	'R'
	endif
	if	r=0		; Was IFZ
	mov	a,l
	endif
	push	r
	push	psw-r
	endm
;
;--------------------------------
; Auxiliary routines
;--------------------------------
;
; Normalize the 32 bit value in (DEHL) left
; and round to 16 bits. Discard the high order
; bit. (B) returns shift count (in offset binary).
; Return Carry for value zero.
; A,F,B,D,E,H,L
;
hlrd:	mvi	b,80H		; 
	mov	a,d		; 
	ora	a		; 
	jm	hlrd2		; Normalized
	ora	e		; 
	ora	h		; 
	ora	l		; 
	stc			; 
	rz			; Zero value
hlrd1:	dcr	b		; 
	call	dhlz		; Left shift
	jp	hlrd1		; 
hlrd2:	ani	7FH		; 
	mov	d,a		; Discard high order bit
	mov	a,h		; 
	ora	a		; Check for rounding
	rp			; Not needed
	inr	e		; Round up
	rnz			; No Carry
	inr	d		; 
	rp			; No overflow
	inr	b		; Modify shift count
	mov	d,e		; Set result
	rtn			; 
;
; Set the high order bits in (BC) and (DE) for
; arithmetic operations. Discard original signs.
; Reset Carry.
; A,F,B,D
;
sethi:	mov	a,b		; 
	ori	80H		; 
	mov	b,a		; 
	mov	a,d		; 
	ori	80H		; 
	mov	d,a		; 
	rtn			; 
;
; Exchange floating operands
; A,B<=>D,C<=>E,H<=>L
;
fxchg:	mov	a,b		; 
	mov	b,d		; 
	mov	d,a		; 
	mov	a,c		; 
	mov	c,e		; 
	mov	e,a		; 
	mov	a,l		; 
	mov	l,h		; 
	mov	h,a		; 
	rtn			; 
;
; Load (DE.H) from stack level (A)
; Value was stored with PUSH D, PUSH H sequence.
; A,F,D,E,H
;
lfds:	push	h		; 
	call	stadr		; Get abs address
	inx	h		; 
	mov	a,m		; Get exponent
	inx	h		; 
	mov	e,m		; 
	inx	h		; 
	mov	d,m		; Get mantissa
	pop	h		; 
	mov	h,a		; 
	rtn			; 
;
; Load (BC.L) from stack level (A)
; Value was stored by PUSH D, PUSH H sequence.
; A,F,B,C,L
;
lfbs:	push	h		; 
	call	stadr		; Get abs address
	inx	h		; 
	mov	a,m		; Get exponent
	inx	h		; 
	mov	c,m		; Get mantissa
	inx	h		; 
	mov	b,m		; 
	pop	h		; 
	mov	l,a		; 
	rtn			; 
;
; Load indirect (BC.L) via stack level (A) ptr
; A,F,B,C,L
;
lfbis:	push	h		; 
	call	stadr		; Form abs address
	mov	a,m		; LS mem address
	inx	h		; 
	mov	h,m		; MS mem address
	mov	l,a		; 
	mov	a,m		; Get exponent
	inx	h		; 
	mov	c,m		; 
	inx	h		; 
	mov	b,m		; Get mantissa
	pop	h		; 
	mov	l,a		; 
	rtn			; 
;
; Load indirect (DE.H) via stack level (A) ptr
; A,F,D,E,H
;
lfdis:	push	h		; 
	call	stadr		; Form abs address
	mov	a,m		; LS mem address
	inx	h		; 
	mov	h,m		; MS mem address
	mov	l,a		; 
	mov	a,m		; Get exponent
	inx	h		; 
	mov	e,m		; 
	inx	h		; 
	mov	d,m		; Get mantissa
	pop	h		; 
	mov	h,a		; 
	rtn			; 
;
; Store (DE.D) indirect via stack level (A) ptr
; A,F
;
sfdis:	push	h		; 
	push	b		; 
	mov	c,m		; Keep exponent
	inr	a		; Allow for PUSH B
	call	stadr		; Get abs address
	mov	a,m		; 
	inx	h		; 
	mov	h,m		; 
	mov	l,a		; Get pointer
	mov	m,c		; Store exponent
	inx	h		; 
	mov	m,e		; 
	inx	h		; 
	mov	m,d		; Store mantissa
	pop	b		; 
	pop	h		; 
	rtn			; 
;
; Load (DE.H) via pointer (BC); advance (BC)
; B,C,D,E,H
;
fload:	push	psw		; 
	ldax	b		; 
	mov	m,a		; 
	inx	b		; 
	ldax	b		; 
	mov	e,a		; Mantissa
	inx	b		; 
	ldax	b		; 
	mov	d,a		; Exponent
	inx	b		; Setup for next time
	pop	psw		; 
	rtn			; 
;
; Store (DE.H) via pointer (BC); advance (BC)
; B,C
;
fstor:	push	psw		; 
	mov	a,h		; 
	stax	b		; 
	inx	b		; 
	mov	a,e		; 
	stax	b		; 
	inx	b		; 
	mov	a,d		; 
	stax	b		; 
	inx	b		; Setup for next time
	pop	psw		; 
	rtn			; 
;
;--------------------------------
; Floating point arithmetic system for YALE 8080-based
; computers -- by Charles B. FALCONER, April 1976
;
; Real representation can express values in the absolute value
; range 0.29388 * 10^-38 through 1.7018 * 10^+38, and zero,
; together with sign, with approximately 4.8 decimal digit
; accuracy. The resolution of a value between 1 and 2 is
; approximately 0.00003. The system is designed to maximize
; register (as opposed to memory) use during computation.
;
; A real (floating point) value is represented by a unipolar
; 16 bit mantissa, whose value is in the range 1.0 > mantissa
; > -1.0. The mantissa absolute value is always >= 0.5.
; Thus, the high order bit of the mantissa is always a "one",
; and is replaced by a sign bit in internal representation.
; A "one" sign bit represents negative values.
;
; Real values are stored in 3 adjacent memory bytes:
;   Lowest address: exponent
;     Next address: least significant byte of mantissa
;  Highest address: most  significant byte of mantissa
;
; Real operands can appear in either of two 8080 internal
; register configurations. The normal position (considered
; the real accumulator) is the DE.H register, in which the
; D and E registers hold the mantissa (sign bit in D), and
; the M register holds the exponent. A second operand may
; be held in the BC.L register, where the B and C registers
; hold the mantissa, and the L register holds the exponent.
;
; Note the storage and load macros SFTS and LFTS above for
; stacking and unstacking floating values. Also note that
; "SFTS B" will disturb the A and F registers,
; while "SFTS D" will not.
;
; The SAVE and RELOAD macros above do not use the standard
; memory format, and operate only on the BC.L internal
; register group.
;
;--------------------------------
; Code for the arithmetic system proper
;--------------------------------
;
; Flating multiply by 10; (DE.H) := 10 * (DE.H)
; Carry for overflow, returns max value
; A,F,D,E,H
;
fmult:	save	bc.l		; 
	lxi	b,2000H		; 10.0
	mvi	l,84H		; 
	call	fmul		; 
	reload	fmul		; 
	rtn			; 
;
; Floating div by 10; (DE.H) := (DE.H) * 0.10000
; Carry for underflow, returns zero
; A,F,D,E,H
;
fdivt:	save	bc.l		; 
	lxi	b,4CCDH		; 0.10000
	mvi	l,80H-3		; 
	call	fmul		; 
	reload	bc.l		; 
	rtn			; 
;
; Floating multiply (DE.H) := (DE.H) * (BC.L)
; Carry for overflow or underflow, when
; maximum or zero values are returned.
; A,F,D,E,H
;
fmul:	mov	a,h		; 
	ora	a		; 
	rz			; Acc zero, return same
	mov	a,l		; 
	ora	a		; 
	jnz	fmul1		; (BC.L) not zero
	mov	h,l		; (BC.L) zero, return zero
	rtn			; 
fmul1:	mov	a,d		; 
	xra	b		; Form result sign
	push	b		; 
	push	h		; Save (BC.L)
	push	psw		; Save result sign
	call	sethi		; Set hi order operand bit
	call	imul		; Perform multiplication
	call	hlrd		; Normalize and round
	pop	psw		; 
	ani	80H		; Result sign
	ora	d		; 
	mov	d,a		; Set result sign
	mov	a,b		; Shift count
	pop	h		; Original exponents
	pop	b		; Original BC
;
; Add exponents H := H + L + A; all in offset code
; Carry for overflow, when set extremes in (DE.H)
; A,F,H (DE)
;
addx:	add	h		; 
	push	psw		; Save Carry
	add	l		; 
	mov	h,a		; Result
	jc	addx1		; One overflow required
@01	set	.lvl		; 
	pop	psw		; 
	cmc			; 
	rnc			; In range
	mvi	h,00H		; Underflow
	rtn			; 
.lvl	set	@01		; 
addx1:	pop	psw		; Had 1st Carry
	rnc			; In range
;
; Set max value for exponent overflow
; A,F,D,E,H
;
ovex:	mvi	h,0FFH		; Overflow, set max
	mov	e,h		;   and mantissa
	mov	a,d		; 
	ori	7FH		; Prserve result sign
	mov	d,a		; 
	stc			; Mark overflow
	rtn			; 
;
; Floating divide (DE.H) := (DE.H) / (BC.L)
; Carry for overflow or underflow when
; maximum or zero values are returned.
; Division by zero causes a system trap.
; A,F,D,E,H
;
fdiv:	mov	a,l		; 
	ora	a		; 
	cz	aerc		; Division by zero, fatal
	rc			; 
fdiv1:	mov	a,h		; 
	ora	a		; 
	rz			; 0/non-zero=0
	mov	a,d		; 
	xra	b		; Form result sign
	push	b		; 
	push	h		; 
	push	psw		; 
	call	sethi		; 
	call	derc		; Extend and position dividend
	mvi	l,0		; 
	mov	a,l		; 
	rar			; Last bit
	mov	h,a		; 
	call	idiv		; Returns 15 or 16 bits
	push	d		; Save quotient
	mxi	d,0		; 
	call	c2bc		; 
	mvi	a,-2		; Need 2 more bits for rounding
fdiv2:	push	psw		; Save iterations count
	dad	h		; Left shift (HLDE)
	rar			; Save Carry out
	xchg			; 
	dad	h		; 
	xchg			; 
	jnc	fdiv3		; No Carry into L
	inx	h		; 
fdiv3:	ral			; Regain Carry from H
	jc	fdiv4		; Yes, generate quotient bit
	mov	a,l		; 
	add	c		; Test for quotient bit
	mov	a,h		; 
	adc	b		; 
	jnc	fdiv5		; No bit
fdiv4:	dad	b		; Subtract
	inx	d		; Insert quotient bit
fdiv5:	pop	psw		; Get iteration count
	inr	a		; 
	jn	fdiv2		; Not done
	mov	a,e		; 
	rrc			; 
	rrc			; 
	mov	h,a		; Extend quotient
	pop	d		; Restore quotient
	call	hlrd		; Normalize and round
	inr	b		; Correct bin point
	pop	psw		; 
	ltos	h		; Original exponent
	ani	80H		; 
	ora	d		; 
	mov	d,a		; Form result sign
	mov	a,l		; 
	cma			; 
	inr	a		; Complement divisor exponent
	mov	l,b		; Shift count
	call	addx		; Form result exponent
	mov	a,h		; 
	pop	h		; Original exponent
	mov	h,a		; 
	pop	b		; 
	rtn			; With any addx Carry
;
; Floating reverse div (DE.H) := (BC.L) / (DE.H)
; Carry for overflow or underflow when
; maximum or zero values are returned.
; Division by zero causes a system trap.
; A,F,D,E,H
;
fdivr:	save	bc.l		; 
	call	fxchg		; 
	call	fdiv		; 
	reload	bc.l		; 
	rtn			; 
;
; Floating reciprocal (DE.H) := 1.0 / (DE.H)
; Division by zero (orig (DE.H) causes system trap
; A,F,D,E,H
;
frcip:	save	bc.l		; 
	movf	b,d		; 
	lxi	d,0		; 
	mvi	h,81H		; Floating 1.0
	call	fdiv		; 
	reload	bc.l		; 
	rtn			; 
;
; Align operands for add
; Returns two 24 bit values in (BC.L) and (DE.H)
; with binary points aligned. The actual binary
; point is that of the larger (on input) magnitude
; plus 1; i.e., right shifted one place. This allows
; space for overflows on addition.
; A,F,B,C,D,E,H,L
;
alin:	mov	a,h		; 
	sub	l		; 
	ora	a		; Reset any Carry
	push	psw		; Relative magnitudes
	mov	a,b		; BC.L := (BC OR 8000H) SHR 1
	ori	80H		; 
	rar			; 
	mov	b,a		; 
	mov	a,c		; 
	rar			; 
	mov	c,a		; 
	mov	a,0		; 
	rar			; 
	mov	l,a		; 
	mov	a,d		; DE := (DE OR 8000H) SHR 1
	ori	80H		; 
	rar			; 
	mov	d,a		; 
	mov	a,e		; 
	rar			; 
	mov	e,a		; 
	mov	a,0		; 
	rar			; 
	mov	h,a		; 
alin1:	pop	psw		; 
	rz			; Aligned
	jp	alin2		; DE mag > BC mag
	inr	a		; BC mag > DE mag
	push	psw		; Save rel mag
	mov	a,d		; Shift DE.H right, 0 in
	rar			; 
	mov	d,a		; 
	mov	a,e		; 
	rar			; 
	mov	e,a		; 
	mov	a,h		; 
	rar			; 
	mov	h,a		; 
	jmp	alin1		; Now test
.lvl	set	.lvl-1		; 
alin2:	dcr	a		; 
	push	psw		; 
	mov	a,b		; Shift BC.L right, 0 in
	rar			; 
	mov	b,a		; 
	mov	a,c		; 
	rar			; 
	mov	c,a		; 
	mov	a,l		; 
	rar			; 
	mov	l,a		; 
	jmp	.lvl-1		; 
.lvl	set	.lvl-1		; 
;
; Floating reverse subtract (DE.H) := (BC.L) - (DE.H)
; Carry for over/underflow, sets extreme value
; A,F,D,E,H
;
fsubr:	fsign	d		; Change D sign
;
; Floating add (DE.H) := (DE.H) + (BC.L)
; Carry for over/underflow, sets extreme value
; A,F,D,E,H
;
fadd:	mov	a,l		; 
	ora	a		; 
	rz			; BC.L = 0
	mov	a,h		; 
	ora	a		; 
	jnz	fadd2		; DE.H <> 0
fadd1:	movf	d,b		; DE.H << BC.L
	rtn			; 
fadd2:	sub	l		; 
	jc	fadd3		; BC mag > DE mag
	cpi	16+1		; 
	rnc			; BC.L << DE.H
	mov	a,h		; Will be result magnitude
	jmp	fadd4		; 
fadd3:	cpi	-16		; 
	cmc			; 
	jnc	fadd1		; DE.H << BC.L
	mov	a,l		; Will be result magnitude
fadd4:	save	bc.l		; 
	push	psw		; Save result magnitude
	mov	a,b		; 
	xra	d		; 
	mov	a,b		; 
	jp	fadd5		; Signs same
@01	set	.lvl		; 
	ana	b		; Signs different
	cp	fxchg		; DE.H neg, BC.L pos
	call	alin		; Now, DE.H pos and BC.L neg
	mov	a,h		; 
	sub	l		; 
	mov	h,a		; 
	mov	a,e		; 
	sbb	c		; Perform subtraction
	mov	e,a		; 
	mov	a,d		; 
	sbb	b		; 
	mov	d,a		; 
	push	psw		; Save result sign
	jp	fadd6		; No complement needed
	call	c1de		; 
	mov	a,h		; 
	cma			; 
	inr	a		; 
	mov	h,a		; 
	jnz	fadd6		; No propagation
	inx	d		; 
	jmp	fadd6		; Now magnitude, sign is stacked
.lvl	set	@01		; 
fadd5:	push	psw		; Result sign
	call	alin		; 
	mov	a,h		; 
	add	l		; 
	mov	h,a		; Add mantissa
	mov	a,e		; 
	adc	c		; 
	mov	e,a		; 
	mov	a,d		; 
	adc	b		; 
	mov	d,a		; 
fadd6:	xra	a		; 
	mov	l,a		; 
	ora	d		; 
	ora	e		; 
	ora	m		; 
@01 	set 	.lvl		; 
	jnz	fadd7		; Result not zero
	pop	psw		; Purge sign
	pop	psw		; Purge magnitude
	ora	a		; Reset any Carry
	jmp	fadd8		; 
.lvl	set	@01		; 
fadd7:	call	hlrd		; 
	pop	psw		; 
	ani	80H		; 
	ora	d		; 
	mov	d,a		; Set result sign
	mov	h,b		; 
	mvi	l,81H		; 
	pop	psw		; Saved result magnitude
	call	addx		; Set result magnitude
fadd8:	reload	bc.l		; 
	rtn			; With addx Carry if overflow
;
; Floating subtract (DE.H) := (DE.H) - (BC.L)
; Carry for over/underflow, sets extreme value
; A,F,D,E,H
;
fsub:	save	bc.l		; 
	fsign	b		; Change B sign
	call	fadd		; 
	reload	bc.l		; 
	rtn			; 
;
; Floating compare, set flags for (DE.H) - (BC.L)
;  Zero flag if equal
;  Plus flag if (DE.H) >= (BC.L)
; Minus falg if (DE.H) <  (BC.L)
; A,F
;
fcmp:	mov	a,l		; 
	ora	a		; 
	jnz	fcmp1		; BC.L <> zero
	mov	a,h		; 
	ora	a		; 
	rz			; Both zero
	mov	a,d		; 
	ori	l		; Set flags according to DE.H
	rtn			;   sign.
fcmp1:	mov	a,h		; 
	ora	a		; 
	jz	fcmp2		; (DE.H) = 0, flags inverse
	sub	l		;   of (BC.L) sign.
	jz	fcmp4		; Magnitude same
	mov	a,d		; 
	jp	fcmp3		; DE.H controlling magnitude
fcmp2:	mov	a,b		; BC.L controlling magnitude
	cma			; 
fcmp3:	ori	01H		; Set flags via appropriate
	rtn			;   operand sign.
fcmp4:	ora	b		; Check signs
	jm	fcmp5		; (BC.L) < 0
	ora	d		; (BC.L) > 0, check (DE.H)
	rn			; (DE.H) < 0
	mov	a,e		; Both >= 0
	sub	c		; 
	mov	a,d		; 
	sbb	b		; 
	rtn			; 
fcmp5:	mov	a,d		; 
	ori	01H		; 
	rp			; (DE.H) > 0 and (BC.L) < 0
	mov	a,c		; 
	sub	e		; Both < 0
	mov	a,b		; 
	sbb	d		; 
	rtn			; 
;
; Convert signed integer (A) to real DE.H)
; A,F,D,E,H
;
flota:	ora	a		; 
	mov	h,a		; 
	rz			; Zero
	mov	d,a		; 
	mvi	e,00H		; 
	ani	80H		; 
flot5:	push	psw		; Save sign
	mvi	h,80H		; Binary point
	mov	a,d		; 
	jp	flot2		; 
	cma			; 
	inr	a		; 
	mov	d,a		; 
	jmp	flot2		; -ve input
.lvl	set	.lvl-1		; 
;
; Convert positive integer (A) to real (DE.H)
; A,F,D,E,H
;
flotp:	ora	a		; 
	mov	h,a		; 
	rz			; Zero
	mov	d,a		; 
	xra	a		; 
	mov	e,a		; 
	jmp	flot5		; 
;
; Convert positive integer (DE) to real (DE.H)
; A,F,D,E,H
;
flotd:	xra	a		; 
	mov	h,a		; 
	jmp	flot1		; 
;
; Extract integer portion of (DE.H) in real form
; A,F,D,E,H
;
fint:	call	fixt		; Convert to integer
	cnc			; 
	rnc			; Already integer
;
; Convert signed integer (DE) to real (DE.H)
; A,F,D,E,H
;
flot:	mvi	h,00H		; 
	mov	a,d		; 
	ani	80H		; 
flot1:	push	psw		; Save sign
	cm	c2de		; Magnitude
	mov	a,d		; 
	ora	e		; 
	jz	flot3		; Zero value
	mvi	h,90H		; Binary point
flot2:	mov	a,d		; 
	ora	a		; 
	jp	flot4		; Further normalizing
	ani	7FH		; 
	mov	d,a		; 
flot3:	pop	psw		; Get sign
	ora	d		; 
	mov	d,a		; 
	rtn			; 
flot4:	xchg			; 
	dad	h		; Left sign
	xchg			; 
	dcr	h		; Adjust binary point
	jmp	flot2		; 
;
; Convert real (DE.H) to signed integer (truncate)
; (DE.H) := signed integer result, truncated.
; Carry if not 32767 >= value >= -32768, unconverted.
; A,F,D,E,H
;
fixt:	mov	a,h		; 
	ora	a		; 
	jnz	fixt2		; Non-zero
fixt1:	xra	a		; 
	mov	d,a		; Zero integer part
	mov	e,a		; 
	rtn			; 
fixt2:	jp	fixt1		; No integer part
	sui	81H		; 
	jm	fixt1		; No integer part
	sui	15		; 
	jnz	fixt3		; Magnitude < 32768
	mov	a,d		; 
	sui	80H		; 
	stc			; 
	rnz			; Not -32768
	ora	e		; 
	rz			; Exactly -32768
	stc			; 
	rtn			; Oversize
fixt3:	cnc			; 
	rc			; Oversize
	mov	h,a		; Binary point 0 for 1 to 2
	mov	a,d		; 
	push	psw		; 
	ori	80H		; 
	mov	d,a		; 
fixt4:	ora	a		; 
	call	derc		; Right shift, 0 in
	inr	h		; 
	jm	fixt4		; 
	pop	psw		; 
	ora	a		; 
	rp			; Positive
	jmp	c2de		; Insert sign
;
; Fix and round (DE.H) to signed integer in (DE)
; Return Carry if mag > 32767, without converting
; A,F,D,E,H
;
fixr:	save	bc.l		; 
	sfts	d		; Save in case of error
	lxi	b,7FFFH		; 
	mov	l,b		; 0.49999 to prevent FADD
	mov	a,d		;   roundup.
	ora	a		; 
	jp	fixr1		; (DE.H) > 0
	fsign	b		; 
fixr1:	call	fadd		; Round
	call	fixt		; Fix
@01	set	.lvl		; 
	jc	fixr2		; Overflow error
	pop	b		; Purge original argument
	pop	b		; 
	jmp	fixr3		; Restore BC.L
.lvl	set	@01		; 
fixr2:	lfts	d		; Restore argument
fixr3:	reload	bc.l		; 
	rtn			; 
;
;--------------------------------
;
	end			; of FLTARITH.ASM