TOP; TINCMP COPYRIGHT (C) 1981 W.A.GALE
 PARAMETER KLF=010; CP/M MODIFICATION AND 8086 RECODING
 PARAMETER KCR=013; BY A. L. BENDER, M. D.
 PARAMETER KEF=026; NEW MODS AND REWORKING COPYRIGHT (C) 1981 A L BENDER, M D
 BYTE AA; WORK
 BYTE BB; WORK BYTE
 BYTE DD; WORK
 BYTE EE; WORK BYTE

 BYTE BF(080); EXPANSION BUFFER
 BYTE BL; BLANK
 BYTE BP; POINTER INTO BF
 BYTE C0; CONSTANT ZERO
 BYTE C1; CONSTANT ONE
 BYTE C2; CONSTANT TWO
 BYTE C3; CONSTANT 3
 BYTE C4; CONSTANT  040
 BYTE C8; CONSTANT 080
 BYTE C9; CONSTANT 9
 BYTE CC; INPUT CHARACTER
 BYTE CX; CONSTANT TEN

 BYTE DG; DIGIT FROM PARAMTER TREATMENT DEFINITION
 BYTE DS(010); DIGIT STACK FOR SUB SD
 BYTE EF; END FILE CHARACTER
 BYTE F1(00128); INPUT BUFFER
 BYTE F2(00128); OUTPUT BUFFER
 BYTE HA; 'A'
 BYTE HF; 'F'
 BYTE LE; END OF LIST
 BYTE LF; LINE FEED CHARACTER
 BYTE LS(09000); LIST OF MACRO DEFINITIONS
 BYTE MF; MACRO REPLACEMENT OPERATOR FLAG
 BYTE ML; MACRO LENGTH
 BYTE MM; MINIMUM MACRO LENGTH

 BYTE ND; NUMBER OF DIGITS USED IN SUB SD FOR NUMBER OUTPUT
 BYTE NL; NEW LINE
 BYTE O1; FETCH CODE
 BYTE O2; INDEX CODE
 BYTE O3; DISPOSE CODE
 BYTE OA; '+' ADD OPERATOR
 BYTE OB; '!' POP STACK OPERATOR
 BYTE OC; 'C' CHARACTER DISPOSE
 BYTE OD; 'V' DIGIT CONVERSION FETCH
 BYTE OE; ESCAPE CHARACTER
 BYTE OG; IGNORE CHARACTER
 BYTE OH; 'H' HEX CONVERSION FETCH
 BYTE OL; 'L' LITERAL FETCH
 BYTE OM; '*' MULTIPLY DISPOSE
 BYTE ON; 'N' NUMERIC LITERAL FETCH

 BYTE OP; 'P' PARAMETER FETCH OR DISPOSE
 BYTE OR; '-' REDUCE (SUBTRACT) DISPOSE
 BYTE OS; 'S' STACK FETCH OR DISPOSE
 BYTE OT; TRACE FLAG TURN ON
 BYTE PP; POINTER INTO IPR
 BYTE RB; BEGIN DEFINITION FLAG
 BYTE RC; (COMMENT) END OF LINE FLAG
 BYTE SF; SUBSTITUTION PARAMETER FLAG
 BYTE SP; STACK POINTER
 BYTE TR; TRUE IF NO TRACE
 BYTE UG; USE IGNORE;  TRUE UNLESS OG IS 'X'

 BYTE UN; NOT X-- FLAG FOR NOT SUPPRESSING NEW LINES ON OUTPUT
 BYTE UO; USE OPERATIONS-- TRUE UNLESS MF IS 'X'
 BYTE UT; USE TRACE  TRACE MODE IS ON
 BYTE ZR; CHARACTER ZERO
 INT I00; CONSTANT ZERO
 INT I01; CONSTANT 1
 INT I09; CONSTANT 9
 INT I10; CONSTANT 10
 INT I16; CONSTANT 16
 INT IAA; WORK
 INT IBB;  WORKING STORAGE
 INT IBC; BUCKET NUMBER
 INT IDP; DEFINITION POINTER WHILE MATCH
 INT IED; POINTS TO END OF DEFINITIONS
 INT III; POINTER TO L WHILE READING
 INT IJJ; POINTER TO L READING CODE
 INT ILM; MAXIMUM LIMIT FOR STORING IN L

 INT ILP(01000); POINTERS TO MACROS
 INT IMP; MACRO POINTER DURING EXPANSION
 INT INM; NUMBER OF MACROS
 INT IPR(010); PARAMETER VALUES
 INT ISS(040);   INT TO HOLD NUMBERS-MAIN STACK
 INT ITU; VALUE OF PARAMETER TO USE
 INT IUU; SYMBOL GENERATOR(UNIQUE)
 INT IXX; WORK
 INT IYY; WORK
 BEGINMAIN(AC,IAV)
 NL=+KCR
 LF=+KLF
 GOSUB CR

 MS 'COPYRIGHT'
 MS ' (C) 1981'
 MS ' W.A.GALE'
 GOSUB CR
 MS '8086 TINC'
 MS 'MP COMPIL'
 MS 'ER CP/M V'
 MS 'ERSION 1.'
 MS '00/TINCMP'
 GOSUB CR
 MS 'COPYRIGHT'
 MS ' (C) 1984'
 MS ' A L BEND'
 MS 'ER, MD   '
 GOSUB CR
MS 'COLLECTED'
MS ' WITH VER'
MS ' 1.3 I/O '
MS 'PACKAGE. '
GOSUB CR
 GOSUB IN
 GOSUB RM
 LOC 00
 WHILE
	READ CC FROM F1
	AA=ER==C0
 ON AA; THAT IS, UNTIL EOF IS REACHED ON INPUT

      IF UG

		WHILE
			BB=CC==NL
			DD=CC==LF
			AA=CC==OG
			EE=BB?DD
			BB=CC==BL
			AA=BB?AA
			AA=EE?AA
		ON AA; IGNORE LEADING CHARACTERS
			GOSUB GC; READ CC FROM F1
		ENDWHILE
      ENDIF
      BP=C1; BUF POINTER
      BF(C0)=CC
      WHILE
		GOSUB GC; READ CC FROM F1
			AA=CC==NL
			IF AA
			GOSUB GC; READ CC FROM F1
			AA=CC==LF
			IF AA
			CC=NL
			ENDIF
			ENDIF
		AA=CC!=NL
		BB=BP!=C8
		AA=AA&BB
      ON AA; WHILE LESS THAN 80 CHAR AND NOT NEWLINE
		BF(BP)=CC; THEN PUT IT IN BUFFER FOR MULT COMP
		BP++

	ENDWHILE
	WHILE
	AA=CC!=NL
	ON AA


		GOSUB GC; READ CC FROM F1
	ENDWHILE; HERE WE ARE DUMPING A LONG INPUT LINE
	BF(BP)=RC
	BP++
	BF(BP)=NL
	LE=BP
	AA=BP<=MM
	IF AA; TOO SHORT TO MATCH
		ML=+000
		GOTO 17
	ELSE
		ML=+001
	ENDIF
	IDP=I00
	PP=C0
	IJJ=I00
	INM=C0
	WHILE
		AA=IDP<!IED; DEF PTR < END OF DEFINITIONS
	ON AA
		BP=C0
		WHILE
			AA=BP<=LE
		ON AA
			AA=LS(IJJ)
			AA=AA==RC
			O3=BF(BP)
			O3=O3==RC
			AA=AA&O3;  CHECK EOL MATCH TARG & TEMPLATE
			IF AA
				GOSUB DM;  DO MACRO EXPANSION
				GOTO 00
			ELSE
			AA=BF(BP)
			BB=LS(IJJ)
			AA=AA==BB
			IF AA
				GOTO 01;  MATCHING
			ELSE
			AA=BB!=SF;  NOT A TEMPLATE PARAMETER FLAG
			IF AA
				GOTO 10;  MISMATCHED
			ELSE;  THIS IS A PARAMETER
				PP++
				AA=BF(BP)
				IAA=AA
				IPR(PP)=IAA
			ENDIF
			ENDIF
			ENDIF
		LOC 01

			BP++
			IJJ++
		ENDWHILE
	LOC 10
		PP=C0
		INM++
		IDP=ILP(INM)
		IJJ=IDP
	ENDWHILE
  LOC 17
	BP=C0
	WHILE
		CC=BF(BP)
		O1=BP+C1
		AA=BF(O1)
		AA=AA!=NL
	ON AA
		IF ML;  THEN ALSO WRITE
			WRITE CC
		ENDIF
		WRITE CC INTO F2
		BP++
	ENDWHILE
	IF ML
		GOSUB CR
	ENDIF
	IF UN;  ONLY IF NOT SUPPRESSING
		WRITE NL INTO F2
		WRITE LF INTO F2
	ENDIF
  ENDWHILE
LOC 88; END OF SATISFACTORY COMPILATION
  MS 'TINCMP CO'
  MS 'MPILATION'
  MS ' FINISHED'
GOSUB CR;
  CLOSE F1
  CLOSE F2
  ENDMAIN
		SUB GC; GETS THE NEXT CHARACTER INTO CC GOES TO 88 ON END
	READ CC FROM F1
	AA=ER!=C0
	IF AA; IF NOT NORMAL READ OPERATION
		GOTO 88; !!!! NOT GOOD PROGRAMMING PRACTICE AT ALL !!!!
	ENDIF
	AA=CC==EF; IF CHARACTER WAS EOF MARK
	IF AA; IN CP/M SYSTEM THIS CAN BE RETURNED TO USER
		GOTO 88; !!!! NOT GOOD PROGRAMMING PRACTICE AT ALL !!!!
	ENDIF
		ENDSUB; GC - GET CHARACTER FROM INPUT FILE
		SUB SD;   CONVERTS TOUSE TO A NUMBER WITHOUT ZRO LEADING
 AA=ITU<!I00
 IF AA
	BB=+001
	ITU=-ITU
 ELSE
	BB=+000
 ENDIF
 AA=ITU==I00
 IF AA
	ND=C1
	DS(C0)=ZR
 ELSE
	ND=C0
	WHILE
		AA=I00<!ITU
	ON AA
		IYY=ITU/I10
		IAA=I10*IYY
		IXX=ITU-IAA
	ITU=IYY
	AA=IXX

	AA=AA+ZR
	DS(ND)=AA
	ND++
	ENDWHILE
 ENDIF
 DS(ND)=OR
 ND=ND+BB;  INCR FOR NEG INTEGER ONLY
 ENDSUB

		SUB WN;   WRITE NUMBER INTO F2

 GOSUB SD;  STACK THE DIGITS
 WHILE;  NOW WRITE THEM OUT FIRST TO LAST
	IAA=ND
	AA=I00<!IAA
 ON AA
	ND--
	AA=DS(ND)
	WRITE AA INTO F2
 ENDWHILE
 ENDSUB

		SUB PN;  WRITE THE NUMBER ON THE TERMINAL

 GOSUB SD;  STACK THE DIGITS
 WHILE
	IAA=ND
	AA=I00<!IAA
 ON AA
	ND--
	AA=DS(ND)
	WRITE AA
 ENDWHILE
 WRITE BL
 ENDSUB

		SUB CD;  CONVERT AA AS A DECIMAL DIGIT

 BB=ZR<=AA
 CC=AA<=C9
 BB=BB&CC
 IF BB

	AA=AA-ZR
	RETURN
 ENDIF
 AA=C0
 ENDSUB

		SUB CH;  CONVERT AA AS HEX DIGIT

 BB=ZR<=AA
 CC=AA<=C9
 BB=BB&CC
 IF BB
	AA=AA-ZR
	RETURN
 ENDIF
 BB=HA<=AA
 CC=AA<=HF
 BB=BB&CC
 IF BB
	AA=AA-HA
	AA=AA+CX

	RETURN
 ENDIF
 AA=C0
 ENDSUB

		SUB IN;  INITIALIZE

 ILM=+08920
 I00=+00000
 I01=+00001
 I10=+00010
 I09=+00009
 C0=+000
 C1=+001
 C2=+002
 C3=+003
 EF=+KEF
 C4=+040
 C8=+080
 I16=+00016
 SP=+000
 C9='9'
 ZR='0'
 BL=' '
 HF='F'
 HA='A'
 CX=+010
 IBC=I01
 TR='R'
 ASSOCIATE FCB 1 WITH IBC
 OPEN F1 FOR TR AT IBC
 TR='W'
 IBC++
 ASSOCIATE FCB 2 WITH IBC
 OPEN F2 FOR TR AT IBC
 READ AA FROM F1;  X SUPPRESSES NEW LINE OUTPUT
 OT='T'
 UT=+000
 BB='X'
 UN=AA!=BB;  UN SAYS CHARACTER WAS NOT X SO DONT SUPPRESS
 READ RB FROM F1
 READ RC FROM F1;  COMMENT AND EOL FLAG
 READ SF FROM F1;  TEMPLATE PARAMETER FLAG
 READ MF FROM F1;  EXPANSION OPERATION FLAG
 BB='X'
 AA=MF==BB
 IF AA
	UO=C0
 ELSE
	UO=C1
 ENDIF
 OP='P'; PARAMETER DESIGNATOR IN OPERATION SEQUENCE
 OE='@'; ESCAPE CHARACTER
 OD='V'; CONVERT PARAMETER TO DIGIT IN ACTION SEQUENCE
 OB='!'; POP STACK DESIGNATOR IN OPERATION SEQUENCE
 OS='S'; STACK DESIGNATOR IN OPERATION SEQUENCE
 OH='H'; HEX CONSTANT FETCH AND WRITE

 ON='N'; LITERAL NUMERIC FETCH
 OL='L'; LITERAL BYTE FETCH
 OC='C'; CHARACTER OUT DESIGNATION
 OA='+'; ADD TO STACK DESIGNATION
 OR='-'; SUBTRACT (REDUCE) FROM STACK
 OM='*'; MULTIPLY STACK BY BASE AND ADD
 READ OG FROM F1; IGNORE CHARACTER
 AA='X'
 BB=AA==OG
 IF BB
	UG=+000
 ELSE
	UG=+001
 ENDIF
 READ CC FROM F1; NEW LINE
 AA=NL!=CC; NL IS NEWLINE
 IF AA
	MS 'FLAG LINE'
	STOP 1
 ENDIF
 IUU=+00100
 ENDSUB; IN
		SUB RM;  READ MACROS
 III=I00
 INM=C0
 MM=+127
 WHILE
	READ CC FROM F1
	AA=ER==C0

 ON AA
	CHOOSE ON CC
	CASE OE;ACCEPT THE NEXT CHARACTER UNCRITICALLY
		READ CC FROM F1
		GOTO 77
	CASE RB;BEGIN A DEFINITION
		ILP(INM)=III
		INM++
		ML=+000

	CASE NL;IGNORE
	CASE LF;IGNORE
	CASE RC;IGNORE FOLLOWING COMMENTS AND MARK LINE END
		LS(III)=RC
		III++
		AA=ML<!MM
		IF AA;THIS LINE IS SHORTEST YET
			MM=ML

		ENDIF
		WHILE
			READ CC FROM F1
			AA=CC!=LF
		ON AA
		ENDWHILE
	CASE OG;IF USING IGNORE, IGNORE
		IF UG
		ELSE
			GOTO 77


		ENDIF
	DEFAULT;
	LOC 77
		LS(III)=CC
		III++
		AA=ILM<!III
		IF AA
			MS 'MACMEMXST'
			GOSUB CR
			CLOSE F1
			STOP 5
		ENDIF
		ML++
	ENDCHOOSE
 ENDWHILE
 AA=CC!=EF
 IF AA
	MS 'DEFN READ'
	STOP 2
 ENDIF
 CLOSE F1
 IBC=+00003
 ASSOCIATE FCB 3 WITH IBC
 TR='R'
 OPEN F1 FOR TR AT IBC
 IED=III;END OF DEFINITIONS
 MS 'LOADED...'
 ITU=III
 GOSUB PN
 MS '.BYTES FO'
 MS 'R DEFINES'
 GOSUB CR
 ILP(INM)=III
 ITU=INM
 GOSUB PN
 MS '.MACROS..'
 ITU=MM
 GOSUB PN
 MS ' MIN LEN.'
 GOSUB CR
 ENDSUB; RM
		SUB CR; DO CARRIAGE RETURN/LINE FEED SEQUENCE
 WRITE NL
 WRITE LF
 ENDSUB; CR

		SUB DM; DO MACRO EXPANSION

 IMP=IJJ+I01
 INM++
 IDP=ILP(INM)
 WHILE
	AA=IMP<!IDP
 ON AA; UNTIL WE HAVE READ UP TO THE NEXT MACRO DEFINITION
	AA=LS(IMP)
	IF UO
		AA=AA==MF
	ELSE
		AA=C0
	ENDIF
	IF AA; OPERATION CODE
		IMP++
		O1=LS(IMP); FROM INDICATOR
		IMP++
		AA=LS(IMP)
		O2=AA
		GOSUB CD; FOR DIGIT CONVERSION
		DG=AA
		IMP++
		O3=LS(IMP); DESTAD
	IF UT
			WRITE O1
			WRITE O2
			WRITE O3
	ENDIF
		CHOOSE ON O1
		CASE OP; FETCH PARAMETER
		ITU=IPR(DG)
		CASE OD; CONVERT FROM DIGIT TO CHARACTER
		IAA=IPR(DG)
		AA=IAA
		GOSUB CD
		ITU=AA
		CASE OB; POP STACK
			ITU=ISS(SP)
			AA=SP<=C0
			IF AA
				MS 'S STACKER'
				GOSUB CR
				SP=C1
			ENDIF
			SP--
		CASE OS; FETCH FROM STACK WITHOUT POPPING IT
			ITU=ISS(SP)
		CASE OH; FETCH AND WRITE HEX CONSTANT BYTE
			AA=O2
			GOSUB CH
			IAA=AA
			IAA=IAA*I16
			AA=O3
			GOSUB CH
			IBB=AA
			ITU=IAA+IBB
			O3=OC
		CASE OL; LITERAL BYTE FETCH
			ITU=O2
		CASE ON; LITERAL DIGIT FETCH
			AA=O2
			GOSUB CD
			ITU=AA
		CASE OT; TURN ON TRACE MODE
			UT=+001
		DEFAULT; FETCH  A UNIQUE NUMBER
			ITU=IUU
			IUU++
		ENDCHOOSE
		IF UT
			III=ITU
			GOSUB PN
			ITU=ISS(SP)
			GOSUB PN
			ITU=SP
			GOSUB PN
			ITU=III
			GOSUB CR
		ENDIF
		CHOOSE ON O3
		CASE OC; CHARACTER OUTPUT
			AA=ITU
			WRITE AA INTO F2
		CASE OS; PUT ON STACK
			SP++
			AA=C4<=SP
			IF AA
				MS 'S OVERFLO'
				GOSUB CR
				SP=C4
			ENDIF
			ISS(SP)=ITU
		CASE OP; PUT INTO PARAMETER LOCATION
			IPR(DG)=ITU
		CASE OA; ADD TO STACK
			IAA=ISS(SP)
			IAA=IAA+ITU
			ISS(SP)=IAA
		CASE OR; REDUCE (SUBTRACT) FROM STACK
			IAA=ISS(SP)
			IAA=IAA-ITU
			ISS(SP)=IAA
		CASE OM; MULTIPLY BY BASE AND ADD
			IAA=ISS(SP)
			IAA=IAA*I10
			IAA=IAA+ITU
			ISS(SP)=IAA
		CASE OH; OUTPUT HIGH BYTE
			UNPACK(ITU,AA,BB)
			WRITE AA INTO F2
		DEFAULT; WRITE OUT AS A DECIMAL NUMBER
			GOSUB WN
		ENDCHOOSE
	ELSE; END OF ACTION SECTION
	AA=LS(IMP)
	IF UN
		BB=AA!=RC
	ELSE
		BB=C1
	ENDIF
	IF BB
		WRITE AA INTO F2
	ELSE
		WRITE NL INTO F2
		WRITE LF INTO F2
	ENDIF
	ENDIF
	IMP++
 ENDWHILE
 UT=+000
 ENDSUB; DM
 BOTTOM; END OF TINCMP 8086 CP/M COMPILER