/3  OS/8 FORTRAN  (PASS TWO)
/
/ VERSION 4A  PT 16-MAY-77
/
/	OS/8 FORTRAN COMPILER - PASS 2
/
/		BY: HANK MAURER
/		UPDATED BY: R. LARY + M. HURLEY
/
/
/COPYRIGHT  (C)  1974,1975 BY DIGITAL EQUIPMENT CORPORATION
/
/
/
/
/
/
/
/
/
/
/THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE
/AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
/CORPORATION.  DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
/FOR ANY ERRORS THAT MAY APPEAR IN THIS DOCUMENT.
/
/THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER
/UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED
/(WITH INCLUSION OF DIGITAL'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH
/SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DIGITAL.
/
/DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY FOR THE USE
/OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY
/DIGITAL.
/
/
/
VERSON=4
/SEE F4.PA FOR LIST OF MAINTENANCE RELEASE CHANGES -S.R.
/ALSO, ADDED SAFETY CDF 0 TO BUMP ROUTINE TO FIX BUG
/MASSAGED LINK IN THAT AREA TO GET ROOM
/ALSO,
/	FIXED BUG RE DN ERROR PRINTING WRONG LINE NUMBER
/
/
/CHANGES FOR OS/8 V3D AND OS/78 BY P.T.
/.PATCH LEVEL FOR PASS2 IS IN LOCATION 327

	IFNDEF	OVERLY	<OVERLY=0>
	IFNZRO	OVERLY	<NOPUNCH>
	*2			/V3C
TEM,	1			/V3C
LINENO,	1			/LINE NUMBER
VERS,	-VERSON			/VERSION NUMBER
ERRPTR,	5001			/POINTER TO THE ERROR LIST
FILDEV,	0			/THIS IS THE FILE DESCRIPTOR
FILBLK,	0			/FOR RALF
X10,	COMREG-1		/INTER PASS COM REGION
X11,	0
X12,	0
X13,	0
X14,	0
X15,	0
X16,	0
X17,	0			/AUTO INDEX REGISTERS
ENTRY,	0			/THINGS USED BY SYMBOL
				/TABLE FIDDLER
OENTRY,	0
BUCKET,	0
TYPE,	0
TEMP,	0			/GENERAL TEMPS
TEMP2,	0
ARG1,	0			/ARGS AND TYPES
BASE1,	0
TYPE1,	0
ARG2,	0
BASE2,	0
TYPE2,	0
TMPCNT,	1			/TEMP COUNT
TMPMAX,	0			/MAX TEMP COUNT
LITNUM,	0			/LITERAL DISPLACEMENT
	TMPBLK=2
	OUBUF=4400
	COMREG=4600
	STACK1=4700
	OVRLAY=5000
	NPOVLY=700
	XRBUFR=6600
	STACK=7000		/STACK-5 CAN'T BE 0
	INBUF=7200
	NPPAS3=1600
ARG,	0			/TEMP FOR CODE
AC,	0			/AC FOR MULTIPLY ROUTINE
XR,	0			/XR CHAR FOR OADDR
MQ,	0			/MQ FOR MULTIPLY ROUTINE
XRNUM,	0			/TEMP USED IN XR STUFF
WHATAC,	0			/POINTER TO VAR
WHATBS,	0			/JUST STORED
FREEXR,	0			/NUMBER OF FREE
				/INDEX REG
DIMPTR,	0			/POINTER TO DIM INFO
				/AFTER GETSS
NARGS,	0			/ARG COUNT FOR SS VAR
				/COMPILE
GLABEL,	1			/GENERATED LABEL COUNTER
STKLVL,	STACK			/STACK LEVEL (CHANGED
				/BY DO)
COMMA,	254			/,
PLUS,	253			/+
IFLABL,	0			/HOLDS LABEL FOR LOG IF
DOTEMP,	7000			/DO LOOP TEMP COUNTER
BINARY,	0			/BINARY IO=1, FORMATTED=0
INPUT,	0			/INPUT=1 OUTPUT=0 FOR IO STMTS
PROGNM,	0			/POINTER TO PROG/FUNC NAME
FUNCTN,	0			/0=MAIN, 1=FUNC, -2=SUBR
ARGLST,	0			/POINTER TO ARG LIST
DATASW,	0			/=1 IF THIS IS A DATA STMT
GCTEMP,	0			/TEMP USED BY GENCAL
EXTLIT,	0			/EXTERNAL LITERALS LIST
ELCNT,	0			/AND COUNT
IOLOOP,	0			/IO LOOP SWITCH
ARGIO,	0			/ARG IO SWITCH
F1LNAM,	0617;2224;2216;2415	/FILE NAME FORTRN.TM
DEVH,	7607			/DEVICE HANDLER ADDRESS
ACSWIT,	0			/IS NON ZERO IF CALLING AN ARG
IOSTMT,	0			/SET 1 IF IN IO STMT
				/(FOR IMPLIED LOOPS)
FMODE,	1			/1 IF IN F OR D MODE (0 IF E)
ASFSWT,	0			/1 IF ASF PROLOG, -1 IF
				/ASF END, 0 OTHER
JSRLBL,	0			/LABEL NUMBER FOR CALLS TO ARGS
DPUSED,	0			/=1 IF DP HARDWARE USED
QM4,	-4
Q260,	260
QTTYOU,	TTYOUT
QERMSG,	ERMSG
QNEXT,	NEXT
QNEXTM,	NEXT-2
QUCODE,	UCODE
QCODE,	CODE
QINWOR,	INWORD
QONUMB,	ONUMBR
QSAVEA,	SAVEAC
Q6M3,
Q5,	5
QGENCO,	GENCOD
QM6,	-6
QOPCOD,	OPCOD
QOPCDE,	OPCODE
QOADDR,	OADDR
Q17,	17
QTTYMS,	TTYMSG
QXRTBL,	XRTABL
QCHKXR,	CHEKXR
QGENSF,	GENSTF
QGENSE,	GENSTE
QOSNUM,	OSNUM
QCRLF,	CRLF
QOTAB,	OTAB
QOUTSY,	OUTSYM
QGARG,	GARG
Q20,	20
Q40,	40
QOUTNA,	OUTNAM
QLITRL,	LITRL
Q200,	200
Q255,	255
Q3,	3
QOLABE,	OLABEL
QGETSS,	GETSS
Q256,	256
QSAVAC,	SAVACT
QSKPIR,	SKPIRL
QGENCA,	GENCAL
QLOADA,	LOADA
QMUL12,	MUL12
QGARGS,	GARGS
QOINS,	OINS
QOCHAR,	OCHAR
QNUMBR,	NUMBRO
QXRBUF,	XRBUFR
QTTYP2,	TTYP2C
QTTCRL,	TTCRLF
QM63,	-63
Q7605,	7605
RELCD,	0
QLABEL,	NLABEL	
P0F1,	5274		/101-2605
P0F2,	VERROR
/ OUTPUT UTILTIY ROUTINES
	PAGE
OCNT,
CRLF,	0			/OUTPUT CR LF
	TAD	(215
	JMS I	QOCHAR
	TAD	(212
	JMS I	QOCHAR
	TAD	(200
	KRS
	TAD	(-203
	SNA CLA
	KSF		/CHECK FOR ^C
	JMP I	CRLF
	JMP I	(7605
NCHAR,
OSNUM,	0			/PRINT STMT NUMBER
	IAC			/SKIP POINTER WORD
	DCA	NAMPTR
	TAD	(6211		/ALWAYS IN FIELD 1
	DCA	NAMCDF
	TAD	OSNUM		/SAVE ENTRY POINT
	DCA	OUTNAM
	TAD	(243		/GET FIRST CHAR (ALWAYS #)
	JMP	L6201		/GO PRINT NAME
TTCHAR,
OUTSYM,	0			/PRINT OPCODE
	DCA	NAMPTR		/SAVE POINTER TO STUFF
	TAD	L6201		/ALWAYS FIELD 0
	DCA	NAMCDF
	TAD	OUTSYM		/SAVE ENTRY
	DCA	OUTNAM
	JMP	NAMCDF		/PRINT REST
ONUMT,
OUTNAM,	0			/OUTPUT NAME
	DCA	NAMPTR		/SAVE ADDRESS OF NAME
	RDF			/GET FIELD OF NAME
	TAD	L6201
	DCA	NAMCDF		/SAVE AS CDF
	TAD I	NAMPTR		/GET FIRST CHAR (ALREADY ASCII)
	ISZ	NAMPTR		/SKIP OVER TYPE AND DIM PTR
	ISZ	NAMPTR
L6201,	CDF
	JMS I	QOCHAR		/OUTPUT CHAR
	ISZ	NAMPTR
NAMCDF,	0
	TAD I	NAMPTR		/GET NEXT TWO CHARS
	CDF
	SNA			/IS NAME DONE ?
	JMP I	OUTNAM		/YES
	DCA	NCHAR		/SAVE TWO CHARS
	TAD	NCHAR
	RTR			/GET UPPER CHAR
	RTR
	RTR
	TAD	(240
	AND	(77
	TAD	(240
	JMS I	QOCHAR		/OUTPUT IT
	TAD	NCHAR		/NOW DO LOWER
	AND	(77
	SNA
	JMP I	OUTNAM		/NAME DONE
	TAD	(240
	AND	(77
	TAD	(240
	JMP	L6201+1		/GO AND OUTPUT IT
ONUMBR,	0			/OUTPUT OCTAL NUMBER
	DCA	ONUMT		/SAVE TEMPORARILY
	TAD	QM4		/4 DIGITS
	DCA	OCNT
OLOOP,	TAD	ONUMT
	CLL RTL
	RAL
	DCA	ONUMT
	TAD	ONUMT
	RAL
	AND	(7
	TAD	Q260
	JMS I	QOCHAR
	ISZ	OCNT
	JMP	OLOOP
	JMP I	ONUMBR
TTYP2C,	0			/PRINT 2 CHARS ON THE TTY
	DCA	TTCHAR
	TAD	TTCHAR
	RTR
	RTR
	RTR
	JMS	CONVRT
	TAD	TTCHAR
	JMS	CONVRT
	JMP I	TTYP2C
NAMPTR,
CONVRT,	6401			/CONVERT TO ASCII
	AND	(77
	SZA
	TAD	(240
	AND	(77
	TAD	(240
	JMS I	QTTYOUT
	JMP I	CONVRT
TTCRLF,	0
	TAD	(215
	JMS I	QTTYOUT
	TAD	(212
	JMS I	QTTYOUT
	JMP I	TTCRLF
TTYMSG,	0			/PRINT 2 CHAR ERROR MESSAGE
	CDF
	TAD I	TTYMSG
	ISZ	TTYMSG		/PRINT ERROR MESSAGE
	JMS I	QERMSG
FATAL,	JMP I	QNEXT		/FATAL ERROR MESSAGE
	TAD I	FATAL
	JMS I	QERMSG
	JMP I	Q7605		/RETURN TO PS8
DP2C1,	TEXT	'.+2,1'
NEG,	JMS I	QUCODE		/NEGATE CODE
	NEGTBL-1
	JMP I	QNEXT
	PAGE
/ OPCODE JUMP TABLE

	TAD	TEMP2
	SKP			/CODE ALREADY READ
NEXT,	JMS I	QINWORD		/GET NEXT INPUT WORD
	TAD	(XPUSH		/INDEX INTO JUMP TABLE
	DCA	TEMP2
	CDF 10
	TAD I	TEMP2
	CDF 0
	DCA	TEMP2	/GET JUMP ADDRESS
	JMP I	TEMP2	/GO THERE
/OPTIMIZING RELATIONAL CODE FOR OS/8 F4
/COMPLIMENTS OF R.L.

LE,	STL RTL		/2
LT,	TAD	QM4	/GENERATE -4 FOR LT, -2 FOR LE
	JMP	GE+1	/GO TO COMMON RELATIONAL CODE
GT,	STL RTL
GE,	IAC		/GENERATE 1 FOR GE, 3 FOR GT
	DCA	RELCD	/ALL THIS FUNNY STUFF IS BECAUSE SOME
	JMS I	QCODE	/OF THE RELATIONAL SKELETONS OPTIMIZE BY
	LETABL-6;5	/PERFORMING THE RELATIONAL ON THE NEGATIVE
	TAD	RELCD	/OF THE FAC - WHEN THIS HAPPENS SPECIAL
	SPA		/CODE IN THE SKELETON DOES AN "ISZ RELCD",
	CIA		/CHANGING ABS(RELCD) TO ITS OPPOSITE RELATIONAL
	JMP	RELGEN	/E.G. GE(1) TO LE(2), LE(-2) TO GE(-1)

EQ,	CLA IAC		/SINCE EQ AND NE ARE SIGN-INDEPENDENT,
NE,	DCA	RELCD	/WE DON'T NEED THAT KLUDGE BUT FOR COMPATIBILITY
	JMS I	QCODE	/WITH RTPS THE OS/8 FORTRAN SYSTEM FUNCTION
	EQTABL-6;5	/"#CEQ" WORKS THE WRONG WAY - IT PRODUCES
	CLA IAC		/A 1.0 IF THE COMPLEX AC WAS (0.,0.)
	AND	RELCD	/AND A 0.0 OTHERWISE - SO WE HAVE TO REVERSE
	SZA CLA		/THE SENSE OF COMPLEX .EQ. AND .NE. RELATIONS.
RELGM1,	TAD	Q5
RELGEN,	DCA	RELCD	/STORE "FINAL" RELCD
	JMS I	QINWORD	/GENTLY PROBE AHEAD IN THE INPUT
	DCA	TEMP2
	TAD	TEMP2
	TAD	(XPUSH-XLOGIF
	SNA CLA		/IF THIS WAS THE TOP RELATION OF A LOGICAL IF,
	JMP	LIFOPT	/WE'RE IN A POSITION TO OPTIMIZE
	TAD	RELCD	/OTHERWISE OUTPUT A CALL TO THE
	CLL RAL		/ROUTINE CORRESPONDING TO THE RELATIONAL
	TAD	(LTRNE
	DCA	.+3
	CLA IAC
	JMS I	(OJSR	/GENERATE A JSA #XX
	0
	JMP I	QNEXTM2	/PROCESS THE WHATCHIMACALLIT

LIFOPT,	TAD	TYPE1	/SEE IF WE SHOULD GENERATE A "STARTF" FIRST
	AND	Q17	/ONLY WORRY ABOUT D.P.
	TAD	QM4	/SINCE THE ROUTINE #CEQ DOES A STARTF
	DCA	FMODE	/FMODE=0 ONLY IF ARGS WERE D.P.
	JMS I	QGENSF	/GENERATE STARTF IF NECESSARY
	JMP I	.+1
	LIFBGN+1	/GO TO LOGICAL IF PROCESSOR

EQV,	JMS I	QCODE	/.EQV. LOGICAL OPERATOR
	EQVTBL-6;0
	JMP	RELGM1
/ PASS TWO OUTPUT ROUTINE
OCHAR,	0			/OUTPUT A CHAR TO THE
				/RALF INPUT FILE
	AND	(377
	DCA	OUTEMP		/SAVE CHAR
	ISZ	OUJUMP		/BUMP THREE WAY SWITCH
OUJUMP,	JMP	.
	JMP	CHAR1
	JMP	CHAR2
	TAD	OUTEMP		/HIGH FOUR BITS GO INTO
	CLL RTL			/THE HIGH ORDER BITS OF THE
	RTL			/FIRST WORD OF THE TWO WORD PAIR
	AND	(7400		/SEE NOTE * BELOW
	TAD I	OUPOLD		/COMBINE WITH OTHER BITS
	DCA I	OUPOLD
	TAD	OUTEMP		/THE OTHER FOUR BITS OF THIS CHAR
	CLL RTR			/GO INTO THE HIGH ORDER FOUR
	RTR			/BITS OF THE SECOND
				/WORD OF THE PAIR
	RAR
	AND	(7400
	TAD I	OUPTR
	DCA I	OUPTR
	TAD	OUJMP		/RESET 3 WAY BRANCH
	DCA	OUJUMP
	ISZ	OUPTR		/BUMP BUFFER POINTER
	ISZ	OUWDCT		/AND DOUBLE WORD COUNTER
	JMP I	OCHAR		/BUFFER NOT FULL
	JMS	OUDUMP		/DUMP IT
	JMP I	OCHAR
CHAR2,	TAD	OUPTR		/SAVE FIRST WORD POINTER
	DCA	OUPOLD
	ISZ	OUPTR		/GO TO SECOND WORD
CHAR1,	TAD	OUTEMP		/STORE CHAR 1 OR 2
	DCA I	OUPTR
	JMP I	OCHAR
OUTEMP,
OUDUMP,	0			/BUMP THE DUFFER
	TAD	OSIZE		/ANY ROOM LEFT ?
	SNA
	JMP	OUERR
	IAC
	DCA	OSIZE		/YES, ITS OK
	JMS I	DEVH		/WRITE
	4200			/CONTROL WORD
	OUBUF			/BUFFER POINTER
OBLOCK,	0			/BLOCK NUMBER
	JMP	OUERR		/ERROR
	ISZ	OBLOCK		/INCREMENT BLOCK NUMBER
	ISZ	FILSIZ		/AND FILE SIZE
	TAD	OBLOCK-1	/SET BUFFER POINTER
	DCA	OUPTR
	TAD	(-200		/SET DOUBLE WORD COUNT
	DCA	OUWDCT
	JMP I	OUDUMP
OUERR,	JMS I	(FATAL		/FATAL OUTPUT ERROR
	1706
/ *  THE PONY EXPRESS STARTED IN 1860 AND ONLY RAN
/	FOR 19 MONTHS WHILE LOSING $200,000.
OUPOLD,	0
OUPTR,	OUBUF
OUJMP,	JMP	OUJUMP
OUWDCT,	-200
OSIZE,	0
DD1,	TEXT	'1'
	PAGE
/ READ FROM FORTRN.TM

INWORD,	0			/READ A WORD FROM INPUT FILE
	ISZ	INBCNT		/ANYTHING LEFT IN BUFFER ?
	JMP	NOREAD		/YES
	ISZ	INRCNT		/ANYTHING LEFT IN FILE?
	SKP
	JMP I	(END		/NO, END OF PROG
	JMS I	DEVH		/READ NEXT BLOCK
X200,	0200
	INBUF
INBLOK,	0
	JMP	INERR		/INPUT ERROR
	ISZ	INBLOK		/BUMP BLOCK NUMBER
	TAD	(-400		/RESET COUNTER
	DCA	INBCNT
	TAD	INBLOK-1	/RESET POINTER
	DCA	INBPTR
NOREAD,	TAD I	INBPTR		/GET WORD FROM BUFFER
	ISZ	INBPTR		/BUMP BUFFER POINTER
	JMP I	INWORD
INERR,	JMS I	(FATAL		/FATAL INPUT ERROR
	1105
INBCNT,	-1			/FORCE READ FIRST TIME
INBPTR,	0
INRCNT,	0
/ CODE UTILITIES
GETSS,	0			/GET POINTER TO DIM INFO
	CDF	10
	IAC
	DCA	DIMPTR		/ADDR OF TYPE WORD
	TAD I	DIMPTR
	ISZ	DIMPTR		/MOVE TO DIM/EQUIV POINTER
	AND	X200		/EQUIV INFO ?
	SNA CLA
	JMP	.+3		/NONE
	TAD I	DIMPTR		/SKIP EQUIV INFO
	DCA	DIMPTR
	TAD I	DIMPTR		/ADDRESS OF DIM INFO
	JMP I	GETSS
NUMBRO,	0			/OUTPUT 15 BIT OCTAL NUMBER
	TAD	AC		/IS HIGH DIGIT 0 ?
	SNA
	JMP	.+3		/YES, PRINT 4 DIGITS ONLY
	TAD	Q260		/MAKE IT ASCII
	JMS I	QOCHAR		/PUT IT
	TAD	MQ		/NOW LOW FOUR DIGITS
	JMS I	QONUMBR
	JMP I	NUMBRO
UCODE,	0			/GEN CODE FOR UNARY OPERATORS
	JMS I	QSAVEAC		/SAVE AC IF NEEDED
	JMS	GARG
	JMP	OTERR		/OPERATOR/TYPE ERROR
	TAD	ARG1		/IS ARG IN AC ?
	SNA CLA
	TAD	Q5		/YES, USE SECOND HALF OF TABLE
	TAD	TYPE1
	TAD I	UCODE		/PLUS TABLE ADDRESS
	DCA	USKEL
	CDF	10
	TAD I	USKEL		/ADDR OF SKELETON
	SNA
	JMP	OTERR		/0 MEANS BAD
				/OPERATOR/TYPE COMBO
	DCA	USKEL		/SAVE SKELETON ADDR
	JMS I	QGENCOD		/GO DO THE CODE
USKEL,	0
	DCA I	X16		/RESULT IN AC
	ISZ	X16		/BUMP STACK POINTER
	ISZ	X16		/TYPE IS ALREADY THERE
	ISZ	UCODE		/FIX RET ADDR
	JMP I	UCODE
GARG,	0			/GET ONE ARG
	CLL CMA RTL		/BACK UP ONE ENTRY
	TAD	X16
	DCA	X16
	TAD	X16		/USABLE POINTER
	DCA	X15
	TAD I	X15		/GET OPERAND
	DCA	ARG1
	TAD I	X15
	DCA	TYPE1
	TAD I	X15
	DCA	BASE1
	TAD	TYPE1		/CHECK TYPE
	TAD	QM6
	SMA CLA
	JMP I	GARG		/TAKE ERROR EXIT
	ISZ	ARG2		/MAKE SURE ARG2 ISN'T ZERO
	JMS I	(MPTRA1		/MOVE THE POINTER IF
				/THERE IS ONE
	ISZ	GARG
	JMP I	GARG

TTYOUT,	0			/OUTPUT TO THE TTY
	TLS
	TSF
	JMP	.-1
	CLA
	KSF
	JMP I	TTYOUT		/NO KEYBOARD FLAG
	KRB
	AND	(177		/ACCEPT PARITY ASCII
	TAD	(-3		/^C ?
	SNA
	JMP I	Q7605		/YES, BACK TO PS8
	TAD	(3-17		/^O ?
	SZA CLA
	JMP I	TTYOUT		/NO, RETURN
	DCA	TTYOUT+1	/KILL OUTPUT STUFF
	DCA	TTYOUT+2
	DCA	TTYOUT+3
	JMP I	TTYOUT		/RETURN
LTRNE,	TEXT	'#NE'
	TEXT	'#GE'
	TEXT	'#LE'
	TEXT	'#GT'
	TEXT	'#LT'
	TEXT	'#EQ'
	PAGE
/ SOME TEXT

P2,	TEXT	'+2'
XVAL,	TEXT	'#VAL'
DP4,	TEXT	'.+4'
FADD,	TEXT	'FADD'
FLDA,	TEXT	'FLDA'
FSUB,	TEXT	'FSUB'
/ SAVE AC ROUTINES
SAVACT,	0			/SAVE TOP OF STACK IF
				/NECESSARY
	TAD	SAVACT		/SAVE RETURN ADDR
	DCA	SAVEAC
	CLL CMA RAL
	JMP	SAVEAC+2	/BACK UP ONLY ONE ENTRY
SAVEAC,	0			/STORE AC IF NEEDED
	TAD	(-5		/LOOK AT STACK TWO DOWN
	TAD	X16
	DCA	SATEMP
	TAD I	SATEMP		/IF 0, RESULT WAS LEFT IN AC
	SZA CLA
	JMP I	SAVEAC		/NO, NO STORE NEEDED
	TAD	TMPCNT		/STORE TEMP NUMBER
	DCA I	SATEMP
	ISZ	SATEMP		/MOVE TO TYPE WORD
	TAD I	SATEMP		/GET TYPE
	JMS	SAVE		/GO DO ACTUAL STORE
	JMP I	SAVEAC
SAVE,	0			/SAVE AC
	DCA	ACSTOR		/THIS IS THE TYPE
	TAD	ACSTOR		/IS IT COMPLEX OR DOUBLE?
	TAD	QM4
	SNA
	JMP	NOC		/ITS DOUBLE
	IAC
	SZA CLA
	JMP	NOCORD		/NO
	JMS I	QGENCOD		/STARTE; FLDA #CAC
	SEGCAC-1
NOC,	JMS	ACSTOR		/%FSTA #TMP+XXXX
	JMS	TMPBMP		/THIS USE TWO TEMPS
	JMP I	SAVE
NOCORD,	JMS	ACSTOR		/%FSTA #TMP+XXXX
	JMP I	SAVE
SATEMP,
ACSTOR,	0			/GENERATES FSTA TEMP+XXXX
	JMS I	QOPCOD		/OUTPUT %FSTA %TEMP+XXXX
	FSTA
	JMS I	QOADDR
	TMPCNT			/TMPCNT CONTAINS THE
				/ARG NUMBER
	JMS	TMPBMP		/BUMP TEMPORARY NUMBER
	JMP I	ACSTOR

TMPBMP,	0		/ROUTINE TO BUMP TEMPORARIES
	TAD	TMPCNT		/BIGGER THAN MAX?
	CIA CLL
	TAD	TMPMAX
	SZL CLA
	JMP	.+3		/GO BUMP TEMP CNT
	TAD	TMPCNT		/NEW TEMP MAX
	DCA	TMPMAX
	ISZ	TMPCNT		/INCR TEMP COUNT
	JMP I	TMPBMP
/ PUSH ARG ONTO STACK
PUSH,	JMS	SAVEAC		/GO SAVE AC IF NEEDED
	JMS I	QINWORD		/GET ADDR OF NEW VAR
	DCA	TEMP		/SAVE IT
	TAD	TEMP		/PUSH IT
	DCA I	X16
	ISZ	TEMP		/GO TO TYPE
	CDF	10
	TAD I	TEMP		/GET TYPE
	CDF
	AND	Q17		/PUSH TYPE
	DCA I	X16		/ONTO STACK
CKPDL,	DCA I	X16		/ZERO BASE WORD
	TAD	X16		/IS STACK FULL ?
	CIA CLL
	TAD	(STACK+177
	SZL CLA
	JMP I	QNEXT		/NO, OK
	TAD	STKLVL		/RESET STACK LEVEL
	DCA	X16
	JMS I	QTTYMSG		/PRINT MESSAGE
	2004
DPUSH,	JMS I	QINWORD		/GET THE VAR NAME PTR
	DCA I	X16		/PUSH IT
	JMS I	QINWORD		/NOW GET THE DISPLACEMENT
	JMP	CKPDL-1		/GO CHECK FOR OVERFLOW
STARTF,	TEXT	'STARTF'
/ ARITHMETIC IF
ARTHIF,	JMS I	QUCODE		/GET ARG INTO AC
	AIFTBL-1
	JMS I	QGENSF		/DO ALL TRANSFERS IN FMODE
	TAD	(JLT		/FIRST OPCODE
	DCA	AJUMP
AIFLUP,	JMS I	QINWORD		/GET NEXT INPUT
	DCA	TEMP2		/SAVE IT IN CASE ITS NOT LABEL
	TAD	TEMP2
	CLL
	TAD	(XPUSH-XLAST	/IS IT A LABEL ?
	SNL CLA
	JMP I	QNEXTM2		/NO, PROCEED
	JMS I	QOPCDE
AJUMP,	0			/OUTPUT CORRECT JUMP
	TAD	TEMP2
	CDF	10
	JMS I	QOSNUM		/NOW THE LABEL
	JMS I	QCRLF
	ISZ	AJUMP		/MOVE TO NEXT OPCODE
	ISZ	AJUMP
	JMP	AIFLUP
DOT,	TEXT	'.'
DP8,	TEXT	'.+10'
	PAGE
/ PICK UP TOP TWO ARGS

GARGS,	0			/GET TOP 2  ARGS FROM STACK
	TAD	X16
	TAD	QM6		/BACK TWO OPERANDS
	DCA	X15
	TAD	X15
	DCA	X16		/AND OFFICIALLY POP THE STACK
	TAD I	X15		/GET FIRST ARG
	DCA	ARG1
	TAD I	X15		/AND TYPE
	DCA	TYPE1
	TAD I	X15
	DCA	BASE1		/AND FIRST BASE (IN
				/CASE OF SS)
	TAD I	X15		/NOW SECOND ARG
	DCA	ARG2
	TAD I	X15
	DCA	TYPE2
	TAD I	X15
	DCA	BASE2
	TAD	TYPE1		/TYPES MUST BE LT 6
	TAD	QM6
	SMA CLA
	JMP I	GARGS		/RETURN BAD
	TAD	TYPE2
	TAD	QM6
	SPA CLA
	ISZ	GARGS		/FIX RETURN
	JMS	MPTRA1		/GET ARG1 POINTER IF NEEDED
	TAD	ARG2		/IS ARG2 A POINTER
	TAD	(-61
	SZA CLA
	JMP I	GARGS		/NO, RETURN
	TAD	ARG1		/IS ARG1 IN THE AC ?
	SZA CLA
	JMP	.+5		/NO
	TAD	TMPCNT		/YES, STORE THE AC
	DCA	ARG1
	TAD	TYPE1		/GET TYPE
	JMS I	(SAVE
	TAD	BASE2		/MOVE POINTER FROM TEMP
				/TO BASE+3
	DCA	ARG2
	JMS I	QGENCOD
	MPTR3-1
	TAD	(62		/ARG IS NOW POINTED TO
				/BY BASE+3
	DCA	ARG2
	JMP I	GARGS
MPTRA1,	0			/MOVE ARG1 POINTER TO BASE
	TAD	ARG1
	TAD	(-61
	SZA CLA
	JMP I	MPTRA1
	TAD	ARG2
	SZA CLA
	JMP	.+5
	TAD	TMPCNT
	DCA	ARG2
	TAD	TYPE2		/GET THE TYPE
	JMS I	(SAVE
	TAD	BASE1
	DCA	ARG1
	JMS I	QGENCOD
	MPTR0-1
	TAD	(61
	DCA	ARG1		/SET ARG1 TO IND0
	JMP I	MPTRA1
/ BINARY OPERATORS
CODE,	0			/GENERATE CODE FOR
				/BINARY OPERATORS
	JMS	GARGS		/GET OPERANDS
	JMP	OTERR		/BAD TYPE OPERATOR COMBO
	TAD	TYPE1		/INDEX INTO TYPE CHECK TABLE
	CLL RTL
	TAD	TYPE1
	TAD	TYPE2
	CLL RAL
	TAD	(TYPMIX-14	/POINTER TO CORRECT ENTRY
	DCA	SKEL
	CDF	10
	TAD I	SKEL		/RESULTING TYPE
	SNA
	JMP	TYPERR		/THIS MIX IS ILLEGAL
	DCA	TYPE1		/SAVE RESULT TYPE
	ISZ	SKEL		/GET INDEX INTO
				/SKELETON TABLE
	TAD I	SKEL
	CDF
	TAD I	CODE		/PLUS BASE GIVES ADDR
				/OF M,AC CASE
	DCA	SKEL
	CDF	10
	TAD I	SKEL		/IS THIS TYPE OPER
				/COMBO LEGAL ?
	SNA CLA
	JMP	OTERR		/NO
	ISZ	CODE		/POINTS TO RESULTING TYPE
	TAD	ARG2
	SZA CLA
	ISZ	SKEL		/SECOND ARG IS IN MEMORY
	TAD	ARG1
	SNA CLA			/SKIP ON M,M CASE
	ISZ	SKEL		/MOVE TO AC,M CASE
	TAD I	SKEL		/PICK UP POINTER TO SKELETON
	DCA	SKEL
	JMS I	QGENCOD		/GO DO THE CODE
SKEL,	0
	DCA I	X16		/RESULT IS IN THE AC
	TAD I	CODE
	SNA			/IS TYPE SAME AS ARGS ?
	TAD	TYPE1		/YES
	DCA I	X16		/STORE IT
	DCA I	X16		/ZERO BASE WORD
	TAD I	CODE		/IS TYPE SAME AS ARGS ?
	SZA
	DCA	FMODE		/NO, WE'RE NOW IN FMODE
	JMP I	CODE
TYPERR,	JMS	BUMP		/PUT FALSE VALUE ONTO STACK
	JMS I	QTTYMSG		/OUTPUT ERROR
	1524
OTERR,	JMS	BUMP		/PUT FALSE VALUE ONTO STACK
	JMS I	QTTYMSG
	1724
XDPP6,	TEXT	'#DPT+6'
XFIX,	TEXT	'#FIX'
	PAGE
/ CODE GENERATOR (FROM SKELETONS)

GENCOD,	0			/CODE GENERATOR ROUTINE
	CDF
	TAD	X14
	DCA	TEMP14		/FIX COMPLEX FUNCTION BUG
	TAD I	GENCOD		/GET SKELETON ADDRESS
	ISZ	GENCOD
MPOPUP,	DCA	X14		/HERE ON MACRO END
	DCA	MRETN
CODLUP,	CDF	10		/STUFF IS IN FIELD 1
	TAD I	X14		/GET OPCODE
	CDF
	SNA
	JMP	ENDM		/IS IT END OF A MACRO ?
	SPA
	JMP	MACRO		/ITS A MACRO REFERENCE
	DCA	.+2		/SAVE OPCODE
	JMS I	QOPCOD		/OUTPUT IT
	0
	CDF	10
	TAD I	X14		/ADDRESS ?
	CDF
	SNA
	JMP	NOADDR		/NO OPERAND FOR THIS INSTR
	SPA
	JMP	DOADDR		/ADDRESS IS AN OPERAND
	DCA	TEMP
	JMS I	QOTAB		/ADDRESS IS A SPECIFIC
	TAD	TEMP
	JMS I	QOUTSYM
NOADDR,	JMS I	QCRLF
	JMP	CODLUP		/DO NEXT LINE
DOADDR,	IAC			/IS IT ARG1 ?
	SZA CLA
	JMP	ITSA2		/NO, ITS ARG2
	JMS I	QOADDR		/OUTPUT ARG1 ADDRESS FIELD
	ARG1
	JMP	CODLUP
ITSA2,	JMS I	QOADDR		/OUTPUT ARG2 ADDRESS
	ARG2			/FIELD
	JMP	CODLUP
MACRO,	TAD	Q5	/CODES BETWEEN -1 AND -5 ARE SPECIAL
	SPA
	JMP	.+4	/NOT ONE OF THEM
	TAD	(JMP MJTBL
	DCA	.+1
	HLT		/GO TO PROPER ROUTINE
	DCA	MSTART		/SAVE START OF MACRO
	TAD	X14		/SAVE RETURN ADDRESS
	DCA	MRETN
	TAD	MSTART		/GO DO MACRO
	DCA	X14
	JMP	CODLUP
ENDM,	TAD	MRETN		/WAS THIS A MACRO ?
	SZA
	JMP	MPOPUP		/YES - GET OUT OF IT
	TAD	TEMP14
	DCA	X14		/RESTORE X14 FOR FUNCAL
	JMP I	GENCOD	/AND EXIT

LOADA1,	JMS I	(LOADA		/GENERATE LOAD
	ARG1			/IF NECESSARY
	JMP	CODLUP
LOADA2,	JMS I	(LOADA		/GENERATE LOAD
	ARG2			/IF NECESSARY
	JMP	CODLUP
DOSTE,	JMS I	QGENSE		/STARTE IF IN F MODE
	JMP	CODLUP
SGNNEG,	ISZ	RELCD	/CHANGE SIGN OF RELATIONAL OPERATOR
	JMP	CODLUP
	MSTART=TEMP
MRETN,	0			/MACRO RETURN ADDRESS
TEMP14,	0

MJTBL,	JMP	SGNNEG	/-5 - NEGATE RELATIONAL SIGN
	JMP	LOADA2	/-4 - LOAD ARG 2
	JMP	LOADA1	/-3 - LOAD ARG 1
	JMP	DOSTE	/-2 - START E MODE
	JMS I	QGENSF	/-1 - START F MODE
	JMP	CODLUP

XSET,	TEXT	'SETX'
ZEROC1,	TEXT	'0,1'
/ GOTO'S AND ASSIGN
CGOTO,	JMS	GTSTUF		/LOOK AT INDEX
	JMS I	QGENCOD		/OUTPUT COMPUTED GOTO CODE
	CGTCOD-1
	JMS I	QINWORD		/GET COUNT
	CIA
	DCA	TEMP2
CGTLUP,	JMS	JAGEN
	ISZ	TEMP2
	JMP	CGTLUP
	JMP I	QNEXT
GOTO,	JMS I	QGENSF		/ALL TRANSFERS IN F MODE
	JMS	JAGEN
	JMP I	QNEXT

JAGEN,	0
	JMS I	QOPCDE		/OUTPUT JA'S
	JA
	JMS I	QINWORD		/GET THE LABEL
	CDF	10
	JMS I	QOSNUM		/OUTPUT IT AS THE ADDRESS
	JMS I	QCRLF
	JMP I	JAGEN

GTSTUF,	0
	JMS I	QGARG		/GET THE ARG
	JMP	GTTYPE
	CLL CMA RTL		/CHECK THE TYPE
	TAD	TYPE1
	SMA CLA
	JMP	GTTYPE		/NOT INTEGER OR REAL
	TAD	ARG1		/IS IT IN THE AC ?
	SNA CLA
	JMP I	GTSTUF		/YES ALREADY
	JMS I	QGENCOD
	GI-1			/LOAD THE INDEX
	JMP I	GTSTUF
GTTYPE,	JMS I	QTTYMSG		/GOTO TYPE ERROR
	0726
JAC,	TEXT	'JAC'
FSTA,	TEXT	'FSTA'
FNEG,	TEXT	'FNEG'
	PAGE
/ ADDRESS FIELD OUTPUT
OADDR,	0			/OUTPUT ADDRESS FIELD
	TAD I	OADDR		/GET ADDRESS OF PARAMETERS
	DCA	ARG
	ISZ	OADDR
	TAD I	ARG		/GET VALUE OF ARG
	CLL
	TAD	(-52		/IS IT A TEMP REFNCE
	SNL
	JMP	TMPREF		/YES, 1-51
	TAD	(52-61		/IS IT AN ARRAY REFERENCE ?
	SZL
	JMP	SSREF		/YES, 52-60 IS XR1-XR7
	SNA
	JMP	IND0		/INDIRECT THROUGH 0
	TAD	(61-7000	/CHECK FOR DO TEMP
	SZL
	JMP	DOTMP
	TAD	(7000-62
	SNA
	JMP	IND3		/INDIRECT THROUGH 3
	TAD	(63
	DCA	TEMP
	CDF	10
	TAD I	TEMP		/IS THIS AN ARG ?
	AND	Q20
	CDF
	SZA CLA
	JMP	INDARG		/YES, REF IT INDIRECTLY
	JMS I	QOTAB
	CDF	10
	TAD I	TEMP		/LOOK AT TYPE WORD
	AND	(50		/IS IT LIT OR STMT NO.?
	SNA
	JMP	OUTA		/NO, JUST OUTPUT ADDRESS
	AND	Q40
	SNA CLA
	JMP	OUTSN		/OUTPUT STMT NUMBER
	JMP	OUTLIT		/OUTPUT LITERAL
OUTA,	TAD	PROGNM		/IS THIS THE FUNCTION NAME ?
	CIA
	TAD	TEMP
	SNA CLA
	JMP	FUNNAM		/YES, REFERENCE #VAL INSTEAD
OUTA2,	CLA CMA			/SIMPLE LOCAL VARIABLE REFNCE
	TAD	TEMP		/ADDRESS OF VAR
	JMS I	QOUTNAM		/INTO ADDR FIELD
	JMS I	QCRLF
	JMP I	OADDR		/END OF ADDRESS
OUTLIT,	ISZ	TEMP		/MOVE TO LITERAL NUMBER
	TAD I	TEMP
	DCA	TEMP		/DISPLACEMENT FROM %LITRL
	CDF
	TAD	QLITRL		/OUTPUT #LIT+
	JMS I	QOUTSYM
	TAD	TEMP		/DISPLACEMENT
	JMS I	QONUMBR
	JMP	OADRET-1
FUNNAM,	TAD	(XVAL		/#VAL
	JMS I	QOUTSYM
	JMP	OADRET-1
SSREF,	TAD	(270		/MAKE IT AN ASCII DIGIT
	DCA	XR
	ISZ	ARG		/POINT TO THE BASE WORD
	TAD I	ARG		/GET THE ADDR OF THE BASE
	DCA	ARG
	CDF	10
	TAD	ARG
	IAC			/GO TO TYPE OF BASE VAR
	DCA	TEMP2
	TAD I	TEMP2		/IS IT AN ARG TO THE SUBR ?
	AND	Q20
	SNA CLA
	JMP	NOTARG		/NO, NO INDIRECT STUFF
	CDF
	JMS	SIT
	TAD	ARG		/VAR NAME
	CDF	10
	JMS I	QOUTNAM
	TAD	COMMA
	JMS I	QOCHAR
	TAD	XR		/XR NUMBER
	JMS I	QOCHAR
	JMS I	QCRLF
OADRET,	JMP I	OADDR
IND3,	TAD	(XBASP3-XBASE	/INDIRECT THRU #BASE+3
IND0,	TAD	(XBASE		/INDIRECT THRU #BASE
	DCA	TEMP
	JMS	SIT
	TAD	TEMP
	JMP	FUNNAM+1
OUTSN,	CLA CMA			/OUTPUT STMT NUMBER
	TAD	TEMP
	JMS I	QOSNUM		/OUTPUT THE NUMBER
	TAD	(P2		/+2 (HACK FOR FORMAT)
	JMP	FUNNAM+1
INDARG,	JMS	SIT		/INDIRECT INDICATOR
	CDF	10
	JMP	OUTA2		/OUTPUT ARG NAME
SIT,	0
	TAD	(245		/% (INDIRECT)
	JMS I	QOCHAR
	JMS I	QOTAB
	JMP I	SIT
CEQ,	TEXT	'#CEQ'
XBAC1P,	TEXT	'#BASE,1+'
XUE,	TEXT	'#UE'
	PAGE
/ ADDRESS FIELD OUTPUT

NOTARG,	TAD I	TEMP2		/GET TYPE WORD
	DCA	TEMP		/SAVE IT
	TAD	TEMP
	ISZ	TEMP2
	AND	Q200		/EQUIVALENCED ?
	SNA CLA
	JMP	.+3
	TAD I	TEMP2		/SKIP EQUIV INFO BLOCK
	DCA	TEMP2
	CLL CML RTL
	TAD I	TEMP2		/ADDRESS OF MAGIC NUMBER
	DCA	TEMP2
	TAD I	TEMP2		/MAGIC NUMBER ITSELF
	DCA	TEMP2
	CDF
	JMS I	QOTAB		/TAB
	TAD	ARG		/OUTPUT VARIABLE MINUS CONST
	JMS	VMC
	TAD	COMMA
	JMS I	QOCHAR
	TAD	XR		/N
	JMS I	QOCHAR
	JMS I	QCRLF		/END OF LINE
	JMP	OADRET
DOTMP,	DCA	TEMP		/ADDRESS RELATIVE TO %DOTMP
	JMS I	QOTAB
	TAD	(DOTMPN		/OUTPUT #DOTMP
	JMS I	QOUTSYM
	JMP	PLUSN		/GO OUTPUT +XXXX
TMPREF,	CLA
	TAD I	ARG	/BUMP TEMPS BACK CORRECTLY (?)
	DCA	TMPCNT
	JMS I	QOTAB		/TAB
	CLA CMA
	TAD I	ARG		/GET NUMBER
	DCA	TEMP		/INTO TEMP
	IFNZRO TMPBLK-2 <XXXXXX>
	CLL STA RAL		/V3C -2 (-TMPBLK)
				/V3C LINK SET
	TAD	TEMP		/V3C (SAVES A LITERAL)
	SNL			/V3C
	DCA	TEMP		/YES, SAVE ALTERED DISPLACEMENT
	SNL CLA			/V3C
	TAD	(TEMPN2-TEMPN	/USE %TEMPX
	TAD	(TEMPN		/USE %TEMP
	JMS I	QOUTSYM
PLUSN,	TAD	PLUS		/PLUS CONSTANT
	JMS I	QOCHAR
	TAD	TEMP		/DISPLACEMENT TIMES THREE
	CLL RAL
	TAD	TEMP
	JMS I	QONUMBR		/OUT IT
	JMS I	QCRLF
	JMP	OADRET
/ UTILITIES
VMC,	0			/OUTPUT VARIABLE MINUS CONST
	CDF	10
	JMS I	QOUTNAM		/PUT VAR NAME
	TAD	Q255		/-
	JMS I	QOCHAR
	TAD	TEMP		/THIS CONTAINS THE TYPE
	JMS	SKPIRL		/SKIP ON I,R OR L
	TAD	Q3		/USE SIX WORDS PER ENTRY
	TAD	Q3		/REAL, INTEGER, OR
				/LOGICAL 3 WORDS
	DCA	MQ
	TAD	TEMP2
	JMS	MUL12		/DO MULTIPLY
	JMS I	QNUMBRO		/OUTPUT 15 BIT NUMBER
	JMP I	VMC
SC,
SKPIRL,	0			/SKIP ON TYPE I R OR L
	AND	Q17		/ISOLATE TYPE CODE
	TAD	QM4		/IS IT DOUBLE ?
	SZA
	IAC			/NO, IS IT COMPLEX ?
	SZA CLA
	ISZ	SKPIRL		/NEITHER, SKIP
	JMP I	SKPIRL		/RETURN
MUL12,	0			/12 BIT MULTIPLY
	DCA	OPRND
	TAD	(-15
	DCA	SC
	JMP	STMUL
M12LUP,	TAD	AC
	SNL
	JMP	.+3
	CLL
	TAD	OPRND
	RAR
STMUL,	DCA	AC
	TAD	MQ
	RAR
	DCA	MQ
	ISZ	SC
	JMP	M12LUP
	JMP I	MUL12
OPRND,
BUMP,	0			/PUT FALSE ENTRY ONTO STACK
	CDF 0			/V3C IMPORTANT PROTECTION
	DCA I	X16
	ISZ	X16
	ISZ	X16		/THIS PREVENTS UNDER
				/FLOWING THE STACK
	JMP I	BUMP		/AFTER SOME ERRORS
EXTERN,	TEXT	'EXTERN'
CADD,	TEXT	'#CAD'
CNEG,	TEXT	'#CNG'
CMUL,	TEXT	'#CML'
JLE,	TEXT	'JLE'
ORG,	TEXT	'ORG'
STARTE,	TEXT	'STARTE'
XDPTMP,	TEXT	'#DPT'
	PAGE
/ RANDOM CODE GENERATORS

ERROR,	JMS I	QINWORD		/GET ERROR CODE
	JMS I	QERMSG		/PRINT IT
	JMP I	QNEXT
EOSTMT,	TAD	DATASW		/WAS THIS A DATA STMT ?
	SNA CLA
	JMP	OPTMYZ		/NO
	DCA	DATASW		/KILL SWITCH
	JMS I	QOPCDE
	ORG			/ORIGIN BACK TO THE PROGRAM
	TAD	GLABEL
	JMS I	QOLABEL
	JMS I	QCRLF
	ISZ	GLABEL		/BUMP LABEL GENERATOR
OPTMYZ,	CLA			/CHANGED TO CLA IAC IF /O
	JMS I	QXRTBL		/CLEAR TABLE OR RESET FLAGS
	ISZ	LINENO		/BUMP LINE NUM
	TAD	LINENO		/DISPLAY IN MQ
	7421			/FOR COOLNESS
	CLA			/FOR NON-EAE FOLKS
	TAD	STKLVL		/RESET STACK LEVEL
	DCA	X16
	JMS	IFEND		/LOOK FOR END OF LOGICAL IF
	JMS I	(ASFEND		/END OF A.S.F. DEFINITION ?
DEBUG,	JMP I	QNEXT		/OVERLAYED IF NO /N SWITCH
	JMS I	QOPCDE		/OUTPUT  LDX NNNN,0
	LDX
	TAD	LINENO		/THIS IS THE CURRENT ISN
	JMS I	QONUMBR
	TAD	COMMA
	JMS I	QOCHAR
	TAD	Q260
	JMS I	QOCHAR
	JMS I	QCRLF
	JMP I	QNEXT
IFEND,	0			/OUTPUT IF END LABEL IF
	TAD	IFLABL		/WAS THIS END OF LOG IF
	SNA
	JMP I	IFEND		/OUTPUT DEBUG STUFF
	JMS I	QLABEL		/OUPTUT THE LABEL
	JMS I	QGENSF		/ALL LOGICAL IFS MUST
				/END IN FMODE
	DCA	WHATAC		/CAN'T DEPEND ON
				/AC HERE
	JMS I	QXRTBL		/OR XR'S EITHER
	DCA	IFLABL		/KILL THE SWITCH
	JMP I	IFEND
OPCOD,	0			/TAB OPCODE
	DCA	WHATAC		/AC HAS JUST BEEN
				/MODIFIED
	JMS I	QOTAB
	TAD I	OPCOD
	ISZ	OPCOD
	JMS I	QOUTSYM
	JMP I	OPCOD
DIV,	JMS I	QSAVACT		/IF SECOND OPERAND IN AC, SAVE IT
	JMS I	QCODE		/DIVIDE
	DIVTBL-6;0
	CLA CMA			/WERE BOTH VARS INTEGER?
	TAD	TYPE1
	SZA CLA
	JMP I	QNEXT		/NO
	JMS I	QGENCOD
	A0FN-1			/ALN 0;FNORM
	JMP I	QNEXT
LIFBGN,	DCA	RELCD	/ENTER HERE IF LAST OPCODE NOT A RELATIONAL
	JMS I	QGARG	/ENTER HERE FROM RELATIONAL OPTIMIZER
	JMP	NOTLOG
	TAD	TYPE1		/MUST BE LOGICAL
	TAD	(-5
	SZA CLA
	JMP	NOTLOG
	TAD	ARG1		/IS IT IN AC ?
	SNA CLA
	JMP	.+3
	JMS I	QGENCOD
	GI-1
	JMS I	QINWORD		/IS IT IF(...)GOTO XX ?
	DCA	TEMP2
	TAD	TEMP2
	TAD	(XPUSH-XGOTO
	SNA CLA
	JMP	IFGOTO		/YES, TREAT AS SPECIAL CASE
	TAD	GLABEL		/SET IF LABEL
	DCA	IFLABL
	TAD	RELCD
	CIA
	TAD	Q5	/GENERATE THE OPPOSITE JUMP
	JMS	RELJMP	/AROUND THE TARGET OF THE IF
	TAD	GLABEL
	JMS I	QOLABEL
	ISZ	GLABEL		/INCREMENT LABEL GENERATOR
	JMS I	QCRLF
	JMP I	QNEXTM2
IFGOTO,	TAD	RELCD
	JMS	RELJMP	/GENERATE TRUE RELATIONAL JUMP IF "IF()GOTO"
	JMS I	QINWORD		/GET THE LABEL
	CDF	10
	JMS I	QOSNUM
	JMS I	QCRLF
	JMP I	QNEXT
NOTLOG,	JMS I	QTTYMSG
	1411

RELJMP,	0
	CLL RAL
	TAD	(JNE
	DCA	.+2
	JMS I	QOPCDE
	0
	JMP I	RELJMP

FMUL,	TEXT	'FMUL'
FDIV,	TEXT	'FDIV'
CAC,	TEXT	'#CAC'
LITRL,	TEXT	'#LIT+'
TEMPN,	TEXT	'#TMP'
	PAGE
/ DO LOOP COMPILER

DOBEGN,	JMS I	QSAVACT		/FOR EXPR IN LOOP PARAMS
	TAD	X16		/SET NEW STACK LEVEL
	DCA	STKLVL
	JMS I	QGARGS		/GET LIMIT AND STEP
	JMP	DPERR		/ERROR IN DO PARMS
	JMS	DOPARM		/DO PARAMETER STUF FOR LIMIT
	ARG1
	JMS	DOPARM
	ARG2			/AND THEN FOR STEP
	TAD	ARG1		/REPLACE ALTERRED STACK
				/ENTRIES
	DCA I	X16
	ISZ	X16		/REST OF ARG1 OK
	TAD	GLABEL		/SAVE LOOP LABEL
	DCA I	X16
	TAD	ARG2
	DCA I	X16
	ISZ	X16
	ISZ	X16
	JMS I	QCRLF		/CRLF BEFORE LABL
	TAD	GLABEL
	JMS I	QLABEL		/OUPTUT LOOP LABEL
	ISZ	GLABEL		/INCR LABEL GENERATOR
	DCA	WHATAC		/FORGET AC AND
	JMS I	QXRTBL		/XR'S AT DO BEGIN
	JMP I	QNEXT
DOSTOR,	JMS I	QGARGS		/LOOK AT INDEX AND
	JMP	DPERR		/INITIAL VALUE
	CLL CMA RTL		/MUST BE INTEGER OR
	TAD	TYPE1		/REAL (L=1  AC=-3)
	SZL CLA			/SKIP IF >2
	CLL CMA RTL		/L=1 AC=-3
	TAD	TYPE2
	SZL CLA			/L=0 IS BAD
	JMP I	(STORE+2	/DO STORE IF OK
DPERR,	JMS I	QTTYMSG		/ERROR IN LIMITS
	0420			/DP
DOFINI,	JMS I	QXRTBL		/DON'T OPTIMIZE XR USAGE
				/IN SUCCESSIVE IMPLIED DO LOOPS
	TAD	IOSTMT		/INSIDE IO STMT ?
	SNA CLA
	JMS	IFEND		/IF NOT, END IF FIRST
	JMS I	QINWORD		/GET THE INDEX
	DCA	ARG1
	TAD	ARG1		/GET THE TYPE WORD ADR
	IAC
	DCA	TYPE1
	CDF	10
	TAD I	TYPE1
	CDF
	AND	Q17
	DCA	TYPE1		/TYPE OF INDEX VAR
	TAD	QM6
	TAD	STKLVL		/BACK UP THE STACK
	DCA	X16
	TAD	X16		/RESET THE STACK LEVEL
	DCA	STKLVL
	TAD I	X16		/GET THE FINAL VALUE
	DCA	DOARG
	ISZ	X16
	TAD I	X16		/GET THE LOOP LABEL
	DCA	DARG
	TAD I	X16		/GET THE STEP
	DCA	ARG2
	TAD I	X16		/WHICH DO FIN CODE ?
	CLL CML RAL
	TAD	TYPE1
	TAD	QM6
	SNA CLA
	TAD	(DOFIN1-DOFIN0	/INDEX=I, STEP=R
	TAD	(DOFIN0-1	/ALL OTHER CASES
	DCA	.+2
	JMS I	QGENCOD		/DO FINISH CODE
	0
	JMS I	QOPCOD		/SUBTRACT UPPER LIMIT
	FSUB
	JMS I	QOADDR
	DOARG
	JMS I	QOPCDE		/NOW THE JLT %%LOOP
	JLE
	TAD	DARG		/OUTPUT LABEL
	JMS I	QOLABEL
	JMS I	QCRLF
	TAD	STKLVL		/FIX X16 INCASE MULTIPLE DO ENDER
	DCA	X16
	JMP I	QNEXT
DOARG,
DOPARM,	0			/SUBR FOR DO PARAMETERS
	TAD I	DOPARM
	ISZ	DOPARM		/GET THE PARM POINTER
	DCA	DARG
	CLL CML RTL		/GET ADDR OF TYPE WORD
	TAD	DARG
	DCA	TYPE
	CLL CMA RTL		/CHECK TYPE
	TAD I	TYPE
	SMA CLA
	JMP	DPERR		/NOT I OR R
	TAD I	DARG
	SNA
	JMP	STRTMP		/ARG ALREADY IN AC
	TAD	QM63		/IS IT ARRAY REF?
	SPA CLA
	JMP	SVLIMT		/YES, SAVE LIMIT
	TAD I	DARG		/REGET SYM ADDR
	DCA	X10		/ADR OF TYPE WORD
	CDF	10
	TAD I	X10		/MAYBE ITS A LIT?
	CDF
	AND	Q40
	SZA CLA
	JMP I	DOPARM		/YES, ITS LITERAL
				/WE'RE ALWAYS IN F MODE HERE
				/SINCE THE LAST THING
				/WAS A DO STORE
SVLIMT,	JMS I	QOPCOD		/OTHERWISE LOAD IT
	FLDA
	JMS I	QOADDR
DARG,	0
STRTMP,	TAD	DOTEMP		/SET ARG TO NEXT DO TEMP
	DCA I	DARG
	JMS I	QOPCOD		/GENERATE STORE
	FSTA
	ISZ	DOTEMP		/BUMP DO TEMP
	TAD	DARG
	DCA	.+2
	JMS I	QOADDR		/DO TEMP ADDRESS FIELD
	0
	JMP I	DOPARM
	PAGE
/ SUBSCRIPT REFERENCE COMPILER

ARGS,	JMS I	QINWORD		/COMPILE ARGUMENT LIST
	CMA
	DCA	NARGS		/NUMBER OF ARGS
	TAD	NARGS		/GET ADDRESS OF SUBSCRIPTED VAR
	CLL RAL
	TAD	NARGS		/ENTRY ON THE STACK
	TAD	X16
	DCA	X15
	TAD	X15		/SAVE POINTER TO START
				/OF THIS ENTRY
	DCA	X14		/FOR POSSIBLE FUTURE USE
	ISZ	NARGS		/NOW ITS THE 2'S COMPLEMENT
	NOP
	TAD I	X15		/FETCH SS VARIABLE
	DCA	BASE1
	TAD I	X15		/ITS TYPE
	DCA	TYPE1
	TAD	BASE1		/STORE BASE WORD
	DCA I	X15
	TAD	BASE1		/GET ADDR OF TYPE WORD
	IAC
	DCA	TEMP
	CDF	10		/GET TYPE WORD
	CLL CML RTR		/TEST DIM BIT
	AND I	TEMP
	SNA CLA
	JMP	TRYCAL		/SOME KIND OF CALL
	TAD	BASE1		/NOW GET ADDRESS OF DIM INFO
	JMS I	QGETSS
	DCA	ARG1		/RETURNS WITH FIELD SET
	TAD I	ARG1		/CORRECT NUMBER OF DIMENSIONS?
	TAD	NARGS
	CDF
	SZA CLA
	JMP	DIMERR		/NO
	ISZ	ARG1		/SKIP TOTAL SIZE
	ISZ	ARG1		/SKIP MAGIC NUMBER
	ISZ	ARG1		/AND ASSOCIATED LITERAL
	DCA	XRNUM		/START WITH XR 1
	TAD	(-10		/SEVEN XRS
	DCA	XRCNT		/COUNT FOR SEARCH
	DCA	FREEXR		/ZERO FREE XR INDICATOR
XRCHEK,	CDF
	ISZ	XRCNT		/ANY MORE XR EXPRS TO TEST ?
	SKP			/YES, GO CHECK THEM
	JMP	COMPSS		/NO, MUST COMPILE
				/XR ERPRESSION
	ISZ	XRNUM		/BUMP XR NUMBER
	TAD	XRNUM
	CLL RTL			/TIMES 16
	CLL RTL
	TAD	(XRBUFR-1	/PLUS BASE (-1)
	DCA	X13
	TAD I	X13		/LOOK AT THE
	SPA			/INDICATOR
	JMP	.+3		/-1=USED BY THIS STMT
	SZA CLA			/IF ZERO GO TO
				/MTXR (EVENTUALLY)
	TAD	FREEXR		/ANY FREE BEFORE THIS ONE ?
	SZA CLA
	JMP	NOTMT		/YES, ALREADY FOUND ONE
	TAD	XRNUM		/THIS WILL BE
	DCA	FREEXR		/THE XR WE USE
	JMP	XRCHEK		/GO LOOK AT NEXT
NOTMT,	TAD	X13		/SAVE FLAG ADDRESS
	DCA	XRFLAG		/IN CASE WE NEED IT LATER
	TAD I	X13		/POINTER TO THE DIM INFO
	DCA	TEMP2
	CDF	10
	TAD I	TEMP2		/SAME NUMBER OF DIMS ?
	TAD	NARGS
	SZA CLA
	JMP	XRCHEK		/NO, THIS XR WONT DO
	TAD	NARGS		/SET COUNTER
	DCA	DCNT
	TAD	ARG1		/POINTER TO DIM FACTORS
	DCA	X12
	ISZ	TEMP2		/SKIP THREE WORDS
	ISZ	TEMP2
	ISZ	TEMP2
DCHEK,	ISZ	DCNT		/ANY MORE ?
	SKP
	JMP	SSCHEK		/DIMS OK, CHECK SS
	ISZ	TEMP2		/GET TO NEXT DIM
	TAD I	TEMP2		/ARE THEY EQUAL ?
	CIA
	TAD I	X12
	SZA CLA
	JMP	XRCHEK		/NO, GO TRY NEXT ONE
	JMP	DCHEK
SSCHEK,	TAD	NARGS		/COUNT AGAIN
	CDF
	DCA	DCNT
	CLL CMA RAL		/-2
	TAD	X16		/ADDR OF START OF TOP
				/SS ON STACK
	JMP	.+3
SSC2,	CLL CMA RTL		/-3
	TAD	XTMP		/BACK UP TO NEXT LOWER SS
	DCA	XTMP		/LINK IS ALWAYS ZERO HERE
	TAD I	XTMP		/GET NEXT SS (WORKING
				/RIGHT TO LEFT)
	TAD	(-61		/IS IT A VAR OR LITERAL?
	SNL CLA
	JMP	XRCHEK		/WE'RE JUST
				/LOOKING FOR AN EMPTY
	TAD I	XTMP		/RE GET SS POINTER
	CIA
	TAD I	X13		/ARE THEY THE SAME ?
	SZA CLA
	JMP	XRCHEK		/NO
	ISZ	DCNT
	JMP	SSC2		/KEEP CHECKING
	TAD	XRNUM		/THEY MATCH, STICK IN
				/THE XR NUMBER
	TAD	(51
	DCA I	X14
	CLL CML RTL
	TAD	X14		/PURGE SS FROM STACK
	DCA	X16
	CLA CMA			/SET FLAG TO
				/'USED BY THIS STMT'
	DCA I	XRFLAG
	JMP I	QNEXT
DCNT,	0
XRFLAG,	0
XTMP,	0
	PAGE
/ SUBSCRIPT REFERENCE COMPILER

COMPSS,	TAD	FREEXR		/GET XR EXPR AREA
	CLL RTL			/BY MULTIPLYING
				/THE NUMBER
	CLL RTL			/BY 16
	TAD	(XRBUFR		/AND ADDING THE
				/BASE ADDRESS
	DCA	XREPTR		/THIS IS IT
	CLA CMA			/SET USED BY THIS
				/STMT FLAG
	DCA I	XREPTR
	ISZ	XREPTR
	CLL CMA RTL		/STORE THE DIB POINTER
	TAD	ARG1
	DCA I	XREPTR
	TAD	NARGS		/GET ADDR OF POINTER TO LAST
	CMA			/DIMENSION FACTOR
	TAD	ARG1
	DCA	ARG1		/SINCE WE USE THEM IN
				/REVERSE ORDER
	JMS I	QSAVEAC		/STORE AC IF NEEDED
		/FOLLOWING INSTRUCTION REMOVED FOR OPTOMIZATION
/	JMS I	QGENSF		/ALL SUBSCRIPTS AR I OR R
	TAD	(FLDA		/LOAD FIRST SS
	SKP
CSSLUP,	TAD	(FADD		/ADD ALL SUBSEQUENT ONES
	DCA	OPC
	CLL CMA RTL		/BACK UP STACK BY ONE ENTRY
	TAD	X16
	DCA	X16
	TAD	X16		/GET A WORKING POINTER
	DCA	X15
	TAD I	X15		/GET THE NEXT SUBSCRIPT
	DCA	ARG2
	CLL CMA RAL		/MUST BE INTEGER
	TAD I	X15
	SMA CLA
	JMP	DIMERR
	TAD I	X15
	DCA	BASE2
	TAD	ARG2		/STORE THE SS INTO THE
				/XR EXPR
	ISZ	XREPTR		/INCREMENT FIRST
	DCA I	XREPTR
	TAD	ARG2		/IS ARG2 THE AC (ONLY
				/POSSIBLE IF
	SNA CLA			/ITS THE RIGHTMOST
				/SUBSCRIPT)
	JMP	NLODSS		/YES, DON'T LOAD IT
	JMS I	QOPCOD		/OUTPUT LOAD OR ADD
OPC,	0			/THIS LOCATION TELLS
				/THE STORY
	JMS I	QOADDR		/FOLLOWED BY THE OPERAND
	ARG2			/POINTED TO BY ARG2
NLODSS,	ISZ	NARGS		/ANY MORE SUBSCRIPTS ?
	JMP	MORESS		/YES, GO COMPILE THEM
	TAD	FREEXR		/ANY FREE INDEX REG?
	SZA CLA
	JMP	ASGNXR		/YES, GO USE IT
	TAD	(61		/ITS A SPECIAL POINTER ENTRY
	DCA I	X14
	ISZ	X14
	TAD	TMPCNT		/SAVE TEMP NUMBER
	DCA I	X14		/BEFORE WE BLOW X14
	JMS I	(GENPTR		/GENERATE POINTER TO THE ARG
	JMS I	QGENCOD		/BACK TO FMODE
	SF-1
	JMS I	(ACSTOR		/GENERATE STORE AC
	JMP I	QNEXT
DIMERR,	JMS I	QTTYMSG		/SS NOT OF CORRECT NUMBER
	2323
XRCNT,	0
TRYCAL,	TAD	ASFSWT		/ASF DEFINITION
	SMA SZA CLA
	JMP	DEFASF		/YES, GO OUTPUT PROLOG
	TAD I	TEMP		/IS IT A FUNCTION OR AN ARG?
	CDF
	AND	(1420
	SNA
	JMP	DIMERR		/NO, SOME KIND OF ERROR
	AND	Q20
	DCA	ACSWIT		/SAVE THE AC SWITCH
	JMP	FUNCAL		/STANDARD FUNCTION CALL
MORESS,	JMS I	QGENSF	/MUST USE SINGLE PRECISION FOR MULTIPLY
	JMS I	QOPCOD		/MULTIPLY BY DIM FACTOR
	FMUL
	CDF	10
	TAD I	ARG1		/PICK UP FACTOR ADDRESS
	CDF
	DCA	ARG2
	CLA CMA
	TAD	ARG1		/MOVE BACK ONE
	DCA	ARG1
	JMS I	QOADDR		/OUTPUT MULTIPLY ADDRESS
	ARG2
	JMP	CSSLUP		/LOOP ON NEXT SS
ASGNXR,	JMS I	QOPCDE		/OUTPUT ATX N
	ATX
	TAD	FREEXR		/GET NUMBER OF FREE XR
	TAD	Q260
	JMS I	QOCHAR
	JMS I	QCRLF
	TAD	FREEXR
	TAD	(51		/COMPUTE PROPER NUMBER
	DCA I	X14		/PUT IT INTO TOP OF STACK
	JMP I	QNEXT
XREPTR,	0
/ RANDOM TEXT
OTAB,	0
	TAD	(211
	JMS I	QOCHAR
	JMP I	OTAB
FCLA,	TEXT	'FCLA'
STARTD,	TEXT	'STARTD'
TEMPN2,	TEXT	'#TMPX'
CSUB,	TEXT	'#CSB'
CDIV,	TEXT	'#CDV'
	PAGE
/ GENERAL CALL GENERATOR

GENCAL,	0		/GENERATE A CALL; ALL ARGS ON STACK
			/X15 POINTS TO START OF STACK INFO
			/NARGS IS NEG NUMBER OF ARGS
			/FUNCTION NAME IS FIRST ON STACK
	TAD I	GENCAL		/GET FUN NAME SWITCH
	DCA	FNSWIT
	TAD	X15		/NEW STACK VALUE
	DCA	X16
	TAD	X15		/WORKING POINTER
	DCA	ARG2
	TAD	NARGS		/WORKING COUNTER
	SNA
	JMP	OUTJSR		/NO ARGS, PUT JSR
	DCA	TYPE2
CHKPTR,	ISZ	ARG2		/MOVE TO NUMBER
	TAD	ARG2
	IAC			/ADDR OF TYPE WORD
	DCA	BASE2
	TAD I	BASE2		/GET TYPE
	DCA	TYPE1		/TYPE OF ARG FOR GENPTR
	ISZ	BASE2		/POINT TO BASE WORD
	TAD I	BASE2
	DCA	BASE1		/FOR GENPTR
	TAD I	ARG2		/GET ARG NUMBER
	CLL
	TAD	(-52		/IS IT INDEXED ?
	SNL
	JMP	NOTINX		/NO, ITS A TEMP
	TAD	(52-61		/IS IT INDIRECT ?
	SZL
	JMP	INXR		/NO, ITS IN AN XR
	SNA
	JMP	INTMP		/POINTER IN A TEMP
	TAD	(62		/GET TO TYPE WORD
	DCA	GCTEMP
	CDF	10
	TAD I	GCTEMP		/IS IT AN ARG
	CDF
	AND	(1020		/ARG OR EXTERNAL ?
	SNA
	JMP	NOTINX+1	/NEITHER
	AND	Q20
	SZA CLA
	JMP	ARGARG		/ARG SQUARED
	JMP	EXTARG		/EXTERNAL ARG
NOTINX,	CLA
	ISZ	ARG2		/BUMP POINTER
	ISZ	ARG2
	ISZ	TYPE2		/INCR COUNT
	JMP	CHKPTR
OUTJSR,	TAD	JSRLBL		/DOES IT GET A LABEL ?
	SNA
	JMP	.+3		/NO
	JMS I	QLABEL		/OUPTUT THE LABEL+COMMA
	DCA	JSRLBL		/KILL SWITCH
	TAD	X16		/ADDR OF POINTER TO FUN NAME
	DCA	TEMP
FNSWIT,	0			/REAARANGED**
	JMP I	(IOFUN		/IO FUNCTION CALL
	JMS I	QOPCDE		/OUTPUT THE JSR
	JSR
	TAD I	TEMP		/NOW THE SUBR NAME
	CDF	10
	JMS I	QOUTNAM
	JMS I	QCRLF
	TAD	NARGS		/ANY ARGS ?
	SNA CLA
	JMP I	GENCAL		/NO, END OF CALL
	JMS I	QOPCDE		/JUMP AROUND THE ARGS
	JA
	TAD	Q256
	JMS I	QOCHAR		/.
	TAD	PLUS
	JMS I	QOCHAR		/+
	CLL CLA CMA RAL		/-2
	TAD	NARGS		/-N-2
	CLL CMA RAL		/2*N+2
	JMS I	QONUMBR
IOONLY,	JMS I	QCRLF
	TAD	X16		/WORKING POINTER
	DCA	X15
PTRLST,	TAD I	X15		/GET NEXT ARG
	SZA
	JMP	SARG		/SIMPLE ARG
	CLL CML RTL
	TAD	X15		/ADDR OF GENERATED
				/LABEL NUMBER
	DCA	TEMP
	TAD I	TEMP		/OUTPUT #GXXXX (THE
				/GENERATED LABEL)
	JMS I	QLABEL		/OUPTUT THE LABEL
	JMS I	QGENCOD
	JADP2-1			/GENERATE A DUMMY JA
	JMP	BARGLP
SARG,	DCA	ARG2		/STORE THE ARG NUMBER
	JMS I	QOPCOD		/OUTPUT JA ARG
	JA
	JMS I	QOADDR		/NOW ADDRESS FIELD
	ARG2
BARGLP,	ISZ	X15		/BUMP POINTER
	ISZ	X15
	ISZ	NARGS		/BUMP COUNT
	JMP	PTRLST
	JMP I	GENCAL
INTMP,	TAD I	BASE2		/GET TEMP NUMBER
	DCA	ARG1		/THAT PTR IS STORED IN
	JMS I	QGENCOD		/PICK UP POINTER
	LDASTD-1
STRPTR,	JMS I	QOPCDE		/NOW STORE THE POINTER
	FSTA
	TAD	GLABEL		/OUTPUT THE LABEL
	JMS I	QOLABEL
	JMS I	QCRLF
	TAD	GLABEL		/SAVE THE LABEL NUMBER
	DCA I	BASE2
	DCA I	ARG2		/ZERO ARG NUMBER
	ISZ	GLABEL		/INCREMENT LABEL NUMBER
	JMS I	QGENCOD		/BACK TO F MODE
	SF-1
	JMP	NOTINX		/CONTINUE LOOP
NLABEL,	0
	JMS I	QOLABEL
	TAD	COMMA
	JMS I	QOCHAR
	JMP I	NLABEL
	PAGE
/ GENERATE SUBROUTINE CALL

FUNCAL,	JMS I	QSAVEAC		/SAVE NEXT TO LAST IF NEEDED
	JMS I	QSAVACT		/SAVE LAST IF NEEDED
	JMS I	QGENSF		/ALL CALLS DONE IN F MODE
	DCA I	X14		/RESULT RETURNED IN AC
	TAD	ACSWIT		/IS THE SUBR AN ARG ?
	SNA CLA
	JMP	MAKCAL		/NO, ITS EASIER
	JMS I	QOPCOD		/GET THE JSR TO THE SUBR
	FLDA
	JMS I	QOADDR
	BASE1			/BY GETTING THE VALUE
				/OF THE ARG
	JMS I	QGENCOD		/STARTD
	SD-1
	JMS I	QOPCDE		/STORE IT AHEAD
	FSTA
	TAD	GLABEL		/INTO THE JSR
	ISZ	GLABEL
	DCA	JSRLBL		/SET THE SWITCH
	TAD	JSRLBL
	JMS I	QOLABEL
	JMS I	QCRLF
	JMS I	QGENCOD		/STARTF
	SF-1
MAKCAL,	ISZ	BASE1		/MOVE TO TYPE WORD
	CDF	10
	TAD I	BASE1		/GET TYPE OF FUNCTION
	CDF
	JMS I	QSKPIRL		/WHAT MODE WILL WE LEAVE IN?
	DCA	FMODE		/PROBABLY E
	JMS I	QGENCAL		/GO GENERATE THE CALL
	SKP
	0			/THIS IS A FREE LOCATION
	JMP I	QNEXT
ARGARG,	JMS I	QOPCDE		/%FLDA
	FLDA
	TAD I	ARG2		/POINTER
	CDF	10
	JMS I	QOUTNAM
	JMS I	QCRLF
	JMS I	QGENCOD		/%SD
	SD-1
	CDF	10
	CLL CML RTR		/IS IT AN ARRAY ?
	AND I	GCTEMP
	CDF
	SNA CLA
	JMP	STRPTR		/GO STORE THE POINTER
	TAD I	ARG2		/GET THE LITERAL NUMBER
	JMS I	QGETSS
	TAD	Q3
	DCA	GCTEMP
	TAD I	GCTEMP
	DCA	OLABEL		/SAVE IT
	CDF
	JMS I	QOPCDE		/%FADD LITERAL
	FADD
	TAD	QLITRL
	JMS I	QOUTSYM
	TAD	OLABEL		/XXXX
	JMS I	QONUMBR
	JMS I	QCRLF
	JMP	STRPTR		/GO STORE THE POINTER
INXR,	TAD	(270		/MAKE AN ASCII CHAR
	DCA	XR
	JMS I	QOPCDE		/XTA
	XTA
	TAD	XR
	JMS I	QOCHAR		/N
	JMS I	QCRLF
	TAD	BASE1		/FIND ADDR OF MAGIC
				/NUMBER LITERAL
	JMS I	QGETSS
	CDF
	TAD	Q3
	DCA	ARG1
	JMS I	(GENPTR		/GENERATE THE POINTER
	JMP	STRPTR		/GO STORE THE POINTER
EXTARG,	TAD I	ARG2		/MAKE AN ENTRY IN THE EXT
	CDF	10		/LITERAL LIST
	DCA I	X17
	TAD	DOTEMP		/USE DO TEMPS FOR THIS
	DCA I	X17
	CDF
	TAD	DOTEMP		/SINCE OADDR CAN HANDLE THEM
	DCA I	ARG2
	ISZ	DOTEMP		/BUMP COUNT
	ISZ	ELCNT		/ALSO EXT LIT COUNT
	JMP	NOTINX		/BACK TO PROCESSING ARGS
/ UTILITY ROUTINES
OLABEL,	0			/OUTPUT #GXXXX FOR GEN'D LABELS
	DCA	TEMP
	TAD	(243
	JMS I	QOCHAR
	TAD	(307
	JMS I	QOCHAR
	TAD	TEMP
	JMS I	QONUMBR
	JMP I	OLABEL
OPCODE,	0			/TAD OPCODE TAB
	DCA	WHATAC		/THIS INSTRUCTION ZAPS AC
	JMS I	QOTAB
	TAD I	OPCODE
	ISZ	OPCODE
	JMS I	QOUTSYM
	JMS I	QOTAB
	JMP I	OPCODE
M1C2,	TEXT	'-1,2'
GENSTE,	0			/GENERATE STARTE IF IN
				/F MODE
	TAD	FMODE		/LOOK AT THE SWITCH
	SNA CLA
	JMP I	GENSTE		/ALREADY IN E MODE
	DCA	FMODE		/CLEAR THE SWITCH
	JMS I	QOPCOD		/GENERATE THE STARTE
	STARTE
	JMS I	QCRLF		/CAN'T USE GENCOD FOR THAT
	JMP I	GENSTE
D0,	TEXT	'0'
DOTMPN,	TEXT	'#DOTMP'
	PAGE
/ OPCODES AND OTHER TEXT

XBASE,	TEXT	'#BASE'
XBASP3,	TEXT	'#BASE+3'
DP3C0,	TEXT	'.+3,0'
JXN,	TEXT	'JXN'
ALN,	TEXT	'ALN'
ATX,	TEXT	'ATX'
XTA,	TEXT	'XTA'
LDX,	TEXT	'LDX'
XREW,	TEXT	'#REW'
XENDF,	TEXT	'#ENDF'
XBAK,	TEXT	'#BAK'
XEXIT,	TEXT	'#EXIT'
XRTN,	TEXT	'#RTN'
JNE,	TEXT	'JNE'
	TEXT	'JGE'
	TEXT	'JLE'
	TEXT	'JGT'
JLT,	TEXT	'JLT'	/MUST BE IN THIS ORDER!!
	TEXT	'JEQ'
JA,	TEXT	'JA'

JSR,	TEXT	'JSR'
JSA,	TEXT	'JSA'	/MUST BE IN THIS ORDER!
TRAP3,	TEXT	'TRAP3'
/ POINTER GENERATOR
GENPTR,	0			/GENERATE A POINTER
	JMS I	QOPCOD		/MULTIPLY BY 3. OR 6.
	FMUL
	TAD	TYPE1		/D OR C ?
	JMS I	QSKPIRL		/SKIP ON I, R, OR L
	TAD	Q6M3
	TAD	(THREE
	DCA	TEMP		/POINTER TO CORRECT LITERAL
	JMS I	QOADDR
	TEMP
	JMS I	QGENCOD		/ALN 0; STARTD
	A0SD-1
	JMS I	QOPCDE		/FADD THE BASE LITERAL
	FADD
	ISZ	BASE1		/GET ADDR OF TYPE WORD
	CDF	10
	TAD I	BASE1		/GET TYPE WORD
	AND	Q20
	SNA CLA
	JMP	NIARG		/NOT AN ARG
	CMA
	TAD	BASE1
	JMS I	QOUTNAM		/IF AN ARG, THE LITERAL
				/IS THE ARG
	JMP	OSF
NIARG,	CDF
	TAD	QLITRL		/OTHERWISE ITS IN THE
				/LITERAL BLOCK
	JMS I	QOUTSYM
	CDF	10
	TAD I	ARG1		/LITERAL NUMBER
	CDF
	JMS I	QONUMBR
OSF,	JMS I	QCRLF
	JMP I	GENPTR
/ MORE RANDOM CODE GENERATORS
STOP,	JMS I	QGENCOD		/CALL EXIT
	STPCOD-1
	JMP I	QNEXT
FORMAT,	JMS I	QINWORD		/NUMBER OF WORDS OF TEXT
	CMA
	DCA	TEMP
	JMS I	QOPCDE		/JA AROUND THE STUFF
	JA
	TAD	Q256
	JMS I	QOCHAR		/.
	TAD	PLUS
	JMS I	QOCHAR
	CLL CMA RAL		/.+2+NWORDS
	TAD	TEMP
	CMA
	JMP	.+3
FMTLUP,	JMS I	QOTAB		/TA
	JMS I	QINWORD		/GET NEXT WORD
	JMS I	QONUMBR		/OUTPUT IT
	JMS I	QCRLF
	ISZ	TEMP
	JMP	FMTLUP
	JMP I	QNEXT

DFRTTM,	0		/ROUTINE TO DELETE "SYS:FORTRN.TM"
	CLA IAC
	CIF 10
	JMS I	Q200
	4
	FTRNTM
	0
	NOP
	JMP I	DFRTTM

EQUDOT,	TEXT	'=.'
XPAUSE,	TEXT	'#PAUSE'
	PAGE
/REWIND, ENDFILE, BACKSPACE

REWIND,	TAD	(XREW-XENDF
ENDFIL,	TAD	(XENDF-XBAK
BAKSPC,	TAD	(XBAK
	DCA	REBSUB
	JMS I	QUCODE
	AIFTBL-1	/GET UNIT INTO FAC
	JMS I	QGENSF	/FORCE F MODE
	CLA STL RTL
	JMS I	(OJSR
REBSUB,	0
	JMP I	QNEXT
/ DATA STATEMENT STUFF
DATAST,	TAD	X16		/SAVE STACK
	DCA	DSTACK
	TAD	DATASW		/MULTIPLE DATA STMT ?
	SZA CLA
	JMP	FIXDAT-2	/YES, DON'T OUTPUT LABEL
	ISZ	DATASW		/SET DATA SWITCH
	JMS I	QOTAB		/DEFINE ORIGIN SYMBOL
	TAD	GLABEL
	JMS I	QOLABEL
	TAD	(EQUDOT		/#GXXXX=.
	JMS I	QOUTSYM
	JMS I	QCRLF
	CLA CMA			/SET VAR TO NONE LEFT
	DCA	NUMELM
FIXDAT,	TAD	QXRBUFR		/USE XR BUFFER FOR DATA BUFFER
	DCA	DATPTR
	CMA
	DCA	RCOUNT		/SET REPETITION COUNT TO 1
	JMP I	QNEXT
DREPTC,	JMS I	QINWORD		/GET REPETITION COUNT
	CIA
	DCA	RCOUNT
	JMP I	QNEXT
DATELM,	JMS I	QINWORD		/GET SIZE OF ELEMENT
	CIA
	DCA	TEMP
	JMS I	QINWORD		/GET ELEMENT
	DCA I	DATPTR
	ISZ	DATPTR		/INTO DATA BUFFER
	ISZ	TEMP
	JMP	.-4
	JMP I	QNEXT
ENDELM,	TAD	QXRBUFR		/SETUP POINTER
	DCA	TEMP
MORELM,	ISZ	NUMELM		/ANY MORE FOR THIS VAR?
	JMP	SAMVAR		/YES
	TAD	DSTACK		/CHECK FOR MISMATCH
	CIA
	TAD	X16
	SNA CLA
	JMP	DLERR		/OOOPS
	ISZ	DSTACK		/GET TO NEXT VAR
	JMS I	QOPCDE		/%ORG VAR
	ORG
	TAD I	DSTACK		/GET VAR
	DCA	TEMP2
	TAD	TEMP2
	ISZ	DSTACK		/MOVE TO THE DISPLACEMENT
	CDF	10		/OUTPUT VAR
	JMS I	QOUTNAM
	CMA
	DCA	NUMELM		/ASSUME UNDIMENSIONED
	CDF	10
	ISZ	TEMP2		/MOVE TO TYPE WORD
	TAD I	TEMP2		/GET TYPE
	JMS I	QSKPIRL		/SKIP ON I R L
	CLL CMA RTL		/YES
	TAD	(-3
	DCA	ELMSIZ		/NUMBER OF WORDS PER ELEMENT
	CLL CML RTR
	AND I	TEMP2
	CDF
	SNA CLA
	JMP	GOTSIZ		/NOT DIMENSIONED
	CLA IAC			/IF DISP = 7777 , WHOLE ARRAY
	TAD I	DSTACK		/LOOK AT DISPLACEMENT
	SZA CLA
	JMP	GOTSIZ+1	/ONLY ONE ELEMENT OF THE ARRAY
	CMA
	TAD	TEMP2		/GET TOTAL SIZE
	JMS I	QGETSS
	IAC
	DCA	TEMP2
	TAD I	TEMP2
	CIA			/THIS IS THE NUMBER OF ELEMENTS
	DCA	NUMELM
	CDF
GOTSIZ,	DCA I	DSTACK		/ZERO DISPLACEMENT
	TAD	PLUS		/OUTPUT +XXXX
	JMS I	QOCHAR
	TAD	ELMSIZ		/MULTIPLY DISP BY 3 OR 6
	CIA
	DCA	MQ
	TAD I	DSTACK		/GET DISP
	JMS I	QMUL12
	JMS I	QNUMBRO		/OUTPUT THE ORG ALTERATION
	JMS I	QCRLF
	ISZ	DSTACK		/MOVE TO NEXT ENTRY
SAMVAR,	TAD	ELMSIZ		/GET SET TO PICK UP AN ELEMENT
	DCA	NARGS
	JMS I	QOTAB
	JMP	.+3		/SKIP ; FIRST TIME
ELMLUP,	TAD	(273		/SEMICOLON
	JMS I	QOCHAR
	TAD I	TEMP		/GET A WORD FROM THE BUFFER
	ISZ	TEMP
	JMS I	QONUMBR
	ISZ	NARGS		/ONE DATA LIST ELEMENT MUST FILL
	JMP	ELMLUP		/ONE VARIABLE LIST ELEMENT
	JMS I	QCRLF		/I.E. ONE ARRAY ELEMENT
	TAD	DATPTR		/IS THIS DATA ELEMENT EXHAUSTED?
	CIA CLL
	TAD	TEMP
	SNL CLA
	JMP	MORELM		/MORE LEFT
	ISZ	RCOUNT		/REPEAT ?
	JMP	ENDELM		/YES
	JMP	FIXDAT		/NO, BACK FOR MORE DATA
DLERR,	JMS I	QTTYMSG		/DATA LIST ERROR
	0414
	ELMSIZ=ARG1
	NUMELM=TYPE1
	DSTACK=BASE1
	DATPTR=ARG2
	RCOUNT=TYPE2
	PAGE
/ END STATEMENT PROCESSING

END,	TAD	FUNCTN		/WHAT WAS IT ?
	SZA CLA
	JMP	.+3		/SUBR, RETURN
	TAD	(STPCOD-1	/MAIN PROG, CALL EXIT
	DCA	.+2
	JMS I	QGENCOD
	RTNCOD-1
	TAD	DOTEMP		/ANY DO TEMPS ?
	TAD	M7000
	SPA SNA
	JMP	.+3		/NO
	JMS	OTMPS		/OUTPUT THEM
XDOTMP,	DOTMPN
	CLA
	TAD	TMPMAX		/ANY EXTRA TEMPS ?
	TAD	(-TMPBLK
	SPA SNA
	JMP	.+4
	IAC			/OUTPUT THEM + 1
	JMS	OTMPS
	TEMPN2
	CLA
	TAD	ELCNT		/ANY EXTERNAL LITERALS?
	SNA
	JMP	END2		/NO
	CIA
	DCA	ELCNT
	TAD	EXTLIT		/PICK UP THE POINTER
	DCA	X17
ELLOOP,	CDF	10
	TAD I	X17		/GET SYMBOL NAME
	DCA	TEMP
	TAD I	X17		/AND DO TEMP NUMBER
	CDF
	TAD	(-7000		/MINUS BASE
	DCA	TEMP2
	JMS I	QOPCDE		/ORIGIN
	ORG
	TAD	XDOTMP		/OUTPUT #DOTMP
	JMS I	QOUTSYM
	TAD	PLUS		/+
	JMS I	QOCHAR
	TAD	TEMP2		/DISP
	CLL CML RAL		/*2+1
	TAD	TEMP2		/*3+1
	JMS I	QONUMBR
	JMS I	QCRLF
	JMS I	QOPCDE		/NOW OUTPUT JSR NAME
	JSR
	TAD	TEMP
	CDF	10
	JMS I	QOUTNAM
	JMS I	QCRLF
	ISZ	ELCNT
	JMP	ELLOOP
END2,	TAD	(232		/^Z
	JMS I	QOCHAR
	JMS I	(OUDUMP		/DUMP BUFFER
	CIF	10
	JMS I	(7700		/GET USR
	10
	CIF	10
	CLA IAC
	JMS I	Q200		/CLOSE OUTPUT FILE
	4
	F1LNAM
FILSIZ,	0
	JMP	OUERR		/BADDDDIE
	TAD	FILSIZ		/FIX INPUT LIST
	CLL RTL
	RTL
	JMP	FINAL
ERMSG,	0			/PRINT ERROR MESSAGE ON THE TTY
	DCA	TEMP		/SAVE THE CODE
	TAD	QM4		/BACK UP THE ERROR
	TAD	ERRPTR		/POINTER
	DCA	X10
	CDF	10
	DCA I	X10		/ZERO END OF LIST
	TAD	TEMP		/NOW STICK IN THE CODE
	DCA I	X10
	TAD	X10		/SAVE THE NEW POINTER
	DCA	ERRPTR
	TAD	LINENO		/NOW THE LINE NUMBER
	DCA I	X10
	CDF
	TAD	TEMP		/PRINT ERROR CODE
	JMS I	QTTYP2C
	JMS I	QTTYP2C		/NOW SOME SPACES
	TAD	QTTYOUT		/FUDGE THE OUTPUT
				/ROUTINE POINTER
	DCA	QOCHAR		/SO THAT ONUMBR GOES TO
				/THE TTY
	TAD	LINENO		/PRINT THE LINE NUMBER
	JMS I	QONUMBR
	TAD	(OCHAR		/FIXUP OUTPUT POINTER
	DCA	QOCHAR
	JMS I	QTTCRLF
	JMS I	QGENCOD		/TRAP IF ERROR EXECUTED
	ERCODE-1
	JMP I	ERMSG
M7000,
OTMPS,	-7000			/OUTPUT TEMP BLOCK
	DCA	TEMP		/SAVE SIZE
	TAD I	OTMPS
	ISZ	OTMPS
	JMS I	QOUTSYM		/OUTPUT NAME
	TAD	COMMA
	JMS I	QOCHAR
	JMS I	QOPCDE		/ORG
	ORG
	TAD	Q256		/.
	JMS I	QOCHAR
	TAD	PLUS
	JMS I	QOCHAR
	TAD	TEMP
	CLL RAL
	TAD	TEMP		/SIZE TIMES THREE
	JMS I	QONUMBR
	JMS I	QCRLF
	JMP I	OTMPS
	PAGE
/ CHAIN TO RALF
/ PASS2O     VERSION 4A  PT 16-MAY-77
/CHANGES FOR OS/8 V3D AND OS/78 BY P.T.
/FIXED THE Q OPTION
/PATCH LEVEL IS IN LOCATION 26131
	IFZERO	OVERLY <	/ANOTHER SCORE FOR PAL8
	*OVRLAY
	NOPUNCH>
	IFNZRO	OVERLY <	/TO TAKE THE LEAD
	FIELD	2
	ENPUNCH
	*OVRLAY>		/LATE IN THE FINAL QUARTER
GORALF,	TAD	FILDEV		/GET SIZE AND DEVICE WORD
	DCA I	(7617		/PUT IT AWAY
	ISZ	(7617		/BUMP POINTER
	TAD	FILBLK		/GET ORIGIN OF FIE
	DCA I	(7617		/STORE IT
	ISZ	(7617
	DCA I	(7617		/ZERO END OF LIST
	TAD I	RALFSV
	CDF 0
	SPA CLA		/WAS /A SPECIFIED?
	JMP I	(7605	/YES - GET OUT
	CLA IAC
CHNLKP,	CIF	10
	JMS I	Q200
	2			/LOOKUP RALF.SV
	RALFNM
RALFSV,	7643
	JMP I	(7605
	TAD	(6		/**
	DCA	CHNLKP+2
	JMP	CHNLKP
RALFNM,	2201;1406;0000;2326	/RALF.SV
PASS3N,	2001;2323;6300;2326	/PASS3.SV

ADD,	JMS I	QCODE		/GENERATE CODE FOR ADD
	ADDTBL-6;0
	JMP I	QNEXT
/ EXP OPERATOR
ETYPE,	0
EXP,	JMS I	QSAVACT		/SAVE AC IF ITS SECOND ARG
	JMS I	QGARGS		/GET THE TWO ARGS
	JMP I	(OTERR		/TYPE/OPERATOR ERROR
	TAD	TYPE1		/GET PLACE IN TABLE
	CLL RTL
	TAD	TYPE1		/TYPE1 TIMES TEN
	TAD	TYPE2		/**
	CLL RAL
	TAD	(EXPTBL-15	/POINTER TO ENTRY MINUS ONE
	DCA	X10
	CDF	10
	TAD I	X10		/GET RESULTING TYPE
	SNA
	JMP I	(OTERR		/BAD IF THIS WORD IS ZERO
	DCA	ETYPE		/SAVE THE TYPE
	TAD I	X10		/GET THE SUBR NAME
	CDF
	DCA I	(ESUBR+2	/PUT IT INTO ITS PLACE
	TAD	TYPE1		/GET INTO CORRECT MODE
	JMS	SETMOD
	TAD	ARG1		/IS ARG 1 ALREADY IN THE AC
	SNA CLA
	JMP	.+5		/YES, SKIP THE LOAD
	JMS I	QOPCOD		/OTHERWISE LOAD IT
	FLDA
	JMS I	QOADDR
	ARG1
	JMS I	QOINS		/FSTA	#BASE
	FSTA;XBASE
	TAD	TYPE2		/SET MODE FOR ARG 2
	JMS	SETMOD
	JMS I	QOPCOD		/NOW LOAD IT
	FLDA
	JMS I	QOADDR
	ARG2
	JMS I	QOINS		/EXTERN FOR THE SUBR
	EXTERN;ESUBR
	JMS I	QOINS		/JSA TO THE SUBR
	JSA;ESUBR
	DCA I	X16		/RESULT IS THE AC
	TAD	ETYPE		/WITH THIS AS THE TYPE
	DCA I	X16
	DCA I	X16
	TAD	ETYPE		/SET FMODE CORRECTLY
	JMS I	QSKPIRL
	SKP
	CLA IAC			/RETURNED IN F MODE
	DCA	FMODE
	JMP I	QNEXT
SETMOD,				/SET MODE TO CORRESPOND
				/TO THE ARG
VOVER,	VERSON			/VERSION NUMBER FOR OVERLAY
	JMS I	QSKPIRL		/SKIP IF WE WANT F MODE
	JMP	.+3		/SET TO E MODE
	JMS I	QGENSF		/SET TO F MODE
	JMP I	SETMOD
	JMS I	QGENSE
	JMP I	SETMOD
FINAL,	CIA
	IAC
	DCA	FILDEV		/SAVE RALF INPUT SPEC
	CMA
	DCA I	X7746		/DON'T SAVE CORE ARROUND CHAIN
	JMS I	(DFRTTM	/DELETE FORTRN.TM
	CDF	10
	TAD I	Q7605		/IS THERE A LISTING FILE?
	SNA CLA
	JMP	GORALF		/NO, JUST CHAIN TO RALF
	CIF	10
	CDF
	CLA IAC
	JMS I	Q200		/FIND PASS 3
	2
	PASS3N
PAS3SV,	0
	JMP I	Q7605
	TAD	PAS3SV-1	/MOVE BLOCK TO CHAIN COMMAND
	IAC			/SKIP OVER CORE CONTROL BLOCK
	DCA	X7746
	JMS I	DEVH		/READ IN PASS 3
	NPPAS3
SPASS3,	400
X7746,	7746
	JMP I	Q7605
	JMP I	SPASS3		/GO DO PASS 3
	PAGE
/ I/O OPEN AND CLOSE

STRTIO,	0			/ROUTINE FOR STARTING IO STMT
	ISZ	IOSTMT		/SET IOSTMT SWITCH
				/(INCASE OF IMPLIED LOOPS)
	JMS I	QSAVEAC		/SAVE AC
	JMS I	QSAVACT		/IF NECESSARY
	TAD I	STRTIO		/GET NUMBER OF ARGS
	DCA	NARGS		/SAVE IT
	ISZ	STRTIO		/MOVE TOHE NME
	TAD	NARGS		/BACKUP STACK BY THIS MUCH
	TAD	NARGS		/THREE OR SIX
	TAD	NARGS
	TAD	X16
	DCA	X15
	TAD	X15
	DCA	TEMP		/FUNCTION NAME GOES HERE
	JMS I	QOPCDE		/EXTERN FOR SUBR
	EXTERN
	TAD I	STRTIO		/GET SUBROUTINE NAME
	JMS I	QOUTSYM		/OUTPUT IT
	JMS I	QCRLF
	TAD I	STRTIO		/PUT NAME
	DCA I	TEMP		/ONTO STACK
	JMS I	QGENSF		/ALL CALLS IN F MODE
	JMS I	QGENCAL		/GENERATE THE CALL
	NOP
	JMP I	QNEXT		/NOTHING FOR R CLOSE
FMTRD1,	IAC			/START FORMATTED READ
	DCA	INPUT		/SET INPUT = 1
	DCA	BINARY		/AND BINARY = 0
	JMS	STRTIO		/GO MAKE THE CALL
	-2;XREADO
FMTWR1,	DCA	INPUT		/SET SWITCHES
	DCA	BINARY
	JMS	STRTIO
	-2;XWRITO
BINRD1,	CLA IAC
	DCA	BINARY
	CLA IAC
	DCA	INPUT
	JMS	STRTIO
	-1;XRUO
BINWR1,	DCA	INPUT
	CLA IAC
	DCA	BINARY
	JMS	STRTIO
	-1;XWUO
WCLOSE,	CLA STL RTL		/TRAP3 HERE TOO**
	JMS	OJSR		/OUTPUT TRAP3 #WUC
	XWUC
	DCA	IOSTMT		/KILL IO SWITCH
	JMP I	QNEXT
OJSR,	0			/OUTPUT EXTERN THEN JSR OR TRAP3
	CLL RAL		/AC ON ENTRY IS 0 (JSR), 1 (JSA) OR 2 (TRAP3).
	TAD	(JSR
	DCA	OJSROP
	JMS I	QOPCDE		/FIRST EXTERN
	EXTERN
	TAD I	OJSR
	JMS I	QOUTSYM
	JMS I	QCRLF
	JMS I	QOPCDE		/THEN JSR
OJSROP,	0
	TAD I	OJSR
	ISZ	OJSR
	JMS I	QOUTSYM
	JMS I	QCRLF
	JMP I	OJSR

XWUC,	TEXT	'#RENDO'	/**
XREADO,	TEXT	'#READO'
XWRITO,	TEXT	'#WRITO'
XRUO,	TEXT	'#RUO'
XWUO,	TEXT	'#WUO'
RDRTNE,	TEXT	/#RSVO/
RDDRTN,	TEXT	/#RFDV/
FTRNTM,	0617;2224;2216;2415	/FORTRN.TM
DNA,	JMS I	QCODE		/AND CODE
	ANDTBL-6;0
	JMP I	QNEXT
PURGE,	JMS I	QGARG		/LOOK AT THE TOP OF STACK
	JMP I	(IOTYPE		/BAD TYPE
	TAD	ARG1		/IT MUST BE A SCALAR REFNCE
	CLL
	TAD	QM63
	SNL CLA
	JMP I	(IOTYPE		/BAD TYPE
	JMP I	QNEXT
PAUZE,	JMS I	QUCODE		/GET ARG INTO FAC
	AIFTBL-1
	JMS I	QGENCOD		/OUTPUT JSR
	PAZCOD-1
	JMP I	QNEXT
	PAGE
/DIRECT ACCESS I/O

DARD1,	CLA IAC			/SET SWITCHES
	DCA	INPUT
	CLA IAC
	DCA	BINARY		/SAME AS UNFORMATTED
	JMS I	(STRTIO		/GENERATE CALL
	-2;XRDAO
DAWR1,	DCA	INPUT		/SAME AS UNFORMATTED WRITE OPEN
	CLA IAC
	DCA	BINARY
	JMS I	(STRTIO		/CALL
	-2;XWDAO
DEFFIL,	TAD	XDFARG		/FAKE A CALL
	DCA I	(STRTIO		/TO SKIP THE ISZ IOSTMT
	JMP I	(STRTIO+2
XDFARG,	.+1
	-4;XDEF
XDEF,	TEXT	'#DEF'
XRDAO,	TEXT	'#RDAO'
XWDAO,	TEXT	'#WDAO'
/ RANDOM UNFITTING STUFF
RETURN,	JMS I	QGENCOD		/JA #RTN
	RTNCOD-1
	JMP I	QNEXT
GENSTF,	0			/GENERATE STARTF IF IN E MODE
	TAD	FMODE		/LOOK AT THE SWITCH
	SZA CLA
	JMP I	GENSTF		/ALREADY THERE
	ISZ	FMODE		/SET SWITCH
	JMS I	QOPCOD		/OUTPUT STARTF
	STARTF
	JMS I	QCRLF
	JMP I	GENSTF		/RETURN
NOT,	JMS I	QUCODE		/.NOT.
	NOTTBL-1
	JMP I	(RELGM1
SUB,	JMS I	QCODE		/SUBTRACT
	SUBTBL-6;0
	JMP I	QNEXT
MUL,	JMS I	QCODE		/MULTIPLY
	MULTBL-6;0
	JMP I	QNEXT
ASFDEF,	CLA IAC			/SET SWITCH FOR ASF PROLOG
	DCA	ASFSWT
	JMP I	QNEXT
OINS,	0			/OUTPUT TAB OPCODE TAB
				/ADDRESS CRLF
	DCA	WHATAC		/ZAPS AC
	JMS I	QOTAB
	TAD I	OINS		/GET OPCODE
	ISZ	OINS
	JMS I	QOUTSYM
	JMS I	QOTAB
	TAD I	OINS		/GET ADDRESS
	SZA
	JMS I	QOUTSYM
	JMS I	QCRLF		/END LINE
	ISZ	OINS
	JMP I	OINS
/ CODE GENERATOR FOR STORE
STORE,	JMS I	QGARGS		/GET ARGS FOR STORE
	JMP I	(OTERR
	TAD	ARG1		/KILL ANY XR
				/EXPRS. INVOLVING
	JMS I	QCHKXR		/THE VARIABLE BEING STORED
	TAD	ARG2		/IS SECOND ARG IN AC ?
	SNA CLA
	TAD	Q5		/YES, ADD 5 TO TYPE2
	TAD	TYPE2
	DCA	TYPE2
	TAD	TYPE1		/TYPE1 TIMES TEN
	CLL RTL
	TAD	TYPE1
	CLL RAL
	TAD	TYPE2		/PLUS TYPE2
	TAD	(STRTBL-13	/PLUS TABLE BASE
	DCA	SSKEL		/GIVES ENTRY ADDRESS
	CDF	10
	TAD I	SSKEL		/POINTER TO SKELETON
	DCA	SSKEL
	JMS I	QGENCOD		/GENERATE CODE
SSKEL,	0
	TAD	ASFSWT		/IS THIS END OF ASF ?
	SZA CLA
	JMP I	QNEXT		/YES, DON'T DO A STORE
	TAD	TYPE1		/MODE IS THE SAME
	JMS I	QSKPIRL		/AS THE VARIABLE STORED IN
	SKP
	CLA IAC
	DCA	FMODE
	JMS I	QOPCOD		/OUTPUT STORE
	FSTA
	JMS I	QOADDR		/ADDRESS FIELD
	ARG1
	TAD	ARG1		/REMEMBER THE AC
	CIA
	DCA	WHATAC		/(REMEMBER THE
	TAD	BASE1		/ALAMO ?)
	CIA			/(WOULD YOU
	DCA	WHATBS		/BELIEVE THE MAINE ???)
	ISZ	ARG1		/GO TO TYPE WORD
	CDF	10
	CLL			/IF ARG1 IS
	TAD	ARG1		/A SS'D REFNCE
	TAD	QM63		/DON'T
	SZL CLA			/BOTHER CHECKING
	TAD I	ARG1		/LOOK AT SOME BITS
	CDF
	AND	(3400		/DIM,EXT, OR ASF ?
	SNA CLA
	JMP I	QNEXT
	JMS I	QTTYMSG		/ATTEMPT TO STORE IN
	1720			/EXTERNAL OR ASF
FLDAP,	TEXT	'FLDA%'
	PAGE
/ARITHEMTIC STATEMENT FUNCTIONS (BLAH!)

DEFASF,	CDF			/A.S.F. PROLOG
	TAD	FMODE		/SAVE CPU MODE
	DCA	ASFMOD		/SINCE WE JUMP ARROUND
	TAD	X14		/SET STACK POINTER
	TAD	(3		/SO THAT ASF NAME STAYS
	DCA	X16
	CLA CMA			/SET ASF SWITCH
	DCA	ASFSWT
	TAD	TMPMAX		/USE UNIQUE TEMPS
	IAC
	DCA	TMPCNT		/FOR ALL ASF'S
	JMS I	QXRTBL		/AND FORGET XR'S
	JMS I	QOPCDE		/JA AROUND
	JA
	TAD	GLABEL		/SAVE ARROUND LABEL
	DCA	ASFSKP
	ISZ	GLABEL		/BUMP LABEL GENERATOR
	TAD	ASFSKP		/PUT LABEL AS ADDRESS OF JA
	JMS I	QOLABEL
	JMS I	QCRLF
	TAD	GLABEL		/FUNCTIONS XR'S O HERE
	JMS I	QLABEL		/OUPTUT THE LABEL
	JMS I	QOINS		/#GXXXX,  ORG   .+10
	ORG;DP8
	TAD	BASE1		/NOW OUTPUT FUNCTION NAME
	CDF	10
	JMS I	QOUTNAM
	TAD	COMMA		/AS TAG
	JMS I	QOCHAR		/OF START OF FUNCTION
	JMS I	QOPCDE		/SETX
	XSET
	TAD	GLABEL		/TO THE GENERATED LABEL
	ISZ	GLABEL
	JMS I	QOLABEL
	JMS I	QCRLF
	JMS I	QOINS		/LDX  0,1
	LDX;ZEROC1
	JMS I	QGENCOD		/STARTD
	SD-1			/JUST LIKE A SUBROUTINE
				/ISN'T IT ?
	JMS I	QOINS		/FLDA  #BASE
	FLDA;XBASE		/GET RETURN JUMP
	JMS I	QOPCDE		/STORE IT AHEAD
	FSTA
	TAD	GLABEL		/USING GENERATED LABEL
	JMS I	QOLABEL
	JMS I	QCRLF
ASFARG,	JMS I	QOINS		/FLDA% #BASE,1+
	FLDAP;XBAC1P		/GET ARG POINTER
	JMS I	QOINS		/FSTA	#BASE+3
	FSTA;XBASP3		/SAVE IT
	TAD I	X15		/GET PARAMETER
	DCA	ARG2
	TAD I	X15
	DCA	TYPE2
	ISZ	X15
	TAD	TYPE2		/IS IT SINGLE OR DOUBLE?
	JMS I	QSKPIRL
	JMP	ASFASE		/DOUBLE
	JMS I	QGENCOD		/STARTF
	SF-1
	CLA IAC
ARGSV,	DCA	FMODE		/SET FMODE APPROPRIATELY
	JMS I	QOINS		/FLDA% #BASE+3
	FLDAP;XBASP3		/GET THE VALUE
	JMS I	QOPCOD
	FSTA			/AND SAVE IT
	JMS I	QOADDR
	ARG2
	ISZ	NARGS		/ANY MORE ARGS ?
	SKP
	JMP I	QNEXT		/NO, END OF ASF PROLOG
	JMS I	QGENCOD		/STARTD
	SD-1
	JMP	ASFARG		/NEXT ARG
ASFASE,	JMS I	QGENCOD		/STARTE
	SE-1
	JMP	ARGSV
ASFEND,	0			/HANDLE END OF A.S.F.
	TAD	ASFSWT		/IS THIS END OF ASF ?
	SNA CLA
	JMP	PTCH		/V3C NO
	DCA	ASFSWT		/CLEAR SWITCH
	JMS I	QOINS		/RESET XR'S
	XSET;ZXR
	TAD	GLABEL		/OUTPUT SPACE FOR RETURN ADDR
	ISZ	GLABEL
	JMS I	QLABEL		/OUPTUT THE LABEL
	JMS I	QOINS		/ORG .+2
	ORG;DOTP2
	TAD	ASFSKP		/OUTPUT SKIP ARROUND LABEL
	JMS I	QLABEL		/OUPTUT THE LABEL
	JMS I	QCRLF
	TAD	ASFMOD		/RESET MODE SWITCH
	DCA	FMODE
	TAD	TMPMAX		/UNIQUE TEMPS
	IAC
	DCA	TEM		/V3C MUST BE USED
	JMS I	QXRTBL		/AND XR'S LOST
PTCH,	TAD	TEM		/V3C
	DCA	TMPCNT		/V3C
	JMP I	ASFEND		/RETURN
ASFMOD,	0
ASFSKP,	0
IOFUN,	JMS I	QOPCDE		/CALLED BY TRAP3,NOT JSR**
	TRAP3
	TAD I	TEMP
	JMS I	QOUTSYM		/OUTPUT THE IO FUNCTION NAME
	JMP I	(IOONLY		/DO SOME OTHER STUFF
ESUBR,	TEXT	'#EXPXX'	/THIS WILL BE THE CORRECT NAME
	PAGE
/ I/O LIST ELEMENT

IOLMNT,	JMS I	QGARG		/GET THE ARG
	JMP	IOTYPE		/TYPE ERROR
	DCA	IOLOOP		/CLEAR LOOP SWITCH
	CLL STA RTL	/-3
	TAD	TYPE1
	DCA	TYPE1	/TYPE1 = 0 IF COMPLEX, 1 IF D.P.
	TAD	ARG1		/ADDR OF TYPE WD
	CLL IAC
	DCA	ARG2
	TAD	ARG1		/LOOK AT ARG
	TAD	QM63
	SNL CLA
	JMP	NOLOOP		/NOT ARRAY OUTPUT
	CDF	10
	CLL CML RTR		/IS IT DIMENSIONED ?
	AND I	ARG2
	CDF
	SNA CLA
	JMP	NOLOOP		/NO, NO LOOP
	ISZ	IOLOOP		/SET SWITCH
	TAD	ARG1		/GET TO SS
	JMS I	QGETSS
	IAC			/TOTAL SIZE WORD
	DCA	BASE1
	TAD I	ARG2		/IS THIS ARRAY AN ARG ?
	AND	Q20
	DCA	ARGIO		/SET SWITCH
	TAD I	BASE1		/IS IT VARIABLY DIMENSIONED ?
	SNA
	JMP I	(VDAIO		/YES, MUST COMPUTE SIZE
	DCA	BASE2		/SAVE SIZE
	CDF
	JMS I	QOPCDE		/PUT SIZE IN XR 1
	LDX
	TAD	Q255
	JMS I	QOCHAR		/-
	TAD	BASE2
	JMS I	QONUMBR
	TAD	COMMA
	JMS I	QOCHAR
	TAD	(261
	JMS I	QOCHAR
	JMS I	QCRLF
	TAD	ARGIO		/IS IT AN ARG ?
	SZA CLA
	JMP I	(ARGIOA		/YES
OLLABL,	TAD	GLABEL		/OUTPUT LABEL
	JMS I	QOLABEL
	DCA I	(XRBUFR+20	/KILL XR1 ENTRY
	TAD	COMMA
	JMS I	QOCHAR
NOLOOP,	TAD	INPUT		/INPUT OR OUTPUT ?
	SNA CLA
	JMP	OUTV		/OUTPUT
	JMS	FIXCAL		/SET PTR FOR OJSR**
	JMS I	(DUMSUB		/NOW THE STORE
	FSTA
	TAD	ARG1		/KILL ASSOCIATED
	JMS I	QCHKXR		/XR EXPRESSIONS
CDSFLP,	TAD	TYPE1		/IS IT C OR D ?
	CLL RAR
	SZA CLA
	JMP	ENDLUP		/NO, NO STARTE
	JMS I	QGENCOD
	SF-1
ENDLUP,	TAD	IOLOOP		/IS THERE A LOOP ?
	SNA CLA
	JMP I	QNEXT		/NO, DO NEXT LIST ELEMENT
	JMS I	QOPCDE		/YES, OUTPUT JXN
	JXN
	TAD	GLABEL
	ISZ	GLABEL		/OUTPUT LABEL
	JMS I	QLABEL		/OUPTUT THE LABEL
	TAD	(261
	JMS I	QOCHAR
	TAD	PLUS		/OUTPUT PLUS (FOR
				/INCREMENT DUMMY)
	JMS I	QOCHAR
	JMS I	QCRLF
	JMP I	QNEXT		/DO NEXT LIST ELEMENT
OUTV,	TAD	TYPE1		/D OR C ?
	CLL RAR
	SZA CLA
	JMP	.+3		/NO, NO STARTF NECCESSARY
	JMS I	QGENCOD
	SE-1
	JMS I	(DUMSUB		/OUTPUT FLDA
	FLDA
	JMS	FIXCAL
	JMP	CDSFLP		/THEN STARTF AND JXN IF ANY
FIXCAL,	6401
	TAD	TYPE1	/IF VARIABLE IS COMPLEX,
	CIA		/OR IF VARIABLE IS DOUBLE AND
	SZA		/I/O IS BINARY,
	TAD	BINARY	/GENERATE A JSR #RFDV
	SNA CLA		/ELSE GENERATE A TRAP3 #RSVO
	JMP	BINDIO
	CLA STL RTL		/SET PTR
	JMS I	(OJSR		/NOW GO DO IT
	RDRTNE			/HERE'S THE NAME
	JMP I	FIXCAL
BINDIO,	JMS I	(OJSR
	RDDRTN
	JMP I	FIXCAL

IOTYPE,	JMS I	QTTYMSG		/IO TYPE ERROR
	1124
DEFLBL,	JMS I	QCRLF		/CRLF BEFORE LABL
	JMS I	QGENSF		/ENTER F MODE BEFORE ALL LABELS
	JMS I	QINWORD		/GET THE LABEL
	CDF	10
	JMS I	QOSNUM		/OUTPUT IT
	TAD	COMMA
	JMS I	QOCHAR
	JMS I	QXRTBL		/KILL XR TABLE
	DCA	WHATAC		/AND AC AT LABEL
	JMP I	QNEXT
	PAGE
/ I/O LIST ELEMENT

VDAIO,	CLL CMA RAL		/GET ADDR OF NUMBER OF DIMS
	TAD	BASE1
	DCA	X10
	TAD I	X10		/GET DIM COUNT
	CIA
	DCA	NARGS
	ISZ	X10		/SKIP SIZE
	ISZ	X10		/AND MAGIC NUMBER
	ISZ	X10		/AND LITERAL NUMBER
	TAD	(FLDA		/LOAD FIRST DIM
	SKP
GSIZLP,	TAD	(FMUL		/MULTIPLY THE REST
	DCA	OPCIO
	CDF	10
	TAD I	X10		/GET THE NEXT DIMENSION
	DCA	TYPE2
	CDF
	JMS I	QOPCOD		/OUTPUT OPCODE
OPCIO,	0
	JMS I	QOADDR		/NOW THE DIMENSION
	TYPE2
	ISZ	NARGS
	JMP	GSIZLP		/KEEP GOING
	JMS I	QOPCOD		/NEGATE THE FAC
	FNEG
	JMS I	QCRLF
	JMS I	QGENCOD		/PUT THE COUNT INTO XR1
	ATX1-1
ARGIOA,	JMS I	QGENCOD		/PUT -1 INTO XR 2
	LXM1C2-1
	JMS I	QOPCDE		/LOAD THE ARG POINTER -
	FLDA			/CONST
	DCA I	(XRBUFR+40	/KILL XR 2 ENTRY
	TAD	ARG1
	CDF	10
	JMS I	QOUTNAM
	JMS I	QCRLF
	JMS I	QOPCDE		/NOW ADD THE MAGIC NUMBER
	FADD
	TAD	QLITRL		/OUTPUT #LIT+XXXX
	JMS I	QOUTSYM
	CDF	10
	ISZ	BASE1
	ISZ	BASE1
	TAD I	BASE1
	CDF
	JMS I	QONUMBR
	JMS I	QCRLF
	JMS I	QOPCDE
	FSTA			/NOW STORE IN #BASE+3
	TAD	(XBASP3
	JMS I	QOUTSYM
	JMS I	QCRLF
	JMS I	QGENCOD		/STARTF
	SF-1
	JMP I	(OLLABL		/NOW THE INSIDE OF THE LOOP
DUMSUB,	0			/OUTPUT FLDA OR FSTA
				/WITH SE IF NEEDED
	TAD I	DUMSUB		/GET THE OPCODE
	DCA	LDASTA
	ISZ	DUMSUB
	TAD	TYPE1		/MUST WE SE ?
	CLL RAR		/TYPE1 IS 0 IF C, 1 IF D
	SNA CLA
	TAD	Q3		/MULTIPLIER IS 6
	TAD	Q3		/OR 3
	DCA	MQ
	JMS I	QOPCOD		/FLDA OR FSTA
LDASTA,	0
	TAD	IOLOOP		/IS IT A LOOP ?
	SNA CLA
	JMP	EZVAR		/NO
	TAD	ARGIO		/IS IT AN ARG  ?
	SZA CLA
	JMP	IBASP3		/YES, INDIRECT THROUGH #BASE+3
	JMS I	QOTAB
	TAD	ARG1
	CDF	10		/OUTPUT NAME
	JMS I	QOUTNAM
	TAD	(255		/-
	JMS I	QOCHAR
	TAD	BASE2		/NEGATIVE OF SIZE
	CIA
	JMS I	QMUL12		/TIMES 6 OR 3
	JMS I	QNUMBRO
	TAD	COMMA		/COMMA SEVEN
	JMS I	QOCHAR
	TAD	(261
	JMS I	QOCHAR
	JMS I	QCRLF
	JMP I	DUMSUB		/RETURN
EZVAR,	JMS I	QOADDR		/ITS A SCALAR
	ARG1
	JMP I	DUMSUB
IBASP3,	TAD	(245		/INDIRECT THROUGH #BASE+3
	JMS I	QOCHAR
	JMS I	QOTAB
	TAD	(XBPC2P		/FLDA%	#BASE+3,2+
	JMS I	QOUTSYM
	JMS I	QCRLF
	JMP I	DUMSUB
XBPC2P,	TEXT	'#BASE+3,2+'
OR,	JMS I	QCODE
	ORTABL-6;0
	JMP I	(RELGEN
XOR,	JMS I	QCODE
	EQVTBL-6;0
	JMP I	(RELGEN
DOTP2,	TEXT	'.+2'
ZXR,	TEXT	'#XR'
	PAGE
/ ASSIGNED GOTO AND ASSIGN

AGOTO,	JMS	GTSTUF		/LOOK AT THE ASSIGNED VAR
	JMS I	QGENCOD		/GENERATE A JAC
	AGTCOD-1
	JMP I	QNEXT
ASSIGN,	JMS I	QGARG		/GET THE ASSIGN VAR
	JMP	GTTYPE
	CLL CMA RTL		/MUST BE I OR R
	TAD	TYPE1
	SMA CLA
	JMP	GTTYPE		/GOTO TYPE ERROR
	JMS I	QGENCOD		/GENERATE THE ASSIGN CODE
	ASNCOD-1
	JMS I	(JAGEN
	JMS I	QGENCOD		/NOW STORE IT
	ASTOR-1
	JMP I	QNEXT
/ OPTIMIZER SUBROUTINES
CHEKXR,	0			/KILL XR EXPRS
	CIA			/ASSOCIATED WITH THIS VAR
	DCA	KILVAR		/SINCE IT HAS
				/JUST BEEN CHANGED
	TAD	(-7		/LOOK AT XR 1 THRU 7
	DCA	TEMP		/COUNT
	TAD	(XRBUFR+20	/POINTER
	DCA	TEMP2
KILLUP,	TAD I	TEMP2		/GET NEXT XR
				/EXPR. INDICATOR
	SNA CLA
	JMP	EOKL		/NOTHING HERE
	TAD	TEMP2		/GET POINTER
	DCA	X13		/INTO AN XR
	TAD I	X13		/GET ADDR OF DIB
	DCA	DIMPTR		/SAVE IT
	CDF	10		/FIELD OF SYMBOL TABLE
	TAD I	DIMPTR		/GET NUMBER OF
				/DIMENSIONS
	CMA			/COMPLIMENTED
	DCA	NARGS		/SAVE IT
	CDF			/BACK TO FIELD OF XRBUFR
CHKKIL,	ISZ	NARGS		/CHECK 1 LESS
				/THAN THE NUMBER
	SKP			/OF DIMENSIONS
	JMP	EOKL
	TAD I	X13		/LOOK AT NEXT
				/ELEMENT OF EXPR
	TAD	KILVAR		/IS IT THE VAR
				/JUST CHANGED ?
	SNA CLA
	DCA I	TEMP2		/YES, KILL THIS EXPRESSION
	JMP	CHKKIL		/LOOP
EOKL,	TAD	TEMP2		/DO NEXT XR
	TAD	Q20
	DCA	TEMP2		/BUMP POINTER BY 16
	ISZ	TEMP
	JMP	KILLUP
	JMP I	CHEKXR		/RETURN
KILVAR,
XRTABL,	0			/CLEAR OR RESET
				/XR TABLE FLAGS
	DCA	TYPE		/0=CLEAR  1=RESET
	TAD	(-7		/DO XR1 THRU 7
	DCA	TEMP		/COUNT
	TAD	(XRBUFR+20	/POINTER
	DCA	TEMP2
XRTLUP,	TAD I	TEMP2		/GET INDICATOR
	SNA CLA
	JMP	.+3		/DON'T CHANGE IF ZERO
	TAD	TYPE		/OTHERWISE SET TO
	DCA I	TEMP2		/'USED BY
				/PREVIOUS STMT'
	TAD	TEMP2		/GET TO NEXT ONE
	TAD	Q20
	DCA	TEMP2		/BUMPING BY 16
	ISZ	TEMP
	JMP	XRTLUP		/LOOP
	JMP I	XRTABL		/DONE
LOADA,	0			/GENERATE AN FLDA
	TAD I	LOADA		/IF NECESSARY
	DCA	LODARG		/GET ARG POINTER
	ISZ	LOADA		/BUMP RETURN
	TAD I	LODARG		/DOES AC MATCH ?
	TAD	WHATAC
	SZA CLA
	JMP	DOLOAD		/NO, MUST LOAD
	TAD	LODARG		/GET ADDRESS
	IAC			/OF BASE
	DCA	ARG		/IN CASE SS'D
	TAD I	ARG		/DOES BASE MATCH?
	TAD	WHATBS
	SNA CLA
	JMP I	LOADA		/OK, DON'T LOAD
DOLOAD,	JMS I	QOPCOD		/GENERATE FLDA
	FLDA
	JMS I	QOADDR		/ADDRESS
LODARG,	0
	JMP I	LOADA
	PAGE
/ INTER PASS EQUATES
	BLNKCN=21
	ALIST=23
	INTLST=60
	FPLIST=56
	DPLIST=57
	CMPLST=61
	HOLIST=55
	SNLIST=62
	ONEI=63
	THREE=70
	SIX=75
	TRUE=102
/ START PASS 2 (INTER PASS COMMUNICATION)
	IFNZRO	OVERLY <
	FIELD	0
	NOPUNCH
	*OVRLAY>
	IFZERO	OVERLY <
	FIELD	0
	ENPUNCH
	*OVRLAY>
START2,	JMP I	Q7605		/RETURN BUT DON'T SAVE CORE
	TAD I	X10		/PICK UP NEXT FROM PASS 1
	DCA	X17
	TAD	X17		/SAVE POINTER TO
				/EXTERNAL LITERALS
	DCA	EXTLIT
	TAD I	X10		/PASS ONE STACK LEVEL
	DCA	X11
	TAD I	X10		/TEMP FILE START
	DCA	INBLOK
	TAD I	X10		/AND SIZE
	CMA
	DCA	INRCNT
	TAD I	X10		/START OF PASS2O.SV
	DCA	PASS2O
	TAD I	X10		/START OF OUTPUT FILE
	DCA	FILBLK		/SAVE IT FOR CHAINING TO RALF
	TAD	FILBLK
	DCA	OBLOCK
	TAD I	X10
	DCA	OSIZE		/ALSO MAX SIZE
	TAD I	X10		/PICK UP PROG NAME
	DCA	PROGNM
	TAD I	X10
	DCA	ARGLST		/AND ARG LIST ADDR
	TAD I	X10		/AND
				/FUNCTION/SUBROUTINE/MAIN SWITCH
	DCA	FUNCTN
	TAD I	X10		/GET DP HARDWARE SWITCH
	DCA	DPUSED
	TAD I	X10		/CHECK FOR CROSSED VERSIONS
	TAD	VERS
	SZA CLA
	JMP	VERROR		/VERSION ERROR
	STA STL			/V3C
DCLOOP,	TAD	X11		/V3C THIS ADD CLEARS THE LINK
	DCA	X11		/V3C
	TAD	X11
	TAD	(-STACK1
	SNL CLA
	JMP	PSN		/GO DO STMT NUMBERS
	TAD I	X11		/GET DO LOOP ENDING STMT NUMBER
	IAC
	DCA	X10
	CDF	10
	TAD	(0416		/DN  DO END MISSING
	JMS	NPRNT		/GO PRINT THE MESSAGE
				/AND THE NUMBER
	CDF
	CLL CMA RTL
	JMP	DCLOOP		/V3C BACK UP 2
PSN,	TAD	(SNLIST		/PROCESS STMT NUMBERS
	CDF	10
SNCLUP,	DCA	ENTRY		/SAVE NEW ENTRY ADDR
	TAD I	ENTRY		/GET ADDR OF NEXT ENTRY
	SNA
	JMP	SNDONE		/NO MORE STMT NUMBERS
	IAC
	DCA	TEMP		/ADDR OF TYPE WORD
	TAD I	TEMP		/WAS STMT NUMBER DEFINED?
	SPA CLA
	JMP	SNDEFN		/YES
	TAD	TEMP
	DCA	X10
	TAD	(2523		/PRINT US MESSAGE
	JMS	NPRNT
SNDEFN,	TAD	(0110		/SET TYPE WORD
	DCA I	TEMP
	TAD I	ENTRY		/PROCEED
	JMP	SNCLUP
SNDONE,	CDF
FIXELP,	JMS I	(TYPRTN
	NEGSLV		/FIX UP NEGATIVE EQUIVALENCE OFFSETS
	CLL CML RTL		/CHECK FOR BLOCK DATA
	TAD	FUNCTN		/(FUNCTN=-2)
	SNA CLA
	JMP	BDSTUF		/IT IS
	JMS I	(TYPRTN		/DO IMPLICIT TYPING
	IMPLCT
	JMS I	(TYPRTN		/REMOVE SUB ARGS FROM LIST
	SUBARG
	JMS I	(TYPRTN		/EXTERNALS
	EXTRNL
	JMP I	(PROLG1		/MORE PROLOG
BDSTUF,	TAD I	(BDSWIT		/SET UP SWITCH
	DCA I	(PROLG2
	TAD	(END2		/ALTER END CODE
	CDF 10
	DCA I	(XEND
	CDF 0
	DCA	NODBUG		/NO ISN'S
	JMP I	(HOLDUN		/DO SOME STUFF
SUBARG,	0			/REMOVE ARGS FROM ST
	TAD I	TYPE
	AND	Q20		/CHECK ARG BIT
	SNA CLA
	JMP I	SUBARG
	JMS	UNHOOK
	JMP	TFUDGE

UNHOOK,	0
	TAD I	ENTRY
	DCA I	OENTRY
	TAD	BUCKET
	DCA I	ENTRY
	JMP I	UNHOOK

VERROR,	TAD	(2605		/PRINT VE (VERSION ERROR)
	JMS I	QTTYP2C
	JMS I	QTTCRLF
	JMP I	Q7605
	PAGE
/ GENERATE ARGUMENT STORAGE

PROLG1,	JMS I	(INS2		/	%JA	#ST
	JA;XST
	JMS I	(INS		/#XR,	%ORG	.+10
	XXR;ORG;DP8
	JMS I	QOPCDE		/	%TEXT	#NAMEXX#
	TEXTX
	TAD	PLUS
	JMS I	QOCHAR
	CDF	10
	TAD	PROGNM
	JMS I	QOUTNAM
	JMS I	(FILL		/FILL WITH BLANKS
	TAD	PLUS
	JMS I	QOCHAR
	ISZ	PROGNM
	JMS I	QCRLF
	JMS I	(INS		/#RET,	%SETX	#XR
	XRET;SETX;XXR
	JMS I	(INS2		/	%SETB	#BASE
	SETB;XBASE
	JMS I	(INS2		/	%JA	.+3
	JA
XDP3,	DP3
	JMS I	(INS		/#BASE,	%ORG	.+6
	XBASE;ORG;DP6
	TAD	ARGLST		/ANY ARGS ?
	SNA
	JMP	NOARGS		/NO, SKIP THIS STUFF
	DCA	X10		/SAVE POINTER TO ARG LIST
	CDF	10		/HOW MANY ?
	TAD I	ARGLST
	CIA
	DCA	NARGS		/THIS MANY
	DCA	TEMP2		/ARRAY ARG COUNTER
ARGLP1,	JMS	PLSUB1		/OUTPUT DEFS FOR ARRAY
				/ARGS FIRST
	SNA CLA			/SINCE THEY MUST BE
				/INDIRECTABLY
	JMP	NOARAY		/REFERENCABLE
	ISZ	TEMP2
NOARAY,	ISZ	NARGS
	JMP	ARGLP1		/PROCESS ENTIRE ARG LIST
	CDF	10
	TAD I	ARGLST		/GO THRU ARGS AGAIN
	CIA CLL
	DCA	NARGS
	TAD	ARGLST
	DCA	X10
	TAD	TEMP2		/HOW MANY ARRAY ARGS ?
	TAD	QM6
	SNA
	JMP	NISA		/NO INDIRECT LOCS LEFT
				/FOR SCALARS
	DCA	TEMP2
	SZL CLA
	JMP	TOOMNY		/TOO MANY ARRAY ARGS (>6)
ARGLP2,	JMS	PLSUB1		/NOW OUTPUT AS MANY INDIRECT
	SZA CLA			/SCALAR ARGS AS POSSIBLE
	JMP	NOSCLR		/TO REDUCE THE PROLOG
	ISZ	TEMP2		/ROOM FOR ANY MORE
	SKP
	JMP	NISA2		/NO, THE REST MUST MOVE VALUES
NOSCLR,	ISZ	NARGS		/LOOP SOME MORE
	JMP	ARGLP2
	JMS I	(PLSUB2		/OUTPUT SOME TRACEBACK STUFF
	JMP I	(MORE		/GENERATE SCALAR,
				/LITERAL AND TEMP STORAGE
NISA2,	JMS I	(PLSUB2
	JMP	NDLP3		/OUTPUT TRACEBACK
				/STUFF,THEN REST
NISA,	JMS I	(PLSUB2		/GET PAST THE TRACEBACK STUFF
ARGLP3,	TAD	XM3		/GENERATE ORG .+6 FOR D OR C
	DCA	XNOP
	JMS	PLSUB1		/OUTPUT REMAINING
				/SCALAR ARG SPACE
	SZA CLA
	JMP	NDLP3
	CDF	10
	TAD I	TEMP		/TURN OFF SUBARG BIT
	AND	(7757		/(THATS THE
				/SECOND TIME I FIXED THIS)

	DCA I	TEMP
NDLP3,	ISZ	NARGS
	JMP	ARGLP3
	CDF
	JMP I	(MORE		/GENERATE SCALAR,
				/LITERAL AND TEMP STORAGE

NOARGS,	JMS I	(PLSUB2		/NO ARGS, OUTPUT TRACEBACK STUFF
	JMP I	(MORE		/GENERATE SCALAR,
				/LITERAL AND TEMP STORAGE
PLSUB1,	0	
	CDF
	TAD I	PLSUB1		/GET THE SKIP
	DCA	PLSKIP
	ISZ	PLSUB1
	CDF	10
	TAD I	X10		/GET THE NEXT ARG
	IAC
	DCA	TEMP		/TYP WORD ADDR
	CLL CML RTR		/2000=DIM BIT
	AND I	TEMP
PLSKIP,	0			/ARRAYS OR SCALARS ?
	JMP I	PLSUB1
	ISZ	PLSUB1
	CLA CMA
	TAD	TEMP		/DEFINE THIS VAR
	JMS I	QOUTNAM
	TAD	COMMA
	JMS I	QOCHAR
	CDF	10
	TAD I	TEMP		/LOOK AT THE TYPE
	CDF
	JMS I	QSKPIRL		/SKIP IF NOT C OR D
XNOP,	NOP			/THIS IS CHANGED LATER (MAYBE)
	TAD	XDP3		/.+3 OR .+6
	DCA	.+3
	JMS I	(INS2		/ORG FOR THE VALUE
	ORG;0
	JMP I	PLSUB1
TOOMNY,	TAD	P0F1		/TOO MANY ARRAY ARGS
	JMP I	P0F2
XM3,	CLL CML RTL
	PAGE
/ SCALARS, LITERALS & TEMPS

HOLLIT,
MORE,	JMS I	(TYPRTN		/OUTPUT SCALARS
	SCALAR
	TAD	(TEMPS		/OUTPUT FIRST FIVE TEMPS
	JMS I	(OUTVAR
	TAD	(LITRL2
	JMS I	QOUTSYM
	TAD	COMMA		/OUTPUT %LITRL,
	JMS I	QOCHAR
	JMS I	(DOLIST
	INTLST
O141,	0141;-3			/OUTPUT INTEGER LITERALS
	JMS I	(DOLIST
	FPLIST
	0142;-3			/OUTPUT FP LITERALS
	JMS I	(DOLIST
	DPLIST
	0144;-6			/DOUBLE LITERALS
	JMS I	(DOLIST
	CMPLST
	0143;-6			/COMPLEX LITERALS
	JMS I	(TYPRTN		/OUTPUT DIMENSION FACTORS
	DFLIT
	JMS I	(ADFLIT		/OUTPUT ARG DIM FACTOR LITERALS
	TAD	(HOLIST		/OUTPUT HOLLERITH LITERALS
	DCA	ENTRY
HOLLUP,	CDF	10
	TAD I	ENTRY
	SNA
	JMP	HOLDUN
	DCA	ENTRY		/SAVE NEW ENTYR
	TAD	ENTRY
	DCA	X10
	TAD	O141		/SET TYPE INFO
	DCA I	X10
	TAD	LITNUM
	DCA I	X10		/SAVE LIT DISP
	CLL CMA RTL		/SET UP COUNTER
	DCA	HOLLIT		/BY THREES
HOLOOP,	CDF	10		/OUTPUT LITERAL AS OCTALS
	TAD I	X10
	CDF
	SNA
	JMP	HOFILL		/FILL OUT REST
	DCA	ARG
	TAD	ARG
	AND	(77		/IS THIS LAST WORD?
	SZA CLA
	JMP	.+4		/NO
	TAD	ARG		/YES, STICK IN
	TAD	Q40		/BLANK
	JMP	HOFILL+1	/AND OUTPUT IT
	TAD	ARG		/OUTPUT CHAR PAIR
	JMS	ONUM
	ISZ	HOLLIT
	JMP	HOLOOP
	JMP	HOLOOP-2
HOFILL,	TAD	(4040		/FILL WITH BLANKS
	JMS	ONUM
	ISZ	HOLLIT
	JMP	HOFILL
	JMP	HOLLUP		/DO NEXT HOLLERITH LITERAL
HOLDUN,	CDF
	JMS I	(TYPRTN		/DO ARRAYS
	ARRAYS
	JMS I	(TYPRTN		/REMOVE COMMON VARS FROM S.T.
	COMVAR
	JMS I	QOTAB
	TAD	(XLBLE		/#LBL=.
	JMS I	QOUTSYM
	JMS I	QCRLF
	CDF	10		/LOOK AT THE BLANK COMMON LIST
	TAD I	(ONEI+2		/MAKE TRUE=INTEGER ONE
	DCA I	(TRUE+2
	TAD I	(BLNKCN+1
	CDF
	SNA
	JMP	NOBC		/NO BLANK COMMON
	DCA	TYPE		/POINTER TO VARIABLE LIST
	JMS I	QOPCOD
	COMMON
	JMS I	QCRLF
	CDF	10
BCLOOP,	TAD	TYPE		/PROCESS THIS HUNK OF
				/BLANK COMMON
	DCA	X10
	TAD I	X10
	SNA
	JMP	NXTBC		/EMPTY HUNK
	CIA			/SIZE OF HUNK
	DCA	TEMP
	TAD I	X10		/OUTPUT HUNK
	JMS I	(OUTVAR
	CDF	10
	ISZ	TEMP
	JMP	.-4
NXTBC,	TAD I	TYPE		/ADDR OF NEXT HUNK
	SNA
	JMP	NOBC		/THAT WAS THE LAST HUNK
	DCA	TYPE
	JMP	BCLOOP		/DO NEXT HUNK
NOBC,	CDF
	JMS I	(TYPRTN		/DO NAMED COMMONS
	COMNAM
	JMS I	(TYPRTN		/NOW EQUIVALENCES
	EQUIVS
	JMS	INS2
	ORG;XLBL		/%ORG #LBL
	JMP I	(PROLG2		/COMPLETE PROLOG
	PAGE
/ ARGUMENT PICKUP GENERATOR

PROLG2,	TAD	FUNCTN		/SECOND PART OF PROLOG
	SZA CLA
	JMP	DORETN		/NOT A MAIN PROG
	JMS I	(INS		/#ST,	BASE	#BASE
	XST;BASE;XBASE
	JMS I	(INS2		/	SETB	#BASE
	SETB;XBASE
	JMS I	(INS2		/	SETX	#XR
	SETX;XXR
BDSWIT,	JMP I	(FINIST		/GO GET OVERLAY
DORETN,	JMS I	(INS		/#RTN,	BASE	#BASE
	XRTN;BASE;XBASE
	TAD	ARGLST		/ANY ARGS ?
	SNA
	JMP	JAGOBK		/NO
	DCA	X10		/POINTER TO THE LIST
	CDF	10
	TAD I	ARGLST		/NUMBER OF ARGS
	CIA
	DCA	NARGS
	DCA	TEMP2		/ZERO ARG COUNTER
	CDF
	TAD	NARGS		/WILL WE RESTORE ANY ?
	TAD	(6
	SMA CLA
	JMP	JAGOBK		/NO
	JMS I	(INS2		/	FLDA	#ARGS
	FLDA;XARGS
	JMS I	(INS2		/	FSTA	#BASE
	FSTA;XBASE
RSLOOP,	CDF	10
	TAD I	X10		/GET NEXT ARG
	IAC
	DCA	TEMP		/ADDR OF TYPE WORD
	ISZ	TEMP2		/INCR COUNT
	TAD I	TEMP		/IS IT A VALUE TRANSMISSION ?
	AND	Q20
	CDF
	SZA CLA
	JMP	NOREST		/NO, DON'T RESTORE IT
	JMS I	QOPCDE		/	%LDX	XXXX,1
	LDX
	TAD	TEMP2
	JMS I	QONUMBR
	TAD	(C1
	JMS I	QOUTSYM
	JMS I	QCRLF
	JMS I	QGENCOD		/STARTD
	SD-1
	JMS I	(INS2		/GET POINTER TO ARG
	FLDAI;XBASC1
	JMS I	(INS2		/AND SAVE IN #BASE+3
	FSTA;XBASP3
	JMS	STFORE		/INTO CORRECT MODE
	JMS I	QOPCDE		/FLDA VAR
	FLDA
	CMA
	TAD	TEMP
	CDF	10
	JMS I	QOUTNAM
	JMS I	QCRLF
	JMS I	(INS2		/	FSTA%	#BASE+3
	FSTAI;XBASP3
NOREST,	ISZ	NARGS
	JMP	RSLOOP
	JMS I	QGENCOD		/MAKE SURE WE'RE IN F MODE
QSFM1,	SF-1
JAGOBK,	TAD	FUNCTN		/WHAT WAS THIS ?
	SPA CLA
	JMP	NOFVAL		/NOT A FUNCTION
	CDF	10		/GET TYPE
	TAD I	PROGNM
	AND	Q17
	TAD	(FVAL-1		/PLUS TABLE ADDRESS
	DCA	GVSKEL		/GIVES POINTER TO
				/SKELETON ADDRESS
	TAD I	GVSKEL		/GET SKELETON ADDRESS
	DCA	GVSKEL
	JMS I	QGENCOD		/PICK UP FUNCTION VALUE
GVSKEL,	0
NOFVAL,	JMS I	(INS2		/	JA	#GOBAK
	JA;XGOBAK
	JMS I	(INS		/#ST,	%STARTD
	XST;STARTD;0
	JMS I	QOTAB
	TAD	(210		/	%FLDA'	10
	JMS I	QONUMBR
	JMS I	QCRLF
	JMS I	(INS2		/	%FSTA	#GOBAK,0
	FSTA;XGOBC0
	JMP I	(MORPLG

STFORE,	0			/START F OR E
	CDF	10
	TAD I	TEMP		/GET TYPE
	CDF
	JMS I	QSKPIRL		/SKIP ON I R OR L
	TAD	(SE-SF		/SE
	TAD	QSFM1		/SF
	DCA	.+2
	JMS I	QGENCOD
	0
	JMP I	STFORE		/DON'T FORGET TO
				/RETURN DUMMY
XARGS,	TEXT	'#ARGS'
	PAGE
/ ENTRY AND EXIT CODE

MORPLG,	JMS I	QOTAB
	TAD	Q200		/	FLDA'	0
	JMS I	QONUMBR
	JMS I	QCRLF
	JMS I	(INS2		/	%SETX	#XR
	SETX;XXR
	JMS I	(INS2		/	%SETB	#BASE
	SETB;XBASE
	TAD	ARGLST		/ANY ARGS ?
	SNA
	JMP I	(ENDPLG		/NO, JUST STARTF
	DCA	ARG		/SAVE POINTER TO THEM
	JMS I	(INS2		/	%LDX	0,1
	LDX;ZC1
	JMS I	(INS2		/	%FSTA	#BASE
	FSTA;XBASE
	JMS I	(INS2		/	%FSTA	#ARGS
	FSTA;XARGS
	CDF	10
	TAD I	ARGLST		/NUMBER OF ARGS
	CIA
	DCA	NARGS
GALOOP,	CDF
	JMS I	(INS2		/	%FLDA I	#BASE,1+
	FLDAI;XBAC1P
	DCA	TYPE		/CLEAR THE SD SWITCH
	CDF	10
	ISZ	ARG		/GET TO NEXT ARG
	TAD I	ARG		/LOOK AT ITS TYPE WORD
	IAC
	DCA	TEMP
	CLL CML RTR
	AND I	TEMP		/WAS IT DIMENSIONED ?
	SNA CLA
	JMP I	(TSTABT		/NO, SEE IF ITS VALUE
	CMA
	TAD	TEMP		/GET ADDR OF DIM INFO
	JMS I	QGETSS
	IAC			/ADDR OF SIZE
	DCA	TEMP2
	TAD I	TEMP2
	ISZ	TEMP2
	ISZ	TEMP2
	SNA CLA
	JMP	OUFSTA+1	/IT HAS A VARIABLE DIMENSION
	TAD I	TEMP2		/GET MAGIC NUMBER LIT DISP
	DCA	TEMP2
	CDF
	JMS I	QOPCDE		/	%FSUB	#LIT+XXXX
	FSUB
	TAD	QLITRL
	JMS I	QOUTSYM
	TAD	TEMP2
	JMS I	QONUMBR
	JMS I	QCRLF
	CDF	10
OUFSTA,	DCA I	ARG		/IT ISN'T VARIABLY DIMENSIONED
	CDF
	JMS I	QOPCDE		/	%FSTA	ARGN
	FSTA
	CDF	10
	CMA
	TAD	TEMP
	JMS I	QOUTNAM
	JMS I	QCRLF
	ISZ	NARGS
	SKP
	JMP I	(ENDPLG		/END OF PROLOG
	TAD	TYPE		/DID WE LEAVE D MODE
	SNA CLA
	JMP	GALOOP		/NO
	JMS I	QGENCOD		/YES, OUTPUT AN %SD
	SD-1
	JMP	GALOOP
FINIST,	CDF	10
	TAD	FUNCTN		/WAS THIS A FUNCTION ?
	SPA SNA CLA
	JMP	.+4		/NO, SKIP THIS
	TAD I	PROGNM		/YES, TURN OFF EXT BIT
	AND	(6777		/ALLOWING STORING IN FUN NAME
	DCA I	PROGNM
	TAD	(2200		/CHECK /N /Q
	AND I	(7644
	CDF
	SNA CLA
NODBUG,	DCA I	(DEBUG		/IF NOT SET, PUT ISN'S
	CDF	10		/INTO CODE
	TAD I	(7644		/IS /Q SET ?
	CDF
	AND	(0200
	SZA CLA
	ISZ I	(OPTMYZ		/MAKE A CLA IAC FROM A CLA
GFNAME,	CDF	10
	TAD I	FNAME		/MOVE FILE NAME
	CDF
	DCA I	NAMEF		/INTO PAGE
	ISZ	FNAME
	ISZ	NAMEF
	ISZ	NFCNT
	JMP	GFNAME
	JMP I	(RDOVLY		/GO WHERE ?
				/CALIFORNIA OF COURSE!!!!
FNAME,	7601
NAMEF,	F1LNAM
NFCNT,	-4

ONUM,	0
	ISZ	LITNUM		/BUMP LITERAL COUNTER
	DCA	ARG
	JMS I	QOTAB
	TAD	ARG
	JMS I	QONUMBR
	JMS I	QCRLF
	JMP I	ONUM
	PAGE
/ ENTRY AND EXIT CODE

TSTABT,	TAD I	TEMP		/VALUE TRANSMISSION ?
	AND	Q20
	SZA CLA
	JMP I	(OUFSTA		/NO
	CDF
	JMS I	(INS2		/	%FSTA	#BASE+3
	FSTA;XBASP3
	JMS I	(STFORE		/ENTER CORRECT MODE
	JMS I	(INS2		/	%FLDA%	#BASE+3
	FLDAI;XBASP3
	ISZ	TYPE		/SET SWITCH
	JMP I	(OUFSTA-1
ENDPLG,	JMS I	QGENCOD		/%SF
	SF-1
	TAD	ARGLST		/ANY VARIABLY
				/DIMENSIONED ARRAYS ?
	SNA
	JMP I	(FINIST		/NO ARGS AT ALL
	DCA	X10
	CDF	10
	TAD I	ARGLST		/NUMBER OF ARGS
	CIA
	DCA	NSARGS
VDIMLP,	CDF	10
	TAD I	X10		/GET NEXT ARG
	SNA
	JMP	NDVDIM		/NOT A VARIABLY
				/DIMENSIONED ARRAY
	DCA	VDTEMP
	TAD	VDTEMP		/GET ADDR OF DIMENSION INFO
	JMS I	QGETSS
	DCA	VDTMP2
	TAD I	VDTMP2		/NUMBER OF DIMENSIONS
	CIA
	DCA	NARGS
	ISZ	VDTMP2		/MOVE TO MAGIC NUMBER LITERAL
	ISZ	VDTMP2
	ISZ	VDTMP2
	TAD I	VDTMP2		/GET IT
	CDF
	DCA	MNL		/SAVE MAGIC NUMBER LITERAL
	TAD	(FLDA		/JUST LOAD FIRST DIM
	DCA	MNOPC
	TAD	NARGS		/GET ADDRESS
	CIA			/OF THE LAST
	TAD	VDTMP2		/DIMENSION
	DCA	VDTMP2		/FOR THE SIZE GETTER
	JMP	CMPMN3		/SKIP MULTIPLY FIRST TIME
CMPMN1,	TAD	(FMUL		/NEXT TIME USE A MULTIPLY
	DCA	MNOPC
	JMS I	QOPCOD		/NEXT SUBSCRIPT (ALWAYS (1.0)
	FADD
	JMS I	QOADDR		/NOW ADDRESS
	(ONEI
CMPMN3,	ISZ	NARGS		/ANY MORE SS ?
	JMP	CMPMN2		/YES
	ISZ	VDTEMP		/GET TO TYPE
	CDF	10
	TAD I	VDTEMP
	CDF
	JMS I	QSKPIRL		/SKIP ON I R L
	TAD	Q6M3		/YES
	TAD	(THREE
	JMS	LDAMUL		/3.02
	JMS I	(INS2		/ALN 0
	ALN;D0
	JMS I	QOPCDE
	FSTA
	TAD	QLITRL		/SAVE IN THE MAGIC
				/NUMBER LITERAL
	JMS I	QOUTSYM
	CLA CMA
	TAD	MNL
	JMS I	QONUMBR
	JMS I	QCRLF
	JMS I	(INS2		/FNEG
	FNEG;0
	JMS I	(INS2		/ENTER D MODE
	STARTD;0
	JMS I	QOPCDE
	FADDM			/NOW MODIFY THE POINTER
	CMA
	TAD	VDTEMP
	CDF	10
	JMS I	QOUTNAM
	JMS I	QCRLF
	JMS I	(INS2		/RETURN TO F MODE
	STARTF;0
NDVDIM,	ISZ	NSARGS		/ANY MORE ARGS TO CHECK?
	JMP	VDIMLP		/YES
	CDF
	JMP I	(FINIST
CMPMN2,	CLA CMA			/BACK UP THE POINTER
	TAD	VDTMP2		/BY ONE
	DCA	VDTMP2
	CDF	10
	TAD I	VDTMP2		/GET IT
	CDF
	JMS	LDAMUL		/3.02
	JMP	CMPMN1		/LOOP
VDTEMP,	0
VDTMP2,	0
NSARGS,	0
MNL,	0
DP12,	TEXT	'.+14'
LDAMUL,	0			/3.02
	DCA	MNADR
	JMS I	QOPCOD
MNOPC,	0
	JMS I	QOADDR
	MNADR
	JMP I	LDAMUL
MNADR,	0
	PAGE
/ RANDOM PROLOG STUFF

ARRAYS,	0			/OUTPUT ARRAYS
	TAD I	TYPE
	AND	(6220		/IS IT AN ARRAY
	SNA
	JMP I	ARRAYS
	AND	(4220		/NOT COMMON, EQUIV OR ARG
	SZA CLA
	JMP I	ARRAYS
	JMS I	(UNHOOK		/REMOVE FROM BUCKET
	TAD	ENTRY		/OUTPUT VARIABLE
	JMS I	(OUTVAR
	JMP	TFUDGE-1
FILL,	0			/FILL SUB NAME WITH BLANKS
	CLL CML RTL
	TAD	PROGNM		/PROGNM+2
	CIA			/-PROGNM-2
	TAD I	XNAMP		/1,2,3
	TAD	QM4		/-3,-2,-1
	DCA	TEMP
	JMP	.+5
	TAD	(240		/TWO BLANKS FOR EACH WORD
	JMS I	QOCHAR
	TAD	(240
	JMS I	QOCHAR
	ISZ	TEMP		/MORE ?
	JMP	.-5		/YES
	JMP I	FILL
XNAMP,	NAMPTR
NPRNT,	0
	JMS I	QTTYP2C
	JMS I	QTTYP2C
	TAD I	X10		/NOW NUMBER
	JMS I	QTTYP2C
	TAD I	X10
	JMS I	QTTYP2C
	TAD I	X10
	JMS I	QTTYP2C
	JMS I	QTTCRLF
	JMP I	NPRNT
/ROUTINE TO FIX UP NEGATIVE EQUIVALENCE OFFSETS

NEGSLV,	0
	TAD I	TYPE
	AND	Q200
	SNA CLA		/IS VARIABLE A SLAVE?
	JMP I	NEGSLV	/NO
	TAD	TYPE
	DCA	X10
	TAD I	X10	/GET POINTER TO EQUIV BLOCK
	DCA	X10
	CLA IAC
	TAD I	X10	/GET POINTER TO MASTER
	DCA	OLDM	/TYPE WORD
	TAD I	X10	/OFFSET FROM MASTER
	CMA STL
	TAD I	X10	/SUBTRACT FROM SLAVE OFFSET
	DCA	SFUDGE	/SAVE IN CASE WE NEED IT
	TAD I	OLDM	/IF MASTER IS IN COMMON FORGET THE NEXT TEST:
	SZL SPA CLA	/IF MASTER OFFSET < SLAVE OFFSET THEN
	JMP I	NEGSLV	/SLAVE WILL ORIGIN BEFORE MASTER -
	TAD I	TYPE	/THEREFORE THE SLAVE MUST BECOME THE MASTER
	AND	(7577	/UNSLAVE THE SLAVE
	DCA I	TYPE
	ISZ	TYPE
	TAD I	TYPE
	DCA	TYPE1	/TYPE1 POINTS TO EQUIV BLOCK
	CLA IAC
	TAD	TYPE1
	DCA	X10	/USE AUTO-XR TO CLEAR OFFSETS
	TAD	ENTRY
	DCA	NEWM
	TAD I	OLDM	/GET OLD MASTER'S TYPE WD
	TAD	Q200
	DCA I	OLDM	/MAKE IT A SLAVE
	ISZ	OLDM
	TAD I	TYPE1	/GET POINTER TO SLAVE DIMENSION BLOCK
	DCA I	TYPE	/PUT IT IN SYMTAB AS BEFITTING A NEW MASTER
	TAD I	OLDM	/GET OLD MASTERS DIM PTR
	DCA I	TYPE1	/PUT IT IN EQUIV BLOCK AS BEFITTING A NEW SLAVE
	TAD	TYPE1	/NOW ASSOCIATE THE EQUIV BLOCK
	DCA I	OLDM	/WITH THE NEW SLAVE
	DCA I	X10	/AND MAKE BOTH OFFSETS 0
	DCA I	X10	/("FIXSLV" WILL ADJUST IT - NOTE THE "MASTER"
	CDF 0		/WD OF THE BLOCK STILL POINTS TO THE OLD MASTER)
	JMS I	(TYPRTN	/** RECURSIVE CALL ** - ACTUALLY WE DON'T CARE
	FIXSLV		/SINCE WE AREN'T RETURNING ANYWAY
	JMP I	(FIXELP	/TRY AGAIN FROM SCRATCH
/ROUTINE TO ADJUST ALL SLAVES OF THE OLD MASTER
/TO BE SLAVES OF THE NEW MASTER

FIXSLV,	0		/THROUGHOUT
	TAD I	TYPE
	AND	Q200
	SNA CLA		/IS IT A SLAVE?
	JMP I	FIXSLV	/NO
	ISZ	TYPE
	CLA IAC
	TAD I	TYPE
	DCA	TYPE	/TYPE NOW POINTS TO THE EQUIV BLOCK
	CLA IAC
	TAD I	TYPE	/GET PTR TO THIS SLAVES MASTER (+1)
	CMA
	TAD	OLDM	/COMPARE MASTERS
	SZA CLA
	JMP I	FIXSLV	/NOT UNDER SAME MASTER - LEAVE
	TAD	NEWM
	DCA I	TYPE	/"MEET THE NEW BOSS.....
	ISZ	TYPE	/ SAME AS THE OLD BOSS...."
	TAD I	TYPE	/		(THE WHO)

	TAD	SFUDGE	/ADD IN THE DIFFERENCE BETWEEN OLD AND NEW
	IAC		/MASTERS TO THE MASTER OFFSET
	DCA I	TYPE
	JMP I	FIXSLV	/THE SLAVE IS NOW --  A SLAVE!

OLDM,	0
NEWM,	0
SFUDGE,	0
	PAGE
/ ENTRY AND EXIT CODE

PLSUB2,	0			/DUMB SUBR FOR PROLOG
	CDF
	JMS	INS2		/	%ORG	#BASE+30
	ORG;XBAP30
	JMS	INS2		/	%FNOP
	FNOP;0
	JMS	INS2		/	%JA	#RET
	JA;XRET
	JMS	INS2		/	FNOP
	FNOP;0
	JMS	INS		/#GOBAK,ORG	.+2
	XGOBAK;DBLZRO;0		/**TO INSURE IT'S 0
	TAD	DPUSED		/WAS DOUBLE PRECISSION USED ?
	SNA CLA
	JMP	NDPUSD		/NO, NO NEED FOR TEMP
	JMS	INS
	XDPTMP;ORG;DP12		/#DPT,	ORG	.+12
	JMS	INS2
	DPCHK;0
NDPUSD,	TAD	FUNCTN		/FUNCTION OR SUBR ?
	SNA
	JMP I	PLSUB2		/ITS #MAIN, NO #VAL OR #ARGS
	SPA CLA
	JMP	.+5		/ITS A SUBROUTINE, NO #VAL
	JMS	INS		/#VAL,	%ORG	.+6
	XVAL;ORG;DP6
	JMS	INS		/#ARGS,	%ORG	.+3
	XARGS;ORG;DP3
	JMP I	PLSUB2
INS2,	0			/	%OPCOD	ADDR
	TAD	INS2		/COMMONIZE RETURNS
	DCA	INS
	JMP	INS3
INS,	0			/TAG,	%OPCOD	ADDR
	TAD I	INS		/GET TAG FIELD
	ISZ	INS
	JMS I	QOUTSYM		/OUTPUT IT
	TAD	COMMA
	JMS I	QOCHAR
INS3,	JMS I	QOTAB
	TAD I	INS		/GET OPCODE
	ISZ	INS
	JMS I	QOUTSYM
	TAD I	INS		/GET ADDR
	SNA CLA
	JMP	.+4		/NO ADDRESS
	JMS I	QOTAB
	TAD I	INS
	JMS I	QOUTSYM
	ISZ	INS
	JMS I	QCRLF
	JMP I	INS
SECT,	TEXT	'SECT'
XRET,	TEXT	'#RET'
XXR,	TEXT	'#XR'
XGOBAK,	TEXT	'#GOBAK'
XST,	TEXT	'#ST'
XGOBC0,	TEXT	'#GOBAK,0'
XBAP30,	TEXT	'#BASE+30'
FNOP,	TEXT	'FNOP'
SETX,	TEXT	'SETX'
SETB,	TEXT	'SETB'
TEXTX,	TEXT	'TEXT'
XBASC1,	TEXT	'#BASE,1'
DP3,	TEXT	'.+3'
DP6,	TEXT	'.+6'
ZC1,	TEXT	'0,1'
FLDAI,	TEXT	'FLDA%'
FSTAI,	TEXT	'FSTA%'
XLBLE,	TEXT	'#LBL=.'
C1,	TEXT	',1'
XLBL,	TEXT	'#LBL'		/STACK-5 CAN'T BE 0
DBLZRO,	TEXT	'0;0'
	PAGE
/ SYMBOL TABLE PROCESSING ROUTINES

IMPLCT,	0			/DO IMPLICIT TYPING
	TAD I	TYPE
	AND	O100		/WAS IT EXPLICITLY TYPED
	SZA CLA
	JMP I	IMPLCT		/YES
	TAD	BUCKET		/IS IT INTEGER ?
	TAD	M317
	CLL
	TAD	M006
	SNL CLA
	ISZ I	TYPE		/TYPE IT REAL
	ISZ I	TYPE		/TYP IT INTEGER
	JMP I	IMPLCT
O100,
DFLIT,	100			/GENERATE FACTORS FOR CALLS
	CLL CML RTR		/DIMENSIONED ?
	AND I	TYPE
	SNA CLA
	JMP I	DFLIT		/NO
	TAD I	TYPE
	DCA	TEMP	/SET PROPER WDS/ENTRY FOR VMC
	TAD	ENTRY		/GET ADDR OF MAGIC NUMBER
	JMS I	QGETSS
	TAD	(2
	DCA	TYPE
	TAD I	ENTRY		/SAVE LINK
	DCA	DFTEMP
	TAD	BUCKET		/FIX NAME
	DCA I	ENTRY
	TAD I	TYPE		/GET MAGIC NUMBER
	DCA	TEMP2
	ISZ	TYPE
	CDF
	JMS I	(ONUM		/OUTPUT A ZERO WORD
	JMS I	QOPCDE
	JA
	TAD	ENTRY		/OUTPUT VAR MINUS CONST
	JMS I	(VMC
	JMS I	QCRLF		/END LITERAL
	CDF	10
	TAD	LITNUM		/SAVE NUMBER IN DIM INFO
	DCA I	TYPE
	ISZ	LITNUM		/THEN BY 2 MORE
	ISZ	LITNUM
	TAD	DFTEMP		/RESTORE ENTRY
	DCA I	ENTRY
	JMP I	DFLIT
M006,
DFTEMP,
EXTRNL,	6			/DO EXTERNALS
	TAD I	TYPE
	AND	O1000		/IS IT EXT ?
	SNA CLA
	JMP I	EXTRNL
	JMS I	(UNHOOK		/REMOVE THIS SYMBOL
	TAD	PROGNM		/IS IT THE PROG NAME ?
	CIA
	TAD	ENTRY
	SZA CLA
	JMP	.+5		/NO, OUTPUT EXTERN
	TAD	FUNCTN		/IS IT A MAIN PROG ?
	SNA CLA
	JMP	TFUDGE-1	/YES, NO SECT
	TAD	(SECT-EXTERN	/NOT MAIN, OUTPUT SECT
	TAD	XTRN
	DCA	M317
	CDF
	JMS I	QOPCDE
M317,	-317
	TAD	ENTRY		/NOW VAR NAME
	CDF	10
	JMS I	QOUTNAM
	JMS I	QCRLF
	JMP	TFUDGE-1
O1000,
EQUIVS,	1000			/OUTPUT EQUIVALENCES
	TAD I	TYPE
	AND	Q200		/IS THIS A SLAVE ?
	SNA CLA
	JMP I	EQUIVS		/NO
	JMS I	(UNHOOK		/UNHOOK THE ENTRY
	TAD I	TYPE		/SAVE THE TYPE WORD
	DCA	TYPE1
	ISZ	TYPE		/POINT TO EQUIVALENCE BLOCK
	TAD I	TYPE
	DCA	X10
	CDF
	JMS I	QOPCDE		/OUTPUT ORG
	ORG
	CDF	10
	TAD I	X10		/MASTER NAME
	DCA	X11		/SAVE IT
	TAD	X11
	JMS I	QOUTNAM		/OUTPUT IT
	TAD	PLUS		/+
	JMS I	QOCHAR
	CDF	10
	TAD I	X11		/MASTER SS
	JMS	SUBRX
	TAD	Q255		/MINUS
	JMS I	QOCHAR
	CDF	10
	TAD	TYPE1		/SLAVE SS
	JMS	SUBRX
	JMS I	QCRLF		/EOL
	CDF	10
	TAD	ENTRY		/NOW OUTPUT SLAVE
	JMS I	(OUTVAR
	JMP	TFUDGE-1
XTRN,
SUBRX,	EXTERN
	JMS I	QSKPIRL		/SIZE OF THING
	TAD	Q3
	TAD	Q3		/TIMES 3 OR 6
	DCA	MQ
	TAD I	X10
	CDF
	JMS I	QMUL12		/MAKE THE PRODUCT
	JMS I	QNUMBRO		/OUT WITH IT
	JMP I	SUBRX
DPCHK,	TEXT	'DPCHK'
FADDM,	TEXT	'FADDM'
	PAGE
/ SYMBOL TABLE PROCESSING ROUTINES

BASE,	TEXT	'BASE'
OUTVAR,	0			/ALLOCATE STORAGE FOR A VARIABLE
	DCA	VARADR
	RDF			/GET FIELD OF VAR
	TAD	X6201
	DCA	OVFLD1
	TAD	OVFLD1
	DCA	OVFLD2
	TAD	VARADR		/OUTPUT		NAME,
	JMS I	QOUTNAM
	TAD	COMMA
	JMS I	QOCHAR
	JMS I	QOPCDE		/OUTPUT ORG
	ORG
	ISZ	VARADR		/POINT TO TYPE WROD
OVFLD1,	0
	TAD I	VARADR		/GET TYPE
X6201,	CDF
	JMS I	QSKPIRL
	TAD	Q3		/PER ENTRY
	TAD	Q3		/INTEGER, REAL, AND
				/LOGICAL  3WORDS
	DCA	MQ
	DCA	AC
OVFLD2,	0
	CLL CML RTR		/CHECK DIM BIT
	AND I	VARADR
	SNA CLA
	JMP	PLSDOT		/NOT DIMENSIONED
	TAD I	VARADR		/LOOK AT TYPE
	ISZ	VARADR		/MOVE TO EQ DIM POINTER
	AND	Q200		/EQUIVALENCED ?
	SNA CLA
	JMP	.+3		/NO
	TAD I	VARADR		/YES, SKIP EQUIV INFO
	DCA	VARADR
	TAD I	VARADR		/ADDRESS OF DIM INFO
	IAC
	DCA	VARADR		/ADDRESS OF SIZE
	TAD I	VARADR		/GET TOTAL SIZE
	CDF
	JMS I	QMUL12
PLSDOT,	CDF
	TAD	Q256
	JMS I	QOCHAR
	TAD	PLUS
	JMS I	QOCHAR
	JMS I	QNUMBRO
	JMS I	QCRLF
	JMP I	OUTVAR
SCALAR,	0			/OUTPUT SCALARS
	TAD I	TYPE		/IS IT A SCALAR ?
	AND	(7630		/COM, DIM, EXT, ASF,
				/EQV, ARG, COMMONNAME
	SZA CLA
	JMP I	SCALAR		/NO
	JMS I	(UNHOOK		/DELETE THIS FROM THE LIST
	TAD	ENTRY		/OUTPUT THIS VARIABLE
	JMS	OUTVAR
	JMP	TFUDGE-1
VARADR,
DOLIST,	0			/PROCESS A LITERAL LIST
	TAD I	DOLIST		/GET LIST START
	DCA	ENTRY
	ISZ	DOLIST
	TAD I	DOLIST
	DCA	TYPE		/GET TYPE BITS
	ISZ	DOLIST
	TAD I	DOLIST
	ISZ	DOLIST
	DCA	LSIZE		/GET LITERAL SIZE
	CDF	10
DLLOOP,	TAD I	ENTRY		/GET NEXT ENTRY
	SNA
	JMP	DLRETN		/NO MORE
	DCA	ENTRY
	TAD	ENTRY
	DCA	X10		/ADDRESS OF TYPE WORD
	TAD	TYPE		/PUT IN TYPE
	DCA I	X10
	TAD	X10		/SAVE THIS ADDR
	DCA	X11
	TAD	LSIZE		/SIZE OF LITERAL
	DCA	TEMP
LITLUP,	CDF
	JMS I	QOTAB
	CDF	10
	TAD I	X10
	CDF
	JMS I	QONUMBR
	JMS I	QCRLF
	ISZ	TEMP
	JMP	LITLUP
	CDF	10
	TAD	LITNUM		/SAVE LITERAL NUMBER
	DCA I	X11
	TAD	LSIZE		/INCREMENT LITERAL NUMBER
	CIA
	TAD	LITNUM
	DCA	LITNUM
	JMP	DLLOOP
DLRETN,	CDF
	JMP I	DOLIST
TEMPS,	243;2000;TMPSIZ;2415;2000
TMPSIZ,	1;TMPBLK+1
LSIZE,
COMVAR,	0			/REMOVE COMMON VARS FROM ST
	TAD I	TYPE
	AND	(4400		/ALSO ASF NAMES
	SNA CLA
	JMP I	COMVAR
	JMS I	(UNHOOK
	JMP	TFUDGE-1
LITRL2,	TEXT	'#LIT'
COMMON,	TEXT	'COMMON'
	PAGE
/ SYMBOL TABLE PROCESSING ROUTINES

TYPRTN,	0			/PROCESS ENTIRE SYMBOL TABLE
	TAD I	TYPRTN		/GET ROUTINE ADDRESS
	DCA	ROUTNE
	ISZ	TYPRTN
	TAD	O301		/START WITH 'A'
	DCA	BUCKET
	TAD	M32		/BUCKET COUNT
	DCA	BCNT
TYPLP2,	TAD	BUCKET		/GET START OF NEXT LIST
	TAD	ALM301
TYPLUP,	DCA	OENTRY		/SAVE OLD ENTRY ADDRESS
	CDF	10
TFUDGE,	TAD I	OENTRY		/GET ADDR OF NEXT ENTRY
	SNA
	JMP	EOL		/0 MEANS END OF LIST
	DCA	ENTRY
	IAC
	TAD	ENTRY		/ADDR OF TYPE WORD
	DCA	TYPE
	JMS I	ROUTNE		/CALL ROUTINE
	TAD I	OENTRY		/CONTINUE DOWN THE LIST
	JMP	TYPLUP
EOL,	ISZ	BUCKET		/DO NEXT LETTER
	ISZ	BCNT
	JMP	TYPLP2
	CDF
	JMP I	TYPRTN		/END OF PASS
	BCNT=ARG1
COMNAM,	0			/OUTPUT A COMMON BLOCK
	TAD I	TYPE		/IS THIS A COMMON BLOCK NAME
	TAD	M111
	SZA CLA
	JMP I	COMNAM		/NO
	CDF
	JMS I	QOPCDE
	COMMON
	CDF	10
	JMS I	(UNHOOK		/REMOVE THE COMMON
				/BLOCK FROM S.T.
	TAD	ENTRY
	JMS I	QOUTNAM		/OUTPUT NAME
	JMS I	QCRLF
	ISZ	TYPE		/GET TO COMMON STUFF POINTER
CNLOOP,	CDF	10
	TAD I	TYPE		/GET ADDR OF NEXT HUNK
				/OF COMMON
	SNA
	JMP	TFUDGE		/END OF IT
	DCA	TYPE
	TAD	TYPE		/GET A WORKING POINTER
	DCA	X10
	TAD I	X10		/GET COUNT
	SNA
	JMP	CNLOOP		/NONE IN THIS HUNK
	CIA
	DCA	TEMP2
	TAD I	X10		/GET VARIABLE ADDRESS
	JMS I	(OUTVAR		/OUTPUT IT
	CDF	10
	ISZ	TEMP2
	JMP	.-4		/DO NEXT ONE FROM THIS HUNK
	JMP	CNLOOP		/DO NEXT HUNK
O301,	301
M32,	-32
ALM301,	ALIST-301
M111,	-111
ROUTNE,
ADFLIT,	0			/OUTPUT ARG DF LITS
	TAD	ARGLST		/ANY ARGS
	SNA
	JMP I	ADFLIT
	DCA	X10
	CDF	10
	TAD I	ARGLST		/NUMBER OF ARGS
	CIA
	DCA	NARGS
ADFLUP,	CDF	10
	TAD I	X10		/GET ARG ADDR
	IAC
	DCA	TEMP		/TYPE WORD ADDR
	TAD I	TEMP		/GET TYPE INFO
	DCA	TEMP2
	CLL CML RTR
	AND I	TEMP		/DIMENSIONED ?
	SNA CLA
	JMP	NDADFL		/NO
	ISZ	TEMP		/ADDR OF DIM INFO
	CLL CML RTL
	TAD I	TEMP		/ADDR OF MAGIC NUMBER
	DCA	TEMP
	TAD I	TEMP		/MAGIC NUMBER
	DCA	MQ		/PREPARE TO MULTIPLY
	ISZ	TEMP		/ADDR OF LITERAL GOES HERE
	TAD	LITNUM		/STICK IN THE ADDRESS
	IAC
	DCA I	TEMP
	CDF
	JMS I	(ONUM		/OUTPUT A ZERO
	TAD	TEMP2		/LOOK AT TYPE
	JMS I	QSKPIRL		/SKIP ON I R L
	TAD	(3		/DOUBLE OR COMPLEX
	TAD	(3
	JMS I	QMUL12
	TAD	AC		/OUTPUT 2 WORD LITERAL
	JMS I	(ONUM
	TAD	MQ
	JMS I	(ONUM
NDADFL,	ISZ	NARGS
	JMP	ADFLUP
	JMP I	ADFLIT
RDOVLY,	JMS I	(7607		/READ IN OVERLAY
	NPOVLY
	OVRLAY
PASS2O,	0
	JMP I	(INERR
	TAD I	(VOVER		/CHECK VERSION OF OVERLAY
	TAD	VERS
	SZA CLA
	JMP I	(VERROR		/ERROR, MIXED VERSIONS
	JMP I	(EOSTMT		/START PASS2 PROPER
	PAGE
	FIELD	1
	*5000
	0			/THIS IS THE START OF
				/THE ERROR MESSAGE LIST
				/WHICH WORKS BACKWARDS
/OS/8 F4 COMPILER CODE SKELETONS

	MAC=-6
	NEGSGN=-5
	FLDAA2=-4
	FLDAA1=-3
	ENTERE=-2
	ENTERF=-1
CGTCOD,	ATX;DD1;STARTD;0;FLDA;DP2C1;STARTF;0
AGTCOD,	JAC;0;0
ASNCOD,	ENTERF;FLDA;DP3C0;JA;DP4;0
ERCODE,	EXTERN;XUE;TRAP3;XUE;0
A0FN,	EXTERN;XFIX;JSA;XFIX;0
A0SD,	ALN;D0
SD,	STARTD;0;0
SE,	STARTE;0;0
SF,	STARTF;0;0
MPTR0,	ENTERF;FLDAA1;FSTA;XBASE;0
MPTR3,	ENTERF;FLDAA2;FSTA;XBASP3;0
JADP2,	JA;DOT;0
DOFIN0,	ENTERF;FLDAA1;FADD;-2
ASTOR,	FSTA;-1;0
DOFIN1,	ENTERF;FLDAA1;FADD;-2;MAC+A0FN;FSTA;-1;0
LDASTD,	FLDAA1;STARTD;0;0
	/CHALK UP ONE FOR PAL8
ATX1,	ATX;DD1;0
LXM1C2,	LDX;M1C2;STARTD;0;0
FVAL,	FVI-1;FVI-1;FVC-1;FVD-1;FVI-1
FVI,	FLDA;XVAL;0
FVC,	STARTE;0;FLDA;XVAL;MAC+PCAC;0
FVD,	STARTE;0;FLDA;XVAL;0
RTNCOD,	RTNX+MAC;JA;XRTN;0
PAZCOD,	ENTERF;EXTERN;XPAUSE;JSR;XPAUSE;0
STPCOD,	RTNX+MAC;EXTERN;XEXIT;JSR;XEXIT;0
GIRL1,	ENTERF;FLDAA1;ENTERE;0
GIRL2,	ENTERF;FLDAA2;ENTERE;0
SEGCAC,
GCAC,	ENTERE;EXTERN;CAC;FLDA;CAC;0
PCAC,	EXTERN;CAC;FSTA;CAC;0
GC1C2,	ENTERE;FLDAA1;EXTERN;CAC;FSTA;CAC;FLDAA2;0
GC1,	ENTERE;FLDAA1;0
GC2,	ENTERE;FLDAA2;0
JSACEQ,	EXTERN;CEQ;JSA;CEQ;NEGSGN;0
JSACNG,	EXTERN;CNEG;JSA;CNEG;0
JSACAD,	EXTERN;CADD;JSA;CADD;0
JSACSB,	EXTERN;CSUB;JSA;CSUB;0
JSACML,	EXTERN;CMUL;JSA;CMUL;0
JSACDV,	EXTERN;CDIV;JSA;CDIV;0
/ ADD, SUBTRACT, MULTIPLY, AND DIVIDE SKELETONS
ADDTBL,	AS-1;AS+2;AS+4
	AX-1;AX+2;AX+5
	AS-1;AD-1;AS+4
	ASC-1;ASC+2;ASC+3
	ASD-1;ASD+7;ASD+10
	ACS-1;ACS+4;ACS+6
	ADS-1;ADS+3;ADS+7
	0
	FNEG;0
AS,	FADD;-1;0
	ENTERF;FLDAA1
	FADD;-2;0
	JSACNG+MAC
AX,	GC1+MAC;JSACAD+MAC;0
	GC1C2+MAC;JSACAD+MAC;0
	GC2+MAC;JSACAD+MAC;0
AD,	ENTERE;FLDAA1;FADD;-2;0
	JSACNG+MAC
ASC,	GIRL1+MAC;JSACAD+MAC;0
	GIRL1+MAC
	ENTERE;PCAC+MAC;GC2+MAC;JSACAD+MAC;0
	FNEG;0
ASD,	FSTA;XDPTMP;ENTERF;FLDAA1;ENTERE;FADD;XDPTMP;0
	GIRL1+MAC
	ENTERE;FADD;-2;0
	JSACNG+MAC
ACS,	ENTERE;PCAC+MAC;GC1+MAC;JSACAD+MAC;0
	GC1+MAC;PCAC+MAC
	GIRL2+MAC;JSACAD+MAC;0
	FNEG;0
ADS,	ENTERE;FADD;-1;0
	GIRL2+MAC;FADD;-1;0
	FSTA;XDPTMP;GIRL2+MAC;FADD;XDPTMP;0
SUBTBL,	AS-3;SS-1;SS+1
	AX-2;SX-1;SX+2
	AS-3;SDBL-1;SS+1
	ASC-2;SSX-1;SSX
	ASD-3;SSD-1;SSD
	ACS-2;SCS-1;SCS+1
	ADS-3;SDS-1;SDS5-1
	0
SS,	ENTERF;FLDAA1
	FSUB;-2;0
SX,	GC1C2+MAC;JSACSB+MAC;0
	GC2+MAC;JSACSB+MAC;0
SDBL,	ENTERE;FLDAA1;FSUB;-2;0
SSX,	GIRL1+MAC
	ENTERE;PCAC+MAC;GC2+MAC;JSACSB+MAC;0
SSD,	GIRL1+MAC
	ENTERE;FSUB;-2;0
SCS,	GC1+MAC;PCAC+MAC
	GIRL2+MAC;JSACSB+MAC;0
SDS,	GIRL2+MAC;FNEG;0;FADD;-1;0
SDS5,	FSTA;XDPTMP;GIRL2+MAC;FNEG;0;FADD;XDPTMP;0
MULTBL,	M1-1;M1+3-1;M1+5-1
	M4-1;M4+3-1;M4+6-1
	M1-1;M7-1;M7+2-1
	M8-1;M8+3-1;M8+4-1
	M11-1;M11+6-1;M11+7-1
	M14-1;M14+5-1;M14+7-1
	M18+1-1;M18-1;M18+5-1
	0
M1,	FMUL;-1;0
	ENTERF;FLDAA1
	FMUL;-2;0
M4,	GC1+MAC;JSACML+MAC;0
	GC1C2+MAC;JSACML+MAC;0
	GC2+MAC;JSACML+MAC;0
M7,	ENTERE;FLDAA1;FMUL;-2;0
M8,	GIRL1+MAC;JSACML+MAC;0
	GIRL1+MAC
	ENTERE;PCAC+MAC;GC2+MAC;JSACML+MAC;0
M11,	FSTA;XDPTMP;GIRL1+MAC;FMUL;XDPTMP;0
	GIRL1+MAC
	ENTERE;FMUL;-2;0
M14,	ENTERE;PCAC+MAC;GC1+MAC;JSACML+MAC;0
	GC1+MAC;PCAC+MAC
	GIRL2+MAC;JSACML+MAC;0
M18,	GIRL2+MAC
	ENTERE;FMUL;-1;0
	FSTA;XDPTMP;GIRL2+MAC;FMUL;XDPTMP;0
DIVTBL,	1;D2-1;D2+2-1
	1;D5-1;D5+3-1
	1;D7-1;D7+2-1
	1;D9-1;D10-1
	1;D12-1;D13-1
	1;D14-1;D15-1
	1;D16-1;D17-1
	0
D2,	ENTERF;FLDAA1
	FDIV;-2;0
D5,	GC1C2+MAC;JSACDV+MAC;0
	GC2+MAC;JSACDV+MAC;0
D7,	ENTERE;FLDAA1;FDIV;-2;0
D9,	GIRL1+MAC
D10,	ENTERE;PCAC+MAC;GC2+MAC;JSACDV+MAC;0
D12,	GIRL1+MAC
D13,	ENTERE;FDIV;-2;0
D14,	GC1+MAC;PCAC+MAC
D15,	GIRL2+MAC;JSACDV+MAC;0
D16,	GIRL2+MAC;FSTA;XDPTMP;FLDAA1;FDIV;XDPTMP;0
D17,	FSTA;XDPP6;GIRL2+MAC;FSTA;XDPTMP;FLDA;XDPP6;FDIV;XDPTMP;0
/ RELATIONALS AND LOGICALS SKELETON TABLES
EQTABL,	EQ1-1;EQ2-1;EQ3-1
	EQ4-1;EQ5-1;EQ6-1
	EQ1-1;EQ7-1;EQ3-1
	EQ8-1;EQ9-1;EQ10-1
	EQ11-1;EQ12-1;EQ13-1
	EQ14-1;EQ15-1;EQ16-1
	EQ17-1;EQ18-1;EQ19-1
	EQ1-1;EQ2-1;EQ3-1
EQ1,	FSUB;-1;0
EQ2,	ENTERF;FLDAA1
EQ3,	FSUB;-2;0
EQ4,	GC1+MAC;JSACEQ+MAC;0
EQ5,	GC1C2+MAC;JSACEQ+MAC;0
EQ6,	GC2+MAC;JSACEQ+MAC;0
EQ7,	ENTERE;MAC+EQ2+1;0
EQ8,	GIRL1+MAC;JSACEQ+MAC;0
EQ9,	GIRL1+MAC
EQ10,	ENTERE;PCAC+MAC;GC2+MAC;JSACEQ+MAC;0
EQ11,	MAC+ASD-2;0
EQ12,	GIRL1+MAC
EQ13,	MAC+SSD+1;0
EQ15,	GIRL2+MAC
EQ14,	ENTERE;PCAC+MAC;GC1+MAC;JSACEQ+MAC;0
EQ16,	GIRL2+MAC;JSACEQ+MAC;0
EQ18,	GIRL2+MAC
EQ17,	MAC+ADS-2;0
EQ19,	MAC+SDS5;0
LETABL,	LE1-1;LE2-1;LE3-1
	0;0;0
	LE1-1;LE4-1;LE3-1
	0;0;0
	LE11-1;LE12-1;LE13-1
	0;0;0
	LE17-1;LE18-1;LE19-1
	0
LE1,	FSUB;-1;NEGSGN;0
LE2,	ENTERF;FLDAA1
LE3,	FSUB;-2;0
LE4,	ENTERE;MAC+LE2+1;0
LE11,	MAC+ASD-2;0
LE12,	GIRL1+MAC
LE13,	MAC+SSD+1;0
LE18,	GIRL2+MAC
LE17,	MAC+ADS-2;0
LE19,	MAC+SDS5;0
ANDTBL,	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	M1-1;M1+3-1;M1+5-1
ORTABL,	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	AS-1;AS+2;AS+4
EQVTBL,	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	0;0;0
	EQ1-1;EQ2-1;EQ3-1
/CONVERSION-FOR-STORE-OPERATOR SKELETONS
STRTBL,	SIIM-1;SIRM-1;SICM-1;SIDM-1;SIIM-1
	SIIA-1;SIRA-1;SICA-1;SIDA-1;SIIA-1
	SIIM-1;SIIM-1;SRCM-1;SRDM-1;SIIM-1
	SIIA-1;SIIA-1;SRCA-1;SRDA-1;SIIA-1
	SCIM-1;SCIM-1;SCCM-1;SCDM-1;SCIM-1
	SCIA-1;SCIA-1;SCCA-1;SCDA-1;SCIA-1
	SDIM-1;SDIM-1;SDCM-1;SDDM-1;SDIM-1
	SDIA-1;SDIA-1;SDCA-1;SDDA-1;SDIA-1
	SLIM-1;SLIM-1;SLCM-1;SLDM-1;SIIM-1
	SLIA-1;SLIA-1;SLCA-1;SLDA-1;SIIA-1
SIIM,	ENTERF;FLDAA2
SIIA,	0
SIRM,	ENTERF;FLDAA2
SIRA,	A0FN+MAC;0
SICM,	GC2+MAC;PCAC+MAC
SICA,	ENTERF;GCAC+1+MAC;A0FN+MAC;0
SRCM,	GC2+MAC;PCAC+MAC
SRCA,	ENTERF;GCAC+1+MAC;0
	SCCM=GC2
SCIM,	ENTERF;FLDAA2
SCIA,	ENTERE;0
	SCCA=GCAC
SLIM,	ENTERF;FLDAA2
SLIA,	JSA;LTRNE;0
SLCM,	GC2+MAC;ENTERF;SLIA+MAC;0
SLCA,	ENTERF;GCAC+1+MAC;SLIA+MAC;0
SIDM,	ENTERE;FLDAA2
SIDA,	ENTERF;SIRA+MAC;0
SRDM,	ENTERE;FLDAA2
SRDA,	ENTERF;0
SCDM,	ENTERE;FLDAA2
SCDA,	FSTA;TEMPN;ENTERF;FLDA;TEMPN;ENTERE;0
SDIM,	ENTERF;FLDAA2
SDIA,	ENTERE;0
SDCM,	ENTERE;FLDAA2;PCAC+MAC
SDCA,	ENTERF;GCAC+1+MAC;ENTERE;0
SDDM,	ENTERE;FLDAA2
SDDA,	0
SLDM,	ENTERE;FLDAA2
SLDA,	JSA;LTRNE;0
/ UNARY MINUS AND .NOT. SKELETONS
NEGTBL,	NIM-1;NIM-1;NCM-1;NDM-1;0
	NIA-1;NIA-1;NCA-1;NIA-1;0
NIM,	ENTERF;FLDAA1
NIA,	FNEG;0;0
NCM,	GC1+MAC;PCAC+MAC;JSACNG+MAC;0
	NCA=JSACNG
NDM,	ENTERE;NIM+1+MAC;0
NOTTBL,	0;0;0;0;NOTM-1
	0;0;0;0;NOTA-1
NOTM,	ENTERF;FLDAA1
NOTA,	0
/ ARITHMETIC IF SKELETONS
AIFTBL,	GI-1;GI-1;GC-1;GD-1;GI-1	/V3C
	GI+1;GI+1;GC+1;GD+1;GI+1	/V3C
GI,	ENTERF;FLDAA1;0
GC,	GC1+MAC;0
GD,	ENTERE;FLDAA1;0
/OPERATOR DISPATCH TABLE

XPUSH,	PUSH
	ADD
	SUB
	MUL
	DIV
	EXP
	NOT
	NEG
	GE
	GT
	LE
	LT
	DNA
	OR
	EQ
	NE
	XOR
	EQV
	PAUZE
	DPUSH
	BINRD1
	FMTRD1
	WCLOSE		/**
	DARD1
	BINWR1
	FMTWR1
	WCLOSE
	DAWR1
	DEFFIL
	ASFDEF
	ARGS
	EOSTMT
	ERROR
	RETURN
	REWIND
	STORE
XEND,	END
	DEFLBL
	DOFINI
	ARTHIF
XLOGIF,	LIFBGN
	DOBEGN
	ENDFIL
	STOP
	ASSIGN
	BAKSPC
	FORMAT
XGOTO,	GOTO
	CGOTO
	AGOTO
	IOLMNT
	DATELM
	DREPTC
	DATAST
	ENDELM
	PURGE
XLAST,	DOSTOR
/ EXPONENTIATION TABLE (NOT A STANDARD SKELETON TABLE)
EXPTBL,	1;1111;2;1122;3;1103;4;1104;0;0 /I**D=D
	2;1111;2;1122;3;1103;4;1104;0;0 /R**D=D
	3;0311;3;0322;3;0303;0;0;0;0
	4;0411;4;0422;0;0;4;0404;0;0
	0;0;0;0;0;0;0;0;0
/ TYPE MIXING TABLE
TYPMIX,	1;6;2;6;3;17;4;22;0;0
	2;6;2;6;3;17;4;22;0;0
	3;25;3;25;3;11;0;0;0;0
	4;30;4;30;0;0;4;14;0;0
	0;0;0;0;0;0;0;0;5;33
RTNX,	ENTERF;EXTERN;LTRNE;0
	$

