	.TITLE PDP9-15 ALGOL COMPILER	9 MAR 72  EDIT 308
/EDIT 002 REMOVED BUG IN INTEGER DIVISION WITH COMPLEX DIVISOR
/EDIT 003 ALLOWS .ABS VERSION IF %SY DEFINED
/COPYRIGHT DIGITAL EQUIPMENT CORPORATION
/SYSTEM VERSION PARAMETERS DEFINE CONDITIONAL ASSEMBLY
/IF UNDEFINED RELOCATABLE VERSION PRODUCED WHERE EACH PASS
/RUNS AS A SEPARATE PROGRAM.
/PROGRAM STARTS AT FIRST LOCATION
/IF %SY DEFINED AN ABSOLUTE VERSION IS PRODUCED FOR SYSTEM INSERTION
/USING PATCH
	.IFDEF DOS
%BOS=152
	.ENDC
/
/
/
	.DEFIN .BOS ADDR
	.IFDEF DOS
	LAC* (%BOS)
	SPA!CLA
	JMP ADDR	/BOS MODE
	.ENDC
	.ENDM
/
/
/
	.DEFIN .OVLAY NAME
	.IFDEF DOS
	0
	24
	.+1
	.SIXBT "NAME"
	.ENDC
	.ENDM
/
/
/
	.IFDEF	%SY
	.ABS
	.ENDC
/
/
/
	.IFDEF	%S1
	.LOC	%S1
	.ENDC
/
/
/
 
/P1C10
/CODE TO DEAL WITH PRE-SET PROCEDURES(NORMALLY OVERWRITTEN
/BY STACKS)
 
	JMP	START
P1C10	LAC	APSP	/)SET XB FOR ENTRY TO
	DAC	XB	/)ANAL
	JMS	P1C71	/INIT STAT TABLE
	JMS	BLKSET
	LAC	BSS-1	/)DISALLOW 'DATSLOT'
	DAC	BSS-5	/)DIRECTIVE
	JMS	GNC00	/GET FIRST CHAR
	JMS	GNBS56	/GET FIRST USEFUL CHAR
	JMS	GNBS	/GET FIRST BS
	JMS	GNEL	/GET FIRST ELEMENT
	JMS	OBEY	/STACK LINK(.+2)
	JMP	ANAL+4	/PROCESS PRE-SET PROC FILE
	LAC	STATE	/RETURN TO HERE
	SAD	C1	/STATE=TRUE?
	JMP	P1C20	/YES:O.K.
	LAW	-132	/REPORT ERROR 90
	JMS	ERR
	JMP	P1C2-3
P1C20	LAC	C2	/)SET FREQD FOR CALL OF
	DAC	FREQD	/)ROUTINE UP
	JMS	UP	/PACK STACKS UP TIGHT
	LAC	POLISH
	JMS	TCA
	TAD	AP1C10
	SPA		/PRE-SET PROC STACKS TOO LONG?
	JMP	P1C2	/NO:OK.
	LAW	-36	/REPORT ERROR 30
	JMP	P1C20-2
 
AP1C10	P1C10+1377
	.EJECT
/SYNTAX BLOCKS FOR PRE-SET PROCEDURES(OVERWRITTEN BY STACKS)
 
	0		/EXIT FAIL
PSP1	CC+BEGEL		/*BEGEL?*
	AN	PSP11
	DZM	XSTAT1-1	/ALLOW ONLY EXTERNAL PROC BODIES
	N	PSP31
PSP11	CC+FPEL		/*FPEL?*
	AN	PSP21
	JMP	PH2	/DO PHASE 2 ON FPEL
	0		/EXIT FAIL
PSP21	JMP	PDEC	/*PROCESS PROC DECN*
	N	PSP41
	0		/EXIT FAIL
PSP31	CC+ENDEL		/*ENDEL?*
	N	PSP51
	N	PSP31
PSP41	CC+SCEL		/*SCEL?*
	N	PSP11
	LAW	-136	/ERROR 94
	AS		/EXIT TRUE
PSP51	40000		/*MASK XHEL*
	S		/EXIT OK
 
APSP	PSP1
	.EJECT
/P1C30
/READS DATSLOT DIRECTIVE AND OUTPUTS "MAIN PROGRAM"
/OP FOLLOWED BY DATSLOTS USED
/DATSLOT 0=NO DATSLOTS USED
/DATSLOT 8=DATSLOT 10(OCT)(10 NOT ALLOWED IN SOURCE)
/DATSLOT 9=ALL DATSLOTS USED
/CODE OVERWRITTEN BY STACKS
 
P1C30	LAC	U05600
	JMS	PUTOUT	/OUTPUT MP OP
	JMS	GNBS60	/GET NEXT MEANINGFUL CHAR
	AND	S03000
	SAD	S03000	/DIGIT?
	JMP	P1C36	/YES
	JMP	P1C33	/NO
P1C31	SAD	U00057	/COMMA?
	JMP	P1C30+2	/YES
P1C32	SAD	U60056	/NO:SEMI-COLON?
	JMP	P1C39	/YES
P1C33	LAW	-40+Z	/NO:REPORT ERROR 32
	JMS	ERR
	LAC	K1
	DAC	ELANAL	/SET ELANAL=FALSE
P1C34	JMS	GNBS	/GET NEXT BASIC SYMBOL
	LAC	AMODL1	/SET XB FOR MAIN PROG MODULE
	JMP	SETXB
P1C36	ISZ	NUMDAT	/COUNT DIGITS READ
	LAC	BSW
	TAD	C3
	AND	S00017	/AC:=OCTAL DIGIT
	SNA		/ZERO?
	JMP	P1C38	/YES
	SAD	C9	/NINE?
	JMP	P1C37-2	/YES
	JMS	PUTOUT	/OUTPUT DIGIT
	JMS	GNBS60	/GET NEXT MEANINGFUL CHAR
	JMP	P1C31
	LAW	-1	/
	DAC	DCT
P1C37	LAC	W00000
	JMS	PUTOUT	/OUTPUT "IODEV ALL"
P1C38	LAC	NUMDAT
	SAD	C1	/ONLY ONE DIGIT READ?
	SKP		/YES:OK
	JMP	P1C33	/NO
	JMS	GNBS60	/GET NEXT MEANINGFUL CHAR
	JMP	P1C32
P1C39	DZM	BSW	/CLEAR BSW FOR GNBS CALL
	JMP	P1C34
S03000	3000
U05600	205600
AMODL1	MODL1
NUMDAT	0
	.EJECT
/INITIALISE STATISTICS TABLE(OVERWRITTEN BY STACKS)
 
P1C71	XX
	LAC	AAINBA
	DAC*	C8	/AUTO:=STATISTICS TABLE-1
	LAC	AGLOBL
	DAC	STPTR	/STPTR:=ADDR OF LAST FREE REG.
	LAC	AASTIN
	DAC*	C9
P1C72	LAC*	AUTO1
	SNA		/END OF INIT TABLE?
	JMP	P1C80	/YES
	DAC	SP00	/SP00:=1ST ENTRY IN TABLE
	AND	Z70000	/RETAIN STACK INDICATOR
	XOR	S07777	/MAKE LS. 12 BITS 7777
	DAC*	STPTR	/DUMP 1ST ENTRY INTO STACK
	LAC	STPTR	/GET ADDR OF BASE OF STACK
	DAC*	AUTO	/DUMP IN STACK BASE REG.
	LAC	SP00
	AND	S07777	/GET COUNT (-VE) OF ENTRIES
	XOR	Z70000	/IN STACK
	DAC	SP01	/DUMP
P1C73	ISZ	SP01	/MORE ENTRIES FOR THIS STACK?
	JMP	P1C74	/YES
	LAC	STPTR	/ADDR OF LAST ENTRY IN STACK
	DAC*	AUTO	/DUMP IN STACK PTR
	TAD	K1	/)
	DAC	STPTR	/)MOVE SK PTR BACK 1 WORD
	JMP	P1C72	/REP. TO END OF INIT. TABLE
 
/SET UP INITIAL CONTENTS OF SK
 
P1C74	LAC	STPTR	/)MOVE SK PTR
	TAD	K1	/)BACK 1 WORD
	DAC	STPTR
	LAC*	AUTO1	/GET SK CONTENTS
	DAC*	STPTR	/DUMP IN SK
	JMP	P1C73
 
/INITIALISE OUT SK FOR PRESET PROC MODE
 
P1C80	LAC	AP1C30
	DAC	OUBASE
	TAD	C1	/ZERO CAN BE PUT ON OUTSK
	DAC	OUT
	DZM	SIZE
	JMP*	P1C71
 
AP1C30	P1C30
	.EJECT
/STINIT	STACK INITIALISATION TABLE (OVERWRITTEN BY STACKS)
 
STINIT	027772		/INTEGR
	0		/FALSE
	-1		/TRUE
	1		
	16		/FOR AUTO-INDEXING IN OBJ.CODE
	2		/FOR OPTIMISATION IN OBJ.CODE
	017777		/REAL
	047777		/STRING
	147777		/OWN
	107777		/SWITCH
	057777		/LABEL
	077777		/PROC
	007777		/VOCAB
	137777		/WORK
	117777		/REVPOL
	067777		/DICT
	127777		/POLISH
	0	/EOT
	.EJECT
/GNC00
/INITIAL ENTRY POINT TO ROUTINE GNC(EXECUTED ONCE
/ONLY,THEN OVERWRITTEN BY STACKS)
 
GNC00	XX
	LAC	GNC00
	DAC	GNC
	.IFUND	%SY
	.IODEV	-11,-12,-13,-15
	.ENDC
	.INIT	DATIN,IN,P1C4+5
	LAC	LIST
	SNA		/LISTING REQD?
	JMP	GNC02	/NO
	.INIT	DATOUT,1,P1C4+5
LDSZP	LAC	S02766	/)CHANGE DATSLOT FOR ERRORS
	DAC	ERR08+4	/) IN .WRITE'S
	DAC	HDBUFF-6	/)
	LAC	S00766	/)CHANGE DATSLOT FOR ERRORS
	DAC	ERR08+10	/)IN .WAIT
GNC02	.SEEK	DATIN,GNC /ADDR OF FILENAME SET BY RCOMST
	LAC	LIST
	SNA		/LISTING REQD?
	JMP	GNC021-3	/NO
	LAC	GNC14
	DAC*	AXW	/SET EXTENSION TO LST
	.ENTER	DATOUT,GNC14 /ADDR OF FILENAME SET BY RCOMST
	LAC	GNC18
	DAC*	AXW	/SET EXTENSION TO A01
	JMS	GNC60	/READ IN FIRST BUFFER
GNC021	JMP	GNC01
	.EJECT
/RCOMST
/ROUTINE TO READ THE COMMAND STRING AND SET UP THE OPTION WORD
/(THE LOWEST FREE REGISTER OF CORE).
/OVERWRITTEN BY STACKS
	.IFUND	%SY
 
	.IODEV -3,-2
	.ENDC
RCOMST	LAC	WORK	/PRESERVE WORK SK PTR
	DAC	SP06
EMPTY1	LAC	SP06	/RESTART PT FOR ^P OR ERRORS
	DAC	WORK
	.INIT -3,1,EMPTY1
	.BOS ...A
	.WRITE -3,2,ANNOUC,8
...A	.INIT -2,0,EMPTY1
	.BOS ...B
	.WRITE	-3,2,OPTION,4
...B	.READ	-2,2,GNC73,34
	.WAIT	-2
	LAC	GNC06
	TAD	C4
	DAC	GNC08
	LAC	GNC70
	DAC	GNC75
	ISZ	GNC75
	DZM	LIST
	DZM	XDICT
	DZM	ERRMOD
	DZM	PRESET
	DZM	ALTMOD
	LAC*	S00102
	DAC	FILE
	DAC	AOPTW	/ADDRESS OF OPTION WORD
	DAC*	S00010
	DZM*	10
	DZM*	10	/CLEAR FILENAME AND EXTENSION
	DZM*	10
	LAC*	S00010
	DAC	AXW
	DZM*	10
	LAC*	S00010
	DAC	SYMB
	ISZ	FILE	/FILENAME WORD
	LAW	-3
	DAC*	AOPTW
	DAC	PACKCT	/COUNT FOR PACKING  6 BIT
	DZM	FNCC
	DZM	CT1
	JMS	BSCON
	LAC	ACSTR
	DAC	XB
	JMS	OBEY	/STACK LINK (.+2)
	JMP	ANAL+4	/PROCESS COMMAND STRING(RETURN TO .+1)
	LAC	AOPTW
	TAD	C1
	DAC	GNC021-4	/INIT .ENTER FOR LISTING DEVICE
	DAC	UP15+6	/INIT .ENTER FOR INT OUTPUT
	DAC	GNC02+2	/INIT .SEEK FOR SOURCE FILE
	JMS	TLPTRS	/SET CCODE AND GTNEXT FOR TOP LEVEL
	.IFUND	%B0
	JMS	REST	/LOAD PRESET STACKS
	.ENDC
	JMS INIT	/RESET OUT AND OUBASE AND SET UP BLKADD
	LAC	PRESET
	SZA		/PRESET PROC OPTION SET?
	JMP	P1C10	/YES
	JMS	BLKSET	/GET STARTING BLOCK # FOR PASS1
	JMS	GNC00	/GET FIRST CHAR
	JMS	GNBS56	/GET FIRST USEFUL CHAR
	JMS	GNBS	/GET FIRST BASIC SYMBOL
	SAD	U00076	/'DATSLOT'?
	JMP	P1C30	/YES
	LAC	AMOD21	/)NO SO SET XB FOR ENTRY TO
SETXB	DAC	XB	/)PROC MODULE ANALYSIS
	JMP	P1CON
AMOD21	MODL21
	.EJECT
/SYNTAX BLOCKS INTERPRETED BY ANAL WHEN PROCESSING THE COMMAND STRING
	JMP	POPT	/SET BIT IN OPTION WORD
	AN	CSTR	/YES
CSTR	JMP	OPTN	/OPTION CHAR?
	N	CSTR4	/NO,CHECK FOR _
	N	CSTR13	/CHECK FOR CR OR ALTM
CSTR4	CC+26		/_?
	N	CSTR5	/YES,CHECK FOR FILENAME CHAR
	N	CSTR10	/NO,CHECK FOR .,%,OR #
CSTR5	1000		/LETTER OR DIGIT?
	AN	CSTR5	/YES
	JMP	PFN	/PACK FILENAME CHAR
	N	CSTR8
CSTR6	CC+20056		/;?
	AN	CSTR7	/YES,CHECK FOR EXT CHAR
	JMP	TFNS	/TEST NO. OF FILENAME CHARS
	N	CSTR11	/NO,CHECK IF .,% OR #
CSTR7	1000		/EXT CHAR=LETTER OR DIGIT?
	AN	CSTR7	/YES
	JMP	PFN	/PACK EXT CHAR
	N	CSTR9	/NO
CSTR8	CC+72		/SPACE?
	AN	CSTR7	/YES,CHECK FOR EXT CHAR
	JMP	TFNS	/TEST NO. OF FILENAME CHARS
	N	CSTR5
CSTR9	JMP	CRALT	/TEST FOR CR OR ALTM
	A		/YES
	JMP	NOEXT	/CHECK NO OF FILENAME CHARS
	N	CSTR6	/NO,CHECK FOR;
CSTR10	4000		/.,%, OR #/?
	AN	CSTR5	/YES
	JMP	PFN	/PACK FILENAME CHAR
	N	CSTR12
CSTR11	4000		/.,% OR #?
	AN	CSTR7	/YES
	JMP	PFN	/PACK EXT CHAR
	N	CSTR7
CSTR12	JMP	CRALT
	A	
	JMP	TXS
	N	CSTR
CSTR13	JMP	CRALT
	A		/EXIT THROUGH STRERR
	JMP	STRERR
	.EJECT
CRALT	LAC	BSW
	XOR	U00000
	SAD	S00015	/CARRIAGE RETURN?
	JMP	CARR02	/YES
	SAD	S00175	/ALTMODE?
	JMP	.+3	/YES
	DZM	NXTRQD
	JMP	FALSE	/NO
	ISZ	ALTMOD
CARR	LAC*	AOPTW
	XOR	S01000	/RET TO MONITOR BIT CLEARED
	DAC*	AOPTW	/WORD
CARR02	.INIT -3,1,P1C4+10
	JMS	TOPT	
	40000
	ISZ	XDICT
	JMS	TOPT
	20000		/LISTING REQUIRED?
	ISZ	LIST	/YES
	JMS	TOPT	/NO
	4000		/PRESET PROCEDURES REQUIRED?
	ISZ	PRESET	/YES
	JMS	TOPT	/NO
	10000		/ERROR MODULE REQUIRED?
	ISZ	ERRMOD	/YES
	JMS	TOPT
	100
	SKP		/DUMP OPTION SET
	JMP	TRUE
/	.INIT	-3,1,DMP	/FOR ^T
	CAL+1000	-3&777
	1
	A+DMP
	0
	JMP	TRUE
 
OPTN	LAC	BSW
	SAD	LLET-1	/K OPTION?
	JMP	FALSE
	AND	U00000
	SNA		/OPTION CHAR?
	JMP	FALSE	/YES
	JMP	TRUE	/NO
	.EJECT
BSCON	XX
BSCON2	JMS	UNP5.7	/UNPACK 5/7 ASCII
	DAC	BSW	/HOLD 7 BIT CHAR
	SAD	S00015	/CR?
	JMP	BSCON6
	SAD	S00175	/ALTM?
	JMP	BSCON6
	TAD	K32
	SPA
	JMP	BSCON2
	TAD	K64
	SMA
	JMP	BSCON2
	TAD	S00140
	TAD	ABSS	/NO,ADD ADDRESS OF BSTABLE
	DAC	BSW	/ADDRESS OF BASIC SYMBOL
	LAC*	BSW	/BASIC SYMBOL
	DAC	BSW
	JMP*	BSCON	/NO,EXIT
BSCON6	XOR	U00000
	JMP	.-3
 
 
 
POPT	LAC	BSW
	AND	Z76300	
	AND*	AOPTW
	SNA		/OPTION BIT ALREADY CLEARED
	JMP	POPT2	/YES,EXIT
	XOR*	AOPTW	/NO,CLEAR OPTION BIT
	DAC*	AOPTW
POPT2	DZM	NXTRQD	/SET MARK TO GET NEXT CHAR
	JMP	ANAL04
	.EJECT
PFN	LAC	BSW
	DZM	NXTRQD
	JMS	FILNAM	/PACK CHAR INTO FILENAME
	ISZ	PACKCT	/3 CHARS PACKED?
	JMP	ANAL04	/NO
	ISZ	FILE	/YES,SET TO NEXT WORD
	LAW	-3
	DAC	PACKCT	/RESET COUNT
	JMP	ANAL04	/RETURN
	.EJECT
TFNS	LAW	-6
	TAD	FNCC
	SMA!SZA		/FNCC>6?
	JMP	STRERR	/YES
	SNA		/NO,FNCC=6?
	JMP	TFNS2	/YES
TFNS1	CLA
	JMS	FILNAM	/PACK FILENAME WITH SPACES
	ISZ	PACKCT	/3 CHARS PACKED?
	JMP	TFNS1	/NO
	LAW	-3	/YES,RESET COUNT
	DAC	PACKCT
	ISZ	FILE	/SET TO NEXT FILENAME WORD
	JMP	TFNS	/JUMP BACK
TFNS2	JMS	PACKFN
	LAW	-3
	DAC	PACKCT
	DZM	FNCC
	JMP	ANAL04
 
 
 
TXS	LAC	FNCC	/EXT CHAR COUNT
	SNA		/COUNT=0?
	JMP	TXS2	/YES
	TAD	K3
	SMA!SZA		/COUNT>3?
	JMP	STRERR	/YES,REPORT ERROR
	SNA		/COUNT=3?
	JMP	TXS4	/YES,EXIT
TXS1	CLA
	JMS	FILNAM	/PACK WITH SPACES
	ISZ	PACKCT	/3 CHARS PACKED?
	JMP	TXS1	/NO,LOOP
	ISZ	FILE
	DAC*	FILE
	JMP	ANAL04
TXS2	JMS	SRCEXT
	JMP	ANAL04
TXS4	LAC*	AXW
	JMP	TXS2-2
 
 
 
SRCEXT	XX
	LAC	SRC
	DAC*	AXW
	DAC*	SYMB
	JMP*	SRCEXT
 
 
 
NOEXT	JMS	SRCEXT
	JMP	TFNS
	.EJECT
FILNAM	XX
	AND	S00077
	TAD	K29
	SPA		/DIGIT OR #?
	JMP	FILNA6	/NO
	TAD	S00060	/YES, SO CONVERT DIGITS TO ASCII
	SAD	S00072	/#?
	TAD	K23	/YES, SO CONVERT TO ASCII
FILNA2	DAC	BSW
	LAC*	FILE
	RTL
	RTL
	RTL
	AND	Z77700
	TAD	BSW
	DAC*	FILE
	ISZ	FNCC
	JMP*	FILNAM	
FILNA6	TAD	C2
	SPA		/. OR %?
	TAD	K18	/NO,LETTER
	SZA		/%?
	TAD	C8	/NO,.
	TAD	S00045
	JMP	FILNA2
	.EJECT
/PACKFN-PACK FILENAME FROM COMMAND STRING FROM
/6 BIT INTO 5/7 ASCII
/
PACKFN	XX
	LAC	S60000
	JMS	PAK5.7	/PACK FORM FEED
	LAC*	S00102
	DAC	TEMP	/ADDRESS OF FILENAME WORD
	ISZ	TEMP
PACK02	LAC*	TEMP
	DAC	TEMP1	/1ST WORD OF FILENAME
PACK04	JMS	CHARAC
	LAC	CT1
	SAD	C4	/5 CHARS PACKED 5/7?
	JMP	PACK03	/YES
	ISZ	PACKCT	/NO,3 CHARS UNPACKED FROM TEMP1?
	JMP	PACK04	/NO,LOOP
	ISZ	TEMP	/YES,SET TO NEXT WORD OF FILENAME
	LAW	-3
	DAC	PACKCT	/RESET UNPACKING COUNT TO -3
	JMP	PACK02	/LOOP
PACK03	LAC	TEMPFN+1	/PACK FILENM
	RCL		/)AND FILENM+1 WITH
	DAC	FILENM+1	/5*7 BIT ASCII CHARS
	LAC	TEMPFN+2
	RAL
	DAC	FILENM
	DZM	TEMPFN+1	/PAIR TO 0
	ISZ	PACKCT
PACK06	JMS	CHARAC
	ISZ	PACKCT	/REMAINING 2 CHARS PACKED?
	JMP	PACK06	/NO,LOOP
	LAC	TEMPFN+1
	CLL
	RTL
	RTL
	DAC	FILENM+2
	JMP*	PACKFN	/EXIT
	.EJECT
/CHARAC
/ROUTINE TO CONVERT 6-BIT TO 5/7 ASCII
 
CHARAC	XX
	LAC	TEMP1
	AND	Z70000	/GET TOP 6 BITS
	SNA
	JMP	CHAR01	/YES
	CLL!RAR
	TAD	U00000	/CONVERT FROM 6 BIT
	XOR	Y00000	/TO 7 BIT
CHAR01	JMS	PAK5.7
	ISZ	CT1	/INCREMENT CHAR COUNT
	LAC	TEMP1
	JMS	MES	/SHIFT NEXT CHAR OF
	JMP	L-6	/FILENAME TO TOP 6 BITS
	DAC	TEMP1
	JMP*	CHARAC	/EXIT
 
/PAK5.7
/ROUTINE TO PACK 5/7 ASCII
 
PAK5.7	XX
	DAC	TEMPFN
	LAW	-7
	DAC	TEMP2	/COUNT FOR 7 BIT PACK
PAK01	LAC	TEMPFN
	RAL
	DAC	TEMPFN
	LAC	TEMPFN+1
	RAL
	DAC	TEMPFN+1
	LAC	TEMPFN+2
	RAL
	DAC	TEMPFN+2
	ISZ	TEMP2	/7 BITS PACKED?
	JMP	PAK01	/NO,LOOP
	JMP*	PAK5.7	/YES,EXIT
	.EJECT
STRERR	.BOS ...C
STRERM	.WRITE -3,2,ERRMES,2
	.WAIT -3
	JMP	EMPTY1
ERRMES	4/2*1000
	0
	.ASCII /?/<175>
	.EJECT
ANNOUC	10/2*1000
	0
	.ASCII /ALGOL V1A/<15>
OPTION	4/2*1000
	0
	.ASCII />/<175>
FILE	0
PACKCT	0
FNCC	0
SYMB	0
CT1	0
ACSTR	CSTR
SRC	232203
S00045	45
S00072	72
S25500	25500
Z76300	776300
	.EJECT
/BANK-BIT INITIALISATION SECTION (OVERWRITTEN)
 
START	JMS	.
	LAC	START
	AND	S60000	/AC:=BANK BITS
	DAC	BANK
	TAD	TSTRT	/SET UP A-I 10 TO START OF
	AND	S77777
	DAC*	C8	/INITN TABLE
NXTADR	LAC*	AUTO	/GET ADDR FROM TABLE
	XOR	BANK	/BANK BIT INITIALISE IT
	DAC	SP00
	LAC*	SP00	/LOAD 15-BIT PROG ADDR
	AND	Z17777	/DISCARD OLD BANK BITS
	XOR	BANK	/INSERT NEW BANK BITS
	DAC*	SP00	/PUT BACK IN CODE
	ISZ	BCNT	/FINISHED?
	JMP	NXTADR	/NO
	LAW	-2	/SET TABLE COUNT
	DAC	BCNT
	LAC	AVTOA
	DAC*	C8
	DAC*	C9
NXTENT	LAC*	AUTO	/)INTIALISE TABLE OF
	RAL
	SPA!RAR		/15-BIT ADDRESS?
	JMP	.+3	/NO,SO IGNORE
	AND	Z17777	/)CONSECUTIVE 15-BIT ADDRESSES
	XOR	BANK
	DAC*	AUTO1
NXTCNT	ISZ	BCNT1	/FINISHED THIS TABLE?
	JMP	NXTENT	/NO
	ISZ	BCNT	/FINISHED?
	SKP		/NO,GO DO STATISTICS TABLE
	JMP	RCOMST	/YES, GO TO READ COMMAND STRING
/NOW BANK INITIALISE STATISTICS TABLE
	ISZ	NXTCNT	/PICK UP SIZE OF STATISTICS TABLE
	LAC	AAINBA	/START OF TABLE
	JMP	NXTENT-2	/GO INIT TABLE
	.EJECT
/BANK BIT INITIALISATION TABLE
 
TSTRT	A	.
	A	AP1C10
	A	APSP
	A	AMODL1
	A	AP1C30
	A	GNC00+5
	A	GNC02-7
	A	EMPTY1+4
	.IFUND	DOS
	A	EMPTY1+10
	A	EMPTY1+14
	A	EMPTY1+20
	A	EMPTY1+24
	.ENDC
	.IFDEF	DOS
	A	...A-2
	A	...A+2
	A	...B-2
	A	...B+2
	.ENDC
	A	AMOD21
	A	CARR02+2
	A	OPTN-3
	.IFUND DOS
	A	STRERR+2
	.ENDC
	.IFDEF DOS
	A	STRERR+5
	.ENDC
	A	ACSTR
	A	AVTOA
	A	GLOBL
	A	GLOBL+1
	A	WORK
	A	P1C1+1
	A	P1C1+2
	.IFNZR	%C1-6
	A	P1C6-3
	.ENDC
	.IFUND	DOS
	A	P1C6-1
	.ENDC
	.IFDEF %S4
	A	P1C6+3
	.IFUND	DOS
	A	P1C6+5
	.ENDC
	.ENDC
	.IFDEF	%S2
	A	P1C9-3
	.IFUND	DOS
	A	P1C9-1
	.ENDC
	.ENDC
	.IFDEF	%B0
	.IFDEF	DOS
	A	P1C9DA
	A	P1C9DA+2
	A	P1C9DA+4
	.ENDC
	.IFUND	DOS
	A	P1C9+2
	A	P1C9+4
	.ENDC
	.ENDC
	.ENDC
	A	PUTW+2
	A	PUTRP+2
	A	PUTPOL+2
	A	PUTOUT+2
	A	VAB+1
	A	CVRS+4
	A	GSTR14-2
	A	GSTR14-1
	A	GSTR14+3
	A	GSTR14+5
	A	GSTR14+7
	A	GSTR14+11
	A	ENDSP+4
	A	ENDSP5-1
	A	ENDSP5+3
	A	ENDSP5+11
	A	USEV-20
	A	USEV-15
	A	DEC00
	A	UPNPTR+3
	A	CNA+5
	A	CNA+6
	A	CDL01+13
	A	CDL02-5
	A	CDL02-4
	A	CDL05+1
	A	CDL05+2
	A	CDL05+5
	A	CDL07+5
	A	CDL08+1
	A	FDA+2
	A	ODL+2
	A	ODL+5
	A	ODL+6
	A	PH2ERR-4
	A	PH2ERR-3
	A	PRP+2
	A	PD+2
	A	PD+5
	A	PD+10
	A	OPOUT-5
	A	OPOUT-4
	A	SWD+6
	A	SWD+11
	A	SWD+13
	A	OTOWN+6
	A	OTOWN1-6
	A	OTOWN1-2
	A	OTOWN1-1
	A	OTOWN1+2
	A	OTOWN1+4
	A	DIPOL2-3
	A	OTSOWN+2
	A	OTSOWN+4
	A	CAFC2+1
	A	CAFC14+1
	A	CDVW1-2
	A	CDVW4-2
	A	CDVW4+5
	A	CDVW6+7
	A	FNPK10-11
	A	FNPK10-2
	A	CAP04-1
	A	CAP04+1
	A	CPN2-5
	A	GNBS+5
	A	GNBS+6
	A	NSTK13+1
	A	NSTK16-1
	A	NSTK16+2
	A	NSTK16+5
	A	ISTK10-3
	A	ISTK10+2
	A	RSTK7+1
	A	RSTK8+2
	A	RSTK8+5
	A	RSTK8+10
	A	GNC20+2
	A	GNC20+3
	A	GNC20+13
	A	GNC20+14
	A	GNC70
	A	GNC71
	A	HDBUFF-4
	A	ERR06-10
	A	ERR06-7
	A	ERR06-3
	A	ERR06-2
	A	ERR07+1
	A	ERR07+2
	A	ERR10-5
	A	ERR24-6
	A	ERR24-3
	A	ERR24+1
	A	ERR24+4
	A	ERR30-2
	A	ERR30-1
	A	ERR32+1
	A	PACKEL+2
	A	PACKEL+3
	A	PACK-3
	A	PACK-2
	A	LDA0+2
	A	LDA1+2
	A	LDA2+2
	A	LDA3+2
	A	LV4+2
	A	DDA2+2
	A	SCV+1
	A	POLOUT+2
	A	TCA-4
	A	TCA-3
	A	EOP2+2
	A	CSTAT2-1
	A	CCODE
	A	DEST
	A	CHRLY+6
	A	GTNEXT	/)
	A	GTNEXT	/)FOR PATCHING
	A	GTNEXT	/)INITIALISATION
	A	GTNEXT	/)TABLE
	A	DMP02-10
	.IFUND	DOS
	A	TP2
	A	TP4
	.ENDC
TEND=.-1
BCNT	TSTRT-TEND
BCNT1	VTOA02+1-TQ
BCNT2	INBASE-OUBASE
AVTOA	VTOA02
Z17777	717777
	.BLOCK	%V1-%K1-Z17777+%S1
	.EJECT
/STATISTICS TABLE
 
GLOBL	SP06		/)DELIMIT GLOBAL LOCNS
	AOPTW		/)FOR DUMP OPTION
INBASE	XX
INTEGR	XX
RLBASE	XX
REAL	XX
STBASE	XX
STRING	XX
OWBASE	XX
OWN	XX
SWBASE	XX
SWITCH	XX
LABASE	XX
LABEL	XX
PRBASE	XX
PROC	XX
VOBASE	XX
VOCAB	XX
WKBASE	XX
WORK	GLOBL
RPBASE	XX
REVPOL	XX
DIBASE	XX
DICT	XX
POBASE	XX
POLISH	XX
OUT	XX
OUBASE	XX
	.EJECT
/P1CON	PASS 1 CONTROL
 
P1C1	JMS	COPY	/)RETURN TO HEREAFTER COMPILING SOURCE
	OTCD		/)ANDPUT OTCD,MAXOTD,
	M*1+WORK		/)MAXL AND SIZE
	4		/)ON WORK SK
	CLA
	JMS	PUTOUT	/)OUTPUT FINAL 2 DUMMY
	JMS	PUTOUT	/)WDS FOR PHASE 3 OR ERROR MODULE
	LAC	SIZE	/INSERT CORRECT SIZE FOR
	DAC*	WORK	/PASS2 OR ERROR MODULE
P1C2	.CLOSE	DATIN
	LAC	LIST
	SNA		/LISTING REQD?
	JMP	.+7	/NO
	LAC	LDSZP-1	/IGNORE "EOP1" IF
	SAD	C34	/LISTING TO TTY
	SKP
	JMS	EOP	/OUTPUT "EOP1"
	.CLOSE	DATOUT
	LAC	S02775
	DAC	EOP2
	LAC	EMODE
	SNA		/ERRORS IN PASS1?
	JMP	P1C8	/NO
	LAC	ERRMOD
	SZA		/ERROR MODULE REQD?
	JMP	P1C6	/YES
P1C4	JMS	EOP	/OUTPUT EOP1(N)
	.WAIT	-3
	LAC	ALTMOD
	SNA		/ALT MODE?
	JMP	.+3	/NO, CR
...C	.EXIT
	.IFDEF	%S1
	.IFUND DOS
	JMS	OLAY	/OVERLAY WITH PASS1
	%B1
	%C1-1
	-%L1
	%S1
	.ENDC
	.OVLAY ALGOL@
	.ENDC
	.IFUND	%S1
	XX
	.ENDC
P1C6	JMS	CSTAT	/COPY STAT TABLE TO BOTTOM OF CORE,ETC
	.IFDEF	%S4
	.IFUND DOS
	JMS	OLAY	/OVERLAY WITH ERROR MODULE
	%B4
	%C4-1
	-%L4
	%S4
	.ENDC
	.OVLAY ALCP4@
	.ENDC
	.IFUND	%S4
	JMS	DUMP
	JMP	P1C4+3
	.ENDC
P1C8	LAC	PRESET
	SZA		/PRESET PROC OPTION SET?
	JMP	P1C9	/YES
	JMS	CSTAT	/COPY STAT TAB TO BOTTOM OF CORE,ETC
	.IFDEF	%S2
	.IFUND DOS
	JMS	OLAY	/OVERLAY WITH PASS 2
	%B2
	%C2-1
	-%L2
	%S2
	.ENDC
	.OVLAY ALCP2@
	.ENDC
	.IFUND	%S2
	JMS	DUMP
	JMP	P1C4+3
	.ENDC
	.IFDEF	%B0
	.IFUND	DOS
P1C9	JMS	OLAY	/WRITE BACK PRESET PROCS
	.ENDC
	.IFDEF	DOS
P1C9	LAC*	BLKADD	/COMPUT ABSOLUTE BLOCK #
	TAD	A%B0 /TO WRITE OUT PRESET INFO
	DAC*	P1C9DA	/TO COMPILER ON SYSTEM DEVICE
	LAC	P1C9DA
	STL		/SET LINK FOR BOOTSTRAP WRITE
	JMP*	S00155	/EXIT VIA SCOM TABLE
P1C9DA	.+1
	%B0
	.ENDC
	.IFUND	DOS
	A+%B0
	.ENDC
	%C0-1
	-%L0
	P1C4+3
	.IFDEF	DOS
A%B0	%B0
	.ENDC
	.IFUND	%B0
P1C9	JMP	P1C6
	.ENDC
	.EJECT
/GNEL:ROUTINE TO ANALYSE THE SOURCE CODE AND ATTEMPT TO FIT IT TO THE
/     FORMAT OF A SYNTAX ELEMENT. IF THE ATTEMPT SUCCEEDS A TRANSFORM-
/     ATION OF THE SOURCE IS PRODUCED ON THE REVPOL STACK IN REVERSE
/     POLISH NOTATION.
GNEL	XX
	LAC	LCT3	/REMEMBER START OF CURRENT EL
	DAC	LCT5
	LAC	CHPOS3
	DAC	CHPOS5
	DZM	EXTMRK
	LAC  ELANAL
	SAD  K1	/ELANAL=TRUE(+1)?
	JMP  GNEL18	/NO, SO REPOSITION ON NEXT VALID RESTART
	LAC  BS	/SYMBOL
	AND  S60000	/MASK "E" AND "S" BITS IN BS
	SAD  S20000	/BS=CODE FOR NORMAL ELEMENT STARTER?
	JMP  GNEL12	/YES
	SAD  S60000	/BS=CODE FOR A SHORT ELEMENT STARTER?
	JMP  GNEL4	/YES
	CLC	/BS DOES NOT HOLD AN EL STARTER: AC=-1
	DAC  ELANAL	/ELANAL:=FALSE(-1)
	LAC	BS
	SAD	SEXH	/SOURCE EXHAUSTED?
	JMP	GNEL2	/YES
	SNA		/INVALID KEYWORD?
	JMP	.+3	/YES
	LAW	-10	/REPORT ERROR 8
	JMS	ERR
	LAC	LCT6	/)
	DAC	LCT4	/)CORRECT POSN OF END
	LAC	CHPOS6	/)OF CURRENT ELEMENT
	DAC	CHPOS4	/)
	LAC	U00150	/LOAD INVEL CODE
	SKP
GNEL2	LAC	U40160	/LOAD XHEL CODE
GNEL3	DAC  CEL	/STORE IN CEL INVEL, XHEL, ENDEL, ELSEL, BEGEL OR
	JMP* GNEL	/SCEL, AND EXIT FROM GNEL
GNEL4	LAC  BS
	SAD  U60061	/BS='END'?
	JMP  GNEL32	/YES
	SAD  U60062	/BS='ELSE'?
	JMP  GNEL8	/YES
	SAD  U60060	/BS='BEGIN'?
	JMP  GNEL5	/YES
	LAC  U00110	/LOAD "SEMI-COLON ELEMENT" CODE
	SKP
GNEL5	LAC  U20120	/LOAD "'BEGIN' EL" CODE
	DAC  CEL
/CODE TO READ COMMENTS (IF ANY) AFTER ; OR 'BEGIN'
GNEL6	DZM  BSW	/CLEAR BSW WHEN ; FOUND (IRRELEVANT FIRST TIME)
	JMS  GNBS	/GET NEXT INT. CODE IN BS AND AC
	SAD  U00065	/'COMMENT'?
	SKP		/YES
	JMP* GNEL	/EXIT FROM GNEL
GNEL7	JMS  GNBS60	/GET NEXT CHAR CODE IN BSW AND AC
	SAD  U60056	/;?
	JMP  GNEL6	/YES
	SAD  U00070	/SOURCE EXHAUSTED?
	SKP	/YES
	JMP  GNEL7
	DAC  BS	/BS:=BSW
	JMP* GNEL	/EXIT FROM GNEL
/END OF CODE TO READ COMMENTS
GNEL8	JMS  GNBS	/GET NEXT BASIC SYMBOL IN BS
	LAC  U00140	/LOAD "'ELSE' EL" CODE
	JMP  GNEL3
/THIS SECTION PROCESSES ANY ELEMENT STARTING WITH 'REAL','INTEGER',
/'BOOLEAN','GOTO','IF','FOR','VALUE','ARRAY','SWITCH','PROCEDURE',
/'LABEL','STRING','OWN','EXTERNAL' OR AN IDENTIFIER.
GNEL12	DZM  CTA	/INITIALISE COUNTS
	DZM  CTB
	DZM  CTN
	DZM  CTI
	LAC  APUTR	/SWITCH OUTPUT OF ROUTINES EXIT AND OUTOP
	DAC  DEST	/TO REVPOL STACK
	LAC  ABS	/SET UP PARAMETERS CCODE AND GTNEXT FOR ENTRY TO
	DAC  CCODE	/ANAL
	LAC  AGNBS
	DAC  GTNEXT
	LAC	XB
	JMS	OBEY	/PUT XB AND LINK(.+2) ON WORK STACK
	JMP	GNEL14
	DAC	XB	/RESET XB
	LAC  APUTO	/SWITCH OUTPUT OF ROUTINES EXIT AND 
	DAC	DEST	/OUTOP BACK TO OUT STACK
	LAC  STATE
	DAC  ELANAL	/SET ELANAL ACCORDING TO STATE
	JMS	TLPTRS	/SET CCODE AND GTNEXT FOR TOP LEVEL
	LAC  RESULT
	XOR  U00000
	JMP  GNEL3	/SET CEL ACCORDING TO RESULT
GNEL14	LAC	BS
	AND	S00077	/)PERFORM TABLE LOOK-UP TO GET
	TAD	AELTAB	/)ADDR OF APPROP SYNTAX BLOCK
	DAC	XB	/SET ADDR IN XB FOR ENTRY TO ANAL
	LAC	BS
	SAD	U20055	/'EXTERNAL'?
	ISZ	EXTMRK	/YES,SO SET EXT MARKER FOR GNBS
	SAD	U20037	/BS=IDENTIFIER ?
	JMP	ANAL	/YES
	JMS	OUTOP7	/)PUT REVPOL OP
	JMS	PUTW	/)ON WORK STACK
	JMS	GNBS	/GET NEXT BASIC SYMBOL IN BS
	JMP	ANAL
/THIS SECTION REPOSITIONS ON THE SOURCE WHEN GNEL IS ENTERED WITH 
/ELANAL=FALSE(-1)
GNEL18	LAC  C1
	DAC  ELANAL	/SET ELANAL=TRUE(+1)
	LAC  BS
	JMP	GNEL20+1
GNEL19	LAC	BSW
	SNA		/BASIC SYMBOL WAITING?
	JMS	GNBS60	/NO,SO GET NEXT CHAR
	SAD	U60056	/;?
	JMP	GNEL20	/YES
	SAD	U00074	/KEYWORD QUOTE?
	JMP	GNEL20	/YES
	SAD	SEXH	/SOURCE EXHAUSTED?
	SKP		/YES
	JMP	GNEL19+2	/NO,SO GO TO GET NEXT CHAR
GNEL20	JMS  GNBS	/GET NEXT BASIC SYMBOL IN BS AND AC
	SAD	SEXH	/SOURCE EXHAUSTED?
	JMP	GNEL2
	AND  S20000	/MASK "E" BIT IN BS
	SNA		/BS=ELEMENT STARTER?
	JMP  GNEL19	/NO
	LAC  BS
	SAD  U20037	/BS=IDENTIFIER?
	JMP  GNEL19	/YES
	SAD  U20044	/BS='IF'?
	JMP	GNEL19	/YES
	SAD	U60062	/BS='ELSE'?
	JMP	GNEL19	/YES
	LAW	-1
	JMS	ERR	/REPORT ERROR 1
	JMP	GNEL+1	/RETURN TO UPDATE L+CH COUNTS
/THIS SECTION READS ANY COMMENT AFTER 'END'
GNEL30	LAC  BSW
	SNA	/SKIP IF BSW NOT CLEAR
GNEL32	JMS  GNBS60	/GET NEXT CHAR CODE IN AC AND BSW
	SAD  U00074	/BSW='?
	JMP  GNEL36	/YES
	SAD  U60056	/;?
	JMP  GNEL34	/YES
	SAD  U00070	/SOURCE EXHAUSTED?
	JMP  GNEL34	/YES
	JMP  GNEL32	/NO
GNEL34	JMS	GNBS	/CALL GNBS TO UPDATE L+CH COUNTS
	JMP  GNEL38
GNEL36	JMS  GNBS	/GET KEYWORD CODE IN AC AND BS
	SAD  U60061	/'END'?
	JMP  GNEL38	/YES
	SAD  U60062	/'ELSE'?
	JMP	GNEL38	/YES
	LAW	-60	/REPORT ERROR 48
	JMS	ERR
GNEL38	LAC	U00130	/LOAD ENDEL CODE
	JMP	GNEL3
	.EJECT
/ANAL
/ANALYSES THE SOURCE BY INTERPRETING SYNTAX BLOCKS
 
ANAL	LAC* XB
	AND	S17777
	XOR	BANK
	DAC  XB	/XB:= ADDR OF CATOM
	LAC* XB	/CATOM INTO AC
	SPA!RTL		/SKIP IF C=0 OR 1
	JMP  ANAL02	/JUMP IF ATOM NOT CODE OR MASK
	SNL!RTR		/SKIP IF C=1:CATOM IN AC
	JMP	ANAL01	/J IF C=0: CATOM IN AC
	SAD*	CCODE	/CATOM=CURRENT CODE ?
	ISZ	NXTRQD	/YES, SO MARK NEXT INPUT REQD & SKIP
	JMP	ANAL03-2
	JMP	ANAL03-3
ANAL02	SZL	/)IF C=3 THEN JUMP TO XB TO OBEY ROUTINE TO
	JMP* XB	/)DETERMINE STATE:RETURN TO ANAL03
	JMS  OBEY	/STACK XB AS LINK AND ENTER ANAL (C=2)
LANAL	JMP  ANAL	/RETURN WITH C(XB)+STATE IN AC TO ANAL03+2
ANAL01	AND*	CCODE	/MASK CURRENT CODE WITH CATOM
	SNA!STL		/MASK BIT(S) SET IN CURRENT CODE ?
	CLC!SKP		/NO, SO SET AC=-1(FALSE) AND SKIP
	GLK		/YES, SO SET AC = +1(TRUE)
/COMMON PATH ONCE CATOM HAS BEEN PROCESSED;DEALS WITH ACTION AND NEXT
ANAL03	DAC	STATE
	TAD	XB
	DAC  XB	/XB:=NEXT(STATE)
	LAC* XB		/AC:=NEXT(STATE)
	SMA		/ACTION REQD ?
	JMP	ANAL04	/NO
	LAC	XB
	TAD	STATE
	DAC	ANAL90	/ANAL90:=ADDR OF ACTION WD
	XCT*	ANAL90	/EXECUTE ACTION:JMP RETURNS TO ANAL04
	LAC*	ANAL90
	SPA!RAL		/ACTION WD WAS LAW OR ISZ INSTN?
	SMA!RAR		/YES:SKIP AGAIN IF LAW
	SKP		/ACTION WAS NOT TO REPORT ERROR
	XCT	ERRORT	/REPORT ERROR(-ERROR NO. IN AC)
ANAL04	LAC  NXTRQD
	SZA!CLC	/SKIP IF NEXT INPUT REQD (NXTRQD=0)
	JMP  .+3
	DAC  NXTRQD	/RESET NXTRQD TO -1(NEXT INPUT NOT REQD)
	JMS* GTNEXT	/GET NEXT INPUT (IN BS OR CEL)
	LAC* XB	/AC=NEXT(STATE)
	RTL	/AC0=N(STATE),L=S(STATE)
	SPA!CLC	/SKIP IF N=0(FALSE):AC=-1
	JMP  ANAL	/IF N=TRUE THEN GO TO PROCESS NEXT XB
	SZL	/SKIP IF S=0(FALSE):AC=-1
	CLA!RAL	/IF S=1(TRUE) THEN AC=+1
	DAC  STATE	/RESET STATE FROM AC
	LAC* XB
	AND  S77777
	DAC  RESULT	/SET RESULT=NEXT(15 BITS)
	JMP  EXIT	/EXIT TO LINK ON WORK STACK
	.EJECT
/PUT	
/SUBROUTINE TO PUT C(AC) ON STACK GIVEN AS A TRAILING ARGUMENT.
/CALLING SEQUENCE:
/SCRATCHPAD USED:SP00,SP01,SP02
/	JMS	PUT
/	.DSA	PTR
 
PUT	XX
	DAC	SP00
PUT01	LAC*	PUT	/LOAD ADDR OF STACK POINTER
	AND	S77777
	SAD	AOUT	/OUT SK?
	JMP	CHOUT	/YES,SO CHECK IF  DATA WD -> OUT
	DAC	STLIM	
	DAC	PTRADD
	LAC*	STLIM	/LOAD STACK POINTER
	TAD	K1	/DECREMENT STACK PTR
	DAC	STWDAD	/HOLD
	ISZ	STLIM	/STLIM:=ADDR OF STACK LIMIT
	SAD*	STLIM	/STACK OVERFLOW?
	JMP	MOVE	/YES,SO MOVE STACKS ABOUT
	DAC*	PTRADD	/INSERT NEW PTR IN STAT. TABLE
PUT02	LAC	SP00	/LOAD WORD TO BE STACKED
	DAC*	STWDAD	/PUT ON STACK
PUT03	LAC	SP00	/EXIT WITH AC PRESERVED
	ISZ	PUT	/BUMP LINK
	JMP*	PUT	
PUT04	LAC	OUBASE	/)LOAD ADDR OF WD ABOVE LAST
	TAD	SIZE	/)WD ON OUT SK
	SAD	OUT-1	/OUT SK OVERFLOW?
	JMP	PUT06	/YES
	DAC	STWDAD	
	JMS	TCA
	TAD	OUT
	SPA		/SIZE LESS THAN 40?
	ISZ	OUT	/NO,SO INCREMENT OUT PTR
	ISZ	SIZE
	JMP	PUT02
PUT06	JMS	UP	/MOVE STACKS UP OR OUTPUT BUFFER
	JMP	PUT04	/TRY AGAIN
	.EJECT
/CHOUT
/CALLED FROM ROUTINE PUT TO CHECK OUTPUT TO OUT STACK
 
CHOUT	LAC	DCT	/LOAD DATA COUNT
	SZA		/DATA WD TO BE OUTPUT?
	JMP	OUTPT2	/YES,SO GO TO OUTPUT OR IGNORE IT
	LAC	SP00	/LOAD DATA WD
	SNA		/ZERO(ONLY AT END OF COMPILATION)?
	JMP	PUT04	/YES, SO OUTPUT IT
	SMA!RTL		/DICT INFO, ERR MESS OR L+CH CTS?
	JMP	CHOUT5	/NO
	SZL		/DICT INFO?
	JMP	CHOUT1	/YES
	SPA		/ERROR MESSAGE?
	JMP	CHOUT2	/YES
	LAW	-11	/NO, L+CH CTS FOR PH3
	JMP	OUTPUT
CHOUT1	LAC	XDICT
	SZA		/EXPAND DICT INFO?
	LAW	-2	/YES
	TAD	K2	/NO
	JMP	OUTPUT
CHOUT5	SNL		/OPCODE?
	JMP	CHOUT4
	LAC	SP00	/YES
	AND	S07700
	SAD	S05400	/LABEL OP?
	SKP		/YES
	JMP	CHOUT4	/NO
	LAW	-4
	JMP	OUTPUT
CHOUT2	ISZ	EMF	/SET ERROR MSG FLG
	LAC	SP00	/LOAD ERROR MSG OPCODE WD
	AND	S00077	/MASK ARGCT FIELD
	JMS	TCA	/AC:=-NO.OF WDS IN ERROR MSG
	DAC	DCT	/SET DATA COUNT
CHOUT3	ISZ	DCT	/INCREMENT DATA COUNT(CAN GO THRU 0)
	JMP	PUT03	/EXIT FROM PUT,IGNORING OPCODE WD
	JMP	PUT03	/DITTO
CHOUT4	LAW	-1	/SET DATA COUNT=-1
 
/THIS SECTION DECIDES WHETHER TO PUT THE GIVEN DATA WD ON THE OUT SK.
OUTPUT	DAC	DCT
OUTPT2	LAC	EMF
	SZA		/ERROR MESSAGE FLAG SET?
OUTPT4	JMP	OUTPT6	/YES
	LAC	PRESET
	SZA		/PRE-SET OPTION SET?
	JMP	CHOUT3	/YES, SO IGNORE DATA WD & EXIT
	LAC	EMODE
	SZA		/ERROR MODE FLAG SET?
	JMP	CHOUT3	/YES,SO IGNORE DATA WD & EXIT
OUTPT6	ISZ	DCT	/INCREMENT DATA COUNT
	SKP		/NOW ZERO?
	DZM	EMF	/YES,SO CLEAR ERROR MSG FLG
	JMP	PUT04	/GO TO PUT DATA WD ON OUT SK
	.EJECT
PUTW	XX
	JMS	PUT
	.DSA	WORK
	JMP*	PUTW
 
PUTRP	XX
	JMS	PUT
	.DSA	REVPOL
	JMP*	PUTRP
 
PUTPOL	XX
	JMS	PUT
	.DSA	POLISH
	JMP*	PUTPOL
 
PUTOUT	XX
	JMS	PUT
	.DSA	OUT
	JMP*	PUTOUT
	.EJECT
TAKEW	XX
	LAC*	WORK
	ISZ	WORK
	JMP*	TAKEW
 
TAKERP	XX
	LAC*	REVPOL
	ISZ	REVPOL
	JMP*	TAKERP
	.EJECT
/MOVE
/CALLED FROM ROUTINE PUT TO MOVE STACKS DOWN THE CORE WHEN STACK
/OVERFLOW OCCURS.
/ENTRY:STLIM CONTAINS THE ADDRESS OF THE LOCATION IN THE STATISTICS
/TABLE FOLLOWING THE POINTER TO THE STACK WHICH OVERFLOWED.
/SCRATCHPAD USED:SP01,SP02
MOVE	LAC	STLIM
	DAC	SP01	
MOVE2	LAC*	SP01	/LOAD ADDR OF BASE OF CURRENT STACK
	SAD	OUT	/OUT SK?
	JMP	MOVE10	/YES
	ISZ	SP01	/SP01:=ADDR OF CURRENT STACK POINTER
	LAC*	SP01	
	CMA	 	/AC=-CURRENT STACK POINTER-1
	DAC	SP02	/STORE TEMPORARILY
	ISZ	SP01	/SP01:=ADDR OF NEXT BASE PTR
	LAC*	SP01
	AND	S77777	/IGNORE SIGN BIT IF SET
	TAD	SP02
	TAD	C25	/AC:=BASE(NEXT)-PTR(CURRENT)+24
	SMA		/FREE SPACE>23?
	JMP	MOVE2	/NO,SO TRY AGAIN
	LAC	SP01	
	TAD	K1
	DAC	SP01	/SP01:=ADDR Of STACK POINTER
	LAC*	SP01	/LOAD STACK POINTER
	TAD	K1	/SET UP A-I 10 WITH START ADDR FOR
	DAC*	C8	/STACK TRANSFER
	TAD	K24	/SET UP A-I 11 WITH DESTINATION
	DAC*	C9	/ADDR FOR STACK TRANSFER
	LAC*	STLIM
	CMA	
	TAD*	SP01	/AC:=PTR-(BASE + 1)
	DAC	SP02	/SET UP COUNT FOR TRANSFER LOOP
MOVE4	LAC*	AUTO	/START OF TRANSFER LOOP
	DAC*	AUTO1
	ISZ	SP02
	JMP	MOVE4	/END OF TRANSFER LOOP
/THIS SECTION UPDATES THE STATISTICS TABLE WITH THE NEW STACK POSITIONS
MOVE6	LAC*	SP01	/AC:=ADDR OF LAST ENTRY TO BE UPDATED
	TAD	K24
	DAC*	SP01	/STORE UPDATED ENTRY
	LAC	SP01
	SAD	STLIM	/TABLE UPDATED?
	JMP	MOVE8	/YES
	TAD	K1
	DAC	SP01	/DECREMENT PTR
	JMP	MOVE6
MOVE8	LAC	STWDAD
	JMP	PUT02-1
MOVE10	JMS	UP	/MOVE STACKS UP CORE, OR OUTPUT BUFFER
	JMP	PUT01
	.EJECT
/OBEY
/ROUTINE TO STACK A LINK ON THE WORK STACK AND ENTER THE ROUTINE
/SPECIFIED AS A TRAILING PARAMETER.
/A LINK ALWAYS HAS THE SIGN BIT SET.
/WHEN LINK POINTS TO ANAL, IT IS STORED AS XB WITH BITS 0-2 SET TO 110
/WHEN LINK POINTS TO PRORP,IT IS STORED AS XB WITH BITS 0-2 SET TO 111
/IN ALL OTHER CASES C(AC) IS STACKED, THEN LINK AS 15-BIT ADDR
/WITH SIGN BIT SET.
/CALLING SEQUENCE:
/	JMS	OBEY
/	JMP	ROUTINE
 
OBEY	XX
	JMS	PUTW	/PUT C(AC) ON WORK STACK
	LAC	OBEY	/GET LINK
	AND	S77777	/KEEP 15 BIT ADDR
	SAD	ALANAL	/LINK TO ANAL?
	LAC	Y00000	/YES
	SAD	ALPROP	/LINK TO PRORP?
	LAC	Z00000	/YES
	SPA		/LINK TO PRORP OR ANAL?
	JMP	OBEY2	/YES
	TAD	W00001	/SET SIGN AND STEP 1
	JMS	PUTW	/PUT LINK ON WORK STACK
	JMP*	OBEY	/ENTER ROUTINE
OBEY2	XOR	XB
	DAC*	WORK
	JMP*	OBEY
	.EJECT
/EXIT
/ROUTINE TO JUMP TO THE ADDRESS SPECIFIED BY THE LAST LINK
/STORED ON THE WORK STACK.
/CALLING SEQUENCE:
/	JMP	EXIT
EXIT	LAC	STATE	/STATE TO AC: -1=FALSE ; +1=TRUE
	SPA!CLA!STL	/AC=0 IF TRUE
	RAL		/AC=1 IF FALSE
	TAD	EXIT04	/PICK UP MODIFIED JUMP
	DAC	EXIT03	/DUMP IN CODE
	JMP	EXIT02	/ENTER LOOP
EXIT01	JMS*	DEST	/IF STATE=TRUE PUT DATA ON STACK
EXIT02	JMS	TAKEW	/TAKE CURRENT WD OFF WORK STACK
	SMA		/SKIP IF LINK
EXIT03	0		/J TO EXIT02 IF FALSE: EXIT01 IF TRUE
	DAC	SP01	/DUMP LINK ADDR
	RTL
	SZL		/LINK FROM ANAL OR PRORP?
	JMP	EXIT05	/YES
	JMS	TAKEW	/TAKE STORED AC OFF WORK STK
	JMP*	SP01	/JUMP TO IT
EXIT04	JMP	EXIT01	/DATA WORD FOR INSTRUCTION AT EXIT03
EXIT05	RAL
	LAC	SP01
	AND	S77777
	SZL		/LINK FROM ANAL?
	JMP	LPRORP+1	/NO
	TAD	STATE
	JMP	ANAL03+2
 
/CODE OBEYED ONCE ONLY THEN USED AS LOCAL STORAGE
 
P1CON	JMS	GNEL	/GET FIRST ELEMENT
	JMS	OBEY	/STACK LINK(.+2)
	JMP	ANAL+4
	JMP	P1C1
	.EJECT
/SYNTAX BLOCKS (AT BASIC SYMBOL LEVEL)
/THESE BLOCKS ARE INTERPRETED BY ANAL WHEN IT IS PROCESSING AN ELEMENT.
 
	ASEL	/FAIL IN ASSIGNMENT EL
NAME1	CX	QUAN1	/*RECURSE*
	N	NAME11
	N	NAME21
NAME11	JMP	TRES	/*TEST IF RESULT=1*
	AS+PSEL		/EXIT OK FROM PROCEDURE STATEMENT EL
	JMP	OUTOP2-2	/OUTPUT REVPOL OP
	ISZ	RESULT	/ADD 1 TO RESULT
	AN	NAME91
NAME21	CC+26		/*:=?*
	AN	NAME31
	JMP	OUTOP1	/OUTPUT REVPOL OP
	ISZ	CTA	/ADD 1 TO ARG A COUNT
	AN	NAME41
NAME31	CX	QUAN1	/*RECURSE*
	AN	NAME61
	ISZ	CTA	/ADD 1 TO ARG A COUNT
	ASEL		/FAIL IN ASSIGNMENT EL
NAME41	JMP	TRES	/*TEST IF RESULT = 1*
	N	NAME51
	ASEL		/FAIL IN ASSIGNMENT EL
NAME51	CX	EXP1	/*RECURSE*
	AS+ASEL		/EXIT OK FROM ASSIGNMENT EL
	JMP	SARGA	/SET NO. OF ARGS IN REVPOL OP
	N	NAME71
NAME61	CC+26		/* := ? *
	N	NAME81
	ASEL		/FAIL IN ASSIGNMENT EL
NAME71	CX	SEXP41	/*RECURSE*
	AS+ASEL		/EXIT OK FROM ASSIGNMENT EL
	JMP	SARGA	/SET NO. OF ARGS IN REVPOL OP
	N	NAME31
NAME81	JMP	TRES	/*TEST IF RESULT=1*
	A+ASEL		/FAIL IN ASSIGNMENT EL
	LAW	-7	/ERROR 7
	LAW	-11	/ERROR 9
	A+ASEL		/FAIL IN ASSIGNMENT EL
NAME91	JMP	TRES	/*TEST IF RESULT = 1*
	N	NAME91+4
	JMP	OUTOP2-2	/OUTPUT REVPOL OP
	AS+PSEL		/EXIT OK FROM PROCEDURE STATEMENT EL
	CC+27		/* : ? *
	AS+LBLEL		/EXIT OK FROM 'LABEL' EL
	JMP	OUTOP1	/OUTPUT REVPOL OP
	GOTEL		/FAIL
GOTO1	CX	QUAN91	/*RECURSE*
	S+GOTEL		/EXIT O.K.
	IFEL		/FAIL ON 'IF' EL
IF1	CX	EXP1	/*RECURSE*
	N	IF11
	LAW	-12	/ERROR 10
	A+IFEL		/FAIL ON 'IF' EL
IF11	CC+31		/*'THEN'?*
	S+IFEL		/EXIT OK FROM 'IF' EL
	N	EXP1
EXPS1	CC+56		/*STRING QUOTE?*
	AS		/EXIT OK
	JMP	GSTR	/READ IN STRING
	N	SEXP1
EXP1	CC+20044		/*'IF'?*
	N	EXP11
	0		/FAIL
EXP11	CX	EXP1	/*RECURSE*
	N	EXP21
	LAW	-5	/ERROR 5
	A
EXP21	CC+31		/*'THEN'?*
	AN	EXP31
	JMP	OUTOP1	/OUTPUT REVPOL OP
	0		/FAIL
EXP31	CX	SEXP1	/*RECURSE*
	N	EXP41
	LAW	-6	/ERROR 6
	A
EXP41	CC+60062		/*'ELSE'?*
	N	EXP51
	0		/FAIL
EXP51	CX	EXP1	/*RECURSE*
	S		/EXIT OK
	N	SEXP11
SEXP1	CC+10001		/*'NOT'?*
	AN	SEXP11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	N	SEXP21
SEXP11	CC+10010		/* + ? *
	AN	SEXP31
	JMP	OUTOP2-3	/OUTPUT REVPOL OP
	N	SEXP31
SEXP21	CC+10011		/* - ? *
	AN	SEXP31
	JMP	OUTOP2-4	/OUTPUT REVPOL OP
	N	SEXP71	/FAIL
SEXP31	CX	PRIM1	/*RECURSE*
	N	SEXP41
	S		/EXIT OK
SEXP41	10000		/*OPERATOR?*
	AN	SEXP51
	JMP	OUTOP1	/OUTPUT REVPOL OP
	N	SEXP61
SEXP51	10		/*ARITHMETIC OPERATOR?*
	AN	SEXP31
	JMS	GNBS	/GET NEXT BASIC SYMBOL IN BS
	AN	SEXP1
SEXP61	20		/*RELATIONAL OPERATOR?*
	AN	SEXP11
	JMS	GNBS	/GET NEXT BASIC SYMBOL IN BS
	0		/FAIL
SEXP71	JMP	TRES	/TEST IF RESULT = 1
	A		/FAIL
	LAW	-4	/REPORT ERROR 4
	N	QUAN1
PRIM1	200		/*CONSTANT OR ( ?*
	AN	PRIM11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	JMS	GNBS	/GET NEXT BASIC SYMBOL IN BS
	AS
PRIM11	CC+216		/* ( ? *
	N	PRIM21
	0		/FAIL
PRIM21	CX	EXP1	/*RECURSE*
	N	PRIM31
	LAW	-17	/ERROR 15
	A		/FAIL
PRIM31	CC+17		/* ) ? *
	S		/EXIT OK
	1		/FAIL:RESULT=1
QUAN1	CC+20037		/*IDENTIFIER?*
	AN	QUAN11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	N	QUAN51
QUAN11	CC+216		/* ( ? *
	AN	QUAN21
	JMP	SC	/SET PARAMETER COUNT TO ZERO
	2		/FAIL:RESULT=2
QUAN21	CX	EXPS1	/*RECURSE*
	N	QUAN31
	LAW	-2	/ERROR 2
	A+2		/FAIL:RESULT=2
QUAN31	JMP	PDELIM	/*PARAMETER DELIMITER?*
	AN	QUAN41
	ISZ*	WORK	/ADD 1 TO PARAMETER COUNT
	JMS	GNBS	/GET NEXT BASIC SYMBOL IN BS
	AN	QUAN21
QUAN41	CC+17		/* ) ? *
	AS+1		/EXIT OK: RESULT=1
	JMP	OUTOP1	/OUTPUT REVPOL OP
	S		/EXIT OK : RESULT=0
QUAN51	CC+106		/* LEFT SQ BRACKET ? *
	AN	QUAN61
	JMP	SC	/INITIALISE SUBSCRIPT COUNT
	3		/FAIL : RESULT = 3
QUAN61	CX	EXP1	/*RECURSE*
	AN	QUAN71
	ISZ*	WORK	/ADD 1 TO SUBSCRIPT COUNT
	N	QUAN81
QUAN71	CC+57		/* , ? *
	N	QUAN61
	LAW	-3	/ERROR 3
	A+3		/FAIL : RESULT = 3
QUAN81	CC+7		/* RIGHT SQ BRACKET ? *
	AS+3		/EXIT OK : RESULT = 3
	JMP	OUTOP1	/OUTPUT REVPOL OP
	LAW	-13	/ERROR 11
	A		/FAIL
QUAN91	CC+20037		/*IDENTIFIER?*
	AN	QUAN51
	JMP	OUTOP1	/OUTPUT REVPOL OP
	FOREL		/FAIL IN 'FOR' ELEMENT
FOR1	CX	FORL1	/*RECURSE*
	AS+FOREL		/EXIT OK FROM 'FOR' ELEMENT
	JMP	SARGA	/SET NO OF ARGS TO 'FOR' EL IN REVPOL OP
	LAW	-31	/ERROR 25
	A		/FAIL
FORL1	CC+20037		/*NAME?*
	AN	FORL11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	LAW	-32	/ERROR 26
	A		/FAIL
FORL11	CC+26		/* := ? *
	AN	FORL21
	JMP	HCV	/CV:VOCPTR TO CONTROLLED VAR:CV TO REVPOL
	0		/FAIL
FORL21	CX	FLE1	/*RECURSE*
	AN	FORL31
	ISZ	CTA	/ADD 1 TO ARG A COUNT
	N	FORL41
FORL31	CC+57		/* , ? *
	AN	FORL21
	JMP	CVR	/PUT COPY OF CV ON REVPOL
	LAW	-33	/ERROR 27
	A		/FAIL
FORL41	CC+63		/* 'DO' ? *
	S		/EXIT OK
	0		/FAIL
FLE1	CX	EXP1	/*RECURSE*
	N	FLE11
	N	FLE21
FLE11	CC+30		/* 'STEP' ? *
	AN	FLE31
	JMP	CVRS	/PUT TWO COPIES OF CV ON REVPOL
	JMP	OUTOP2-5	/OUTPUT REVPOL OP
	AS		/EXIT OK
FLE21	CC+32		/* 'WHILE' ? *
	AN	FLE61
	JMP	OUTOP1	/OUTPUT REVPOL OP
	0		/FAIL
FLE31	CX	EXP1	/*RECURSE*
	AN	FLE41
	JMP	VAB	/REMEMBER VADDR OF EXP & DO CVR
	LAW	-34	/ERROR 28
	A		/FAIL
FLE41	CC+64		/* 'UNTIL' ? *
	N	FLE51
	0		/FAIL
FLE51	CX	EXP1	/*RECURSE*
	AS		/EXIT OK
	JMP	VAC	/REMEMBER VADDR OF EXP;OPS TO REVPOL
	0		/EXIT FAIL
FLE61	CX	EXP1	/*RECURSE:PROCESS EXP*
	S		/EXIT OK
	LAW	-16	/ERROR 14
	A		/FAIL
ILST1	CC+20037		/*IDENTIFIER?*
	AN	ILST11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	S		/EXIT OK
ILST11	CC+57		/* , ? *
	AN	ILST21
	ISZ	CTN	/ADD 1 TO ARG N COUNT
	0		/EXIT FAIL
ILST21	CX	ILST1	/*RECURSE:PROCESS REST OF IDENT. LIST*
	S		/EXIT OK
	SLIST		/FAIL ON LABEL OR STRING LIST
LSTR1	CX	ILST1	/*RECURSE*
	AS+SLIST		/EXIT OK FROM LABEL OR STRING LIST
	JMP	SARGN	/SET NO. OF ARGS IN REVPOL OP
	VALEL		/FAIL
VALUE1	CX	ILST1	/*RECURSE*
	AS+VALEL
	JMP	SARGN	/SET NO. OF ARGS IN REVPOL OP
	LAW	-14	/ERROR 12
	A+SWDEC		/FAIL
SWCH1	CC+20037		/*IDENTIFIER?*
	AN	SWCH11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	LAW	-41	/ERROR 33
	A+SWDEC		/FAIL
SWCH11	CC+26		/* := ? *
	N	SWCH21
	SWDEC		/FAIL IN SWITCH DECLARATION
SWCH21	CX	GOTO1	/*RECURSE*
	AN	SWCH31
	ISZ	CTN	/ADD 1 TO ARG N COUNT
	JMP	SARGMN	/SET NO. OF ARGS IN REVPOL OP
	AS+SWDEC		/EXIT OK FROM SWITCH DECLARATION
SWCH31	CC+57		/* , ? *
	N	SWCH21
	N	TYPE31
TYPE1	CC+20047		/* 'ARRAY' ? *
	AN	TYPE11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	ARDEC!ARSP	/FAIL IN ARRAY DEC OR SPEC
TYPE11	CX	ILST1	/*RECURSE*
	AN	TYPE21
	ISZ	CTN	/ADD 1 TO ARG N COUNT
	JMP	ARD.SP	/CHANGE OP ON WORK TO ARR SPEC FROM ARD
	AS+ARSP		/EXIT OK FROM ARRAY SPEC
TYPE21	100		/* LEFT SQ BRACKET ? *
	AN	OWN51
	ISZ	CTI	/ADD 1 TO ARG I COUNT
	N	TYPE41
TYPE31	CC+20051		/* 'PROCEDURE' ? *
	AN	PROC1
	JMP	OUTOP1	/OUTPUT REVPOL OP
	TLIST		/FAIL IN TYPE LIST
TYPE41	CX	ILST1	/*RECURSE*
	AS+TLIST		/EXIT OK FROM TYPE LIST
	JMP	SARGN	/SET NO. OF ARGS IN REVPOL OP
	ARDEC		/FAIL IN ARRAY DECLARATION
OWN41	CX	ILST1	/*RECURSE*
	AN	OWN51
	ISZ	CTN	/ADD 1 TO ARG N COUNT
	ARDEC		/FAIL IN ARRAY DECLARATION
OWN51	CX	BPL1	/*RECURSE*
	AN	OWN61
	ISZ	CTA	/ADD 1 TO ARG A COUNT
	JMP	SARGA	/SET NO. OF ARGS IN REVPOL OP
	AS+ARDEC		/EXIT OK FROM ARRAY DECLARATION
OWN61	CC+57		/* , ? *
	N	OWN41
	LAW	-21	/ERROR 17
	A		/FAIL
BPL1	CC+106		/* LEFT SQ BRACKET ? *
	AN	BPL11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	0		/FAIL
BPL11	CX	IEXP1	/*RECURSE*
	AN	BPL21
	ISZ	CTB	/ADD 1 TO ARG B COUNT
	LAW	-22	/ERROR 18
	A		/FAIL
BPL21	CC+27		/* : ? *
	N	BPL31
	0		/FAIL
BPL31	CX	IEXP1	/*RECURSE*
	AN	BPL41
	ISZ	CTB	/ADD 1 TO ARG B COUNT
	JMP	SARGB	/SET NO. OF ARGS IN REVPOL OP
	AN	BPL51
BPL41	CC+57		/* , ? *
	N	BPL11
	LAW	-23	/ERROR 19
	A		/FAIL
BPL51	CC+7		/* RIGHT SQ BRACKET ? *
	AN	BPL61
	JMP	OUTOP2-1	/OUTPUT REVPOL OP
	JMP	SARGN	/SET NO. OF ARGS IN REVPOL OP
	AS		/EXIT OK
BPL61	0		/* , ? *
	LAW	-20	/ERROR 16
	A+OTDEC		/FAIL IN OWN TYPE DEC
OWN1	100000		/*'REAL','INTEGER' OR 'BOOLEAN' ? *
	AN	OWN21
	JMP	NXTOP1	/OUTPUT REVPOL OP & SET NXTRQD
	N	OWN31
OWN21	CC+20047		/* 'ARRAY' ? *
	AN	OWN41
	JMP	OUTOP1	/OUTPUT REVPOL OP
	OTDEC		/FAIL IN OWN TYPE DEC
OWN31	CX	ILST1	/*RECURSE*
	AS+OTDEC		/EXIT OK FROM OWN TYPE DEC
	JMP	SARGN	/SET NO. OF ARGS IN REVPOL OP
	LAW	-24	/ERROR 20
	A+FPEL		/FAIL IN FORMAL PARAMETER
PROC1	CC+20037		/*IDENTIFIER?*
	AN	PROC11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	S+FPEL		/EXIT OK
PROC11	CC+216		/* ( ? *
	N	PROC21
	FPEL		/FAIL IN FORMAL PARAMETER
PROC21	CX	FPAR1	/*RECURSE*
	AS+FPEL		/EXIT OK
	JMP	SARGMN
	LAW	-25	/ERROR 21
	A		/FAIL
FPAR1	CC+20037		/*IDENTIFIER?*
	AN	FPAR11
	JMP	OUTOP1	/OUTPUT REVPOL OP
	LAW	-26	/ERROR 22
	A
FPAR11	JMP	PDELIM	/* PARAMETER DELIMITER ? *
	AN	FPAR21
	ISZ	CTN	/ADD 1 TO ARG N COUNT
	JMS	GNBS	/GET NEXT BASIC SYMBOL IN BS
	AN	FPAR1
FPAR21	CC+17		/* ) ? *
	S		/EXIT OK
	N	IEXP31
IEXP1	JMP	TCTI	/* TEST IF ARG I COUNT = 1 *
	N	IEXP11
	0		/FAIL
IEXP11	CX	EXP1	/*RECURSE*
	S		/EXIT OK
	LAW	-15	/ERROR 13
	A		/FAIL
IEXP21	CC+235		/*INTEGER ? *
	AS		/EXIT OK
	JMP	OUTOP1	/OUTPUT REVPOL OP
	N	IEXP21
IEXP31	CC+10011		/*-?*
	AN	IEXP21
	JMP	OUTOP2-4	/OUTPUT REVPOL OP
	S+EXTEL		/EXIT OK
EXT1	CC+20037		/*IDENTIFIER?*
	AS+EXTEL		/EXIT OK
	JMP	OUTOP1	/OUTPUT REVPOL OP
	.EJECT
/SYNTAX BLOCKS (AT ELEMENT LEVEL).
/THESE BLOCKS ARE INTERPRETED BY ANAL WHEN IT IS PROCESSING ELEMENTS.
	LAW	-133	/ERROR 91
	AN	MODL71
MODL1	CC+BEGEL		/*BEGEL?*
	N	MODL11
	N	MODL81
MODL11	1000		/*MASK DECN*
	N	MODL91
	LAW	-137	/ERROR 95
	AN	MODL61
MODL21	CC+FPEL		/*FPEL?*
	AN	MODL41
	JMP	PH2	/DO PHASE 2 ON FPEL
	LAW	-136	/ERROR 94
	A		/FAIL
MODL31	40000		/*MASK XHEL*
	S		/EXIT OK
	LAW	-42+Z	/ERROR 34
	A		/FAIL
MODL41	JMP	PDEC	/*PROCESS PROC HEAD AND BODY*
	N	MODL51
	N	MODL31
MODL51	CC+SCEL		/*SCEL?*
	N	MODL31
	0		/EXIT FAIL
MODL61	20000		/*MASK BEGEL*
	N	MODL1
	0		/EXIT FAIL
MODL71	CC+FPEL		/*FPEL?*
	AN	MODL41
	JMP	PH2	/DO PH2 ON FPEL
	LAW	-42+Z	/ERROR 34
	A		/EXIT FAIL
MODL81	CX	CBX1	/*RECURSE TO RIGHT DEPTH*
	N	MODL51
	LAW	-42+Z	/ERROR 34
	A
MODL91	CX	CB51	/*RECURSE:RECOVER DECN*
	N	MODL51
	LAW	-135	/ERROR 93
	AS		/EXIT O.K.
SCIV1	CC+INVEL		/*INVEL?*
	N	SCIV11
	N	SCIV1
SCIV11	CC+SCEL		/*SCEL?*
	S		/EXIT O.K.
CB1	CC+BEGEL		/*BEGEL?*
	N	CB51
	JMP	BEGBL	/OPEN DICT LEVEL
	AN	CB31
CBX1	0		/*DUMMY MASK*
	0		/FAIL
CB31	CX	DEC1	/*RECURSE:PROCESS DECS*
	N	CB41
	N	CB61
CB41	CX	COMP21	/*RECURSE:PROCESS BODY*
	AS		/EXIT O.K.
	JMP	ENDBL	/CLOSE DICT LEVEL
	0		/NO,EXIT FAIL
CB61	JMP	TRES	/RESULT=1?
	N	CB31	/YES
	N	CB81
CB71	400		/*MASK VALUE PART OR SPEC*
	AN	CB51
	JMP	IGNORE	/REPORT ERROR 92 & GET NEXT EL
	N	CB91
CB81	CX	COMP21	/*RECURSE:PROCESS COMPOUND STAT*
	S		/EXIT OK
	0		/NO, EXIT FAIL
CB91	JMP	TRES	/*RESULT=1?*
	N	CB51	/YES, PROCESS WRONG EL
	N	COMP31
COMP1	CC+SCEL		/*SCEL?*
	N	COMP21
	N	CB71
CB51	1000		/*MASK DEC*
	AN	CB31
	JMP	BEGBL	/OPEN DICT LEVEL
	LAW	-141	/ERROR 97
	A+1		/FAIL:RESULT:=1
COMP11	40000		/*MASK XHEL*
	0		/FAIL
COMP21	CX	STAT11	/*RECURSE:PROCESS STAT*
	N	COMP1
	N	COMP51
COMP31	CC+INVEL		/*INVEL?*
	N	COMP21
	N	COMP11
COMP41	4000		/*MASK ELSEL OR EXTEL*
	AN	COMP21
	JMP	IGNORE
	N	COMP61
COMP51	CC+ENDEL		/*ENDEL?*
	S		/EXIT TRUE
	N	COMP41
COMP61	2000		/*MASK STATEMENT*
	AN	COMP21
	LAW	-135	/ERROR 93
	N	DEC11
DEC1	CC+FPEL		/*FPEL?*
	AN	DEC41
	JMP	PH2	/DO PHASE 2 ON FPEL
	N	DEC51
DEC11	1000		/*MASK DEC*
	AN	DEC31
	JMP	PH2	/DO PHASE 2 ON DEC
DEC31	CX	SCIV11	/*RECURSE:SCEL(IGNORING INVEL)?*
	N	DEC1
	0		/FAIL
DEC41	JMP	PDEC	/*PROCESS PROC HEAD AND BODY*
	N	DEC31	
	JMP	OUTOP2-11	/OUTPUT OP ENDD
	AS		/EXIT OK
DEC51	400		/*MASK VALUE PART OR SPEC*
	AN	DEC31
	JMP	IGNORE	/REPORT ERROR 92 & GET NEXT EL
	0		/EXIT FAIL
STAT1	CX	STAT11	/*RECURSE:PROCESS STAT*
	AS		/EXIT O.K.
	JMP	OUTOP2-7	/OUTPUT OP "ENDF" TO WORK
	N	STAT21
STAT11	CC+LBLEL		/*LBLEL?*
	AN	STAT11
	JMP	PH2	/DO PHASE 2 ON LBLEL
	N	STAT31
STAT21	CC+FOREL		/*FOREL?*
	AN	STAT1
	JMP	PH2	/DO PHASE 2 ON FOREL
	N	STAT41
STAT31	JMP	TWL	/*WORK =LINK?*
	N	STAT81
	0		/EXIT FAIL
STAT41	CX	UUS1	/*RECURSE:PROCESS UNLABELLED UNCOND STAT*
	N	STAT51
	N	STAT61
STAT51	JMP	TWL	/*WORK=LINK?*
	S		/EXIT O.K.
STAT61	CC+ELSEL		/*ELSEL?*
	AN	STAT71
	JMP	OUTOP2-10	/OUTPUT OP "ELSE" TO OUT1
	0		/EXIT FAIL
STAT71	CX	STAT11	/*RECURSE:PROCESS STAT*
	S		/EXIT O.K.
	N	STAT41
STAT81	CC+IFEL		/*IFEL?*
	AN	STAT91
	JMP	PH2	/DO PHASE 2 ON IFEL
	0		/EXIT FAIL
STAT91	CX	COND1	/*RECURSE TO CUT OUT IFEL AFTER IFEL*
	S		/EXIT O.K.
	N	CB1
UUS1	10000		/*MASK ASEL,GOTEL OR PSEL*
	AS		/EXIT O.K.
	JMP	PH2	/DO PHASE 2 ON ELEMENT
	JMP	OUTOP2	/OUTPUT OP "ENDC" TO WORK
	AN	STAT11
COND1	0		/*MASK WITH ZERO*
 
/THE FOLLOWING UPPER LEVEL SYNTAX BLOCKS ARE USED BY THE
/ACTION PDEC.
FPEL1	CX	SCIV11	/*RECURSE:SCEL(IGNORING INVEL)?*
	AN	FPEL21
	JMP	OUTOP2-6	/OUTPUT OP "ENDP" TO WORK
FPEL11	CX	SCIV11	/*RECURSE:SCEL(IGNORING INVEL)?*
	N	FPEL51
FPEL21	CC+VALEL		/*VALEL?*
	AN	FPEL11
	JMP	PH2	/DO PHASE 2 ON VALEL
	JMP	ENDSP	/CHECK PARA-SPEC CORR THEN DO ODL
	AN	FPEL41
FPEL31	400		/*MASK SPEC*
	AN	FPEL11
	JMP	PH2	/DO PHASE 2 ON SPEC
	0		/EXIT FAIL
FPEL41	CX	XSTAT1	/*RECURSE:PROCESS PROC BODY*
	AS		/EXIT O.K.
	JMS	CDL	/CLOSE DICT LEVEL ROUND PROC BODY
	N	STAT11
XSTAT1	CC+EXTEL		/*EXTEL?*
	AS		/EXIT OK
	JMP	PH2	/DO PHASE 2 ON EXTEL
	N	FPEL61
FPEL51	CC+VALEL		/*VALEL?*
	AN	FPEL11
	LAW	-140	/REPORT ERROR 96
	N	FPEL31	/NO
FPEL61	CC+INVEL	/*INVEL?*
	N	FPEL11	/YES,IGNORE IT
	.EJECT
/OUTOP1:THIS IS AN ACTION USED BY ANAL WHEN A BS CAN GENERATE A REVPOL
/OPERATOR.
OUTOP1	JMS	OUTOP7	/GENERATE OPERATOR
	JMP	RETURN	/STACK OP AND RETURN TO ANAL
 
/OUTOP2:THIS IS AN ACTION USED BY ANAL WHEN AN OPERATOR IS REQUIRED 
/       WHICH IS NOT A FUNCTION OF BS. IT GENERATES A DISPLACEMENT IN
/       THE AC WHICH IS USED FOR A TABLE LOOK-UP TO EXTRACT THE 
/       APPROPRIATE OPERATOR. ENTRY AT OUTOP2-N GENERATES 57(OCTAL)+N
/       IN THE AC.
	ISZ	ISZCT
	ISZ	ISZCT
	ISZ	ISZCT
	ISZ	ISZCT
	ISZ	ISZCT
	ISZ	ISZCT
	ISZ	ISZCT
	ISZ	ISZCT
	ISZ	ISZCT
OUTOP2	LAC  ISZCT
	DZM  ISZCT	/CLEAR COUNT
	TAD	K8
	SMA		/OUTPUT TO WORK STACK?
	JMP	.+4	/NO
	TAD	S00067
	JMS  OUTOP3	/GET OPERATOR
	JMP	RETURN	/STACK AND RETURN
	TAD	APTAB
	DAC	SP01
	LAC*	SP01	/LOAD OPERATOR
	JMS	PUTOUT	/OUTPUT IT
	JMP	ANAL04
	.EJECT
/OUTOP3:ROUTINE TO GENERATE A REVPOL OP IN THE AC,HAVING
/       REMOVED ANY OPS OF HIGHER OR EQUAL PRECEDENCE (LOWER OR
/       EQUAL NUMERICAL PROCEDENCE VALUE)FROM THE WORK STACK.
/       REMOVAL FROM THE WORK STACK OF HIGHER PRECEDENCE
/       OPS STOPS WHEN A PROGRAM LINK(NEGATIVE WORD) IS REACHED. IF THE
/       NEW OPERATOR HAS THE SIGN BIT SET THEN THE SIGN IS CLEARED
/       AND THE L.S. 6 BITS ARE FILLED FROM THE CURRENT WORD ON THE 
/       WORK STACK (TAKEN OFF).
/
/ENTRY:AC CONTAINS A POSITION IN THE LOOK-UP TABLE RVOP
/EXIT:AC CONTAINS NEW OP.
 
OUTOP3	XX
	TAD  AARVOP	/FORM ADDR OF TABLE POSITION
	DAC	OUTOP8
	LAC*	OUTOP8	/LOAD OP FROM RVOP TABLE
	SMA
	JMP  OUTOP4	/J IF ARG# NOT ON WORK STACK
/THIS SECTION TAKES THE NUMBER OF ARGS FROM THE WORK STACK AND PLACES
/THEM IN L.S. 6 BITS OF OPERATOR.
	JMS	TAKEW	/TAKE NO OF ARGS OFF WORK STACK
	JMS	TARG	/CHECK NO OF ARGS
	TAD  V77701	/FILL UP WITH MASK TO CLEAR SIGN BIT
	AND*  OUTOP8	/COMBINE WITH OPERATOR TO FORM NEW OP
/THIS SECTION DEALS WITH PRECEDENCE AND LINKS
OUTOP4	DAC	OUTOP8	/DUMP OP
	AND  Z70000
	TAD  S10000	/EXTRACT PRECEDENCE+1
	DAC	OUTOP9	/DUMP NEW PREC
OUTOP5	LAC* WORK	/EXTRACT CURRENT WORK STACK ENTRY
	SPA!CMA	/SKIP IF OPERATOR: AC = -PREC(WORK)-1
	JMP  OUTOP6	/J IF LINK ON WORK
	TAD  OUTOP9	/AC=PREC(NEW)-PREC(WORK)
	SPA
	JMP  OUTOP6	/J IF PREC(NEW)<PREC(WORK)
	JMS	TAKEW	/TAKE OP OFF WORK STACK
	JMS*	DEST	/PUT OP ONTO APPROPRIATE STACK
	JMP  OUTOP5
OUTOP6	LAC  OUTOP8	/GET NEW OPERATOR
	JMP* OUTOP3	/EXIT
/SUBROUTINE TO GENERATE A REVPOL OPERATOR FROM BS
OUTOP7	XX
	LAC	BS
	AND	S00077	/SAVE BITS 12-17 OF BS FOR TABLE LOOK-UP
	JMS	OUTOP3	/GET OP IN AC
	JMP*	OUTOP7
	.EJECT
/SARG
/ACTION: INSERT NUMBER OF ARGUMENTS TO AN OPERATOR INTO LAST WORD ON
/WORK STACK.
SARGA	ISZ	ISZCT
SARGB	ISZ	ISZCT
SARGN	JMS	SARG	/INSERT ARG COUNT
	JMP	ANAL04	/RETURN TO ANAL
 
/SARGM
/ACTION: INSERT NUMBER OF ARGUMENTS TO AN OPERATOR INTO PENULTIMATE
/WORD ON WORK STACK.
SARGMN	ISZ	WORK	/INCREMENT WORK STACK PTR
	JMS	SARG	/INSERT ARG COUNT
	LAC	WORK	/RESET PTR
	TAD	K1
	DAC	WORK
	JMP	ANAL04	/RETURN TO ANAL
 
SARG	XX
	LAC	ISZCT
	DZM	ISZCT	/CLEAR COUNT
	TAD	ACTN	/ADD FIXED DISPLACEMENT
	DAC	SP01
	LAC*	SP01	/LOAD ARG COUNT
	JMS	TARG	/CHECK NO OR ARGS
	DZM*	SP01	/CLEAR ARG COUNT
	TAD*	WORK	/ADD TO OP ON WORK STACK
	DAC*	WORK
	JMP*	SARG
 
/IGNORE	TOP LEVEL ACTION
/REPORTS ERROR 92,THEN MARKS NXTRQD TO CALL GNEL
 
IGNORE	LAW	-134
	JMS	ERR
	DZM	NXTRQD
	JMP	ANAL04
	.EJECT
/ARD.SP
/ACTION:CHANGE OP ON WORK FROM ARD (ARRAY DEC) TO ARR (ARRAY SPEC)
/       AND INSERT #SPEC IDENTS IN OPCODE WD.
ARD.SP	LAC	CTN	/GET # IDENTS
	JMS	TARG	/CHECK # WITHIN RANGE
	XOR	U00600	/INSERT ARR OPCODE
	DAC*	WORK	/REPLACE ARD OP ON WORK BY NEW OP ARR
	JMP	ANAL04
 
/NXTOP1
/ACTION	SET NXTRQD=0 AND OUTPUT REVPOL OP.
 
NXTOP1	DZM	NXTRQD
	JMP	OUTOP1
	.EJECT
/SC
/ACTION: BUY A CLEAR WORD ON WORK STACK.
SC	CLA
RETURN	JMS	PUTW
	JMP	ANAL04
 
/HCV,VAB,CVR,CVRS,VAC
/PHASE 1 ACTIONS DEALING WITH FOR CLAUSES
 
HCV	LAC*	WORK	/)REMEMBER CONTROLLED VARIABLE(CV) PTR
	DAC	CV	/)FOR OUTPUT LATER
	JMP	CVR+1
VAB	JMS	EVA	/)REMEMBER REVPOL VADDR OF END
	.DSA	RPBASE	/)OF STEP EXPRESSION
	DAC	VA2	/)FOR PHASE 2
CVR	LAC	CV	/OUTPUT CV PTR
CVR2	JMS	PUTRP
	JMP	ANAL04	/RETURN TO ANAL
 
CVRS	LAC	CV
	JMS	PUTRP	/OUTPUT CV PTR TWICE
	JMS	PUTRP
	JMS	EVA	/)REMEMBER REVPOL VADDR OF START
	.DSA	RPBASE	/)OF STEP EXPRESSION
	DAC	VA1	/) FOR PHASE 2
	JMP	OUTOP1	/OUTPUT STEP OP AND RETURN TO ANAL
 
VAC	LAC	MIN
	JMS	PUTRP	/OUTPUT MIN OP
	LAC	VA1	/)OUTPUT REVPOL VADDR OF START
	JMS	PUTRP	/)OF STEP EXP
	LAC	VA2	/)OUTPUT REVPOL VADDR OF END
	JMP	CVR2	/)OF STEP EXP
	.EJECT
/GSTR	PHASE 1 ACTION
/READ IN STRING AND PACK CHARS IN 5-7 ASCII INTO STRING STACK
/A PTR TO THE PACKED STRING IS PLACED IN THE APPROP.REVPOL OPCODE.
 
/SCRATCHPAD USED:-SP00,SP01,SP02,SP03,SP05,SP06
 
GSTR	DZM	GSTR14	/INITIALISE NO.OF WORDS IN STRING
	LAW	-5	/SET COUNT FOR NO OF
	DAC	SP06	/CHARS IN WD PR
GSTR4	JMS	GNC	/GET NEXT CHAR IN AC & NC
	SAD	S00042	/CLOSING STRING QUOTE?
	JMP	GSTR8	/YES
	SAD	S00176	/SOURCE EXHAUSTED?
	JMP	GSTR6	/YES
	SAD	S00041	/!?
	JMP	GSTR16	/YES
	JMS	GSTR50
	JMP	GSTR4
GSTR6	LAC	U00070	/PLACE INTERNAL CODE FOR
	DAC	BSW	/"SOURCE EXHAUSTED" IN BSW
	JMP	GSTR8
GSTR10	CLA
	JMS	GSTR50	/PACK IN NULL CHAR
GSTR8	LAW	-5
	SAD	SP06	/LAST NULL PACKED?
	SKP		/YES
	JMP	GSTR10	/NO
	JMS	COPY	/)MOVE PACKED STRING FROM
	M*1+WORK		/)WORK STACK TO STRING STACK,
	M*1+STRING	/)INVERTING AT SAME TIME
GSTR14	0		/NO.OF WDS TO MOVE
	LAC	GSTR14	/)PUT NO OF WDS IN STRING
	JMS	PUT	/)ON STRING STACK
	STRING
	JMS	EVA	/)FIND VADDR OF FREE END OF
	.DSA	STBASE	/)STRING STACK
	JMS	PUT	/PUT STRING VADDR ON SK
	STRING
	JMS	EVA	/FIND VADDR OF FREE END OF
	.DSA	STBASE	/STRING STACK
	DAC	STRNG	/DUMP IN REVPOL OPCODE
	DZM	BSW	/RESET BSW IN CASE !'S READ
	LAC	ERR
	SNA		/ERROR IN PASS 1 SO FAR?
	JMP	OUTOP1	/NO
	LAC	STBASE	/CLEAR STRING STACK
	DAC	STRING
	JMP	OUTOP1
	.EJECT
/THIS SECTION ANALYSES CHARACTERS BETWEEN EXCLAMATION MARKS.
 
GSTR16	JMS	GNBS60	/NEXT CH, IGNORING SPACES ETC
GSTR18	SAD	SLET	/LETTER S?
	LAC	W00040	/YES, SO LOAD ASCII FOR SPACE
	SAD	LLET	/LETTER L?
	LAC	W00015	/YES, SO LOAD ASCII FOR CR
	SAD	FLET	/LETTER F?
	LAC	W00014	/YES, SO LOAD ASCII FOR FORM-FEED
	SAD	TLET	/LETTER T?
	LAC	W00011	/YES, SO LOAD ASCII FOR HORIZ. TAB
	SAD	ELET	/LETTER E?
	LAC	W00041	/YES, SO LOAD ASCII FOR !
	SAD	ALET	/LETTER A?
	LAC	W00175	/YES,SO LOAD ASCII FOR ALT MODE
	SAD	QLET	/LETTER Q?
	LAC	W00042	/YES,SO LOAD ASCII FOR "
	SAD	EXC	/!?
	JMP	GSTR4	/YES
	SAD	EXC+1	/CLOSING STRING QUOTE?
	JMP	GSTR8	/YES
	SMA		/VALID CHAR?
	JMP	GSTR32	/NO
	XOR	W00000
	DAC	SP05	/HOLD CHAR TO BE OUTPUT
GSTR20	JMS	GNBS60	/NEXT CH, IGNORING SPACES ETC
	AND	S02000
	SNA!CLL		/DIGIT?
	JMP	GSTR22	/NO
	LAC	ISZCT
	RAL		/MULT BY 2
	DAC	ISZCT	/HOLD
	RTL		/MULT ORIG ISZCT BY 8
	TAD	ISZCT	/AC:=10*ORIG ISZCT
	DAC	ISZCT	/HOLD
	LAC	BSW
	TAD	C3
	AND	S00017	/AC:=NEW DIGIT
	TAD	ISZCT	/AC:=NEW TOTAL
	AND	V77777	/ENSURE ISZCT POSITIVE
	DAC	ISZCT
	JMP	GSTR20	/LOOP
GSTR22	LAC	ISZCT
	SNA
	LAC	C1
	JMS	TCA
	DAC	ISZCT	/SET COUNT FOR LOOP
GSTR26	LAC	SP05
	JMS	GSTR50	/OUTPUT CHAR
	ISZ	ISZCT	/END OF LOOP?
	JMP	GSTR26	/NO
	LAC	BSW
	JMP	GSTR18
GSTR32	LAW	-56+Z	/REPORT ERROR
	JMS	ERR
	DZM	ISZCT	/RESET ISZCT IN CASE ERROR IN !'S
	JMP	GSTR16
	.EJECT
/GS5
/SUBROUTINE TO SHIFT THE WD-PR NCB1,NCB2 7 BITS TO THE
/LEFT,PLACING BITS 11-17 OF THE AC IN BITS 11-17 OF NCB2,
/THEN TO PACK A FINAL ZERO INTO THE WD-PR AND PLACE IT ON THE
/WORK STACK.
 
GSTR50	XX
	JMS	MES	/GET BIT 11 OF AC IN
	JMP	R-10	/THE LINK
	DAC	NCB	/ BITS 12-17 OF AC IN 0-5 OF NCB2
	LAW	-7	/INITIALISE BIT COUNT
	DAC	SP01
GSTR52	JMS	RNUMSZ	/ROTATE ONCE
	ISZ	SP01	/LAST BIT PACKED?
	JMP	GSTR52	/NO
	ISZ	SP06	/FIFTH CH PACKED?
	JMP*	GSTR50	/NO
	DZM	NCB
	JMS	RNUMSZ	/PACK IN FINAL ZERO
	LAC	NCB1	/PUT FIRST WD ON STACK
	JMS	PUTW
	LAC	NCB2	/PUT SECOND WD ON STACK
	JMS	PUTW
	ISZ	GSTR14	/BUMP WD COUNT TWICE
	ISZ	GSTR14
	LAW	-5	/)RESET COUNT FOR NO. OF CHS
	DAC	SP06	/)IN WD-PR
	JMP*	GSTR50
	.EJECT
/BEGBL	JDSOCT 69
/BEGIN BLOCK
/INVOKED BY BEGINNING OF BLOCK AS ANAL ACTION
/CALLS ODL & OUTPUTS OPERATOR OP(BEG,1)+CHL
 
 
BEGBL	JMS	ODL
	LAC	U06501	/)OP(BEG,1)
	JMS	PUTOUT	/OUT(+)_
	LAC	CHL	/CURRENT HIERARCHY & LEVEL
BEGBL2	JMS	PUTOUT	/OUT(+)_
	JMP	ANAL04	/RETURN
 
 
/ENDBL	END BLOCK
/INVOKED BY END OF BLOCK AS ANAL ACTION
/CALLS CDL TO CLOSE DICT LEVEL & OUTPUTS OPERATOR OP(END,0)
 
ENDBL	JMS	CDL
	LAC	U06600
	JMP	BEGBL2	/OUT(+)_OP(END,0)
	.EJECT
/ENDSP	PH1 TOP LEVEL ACTION
/CALLED AT END OF PROCEDURE HEADING TO CHECK ALL PARAMS
/SPECIFIED AND TO BUY OTS FOR PARAMS
/ON ENTRY PA CONTAINS VADDR OF PROC ATTRS
 
 
ENDSP	LAC	FPLERR
	SZA		/FAILED IN LAST FPEL
	JMP	ENDSP7	/YES
	JMS	LVM	/GET VADDR OF PROC INFO
	M*2+PA		/FROM PROC ATTRS
	TAD	C3	/BUMP TO "NO. OF PARAM WDS" WD
	DAC	SP05	/HOLD
	TAD	C3	/BUMP TO PARAM COUNT WD
	DAC	SP04	/HOLD FOR PARAM WORD PTR
	JMS	LV4	/GET PARAM CT
	DAC	ARGCT	/SET AS CTR
	JMP	ENDSP5	
ENDSP2	ISZ	SP04	/BUMP TO NEXT PARAM WORD
	JMS	LV4	/GET PARAM WORD
	DAC	NAPTR	/HOLD(VADDR OF PARAM ATTS)
	SPA
	XOR	W00000
	DAC	VOCPTR	/HOLD IN VOCPTR FOR ERRORS
	AND	T70000	/EXTRACT SK#
	SNA		/STILL VOCPTR?
	JMP	ENDSP9	/YES:NO SPEC GIVEN
	JMS	LDA3	/GET SKT FOR PARAM
	JMS	XSKT	/EXPAND INTO Q
	JMS	OTS00	/BUY OTS & STORE IN PARAM ATTRS
	LAC	Q
	JMS	DVM	/PUT Q IN PARAM WD
	SP04
ENDSP5	ISZ	ARGCT	/MORE PARAMS?
	JMP	ENDSP2	/YES
	JMS	LVM	/GET SKT WD
	M*3+PA
	JMS	XSKT	/GET Q FOR PROC
	RTR		/B0(AC)_B17(Q)
	AND	W00000	/-VE IF REAL
	XOR	OTD	/CREATE NPW WD
	JMS	DVM	/& STORE IN PROC INFO
	SP05
	RAL		/L:=1 IF REAL PROC
	LAC	OTD
	SZL		/REAL?
	TAD	C2	/YES, SO OTD:=OTD+3
	TAD	C3	/NO, SO OTD:=OTD+1
	DAC	OTD	/ADD 1 FOR OLD BASE WD AND 1 FOR LINK
ENDSP7	DZM	FPLERR	/CLEAR FAILURE FLAG
	JMS	ODL	/OPEN DICT LEVEL ROUND PROC BODY
	JMP	ANAL04
ENDSP9	LAW	-116+Y	/ERROR 78:NO SPECIFICATOR
	JMS	ERR
	LAW	0
	JMP	ENDSP5-2
	.EJECT
/TCTI: CATOM TEST TO DETERMINE WHETHER THE LOCATION CTI CONTAINS 1,
/AND SET STATE ACCORDINGLY.
TCTI	LAC	CTI
	SKP
/TRES: CATOM TEST TO DETERMINE WHETHER THE LOCATION RESULT CONTAINS 1,
/AND SET STATE ACCORDINGLY.
TRES	LAC	RESULT
	SAD	C1	/SPECIFIED LOCATION = 1 ?
TRUE	CLA!STL!SKP	/YES, SO SET AC = +1 (TRUE)
FALSE	CLC!SKP		/NO, SO SET AC = -1 (FALSE)
	RAL
	JMP	ANAL03	/RETURN TO ANAL
 
/TWL: CATOM TEST TO DETERMINE WHETHER CURRENT ENTRY ON WORK STACK IS A
/LINK (WORD IS NEGATIVE), AND SET STATE ACCORDINGLY.
TWL	LAC*	WORK	/LOAD CURRENT WORD FROM WORK STACK
	SMA		/WORD=LINK ?
	JMP	FALSE	/NO, SO SET STATE=FALSE
	JMP	TRUE	/YES, SO SET STATE=TRUE
 
/PDELIM (PARAMETER DELIMITER)
/CATOM TEST TO READ A COMMENT IN A PROCEDURE PARAMETER LIST.
PDELIM	LAC	BS
	SAD	U00057	/BS = , ?
	JMP	TRUE	/YES
	XOR	U00017
	SZA		/BS = ) ?
	JMP	FALSE	/NO
	JMS	GNBS60	/ GET NEXT CHAR IN BSW AND AC
	AND	S00400
	SNA		/BSW = LETTER ?
	JMP	TRUE	/NO
PDL2	JMS	GNBS60	/GET NEXT CHAR IN AC AND BSW
	AND	S00400
	SZA		/BSW = LETTER ?
	JMP	PDL2	/YES
	LAC	BSW
	SAD	U00027	/BSW = : ?
	JMP	PDL8	/YES
PDL4	JMS	GNBS	/BS := BSW
	JMP	FALSE
PDL8	JMS	GNBS60	/GET NEXT CHAR IN AC AND BSW
	SAD	U00216	/BSW = ( ?
	SKP		/YES
	JMP	PDL4
	DZM	BSW	/CLEAR BSW
	LAC	U00057
	DAC	BS	/SET BS = ,
	JMP	TRUE
	.EJECT
/GNIN: DUMMY CATOM TEST WHICH SERVES TO GET THE NEXT UNIT OF INPUT.
GNIN	DZM	NXTRQD
	JMP	FALSE
	.EJECT
/PDEC
/CATOM TEST TO PROCESS A PROCEDURE DECLARATION.IF XHEL IS
/FOUND AFTER THE PROC BODY STATE:=FALSE;OTHERWISE STATE:=TRUE
 
/THIS SECTION INVOKES A BLOCK AFTER A PROCEDURE NAME,
/PRESERVES XB,MAXL,MAXOTD,VADDR OF PROC ATTRS & INCREMENTS HIERARCHY #
 
PDEC	LAC	XB
	JMS	PUTW	/STACK XB
	LAC	MAXL
	JMS	PUTW	/STACK MAXL
	LAC	MAXOTD
	JMS	PUTW	/STACK MAXOTD
	JMS	LDA2	/LOAD PROC INFO PTR WD FROM PROC ATTRS
	XOR	W00000	/MARK PROC ACTIVE
	DAC*	SP00	/REPLACE IN PROC ATTRS
	LAC	NAPTR	/)STACK PROCNAME ATTRS
	JMS	PUTW	/)PTR
	JMS	ODL	/OPEN DICT LEVEL (AC =HL ON RETURN)
	DZM	MAXL	/RESET MAXL TO ZERO
	DZM	MAXOTD	/MAXOTD
	DZM	OTD	/OTD
	TAD	K1
	SNA		/L=1 AND H=0?
	JMP	PDEC02	/YES:SET H=L=0
	LAC	CHL
	TAD	S00100	/H:=H+1
	AND	S03700	/GET HIERARCHY NO.
	SZA		/HIERARCHY NOW>31?
	JMP	PDEC02	/NO:OK
	LAW	-71	/)YES:ERROR 57:TOO MANY
	JMP	ODL01	/)NESTED PROCS:ABORT
PDEC02	DAC	CHL
	LAC	AFPEL1	/)SET UP XB FOR ENTRY TO
	DAC	XB	/)UPPER LEVEL SYNTAX BLOCKS
	JMS	OBEY	/WORK(+)_LINK(.+2)
	JMP	ANAL+4	/RETURN FROM OBEY TO HERE
 
/THIS SECTION TERMINATES BLOCK ENCLOSING WHOLE OF PROCEDURE,
/USES CURRENT VALUES OF MAXOTD,MAXL TO COMPUTE DNLBL,DBI IN
/PROC DATA THEN RESTORES STACKED VALUES OF MAXOTD,MAXL
  
	JMS	CDL	/CLOSE DICT LEVEL
	JMS	TAKEW	/)UNSTACK PROCNAME ATTRS
	DAC	NAPTR	/)PTR
	JMS	LDA2	/LOAD PROC INFO PTR WD
	XOR	W00000	/MARK PROC DEAD
	DAC*	SP00
	DAC	SP04
	LAC	CHL
	JMS	MES
	JMP	R-6
	AND	S00037	/EXTRACT H
	TAD	C1	/AC:=H+1
	TAD	MAXOTD	/H+1+MAXOTD(=DNLBL)
	JMS	DVM	/DEPOSIT IN DNLBL IN PROC INFO
	M*5+SP04
	TAD	MAXL	/L+DNLBL(=DBIL)
	JMS	DVM	/DEPOSIT IN DBIL IN PROC INFO
	M*4+SP04
	AND	Z60000
	SNA		/PROC OTD TOO LARGE(>4096)?
	JMP	.+3	/NO
	LAW	-73	/YES, SO REPORT ERROR
	JMS	ERR
	JMS	TAKEW
	DAC	MAXOTD	/RESTORE MAXOTD
	JMS	TAKEW
	DAC	MAXL	/RESTORE MAXL
	JMS	TAKEW	/LOAD STACKED XB
	TAD	STATE
	JMP	ANAL03+2	/RETURN TO ANAL
	.EJECT
/USEV	15/8/69	JDS
/ROUTINE TO PROCESS REFERENCE TO VARIABLE
/ON ENTRY V.ADDR OF VOCAB ENTRY HELD IN VOCPTR
/ON EXIT IF SUCCESS:VADDR OF ATTRS LEFT IN NAPTR AND Q SET UP
/		FROM SKT(ATTRS)
/            FAILED:Q SET TO INVALID AND ERROR REPORTED
 
/USES ROUTINES	FDA,ERR,CNA
 
USEV	JMS	FDA	/FIND DICT ATTR
	JMP	USEV03	/J NAME NOT USED
	JMP	USEV04	/J NAME NOT USED THIS LEVEL
	JMP	USEV02
/SCAN UPPER CHAIN LOOKING FOR DECLARED ATTRS
/ERROR FLAGGED IF ATTRS ON LABEL STACK FOUND
 
USEV01	JMS	LDA0	/GET W0RD O OF ATTRS
	SPA		/DECLARED?
	JMP	USEVOK	/YES:EXIT OK
	AND	T77777	/GET PTR TO UPPER ATTRS
	DAC	NAPTR	/DUMP IT
	AND	T70000	/EXTRACT STACK IND
	SAD	S60000	/ON DICT STACK?
	JMP	USEV01	/YES:CONT SCAN
USEV02	LAW	-66+Y	/ERROR 54:NAME ON LABEL STACK
	JMP	USEF
USEV03	LAW	-67+Y	/ERROR 55:NAME NOT KNOWN
	JMP	USEF
/NAME NOT USED THIS LEVEL:CREATE ATTRS & FIND CURRENT DECLN.
USEV04	LAC	ADICT	/SET STACK TO USE TO BE
	DAC	DLST	/DICT
	JMS	CNA	/CREATE NEW ATTRS
	JMP	USEV01	/J TO SCAN FOR DECLN.
	.EJECT
/USEL***JDSMART  31/7/69
/ROUTINE TO PROCESS REFERENCE TO LABEL
/ON ENTRY V ADDR. OF VOCAB ENTRY HELD IN VOCPTR
/ON EXIT:AS FOR USEV
 
/USES ROUTINES	FDA,CNA,ERR
 
USEL	LAC	ALABEL	/SET UP STACK TO USE
	DAC	DLST	/TO BE LABELS
	JMS	FDA	/FIND DICT ATTRS
	NOP		/IF NAME NOT IN USE AT THIS
	JMS	CNA	/LEVEL CREATE ATTRS(ASSUMED)
	JMP	USELOK	/EXIT:ATTRS OK AT THIS LEVEL
	LAW	-65+Y	/NAME A VARB. AT THIS LEVEL:ERROR 53
USEF	JMS	ERR
	LAC	S10300	/REFERENCE FAILED
	DAC	Q	/SET Q=INVALID,ACTUAL,VARIABLE
	JMP*	PRORP
USEVOK	JMS	DIPOL	/POL(+)_DICT ATTRS
	JMP	USELOK+2
USELOK	LAC	NAPTR	/POL(+)_OP(LPTR)
	JMS	PUTPOL
	JMS	LDA3	/EXTRACT SKT(ATTRS)
	JMS	XSKT	/EXPAND INTO Q
	RTL
	RTL
	AND	S40000
	XOR	Q	/)SET COMPLEX BIT IN Q
	DAC	Q	/)IF FORMAL BY NAME
	JMP*	PRORP
	.EJECT
/DECV***JDSMART  29/7/69
/HANDLE DECLARATION OF A VARIABLE (NOT LABELS)
/ON ENTRY VIRTUAL ADDRESS OF VOCAB ENTRY HELD IN VOCPTR
/EXIT LINK+1: VIRTUAL ADDR.OF NAME ATTRS IN NAPTR
/EXIT TO LINK IF NAME ALREADY DECLARED
/USES LOCN	SP00
/USES ROUTINES	FDA,LVM,ERR,CNA
 
DEC00	TRUE
	LAC	Q
	AND	S00020
	SZA		/LABEL?
	JMP	DECL	/YES
DEC	JMS	TAKERP
	DAC	VOCPTR
	LAC	ADICT	/ADDRESS OF DICT PTR
	DAC	DLST	/TO DLST FOR LATER REF
	JMS	FDA	/FIND DICT ATTRS
	JMP	DECV03	/J NAME NOT IN USE
	JMP	DECV03	/J NAME NOT USED THIS LEVEL
	JMP	DECV02	/J NAME ON LABEL STACK
DECV01	JMS	LDA0	/GET DICT ATTRS WORD 0
	SMA		/IS IT DECLARED?
	JMP	DECV04	/NO
	LAW	-62+Y	/YES;ERROR 50
	JMS	ERR
	JMP*	DEC00
/ATTRS FOUND AT THIS LEVEL ON WRONG STACK
DECV02	LAW	-63+Y	/ERROR 51:ON LABEL STACK
	JMS	ERR
	JMS	LDA0	/GET DICT ATTRS WORD 0
	AND	X77777
	XOR	U00000	/MARK 'NOT ACTIVE'
	DAC*	SP00	/REPLACE DICT ATTR WORD
	AND	T77777	/EXTRACT NATUP
	DAC	NAPTR	/DUMP IN NEW ATTRS
 
/ATTACH NEW ATTRS INTO DICT STRUCTURE
 
DECV03	JMS	CNA	/CREATE NEW NAME ATTRS
	JMS	LDA0	/LOAD DICT ATTRS WD 0
	XOR	W00000	/)MARK ATTRS 'DECLARED'
	DAC*	SP00	/)
	JMP*	DEC00
 
DECV04	LAC	DLST	/_ATTRS NOT DECLARED
	SAD	ALABEL	/IS IT A LABEL ATTR?
	JMP	DECV03+1	/YES : OK
	LAW	-70+Y	/NO
	JMS	ERR	/_ERROR 56 - USED BEFORE DECLN
	JMP	DECV03+1
 
/DECL
/ROUTINE LIKE DEC BUT HANDLES LABEL DECLARATIONS
DECL	JMS	TAKERP
	DAC	VOCPTR
	LAC	ALABEL	/)SET UP STACK TO USE
	DAC	DLST	/)TO BE LABEL STACK
	JMS	FDA	/FIND DICT ATTRS
	JMP	DECV03	/J NAME NOT IN USE
	JMP	DECV03	/J NAME NOT USED THIS LEVEL
	JMP	DECV01	/J NAME ON LABELS (OK)
	LAW	-64+Y	/ERROR 52 :ON DICT STACK
	JMP	DECV02+1
	.EJECT
/UPNPTR*JDSMART  31/9/69
/ROUTINE TO UPDATE NAME.PTR IN VOCAB ENTRY
/ON ENTRY AC HOLDS ADDRESS OF WORD GIVING ABSOLUTE ADD OF ATTRS
/	LOC 'NAPTR' HOLDS DICT.PTR TO BE PUT INTO VOCAB
/THE VIRTUAL ADDRESS OF THE VOCAB ENTRY TO BE UPDATED IS
/HELD IN WORD ONE OF NAME ATTRS SUPPLIED BY AC
 
/USES LOCATIONS	SP00,1,2
 
/USES ROUTINES	LAM,VTOA
 
UPNPTR	XX		/LINK
	DAC	SP02	/DUMP ADDR OF ATTRS ADDR
	JMS	LAM	/LOAD WORD 1 OF ATTRS
	M*1+SP02		/)INTO AC
	AND	S07777	/GET VIRTUAL ADDR OF VOCAB
	JMS	VTOA	/CONVERT TO ABS(IN SP00)
	LAC	NAPTR	/LOAD V.ADDR OF ATTRS
	AND	T77777	/MASK OFF TOP 2 BITS
	DAC*	SP00	/DUMP INTO VOCAB ENTRY
	JMP*	UPNPTR	/EXIT
	.EJECT
/CNA****JDSMART 31/7/69
/CREATE NEW NAME ATTRS IN THE DICT STRUCTURE AND ATTACH TO
/RELEVANT VOCAB ENTRY. ATTRS SET UP IN LOCNS CHL TO NAPTR.
/STACK TO USE GIVEN BY DLST
 
/USES ROUTINES	COPY,EVA,UPNPTR
 
CNA	XX
	JMS	Q.SKT	/Q INTO TOP END OF AC
	XOR	CHL	/PACK INTO CHL
	DAC	CHL
	JMS	COPY	/)COPY NEW ATTRS ONTO
	CHL		/)APPROP STACK
	M*5+DLST
	4
	LAC	S03777	/CLEAR SKT IN CHL
	AND	CHL
	DAC	CHL
	LAC	DLST	/GET STACK PTR ADDR
	TAD	K1	/CHANGE TO ADDR OF BASE
	DAC	.+2
	JMS	EVA	/EVAL VADDR OF STACK PTR
	0	/DIBASE  OR  LABASE
	DAC	NAPTR	/STORE IT
	LAC*	DLST	/GET ADDR OF NEW  NATTRS
	JMS	UPNPTR	/ATTACH TO  VOCAB
	JMP*	CNA
	.EJECT
/CDL
/CLOSE DICTIONARY LEVEL
CDL	XX
	DZM	CDL92	/CLEAR CT OF RETAINED ATTRS
	JMS	TAKEW	/UNSTACK 'OUTER LEVEL'
	DAC	CDL90	/TO CDL90
	JMS	TAKEW	/UNSTACK VADDR OF DICT PTR
	JMS	VTOA	/CONVERT IT TO ABS(INTO SP00)
	LAC	DICT	/LOAD CURRENT DICT PTR
	JMS	TCA
	TAD	SP00	/OUTER DICT PTR-CURRENT D.P.
	RCR		/COMPUTE # DICT ENTRIES
	RCR		/TO BE PROCESSED
	CMA		/(# WORDS/4)
	DAC	CDL91	/STORE -VELY
	JMP	CDL04	/J TO PROCESS THIS LEVEL ATTRS
 
CDL01	LAC*	DICT	/YES:GET NAPTR WORD OF ATTRS
	DAC	NAPTR	/AND HOLD
	SPA!RAL		/ATTR DECLARED?
	JMP	CDL02	/YES
	SPA		/ATTRS ACTIVE?
	JMP	CDL03	/NO
	JMS	LDA3
	AND	S03777	/)OUTER ATTRS
	SAD	CDL90	/OUTER ATTRS AT OUTER LEVEL?
	JMP	CDL02	/YES
	JMS	LAM	/)EXTRACT SKT FROM LOWER
	M*3+DICT		/)LEVEL ATTRS
	AND	Z74000	/)
	XOR	CDL90	/CHANGE HL TO OUTER HL
	DAC*	SP00	/RESET IN ATTRS
	JMS	COPY	/RETAIN THESE ATTRS
	M*1+DICT			/ON WORK
	M*1+WORK
	4
	ISZ	CDL92	/STEP CT.OF RETAINED ATTRS
	JMP	CDL04
 
CDL02	LAC	DICT	/UPDATE NAPTR IN VOCAB ENTRY
	JMS	UPNPTR
CDL03	LAC	DICT	/)TAKE 4 WORD ATTR
	TAD	C4	/)OFF DICT STACK
	DAC	DICT
CDL04	ISZ	CDL91	/ANY ATTRS AT THIS LEVEL
	JMP	CDL01	/YES:PROCESS IT
	LAC	CDL92	/CONVERT CT OF # OF
	CMA		/ATTRS RETAINED INTO CT FOR
	DAC	CDL92	/SETTING BACK ON STACK
	JMP	CDL06
 
CDL05	JMS	COPY	/COPY ATTR BACK TO DICT
	M*1+WORK			/FROM WORK
	M*1+DICT
	4
	JMS	EVA	/)FIND ITS NEW VIRT. ADD
	DIBASE
	DAC	NAPTR
	LAC	DICT	/)AND PUT THIS INTO VOCAB
	JMS	UPNPTR
CDL06	ISZ	CDL92	/ANY ATTRS TO PUT BACK?
	JMP	CDL05	/YES
/CLOSE  DOWN LABEL STACK LEVEL
/
	LAC	LABEL
	JMP	CDL11+2
CDL07	LAC*	CDL91	/GET NAPTR IN ATTRS
	RAL
	SPA		/IS ATTR ACTIVE?
	JMP	CDL11	/NO:IGNORE IT
	JMS	LAM	/EXTRACT HL FROM ATTRS
	M*3+CDL91
	AND	S03777
	CMA
	TAD	CHL	/CHL-HL(ATTR)
	SMA		/ATTRS AT OUTER LEVEL?
	JMP	CDL12	/YES END OF PROCESS
	LAC*	CDL91	/GET NAPTR WORD OF ATTRS
	DAC	NAPTR	/DUMP IT
	SPA		/IS ATTR DECLARED?
	JMP	CDL10	/YES:DISCARD IT
	AND	T77777	/EXTRACT PTR FIELD
	SNA		/IS NAPTR=0?
	JMP	CDL08	/YES:RETAIN AT OUTER LEVEL
	JMS	LDA3	/EXTRACT HL FROM UPNPTR ATTRS
	AND	S03777
	SAD	CDL90	/AT OUTER LEVEL?
	JMP	CDL09	/YES
CDL08	JMS	LAM	/)EXTRACT SKT FROM LOWER
	M*3+CDL91		/)LEVEL ATTRS
	AND	Z74000	/)
	XOR	CDL90
	DAC*	SP00	/CHANGE TO OUTER LEVEL
	JMP	CDL11	/J TO PROCESS NEXT
 
/FOUND ATTR AT OUTER LEVEL:DISCARD THESE ATTRS CHECKING OUTER ATTRS
/NOT ON DICT STACK
 
CDL09	LAC	NAPTR	/EXTRACT STACK INDICATOR
	AND	T70000	/FOR OUTER ATTRS
	SAD	S60000	/OUTER ON DICT STACK
	SKP		/YES:ERROR THEN DISCARD
	JMP	CDL10	/NO:DISCARD
	JMS	LDA1
	DAC	VOCPTR	/HOLD IN VOCPTR FOR ERRORS
	LAW	-130+Y	/ERROR 88:LABEL REF TO
	JMS	ERR	/VARB AT OUTER LEVEL
	LAC	U00000	/CLEAR NAPTR IN ATTRS
	JMP	CDL10+2
 
CDL10	LAC*	CDL91
	XOR	U00000	/MARK 'NOT ACTIVE'
	DAC*	CDL91
	LAC	CDL91	/UPDATE NAPTR IN VOCAB ENTRY
	JMS	UPNPTR	/TO POINT TO OUTER ATTRS
CDL11	LAC	CDL91
	TAD	C4
	DAC	CDL91
	SAD	LABASE	/LABEL SK EMPTY?
	SKP		/YES
	JMP	CDL07	/NO _ REPEAT PROCESS
/END OF CLOSING DICT PROCESS
CDL12	LAC	CHL
	AND	S00077	/=L(LEVEL)
	CMA
	TAD	MAXL	/MAXL-L-1
	RAL		/L=1 IF L>=MAXL
	LAC	CHL
	AND	S00077	/AC=L
	SZL		/L>=MAXL?
	DAC	MAXL	/YES:MAXL:=L
	LAC	OTD
	CMA
	TAD	MAXOTD	/MAXOTD-OTD-1
	RAL		/L=1 IF MAXOTD<=OTD
	LAC	OTD
	SZL		/OTD>=MAXOTD?
	DAC	MAXOTD	/YES:MAXOTD:=OTD
	JMS	TAKEW	/WORK(-)
	DAC	OTD	/OTD_
	LAC	CDL90
	DAC	CHL	/SET CHL FOR OUTER LEVEL
	JMP*	CDL	/EXIT
	.EJECT
/FDA****JDSMART  29/7/69
/FIND DICTIONARY ATTRS.
/GIVEN VOCAB.PTR IN VOCPTR AND CURRENT LEVEL IN CHL WILL
/EXIT TO LINK    IF ATPTR IN VOCAB ENTRY=0
/EXIT TO LINK+1  IF LEVEL OF ATTRS FOUND NOT AT CURRENT LEVEL
/EXIT TO LINK+2  IF ATTRS AT CURRENT LEVEL AND ON LABEL STACK
/EXIT TO LINK+3  IF ATTRS AT CURRENT LEVEL AND ON DICT STACK
/
/
FDA	XX
	JMS	LVM	/GET VIRT ADDRESS OF ATTRS
	VOCPTR		/FROM VADDR IN VOCPTR
	DAC	NAPTR	/DUMP
	SNA		/ANY ATTRS ADDRESSED?
	JMP*	FDA	/NO:EXIT TO LINK
	ISZ	FDA	/STEP LINK
	JMS	LDA3	/EXTRACT WORD HOLDING LEVEL
	AND	S03777
	SAD	CHL	/ARE ATTRS AT CURRENT LEVEL?
	SKP
	JMP*	FDA	/NO:EXIT TO LINK+1
	ISZ	FDA	/STEP LINK
	LAC	NAPTR	/GET DICT ATTR PTR
	AND	T70000	/EXTRACT STACK INDICATOR
	SAD	S60000	/ARE ATTRS ON DIXT STACK?
	ISZ	FDA	/YES:EXIT TO LINK+3
	JMP*	FDA	/NO:EXIT TO LINK+2
	.EJECT
/ODL	JDS	OCT69
/OPEN DICTIONARY LEVEL
/PRESERVES OTD,VADDR OF LAST DICT.ENTRY & CHL ON ENTRY TO A BLOCK
/OR PROCEDURE BODY. INCREMENTS LEVEL #
 
 
ODL	XX
	JMS	EVA	/)GET VADDR OF LAST
	DIBASE		/)DICT ENTRY
	DAC	OTD+1
	JMS	COPY	/)STACK:OTD
	M*0+OTD		/)VADDR(DICT)
	M*1+WORK		/)CHL
	3
	ISZ	CHL	/L:=L+1
	LAC	CHL
	AND	S00077
	SZA		/LEVEL NOW>63?
	JMP*	ODL	/NO:EXIT O.K.
	LAW	-72	/YES:ERROR 58:TOO MANY NESTED BLOCKS
ODL01	JMS	ERR
	JMP	P1C2-3	/ABORT
	.EJECT
 
/PH2
/PHASE 2:AN ACTION USED BY THE UPPER LEVEL SYNTAX BLOCKS
M=100000
PH2	CLC
	DAC	NXTRQD	/INIT. NXTRQD FOR PH2 SYNTAX BLOCKS
	SAD	ELANAL	/ELANAL=FALSE?
	JMP	PH207	/YES,SO DISCARD REVPOL
	LAC	CEL	/)
	AND	C7	/)SET Q ACCORDING TO
	TAD	ATQ	/)ELEMENT TO BE
	DAC	SP03	/)PROCESSED
	LAC*	SP03	/)
	DAC	Q	/)
	LAC	CEL
	AND	S00200
	SZA		/LINE & CHAR CTS REQD FOR PH3?
	JMP	PH210	/YES
PH201	LAC	AQ	/SET CCODE FOR ANAL
	DAC	CCODE
	LAC	APRORP	/SET GTNEXT FOR ANAL
	DAC	GTNEXT
	DZM	ASSQ	/)INITIALISE GLOBAL
	DZM	DIMA	/)LOCATIONS USED BY PH2
	LAC	APUTP	/)SWITCH ROUTINE EXIT
	DAC	DEST	/)TO POLISH STACK
	LAC	CAFC7	/)SWITCH ANAL'S TREATMENT OF
	DAC	ERRORT	/)ERRORS
	JMS	PRORP	/PROCESS REVPOL FOR ELEMENT
	JMS	POLOUT	/MOVE POLISH SK(INVERTED) TO OUT
	LAC	APUTO	/)SWITCH BACK ROUTINE EXIT
	DAC	DEST	/)TO OUT
	LAC	GNEL2-7	/)SWITCH BACK ANAL'S
	DAC	ERRORT	/)TREATMENT OF ERRORS
	JMS	TLPTRS	/SET CCODE & GTNEXT FOR TOP LEVEL
PH205	LAC	RPBASE	/DISCARD REVPOL
	DAC	REVPOL
	CLC		/PREPARE FOR GETTING NEXT UNIT OF INPUT
	JMP	ANAL04+3	/RETURN TO ANAL
PH207	LAC	CEL
	SAD	U01003	/FAILURE IN FPEL ELEMENT?
	ISZ	FPLERR	/YES,SO SET FLAG
	JMP	PH205
PH210	JMS	PACKEL	/PACK L+CH CTS INTO ERR BUFFER
	LAC	W00000
	JMS	PUTOUT
	JMS	COPY	/COPY PACKED INFO TO OUT SK
	ENUM+2
	M*1+OUT
	10
	JMP	PH201
	.EJECT
PH2ERR	XX
	DAC	SP01	/REMEMBER ERROR NO.
	LAC	Q
	AND	S00100
	SZA		/Q HAS INVALID BIT SET ?
	JMP*	PH2ERR	/YES, SO RETURN
	LAC	SP01	/LOAD ERROR NO. (NEGATIVE)
	JMS	ERR	/REPORT ERROR
	LAC	Q
	AND	Z77600
	XOR	S00100	/SET INVALID BIT IN Q
	DAC	Q
	JMP*	PH2ERR
	.EJECT
/PRORP	JDS	OCT69
/PROCESS REVERSE POLISH DATA
/IF CURRENT ENTRY ON REVPOL IS AN OPERATOR THEN IT IS MOVED TO
/WORK STACK AND IF TXB2 ENTRY HAS SIGN BIT SET THE ARG COUNT IS
/STACKED (NEGATIVELY) BEFORE ANAL IS OBEYED.
/IF CURRENT ENTRY IS VOCPTR IT IS PROCESSED AS A REFERENCE DEPENDING
/UPON Q AND PUTS THE RESULTANT DICT INFO INTO POLISH.
/IF CURRENT ENTRY IS A CONSTANT POINTER IT IS MOVED TO POLISH
/IF CURRENT ENTRY IS A REVPOL PTR A COPY OF THE INFO IS MADE ON
/END OF REVPOL AND THE ROUTINE IS REPEATED.
 
 
PRORP	XX
	JMS	TAKERP	/TAKE ENTRY FROM REVPOL
	DAC	VOCPTR	/& HOLD IN VOCPTR
	RAL
	SMA		/IS IT AN OPERATOR?
	JMP	PRORP2	/NO:ANALYSE IT
	LAC	PRORP
	JMS	PUTW	/STACK LINK TO PRORP
	JMS	OBEY	/STACK XB AS RETURN LINK(.+2)
LPRORP	JMP	PRORP1	/CONTINUE SETTING UP AT PRORP1
	DAC	XB	/ON RETURN FROM ANAL:RESET XB
	LAC	Q
	AND	S00177	/)MARK Q AS COMPLEX
	XOR	U50200	/)SORT=VAR:KIND=ACTUAL
	DAC	Q
	JMS	TAKEW
	DAC	PRORP	/RESET LINK TO PRORP
	JMP*	PRORP	/YES:EXIT
 
/SET UP OPERATOR & ARGCT ON WORK & XB FOR ANAL TO PROCESS OPERATOR
 
PRORP1	LAC	VOCPTR
	AND	U07777	/STACK OPERATOR(LESS PREC), KEEPING B1
	JMS	PUTW
	JMS	MES
	JMP	R-6
	AND	S00077	/EXTRACT OPCODE
	TAD	ATXB2	/GET ADDR OF APPROP XB
	DAC	XB
	LAC*	XB
	SMA		/ARGCT REQD?
	JMP	ANAL	/NO:ENTER ANAL
	LAC	VOCPTR	/YES:
	AND	S00077	/PUT ARGCT ONTO WORK
	JMS	TCA
	JMS	PUTW
	JMP	ANAL	/ENTER ANAL
 
/REVPOL NOT AN OPERATOR(AC=2*REVPOL WORD)
 
PRORP2	AND	Z60000	/EXTRACT PREC(SK#)
	SZA		/IS IT VPTR?(SK#=0)
	JMP	PRORP4	/NO
	LAC	Q	/YES
	AND	S00020	/IS TYPE(Q)=LABEL?
	SNA		/YES
	JMP	USEV
	JMP	USEL
 
/REVPOL A CONSTANT
 
PRORP4	SAD	U20000	/IS IT A REVPOL PTR?
	JMP	PRORP6	/YES
	RTR		/NO:MOVE STACK# INTO SKT POSN
	XOR	W00000	/PACK IN SORT=VARB:KIND=ACTUAL
	JMS	XSKT	/EXPAND RESULT INTO Q
	XOR	T00000	/MARK AS CONSTANT (K IN Q)
	DAC	Q
	LAC	VOCPTR
	JMS	PUTPOL	/POL(+)_OP(CONSTANT)
	JMP*	PRORP
 
/REVPOL A REVPOL PTR-COPY DATA DELIMITED BY PTRS TO END OF REVPOL
 
PRORP6	JMS	TAKERP	/GET VADDR(START)
PRORP7	TAD	K1	/STEP VADDR(START)
	DAC	SP04
	JMS	LV4	/LOAD WORD TO AC
	JMS	PUTRP	/REVPOL(+)_
	LAC	SP04
	SAD	VOCPTR	/REACHED VADDR(END)?
	JMP	PRORP+1	/YES:PROCESS RESULT
	JMP	PRORP7	/NO:REPEAT
	.EJECT
/PHASE 2 SYNTAX BLOCKS
 
	JMS	NQ	/MARK Q NO TYPE
	AN	EXP12
EXP2	JMP	GNIN	/*GET NEXT INPUT*
	N	EXP32
EXP12	20000		/*MASK PROC*
	AN	EXP22
	JMP	CQ	/MARK Q COMPLEX
	LAW	-104	/REPORT ERROR 68
	AS		/EXIT OK
EXP22	JMP	CDIMZ	/*CHECK THAT PROC DIM=ZERO*
	AS		/EXIT OK
	JMP	OPFC	/OUTPUT OP FC
	LAW	-74+Y	/REPORT ERROR 60
	AS		/EXIT OK
EXP32	10000		/*MASK VARIABLE*
	S		/EXIT OK
BEXP2	CX	EXP2	/*RECURSE:PROCESS EXP*
	N	BEXP12
	LAW	-126+Y	/REPORT ERROR 86
	AS		/EXIT OK
BEXP12	4		/*MASK BOOLEAN*
	S		/EXIT OK
AEXP2	CX	EXP2	/*RECURSE:PROCESS EXP*
	N	AEXP12
	LAW	-127+Y	/REPORT ERROR 87
	AS		/EXIT OK
AEXP12	JMP	IR	/*MASK INT OR REAL*
	S		/EXIT OK
PAR2	CX	EXP2	/*RECURSE:PROCESS EXP*
	0		/EXIT FAIL
NEG2	CX	AEXP2	/*RECURSE:PROCESS ARITHMETIC EXP*
	AS		/EXIT OK
	JMP	QA	/INSERT TYPE IN OP ON WORK STACK
POS2	CX	AEXP2	/*RECURSE:PROCESS ARITH EXP*
	0		/EXIT FAIL
IFEX2	CX	EXP2	/*RECURSE:PROCESS EXP*
	AN	IFEX12
	JMP	QW	/PUT Q ON WORK STACK
IFEX12	CX	EXP2	/*RECURSE:PROCESS EXP*
	AN	IFEX22
	JMP	QW	/PUT Q ON WORK STACK
IFEX22	CX	BEXP2	/*RECURSE:PROCESS
	N	IFEX32
DIV2	CX	REXP2	/*RECURSE:PROCESS EXP & FLOAT IF INT.*
	AN	DIV12
	JMP	QW	/WORK(+)_Q
DIV12	CX	REXP2	/*RECURSE:PROCESS BASE & FLOAT IF INT.*
	AN	IFEX32
	JMP	QW	/WORK(+)_Q
IFEX32	JMP	CQQ	/*CHECK VALIDITY,CREATE OP & Q*
	S		/EXIT OK
DYAD2	CX	EXP2	/*RECURSE:PROCESS EXP*
	AN	DYAD12
	JMP	QW	/WORK(+)_Q
DYAD12	CX	EXP2	/*RECURSE:PROCESS EXP*
	AN	IFEX32
	JMP	QW	/PUT Q ON WORK STACK
	N	DIV2
XPN2	JMP	TPI	/TEST IF EXPONENT IS +INT
	AN	DYAD12
	JMP	QW	/WORK(+)_Q
	JMS	OPOUT	/OUT(+)_OP(WORK)(-):WORK(+)_-ARGCT(OP)
	AN	ARD12
ARD2	JMP	QHOLD	/*REMEMBER Q AND THEN MASK OWN BIT*
	AN	ARD12
	JMS	OPOUT1	/WORK(+)_-ARGCT(WORK(-))
	DZM	NXTRQD	/PROCESS NEXT UNIT OF INPUT
	A		/EXIT FAIL
ARD12	JMP	CTANR	/*DO CARG,THEN MARK NXTRQD IF TRUE*
	N	ARD12
	JMP	OPOUT2	/DO OPOUT FOLLOWED BY POLOUT
	AN	ASEG12
ASEG2	JMP	PBPL	/*PROCESS BOUND PAIR LIST*
	AN	ASEG12
	JMS	OPOUT1	/WORK(+)_-ARGCT(WORK(-))
	N	ASEG32
ASEG12	JMP	CARG	/*INCREMENT ARGCT & TEST IF =0*
	N	ASEG22
ASEG22	JMP	DEC	/*PROCESS VARIABLE DECN*
	AN	ASEG12
	JMP	OTSA	/OBJECT TIME SPACE ALLOCATION
	JMS	POLOUT	/OUT(+)_WHOLE OF POL STACK
	A		/EXIT FAIL
ASEG32	400		/*MASK OWN*
	A		/EXIT FAIL
	JMP	DSMF	/DELETE STORAGE MAPPING FUNCTION
AF2	JMP	ARP	/*PUT OP ASS ON REVPOL & MARK NXTRQD*
	S		/EXIT O.K.
BPL12	JMP	CARG	/*INCREMENT ARGCT & TEST IF =0*
	N	BPL2
BPL2	CX	IEXP2	/*RECURSE:PROCESS BOUND PR EXP*
	N	BPL12
LAB2	JMP	DECL	/*PROCESS LABEL DECN*
	AS		/EXIT O.K.
	JMP	LABPOL	/PUT LABEL INFO ONTO POL
	S		/EXIT OK
IEXP12	1		/*MASK REAL*
	AS		/EXIT O.K.
	JMS	FIX
IEXP2	CX	AEXP2	/*RECURSE:PROCESS ARITH EXP*
	N	IEXP12
REXP2	CX	AEXP2	/*RECURSE:PROCESS ARITH EXP*
	N	REXP12
	S
REXP12	2		/*MASK INTEGER*
	AS		/EXIT OK
	JMP	CFLOAT	/SET C BIT IN Q & FLOAT EXP
	N	SV62
SV2	JMP	REFV	/*PROCESS ARRAY NAME*
	AN	SV12
	JMP	QWA	/WORK(+)_Q MOVING ARGCT
	LAW	-75+Y	/REPORT ERROR 61
	AN	SV62
SV12	4000		/*MASK ARRAY*
	AN	SV22
	JMP	CHRLY	/CHECK IF REAL ARRAY
	N	SV32
SV22	2000		/*MASK FORMAL BY NAME*
	N	SV42
	LAW	-76+Y	/REPORT ERROR 62
	AN	SV42
SV32	JMP	CDIM	/*CHECK NO.OF SUBSCRIPTS*
	N	SV42
	JMP	WQ	/Q_WORK(-)
	AS		/EXIT O.K.
SV42	JMP	CARG	/*INCREMENT ARGCT & TEST IF =0*
	N	SV52
SV52	CX	IEXP2	/*RECURSE:PROCESS SUBSCRIPT EXP*
	N	SV42
	0		/EXIT FAIL
SV62	JMP	CARG	/*INCREMENT ARGCT & TEST IF=0*
	N	SV72
SV72	CX	IEXP2	/*RECURSE:PROCESS SUBSCRIPT EXP*
	N	SV62
	0		/EXIT FAIL
VAL12	JMP	CARG	/*INCREMENT ARGCT & TEST IF =0*
	N	VAL2
	LAW	-101+Y	/REPORT ERROR 65
	AN	VAL12
VAL2	JMP	FNPV	/*FIND PARAMETER & MARK BY VALUE*
	N	VAL12
ASS2	CX	EXP2	/*RECURSE:PROCESS EXP*
	AN	ASS12
	JMP	ENDQWA	/OUTPUT END OP & PUT Q ON WORK
	JMP	ASW	/PUT ASSQ ON WORK
	AN	IFEX32
ASS12	JMP	CTANR	/*DO CARG,THEN MARK NXTRQD IF TRUE*
	N	ASS22
	LAW	-117+Y	/REPORT ERROR 79
	AN	ASS12
ASS22	JMP	BIR	/*MASK BOOLEAN INT OR REAL*
	N	ASS32
	N	ASS42
ASS32	10000		/*MASK VARIABLE*
	N	ASS62
	LAW	-120+Y	/REPORT ERROR 80
	AN	ASS12
ASS42	20000		/*MASK PROCEDURE*
	N	ASS52
	LAW	-121+Y	/REPORT ERROR 81
	AN	ASS12
ASS52	JMP	CAP	/*CHECK ASSIGNMENT TO PROC NAME*
	N	ASS62
	LAW	-122+Y	/REPORT ERROR 82
	AN	ASS12
ASS62	JMP	TASQ	/*CHECK CONSISTENCY OF LHS'S*
	N	ASS12
	N	GOTO12
GOTO2	JMP	GNIN	/*GET NEXT UNIT OF INPUT*
	LAW	-125+Y	/REPORT ERROR 85
	A		/EXIT FAIL
GOTO12	20		/*MASK LABEL*
	S		/EXIT OK
	N	FOR42
FOR2	JMP	REFV	/*PROCESS VARIABLE REFERENCE*
	AN	FOR12
	JMP	FLK	/BUY 1 WD OF OTD & OUTPUT OP FLK
	LAW	-123+Y	/REPORT ERROR 83
	N	FOR42
FOR12	10000		/*MASK VARIABLE*
	N	FOR22
	LAW	-124+Y	/REPORT ERROR 84
	N	FOR42
FOR22	JMP	IR	/*MASKK INT OR REAL*
	N	FOR32
	JMP	FLKPH3	/OUTPUT FOR LINK FOR PH3
	AS		/EXIT OK
FOR32	JMP	CTANR	/*DO CARG,THEN MARK NXTRQD IF TRUE*
	AN	FOR32
	JMP	DO	/OUTPUT DO OP
	0		/EXIT FAIL
FOR42	JMP	LOSECT	/LOSE ARG CNT FROM WORK
WH2	JMP	IFRP	/*PUT OP IFS ON REVPOL & MARK NXTRQD*
	N	AF2
STEP2	JMP	UNT	/*EXPAND UNTIL PART*
	N	STEP12
STEP12	JMP	STP	/*EXPAND STEP PART*
	N	AF2
PDEC2	JMP	DEC	/*PROCESS VARIABLE DEC*
	AN	PDEC12
	JMP	PN	/SET DIM IN PROCNAME ATTRS
	JMP	PD	/PUT DICT INFO ON POL
	AS		/EXIT OK
PDEC12	JMP	CARG	/*INCREMENT ARGCT & TEST IF =0*
	AN	PDEC12
	JMP	PRP	/PUT PARAM NAMES ONTO POL STACK
	JMP	QWA	/WORK(+)_Q MOVING ARGCT
	AN	FC32
FC2	JMP	REFV	/*PROCESS VARIABLE REFERENCE*
	AN	FC12
	JMP	QWA	/WORK(+)_Q MOVING ARGCT
	LAW	-103+Y	/REPORT ERROR 67
	AN	FC32
FC12	20000		/*MASK PROCEDURE*
	N	FC22
	LAW	-104+Y	/REPORT ERROR 68
	AN	FC32
FC22	JMP	CDIM	/*CHECK NO OF PARAMS*
	N	FC42
OWN2	JMP	OQK	/*MARK OWN IN Q & MARK NXTRQD*
	0		/EXIT FAIL
	JMP	WQ	/WORK(-)->Q
	A		/EXIT FAIL
FC32	JMP	CTANR	/*DO CARG,THEN MARK NXTRQD IF TRUE*
	N	FC32
	JMP	WQ	/Q_WORK(-)
	AS		/EXIT OK
FC42	JMP	CAFC	/CHECK ACTUAL-FORMAL CORRESPONDENCE
	JMS	NQ	/MARK NO TYPE IN Q
	AN	PC12
PC2	JMP	GNIN	/*GET NEXT UNIT OF INPUT*
	LAW	-106	/REPORT ERROR 70
	A		/EXIT FAIL
PC12	40		/*MASK NO TYPE*
	N	PC22
	ISZ	POLISH	/LOSE OP FC FROM POL SK
	AS		/EXIT OK
PC22	20000		/*MASK PROC*
	N	PC32
	LAW	-104	/REPORT ERROR 68
	A		/EXIT FAIL
PC32	JMP	CDIMZ	/*CHECK THAT # PARAMS = 0*
	S		/EXIT OK
	N	TYPE12
TYPE2	JMP	OPTQ	/*MARK TYPE IN Q & TEST IF VARIABLE*
	A		/EXIT FAIL
	ISZ	WORK	/LOSE ARGCT FROM WORK STACK
	N	DEC2	/NO
TYPE12	JMP	LEVZ	/*LEVEL ZERO(I.E.SPEC)?*
	N	SPEC2	/YES
DEC2	JMP	DEC	/*PROCESS VARIABLE DEC*
	AN	DEC12
	JMS	OTS00	/COMPUTE OBJECT TIME DISPLACEMENT
	0		/EXIT FAIL
DEC12	JMP	CARG	/*INCREMENT ARGCT & TEST IF=0*
	N	DEC2
	LAW	-77+Y	/REPORT ERROR 63
	AN	SPEC52
SPEC2	JMP	FNPK	/*FIND KIND OF NEXT PARAM*
	N	SPEC12
	N	SPEC22
SPEC12	2000		/*MASK FORMAL BY NAME*
	N	SPEC52
SPEC22	4030		/*MASK LABEL, STRING OR ARRAY*
	AN	SPEC52
	LAW	-100+Y	/REPORT ERROR 64
	0		/EXIT FAIL
SPEC52	JMP	CARG	/*INCREMENT ARGCT & TEST IF=0*
	N	SPEC2
SW2	JMP	DEC	/*PROCESS SWITCH VARIABLE DEC*
	AN	SW12
	JMP	SWD	/BUY SPACE FOR SW LIST & MARK DICT INFO
	S		/EXIT OK
SW12	JMP	CTANR	/*DO CARG,THEN MARK NXTRQD IF TRUE*
	AN	SW22
	JMP	LQ	/MARK LABEL IN Q
	LAW	-102+Y	/REPORT ERROR 66
	AN	SW12
SW22	20		/*MASK LABEL*
	N	SW12
	0		/EXIT FAIL
EXT2	JMP	CPN	/CHANGE PROCNAME IF ALIAS GIVEN
	.EJECT
/QA	PH2 ACTION
/SET TYPE INTO CONTROL FIELD IN OP ON WORK STACK
QA	LAC	Q
	RAR		/LINK=1 IF TYPE =REAL
	LAC*	WORK
	SZL
	XOR	S20000	/SET "REAL FIRST ARG" IN OP
	DAC*	WORK
	JMP	ANAL04	/RETURN TO ANAL
 
/PRP	PH2 ACTION
/MOVE VOCPTR FROM REVPOL(-) TO PROC(+)
 
PRP	JMS	TAKERP
	JMS	PUT
	PROC
	JMP	ANAL04
 
/PN	PH2 ACTION
/ARGCT(WORK) TO DIMA THEN DIM(ATTRS(NAPTR)):=-DIMA-1
 
 
PN	LAC*	WORK
	DAC	DIMA
	LAC	NAPTR	/)HOLD VADDR(PROC ATTRS)
	DAC	PA	/)FOR ACTION ENDSP
	JMS	DIM
	JMP	ANAL04
 
/DO	PH2 ACTION
/OUTPUT DO OP TO POL STACK
 
DO	LAC	U06100
	JMP	OPPOL
 
/CHRLY	PH2 ACTION
/SET BIT 4 IN SV OP ON WORK SK IF ARRAY IS TYPE REAL
 
CHRLY	LAC	Q
	AND	C1
	SZA		/REAL ARRAY?
	LAC	S20000	/YES,SO SET BIT 4
	DAC	SP06	/HOLD
	JMS	LAM	/)LOAD
	M*2+WORK		/)SV OP
	XOR	SP06
	DAC*	SP00	/REPLACE OP ON WORK SK
	JMP	ANAL04
	.EJECT
/PD	PH2 ACTION
/	FINISH SETTING UP PROC INFO ON PROC STACK AND ATTACH
/	TO PROC ATTRS.OPERATOR(WORK):=(PDEC,1)
/	DICT INFO(NAPTR)GOES TO POL(+)
 
 
PD	LAC	DIMA	
	JMS	PUT	/PROC(+)_#PARAMS+1(-VE)
	PROC
	JMS	COPY	/BUY PROC INFO SPACE FOR:-
	0		/)DBIL,DNLBL,NPW,EP
	M*1+PROC		/)NAME(2),NAME(1)
	6
	JMS	EVA
	PRBASE		/VADDR OF PROC SK
	JMS	DDA2	/SET INTO DISPL IN PROC ATTRS
	JMS	LDA1	/GET VOCPTR
	AND	S07777
	TAD	U00001
	DAC	.+2
	JMS	COPY	/COPY NAME TO LAST 2 WORDS ON PROC
	VOCPTR		/DUMPED HERE AS M*2+VOCPTR(PROC ATTRS)
	M*4+PROC
	2
	JMS	DIPOL
	JMP	ANAL04
	.EJECT
/OP	PH2 ACTION ROUTINE
/	OUT(+)_OP(WK(-));WK(+)_-ARGCT(OP)
 
OPOUT	XX
	LAC*	WORK	/OP(WORK)
	JMS	PUTOUT	/OUT(+)_
	JMS	OPOUT1	/REPLACE OP ON WORK BY -ARGCT(OP)
	JMP*	OPOUT
 
/OP1	PH2 ACTION ROUTINE
/	WORK(+)_-ARGCT(OP(WORK(-)))
 
OPOUT1	XX
	LAC*	WORK
	AND	S00077
	JMS	TCA	/AC:=-ARGCT
	DAC*	WORK
	JMP*	OPOUT1
 
/OP2	PH2 ACTION
/	OPOUT FOLLOWED BY POLOUT
 
OPOUT2	JMS	OPOUT
	JMS	POLOUT
	JMP	ANAL04
	.EJECT
/NQ	PH2 ACTION ROUTINE
/NONE TO TYPE(Q)
 
NQ	XX
	LAW	777600
	AND	Q	/HOLD SORT,KIND(Q)
	XOR	S00040	/TYPE(Q)_NONE
	DAC	Q
	JMP*	NQ
 
/CQ	PH2 ACTION
/	MARK Q AS COMPLEX
 
CQ	LAC	Q
	XOR	S40000	/Q_C
CQ01	DAC	Q
	JMP	ANAL04
 
/LQ	PH2 ACTION
/	CHANGE SORT(Q) TO VAR AND TYPE(Q) TO LABEL
 
LQ	LAC	Q
	AND	Z43600	/MASK OUT SORT AND TYPE FIELDS
	XOR	S10020
	JMP	CQ01
 
/DSMF	PH2 ACTION
/	DELETE STORAGE MAPPING FUNCTION FROM WORK STACK
DSMF	LAW	-3
	TAD	DIMA	/AC:=-#DIMS-4
	CMA		/AC:=#DIMS+3
	TAD	WORK	/)DELETE (#DIMS+3) WDS
	DAC	WORK	/)FROM WORK STACK
	JMP	ANAL04
 
/LABPOL	PH2 ACTION
/	PUT LABEL INFO ONTO POL SK
 
LABPOL	LAC	NAPTR	/PICK UP LABEL SK PTR
	JMS	PUTW	/PUT ONTO WORK SK
	JMS	LDA1	/LOAD VOCAB PTR
	DAC	NAPTR
	JMS	LDA2	/PUT NAME(2) ON POL SK
	JMS	PUTPOL
	JMS	LDA1	/PUT NAME(1) ON POL SK
	JMP	OPPOL
	.EJECT
/QWA AND ENDQWA	PH2 ACTIONS
/	OUTPUT OP END
/	PUT Q ON WORK MOVING ARGCT TO END OF STACK
 
ENDQWA	LAC	U06600
	JMS	PUTPOL
QWA	JMS	TAKEW
	DAC	ARGCT
	LAC	Q
	JMS	PUTW
	LAC	ARGCT
	JMP	RETURN
 
/QW	PH2 ACTION
/	PUT Q ON WORK
QW	LAC	Q
	JMP	RETURN
 
/WQ	PH2 ACTION
/	TAKE LAST WORD FROM WORK AND PLACE IN Q
WQ	JMS	TAKEW
	DAC	Q
	JMS	MES
	JMP	R-6
	AND	S20000	/)SET A1 BIT IN CONTROL FIELD
	XOR*	WORK	/)OF SV OP AND OF FC OP
	JMP	ARD.SP+3
 
/ASW	PH2 ACTION
/	MOVE ASSQ TO WORK(+)
 
ASW	LAC	ASSQ
	JMP	RETURN
	.EJECT
/FLK	PH2 ACTION
/	BUY OT SPACE FOR FOR LINK AND GENERATE OP(FLK,1)
/	ON POLISH
 
FLK	LAC	XDICT
	SZA		/EXPAND DICT INFO?
	LAC	C2	/YES
	TAD	C2
	TAD	POLISH	/)LOSE DICT ATTRS FOR
	DAC	POLISH	/)CONTROLLED VARIABLE
	LAC*	WORK
	SAD	K2
	JMP	ANAL04
	LAC	OTD	/CURRENT VALUE OF OTD TO POL(+)
	JMS	PUTPOL
	ISZ	OTD	/INCR OTD (1 WORD BOUGHT)
	LAC	U07001	/OP(FLK,1)
OPPOL	JMS	PUTPOL	/POL(+)_
	JMP	ANAL04	
OPFC	LAC	U03601	/OP(FC,1)
	JMP	OPPOL
	.EJECT
/SWD	PH2 ACTION
 
SWD	JMS	TAKEW
	DAC	SP04
	CMA		/# SW ELEMENTS(=N)
	DAC	.+4
	JMS	COPY	/BUY N WORDS
	0		/ON SWITCH SK
	M*1+SWITCH
	0
	JMS	PUT	/APPEND N TO SWITCH SK
	SWITCH
	JMS	EVA	/FIND VADDR OF SWITCH LIST
	SWBASE
	JMS	PUTW	/W(+)_
	JMS	DDA2	/STORE IN SWITCH ATTRS
	LAC	SP04
	JMS	PUTW	/PUT ARGCT BACK ONTO WORK
	LAW	-2
	DAC	DIMA
	JMS	DIM	/DIM(ATTRS):=1
	LAC	U06600
	JMP	OPPOL	/OP(END,0)TO POL(+)
 
/FLKPH3	PH2 ACTION
/OUTPUT FOR LINK FOR PH3 IF MORE THAN ONE ELEMENT IN FOR LIST
 
FLKPH3	LAC*	WORK	/LOAD FOR OP
	AND	S00077	/MASK ARG CT
	SAD	C2	/ONLY ONE EL IN FOR LIST?
	JMP	ANAL04	/YES
	JMP	OPPOL-1	/NO,SO OUTPUT FLK OP
	.EJECT
/OTSA	PH2 ACTION WHICH BUYS OBJECT TIME SPACE FOR ARRAYS
/BUYS ARRAY WORD FOR LOCAL ARRAYS AND OUTPUTS DICT INFO
/BUYS DOPE VECTOR AND ARRAY SPACE FOR OWN ARRAYS (NO POLISH OUTPUT)
 
 
OTSA	JMS	DIM	/SET #DIM INTO ATTRS
	LAC	Q
	AND	S00400
	SZA		/OWN ARRAY?
	JMP	OTOWN	/YES
	LAC	OTD	/NO
	JMS	DDA2	/STORE OTD FOR ARRAY WD IN ATTRS
	XOR	S60000
	JMS	PUTOUT
	ISZ	OTD	/BUY 1 WORD OT OTD
	JMP	ANAL04
OTOWN	LAC	DIMA
	CMA		/NUMBER OF DIMENSIONS
	TAD	C3	/D+3
	DAC	OTOWN1
	LAC	OTCD
	JMS	PUT	/ADDRESS OF A(L)
	OWN
	TAD	RESLT	/UPDATE OTCD
	DAC	OTCD
	JMS	EVA
	WKBASE		/VIRTUAL ADDRESS OF END OF
	DAC	SP04	/WORK STACK
	ISZ	SP04	/ADDR OF -C(N)
	JMS	COPY
	M*6+SP04
	M*1+OWN		/COPY (D+2)WORDS FROM
OTOWN1	0		/WORK TO OWN
	JMS	EVA	
	OWBASE		/ADDRESS OF END OF DOPE
	JMS	PUT	/VECTOR TO ARRAY WORD
	OWN
	TAD	K1
	JMS	DDA2	/ADDR OF ARRAY WD TO ATTRS
	JMP	ANAL04	/JUMP BACK TO ANAL04
	.EJECT
/FIX	PH2 ACTION ROUTINE
/	OUTPUT OP(FIX,1) TO POLISH
 
FIX	XX
	LAC	U07601
	JMS	PUTPOL
	ISZ	Q	/MARK Q INTEGER
	JMP*	FIX
 
/FLOAT	ROUTINE TO OUTPUT OP(FLOAT,1) TO POLISH
FLOAT	XX
	LAC	U07701
	JMS	PUTPOL
	LAC	Q
	TAD	K1
	DAC	Q
	JMP*	FLOAT
 
/CFLOAT	PH2 ACTION
/	OUTPUT OP(FLOAT,1) TO POLISH & SET COMPLEX BIT IN Q.
 
CFLOAT	LAC	Q
	AND	S40000	/SET COMPLEX BIT IF NOT ALREADY SET
	SZA
	JMP	CFL2
	LAC	S40000
	XOR	Q
	DAC	Q
CFL2	JMS	FLOAT
	JMP	ANAL04
	.EJECT
/DIPOL	DICT INFO ONTO POLISH(+)
/COPIES DICT ATTRS(VADDR IN NAPTR)ONTO POL REMOVING UPNPTR
/WORD AND ATTACHING AN OPERATOR WORD
 
 
DIPOL	XX
	LAC	XDICT
	SNA		/EXPAND DICT INFO?
	JMP	DIPOL4	/NO
	LAC	NAPTR	/VADDR OF ATTRS
	TAD	U00001	/OMIT UPNPTR WORD
	DAC	.+2
	JMS	COPY	/COPY 3 WORDS OF DICT INFO
	0		/ONTO POLISH(+)
	M*1+POLISH
	3
	LAC	Y06703	/OP(DICT INFO,3)
DIPOL2	JMS	PUTPOL	/POL(+)_
	JMP*	DIPOL
DIPOL4	JMS	LDA3	/LOAD SKTHL WD FROM DICT ATTRS
	JMS	PUTPOL	/POL(+)_
	JMS	LDA2	/LOAD DISP WD
	AND	T77777	/)SET TOP TWO BITS FOR
	XOR	Y00000	/)PUTOUT ROUTINE
	JMP	DIPOL2
	.EJECT
/DIM	SET DIM IN ATTRS FROM DIMA
/USED BY OTSA AND PN TO SET DIM IN ATTRS(VADDR IN NAPTR)
/ON ENTRY DIMA=-(#DIMS)-1 FOR ARRAYS
/	=-(#PARAMS)-1 FOR PROCS
 
 
DIM	XX
	LAC	DIMA
	CMA		/AC=#DIMS(PARAMS)
	JMS	MES
	JMP	LL+14	/TO MS 6 BITS
	DAC	ARGCT	/HOLD
	JMS	LDA1	/ACCESS DICT INFO WORD 1
	AND	S07777	/CLEAR DIM FIELD
	XOR	ARGCT	/PACK IN DIM
	DAC*	SP00	/STORE RESULT
	JMP*	DIM
	.EJECT
/OTS
/OBJECT TIME SPACE ALLOCATOR
/ON ENTRY Q CONTAINS DETAILS OF QUANTITY FOR WHICH SPACE HAS
/TO BE ALLOCATED
/THE ATTRIBUTES OF THE QUANTITY ARE POINTED TO BY VADDR IN NAPTR
 
OTS00	XX
	LAC	Q
	AND	S00400	/M(0)
	SZA
	JMP	OTSOWN	/J TO DEAL WITH OWN VARIABLE
	LAC	Q
	AND	S06011	/M(Y):M(FN):M(S):M(R)
	TAD	Z74000	/IS IT AN ARRAY?
	SMA		/NO
	JMP	OTS02	/YES:ALLOCATE 1 WORD
	TAD	S02000	/IS IT FORMAL BY NAME?
	SPA		/YES
	JMP	OTS04	/NO
	AND	S00010	/IS IT A FORMAL STRING?
	SNA		/YES:ALLOCATE 1 WORD
	ISZ	OTD	/NO:ALLOCATE 2 WORDS
OTS02	LAC	OTD
	JMS	DDA2	/STORE VALUE OF OTD IN ATTRS
	ISZ	OTD	/MAKE OTD ADDRESS NEXT SPARE LOCN
	JMP*	OTS00
 
OTS04	AND	C1	/IS IT REAL?
	SNA		/YES:ALLOCATE 3 WORDS
	JMP	OTS02	/NO:ALLOCATE 1 WORD
	ISZ	OTD
	JMP	OTS02-1
 
/OTSOWN DEALS WITH OBJECT TIME SPACE ALLOCATION FOR
/	OWN VARIABLES
 
OTSOWN	LAC	OTCD	/PUT CURRENT COMMON DISPL
	JMS	PUT	/INTO NEXT OWN LOCN
	OWN
	JMS	EVA	/FIND VADDR OF THIS LOCN
	OWBASE
	JMS	DDA2	/& STORE IN ATTRS(AS DISPL)
	ISZ	OTCD	/STEP COMMON DISPL
	LAC	Q
	AND	C1	/IS Q REAL?
	SNA		/YES
	JMP*	OTS00
	ISZ	OTCD	/ALLOCATE 3 WORDS
	ISZ	OTCD	
	JMP*	OTS00
	.EJECT
/CAFC	PH2 CATOM TEST
/CHECK ACTUAL FORMAL CORRESPONDENCE
/ON ENTRY	WORK HOLDS ARGCT (#PARAMS+1,-VE)
/	AND NAPTR VADDR OF DICT ATTRS OF PROCNAME
/ON EXIT	PARAM LIST IS EXHAUSTED AND STATE =FALSE
 
/SCRATCHPAD USED:-SP00,SP01,SP02,SP04,SP05
 
CAFC	LAC*	WORK	/HOLD ARGCT TEMPORARILY
	DAC	SP04
	CMA
	DAC	SP05	/HOLD # PARAMS(+)
	JMS	LDA2	/LOAD VADDR OF PROC INFO
	TAD	C7
	TAD	SP05	/BUMP TO Q FOR FIRST PARAM
	DAC*	WORK	/HOLD ON WORK
	LAC	SP04
	JMS	PUTW	/REPLACE ARGCT ON WORK
	LAC	AEXP22	/CHANGE XB IN CASE ANY ACTUAL
	DAC	XB	/IS A PARAM-LESS PROC
	JMP	CAFC10
CAFC2	JMS	LAM	/GET CURRENT VADDR OFF WORK
	M*1+WORK
	TAD	K1	/BUMP TO VADDR OF NEXT PARAM WD
	DAC*	SP00	/REPLACE OLD VADDR ON WORK
	DAC	SP04
	JMS	LV4	/LOAD PARAM WD
	DAC	Q	/SET Q FOR PRORP
	JMS	PUTW	/SK FORMAL Q(SORT=PROC IF PAR NOT SPECD)
	JMS	PRORP	/PROCESS ACTUAL PARAM
	JMS	TAKEW
	DAC	FQ	/REMEMBER EXPANDED FORMAL S,K,T
	LAC	Q	/GET RESULTANT Q FOR ACTUAL PARAM
	AND	S20000
	SNA		/IS SORT=PROC?
	JMP	CAFC6	/NO
	TAD	S10000	/MARK SORT=VARIABLE
	JMS	OBEY	/CHECK PROC IS PARAM-LESS
	JMP	ANAL+4	/IF SO POL(+)_OP(FC,1)
CAFC6	XOR	Q	/AC:=Q FOR ACTUAL:NOT SORT=PROC
	AND	U34177	/CLEAR KIND(Q)
	XOR	FQ	/MATCH WITH Q FOR FORMAL PARAM
	TAD	Z77000
	SZA		/SKIP IF FV & MATCH
	SAD	S01000	/SKIP IF NOT(FN & MATCH)
	JMP	CAFC8	/OK
	SAD	C3	/SKIP IF NOT(FV & ARITH)
	JMP	CAFC7+2
	LAW	-105+Y	/ERROR 69(MISMATCH)
CAFC7	JMS	PH2ERR
	JMP	CAFC10
	LAC	Q
	AND	C1	/GET TYPE(Q)
	SZA
	JMP	CAFC12
	JMS	FLOAT
CAFC8	LAC	FQ	/LOAD FORMAL S,K,T
	AND	S04004	/MASK ARRAY & BOOLEAN BITS
	TAD	Z74000
	SMA!RAR		/ARRAY?
	JMP	CAFC14	/YES
	RTR		/LINK:=1 IF BOOLEAN
	SZL		/BOOLEAN?
	JMP	CAFC18	/YES
	LAC	FQ	/LOAD FORMAL Q
CAFC9	DAC	Q	/DUMP IN Q FOR Q.SKT CALL
	JMS	Q.SKT	/AC:=PACKED FORMAL S,K,T
	JMS	MES
	JMP	R-5	/MOVE TO OPCODE FIELD
	AND	S00700	/MASK TYPE BITS
	XOR	U07000	/COMPLETE OPCODE FIELD & SET B1
	DAC	SP04	/HOLD
	LAC	Q	/LOAD FORMAL Q
	RTL		/)OBTAIN FN,FV BITS
	RAL		/)AND ARGCT FOR INSERTION
	AND	S30001	/)IN OP GIVING FORMAL PAR TYPE
	XOR	SP04	/INSERT OPCODE FIELD
	JMS	PUTPOL	/POL(+)_OP(FPT,1)
CAFC10	ISZ*	WORK	/MORE PARAMS?
	JMP	CAFC2	/YES
	ISZ	WORK	/REMOVE ARGCT FROM WORK
	LAC	AFC42
	DAC	XB	/RESET XB
	JMP	CARG+2	/WORK(-)(PARAM ADDR):FALSE
CAFC12	JMS	FIX	/OUTPUT FIX OP
	JMP	CAFC8
CAFC14	JMS	LAM	/LOAD SKT WD FROM ACTUAL DICT INFO
	M*1+POLISH
	AND	S03777	/HOLD K,H,L
	XOR	W10000	/SET S=VAR,T=INT
	DAC*	SP00
	LAC	U17201	/LOAD OP (FV,FINT,1)
	JMP	CAFC10-1
CAFC18	LAC	FQ	/LOAD FORMAL Q
	AND	Z77600	/CHANGE TYPE TO INT
	XOR	C2
	JMP	CAFC9
	.EJECT
/PBPL	PHASE 2 CATOM TEST TO PROCESS A BOUND PAIR LIST
/ EXTRACTS DIMENSIONS OF ARRAY FROM BPL OPERATOR
/PROCESSES BPL AND COMPUTES DOPE VECTOR(ON TO WORK) FOR OWN ARRAYS
 
 
PBPL	LAC*	REVPOL
	AND	S00077	/AC=2*DIM
	CMA!STL
	RAR
	DAC	DIMA	/DIMA=-D-1
	LAC	U06600
	JMS	PUTPOL
	JMS	PRORP	/PROCESS BPL
	LAC	Q3	/)SET UP Q FOR DECN
	DAC	Q	/)OF ARRAY NAMES
	AND	S00401	/M(O)
	RCR
	SNA		/OWN ARRAY?
	JMP	PBPL12	/NO:FALSE
	JMS	TAKEW	/)YES:DISCARD OP(ASEG)
	DAC	ARGCT
/CDVW	THIS SECTION CREATES A DOPE VECTOR ON WORK
/ENTRY:	POL SK HOLDS	VADDR(ON INT. SK) OF U(N)
/				"	    L(N)
/				.
/				.
/			VADDR(ON INT. SK) OF U(1)
/				"	   L(1)
/				BPL OP		_POLISH
/	WHERE THE BOUND PAIR LIST IS [L(1):U(1),...,L(N):U(N)]
/EXIT:	WORK SK HOLDS	-(NO. OF DIMS)
/			   C(N-1)
/			     .
/			     .
/			    C(1)
/			    C(0)
/			  -A[0]
/			  -C(N)		_WORK
/	WHERE C(I)=(U(I)-L(I)+1)*C(I-1) AND C(0)=1 OR 3
/	AND WHERE A[0]=SUM OF L(I)*C(I-1)
 
	LAC	DIMA
	TAD	C1	/-NUMBER OF DIMENSIONS
	JMS	PUTW	/PUT ON WORK STACK
	DAC	A0
	DAC	SP06
	RCL		/-2D
	CMA		/2D-1
	TAD	POLISH	/ADDR OF L(N)
	JMS	EVA00
	POBASE
	DAC	NAPTR	/HOLD VADDR OF L(N)
CDVW1	JMS	LDA1	/AC:= VADDR OF UPPER BOUND
	DAC	SP04
	JMS	LV4	/AC:= UPPER BOUND
	DAC	SP05
	JMS	LDA0	/AC:= VADDR OF LOWER BOUND
	DAC	SP04
	JMS	LV4	/AC:= LOWER BOUND
	CMA		/-L.B.-1
	TAD	SP05	/ADD UPPER BOUND
	TAD	C2	/ADD 2
	SPA!SNA		/RANGE >0?
	JMP	CDVW8	/NO
CDVW5	JMS	PUTW	/YES,PUT RANGE ON WORK
	LAW	-2
	TAD	NAPTR
	DAC	NAPTR
	ISZ	A0	/ANY MORE DIMENSIONS?
	JMP	CDVW1	/YES
	LAC	Q	/NO,REAL INTEGER OR
	AND	C1	/BOOLEAN?
	STL		/IF INTEGER OR BOOLEAN,1 WORD ELEMENT
	RAL		/IF REAL,3 WORD ELEMENT
	DAC	MAP	/1 OR 3 INTO MAP
	JMS	EVA
	WKBASE		/VIRTUAL ADDRESS OF THE END
	DAC	SP04	/OF THE WORK STACK
CDVW4	ISZ	NAPTR
	ISZ	NAPTR
	JMS	LDA0	/VADDR OF LOWER BOUND TO AC
	DAC	SP05
	JMS	LVM	/LOWER BOUND TO AC
	SP05
	SMA		/-VE LOWER BOUND?
	JMP	CDVW6	/NO
	JMS	TCA	/NEGATE L.B.
	JMS	MULT	/MULTIPLY BY APPROP. C
	JMS	TCA	/NEGATE RESULT
	SKP
CDVW6	JMS	MULT	/MULTIPLY ROUTINE
	TAD	A0
	DAC	A0	/SUM OF L(I)*C(I-1)
	JMS	LV4	/RANGE(I+1)
	DAC	RESLT	/INTO CN
	LAC	MAP	/C(I)
	JMS	DVM
	SP04		/LOAD C(I) ONTO WORK STACK
	LAC	RESLT	/MULTIPLY R(I+1) AND C(I) TO
	JMS	MULT	/FORM
	DAC	MAP	/C(I+1)
	ISZ	SP04
	ISZ	SP06	/ANY MORE DIMENSIONS?
	JMP	CDVW4	/YES,LOOP AGAIN
	LAC	A0
	JMS	TCA
	JMS	PUTW
	LAC	MAP
	JMS	TCA
	JMS	PUTW	/C(N) ONTO WORK STACK
	LAC	POBASE	/RESET POLISH
	DAC	POLISH	/POINTER
 
	LAC	ARGCT	/ARGCT
	JMS	PUTW	/WORK(+)_
	JMP	TRUE
CDVW8	LAW	-131	/REPORT ERROR 89
	JMS	ERR	/RANGE -VE
	LAC	C1
	JMP	CDVW5	/SET RANGE=1 AND RETURN
PBPL12	SNL		/REAL ARRAY?
	JMP	FALSE	/NO
	LAC	S10000	/YES, SO SET BIT IN BPL OP
	XOR*	POLISH
	DAC*	POLISH
	JMP	FALSE
	.EJECT
/MULT
/SUBROUTINE USED BY CDVW TO MULTIPLY INT.(+) HELD IN GLOBAL LOCN MAP
/(MULTIPLICAND) BY INT.(+) HELD IN AC ON ENTRY (MULTIPLIER).
/RESULT IN AC ON EXIT.
/SCRATCHPAD USED:- SP00,SP01,SP02,SP03,SP05
 
MULT	XX
	DZM	RESLT	/CHECK FOR 0 MULTIPLIER
	SNA
	JMP*	MULT
	DAC	SP00	/HOLD MULTIPLIER INTO SP00
	LAC	K19
	DAC	SP03	/SP03=-19 DEC
	LAC	SP00
MULT1	RAL		/SHIFT SP00 1 LEFT
	ISZ	SP03	/INCREMENT
	SNL		/LINK=0?
	JMP	MULT1	/YES,LOOP AGAIN
	DZM	SP05
	DZM	SP02
MULT2	LAC	SP00	/LOAD MULTIPLIER
	RAR		/SHIFT 1 RIGHT
	DAC	SP00	/LOAD BACK
	SNL		/LINK=0?
	JMP	MULT6	/YES
	DZM	SP05	/NO
	CLA!CLL		/AC=0
	SAD	SP02	/SP02=0?
	JMP	MULT4	/YES
	LAC	MAP	/LOAD MULTIPLICAND
MULT3	RAL		/SHIFT 1 LEFT
	DAC	SP01
	ISZ	SP05	/INCREMENT COUNT
	LAC	SP05
	SAD	SP02	/SP02 BITS MOVED?
	JMP	MULT5	/YES
	LAC	SP01	/NO
	JMP	MULT3	/LOOP AGAIN
MULT4	LAC	MAP	/LOAD MULTIPLICAND
	DAC	SP01
MULT5	LAC	RESLT
	TAD	SP01
	DAC	RESLT
MULT6	ISZ	SP02
	ISZ	SP03	/MULTIPLICAND FINISHED?
	JMP	MULT2	/NO LOOP AGAIN
	JMP*	MULT	/EXIT
	.EJECT
/CQQ	PHASE 2 CATOM TEST
/	CHECK COMPATIBILITY OF THE Q'S ASSOCIATED WITH PAIRS OF
/	ARGUMENTS & GENERATE RESULTANT Q AS FUNCTION OF OPERATOR
/	SETS UP CONTROL BITS IN PREC.FIELD OF OPERATOR
/USED IN ANALYSIS OF ASSIGNMENTS,IFEX,AND DYADICS
/ON ENTRY WORK STACK CONTAINS :-OPERATOR
/			Q(2ND ARG)
/			Q(1ST ARG)_WORK
/
/ON EXIT LOCN Q UPDATED AND OPERATOR UPDATED ON WORK STACK
 
 
CQQ	LAW	-114
	DAC	ERRNO	/ERRNO=-76
	JMS	TAKEW
	AND	S00177	/TYPE(Q(1ST ARG))
	DAC	Q	/_Q
	JMS	TAKEW
	DAC	Q2	/Q2_Q(2ND ARG)
	AND	S40000	/M(C) IN Q2
	DAC	OP	/HOLD IN OP
	LAC	Q2
	RAR		/LMK _IN (R) IN Q2
	LAC	Q
	JMS	MES	/M(R1),M(R2) TO MS 6 BITS
	JMP	R-6
	AND	S30000
	XOR	OP	/PACK INTO OPERATOR
	SAD	S20000	/1ST ARG REAL AND 2ND ARG NOT?
	XOR	S40000	/YES, SO SET COMPLEX BIT IN OP
	XOR*	WORK	/PACK INTO OP
	DAC*	WORK	/REPLACE OP ON WORK BY RESULT
	DAC	OP
	XOR	W00000	/SET SIGN BIT FOR ERROR MODULE
	DAC	VOCPTR	/HOLD IN VOCPTR FOR ERRORS
	LAC	Q2
	AND	S00070	/M(NLS) IN Q2
	SZA		/2ND ARG N,L, OR S?
	JMP	CQQ12	/YES:ERROR 71
	LAC	Q
	AND	S00070
	SZA		/1ST ARG N,L OR S?
	JMP	CQQ14	/YES:ERROR76
	LAC	Q2
	AND	S00177
	XOR	Q	/Q_TYPE(Q(1))\TYPE(Q(2))
	AND	C7	/REMOVE M(X) IF SET
	SNA		/IF BOTH ARGS OF SAME TYPE
CQQ01	LAC	Q2	/USE TYPE (Q2)
	AND	S00177
	DAC	Q	/Q_Q2(TYPE OF BOTH ARGS)
	AND	S00100
	SZA		/Q=X?
	JMP	TRUE	/YES:EXIT
	ISZ	ERRNO	/ERRNO=-75
	LAC	OP
	AND	S01000
	SZA		/IS OP=IFEXP,ASS,BOOL?
	JMP	CQQ07	/YES
	LAW	-4
	TAD	Q
	SMA		/BOTH ARGS ARITHMETIC?
	JMP	CQQ09	/NO
CQQ03	LAC	OP	/YES
	AND	S02000
	SZA		/IS OP=RELATIONAL?
	JMP	CQQ06	/YES
	LAC	C2	/NO
	SAD	Q	/BOTH ARGS INTEGER?
	JMP	TRUE	/YES
	DAC	Q
	LAC	OP	/NO
	AND	S07700
	SAD	S04400	/OP='IDIV'?
	JMP	CQQ10+2	/YES:ERROR 75
CQQ04	LAC	C1	/NO:Q_REAL
	DAC	Q	/RESULTAN TYPE TO Q
	JMP	TRUE
 
/RELATIONAL OP
CQQ06	LAW	770000
	AND*	WORK	/HOLD CAA FROM OP
	TAD	S04102	/INJECT (MINUS,2)
	JMS	PUTPOL	/POLISH(+)_
	LAC	C4	/Q_BOOLEAN
	JMP	CQQ04+1
 
/OP=IFEXP,ASS,BOOLEAN
CQQ07	ISZ	ERRNO	/ERRNO=-74
	LAC	OP
	AND	S00400
	SNA		/IS OP=BOOLEAN?
	JMP	CQQ08	/NO
	LAC	C4	/YES
	SAD	Q	/BOTH ARGS BOOLEAN?
	JMP	TRUE	/YES
	JMP	CQQ10+1	/NO:Q_BOOL ERROR74
/OP=IFEXP OR ASS
 
CQQ08	LAW	-4
	TAD	Q
	SZA!SMA		/BOTH ARGS BOOL OR ARITHMETIC?
	JMP	CQQ10-2	/NO:Q_X:ERROR 72
	SAD	K1	/ARGS OF DIFFERENT ARITH TYPE?
	JMP	CQQ04	/YES:RESULT TYPE=REAL
	JMP	TRUE	/NO:Q IS OK
 
/NON-ARITH ARGS TO ARITH OP
 
CQQ09	SZA		/BOTH ARGS BOOLEAN?
	JMP	CQQ11	/NO
	ISZ	ERRNO
	ISZ	ERRNO
CQQ10	LAC	S00100	/YES:Q_X:ERROR 73
	DAC	Q
	LAC	ERRNO
	XOR	S04000	/CLEAR ERROR TYPE 4 BIT
	JMS	ERR
	JMP	TRUE
 
CQQ11	DAC	Q	/Q_ARITH TYPE
	LAW	-115+Y	/ERROR 77
	JMS	ERR
	JMP	CQQ03	/CONTINUE
 
/2ND ARG OF WRONG TYPE
CQQ12	LAW	-107+Y	/ERROR 71
	JMS	ERR
	LAC	Q
	AND	S00070	/M(NLS)IN Q
	SZA		/1ST ARG N,L OR S?
	JMP	CQQ10	/YES:Q_X:ERROR 76
	LAC	Q	/NO
	JMP	CQQ01+3
CQQ14	LAW	-114+Y	/ERROR 76
	JMS	ERR
	JMP	CQQ01
	.EJECT
/SCANP:SUBROUTINE USED BY PH2 CATOM TESTS FNVP,FNPK
/SCAN PARAMETER LIST ON PROC STACK FOR VOCPTR HELD ON REVPOL
/ON EXIT:IF FOUND SP00 HOLDS ABS ADDR OF PARAMETER WORD
/		AND AC HOLDS CONTENTS OF THIS WORD
/IF NOT FOUND REVPOL WORD IS DISCARDED AND CONTROL GIVEN
/	IMMEDIATELY TO 'FALSE'(LINK NOT USED)
 
 
SCANP	XX
	LAC*	REVPOL
	DAC	VOCPTR	/HOLD VOCAB PTR FOR ERRORS
	LAC	PROC	/GET END OF PROC SK
	TAD	C6
	DAC	SP04	/ADDR OF # OF PARAMS
	LAC*	SP04
	DAC	SP01	/# PARAMS (-VE COUNT)
	JMP	SCANP2	/ENTER SCAN
SCANP1	ISZ	SP04	/STEP THRU PARAMS
	LAC*	SP04
	AND	V77777	/EXTRACT VPTR FROM PARAM WORD
	SAD	VOCPTR	/=VOCAB PTR FOR SPEC?
	JMP*	SCANP	/YES:EXIT
SCANP2	ISZ	SP01	/NO:END OF PARAMS?
	JMP	SCANP1	/NO:CONTINUE SCAN
	ISZ	REVPOL	/DISCARD VOCPTR ON REVPOL
	JMP	FALSE
	.EJECT
 
 
/FNPV	FIND PARAMETER WORD & MARK 'BY VALUE'(SIGN BIT)
/	IF FOUND,EXIT FALSE IF NOT FOUND
 
FNPV	LAC	FPLERR
	SZA		/PH1 FAILURE IN FPEL?
	JMP	TRUE	/YES,SO IGNORE VALUE PART
	JMS	SCANP	/SCAN PARAM LIST
	ISZ	REVPOL	/LOSE VOCPTR FROM REVPOL
	XOR	W00000	/MARK'BY VALUE'
	DAC*	SP04	/RESET PARAMETER WORD
	JMP	TRUE
 
/FNPK	FIND PARAMETER WORD & SET KIND(Q) FROM SIGN  BIT
/	USE Q TO DECLARE PARAM & SET VADDR OF ATTRS
/	FOUND INTO PARAM WORD
/IF PARAM WORD NOT FOUND EXITS FALSE(IN SCANP)
 
  
FNPK	LAC	FPLERR
	SZA		/PH1 FAILURE IN FPEL?
	JMP	FNPK10	/YES
	JMS	SCANP	/SCAN PARAM LIST
	LAC*	SP04
	RAL		/LINK_'BY VALUE'
	LAW	774177
	AND	Q
	XOR	S01000	/KIND(Q):='BY VALUE'
	SNL		/IS PARAM BY VALUE?
	TAD	S01000	/NO:MARK Q 'BY NAME'
	DAC	Q	/RESULT TO Q
	LAC	SP04
	JMS	EVA00
	PRBASE		/CONVERT ABS ADDR OF PARAM WD TO VADDR
	DAC	SP04	/HOLD
	JMS	DEC00	/DECLARE PARAM
	LAC	ATRUE	/)RESET DEC LINK
	DAC	DEC00	/)TO TRUE
	LAC	NAPTR	/PARAM ATTR TO PARAM LIST
	JMS	DVM
	SP04
	JMP	TRUE
FNPK10	LAW	774177
	AND	Q	/CLEAR KIND FIELD IN Q
	XOR	S02000	/MARK FORMAL BY NAME
	DAC	Q
	JMS	DEC00	/DECLARE SPEC VARIABLE
	LAC	ATRUE
	DAC	DEC00	/RESET LINK
	JMP	TRUE
	.EJECT
/CARG	INCREMENT -VE COUNT ON WORK
/	TRUE IF THEN NON ZERO
/	FALSE IF THEN ZERO (REMOVED FROM WORK(-))
 
CARG	ISZ*	WORK	/INCREMENT ARGCT
	JMP	TRUE	/_TRUE IF NOT ZERO
LOSECT	ISZ	WORK	/WORK(-)
	JMP	FALSE
 
/CTANR	AS CARG EXCEPT NXTRQD MARKED IF TRUE
 
CTANR	ISZ*	WORK
	JMP	OQK01	/NXTRQD:TRUE
	JMP	CARG+2
 
/CDIMZ	TRUE IF DIM(ATTRS(NAPTR))=0 ELSE FALSE
 
CDIMZ	JMS	LDA1
	AND	Z70000	/EXTRACT DIM FROM ATTRS
	JMP	REFV01
 
/REFV	PROCESS NAME ON REVPOL AS A REFERENCE
/	FALSE IF FAILED(M(X)=1) ELSE TRUE
 
REFV	JMS	NQ	/NONE -> TYPE(Q)
	JMS	PRORP
	LAC	Q
	AND	S00100	/EXTRACT M(X)
REFV01	SZA
	JMP	FALSE
	JMP	TRUE
 
/CDIM	TRUE IF DIM(ATTRS(NAPTR))=1+ARGCT(WORK)ELSE FALSE
 
CDIM	LAC*	WORK	/-ARGCT-1
	CMA
	DAC	ARGCT	/ARGCT
	JMS	LDA1
	JMS	MES	
	JMP	RR+14
	AND	S00077	/AC=DIM
	SAD	ARGCT	/DIM=ARGCT?
	JMP	TRUE	/YES
	JMP	FALSE	/NO
	.EJECT
/CAP	PH2 CATOM TEST
/CHECK ASSIGNMENT TO PROC NAME
 
CAP	JMS	LDA2	/LOAD PROC INFO PTR WD
	SMA		/PROC ACTIVE?
	JMP	FALSE	/NO
	TAD	C3	/AC:=VADDR OF NPW WD IN PROC INFO
	DAC	SP04
	JMS	LV4	/LOAD NPW WD
	SPA		/PROC REAL?
	TAD	W00002	/YES, SO ADD 4 TO NPW
	TAD	C2	/NO, SO ADD 2 TO NPW
	DAC	SP00	/HOLD
	LAC	XDICT
	SNA		/EXPAND DICT INFO?
	JMP	CAP06	/NO
	LAC	SP00
	JMS	DAM	/INSERT NEW NPW IN DISPL. WD
	M*2+POLISH
CAP04	JMS	LAM	/LOAD H,L WD FROM PROC ATTRS
	M*1+POLISH
	TAD	Z00100	/MARK AS VARIABLE, & INCREMENT HIERARCHY
	DAC*	SP00	/SET IN ATTRS
	JMP	TRUE
CAP06	LAC	SP00
	XOR	Y00000
	DAC*	POLISH
	JMP	CAP04
 
/TASQ	IF ASSQ=0 THEN ASSQ:=TYPE(Q)THEN TRUE
/	ELSE IF ASSQ=TYPE(Q) THEN TRUE ELSE FALSE
 
TASQ	LAC	ASSQ
	SZA		/ASSQ=0?
	JMP	TASQ01	/NO
	LAC	Q
	AND	S00177	/TYPE(Q)
	DAC	ASSQ	/ASSQ,_
	JMP	TRUE
TASQ01	AND	Q
	SZA		/ASSQ=TYPE(Q)?
	JMP	TRUE	/YES
	JMP	FALSE	/NO
 
/OQK	KIND(Q)_OWN:MARK NXTRQD:TRUE
 
OQK	LAW	774177
	AND	Q	/CLEAR KIND(Q)
	XOR	S00400	/KIND(Q)_OWN
	DAC	Q
OQK01	DZM	NXTRQD
	JMP	TRUE
	.EJECT
/OPTQ	TYPE(Q)_TYPE(OPCODE):IF VARB THEN FALSE ELSE TRUE
 
OPTQ	LAC	VOCPTR	/ACCESS OPERATOR
	JMS	MES
	JMP	R-6
	AND	C7	/EXTRACT OPCODE
	TAD	ATYPE	/TYPE(OPCODE)
	DAC	.+3
	LAC	Q
	AND	X77600	/CLEAR TYPE Q &D1
	XOR	TYPE	/TYPE(OPCODE)
	DAC	Q	/_Q
	AND	S10000	/M(V)
	SZA		/SKIP IF NOT M(V)
	JMP	FALSE
	JMP	OQK01
/LEVZ	TRUE IF L(CHL)=0 ELSE FALSE
 
LEVZ	LAC	CHL
	AND	S00077	/EXTRACT L FROM CHL
	JMP	REFV01
 
/STP	PROCESS STEP OPERATOR
 
STP	LAC	PLUS
	JMS	PUTRP	/REVPOL(+)_OP(PLUS,2)
 
/ARP	PROCESS AFOR OPERATOR
ARP	LAC	U01202	/OP(ASS,2)
ARP01	JMS	PUTRP	/REVPOL(+)_
	JMP	OQK01	/NEXT REQD :TRUE
 
/UNT	PROCESS UNTIL STREAM
UNT	LAC	MIN+1	/OP(MULT,2)
	JMS	PUTRP	/REVPOL(+)_
	LAC	S27776	/CONST(INTEGER 0)
	JMS	PUTRP	/REVPOL(+)_
	LAC	MIN+13	/OP(LE,2)
	JMS	PUTRP	/REVPOL(+)_
IFRP	LAC	NAME+5	/OP(IFS,1)
	JMP	ARP01	/REVPOL(+)_:NXTRQD:TRUE_
 
/QHOLD	PH2 CATOM TEST
/HOLD Q IN GLOBAL LOCN Q3 THEN IF OWN THEN TRUE ELSE FALSE
 
QHOLD	LAC	Q
	DAC	Q3
	AND	S00400
	JMP	TASQ01+1
	.EJECT
/TPI	PH2 CATOM TEST
/TEST FOR +INT (AS EXPONENT)
 
TPI	LAC*	REVPOL	/LOAD CURRENT REVPOL WD
	DAC	SP04	/HOLD IN CASE INT. SK PTR
	AND	Z70000
	SAD	S20000	/INT. SK PTR?
	SKP		/YES
	JMP	FALSE	/NO
	JMS	LV4	/LOAD INTEGER
	SPA		/+VE?
	JMP	FALSE	/NO
	JMS	PRORP	/YES, SO PROCESS IT
	JMP	TRUE
 
/CPN	PH2 CATOM TEST
/	CHANGE PROCNAME IF ALIAS GIVEN
 
CPN	LAC	REVPOL	/LOAD REVPOL PTR
	SAD	RPBASE	/=BASE?
	JMP	CPN2	/YES, SO EXIT(NO ALIAS GIVEN)
	JMS	TAKERP	/REVPOL(-):AC:=VOCAB PTR
	DAC	NAPTR
	JMS	LDA2	/LOAD SECOND WD OF PROCNAME
	JMS	DAM	/PROC_
	M*1+PROC
	JMS	LDA1	/LOAD FIRST WD OF PROCNAME
	XOR	U00000	/SET BIT 1 AS EXTERNAL FLAG
	DAC*	PROC
	JMP	FALSE
CPN2	LAC*	PROC
	JMP	.-4
 
/BIR,IR	PH2 CATOM TESTS
/MASK BOOLEAN AND/OR(INTEGER,REAL) BITS IN Q
 
BIR	LAC	C7
	SKP
IR	LAC	C3
	JMP	TASQ01
	.EJECT
/GNBS
/SUBROUTINE TO GET THE NEXT BASIC SYMBOL AND ISSUE IT (AS AN
/INTERNAL CODE) IN THE LOCATION BS AND IN THE AC TO THE CALLING PROGRAM
GNBS	XX
	LAC	BSW
	SNA		/INTERNAL CODE WAITING?
	JMS	GNBS60	/NO,SO GET ONE IN AC AND BSW
	JMS	COPY	/)REMEMBER END OF LAST BS
	LCT1		/)AND START OF CURRENT BS
	LCT3		/)
	4		/)
	LAC	BSW
	DAC  BS
	SAD  U00027	/COLON?
	JMP  GNBS52	/YES,SO SEE IF FOLLOWED BY =
	SAD  U00074	/QUOTE?
	JMP  GNBS25	/YES, SO READ KEYWORD
	SAD  U10025	/LESS THAN?
	JMP  GNBS50	/YES,SO SEE IF FOLLOWED BY =
	SAD  U10020	/GREATER THAN?
	JMP  GNBS51	/YES, SO SEE IF FOLLOWED BY =
	AND	S01400	/MASK LD AND L BITS
	SAD	S01400	/LETTER?
	JMP	GNBS41	/YES
	SZA		/DIGIT?
	JMP	RNUM	/YES,SO READ NUMBER
	LAC	BS
	SAD	U00067	/@?
	JMP	RNUM	/YES,SO READ NUMBER
	AND	S04000
	SZA		/%,# OR .?
	JMP	GNBS16	/YES
	LAC  BS	/ISSUE INTERNAL CODE IN AC
GNBS12	DZM	BSW
	DAC	BS	/EXIT FROM GNBS
	LAC	LCT1	/)
	DAC	LCT6	/)CORRECT POSN OF END
	LAC	CHPOS1	/)OF CURRENT BS
	DAC	CHPOS6	/)
	JMP	GNBS14
GNBS13	DAC	BS
	LAC	LCT2	/)
	DAC	LCT6	/)CORRECT POSN. OF END
	LAC	CHPOS2	/)OF CURRENT BS
	DAC	CHPOS6	/)
GNBS14	LAC	BS	/EXIT WITH BS IN AC
	SZA		/INVALID KEYWORD?
	JMP*	GNBS	/NO
	LAW	-45	/YES,ERROR 37
	JMS	ERR
	CLA		/EXIT WITH BS IN AC
	JMP*	GNBS
GNBS16	LAC	EXTMRK
	RAR		/L:=1 IF EXTERNAL MODE
	LAC	BS
	SZL		/EXTERNAL MODE?
	JMP	GNBS41	/YES
	SAD	U04033	/%?
	LAC	U00077	/YES,SO LOAD INVALID CODE
	SAD	U14047	/#?
	LAC	U10023	/YES,SO LOAD 'NE' CODE
	SAD	U04034	/.?
	JMP	RNUM	/YES,SO READ NUMBER
	JMP	GNBS12
	.EJECT
/CODE TO READ IN A KEYWORD. NCB STANDS FOR NAME CHAR BLOCK.
GNBS25	JMS  GNBS64	/OPEN THE NCB
GNBS26	JMS  GNBS60	/GET NEXT CHAR IN AC AND BSW
	DAC  BS
	AND  S01000
	SNA	/LETTER OR DIGIT?
	JMP  GNBS27	/NO
	LAC  SP02	/LOAD CHAR COUNT
	SAD  C9	/9?
	JMP  GNBS30	/YES
	JMS  GNBS61	/PACK THE CURRENT CHAR
	JMP  GNBS26
GNBS27	LAC  BSW	/LOAD CURRENT CHAR
	SAD  U00074	/QUOTE?
	JMP  GNBS31	/YES
GNBS30	CLA
	JMP  GNBS13	/EXIT FROM GNBS
GNBS31	LAC  AAKTAB
	DAC* C8	/INITIALISE KEYWORD TABLE PTR
GNBS32	LAC  ANCB
	DAC  SP01	/INITIALISE NCB PTR
GNBS33	LAC* AUTO	/LOAD CURRENT WORD OF KEYWORD TABLE
	SAD  Z70001	/END OF TABLE?
	JMP  GNBS37	/YES
	SAD* SP01	/CURRENT KEYWD TABLE WD = CURRENT NCB WD?
	JMP  GNBS35	/YES
	SMA	/CURRENT KEYWD TABLE WD NEGATIVE?
	JMP  GNBS34	/NO
	LAC* AUTO	/LOAD CURRENT KEYWD TABLE WD
	JMP  .-3
GNBS34	LAC* AUTO	/SKIP OVER INTERNAL CODE
	JMP  GNBS32
GNBS35	SMA	/CURRENT KEYWD TABLE WD NEGATIVE?
	JMP  GNBS36	/NO
	ISZ  SP01	/INCREMENT NCB PTR
	JMP  GNBS33
GNBS36	LAC* AUTO	/ISSUE CODE FOR KEYWD FOUND
	JMP  GNBS12
GNBS37	CLA
	JMP  GNBS12
	.EJECT
/CODE TO READ IN AN IDENTIFIER. NCB STANDS FOR NAME CHAR BLOCK.
GNBS41	JMS  GNBS64	/OPEN THE NCB
GNBS42	JMS  GNBS61	/PACK CURRENT CHAR INTO NCB
GNBS43	JMS  GNBS60	/GET NEXT CHAR IN AC AND BSW
	DAC  BS
	LAC	EXTMRK
	RAR		/L:=1 IF EXTERNAL MODE
	LAC	BS
	AND	S01000	/MASK LD BIT
	SZA		/LETTER OR DIGIT?
	JMP	GNBS47	/YES
	LAC	BS
	AND	S04000
	SZA		/%,# OR .?
	SNL		/YES,SO SKIP IF IN EXT MODE
	JMP	GNBS44	/ILLEGAL CHAR FOR IDENT FOUND
GNBS47	LAC	SP02	/LOAD CHAR COUNT
	SAD  C6	/CHAR COUNT = 6?
	JMP  GNBS43	/YES
	JMP  GNBS42
GNBS44	DZM  BS	/START OF CODE TO CLOSE NCB
GNBS45	LAC  SP02	/LOAD CHAR COUNT
	TAD  K3	/SUBTRACT 3
	SNA	/CHAR COUNT = 3 OR 6 ?
	JMP  GNBS46	/YES
	SMA
	JMP  .-4
	JMS  GNBS61	/PACK SPACE INTO NCB
	JMP  GNBS45
GNBS46	JMS	NSTK	/STORE IDENTIFIER ON VOCAB STACK
	LAC  U20037	/ISSUE "IDENTIFIER" CODE
	JMP  GNBS13	/EXIT FROM GNBS
	.EJECT
/CODE TO TREAT :, > AND <.
GNBS50	LAW  U10024	/LOAD ADDRESS OF INT. CODE FOR <=
	JMP  .+4
GNBS51	LAW  U10021	/LOAD ADDR OF CODE FOR >=
	SKP
GNBS52	LAW  U00026	/LOAD ADDR OF CODE FOR :=
	TAD  U20000	/CHANGE OP FIELD TO LAC
	DAC  GNBS54
	JMS  GNBS60	/GET NEXT CHAR IN AC AND BSW
	SAD  U10022	/NEXT CHAR IS = ?
	JMP  GNBS54	/YES
	JMP	GNBS13+1
GNBS54	XX	/CHANGED DYNAMICALLY TO LAC <=, >= OR :=
	JMP  GNBS12	/EXIT FROM GNBS
	.EJECT
/GNBS60
/SUBROUTINE TO GET THE NEXT CHAR, CONVERT IT TO AN INTERNAL CODE
/AND ISSUE THE CODE IN THE AC AND IN BSW. SPACES ARE IGNORED.
/ILLEGAL CHARS CAUSE AN ERROR MESSAGE ,BUT ARE OTHERWISE
/IGNORED
GNBS56	XX
GNBS57	SAD  S00040	/SPACE?
	JMP  GNBS58	/YES
	TAD  ABSS	/ADD ASCII CODE OF CHAR
	DAC  SP00	/STORE ADDR OF INTERNAL CODE
	LAC* SP00	/LOAD INTERNAL CODE
	SAD	U00077	/INVALID CHAR?
	JMP	.+3	/YES
	DAC	BSW
	JMP*	GNBS56
	LAW	-57+Z	/REPORT ERROR 47
	JMS	ERR
GNBS58	JMS	GNC	/IGNORE IT
	JMP	GNBS57
 
GNBS60	XX
	LAC	LCT1	/REMEMBER POSN OF LAST MEANINGFUL CHAR
	DAC	LCT2
	LAC	CHPOS1
	DAC	CHPOS2
	JMS	GNC
	JMS	GNBS56
	JMP*	GNBS60
	.EJECT
/SUBROUTINE TO PACK THE CHAR HELD IN BS INTO THE THREE WD NAME CHAR 
/BLOCK (NCB), IN RADIX 50.
GNBS61	XX
	LAC  BS
	AND  S00077	/CUT CHAR CODE DOWN TO RADIX 50 (6 BITS)
	DAC  BS
	LAC  SP02	/LOAD CHAR COUNT
	TAD  K3	/FORM (CHAR COUNT - 3)
	SNA	/CHAR COUNT =  3 OR 6 ?
	JMP  GNBS63	/YES
	SMA	
	JMP  .-4
	LAC* SP01	/LOAD CURRENT WD OF NCB
	RCL	/MULT CURRENT WD BY 50 (RADIX 8)
	RTL
	DAC  SP03
	RTL
	TAD  SP03
GNBS62	TAD  BS	/ADD CURRENT CHAR IN RADIX 50
	DAC* SP01	/STORE IN CURRENT WD OF NCB
	ISZ  SP02	/INCREMENT CHAR COUNT
	JMP* GNBS61
GNBS63	LAC* SP01	/LOAD CURRENT WD OF NCB
	XOR  W00000	/SET SIGN BIT
	DAC* SP01	/STORE IN CURRENT WD AGAIN
	ISZ  SP01	/INCREMENT PTR
	CLA
	JMP  GNBS62
	.EJECT
/SUBROUTINE TO OPEN THE NAME CHAR BLOCK (NCB)
GNBS64	XX
	DZM  NCB	/CLEAR NCB
	DZM  NCB1
	DZM  NCB2
	DZM  SP02	/INITIALISE CHAR COUNT
	LAC  ANCB
	DAC  SP01	/SET PTR TO WD 1 OF NCB
	JMP* GNBS64
	.EJECT
/NSTK
/ROUTINE TO SEARCH THE VOCAB STACK FOR A MATCH WITH THE NAME HELD (IN
/RADIX 50 FORMAT) IN THE FIRST TWO WDS OF THE NAME CHARACTER BLOCK.
/IF NO MATCH IS FOUND THE NEW NAME IS ADDED TO THE STACK. THE DISPLACE-
/MENT OF THE ENTRY FROM THE BASE OF THE STACK IS INSERTED IN THE L.S.
/12 BITS OF THE APPROPRIATE REVPOL OPCODE.
NSTK	XX
	LAC	NCB
	RAL		/L=1 IF NEW NAME 2 WDS, L=0 IF 1 WD
	LAC	VOCAB
	DAC	SP01
NSTK2	SAD	VOBASE	/AC POINTS TO BASE OF VOCAB STACK ?
	JMP	NSTK14	/YES
	ISZ	SP01
	LAC*	SP01	/AC := FIRST WD OF CURRENT NAME
	ISZ	SP01
	SAD	NCB	/SAME AS FIRST WD OF NEW NAME ?
	JMP	NSTK8	/YES
	SPA		/TWO WD NAME IN VOCAB ?
NSTK4	ISZ	SP01	/YES: SP01 POINTS TO SECOND WD
NSTK6	LAC	SP01
	JMP	NSTK2	/J WITH AC = ADDR OF LAST WD OF CURR ENTRY
NSTK8	SMA!SNL		/NEW NAME ONE WD AND CURR NAME ONE WD ?
	JMP	NSTK12	/YES
	SMA		/NEW NAME TWO WDS AND CURR NAME ONE WD?
	JMP	NSTK6	/YES
	SNL		/NEW NAME ONE WD AND CURR NAME TWO WDS?
	JMP	NSTK4	/YES
	LAC*	SP01	/LOAD SECOND WD OF CURR NAME
	SAD	NCB1	/SAME AS SECOND WD OF NEW NAME ?
	JMP	NSTK12	/YES, SO EXIT WITH TWO-WD NAME FOUND
	JMP	NSTK4
NSTK12	LAC	SP01
	TAD	K2	/AC:=PTR
NSTK13	JMS	EVA00	/CONVERT ADDR TO VADDR
	.DSA	VOBASE
	DAC	NAME	/INSERT VADDR IN REVOP TABLE
	JMP*	NSTK
NSTK14	SNL		/NEW NAME ONE WD?
	JMP	NSTK16	/YES
	LAC	NCB1	/PUT SECOND WD OF NEW
	JMS	PUT	/NAME ON VOCAB STACK
	VOCAB
NSTK16	LAC	NCB
	JMS	PUT	/PUT FIRST WD ON VOCAB
	VOCAB
	CLA		/PUT ZERO DICT PTR WD
	JMS	PUT	/ON VOCAB STACK
	VOCAB
	LAC	VOCAB	/LOAD POINTER
	JMP	NSTK13
	.EJECT
/ISTK
/ROUTINE TO SEARCH THE INTEGER STACK FOR A MATCH WITH THE INTEGER HELD
/IN NCB. IF NO MATCH IS FOUND THE NEW INTEGER IS PLACED ON THE STACK.
/THE DISPLACEMENT OF THE NUMBER FROM THE BASE OF THE STACK IS
/INSERTED IN THE L.S. 12 BITS OF NUMI (THE "INTEGER NO."
/ENTRY IN THE REVPOL OPCODE TABLE).
ISTK	XX
	LAC*	WORK	/LOAD PREVIOUS REVPOL OP
	SAD	MIN	/DYADIC MINUS?
	JMP	ISTK2	/YES
	SAD	NEG	/MONADIC MINUS?
	JMP	ISTK4	/YES
	JMP	ISTK6
ISTK2	LAC	PLUS	/REPLACE - BY +
	DAC*	WORK
	SKP
ISTK4	ISZ	WORK	/DELETE OP FROM WORK STACK
	LAC	NCB	/COMPLEMENT INTEGER
	JMS	TCA
	DAC	NCB
ISTK6	LAC	INTEGR	/LOAD INT STACK PTR
	TAD	K1	/SUBTRACT 1
	DAC*	C8	/LOAD A-I 10 WITH START VAL FOR TABLE SRCH
ISTK8	LAC*	AUTO	/LOAD NEXT WORD FROM STACK
	SAD	NCB	/SAME AS NEW INT. ?
	JMP	ISTK10	/YES
	LAC*	C8	/LOAD ADDR OF CURRENT WD ON STACK
	TAD	C1
	SAD	INBASE	/BASE OF STACK ?
	SKP		/YES
	JMP	ISTK8	/NO, SO REPEAT SEARCH
	LAC	NCB
	JMS	PUT	/PUT NEW INT. ON STACK
	INTEGR
	LAC	INTEGR	/LOAD PTR TO INT. POSITION
	SKP
ISTK10	LAC*	C8	/LOAD PTR TO INT. POSITION
	JMS	EVA00
	.DSA	INBASE
	DAC	NUMI
	JMP*	ISTK
	.EJECT
/RSTK
/THIS ROUTINE SEARCHES THE REAL STACK FOR A MATCH WITH THE REAL
/NUMBER HELD IN THE THREE-WORD NAME CHARACTER BLOCK. IF NO MATCH IS 
/FOUND THE NEW NUMBER IS ADDED TO THE REAL STACK. THE DISPLACEMENT
/OF THE NUMBER FROM THE BASE OF THE STACK IS INSERTED IN THE L.S.
/12 BITS OF NUMR(THE "REAL NUMBER" ENTRY IN THE REVPOL OPCODE TABLE).
RSTK	XX
	LAC	REAL	/LOAD VALUE OF REAL STACK PTR
	JMP	RSTK3
RSTK2	LAC	REALS
	TAD	C3	/ADD 3 TO REALS
RSTK3	DAC	REALS
	SAD	RLBASE	/REALS=RLBASE ?
	JMP	RSTK8	/YES
	TAD	K1
	DAC*	C9	/INITIALISE A-I REG 11
	LAC	AANCB	/INITIALISE A-I REG 10
	DAC*	C8
	LAW	-3
	DAC	SP01
RSTK4	LAC*	AUTO1	/LOAD WORD FROM STACK
	SAD*	AUTO	/SAME AS CORR. WORD IN NEW NUMBER ?
	SKP		/YES
	JMP	RSTK2	/NO, SO TRY NEXT REAL ON STACK
	ISZ	SP01	/THIRD SUCCESSFUL COMPARISON ?
	JMP	RSTK4	/NO
	LAC	REALS	/LOAD POINTER
RSTK7	JMS	EVA00	/CONVERT ADDR TO VADDR
	.DSA	RLBASE
	DAC	NUMR	/PLACE VADDR IN REVOP TABLE
	JMP*	RSTK
RSTK8	LAC	NCB2
	JMS	PUT	/PUT L.S. MANTISSA ON STACK
	REAL
	LAC	NCB1
	JMS	PUT	/PUT M.S. MANTISSA ON STACK
	REAL
	LAC	NCB
	JMS	PUT	/PUT EXPONENT ON STACK
	REAL
	LAC	REAL
	JMP	RSTK7	/GO TO INSERT PTR IN OPCODE
	.EJECT
/RNUM:NUMBER CONVERSION
/E.N.HAWKINS
RNUM	DZM	RNUMSE	/SIGN EXPONENT
	DZM	RNUMA0	/TRIPLE LENGTH MANTISSA (M.S.)
	DZM	RNUMA1	/L.S.
	DZM	RNUMA2	/REAL EXPONENT OR INTEGER NO.
	DZM	RNUMB	/DECIMAL EXPONENT
	DZM	RNUMDP	/DECIMAL PLACES
	DZM	RNUMST	/STATE
	LAW	-20	/NUMBER OF DIGITS
	DAC	RNUMDM	/ALLOWED IN MANTISSA
	LAW	-3	/NUMBER OF DIGITS
	DAC	RNUMDE	/ALLOWED IN EXPONENT
	LAC	BSW	/FIRST SYMBOL
	JMP	RNUM03-1
RNUM01	ISZ	RNUMST	/ST=ST+1
RNUM02	JMS	GNBS60	/NEXT SYMBOL
	DAC	RNUMCH
RNUM03	AND	S02000	/IS IT A DIGIT
	SNA
	JMP	RNUM09	
	LAC	RNUM05	/TREE INSTRUCTION
RNUM04	TAD	RNUMST	/MODIFY
	DAC	.+1	/OBEY
	XX	
RNUM05	JMP	RNUM06	/MODIFIED INST
RNUM06	JMP	RNUM08	/ST=0
	ISZ	RNUMST	/ST=1
	JMP	RNUM07	/ST=2
	ISZ	RNUMST	/SY=3
	ISZ	RNUMST	/ST=4
	ISZ	RNUMDE	/ST=5
	SKP
	JMP	RNUMEA	/TOO MANY EXP DIGITS
	LAC	RNUMB	/B
	RCL		/2B
	DAC	RNUMB	/2B
	RTL		/8B
	TAD	RNUMB	/10B
	TAD	RNUMCH	/10B+DIGIT
	TAD	X74743	/CORRECTION
	DAC	RNUMB	
	JMP	RNUM02	/ALPHA
RNUM07	ISZ	RNUMDP	/DP=DP+1
RNUM08	ISZ	RNUMDM	/DIGITS IN MANTISSA
	SKP
	JMP	RNUMEB	/TOO MANY
	JMS	RNUMSZ	/2A
	JMS	RNUMSY	/COPY TO C
	JMS	RNUMSZ	/4A
	JMS	RNUMSZ	/8A
	JMS	RNUMSX	/10A
	DZM	RNUMC0	/TRIPLE
	DZM	RNUMC1	/LENGTH
	LAC	RNUMCH	/DIGIT
	TAD	X74743	/CORRECTION
	DAC	RNUMC2	/STORE
	JMS	RNUMSX	/NEW MANTISSA
	JMP	RNUM02	/ALPHA
RNUM09	LAC	RNUMCH	/LABEL BETA
	SAD	U04034	/CHAR =.?
	JMP	RNUM22	/IT IS
	SAD	U00067	/CH=DROP 10
	JMP	RNUM21	/IT IS
	LAC	RNUM10	/TREE INSTRUCTION
	JMP	RNUM04	/MODIFY AND JUMP
RNUM10	JMP	RNUM11	/MODIFIED INST
RNUM11	JMP	RNUM20	/ST=0
	JMP	RNUMEC	/ST=1 ERROR
	JMP	RNUM12	/ST=2
	JMP	RNUM18	/ST=3
	JMP	RNUMED	/ST =4
RNUM12	CLA		/ST=5 ERROR
	SAD	RNUMA0	/A0=0
	JMP	RNUM15	/IT IS
RNUM13	LAW	-65	
RNUM14	DAC	RNUMBE	/BE=-53
	LAC	RNUMB	/AC:=B
	TAD	RNUMSE	/AC:=B-1 OR B
	ISZ	RNUMSE	/SE=-1?
	CMA		/NO:AC:=B-1 OR -B-1
	TAD	RNUMDP	/AC:D+B-1 OR D-B-1
	CMA		/AC:=-D-B OR B-D
	DAC	RNUMB
	JMP	RNUM24	/EPSILON
RNUM15	SAD	RNUMA1	/A1=O
	JMP	RNUM17	/IT IS
	LAC	RNUMA1	/TOP BIT A1=O
	SPA
	JMP	RNUM13	/IT IS
RNUM16	LAC	RNUMA1	
	DAC	RNUMA0	/A0=A1
	LAC	RNUMA2	/A1=A2
	DAC	RNUMA1	
	DZM	RNUMA2	/A2=0
	LAW	-43	/BE=-35
	JMP	RNUM14	
RNUM17	SAD	RNUMA2	/A2=0
	JMP	RNUM29	/IT IS REAL EXIT
	LAC	RNUMA2	/TOP BIT A2=0
	SPA
	JMP	RNUM16	/IT IS NOT
	DAC	RNUMA0	/A0=A2
	DZM	RNUMA2	/A2=0
	LAW	-21	/BE=-17
	JMP	RNUM14	
RNUM18	LAC	RNUMCH	/CH=-
	SAD	U10011
	JMP	RNUM19	/IT IS
	SAD	U10010	/CH=+
	JMP	RNUM01	/IT IS
	JMP	RNUMEE	/ERROR
RNUM19	LAW	-1
	DAC	RNUMSE	/SE=-1
	JMP	RNUM01	/ALPHA DASH
RNUM20	LAC	RNUMA0
	SZA		/A0=0
	JMP	RNUMEF
	LAC	RNUMA1
	SZA
	JMP	RNUMEF	/ERROR
	LAC	RNUMA2	/A2 NOT SINGLE LENGTH
	SPA
	JMP	RNUMEF	/ERROR
	JMS	ISTK
	LAC	U00235	
	JMP	GNBS13
RNUM21	LAC	RNUMST
	SNA
	JMP	.+4	/ST=0
	TAD	Z77776	/ST=2
	SZA
	JMP	RNUMEG	/ERROR
	LAC	C3	/ST=3
	DAC	RNUMST	
	JMP	RNUM02	/ALPHA
RNUM22	LAC	RNUMST	/ST=O
	SNA
	JMP	RNUM01	/ALPHA DASH
	JMP	RNUMEH	/ERROR
RNUM23	ISZ	RNUMBE	/BE=BE+1
	NOP		/BE CAN GO THRU 0
	JMS	RNUMSZ	/SHIFT(A,1) TO A
RNUM24	LAC	RNUMA0	/IS BIT OF A 0
	RAL		/ A ZERO
	SMA
	JMP	RNUM23	/NO,SHIFT AGAIN
	LAC	RNUMB	/IS B=0
	SNA
	JMP	RNUM26	/YES
	SMA
	JMP	RNUM25	/B>0
	ISZ	RNUMB	/B+1->B
	NOP		/FOR NEW B=0
	LAC	RNUMBE	
	TAD	C3	/BE=BE+3
	DAC	RNUMBE
	JMS	RNUMSW	/SHIFT(A,-1) TO A
	JMS	RNUMSV	/SHIFT (A,-1) TO C
	JMS	RNUMSX	/ADD C TO A
	LAW	-3	/SHIFT (A,-4) TO C
	JMS	RNUMSR
	JMS	RNUMSX	/ADD C TO A
	LAW	-7	/SHIFT (A,-8) TO C
	JMS	RNUMSR
	JMS	RNUMSX	/ADD C TO A
	LAW	-17	/SHIFT(A,-16) TO C
	JMS	RNUMSR
	JMS	RNUMSX	/ADD C TO A
	LAW	-37	/SHIFT (A,-32) TO C
	JMS	RNUMSR	
	JMS	RNUMSX	/ADD C TO A
	JMP	RNUM24	/EPSILON
RNUM25	LAW	-1	/B =B-1
	TAD	RNUMB
	DAC	RNUMB
	LAW	-4	/BE=BE-4
	TAD	RNUMBE	
	DAC	RNUMBE
	JMS	RNUMSW	/SHIFT(A,-1)TO A
	LAW	-1	/SHIFT (A,-2) TO C
	JMS	RNUMSR
	JMS	RNUMSX	/ADD C TO A
	JMP	RNUM24	/EPSILON
RNUM26	DZM	RNUMC0	/SET UP TRIPLE
	DZM	RNUMC1	/LENGTH
	LAC	W00000	/ROUND OFF
	DAC	RNUMC2
	JMS	RNUMSX	/ROUND
	LAC	RNUMBE	/NEGATE BE
	JMS	TCA
	DAC	RNUMA2	/A2_
	LAC	RNUMA0	/TEST FOR SPILL
	SPA!CLA!STL	/BIT 0(A2)=1?
	JMP	RNUM28	/JUMP IF SPILL
RNUM29	JMS	RSTK
	LAC	U00236
	JMP	GNBS13
RNUM28	RTR		/SET MANTISSA
	DAC	RNUMA0	/EQUAL A HALF
	ISZ	RNUMA2	/)ADD ONE TO
	JMP	RNUM29	/)FINAL EXPONENT
	JMP	RNUM29	/CAN GO THRU 0
RNUMSW	XX		/SUBROUTINE TO
	LAC	RNUMA0	/SHIFT THE
	RCR		/TRIPe LENGTH
	DAC	RNUMA0	/MANTISSA ONE
	LAC	RNUMA1	/PLACE TO THE
	RAR		/RIGHT
	DAC	RNUMA1
	LAC	RNUMA2
	RAR
	DAC	RNUMA2	
	JMP*	RNUMSW	/EXIT
RNUMSY	XX		/SUBROUTINE TO
	LAC	RNUMA0	/COPY TRIPLE LENGTH
	DAC	RNUMC0	/MANTISSA TO
	LAC	RNUMA1	/TRIPLE LENGTH WORK
	DAC	RNUMC1	/STORE
	LAC	RNUMA2
	DAC	RNUMC2
	JMP*	RNUMSY	/EXIT
RNUMSX	XX		/SUBROUTINE TO
	CLL		/ADD THE TRIPLE
	LAC	RNUMA2	/LENGTH WORK STORE
	TAD	RNUMC2	/TO THE TRIPLE
	DAC	RNUMA2	/LENGTH ACCUMULATOR
	GLK
	TAD	RNUMA1
	TAD	RNUMC1
	DAC	RNUMA1
	GLK
	TAD	RNUMA0
	TAD	RNUMC0
	DAC	RNUMA0
	JMP*	RNUMSX	/EXIT
RNUMSZ	XX		/SUBROUTINE TO SHIFT
	LAC	RNUMA2	/THE TRIPLE LENGTH
	RCL		/MANTISSA ONE PLACE
	DAC	RNUMA2	/TO THE LEFT
	LAC	RNUMA1
	RAL
	DAC	RNUMA1
	LAC	RNUMA0
	RAL
	DAC	RNUMA0
	JMP*	RNUMSZ	/EXIT
RNUMSV	XX		/SUBROUTINE TO
	LAC	RNUMA0	/SHIFT THE TRIPLE
	RCR		/LENGTH MANTISSA
	DAC	RNUMC0	/ONE PLACE RIGHT BUT
	LAC	RNUMA1	/INTO THE TRIPLE
	RAR		/LENGTH WORK STORE
	DAC	RNUMC1
	LAC	RNUMA2
	RAR
	DAC	RNUMC2
	JMP*	RNUMSV	/EXIT
RNUMSR	XX		/SUBROUTINE TO SHIFT
	DAC	RNUMSQ	/THE TRIPLE LENGTH MANTISSA
	JMS	RNUMSV	/N PLACES BUT DOING
RNUMSP	LAC	RNUMC0	/THE SHIFT IN THE
	RCR		/TRIPLE LENGTH
	DAC	RNUMC0	/WORK STORE
	LAC	RNUMC1
	RAR
	DAC	RNUMC1
	LAC	RNUMC2
	RAR
	DAC	RNUMC2
	ISZ	RNUMSQ	/COUNT SHIFTS
	JMP	RNUMSP
	JMP*	RNUMSR	/EXIT
RNUMSQ	CAL	0
RNUMEA	ISZ	ISZCT	/TOO MANY EXPONENT DIGITS
RNUMEB	ISZ	ISZCT	/TOO MANY MANTISSA DIGITS (>15)
RNUMEC	ISZ	ISZCT	/NO DIGIT AFTER .
RNUMED	ISZ	ISZCT	/NO DIGIT AFTER SIGN OF EXPONENT
RNUMEE	ISZ	ISZCT	/INVALID CHAR AFTER @
RNUMEG	ISZ	ISZCT	/@ INVALID HERE
RNUMEH	LAC	ISZCT	/. INVALID HERE
	DZM	ISZCT
	TAD	S10047	/SET BIT 5 FOR TYPE 1 ERROR
	JMS	TCA
	JMS	ERR
	LAC	U00077
	JMP	GNBS13
RNUMEF	LAC	LCT2	/CORRECT POSN OF END OF CURRENT BS
	DAC	LCT6
	LAC	CHPOS2
	DAC	CHPOS6
	LAW	-46	/INTEGER OUT OF RANGE
	JMS	ERR
	JMP	RNUMEF-2
RNUMB	XX
RNUMBE	XX
RNUMCH	XX
RNUMC0	XX
RNUMC1	XX
RNUMC2	XX
RNUMDE	XX
RNUMDM	XX
RNUMDP	XX
RNUMSE	XX
RNUMST	XX
	.EJECT
/GNC
/SUBROUTINE TO GET THE NEXT CHAR FROM THE SOURCE FILE AND ISSUE 
/IT IN THE LOCATION NC AND IN THE AC TO THE CALLING PROGRAM.
/GNC PROVIDES A SOURCE LISTING AT THE SAME TIME.
/SCRATCHPAD USED:SP00
 
GNC	XX		/NORMAL ENTRY POINT
	JMP	GNC03
 
GNC01	LAC  GNC70	/SWAP BUFFERS
	DAC  SP00
	LAC  GNC71
	DAC  GNC70
	DAC	GNC75
	TAD	K2
	DAC	GNC22	/SELECT BUFFER FOR WRITING
	LAC  SP00
	DAC  GNC71
	JMS  GNC60	/READ IN NEXT BUFFER
	LAC* GNC70	/GET BUFFER HEADER WORD
	AND	S00017	/LOOK FOR EOF AND EOM
	SAD  C5	/EOF?
	SKP	/YES
	SAD  C6	/EOM?
	JMP  GNC13	/YES,SO CLOSE INPUT FILE
	LAC*	GNC70	/LOOK FOR READ ERRORS
	AND	S00060
	SNA		/READ ERROR?
	JMP	.+3	/NO
	LAW	-37+Z	/YES:REPORT ERROR 31
	JMS	ERR
	ISZ	LCT1	/INCREMENT LINE COUNT
	LAC	C5
	DAC	CHPOS1	/RESET CHARACTER COUNT
	LAC	LIST
	SZA		/LISTING REQUIRED?
	JMS	GNC20	/YES,SO WRITE CURR BUFF TO LDEV
	ISZ	GNC75	/BUMP PTR
	LAC	GNC06	/)
	TAD	C4	/)INITIALISE XCT INSTN
	DAC	GNC08	/)
GNC03	JMS	UNP5.7	/DO 5-7 UNPACK TO GET CH IN AC
	DAC	NC	/HOLD CHARACTER
	TAD	K32	/SUBTRACT 40(8)
	SPA		/AC>0R=0?
	JMP	GNC101	/NO,NON PRINTING CHAR
	TAD	Z77700	/YES,SUBTRACT 100
	SPA		/AC>OR=0?
	JMP	GNC104	/NO,PRINTING CHARACTER
	TAD	S00100
GNC101	TAD	C32	/ADD TO REFORM CHARACTER
	SAD	S00011	/HORIZONTAL TAB?
	JMP	GNC103	/YES
	SAD	S00012	/LINE FEED?
	JMP	GNC03	/YES
	SAD	S00013	/VERTICAL TAB?
	JMP	GNC03	/YES
	SAD	S00014	/FORM FEED?
	JMP	GNC03	/YES
	SAD	S00175	/ALTMODE?
	JMP	GNC12	/YES
	SAD	S00015	/CARRIAGE RETURN?
	SKP		/YES
	JMP	GNC15	/NO,INVALID CHAR
	.WAIT	DATOUT
	JMP	GNC01
GNC103	LAC	CHPOS1	/LOAD CHAR COUNT
	TAD	K10	/SUBTRACT 10
	SMA		/CHAR COUNT >10?
	JMP	.-2	/YES,LOOP
	CMA		/NO,COMPLEMENT AC
	SPA!SNA		/AC>0?
	TAD	C10	/NO ADD 10
	TAD	CHPOS1	/ADD CHAR COUNT
	DAC	CHPOS1
	ISZ	CHPOS1	/INCREMENT CHAR CT
	JMP	GNC03
GNC104	ISZ	CHPOS1	/INCREMENT CHAR COUNT
	LAC	NC	/EXIT WITH CODE IN NC AND AC
	JMP* GNC
GNC12	LAW	-57+Z	/REPORT ERROR 47
	JMS	ERR
	JMP	GNC103-3
GNC13	LAC	S00140
	DAC	NC
	JMP*	GNC	/EXIT
GNC14	.SIXBT	ZLSTZ	/EXTENSION FOR LISTING FILE
GNC15	LAW	-57+Z	/REPORT ERROR 47
	JMS	ERR
	JMP	GNC03
GNC18	.SIXBT	ZA01Z	/EXTENSION FOR INT. CODE FILE
	.EJECT
/GNC20
/SUBROUTINE TO WRITE THE CURRENT BUFFER TO THE LISTING DEVICE
GNC20	XX
	JMS	COPY	/)
	M*4+GNC70	/)COPY HDR WD PR TWO WDS
	M*4+GNC22	/)DOWN CORE
	2
	LAC*	GNC22	/LOAD FIRST WD OF HDR WD PR
	TAD	S01000	/ADD 1 TO WD PR COUNT
	DAC*	GNC22	/REPLACE HDR WD
	LAC	LCT1
	JMS	BDEC	/CONVERT LINE COUNT TO ASCII
	JMS	COPY	/PUT LINE COUNT IN LISTING BUFFER
	NUM3
	M*4+GNC70
	2
	ISZ	LCT	/INCREMENT LINE COUNT
	LAC	LCT	/LOAD LINE COUNT
	SAD	C56	/PAGE FULL?
	JMS	PAGEHD	/YES,SO OUTPUT PAGE HDR
	CAL+2000	DATOUT&777
	.DSA	11
GNC22	.DSA	0
	.DSA	777712
	JMP*	GNC20
	.EJECT
/SUBROUTINE TO INITIATE READING OF NEXT BUFFER
GNC60	XX
	LAC  GNC71
	DAC  GNC61
/	.READ DATIN,IOPS,BUFF2,52
	CAL+2000	DATIN&777
	.DSA 10
GNC61	.DSA 0
	.DSA 777714
	JMP* GNC60
	.EJECT
/LOCAL STORAGE FOR ROUTINE GNC
GNC70	.DSA GNC73
GNC71	.DSA GNC74
	0
	0
GNC73	.BLOCK 64	/INPUT BUFFER
	0
	0
GNC74	.BLOCK 64	/INPUT BUFFER
GNC75	0		/PTR TO CURRENT WD IN BUFFER
	.EJECT
/PAGEHD
/ROUTINE TO OUTPUT A FORM-FEED FOLLOWED BY A PAGE HEADING
 
PAGEHD	XX
	ISZ	PAGECT	/INCREMENT PAGE COUNT
	LAC	PAGECT	/LOAD PAGE COUNT
	JMS	BDEC	/CONVERT TO DECIMAL
	JMS	DLZ	/DELETE LEADING ZEROS
	DAC	PAGENO
	LAC	NUM3+1
	XOR	S25132	/INSERT LF AND CR INTO  BUFFER
	DAC	PAGENO+1
	.WRITE	-3,2,HDBUFF,10
	DZM	LCT	/CLEAR LINE COUNT
	JMP*	PAGEHD
 
HDBUFF	5002
	0
FILENM	60000
	0
	0
	22		/HORIZ TAB
	.ASCII	!PAGE !
PAGENO	0
	0
	.EJECT
/ERR
/SUBROUTINE TO REPORT AN ERROR,EITHER TO THE ERROR
/MODULE,OR TO THE LISTING DEVICE,OR TO THE TELETYPE.
/ON ENTRY,AC CONTAINS -(ERROR NO.)
ERR	0
	ISZ	ERRNUM	/INCREMENT ERROR CT
	DZM	ENUM+10	/CLEAR ERROR TYPE 4 FLAG
	DZM	ENUM+11	/CLEAR ERROR TYPE 1 FLAG
	JMS	TCA	/GET + ERROR NO
	DAC	ENUM+2	/HOLD
	AND	S14000
	SAD	S04000	/ERROR TYPE 4?
	ISZ	ENUM+10	/YES,SO SET FLAG
	SAD	S10000	/ERROR TYPE 1?
	ISZ	ENUM+11	/YES,SO SET FLAG
	XOR	ENUM+2	/AC:=TRUE ERROR NO
	DAC	ENUM+7	/HOLD
ERR01	JMP	.+1	/THREE WAY JUMP
	JMP	ERR10	/FIRST TIME ONLY
	JMP	ERR20	/IF ERROR MODULE REQUIRED
	LAC	ENUM+7	/LOAD TRUE ERROR NO
	JMS	BDEC	/CONVERT ERR NO TO DECIMAL
	AND	S03777	/CONVERT FIRST CHAR TO NULL
	DAC	ENUM
	LAC	NUM3+1
	XOR	S00020	/CONVERT TO SPACE,(
	DAC	ENUM+1	/ERR NO NOW PACKED IN BUFFER
	LAC	ENUM+11
	SZA		/ERROR TYPE 1?
	JMP	ERR07	/YES
	LAC	ENUM+7	/RELOAD ERR NO
	TAD	K49
	SMA		/ERROR TYPE 2?
	JMP	ERR06	/NO,ERROR TYPE 3 OR 4
	JMS	PACK	/)PACK LINE AND CHAR NOS
	LCT3		/)OF START OF CURRENT BS
	ENUM+2		/)INTO BUFFER
	XOR	S00112	/CONVERT LAST CHAR(CR) TO (
	DAC	ENUM+5
	JMS	PACK	/)PACK LINE AND CHAR NOS
	LCT6		/)OF END OF CURRENT BS
	ENUM+6		/)INTO BUFFER
	JMP	ERR08
ERR06	JMS	PACKEL	/PACK EL DELIMITERS INTO BUFFER
	JMP	ERR08
ERR07	JMS	PACK	/)PACK LINE AND CHAR NOS
	LCT1		/)OF CURRENT CHAR
	ENUM+2		/)INTO BUFFER
ERR08	ISZ	LCT	/INCREMENT LINE COUNT
	LAC	LCT	/LOAD LINE CT
	SAD	C56	/END OF PAGE?
	JMS	PAGEHD	/YES, SO OUTPUT FF AND PAGE HEADER
	.WRITE	-3,2,ERRBUF,14
	.WAIT	-3
	JMP*	ERR
ERR10	ISZ	EMODE	/SET ERROR FLAG FOR ROUTINE PUT
	ISZ	ERR01	/INCREMENT JMP INSTN
	JMS	TOPT
	400		/INT CODE OUTPUT?
	SKP		/YES
	JMP	ERR12	/NO
	LAC	UP14	/)
	TAD	K1	/)RE INITIALISE ROUTINE UP
	DAC	UP14	/)
	LAC*	AOPTW	/)SET
	XOR	S00400	/)INT CODE BIT
	DAC*	AOPTW	/)IN OPTION WORD
ERR12	JMS	INIT	/INITIALISE OUT SK
	LAC	ERRMOD
	SZA		/ERROR MODULE REQUESTED?
	JMP	ERR20	/YES
	ISZ	ERR01	/INCREMENT JMP INSTN AGAIN
	LAC	OUBASE	/CLEAR INT CODE BUFFER
	TAD	K1	/(SIZE  ALREADY CLEARED IN INIT)
	DAC	OUT
	JMP	ERR01+3
ERR20	LAC	ENUM+11
	SZA		/ERROR TYPE 1?
	JMP	ERR32	/YES
	LAC	ENUM+7	/RE-LOAD TRUE ERROR NO
	TAD	K49
	SMA		/ERROR TYPE 2?
	JMP	ERR24	/NO,ERROR TYPE 3 OR 4
	JMS	PCKLCH	/)PACK UP POSN OF START
	LCT3		/)OF CURRENT BS
	DAC	ENUM+3
	JMS	PCKLCH	/)PACK UP POSN OF END
	LCT6		/)OF CURRENT BS
	DAC	ENUM+4
	JMP	ERR27
ERR24	JMS	PCKLCH	/)PACK UP POSN OF START OF
	LCT5		/)CURRENT ELEMENT
	DAC	ENUM+3
	JMS	PCKLCH	/)PACK UP POSN OF END OF
	LCT4		/)CURRENT ELEMENT
	DAC	ENUM+4
	LAC	ENUM+10
	SNA		/ERROR TYPE 4?
	JMP	ERR27	/NO:TYPE 3
	LAC	C69
	SAD	ENUM+7	/ERROR 69?
	JMP	ERR34	/YES
	LAC	VOCPTR	/)NORMAL ERROR TYPE 4,SO
	DAC	ENUM+5	/)OUTPUT VOCPTR
ERR26	ISZ	ERR30	/INCREMENT NO OF WDS TO OUTPUT
ERR27	ISZ	ERR30	/INCREMENT NO OF WDS TO OUTPUT
ERR28	LAC	X77600	/LOAD ERROR MSG OPCODE
	TAD	ERR30	/ADD IN ARGCT
	DAC	ENUM+1
	JMS	COPY	/)
	ENUM+1		/)OUTPUT
	M*1+OUT		/)ERROR MESSAGE
ERR30	3		/)
	LAC	C3	/RESET NO OF WDS TO OUTPUT
	DAC	ERR30
	JMP*	ERR
ERR32	JMS	PCKLCH	/)PACK UP POSN OF
	LCT1		/)CURRENT CHAR
	DAC	ENUM+3
	JMP	ERR28
ERR34	LAC*	WORK	/LOAD NEG COUNT FROM WORK
	DAC	ENUM+5	/OUTPUT -PARAM NO
	JMP	ERR26
 
ERRBUF	7002
	0
	.ASCII	'**E'
	.REPT	12
ENUM	0
	.EJECT
/PACKEL
/SUBROUTINE TO PACK ELEMENT DELIMITERS INTO ERR BUFFER.
 
PACKEL	XX
	JMS	PACK	/)PACK LINE AND CHAR NOS
	LCT5		/)OF START OF EL
	ENUM+2		/)INTO BUFFER
	XOR	S00112	/CONVERT LAST CH (CR) TO (
	DAC	ENUM+5
	JMS	PACK	/)PACK L+CH NOS
	LCT4		/)OF END OF EL
	ENUM+6		/)INTO BUFFER
	JMP*	PACKEL
	.EJECT
/PACK
/SUBROUTINE TO PACK THE LINE COUNT AND CHAR COUNT GIVEN
/BY THE FIRST TRAILING PARAMETER INTO THE TWO BUFFER WD-PRS
/GIVEN BY THE SECOND TRAILING PARAMETER
/CALLING SEQUENCE:-
/	JMS	PACK
/	LCNT		/ADDR OF APPROP LINE CHAR CT WD PR
/	BUFFADDR		/ADDR OF APPROP BUFFER WD PR
 
PACK	XX
	LAC*	PACK
	DAC	PACK90	/REMEMBER ADDR OF LCNT WD
	ISZ	PACK
	LAC*	PACK
	DAC	PACK92	/REMEMBER ADDR OF FIRST BUFF WD
	LAC*	PACK90	/LOAD LINE COUNT
	JMS	BDEC	/CONVERT TO ASCII DECIMAL
	JMS	DLZ	/DELETE LEADING ZEROS
	DAC*	PACK92
	ISZ	PACK90	/BUMP TO ADDR OF CHAR CT WD
	LAC	NUM3+1	/LOAD SECOND ASCII WD
	XOR	S06100	/CONVERT TO COMMA,NULL
	ISZ	PACK92	/BUMP TO ADDR OF SECOND BUFF WD
	DAC*	PACK92
	LAC*	PACK90	/LOAD CHAR CT
	JMS	BDEC	/CONVERT TO ASCII DECIMAL
	JMS	DLZ	/DELETE LEADING ZEROS
	ISZ	PACK92	/BUMP TO ADDR OF THIRD BUFF WD
	DAC*	PACK92
	LAC	NUM3+1
	XOR	S04532	/CONVERT TO ),CR
	ISZ	PACK92	/BUMP TO ADDR OF FOURTH BUFF WD
	DAC*	PACK92
	ISZ	PACK
	JMP*	PACK
 
/DLZ
/SUBROUTINE TO DELETE ANY LEADING ZEROS FROM THE WD-PR NUM3,NUM3+1
/CREATED BY SUBROUTINE BDEC.
 
DLZ	XX
	LAC	LZCT
	SNA!CLL!RAR	/ANY LEADING ZEROS?
	JMP	DLZ2	/NO
	SNL
	XOR	S01401	/DELETE TENS COUNT
	XOR	V00000	/DELETE HUNDREDS COUNT
DLZ2	XOR	NUM3
	JMP*	DLZ
	.EJECT
/PCKLCH
/ROUTINE TO PACK THE LINE AND CHAR  COUNT POINTED TO BY THE
/TRAILING PARAMETER INTO THE AC.
/CALLING SEQUENCE:
/	JMS	PCKLCH
/	LCT		/ADDR OF APPROP LINE COUNT WD
 
PCKLCH	XX
	LAC*	PCKLCH	/LOAD ADDR OF LINE COUNT
	ISZ	PCKLCH	/BUMP LINK
	DAC	ENUM	/HOLD
	LAC*	ENUM	/LOAD LINE COUNT
	DAC	ENUM+6	/HOLD
	ISZ	ENUM	/BUMP TO ADDR OF CHAR COUNT
	LAC*	ENUM	/LOAD CHAR COUNT
	CLL		/)CLEAR LINK AND
	JMS	MES	/)ROTATE LEFT
	JMP	LL+13	/11(DEC)
	TAD	ENUM+6	/ADD LINE COUNT
	JMP*	PCKLCH	/EXIT
	.EJECT
/EVA
/ROUTINE TO EVALUATE VIRTUAL ADDRESS OF FREE END OF STACK
/CALLING SEQUENCE	JMS	EVA
/		ADDRESS OF STACK BASE
/RESULT IS VIRTUAL ADDRESS IN AC AND SP00 AND IS 16 BIT
/STACK INDICATOR(4 BITS) + DISPLACEMENT (12BITS)
/SIGN BIT OF PARAMETER SET IF INDIRECT REFERENCE
/USES LOCATIONS SP00,SP01,SP02
 
EVA	XX
	LAC*	EVA	/GET PARAMETER
	DAC	SP00	/DUMP (IN CASE INDIRECT)
	SPA		/SKIP IF DIRECT
	LAC*	SP00	/RELOAD IF INDIRECT
	DAC	SP00	/DUMP ADDRESS OF BASE
	DAC	SP02	/:=ADDR OF BASE
	ISZ	SP00	/:=ADDR OF PTR
	LAC*	SP00	/VALUE OF PTR
	DAC	SP00	/:=ABS ADDR TO CONVERT
 
EVA01	LAC*	SP02	/VALUE OF BASE
	DAC	SP01
	CMA
	TAD	SP00	/ADDR-BASE VAL.-1 = DISPL.
	TAD	S07777	/VADDR+4095
	SPA		/VADDR > 12 BITS?
	JMP	EVA90
	TAD	Z70001	/REVERT TO DISPL. (-VE)
	AND*	SP01	/SET IN STACK #
	DAC	SP00	/STORE RESULT: ALSO IN AC
	ISZ	EVA
	JMP*	EVA	/EXIT
EVA90	LAW	-35	/REPORT ERROR 29 AND ABORT
	JMP	ODL01
 
/COMPUTE VADDR OF ABS ADDR GIVEN IN AC  WRT STACK SPECIFIED.
/CALLING SEQUENCE:
/	ABS ADDR IN AC
/	JMS	EVA00
/	ADDR OF SK BASE	/INDIRECTION NOT ALLOWED
 
EVA00	XX
	DAC	SP00	/:=ABS ADDR TO CONVERT
	LAC*	EVA00
	DAC	SP02	/:=ADDR OF BASE
	LAC	EVA00	/)MOVE LINK
	DAC	EVA	/)
	JMP	EVA01	/J & COMPUTE VADDR
	.EJECT
 
/VTOA***JDSMART  29/7/69
/SUBROUTINE TO CONVERT STACK DISPLACEMENT(VIRTUAL ADDRESS)TO AN
/ABSOLUTE CORE ADDRESS
/VIRTUAL ADDRESSES ARE 16BIT QUANTITIES OF THE FORM
/	LS 12 BITS GIVE DISPLACEMENT(0-4094)
/	TOP 4 BITS (B2-B5) INDICATE STACK REFERENCED
 
/ON ENTRY THE AC HOLDS THE VIRTUAL ADDRESS
/ON EXIT THE AC HOLDS THE CORRESPONDING ABSOLUTE ADDRESS
/AND IT IS DUMPED INTO SP00
/USES ROUTINES	RL6
 
/USES LOCATIONS	SP00,SP01,
 
 
VTOA	XX		/ON ENTRY AC=VIRTUAL
	DAC	SP01	/DUMP VIRTUAL
	JMS	MES	/GET INDICATOR TO LS END OF AC
	JMP	RR+14
	AND	C15
	RCL
	TAD	VTOA02	/)GET APPROP POSITION IN STACK
	DAC	VTOA01	/)INDICATOR CONVERSION TABLE
	LAC	SP01	/GET VADDR
	AND	S07777	/)MAKE REL TO BASE
	TAD	Z70001	/)-VE DISPL.
VTOA01	0	/TAD* VTOA02+1+SK#	:ADD BASE VALUE
	DAC	SP00	/)TO GIVE ABSOLUTE ADDRESS
	CMA		/-ABS ADDR-1
	ISZ	VTOA01	/STEP TO ADRR OF PTR
	XCT	VTOA01	/AC:=PTR ADDR-ABS ADDR-1
	SMA		/WITHIN CURRENT LIMIT OF STACK?
	JMP	VTOA90
	LAC	SP00	/LOAD RESULT
	JMP*	VTOA	/EXIT
VTOA90	LAW	-30	/REPORT ERROR 24 AND ABORT
	JMP	ODL01
	.EJECT
/MES	9SEP69	JDS

/MULTIPLE ENTRY SUBROUTINE
/CALL	JMS	MES
/	JMP	(LABEL)	/WHERE (LABEL) IS THE ADDRESS OF THE
/			/CODE TO BE EXECUTED
/
MES	XX
	JMP*	MES	/OBEY IN LINE JMP TO CODE 
	ISZ	MES	/BUMP LINK
	JMP*	MES	/RETURN
 
 
/SHIFT AC RIGHT UP TO 9 PLACES
	.REPT	11
	RAR
R	JMP	MES+2
 
/SHIFT AC LEFT TO 9 PLACES
	.REPT	11
	RAL
L	JMP	MES+2
RR=L-23
LL=R-23
	.EJECT
/UP
/SUBROUTINE TO MOVE STACKS UP THE CORE WHEN STACK OVERFLOW
/OCCURS. IF THE STACKS ARE TOO TIGHTLY PACKED TO BE MOVED
/UP TO 6 BUFFER-FULLS OF INTERMEDIATE CODE ARE OUTPUT (UNLESS
/THIS WOULD NOT RELIEVE THE JAM,WHEN THE RUN IS ABORTED
/AND AN ERROR MESSAGE OUTPUT).
/ENTRY	LOCN FREQD HOLDS 1+THE SIZE OF FREE SPACE
/	REQUIRED BEFORE THE STACK BELOW THE FREE SPACE IS
/	MOVED UP.
/EXIT	STACKS MOVED UP,BUFFER OUTPUT,OR ABORT.
/SCRATCHPAD USED: SP01,SP02
/AUTO-INDEX REGS. USED: 14,15
 
UP	XX
	DZM	SMF	/CLEAR "STACKS MOVED" FLAG
	LAC	FREQD
	SKP
UP02	LAC	FSREQD
	RCR
	DAC	FSREQD	/HALVE SIZE OF FREE SPACE REQD
	SNA		/RESULT=0?
	JMP	UP12	/YES,SO GO TO OUTPUT BUFFER
	LAC	AINBA
	DAC	SP02
UP04	ISZ	SP02
UP06	LAC*	SP02	/GET NEXT PTR
	SAD	OUT-1	/LAST FREE SPACE?
	JMP	UP10	/YES,SO EXIT FROM LOOP
	ISZ	SP02	/SP02:=ADDR OF NEXT BASE
	JMS	TCA
	TAD*	SP02	/AC:=-(FREE SPACE+1)
	TAD	FSREQD	/AC:=-(FREE SPACE-(FSREQD-1))
	SMA		/STACK TO BE MOVED?
	JMP	UP04	/NO,SO FIND NEXT FREE SPACE
	DAC	SMF
	JMS	TCA	/AC:=FREE SPACE -FSREQD
	DAC	SP01	/HOLD
	TAD*	SP02	/)SET NEW BASE ENTRY
	DAC*	SP02	/)IN STAT TABLE
	DAC*	C12	/HOLD
	ISZ	SP02	/SP02:=ADDR OF PTR
	LAC	SP01
	TAD*	SP02	/)SET NEW PTR ENTRY
	DAC*	SP02	/)IN STAT TABLE
	CMA		/ACC:=-(NEWPTR-1)
	TAD	C2
	DAC	SP01	/HOLD FOR USE IN LOOP
	JMP	UP09
UP08	LAC*	AUTO4	/START OF LOOP TO MOVE STACK UP
	DAC*	AUTO5
	ISZ	ISZCT
	JMP	UP08	
UP09	LAC*	C12	/LOAD OLD ADDR OF LAST WD MOVED
	TAD	SP01	/SUBTRACT (NEW PTR-1)
	SPA!SNA		/WHOLE STACK MOVED?
	JMP	UP06	/YES,SO JMP OUT OF LOOP
	TAD	SMF	/SUBTRACT NO. OF WORDS TO MOVE
	SMA		/SHORT BLOCK TO BE MOVED ?
	CLA		/NO ACC:=0
	JMS	TCA	/YES ACC=MODIFIER
	TAD	SMF	/MODIFY NO OF WORDS TO BE MOVED:=CNT
	DAC	ISZCT	/RESET COUNT FOR INNER LOOP
	LAC*	C12	/)
	TAD	ISZCT	/)RESET AUTO-INDICES
	DAC*	C13	/)FOR INNER LOOP
	TAD	SMF	/)
	DAC*	C12	/)
	JMP	UP08
UP10	LAC	SMF
	SNA		/ANY STACKS MOVED?
	JMP	UP02	/NO
	JMP*	UP	/YES,SO EXIT
UP12	LAW	-50
	TAD	SIZE	/AC:=(NO OF WDS ON OUT SK)-40
	SMA		/SHOULD BUFFER BE OUTPUT?
UP14	JMP	UP16	/YES
	LAW	-27	/NO,SO REPORT ERROR 23
	JMS	ERR
	JMP	P1C2-3	/AND RE-INITIALISE
UP15	.INIT	INTOUT,1,P1CON	/OBEYED ONCE ONLY
	.ENTER	INTOUT,GNC18	/ADDR OF FILENAME SET BY P1CON
	LAW	777377	/)
	AND*	AOPTW	/)SET IC MARKER IN OPT WD
	DAC*	AOPTW	/)
	ISZ	UP14	/CHANGE INSTN
	SKP	
UP16	JMP	UP15
	LAW	-6
	DAC	SP02	/SET COUNT FOR # BUFFERS
UP18	.WRITE	INTOUT,0,UP18,42	/BUFF ADDR SET BY P1CON
	LAC	SIZE
	TAD	K40
	JMS	TCA
	DAC	SP01	/HOLD CT FOR LOOP
	LAC	OUBASE
	TAD	C39
	DAC*	C12
	TAD	K40
	DAC*	C13
UP20	LAC*	AUTO4	/START OF LOOP
	DAC*	AUTO5
	ISZ	SP01	/END?
	JMP	UP20	/NO
	LAC	SIZE	/)DECREMENT SIZE BY
	TAD	K40	/)NO OF WDS
	DAC	SIZE	/)OUTPUT
	TAD	K40	/AC:=NEW SIZE-40
	SPA		/SIZE<40?
	CLA		/YES:AC:=0
	TAD	C39	/AC:=39 OR SIZE-1
	TAD	OUBASE
	DAC	OUT	/SET OUT SK PTR IN STAT TABLE
	ISZ	SP02	/SIX BUFFERS OUTPUT?
	SKP		/NO
	JMP*	UP	/YES,SO EXIT
	LAW	-50
	TAD	SIZE
	SMA		/CAN ANOTHER BUFFER BE OUTPUT?
	JMP	UP18	/YES
	JMP*	UP	/EXIT
	.EJECT
/TOPT
/TEST FOR OPTION
/CALL:	JMS	TOPT
/	MASK FOR OPTION
/RETURNS TO LINK IF OPTION SET(BIT=0)
/RETURNS TO LINK+1 IF OPTION NOT REQUIRED(BIT=1)
 
TOPT	XX
	LAC*	AOPTW	/LOAD OPTION WORD
	AND*	TOPT	/MASK FOR OPTION REQD
	ISZ	TOPT
	SZA		/OPTION REQD?
	ISZ	TOPT	/NO,SKP LOCATION
	JMP*	TOPT	/YES,RETURN
	.EJECT
/LAM****JDSMART   14/8/69
/ROUTINES TO LOAD AC FROM INDIRECTLY ADDRESS CORE (AFTER MODIFICATION)
/CALLING SEQUENCE 	JMS	LAM(LOAD AC) OR DAM(DUMP AC)
/			MOD+A
/WHERE LOCN.A CONTAINS ADDR TO BE MODIFIED AND THEN USED.
/'MOD' IS THE TOP 3 BITS(VALUE 0-7) WHICH IS ADDED TO THE
/ADDR FOUND TO GIVE THE EFFECTIVE ADDR.
/ROUTINE EQUIVALENT TO:-
/	LAC	A
/	TAD	MOD
/	DAC	SP00
/	LAC*	SP00
 
/OR TO	LAC*	A,X	WHERE INDEX REG.CONTAINS MOD
 
/USES LOCATIONS	SP00,SP01,SP02,SP03
/USES ROUTINE	EMA
/ON EXIT SP00 HOLDS ABS(15-BIT) ADDR OF CORE LOCATION REFERENCED.
 
EMA	XX	/EVALUATE MODIFIED ADDRESS GIVEN IN AC
	DAC	SP03
	RTL
	RTL
	AND	C7	/)EXTRACT MODIFIER AND
	DAC	SP01	/)DUMP IT
	LAC*	SP03	/)GET ADDRESS OF
	TAD	SP01	/)OF LOCATION REQUIRED
	DAC	SP00	/)&DUMP IT
	JMP*	EMA
 
LAM	XX		/LOAD AC FROM ABSOLUTE MODIFIED
	LAC*	LAM	/GET PARAMETER
	JMS	EMA	/EVALUATE MODIFIED ADDRESS
	LAC*	SP00	/LOAD REQUIRED CONTENTS
	ISZ	LAM
	JMP*	LAM	/EXIT
 
DAM	XX	/DUMP AC IN ABSOLUTE MODIFIED
	DAC	SP02	/STORE AC
	LAC*	DAM	/GET PARAMETER
	JMS	EMA	/EVALUATE MODIFIED ADDRESS
	LAC	SP02	/RELOAD AC
	DAC*	SP00	/DUMP IN SPECIFIED LOCATION
	ISZ	DAM
	JMP*	DAM	/EXIT
	.EJECT
/LVM****J.D.SMART 29/7/69
/ROUTINES TO LOAD AC AND DUMP AC FROM & TO VIRTUALLY ADDRESSED STORE
/CALLING SEQUENCE	JMS	LVM(LOAD AC FROM VIRTUAL)OR DVM
/		MOD+A
/WHERE LOCATION A CONTAINS A VIRTUAL ADDRESS,WHICH IS MODIFIED
/TO GIVE THE EFFECTIVE VIRTUAL ADDRESS.
/MOD IS THE TOP 3 BITS OF PARAMETER WD.(VALUE 0-7)
 
/USES LOCATIONS	SP00,SP01,SP02,SP03
 
/USES ROUTINES	EMA VTOA
/ON EXIT SP00 HOLDS ABS(15-BIT) ADDR OF CORE LOCN.REFERENCED
 
 
LVM	XX		/LOAD AC FROM VIRTUAL MODIFIED
	LAC*	LVM	/GET PARAMETER
	JMS	EMA	/EVALUATE REQUIRED VIRTUAL
	JMS	VTOA	/CURRENT VIRTUAL TO ABSOLUTE
	LAC*	SP00	/LOAD AC FROM ABSOLUTE
	ISZ	LVM
	JMP*	LVM	/EXIT
 
DVM	XX		/DUMP AC IN VIRTUAL MODIFIED
	DAC	SP02	/STORE AC
	LAC*	DVM	/GET PARAMETER
	JMS	EMA	/EVALUATE REQUIRED VIRTUAL
	JMS	VTOA	/CONVERT TO ABSOLUTE
	LAC	SP02	/RELOAD AC
	DAC*	SP00	/DUMP IN SPECIFIED LOCATION
	ISZ	DVM
	JMP*	DVM	/EXIT
	.EJECT
LDA0	XX
	JMS	LVM	/WORD 0 OF DICT ATTRS
	NAPTR		/D,A,UPNPTR
	JMP*	LDA0
 
LDA1	XX
	JMS	LVM	/WORD 1 OF DICT ATTRS
	M*1+NAPTR		/DIM,VOCPTR
	JMP*	LDA1
 
LDA2	XX
	JMS	LVM	/WORD 2 OF DICT ATTRS
	M*2+NAPTR		/DISPL OR STACK PTR
	JMP*	LDA2
 
LDA3	XX
	JMS	LVM	/WORD 3 OF DICT ATTRS
	M*3+NAPTR		/S,K,T,H,L
	JMP*	LDA3
 
LV4	XX
	JMS	LVM
	SP04
	JMP*	LV4
 
DDA2	XX
	JMS	DVM	/)SET DISPL IN
	M*2+NAPTR	/)DICT ATTRS
	JMP*	DDA2
	.EJECT
/COPY***JDSMART  14/8/69
/SUBROUTINE TO COPY BLOCKS OF CORE
/THREE PARAMETERS:-1)POSITION OF SOURCE AND MEANS OF ACCESS
/	2)POSITION OF DESTINATION AND MEANS OF ACCESS
/	3)LENGTH (IN WORDS)
/THERE ARE THREE MEANS OF ACCESS:-
/	1)ABSOLUTE CORE ADDRESS GIVEN
/	2)DISPLACEMENT IN STACK GIVEN (VIRTUAL ACCESS)
/	3)ON FREE END OF STACK (STACK ACCESS)
/THE ABOVE INFORMATION IS SUPPLIED BY THREE IN-LINE PARAMETERS
/FOLLOWING THE SUBROUTINE CALL:-
/	JMS	COPY
/	SOURCE INFO
/	DESTINATION   INFO
/	LENGTH (GIVEN POSITIVELY)
/THE SOURCE AND DESTINATION INFO TAKE THE FOLLOWING FORM
/MS 3 BITS ARE INDICATORS
/	BN(SIGN BIT)=1=>LEVEL OF INDIRECTION
/	B1=1=> POSITION GIVEN AS VIRTUAL ADDRESS
/	B2=1=> POSITION GIVEN AS STACK POINTER (ONLY IF B1=0)
/IF B1 =1 & B0=0 THEN LS 16 BITS ARE THE VIRTUAL ADDRESS OTHERWISE
/THE LS 15 BITS ARE ADDRESS APPROPRIATE TO SETTING OF B0,1&2
/THE ACCUMULATOR IS PRESERVED
/USES ROUTINES:-	PUT
/		VTOA
/		LVM
/USES LOCATIONS:	SP00,1,2
/USES AUTOINDICES:	AUTO2,AUTO3
 
COPY	XX		/LINK
	DAC	COPYSV	/DUMP AC
	LAC*	COPY	/PICK UP SOURCE INFO
	DAC	COPYSC	/DUMP(IN CASE INDIRECT)
	SPA		/SKIP IF NOT INDIRECT
	LAC*	COPYSC	/ACCESS ADDRESSED WORD
	DAC	COPYSC	/DUMP SOURCE POSITION
	LAC*	COPY	/RELOAD SOURCE INFO
	ISZ	COPY	/INCR.LINK TO DEST INFO
	SNA		/SOURCE = ZERO?
	JMP	COPY11	/YES: ARRANGE TO CLEAR DEST.
	RTL		/B1 TO LINK,B2 TO AC0
	SZL		/IS SOURCE A VIRTUAL ADDRESS?
	JMP	COPY06	/YES
	SPA		/IS SOURCE A STACK
	JMP	COPY08	/YES
/ABSOLUTE SOURCE-LOAD ADDRESS -1 INTO AUTOINDEX
	LAC	COPYSC	/LOAD SOURCE ADDRESS
COPY01	TAD	K1	/DECREMENT FOR AUTOINDEXING
	DAC*	C10	/DUMP IN AUTOINDEX 12
	LAC	ASCAB
COPY02	DAC	COPY05	/SET UP SOURCE ROUTINE
/PROCESS DESTINATION INFO
	LAC*	COPY	/LOAD DEST INFO
	DAC	COPYDT	/DUMP(IN CASE INDIRECT)
	SPA		/INDIRECT?
	LAC*	COPYDT	/YES:ACCESS ADDRESS
	DAC	COPYDT
	LAC*	COPY	/RELOAD DEST INFO
	SNA		/DEST. = ZERO?
	JMP	COPY12	/YES: ARRANGE NOT TO COPY SOURCE
	RTL
	SZL		/DEST VIRTUAL?
	JMP	COPY09	/YES
	SPA		/DEST A STACK
	JMP	COPY10	/YES
/ABSOLUTE DESTINATION-LOAD ADDRESS-1 INTO AUTOINDEX
	LAC	COPYDT	/DEST ADDRESS
COPY03	TAD	K1	/DECREMENT
	DAC*	C11	/DUMP IN AUTOINDEX 13
	LAC	ADTAB	/SET TO COPY ABSOLUTE
COPY04	DAC	COPY05+1	/SET UP DEST ROUTINE
	ISZ	COPY	/STEP AUTO TO LENGTH
	LAC*	COPY	/LOAD LENGTH
	DAC	COPYCT	/DUMP IN COUNT
	SPA		/INDIRECT REF
	LAC*	COPYCT	/YES-LOAD LENGTH
	SNA		/ZERO?
	JMP	COPY05+4	/YES,SO DO NOTHING
	JMS	TCA	/NEGATE COUNT
	DAC	COPYCT	/DUMP
COPY05	XX		/GET WORD FROM SOURCE
	XX		/PUT RESULT IN DESTINATION
	ISZ	COPYCT	/INCREMENT COUNT
	JMP	COPY05	/REPEAT IF NONZERO
	ISZ	COPY	/STEP  LINK
	LAC	COPYSV	/RESTORE AC
	JMP*	COPY	/EXIT
 
/VIRTUAL SOURCE-CONVERT TO ABSOLUTE IF DEST. NOT A STACK
COPY06	LAC*	COPY	/LOAD DEST INFO
	RTL		/B2 TO AC0
	SMA		/IS DEST A STACK?
	JMP	COPY07	/NO
	SZL		/IS IT VIRTUAL?
	JMP	COPY07	/YES: S BIT IS SK#
	LAC	ASCV	/SET TO COPY FROM VIRTUAL
	JMP	COPY02
 
/CONVERT VIRTUAL SOURCE TO ABSOLUTE
COPY07	LAC	COPYSC	/VIRTUAL ADDRESS TO AC
	JMS	VTOA	/CONVERT TO ABSOLUTE &
	JMP	COPY01	/J TO LOAD INTO AUTOINDEX
 
/SOURCE A STACK
COPY08	LAC	ASCS	/SET TO COPY FROM STACK
	JMP	COPY02
 
/CONVERT VIRTUAL DESTINATION TO ABSOLUTE
COPY09	LAC	COPYDT	/VIRTUAL ADDRESS TO AC
	JMS	VTOA	/CONVERT TO ABSOLUTE &
	JMP	COPY03	/LOAD INTO AUTOINDEX
 
/DESTINATION A STACK
COPY10	LAC	ADTS	/SET TO COPY STACK
	JMP	COPY04
 
/	ZERO SOURCE
COPY11	LAC	ASCZE	/SET AC CLEAR AS SOURCE
	JMP	COPY02
 
/	ZERO DEST.
COPY12	LAC	ADTZE	/SET NOT TO WRITE TO DEST
	JMP	COPY04
 
/ADDRESS OF CODE SEQUENCES FOR LOADING AND DUMPING AC APPROPRIATELY
ASCAB	LAC*	AUTO2	/ABS. SRC
ASCS	JMP	SCS	/SRC A STACK
ASCV	JMP	SCV	/VIRTUAL SRC
ASCZE	CLA		/ZERO SRC
ADTAB	DAC*	AUTO3	/ABS,VIRT DEST
ADTS	JMP	DTS	/DEST A STACK
ADTZE	NOP		/ZERO DEST
			/DUMP AC ON STACK
DTS	JMS	PUT
COPYDT	.DSA	/DESTINATION ADDRESS IN APPROPRIATE FORM
	JMP	COPY05+2
			/LOAD AC FROM VIRTUAL
SCV	JMS	LVM	/
	COPYSC		/ADDR. OF VIRT ADDR
	ISZ	COPYSC	/REDUCE VADDR BY ONE
	JMP	COPY05+1 	/J TO DUMP AC
			/LOAD AC FROM STACK
SCS	LAC*	COPYSC	/GET ADDRESS OF STACK PNTR
	DAC	SP00	/DUMP IT
	LAC*	SP00	/LOAD STACK WORD
	ISZ*	COPYSC	/TAKE WORD OFF STACK
	JMP	COPY05+1	/J TO DUMP AC
	.EJECT
/EXPAND SORT,KIND & TYPE FROM DICT ATTRS INTO MARKERS IN Q
/ON ENTRY DICT WORD IN AC
XSKT	XX
	RTL
	RAL		/SORT TO LS END AC
	DAC	SP00
	AND	C3	/SORT=1,2&3
	TAD	ASORT
	DAC	XSKT01
	LAC	SP00
	RTL		/KIND TO LS END AC
	AND	C3	/=0,1,2 OR 3
	TAD	AKIND
	DAC	XSKT01+1
	LAC	SP00
	JMS	MES
	JMP	L-5	/TYPE TO LS END OF AC
	AND	C7	/=1 THRU 7
	TAD	ATYPE
	DAC	XSKT01+2
XSKT01	LAC	SORT
	XOR	KIND
	XOR	TYPE
	DAC	Q
	JMP*	XSKT
	.EJECT
Q.SKT1	XX
	ISZ	SP00	/COUNT BITS SHIFTED OFF
	RAR
	SNL!CLL
	JMP	.-3	/REPEAT IF BIT=0
	LAC	SP00
	RTL		/SP00=BIT CT*4
	JMP*	Q.SKT1
/COMPRESS Q INTO SKT FOR PACKING INTO DICT INFO
Q.SKT	XX
	DZM	SP00
	LAC	Q
	JMS	MES
	JMP	RR+13	/SORT(Q)TO LS END
	JMS	Q.SKT1	/FIND POSN OF SORT BIT
	TAD	K1
	DAC	SP00	/=SORT-1
	LAC	Q
	JMS	MES
	JMP	R-7	/KIND(Q) TO LS END
	JMS	Q.SKT1	/FIND POSN OF KIND BIT
	RAL		/LEAVE SPACE FOR 3 BIT TYPE
	DAC	SP00
	LAC	Q
	JMS	Q.SKT1	/FIND POSN OF TYPE BIT
	JMS	MES	/SHIFT RESULTANT SKT
	JMP	L-11	/TO TOP OF AC
	JMP*	Q.SKT
	.EJECT
/POLOUT
/ROUTINE TO COPY THE WHOLE OF THE POLISH STACK TO OUT,
/INVERTING AT THE SAME TIME.
 
POLOUT	XX
	JMS	EVA	/)GET VADDR OF FREE END OF
	.DSA	POBASE	/)POLISH STACK
	TAD	Y50001	/AC:=-NO.OF WDS TO BE MOVED
	JMS	TCA	/NEGATE IT
	DAC	.+4	/SET NO.OF WDS TO COPY
	JMS	COPY
	M*1+POLISH
	M*1+OUT
	0
	JMP*	POLOUT
 
/TCA
/ROUTINE TO TWO'S COMPLEMENT THE AC
TCA	XX
	CMA
	TAD	C1
	JMP*	TCA
 
/TARG
/SUBROUTINE TO CHECK THE NO OF ARGS  TO A REVPOL OPERATOR
/ENTER AND EXIT WITH NO IN AC
TARG	XX
	DAC	SP02	/STORE ARG COUNT
	TAD	K63
	SPA		/TOO MANY ARGS?
	JMP	TARG2	/NO
	LAW	-61	/REPORT ERROR 49
	JMS	ERR
TARG2	LAC	SP02
	AND	S00077	/GET L.S.6 BITS IN CASE OF ERROR
	JMP*	TARG	/RETURN WITH NO IN AC
 
/TLPTRS
/SUBROUTINE TO SET POINTERS IN LOCATIONS CCODE AND GTNEXT
/APPROPRIATE TO TOP LEVEL ANALYSIS
TLPTRS	XX
	LAC	ACEL
	DAC	CCODE
	LAC	AGNEL
	DAC	GTNEXT
	JMP*	TLPTRS
	.EJECT
/BDEC
/ROUTINE TO CONVERT + NO IN AC ON ENTRY TO DECIMAL AND
/5-7 PACK IN WD-PR NUM3,NUM3+1.
/THE NUMBER IS TREATED MODULO 1000(DEC)
/LEADING ZEROS ARE NOT DELETED AND TWO TRAILING SPACES
/ARE PACKED INTO THE WD-PR
 
BDEC	XX
	DZM	LZCT	/CLEAR COUNT OF LEADING ZEROS
	DZM	BDEC10	/CLEAR DECIMAL DIGIT COUNT
	DZM	BDEC11	/          ,,
	TAD	K1000
	SMA
	JMP	.-2
	TAD	C1000
BDEC1	TAD	K100	/SUBTRACT 100(DEC)FROM ERROR NUMBER
	SPA		/NUMBER NEGATIVE?
	JMP	BDEC2	/YES
	ISZ	BDEC10	/NO:INCREMENT HUNDREDS COUNT
	JMP	BDEC1	/LOOP
BDEC2	TAD	C100	/ADD 100 (DEC) TO NUMBER
BDEC3	TAD	K10	/SUBTRCT 10 (DEC) FROM NUMBER
	SPA!STL		/NUMBER NEGATIVE?
	JMP	BDEC4	/YES
	ISZ	BDEC11	/NO:INCREMENT TENS COUNT
	JMP	BDEC3
BDEC4	TAD	C10	/ADD 10 (DEC) TO NUMBER & CLEAR LINK
	RTR
	RTR
	XOR	S20100
	DAC	NUM3+1	/STORE 3 BITS+2 SPACES
	GLK
	DAC	NUM3	/STORE TOP 4 BITS(TOP 3 BITS ZERO)
	LAC	BDEC10	/LOAD HUNDREDS COUNT
	SNA		/ZERO?
	ISZ	LZCT	/YES
	JMS	MES	/)ROTATE LEFT 7
	JMP	L-7	/)
	TAD	BDEC11	/ADD TENS COUNT
	SNA		/STILL ZERO?
	ISZ	LZCT	/YES
	RTL
	RTL		/ROTATE LEFT 4
	XOR	NUM3	/ADD TOP 4 BITS OF UNITS COUNT
	XOR	V01406	/FOLLOWED BY CONVERSION TO ASCII
	DAC	NUM3	/STORE
	JMP*	BDEC	/EXIT
	.EJECT
/INIT
/SUBROUTINE TO INITIALISE OUT SK
 
INIT	XX
	LAC*	S00102	/GET 1ST FREE REG
	AND	S77777	/HOLD 15 BITS
	TAD	C75
	DAC	OUT	/SET OUT SK PTR
	TAD	K39
	DAC	OUBASE	/SET OUBASE
	DZM	SIZE	/ZERO NO. OF WDS ON OUT SK
	TAD	K2
	DAC	UP18+2	/SET L.B. ADDR IN WRITE IN UP
	TAD	K1
	DAC	BLKADD
	JMP*	INIT
	.EJECT
/UNP5.7
/ROUTINE TO UNPACK INPUT BUFFER
 
UNP5.7	XX
GNC07	ISZ	GNC08	/BUMP SWITCH TO NEXT CHAR
	LAC*	GNC75	/LOAD CURRENT WORD OF PR
GNC08	XCT	GNC06+4
GNC10	AND	S00177
	JMP*	UNP5.7	/EXIT WITH 7 BIT CHAR IN AC
GNCH1	ISZ	GNC75
	LAC	GNC06	
	DAC	GNC08	/RESET MULTI-WAY SWITCH
	LAC*	GNC75	/LOAD FIRST WORD OF PR
	RTL		/GET FIRST CHAR TO BOTTOM END
	RTL
GNC04	RTL
	RTL
	JMP	GNC10
GNCH3	RAR		/ENTRY FOR THIRD CHAR IN WD PR
	AND	C7	/GET TOP 4 BITS OF CHAR
	DAC	SP00	/STORE
	ISZ	GNC75	/BUMP PTR TO 2ND WD OF PR
	LAC*	GNC75
	AND	Z00000	/GET BOTTOM 3 BITS OF CHAR
	XOR	SP00	/COMBINE
	JMP	GNC04
GNCH4	RTR
	RTR
GNCH2	RTR
	RTR
	JMP	GNC10
GNC06	XCT	GNC06	/INST TO BE PICKED UP,NOT OBEYED
	JMP	GNCH2
	JMP	GNCH3
	JMP	GNCH4
	RAR
	JMP	GNCH1
	.EJECT
/EOP
/ROUTINE TO WRITE TO THE TTY OR LISTING DEV "EOP1" FOLLOWED BY
/THE NUMBER OF ERRORS FOUND IN PASS1.
 
EOP	XX
	LAC	ERRNUM	/LOAD NO. OF ERRORS
	JMS	BDEC	/CONVERT TO DEC
	JMS	DLZ	/DELETE LEADING ZEROS
	DAC	EOPNUM	/PUT FIRST WD OF PR IN BUFFER
	LAC	NUM3+1	/LOAD 2ND WD OF PR
	XOR	S04672	/CONVERT TO "),ALTMODE"
	DAC	EOPNUM+1	/PUT 2ND WD OF PR IN BUFFER
EOP2	.WRITE	DATOUT,2,EOPBUF,6
	JMP*	EOP
 
EOPBUF	3002
	0
	.ASCII	!EOP1(!
EOPNUM	0
	0
 
/BLKSET
/SUBROUTINE TO SET UP ABSOLUTE BLOCK # (ON SYSTEM TAPE)
/OF START OF PASS 1
 
BLKSET	XX
	LAC	S25500	/SET UP HEADER WORD FOR INT CODE .WRITE
	DAC*	UP18+2
	LAC*	S00100	/GET ADDR OF BLOCK #
	DAC	FNCC
	ISZ	FNCC
	LAC*	FNCC	/GET BLOCK #
	DAC*	BLKADD	/PUT IN ALCOM LOCATION
	JMP*	BLKSET
/CSTAT
/ROUTINE TO COPY THE STAT TABLE TO THE SPACE RESERVED FOR IT AT
/THE BOTTOM OF CORE,CLOSE THE INT CODE FILE IF PRESENT
/AND OUTPUT EOP1(N) TO THE TTY
 
CSTAT	XX
	LAC*	S00102
	AND	S77777
	TAD	C5
	DAC	CSTAT2
	JMS	COPY
	INBASE
CSTAT2	0
	32
	JMS	TOPT
	400		/INT CODE?
	SKP		/YES
	JMP	.+3	/NO
	.CLOSE	INTOUT
	JMS	EOP
	.WAIT	-3
	JMP*	CSTAT
	.EJECT
/	VTOA CONVERSION TABLE
 
VTOA02	TAD*	.+1	/SK#
		VOBASE	/0
		VOCAB
		RLBASE	/1
		REAL
		INBASE	/2
		INTEGR
		INBASE	/3
		INTEGR
		STBASE	/4
		STRING
		LABASE	/5
		LABEL
		DIBASE	/6
		DICT
		PRBASE	/7
		PROC
		SWBASE	/8
		SWITCH
		RPBASE	/9
		REVPOL
		POBASE	/10
		POLISH
		WKBASE	/11
		WORK
		OWBASE	/12
		OWN
		OUT	/13
		OUBASE
 
/ELTAB
/LOOK-UP TABLE TO OBTAIN FROM THE L.S. 6 BITS OF THE CURRENT BASIC 
/SYMBOL CODE THE ADDR OF THE APPROPRIATE PHASE 1 SYNTAX BLOCK.
ELTAB	NAME1
	TYPE1
	TYPE1
	TYPE1
	GOTO1
	IF1
	FOR1
	VALUE1
	TYPE11
	SWCH1
	PROC1
	LSTR1
	LSTR1
	OWN1
	EXT1
	.EJECT
/TXB2
/LOOK-UP TABLE USED BY PHASE 2 TO OBTAIN FROM THE MIDDLE SIX
/BITS OF THE CURRENT REVPOL OPERATOR WORD THE ADDRESS OF THE
/APPROPRIATE SYNTAX BLOCK
TXB2	POS2
	A+TYPE2
	A+TYPE2
	A+TYPE2
	A+TYPE2
	A+TYPE2
	A+SPEC2
	OWN2
	A+VAL2
	PAR2
	A+ASS2
	IFEX2
	DYAD2
	DYAD2
	DYAD2
	DYAD2
Z77700	777700
	DYAD2
	DYAD2
	DYAD2
	A+FOR2
	DYAD2
	DYAD2
	DYAD2
	AF2
	WH2
	STEP2
	GOTO2
	BEXP2
	PC2
	A+FC2
	A+SV2
	DYAD2
	DYAD2
	DYAD2
	DIV2
	DYAD2
	XPN2
	EXT2
	NEG2
	ARD2
	A+PDEC2
	ASEG2
	A+BPL2
	LAB2
	A+SW2
Z77600	777600
Z77400	777400
Z77000	777000
Z74000	774000
	BEXP2
/ADDRESS CONSTANTS
 
AAINBA	INBASE-1
AAKTAB	KTAB-1
AANCB	NCB-1
AARVOP	RVOP-1
AASTIN	STINIT-1
ABS	BS
ABSS	BSS-40
ACEL	CEL
ACTN	CTN
ADICT=VTOA02+16
AELTAB	ELTAB-37
AEXP22	EXP22
AFC42	FC42
AFPEL1	FPEL1
AGLOBL	GLOBL-1
AGNBS	GNBS
AGNEL	GNEL
AINBA	INBASE
ALABEL=VTOA02+14
ALANAL	LANAL
ALPROP	LPRORP
ANCB	NCB
AOUT	OUT
APRORP	PRORP
APTAB	PTAB
APUTO	PUTOUT
APUTP	PUTPOL
APUTR	PUTRP
AQ	Q
ATQ	TQ
ATRUE	TRUE
ATXB2	TXB2
	.EJECT
/TQ
/TABLE USED BY THE ACTION PH2
TQ	210240
	210220
	204201
	220240
	204220
 
/SORT
/TABLE USED BY SUBROUTINE XSKT
SORT	204000	/SORT	/1=ARRAY
	210000		/2=VARIABLE
	220000		/3=PROC
KIND	200	/KIND	/0=ACTUAL
	400		/1=OWN
	1000		/2=FORMAL BY VALUE
TYPE	2000		/3=FORMAL BY NAME
	1	/TYPE	/1=REAL
	2		/2=INTEGER
	4		/3=BOOLEAN
	10		/4=STRING
	20		/5=LABEL
	40		/6=NONE
	100		/7=INVALID
AKIND	XOR	KIND
ASORT	LAC	SORT-1
ATYPE	XOR	TYPE
 
/ELEMENT CODES
ASEL=12010
PSEL=12020
IFEL=2030
FOREL=2040
SLIST=450
VALEL=460
OTDEC=1070
TLIST=1500
GOTEL=12211
LBLEL=2021
ARDEC=1212
ARSP=422
FPEL=1003
SWDEC=1204
SCEL=110
BEGEL=20120
ENDEL=130
ELSEL=4140
INVEL=150
XHEL=40160
EXTEL=4170
	.EJECT
/RVOP: TABLE OF REVERSE POLISH OPCODES, ACCESSED BY A LOOK-UP ON THE
/L.S. 6 BITS OF THE CURRENT BASIC SYMBOL CODE.
/THE FOLLOWING CODES ARE USED BY OUTOP1
RVOP	246201	/NOT
	251402	/AND
	261502	/OR
	271602	/IMPL
	301702	/EQUIV
	205300	/BPL(BOUND PAIR LIST) ([)
	603777	/SV(SUBSCRIPTED VARIABLE) (])
PLUS	224002	/PLUS(DYADIC +)
MIN	224102	/MINUS(DYADIC -)
	214202	/MULT(*)
	214302	/DIV(/)
	214402	/IDIV
	204502	/XPN(^)
	201101	/PAR (PARENTHESIS PAIR) ( ( )
	603677	/FC(FUNCTION CALL) ( ) )
	232702	/GT(>)
	232502	/GE(>=)
	232202	/EQ(=)
	232602	/NE(#)
	232302	/LE(<=)
	232102	/LT(<)
	201201	/ASS(ASSIGNMENT) (:=)
	205401	/LAB(LABEL) (:)
	203203	/STEP(STEP UNTIL ELEMENT)
	201303	/IFEXP(IF EXP) (THEN)
	203102	/WHILE
	37776	/FALSE
	37775	/TRUE
NUMI	20000	/INTEGER STACK PTR
NUMR	10000	/REAL STACK PTR
NAME	0	/VOCAB STACK PTR
	210101	/REAL
	210201	/INTEGER
	210301	/BOOLEAN
	213301	/GOTO
	203401	/IFS(IF STATEMENT) (IF)
	202401	/FOR
	201001	/VALUE
	205000	/ARD(ARRAY DEC) (ARRAY)
	205501	/SWITCH(DEC)
	205101	/PDEC(PROCEDURE DEC) (PROCEDURE)
	200501	/LABS(LABEL SPEC) (LABEL)
	200401	/STRING(SPEC)
	220701	/OWN
	204601	/EXTERNAL
STRNG	40000	/STRING STACK PTR
/THE FOLLOWING CODES ARE USED BY OUTOP2 WITH THE WORK STACK
	212000	/ENDC(END OF IF STAT)
	215201	/ASEG(ARRAY SEGMENT)
	203501	/PC(PROCEDURE CALL)
	220001	/POS(MONADIC +)
NEG	224701	/NEG(MONADIC -)
	203001	/AFOR(SIMPLE FOR LIST ELEMENT)
	206000	/ENDP(END OF PROC DEC)
	202000	/ENDF(END OF FOR STAT)
/THE FOLLOWING CODES ARE USED BY OUTOP2 WITH OUT
PTAB	206400	/ELSE
	206300	/ENDD(END OF DECS)
	.EJECT
/START OF KEYWORD TABLE. THE KEYWORDS ARE STORED IN RADIX 50 WITH THE
/LAST WORD RIGHT JUSTIFIED. THE INTERNAL CODE (ONE WORD) FOR EACH
/KEYWORD FOLLOWS ITS RADIX 50 REPRESENTATION.
KTAB	470511	/REAL
	14
	320040
	435204	/INTEGER
	420135
	22
	320041
	023752	/FOR
	220045
	474745	/STEP
	20
	200030
	502604	/UNTIL
	564
	200064
	406517	/BEGIN
	566
	260060
	020564	/END
	260061
	764	/LT
	210025
	454	/GT
	210020
	331	/EQ
	210022
	745	/LE
	210024
	435	/GE
	210021
	1065	/NE
	210023
	556	/IF
	220044
	477105	/THEN
	16
	200031
	257	/DO
	200063
	420463	/ELSE
	5
	260062
	427054	/GOTO
	17
	220043
	404442	/ARRAY
	101
	220047
	1152	/OR
	210003
	4164	/AND
	210002
	054754	/NOT
	210001
	463337	/PROCEDURE
	411614
	103025
	220051
	412445	/COMMENT
	451026
	24
	200065
	504664	/VALUE
	1515
	220046
	445452	/LABEL
	324
	220052
	060546	/OWN
	220054
	421424	/EXTERNAL
	421036
	64
	220055
	474762	/STRING
	035167
	220053
	407347	/BOOLEAN
	445711
	16
	320042
	510411	/WHILE
	745
	200032
	475141	/SWITCH
	076600
	220050
	477745	/TRUE
	5
	200234
	422664	/FALSE
	1375
	200233
	434351	/IDIV
	26
	210014
	420775	/EQUIV
	576
	210005
	435130	/IMPL
	14
	210004
	414474	/DATSLOT
	474257
	24
	200076
	770001	/EOT
	.EJECT
/LOOK-UP TABLE TO CONVERT 7-BIT ASCII CODES TO INTERNAL CODES.
BSS	200072	/SPACE(USED IN COMSTR DECODER)
EXC	200071	/!(USED IN STRINGS)
	200056	/"(STRING QUOTE)
	214047	/#
	200077	/$(INVALID)
	204033	/%
	210002	/&(EQUIV TO 'AND')
	200074	/'(KEYWORD QUOTE)
	200216	/(
	200017	/)
	210012	/*(MULTIPLY)
	210010	/+
	200057	/,
	210011	/-
	204034	/.
	210013	//(DIVIDE)
	203035	/0
	203036	/1
	203037	/2
	203040	/3
	203041	/4
	203042	/5
	203043	/6
	203044	/7
	203045	/8
	203046	/9
	200027	/:
	260056	/;
	210025	/<(EQUIV TO 'LT')
	210022	/=(EQUIV TO 'EQ')
	210020	/>(EQUIV TO 'GT')
	200077	/?(INVALID)
	200067	/@(TEN TO THE POWER)
ALET	201401	/A
	101402	/B
	201403	/C
	1504	/D
ELET	11405	/E
FLET	201406	/F
	201407	/G
	201410	/H
	201411	/I
	201412	/J
	201413	/K
LLET	21414	/L
	1615	/M
	201416	/N
	3417	/O
	5420	/P
QLET	201421	/Q
	201422	/R
SLET	201423	/S
TLET	401424	/T
	201425	/U
	201426	/V
	201427	/W
	41430	/X
	201431	/Y
	201432	/Z
	200106	/LEFT SQ BRACKET
	200077	/BACK SLASH(INVALID)
	200007	/RT SQ BRACKET
	210015	/^(EXPONENTIATION)
	200026	/_(:=)
SEXH	200070	/SOURCE EXHAUSTED
	.EJECT
/GLOBAL LOCATIONS (I.E. LOCATIONS USED BY MORE THAN ONE ROUTINE WITH
/PRESERVATION OF CONTENTS NEEDED BETWEEN USES).
AOPTW	XX	/ADDR OF OPTION WD
ARGCT	XX
ASSQ	XX	/Q FOR LHS'S OF ASSIGNMENTS
AXW	XX	/ADDR OF EXTENSION WD IN FILENAME BLOCK
BANK	XX
BLKADD	XX	/ADDR OF ALCOM WORD GIVING BL # OF PASS1 START
BS	XX
BSW	XX
CCODE	BSW
CEL	XX
CTN	XX
CTB	XX
CTA	XX
CTI	XX
CV	XX	/HOLDS VOCPTR TO CONTROLLED VARIABLE
DEST	PUTOUT
DIMA	XX	/#DIMS OR PARAMS
DLST	XX	/PTR TO PTR TO FREE END OF LABEL OR DICT SK
ELANAL	1
ERRORT	JMS	ERR	/HOLDS JMP OR JMS TO REPORT ERRORS
EXTMRK	XX	/EXTERNAL CODE MARKER(1=EXT)
FREQD	40	/CONTROLS OPERATION OF ROUTINE UP
GTNEXT	BSCON
LCT	67	/COUNT OF NO OF LINES ON LISTING PAGE
LZCT	XX	/COUNT OF LEADING ZEROS
MAP	XX	/USED BY CDVW AND MULT
NC	XX
NCB	XX
NCB1	XX
NCB2	XX
NUM3	XX	/)HOLDS ASCII WD-PR
	XX	/)CREATED BY ROUTINE BDEC
NXTRQD	-1
PA	XX	/VADDR OF PROC ATTRS DURING DECLARATION
Q	XX	/PHASE 2 CONTROL WORD
Q3	XX	/USED BY PH2 CATOM TESTS QHOLD & PBPL
RESLT	XX	/USED BY CDVW, MULT AND OTOWN
RESULT	XX
STATE	XX
STWDAD	XX
STLIM	XX
STPTR	XX
VA1	XX	/)HOLD REVPOL VADDRS OF START & END
VA2	XX	/)OF STEP EXPRESSIONS
XB	XX
 
/GLOBAL LOCNS INITIALLY ZERO
OTCD	0	/OBJECT TIME COMMON DISP
MAXOTD	0	/MAX OTD REACHED IN NESTED BLOCKS
MAXL	0	/MAX LEVEL REACHED IN NESTED BLOCKS
SIZE	0	/NO. OF WDS OF INT. OUTPUT IN CORE
ISZCT	0
OTD	0	/OBJECT TIME DISPL.
	0	/SPACE FOR VADDR(DICT)WHEN STACKED BY ODL
CHL	0	/NEW NAME ATTRS(4 WDS)
	0
VOCPTR	0
NAPTR	0
ALTMOD	0	/ALT MODE FLAG
DCT	0	/USED IN ROUTINE PUT
EMF	0	/DITTO
EMODE	0	/DITTO
ERRMOD	0	/ERROR MODULE FLAG
ERRNUM	0	/NO. OF ERRORS FOUND
FPLERR	0	/SET(=1)WHEN PH1 FAILS ON FPEL FOR FOLLOWING
		/VAL&SPEC ELS(PH2) AND ENDSP(CLEARED)
LIST	0	/SOURCE LISTING FLAG
PAGECT	0	/COUNT OF NO OF LISTING PAGES
PRESET	0	/PRESET PROC FLAG
XDICT	0	/EXPAND DICT INFO FLAG
	.EJECT
/LOCATIONS USED TO MAINTAIN LINE AND CHAR COUNTS FOR
/CHARACTERS,BASIC SYMBOLS AND ELEMENTS FOR USE
/IN ERROR REPORTING.
 
LCT1	0	/POINTS TO CURRENT CHAR
CHPOS1	5
LCT2	0	/POINTS TO LAST MEANINGFUL CHAR
CHPOS2	0
LCT3	0	/POINTS TO START OF CURRENT BS
CHPOS3	0
LCT4	0	/POINTS TO END OF LAST BS
CHPOS4	0
LCT5	0	/POINTS TO START OF CURRENT ELEMENT
CHPOS5	0
LCT6	0	/POINTS TO END OF CURRENT BS
CHPOS6	0
 
/SCRATCHPAD
 
SP00	XX
SP01	XX
SP02	XX
SP03	XX
SP04	XX
SP05	XX
SP06	XX
	.EJECT
/LOCAL STORAGE
ANAL90=CSTAT	/USED BY CONTROL ROUTINE ANAL
A0=NSTK	/USED BY CDVW
CDL90=GNBS64	/USED BY PHASE 2 DICTIONARY ROUTINE CDL
CDL91=GNBS61
CDL92=OBEY
COPYSV=OPOUT	/USED BY GENERAL-PURPOSE ROUTINE COPY
COPYSC=FIX
COPYCT=FLOAT
ERRNO=DIPOL	/HOLDS ERROR NO.GENERATED BY CATOM TEST CQQ
FQ=OTS00	/HOLDS Q FOR FORMAL PARAM IN PH2 CATOM TEST CAFC
FSREQD=DIM	/FREE SPACE REQD BY ROUTINE UP
OP=MULT	/HOLDS OPERATOR USED BY CATOM TEST CQQ
PACK90=Q.SKT1	/USED BY ROUTINE PACK
PACK92=Q.SKT	/DITTO
PTRADD=TLPTRS	/USED BY PUT
Q2=UNP5.7	/USED BY PHASE 2 CATOM TEST CQQ
REALS=EOP	/USED BY RSTK
SMF=RSTK	/USED BY ROUTINE UP
BDEC10=INIT	/USED BY ROUTINE BDEC
BDEC11=TOPT
OUTOP8=P1CON	/FOR OP ADDR AND OP IN OUTOP
OUTOP9=ISTK	/FOR PREC IN OUTOP
	.EJECT
/NUMERICAL CONSTANTS
	.DEC
C1=TYPE+1
C2=TYPE+2
C3=QUAN61-1
C4=TYPE+3
C5=KTAB+40
C6	6
C7	7
C8=TYPE+4
C9	9
C10	10
C11	11
C12=KTAB+1
C13	13
C15=KTAB+43
C21	21
C25	25
C32=TYPE+6
C34	34
C39	39
C40	40
C50	50
C56	56
C69	69
C75	75
C100	100
C1000	1000
K1=GNEL30-3
K2=QUAN21+2
K3=QUAN71+2
K4=SEXP71+2
K5=EXP21-2
K8=GNEL2-8
K9=NAME91-2
K10=IF1+2
K14=FLE61+2
K15=QUAN1-5
K18=BPL21-2
K19=BPL41+2
K23=UP14+1
K24=VTOA90
K26=FORL1+3
K28=FLE41-2
K29=EVA90
K32	LAW	-32
K39	LAW	-39
K40=UP12
K49=TARG2-2
K63	LAW	-63
K64=Z77700
K100	LAW	-100
K1000	LAW	-1000
	.OCT
S00010=C8
S00011=C9
S00012=C10
S00013=C11
S00014=KTAB+1
S00015=C13
S00016	16
S00017=KTAB+53
S00020=KTAB+12
S00037	37
S00040	40
S00041	41
S00042	42
S00060	60
S00067	67
S00070	70
S00077	77
S00100=TYPE+7
S00102	102
S00103	103
S00105	105
S00112	112
S00116	116
S00117	117
S00140	140
	.IFDEF	DOS
S00155	155
	.ENDC
S00175	175
S00176	176
S00177	177
S00200=KIND
S00400=KIND+1
S00401	401
S00700	700
S00766=GNC103-3
S01000=KIND+2
S01400	1400
S01401	1401
S02000=TYPE
S02766=GNC22-2
S02775	2775
S03700	3700
S03777	3777
S04000=SV12
S04004	4004
S04102	4102
S04400	4400
S04532	4532
S04672	4672
S05400	5400
S06011	6011
S06100	6100
S07700	7700
S07777	7777
S10000=SEXP41
S10020	10020
S10047	10047
S10300	10300
S14000	14000
S17777	17777
S20000=MODL61
S20100	20100
S25132	25132
S27776	27776
S30000	30000
S30001	30001
S40000=COMP11
S60000	60000
S77777	77777
T00000=OWN1
T43777	143777
T70000	170000
T77777	177777
U00000=EXP51+1
U00001	200001
U00017=BSS+11
U00026=BSS+77
U00027=BSS+32
U00057=BSS+14
U00065=KTAB+75
U00067=ELET-5
U00070=BSS+100
U00074=BSS+7
U00076=BSS-2
U00077=BSS+4
U00110=SCIV11
U00130=COMP51
U00140=STAT61
U00150=SCIV1
U00216=BSS+10
U00235	200235
U00236	200236
U00600	200600
U01003=DEC1
U01202	201202
U03601	203601
U04033=EXC+4
U04034=EXC+15
U06100	206100
U06501	206501
U06600	206600
U07000	207000
U07001	207001
U07601	207601
U07701	207701
U07777	207777
U10010=BSS+13
U10011=BSS+15
U10020=BSS+36
U10021=KTAB+35
U10022=BSS+35
U10023=KTAB+37
U10024=KTAB+33
U10025=BSS+34
U14047=EXC+2
U17201	217201
U20000=SORT+2
U20037=QUAN1
U20044=KTAB+41
U20055=KTAB+111
U20120=CB1
U34177	234177
U40160	240160
U50200	250200
U60056=BSS+33
U60060=KTAB+21
U60061=KTAB+23
U60062=KTAB+51
V00000	300000
V01406	301406
V77701	377701
V77777	377777
W00000=EXP21-1
W00001	400001
W00002=QUAN31-1
W00011	400011
W00014	400014
W00015	400015
W00040	400040
W00041	400041
W00042	400042
W00175	400175
W10000	410000
X74743	574743
X77600	577600
X77777	577777
Y00000=EXPS1+1
Y06703	606703
Y50001	650001
Z00000	700000
Z00100	700100
Z43600	743600
Z60000	760000
Z70000	770000
Z70001=BSS-1
Z77776=K2
	.EJECT
/AUTO-INDEX REGISTERS USED
AUTO=10
AUTO1=11
AUTO2=12
AUTO3=13
AUTO4=14
AUTO5=15
 
/ASSIGNMENTS
INTOUT=-13
DATIN=-11
DATOUT=-12
DUMPS=-13
DMPS=-15
IN=0
RNUMA0=NCB1
RNUMA1=NCB2
RNUMA2=NCB
A=400000
CC=200000
N=100000
AN=500000
AS=600000
S=CC
M=N
CX=A
Z=10000
Y=14000
TEMP1=SP00
TEMP2=SP01
TEMP=SP02
TEMPFN=SP03
	.EJECT
/DMP
/CODE TO DUMP COMPILER DATA ONTO DATSLOT DMPS=-13 IN DUMP MODE.
/ACTIVATED BY ^T (BUT ONLY WHEN DUMP OPTION REQUESTED).
 
DMP	.INIT	DMPS,1,DMP
	LAC	AOPTW	/ADDR OF OPTION WD
	DAC*	S00016	/HOLD IN AUTO 16
	TAD	C4	/ADDR OF STAT TABLE SPACE
	DAC*	S00017	/HOLD IN AUTO 17
	TAD	C1
	DAC	DMPCA	/SET IN .WRITE
	DAC	DMP93
	LAC*	16	/)
	DAC	DMPFN	/)SET UP FILENAME FOR
	LAC*	16	/)DUMP FILE
	DAC	DMPFN+1	/)
	ISZ	DMPFN+2	/INCREMENT EXTENSION
	.ENTER	DMPS,DMPFN
	LAW	-2
	TAD	AINBA
	DAC	DMP92
	LAW	-17
	DAC	DMP91	/CT FOR #WRITES
	DAC	DMP90
	ISZ	DMP90	/CT FOR #SKS
DMP02	LAC*	DMP92	/BASE
	CMA		/-B-1
	ISZ	DMP92
	TAD*	DMP92	/PTR-B-1(-#WDS ON SK)
	DAC*	17
	LAC*	DMP92	/PTR
	DAC*	17
	ISZ	DMP92
	ISZ	DMP90	/END OF STAT TABLE?
	JMP	DMP02	/NO, LOOP
	LAW	-34
	DAC	DMPL
/	.WRITE
DMP04	CAL+4000	DMPS&777
	11
DMPCA	0
DMPL	0
	LAC*	DMP93
	DAC	DMPL	/SET LENGTH OF SK IN .WRITE
	ISZ	DMP93
	LAC*	DMP93
	DAC	DMPCA	/SET UP ADDR OF SK
	ISZ	DMP93
	ISZ	DMP91	/LAST SK?
	JMP	DMP04	/NO, SO WRITE OUT SK
	.CLOSE	DMPS
	LAC*	S00116	/LOAD PC AND LINK
	DAC	DMP90
	RAL		/SET LINK FOR RETURN
	LAC*	S00117	/SET AC FOR RETURN
	JMP*	DMP90
 
DMPFN	0
	0
	.SIXBT	!D10!
 
DMP90	XX
DMP91	XX
DMP92	XX
DMP93	XX
	.EJECT
/GENERAL ROUTINE TO DRIVE SYSTEM BOOTSTRAP
/FOR CORE OVERLAY OR TO WRITE TO SYSTEM DEVICE
/CALLING SEQUENCE JMS	OLAY
/		BLOCK NO +400,000 IF WRITE
/		CORE ADDR.-1
/		2'S COMP NEG  W.C.
/		PROGRAM START ADDRESS ON COMPLETION
/ROUTINE PUTS THIS ADDRESS INTO .SCOM+5
	.IFUND	DOS
OLAY	XX		/ENTRY
	LAW	-1	/SET AUTO INDEX 10 WITH
	TAD	OLAY	/ADDRESS OF FIRST TRAILING
	AND	S77777
	DAC*	C8	/PARAMETER -1
	LAC*	S00100	/SET ADDR OF  BOOTSTRAP
	DAC*	C9	/-1 INTO AUTO INDEX 11
	TAD	C21
	DAC	SP01	/PUT IN JMP ADDRESS FOR
	TAD	C2	/JMPS TO BOOTSTRAP
	DAC	SP02
	LAC*	AUTO	/GET RELATIVE BLOCK NO
	TAD*	BLKADD	/MAKE ABSOLUTE
	DAC	SP00	/STORE
	AND	S07777	/AND OF SIGN BIT
	DAC*	AUTO1	/PUT INTO BTSTRAP
	LAC*	AUTO	/TRANSFER CORE ADDR-1
	DAC*	AUTO1
	LAC*	AUTO	/TRANSFER WORD CT
	DAC*	AUTO1
	LAC*	AUTO1	/MOVE AUTO INDEX 11
	LAC*	AUTO1	/TO NEXT REQD LOCN IN BOOTSTRAP-1
	LAC	S21000	/UNIT  NO INTO BOOTSTRAP
	DAC*	AUTO1
	LAC*	AUTO	/PUT STARTING ADDR
	DAC*	NOWT	/INTO LOCATION 0
	LAC	JMP.T1	/START VIA MONITOR
	DAC*	S00105
	LAC	SP00
	SMA		/WRITE?
	JMP*	SP01	/EXIT TO DTBEG
	LAC*	OLAY	/CHECK PARAMS WHEN WRITING TO SYSTAPE
	SAD	TP1
	SKP
	XX
	ISZ	OLAY
	LAC*	OLAY
	SAD	TP2
	SKP	
	XX
	ISZ	OLAY
	LAC*	OLAY
	SAD	TP3
	SKP
	XX
	ISZ	OLAY
	LAC*	OLAY
	SAD	TP4
	JMP*	SP02	/EXIT TO DTOUT
	XX
	.IFDEF	%B0
TP1	A+%B0
TP2	%C0-1
TP3	-%L0
TP4	P1C4+3
	.ENDC
	.IFUND	%B0
TP1	0
TP2	0
TP3	0
TP4	0
	.ENDC
S21000	21000
NOWT	0	/LOCATION 0
	.IFDEF	PDP15
JMP.T1	253
	.ENDC
	.ENDC
	.EJECT
	.IFDEF	%S2
	.IFDEF	%S4
DEF=1
	.ENDC
	.ENDC
	.IFUND	DEF
/DUMP ROUTINE TO DUMP COMPILER DATA ONTO BULK STORAGE IN DUMP MODE
/	USES CONTROL DATA STORED AT ADDR GIVEN BY SCOM+2
DUMP	XX
	.INIT	DUMPS,1,DUMP
	LAC	AOPTW	/GET ADDR OF OPTION WORD
	DAC	DUMPOW
	DAC*	C8
	TAD C5
	DAC	SP02
	DAC	SP04
	DAC	DUMPCA
	LAC*	10
	DAC	DUMPFN	/SET UP FILNAM FOR DUMP FILE
	LAC*	10
	DAC	DUMPFN+1
	.ENTER	DUMPS,DUMPFN
/	.WRITE DUMPS,4,AOPTW,4	/WRITE OPTION WORD & FILNAM
	CAL+4000	DUMPS&777
	11
DUMPOW	0
	-4
	LAC	K14
	DAC	SP01	/CT FOR # WRITES
	DAC	SP00
	ISZ	SP00	/COUNT FOR # SK
DUMP1	LAC	SP02	/
	DAC	SP03	/HOLD ADDR OF BASE WORD
	LAC*	SP02	/BASE
	CMA		/-B-1
	ISZ	SP02
	TAD*	SP02	/PTR-B-1(-#WDS ON SK)
	DAC*	SP03	/HOLD IN BASE WORD
	ISZ	SP02
	ISZ	SP00	/END OF STAT TABLE?
	JMP	DUMP1	/NO,REPEAT
	LAC	K26	/YES,DUMP STAT TABLE
	DAC	DUMPL
/	.WRITE
DUMP2	CAL+4000	DUMPS&777
	11
DUMPCA	0
DUMPL	0
	LAC*	SP04
	DAC	DUMPL	/SET UP LENGTH OF SK
	ISZ	SP04
	LAC*	SP04
	DAC	DUMPCA	/SET UP ADDR OF SK
	ISZ	SP04
	ISZ	SP01	/END OF SK
	JMP	DUMP2	/NO DUMP STACK
	.CLOSE	DUMPS
	JMP*	DUMP
DUMPFN	0
	0
	.SIXBT !AL1!	/!AL2!FOR PASS 2
	.EJECT
	.ENDC
	.IFUND	%B0
/REST
/ROUTINE TO RESTORE THE STACKS PREVIOUSLY CREATED DURING A RUN WITH
/THE PRE-SET PROC OPTION SET.
/FILE NAMED "PRESET AL1" IS READ IN DUMP MODE FROM DATSLOT DATIN=-11.
 
REST	XX
	.INIT	DATIN,0,REST
	LAC	K14
	DAC	SP00	/COUNT OF STACKS TO BE READ
	LAC	AOPTW
	TAD	C4
	DAC	SP01	/ADDR OF WORD HOLDING ADDR OF STAT TABLE
	DAC*	SP01
	ISZ*	SP01
	DAC	SP04	/HOLD ADDR OF WORD HOLDING ADDR STAT TABLE
	DAC	STATIN
	ISZ	STATIN	/ADDR OF STAT TABLE AFTER RESTORE
/	.SEEK	DATIN,RESTFN
	CAL	DATIN&777
	3
	RESTFN
	LAC	AGLOBL
	DAC	SP03	/HOLD ADDR OF TOP OF CORE
/	.READ	DATIN,4,LCT1,4
	CAL+4000	DATIN&777
	10
	LCT2
	-4
	LAC	K26
	DAC	RESTL	/LENGTH OF STAT TABLE
	LAC*	SP01
	DAC	RESTCA	/ADDR OF STAT TABLE
REST1	.WAIT	DATIN
/	.READ	DATIN,4,RESTCA,RESTL	/READ STAT TABLE,THEN STACKS
	CAL+4000	DATIN&777
	10
RESTCA	0
RESTL	0
	ISZ	SP01	/ADDR OF SK BASE
	LAC*	SP01	/)LENGTH OF STACK
	DAC	RESTL	/)TO READ
	TAD	SP03	/ADD ADDR OF TOP END OF FREE CORE
	DAC	RESTCA
	ISZ	RESTCA	/ADDR OF READ STACK INTO
	LAC	SP03	/)TOP OF FREE CORE
	DAC*	SP01	/)TO SK BASE
	ISZ	SP01
	LAC	RESTCA	/)END OF STACK
	DAC*	SP01	/)TO SK PTR
	TAD	K1
	DAC	SP03	/RESET TOP OF FREE CORE
	ISZ	SP00
	JMP	REST1
REST2	.CLOSE	DATIN
	JMS	COPY	/)MOVE STAT TABLE NOW CREATED
STATIN	XX		/)INTO PROGRAM AREA
	INBASE
	32
	LAC	AINBA	/)UPDATE ADDR OF STAT TABLE
	DAC*	SP04	/)AT BOTTOM OF CORE
	JMP*	REST
 
RESTFN	.SIXBT	!PRESETAL1!
	.ENDC
PCH=.			/PATCH AREA FOR DEBUGGING
	.IFUND	DOS
	.BLOCK	%S1+%V1-JMP.T1-2
	.ENDC
	.IFDEF	DOS
	.BLOCK	%S1+%V1-DMP93-3
	.ENDC
	.SIZE
	.END	START
