	NAM	Copyright:FORTH Interest Group
	OPT	NOG,PAGE
* filename FTH7.21
* === FORTH-6800 06-06-79 21:00

*
* This listing is in the PUBLIC DOMAIN and
* may be freely copied or published with the
* restriction that a credit line is printed
* with the material, crediting the
* authors and the FORTH INTEREST GROUP.
*
* === by Dave Lion,
* === with help from
* === Bob Smith,
* === LaFarr Stuart,
* === The Forth Interest Group
* === PO Box 1105
* === San Carlos, CA 94070
* ===  and
* === Unbounded Computing
* === 1134-K Aster Ave.
* === Sunnyvale, CA 94086
*
*  This version was developed on an AMI EVK 300 PROTO
*  system using an ACIA for the I/O.  All terminal I/O
*  is done in three subroutines:
*   PERMIT   ( word # 182 )
*   PKEY    (        183)
*   PQTERM  (        184)
*
* The FORTH words for disc related I/O follow the model
* of the FORTH Interest Group, but have not been
* tested using a real disc.
*
* Addresses in this implementation reflect the value that,
* on the development system, it was convenient to
* write-protect memory at hex 1000, and leave the first
* 4K bytes write-enabled.  As a consequence, code from
* location $1000 to lable ZZZZ could be put in ROM.
* Minor deviations from the moel were made in the
* initialization and words ?STACK and FORGET
* in order to do this.
*


*
NBLK	EQU	4	# of disc buffer blocks for virtual memory
MEMEND	EQU	132*NBLK+$3000	end of ram
*  each block is 132 bytes in size,
*  holding 128 characters
*
MEMTOP	EQU	$3FFF	absolute end of all ram
ACIAC	EQU	$FBCE	the ACIA control address and
ACIAD	EQU	ACIAC+1	data address for PROTO
	PAGE
*	MEMORY MAP for this 16K system:
*  ( positioned so that systems with 4k byte write-
*    protected segments can write protect FORTH )
*
* addr.	            contents         	pointer	init by
* *****	*****************************	*******	*******
* 3FFF			HI
*	substitute for disc mass memory
* 3210			LO,MEMEND
* 320F
*	4 buffer sectors of VIRTUAL MEMORY
* 3000			FIRST
* >>>>>>	memory from here up must be RAM <<<<<<
*
* 27FF
*	6k of romable "FORTH"	<== IP	ABORT
*		<== W
*	the VIRTUAL FORTH MACHINE
*
* 1004	<<< WARM START ENTRY >>>
* 1000	<<< COLD START ENTRY >>>
*
* >>>>>>	memory from here down must be RAM <<<<<<
* FFE	RETURN STACK base	<== RP	RINIT
*
* FB4
*	INPUT LINE BUFFER
*	holds up to 132 characters
*	and is scanned upward by IN
*	starting at TIB
* F30		<== IN	TIB
* F2F	DATA STACK	<== SP	SP0,SINIT
*   |	grows downward from F2F
*   |
*   V
*
*   ^
*   |
*   |	DICTIONARY grows upward
*
* 183	end of ram-dictionary.	<== DP	DPINIT
*	"TASK"
*
* 150	"FORTH" ( a word )	<=, <== CONTEXT
*		==== CURRENT
* 148	start of ram-dictionary.
*
* 100	user #1 table of variables	<== UP	UPINIT
*  F0	registers & pointers for the virtual machine
*	scratch area used by various words
*  E0	lowest address used by FORTH
*
* 0000
	PAGE
* * *
*
* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS:
*
* IP	points to the current instruction ( pre-increment mode )
* RP	points to the second free byte (first free word) in return stack
* SP	(hardware SP) points to first free byte in data stack
*
*	when A and B hold one 16 bit FORTH data word,
*	A contains the high byte, B, the low byte.
* * *


	ORG	$E0	variables

N	RMB	10	used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY
*			        SP@,SWAP,DOES>,COLD

*	These locations are used by the TRACE routine :

TRLIM	RMB	1	the count for tracing without user intervention
TRACEM	RMB	1	non-zero = trace mode
BRKPT	RMB	2	the breakpoint address at which
*	the program will go into trace mode
VECT	RMB	2	vector to machine code
*		(only needed if the TRACE routine is resident)

*	Registers used by the FORTH virtual machine:
*	Starting at $00F0 :

W	RMB	2	the instruction register points to 6800 coe
IP	RMB	2	the instruction pointer points to pointer to 6800 code
RP	RMB	2	the return stack pointer
UP	RMB	2	the pointer to base of current user's 'USER' tabl
*	( altered during multi-tasking )
*

	PAGE
*	This system is shown with one user, but additional users
*	may be added by allocating additional user tables:
*	UORIG2	RMB	64	data table for user #2
*
*	Some of this stuff gets initialized during
*	COLD start  and  WARM start:
*	[ names correspond to FORTH words of similar (no X) name ]
*
	ORG	$100
UORIG	RMB	6	3 reserved variables
XSPZER	RMB	2	initial top of data stack for this user
XRZERO	RMB	2	initial top of return stack
XTIB	RMB	2	start of terminal input buffer
XWIDTH	RMB	2	name field width
XWARN	RMB	2	warning message mode (0 = no disc)
XFENCE	RMB	2	fence for FORGET
XDP	RMB	2	dictionary pointer
XVOCL	RMB	2	vocabulary linking
XBLK	RMB	2	disc block being accessed
XIN	RMB	2	scan pointer into the block
XOUT	RMB	2	cursor position
XSCR	RMB	2	disc screen being accessed ( 0=terminal )
XOFSET	RMB	2	disc sector offset for multi-disc
XCONT	RMB	2	last word in primary search vocabulary
XCURR	RMB	2	last word in extensible vocabulary
XSTATE	RMB	2	flag for 'interpret' or 'compile' modes
XBASE	RMB	2	number base for I/O numeric conversion
XDPL	RMB	2	decimal point place
XFLD	RMB	2
XCSP	RMB	2	current stack position, for compile checks
XRNUM	RMB	2
XHLD	RMB	2
XDELAY	RMB	2	carriage return delay count
XCOLUM	RMB	2	carriage width
IOSTAT	RMB	2	last acia status from write/read
	RMB	2	( 4 spares! )
	RMB	2
	RMB	2
	RMB	2


*
*
*   end of user table, start of common system variables
*
*
*
XUSE	RMB	2
XPREV	RMB	2
	RMB	4	( spares )
*
* These things, up through the lable 'REND', are overwritten
* at time of cold load and should have the same contents
* as shown here:
*
	FCB	$C5	immediate
	FCC	"FORT" "H"
	FCB	$C8
	FDB	NOOP-7
FORTH	FDB	DODOES,DOVOC,$81A0,TASK-7
	FDB	0
*
	FCC	"(C) Forth Interest Group, 1979"

	FCB	$84
	FCC	"TAS" "K"
	FCB	$CB
	FDB	FORTH-8
TASK	FDB	DOCOL,SEMIS
*
REND	EQU	*	( first empty location in dictionary )
	PAGE
*	The FORTH program (address $1000 to $27FF ) is written
*	so that it can be in a ROM, or write-protected if desigged
	ORG	$1000
* ######>> screen 3 <<
*
***************************
**  C O L D  E N T R Y   **
***************************
ORIG	NOP
	JMP	CENT

***************************
**  W A R M  E N T R Y   **
***************************
	NOP
	JMP	WENT	warm-start code, keeps current dictionary intact

*
****** startup parameters ***********************
*
	FDB	$6800,0000	cpu & revision
	FDB	0	topmost word in FORTH vocabulary
BACKSP	FDB	$7F	backspace character for editing
UPINIT	FDB	UORIG	initial user area
SINIT	FDB	ORIG-$D0	initial top of data stack
RINIT	FDB	ORIG-2	initial top of return stack
	FDB	ORIG-$D0	terminal input buffer
	FDB	31	initial name field width
	FDB	0	initial warning mode (0 = no disc)
FENCIN	FDB	REND	initial fence
DPINIT	FDB	REND	cold start value for DP
VOCINT	FDB	FORTH+8	cold start value for VOC-LINK
COLINT	FDB	132	initial terminal carriage width
DELINT	FDB	4	initial carriage return delay
*************************************************
*
	PAGE
*
* ######>> screen 13 <<
PULABX	PULA		24 cycles until 'NEXT'
	PULB
STABX	STAA	0,X	16 cycles until 'NEXT'
	STAB	1,X
	BRA	NEXT
GETX	LDAA	0,X	18 cycles until 'NEXT'
	LDAB	1,X
PUSHBA	PSHB		8 cycles until 'NEXT'
	PSHA

*
* "NEXT" takes 38 cycles if TRACE is removed,
*
* and 95 cycles if NOT tracing.
*
* = = = = = = =   t h e   v i r t u a l   m a c h i n e   = = = = =
*                                                                 =
NEXT	LDX	IP
	INX
	INX		pre-increment moe
	STX	IP
NEXT2	LDX	0,X	get W which points to CFA of word to be done
NEXT3	STX	W
	LDX	0,X	get VECT which points to executable code
*                                                                 =
* The next instruction could be patched to JMP TRACE              =
* if a TRACE routine is available:                                =
*                                                                 =
* The next instruction could be patched to JMP TRACE              =
*                                                                 =
	JMP	0,X
	NOP
*	JMP TRACE ( an alternate for the above )
*                                                                 =
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
	PAGE
*
* ======>>  1  <<
	FCB	$83
	FCC	"LI" "T"	NOTE: this is different from LITERAL
	FCB	$D4
	FDB	0	 link of zero to terminate dictionary scan
LIT	FDB	*+2
	LDX	IP
	INX
	INX
	STX	IP
	LDAA	0,X
	LDAB	1,X
	JMP	PUSHBA
*
* ######>> screen 14 <<
* ======>>  2  <<
CLITER	FDB	*+2	( this is an invisible word, with no header )
	LDX	IP
	INX
	STX	IP
	CLRA
	LDAB	1,X
	JMP	PUSHBA
*
* ======>>  3  <<
	FCB	$87
	FCC	"EXECUT" "E"
	FCB	$C5
	FDB	LIT-6
EXEC	FDB	*+2
	TSX
	LDX	0,X	get code field address (CFA)
	INS		pop stack
	INS
	JMP	NEXT3
*
* ======>>  4  <<
	FCB	$86
	FCC	"BRANC" "H"
	FCB	$C8
	FDB	EXEC-10
BRAN	FDB	ZBYES	Go steal code in ZBRANCH
*
* ======>>  5  <<
	FCB	$87
	FCC	"0BRANC" "H"
	FCB	$C8
	FDB	BRAN-9
ZBRAN	FDB	*+2
	PULA
	PULB
	ABA
	BNE	ZBNO
	BCS	ZBNO
ZBYES	LDX	IP	Note: code is shared with BRANCH (+LOOP), (LOOP)
	LDAB	3,X
	LDAA	2,X
	ADDB	IP+1
	ADCA	IP
	STAB	IP+1
	STAA	IP
	JMP	NEXT
ZBNO	LDX	IP	no branch.  This code is shared with (+LOOP) & (LOOP).
	INX		jump over branch delta
	INX
	STX	IP
	JMP	NEXT
*
* ######>> screen 16 <<
* ======>>  6  <<
	FCB	$86
	FCC	"(LOOP" ")"
	FCB	$A9
	FDB	ZBRAN-10
XLOOP	FDB	*+2
	CLRA
	LDAB	#1	get set to increment counter by 1
	BRA	XPLOP2	go steal other guy's code!
*
* ======>>  7  <<
	FCB	$87
	FCC	"(+LOOP" ")"
	FCB	$A9
	FDB	XLOOP-9
XPLOOP	FDB	*+2	Note: +LOOP has an un-signed loop counter
	PULA		get increment
	PULB
XPLOP2	TSTA
	BPL	XPLOF	forward looping
	BSR	XPLOPS
	SEC
	SBCB	5,X
	SBCA	4,X
	BPL	ZBYES
	BRA	XPLONO	fall thru
*
* the subroutine :
XPLOPS	LDX	RP
	ADDB	3,X	add it to counter
	ADCA	2,X
	STAB	3,X	store new counter value
	STAA	2,X
	RTS
*
XPLOF	BSR	XPLOPS
	SUBB	5,X
	SBCA	4,X
	BMI	ZBYES
XPLONO	INX		done, don't branch back
	INX
	INX
	INX
	STX	RP
	BRA	ZBNO	use ZBRAN to skip over unused delta
*
* ######>> screen 17 <<
* ======>>  8  <<
	FCB	$84
	FCC	"(DO" ")"
	FCB	$A9
	FDB	XPLOOP-10
XDO	FDB	*+2	This is the RUN-TIME DO, not the COMPILING DO
	LDX	RP
	DEX
	DEX
	DEX
	DEX
	STX	RP
	PULA
	PULB
	STAA	2,X
	STAB	3,X
	PULA
	PULB
	STAA	4,X
	STAB	5,X
	JMP	NEXT
*
* ======>>  9  <<
	FCB	$81	I
	FCB	$C9
	FDB	XDO-7
I	FDB	*+2
	LDX	RP
	INX
	INX
	JMP	GETX
*
* ######>> screen 18 <<
* ======>>  10  <<
	FCB	$85
	FCC	"DIGI" "T"
	FCB	$D4
	FDB	I-4
DIGIT	FDB	*+2	NOTE: legal input range is 0-9, A-Z
	TSX
	LDAA	3,X
	SUBA	#$30	ascii zero
	BMI	DIGIT2	IF LESS THAN '0', ILLEGAL
	CMPA	#$A
	BMI	DIGIT0	IF '9' OR LESS
	CMPA	#$11
	BMI	DIGIT2	if less than "A"
	CMPA	#$2B
	BPL	DIGIT2	if greater than "Z"
	SUBA	#7	translate 'A' thru 'F'
DIGIT0	CMPA	1,X
	BPL	DIGIT2	if not less than the base
	LDAB	#1	set flag
	STAA	3,X	store digit
DIGIT1	STAB	1,X	store the flag
	JMP	NEXT
DIGIT2	CLRB
	INS
	INS		pop bottom number
	TSX
	STAB	0,X	make sure both bytes are 00
	BRA	DIGIT1
*
* ######>> screen 19 <<
*
* The word format in the dictionary is:
*
* char-count + 80	lowest address
* char 1
* char 2
*
* char n + $80
* link high byte \ point to previous word
* link low  byte /
* CFA  high byte \ Pnt to 6800 code
* CFA  low  byte /
*    "
*    "
*    "
*
* ======>>   11  <<
	FCB	$86
	FCC	"(FIND" ")"
	FCB	$A9
	FDB	DIGIT-8
PFIND	FDB	*+2
	NOP
	NOP
PD	EQU	N	ptr to dict word being checked
PA0	EQU	N+2
PA	EQU	N+4
PC	EQU	N+6
	LDX	#PD
	LDAB	#4
PFIND0	PULA		loop to get arguments
	STAA	0,X
	INX
	DECB
	BNE	PFIND0
*
	LDX	PD
PFIND1	LDAB	0,X	get count dict count
	STAB	PC
	ANDB	#$3F
	INX
	STX	PD	update PD
	LDX	PA0
	LDAA	0,X	get count from arg
	INX
	STX	PA	initialize PA
	CBA		compare lengths
	BNE	PFIND4
PFIND2	LDX	PA
	LDAA	0,X
	INX
	STX	PA
	LDX	PD
	LDAB	0,X
	INX
	STX	PD
	TSTB		is dict entry neg. ?
	BPL	PFIND8
	ANDB	#$7F	clear sign
	CBA
	BEQ	FOUND
PFIND3	LDX	0,X	get new link
	BNE	PFIND1	continue if link not=0
*
*	not found :
*
	CLRA
	CLRB
	JMP	PUSHBA
PFIND8	CBA
	BEQ	PFIND2
PFIND4	LDX	PD
PFIND9	LDAB	0,X	scan forward to end of this name
	INX
	BPL	PFIND9
	BRA	PFIND3
*
*	found :
*
FOUND	LDAA	PD	compute CFA
	LDAB	PD+1
	ADDB	#4
	ADCA	#0
	PSHB
	PSHA
	LDAA	PC
	PSHA
	CLRA
	PSHA
	LDAB	#1
	JMP	PUSHBA
*
	PSHA
	CLRA
	PSHA
	LDAB	#1
	JMP	PUSHBA
*
* ######>> screen 20 <<
* ======>>  12  <<
	FCB	$87
	FCC	"ENCLOS" "E"
	FCB	$C5
	FDB	PFIND-9
* NOTE :
* FC means offset (bytes) to First Character of next word
* EW   "     "  to End of Word
* NC   "     "  to Next Character to start next enclose at
ENCLOS	FDB	*+2
	INS
	PULB		now,get the low byte, for an 8-bit delimiter
	TSX
	LDX	0,X
	CLR	N
*	 wait fo a non- delimiter or a NUL
ENCL2	LDAA	0,X
	BEQ	ENCL6
	CBA		CHECK FOR DELIM
	BNE	ENCL3
	INX
	INC	N
	BRA	ENCL2
*	 found first character.  Push FC
ENCL3	LDAA	N	found first char.
	PSHA
	CLRA
	PSHA
*	 wait for a delimiter or a NUL
ENCL4	LDAA	0,X
	BEQ	ENCL7
	CBA		ckech for delim.
	BEQ	ENCL5
	INX
	INC	N
	BRA	ENCL4
*	 found EW.  Push it
ENCL5	LDAB	N
	CLRA
	PSHB
	PSHA
*	 advance and push NC
	INCB
	JMP	PUSHBA
*	 found NUL before non-delimiter, therefore there is no word
ENCL6	LDAB	N	found NUL
	PSHB
	PSHA
	INCB
	BRA	ENCL7+2
*	 found NUL following the word instead of SPACE
ENCL7	LDAB	N
	PSHB		save EW
	PSHA
ENCL8	LDAB	N	save NC
	JMP	PUSHBA
	PAGE
*
* ######>> screen 21 <<
* The next 4 words call system-dependant I/O subroutines
* which are listed after word "-->" ( label: "arrow" )
* in the dictionary.
*
* ======>>  13  <<
	FCB	$84
	FCC	"EMI" "T"
	FCB	$D4
	FDB	ENCLOS-10
EMIT	FDB	*+2
	PULA
	PULA
	JSR	PEMIT
	LDX	UP
	INC	XOUT+1-UORIG,X
	BNE	*+4
	INC	XOUT-UORIG,X
	JMP	NEXT
*
* ======>>  14  <<
	FCB	$83
	FCC	"KE" "Y"
	FCB	$D9
	FDB	EMIT-7
KEY	FDB	*+2
	JSR	PKEY
	PSHA
	CLRA
	PSHA
	JMP	NEXT
*
* ======>>  15  <<
	FCB	$89
	FCC	"?TERMINA" "L"
	FCB	$CC
	FDB	KEY-6
QTERM	FDB	*+2
	JSR	PQTER
	CLRB
	JMP	PUSHBA	stack the flag
*
* ======>>  16  <<
	FCB	$82
	FCC	"C" "R"
	FCB	$D2
	FDB	QTERM-12
CR	FDB	*+2
	JSR	PCR
	JMP	NEXT
*
*######>> screen 22 <<
* ======>>  17  <<
	FCB	$85
	FCC	"CMOV" "E"	source, destination, count
	FCB	$C5
	FDB	CR-5
CMOVE	FDB	*+2	takes ( 43+47*count ) cycles
	LDX	#N
	LDAB	#6
CMOV1	PULA
	STAA	0,X	move parameters to scratch area
	INX
	DECB
	BNE	CMOV1
CMOV2	LDAA	N
	LDAB	N+1
	SUBB	#1
	SBCA	#0
	STAA	N
	STAB	N+1
	BCS	CMOV3
	LDX	N+4
	LDAA	0,X
	INX
	STX	N+4
	LDX	N+2
	STAA	0,X
	INX
	STX	N+2
	BRA	CMOV2
CMOV3	JMP	NEXT
*
* ######>> screen 23 <<
* ======>>  18  <<
	FCB	$82
	FCC	"U" "*"
	FCB	$AA
	FDB	CMOVE-8
USTAR	FDB	*+2
	BSR	USTARS
	INS
	INS
	JMP	PUSHBA
*
* The following is a subroutine which
* multiplies top 2 words on stack,
* leaving 32-bit result:  high order word in A,B
* low order word in 2nd word of stack.
*
USTARS	LDAA	#16	bits/word counter
	PSHA
	CLRA
	CLRB
	TSX
USTAR2	ROR	5,X	shift multiplier
	ROR	6,X
	DEC	0,X	done?
	BMI	USTAR4
	BCC	USTAR3
	ADDB	4,X
	ADCA	3,X
USTAR3	RORA
	RORB		shift result
	BRA	USTAR2
USTAR4	INS		dump counter
	RTS
*
* ######>> screen 24 <<
* ======>>  19  <<
	FCB	$82
	FCC	"U" "/"
	FCB	$AF
	FDB	USTAR-5
USLASH	FDB	*+2
	LDAA	#17
	PSHA
	TSX
	LDAA	3,X
	LDAB	4,X
USL1	CMPA	1,X
	BHI	USL3
	BCS	USL2
	CMPB	2,X
	BCC	USL3
USL2	CLC
	BRA	USL4
USL3	SUBB	2,X
	SBCA	1,X
	SEC
USL4	ROL	6,X
	ROL	5,X
	DEC	0,X
	BEQ	USL5
	ROLB
	ROLA
	BCC	USL1
	BRA	USL3
USL5	INS
	INS
	INS
	INS
	INS
	JMP	SWAP+4	reverse quotient & remainder
*
* ######>> screen 25 <<
* ======>>  20  <<
	FCB	$83
	FCC	"AN" "D"
	FCB	$C4
	FDB	USLASH-5
AND	FDB	*+2
	PULA
	PULB
	TSX
	ANDB	1,X
	ANDA	0,X
	JMP	STABX
*
* ======>>  21  <<
	FCB	$82
	FCC	"O" "R"
	FCB	$D2
	FDB	AND-6
OR	FDB	*+2
	PULA
	PULB
	TSX
	ORAB	1,X
	ORAA	0,X
	JMP	STABX
*
* ======>>  22  <<
	FCB	$83
	FCC	"XO" "R"
	FCB	$D2
	FDB	OR-5
XOR	FDB	*+2
	PULA
	PULB
	TSX
	EORB	1,X
	EORA	0,X
	JMP	STABX
*
* ######>> screen 26 <<
* ======>>  23  <<
	FCB	$83
	FCC	"SP" "@"
	FCB	$C0
	FDB	XOR-6
SPAT	FDB	*+2
	TSX
	STX	N	scratch area
	LDX	#N
	JMP	GETX
*
*
* ======>>  24  <<
	FCB	$83
	FCC	"SP" "!"
	FCB	$A1
	FDB	SPAT-6
SPSTOR	FDB	*+2
	LDX	UP
	LDX	XSPZER-UORIG,X
	TXS		watch it ! X and S are not equal.
	JMP	NEXT
*
* ======>>  25  <<
	FCB	$83
	FCC	"RP" "!"
	FCB	$A1
	FDB	SPSTOR-6
RPSTOR	FDB	*+2
	LDX	RINIT	initialize from rom constant
	STX	RP
	JMP	NEXT
*
* ======>>  26  <<
	FCB	$82
	FCC	";" "S"
	FCB	$D3
	FDB	RPSTOR-6
SEMIS	FDB	*+2
	LDX	RP
	INX
	INX
	STX	RP
	LDX	0,X	get address we have just finished.
	JMP	NEXT+2	increment the return address & do next word
*
* ######>> screen 27 <<
* ======>>  27  <<
	FCB	$85
	FCC	"LEAV" "E"
	FCB	$C5
	FDB	SEMIS-5
LEAVE	FDB	*+2
	LDX	RP
	LDAA	2,X
	LDAB	3,X
	STAA	4,X
	STAB	5,X
	JMP	NEXT
*
* ======>>  28  <<
	FCB	$82
	FCC	">" "R"
	FCB	$D2
	FDB	LEAVE-8
TOR	FDB	*+2
	LDX	RP
	DEX
	DEX
	STX	RP
	PULA
	PULB
	STAA	2,X
	STAB	3,X
	JMP	NEXT
*
* ======>>  29  <<
	FCB	$82
	FCC	"R" ">"
	FCB	$BE
	FDB	TOR-5
FROMR	FDB	*+2
	LDX	RP
	LDAA	2,X
	LDAB	3,X
	INX
	INX
	STX	RP
	JMP	PUSHBA
*
*======>>  30  <<
	FCB	$81	R
	FCB	$D2
	FDB	FROMR-5
R	FDB	*+2
	LDX	RP
	INX
	INX
	JMP	GETX
*
* ######>> screen 28 <<
* ======>>  31  <<
	FCB	$82
	FCC	"0" "="
	FCB	$BD
	FDB	R-4
ZEQU	FDB	*+2
	TSX
	CLRA
	CLRB
	LDX	0,X
	BNE	ZEQU2
	INCB
ZEQU2	TSX
	JMP	STABX
*
* ======>>  32  <<
	FCB	$82
	FCC	"0" "<"
	FCB	$BC
	FDB	ZEQU-5
ZLESS	FDB	*+2
	TSX
	LDAA	#$80	check the sign bit
	ANDA	0,X
	BEQ	ZLESS2
	CLRA		if neg.
	LDAB	#1
	JMP	STABX
ZLESS2	CLRB
	JMP	STABX
*
* ######>> screen 29 <<
* ======>>  33  <<
	FCB	$81	+
	FCB	$AB
	FDB	ZLESS-5
PLUS	FDB	*+2
	PULA
	PULB
	TSX
	ADDB	1,X
	ADCA	0,X
	JMP	STABX
*
* ======>>  34  <<
	FCB	$82
	FCC	"D" "+"
	FCB	$AB
	FDB	PLUS-4
DPLUS	FDB	*+2
	TSX
	CLC
	LDAB	#4
DPLUS2	LDAA	3,X
	ADCA	7,X
	STAA	7,X
	DEX
	DECB
	BNE	DPLUS2
	INS
	INS
	INS
	INS
	JMP	NEXT
*
* ======>>  35  <<
	FCB	$85
	FCC	"MINU" "S"
	FCB	$D3
	FDB	DPLUS-5
MINUS	FDB	*+2
	TSX
	NEG	1,X
	BCS	MINUS2
	NEG	0,X
	BRA	MINUS3
MINUS2	COM	0,X
MINUS3	JMP	NEXT
*
* ======>>  36  <<
	FCB	$86
	FCC	"DMINU" "S"
	FCB	$D3
	FDB	MINUS-8
DMINUS	FDB	*+2
	TSX
	COM	0,X
	COM	1,X
	COM	2,X
	NEG	3,X
	BNE	DMINX
	INC	2,X
	BNE	DMINX
	INC	1,X
	BNE	DMINX
	INC	0,X
DMINX	JMP	NEXT
*
* ######>> screen 30 <<
* ======>>  37  <<
	FCB	$84
	FCC	"OVE" "R"
	FCB	$D2
	FDB	DMINUS-9
OVER	FDB	*+2
	TSX
	LDAA	2,X
	LDAB	3,X
	JMP	PUSHBA
*
* ======>>  38  <<
	FCB	$84
	FCC	"DRO" "P"
	FCB	$D0
	FDB	OVER-7
DROP	FDB	*+2
	INS
	INS
	JMP	NEXT
*
* ======>>  39  <<
	FCB	$84
	FCC	"SWA" "P"
	FCB	$D0
	FDB	DROP-7
SWAP	FDB	*+2
	PULA
	PULB
	TSX
	LDX	0,X
	INS
	INS
	PSHB
	PSHA
	STX	N
	LDX	#N
	JMP	GETX
*
* ======>>  40  <<
	FCB	$83
	FCC	"DU" "P"
	FCB	$D0
	FDB	SWAP-7
DUP	FDB	*+2
	PULA
	PULB
	PSHB
	PSHA
	JMP	PUSHBA
*
* ######>> screen 31 <<
* ======>>  41  <<
	FCB	$82
	FCC	"+" "!"
	FCB	$A1
	FDB	DUP-6
PSTORE	FDB	*+2
	TSX
	LDX	0,X
	INS
	INS
	PULA		get stack data
	PULB
	ADDB	1,X	add & store low byte
	STAB	1,X
	ADCA	0,X	add & store hi byte
	STAA	0,X
	JMP	NEXT
*
* ======>>  42  <<
	FCB	$86
	FCC	"TOGGL" "E"
	FCB	$C5
	FDB	PSTORE-5
TOGGLE	FDB	DOCOL,OVER,CAT,XOR,SWAP,CSTORE
	FDB	SEMIS
*
* ######>> screen 32 <<
* ======>>  43  <<
	FCB	$81	@
	FCB	$C0
	FDB	TOGGLE-9
AT	FDB	*+2
	TSX
	LDX	0,X	get address
	INS
	INS
	JMP	GETX
*
* ======>>  44  <<
	FCB	$82
	FCC	"C" "@"
	FCB	$C0
	FDB	AT-4
CAT	FDB	*+2
	TSX
	LDX	0,X
	CLRA
	LDAB	0,X
	INS
	INS
	JMP	PUSHBA
*
* ======>>  45  <<
	FCB	$81	!
	FCB	$A1
	FDB	CAT-5
STORE	FDB	*+2
	TSX
	LDX	0,X	get address
	INS
	INS
	JMP	PULABX
*
* ======>>  46  <<
	FCB	$82
	FCC	"C" "!"
	FCB	$A1
	FDB	STORE-4
CSTORE	FDB	*+2
	TSX
	LDX	0,X
	INS
	INS
	INS
	PULB
	STAB	0,X
	JMP	NEXT
	PAGE
*
* ######>> screen 33 <<
* ======>>  47  <<
	FCB	$C1	:   immediate
	FCB	$BA
	FDB	CSTORE-5
COLON	FDB	DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
	FDB	CREATE,RBRAK
	FDB	PSCODE


* Here is the IP pusher for allowing
* nested words in the virtual machine:
*
* ( ;S  is the equivalent un-nester )


DOCOL	LDX	RP	make room in the stack
	DEX
	DEX
	STX	RP
	LDAA	IP
	LDAB	IP+1
	STAA	2,X	Store address of the high level word
	STAB	3,X	that we are starting to execute
	LDX	W	Get first sub-word of that definition
	JMP	NEXT+2	and execute it
*
* ======>>  48  <<
	FCB	$C1	;   immediate code
	FCB	$BB
	FDB	COLON-4
SEMI	FDB	DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
	FDB	SEMIS
*
* ######>> screen 34 <<
* ======>>  49  <<
	FCB	$88
	FCC	"CONSTAN" "T"
	FCB	$D4
	FDB	SEMI-4
CON	FDB	DOCOL,CREATE,SMUDGE,COMMA,PSCODE
DOCON	LDX	W
	LDAA	2,X
	LDAB	3,X	A & B now contain the constant
	JMP	PUSHBA
*
* ======>>  50  <<
	FCB	$88
	FCC	"VARIABL" "E"
	FCB	$C5
	FDB	CON-11
VAR	FDB	DOCOL,CON,PSCODE
DOVAR	LDAA	W
	LDAB	W+1
	ADDB	#2
	ADCA	#0	A,B now contain the address of the variable
	JMP	PUSHBA
*
* ======>>  51  <<
	FCB	$84
	FCC	"USE" "R"
	FCB	$D2
	FDB	VAR-11
USER	FDB	DOCOL,CON,PSCODE
DOUSER	LDX	W	get offset into user's table
	LDAA	2,X
	LDAB	3,X
	ADDB	UP+1	add to users base address
	ADCA	UP
	JMP	PUSHBA	push address of user's variable
*
* ######>> screen 35 <<
* ======>>  52  <<
	FCB	$81	0
	FCB	$B0
	FDB	USER-7
ZERO	FDB	DOCON
	FDB	0000
*
* ======>>  53  <<
	FCB	$81	1
	FCB	$B1
	FDB	ZERO-4
ONE	FDB	DOCON
	FDB	1
*
* ======>>  54  <<
	FCB	$81	2
	FCB	$B2
	FDB	ONE-4
TWO	FDB	DOCON
	FDB	2
*
* ======>>  55  <<
	FCB	$81	3
	FCB	$B3
	FDB	TWO-4
THREE	FDB	DOCON
	FDB	3
*
* ======>>  56  <<
	FCB	$82
	FCC	"B" "L"
	FCB	$CC
	FDB	THREE-4
BL	FDB	DOCON	ascii blank
	FDB	$20
*
* ======>>  57  <<
	FCB	$85
	FCC	"FIRS" "T"
	FCB	$D4
	FDB	BL-5
FIRST	FDB	DOCON
	FDB	MEMEND-528	(132*NBLK)
*
* ======>>  58  <<
	FCB	$85
	FCC	"LIMI" "T"	( the end of memory +1 )
	FCB	$D4
	FDB	FIRST-8
LIMIT	FDB	DOCON
	FDB	MEMEND
*
* ======>>  59  <<
	FCB	$85
	FCC	"B/BU" "F"	(bytes/buffer)
	FCB	$C6
	FDB	LIMIT-8
BBUF	FDB	DOCON
	FDB	128
*
* ======>>  60  <<
	FCB	$85
	FCC	"B/SC" "R"	(blocks/screen)
	FCB	$D2
	FDB	BBUF-8
BSCR	FDB	DOCON
	FDB	8
* blocks/screen = 1024 / "B/BUF" = 8
*
* ======>>  61  <<
	FCB	$87
	FCC	"+ORIGI" "N"
	FCB	$CE
	FDB	BSCR-8
PORIG	FDB	DOCOL,LIT,ORIG,PLUS
	FDB	SEMIS
*
* ######>> screen 36 <<
* ======>>  62  <<
	FCB	$82
	FCC	"S" "0"
	FCB	$B0
	FDB	PORIG-10
SZERO	FDB	DOUSER
	FDB	XSPZER-UORIG
*
* ======>>  63  <<
	FCB	$82
	FCC	"R" "0"
	FCB	$B0
	FDB	SZERO-5
RZERO	FDB	DOUSER
	FDB	XRZERO-UORIG
*
* ======>>  64  <<
	FCB	$83
	FCC	"TI" "B"
	FCB	$C2
	FDB	RZERO-5
TIB	FDB	DOUSER
	FDB	XTIB-UORIG
*
* ======>>  65  <<
	FCB	$85
	FCC	"WIDT" "H"
	FCB	$C8
	FDB	TIB-6
WIDTH	FDB	DOUSER
	FDB	XWIDTH-UORIG
*
* ======>>  66  <<
	FCB	$87
	FCC	"WARNIN" "G"
	FCB	$C7
	FDB	WIDTH-8
WARN	FDB	DOUSER
	FDB	XWARN-UORIG
*
* ======>>  67  <<
	FCB	$85
	FCC	"FENC" "E"
	FCB	$C5
	FDB	WARN-10
FENCE	FDB	DOUSER
	FDB	XFENCE-UORIG
*
* ======>>  68  <<
	FCB	$82
	FCC	"D" "P"	points to first free byte at end of dictionary
	FCB	$D0
	FDB	FENCE-8
DP	FDB	DOUSER
	FDB	XDP-UORIG
*
* ======>>  68.5  <<
	FCB	$88
	FCC	"VOC-LIN" "K"
	FCB	$CB
	FDB	DP-5
VOCLIN	FDB	DOUSER
	FDB	XVOCL-UORIG
*
* ======>>  69  <<
	FCB	$83
	FCC	"BL" "K"
	FCB	$CB
	FDB	VOCLIN-11
BLK	FDB	DOUSER
	FDB	XBLK-UORIG
*
* ======>>  70  <<
	FCB	$82
	FCC	"I" "N"	scan pointer for input line buffer
	FCB	$CE
	FDB	BLK-6
IN	FDB	DOUSER
	FDB	XIN-UORIG
*
* ======>>  71  <<
	FCB	$83
	FCC	"OU" "T"
	FCB	$D4
	FDB	IN-5
OUT	FDB	DOUSER
	FDB	XOUT-UORIG
*
* ======>>  72  <<
	FCB	$83
	FCC	"SC" "R"
	FCB	$D2
	FDB	OUT-6
SCR	FDB	DOUSER
	FDB	XSCR-UORIG
* ######>> screen 37 <<
*
* ======>>  73  <<
	FCB	$86
	FCC	"OFFSE" "T"
	FCB	$D4
	FDB	SCR-6
OFSET	FDB	DOUSER
	FDB	XOFSET-UORIG
*
* ======>>  74  <<
	FCB	$87
	FCC	"CONTEX" "T"	points to pointer to vocab to search first
	FCB	$D4
	FDB	OFSET-9
CONTXT	FDB	DOUSER
	FDB	XCONT-UORIG
*
* ======>>  75  <<
	FCB	$87
	FCC	"CURREN" "T"	points to ptr. to vocab being extended
	FCB	$D4
	FDB	CONTXT-10
CURENT	FDB	DOUSER
	FDB	XCURR-UORIG
*
* ======>>  76  <<
	FCB	$85
	FCC	"STAT" "E"	1  if compiling , 0 if not
	FCB	$C5
	FDB	CURENT-10
STATE	FDB	DOUSER
	FDB	XSTATE-UORIG
*
* ======>>  77  <<
	FCB	$84
	FCC	"BAS" "E"	number base for all input & output
	FCB	$C5
	FDB	STATE-8
BASE	FDB	DOUSER
	FDB	XBASE-UORIG
*
* ======>>  78  <<
	FCB	$83
	FCC	"DP" "L"
	FCB	$CC
	FDB	BASE-7
DPL	FDB	DOUSER
	FDB	XDPL-UORIG
*
* ======>>  79  <<
	FCB	$83
	FCC	"FL" "D"
	FCB	$C4
	FDB	DPL-6
FLD	FDB	DOUSER
	FDB	XFLD-UORIG
*
* ======>>  80  <<
	FCB	$83
	FCC	"CS" "P"
	FCB	$D0
	FDB	FLD-6
CSP	FDB	DOUSER
	FDB	XCSP-UORIG
*
* ======>>  81  <<
	FCB	$82
	FCC	"R" "#"
	FCB	$A3
	FDB	CSP-6
RNUM	FDB	DOUSER
	FDB	XRNUM-UORIG
*
* ======>>  82  <<
	FCB	$83
	FCC	"HL" "D"
	FCB	$C4
	FDB	RNUM-5
HLD	FDB	DOCON
	FDB	XHLD
*
* ======>>  82.5  <<== SPECIAL
	FCB	$87
	FCC	"COLUMN" "S"	line width of terminal
	FCB	$D3
	FDB	HLD-6
COLUMS	FDB	DOUSER
	FDB	XCOLUM-UORIG
*
* ######>> screen 38 <<
* ======>>  83  <<
	FCB	$82
	FCC	"1" "+"
	FCB	$AB
	FDB	COLUMS-10
ONEP	FDB	DOCOL,ONE,PLUS
	FDB	SEMIS
*
* ======>>  84  <<
	FCB	$82
	FCC	"2" "+"
	FCB	$AB
	FDB	ONEP-5
TWOP	FDB	DOCOL,TWO,PLUS
	FDB	SEMIS
*
* ======>>  85  <<
	FCB	$84
	FCC	"HER" "E"
	FCB	$C5
	FDB	TWOP-5
HERE	FDB	DOCOL,DP,AT
	FDB	SEMIS
*
* ======>>  86  <<
	FCB	$85
	FCC	"ALLO" "T"
	FCB	$D4
	FDB	HERE-7
ALLOT	FDB	DOCOL,DP,PSTORE
	FDB	SEMIS
*
* ======>>  87  <<
	FCB	$81	, (COMMA)
	FCB	$AC
	FDB	ALLOT-8
COMMA	FDB	DOCOL,HERE,STORE,TWO,ALLOT
	FDB	SEMIS
*
* ======>>  88  <<
	FCB	$82
	FCC	"C" ","
	FCB	$AC
	FDB	COMMA-4
CCOMM	FDB	DOCOL,HERE,CSTORE,ONE,ALLOT
	FDB	SEMIS
*
* ======>>  89  <<
	FCB	$81	-
	FCB	$AD
	FDB	CCOMM-5
SUB	FDB	DOCOL,MINUS,PLUS
	FDB	SEMIS
*
* ======>>  90  <<
	FCB	$81	=
	FCB	$BD
	FDB	SUB-4
EQUAL	FDB	DOCOL,SUB,ZEQU
	FDB	SEMIS
*
* ======>>  91  <<
	FCB	$81	<
	FCB	$BC
	FDB	EQUAL-4
LESS	FDB	*+2
	PULA
	PULB
	TSX
	CMPA	0,X
	INS
	BGT	LESST
	BNE	LESSF
	CMPB	1,X
	BHI	LESST
LESSF	CLRB
	BRA	LESSX
LESST	LDAB	#1
LESSX	CLRA
	INS
	JMP	PUSHBA
*
* ======>>  92  <<
	FCB	$81	>
	FCB	$BE
	FDB	LESS-4
GREAT	FDB	DOCOL,SWAP,LESS
	FDB	SEMIS
*
* ======>>  93  <<
	FCB	$83
	FCC	"RO" "T"
	FCB	$D4
	FDB	GREAT-4
ROT	FDB	DOCOL,TOR,SWAP,FROMR,SWAP
	FDB	SEMIS
*
* ======>>  94  <<
	FCB	$85
	FCC	"SPAC" "E"
	FCB	$C5
	FDB	ROT-6
SPACE	FDB	DOCOL,BL,EMIT
	FDB	SEMIS
*
* ======>>  95  <<
	FCB	$83
	FCC	"MI" "N"
	FCB	$CE
	FDB	SPACE-8
MIN	FDB	DOCOL,OVER,OVER,GREAT,ZBRAN
	FDB	MIN2-*
	FDB	SWAP
MIN2	FDB	DROP
	FDB	SEMIS
*
* ======>>  96  <<
	FCB	$83
	FCC	"MA" "X"
	FCB	$D8
	FDB	MIN-6
MAX	FDB	DOCOL,OVER,OVER,LESS,ZBRAN
	FDB	MAX2-*
	FDB	SWAP
MAX2	FDB	DROP
	FDB	SEMIS
*
* ======>>  97  <<
	FCB	$84
	FCC	"-DU" "P"
	FCB	$D0
	FDB	MAX-6
DDUP	FDB	DOCOL,DUP,ZBRAN
	FDB	DDUP2-*
	FDB	DUP
DDUP2	FDB	SEMIS
*
* ######>> screen 39 <<
* ======>>  98  <<
	FCB	$88
	FCC	"TRAVERS" "E"
	FCB	$C5
	FDB	DDUP-7
TRAV	FDB	DOCOL,SWAP
TRAV2	FDB	OVER,PLUS,CLITER
	FCB	$7F
	FDB	OVER,CAT,LESS,ZBRAN
	FDB	TRAV2-*
	FDB	SWAP,DROP
	FDB	SEMIS
*
* ======>>  99  <<
	FCB	$86
	FCC	"LATES" "T"
	FCB	$D4
	FDB	TRAV-11
LATEST	FDB	DOCOL,CURENT,AT,AT
	FDB	SEMIS
*
* ======>>  100  <<
	FCB	$83
	FCC	"LF" "A"
	FCB	$C1
	FDB	LATEST-9
LFA	FDB	DOCOL,CLITER
	FCB	4
	FDB	SUB
	FDB	SEMIS
*
* ======>>  101  <<
	FCB	$83
	FCC	"CF" "A"
	FCB	$C1
	FDB	LFA-6
CFA	FDB	DOCOL,TWO,SUB
	FDB	SEMIS
*
* ======>>  102  <<
	FCB	$83
	FCC	"NF" "A"
	FCB	$C1
	FDB	CFA-6
NFA	FDB	DOCOL,CLITER
	FCB	5
	FDB	SUB,ONE,MINUS,TRAV
	FDB	SEMIS
*
* ======>>  103  <<
	FCB	$83
	FCC	"PF" "A"
	FCB	$C1
	FDB	NFA-6
PFA	FDB	DOCOL,ONE,TRAV,CLITER
	FCB	5
	FDB	PLUS
	FDB	SEMIS
*
* ######>> screen 40 <<
* ======>>  104  <<
	FCB	$84
	FCC	"!CS" "P"
	FCB	$D0
	FDB	PFA-6
SCSP	FDB	DOCOL,SPAT,CSP,STORE
	FDB	SEMIS
*
* ======>>  105  <<
	FCB	$86
	FCC	"?ERRO" "R"
	FCB	$D2
	FDB	SCSP-7
QERR	FDB	DOCOL,SWAP,ZBRAN
	FDB	QERR2-*
	FDB	ERROR,BRAN
	FDB	QERR3-*
QERR2	FDB	DROP
QERR3	FDB	SEMIS
*
* ======>>  106  <<
	FCB	$85
	FCC	"?COM" "P"
	FCB	$D0
	FDB	QERR-9
QCOMP	FDB	DOCOL,STATE,AT,ZEQU,CLITER
	FCB	$11
	FDB	QERR
	FDB	SEMIS
*
* ======>>  107  <<
	FCB	$85
	FCC	"?EXE" "C"
	FCB	$C3
	FDB	QCOMP-8
QEXEC	FDB	DOCOL,STATE,AT,CLITER
	FCB	$12
	FDB	QERR
	FDB	SEMIS
*
* ======>>  108  <<
	FCB	$86
	FCC	"?PAIR" "S"
	FCB	$D3
	FDB	QEXEC-8
QPAIRS	FDB	DOCOL,SUB,CLITER
	FCB	$13
	FDB	QERR
	FDB	SEMIS
*
* ======>>  109  <<
	FCB	$84
	FCC	"?CS" "P"
	FCB	$D0
	FDB	QPAIRS-9
QCSP	FDB	DOCOL,SPAT,CSP,AT,SUB,CLITER
	FCB	$14
	FDB	QERR
	FDB	SEMIS
*
* ======>>  110  <<
	FCB	$88
	FCC	"?LOADIN" "G"
	FCB	$C7
	FDB	QCSP-7
QLOAD	FDB	DOCOL,BLK,AT,ZEQU,CLITER
	FCB	$16
	FDB	QERR
	FDB	SEMIS
*
* ######>> screen 41 <<
* ======>>  111  <<
	FCB	$87
	FCC	"COMPIL" "E"
	FCB	$C5
	FDB	QLOAD-11
COMPIL	FDB	DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
	FDB	SEMIS
*
* ======>>  112  <<
	FCB	$C1	[  immediate
	FCB	$DB
	FDB	COMPIL-10
LBRAK	FDB	DOCOL,ZERO,STATE,STORE
	FDB	SEMIS
*
* ======>>  113  <<
	FCB	$81	]
	FCB	$DD
	FDB	LBRAK-4
RBRAK	FDB	DOCOL,CLITER
	FCB	$C0
	FDB	STATE,STORE
	FDB	SEMIS
*
* ======>>  114  <<
	FCB	$86
	FCC	"SMUDG" "E"
	FCB	$C5
	FDB	RBRAK-4
SMUDGE	FDB	DOCOL,LATEST,CLITER
	FCB	$20
	FDB	TOGGLE
	FDB	SEMIS
*
* ======>>  115  <<
	FCB	$83
	FCC	"HE" "X"
	FCB	$D8
	FDB	SMUDGE-9
HEX	FDB	DOCOL
	FDB	CLITER
	FCB	16
	FDB	BASE,STORE
	FDB	SEMIS
*
* ======>>  116  <<
	FCB	$87
	FCC	"DECIMA" "L"
	FCB	$CC
	FDB	HEX-6
DEC	FDB	DOCOL
	FDB	CLITER
	FCB	10	note: hex "A"
	FDB	BASE,STORE
	FDB	SEMIS
*
* ######>> screen 42 <<
* ======>>  117  <<
	FCB	$87
	FCC	"(;CODE" ")"
	FCB	$A9
	FDB	DEC-10
PSCODE	FDB	DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
	FDB	SEMIS
*
* ======>>  118  <<
	FCB	$C5	immediate
	FCC	";COD" "E"
	FCB	$C5
	FDB	PSCODE-10
SEMIC	FDB	DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
	FDB	SEMIS
* note: "QSTACK" will be replaced by "ASSEMBLER" later
*
* ######>> screen 43 <<
* ======>>  119  <<
	FCB	$87
	FCC	"<BUILD" "S"
	FCB	$D3
	FDB	SEMIC-8
BUILDS	FDB	DOCOL,ZERO,CON
	FDB	SEMIS
*
* ======>>  120  <<
	FCB	$85
	FCC	"DOES" ">"
	FCB	$BE
	FDB	BUILDS-10
DOES	FDB	DOCOL,FROMR,TWOP,LATEST,PFA,STORE
	FDB	PSCODE
*
DODOES	LDAA	IP
	LDAB	IP+1
	LDX	RP	make room on return stack
	DEX
	DEX
	STX	RP
	STAA	2,X	push return address
	STAB	3,X
	LDX	W	get addr of pointer to run-time code
	INX
	INX
	STX	N	stash it in scratch area
	LDX	0,X	get new IP
	STX	IP
	CLRA		get address of parameter
	LDAB	#2
	ADDB	N+1
	ADCA	N
	PSHB		and push it on data stack
	PSHA
	JMP	NEXT2
*
* ######>> screen 44 <<
* ======>>  121  <<
	FCB	$85
	FCC	"COUN" "T"
	FCB	$D4
	FDB	DOES-8
COUNT	FDB	DOCOL,DUP,ONEP,SWAP,CAT
	FDB	SEMIS
*
* ======>>  122  <<
	FCB	$84
	FCC	"TYP" "E"
	FCB	$C5
	FDB	COUNT-8
TYPE	FDB	DOCOL,DDUP,ZBRAN
	FDB	TYPE3-*
	FDB	OVER,PLUS,SWAP,XDO
TYPE2	FDB	I,CAT,EMIT,XLOOP
	FDB	TYPE2-*
	FDB	BRAN
	FDB	TYPE4-*
TYPE3	FDB	DROP
TYPE4	FDB	SEMIS
*
* ======>>  123  <<
	FCB	$89
	FCC	"-TRAILIN" "G"
	FCB	$C7
	FDB	TYPE-7
DTRAIL	FDB	DOCOL,DUP,ZERO,XDO
DTRAL2	FDB	OVER,OVER,PLUS,ONE,SUB,CAT,BL
	FDB	SUB,ZBRAN
	FDB	DTRAL3-*
	FDB	LEAVE,BRAN
	FDB	DTRAL4-*
DTRAL3	FDB	ONE,SUB
DTRAL4	FDB	XLOOP
	FDB	DTRAL2-*
	FDB	SEMIS
*
* ======>>  124  <<
	FCB	$84
	FCC	/(."/ ")"
	FCB	$A9
	FDB	DTRAIL-12
PDOTQ	FDB	DOCOL,R,TWOP,COUNT,DUP,ONEP
	FDB	FROMR,PLUS,TOR,TYPE
	FDB	SEMIS
*
* ======>>  125  <<
	FCB	$C2	immediate
	FCC	"." /"/
	FCB	$A2
	FDB	PDOTQ-7
DOTQ	FDB	DOCOL
	FDB	CLITER
	FCB	$22	ascii quote
	FDB	STATE,AT,ZBRAN
	FDB	DOTQ1-*
	FDB	COMPIL,PDOTQ,WORD
	FDB	HERE,CAT,ONEP,ALLOT,BRAN
	FDB	DOTQ2-*
DOTQ1	FDB	WORD,HERE,COUNT,TYPE
DOTQ2	FDB	SEMIS
*
* ######>> screen 45 <<
* ======>>  126  <<== MACHINE DEPENDENT
	FCB	$86
	FCC	"?STAC" "K"
	FCB	$CB
	FDB	DOTQ-5
QSTACK	FDB	DOCOL,CLITER
	FCB	$12
	FDB	PORIG,AT,TWO,SUB,SPAT,LESS,ONE
	FDB	QERR
* prints 'empty stack'
*
QSTAC2	FDB	SPAT
* Here, we compare with a value at least 128
* higher than dict. ptr. (DP)
	FDB	HERE,CLITER
	FCB	$80
	FDB	PLUS,LESS,ZBRAN
	FDB	QSTAC3-*
	FDB	TWO
	FDB	QERR
* prints 'full stack'
*
QSTAC3	FDB	SEMIS
*
* ======>> 127  << this word's function
*          is done by ?STACK in this version
*	FCB	$85
*	FCC	"?FRE" "E"
*	FCB	$C5
*	FDB	QSTACK-9
* QFREE	FDB	DOCOL,SPAT,HERE,CLITER
*	FCB	$80
*	FDB	PLUS,LESS,TWO,QERR,SEMIS
*
* ######>> screen 46 <<
* ======>>  128  <<
	FCB	$86
	FCC	"EXPEC" "T"
	FCB	$D5
	FDB	QSTACK-9
EXPECT	FDB	DOCOL,OVER,PLUS,OVER,XDO
EXPEC2	FDB	KEY,DUP,CLITER
	FCB	$0E
	FDB	PORIG,AT,EQUAL,ZBRAN
	FDB	EXPEC3-*
	FDB	DROP,CLITER
	FCB	8	( backspace character to emit )
	FDB	OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
	FDB	TOR,SUB,BRAN
	FDB	EXPEC6-*
EXPEC3	FDB	DUP,CLITER
	FCB	$D	( carriage return )
	FDB	EQUAL,ZBRAN
	FDB	EXPEC4-*
	FDB	LEAVE,DROP,BL,ZERO,BRAN
	FDB	EXPEC5-*
EXPEC4	FDB	DUP
EXPEC5	FDB	I,CSTORE,ZERO,I,ONEP,STORE
EXPEC6	FDB	EMIT,XLOOP
	FDB	EXPEC2-*
	FDB	DROP
	FDB	SEMIS
*
* ======>>  129  <<
	FCB	$85
	FCC	"QUER" "Y"
	FCB	$D9
	FDB	EXPECT-9
QUERY	FDB	DOCOL,TIB,AT,COLUMS
	FDB	AT,EXPECT,ZERO,IN,STORE
	FDB	SEMIS
*
* ======>>  130  <<
	FCB	$C1	immediate    < carriage return >
	FCB	$80
	FDB	QUERY-8
NULL	FDB	DOCOL,BLK,AT,ZBRAN
	FDB	NULL2-*
	FDB	ONE,BLK,PSTORE
	FDB	ZERO,IN,STORE,BLK,AT,BSCR,MOD
	FDB	ZEQU
*   check for end of screen
	FDB	ZBRAN
	FDB	NULL1-*
	FDB	QEXEC,FROMR,DROP
NULL1	FDB	BRAN
	FDB	NULL3-*
NULL2	FDB	FROMR,DROP
NULL3	FDB	SEMIS
*
* ######>> screen 47 <<
* ======>>  133  <<
	FCB	$84
	FCC	"FIL" "L"
	FCB	$CC
	FDB	NULL-4
FILL	FDB	DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
	FDB	FROMR,ONE,SUB,CMOVE
	FDB	SEMIS
*
* ======>>  134  <<
	FCB	$85
	FCC	"ERAS" "E"
	FCB	$C5
	FDB	FILL-7
ERASE	FDB	DOCOL,ZERO,FILL
	FDB	SEMIS
*
* ======>>  135  <<
	FCB	$86
	FCC	"BLANK" "S"
	FCB	$D3
	FDB	ERASE-8
BLANKS	FDB	DOCOL,BL,FILL
	FDB	SEMIS
*
* ======>>  136  <<
	FCB	$84
	FCC	"HOL" "D"
	FCB	$C4
	FDB	BLANKS-9
HOLD	FDB	DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
	FDB	SEMIS
*
* ======>>  137  <<
	FCB	$83
	FCC	"PA" "D"
	FCB	$C4
	FDB	HOLD-7
PAD	FDB	DOCOL,HERE,CLITER
	FCB	$44
	FDB	PLUS
	FDB	SEMIS
*
* ######>> screen 48 <<
* ======>>  138  <<
	FCB	$84
	FCC	"WOR" "D"
	FCB	$C4
	FDB	PAD-6
WORD	FDB	DOCOL,BLK,AT,ZBRAN
	FDB	WORD2-*
	FDB	BLK,AT,BLOCK,BRAN
	FDB	WORD3-*
WORD2	FDB	TIB,AT
WORD3	FDB	IN,AT,PLUS,SWAP,ENCLOS,HERE,CLITER
	FCB	34
	FDB	BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
	FDB	CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
	FDB	SEMIS
*
* #######>>  screen 49 <<
* ======>>  139  <<
	FCB	$88
	FCC	"(NUMBER" ")"
	FCB	$A9
	FDB	WORD-7
PNUMB	FDB	DOCOL
PNUMB2	FDB	ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
	FDB	PNUMB4-*
	FDB	SWAP,BASE,AT,USTAR,DROP,ROT,BASE
	FDB	AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
	FDB	PNUMB3-*
	FDB	ONE,DPL,PSTORE
PNUMB3	FDB	FROMR,BRAN
	FDB	PNUMB2-*
PNUMB4	FDB	FROMR
	FDB	SEMIS
*
* ======>>  140  <<
	FCB	$86
	FCC	"NUMBE" "R"
	FCB	$D2
	FDB	PNUMB-11
NUMB	FDB	DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,CLITER
	FCC	"-"	minus sign
	FDB	EQUAL,DUP,TOR,PLUS,LIT,$FFFF
NUMB1	FDB	DPL,STORE,PNUMB,DUP,CAT,BL,SUB
	FDB	ZBRAN
	FDB	NUMB2-*
	FDB	DUP,CAT,CLITER
	FCC	"."
	FDB	SUB,ZERO,QERR,ZERO,BRAN
	FDB	NUMB1-*
NUMB2	FDB	DROP,FROMR,ZBRAN
	FDB	NUMB3-*
	FDB	DMINUS
NUMB3	FDB	SEMIS
*
* ======>>  141  <<
	FCB	$85
	FCC	"-FIN" "D"
	FCB	$C4
	FDB	NUMB-9
DFIND	FDB	DOCOL,BL,WORD,HERE,CONTXT,AT,AT
	FDB	PFIND,DUP,ZEQU,ZBRAN
	FDB	DFIND2-*
	FDB	DROP,HERE,LATEST,PFIND
DFIND2	FDB	SEMIS
*
* ######>> screen 50 <<
* ======>>  142  <<
	FCB	$87
	FCC	"(ABORT" ")"
	FCB	$A9
	FDB	DFIND-8
PABORT	FDB	DOCOL,ABORT
	FDB	SEMIS
*
* ======>>  143  <<
	FCB	$85
	FCC	"ERRO" "R"
	FCB	$D2
	FDB	PABORT-10
ERROR	FDB	DOCOL,WARN,AT,ZLESS
	FDB	ZBRAN
*  note:  WARNING is -1 to abort, 0 to print erro #
*         and 1 to print error message from disc
	FDB	ERROR2-*
	FDB	PABORT
ERROR2	FDB	HERE,COUNT,TYPE,PDOTQ
	FCB	4,7	( bell )
	FCC	" ? "
	FDB	MESS,SPSTOR,IN,AT,BLK,AT,QUIT
	FDB	SEMIS
*
* ======>>  144  <<
	FCB	$83
	FCC	"ID" "."
	FCB	$AE
	FDB	ERROR-8
IDDOT	FDB	DOCOL,PAD,CLITER
	FCB	32
	FDB	CLITER
	FCB	$5F	( underline )
	FDB	FILL,DUP,PFA,LFA,OVER,SUB,PAD
	FDB	SWAP,CMOVE,PAD,COUNT,CLITER
	FCB	31
	FDB	AND,TYPE,SPACE
	FDB	SEMIS
*
* ######>> screen 51 <<
* ======>>  145  <<
	FCB	$86
	FCC	"CREAT" "E"
	FCB	$C5
	FDB	IDDOT-6
CREATE	FDB	DOCOL,DFIND,ZBRAN
	FDB	CREAT2-*
	FDB	DROP,PDOTQ
	FCB	8
	FCB	7	( bel )
	FCC	"redef: "
	FDB	NFA,IDDOT,CLITER
	FCB	4
	FDB	MESS,SPACE
CREAT2	FDB	HERE,DUP,CAT,WIDTH,AT,MIN
	FDB	ONEP,ALLOT,DUP,CLITER
	FCB	$A0
	FDB	TOGGLE,HERE,ONE,SUB,CLITER
	FCB	$80
	FDB	TOGGLE,LATEST,COMMA,CURENT,AT,STORE
	FDB	HERE,TWOP,COMMA
	FDB	SEMIS
*
* ######>> screen 52 <<
* ======>>  146  <<
	FCB	$C9	immediate
	FCC	"[COMPILE" "]"
	FCB	$DD
	FDB	CREATE-9
BCOMP	FDB	DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
	FDB	SEMIS
*
* ======>>  147  <<
	FCB	$C7	immediate
	FCC	"LITERA" "L"
	FCB	$CC
	FDB	BCOMP-12
LITER	FDB	DOCOL,STATE,AT,ZBRAN
	FDB	LITER2-*
	FDB	COMPIL,LIT,COMMA
LITER2	FDB	SEMIS
*
* ======>>  148  <<
	FCB	$C8	immediate
	FCC	"DLITERA" "L"
	FCB	$CC
	FDB	LITER-10
DLITER	FDB	DOCOL,STATE,AT,ZBRAN
	FDB	DLITE2-*
	FDB	SWAP,LITER,LITER
DLITE2	FDB	SEMIS
*
* ######>> screen 53 <<
* ======>>  149  <<
	FCB	$89
	FCC	"INTERPRE" "T"
	FCB	$D4
	FDB	DLITER-11
INTERP	FDB	DOCOL
INTER2	FDB	DFIND,ZBRAN
	FDB	INTER5-*
	FDB	STATE,AT,LESS
	FDB	ZBRAN
	FDB	INTER3-*
	FDB	CFA,COMMA,BRAN
	FDB	INTER4-*
INTER3	FDB	CFA,EXEC
INTER4	FDB	BRAN
	FDB	INTER7-*
INTER5	FDB	HERE,NUMB,DPL,AT,ONEP,ZBRAN
	FDB	INTER6-*
	FDB	DLITER,BRAN
	FDB	INTER7-*
INTER6	FDB	DROP,LITER
INTER7	FDB	QSTACK,BRAN
	FDB	INTER2-*
*	FDB SEMIS never executed
*
* ######>> screen 54 <<
* ======>>  150  <<
	FCB	$89
	FCC	"IMMEDIAT" "E"
	FCB	$C5
	FDB	INTERP-12
IMMED	FDB	DOCOL,LATEST,CLITER
	FCB	$40
	FDB	TOGGLE
	FDB	SEMIS
*
* ======>>  151  <<
	FCB	$8A
	FCC	"VOCABULAR" "Y"
	FCB	$D9
	FDB	IMMED-12
VOCAB	FDB	DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
	FDB	COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
DOVOC	FDB	TWOP,CONTXT,STORE
	FDB	SEMIS
*
* ======>>  152  <<
*
* Note: FORTH does not go here in the rom-able dictionary,
*       since FORTH is a type of variable.
*
*
* ======>>  153  <<
	FCB	$8B
	FCC	10,"DEFINITION" "S"
	FCB	$D3
	FDB	VOCAB-13
DEFIN	FDB	DOCOL,CONTXT,AT,CURENT,STORE
	FDB	SEMIS
*
* ======>>  154  <<
	FCB	$C1	immediate  (
	FCB	$A8
	FDB	DEFIN-14
PAREN	FDB	DOCOL,CLITER
	FCC	")"
	FDB	WORD
	FDB	SEMIS
*
* ######>> screen 55 <<
* ======>>  155  <<
	FCB	$84
	FCC	"QUI" "T"
	FCB	$D4
	FDB	PAREN-4
QUIT	FDB	DOCOL,ZERO,BLK,STORE
	FDB	LBRAK
*
* Here is the outer interpretter
* which gets a line of input, does it, prints " OK"
* then repeats :
*
QUIT2	FDB	RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
	FDB	ZBRAN
	FDB	QUIT3-*
	FDB	PDOTQ
	FCB	3
	FCC	" OK"
QUIT3	FDB	BRAN
	FDB	QUIT2-*
*	FDB SEMIS (never executed)
*
* ======>>  156  <<
	FCB	$85
	FCC	"ABOR" "T"
	FCB	$D4
	FDB	QUIT-7
ABORT	FDB	DOCOL,SPSTOR,DEC,QSTACK,DRZERO,R,PDOTQ
	FCB	8
	FCC	"FORTH-68"
	FDB	FORTH,DEFIN
	FDB	QUIT
*	FDB SEMIS never executed
	PAGE
*
* ######>> screen 56 <<
* bootstrap code... moves rom contents to ram :
* ======>>  157  <<
	FCB	$84
	FCC	"COL" "D"
	FCB	$C4
	FDB	ABORT-8
COLD	FDB	*+2
CENT	LDS	#REND-1	top of destination
	LDX	#ERAM	top of stuff to move
COLD2	DEX
	LDAA	0,X
	PSHA		move TASK & FORTH to ram
	CPX	#RAM
	BNE	COLD2
*
	LDS	#XFENCE-1	put stack at a safe place for now
	LDX	COLINT
	STX	XCOLUM
	LDX	DELINT
	STX	XDELAY
	LDX	VOCINT
	STX	XVOCL
	LDX	DPINIT
	STX	XDP
	LDX	FENCIN
	STX	XFENCE


WENT	LDS	#XFENCE-1	top of destination
	LDX	#FENCIN	top of stuff to move
WARM2	DEX
	LDAA	0,X
	PSHA
	CPX	#SINIT
	BNE	WARM2
*
	LDS	SINIT
	LDX	UPINIT
	STX	UP	init user ram pointer
	LDX	#ABORT
	STX	IP
	NOP		Here is a place to jump to special user
	NOP		initializations such as I/O interrups
	NOP
*
*   For systems with TRACE:
	LDX	#00
	STX	TRLIM	clear trace mode
	LDX	#0
	STX	BRKPT	clear breakpoint address
	JMP	RPSTOR+2	start the virtual machine running !
*
* Here is the stuff that gets copied to ram :
* at address $140
*
RAM	FDB	$3000,$3000,0,0

* ======>>  (152)  <<
	FCB	$C5	immediate
	FCC	"FORT" "H"
	FCB	$C8
	FDB	NOOP-7
RFORTH	FDB	DODOES,DOVOC,$81A0,TASK-7
	FDB	0
	FCC	"(C) Forth Interest Group, 1979"
	FCB	$84
	FCC	"TAS" "K"
	FCB	$CB
	FDB	FORTH-8
RTASK	FDB	DOCOL,SEMIS
ERAM	FCC	"David Lion"
	PAGE
*
* ######>> screen 57 <<
* ======>>  158<<
	FCB	$84
	FCC	"S->" "D"
	FCB	$C4
	FDB	COLD-7
STOD	FDB	DOCOL,DUP,ZLESS,MINUS
	FDB	SEMIS


*
* ======>>  159  <<
	FCB	$81	*
	FCB	$AA
	FDB	STOD-7
STAR	FDB	*+2
	JSR	USTARS
	INS
	INS
	JMP	NEXT
*
* ======>>  160  <<
	FCB	$84
	FCC	"/MO" "D"
	FCB	$C4
	FDB	STAR-4
SLMOD	FDB	DOCOL,TOR,STOD,FROMR,USLASH
	FDB	SEMIS
*
* ======>>  161  <<
	FCB	$81	/
	FCB	$AF
	FDB	SLMOD-7
SLASH	FDB	DOCOL,SLMOD,SWAP,DROP
	FDB	SEMIS
*
* ======>>  162  <<
	FCB	$83
	FCC	"MO" "D"
	FCB	$C4
	FDB	SLASH-4
MOD	FDB	DOCOL,SLMOD,DROP
	FDB	SEMIS
*
* ======>>  163  <<
	FCB	$85
	FCC	"*/MO" "D"
	FCB	$C4
	FDB	MOD-6
SSMOD	FDB	DOCOL,TOR,USTAR,FROMR,USLASH
	FDB	SEMIS
*
* ======>>  164  <<
	FCB	$82
	FCC	"*" "/"
	FCB	$AF
	FDB	SSMOD-8
SSLASH	FDB	DOCOL,SSMOD,SWAP,DROP
	FDB	SEMIS
*
* ======>>  165  <<
	FCB	$85
	FCC	"M/MO" "D"
	FCB	$C4
	FDB	SSLASH-5
MSMOD	FDB	DOCOL,TOR,ZERO,R,USLASH
	FDB	FROMR,SWAP,TOR,USLASH,FROMR
	FDB	SEMIS
*
* ======>>  166  <<
	FCB	$83
	FCC	"AB" "S"
	FCB	$D3
	FDB	MSMOD-8
ABS	FDB	DOCOL,DUP,ZLESS,ZBRAN
	FDB	ABS2-*
	FDB	MINUS
ABS2	FDB	SEMIS
*
* ======>>  167  <<
	FCB	$84
	FCC	"DAB" "S"
	FCB	$D3
	FDB	ABS-6
DABS	FDB	DOCOL,DUP,ZLESS,ZBRAN
	FDB	DABS2-*
	FDB	DMINUS
DABS2	FDB	SEMIS
*
* ######>> screen 58 <<
* Disc primatives :
* ======>>  168  <<
	FCB	$83
	FCC	"US" "E"
	FCB	$C5
	FDB	DABS-7
USE	FDB	DOCON
	FDB	XUSE
*
* ======>>  169  <<
	FCB	$84
	FCC	"PRE" "V"
	FCB	$D6
	FDB	USE-6
PREV	FDB	DOCON
	FDB	XPREV
*
* ======>>  170  <<
	FCB	$84
	FCC	"+BU" "F"
	FCB	$C6
	FDB	PREV-7
PBUF	FDB	DOCOL,CLITER
	FCB	$84
	FDB	PLUS,DUP,LIMIT,EQUAL,ZBRAN
	FDB	PBUF2-*
	FDB	DROP,FIRST
PBUF2	FDB	DUP,PREV,AT,SUB
	FDB	SEMIS
*
* ======>>  171  <<
	FCB	$86
	FCC	"UPDAT" "E"
	FCB	$C5
	FDB	PBUF-7
UPDATE	FDB	DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
	FDB	SEMIS
*
* ======>>  172  <<
	FCB	$8D
	FCC	12,"EMPTY-BUFFER" "S"
	FCB	$D3
	FDB	UPDATE-9
MTBUF	FDB	DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
	FDB	SEMIS
*
* ======>>  173  <<
	FCB	$83
	FCC	"DR" "0"
	FCB	$B0
	FDB	MTBUF-16
DRZERO	FDB	DOCOL,ZERO,OFSET,STORE
	FDB	SEMIS
*
* ======>>  174  <<== system dependant word
	FCB	$83
	FCC	"DR" "1"
	FCB	$B1
	FDB	DRZERO-6
DRONE	FDB	DOCOL,LIT,$07D0,OFSET,STORE
	FDB	SEMIS
*
* ######>> screen 59 <<
* ======>>  175  <<
	FCB	$86
	FCC	"BUFFE" "R"
	FCB	$D2
	FDB	DRONE-6
BUFFER	FDB	DOCOL,USE,AT,DUP,TOR
BUFFR2	FDB	PBUF,ZBRAN
	FDB	BUFFR2-*
	FDB	USE,STORE,R,AT,ZLESS
	FDB	ZBRAN
	FDB	BUFFR3-*
	FDB	R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
BUFFR3	FDB	R,STORE,R,PREV,STORE,FROMR,TWOP
	FDB	SEMIS
*
* ######>> screen 60 <<
* ======>>  176  <<
	FCB	$85
	FCC	"BLOC" "K"
	FCB	$CB
	FDB	BUFFER-9
BLOCK	FDB	DOCOL,OFSET,AT,PLUS,TOR
	FDB	PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
	FDB	BLOCK5-*
BLOCK3	FDB	PBUF,ZEQU,ZBRAN
	FDB	BLOCK4-*
	FDB	DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
BLOCK4	FDB	DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
	FDB	BLOCK3-*
	FDB	DUP,PREV,STORE
BLOCK5	FDB	FROMR,DROP,TWOP
	FDB	SEMIS
*
* ######>> screen 61 <<
* ======>>  177  <<
	FCB	$86
	FCC	"(LINE" ")"
	FCB	$A9
	FDB	BLOCK-8
PLINE	FDB	DOCOL,TOR,CLITER
	FCB	$40
	FDB	BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,CLITER
	FCB	$40
	FDB	SEMIS
*
* ======>>  178  <<
	FCB	$85
	FCC	".LIN" "E"
	FCB	$C5
	FDB	PLINE-9
DLINE	FDB	DOCOL,PLINE,DTRAIL,TYPE
	FDB	SEMIS
*
* ======>>  179  <<
	FCB	$87
	FCC	"MESSAG" "E"
	FCB	$C5
	FDB	DLINE-8
MESS	FDB	DOCOL,WARN,AT,ZBRAN
	FDB	MESS3-*
	FDB	DDUP,ZBRAN
	FDB	MESS3-*
	FDB	CLITER
	FCB	4
	FDB	OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
	FDB	MESS4-*
MESS3	FDB	PDOTQ
	FCB	6
	FCC	"err # "
	FDB	DOT
MESS4	FDB	SEMIS
*
* ######>> screen 62 <<
* ======>>  180  <<
	FCB	$84
	FCC	"LOA" "D"	input:scr #
	FCB	$C4
	FDB	MESS-10
LOAD	FDB	DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
	FDB	BSCR,STAR,BLK,STORE
	FDB	INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
	FDB	SEMIS
*
* ======>>  181  <<
	FCB	$C3
	FCC	"--" ">"
	FCB	$BE
	FDB	LOAD-7
ARROW	FDB	DOCOL,QLOAD,ZERO,IN,STORE,BSCR
	FDB	BLK,AT,OVER,MOD,SUB,BLK,PSTORE
	FDB	SEMIS
	PAGE
*
* ######>> screen 63 <<
*     The next 4 subroutines are machine dependant, and are
*     called by words 13 through 16 in the dictionary.
*
* ======>>  182  << code for EMIT
PEMIT	STAB	N	save B
	STX	N+1	save X
	LDAB	ACIAC
	BITB	#2	check ready bit
	BEQ	PEMIT+4	if not ready for more data
	STAA	ACIAD
	LDX	UP
	STAB	IOSTAT-UORIG,X
	LDAB	N	recover B & X
	LDX	N+1
	RTS		only A register may change
* PEMIT JMP $E1D1   for MIKBUT
* PEMIT FCB $3F,$11,$39 for PROTO
* PEMIT JMP $D286  for Smoke Signal DOS
*
* ======>>  183  << code for KEY
PKEY	STAB	N
	STX	N+1
	LDAB	ACIAC
	ASRB
	BCC	PKEY+4	no incoming data yet
	LDAA	ACIAD
	ANDA	#$7F	strip parity big
	LDX	UP
	STAB	IOSTAT+1-UORIG,X
	LDAB	N
	LDX	N+1
	RTS
* PKEY JMP $E1AC   for MIKBUG
* PKEY FCB $3F,$14,$39 for AMI PROTO
* PKEY JMP $D289  for Smoke Signal DOS
*
* ######>> screen 64 <<
* ======>>  184  << code for ?TERMINAL
PQTER	LDAA	ACIAC	Test for 'break' condition
	ANDA	#$11	mask framing error bit and
*       input buffer full
	BEQ	PQTER2
	LDAA	ACIAD	clear input buffer
	LDAA	#01
PQTER2	RTS
*
* ======>>  185  << code for CR
PCR	LDAA	#$D	carriage return
	BSR	PEMIT
	LDAA	#$A	line feed
	BSR	PEMIT
	LDAA	#$7F	rubout
	LDX	UP
	LDAB	XDELAY+1-UORIG,X
PCR2	DECB
	BMI	PQTER2	return if minus
	PSHB		save counter
	BSR	PEMIT	print RUBOUTs to delay.....
	PULB
	BRA	PCR2	repeat
	PAGE
*
* ######>> screen 66 <<
* ======>>  187  <<
	FCB	$85
	FCC	"?DIS" "C"
	FCB	$C3
	FDB	ARROW-6
QDISC	FDB	*+2
	JMP	NEXT
*
* ######>> screen 67 <<
* ======>>  189  <<
	FCB	$8B
	FCC	10,"BLOCK-WRIT" "E"
	FCB	$C5
	FDB	QDISC-8
BWRITE	FDB	*+2
	JMP	NEXT
*
* ######>> screen 68 <<
* ======>>  190  <<
	FCB	$8A
	FCC	"BLOCK-REA" "D"
	FCB	$C5
	FDB	BWRITE-14
BREAD	FDB	*+2
	JMP	NEXT
*
* The next 3 words are written to create a substitute for disc
* mass memory, located between $3210 & $3FFF in ram.
* ======>>  190.1  <<
	FCB	$82
	FCC	"L" "O"
	FCB	$CF
	FDB	BREAD-13
LO	FDB	DOCON
	FDB	MEMEND	a system dependant equate at front
*
* ======>>  190.2  <<
	FCB	$82
	FCC	"H" "I"
	FCB	$C9
	FDB	LO-5
HI	FDB	DOCON
	FDB	MEMTOP	( $3FFF in this version )
*
* ######>> screen 69 <<
* ======>>  191  <<
	FCB	$83
	FCC	"R/" "W"
	FCB	$D7
	FDB	HI-5
RW	FDB	DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
	FDB	RW2-*
	FDB	PDOTQ
	FCB	8
	FCC	" Range ?"
	FDB	QUIT
RW2	FDB	FROMR,ZBRAN
	FDB	RW3-*
	FDB	SWAP
RW3	FDB	BBUF,CMOVE
	FDB	SEMIS
*
* ######>> screen 72 <<
* ======>>  192  <<
	FCB	$C1	immediate
	FCB	$A7	'  ( tick )
	FDB	RW-6
TICK	FDB	DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
	FDB	SEMIS
*
* ======>>  193  <<
	FCB	$86
	FCC	"FORGE" "T"
	FCB	$D4
	FDB	TICK-4
FORGET	FDB	DOCOL,CURENT,AT,CONTXT,AT,SUB,CLITER
	FCB	$18
	FDB	QERR,TICK,DUP,FENCE,AT,LESS,CLITER
	FCB	$15
	FDB	QERR,DUP,ZERO,PORIG,GREAT,CLITER
	FCB	$15
	FDB	QERR,DUP,NFA,DP,STORE,LFA,AT,CONTXT,AT,STORE
	FDB	SEMIS
*
* ######>> screen 73 <<
* ======>>  194  <<
	FCB	$84
	FCC	"BAC" "K"
	FCB	$CB
	FDB	FORGET-9
BACK	FDB	DOCOL,HERE,SUB,COMMA
	FDB	SEMIS
*
* ======>>  195  <<
	FCB	$C5
	FCC	"BEGI" "N"
	FCB	$CE
	FDB	BACK-7
BEGIN	FDB	DOCOL,QCOMP,HERE,ONE
	FDB	SEMIS
*
* ======>>  196  <<
	FCB	$C5
	FCC	"ENDI" "F"
	FCB	$C6
	FDB	BEGIN-8
ENDIF	FDB	DOCOL,QCOMP,TWO,QPAIRS,HERE
	FDB	OVER,SUB,SWAP,STORE
	FDB	SEMIS
*
* ======>>  197  <<
	FCB	$C4
	FCC	"THE" "N"
	FCB	$CE
	FDB	ENDIF-8
THEN	FDB	DOCOL,ENDIF
	FDB	SEMIS
*
* ======>>  198  <<
	FCB	$C2
	FCC	"D" "O"
	FCB	$CF
	FDB	THEN-7
DO	FDB	DOCOL,COMPIL,XDO,HERE,THREE
	FDB	SEMIS
*
* ======>>  199  <<
	FCB	$C4
	FCC	"LOO" "P"
	FCB	$D0
	FDB	DO-5
LOOP	FDB	DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
	FDB	SEMIS
*
* ======>>  200  <<
	FCB	$C5
	FCC	"+LOO" "P"
	FCB	$D0
	FDB	LOOP-7
PLOOP	FDB	DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
	FDB	SEMIS
*
* ======>>  201  <<
	FCB	$C5
	FCC	"UNTI" "L"	( same as END )
	FCB	$CC
	FDB	PLOOP-8
UNTIL	FDB	DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK
	FDB	SEMIS
*
* ######>> screen 74 <<
* ======>>  202  <<
	FCB	$C3
	FCC	"EN" "D"
	FCB	$C4
	FDB	UNTIL-8
END	FDB	DOCOL,UNTIL
	FDB	SEMIS
*
* ======>>  203  <<
	FCB	$C5
	FCC	"AGAI" "N"
	FCB	$CE
	FDB	END-6
AGAIN	FDB	DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
	FDB	SEMIS
*
* ======>>  204  <<
	FCB	$C6
	FCC	"REPEA" "T"
	FCB	$D4
	FDB	AGAIN-8
REPEAT	FDB	DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
	FDB	TWO,SUB,ENDIF
	FDB	SEMIS
*
* =======>>  205  <<
	FCB	$C2
	FCC	"I" "F"
	FCB	$C6
	FDB	REPEAT-9
IF	FDB	DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
	FDB	SEMIS
*
* ======>>  206  <<
	FCB	$C5
	FCC	"ELS" "E"
	FCB	$C5
	FDB	IF-5
ELSE	FDB	DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
	FDB	ZERO,COMMA,SWAP,TWO,ENDIF,TWO
	FDB	SEMIS
*
* ======>>  207  <<
	FCB	$C5
	FCC	"WHIL" "E"
	FCB	$C5
	FDB	ELSE-7
WHILE	FDB	DOCOL,IF,TWOP
	FDB	SEMIS
*
* ######>> screen 75 <<
* ======>>  208  <<
	FCB	$86
	FCC	"SPACE" "S"
	FCB	$D3
	FDB	WHILE-8
SPACES	FDB	DOCOL,ZERO,MAX,DDUP,ZBRAN
	FDB	SPACE3-*
	FDB	ZERO,XDO
SPACE2	FDB	SPACE,XLOOP
	FDB	SPACE2-*
SPACE3	FDB	SEMIS
*
* ======>>  209  <<
	FCB	$82
	FCC	"<" "#"
	FCB	$A3
	FDB	SPACES-9
BDIGS	FDB	DOCOL,PAD,HLD,STORE
	FDB	SEMIS
*
* ======>>  210  <<
	FCB	$82
	FCC	"#" ">"
	FCB	$BE
	FDB	BDIGS-5
EDIGS	FDB	DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
	FDB	SEMIS
*
* ======>>  211  <<
	FCB	$84
	FCC	"SIG" "N"
	FCB	$CE
	FDB	EDIGS-5
SIGN	FDB	DOCOL,ROT,ZLESS,ZBRAN
	FDB	SIGN2-*
	FDB	CLITER
	FCC	"-"
	FDB	HOLD
SIGN2	FDB	SEMIS
*
* ======>>  212  <<
	FCB	$81	#
	FCB	$A3
	FDB	SIGN-7
DIG	FDB	DOCOL,BASE,AT,MSMOD,ROT,CLITER
	FCB	9
	FDB	OVER,LESS,ZBRAN
	FDB	DIG2-*
	FDB	CLITER
	FCB	7
	FDB	PLUS
DIG2	FDB	CLITER
	FCC	"0"	ascii zero
	FDB	PLUS,HOLD
	FDB	SEMIS
*
* ======>>  213  <<
	FCB	$82
	FCC	"#" "S"
	FCB	$D3
	FDB	DIG-4
DIGS	FDB	DOCOL
DIGS2	FDB	DIG,OVER,OVER,OR,ZEQU,ZBRAN
	FDB	DIGS2-*
	FDB	SEMIS
*
*
* ######>> screen 76 <<
* ======>>  214  <<
	FCB	$82
	FCC	"." "R"
	FCB	$D2
	FDB	DIGS-5
DOTR	FDB	DOCOL,TOR,STOD,FROMR,DDOTR
	FDB	SEMIS
*
* ======>>  215  <<
	FCB	$83
	FCC	"D." "R"
	FCB	$D2
	FDB	DOTR-5
DDOTR	FDB	DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
	FDB	EDIGS,FROMR,OVER,SUB,SPACES,TYPE
	FDB	SEMIS
*
* ======>>  216  <<
	FCB	$82
	FCC	"D" "."
	FCB	$AE
	FDB	DDOTR-6
DDOT	FDB	DOCOL,ZERO,DDOTR,SPACE
	FDB	SEMIS
*
* ======>>  217  <<
	FCB	$81	.
	FCB	$AE
	FDB	DDOT-5
DOT	FDB	DOCOL,STOD,DDOT
	FDB	SEMIS
*
* ======>>  218  <<
	FCB	$81	?
	FCB	$BF
	FDB	DOT-4
QUEST	FDB	DOCOL,AT,DOT
	FDB	SEMIS
*
* ######>> screen 77 <<
* ======>>  219  <<
	FCB	$84
	FCC	"LIS" "T"
	FCB	$D4
	FDB	QUEST-4
LIST	FDB	DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
	FCB	6
	FCC	"SCR # "
	FDB	DOT,CLITER
	FCB	$10
	FDB	ZERO,XDO
LIST2	FDB	CR,I,THREE
	FDB	DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
	FDB	LIST2-*
	FDB	CR
	FDB	SEMIS
*
* ======>>  220  <<
	FCB	$85
	FCC	"INDE" "X"
	FCB	$D8
	FDB	LIST-7
INDEX	FDB	DOCOL,CR,ONEP,SWAP,XDO
INDEX2	FDB	CR,I,THREE
	FDB	DOTR,SPACE,ZERO,I,DLINE
	FDB	QTERM,ZBRAN
	FDB	INDEX3-*
	FDB	LEAVE
INDEX3	FDB	XLOOP
	FDB	INDEX2-*
	FDB	SEMIS
*
* ======>>  221  <<
	FCB	$85
	FCC	"TRIA" "D"
	FCB	$C4
	FDB	INDEX-8
TRIAD	FDB	DOCOL,THREE,SLASH,THREE,STAR
	FDB	THREE,OVER,PLUS,SWAP,XDO
TRIAD2	FDB	CR,I
	FDB	LIST,QTERM,ZBRAN
	FDB	TRIAD3-*
	FDB	LEAVE
TRIAD3	FDB	XLOOP
	FDB	TRIAD2-*
	FDB	CR,CLITER
	FCB	$0F
	FDB	MESS,CR
	FDB	SEMIS
*
* ######>> screen 78 <<
* ======>>  222  <<
	FCB	$85
	FCC	"VLIS" "T"
	FCB	$D4
	FDB	TRIAD-8
VLIST	FDB	DOCOL,CLITER
	FCB	$80
	FDB	OUT,STORE,CONTXT,AT,AT
VLIST1	FDB	OUT,AT,COLUMS,AT,CLITER
	FCB	32
	FDB	SUB,GREAT,ZBRAN
	FDB	VLIST2-*
	FDB	CR,ZERO,OUT,STORE
VLIST2	FDB	DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
	FDB	DUP,ZEQU,QTERM,OR,ZBRAN
	FDB	VLIST1-*
	FDB	DROP
	FDB	SEMIS
*
* ======>>  XX  <<
	FCB	$84
	FCC	"NOO" "P"
	FCB	$D0
	FDB	VLIST-8
NOOP	FDB	NEXT	a useful no-op
ZZZZ	FDB	0,0,0,0,0,0,0,0	end of rom program
	END
