TOP;METATERP 8086 IMPLEMENTATION UNDER CP/M
;PROGRAMMED BY A. L. BENDER, M. D.
PARAMETER KEF=026;CP/M END OF FILE
PARAMETER KHT=009;HORIZONTAL TAB
PARAMETER KQM=039;QUOTE MARK
PARAMETER KEL=013;CARRIAGE RETURN CODE
PARAMETER KNL=010;LINE FEED
;COPYRIGHT (C) W.A.GALE
BYTE AA;ALL LOW DOUBLE LETTERS ARE TEMPORARY VARIABLES
BYTE BB
BYTE BO(080);OUTPUT STRING
BYTE C0;NUMBER 0
BYTE C1;NUMBER 1
BYTE C2;NUMBER 2
BYTE C3;NUMBER 3
BYTE C9;NUMBER 9
BYTE CB;BLANK
BYTE CC
BYTE CD;'.' DOT
BYTE CE;'/' ESCAPE FOR NUMBERS
BYTE CG;'>'
BYTE CL;'<'
BYTE CM;'-'
BYTE CP;'+'
BYTE CQ;'''
BYTE CS;'*'
BYTE CT;HORIZONTAL TAB
BYTE CU;'='
BYTE CV;NUMBER 25
BYTE CX;'!'
BYTE DD
BYTE DS(010);DIGIT STACK FOR WRITING NUMBERS
BYTE EE
BYTE EF;CP/M END OF FILE CODE (CTL-Z)
BYTE EL;CARRIAGE RETURN CODE
BYTE F1(128);INPUT BUFFER
BYTE F2(128);OUTPUT BUFFER
BYTE FL;FLAG FOR TRUE AND FALSE JUMPS
BYTE KA;SPECIAL BYTE FOR TESTS IN KG ROUTINE
BYTE KB;SPECIAL BYTE FOR TESTS IN KG
BYTE KC;WRITE OUTPUT TO CRT TOO
BYTE KS(06000);PROGRAM MEMORY SPACE
BYTE LI;INSTRUCTION LENGTH
BYTE LL;LINE LENGTH DURING LOADING
BYTE MC(03000);SYMBOLIC MEMORY CHARACTER VECTOR
BYTE MK;MEMORY SIZE CELL
BYTE MN;DIMENSIONS OF NS LESS ONE
BYTE ND;NUMBER OF DIGITS FOR WRITING NUMBERS
BYTE NL;NEW LINE !!!! PARAMETERIZED SYSTEM DEPENDENT
BYTE NS(080);CIRCULAR INPUT BUFFER
BYTE OS(080);INPUT STRING
BYTE PB;POINTER INTO BO
BYTE PI;INDEX INTO RI
BYTE PL;POINTER INTO NS
BYTE PM;LOCUS IN NS WHERE INPUT NOT ACCEPTED
BYTE PN;COUNT OF SUBROUTINES LOADED
BYTE PO;POINTER INTO OS
BYTE QI;POINTER INTO RI
BYTE RC;COMMAND READ
BYTE RI(080);INSTRUCTION REGISTER
BYTE SD;STACK DIMENSIONS BOTH Y AND Z
BYTE WA;WORK IN PACK
BYTE WB;WORK IN PACK
BYTE X0;CHARACTER ZERO
BYTE X1; 1
BYTE X2; 2
BYTE X3; 3
BYTE X9; 9
BYTE XA; A
BYTE XB; B
BYTE XC; C
BYTE XD; D
BYTE XE; E
BYTE XF; F
BYTE XG; G
BYTE XH; H
BYTE XI; I
BYTE XJ; J
BYTE XK; K
BYTE XL; L
BYTE XM; M
BYTE XN; N
BYTE XO; O
BYTE XP; P
BYTE XQ; Q
BYTE XR; R
BYTE XS; S
BYTE XT; T
BYTE XU; U
BYTE XV; V
BYTE XW; W
BYTE XX; X
BYTE XY; Y
BYTE XZ; Z
BYTE YP;STACK POINTER
BYTE ZP;STACK POINTER
BYTE ZX;STORAGE FOR ERROR RECOVERY SYMBOL
;
;INTEGER STORAGE
;
INT I00;NUMBER 000
INT I01;NUMBER 001
INT I03;NUMBER 003
INT I10;NUMBER 10
INT I16;NUMBER 16
INT IAA;WORKING STORAGE
INT IBB;WORKING STORAGE
INT IBK;BLOCK NUMBER (FILE NUMBER)
INT ICC;WORKING STORAGE
INT IDD;WORKING STORAGE
INT ILB;POINTER INTO ILT
INT ILN;LINE NUMBER OF INPUT
INT ILT(01000);LOCATION TABLE FOR NUMBER LABELS
INT IMB;MEMORY BASE INDEX FOR CURRENT LEVEL
INT IMD;DIMENSION OF MC AND IMI
INT IMF;MEMORY FREE INDEX
INT IMI(03000);SYMBOLIC MEMORY INDEX VECTOR
INT IML;NUMBER OF LOCAL PARAMETERS PER MEMORY LEVEL
INT IMM;MAX MEMORY COUNTER
INT IMT;TOP OF FREE MEMORY, REST TAKEN BY CELL STACK
INT IMX;NULL MEMORY INDEX
INT IMZ;TEMP VBL FOR MEM SRCH
INT INL;NUMBER OF NUMERICAL LABELS
INT IPC;PROGRAM COUNTER INDEX TO CURRENT INSTRUCTION
INT IPL;CODE POINTER WHILE LOADING
INT IPR(010);REGISTER VECTOR
INT IPT;POINTER INTO IST SUBROO STACK
INT IRN;NUMBER RETURNED BY READ NUMBER ROUTINE
INT ISM;SYMBOL NUMBER OF INPUT
INT IST(00600);SUBROUTINE AND LABEL STACK
INT ITU;RESULT OF DIRECT FETCH
INT IUU;UNIQUE SYMBOL GENERATOR
INT IXX;WORK DURING NUMBER MANIP
INT IYS(080);Y STACK
INT IYY;WORK DURING NUMBER MANIP
INT IZC;ERROR PROGRAM COUNTER
INT IZS(080);Z STACK
INT IZT;ERROR STACK POINTER
BEGINMAIN(AC,IAV)
EL=+KEL
NL=+KNL
MS 'METATERP '
MS 'Ver 1.2  '
GOSUB CR
MS '8086 VERS'
MS 'ION FOR C'
MS 'P/M-86   '
GOSUB CR
MS 'COPYRIGHT'
MS ' 1984 A. '
MS 'L. BENDER'
MS ', M. D.  '
GOSUB IN; INITIALIZATION
GOSUB CR; DON'T DO UNTIL IN HAS EXECUTED
GOSUB RC; READ COMMANDS
GOSUB LI;LEXICAL INITIALIZATION
IPC=+00000
LOC 00
GOSUB GI
CC=RI(C0)
CHOOSE ON CC
CASE XL;LEXICAL ANALYSIS COMMANDS
	AA=PI==C1
	IF AA
		IF FL
			GOSUB LW;SEEK WHITE SPACE MOVE UP BASE
			ISM++;	INCREMENT SYMBOL COUNT
		ELSE
			PL=PM;RESET LOOK AHEAD POINTER
		ENDIF
	ELSE;LONGER THAN ONE
	CC=RI(C1)
	CHOOSE ON CC
	CASE XM;MATCH SPECIFIC STRING
		FL=+000
		BB=+002
		WHILE
			AA=BB<!PI
		ON AA
			AA=RI(BB)
			DD=NS(PL)
			AA=AA!=DD
			IF AA
				GOTO 99;NO MATCH
			ENDIF
			BB++
			GOSUB LA
		ENDWHILE
		FL=+001
		GOSUB LB
	CASE XI;ID TEST
		FL=+000
		CC=NS(PL)
		PO=+000
		GOSUB ZA
		WHILE
		ON AA;
			OS(PO)=CC
			PO++
			GOSUB LA
			CC=NS(PL)
			GOSUB ZA
			DD=AA
			GOSUB ZN
			AA=DD?AA
		ENDWHILE
		AA=PO==C0
		IF AA
			GOTO 99
		ENDIF
		GOSUB MS;SEARCH ALL LEVELS
		IPR(C0)=IAA
		FL=+001
	CASE XN;	POSITIVE INTEGER TEST
;			---------------------
		FL=+000
	IAA=I00
	WHILE
		CC=NS(PL)
		GOSUB ZN
	ON AA
		FL=+001
		IAA=IAA*I10
		CC=CC-X0
		IBB=CC
		IAA=IAA+IBB
		GOSUB LA
	ENDWHILE
	IPR(C0)=IAA
	CASE XH;	HEXADECIMAL NUMBER TEST
;			-----------------------
	FL=+000
	IAA=+00000
	WHILE
		CC=NS(PL)
		GOSUB ZH
	ON AA
		FL=+001
		IAA=IAA*I16
		IBB=CC
		IAA=IAA+IBB
		GOSUB LA
	ENDWHILE
	IPR(C0)=IAA
	CASE XQ;	STRING QUOTED BY
;			----------------
		DD=RI(C2)
			CC=NS(PL)
			PO=+000
			AA=CC==DD
			IF AA
				GOSUB LA
				WHILE
					CC=NS(PL)
					AA=CC!=NL
					BB=CC!=DD
					AA=AA&BB
				ON AA
					OS(PO)=CC
					PO++
					GOSUB LA
				ENDWHILE
				GOSUB LA
				AA=CC==NL
				IF AA
					ILN++
					ISM=I00
				ENDIF
				FL=+001
			ELSE
				FL=+000
			ENDIF
	DEFAULT;
		WRITE CC
		MS ' NOT LEX!'
		GOSUB CR
	ENDCHOOSE
	ENDIF; TWO LETTER COMMANDS
CASE XF;	FALSE JUMP
	IF FL
	ELSE
		GOTO 20
	ENDIF
CASE XP;	PRINT STRING GIVEN
	BB=+001
	WHILE
		AA=BB<!PI
	ON AA
		CC=RI(BB)
		BO(PB)=CC
		PB++
		BB++
	ENDWHILE
CASE XO;	OUT
	BB=+000
	WHILE
		AA=BB<!PB
	ON AA
		CC=BO(BB)
		BB++
		WRITE CC INTO F2
	ENDWHILE
	PB=+000

	AA=PI==C1
	IF AA
		WRITE EL INTO F2
		WRITE NL INTO F2
	ENDIF
CASE XX;	ERROR JUMP
	AA=PI==C1
	IF AA;JUST AN X
		IF FL
		ELSE
	LOC 98;
		MS 'ERROR AT '
		MS 'LINE NUM '
		IAA=ILN
		GOSUB PN
		MS ' SYMBOL  '
		IAA=ISM
		GOSUB PN
		WRITE CB
		GOSUB CR
		WHILE
			CC=NS(PL)
			AA=CC!=ZX;COMPARE TO SPECIAL CHARACTER
			BB=CC!=C0;AND EOF SIGNAL (CC=0)
			AA=AA&BB
		ON AA
			AA=CC==NL
			IF AA
				ILN++
				ISM=+00000
			ENDIF
			GOSUB LA;READ ONE MORE
			GOSUB LB;AND BRING UP REAR
		ENDWHILE;HAVE JUST READ SPECIAL CHARACTER
		BB=CC==C0
		IF BB;OR EOF CHARACTER
			MS 'END FILE '
			GOTO 21
		ENDIF
		GOSUB LA;NOW MOVE BEYOND ZX
		GOSUB LB
		GOSUB LW;EAT UP WHITE SPACE
		IPC=IZC;RESTORE PROGRAM COUNTER
		IPT=IZT;AND STACK POINTER
		FL=+001;TRUE
		ENDIF
	ELSE;A LONGER COMMAND
	CC=RI(C1)
	CHOOSE ON CC
	CASE XN;	WRITE LINE NUMBER INTO OUTBUF
		IAA=ILN
		GOSUB WN
	CASE XO;	WRITE OUTBUF TO ERROR OUTPUT
		BB=+000
		WHILE
			AA=BB<!PB
		ON AA
			CC=BO(BB)
			BB++
			WRITE CC
		ENDWHILE
		GOSUB CR
		PB=+000
	CASE XM;	MARK FOR ERROR RETURN
		IZC=IPC;SAVE CODE POSITION
		IZT=IPT;SAVE STACK POSITION
		ZX=RI(C2);AND SPECIAL CHARACTER TO READ THRU
	DEFAULT
	ENDCHOOSE
	ENDIF; X + LETTER
CASE XT;		TRUE JUMP
	IF FL
		GOTO 20
	ENDIF
CASE XG;		GOSUB LABEL MUST BE ALPHA
	WA=RI(C1)
	WB=RI(C2)
	IPT=IPT+I03
	IAA=+00597;STACK DEPTH-3
	AA=IAA<=IPT
	IF AA
		MS 'STACK OVE'
		MS 'R FLOW>>>'
		GOTO 98
	ENDIF
	IST(IPT)=IPC
	PACK(IPC,WA,WB)
	IAA=IPT
	IAA++
	IST(IAA)=I00
	IAA++
	IST(IAA)=I00
CASE XR;		RETURN
	IPC=IST(IPT)
	AA=IPT<!I03
	IF AA
		MS 'STACK UND'
		MS 'ERFLOW...'
		GOTO 98
	ENDIF
	IPT=IPT-I03
CASE XS;		SET
	AA=PI==C1
	IF AA

		FL=+001
	ELSE
		CC=RI(C1)
		CHOOSE ON CC
		CASE XF;	SET FALSE
			FL=+000
		CASE XC;	SET CHANGED
			FL=C1-FL
		DEFAULT;	SET ERROR
			MS 'SET ERROR'
			GOSUB CR
		ENDCHOOSE
	ENDIF
CASE XU;		UNIQUE NUMBER GENERATED AND STACKED
AA=PI==C1
IF AA;	THEN DO A LOT OF WORK
	IAA=IPT
	IAA++
LOC 10
	IBB=IST(IAA); CURRENT UNIQUE
	AA=IBB<!I01;	IE NEVER FILLED IN (YET)
	IF AA
		IUU++
		IBB=IUU
		IST(IAA)=IUU
	ENDIF
	IAA=IBB
	IPR(C0)=IAA
	GOSUB WN;	WRITE NUMBER INTO BUFFER
ELSE;	THIS IS A FETCH FROM U
	GOTO 22
ENDIF

CASE XC;		COPY INPUT

	BB=+000
	WHILE
		AA=BB<!PO
	ON AA
		CC=OS(BB)
		BO(PB)=CC
		PB++
		BB++
	ENDWHILE

CASE XV;		UNIQUE NUMBER 2

AA=PI==C1
IF AA;	THEN THIS IS TO GENERATE A NUMBER
	IAA=IPT
	IAA++
	IAA++
	GOTO 10;	IAA=>SECOND UNIQUE
ELSE;	JUST A FETCH...
	GOTO 22
ENDIF

CASE XM;		MEMORY OPERATIONS

	CC=RI(C1)
	CHOOSE ON CC
	
	CASE XS;	STACK MEMORY
		GOSUB MH
	CASE XP;	POP MEMORY
		GOSUB MP
	CASE XE;	DEFINE A CELL ON TOP
		GOSUB ME
		IPR(C0)=IAA
	CASE XQ;	QUERY
		GOSUB MS
		IPR(C0)=IAA
	CASE XC;	CREATE CELL
		GOSUB MC
		IPR(C0)=IAA
	CASE XD;	DESTROY CELL
		GOSUB MD
		IPR(C0)=IAA
	CASE XI;	INITIALIZE
		CC=RI(C2)
		GOSUB ZN
		IF AA
			MK=CC-X0
		ELSE
			MK=+002
		ENDIF
		GOSUB MI
	DEFAULT
		MS 'ILLEGAL M'
		MS 'EM OPN>>>'
		GOSUB CR
	ENDCHOOSE
CASE XJ;		JUMP UNCONDITIONAL - LABEL MUST BE NUMBER
LOC 20
	AA=RI(C1)
	BB=RI(C2)
	PACK(ILB,AA,BB)
	IPC=ILT(ILB)
CASE XE;		STOP HERE
LOC 21
	CLOSE F1
	CLOSE F2
	IAA=IMM;	MAXIMUM MEMORY USED
	GOSUB PN;	PRINT MAX MEMORY USAGE
	MS ' MAX MEM '
	MS 'USAGE.   '
	GOSUB CR
	MS 'PROGRAMME'
	MS 'D TERMINA'
	MS 'TION     '
	GOSUB CR
	STOP 0
DEFAULT;		LOOK FOR FETCH AND STORE INSTRUCTION
LOC 22
	QI=+000
	GOSUB FT
	GOSUB FI
	GOSUB ST
ENDCHOOSE
GOTO 00
LOC 99
	FL=+000
	GOTO 00
ENDMAIN

		SUB CK;		CHECK OPENED
AA=ER!=C0
IF AA
	MS 'CANT OPEN'
	IAA=IBK
	GOSUB PN
	GOSUB CR
	STOP 1
ENDIF
ENDSUB

		SUB CR;		CR/LF SUBROUTINE
	
WRITE EL
WRITE NL
ENDSUB

		SUB DS;		DIGIT STACK
AA=IAA<!I00
IF AA
	BB=+001
	IAA=-IAA
ELSE
	BB=+000
ENDIF
AA=IAA==I00
IF AA
	ND=C1
	DS(C0)=X0
ELSE
	ND=C0
	WHILE
		AA=I00<!IAA
	ON AA
		IYY=IAA/I10
		IBB=I10*IYY
		IXX=IAA-IBB
		IAA=IYY
		AA=IXX
		AA=AA+X0
		DS(ND)=AA
		ND++
	ENDWHILE
ENDIF
DS(ND)=CM;'-'
ND=ND+BB;	INCR ONLY IF MINUS
ENDSUB

		SUB FI;		FETCH INDIRECT
QI++
CC=RI(QI)
CHOOSE ON CC

CASE XM;	MEMORY FETCH
	QI++
	CC=RI(QI)
	GOSUB ZN
	IF AA
		BB=CC-X0
	ELSE
	LOC 11
	MS 'INDEX TO '
	MS 'MEM CELL '
	BB=+000
	ENDIF
AA=BB<!MK
IF AA
	IAA=BB
	IAA=IAA+ITU
	ITU=IMI(IAA)
	RETURN
ELSE
	BB=BB-MK
	AA=BB<!MK
	IF AA
		IAA=BB
		IAA=ITU+IAA
		AA=MC(IAA)
		ITU=AA
	ELSE
		GOTO 11
	ENDIF
ENDIF

CASE XS;		FETCH FROM STRING REGISTER

	AA=ITU
	BB=OS(AA)
	ITU=BB
DEFAULT
	QI--
ENDCHOOSE
ENDSUB
			SUB FT; FETCHES DIRECT
CC=RI(QI)
CHOOSE ON CC
CASE XY;		Y STACK
	ITU=IYS(YP)
CASE CX;		'!' POP Y STACK
	ITU=IYS(YP)
	GOSUB PY
CASE XZ;		Z STACK ALWAYS POP
	ITU=IZS(ZP)
	AA=ZP==C0
	IF AA
		MS 'Z STACKER'
		GOSUB CR
		ZP=+001
		FL=+000
	ENDIF
	ZP--
CASE XN;		LITERAL FETCH OF NUMBER
	QI++
	AA=RI(QI)
	QI++
	BB=RI(QI)
	PACK(ITU,AA,BB)
CASE XH;		FETCH HIGH OF STACK
	ITU=IYS(YP)
	UNPACK(ITU,AA,BB)
	ITU=AA
CASE XB;		FETCH BREDTH OF STRING
	ITU=PO
CASE XU;		FIRST STACK NUMBER
	IAA=IPT
LOC 38
	IAA++
	ITU=IST(IAA)
CASE XV;		SECOND STACK NUMBER
	IAA=IPT
	IAA++
	GOTO 38
DEFAULT;		NUMBER OR ERROR

	GOSUB ZN
	IF AA
		AA=CC-X0
	ELSE
		MS 'ILLEGAL F'
		MS 'ETCH OPN '
		GOSUB CR
		AA=+000
	ENDIF
	ITU=IPR(AA)
ENDCHOOSE
ENDSUB;	FT

			
			SUB GI;		GET INSTRUCTION
PI=+000
LI=KS(IPC)
IPC++
WHILE
	AA=PI<!LI
ON AA
	AA=KS(IPC)
	IPC++
	RI(PI)=AA
	PI++
ENDWHILE
ENDSUB;	GI

			SUB IN;		INITIALIZATION
KB=+000
KC=+000
ZX=+000
YP=+000
ZP=+000
C0=+000
FL=+000
PI=+000
PB=+000
PO=+000
PN=+000
IZC=+00000
IZT=+00000
I00=+00000
IPC=+00000
IPT=+00000
ILB=+00000
IUU=+00000
ISM=+00000
INL=+00000
C1=+001
C2=+002
MK=+002
I01=+00001
ILN=+00001
C3=+003
I03=+00003
C9=+009
CV=+025
EL=+KEL
NL=+KNL
EF=+KEF
I10=+00010
I16=+00016
SD=+080
MN=+079
XA='A'
XB='B'
XC='C'
XD='D'
XE='E'
XF='F'
XG='G'
XH='H'
XI='I'
XJ='J'
XK='K'
XL='L'
XM='M'
XN='N'
XO='O'
XP='P'
XQ='Q'
XR='R'
XS='S'
XT='T'
XU='U'
XV='V'
XW='W'
XX='X'
XY='Y'
XZ='Z'
X0='0'
X1='1'
X2='2'
X3='3'
X9='9'
CB=' '
CX='!'
CS='*'
CM='-'
CP='+'
CG='>'
CU='='
CL='<'
CT=+KHT;HORIZONTAL TAB
CE='/'
CD='.'
CQ=+KQM;QUOTE MARK
IBK=+00003;FILE 3
ASSOCIATE FCB 3 WITH IBK; ***CP/M DEPENDENT***
OPEN F2 FOR XW AT IBK;	OPEN OUTPUT FILE
GOSUB MI;	INITIALIZE MEMORY
ENDSUB;	IN
			SUB LA; L IS FOR LEX, A IS FOR AHEAD
AA=PL==MN;MAX FOR NS
IF AA
	PL=+000
ELSE
	PL++
ENDIF
ENDSUB;	LA
			SUB LB; MOVE UP THE BASE
WHILE
	AA=PL!=PM
ON AA
	GOSUB KG;READ CC FROM F1
	AA=ER!=C0
	IF AA
		CC=+000
	ENDIF
	NS(PM)=CC
	AA=PM==MN
	IF AA
		PM=+000
	ELSE
		PM++
	ENDIF
ENDWHILE
ENDSUB; LB
			SUB LI; INITIALIZE LEX
PM=+000
PL=+000
BB=+000
WHILE

	AA=BB<=MN
	CC=ER==C0
	AA=AA&CC
ON AA
	GOSUB KG;READ CC FROM F1; - SPECIAL READ FOR CP/M
	NS(BB)=CC
	BB++
ENDWHILE
ENDSUB; LI
			SUB LW; TEST AND  DISCARD WHITE SPACE
CC=NS(PL)
WHILE
	AA=CC==NL
	IF AA
		ILN++
		ISM=+00000
	ENDIF
	BB=CC==CB
	AA=AA?BB
	BB=CC==CT
	AA=AA?BB
	BB=CC==EL
	AA=BB?AA
ON AA
	GOSUB LA
	CC=NS(PL)
ENDWHILE
GOSUB LB
ENDSUB; LW
			SUB MC; CREATE CELL AT THTE TOP
IAA=MK
IMT=IMT-IAA
GOSUB MO;CHECK FOR OVERFLOW
IAA=IMT;POINT TO CELL
GOSUB MZ;ZERO IT
ENDSUB; MC
			SUB MD; DESTROY CELL
IAA=MK
IMT=IMT+IAA;RAISE TOP BY CELL SIZE
AA=IMD<!IMT
IF AA
	MS 'DESTROY C'
	MS 'ELL ERROR'
	GOSUB CR
ENDIF
IAA=IMT
ENDSUB; MD
			SUB ME; ENTER INTO TOP LEVEL
;RETURNS IAA AS INDEX TO CELL
GOSUB ML;	SEARCH TOP LEVEL
EE=IAA!=I00;	FOUND IT HERE
IF EE
	RETURN
ENDIF
IMI(IBB)=IMF;	IBB FROM ML, STORE TO SHOW THIS OPTION
WHILE
	MC(IMF)=CC; CC FROM ML ONCE
	IMI(IMF)=IMX; NO ALTERNATIVES NOW
	IMF++
	GOSUB MO;	CHECK OVERFLOW
	AA=CC!=C0;	NOT LAST CHARACTER
ON AA
	BB++;	BB FROM ML TO START
	CC=OS(BB)
ENDWHILE
IAA=IMF
IDD=MK
IMF=IDD+IMF
GOSUB MO
GOSUB MZ
ENDSUB; ME
			SUB MH; PUSH A NEW LEVEL
IMI(IMF)=IMB;	POINT TO CURRENT BASE
IMB=IMF
IMF=IMF+IML
MC(IMF)=C0
IMI(IMF)=I00
ENDSUB; MH
			SUB MI; MEMORY INITIALIZE
IMB=+00000
IMM=+00000
IMD=+03000; DIMENSION OF MC AND IMI
IMT=IMD
IML=+00001
IMF=IMB+IML
IMX=+00000
IMI(IMB)=I00
MC(IMF)=C0
IMI(IMF)=I00
ENDSUB; MI
			SUB ML; LEVEL SEARCH PATTERN ENDS WITH NULL
IBB=IMB+IML;		FIRST CHAR IN MEMORY
BB=+000;		SUBSCRIPT FOR PATTERN
WHILE
	CC=OS(BB);	PATTERN CHARACTER
	DD=MC(IBB);	MEMORY CHARACTER
	EE=CC==DD;	MATCH
	IF EE;		MATCHING?
		EE=CC==C0;	END OF STRING SIGNAL
		IF EE;		ENTIRE MATCH?
		IAA=IBB+I01;
		GOTO 77
		ENDIF
		IBB++
		BB++
	ELSE;		FAILED
		IAA=IMI(IBB)
		EE=IAA==IMX
		IF EE;	END OF THE ROAD
			IAA=+00000
			GOTO 77
		ENDIF
		IBB=IAA
	ENDIF
	EE=IBB<!IMF
ON EE
ENDWHILE
IAA=+00000;	FAILED TO FIND BELOW FREE MARKER
LOC 77
ENDSUB; ML
			SUB MO;	CHECK FOR MEMORY OVERFLOW
AA=IMT<!IMF
IF AA
	MS 'OUT OF ME'
	MS 'MORY ERR.'
	STOP 3
ENDIF
AA=IMM<!IMF
IF AA
	IMM=IMF;	MAXIMUM MEMORY IN USE
ENDIF
ENDSUB; MO
			SUB MP; POP A LEVEL
AA=IMB!=I00
IF AA
	IMF=IMB
	IMB=IMI(IMB)
ELSE
	IMF=IML
	MC(IMF)=C0
	IMI(IMF)=I00
ENDIF
ENDSUB; MP
			SUB MS; SEARCH ALL LEVELS
OS(PO)=C0

IMZ=IMB
WHILE
	GOSUB ML
	EE=IAA==I00
	IMB=IMI(IMB)
	DD=IMB!=I00
	CC=EE&DD
ON CC
ENDWHILE
IMB=IMZ; TO TOP LEVEL
ENDSUB; MS
			SUB MZ; ZERO A MEMORY CELL
BB=+000
IDD=IAA;	RETAIN POINTER TO CELL
WHILE
	AA=BB<!MK
	BB++
ON AA
	MC(IDD)=C0
	IMI(IDD)=I00
	IDD++
ENDWHILE
ENDSUB; MZ
			SUB PN; PRINT NUMBER ON THE TERMINAL
GOSUB DS;	STACK THE DIGITS
WHILE
	IBB=ND
	AA=I00<!IBB
ON AA
	ND--
	AA=DS(ND)
	WRITE AA
ENDWHILE
WRITE CB
ENDSUB; PN
			SUB PY; POP Y STACK
AA=YP==C0
IF AA
	MS 'Y STACKER'
	GOSUB CR
	YP=C1
	FL=+000
ENDIF
YP--
ENDSUB; PY
			SUB RA; READ ALPHA LABEL
;FIRST COPY LABEL TO STRING INDEX
OS(C0)=CC
PO=+001
WHILE
	GOSUB KG;READ CC FROM F1
	GOSUB ZA
	DD=AA;SAVE THE RESULT
GOSUB ZN;ALLOW EITHER ALPHA OR NUMERIC AFTER FIRST ALPHA
	AA=AA?DD
ON AA

	OS(PO)=CC
	PO++
ENDWHILE
;NOW, EAT UP LINE
AA=CC==NL
IF AA
ELSE
	WHILE
		GOSUB KG;READ CC FROM F1
		AA=CC!=NL
	ON AA
	ENDWHILE
ENDIF
ENDSUB;	RA

		SUB RC; READ COMMANDS
CLOSE F1
IBK=+00001;	FILE #1 IN TBUFF
ASSOCIATE FCB 1 WITH IBK;	*** CPM SENSITIVE ***
OPEN F1 FOR XR AT IBK;	BUFFER1/FILE1/READ
GOSUB CK;	DID FILE OPEN OK
IPC=+00001
LL=+000
IPL=+00000
WHILE
AA=AA; DUMMY TO FIX LABELING ERROR IN MACRO GENERATOR
LOC 67;
	READ RC FROM F1
	AA=RC==EL;
	IF AA
		GOTO 67
	ENDIF
LOC 33
	AA=ER==C0
ON AA
	CHOOSE ON RC
	CASE CE; '/' NUMBER FOLLOWS
		GOSUB KG;READ CC FROM F1
		AA=CC==CM;'-'
		IF AA; MINUS SIGN
			GOSUB KG;READ CC FROM F1
			GOSUB RN;READ NUMBER
			IRN=-IRN;INVERT IT
			GOTO 37
		ENDIF
		GOSUB ZN
		IF AA
			GOSUB RN;READ NUMBER
		LOC 37;
			UNPACK(IRN,AA,BB)
			KS(IPC)=AA
			IPC++
			LL++
			KS(IPC)=BB
			IPC++
			LL++
			RC=CC
			AA=RC==CB
			IF AA
			ELSE
				GOTO 33
			ENDIF
		ELSE
			KS(IPC)=CE
			IPC++
			LL++
			RC=CC
			GOTO 33
		ENDIF
	CASE NL;	END OF COMMAND
		KS(IPL)=LL; PUT THE LENGTH OF THE INSTRUCTION AT THE FRONT!
		IPL=IPC
		IPC++
		LL=+000
	CASE CD;	'.' LABEL FOLLOWS
		AA=LL==C0
		IF AA
			GOSUB RL
			RC=NL
			IPC--
			GOTO 33
		ELSE
			GOTO 35
		ENDIF
	CASE XG;	IF AT BEGINNING, A GOSUB TO COMPILE
		AA=LL==C0
		IF AA
			GOSUB KG;READ CC FROM F1
			GOSUB RA;	READ ALPHA LABEL
			OS(PO)=C0
			GOSUB ME;	FIND OR DEFINE
			IRN=IMI(IAA);	DEFINED VALUE
			AA=IRN==I00
			IF AA
				IRN=IAA;	NOT YET DEFINED
				KS(IPC)=NL;	SET WARNING
			ELSE
				KS(IPC)=RC;	WAS DEFINED, VALUE FILLED
			ENDIF
			IPC++
			UNPACK(IRN,AA,BB)
			KS(IPC)=AA
			IPC++
			KS(IPC)=BB
			IPC++
			LL=C3
			RC=NL
			GOTO 33
			ELSE
			GOTO 35
			ENDIF
		CASE EL; THIS IS TO THROW AWAY THE 0DH CODE BEFORE LF
		;DO NOTHING
		DEFAULT;	ACCEPT
		LOC 35
		KS(IPC)=RC
		IPC++
		LL++
		ENDCHOOSE
	ENDWHILE
;HAVE REACHED END
IPC--

AA=ER!=C1
IF AA;NO, AN ERROR
	MS 'CANT READ'
	MS ' COMMANDS'
	GOSUB CR
	STOP 1
ENDIF
CLOSE F1
IBK=+00002
ASSOCIATE FCB 2 WITH IBK
OPEN F1 FOR XR AT IBK
GOSUB CK
;PATCH ALL THE UNDEFINED GOSUBS
IAA=+00000
WHILE
	AA=IAA<!IPC
ON AA
	LL=KS(IAA)
	IBB=IAA+I01
	AA=KS(IBB);THE COMMAND
	AA=AA==NL
	IF AA;A GOSUB NEEDING PATCH
		KS(IBB)=XG
		IBB++
		AA=KS(IBB);GET INDEX TO DEFINE
		IBB++
		BB=KS(IBB)
		PACK(IRN,AA,BB)
		BB=MC(IRN)
		AA=BB!=C1
		IF AA;THE SUB WASN'T DEFINED, WE DON'T KNOW NAME
			ICC=IRN-I10
			WHILE
				AA=ICC<!IRN
			ON AA
				BB=MC(ICC)
				WRITE BB
				ICC++
			ENDWHILE
			WRITE CB
			MS 'SUB UNDEF'
			GOSUB CR
		ENDIF
		ICC=IMI(IRN)
		UNPACK(ICC,AA,BB);ICC=REAL LOC OF SUB
		KS(IBB)=BB;STORE IT
		IBB--
		KS(IBB)=AA
	ENDIF
	IBB=LL
	IAA=IAA+IBB
	IAA=IAA+I01
ENDWHILE
GOSUB MP;POP MEMORY, FORGET NAMES
IAA=IPC
GOSUB PN
MS 'CMD BYTS '
IAA=INL
GOSUB PN
MS 'NUM LABS '
IAA=PN
GOSUB PN
MS 'SUBROUTIN'
GOSUB CR
ENDSUB;	RC
		SUB RL;	READ LABEL
;FIRST DISCARD ANY ALPHANUMERICS
WHILE
	GOSUB KG;READ CC FROM F1
	GOSUB ZA
	IF AA
		GOTO 80;ALPHA LABEL
	ENDIF
	GOSUB ZN
	IF AA
		GOTO 85;NUMBER LABEL
	ENDIF
	AA=CC!=NL;IF NO LABEL, NO ACTION
ON AA
ENDWHILE
RETURN
LOC 80;ALPHA LABEL
GOSUB RA;READ ALPHA LABEL
OS(PO)=C0
GOSUB ME; SEARCH MEMORY
IMI(IAA)=IPL;SAVE VALUE
MC(IAA)=C1;MARK DEFINED
PN++;COUNT SUBROUTINES
RETURN
LOC 85;NUMBER LABEL
INL++
GOSUB RN;READ A NUMBER
ILT(IRN)=IPL
ENDSUB;	RL
			SUB RN;READ A NUMBER
IRN=+00000
WHILE
	CC=CC-X0
	IAA=CC
	IRN=IRN*I10;	CONVERT TO BINARY
	IRN=IRN+IAA
	GOSUB KG;READ CC FROM F1
	GOSUB ZN
ON AA
ENDWHILE
ENDSUB;	RN
			SUB ST; STORE A NUMBER
QI++
CC=RI(QI)
CHOOSE ON CC
CASE XY;	Y STACK
	YP++
	AA=SD<=YP
	IF AA
		MS 'Y OVERFLW'
		GOSUB CR
		YP=SD
		FL=+000
	ENDIF
	IYS(YP)=ITU
CASE XZ;	Z STACK
	ZP++
	AA=SD<=ZP
	IF AA
		MS 'Z OVERFLW'
		GOSUB CR
		ZP=SD
		FL=+000
	ENDIF
	IZS(ZP)=ITU
CASE CP;	"+" ADD TO S
	IAA=IYS(YP)
	IAA=IAA+ITU
	IYS(YP)=IAA
CASE CM;	"-" SUBTRACT FROM TOP OF STACK
	IAA=IYS(YP)
	IAA=IAA-ITU
	IYS(YP)=IAA
CASE CS;	"*" MULTIPLY TOP OF STACK BY TO USE
	IAA=IYS(YP)
	IAA=IAA*ITU
	IYS(YP)=IAA
CASE CG;	">" GREATER - SET FLAGS ACCORDINGLY
	IAA=IYS(YP)
	AA=IAA<!ITU
LOC 12;
	IF AA
		FL=+001;	T R U E
	ELSE
		FL=+000;	F A L S E
	ENDIF
	GOSUB PY;	POP Y STACK
CASE CL;	"<" LESS THAN - SET FLAGS
	IAA=IYS(YP)
	AA=ITU<!IAA
	GOTO 12
CASE CU;	"=" EQUAL
	IAA=IYS(YP)
	AA=ITU==IAA
	GOTO 12
CASE XI;	INDIRECT TO MEMORY
	QI++
	DD=RI(QI)
	IBB=ITU
	QI++
	GOSUB FT
	CC=DD
	GOSUB ZN
	IF AA
		BB=CC-X0;	REMOVE ASCII BIAS
	ELSE
	LOC 13;
		MS 'BAD INDIR'
		MS 'ECT INDEX'
		GOSUB CR
		BB=+000
	ENDIF
	AA=BB<!MK
	IF AA
		IAA=BB
		IAA=ITU+IAA
		IMI(IAA)=IBB
		RETURN
	ELSE
		BB=BB-MK
		AA=BB<!MK
		IF AA
			IAA=BB
			IAA=IAA+ITU
			AA=IBB
			MC(IAA)=AA
		ELSE
			GOTO 13
		ENDIF
	ENDIF
CASE XC;	CONVERT NUMERIC TO STRING, WRITE IT OUT
	IAA=ITU
	GOSUB WN
CASE XL;	WRITE LOW BYTE OF FETCHED TO OUTPUT BUFFER
	AA=ITU
	BO(PB)=AA
	PB++
CASE XA;	APPEND LOW BYTE OF FETCHED TO STRING BUFFER
	AA=ITU
	OS(PO)=AA
	PO++
	OS(PO)=C0
CASE XB;	SET LENGTH OF STRING BUFFER
	PO=ITU
	OS(PO)=C0
CASE XG;	SET GENERATOR
	IUU=ITU
CASE XU;	FIRST STACK NUMBER
	IAA=IPT
LOC 39;
	IAA++
	IST(IAA)=ITU
CASE XV;	SECOND STACK NUMBER
	IAA=IPT
	IAA++
	GOTO 39
CASE XD;	DUMP IT, NULL OPERATION
CASE XH;	WRITE LOW BYTE IN HEX
	AA=ITU
	ITU=AA
	IAA=ITU/I16;	HIGH HEX DIGIT
	IBB=IAA*I16;	FANCY MASKER
	IBB=ITU-IBB;	LOW HEX DIGIT
	CC=IAA
	GOSUB WH
	CC=IBB
	GOSUB WH;	WRITE HEX DIGITS
DEFAULT;	NUMBER OR ERROR
	CC=RI(QI)
	GOSUB ZN
	IF AA
		AA=CC-X0
	ELSE
		MS 'ILLEGAL S'
		MS 'TORE ATMP'
		GOSUB CR
		AA=+000
	ENDIF
	IPR(AA)=ITU
ENDCHOOSE
ENDSUB;	ST
			SUB WH; WRITE HEX DIGIT TO OBUFF
AA=CC<=C9
IF AA
	CC=CC+X0
ELSE
	CC=CC+XA
	CC=CC-C9
	CC=CC-C1
ENDIF
BO(PB)=CC
PB++
ENDSUB;	WH
			SUB WN; WRITE NUMBER INTO OBUFF
GOSUB DS;	STACK THE DIGITS
WHILE
	IBB=ND
	AA=I00<!IBB
ON AA
	ND--
	AA=DS(ND)
	BO(PB)=AA
	PB++
ENDWHILE
ENDSUB;	WN
			SUB ZA;	ALPHA TEST CC ASSUMES LINEAR MONOTONIC
AA=CC-XA
BB=XZ-CC;IZIT A TO Z?
AA=AA<=CV
BB=BB<=CV
AA=AA&BB
ENDSUB;	ZA
			SUB ZH; TEST AND CONVERT HEX DIGIT
AA=X0<=CC
BB=CC<=X9
AA=AA&BB
IF AA
	CC=CC-X0
	RETURN
ENDIF
AA=XA<=CC
BB=CC<=XF;	CHECK 0-9, A-F
AA=AA&BB
IF AA
	CC=CC-XA
	BB=+010
	CC=CC+BB
	RETURN
ENDIF
ENDSUB;	ZH AA IS FALSE HERE
			SUB ZN;	CC IS A NUMBER
AA=CC-X0
BB=X9-CC
AA=AA<=C9
BB=BB<=C9
AA=AA&BB
ENDSUB
			SUB ZW;	CC IS WHITE SPACE
AA=CC==CB;BLANK
BB=CC==CT;TAB
AA=AA?BB;EITHER?
BB=CC==EL;RETURN
AA=AA?BB
BB=CC==NL;NEW LINE (LF)
AA=AA?BB
ENDSUB;	ZW
			SUB KG; READ CC FROM FILE 1 - DISCARD C/R
READ CC FROM F1;	READ A CHARACTER
KA=CC==EL
	IF KA
	READ CC FROM F1;	IF LAST CHARACTER WAS C/R
	ENDIF
ENDSUB;	KG
BOTTOM