Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-02 - 43,50263/sddsys.mac
There are 2 other files named sddsys.mac in the archive. Click here to see a list.
	TITLE	S$$SYS  SYSTEM BASIC MODULE
	SUBTTL	DESCRIPTION OF FUNCTIONS
	SALL
	RADIX	10
	SEARCH	S$$NDF

	COMMENT"
	THIS MODULE CONTAINS ALL THE BASIC FUNCTIONS OF THE RUN-TIME
SYSTEM, DESCRIBED BRIEFLY BELOW AND FUNCTIONALLY IN THE APPROPRIATE
SECTION.

SYSTEM INITIALIZATION- INITIALIZES SYSTEM PARAMETERS, STACKS, AND INITIAL-
LIZES THE MAIN PROGRAM. SYSTEM COMMON IS DEFINED TO RECLAIM AS MUCH OF
THE CORE USED BY THE INITIALIZATION AS POSSIBLE.

PROGRAM INITIALIZATION- INCORPORATES THE NEW PROGRAM'S PARAMETERS AND
SYMBOLS INTO THE SYSTEM.

UUO HANDLER- DISPATCHES OPERATIONS 01-37.

INTERRUPT HANDLER- DISPATCHES PROGRAM-TRAPPED INTERRUPTS

STACK OVERFLOW- EXPANDS STACKS WHEN THEY OVERFLOW.

FREE STORAGE- DYNAMIC STORAGE ALLOCATION FUNCTIONS.

INPUT/OUTPUT- ELEMENTARY I/O FUNCTIONS.

RUN-TIME ERRORS- HANDLES CONDITIONALLY OR UNCONDITIONALLY FATAL ERRORS.

SYSTEM EXITS- NORMAL OR ERROR EXITS FROM SYSTEM.

RUN-TIME SYMBOL TABLE- BASIC AND SYSTEM SYMBOL LOOKUP FUNCTIONS
AND SYMBOL BLOCK INITIALIZATION ROUTINE.

FUNCTION CALL HANDLER- DISPATCHES PRIMITIVE AND PROGRAMMER-DEFINED FUNC-
TION CALLS, FIELD AND DATATYPE REFERENCES.

DEDICATED MODE ROUTINES- DISPATCHES DEDICATED ASSIGNMENTS AND DEDICATED
STRING CONCATENATION.

DESCRIPTOR MODE CONVERSION- CONVERTS FROM DESCRIPTOR MODE INTO
INTEGER OR REAL.

ARRAY/TABLE REFERENCE HANDLER- PRODUCES VALUE OR NAME OF ARRAY OR
TABLE ELEMENT.

FAILPOINT ROUTINE- HANDLES GLOBAL, NEGATION, AND UNEVALUATED EXPRESSION
FAILURES.

UTILITY ROUTINES- ASSORTED CONVERSION ROUTINES.

DUMMY FORTRAN ENTRIES- USED TO SATISFY FORTRAN MATH LIBRARY ROUTINES."
	SUBTTL	SYSTEM INITIALIZATION

	ENTRY	S$$ILZ
	EXTERN	.JBUUO,.JB41,.JBREL,.JBSA,.JBFF,.JBAPR,.JBCNI
	EXTERN	.JBTPC,.JBCOR

	COMMENT/ SYSTEM INITIALIZATION
CALL:	JSP	R12,S$$ILZ	; OCCURS AT THE START OF MAIN PROGRAM
	XWD	HSHSIZ,MAINPB	; WHERE HSHSIZ IS THE BUCKET TABLE SIZE,
DEFAULT (P$HSHS) USED IF 0, AND MAINPB IS THE MAIN PROGRAM PARAMETER
BLOCK POINTER.

	DOES A RESET, SETS UP UUO AND INTERRUPT SERVICE, SAVES START
TIME, INITIALIZES FREE STORAGE, STACKS, CHANNEL TABLE, BUCKET TABLE, AND
SYSTEM SYMBOLS, AND INITIALIZES MAIN PROGRAM.
	THE CORE OCCUPIED BY THE INITIALIZATION CODE IS RECLAIMED FOR
USE BY VARIABLES AND TABLES IN THIS MODULE THAT DO NOT REQUIRE INITIAL
VALUES/

S$$ILZ:	RESET		; RESET SYSTEM
	SETZ	R0,	; GET START TIME OF EXECUTION
	RUNTIM	R0,	; FOR THIS JOB
	MOVEM	R0,SSTT	; SAVE
	MOVE	R0,S$$UUL	; SET UP UUO HANDLER
	MOVEM	R0,.JB41
	MOVEI	R0,INTRUP	; SET UP INTERRUPT HANDLER
	MOVEM	R0,.JBAPR
	MOVEI	R0,^O620110	; REPETITIVE ENABLE PUSHDOWN OVFLOW,
	APRENB	R0,	; MEMORY, ARITH OVFLOW, DIVIDE CHECK

; INITIALIZE FREE STORAGE
	HLRZ	R2,.JBSA	; GET FIRST FREE LOCATION
	MOVEM	R2,MINCOR	; SAVE
	MOVEM	R2,CURCOR
	ADDI	R2,P$GBUF+P$SSSZ+P$ESSZ+P$PSSZ+P$ASSZ+P$CSSZ
			; ADD CORE NEEDED BY GARBAGE AND OTHER STACKS
	HLRZ	R1,(R12)	; GET BUCKET TABLE SIZE
	JUMPG	R1,.+2	; SKIP IF SPECIFIED AND > 0
	MOVEI	R1,P$HSHS	; USE DEFAULT SIZE
	HRRM	R1,DOHASH	; SAVE IN HASHING OPERATION
	ADDI	R2,1(R1)	; ADD CORE NEEDED BY BUCKET TABLE
	CAMG	R2,.JBREL	; NEED TO EXPAND CORE?
	JRST	.+3	; NO
	JSP	R6,EXPCOR	; YES, TRY
	UFERR	4,R12	; CAN'T MAKE IT, ERROR
	MOVE	R0,.JBREL	; GET HIGHEST ADDRESS FOR USER
	MOVEM	R0,MAXCOR	; SAVE
	SUBI	R0,P$GBUF	; HIGHEST ADDRESS FOR FREE STORAGE
	MOVEM	R0,MAXFRE	; SAVE
	MOVEM	R0,.JBFF	; USE GARB STACK AREA FOR DUMMY BUFFERS
	HRLM	R0,.JBSA	; UPDATE JOB PARAMETERS
	HRLM	R0,.JBCOR
; INITIALIZE STACKS
	MOVNI	R7,4	; SET UP FOR FIVE STACKS
ILZSTK:	MOVE	R8,CSBA(R7)	; GET EXTENSION, INITIAL SIZE
	MOVEI	R0,(R8)	; INITIAL SIZE FOR STACK
	JSP	R6,S$$GNS	; GET NONRETURNABLE BLOCK
	MOVNI	R2,(R8)	; GET -(SIZE-2) INTO HU
	HRLI	R1,2(R2)
	MOVEM	R1,CSBA(R7)	; SAVE POINTER IN STACK BASE WORD
	HLRM	R8,(R1)	; SAVE STACK EXTENSION SIZE
	HRLI	R0,CSBA(R7)	; FORM REVERSE OF LAST STACK BLOCK WORD
	ADDI	R8,-1(R1)	; GET POINTER TO LAST WORD
	MOVSM	R0,(R8)	; STORE SIZE, PTR TO BASE WORD
	AOJLE	R7,ILZSTK	; LOOP FOR EACH STACK
	MOVE	SS,SSBA	; INITIALIZE SS
	MOVE	ES,ESBA	; INITIALIZE ES

; INITIALIZE CHANNEL TABLE
	SETZM	CHNTBL	; ZERO CHNTBL(0) - CHNTBL(15)
	MOVEI	R1,CHNTBL+1
	HRLI	R1,CHNTBL
	BLT	R1,CHNTBL+15

; INITIALIZE BUCKET TABLE
	HRRZ	R0,DOHASH	; GET BUCKET TABLE SIZE
	ADDI	R0,1	; +1 FOR BLOCK HEADER WORD
	JSP	R6,S$$GNS	; GET NONRETURNABLE BLOCK
	ADDI	R1,1	; POINTER TO FIRST BUCKET
	HRRM	R1,BUCKTB	; SAVE
	SETZM	(R1)	; ZERO ALL BUCKETS
	ADDI	R0,-2(R1)	; UP TO LAST
	HRLI	R1,1(R1)	; USING
	MOVS	R1,R1	; BLT WORD
	MOVE	R2,R0	; AND LAST LOC INDEX
	BLT	R1,(R2)

; INITIALIZE GLOBAL SYMBOLS
	MOVEI	R9,GLOBSY	; GET START OF GLOBAL SYMBOL BLOCK
	JSP	R10,S$$SYI	; DO INITIALIZATION

; INITIALIZE THE MAIN PROGRAM
	HRRZ	R10,(R12)	; GET PARAMETER BLOCK POINTER
	MOVEM	R10,PRGL	; SAVE IN PROGRAM LIST AS LAST
	HRLM	R10,PRGL	; AND FIRST PROGRAM
	MOVEI	R9,1(R10)	; SAVE PARBLK+1
	MOVEM	R9,PBLP	; AS CURRENT PROGRAM BLOCK
	JSP	R11,INIPR1	; INITIALIZE PROGRAM
	JRST	1(R12)	; RETURN
ILZEND:
; DEFINITIONS USED TO RECLAIM INITIALIZATION AREA
	SST=S$$ILZ	; SCRATCH AREA START
	SED=ILZEND	; SCRATCH AREA END
	DEFINE	VARDEF(N,S)	;;DEFINE SPACE FOR NAME N OF SIZE S
<	SST1=SST
	IFLE	SST+S-SED,	;;IF ENOUGH ROOM LEFT IN SCRATCH AREA
 <	N=SST			;;USE THE SCRATCH AREA
	SST1=SST+S>		;;AND INCREASE THE POINTER
	IFG	SST+S-SED,
 <N:	BLOCK	S>		;;OTHERWISE USE SPACE WHERE CALLED
	SST=SST1>

; WORD FORMAT DEFINITIONS
	DEFINE	SHD(T,S,P)	;;STORAGE BLOCK HEADER WORD
<	BYTE	(2)T(16)S(18)P>	;;TYPE, SIZE, POINTER

	DEFINE	SDC(S,C,N)	;;STRING DESCRIPTOR
<	POINT	7,[SHD	2,S,C	;;SIZE, CHARACTER COUNT
		ASCII/N/],35>	;;AND STRING

	DEFINE	NDC(D,P)	;;NAME DESCRIPTOR
<	BYTE	(4)4(2)D(12)0(18)P>	;;DEDICATION, POINTER

; DEFINE JFFO IF ASSEMBLY IS FOR PDP-6
	IFN	P$PDP6,
<	DEFINE	JFFO(REG,LOC)
<	JRST	[
	SETZ	REG'+1,
	JUMPE	REG,.+1
	EXCH	REG'+2,.
	MOVEM	REG,11(REG'+2)
	TLNE	REG,1B18
	JRST	8(REG'+2)
	LSH	REG,1
	AOJA	REG'+1,4(REG'+2)
	MOVE	REG,11(REG'+2)
	EXCH	REG'+2,.
	JRST	LOC
	0]>>
	SUBTTL	SYSTEM COMMON

	ENTRY	S$$FLP,S$$KWD,S$$CHT,S$$STB,S$$STS,S$$STP,S$$GLP
	ENTRY	S$$PGL,S$$LFC,S$$TMS,S$$PBP,S$$RTP,S$$NUL
	ENTRY	S$$INP,S$$INC,S$$OUT,S$$OUC,S$$TAC,S$$SJC,S$$SST,S$$PRL
	ENTRY	S$$TA1
	EXTERN	S$$SRT,S$$FRT,S$$NRT

	COMMENT/ SYSTEM COMMON
	DEFINES MOST VARIABLES, PARAMETERS, TABLES AND CONSTANTS
COMMONLY USED BY THE SYSTEM/

; ELEMENTS THAT MUST APPEAR FIRST IN THE SCRATCH AREA
	VARDEF	SSTT,1	; SYSTEM START TIME
	S$$SST=SSTT
	VARDEF	MINCOR,1	; LOW FREE CORE POINTER
	S$$LFC=MINCOR
	VARDEF	MAXCOR,1	; HIGH USER CORE POINTER
	VARDEF	MAXFRE,1	; HIGH FREE CORE POINTER
	VARDEF	CURCOR,1	; QUICKMODE CORE POINTER
	VARDEF	CHNTBL,16	; CHANNEL TABLE
	S$$CHT=CHNTBL

; STACK PARAMETERS
SSBA:	XWD	P$SSXT,P$SSSZ	; SS BASE WORD
ESBA:	XWD	P$ESXT,P$ESSZ	; ES BASE WORD
	S$$STB=ESBA
PSBA:	XWD	P$PSXT,P$PSSZ	; PS BASE WORD
ASBA:	XWD	P$ASXT,P$ASSZ	; AS BASE WORD
CSBA:	XWD	P$CSXT,P$CSSZ	; CS BASE WORD
	VARDEF	SSSA,1	; SS SAVED
	VARDEF	ESSA,1	; ES SAVED
	S$$STS=ESSA
	VARDEF	PSSA,1	; PS SAVED
	VARDEF	ASSA,1	; AS SAVED
	VARDEF	CSSA,1	; CS SAVED
SSPR:	XWD	0,0	; SS PREVIOUS
ESPR:	XWD	0,0	; ES PREVIOUS
	S$$STP=ESPR
PSPR:	XWD	0,0	; PS PREVIOUS
ASPR:	XWD	0,0	; AS PREVIOUS
CSPR:	XWD	0,0	; CS PREVIOUS

; GLOBAL PARAMETERS
	VARDEF	PRGL,1	; PROGRAM LIST
	S$$PRL=PRGL
S$$GLP:
GLST:	BYTE	(2)1,1(1)1(13)0(18)GLSTBB	; GLOBAL SYMBOL TBL DSCR
GLVL:	XWD	GLOBVR,GLOBVR	; VARIABLE BLOCK LIST
GLVX:	8		; NEXT GLOBAL VARIABLE INDEX
LTBL:	0		; LATEST TABLE NUMBER

; DYNAMIC PARAMETERS
	VARDEF	PRGLNK,1	; PROGRAM LINK
	S$$PGL=PRGLNK
	VARDEF	TIMR,1	; CURRENT STATEMENT START TIME
	S$$TMS=TIMR
	VARDEF	PBLP,1	; CURRENT PARAMETER BLOCK
	S$$PBP=PBLP
	VARDEF	FAIL,1	; FAILPOINT POINTER
	S$$FLP=FAIL
; SYSTEM VARIABLE STORAGE BLOCK (GLOBAL VARIABLES)
GLOBVR:	SHD	2,8,0	; 7 VARS
LOCINP:	0		; 'INPUT'
LOCINC:	0		; 'INPUTC'
LOCOUT:	0		; 'OUTPUT'
LOCOUC:	0		; 'OUTPUTC'
TMPA:	0		; TEMPORARY AC
	S$$TAC=TMPA
SUBJ:	0		; SUBJECT STRING FOR PATTERN MATCH
	S$$SJC=SUBJ
TMP1:	0		; TEMPORARY VALUE #1
	S$$TA1=TMP1

; SYSTEM SYMBOL BLOCK
GLOBSY:	SHD	2,33,-8	; HEADER WORD
	XWD	0,0	; 'INPUT' VARIABLE
	2B4
	SDC	2,5,INPUT
S$$INP:	NDC	0,-1
	XWD	0,0	; 'INPUTC' VARIABLE
	2B4
	SDC	3,6,INPUTC
S$$INC:	NDC	0,-2
	XWD	0,0	; 'OUTPUT' VARIABLE
	2B4
	SDC	3,6,OUTPUT
S$$OUT:	NDC	0,-3
	XWD	0,0	; 'OUTPUTC' VARIABLE
	2B4
	SDC	3,7,OUTPUTC
S$$OUC:	NDC	0,-4
	XWD	0,0	; 'RETURN' LABEL
	4B4
S$$RTP:	SDC	3,6,RETURN
	JRST	S$$SRT
	XWD	0,0	; 'FRETURN' LABEL
	4B4
	SDC	3,7,FRETURN
	JRST	S$$FRT
	XWD	0,0	; 'NRETURN' LABEL
	4B4
	SDC	3,7,NRETURN
	JRST	S$$NRT
	XWD	0,0	; 'END' LABEL
	4B4
	SDC	2,3,END
	JRST	S$$SXT

; GLOBAL SYMBOL TABLE BASE BLOCK
GLSTBB:	SHD	2,3,P$GSXT
	XWD	0,.+2
	XWD	0,0	; NO MORE ROOM LEFT, USE EXTENSION

; KEYWORDS
S$$KWD:
;	INITIAL		; NAME		TYPE	INDEX	PROTECTED?
STFC:	0		; &STFCOUNT	INT	0	YES
LSTN:	0		; &LASTNO	INT	1	YES
STNO:	0		; &STNO		INT	2	YES
FNCL:	0		; &FNCLEVEL	INT	3	YES
STCN:	0		; &STCOUNT	INT	4	YES
ERRT:	0		; &ERRTYPE	INT	5	YES
RTNT:	POINT 7,NULSTR,35 ;&RTNTYPE	STRING	6	YES
	POINT 7,ALPHAB,35 ;&ALPHABET	STRING	7	YES
ABND:	0		; &ABEND	INT	8	NO
ANCH:	0		; &ANCHOR	INT	9	NO
FULS:	0		; &FULLSCAN	INT	10	NO
STNT:	0		; &STNTRACE	INT	11	NO
MXLN:	P$MXLN		; &MAXLNGTH	INT	12	NO
STLT:	P$MXST		; &STLIMIT	INT	13	NO
ERLT:	0		; &ERRLIMIT	INT	14	NO
DENS:	P$DENS		; &DENSITY	INT	15	NO
KINP:	1		; &INPUT	INT	16	NO
KOUT:	1		; &OUTPUT	INT	17	NO
DUMP:	0		; &DUMP		INT	18	NO
SLFR:	0		; &SLOWFRAG	INT	19	NO

; SYSTEM CONSTANTS
NULSTR:	SHD	2,1,0	; NULL STRING
NULDSC:	POINT	7,NULSTR,35	; NULL DESCRIPTOR
	S$$NUL=NULDSC
	RPTC=0
ALPHAB:	SHD	2,27,128	; ALPHABET STRING
	REPEAT	25,<
	BYTE	(7)RPTC,RPTC+1,RPTC+2,RPTC+3,RPTC+4
	RPTC=RPTC+5>
	BYTE	(7)125,126,127
	SUBTTL	PROGRAM INITIALIZATION

	ENTRY	S$$IPR

	COMMENT/
CALL:	JSP	R11,S$$IPR	; WITH PARBLK PTR IN R10
	ADDS PROGRAM TO PROGRAM LIST, SETS INITIALIZATION FLAG, ADDS
VARIABLE STORAGE BLOCK, IF ANY, TO FRONT OF VARIABLE STORAGE BLOCK LIST
, CREATES TIMING BLOCK IF REQUIRED, AND INITIALIZES SYMBOLS, IF ANY/

S$$IPR:	MOVE	R9,PRGL	; GET FIRST,LAST PROGRAM POINTERS
	HRRM	R10,(R9)	; ADD CURRENT ONE TO END OF CHAIN
	HRRI	R9,(R10)	; NEW LAST PROG PTR
	MOVEM	R9,PRGL	; RESTORE
INIPR1:	HRLZI	R9,-1	; SET INITIALIZATION FLAG, END OF CHAIN
	EXCH	R9,(R10)	; AND FETCH VARIABLE STORAGE POINTER
	JUMPE	R9,INIPR2	; SKIP IF THERE IS NONE
	HLRZ	R8,GLVL	; FIRST BLOCK IN VAR BLOCK LIST
	HRRM	R8,(R9)	; IS NOW SECOND
	HRLM	R9,GLVL	; AND CURRENT IS FIRST
INIPR2:	HRRZ	R9,1(R10)	; GET NSTAT
	SETZ	R1,
	JUMPE	R9,INIPR3	; SKIP IF NO TIMING BLOCK NEEDED
	MOVEI	R0,1(R9)	; NUMBER OF WORDS NEEDED
	JSP	R6,S$$GNS	; GET NONRETURNABLE BLOCK
	HLLZS	(R1)	; CLEAR RH OF FIRST WORD (TOTTIM)
	HRLZI	R2,1(R1)	; BLT WORD
	HRRI	R2,2(R1)	; FOR REST OF BLOCK
	SETZM	1(R1)	; ZERO ALL WORDS
	ADDI	R9,(R1)	; UP TO END OF BLOCK
	BLT	R2,(R9)
INIPR3:	EXCH	R1,1(R10)	; SAVE TIMING BLOCK POINTER, IF
			; ANY, AND GET SYMBOL BLOCK POINTER
	TLNN	R1,^O777777	; ANY SYMBOLS?
	JRST	(R11)	; NO, RETURN
	AOS	R8,LTBL	; GET NEW TABLE NUMBER
	HRLM	R8,1(R10)	; SAVE IN PARAMETER BLOCK
	HRLZI	R8,(R8)	; PREPARE FOR SYMBOL INITIALIZATION
	HLRZ	R9,R1	; GET SYMBOL BLOCK POINTER
	JSP	R10,S$$SYI	; INITIALIZE SYMBOLS
	JRST	(R11)	; RETURN
	SUBTTL	UUO HANDLER

	ENTRY	S$$UUL,S$$UDU,S$$UPC

	COMMENT/
CALL:	UUO	AC,ADDR	; LEAVES PC IN S$$UPC AND UUO AC,EFFADR IN
	JOBUUO, AND JUMPS TO APPROPRIATE TABLE ENTRY WITH ALL AC'S OK.

	S$$UDU CAN BE USED TO DYNAMICALLY DEFINE NEW UUO'S, AND IT
CONTAINS XWD NEXT AVAILABLE OPCODE, TABLE ENTRY POINTER/

S$$UUL:	JSR	.	; USED TO INITIALIZE .JB41
	EXCH	R10,S$$UUL	; SAVE R10, GET PC
	HRRZM	R10,S$$UPC	; SAVE PC
	HLRZ	R10,.JBUUO	; GET OPCODE
	LSH	R10,-9
	HRLI	R10,S$$UUL	; SET UP FOR JRA
	JRA	R10,S$$UDU(R10)	; RESTORE R10 AND GO TO TABLE ENTRY
S$$UDU:	XWD	NXTUUO,.+NXTUUO	; NEXT ALLOWABLE UUO DEFINITION
	JRST	LUFERR	; UNCONDITIONALLY FATAL ERROR
	JRST	LCFERR	; CONDITIONALLY FATAL ERROR
	JRST	LFCALV	; FUNCTION CALL FOR VALUE
	JRST	LFCALN	; FUNCTION CALL FOR NAME
	JRST	LDASGN	; DEDICATED ASSIGNMENT
	JRST	LDCONC	; DEDICATED CONCATENATION
	JRST	LDICNV	; DEDICATED INTEGER CONVERSION
	JRST	LDRCNV	; DEDICATED REAL CONVERSION
	JRST	LAREFV	; ARRAY/TABLE REFERENCE FOR VALUE
	JRST	LAREFN	; ARRAY/TABLE REFERENCE FOR NAME

	NXTUUO=.-S$$UDU
	REPEAT	^O40-NXTUUO,
<	JRST	ERRUUO>	; REMAINING UUO'S INITIALLY UNDEFINED
ERRUUO:	MOVE	R10,[UFERR 1,S$$UPC]	; SET UP ERROR/TYPE POINTER
	MOVEM	R10,.JBUUO	; FAKE
	JRST	LUFERR	; UNCONDITIONALLY FATAL ERROR
; STORAGE
	VARDEF	S$$UPC,1
	SUBTTL	INTERRUPT HANDLER

	COMMENT/ THE FOLLOWING INTERRUPTS ARE TRAPPED:
PUSHDOWN OVERFLOW- THE STACK THAT HAS OVERFLOWED IS EXTENDED
MEMORY PROTECTION VIOLATION- INPUT OR OUTPUT IS PERFORMED IF INST.
	IS A MOVE OR MOVEM AND ILL ADDR IS AN INDEX IN ASSOC. TABLE
FLOATING POINT AND ARITH METIC OVERFLOW- DIVIDE CHECK OR ARITHMETIC
	OVERFLOW CAUSES UNCONDITIONALLY FATAL ERROR

	R1 IS SAVED IN .JBCNI/

INTRUP:	EXCH	R1,.JBCNI	; GET CONDITIONS AND SAVE R1
	ANDI	R1,^O220110	; MASK APPROPRIATE BITS
	CAIGE	R1,^O200000	; IS IT PUSHDOWN OVERFLOW?
	JRST	INTRU1	; NO
	SKIPN	GARBCL	; IS GARBAGE COLLECT FLAG ON?
	JRST	STKOVF	; NO, NORMAL STACK OVERFLOW
	JRST	GRBOVF	; YES, GARBAGE COLLECT STACK OVERFLOW
INTRU1:	CAIL	R1,^O20000	; IS IT MEMORY PROTECTION VIOLATION?
	JRST	VIOASO	; YES, GO DO I/O
	JSP	R1,.+1	; NO, ARITH OVERFLOW, GET FLAGS
	TLNE	R1,1B30	; IS NO DIVIDE OFF?
	UFERR	14,.JBTPC	; NO, DIVIDE CHECK ERROR
	UFERR	15,.JBTPC	; YES, ARITHMETIC OVERFLOW ERROR
	SUBTTL	STACK OVERFLOW

	COMMENT/ HANDLES OVERFLOW OF SS,ES,PS,AS,AND CS DUE TO A PUSH
OR A PUSHJ BY ACQUIRING A NEW STORAGE BLOCK EQUAL TO THE SIZE OF THE
CURRENT ONE PLUS THE EXTENSION SIZE, AND COPYING THE VALID CONTENTS.
THE OLD BLOCK IS RELEASED, THE STACK POINTER AND STACK BASE WORD CHANGED/

STKOVF:	MOVE	R1,.JBTPC	; SAVE NEXT INSTRUCTION ADDR
	HRRM	R1,STKRST+1	; IN CASE OF A NESTED INTERRUPT
	MOVE	R1,[MOVE SS,STKREG]	; GET INSTR TO SAVE SS
	JUMPGE	SS,STKSAV	; SS HAS OVERFLOWED
	SUB	R1,[Z SS-ES,]	; CHANGE TO SAVE ES (OR PS)
	JUMPGE	ES,STKSAV	; ES (OR PS) HAS OVERFLOWED
	SUB	R1,[Z ES-AS,]	; CHANGE TO SAVE AS
	JUMPGE	AS,STKSAV	; AS HAS OVERFLOWED
	SUB	R1,[Z AS-CS,]	; CHANGE TO SAVE CS
	JUMPGE	CS,STKSAV	; CS HAS OVERFLOWED
STKERR:	UFERR	1,STKRST+1	; ERROR, UNKKNOWN STACK OVERFLOW
STKSAV:	MOVEM	R1,STKRST	; EXECUTED TO RELOAD REGISTER ON RETURN
	TLO	R1,^O2000	; CHANGE TO A MOVEM INSTR
	XCT	R1	; AND EXECUTE IT
	MOVE	R1,.JBCNI	; RESTORE R1
	MOVEM	R9,STKSRG+9	; SAVE R0-R9
	HRRZI	R9,STKSRG
	BLT	R9,STKSRG+8
	MOVE	R7,STKREG	; GET CONTENTS OF STACK REGISTER
	MOVE	R8,1(R7)	; GET SIZE, STACK BASE WORD POINTER
	HLRZ	R0,R8	; GET STACK BLOCK SIZE
	MOVEI	R8,(R8)	; XWD 0,STACK BASE WORD POINTER
	CAIL	R8,SSBA	; IS IT ONE OF KNOWN STACK BASE WORDS?
	CAILE	R8,CSBA
	JRST	STKERR	; NO, ERROR
	MOVE	R9,(R8)	; GET STACK BASE WORD
	SUB	R7,R9	; FORM STACK POINTER - BASE
	MOVEM	R7,STKREG	; SAVE REL POINTER
	MOVE	R7,(R9)	; GET CONTENTS OF FIRST WORD OF STACK BLOCK
	TLC	R7,3B19	; CHANGE MARK BITS TO RETURNABLE
	ADDI	R0,(R7)	; ADD EXTENSION SIZE
	JSP	R6,S$$GNS	; GET NEW BLOCK
	MOVEM	R7,(R9)	; MAKE OLD BLOCK RETURNABLE
	HRRM	R7,(R1)	; SAVE EXTENSION SIZE
	HRL	R8,R0	; FORM LAST WORD OF NEW BLOCK WITH NEW SIZE
	MOVE	R2,R0	; GET NEW SIZE
	MOVNI	R3,-2(R2)	; GET -(NEWSIZE-2)
	HRLI	R1,(R3)	; FORM NEW BASE WORD
	MOVEM	R1,(R8)	; SAVE IN BASE WORD LOC
	ADDM	R1,STKREG	; UPDATE STACK POINTER WITH NEW BASE
	HRLI	R1,(R9)	; GET POINTER TO OLD BLOCK
	ADDI	R2,-1(R1)	; GET POINTER TO LAST WORD OF NEW BLOCK
	MOVEM	R8,(R2)	; SAVE SIZE, BASE WORD POINTER
	MOVE	R2,STKREG	; GET LAST VALID STACK ENTRY IN NEW
	AOBJP	R1,.+1	; BLOCK, AND START AT SECOND WORD OF OLD AND NEW
	BLT	R1,(R2)	; BLOCKS TO TRANSFER ALL VALID STACK ENTRIES
	HRLZI	R9,STKSRG	; RESTORE R0-R9
	BLT	R9,R9
STKRST:	.-.		; RESTORE STACK REGISTER
	JRST	.-.	; CONTINUE
; STORAGE
	VARDEF	STKREG,11	; TEMPORARY STACK REGISTER
	STKSRG=STKREG+1		; TEMPS FOR R0-R9
	SUBTTL	FREE STORAGE

	ENTRY	S$$GRS,S$$GNS,S$$MRS,S$$MNS,S$$GCL

	COMMENT/ THE FREE STORAGE SECTION PROVIDES EXTERNAL ENTRIES
FOR ACQUIRING RETURNABLE OR NONRETURNABLE BLOCKS, MAKING BLOCKS RETUR-
NABLE OR NONRETURNABLE, AND FOR FORCING A GARBAGE COLLECTION. IN ADDI-
TION, IT CONTAINS THE GARBAGE COLLECTION ROUTINES,AND TWO MODES OF
STORAGE ACQUISITION: THE FIRST, CALLED QUICKMODE, IS VERY EFFICIENT
AND OPERATES UNTIL THE INITIAL CORE ALLOCATION IS EXHAUSTED; THEN A
GARBAGE COLLECTION OCCURS, AND THE NORMAL MODE IS ENTERED, WHICH MAKES
USE OF AVAILABLE BLOCK LISTS AND EXPANDS CORE WHEN NECESSARY.

	GET RETURNABLE STORAGE
CALL:	JSP	R6,S$$GRS; WITH SIZE IN R0, RETURNS 0,PTR IN R1 WITH
	R0 UNCHANGED

	GET NONRETURNABLE STORAGE
CALL:	JSP	R6,S$$GNS	;SAME AS S$$GRS, BUT BLOCK IS MARKED
	SO THAT IT CAN'T BE COLLECTED

	MAKE RETURNABLE (NONRETURNABLE) STORAGE
CALL:	JSP	R6,S$$MRS(0R S$$MNS)	; WITH POINTER IN R1, MARKS
	BLOCK APPROPRIATELY, AND LEAVES R1 UNCHANGED

	FORCE GARBAGE COLLECTION
CALL:	JSP	R6,S$$GCL	; WITH 0 IN R0, FORCES GARBAGE COLLEC-
	TION, AND RETURNS TOTAL AMOUNT OF WORDS AVAILABLE IN R1 AND
	SIZE OF LARGEST AVAILABLE BLOCK IN R2/
; GET RETURNABLE AND NONRETURNABLE STORAGE
S$$GRS:	JSP	R2,QUICKM	; REPLACED WITH JSP R2,S$$GNS+1 IN NOR-
S$$GNS:	JSP	R2,QUICKM	; MAL MODE (AFTER FIRST GARB COL)
	SUBI	R2,S$$GRS	; FORM INDEX OF 1 OR 2
	JFFO	R0,.+1	; COUNT NUMBER OF LEADING ZEROS
	LSH	R1,1	; *2
	MOVEM	R1,SLOT1	; SAVE FIRST SLOT INDEX
GRBTRY:	HLRZ	R3,AVAIL(R1)	; GET SLOT COUNT
	SOJL	R3,NXTSIZ	; QUIT IF ZERO
	HLRZ	R4,AVAIL+1(R1)	; GET ROVER POINTER
	HLRZ	R5,(R4)	; GET BLOCK SIZE
	CAIG	R0,(R5)	; IS IT BIG ENOUGH?
	JRST	FOUNDS	; YES, USE THIS BLOCK
	SOJL	R3,NXTSIZ	; NO, QUIT IF SLOT COUNT WAS 1
TRYLOP:	HRRZ	R4,(R4)	; GET NEXT BLOCK POINTER
	CAIN	R4,AVAIL(R1)	; IS IT THE AVAIL ARRAY?
	HRRZ	R4,(R4)	; YES, GET NEXT BLOCK POINTER
	HLRZ	R5,(R4)	; NO, GET BLOCK SIZE
	CAIG	R0,(R5)	; IS IT BIG ENOUGH?
	JRST	[HLRZ	R3,AVAIL(R1)
		 SOJA	R3,FOUNDS]	; YES, GET SLOT COUNT - 1
	SOJGE	R3,TRYLOP	; DECREMENT SLOT COUNT, LOOP IF ANY LEFT
	HRLM	R4,AVAIL+1(R1)	; UPDATE ROVER POINTER
NXTSIZ:	SUBI	R1,2	; NEXT LARGER SLOT
	CAIGE	R1,40	; OFF THE END OF THE AVAIL ARRAY?
	JRST	GRBCOL	; YES, NO BLOCKS LEFT, DO GARBAGE COLLECTION
	HLRZ	R3,AVAIL(R1)	; NO, GET SLOT COUNT
	SOJL	R3,NXTSIZ	; QUIT IF ZERO
	HLRZ	R4,AVAIL+1(R1)	; GET ROVER POINTER
	HLRZ	R5,(R4)	; GET BLOCK SIZE
FOUNDS:	HRLM	R3,AVAIL(R1)	; UPDATE SLOT COUNT (OLD COUNT - 1)
	SOJL	R3,ALLGON	; SKIP ROVER UPDATE IF ZERO
	HRRZ	R3,(R4)	; GET NEXT BLOCK POINTER
	CAIN	R3,AVAIL(R1)	; IS IT THE AVAIL ARRAY?
	HRRZ	R3,(R3)	; YES, GET NEXT BLOCK POINTER
	HRLM	R3,AVAIL+1(R1)	; NO, UPDATE ROVER POINTER
ALLGON:	EXCH	R4,R1	; EXCHANGE SLOT INDEX, BLOCK POINTER
	HRLZ	R3,R0	; GET DESIRED BLOCK SIZE INTO LH
	LSH	R3,2	; SET MARK BITS IN BITS 0 AND 1
	LSHC	R2,-2
	EXCH	R3,(R1)	; EXCHANGE WITH FIRST WORD OF ACTUAL BLOCK
	MOVE	R2,1(R1)	; GET BACK LINK FROM ACTUAL BLOCK
	HRRM	R3,(R2)	; SET FORWARD LINK IN PREVIOUS BLOCK
	HRRM	R2,1(R3)	; SET BACK LINK IN NEXT BLOCK
	MOVEI	R3,(R5)	; GET ACTUAL BLOCK SIZE
	MOVE	R2,R0	; GET DESIRED BLOCK SIZE
	SUBI	R3,(R2)	; DIFFERENCE IN SIZE
	JUMPE	R3,(R6)	; RETURN IF ZERO
	ADDI	R2,(R1)	; REMAINDER BLOCK POINTER
	SKIPE	SLFR	; SKIP HEURISTIC IF &SLOWFRAG IS NOT ON
	CAME	R4,SLOT1	; IS THE CURRENT SLOT=INITIAL SLOT?
	CAIG	R3,1	; NO, ARE THERE < 2 WORDS LEFT?
	JRST	.+2	; SAME SLOT OR < 2 WORDS LEFT
	JRST	ADDLST	; NEITHER ADD REMAINDER BLOCK TO AVAIL LIST
	HRLZI	R4,1B19(R3)	; MAKE REMAINDER BLOCK INERT, WILL BE
	MOVEM	R4,(R2)	; COLLECTED LATER
	JRST	(R6)	; RETURN

; ADDLST ADDS A BLOCK TO THE APPROPRIATE AVAIL LIST.
; CALL:	JSP	R6,ADDLST	; WITH PTR IN R2 AND SIZE IN R3, LEAVES
;  R0 AND R1 UNCHANGED
ADDLST:	JFFO	R3,.+1	; COUNT NUMBER OF LEADING ZEROS
	LSH	R4,1	; *2, = SLOT INDEX OF BLOCK
	MOVEI	R4,AVAIL(R4)	; POINTER TO AVAIL ARRAY ENTRY
	MOVE	R5,(R4)	; SLOT COUNT, FIRST BLOCK POINTER
	HRRM	R2,1(R5)	; SET BACK LINK OF FIRST BLOCK
	HRLI	R3,(R5)	; GET FIRST BLOCK POINTER IN LH
	MOVSM	R3,(R2)	; SET SIZE, FORWARD LINK IN NEW BLOCK
	HRRZM	R4,1(R2)	; SET BACK LINK IN NEW BLOCK
	AOBJP	R5,.+1	; INCREMENT SLOT COUNT
	HRRI	R5,(R2)	; SET FIRST BLOCK PTR TO NEW BLOCK
	MOVEM	R5,(R4)	; AND SAVE IN AVAIL ARRAY
	HRLM	R2,1(R4)	; SET ROVER POINTER TO NEW BLOCK
	JRST	(R6)	; RETURN

; MAKE RETURNABLE AND NONRETURNABLE STORAGE
S$$MRS:	JSP	R2,S$$MNS+1	; RETURNABLE, INDEX=1
S$$MNS:	JSP	R2,S$$MNS+1	; NONRETURNABLE, INDEX=2
	MOVEI	R3,(R1)	; GET PTR WITH LH=0
	CAML	R3,MINCOR	; BELOW MINIMUM?
	CAMLE	R3,MAXCOR	; OR ABOVE MAXIMUM?
	JRST	(R6)	; YES, FORGET IT
	SUBI	R2,S$$MRS	; NO, FORM INDEX
	DPB	R2,MRKPTR	; STORE INTO MARK BITS
	JRST	(R6)	; RETURN
MRKPTR:	POINT	2,(R1),1	; FIRST TWO BITS POINTED TO BY R1

; FORCE GARBAGE COLLECTION
S$$GCL:	MOVEM	R0,BLSIZE	; SAVE SIZE
	JRST	QUICKO+3	; INITIALLY QUICKMODE, LATER CHANGED TO
		; JRST GRBCOL+2
; QUICKMODE STORAGE ACQUISITION ROUTINES, WHICH OVERLAY THEMSELVES
; WITH THE AVAIL LIST WHEN SWITCHING MODES
	AVAIL=.-36	; DEFINE REAL PART OF AVAIL LIST AS STARTING HERE
QUICKM:	SUBI	R2,S$$GRS	; FORM MARK BITS
	MOVE	R1,CURCOR	; GET CURRENT LOCATION
	MOVE	R3,R0	; GET SIZE
	ADDI	R3,(R1)	; COMPUTE NEXT LOCATION
	CAMLE	R3,MAXFRE	; WITHIN BOUNDS?
	JFFO	R0,QUICKO	; NO, QUICKMODE OVERFLOW
	MOVEM	R3, CURCOR	; YES, NEW CURRENT LOC
	IOR	R0,MRKTB1(R2)	; SET MARK BITS
	HRLZM	R0,(R1)	; STORE MARK BITS, SIZE IN LH
	ANDI	R0,^O177777	; CLEAR MARK BITS
	JRST	(R6)	; RETURN
QUICKO:	LSH	R1,1	; COMPUTE SLOT
	MOVEM	R0,BLSIZE	; SAVE SIZE
	MOVEM	R2,BLTYPE	; SAVE MARK TYPE
	EXCH	R1,SLOT1	; SAVE SLOT NUMBER, GET CURCOR
	MOVE	R3,MAXFRE	; DETERMINE AMOUNT LEFT
	SUBI	R3,(R1)
	HRLZI	R4,1B19(R3)	; CREATE INERT BLOCK
	MOVEM	R4,(R1)	; STARTING AT CURRENT LOC
	MOVEI	R3,S$$GNS+1	; UPDATE ENTRY POINTS
	HRRM	R3,S$$GRS
	HRRM	R3,S$$GNS
	MOVE	R5,AVLWRD	; GET INDEX WORD FOR AVAIL INITIALIZATION
	HRLZI	R4,AVLOOP	; MOVE AVLOOP INTO R0-R4
	BLT	R4,R4
	MOVEM	R4,S$$GCL+1	; UPDATE GARB COL ENTRY
	JRST	0	; START LOOP
AVLOOP:	PHASE	0
	HRRZM	R5,(R5)	; R0: STORE FORWARD LINK
	HRRZM	R5,1(R5)	; R1: STORE BACKWARD LINK
	AOBJN	R5,.+1	; R2: BUMP COUNT
	AOBJN	R5,.-3	; R3: BUMP COUNT, LOOP IF NOT YET FINISHED
	JRST	GRBCOL+2	; R4: FINISHED, PROCEED WITH GARB COL
	DEPHASE
AVLWRD:	XWD	-34,AVAIL+36	; PRESET 34 WORDS WITH FORWARD AND BACK
	BLOCK	AVAIL+70-.	; ALLOW FOR FULL 34 WORDS
GARBCL:	0	; USE BOTH AS FLAG AND 35TH WORD (SIZE 1)
	MRKTB1=.-1
	1B19	; MARK BITS=1
	2B19	; MARK BITS=2
	COMMENT/ GARBAGE COLLECTION
SAVE SIZE, TYPE, AND LINK. SET GARBCL FLAG AND INITIALIZE GARBAGE STACK.
MARK BLOCKS POINTED TO BY PROGRAM VARIABLES, GLOBAL VARIABLES, AND
VALUES ON ES, AND BY ELEMENTS OF NONTERMINAL DATATYPE VALUES. COLLECT
ALL UNUSED BLOCKS AND RETURN THEM TO THE AVAIL LIST, COUNTING THE TOTAL
CORE AVAILABLE AND RETAINING THE LARGEST AVAILABLE BLOCK SIZE FOUND.
GET THE BLOCK (IF REQUESTED), EXPANDING CORE IF NECESSARY. COMPUTE
DENSITY EXTENSION, EXPANDING CORE IF NECESSARY. RESET GARBCL FLAG AND
RETURN/

GRBCOL:	MOVEM	R0,BLSIZE	; SAVE BLOCK SIZE
	MOVEM	R2,BLTYPE	; SAVE MARK TYPE
	MOVEM	R6,BLLINK	; SAVE PROGRAM LINK
	SETOM	GARBCL	; SET GARBAGE COLLECTION FLAG
	MOVN	R6,GARSIZ	; SET UP GARBAGE STACK (FOR MARKING)
	HRL	R6,MAXFRE	; IN R6, RUNNING FROM MAXFRE TO .JBREL,
	MOVS	R6,R6	; OF SIZE GARSIZ+1
	SUB	R6,[XWD 1,1]	; IOWD GARSIZ+1,MAXFRE
; START MARKING BY DETERMINING NUMBER OF ELEMENTS ON ES AND MARKING THEM
	HRLZI	R0,1B18	; MARK BIT FOR USED BLOCKS
	MOVN	R5,ESSA	; GET - ES SAVED -(M,M)
	MOVE	R4,ESBA	; AND ES BASE
	HLRE	R1,ES	; GET -NO OF REMAINING ELEMENTS ON ES
	MOVN	R1,R1	; MAKE POSITIVE
	JUMPL	R1,GETESB	; IF <0, MUST BE IN FORTRAN, USE ES SAVED
	ADDI	R1,1(ES)	; ADDRESS OF LAST WORD OF STACK
	CAMLE	R1,MAXCOR	; WITHIN CORE BOUNDS?
	JRST	GETESB	; NO, MUST BE IN FRORTRAN, USE ES SAVED
	HRRZ	R2,(R1)	; GET BASE WORD POINTER
	CAIE	R2,ESBA	; DOES BASE WORD POINTER POINT TO ES BASE WORD?
	JRST	GETESB	; NO, ES IS NOT CURRENT, USE ES SAVED
	MOVN	R5,ES	; YES, COMPUTE - ES CURRENT
	ADD	R5,R4
GETESB:	HRRI	R5,(R4)	; -M, PTR TO FIRST ENTRY
	AOBJP	R5,.+2	; SKIP IF NOTHING ON STACK
	PUSHJ	R6,MRKMLT	; MARK EACH VALUE FROM BOTTOM TO TOP
; MARK VALUES OF EACH VARIABLE ON VARIABLE BLOCK LIST
	HLRZ	R1,GLVL	; GET FIRST BLOCK POINTER
MRKGLV:	PUSH	R6,(R1)	; SAVE NEXT BLOCK POINTER
	HLRZ	R5,(R1)	; GET -(BLOCKSIZE-1) INTO RH
	MOVNI	R5,-1B18-1(R5)
	HRLI	R5,1(R1)	; AND BLOCK PTR + 1 IN LH
	MOVS	R5,R5	; SWITCH
	PUSHJ	R6,MRKMLT	; MARK EACH VALUE IN BLOCK
	POP	R6,R1	; RESTORE NEXT BLOCK POINTER
	TRNE	R1,-1	; IS IT ZERO?
	JRST	MRKGLV	; NO, LOOP FOR EACH VARIABLE BLOCK ON CHAIN
; CORE MAY HAVE EXPANDED DURING MARKING PHASE
	MOVE	R1,.JBREL	; HAS CORE EXPANDED?
	CAMN	R1,MAXCOR
	JRST	STRAVL	; NO, SKIP
	SUB	R1,GARSIZ	; YES, COMPUTE NEW MAXFRE
	EXCH	R1,MAXFRE	; EXCHANGE WITH OLD ONE
	MOVE	R2,MAXFRE	; COMPUTE DIFFERENCE
	SUBI	R2,(R1)
	HRLZI	R2,1B19(R2)	; CREATE FIRST WORD OF INERT BLOCK
	MOVEM	R2,(R1)	; BETWEEN OLD AND NEW VALUES OF MAXFRE
; START COLLECTION, INITIALIZE PARAMETERS
STRAVL:	TLO	R0,1	; PSEUDO 1-WORD NONRETURNABLE BLOCK
	MOVEM	R0,@MAXFRE	; MARK MAXFRE TO DELIMIT COLLECTION AREA
	SETZM	AVLCOR	; TOTAL CORE AVAILABLE
	SETZM	BIGBLK	; BIGGEST BLOCK AVAILABLE
	SETZM	LSTBLK	; LAST AVAILABLE BLOCK POINTER
	SETZ	R0,	; INITIAL SIZE
	MOVE	R1,MINCOR	; INITIAL PTR
; ACCUMULATION LOOP, CLEAR ACCUMULATION PARAMETERS
CLRAVL:	SETZM	AVLPTR	; AVAILABLE BLOCK POINTER
	SETZM	AVLSIZ	; AVAILABLE BLOCK SIZE
	SETZM	AVLCNT	; AVAILABILITY INDICATOR
; CONSECUTIVE BLOCK LOOP, INCREMENT POINTER
NXTAVL:	ADD	R1,R0	; PTR_PTR+SIZE
	CAMLE	R1,MAXFRE	; IS PTR > MAXFRE?
	JRST	COLFIN	; YES, STOP COLLECTING
	SETZ	R2,	; GET MARK TYPE OF PTR
	HLLZ	R3,(R1)
	LSHC	R2,2
	LSH	R3,-2	; GET SIZE OF POINTER
	HLRZ	R0,R3
	JRST	.+1(R2)	; JUMP TO APPROPRIATE ACTION
	JRST	AVLAVL	; MARK=00, ON AVAIL LIST
	JRST	AVLFRE	; MARK=01, AVAILABLE
	JRST	GATHER	; MARK=10, NONRETURNABLE
	TLO	R3,1B19	; MARK=11, MARKED, RESET TO 01
	HLLM	R3,(R1)	; AND STORE WITH SIZE IN FIRST WORD OF BLOCK
GATHER:	MOVE	R2,AVLCNT	; GET AVAILABILITY INDICATOR
	JUMPE	R2,NXTAVL	; IF 0, GO ON TO NEXT BLOCK
	JUMPL	R2,UPDAVL	; IF<0, UPDATE STATISTICS
	MOVE	R3,AVLSIZ	; IF>0, GET ACCUMULATED SIZE
	CAIN	R3,1	; IS IT JUST 1?
	JRST	CLRAVL	; YES, IGNORE BLOCK AS IF IT WERE MARKED
	MOVE	R2,AVLPTR	; NO, GET ACCUMULATED BLOCK POINTER
	CAIL	R3,1B19	; IS BLOCK TOO BIG?
	JSP	R6,ADDBBB	; YES, BREAK IT UP
	JSP	R6,ADDLST	; NO, ADD TO AVAIL LIST
UPDAVL:	MOVE	R3,AVLSIZ	; GET ACCUMULATED SIZE
	ADDM	R3,AVLCOR	; ADD TO TOTAL CORE AVAILABLE
	MOVE	R2,AVLPTR	; GET ACCUMULATED BLOCK POINTER
	MOVEM	R2,LSTBLK	; SAVE PTR AS LAST BLOCK AVAILABLE
	CAMLE	R3,BIGBLK	; BIGGER THAN BIGGEST?
	MOVEM	R3,BIGBLK	; YES, USE INSTEAD
	JRST	CLRAVL	; LOOP
AVLAVL:	SKIPE	AVLCNT	; IS INDICATOR 0?
	JRST	REMPRE	; NO, DISCONNECT PRESENT BLOCK
	MOVNM	R0,AVLCNT	; YES, SET INDICATOR<0
BEGAVL:	MOVEM	R0,AVLSIZ	; INITIALIZE SIZE
	MOVEM	R1,AVLPTR	; AND BLOCK POINTER FOR ACCUMULATION
	JRST	NXTAVL	; LOOP
AVLFRE:	SKIPE	R2,AVLCNT	; IS INDICATOR 0? (R2_INDICATOR)
	JRST	REMPR1	; NO, GO ACCUMULATE
	MOVEM	R0,AVLCNT	; YES, SET INDICATOR>0
	JRST	BEGAVL	; INITIALIZE ACCUMULATION
REMPRE:	MOVE	R3,R0	; PRESENT BLOCK SIZE
	MOVE	R2,R1	; PRESENT BLOCK POINTER
	JSP	R6,REMLST	; DISCONNECT
	MOVE	R2,AVLCNT	; RELOAD INDICATOR
REMPR1:	JUMPGE	R2,REMPR2	; SKIP OVER IF >0
	MOVE	R2,AVLPTR	; LAST PTR
	MOVE	R3,AVLSIZ	; LAST SIZE
	JSP	R6,REMLST	; DISCONNECT
	MOVEM	R0,AVLCNT	; SET INDICATOR>0
REMPR2:	ADDM	R0,AVLSIZ	; INCREASE AVAILABLE BLOCK SIZE
	JRST	NXTAVL	; LOOP

; REMLST REMOVES A BLOCK FROM THE AVAIL LIST
; CALL:	JSP	R6,REMLST	; WITH POINTER IN R2 AND SIZE IN R3,
;  LEAVES R0 AND R1 UNCHANGED
REMLST:	MOVE	R4,(R2)	; FORWARD LINK
	MOVE	R5,1(R2)	; BACK LINK
	HRRM	R5,1(R4)	; BACK LINK IN FORWARD BLOCK
	HRRM	R4,(R5)	; FORWARD LINK IN BACK BLOCK
	JFFO	R3,.+1	; COMPUTE SLOT INDEX
	LSH	R4,1
	HRLZI	R5,-1	; DECREMENT SLOT COUNT
	ADDB	R5,AVAIL(R4)	; AND GET FIRST BLOCK PTR
	HRLM	R5,AVAIL+1(R4)	; RESET ROVER POINTER TO FIRST BLOCK
	JRST	(R6)	; RETURN

; ADDBBB ADDS THE PIECES OF AN OVERSIZE BLOCK TO THE AVAIL LIST
; CALL:	JSP	R6,ADDBBB	; WITH POINTER IN R2 AND SIZE IN R3,
;	JSP	R6,ADDLST	; LEAVES R0 AND R1 UNCHANGED
ADDBBB:	HRRM	R6,BBBRET	; SAVE LINK
BBBLOP:	MOVEI	R4,(R3)	; GET SIZE
	SUBI	R4,1B19-1	; REDUCE IT BY MAXIMUM PERMISSIBLE
	HRRM	R4,LODSIZ	; SAVE REDUCED SIZE
	MOVEI	R4,(R2)	; GET PTR
	ADDI	R4,1B19-1	; NEXT POINTER
	HRRM	R4,LODPTR	; SAVE IT
	MOVEI	R3,1B19-1	; SIZE OF CURRENT BLOCK
	JSP	R6,ADDLST	; ADD TO AVAIL LIST
LODSIZ:	MOVEI	R3,.-.	; RESTORE SIZE
LODPTR:	MOVEI	R2,.-.	; RESTORE POINTER
	CAIL	R3,1B19	; IS SIZE STILL TOO BIG?
	JRST	BBBLOP	; YES, LOOP
	CAILE	R3,1	; NO, IS SIZE>1?
BBBRET:	JRST	.-.	; YES, RETURN AND DO A\DDLST
	AOS	R6,.-1	; BUMP RETURN LINK BEYORD ADDLST
	JUMPE	R3,(R6)	; RETURN IF ZERO
	HRLZI	R5,1B19+1	; CREATE INERT BLOCK OF SIZE 1
	MOVEM	R5,(R2)
	JRST	(R6)	; RETURN
; COLLECTION OVER, GET DESIRED BLOCK
COLFIN:	MOVE	R0,BLSIZE	; GET BLOCK SIZE
	JUMPE	R0,DNSCHK	; IF 0 (FORCED COLLECTION) GO TO DENSITY
	CAMLE	R0,BIGBLK	; IS SIZE>LARGEST AVAILABLE?
	JRST	MORCOR	; YES, MUST EXPAND CORE
	MOVE	R1,SLOT1	; NO, GET SLOT INDEX
	MOVE	R2,BLTYPE	; AND MARK TYPE
	JSP	R6,GRBTRY	; SIMULATE GET BLOCK CALL
	MOVEM	R1,BLPOIN	; SAVE POINTER
	JRST	DNSCHK	; GO ON TO DENSITY CHECK
; EXPAND CORE TO GET ENOUGH FOR DESIRED BLOCK
MORCOR:	MOVE	R2,MAXFRE	; GET FREE CORE TOP BOUNDARY
	HLRZ	R3,@LSTBLK	; GET SIZE OF LAST BLOCK MADE AVAILABLE
	SUBI	R2,(R3)	; AND SUBTRACT FROM TOP BOUNDARY
	CAME	R2,LSTBLK	; IS IT THE SAME LOC AS LAST BLOCK?
	JRST	MORCR1	; NO, FORGET IT
	MOVEM	R2,MAXFRE	; YES, MOVE BOUNDARY DOWN
	SUBM	R3,AVLCOR	; SUBTRACT SIZE FROM TOTAL CORE AVAILABLE
	MOVNS	AVLCOR
	JSP	R6,REMLST	; DISCONNECT, TO BE USED AS FIRST PART
				; OF NEW ONE
MORCR1:	MOVE	R2,MAXFRE	; COMPUTE NEW MAX CORE BOUNDARY
	ADD	R2,R0	; NEEDED FOR NEW BLOCK
	ADD	R2,GARSIZ	; AND GARBAGE STACK
	JSP	R6,EXPCOR	; EXPAND CORE
	UFERR	4,PRGLNK	; ERROR IF CANNOT
	MOVE	R2,MAXFRE	; PTR TO NEW BLOCK
	HRRZ	R3,R0	; FORM FIRST WORD WITH MARK BITS AND SIZE
	MOVE	R4,BLTYPE
	IOR	R3,MRKTB1(R4)
	HRLZM	R3,(R2)
	MOVEM	R2,BLPOIN	; SAVE POINTER
	ADD	R2,R0	; FIRST AVAILABLE LOC
	MOVE	R3,.JBREL	; COMPUTE LAST AVAILABLE LOC
	SUB	R3,GARSIZ
	MOVEM	R3,MAXFRE	; SAVE
	SUBI	R3,(R2)	; COMPUTE SIZE IN BETWEEN
	CAIG	R3,1	; IS IT >1?
	JRST	SMLEXT	; NO, IGNORE OR MAKE INERT
	MOVEM	R2,LSTBLK	; YES, SAVE AS LAST AVAILABLE BLOCK
	ADDM	R3,AVLCOR	; ADD TO AVAILABLE STORAGE
	CAMLE	R3,BIGBLK	; BIGGER THAN BIGGEST BLOCK?
	MOVEM	R3,BIGBLK	; YES, USE INSTEAD
	JSP	R6,ADDLST	; ADD TO AVAIL LIST
	JRST	DNSCHK	; GO DO DENSITY CHECK
SMLEXT:	JUMPE	R3,DNSCHK	; SKIP IF ZERO
	HRLZI	R4,1B19+1	; MAKE INERT BLOCK OF 1
	MOVEM	R4,(R2)
; DENSITY CHECK: IF DENSITY IS GREATER THAN SPECIFIED BY &DENSITY
; KEYWORD, CORE IS EXPANDED AS FAR AS POSSIBLE TO ACCOMODATE REQUIREMENT.
;  FORMULA IS: EXT_((100-&DENSITY)*(MAXFRE-MINCOR)-100*AVLCOR)/&DENSITY
; IF EXT>0, EXTEND CORE BY THAT AMOUNT, IF POSSIBLE. IF EXT<0 OR =0,
; REQUIREMENTS ARE ALREADY MET BY CURRENT CORE SIZE
DNSCHK:	MOVE	R2,DENS	; GET KEYWORD VAL
	CAILE	R2,100	; IS IT >100
	MOVEI	R2,100	; YES, 100 IS ENOUGH
	CAIGE	R2,1	; IS IT <1
	MOVEI	R2,1	; YES, MUST BE AT LEAST 1
	MOVEM	R2,DENS	; RESET KEYWORD IF NECESSARY
	SUBI	R2,100	; COMPUTE FORMULA
	MOVE	R3,MINCOR
	SUB	R3,MAXFRE
	IMUL	R2,R3
	MOVE	R3,AVLCOR
	IMULI	R3,100
	SUB	R2,R3
	IDIV	R2,DENS	; RESULT IN R2
	JUMPLE	R2,NOTEXT	; DON'T EXTEND UNLESS >0
	ADD	R2,.JBREL	; NEW MAX CORE LIMIT
	CAIL	R2,^O776000	; INTO LAST 1K BLOCK?
	MOVEI	R2,^O775777	; YES, CAN'T GO THERE
	CORE	R2,	; TRY TO EXPAND
	JRST	PRTEXT	; ONLY PARTIAL EXPANSION
PRTEXR:	MOVE	R2,MAXFRE	; GET LAST FREE CORE MAX
	MOVE	R3,.JBREL	; COMPUTE LATEST
	SUB	R3,GARSIZ
	MOVEM	R3,MAXFRE	; SAVE
	SUBI	R3,(R2)	; SIZE OF BLOCK IN BETWEEN
	ADDM	R3,AVLCOR	; ADD TO AVAILABLE CORE
	CAMLE	R3,BIGBLK	; BIGGER THAN BIGGEST?
	MOVEM	R3,BIGBLK	; YES, USE INSTEAD
	CAIL	R3,1B19	; MAKE SURE IT IS NOT TOO BIG
	JSP	R6,ADDBBB	; TOO BIG, BREAK IT UP
	JSP	R6,ADDLST	; OK, ADD TO AVAIL LIST
; FINISH UP BY TESTING FOR ANY CORE EXPANSION AND RESETTING PARAMETERS
NOTEXT:	MOVE	R2,.JBREL	; GET NEW CORE BOUNDARY
	CAMN	R2,MAXCOR	; SAME AS OLD?
	JRST	GRBFIN	; YES, SKIP
	MOVEM	R2,MAXCOR	; NO, UPDATE PARAMETERS
	MOVE	R2,MAXFRE
	MOVEM	R2,.JBFF
	HRLM	R2,.JBSA
	HRLM	R2,.JBCOR
GRBFIN:	JUMPE	R0,GCLFIN	; DIFFERENT RESULTS IF FORCED COLLECTION
	MOVE	R1,BLPOIN	; LOAD BLOCK POINTER (SIZE ALREADY IN R0)
	SETZM	GARBCL	; CLEAR GARBAGE COLLECT FLAG
	AOS	STATV+1	; INCREMENT GARBAGE COLLECTION COUNT
	JRST	@BLLINK	; RETURN
GCLFIN:	MOVE	R1,AVLCOR	; GET TOTAL CORE AVAILABLE
	MOVE	R2,BIGBLK	; AND BIGGEST BLOCK
	JRST	GRBFIN+2	; AND EXIT
; PARTIAL CORE EXTENSION, SWITCH DENSITY CHECK AND CORE EXPANSION CHECK
; OUT ONCE CORE HAS REACHED SYSTEM-ALLOWED LIMIT
PRTEXT:	MOVE	R3,NOTEXT+2	; GET [JRST GRBFIN]
	MOVEM	R3,DNSCHK	; SWITCH OUT INTERVENING CODE
	LSH	R2,10	; NUMBER OF CORE BLOCKS*^O2000
	SUBI	R2,1	; -1=LAST WORD
	CAME	R2,.JBREL	; ANYTHING LEFT TO GAIN?
	CORE	R2,	; YES, EXTEND CORE
	JRST	NOTEXT	; NO, OR ERROR, SKIP TO FINISH
	JRST	PRTEXR	; ADD NEW CORE TO SYSTEM
	COMMENT/ MARK MULTIPLE ELEMENT BLOCK
CALL:	PUSHJ	R6,MRKMLT	; WITH -COUNT,FIRST PTR IN R5
	IF A VALUE POINTS TO A FREE STORAGE BLOCK THAT IS NOT MARKED,
IT IS MARKED. IN ADDITION, IF IT IS ITSELF A MULTIPLE ELEMENT BLOCK,
MRKMLT IS CALLED RMCURSIVELY ON IT. R0 CONTAINS 1B0, USED FOR MARKING,
AND IS UNCHANGED/

MRKMLT:	MOVE	R2,(R5)	; GET NEXT ELEMENT DESCRIPTOR
	JUMPL	R2,MRKLOP	; LOOP IF INTEGER OR REAL
	HRRZI	R3,(R2)	; GET DESCR PTR
	CAML	R3,MINCOR	; IS IT WITHIN FREE STORAGE BOUNDS?
	CAML	R3,MAXFRE
	JRST	MRKLOP	; NO, LOOP
	SKIPGE	R4,(R3)	; IS IT ALREADY MARKED? (R4_FIRST WORD)
	JRST	MRKLOP	; YES, LOOP
	SETZ	R1,	; NO
	LSHC	R1,4	; GET DESCR TYPE
	CAIN	R1,4	; IS IT NAME?
	JRST	MRKLOP	; YES, LOOP
	IORM	R0,(R3)	; NO, MARK
	JUMPE	R1,MRKLOP	; LOOP IF STRING
	PUSH	R6,R5	; SAVE BLOCK INDEX, PTR
	XCT	MRKDSC-5(R1)	; PERFORM MARKING PER DESCR TYPE
	POP	R6,R5	; RESTORE BLOCK INDEX, POINTER
MRKLOP:	AOBJN	R5,MRKMLT	; LOOP IF MORE ELEMENTS
	POPJ	R6,	; OR RETURN
; THREE DIFFERENT MULTIPLE ELEMENT DESCRIPTOR TYPES
MRKDSC:	PUSHJ	R6,MRKART	; ARRAY OR TABLE
	JRST	MRKPAT	; PATTERN
	JRST	MRKDAT	; PROGRAMMER-DEFINED DATATYPE
; ARRAY OR TABLE BLOCK
MRKART:	JUMPL	R2,MRKTAB	; DESCRIPTOR BIT 4 = 1, IS TABLE
	SUB	R6,[XWD 1,1]	; ERASE PUSHJ
	MOVE	R5,(R4)	; GET FIRST WORD OF PROTOTYPE BLOCK
	JUMPL	R5,MRKCOM	; SKIP IF PROTOTYPE ALREADY MARKED
	IORM	R0,@(R5)	; MARK PROTOTYPE STRING
	IORM	R0,(R4)	; MARK PROTOTYPE BLOCK
MRKCOM:	HRLZI	R5,(R3)	; GET BLOCK POINTER INTO LH
	HRRI	R5,MRKCNT	; GET 'CONTINUE MARKING' LAB INTO RH
	EXCH	R5,(R6)	; SIMULATE PUSHJ, AND RESTORE R5
	JRST	MRKLOP	; CONTINUE LOOP
MRKCNT:	HLRZ	R5,1(R6)	; NOW MARK ELEMENTS OF BLOCK, GET PTR
	HLRZ	R4,(R5)	; GET -(SIZE) INTO LH OF R5
	TRZ	R4,3B19
	MOVNI	R4,(R4)
	HRLI	R5,(R4)
	AOBJN	R5,MRKMLT	; GO MARK
	POPJ	R6,	; THIS SHOULN'T HAPPEN, BUT QUIT JUST IN CASE
; TABLE BLOCK
MRKTAB:	ADDI	R3,2	; PTR TO EXTENSION WORD OF BASE BLOCK
	PUSH	R6,R3	; SAVE
	HLRZ	R5,-1(R3)	; COMPUTE NEXT AVAILABLE ENTRY POINTER
	MOVE	R4,-1(R3)
	ADDI	R5,(R4)
	PUSH	R6,R5	; SAVE
	HLRZ	R5,(R3)	; COMPUTE END OF CURRENT BLOCK
	ADDI	R5,1(R3)
	PUSH	R6,R5	; SAVE
	MOVEI	R5,1(R3)	; STARTING ENTRY POINTER FOR CURRENT BL
TBMLOP:	CAMN	R5,-1(R6)	; REACHED NEXT AVAILABLE ENTRY?
	JRST	TBMFIN	; YES, FINISHED WITH WHOLE TABLE
	CAMN	R5,(R6)	; NO, REACHED END OF CURRENT BLOCK?
	JRST	TBMNXT	; YES, GO ON TO EXTENSION
	PUSH	R6,R5	; NO, SAVE MARKING POINTER
	ADD	R5,[XWD -2,2]	; SET UP TO MARK KEY AND VALUE DESCRS
	PUSHJ	R6,MRKMLT
	POP	R6,R5	; RESTORE MARKING POINTER
	ADDI	R5,4	; POINT TO NEXT ENTRY
	JRST	TBMLOP	; LOOP, WITH R5=0,NEXT ENTRY PTR
TBMNXT:	HRRZ	R3,@-2(R6)	; GET PTR TO EXT WORD OF EXT BLOCK
	ADDI	R3,1
	MOVEM	R3,-2(R6)	; SAVE BACK IN STACK
	IORM	R0,-1(R3)	; MARK EXTENSION BLOCK
	HLRZ	R5,(R3)	; COMPUTE END OF CURRENT BLOCK
	ADDI	R5,1(R3)
	MOVEM	R5,(R6)	; SAVE BACK IN STACK
	JRST	TBMLOP-1	; RESTART LOOP
TBMFIN:	SUB	R6,[XWD 3,3]	; RESET STACK PTR
	POPJ	R6,	; RETURN
; PATTERN BLOCK
MRKPAT:	MOVEI	R5,-1(R4)	; GET PTR TO FIRST WORD OF PATTERN BLOCK
	CAML	R5,MINCOR	; IS IT WITHIN FREE STORAGE BOUNDS?
	IORM	R0,(R5)	; YES, MARK IT
	JRST	MRKCOM	; NO, AND CONTINUE
; DATATYPE BLOCK
	MRKDAT=MRKCOM	; PROTOTYPE STRING AND LOCATION ARE ALWAYS 
			; MARKED NONRETURNABLE
; EXPAND CORE, TESTING FOR LAST 1K BLOCK LIMIT
; CALL:	JSP	R6,EXPCOR	; WITH NEW CORE LIMIT IN R2, RETURNS
;	TO 0(R6) IF ERROR OR INTO LAST 1K BLOCK, AND TO 1(R6) IF SUC-
;	CESSFUL. LEAVES R0 AND R1 UNCHANGED
EXPCOR:	CAIL	R2,^O776000	; INTO LAST 1K BLOCK?
	JRST	(R6)	; YES, FAIL
	CORE	R2,	; TRY TO EXPAND
	JRST	(R6)	; FAIL
	JRST	1(R6)	; SUCCEED

; GARBAGE COLLECTION STACK OVERFLOW DURING MARKING
; EXPAND CORE BY 1K BLOCK, EXPAND STACK (IN R6) BY SAME AMOUNT, EXPAND
; GARSIZ BY EXTENSION SIZE (P$GBXT), AND RE-EXECUTE PUSH OR PUSHJ
GRBOVF:	MOVE	R1,.JBREL	; GET CURRENT CORE LIMIT
	ADDI	R1,^O2000	; EXPAND BY 1K BLOCK
	CAIGE	R1,^O776000	; BUT NOT INTO LAST 1K OF CORE
	CORE	R1,	; EXPAND
	UFERR	4,PRGLNK	; ERROR
	HRLI	R6,-^O2000	; UPDATED STACK COUNT
	MOVEI	R1,P$GBXT	; GET EXTENSION SIZE
	ADDM	R1,GARSIZ	; MAKE GARBAGE STACK BIGGER IN THE FUTURE
	MOVE	R1,.JBCNI	; RESTORE R1
	JRST	@.JBTPC	; CONTINUE

; STORAGE
GARSIZ:	P$GBUF	; INITIAL GARBAGE COLLECT STACK SIZE
	SLOT1=CURCOR	; SLOT INDEX
	VARDEF	BLSIZE,1	; DESIRED BLOCK SIZE
	VARDEF	BLTYPE,1	; DESIRED BLOCK MARK TYPE
	VARDEF	BLLINK,1	; RETURN LINK
	VARDEF	BLPOIN,1	; DESIRED BLOCK POINTER
	VARDEF	AVLCOR,1	; CUMULATIVE AVAILABLE CORE
	VARDEF	BIGBLK,1	; LARGEST AVAILABLE BLOCK ENCOUNTERED
	VARDEF	LSTBLK,1	; LAST AVAILABLE BLOCK ENCOUNTERED
	VARDEF	AVLPTR,1	; CURRENT AVAILABLE CORE STARTING PTR
	VARDEF	AVLSIZ,1	; CURRENT AVAILABLE BLOCK SIZE
	VARDEF	AVLCNT,1	; AVAILABILITY INDICATOR
	SUBTTL	INPUT AND OUTPUT ASSOCIATION FUNCTIONS

	ENTRY	S$$AST,S$$ASB,S$$IOI,S$$IIX,S$$IOX

	COMMENT" THIS SECTION PERFORMS I/O AS A RESULT OF A MEMORY
PROTECTION INTERRUPT, USING THE ILLEGAL ADDRESS AS AN INDEX IN THE ASSO-
CIATION TABLE. IF THE INSTRUCTION CAUSING THE INTERRUPT IS A MOVE, SETZM,
OR MOVEM, I/O IS PERFORMED PROVIDED THE RESPECTIVE ASSOCIATION EXISTS,
AND THE KEYWORDS &INPUT OR &OUTPUT, RESPECTIVELY, ARE NONZERO.
IF THE INSTRUCTION IS A SETM OR SETAM, OR A MOVE OR MOVEM WITHOUT A
CORRESPONDING ASSOCIATION, THE OPERATION IS COMPLETED USING THE AC-
TUAL VARIABLE ADDRESS, BUT NO I/O IS PERFORMED. ANY OTHER OPCODE OR
ADDRESS BEYOND ASSOCIATION TABLE LIMITS IS AN ADDRESSING ERROR.
	R9 MUST NOT BE USED IN THE EFFECTIVE ADDRESS COMPUTATION,
AND AN INPUT INSTRUCTION MUST NEVER IMMEDIATELY FOLLOW AN OUTPUT
INSTRUCTION ON THE PDP-6 OR KA10."

VIOASO:	MOVE	R1,.JBCNI	; RESTORE R1
	MOVEM	R9,STKSRG+9	; SAVE R9
	IFE	P$KI10,
<	MOVE	R9,GOTINP	; CHANGE RESPONSE TO ILLEGAL ADDR
	MOVEM	R9,VIOASO+1	; DURING THIS COMPUTATION
	MOVE	R9,.JBTPC	; GET POINTER TO INSTR
	HRRM	R9,VIOEXT	; SAVE INSTR POINTER
	MOVE	R9,-1(R9)	; GET ACTUAL INSTRUCTION
	TLZN	R9,1B31	; CLOBBER INDIRECT BIT
	JRST	[HRRI	R9,@R9
		JRST	.+2]	; GET IMMEDIATE IF NOT INDIRECT
	HRR	R9,@R9	; GET FIRST LEVEL EFF ADDR
	TLZ	R9,^O17	; ERASE INDEX FIELD
	HLLZM	R9,VIOINS	; SAVE OP AC,
	MOVEI	R9,(R9)	; CLEAR LH
	CAIGE	R9,^O776000	; IS ADDR IN LAST 1K OF MEMORY?
GOTINP:	JRST	TRYINP	; NO, TRY INPUT POSSIBILITY
	LSH	R9,2	; *4
	ADD	R9,ASOTBL	; + TABLE BASE
	HLLI	R9,	; CLEAR LH
	CAMG	R9,ASOTBT	; LESS THAN TABLE TOP?
	JRST	TRYINP	; YES, TRY INPUT
	MOVEM	R9,VIOENT	; SAVE ENTRY POINTER
	HRRZ	R9,(R9)	; GET VARIABLE POINTER
	HRRM	R9,VIOINS	; SAVE POINTER, GET OP AC,
	MOVE	R9,[MOVEM R9,STKSRG+9]	; CHANGE RESPONSE TO
	MOVEM	R9,VIOASO+1	; ILLEG ADDR BACK TO NORMAL
	HLLZ	R9,VIOINS	; GET OPCODE
	TLZ	R9,^O740
	IFN	P$PDP6,
<	CAMN	R9,[MOVEM]	; IS IT A STORE?>
	IFE	P$PDP6,
<	CAME	R9,[MOVEM]	; IS IT A STORE?
	CAMN	R9,[SETZM]>
	JRST	VIOOUT	; YES, DO OUTPUT
	CAME	R9,[SETAM]	; IS IT STORE W/O OUTPUT?
	JRST	TRYINP	; NO, TRY INPUT
	JRST	VIORET+1	; YES, DO STORE
TRYINP:	MOVE	R9,GOTERR	; CHANGE RESPONSE AGAIN
	MOVEM	R9,VIOASO+1
	AOS	R9,VIOEXT	; BUMP INSTR POINTER, TRY INPUT
	MOVE	R9,-1(R9)	; AND GO THROUGH SAME SEQUENCE
	TLZN	R9,1B31
	JRST	[HRRI	R9,@R9
		JRST	.+2]
	HRR	R9,@R9
	TLZ	R9,^O17
	HLLZM	R9,VIOINS
	MOVEI	R9,(R9)
	CAIGE	R9,^O776000
GOTERR:	JRST	ILLADR
	LSH	R9,2
	ADD	R9,ASOTBL
	HLLI	R9,
	CAMG	R9,ASOTBT
	JRST	ILLADR
	MOVEM	R9,VIOENT
	HRRZ	R9,(R9)
	HRRM	R9,VIOINS
	MOVE	R9,[MOVEM R9,STKSRG+9]
	MOVEM	R9,VIOASO+1
	HLLZ	R9,VIOINS
	TLZ	R9,^O740
	IFN	P$PDP6,
<	CAMN	R9,[SETZM]	; IS IT A FUNNY STORE?
	JRST	VIOOUT	; YES, DO OUTPUT>
	CAMN	R9,[MOVE]	; IS IT A LOAD?
	JRST	VIOINP	; YES, DO INPUT
	CAMN	R9,[SETM]	; IS IT A LOAD W/O INPUT?
	JRST	VIORET+1	; YES, DO LOAD>
	IFN	P$KI10,
<	MOVE	R9,GOTERR	; CHANGE RESPONSE TO ILLEGAL ADDR.
	MOVEM	R9,VIOASO+1	; DURING THIS COMPUTATION
	MOVE	R9,.JBTPC	; GET POINTER TO INSTRUCTION
	ADDI	R9,1	; INCREMENT PC
	HRRM	R9,VIOEXT	; SAVE NEXT INSTRUCTION POINTER
	MOVE	R9,-1(R9)	; GET ACTUAL INSTRUCTION
	TLZN	R9,1B31	; CLOBBER INDIRECT BIT
	JRST	[HRRI	R9,@R9
		JRST	.+2]	; GET IMMEDIATE IF NOT INDIRECT
	HRR	R9,@R9	; GET FIRST LEVEL EFFECTIVE ADDRESS
	TLZ	R9,^O17	; ERASE INDEX FIELD
	HLLZM	R9,VIOINS	; SAVE OP AC,
	MOVEI	R9,(R9)	; CLEAR LH
	CAIGE	R9,^O776000	; IS IT IN LAST 1K OF MEMORY?
GOTERR:	JRST	ILLADR	; NO, ADDRESS ERROR
	LSH	R9,2	; GET -I/O INDEX*4
	ADD	R9,ASOTBL	; + TABLE BASE
	HLLI	R9,	; CLEAR LH
	CAMG	R9,ASOTBT	; LESS THAN TABLE TOP?
	JRST	ILLADR	; YES, ADDRESS ERROR
	MOVEM	R9,VIOENT	; SAVE I/O TABLE ENTRY POINTER
	HRRZ	R9,(R9)	; GET VARIABLE POINTER
	HRRM	R9,VIOINS	; SAVE POINTER
	MOVE	R9,[MOVEM R9,STKSRG+9]	; CHANGE RESPONSE TO ILLEGAL
	MOVEM	R9,VIOASO+1	; ADDRESS BACK TO NORMAL
	HLLZ	R9,VIOINS	; GET OPCODE
	TLZ	R9,^O740
	CAME	R9,[MOVEM]	; IS IT A STORE?
	CAMN	R9,[SETZM]
	JRST	VIOOUT	; YES, DO OUTPUT
	CAMN	R9,[MOVE]	; IS IT A LOAD?
	JRST	VIOINP	; YES, DO INPUT
	CAME	R9,[SETAM]	; IS IT A NON-I/O STORE
	CAMN	R9,[SETM]	; OR LOAD?
	JRST	VIORET+1	; YES, PERFORM ISTRUCTION>
	SOS	VIOEXT	; BUMP POINTER BACK
VIOERA:	UFERR	5,VIOEXT	; NO, ADDRESS ERROR
VIORET:	MOVE	R8,STKSRG+8	; RESTORE R8
	MOVE	R9,STKSRG+9	; RESTORE R9
S$$IOI:			; EXTERNAL NAME FOR INSTRUCTION WORD
VIOINS:	.-.	; PERFORM INSTRUCTION
VIOEXT:	JRST	.-.	; RETURN
ILLADR:	MOVE	R9,[MOVEM R9,STKSRG+9]	; CHANGE RESPONSE TO ILLEGAL
	MOVEM	R9,VIOASO+1	; ADDRESS BACK TO NORMAL
	JRST	VIOERA	; AND TAKE ERROR EXIT
	VARDEF	VIOENT,1	; ASSOCIATION ENTRY POINTER
;  INPUT PROCESSING
VIOINP:	SKIPN	KINP	; IS &INPUT ON?
	JRST	VIORET+1	; NO, DO NOT INPUT
	MOVEM	R8,STKSRG+8	; SAVE R8
	MOVE	R8,VIOENT	; GET ENTRY POINTER
	SKIPN	R9,2(R8)	; GET INPUT WORD, IS IT ZERO?
	JRST	VIORET	; YES, NO INPUT ASSOCIATION
	MOVEM	R7,STKSRG+7	; SAVE R0-R7
	HRRZI	R7,STKSRG
	BLT	R7,STKSRG+6
	HLRZ	R0,3(R8)	; GET MAX INPUT BLOCK SIZE
	JSP	R6,S$$GRS	; GET BLOCK FOR INPUT STRING
	HRLI	R1,^O700	; FORM STRING DESCRIPTOR
	MOVEM	R1,@VIOINS	; SAVE IN VARIABLE LOC
	JRST	(R9)	; PERFORM INPUT

; OUTPUT PROCESSING
VIOOUT:	SKIPN	KOUT	; IS &OUTPUT ON?
	JRST	VIORET+1	; NO, DO NOT OUTPUT
	MOVE	R9,STKSRG+9	; RESTORE R9
	XCT	VIOINS	; DO STORE
	MOVEM	R9,STKSRG+9	; SAVE R9
	MOVEM	R8,STKSRG+8	; SAVE R8
	MOVE	R8,VIOENT	; GET ENTRY POINTER
	SKIPN	R9,1(R8)	; GET OUTPUT WORD, IS IT ZERO?
	JRST	VIORET	; YES, NO OUTPUT ASSOCIATION
	MOVEM	R7,STKSRG+7	; SAVE R0-R7
	HRRZI	R7,STKSRG
	BLT	R7,STKSRG+6
	MOVE	R1,@VIOINS	; GET VALUE DESCRIPTOR
	JSP	R7,S$$CVS	; CONVERT TO STRING FROM ANY TYPE
	JRST	(R9)	; PERFORM OUTPUT
; CONTROLLING TELETYPE LINE MODE INPUT
TTYLMI:	HRRI	R9,0	; START COUNT AT 0
	MOVE	[XWD TLILOP,TLICHR]	; MOVE LOOP INTO R2-R8
	BLT	TLIEND
	JRST	TLICHR	; START LOOP
TLILOP:	PHASE	2
TLICHR:	INCHWL	R0	; R2: GET CHAR
	CAIN	R0,^O15	; R3: IS IT A CARRIAGE RETURN?
	JRST	TLIFIN	; R4: YES, JUMP OUT OF LOOP
	IDPB	R0,R1	; R5: NO, DEPOSIT IN STRING
	AOBJN	R9,TLICHR	; R6: LOOP IF ASSOC LEN IS NOT EXHAUSTED
	MOVE	.-2,.+1	; R7: SET UP TO THROW AWAY REST OF CHARS IN LINE
TLIEND:	JRST	TLICHR	; R8: AND RESUME LOOP
	DEPHASE
TLIFIN:	INCHWL	R0	; THROW AWAY LINE FEED
S$$IIX:			; EXTERNAL NAME FOR INPUT EXIT
VIOIND:	MOVE	R1,@VIOINS	; GET DESCR
	HRRM	R9,(R1)	; SAVE CHARACTER COUNT
	MOVE	R1,MXLN	; ASSURE STRING LENGTH DOES NOT EXCEED &MAXLGTH
	CAIGE	R1,(R9)
	CFERR	15,VIOEXT
	HRLZI	R9,STKSRG	; RESTORE R0-R9
	BLT	R9,R9
	JRST	VIOINS	; EXECUTE INSTRUCTION AND RETURN

; CONTROLLING TELETYPE CHARACTER MODE INPUT
TTYCMI:	HRRZI	R9,1	; ONE CHARACTER
	INCHRW	R0	; GET IT
	IDPB	R0,R1	; PUT IN STRING
	HRRM	R9,-1(R1)	; SET CHAR COUNT
	JRST	VIOIND+2	; FINISH UP INPUT
; CONTROLLING TELETYPE LINE MODE OUTPUT
TTYLMO:	HRRI	R9,0	; START COUNT AT 0
	JUMPE	R1,CRLFTY	; DO CR,LF IF NULL
	HRRZ	R8,(R1)	; GET CHAR COUNT
	JUMPE	R8,CRLFTY	; DO CR,LF IF 0 CHARS
	MOVE	[XWD TLOLOP,TLOCHR]	; MOVE LOOP INTO R2-R6
	BLT	TLOEND
	JRST	TLOCHR	; START LOOP
TLOLOP:	PHASE	2
TLOCHR:	ILDB	R0,R1	; R2: GET CHAR FROM STRING
	OUTCHR	R0	; R3: OUTPUT CHARACTER
	SOJE	R8,CRLFTY	; R4: SKIP OUT IF NO MORE CHARS
	AOBJN	R9,TLOCHR	; R5: LOOP IF ASSOC LEN IS NOT EXHAUSTED
TLOEND:	JRST	ASCLTY	; R6: ASSOC LEN REACHED, SKIP OUT
	DEPHASE
ASCLTY:	OUTCHR	[^O15]	; OUTPUT CR,LF
	OUTCHR	[^O12]
	MOVNI	R9,(R9)	; GET -ASSOC LEN,0 IN R9
	HRLZI	R9,(R9)
	JRST	TLOCHR	; GO BACK TO LOOP
CRLFTY:	OUTCHR	[^O15]	; OUTPUT CR,LF
	OUTCHR	[^O12]
S$$IOX:			; EXTERNAL NAME FOR OUTPUT EXIT
VIOOND:	HRLZI	R9,STKSRG	; RESTORE R0-R9
	BLT	R9,R9
	JRST	@VIOEXT	; EXIT

; CONTROLLING TELETYPE CHARACTER MODE OUTPUT
TTYCMO:	JUMPE	R1,VIOOND	; FINISHED IF NULL
	HRRZ	R8,(R1)	; GET CHAR COUNT
	JUMPE	R8,VIOOND	; FINISHED IF 0 CHARS
	MOVE	[XWD TCOLOP,TCOCHR]	; MOVE LOOP INTO R2-R5
	BLT	TCOEND
	JRST	TCOCHR	; START LOOP
TCOLOP:	PHASE	2
TCOCHR:	ILDB	R0,R1	; R2: GET CHAR FROM STRING
	OUTCHR	R0	; R3: OUTPUT CHAR
	SOJN	R8,TCOCHR	; R4: LOOP FOR EACH CHAR
TCOEND:	JRST	VIOOND	; R5: OR FINISH UP
	DEPHASE
; STORAGE AND INITIAL PARAMETERS
	P$ASIZ=P$ALEN/5	; COMPUTE BLOCK SIZE FOR DEFAULT ASSOCIATION LEN
	IFN	P$ALEN-P$ASIZ*5,<P$ASIZ=P$ASIZ+1>
	P$ASIZ=P$ASIZ+1
S$$AST:			; EXTERNAL NAME FOR POINTER TO TOP OF ASSOC TABLE
ASOTBT:	.+1	; ASSOC TABLE TOP POINTER
	SHD	2,P$ATXT+1,P$ATXT	; ASSOC TABLE HEADER WORD
	REPEAT	P$ATXT-16,<0>	; EMPTY ASSOCIATION ENTRIES
	XWD	S$$OUC,LOCOUC	; 'OUTPUTC' ASSOCIATION
	XWD	0,TTYCMO
	0
	0
	XWD	S$$OUT,LOCOUT	; 'OUTPUT' ASSOCIATION
	XWD	-P$ALEN,TTYLMO
	0
	0
	XWD	S$$INC,LOCINC	; 'INPUTC' ASSOCIATION
	0
	XWD	0,TTYCMI
	XWD	2,0
	XWD	S$$INP,LOCINP	; 'INPUT' ASSOCIATION
	0
	XWD	-P$ALEN,TTYLMI
	XWD	P$ASIZ,0
S$$ASB:			; EXTERNAL NAME FOR POINTER TO BASE OF ASSOC TAB
ASOTBL:	.	; ASSOC TABLE BASE POINTER
	XWD	TTYLMO,TTYLMI	; TTY LINE MODE OUTPUT/INPUT
	XWD	TTYCMO,TTYCMI	; TTY CHAR MODE OUTPUT/INPUT
	SUBTTL	RUNTIME ERRORS

	COMMENT/
CALL:	CFERR	ERRNO,LOC	; CONDITIONALLY FATAL ERROR
CALL:	UFERR	ERRNO,LOC	; UNCONDITIONALLY FATAL ERROR

	STORE ERRNO (ERRNO+16 FOR UFERR) IN &ERRTYPE, AND IF CFERR AND
IF &ERRLIMIT IS NOT 0, DECREMENT &ERRLIMIT AND GO TO FAILPOINT ROUTINE.
OTHERWISE OUTPUT ERROR NUMBER AND LOCATION (C(LOC)-1), AND GO TO SYSTEM
EXIT SEQUENCE/

LCFERR:	MOVEM	R7,SAVXR7	; CONDITIONAL
	JSP	R7,ERRCOM
LUFERR:	MOVEM	R7,SAVXR7	; UNCONDITIONAL
	JSP	R7,ERRCOM
	VARDEF	SAVXR0,8	; SPACE TO SAVE R0-R7
	SAVXR7=SAVXR0+7
ERRCOM:	SUBI	R7,LUFERR	; FORM INDEX (0 OR 2)
	HRRM	R7,ERXTYP	; SAVE
	LDB	R7,[POINT 5,.JBUUO,12]	; GET ERROR TYPE (+16 FOR UFERR)
	MOVEM	R7,ERRT	; SAVE IN &ERRTYPE
ERXTYP:	MOVEI	R7,.-.	; RESTORE INDEX
	JUMPN	R7,.+3	; SKIP OVER IF UNCONDITIONAL
	SOSL	ERLT	; DECREMENT &ERRLIMIT AND
	JRST	S$$FLR	; FAIL IF >0
	HRRZI	R7,SAVXR0	; OTHERWISE SAVE R0-R6
	BLT	R7,SAVXR7-1
	MOVE	R1,ERRPT1	; EDIT ERROR NUMBER
	MOVE	R2,ERRT	; INTO ERROR MESSAGE
	JSP	R4,S$$ITS
	MOVEI	R0,6	; EDIT 6-DIGIT OCTAL ADDRESS
	MOVE	R1,ERRPT2	; INTO ERROR MESSAGE
	MOVE	R2,@.JBUUO	; RH IS ERROR ADDR + 1
	HRLZI	R2,-1(R2)	; LH IS ERROR ADDR
EROCTL:	HLRI	R2,	; CONVERT TO 6-DIGIT OCTAL
	ROT	R2,3
	ADDI	R2,"0"
	IDPB	R2,R1
	SOJN	R0,EROCTL
	MOVE	R1,ERRDSC	; OUTPUT ERROR MESSAGE
	MOVEM	R1,@S$$OUT	; ON 'OUTPUT' DEVICE
	JRST	SYSEXC	; GO TO COMMON EXIT SEQUENCE
; STORAGE
ERRDSC:	POINT	7,.+1,35	; ERROR MESSAGE DESCRIPTOR
	SHD	2,6,23
ERRSTR:	ASCII/ERROR    AT USER       /
ERRPT1:	POINT	7,ERRSTR+1,6	; POINTER TO ERROR TYPE CHARS
ERRPT2:	POINT	7,ERRSTR+3,13	; POINTER TO ERROR LOC CHARS
	SUBTTL	SYSTEM EXITS

	ENTRY	S$$SXT
	EXTERN	S$$TMX,S$$TMF,S$$DMP

	COMMENT/
CALL:	JRST	S$$SXT	; FROM 'END' STATEMENT OF ANY PROGRAM
	DOES OUTPUT OF EXIT MESSAGES, AND TIMING STATISTICS IF REQUIRED.
IF &ABEND IS OFF, AN EXIT 0, IS PERFORMED, OTHERWISE AN EXIT 1, IS DONE/

S$$SXT:	MOVEM	R7,SAVXR7	; SAVE R0-R7
	HRRZI	R7,SAVXR0
	BLT	R7,SAVXR7-1
	MOVE	R1,NORDSC	; OUTPUT NORMAL TERMINATION MESSAGE
	MOVEM	R1,@S$$OUT	; ON 'OUTPUT' DEVICE
SYSEXC:	JSP	R5,S$$TMF	; FINISH TIMING LAST STATEMENT
	SETZ	R0,
	RUNTIM	R0,	; SAVE EXECUTION TIME
	SUB	R0,SSTT	; = FINISH TIME - START TIME
	MOVEM	R0,STATV+4
	MOVE	R1,LOCDC1	; "/IN STATEMENT "
	MOVEM	R1,@S$$OUC
	MOVE	R1,DUMDSC	; OUTPUT STATEMENT NUMBER
	MOVE	R2,STNO
	JSP	R4,S$$ITS
	HRRM	R3,DUMBLK
	MOVE	R1,DUMDSC
	MOVEM	R1,@S$$OUC
	MOVE	R1,LOCDC2	; " OF "
	MOVEM	R1,@S$$OUC
	MOVE	R1,PBLP	; OUTPUT PROGRAM NAME
	MOVE	R1,-2(R1)
	MOVEM	R1,@S$$OUC
	MOVE	R1,LOCDC3	; " AT LEVEL "
	MOVEM	R1,@S$$OUC
	MOVE	R1,DUMDSC	; OUTPUT FUNCTION LEVEL
	MOVE	R2,FNCL
	JSP	R4,S$$ITS
	HRRM	R3,DUMBLK
	MOVE	R1,DUMDSC
	MOVEM	R1,@S$$OUT
	MOVE	R1,STADSC	; "////FASBOL STATISTICS SUMMARY-"
	MOVEM	R1,@S$$OUT
; SET UP DATA FOR STATISTICS LOOP
	MOVE	R1,STATV+4	; GET EXECUTION TIME
	IMULI	R1,1000	; IN MICROSECONDS
	MOVE	R2,STCN	; TOTAL STATEMENTS EXECUTED
	MOVEM	R2,STATV+3
	JUMPE	R2,.+2	; SKIP IF 0
	IDIV	R1,R2	; MICROSEC PER STATEMENT
	MOVEM	R1,STATV
	MOVE	R1,STFC	; GET # OF STATEMENTS FAILED
	MOVEM	R1,STATV+2
	MOVEI	R7,4	; 5 STATISTICS

; STATISTICS LOOP
STATLP:	MOVE	R1,DUMDSC	; CONVERT STATISTIC TO STRING
	MOVE	R2,STATV(R7)
	JSP	R4,S$$ITS
	HRRM	R3,DUMBLK
	MOVEI	R2,INDENT	; LEFT PAD WITH BLANKS
	SUBI	R2,(R3)
	HRRM	R2,BLANKD+1
	MOVE	R1,BLANKD	; OUTPUT PADDING
	MOVEM	R1,@S$$OUC
	MOVE	R1,DUMDSC	; OUTPUT STATISTIC
	MOVEM	R1,@S$$OUC
	MOVE	R1,STATM(R7)	; OUTPUT STATISTIC MESSAGE
	MOVEM	R1,@S$$OUT
	SOJGE	R7,STATLP	; LOOP FOR EACH STATISTIC

; POSSIBLE ADDITIONAL OUTPUT
	MOVE	R6,PRGL	; GET PROGRAM LIST
	JSP	R7,S$$TMX	; PRINT OUT TIMER STATISTICS, IF ANY
	SKIPE	DUMP	; IS &DUMP ON?
	JSP	R7,S$$DMP	; YES, DO DUMP
	HRLZI	R7,SAVXR0	; RESTORE R0-R7
	BLT	R7,R7
	SKIPN	ABND	; IS &ABEND=0?
	EXIT		; YES, EXIT NORMALLY
	EXIT	1,	; NO, EXIT ABNORMALLY
; STORAGE
NORDSC:	POINT	7,.+1,35
	SHD	2,5,18
	ASCII/NORMAL TERMINATION/
LOCDC1:	POINT	7,.+1,35
	SHD	2,4,14
	BYTE	(7)^O12,"I","N"," ","S"
	ASCII/TATEMENT /
DUMDSC:	POINT	7,DUMBLK,35
	VARDEF	DUMBLK,3
LOCDC2:	POINT	7,.+1,35
	SHD	2,2,4
	ASCII/ OF /
LOCDC3:	POINT	7,.+1,35
	SHD	2,3,10
	ASCII/ AT LEVEL /
STADSC:	POINT	7,.+1,35
	SHD	2,7,30
	BYTE	(7)^O12,^O12,^O12,^O12,"F"
	ASCII/ASBOL STATISTICS SUMMARY-/
STATV:	REPEAT	5,<0>	; STATISTICS VARIABLES
	INDENT=15
BLANKD:	POINT	7,.+1,35
	SHD	2,4,15
	ASCII/               /
STATM:	POINT	7,XMSG5,35
	POINT	7,XMSG4,35
	POINT	7,XMSG3,35
	POINT	7,XMSG2,35
	POINT	7,XMSG1,35
XMSG1:	SHD	2,5,19
	ASCII/ MS. EXECUTION TIME/
XMSG2:	SHD	2,5,20
	ASCII/ STATEMENTS EXECUTED/
XMSG3:	SHD	2,5,18
	ASCII/ STATEMENTS FAILED/
XMSG4:	SHD	2,8,33
	ASCII/ REGENERATIONS OF DYNAMIC STORAGE/
XMSG5:	SHD	2,8,32
	ASCII/ MICROSECONDS AVG. PER STATEMENT/
	SUBTTL	SYMBOL TABLE

	ENTRY	S$$SY1,S$$SY2,S$$SYI

	COMMENT"
	SYMBOL LOOKUP
CALL:	JSP	R7,S$$SY1	; WITH TYPE/NO. IN LH(R0), KEY DESCRIPTOR
	IN R1. IF NOT FOUND, RETURN TO 1(R7) WITH TYPE/NO.,MAJOR KEY
	IN R0, KEY DESCR IN R1, PTR TO NEXT LARGER ENTRY IN R2, BUCKET
	POINTER IN R3, AND COMPARE TYPE WORD IN R4. IF FOUND, RETURN
	TO 0(R7) WITH PTR TO VALUE LOC IN R2

	SYMBOL LOOKUP RETRY
CALL:	JSP	R7,S$$SY2	; WITH R0-R4 SET TO RESULTS OF S$$SY1
	(NOT FOUND), EXCEPT TYPE/NO. MODIFIED. SAME RETURN CONVENTIONS
	AS S$$SY1

	SYMBOL BLOCK INITIALIZATION
CALL:	JSP	R10,S$$SYI	; WITH SYMBOL BLOCK POINTER IN R9, SYM-
	BOL TABLE NUMBER IN LH(R8), WITH RH(R8)=0

	SYMBOL ENTRIES ON EACH BUCKET CHAIN ARE ORDERED FROM LEAST TO
GREATEST BY THE TYPE/NO.,MAJOR KEY WORD. THE KEY DESCRIPTOR IS NOR-
MALLY USED AS THE HASHWORD, EXCEPT IN THE CASE OF STRINGS, WHERE THE
HASHWORD IS DERIVED BY ADDING AND SHIFTING FOR EACH CHARACTER UP TO A
MAXIMUM OF 28 CHARACTERS. THE BUCKET ENTRY IS COMPUTED BY DIVIDING THE
HASHWORD BY THE HASHSIZE (=BUCKET TABLE SIZE), USUALLY A PRIME NUMBER.
THE REMAINDER IS USED AS THE BUCKET INDEX RELATIVE TO THE TABLE BASE,
AND THE QUOTIENT TRUNCATED TO THE 18 RIGHTMOST BITS IS USED AS THE
MAJOR KEY"

; SYMBOL BLOCK INITIALIZATION
S$$SYI:	HRL	R9,(R9)	; GET -COUNT INTO LH(R9)
	AOJA	R9,.+2	; POINT AT FIRST ENTRY
SYILOP:	ADDI	R9,3	; 4 WORDS PER ENTRY
	MOVE	R0,1(R9)	; GET TYPE
	MOVE	R1,2(R9)	; GET KEY (STRING) DESCRIPTOR
	TLNE	R0,^O20000	; IS IT TYPE 1,3, OR 5 (LOCAL SYMBOL)
	ADD	R0,R8	; YES, ADD TABLE NUMBER
	JSP	R7,S$$SY1	; LOOK IT UP
	JRST	MLDFER	; SHOULD NOT FIND, ERROR
	HLRZ	R6,(R2)	; SPLICE INTO BUCKET CHAIN
	HRRM	R9,(R6)
	HRLM	R9,(R2)
	HRLI	R2,(R6)
	MOVEM	R2,(R9)
	MOVEM	R0,1(R9)	; SAVE TYPE/NO,MAJOR KEY
	AOBJN	R9,SYILOP	; LOOP
	JRST	(R10)	; RETURN
; SYMBOL LOOKUP AND RETRY
S$$SY1:	MOVE	R2,R1	; GET DESCR
	JUMPE	R2,OTHRTY	; SKIP OUT IF NULL
	TLNE	R2,^O770000	; IS IT STRING?
	JRST	OTHRTY	; NO, SKIP
	HRRZ	R3,(R2)	; GET CHAR COUNT
	CAILE	R3,28	; IS IT >28?
	MOVEI	R3,28	; YES, 28 IS ENOUGH
	SETZ	R4,	; INITIALIZE HASHWORD
	JUMPN	R3,STRNTY	; DO HASH IF CHARS>0
	SETZB	R2,R1	; OTHERWISE SAME AS NULL
OTHRTY:	MOVE	R4,[CAME R1,2(R2)]	; COMPARISON FOR NON- OR NULL STRINGS
	JRST	DOHASH	; GO DO HASH
STRNLP:	LSH	R4,1	; PREPARE FOR ONE MORE CHAR
STRNTY:	ILDB	R5,R2	; GET IT
	ADDI	R4,(R5)	; ADD IT TO HASHWORD
	SOJG	R3,STRNLP	; LOOP FOR N-1 CHARS
	MOVE	R2,R4	; MOVE TO PROPER HASHWORD LOC
	MOVE	R4,[JRST STRCOM]	; COMPARISON FOR STRINGS
DOHASH:	IDIVI	R2,.-.	; DIVIDE BY HASHSIZE (SET BY SYSTEM INI.)
	HRRI	R0,(R2)	; SET MAJOR KEY
	MOVM	R2,R3	; GET BUCKET INDEX
BUCKTB:	ADDI	R2,.-.	; ADD TABLE BASE (SET BY SYSTEM INI.)
	MOVEI	R3,(R2)	; SAVE BUCKET POINTER
	SKIPE	(R2)	; IS BUCKET EMPTY?
	JRST	SRCHLP	; GO SEARCH IF NONZERO
	HRLM	R2,(R2)	; MAKE EMPTY BUCKET CHAIN AND SAVE IN BUCKET
	HRRM	R2,(R2)
	JRST	1(R7)	; RETURN NOT FOUND
SRCHLP:	HRRZ	R2,(R2)	; GET NEXT ENTRY POINTER
S$$SY2:	CAIN	R2,(R3)	; IS IT BUCKET?
	JRST	1(R7)	; YES, RETURN NOT FOUND
	CAMLE	R0,1(R2)	; IS TYPE/NO,MAJOR KEY>ENTRY?
	JRST	SRCHLP	; YES, CONTINUE SEARCH
	CAME	R0,1(R2)	; IS IT EQUAL?
	JRST	1(R7)	; NO, IS <, RETURN NOT FOUND
	XCT	R4	; COMPARE KEYS FOR TRUE EQUALITY
	JRST	SRCHLP	; NOT EQUAL, KEEP SEARCHING
	ADDI	R2,3	; EQUAL, GET PTR TO VALUE WORD
	JRST	(R7)	; AND RETURN FOUND
STRCOM:	HRRZ	R6,(R1)	; GET CRAR COUNT OF KEY
	HRRZ	R5,@2(R2)	; GET CHAR COUNT OF ENTRY KEY
	CAIE	R6,(R5)	; SAME?
	JRST	SRCHLP	; NO, STRINGS CAN'T BE EQUAL
	MOVEM	R1,SYMDSC	; SAVE KEY DESCR
	HRRM	R3,BCKPTR	; SAVE BUCKET POINTER
	MOVE	R4,2(R2)	; GET ENTRY KEY DESCR
COMLOP:	ILDB	R5,R1	; GET CHAR FROM KEY
	ILDB	R3,R4	; GET CHAR FROM ENTRY KEY
	CAIE	R5,(R3)	; SAME?
	JRST	STRNEQ	; NO, STRINGS NOT EQUAL
	SOJG	R6,COMLOP	; LOOP FOR EACH CHAR
	ADDI	R2,3	; OR FINISHED, STRINGS EQUAL,
	JRST	(R7)	; GET PTR TO VALUE WORD AND RETURN FOUND
STRNEQ:	MOVE	R1,SYMDSC	; RESTORE KEY DESCR
BCKPTR:	MOVEI	R3,.-.	; RESTORE BUCKET POINTER
	MOVE	R4,[JRST STRCOM]	; RESTORE EQUALITY TEST
	JRST	SRCHLP	; CONTINUE SEARCHING

; MULTIPLE DEFINITION ERROR
MLDFER:	MOVE	R6,MLDERM
	MOVEM	R6,@S$$OUC
	MOVE	R6,2(R9)
	MOVEM	R6,@S$$OUT
	UFERR	1,PRGLNK
; STORAGE
MLDERM:	POINT	7,.+1,35
	SHD	2,7,30
	ASCII/>>>> MULTIPLY-DEFINED GLOBAL: /
SYMDSC:	BLOCK	1	; DANGEROUS TO USE VARDEF HERE
	SUBTTL	FUNCTION CALL HANDLER

	ENTRY	S$$EQA

	COMMENT/
	EUALIZE ARGUMENTS
CALL:	JSP	R4,S$$EQA	; WITH ACTUAL NUMBER OF ARGS IN R2,
	EXPECTED NUMBER IN R3. ALL ARGUMENTS, IF ANY, ARE ON ES, AND
	EXTRA ONES ARE REMOVED OR NULL VALUES ADDED. R3 IS UNCHANGED

	FUNCTION CALL
CALL:	FCALV	NARG,FLOC	; CALL FOR VALUE
CALL:	FCALN	NARG,FLOC	; CALL FOR NAME
	WHERE NARG IS THE NUMBER OF ACTUAL ARGUMENTS IN THE FUNCTION
	CALL, AND FLOC IS A PTR TO THE FUNCTION WORD. THE LAST ARGUMENT,
	IF ANY, IS IN R1, WITH REMAINING ARGS ON ES.
	THE PC IS SAVED IN PRGLNK, AND IF THE A FIELD OF THE FUNCTION
WORD IS 0, THE NUMBER OF ARGUMENTS SUPPLIED IS EQUALIZED TO THE NUMBER
REQUIRED. THE FUNCTION IS CALLED, WITH APPROPRIATE ACTION TAKEN ON
'RETURN' (JRST (LINK)) AND 'NRETURN' (JRST 1(LINK)), WITH FUNCTION
VALUE RETURNED IN R1. 'FRETURN' WILL CAUSE A DIRECT JUMP TO THE FAILPOINT
ROUTINE/

LFCALN:	JSP	R12,LFCALV+1	; FORM INDEX FOR NAME (0)
LFCALV:	JSP	R12,LFCALV+1	; FORM INDEX FOR VALUE (1)
	SUBI	R12,LFCALV
	MOVE	R2,S$$UPC	; SAVE PC
	MOVEM	R2,PRGLNK
	LDB	R2,[POINT 4,.JBUUO,12]	; GET ACTUAL NUMBER OF ARGS
	JUMPE	R2,.+2	; SKIP IF NO ARGS
	PUSH	ES,R1	; OTHERWISE PUSH LAST ONE ON STACK
	MOVE	R11,@.JBUUO	; GET FUNCTION WORD
	LDB	R3,[POINT 5,R11,12]	; GET 'A' FLAG, REQUIRED ARGS
	TRNN	R3,^O20	; SHOULD ARGS BE EQUALIZED? ('A'=0)
	JSP	R4,S$$EQA	; YES, EQUALIZE THEM
	XCT	FCALL(R12)	; DO FUNCTION CALL
	CFERR	8,PRGLNK	; 'RETURN' FOR NAME CALL, ERROR
	JRST	@PRGLNK	; 'NRETURN' FOR NAME, 'RETURN' FOR VALUE CALL
	MOVE	R1,(R1)	; 'NRETURN' FOR VALUE CALL,
	JRST	@PRGLNK	; GET VALUE FROM NAME
FCALL:	JSP	R12,(R11)	; NAME CALL
	JSP	R12,.+1	; VALUE CALL
	AOJA	R12,(R11)	; RETURNS TO PC 1 GREATER
S$$EQA:	SUBI	R2,(R3)	; GET ACTUAL-DESIRED
	JUMPE	R2,(R4)	; RETURN IF 0
	JUMPL	R2,NULPAD	; DESIRED>ACTUAL, ADD NULL ARGS
	POP	ES,R1	; DESIRED<ACTUAL, GET RID OF EXTRAS
	SOJG	R2,.-1
	JRST	(R4)	; AND RETURN
NULPAD:	SETZ	R1,	; NULL VALUE
	PUSH	ES,R1	; ADD EXTRA ARGS
	AOJL	R2,.-1
	JRST	(R4)	; RETURN
	SUBTTL	DEDICATED MODE ROUTINES

	ENTRY	S$$MKS,S$$MKI,S$$MKR,S$$DSG

	COMMENT/
CALL:	DASGN	TYPE,VLOC	; DEDICATED ASSIGNMENT, WHERE DESCRIPTOR
	IN R1 IS CONVERTED TO APPROPRIATE TYPE (1=STRING, 2=INTEGER,
	3=REAL), AND STORED IN THE VARIABLE LOCATION VLOC

CALL:	JRST	S$$DSG	; LIKE DASGN, EXCEPT VLOC IS ALREADY
	IN R8, AND LINK IN R9 AND IN PRGLNK

CALL:	DCONC	ARGNO,VLOC	; DEDICATED STRING CONCATENATION AND
	ASSIGNMENT, WHERE ARGNO IS THE NUMBER OF ELEMENTS IN THE CON-
	CATENATION (LAST IN R1, REST ON ES), AND VLOC IS THE DEDICATED
	STRING VARIABLE INTO WHICH THE CONCATENATION IS TO BE STORED

CALL:	JSP	R7,S$$MKI	; MAKE INTEGER, WITH DESCRIPTOR IN R1,
	RETURNS TO 0(R7) IF UNABLE, OR TO 1(R7) WITH INTEGER IN R1

CALL:	JSP	R7,S$$MKR	; MAKE REAL, SIMILAR TO S$$MKI

CALL:	JSP	R7,S$$MKS	; MAKE STRING, WITH DESCRIPTOR IN R1.
	RETURNS TO 0(R7) IF UNABLE, OR TO 1(R7) WITH STRING DESCRIPTOR
	IN R1. IF R0<0, THEN IF R1 DOES NOT ALREADY CONTAIN A STRING
	DESCRIPTOR, STORAGE IS ACQUIRED FOR THE NEW STRING, THE DESCRIP-
	TOR FOR THE NEW STRING IS RETURNED IN R1, AND THE CHARACTER
	COUNT FOR THE NEW STRING IS STORED IN THE STORAGE BLOCK. IF R0
	=0 OR >0, THEN THE BYTE POINTER IN R2 IS USED TO STORE THE STRING,
	WITH THE UPDATED BYTE POINTER RETURNED IN R2, THE ORIGINAL BYTE
	POINTER RETURNED IN R1 IF A CONVERSION FROM INTEGER OR REAL WAS
	DONE, AND R0 USED TO DETERMINE THE MAXIMUM CHARACTER COUNT.
	IN ANY CASE, THE ACTUAL CHARACTER COUNT IS RETURNED IN R3/
; DEDICATED ASSIGNMENT
LDASGN:	MOVE	R8,.JBUUO	; GET VLOC POINTER
	MOVE	R9,S$$UPC	; GET LINK
	MOVEM	R9,PRGLNK	; SAVE RETURN LINK
	SKIPN	R3,[POINT 4,R8,12]	; TYPE POINTER FOR LDASGN
S$$DSG:	MOVE	R3,[POINT 2,R8,5]	; TYPE POINTER FOR S$$DSG
	LDB	R2,R3	; GET TYPE
	XCT	CNVDSG-1(R2)	; DO PROPER TYPE OF CONVERSION
	CFERR	1,PRGLNK	; NO CONVERSION POSSIBLE, ILLEGAL TYPE
	MOVEM	R1,(R8)	; STORE INTEGER OR REAL IN LOC
	JRST	(R9)	; RETURN
CNVDSG:	JRST	.+3	; STRING, GO TO CONVERSION SEQUENCE
	JSP	R7,S$$MKI	; INTEGER MAKE
	JSP	R7,S$$MKR	; REAL MAKE
	MOVE	R2,(R8)	; GET BYTE POINTER FO^ DEDICATED STRING
	HLRZ	R0,(R2)	; COMPUTE MAXIMUM CHARACTERS FROM BLOCK SIZE
	SUBI	R0,1
	IMULI	R0,5
	JSP	R7,S$$MKS	; MAKE STRING AND STORE
	CFERR	1,PRGLNK	; COULD NOT BE CONVERTED
	HRRM	R3,@(R8)	; SAVE CHAR COUNT IN STRING
	JRST	(R9)	; RETURN

; DEDICATED STRING CONCATENATION AND ASSIGNMENT
LDCONC:	MOVE	R8,.JBUUO	; GET ARGNO,PTR
	MOVE	R9,S$$UPC	; GET LINK
	MOVEM	R9,PRGLNK	; SAVE LINK
	LDB	R9,[POINT 4,R8,12]	; GET ARGNO
	MOVNI	R9,(R9)	; FORM -(ARGNO,ARGNO)
	HRLI	R9,-1(R9)
	PUSH	ES,R1	; PUSH LAST ELEMENT ONTO ES
	ADD	ES,R9	; RESET ES BELOW ARGS
	HRRI	R9,(ES)	; SET UP ELEMENT POINTER TO FIRST
	AOBJN	R9,.+1
	MOVE	R2,(R8)	; GET BYTE POINTER FOR DEDICATED STRING
	HLRZ	R0,(R2)	; COMPUTE MAX CHARS
	SUBI	R0,1
	IMULI	R0,5
	HRLZI	R8,(R8)	; SAVE LOC PTR, SET INITIAL CHAR COUNT TO 0
DCNLOP:	MOVE	R1,(R9)	; GET NEXT ELEMENT DESCR
	JSP	R7,S$$MKS	; CONV IF NECESSARY, PUT IN DED STRING
	CFERR	1,PRGLNK	; CAN'T CONVERT
	ADDI	R8,(R3)	; INCREASE CHARACTER COUNT
	SUBI	R0,(R3)	; DECREASE MAX CHARS
	AOBJN	R9,DCNLOP	; LOOP FOR EACH ELEMENT
	MOVS	R8,R8	; SWAP LOCPTR,CHARS
	HLRM	R8,@(R8)	; SAVE TOTAL CHARS IN STRING
	JRST	@PRGLNK	; RETURN
; MAKE INTEGER
S$$MKI:	SETZ	R2,	; CLEAR AND SHIFT IN TYPE
	ROTC	R1,2
	XCT	MKITYP(R2)	; EXECUTE ACCORDING TO TYPE
	JRST	1(R7)	; RETURN SUCCESSFULLY
MKITYP:	JRST	S$$STI-1	; STRING, TRY TO MAKE INTEGER
	JRST	(R7)	; NAME, ETC- NO GO
	ASH	R1,-2	; INTEGER
	JSP	R3,S$$RTI	; RESL, CONVERT TO INTEGER

; MAKE REAL
S$$MKR:	SETZ	R2,	; CLEAR AND SHIFT IN TYPE
	ROTC	R1,2
	XCT	MKRTYP(R2)	; EXECUTE ACCORDING TO TYPE
	JRST	1(R7)	; RETURN SUCCESSFULLY
MKRTYP:	JRST	S$$STR-1	; STRING, TRY TO MAKE REAL
	JRST	(R7)	; NAME, ETC- NO GO
	JSP	R3,S$$ITR-1	; INTEGER, SHIFT BACK AND CONVERT
	JRST	1(R7)	; REAL, RETURN

; MAKE STRING
S$$MKS:	JUMPL	R1,MKNSTR	; IF NEG MUST BE INT OR REAL DESCR
	TLNE	R1,^O770000	; IS IT STRING?
	JRST	(R7)	; NO, CAN'T DO
	JUMPN	R1,.+3	; IS IT NULL?
	SETZ	R3,	; YES, SET CHAR COUNT TO 0
	JRST	1(R7)	; AND RETURN
	HRRZ	R3,(R1)	; GET CHAR COUNT
	JUMPL	R0,1(R7)	; IF R0<0, CONVERSION DONE
	JUMPE	R3,1(R7)	; IF CHAR COUNT=0, CONVERSION DONE
	CAIGE	R0,(R3)	; WILL CONVERSION OVERFLOW?
	CFERR	7,PRGLNK	; YES, ERROR
	MOVNI	R3,(R3)	; GET -CHAR COUNT,0 IN R3
	HRLZI	R3,(R3)
	ILDB	R4,R1	; MOVE CHAR FROM DESCR PTR TO BYTE PTR
	IDPB	R4,R2
	AOBJN	R3,.-2	; AND LOOP FOR EACH CHARACTER
	JRST	1(R7)	; RETURN
MKNSTR:	MOVEM	R0,MKSMOD	; SAVE TRANSFER MODE INDICATOR
	JUMPGE	R0,MKNSTC	; STRING STORAGE ALREADY PROVIDED?
	MOVEM	R1,MKSDSC	; NO, SAVE DESCRIPTOR
	MOVEI	R0,4	; GET 12-CHARACTER BLOCK
	JSP	R6,S$$GRS
	MOVEI	R0,12	; 12 CHARS MAX
	MOVE	R2,MKSDSC	; GET DESCRIPTOR BACK
	HRLI	R1,^O700	; FORM STRING DESCRIPTOR
	MOVEM	R1,MKSDSC	; SAVE STRING DESCR
	JRST	.+2
MKNSTC:	EXCH	R1,R2	; SWITCH DESCR,BYTE PTR
	SETZ	R3,	; GET TYPE (2=INT, 3=REAL)
	ROTC	R2,2
	CAIE	R3,3	; IS IT REAL?
	ASH	R2,-2	; NO, FORM INTEGER
	XCT	NTOSTR-2(R3)	; DO APPROPIIATE CONVERSION
	MOVE	R2,MKSDSC	; GET STRING DESCR BACK
	EXCH	R1,R2	; GET UPDATED BYTE PTR INTO R2
	SKIPGE	MKSMOD	; WAS STRING STORAGE PROVIDED?
	HRRM	R3,(R1)	; NO, SAVE CHARACTER COUNT IN STRIN
	JRST	1(R7)	; RETURN
NTOSTR:	JSP	R4,S$$ITS+1	; INTEGER TO STRING
	JSP	R4,S$$RTS+1	; REAL TO STRING
; STORAGE
	VARDEF	MKSMOD,1
	VARDEF	MKSDSC,1
	SUBTTL	DESCRIPTOR MODE CONVERSION

	COMMENT/
CALL:	DICNV	@NLOC	; CONVERT DESCRIPTOR IN @NLOC TO INTEGER, OR IN
	R1 IF @NLOC=0, RETURN VALUE IN R1

CALL:	DRCNV	@NLOC	; CONVERT TO REAL, LIKE DICNV/

LDICNV:	JSP	R7,LDRCNV+1	; INTEGER INDEX=LDRCNV
LDRCNV:	JSP	R7,LDRCNV+1	; REAL INDEX=LDRCNV+1
	MOVE	R6,S$$UPC	; GET LINK
	MOVEM	R6,PRGLNK	; SAVE
	MOVE	R6,.JBUUO	; GET EFF ADR
	TRNE	R6,^O777777	; IS IT ZERO?
	MOVE	R1,(R6)	; NO, GET DESCR, POSSIBLE INPUT
	XCT	DCNVXT-LDRCNV(R7)	; DO CONVERSION
	CFERR	1,PRGLNK	; NOT CONVERTIBLE
	JRST	@PRGLNK	; RETURN
DCNVXT:	JSP	R7,S$$MKI	; MAKE INTEGER
	JSP	R7,S$$MKR	; MAKE REAL
	SUBTTL	ARRAY/TABLE REFERENCE HANDLER

	EXTERN	S$$ARF,S$$TRF

	COMMENT/
CALL:	AREFV	NARG,VLOC	; REFERENCE FOR VALUE
CALL:	AREFN	NARG,VLOC	; REFERENCE FOR NAME
	WHERE NARG IS THE NUMBER OF ARGUMENTS IN THE CALL, AND VLOC IS
THE LOCATION OF THE NAME OF THE VARIABLE HOLDING THE ARRAY OR TABLE
DESCRIPTOR. THE LAST ARGUMENT, IF ANY, IS IN R1, WITH REMAINING ARGS
ON ES. THE PC IS SAVED IN PRGLNK, AND THE NUMBER OF ARGUMENTS SUPPLIED,
PROVIDED THEY DO NOT EXCEED THE NUMBER OF ARGUMENTS EXPECTED,
IS EQUALIZED TO (FOR ARRAYS) THE NUMBER OF DIMENSIONS OR (FOR TABLES) 1.
THE ARRAY OR TABLE REFERENCE ROUTINES ARE CALLED WITH THE DESCRIPTOR IN
R8 AND RETURN A POINTER TO THE ARRAY OR TABLE ELEMENT IN R2. AREFV LOADS
R1 WITH THE CONTENTS OF THE ELEMENT AND RETURNS, AND AREFN FORMS A NAME
DESCRIPTOR FOR THE ELEMENT AND RETURNS/

LAREFV:	JSP	R12,LAREFN+1	; REFERENCE FOR VALUE, INDEX=0
LAREFN:	JSP	R12,LAREFN+1	; REFERENCE FOR NAME, INDEX=1
	SUBI	R12,LAREFN
	MOVE	R2,S$$UPC	; GET LINK
	MOVEM	R2,PRGLNK	; SAVE
	LDB	R2,[POINT 4,.JBUUO,12]	; GET ACTUAL NUMBER OF ARGS
	JUMPE	R2,.+2	; SKIP IF NONE
	PUSH	ES,R1	; OR PUSH LAST ONE ONTO ES
	MOVE	R8,@.JBUUO	; GET NAME OF VAR
	SETM	R8,(R8)	; GET VALUE WITHOUT I/O
	HLLZ	R3,R8	; GET DESCRIPTOR TYPE
	ROT	R3,4
	MOVEI	R5,-5(R3)	; IS IT ARRAY OR TABLE?
	JUMPE	R5,.+2	; YES,SKIP
	CFERR	3,PRGLNK	; NO, ERROR
	JUMPGE	R3,.+3	; JUMP IF ARRAY
	AOS	R3,R5	; OR IF TABLE, SET EXPECTED ARGS=1, TYPE INDEX=1
	JRST	.+3	; AND SKIP
	ROT	R3,9	; GET NUMBER OF ARRAY DIMENSIONS
	ANDI	R3,^O377
	CAILE	R2,(R3)	; IS ACTUAL # OF ARGS > EXPECTED?
	CFERR	3,PRGLNK	; YES, ERROR
	JSP	R4,S$$EQA	; EQUALIZE ARGS
	ADDI	R12,.+2(R12)	; FORM RETURN LINK FOR VALUE OR NAME
	JRST	@ATBREF(R5)	; GO TO ARRAY OR TABLE REF ROUTINE
	MOVE	R1,(R2)	; VALUE CALL, LOAD VALUE
	JRST	@PRGLNK	; AND RETURN TO PROG
	HRLZI	R1,1B19	; NAME CALL, FORM NAME DESCRIPTOR
	ADDI	R1,(R2)
	JRST	@PRGLNK	; AND RETURN TO PROG
ATBREF:	S$$ARF	; ARRAY REF
	S$$TRF	; TABLE REF
	SUBTTL	FAILPOINT ROUTINE

	ENTRY	S$$FLR

	COMMENT/
CALL:	JRST	S$$FLR	; USED FAILPOINT STORED IN FAIL.
	IF LH OF FAIL IS <0, CONTROL IS PASSED TO LOCATION POINTED TO BY
RH OF FAIL (ABNORMAL FAILPOINT, AS IN NEGATION, UNEVALUATED EXPR.).
OTHERWISE ES AND SS ARE RESET TO THEIR PREVIOUS VALUES AND &STFCOUNT
INCREMENTED BEFORE JUMPING TO THE STATEMENT FAILPOINT/

S$$FLR:	MOVE	R1,FAIL	; GET CONTENTS OF FAILPOINT WORD
	JUMPL	R1,(R1)	; GO THERE IF NEGATIVE
	MOVE	ES,ESPR	; OTHERWISE GET PREVIOUS VALUE OF ES (- BASE)
	ADD	ES,ESBA	; (ADD BASE)
	MOVE	SS,SSPR	; AND PREVIOUS VALUE OF SS (- BASE)
	ADD	SS,SSBA	; (ADD BASE)
	AOS	STFC	; INCREMENT &STFCOUNT
	JRST	(R1)	; AND GO TO STATEMENT FAILPOINT
	SUBTTL	UTILITY ROUTINES- INTEGER TO STRING CONVERSION

	ENTRY	S$$ITS

	COMMENT/
CALL:	JSP	R4,S$$ITS	; WITH BYTE POINTER FOR FIRST CHARACTER
	IN R1, INTEGER IN R2, RETURNS UPDATED BYTE POINTER IN R1
AND CHARACTER COUNT IN R3. S$$ITS+1 MAY BE CALLED IF R0 IS ALREADY SET
TO MAXIMUM ALLOWABLE CHARACTER COUNT/

S$$ITS:	MOVEI	R0,12	; NO POSSIBLE STRING OVERFLOW, 11 DIGITS + SIGN
	MOVEM	R4,ITSBLK	; SAVE RETURN LINK FOR EXTRA POPJ
	MOVE	R4,ITSSTK	; GET STACK PTR
	HLRM	R2,NEGSW	; SET SIGN SWITCH
	MOVM	R2,R2	; ASSURE INTEGER IS POSITIVE
DECTOS:	IDIVI	R2,10	; REM IN R3, QUOTIENT IN R2
	HRLM	R3,(R4)	; SAVE REM (NEXT DIGIT)
	JUMPN	R2,DECTO1	; CONTINUE IF ALL DIGITS NOT FORMED
	MOVNI	R3,ITSBLK-1	; COMPUTE NUMBER OF DIGITS
	ADDI	R3,(R4)
	CAIGE	R0,(R3)	; >MAX ALLOWABLE?
	CFERR	7,PRGLNK	; YES, OVERFLOW
	HRRE	R2,NEGSW	; GET SIGN SWITCH
	JUMPGE	R2,DECTO2	; IS IT -?, IF NOT, SKIP
	ADDI	R3,1	; YES, ADD 1 CHAR FOR - SIGN
	CAIGE	R0,(R3)	; >MAX ALLOWABLE
	CFERR	7,PRGLNK	; YES, OVERFLOW
	MOVEI	R2,"-"	; START OFF STRING WITH -
	IDPB	R2,R1
	JRST	DECTO2
DECTO1:	PUSHJ	R4,DECTOS	; COMPUTE MORE DIGITS
DECTO2:	HLRZ	R2,(R4)	; TAKE DIGITS OUT IN OPPOSITE ORDER
	ADDI	R2,"0"	; CONVERT TO ASCII
	IDPB	R2,R1	; AND PUT IN STRING
NEGSW:	POPJ	R4,.-.	; RETURN TO DIGIT LOOP OR CALLING PROGRAM
; STORAGE
ITSSTK:	IOWD	11,ITSBLK+1	; STACK ARTIFICIALLY PUSHED ONCE
	ITSBLK=STKREG	; SPACE FOR STACK
	SUBTTL	UTILITY ROUTINES- REAL TO STRING CONVERSION

	ENTRY	S$$RTS

	COMMENT/
CALL:	JSP	R4,S$$RTS	; WITH REAL IN R2, LIKE S$$ITS/

S$$RTS:	MOVEI	R0,12	; MAX CHARS = 9 SIG DIGITS + SIGN + "." + XTRA 0
	MOVEM	R4,ITSBLK	; SAVE RETURN LINK
	HLRM	R2,NEGSW	; SET SIGN SWITCH
	MOVM	R2,R2	; ASSURE REAL IS POSITIVE
	MULI	R2,^O400	; SEPARATE FRACTION AND EXPONENT
	EXCH	R2,R3	; PUT SHIFTED MANTISSA INTO R2
	HRREI	R4,-^O243(R3)	; AND BINARY POINT SHIFT INTO R4
	JUMPLE	R4,.+2	; ERROR IF >0
	CFERR	9,PRGLNK	; BECAUSE INTEGER > 2**35
	SETZ	R3,	; FORM INTEGER PART IN R2
	ASHC	R2,(R4)
	MOVEM	R3,RFRACT	; SAVE FRACTION
	MOVE	R4,ITSSTK	; GET STACK POINTER
	PUSHJ	R4,DECTOS	; CONVERT INTEGER AND SIGN
	MOVEI	R2,"."	; PUT OUT DECIMAL POINT
	IDPB	R2,R1
	HRLZ	R2,NEGSW	; COMPUTE REMAINING SIGNIFICANCE
	JUMPL	R2,.+2	; -(12-#CHARS) IF "-" SIGN
	ADDI	R2,1	; -(11-#CHARS) IF POSITIVE
	ADDI	R2,(R3)
	HRLZI	R4,-12(R2)	; PUT -REM SIGNIFICANCE IN LH
	HRRI	R4,(R3)	; PUT CHAR COUNT IN RH
	MOVE	R2,RFRACT	; GET FRACTION
FRCTLP:	MULI	R2,10	; NEXT FRACTION DIGIT
	CAIG	R0,(R4)	; <MAX ALLOWABLE CHARS?
	CFERR	7,PRGLNK	; NO, ERROR
	ADDI	R2,"0"	; FORM ASCII DIGIT
	IDPB	R2,R1	; PUT IN STRING
	AOBJP	R4,FRCTND	; SKIP OUT IF SIGNIFICANCE SATISFIED
	MOVE	R2,R3	; RESTORE FRACTION
	JUMPN	R2,FRCTLP	; LOOP IF STILL NONZERO
FRCTND:	MOVEI	R3,(R4)	; GET CHAR COUNT IN R3
	JRST	@ITSBLK	; RETURN
; STORAGE
	VARDEF	RFRACT,1
	SUBTTL	UTILITY ROUTINES- INTEGER TO REAL AND REAL TO INTEGER CONV

	ENTRY	S$$ITR,S$$RTI

	COMMENT/
CALL:	JSP	R3,S$$ITR	; WITH INTEGER IN R1, RETURNS REAL IN R1.
	CALL TO S$$ITR-1 IF R1 CONTAINS INTEGER LEFT SHIFTED 2 BITS

CALL:	JSP	R3,S$$RTI	; WITH REAL IN R1, RETURNS INTEGER IN R1.
	IF MAG(R1)>2**35, ARITHMETIC OVERFLOW OCCURRS/

	ASH	R1,-2	; RESTORE INTEGER FROM TYPE TEST
S$$ITR:	IDIVI	R1,^O400	; DIVIDE INTO TWO PIECES
	SKIPE	R1	; IMPLIES INT < 9 BITS
	TLC	R1,^O243000	; SET EXP TO 243 (27 + 8 DECIMAL)
	TLC	R2,^O233000	; SET EXP TO 233 (27 DECIMAL)
	FAD	R1,R2	; NORMALIZE AND ADD
	JRST	(R3)	; RETURN

S$$RTI:	HLL	R3,R1	; SAVE SIGN IN LINK REG
	MOVM	R1,R1	; ASSURE POSITIVE REAL
	MULI	R1,^O400	; SEPARATE FRACTION AND EXPONENT
	EXCH	R1,R2	; PUT PARTIAL RESULT IN R1
	ASH	R1,-^O243(R2)	; USE EXP AS INDEX TO GET WHOLE PART
	JUMPGE	R3,(R3)	; RETURN IF POSITIVE
	MOVN	R1,R1	; OR COMPLEMENT
	JRST	(R3)	; AND RETURN
	SUBTTL	UTILITY ROUTINES- STRING TO INTEGER OR REAL CONVERSION

	ENTRY	S$$STI,S$$STR,S$$STN

	COMMENT/
CALL:	JSP	R7,S$$STI	; WITH STRING DESRIPTOR IN R1, RETURNS
	TO 0(R7) IF CANNOT BE CONVERTED OR TO 1(R7) WITH INTEGER IN R1.
	CALL TO S$$STI-1 IF DESCRIPTOR NEEDS TO BE SHIFTED BACK

CALL:	JSP	R7,S$$STR	; SAME AS S$$STI EXCEPT RETURNS REAL IN R1

CALL:	JSP	R7,S$$STN	; SAME AS S$$STI EXCEPT RETURNS SUCCESS-
	FULLY TO 2(R7) WITH 2 IN R2 IF VALUE IN R1 IS INTEGER, AND 3 IN
	R2 IF VALUE IN R1 IS REAL

	REAL STRINGS ARE CONVERTED TO INTEGERS AND INTEGER STRINGS TO
REALS IF NECESSARY/

	ROTC	R1,-2	; RESTORE STRING DESCRIPTOR
S$$STN:	MOVEI	R2,2	; START OUT ASSUMING INTEGER
	MOVEM	R2,IRSTMD	; AND SAVE MODE
	JUMPN	R1,S$$STR+2	; PROCESS IF NON-NULL
	JRST	2(R7)	; OR RETURN
	ROTC	R1,-2	; RESTORE STRING DESCR
S$$STI:	JUMPE	R1,1(R7)	; RETURN 0 IF NULL
	SETOM	IRSTMD	; SET MODE TO INT
	JRST	S$$STR+2	; CONTINUE
	ROTC	R1,-2	; RESTORE STRING DESCR
S$$STR:	JUMPE	R1,1(R7)	; RETURN 0 IF NULL
	SETZM	IRSTMD	; SET MODE TO REAL
	HRRZ	R6,(R1)	; GET CHAR COUNT
	JUMPN	R6,.+3	; SKIP IF >0
	SETZ	R1,	; RETURN 0 FOR EMPTY STRING
	JRST	TSTMOD	; RETURN
	SETZ	R3,	; INITIALIZE WHOLE PART
	SETZM	STSIGN	; INITIALIZE SIGN TO +
	ILDB	R2,R1	; GET FIRST CHAR
	CAILE	R2,"-"	; > - SIGN?
	JRST	NOSIGN	; YES, TRY DIGITS
	CAIE	R2,"-"	; IS IT - SIGN?
	JRST	TRYPLS	; NO, TRY +
	SETOM	STSIGN	; YES, SET SIGN TO -
	SOJG	R6,NOSIGN-1	; DECREMENT CHAR COUNT AND CONTINUE
	JRST	(R7)	; OR FAIL IF NO MORE
TRYPLS:	CAIN	R2,"+"	; IS IT + SIGN?
	SOJG	R6,NOSIGN-1	; YES, DECREMENT CHAR COUNT AND CONTINUE
	JRST	(R7)	; NOT + OR NO MORE CHARS, FAIL
	ILDB	R2,R1	; GET NEXT CHAR
NOSIGN:	CAILE	R2,"9"	; >9?
	JRST	(R7)	; YES, FAIL
	SUBI	R2,"0"	; FORM DIGIT
	JUMPL	R2,(R7)	; FAIL IF <"0"
FORMIN:	IMULI	R3,10	; TOT=TOT*10+DIGIT
	ADDI	R3,(R2)
	SOJG	R6,FORMI1	; DECREMENT CHAR COUNT AND CONTINUE
	MOVE	R1,R3	; NO MORE CHARS, GET TOTAL
	SKIPN	R2,IRSTMD	; IS MODE REAL?
	JSP	R3,S$$ITR	; YES, CONVERT TO REAL
INTFIN:	SKIPE	STSIGN	; IS SIGN +?
	MOVN	R1,R1	; NO, NEGATE
TSTMOD:	SKIPG	IRSTMD	; IS MODE OPTIONAL?
	JRST	1(R7)	; NO, RETURN SUCCESSFULLY
	JRST	2(R7)	; YES, RETURN SUCCESSFULLY
FORMI1:	ILDB	R2,R1	; GET NEXT CHAR
	CAILE	R2,"9"	; >"9"?
	JRST	(R7)	; YES, FAIL
	SUBI	R2,"0"	; FORM DIGIT
	JUMPGE	R2,FORMIN	; LOOP IF BETWEEN 0 AND 9
	CAME	R2,["."-"0"]	; OTHERWISE, IS IT "."?
	JRST	(R7)	; NO, FAIL
	MOVEM	R3,WHLPRT	; SAVE WHOLE PART
	SETZ	R3,	; INITIALIZE FRACTION
	MOVNI	R6,(R6)	; FORM -(REM CHARS+1),0
	HRLZI	R6,(R6)
	JRST	.+3	; AND JUMP INTO LOOP
FORMFR:	IMULI	R3,10	; TOT=TOT*10+DIGIT
	ADDI	R3,(R2)
	AOBJN	R6,FORMF1	; SKIP IF ANY CHARS REMAIN
	MOVE	R1,WHLPRT	; OTHERWISE GET WHOLE PART
	SKIPGE	IRSTMD	; IS IT REAL MODE OR OPTIONAL MODE?
	JRST	INTFIN	; NO, GO RETURN INTEGER
	MOVEM	R3,FRCPRT	; SAVE FRACTION PART
	JUMPE	R1,.+2	; SKIP IF WHOLE PART=0
	JSP	R3,S$$ITR	; FORM REAL WHOLE PART
	EXCH	R1,FRCPRT	; EXCHANGE WITH INTEGER FRACTION
	JUMPE	R1,.+3	; SKIP IF FRACT PART=0
	JSP	R3,S$$ITR	; FORM REAL FRACTIONAL PART
	FMP	R1,NEGPWR(R6)	; MULTIPLY BY APPROPRIATE -PWR OF TEN
	FAD	R1,FRCPRT	; ADD WHOLE PART
	SKIPG	R2,IRSTMD	; IS MODE OPTIONAL?
	JRST	INTFIN	; NO, GO CHECK SIGN ON REAL
	AOJA	R2,INTFIN	; YES, GO CHECK SIGN AND RETURN REAL
FORMF1:	ILDB	R2,R1	; GET NEXT CHAR
	CAILE	R2,"9"	; IS IT >"9"
	JRST	(R7)	; YES, FAIL
	SUBI	R2,"0"	; FORM DIGIT
	JUMPGE	R2,FORMFR	; LOOP IF NOT<"0"
	JRST	(R7)	; OR FAIL
; STORAGE
	VARDEF	IRSTMD,1
	VARDEF	STSIGN,1
	VARDEF	WHLPRT,1
	FRCPRT=WHLPRT
	NEGPWR=.-2
	EXP	1.0E-1,1.0E-2,1.0E-3,1.0E-4,1.0E-5,1.0E-6,1.0E-7
	EXP	1.0E-8,1.0E-9,1.0E-10,1.0E-11
	SUBTTL	UTILITY ROUTINES- CONVERT TO STRING ALWAYS

	ENTRY	S$$CVS

	COMMENT/
CALL:	JSP	R7,S$$CVS	; WITH DESCR IN R1, RETURNS STRING IN
	R1. NAMES RETURN 'NAME', ARRAYS 'ARRAY', TABLES 'TABLE', PATTERNS
	'PATTERN', AND PROGRAMMER-DEFINED DATATYPES THEIR NAME/

S$$CVS:	TLNN	R1,^O770000	; IS IT A STRING?
	JRST	(R7)	; YES, RETURN
	JUMPG	R1,CVS1	; JUMP IF NOT INTEGER OR REAL
	SETO	R0,	; OTHERWISE SET UP NUMERICAL TO STRING CONVERSION
	SOJA	R7,MKNSTR	; AND JUMP IN WITH MODIFIED LINK
CVS1:	SETZ	R2,	; GET TYPE BITS
	ROTC	R1,4
	XCT	CVS2-4(R2)	; GET TYPE STRING
	JRST	(R7)	; RETURN
CVS2:	MOVE	R1,CVSNAM	; NAME, GET 'NAME'
	JRST	CVSTAR	; ARRAY OR TABLE
	MOVE	R1,CVSPAT	; PATTERN, GET 'PATTERN'
	JRST	.+1	; DATATYPE
	LSH	R1,-4	; GET DATATYPE NAME
	MOVE	R1,(R1)
	MOVE	R1,(R1)
	JRST	(R7)	; AND RETURN
CVSTAR:	ROTC	R1,1	; GET ARRAY/TABLE BIT
	MOVE	R1,CVSARR-10(R2)	; GET 'ARRAY' OR 'TABLE'
	JRST	(R7)	; RETURN
; STORAGE
CVSNAM:	SDC	2,4,NAME
CVSPAT:	SDC	3,7,PATTERN
CVSARR:	SDC	2,5,ARRAY
	SDC	2,5,TABLE
	SUBTTL	DUMMY FORTRAN ENTRIES

	ENTRY	TYPER.,OVPCWD

	COMMENT/
CALL:	PUSHJ	^017,TYPER.	; WITH ERROR TYPE IN R0

	OVPCWD IS THE PC WORD ON TRAPS/

TYPER.:	CAIE	R0,2	; IS IT 2
	CAIN	R0,5	; OR 5?
	UFERR	14,PRGLNK	; YES, DIVIDE CHECK
	UFERR	15,PRGLNK	; NO, OVERFLOW
OVPCWD:	0
	SUBTTL	LITERALS
	LIT
	END