	INCLUDE	SDOSUSERDEFS.ASM
	NAME	METAM14C.ASM
*
*		METAPLUS -- META MACHINE FOR 6800 SERIES
*		COPYRIGHT (C) 1977 SOFTWARE DYNAMICS
*		ALL RIGHTS RESERVED
*		IMPROVEMENTS?	1)COUNT SOURCE LINES AND DISPLAY AT ERROR TIME
*
*
*	REV 14C 3/22/82 I.B.
*		CLEAN UP AND MOVE TO '09
*		ALLOW MTEST TO MATCH STRINGS CONTIANING LOWER CASE
*		MADE REPLY BUFFER OF SYSCALLS NOT POINT INTO SCRATCHPAD
*		FIXED "INCLUDE" EDGE CONDITIONS
*		SIMPLIFIED PROCESS OF GENERATING CHECKSUMS
*	REV 14B 12/1/80 ALLOW MNOTTEST TO FOLLOW MKEYWORDTEST
*	REV 14A 10/6/80	UPPER/LOWER CASE KEYWORD TEST
*			CHECKSUM TEST ON METAMACHINE
*			CONVERTED TO M680C
*			ERROR IN INCLUDE DISPLAYS ERROR LINE
*	REVISION 13E 3/13/80	ALLOWS 0 PARAMETERS TO BE PASSED TO SUBROUTINE
*			ALSO CAUSES REALIZATION OF LABEL # AT CALL SITE...
*			WHEN PASSED TO SUBROUTINE AND NOT YET GENERATED
*	REVISION 13D 2/16/80	FIXES ERROR DISPLAY AND RECOVERY

	WITH	WI=107,DE=51
*
	PAGE
*
	IFUND	PZBASE	SELECT PAGE ZERO VARIABLES BASE
PZBASE	EQU	$20	THIS IS A GOOD DEFAULT SINCE IT AVOIDS 6801 PAGE ZERO PIAS
	FIN
	IFUND	CODE	SELECT CODE BASE
CODE	EQU	$100	NORMAL DEFAULT
	FIN
	IFUND	INPUTBUFFERSIZE
INPUTBUFFERSIZE	EQU	400
	FIN
EST:METAMSIZE	EQU	$C80	ESTIMATED SIZE OF METAMACHINE
*
*
*	CHANNEL ASSIGNMENTS
*
SI	EQU	2	SOURCE IN
SO	EQU	1	SOURCE OUT
CO	EQU	0	CONSOLE OUT
CI	EQU	0	CONSOLE IN
*
*	STRING DICTIONARY NODE DISPLACEMENTS
*
	ORG	0
STRINGNODE:FLAGS	RMB	2	16 BITS OF TAG BITS FOR THIS NODE
STRINGNODE:TYPE	RMB	1	TYPE OF NODE
STRINGNODE:NEXT	RMB	2	POINTER TO NEXT NODE IN THIS HASH BUCKETCHAIN
STRINGNODE:KEYLEN	RMB	1	MSB IS "I'M A KEYWORD" FLAG; LOWER 7 BITS IS LENGTH
STRINGNODE:BODY	RMB	0	1ST BYTE OF BODY OF STRING
	PAGE
	ORG	PZBASE
METAPC	RMB	2	METAMACHINE P COUNTER
FLAG	RMB	1	META MACHINE TRUE/FALSE FLAG
STAR	RMB	2	POINTEJR TO STAR STRING
NUMSTR	RMB	1	NUMBER OF STACKED STRINGS
INCLBL	RMB	2	INCARNATION LABEL
LABGEN	RMB	2	LABEL GENERATOR

RECOVERYMETAPC	RMB	2	DISTINGUISHED RULE (RECOVERY POINT)
RECOVERYSTACK	RMB	2	RECOVERY POINT'S STACK POINTER
RECOVERYNUMSTR	RMB	1	NUMBER OF STACKED STRINGS

TOKENPOINTER	RMB	2	THE ONE FOUND BY FINDSTRING
DECODEADD	RMB	2	POINTER TO META INSTRUCTION DECODE JMP TABLE
STATEVARBASE	RMB	2	USED TO COMPUTE ADDRESS OF STATE VARIABLE
POINTER1	RMB	2
POINTER2	RMB	2
SAVEX	RMB	2	JUST A TEMPORARY
FILLPOINTER	RMB	2	INPUT BUFFER FILL POINTER
EMPTYPOINTER	RMB	2	INPUT BUFFER EMPTY POINTER
SCANPOINTER	RMB	2	INPUT SCAN POINTER

OUTPUTPOINTER	RMB	2	OUTPUT BUFFER POINTER
OUTFLAG	RMB	1	OUTPUT ENABLED FLAG

CCODE	RMB	2	COMPILER COMPLETION CODE
STRINGLENGTH	RMB	1	SIZE OF STRING TO BE INSERTED IN DICTIONARY

CASECONVERSION	RMB	1	=$0 IF STRING TOKEN, ='a-'A IF NOT STRING TOKEN

INCLUDEERROR	RMB	2	ERROR CODE RETURNED BY SDOS WHEN OPENING INCLUDE FILE
	PAGE
	ORG	CODE
BEGIN	JMP	MINIT	GO DO THE INITIALIZATION
CHECKSUM	FCB	0	SUM OF THIS BYTE PLUS REST OF METAM = 0.
*
*	META MACHINE ENTRY POINT JUMP TABLE
*	USED BY TOKEN BUSTERS AND SPECIAL PURPOSE OUTPUT ROUTINES
*
	JMP	STARTTOKEN	RESTART TOKEN SCAN FROM BEGINNING OF INPUT
	JMP	GETTOKENCHAR	READ NEXT CHARACTER FROM INPUT BUFFER
	JMP	BACKUP	REJECT LAST CHARACTER READ FROM INPUT BUFFER
	JMP	EATTOKEN	THROW AWAY CONTENTS OF INPUT BUFFER SCANNED
	JMP	FINDSTAR	RETURN (X) POINTING TO STRING BODY, (B) = L
	JMP	FINDSTARN	LIKE FINDSTAR, BUT FOR nTH STAR STRING
	JMP	PUTCHAR	 SEND A CHARACTER TO THE OUTPUT STREAM
	JMP	ENTERMETA	RE-ENTER META INSTRUCTION CODE
	FCC	'METAMACHINE Version 1.4 Copyright (c) 1982 Software Dynamics'
	FCB	$D
	PAGE
*
*	THIS IS A DECODE-BRANCH TABLE FOR THE FIRST 64 META-INSTRUCTIONS
*
DECODE	EQU	*
	FDB	MFIN	0 TERMINATES COMPILATION
*
*	CALL SUBROUTINE # 64 TO 319
*	00000001 XXXXXXXX
*
	FDB	CALLSEXTENDED	META-OPCODE $01
*
*	CALL SUBROUTINE # 320 TO 575
*	00000010 XXXXXXXX
*
	FDB	CALLSEXTENDED	META-OPCODE $02
	PAGE
*	CALL TOKEN RECOGNIZER
*	000XXXXX	TOKEN # 0 TO 28
*
	FDB	CALLT	META-OPCODE $03
	FDB	CALLT	META-OPCODE $04
	FDB	CALLT	META-OPCODE $05
	FDB	CALLT	META-OPCODE $06
	FDB	CALLT	META-OPCODE $07
	FDB	CALLT	META-OPCODE $08
	FDB	CALLT	META-OPCODE $09
	FDB	CALLT	META-OPCODE $0A
	FDB	CALLT	META-OPCODE $0B
	FDB	CALLT	META-OPCODE $0C
	FDB	CALLT	META-OPCODE $0D
	FDB	CALLT	META-OPCODE $0E
	FDB	CALLT	META-OPCODE $0F
	FDB	CALLT	META-OPCODE $10
	FDB	CALLT	META-OPCODE $11
	FDB	CALLT	META-OPCODE $12
	FDB	CALLT	META-OPCODE $13
	FDB	CALLT	META-OPCODE $14
	FDB	CALLT	META-OPCODE $15
	FDB	CALLT	META-OPCODE $16
	FDB	CALLT	META-OPCODE $17
	FDB	CALLT	META-OPCODE $18
	FDB	CALLT	META-OPCODE $19
	FDB	CALLT	META-OPCODE $1A
	FDB	CALLT	META-OPCODE $1B
	FDB	CALLT	META-OPCODE $1C
	FDB	CALLT	META-OPCODE $1D
	FDB	CALLT	META-OPCODE $1E
	FDB	CALLT	META-OPCODE $1F
	PAGE
*	META OPCODE
*	001XXXXX
	FDB	BADMETAOP	:20 *** NOT CURRENTLY USED ***
	FDB	MTEST	:21 COMPARE INPUT TO STRING, SET FLAG
:MNOTTEST	EQU	(*-DECODE)/2	SHOULD NEVER EXECUTE THIS
	FDB	BADMETAOP	:22 INVERT TOKEN & STRING TEST
	FDB	MTAG	:23 TURN ON DICTIONARY FLAG BIT
	FDB	MTAGN	:24 TAG THE NTH STRING
	FDB	MUNTAG	:25 TURN ENTRY FLAG BITS OFF, SET FLAG
	FDB	MUNTAGN	:26 TURN FLAG OFF FOR NTH STRING
	FDB	MQUERY	:27 QUERY THE STAR STRING
	FDB	MQUERYN	:28 QUERY THE NTH STRING
	FDB	MR	:29 RETURN FROM META SUBROUTINE
	FDB	MRT	:2A RETURN IF FLAG SET
	FDB	MRF	:2B RETURN IF FLAG CLEAR
	FDB	MBE	:2C COMPILATION FAILURE IF FLAG FALSE
	FDB	MERR	:2D DISPLAY STRING AND RULE
	FDB	MTAB	:2E OUTPUT TAB
	FDB	MCR	:2F OUTPUT CARRIAGE RETURN
	FDB	MCL	:30 OUTPUT STRING
	FDB	MOUT	:31 OUTPUT STRING
	FDB	MOUTN	:32 OUTPUT NTH STACKED STRING
	FDB	MGENL	:33 GENERATE AND OUTPUT LABEL
	FDB	MSET	:34 SET FLAG
	FDB	MRECOVERYMETAPC	:35 REMEMBER DISTINGUISHED PHRASE
	FDB	MINCLUDE	:36 OPEN * STRING AS NEW INPUT CHANNEL
	FDB	MOVESTRINGUP	:37 PASS STRING TO CALLING ROUTINE
:MPARAMS	EQU	(*-DECODE)/2	SHOULD NEVER EXECUTE THIS
	FDB	BADMETAOP	:38 PASS PARAMETERS
	FDB	MASM	:39 ENTER ASSEMBLY CODE
	FDB	MSETSTATE	:3A SET STATE VARIABLE
	FDB	MQUERYSTATE	:3B QUERY STATE VARIABLE
	FDB	MSETTYPEN	:3C SET TYPE OF *N STRING
	FDB	MQUERYTYPEN	:3D QUERY TYPE OF *N STRING
	FDB	MKEYWORDTEST	:3E TEST FOR KEYWORD
	RPT	$40-(*-DECODE)/2
	FDB	BADMETAOP	*** AVAILABLE META INSTRUCTIONS ***
*
	PAGE
*
*	MSETSTATE -- SET STATE VARIABLE
*	(:3A) (8 BIT STATE VARIABLE NUMBERS) (8 BIT VALUE)
*
MSETSTATE	BSR	GETSTATEADDRESS HOW OBVIOUS
	STAB	STATEVARS&$FF,X
	JMP	METAINCPC2
*
*	MQUERYSTATE -- QUERY STATE VARIABLE
*	SETS FLAG TO "TRUE" IF MATCH
*	(:3B) (8 BIT STATE VARIABLE NUMBER) (8 BIT VALUE)
*
MQUERYSTATE	CLR	FLAG	ASSUME THE WORST!
	BSR	GETSTATEADDRESS	LIKEWISE...
	CMPB	STATEVARS&$FF,X
	BNE	MQUERYSTATE1	B/ NO MATCH
	INC	FLAG	A MATCH, REMEMBER THAT!
MQUERYSTATE1	JMP	METAINCPC2
*
GETSTATEADDRESS	LDX	METAPC	COMPUTE ADDRESS OF STATE VARIABLE
	LDD	0,X	ALSO GRAB 8 BIT VALUE FOR STORE/COMPARISON
	STAA	STATEVARBASE+1
	LDX	STATEVARBASE
	RTS
*
MRECOVERYMETAPC	LDX	METAPC	THIS IS THE ERROR RECOVERY POINT
	STX	RECOVERYMETAPC	SAVE THE ADDRESS
	LDAA	NUMSTR	SAVE THE STACKED STRING COUNT
	STAA	RECOVERYNUMSTR
	STS	RECOVERYSTACK	SAVE THE STACK POINTER
	JMP	METAM
	PAGE
MBE	LDAA	FLAG	SYNTAX ERROR IF FLAG FALSE
	BEQ	MBE1	B/ SYNTAX ERROR
	JMP	METAM	B/ ALL IS OK
MBE1	LDX	#M:SYNTAX
	JSR	PRINT
	BRA	MERR3
*
*	MERR -- DISPLAY ERROR MESSAGE
*
MERR	LDX	METAPC
	BRA	MERR2
MERR1	JSR	PUTELOG
	INX
MERR2	LDAA	0,X
	BPL	MERR1
	INX
	STX	METAPC
	ANDA	#$7F
	JSR	PUTELOG
	JSR	CRLF
MERR3	JSR	DUMPLINE
	LDX	#ERR:FATALCOMPILE
	STX	CCODE
	LDX	RECOVERYMETAPC	IS THE DISTINGUISHED RULE STILL VALID?
	BEQ	MFIN	B/ NO, QUIT
	STX	METAPC	YES, USE RECOVERY POINT TO CONTINUE EXECUTION
	LDS	RECOVERYSTACK	RESTORE THE STACK
	LDAA	RECOVERYNUMSTR	RESTORE THE STACKED STRING COUNT
	STAA	NUMSTR
	LDAA	#1
	STAA	OUTFLAG	TURN OFF THE OUTPUT
MERRLOOP	JSR	STARTTOKEN	START ERROR TOKEN AT THE EMPTYPOINTER!
	JSR	ERRORTOKEN	DO THE ERROR TOKEN SWALLOWER
	BCC	MERR5	B/ NO MORE STUFF TO SWALLOW!
	JSR	EATTOKEN	EAT AN ERROR SOMETHING
	BRA	MERRLOOP	B/ GO EAT SOME MORE
MERR5	JMP	METAM
	PAGE
MFIN	JSR	PURGEBUFFER	PURGE THE OUTPUT BUFFER
	LDX	CCODE	GET THE COMPLETION CODE
MFIN1	STX	IOERROR
	LDX	#M:IMDONE
	JSR	PRINT
	LDX	#IOERRORBLOCK
	JMP	SYSCALL$
*
*	TEST FOR PRESENCE OF SELECTED KEYWORD
*	(OPCODE)(POINTER TO KEYWORD IN HASH TABLE)
*
MKEYWORDTEST	JSR	DEBLANK	SKIP UNWANTED BLANKS
	CLR	FLAG	ASSUME FAILURE TO MATCH KEYWORD
	JSR	KEYWORDTOKEN	GO PICK UP TOKEN
	BCC	METAKEYWORDEXIT	B/ NOT A KEYWORDTOKEN, CAN'T BE KEYWORD SELECTED
	JSR	FINDSTRING	LOOKS RATIONAL, GO LOOK IT UP IN HASH TABLE
	STX	SAVEX	SAVE POINTER TO HASH TABLE LOCATION
	LDX	[METAPC]	FOUND KEYWORD = DESIRED KEYWORD ?
	CPX	SAVEX	...?
	BNE	METAKEYWORDEXIT	B/ NO, LEAVE FLAG RESET
	DEC	FLAG	MATCHED DESIRED KEYWORD! SET THE FLAG
METAKEYWORDEXIT	LDX	METAPC	ADVANCE METAPC PAST KEYWORD POINTER
	LEAX	2,X
	STX	METAPC
	BRA	FAILRETURN	GO CHECK FOR MNOTTEST, EAT INPUT IF REQ'D
	PAGE
*	"CALL TOKEN" INSTRUCTION INTERPRETER
*
CALLT	CLR	FLAG	ASSUME TOKEN WILL NOT BE RECOGNIZED
	LDAA	#(TOKENADD-6)/256
	PSHD		SAVE POINTER TO TOKEN ROUTINE
	JSR	DEBLANK	SKIP OVER UNWANTED INPUT
	PULX		GRAB SAVED POINTER TO TOKEN ROUTINE
	JSR	[(TOKENADD-6)&$FF,X]
	BCC	FAILRETURN	B/ CARRY CLEAR --> DIDN'T SEE DESIRED TOKEN TYPE
SUCCESSRETURN	JSR	FINDSTRING	NOW FIND THE STRING IN THE DICTIONARY
	LDAA	STRINGNODE:KEYLEN,X IS IT A KEYWORD ?
	BMI	FAILRETURN	B/ YEP, CAN'T BE A SUCCESS!
	STX	STAR	SAVE THE POINTER TO THE STAR STRING
	LDD	STAR
	PSHD
	STS	SAVEX	STACKM >= LIMIT?
	LDD	SAVEX
	SUBB	DICT+1	(NOTE: THIS CODE CANNOT BE OPTIMIZED ON 6809)
	SBCA	DICT
	BEQ	CALLT4	B/ TOO MANY STRINGS
	INC	NUMSTR
	BMI	CALLT5	B/ TOO MANY STRINGS
CALLT6	DEC	FLAG	REMEMBER THAT WE SUCCESSFULLY OBTAINED A TOKEN
FAILRETURN	; RE-ENTRY POINT FOR "TOKEN NOT RECOGNIZED"
	LDX	METAPC	INVERT THE FLAG IF NOTTST
	LDAB	0,X
	CMPB	#:MNOTTEST
	BEQ	MNOTTEST	B/ IT'S A NOTTEST
	LDAA	FLAG	IS THE INPUT RECOGNIZED ?
	BEQ	CALLT2	B/ NO
	BSR	EATTOKEN	YES, EAT IT UP!
CALLT2	JMP	METAM

MNOTTEST	COM	FLAG	DON'T EAT THE INPUT
	JMP	METAINXPC
*
DEBLANKLOOP	JSR	EATTOKEN	EAT UP THE BLANK
DEBLANK	JSR	STARTTOKEN	START SCAN AT BUFFER START
	JSR	DEBLANKTOKEN	GO SEE IF A BLANK TOKEN IS GIVEN
	BCS	DEBLANKLOOP	B/ YEP, EAT IT AND TRY AGAIN
STARTTOKEN	LDX	EMPTYPOINTER
	STX	SCANPOINTER
	RTS
*
CALLT4	JMP	ERRCALLSTKOVFLW

CALLT5	LDX	#M:TOOMANYSTRINGS
	JMP	CROAK
**
EATTOKEN	LDX	SCANPOINTER
	STX	EMPTYPOINTER
	RTS
*
BACKUP	LDX	SCANPOINTER
	DEX
	CPX	#INPUTBUFFER-1
	BNE	BACKUP1
	LDX	#INPUTBUFFEREND-1
BACKUP1	STX	SCANPOINTER
	RTS
	PAGE
MTEST	CLR	FLAG	ASSUME FAILURE
	JSR	DEBLANK	TEST FOR PRESENCE OF STRING
	LDX	METAPC
	DEX
	STX	METAPC
MTEST1	JSR	GETTOKENCHAR	GET A CHAR FROM THE INPUT STREAM
	LDX	METAPC	GET A CHAR FROM THE META STRING
	INX
	STX	METAPC
	CMPA	0,X
	BEQ	MTEST1	B/ MATCHED SO FAR, KEEP GOING
	CMPA	#'a	DIDN'T MATCH, PERHAPS CASE IS INCORRECT
	BLT	MTEST1A	B/ STRINGS DON'T MATCH
	CMPA	#'z	...(checking for lower case)
	BGT	MTEST1A	B/ STRINGS DON'T MATCH
	SUBA	#'a-'A	CONVERT TO UPPER CASE
	CMPA	0,X	MATCH AGAINST STRING ?
	BEQ	MTEST1	B/ MATCHED SO FAR, KEEP GOING
MTEST1A	LDAB	0,X	WAS THIS THE LAST CHAR?
	BPL	MTEST2	B/ NOPE, NO MATCH
	ANDB	#$7F	YES, COMPARE IT AGAIN
	CBA
	BEQ	MTEST3	B/ STRING MATCHES
	BRA	MTEST2A

MTEST2	INX
	LDAA	0,X
	BPL	MTEST2	B/ NOT DONE YET
MTEST2A	INX		FAILED TO MATCH
	STX	METAPC
	BRA	FAILRETURN

MTEST3	INX		SUCCESSFUL MATCH
	STX	METAPC
	BRA	CALLT6	GO EAT THE INPUT
	PAGE
MCL	LDX	METAPC
	BRA	MCL2

MCL1	JSR	PUTCHAR
	INX
MCL2	LDAA	0,X
	BPL	MCL1
	ANDA	#$7F
	JSR	PUTCHAR
	JMP	METAINXPC
	PAGE
*	BRANCH TRUE, SIGNED DISPLACEMENT
*	01XXXXXX XXXXXXXX
*
BT	LDAA	FLAG
	BEQ	METAINXPC2	B/ FLAG IS FALSE, DON'T BRANCH
BT1	TFR	B,A	COPY UPPER BYTE OF DISPLACE TO (A)
	ASLA		SIGN EXTEND THE BRANCH DISPLACEMENT
	ASRA		NOTE: RELATIVE DISPLACEMENT IS FROM ADDRESS
	ASRA		OF THE OPCODE BYTE
	LDAB	1,X
	ADDD	METAPC
	STD	METAPC
	JMP	METAM
*
*	BRANCH FALSE, SIGNED DISPLACEMENT
*	10XXXXXX XXXXXXXX
*
BF	LDAA	FLAG	IS THE FLAG FALSE?
	BEQ	BT1	B/ YES, TAKE THE BRANCH
METAINXPC2	LEAX	2,X	BUMP (X) TWICE AND USE FOR META PC
	STX	METAPC
	JMP	METAMX
*
*	MASM --	ENTER ASSEMBLY CODE
*
MASM	JMP	[METAPC]	RE-ENTRY IS THRU "ENTERMETA" ENTRY POINT
*
ENTERMETA	LDX	,S++	RE-ENTER META-CODE
*			CALLED VIA: JSR ENTERMETA
	BRA	METASTXPC	FOLLOWED BY META CODE
	PAGE
METAINCPC2	LDX	METAPC	BUMP META PC BY TWO AND CONTINUE EXECUTION
	LEAX	2,X
	STX	METAPC
	JMP	METAMX

METAINCPC	LDX	METAPC	BUMP META PC AND CONTINUE EXECUTION
METAINXPC	INX		BUMP (X) AND USE FOR META PC
METASTXPC	STX	METAPC	USE (X) FOR META PC
	JMP	METAMX	WHICH IS 1 CYCLE FASTER THAN FALLING INTO

METAM	LDX	METAPC	GET THE META PROGRAM COUNTER
METAMX	LDAB	0,X	PICK UP THE META OPCODE
	ASLB		WHICH HALF OF THE TABLE?
	BCS	METAM1	B/ MUST BE "BRANCH FALSE" OR "CALL SUBR 0 T
	BMI	BT	B/ MUST BE BRANCH IF TRUE
	INX		BUMP THE META PC
	STX	METAPC
	IF	M6800!M6801
	STAB	DECODEADD+1
	LDX	DECODEADD	COMPUTE THE DISPLACEMENT
	JMP	[DECODE&$FF,X]	GO TO META ROUTINE
	ELSE	(M6809)
	LDX	#DECODE
	JMP	[B,X]
	FIN

METAM1	BPL	BF	B/ MUST BE "BRANCH IF FALSE"
*	BRA	CALLS0TO63	B/ MUST BE "CALL SUBROUTINE 0 TO 63"
	PAGE
*	CALL SUBROUTINE 0 TO 63
*	11XXXXXX
*
*	STRING N ADD HIGH
*	STRING N ADD LOW
*	:
*	:
*	STRING 1 ADD HIGH
*	STRING 1 ADD LOW
*	NUMSTR
*	INCLBL HIGH
*	INCLBL LOW
*	METPC HIGH
*	METAPC LOW
*
CALLS0TO63	LDAA	#(SUBRADD-$C0*2+$100)/256 COMPUTE SUBROUTINE ADDRESS
CALLS0	STD	SAVEX	THIS CODE IS TRICKY, SO WATCH OUT!
	LDX	SAVEX
	LDX	(SUBRADD-$C0*2+$100)&$FF,X
	BEQ	ERRUNDEFSUBR
	LDD	METAPC	SAVE THE METAPC
*	(NOTE: IT MUST BE INCREMENTED BEFORE USED AGAIN)
	PSHD
	STX	METAPC
	LDD	INCLBL	SAVE THE INCARNATION LABEL
	PSHD
	LDAA	NUMSTR	SAVE NUMBER OF STACKED STRINGS
	PSHA
	CLR	NUMSTR	SET NUMBER OF STRINGS TO 'NONE"
	STS	SAVEX	CHECK ENOUGH ROOM FOR AT LEAST 256 BYTES
	LDD	SAVEX
	SUBB	DICT+1	(NOTE: THIS CODE CANNOT BE OPTIMIZED ON 6809)
	SBCA	DICT
	BNE	MPARAMS	B/ ALL IS OK, CHECK FOR PARAMETERS
ERRCALLSTKOVFLW	LDX	#M:CALLSTACKOVERFLOW
	JMP	CROAK
*
ERRUNDEFSUBR	LDX	#M:UNDEFSUBR
	JMP	CROAK
*
*	CALL SUBROUTINE # 64 TO 319 / 320 TO 575
*	00000001 XXXXXXXX
*	00000010 XXXXXXXX
*
CALLSEXTENDED	TBA		COPY OPCODE * 2 TO (A,B)
	LDX	METAPC
	LDAB	0,X	FETCH 2ND BYTE OF OPCODE
	ASLB
	ADCA	#0+(SUBRADD-$C0*2)/256
	BRA	CALLS0	OOOH... TALK ABOUT PROGRAMMING TRICKS...
*	WHAT HAPPENS NEXT IS THE "LDX..(SUBR..)&$FF,X" TRICK
*	WHICH JUST SO HAPPENS TO HAVE THE CORRECT DISPLACEMENT!
	PAGE
MPARAMSL	JSR	REALIZELABEL	FORCE LABEL GENERATION
	LDD	INCLBL	SAVE IT IN THE STACK SO WE GET IT BACK WHEN WE RETURN
	STD	1,S	THIS IS WHERE IT IS!
	LDX	POINTER1	MUST GET PARAMETER LIST LENGTH AGAIN
	LDAB	2,X	GET THE LIST LENGTH
	ANDB	#$7F	DUMP THE "PASS GEN'D LABEL#" FLAG
	BRA	MPARAMS0

MPARAMS	LDX	3,S	SEE IF ANY PARAMETERS (GET THE RETURN METAPC)
	LDAB	1,X	GET THE METAOP AT THE RETURN ADDRESS
	CMPB	#:MPARAMS	AND SEE IF ANY PARAMETERS
	BNE	MPARAMS5	B/ NO
	STX	POINTER1	YES, REMEMBER THE PARAMETER LIST
	LDAB	2,X	GET THE LIST LENGTH
	BMI	MPARAMSL	B/ MUST PASS GENERATED LABEL NUMBER, TOO!
	LDX	#0	SET THE INCARNATION LABEL TO 'NONE'
	STX	INCLBL
MPARAMS0	STAB	NUMSTR	REMEMBER THE LIST LENGTH
*			BUMP THE RETURN METAPC PAST THE ARG LIST
	CLRA		EXTEND LIST LENGTH TO 16 BITS
	ADDB	#2		+2 FOR METAOP AND LIST LENGTH
	ADDD	3,S
	IF	M6809
	STD	3,S
	ELSE
	STD	3,X
	FIN
	LDAB	NUMSTR
	BEQ	MPARAMS2	B/ NO ARGUMENTS TO COPY!
	PAGE
MPARAMS1	LDX	SAVEX
	LDAA	0+1-M6809,X	GET THE STACKED NUMSTR
	LDX	POINTER1	GET NEXT STRING NUMBER FROM METAPROGRAM
	SUBA	3,X
	BCS	MPARAMS6	B/ STRING SELECTOR OUT OF RANGE
	INX
	STX	POINTER1
	ASLA
	ADDA	SAVEX+1
	STAA	TEMPX+1
	LDAA	SAVEX
	ADCA	#0
	STAA	TEMPX
	LDX	TEMPX
	LDAA	6+1-M6809,X
	PSHA
	LDAA	5+1-M6809,X
	PSHA
	DECB		ARE WE DONE?
	BNE	MPARAMS1	B/ NO
MPARAMS2	JMP	METAM

MPARAMS5	LDX	#0	SET THE INCARNATION LABEL TOJ 'NONO'
	STX	INCLBL
	JMP	METAM

MPARAMS6	LDX	#M:STRINGSELECTOR
	JMP	CROAK
	PAGE
MSET	LDAA	#$FF	SET THE FLAG
	BRA	MQUERY2
*
*
*
MQUERYN	JSR	FINDSTRINGADD	GET ADD OF NTH STRING
	BRA	MQUERY1

MQUERY	LDX	STAR
	BEQ	MPARAMS6	B/ NO STAR STRING !
MQUERY1	JSR	FINDFLAG	ADD IN X, BIT # IN A
	ANDA	STRINGNODE:FLAGS,X
MQUERY2	STAA	FLAG
	JMP	METAM
*
*
*
MTAGN	BSR	FINDSTRINGADD
	BRA	MTAG1

MTAG	LDX	STAR
	BEQ	MPARAMS6	B/ NO STAR STRING !
MTAG1	JSR	FINDFLAG
	ORAA	STRINGNODE:FLAGS,X
	STAA	STRINGNODE:FLAGS,X
	JMP	METAM
*
*
*
MUNTAGN	BSR	FINDSTRINGADD
	BRA	MUNTAGN1

MUNTAG	LDX	STAR
	BEQ	ERRSTRINGSELRNG	B/ NO STAR STRING !
MUNTAGN1	BSR	FINDFLAG
	COMA
	ANDA	STRINGNODE:FLAGS,X
	STAA	STRINGNODE:FLAGS,X
	JMP	METAM
	PAGE
MSETTYPEN	BSR	FINDSTRINGADD	SET TYPE OF *N STRING
	BSR	FETCH2ND	GET THE 2ND PARAMETER BYTE OF OPCODE
	STAA	STRINGNODE:TYPE,X
	JMP	METAM

MQUERYTYPEN	BSR	FINDSTRINGADD	QUERY TYPE OF *N STRING
	BSR	FETCH2ND
	CLR	FLAG	ASSUME NO MATCH
	CMPA	STRINGNODE:TYPE,X
	BNE	MQUERYTYPEN1	B/ NO MATCH
	INC	FLAG	MATCH!
MQUERYTYPEN1	JMP	METAM

FETCH2ND	STX	SAVEX	FETCH 2ND PARAMETER BYTE OF OPCODE
	LDX	METAPC
	LDA	,X+
	STX	METAPC
	LDX	SAVEX
	RTS
	PAGE
FINDSTARN	LDAA	NUMSTR	FIND NTH STRING, N IN (B)
	SBA
	BCS	ERRSTRINGSELRNG	B/ STRING SELECTOR OUT OF RANGE
	ASLA		#2
	STS	SAVEX
	ADDA	SAVEX+1
	STAA	SAVEX+1
	BCC	FINDSTARN1
	INC	SAVEX
FINDSTARN1	LDX	SAVEX
*	THE 3,X	ALLOWS 1 FOR STACK, 2 FOR RETURN ADDRESS
	LDX	3-M6809,X	GET ADDRESS OF NTH STRING
	BRA	FINDSTAR1

FINDSTAR	LDX	STAR	FIND STAR STRING, RETURN ADDR IN (X)
	BEQ	ERRSTRINGSELRNG	B/ NO STAR STRING !
FINDSTAR1	LDAB	STRINGNODE:KEYLEN,X AND RETURN LENGTH IN (B)
	ANDB	#$7F
	LEAX	STRINGNODE:BODY,X
	RTS
	PAGE
FINDSTRINGADD	LDX	METAPC
	LDB	,X+	FETCH STRING SELECTOR BYTE
	STX	METAPC
	LDAA	NUMSTR
	SBA
	BCS	ERRSTRINGSELRNG	B/ STRING SELECTOR OUT OF RANGE
	ASLA		#2
	STS	SAVEX
	ADDA	SAVEX+1
	STAA	SAVEX+1
	BCC	FINDSTRINGADD1
	INC	SAVEX
FINDSTRINGADD1	LDX	SAVEX
*	THE 3,X ALLOWS 1 FOR STACK, 2 FOR RETURN ADDRESS
	LDX	3-M6809,X	GET ADDRESS OF NTH STRING
	RTS
ERRSTRINGSELRNG	LDX	#M:STRINGSELECTOR
	JMP	CROAK
*
FINDFLAG	STX	SAVEX	SAVE THE STRING ADDRESS
	LDX	METAPC
	LDB	,X+	GET THE BIT NUMBER
	STX	METAPC
	LDX	SAVEX	GET THE STRING ADDRESS BACK
	ANDB	#$F	MAKE SURE IT'S < 16
	CMPB	#7
	BLE	FINDFLAG1
	SUBB	#8
	INX
FINDFLAG1	CLRA		FORM THE BIT MASK
	SEC
FINDFLAG2	ROLA
	DECB
	BPL	FINDFLAG2
	RTS
	PAGE
*	MOVESTRINGUP TAKES THE SELECTED STRING AND INVENTS
*	A STACKED STRING ENTRY FOR THE CALLING ROUTINE
*
MOVESTRINGUP	BSR	FINDSTRINGADD	GO FIND THE STACKED STRING ADDRESS
	STX	SAVEX
	LEAS	-2,S	RESERVE 2 BYTES FOR THE PUSHED STAR STRING
	LDAB	NUMSTR	MOVE THE STACKED STRINGS FIRST
	ASLB
	TSX
MOVESTR1	LDAA	2,X
	STA	,X+
	DECB
	BNE	MOVESTR1
	INC	2,X	BUMP THE NUMSTR IN THE STACK
	BMI	MOVESTR3	B/ TOO MANY STRINGS, ERROR
	LDAB	#5
MOVESTR2	LDAA	2,X
	STA	,X+
	DECB
	BNE	MOVESTR2
	LDD	SAVEX
	STD	0,X
	STS	SAVEX
	LDD	SAVEX
	SUBB	DICT+1	(NOTE: THIS CODE CANNOT BE OPTIMIZED FOR 6809)
	SBCA	DICT
	BEQ	JERRCALLSTKOVFLW	B/ STACK SPACE EXHAUSTED
	JMP	METAM

MOVESTR3	LDX	#M:TOOMANYSTRINGS
	JMP	CROAK
JERRCALLSTKOVFLW	JMP	ERRCALLSTKOVFLW
	PAGE
*	MINCLUDE USES THE STAR STRING AS A FILE NAME TO
*	REDIRECT THE SOURCE INPUT CHANNEL
*
MINCLUDE	LDX	STAR
	LDAB	STRINGNODE:KEYLEN,X GET THE COUNT BYTE
	ANDB	#$7F	MASK OFF THE KEY BIT
	LEAX	STRINGNODE:BODY,X
	CLR	OPENIFILE+OPEN:LENGTH
	STAB	OPENIFILE+OPEN:LENGTH+1
	STX	OPENIFILE+OPEN:NAMEP SAVE THE BUFFER POINTER
	INC	SICHANNEL	WE NEED A NEW I/O CHANNEL
	LDAB	SICHANNEL
	STAB	OPENIFILE+OPEN:CHANNEL SET THE CHANNEL NUMBER
	LDX	#OPENIFILE
	JSR	SYSCALL$
	BCC	METAMJ	B/ NO ERROR
	DEC	SICHANNEL	ENSURE THAT SI CHANNEL IS REALLY OPEN
	STX	INCLUDEERROR	SAVE THE ERROR CODE
	JSR	DUMPLINE	TELL THE USER WHY HE'S WRONG
	LDX	INCLUDEERROR
	JMP	CALLSYSCALL1
	PAGE
MRT	LDAA	FLAG	META SUBROUTINE RETURN IF TRUE
	BNE	MR	B/ RETURN
METAMJ	JMP	METAM	NO RETURN
*
MRF	LDAA	FLAG	METASUBROUTINE RETURN IF FALSE
	BEQ	MR	B/ RETURN
	JMP	METAM	NO RETURN
*
MR	LDAB	NUMSTR	DITCH THE * STRINGS FOR THIS RULE
	ASLB		*2 (ASSERT: NUMSTR<=127)
	IF	M6809
	CLRA		MAKE UNSIGNED 16 BIT DISPLACEMENT
	LEAS	D,S
	ELSE
	STS	SAVEX
	ADDB	SAVEX+1
	STAB	SAVEX+1
	BCC	MR1
	INC	SAVEX
MR1	LDS	SAVEX
	FIN
	PULA
	STAA	NUMSTR
	PULD
	STD	INCLBL
	PULD
	STD	METAPC
	TSX		SO '00 AND '09 GET THE SAME THING
	STX	SAVEX	NOW FORGET THE DISTINGUISHED RULE IF STACK
	LDD	RECOVERYSTACK	IS POPPED PAST ITS NESTING
	SUBD	SAVEX
	BCC	MR2	B/ STILL OK
	LDX	#0
	STX	RECOVERYMETAPC	RECOVERYMETAPC IS NO LONGER VALID
MR2	JMP	METAINCPC	BECAUSE "CALL" NEVER ADVANCED IT!
	PAGE
MCR	LDAA	#ASCII:CR
	JSR	PUTCHAR
	JMP	METAM

MTAB	LDAA	#ASCII:HT
	JSR	PUTCHAR
	JMP	METAM
*
MOUTN	JSR	FINDSTRINGADD
	BSR	OUTSTRING
	JMP	METAM

MOUT	LDX	STAR
	BSR	OUTSTRING
	JMP	METAM
*
OUTSTRING	LDAB	STRINGNODE:KEYLEN,X GET THE STRING LENGTH
	ANDB	#$7F	MASK OFF THE KEY BIT
	BEQ	OUTSTRING2	B/ ZERO LENGTH STRING
OUTSTRING1	LDAA	STRINGNODE:BODY,X GET A CHAR
	JSR	PUTCHAR	OUTPUT IT
	INX
	DECB
	BNE	OUTSTRING1	B/ MORE TO DO
OUTSTRING2	RTS		DONE
	PAGE
*
*	REALIZE LABEL -- ENSURE THAT A LABEL NUMBER HAS BEEN GENERATED...
*	FOR THIS INCARNATION
*
REALIZELABEL	EQU	*
	LDX	INCLBL	GET INCARNATION LABEL
	BNE	MGENL1	= NONE (ZERO VALUE)
	LDX	LABGEN	BUMP LABEL GENERATOR &
	INX	SET INCARNATION LABEL
	STX	LABGEN
	STX	INCLBL
MGENL1	RTS

MGENL	BSR	REALIZELABEL	FORCE LABEL NUMBER GENERATION
	LDX	METAPC	GET THE LABEL NUMBER
	LDA	,X+
	STX	METAPC
	ADDA	#'0
	JSR	PUTCHAR	APPEND TO LABEL '$'
	CLR	FLAG	USE THIS AS A LEAD ZERO FLAG
	LDAA	INCLBL
	BSR	MGENL2
	LDAA	INCLBL+1
	BSR	MGENL2
	JMP	METAM
*
MGENL2	PSHA
	LSRA
	LSRA
	LSRA
	LSRA
	BSR	MGENL3
	PULA
	ANDA	#$F
MGENL3	BNE	MGENL4	B/ NOT A ZERO
	LDAB	FLAG	WAITING FOR NONZERO?
	BEQ	MGENL6	B/ YES, DON'T OUTPUT
	BRA	MGENL4A	NO, OUTPUT IT ANYWAY
MGENL4	STAA	FLAG
MGENL4A	CMPA	#10
	BLT	MGENL5
	ADDA	#7
MGENL5	ADDA	#'0
	JMP	PUTCHAR
MGENL6	RTS
	PAGE
*
*	COMPUTEHASH -- COMPUTE POINTER TO HASH BUCKET FOR STRING...
*	(X) POINTS TO STRING BODY; (B) CONTAINS STRING LENGTH
*
COMPUTEHASH	STAB	TEMPB	SAVE COUNT
	CLRA
*	CLC		(PREVIOUS INSTRUCTION DID THIS)
HASH	ASLA		SHIFT THE BITS AROUND TO HELP GARBLE THINGS
	LDB	,X+	GET THE NEXT STRING BYTE
	ANDB	#%01011111	DROP UPPER/LOWER CASE BIT
	ADCB	#0	FEED BACK SHIFTED OUT MSB (CAN'T CARRY OUT!
	ABA		SUM SHIFTED HASH AND NEW CHARACTER
	CPX	#INPUTBUFFEREND	(NOTE: THIS DESTROYS C BIT ON 6809!)
	BNE	HASH1
	LDX	#INPUTBUFFER
HASH1	DEC	TEMPB	DOWN COUNT # BYTES NOT HASHED YET
	BNE	HASH
	TFR	A,B	TO MAKE FOLLOWING CODE EFFICIENT ON '09
	ANDB	#$1F	CHOP TO 32 BUCKETS
	ASLB		BUCKET NUMBER * 2
	CLRA		MAKE UNSIGNED 16 BIT OFFSET
	ADDD	#HASHTABLE-STRINGNODE:NEXT
	STD	TOKENPOINTER
	RTS
	PAGE
FINDSTRING	LDD	SCANPOINTER	COMPUTE LENGTH OF STAR STRING
	SUBD	EMPTYPOINTER
	BCC	FINDSTRING1A	B/ LENGTH IS POSITIVE
	ADDD	#INPUTBUFFERSIZE IS NEGATIVE, FIND ABSOLUTE VALUE
FINDSTRING1A	EQU	*
	IF	M6809
	TSTA
	FIN
	BNE	FINDSTRINGA	B/STRING SIZE >=256, CAN'T HANDLE
	TSTB
	BMI	FINDSTRINGA	B/ STRING SIZE >= 128, CAN'T HANDLE
	STAB	STRINGLENGTH	WE'LL NEED THIS LOTS, LATER
	LDX	EMPTYPOINTER	COMPUTE HASH BUCKET
	LDAA	#'a-'A	ASSUME WE WILL HAVE TO CONVERT LOWER TO UPPER
	STAA	CASECONVERSION	(I.E., THIS IS NOT A "STRING" TOKEN)
	LDAA	0,X	GET FIRST BYTE OF TOKEN BODY
	CMPA	#''	START WITH SINGLE OR DOUBLE QUOTE ?
	BEQ	FINDSTRING2A	B/ YEP, DON'T FOLD CASE!
	CMPA	#'"	...?
	BNE	FINDSTRING2B	B/NO, DO FOLD LOWER INTO UPPER CASE
FINDSTRING2A	CLR	CASECONVERSION	IS STRING TOKEN, DON'T FOLD CASE!
FINDSTRING2B	BSR	COMPUTEHASH
FINDSTRING2	LDAB	STRINGLENGTH	CHECK NEXT STRINGNODE ON CHAIN FOR MATCH
	LDX	TOKENPOINTER
	LDX	STRINGNODE:NEXT,X GET POINTER TO NEXT NODE
	BEQ	FINDSTRING5	B/ END OF LIST, GO INSERT
	STX	TOKENPOINTER
	LDAA	STRINGNODE:KEYLEN,X GET COUNT BYTE
	ANDA	#$7F	IGNORE KEYWORD BIT
	CBA		LENGTH EQUAL?
	BNE	FINDSTRING2	B/ NO, TRY NEXT
	STX	POINTER2
	LDX	EMPTYPOINTER
	BRA	FINDSTRING3A
FINDSTRING3	LDX	POINTER1
FINDSTRING3A	LDA	,X+
	CPX	#INPUTBUFFEREND
	BNE	FINDSTRING4
	LDX	#INPUTBUFFER
FINDSTRING4	STX	POINTER1
	LDX	POINTER2
	CMPA	STRINGNODE:BODY,X
	BEQ	FINDSTRING4A	B/ BYTES MATCH!
	CMPA	#'a	BYTES DON'T MATCH, PERHAPS CASE IS WRONG
	BLT	FINDSTRING2	B/ CASE IS OK, STRINGS DON'T MATCH!
	CMPA	#'z	...
	BGT	FINDSTRING2	B/ CASE IS OK, STRINGS DON'T MATCH!
	SUBA	CASECONVERSION	CONVERT TO UPPER CASE
	CMPA	STRINGNODE:BODY,X AND TRY THE COMPARISON AGAIN!
	BNE	FINDSTRING2	B/ STILL DOESN'T MATCH...
FINDSTRING4A	INX
	STX	POINTER2
	DECB		DECREMENT BYTE COUNT
	BNE	FINDSTRING3	B/ STILL MORE TO CHECK
	BRA	FINDSTRING8	MATCHED!!
FINDSTRINGA	LDX	#M:STRINGLENGTH
	JMP	CROAK
	PAGE
*
*	INSERT THE STRING INTO A NEW STRINGNODE
*
FINDSTRING5	LDD	DICT	ALLOCATE THE SPACE
*	ASSERT: >=256 BYTES OF DICTIONARY SPACE AVAILABLE
	LDX	TOKENPOINTER
	STD	STRINGNODE:NEXT,X
	ADDB	STRINGLENGTH	STRINGLENGTH
	ADCA	#0
	ADDD	#STRINGNODE:BODY +OVERHEAD
	STD	DICT
	STS	TEMPX
	SUBB	TEMPX+1	IS THERE ENOUGH ROOM?
	SBCA	TEMPX	(NOTE: CANNOT OPTIMIZE THIS CODE ON 6809)
	BEQ	FINDSTRING9	B/ NO
	LDX	TOKENPOINTER	GET ADDRESS OF NEW NODE
	LDX	STRINGNODE:NEXT,X
	STX	TOKENPOINTER
	CLR	STRINGNODE:FLAGS,X FLAGS HIGH
	CLR	STRINGNODE:FLAGS+1,X FLAGS LOW
	CLR	STRINGNODE:TYPE,X SET TYPE TO 'UNDEFINED'
	CLR	STRINGNODE:NEXT,X END OF LIST
	CLR	STRINGNODE:NEXT+1,X
	LDAB	STRINGLENGTH	ASSERT: MSB IS OFF!
	STAB	STRINGNODE:KEYLEN,X K, LENGTH
	STX	POINTER2
	LDX	EMPTYPOINTER
	BRA	FINDSTRING6B
FINDSTRING6	LDX	POINTER1
FINDSTRING6B	LDA	,X+
	CMPA	#'a	FOLD LOWER CASE INTO UPPER CASE
	BLT	FINDSTRING6A	B/ NOT LOWER CASE
	CMPA	#'z	...?
	BGT	FINDSTRING6A	B/ NOT LOWER CASE
	SUBA	CASECONVERSION	is lower case, MAKE INTO UPPER CASE
FINDSTRING6A	CPX	#INPUTBUFFEREND
	BNE	FINDSTRING7
	LDX	#INPUTBUFFER
FINDSTRING7	STX	POINTER1
	LDX	POINTER2
	STAA	STRINGNODE:BODY,X
	INX
	STX	POINTER2
	DECB
	BNE	FINDSTRING6
FINDSTRING8	LDX	TOKENPOINTER
	RTS
FINDSTRING9	LDX	#M:DICTIONARYOVERFLOW DICTIONARY OVERFLOW
	JMP	CROAK
	PAGE
M:SYNTAX	FCC	'Syntax Erro'
	FCB	'r+$80
M:IMDONE	FCC	'Compilation Complet'
	FCB	'e+$80
M:DICTIONARYOVERFLOW	FCC	'Memory Full: Dictionary Overflo'
	FCB	'w+$80
M:CALLSTACKOVERFLOW	FCC	'Memory Full: Call Stack Overflo'
	FCB	'w+$80
M:TOOMANYSTRINGS	FCC	'Compiler Bug! Too many stacked String'
	FCB	's+$80
M:STRINGLENGTH	FCC	'String Length exceeds 127 character'
	FCB	's+$80
M:STRINGSELECTOR	FCC	'Compiler Bug! String Selector out of rang'
	FCB	'e+$80
M:EOFHIT	FCC	'End of file Hit before End of Progra'
	FCB	'm+$80
M:BADMETAOP	FCC	'Compiler Bug! Illegal Meta Instructio'
	FCB	'n+$80
M:UNDEFSUBR	FCC	'Compiler Bug! Undefined Subroutin'
	FCB	'e+$80
M:LINETOOLONG	FCC	'Source line is too lon'
	FCB	'g+$80
	PAGE

*	PRINT MESSAGE (X)
*
PRINT2	BSR	PUTELOG
	INX
PRINT	LDAA	0,X
	BPL	PRINT2
	ANDA	#$7F
	BSR	PUTELOG
	BRA	CRLF
*
BADMETAOP	LDX	#M:BADMETAOP
CROAK	STX	SAVEX	SAVE MESSAGE ADDRESS
	JSR	PURGEBUFFER	SO IRA CAN SEE JUST HOW FAR WE GOT
	LDX	SAVEX	GET MESSAGE ADDRESS AND GO PRINT IT
	BSR	PRINT
	BSR	DUMPLINE
	BSR	CRLF
CROAK1	LDX	#ERR:FATALCOMPILE
	JMP	MFIN1
	PAGE
*	DUMPLINE -- PRINTS OUT LAST LINE OF TEXT COLLECTED
*	ALONG WITH "^" POINTER TO CURRENT TEXT POSITION
*
DUMPLINE	LDX	EMPTYPOINTER	REMEMBER EXACTLY WHERE THE ERROR OCCURED
	STX	POINTER1
	LDAA	#ASCII:CR
*	<CR> at end of buffer will take care of case where error in first line
DUMPLINE1	CPX	#INPUTBUFFER	AT FRONT OF BUFFER ?
	BNE	DUMPLINE0	B/ NO, LEAVE POINTER ALONE
	LDX	#INPUTBUFFEREND	YES, MAKE POINTER GO BACKWARDS CIRCULARLY
DUMPLINE0	DEX
	CPX	FILLPOINTER
	BEQ	DUMPLINE3	B/ CAN'T GO BACK ANY FURTHER
	CMPA	0,X
	BNE	DUMPLINE1	B/ DIDN'T FIND BEGINNING OF LINE YET
DUMPLINE3	INX	START AT BEGINNING OF LINE
	CPX	#INPUTBUFFEREND	AT END OF BUFFER ?
	BNE	DUMPLINE2	B/ NO
	LDX	#INPUTBUFFER	YES, MAKE POINTER GO CIRCULARLY
DUMPLINE2	STX	EMPTYPOINTER
	STX	SCANPOINTER
DUMPLINE4	JSR	GETTOKENCHAR
	BSR	PUTELOG
	CMPA	#ASCII:CR
	BNE	DUMPLINE4
DUMPLINE5	LDX	EMPTYPOINTER	AT ERROR POINT ?
	CPX	POINTER1	...?
	BEQ	DUMPLINE7	B/ YEP
	JSR	GETINPUTCHAR
	CMPA	#ASCII:HT	UNLESS IT'S A TAB...
	BEQ	DUMPLINE6
	LDAA	#' 	OUTPUT A BLANK
DUMPLINE6	BSR	PUTELOG
	BRA	DUMPLINE5
DUMPLINE7	LDAA	#'^
	BSR	PUTELOG
	BSR	CRLF	OUTPUT 2 CRLF'S TO SEPARATE EACH ERROR DISP
*	BRA	CRLF
	PAGE
*
CRLF	LDAA	#ASCII:CR
PUTELOG	PSHA
	STX	SAVEX
	TSX
	STX	CONSOLEOUTBUFFER
	LDX	#CONSOLEOUT
	JSR	CALLSYSCALL
	LDX	SAVEX
	PULA
	RTS
	PAGE
*	PUT THE CHARACTER INTO THE OUTPUT BUFFER
*	WHEN THE OUTPUT BUFFER BECOMES FULL,
*	WRITE IT TO THE OUTPUT FILE
*
PUTCHAR	TST	OUTFLAG	IS THE OUTPUT ENABLED?
	BNE	PUTCHAR2	B/ NO
	STX	SAVEX	YES, SAVE HIS X
	LDX	OUTPUTPOINTER
	STA	,X+
	CPX	#OUTPUTBUFFEREND ARE WE AT THE END OF THE BUFFER?
	BNE	PUTCHAR1	B/ NO, CONTINUE
	PSHB		SAVE (B), SOME PEOPLE USE HIM AS COUNTER
	LDX	#PUTBUFFER	OUTPUT THE BUFFER
	JSR	CALLSYSCALL
	PULB		RESTORE (B)
	LDX	#OUTPUTBUFFER
PUTCHAR1	STX	OUTPUTPOINTER
	LDX	SAVEX
PUTCHAR2	RTS
*
PURGEBUFFER	LDD	OUTPUTPOINTER	AT QUITTING TIME
	SUBD	#OUTPUTBUFFER
	STD	PUTBUFFERL
	LDX	#PUTBUFFER
	JMP	CALLSYSCALL
*
PUTBUFFER	FCB	SYSCALL:WRITEA	SYSCALL OPCODE
	FCB	WRITEA:SCLEN	LENGTH OF SYSCALL BLOCK
	FCB	SO	SOURCE OUTPUT CHANNEL
	FCB	IGNORED	ONE BYTE FILLER
	FDB	OUTPUTBUFFER	POINTER TO THE DATA
PUTBUFFERL	FDB	OUTPUTBUFFERSIZE SIZE OF DATA
	PAGE
GETTOKENCHAR0	BSR	FILLTHEBUFFER
GETTOKENCHAR	LDX	SCANPOINTER	NO, GET THE NEXT TOKEN CHAR
	CPX	FILLPOINTER	AT END OF USEABLE INPUT ?
	BEQ	GETTOKENCHAR0	B/ YES, GO GET SOME MORE!
	LDA	,X+
	CPX	#INPUTBUFFEREND
	BNE	GETTOKENCHAR2
	LDX	#INPUTBUFFER
GETTOKENCHAR2	STX	SCANPOINTER
	RTS
*
GETINPUTCHAR0	BSR	FILLTHEBUFFER
GETINPUTCHAR	LDX	EMPTYPOINTER	NO, GET NEXT INPUT CHAR
	CPX	FILLPOINTER
	BEQ	GETINPUTCHAR0	B/ BUFFER IS EXHAUSTED
	LDA	,X+
	CPX	#INPUTBUFFEREND
	BNE	GETINPUTCHAR2
	LDX	#INPUTBUFFER
GETINPUTCHAR2	STX	EMPTYPOINTER
	RTS
	PAGE

*
*	FILL UP THE INPUT BUFFER (WELL, FILL SOME OF IT, ANYWAY)
*	ALWAYS READS A FULL LINE SO THAT ERROR PRINT-OUT IS POSSIBLE
*	THERE ARE TWO CASES:
*	1) THE FILL POINTER IS < THE EMPTY POINTER
*		READ EMPTYPOINTER-FILLPOINTER-1 BYTES
*		INTO THE BUFFER AT FILLPOINTER
*	2) THE EMPTY POINTER IS <= THE FILL POINTER
*		READ BUFFEREND-FILLPOINTER BYTES
*		INTO THE BUFFER AT FILLPOINTER
*
FILLTHEBUFFER	LDD	EMPTYPOINTER	DECIDE WHICH CASE
	SUBD	FILLPOINTER
	BCS	FILLTHEBUFFER0	B/ CASE 2
	BNED	FILLTHEBUFFER1	B/ NOPE, CASE 1
*
*	CASE 2, FILL TO END OF BUFFER
*
FILLTHEBUFFER0	LDD	#INPUTBUFFEREND
	SUBD	FILLPOINTER
	LDX	EMPTYPOINTER	WATCH OUT FOR SPECIAL CASE:
	CPX	#INPUTBUFFER	WE DON'T WANT FILL POINTER TO CATCH UP...
	BNE	FILLTHEBUFFER1A WITH EMPTY POINTER (B/ NOT SPECIAL CASE)
FILLTHEBUFFER1	SUBD	#1	SO THAT FILL POINTER CAN'T CATCH UP WITH THE EMPTY POINTER
FILLTHEBUFFER1A	STD	FILLBLOCKL
	LDX	FILLBLOCKL	HOW MANY BYTES ARE WE REQUESTING ?
	BEQ	FILLTHEBUFFERF	B/ ZERO, BUFFER HAS NO ROOM!
FILLTHEBUFFER5	LDX	FILLPOINTER	TELL HIM WHERE TO PUT IT
	STX	FILLBLOCKB
	LDX	#FILLBLOCK	NO, GO AHEAD AND READ
	JSR	SYSCALL$
	BCC	FILLTHEBUFFER2	B/ ALL DONE
	CPX	#ERR:EOFHIT	END OF FILE ENCOUNTERED ?
	BNE	CALLSYSCALL1	B/ NO, I CAN'T HANDLE IT
	LDX	FILLBLOCK+READA:ACTUALCOUNT DID WE GET ANY BYTES ?
	BNE	FILLTHEBUFFER2	B/ YES, GET THE HELL OUT OF HERE!
	LDAA	SICHANNEL	EOF ON THE PRIMARY INPUT CHANNEL?
	CMPA	#SI
	BHI	FILLTHEBUFFER4	B/ NO, KEEP GOING
	JSR	PURGEBUFFER	SO IRA CAN SEE HOW FAR WE GOT, EXACTLY...
	LDX	#M:EOFHIT	WE'RE DEAD
FILLTHEBUFFER5A	JSR	PRINT	THE ERROR MESSAGE
	JMP	CROAK1

FILLTHEBUFFERF	JSR	PURGEBUFFER	JUST TO BE NICE
	LDX	#M:LINETOOLONG	AND I DON'T KNOW WHAT TO DO ABOUT IT...
	BRA	FILLTHEBUFFER5A	SO I'LL STICK YOU WITH THE PROBLEM

FILLTHEBUFFER4	STAA	CLOSEIFILECHANNEL
	LDX	#CLOSEIFILE
	BSR	CALLSYSCALL
	DEC	SICHANNEL
	BRA	FILLTHEBUFFER5

FILLTHEBUFFER2	LDD	FILLPOINTER	UPDATE THE FILL POINTER
	ADDD	FILLBLOCK+READA:ACTUALCOUNT
	STD	FILLPOINTER
	LDX	FILLPOINTER
	DEX		SEE IF LAST CHARACTER READ IS <CR>
	LDAA	0,X	GRAB LAST CHARACTER READ FOR LATER INSPECTION
	CPX	#INPUTBUFFEREND-1
	BNE	FILLTHEBUFFER3
	LDX	#INPUTBUFFER
	STX	FILLPOINTER
FILLTHEBUFFER3 ; NOW CHECK THAT A COMPLETE LINE HAS BEEN READ
	CMPA	#ASCII:CR
	BNE	FILLTHEBUFFER	B/ DIDN'T READ COMPLETE LINE, READ ANOTHER CHUNK
	RTS		NEXT TIME, I'LL HANDLE ANY EOF
*
FILLBLOCK	FCB	SYSCALL:READA	SYSCALL OPCODE
	FCB	READA:SCLEN	LENGTH OF SYSCALL BLOCK
SICHANNEL	FCB	SI	CONSOLE INPUT CHANNEL
	FCB	1	LINE INPUT MODE
	FDB	IGNORED	WRITE BUFFER
	FDB	IGNORED	WRITE BUFFER LENGTH
	FDB	CHANGED	ACTUAL # OF BYTES READ
FILLBLOCKB	FDB	0	READ BUFFER
FILLBLOCKL	FDB	0	READ BUFFER SIZE
*
	PAGE
CALLSYSCALL	JSR	SYSCALL$
	BCC	CALLSYSCALL2	B/ NO ERRORS
CALLSYSCALL1	STX	IOERROR
CHECKSUMERROR	LDX	#IOERRORBLOCK	NOTE: SDOS CLOSES ALL THE I/O CHANNELS FOR
	JMP	SYSCALL$	... THAT'S ALL, FOLKS
CALLSYSCALL2	RTS
*
IOERRORBLOCK	FCB	SYSCALL:ERROREXIT
	FCB	ERROREXIT:SCLEN	SYSCALL BLOCK LENGTH
IOERROR	FDB	ERR:SELFTESTCKSUM	ERROR CODE GOES HERE
*
CLOSEIFILE	FCB	SYSCALL:CLOSE	SYSCALL OPCODE
	FCB	CLOSE:SCLEN	LENGTH OF SYSCALL BLOCK
CLOSEIFILECHANNEL	FCB	SI	INPUT CHANNEL
	FCB	IGNORED
*
*
OPENIFILE	FCB	SYSCALL:OPEN	OPCODE
	FCB	OPEN:SCLEN	LENGTH OF SYSCALL BLOCK
	FCB	SI	INPUT CHANNEL
	FCB	IGNORED	ONE BYTE FILLER
	FDB	NAMEBUFFER	POINTER TO FILE NAME
	FDB	0	LENGTH OF FILE NAME
	FDB	CHANGED	REPLY LENGTH
	FDB	SAVEX	A GOOD 2-BYTE BUFFER
	FDB	2	SIZE OF BUFFER
*
CONSOLEOUT	FCB	SYSCALL:WRITEA	OPCODE
	FCB	WRITEA:SCLEN	LENGTH OF SYSCALL BLOCK
	FCB	CO	CONSOLE OUTPUT CHANNEL
	FCB	IGNORED FILLER TO GET TO NEXT BYTE
CONSOLEOUTBUFFER	FDB	0	POINTER TO MESSAGE
	FDB	1	LENGTH OF MESSAGE
*
HASHTABLE	RPT	32	32 HASH BUCKETS
	FDB	0
	PAGE
*
*	INITIALIZATION CODE
*	THIS STUFF IS DONE ONCE AND THROWN AWAY
*	SO I PUT IT IN THE BUFFER AREA
*
INPUTBUFFER	EQU	*
HIMESSAGE	FCB	SYSCALL:WRITEA	OPCODE
	FCB	WRITEA:SCLEN	LENGTH OF SYSCALL BLOCK
	FCB	CO	CONSOLE OUTPUT
	FCB	IGNORED	FILLER TO GET TO NEXT BYTE
	FDB	CHANGED	POINTER TO MESSAGE
HIMESSAGEL	FDB	0	LENGTH OF TEXT (<256 BYTES, MUST INCLUDE AS
*
INPUTFILENAME	FCB	SYSCALL:WRITEA	OPCODE
	FCB	WRITEA:SCLEN	LENGTH OF SYSCALL BLOCK
	FCB	CO	CONSOLE OUTPUT
	FCB	IGNORED	FILLER TO GET TO NEXT BYTE
	FDB	INPUTPROMPT	POINTER TO MESSAGE
	FDB	INPUTPROMPTL	LENGTH OF MESSAGE
*
INPUTPROMPT	FCC	'Input file = '
INPUTPROMPTL	EQU	*-INPUTPROMPT
*
OUTPUTFILENAME	FCB	SYSCALL:WRITEA	OPCODE
	FCB	WRITEA:SCLEN	LENGTH OF SYSCALL BLOCK
	FCB	CO	CONSOLE OUTPUT
	FCB	IGNORED	FILLER TO GET TO NEXT BYTE
	FDB	OUTPUTPROMPT	POINTER TO MESSAGE
	FDB	OUTPUTPROMPTL	LENGTH OF MESSAGE
*
OUTPUTPROMPT	FCC	'Output File = '
OUTPUTPROMPTL	EQU	*-OUTPUTPROMPT
*
OPENOFILE	FCB	SYSCALL:CREATE	OPCODE
	FCB	CREATE:SCLEN	LENGTH OF SYSCALL BLOCK
	FCB	SO	INPUT CHANNEL
	FCB	IGNORED	ONE BYTE FILLER
	FDB	NAMEBUFFER	POINTER TO FILE NAME
	FDB	0	LENGTH OF FILE NAME
	FDB	CHANGED	REPLY LENGTH
	FDB	SAVEX	A GOOD 2-BYTE BUFFER
	FDB	2	SIZE OF REPLY
*
INPUTCONSOLE	FCB	SYSCALL:READA	SYSCALL OPCODE
	FCB	READA:SCLEN	LENGTH OF SYSCALL BLOCK
	FCB	CI	CONSOLE INPUT CHANNEL
	FCB	1	LINE INPUT MODE
	FDB	IGNORED	WRITE BUFFER
	FDB	IGNORED	WRITE BUFFER LENGTH
	FDB	CHANGED	ACTUAL NUMBER OF BYTES READ
	FDB	NAMEBUFFER	READ BUFFER
	FDB	NAMEBUFFERL	READ BUFFER SIZE
	PAGE
MINIT	EQU	*
*
*	DO CHECKSUM OVER COMPILER
*
	LDX	#CODE
	CLRA		= SUM
CKSUML1	ADDA	,X+	SUM OVER METAMACHINE
	CPX	#METAMCODEEND
	BNE	CKSUML1
	LDX	METACODE	SUM OVER META INSTRUCTIONS
CKSUML2	ADDA	,X+
	CPX	DICT
	BNE	CKSUML2
	TFR	A,B	COMPUTE PROPER VALUE FOR CHECKSUM BYTE IN CASE IT'S WRONG
	NEGB
	ADDB	CHECKSUM
	STB	CHECKSUM
	TSTA		IS CHECKSUM CORRECT ?
	BNE	MINITDISPLAY	B/ CHECKSUM WRONG, GO DISPLAY BANNER AND DIE...
	IF	M6800!M6801
	LDB	#$01	= 6800/6801 NOP INSTRUCTION
	ELSE	(M6809)
	LDB	#$12	= 6809 NOP INSTRUCTION
	FIN
	STB	MINITCKFAULT	CHECKSUM IS OK, KILL THE FAULT DISPLAY LOGIC
	STB	MINITCKFAULT+1
	STB	MINITCKFAULT+2
*
*	DISPLAY THE BANNER
*
MINITDISPLAY	LDX	METACODE	GET POINTER TO BANNER STRING
	STX	METAPC	WE'LL NEED THIS LATER
	LDA	,X+	GET LENGTH OF THE BANNER
	STAA	HIMESSAGEL+1	AND PRINT OUT BANNER
	STX	HIMESSAGE+WRITEA:BUFFERP SAVE BANNER POINTER
	LDX	#HIMESSAGE
	JSR	CALLSYSCALL
MINITCKFAULT	JMP	CHECKSUMERROR	REPLACE BY NOPS IF CHECKSUM IS OK

	PAGE
MINITGO	EQU	*
*
*	ASK FOR THE INPUT FILE NAME AND OPEN IT UP
*
	LDX	#INPUTFILENAME	GIVE HIM THE PROMPT
	JSR	CALLSYSCALL
	LDX	#INPUTCONSOLE	READ HIS RESPONSE
	JSR	CALLSYSCALL
	LDX	INPUTCONSOLE+READA:ACTUALCOUNT GET RESPONSE LENGTH
	STX	OPENIFILE+OPEN:LENGTH
	LDX	#OPENIFILE	... AND OPEN THE INPUT FILE
	JSR	CALLSYSCALL
*
*	ASK FOR THE OUTPUT FILE NAME AND OPEN IT UP
*
	LDX	#OUTPUTFILENAME	GIVE HIM THE PROMPT
	JSR	CALLSYSCALL
	LDX	#INPUTCONSOLE	READ HIS RESPONSE
	JSR	CALLSYSCALL
	LDX	INPUTCONSOLE+READA:ACTUALCOUNT GET RESPONSE LENGTH
	STX	OPENOFILE+OPEN:LENGTH
	LDX	#OPENOFILE	... AND OPEN IT UP
	JSR	CALLSYSCALL
	PAGE
*
*	THIS BEGINS THE VARIABLE INITIALIZATION STUFF
*
	LDX	#INPUTBUFFER
	STX	FILLPOINTER
	STX	EMPTYPOINTER
	STX	SCANPOINTER
	LDX	#OUTPUTBUFFER
	STX	OUTPUTPOINTER
*
	CLRA
	STAA	NUMSTR	NO STACKED STRINGS
	STAA	OUTFLAG	ENABLE OUTPUT
	LDX	#0
	STX	INCLBL
	STX	LABGEN
	STX	CCODE
	STX	RECOVERYMETAPC
	LDX	#STATEVARS
	STX	STATEVARBASE
	STS	TEMPX	SEE IF ENOUGH STACK SPACE EXISTS
	LDD	TEMPX
	SUBB	DICT+1	(NOTE: THIS CANNOT BE OPTIMIZED FOR 6809)
	SBCA	DICT
	BCS	GAKDIE	you guess what this means...
	BEQ	GAKDIE	MUST HAVE AT LEAST 256 BYTES OF SLOP
	LDX	#DECODE
	STX	DECODEADD
	CLRA	SET UP THE METAPC
	LDAB	HIMESSAGEL+1	GET LENGTH OF HELLO MESSAGE
	ADDD	METAPC	FIND END OF BANNER STRING
	STD	METAPC
	LDX	KEYWORDCHAIN	NOW, ADD ALL THE KEYWORDS...
	BEQ	MINITDONE	(B/ NO KEYWORDS!)
KEYWORDINSERT	STX	SAVEX	TO THE TOKEN DICTIONARY
	LDAB	STRINGNODE:KEYLEN,X
	LEAX	STRINGNODE:BODY,X
	ANDB	#$7F	MASK OFF "KEYWORD" BIT
	JSR	COMPUTEHASH	FIGURE OUT THE PROPER BUCKET
	LDX	SAVEX	MAKE THIS KEYWORD POINT TO REST OF BUCKET C
	LDD	STRINGNODE:NEXT,X (AHA! FIRST, FIGURE OUT WHERE NEXT KEYWORD
	STD	TEMPX
	LDX	TOKENPOINTER	(THIS IS SET BY COMPUTEHASH)
	LDD	STRINGNODE:NEXT,X
	LDX	SAVEX
	STD	STRINGNODE:NEXT,X
	LDX	TOKENPOINTER	MAKE BUCKET HEAD POINT TO KEYWORD MODE
	LDD	SAVEX
	STD	STRINGNODE:NEXT,X
	LDX	TEMPX	NOW, GET NEXT KEYWORD ADDRESS AND GO INSERT
	BNE	KEYWORDINSERT
MINITDONE	JMP	METAINCPC	ALL DONE, FIRE UP THE META MACHINE

GAKDIE	JMP	ERRCALLSTKOVFLW	AND WE DIDN'T EVEN GET STARTED!
METAMCODEEND	EQU	*

NAMEBUFFER	EQU	*
	RPT	80
	FCB	0
NAMEBUFFERL	EQU	*-NAMEBUFFER
	PAGE
******** THIS CHUNK OF STUFF GETS ERROR DISPLAY ON FIRST LINE TO WORK RIGHT ***
	IF	*+1<<INPUTBUFFER+INPUTBUFFERSIZE
	ORG	INPUTBUFFER+INPUTBUFFERSIZE-1
	FIN
	FCB	ASCII:CR	THIS MAKES ERROR ON FIRST SOURCE LINE PRINT
**************************************************************
INPUTBUFFEREND	EQU	*
OUTPUTBUFFER	EQU	INPUTBUFFEREND
OUTPUTBUFFEREND	EQU	EST:METAMSIZE
OUTPUTBUFFERSIZE	EQU	OUTPUTBUFFEREND-OUTPUTBUFFER
	IF	OUTPUTBUFFERSIZE<<50
	? OUTPUT BUFFER LENGTH TOO SMALL FOR EFFICIENT OPERATION ?
	FIN
METAMEND	EQU	OUTPUTBUFFEREND
	IF METAMEND>>EST:METAMSIZE
	?METAMACHINE SIZE ESTIMATE EXCEEDED?
	FIN
	PAGE
	ORG	METAMEND	A GOOD PLACE TO START THE META PROGRAM
DEBLANKTOKEN	RMB	3	JMP TO DEBLANK TOKEN RECOGNIZER
ERRORTOKEN	RMB	3	JMP TO ERROR RECOVERY TOKEN BUSTER
KEYWORDTOKEN	RMB	3	JMP TO KEYWORD TOKEN BUSTER
DICT	RMB	2	INITIALLY POINTS TO END +1 OF META PROGRAM
KEYWORDCHAIN	RMB	2	POINTER TO CHAIN OF KEYWORDS
METACODE	RMB	2	POINTER TO INITIAL META CODE (BANNER MESSAGE
*
*	29 TOKENS
*	576 SUBROUTINES
*
TOKENADD	RMB	29*2	POINTERS TO TOKEN BUSTING ROUTINES
SUBRADD	RMB	(64+256+256)*2	POINTERS TO PARAMETERIZED SUBROUTINES
STATEVARS	RMB	0	UP TO 256 STATE VARIABLES
	END	BEGIN	WHAT DID YOU EXPECT?
