;
;  FLOAT.MAC - Floating Point Functions
;
;  -FP  FLOAT+  FLOATS  FALIGN  FALIGNED  F,  FCONSTANT  FVARIABLE
;  FLITERAL  FDEPTH  FDROP  FDUP  FSWAP  FOVER  FROT  F@  F!  FABS
;  FNEGATE  D>F  F>D  F0=  F0<  F<  FMIN  FMAX  FLOOR  FROUND  F+
;  F-  F*  F/  >FLOAT  REPRESENT  PRECISION  SET-PRECISION  (FS.)
;  FS.R  FS.  (F.)  F.R  F.  (FE.)  FE.R  FE.  FSQRT  FLN  FEXP  F**
;  FSIN  FCOS  FATAN  FRANDOM  fpinit  fident  fnumber
;

;	-FP  ( -- )		marker -FP

	hdr	1,'-FP',,1
dfp:	nextt

;	FLOAT+ ( f-addr1 -- f-addr2 )	4 +

	hdr	1,'FLOAT+'
floatp:	pop	hl
	ld	de,4
	add	hl,de
	jp	hpush

;	FLOATS ( n1 -- n2 )		2* 2*

	hdr	1,'FLOATS'
floats:	call	docol
	dw	tstar,tstar
	dw	exit

;	FALIGN  ( -- )			aka noop falign immediate

	hdr	1,'FALIGN',1,,noop
falign	equ	next

;	FALIGNED ( addr -- f-addr )	aka noop faligned immediate

	hdr	1,'FALIGNED',1,,noop
falignd	equ	next

;	F,  (F: r -- ) or ( r -- )	, ,

	hdr	1,'F,',,1
fcomm:	call	docol
	dw	comma,comma
	dw	exit

;	FLITERAL  ( -- r )

	hdr	1,'FLITERAL',1,,tlite	aka fliteral 2literal immediate
flite	equ	tlite

flit	equ	tlit

;	FCONSTANT  ( -- r )

	hdr	1,'FCONSTANT',,,tcon	aka 2constant fconstant
fcon	equ	tcon

dofcon	equ	tat

;	FVARIABLE  ( -- f-addr )	aka 2variable fvariable

	hdr	1,'FVARIABLE',,,tvar
fvar	equ	tvar

;	FDEPTH   ( -- +n )	depth 2/

	hdr	1,'FDEPTH'
fdepth:	call	docol
	dw	depth
	dw	twodiv
	dw	exit

;	FDROP  ( r -- )

	hdr	1,'FDROP',,,tdrop	; aka 2drop fdrop
fdrop	equ	tdrop

;	FDUP  ( r -- r r )

	hdr	1,'FDUP',,,tdup		; aka 2dup fdup
fdup	equ	tdup

;	FSWAP  ( r1 r2 -- r2 r1 )

	hdr	1,'FSWAP',,,tswap	; aka 2swap fswap
fswap	equ	tswap

;	FOVER  ( r1 r2 -- r1 r2 r1 )

	hdr	1,'FOVER',,,tover	; aka 2over fover
fover	equ	tover

;	FROT  ( r1 r2 r3 -- r2 r3 r1 )

	hdr	1,'FROT',,,trot		; aka 2rot frot
frot	equ	trot

;	F@  ( f-addr -- r )

	hdr	1,'F@',,,tat		; aka 2@ f@
fat	equ	tat

;	F!  ( r f-addr -- )

	hdr	1,'F!',,,tstor		; aka 2! f!
fstor	equ	tstor

;	FABS  ( r1 -- r2 )

	hdr	1,'FABS'
fabss:	call	ldop
	call	fab
	jp	svop

;	FNEGATE  ( r1 -- r2 )

	hdr	1,'FNEGATE'
fneg:	call	ldop
	call	chs
	jp	svop

;	D>F  ( d -- r )

	hdr	1,'D>F'
dtof:	pop	hl
	pop	de
	push	bc
	ld	c,l
	ld	b,h
	ld	a,32		; scaling factor
	call	flt1
	jp	svop

;	F>D  ( r -- d )

	hdr	1,'F>D'
ftod:	call	ldop
	ld	e,32		; scaling factor
	call	fix
	ld	e,d
	ld	d,c
	ld	l,b
	ld	h,a
	pop	bc
	jp	dpush

;	F0=  ( r -- flag )

	hdr	1,'F0='
fze:	pop	hl
	ld	h,l
	ex	(sp),hl
	jp	zequ

;	F0<  ( r -- flag )

	hdr	1,'F0<'
fzl:	pop	hl
	pop	de
	ld	a,l
	or	a
	jp	z,false		; zero
	ld	a,h
	rla
	jp	c,true		; negative
	jp	false

;	F<  ( r1 r2 -- flag )

	hdr	1,'F<'
fles:	call	ld2op
	call	fcmp
	pop	bc
	jp	m,true
	jp	false

;	FMIN  ( r1 r2 -- r1 | r2 )  fover fover f< 0= if fswap then fdrop

	hdr	1,'FMIN'
fmin:	call	ld2op
	push	hl
	call	fcmp
	pop	hl
	call	p,lod		; r1 >= r2
	jp	svop

;	FMAX  ( r1 r2 -- r1 | r2 )  fover fover f< if fswap then fdrop

	hdr	1,'FMAX'
fmax:	call	ld2op
	push	hl
	call	fcmp
	pop	hl
	call	m,lod		; r1 < r2
	jp	svop

;	FLOOR  ( r1 -- r2 )

	hdr	1,'FLOOR'
floor:	call	ldop
	call	flr
	jp	svop

;	FROUND  ( r1 -- r2 )

	hdr	1,'FROUND'
frnd:	call	ldop
	call	rnd
	jp	svop

;	F+  ( r1 r2 -- r3 )

	hdr	1,'F+'
fadd:	call	ld2op
	call	fad
	jp	svop

;	F-  ( r1 r2 -- r3 )

	hdr	1,'F-'
fsub:	call	ld2op
	call	fsu
	jp	svop

;	F*  ( r1 r2 -- r3 )

	hdr	1,'F*'
fstar:	call	ld2op
	call	fmu
	jp	svop

;	F/  ( r1 r2 -- r3 )

	hdr	1,'F/'
fslas:	call	ld2op
	call	fdi
	jp	svop

;	>FLOAT  ( c-addr u -- r true | false )

	hdr	1,'>FLOAT'
tflt:	pop	hl
	ld	a,l		; assume u <= 255
	pop	hl
	push	bc
	call	fin
	ld	e,c
	ld	h,b
	ld	l,a
	pop	bc
	jp	c,false
	push	de
	push	hl
	jp	true

	hdr	1,'MAX-PRECISION'
mprec:	call	docco		; max precision
	db	maxsig

	hdr	x,'EXSN'
exsn:	call	docre		; exponent, sign
	ds	2*cw

;	REPRESENT  ( r c-addr n -- exp sign flag )
;				2dup max-precision max [char] 0 fill dup
;				0< if 2drop fdrop 0 0 else max-precision
;				min 2>r fdup f0< 0 exsn 2! fabs fdup f0=
;				0= if begin fdup 1.0e f< 0= while 10.0e
;				f/ 1 expsgn +! repeat begin fdup 0.1e f<
;				while 10.0e f* -1 expsgn +! repeat then
;				r@ 0 ?do 10.0e f* loop fround f>d 2dup <#
;				#s #> dup r@ - exsn +! 2r> rot min 1 max
;				cmove then d0= if 1 0 else exsn 2@ swap
;				then true

	hdr	1,'REPRESENT'
repr:	call	docol
	dw	tdup
	dw	mprec,max
	dw	clit
	db	'0'
	dw	fill
	dw	dupp,zless
	dw	zbran,repr1
	dw	tdrop,fdrop
	dw	zero,zero
	dw	bran,repr7
repr1:	dw	mprec,min
	dw	ttor
	dw	fdup,fzl
	dw	zero,exsn,tstor
	dw	fabss
	dw	fdup,fze
	dw	zequ
	dw	zbran,repr4
repr2:	dw	fdup		; begin
	dw	flit
	db	81h,0,0,0
	dw	fles,zequ
	dw	zbran,repr3	; while
	dw	ften,fslas
	dw	one,exsn,pstor
	dw	bran,repr2	; repeat
repr3:	dw	fdup		; begin
	dw	flit
	db	7dh,4ch,0cch,0cdh
	dw	fles
	dw	zbran,repr4	; while
	dw	ften,fstar
	dw	true,exsn,pstor
	dw	bran,repr3	; repeat
repr4:	dw	rat,zero
	dw	xqdo,repr6
repr5:	dw	ften,fstar
	dw	xloop,repr5
repr6:	dw	frnd,ftod
	dw	tdup
	dw	bdigs
	dw	digs
	dw	edigs
	dw	dupp
	dw	rat,subb	; handle overflow
	dw	exsn,pstor
	dw	tfrom
	dw	rot,min
	dw	one,max
	dw	cmove
repr7:	dw	dzequ
	dw	zbran,repr8
	dw	one,zero	; 0.0E fixup
	dw	bran,repr9
repr8:	dw	exsn,tat
	dw	swap
repr9:	dw	true
	dw	exit

;	PRECISION  ( -- u )

	hdr	1,'PRECISION'
prec:	call	doval
	dw	maxsig		; default

;	SET-PRECISION  ( u -- )   1 max max-precision min to precision

	hdr	1,'SET-PRECISION'
setpr:	call	docol
	dw	one,max
	dw	mprec,min
	dw	pto,prec
	dw	exit

	hdr	1,'FDP'
fdp:	call	docre		; decimal point display
	dw	-1		; set by FPINIT
	ds	2

	hdr	x,'FBUF'
fbuf:	call	docre		; fp string buffer
	ds	maxsig

	hdr	x,'EX#'
exn:	call	doval		; exponent
	ds	cw

	hdr	x,'SN#'
snn:	call	doval		; sign
	ds	cw

	hdr	x,'EF#'
efn:	call	doval		; exponent factor
	ds	cw

	hdr	x,'PL#'
pln:	call	doval		; places after decimal point
	ds	cw

;	(f1)  ( r -- r exp )
;				fdup fbuf max-precision represent 2drop

	hdr	x,'(F1)'	; get exponent
pf1:	call	docol
	dw	fdup
	dw	fbuf,mprec
	dw	repr,tdrop	; never error
	dw	exit

;	(f2)  ( exp -- offset exp' )  s>d ef# fm/mod ef# *

	hdr	x,'(F2)'	; apply exponent factor
pf2:	call	docol
	dw	stod
	dw	efn,fmmod
	dw	efn,star
	dw	exit

;	(f3)  ( r places -- c-addr u )
;                               dup to pl# 0< if precision else (f1) ef# 0>
;                               if 1- (f2) drop 1+ then pl# + max-precision
;                               min then fbuf swap represent drop to sn# to
;                               ex# fbuf max-precision -trailing <# ;

	hdr	x,'(F3)'	; float to ascii
pf3:	call	docol
	dw	dupp
	dw	pto,pln
	dw	zless
	dw	zbran,pf31
	dw	prec
	dw	bran,pf33
pf31:	dw	pf1
	dw	efn,zgrea
	dw	zbran,pf32
	dw	onem
	dw	pf2,drop
	dw	onep
pf32:	dw	pln,plus
	dw	mprec,min
pf33:	dw	fbuf,swap
	dw	repr
	dw	drop		; never error
	dw	pto,snn
	dw	pto,exn
	dw	fbuf
	dw	mprec
	dw	dtrai
	dw	bdigs
	dw	exit

;	(f4)  ( exp -- )	pl# 0< >r dup abs s>d r@ 0= if # then #s
;				2drop dup sign 0< r> d0= if [char] + hold
;				then [char] E hold

	hdr	x,'(F4)'	; insert exponent
pf4:	call	docol
	dw	pln,zless
	dw	tor
	dw	dupp
	dw	abss,stod
	dw	rat,zequ
	dw	zbran,pf41
	dw	dig
pf41:	dw	digs
	dw	tdrop
	dw	dupp,sign
	dw	zless
	dw	fromr
	dw	dzequ
	dw	zbran,pf42
	dw	clit
	db	'+'
	dw	hold
pf42:	dw	clit
	db	'E'
	dw	hold
	dw	exit

;	(f5)  ( char -- )	hold fdp cell+ on

	hdr	x,'(F5)'	; insert digit and update flag
pf5:	call	docol
	dw	hold
	dw	fdp,twop
	dw	on
	dw	exit

;	(f6)  ( c-addr u -- )	0 max begin dup while 1- 2dup + c@ (f5)
;				repeat 2drop

	hdr	x,'(F6)'	; insert string
pf6:	call	docol
	dw	zero,max
pf61:	dw	dupp
	dw	zbran,pf62
	dw	onem
	dw	tdup,plus
	dw	cat
	dw	pf5
	dw	bran,pf61
pf62:	dw	tdrop
	dw	exit

;	(f7)  ( n -- )		0 max 0 ?do [char] 0 (f5) loop

	hdr	x,'(F7)'	; insert '0's
pf7:	call	docol
	dw	zero,max
	dw	zero
	dw	xqdo,pf72
pf71:	dw	clit
	db	'0'
	dw	pf5
	dw	xloop,pf71
pf72:	dw	exit

;	(f8)  ( -- )		sn# sign 0 0 #>

	hdr	x,'(F8)'	; insert sign
pf8:	call	docol
	dw	snn,sign
	dw	zero,zero
	dw	edigs
	dw	exit

;	(f9)  ( c-addr u1 -- c-addr u2 )
;				pl# 0< if begin dup while 1- 2dup
;				+ c@ [char] 0 - until 1+ then then

	hdr	x,'(F9)'	; trim trailing '0's
pf9:	call	docol
	dw	pln,zless
	dw	zbran,pf92
pf91:	dw	dupp
	dw	zbran,pf92
	dw	onem,tdup
	dw	plus,cat
	dw	clit
	db	'0'
	dw	subb
	dw	zbran,pf91
	dw	onep
pf92:	dw	exit

;	(fa)  ( u1 -- u1 u2 )	pl# 0< if dup else pl# then

	hdr	x,'(FA)'
pfaa:	call	docol
	dw	pln,zless
	dw	zbran,pfaa1
	dw	dupp
	dw	bran,pfaa2
pfaa1:	dw	pln
pfaa2:	dw	exit

;	(fb)  ( c-addr u n -- )  fdp cell+ off >r (f9) r@ + (fa) over -
;				(f7) (fa) min r@ - (f6) r> (fa) min (f7)
;				fdp 2@ or if [char] . hold then

	hdr	x,'(FB)'	; insert fraction n places right of dec. pt
pfbb:	call	docol
	dw	fdp,twop
	dw	off
	dw	tor
	dw	pf9
	dw	rat,plus
	dw	pfaa
	dw	over,subb
	dw	pf7
	dw	pfaa,min
	dw	rat,subb
	dw	pf6
	dw	fromr
	dw	pfaa,min
	dw	pf7
	dw	fdp,tat,orr
	dw	zbran,pfbb1
	dw	clit
	db	'.'
	dw	hold
pfbb1:	dw	exit

;	(fc)  ( c-addr u n -- )
;				>r 2dup r@ min 2swap r> /string 0 (fb) (f6)

	hdr	x,'(FC)'	; split into int/frac and insert
pfcc:	call	docol
	dw	tor
	dw	tdup
	dw	rat,min
	dw	tswap
	dw	fromr,sstr
	dw	zero,pfbb
	dw	pf6
	dw	exit

;	(fd)  ( r n factor -- c-addr u )
;				to ef# (f3) ex# 1- (f2) (f4) 1+ (fc) (f8)

	hdr	x,'(FD)'	; exponent form
pfdd:	call	docol
	dw	pto,efn
	dw	pf3
	dw	exn,onem
	dw	pf2
	dw	pf4
	dw	onep,pfcc
	dw	pf8
	dw	exit

;	(FS.)  ( r n -- c-addr u )  1 (fd)

	hdr	1,'(FS.)'
pfsd:	ld	hl,1
	push	hl
	jp	pfdd

;	FS.R  ( r n u -- )
;				>r (fs.) r> over - swap spaces type

	hdr	1,'FS.R'
fsdr:	call	docol
	dw	tor
	dw	pfsd
	dw	bran,ddotr1

;	FS.  ( r -- )		-1 0 fs.r space

	hdr	1,'FS.'
fsdot:	call	docol
	dw	true
	dw	zero,fsdr
	dw	space
	dw	exit

	 if	fpeng

;	(FE.)  ( r -- c-addr u )  3 (fd)

	hdr	1,'(FE.)'
pfse:	ld	hl,3
	push	hl
	jp	pfdd

;	FE.R  ( r n u -- )	>r (fe.) r> over - swap spaces type

	hdr	1,'FE.R'
fedr:	call	docol
	dw	tor
	dw	pfse
	dw	bran,ddotr1

;	FE.  ( r -- )		-1 0 fe.r space

	hdr	1,'FE.'
fedot:	call	docol
	dw	true
	dw	zero,fedr
	dw	space
	dw	exit

	 endif

;	(F.)  ( r n -- c-addr u )
;				0 to ef# (f3) ex# dup max-precision > if
;				fbuf 0 0 (fb) max-precision - (f7) (f6)
;				else dup 0> if (fc) else abs (fb) 1 (f7)
;				then then (f8)

	hdr	1,'(F.)'
pfd:	call	docol
	dw	zero
	dw	pto,efn
	dw	pf3
	dw	exn,dupp
	dw	mprec,great
	dw	zbran,pfd1	; if
	dw	fbuf,zero
	dw	zero,pfbb
	dw	mprec,subb
	dw	pf7
	dw	pf6
	dw	bran,pfd3	; else
pfd1:	dw	dupp,zgrea
	dw	zbran,pfd2
	dw	pfcc
	dw	bran,pfd3	; else
pfd2:	dw	abss
	dw	pfbb
	dw	one,pf7
pfd3:	dw	pf8		; then then
	dw	exit

;	F.R  ( r n u -- )
;				>r (f.) r> over - spaces type

	hdr	1,'F.R'
fdotr:	call	docol
	dw	tor
	dw	pfd
	dw	bran,ddotr1

;	F.  ( r -- )		-1 0 f.r space

	hdr	1,'F.'
fdot:	call	docol
	dw	true
	dw	zero,fdotr
	dw	space
	dw	exit

;	(G.)  ( r n -- c-addr u )
;				>r (f1) -3 7 within  r> swap if (f.) else
;				(fs.) then

	hdr	1,'(G.)'
pgd:	call	docol
	dw	tor
	dw	pf1
	dw	lit,-3
	dw	clit
	db	7
	dw	within
	dw	fromr,swap
	dw	zbran,pgd1	; if
	dw	pfd
	dw	bran,pgd2	; else
pgd1:	dw	pfsd
pgd2:	dw	exit		; then

;	G.R  ( r n u -- )
;				>r (g.) r> over - spaces type

	hdr	1,'G.R'
gdotr:	call	docol
	dw	tor,pgd
	dw	bran,ddotr1

;	G.  ( r -- )		-1 0 g.r space

	hdr	1,'G.'
gdot:	call	docol
	dw	true
	dw	zero,gdotr
	dw	space
	dw	exit

;	FSQRT  ( r1 -- r2 )

	hdr	1,'FSQRT'
fsqr:	call	ldop
	call	sqr
	jp	svop

;	FLN  ( r1 -- r2 )

	hdr	1,'FLN'
ffln:	call	ldop
	call	log
	jp	svop

;	FEXP  ( r1 -- r2 )

	hdr	1,'FEXP'
fexp:	call	ldop
	call	exp
	jp	svop

;	F**  ( r1 r2 -- r3 )	fswap fln f* fexp

	hdr	1,'F**'
ftst:	call	docol
	dw	fswap,ffln
	dw	fstar,fexp
	dw	exit

;	FSIN  ( r1 -- r2 )

	hdr	1,'FSIN'
fsin:	call	ldop
	call	sin
	jp	svop

;	FCOS  ( r1 -- r2 )

	hdr	1,'FCOS'
fcos:	call	ldop
	call	cos
	jp	svop

;	FATAN  ( r1 -- r2 )

	hdr	1,'FATAN'
fatan:	call	ldop
	call	atan
	jp	svop

;	PI  ( -- r )

	hdr	1,'PI'
fpi:	call	dofcon
	db	82h,49h,0fh,0dbh	; pi

;	FRANDOM  ( r1 -- r2 )

	hdr	1,'FRANDOM'
rand:	call	ldop
	jp	m,rand1		; seed generator
	push	af
	ld	hl,rand4
	call	lod
	ld	e,a
	pop	af
	ld	a,e
	jp	z,svop		; return last value
	ld	hl,rand2	; get next value
	call	fmu
	ld	hl,rand3
	call	fad
rand1:	ld	hl,acc3
	ld	b,(hl)		; swap msb lsb
	dec	hl
	ld	c,(hl)
	dec	hl
	ld	d,(hl)
	dec	hl
	ld	(hl),80h	; make positive
	dec	hl
	ld	e,(hl)
	ld	(hl),80h	; fix exponent
	call	fad6		; normalise
	ld	hl,rand4
	call	str
	jp	svop

rand2:	db	98h,35h,44h,7ah
rand3:	db	68h,28h,0b1h,46h
rand4:	db	80h,31h,41h,59h		; seed

	cseg

; pop float from stack to accum, saving bc

ldop:	pop	de
	pop	hl
	ld	(f1),hl
	pop	hl
	ld	(f1+2),hl
	push	bc
	push	de
	ld	hl,f1
	jp	lod

; pop 2 float from stack to hl (f2) and accum, saving bc

ld2op:	pop	hl
	ld	(ld2op1),hl
	pop	hl
	ld	(f2),hl
	pop	hl
	ld	(f2+2),hl
	call	ldop
	ld	hl,(ld2op1)
	push	hl
	ld	hl,f2
	ret

ld2op1:	ds	2

; push float registers to stack, restore bc and exit

svop:	ld	l,a
	ld	h,b
	ld	e,c
	pop	bc
	jp	dpush

;
; str	store registers to accum
;

strr:	ld	hl,acce
	ld	(hl),e
	inc	hl

; entry - hl=adr, a=exp, bcd (packed)
; exit  - none

str:	ld	(hl),a
str1:	inc	hl		; entry when hl=accs
	ld	(hl),b
	inc	hl
	ld	(hl),c
	inc	hl
	ld	(hl),d
	ret

;
; zero - set accum and regs to zero
;
; entry - none
; exit  - none

zro:	xor	a
	ld	(acce),a
	ld	b,a
	ld	c,a
	ld	d,a
	ret

; overflow - set regs to maximum, set cy

ovf:	ld	bc,7fffh
	ld	a,c
	ld	d,c
	scf
	ret

;
; chs	change sign of accumulator
;
; entry - none
; exit  - bcd (packed), a=exp, flags set

chs:	ld	a,80h
	jp	fab1

;
; change sign of accumulator and again on result
; (when calling routine completes)

chss:	call	chs
	ld	hl,chs
	ex	(sp),hl
	jp	(hl)

;
; fab	set acc to absolute
;
; entry - none
; exit  - bcd (packed), a=exp, flags set

fab:	xor	a
fab1:	ld	hl,accs
	and	(hl)
	xor	80h
	ld	(hl),a		; fall thru tst

;
; tst	load registers from acc and test
;
; exit  - bcd (packed), a=exp, flags set

tst:	ld	hl,acce
	ld	a,(hl)
	and	a
	jp	z,zro
	ld	e,a		; e exp
	inc	hl
	ld	a,(hl)		; accs
	inc	hl
	xor	(hl)		; pack msb with sign
	inc	hl
	ld	c,(hl)
	inc	hl
	ld	d,(hl)
	jp	fad8

;
; lod	load float (hl) to accum and regs, set flags
;
; entry - hl=adr
; exit  - bcd (packed), a=exp, flags set

lod:	ld	a,(hl)
	and	a
	jp	z,zro
	ld	e,a
	inc	hl
	ld	a,(hl)
	inc	hl
	ld	c,(hl)
	inc	hl
	ld	d,(hl)
	ld	l,a
	or	80h
	ld	b,a
	xor	l
	call	strr
	xor	b
	jp	fad8

;
; tstr	test registers and set flags; Z if zero, M if minus
;

tstr:	ld	e,a
tstr1:	or	a
	ret	z
tstr2:	ld	a,b
tstr3:	or	1
	ld	a,e
	ret

;
; fcmp	compare registers with (hl), return M if regs < (hl)
;

fcmp:	ld	e,a
	ld	a,(hl)
	or	a
	ld	a,e
	jp	z,tstr1		; hl zero, test sign regs
	or	a
	inc	hl
	ld	a,(hl)
	cpl
	jp	z,tstr3		; regs zero, test sign hl
	xor	b
	jp	p,tstr2		; signs differ
	call	fcmp1
	rra
	xor	b		; complement sign for neg values
	ld	a,e
	ret

fcmp1:	dec	hl
	ld	a,e
	cp	(hl)
	ret	nz
	inc	hl
	ld	a,b
	cp	(hl)
	ret	nz
	inc	hl
	ld	a,c
	cp	(hl)
	ret	nz
	inc	hl
	ld	a,d
	cp	(hl)
	ret	nz
	pop	hl
	ld	a,e
	ret

;
; fsu	floating point subtract subroutine
;

fsu:	ld	a,80h		; mask to change operand sign
	jp	fad1

;
; fad	floating point add subroutine
;

fad:	xor	a
fad1:	ld	e,(hl)		; load operand to abcd
	inc	hl
	xor	(hl)
	ld	b,a
	inc	hl
	ld	c,(hl)
	inc	hl
	ld	d,(hl)
	ld	a,e
	and	a
	jp	z,tst		; operand zero

	ld	l,b		; unpack
	ld	a,b
	or	80h
	ld	b,a
	xor	l		; generate subtraction flag
	ld	hl,accs
	xor	(hl)
	ld	(sf),a

; determine relative magnitudes of operand and accum

	dec	hl		; acce
	ld	a,(hl)
	and	a
	jp	z,fad9		; accum zero

	sub	e		; get difference of exponents
	jp	c,fad2		; accum smaller

; check for insignificant operand

	jp	m,tst
	cp	25		; compare shift count to 25
	jp	c,fad3
	jp	tst

; check for insignificant accum, exchange accum and operand

fad2:	jp	p,fad9
	cp	0-25		; compare shift count to -25
	jp	c,fad9

	ld	(hl),e		; set acce

	ld	e,a		; save shift count

	ld	a,(sf)		; set accum sign
	inc	hl		; accs
	xor	(hl)
	ld	(hl),a

	xor	a		; complement shift count
	sub	e

	inc	hl		; exchange fraction
	ld	e,(hl)
	ld	(hl),b
	ld	b,e
	inc	hl
	ld	e,(hl)
	ld	(hl),c
	ld	c,e
	inc	hl
	ld	e,(hl)
	ld	(hl),d
	ld	d,e

; position the operand, check if add or subtract

fad3:	call	shr
	ld	hl,acc3
	ld	a,(sf)
	and	a
	jp	m,fad4

	ld	a,(hl)		; add
	add	a,d
	ld	d,a
	dec	hl
	ld	a,(hl)
	adc	a,c
	ld	c,a
	dec	hl
	ld	a,(hl)
	adc	a,b
	ld	b,a
	jp	nc,fad7

	rra			; got carry, so rshift fraction
	ld	b,a
	ld	a,c
	rra
	ld	c,a
	ld	a,d
	rra
	ld	d,a
	rra
	ld	e,a
	ld	hl,acce		; and adjust exponent
	ld	a,(hl)
	add	a,1
	ld	(hl),a
	jp	c,ovf		; overflow
	jp	fad7

fad4:	xor	a		; subtract
	sub	e
	ld	e,a
	ld	a,(hl)
	sbc	a,d
	ld	d,a
	dec	hl
	ld	a,(hl)
	sbc	a,c
	ld	c,a
	dec	hl
	ld	a,(hl)
	sbc	a,b
	ld	b,a

fad5:	call	c,fcpl		; got carry, so complement

fad6:	ld	a,b		; normalise if necessary
	and	a
	call	p,norm
	jp	p,zro		; underflow or zero

fad7:	call	rondr		; round bcde
	jp	c,ovf

; entry - acd (packed), e=exp
; exit  - bcd (packed), a=exp, flags set

fad8:	ld	b,a
	or	1		; test sign, clear Z C flags
	ld	a,e
	ret

; accum insignificant, so load the accum with the operand

fad9:	ld	a,(sf)
	ld	hl,accs
	xor	(hl)
	call	strr
	xor	b
	jp	fad8

;
; read the operand at (hl), check the accum exponent
;

mdex:	ld	b,a
	inc	hl
	ld	c,(hl)
	inc	hl
	ld	d,(hl)
	inc	hl
	ld	e,(hl)

	ld	hl,acce		; accum exp
	ld	a,(hl)
	and	a
	ret	z		; is zero

	add	a,b		; result exp plus bias
	ld	b,a
	rra			; carry to sign
	xor	b		; carry and sign must differ
	ld	a,b		; result exp plus bias
	ld	b,80h		; exp bias, sign mask, most sig bit
	jp	p,mdex1		; if over or underflow
	sub	b		; remove excess exp bias
	ret	z		; return if underflow
	ld	(hl),a		; result exp
	inc	hl		; address accum sign
	ld	a,(hl)
	xor	c		; result sign in sign bit
	and	b		; result sign
	ld	(hl),a		; store it
	ld	a,c		; operand sign and 1st fraction
	or	b		; operand first fraction
	ret

mdex1:	rlca			; set carry bit if overflow
	ret	c
	xor	a		; clear a register
	ret			; return if underflow

;
; fmu	floating point multiplication subroutine
;

fmu:	ld	a,(hl)		; operand exponent
	and	a
	push	hl
	call	nz,mdex		; read operand
	pop	hl
	jp	z,zro		; zero or underflow
	jp	c,ovf		; overflow
	call	mulx		; fixed mult
	ld	a,b		; normalize if necessary
	and	a
	jp	m,fad7

	ld	hl,acce		; dec accum exp
	dec	(hl)
	ret	z		; underflow
	call	shl
	jp	fad7

; fixed point multiply subroutine

mulx:	ld	hl,mulx4
	ld	(hl),e		; 3rd multiplicand
	inc	hl
	ld	(hl),d		; 2nd multiplicand
	inc	hl
	ld	(hl),a		; 1st multiplicand

	xor	a		; clear 6th product
	ld	e,a		; clear 5th product
	ld	d,a		; clear 4th product

; multiply  by each accumulator fraction in turn

	ld	hl,acc3
	call	mulx2		; multiply by accum 3rd fraction
	ld	hl,acc2
	call	mulx1		; multiply by accum 2nd fraction
	ld	hl,acc1

; multiply by one accumulator byte

mulx1:	ld	a,d		; 5th partial product
	ld	e,c		; 4th partial prod
	ld	d,b		; 3rd partial prod
mulx2:	ld	b,(hl)		; multiplier
	ld	l,a		; 5th partial prod
	xor	a		; zero a register
	ld	c,a		; 2nd partial prod
	sub	b		; set carry bit for exit flag
	jp	c,mulx3		; if multiplier is not zero
	ld	c,d		; 2nd partial product
	ld	d,e		; 3rd partial prod
	ret

; loop for each bit of multiplier byte

mulx3:	ld	a,l		; 5th partial product, exit flag
	adc	a,a		; shift exit flag out if done
	ret	z		; exit if multiplication done
	ld	l,a		; 5th partial prod, exit flag
	ld	a,e		; 4th partial prod
	rla			; shift 4th partial prod
	ld	e,a		; 4th partial prod
	ld	a,d		; 3rd partial prod
	rla
	ld	d,a
	ld	a,c		; 2nd partial prod
	rla
	ld	c,a
	ld	a,b		; 1st partial prod and multiplier
	rla
	ld	b,a
	jp	nc,mulx3	; if no addition required

; add the multiplicand to the product if the multiplier bit is one

	ld	a,(mulx4)	; operand 3rd fraction
	add	a,e
	ld	e,a		; 4th partial prod
	ld	a,(mulx4+1)	; operand 2nd fraction
	adc	a,d
	ld	d,a		; 3rd partial prod
	ld	a,(mulx4+2)	; operand 1st fraction
	adc	a,c
	ld	c,a		; 2nd partial prod
	jp	nc,mulx3	; if no carry to 1st prod
	inc	b		; add carry to 1st prod
	and	a		; clear carry bit
	jp	mulx3

mulx4:	ds	3

;
; fdi	floating point division subroutine
;

fdi:	xor	a
	sub	(hl)		; complement of divisor exponent
	cp	1		; set carry if division by zero
	push	hl
	call	nc,mdex		; read operand if not zero
	pop	hl
	jp	c,ovf		; overflow or division by zero
	jp	z,zro		; underflow or zero
	ld	c,a
	call	divx		; fixed division
	jp	nc,ovf
	jp	fad7

; fixed point divide subroutine

; subtract divisor from accum to obtain 1st remainder

divx:	ld	hl,acc3
	ld	a,(hl)		; accum 3rd fraction
	sub	e
	ld	(hl),a
	dec	hl
	ld	a,(hl)		; accum 2nd fraction
	sbc	a,d
	ld	(hl),a
	dec	hl
	ld	a,(hl)		; accum 1st fraction
	sbc	a,c
	ld	(hl),a

; halve the divisor and store for addition or subtraction

	ld	a,c		; get carry bit
	rla
	ld	a,c		; divisor 1st fraction
	rra
	ld	(divx4+3),a
	ld	a,d		; divisor 2nd fraction
	rra
	ld	(divx4+2),a
	ld	a,e		; divisor 3rd fraction
	rra
	ld	(divx4+1),a	; 3rd subtract divisor
	ld	b,0		; init quot 1st fraction
	ld	a,b		; divisor 4th fraction is zero
	rra
	ld	(divx4),a	; 4th subtract divisor

; load 1st remainder

	ld	a,(hl)		; 1st fraction
	inc	hl
	ld	d,(hl)		; 2nd fraction
	inc	hl
	ld	e,(hl)		; 3rd fraction

; position remainder, initialise quotient, check sign

	ex	de,hl		; remainder 3rd fraction
				; remainder 2nd fraction
	ld	e,a		; remainder 1st fraction
	ld	c,b		; init quot 2nd fraction
	ld	d,b		; init quot 3rd fraction
	and	a
	jp	m,divx3		; if remainder is negative

; adjust exponent

	ld	a,(acce)	; increment quotient exp
	inc	a
	ret	z		; overflow
	ld	(acce),a

	inc	d		; init quot 3rd fraction

; subtract the divisor if remainder positive

divx1:	push	bc
	ld	c,l
	ld	b,h
	xor	a		; 4th fraction is zero
	ld	hl,divx4
	sub	(hl)
	ld	a,c		; 3rd fraction
	inc	hl
	sbc	a,(hl)
	ld	c,a
	ld	a,b		; 2nd fraction
	inc	hl
	sbc	a,(hl)
	ld	b,a
	ld	a,e		; 1st fraction
	inc	hl
	sbc	a,(hl)
	ld	e,a
	ld	l,c
	ld	h,b
divx2:	pop	bc

	ld	a,(divx4)	; remainder 4th fraction
	rlca			; shift remainder 4th fraction to carry

; shift the remainder left one bit

	ld	a,b
	rla
	ret	c		; division complete
	rra			; shift BCDEHL
	ld	a,l
	rla
	ld	l,a
	ld	a,h
	rla
	ld	h,a
	call	shl

; branch if subtraction is required

	ld	a,d		; quotient 3rd fraction
	rrca			; remainder sign indic to carry bit
	jp	c,divx1		; to sub divisor if remainder positive

; add the divisor if the remainder is negative

divx3:	push	bc
	ld	bc,divx4+1
	ld	a,(bc)		; 3rd fraction
	add	a,l
	ld	l,a
	inc	bc
	ld	a,(bc)		; 2nd fraction
	adc	a,h
	ld	h,a
	inc	bc
	ld	a,(bc)		; 1st fraction
	adc	a,e
	ld	e,a
	jp	divx2

divx4:	ds	4

;
; left shift bcde one bit
;
; entry - bcde
; exit  - bcde

shl:	ld	a,e
	rla
	ld	e,a
	ld	a,d
	rla
	ld	d,a
	ld	a,c
	rla
	ld	c,a
	ld	a,b
	adc	a,a
	ld	b,a
	ret

;
; right shift bcd by a bits
;
; entry - bcd, a=shift count
; exit  - bcde

shr:	ld	e,0
	ld	l,8		; shift 8 bits by moving registers
shr1:	cp	l
	jp	m,shr2		; less than 8
	ld	e,d
	ld	d,c
	ld	c,b
	ld	b,0
	sub	l
	jp	nz,shr1
shr2:	and	a
	ret	z		; done
	ld	l,a
shr3:	and	a		; clear carry
	ld	a,b
	rra
	ld	b,a
	ld	a,c
	rra
	ld	c,a
	ld	a,d
	rra
	ld	d,a
	ld	a,e
	rra
	ld	e,a
	dec	l
	jp	nz,shr3
	ret

;
; Complement bcde adjust accs, return sign flag
;

fcpl:	ld	hl,accs		; change accum sign
	ld	a,(hl)
	xor	80h
	ld	(hl),a
	xor	a		; complement fraction
	ld	l,a
	sub	e
	ld	e,a
	ld	a,l
	sbc	a,d
	ld	d,a
	ld	a,l
	sbc	a,c
	ld	c,a
	ld	a,l
	sbc	a,b
	ld	b,a
	ret

;
; Normalize bcde registers, adjust acce
;
; entry - bcde
; exit  - bcde, z= bcde=0 or acce=0

norm:	ld	l,32		; max shift
norm1:	ld	a,b
	and	a
	jp	nz,norm3
	ld	b,c
	ld	c,d
	ld	d,e
	ld	e,a
	ld	a,l
	sub	8
	ld	l,a
	jp	nz,norm1
	ret			; bcde = zero

norm2:	dec	l		; shl until bit 31 set
	call	shl
norm3:	jp	p,norm2

	ld	a,l		; adjust accum exp
	sub	32
	ld	hl,acce
	add	a,(hl)
	ld	(hl),a
	ret	z		; if zero exp
	rra			; move borrow bit to sign
	and	a		; set sign to indicate underflow
	ret

;
; Round the bcde registers, save to acc
;
; entry - bcde
; exit  - bcd, a=packed msb, e=exp, cy=ovf

rondr:	ld	a,e		; lsb
	and	a		; test sign and clear cy
	ld	hl,acce		; exp
	ld	e,(hl)
	call	m,rondr1
	ret	c		; rounder overflow
	ld	a,b
	inc	hl		; accs
	xor	(hl)		; a=packed msb
	jp	str1		; save bcd to acc

; round up bcd e=exp, cy=ovf

rondr1:	inc	d
	ret	nz
	inc	c
	ret	nz
	inc	b
	ret	nz
	ld	b,80h		; new 1st fraction
	ld	a,e		; inc exp
	add	a,1		; adjust cy
	ld	e,a
	ld	(acce),a	; new acc exp
	ret

;
; flt	convert 32 bit signed integer to float
;
; entry - abcd (int), e=scaling

flt:	ld	l,e
	ld	e,d
	ld	d,c
	ld	c,b
	ld	b,a
	ld	a,l
flt1:	xor	80h		; apply exponent bias
	ld	hl,acce
	ld	(hl),a
	inc	hl
	ld	(hl),80h	; assume positive accum sign
	ld	a,b		; set cy if integer negative
	and	a
	rla
	jp	fad5		; complete the conversion

;
; fix	convert float in acc to 32 bit integer
;
; entry - e=scaling
; exit  - abcd (int)

fix:	ld	hl,acce
	ld	a,(hl)
	and	a
	jp	z,zro		; zero
	ld	a,e
	add	a,80h-1		; add bias-1
	sub	(hl)		; shift count -1
	ret	c		; accum too large
	cp	31		; compare to large shift
	jp	nc,zro		; accum too small
	add	a,1		; shift count
	ld	hl,acc1
	ld	b,(hl)
	inc	hl
	ld	c,(hl)
	inc	hl
	ld	d,(hl)
	call	shr		; position the fraction
	ld	a,(accs)	; complement if negative
	and	a
	call	p,fcpl
	ld	a,1		; set flags
	or	b
	ld	a,b
	ld	b,c
	ld	c,d
	ld	d,e
	ret

;
; Round accum to integer
;

rnd:	call	tstr
	call	m,chss
	cp	98h
	ret	nc		; no fraction
	ld	hl,ffiv		; 0.5
	call	fad
	jp	flr1

;
; Floor accum to integer
;
; entry - abcd
; exit  - abcd e=signed integer

flr:	ld	e,d
	cp	98h
	ret	nc		; no fraction
flr1:	ld	e,a
	ld	a,80h		; unpack b
	or	b
	ld	b,a
	ld	a,(accs)
	rla
	push	af
	jp	c,flr3		; positive
	ld	a,d		; decr bcd
	or	a
	jp	nz,flr2
	dec	bc
flr2:	dec	d
flr3:	ld	a,98h
	sub	e
	call	shr
	pop	af
	call	nc,rondr1	; incr bcd
	ld	a,98h
	ld	(acce),a
	ld	a,d
	jp	c,flr4
	cpl
	inc	a
flr4:	push	af
	ld	e,0
	call	fad6		; normalise and pack
	pop	hl
	ld	e,h
	ret

;

finstr:	ds	3	; string addr, count
finsgn:	ds	1	; sign
finpt:	ds	1	; decimal point flag
finexp:	ds	1	; decimal exponent
fincvt:	ds	1	; converted digits

; fin	convert character string to float
; entry - hl=adr, a=len
; exit  - result in accum, cy=error

fin:	dec	hl		; init string adr, count
	ld	(finstr),hl
	inc	a
	ld	(finstr+2),a

	ld	a,80h		; set sign positive
	ld	(finsgn),a
	xor	a
	ld	(finpt),a	; clear decimal point flag
	ld	(finexp),a	; set decimal exponent = 0
	ld	(fincvt),a	; zero converted digits
	ld	(acce),a	; zero accum

	call	fin17		; get 1st char
	jp	z,fin14		; treat zero length as zero blanks

	cp	' '
	jp	nz,fin2
fin1:	call	fin17		; treat all blanks as zero
	jp	z,fin14
	cp	' '
	jp	z,fin1
	scf
	ret

fin2:	cp	'+'		; check for sign
	jp	z,fin3
	cp	'-'
	jp	nz,fin4
	xor	a		; set negative flag
	ld	(finsgn),a
fin3:	call	fin17		; get char after sign
	scf
	ret	z		; none

fin4:	cp	'.'		; check for decimal point
	jp	nz,fin7
	ld	hl,finpt
	xor	(hl)
	ld	(hl),a
	jp	nz,fin8
fin5:	scf			; 2nd decimal point
	ret

fin6:	ld	a,(fincvt)
	or	a
	jp	z,fin5
	jp	fin14

; process char

fin7:	call	fin18		; convert char to digit
	ret	c		; bad

	ld	hl,fincvt
	inc	(hl)
	push	af
	ld	hl,ften1	; mult old value by 10
	call	fmu
	call	savf1
	pop	af		; convert digit to floating point
	ld	bc,0000h
	ld	de,0008h	; e=8
	call	flt
	ld	hl,f1		; add to old value
	call	fad

	ld	a,(finpt)	; if decimal point
	and	a
	jp	z,fin8
	ld	hl,finexp	; decrement exponent
	dec	(hl)

; get next char

fin8:	ld	b,0		; zero exponent
	call	fin17
	jp	z,fin6		; done

; check for exponent

	cp	'+'
	jp	z,fin10
	cp	'-'
	jp	z,fin10
	call	upc
	cp	'E'
;	jp	z,fin9
;	cp	'D'
	jp	nz,fin4

; process exponent

fin9:	call	fin17		; next char
	jp	z,fin6		; done

fin10:	ld	b,a		; save 1st char
	sub	'-'		; compare minus sign
	ld	e,a
	jp	z,fin11
	add	a,'-'-'+'	; compare plus sign
	ld	a,b
	jp	nz,fin12

fin11:	call	fin17		; got sign, get 1st digit

fin12:	ld	b,0		; possible decimal exponent
	jp	z,fin6		; none - assume zero exponent

fin13:	call	fin18
	ret	c		; not digit
	ld	c,a		; accumulate exponent
	ld	a,b
	add	a,a
	add	a,a
	add	a,b
	add	a,a
	add	a,c
	ld	b,a
	call	fin17		; get next
	jp	nz,fin13

	ld	a,e		; test exponent sign
	and	a
	jp	nz,fin14
	sub	b		; complement if neg
	ld	b,a

fin14:	ld	a,(finsgn)	; store accum sign
	ld	(accs),a

; adjust exponent

	ld	a,b
fin15:	ld	hl,finexp
	add	a,(hl)
	jp	z,tst		; done
	ld	(hl),a
	ld	hl,ften1
	jp	p,fin16
	call	fdi		; div by 10
	ld	a,1
	jp	fin15

fin16:	call	fmu		; mul by 10
	ret	c		; overflow
	ld	a,0ffh
	jp	fin15

; get next char, return z if end reached

fin17:	ld	hl,finstr+2
	dec	(hl)
	ld	hl,(finstr)
	inc	hl
	ld	(finstr),hl
	ld	a,(hl)
	ret

; convert ascii char (a) to digit, return cy if not in range 0-9

fin18:	sub	'0'
	ret	c
	cp	10
	ccf
	ret

;	sqr

sqr:	call	tstr
	ret	z		; zero
	jp	m,ovf		; neg
	call	savf1
	and	a
	rra
	add	a,40h
	call	savf2
	ld	d,5
sqr1:	push	de
	call	lodf1
	ld	hl,f2
	call	fdi
	ld	hl,f2
	call	fad
	sub	1
	call	savf2
	pop	de
	dec	d
	jp	nz,sqr1
	ld	hl,f2
	jp	lod

;	exp

exp:	ld	hl,ln2
	call	fdi
	cp	88h
	jp	nc,ovf
	cp	68h
	ld	hl,fone
	jp	c,lod
	call	savf2
	call	flr
	call	savf1
	ld	a,e
	add	a,81h
	jp	z,exp1
	push	af
	call	lodf2
	ld	hl,f1
	call	fsu
	ld	hl,exp2
	call	poly
	pop	af
	ld	bc,0
	ld	d,b
	call	savf1
	ld	hl,f1
	jp	fmu

exp1:	call	tst
	jp	m,zro
	jp	ovf

exp2:	db	7
	db	74h,59h,88h,7ch
	db	77h,26h,97h,0e0h
	db	7ah,1eh,1dh,0c4h
	db	7ch,63h,50h,5eh
	db	7eh,75h,0feh,1ah
ln2:	db	80h,31h,72h,18h		; ln2
fone:	db	81h,0,0,0		; 1.0

;	log

log:	call	tstr
	jp	m,ovf		; neg
	jp	z,ovf		; zero
	xor	80h
	push	af
	ld	a,80h
	ld	hl,log1
	call	poly
	call	savf1
	pop	af
	ld	d,a
	rla
	sbc	a,a
	ld	c,a
	ld	b,a
	ld	e,32
	call	flt
	ld	hl,f1
	call	fad
	ld	hl,ln2
	jp	fmu

log1:	db	9
	db	82h,94h,0eeh,0d8h
	db	84h,7dh,0aah,0a9h
	db	86h,0bfh,99h,7dh
	db	87h,28h,0e5h,7bh
	db	87h,0c0h,71h,8ah
	db	87h,14h,95h,6eh
	db	86h,0a0h,1eh,0b2h
	db	85h,02h,7ah,0adh
	db	83h,8dh,9dh,09h

;	sin / cos

cos:	ld	hl,fpi2
	call	fad
sin:	or	a
	ret	z
	cp	99h
	jp	nc,ovf
	ld	hl,f2pi
	call	fdi
	call	savf1
	call	flr
	or	a
	push	af
	ld	hl,f2
	call	nz,str
	call	lodf1
	pop	af
	ld	hl,f2
	call	nz,fsu
	ld	hl,sin2
	call	fsu
	push	af
	jp	m,sin1
	ld	hl,ffiv
	call	fsu
	call	p,chs
sin1:	ld	hl,sin2
	call	fad
	ld	e,a
	pop	af
	ld	a,e
	call	p,chs
	ld	hl,sin3
	jp	polx

sin2:	db	7fh,0,0,0		; 0.25

sin3:	db	5
	db	86h,1eh,0d7h,0fbh
	db	87h,99h,26h,64h
	db	87h,23h,34h,58h
	db	86h,0a5h,5dh,0e1h
f2pi:	db	83h,49h,0fh,0dbh	; 2pi

fpi2:	db	81h,49h,0fh,0dbh	; pi/2

;	atan

atan:	call	tstr
	call	m,chss		; make positive
	cp	81h
	jp	c,atan1		; < 1
	ld	hl,atan3
	push	hl
	call	savf1
	ld	hl,fone
	call	lod
	ld	hl,f1
	call	fdi
atan1:	ld	hl,atan8
	call	fcmp
	jp	m,atan2
	ld	hl,atan4
	push	hl
	call	savf1
	ld	hl,atan6
	call	fad
	ld	hl,atan10
	call	str
	call	lodf1
	ld	hl,atan5
	call	poly
	ld	hl,atan10
	call	fdi
atan2:	ld	hl,atan7
	jp	polx

atan3:	ld	hl,fpi2
	call	fsu
	jp	chs

atan4:	ld	hl,atan9
	jp	fad

atan5:	db	2
atan6:	db	81h,5dh,0b3h,0d7h
	db	81h,80h,0,0		; -1.0

atan7:	db	4
	db	7eh,83h,35h,62h
	db	7eh,4ch,24h,50h
	db	7fh,0aah,0a9h,79h
	db	81h,0,0,0

atan8:	db	7fh,09h,38h,0a3h
atan9:	db	80h,06h,0ah,92h

atan10:	ds	4

;

polx:	push	hl
	call	savf2
	ld	hl,f2
	call	fmu
	pop	hl
	call	poly
	ld	hl,f2
	jp	fmu

poly:	push	hl
	call	savf1
	pop	hl
	ld	a,(hl)
	ld	(poly3),a
	inc	hl
	push	hl
	call	lod
	jp	poly2

poly1:	ld	hl,poly3
	dec	(hl)
	pop	hl
	ret	z
	push	hl
	ld	hl,f1
	call	fmu
	pop	hl
	push	hl
	call	fad
poly2:	pop	hl
	inc	hl
	inc	hl
	inc	hl
	inc	hl
	push	hl
	jp	poly1

poly3:	ds	1

	cseg

savf1:	ld	hl,f1		; save regs to f1
	jp	str

savf2:	ld	hl,f2		; save regs to f2
	jp	str

lodf1:	ld	hl,f1		; load accum/regs from f1
	jp	lod

lodf2:	ld	hl,f2		; load accum/regs from f2
	jp	lod


ften:	call	tat		; fconstant
ften1:	db	84h,20h,0,0	; 10.0

ffiv:	db	80h,0,0,0	; 0.5

acce:	ds	5		; accumulator exponent
accs	equ	acce+1		; accumulator sign
acc1	equ	accs+1		; accumulator 1st fraction
acc2	equ	acc1+1		; accumulator 2nd fraction
acc3	equ	acc2+1		; accumulator 3rd fraction

sf:	ds	1		; subtraction flag

f1:	ds	4		; temp float storage
f2:	ds	4		;

;	fpinit  ( -- )		max-precision set-precision fdp on

	hdr	x,'FPINIT'
fpini:	call	docol
	dw	mprec,setpr
	dw	fdp,on
	dw	exit

;	fident  ( -- )

	hdr	x,'FIDENT',,1
fiden:	call	docol
	dw	crr
	dw	pdotq
	db	fiden1-$-1
	db	'Software floating-point ('
;	 if	fstack
;	db	'separate'
;	 else
	db	'common'
;	 endif
	db	' stack)'
fiden1:	dw	exit

;	fnumber  ( c-addr u -- [r] flag )
;				2dup s" E" caps search -rot 2drop base @
;				10 = and if >float else 2drop 0 then dup >r
;				state? and if postpone fliteral then r>

	hdr	x,'FNUMBER',,1
fnumb:	call	docol
	dw	tdup		; scan 'E'
	dw	psqot
	dcs	'E'
	 if	ucase
	dw	caps
	 endif
	dw	sear
	dw	drot,tdrop
	dw	base,at		; decimal base?
	dw	clit
	db	10
	dw	equal,andd
	dw	zbran,fnumb2
fnumb1:	dw	tflt
	dw	bran,fnumb3
fnumb2:	dw	tdrop,zero
fnumb3:	dw	dupp,tor
	dw	stateq
	dw	andd
	dw	zbran,fnumb4
	dw	flite
fnumb4:	dw	fromr
	dw	exit

	aseg

; 	( -- )			:noname ['] noop dup (cold2) ! (cold9) !
;				['] false (inte12) ! (nfps) off (nfpm) off
;				; remember

	hdr	x,'(-FP)',,1
fprun:	ld	hl,noop
	ld	(cold2),hl		; INIT
	ld	(cold9),hl		; INDENTIFY
	ld	hl,false
	ld	(inte12),hl		; FNUMBER
;	ld	hl,0
;	ld	(nfps),hl
;	ld	(nfpm),hl
	nextt

fprun1:	dw	0		; link
	dw	fprun		; xt

;	end

