.H			Copyright (c) 1996, Gary D. Campbell
NAME =MORE	PREP,BODY,BACK,USAGE
$$$$ CODE=01200
0000 PARMS	(32)	   ------------ PTRAN -------------
1200 PRIMITIVES ENTRY	+  indicates "Emits Token"
1200		=@P.A	+  [space] alpha [alpha|.|digit]..
1202		=@P.B	   S: Wrapup Prep, F: Initialize for Match(Body)
1204		=@P.C	   handle continuation, always Succeed
1206		=@P.D	   bump SI past spaces, AF=0
1208		=@P.E	   RETURN: IF EndLine (AA=0); ELSE (NotEndLine CY=1).
120A		=@P.F	+  [space] match file characters
120C		=@P.G	+  [space] match 'arb' or "arb" (arb=notany(CR))
120E		=@P.H	+  [space] stopshort('"',"'|]",space,CR,lowercase)
1210		=@P.I	+  [space] alpha notany(alpha|.|digit)
1212		=@P.J	   Initialize Match(Prep), S: comment or null line.
1214 :
1214 : ALL PRIMITIVES HAVE 3 CHOICES (NOTE: $SP=RTN to SUC.MORE or DO.MORE):
1214 : 1. Emit a Token: CALL ERR.xx; =err,pfx; SI=BeginMatch; AA=Length
1214 : 2. Emit no Token: RTN SI=Match+1, AA=0
1214 : 3. Fail via CALL GET.RETRY; =err; (directly to SUC.MORE or DO.MORE)
1214 :
1214 CK.BYTE	A=$SI+		RETURN	SI=SI+1 only if 1 space skipped
1215*		A:" "			EQ: stopshort(space,space)
1217		IF EQ,			LT: $SI = control character
1219			A=$SI		GT: $SI = notany(space)
121B*			A:" "
121D		*	IF NE,EXIT
121F		ELSE	SI=(SI-1)
1222 RTN:	RETURN
1223 CK.A.NUM	CALL CK.DEC.A
1226		IF NC,GOTO RTN
1228*CK.ALPHA	A:"z"+1
122A		IF LT,
122C*			A:"a"
122E			RETURN
122F.RTN.CY:	CY=1
1230		RETURN
1231+FOLLOW.ON	SI=SI+1
1232		A=$SI
1234*		A:"."
1236		IF NE,GOTO CK.A.NUM
1238		PUSH SI
1239		CALL FOLLOW.ON
123C		POP SI
123D		RETURN
123E CK.DEC	A=$SI+		RETURN:
123F*CK.DEC.A	A:"9"+1 		NC if in range 0-9
1241		IF GE,GOTO RTN.CY	CY if outside this range
1243*		A:"0"
1245		RETURN
1246 ERR.CY	IF NC,			IF EITHER AA=SI or CY=1
1248 ERR.ZR		SWAP AA,SI	THEN GOTO GET.RETRY
1249*			AA=AA-SI	ELSE (AA>SI)
124B			IF NZ,		AA=Length, SI=@Source, CY=0
124D				POP HL
124E				CS:	L=$(HL+1)	Get Token pfx Code
1252				SWAP AA,HL
1253				$DI+=A			Emit it.
1254				SWAP AA,HL		Let SUC emit the
1255				RETURN	(back to SUC)	rest of the Token.
1256		GOTO GET.RETRY
.P
1259 P.A	CALL CK.BYTE	[space] alpha [follow.on]..
125C		PUSH SI
125D		CALL CK.ALPHA
1260		IF NC,
1262			DO	CALL FOLLOW.ON
1265			LOOP WHILE NC
1267.			CY=0
1268		POP AA
1269		CALL ERR.CY
126C		="AA"		Error in an Alpha.numeric
126E P.B	PUSH SI
126F		AA=%(SI+4)	This primitive
1272*		A:"="			SUCCEEDS if column (5,6) is "="
1274		IF NE,			and FAILS otherwise.
1276*			A':"="
1279		IF EQ,
127B			SI=(SI+5)
127E		POP AA
127F		CALL ERR.ZR
1282		="BB"
1284 P.C	PUSH SI
1285		CALL CK.BYTE	THIS PRIMITIVE CAN'T FAIL
1288		IF LT,		IT CHECKS FOR AND HANDLES CONTINUATION
128A*			A:CR	It advances SI & returns AF=0.
128C		IF EQ,
128E			DO	CALL COMMENT.C	(CY-->End-of-File)
1291		*		IF CY,NEXT	(NC,ZR-->Comment)
1293			LOOP WHILE ZR		(NC,NZ-->Next Statement)
1295			CS:	AA=%OBJECT	(comments are skipped)
1299			CALL WRITE.HEX
129C*			%SI:"  "
12A0		*	IF EQ,EXIT
12A2		ELSE	POP SI
12A3*RTN.ZR:		AA=0		AA=0,SI++ causes Success
12A5			RETURN		& No Object Token
12A6		POP AA
12A7 P.D	DO	A=$SI+		THIS PRIMITIVE CAN'T FAIL
12A8*			A:" "		It bumps SI past ALL Spaces
12AA		LOOP WHILE EQ		& returns AF=0.
12AC+		SI=SI-1
12AD		GOTO RTN.ZR
12AF P.E	CALL B.SOURCE		THIS PRIMITIVE MATCHES SP,SP | CR
12B2+		SI=SI-1
12B3		IF NC,GOTO RTN.ZR	(otherwise it fails)
12B5		CALL GET.RETRY
12B8		="E"			End-of-Statement Error
.P
12B9 P.F	CALL CK.BYTE	[space] match file characters
12BC		PUSH SI 	Save index of 1st byte
12BD		DO	CALL FILE.CHR
12C0*			A'=A' XOR 5
12C3		LOOP UNTIL NE		check bytes until 1 byte too many
12C5+		SI=SI-1 		BACKUP 1
12C6		POP AA			(NC, let ERR.CY detect FAIL=Null)
12C7		CALL ERR.CY
12CA		="FF"
12CC P.G	CALL CK.BYTE	[space] match Quote Arb Quote
12CF		PUSH SI 		"any string" or 'any"string'
12D0*		A:'"'			(must be " inside 'quotes')
12D2		IF NE,
12D4*			A:"'"
12D6			L=0			L=0 flags an error
12D8		*	IF NE,EXIT
12DA		ELSE	A'=A			L>0 if A = "
12DC+			SI=SI+1
12DD			DO	A=$SI+
12DE*				A:A'
12E0		*		IF EQ,EXIT	(LEN = string content + 2)
12E2*				A:'"'
12E4				IF EQ,
12E6					L=A	(flag '.."..' string OK)
12E8*				A:CR
12EA			LOOP UNTIL EQ
12EC			L=0			FAIL due to premature EOL
12EE*		L:0
12F0		POP AA
12F1		IF EQ,
12F3			SI=AA
12F5		CALL ERR.ZR		Q = Quote Error
12F8		="QG"
12FA P.H	CALL CK.BYTE	[space]
12FD		PUSH SI 	stopshort('"',"'|]",space,CR,lowercase)
12FE		DO	A=$SI+
12FF*			A:" "
1301		*	IF EQ,EXIT
1303*			A:7B
1305			IF LT,
1307*				A:061
1309		*		IF GE,EXIT
130B*			A:"["
130D		*	IF EQ,EXIT
130F*			A:"|"
1311		*	IF EQ,EXIT
1313*			A:"]"
1315		*	IF EQ,EXIT
1317*			A:"'"
1319		*	IF EQ,EXIT
131B*			A:'"'
131D		*	IF EQ,EXIT
131F*			A:CR
1321		LOOP UNTIL EQ
1323+		SI=SI-1
1324		POP AA
1325		CALL ERR.CY
1328		="KH"			K = Keyword content error
.P
132A P.I	CALL CK.BYTE
132D		PUSH SI
132E*		A:"z"
1330		IF LE,
1332*			A:"a"
1334		*	IF LT,EXIT
1336			CALL FOLLOW.ON
1339.			CY=~CY
133A		POP AA
133B		CALL ERR.CY		a = alpha primitive error
133E		="aI"
1340 P.J	CALL COMMENT.J	This is the FIRST ALTERNATIVE OF PREP.
1343		IF LE,		RETURN SUCCESS IF <comment> or EOF
1345*			AA=0
1347			RETURN			(Success)
1348		PUSH SI
1349		AA=%(SI+4)	NE-->looking at BeginLine > 6.
134C*		A:"="			(check for "=" in col 5/6)
134E		IF NE,		The following ALWAYS FAILS, since SI
1350*			A':"="			is not bumped.
1353		*	IF NE,EXIT
1355		ELSE	HL=@CK.LIST-4		Here we "fixup" all
1358			A=$SI			"prep" statements.
135A*			A=A AND 5F		This means rewriting
135C			DO	HL=(HL+4)	columns 1-4 if there
135F*				CS:	$(HL+4):0	is an "=" in
1364			*	IF EQ,EXIT		column 5 or 6.
1366*				CS:	A:$HL
1369			LOOP UNTIL EQ
136B			CS:	AA=%HL
136E			%SI=AA
1370			CS:	AA=%(HL+2)
1374			%(SI+2)=AA
1377*			$(SI+5):"="
137B			IF EQ,
137D				$(SI+4)=" "
1381		POP AA
1382		CALL ERR.ZR
1385		="=J",39*0
.P
13AE COMMENT.C	CALL SKIP.CR
13B1		IF ZR,
13B3+			SI=SI-2
13B5 COMMENT.J	CALL EOF.COUNT		Come here FROM: P.C & P.J
13B8*		AA:8			WITH:	SI = <begin statement>
13BB		IF GE,			NEED:	SI < CR,LF CY,NE <EOF>
13BD			AA=%SI		else,	SI = same, NC,NE <GoodLine>
13BF*			AA:"<<" 		SI < final CR,LF <comment>
13C2			IF EQ,				(NC,EQ)
13C4+				DO	SI=SI+1 	Always RETURN AA=0.
13C5*					SI:-16		(SI:65520)
13C8					IF GE,CALL CRASH
13CD					AA=%SI
13CF*					AA:">>"
13D2		*			IF EQ,EXIT
13D4*					A:CR
13D6				*	IF NE,LOOP
13D8					CALL EOF.COUNT
13DB*					AA:14		LF>>LFxxxx xLF[eof]
13DE				LOOP WHILE GE
13E0		*		EXIT
13E2*			CS:	A:$PERIOD
13E7		*	IF EQ,EXIT
13E9			PUSH BC
13EA			PUSH SI
13EB			BC=6
13EE			DO	A=$SI+
13EF*				A:CR
13F1			*	IF EQ,EXIT
13F3*				A:":"
13F5				BC=BC-1
			LOOP NE (BC>0)
13F7			POP SI		RETURN:
13F8			POP BC			Possible Good Statement
13F9		*	IF EQ,EXIT		O.K. = NC,NE (SI unchanged)
13FB.			CY=0			EOF =  CY,NE
13FC		RETURN				Comment = NC,EQ
13FD SKIP.CR	DO	A=$SI+
13FE*			SI:-16			(SI:65520)
1401			IF GE,CALL CRASH
1406*			A:CR
1408		LOOP UNTIL EQ
140A+		SI=SI+1
140B EOF.COUNT	PUSH BC 	RETURN AA = MIN(65520, EndSource-SourcePtr)
140C		PUSH DE
140D		PUSH DI 		SI,DS = SourcePointer
140E		PUSH ES
140F		CS:	DI,ES=%FILE.EOF
1414		CALL PTR.DIFF
1417		POP ES
1418		POP DI
1419		POP DE
141A		POP AA
141B		SWAP AA,BC
141C*		AA:0
141E		RETURN
141F		=18*0
.P
1431 :<Define offsets>	Refer to:   DS:PARMS+offset   or   %(BP+offset)
0002 EXIT=2	Exit Address for WRAPUP Error (set by INIT.T)
0004 ADDR=4	ADDRESS of Begin Current Statement Def. (set by INIT.B)
0006 SYM=6	SymTab Pointer from last lookup
0008 S.S=8	Source Segment
000A VECT=10	@Vector (upper SYMTAB segment)
000C TOKN=12	Token (FF80+)
000E FLAGS=14	=0 (INIT.P), =255 (1st INIT.B), =CY (2nd INIT.B FAILs)
1431 INIT.F	ENTRY		Initialize on behalf of entire source file
1431		AA=@E.O.CODE
1434		%E.O.MEM=AA
1437*		AA=0
1439		%ERR.CNT=AA
143C		CALL FILE.POINT
143F		SWAP ES,DS		%(SI,DS) = <filename>.<ext>
1443		SWAP SI,DI		%(DI,ES) = Symtab 1st entry
1445		A=0FB		Need Init Symtab = <sig><adr><rootfile>,0
1447		$DI+=A				    0FB,0,0,<sourcefile>,0
1448*		AA=0					    (pad w/Spaces)
144A		%DI+=AA
144B		DO	$DI+=$SI+
144C*			$SI:"."
144F		LOOP UNTIL EQ
1451		AA="  "
1454		%DI+=AA
1455		%DI+=AA
1456		%DI+=AA
1457		%DI+=AA
1458*		AA=0
145A		DI=0B
145D		%DI+=AA
145E		ES=CS
1460		RETURN
1461 NEXT.LINE	ENTRY
1461		CS:	SI,DS=%FILE.PTR 	Get pointers positioned
1466		CALL EOF.COUNT			for another line of source.
1469		SWAP AA,BC			RTN CY if too near the EOF.
146A		DO UNTIL BC=0
146C			A=$SI+
146D*			A:CR
146F			BC=BC-1
		LOOP NE (BC>0)
1471+		SI=SI+1 		LFxxxx xLF
1472		CALL MIN.SI		 ^BC------^EOF
1475		AA=DS			  (min = 9)
1477		DS=CS
1479*		BC:9
147C		IF GE,
147E			%FILE.PTR+2=AA
1481			%FILE.PTR=SI
1485		RETURN
1486		=16*0
.P
1496 CK.LIST:	="NAME",35*0
14BD INIT.P	ENTRY		Initialize before call MATCH(prep)
14BD		BP=@PREP
14C0		DE=(BP+2)
14C3		BP=%BP
14C6		AA=%TOKENS+2
14C9		ES=AA		ES = Token Segment
14CB*		AA=0		DI will Index EOF of Tokens (until WRAPUP)
14CD		%PARMS+FLAGS=AA
14D0		SWAP AA,DI		DI,ES = Match Object (Token Stream)
14D1		SI,DS=%FILE.PTR 	SI,DS = Match Source
14D5		CS:	%MAX.SRC=SI
14DA		CS:	%COLUMN1=SI
14DF		RETURN
14E0 INIT.B	ENTRY		Initialize before call MATCH(body)
14E0		DS=CS
14E2		BP=@BODY
14E5		DE=(BP+2)
14E8		BP=%BP
14EB*		$PARMS+FLAGS=$PARMS+FLAGS+255
14F0		IF NC,
14F2			AA=%OBJECT
14F5			%PARMS+ADDR=AA
14F8			SI,DS=%FILE.PTR
14FC			CALL WRITE.HEX
14FF+			SI=SI+1
1500.			CY=0
1501		RETURN
1502 INIT.T	ENTRY
1502		BP=@PARMS
1505		HL=@BACK
1508		%BP=HL			%BP=@BACK Subpatterns
150B		CS:	HL=%HL		HL=%BACK (1st Pattern)
150E		SWAP DE,DI		DE=End-of-Tokens
1510*		DI=0
1512		%(BP+EXIT)=SP		Set an Exit Address
1515		CS:	%FILE.PTR=SI	Update SourcePtr; can't BACKUP now
151A		%(BP+S.S)=DS		Save the Source Segment Register
151D		RETURN
151E		=16*0
.P
152E FAIL.WRAP	POP SI
152F		CS:	A=$SI
1532		CS:	$ERR.FLG=A
1536 F.E:	SP=%(BP+EXIT)
1539 ERROR	ENTRY			CALLED from TRANSLATE or WRAPUP when
1539		CS:	DS=%FILE.PTR+2		MATCH(prep), MATCH(body), and
153E		CS:	SI=%COLUMN1		WRAPUP can't handle statement
1543		AA=%(SI+4)				(columns 5-6)
1546*		A:"="			Kxxx=arb
1548		IF NE,			Knn?=arb
154A*			A':"="			Kxxx =arb
154D		*	IF NE,EXIT		K nn?=arb
154F+			SI=SI+1
1550			$SI=" "
1553+		ELSE	SI=SI+1 			(column 2/3)
1554 ERR.1:		%(SI+2)="?="			(columns 4/5-5/6)
1559			CS:	AA=%MAX.SRC
155D*			CS:	AA=AA-%COLUMN1
1562*			AAM		A'=10's, A=1's (Decimal Number)
1564*			AA=AA OR "00"
1567			SWAP A,A'
1569*			A:"9"
156B			IF GT,
156D				A="9"		(max=99)
156F			%SI=AA
1571			CS:	A=$ERR.CNT
1575*			A=A+01
1577*			DAA		Keep a BCD ERR.CNT
1578			IF CY,
157A				A=099		(max=99)
157C			CS:	$ERR.CNT=A
1580			RETURN
1581		CS:	A=$ERR.FLG		xxxx+label
1585		$(SI+4)=A			nn?=xlabel
1588		GOTO ERR.1
158A		=50*0
.P
15BC FUNCTIONS	ENTRY
15BC		=@F.0	Pattern Definition Fixup (post processing)
15BE		=@F.A	Reference a <label>
15C0		=@F.B	Emit <hex> Byte
15C2		=@F.C	Fixup prev ALT prefix (follows <push..>pop)
15C4		=@F.D	Define a <label>
15C6		=@F.E	Invoke an Error (last ALT from PREP)
15C8		=@F.F	Put NAME=<filename> into SymTab
15CA		=@F.G	"literal"
15CC		=@F.H	LITERAL
15CE		=@F.I	Emit Function Call (a..z)
15D0		=20*0
15E4 F.I:	CALL GET.TOKEN
15E7		A=$SI+
15E8		GOTO EMIT.A
15EB GET.TOKEN	DS=%(BP+S.S)
15EE		ES:	SI=%(DI+2)
15F2		PUSH AA
15F3		AA=%(SI+1)
15F6		CS:	%MAX.SRC=AA
15FA		POP AA
15FB		ES:	C=$(DI+1)
15FF		B=0
1601		RETURN
0020 TEMP	(16)
1602 BUFFER	NEXT
1602*		BC:10			MaxSymbolLength=10
1605		IF GT,
1607			BC=10
160A		PUSH BC 		BC = Length; SI,DS = Raw Source
160B		ES=CS
160D		DI=@TEMP
1610		PUSH DI
1611		DO	CALL FILE.CHR
1614			$DI+=A
1615			BC=BC-1
		LOOP (BC>0)
1617		DS=CS
1619		POP SI			SI,DS = @Buffer (Shifted Source)
161A		POP BC			BC = Length
161B		RETURN
161C		=41*0
.P
1645 LOOKUP	NEXT
1645		DI,ES=%SYMTAB		SI,DS = @Buffer (Symbol) (DS=CS)
1649		SWAP AA,BC		BC was Length of Symbol (max=10)
164A		PUSH DI
164B		DO	POP DI
164C			ES:	C=$DI		Here, A=Len
164F*			BC=BC AND 0F
1653*			DI=DI+BC
1655			ES:	C=$DI
1658*			C=C AND 0F
165B*			C:1
165E			PUSH DI
165F		*	IF LT,EXIT
1661			DI=(DI+3)
1664*			C=C-3
1667*			A:C		Are lengths equal?
1669		*	IF NE,LOOP	(if not, symbols can't be equal)
166B			PUSH SI
166C			DO UNTIL BC=0
    *				$SI+:$DI+
				BC=BC-1
			LOOP EQ (BC>0)
166E			POP SI
166F		LOOP WHILE NE
1671		SWAP AA,BC		BC=Length of Symbol
1672		POP DI
1673		%(BP+SYM)=DI		EQ-->Symbol Found (%DI=[k l] Value)
1676		RETURN			NE-->End-of-Table (%DI=[0])
1677 ENTER	NEXT
1677		ES=%SYMTAB+2	H=Key (LS4 bits = 0)	Must be called after
167B		DI=%(BP+SYM)	BC=Symbol Length;		LOOKUP fails.
167E ENTER.DI	NEXT
167E		PUSH DI 	AA = Value (Token)
167F+		DI=DI+1 	SI,DS = @Buffer (Symbol to be entered)
1680		%DI+=AA
1681		DO UNTIL BC=0
			$DI+=$SI+		DO NOT USE THIS ROUTINE
			BC=BC-1 		TO ENTER A FILENAME (key=F)
		LOOP (BC>0)
1683		ES:	%DI=BC		End-of-Table = @0-word
1686		POP AA		Index of Skip Byte
1687		SWAP AA,DI	now, AA = Index of 0-Byte
1688*		AA=AA-DI	now, DI = Begin Entry & A = Length of Entry
168A*		A=A OR H	combine key & skip
168C		$DI+=A		and fix the [key skip] byte.
168D		RETURN		(MUST RETURN NC)
168E		=49*0
.P
16BF F.0:	CALL CK.LEFT
16C2		CALL SORT.ALTS
16C5		SP=%(BP+EXIT)
16C8		RETURN
16C9 F.A:	PUSH HL
16CA		PUSH DI
16CB		PUSH ES
16CC		CALL GET.TOKEN
16CF		CALL BUFFER
16D2		CALL LOOKUP
16D5		IF NE,
16D7			CALL NEW.REF
16DA			H=080
16DC NEW.ONE:		CALL ENTER
16DF POP.ONE:		POP ES
16E0			POP DI
16E1			POP HL
16E2			RETURN
16E3*		ES:	%(DI+1):0	Only the Statement Def = 0.
16E8		IF EQ,
16EA			CALL FAIL.WRAP	ref to Statement Definition
16ED			="D"
16EE		ES:	AA=%(DI+1)	otherwise, get AA = Ref Token
16F2		CALL EMIT.REF
16F5		GOTO POP.ONE
16F7 F.D:	PUSH HL
16F8		PUSH DI
16F9		PUSH ES
16FA		CALL GET.TOKEN
16FD		CALL BUFFER
1700		CALL LOOKUP	CALLED WITH: <def> = <pattern>
1703		AA=%(BP+ADDR)		<def> is in BUFFER, BC=Length
1706		IF NE,
1708*			AA:0		didn't find def in symtab
170A			IF NZ,			ONLY allowed for 1st def
170C BAD.DEF:			CALL FAIL.WRAP	(otherwise, error)
170F				="S"
1710			%(BP+VECT)=AA		Yes, 1st def, so enter.
1713			%(BP+TOKN)=@0FF7F	Initialize vector & token
1718			CALL NEW.VECT		Emit 1st vector element.
171B			H=060			And Enter a local symbol.
171D			GOTO NEW.ONE
171F		DS=ES
1721*		$DI::`0 		Found symbol, is it marked
1724		IF ZR,GOTO BAD.DEF		as forward ref? (error)
1726*		$DI=$DI AND 0F		yes, key = forward ref.
1729*		$DI=$DI OR 060		now, change key to "local"
172C		PUSH AA
172D		A=$(DI+1)
1730*		A=A+A
1732		A'=0
1734*		AA=AA+%(BP+VECT)
1737		POP DI
1738		SWAP AA,DI
1739		%(DI+2)=AA
173C		GOTO POP.ONE
173E		=22*0
.P
1754 NEW.REF	AA=%(BP+TOKN)
1757+		A=A+1
1759		IF ZR,
175B			CALL FAIL.WRAP
175E			=">"
175F		$(BP+TOKN)=A
1762		CALL NEW.VECT
1765 EMIT.REF	GOTO EMIT.A
1768 NEW.VECT	DS=%SYMTAB+2		Enter with:
176C		DI=%(BP+VECT)			AA=New Address
176F+		DI=DI-2 			BP=@PTRS, DS=CS
1771		%(BP+VECT)=DI
1774+		DO	DI=DI+2 	Move Vector 2 bytes down & put
1776		*	IF ZR,EXIT	New Address into last location.
1778			PUSH %DI
177A			POP %(DI-2)
177D		LOOP
177F		%(DI-2)=AA	Need to RETURN:
1782		DS=CS			AA,BC,SI unchanged.
1784		RETURN			DI=0, DS=CS
1785 F.B:	ES:	A=$DI
1788*		ASL A,4
178B*		ES:	A=A OR $(DI+4)
178F		GOTO EMIT.A
1792		=86*0
.P
17E8 F.F:	PUSH DE
17E9		PUSH HL
17EA		PUSH DI
17EB		PUSH ES
17EC		CALL GET.TOKEN		Handle NAME=<filename>
17EF		CALL BUFFER
17F2		CS:	ES=%SYMTAB+2
17F7		DI=3			Index to Root NAME entry.
17FA		PUSH SI
17FB		PUSH BC
17FC*		BC:8
17FF		IF GT,			Truncate to 8 characters.
1801			BC=8
1804		DO UNTIL BC=0
			$DI+=$SI+
			BC=BC-1 	Overwrite with new NAME=<rootfile>
		LOOP (BC>0)
1806*		DO	DI:11
1809		*	IF GE,EXIT
180B			ES:	$DI=" "
180F+			DI=DI+1 	Pad with Spaces if necessary.
1810		LOOP
1812		POP BC
1813		POP SI
1814		POP ES
1815		POP DI
1816		POP HL
1817		POP DE
1818		RETURN
1819 F.H:	CALL GET.TOKEN
181C		DO	A=$SI+
181D*			A:021
181F		*	IF LT,EXIT
1821*			A:"a"
1823			IF GE,
1825*				A:"z"
1827		*		IF LE,EXIT
1829*			A:7F
182B		*	IF GE,EXIT
182D			CALL EMIT.A
1830			BC=BC-1
		*	LOOP (BC>0)
1832			RETURN
1833 F.G:		CALL GET.TOKEN
1836+			BC=BC-1
1837+			SI=SI+1
1838			BC=BC-1
		LOOP (BC>0)
183A		CALL FAIL.WRAP
183D		="K",35*0
.P
1861 F.C:	SWAP AA,SI	DS:SI Set by > Action (just before "c")
1862		CALL GET.EMIT	Look at the previous Prefix
1865		SWAP AA,SI		Now, AA=Current Object
1866*		AA=AA-SI		and, SI=Previous ALT
1868*		AA:3F			IS skip distance > 3F ?
186B		IF GT,
186D			CALL FAIL.WRAP
1870			=">"
1871*		$SI=$SI OR A		IF not, then OR Skip into ALT
1873		RETURN
1874 NO.DEF	C=$SI
1876		PUSH DS
1877		PUSH ES
1878		PUSH SI
1879		PUSH DI
187A		PUSH AA
187B		SI=(SI+3)
187E*		C=C-3
1881*		BC=BC AND 0F
1885		DI=5D
1888		ES=CS
188A		DO UNTIL BC=0
			$DI+=$SI+
			BC=BC-1
		LOOP (BC>0)
188C		CS:	$DI=0
1890		SI=@NO.DEF.1
1893		CALL DSPLY
1896+		$ERR.CNT=$ERR.CNT+1
189A		POP AA
189B		POP DI
189C		POP SI
189D		POP ES
189E		POP DS
189F		RETURN
18A0*SYM.FIX	%OBJECT:0
18A5		SI=@EMPTY		Aborts if OBJECT=0
18A8		IF EQ,GOTO DSPLY
18AC		BP=@PARMS
18AF		SI,DS=%SYMTAB		FIX SymTab(0B); Value always = @0
18B3*		$0B=$0B XOR 040 	change Type from 06x to 02x
18B8 MAP.IT	CS:	ES=%SYMTAB+2	Get Regs:
18BD		DI=%(BP+VECT)		DI,ES = Vector (at high SYMTAB)
18C0*		A=A+A
18C2		A'=0
18C4*		AA=AA+DI		AA = Token for symbol
18C6		SWAP AA,DI	RETURN WITH:
18C7		ES:	DI=%(DI+2)	AA = Address (or unchanged)
18CB		SWAP AA,DI		Only other regs changed = DI,ES.
18CC		RETURN
18CD		=32*0
.P
18ED FINAL	ENTRY
18ED		DS=CS
18EF*		$ERR.CNT:0
18F4		IF ZR,			AF = ERR.CNT (IF count > 0, quit)
18F6			CALL SYM.FIX
18F9			DO	C=$SI
18FB*				BC=BC AND 0F
18FF			*	IF ZR,EXIT
1901*				SI=SI+BC
1903				AA=%(SI+1)
1906*				A':-1
1909			*	IF NE,LOOP
190B				CALL MAP.IT
190E*				A':-1
1911				IF EQ,CALL NO.DEF
1916				%(SI+1)=AA
1919			LOOP
191B+			SI=SI+2
191D			PUSH SI
191E			SI=DI
1920*			DO	%SI=%SI-DI
1922+				SI=SI+2
1924			LOOP UNTIL ZR
1926			POP SI
1927			CALL E.VECTOR
192A			CS:	BC,DS=%OBJECT
192F+			BC=BC+1 	Include Final 080 byte
1930*			SI=0
1932			DO	A=1
1934				HL=DI
1936				$DI+=A
1937				DO	$DI+=$SI+
1938+					A=A+1
193A					ES:	$HL=A
193D*					A:63
193F					BC=BC-1
				LOOP NE (BC>0)
1941+				BC=BC+1
1942				BC=BC-1
			LOOP (BC>0)
1944*			AA=0
1946			$DI+=A
1947			DS=CS
1949		ES=CS
194B		A=$ERR.CNT
194E*		A:0
1950		RETURN			AF = ERR.CNT
1951		=55*0
.P
1988 CK.LEFT	CS:	DS=%OBJECT+2	The following code is identical
198D		SI=%(BP+ADDR)		in both PTRAN and DEXPL.
1990 CK.MORE	C=$SI			-----------------------------------
1992*		C::01000000
1995		IF NZ,
1997+			SI=SI+1
1998+			C=C-1
199A*		DO	BC=BC AND 3F
199E+			SI=SI+1
199F+			BC=BC-1
19A0			PUSH BC
19A1			PUSH SI
19A2			IF NZ,
19A4				A=$SI		Checking left-most element
19A6*				A:020		if [ ], get next element
19A8				IF EQ,
19AA					A=$(SI+1)
19AD*				A:0		and test to see if subpat'rn
19AF			*	IF POS,EXIT
19B1				CALL MAP.IT	If it is, get its address
19B4*				A':-1
19B7			*	IF EQ,EXIT
19B9*				AA:%(BP+ADDR)	and verify that we aren't
19BC				IF EQ,			back where we
19BE					CALL FAIL.WRAP	started.  If we are,
19C1					="L"		it's left recursion.
19C2				SWAP AA,SI
19C3				CALL CK.MORE
19C6			POP SI
19C7			POP BC
19C8*			SI=SI+BC
19CA			C=$SI
19CC*			C:0
19CE		LOOP UNTIL NEG
19D0		RETURN
19D1 SORT.ALTS	ES=DS
19D3		CALL INS.OVRRDS
19D6		IF NEG,RTN
19D9		DO	SI=%(BP+ADDR)
19DC			DO	CALL CMP.ALTS	Must ALTS be Exchanged ?
19DF				IF CY,		HL is Set by CMP.ALTS
19E1					CALL ROTATE	Moves ALT at %DI
19E4			*		EXIT		to %HL & [HL..DI] up.
19E6				C=$SI
19E8*				BC=BC AND 3F
19EC*				SI=SI+BC
19EE*				SI:DI
19F0			*	IF NE,LOOP
19F2				CALL DI.P.ONE
19F5		LOOP UNTIL NEG
19F7		CALL DEL.OVRRDS 	Sets final value of $OBJECT
19FA		RETURN
19FB		=32*0
.P
1A1B CMP.ALTS	PUSH SI
1A1C		C=$SI
1A1E*		BC=BC AND 3F
1A22*		SI=SI+BC
1A24		A=$(SI-1)		A  = Next ALT #
1A27		POP SI
1A28		A'=-1
1A2A*		SI:%(BP+ADDR)
1A2D		IF NE,
1A2F			A'=$(SI-1)	A' = Prev ALT #
1A32*		A':A
1A34		IF GT,			IF Prev #  >  Next #
1A36			HL=SI		then Put Insert Point = Next ALT
1A38		PUSH SI 		(otherwise it remains somewhere
1A39		C=$SI			farther left, or at the beginning)
1A3B*		C=C AND 7F
1A3E*		C::040			Adjust for the initial prefix ALT
1A41		IF NZ,			(it can now be anywhere & may have
1A43*			C=C-041 	an override byte flagged after it).
1A46+			SI=SI+1 	Get rid of the bit and the byte.
1A47+		SI=SI+1 		Now, SI = 1st ALT byte to be matched.
1A48*		C:$DI
1A4A		IF LE,
1A4C			PUSH BC 	Match only if $SI shorter than $DI.
1A4D			PUSH DI 	(fail if same length & full match).
1A4E+			BC=BC-2
1A50+			DI=DI+1 	(flags = NZ at this point)
1A51			DO UNTIL BC=0
    *				$SI+:$DI+
				BC=BC-1
			LOOP EQ (BC>0)
1A53			POP DI		Flags EQ here only if complete match.
1A54			POP BC
1A55		*	IF NE,EXIT	No need to exchange.
1A57*			C:$DI
1A59			IF EQ,			Fail if same lengths.
1A5B				CALL FAIL.WRAP
1A5E				="D"
1A5F			POP SI		Here we need to exchange due to
1A60			CALL TST.NEXT	$SI being a proper head of $DI.
1A63			IF NE,			Compare Prev ALT # to
1A65+				A'=A'+1 	# of ALT to be Inserted.
1A67				CALL TST.NEXT
1A6A			IF EQ,		If Insert would be in sequence here,
1A6C				HL=SI		then, set Insert Point here.
1A6E.			CY=1		Otherwise, accept Point set above.
1A6F			RETURN
1A70		POP SI		<<<<	Here we have disjoint ALTs.
1A71		CALL GET.BOTH		Are Both Literals OR NOT Literals?
1A74*		B=B XOR C		(B & C = types of 1st Elements)
1A76		IF ZR,			(if not the same, RTN NC)
1A78			CALL TST.NEXT	If they are, check their sequence.
1A7B		*	IF GT,EXIT	(no insert needed, RTN NC)
1A7D*			A':A		RTN CY ONLY if we need to insert.
1A7F		*	IF EQ,EXIT	(RTN NC)
1A81.			CY=~CY		NC if A'< A;  CY ONLY if A'> A.
1A82		RETURN
1A83		=16*0
.P
1A93 TST.NEXT	PUSH DI
1A94		C=$DI
1A96*		DI=DI+BC
1A98*		A':$(DI-1)
1A9B		POP DI
1A9C		RETURN
1A9D GET.BOTH	B=$(SI+1)	SI in range of initial ALT
1AA0*		$SI::040	DI is to the right of that.
1AA3		IF NZ,
1AA5			B=$(SI+2)	Skip possible leading ALT Override.
1AA8		C=$(DI+1)	Return	B = Type of ALT at $DI, and
1AAB		CALL TEST.B		C = Type of ALT at $SI.
1AAE		SWAP B,C	Possible Ranges of Element B.
1AB0*TEST.B	B=B-021 	00-20 21-60 61-7A 7A-7E 7F-FF
1AB3*		B:5A		      00-3F 40-59 5A-5D 5E...
1AB6		IF GE,		      ^LIT^   |   ^LIT^  |
1AB8*			B:5D		 |    |    LE:	GT:
1ABB		*	EXIT		 |    |     |	 |
1ABD*		ELSE	B:3F		LE:  GT:    |	 |
1AC0		B=-1			 |    |     |	 |
1AC2		IF GT,			B=-1  |    B=-1  |
1AC4			B=0		     B=0	B=0
1AC6		RETURN
1AC7 ROTATE	SI=HL
1AC9		L=$DI
1ACB*		HL=HL AND 3F		Length of Upper Area
1ACF		DE=DI
1AD1*		DE=DE-SI		Length of Lower Area
1AD3		BC=HL
1AD5*		BC=BC+DE
1AD7		PUSH DI
1AD8		A=$DI
1ADA		DO	SWAP A,A'
1ADC			A=$SI
1ADE			$SI=A'
1AE0*			SI:DI
1AE2			IF LT,
1AE4*				SI=SI+HL
1AE6			*	EXIT
1AE8			ELSE	IF EQ,
1AEA+					SI=SI+1
1AEB+					DI=DI+1
1AEC					A=$SI
1AEE*				SI=SI-DE
1AF0			BC=BC-1
		LOOP (BC>0)
1AF2		POP DI
1AF3*		DI=DI+HL	[  DE  ] [ HL ]    [ HL ] [  DE  ]
1AF5*		$DI:0		Before:  ^DI	   After:	  ^DI
1AF8		RETURN
1AF9		=16*0
.P
1B09 INS.OVRRDS CALL DI.A.ONE		If single ALT, take an early exit.
1B0C		IF POS,
1B0E			SI=%(BP+ADDR)		Get @Begin Statement
1B11			A=$SI			and check for a
1B13*			A=A+A			"Bracket ID"
1B15		*	IF POS,EXIT		Exit early if one is flagged.
1B17		ELSE	RETURN
1B18		E=0			E = # of Current ALT
1B1A		DO	L=$SI
1B1C*			HL=HL AND 3F
1B20			$SI=L		Set upper 2 bits of Skip = 0
1B22*			L:2			Test size of Current ALT
1B25			HL=(HL+SI)		(HL = @ Next Alt)
1B27			IF GE,
1B29				A=$(HL-1)	Size > 1,
1B2C*				A:020		so test for ALT Override
1B2E			*	IF GE,NEXT
1B30				SWAP AA,DE	E = Override
1B31			*	EXIT
1B33*			ELSE	E:32		if there was no override,
1B36		*		IF GE,EXIT		(AND E < 32)
1B38+				$SI=$SI+1	then we insert an Override
1B3A*				$SI::00111111
1B3D		*		IF ZR,EXIT		(skip byte overflow)
1B3F				CS:	DI=%OBJECT	DI = Cutoff Point
1B44				A=E
1B46+				HL=HL-1
1B47+				DO	HL=HL+1 	From HL to Cutoff,
1B48					SWAP A,A'	move all the bytes
1B4A					A=$HL		up one position,
1B4C					$HL=A'		inserting ALT at 1st
1B4E*					HL:DI		position.
1B50				LOOP UNTIL GT
1B52+				CS:	%OBJECT=%OBJECT+1	Bump Cutoff.
1B57			L=$SI
1B59*			HL=HL AND 3F		$SI = Current ALT Skip Byte
1B5D			SI=(HL+SI)
1B5F*			$SI::11000000		$SI = Next ALT's Skip Byte
1B62			IF ZR,			ZR-->not a synonym
1B64+				E=E+1			so, bump ALT #.
1B66		*	IF POS,LOOP		NEG-->We're at End-Statement
1B68 DI.A.ONE	ELSE	DI=%(BP+ADDR)		End-Statement = `0.
1B6B DI.P.ONE		C=$DI		Here is our exit sequence,
1B6D*			BC=BC AND 3F		if we inserted overrides,
1B71*			DI=DI+BC		we always return POS.
1B73*			$DI:0		If we didn't, we returned NEG (above)
1B76			RETURN
1B77		CALL FAIL.WRAP		Here is our abort sequence.
1B7A		=">"
.P
1B7B E.VECTOR	SWAP SI,DI
1B7D		A=3
1B7F		$DI+=A
1B80*		AA=0
1B82		%DI+=AA
1B83		DO	A=`3
1B85			$DI+=A
1B86			%DI+=%SI+
1B87*			SI:0
1B89		LOOP UNTIL EQ
1B8B		RETURN
1B8C DEL.OVRRDS SI=%(BP+ADDR)		Here we're looking at a set of ALTS
1B8F*		$SI=$SI OR `0		with all explicit ALT Overrides.
1B92		E=-1			No synonym bits are set, and
1B94		DO	L=$SI		no "Bracket ID" is allowed.
1B96*			HL=HL AND 3F	Set the sign bit on the 1st Skip,
1B9A			HL=(HL+SI)	& clear it on all others.
1B9C*			E:$(HL-1)	Set synonym bits as appropriate.
1B9F			IF EQ,		Final Byte = `0 (End-Statement)
1BA1*				$SI=$SI OR 01000000
1BA4			*	EXIT
1BA6+			ELSE	E=E+1	Here, E = Sequential ALT #
1BA8*			E:$(HL-1)	SI=@ALT, HL=@Next ALT
1BAB			IF NE,
1BAD				E=$(HL-1)	Update E & Keep ALT Override
1BB0			*	EXIT
1BB2			ELSE	CS:	DI=%OBJECT	Here, we can get rid
1BB7+				$SI=$SI-1		of a redundant
1BB9				DO	A=$HL		ALT Override.
1BBB					$(HL-1)=A
1BBE+					HL=HL+1
1BBF*					HL:DI
1BC1				LOOP UNTIL GT
1BC3+				CS:	%OBJECT=%OBJECT-1
1BC8			L=$SI
1BCA*			HL=HL AND 3F
1BCE			SI=(HL+SI)
1BD0*			$SI:0		End-Statement = `0 (NEG)
1BD3		LOOP WHILE POS
1BD5		RETURN
1BD6		NEXT
.
1256 GET.RETRY	128A CR 	1295 OBJECT	1299 WRITE.HEX
12AF B.SOURCE	12BD FILE.CHR	13C8 CRASH	13E2 PERIOD
140F FILE.EOF	1414 PTR.DIFF	1431 E.O.CODE	1434 E.O.MEM
1439 ERR.CNT	143C FILE.POINT 1461 FILE.PTR	1472 MIN.SI
14BD PREP	14C6 TOKENS	14D5 MAX.SRC	14DA COLUMN1
14E2 BODY	1505 BACK	1532 ERR.FLG	15E8 EMIT.A
1645 SYMTAB	1862 GET.EMIT	1890 NO.DEF.1	1893 DSPLY
18A5 EMPTY