; NIBL Assembler
;
; Reformated for SBASM	Chris Oddy	February 2024
;
	.CR	scmp			; 8060
	.LF	nibl.list		; listing file
	.TF	nibl.bin		; object file
	.LI	coff
;
; Configuration Switches (uncomment one line in each section)
;
; CPU Clock
;CPUCLK	.EQ	2		; 2MHz Clock
CPUCLK	.EQ	4		; 4MHz Clock
;
; Baud Rate
;BAUD		.EQ	110		; 110 bits/s symbol rate
;BAUD		.EQ	300		; 300 bits/s symbol rate
;BAUD		.EQ	600		; 600 bits/s symbol rate
;BAUD		.EQ	1200		; 1200 bits/s symbol rate
BAUD		.EQ	2400		; 2400 bits/s symbol rate (4MHz only)
;
; Source Version
SOURCE	.EQ	0		; National Semiconductor published source code
;SOURCE	.EQ	1		; Dr. Dobbs Journal Nov/Dec 1976 source code
;
; NIBL or NIBL-E
;NIBL		.EQ	0		; (NIBL)
NIBL		.EQ	1		; (NIBL-E)
;
; Fixes/Patches (set to 1 to enable)
;
FIX1		.EQ	0		; fix to CMPR and UNTIL
FIX2		.EQ	1		; serial echo bit 7 cleared (currently only for 2400 baud)
FIX3		.EQ	1		; changes NIBL-E cursor from < to >
FIX4		.EQ	1		; remove 'reader relay'
FIX5		.EQ	1		; add GECO and PUTC redirections for page3.sys
; (be aware that page3.sys also calls REST at $1970, make sure any changes do not move REST)
;
; Check for invalid combinations of switches
;
		.DO	CPUCLK=2
			.DO	BAUD=2400
			.ER	F,2400 Baud not avaliable for 2MHz CPU
			.FI
		.FI
		.DO	FIX2=1
			.DO	BAUD<>2400
			.ER	F,FIX2 (bit 7 fix) only valid for 2400 Baud
			.FI
		.FI
;
; I.L. INSTRUCTION FLAGS
;
TSTBIT	.EQ	$20
JMPBIT	.EQ	$40
CALBIT	.EQ	$80
;
; DISPLACEMENTS FOR RAM VARIABLES USED BY INTERPRETER
;
DOPTR		.EQ	-1		; DO stack pointer
FORPTR	.EQ	-2		; FOR stack pointer
LSTK		.EQ	-3		; arithmetic stack pointer
SBRPTR	.EQ	-4		; GOSUB stack pointer
PCLOW		.EQ	-5		; Intermediate Language program counter
PCHIGH	.EQ	-6
PCSTK		.EQ	-7		; Intermediate Language CALL stack pointer
LOLINE	.EQ	-8		; current line number
HILINE	.EQ	-9
PAGE		.EQ	-10		; value of current PAGE
LISTNG	.EQ	-11		; listing flag
RUNMOD	.EQ	-12		; run/edit flag
LABLLO	.EQ	-13
LABLHI	.EQ	-14
P1LOW		.EQ	-15		; space to save cursor
P1HIGH	.EQ	-16
LO		.EQ	-17
HI		.EQ	-18
FAILLO	.EQ	-19
FAILHI	.EQ	-20
NUM		.EQ	-21
TEMP		.EQ	-22
TEMP2		.EQ	-23
TEMP3		.EQ	-24
CHRNUM	.EQ	-25
RNDF		.EQ	-26
RNDX		.EQ	-27		; seeds for random number
RNDY		.EQ	-28
;
; Allocation of RAM for NIBL Variables, Stacks and Line Buffer
;
	.DO	NIBL=0		; (NIBL)
VARS		.EQ	$1000+28	; NIBL variables A-Z
	.EL				; (NIBL-E)
VARS		.EQ	$2000+28	; NIBL variables A-Z
	.FI
AESTK		.EQ	VARS+52	; Arithmetic Stack
SBRSTK	.EQ	AESTK+26	; G0SUB stack
DOSTAK	.EQ	SBRSTK+16	; DO/UNTIL stack
FORSTK	.EQ	DOSTAK+16	; FOR/NEXT stack
PCSTAK	.EQ	FORSTK+28	; Intermediate Language CALL stack
LBUF		.EQ	PCSTAK+48	; line buffer
PGM		.EQ	LBUF+74	; user's program
;
; Macro Definitions
;
LDPI	.MA	P,VAL
		LDI	/]2		; VAL
		XPAH	]1		; P
		LDI	]2		; VAL
		XPAL	]1		; P
	.EM
;
JS	.MA	P,VAL
		LDI	/]2-1		; VAL
		XPAH	]1		; P
		LDI	]2-1		; VAL
		XPAL	]1		; P
		XPPC	]1		; P
	.EM
;
;		Set Start Address - $0000 for NIBL, $1000 for NIBL-E
;
	.DO	NIBL=0		; (NIBL)
		.OR	$0000
	.EL				; (NIBL-E)
		.OR	$1000
	.FI
;
	.DO	NIBL=0		; start of NIBL Initialisation
;
;************************************
;*	INITIALISATION OF NIBL		*
;************************************
;
		NOP
		>LDPI	P2,VARS	; point P2 at variables
		>LDPI	P1,PGM	; point P1 U PAGE one program
		LDI	-1		; store -1 at start of program
		ST	0(P1)
		ST	1(P1)
		LDI	$0D		; also store a dummy
		ST	-1(P1)	; carriage return
		LDI	2		; point P2 at PAGE 2
		ST	PAGE(P2)	; initially set PAGE to 2
		XPAL	P1
		LDI	$020
		XPAH	P1
		DLD	2(P1)		; check if there is really
		XAE			; a program in PAGE 2:
		LD	E(P1)		; if first line length
		XRI	$0D		; points to carriage return
		JZ	LOOP0		; at end of line
		DLD	PAGE(P2)	; if not, PAGE=1
LOOP0:	LDI	$020
LOOP:		XPAH	P1
		LDI	-1		; store -1 in 2 consecutive
		ST	(P1)		; locations at start of PAGE
		ST	1(P1)
		LDI	$0D		; also put a dummy end-of-line
		ST	-1(P1)	; just before text
		XPAH	P1		; update P1 to point to
		CCL			; next PAGE (until PAGE=8)
		ADI	$10		; repeat initialisation
		XRI	$80		; for PAGES 2-7
		JZ	LOOP1
		XRI	$080
		JMP	LOOP
LOOP1:	LDI	0		; clear some flags
		ST	RUNMOD(P2)
		ST	LISTNG(P2)
		LDI	BEGIN		; initialise Intermediate Language PC so that
		ST	PCLOW(P2)	; NIBL program is executed immediately
		LDI	/BEGIN
		ST	PCHIGH(P2)
CLEAR:	LDI	0
		ST	TEMP(P2)
		XAE
CLEAR1:	LDI	0		; set all variables to zero
		ST	E(P2)
		ILD	TEMP(P2)
		XAE
		LDI	52
		XRE
		JNZ	CLEAR1
		LDI	AESTK		; initialise some stacks:
		ST	LSTK(P2)	; arithmetic stack,
		LDI	DOSTAK
		ST	DOPTR(P2)	; DO/UNTIL stack,
		LDI	SBRSTK
		ST	SBRPTR(P2)	; GOSUB stack,
		LDI	PCSTAK
		ST	PCSTK(P2)	; Intermediate Language CALL stack,
		LDI	FORSTK
		ST	FORPTR(P2)	; FOR/NEXT stack

	.EL				; end of NIBL initialisation
					; start of NIBL-E initialisation
;
;************************************
;*	Initialisation OF NIBL-E	*
;************************************
;
		NOP
		NOP
		NOP
		>LDPI	P2,VARS	; point P2U
		>LDPI	P1,PGM	; point P1 AT PAGE ONE PROGRAM
		LDI	-1		; U
		ST	0(P1)
		ST	1(P1)
		LDI	3		; point P2 at PAGE 2,
		ST	PAGE(P2)	; initially set PAGE to 2
		LDI	2
		XPAL	P1
		LDI	$30
		XPAH	P1
		DLD	2(P1)		; check if there is really
		XAE			; a program in PAGE 2:
		ILD	2(P1)
		LD	E(P1)		; if first line length
		XRI	$0D		; points to carriage return
		JZ	LOOP1		; at end of line
		DLD	PAGE(P2)	; if not, PAGE=1
LOOP0:	LDI	-1		; store -1 in 2 consecutive
		ST	(P1)		; locations at start of PAGE
		ST	1(P1)
		LDI	$0D		; also put a dummy end-of-line
		ST	-1(P1)	; just before text
		XPAH	P1		; update P1 to point to
		CCL			; next PAGE (until PAGE=8)
		ADI	$10		; repeat initialisation
		XRI	$40		; for PAGES 2-7
		JZ	LOOP1
		XRI	$40
		XPAH	P1
		JMP	LOOP0
LOOP1:	LDI	0		; clear some flags
		ST	RUNMOD(P2)
		ST	LISTNG(P2)
		LDI	BEGIN		; initialise Intermediate Language PC so that
		ST	PCLOW(P2)	; NIBL program is executed immediately
		LDI	/BEGIN
		ST	PCHIGH(P2)
CLEAR:	LDI	0
		ST	TEMP(P2)
		XAE
CLEAR1:	LDI	0		; set all variables to zero
		ST	E(P2)
		ILD	TEMP(P2)
		XAE
		LDI	52
		XRE
		JNZ	CLEAR1
		LDI	AESTK		; initialise some stacks:
		ST	LSTK(P2)	; arithmetic stack,
		LDI	DOSTAK
		ST	DOPTR(P2)	; DO/UNTIL stack,
		LDI	SBRSTK
		ST	SBRPTR(P2)	; GOSUB stack,
		LDI	PCSTAK
		ST	PCSTK(P2)	; Intermediate Language CALL stack,
		LDI	FORSTK
		ST	FORPTR(P2)	; FOR/NEXT stack

	.FI				; end of NIBL-E initialisation
;
	.DO	SOURCE=0		; start of National Semiconductor source
;
;******************************************
;*	Intermediate Language Executor	*
;*	from National Semiconductor source	*
;******************************************
;
EXECIL:	LD	PCLOW(P2)	; set P3 to current
		XPAL	P3		; Intermediate Language PC
		LD	PCHIGH(P2)
		XPAH	P3
CHEAT:	LD	@1(P3)
		XAE			; get new Intermediate Language instruction
		LD	@1(P3)	; into P3 through
		XPAL	P3		; obscure methods
		ST	PCLOW(P2)	; simultaneously, increment
		LDE			; the PC by 2
	.DO	NIBL=0		; (NIBL)
		ANI	$0F		; remove flag from instruction
	.EL				; (NIBL-E)
		ANI	$1F		; remove flag from instruction
	.FI
		ORI	$/256		; turn into actual address,
		XPAH	P3		; PUT BACK INTO p3
		st	pchigh(p2)
		LDE
	.DO NIBL=0			; (NIBL)
		ANI	$F0		; check if Intermediate Language instruction
	.EL				; (NIBL-E)
		ANI	$E0		; check if Intermediate Language instruction
	.FI
		XRI	TSTBIT	; is a 'test'
		JZ	TST
		XRI	CALBIT!TSTBIT ; check for Intermediate Language CALL
		JZ	ILCALL
		XRI	JMPBIT!CALBIT ; check for Intermediate Language JUMP
		JZ	CHEAT		; JUMP is trivial
NOJUMP:	XPPC	P3		; must be a subroutine
		JMP	EXECIL	; if none of the above
;
	.FI				; end of National Semiconductor source
;
	.DO	SOURCE=1		; start of Dr. Dobbs source
;
;******************************************
;*	Intermediate Language Executor	*
;*	*from Dr. Dobbs Journal			*
;******************************************
;
EXECIL:	LD	PCLOW(P2)	; set P3 to current
		XPAL	P3		; Intermediate Language PC
		LD	PCHIGH(P2)
		XPAH	P3
CHEAT:	LD	@1(P3)
		XAE			; get new Intermediate Language instruction
		LD	@1(P3)	; into P3 through
		XPAL	P3		; obscure methods
		ST	PCLOW(P2)	; simultaneously, increment
		LDE			; the PC by 2
		XPAH	P3
		ST	PCHIGH(P2)
		LDE
	.DO	NIBL=0		; (NIBL)
		ANI	$F0		; check if Intermediate Language instruction
	.EL				; (NIBL-E)
		ANI	$e0		; check if Intermediate Language instruction
	.FI
		XRI	TSTBIT	; is a 'test'
		JZ	TST
		XRI	CALBIT!TSTBIT ; check for Intermediate Language CALL
		JZ	ILCALL
		XRI	JMPBIT!CALBIT ; check for Intermediate Language JUMP
		JNZ	NOJUMP
		XPAH	P3		; *** Intermediate Language JUMP ***
	.DO	NIBL=0		; (NIBL)
		ANI	$0F		; all it takes is scrubbing
	.EL				; (NIBL-E)
		ANI	$1F		; all it takes is scrubbing
	.FI
		XPAH	P3		; the jump flag off of P3
CHEAT1:	JMP	CHEAT
NOJUMP:	XPPC	P3		; must be a subroutine
		JMP	EXECIL	; if none of the above
;
	.FI				; end of Dr. Dobbs source
;
;************************************
;*	Intermediate Language CALL	*
;************************************
;
ILCALL:	LD	PCSTK(P2)
		XRI	LBUF		; check for stack overflow
		JNZ	ILC1
		LDI	10
		JMP	E0A
ILC1:		XRI	LBUF		; restore accumulator
		XPAL	P3		; save low byte of new
		ST	TEMP(P2)	; Intermediate Language PC in temp
		LDI	/PCSTAK	; point P3 at ntermediate language
		XPAH	P3		; subroutine stack
	.DO	SOURCE=0		; (National Semiconductor source only)
		XAE			; save new PC high in X
	.FI
		LD	PCLOW(P2)	; save old PC on stack
		ST	@1(P3)
		LD	PCHIGH(P2)
		ST	@1(P3)
		LD	TEMP(P2)	; get low byte of new
		XPAL	P3		; PC into P3 low
		ST	PCSTK(P2)	; update Intermediate Language stack pointer
		LDE			; get high byte of new P3
	.DO	SOURCE=1		; (Dr. Dobbs source only)
		ANI	$0F 
	.FI
		XPAH	P3		; PC into P3 high
	.DO	SOURCE=0		; (National Semiconductor source only)
CHEAT1:
	.FI
		JMP	CHEAT
;
;************************************
;*	I.L. 'TEST' INSTRUCTION		*
;************************************
;
TST:		ST	CHRNUM(P2)	; clear number of characters scanned
SCAN0:	LD	@1(P1)	; slew off spaces
		XRI	' '
		JZ	SCAN0
		LD	@-1(P1)	; reposition cursor
		LD	PCHIGH(P2)	; point P3 at Intermediate Language table
		XPAH	P3
	.DO	SOURCE=1		; (Dr. Dobbs source only)
		ANI	$0F
	.FI
		ST	FAILHI(P2)	; fail address <- old P3
		LD	PCLOW(P2)
		XPAL	P3
		ST	FAILLO(P2)
LOOP2:	LD	@1(P3)
		XAE			; save character from table
		DLD	CHRNUM(P2)	; decrement character count
		LDE			; get character back
		ANI	$7F		; scrub off flag (if any)
		XOR	@1(P1)	; is character equal to text character ?
		JNZ	NEQ0		; no - end test
		LDE			; yes - but is it last character ?
		JP	LOOP2		; if not, continue to compare
		JMP	CHEAT		; if so, get next Intermediate Language
X0:		JMP	EXECIL	; instruction
NEQ0:		LD	CHRNUM(P2)	; restore P1 to
		XAE			; original value
		LD	@E(P1)
		LD	FAILLO(P2)	; load test-fail address
		XPAL	P3		; into P3
		LD	FAILHI(P2)
		XPAH	P3
		JMP	CHEAT1	; get next Intermediate Language instruction
;
;************************************************
;*	Intermediate Language Sunroutine Return	*
;************************************************
;
RTN:		LDI	/PCSTAK	; point P3 at Intermediate Language PC stack
		XPAH	P3
		LD	PCSTK(P2)
		XPAL	P3
		LD	@-1(P3)	; get high part of old PC
		XAE
		LD	@-1(P3)	; get low part of old PC
		XPAL	P3
		ST	PCSTK(P2)	; update Intermediate language stack pointer
		LDE
		XPAH	P3		; P3 now has old PC
		JMP	CHEAT1
E0A:		JMP	E0
;
;************************************
;*	Save GOSUB Return Address	*
;************************************
;
SAV:		LD	SBRPTR(P2)
		XRI	DOSTAK	; check for more
		JZ	SAV2		; than 8 saves
		ILD	SBRPTR(P2)
		ILD	SBRPTR(P2)
		XPAL	P3		; set P3 to
		LDI	/SBRSTK	; subroutine stack top
		XPAH	P3
		LD	RUNMOD(P2)	; if immediate mode,
		JZ	SAV1		; save negative address
		XPAH	P1		; save high portion of cursor
		ST	-1(P3)
		XPAH	P1
		XPAL	P1		; save low portion of cursor
		ST	-2(P3)
		XPAL	P1
		JMP	X0		; return
SAV1:		LDI	-1		; immediate mode
		ST	-1(P3)	; return address is
		JMP	X0		; negative
SAV2:		LDI	10		; error: more than
		JMP	E0		; eight GOSUBs
;
;************************************
;*	Check Statement Finished	*
;************************************
;
DONE:		LD	@1(P1)	; skip spaces
		XRI	' '
		JZ	DONE
		XRI	' '^$0D	; is it carriage return ?
		JZ	DONE1		; yes - return
		XRI	$37		; is character a ':' ?
		JNZ	DONE2		; no - error
DONE1:	XPPC	P3		; yes - return
DONE2:	LDI	4
		JMP	E0
;
;******************************
;*	Return From GOSUB		*
;******************************
;
RSTR:		LD	SBRPTR(P2)
		XRI	SBRSTK	; check for return
		JNZ	RSTR1		; without GOSUB
		LDI	9
E0:		JMP	E1		; GOTO error
RSTR1:	DLD	SBRPTR(P2)
		DLD	SBRPTR(P2)	; POP GOSUB stack,
		XPAL	P3		; put pointer in P3
		LDI	/SBRSTK
		XPAH	P3
		LD	1(P3)		; if address negative,
		JP	RSTR2		; subroutine was called
	.DO	SOURCE=0		; (National Semiconductor source only)
		LDI	0		; in immediate mode,
		ST	RUNMOD(P2)	; so finish up executing
	.FI
	.DO	SOURCE=1		; (Dr. Dobbs source only)
		JS	P3,FIN	; in immediate mode,
	.FI
X1:		JMP	X0		; so finish up executing
RSTR2:	XPAH	P1		; restore cursor high
		LD	0(P3)
		XPAL	P1		; restore cursor low
		LDI	1		; set run mode
		ST	RUNMOD(P2)
		JMP	X1
;
;************************************
;*	Transfer to New Statement	*
;************************************
;
XFER:		LD	 LABLHI(P2)	; check for non-existent line
		JP	 XFER1
		LDI	8
		JMP	E1
XFER1:	LDI	1		; set run mode to 1
		ST	 RUNMOD(P2)
		XPPC	P3
;
;******************************
;*	Print String in Text	*
;******************************
;
PRS:		>LDPI	P3,PUTC-1	; point P3 at PUTC routine
		LD	 @1(P1)	; load next character
		XRI	'"'		; if ", end of string
		JZ	 X1
		XRI	$2F		; if CR, error
		JZ	 PRS1
		XRI	$0D		; restore character
		XPPC	P3		; print character
		JMP	PRS		; get next character
PRS1:		LDI	7		; syntax error
E1:		JMP	E2
;
;******************************
;*	Print Number on Stack	*
;******************************
;
; This routine is based on Dennis Allison's binary to decimal
; conversion routine in vol. 1, #1 of "Dr. Dobb's Journal",
; but is much more obscure because of the stack manipulation.
;
PRN:		LDI	/AESTK	; point P3 at A.E. stack
		XPAH	P3
		ILD	LSTK(P2)
		ILD	LSTK(P2)
		XPAL	P3
		LDI	10		; put 10 on stack (we'll be dividing by it later)
		ST	-2(P3)
		LDI	0	
		ST	-1(P3)
		LDI	5		; set CHRNUM to point to place
		ST	CHRNUM(P2)	; in stack where we store
		LDI	-1		; the characters to print
		ST	5(P3)		; first character is a flag (-1)
		LD	-3(P3)	; check if number is negative
		JP	PRN0
		LDI	'-'		; put '-' on stack, and negate the number
		ST	4(P3)
		LDI	0
		SCL
		CAD	-4(P3)
		ST	-4(P3)
		LDI	0
		CAD	-3(P3)
		ST	-3(P3)
		JMP	X1		; go do division by 10
PRN0:		LDI	' '		; if positive, put ' ' on
		ST	4(P3)		; stack before division
X4:		JMP	X1
E2:		JMP	ERR1
;
; The division is performed, then control is transferred to prn1, which follows
;
PRN1:		ILD	LSTK(P2)	; point P1 at A.E. stack
		ILD	LSTK(P2)
		XPAL	P1
		LDI	/AESTK
		XPAH	P1
		ILD	CHRNUM(P2)	; increment character stack
		XAE			; pointer, put in X register
		LD	1(P1)		; get remainder from divide,
		ORI	'0'
		ST	E(P1)		; put it on the stack
		LD	-3(P1)	; is the quotient zero yet ?
		OR	-4(P1)
		JZ	PRN2		; yes - go print the number
		LDI	/PRNUM1	; no - change the intermediate Language PC
		ST	PCHIGH(P2)	; so that divide is performed again
		LDI	PRNUM1
		ST	PCLOW(P2)
		JMP	X4		; go do division by 10 again
PRN2:		>LDPI	P3,PUTC-1	; point P3 at PUTC routine
		LD	LISTNG(P2)	; if listing, skip printing leading space
		JNZ	PRN3
		LD	4(P1)		; print either '-'
		XPPC	P3		; or leading space
		LD	CHRNUM(P2)	; get X register value back
		XAE
PRN3:		LD	@E(P1)	; point P3 at first character to be printed
		LD	(P1)
LOOP3:	XPPC	P3		; print the character
		LD	@-1(P1)	; get next character
		JP	LOOP3		; repeat until = -1
		LDI	AESTK
		ST	LSTK(P2)	; clear the A.E. stack
		LD	LISTNG(P2)	; print a trailing space
		JNZ	X4		; if not listing program
		LDI	' '
		XPPC	P3
		JMP	X4
;
;************************************
;*	Carriage Return / Line Feed	*
;************************************
;
NLINE:	>LDPI	P3,PUTC-1	; point P3 at PUTC routine
		LDI	$0D		; carriage return
		XPPC	P3
		LDI	$0A		; line feed
		XPPC	P3
X5:		JMP	X4
;
;************************
;*	Error Routine	*
;************************
;
ERR:		LDI	5		; syntax error
ERR1:		ST	NUM(P2)	; save error number
ERR2:		LD	NUM(P2)
		ST	TEMP(P2)
		>LDPI	P3,PUTC-1	; point P3 at PUTC
		LDI	$0D		; print CR/LF
		XPPC	P3
		LDI	$0A
		XPPC	P3
		>LDPI	P1,MESGS	; P1 -> error messages
NMSG:		DLD	NUM(P2)	; is this the right message ?
		JZ	MSG0		; yes - go print it
LOOP4:	LD	@1(P1)	; no - scan through to next message
		JP	LOOP4
		JMP	NMSG
MSG0:		LD	@1(P1)	; get message character
		XPPC	P3		; print it
		LD	-1(P1)	; is message done ?
		JP	MSG0		; no - get next character
		LD	TEMP(P2)	; was this a break message ?
		XRI	14
		JZ	SKIP0		; yes - skip printing 'ERROR'
		>LDPI	P1,MESGS	; no - print error
AGAIN:	LD	@1(P1)	; get character
		XPPC	P3		; print it
		LD	-1(P1)	; done ?
		JP	AGAIN		; no - repeat loop
SKIP0:	LD	RUNMOD(P2)	; don't print line number
		JZ	FIN		; if immediate mode
		LDI	' '
		XPPC	P3		; space
		LDI	'A'		; AT
		XPPC	P3
		LDI	'T'
		XPPC	P3
		LDI	/AESTK	; point P3 at A.E. stack
		XPAH	P3
		ILD	LSTK(P2)
		ILD	LSTK(P2)
		XPAL	P3
		LD	HILINE(P2)	; get high byte of line number
		ST	-1(P3)	; put on stack
		LD	LOLINE(P2)	; get low byte of line number
		ST	-2(P3)	; put on stack
		LDI	ERRNUM	; go to prn
		ST	PCLOW(P2)
		LDI	/ERRNUM
		ST	PCHIGH(P2)
X5A:		JMP	X5
; 
;************************************
;*	Break, NXT, FIN, & STRT		*
;************************************
;
BREAK:	LDI	14		; *** cause a break ***
E3A:		JMP	ERR1		; display ERROR AT ...
					; *** next statement ***
NXT:		LD	RUNMOD(P2)	; if in immediate mode,
		JZ	FIN		; stop execution
		LD	(P1)		; if we hit end of file,
		ANI	$80		; finish up things
		JNZ	FIN
		CSA			; break if someone is
		ANI	$20		; typing on the console
		JZ	BREAK
		LD	-1(P1)	; get last character scanned
		XRI	$0D		; was it carriage return ?
		JNZ	NXT1		; yes - skip following updates
		LD	@1(P1)	; get high byte of next line number
		ST	HILINE(P2)	; save it
		LD	@2(P1)	; get low byte of line number, skip
		ST	LOLINE(P2)	; line length byte
NXT1:		LDI	/STMT		; go to 'stmt' in Intermediate Language table
		ST	PCHIGH(P2)
		LDI	STMT
		ST	PCLOW(P2)
		XPPC	P3
 
FIN:		LDI	0		; *** finish execution ***
		ST	RUNMOD(P2)	; clear run mode
		LDI	AESTK		; clear arithmetic stack
		ST	LSTK(P2)
		LDI	START		; set Intermediate Language PC to getting lines
		ST	PCLOW(P2)	; to prompt for command
		LDI	/START
		ST	PCHIGH(P2)
		LDI	PCSTAK
		ST	PCSTK(P2)
		JMP	X5A
					; *** start execution ***
STRT:		ILD	RUNMOD(P2)	; run mode = 1
		LD	TEMP2(P2)	; point cursor to
		XPAH	P1		; start of nibl program
		LD	TEMP3(P2)
		XPAL	P1
		LDI	SBRSTK	; empty some stacks:
		ST	SBRPTR(P2)	; GOSUB stack,
		LDI	FORSTK
		ST	FORPTR(P2)	; FOR stack
		LDI	DOSTAK
		ST	DOPTR(P2)	; & DO/UNTIL stack
		XPPC	P3		; return
X6:		JMP	X5A
E4:		JMP	E3A
;
;************************************
;*		List NIBL Program		*
;************************************
;
LST:		LD	(P1)		; check for end of file
		XRI	$80
		JP	LST2
		LDI	/AESTK	; get line number onto stack
		XPAH	P3
		ILD	LSTK(P2)
		ILD	LSTK(P2)
		XPAL	P3
		LD	@1(P1)
		ST	-1(P3)   
		LD	@1(P1)
		ST	-2(P3)
		LD	@1(P1)	; skip over line length
		LDI	1
		ST	LISTNG(P2)	; set listing flag
		JMP	X6		; go print line number
LST2:		LDI	0
		ST	LISTNG(P2)	; clear listing flag
		JS	P3,NXT	; go to next
X6A:		JMP	X6
E5:		JMP	E4
LST3:		>LDPI	P3,PUTC-1	; point P3 at PUTC
LST4:		CSA
		ANI	$20
		JZ	LST2		; if typing, stop
		LD	@1(P1)	; get next characte
		XRI	$0D		; test for cr
		JZ	LST5
		XRI	$0D		; get character
		XPPC	P3		; print character
		JMP	LST4
LST5:		LDI	$0D		; carriage return
		XPPC	P3
		LDI	$0A		; line feed
		XPPC	P3
		CCL
		LDI	LIST3
		ST	PCLOW(P2)
		LDI	/LIST3
		ST	PCHIGH(P2)
		JMP	LST		 ; get next line
;
;************************************
;*	  Add and Subtract		*
;************************************
;
ADD:		LDI	/AESTK	; set P3 to current
		XPAH	P3		; stack location
		DLD	LSTK(P2)
		DLD	LSTK(P2)
		XPAL	P3
		CCL
		LD	-2(P3)	; replace two top items
		ADD	0(P3)		; on stack by their sum
		ST	-2(P3)
		LD	-1(P3)
		ADD	1(P3)
		ST	-1(P3)
X7:		JMP	X6A
;
SUB:		LDI	/AESTK	; set P3 to current
		XPAH	P3		; stack location
		DLD	LSTK(P2)
		DLD	LSTK(P2)
		XPAL	P3
		SCL
		LD	-2(P3)	; replace two top items
		CAD	0(P3)		; on stack by their difference
		ST	-2(P3)
		LD	-1(P3)
		CAD	1(P3)
		ST	-1(P3)
		JMP	X6A
;
;************************************
;*		 Negate			*
;************************************
;
NEG:		LDI	/AESTK	; set P3 to current
		XPAH	P3		; stack location
		LD	LSTK(P2)
		XPAL	P3
		SCL
		LDI	0
		CAD	-2(P3)	; negate top item on stack
		ST	-2(P3)
		LDI	0
		CAD	-1(P3)
		ST	-1(P3)
X8:		JMP	X7
E6:		JMP	E5
;
;********************************
;*		 Multiply		  *
;********************************
;
MUL:		LDI	/AESTK	; set P3 to current
		XPAH	P3		; stack location
		LD	LSTK(P2)
		XPAL	P3		; determine sign of product, 
		LD	-1(P3)	; save in temp(P2)
		XOR	-3(P3)
		ST	TEMP(P2)
		LD	-1(P3)	; check for negative
		JP	MPOS		; multiplier
		SCL
		LDI	0		; if negative,
		CAD	-2(P3)	; negate
		ST	-2(P3)
		LDI	0
		CAD	-1(P3)
		ST	-1(P3)
MPOS:		LD	-3(P3)	; check for negative
		JP	MPOS1		; multiplicand
		SCL
		LDI	0		; if negative,
		CAD	-4(P3)	; negate
		ST	-4(P3)
		LDI	0
		CAD	-3(P3)
		ST	-3(P3)
MPOS1:	LDI	0		; clear workspace
		ST	0(P3)
		ST	1(P3)
		ST	2(P3)
		ST	3(P3)
		LDI	16		; set counter to 16
		ST	NUM(P2)
LOOP5:	LD	-1(P3)	; rotate multiplier
		RRL			; right one bit
		ST	-1(P3)
		LD	-2(P3)
		RRL
		ST	-2(P3)
		CSA			; check for carry bit
		JP	MM3		; if not set, don't do add
		CCL
		LD	2(P3)		; add multiplicand
		ADD	-4(P3)	; into workspace
		ST	2(P3)
		LD	3(P3)
		ADD	-3(P3)
		ST	3(P3)
		JMP	MM3
E6A:		JMP	E6
MM3:		CCL
		LD	3(P3)		; shift workspace right by 1
		RRL
		ST	3(P3)
		LD	2(P3)
		RRL
		ST	2(P3)
		LD	1(P3)
		RRL
		ST	1(P3)
		LD	0(P3)
		RRL
		ST	0(P3)
		DLD	NUM(P2)	; decrement counter
		JNZ	LOOP5		; loop if not zero
		JMP	MM4
X9:		JMP	X8
MM4:		LD	TEMP(P2)	; check sign word
		JP	EXIT0		; if bit7 = 1, negate product
		SCL
		LDI	0
		CAD	0(P3)
		ST	0(P3)
		LDI	0
		CAD	1(P3)
		ST	1(P3)
EXIT0:	LD	0(P3)		; put product on top of stack
		ST	-4(P3)
		LD	1(P3)
		ST	-3(P3)
		DLD	LSTK(P2)	; subtract 2 from LSTK
		DLD	LSTK(P2)
		JMP	X9
;
;******************
;*	Divide	*
;******************
;
DIV:		LDI	/AESTK
		XPAH	P3
		LD	LSTK(P2)  
		XPAL	P3
		LD	-1(P3)	; check for division by 0
		OR	-2(P3)
		JNZ	QD0
		LDI	13
		JMP	E6A
QD0:		LD	-3(P3)
		XOR	-1(P3)
		ST	TEMP(P2)	; save sign of quotient
		LD	-3(P3)	; is dividend positive ?
		JP	DPOS		; yes - jump
		LDI	0
		SCL
		CAD	-4(P3)	; no - negate dividend,
		ST	3(P3)		; store in right half
		LDI	0		; of 32-bit accumulator
		CAD	-3(P3)
		ST	2(P3)
		JMP	QD1
X9A:		JMP	X9
DPOS:		LD	-3(P3)	; store non-negated dividend
		ST	2(P3)		; in 32-bit accumulator
		LD	-4(P3)
		ST	3(P3)
QD1:		LD	-1(P3)	; check for negative divisor
		JP	QD2
		LDI	0		; negate divisor
		SCL
		CAD	-2(P3)
		ST	-2(P3)
		LDI	0
		CAD	-1(P3)
		ST	-1(P3)
QD2:		LDI	0		; put zero in:
		ST	1(P3)		; left half of 32-bit accumulator,
		ST	0(P3)
		ST	NUM(P2)	; the counter, and
		ST	-3(P3)	; in the dividend, now used
		ST	-4(P3)	; store the quotient
LOOP6:	CCL			; begin main divide loop:
		LD	-4(P3)	; shift quotient left,
		ADD	-4(P3)
		ST	-4(P3)
		LD	-3(P3)
		ADD	-3(P3)
		ST	-3(P3)
		CCL			; shift 32-bit accumulator left,
		LD	3(P3)
		ADD	3(P3)
		ST	3(P3)
		LD	2(P3)
		ADD	2(P3)
		ST	2(P3)
		LD	1(P3)
		ADD	1(P3)
		ST	1(P3)
		LD	(P3)
		ADD	(P3)
		ST	(P3)
		SCL
		LD	1(P3)		; subtract divisor into
		CAD	-2(P3)	; left half of accumulator,
		ST	1(P3)
		LD	(P3)
		CAD	-1(P3)
		ST	(P3)
		JP	QDENT1	; if result is negative,
		CCL			; restore original contents
		LD	1(P3)		; of accumulator by adding divisor
		ADD	-2(P3)
		ST	1(P3)
		LD	(P3)
		ADD	-1(P3)
		ST	(P3)
		JMP	QD3
X9B:		JMP	X9A
QDENT1:	LD	-4(P3)	; else if result positive,
		ORI	1		; record a 1 in quotient
		ST	-4(P3)	; without restoring the accumulator
QD3:		ILD	NUM(P2)	; increment the counter
		XRI	16		; are we done ?
		JNZ	LOOP6		; loop if not done
		LD	TEMP(P2)	; check the quotient's sign,
		JP	QDEND		; negating if necessary
		LDI	0
		SCL
		CAD	-4(P3) 
		ST	-4(P3)
		LDI	0
		CAD	-3(P3)
		ST	-3(P3)
QDEND:	DLD	LSTK(P2)	; decrement the stack pointer,
		DLD	LSTK(P2)
		JMP	X9B		; and exit
; 
;************************
;*	Store Variable	*
;************************
;
STORE:	LDI	/AESTK	; set P3 to stack
		XPAH	P3
		LD	LSTK(P2)
		XPAL	P3
		LD	@-3(P3)	; get variable index
		XAE			; put in E register
		LD	1(P3)
		ST	E(P2)		; store lower 8 bits
		CCL			; into variable
		LDE			; increment index
		ADI	1
		XAE
		LD	2(P3)
		ST	E(P2)		; store upper 8 bits
		XPAL	P3		; into variable
		ST	LSTK(P2)	; update stack pointer
X10:		JS	P3,EXECIL
; 
;************************************
;*	Test for Variable in Text	*
;************************************
;
TSTVAR:	LD	@1(P1)
		XRI	' '		; slew off spaces
		JZ	TSTVAR 
		LD	-1(P1)	; character in question
		SCL
		CAI	'Z'+1		; subtract 'Z'+l
		JP	TVFAIL	; not variable if positive
		SCL
		CAI	'A'-'Z'-1	; subtract 'A'
		JP	TVMAY		; if positive, may be variable
TVFAIL:	LD	@-1(P1)	; backspace cursor
		LD	PCLOW(P2)	; get test-fail address
		XPAL	P3		; from Intermediate Language table, put it
		LD	PCHIGH(P2)	; into Intermediate Language PC
		XPAH	P3
		LD	(P3)
		ST	PCHIGH(P2)
		LD	1(P3)
		ST	PCLOW(P2)
		JMP	X10
TVMAY:	XAE			; save value (0-25)
		LD	(P1)		; check following character
		SCL			; MUST NOT BE A LETTER
		CAI	'Z'+1		; otherwise we'd be looking
		JP	TVOK		; at a keyword, not a variable
		SCL
		CAI	'A'-'Z'-1
		JP	TVFAIL
TVOK:		LDI	/AESTK	; set P3 to current
		XPAH	P3		; stack location
		ILD	LSTK(P2)	; increment stack pointer
		XPAL	P3
		CCL			; double variable index
		LDE
		ADE
		ST	-1(P3)	; put index on stack
		LDI	2		; increment Intermediate Language PC, skipping
		CCL			; over test-fail address
		ADD	PCLOW(P2)
		ST	PCLOW(P2)
		LDI	0
		ADD	PCHIGH(P2)
		ST	PCHIGH(P2)
		JMP	X10
;
;************************************
;*	IND - Evaluate a Variable	*
;************************************
;
IND:		LDI	/AESTK	; set P3 to stack
		XPAH	P3
		ILD	LSTK(P2)
		XPAL	P3
		LD	-2(P3)	; get index off TOP
		XAE			; put index in E register
		LD	E(P2)		; get lower 8 bits
		ST	-2(P3)	; save on stack
		CCL
		LDE			; increment E register
		ADI	1
		XAE
		LD	E(P2)		; get upper 8 bits
		ST	-1(P3)	; save on stack
X11:		JMP	X10
;
;******************************
;*	Relational Operators	*
;******************************
;
EQ:		LDI	1		; each relational operator
		JMP	CMP		; loads a number used later
NEQ:		LDI	2		; as a case selector, after
		JMP	CMP		; the two operands are compared
LSS:		LDI	3		; based on the comparison
		JMP	CMP		; flags are set that
LEQ:		LDI	4		; are equivalent to those set
		JMP	CMP		; by the 'CMP' instruction in
GTR:		LDI	5		; the PDP-11. these pseudo-
		JMP	CMP		; flags are used to determine
GEQ:		LDI	6		; whether the particular
					; relation is satisfied or not
CMP:		ST	NUM(P2)
		LDI	/AESTK	; set P3 -> arithmetic stack
		XPAH	P3
		DLD	LSTK(P2)
		DLD	LSTK(P2)
		XPAL	P3
		SCL
		LD	-2(P3)	; subtract the two operands,
		CAD	(P3)		; storing result in lo & hi
		ST	LO(P2)
		LD	-1(P3)
		CAD	1(P3)
		ST	HI(P2)
		XOR	-1(P3)	; overflow occurs if signs of
		XAE			; result and 1st operand
		LD	-1(P3)	; differ, and signs of the
		XOR	1(P3)		; two operands differ
		ANE			; bit 7 equivalent to V flag
		XOR	HI(P2)	; bit 7 equivalent to N XOR V
		ST	TEMP(P2)	; store in temp
		LD	HI(P2)	; determine if result was zero
		OR	LO(P2)
		JZ	SETZ		; if result=0, SET Z flag
		LDI	$80		; else clear Z flag
SETZ:		XRI	$80
		XAE			; bit 7 of EX = Z flag
		DLD	NUM(P2)	; test for =
		JNZ	NEQ1
		LDE			; equal if Z = 1
		JMP	CMP1
X12:		JMP	X11
NEQ1:		DLD	NUM(P2)	; test for <>
		JNZ	LSS1
		LDE			; not equal if Z = 0
		XRI	$80
		JMP	CMP1
LSS1:		DLD	NUM(P2)	; test for <
		JNZ	LEQ1
		LD	TEMP(P2)	; less than if (N XOR V)=l
		JMP	CMP1
LEQ1:		DLD	NUM(P2)	; test for <=
		JNZ	GTR1
		LDE			; less than or equal
		OR	TEMP(P2)	; if (Z OR (N XOR V))=l
		JMP	CMP1
GTR1:		DLD	NUM(P2)	; test for >
		JNZ	GEQ1
		LDE			; greater than
		OR	TEMP(P2)	; if (Z OR (N XOR V))=0
		XRI	$80
		JMP	CMP1
GEQ1:		LD	TEMP(P2)	; greater than or equal
		XRI	$80		; if (N XOR V)=0
CMP1:		JP	FALSE_	; is relation satisfied ?
		LDI	1		; yes - push 1 on stack
		JMP	CMP2
FALSE_:	LDI	0		; no - push 0 on stack
CMP2:		ST	-2(P3)
		LDI	0 
		ST	-1(P3)
		JS	P3,RTN	; do an Intermediate Language return
		JMP	X12
;
;************************************
;*	IF Statement Test for Zero	*
;************************************
;
CMPR:		LD	LO(P2)	; get low & hi bytes of expression
		.DO	FIX1=1	; NIBL-E late change
		ANI	$01		; test if expression is zero
		.EL
		OR	HI(P2)	; test if expression is zero
		.FI
		JZ	FAIL		; yes - it is
		JMP	X12		; no - it isn't so continue
FAIL:		LD	@1(P1)	; skip to next line in program
		XRI	$0D		; (i.e. til next CR)
		JNZ	FAIL
		JS	P3,NXT	; call NXT and return
X12A:		JMP	X12
;
;************************
;*	AND, OR, & NOT	*
;************************
;
ANDOP:	LDI	1		; each operation has its
		JMP	LOGAND	; own case selector
OROP:		LDI	2
		JMP	LOGAND
NOTOP:	LDI	3
LOGAND:	ST	NUM(P2)
		LDI	/AESTK	; set P3 -> arithmetic stack
		XPAH	P3
		DLD	LSTK(P2)
		DLD	LSTK(P2)
		XPAL	P3
		DLD	NUM(P2)	; test for AND
		JNZ	LOGOR
		LD	1(P3)		; replace two top items on
		AND	-1(P3)	; stack by their AND
		ST	-1(P3)
		LD	0(P3)
		AND	-2(P3)
		ST	-2(P3)
		JMP	X12A
LOGOR:	DLD	NUM(P2)	; test for OR
		JNZ	LOGNOT
		LD	1(P3)		; replace two top items on
		OR	-1(P3)	; stack by their OR
		ST	-1(P3)
		LD	0(P3)
		OR	-2(P3)
		ST	-2(P3)
		JMP	X12A
LOGNOT:	LD	@1(P3)	; NOT operation
		XRI	$FF
		ST	-1(P3)	; replace top item on stack
		LD	@1(P3)	; by its one's complement
		XRI	$FF
		ST	-1(P3)
		XPAL	P3
		ST	LSTK(P2)	; stack pointer fixup
X12B:		JMP	X12A
;
;************************************
;*	Exchange Cursor with RAM	*
;************************************
;
XCHGP1:	LD	P1LOW(P2)	; this routine is handy when
		XPAL	P1		; executing an 'input' statement
		ST	P1LOW(P2)	; it exchanges the current
		LD	P1HIGH(P2)	; text cursor with one saved
		XPAH	P1		; in RAM
		ST	P1HIGH(P2)
		XPPC	P3
;
;************************
;*	Check Run Mode	*
;************************
;
CKMODE:	LD	RUNMOD(P2)	; this routine causes an error
		JZ	CK1		; if currently in edit mode
		XPPC	P3
CK1:		LDI	3
E8:		ST	NUM(P2)	; error if run mode = 0
		JS	P3,ERR2	; minor kluge
;
;************************************
;*	Get Hexadecimal Number		*
;************************************
;
HEX:		ILD	LSTK(P2)	; point P3 at arithmetic stack
		ILD	LSTK(P2)
		XPAL	P3
		LDI	/AESTK
		XPAH	P3
		LDI	0		; number initially zero
		ST	-1(P3)	; put it on stack
		ST	-2(P3)
		ST	NUM(P2)	; zero number of digits
HSKIP:	LD	@1(P1)	; skip any spaces
		XRI	' '
		JZ	HSKIP
		LD	@-1(P1)
LOOP7:	LD	(P1)		; get a character
		SCL
		CAI	'9'+1		; check for a numeric character
		JP	HLETR
		SCL
		CAI	'0'-'9'-1	; if numeric, shift number
		JP	HENTER	; and add new hex digit
		JMP	HEND
X12C:		JMP	X12B
HLETR:	SCL			; check for hex letter
		CAI	'G'-'9'-1
		JP	HEND
		SCL
		CAI	'A'-'G'
		JP	HXOK
		JMP	HEND
HXOK:		CCL			; add 10 to get true value
		ADI	10		; of letter
HENTER:	XAE			; new digit in X register
		LDI	4		; set shift counter
		ST	TEMP(P2)
		ST	NUM(P2)	; digit count is non-zero
HSHIFT:	LD	-2(P3)	; shift number left by 4
		CCL
		ADD	-2(P3)
		ST	-2(P3)
		LD	-1(P3)
		ADD	-1(P3)
		ST	-1(P3)
		DLD	TEMP(P2)
		JNZ	HSHIFT
		LD	-2(P3)	; add new digit
		ORE			; into number
		ST	-2(P3)
		LD	@1(P1)	; advance the cursor
		JMP	LOOP7		; get next character
HEND:		LD	NUM(P2)	; check if there were
		JNZ	X12B		; more than 0 characters
		LDI	5		; error if there were none
E8B:		JMP	E8
;
;************************************
;*	Test For Number in Text		*
;************************************
;
; this routine tests for a number in the text.  If no number
; is found, Intermediate Language control passes to the address
; indicated in the TSTN instruction.  Otherwise, the
; number is scanned and put on the arithmetic stack, with
; Intermediate Language control passing to the next instruction.
;
TSTNUM:	LD	@1(P1)
		XRI	' '		; skip over any spaces
		JZ	TSTNUM
		LD	@-1(P1)	; get first character
		SCL			; test for digit
		CAI	'9'+1
		JP	TNABRT
		SCL
		CAI	'0'-'9'-1
		JP	TN1
TNABRT:	LD	PCLOW(P2)	; get test-fail address
		XPAL	P3		; from Intermediate Language table
		LD	PCHIGH(P2)
		XPAH	P3
		LD	(P3)		; put test-fail address
		ST	PCHIGH(P2)	; into Intermediate language PC
		LD	1(P3)
		ST	PCLOW(P2)
		JMP	X12C
TNRET:	LDI	2		; skip over one Intermediate language instruction
		CCL			; if number is done
		ADD	PCLOW(P2)
		ST	PCLOW(P2)
		LDI	0
		ADD	PCHIGH(P2)
		ST	PCHIGH(P2)
X13:		JMP	X12C
ESA:		JMP	E8B
TN1:		XAE			; save digit in X register
		LDI	/AESTK	; point P3 at Arithmetic Stack
		XPAH	P3
		ILD	LSTK(P2)
		ILD	LSTK(P2)
		XPAL	P3
		LDI	0
		ST	-1(P3)
		LDE
		ST	-2(P3)
LOOP8:	LD	@1(P1)	; get next character
		LD	(P1)
		SCL			; test if it is digit
		CAI	'9'+1
		JP	TNRET		; return if it isn't
		SCL
		CAI	'0'-'9'-1
		JP	TN2
		JMP	TNRET
TN2:		XAE			; save digit
		LD	-1(P3)	; put result in scratch space
		ST	1(P3)
		LD	-2(P3)
		ST	(P3)
		LDI	2
		ST	TEMP(P2)	; multiply result by 10
TNSHFT:	CCL			; first multiply by 4
		LD	-2(P3)
		ADD	-2(P3)
		ST	-2(P3)
		LD	-1(P3)
		ADD	-1(P3)
		ST	-1(P3)
	.DO	SOURCE=0		; (National Semiconductor source only)
		ANI	$80		; make sure no overflow
		JNZ	TNERR		; occurred
	.FI
		DLD	TEMP(P2)
		JNZ	TNSHFT
		CCL			; then add old result,
		LD	 -2(P3)	; so we have result * 5
		ADD	(P3)
		ST	 -2(P3)
		LD	 -1(P3)
		ADD	1(P3)
		ST	 -1(P3)
	.DO	SOURCE=0		; (National Semiconductor source only)
		ANI	$80		; make sure no overflow
		JNZ	TNERR		; occurred
	.FI
		CCL			; then multiply by two
		LD	-2(P3)
		ADD	-2(P3)
		ST	-2(P3)
		LD	-1(P3)
		ADD	-1(P3)
		ST	-1(P3)
	.DO	SOURCE=0		; (National Semiconductor source only)
		ANI	$80		; make sure no overflow
		JNZ	TNERR		; occurred
	.FI
		CCL			; THEN ADD IN NEW DIGIT
		LDE
		ADD	-2(P3)
		ST	-2(P3)
		LDI	0
		ADD	-1(P3)
		ST	-1(P3)
		JP	LOOP8		; repeat if no overflow
TNERR:	LDI	6
E9:		JMP	ESA		; else report error
X14:		JMP	X13
;
;************************************
;*	Get Line From Teletype		*
;************************************
;
GETL:		>LDPI	P1,LBUF	; set P1 TO LBUF
		LDI	0		; clear number of characters
		ST	CHRNUM(P2)
		>LDPI	P3,PUTC-1	; point P3 at PUTC routine
		LD	RUNMOD(P2)	; print '? ' if running
		JZ	GETL0		; (i.e. during INPUT)
		LDI	'?'
		XPPC	P3
		LDI	' '
		XPPC	P3
		JMP	GETL1
		.DO	NIBL=0	; (NIBL)
GETL0:	LDI	'>'		; otherwise print '>'
	.EL				; (NIBL-E)
		.DO	FIX3=0	; FIX3 changes original NIBL-E cursor from < to >
GETL0:	LDI	'<'		; otherwise print '<' (original NIBL-E cursor)
		.EL
GETL0:	LDI	'>'		; otherwise print '>' (alternative NIBL-E cursor)
		.FI
	.FI
		XPPC	P3   
GETL1:	JS	P3,GECO	; get character
		LDI	PUTC-1	; point P3 at PUTC again
		XPAL	P3
		LDE			; get typed character
		JZ	GETL1		; ignore nulls
		XRI	$0A		; ignore line feed
		JZ	GETL1
		LDE
		XRI	$0D		; check for CR
		JZ	GETLCR
		LDE
		XRI	'O'+$10	; check for shift/O
		JZ	GETRUB
		LDE			; check for ctrl/H
		XRI	8
		JZ	GXH
		LDE
		XRI	$15		; check for ctrl/U
		JZ	GXU
		LDE
		XRI	3		; check for ctrl/C
		JNZ	GENTER
		LDI	'^'		; echo control/C as ^C
		XPPC	P3
		LDI	'C'
		XPPC	P3
		LDI	14		; cause a break
		JMP	E9
GXU:		LDI	'^'		; echo control/U as ^U
		XPPC	P3
		LDI	'U'
		XPPC	P3
		LDI	$0D		; print CR/LF
		XPPC	P3
		LDI	$0A
		XPPC	P3
		JMP	GETL		; go get another line
X15:		JMP	X14
GENTER:	LDE
		ST	@1(P1)	; put character in LBUF
		ILD	CHRNUM(P2)	; increment CHRNUM
		XRI	72		; if=72, line full
		JNZ	GETL1
		LDI	$0D
		XAE			; save Carriage Return
		LDE
		XPPC	P3		; print it
		JMP	GETLCR	; store it in LBUF
E10:		JMP	E9
GXH:		LDI	' '		; blank out the character
		XPPC	P3
		LDI	8		; print another backspace
		XPPC	P3
GETRUB:	LD	CHRNUM(P2)
		JZ	GETL1
		DLD	CHRNUM(P2)	; one less character
		LD	@-1(P1)	; backspace cursor
		JMP	GETL1
GETLCR:	LDE
		ST	@1(P1)	; store CR in LBUF
		LDI	$0A		; print line feed
		XPPC	P3
		LDI	/LBUF		; set P1 to beginning of LBUF
		XPAH	P1
		LDI	LBUF
		XPAL	P1
X16:		JMP	X15
;
;************************************
;*	EVAL -- Get Memory Contents	*
;************************************
;
; This routine implements the '@' operator in expressions
;
EVAL:		LDI	/AESTK
		XPAH	P3
		LD	LSTK(P2)
		XPAL	P3		; P3 -> arithmetic stack
		LD	-1(P3)	; get address off stack,
		XPAH	P1		; and into P1,
		XAE			; saving old P1 in X & LO
		LD	-2(P3)
		XPAL	P1
		ST	LO(P2)
		LD	0(P1)		; get memory contents,
		ST	-2(P3)	; shove onto stack
		LDI	0
		ST	-1(P3)	; high order 8 bits zeroed
		LD	LO(P2)
		XPAL	P1		; restore original P1
		LDE
		XPAH	P1
		JMP	X15
;
;************************************
;*	MOVE -- Store Into Memory	*
;************************************
;
; This routine implements the statement:
;	'@' factor '=' REL-EXP
;
MOVE:		LDI	/AESTK
		XPAH	P3
		LD	LSTK(P2)
		XPAL	P3		; P3 -> arithmetic stack
		LD	@-2(P3)	; get byte to be moved
		XAE
		LD	@-1(P3)	; now get address into P3
		ST	TEMP(P2)
		LD	@-1(P3)
		XPAL	P3
		ST	LSTK(P2)	; stack pointer updated now
		LD	TEMP(P2)
		XPAH	P3
		LDE
		ST	0(P3)		; move the  byte into memory
X17:		JMP	X16
Ell:		JMP	E10
;
;************************
;*	Text Editor		*
;************************
;
; Inputs to this routine: pointer to line buffer in P1LOW &
; P1HIGH.  P1 points to the insertion point in the text.
; the Arithmetic Stack has the line number on it (stack pointer
; is already popped).
;
; Each line in the NIBL text is stored in the following
; format: two bytes containing the line number (in binary,
; high order byte first), then one byte containing the
; length of the line, and finally the line itself followed
; by a carriage return.  the last line in the text is
; followed by two consecutive bytes of x'FF.
;
INSRT:	LDI	/AESTK	; point P3 at Arithmetic Stack,
		XPAH	P3		; which has the line number on it
		LD	LSTK(P2)
		XPAL	P3
		LD	1(P3)		; save new line's number
		ST	HILINE(P2)
		LD	0(P3)
		ST	LOLINE(P2)
		LD	P1LOW(P2)	; put pointer to LBUF into P3
		XPAL	P3
		LD	P1HIGH(P2)
		XPAH	P3
		LDI	4		; initially length of new line
		ST	CHRNUM(P2)	; = 4. add 1 to length for
INSRT1:	LD	@1(P3)	; each character in line up to, but
		XRI	$0D		; not including, carriage return
		JZ	INSRT2
		ILD	CHRNUM(P2)
		JMP	INSRT1
INSRT2:	LD	CHRNUM(P2)	; if length still 4, we'll delete
		XRI	4		; a line, so set length = 0
		JNZ	INSRT3
		ST	CHRNUM(P2)
INSRT3:	LD	CHRNUM(P2)	; put new line length in X
		XAE
		LD	LABLHI(P2)	; is new line replacing old ?
		JP	INSRT4	; yes - do replace
		ANI	$7F		; no - we'll insert line here,
		ST	LABLHI(P2)	; where FNDLBL got us
		JMP	AMOVE		; but first make room
INSRT4:	LD	@3(P1)	; skip line number and length
		LDE			; X now holding new line
		CCL			; length, will soon hold
		ADI	-4		; displacement of lines
		XAE			; to be moved
INSRT5:	LD	@1(P1)	; subtract 1 from displacement
		XRI	$0D		; for each characte in line being
		JZ	AMOVE		; replaced
		LDE
		CCL
		ADI	-1
		XAE
		JMP	INSRT5
X19:		JMP	X17
E12:		JMP	Ell
AMOVE:	LDE			; if displacement and length
		OR	CHRNUM(P2)	; of new line are 0, return
		JZ	X19
		LDI	DOSTAK	; clear some stacks
		ST	DOPTR(P2)
		LDI	SBRSTK
		ST	SBRPTR(P2)
		LDI	FORSTK
		ST	FORPTR(P2)
		LDE
		JZ	INSAD0	; don't need to move lines
		JP	INSUP0	; skip if displacement positive
ADOWN:	LD	0(P1)		; negative displacement:
		ST	E(P1)		; do;
		LD	@1(P1)	; M(P1+Disp) = M(P1);
		JP	ADOWN		; P1 = P1+1;
		LD	0(P1)		; until M(P1)<0 & M(P1-1)<0;
		JP	ADOWN
		ST	E(P1)		; M(P1+Disp) = M(P1);
		JMP	INSAD0
INSUP0:	LD	-2(P1)	; positive displacement:
		ST	TEMP(P2)	; flag beginning of move with
		LDI	-1		; A -1 followed by 80, which
		ST	-2(P1)	; can never appear in a
		LDI	80		; NIBL text
		ST	-1(P1)
INSUP1:	LD	@1(P1)	; advance P1 to end of text
		JP	INSUP1
		LD	0(P1)
		JP	INSUP1
		XPAH	P1		; save P1 in LO, HI
		ST	HI(P2)
		XPAH	P1   
		XPAL	P1
		ST	LO(P2)
		XPAL	P1
		LD	LO(P2)	; add displacement to
		CCL			; value of P1, to check
		ADE			; whether we're out of
		LDI	0		; RAM for user's program
		ADD	HI(P2)
		XOR	HI(P2)
		ANI	$F0
		JZ	INSUP2
		LDI	0		; if out of RAM, change
		XAE			; displacement to zero
INSUP2:	LDI	-1
INSUP3:	ST	E(P1)		; move text up until we reach
		LD	@-1(P1)	; the flags set above
		JP	INSUP3
		LD	1(P1)
		XRI	80
		JZ	INSUP4
		LD	0(P1)
		JMP	INSUP3
INSUP4:	LD	TEMP(P2)	; restore the flagged location
		ST	0(P1)		; to their original values
		LDI	$0D
		ST	1(P1)
		LDE			; if displacement = 0, we're
		JNZ	INSAD0	; out of RAM, so report error
		LDI	2
E12A:		JMP	E12
INSAD0:	LD	CHRNUM(P2)	; insert new line
X19A:		JZ	X19		; unless length is zero
		LD	P1LOW(P2)	; point P1 at line buffer
		XPAL	P1
		LD	P1HIGH(P2)
		XPAH	P1
		LD	LABLLO(P2)	; point P3 at insertion place
		XPAL	P3
		LD	LABLHI(P2)
		XPAH	P3
		LD	HILINE(P2)	; put line number into text
		ST	@1(P3)
		LD	LOLINE(P2)
		ST	@1(P3)
		LD	CHRNUM(P2)	; store line length in text
		ST	@1(P3)
INSAD1:	LD	@1(P1)	; put rest of characters
		ST	@1(P3)	; (including or) into text
		XRI	$0D
		JNZ	INSAD1
		JMP	X19A		; return
X20:		JS	P3,EXECIL
E13:		JMP	E12A
; 
;******************************
;*	POP Arithmetic Stack	*
;******************************
;
POPAE:	DLD	LSTK(P2)	; this routine POP the AE
		DLD	LSTK(P2)	; stack, and puts the result
		XPAL	P3		; into LO(P2) and HI(P2)
		LDI	/AESTK
		XPAH	P3
		LD	(P3)
		ST	LO(P2)
		LD	1(P3)
		ST	HI(P2)
		JMP	X20
;
;******************
;*	UNTIL		*
;******************
;
UNTIL:	LD	DOPTR(P2)	; check for DO stack underflow
		XAE
		LDE 
		XRI	DOSTAK
		JNZ	UNTL1
		LDI	15
		JMP	E13
UNTL1:	LD	LO(P2)	; check for expression = 0
		.DO	FIX1=1
		ANI	01
		.EL
		OR	HI(P2)
		.FI
		JZ	SREDO		; if zero, repeat DO loop
		DLD	DOPTR(P2)	; else POP save stack
		DLD	DOPTR(P2)
		JMP	X20		; continue to next statement
SREDO:	LDE			; point P3 at DO stack
		XPAL	P3
		LDI	/DOSTAK
		XPAH	P3
		LD	-1(P3)	; load P1 from DO stack
		XPAH	P1
		LD	-2(P3)
		XPAL	P1		; cursor now points to first
		JMP	X20		; statement of DO loop
;
;************************************
;*	Store Into Status Register	*
;************************************
;
; this routine implements the statement:
;	STAT = REL-EXP
;
MOVESR:	LD	LO(P2)	; low byte goes to status
		ANI	$F7		; but with ien bit cleared
		CAS
X21:		JMP	X20
E14:		JMP	E13
;
;************************
;*	STAT function	*
;************************
;
STATUS:	LDI	/AESTK
		XPAH	P3		; point P3 at Arithmetic Stack
		ILD	LSTK(P2)
		ILD	LSTK(P2)
		XPAL	P3
		CSA
		ST	-2(P3)	; status register is low byte
		LDI	0
		ST	-1(P3)	; zero is high byte
		JMP	X21
; 
;************************************
;*	Machine Language Subroutine	*
;************************************
;
; This Routine Implements the LINK statement
;
CALLML:	LD	HI(P2)	; get high byte of address
		XPAH	P3
		LD	LO(P2)	; get low byte
		XPAL	P3		; P3 -> user's routine
		LD	@-1(P3)	; correct P3
		XPPC	P3		; Call routine (pray it works)
REST:		>LDPI	P2,VARS	; restore RAM pointer
		JMP	X21		; return
;
;******************************
;*	Save DO Loop Address	*
;******************************
;
; This Routine Implements the DO statement
;
SAVEDO:	LD	DOPTR(P2)	; check for stack overflow
		XRI	FORSTK
		JNZ	SAVED1
		LDI	10
E15:		JMP	E14
SAVED1:	ILD	DOPTR(P2)
		ILD	DOPTR(P2)
		XPAL	P3
		LDI	/DOSTAK
		XPAH	P3		; P3 -> top of DO stack
		XPAH	P1		; save cursor on the stack
		ST	-1(P3)
		XPAH	P1
		XPAL	P1
		ST	-2(P3)
		XPAL	P1
X22:		JMP	X21
;
;******************************
;*	Top of RAM function	*
;******************************
;
TOP:		LD	TEMP2(P2)	; set P3 to point to
		XPAH	P3		; start of NIBL text
		LD	TEMP3(P2)
		XPAL	P3
TOP0:		LD	(P3)		; have we hit end of text ?
		JP	TOP1		; no - skip to next line
		JMP	TOP2		; yes - put cursor on stack
TOP1:		LD	2(P3)		; get length of line
		XAE
		LD	@E(P3)	; skip to next line
		JMP	TOP0		; go check for EOF
TOP2:		LD	@2(P3)	; P3 := P3 + 2
		ILD	LSTK(P2)	; set P3 to stack, saving
		ILD	LSTK(P2)	; old P3 (which contains TOP)
		XPAL	P3		; on it somehow
		XAE
		LDI	/AESTK
		XPAH	P3
		ST	-1(P3)
		LDE
		ST	-2(P3)
		JMP	X22
;
;************************************
;*	Skip to Next NIBL Line		*
;************************************
;
IGNORE:	LD	@1(P1)	; scan til we're past
		XRI	$0D		; carriage return
		JNZ	IGNORE
		XPPC	P3		; yes - return
;
;************************
;*	MODULO Function	*
;************************
;
MODULO:	LD	LSTK(P2)	; this routine must be
		XPAL	P3		; immediately after a
		LDI	/AESTK	; divide to work correctly
		XPAH	P3
		LD	3(P3)		; get low byte of remainder
		ST	-2(P3)	; put on stack
		LD	2(P3)		; get high byte of remainder
		ST	-1(P3)	; put on stack
X23:		JMP	X22
E16:		JMP	E15
;
;************************
;*	RANDOM Function	*
;************************
;
RANDOM:	LDI	8		; loop counter for multiply
		ST	NUM(P2)
		LD	RNDX(P2)
		XAE
		LD	RNDY(P2)
		ST	TEMP2(P2)
LOOP9:	LD	RNDX(P2)	; multiply the seeds by 9
		CCL
		ADE
		XAE
		LD	RNDY(P2)
		CCL
		ADD	TEMP2(P2)
		ST	RNDY(P2)
		DLD	NUM(P2)
		JNZ	LOOP9
		LDE			; add 7 to seeds
		CCL
		ADI	7
		XAE
		LD	RNDY(P2)
		CCL
		ADI	7
		RR
		ST	RNDY(P2)
		ILD	RNDF(P2)	; have we gone through
		JZ	RND1		; 256 generations ?
		LDE			; if so, skip generating
		ST	RNDX(P2)	; the new RNDX
RND1:		LD	LSTK(P2)	; start messing with the stack
		XPAL	P3
		LDI	/AESTK
		XPAH	P3
		LDI	1		; first put 1 on stack
		ST	(P3)
		LDI	0
		ST	1(P3)
		LD	-2(P3)	; put EXPR2 on stack
		ST	2(P3)
		LD	-1(P3)
		ST	3(P3)
		LD	-4(P3)	; put EXPR1 on stack
		ST	4(P3)
		LD	-3(P3)
		ST	5(P3)
		LD	RNDY(P2)	; put random number on stack
		ST	-2(P3)
		LD	RNDX(P2)
		XRI	$FF
		ANI	$7F
		ST	-1(P3)
		LD	@6(P3)	; add 6 to stack pointer
		XPAL	P3
		ST	LSTK(P2)
X24:		JMP	X23
E16A:		JMP	E16
;
;************************************
;*	PUSH 1 On Arithmetic Stack	*
;************************************
;
LIT1:		ILD	LSTK(P2)
		ILD	LSTK(P2)
		XPAL	P3
		LDI	/AESTK
		XPAH	P3
		LDI	0
		ST	-1(P3)
		LDI	1
		ST	-2(P3)
		JMP	X24
;
;************************************
;*	FOR Loop Initialisation		*
;************************************
;
SAVFOR:	LD	FORPTR(P2)	; check for for stack overflow
		XRI	PCSTAK
		JNZ	SFOR1
		LDI	10
E17:		JMP	E16A
SFOR1:	XRI	PCSTAK
		XPAL	P1		; point P1 at for stack
		ST	P1LOW(P2)	; saving old P1
		LDI	/FORSTK
		XPAH	P1
		ST	P1HIGH(P2)
		LD	LSTK(P2)	; point P3 at Arithmetic Stack
		XPAL	P3
		LDI	/AESTK
		XPAH	P3
		LD	-7(P3)	; get variable index
		ST	@1(P1)	; save on FOR stack
		LD	-4(P3)	; get L(LIMIT)
		ST	@1(P1)	; save
		LD	-3(P3)	; get H(LIMIT)
		ST	@1(P1)	; save
		LD	-2(P3)	; get L(STEP)
		ST	@1(P1)	; save
		LD	-1(P3)	; get H(STEP)
		ST	@1(P1)	; save
		LD	P1LOW(P2)	; get L(P1)
		ST	@1(P1)	; save
		LD	P1HIGH(P2)	; get H(P1)
		ST	@1(P1)	; save
		XPAH	P1		; restore old P1
		LD	P1LOW(P2)
		XPAL	P1
		ST	FORPTR(P2)	; update por stack pointer
		LD	@-4(P3)
		XPAL	P3
		ST	LSTK(P2)	; update Arithmetic Stack pointer
X25:		JMP	X24
;
;************************************
;*	First Part of NEXT Variable	*
;************************************
;
NEXTV:	LD	FORPTR(P2)	; point P1 at FOR stack,
		XRI	FORSTK	; checking for underflow
		JNZ	QNXTV1
		LDI	11		; report error
		JMP	E17
QNXTV1:	XRI	FORSTK
		XPAL	P1
		ST	P1LOW(P2)	; save old P1
		LDI	/FORSTK
		XPAH	P1
		ST	P1HIGH(P2) 
		LD	LSTK(P2)	; point P3 at Arithmetic Stack
		XPAL	P3
		LDI	/AESTK
		XPAH	P3
		LD	@-1(P3)	; get variable index
		XOR	-7(P1)	; compare with index
		JZ	NXTV10	; on FOR stack: error
		LDI	12		; if not equal
E18:		JMP	E17
NXTV10:	XOR	-7(P1)	; restore index
		XAE			; save in E
		LD	E(P2)		; get L(VARIABLE)
		CCL
		ADD	-4(P1)	; add L(STEP)
		ST	E(P2)		; store in variable
		ST	(P3)		; and on stack
		LD	@1(P2)	; increment RAM pointer
		LD	E(P2)		; get H(VARIABLE)
		ADD	-3(P1)	; add H(STEP)
		ST	E(P2)		; store in variable
		ST	1(P3)		; and on stack
		LD	@-1(P2)	; restore RAM pointer
		LD	-6(P1)	; get L(LIMIT)
		ST	2(P3)		; put on stack
		LD	-5(P1)	; get H(LIMIT)
		ST	3(P3)		; put on stack
		LD	-3(P1)	; get H(STEP)
		JP	NXTV2		; if negative, invert
		LDI	4		; ITEMS ON A.E. STACK
		ST	NUM(P2)	; NUM = loop counter
LOOP10:	LD	@1(P3)	; get byte from stack
		XRI	$FF		; invert it
		ST	-1(P3)	; put back on stack
		DLD	NUM(P2)	; do until NUM = 0
		JNZ	LOOP10
		JMP	NXTV3
NXTV2:	LD	@4(P3)	; update Arithmetic Stack pointer
NXTV3:	XPAL	P3
		ST	LSTK(P2)
		LD	P1LOW(P2)	; restore old P1
		XPAL	P1
		LD	P1HIGH(P2)
		XPAH	P1
X26:		JMP	X25
;
;************************************
;*	Second Part of NEXT Variable	*
;************************************
;
NEXTV1:	LD	LO(P2)	; is FOR loop over with ?
		JZ	LREDO		; no - repeat loop
		LD	FORPTR(P2)	; yes - pop FOR stack
		CCL
		ADI	-7
		ST	FORPTR(P2)
		XPPC	P3		; RETURN TO Intermediate Language interpreter
LREDO:	LD	FORPTR(P2)	; point P3 at FOR stack
		XPAL	P3
		LDI	/FORSTK
		XPAH	P3
		LD	-1(P3)	; get old P1 off stack
		XPAH	P1
		LD	-2(P3)
		XPAL	P1
		JMP	X26
E19:		JMP	E18
;
;************************************
;*	Print Memory As String		*
;************************************
;
; This routine implements the statement:
;	PRINT '$' factor
;
PSTRNG:	LD	HI(P2)	; point P1 at string to print
		XPAH	P1
		LD	LO(P2)
		XPAL	P1
		>LDPI	P3,PUTC-1	; point P3 at PUTC routine
PRSTR1:	LD	@1(P1)	; get a character
		XRI	$0D		; is it a carriage return ?
		JZ	X26		; yes - we're done
		XRI	$0D		; no - print the character
		XPPC	P3
		CSA			; make sure no one is
		ANI	$20		; typing on the tty
		JNZ	PRSTR1	; before repeating loop
		JMP	X26
;
;************************
;*	Input a String	*
;************************
;
; This routine implements the statement:
;	INPUT $ factor
;
ISTRNG:	LD	HI(P2)	; get address to store the
		XPAH	P3		; string, put it into P3
		LD	LO(P2)
		XPAL	P3
ISTRG2:	LD	@1(P1)	; get a byte from line buffer
		ST	@1(P3)	; put it in specified location
		XRI	$0D		; do until character = carriage return
		JNZ	ISTRG2
X27:		JMP	X26
;
;************************************
;*   String Constant Assignment	*
;************************************
;
; This routine implements the statement:
;	$ factor = string
;
PUTSTR:	LD	LO(P2)	; get address to store string,
		XPAL	P3		; put it into P3
		LD	HI(P2)
		XPAH	P3
LOOP11:	LD	@1(P1)	; get a byte from string
		XRI	'"'		; check for end of string
		JZ	STREND
		XRI	'"'^$0D	; make sure there's no cr
		JNZ	PTSTR1
		LDI	7
		JMP	E19		; error if carriage return
PTSTR1:	XRI	$0D		; restore character
		ST	@1(P3)	; put in specified location
		JMP	LOOP11	; get next character
STREND:	LDI	$0D		; append carriage return
		ST	(P3)		; to string
		JMP	X27
;
;************************
;*	Move String		*
;************************
;
; This routine implements the statement:
;	$ factor = $ factor
;
MOVSTR:	LD	LSTK(P2)	; point P3 at Arithmetic Stack
		XPAL	P3
		LDI	/AESTK
		XPAH	P3
		LD	@-1(P3)	; get address of source string
		XPAH	P1		; into P1
		LD	@-1(P3)
		XPAL	P1
		LD	@-1(P3)	; get address of destination
		XAE			; string into P3
		LD	@-1(P3)
		XPAL	P3
		ST	LSTK(P2)	; update stack pointer
		LDE
		XPAH	P3
LOOP12:	LD	@1(P1)	; get a source character
		ST	@1(P3)	; send it to destination
		XRI	$0D		; repeat until carriage return
		JZ	X27
		CSA			; or keyboard interrupt
		ANI	$20
		JNZ	LOOP12
		JMP	X27
;
;************************************
;*	Put PAGE Number On Stack	*
;************************************
;
PUTPGE:	ILD	LSTK(P2)
		ILD	LSTK(P2)
		XPAL	P3
		LDI	/AESTK
		XPAH	P3
		LD	PAGE(P2)
		ST	-2(P3)
		LDI	0
		ST	-1(P3)
		JMP	X27
;
;************************
;*	Assign New PAGE	*
;************************
;
NUPAGE:	LD	LO(P2)	; get PAGE number from stack,
	.DO	NIBL=0		; (NIBL)
		ANI	7		; get the low 3 bits
		JNZ	NUPGE0	; PAGE 0 becomes PAGE 1
		LDI	$1
NUPGE0:	ST	PAGE(P2)
		XPPC	P3		; return
	.EL				; (NIBL-E)
		ANI	6		; get the low 3 bits
		JZ	NUPGE0	; PAGE 0 becomes PAGE 1
		LD	LO(P2)
		ST	PAGE(P2)
NUPGE0:	XPPC	P3		; return
	.FI
;
;******************************
;*	Find Start Of PAGE	*
;******************************
;
; This routine computes the start of the current text PAGE,
; storing the address in TEMP2(P2) [the high byte], and
; TEMP3(P2) [the low byte].
;
FNDPGE: 	LD	PAGE(P2)
	.DO	NIBL=0		; (NIBL)
		XRI	1		; special case is PAGE 1, but
	.EL				; (NIBL-E)
		XRI	2		; special case is PAGE 2, but
	.FI
		JNZ	FPGE1		; others are conventional
		LDI	/PGM		; PAGE 1 starts at 'PGM'
		ST	TEMP2(P2)
		LDI	PGM
		ST	TEMP3(P2)
		XPPC	P3		; return
	.DO	NIBL=0		; (NIBL)
FPGE1:	XRI	1		; restore PAGE number
	.EL				; (NIBL-E)
FPGE1:	XRI	2		; restore PAGE number
	.FI
		XAE			; save it
		LDI	4		; LOPGMOP counter = 4
		ST	NUM(P2)
LOOP13:	LDE			; multiply PAGE number by 16
		CCL
		ADE
		XAE
		DLD	NUM(P2)
		JNZ	LOOP13
		LDE
		ST	TEMP2(P2)	; TEMP2 has high byte
		LDI	2		; of address now
		ST	TEMP3(P2)	; low byte is always 2
		XPPC	P3
;
;************************************
;*	Move Cursor To New PAGE		*
;************************************
;
CHPAGE:	LD	TEMP2(P2)	; put start of PAGE
		XPAH	P1		; into P1. this routine
		LD	TEMP3(P2)	; must be called right
		XPAL	P1		; after FNDPGE
		XPPC	P3		; return
;
;************************************
;*	Determine Current PAGE		*
;************************************
;
DETPGE:	XPAH	P1		; current PAGE is high
		XAE			; part of cursor divided
		LDE			; by 16
		XPAH	P1
		LDE
		SR
		SR
		SR
		SR
		ST	PAGE(P2)
		XPPC	P3		; return
; 
;******************************
;*	CLEAR CURRENT PAGE	*
;******************************
;
NEWPGM:	LD	TEMP2(P2)	; point P1 at current PAGE
		XPAH	P1
		LD	TEMP3(P2)
		XPAL	P1
		LDI	$0D		; put dummy end-of-line
		ST	-1(P1)	; just before text
		LDI	-1		; put -1 at start of text
		ST	(P1)
		ST	1(P1)
		XPPC	P3		; return
;
;************************************
;*	Find Line Number in Text	*
;************************************
;
; Inputs: the start of the current PAGE in TEMP2 and TEMPS,
;		the line number to look for in LO and HI.
; Ouputs: the address of the first line in the NIBL text
;		whose line number is greater than or equal to the
;		number in HI and LO, returned in P1 and also in
;		in the ram variables LABLLO and LABLHI.  the sign
;		bit of LABLHI is set if exact line is not found.
;
FNDLBL:	LD	TEMP2(P2)	; point P1 at start of text
		XPAH	P1
		LD	TEMP3(P2)
		XPAL	P1
FNLBL1:	LD	(P1)		; have we hit end of text ?
		XRI	$FF
		JP	FNLBL2	; yes - stop looking
		SCL			; no - compare line numbers
		LD	1(P1)		; by subtracting
		CAD	LO(P2)
		LD	0(P1)
		CAD	HI(P2)	; IS TEXT LINE number >= LINE number ?
		jp	fnlbl2	; yes - stop looking
		LD	2(P1)		; no - try next line in text
		XAE
		LD	@E(P1)	; skip length of line
		JMP	FNLBL1
FNLBL2:	XPAL	P1		; save address of found line
		ST	LABLLO(P2)	; in LABLHI and LABLLO
		XPAL	P1
		XPAH	P1
		ST	LABLHI(P2)
		XPAH	P1
		LD	LO(P2)	; was there an exact match ?
		XOR	1(P1)
		JNZ	FNLBL3
		LD	HI(P2)
		XOR	0(P1)
		JNZ	FNLBL3	; no - flag the address
		XPPC	P3		; yes - return normally
FNLBL3:	LD	LABLHI(P2)	; set sign bit of high part
		ORI	$80		; of address to indicate
		ST	LABLHI(P2)	; inexact match of line numbers
		XPPC	P3
;
;************************************
;*	Intermediate Language Macros	*
;************************************
;
TSTBITH	.EQ	TSTBIT*256
CALBITH	.EQ	CALBIT*256
JMPBITH	.EQ	JMPBIT*256
;
TSTR:		.MA	FAIL,TEXT
		.DR	]1&$0FFF^TSTBITH
		.AT	']2'
		.EM
;
TSTCR:	.MA	FAIL
		.DR	]1&$0FFF^TSTBITH
		.DB	$0D|$80
		.EM
;
TSTV:		.MA	FAIL
		.DR	TSTVAR-1
		.DR	]1
		.EM
;
TSTN:		.MA	FAIL
		.DR	TSTNUM-1
		.DR	]1
		.EM
;
JUMP:		.MA	ADR
		.DR	]1&$0FFF^JMPBITH
		.EM
;
CALL:		.MA	ADR
		.DR	]1&$0FFF^CALBITH
		.EM
;
DO:		.MA	ADRLIST (maximum 7)
		.DR	]1-1
		.XM	]#=1
		.DR	]2-1
		.XM	]#=2
		.DR	]3-1
		.XM	]#=3
		.DR	]4-1
		.XM	]#=4
		.DR	]5-1
		.XM	]#=5
		.DR	]6-1
		.XM	]#=6
		.DR	]7-1
		.XM	]#=7
		.EM 
;
;*****************8******************
;*	Intermediate Language TABLE	*
;************************************
;
START:	>DO		NLINE
PROMPT:	>DO		GETL
		>TSTCR	PRMPT1
		>JUMP		PROMPT
PRMPT1:	>TSTN		LIST
		>DO		FNDPGE,XCHGP1,POPAE,FNDLBL,INSRT
		>JUMP		PROMPT
LIST:		>TSTR		RUN,"LIST"
		>DO		FNDPGE
		>TSTN		LIST1
		>DO		POPAE,FNDLBL
		>JUMP		LIST2
LIST1:	>DO		CHPAGE
LIST2:	>DO		LST
LIST3:	>CALL		PRNUM
		>DO		LST3
		>JUMP		START
RUN:		>TSTR		CLR,"RUN"
		>DO		DONE
BEGIN:	>DO		FNDPGE,CHPAGE,STRT,NXT
CLR:		>TSTR		NEW,"CLEAR"
		>DO		DONE,CLEAR,NXT
NEW:		>TSTR		STMT,"NEW"
		>TSTN		DFAULT
		>JUMP		NEW1
DFAULT:	>DO		LIT1
NEW1:		>DO		DONE,POPAE,NUPAGE,FNDPGE,NEWPGM,NXT
STMT:		>TSTR		LET,"LET"
LET:		>TSTV		AT
		>TSTR		SYNTAX,'='
		>CALL		RELEXP
		>DO		STORE,DONE,NXT
AT:		>TSTR		IF,'@'
		>CALL		FACTOR
		>TSTR		SYNTAX,'='
		>CALL		RELEXP
		>DO		MOVE,DONE,NXT
IF:		>TSTR		UNT,"IF"
		>CALL		RELEXP
		>TSTR		IF1,"THEN"
IF1:		>DO		POPAE,CMPR
		>JUMP		STMT
UNT:		>TSTR		DOSTMT,"UNTIL"
		>DO		CKMODE
		>CALL		RELEXP
		>DO		DONE,POPAE,UNTIL,DETPGE,NXT
DOSTMT:	>TSTR		GOTO,"DO"
		>DO		CKMODE,DONE,SAVEDO,NXT
GOTO:		>TSTR		RETURN,"GO"
		>TSTR		GOSUB,"TO"
		>CALL		RELEXP
		>DO		DONE
		>JUMP		GO1
GOSUB:	>TSTR		SYNTAX,"SUB"
		>CALL		RELEXP
		>DO		DONE,SAV
GO1:		>DO		FNDPGE, POPAE,FNDLBL,XFER,NXT
RETURN:	>TSTR		NEXT,"RETURN"
		>DO		DONE,RSTR,DETPGE,NXT
NEXT:		>TSTR		FOR,"NEXT"
		>DO		CKMODE
		>TSTV		SYNTAX
		>DO		DONE,NEXTV
		>CALL		GTROP
		>DO		POPAE, NEXTV1,DETPGE,NXT
FOR:		>TSTR		STAT,"FOR"
		>DO		CKMODE
		>TSTV		SYNTAX
		>TSTR		SYNTAX,'='
		>CALL		RELEXP
		>TSTR		SYNTAX,"TO"
		>CALL		RELEXP
		>TSTR		FOR1,"STEP"
		>CALL		RELEXP
		>JUMP		FOR2
FOR1:		>DO		LIT1
FOR2:		>DO		DONE,SAVFOR,STORE,NXT
STAT:		>TSTR		PGE,"STAT"
		>TSTR		SYNTAX,'='
		>CALL		RELEXP
		>DO		POPAE,MOVESR
		>DO		DONE,NXT
PGE:		>TSTR		DOLLAR,"PAGE"
		>TSTR		SYNTAX,'='
		>CALL		RELEXP
		>DO		DONE,POPAE,NUPAGE,FNDPGE,CHPAGE,NXT
DOLLAR:	>TSTR		PRINT,'$'
		>CALL		FACTOR
		>TSTR		SYNTAX,'='
		>TSTR		DOLR1,'"'
		>DO		POPAE,PUTSTR
		>JUMP		DOLR2
DOLR1:	>TSTR		SYNTAX,'$'
		>CALL		FACTOR
		>DO		XCHGP1,MOVSTR,XCHGP1
DOLR2:	>DO		DONE,NXT
PRINT:	>TSTR		INPUT,"PR"
		>TSTR		PR1,"INT"
PR1:		>TSTR		PR2,'"'
		>DO		PRS
		>JUMP		COMMA
PR2:		>TSTR		PR3,'$'
		>CALL		FACTOR
		>DO		XCHGP1,POPAE,PSTRNG,XCHGP1
		>JUMP		COMMA
PR3:		>CALL		RELEXP
		>CALL		PRNUM
COMMA:	>TSTR		PR4,','
		>JUMP		PR1
PR4:		>TSTR		PR5,';'
		>JUMP		PR6
PR5:		>DO		NLINE
PR6:		>DO		DONE,NXT
INPUT:	>TSTR		END,"INPUT"
		>DO		CKMODE
		>TSTV		IN2
		>DO		XCHGP1,GETL
IN1:		>CALL		RELEXP
		>DO		STORE,XCHGP1
		>TSTR		IN3,','
		>TSTV		SYNTAX
		>DO		XCHGP1
		>TSTR		SYNTAX,','
		>JUMP		IN1
IN2:		>TSTR		SYNTAX,'$'
		>CALL		FACTOR
		>DO		XCHGP1,GETL,POPAE,ISTRNG,XCHGP1
IN3:		>DO		DONE,NXT
END:		>TSTR		ML,"END"
		>DO		DONE,BREAK
ML:		>TSTR		REM,"LINK"
		>CALL		RELEXP
		>DO		DONE,XCHGP1,POPAE,CALLML,XCHGP1,NXT
REM:		>TSTR		SYNTAX,"REM"
		>DO		IGNORE,NXT
SYNTAX:	>DO		ERR
ERRNUM:	>CALL		PRNUM
		>DO		FIN
;
; Note: each relational operator (EQ, LEQ, ETC.) does an
; automatic RTN (this saves valuable bytes !)
;
RELEXP:	>CALL		EXPR
		>TSTR		REL1,'='
		>CALL		EXPR
		>DO		EQ
REL1:		>TSTR		REL4,'<'
		>TSTR		REL2,'='
		>CALL		EXPR
		>DO		LEQ
REL2:		>TSTR		REL3,'>'
		>CALL		EXPR
		>DO		NEQ
REL3:		>CALL		EXPR
		>DO		LSS
REL4:		>TSTR		RETEXP,'>'
		>TSTR		REL5,'='
		>CALL		EXPR
		>DO		GEQ
REL5:		>CALL		EXPR
GTROP:	>DO		GTR
EXPR:		>TSTR		EX1,'-'
		>CALL		TERM
		>DO		NEG
		>JUMP		EX3
EX1:		>TSTR		EX2,'+'
EX2:		>CALL		TERM
EX3:		>TSTR		EX4,'+'
		>CALL		TERM
		>DO		ADD
		>JUMP		EX3
EX4:		>TSTR		EX5,'-'
		>CALL		TERM
		>DO		SUB
		>JUMP		EX3
EX5:		>TSTR		RETEXP,"OR"
		>CALL		TERM
		>DO		OROP
		>JUMP		EX3
RETEXP:	>DO		RTN
TERM:		>CALL		FACTOR
T1:		>TSTR		T2,'*'
		>CALL		FACTOR
		>DO		MUL
		>JUMP		T1
T2:		>TSTR		T3,'/'
		>CALL		FACTOR
		>DO		DIV  
		>JUMP		T1
T3:		>TSTR		RETEXP,"AND"
		>CALL		FACTOR
		>DO		ANDOP
		>JUMP		T1
FACTOR:	>TSTV		F1
		>DO		IND,RTN
F1:		>TSTN		F2
		>DO		RTN
F2:		>TSTR		F3,'#'
		>DO		HEX,RTN
F3:		>TSTR		F4,'('
		>CALL		RELEXP
		>TSTR		SYNTAX,')'
		>DO		RTN
F4:		>TSTR		F5,'@'
		>CALL		FACTOR
		>DO		EVAL,RTN
F5:		>TSTR		F6,"NOT"
		>CALL		FACTOR
		>DO		NOTOP,RTN
F6:		>TSTR		F7,"STAT"
		>DO		STATUS,RTN
F7:		>TSTR		F8,"TOP"
		>DO		FNDPGE,TOP,RTN
F8:		>TSTR		F9,"MOD"
		>CALL		DOUBLE
		>DO		DIV,MODULO,RTN
F9:		>TSTR		F10,"RND"
		>CALL		DOUBLE
		>DO		RANDOM,SUB,ADD,DIV,MODULO,ADD,RTN
F10:		>TSTR		SYNTAX,"PAGE"
		>DO		PUTPGE,RTN
DOUBLE:	>TSTR		SYNTAX,'('
		>CALL		RELEXP
		>TSTR		SYNTAX,','
		>CALL		RELEXP
		>TSTR		SYNTAX,')'
		>DO		RTN
PRNUM:	>DO		XCHGP1,PRN
PRNUM1:	>DO		DIV,PRN1,XCHGP1,RTN
;
;************************
;*	Error Messages	*
;************************
;
MESSAGE:	.MA	A,B
		 DB  A
		 DB  B|$80
		.EM
;
MESGS:	.AT " ERROR"	; 1
		.AT "AREA"		; 2
		.AT "STMT"		; 3
		.AT "CHAR"		; 4
		.AT "SNTX"		; 5
		.AT "VALU"		; 6
		.AT "END",'"'	; 7
		.AT "NOGO"		; 8
		.AT "RTRN"		; 9
		.AT "NEST"		; 10
		.AT "NEXT"		; 11
		.AT "FOR"		; 12
		.AT "DIV0"		; 13
		.AT "BRK"		; 14
		.AT "UNTL"		; 15
;
;************************************
;*	Get Character and Echo It	*
;************************************
;
GECO:		LDI	8		; set count = 8
		ST	NUM(P2)
		.DO	FIX4=0
		CSA			; set reader relay
			.DO	NIBL=0	; (NIBL)
			ORI	2
			.EL			; (NIBL-E)
			ORI	0
			.FI
		CAS
		.FI
GET1:		CSA			; wait for start bit
		ANI	$20
		JNZ	GET1		; not found
					; delay 1/2 bit time
		.DO	CPUCLK=2
			.DO	BAUD=110
			LDI	$57
			DLY	$04
			.FI
			.DO	BAUD=300
			LDI	$76
			DLY	$01
			.FI
			.DO	BAUD=600
			LDI	$A7
			DLY	$00
			.FI
			.DO	BAUD=1200
			LDI	$3D
			DLY	$00
			.FI
		.FI
		.DO	CPUCLK=4
			.DO	BAUD=110
			LDI	$C3
			DLY	$08
			.FI
			.DO	BAUD=300
			LDI	$29
			DLY	$03
			.FI
			.DO	BAUD=600
			LDI	$8A
			DLY	$01
			.FI
			.DO	BAUD=1200
			LDI	$BB
			DLY	$00
			.FI
			.DO	BAUD=2400
				.DO FIX2=0
				LDI	$57	; original values
				DLY	$04
				.EL
				LDI	$43	; values for FIX2
				DLY	$00
				.FI
			.FI
		.FI
		CSA			; is start bit still there ?
		ANI	$20
		JNZ	GET1		; no
		CSA			; send start bit
		.DO	FIX4=0
			.DO	NIBL=0	; (NIBL)
				ANI	$FD	; reset reader relay
			.EL			; (NIBL-E)
				ANI	$FF	; reset reader relay
			.FI
		.FI
		ORI	1
		CAS
GET2:					; delay one bit time
		.DO	CPUCLK=2
			.DO	BAUD=110
				.DO	SOURCE=0	; National Semiconductor source
				LDI	$7E
				DLY	$08
				.EL			; Dr. Dobbs source
				LDI	$85
				DLY	$08
				.FI
			.FI
			.DO	BAUD=300
			LDI	$E5
			DLY	$02
			.FI
			.DO	BAUD=600
			LDI	$45
			DLY	$01
			.FI
			.DO	BAUD=1200
			LDI	$76
			DLY	$00
			.FI
		.FI
		.DO	CPUCLK=4
			.DO	BAUD=110
			LDI	$45
			DLY	$11
			.FI
			.DO	BAUD=300
			LDI	$11
			DLY	$06
			.FI
			.DO	BAUD=600
			LDI	$D4
			DLY	$02
			.FI
			.DO	BAUD=1200
			LDI	$34
			DLY	$01
			.FI
			.DO	BAUD=2400
				.DO	FIX2=0
				LDI	$7E	; original values
				DLY	$08
				.EL
				LDI	$7A	; values for FIX2
				DLY	$00
				.FI
			.FI
		.FI
		CSA			; get bit (SENSEB)
		ANI	$20
		JZ	GET3
		LDI	1
		JMP	GET4
GET3:		LDI	0
		JNZ	GET4
GET4:		ST	TEMP(P2)	; save bit value (0 or 1)
		RRL			; rotate into link
		XAE
		SRL			; shift into character
		XAE			; return character to E
		CSA			; echo bit to output
		ORI	1
		XOR	TEMP(P2)
		CAS
		DLD	NUM(P2)	; decrement bit count
		JNZ	GET2		; loop until 0

	.DO	FIX2=1
		LDI	$AA		; delay bit time for MSB (2400 baud only)
		DLY	$00
	.FI

		CSA			; set stop bit
		ANI	$FE
		CAS
					; delay approximatly one bit time
		.DO	CPUCLK=2
			.DO	BAUD=110
			DLY	$08
			.FI
			.DO	BAUD=300
			DLY	$06
			.FI
			.DO	BAUD=600
			DLY	$04
			.FI
			.DO	BAUD=1200
			DLY	$02
			.FI
		.FI
		.DO	CPUCLK=4
			.DO	BAUD=110
			DLY	$11
			.FI
			.DO	BAUD=300
			DLY	$06
			.FI
			.DO	BAUD=600
			DLY	$03
			.FI
			.DO	BAUD=1200
			DLY	$01
			.FI
			.DO	BAUD=2400
				.DO	FIX2=0
				DLY	$08	; original value
				.EL
				DLY	$02	; value for FIX2
				.FI
			.FI
		.FI
		LDE			; A has input character
		ANI	$7F
		XAE
		LDE
		XPPC	P3		; return
GET5:		JMP	GECO
;
;*************************************
;*	Print Character at TTY		 *
;*************************************
;
PUTC:
	.DO	FIX2=1		; echo bit 7 cleared fix
		ANI	$7F		; clear top bit
	.FI
		XAE			; save character in E
					; delay almost three bit times
		.DO	CPUCLK=2
			.DO	BAUD=110
			LDI	$FF
			DLY	$17
			.FI
			.DO	BAUD=300
			LDI	$64
			DLY	$06
			.FI
			.DO	BAUD=600
			LDI	$25
			DLY	$03
			.FI
			.DO	BAUD=1200
			LDI	$86
			DLY	$01
			.FI
		.FI
		.DO	CPUCLK=4
			.DO	BAUD=110
			LDI	$BB
			DLY	$2F
			.FI
			.DO	BAUD=300
			LDI	$6C
			DLY	$06
			.FI
			.DO	BAUD=600
			LDI	$2D
			DLY	$03
			.FI
			.DO	BAUD=1200
			LDI	$99
			DLY	$01
			.FI
			.DO	BAUD=2400
				.DO FIX2=0
				LDI	$FF	; original values
				DLY	$17
				.EL
				LDI	$31	; FIX2 values
				DLY	$01
				.FI
			.FI
		.FI
		CSA			; set output bit to logic 0
		ORI	1		; for start bit (note inversion)
		CAS
		LDI	9		; initialise bit count
		ST	TEMP3(P2)
PUTC1:				; delay one bit time
		.DO	CPUCLK=2
			.DO	BAUD=110
			LDI	$8A
			DLY	$08
			.FI
			.DO	BAUD=300
			LDI	$F0
			DLY	$02
			.FI
			.DO	BAUD=600
			LDI	$50
			DLY	$01
			.FI
			.DO	BAUD=1200
			LDI	$81
			DLY	$00
			.FI
		.FI
		.DO	CPUCLK=4
			.DO	BAUD=110
			LDI	$54
			DLY	$11
			.FI
			.DO	BAUD=300
			LDI	$21
			DLY	$06
			.FI
			.DO	BAUD=600
			LDI	$E5
			DLY	$02
			.FI
			.DO	BAUD=1200
			LDI	$44
			DLY	$01
			.FI
			.DO	BAUD=2400
				.DO	FIX2=0
				LDI	$8A	; original values
				DLY	$08
				.EL
				LDI	$82	; FIX2 values
				DLY	$00
				.FI
			.FI
		.FI
		DLD	TEMP3(P2)	; decrement bit count
		JZ	PUTC2
		LDE			; prepare next bit
		ANI	1
		ST	TEMP2(P2)
		XAE			; shift data right one bit
		SR
		XAE
		CSA			; set up output bit
		ORI	1
		XOR	TEMP2(P2)
		CAS			; put bit into tty
		JMP	PUTC1
PUTC2:	CSA			; set stop bit
		ANI	$FE
		CAS
		XPPC	P3		; return
PUTC3:	JMP	PUTC
;
		.DO	NIBL=1	; redirections for GECO and PUTC used by page3.sys
			.BS	$1FFC-PUTC3-2,$FF	; fill space with $FF
JMGECO:		JMP	GET5
JMPUTC:		JMP	PUTC
		.FI