	.TITLE	IDENT
/
/   5 AUG 74 (JAS) IMPLEMENT VARIABLE RETURN
/   1 AUG 74 (PDH, JAS) CHANGE 'SV' ERRORS TO 'DM' ERRORS
/  31 JUL 74 (PDH) ISSUE '.IODEV TRDV' FOR '$TRACEON'
/  14 JUN 74 (JAF) FIX UP DATA IN SPECS AGAIN AFTER BLOCK DATA CHANGES
/  12 JUN 74 (JAF, JAS) BLOCK DATA IMPLEMENTATION; REMOVE '.EBREL'
/  17 APR 74 (JAF, JAS) NO EQUIVALENCE OF FORMAL PARAMETERS
/  27 MAR 74 (JAS) REMOVE EXTRA WORD FROM CHARACTER DOPE VECTOR
/   6 MAR 74 (PDH) ADD LOGICAL, COMPLEX, CHARACTER FUNCTION
/	     (JAF) FIX OUTPUT OF NEGATIVE CONSTANTS AND VARIABLES
/   5 MAR 74 (JAS) FIX UP NEGATIVE DIMENSIONS [ (-2/3) ]
/  27 FEB 74 (JAF, JAS) UPDATE 'CPOINT' IN CLEAN-UP
/  22 FEB 74 (JAS,JAF) CORE-TO-CORE I/O FIX
/  20 FEB 74 (JAF, JAS) FIX UP CHARACTERS IN DATA STATEMENTS
/  14 FEB 74 (JAF) CHANGE 'TEMPAC' TO 'TEMPA2' FOR STATEMENT FUNCTION REASONS
/   7 FEB 74 (PDH) BEGIN IMPLEMENTATION OF BLOCK DATA
/  17 SEP 73 (PDH) CHANGE DEVICE NUMBER REFERENCES TO SYMBOLIC
/  11 SEP 73 (PDH) .WAIT BEFORE .EXIT; .EBREL
/   6 SEP 73 (JAS) FIX DATA FOR CHARACTER VARIABLES
/   1 AUG 73 (JAS) MAKE SYMBOL TABLE COME OUT IN CORRECT SEQUENCE
/  25 JUL 73 (JAS) FIX COUNT DOPE VECTORS FOR SIMPLE CHARACTER VARIABLES
/   4 JUL 73 (JAS) FIX DATA IN SPECIFICATION
/   3 JUL 73 (PDH) $TRACEON & $TRACEOFF
/  17 APR 73 (JAS) FIX UP ' IF (LOG) IF (ARITH) . . .'
/
/
/ THE FOLLOWING ARE THE GLOBL VARIABLES:
/
/ IN WATRAN -
/   ADDRESSES:
	.GLOBL	BOX,CHI,CHIEND,LIST,LIST1,NXTSPC,RETRN
	.GLOBL	BASE2,BASE3,TESOUT,SETPT2,JOINCK,.START
/   SUBROUTINES:
	.GLOBL	INSERT,ERROR,ERRORS,WARN,HIERAR,STLINE,PROCES,HOOK
/   SWITCHES:
	.GLOBL	EQSWT,EQSWL,MODESW,STATSW,EQUVSW,LST
/
/ IN IDENT -
/   ADDRESSES:
	.GLOBL BASE1,DTSTAT,DTSTOR,IFSTAT,ERSW,OVERS
	.GLOBL SYMPRT,EXITSW,KIND,FORMBX
	.GLOBL ARITH,ASSGN,CALLS,CHARAC,.CONT,COMMN,COMPLX
	.GLOBL DATA,DBCPLX,DBLINT,DBLREL,DIMEN,DO,END,EQUIV
	.GLOBL EXTRNL,FORMAT,FUNCT,.GOTO,IFBRAC
	.GLOBL INTGR,LOGIC,.PAUSE,PRINT.,PUNCH.,READBR,READ.
	.GLOBL REAL,RETR,STOP,SUBR,TRACON,TRACOFF,WRITEB
	.GLOBL	LOGICF,INTF,DINTF,REALF,DREALF,CMPLXF,CHARF
	.GLOBL ENDFIL,BLDATA
	.GLOBL	STSIZE,MODPTR,BITPTR,CPOINT
/   SUBROUTINES:
	.GLOBL	SHOVE,PULL,CLENUP,EQUCLN,WDSIZE,ARYSIZ,ENDDO,REPACK
/   SWITCHES:
	.GLOBL	COMSW,TYPESW,CMNSWH,ENDSW,IFSW,IFSTOR,DEVICE,DIMCNT
	.GLOBL	HEADER,CHRCNT
/
/ IN SEARCH -
/   ADDRESSES:
	.GLOBL FLTFLG,CHINXT,VANTED,VANT1,VANT2,INDEX,IND
/   SUBROUTINES:
	.GLOBL SEARCH,GETCHI,RECORD,REGAIN,REPLCE
/
/ IN CALCP -
/   ADDRESSES:
	.GLOBL SAVCMN,TBPOSN,TBADDR,OPT2,DTNEXT,OTNEXT
	.GLOBL DTABLE,PTABLE,OTABLE,OPLACE,INTAB
/   SUBROUTINES:
	.GLOBL CALCP,GETOTB,GETADR,DLOTAB
/
/ IN GEARS -
/   ADDRESSES:
	.GLOBL	NUMS,CHARCT
/   SUBROUTINES:
	.GLOBL G.MOVE,G.SCAN,G.INIT,G.STPC,G.PACK,G.CVRT
/
/ IN SYMBOL -
/   SUBROUTINES:
	.GLOBL SYMBOL
/
/ IN EXPRES -
/   ADDRESSES:
	.GLOBL SPOT2,AD2,CLEW2,ACCSW,TEMPA2,HIDCON
/
/   SUBROUTINES:
	.GLOBL EXPRES
	.GLOBL	PLXPIK
/ IN ASCOM -
/   ADDRESSES:
	.GLOBL	VARAA,VARAC
/   SUBROUTINES:
	.GLOBL	ASCOM
/
/ IN BIN1 -
/   ADDRESSES:
	.GLOBL	OPCODE,DRESS,CLUES,LOCCNT,ITEM
/   SUBROUTINES:
	.GLOBL PUNCH
	.GLOBL	CLOSER,NAMEIT,ITEMIN,ITEM4,ITEM5,INSRT
/
/ IN APPEND -
/   ADDRESSES:
	.GLOBL	START,CNAME,COMPNT,NXTADR
/   SUBROUTINES:
	.GLOBL	APPEND,CHKNAM
/
/
/
/ MACRO FOR EXIT
	.DEFIN EXIT
	JMP*	RETRN
	.ENDM
	.EJECT
/ THIS SECTION PROCESSES ALL ARITHMETIC STATEMENTS
ARITH	LAW	H5!.EXC
	JMS*	HIERAR
	DZM*	EQSWL
	LAC*	CHI
	TAD	(1
	DAC*	INDEX
	CLC
	DAC*	IND
	JMS*	GETCHI
	JMS*	ASCOM
	EXIT
	.EJECT
/
ASSGN	LAW	H5!.EXC
	JMS*	HIERAR
	EXIT
	.EJECT
/
CALLS	LAW	H5!.EXC
	JMS*	HIERAR
	JMS*	GETCHI
	LAW	EXPILL!CALLSW
	JMS*	EXPRES
	WRNSXA
	WRNSXA
	.DSA	OUTCAL
	WRNSXA
/
WRNSXA	JMS*	WARN		/WARNING: CHARACTERS ENCOUNTERED AFTER ')'
	.SIXBT	'SXA'
OUTCAL	EXIT
	.EJECT
/
.CONT	LAW	H5!.EXC
	JMS*	HIERAR
	EXIT
	.EJECT
/
/ COMMON STATEMENTS
/
COMMN	LAW	H3!NON.EX!BDLEGL
	JMS*	HIERAR
	ISZ	COMSW	/ INDICATES WE ARE IN COMMON STATEMENT
	ISZ	CMNSWH	/ INDICATES A COMMON STAT HAS OCCURRED
	JMS*	GETCHI	/SET UP NEXT CHARACTER
	SAD	(SLASH
	SKP
	JMP	BNKCMN	/NO. IT IS BLANK COMMON
CMNSL1	JMS*	GETCHI	/YES. LOOKS LIKE NAMED COMMON
	LAC*	CHINXT	/ LOAD NEXT CHAR
	SAD	(SLASH	/ IS IT SLASH ?
	JMP	BNKCMN	/YES. CHANGED MINDS, // = BLANK COMMON
NAMCMN	LAC	(NAME	/ WANT NAME NOW
	JMS*	SEARCH	/ GET NAME
	LAC	(COMNAM	/ INDICATES NAMED COMMON FOR CALCP
	JMS*	CALCP
	LAC*	CHINXT
	SAD	(SLASH	/ LAST DELIMITER SHOULD BE " / "
	JMP	.+3	/ OKAY IT IS
ERRCM3	JMS*	ERRORS
	.SIXBT	'CM3'
	JMS*	GETCHI	/ GET NEXT CHARACTER
	JMP	SAVPTR
/
BNKCMN	LAC	BNKNAM
	DAC*	VANTED
	DZM*	VANT1
	LAC	(COMNAM
	JMS*	CALCP
SAVPTR	LAC*	TBPOSN	/ GET LAST POINTER TO COMMON NAME
	DAC	SAVCMN	/ SAVE ADDRESS OF COMMON NAME
	LAC*	CHINXT	/ RETREIVE CHARACTER
	SAD	(ENDST	/ ARE THERE ANY VARIABLES
	EXIT		/ NO
	JMP	SPECST	/ YES. ENTER GENERAL SECTION NOW
/
/ THE FOLLOWING IS THE NAME UNDER WHICH UN-NAMED COMMONS
/  STORED INTERNALLY. IT IS ' .XX '
BNKNAM	POINT*100+XXX*100+XXX
/
	.EJECT
/  BLOCK DATA COMES HERE
/
BLDATA	LAC	(BLOCKD
	DAC	KIND		/ MARK AS BLOCK DATA
	LAC	BL1
	DAC*	VANTED		/ DUMMY UP A PROGRAM NAME
	LAC	BL2		/ FOR LOADER IN CASE OF
	DAC*	VANT1		/ MULTIPLE PROGRAMS BEING COMPILED.
	DZM*	CNAME		/ BLANK OUT COMMON NAME FOR DATA PUNCHING
	LAW	H1!NON.EX!BDLEGL
	JMS*	HIERAR
	DZM	HEADER		/ NO START CODE SPACE REQUIRED FOR BLOCK DATA
	EXIT
/
BL1	BB*100+POINT*100+DD	/ DUMMY FILE NAME FOR BLOCK DATA
BL2	AA*100+TT*100+AA
/
ERRBD0	JMS*	ERRORS		/ ERROR - ATTEMPT TO INITIALIZE NON-COMMON
	.SIXBT	'BD0'		/ VARIABLE IN BLOCK DATA
	.EJECT
/
/
/
/ SPACE FOR DATA VARIABLES IS ABOUT TO BE ASSIGNED SO
/ THIS SUBROUTINE TESTS IF ANY CODE HAS BEEN COMPILED YET OR
/ IF THE LAST STATEMENT WAS A DATA STATEMENT. IF NOT, A GO TO
/ IS COMPILED AROUND THE DATA INFORMATION
/ USED ALSO BY FORMAT STATEMENTS!!!!!!!
TESTGO	XX
	LAC	NA	/ GET LOCATION CNTR AT START OF DATA STAT
	TAD	(-1
	SAD*	START	/ IF NA-1=START, THEN NO CODE COMPILED YET
	JMP*	TESTGO	/ NO CODE EXIT
/
/ THERE HAS BEEN CODE COMPILED, CHECK IS A 'GO TO' IS NEEDED
	LAC	DTSTOR	/ CONTAINS ADDRESS IN OTABLE FOR UPDATING
	SZA		/ DOES A GOTO EXIST THAT WE CAN USE?
	JMP*	TESTGO	/ YES. NO EXECUTABLE STATEMENTS SINCE 
/			/ LAST INTERNAL 'GOTO'
/ THERE IS NO INTERNAL 'GO TO'  THAT WE CAN USE, CHECK IF ONE IS NEEDED
TRYUNC	LAC*	STATSW
	SZA		/ WAS LAST STATEMENT A UNCONDITIONAL TRANSFER
	JMP*	TESTGO	/ YES. DO NOT NEED A INTERNAL GOTO!
/
/COMPILE AN INTERNAL 'GO TO' AND SAVE ITS OTABLE ADDRESS
COMPGO	LAC	DTSTAT	/ GET INTERNAL STATEMENT NUMBER
	ISZ	DTSTAT	/ INCREMENT FOR NEXT TIME
	DAC*	VANTED
	LAC	(STNUM
	JMS*	CALCP	/ ENTER IN SYMBOL TABLE
	LAC*	OPLACE
	DAC	DTSTOR	/ SAVE OTABLE ADDRESS FOR UPDATING
	LAC	(GOTO*M
	XOR*	TBADDR	/ ADD IN RELATIVE OTABLE ADDRESS
	JMS*	ITEM4	/ PUNCH OUT 'GOTO'
	ISZ	NA	/ STEP PAST 'GOTO'
	JMP*	TESTGO
/
/
/ DATA STATEMENTS START HERE. SCAN EACH VARIABLE LIST UNTIL THE '/' IS
/ FOUND AND REPLACE IT WITH A ';' SO EXPRES WON'T GET UNHAPPY. THEN
/ PROCESS THE VARIABLE LIST BUILDING UP A TABLE (ON TOP OF THE CHI TABLE)
/ CONTAINING THE OTABLE ADDRESSES IN THE FOLLOWING FORM:
/       0NNNNN  -  SIMPLE VARIABLES
/       2NNNNN  -  ARRAY ELEMENT
/       4NNNNN  -  ARRAY
/ ONLY SIMPLE VARIABLES NEED SPACE ASSIGNED TO THEM AND THIS MEANS A
/ 'GO TO' MIGHT HAVE TO BE COMPILED. THE SPACE REQUIRED IS TOTALED
/ AND A CODE 06 IS ISSUED FOR IT.
DATA	LAW	H5!ILGIF!NON.EX!BDLEGL
	JMS*	HIERAR
	LAC*	LOCCNT
	DAC	NA	/ SAVE VALUE OF LOC CNTR AT START OF DATA STATEMENT
AGDA	JMS*	GETCHI	/ GET NEXT CHARACTER IN STRING
	JMS*	RECORD	/ RECORD POSITION IN CHI, LEAVES CHAR IN AC
	SKP
AGDA0	JMS*	GETCHI
	SAD	(ENDST	/ IS IT ';'
	JMP	ERRDA5
	SAD	(SLASH
	SKP!CLL
	JMP	AGDA0	/ NOT '/', TRY NEXT CHARACTER
	JMS*	REPLCE	/ IT IS '/' , REPLACE WITH ';'
/
/ RESET TO THE START OF THIS VARIABLE LIST AND PROCESS EACH VARIABLE
	LAC*	CHI
	DAC*	(AUTO14	/ SET AUTO-INDEX FOR LIST
	JMS*	REGAIN	/ REGAIN POSITION IN CHI, CHAR LEFT IN AC.
	ISZ	EQUVSW	/ LIE TO EXPRES, MARK AS BEING EQUIVALENCE
AGDA1	LAW	EXPILL!DFNSW!CONILL
	JMS*	EXPRES
	.DSA	CMMAS
	.DSA	ERRDA5
	.DSA	SEMCLN
	.DSA	ERRDA5
/
SEMCLN	LAW	-1
	DAC	ENDNST	/ MARK '/' AS OCCURRING
/
CMMAS	JMS	VARSUB
	LAC	KIND		/ CHECK IF IN
	SAD	(BLOCKD		/ BLOCK DATA PROGRAM
	JMP	REJOIN
	LAC*	BITPTR	/ GET CONTROL BITS
RETEST	AND	(DIMENS!FUNBIT!FORMAL!COMSET!EQUSET
	SNA
	JMP	SIMPL	/ SIMPLE VARIABLE
	SAD	(EQUSET	/ IS IT SIMPLE VARIABLE IN EQUIVALENCE
	JMP	TOSS	/ YES.
	AND	(DIMENS!FUNBIT!FORMAL!COMSET
	SAD	(DIMENS
	JMP	DIMION	/ DIMENSIONED VARIABLE
	AND	(FUNBIT!FORMAL!COMSET
	SAD	(COMSET
	JMP	ERRDA9
ERRDA3	JMS*	ERRORS
	.SIXBT	'DA3'
ERRDA9	JMS*	ERRORS
	.SIXBT	'DA9'
/
REJOIN	JMS	INBLKD
	LAC*	BITPTR
	XOR	(COMSET
	JMP	RETEST
/
INBLKD	XX
	LAC*	BITPTR
	AND	(COMSET		/ CHECK IF BLOCK DATA ITEM IS IN COMMON
	SNA
	JMP	ERRBD0		/ NO.  ERROR!
	LAC*	CNAME		/ DO WE HAVE A COMMON NAME?
	SNA
	JMP	PUTCNM		/ NOT ON 1ST TIME
	LAC*	OPT2
	JMS*	CHKNAM		/ DO WE HAVE ANOTHER COMMON NAME?
	SZA
	JMP*	INBLKD		/  NO.  THIS NAME AGAIN.
ERRBD1	JMS*	ERRORS		/ ERROR - MAY ONLY INITIALIZE ONE BLOCK
	.SIXBT	'BD1'		/ COMMON AREA PER BLOCK DATA SUBPROGRAM
/
PUTCNM	LAC*	OPT2
	JMS*	CHKNAM
	LAC*	COMPNT
	DAC*	NXTADR
	JMP*	INBLKD
/
/ CHECK IF VARIABLE ALREADY HAS DATA. ONLY SINGLE VARIABLES AND ARRAYS
/ CAN BE CHECKED, ELEMENTS OF ARRAYS CAN NOT
CHKDT	XX
	LAC*	BITPTR
	AND	(DATSET
	SNA
	JMP*	CHKDT
WRNDA8	JMS*	WARN
	.SIXBT	'DA8'
	JMP*	CHKDT
/
/ VARIABLES HAS DIMENSIONS. THUS IT ALREADY HAS ITS STORAGE ASSIGNED
DIMION	LAC*	CLEW2	/ GET CLUE BITS FROM EXPRES
	AND	(DIMMEN
	SNA		/ IS VARIABLE ARRAY NAME OR ELEMENT
	JMP	ELEMNT	/ ELEMENT
	JMS	CHKDT
	LAC	(400000	/ ARRAY NAME, MARK AS SUCH
	TAD	MODPTR
	JMP	TOSS1
ELEMNT	LAC	(200000	/ MARK AS ELEMENT
	TAD	MODPTR
	DAC*	AUTO14
	LAC*	SPOT2	/ GET OFFSET OF ELEMENT WRT THE BASE ADDRESS
	JMP	TOSS1
/
/ SIMPLE VARIABLES DO NOT HAVE AN ADDRESS YET UNLESS IN COMMON!!!
SIMPL	LAC*	BITPTR
	AND	(COMSET
	SZA
	JMP	TOSS
	LAC	BITPTR	/ SAVE VARIABLE BECAUSE TESTGO WILL BOMB IT
	DAC	COUNT	/ IF IT PUNCHES OUT AN INTERNAL STATEMENT NUMBER
	JMS	TESTGO	/ NO. COMPILE A 'GO TO' IF REQUIRED
	LAC	COUNT	/ RESTORE VARIABLE NOW
	DAC	BITPTR
	JMS	CHKDT	/ CHECK IF VARIABLE ALREADY HAS DATA
/ NOW INSERT VARIABLE'S ADDRESS IN OTABLE
	LAC*	LOCCNT
	DAC*	OPT1	/ PUT ADDRESS IN OTABLE
	LAC*	MODPTR
	JMS	WDSIZE
	TAD*	LOCCNT
	DAC*	LOCCNT	/ RESET TO ADDRESS FOR NEXT VARIABLE
/
/  IF VARIABLE IS CHARACTER, INCREMENT 'CHRCNT' FOR DOPE VECTORS
/
	LAC*	MODPTR
	AND	(17
	SAD	(CHARM		/IS IT CHARACTER VARIABLE?
	SKP
	JMP	TOSS		/NO
	ISZ	CHRCNT
	ISZ	CHRCNT
/
/ TOSS THE VARIABLE'S OTABLE ADDRESS IN THE STACK. IF THIS WAS THE LAST
/ VARIABLE, GO PROCESS THE CONSTANTS.
TOSS	LAC	MODPTR
TOSS1	DAC*	AUTO14
	LAC	(DATSET
	JMS	SHOVE	/ MARK AS HAVING DATA
	ISZ	ENDNST	/ IS THIS LAST VARIABLE
	JMP	AGDA1	/ NO. GO GET NEXT VARIABLE
	LAW	-1	/ YES.
	DAC*	AUTO14	/ MARK END OF VARIABLES IN STACK
	.EJECT
/
/ END OF VARIABLE LIST IS REACHED, GET CONSTANTS
	DZM	COUNT	/ RSET REPLICATION COUNT
	LAC*	CHI
	DAC*	(AUTO14	/ SET UP TO START OF LIST
	DZM	EQUVSW	/ REMOVE EQUIVALENCE INDICATOR
	JMS	PICCON
/ END OF CONSTANT LIST
	LAC	COUNT	/ IF COUNT = 0
	TAD*	AUTO14	/ AND TABLE END = -1
	SAD	(-1	/ THEN VARIABLES ARE FINISHED
	JMP	VCEVEN
ERRDA7	JMS*	ERRORS	/ MORE CONSTANTS THAN VARIABLES
	.SIXBT	'DA7'
/
/ THE VARIABLE AND CONSTANT LISTS CAME OUT EVEN. CHECK IF THE IS
/ ANOTHER VARIABLE LIST
VCEVEN	JMS*	GETCHI
	SAD	(COMMA
	JMP	AGDA	/ FORM /,  GO GET NEXT LIXT
	SAD	(ENDST
	JMP	DTENTR	/ END OF STATEMENT
ERRDAA	JMS*	ERRORS	/ MISSING ',' OR ILLEGAL CONSTRUCTION
	.SIXBT	'DAA'
/
/ THIS CODE DECIDES WHAT UPDATING SHOULD BE DONE AFTER NON-EXECUTABLE 
/ INFORMATION HAS BEEN PUNCHED OUT. IT IS USED AT THE END OF DATA
/ STATEMENTS AND FORMAT STATEMENTS.
/ DATA COMES HERE
DTENTR	LAC	NA
	SAD*	LOCCNT	/ HAS ANY SPACE BEEN RESERVED?
	EXIT		/ NO.
	CMA		/ YES. ISSUE A CODE 06
	TAD	(1
	TAD*	LOCCNT
	DAC*	ITEM
	LAC	(06
	JMS*	INSRT	/ PUNCH OUT THE CODE
/ FORMAT COMES HERE. NON-EXECUTABLE SPACE HAS BEEN RESERVED
FMENTR	LAC	DTSTOR
	SNA		/ WAS AN INTERNAL 'GOTO' COMPILED
	JMP	NOGOTO	/ NO.
	LAC*	LOCCNT	/ YES. MUST UPDATE OR SET ADDRESS
	DAC*	DTSTOR
	EXIT
/ NO 'GOTO' WAS COMPILED. EITHER STATEMENT WAS PRECEDED BY AN
/ UNCONDITIONAL 'GOTO' OR NO CODE HAS BEEN COMPILED.
NOGOTO	LAC*	STATSW
	SZA		/ WAS PRECEDING STATEMENT UNCOND TRANSFER
	EXIT		/ YES.
	LAW	-1	/ NO. THUS NO CODE WAS COMPILED.
	TAD*	LOCCNT
	DAC*	START	/ RESET START OF CODE ADDRESS
	EXIT
	.EJECT
/
/ THE VARIABLE LIST IS EXHAUSTED AND THE TABLE HAS BEEN BUILT UP
/ NOW GET EACH CONSTANT AND PUNCH OUT THE DATA CODES AND INFORMATION
GETCON	JMS*	GETCHI
	SKP
PICCON	XX
	LAW	-1
	JMS	FNDCON
	LAC*	CHINXT
	SAD	(STAR
	SKP
	JMP	NOREP	/ NO CONSTANT REPLICATION FACTOR
	LAC*	FLTFLG
	SAD	(CONBIT!SINTGM	/ IS IT SINGLE INTEGER
	JMP	.+3	/ YES.
ERRDA0	JMS*	ERRORS	/ NO. ERROR, MODES DISAGREE
	.SIXBT	'DA0'
	JMS*	GETCHI
	LAW	-1
	TAD*	VANTED
	CMA!SPA
	JMP	ERRDA0	/ NEGATIVE REPLICATION FACTOR
	JMS	FNDCON
/
/ DO WE NEED A VARIABLE
NOREP	LAC	COUNT
	SZA		/ IS VARIABLE FULL
	JMP	CHMD	/ NO.
/
/ YES. GET THE NEXT VARIABLE
ANEWV	LAC*	AUTO14	/ GET NEXT VARIABLE
	SAD	(-1	/ IS IT END OF TABLE
	JMP	ERRDA7	/ YES.
	DAC	MODPTR		/ SET UP DTABLE & OTABLE POINTERS
	TAD	(3
	DAC	BITPTR
	TAD	(1
	DAC	CPOINT		/ IN CASE CHARACTER VARIABLE
	LAC*	MODPTR
	JMS*	GETADR
	DAC	OPT1
	TAD	(-1
	DAC	OPT2
	LAC	MODPTR		/ REGAIN INDICATOR BITS
	RTL
	LAC*	OPT1	/ GET ADDRESS OF VARIABLE
	AND	(077777		/ REMOVE COMMON INDICATOR BIT, IF SET
	SZL		/ LINK =1, IF VARIABLE IS AN ELEMENT
	TAD*	AUTO14	/ NEXT WORD IS OFFSET WRT THE BASE
	DAC	BOX1	/ CONTAINS ADDRESS OF VARIABLE
	LAC*	MODPTR
	JMS	WDSIZE
	DAC	WDS
	LAC	MODPTR	/ MODPTR STILL CONTAINS INDICATOR BITS
	SMA!CLC		/ IS VARIABLE AN ARRAY NAME.(AC_777777)
	JMP	REPV	/ NOT ARRAY, REPLICATION FACTOR = 1.
	JMS	ARYSIZ	/ GET ARRAY SIZE
	CLL
	IDIV
WDS	XX		/VARIABLE REPLICATION FACTOR=ARRAY SIZE/WORD SIZE
	LACQ
	CMA
	TAD	(1
REPV	DAC	COUNT	/ NEG VARAIBLE REPLICATION FACTOR
/
/ CHECK IF MODE OF VARIABLE AND CONSTANT MATCH
CHMD	LAC*	FLTFLG	/ GET MODE OF CONSTANT
	SAD	(CHARM!CONBIT
	JMP	HOLRTH
	SAD	(CONBIT!SINTGM
	JMP	SINCON	/ SINGLE INTEGER CONSTANT
	XOR*	MODPTR
	AND	(17
	SNA
	JMP	DATOUT
ERRDA6	JMS*	ERRORS
	.SIXBT	'DA6'
/
/ A SINGLE INTEGER CONSTANT MAY GO INTO A SINGLE OR DOUBLE
/ INTEGER VARIABLE.
SINCON	LAC*	MODPTR	/ GET VARIABLE MODE
	AND	(7
	SAD	(SINTGM
	JMP	DATOUT	/ ITS SINGLE INTEGER ALSO
	SAD	(DINTGM
	SKP
	JMP	ERRDA6	/ NEITHER SINGLE OR DOUBLE 
	LAC*	VANTED	/ VARIABLE IS DOUBLE INTEGER. MAKE CONSTANT DOUBLE
	DAC*	VANT1
	SPA!CLA		/ EXTEND SIGN BIT
	CMA
	DAC*	VANTED
	JMP	DATOUT
/
/
/
/ PICK UP CONSTANTS, CHECK FOR COMPLEX
FNDCON	XX
	DAC	NUMBER
	LAC*	CHINXT
	SAD	(OPEN
	JMP	CPLX	/ LOOKS LIKE COMPLEX
	LAC	(SIGNER!CONSTN
	JMS*	SEARCH	/ GET CONSTANT
	JMP*	FNDCON
CPLX	JMS*	GETCHI	/ TOSS AWAY '('
	LAC	(SIGNER!CONSTN
	JMS*	SEARCH
	LAC*	CHINXT
	SAD	(COMMA
	JMP	.+3
ERRDAB	JMS*	ERRORS
	.SIXBT	'DAB'
	JMS*	PLXPIK	/ GET REMAINDER OF CONSTANT
	JMS*	GETCHI	/ TOSS AWAY )
	JMP	NOREP
/
/
/
HOLRTH	LAC*	VANTED		/ GET -SIZE OF CONSTANT
	DAC	MOVCNT		/ ALWAYS MOVE THIS MANY WORDS
	TAD	WDS		/ ADD WORD SIZE OF VARIABLE
	TAD	(2	/(ITS 2 HIGH FROM FILLING 2 SPACES IN LAST WORD)
	SMA		/ IS CONSTANT TOO LARGE
	JMP	MOVCNT	/ NO.
WRNDAC	JMS*	WARN	/ YES. ISSUE TRUNCATION WARNING
	.SIXBT	'DAC'
/
MOVCNT	LAW	-10
	JMS*	G.MOVE	/ SHIFT THE CONSTANT IN VANTED FOR TRANSFER
	TAD	VANT2
	TAD	VANTED
/
	LAW	-1
	TAD	WDS
	SZA
	JMP	DATOUT
	LAC*	VANTED
	AND	(777760
	DAC*	VANTED	/ CLEAR RIGHT MOST BITS FOR LOGICAL AND INTEGER
/
/ PUNCH OUT THE CONSTANT FOR ONE VARIABLE OR ELEMENT
/
DATOUT	JMS	DATPCH	/ PUNCH OUT DATA FOR ONE VARIABLE OR ELEMENT
	LAC	BOX1
	TAD	INCRES
	DAC	BOX1	/ ADVANCE ARRAY POINTER ADDRESS
	ISZ	NUMBER	/ IS CONSTANT DONE
	JMP	STILLC
	ISZ	COUNT	/ COUNT THE VARIABLE
	NOP
	LAC*	CHINXT
	SAD	(COMMA
	JMP	GETCON
	SAD	(SLASH
	JMP*	PICCON
ERRDA4	JMS*	ERRORS
	.SIXBT	'DA4'
/
/
ERRDA5	JMS*	ERRORS
	.SIXBT	'DA5'
/
/ END OF CURRENT CONSTANT IS REACHED. TEST FOR END OF VARIABLE
STILLC	ISZ	COUNT
	JMP	DATOUT
	JMP	ANEWV
/
/
/
DATPCH	XX
	LAW	-1
	TAD	VANTED
	DAC*	(AUTO10		/SUBTRACT 1 FOR AUTO-INDEX
	LAC	WDS
	DAC	INCRES	/ SET UP FOR INCREMENTING ADDRESS
	CMA
	TAD	(1
	DAC	S
/
NEWDAT	LAC*	AUTO10
	DAC*	ITEM
	LAC	(17		/LOADER CODE FOR 1ST 'DATA' ELEMENT
	JMS*	INSRT
	CLA
	ISZ	S
	SKP
	JMP	DONE
/
	LAC*	AUTO10	/ GET NEXT WORD OF CONSTANT
	DAC*	ITEM
	LAC	(20		/LOADER CODE FOR 2ND 'DATA' ELEMENT
	JMS*	INSRT
	LAC	(100000
	ISZ	S
	SKP
	JMP	DONE
/
	LAC*	AUTO10
	DAC*	ITEM
	LAC	(21		/LOADER CODE FOR 3RD 'DATA' ELEMENT
	JMS*	INSRT
	LAC	(200000
	ISZ	S
	NOP
DONE	TAD	BOX1
	DAC*	ITEM
	LAC	(22		/LOADER CODE 'DATA INITIALIZATION
	JMS*	INSRT		/	CONSTANT DEFINITION'
/
	LAC	S
	SNA
	JMP*	DATPCH
	LAC	(3
	TAD	BOX1
	DAC	BOX1
	LAW	-3
	TAD	INCRES
	DAC	INCRES
	JMP	NEWDAT
/
/
	.EJECT
/
/
/
ERRDO0	JMS*	ERRORS
	.SIXBT	'DO0'
/
DO	LAW	H5!ILGIF!.EXC
	JMS*	HIERAR
	LAC*	CHI
	TAD	(2	/ STEP PAST THE 1ST TWO CHARS (DO)
	DAC*	INDEX
	CLC
	DAC*	IND
	JMS*	GETCHI	/ SET UP TO NEXT CHARACTER
	LAC	(INTGRS
	JMS*	SEARCH	/ PICK UP STATEMENT NUMBER
	LAC	(STNUM
	JMS*	CALCP	/ PUT IN SYMBOL TABLE
	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(000077\DO.S	/ EVERYTHING ELSE ILLEGAL
	SZA
	JMP	ERRDO0
	LAC*	BITPTR
	AND	(DO.S
	SNA
	ISZ*	DTNEXT	/ FIRST TIME IN DO STATEMENT, ALLOW FOR DO COUNT
	LAC	BITPTR
	TAD	(2
	DAC	TEMP
	ISZ*	TEMP	/ COUNT THIS 'DO' STATEMENT
/
	LAC	(DO.S
	JMS	SHOVE	/ MARK AS OCCURRING IN 'DO' STATEMENT
	JMS	PRODOS	/ PROCESS DO PARAMETERS
	EXIT
/
/ IMPLIED DOS ARE ALSO PROCESSED BY THIS SECTION
PRODOS	XX
	JMS*	RECORD	/ RECORD CURRENT POSITION IN CHI TABLE
	DZM	CNT
AGDO1	LAC	CNT
	SZA!CLL
	STL
	LAC*	CHINXT	/ GET NEXT CHARACTER
AGDO2	SAD	(OPEN	/ IS IT '('
	JMP	ITSOPN	/ YES.
	SAD	(CLOSE	/ IS IT ')'
	JMP	ITSCLS	/ YES.
	SZL		/ ARE WE INSIDE (.......)
	JMP	GET2	/ YES. IGNORE CHARACTER
	SAD	(COMMA	/ IS IT ','
	JMP	GETK	/ ITS ','
	SAD	(ENDST
	JMP	ERRDO0	/ END OF STATEMENT - ERROR.
GET1	JMS*	GETCHI	/ NONE OF ABOVE SET UP NEXT CHAR
	JMP	AGDO2
/
ITSCLS	LAW	-1
	TAD	CNT
	DAC	CNT	/ UNCOUNT CLOSING BRACKETS
	SKP
ITSOPN	ISZ	CNT	/ COUNT OPENING BRACKETS
GET2	JMS*	GETCHI
	JMP	AGDO1	/ MIGHT HAVE ENTERED OR EXITED FORM (...)
/
/
/ GET K
/
GETK	JMS*	GETCHI	/ STEP PAST COMMA
	LAW	NOSTEP
	JMS*	EXPRES
	.DSA	KOMLN
	.DSA	ERRDO0
	.DSA	KOMLN
	.DSA	ERRDO0
/
KOMLN	JMS	FIDDLE
	SNA!CLA		/ XCT'D FROM FIDDLE
	DAC	ADDRSK	/ RETURNS HERE FROM FIDDLE
/
/ GET L
/
GETL	LAC*	CHINXT
	SAD	(ENDST
	JMP	LMISSG	/ NO L, USE +1
	JMS*	GETCHI
	LAW	0
	JMS*	EXPRES
	.DSA	ERRDO0
	.DSA	ERRDO0
	.DSA	.+2
	.DSA	ERRDO0
/
	JMS	FIDDLE
	SZA!CLA		/ XCT'D FROM FIDDLE
LJOIN	DAC	ADDRSL	/ RETURNS HERE
	JMP	GETI
/
/ THERE IS NO L PARAMETER, DEFAULT IS +1 .
LMISSG	LAC	(1
	DAC*	VANTED
	DZM*	VANT1	/ ZERO FOR HASH ENTRANCE TO SYMBOL TABLE
	LAC	(CONBIT!SINTGM
	DAC*	FLTFLG
	LAC	(CONST
	JMS*	CALCP	/ ENTER '1' IN SYMBOL TABLE
	LAC*	TBADDR
	JMP	LJOIN
/
/ GET I
GETI	JMS*	REGAIN
	LAW	LHSSW!CONILL!EXPILL!DFNSW
	JMS*	EXPRES
	.DSA	ERRDO0
	.DSA	.+3
	.DSA	ERRDO0
	.DSA	ERRDO0
	LAC*	AD2
	DAC	ADDRSI	/ SAVE IMPORTANT INFO
	LAC*	CLEW2
/
/ CHECK MODE, MUST BE INTEGER.
/
	AND	(17
	SAD	(SINTGM
	JMP	GETJ
	SAD	(DINTGM
	JMP	GETJ
ERRDO1	JMS*	ERRORS
	.SIXBT	'DO1'
/
/ GET RIGHT HAND SIDE WHICH IS J
GETJ	LAW	0
	JMS*	EXPRES
	.DSA	.+4
	.DSA	ERRDO0
	.DSA	ERRDO0
	.DSA	ERRDO0
/
/ ONLY INTEGER AND REAL MODES LEGAL
	JMS	MDCHK
	LAC*	CLEW2
	AND	(INACC
	SZA
	JMP	PUTDO	/ J IS AN EXPRESSION
	LAC*	AD2
	DAC*	DRESS
	LAC*	CLEW2
	DAC*	CLUES
	LAC	(LOAD*M	/ LOAD
	DAC*	OPCODE
	JMS*	PUNCH	/ PUNCH OUT LOAD J
/
/ NOW PUNCH OUT THE 'DO' OPCODE
PUTDO	LAC*	CLEW2
	AND	(INVERT
	SZA
	LAC	(400000	/ DO MARK A STOREN IS NEEDED
	DAC	CNT
	LAC	(DOS*M
	DAC*	OPCODE
	DZM*	CLUES
	LAC	ADDRSI
	DAC*	DRESS
	JMS*	PUNCH
/
/ NOW GET A TEMPORARY ACCUMULATOR FOR EXECUTATION STORAGE
	LAC	(INACC!REALM
	DAC*	CLEW2
	LAC	CLEW2
	DAC*	ACCSW
	CLL
	LAC	CNT	/ EITHER 0 OR 400000
	JMS*	TEMPA2
	LAC*	BASE3
	DAC	ADDRSI
	LAC*	DRESS	/ GET ADDRESS OF TEMP ACC
	DAC*	ADDRSI
	ISZ*	BASE3	/ STEP PAST ENTRY
/
/ PUNCH OUT ADDRESS OF L
	DZM*	OPCODE
	LAC	(TEMPER
	DAC*	CLUES	/ LET PUNCH SORT OUT IF IS A TEMP ACC
	LAC	ADDRSL
	DAC*	DRESS
	JMS*	PUNCH
/
/ PUNCH OUT ADDRESS OF K
	LAC	ADDRSK	/ OPCODE & CLUES ARE STILL SET
	DAC*	DRESS
	JMS*	PUNCH
	JMP*	PRODOS
/
/
/ THIS ROUTINE SORTS OUT THE EXPRESSIONS, VARIABLES, AND CONSTANTS
/ OF THE  DO STATEMENT
/
FIDDLE	XX
	JMS	MDCHK	/ CHECK MODES
	LAC*	CLEW2
	AND	(INACC
	SNA
	JMP	VARCON	/ IT IS VARIABLE OR CONSTANT
/
/ ITS AN EXPRESSION, STORE IN A SMASHED TEMP ACC
EXPRS	LAC	CLEW2
	DAC*	ACCSW
	LAC*	CLEW2
	AND	(INVERT
	XCT*	FIDDLE
	JMP	.+3
	LAC	(STORE*M
	SKP!CLL
	LAC	(STOREN*M
	JMS*	TEMPA2
FJOIN	LAC*	DRESS
FJOIN1	ISZ	FIDDLE	/ BUMP RETURN ADDRESS
	JMP*	FIDDLE
/
/ ITS A VARIABLE OR CONSTANT
VARCON	LAC*	CLEW2
	AND	(INVERT
	XCT*	FIDDLE
	LAC	(400000	/ MARK THAT INVERT WAS SET
	XOR*	AD2
	JMP	FJOIN1
/
/
/ THIS SUBROUTINE CHECKS THE MODES, ONLY INTEGER AND REAL PASS
MDCHK	XX
	LAC*	CLEW2
	AND	(000017
	SAD	(LOGICM
	JMP	ERRDO2
	AND	(000010
	SNA
	JMP*	MDCHK
ERRDO2	JMS*	ERRORS
	.SIXBT	'DO2'
/
/
/
/ THIS SECTION CLEANS UP AFTER THE END OF THE DO LOOP IS ENCOUNTERED
/ THE AC CONTAINS THE 2'S COMPLIMENT OF THE NUMBER OF DO LOOPS
/ THAT TERMINATE ON THIS STATEMENT
/
ENDDO	XX
	DAC	ADDRSL	/ SAVE COUNT
DOMORE	LAW	-1	/ NOW UNWIND A DO LOOP
	TAD*	BASE3	
	DAC*	BASE3	/ RESET TO LAST ENTRY IN DO TABLE
	DAC	ADDRSI	/ POINT TO LAST ENTRY
	LAC*	ADDRSI	/ GET LAST ENTRY
	DAC*	DRESS
	LAC	(TEMPER	/ MARK AS TEMP ACC TO FREE IT
	DAC*	CLUES
	LAC	(UNDO*M
	DAC*	OPCODE
	JMS*	PUNCH
	ISZ	ADDRSL	/ ARE ALL DO LOOPS UNWOUND?
	JMP	DOMORE	/ NO. DO ANOTHER
	JMP*	ENDDO	/ YES. RETURN
/
	.EJECT
/
/ THE 'END' SECTION FOLLOWS. THE TAG END IS BRANCHED TO WHEN AN
/ END STATEMENT IS ENCOUNTERED. IT PERFORMS A CHECK AND THEN
/ GOES TO CLEAN UP THE SYMBOL TABLE . IF A LISTING OF THE SYMBOL TABLE
/ IS NEEDED IT DOES THIS BEFORE RETURNING TO CHECK IF A SUBROUTINE
/ FOLLOWS.
/
END	LAC*	STATSW
	SZA		/ WAS LAST STATEMENT A TRANSFER STATEMENT
	JMP	ENDOK	/ YES.
	LAC	KIND
	SAD	(BLOCKD
	JMP	ENDOK		/ END STATEMENT OK ANY TIME IN BLOCK DATA
/
ERREN3	JMS*	ERROR	/ NO. END STATEMENT NOT PRECEDED BY A TRANSFER STATEMENT
	.SIXBT	'EN3'
ENDOK	DZM*	STATSW	/ TURN OFF STATSW
	LAW	H5!ILGIF!NON.EX!BDLEGL
	JMS*	HIERAR
	ISZ	ENDSW	/ INDICATE AN END STATEMENT WAS FOUND
	JMS*	APPEND	/ GO CLEAN UP SYMBOL TABLE
	JMS*	HOOK		/ALLOW PRINTING (IF ANY) TO CATCH UP
	LAC*	LST
	SNA
	JMP	NOLIST		/NO LISTING - NO FORM FEED!!
	.WRITE	LP,2,FORMFD,0
NOLIST	LAC	SYMPRT	/ IS A SYMBOL TABLE LISTING REQUIRED
	SZA
	JMS*	SYMBOL	/ YES, GO PRINT OUT SYMBOL TABLE
	JMS*	SETPT2	/ RELEASE LAST LINE FOR PRINTING
	JMP*	JOINCK
/
/ WHEN THE OUTPUT ROUTINE REACHES AN EOM OR EOF THE FILE IS
/ FINISHED BEING PROCESSED. CLOSE FILE.
ENDFIL	JMS*	CLOSER	/ CLOSE THE BINARY FILE
	.CLOSE	DKI
	ISZ	EXITSW	/ WAS A CARRIAGE RETURN OR ALTMODE TYPED
	JMP*	.START	/ WAS ALTMODE, RETURN TO COMPILER
	.WAIT	TTO	/WAIT FOR ERROR COUNT ANNOUNCEMENT TO FINISH
	.EXIT		/ RETURN TO MONITOR
/
ENDSW	0 	/ INDICATES WHETHER A END STATEMENT HAS BEEN PROCESSED
EXITSW	0	/ IF -1, ALTMODE WAS ENCOUNTERED, RETURN TO MONITOR
SYMPRT	0	/ IF 1, THEN A SYMBOL TABLE LISTING IS DESIRED
/
FORMFD	2002; 0; .ASCII <14><15>  /FORM FEED ON END STATEMENT
	.EJECT
/
/
/ THE FOLLOWING STORAGE LOCATIONS FOR THE EQUIVALENCE SECTION
/ ARE SHARED WITH OTHER, NON-CONFLICTING SECTIONS
NESTPT	/ POINTS TO THE NEXT LOCATION FOR THE NEXT EQUIV ROW
NESTJ	/ NEST NUMBER INDICATOR FOR EQUIVALENCE CLEANUP
D	/ WORD OR ARRAY SIZE REQUIRED FOR ELEMENT
N	/ STORAGE FOR NEST NUMBERS WHILE THREADING THRO TIE INS.
L
SMALLS
SMALLT
SMALLI
/
/ THE FOLLOWING LOCATIONS ARE NEST PARAMETERS AND MUST REMAIN
/ TOGETHER IN THIS ORDER FOR TRANSFERAL INTO THE TABLE.
I	/ NEST NUMBER THIS NEST IS TIED TO
A	/ ADDRESS OF NEST IF IT HAS BEEN ASSIGNED
F	/ OFFSET OF NEST RELATIVE TO THE ONE POINTED AT
DTBLE	/ POINTER TO COMMON NAME DTABLE ADDRESS NEST IS EQUIV'D TO
MINJ	/ MAX DISTANCE TO 1ST ELEMENT OF ANY ARRAY IN NEST
MAXJ	/  "     "      " LAST   "	"   "    "   "   "	.
/
IL;AL;FL;DTPTL;MINL;MAXL	/ POINTERS TO NEST PARAMETERS
IN;AN;FN;DTPTN;MINN;MAXN	/ POINTERS TO NEST PARAMETERS
AO;AOP
FO;FOP
NA
NC
/
/
/ THIS ROUTINE TESTS ARRAY ELEMENTS FOR VARIABLE SUBSCRIPTS
/ WHICH ARE ILLEGAL IN DATA, AND EQUIVALENCE STATEMENTS
VARSUB	XX
	LAC*	MODPTR
	JMS*	GETADR	/ GET OTABLE ADDRESS
	DAC	OPT1
	TAD	(-1
	DAC	OPT2
	CMA		/ GIVES 2' COMP OF OPT1
	TAD*	OTABLE	/ GIVES COMPILE TIME RELATIVE ADDRESS
	RCR		/ GIVES EXECUTION TIME RELATIVE ADDRESS
	SAD*	AD2	/ COMPARE WITH RELATIVE ADDRESS IN EXPRESS
	JMP*	VARSUB	/ THEY MATCH.
ERREC8	JMS*	ERRORS
	.SIXBT	'EC8'
/
/
/ ENTER HERE FOR EQUIVALENCE STATEMENTS
EQUIV	LAW	H4!NON.EX!BDLEGL
	JMS*	HIERAR
	ISZ	EQUVSW	/ INDICATES WE ARE IN EQUIVALENCE
	LAC*	BASE3	/ GET START ADDRESS OF EQUIVALENCE TABLE
	DAC	NESTPT
/
NXTNST	ISZ	SMALLJ	/ INCREMENT NEST COUNTER
/
	LAW	-26	/ INITIALIZE 22 LOCATIONS
	JMS*	G.INIT	/ INITIALIZE LOCATIONS
	LAC	(D
	CLA
/
	JMS*	GETCHI	/ GET NEXT CHAR,SHOULD BE (
	SAD	(OPEN
	SKP
	JMP	ERREV0
	JMS*	GETCHI	/ GET NEXT CHAR
NXTELM	DZM*	SPOT2
	LAW	EXPILL!DFNSW!CONILL
	JMS*	EXPRES
	.DSA	CMMA
	.DSA	ERREV0
	.DSA	ERREV0
	.DSA	CLOSP	/ CLOSING PARENTHESES
/
ERREV0	JMS*	ERRORS	/ ILLEGAL NEST CONSTRUCTION
	.SIXBT	'EV0'
ERREV2	JMS*	ERRORS	/ FEWER THAN 2 MEMBERS IN EQUIVALENCE LIST
	.SIXBT	'EV2'
ERREV4	JMS*	ERRORS	/ CAN'T EQUIVALENCE FORMAL PARAMETERS
	.SIXBT	'EV4'
ERREV5	JMS*	ERRORS	/ ILLEGAL NEST DELIMITER
	.SIXBT	'EV5'
/
CLOSP	CLC
	DAC	ENDNST	/ INDICATES CLOSING PARENTHESES
CMMA	LAC*	BITPTR
	AND	(FORMAL		/ CAN'T EQUIVALENCE FORMAL PARAMETERS
	SZA
	JMP	ERREV4
	LAC	(EQUSET	/ MARK AS BEING IN EQUIVALENCE
	JMS	SHOVE
	JMS	VARSUB	/ TEST IF VARIABLE SUBSCRIPTS, WHICH ARE ILLEGAL
/
	JMS	ARYSIZ	/ GET SIZE OF STORAGE REQ'D
	DAC	D
	LAC*	SPOT2
	CMA
	TAD	(1
	DAC	SMALLS
	LAC	MINJ
	JMS	MINIM	/ GET MINJ=MIMIN(MINJ,-S))
	TAD	SMALLS
	DAC	MINJ
/
	LAC	D
	TAD	SMALLS
	JMS	MAXIM	/ GET MAXJ=MAXIM(MAXJ,D-S)
	TAD	MAXJ
	DAC	MAXJ
/
/
	LAC*	BITPTR
	AND	(COMSET
	SZA		/ IS VARIABLE IN COMMON
	JMP	H	/ YES
	LAC*	OPT1	/ NO
	SZA		/ IS VARIABLE IN ANOTHER EQUIV NEST
	JMP	H	/YES
/
/
	LAC	SMALLJ	/ NO GET NEST NUMBER
	DAC*	OPT1	/ STORE IN OTABLE
	LAC	SMALLS
	DAC*	OPT2
/
ATAG	ISZ	SMALLI	/ INCREMENT ELEMENT #
	ISZ	ENDNST	/!HAS END OF NEST BEEN REACHED
	JMP	NXTELM	/ NO.
/
	LAC	(1	/ YES
	SAD	SMALLI
	JMP	ERREV2	/ THERE WAS ONLY ONE ELEMENT IN NEST
/
	LAW	-6	/ NO. OKAY
	JMS*	G.MOVE	/ TRANSFER DATA TO NEST
	TAD	(I
	TAD	NESTPT
/
	LAC	NESTPT
	TAD	(6
	DAC	NESTPT	/RESET FOR A NEW ROW
	LAC*	CHINXT
	SAD	(COMMA	/ IS IT ','
	JMP	NXTNST
	SAD	(ENDST	/ NO, THEN IT SHOULD BE END OF STATEMENT
	SKP
	JMP	ERREV5	/ IT IS NEITHER-ERROR!
	DZM	EQUVSW	/ TURN OFF 'EQUVSW'
	LAC	NESTPT
	DAC*	BASE3	/ RESET TO END OF EQUIVALENCE TABLES
	EXIT
/
/
/ THIS SECTION IS REACHED WHEN AN ELEMENT IS EITHER IN COMMON OR
/ ANOTHER EQUIVALENCE NEST.
H	LAC	SMALLS
	DAC	FO	/ STORE OFFSET
	LAC	SMALLJ
	DAC	L	/ STORE CURRENT NEST NUMBER
/
	LAC	(I
NOTHER	JMS	SETPTL
	LAC*	IL	/ IS THIS NEST TIED TO ANOTHER
	SNA		/ YES, SKIP
	JMP	BASES	/ NO
	DAC	L
	LAC*	FL	/ COMPOUND OFFSET
	TAD	FO
	DAC	FO
	LAC	L
	JMS	NEWROW	/ SET UP POINTERS TO NEST POINTED AT
	JMP	NOTHER
/
BASES	LAC*	AL
	SNA		/ HAS NEST BEEN ASSIGNED AN ADDRESS
	JMP	K	/ NO
	LAC	FO	/ YES
	TAD*	AL
	DAC	AO
/
K	LAC*	BITPTR
	AND	(COMSET
	SZA		/ IS VARIABLE IN COMMON
	JMP	MTAG	/ YES.
	LAC*	OPT2	/ NO. THEN IT IS IN ANOTHER NEST
	DAC	FOP
	LAC*	OPT1	/ GET PREVIOUS NEST NUMBER
	DAC	N	/ SAVE IT
/
NEWLVL	JMS	NEWROW
	JMS	SETPTN	/ POINT TO PREV NEST WITH VARIABLE
	LAC*	IN
	SNA		/ IS THIS NEST TIED TO ANOTHER NEST
	JMP	NTAG	/ NO.
	DAC	N	/ YES.
	LAC*	FN	/ COMPOUND OFFSET
	TAD	FOP
	DAC	FOP
	LAC	N	/ GET NEST THIS ONE IS CONNECTED TO
	JMP	NEWLVL
/
/ ELEMENT IS IN COMMON AND THUS ITS ADDRESS FIXES THE NEST
MTAG	LAC*	OPT1	/ GET COMMON ADDRESS
	DAC	AOP	/ STORE IN AO PRIME
	LAC*	OPT2
	LMQ	/ STORE FOR LATER
P	LAC*	AL
	SNA		/ DOES NEST HAVE AN ADDRESS
	JMP	Q	/ NO.
	LAC*	OPT2	/ YES. NEST FIXED TO COMMON
	SAD*	DTPTL	/ IS IT THE SAME COMMON
	SKP
	JMP	ERREC0	/ NO. ERROR
	LAC	AO	/ YES.
	SAD	AOP
	JMP	ATAG	/ YES. REDUNDANT
ERREC1	JMS*	ERRORS	/ NO. ERROR
	.SIXBT	'EC1'
ERREC0	JMS*	ERRORS
	.SIXBT	'EC0'
/
/
Q	LAC	FO	/ FIX EQUIVALENCE NEST TO COMMONN
	CMA
	TAD	(1
	TAD	AOP
	DAC*	AL
	LACQ
	DAC*	DTPTL	/ STORE POINTER TO COMMON BLOCK
	JMP	ATAG
/
/ ELLEMENT WAS IN ANOTHER NEST AND WE HAVE CHAINED THROUGH
/ TO THIS ONES BASE NEST.
NTAG	LAC*	AN
	SNA		/ DOES BASE NEST HAVE AN ADDRESS?
	JMP	R	/ NO.
	TAD	FOP	/ YES. CALCULATE NEW BASE ADDRESS
	DAC	AOP
	LAC*	DTPTN	/ HAS ADDRESS, THEN HAS DTABLE POINTER
	LMQ		/ PREPARE TO INSERT FOR CURRENT NEST
	JMP	P
/
R	LAC*	AL
	SNA		/ DOES CURRENT NEST HAVE AN ADDRESS
	JMP	T	/ NO.
	LAC	FOP	/ YES. GET OFFSET OF ELEMENT
	TAD	AO	/ ADD ADDRESS OF CURRENT NEST
	DAC*	AN	/ TO GET NEST ADDRESS FOR BASE NEST
	LAC*	DTPTL	/ GET DTABLE POINTER
	DAC*	DTPTN	/ INSERT IN BASE NEST
	JMP	ATAG
/
T	LAC	N
	SAD	L	/ ARE THESE NESTS THE SAME
	SKP
	JMP	SSS	/ NO.
	LAC	FO	/ YES
	SAD	FOP
	JMP	ATAG
ERREV3	JMS*	ERRORS
	.SIXBT	'EV3'
/
/
/
SSS	DAC*	IL	/ MARK CURRENT NEST AS TIED TO PREV ONE / CALCULATE NEW OFFSET.
	LAC	FO
	CMA
	TAD	(1
	TAD	FOP
	DAC*	FL
	JMP	ATAG
/
/
/
/ THIS SUBROUTINE USES THE ROW NUMBER TO GET THE START ADDRESS
/ OF THAT ROW IN THE TABLE, RETURNS WITH ADDRESS IN AC
/	LAC	(ROW NUMBER
/	JMS	NEWROW
/
NEWROW	XX
	TAD	(-1
	CLL
	MUL
	.DSA	6
	LACQ
	TAD*	BASE2	/ ADD  START ADDRESS OF TABLE
	DAC	TEMP
	JMP*	NEWROW
/
/ THIS SUBROUTINE SETS UP THE 'L' POINTERS
SETPTL	XX
	DAC	IL
	TAD	(1
	DAC	AL
	TAD	(1
	DAC	FL
	TAD	(1
	DAC	DTPTL
	JMP*	SETPTL
/
MXMNL	XX
	TAD	(1
	DAC	MINL
	TAD	(1
	DAC	MAXL
	JMP*	MXMNL
/
/
/ THIS SUBROUTINE SETS UP THE 'N' POINTERS TO I,A,F VALUES FOR PREVIOUS
/ NESTS WHICH ARE STORED IN THE TABLE
SETPTN	XX
	DAC	IN
	TAD	(1
	DAC	AN
	TAD	(1
	DAC	FN
	TAD	(1
	DAC	DTPTN
	JMP*	SETPTN
/
MXMNN	XX
	TAD	(1
	DAC	MINN
	TAD	(1
	DAC	MAXN
	JMP*	MXMNN
/
/
/
/THIS SUBROUTINE TAKES THE MINIMUM OF X & Y AND LEAVES THE RESULT
/ IN THE AC
/	LAC	(X
/	JMS	MINIM
/	TAD	(Y
/
MINIM	XX
	LMQ		/ MQ_X
	CMA		/ AC_-X
	XCT*	MINIM	/ AC_Y-X
	SPA!CLA
	JMP*	MINIM	/  AC_0+Y
	ISZ	MINIM
	LACQ		/ AC_X
	JMP*	MINIM
/
/
/
/ THIS SUBROUTINE TAKES THE MAXIMUM OF X & Y AND LEAVES THE RESULT
/ IN THE AC.
/	LAC	(X
/	JMS	MINIM
/	TAD	(Y
/
MAXIM	XX
	LMQ		/ MQ_X
	CMA		/ AC_-X
	XCT*	MAXIM	/ AC_Y-X
	SMA!CLA
	JMP*	MAXIM	/ AC_O+Y
	ISZ	MAXIM
	LACQ		/ AC_X
	JMP*	MAXIM
/
/
/ THIS SECTION CLEANS UP THE EQUIVALENCE TABLES IF ANY EXIST AND
/ ASSIGN ADDRESS TO THOSE NESTS AND THEN TO ALL VARIABLES.
/
EQUCLN	XX
	LAC	HEADER
	DAC	NA	/ GET SPACE FOR START SECTION
	LAC	SMALLJ
	SNA		/ IS THERE AN EQUIV TABLE
	JMP	ASSALL	/ NO GO ASSIGN ADDRESSES TO ALL VAR.
	ISZ	SMALLJ
	DZM	NESTJ	/ NEW NEST COUNTER
/
NSTNXT	ISZ	NESTJ	/ INCREMENT NEST NUMBER
	LAC	NESTJ
	SAD	SMALLJ	/ HAVE ALL NESTS BEEN DONE
	JMP	ASSFRE	/ YES. GO ASSIGN ALL FREE NESTS
	JMS	NEWROW	/ NO.
	JMS	SETPTL	/ SET UP POINTERS TO NEST.
	JMS	MXMNL	/ BEING WORKED ON.
	LAC*	IL
	SNA		/ IS NEST TIED TO ANOTHER ?
	JMP	NOTIED	/ NO
TIED	JMS	NEWROW	/ YES. SET UP 'N' POIINTERS TO THIS NEST
	JMS	SETPTN
	JMS	MXMNN
	LAC*	IN
	SNA		/ IS THIS ONE TIED TO ANOTHER
	JMP	NOMORE	/ NO
	LAC*	FL	/ YES. COMPOUND OFFSET TO
	TAD*	FN	/ REDUCE ALL NEST TO ONLY ONE LEVEL
	DAC*	FL
	LAC*	IN
	DAC*	IL	/ MARK NEST AS TIED TO THE NEW ONE
	JMP	TIED
/
NOMORE	LAC*	MINL	/ GET MAX OF CURRENT NEST
	TAD*	FL	/ ADD COMPOUNDED OFFSET
	JMS	MINIM
	TAD*	MINN
	DAC*	MINN	/ RETURN NEW MINIINUM
/
	LAC*	MAXL
	TAD*	FL
	JMS	MAXIM
	TAD*	MAXN
	DAC*	MAXN
	JMP	CKADR
/
NOTIED	LAC	NESTJ
	JMS	NEWROW	/ SET UP 'N' POINTERS TO THE
	JMS	SETPTN	/ CURRENT ROW ALSO SO WE CAN
	JMS	MXMNN	/ USE COMMON CODING HERE ON
/
/
/ WHEN WE GET HERE WE HAVE THE 'N' POINTERS POINTING TO A BASE
/ NEST. ALL NESTS HAVE BEEN REDUCED TO A BASE NEST.
/
CKADR	LAC*	AN
	SNA		/ DOES THIS BASE NEST HAVE AN ADDRESS
	JMP	NSTNXT	/ NO. GO DO NEXT NEST
	AND	(077777	/ REMOVE ANY STRAY BITS
	TAD*	MAXN	/ YES. ADD ADDRESS+MAXIMUM
	JMS	MAXIM
	TAD	NC
	DAC	NC
/
	LAC*	AN	/ GET ADDRESS
	AND	(077777	/ REMOVE ANY STRAY BITS
	TAD*	MINN
	SMA		/ DOES IT EXTEND COMMON BACKWARDS
	JMP	NSTNXT	/ GO DO NEXT NEST
ERREC3	JMS*	ERROR
	.SIXBT	'EC3'
	JMP*	EQUCLN	/ RETURN TO RESET HIERARCHY NUMBERS
/
/
/ ASSIGN ADDRESSES TO ALL FREE EQUIVALENCE GROUPS, IE. ALL BASE NESTS
/
ASSFRE	DZM	NESTJ
/
NEWNST	ISZ	NESTJ
	LAC	NESTJ
	SAD	SMALLJ	/ HAVE ALL NESTS BEEN DONE
	JMP	ASSREL	/ YES. GO ASSIGN ALL RELATIVE GROUPS
	JMS	NEWROW
	JMS	SETPTL
	JMS	MXMNL
	LAC*	IL
	SZA		/ IS THIS NEST TIED TO ANOTHER
	JMP	NEWNST	/ YES. GO TRY NEXT ONE
	LAC*	AL	/ GET NEST ADDRESS
	SZA		/ DOES NEST HAVE AN ADDRESS
	JMP	NEWNST	/ YES. GO TRY NEXT ONE
	LAC*	MINL	/ NO.
	CMA
	TAD	(1
	TAD	NA
	DAC*	AL	/ ASSIGN IT AN ADDRESS
	TAD*	MAXL
	DAC	NA	/ CALCULATE NEXT FREE ADDRESS
	JMP	NEWNST
/
/
/ ASSIGN ADDRESS TO ALL RELATIVE EQUIVALENCE GROUPS
/
ASSREL	DZM	NESTJ
/
NSTNEW	ISZ	NESTJ
	LAC	NESTJ
	SAD	SMALLJ	/ HAVE ALL NESTS BEEN DONE
	JMP	ASSALL	/ YES. GO ASSIGN ALL ADDRESSES
	JMS	NEWROW	/ YES
	JMS	SETPTL	/ SET 'L' POINTERS TO THIS NEST
	LAC*	IL
	SNA		/ IS THIS NEST TIED DOWN
	JMP	NSTNEW	/ NO. GO GET NEW NEST
	JMS	NEWROW	/ YES.
	JMS	SETPTN	/ SET 'N' POINTERS TO BASE NEST
	LAC*	AN	/ GET BASE ADDRESS ( ONLY ONE LEVEL)
	TAD*	FL
	DAC*	AL	/ INSERT THE NESTS ADDRESS
	LAC*	DTPTN	/ GET DTABLE ADDRESS IF ANY
	DAC*	DTPTL	/ INSERT IN CURRENT NEST
	JMP	NSTNEW	/ GO GET NEW NEST
/
/
/ NOW ASSIGN ADDRESSES TO ALL VARIABLES IN THE WHOLE SYMBOL TABLE
/
ASSALL	LAW	-1
	TAD*	PTABLE	
	DAC*	(AUTO12	/ SET AUTO-INDEX FOR PTABLE SCAN
/
VARNEW	LAC	(VARIAB	/ WANT VARIABLE
	JMS*	G.SCAN	/ GO SCAN PTABLE
	JMP	FOUND	/ RETURN HERE WHEN VARIABLE FOUND
	LAC	NA	/ GET STORAGE REQUIRED
	SNA
	JMP	NOSPACE		/ ONLY IN BLOCK DATA WILL THHS BE ZERO
	DAC*	ITEM
	LAC	(06	/ CODE 06 RESERVES NON-COMMON STORAGE
	JMS*	INSRT	/ PUNCH IT OUT
	LAC	NA	/ GET NEXT FREE ADDRESS
NOSPACE	DAC*	LOCCNT	/ IS STARTING VALUE FOR LOCATION COUNTER
	TAD	(-1
	DAC*	START	/ MARK AS START-1 OF INTERPRETIVE CODE
/ NOW CHECK IF THERE WAS ANY DATA IN SPEC STATEMENTS AND CLEAN IT UP
	JMS*	RECORD	/ SAVE PLACE IN CHI
	LAW	-1
	DAC	ERSW
	LAC	BASE1	/ GET START ADDRESS OF DATA
LOPS	SAD*	BASE2	/ WAS THERE ANY DATA?
	JMP	OVERS	/ NO
	DAC	NC
	LAC	KIND
	SAD	(BLOCKD		/ CHECK FOR BLOCK DATA
	JMP	DONAME
	LAC*	NC	/ GET MODPTR
	DAC	DSPECS
CTIE	LAW	-1
	DAC	DSPECS+1
	DAC*	IND	/ START ON LEFT
	LAC	NC
	TAD	(1
	DAC*	INDEX
	LAC	(DSPECS-1
	DAC*	(AUTO14
	DZM	COUNT
	JMS*	GETCHI	/ GET 1ST CHARACTER
	JMS	PICCON
	LAC*	INDEX
	TAD*	IND
	TAD	(1
	JMP	LOPS
OVERS	JMS*	REGAIN
	LAC	BASE1	/ GET START ADDRESS OF DATA STORAGE
	DAC*	BASE2	/ RESET EQUIVALENCE POINTER
	DAC*	BASE3	/ RESET START OF WORK AREA POINTER
	DZM	ERSW
	JMP*	EQUCLN	/ RETURN
/
/  CHECK COMMON NAME FOR BLOCK DATA
/
DONAME	LAC*	NC
	DAC	DSPECS
	TAD	(3
	DAC	BITPTR
	LAC*	DSPECS
	JMS*	GETADR
	TAD	(-1
	DAC	OPT2
	JMS	INBLKD
	JMP	CTIE
/
/ BRANCH TO HERE WITH A NEW VARIABLE
FOUND	DAC	MODPTR	/ SET UP POINTERS TO DTABLE
	TAD	(3
	DAC	BITPTR
	TAD	(1
	DAC	CPOINT	/ FOR CHARACTER VARIABLES
	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(FORMAL!FUNBIT!NOHERE!FUNNAM	/ DO NOT ASSIGN
	SZA		/ SPACE TO FUNCTION NAMES
	JMP	VARNEW
/
/ IF THE VARIABLE IS CHARACTER, COUNT THE SPACE NEEDED FOR ITS DOPE
/  VECTOR.  (THIS WILL ASSIGN A 2 WORD DOPE VECTOR FOR SINGLE
/  VARIABLES WHICH HAVE DATA.  MAYBE NOT NECESSARY, BUT NOT GOING
/  TO CHANGE NOW!)
/
	LAC*	MODPTR
	AND	(17	/ GET MODE
	SAD	(CHARM
	SKP
	JMP	NOCHR	/ NOT CHARACTER
	ISZ	CHRCNT
	ISZ	CHRCNT
/
/ NOW DO NOT ASSIGN SPACE TO COMMON VARIABLES EITHER
NOCHR	LAC*	BITPTR
	AND	(COMSET
	SZA
	JMP	VARNEW
/
/ NOW DO SOME HONEST WORK.
	LAC*	MODPTR
	JMS*	GETADR
	DAC	OPT1
	TAD	(-1
	DAC	OPT2
NONEOF	LAC*	OPT1	/ GET 1ST WORD OF OF OTABLE
	SZA		/ DOES VARIABLE HAVE A NEST #.
	JMP	NSTNUM	/ YES.
	LAC	NA	/ NO. ASSIGN AN ADDRESS
	DAC*	OPT1	/ NO. ASSIGN STARTING AFTER EQUIV ADDRESS
	JMS	ARYSIZ	/ GET STORAGE REQUIRED
	TAD	NA
	DAC	NA	/ RESET FOR NEXT ADDRESS
	JMP	VARNEW
/
/ IF EQUIVALENCE NEST CONTAINED A COMMON ENTRY THEN THE ADDRESS
/ USED FOR THE NEST IS THAT COMMON ADDRESS AND THE INDICATOR
/ BIT 200000 IS RETAINED WITH IT. THUS WHEN WE ASSIGN THIS ADDRESS
/ TO ANY NON-COMMON VARIABLES THAT WERE IN THE NEST THEN WE
/ AUTOMATICALLY MARK THEM AS BEING COMMON ENTRIES, WHICH IS WHAT
/ WE WANT.
NSTNUM	JMS	NEWROW
	JMS	SETPTL
	LAC*	AL	/ GET NEST ADDRESS
	TAD*	OPT2	/ ADD VARIABLE OFFSET FROM EQUIV PT
	DAC*	OPT1	/ TO GET START ADDRESS OF VARIABLE
/ IF NEST IS TIED TO COMMON THEN MUST MARK VARIABLE IN THE DTABLE
/ AS BEING IN COMMON AND SET THE OTABLE POINTER TO THE DTABLE ENTRY
/ FOR THE COMMON NAME. MUST ALSO UPDATE THE COMMON SIZE IF THE 
/ VARIABLE EXTENDS IT. 
/   SIZE = MAX(START ADDRESS OF VAR + VAR. SIZE, COMMON SIZE)
	LAC*	DTPTL	/ ADDRESS OF COMMON NAME IF NOT ZERO
	DAC	NESTJ
	SNA		/ IS NEST TIED TO COMMON
	JMP	NOCOMN	/ NO.
	DAC*	OPT2	/ YES. STORE ADDRESS
	LAC	(COMSET
	JMS	SHOVE	/ MARK AS IN COMMON IN DTABLE
	JMS	ARYSIZ	/ GET SIZE OF VARIABLE
	TAD*	OPT1	/ GET START ADDRESS
	AND	(077777	/ REMOVE COMMON INDICATOR BITS
	JMS	MAXIM	/ TAKE MAXIMUM
	TAD*	NESTJ	/ SIZE OF COMMON FOR 'MAXIM'
	DAC*	NESTJ	/ RESTORE SIZE
	JMP	VARNEW
/
/ VARIABLE NOT IN COMMON, JUST INSERT POINTER TO ITS DTABLE ENTRY
NOCOMN	LAC	MODPTR
	DAC*	OPT2	/ INSERT DTABLE ADDRESS IN OTABLE
	JMP	VARNEW
/
	.EJECT
/
/
/
EXTRNL	LAW	H3!NON.EX!BDLEGL
	JMS*	HIERAR
AGEXT	JMS*	GETCHI
	LAC	(NAME
	JMS*	SEARCH
	LAC	(VARIAB
	JMS*	CALCP	/ ENTER IN SYMBOL TABLE
	LAC	(FUNBIT!XTERNL!NOHERE
	JMS	SHOVE
	JMS*	DLOTAB	/ DELETE THE OTABLE ENTRY JUST ASSIGNED
	LAC*	CHINXT
	SAD	(COMMA	/ IS IT ','
	JMP	AGEXT	/ YES. GO GET NEXT VARIABLE
	SAD	(ENDST	/ IS IT END-OF-STATEMENT
	EXIT		/ YES. RETURN
	JMP	.	/ NO. ILLEGAL CHARACTER, ERROR
/
	.EJECT
/ TABLE FOR CONVERSION FROM INTERNAL CODE TO ASCII
/
ATABLE	.ASCII <0>
	.ASCII '(!&'<0>'<'
	.ASCII '>'<0><0><0><0>
	.ASCII '-+*/^'
	.ASCII <0>',='<0>')'
	.ASCII 'ABCDEFGHIJKLMNO'
	.ASCII 'PQRSTUVWXY'
	.ASCII 'Z$01234567'
	.ASCII '89.'<0><0>
	.ASCII ' '
/
/ THIS SUBROUTINE CONVERTS AN INTERNAL CODE CHARACTER INTO 5/7 ASCII
/ AND PACKS IT WITH G.PACK
REPACK	XX
	IDIV!660000	/ CLEAR LINK ! IDIVIDE
		5
	DAC	SHIFT
	RCL
	RTL
	CMA
	TAD	(LRS 36
	TAD	SHIFT
	DAC	SHIFT
	LACQ
	RCL
	TAD	(ATABLE
	DAC	TEMP
	DAC*	(AUTO10
	LAC*	AUTO10
	LMQ
	LAC*	TEMP
SHIFT	XX
	LACQ
	AND	(177
	SNA
	JMP	ERRFM0
	JMS*	G.PACK
	JMP*	REPACK
/
/ FORMAT ROUTINES
/ A FORMAT STATEMENT WAS PREVIOUSLY CONVERTED TO '......' TYPE
/ HOLLERITH CONSTANTS, NOW CONVERT ALL SUCH HOLLERITHS TO NNH.....
/ TYPE HOLLERITHS
FORMAT	LAW	H5!ILGIF!FORM	/ THIS MUST BE DONE AT THE 1ST IN CASE A
	JMS*	HIERAR	/ DO LOOP MUST BE UNWOUND
	LAC*	LOCCNT	/ GET LOCATION COUNTER FOR SET UP AND TO  
	DAC	NA	/ DETERMINE IF TESTGO COMPILES A GOTO
	JMS	TESTGO	/ CHECK IF A GOTO MUST BE COMPILED AROUND
	LAC*	LOCCNT
	DAC*	FORMBX	/ RESET IN CASE A GOTO WAS COMPILED
	LAC*	CHI	/ SET UP 5/7 ASCII BUFFER
	JMS*	G.STPC
	SKP
FPACK	JMS	REPACK	/ CONVERT THE CODE TO ASCII AND STORE IT
P1	JMS*	GETCHI	/ PICK UP INTERNAL CODE CHARACTER
	SAD	(ENDST	/ IS IT END OF STATEMENT ?
	JMP	P3
	SAD	(APOST	/ IS IT APOSTROPHE
	SKP		/ YES.
	JMP	FPACK	/ NO.
/
/ HAVE FOUND AN APOSTROPHE. IT CONTAINS ASCII ALREADY BUT CONVERT
/ IT TO A NNH........ TYPE HOLLERITH
P4	JMS*	RECORD	/ RECORD POSITION IN CHI TABLE
	DZM	COUNT
	JMS*	GETCHI
	SAD	(APOST	/ IS IT APOSTROPHE
	JMP	P8
	ISZ	COUNT	/ COUNT CHARACTERS UNTIL NEXT APOSTROPHE
	JMP	.-4
/
/ HAVE FOUND 2ND APOSTROPHE
P8	JMS*	REGAIN	/ REGAIN PLACE IN CHI TABLE AT 1ST '
	DZM*	NUMS
	LAC	COUNT
	SNA!STL
	JMP	ERRFM0	/ HAVE FOUND A ZERO LENGTH HOLLERITH
	JMS*	G.CVRT
	LAC	(110	/ASCII H
	JMS*	G.PACK	/ JUST PICK UP ASCII CHARS INSIDE '..'
	JMS*	GETCHI	/ AND TRANSFER THEM AS IS.
	SAD	(APOST
	JMP	P1
	JMP	.-4
/
ERRFM0	JMS*	ERRORS
	.SIXBT	'FM0'
/
/ END OF STATEMENT FOUND. DUMMY UP AS A CHARACTER CONSTANT
P3	LAC*	CHARCT
	TAD	(400002
	RCL		/ MULT BY 2, SET L_1
	IDIVS
		5	/ DIVIDE BY 5
	LACQ		/ RESULT IS NEGATIVE
	DAC	COUNT	/ NUMBER OF WORDS TO TRANSFER
	LAW	-1
	TAD*	CHI
	DAC*	(AUTO10
	LAC*	CHARCT	/ GET NUMBER OF CHARACTERS
	TAD	(600000
P5	JMS*	ITEM4	/ PUNCH OUT THE CONSTANT
	LAC*	AUTO10
	ISZ	COUNT
	JMP	P5
	JMP	FMENTR	/ GO UPDATE INTERNAL GOTO IF NECESSARY
	.EJECT
/ GO TO AND GO TO (
.GOTO	LAW	H5!.EXC
	JMS*	HIERAR
	JMS*	GETCHI
	SAD	(OPEN	/ IS STATEMENT 'GO TO (.....),N'
	JMP	GOTOBR	/ YES
	LAC	IFSW	/FOR 'IF(LOGICAL)GOTO', DON'T NEED STATEMENT #
	SMA
	ISZ*	STATSW	/ DEMAND NEXT STATEMENT HAS A STATEMENT NUMBER
	LAC	(INTGRS
	JMS*	SEARCH
	LAC	(STNUM
	JMS*	CALCP
	LAC*	BITPTR
	AND	(000077\TRAN.\.EXC\DO.S
	SZA
	JMP	ERRGO0
	LAC	(TRAN.
	JMS	SHOVE
	LAC	(GOTO*M
	XOR*	TBADDR
	JMS*	ITEM4	/ CODE 04
	LAC*	CHINXT
	SAD	(ENDST
	EXIT
ERRGO1	JMS*	ERRORS		/ INVALID SYNTAX IN COMPUTED GO TO
	.SIXBT	'GO1'
/
ERRGO0	JMS*	ERRORS		/ STATEMENT TRANSFERS TO A 
	.SIXBT	'GO0'		/ NON-EXECUTABLE STATEMENT
/
/
/ COMPUTED GO TO
GOTOBR	DZM	CNT
	JMS*	RECORD	/ RECORD POSITION IN CHI TABLE
AGSTN1	JMS*	GETCHI
	SAD	(CLOSE
	JMP	ENDBR
	SAD	(COMMA
	ISZ	CNT
	SAD	(ENDST
	JMP	ERRGO1
	JMP	AGSTN1
/
ENDBR	JMS*	GETCHI	/ GET NEXT CHARACTER
	SAD	(COMMA	/ IS IT COMMA ?
	SKP
	JMP	ERRGO1	/ ERROR, NO COMMA AFTER BRACKETS
	JMS*	GETCHI
	LAC	(NAME
	JMS*	SEARCH
	LAC	(VARIAB
	JMS*	CALCP
	LAC*	CHINXT
	SAD	(ENDST
	JMP	GOOKAY
ERRGO2	JMS*	ERRORS		/ INDEX NOT SIMPLE VARIABLE
	.SIXBT	'GO2'
/
/ PUNCH OUT 'LOAD N'
/
GOOKAY	LAC	(LOAD*M
	TAD*	TBADDR	/ ADD RELATIVE OTABLE COUNTER
	JMS*	ITEM4	/ CODE 04
/ PUNCH OUT 'GO TO M'.(M = THE NUMBER OF STATEMENT NUMBERS)
	LAC	CNT
	TAD	(1
	JMS*	HIDCON	/ HIDE THE CONSTANT AWAY IN SYMBOL TABLE
	DAC*	DRESS	/ STORE ITS ADDRESS
	LAC	(GOTOB*M
	DAC*	OPCODE
	DZM*	CLUES
	JMS*	PUNCH
/
	JMS*	REGAIN	/ REGAIN POSITION IN CHI TABLE
AGSTN2	JMS*	GETCHI
	LAC	(INTGRS
	JMS*	SEARCH
	LAC	(STNUM
	JMS*	CALCP
	LAC	(TRAN.
	JMS	SHOVE	/ INSERT CONTROL BITS
	LAC*	TBADDR	/ GET RELATIVE OTABLE ADDRESS
	JMS*	ITEM4	/ CODE 04
	LAC*	CHINXT
	SAD	(COMMA
	JMP	AGSTN2
	SAD	(CLOSE
	EXIT
	JMP	ERRGO1
/
	.EJECT
/
ERRIF0	JMS*	ERRORS
	.SIXBT	'IF0'
ERRIF1	JMS*	ERRORS
	.SIXBT	'IF1'
/ IF STATEMENTS
IFBRAC	LAW	H5!.EXC
	JMS*	HIERAR
	JMS*	GETCHI
	LAW	CONILL
	JMS*	EXPRES	/ PROCESS CONTENTS IF 'IF' STATEMENT
	.DSA	ERRIF0
	.DSA	ERRIF0
	.DSA	ERRIF0
	.DSA	.+1
/
	LAC*	AD2
	DAC*	DRESS
	LAC*	CLEW2	/ GET CLUES ABOUT CONDITIONAL STATEMENT
	DAC*	CLUES
	AND	(INVERT
	SZA!CLA
	CLC
	DAC	IFTEMP
	LAC*	CLUES
	AND	(INACC	/ IF INACC=1, CONTENTS ARE AN EXPRESSION
	SZA		/ AC=0, IF INACC = 0
	JMP	EXPION	/ ITS AN EXPRESSION
	LAC	(LOAD*M
	DAC*	OPCODE
	JMS*	PUNCH
/
EXPION	LAC*	CLEW2
	AND	(17
	SAD	(LOGICM
	JMP	LOGICL		/MUST BE LOGICAL 'IF'
	AND	(10	/ MUST BE ARITHMETIC 'IF
	SZA		/ ONLY INTEGER AND REAL ARE LEGAL
	JMP	ERRIF1
/
/ ITS AN ARITHMETIC 'IF' STATEMENT
	LAC	IFSW		/ FOR ' IF(LOGICAL) IF(ARITH)',
	SMA			/ DON'T NEED STATEMENT #
	ISZ*	STATSW	/ NEXT STATEMENT MUST HAVE A STATEMENT NUMBER
	JMS	NEWSTN
	DAC	IFBOX	/ SAVE NEGATIVE CONDITION STATEMENT NUMBER
	JMS	NEWSTN
	XOR	(IFA*M
	JMS*	ITEM4	/ PUNCH OUT ZERO CONDITION ST. NUMBER
	ISZ	IFTEMP	/ CHECK IF CONTENTS HAD INVERT BIT SET
	JMP	IFOKAY	/ NO
/
/ YES. INVERT BIT WAS SET SWAP NEG AND POS STATEMENT NUMBERS
	LAC	IFBOX
	JMS*	ITEM4	/ PUNCH OUT NEG CONDITION ST. NUMBER
	JMS	NEWSTN
IFFIN	JMS*	ITEM4	/ PUNCH OUT POS CONDITION ST. NUMBER
	EXIT
/
IFOKAY	JMS	NEWSTN
	JMS*	ITEM4	/ PUNCH OUT POS
	LAC	IFBOX
	JMP	IFFIN
/
/
NEWSTN	XX
	LAC	(INTGRS	/ GET AN INTEGER
	JMS*	SEARCH
	LAC	(STNUM
	JMS*	CALCP
	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(NON.EX!FORM!.IOPUT
	SAD	(NON.EX
	JMP	ERRST7	/ STATEMENT NUMBER IS NON-EXECUTABLE
	SZA
	JMP	ERRST9	/ STATEMENT NUMBER IS A FORMAT STATEMENT
	LAC	(TRAN.
	JMS	SHOVE	/ INSERT CONTROL BITS
	JMS*	GETCHI	/ STEP PAST DELIMITER
	LAC*	TBADDR
	JMP*	NEWSTN
/
ERRST7	JMS*	ERRORS	/ ERROR - NON-EXECUTABLE STATEMENT NUMBER
	.SIXBT	'ST7'
ERRST9	JMS*	ERRORS	/ ERROR - FORMAT STATEMENT NUMBER, EITHER OCCURRED
	.SIXBT	'ST9'	/ ON A FORMAT OR IN A I/O STATEMENT
/
/
/ WE HAVE A LOGICAL 'IF' STATEMENT
/  CHECK IF WE HAVE ' IF(LOG) IF(LOG) . . .'
LOGICL	LAC	IFSW
	SPA
	JMP	ERRIF0
	LAC	IFSTAT	/ GET INTERNAL STATEMENT NUMBER
	DAC*	VANTED
	ISZ	IFSTAT
	LAC	(STNUM
	JMS*	CALCP	/ ENTER IN SYMBOL TABLE
	LAC*	OPLACE	/ GET ABSOLUTE ADDRESS OF ENTRY
	DAC	IFSTOR	/ STORE IT UNTIL CONDITIONAL CODE IS PROCESSED
	LAC	(IFLN*M
	ISZ	IFTEMP
	LAC	(IFL*M	/ LOGICAL 'IF' CODE
	XOR*	TBADDR	/ INSERT RELATIVE OTABLE ADDRESS
	JMS*	ITEM4	/ CODE 04
/
	LAW	-1
	DAC	IFSW
	LAC*	EQSWL
	DAC*	EQSWT
	JMS*	STLINE	/ SET UP FOR A NEW STATEMENT
	LAC*	CHINXT	/ GET CHARACTER AFTER ')'
AGCH	SAD	(ENDST
	JMP*	PROCES
	DAC*	BOX
	JMS*	INSERT
	JMS*	GETCHI
	JMP	AGCH
	.EJECT
/
/ THE FOLLOWING SECTION HANDLES THE READ AND WRITE STATEMENTS OF FORTRAN
/ IT ALLOWS FREE FORMAT
/ ENTRANCE FOR PRINT,  PRINTN  PRINTN,  PUNCH,  PUNCHN  PUNCHN, 
/ AND READ,  READN  READN,
READ.	LAC	(READS*M+5	/ DEFAULT DEVICE NUMBER = 5
	JMP	PUNCH.+1
PRINT.	LAC	(WRITES*M+6	/ DEFAULT DEVICE NUMBER = 6
	JMP	PUNCH.+1
PUNCH.	LAC	(WRITES*M+7	/ DEFAULT DEVICE NUMBER = 7
	JMS	STRAIT	/ SETS UP OPCODE, SAVES AC IN STARTP
	LAC	OLDCHR
	AND	(7
	JMS*	HIDCON	/ HIDE THE CONSTANT AWAY
	DAC*	AD2	/ GET UNIT # BACK, STORE FOR CDEV
	JMS	CDEV	/ ISSUE DEVICE REQUEST
	DZM*	CLUES
	JMS*	PUNCH	/ PUNCH OUT OPCODE+ UNIT #
/ NOW SORT OUT PRINT, PRINTN AND PRINTN,
	LAC*	CHINXT
	SAD	(COMMA
	JMP	FRFORM	/ WAS FREE FORMAT
/ WAS FORM PRINTN OR PRINTN,
	JMS	PROFRM	/ PROCESS FORMAT NUMBER
	JMS*	ITEM4	/ PUNCH OUT STATEMENT # ADDRESS
	LAC*	CHINXT	/ GET TERMINATING CHARACTER
	SAD	(COMMA
	JMP	FRFOR1	/ ITS FORM PRINTN,
	SAD	(ENDST
	JMP	PROLS0	/ ITS FORM PRINTN;
	JMP	ERRIOF	/ ANY OTHER DELIMITER IS ILLEGAL
/ WAS FREE FORMAT PRINT,
FRFORM	CLA
	JMS*	ITEM4
FRFOR1	JMS*	GETCHI	/ STEP PAST COMMA (COMES HERE FROM UNWIND ALSO)
	JMP	PROLS1	/ GO PROCESS I/O LIST
/
/ ENTRANCE FOR READ(N,M)  ,  WRITE(N,M)  ,  READ (N,*)   ,  WRITE(N,*)
READBR	LAC	(READS*M
	SKP
WRITEB	LAC	(WRITES*M
	JMS	STRAIT
/ PROCESS THE DEVICE NUMBER
	LAW	EXPILL!NOSTEP
	JMS*	EXPRES
	.DSA	DODEV	/ ,
	.DSA	ERRIOF	/ =
	.DSA	ERRIOF	/ ;
	.DSA	DODEV	/ )
/
/ NOW CHECK DEVICE NUMBER. IT MAY BE INTEGER CONSTANT, SINGLE
/ OR DOUBLE INTEGER VARIABLE, OR A CHARACTER VARIABLE OR ARRAY.
/
DODEV	LAC	OLDCHR		/SET UP 'READ' ETC. OP CODE
	AND	(770000
	DAC*	OPCODE
	DZM	OLDCHR
	DZM*	CLUES
	LAC*	CLEW2	/ GET CLUE BITS ABOUT DEVICE NUMBER
	AND	(37
	SAD	(CONBIT!SINTGM
	JMP	CONDEV	/ SINGLE INTEGER CONSTANT
	SAD	(CHARM
	JMP	CHRDEV	/ CHARACTER DEVICE (NO DEVICE REQUESTS)
	SAD	(SINTGM
	JMP	ALLDEV	/ SINGLE INTEGER VARIABLE, REQUEST ALL DEVICES
	SAD	(DINTGM
	JMP	ALLDEV	/ DOUBLE INTEGER VARIABLE, REQUEST ALL DEVICES
ERRIOD	JMS*	ERRORS	/ ERROR - ILLEGAL UNIT NUMBER
	.SIXBT	'IOD'
/ DEVICE NUMBER WAS INTEGER VARIABLE, REQUEST ALL DEVICES
ALLDEV	LAW	-1
	DAC	DEVICE
CHRDEV	LAC*	AD2	/ ADDRESS OF VARIABLE
	DAC*	DRESS
	SKP
/ DEVICE NUMBER WAS CONSTANT
CONDEV	JMS	CDEV	/ CHECK IF CONSTANT WITHIN RANGE
	JMS*	PUNCH	/ PUNCH OUT OPCODE + UNIT #
/
/ HAVE PROCESSED DEVICE NUMBER AND PUNCHED OUT OPCODE
/ NOW HAVE THE CONDITIONS: BINARY- (N) OR (N,END=...,ERR=..)
/ 			   FREE FORMAT- (N,*) OR (N,*,END=..,ERR=..)
/                          FORMAT I/O- (N,M) OR (N,M,END=..,ERR=..)
/ THE ONLY DELIMITERS ALLOWED WHERE ')' OR ','  .
	LAC*	CHINXT	/ GET LAST DELIMITER
	SAD	(CLOSE	/ WAS IS ')'
	JMP	IOLST0	/ YES.  OUT GOES (N)  BINARY.
	JMS*	GETCHI	/ MUST HAVE BEEN ',' , STEP PAST IT.
	SAD	(STAR	/ IS CHAR '*'
	JMP	DITCH	/ YES. MUST BE (N,*), OUT IT GOES FOR NOW.
/
/ NOW HAVE LEFT (N,M) OR (N,M,END=..,ERR=..)
/            OR (N,END=..,ERR=..)
	JMS	GETENT	/ GET NEXT ELEMENT (RETURNS .+1 OR .+2)
	JMP	FORMTD	/ RETURNS HERE ON DELIMITERS ',' OR ')' OR ILLEGAL
/
/ MUST BE (N,END=..,ERR=..) TYPE.  (RETURNS HERE ON DELIMITER '=')
	JMS	PROSEE	/ GO PROCESS END= AND/OR ERR=
	JMP	IOLST0	/ CARRY ON.
/
/ MUST BE (N,M) OR (N,M,END=..,ERR=..) TYPE
FORMTD	JMS	PREFMT	/ SNEAK IN TO PROFRM SUBROUTINE AND PROCESS FORMAT #
JOIN1	LAC*	CHINXT	/ GET DELIMITER, (N*) REENTERS HERE
	SAD	(CLOSE
	JMP	JOIN2	/ IT WAS (N,M) OR (N,*)
	SAD	(COMMA
	SKP
	JMP	ERRIOF	/ ILLEGAL TERMINATOR
/
/ MUST HAVE (N,M,END=..,ERR=..) OR (N,*,END=..,ERR=..)
	JMS*	GETCHI	/ STEP PAST ','
	JMS	GETENT	/ GET NEXT ELEMENT
	JMP	ERRIOF	/ SHOULD HAVE BEEN A '=' DELIMITER
	JMS	PROSEE	/ ENDED ON '='. GO PROCESS END= AND/OR ERR= .
JOIN2	LAC	OLDPLC	/ GET ADDRESS OF FORMAT SAVED BY PREFMT
	JMS*	ITEM4	/ PUNCH OUT FORMAT ADDRESS
	JMP	PROLST	/ CARRY ON
/
/ THIS SUBROUTINE PICKS UP THE NEXT ELEMENT.  IF THE TERMINATING
/ CHARACTER WAS A '=' IT INCREMENTS THE RETURN ADDRESS.
GETENT	XX
	CLA		/ ACCEPT ANYTHING
	JMS*	SEARCH
	LAC*	CHINXT
	SAD	(REPLAC	/ IS CHAR '='
	ISZ	GETENT
	JMP*	GETENT
/
/ THIS SUBROUTINE PROCESSES EXPECTED END= AND/OR ERR=  . ONLY ONE
/ OCCURRENCE OF EACH IS ALLOWED AND TERMINATING CONDITIONS ARE CHECKED.
/ THE ERR= CONDITION IS PROCESSED AND IGNORED. THE END= CONDITION IS
/ PROCESSED AND THE CORRECT ITEM PUNCHED OUT.
PROSEE	XX
	DZM	LEVEL
	DZM	OLDCHR
PRO1	LAC*	VANTED
	SAD	(EE*100+NN*100+DD	/ HAVE WE END
	JMP	LOKEND
	SAD	(EE*100+RR*100+RR	/ HAVE WE ERR
	JMP	LOKERR
ERRIOH	JMS*	ERRORS		/ EXPECTING 'ERR=' OR 'END='; FOUND
	.SIXBT	'IOH'		/ OTHER CHARACTERS INSTEAD.
/ LOOKS LIKE WE HAVE 'ERR='
LOKERR	LAC	OLDCHR
	JMS	CHKRST
	ISZ	OLDCHR
	JMP	JOIN3
/ LOOKS LIKE 'END='
LOKEND	LAC	LEVEL
	JMS	CHKRST
	ISZ	LEVEL
	LAC*	TBADDR	/ GET OTABLE ADDRESS
	XOR	(400000
	JMS*	ITEM4
/ THE ONLY VALID TERMINATORS NOW ARE ')' AND ','
JOIN3	LAC*	CHINXT
	SAD	(CLOSE
	JMP*	PROSEE	/ ALL DONE, WAS ')'
	SAD	(COMMA
	SKP
	JMP	ERRIOH
	JMS*	GETCHI	/ STEP PAST ','
	JMS	GETENT	/ GET NEXT ELEMENT
	JMP	ERRIOH	/ SHOULD BE '='
	JMP	PRO1	/ WAS '='
/
/ THIS SUBROUTINE PERFORMS SOME CHECKS AND PROCESSES THE STATEMENT
/ NUMBER
CHKRST	XX
	SZA
	JMP	ERRIOI	/ ATTEMPT AT TWO END= OR ERR=
	LAC*	VANT1
	SZA
	JMP	ERRIOH
	JMS*	GETCHI	/ STEP PAST '='
	LAC	(INTGRS
	JMS*	SEARCH
	LAC	(STNUM
	JMS*	CALCP
	LAC	(TRAN.
	JMS	SHOVE
	JMP*	CHKRST
/
/ IT WAS A SNEAKY FREE FORMAT
DITCH	JMS*	GETCHI	/ STEP PAST *
	DZM	OLDPLC	/ MARK AS FREE FORMAT
	JMP	JOIN1
/
/ THIS SUBROUTINE PERFORMS THE HIERARCHY CHECK, SETS UP THE OPCODE
/ AND CHECKS FOR NO I/O LIST.
STRAIT	XX
	DAC	OLDCHR	/ SAVE AC INFO
	LAW	H5!.EXC
	JMS*	HIERAR
	LAC	OLDCHR	/ REGAIN INFO
	AND	(770000
	DAC*	OPCODE	/ SET UP OPCODE
	JMS*	GETCHI
	SAD	(ENDST
	SKP
	JMP*	STRAIT
ERRIO7	JMS*	ERRORS	/ ERROR - NO FORMAT # OR I/O LIST
	.SIXBT	'IO7'
/
/ CHECK IF UNIT # IS VALID AND RECORD DEVICE REQUESTS
CDEV	XX
	LAC*	VANTED	/ GET CONSTANT
	TAD	(LRS!CLQ  0	/ BUILD UP SHIFT TO RECORD DEVICE REQUEST
	DAC	MAKE
	LAC*	VANTED	/ GET & CHECK CONSTANT
	SPA!SNA!STL
	JMP	ERRIOD	/ ERROR - ILLEGAL DEVICE NUMBER
	TAD	(-11
	SMA!CLA!RAL	/ AC=1
	JMP	ERRIOD	/ ERROR - ILLEGAL DEVICE NUMBER
MAKE	XX
	LAC	DEVICE
	OMQ		/ 'OR' IN NEW DEVICE REQUEST
	DAC	DEVICE
	LAC*	AD2
	DAC*	DRESS	/ SET UP FOR PUNCH
	JMP*	CDEV
/
/
/ THIS SUBROUTINE PROCESSES THE FORMAT NUMBER. IT MAY BE A FORMAT
/ STATEMENT OR AN ARRAY.
/ THE ROUTINE IS ENTERED AT PREFMT IF THE CALL TO SEARCH HAS ALREADY
/ BEEN DONE.
PREFMT	XX
	LAC	PREFMT
	DAC	PROFRM
	JMP	SNEAK
PROFRM	XX
	CLA
	JMS*	SEARCH	/ ACCEPT ANYTHING FROM SEARCH
SNEAK	LAC*	FLTFLG
	SAD	(CONBIT!SINTGM
	JMP	STATE	/ ITS A STATEMENT NUMBER
	AND	(CONBIT
	SZA
	JMP	ERRIO6	/ ANY OTHER TYPE OF CONSTANT IS ILLEGAL
/
	LAC	(VARIAB
	JMS*	CALCP	/ ENTER VARIABLE IN SYMBOL TABLE
	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(DIMENS
	SZA		/ MUST BE AN ARRAY
	JMP	PROJN	/ IT IS AN ARRAY
ERRIO6	JMS*	ERRORS	/ ERROR - ILLEGAL FORMAT TYPE
	.SIXBT	'IO6'
/
/ ITS A STATEMENT NUMBER, PROCESS IT.
STATE	LAC	(STNUM
	JMS*	CALCP	/ ENTER IN SYMBOL TABLE
	LAC*	BITPTR
	AND	(000077\FORM\.IOPUT
	SZA
	JMP	ERRIO2
	LAC	(.IOPUT	/ MARK AS OCCURRING IN A I/O STATEMENT
	JMS	SHOVE
PROJN	LAC*	TBADDR	/ GET OTABLE ADDRESS OF STATEMENT NUMBER
	DAC	OLDPLC	/ SAVE IT
	JMP*	PROFRM
/
/
/ THIS SECTION PROCESSES THE I/O LIST FOR ALL THE I/O STATEMENTS
IOLST0	LAC*	CLEW2
	AND	(37
	SAD	(CHARM
	JMP	ERRIOK	/ ERROR - BINARY INTO CHARACTER
	LAC	(400000	/ MARK AS BINARY I/O
IOLST	JMS*	ITEM4	/ PUNCH OUT 2ND WORD
PROLST	JMS*	GETCHI
PROLS0	SAD	(ENDST
	JMP	CFINSH
PROLS1	DZM	LEVEL
	LAW	-4
	TAD*	CHIEND
	DAC	IMPTAB
	DAC	OLDPLC
	LAC*	CHINXT
IENTER	SAD	(OPEN
	JMP	IMPLDO	/ LOOKS LIKE AN IMPLIED DO COMING UP
	JMS	PRVARB
	LAC*	CHINXT	/ GET TERMINATING CHAR
	SAD	(ENDST
	JMP	CFINSH	/ END OF STATEMENT
	JMS*	GETCHI	/ STEP PAST LAST CHAR
	JMP	IENTER
/ END OF LIST IS ENCOUNTERED. COMPILE FINISH OPCODE AND EXIT
CFINSH	LAC	(IODONE*M
	JMS*	ITEM4
R13	EXIT
/
ERRIO2	JMS*	ERRORS
	.SIXBT	'IO2'
ERRIO3	JMS*	ERRORS
	.SIXBT	'IO3'
ERRIOJ	JMS*	ERRORS
	.SIXBT	'IOJ'
ERRIOF	JMS*	ERRORS
	.SIXBT	'IOF'
ERRIOI	JMS*	ERRORS	/ ERROR - ATTEMPT AT TWO END= OR ERR=
	.SIXBT	'IOI'
ERRIOK	JMS*	ERRORS
	.SIXBT	'IOK'
/
/
/
/ HAVE FOUND A '(' , IT MUST BEGIN A DO LOOP. BUILD UP IMPLIED DO
/ LOOP TABLES.
IMPLDO	LAC	OLDPLC
	TAD	(4
	DAC	OLDPLC
	JMS	CENTRY
	TAD	(1
	DAC*	CHIEND	/ RESET UP CHIEND TO PROTECT TABLE ENTRY
	ISZ	LEVEL	/ STEP UP A LEVEL
	LAC	LEVEL
	DAC*	LEVELP	/ STORE IN TABLE
	JMS	GETPLC	/ GET CURRENT POSITION
	DAC*	OPENP	/ STORE POSITION OF '('
	DZM*	COMMAP
	DZM*	SEMIPT
/
/ SEARCH THE INPUT STRING FOR THE FOLLOWING CHARACTERS. A '(' MAY
/ BEGIN AN IMPLIED DO ONLY IF IT IS PRECEDED BY A '(' OR ','
SVCHAR	LAC*	CHINXT
SVCHR1	DAC	OLDCHR	/ SAVE LAST CHAR
	JMS*	GETCHI	/ GET NEXT ONE
	SAD	(OPEN
	JMP	CHKIMD	/ CHAR IS '('
	SAD	(APOST
	JMP	QUOTE	/ CHAR IS "'"
	SAD	(COMMA
	JMP	ITCOM	/ CHAR IS ','
	SAD	(CLOSE
	JMP	ERRIO3	/ CHAR IS ')'
	SAD	(REPLAC
	SKP		/ CHAR IS '='
	JMP	SVCHAR	/ NONE OF THE ABOVE
/
/ HAVE FOUND A '=' . SCAN THROUGH TO ')'
	LAC*	COMMAP
	SNA		/ HAVE WE HAD A ','
	JMP	ERRIO3	/ ERROR - NO ',' ENCOUNTERED BEFORE '='
GETCLS	JMS*	GETCHI	/ GET NEXT CHAR
	SAD	(CLOSE
	SKP
	JMP	GETCLS
	JMS	GETPLC	/ GET POSITION OF ')'
	DAC*	SEMIPT
	JMS*	REPLCE	/ REPLACE WITH ';'
	LAC*	LEVELP
	SAD	(1
	JMP	PROIMD	/ GO PROCESS IMPLIED DO
	LAW	-1	/ NOT LEVEL 1
	TAD	LEVEL
	DAC	LEVEL	/ DECREMENT LEVEL
	JMS	BACKS	/ BACK DOWN THE TABLE TO ENTRY AT THIS LEVEL
	JMP	SVCHAR
/
/ HAVE FOUND A '(' . IF NOT AN IMPLIED DO, SCAN FOR THE CLOSING ')' .
CHKIMD	LAC	OLDCHR
	SAD	(OPEN
	JMP	IMPLDO	/ MUST BEGIN AN IMPLIED DO
	SAD	(COMMA
	JMP	IMPLDO	/ MUST BEGIN AN IMPLIED DO
GETCL1	JMS*	GETCHI	/ SCAN FOR ')'
	SAD	(CLOSE
	JMP	SVCHR1	/ FOUND ')'
	JMP	GETCL1	/ NOT ')' , TRY AGAIN
/
/ HAVE FOUND A "'" . SKIP TO THE END OF IT
QUOTE	JMS*	GETCHI
	SAD	(APOST
	JMP	SVCHAR
	JMP	QUOTE
/
/ HAVE FOUND A ','
ITCOM	JMS	GETPLC
	DAC*	COMMAP	/ STORE POSITION OF COMMA
	JMP	SVCHAR
/
/ PROCESS THE IMPLIES DO LOOP AND PUNCH OUT THE CODE
PROIMD	LAC	IMPTAB	/ SET UP TO 1ST ENTRY
	SKP
NEWNTY	LAC	NXPLC
	TAD	(4
	DAC	NXPLC
	JMS	CENTRY	/ SET POINTERS TO NEW ENTRY
/
/ PROCESS THE DO SECTION
	LAC*	COMMAP
	JMS	RETPLC	/ SET UP TO POSITION OF ','
	JMS	PRODOS	/ PROCESS THE DO LOOP
	LAC*	OPENP
	JMS	RETPLC	/ RESET TO '('+1
CHKOP	SAD	(OPEN	/ IS NEXT CHAR '('
	JMP	NEWNTY	/ A NEW IMPLIED DO
/
/ WE DO NOT HAVE A '(' . THUS PROCESS THE EXPRESSION
	LAC*	LEVELP	/ SET TO CURRENT LEVEL
	DAC	LEVEL
PROV	JMS	PRVARB
	LAC*	CHINXT	/ GET TERMINATING CHAR
	SAD	(COMMA
	SKP
	JMP	ERRIO3	/ ERROR - NOT COMMA
/
/ CHECK IF COMMA PRECEDES DO PARAMETERS ,I=J,K,L
CPRECD	JMS	GETPLC	/ GET POSITION OF THIS ','
	SAD*	COMMAP
	JMP	UNWIND	/ IT DOES
	JMS*	GETCHI	/ NO. STEP PAST ','
	JMP	CHKOP	/ GO CHECK IF NEXT CHAR BEGINS A IMPLIED DO
/
/ THE ',' PRECEDES THE DO PARAMETERS
UNWIND	LAW	-1
	JMS	ENDDO	/ UNWIND ONE DO LOOP
	LAC*	SEMIPT
	JMS	RETPLC	/ SKIP OVER PARAMETERS TO )+1
	SAD	(ENDST	/ IS IT END OF STATEMENT
	JMP	CFINSH	/ YES
	SAD	(COMMA	/ NO. IS IT COMMA
	SKP
	JMP	ERRIO3	/ ILLEGAL TERMINATOR AFTER ')'
	LAC*	LEVELP	/ GET LEVEL
	SAD	(1	/ HAVE WE UNWOUND THE LAST IMPLIED DO?
	JMP	FRFOR1	/ YES. END OF THIS IMPLIED DO SET
	TAD	(-1
	DAC	LEVEL	/ GO DOWN A LEVEL
	JMS	BACKS	/ THIS DO LOOP SET NOT FINISHED
/ POSSIBLE CONDITIONS ARE ((A(I,J),I=1,K),J=1,L) AND
/ ((A(I,J),I=1,K),.........,J=1,L)
	JMS	GETPLC
	SAD*	COMMAP
	JMP	UNWIND	/ IT IS ((AI,J),I=1,K),J=1,L)
/ MUST BE THE FORM ((A(I,J),I=1,K),.....,J=1,L)
	JMS*	GETCHI	/ STEP PAST ','
	JMP	CHKOP
/
/
/
/ THIS SUBROUTINE ADVANCES THE POINTERS EITHER UP OR DOWN
/ THE TABLE
CENTRY	XX
	DAC	LEVELP
	TAD	(1
	DAC	OPENP
	TAD	(1
	DAC	COMMAP
	TAD	(1
	DAC	SEMIPT
	JMP*	CENTRY
ERRIOL	JMS*	ERRORS
	.SIXBT	'IOL'
/
/ THIS SUBROUTINE BACKS DOWN THE TABLE LOOKING FOR AN ENTRY
/ AT A CERTAIN LEVEL
BACKS	XX
BACK1	LAW	-4
	TAD	LEVELP
	JMS	CENTRY
	LAC*	LEVELP
	SAD	LEVEL
	JMP*	BACKS	/ ENTRY FOUND
	JMP	BACK1	/ TRY NEXT ONE DOWN
/
/
/ THIS SUBROUTINE CRUNCHES THE ADDRESS OF A CHARACTER IN
/ THE CHI TABLE INTO ONE WORD FOR THE IMPLIED DO TABLE
GETPLC	XX
	LAC*	IND
	SZA
	LAC	(400000
	TAD*	INDEX
	JMP*	GETPLC
/
/
/ THIS SUBROUTINE RESETS THE CHI POINTERS
RETPLC	XX
	SPA!CLL
	STL		/ SET LINK IF AC0=1
	AND	(077777
	DAC*	INDEX
	SZL!CLA
	CLC
	DAC*	IND
	JMS*	GETCHI	/ GET CHARACTER AFTER THE CURRENT ONE
	JMP*	RETPLC
/
/
/ THIS SUBROUTINE PROCESSES VARIABLES IN THE INPUT OR OUTPUT LISTS
PRVARB	XX
	LAW	NOSTEP
	JMS*	EXPRES
	.DSA	TAIL
	.DSA	ERRIOJ
	.DSA	TAIL
	.DSA	TAIL
TAIL	LAC*	CLEW2
	DAC*	CLUES
	AND	(INACC!INVERT
	SNA			/DID WE HAVE AN EXPRESSION?
	JMP	NOTEXP		/NO
	SAD	(INVERT		/IS ITEM NOT IN AC BUT REQUIRES INVERSION?
	SKP
	JMP	STREXP		/HAVE EXPRESSION
	LAC	(INACC
	XOR*	CLEW2		/MARK RESULT AS BEING IN ACCUMULATOR
	DAC*	CLEW2
	LAC*	AD2		/MUST LOAD AND STORE NEGATIVE
	DAC*	DRESS		/BECAUSE WE HAVE -(CONSTANT) OR
	LAC	(LOAD*M		/ -(VARIABLE)
	DAC*	OPCODE
	JMS*	PUNCH		/PUNCH OUT LOAD
/
/ HAD AN EXPRESSION, STORE IT
/
STREXP	LAC	CLEW2
	DAC*	ACCSW
	LAC*	CLEW2
	AND	(INVERT
	SZA!STL			/DO WE REQUIRE INVERSION?
	JMP	.+3
	LAC	(STORE*M	/YES. COMPILE STORE NEGATIVE
	SKP
	LAC	(STOREN*M		/YES.
	JMS*	TEMPA2	/ GET A TEMPORARY ACCUMULATOR, CLEAR ACC
	LAC	(TEMPER	/ TO FREE TEMPORARY ACC
	DAC*	CLUES	/ ON NEXT OPCODE
	JMP	SINGL	/ GO MARK AS A SINGLE VARIABLE
/ IT WAS NOT AN EXPRESSION
NOTEXP	LAC*	AD2
	DAC*	DRESS
	LAC*	CLEW2
	AND	(DIMMEN
	SNA
	JMP	.+3
	LAC	(GROUPS*M	/ GET ARRAY OPCODE
	SKP
SINGL	LAC	(SINVAR*M	/ GET SINGLE VARIABLE OPCODE
	DAC*	OPCODE
	JMS*	PUNCH	/ GO PUNCH OPCODE OUT
	JMP*	PRVARB
	.EJECT
ERRRT0	JMS*	ERRORS		/ TOO FEW RETURN POINTS FOR VARIABLE RETURN
	.SIXBT	'RT0'
ERRRT1	JMS*	ERRORS		/ ILLEGAL SYNTAX ON RETURN CODE
	.SIXBT	'RT1'
/
RETR	LAW	H5!.EXC
	JMS*	HIERAR
	LAC	IFSW	/ IF(...)RETURN,IS NOT UNCONDITIONAL TRANSFER
	SMA
	ISZ*	STATSW	/ ORDINARY RETURN
	LAC	KIND
	SAD	(MAINK	/ IF A MAINLINE PROGRAM, COMPILE AS 'STOP'
	JMP	STOP2
	SAD	(FUNK	/ OR IS IT A FUNCTION SUBPROGRAM ?
	JMP	RFUNK	/ YES.
/
/ WE MUST BE PROCESSING A SUBROUTINE SUBPROGRAM
	JMS*	GETCHI
	SAD	(ENDST
	JMP	RETURN	/ IT IS FORM 'RETURN'
/
/  IT MUST BE OF THE FORM 'RETURN I'
/  PROCESS THE CONSTANT OR VARIABLE
/
	LAW	EXPILL
	JMS*	EXPRES
	ERRRT1
	ERRRT1
	ROKAY
	ERRRT1
/
/  MUST BE POSITIVE SINGLE INTEGER CONSTANT, OR
/  SINGLE OR DOUBLE INTEGER VARIABLE
/
ROKAY	LAC*	CLEW2
	AND	(37!INVERT
	SAD	(SINTGM		/ IS IT SINGLE VARIABLE?
	JMP	RETRNV		/ YES.  LEGAL.
	SAD	(DINTGM		/ DOUBLE INTEGER VARIABLE?
	JMP	RETRNV		/ YES.  ALSO LEGAL.
	SAD	(CONBIT!SINTGM	/ SINGLE INTEGER CONSTANT?
	JMP	RETRNC
/
ERRRT2	JMS*	ERRORS		/ RETURN CODE MUST BE CORRECT MODE
	.SIXBT	'RT2'
/
/  PUNCH OUT OPCODE AND ADDRESS
/
RETRNV	LAC*	AD2
	DAC*	DRESS
	LAC*	CLEW2
	DAC*	CLUES
	LAC	(RTRNX*M
	DAC*	OPCODE
	JMS*	PUNCH
	LAC	RPCNT		/ GET # OF RETURN POINTS
	TAD	(6		/ ADD # OF STATIC ELEMENTS IN OTABLE
	JMS*	ITEM4
	EXIT
/
/  IT IS A SINGLE INTEGER CONSTANT.  CHECK IF IT IS WITHIN RANGE.
/
RETRNC	LAC*	VANTED
	CMA
	TAD	(1
	TAD	RPCNT
	SPA
	JMP	ERRRT0	/ ERROR # > # OF RETURN POINTS
	LAC*	VANTED
	TAD	(5	/ ADD (# OF STATIC ELEMENTS - 1) IN TABLE
	JMP	RETUR1
/
/ WE ARE PROCESSING A FUNCTION SUBPROGRAM
/ COMPILE 'LOAD 0006'
RFUNK	LAC	(LOAD*M+0006 	/ THERE ARE 6 SPECIAL ENTRIES AHEAD OF IT
	JMS*	ITEM4	/ CODE 04
/
/ COMPILE 'RTRN 0001'
RETURN	LAC	(0001
RETUR1	XOR	(RTRN*M
	JMS*	ITEM4	/ CODE 04
	EXIT
/
/
STOP	LAW	H5!.EXC
	JMS*	HIERAR
	LAC	IFSW	/ IF(...) STOP ,IS NOT UNCONDITIONAL TRANSFER
	SMA
	ISZ*	STATSW	/ ORDINARY STOP
STOP2	LAC	(LEAVE*M
	JMP	PAUSE1
/
/ PAUSE STATEMENT
.PAUSE	LAW	H5!.EXC
	JMS*	HIERAR
	LAC	(PAUSE*M
PAUSE1	DAC	COUNT
	DZM*	VANTED	/ ZERO VANTED IN CASE OF NO NUMBER, IE PAUSE;
	JMS*	GETCHI
	SAD	(ENDST	/ IS IT SIMPLE FORM, PAUSE; OR STOP;
	JMP	GOT	/ YES.
	LAC	(INTGRS	/ NO. MUST BE FORM, PAUSE N; OR STOP N;
	JMS*	SEARCH
	LAC*	VANTED	/ GET OCTAL NUMBER
	TAD	(-303237	/ 99999 DECIMAL = 303237 OCTAL
	SMA!SZA		/ IS NUMBER LARGER THAN 99999 DECIMAL
	JMP	ERRPA0
/
GOT	LAC	VANTED	/ GET VANTED'S ADDRESS
	JMS*	G.STPC	/ SET UP VANTED AS BUFFER FOR ASCII
	LAC	(1
	DAC*	NUMS	/ CONVERT 5 DIGITS TO ASCII
	CLL		/ STORE LEADING ZEROS
	LAC*	VANTED	/ GET INTEGER NUMBER
	JMS*	G.CVRT	/ CONVERT TO ASCII & PLACE IN VANTED
	LAC	(REALM
	DAC*	FLTFLG	/ INSERT ASCII AS REAL NUMBER
	LAC	(CONSTN
	JMS*	CALCP	/ ENTER IN SYMBOL TABLE
	LAC*	TBADDR	/ GET RELATIVE OTABLE ADDRESS
	XOR	COUNT	/ GET EITHER 'STOP' OR 'PAUSE' CODE
	JMS*	ITEM4	/ CODE 04
	LAC*	CHINXT
	SAD	(ENDST
	EXIT
ERRPA0	JMS*	ERRORS
	.SIXBT	'PA0'
/
/  WE ARE COMPILING '$TRACEON' (OP CODE 63) OR '$TRACEOFF' (OP CODE 64)
/
TRACON	LAW	H5!.EXC
	JMS*	HIERAR
	LAC	(TRCON*M
	JMS*	ITEM4
	LAC	(TRDV&777	/ I/O DEVICE FOR '$TRACEON'
	DAC*	ITEM
	LAC	(26
	JMS*	INSRT		/ GENERATE ' .IODEV TRDV'
	EXIT
/
TRACOFF	LAW	H5!.EXC
	JMS*	HIERAR
	LAC	(TRCOF*M
	JMS*	ITEM4
	EXIT
	.EJECT
/********************************************
/
/ THE FOLLOWING CODE HANDLES FUNCTION AND SUBROUTINE STATEMENTS
/
LOGICF	LAC	(LOGICM		/LOGICAL FUNCTION
	JMP	SETMDE
INTF	LAC	(SINTGM		/INTEGER FUNCTION
	JMP	SETMDE
DINTF	LAC	(DINTGM		/DOUBLE INTEGER FUNCTION
	JMP	SETMDE
REALF	LAC	(REALM		/REAL FUNCTION
	JMP	SETMDE
DREALF	LAC	(DBLEM		/DOUBLE PRECISION FUNCTION
	JMP	SETMDE
CMPLXF	LAC	(CMPLXM		/COMPLEX FUNCTION
	JMP	SETMDE
CHARF	LAC	(CHARM		/CHARACTER FUNCTION
/
SETMDE	DAC	MODE	/ MODE DEFINITION OVERRIDES IMPLICIT MODE
/ REGULAR FUNCTION ENTER HERE
FUNCT	LAC	(FUNK	/ MARK SUBPROGRAM AS A FUNCTION
	JMP	PROCS
/
/ SUBROUTINES ENTER HERE
SUBR	LAC	(SUBK
PROCS	DAC	KIND
	JMS*	GETCHI
	LAC	(NAME
	JMS*	SEARCH	/ GET SUBPROGRAM NAME
/ DO HIERARCHY CHECK AND SAVE THE SUBPROGRAM AS ASCII IN OTABLE
/ AND IN INTERNAL CODE FOR INTERNAL GLOBLING LATER
	LAW	H1!NON.EX
	JMS*	HIERAR
/
/ THE SUBPROGRAM NAME HAS NOW BEEN SAVED. IF IT IS A FUNCTION
/ ENTER THE FUNCTION NAME IN THE SYMBOL TABLE AS A VARIABLE
	DZM	RPCNT	/ MARK AS NO STATEMENT NUMBER ARGUMENTS YET
	LAC	KIND
	SAD	(SUBK	/ IS IT A SUBROUTINE
	JMP	ITSASB	/ YES.
/ SUBPROGRAM IS A FUNCTION
	LAC	MODE
	SZA		/ IF MODE IS SET IT OVERRIDES IMPLICIT MODE
	DAC*	FLTFLG
	LAC	(VARIAB
	JMS*	CALCP	/ ENTER NAME IN SYMBOL TABLE
	LAC	MODE
	SZA		/ WAS IT A TYPE FUNCTION
	LAC	(MODEST	/ YES. MARK MODE AS BEING SET
	XOR	(FUNNAM	/ MARK AS PROGRAM NAME
	JMS	SHOVE
	LAC*	CHINXT	/ GET NEXT CHARACTER
SJOIN	SAD	(STAR	/ IS IT '*'
	JMP	FUNTST	/ PROCESS THE MODE CHANGE
CHKOPN	SAD	(OPEN	/ IS IT '('
	JMP	PROARG	/ YES. GO PROCESS ARGUMENT STRING
	SAD	(ENDST	/ IS IT ';'
	JMP	ERRFN0	/ ERROR - MISSING ARGUMENT STRING
ERRFN1	JMS*	ERRORS	/ ERROR - ILLEGAL CHARACTER AFTER NAME
	.SIXBT	'FN1'
/ THE CHARACTER IS '*'. THIS IS ILLEGAL IN A SUBROUTINE AND NON-TYPE
/ FUNCTION SUBPROGRAM
FUNTST	LAC	MODE	/ IF MODE=0 THEN STATEMENT IS EITHER
	SNA		/ NON-TYPE FUNCTION OR SUBROUTINE
	JMP	ERRFN2	/ MODE CHANGE IS ILLEGAL IN BOTH
	JMS*	GETCHI	/ GET CHAR AFTER '*'
	LAC	(SIGNER!INTGRS	/ PICK UP WORD SIZE
	JMS*	SEARCH
	LAC	FN6	/ ERROR IN CASE MODE CHANGE ILLEGAL
	JMS	MODCHK	/ IS IT A LEGAL LENGTH
	LAC*	MODPTR	/ MUST BE, IT RETURNED
	AND	(777760	/ REMOVE OLD MODE
	XOR	MODE	/ INSERT NEW MODE
	DAC*	MODPTR
	LAC*	CHINXT
	JMP	CHKOPN
/
/ SUBPROGRAM IS A SUBROUTINE
ITSASB	ISZ	HEADER	/ SET HEADER FOR NO ARG SUBROUTINE
	LAC*	CHINXT
	SAD	(ENDST
	EXIT		/ ITS A NO ARGUMENT SUBROUTINE
	JMP	SJOIN	/ EITHER HAS ARGUMENTS OR ITS AN ERROR.
/
/ THE SUBPROGRAM HAS AN ARGUMENT LIST, PROCESS IT
PROARG	LAC	(10	
	DAC	HEADER	/ SET HEADER TO BASIC SUB WITH ARG SIZE
PROAR1	JMS*	GETCHI	/ GET NEXT CHARACTER
	SAD	(STAR	/ IS IT THE '*' FOR A STATEMENT NUMBER?
	JMP	PROSTA	/ YES. PROCESS STATEMENT NUMBER
	LAC	(NAME	/ NOT STATEMENT NUMBER, GET NAME
	JMS*	SEARCH
	LAC	(VARIAB
	JMS*	CALCP
	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(FORMAL!FUNNAM
	SAD	(FORMAL	/ WAS ARGUMENT IN STRING ALREADY
	JMP	ERRFN3	/ YES.
	SAD	(FUNNAM	/ IS ARGUMENT SAME AS PROGRAM NAME
	JMP	ERRFN8	/ YES.
	LAC	(FORMAL!NOHERE	/ IST TIME FOR ARGUMENT
	JMS	SHOVE	/ ENTER CONTROL BITS
	JMS*	DLOTAB	/ RESCIND OTABLE ENTRY FOR ARGUMENT
	ISZ*	DTNEXT	/ GET EXTRA WORD FOR A FORMAL PARAMETER IN
			/ CASE IT'S A CHARACTER VARIABLE.
AGSUB2	LAC	MODPTR
	DAC*	BASE1
	ISZ	BASE1	/ ADVANCE TO NEXT WORD
	ISZ	HEADER	/ COUNT THE ARGUMENTS
	LAC*	CHINXT	/ RETRIEVE LAST CHARACTER
	SAD	(COMMA	/ WAS IT ','
	JMP	PROAR1	/ YES. GO AFTER NEXT ARGUMENT
/
	SAD	(CLOSE	/ IS IT ')'
	SKP
	JMP	ERRFN1
	JMS*	GETCHI
	SAD	(ENDST	/ IS IT END OF STATEMENT
	SKP
	JMP	ERRFN1
	LAW	-1
	DAC*	BASE1	/ INSERT END OF FORMAL PARAMETER LIST INDICATOR
	ISZ	BASE1
	LAC	RPCNT
	SNA		/ WERE THERE '*' STATEMENT # ARGUMENTS
	JMP	REINCR
	LAC	KIND	/ YES.
	SAD	(SUBK	/ ARE WE PROCESSING A SUBROUTINE?
	JMP	REINCR
ERRFN5	JMS*	ERRORS	/ MULTIPLE RETURNS ILLEGAL IN FUNCTIONS
	.SIXBT	'FN0'
REINCR	LAC	BASE1
	DAC*	BASE2	/ PROTECT FORMAL PARAMETERS BY ADVANCING POINTER
	DAC*	BASE3
	EXIT
/
/
PROSTA	ISZ	RPCNT	/ COUNT STATEMENT NUMBERS
	LAC	IFSTAT	/ GET AN INTERNAL STATEMENT NUMBER
	DAC*	VANTED	/ TO PREVENT CLASH WITH 00000
	ISZ	IFSTAT	/ INCREMENT INTERNAL NUMBER
	LAC	(STNUM
	JMS*	CALCP
	JMS*	GETCHI	/ STEP PAST *
	LAC	BITPTR
	TAD	(STOTB*100000
	JMP	AGSUB2+1
/
FN6	.SIXBT	'FN6'
/
ERRFN0	JMS*	ERRORS	/ ERROR- NO ARGUMENT LIST FOR FUNCTION
	.SIXBT	'FN0'
ERRFN2	JMS*	ERRORS	/ ERROR- TYPE CHANGE ILLEGAL HERE
	.SIXBT	'FN2'
ERRFN3	JMS*	ERRORS	/ ERROR- REPEATED ARGUMENT IN PARAMETER LIST
	.SIXBT	'FN3'
ERRFN8	JMS*	ERRORS	/ ERROR- ARGUMENT NAME SAME AS SUBPROGRAMS
	.SIXBT	'FN8'
	.EJECT
/
/
/ TABLE TO ALLOW CHECKING OF MODE CHANGES WITHIN SPECIFICATION
/  STATEMENTS. GENERAL FORM IS : 'MODE + WORD SIZE'
/
L.2.4	LOGICM*10000+2
	LOGICM*10000+4
I.2	SINTGM*10000+2
I.4	DINTGM*10000+4
	SINTGM*10000+2
W1	.DSA 0
	.DSA 0
R.4	REALM*10000+4
	DBLEM*10000+10
R.8	DBLEM*10000+10
	REALM*10000+4
W2	.DSA 0
	.DSA 0
W3	.DSA 0
	.DSA 0
C.8	CMPLXM*10000+10
	DCMPXM*10000+20
W4	.DSA 0
	.DSA 0
C.16	DCMPXM*10000+20
	CMPLXM*10000+10
/
/ THIS SUBROUTINE CHECKS FOR LEGAL CHANGES OF WORD LENGTHS
MODCHK	XX
	DAC	ERRSP+1
	LAC	MODE
	SAD	(CHARM
	JMP	MODCHM
	TAD	(-1	/ USE TABLE TO CHECK MODE.
	RCL		/ -1 * 2
	TAD	(L.2.4	/ ADD START ADDRESS OF TABLE
	DAC	TEMP	/ TO GET CORRECT ENTRY
	LAC*	TEMP	/ GET CONTENTS
	AND	(000077	/ REMOVE MODE BITS
	SAD*	VANTED	/ IS IT THE SAME AS THE NUMBER IN VANTED
	JMP*	MODCHK	/ MODES ARE THE SAME, RETURN.
/
	ISZ	TEMP	/ TRY 2ND WORD
	LAC*	TEMP
	AND	(000077	/ REMOVE MODE BITS
	SAD*	VANTED
	SKP
	JMP	ERRSP	/ NO MATCH , COMBINATION ILLEGAL
	LAC*	TEMP
	CLL
	LRS	14
	DAC	MODE
	JMP*	MODCHK
/ CHECK IF CHARACTER SIZE IS WITHIN RANGE
MODCHM	JMS	CHKRNG	/ GO CHECK THE RANGE OF THE INTEGER
	LAC*	VANTED
	DAC*	CPOINT	/ SIZE VALID, OVERRIDE STATEMENT CHAR SIZE IN DTABLE
	JMP*	MODCHK
ERRSP	JMS*	ERRORS
	XX		/ THE SIXBIT CODE IS PLACED HERE
/
SP1	.SIXBT	'SP1'
/
/ THIS SUBROUTINE CHECKS THE RANGE OF CHARACTER DECLARACTIONS
CHKRNG	XX
	LAC*	VANT1
	SZA		/ 2ND WORD MUST BE ZERO
	JMP	ERRSP6	/ SIZE TOO LARGE
	LAC*	VANTED
	SNA
	JMP	ERRSP6	/ SIZE IS ZERO
	TAD	(-400	/ 256
	SMA!SZA
	JMP	ERRSP6	/ ERROR - SIZE > 256
	JMP*	CHKRNG
/
/
/ TABLE CONTAINS THE # OF WORDS STORAGE REQUIRED FOR DIFFERENT
/  TYPES OF VARIABLES.THIS TABLE IS ACCESSED WHEN WE ARE BUILDING
/  UP DIMENSION TABLES AND ASSIGNING ADDRESS & SIZES
SIZETB	.DSA	1	/ LOGIC
	.DSA	1	/ SINGLE INTEGER
	.DSA	2	/ DOUBLE INTEGER
	.DSA	15	/ UNKOWN - TEMPORARY ACCUMULATOR
	.DSA	2	/ REAL
	.DSA	4	/ DOUBLE REAL
	.DSA	0	/ BLANK
	.DSA	0	/ BLANK
	.DSA	4	/ COMPLEX
	.DSA	0	/ BLANK
	.DSA	10	/ DOUBLE COMPLEX
/
/
/ THIS SUBROUTINE GETS THE WORD SIZE FORM THE ABOVE TABLE
/  TAKING THE MODE FROM THE DTABLE AND LEAVES THE
/  WORD SIZE IN AC.
WDSIZE	XX
	AND	(17	/ GET MODE
	SAD	(CHARM
	JMP	WDCHAR
	TAD	(SIZETB-1
	DAC	TEMP	/ POINTS TO WORD SIZE
	LAC*	TEMP	/ GET WORD SIZE IN AC
	JMP*	WDSIZE
/ NOW GET THE NUMBER OF  WORDS FOR A CHARACTER ELEMENT
WDCHAR	LAC*	CPOINT
	TAD	(2
	RCL
	IDIV
		5
	LACQ
	JMP*	WDSIZE
/
/
/ THIS SUBROUTINE INSERTS CONTROL BITS FROM THE AC INTO WHERE-EVER
/  BITPTR POINTS.
SHOVE	XX
	LMQ		/ SAVE BITS IN MQ
	LAC*	BITPTR	/ LOAD CONTROL BITS
	OMQ		/ OR NEW BITS IN
	DAC*	BITPTR
	JMP*	SHOVE
/
/ THIS SUBROUTINE REMOVES THE CONTROL BITS CORRESPONDING TO
/  THOSE IN THE AC FORM WHERE-EVER BITPTR POINTS
PULL	XX
	CMA
	AND*	BITPTR	/ REMOVE THAT BIT
	DAC*	BITPTR	/ REPLACE CONTENTS
	JMP*	PULL
/
BASE1			/ CONTAINS START ADDRESS FOR DATA STORAGE
SAVCMN		/ SAVES POINTER TO START OF COMMON ENTRY
/
/
/ LOGIC
LOGIC	LAC	(LOGICM
	JMP	SPECS3
/ INTEGER
INTGR	LAC	(SINTGM
	JMP	SPECS3
/ DOUBLE INTEGER
DBLINT	LAC	(DINTGM
	JMP	SPECS3
/ REAL
REAL	LAC	(REALM
	JMP	SPECS3
/ DOUBLE REAL
DBLREL	LAC	(DBLEM
	JMP	SPECS3
/ COMPLEX
COMPLX	LAC	(CMPLXM
	JMP	SPECS3
/ DOUBLE COMPLEX
DBCPLX	LAC	(DCMPXM
	JMP	SPECS3
/CHARACTER. A SPECIAL CASE DUE TO THE LARGER DTABLE ENTRY. IF A DTABLE
/ ENTRY HAS BEEN ASSIGNED WITH OTHER THAN CHAR MODE, IT IS TOO SMALL.
/ THUS IF A CHAR VARIABLE APPEARS IN BOTH DIMENSION AND CHARACTER
/ STATEMENTS, THE CHARACTER STATEMENT MUST BE 1ST.
CHARAC	JMS*	GETCHI
	SAD	(STAR
	JMP	REPLCC
	LAC	(1	/ DEFAULT OF 1
	JMP	DEFLTC
REPLCC	JMS*	GETCHI
	LAC	(INTGRS
	JMS*	SEARCH	/ GET CHAR SIZE
	JMS	CHKRNG	/ CHECK SIZE OF INTEGER
	LAC*	VANTED
DEFLTC	DAC	STSIZE	/ STORE STATEMENT CHARACTER SIZE
	ISZ	TYPESW
	LAW	H3!NON.EX!BDLEGL
	JMS*	HIERAR
	LAC	(CHARM
	DAC	MODESW
	JMP	SPECST
/
SETFFG	DAC*	FLTFLG	/ SET TO TRUE MODE
	DAC	MODE
	LAC	(VARIAB
	JMS*	CALCP
	LAC*	FLTFLG	/ IF FLTFLG IS CHANGED THEN ENTRY ALREADY EXISTS
	SAD	(CHARM	/ WITH ANOTHER MODE.
	JMP	CHKSTR
	LAC*	BITPTR
	AND	(FORMAL
	SNA
	JMP	ERRSP7
	LAC	STSIZE
	DAC*	CPOINT		/ INSERT CHARACTER SIZE IN DTABLE
	JMP	CHKSTR
ERRSP7	JMS*	ERRORS	/ ERROR - 1ST ENCOUNTER OF VARIABLE WAS NOT CHARACTER
	.SIXBT	'SP7'
/
ERRSP6	JMS*	ERRORS	/ ERROR - ILLEGAL CHARACTER SIZE, 0 OR >256
	.SIXBT	'SP6'
/ DIMENSION
DIMEN	ISZ	DIMSW
	JMP	SPECS4
/ THIS SECTION LOOKS AFTER THE SPECIFICATION STATEMENTS ANALYSING
/  THEM AND SETTING UP THE PROPER SYMBOL TABLE ENTRIES.
SPECS3	ISZ	TYPESW
	DAC	MODESW
SPECS4	LAW	H3!NON.EX!BDLEGL
	JMS*	HIERAR
SPECS1	JMS*	GETCHI
SPECST	LAC	(NAME	/ WE WANT A NAME
	JMS*	SEARCH	/ GET VARIABLE
/
	LAC	MODESW	/ IF MODESW IS SET WE ARE IN SPEC STAT
	SAD	(CHARM	/ IF CHARACTER ST. DO SPECIAL ENTRY
	JMP	SETFFG
	SNA		/ AND MODESW CONTAINS THE MODE
NOTSPC	LAC*	FLTFLG	/ NOT IN SPEC STATEMENT, USE FLTFLG
	DAC	MODE	/ OTHERWISE USE MODE OF MODESW
/
	LAC	(VARIAB	/ SIGNIFIES WE ARE PASSING A VARIABLE
	JMS*	CALCP	/ STORE IN SYMBOL TABLE
CHKSTR	LAC*	CHINXT	/ GET CHAR AFTER NAME
	SAD	(STAR	/ IS IT "*"
	SKP
	JMP	MODSET	/ NO
/
/ REDEFINITION OF MODE ATTEMPTED, VALID ONLY IN SPEC STATEMENT
	LAC	COMSW
	TAD	DIMSW
	SZA
	JMP	ERRDM1	/ MODE CHANGE ILLEGAL IN COMMON OR DIMENSION
/
	JMS*	GETCHI	/ YES. SET UP NEXT CHAR
	LAC	(INTGRS	/ BETTER BE A INTEGER CONSTANT
	JMS*	SEARCH
	LAC	SP1	/ LOAD ERROR IN CASE OF NO MATCH
	JMS	MODCHK	/ GO CHECK MODES
/
/ WAS MODE SET PREVIOUSLY IN A SPECIFICATION STATEMENT ?
MODSET	LAC*	BITPTR	/ GET CONTROL BITS FROM DTABLE
	AND	(MODEST	/ WAS MODE PREVIOUSLY SET IN A SPEC
	SNA		/  STATEMENT ?
	JMP	SETMOD	/ NO.
/ ARE WE TRYING TO REDEFINE MODE ILLEGALLY IN ANOTHER SPEC STATEMENT
	LAC	TYPESW	/ MODE SET PRVIOUSLY IN SPEC STATEMENT
	SNA		/ ARE WE IN A SPEC STATEMENT NOW?
	JMP	OKAY	/ NO, OKAY CONTINUE
	LAC*	FLTFLG	/ YES, GET SEARCH MODE
	SAD	MODE	/ IS IT THE SAME AS MODE OF SPEC STATEMENT
	SKP
	JMP	ERRSP2	/ NO ERROR
WRNSP9	JMS*	WARN	/ YES ISSUE WARNING
	.SIXBT	'SP9'
	JMP	OKAY	/ CONTINUE
/
/
/ SET MODE IN DTABLE
SETMOD	LAC*	MODPTR	/ NO. THEN INSERT MODE
	AND	(777760	/ SAVE DTABLE POINTER, REMOVE MODE
	TAD	MODE	/ INSERT MODE
	DAC*	MODPTR	/ RESTORE WORD
	LAC	TYPESW
	SNA		/ ARE WE IN A SPEC STATEMENT
	JMP	OKAY	/ NO CONTINUE
/
/ MARK MODE AS HAVING BEEN SET IN A SPEC STATEMENT (CAN'T BE CHANGED)
	LAC	(MODEST	/ YES
	JMS	SHOVE
/
/ CHECK NOW TO SEE IF ANY DIMENSIONS FOLLOW.
OKAY	LAC*	CHINXT	/ GET NEXT CHAR
	SAD	(OPEN	/ IS IT " ( "
	JMP	INFO	/ YES. DIMENSION INFO, PROCESS IT.
	LAC	DIMSW	/ NO
	SZA		/ ARE WE IN A DIMENSION STATEMENT ?
	JMP	ERRDM0	/ YES. ERROR NO DIMENSIONS
	JMP	FURTHR	/ NO. OKAY THEN
/
/
ARGSW;VARSW;BOX1;COUNT;FILLPT;LOW;NUMBER;SLSHSW;SUBPT;SUM
TEMP;PTRBIT;OTSAVE;S
/
/ DIMENSIONING INFORMATION FOLLOWS, CHECK IF IT IS LEGAL
SUBTAB		/ START ADDRESS FOR SUBSCRIPT TABLE
INFO	LAC*	BASE3
	DAC	SUBTAB
	LAC*	INTAB
	SNA		/ WAS VARIABLE ALREADY IN TABLE
	JMP	NOTIN	/ NO IT WAS NOT.
	LAC*	BITPTR	/ YES IT WAS, GET CONTROL BITS
	AND	(DIMENS!DATSET!FUNBIT!FUNNAM
	SNA
	JMP	ONLY1	/ NONE OF ABOVE
	SAD	(FUNBIT
	JMP	ERRDM5	/ IT IS A FUNCTION NAME
	SAD	(FUNNAM
	JMP	ERRDM5	/ ITS THE SUBPROGRAM NAME
	SAD	(DIMENS
	JMP	ERRDM3	/ IT ALREADY HAS DIMENSIONS
	JMP	ERRDM4	/ IT HAS DATA AND MAYBE DIMENSIONS ALREADY
/
/ IF WE REACH HERE THEN THE VARIABLE WAS ALREADY IN THE TABLE
/ WITH NO DIMENSIONS OR DATA SUPPLIED. IT NOW HAS DIMENSIONS THUS
/ WE DISCARD THE PREVIOUS OTABLE ENTRY ( IT MIGHT BE REUSED LATER)
/ AND ASSIGN A NEW OTABLE ENTRY WHERE THE TWO OTABLE ENTRIES FOR
/ A DIMENSIONED VARIABLE MAY BE CONSECUTIVE!
ONLY1	LAC*	MODPTR
	JMS*	GETADR	/ GET OLD OTABLE ADDRESS
	DAC	TEMP	/ SAVE IT
	LAC*	TEMP	/ GET 1ST WORD
	LMQ		/ SAVE IT
	LAW	-1
	TAD	TEMP
	DAC	TEMP
	LAC*	TEMP	/ GET SECOND WORD
	JMS*	GETOTB	/ ASSIGN NEW OTABLE ENTRY
	CLQ!LLS+6
	DAC	TEMP	/ SAVE RELATIVE OTABLE POINTER
	LAC*	MODPTR	/ GET DTABLE POINTER
	AND	(000077	/ REMOVE OLD ADDRESS
	TAD	TEMP	/ ADD IN NEW ADDRESS
	DAC*	MODPTR	/ RESTORE THE WORD
/
/ ENTER HERE IF VARIABLE WAS NOT IN SYMBOL TABLE AND HAS DIMENSIONS
NOTIN	LAC	SUBTAB
	DAC	SUBPT
	DZM	COUNT
	DZM	ARGSW
	DZM	VARSW
	LAC	BITPTR
	DAC	PTRBIT	/ SAVE POINTER CAUSE VARIABLE SUBSCRIPTS CLOBBER BITPTR
	LAC	(DIMENS	/ MARK AS HAVING DIMENSION INFO
	JMS	SHOVE
	LAC*	OTNEXT	/ SAVE POINTER TO OTABLE
	DAC	OTSAVE
	CLQ!001000	/ CLEAR AC AND MQ
	JMS*	GETOTB	/ MAKE OTABLE ENTRY FOR DIM TABLE SO ITS CONSECUTIVE
	LAC*	BITPTR
	AND	(FORMAL
	SZA		/ IS VARIABLE A FORMAL PARAMETER ?
	ISZ	ARGSW	/ YES. SET SWITCH
/
/ NOW PROCEED TO PROCESS THE DIMENSION INFORMATION
DOWN	DZM	SLSHSW
	LAC	(2
	DAC	LOW	/ DEFAULT LOWER LIMIT = 1 , (RCL'D)
GAMMA	JMS*	GETCHI
	LAC	ARGSW
	SZA		/ IF IN ARGUMENT STRING, ARGSW=1
	JMP	ALPHA
/
/ VARIABLE NOT A FORMAL PARAMETER. ONLY INTEGER CONSTANTS ALLOWED.
INTEG	LAC	(INTGRS!SIGNER	/ NO. THUS WANT AN INTEGER
	JMS*	SEARCH
INTEG1	LAC*	VANTED
	RCL
	DAC	BOX1
	JMP	BETA
/
/ VARIABLE WAS FORMAL PARAMETER. INTEGER CONSTANT OR INTEGER VARIABLES ALLOWED
ALPHA	LAW	SIGNER
	JMS*	SEARCH	/ ACCEPT ANY THING
	LAC*	FLTFLG
	SAD	(CONBIT!SINTGM	/ IS IT INTEGER CONSTANT ?
	JMP	INTEG1	/ YES
	SAD	(SINTGM	/ IS IT SINGLE INTEGER VARIABLE
	JMP	MODOK
	SAD	(DINTGM	/ IS IT DOUBLE INTEGER VARIABLE
	JMP	MODOK
ERRDM9	JMS*	ERRORS		/ VARIABLE DIMENSION NOT
	.SIXBT	'DM9'		/ SINGLE OR DOUBLE INTEGER
/
/ HAVE A LEGAL MODE FOR THE VARIABLE
MODOK	LAC	COMSW	/ HAVE FOUND VARIABLE
	SZA		/ ARE WE IN COMMON
	JMP	ERREC8	/ YES. VARIABLE DIMENSIONS IN COMMON ILLEGAL
	LAC	(VARDIM
	DAC	VARSW
	LMQ
	LAC*	PTRBIT	/ GET CONTROL BITS
	OMQ		/ MARK AS HAVING VARIABLE DIMENSIONS
	DAC*	PTRBIT
	LAC	(VARIAB	/ PASS VARIABLE TO SYMBOL TABLE ROUTINE
	JMS*	CALCP
	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(FORMAL!COMSET	/ ONLY THESE TWO BITS ARE LEGAL
	SNA!CLL
	JMP	ERRDM6	/ ERROR - ILLEGAL TYPE OF VARIABLE
	LAC*	MODPTR	/ GET 1ST WORD OF DTABLE
	LRS	6	/ GET RELATIVE OTABLE POINTER
	STL
	RAL
	DAC	BOX1	/ STORE IT. AC17=1 INDICATES VARIABLE
	LAC	(USED	/ MARK VARIABLE DIMENSION AS USED
	JMS	SHOVE
/
/ HAVE GOT AN INTEGER VARIABLE ADDRESS IN BOX1
BETA	LAC*	CHINXT
	SAD	(SLASH
	JMP	ITSLSH
	SAD	(COMMA
	JMP	ITSCMA
	SAD	(CLOSE
	SKP
	JMP	ERRSP3	/ ILLEGAL DELIMITER IN SPEC ST
	JMS	PUT	/ END OF DIMENSION INFO. PUT LAST LIMITS IN TABLE
/
/ SET UP TO PROCESS LIMITS TABLE
	LAC	COUNT	/ GET # OF SUBSCRIPTS
	CMA
	DAC	NUMBER	/ -(N+1)
	TAD	(1
	DAC	CNT	/ SET UP COUNTER WITH -N
	LAC	VARSW
	SZA		/ DOES THIS VARIABLE HAVE VARIABLE DIMENSIONS
	JMP	ENTRVD	/ YES. CAN'T PROCESS THEM.
/
/ COMPUTE THE ADJUSTMENT FACTOR AND THE BASE ADDRESSES FOR THE
/ COLUMNS.
CONSUB	DZM	SUM	/ INITIALIZE ADJUST FACTOR
	LAC	(1
	DAC	PROD	/ INITIALIZE PRODUCTS
	LAC	SUBTAB	/ START ADDRESS OF SUBSCRIPT TABLE
	DAC	SUBPT	/ SET UP A POINTER TO SCAN TABLE
	TAD	(1
	DAC	FILLPT	/ SET UP POINTER TO REFILL TABLE
TOP	LAC*	SUBPT	/ GET LOW VALUE
	DAC	LOW	/ STORE IT
	CMA		/ NEGATE IT
	TAD	(1	/ 2'S COMPLIMENT
	ISZ	SUBPT	/ NOW POINTS TO HIGH VALUE
	TAD*	SUBPT	/ ADD HIGH VALUE
	SPA!RCR		/ SHIFT TO GET PROPER NUMBER
	JMP	ERRDM7		/UPPER LIMIT .LT. LOWER LIMIT
	TAD	(1	/ STRAIGHTEN UP ARITHMETIC
	DAC	LENGTH
	ISZ	SUBPT	/ POINTS AT NEXT LOW VALUE
/
/ CALCULATE ADJUSTMENT FACTOR
	LAC	LOW
	SPA!CLL!RAR		/EXTEND SIGN & MAKE 1'S COMPLEMENT
	TAD	(400000-1
	MULS		/ LOW * PRODUCT
PROD	XX
	LACQ
	ADD	SUM
	DAC	SUM
/
/ CALCULATE COLUMN ADDRESSES.
	LAC	PROD
	CLL
	MUL		/ LENGTH * PRODUCT
LENGTH	XX
	LACQ
	DAC	PROD
	DAC*	FILLPT	/ PLACE IN TABLE
	ISZ	FILLPT
	ISZ	CNT	/ ARE WE FINISHED ?
	JMP	TOP
/
	LAC	SUM	/ GET ADJUSTMENT FACTOR
	SMA!CMA
	TAD	(1
	DAC*	SUBTAB
	CLA
/
/ MAKE OTABLE ENTRY FOR DIMENSION TABLE AND DUMP
/ THE DIMENSION TABLE INTO THE DTABLE.
ENTER	TAD	COUNT	/ N      OR  3N
	TAD	(1	/ N+1    OR  3N+1
	TAD	DIMCNT
	DAC	DIMCNT	/ ACCUMULATE SPACE NEEDED FOR DOMEMSION TABLES
	LAC*	PTRBIT	/ GET CONTROL BITS
	AND	(FORMAL
	SZA
	ISZ	DIMCNT	/ NEED AN EXTRA WORD FOR FORMAL PARAMETERS
	LAC*	DTNEXT	/ 2ND WORD POINTS TO DTABLE LOCATION
	XOR	(DMOTB*100000	/ MARK AS DIMENSION TABLE
	DAC*	OTSAVE	/ DEPOSIT IN 2ND WORD
	ISZ	OTSAVE	/ STEP TO 1ST WORD
	LAC	COUNT	/ DEPOSIT NUMBER OF SUBSCRIPTS
	DAC*	OTSAVE	/ IN 1ST WORD
	LAC	NUMBER	/ GET NEG WORD COUNT FOR MOVING
	JMS*	G.MOVE
	TAD	SUBTAB
	TAD*	DTNEXT
	LAC*	(AUTO11	/ CONTAINS LAST DTABLE ADDRESS
	TAD	(1
	DAC*	DTNEXT	/ RESET TO NEXT FREE LOCATION
	JMS*	GETCHI
	LAC	PTRBIT	/ RESET BITPTR FOR SUBSEQUENT CHECKING
	DAC	BITPTR
	JMP	FURTHR
/
/ SET UP THE COUNTER TO TRANSFER THE LIMITS TABLE AS IS. IE. 2N WORDS
ENTRVD	LAC	NUMBER	/ -(N+1)
	TAD	(1	/ -N
	RCL		/ -2N
	DAC	NUMBER
	LAC	COUNT	/ N
	RCL		/ 2N
	JMP	ENTER
/
/ CHECK IF THERE ARE TWO SLASHES (IE. A(5/5/...) ) ERROR IF SO.
ITSLSH	LAC	SLSHSW
	SZA		/ IS IT SECOND SLASH
	JMP	ERRDMA	/ TWO SLASHES ILLEGAL
	LAC	BOX1
	DAC	LOW
	ISZ	SLSHSW	/ MARK FIRST SLASH AS HAVING OCCURRED
	JMP	GAMMA
/
ITSCMA	JMS	PUT
	JMP	DOWN
/
/ PUT LOW AND HIGH LIMITS IN THE TABLE
PUT	XX
	ISZ	COUNT
	LAC	COUNT
	SAD	(15
	JMP	ERRDM8	/ TOO MANY SUBSCRIPTS
	LAC	LOW
	DAC*	SUBPT
	ISZ	SUBPT
	LAC	BOX1
	DAC*	SUBPT
	ISZ	SUBPT
	JMP*	PUT
/
	.EJECT
/
/ WE HAVE FINISHED PROCESSING DIMENSIONS FOR THIS VARIABLE IF 
/ THERE WERE ANY.
FURTHR	LAC	COMSW
	SZA		/ ARE WE IN A COMMON STATEMENT ?
	JMP	CHAIN	/ YES
	LAC*	CHINXT	/ NO. LOAD NEXT CHAR
	SAD	(SLASH	/ IS IT " / "
	SKP
	JMP	TRYCMA	/ NOT SLASH
	LAC	DIMSW
	SZA		/ ARE WE IN A DIMENSION STATEMENT
	JMP	ERRDM2	/ YES. BUT " / " IS ILLEGAL
/
/ PROCESS DATA INFORMATION, EVERYTHING AFTER THE FIRST SLASH- UP TO
/  AND INCLUDING THE LAST SLASH IS CONTAINED IN THE TEMPORARY STORAGE
	LAC*	BASE2
	DAC	TEMP
	LAC*	BITPTR
	AND	(DIMENS		/ DO WE HAVE AN ARRAY OR SIMPLE VARIABLE?
	SZA
	LAC	(400000		/ SET UP ARRAY MARKER FOR 'PICCON'
	XOR	MODPTR
	DAC*	TEMP	/ STORE IN TEMP STORAGE
	LAC	TEMP
	DAC*	LIST	/ SET UP INSERTING ROUTINE
	CLA!CMA
	DAC*	LIST1
LOOP	JMS*	GETCHI	/ GET NEXT CHAR
	DAC*	BOX	/ STORE FOR INSERTION
	JMS*	INSERT
	LAC*	BOX	/ GET LAST CHAR
	SAD	(SLASH	/ WAS IT " / "
	JMP	YEP	/ YES
	SAD	(ENDST	/ IS IT END OF LINE ?
	JMP	ERRSP3	/ NO FINAL SLASH
	JMP	LOOP
/
YEP	LAC*	LIST	/ REGAIN POINTER
	TAD	(1	/ POINTS AT NEXT FREE LOCATION
	DAC*	BASE2
	DAC*	BASE3
	JMS*	GETCHI	/ GET NEXT CHAR
	LAC	(DATSET
	JMS	SHOVE	/ MARK AS HAVING DATA
	JMP	TRYCMA
/
/ CHAIN THE COMMON VARIABLES INTO THE COMMON FILES
CHAIN	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(FORMAL!FUNBIT!FUNNAM!COMSET
	SNA		/ NONE OF THE ABOVE
	JMP	NOCERR
	SAD	(COMSET	/ WAS VARIABLE ALREADY IN COMMON
	JMP	ERRCM0	/ YES.
	SAD	(FORMAL	/ WAS VARIABLE A SUBPROGRAMME PARAMETER
	JMP	ERRCM2	/ YES.
	JMP	ERRCM1	/ EITHER FUNCTION OR SUBPROGRAMME NAME
/
/ VARIABLE MAY BE IN COMMON
NOCERR	LAC	(COMSET
	JMS	SHOVE	/ OCCURRED IN COMMON
	LAC*	SAVCMN	/ GET 1ST WORD OF COMMON NAME ENTRY
	SNA		/ IF=0, THEN FIRST ENTRY IS HAPPENING
	JMP	FIRST
	DAC	TEMP	/ NOT=0,CONTAINS POINTER TO FIRST ENTRY
THREAD	LAC*	TEMP	/ GET DTABLE INFORMATION
	JMS*	GETADR
	DAC	TEMP	/ STORE ADDRESS
	LAC*	TEMP	/ GET CONTENTS
	SAD	(200000	/ IF=0, THEN END OF CHAIN
	JMP	ENDCHN
	DAC	TEMP	/ NOT=0,CONTAINS DTABLE POINTER
	JMP	THREAD	/ OF NEXT ITEM IN CHAIN
/
ENDCHN	LAC	MODPTR	/ GET LAST DTABLE ENTRY POSITION
	XOR*	TEMP	/ STORE IN OTABLE TO EXTEND CHAIN
	DAC*	TEMP	/ REPLACE IT
	JMP	FIRST2
/
FIRST	LAC	MODPTR	/ GET DTABLE POINTER
	DAC*	SAVCMN	/ START COMMON CHAIN
FIRST2	LAC*	MODPTR	/ GET 1ST WORD OF LAST VARIABLE
	JMS*	GETADR	/ GET ITS OTABLE ENTRY. POINTS TO 1ST WORD
	TAD	(-1	/ NOW POINTS TO 2ND WORD
	DAC	TEMP
	LAC	SAVCMN	/ COMMON NAME ADDRESS
	DAC*	TEMP	/ GOES IN 2ND WORD OF OTABLE ENTRY
/
DELTA	LAC*	CHINXT
	SAD	(SLASH
	JMP	CMNSL1
/
TRYCMA	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(DIMSET!DATSET!DIMENS!COMSET
	SZA		/ IF ABOVE BITS NOT SET, WE ARE NOT SURE
	JMP	.+4	/ OF VARIABLE, SO SET NOHERE BIT
	LAC	(NOHERE
	JMS	SHOVE
	JMS*	DLOTAB	/ RESCIND OTABLE ENTRY FOR VARIABLE
/
	LAC*	CHINXT
	SAD	(COMMA	/ IS IT " , "
	JMP	SPECS1
	SAD	(ENDST
	EXIT		/ YES. RETURN
ERRSP3	JMS*	ERRORS		/ 'MISSING SLASH IN SPECIFICATION
	.SIXBT	'SP3'		/  STATEMENT DATA' OR 'ILLEGAL DELIMITER'
/
/ THIS SECTION IS ENTERED WHEN THE FIRST NON-SPECIFICATION
/  STATEMENT IS FOUND. THE PTABLE IS SEARCHED FOR
/  COMMON NAMES AND WHEN FOUND IT CHAINS THROUGH THE
/  COMMON VARIABLES AND ASSIGNS THEM  LOCATIONS RELATIVE TO THE
/  START OF THAT COMMON BLOCK.
/
/ STORAGE LOCATIONS
ADRES;DPOINT;DPTR;OPT1;OPT2;OPTR1;OPTR2
/
CLENUP	XX
	LAC	CMNSWH
	SNA		/ WAS THERE ANY COMMON STATEMENTS ?
	JMP*	CLENUP	/ NO. RETURN
	LAC*	PTABLE	/ YES.
	TAD	(-1
	DAC*	(AUTO12	/ LOAD AUTO-INDEX REGISTER FOR G.SCAN
NEXT	LAC	(COMNAM	/ WE ARE SEARCHING FOR COMMON NAMES
	JMS*	G.SCAN	/ GO SCAN PTABLE
	SKP		/ EXIT HERE WHEN COMMON NAME FOUND
	JMP*	CLENUP	/ EXIT HERE ON END OF PTABLE
	DAC	DPOINT	/ STORE DTABLE ADDRESS
	DAC*	(AUTO10
/
/  THIS SECTION CHAINS THROUGH COMMON ENTRIES & ASSIGNS LOCATIONS
	DZM	ADRES	/ NEW COMMON BLOCK. INITIALIZE ADDRESS
	LAC*	DPOINT	/ GET IST WORD OF DTABLE COMMON NAME ENTRY
/
NEWVAR	AND	(077777
	SNA		/ IF=0, ITS END OF COMMON CHAIN
	JMP	FIX	/ SET UP TOTAL COMMON SIZE
	DAC	MODPTR	/ FINALLY POINTS TO 1ST WORD OF VARIABLE
	TAD	(3
	DAC	BITPTR	/ POINTS TO CONTROL BITS OF VARIABLE
	TAD	(1
	DAC	CPOINT		/POINT TO CHARACTER VARIABLE SIZE
/
	LAC*	MODPTR	/ GET 1ST DTABLE WORD OF VARIABLE
	JMS*	GETADR	/ SUBROUTINE RETURNS ABSOLUTE OTABLE LOC
	DAC	OPT1	/ POINTS TO 1ST WORD OF VARIABLE
	TAD	(-1
	DAC	OPT2	/ POINTS TO 2ND WORD
	LAC*	OPT1	/ GET ADDRESS OF NEXT VARIABLE
	DAC	DPTR	/ IN DAISY CHAIN,IF ANY. SAVE IT.
	LAC	ADRES	/ ASSIGN LOCATION
	XOR	(200000	/ ADD INDICATOR BITS
	DAC*	OPT1	/ PUT ADDRESS IN OTABLE.
	JMS	ARYSIZ	/ GO GET ARRAY OR WORD SIZE
	TAD	ADRES	/ ADD 'ADRES' TO GET NEW
	DAC	ADRES	/ START ADDRESS FOR NEXT VARIABLE
	LAC	DPTR	/ CONTINUE DAISY CHAIN
	JMP	NEWVAR
/
/
FIX	LAC	ADRES	/ THE VALUE OF ADRES IS ALSO THE TOTAL
	DAC*	DPOINT	/ SIZE OF THE COMMON BLOCK. STORE IN
	JMP	NEXT	/ DTABLE.
/
/
/ THIS SUBROUTINE DETERMINES THE SIZE OF STORAGE NEEDED FOR THE
/ VARIABLE. IF VARIABLE IS DIMENSIONED IT GETS THE ARRAY SIZE; IF NOT
/ IT RETURNS THE WORD SIZE.
ARYSIZ	XX
	LAC*	MODPTR
	JMS	WDSIZE	/ GET WORD SIZE
	DAC	ARSQ
	LAC*	BITPTR	/ GET CONTROL BITS
	AND	(DIMENS
	SZA		/ ARE THERE ANY DIMENSIONS
	JMP	ARRAY	/ YES IT IS AN ARRAY
	LAC	ARSQ	/ NOT AN ARRAY, RETRIEVE WORD SIZE
	JMP*	ARYSIZ
/
/ SECTION TO DECIPHER DIMENSION INFORMATION TO GET ARRAY SIZE
ARRAY	LAC	OPT2	/ SINCE ITS AN ARRAY, NEXT OTABLE ENTRY
	TAD	(-1
OENTRY	DAC	OPTR1	/ CONTAINS EITHER: # OF SUBSCRIPTS
	TAD	(-1
	DAC	OPTR2	 / & POINTER TO DTABLE DIMENSION INFO
	LAC*	OPTR1	/ BUT IF FOLLOWING BIT IS SET 2ND WORD
	SMA!CLL		/ POINTS TO THE CORRECT OTABLE ENTRY
	JMP	GETDIM	/ BIT NOT SET! THIS IS THE REAL THING.
	LAC*	OPTR2	 / BIT SET! IS ONLY ADDRESS
	JMP	OENTRY	/ TEST THIS NEW OTABLE ENTRY
/
GETDIM	TAD*	 OPTR2	  / # OF SUBSCRIPTS.ADD ADDRESS OF DIMEN-
	DAC	OPTR2	/ TO GET ENTRY TO TABLE
	LAC*	OPTR2	 / GET # OF ELEMENTS
	MUL		/ MULT BY WORD SIZE
ARSQ	XX
	LACQ		/ GET ARRAY SIZE
	JMP*	ARYSIZ
/
/
ERRCM0	JMS*	ERRORS		/ 'VARIABLE PREVIOUSLY PLACED IN COMMON'
	.SIXBT	'CM0'
ERRCM1	JMS*	ERRORS		/ 'NAME IN COMMON LIST PREVIOUSLY
	.SIXBT	'CM1'		/  USED AS OTHER THAN VARIABLE'
ERRCM2	JMS*	ERRORS		/ 'SUBPROGRAM PARAMETER APPEARS IN 
	.SIXBT	'CM2'		/  COMMON STATEMENT'
ERRDM0	JMS*	ERRORS		/ 'NO DIMENSION SPECIFIED FOR A
	.SIXBT	'DM0'		/  VARIABLE IN A DIMENSION STATEMENT'
ERRDM1	JMS*	ERRORS		/ 'OPTIONAL LENGTH SPECIFICATION IN
	.SIXBT	'DM1'		/  DIMENSION OR COMMON STATEMENT IS ILLEGAL'
ERRDM2	JMS*	ERRORS		/ 'INITIALIZATION IN DIMENSION STATEMENT
	.SIXBT	'DM2'		/  IS ILLEGAL'
ERRDM3	JMS*	ERRORS		/ 'ATTEMPT TO RE-DIMENSION A VARIABLE'
	.SIXBT	'DM3'
ERRDM4	JMS*	ERRORS		/ 'ATTEMPT TO DIMENSION AN
	.SIXBT	'DM4'		/  INITIALIZED VARIABLE'
ERRDM5	JMS*	ERRORS		/ 'ATTEMPT TO DIMENSION A FUNCTION OR
	.SIXBT	'DM5'		/  SUBPROGRAM NAME'
ERRDM6	JMS*	ERRORS		/ 'VARIABLE SUBSCRIPT IS NOT A
	.SIXBT	'DM6'		/  FORMAL PARAMETER'
ERRDM7	JMS*	ERRORS		/ 'UPPER LIMIT LESS THAN LOWER LIMIT'
	.SIXBT	'DM7'
ERRDM8	JMS*	ERRORS		/ 'MORE THAN 13 SUBSCRIPTS NOT ALLOWED'
	.SIXBT	'DM8'
ERRDMA	JMS*	ERRORS		/ 'ILLEGAL SYNTAX IN DECLARATION OF
	.SIXBT	'DMA'		/  LOWER/UPPER BOUNDS FOR DIMENSION'
ERRSP2	JMS*	ERRORS		/ 'ILLEGAL RE-DEFINITION OF PRECISION
	.SIXBT	'SP2'		/  WITHIN A SPECIFICATION STATEMENT'
/
/
/ PROGRAM STORAGE LOCATIONS.
/  THE FOLLOWING MUST BE INITIALIZED AT START OF EACH JOB
/  AND MUST NOT BE USED AS GENERAL REGISTERS
/
DTSTAT	.DSA	440000	/ INTERNAL STATEMENT NUMBERS FOR DATA STATEMENTS
IFSTAT	.DSA	400000	/ INTERNAL STATEMENT NUMBERS FOR LOGICAL 'IF'
/
/
CMNSWH	0	/ SIGNIFIES THERE WAS A COMMON STATEMENT
CHRCNT	0	/ COUNTS THE NUMBER OF CHARACTER VARIABLE ASSIGNED SPACE
DIMCNT	0	/ COUNTS TOTAL SIZE REQUIRED FOR THE DIMENSION TABLES
DTSTOR	0	/ STORAGE IN CASE OF MULTIPLE DATA STATEMENTS
ENDNST
ERSW	0	/ IF SET, ERROR ROUTINE RETURNS TO PROCESS SPECIAL LINE
IFSW
IFSTOR
KIND	0	/ DESCRIBES PROGRAM TYPE-1=MAINLINE,2=SUB,3=FUNCTION,
		/ 4=BLOCK DATA
RPCNT	0	/ A COUNT OF STATEMENT NUMBERS IN SUBROUTINE LIST
SMALLJ	0	/ NEST NUMBER
DEVICE	0	/ CONTAINS THE DEVICE REQUESTS
/
/ THE FOLLOWING  MUST BE INITIALIZED AT THE START OF EACH LINE
/ AND MUST NOT BE USED AS GENERAL REGISTERS
TYPESW;DIMSW;COMSW;EQUVSW;MODE;MODESW;STSIZE
/
/ THE FOLLOWING ARE NOT GENERAL REGISTERS BUT DO NOT HAVE
/ TO BE INITIALIZED
MODPTR;BITPTR;CPOINT;HEADER
/
/
/
/
/ THE FOLLOWING LOCATIONS ARE GENERAL STORAGE VARIABLES WHICH
/ SHOULD BE USED ONLY WHILE IN A CERTAIN STATEMENT PROCESSOR
/ THE STORAGE IS OVER LAPPED TO SAVE SPACE.
/
/ GENERAL
CNT;INCRES
/ DON'T OVERLAP THE ABOVE WORK REGISTERS
/ IF PROCESSOR
IFBOX
IFTEMP
/
/FORMAT PROCESSOR
/
FORMBX		/POINTER TO FORMAT STATEMENT NO. OTABLE
/
/  DATA IN SPECIFICATION PROCESSOR
/
DSPECS	.BLOCK	2
/
/ DO PROCESSOR
ADDRSK
ADDRSL
ADDRSI
/
/ I/O PROCESSOR
OLDCHR
LEVEL
OLDPLC
NXPLC
LEVELP
OPENP
COMMAP
SEMIPT
IMPTAB
	.END
