OPT PRT

* fig-FORTH FOR 6800 => 6809, ***** Not yet functioning!!! *****
* ASSEMBLY SOURCE LISTING

* RELEASE 1
* MAY 1979
* WITH COMPILER SECURITY
* AND VARIABLE LENGTH NAMES

* This (not reallly) public domain publication is provided
* through the courtesy of:
* FORTH
* INTEREST
* GROUP
* fig

* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
* Further distribution must include this notice.
	PAGE
	NAM	Copyright:FORTH Interest Group
	OPT	NOG,PAG
* filename FTH7.21
* === FORTH-6800 06-06-79 21:OO


* This listing is NOT in the PUBLIC DOMAIN but 
* 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,
* and all risk of use is ENTIRELY assumed by the user.


* === 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
*
* ++++ Brain-dead conversion to non-optimal 6809 source by Joel Matthew Rees
* ++++ using a perl script published elsewhere in his pastebin on OSDN.
*
*  This version was developed on an AMI EVK 300 PROTO
*  system using an ACIA for the I/O. All terminal 1/0
*  is done in three subroutines:
*   PEMIT  ( 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 fact 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 model 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
*  - -
*    |
*    I	DICTIONARY grows upward
* 
*  183	end of ram-dictionary.		<== DP	DPINIT
*	"TASK"
*
*  150	"FORTH" ( a word )		<=, <== CONTEXT
*					`==== CURRENT
*  148	start of ram-dictionary.
*
*  100	user #l table of variables	<= UP	DPINIT
*   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 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 $OOFO:


W	RMB	2	the instruction register points to 6800 code
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' table
*		( 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 ( O=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 )

	PAGE
*  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'	; 'FORTH'
	FCB	$C8
	FDB	NOOP-7
FORTH	FDB	DODOES,DOVOC,$81A0,TASK-7
	FDB	0
*
	FCC	"(C) Forth Interest Group, 1979"

	FCB	$84
	FCC	'TAS'	; 'TASK'
	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 desired
	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 parmeters **************************
*
	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	
COLINT	FDB	132	initial terminal carriage width
DELINT	FDB	4	initial carriage return delay
****************************************************
*
	PAGE
*
* ######>> screen 13 <<
PULABX	PULS A	; 24 cycles until 'NEXT'
	PULS B	; 
STABX	STA 0,X	16 cycles until 'NEXT'
	STB 1,X
	BRA	NEXT
GETX	LDA 0,X	18 cycles until 'NEXT'
	LDB 1,X
PUSHBA	PSHS B	; 8 cycles until 'NEXT'
	PSHS A	; 



*
* "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
	LEAX 1,X	; 		pre-increment mode
	LEAX 1,X	; 
	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:                                =
*                                                                 =
	JMP	0,X
	NOP
*	JMP	TRACE	( an alternate for the above )
*                                                                 =
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =


	PAGE
*
* ======>>  1  <<
	FCB	$83
	FCC	'LI'	; 'LIT' : 	NOTE: this is different from LITERAL
	FCB	$D4
	FDB	0	link of zero to terminate dictionary scan
LIT	FDB	*+2
	LDX	IP
	LEAX 1,X	; 
	LEAX 1,X	; 
	STX	IP
	LDA 0,X
	LDB 1,X
	JMP	PUSHBA
*
* ######>> screen 14 <<
* ======>>  2  <<
CLITER	FDB	*+2	 (this is an invisible word, with no header)
	LDX	IP
	LEAX 1,X	; 
	STX	IP
	CLRA	;
	LDB 1,X
	JMP	PUSHBA
*
* ======>>  3  <<
	FCB	$87
	FCC	'EXECUT'	; 'EXECUTE'
	FCB	$C5
	FDB	LIT-6
EXEC	FDB	*+2
	TFR S,X	; TSX : 
	LDX	0,X	get code field address (CFA)
	LEAS 1,S	; 		pop stack
	LEAS 1,S	; 
	JMP	NEXT3
*
* ######>> screen 15 <<
* ======>>  4  <<
	FCB	$86
	FCC	'BRANC'	; 'BRANCH'
	FCB	$C8
	FDB	EXEC-10
BRAN	FDB	ZBYES	Go steal code in ZBRANCH
*
* ======>>  5  <<
	FCB	$87
	FCC	'0BRANC'	; '0BRANCH'
	FCB	$C8
	FDB	BRAN-9
ZBRAN	FDB	*+2
	PULS A	; 
	PULS B	; 
	PSHS B	; ** emulating ABA:
	ADDA ,S+	; 
	BNE	ZBNO
	BCS	ZBNO
ZBYES	LDX	IP	Note: code is shared with BRANCH, (+LOOP), (LOOP)
	LDB 3,X
	LDA 2,X
	ADDB IP+1
	ADCA IP
	STB IP+1
	STA IP
	JMP	NEXT
ZBNO	LDX	IP	no branch. This code is shared with (+LOOP), (LOOP).
	LEAX 1,X	; 		jump over branch delta
	LEAX 1,X	; 
	STX	IP
	JMP	NEXT
*
* ######>> screen 16 <<
* ======>>  6  <<
	FCB	$86
	FCC	'(LOOP'	; '(LOOP)'
	FCB	$A9
	FDB	ZBRAN-10
XLOOP	FDB	*+2
	CLRA	;
	LDB #1	get set to increment counter by 1
	BRA	XPLOP2	go steal other guy's code!
*
* ======>>  7  <<
	FCB	$87
	FCC	'(+LOOP'	; '(+LOOP)'
	FCB	$A9
	FDB	XLOOP-9
XPLOOP	FDB *+2	Note: +LOOP has an un-signed loop counter
	PULS A	; get increment
	PULS B	; 
XPLOP2	TSTA	;
	BPL	XPLOF	forward looping
	BSR	XPLOPS
	ORCC #$01	; SEC : 
	SBCB 5,X
	SBCA 4,X
	BPL	ZBYES
	BRA	XPLONO	fall through
*
* the subroutine :
XPLOPS	LDX	RP
	ADDB 3,X	add it to counter
	ADCA 2,X
	STB 3,X	store new counter value
	STA 2,X
	RTS
*
XPLOF	BSR	XPLOPS
	SUBB 5,X
	SBCA 4,X
	BMI	ZBYES
*
XPLONO	LEAX 1,X	; 		done, don't branch back
	LEAX 1,X	; 
	LEAX 1,X	; 
	LEAX 1,X	; 
	STX	RP
	BRA	ZBNO	use ZBRAN to skip over unused delta
*
* ######>> screen 17 <<
* ======>>  8  <<
	FCB	$84
	FCC	'(DO'	; '(DO)'
	FCB	$A9
	FDB	XPLOOP-10
XDO	FDB	*+2	This is the RUNTIME DO, not the COMPILING DO
	LDX	RP
	LEAX -1,X	; 
	LEAX -1,X	; 
	LEAX -1,X	; 
	LEAX -1,X	; 
	STX	RP
	PULS A	; 
	PULS B	; 
	STA 2,X
	STB 3,X
	PULS A	; 
	PULS B	; 
	STA 4,X
	STB 5,X
	JMP	NEXT
*
* ======>>  9  <<
	FCB	$81	I
	FCB	$C9
	FDB	XDO-7	
I	FDB	*+2
	LDX	RP
	LEAX 1,X	; 
	LEAX 1,X	; 
	JMP	GETX
*
* ######>> screen 18 <<
* ======>>  10  <<
	FCB	$85
	FCC	'DIGI'	; 'DIGIT'
	FCB	$D4
	FDB	I-4
DIGIT	FDB	*+2	NOTE: legal input range is 0-9, A-Z
	TFR S,X	; TSX : 
	LDA 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
	LDB #1	set flag
	STA 3,X	store digit
DIGIT1	STB 1,X	store the flag
	JMP	NEXT
DIGIT2	CLRB	;
	LEAS 1,S	; 
	LEAS 1,S	; 	pop bottom number
	TFR S,X	; TSX : 
	STB 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 /
* parameter fields
*    "
*    "
*    "
*
* ======>>  11  <<
	FCB	$86
	FCC	'(FIND'	; '(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
	LDB #4
PFIND0	PULS A	; loop to get arguments
	STA 0,X
	LEAX 1,X	; 
	DECB	;
	BNE	PFIND0
*
	LDX	PD
PFIND1	LDB 0,X	get count dict count
	STB PC
	ANDB #$3F
	LEAX 1,X	; 
	STX	PD	update PD
	LDX	PA0
	LDA 0,X	get count from arg
	LEAX 1,X	; 
	STX	PA	intialize PA
	PSHS B	; ** emulating CBA:
	CMPA ,S+	; 		compare lengths
	BNE	PFIND4
PFIND2	LDX	PA
	LDA 0,X
	LEAX 1,X	; 
	STX	PA
	LDX	PD
	LDB 0,X
	LEAX 1,X	; 
	STX	PD
	TSTB	;		is dict entry neg. ?
	BPL	PFIND8
	ANDB #$7F	clear sign
	PSHS B	; ** emulating CBA:
	CMPA ,S+	; 
	BEQ	FOUND
PFIND3	LDX	0,X	get new link
	BNE	PFIND1	continue if link not=0
*
*	not found :
*
	CLRA	;
	CLRB	;
	JMP	PUSHBA
PFIND8	PSHS B	; ** emulating CBA:
	CMPA ,S+	; 
	BEQ	PFIND2
PFIND4	LDX	PD
PFIND9	LDB 0,X	scan forward to end of this name
	LEAX 1,X	; 
	BPL	PFIND9
	BRA	PFIND3
*
*	found :
*
FOUND	LDA PD	compute CFA
	LDB PD+1
	ADDB #4
	ADCA #0
	PSHS B	; 
	PSHS A	; 
	LDA PC
	PSHS A	; 
	CLRA	;
	PSHS A	; 
	LDB #1
	JMP	PUSHBA
*
	PSHS A	; 
	CLRA	;
	PSHS A	; 
	LDB #1
	JMP	PUSHBA
*
* ######>> screen 20 <<
* ======>>  12  <<
	FCB	$87
	FCC	'ENCLOS'	; 'ENCLOSE'
	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
	LEAS 1,S	; 
	PULS B	; now, get the low byte, for an 8-bit delimiter
	TFR S,X	; TSX : 
	LDX	0,X
	CLR N
*	wait for a non-delimiter or a NUL
ENCL2	LDA 0,X
	BEQ	ENCL6
	PSHS B	; ** emulating CBA:
	CMPA ,S+	; 		CHECK FOR DELIM
	BNE	ENCL3
	LEAX 1,X	; 
	INC N
	BRA	ENCL2
*	found first character. Push FC
ENCL3	LDA N	found first char.
	PSHS A	; 
	CLRA	;
	PSHS A	; 
*	wait for a delimiter or a NUL
ENCL4	LDA 0,X
	BEQ	ENCL7
	PSHS B	; ** emulating CBA:
	CMPA ,S+	; 		ckech for delim.
	BEQ	ENCL5
	LEAX 1,X	; 
	INC N
	BRA	ENCL4
*	found EW. Push it
ENCL5	LDB N
	CLRA	;
	PSHS B	; 
	PSHS A	; 
*	advance and push NC
	INCB	;
	JMP	PUSHBA
*	found NUL before non-delimiter, therefore there is no word
ENCL6	LDB N	found NUL
	PSHS B	; 
	PSHS A	; 
	INCB	;
	BRA	ENCL7+2	
*	found NUL following the word instead of SPACE
ENCL7	LDB N
	PSHS B	; save EW
	PSHS A	; 
ENCL8	LDB N	save NC
	JMP	PUSHBA

	PAGE
*
* ######>> screen 21 <<
* The next 4 words call system dependant I/O routines
* which are listed after word "-->" ( lable: "arrow" )
* in the dictionary.
*
* ======>>  13  <<
	FCB	$84
	FCC	'EMI'	; 'EMIT'
	FCB	$D4
	FDB	ENCLOS-10
EMIT	FDB	*+2
	PULS A	; 
	PULS A	; 
	JSR	PEMIT
	LDX	UP
	INC XOUT+1-UORIG,X
	BNE *+4	; 
	****WARNING**** HARD OFFSET: *+4 ****
	INC XOUT-UORIG,X
	JMP	NEXT
*
* ======>>  14  <<
	FCB	$83
	FCC	'KE'	; 'KEY'
	FCB	$D9
	FDB	EMIT-7
KEY	FDB	*+2
	JSR	PKEY
	PSHS A	; 
	CLRA	;
	PSHS A	; 
	JMP	NEXT
*
* ======>>  15  <<
	FCB	$89
	FCC	'?TERMINA'	; '?TERMINAL'
	FCB	$CC
	FDB	KEY-6
QTERM	FDB	*+2
	JSR	PQTER
	CLRB	;
	JMP	PUSHBA	stack the flag
*
* ======>>  16  <<
	FCB	$82
	FCC	'C'	; 'CR'
	FCB	$D2
	FDB	QTERM-12
CR	FDB	*+2
	JSR	PCR
	JMP	NEXT
*
* ######>> screen 22 <<
* ======>>  17  <<
	FCB	$85
	FCC	'CMOV'	; 'CMOVE' : 	source, destination, count
	FCB	$C5
	FDB	CR-5
CMOVE	FDB	*+2	takes ( 43+47*count cycles )
	LDX	#N
	LDB #6
CMOV1	PULS A	; 
	STA 0,X	move parameters to scratch area
	LEAX 1,X	; 
	DECB	;
	BNE	CMOV1
CMOV2	LDA N
	LDB N+1
	SUBB #1
	SBCA #0
	STA N
	STB N+1
	BCS	CMOV3
	LDX	N+4
	LDA 0,X
	LEAX 1,X	; 
	STX	N+4
	LDX	N+2
	STA 0,X
	LEAX 1,X	; 
	STX	N+2
	BRA	CMOV2
CMOV3	JMP	NEXT
*
* ######>> screen 23 <<
* ======>>  18  <<
	FCB	$82
	FCC	'U'	; 'U*'
	FCB	$AA
	FDB	CMOVE-8
USTAR	FDB	*+2
	BSR	USTARS
	LEAS 1,S	; 
	LEAS 1,S	; 
	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	LDA #16	bits/word counter
	PSHS A	; 
	CLRA	;
	CLRB	;
	TFR S,X	; 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	LEAS 1,S	; 		dump counter
	RTS
*
* ######>> screen 24 <<
* ======>>  19  <<
	FCB	$82
	FCC	'U'	; 'U/'
	FCB	$AF
	FDB	USTAR-5
USLASH	FDB	*+2
	LDA #17
	PSHS A	; 
	TFR S,X	; TSX : 
	LDA 3,X
	LDB 4,X
USL1	CMPA 1,X
	BHI	USL3
	BCS	USL2
	CMPB 2,X
	BCC	USL3
USL2	ANDCC #~$01	; CLC : 
	BRA	USL4
USL3	SUBB 2,X
	SBCA 1,X
	ORCC #$01	; SEC : 
USL4	ROL 6,X
	ROL 5,X
	DEC 0,X
	BEQ	USL5
	ROLB	;
	ROLA	;
	BCC	USL1
	BRA	USL3
USL5	LEAS 1,S	; 
	LEAS 1,S	; 
	LEAS 1,S	; 
	LEAS 1,S	; 
	LEAS 1,S	; 
	JMP	SWAP+4	reverse quotient & remainder
*
* ######>> screen 25 <<
* ======>>  20  <<
	FCB	$83
	FCC	'AN'	; 'AND'
	FCB	$C4
	FDB	USLASH-5
AND	FDB	*+2
	PULS A	; 
	PULS B	; 
	TFR S,X	; TSX : 
	ANDB 1,X
	ANDA 0,X
	JMP	STABX
*
* ======>>  21  <<
	FCB	$82
	FCC	'O'	; 'OR'
	FCB	$D2
	FDB	AND-6
OR	FDB	*+2
	PULS A	; 
	PULS B	; 
	TFR S,X	; TSX : 
	ORB 1,X
	ORA 0,X
	JMP	STABX
*	
* ======>>  22  <<
	FCB	$83
	FCC	'XO'	; 'XOR'
	FCB	$D2
	FDB	OR-5
XOR	FDB	*+2
	PULS A	; 
	PULS B	; 
	TFR S,X	; TSX : 
	EORB 1,X
	EORA 0,X
	JMP	STABX
*
* ######>> screen 26 <<
* ======>>  23  <<
	FCB	$83
	FCC	'SP'	; 'SP@'
	FCB	$C0
	FDB	XOR-6
SPAT	FDB	*+2
	TFR S,X	; TSX : 
	STX	N	scratch area
	LDX	#N
	JMP	GETX
*
* ======>>  24  <<
	FCB	$83
	FCC	'SP'	; 'SP!'
	FCB	$A1
	FDB	SPAT-6
SPSTOR	FDB	*+2
	LDX	UP
	LDX	XSPZER-UORIG,X
	TFR X,S	; TXS : 		watch it ! X and S are not equal.
	JMP	NEXT
* ======>>  25  <<
	FCB	$83
	FCC	'RP'	; '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
	LEAX 1,X	; 
	LEAX 1,X	; 
	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'	; 'LEAVE'
	FCB	$C5
	FDB	SEMIS-5
LEAVE	FDB	*+2
	LDX	RP
	LDA 2,X
	LDB 3,X
	STA 4,X
	STB 5,X
	JMP	NEXT
*
* ======>>  28  <<
	FCB	$82
	FCC	'>'	; '>R'
	FCB	$D2
	FDB	LEAVE-8
TOR	FDB	*+2
	LDX	RP
	LEAX -1,X	; 
	LEAX -1,X	; 
	STX	RP
	PULS A	; 
	PULS B	; 
	STA 2,X
	STB 3,X
	JMP	NEXT
*
* ======>>  29  <<
	FCB	$82
	FCC	'R'	; 'R>'
	FCB	$BE
	FDB	TOR-5
FROMR	FDB	*+2
	LDX	RP
	LDA 2,X
	LDB 3,X
	LEAX 1,X	; 
	LEAX 1,X	; 
	STX	RP
	JMP	PUSHBA
*
* ======>>  30  <<
	FCB	$81	R
	FCB	$D2
	FDB	FROMR-5
R	FDB	*+2
	LDX	RP
	LEAX 1,X	; 
	LEAX 1,X	; 
	JMP	GETX
*
* ######>> screen 28 <<
* ======>>  31  <<
	FCB	$82
	FCC	'0'	; '0='
	FCB	$BD
	FDB	R-4
ZEQU	FDB	*+2
	TFR S,X	; TSX : 
	CLRA	;
	CLRB	;
	LDX	0,X
	BNE	ZEQU2
	INCB	;
ZEQU2	TFR S,X	; TSX : 
	JMP	STABX
*
* ======>>  32  <<
	FCB	$82
	FCC	'0'	; '0<'
	FCB	$BC
	FDB	ZEQU-5
ZLESS	FDB	*+2
	TFR S,X	; TSX : 
	LDA #$80	check the sign bit
	ANDA 0,X
	BEQ	ZLESS2
	CLRA	;		if neg.
	LDB #1
	JMP	STABX
ZLESS2	CLRB	;
	JMP	STABX
*
* ######>> screen 29 <<
* ======>>  33  <<
	FCB	$81	'+'
	FCB	$AB
	FDB	ZLESS-5
PLUS	FDB	*+2
	PULS A	; 
	PULS B	; 
	TFR S,X	; TSX : 
	ADDB 1,X
	ADCA 0,X
	JMP	STABX
*
* ======>>  34  <<
	FCB	$82
	FCC	'D'	; 'D+'
	FCB	$AB
	FDB	PLUS-4
DPLUS	FDB	*+2
	TFR S,X	; TSX : 
	ANDCC #~$01	; CLC : 
	LDB #4
DPLUS2	LDA 3,X
	ADCA 7,X
	STA 7,X
	LEAX -1,X	; 
	DECB	;
	BNE	DPLUS2
	LEAS 1,S	; 
	LEAS 1,S	; 
	LEAS 1,S	; 
	LEAS 1,S	; 
	JMP	NEXT
*
* ======>>  35  <<
	FCB	$85
	FCC	'MINU'	; 'MINUS'
	FCB	$D3
	FDB	DPLUS-5
MINUS	FDB	*+2
	TFR S,X	; TSX : 
	NEG 1,X
	BCC	MINUS2
	NEG 0,X
	BRA	MINUS3
MINUS2	COM 0,X
MINUS3	JMP	NEXT
*
* ======>>  36  <<
	FCB	$86
	FCC	'DMINU'	; 'DMINUS'
	FCB	$D3
	FDB	MINUS-8
DMINUS	FDB	*+2
	TFR S,X	; 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'	; 'OVER'
	FCB	$D2
	FDB	DMINUS-9
OVER	FDB	*+2
	TFR S,X	; TSX : 
	LDA 2,X
	LDB 3,X
	JMP	PUSHBA
*
* ======>>  38  <<
	FCB	$84
	FCC	'DRO'	; 'DROP'
	FCB	$D0
	FDB	OVER-7
DROP	FDB	*+2
	LEAS 1,S	; 
	LEAS 1,S	; 
	JMP	NEXT
*
* ======>>  39  <<
	FCB	$84
	FCC	'SWA'	; 'SWAP'
	FCB	$D0
	FDB	DROP-7
SWAP	FDB	*+2
	PULS A	; 
	PULS B	; 
	TFR S,X	; TSX : 
	LDX	0,X
	LEAS 1,S	; 
	LEAS 1,S	; 
	PSHS B	; 
	PSHS A	; 
	STX	N
	LDX	#N
	JMP	GETX
*
* ======>>  40  <<
	FCB	$83
	FCC	'DU'	; 'DUP'
	FCB	$D0
	FDB	SWAP-7
DUP	FDB	*+2
	PULS A	; 
	PULS B	; 
	PSHS B	; 
	PSHS A	; 
	JMP PUSHBA
*
* ######>> screen 31 <<
* ======>>  41  <<
	FCB	$82
	FCC	'+'	; '+!'
	FCB	$A1
	FDB	DUP-6
PSTORE	FDB	*+2
	TFR S,X	; TSX : 
	LDX	0,X
	LEAS 1,S	; 
	LEAS 1,S	; 
	PULS A	; get stack data
	PULS B	; 
	ADDB 1,X	add & store low byte
	STB 1,X
	ADCA 0,X	add & store hi byte
	STA 0,X
	JMP	NEXT
*
* ======>>  42  <<
	FCB	$86
	FCC	'TOGGL'	; 'TOGGLE'
	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
	TFR S,X	; TSX : 
	LDX	0,X	get address
	LEAS 1,S	; 
	LEAS 1,S	; 
	JMP	GETX
*
* ======>>  44  <<
	FCB	$82
	FCC	'C'	; 'C@'
	FCB	$C0
	FDB	AT-4
CAT	FDB	*+2
	TFR S,X	; TSX : 
	LDX	0,X
	CLRA	;
	LDB 0,X
	LEAS 1,S	; 
	LEAS 1,S	; 
	JMP	PUSHBA
*
* ======>>  45  <<
	FCB	$81
	FCB	$A1
	FDB	CAT-5
STORE	FDB	*+2
	TFR S,X	; TSX : 
	LDX	0,X	get address
	LEAS 1,S	; 
	LEAS 1,S	; 
	JMP	PULABX
*
* ======>>  46  <<
	FCB	$82
	FCC	'C'	; 'C!'
	FCB	$A1
	FDB	STORE-4
CSTORE	FDB	*+2
	TFR S,X	; TSX : 
	LDX	0,X	get address
	LEAS 1,S	; 
	LEAS 1,S	; 
	LEAS 1,S	; 
	PULS B	; 
	STB 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
	LEAX -1,X	; 
	LEAX -1,X	; 
	STX	RP
	LDA IP
	LDB IP+1	
	STA 2,X	Store address of the high level word
	STB 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	;   imnediate code
	FCB	$BB
	FDB	COLON-4
SEMI	FDB	DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
	FDB	SEMIS
*
* ######>> screen 34 <<
* ======>>  49  <<
	FCB	$88
	FCC	'CONSTAN'	; 'CONSTANT'
	FCB	$D4
	FDB	SEMI-4
CON	FDB	DOCOL,CREATE,SMUDGE,COMMA,PSCODE
DOCON	LDX	W
	LDA 2,X	
	LDB 3,X	A & B now contain the constant
	JMP	PUSHBA
*
* ======>>  50  <<
	FCB	$88
	FCC	'VARIABL'	; 'VARIABLE'
	FCB	$C5
	FDB	CON-11
VAR	FDB	DOCOL,CON,PSCODE
DOVAR	LDA W
	LDB W+1
	ADDB #2
	ADCA #0	A,B now contain the address of the variable
	JMP	PUSHBA
*
* ======>>  51  <<
	FCB	$84
	FCC	'USE'	; 'USER'
	FCB	$D2
	FDB	VAR-11
USER	FDB	DOCOL,CON,PSCODE
DOUSER	LDX	W	get offset  into user's table
	LDA 2,X
	LDB 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
	FCB	$B0	0
	FDB	USER-7
ZERO	FDB	DOCON
	FDB	0000
*
* ======>>  53  <<
	FCB	$81
	FCB	$B1	1
	FDB	ZERO-4
ONE	FDB	DOCON
	FDB	1
*
* ======>>  54  <<
	FCB	$81
	FCB	$B2	2
	FDB	ONE-4
TWO	FDB	DOCON
	FDB	2
*
* ======>>  55  <<
	FCB	$81
	FCB	$B3	3
	FDB	TWO-4
THREE	FDB	DOCON
	FDB	3
*
* ======>>  56  <<
	FCB	$82
	FCC	'B'	; 'BL'
	FCB	$CC
	FDB	THREE-4
BL	FDB	DOCON	ascii blank
	FDB	$20
*
* ======>>  57  <<
	FCB	$85
	FCC	'FIRS'	; 'FIRST'
	FCB	$D4
	FDB	BL-5
FIRST	FDB	DOCON
	FDB	MEMEND-528	(132 * NBLK)
*
* ======>>  58  <<
	FCB	$85
	FCC	'LIMI'	; 'LIMIT' : 	( the end of memory +1 )
	FCB	$D4
	FDB	FIRST-8
LIMIT	FDB	DOCON
	FDB	MEMEND
*
* ======>>  59  <<
	FCB	$85
	FCC	'B/BU'	; 'B/BUF' : 	(bytes/buffer)
	FCB	$C6
	FDB	LIMIT-8
BBUF	FDB	DOCON
	FDB	128
*
* ======>>  60  <<
	FCB	$85
	FCC	'B/SC'	; 'B/SCR' : 	(blocks/screen)
	FCB	$D2
	FDB	BBUF-8
BSCR	FDB	DOCON
	FDB	8
*	blocks/screen = 1024 / "B/BUF" = 8
*
* ======>>  61  <<
	FCB	$87
	FCC	'+ORIGI'	; '+ORIGIN'
	FCB	$CE
	FDB	BSCR-8
PORIG	FDB	DOCOL,LIT,ORIG,PLUS
	FDB	SEMIS
*
* ######>> screen 36 <<
* ======>>  62  <<
	FCB	$82
	FCC	'S'	; 'S0'
	FCB	$B0
	FDB	PORIG-10
SZERO	FDB	DOUSER
	FDB	XSPZER-UORIG
*
* ======>>  63  <<
	FCB	$82
	FCC	'R'	; 'R0'
	FCB	$B0
	FDB	SZERO-5
RZERO	FDB	DOUSER
	FDB	XRZERO-UORIG
*
* ======>>  64  <<
	FCB	$83
	FCC	'TI'	; 'TIB'
	FCB	$C2
	FDB	RZERO-5
TIB	FDB	DOUSER
	FDB	XTIB-UORIG
*
* ======>>  65  <<
	FCB	$85
	FCC	'WIDT'	; 'WIDTH'
	FCB	$C8
	FDB	TIB-6
WIDTH	FDB	DOUSER
	FDB	XWIDTH-UORIG
*
* ======>>  66  <<
	FCB	$87
	FCC	'WARNIN'	; 'WARNING'
	FCB	$C7
	FDB	WIDTH-8
WARN	FDB	DOUSER
	FDB	XWARN-UORIG
*
* ======>>  67  <<
	FCB	$85
	FCC	'FENC'	; 'FENCE'
	FCB	$C5
	FDB	WARN-10
FENCE	FDB	DOUSER
	FDB	XFENCE-UORIG
*
* ======>>  68  <<
	FCB	$82
	FCC	'D'	; 'DP' : 	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'	; 'VOC-LINK'
	FCB	$CB
	FDB	DP-5
VOCLIN	FDB	DOUSER
	FDB	XVOCL-UORIG
*
* ======>>  69  <<
	FCB	$83
	FCC	'BL'	; 'BLK'
	FCB	$CB
	FDB	VOCLIN-11
BLK	FDB	DOUSER
	FDB	XBLK-UORIG
*
* ======>>  70  <<
	FCB	$82
	FCC	'I'	; 'IN' : 	scan pointer for input line buffer
	FCB	$CE
	FDB	BLK-6
IN	FDB	DOUSER
	FDB	XIN-UORIG
*
* ======>>  71  <<
	FCB	$83
	FCC	'OU'	; 'OUT'
	FCB	$D4
	FDB	IN-5
OUT	FDB	DOUSER
	FDB	XOUT-UORIG
*
* ======>>  72  <<
	FCB	$83
	FCC	'SC'	; 'SCR'
	FCB	$D2
	FDB	OUT-6
SCR	FDB	DOUSER
	FDB	XSCR-UORIG
* ######>> screen 37 <<
*
* ======>>  73  <<
	FCB	$86
	FCC	'OFFSE'	; 'OFFSET'
	FCB	$D4
	FDB	SCR-6
OFSET	FDB	DOUSER
	FDB	XOFSET-UORIG
*
* ======>>  74  <<
	FCB	$87
	FCC	'CONTEX'	; 'CONTEXT' : 	points to pointer to vocab to search first
	FCB	$D4
	FDB	OFSET-9
CONTXT	FDB	DOUSER
	FDB	XCONT-UORIG
*
* ======>>  75  <<
	FCB	$87
	FCC	'CURREN'	; 'CURRENT' : 	points to ptr. to vocab being extended
	FCB	$D4
	FDB	CONTXT-10
CURENT	FDB	DOUSER
	FDB	XCURR-UORIG
*
* ======>>  76  <<
	FCB	$85
	FCC	'STAT'	; 'STATE' : 	1 if compiling, 0 if not
	FCB	$C5
	FDB	CURENT-10
STATE	FDB	DOUSER
	FDB	XSTATE-UORIG
*
* ======>>  77  <<
	FCB	$84
	FCC	'BAS'	; 'BASE' : 	number base for all input & output
	FCB	$C5
	FDB	STATE-8
BASE	FDB	DOUSER
	FDB	XBASE-UORIG
*
* ======>>  78  <<
	FCB	$83
	FCC	'DP'	; 'DPL'
	FCB	$CC
	FDB	BASE-7
DPL	FDB	DOUSER
	FDB	XDPL-UORIG
*
* ======>>  79  <<
	FCB	$83
	FCC	'FL'	; 'FLD'
	FCB	$C4
	FDB	DPL-6
FLD	FDB	DOUSER
	FDB	XFLD-UORIG
*
* ======>>  80  <<
	FCB	$83
	FCC	'CS'	; 'CSP'
	FCB	$D0
	FDB	FLD-6
CSP	FDB	DOUSER
	FDB	XCSP-UORIG
*
* ======>>  81  <<
	FCB	$82
	FCC	'R'	; 'R#'
	FCB	$A3
	FDB	CSP-6
RNUM	FDB	DOUSER
	FDB	XRNUM-UORIG
*
* ======>>  82  <<
	FCB	$83
	FCC	'HL'	; 'HLD'
	FCB	$C4
	FDB	RNUM-5
HLD	FDB	DOCON
	FDB	XHLD
*
* ======>>  82.5  <<== SPECIAL
	FCB	$87
	FCC	'COLUMN'	; 'COLUMNS' : 	line width of terminal
	FCB	$D3
	FDB	HLD-6
COLUMS	FDB	DOUSER
	FDB	XCOLUM-UORIG
*
* ######>> screen 38 <<
* ======>>  83  <<
	FCB	$82
	FCC	'1'	; '1+'
	FCB	$AB
	FDB	COLUMS-10
ONEP	FDB	DOCOL,ONE,PLUS
	FDB	SEMIS
*
* ======>>  84  <<
	FCB	$82
	FCC	'2'	; '2+'
	FCB	$AB
	FDB	ONEP-5
TWOP	FDB	DOCOL,TWO,PLUS
	FDB	SEMIS
*
* ======>>  85  <<
	FCB	$84
	FCC	'HER'	; 'HERE'
	FCB	$C5
	FDB	TWOP-5
HERE	FDB	DOCOL,DP,AT
	FDB	SEMIS
*
* ======>>  86  <<
	FCB	$85
	FCC	'ALLO'	; 'ALLOT'
	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'	; '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
	PULS A	; 
	PULS B	; 
	TFR S,X	; TSX : 
	CMPA 0,X
	LEAS 1,S	; 
	BGT	LESST
	BNE	LESSF
	CMPB 1,X
	BHI	LESST
LESSF	CLRB	;
	BRA	LESSX
LESST	LDB #1
LESSX	CLRA	;
	LEAS 1,S	; 
	JMP	PUSHBA
*
* ======>>  92  <<
	FCB	$81	>
	FCB	$BE
	FDB	LESS-4
GREAT	FDB	DOCOL,SWAP,LESS
	FDB	SEMIS
*
* ======>>  93  <<
	FCB	$83
	FCC	'RO'	; 'ROT'
	FCB	$D4
	FDB	GREAT-4
ROT	FDB	DOCOL,TOR,SWAP,FROMR,SWAP
	FDB	SEMIS
*
* ======>>  94  <<
	FCB	$85
	FCC	'SPAC'	; 'SPACE'
	FCB	$C5
	FDB	ROT-6
SPACE	FDB	DOCOL,BL,EMIT
	FDB	SEMIS
*
* ======>>  95  <<
	FCB	$83
	FCC	'MI'	; 'MIN'
	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'	; 'MAX'
	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'	; '-DUP'
	FCB	$D0
	FDB	MAX-6
DDUP	FDB	DOCOL,DUP,ZBRAN
	FDB	DDUP2-*
	FDB	DUP
DDUP2	FDB	SEMIS
*
* ######>> screen 39 <<
* ======>>  98  <<
	FCB	$88
	FCC	'TRAVERS'	; 'TRAVERSE'
	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'	; 'LATEST'
	FCB	$D4
	FDB	TRAV-11
LATEST	FDB	DOCOL,CURENT,AT,AT
	FDB	SEMIS
*
* ======>>  100  <<
	FCB	$83
	FCC	'LF'	; 'LFA'
	FCB	$C1
	FDB	LATEST-9
LFA	FDB	DOCOL,CLITER
	FCB	4
	FDB	SUB
	FDB	SEMIS
*
* ======>>  101  <<
	FCB	$83
	FCC	'CF'	; 'CFA'
	FCB	$C1
	FDB	LFA-6
CFA	FDB	DOCOL,TWO,SUB
	FDB	SEMIS
*
* ======>>  102  <<
	FCB	$83
	FCC	'NF'	; 'NFA'
	FCB	$C1
	FDB	CFA-6
NFA	FDB	DOCOL,CLITER
	FCB	5
	FDB	SUB,ONE,MINUS,TRAV
	FDB	SEMIS
*
* ======>>  103  <<
	FCB	$83
	FCC	'PF'	; 'PFA'
	FCB	$C1
	FDB	NFA-6
PFA	FDB	DOCOL,ONE,TRAV,CLITER
	FCB	5
	FDB	PLUS
	FDB	SEMIS
*
* ######>> screen 40 <<
* ======>>  104  <<
	FCB	$84
	FCC	'!CS'	; '!CSP'
	FCB	$D0
	FDB	PFA-6
SCSP	FDB	DOCOL,SPAT,CSP,STORE
	FDB	SEMIS
*
* ======>>  105  <<
	FCB	$86
	FCC	'?ERRO'	; '?ERROR'
	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'	; '?COMP'
	FCB	$D0
	FDB	QERR-9
QCOMP	FDB	DOCOL,STATE,AT,ZEQU,CLITER
	FCB	$11
	FDB	QERR
	FDB	SEMIS
*
* ======>>  107  <<
	FCB	$85
	FCC	'?EXE'	; '?EXEC'
	FCB	$C3
	FDB	QCOMP-8
QEXEC	FDB	DOCOL,STATE,AT,CLITER
	FCB	$12
	FDB	QERR
	FDB	SEMIS
*
* ======>>  108  <<
	FCB	$86
	FCC	'?PAIR'	; '?PAIRS'
	FCB	$D3
	FDB	QEXEC-8
QPAIRS	FDB	DOCOL,SUB,CLITER
	FCB	$13
	FDB	QERR
	FDB	SEMIS
*
* ======>>  109  <<
	FCB	$84
	FCC	'?CS'	; '?CSP'
	FCB	$D0
	FDB	QPAIRS-9
QCSP	FDB	DOCOL,SPAT,CSP,AT,SUB,CLITER
	FCB	$14
	FDB	QERR
	FDB	SEMIS
*
* ======>>  110  <<
	FCB	$88
	FCC	'?LOADIN'	; '?LOADING'
	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'	; 'COMPILE'
	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'	; 'SMUDGE'
	FCB	$C5
	FDB	RBRAK-4
SMUDGE	FDB	DOCOL,LATEST,CLITER
	FCB	$20
	FDB	TOGGLE
	FDB	SEMIS
*
* ======>>  115  <<
	FCB	$83
	FCC	'HE'	; 'HEX'
	FCB	$D8
	FDB	SMUDGE-9
HEX	FDB	DOCOL
	FDB	CLITER
	FCB	16
	FDB	BASE,STORE
	FDB	SEMIS
*
* ======>>  116  <<
	FCB	$87
	FCC	'DECIMA'	; 'DECIMAL'
	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'	; '(;CODE)'
	FCB	$A9
	FDB	DEC-10
PSCODE	FDB	DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
	FDB	SEMIS
*
* ======>>  118  <<
	FCB	$C5	immediate
	FCC	';COD'	; ';CODE'
	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'	; '<BUILDS'
	FCB	$D3
	FDB	SEMIC-8
BUILDS	FDB	DOCOL,ZERO,CON
	FDB	SEMIS
*
* ======>>  120  <<
	FCB	$85
	FCC	'DOES'	; 'DOES>'
	FCB	$BE
	FDB	BUILDS-10
DOES	FDB	DOCOL,FROMR,TWOP,LATEST,PFA,STORE
	FDB	PSCODE
DODOES	LDA IP
	LDB IP+1
	LDX	RP	make room on return stack
	LEAX -1,X	; 
	LEAX -1,X	; 
	STX	RP
	STA 2,X	push return address
	STB 3,X
	LDX	W	get addr of pointer to run-time code
	LEAX 1,X	; 
	LEAX 1,X	; 
	STX	N	stash it in scratch area
	LDX	0,X	get new IP
	STX	IP
	CLRA	;		get address of parameter
	LDB #2
	ADDB N+1
	ADCA N
	PSHS B	; and push it on data stack
	PSHS A	; 
	JMP	NEXT2
*
* ######>> screen 44 <<
* ======>>  121  <<
	FCB	$85
	FCC	'COUN'	; 'COUNT'
	FCB	$D4
	FDB	DOES-8
COUNT	FDB	DOCOL,DUP,ONEP,SWAP,CAT
	FDB	SEMIS
*
* ======>>  122  <<
	FCB	$84
	FCC	'TYP'	; 'TYPE'
	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'	; '-TRAILING'
	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'	; '?STACK'
	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	4,?FREE
*	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'	; 'EXPECT'
	FCB	$D4
	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'	; 'QUERY'
	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'	; 'FILL'
	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'	; 'ERASE'
	FCB	$C5
	FDB	FILL-7
ERASE	FDB	DOCOL,ZERO,FILL
	FDB	SEMIS
*
* ======>>  135  <<
	FCB	$86
	FCC	'BLANK'	; 'BLANKS'
	FCB	$D3
	FDB	ERASE-8
BLANKS	FDB	DOCOL,BL,FILL
	FDB	SEMIS
*
* ======>>  136  <<
	FCB	$84
	FCC	'HOL'	; 'HOLD'
	FCB	$C4
	FDB	BLANKS-9
HOLD	FDB	DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
	FDB	SEMIS
*
* ======>>  137  <<
	FCB	$83
	FCC	'PA'	; 'PAD'
	FCB	$C4
	FDB	HOLD-7
PAD	FDB	DOCOL,HERE,CLITER
	FCB	$44
	FDB	PLUS
	FDB	SEMIS
*
* ######>> screen 48 <<
* ======>>  138  <<
	FCB	$84
	FCC	'WOR'	; 'WORD'
	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'	; '(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'	; 'NUMBER'
	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'	; '-FIND'
	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'	; '(ABORT)'
	FCB	$A9
	FDB	DFIND-8
PABORT	FDB	DOCOL,ABORT
	FDB	SEMIS
*
* ======>>  143  <<
	FCB	$85
	FCC	'ERRO'	; 'ERROR'
	FCB	$D2
	FDB	PABORT-10
ERROR	FDB	DOCOL,WARN,AT,ZLESS
	FDB	ZBRAN
* note: WARNING is -1 to abort, 0 to print error #
* 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'	; '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'	; 'CREATE'
	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'	; '[COMPILE]'
	FCB	$DD
	FDB	CREATE-9
BCOMP	FDB	DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
	FDB	SEMIS
*
* ======>>  147  <<
	FCB	$C7	immediate
	FCC	'LITERA'	; 'LITERAL'
	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'	; 'DLITERAL'
	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'	; 'INTERPRET'
	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'	; 'IMMEDIATE'
	FCB	$C5
	FDB	INTERP-12
IMMED	FDB	DOCOL,LATEST,CLITER
	FCB	$40
	FDB	TOGGLE
	FDB	SEMIS
*
* ======>>  151  <<
	FCB	$8A
	FCC	'VOCABULAR'	; 'VOCABULARY'
	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	'DEFINITION'	; 'DEFINITIONS'
	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'	; 'QUIT'
	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'	; ' OK'
QUIT3	FDB	BRAN
	FDB	QUIT2-*
*	FDB	SEMIS	( never executed )
*
* ======>>  156  <<
	FCB	$85
	FCC	'ABOR'	; 'ABORT'
	FCB	$D4
	FDB	QUIT-7
ABORT	FDB	DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,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'	; 'COLD'
	FCB	$C4
	FDB	ABORT-8
COLD	FDB	*+2
CENT	LDS	#REND-1	top of destination
	LDX	#ERAM	top of stuff to move
COLD2	LEAX -1,X	; 
	LDA 0,X
	PSHS A	; move TASK & FORTH to ram
	CMPX	#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	LEAX -1,X	; 
	LDA 0,X
	PSHS A	; 
	CMPX	#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/0 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'	; 'FORTH'
	FCB	$C8
	FDB	NOOP-7
RFORTH	FDB	DODOES,DOVOC,$81A0,TASK-7
	FDB	0
	FCC	"(C) Forth Interest Group, 1979"
	FCB	$84
	FCC	'TAS'	; 'TASK'
	FCB	$CB
	FDB	FORTH-8
RTASK	FDB	DOCOL,SEMIS
ERAM	FCC	"David Lion"	
	PAGE
*
* ######>> screen 57 <<
* ======>>  158  <<
	FCB	$84
	FCC	'S->'	; '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
	LEAS 1,S	; 
	LEAS 1,S	; 
	JMP	NEXT
*
* ======>>  160  <<
	FCB	$84
	FCC	'/MO'	; '/MOD'
	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'	; 'MOD'
	FCB	$C4
	FDB	SLASH-4
MOD	FDB	DOCOL,SLMOD,DROP
	FDB	SEMIS
*
* ======>>  163  <<
	FCB	$85
	FCC	'*/MO'	; '*/MOD'
	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'	; 'M/MOD'
	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'	; 'ABS'
	FCB	$D3
	FDB	MSMOD-8
ABS	FDB	DOCOL,DUP,ZLESS,ZBRAN
	FDB	ABS2-*
	FDB	MINUS
ABS2	FDB	SEMIS
*
* ======>>  167  <<
	FCB	$84
	FCC	'DAB'	; 'DABS'
	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'	; 'USE'
	FCB	$C5
	FDB	DABS-7
USE	FDB	DOCON
	FDB	XUSE
* ======>>  169  <<
	FCB	$84
	FCC	'PRE'	; 'PREV'
	FCB	$D6
	FDB	USE-6
PREV	FDB	DOCON
	FDB	XPREV
* ======>>  170  <<
	FCB	$84
	FCC	'+BU'	; '+BUF'
	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'	; 'UPDATE'
	FCB	$C5
	FDB	PBUF-7
UPDATE	FDB	DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
	FDB	SEMIS
*
* ======>>  172  <<
	FCB	$8D
	FCC	'EMPTY-BUFFER'	; 'EMPTY-BUFFERS'
	FCB	$D3
	FDB	UPDATE-9
MTBUF	FDB	DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
	FDB	SEMIS
*
* ======>>  173  <<
	FCB	$83
	FCC	'DR'	; 'DR0'
	FCB	$B0
	FDB	MTBUF-16
DRZERO	FDB	DOCOL,ZERO,OFSET,STORE
	FDB	SEMIS
*
* ======>>  174  <<== system dependant word
	FCB	$83
	FCC	'DR'	; 'DR1'
	FCB	$B1
	FDB	DRZERO-6
DRONE	FDB	DOCOL,LIT,$07D0,OFSET,STORE
	FDB	SEMIS
*
* ######>> screen 59 <<
* ======>>  175  <<
	FCB	$86
	FCC	'BUFFE'	; 'BUFFER'
	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'	; 'BLOCK'
	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'	; '(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'	; '.LINE'
	FCB	$C5
	FDB	PLINE-9
DLINE	FDB	DOCOL,PLINE,DTRAIL,TYPE
	FDB	SEMIS
*
* ======>>  179  <<
	FCB	$87
	FCC	'MESSAG'	; 'MESSAGE'
	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 # '	; 'err # '
	FDB	DOT
MESS4	FDB	SEMIS
*
* ======>>  180  <<
	FCB	$84
	FCC	'LOA'	; 'LOAD' : 	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 dependent, and are
*    called by words 13 through 16 in the dictionary.
*
* ======>>  182  << code for EMIT
PEMIT	STB N	save B
	STX	N+1	save X
	LDB ACIAC
	BITB #2	check ready bit
	BEQ	PEMIT+4	if not ready for more data
	STA ACIAD
	LDX	UP
	STB IOSTAT-UORIG,X
	LDB N	recover B & X
	LDX	N+1
	RTS		only A register may change
*  PEMIT	JMP	$E1D1	for MIKBUG
*  PEMIT	FCB	$3F,$11,$39	for PROTO
*  PEMIT	JMP	$D286 for Smoke Signal DOS
*
* ======>>  183  << code for KEY
PKEY	STB N
	STX	N+1
	LDB ACIAC
	ASRB	;
	BCC	PKEY+4	no incoming data yet
	LDA ACIAD
	ANDA #$7F	strip parity bit
	LDX	UP
	STB IOSTAT+1-UORIG,X
	LDB N
	LDX	N+1
	RTS
*  PKEY	JMP	$E1AC	for MIKBUG
*  PKEY	FCB	$3F,$14,$39	for PROTO
*  PKEY	JMP	$D289 for Smoke Signal DOS
*
* ######>> screen 64 <<
* ======>>  184  << code for ?TERMINAL
PQTER	LDA ACIAC	Test for 'break'  condition
	ANDA #$11	mask framing error bit and
*			input buffer full
	BEQ	PQTER2
	LDA ACIAD	clear input buffer
	LDA #01
PQTER2	RTS


	PAGE
*
* ======>>  185  << code for CR
PCR	LDA #$D	carriage return
	BSR	PEMIT
	LDA #$A	line feed
	BSR	PEMIT
	LDA #$7F	rubout
	LDX	UP
	LDB XDELAY+1-UORIG,X
PCR2	DECB	;
	BMI	PQTER2	return if minus
	PSHS B	; save counter
	BSR	PEMIT	print RUBOUTs to delay.....
	PULS B	; 
	BRA	PCR2	repeat


	PAGE
*
* ######>> screen 66 <<
* ======>>  187  <<
	FCB	$85
	FCC	'?DIS'	; '?DISC'
	FCB	$C3
	FDB	ARROW-6
QDISC	FDB	*+2
	JMP	NEXT
*
* ######>> screen 67 <<
* ======>>  189  <<
	FCB	$8B
	FCC	'BLOCK-WRIT'	; 'BLOCK-WRITE'
	FCB	$C5
	FDB	QDISC-8
BWRITE	FDB	*+2
	JMP	NEXT
*
* ######>> screen 68 <<
* ======>>  190  <<
	FCB	$8A
	FCC	'BLOCK-REA'	; 'BLOCK-READ'
	FCB	$C4
	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'	; 'LO'
	FCB	$CF
	FDB	BREAD-13
LO	FDB	DOCON
	FDB	MEMEND	a system dependent equate at front
*
* ======>>  190.2  <<
	FCB	$82
	FCC	'H'	; 'HI'
	FCB	$C9
	FDB	LO-5
HI	FDB	DOCON
	FDB	MEMTOP	( $3FFF in this version )
*
* ######>> screen 69 <<
* ======>>  191  <<
	FCB	$83
	FCC	'R/'	; '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 ?'	; ' 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'	; 'FORGET'
	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'	; 'BACK'
	FCB	$CB
	FDB	FORGET-9
BACK	FDB	DOCOL,HERE,SUB,COMMA
	FDB	SEMIS
*
* ======>>  195  <<
	FCB	$C5
	FCC	'BEGI'	; 'BEGIN'
	FCB	$CE
	FDB	BACK-7
BEGIN	FDB	DOCOL,QCOMP,HERE,ONE
	FDB	SEMIS
*
* ======>>  196  <<
	FCB	$C5
	FCC	'ENDI'	; 'ENDIF'
	FCB	$C6
	FDB	BEGIN-8
ENDIF	FDB	DOCOL,QCOMP,TWO,QPAIRS,HERE
	FDB	OVER,SUB,SWAP,STORE
	FDB	SEMIS
*
* ======>>  197  <<
	FCB	$C4
	FCC	'THE'	; 'THEN'
	FCB	$CE
	FDB	ENDIF-8
THEN	FDB	DOCOL,ENDIF
	FDB	SEMIS
*
* ======>>  198  <<
	FCB	$C2
	FCC	'D'	; 'DO'
	FCB	$CF
	FDB	THEN-7
DO	FDB	DOCOL,COMPIL,XDO,HERE,THREE
	FDB	SEMIS
*
* ======>>  199  <<
	FCB	$C4
	FCC	'LOO'	; 'LOOP'
	FCB	$D0
	FDB	DO-5
LOOP	FDB	DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
	FDB	SEMIS
*
* ======>>  200  <<
	FCB	$C5
	FCC	'+LOO'	; '+LOOP'
	FCB	$D0
	FDB	LOOP-7
PLOOP	FDB	DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK
	FDB	SEMIS
*
* ======>>  201  <<
	FCB	$C5
	FCC	'UNTI'	; 'UNTIL' : 	( 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'	; 'END'
	FCB	$C4
	FDB	UNTIL-8
END	FDB	DOCOL,UNTIL
	FDB	SEMIS
*
* ======>>  203  <<
	FCB	$C5
	FCC	'AGAI'	; 'AGAIN'
	FCB	$CE
	FDB	END-6
AGAIN	FDB	DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
	FDB	SEMIS
*
* ======>>  204  <<
	FCB	$C6
	FCC	'REPEA'	; 'REPEAT'
	FCB	$D4
	FDB	AGAIN-8
REPEAT	FDB	DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
	FDB	TWO,SUB,ENDIF
	FDB	SEMIS
*
* ======>>  205  <<
	FCB	$C2
	FCC	'I'	; 'IF'
	FCB	$C6
	FDB	REPEAT-9
IF	FDB	DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
	FDB	SEMIS
*
* ======>>  206  <<
	FCB	$C4
	FCC	'ELS'	; 'ELSE'
	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'	; 'WHILE'
	FCB	$C5
	FDB	ELSE-7
WHILE	FDB	DOCOL,IF,TWOP
	FDB	SEMIS
*
* ######>> screen 75 <<
* ======>>  208  <<
	FCB	$86
	FCC	'SPACE'	; 'SPACES'
	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'	; 'SIGN'
	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.'	; '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'	; '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'	; 'LIST'
	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'	; 'INDEX'
	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'	; 'TRIAD'
	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'	; 'VLIST'
	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'	; 'NOOP'
	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







	PAGE
	OPT	L
	END