;
;  NUMBER.MAC - Numeric Conversion
;
;  DECIMAL  HEX  digit  >NUMBER  NUMBER?  HOLD  <#  #>  SIGN  #  #S
;

;	DECIMAL  ( -- )		10 base !

	hdr	1,'DECIMAL'
decim:	call	docol
	dw	clit
	db	10
	dw	base,store
	dw	exit

;	HEX  ( -- )		16 base !

	hdr	1,'HEX'
hex:	call	docol
	dw	clit
	db	16
	dw	base,store
	dw	exit

;	digit  ( char base -- u -1 | 0 )

	hdr	x,'DIGIT'
digit:	pop	hl
	pop	de
	ld	a,e
	call	upc		; make uppercase
	sub	'0'
	jp	m,false
	cp	10
	jp	m,digit1
	sub	7
	cp	10
	jp	m,false
digit1:	cp	l
	jp	p,false
	ld	e,a
	push	de
	jp	true

;	>NUMBER  ( d1 addr1 u1 -- d2 addr2 u2 )
;				begin dup while over c@ base @ digit while
;				>r 2swap r> swap base @ um* drop rot base @
;				um* d+ 2swap 1 /string 1 dpl +! repeat then

	hdr	1,'>NUMBER'
tonum:	call	docol
tonum1:	dw	dupp		; begin
	dw	zbran,tonum2	; while
	dw	over,cat
	dw	base,at
	dw	digit
	dw	zbran,tonum2	; while
	dw	tor
	dw	tswap,fromr
	dw	swap
	dw	base,at
	dw	umstr,drop
	dw	rot
	dw	base,at
	dw	umstr
	dw	dplus
	dw	tswap
	dw	one,sstr
	dw	one,dpl,pstor
	dw	bran,tonum1	; repeat
tonum2:	dw	exit		; then

;	NUMBER?  ( c-addr u -- d -1 | 0 )
;				over c@ [char] - = over 0> and dup >r 1
;				and /string over c@ [char] . > and 0 0
;				2swap ?dup if >number dpl on dup if 1-
;				over c@ [char] . - or dpl off then while
;				then r> 2drop 2drop false else drop r> if
;				dnegate then true then

	hdr	1,'NUMBER?'
numq:	call	docol		; convert string to double number
	dw	over,cat
	dw	clit
	db	'-'
	dw	equal
	dw	over,zgrea
	dw	andd
	dw	dupp,tor
	dw	one,andd
	dw	sstr
	dw	over,cat
	dw	clit
	db	'.'
	dw	great,andd
	dw	zero,zero
	dw	tswap
	dw	qdup
	dw	zbran,numq2
	dw	tonum
	dw	dpl,on
	dw	dupp
	dw	zbran,numq1
	dw	onem
	dw	over,cat
	dw	clit
	db	'.'
	dw	subb,orr
	dw	dpl,off
numq1:	dw	zbran,numq3
numq2:	dw	fromr
	dw	tdrop,tdrop
	dw	false
	dw	bran,numq5
numq3:	dw	drop
	dw	fromr
	dw	zbran,numq4
	dw	dnegat
numq4:	dw	true
numq5:	dw	exit

;	HOLD  ( char -- )	-1 hld +! hld @ dup dp @ u<
;				abort" numeric buffer overflow" c!

	hdr	1,'HOLD'
hold:	call	docol
	dw	true,hld,pstor
	dw	hld,at,dupp
	dw	dpp,at,uless
	dw	pabq
	dcs	'numeric buffer overflow'
	dw	cstor
	dw	exit

;	<#  ( -- )		pad hld !

	hdr	1,'<#'
bdigs:	call	docol
	dw	pad
	dw	hld,store
	dw	exit

;	#>  ( d -- c-addr u )	2drop hld @ pad over -

	hdr	1,'#>'
edigs:	call	docol
	dw	tdrop
	dw	hld,at
	dw	pad
	dw	over
	dw	subb
	dw	exit

;	SIGN  ( n -- )		0< if [char] - hold then

	hdr	1,'SIGN'
sign:	call	docol
	dw	zless
	dw	zbran,sign1
	dw	clit
	db	'-'
	dw	hold
sign1:	dw	exit

;	#  ( +d1 -- +d2 )	base @ >r 0 r@ um/mod r> swap >r um/mod
;				r> rot 9 over < if 7 + then [char] 0 + hold

	hdr	1,'#'
dig:	call	docol
	dw	base,at,tor
	dw	zero
	dw	rat,umslm
	dw	fromr
	dw	swap,tor
	dw	umslm
	dw	fromr
	dw	rot
	dw	clit
	db	9
	dw	over,less
	dw	zbran,dig1
	dw	clit
	db	7
	dw	plus
dig1:	dw	clit
	db	'0'
	dw	plus
	dw	hold
	dw	exit

;	#S  ( +d -- 0 0 )	begin # 2dup d0= until

	hdr	1,'#S'
digs:	call	docol
digs1:	dw	dig
	dw	tdup
	dw	dzequ		;** orr,zequ
	dw	zbran,digs1
	dw	exit

;	end

