/ C O S   DIBOL				EDITED 10/9/73
/
/
/
/
/
/
/
/		C O S    D I B O L
/
/		/SR
/
/
/
/	COPYRIGHT 1972, 1973
/
/	DIGITAL EQUIPMENT CORPORATION
/
/	146 MAIN STREET
/
/	MAYNARD, MASSACHUSETTES	01754
/
/	SOL III
/
/THIS SOFTWARE IS FURNISHED TO PURCHASER UNDER A LICENSE FOR USE
/ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED (WITH INCLUSION
/OF DEC'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH SYSTEM, EXCEPT
/AS MAY OTHERWISE BE PROVIDED IN WRITING BY DEC.
/
/THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT
/NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
/EQUIPMENT CORPORATION.
/
/DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY
/OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
/

	/DIBOL COMPILER
	/OPCODES
	/MEMORY ADDRESS CLASS
	FIXMRI CALL=	4400
	FIXMRI EXIT=	5400
	FIXTAB	
	PUSHOP=	1000
	PUSH1S=	2000
	PUSH2S=	3000
	BRASUB=	4000
	BRANCH=	5000
	BRATRP=	6000
	/OPERATE CLASS (0XXX)
	/MULTIPLY=	1
	/ADD=	2
	IMAGOP=	3
	/SUBTRACT=	4
	UMINUS=	5
	/DIVIDE=	6
	CLEARA=	11	/CLEARA MUST =	 CLEARD -1 !
	CLEARD=	12
	BCMPTD=	13
	RTRNOP=	14
	STOPOP=	15
	INITOP=	16
	XMITOP=	17
	READOP=	20
	WRITOP=	21
	FINIOP=	22
	FORMOP=	23
	STOROP=	24
	STORAA=	24
	STORAD=	25
	STORDA=	26
	STORDD=	27
	HERETR=	33	/TRACE
	HERENT=	43	/DONT TRACE (MUST BE HERETR+10)
	HEREDC=	30	/HERE I IS
	SKPCND=	40	/SKIP ON CONDITION FALSE
	STADOP=	31	/ADD AND STORE
	STSBOP=	32	/SUBTRACT AND STORE
	CNVOCT=	7	/CNVERT OCTAL
	TRYOP=	34	/TRY LOGICAL UNIT #
	DISPOP=	35	/DISPLAY
	DISPUP=	36	/DISPLAY SPECIAL NUMERIC CODE
	ACPTOP=	37	/ACCEPT
	INCROP=	40
	CHNOP=	41
	ONERXX=	42

	READ=	0
	WRITE=	4000
	SRCBUF=	5000
	LEN0=	400	/512 WD BUFFERS
	LEN1=	400	/"
	OUTBUF=	6000
	MAGIC=	100
	LEN02=	2000	/2048 WD BUFFERS
	LEN12=	2000	/"
/LOADER CODES:
	KODE=	0		/PROGRAM CODE
	ACLEAR=	1	/ALPHA DATA CLEAR (OBSOLETE)
	DCLEAR=	2	/DECIMAL DATA CLEAR (MUST BE ACLEAR+1)
	SYMTAB=	3	/SYMBOL TABLE INDICATOR
	COMMAP=	4	/COMMA P
	PROCOD=	5	/PROC CODE
	RELOC=	6		/RELOCATION CODE
	DATAIN=	7	/DATA INITIALIZATION
	COMMAD=	10	/COMMA D
	DCLRCH=	11	/CLEARD IF NO CHAIN
	COMMAS=	12	/COMMA S
/1	ALPHA
/2	DECIMAL
/4	LABEL
/10	RECORD
/20	UNDEF?
/2000	FORWARD REFERENCE
/4000	CCP

	LPOCHR=	35
	TTOCHR=	31
	LENGTH=	44	/NEG OF MAX LENGTH
	OTOD=	74		/O TO D CONV
	KPUTC=	25
	KGETC=	24
	RDOIO=	26
	L7=	40
	L77=	20
	BSWPTR=	22
	L7400=	2
	M1=	45
	W2=	50
	W3=	51
	L17=	64
	L70=	65
	M4=	66
	L7600=	70
	KCDF0=	71
	LISTSW=	7776	/CHAR "N" MEANS NO LIST
	SYSHND=	77
	TOPFLD=	7775
	SBT=	6370
	KPTRST=	43
	U0=	54
	W1=	47
	W4=	52
	W5=	53
	W0=	46
	GPBUF=	41
	REALSYS=	7774
	LPWDTH=	7773
	DOSW=	6260
	SYSDAT=	45
	MOVE=	23
	UTBASE=	6200	/SW
	CTRLO=	73

	*3
NAME1,	0
NAME2,	0
NAME3,	0
RCNT,
EXTMP1,	0
CRCNT,
EXTMP2,	0
	*11
XT,	0
X0,	-1
X1,	0
X2,	0
X3,	0
X4,	0
GOPTR,	7600-1
	*100
STREF,	0
OPRAND,	0
SYMNUM,	0
BYTORG,	0		/DATA LOCATION COUNTER
SYMEND,	0		/END OF SYMBOL TABLE -1
LITNUM,	0		/DUMMY LITERAL NAME
NSYMS,	0		/NUMBER OF SYMBOLS
CHRPTR,	0
ENDKNT,
PDLCNT,	0
ELCNT,
LOCCTR,	0		/CODE LOCATION COUNTER
LOD,
TYPE,	0		/TYPE OF EXPRESSION
PFLAG,
TYPLFT,	0		/TYPE OF LEFT OF EQUAL SIGN
OLDBLK,	0		/ORIGIN OF LAST BLOCK
BLKOPT,	0		/OPTION C=0, X=1
OBSIZE,	0		/PTR TO SIZE ENTRY OF BLOCK
LITSIZ,	0		/SIZE OF LITERAL (IN BYTES)
LINDIF,
CELSIZ,
EFL,
RIGHT,	0		/SET TO 1 IF RIGHT SIDE OF =
PROCNM,	0
COPT,	0		/NONZERO MEANS ,C OPTION IN EFFECT
LSTSW,	0		/0 MEANS LISTING
SIZ,
LINENO,	0
ORI,
OLDLNO,	0
ERKNT,	0		/# OF ERRORS
SIZE,	0		/TOTAL SIZE FOR CORG
BUNIT,	0		/BINARY OUTPUT UNIT
HIORG,	2		/HIGH ORDER DATA ORIGIN
HILOC,	0		/HIGH ORDER LOC COUNTER
BOUTLN,	402		/BINARY OUTPUT LENGTH
HIBOUT,	0		/HIGH ORDER PART
ELSIZE,	0
RECSIZ,	0		/ CURRENT RECORD SIZE
BLNAME,	0		/0 IF UNNAMED BLOCK, 7000 IF NAMED BLOCK
SAVE,	0

/DUMB PSEUDO-PAGE ZERO LITERALS TO FAKE OUT PAL8
ZRESET,	RESET
ZCDUMP,	CDUMP
ZCODE,	CODE
ZBACKUP,	BACKUP
M100,
Z7700,	7700
ZERROR,	ERROR
ZLPAREN,	LPAREN
NSKNT,
ZEXPR,	EXPR
ZCOMA,	COMA
ZNAME,	NAME
ZRPAREN,	RPAREN
ZNXTSTM,	NXTSTM
ZPUSH,	PUSH
ZPOP,	POP
ZNXTCHR,	NXTCHR
ZM12,	-12
ZLOOKUP,	LOOKUP
ZM11,	-11
LINKNT,	-1
ZM15,	-15
ZPCRLF,	LPCRLF
ZNMLS,	NMLSER
ZM10,	-10
ZPRINT,	PRINT
TSIZE,	0
ZSKIP,	SKIP
NUMBER,	NOMBRE
Z3,	3
Z10,	10
Z101,	101
LP8PC,	7600		/ADDRESS OF "LPT" ROUTINE

	*200		/ONCE ONLY CODE
START,	JMP I .+1
	CREATE
	CDF 10
	IAC		/DUMMY ENTRY
	DCA I X0
	TAD Z101
	DCA I X0
	TAD Z101
	DCA I X0
	CLA IAC
	DCA I X0
	DCA I L7
	CDF 0
	TAD M4
	TAD I P7762	/MAGIC LOCATION CONTAINS COMPILER HUNK
	CIA
	DCA I (TOPF	/SET MAX BINARY LENGTH (ECCH)
	TAD LPOCHR
	DCA LP8PC
	TAD I PLSTSW
	AND L77
	CALL (SWITCH
	CALL (DEIGHT
	TAD I M4	/REALSYS
	DCA SYSHND	/"ALL PROGRAMS MUST DO THIS" - R.L.
	STA
	TAD SYSHND	/GET SYSTEM HANDLER ADDR-1
	DCA START
	TAD I START	/LOOK AT CONTENTS
	TAD (-4565	/IS IT "DT"?
	SZA CLA
	DCA BUNIT	/USE UNIT 0 IF NOT DT
	TAD (6
	DCA	SYMEND
	DCA	LITNUM
	DCA	NSYMS
	CLL CML RTR	/2000 DESTROYS LOC 12000 THE FIRST TIME
	DCA	OBSIZE
	STA
	DCA I (CODBUF
	TAD I (TOPFLD
	AND L70
	TAD ZM10
	SNA CLA
	JMP BUFSOK	/WORKING IN 8K
	TAD NEWSRB	/WORKING IN AT LEAST 12K
	DCA SRB		/ADJUST BUFFERS
	TAD SRB
	DCA I (SRB2
	DCA SRC		/USE ALL FIELD 2
	DCA I (SRC2	/0
	TAD GLUG2
	DCA GLUG
	TAD NEWSRC
	DCA OUTC
	STL CLA RAR	/4000
	DCA OUTB
	TAD (-1000
	DCA I (STS

BUFSOK,CLA STL RTL	/2
	CALL (SYSINI	/OPEN FILE 0 FOR INPUT
SRB,	READ+LEN0+10
SRC,	SRCBUF		/BUFFER START
P7762,	7762		/UMONITOR ERROR
	TAD (MAGIC	/SET SPECIAL OUTPUT BLOCK
	DCA I (SBT	/AS FUDGE
	TAD (SBT
	DCA I (GET
	TAD OUTC
	TAD BUNIT
	DCA OUTC
	CLA IAC
	CALL (SYSINI	/OPEN FILE 1 FOR OUTPUT
OUTC,	WRITE+LEN1+10
OUTB,	OUTBUF
PLSTSW,	LISTSW		/HALT IF ERROR
	TAD GLUG
	DCA I W3
	STA
	TAD OUTB
	DCA I W2
	TAD LSTSW
	SNA CLA
	JMP	NOFIX
	TAD	M4
	JMS I	MOVE
	CDF 10
	EMSG-1
	LSTNG-1
NOFIX,	CALL ZCDUMP
K5,	PROCOD		/OUTPUT TYPE 5 RECORD
	STA		/-1 CHANGED AT END
	CALL ZCODE
	CALL ZCODE
	CALL ZCODE
	CALL ZCODE
	CALL ZCODE
	TAD	K5		/VERSION 5
	CALL ZCODE
	TAD	(0402		/PUT IN "DB"
	CALL	ZCODE		/FOR USE BY SAVE COMMAND
	CALL ZRESET
	TAD I (LPWDTH
	DCA I (LPTWD
	JMP I	(NOWSTM
/	PROC NUM (NEG IF BAD PROG)
/	STARTING
/	ADDRESS
/	LENGTH
/	MORE LENGTH?
/	VERSION #

NEWSRB,	READ+LEN02+20	/LOWER HALF FIELD 2 INPUT BUFFER
NEWSRC,	WRITE+LEN12+20	/UPPER HALF FIELD 2 OUTPUT BUFFER
			/IF HAVE 12K OR MORE
GLUG,	-LEN1^2
GLUG2,	-LEN12^2
/
	PAGE

LBUFR=200	/BLOCK LITERAL BUFFER (LENGTH 100)
INPLIN=300	/INPUT LINE BUFFER (LENGTH 100)
PDL=4400	/PUSH DOWN LIST (LENGTH 100)
MBUFR=4500	/LITERAL BUFFER (LENGTH 100)
CODBUF=4600	/CODE BUFFER (LENGTH 200)

	*400
NAME,	0			/PICK UP VARIABLE NAME
	TAD Z101	/SET VAR NAME TO BLANKS
	DCA	NAME1
	TAD Z101
	DCA	NAME2
	TAD Z101
	DCA	NAME3
	JMS	NXTCHR
	JMP I	NAME
	JMS	LETTER		/MUST START WITH LETTER
	JMP	NONAME		/IF NOT A LETTER, BACKUP
	CALL ZBACKUP	/OTHERWISE BACKUP ANYWAY
	TAD	(NAME1+NAME1	/SET CHAR PTR FOR NAME
	DCA	NAMPTR
	CLL CMA RTL		/-3
	DCA	NAMCNT		/ONLY 3 WORDS SIGNIFICANT
	ISZ	NAME		/BUMP RETURN ADDR
IDLOOP,	JMS	NXTCHR		/GET NEXT NAME CHAR
	EXIT NAME	/IF END OF LINE, NAME DONE
	JMS	LETTER		/IS IT A LETTER?
	SKP			/NO
	JMP	.+3		/YES, SKIP SOME JUNK
	CALL	NUMBER		/IS IT A DIGIT?
	EXIT NAME	/NO, END OF NAME
	DCA	NAMCHR		/SAVE CHAR
	TAD	NAMPTR		/GET CHAR PTR
	CLL RAR			/SPLIT INTO WORD PTR,
	DCA	NAMTMP		/WHICH GETS STORED
	ISZ	NAMPTR
	TAD	NAMCHR
	SZL			/AND INDICATOR (IN LINK)
	JMP	LOWNAM		/IF LINK=0, LOWER CHAR
	RTL			/OTHERWISE UPPER
	RTL
	RTL
	IAC
	DCA I	NAMTMP		/SAVE UPPER CHAR
	JMP	IDLOOP		/AND GET SOME MORE

LOWNAM,	TAD I	NAMTMP		/COMBINE UPPER AND LOWER
	TAD M1
	DCA I	NAMTMP
	ISZ	NAMCNT		/BUMP COUNT
	JMP	IDLOOP
SKPNAM,	JMS	NXTCHR		/SKIP ANY
	JMP I	NAME		/NON-SIGNIFICANT
	JMS	LETTER		/CHARS
	SKP
	JMP	.+3
	CALL NUMBER
	EXIT NAME
	CLA
	JMP	SKPNAM
NAMPTR,	0
NAMCNT,	0
NAMTMP,
LETTER,	0			/SKIP ON LETTER
	TAD	(-40
	CLL
	TAD	(-34
	SNL
	ISZ	LETTER
	TAD	(74
	JMP I	LETTER

NAMCHR,	0
NONAME,	JMS I ZBACKUP		/REPLACE CHARACTER
	JMP I	NAME		/AND EXIT
GETCHR,	0	/GET NEXT CHAR
	TAD	CHRPTR
	DCA	CHP
	TAD (INPLIN
	JMS I	KGETC
CHP,	0
	SNA
	JMP I	GETCHR	/EOL
	TAD (-75
	SNA
	TAD (-74
	TAD L75
	ISZ	CHRPTR
	ISZ	GETCHR
	JMP I	GETCHR
SKIPT,	0
SKIP,	0
	TAD I	SKIP		/SKIP N CHARS
	DCA	SKIPT
	JMS	NXTCHR
	SKP CLA			/CAN OCCUR
	CLA
	ISZ	SKIPT
	JMP	.-4
	ISZ	SKIP
	JMP I	SKIP

NXTCHR,	0			/GET NEXT NON-BLANK CHAR
	JMS	GETCHR
	JMP I	NXTCHR
	TAD	M1		/BLANK IS 40 (OCTAL)
	SNA
	JMP	.-4
	TAD	(1-34		/TEST FOR ; (COMMENT)
	SNA
	JMP	SEMI
	TAD	(34
	ISZ	NXTCHR
	JMP I	NXTCHR
SEMI,	JMS I	ZBACKUP
	JMP I	NXTCHR
HEREAM,	0
	TAD (HEREDC
	CALL ZCODE
	TAD LINENO
	CALL ZCODE	/OUTPUT LINE #
	EXIT HEREAM
OPTMZ3,	0		/1 IF /O
FATAL,
L75,	75
	TAD I FATAL
	JMS I (ERMSG
	JMP I L7600
/
	PAGE

BACKUP,	0			/BACKUP 1 CHARACTER
	CLA CMA
	TAD	CHRPTR
	DCA	CHRPTR
	JMP I	BACKUP
CDUMP,	0			/CHANGE RECORD TYPE
	TAD I	(CODBUF
	CMA		/THIS ROUTINE COMPLETELY REWRITTEN BY RL
	SPA SNA CLA	/NULL RECORD?
	JMP ZRCODE	/YES - DON'T OUTPUT
	TAD ERKNT
	SZA CLA
	JMP NOCODE	/NO CODE IF ERRORS
	TAD I (CODBUF+1
	TAD I CDUMP
	SNA CLA
	JMP CDEXIT
	TAD I (CODBUF
	CIA
	IAC CLL
	TAD BOUTLN
	DCA BOUTLN
	SZL
	ISZ HIBOUT
	TAD HIBOUT
	TAD TOPF
	SMA CLA		/EXCEEDED BINARY AREA?
	JMP ER61	/YES!
	STL RAR
	DCA LENGTH	/NO LENGTH LIMIT
	CLA IAC
	CALL	RDOIO
	CODBUF-1
TOPF,	-2		/***
NOCODE,/CALL (OPRNT
ZRCODE,	STA
	DCA I	(CODBUF
	TAD	(CODBUF	/RE-INITIALIZE CODE BUFFER
	DCA	X3
	TAD I	CDUMP
	DCA I	X3	/INSERT RECORD TYPE
CDEXIT,	ISZ CDUMP
	JMP	I CDUMP

CODE,	0		/ROUTINE TO OUTPUT A WORD
	DCA I	X3	/STORE IT
	TAD I	(CODBUF+1/RL
	SNA CLA
	ISZ	LOCCTR	/BUMP PC IF RECORD TYPE IS "PROG"
	SKP
	ISZ HILOC
	STA
	TAD I	(CODBUF
	DCA I	(CODBUF	/BUMP COUNT
	TAD I	(CODBUF
	TAD	(177
	SNA CLA
	JMS CDUMP	/FORCE OUT CODE
	EXIT CODE	/NECESSARY ARGUMENT
	DCA I (CODBUF+1
	EXIT CODE
ER61,	CALL ZERROR	/BINARY OUTPUT TOO BIG
	ERR61

TYPSET,	CDF 10
	CLL STA RAR
	AND I EXTMP1
	AND (13
	SNA
	JMP	ER26
	CDF 0
	DCA	TYPE		/FIRST VARIABLE, SET TYPE
	JMP I	TYPCHK
TYPCHK,	0			/TYPE CHECK
	CDF 10
	CLL STA RAR
	AND I EXTMP1
	CDF 0
	SNA CLA
	JMP I	(UNDEF		/UNDEFINED
	TAD	TYPE
	SNA
	JMP	TYPSET		/FIRST OPERAND SO SET TYPE
	CDF 10
	AND I	EXTMP1		/COMPARE TYPES
	CDF 0
	SZA CLA
	JMP I	TYPCHK		/SAME, SO RETURN
IMGERR,
TYPERR,	CALL ZERROR	/MIXED MODE
	ERR6
ER26,	CALL	ZERROR
	ERR26		/NOT ALPHA OR DECIMAL

CORG,	0		/OUTPUT SIZE-ORIGIN
	TAD SIZE
	CLL RAL		/DEATH
	CLL RAL
	CLL RAL
	TAD HIORG
	JMS I ZCODE
	TAD BYTORG
	JMS I ZCODE	/LOW ORDER ORIG
	EXIT CORG	/RETURN
ER17,	CALL ZERROR	/SUBSCRIPT NOT DECIMAL
	ERR17
BLPAD,	0
	TAD Z101
	DCA I X2
	TAD Z101
	DCA I X2
	EXIT BLPAD

RESET,	0
	CLA
	TAD SAVE
	DCA CHRPTR
	TAD (PDL-1		/RESET STACK
	DCA X4
	TAD M100
	DCA PDLCNT
	CALL ZCDUMP
	KODE
	EXIT RESET
/RESET MIGHT BE ABLE TO GO IN-LINE
PROCSYM,0
ER47,	CALL ZERROR	/BAD ALPHA CONSTANT
	ERR47
/
	PAGE

EXPR,	0			/GET ARITHMETIC EXPR
	TAD EXPR
	CALL ZPUSH
	JMS I	ZPUSH		/MARK STACK
GTOPND,	JMS I	ZNXTCHR		/CHECK FOR UNARY MINUS
	JMP	MSNGOP		/NO CHARS MEANS ERROR
	TAD M4		/UNARY #?
	SZA
	JMP NONONA	/NO
	TAD TYPE
	CLL RTR		/MUST BE 0 OR 2
	SZA CLA
	JMP I (TYPERR
	DCA TYPE
	TAD (CNVOCT+12	/YES (KLUDGE)
	JMP PUSHON
NONONA,	CLL
	TAD ZM10	/UNARY +?
	SNA
	JMP UNARY	/LINK IS SET
	TAD	(-2
	SZA
	JMP	CKOPND		/NOT UNARY MINUS
	CLL		/LINK CLEAR IF -
UNARY,	TAD	RIGHT		/UNARY MINUS NO GOOD
	SNA CLA			/IF ON LEFT OF EQUALS
	JMP	BADLFT
	SZL
	JMP GTOPND	/IGNORE UNARY PLUS ON RIGHT
	TAD	(UMINUS+12	/PUT 56 FOR U.M.
PUSHON,	JMS I	ZPUSH
	JMP	GTOPND		/KEEP LOOKING FOR OPERAND
CKOPND,	TAD	(16-11		/CHECK FOR (
	SZA CLA
	JMP	NPAREN		/NOT PARENTHESIS
	JMS	EXPR		/COMPILE SUB EXPR
	CALL ZRPAREN
	JMP I	(GOPR8R		/IF FOUND, LOOK FOR OPERATOR

NPAREN,	JMS I	ZBACKUP		/PUT BACK CHAR
	JMS I	ZNAME		/LOOK FOR VARIABLE
	JMP I	(TRYLIT		/NOT VAR
	JMS I	ZLOOKUP		/DO S.T. LOOKUP
	CDF 0
	TAD	OPRAND		/SAVE POINTERS
	DCA	EXTMP1
	TAD	SYMNUM
	DCA	EXTMP2
	CALL (TYPCHK
	JMS I	ZNXTCHR		/CHECK FOR SUBSCRIPTS
	JMP	WASLIT		/IF NOTHING LEFT, FINISH THIS
	TAD	ZM11		/TEST FOR (
	SZA CLA
	JMP	NOSUBS		/NO ( MEANS NO SUBSCRIPTS
	TAD EXTMP2
	CALL ZPUSH
	JMS	RECEXP		/GET FIRST S.S.
	JMS I	ZNXTCHR		/GET DELIMITER
	JMP	SUBERR		/NOTHING IS SUBSCRPT ERR
	TAD	ZM12		/IS IT )
	SNA
	JMP	ONESUB		/YES, ONLY 1 S.S.
	TAD	(-3
	SZA CLA		/BETTER BE ,
	JMP	SUBERR	/NO
	JMS	RECEXP		/GET SECOND S.S.
	CALL (RPAREN
	CALL ZPOP
	TAD	(PUSH2S		/IS A.O.K. , GET PUSH 2 OP
	CALL ZCODE
	JMP I (GOPR8R

RECEXP,	0		/RECURSIVE EXPR
	TAD RECEXP	/MAKE RECEXP REC EXP
	CALL ZPUSH
	CLA IAC		/MAKE NON ZERO
	TAD TYPE
	CALL ZPUSH	/SAVE TYPE
	DCA TYPE	/LEAVE EXPR UNBIASED
	IAC
	TAD RIGHT
	CALL ZPUSH	/SAVE SIDE SWITCH
	IAC
	DCA RIGHT	/SUBSCRIPT EXPR ALLOWED ON LEFT
	JMS EXPR	/RECURSIVE CALL
	CALL ZPOP	/RESTORE SIDE SWITCH
	TAD M1
	DCA RIGHT
	CLL STA RAL	/-2
	TAD TYPE
	SZA CLA		/WHAT TYPE SUBSCR?
	JMP I (ER17	/NOT DECIMAL
	CALL ZPOP
	TAD M1
	DCA TYPE	/RESTORE TYPE
	CALL ZPOP
	DCA RECEXP	/RESTORE RET ADDR
	EXIT RECEXP	/RETURN

ONESUB,	CALL ZPOP
	TAD	(PUSH1S		/GET PUSH 1 OP
	CALL ZCODE
	JMP I (GOPR8R
NOSUBS,	JMS I	ZBACKUP		/PUT BACK NON (
WASLIT,	TAD	(PUSHOP		/GET PUSH OP
	TAD	EXTMP2		/ADD IN S.T. ADDR.
	JMS I	ZCODE		/OUTPUT IT
	JMP I	(GOPR8R		/NOW LOOK FOR OPERATOR

UNDEF,	CALL ZERROR	/UNDEFINED VARIABLE
	ERR5
BADLFT,	CALL ZERROR	/BAD LEFT SIDE
	ERR4
SUBERR,	CALL ZERROR	/SUBSCRIPT ERROR
	ERR3
MSNGOP,	CALL ZERROR	/MISSING OPERAND
	ERR2
/
	PAGE

SYSINI,	0
	JMS I KPTRST
	TAD I SYSINI
	DCA I W0
	ISZ SYSINI
	TAD I	W0
LL40,	AND	L7
	TAD I SYSINI
	ISZ SYSINI
	DCA I W1
	TAD I GET
	SNA
	JMP I SYSINI
	ISZ GET
	CLL RTR
	RTR
	DCA TEMP
	TAD TEMP
	RAR
	AND L7400
	DCA I W5
	TAD TEMP
	AND (377
	DCA I W4
	DCA I W3
	ISZ SYSINI
	JMP I SYSINI
GET,	SBT

CDOIOC,	0
	IAC		/FOR COMPATIBILITY
	DCA PRCADR
	DCA SUPLCT
	TAD (-16
	DCA PTABCT
	TAD LPTWD
	DCA PRWDTH
	DCA WRELC
PRLOOP,	TAD PRCADR
	SPA
	CDF 10
	CALL KGETC
TEMP,
WRELC,	0
	SNA
	JMP PRCRLF
	JMS LPTCHR
	ISZ WRELC
	JMP PRLOOP
LPTWD,	0
ROUND,	0
	ISZ BYTORG
	SKP
	ISZ HIORG
	CLL STA RAL	/ROUND TO EVEN BYTE
	AND BYTORG
	DCA BYTORG
	TAD HIORG
	AND L7
	SZA CLA
	EXIT ROUND
	JMS I ZERROR
	ERR63		/TOO MUCH DAMN DATA

LPTCHR,	0
	TAD (-75
	SNA
	JMP PRTTAB
	TAD (334
	JMS BUMPTC
	EXIT LPTCHR
PRTTAB,	TAD LL40
	JMS BUMPTC
	JMP PRTTAB
PRCRLF,	JMS LPCRLF
	JMP I CDOIOC
LPCRLF,	0
	TAD (215
	CALL LP8PC
	TAD (212
	CALL LP8PC
	EXIT LPCRLF
BUMPTC,	0
	CALL LP8PC
	ISZ PRWDTH
	JMP .+3
	ISZ SUPLCT
	JMS LPCRLF
	ISZ PTABCT
	EXIT BUMPTC
	TAD ZM10
	DCA PTABCT
	EXIT LPTCHR
PRWDTH,	0
PTABCT,	0
SUPLCT,	0

PRCADR,
SFINI,	0
	CALL KPTRST
	TAD I W2
	DCA XT
	TAD I W0
	AND L70
	TAD KCDF0
	DCA .+1
	HLT
	DCA I XT
	CDF 0
	CALL GPBUF
	DCA I W0
	EXIT SFINI
LL20,	20
EER12,	CALL ZBACKUP
ER12,	CDF 10
	TAD (6000
	AND I OPRAND
	TAD LL20
	DCA I OPRAND	/INSERT REDEF TYPE
	CALL ZERROR
	ERR12		/NAME PREVIOUSLY DEFINED
/
	PAGE

ROOMTM,
LOOKUP,	0			/LOOKUP VAR IN SYMBOL TABLE
	DCA SYMNUM	/ZERO SYMBOL # (MIGHT HAVE AC NON-ZERO)
	TAD	NAME1		/COMPLEMENT
	CIA
	DCA	NAME1C		/THE
	TAD	NAME2
	CIA			/THREE
	DCA	NAME2C
	TAD	NAME3		/WORD
	CIA
	DCA	NAME3C		/NAME.
	TAD SYMNUM
	CLL RAL
	TAD SYMNUM
	CLL RAL
	TAD SYMNUM	/MULT SYMNUM BY 7
	TAD M1		/SUBTR 1
	DCA X0		/SET PTR TO TABLE-1
	CDF 10		/SET FIELD
SYMLUP,	TAD I	X0		/IS THIS END OF TABLE?
	SNA
	JMP	ENDTAB		/YES, MAKE NEW ENTRY
	TAD	NAME1C		/IS THIS THE ONE?
	SZA CLA
	JMP	BUMP6		/NO
	TAD I	X0
	TAD	NAME2C		/SO FAR SO GOOD
	SZA CLA
	JMP	BUMP5		/NO
	TAD I	X0
	TAD	NAME3C		/ALMOST...
	SZA CLA
	JMP	BUMP4		/AW NUTS!
	TAD	X0		/YES, THIS IT 
	IAC
	DCA	OPRAND		/SET THE POINTER
	JMP I	LOOKUP		/RETURN
BUMP6,	IAC			/SKIP
BUMP5,	IAC			/THE REST
BUMP4,	IAC			/OF
	TAD	Z3		/THIS
	TAD	X0		/ENTRY
	DCA	X0		/AND THEN
	ISZ	SYMNUM		/BUMP SYMBOL NUMBER AND
	JMP	SYMLUP		/LOOP
ENDTAB,	CMA			/END OF TABLE
	TAD	X0
	DCA	X0
	TAD	NAME1
	DCA I	X0		/SO MAKE
	TAD 	NAME2
	DCA I	X0		/A NEW
	TAD	NAME3
	DCA I	X0		/ENTRY.
	DCA I	X0		/WITH TYPE 0
	TAD	X0
	DCA	OPRAND		/(SAVE THE POINTER)
	DCA I	X0		/AND 0 DIMENSION
	DCA I	X0		/AND 0 ELEMENT SIZE
	DCA I	X0		/AND 0 ORIGIN
	TAD	X0
	DCA	SYMEND		/SAVE NEW END OF TABLE
	DCA I	X0		/ZERO E.O.T.
	ISZ	NSYMS		/BUMP # OF SYMBOLS
	TAD	NSYMS
	TAD	STS		/S.T. FULL
	SPA CLA
	JMP I	LOOKUP		/NO, WE'RE STILL ALIVE
	CDF 0
	JMS I	(FATAL		/WHUPS! ,THIS IS FATAL
	ERR23
NAME3C,	0
STS,	-555		/- S.T. SIZE (IN ENTRIES)

NAME1C,
ROOM,	0		/15-BIT ADDRESSING HACK
	CLL		/WANT TO INSERT AN ENTRY
	TAD BYTORG	/OF SIZE TSIZE
	TAD TSIZE
	SNL CLA
	EXIT ROOM	/IT FITS
	TAD HIORG
	RAR
	SNL CLA
	EXIT ROOM	/STILL FITS BUT OVERFLOWS HALF-HUNK
	CALL ZCDUMP	/TELL LARY ABOUT SHUFFLE
	RELOC
	TAD I (HIOLDBLK
	AND L7
	CALL ZCODE
	TAD OLDBLK
	CALL ZCODE
	CALL ZCDUMP	/DUMP CRUMMY RECORD
	KODE
	TAD OLDBLK
	CIA
	DCA OLDBLK	/NEGATE
	CDF 10
FIXLUP,	TAD STREF
	CIA
	TAD SYMEND
	SPA CLA
	JMP FIXOUT	/YES
	CALL (COMN
	TAD OLDBLK	/SUBTRACT OFF CRUD
	DCA I STREF	/REPLACE HAPPIER THAN EVER
	ISZ STREF
	JMP FIXLUP	/REITERATE
FIXOUT,	CDF 0
	TAD BYTORG
	TAD OLDBLK
	DCA BYTORG	/ADJUST BYTORG
	DCA OLDBLK
	ISZ HIORG	/GO TO NEXT FIELD
	ISZ I (HIOLDBLK
	EXIT ROOM

NAME2C,	0
	ISZ CHRPTR
NMLSER,	CALL ZERROR
	ERR11
PRCDIV,	6163
	6044
	4645
	6663
	4601
/
	PAGE

CPUTC,	0
	CALL KPUTC
LMBUFR,	MBUFR-1
LCNUM,	0
	ISZ LCNUM
	JMP I CPUTC

LITERL,	0			/LOOK FOR A LITERAL (LATERALLY!)
	DCA LCNUM
	DCA	ALIT		/SET TYPE TO DECIMAL
	JMS I	ZNXTCHR		/GRAB A CHARACTER
	JMP I	LITERL		/SORRY, NONE LEFT
	JMS I	NUMBER		/IS IT A DIGIT?
	JMP	QUOTCK		/NO, TRY A QUOTE
	JMS I	ZBACKUP		/YES, BACK 1
STLIT,	DCA	LITSIZ		/LITERAL HAS 0 LENGTH
LITLUP,	JMS	GLCHR		/GET NEXT CHAR (LITERALLY)
	JMP	ENDLIT		/END IT OFF
	JMS CPUTC
	ISZ	LITSIZ		/BUMP SIGHS AGAIN
	JMP	LITLUP		/AND LOOP
ENDLIT,	ISZ LITERL	/BUMP RETURN ADDRESS
	JMS CPUTC
	JMS CPUTC
	JMS CPUTC
	TAD I (MBUFR
	DCA NAME2
	TAD I (MBUFR+1
	DCA NAME3
	ISZ LITNM	/UNIQUE BY 2
	ISZ LITNM
	TAD (-5
	TAD LITSIZ
	SMA CLA
	TAD LITNM	/UNIQUE NAME IF .GT. 4 DIGS
	TAD ALIT	/WORK IN TYPE
	TAD Z10
	DCA NAME1
	TAD I (PROCSYM
	CALL ZLOOKUP
	CLL STA RAR
	AND I OPRAND
	CDF 0
	SZA CLA		/PREV DEF?
	JMP I LITERL	/YES, RETURN
	CALL (ORDAIN

	JMS I	ZCDUMP		/DUMP THIS RECORD
	KODE			/AND SET TYPE TO 0
	TAD ALIT	/SET TYPE
	CMA		/0 BECOMES 2 DECIMAL
	TAD Z3		/-6 BECOMES 10 RECORD (1 STAYS)
	CDF 10
	TAD I OPRAND
	DCA I	OPRAND		/PUT TYPE INTO S.T.
	ISZ OPRAND
	IAC
	DCA I	OPRAND		/DIMENSION IS 1
	ISZ OPRAND
	TAD	LITSIZ
	CLL RAL
	RTL
	TAD	HIORG
	DCA I	OPRAND		/SET ELEMENT SIZE
	ISZ OPRAND
	TAD	BYTORG
	DCA I	OPRAND		/AND ORIGIN
	CDF 0
	TAD	BYTORG		/BUMP BYTE ORG
	TAD	LITSIZ	/ORDAIN GIVES US ROOM
	DCA	BYTORG
	CLL STA RTL	/-3
	TAD OPRAND
	DCA OPRAND	/OPERAND PTS. TO TYPE
	TAD ALIT
	SPA CLA
	CALL (ROUND
	JMP I	LITERL		/NOW EXIT

QUOTCK,	CALL ZNXTCHR
LITNM,	4	/CANNOT OCCUR
	TAD	ZM10		/IS IT A '
	ISZ	ALIT		/DON'T KNOW, BUT SET IT ANYWAY
	SNA
	JMP	STLIT		/YUP, IT WAS
	TAD (5
	SNA CLA		/IS IT "?
	JMP RECLIT	/YES
	JMS I	ZBACKUP		/NOPE, PUT CHAR BACK
	JMP I	LITERL		/AND RETURN WITH NO SKIP
GLCHR,	0			/PICK UP A CHAR FOR LIT
	TAD	ALIT		/IS IT ALPHA OR DEC?
	SZA CLA
	JMP	GETACH		/ITS ALPHA
	JMS I	ZNXTCHR		/GET A CHAR
	JMP I	GLCHR		/NO MORE, FINISH IT OFF
	JMS I	NUMBER		/DIGIT?
	EXIT GLCHR	/NO
GLRET,	ISZ	GLCHR		/YES, BUMP RETURN
	JMP I	GLCHR		/RETURN

GETACH,	JMS I	(GETCHR		/NEXT CHAR (BLANKS INCL.)
	JMP	BADLIT		/MISSING QUOTE
	TAD	ZM10		/IS IT A '
	SNA
	JMP I	GLCHR		/YES, LIT. DONE
	TAD Z10
	JMP GLRET
BADLIT,	JMS I	ZERROR
	ERR10			/MISSING QUOTE ERROR
ALIT,	0		/0:DECIMAL, 1:ALPHA, -6:RECORD

RECLIT,	CALL (ROUND
	TAD (-6
	DCA ALIT
	TAD Z10
	JMS CPUTC
	TAD Z10
	JMS CPUTC
	STL CLA RTL
	JMP STLIT
/
	PAGE

PROCST,	DCA I (IFLG
	JMS I	ZNAME		/LOOK FOR A SYMBOL
	JMP	I (NMLSER-1	/THIS IS A NAMELESS ERROR
	JMS I	ZNXTCHR		/IS THIS A LABEL?
P5,	5			/MUST BE ONE WORD COMMAND
	TAD	ZM15		/TEST FOR ,
	SZA CLA
	JMP	NOLABL
	TAD I (PROCSYM
	JMS I	ZLOOKUP		/DO S.T. LOOKUP
	TAD I	OPRAND		/SHOULD NOT BE PREVIOUSLY DEF
	CLL RAL
	SMA SZA CLA
	JMP I (EER12
	TAD Z10
	RAR
	DCA I	OPRAND		/SET TYPE TO
	ISZ	OPRAND		/"DEFINED LABEL"
	ISZ	OPRAND
	TAD HILOC
	TAD Z10
	DCA I OPRAND
	ISZ	OPRAND
	TAD	LOCCTR		/STORE LABEL VALUE
	DCA I	OPRAND
	CDF 0
	TAD CHRPTR
	DCA SAVE
OPTMZ1,	CALL (HEREAM	/OUTPUT LINE# (CLA IF /O)
	JMP EQL

NOLABL,	TAD SAVE
	DCA CHRPTR
	TAD LINENO
	CIA
	TAD OLDLNO	/FORM DIFFERENCE
	DCA LINDIF
	STL CLA RTR
	RAR		/CLL AND TAD (1000
	TAD LINDIF
	SNL CLA		/IS IT LESS THAN 1000?
	JMP OPTMZ1	/NO, GUY'S CRAZY
	TAD LINDIF
OPTMZ2,	CALL ZCODE	/OUTPUT DIFFERENCE (CLA IF /O)

EQL,	DCA	RIGHT	/ZERO QUOTE COUNTER
	ISZ	ONERCT	/IF THIS IS THE 2D STATEMENT
	JMP	.+3	/AFTER AN "ON ERROR" STATEMENT
	TAD	(ONERXX	/OUTPUT A SPECIAL CODE
	CALL	ZCODE	/TO CANCEL THE ERROR TRAP
EQLOOP,	JMS I	ZNXTCHR
	JMP I	(COMAND	/NO EQUAL SIGN - MUST BE A COMMAND
	TAD	ZM10
	SNA
	ISZ	RIGHT	/BUMP QUOTE COUNTER ON QUOTES
	TAD P5
	SZA
	JMP .+3
	CLA IAC
	DCA RIGHT
	TAD (3-36
	SZA CLA
	JMP	EQLOOP	/NO = YET, KEEP LOOKING
	CLA IAC
	AND	RIGHT
	SZA CLA		/ARE WE IN QUOTES?
	JMP	EQLOOP	/YES - DOESNT COUNT
	TAD SAVE
	DCA CHRPTR
	DCA	RIGHT		/SET SWITCH FOR LEFT SIDE
	DCA	TYPE		/ZERO TYPE
	JMS I	ZEXPR		/ASSUME ARITHMETIC UNTIL PROVEN
	JMS I	(CKLET
	36			/CHECK FOR "="
	JMS I	ZNXTCHR		/IF END OF STATEMENT
	JMP I	(CLEAR		/IT WAS A "CLEAR"
	JMS I	ZBACKUP		/PUT BACK CHAR
	TAD	TYPE
	DCA	TYPLFT		/SAVE TYPE OF LEFT SIDE
	DCA	TYPE		/RE-ZERO TYPE
	ISZ	RIGHT		/SET SWITCH FOR RIGHT SIDE
	JMS I	ZEXPR		/GET RIGHT SIDE OF EXPR
	TAD TYPLFT
	TAD TYPE
	AND Z10
	SZA CLA
	JMP I (IMGERR
	JMS I	ZNXTCHR
	SKP
	JMP I	(IMAGE		/CHECK FOR DECIMAL,ALPHA
	TAD TYPLFT
	AND	Z10	/********THINK SHOULD BE Z10 (USED TO BE ZM10)
	SZA CLA		/IS LEFT SIDE A BLOCK?
	JMP	AASTOR	/YES - USE ALPHA STORE
	STA CLL RTL	/-3
	TAD TYPLFT
	CLL RAL
	TAD TYPE	/COMBINE LEFT AND RIGHT TYPES
	SZA
	JMP FASTZ	/MIXED MODES - DON'T OPTOMIZE
	TAD X3		/DO OPTIMIZATION ON A=B+C AND A=B-C
	DCA TYPE		/BUT ONLY IF D TO D STORE
	CLL STA RAL	/-2
	TAD I TYPE	/GET LAST CODE ENTRY
	CLL RTR		/DON'T GO THROUGH 'CODE'
	SZA CLA		/2 OR 4?
	JMP FASTZ	/NO
	RAL		/YES, LINK ON MEANS 4 (SUB)
	TAD (STADOP
	DCA I TYPE	/INSERT
	JMP I ZNXTSTM
AASTOR,	STA CLL RTL	/STORAA=STORDD-3
FASTZ,	TAD (STORDD
	JMS I	ZCODE
	JMP I	ZNXTSTM		/GO DO NEXT STMT
ONERCT,	0
/
	PAGE

STAR,	JMS I	(CKLET
	65		/CHECK FOR "START"
COMM,	JMS COM
	STA
	DCA LINKNT
	JMP NEWSTM
COM,	0
EOP,	CALL ZNXTCHR	/LOOK FOR SLASH
	JMP EOL		/END OF LINE
	TAD (-20
	SNA CLA		/IS IT SLASH?
	CALL ZNXTCHR	/YES
	NOP		/MISSING ARG
	TAD (-65
	SNA		/IS IT /T?
	JMP ITST	/YES
	TAD Z10
	CLL RTR
	SZA
	JMP ER14		/NOT L OR N
	SNL
	JMP ITSL
	ISZ LSTSW	/N
	JMP EOP
ITSL,	TAD I (LPWDTH
	DCA I (LPTWD
	TAD LPOCHR	/L
	JMP ITSLT
ITST,	TAD (-110
	DCA I (LPTWD
	TAD TTOCHR	/T
ITSLT,	DCA LP8PC
	STL CLA RAR
	AND LSTSW
	DCA LSTSW
	JMP EOP
EOL,	TAD	L32
	DCA	PUTCN	/INITIALIZE CHAR POINTER INTO SUBHEADER
	ISZ CHRPTR
STARLP,	TAD	PUTCN
	TAD	(-115
	SNA CLA		/ARE WE AT THE END OF THE SUBHEADER?
	EXIT COM	/YES - IGNORE EXCESS CHARS & PROCEED
	JMS I	(GETCHR	/GET A CHAR
L32,	32		/CR - BIG DEAL
	CDF 10
	JMS I	KPUTC
	SUBHDG		/PUT THE CHAR INTO THE SUBHEADING
PUTCN,	0
	ISZ	PUTCN	/BUMP POINTER
	JMP	STARLP	/LOOP

NXTSTM,	JMS I	ZNXTCHR
	JMP	.+3
ER14,	JMS I	ZERROR
	ERR14
	CALL ZRESET	/FORCE OUT LAST RECORD
NEWSTM,	TAD LSTSW
	SNA CLA		/PRINT LAST LINE
	CALL ZPRINT	/YES
	INPLIN-1	/NO
NOWSTM,	JMS I	(GETLIN		/GET NEXT LINE
	TAD CHRPTR
	DCA SAVE
	CALL ZNXTCHR	/NULL LINE?
	JMP	RSETLN	/RESET LINE # AND GET NEXT STMT
	TAD (-40	/(USE SMA SZA CLA)***
	CLL
	TAD Z3
	JMS I (CCP
	CALL ZRESET
	JMP I BLKJMX
RSETLN,	CDF 0
	TAD	OLDLNO
	DCA	LINENO	/RESTORE LINE NUMBER
	JMP	NEWSTM

PROC,	TAD	(-5
	JMS I	MOVE	/CHANGE THE SUBHEADER
	CDF 10		/TO READ "PROCEDURE DIVISION"
	PRCDIV-1	/INSTEAD OF "DATA DIVISION"
	SUBHDG+2	/LEAVING THE USERS COMMENTS (IF ANY) UNDISTURBED
	DCA LOCCTR
	CALL (HEREAM
	TAD L7		/DEFAULT IS 7
	DCA PROCNM
	CALL (ROUND
	STL CLA RAR	/4000 PROC OVERLAY AT RECORD 10 OF HUNK 3
	CALL SYSHND	/READ PROC OVERLAY
	400		/2 RECORDS (4 PAGES)
BLKJMX,	3400		/BUFFER
	3		/THE HUNK!
	TAD NSYMS
	IAC		/COMPUTE FIRST NON-DATA SYMBOL #
	DCA I	(PROCSYM	/STORE FIRST NON-DATA SYMBOL #
	CLA STL RTR	/*** KLUDGE ***
	DCA	BLKJMX	/*** STORE "PROCST" IN "BLKJMX" ***
	TAD NAME3
	AND Z7700
	CLL RTR
	RTR
	RTR		/GET DIGIT
	TAD M1
	SZA		/BLANK IS EQUIVALENT TO 0
	TAD (-20	/CONVERT TO OCTAL
	SNA		/A CONSESSION TO RL
	JMP	COMM	/0 GOES TO 7
	DCA PROCNM	/SAVE IT
	TAD PROCNM
	AND ZM10	/IS IT 0-7?
	SNA CLA
	JMP	COMM
	CALL ZERROR	/BAD PROC #
	ERR70
/
	PAGE

TRYST,	TAD NAME1	/LOOK FOR START
	TAD (-6465	/"ST"
	SNA CLA
	TAD NAME2
	TAD (-4263	/"AR"
	SNA CLA
	TAD NAME3
	TAD (-6501	/"T"
	SZA CLA
	JMP I ZNMLS
	JMP I (COMM	/UGGH
TRYREC,	TAD NAME1	/LOOK FOR "RECORD"
	TAD (-6346	/"RE"
	SNA CLA
	TAD NAME2
	TAD (-4460	/"CO"
	SNA CLA
	TAD NAME3
	TAD (-6345	/"RD"
	SZA CLA
	JMP TRYPRC
	JMS I ZRESET
	CALL ZSKIP
	-6		/PASS OVER RECORD CHARS
	JMP I (RECORD	/JOIN PROCESSING

ORDAIN,	0		/SEE IF ROOM FOR LITERAL
	CLL
	TAD BYTORG
	TAD LITSIZ
	CLA SNL
	JMP EXT		/PLENTY OF ROOM
	ISZ HIORG	/HORRORS!
	DCA BYTORG	/ACTUALLY WE'RE WASTING SPACE AT HALF-FIELD BDY
EXT,	CALL ZCDUMP
	DATAIN
	TAD LITSIZ
	CLL RTL
	RAL
	TAD HIORG
	CALL ZCODE	/OUTPUT SIZE
	TAD BYTORG
	CALL ZCODE	/AND ORIGIN
	TAD (MBUFR-1
	DCA X2
	STA
	TAD LITSIZ
	CLL CML CMA RAR
	DCA LTMP
	TAD I X2
	CALL ZCODE
	ISZ LTMP
	JMP .-3
	EXIT ORDAIN
LTMP,	0

NOMBRE,	0		/SKIP ON DIGIT
/	BACKUP SCAN IF NOT FOUND
	TAD (-33
	CLL
	TAD (12
	SNL
	JMP NONONO
	ISZ NOMBRE
	TAD (21
	EXIT NOMBRE
NONONO,	CLA
	CALL ZBACKUP
	EXIT NOMBRE
COMA,	0		/SKIP ON COMMA
	CALL ZNXTCHR	/GET NEXT CHAR
	JMP ER56	/EOL IS BAD
	TAD ZM15	/IS IT ","?
	SNA CLA
	EXIT COMA	/RETURN
ER56,	CALL ZERROR	/MISSING COMMA
	ERR56

TRYPRC,	CALL ZNXTCHR
	JMP NOCO
	TAD ZM15
	SNA CLA		/IS IT ","?
	JMP I (DATASP	/YES
	CALL ZBACKUP	/NO KEYWORDS!
NOCO,	TAD	NAME1		/LOOK FOR "PROC"
	TAD	(-6163		/"PR"
	SZA	CLA
	JMP TRYST	/MAYBE ITS AN ANACHRONISM
	TAD	NAME2
	TAD	(-6044		/"OC"
	SZA	CLA
	JMP TRYST
	TAD	NAME3
	AND L77
	TAD M1
	SZA	CLA
	JMP TRYST
	CALL (FIX
	JMP I (PROC
PUSH,	0
	DCA I	X4
	ISZ	PDLCNT
	JMP I	PUSH
	JMS I	ZERROR
	ERR22
CHAIN,	JMS I	(CKLET
	57		/CHECK FOR "N"
	JMS I	(IARG	/ONE DECIMAL ARG
	TAD	(CHNOP
	JMS I	ZCODE
	JMP I	ZNXTSTM
/
	PAGE

	ERTMP=EXTMP1
ERMSG,	0		/PRINT ERROR MESSAGE
	TAD	M1
	DCA ADRER	/ADDR OF TEXT IS IN AC
	DCA I (DOSW
	TAD ERKNT
	SZA CLA
	JMP MORERR
	IAC		/TAD (IFN1
	CALL (SFINI
MORERR,	ISZ ERKNT
	CALL ZPRINT	/NO, PRINT NOW
	INPLIN-1
	TAD CHRPTR
	TAD	(-6
	CMA
	DCA CHRPTR	/USE CHRPTR AS KNT
	DCA I (SUPLCT
	TAD (-16
	DCA I (PTABCT
	DCA I (PRWDTH
	TAD	M4
	DCA	INK
	TAD (16
	CALL (LPTCHR	/OUTPUT 4 UNDERLINES TO LPT
	ISZ	INK
	JMP	.-3
	TAD (4
	DCA INK

BLINS,	TAD (INPLIN
	CALL KGETC
INK,	4
	TAD (-75
	SNA CLA		/OUTPUT TABS AS TABS
	TAD L74		/AND OTHER CRAP AS SPACES
	IAC
	CALL (LPTCHR
	ISZ INK		/GO TO NEXT CHAR
	ISZ CHRPTR	/THROUGH?
	JMP BLINS
	TAD L77
	CALL (LPTCHR	/INSERT CARET
	CALL (LPCRLF	/CRLF
	TAD (-6
	DCA ERTMP	/PAD WITH 6 SPACES
	TAD (240
	CALL LP8PC
	ISZ ERTMP
	JMP .-3
	IAC		/INHIBIT LPT LINE COUNT
	CALL ZPRINT
ADRER,	0
	TAD (212
	CALL LP8PC	/LF
	TAD LINKNT
	TAD Z3
	DCA LINKNT
	TAD LINKNT
	SMA
	STA
	DCA LINKNT
	EXIT ERMSG

POP,	0
	TAD	X4
	DCA	ERMSG
	CMA
	TAD	X4
	DCA	X4
	CMA
	TAD	PDLCNT
	DCA	PDLCNT
	TAD I	ERMSG
	JMP I	POP

NOEND,	CLA STL RTL	/TRY TO OPEN NEXT SOURCE FILE
			/IFN0=2
	CALL (SYSINI
SRB2,	READ+LEN0+10	/FOR INPUT
SRC2,	SRCBUF		/START OF BUFFER
	JMP EENDYD	/NO MORE
	STA
	DCA LINKNT
	JMP I (NOWSTM
EENDY,	TAD LSTSW
	SNA CLA		/PRINT END STATEMENT?
	CALL ZPRINT	/YES
	INPLIN-1	/NO
	TAD SAVE	/RESET
	DCA CHRPTR
	CALL ZSKIP
	-3
	CALL (COM
EENDYD,	TAD (5000
	CALL SYSHND
	500		/2 RECORDS
	1400		/ANOTHER OPENING ANOTHER SHOW
	3		/VIVE LA HUNK
	TAD (STOPOP
	CALL ZCODE
	CALL ZCDUMP
L74,	74		/NEED TO DUMP END OF CODE
	JMP I (ENDST	/GO TO IT
ERROR,	0
	CLA
	CDF 0
	TAD I ERROR
	JMS ERMSG
	JMP I ERET
ERET,	NOWSTM
/
	PAGE

IF,	TAD SAVE
	DCA CHRPTR
	CALL ZSKIP
	-2
	CALL ZLPAREN
	DCA	TYPE		/ZERO TYPE
	IAC
	DCA	RIGHT		/SET RIGHT-SIDE SWITCH
	JMS I	ZEXPR		/NOW GET FIRST EXPR
	JMS I	ZNXTCHR		/LOOK FOR .
	JMP	ER65
	TAD	(-17
	SZA CLA
	JMP ER65
	JMS I	ZNAME		/GET RELATIONAL
	JMP	ER65
	TAD	NAME2
	AND L7600
	SZA CLA
	JMP I (ER25
	TAD	(-6		/LOOK UP RELATIONAL
	DCA I	(IFCCOD
	TAD	(RELLST-1
	DCA	X0
RLOOP,	TAD I	X0		/IN THIS LOOP
	TAD	NAME1
	SNA CLA
	JMP I	(GOTREL
	ISZ I	(IFCCOD	/BUMP CONDITION CODE
	JMP	RLOOP
ER65,	CALL ZERROR	/MISSING RELATIONAL
	ERR65

/DEBUGGING ROUTINE
/PRINTS OCTAL NUMBERS ON LINEPRINTER
/OPRNT,	0
/	CLA
/QPRNT,	EXIT OPRNT	/GETS ZEROD
/	TAD (CODBUF-1
/	DCA X0
/	TAD I X0
/	DCA ZKNT
/	LAS
/	TAD (-1234
/	SZA CLA
/	JMP I OPRNT
/	CALL ZPCRLF
/ZLOOP,	TAD I X0
/	DCA WORD
/	TAD M4
/	DCA YKNT
/ZLUP,	TAD WORD
/	RTL
/	RTL
/	AND L7
/	TAD L260
/	JMS I LP8PC
/	TAD WORD
/	RTL
/	RAL
/	DCA WORD
/	ISZ YKNT
/	JMP ZLUP
/	CALL ZPCRLF
/	ISZ ZKNT
/	JMP ZLOOP
/	CALL ZPCRLF
/	JMP I OPRNT
/ZKNT,	0

/0	<
/1	=
/2	>
/RETURN TO RSETLN TO IGNORE LINE
/IF LINK IS ON, IT'S A CCP COMMAND
/NORMAL RETURN TO PROCESS LINE
CCP,	0
	SNL		/IS IT A CCP COMMAND?
	JMP REGCOM	/NO
	TAD JT
	DCA .+1
IGNORE,	0
	TAD NOCOMP
	SZA CLA
	JMP BLNKLN
	CALL ZNAME	/LOOK FOR VARIABLE
	JMP ER71	/NAME MISSING
	CALL ZLOOKUP
	TAD I OPRAND
	JMP I IGNORE
JT,	JMP I .+1
	CCLT
	CCEQ
	CCGT
CCLT,	ISZ LTKNT	/BUMP LT COUNT
	JMS IGNORE
	SMA CLA		/IS IT DEFINED?
	ISZ NOCOMP	/YES
	TAD LTKNT
	CIA
	DCA OFFKNT	/SAVE (NEG OF) LTKNT
	JMP I (RSETLN	/IGNORE LINE
CCEQ,	JMS IGNORE
	TAD (4000
CCOM,	DCA I OPRAND	/DEFINE IT
	JMP I (RSETLN
CCGT,	TAD LTKNT
	TAD OFFKNT
	SNA CLA
	DCA NOCOMP	/COMPILE AGAIN
	STA
	TAD LTKNT
	SPA
	JMP ER71	/MISMATCHED GT
	DCA LTKNT	/DECREMENT LT COUNT
	TAD NOCOMP
	SNA CLA
	JMP I (RSETLN	/IGNORE LINE
BLNKLN,	TAD Z101
	DCA I (INPLIN+1
	TAD Z101
	DCA I (INPLIN+2
	JMP I (RSETLN
ER71,	JMS I ZERROR
	ERR71
NOCOMP,	0		/1 MEANS DON'T COMPILE
LTKNT,	0		/NUMBER OF NESTED LT'S
REGCOM,	CLA
	TAD NOCOMP
	SNA CLA
	EXIT CCP
	JMP BLNKLN
/NESTED CONDITIONALS NOT WORKING
/REACTIVATE WHEN COUNT RETURNS TO ACTIVATING ONE (NOT 0)
/CHECK IN END OVERLAY FOR HANGING NEST
/CAN'T DEFINE USE UNDEFINED CONDITIONAL IN MIDDLE OF RECORD
OFFKNT,	0		/NEG OF LT COUNT WHEN COMP WENT AWAY

IMAGE,	TAD	ZM15		/CHECK FOR COMMA
	SZA CLA
	JMP ILLDIM
	CLL CML RTL
	AND	TYPE
	SNA CLA
	JMP I (IMGERR
	STL RAL
	AND TYPLFT
	SNA CLA
	JMP I (IMGERR	/REALLY SEP ERROR
	IAC			/TYPE REQUIRED IS ALPHA
	DCA	TYPE
	JMS I	ZEXPR		/GET IMAGE STRING
	TAD	(IMAGOP
	JMS I	ZCODE
	JMP I ZNXTSTM
ILLDIM,	CALL ZERROR
	ERR16
/
	PAGE

PRINT,	0		/PRINTS THE NEXT SOURCE LINE
	SNA CLA
	ISZ	LINKNT
	SKP
	JMS	EJEKT
	TAD I	PRINT
	CALL (CDOIOC
	CLL
	TAD LINKNT
	TAD I (SUPLCT
	DCA LINKNT
	SZL
	JMS EJEKT
	ISZ	PRINT
	JMP I	PRINT
EJEKT,	0		/PERFORM TOP OF FORMS
	TAD (-66	/56 LINES PER PAGE
	DCA LINKNT	/RESET LINE COUNTER
	TAD (214
	CALL LP8PC	/PRINT FORM FEED
	ISZ PGNM	/INCR PAGE NUMBER
	TAD PGNM
	CALL OTOD	/CONVERT TO DECIMAL
	CDF 10
	DCA I (PAGNUM	/INSERT
	CDF 0
	TAD HEAD
	CALL (CDOIOC
	TAD SUBHD
	CALL (CDOIOC
	CALL ZPCRLF
/PAGE # AND DATE?
	EXIT EJEKT	/RETURN
PGNM,	0		/PAGE NUMBER
HEAD,	HEADING-1
SUBHD,	SUBHDG-1

/THIS ROUTINE INSERTS LINE NUMBER IN INPUT BUFFER.
/FORMAT OF INPUT BUFFER
/LOCATION	ORIGINAL USE	NEW USE
/INPLIN		NOT USED	NEW WC
/INPLIN+1	NOT USED	DIG1,DIG2
/INPLIN+2	OLD WC		DIG3,DIG4
/INPLIN+3	OLD LINE#	BLANK,BLANK
/INPLIN+4	START OF TEXT	START OF TEXT
GETLIN,	0		/READ A NEW LINE
	TAD Z7700
	DCA LENGTH	/SET LENGTH
	CLA STL RTL	/READ FILE 0
	CALL RDOIO
	INPLIN+1	/BUFFER ADDR -1
	JMP I (NOEND	/IF EOF, END MISSING
	STA CLL RAL
	TAD I (INPLIN+2	/INCREMENT WC BY 2
	DCA I (INPLIN	/INSERT
	TAD LINENO
	DCA OLDLNO	/SAVE OLD LINE #
	TAD I (INPLIN+3
	DCA LINENO	/SET NEW LINE #
	TAD LINENO
	JMS DECI
	DCA I (INPLIN+1	/INSERT
	TAD LOD		/GET NEXT 2 DIGITS
	DCA I (INPLIN+2	/INSERT
	TAD Z101	/GET 2 BLANKS
	DCA I (INPLIN+3	/INSERT
	TAD (6		/RESET CHAR POINTER
	DCA CHRPTR
	JMP I	GETLIN		/RETURN

DECI,	0
	DCA N1
	DCA TEST
	TAD N1
DECILP,	CLL
	ISZ TEST
	TAD (-144
	SZL
	JMP DECILP
	TAD (144
	CALL OTOD
	DCA LOD
	STA
	TAD TEST
	CALL OTOD
	EXIT DECI
N1,	0
TEST,	0

/ENTER WITH STREF PTING TO ENTRY
COMN,	0
	TAD STREF
	TAD (5
	DCA STREF
	ISZ I STREF
	ISZ STREF
	TAD I STREF
	EXIT COMN
CLEAR,	CLA CLL CML RTL
	AND TYPE
	RAR
	TAD	(CLEARA	
	JMP	CLSTCM
INKR,	DCA RIGHT	/WANT LEFT SIDE
	STL RTL
	DCA TYPE	/WANT DECIMAL
	CALL ZEXPR
	TAD (INCROP
CLSTCM,	CALL ZCODE
	JMP I ZNXTSTM
TRYLIT,	TAD RIGHT
	SZA CLA
	JMS I	(LITERL		/IS OPERAND A LITEAL?
	JMP I	(MSNGOP		/NO, MISSING OPERAND
	TAD	OPRAND		/YES, SAVE PARAMETERS
	DCA	EXTMP1
	TAD	SYMNUM
	DCA	EXTMP2
	CALL (TYPCHK
	JMP I	(WASLIT		/GO DO REST
/
	PAGE

/3400-4400 IS PROC OVERLAY OF BLOCK
BLOCK,	JMS I	ZNAME		/LOOK FOR "BLOCK"
	JMP I (NOBL	/MAYBE STARTS WITH ","
	TAD	NAME1
	TAD	(-4355		/"BL"
	SNA	CLA
	TAD	NAME2
	TAD	(-6044		/"OC"
	SNA	CLA
	TAD	NAME3
	AND	Z7700
	TAD	(-5400		/"K"
	SZA	CLA
	JMP I 	(TRYREC
	JMS I	ZRESET		/RESET CHAR POINTER
	JMS	I ZSKIP		/SKIP OVER FIRST 5
	-5
RECORD,	TAD SYMEND	/SET STREF
	IAC
	DCA I (STREF
	TAD	L7000
	DCA	BLNAME
	JMS I	ZNAME	/GET BLOCK NAME
	JMS I (DUMMY	/NO BLOCK NAME
	JMS I	ZLOOKUP
	TAD I	OPRAND		/CHECK TYPE
	CLL RAL
	SZA	CLA
	JMP	I (ER12		/IF ALREADY DEFINED, BAD
	RAR
	TAD	Z10		/SET TYPE TO "BLOCK"
	DCA I	OPRAND
	CDF 0
	TAD	BLKOPT
	SZA CLA		/WAS LAST BLOCK AN OVERLAY?
	JMP	NOVA	/YES
	TAD	RECSIZ	/NO
	CIA
	DCA	LASIZ
NOVA,	JMS I (FIX
	DCA	BLKOPT
	DCA COPT		/NEEDED FOR CHAIN OVERLAYS
	DCA	RECSIZ
BLKLUP,	JMS I	ZNXTCHR
	JMP	NOOPTN
	TAD	ZM15
	SZA CLA
	JMP	I (ER56
	JMS I	ZNXTCHR
L7000,	NOP
	TAD	(-71		/WE HAD A COMMA, LOOK FOR X
	SNA		/IS IT "X"?
	JMP XOPT	/YES
	TAD (25		/IS IT "C"?
	SNA CLA
	JMP KOPT	/YES
ER45,	JMS I ZERROR
	ERR45		/BAD OPTION
XOPT,	ISZ BLKOPT	/NOTE X OPT
	JMP BLKLUP	/MORE OPTIONS?
KOPT,	ISZ COPT	/NOTE C OPT
	JMP BLKLUP	/MORE OPTIONS?

NOOPTN,	TAD	BLKOPT
	SNA	CLA
	JMP	NOX
	TAD	OLDBLK		/OPTION IS ",X"
	DCA	BYTORG		/DO OVERLAY
	TAD HIOLDBLK
	DCA HIORG
	DCA	COPT	/X IMPLIES NO C
	JMP YOX
NOX,	DCA LASIZ
/YOX,	TAD HIORG
/	RAR
/	CLA
YOX,	STL		/MIGHT WASTE 2 WDS AT HALF-FLD BDRY
	TAD BYTORG
	RAR
	CLL IAC
	SNL CLA
	JMP .+3
	ISZ HIORG
	DCA BYTORG
	CALL (ROUND
	TAD BYTORG
	DCA OLDBLK	/FIX ELUSIVE BUG
	TAD HIORG
	DCA HIOLDBLK
	ISZ	OPRAND		/POINTER TO DIMENSION
	IAC
	CDF 10
	DCA I	OPRAND		/SET IT TO 1
	ISZ	OPRAND
	TAD	OPRAND		/SAVE PTR TO BLK SIZE
	DCA	OBSIZE
	TAD HIORG
	DCA I OPRAND
	ISZ	OPRAND
	TAD	BYTORG
	DCA I 	OPRAND		/STORE BLOCK ORIGIN
	ISZ BYTORG
	ISZ BYTORG
	CDF 0		/CAN'T POSSIBLY BE SKIPPED
	JMP I	ZNXTSTM		/GET BLOCK STUFF
LASIZ,	0		/NEG OF SIZE OF FIRST RECORD IN OVERLAY GROUP

PATCH2,	0
	TAD	RECSIZ
	CLL CML
	TAD	TSIZE
	SNL
	JMP	ER20
	DCA	RECSIZ
	TAD	RECSIZ
	TAD	LASIZ
	SZL SNA CLA	/CHECK FOR OVERFLOW (DOUBLE CHECK)
	EXIT	PATCH2
ER20,	CALL	ZERROR
	ERR20		/OVERLAYOR LARGER THAN OVERLAYEE
HIOLDBLK,0
/
	PAGE

DUMMY,	0		/CREATE DUMMY NAME
	CLA IAC
	DCA NAME1
	CDF 10
	DCA I Z3	/UNDEFINE IT
	CDF 0
	DCA	BLNAME
	EXIT DUMMY	/RETURN

DINIT,	JMS I	ZNXTCHR		/LOOK FOR DECIMAL INIT.
	JMP I	(ENDDAT-1
	TAD	ZM15
	SZA	CLA
	JMP I (ER56	/NOT ","
	TAD	L40
	DCA	SIGN		/40 IS NEGATIVE
	JMS NYPD	/LOOK FOR P OR D
	JMP I (ENDDAT-1	/FOUND P, OR D OR S
	TAD (-6		/IS IT "-"?
	SNA
	JMP	.+5
	TAD	(16-14
	SZA	CLA
	JMS I	ZBACKUP
	DCA SIGN	/0 IS POSITIVE
	JMS I (RLINIT
GDINIT,	JMS I	ZNXTCHR
	JMP	ENDNUM
	TAD (-16
	SNA		/IS IT "-"?
	JMP ENDNU	/YES
	TAD (16		/RESTORE CHAR
	JMS I	NUMBER
	JMP	ENDFLD
	DCA Y5
	TAD Y5
	CALL (RLPUTC
	JMP	GDINIT
ENDNU,	TAD L40		/NEGATIVE
	DCA SIGN
	CALL ZNXTCHR
	JMP ENDNUM

ENDFLD,	CALL ZNXTCHR
L40,	40		/DNO
	TAD ZM15
	SZA CLA
	JMP ER43
	CALL ZBACKUP
ENDNUM,	STA
	TAD I (RLCNT
	DCA I (RLCNT
	TAD Y5
	TAD SIGN
	CALL (RLPUTC
	JMS RLFINI
	JMP DINIT
SIGN,	0

RLFINI,	0
	TAD I (RLCNT
	CIA
	TAD ELSIZE
	SZA CLA
	JMP ER51
	TAD (LBUFR-1
	DCA X0
	STA
	TAD I (RLCNT
	CLL CML CMA RAR
	DCA ELCNT
	TAD I X0
	CALL ZCODE
	ISZ ELCNT
	JMP .-3
	JMS BUPD
	ISZ CRCNT
	EXIT RLFINI
	CALL ZERROR
	ERR50
BUPD,	0
	CLL
	TAD BYTORG
	TAD ELSIZE
	DCA BYTORG
	SZL
	ISZ HIORG
	EXIT BUPD
ER51,	CALL ZERROR
	ERR51

ER46,	CALL ZERROR	/DATA INIT MISSING
	ERR46
ER43,	CALL ZERROR	/BAD DECIMAL CONSTANT
	ERR43
Y5,	0

NYPD,	0
	CALL ZNXTCHR
	JMP ER46
	TAD (-64	/IS IT S?
	SNA
	JMP SOPT	/YES
	TAD Z3		/BUT IS IT P?
	SZA
	JMP NOPP	/NO
	STL RTL		/2
NYGO,	CLL CMA RAL	/-6 OR -2
SOPT,	TAD (12		/4 OR 10 OR 12
	DCA PFLAG
	JMP I NYPD
NOPP,	TAD (61-45
	SNA
	JMP NYGO
NOD,	TAD (35
	ISZ NYPD
	EXIT NYPD	/RETURN WITH IT-10 IN AC
/P - TYPE 4 RECORD
/D - TYPE 10 RECORD
/S - TYPE 12 RECORD
/
	PAGE

NOBL,	JMS I (DUMMY
	CALL ZCOMA
DATASP,	JMS I	ZLOOKUP
	TAD I	OPRAND
	CLL RAL
	CDF 0
	SZA	CLA
	JMP	I (EER12
	JMS	I (DATNUM
	DCA	RCNT
	TAD	RCNT
	CMA
	DCA	CRCNT
	JMS I	ZNXTCHR
	JMP	I (ER52
	TAD (-42
	DCA	TYPE
	CALL (DATNUM
	DCA ELSIZE
	TAD	ELSIZE
	CIA CLL
	DCA	CELSIZ
ADUP,	TAD	RCNT
	SZL
	JMP I (ER15	/WOW IS BIG!
	ISZ	CELSIZ
	JMP ADUP
	DCA	TSIZE
	TAD ELSIZE
	AND D7000
	SZA CLA
	JMP I (ER15	/IS BIG
	CALL	(PATCH2
	CLA IAC
	TAD	RECSIZ
	AND	BLNAME
	SZA CLA
	JMP I	(ER20	/RECORD TOO BIG
	DCA PFLAG	/ZERO P FLAG
	CALL (PATCH	/SAVE INFO FOR ,P
	TAD BLKOPT
	SZA CLA
	JMP NOCLR
	TAD TSIZE
	DCA SIZE
	TAD	TYPE	/0 OR 3
	TAD	COPT	/0 OR 1
	SNA		/BOTH 0 MEANS LET RSYS DO IT
	JMP	NOCLR
	TAD	PCLRTB
	DCA	XCLEAR
	TAD I	XCLEAR	/GET PROPER CLEAR CODE
	DCA	XCLEAR
	CALL ZCDUMP
XCLEAR,	DCLEAR
	JMS I (CORG	/OUTPUT SIZE-ORIGIN
	TAD SIZE
	CIA
	CALL ZCODE	/NEED 12-BIT SIZE HERE (NEW)
NOCLR,	TAD ELSIZE
	DCA SIZE
	TAD TYPE
	SZA CLA		/IS TYPE "A"?
	JMP I (DINIT	/NO
AINIT,	JMS I	ZNXTCHR		/LOOK FOR ALPHA INITIALIZATION
	JMP	I (ENDDAT
	TAD	ZM15
	SZA	CLA
	JMP	I (ER14
	CALL (NYPD
	JMP I (ENDDAT
	SZA CLA
	JMP I (ER47
	JMS RLINIT
GETAI,	JMS I	(GETCHR		/GET NEXT CHAR, KEEP BLANKS
	JMP I (ER47
	TAD	ZM10		/LOOK FOR CLOSING '
	SNA
	JMP	FINAI
	TAD	Z10
	JMS RLPUTC
	JMP	GETAI
FINAI,	CALL (RLFINI
	JMP	AINIT

RLINIT,	0
	TAD TYPE
	SNA CLA
	JMP SRLINI
	TAD BLKOPT
	TAD TSIZE
	CIA
	TAD ELSIZE
	SNA CLA
	DCA I (CODBUF
/	DELETE PREVIOUS CODE ENTRY!
SRLINI,	CALL ZCDUMP
	DATAIN
	CALL (CORG
	DCA RLCNT
	JMP I RLINIT
RLPUTC,	0
	CALL KPUTC
	LBUFR-1
RLCNT,	0
	ISZ RLCNT
D7000,	7000
	EXIT RLPUTC
CLRTAB,	ACLEAR		/CLEAR ALPHA   (A WITH ,C)
PCLRTB,	CLRTAB-1	/HOLE IN TABLE
	DCLRCH		/CLEAR DECIMAL (D WITHOUT ,C)
	DCLEAR		/CLEAR DECIMAL (D WITH ,C)
/
	PAGE

	IAC
ENDDAT,	IAC
	CDF 10
	TAD I OPRAND
	DCA I	OPRAND
	ISZ	OPRAND
	TAD	RCNT
	DCA I	OPRAND
	TAD SAVHI
	DCA HIORG
	ISZ	OPRAND
	TAD	ELSIZE
	CLL RTL
	RAL
	TAD HIORG
	DCA I	OPRAND
	ISZ	OPRAND
	TAD SAVBYT	/THIS IS BETTER THAN ORGBYT
	DCA BYTORG
	TAD	BYTORG
	DCA I	OPRAND
	CDF 0
	TAD TSIZE
	DCA ELSIZE	/BUPD WANTS ELSIZE
	CALL (BUPD
	TAD PFLAG	/P?
	SNA
	JMP I	ZNXTSTM
	DCA TYPE4
	CALL ZCDUMP	/CREATE TYPE 4 RECORD
TYPE4,	COMMAP
	TAD NAME1	/OUTPUT NAME
	CALL ZCODE
	TAD NAME2
	CALL ZCODE
	TAD NAME3
	CALL ZCODE
	TAD SV1
	CALL ZCODE	/OUTPUT SIZE-ORIGIN
	TAD SV2
	CALL ZCODE
	JMP I ZNXTSTM	/NEXT STMNT
/NOTE: ,P CAN FOLLOW A DEFAULT INITIAL VALUE
SAVHI,	0
SAVBYT,	0
SV1,	0
SV2,	0

DIGIT,	0
NMBR,	0
DATNUM,	0
	TAD M4
	DCA DTCNT
NUMCNV,	DCA	NMBR
	JMS I	ZNXTCHR		/LOOK FOR FIRST DIGIT
	JMP NONUM		/IF NO CHARS, INCOMPLETE	JMS I	NUMBER		/TEST FOR DIGIT
	JMP	NONUM		/IN THIS CASE, BACK 1
	AND	L17		/STRIP OFF LEADING BITS
	TAD	M1
	DCA	DIGIT		/SAVE THIS DIGIT
	ISZ DTCNT
	JMP .+3
ER15,	CALL ZERROR	/ENTITY TOO LARGE
	ERR15
	TAD	NMBR		/MULTIPLY OLD NUMBER BY 10
	CLL RTL
	TAD	NMBR
	CLL RAL
	TAD	DIGIT		/NOW ADD NEW DIGIT
	JMP	NUMCNV		/GO STORE THE UPDATED NUMBER
NONUM,	CLA STL RTL	/2
	RAL		/4
	TAD	DTCNT
	SNA CLA		/IF NUMBER WASN'T THERE
	IAC		/MAKE IT 1
	TAD	NMBR
	SNA		/IF NUMBER WAS THERE AND WAS 0,
	JMP	ER15	/ITS AN ERROR
	JMP I	DATNUM	/RETURN WITH NUMBER IN AC

DTCNT,			/NO. MUST BE 1, 2, OR 3 DIGS.
FIX,	0
	TAD OLDBLK
	CIA
	TAD BYTORG
	CLL RAL
	CLL RAL
	CLL RAL
	TAD I (HIOLDBLK
	CDF 10
	DCA I OBSIZE
	CDF 0
	TAD BLKOPT
	SNA CLA		/WAS LAST BLOCK AN OVERLAY?
	JMP NOOV	/NO
	TAD REALBYT	/YES
	DCA BYTORG
	TAD REALHI
	DCA HIORG
NOOV,	TAD BYTORG
	DCA REALBYT
	TAD HIORG
	DCA REALHI
	EXIT FIX	/RETURN
REALBYT,0		/NEXT REAL BYTE LOC
REALHI,	0
PATCH,	0
	CALL	(ROOM	/SEE IF ROOM IN FIELD
	TAD TYPE
	SZA
	TAD (-3
	SZA CLA
	JMP ER52	/IT'S NOT A OR D
	TAD ELSIZE
	CLL RTL
	RAL
	TAD HIORG
	DCA SV1
	TAD BYTORG
	DCA SV2
	TAD BYTORG
	DCA SAVBYT
	TAD	HIORG
	DCA	SAVHI
	EXIT PATCH
ER52,	CALL ZERROR
	ERR52		/NOT A OR D
/
	PAGE

	*4400
SWITCH,	0
/	ARG IN AC
	DCA TM2
	TAD I (LISTSW
	RTR
	RTR
	RTR
	AND L77
	DCA TM1
	TAD TM1
	JMS I	(NUMBUR
	JMP N2		/IT'S A DIGIT
	TAD TM1		/IT'S NOT
	JMS GOPT
	TAD TM2		/NO
	JMS I	(NUMBUR	/DIGIT?
	EXIT SWITCH	/YES SIR
N2,	TAD TM2		/NO SIR
	JMS GOPT
/	ISZ I (LISTSW	/"??"?
/	EXIT	SWITCH
/	DCA I (QPRNT	/YES
	EXIT SWITCH

DEIGHT,	0
	TAD I SYSDAT	/GET DATE
	DCA DATEM	/SAVE IT
	TAD DATEM
	CLL RTL
	RTL
	RAL
	AND L17
	DCA	TM1		/SAVE MONTH FOR LATER
	TAD	TM1
	CLL RAL
	TAD (MONLST-3
	DCA X2
	TAD I X2
	CDF 10
	DCA I (MONTH1
	CDF 0
	TAD I X2
	CDF 10
	DCA I (MONTH2
	TAD DATEM
	AND L7
	DCA	TM2		/SAVE YEAR FOR LATER
	TAD	TM2
	CLL RTL
	RTL
	RTL
	TAD (2301
	DCA I (YEAR
	CDF 0
	TAD DATEM
	CLL RTR
	RAR
	AND (37
	DCA	DATEM		/SAVE DAY FOR LATER
	TAD	DATEM
	CALL OTOD
	CDF 10
	DCA I (DAY
/FIGURE OUT DAY OF WEEK
	CDF 0
	TAD	TM2
	CLL RTR
	SNL SMA			/CHECK FOR A LEAP YEAR
	JMP	LEAP		/WE GOT ONE!
	ISZ I	(JAN		/IF NOT, FUDGE UP THE CONSTANTS
	ISZ I	(FEB
LEAP,	AND	(37
	TAD	TM2
	TAD	(132		/72 + 72/4 IN DISGUISE
	TAD	DATEM
	DCA	DATEM
	TAD	TM1
	JMS I	(PART2		/GO TO NEXT KLUDGE AREA
	EXIT DEIGHT	/THAT'S A SWITCH
	DATEM=NAME3
	TM1=NAME1
	TM2=NAME2
/
GOPT,	0
	TAD M4
	SNA
	JMP GO		/  /D IMPLIES /G
	TAD (-3
	SNA
	JMP GO
	TAD ZM15	/T
	SZA
	JMP TSTOSW
GO,	TAD (GOLOAD-1
	DCA GOPTR
	JMP	SETNLS
TSTOSW,	TAD	(5
	SZA
	JMP	TSTNSW
	TAD	(7200
	DCA I	(OPTMZ1
	TAD	(7200
	DCA I	(OPTMZ2	/DON'T OUTPUT LINE NUMBERS
	ISZ I	(OPTMZ3
TSTNSW,	IAC
	SZA CLA
	JMP I GOPT
SETNLS,	STL CLA RAR	/LSTSW=4000 MEANS NOLIST
	DCA LSTSW
	JMP I GOPT
/
	PAGE

CODBUF,	-1		/KLUDGE TO CDUMP
EMSG,	4663	/ER
	6360	/RO
	6364	/RS
	0101	/
NUMBUR,	0		/SKIP IF NOT STRIPPED DIGIT & STUFF
	TAD (-72
	CLL
	TAD (12
	SNL
	JMP YECCH	/BAD #
		/SW ROUTINE TO FIND LOG UNIT# ASSOC WITH DT #
	TAD SYSHND
	CIA
	DCA MATCH
	TAD (UTBASE-1
	DCA X0
	TAD (-20
	DCA COUNT
	DCA LOGICAL
SLOOP,	TAD I X0
	TAD MATCH
	SNA CLA
	JMP GOTCHA
	ISZ LOGICAL
	CLA STL RTL
	TAD X0
	DCA X0
	ISZ COUNT
	JMP SLOOP
	HLT		/DTA NOT ASSIGNED
GOTCHA,	TAD LOGICAL
	DCA BUNIT	/SOMEONE'S BEEN SLEEPING IN MY UNIT AND HERE IT IS
	EXIT NUMBUR
YECCH,	CLA
	ISZ NUMBUR	/BUMP
	EXIT	NUMBUR
LOGICAL,0
COUNT,	0
MATCH,	0
/
PART2,	0		/2ND PART OF KLUDGE TO GET DAY OF WEEK
	TAD	(JAN-1
	DCA	TM1
	TAD I	TM1		/GET MAGIC # FROM TABLE
	TAD	DATEM
DIV7,	CLL
	TAD	(-7
	SZL
	JMP	DIV7
	TAD	L7
	CLL RAL
	TAD	(WEEKDY-1
	DCA	GETWKP
	AC7776=	CLA CLL CMA RAL
	AC7776
	JMS I	MOVE
	CDF 10
GETWKP,	0
	WKDAY-1
	JMP I	PART2
/
WEEKDY,	6442	/SA
	6501	/T
	6466	/SU
	5701	/N
	5660	/MO
	5701	/N
	6566	/TU
	4601	/E
	7046	/WE
	4501	/D
	6551	/TH
	6663	/UR
	4763	/FR
	5201	/I

MONLST,	1653;4257;1647
	4643;1656;4263
	1642;6163;1656
	4272;1653;6657
	1653;6655;1642
	6650;1664;4661
	1660;4465;1657
	6067;1645;4644
/
/A MAGICAL TABLE
JAN,	0
FEB,	3
	4;0;2;5;0;3;6;1;4;6
/
	PAGE

CREATE,	TAD (SKP
	DCA I (200
	STL CLA RAR
	JMS I 77	/WRITE PROC OVERLAY
	4410		/WRITE 4 PAGES FROM FIELD 1
	3400		/LOCATION 3400
	3		/HUNK
	TAD (5000
	JMS I 77	/WRITE END OVERLAY
	4510		/WRITE 5 PAGES FROM FIELD 1
	1400		/LOCATION 1400
	3		/HUNK
	JMS I 77	/WRITE CORE CONTROL BLOCK
	4200		/WRITE 2 PAGES FROM FIELD 0
	CCB		/LOCATION
	6		/INTO HUNK 6
	TAD (400
	JMS I 77	/WRITE ERROR MESSAGES
	4410		/WRITE 4 PAGES FROM FIELD 1
	6400		/LOCATION 6400 (FUDGE)
	6		/INTO HUNK 6
	TAD (1400
	JMS I 77	/WRITE COMPILER
	6400		/WRITE 24 PAGES FROM FIELD 0
	0		/LOCATION 0
	6		/INTO HUNK 6
	IOF
	JMP I .+1
	7605
CCB,	-2		/2 ENTRIES
	6203		/SA FIELD 0
	200		/SA=00200
	00		/JUNK
	7000		/START AT 17000
	410		/4 PAGES
	0		/START AT 0
	2400		/24 PAGES
/
	PAGE

	FIELD 1		/OVERLAYS GO IN FIELD 1 FOR ASSEMBLY PURPOSES
	*1400
LA,	5542;4346;5501
UN,	6657;4546;4701
RE,	6346;4460;6345
/TYPE	/	/	/KLUDGE
/0	0	14	00003
/1	2	2	10000
/2	4	4	00001
/4	10	10	00002
/10	20	20	00004
/20	40	40	00010
/2000	4000	14	00003
/4000	0	16	10003

SOT,	0		/2 OR 3 PLACE PRINT ROUTINE
	CALL (DECI
	CDF 10
	AND L77
	DCA SOTM
	TAD SOTM
	TAD (-21
	SZA
	TAD (20
	TAD Z101
	DCA I X2	/INSERT IN PRINT BUFFER
	TAD LOD
	DCA I X2	/LOW ORDER PART TOO
	EXIT SOT
SOTM,	0
GOLOAD,	DCA LINKNT
	CALL ZPRINT
	IMPRES-1
	TAD (4400
	CALL SYSHND
Q200,	200
	4400
	1
	TAD (6000
	CALL SYSHND	/LOAD CORE CONTROL BLOCK KLUDGE
	200
	4000
	1
	TAD (6400
	CALL SYSHND
	600
Q0,	0
	1
	JMP I Q200

PTCH3,	0
	CALL (BLPAD
	TAD (4265	/"AT"
	DCA I X2
	TAD (155	/" L"
	DCA I X2
	TAD (5257	/"IN"
	DCA I X2
	TAD (4601	/"E "
	DCA I X2
	ISZ X0
	ISZ X0
	TAD I X0
	CDF 0
	CALL (DECI
	CDF 10
	DCA I X2
	TAD LOD
	DCA I X2
	DCA I X2
	EXIT PTCH3
ENDST,	TAD I (LTKNT
	SZA CLA
	JMP CCPFTL
	TAD NSYMS
	IAC
	DCA I (TYPE3+2
	TAD I (PROCSYM
	IAC
	DCA I (TYPE3+3
	TAD	L100
	DCA I	(SBT
	STL CLA RAR
	DCA LENGTH
	TAD ERKNT
	SZA CLA
	JMP LEV
	CLA IAC
	CALL RDOIO
	TYPE3-1
L100,	100
LEV,	TAD (STITLE-1	/CHANGE HEADING
	DCA I (SUBHD
	CDF 10
	TAD	(-6
	JMS I	MOVE
	CDF 10		/CHANGE THE HEADER LINE
	HEAD2-1		/TO READ "STORAGE MAP LISTING"
	CMPLTN-1	/INSTEAD OF "COMPILATION LISTING"
	STA
	DCA LINKNT
	TAD NSYMS
	CIA
	CLL RAL
	CDF 10
	DCA I Q0
	DCA X1
	TAD (3400
	DCA R3
	CDF 0
	JMP I (ENDST2
CCPFTL,	JMS I (FATAL
	ERR71
/
	PAGE

	R3=COPT
	PDTEM=BLNAME
ENDST2,	TAD I (PROCSYM
	CLL RAL
	TAD I (PROCSYM
	TAD (3377
	DCA I (SHI
	CDF 10
	TAD (6		/START AT ENTRY 1!!!!
	DCA X0
	TAD (-31
	DCA I L7001	/SET WC
	CALL (ROUND	/ROUND UP TO EVEN BYTE
	TAD HIORG	/DOUBLE PREC DIVIDE BY 2
	CLL RAR
	DCA HIORG
	TAD BYTORG
	RAR
	DCA BYTORG
L7001,	IAC
	DCA NSKNT
	TAD (ENDLUP
	CDF 0
	DCA I (ERET
/X0 PTS TO SYMBOL TABLE
/X1 PTS TO COMPACTED SYMBOL TABLE
/X2 PTS TO PRINT BUFFER 
/X4 PTS TO TYPE NAME
/R3 POINTS TO DDT SYMBOL TABLE

ENDLUP,	CDF 10
	TAD L7001
	DCA X2
	TAD (1717
	DCA UNTEM
	TAD I X0
	SNA
	JMP I (ISZN
	SPA
	DCA UNTEM
	CLA
	TAD NSKNT
	JMS I	BSWPTR
	CALL (BFOO
	TAD NSKNT
	CALL (BFOO
	CALL (BLPAD
	ISZ NSKNT
	TAD UNTEM
	JMS PUTDDT
	DCA EFL
	TAD I X0
	JMS PUTDDT
	TAD I X0
	JMS PUTDDT
	JMS I (BLPAD
	TAD I X0	/GET TYPE
	CLL RAL
	DCA NTEM
	TAD NTEM
	SMA SZA
	JMP UNUN
	DCA EFL		/UNRESOLVED LABEL REFERENCE
	RTL
	TAD (14		/PT TO "UNDEF"
UNUN,	CLL RTR		/FUDGE
	CML
	SZA SNL
	STA
	TAD (TYPTBL
	DCA UNTEM
	CDF 0
	TAD I UNTEM
	DCA X4
	CLL STA RTL	/-3
	DCA ENDKNT
	CDF 0
	TAD I X4
	CDF 10
	DCA I X2	/PRINT TYPE
	ISZ ENDKNT
	JMP .-5
	TAD NTEM
	SNA CLA
	DCA I X2
	TAD EFL
	SNA CLA
	JMP I (AAAAAA
	JMS I (ABORT
	CALL (PTCH3
	JMP I (NOOF
	JMP I (AAAAAA
UNTEM,	0
PUTDDT,	0
	SNA			/CONVERT 0'S TO SPACES
	TAD	Z101
	DCA PDTEM
	TAD	PDTEM
	AND	L77
	SNA CLA			/ZERO IN RIGHT HALFWORD?
	ISZ	PDTEM		/CONVERT IT TO A SPACE
	TAD R3
	TAD (-4775
	SMA CLA
	JMP DDEND	/STOP AT 4774
	ISZ R3
	CDF 0
	TAD PDTEM
	DCA I R3
EXITDD,	TAD PDTEM
	CDF 10
	DCA I	X2
	JMP I PUTDDT
DDEND,	TAD (4775
	DCA I (SHI
	JMP EXITDD
/
	PAGE

AAAAAA,	JMS I (BLPAD
	TAD I X0	/GET DIMENSION
	CDF 0
	CALL (SOT	/CONVERT TO DECIMAL
	JMS I (BLPAD
	TAD I X0	/GET SIZE, H.O. ORIGIN
	DCA SIZ
	TAD I X0
	DCA ORI		/GET L.O. ORIGIN
	TAD NTEM
	TAD ZM10
	SZA CLA
	JMP NOOF
	CLL
	TAD ORI
	TAD BYTORG
	DCA ORI
	RAL		/FIXED
	TAD HIORG
	TAD SIZ
	DCA SIZ
NOOF,	TAD SIZ
	DCA I X1
	TAD ORI
	DCA I X1	/COMPACT
	TAD SIZ
	CLL RAR
	CLL RAR
	CLL RAR
	CDF 0
	SNA
	TAD (1000
	CALL (SOT	/PRINT SIZE
	JMS I (BLPAD
	TAD SIZ
	AND L7
	TAD (121
	DCA I X2
	TAD ORI
	JMS I	BSWPTR
	JMS BFOO
	TAD ORI
	JMS BFOO
	CDF 0
	TAD EFL
	SZA CLA
	JMP ZPR
	TAD LSTSW
	SZA CLA
	JMP I (ENDLUP
ZPR,	CALL ZPRINT
	7000
	JMP I (ENDLUP

BFOO,	0
	DCA FOOT
	TAD FOOT
	AND L7
	DCA FOT
	TAD FOOT
	RTL
	RAL
	AND (700
	TAD FOT
	TAD (2121
	DCA I X2
	EXIT BFOO
FOOT,	0
	NTEM=Z3

ISZN,	CDF 0
	TAD ERKNT
	SZA
	CALL OTOD
	SNA
	TAD (5760
	DCA I (ERTXT+1	/INSERT NO. OF ERRORS IN MSG
	STA
	TAD ERKNT
	SZA CLA
	JMP .+3
	TAD Z101	/CORRECT ENGLISH GRAMMAR
	DCA I (S	/BLANK OUT "S"
	CLL
	TAD LOCCTR
	TAD BYTORG
	SZL
	ISZ HILOC
	CLL
	TAD NSYMS
	TAD NSYMS
	DCA NAME1
	SNL
	STA
	DCA NAME2
	RAL
	TAD HILOC
	TAD HIORG
	CLL RTL
	RAL
	DCA CORE
	JMP I (PREEND

FOT,
ABORT,	0
	TAD (1313	/"**"
	DCA I X2
	TAD ERKNT
	SZA CLA
	JMP OK
	CDF 0
	CLA IAC
	CALL (SFINI
	CDF 10
OK,	ISZ ERKNT
	EXIT ABORT
CP,	4444;6100
/
	PAGE

PREEND,	TAD LSTSW
	SZA CLA
	JMP EPI2
	STA
	TAD NSKNT
	CALL (DECI
	DCA STLENT+1
	TAD LOD
	DCA STLENT+2
	CALL ZPCRLF
	CALL ZPRINT
	STLENT-1
	TAD CORE
	TAD Z10
	CLL RAR
	CALL OTOD
	DCA I (CORNO
	TAD	NAME1
	CMA
	CALL	(DECI	/CONVERT FREE CORE TO DECIMAL
	DCA I	(CORLFT
	TAD	LOD
	DCA I	(CORLFT+1	/STORE IN MESSAGE
	TAD	LOCCTR
	TAD	BYTORG	/GET LAST LOC USED IN LAST FIELD
	CLL		/WATCH FOR CARRIES FROM HERE ON
	TAD	K377
	AND	L7400	/ROUND UP TO BLOCK BDY
	TAD	NSYMS
	TAD	NSYMS	/ADD IN SYMBOL TABLE LENGTH
	TAD	K377
	AND	L7400	/ROUND UP AGAIN
	SZL		/IF THE TOTAL OVERFLOWED,
	ISZ	NAME2	/AND THE UNROUNDED TOTAL DIDN'T,
	SKP
	CLA		/THEN THERE IS NO ROOM FOR BUFFERS
	CIA
	CLL RAL
	RTL
	RTL		/GET BUFFER COUNT
	CALL	OTOD
	DCA I	(BFSLFT
	CALL ZPCRLF
	CALL ZPRINT
	ERTXT-1
	TAD I	(OPTMZ3
	SNA CLA		/ /O?
	JMP	EPI2
	CALL	ZPCRLF
	CALL	ZPRINT
	OPTMSG-1
EPI2,	TAD ERKNT
	SZA CLA
	JMP FORMF
	TAD LSTSW
	SZA CLA
	JMP EPI
FORMF,	STA
	CALL	ZPCRLF	/PUT OUT A FORM FEED
EPI,	TAD TTOCHR
	DCA LP8PC
	TAD ERKNT
	SZA CLA
	JMP LEAVE
	TAD (11
	CALL RDOIO
	-1
	214
	DCA I SHI	/0 END OF DDT SYMBOL TABLE
	TAD SHI
	TAD KM3400
	CIA
	DCA I K3400
	CLA IAC
	CALL RDOIO
	3400-1
	NOP
	CLA IAC
	CALL (SFINI
	JMP I (EPI1
SHI,	0
OPTMSG,	-10
	4460;5661;5255
	4645;0170;5265
	5101;2060
STLENT,	-6
	101;101;164
	7256;4360;5564
TYPE3,	-3;SYMTAB;0;0
	CP-1
TYPTBL,	AL-1
	DE-1
	LA-1
	UN-1
	RE-1
K3400,	3400
KM3400,	-3400
K377,	377
	MD-1	/MUST BE AT TYPTBL+10
LEAVE,	DCA LINKNT
	DCA I (ZOTZ
	DCA I CTRLO
	CALL ZPRINT
	ERTXT-1
	JMP I L7600
/
	PAGE

EPI1,	TAD NSYMS
	IAC
	CLL RAL
	TAD BOUTLN
	DCA BOUTLN
	SZL
	ISZ HIBOUT
	TAD I (3400
	CIA
	IAC CLL
	TAD BOUTLN
	DCA BOUTLN
	SZL
	ISZ HIBOUT
	TAD BUNIT
	SNA CLA		/COPY TEMP FILE?
	JMP BACKIN	/NO
	TAD	HIBOUT
	CMA
HBCNT,	DCA	.	/SUAVELY USES A TEMPORARY
	SKP
	JMS	COPY	/COPY A HUNK
	ISZ	HBCNT	/KEEP GOING?
	JMP	.-2	/YES
	TAD	BOUTLN	/GET LOW ORDER OUTPUT WORD COUNT
	AND	L7400
	SZA		/WATCH OUT IF ITS ZERO
	JMS	COPY	/IF NOT, COPY A TRUNCATED HUNK

BACKIN,	CALL SYSHND	/GO BACK AND INSERT
	0200		/READ OUTPUT
	0200		/INTO 200
	4		/THE HUNK
	TAD	(201
	DCA	X1
	TAD PROCNM
	DCA I X1	/INSERT PROC #
	CLL STA
	TAD BYTORG
	DCA BYTORG	/SUBTRACT 1
	SNL
	STA
	TAD HIORG
	CLL RTL
	RAL
	DCA I X1
	TAD BYTORG
	DCA I X1
	TAD BOUTLN
	AND L7400
	CLL RAL
	TAD HIBOUT
	RTL
	RTL
	DCA I X1	/INSERT OUTPUT SIZE
	TAD CORE
	DCA I X1
	CALL SYSHND	/REWRITE
	4200
	200
	4		/LONG LIVE THE HUNK!
	JMP I GOPTR
COPY,	0		/TAPE COPY ROUTINE
	CLL CML RAR
	TAD	Z10	/SET UP A WRITE ONTO THE SYSTEM TAPE
	DCA	IOCTW2
	TAD	IOCTW2
	AND	(3670	/KEEP THE COUNT AND THE FIELD
	TAD	BUNIT	/TURN IT INTO A READ FROM BUNIT
	DCA	IOCTW1
	CALL	SYSHND
IOCTW1,	0
	0
	4		/BINARY WORK AREA
	ISZ	.-1	/BUMP IT
	CALL	SYSHND
IOCTW2,	0
	0
	4		/BINARY WORK AREA ON SYS
	ISZ	.-1	/BUMP THAT TOO
	JMP I	COPY	/RETURN
	CORE=ZM12

ERTXT,	-43
	101;146;6363
	6063;6401;4546
	6546;4465;4645
	1701;101;101
	154;144;6063
	4601;6346;6266
	5263;4645;174
	2121;2121;147
	6346;4601;5560
	4464;0136
BFSLFT,	101;143;6647
	4746;6364;7600
	CORNO=ERTXT+14
	CORLFT=ERTXT+26
	S=ERTXT+5
	ZOTZ=ERTXT+6
MD,	6346;4546;4700
AL,	4255;6151;4201
DE,	4546;4456;4255
/
	PAGE

	*3400
GOTREL,	JMS I	ZNXTCHR		/LOOK FOR ANOTHER .
G537,	537
	TAD	(-17
	SZA CLA
	JMP ER25
	JMS I	ZEXPR	/NOW GET EXPR
	CALL ZRPAREN	/LOOK FOR )
	TAD	IFCCOD
	CLL CMA RTL	/MULTIPLY C.C. BY 20
	RTL
	TAD	G537	/ADD OFFSET TO MAKE MAGIC SKIP
	TAD	TYPE
	CALL ZCODE
	TAD CHRPTR
	DCA SAVE
	ISZ I (IFLG	/DON'T WANT COMPUTED GOTOS
	TAD (CML2-CMLIST	/FAKE OUT CMLIST
	JMP CMCHK
RELLST,	-5065	/GT - SZL SNA CLA
	-5546	/LE - SNL SZA CLA
	-5746	/NE - SNA CLA
	-4662	/EQ - SZA CLA
	-5046	/GE - SZL CLA
	-5565	/LT - SNL CLA

FORMS,	JMS	CKLET
	64		/CHECK FOR "S"
	CALL ZLPAREN	/GET LEFT PAREN
	CALL (IARG
	CALL ZCOMA
	CALL ZEXPR	/GET CHANNEL
	CALL ZRPAREN	/GET RIGHT PAREN
	TAD (FORMOP	/YES
	JMP CMNCOD
XMIT,	CALL ZLPAREN	/GET LEFT PAREN
	CALL (XARG
	TAD	(XMITOP		/OUTPUT XMIT CODE
	JMS I	ZCODE
	CALL ZNXTCHR	/LOOK FOR ","
	JMP I (ER56	/OH WELL
	TAD ZM15	/IS IT?
	SNA
	JMP GETEOF	/IT'S A COMMA
	TAD Z3
	SZA CLA		/IS IT A ")"?
	JMP I (ER56	/NO
	CALL ZBACKUP
	JMP GOTEOF

GETEOF,	CALL (GETLBL	/LOOK FOR LABEL
	TAD SYMNUM	/SET UP BRANCH TO IT
GOTEOF,	TAD (BRANCH	/OUTPUT BRANCH CODE
	JMP	I (CCLOSE
RETURN,	JMS RNSUB
	STA		/*** RETURN MUST BE STOP-1! ***
STOP,	TAD	(STOPOP
	JMP CMNCOD
IFCCOD,
RNSUB,	0		/CAN BE CALLED WITH AC .NE. 0
	TAD NAME3
	TAD (-6357
	SZA CLA
	JMP I ZNMLS
	CALL ZSKIP
	-2
	EXIT RNSUB

TREPSE,	CALL	ZCODE		/"TRAP" WITH A YIDISCHE ACCENT
KALL,	JMS I	(GETLBL		/GET THE LABEL
/	TAD	(BRASUB		/AND THE OPCODE
SENDIT,	STL RAR
	TAD	SYMNUM
CMNCOD,	JMS I	ZCODE		/AND SEND IT OUT
	JMP I	ZNXTSTM
TRAP,	STA
	JMS RNSUB
	JMS	CKLET
	63
	CALL (GETLBL
	STA CLL RAL
	DCA I	(ONERCT
	STL RAR		/4000 HERE, 6000 LATER
	JMP SENDIT
CKLET,	0		/ROUTINE TO VERIFY A CHARACTER
	CALL	ZNXTCHR
	JMP I	ZNMLS
	CIA
	TAD I	CKLET
	SZA CLA
	JMP I	ZNMLS
	JMP I	CKLET

COMAND,	TAD SAVE
	DCA CHRPTR
CMCHK,	TAD	(CMLIST-2	/(NEE CMCHTKA) COMMAND LIST POINTER
	DCA	X0
	JMS I	ZNAME		/GET THE COMMAND
	JMP I ZNXTSTM
INK1,	ISZ X0
	TAD I	X0		/CHECK AGAINST LIST
	SNA
	JMP	I ZNMLS		/NO KNOWN STMT
	CIA
	TAD	NAME1
	SNA CLA
	TAD NAME2
	CIA
	TAD I X0
	SZA CLA
	JMP	INK1		/NOT THIS COM.
	TAD I	X0
	DCA	EXTMP1		/GET COMMAND HANDLER ADR
	TAD SAVE
	DCA CHRPTR
	CALL ZSKIP
	-4
	JMP I	EXTMP1		/GO THERE
ER25,	CALL ZERROR	/RELATIONAL IS N.G.
	ERR25
/
	PAGE

IARG,	0
	TAD (2		/AC MIGHT BE NON-ZERO
	DCA TYPE	/SET TYPE TO DEC (ALPHA)
	IAC
	DCA RIGHT
	CALL ZEXPR
	EXIT IARG

XARG,	0		/PARSE EXPR,BLKNAME
	JMS IARG
	CALL ZCOMA
	TAD Z10
	DCA TYPE
	CALL ZEXPR
	DCA TYPE
	EXIT XARG	/RETURN
WRYTE,	JMS I	(CKLET
	46
	IAC
WREAD,	TAD (READOP	/GET READ OR WRITE OP
	DCA WROPZ
	CALL ZLPAREN	/GET LEFT PAREN
	JMS XARG	/GET ARGS 1 AND 2
	CALL ZCOMA	/GET COMMA
	CALL ZEXPR	/GET ARG 3
	TAD WROPZ
CCLOSE,	CALL ZCODE	/OUTPUT
	CALL ZRPAREN	/GET RIGHT PAREN
	JMP I ZNXTSTM	/CONTINUE WITH NEXT STMNT

LPAREN,	0		/GET LEFT PARENTHESIS
	CALL ZNXTCHR
	JMP ER66	/BAD IF NOTHING
	TAD ZM11
	SNA CLA		/IS IT "("?
	EXIT LPAREN	/YES, RETURN
ER66,	CALL ZERROR	/NO
	ERR66		/MISSING LEFT PAREN
RPAREN,	0		/GET RIGHT PARENTHESIS
	CALL ZNXTCHR	/NOTHING IS BAD
	JMP ER67
	TAD ZM12
	SNA CLA		/IS IT ")"?
	EXIT RPAREN	/YES, RETURN
ER67,	CALL ZERROR	/NO, ERROR
	ERR67		/MISSING RIGHT PAREN
NOTRACE,TAD (6357-4244
	CALL (RNSUB
	TAD	Z10
	IFNZRO HERENT-HERETR-10 <???> /ERROR, CATASTROPHIC
TRACE,	TAD (HERETR
	CALL ZCODE
	JMS I	(CKLET
	46
	JMP I ZNXTSTM
WROPZ,	0

INIT,	CALL ZLPAREN	/GET LEFT PAREN
	JMS IARG
FORV,	CALL ZCOMA	/LOOK FOR COMMA
	CALL ZNAME	/GET DEVICE NAME
	JMP ER64	/NOTHING THERE.
	TAD (DEVTBL-1
	DCA NAME2		/SET UP FOR TBL SRCH
DEVLUP,	ISZ NAME2		/PASS OVER DEVICE CODE
	CDF 10
	TAD I NAME2	/GET TABLE ENTRY
	ISZ	NAME2
	SNA		/END OF TABLE?
	JMP ER64	/YES, DEVICE NOT FOUND
	TAD	NAME1
	AND	Z7700	/HIGH - ORDER CHAR ONLY
	SZA CLA		/IS THIS IT?
	JMP DEVLUP	/NO, KEEP LOOKING
	TAD I NAME2	/YES, GET CODE #
	CDF 0
	SNA		/ WAS IT F OR V?
	JMP	FORV	/YES - TRY AGAIN
	DCA WROPZ	/SAVE DEVICE CODE
	TAD WROPZ
	RAL
	SNL SMA CLA	/IS IT FILE STRUCTURED?
	JMP INIEND	/NO
	CALL ZCOMA	/LOOK FOR COMMA
	STA		/WANT ALPHA
	JMS IARG
	CALL (UNITRY
INIEND,	TAD (INITOP
	CALL ZCODE	/OUTPUT INIT OP
	TAD WROPZ
	JMP CCLOSE
ER64,	CALL ZERROR	/MISSING OR BAD DEVICE
	ERR64

DISPLAY,TAD (6357-5542
	CALL (RNSUB
	JMS I	(CKLET
	72
	CALL ZLPAREN	/CHECK FOR "("
	JMS IARG
	CALL ZCOMA	/GET DEC XCOORD
	JMS IARG	/GET DEC YCOORD
	CALL ZCOMA
	DCA TYPE	/BE UNBIASED
	CALL ZEXPR	/GET ARG3
	STA
	TAD TYPE
	CLL RAR
	SZA CLA
	JMP I (ER26
	TAD TYPE
	TAD (DISPOP-1
	JMP CCLOSE
FINIS,	CALL ZLPAREN	/GET LEFT PAREN
	JMS I	ZBACKUP		/PUT BACK (
	JMS IARG
	TAD	(FINIOP		/OUTPUT FINI OPCODE
	JMP I (CMNCOD
/
	PAGE

GOTO,	JMS I	ZNXTCHR		/LOOK FOR (
	JMP	LBLERR		/NOTHING LEFT MEANS ERROR
	TAD	ZM11
	SNA CLA
	JMP	COMPGT		/COMPUTED GO TO
	JMS I	ZBACKUP
	JMS	GETLBL		/GO GET LABEL
	TAD	(BRANCH
	TAD	SYMNUM
	JMS I	ZCODE		/OUTPUT BRANCH
	JMP I	ZNXTSTM		/GO GET NEXT STATEMENT
GETLBL,	0
	JMS I	ZNAME		/PICK UP LABEL NAME
	JMP	LBLERR		/MISSING LABLE
	TAD I (PROCSYM	/SEARCH FOR PROC SYMBOL
	JMS I	ZLOOKUP		/S.T. LOOKUP
	TAD I	OPRAND		/TEST TYPE
	CLL RAL
	SZA
	JMP	NNLABL		/THIS ISN'T FIRST REF.
	CLL CML RAR		/TYPE SET TO 4000
	RAR
	DCA I	OPRAND		/MEANS REFNCD, NOT DEFINED
	TAD OPRAND
	TAD Z3
	DCA OPRAND
	TAD LINENO
	DCA I OPRAND
GLRETN,	CDF 0
	JMP I	GETLBL
NNLABL,	AND	(4010		/IF DEFINED, MUST BE
	SZA CLA			/2000, OR 4
	JMP	GLRETN
	CALL ZERROR	/WRONG TYPE (NOT LABEL)
	ERR24
LBLERR,	ISZ CHRPTR
	JMS I	ZERROR
	ERR13

COMPGT,	TAD	X4		/SAVE STACK POSITION
	DCA	STKSAV
	TAD IFLG
	SZA CLA
	JMP I ZNMLS	/NOT ALLOWED IN IF
	DCA	GTTMP
CGTLUP,	JMS	GETLBL		/GET A LABEL
	TAD	SYMNUM
	CALL ZPUSH
	ISZ	GTTMP		/BUMP COUNT
	JMS I	ZNXTCHR		/LOOK AT DELIMITER
	JMP	I (ER67		/BAD COMPUTED GO TO
	TAD	ZM15		/IS IT A COMMA?
	SNA
	JMP	CGTLUP		/YES, GET NEXT LABEL
	TAD	Z3		/IS IT A ) ?
	SZA CLA
	JMP	I (ER67		/NO, ERROR
	CALL ZCOMA
	CALL (IARG
	TAD	(BCMPTD		/NOW A COMPUTED GO TO OP.
	JMS I	ZCODE
	TAD	GTTMP		/NOW THE COUNT
	JMS I	ZCODE
	TAD	GTTMP
	CIA
	DCA	GTTMP
	TAD STKSAV
	DCA X4
	TAD I X4
	TAD (BRANCH
	JMS I	ZCODE		/OUTPUT THIS LABEL
	ISZ	GTTMP
	JMP	.-4
	TAD STKSAV
	DCA X4
	JMP I	ZNXTSTM		/GO GET NEXT STMT
IFLG,	0

ACCEPT,	TAD (6357-6165
	CALL (RNSUB
	CALL ZLPAREN
	DCA RIGHT	/WANT LEFT SIDE
	STL RTL
	DCA TYPE	/WANT DEC
	CALL ZEXPR
	CALL ZCOMA
	CLA IAC
	DCA TYPE	/WANT ALPHA
	CALL ZEXPR
	TAD (ACPTOP
	JMP I (CCLOSE

STKSAV,		/SAVE PDL PTR
UNITRY,	0
	CALL ZNXTCHR
	JMP I (ER67
	TAD ZM15
	SZA CLA		/IS IT ","?
	JMP NOUN	/NO
	STL RTL
	DCA TYPE	/YES
	CALL ZEXPR	/COMPILE DECIMAL EXPRESSION
	TAD (TRYOP
	CALL ZCODE
	EXIT UNITRY

SUBB,	0
	TAD ZM12
	CALL ZCODE
	STL CLA RTL
	DCA TYPE	/SET TYPE TO 2
	EXIT SUBB
PREC,	10		/*
	05		/+
GTTMP,	0		/,
	05		/-
	20		/.
	10		//
	24		/# (UNARY)
	30		/# (BINARY)
NOUN,	CALL ZBACKUP
	EXIT UNITRY
/
	PAGE

GOPR8R,	JMS I	ZNXTCHR		/LOOK FOR OPERATOR
	JMP	NDEXPR		/END OF STMT
	TAD	M4
	SNA		/IS IT #?
	TAD	(16	/YES - CHANGE TO 1
	TAD	(4
	DCA	NEWOP		/SAVE CHAR
	TAD	NEWOP
	TAD	(-13
	SNA
	JMP	OPR8R	/* IS LEGAL
	CLL RAR
	AND	M4
	SNA CLA		/CHECK FOR +,-,/,#
	SNL		/IN ONE SWELL FOOP
	JMP	NOPR8R
OPR8R,	TAD	RIGHT		/CHECK SWITCH
	SNA CLA
	JMP I	(BADLFT		/OPERATOR ILLEGAL ON LEFT
	TAD	NEWOP
	TAD	(PREC-13
	DCA	PNEWOP		/GET NEW PRECEDENCE
CMPPRC,	JMS I	ZPOP		/GET OLD OPERATOR
	SNA
	JMP	PSHNEW+1	/IS ZERO, JUST PUSH NEW
	DCA	OLDOP
	TAD	OLDOP
	TAD	(PREC-13
	DCA	POLDOP		/GET OLD PREC
	TAD I	PNEWOP
	CIA
	TAD I	POLDOP		/COMPARE PREC
	SPA CLA
	JMP	PSHNEW		/IF P(OLD) < P(NEW), PUSH NEW
	TAD	OLDOP		/IF P(OLD) >= P(NEW), THEN ...
	CALL (SUBB
	JMP	CMPPRC		/AND DO NEW COMPARE
PSHNEW,	TAD	OLDOP		/REPLACE OLD
	JMS I	ZPUSH
	TAD	NEWOP		/PUSH NEW
	JMS I	ZPUSH
	JMP I	(GTOPND		/GET AN OPERAND
NOPR8R,	JMS I	ZBACKUP		/REPLACE ONE CHARACTER
NDEXPR,	JMS I	ZPOP		/OUTPUT ALL
	SNA			/REMAINING
	JMP EXPRET
	CALL (SUBB
	JMP	NDEXPR

EXPRET,	CALL ZPOP
	DCA NEWOP
	JMP I NEWOP
NEWOP,	0
OLDOP,	0
PNEWOP,	0
POLDOP,	0
/***IF OPERATOR IS #, SET TYPE TO 2 (DEC)

CMLIST,	4657;4501;EENDY
	5247;0101;IF
	5257;5265;INIT
	7156;5265;XMIT
	4752;5752;FINIS
	6465;4263;STAR
	4760;6356;FORMS
	6346;4245;WREAD
	7063;5265;WRYTE

	4552;6461;DISPLAY
	4244;4446;ACCEPT
	5257;4463;INKR
	6563;4261;TREPSE
	4451;4252;CHAIN
CML2,	5060;6560;GOTO
	6346;6566;RETURN
	6465;6061;STOP
	4442;5555;KALL
	6563;4244;TRACE
	5760;6563;NOTRACE
	6057;4663;TRAP
	0
/
	PAGE
	/ERROR DETECTION SECTION:
	IFNZRO BLOCK-3400	<_ERROR - SEE "BLKJMX">
	IFNZRO	PROCST-2000	<_ERROR - SEE "PATCH3">

	*6400
	NOPUNCH
	*7000
	ENPUNCH
/ERROR MESSAGES MUST BE IN UPPER HALF OF FIELD
ERR2,	ERR2-ERR3
	5652;6464;5257
	5001;6061;4663
	4257;4500
ERR3,	ERR3-ERR4
	6466;4364;4463
	5261;6501;4663
	6360;6300
ERR4,	ERR4-ERR5
	4671;6163;4664
	6452;6057;157
	6065;142;5555
	6070;4645;0
ERR5,	ERR5-ERR6
	6657;4546;4752
	5746;4501;5742
	5646;0
ERR6,	ERR6-ERR10
	7063;6057;5001
	4542;6542;165
	7261;4600
ERR10,	ERR10-ERR11
	5652;6464;5257
	5001;6266;6065
	4600
ERR11,	ERR11-ERR12
	5255;5546;5042
	5501;6465;5657
	6500
ERR12,	ERR12-ERR13
	5742;5646;161
	6346;6752;6066
	6455;7201;4546
	4752;5746;4500
ERR13,	ERR13-ERR14
	4671;6146;4465
	4645;155;4243
	4655;152;6401
	5652;6464;5257
	5000
ERR14,	ERR14-ERR15
	4671;6563;4201
	4451;4263;6401
	4265;164;6556
	5765;146;5745
	0
ERR15,	ERR15-ERR16
	4752;4655;4501
	6560;6001;5542
	6350;4601;6063
	121;0
ERR16,	ERR16-ERR17
	5255;5546;5042
	5501;6061;4663
	4265;6063;0
ERR17,	ERR17-ERR20
	6466;4364;4463
	5261;6501;5760
	6501;4546;4452
	5642;5500
ERR20,	ERR20-ERR22
	6346;4460;6345
	165;6060;143
	5250;0
ERR22,	ERR22-ERR23
	6465;5657;6501
	6560;6001;4460
	5661;5546;7100
ERR23,	ERR23-ERR24
	6560;6001;5642
	5772;164;7256
	4360;5564;200
ERR24,	ERR24-ERR25
	5760;6501;5542
	4346;5500
ERR25,	ERR25-ERR26
	4342;4501;6346
	5542;6552;6057
	4255;0
ERR26,	ERR26-ERR43
	5542;4346;5501
	5760;6501;4255
	5560;7046;4500
ERR43,	ERR43-ERR45
	4342;4501;4546
	4452;5642;5501
	6742;5566;4600
ERR45,	ERR45-ERR46
	5652;6464;5257
	5001;6063;143
	4245;160;6165
	5260;5700
ERR46,	ERR46-ERR47
	4542;6542;152
	5752;6552;4255
	5273;4265;5260
	5701;5652;6464
	5257;5000
ERR47,	ERR47-ERR50
	4342;4501;4255
	6151;4201;6742
	5566;4600
ERR50,	ERR50-ERR51
	6560;6001;5642
	5772;152;6546
	5664;0
ERR51,	ERR51-ERR52
	5257;5265;5242
	5501;6742;5566
	4601;7063;6057
	5001;6452;7346
	0
ERR52,	ERR52-ERR56
	5760;6501;4201
	6063;145;0
ERR56,	ERR56-ERR61
	4460;5656;4201
	5652;6464;5257
	5000
ERR61,	ERR61-ERR63
	6163;6050;6342
	5601;6560;6001
	4352;5000
ERR63,	ERR63-ERR64
	6560;6001;5666
	4451;145;4265
	4200
ERR64,	ERR64-ERR65
	5652;6464;5257
	5001;6063;143
	4245;145;4667
	5244;4600
ERR65,	ERR65-ERR66
	5652;6464;5257
	5001;6346;5542
	6552;6057;4255
	0
ERR66,	ERR66-ERR67
	5652;6464;5257
	5001;6061;4657
	161;4263;4657
	0
ERR67,	ERR67-ERR70
	5652;6464;5257
	5001;4455;6064
	4601;6142;6346
	5700
ERR70,	ERR70-ERR71
	4342;4501;6163
	6044;104;0
ERR71,	ERR71-DEVTBL
	4444;6101;4663
	6360;6300
/	! INDICATES COMPILER ABORT.

/DEVICE TABLE USED BY INIT
DEVTBL,	-5200;2000	/IN
	-6000;4000	/OUT
	-6600;6000	/UPDATE
	-5400;100	/KBD
	-6500;101	/TTY
	-4400;102	/CDR
	-6100;103	/PUNCH
	-6300;104	/RDR
	-5500;105	/LPT
	-7300;106	/X (NULL INPUT DEVICE)
	-7400;107	/Y (NULL OUTPUT DEVICE)
	-4700;0		/F
	-6700;0		/V
	-6400;1777	/SYS
	0		/TABLE END

HEADING,HEADING-PAGNUM
	4460;6401;4552
	4360;5501;101
	0101
DAY,	101;166;5745
	1630;4645;101
WKDAY,	0101;0101
	101;101
CMPLTN,	4460
	5661;5255;4265
	5260;5701
LSTNG,	5552
	6465;5257;5001
	101;101;167
	0124		/ 3		***** VERSION # *****
	1721		/.0
	3001		/7
	161;4250;4601
PAGNUM,	2121
	MONTH1=DAY+1
	MONTH2=DAY+2
	YEAR=DAY+4
HEAD2,	6465;6063;4250
	4601;5642;6101

SUBHDG,	SUBHDG-EOMESGS
	101;101;101
	101;101;4542
	6542;145;5267
	5264;5260;5701
	101;0
	ZBLOCK	33		/PADDING FOR THE USER HEADING
EOMESGS=.

STITLE,	-31
	401;101;101
	101;5742;5646
	101;101;101
	6572;6146;101
	101;101;145
	5256;101;101
	6452;7346;101
	101;6063;5250
	5257
IMPRES,	-4
	5560;4245;5257
	5000
	$