;STACKS 5/23/79
;XYBASIC Interpreter Source Module
;Copyright (C) 1978, 1979 by Mark Williams Company, Chicago
;symbol table and control stack manipulation routines


;FNDTK finds the location of a token in the keyword table.
;Call:	A	character or token
;Retn:	Carry	Reset if character, set if token
;	A	Preserved if character, 0 if token
;	BC,DE	Preserved
;	HL	Preserved if character, address of table entry if token
	if	not compl
fndtk:	ora	a
	if	key80
	jm	fndt1		;command or function token
	cpi	20H
	rnc			;printable char, return Carry reset
	cpi	rwdtk
	cmc
	rnc			;<cr> or <bell>, return Carry reset
	lxi	h,rwdta		;elese reserved word token
	sui	(rwdtk-1) and 0FFH	;token bias
	jmp	fndt2
	else			;not KEY80
	rp			;return Carry reset if positive
	endif
fndt1:	lxi	h,keyta
	adi	nkeys+1		;token bias
fndt2:	dcr	a		;decement token count
	jnz	fndt3		;not there yet
	stc			;else set Carry
	ret			;and return
fndt3:	push	psw		;save token count
fndt4:	mov	a,m		;fetch char
	inx	h
	ora	a
	jp	fndt4		;skip more chars in same keyword
	pop	psw		;restore token count
	jmp	fndt2		;and keep looking
	endif

;STPSH builds a new symbol table entry.
;Call:	A	token
;	HL	entry length
;	(bufad)	symbol name
;Retn:	(symta)	(symta) - length
;	((symta))	length
;	((symta)+1)	token
;	((symta)+2...)	name
;Other bytes in the entry are zeroed
;	A	token
;	BC	preserved
;	DE	address of name
;	HL	address following name
stpsh:	push	b
	push	psw		;save token
	xchg			;length to DE
	mvi	a,254
	cmp	e		;Carry set iff (E) is 255
	sbb	a		;A is 255 if (E) is 255, 0 otherwise
	ora	d		;Zero set iff (DE) <= 254
	jz	stps1
	inx	d
	inx	d
stps1:	push	d		;save length
	call	cplde		;- length to DE
	lhld	symta
	dad	d		;old - length = new symbol table address
	jnc	omerr		;much too big, OM error
	xchg
	lhld	cstkp
	xchg			;CSTKP to DE
	call	cmdhu		;compare to new SYMTA
	jnc	omerr		;CSTKP >= new SYMTA, OM error
	shld	symta		;store new SYMTA
	pop	d		;restore length
	push	d		;and save
	push	h		;and save SYMTA
stps2:	mvi	m,0		;zero a byte
	inx	h
	dcx	d
	mov	a,d
	ora	e
	jnz	stps2		;zero more bytes
	pop	h		;restore pointer
	pop	d		;and length
	mov	a,d
	ora	a
	jz	stps3
	mvi	m,255		;long entry
	inx	h
	mov	m,d
	inx	h
stps3:	mov	m,e		;store length
	inx	h
	pop	psw		;recover token
	push	psw
	mov	m,a		;store token
	inx	h
	push	h		;save name pointer
	call	cpys0		;copy name from bufad
	pop	d		;return name pointer in DE
	pop	psw		;restore token to A
	pop	b
	ret
omerr:	error	f, O, M		;fatal OM error

;STNXT gets the address of the next symbol table entry.
;Call:	HL	address of current symbol table entry length byte
;Retn:	Carry	set iff no more entries
;	BC	preserved
;	DE	current entry type byte address
;	HL	next entry address
stnxt:	mov	a,m		;fetch length byte
	ora	a
	stc
	rz			;return carry set if at end of table
	mov	d,h
	mov	e,l
	inx	d		;point to type byte
	cpi	255		;check if long entry
	jnz	adahl		;no, so length + current = next and return
	xchg			;current to DE, length byte addr to HL
	mov	a,m
	inx	h
	push	h		;save type byte addr - 1
	mov	l,m
	mov	h,a		;length to HL
	dad	d		;current + length = next
	pop	d		;type byte addr to DE
	inx	d
	ret

;STLKU looks up a symbol in the symbol table.
;Call:	(bufad)	symbol name string
;	(varty)	symbol type token
;Retn:	Carry	set iff not found, otherwise:
;	DE	entry type address
;	HL	address following name in entry
stlku:	lda	varty
stlk0:	lhld	symta
	mov	b,a		;desired type to B
stlk1:	call	stnxt		;address next entry
	rc			;return carry set iff not found
	ldax	d		;fetch entry type
	ani	1FH		;mask to type
	cmp	b
	jnz	stlk1		;not the right type, try next
	push	h		;save next
	push	d		;save type byte addr
	xchg
	inx	h		;point to name
	lxi	d,bufad
	call	cmpst		;compare to desired name
	pop	d		;restore type addr to DE
	jz	pop1		;matched, pop next to BC and retn Carry reset
	pop	h		;else next to HL
	jmp	stlk1		;and try next

;STZAP resets BREAK and FN entries in the symbol table.
;Retn:	BC	preserved
;	A,DE,HL	clobbered
stzap:	lhld	symta
stza1:	call	stnxt
	if	compl
	rc			;end of table, done if no line breaks to zap
	else
	jc	unbkl		;unbreak lines if not compl
	endif
	ldax	d
	ani	1FH		;mask to type
	if	not compl
	cpi	brkst
	jz	stza2		;break
	endif
	cpi	ufnst		;check if user-defined fn
	jnz	stza1		;neither FN nor break, try next
stza2:	xra	a
	stax	d		;store 0 type byte
	jmp	stza1

	if	not compl
;UNBKL removes all line breakpoints.
unbkl:	if	romsq		;first loc to test to HL
	lhld	sourc
	call	rtest
	rnz			;done if ROM
	else
	lxi	h,srcad
	endif
unbl1:	mov	a,m
	ora	a
	rz			;done
	push	h
	call	unbr1		;unbreak a line
	pop	h
	call	adahl		;point to next line
	jmp	unbl1		;and keep going
	endif

;CPUSH checks that sufficient free memory remains to build a control stack
;entry and if not issues an OM error.  Otherwise it pushes a token, (TEXTP) and
;(LNNUM) to the control stack, and updates the stack pointer.
;Call:	A	token (l.s. 5 bits give entry length)
;Retn:	A,BC	clobbered
;	DE	return text pointer
;	HL	(cstkp) - 4
;	(cstkp)	(cstkp) + (A4-A0)
;	((cstkp))	token
;	((cstkp)-1:(cstkp)-2)	line # address
;	((cstkp)-3:(cstkp)-4)	return text pointer
cpush:	lhld	textp
	push	h
cpsh1:	mov	b,a		;save token
	lhld	cstkp
cpsh2:	ani	1FH		;mask to length
	call	adahl
	jc	cpsh3		;new stacktop > 64K, OM error
	call	cspst		;store new control stack pointer
	xchg			;cstack pointer to DE
	lhld	symta		;symbol table pointer to HL
	call	cmdhu		;compare
	jnc	cpsh3		;OM -- flush and continue
	lhld	lnnum
	if	not compl
	mov	a,h
	ora	l
	cz	icstd		;increment CSTACK direct count if direct
	endif
	xchg			;current line # address to DE
	mov	m,b		;token to control stack
	call	mvmde		;return line # address to control stack
	pop	d
	jmp	mvmde		;return text pointer to control stack & return
cpsh3:	call	clea2		;reset CSTACK pointer
	error	n, O, M		;nonfatal OM error
	mov	a,b		;restore token
	jmp	cpsh2		;try again

;CSPOP is used to pop information from the control stack for RETURNs from
;GOSUBs and interrupts, for CONTinues, and for NEXTs.
;If the entry was made from direct mode, the dmode count CSTKD is
;decremented and an ID error issued if < 0.
;Call:	HL	address of control stack entry type/length byte
;Retn:	(lnnum)	control stack entry line # bytes
;	(textp)	control stack entry return address
;	PSW,BC	preserved
;	DE	new textp
;	HL	(HL) - 5
cspop:	if	compl
	dcx	h
	call	mvdem		;line # to DE
	else			;non COMPL version must update CSTKD
	push	psw
	push	h		;save type byte addr
	dcx	h
	call	mvdem		;line # of entry to DE
	xthl			;save entry pointer, type byte addr to HL
	if	not compl
	mov	a,d
	ora	e		;test if direct mode entry
	jnz	cspo1		;no -- restore and return
	call	dcstd		;yes -- decrement CSTACK direct count
	mov	a,m		;fetch type byte
	cpi	csfor		;check if doing a NEXT
	cz	icstd		;undecrement count if so
	endif
cspo1:	pop	h		;restore entry ptr
	pop	psw
	endif
	xchg
	shld	lnnum		;store new lnnum
	xchg
	call	mvdem
	xchg
	shld	textp		;store new textp
	xchg
	ret			;and continue from there

;CSDIG digs in the control stack for an entry with type matching B or C.
;Call:	B,C	desired type/length bytes
;Retn:	A	type/length byte found, 0 if none
;	BC,DE	preserved
;	HL	addr of type/length byte, eofad if not found
;	Carry	set iff not found
csdig:	lhld	cstkp
csdi1:	mov	a,m		;fetch type/length byte
	cmp	b
	rz			;found
	cmp	c
	rz			;found
	ani	1FH		;mask to length
	stc
	rz			;not found
	call	sbahl		;address next
	jmp	csdi1		;and try it

;CSRST resets the control stack after purging an entry.
;Call:	A	type/length byte of entry to be purged
;	HL	address of next entry in stack
;Retn:	BC	preserved
;	HL	new cstkp
csrst:	push	b
	inx	h		;point to destination
	push	h		;and save it
	ani	1FH		;mask A to length
	call	adahl		;destination + offset = source
	push	h		;saved
	xchg
	call	cplde
	lhld	cstkp
	dad	d		;# of bytes to move -1 to HL
	inx	h
	xchg			;and then to DE
	pop	b		;source to BC
	pop	h		;destination to HL
	cc	moved		;move rest  of stack
	pop	b		;restore BC
	dcx	h		;readdress cstkp
	jmp	cspst		;and reset it

;ICSTD increments the CSTACK direct count CSTKD.  DCSTD decrements CSTKD and
;issues an ID error if negative.  CSTKD counts how many CSTACK entries
;have been built from direct mode, and catches errors such as attempting to
;RETURN or NEXT when the GOSUB or FOR context has been lost.
;Status bits affected, all registers preserved.
	if	not compl
icstd:	push	h
	lxi	h,cstkd
	inr	m		;increment cstack direct count
	pop	h
	ret
dcstd:	push	h
	lxi	h,cstkd
	dcr	m		;decrement cstack direct count
	pop	h
	rp			;ok if nonnegative
	jmp	iderr		;fatal ID error if negative
	endif


;end of STACKS
	page
