Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-02 - decus/20-0057/sddsys.vms
There are 2 other files named sddsys.vms in the archive. Click here to see a list.
00100		TITLE	S$$SYS  SYSTEM BASIC MODULE
00200		SUBTTL	DESCRIPTION OF FUNCTIONS
00300		SALL
00400		RADIX	10
00500		SEARCH	S$$NDF
00600	
00700		COMMENT"
00800		THIS MODULE CONTAINS ALL THE BASIC FUNCTIONS OF THE RUN-TIME
00900	SYSTEM, DESCRIBED BRIEFLY BELOW AND FUNCTIONALLY IN THE APPROPRIATE
01000	SECTION.
01100	
01200	SYSTEM INITIALIZATION- INITIALIZES SYSTEM PARAMETERS, STACKS, AND INITIAL-
01300	LIZES THE MAIN PROGRAM. SYSTEM COMMON IS DEFINED TO RECLAIM AS MUCH OF
01400	THE CORE USED BY THE INITIALIZATION AS POSSIBLE.
01500	
01600	PROGRAM INITIALIZATION- INCORPORATES THE NEW PROGRAM'S PARAMETERS AND
01700	SYMBOLS INTO THE SYSTEM.
01800	
01900	UUO HANDLER- DISPATCHES OPERATIONS 01-37.
02000	
02100	INTERRUPT HANDLER- DISPATCHES PROGRAM-TRAPPED INTERRUPTS
02200	
02300	STACK OVERFLOW- EXPANDS STACKS WHEN THEY OVERFLOW.
02400	
02500	FREE STORAGE- DYNAMIC STORAGE ALLOCATION FUNCTIONS.
02600	
02700	INPUT/OUTPUT- ELEMENTARY I/O FUNCTIONS.
02800	
02900	RUN-TIME ERRORS- HANDLES CONDITIONALLY OR UNCONDITIONALLY FATAL ERRORS.
03000	
03100	SYSTEM EXITS- NORMAL OR ERROR EXITS FROM SYSTEM.
03200	
03300	RUN-TIME SYMBOL TABLE- BASIC AND SYSTEM SYMBOL LOOKUP FUNCTIONS
03400	AND SYMBOL BLOCK INITIALIZATION ROUTINE.
03500	
03600	FUNCTION CALL HANDLER- DISPATCHES PRIMITIVE AND PROGRAMMER-DEFINED FUNC-
03700	TION CALLS, FIELD AND DATATYPE REFERENCES.
03800	
03900	DEDICATED MODE ROUTINES- DISPATCHES DEDICATED ASSIGNMENTS AND DEDICATED
04000	STRING CONCATENATION.
04100	
04200	DESCRIPTOR MODE CONVERSION- CONVERTS FROM DESCRIPTOR MODE INTO
04300	INTEGER OR REAL.
04400	
04500	ARRAY/TABLE REFERENCE HANDLER- PRODUCES VALUE OR NAME OF ARRAY OR
04600	TABLE ELEMENT.
04700	
04800	FAILPOINT ROUTINE- HANDLES GLOBAL, NEGATION, AND UNEVALUATED EXPRESSION
04900	FAILURES.
05000	
05100	UTILITY ROUTINES- ASSORTED CONVERSION ROUTINES.
05200	
05300	DUMMY FORTRAN ENTRIES- USED TO SATISFY FORTRAN MATH LIBRARY ROUTINES."
     
00100		SUBTTL	SYSTEM INITIALIZATION
00200	
00300		ENTRY	S$$ILZ
00400		EXTERN	.JBUUO,.JB41,.JBREL,.JBSA,.JBFF,.JBAPR,.JBCNI
00500		EXTERN	.JBTPC,.JBCOR
00600	
00700		COMMENT/ SYSTEM INITIALIZATION
00800	CALL:	JSP	R12,S$$ILZ	; OCCURS AT THE START OF MAIN PROGRAM
00900		XWD	HSHSIZ,MAINPB	; WHERE HSHSIZ IS THE BUCKET TABLE SIZE,
01000	DEFAULT (P$HSHS) USED IF 0, AND MAINPB IS THE MAIN PROGRAM PARAMETER
01100	BLOCK POINTER.
01200	
01300		DOES A RESET, SETS UP UUO AND INTERRUPT SERVICE, SAVES START
01400	TIME, INITIALIZES FREE STORAGE, STACKS, CHANNEL TABLE, BUCKET TABLE, AND
01500	SYSTEM SYMBOLS, AND INITIALIZES MAIN PROGRAM.
01600		THE CORE OCCUPIED BY THE INITIALIZATION CODE IS RECLAIMED FOR
01700	USE BY VARIABLES AND TABLES IN THIS MODULE THAT DO NOT REQUIRE INITIAL
01800	VALUES/
01900	
02000	S$$ILZ:	RESET		; RESET SYSTEM
02100		SETZ	R0,	; GET START TIME OF EXECUTION
02200		RUNTIM	R0,	; FOR THIS JOB
02300		MOVEM	R0,SSTT	; SAVE
02400		JSR	S$$PFZ##	; INITIALIZE PAGE FAULT HANDLER
02500		MOVE	R0,S$$UUL	; SET UP UUO HANDLER
02600		MOVEM	R0,.JB41
02700		MOVEI	R0,INTRUP	; SET UP INTERRUPT HANDLER
02800		MOVEM	R0,.JBAPR
02900		MOVEI	R0,^O620110	; REPETITIVE ENABLE PUSHDOWN OVFLOW,
03000		APRENB	R0,	; MEMORY, ARITH OVFLOW, DIVIDE CHECK
03100	
03200	; INITIALIZE FREE STORAGE
03300		HLRZ	R2,.JBSA	; GET FIRST FREE LOCATION
03400		MOVEM	R2,MINCOR	; SAVE
03500		MOVEM	R2,CURCOR
03600		ADDI	R2,P$GBUF+P$SSSZ+P$ESSZ+P$PSSZ+P$ASSZ+P$CSSZ
03700				; ADD CORE NEEDED BY GARBAGE AND OTHER STACKS
03800		HLRZ	R1,(R12)	; GET BUCKET TABLE SIZE
03900		JUMPG	R1,.+2	; SKIP IF SPECIFIED AND > 0
04000		MOVEI	R1,P$HSHS	; USE DEFAULT SIZE
04100		HRRM	R1,DOHASH	; SAVE IN HASHING OPERATION
04200		ADDI	R2,1(R1)	; ADD CORE NEEDED BY BUCKET TABLE
04300		CAMG	R2,.JBREL	; NEED TO EXPAND CORE?
04400		JRST	.+3	; NO
04500		JSP	R6,EXPCOR	; YES, TRY
04600		UFERR	4,R12	; CAN'T MAKE IT, ERROR
04700		MOVE	R0,.JBREL	; GET HIGHEST ADDRESS FOR USER
04800		MOVEM	R0,MAXCOR	; SAVE
04900		SUBI	R0,P$GBUF	; HIGHEST ADDRESS FOR FREE STORAGE
05000		MOVEM	R0,MAXFRE	; SAVE
05100		MOVEM	R0,.JBFF	; USE GARB STACK AREA FOR DUMMY BUFFERS
05200		HRLM	R0,.JBSA	; UPDATE JOB PARAMETERS
05300		HRLM	R0,.JBCOR
     
00100	; INITIALIZE STACKS
00200		MOVNI	R7,4	; SET UP FOR FIVE STACKS
00300	ILZSTK:	MOVE	R8,CSBA(R7)	; GET EXTENSION, INITIAL SIZE
00400		MOVEI	R0,(R8)	; INITIAL SIZE FOR STACK
00500		JSP	R6,S$$GNS	; GET NONRETURNABLE BLOCK
00600		MOVNI	R2,(R8)	; GET -(SIZE-2) INTO HU
00700		HRLI	R1,2(R2)
00800		MOVEM	R1,CSBA(R7)	; SAVE POINTER IN STACK BASE WORD
00900		HLRM	R8,(R1)	; SAVE STACK EXTENSION SIZE
01000		HRLI	R0,CSBA(R7)	; FORM REVERSE OF LAST STACK BLOCK WORD
01100		ADDI	R8,-1(R1)	; GET POINTER TO LAST WORD
01200		MOVSM	R0,(R8)	; STORE SIZE, PTR TO BASE WORD
01300		AOJLE	R7,ILZSTK	; LOOP FOR EACH STACK
01400		MOVE	SS,SSBA	; INITIALIZE SS
01500		MOVE	ES,ESBA	; INITIALIZE ES
01600	
01700	; INITIALIZE CHANNEL TABLE
01800		SETZM	CHNTBL	; ZERO CHNTBL(0) - CHNTBL(15)
01900		MOVEI	R1,CHNTBL+1
02000		HRLI	R1,CHNTBL
02100		BLT	R1,CHNTBL+15
02200	
02300	; INITIALIZE BUCKET TABLE
02400		HRRZ	R0,DOHASH	; GET BUCKET TABLE SIZE
02500		ADDI	R0,1	; +1 FOR BLOCK HEADER WORD
02600		JSP	R6,S$$GNS	; GET NONRETURNABLE BLOCK
02700		ADDI	R1,1	; POINTER TO FIRST BUCKET
02800		HRRM	R1,BUCKTB	; SAVE
02900		SETZM	(R1)	; ZERO ALL BUCKETS
03000		ADDI	R0,-2(R1)	; UP TO LAST
03100		HRLI	R1,1(R1)	; USING
03200		MOVS	R1,R1	; BLT WORD
03300		MOVE	R2,R0	; AND LAST LOC INDEX
03400		BLT	R1,(R2)
03500	
03600	; INITIALIZE GLOBAL SYMBOLS
03700		MOVEI	R9,GLOBSY	; GET START OF GLOBAL SYMBOL BLOCK
03800		JSP	R10,S$$SYI	; DO INITIALIZATION
03900	
04000	; INITIALIZE THE MAIN PROGRAM
04100		HRRZ	R10,(R12)	; GET PARAMETER BLOCK POINTER
04200		MOVEM	R10,PRGL	; SAVE IN PROGRAM LIST AS LAST
04300		HRLM	R10,PRGL	; AND FIRST PROGRAM
04400		MOVEI	R9,1(R10)	; SAVE PARBLK+1
04500		MOVEM	R9,PBLP	; AS CURRENT PROGRAM BLOCK
04600		JSP	R11,INIPR1	; INITIALIZE PROGRAM
04700		JRST	1(R12)	; RETURN
04800	ILZEND:
     
00100	; DEFINITIONS USED TO RECLAIM INITIALIZATION AREA
00200		SST=S$$ILZ	; SCRATCH AREA START
00300		SED=ILZEND	; SCRATCH AREA END
00400		DEFINE	VARDEF(N,S)	;;DEFINE SPACE FOR NAME N OF SIZE S
00500	<	SST1=SST
00600		IFLE	SST+S-SED,	;;IF ENOUGH ROOM LEFT IN SCRATCH AREA
00700	 <	N=SST			;;USE THE SCRATCH AREA
00800		SST1=SST+S>		;;AND INCREASE THE POINTER
00900		IFG	SST+S-SED,
01000	 <N:	BLOCK	S>		;;OTHERWISE USE SPACE WHERE CALLED
01100		SST=SST1>
01200	
01300	; WORD FORMAT DEFINITIONS
01400		DEFINE	SHD(T,S,P)	;;STORAGE BLOCK HEADER WORD
01500	<	BYTE	(2)T(16)S(18)P>	;;TYPE, SIZE, POINTER
01600	
01700		DEFINE	SDC(S,C,N)	;;STRING DESCRIPTOR
01800	<	POINT	7,[SHD	2,S,C	;;SIZE, CHARACTER COUNT
01900			ASCII/N/],35>	;;AND STRING
02000	
02100		DEFINE	NDC(D,P)	;;NAME DESCRIPTOR
02200	<	BYTE	(4)4(2)D(12)0(18)P>	;;DEDICATION, POINTER
02300	
02400	; DEFINE JFFO IF ASSEMBLY IS FOR PDP-6
02500		IFN	P$PDP6,
02600	<	DEFINE	JFFO(REG,LOC)
02700	<	JRST	[
02800		SETZ	REG'+1,
02900		JUMPE	REG,.+1
03000		EXCH	REG'+2,.
03100		MOVEM	REG,11(REG'+2)
03200		TLNE	REG,1B18
03300		JRST	8(REG'+2)
03400		LSH	REG,1
03500		AOJA	REG'+1,4(REG'+2)
03600		MOVE	REG,11(REG'+2)
03700		EXCH	REG'+2,.
03800		JRST	LOC
03900		0]>>
     
00100		SUBTTL	SYSTEM COMMON
00200	
00300		ENTRY	S$$FLP,S$$KWD,S$$CHT,S$$STB,S$$STS,S$$STP,S$$GLP
00400		ENTRY	S$$PGL,S$$LFC,S$$TMS,S$$PBP,S$$RTP,S$$NUL
00500		ENTRY	S$$INP,S$$INC,S$$OUT,S$$OUC,S$$TAC,S$$SJC,S$$SST,S$$PRL
00600		ENTRY	S$$TA1
00700		EXTERN	S$$SRT,S$$FRT,S$$NRT
00800	
00900		COMMENT/ SYSTEM COMMON
01000		DEFINES MOST VARIABLES, PARAMETERS, TABLES AND CONSTANTS
01100	COMMONLY USED BY THE SYSTEM/
01200	
01300	; ELEMENTS THAT MUST APPEAR FIRST IN THE SCRATCH AREA
01400		VARDEF	SSTT,1	; SYSTEM START TIME
01500		S$$SST=SSTT
01600		VARDEF	MINCOR,1	; LOW FREE CORE POINTER
01700		S$$LFC=MINCOR
01800		VARDEF	MAXCOR,1	; HIGH USER CORE POINTER
01900		VARDEF	MAXFRE,1	; HIGH FREE CORE POINTER
02000		VARDEF	CURCOR,1	; QUICKMODE CORE POINTER
02100		VARDEF	CHNTBL,16	; CHANNEL TABLE
02200		S$$CHT=CHNTBL
02300	
02400	; STACK PARAMETERS
02500	SSBA:	XWD	P$SSXT,P$SSSZ	; SS BASE WORD
02600	ESBA:	XWD	P$ESXT,P$ESSZ	; ES BASE WORD
02700		S$$STB=ESBA
02800	PSBA:	XWD	P$PSXT,P$PSSZ	; PS BASE WORD
02900	ASBA:	XWD	P$ASXT,P$ASSZ	; AS BASE WORD
03000	CSBA:	XWD	P$CSXT,P$CSSZ	; CS BASE WORD
03100		VARDEF	SSSA,1	; SS SAVED
03200		VARDEF	ESSA,1	; ES SAVED
03300		S$$STS=ESSA
03400		VARDEF	PSSA,1	; PS SAVED
03500		VARDEF	ASSA,1	; AS SAVED
03600		VARDEF	CSSA,1	; CS SAVED
03700	SSPR:	XWD	0,0	; SS PREVIOUS
03800	ESPR:	XWD	0,0	; ES PREVIOUS
03900		S$$STP=ESPR
04000	PSPR:	XWD	0,0	; PS PREVIOUS
04100	ASPR:	XWD	0,0	; AS PREVIOUS
04200	CSPR:	XWD	0,0	; CS PREVIOUS
04300	
04400	; GLOBAL PARAMETERS
04500		VARDEF	PRGL,1	; PROGRAM LIST
04600		S$$PRL=PRGL
04700	S$$GLP:
04800	GLST:	BYTE	(2)1,1(1)1(13)0(18)GLSTBB	; GLOBAL SYMBOL TBL DSCR
04900	GLVL:	XWD	GLOBVR,GLOBVR	; VARIABLE BLOCK LIST
05000	GLVX:	8		; NEXT GLOBAL VARIABLE INDEX
05100	LTBL:	0		; LATEST TABLE NUMBER
05200	
05300	; DYNAMIC PARAMETERS
05400		VARDEF	PRGLNK,1	; PROGRAM LINK
05500		S$$PGL=PRGLNK
05600		VARDEF	TIMR,1	; CURRENT STATEMENT START TIME
05700		S$$TMS=TIMR
05800		VARDEF	PBLP,1	; CURRENT PARAMETER BLOCK
05900		S$$PBP=PBLP
06000		VARDEF	FAIL,1	; FAILPOINT POINTER
06100		S$$FLP=FAIL
     
00100	
00200	; SYSTEM VARIABLE STORAGE BLOCK (GLOBAL VARIABLES)
00300	GLOBVR:	SHD	2,8,0	; 7 VARS
00400	LOCINP:	0		; 'INPUT'
00500	LOCINC:	0		; 'INPUTC'
00600	LOCOUT:	0		; 'OUTPUT'
00700	LOCOUC:	0		; 'OUTPUTC'
00800	TMPA:	0		; TEMPORARY AC
00900		S$$TAC=TMPA
01000	SUBJ:	0		; SUBJECT STRING FOR PATTERN MATCH
01100		S$$SJC=SUBJ
01200	TMP1:	0		; TEMPORARY VALUE #1
01300		S$$TA1=TMP1
01400	
01500	; SYSTEM SYMBOL BLOCK
01600	GLOBSY:	SHD	2,33,-8	; HEADER WORD
01700		XWD	0,0	; 'INPUT' VARIABLE
01800		2B4
01900		SDC	2,5,INPUT
02000	S$$INP:	NDC	0,-1
02100		XWD	0,0	; 'INPUTC' VARIABLE
02200		2B4
02300		SDC	3,6,INPUTC
02400	S$$INC:	NDC	0,-2
02500		XWD	0,0	; 'OUTPUT' VARIABLE
02600		2B4
02700		SDC	3,6,OUTPUT
02800	S$$OUT:	NDC	0,-3
02900		XWD	0,0	; 'OUTPUTC' VARIABLE
03000		2B4
03100		SDC	3,7,OUTPUTC
03200	S$$OUC:	NDC	0,-4
03300		XWD	0,0	; 'RETURN' LABEL
03400		4B4
03500	S$$RTP:	SDC	3,6,RETURN
03600		JRST	S$$SRT
03700		XWD	0,0	; 'FRETURN' LABEL
03800		4B4
03900		SDC	3,7,FRETURN
04000		JRST	S$$FRT
04100		XWD	0,0	; 'NRETURN' LABEL
04200		4B4
04300		SDC	3,7,NRETURN
04400		JRST	S$$NRT
04500		XWD	0,0	; 'END' LABEL
04600		4B4
04700		SDC	2,3,END
04800		JRST	S$$SXT
04900	
05000	; GLOBAL SYMBOL TABLE BASE BLOCK
05100	GLSTBB:	SHD	2,3,P$GSXT
05200		XWD	0,.+2
05300		XWD	0,0	; NO MORE ROOM LEFT, USE EXTENSION
05400	
05500	; KEYWORDS
05600	S$$KWD:
05700	;	INITIAL		; NAME		TYPE	INDEX	PROTECTED?
05800	STFC:	0		; &STFCOUNT	INT	0	YES
05900	LSTN:	0		; &LASTNO	INT	1	YES
06000	STNO:	0		; &STNO		INT	2	YES
06100	FNCL:	0		; &FNCLEVEL	INT	3	YES
06200	STCN:	0		; &STCOUNT	INT	4	YES
06300	ERRT:	0		; &ERRTYPE	INT	5	YES
06400	RTNT:	POINT 7,NULSTR,35 ;&RTNTYPE	STRING	6	YES
06500		POINT 7,ALPHAB,35 ;&ALPHABET	STRING	7	YES
06600	ABND:	0		; &ABEND	INT	8	NO
06700	ANCH:	0		; &ANCHOR	INT	9	NO
06800	FULS:	0		; &FULLSCAN	INT	10	NO
06900	STNT:	0		; &STNTRACE	INT	11	NO
07000	MXLN:	P$MXLN		; &MAXLNGTH	INT	12	NO
07100	STLT:	P$MXST		; &STLIMIT	INT	13	NO
07200	ERLT:	0		; &ERRLIMIT	INT	14	NO
07300	DENS:	P$DENS		; &DENSITY	INT	15	NO
07400	KINP:	1		; &INPUT	INT	16	NO
07500	KOUT:	1		; &OUTPUT	INT	17	NO
07600	DUMP:	0		; &DUMP		INT	18	NO
07700	SLFR:	0		; &SLOWFRAG	INT	19	NO
07800	
07900	; SYSTEM CONSTANTS
08000	NULSTR:	SHD	2,1,0	; NULL STRING
08100	NULDSC:	POINT	7,NULSTR,35	; NULL DESCRIPTOR
08200		S$$NUL=NULDSC
08300		RPTC=0
08400	ALPHAB:	SHD	2,27,128	; ALPHABET STRING
08500		REPEAT	25,<
08600		BYTE	(7)RPTC,RPTC+1,RPTC+2,RPTC+3,RPTC+4
08700		RPTC=RPTC+5>
08800		BYTE	(7)125,126,127
     
00100		SUBTTL	PROGRAM INITIALIZATION
00200	
00300		ENTRY	S$$IPR
00400	
00500		COMMENT/
00600	CALL:	JSP	R11,S$$IPR	; WITH PARBLK PTR IN R10
00700		ADDS PROGRAM TO PROGRAM LIST, SETS INITIALIZATION FLAG, ADDS
00800	VARIABLE STORAGE BLOCK, IF ANY, TO FRONT OF VARIABLE STORAGE BLOCK LIST
00900	, CREATES TIMING BLOCK IF REQUIRED, AND INITIALIZES SYMBOLS, IF ANY/
01000	
01100	S$$IPR:	MOVE	R9,PRGL	; GET FIRST,LAST PROGRAM POINTERS
01200		HRRM	R10,(R9)	; ADD CURRENT ONE TO END OF CHAIN
01300		HRRI	R9,(R10)	; NEW LAST PROG PTR
01400		MOVEM	R9,PRGL	; RESTORE
01500	INIPR1:	HRLZI	R9,-1	; SET INITIALIZATION FLAG, END OF CHAIN
01600		EXCH	R9,(R10)	; AND FETCH VARIABLE STORAGE POINTER
01700		JUMPE	R9,INIPR2	; SKIP IF THERE IS NONE
01800		HLRZ	R8,GLVL	; FIRST BLOCK IN VAR BLOCK LIST
01900		HRRM	R8,(R9)	; IS NOW SECOND
02000		HRLM	R9,GLVL	; AND CURRENT IS FIRST
02100	INIPR2:	HRRZ	R9,1(R10)	; GET NSTAT
02200		SETZ	R1,
02300		JUMPE	R9,INIPR3	; SKIP IF NO TIMING BLOCK NEEDED
02400		MOVEI	R0,1(R9)	; NUMBER OF WORDS NEEDED
02500		JSP	R6,S$$GNS	; GET NONRETURNABLE BLOCK
02600		HLLZS	(R1)	; CLEAR RH OF FIRST WORD (TOTTIM)
02700		HRLZI	R2,1(R1)	; BLT WORD
02800		HRRI	R2,2(R1)	; FOR REST OF BLOCK
02900		SETZM	1(R1)	; ZERO ALL WORDS
03000		ADDI	R9,(R1)	; UP TO END OF BLOCK
03100		BLT	R2,(R9)
03200	INIPR3:	EXCH	R1,1(R10)	; SAVE TIMING BLOCK POINTER, IF
03300				; ANY, AND GET SYMBOL BLOCK POINTER
03400		TLNN	R1,^O777777	; ANY SYMBOLS?
03500		JRST	(R11)	; NO, RETURN
03600		AOS	R8,LTBL	; GET NEW TABLE NUMBER
03700		HRLM	R8,1(R10)	; SAVE IN PARAMETER BLOCK
03800		HRLZI	R8,(R8)	; PREPARE FOR SYMBOL INITIALIZATION
03900		HLRZ	R9,R1	; GET SYMBOL BLOCK POINTER
04000		JSP	R10,S$$SYI	; INITIALIZE SYMBOLS
04100		JRST	(R11)	; RETURN
     
00100		SUBTTL	UUO HANDLER
00200	
00300		ENTRY	S$$UUL,S$$UDU,S$$UPC
00400	
00500		COMMENT/
00600	CALL:	UUO	AC,ADDR	; LEAVES PC IN S$$UPC AND UUO AC,EFFADR IN
00700		JOBUUO, AND JUMPS TO APPROPRIATE TABLE ENTRY WITH ALL AC'S OK.
00800	
00900		S$$UDU CAN BE USED TO DYNAMICALLY DEFINE NEW UUO'S, AND IT
01000	CONTAINS XWD NEXT AVAILABLE OPCODE, TABLE ENTRY POINTER/
01100	
01200	S$$UUL:	JSR	.	; USED TO INITIALIZE .JB41
01300		EXCH	R10,S$$UUL	; SAVE R10, GET PC
01400		HRRZM	R10,S$$UPC	; SAVE PC
01500		HLRZ	R10,.JBUUO	; GET OPCODE
01600		LSH	R10,-9
01700		HRLI	R10,S$$UUL	; SET UP FOR JRA
01800		JRA	R10,S$$UDU(R10)	; RESTORE R10 AND GO TO TABLE ENTRY
01900	S$$UDU:	XWD	NXTUUO,.+NXTUUO	; NEXT ALLOWABLE UUO DEFINITION
02000		JRST	LUFERR	; UNCONDITIONALLY FATAL ERROR
02100		JRST	LCFERR	; CONDITIONALLY FATAL ERROR
02200		JRST	LFCALV	; FUNCTION CALL FOR VALUE
02300		JRST	LFCALN	; FUNCTION CALL FOR NAME
02400		JRST	LDASGN	; DEDICATED ASSIGNMENT
02500		JRST	LDCONC	; DEDICATED CONCATENATION
02600		JRST	LDICNV	; DEDICATED INTEGER CONVERSION
02700		JRST	LDRCNV	; DEDICATED REAL CONVERSION
02800		JRST	LAREFV	; ARRAY/TABLE REFERENCE FOR VALUE
02900		JRST	LAREFN	; ARRAY/TABLE REFERENCE FOR NAME
03000	
03100		NXTUUO=.-S$$UDU
03200		REPEAT	^O40-NXTUUO,
03300	<	JRST	ERRUUO>	; REMAINING UUO'S INITIALLY UNDEFINED
03400	ERRUUO:	MOVE	R10,[UFERR 1,S$$UPC]	; SET UP ERROR/TYPE POINTER
03500		MOVEM	R10,.JBUUO	; FAKE
03600		JRST	LUFERR	; UNCONDITIONALLY FATAL ERROR
03700	; STORAGE
03800		VARDEF	S$$UPC,1
     
00100		SUBTTL	INTERRUPT HANDLER
00200	
00300		COMMENT/ THE FOLLOWING INTERRUPTS ARE TRAPPED:
00400	PUSHDOWN OVERFLOW- THE STACK THAT HAS OVERFLOWED IS EXTENDED
00500	MEMORY PROTECTION VIOLATION- INPUT OR OUTPUT IS PERFORMED IF INST.
00600		IS A MOVE OR MOVEM AND ILL ADDR IS AN INDEX IN ASSOC. TABLE
00700	FLOATING POINT AND ARITH METIC OVERFLOW- DIVIDE CHECK OR ARITHMETIC
00800		OVERFLOW CAUSES UNCONDITIONALLY FATAL ERROR
00900	
01000		R1 IS SAVED IN .JBCNI/
01100	
01200	INTRUP:	EXCH	R1,.JBCNI	; GET CONDITIONS AND SAVE R1
01300		ANDI	R1,^O220110	; MASK APPROPRIATE BITS
01400		CAIGE	R1,^O200000	; IS IT PUSHDOWN OVERFLOW?
01500		JRST	INTRU1	; NO
01600		SKIPN	GARBCL	; IS GARBAGE COLLECT FLAG ON?
01700		JRST	STKOVF	; NO, NORMAL STACK OVERFLOW
01800		JRST	GRBOVF	; YES, GARBAGE COLLECT STACK OVERFLOW
01900	INTRU1:	CAIL	R1,^O20000	; IS IT MEMORY PROTECTION VIOLATION?
02000		JRST	VIOASO	; YES, GO DO I/O
02100		JSP	R1,.+1	; NO, ARITH OVERFLOW, GET FLAGS
02200		TLNE	R1,1B30	; IS NO DIVIDE OFF?
02300		UFERR	14,.JBTPC	; NO, DIVIDE CHECK ERROR
02400		UFERR	15,.JBTPC	; YES, ARITHMETIC OVERFLOW ERROR
     
00100		SUBTTL	STACK OVERFLOW
00200	
00300		COMMENT/ HANDLES OVERFLOW OF SS,ES,PS,AS,AND CS DUE TO A PUSH
00400	OR A PUSHJ BY ACQUIRING A NEW STORAGE BLOCK EQUAL TO THE SIZE OF THE
00500	CURRENT ONE PLUS THE EXTENSION SIZE, AND COPYING THE VALID CONTENTS.
00600	THE OLD BLOCK IS RELEASED, THE STACK POINTER AND STACK BASE WORD CHANGED/
00700	
00800	STKOVF:	MOVE	R1,.JBTPC	; SAVE NEXT INSTRUCTION ADDR
00900		HRRM	R1,STKRST+1	; IN CASE OF A NESTED INTERRUPT
01000		MOVE	R1,[MOVE SS,STKREG]	; GET INSTR TO SAVE SS
01100		JUMPGE	SS,STKSAV	; SS HAS OVERFLOWED
01200		SUB	R1,[Z SS-ES,]	; CHANGE TO SAVE ES (OR PS)
01300		JUMPGE	ES,STKSAV	; ES (OR PS) HAS OVERFLOWED
01400		SUB	R1,[Z ES-AS,]	; CHANGE TO SAVE AS
01500		JUMPGE	AS,STKSAV	; AS HAS OVERFLOWED
01600		SUB	R1,[Z AS-CS,]	; CHANGE TO SAVE CS
01700		JUMPGE	CS,STKSAV	; CS HAS OVERFLOWED
01800	STKERR:	UFERR	1,STKRST+1	; ERROR, UNKKNOWN STACK OVERFLOW
01900	STKSAV:	MOVEM	R1,STKRST	; EXECUTED TO RELOAD REGISTER ON RETURN
02000		TLO	R1,^O2000	; CHANGE TO A MOVEM INSTR
02100		XCT	R1	; AND EXECUTE IT
02200		MOVE	R1,.JBCNI	; RESTORE R1
02300		MOVEM	R9,STKSRG+9	; SAVE R0-R9
02400		HRRZI	R9,STKSRG
02500		BLT	R9,STKSRG+8
02600		MOVE	R7,STKREG	; GET CONTENTS OF STACK REGISTER
02700		MOVE	R8,1(R7)	; GET SIZE, STACK BASE WORD POINTER
02800		HLRZ	R0,R8	; GET STACK BLOCK SIZE
02900		MOVEI	R8,(R8)	; XWD 0,STACK BASE WORD POINTER
03000		CAIL	R8,SSBA	; IS IT ONE OF KNOWN STACK BASE WORDS?
03100		CAILE	R8,CSBA
03200		JRST	STKERR	; NO, ERROR
03300		MOVE	R9,(R8)	; GET STACK BASE WORD
03400		SUB	R7,R9	; FORM STACK POINTER - BASE
03500		MOVEM	R7,STKREG	; SAVE REL POINTER
03600		MOVE	R7,(R9)	; GET CONTENTS OF FIRST WORD OF STACK BLOCK
03700		TLC	R7,3B19	; CHANGE MARK BITS TO RETURNABLE
03800		ADDI	R0,(R7)	; ADD EXTENSION SIZE
03900		JSP	R6,S$$GNS	; GET NEW BLOCK
04000		MOVEM	R7,(R9)	; MAKE OLD BLOCK RETURNABLE
04100		HRRM	R7,(R1)	; SAVE EXTENSION SIZE
04200		HRL	R8,R0	; FORM LAST WORD OF NEW BLOCK WITH NEW SIZE
04300		MOVE	R2,R0	; GET NEW SIZE
04400		MOVNI	R3,-2(R2)	; GET -(NEWSIZE-2)
04500		HRLI	R1,(R3)	; FORM NEW BASE WORD
04600		MOVEM	R1,(R8)	; SAVE IN BASE WORD LOC
04700		ADDM	R1,STKREG	; UPDATE STACK POINTER WITH NEW BASE
04800		HRLI	R1,(R9)	; GET POINTER TO OLD BLOCK
04900		ADDI	R2,-1(R1)	; GET POINTER TO LAST WORD OF NEW BLOCK
05000		MOVEM	R8,(R2)	; SAVE SIZE, BASE WORD POINTER
05100		MOVE	R2,STKREG	; GET LAST VALID STACK ENTRY IN NEW
05200		AOBJP	R1,.+1	; BLOCK, AND START AT SECOND WORD OF OLD AND NEW
05300		BLT	R1,(R2)	; BLOCKS TO TRANSFER ALL VALID STACK ENTRIES
05400		HRLZI	R9,STKSRG	; RESTORE R0-R9
05500		BLT	R9,R9
05600	STKRST:	.-.		; RESTORE STACK REGISTER
05700		JRST	.-.	; CONTINUE
05800	; STORAGE
05900		VARDEF	STKREG,11	; TEMPORARY STACK REGISTER
06000		STKSRG=STKREG+1		; TEMPS FOR R0-R9
     
00100		SUBTTL	FREE STORAGE
00200	
00300		ENTRY	S$$GRS,S$$GNS,S$$MRS,S$$MNS,S$$GCL
00400	
00500		COMMENT/ THE FREE STORAGE SECTION PROVIDES EXTERNAL ENTRIES
00600	FOR ACQUIRING RETURNABLE OR NONRETURNABLE BLOCKS, MAKING BLOCKS RETUR-
00700	NABLE OR NONRETURNABLE, AND FOR FORCING A GARBAGE COLLECTION. IN ADDI-
00800	TION, IT CONTAINS THE GARBAGE COLLECTION ROUTINES,AND TWO MODES OF
00900	STORAGE ACQUISITION: THE FIRST, CALLED QUICKMODE, IS VERY EFFICIENT
01000	AND OPERATES UNTIL THE INITIAL CORE ALLOCATION IS EXHAUSTED; THEN A
01100	GARBAGE COLLECTION OCCURS, AND THE NORMAL MODE IS ENTERED, WHICH MAKES
01200	USE OF AVAILABLE BLOCK LISTS AND EXPANDS CORE WHEN NECESSARY.
01300	
01400		GET RETURNABLE STORAGE
01500	CALL:	JSP	R6,S$$GRS; WITH SIZE IN R0, RETURNS 0,PTR IN R1 WITH
01600		R0 UNCHANGED
01700	
01800		GET NONRETURNABLE STORAGE
01900	CALL:	JSP	R6,S$$GNS	;SAME AS S$$GRS, BUT BLOCK IS MARKED
02000		SO THAT IT CAN'T BE COLLECTED
02100	
02200		MAKE RETURNABLE (NONRETURNABLE) STORAGE
02300	CALL:	JSP	R6,S$$MRS(0R S$$MNS)	; WITH POINTER IN R1, MARKS
02400		BLOCK APPROPRIATELY, AND LEAVES R1 UNCHANGED
02500	
02600		FORCE GARBAGE COLLECTION
02700	CALL:	JSP	R6,S$$GCL	; WITH 0 IN R0, FORCES GARBAGE COLLEC-
02800		TION, AND RETURNS TOTAL AMOUNT OF WORDS AVAILABLE IN R1 AND
02900		SIZE OF LARGEST AVAILABLE BLOCK IN R2/
     
00100	; GET RETURNABLE AND NONRETURNABLE STORAGE
00200	S$$GRS:	JSP	R2,QUICKM	; REPLACED WITH JSP R2,S$$GNS+1 IN NOR-
00300	S$$GNS:	JSP	R2,QUICKM	; MAL MODE (AFTER FIRST GARB COL)
00400		SUBI	R2,S$$GRS	; FORM INDEX OF 1 OR 2
00500		JFFO	R0,.+1	; COUNT NUMBER OF LEADING ZEROS
00600		LSH	R1,1	; *2
00700		MOVEM	R1,SLOT1	; SAVE FIRST SLOT INDEX
00800	GRBTRY:	HLRZ	R3,AVAIL(R1)	; GET SLOT COUNT
00900		SOJL	R3,NXTSIZ	; QUIT IF ZERO
01000		HLRZ	R4,AVAIL+1(R1)	; GET ROVER POINTER
01100		HLRZ	R5,(R4)	; GET BLOCK SIZE
01200		CAIG	R0,(R5)	; IS IT BIG ENOUGH?
01300		JRST	FOUNDS	; YES, USE THIS BLOCK
01400		SOJL	R3,NXTSIZ	; NO, QUIT IF SLOT COUNT WAS 1
01500	TRYLOP:	HRRZ	R4,(R4)	; GET NEXT BLOCK POINTER
01600		CAIN	R4,AVAIL(R1)	; IS IT THE AVAIL ARRAY?
01700		HRRZ	R4,(R4)	; YES, GET NEXT BLOCK POINTER
01800		HLRZ	R5,(R4)	; NO, GET BLOCK SIZE
01900		CAIG	R0,(R5)	; IS IT BIG ENOUGH?
02000		JRST	[HLRZ	R3,AVAIL(R1)
02100			 SOJA	R3,FOUNDS]	; YES, GET SLOT COUNT - 1
02200		SOJGE	R3,TRYLOP	; DECREMENT SLOT COUNT, LOOP IF ANY LEFT
02300		HRLM	R4,AVAIL+1(R1)	; UPDATE ROVER POINTER
02400	NXTSIZ:	SUBI	R1,2	; NEXT LARGER SLOT
02500		CAIGE	R1,40	; OFF THE END OF THE AVAIL ARRAY?
02600		JRST	GRBCOL	; YES, NO BLOCKS LEFT, DO GARBAGE COLLECTION
02700		HLRZ	R3,AVAIL(R1)	; NO, GET SLOT COUNT
02800		SOJL	R3,NXTSIZ	; QUIT IF ZERO
02900		HLRZ	R4,AVAIL+1(R1)	; GET ROVER POINTER
03000		HLRZ	R5,(R4)	; GET BLOCK SIZE
03100	FOUNDS:	HRLM	R3,AVAIL(R1)	; UPDATE SLOT COUNT (OLD COUNT - 1)
03200		SOJL	R3,ALLGON	; SKIP ROVER UPDATE IF ZERO
03300		HRRZ	R3,(R4)	; GET NEXT BLOCK POINTER
03400		CAIN	R3,AVAIL(R1)	; IS IT THE AVAIL ARRAY?
03500		HRRZ	R3,(R3)	; YES, GET NEXT BLOCK POINTER
03600		HRLM	R3,AVAIL+1(R1)	; NO, UPDATE ROVER POINTER
03700	ALLGON:	EXCH	R4,R1	; EXCHANGE SLOT INDEX, BLOCK POINTER
03800		HRLZ	R3,R0	; GET DESIRED BLOCK SIZE INTO LH
03900		LSH	R3,2	; SET MARK BITS IN BITS 0 AND 1
04000		LSHC	R2,-2
04100		EXCH	R3,(R1)	; EXCHANGE WITH FIRST WORD OF ACTUAL BLOCK
04200		MOVE	R2,1(R1)	; GET BACK LINK FROM ACTUAL BLOCK
04300		HRRM	R3,(R2)	; SET FORWARD LINK IN PREVIOUS BLOCK
04400		HRRM	R2,1(R3)	; SET BACK LINK IN NEXT BLOCK
04500		MOVEI	R3,(R5)	; GET ACTUAL BLOCK SIZE
04600		MOVE	R2,R0	; GET DESIRED BLOCK SIZE
04700		SUBI	R3,(R2)	; DIFFERENCE IN SIZE
04800		JUMPE	R3,(R6)	; RETURN IF ZERO
04900		ADDI	R2,(R1)	; REMAINDER BLOCK POINTER
05000		SKIPE	SLFR	; SKIP HEURISTIC IF &SLOWFRAG IS NOT ON
05100		CAME	R4,SLOT1	; IS THE CURRENT SLOT=INITIAL SLOT?
05200		CAIG	R3,1	; NO, ARE THERE < 2 WORDS LEFT?
05300		JRST	.+2	; SAME SLOT OR < 2 WORDS LEFT
05400		JRST	ADDLST	; NEITHER ADD REMAINDER BLOCK TO AVAIL LIST
05500		HRLZI	R4,1B19(R3)	; MAKE REMAINDER BLOCK INERT, WILL BE
05600		MOVEM	R4,(R2)	; COLLECTED LATER
05700		JRST	(R6)	; RETURN
05800	
05900	; ADDLST ADDS A BLOCK TO THE APPROPRIATE AVAIL LIST.
06000	; CALL:	JSP	R6,ADDLST	; WITH PTR IN R2 AND SIZE IN R3, LEAVES
06100	;  R0 AND R1 UNCHANGED
06200	ADDLST:	JFFO	R3,.+1	; COUNT NUMBER OF LEADING ZEROS
06300		LSH	R4,1	; *2, = SLOT INDEX OF BLOCK
06400		MOVEI	R4,AVAIL(R4)	; POINTER TO AVAIL ARRAY ENTRY
06500		MOVE	R5,(R4)	; SLOT COUNT, FIRST BLOCK POINTER
06600		HRRM	R2,1(R5)	; SET BACK LINK OF FIRST BLOCK
06700		HRLI	R3,(R5)	; GET FIRST BLOCK POINTER IN LH
06800		MOVSM	R3,(R2)	; SET SIZE, FORWARD LINK IN NEW BLOCK
06900		HRRZM	R4,1(R2)	; SET BACK LINK IN NEW BLOCK
07000		AOBJP	R5,.+1	; INCREMENT SLOT COUNT
07100		HRRI	R5,(R2)	; SET FIRST BLOCK PTR TO NEW BLOCK
07200		MOVEM	R5,(R4)	; AND SAVE IN AVAIL ARRAY
07300		HRLM	R2,1(R4)	; SET ROVER POINTER TO NEW BLOCK
07400		JRST	(R6)	; RETURN
07500	
07600	; MAKE RETURNABLE AND NONRETURNABLE STORAGE
07700	S$$MRS:	JSP	R2,S$$MNS+1	; RETURNABLE, INDEX=1
07800	S$$MNS:	JSP	R2,S$$MNS+1	; NONRETURNABLE, INDEX=2
07900		MOVEI	R3,(R1)	; GET PTR WITH LH=0
08000		CAML	R3,MINCOR	; BELOW MINIMUM?
08100		CAMLE	R3,MAXCOR	; OR ABOVE MAXIMUM?
08200		JRST	(R6)	; YES, FORGET IT
08300		SUBI	R2,S$$MRS	; NO, FORM INDEX
08400		DPB	R2,MRKPTR	; STORE INTO MARK BITS
08500		JRST	(R6)	; RETURN
08600	MRKPTR:	POINT	2,(R1),1	; FIRST TWO BITS POINTED TO BY R1
08700	
08800	; FORCE GARBAGE COLLECTION
08900	S$$GCL:	MOVEM	R0,BLSIZE	; SAVE SIZE
09000		JRST	QUICKO+3	; INITIALLY QUICKMODE, LATER CHANGED TO
09100			; JRST GRBCOL+2
     
00100	; QUICKMODE STORAGE ACQUISITION ROUTINES, WHICH OVERLAY THEMSELVES
00200	; WITH THE AVAIL LIST WHEN SWITCHING MODES
00300		AVAIL=.-36	; DEFINE REAL PART OF AVAIL LIST AS STARTING HERE
00400	QUICKM:	SUBI	R2,S$$GRS	; FORM MARK BITS
00500		MOVE	R1,CURCOR	; GET CURRENT LOCATION
00600		MOVE	R3,R0	; GET SIZE
00700		ADDI	R3,(R1)	; COMPUTE NEXT LOCATION
00800		CAMLE	R3,MAXFRE	; WITHIN BOUNDS?
00900		JFFO	R0,QUICKO	; NO, QUICKMODE OVERFLOW
01000		MOVEM	R3, CURCOR	; YES, NEW CURRENT LOC
01100		IOR	R0,MRKTB1(R2)	; SET MARK BITS
01200		HRLZM	R0,(R1)	; STORE MARK BITS, SIZE IN LH
01300		ANDI	R0,^O177777	; CLEAR MARK BITS
01400		JRST	(R6)	; RETURN
01500	QUICKO:	LSH	R1,1	; COMPUTE SLOT
01600		MOVEM	R0,BLSIZE	; SAVE SIZE
01700		MOVEM	R2,BLTYPE	; SAVE MARK TYPE
01800		EXCH	R1,SLOT1	; SAVE SLOT NUMBER, GET CURCOR
01900		MOVE	R3,MAXFRE	; DETERMINE AMOUNT LEFT
02000		SUBI	R3,(R1)
02100		HRLZI	R4,1B19(R3)	; CREATE INERT BLOCK
02200		MOVEM	R4,(R1)	; STARTING AT CURRENT LOC
02300		MOVEI	R3,S$$GNS+1	; UPDATE ENTRY POINTS
02400		HRRM	R3,S$$GRS
02500		HRRM	R3,S$$GNS
02600		MOVE	R5,AVLWRD	; GET INDEX WORD FOR AVAIL INITIALIZATION
02700		HRLZI	R4,AVLOOP	; MOVE AVLOOP INTO R0-R4
02800		BLT	R4,R4
02900		MOVEM	R4,S$$GCL+1	; UPDATE GARB COL ENTRY
03000		JRST	0	; START LOOP
03100	AVLOOP:	PHASE	0
03200		HRRZM	R5,(R5)	; R0: STORE FORWARD LINK
03300		HRRZM	R5,1(R5)	; R1: STORE BACKWARD LINK
03400		AOBJN	R5,.+1	; R2: BUMP COUNT
03500		AOBJN	R5,.-3	; R3: BUMP COUNT, LOOP IF NOT YET FINISHED
03600		JRST	GRBCOL+2	; R4: FINISHED, PROCEED WITH GARB COL
03700		DEPHASE
03800	AVLWRD:	XWD	-34,AVAIL+36	; PRESET 34 WORDS WITH FORWARD AND BACK
03900		BLOCK	AVAIL+70-.	; ALLOW FOR FULL 34 WORDS
04000	GARBCL:	0	; USE BOTH AS FLAG AND 35TH WORD (SIZE 1)
04100		MRKTB1=.-1
04200		1B19	; MARK BITS=1
04300		2B19	; MARK BITS=2
     
00100		COMMENT/ GARBAGE COLLECTION
00200	SAVE SIZE, TYPE, AND LINK. SET GARBCL FLAG AND INITIALIZE GARBAGE STACK.
00300	MARK BLOCKS POINTED TO BY PROGRAM VARIABLES, GLOBAL VARIABLES, AND
00400	VALUES ON ES, AND BY ELEMENTS OF NONTERMINAL DATATYPE VALUES. COLLECT
00500	ALL UNUSED BLOCKS AND RETURN THEM TO THE AVAIL LIST, COUNTING THE TOTAL
00600	CORE AVAILABLE AND RETAINING THE LARGEST AVAILABLE BLOCK SIZE FOUND.
00700	GET THE BLOCK (IF REQUESTED), EXPANDING CORE IF NECESSARY. COMPUTE
00800	DENSITY EXTENSION, EXPANDING CORE IF NECESSARY. RESET GARBCL FLAG AND
00900	RETURN/
01000	
01100	GRBCOL:	MOVEM	R0,BLSIZE	; SAVE BLOCK SIZE
01200		MOVEM	R2,BLTYPE	; SAVE MARK TYPE
01300		MOVEM	R6,BLLINK	; SAVE PROGRAM LINK
01400		SETOM	GARBCL	; SET GARBAGE COLLECTION FLAG
01500		MOVN	R6,GARSIZ	; SET UP GARBAGE STACK (FOR MARKING)
01600		HRL	R6,MAXFRE	; IN R6, RUNNING FROM MAXFRE TO .JBREL,
01700		MOVS	R6,R6	; OF SIZE GARSIZ+1
01800		SUB	R6,[XWD 1,1]	; IOWD GARSIZ+1,MAXFRE
01900	; START MARKING BY DETERMINING NUMBER OF ELEMENTS ON ES AND MARKING THEM
02000		HRLZI	R0,1B18	; MARK BIT FOR USED BLOCKS
02100		MOVN	R5,ESSA	; GET - ES SAVED -(M,M)
02200		MOVE	R4,ESBA	; AND ES BASE
02300		HLRE	R1,ES	; GET -NO OF REMAINING ELEMENTS ON ES
02400		MOVN	R1,R1	; MAKE POSITIVE
02500		JUMPL	R1,GETESB	; IF <0, MUST BE IN FORTRAN, USE ES SAVED
02600		ADDI	R1,1(ES)	; ADDRESS OF LAST WORD OF STACK
02700		CAMLE	R1,MAXCOR	; WITHIN CORE BOUNDS?
02800		JRST	GETESB	; NO, MUST BE IN FRORTRAN, USE ES SAVED
02900		HRRZ	R2,(R1)	; GET BASE WORD POINTER
03000		CAIE	R2,ESBA	; DOES BASE WORD POINTER POINT TO ES BASE WORD?
03100		JRST	GETESB	; NO, ES IS NOT CURRENT, USE ES SAVED
03200		MOVN	R5,ES	; YES, COMPUTE - ES CURRENT
03300		ADD	R5,R4
03400	GETESB:	HRRI	R5,(R4)	; -M, PTR TO FIRST ENTRY
03500		AOBJP	R5,.+2	; SKIP IF NOTHING ON STACK
03600		PUSHJ	R6,MRKMLT	; MARK EACH VALUE FROM BOTTOM TO TOP
03700	; MARK VALUES OF EACH VARIABLE ON VARIABLE BLOCK LIST
03800		HLRZ	R1,GLVL	; GET FIRST BLOCK POINTER
03900	MRKGLV:	PUSH	R6,(R1)	; SAVE NEXT BLOCK POINTER
04000		HLRZ	R5,(R1)	; GET -(BLOCKSIZE-1) INTO RH
04100		MOVNI	R5,-1B18-1(R5)
04200		HRLI	R5,1(R1)	; AND BLOCK PTR + 1 IN LH
04300		MOVS	R5,R5	; SWITCH
04400		PUSHJ	R6,MRKMLT	; MARK EACH VALUE IN BLOCK
04500		POP	R6,R1	; RESTORE NEXT BLOCK POINTER
04600		TRNE	R1,-1	; IS IT ZERO?
04700		JRST	MRKGLV	; NO, LOOP FOR EACH VARIABLE BLOCK ON CHAIN
04800	; CORE MAY HAVE EXPANDED DURING MARKING PHASE
04900		MOVE	R1,.JBREL	; HAS CORE EXPANDED?
05000		CAMN	R1,MAXCOR
05100		JRST	STRAVL	; NO, SKIP
05200		SUB	R1,GARSIZ	; YES, COMPUTE NEW MAXFRE
05300		EXCH	R1,MAXFRE	; EXCHANGE WITH OLD ONE
05400		MOVE	R2,MAXFRE	; COMPUTE DIFFERENCE
05500		SUBI	R2,(R1)
05600		HRLZI	R2,1B19(R2)	; CREATE FIRST WORD OF INERT BLOCK
05700		MOVEM	R2,(R1)	; BETWEEN OLD AND NEW VALUES OF MAXFRE
     
00100	; START COLLECTION, INITIALIZE PARAMETERS
00200	STRAVL:	TLO	R0,1	; PSEUDO 1-WORD NONRETURNABLE BLOCK
00300		MOVEM	R0,@MAXFRE	; MARK MAXFRE TO DELIMIT COLLECTION AREA
00400		SETZM	AVLCOR	; TOTAL CORE AVAILABLE
00500		SETZM	BIGBLK	; BIGGEST BLOCK AVAILABLE
00600		SETZM	LSTBLK	; LAST AVAILABLE BLOCK POINTER
00700		SETZ	R0,	; INITIAL SIZE
00800		MOVE	R1,MINCOR	; INITIAL PTR
00900	; ACCUMULATION LOOP, CLEAR ACCUMULATION PARAMETERS
01000	CLRAVL:	SETZM	AVLPTR	; AVAILABLE BLOCK POINTER
01100		SETZM	AVLSIZ	; AVAILABLE BLOCK SIZE
01200		SETZM	AVLCNT	; AVAILABILITY INDICATOR
01300	; CONSECUTIVE BLOCK LOOP, INCREMENT POINTER
01400	NXTAVL:	ADD	R1,R0	; PTR_PTR+SIZE
01500		CAMLE	R1,MAXFRE	; IS PTR > MAXFRE?
01600		JRST	COLFIN	; YES, STOP COLLECTING
01700		SETZ	R2,	; GET MARK TYPE OF PTR
01800		HLLZ	R3,(R1)
01900		LSHC	R2,2
02000		LSH	R3,-2	; GET SIZE OF POINTER
02100		HLRZ	R0,R3
02200		JRST	.+1(R2)	; JUMP TO APPROPRIATE ACTION
02300		JRST	AVLAVL	; MARK=00, ON AVAIL LIST
02400		JRST	AVLFRE	; MARK=01, AVAILABLE
02500		JRST	GATHER	; MARK=10, NONRETURNABLE
02600		TLO	R3,1B19	; MARK=11, MARKED, RESET TO 01
02700		HLLM	R3,(R1)	; AND STORE WITH SIZE IN FIRST WORD OF BLOCK
02800	GATHER:	MOVE	R2,AVLCNT	; GET AVAILABILITY INDICATOR
02900		JUMPE	R2,NXTAVL	; IF 0, GO ON TO NEXT BLOCK
03000		JUMPL	R2,UPDAVL	; IF<0, UPDATE STATISTICS
03100		MOVE	R3,AVLSIZ	; IF>0, GET ACCUMULATED SIZE
03200		CAIN	R3,1	; IS IT JUST 1?
03300		JRST	CLRAVL	; YES, IGNORE BLOCK AS IF IT WERE MARKED
03400		MOVE	R2,AVLPTR	; NO, GET ACCUMULATED BLOCK POINTER
03500		CAIL	R3,1B19	; IS BLOCK TOO BIG?
03600		JSP	R6,ADDBBB	; YES, BREAK IT UP
03700		JSP	R6,ADDLST	; NO, ADD TO AVAIL LIST
03800	UPDAVL:	MOVE	R3,AVLSIZ	; GET ACCUMULATED SIZE
03900		ADDM	R3,AVLCOR	; ADD TO TOTAL CORE AVAILABLE
04000		MOVE	R2,AVLPTR	; GET ACCUMULATED BLOCK POINTER
04100		MOVEM	R2,LSTBLK	; SAVE PTR AS LAST BLOCK AVAILABLE
04200		CAMLE	R3,BIGBLK	; BIGGER THAN BIGGEST?
04300		MOVEM	R3,BIGBLK	; YES, USE INSTEAD
04400		JRST	CLRAVL	; LOOP
04500	AVLAVL:	SKIPE	AVLCNT	; IS INDICATOR 0?
04600		JRST	REMPRE	; NO, DISCONNECT PRESENT BLOCK
04700		MOVNM	R0,AVLCNT	; YES, SET INDICATOR<0
04800	BEGAVL:	MOVEM	R0,AVLSIZ	; INITIALIZE SIZE
04900		MOVEM	R1,AVLPTR	; AND BLOCK POINTER FOR ACCUMULATION
05000		JRST	NXTAVL	; LOOP
05100	AVLFRE:	SKIPE	R2,AVLCNT	; IS INDICATOR 0? (R2_INDICATOR)
05200		JRST	REMPR1	; NO, GO ACCUMULATE
05300		MOVEM	R0,AVLCNT	; YES, SET INDICATOR>0
05400		JRST	BEGAVL	; INITIALIZE ACCUMULATION
05500	REMPRE:	MOVE	R3,R0	; PRESENT BLOCK SIZE
05600		MOVE	R2,R1	; PRESENT BLOCK POINTER
05700		JSP	R6,REMLST	; DISCONNECT
05800		MOVE	R2,AVLCNT	; RELOAD INDICATOR
05900	REMPR1:	JUMPGE	R2,REMPR2	; SKIP OVER IF >0
06000		MOVE	R2,AVLPTR	; LAST PTR
06100		MOVE	R3,AVLSIZ	; LAST SIZE
06200		JSP	R6,REMLST	; DISCONNECT
06300		MOVEM	R0,AVLCNT	; SET INDICATOR>0
06400	REMPR2:	ADDM	R0,AVLSIZ	; INCREASE AVAILABLE BLOCK SIZE
06500		JRST	NXTAVL	; LOOP
06600	
06700	; REMLST REMOVES A BLOCK FROM THE AVAIL LIST
06800	; CALL:	JSP	R6,REMLST	; WITH POINTER IN R2 AND SIZE IN R3,
06900	;  LEAVES R0 AND R1 UNCHANGED
07000	REMLST:	MOVE	R4,(R2)	; FORWARD LINK
07100		MOVE	R5,1(R2)	; BACK LINK
07200		HRRM	R5,1(R4)	; BACK LINK IN FORWARD BLOCK
07300		HRRM	R4,(R5)	; FORWARD LINK IN BACK BLOCK
07400		JFFO	R3,.+1	; COMPUTE SLOT INDEX
07500		LSH	R4,1
07600		HRLZI	R5,-1	; DECREMENT SLOT COUNT
07700		ADDB	R5,AVAIL(R4)	; AND GET FIRST BLOCK PTR
07800		HRLM	R5,AVAIL+1(R4)	; RESET ROVER POINTER TO FIRST BLOCK
07900		JRST	(R6)	; RETURN
08000	
08100	; ADDBBB ADDS THE PIECES OF AN OVERSIZE BLOCK TO THE AVAIL LIST
08200	; CALL:	JSP	R6,ADDBBB	; WITH POINTER IN R2 AND SIZE IN R3,
08300	;	JSP	R6,ADDLST	; LEAVES R0 AND R1 UNCHANGED
08400	ADDBBB:	HRRM	R6,BBBRET	; SAVE LINK
08500	BBBLOP:	MOVEI	R4,(R3)	; GET SIZE
08600		SUBI	R4,1B19-1	; REDUCE IT BY MAXIMUM PERMISSIBLE
08700		HRRM	R4,LODSIZ	; SAVE REDUCED SIZE
08800		MOVEI	R4,(R2)	; GET PTR
08900		ADDI	R4,1B19-1	; NEXT POINTER
09000		HRRM	R4,LODPTR	; SAVE IT
09100		MOVEI	R3,1B19-1	; SIZE OF CURRENT BLOCK
09200		JSP	R6,ADDLST	; ADD TO AVAIL LIST
09300	LODSIZ:	MOVEI	R3,.-.	; RESTORE SIZE
09400	LODPTR:	MOVEI	R2,.-.	; RESTORE POINTER
09500		CAIL	R3,1B19	; IS SIZE STILL TOO BIG?
09600		JRST	BBBLOP	; YES, LOOP
09700		CAILE	R3,1	; NO, IS SIZE>1?
09800	BBBRET:	JRST	.-.	; YES, RETURN AND DO A\DDLST
09900		AOS	R6,.-1	; BUMP RETURN LINK BEYORD ADDLST
10000		JUMPE	R3,(R6)	; RETURN IF ZERO
10100		HRLZI	R5,1B19+1	; CREATE INERT BLOCK OF SIZE 1
10200		MOVEM	R5,(R2)
10300		JRST	(R6)	; RETURN
     
00100	; COLLECTION OVER, GET DESIRED BLOCK
00200	COLFIN:	MOVE	R0,BLSIZE	; GET BLOCK SIZE
00300		JUMPE	R0,DNSCHK	; IF 0 (FORCED COLLECTION) GO TO DENSITY
00400		CAMLE	R0,BIGBLK	; IS SIZE>LARGEST AVAILABLE?
00500		JRST	MORCOR	; YES, MUST EXPAND CORE
00600		MOVE	R1,SLOT1	; NO, GET SLOT INDEX
00700		MOVE	R2,BLTYPE	; AND MARK TYPE
00800		JSP	R6,GRBTRY	; SIMULATE GET BLOCK CALL
00900		MOVEM	R1,BLPOIN	; SAVE POINTER
01000		JRST	DNSCHK	; GO ON TO DENSITY CHECK
01100	; EXPAND CORE TO GET ENOUGH FOR DESIRED BLOCK
01200	MORCOR:	MOVE	R2,MAXFRE	; GET FREE CORE TOP BOUNDARY
01300		HLRZ	R3,@LSTBLK	; GET SIZE OF LAST BLOCK MADE AVAILABLE
01400		SUBI	R2,(R3)	; AND SUBTRACT FROM TOP BOUNDARY
01500		CAME	R2,LSTBLK	; IS IT THE SAME LOC AS LAST BLOCK?
01600		JRST	MORCR1	; NO, FORGET IT
01700		MOVEM	R2,MAXFRE	; YES, MOVE BOUNDARY DOWN
01800		SUBM	R3,AVLCOR	; SUBTRACT SIZE FROM TOTAL CORE AVAILABLE
01900		MOVNS	AVLCOR
02000		JSP	R6,REMLST	; DISCONNECT, TO BE USED AS FIRST PART
02100					; OF NEW ONE
02200	MORCR1:	MOVE	R2,MAXFRE	; COMPUTE NEW MAX CORE BOUNDARY
02300		ADD	R2,R0	; NEEDED FOR NEW BLOCK
02400		ADD	R2,GARSIZ	; AND GARBAGE STACK
02500		JSP	R6,EXPCOR	; EXPAND CORE
02600		UFERR	4,PRGLNK	; ERROR IF CANNOT
02700		MOVE	R2,MAXFRE	; PTR TO NEW BLOCK
02800		HRRZ	R3,R0	; FORM FIRST WORD WITH MARK BITS AND SIZE
02900		MOVE	R4,BLTYPE
03000		IOR	R3,MRKTB1(R4)
03100		HRLZM	R3,(R2)
03200		MOVEM	R2,BLPOIN	; SAVE POINTER
03300		ADD	R2,R0	; FIRST AVAILABLE LOC
03400		MOVE	R3,.JBREL	; COMPUTE LAST AVAILABLE LOC
03500		SUB	R3,GARSIZ
03600		MOVEM	R3,MAXFRE	; SAVE
03700		SUBI	R3,(R2)	; COMPUTE SIZE IN BETWEEN
03800		CAIG	R3,1	; IS IT >1?
03900		JRST	SMLEXT	; NO, IGNORE OR MAKE INERT
04000		MOVEM	R2,LSTBLK	; YES, SAVE AS LAST AVAILABLE BLOCK
04100		ADDM	R3,AVLCOR	; ADD TO AVAILABLE STORAGE
04200		CAMLE	R3,BIGBLK	; BIGGER THAN BIGGEST BLOCK?
04300		MOVEM	R3,BIGBLK	; YES, USE INSTEAD
04400		JSP	R6,ADDLST	; ADD TO AVAIL LIST
04500		JRST	DNSCHK	; GO DO DENSITY CHECK
04600	SMLEXT:	JUMPE	R3,DNSCHK	; SKIP IF ZERO
04700		HRLZI	R4,1B19+1	; MAKE INERT BLOCK OF 1
04800		MOVEM	R4,(R2)
     
00100	; DENSITY CHECK: IF DENSITY IS GREATER THAN SPECIFIED BY &DENSITY
00200	; KEYWORD, CORE IS EXPANDED AS FAR AS POSSIBLE TO ACCOMODATE REQUIREMENT.
00300	;  FORMULA IS: EXT_((100-&DENSITY)*(MAXFRE-MINCOR)-100*AVLCOR)/&DENSITY
00400	; IF EXT>0, EXTEND CORE BY THAT AMOUNT, IF POSSIBLE. IF EXT<0 OR =0,
00500	; REQUIREMENTS ARE ALREADY MET BY CURRENT CORE SIZE
00600	DNSCHK:	MOVE	R2,DENS	; GET KEYWORD VAL
00700		CAILE	R2,100	; IS IT >100
00800		MOVEI	R2,100	; YES, 100 IS ENOUGH
00900		CAIGE	R2,1	; IS IT <1
01000		MOVEI	R2,1	; YES, MUST BE AT LEAST 1
01100		MOVEM	R2,DENS	; RESET KEYWORD IF NECESSARY
01200		SUBI	R2,100	; COMPUTE FORMULA
01300		MOVE	R3,MINCOR
01400		SUB	R3,MAXFRE
01500		IMUL	R2,R3
01600		MOVE	R3,AVLCOR
01700		IMULI	R3,100
01800		SUB	R2,R3
01900		IDIV	R2,DENS	; RESULT IN R2
02000		JUMPLE	R2,NOTEXT	; DON'T EXTEND UNLESS >0
02100		ADD	R2,.JBREL	; NEW MAX CORE LIMIT
02200		CAIL	R2,^O776000	; INTO LAST 1K BLOCK?
02300		MOVEI	R2,^O775777	; YES, CAN'T GO THERE
02400		CORE	R2,	; TRY TO EXPAND
02500		JRST	PRTEXT	; ONLY PARTIAL EXPANSION
02600	PRTEXR:	MOVE	R2,MAXFRE	; GET LAST FREE CORE MAX
02700		MOVE	R3,.JBREL	; COMPUTE LATEST
02800		SUB	R3,GARSIZ
02900		MOVEM	R3,MAXFRE	; SAVE
03000		SUBI	R3,(R2)	; SIZE OF BLOCK IN BETWEEN
03100		ADDM	R3,AVLCOR	; ADD TO AVAILABLE CORE
03200		CAMLE	R3,BIGBLK	; BIGGER THAN BIGGEST?
03300		MOVEM	R3,BIGBLK	; YES, USE INSTEAD
03400		CAIL	R3,1B19	; MAKE SURE IT IS NOT TOO BIG
03500		JSP	R6,ADDBBB	; TOO BIG, BREAK IT UP
03600		JSP	R6,ADDLST	; OK, ADD TO AVAIL LIST
03700	; FINISH UP BY TESTING FOR ANY CORE EXPANSION AND RESETTING PARAMETERS
03800	NOTEXT:	MOVE	R2,.JBREL	; GET NEW CORE BOUNDARY
03900		CAMN	R2,MAXCOR	; SAME AS OLD?
04000		JRST	GRBFIN	; YES, SKIP
04100		MOVEM	R2,MAXCOR	; NO, UPDATE PARAMETERS
04200		MOVE	R2,MAXFRE
04300		MOVEM	R2,.JBFF
04400		HRLM	R2,.JBSA
04500		HRLM	R2,.JBCOR
04600	GRBFIN:	JUMPE	R0,GCLFIN	; DIFFERENT RESULTS IF FORCED COLLECTION
04700		MOVE	R1,BLPOIN	; LOAD BLOCK POINTER (SIZE ALREADY IN R0)
04800		SETZM	GARBCL	; CLEAR GARBAGE COLLECT FLAG
04900		AOS	STATV+1	; INCREMENT GARBAGE COLLECTION COUNT
05000		JRST	@BLLINK	; RETURN
05100	GCLFIN:	MOVE	R1,AVLCOR	; GET TOTAL CORE AVAILABLE
05200		MOVE	R2,BIGBLK	; AND BIGGEST BLOCK
05300		JRST	GRBFIN+2	; AND EXIT
05400	; PARTIAL CORE EXTENSION, SWITCH DENSITY CHECK AND CORE EXPANSION CHECK
05500	; OUT ONCE CORE HAS REACHED SYSTEM-ALLOWED LIMIT
05600	PRTEXT:	MOVE	R3,NOTEXT+2	; GET [JRST GRBFIN]
05700		MOVEM	R3,DNSCHK	; SWITCH OUT INTERVENING CODE
05800		LSH	R2,10	; NUMBER OF CORE BLOCKS*^O2000
05900		SUBI	R2,1	; -1=LAST WORD
06000		CAME	R2,.JBREL	; ANYTHING LEFT TO GAIN?
06100		CORE	R2,	; YES, EXTEND CORE
06200		JRST	NOTEXT	; NO, OR ERROR, SKIP TO FINISH
06300		JRST	PRTEXR	; ADD NEW CORE TO SYSTEM
     
00100		COMMENT/ MARK MULTIPLE ELEMENT BLOCK
00200	CALL:	PUSHJ	R6,MRKMLT	; WITH -COUNT,FIRST PTR IN R5
00300		IF A VALUE POINTS TO A FREE STORAGE BLOCK THAT IS NOT MARKED,
00400	IT IS MARKED. IN ADDITION, IF IT IS ITSELF A MULTIPLE ELEMENT BLOCK,
00500	MRKMLT IS CALLED RMCURSIVELY ON IT. R0 CONTAINS 1B0, USED FOR MARKING,
00600	AND IS UNCHANGED/
00700	
00800	MRKMLT:	MOVE	R2,(R5)	; GET NEXT ELEMENT DESCRIPTOR
00900		JUMPL	R2,MRKLOP	; LOOP IF INTEGER OR REAL
01000		HRRZI	R3,(R2)	; GET DESCR PTR
01100		CAML	R3,MINCOR	; IS IT WITHIN FREE STORAGE BOUNDS?
01200		CAML	R3,MAXFRE
01300		JRST	MRKLOP	; NO, LOOP
01400		SKIPGE	R4,(R3)	; IS IT ALREADY MARKED? (R4_FIRST WORD)
01500		JRST	MRKLOP	; YES, LOOP
01600		SETZ	R1,	; NO
01700		LSHC	R1,4	; GET DESCR TYPE
01800		CAIN	R1,4	; IS IT NAME?
01900		JRST	MRKLOP	; YES, LOOP
02000		IORM	R0,(R3)	; NO, MARK
02100		JUMPE	R1,MRKLOP	; LOOP IF STRING
02200		PUSH	R6,R5	; SAVE BLOCK INDEX, PTR
02300		XCT	MRKDSC-5(R1)	; PERFORM MARKING PER DESCR TYPE
02400		POP	R6,R5	; RESTORE BLOCK INDEX, POINTER
02500	MRKLOP:	AOBJN	R5,MRKMLT	; LOOP IF MORE ELEMENTS
02600		POPJ	R6,	; OR RETURN
02700	; THREE DIFFERENT MULTIPLE ELEMENT DESCRIPTOR TYPES
02800	MRKDSC:	PUSHJ	R6,MRKART	; ARRAY OR TABLE
02900		JRST	MRKPAT	; PATTERN
03000		JRST	MRKDAT	; PROGRAMMER-DEFINED DATATYPE
03100	; ARRAY OR TABLE BLOCK
03200	MRKART:	JUMPL	R2,MRKTAB	; DESCRIPTOR BIT 4 = 1, IS TABLE
03300		SUB	R6,[XWD 1,1]	; ERASE PUSHJ
03400		MOVE	R5,(R4)	; GET FIRST WORD OF PROTOTYPE BLOCK
03500		JUMPL	R5,MRKCOM	; SKIP IF PROTOTYPE ALREADY MARKED
03600		IORM	R0,@(R5)	; MARK PROTOTYPE STRING
03700		IORM	R0,(R4)	; MARK PROTOTYPE BLOCK
03800	MRKCOM:	HRLZI	R5,(R3)	; GET BLOCK POINTER INTO LH
03900		HRRI	R5,MRKCNT	; GET 'CONTINUE MARKING' LAB INTO RH
04000		EXCH	R5,(R6)	; SIMULATE PUSHJ, AND RESTORE R5
04100		JRST	MRKLOP	; CONTINUE LOOP
04200	MRKCNT:	HLRZ	R5,1(R6)	; NOW MARK ELEMENTS OF BLOCK, GET PTR
04300		HLRZ	R4,(R5)	; GET -(SIZE) INTO LH OF R5
04400		TRZ	R4,3B19
04500		MOVNI	R4,(R4)
04600		HRLI	R5,(R4)
04700		AOBJN	R5,MRKMLT	; GO MARK
04800		POPJ	R6,	; THIS SHOULN'T HAPPEN, BUT QUIT JUST IN CASE
04900	; TABLE BLOCK
05000	MRKTAB:	ADDI	R3,2	; PTR TO EXTENSION WORD OF BASE BLOCK
05100		PUSH	R6,R3	; SAVE
05200		HLRZ	R5,-1(R3)	; COMPUTE NEXT AVAILABLE ENTRY POINTER
05300		MOVE	R4,-1(R3)
05400		ADDI	R5,(R4)
05500		PUSH	R6,R5	; SAVE
05600		HLRZ	R5,(R3)	; COMPUTE END OF CURRENT BLOCK
05700		ADDI	R5,1(R3)
05800		PUSH	R6,R5	; SAVE
05900		MOVEI	R5,1(R3)	; STARTING ENTRY POINTER FOR CURRENT BL
06000	TBMLOP:	CAMN	R5,-1(R6)	; REACHED NEXT AVAILABLE ENTRY?
06100		JRST	TBMFIN	; YES, FINISHED WITH WHOLE TABLE
06200		CAMN	R5,(R6)	; NO, REACHED END OF CURRENT BLOCK?
06300		JRST	TBMNXT	; YES, GO ON TO EXTENSION
06400		PUSH	R6,R5	; NO, SAVE MARKING POINTER
06500		ADD	R5,[XWD -2,2]	; SET UP TO MARK KEY AND VALUE DESCRS
06600		PUSHJ	R6,MRKMLT
06700		POP	R6,R5	; RESTORE MARKING POINTER
06800		ADDI	R5,4	; POINT TO NEXT ENTRY
06900		JRST	TBMLOP	; LOOP, WITH R5=0,NEXT ENTRY PTR
07000	TBMNXT:	HRRZ	R3,@-2(R6)	; GET PTR TO EXT WORD OF EXT BLOCK
07100		ADDI	R3,1
07200		MOVEM	R3,-2(R6)	; SAVE BACK IN STACK
07300		IORM	R0,-1(R3)	; MARK EXTENSION BLOCK
07400		HLRZ	R5,(R3)	; COMPUTE END OF CURRENT BLOCK
07500		ADDI	R5,1(R3)
07600		MOVEM	R5,(R6)	; SAVE BACK IN STACK
07700		JRST	TBMLOP-1	; RESTART LOOP
07800	TBMFIN:	SUB	R6,[XWD 3,3]	; RESET STACK PTR
07900		POPJ	R6,	; RETURN
08000	; PATTERN BLOCK
08100	MRKPAT:	MOVEI	R5,-1(R4)	; GET PTR TO FIRST WORD OF PATTERN BLOCK
08200		CAML	R5,MINCOR	; IS IT WITHIN FREE STORAGE BOUNDS?
08300		IORM	R0,(R5)	; YES, MARK IT
08400		JRST	MRKCOM	; NO, AND CONTINUE
08500	; DATATYPE BLOCK
08600		MRKDAT=MRKCOM	; PROTOTYPE STRING AND LOCATION ARE ALWAYS 
08700				; MARKED NONRETURNABLE
     
00100	; EXPAND CORE, TESTING FOR LAST 1K BLOCK LIMIT
00200	; CALL:	JSP	R6,EXPCOR	; WITH NEW CORE LIMIT IN R2, RETURNS
00300	;	TO 0(R6) IF ERROR OR INTO LAST 1K BLOCK, AND TO 1(R6) IF SUC-
00400	;	CESSFUL. LEAVES R0 AND R1 UNCHANGED
00500	EXPCOR:	CAIL	R2,^O776000	; INTO LAST 1K BLOCK?
00600		JRST	(R6)	; YES, FAIL
00700		CORE	R2,	; TRY TO EXPAND
00800		JRST	(R6)	; FAIL
00900		JRST	1(R6)	; SUCCEED
01000	
01100	; GARBAGE COLLECTION STACK OVERFLOW DURING MARKING
01200	; EXPAND CORE BY 1K BLOCK, EXPAND STACK (IN R6) BY SAME AMOUNT, EXPAND
01300	; GARSIZ BY EXTENSION SIZE (P$GBXT), AND RE-EXECUTE PUSH OR PUSHJ
01400	GRBOVF:	MOVE	R1,.JBREL	; GET CURRENT CORE LIMIT
01500		ADDI	R1,^O2000	; EXPAND BY 1K BLOCK
01600		CAIGE	R1,^O776000	; BUT NOT INTO LAST 1K OF CORE
01700		CORE	R1,	; EXPAND
01800		UFERR	4,PRGLNK	; ERROR
01900		HRLI	R6,-^O2000	; UPDATED STACK COUNT
02000		MOVEI	R1,P$GBXT	; GET EXTENSION SIZE
02100		ADDM	R1,GARSIZ	; MAKE GARBAGE STACK BIGGER IN THE FUTURE
02200		MOVE	R1,.JBCNI	; RESTORE R1
02300		JRST	@.JBTPC	; CONTINUE
02400	
02500	; STORAGE
02600	GARSIZ:	P$GBUF	; INITIAL GARBAGE COLLECT STACK SIZE
02700		SLOT1=CURCOR	; SLOT INDEX
02800		VARDEF	BLSIZE,1	; DESIRED BLOCK SIZE
02900		VARDEF	BLTYPE,1	; DESIRED BLOCK MARK TYPE
03000		VARDEF	BLLINK,1	; RETURN LINK
03100		VARDEF	BLPOIN,1	; DESIRED BLOCK POINTER
03200		VARDEF	AVLCOR,1	; CUMULATIVE AVAILABLE CORE
03300		VARDEF	BIGBLK,1	; LARGEST AVAILABLE BLOCK ENCOUNTERED
03400		VARDEF	LSTBLK,1	; LAST AVAILABLE BLOCK ENCOUNTERED
03500		VARDEF	AVLPTR,1	; CURRENT AVAILABLE CORE STARTING PTR
03600		VARDEF	AVLSIZ,1	; CURRENT AVAILABLE BLOCK SIZE
03700		VARDEF	AVLCNT,1	; AVAILABILITY INDICATOR
     
00100		SUBTTL	INPUT AND OUTPUT ASSOCIATION FUNCTIONS
00200	
00300		ENTRY	S$$AST,S$$ASB,S$$IOI,S$$IIX,S$$IOX
00400	
00500		COMMENT" THIS SECTION PERFORMS I/O AS A RESULT OF A MEMORY
00600	PROTECTION INTERRUPT, USING THE ILLEGAL ADDRESS AS AN INDEX IN THE ASSO-
00700	CIATION TABLE. IF THE INSTRUCTION CAUSING THE INTERRUPT IS A MOVE, SETZM,
00800	OR MOVEM, I/O IS PERFORMED PROVIDED THE RESPECTIVE ASSOCIATION EXISTS,
00900	AND THE KEYWORDS &INPUT OR &OUTPUT, RESPECTIVELY, ARE NONZERO.
01000	IF THE INSTRUCTION IS A SETM OR SETAM, OR A MOVE OR MOVEM WITHOUT A
01100	CORRESPONDING ASSOCIATION, THE OPERATION IS COMPLETED USING THE AC-
01200	TUAL VARIABLE ADDRESS, BUT NO I/O IS PERFORMED. ANY OTHER OPCODE OR
01300	ADDRESS BEYOND ASSOCIATION TABLE LIMITS IS AN ADDRESSING ERROR.
01400		R9 MUST NOT BE USED IN THE EFFECTIVE ADDRESS COMPUTATION,
01500	AND AN INPUT INSTRUCTION MUST NEVER IMMEDIATELY FOLLOW AN OUTPUT
01600	INSTRUCTION ON THE PDP-6 OR KA10."
01700	
01800	VIOASO:	MOVE	R1,.JBCNI	; RESTORE R1
01900		MOVEM	R9,STKSRG+9	; SAVE R9
02000		IFE	P$KI10,
02100	<	MOVE	R9,GOTINP	; CHANGE RESPONSE TO ILLEGAL ADDR
02200		MOVEM	R9,VIOASO+1	; DURING THIS COMPUTATION
02300		MOVE	R9,.JBTPC	; GET POINTER TO INSTR
02400		HRRM	R9,VIOEXT	; SAVE INSTR POINTER
02500		MOVE	R9,-1(R9)	; GET ACTUAL INSTRUCTION
02600		TLZN	R9,1B31	; CLOBBER INDIRECT BIT
02700		JRST	[HRRI	R9,@R9
02800			JRST	.+2]	; GET IMMEDIATE IF NOT INDIRECT
02900		HRR	R9,@R9	; GET FIRST LEVEL EFF ADDR
03000		TLZ	R9,^O17	; ERASE INDEX FIELD
03100		HLLZM	R9,VIOINS	; SAVE OP AC,
03200		MOVEI	R9,(R9)	; CLEAR LH
03300		CAIGE	R9,^O776000	; IS ADDR IN LAST 1K OF MEMORY?
03400	GOTINP:	JRST	TRYINP	; NO, TRY INPUT POSSIBILITY
03500		LSH	R9,2	; *4
03600		ADD	R9,ASOTBL	; + TABLE BASE
03700		HLLI	R9,	; CLEAR LH
03800		CAMG	R9,ASOTBT	; LESS THAN TABLE TOP?
03900		JRST	TRYINP	; YES, TRY INPUT
04000		MOVEM	R9,VIOENT	; SAVE ENTRY POINTER
04100		HRRZ	R9,(R9)	; GET VARIABLE POINTER
04200		HRRM	R9,VIOINS	; SAVE POINTER, GET OP AC,
04300		MOVE	R9,[MOVEM R9,STKSRG+9]	; CHANGE RESPONSE TO
04400		MOVEM	R9,VIOASO+1	; ILLEG ADDR BACK TO NORMAL
04500		HLLZ	R9,VIOINS	; GET OPCODE
04600		TLZ	R9,^O740
04700		IFN	P$PDP6,
04800	<	CAMN	R9,[MOVEM]	; IS IT A STORE?>
04900		IFE	P$PDP6,
05000	<	CAME	R9,[MOVEM]	; IS IT A STORE?
05100		CAMN	R9,[SETZM]>
05200		JRST	VIOOUT	; YES, DO OUTPUT
05300		CAME	R9,[SETAM]	; IS IT STORE W/O OUTPUT?
05400		JRST	TRYINP	; NO, TRY INPUT
05500		JRST	VIORET+1	; YES, DO STORE
05600	TRYINP:	MOVE	R9,GOTERR	; CHANGE RESPONSE AGAIN
05700		MOVEM	R9,VIOASO+1
05800		AOS	R9,VIOEXT	; BUMP INSTR POINTER, TRY INPUT
05900		MOVE	R9,-1(R9)	; AND GO THROUGH SAME SEQUENCE
06000		TLZN	R9,1B31
06100		JRST	[HRRI	R9,@R9
06200			JRST	.+2]
06300		HRR	R9,@R9
06400		TLZ	R9,^O17
06500		HLLZM	R9,VIOINS
06600		MOVEI	R9,(R9)
06700		CAIGE	R9,^O776000
06800	GOTERR:	JRST	ILLADR
06900		LSH	R9,2
07000		ADD	R9,ASOTBL
07100		HLLI	R9,
07200		CAMG	R9,ASOTBT
07300		JRST	ILLADR
07400		MOVEM	R9,VIOENT
07500		HRRZ	R9,(R9)
07600		HRRM	R9,VIOINS
07700		MOVE	R9,[MOVEM R9,STKSRG+9]
07800		MOVEM	R9,VIOASO+1
07900		HLLZ	R9,VIOINS
08000		TLZ	R9,^O740
08100		IFN	P$PDP6,
08200	<	CAMN	R9,[SETZM]	; IS IT A FUNNY STORE?
08300		JRST	VIOOUT	; YES, DO OUTPUT>
08400		CAMN	R9,[MOVE]	; IS IT A LOAD?
08500		JRST	VIOINP	; YES, DO INPUT
08600		CAMN	R9,[SETM]	; IS IT A LOAD W/O INPUT?
08700		JRST	VIORET+1	; YES, DO LOAD>
     
00100		IFN	P$KI10,
00200	<	MOVE	R9,GOTERR	; CHANGE RESPONSE TO ILLEGAL ADDR.
00300		MOVEM	R9,VIOASO+1	; DURING THIS COMPUTATION
00400		MOVE	R9,.JBTPC	; GET POINTER TO INSTRUCTION
00500		ADDI	R9,1	; INCREMENT PC
00600		HRRM	R9,VIOEXT	; SAVE NEXT INSTRUCTION POINTER
00700		MOVE	R9,-1(R9)	; GET ACTUAL INSTRUCTION
00800		TLZN	R9,1B31	; CLOBBER INDIRECT BIT
00900		JRST	[HRRI	R9,@R9
01000			JRST	.+2]	; GET IMMEDIATE IF NOT INDIRECT
01100		HRR	R9,@R9	; GET FIRST LEVEL EFFECTIVE ADDRESS
01200		TLZ	R9,^O17	; ERASE INDEX FIELD
01300		HLLZM	R9,VIOINS	; SAVE OP AC,
01400		MOVEI	R9,(R9)	; CLEAR LH
01500		CAIGE	R9,^O776000	; IS IT IN LAST 1K OF MEMORY?
01600	GOTERR:	JRST	ILLADR	; NO, ADDRESS ERROR
01700		LSH	R9,2	; GET -I/O INDEX*4
01800		ADD	R9,ASOTBL	; + TABLE BASE
01900		HLLI	R9,	; CLEAR LH
02000		CAMG	R9,ASOTBT	; LESS THAN TABLE TOP?
02100		JRST	ILLADR	; YES, ADDRESS ERROR
02200		MOVEM	R9,VIOENT	; SAVE I/O TABLE ENTRY POINTER
02300		HRRZ	R9,(R9)	; GET VARIABLE POINTER
02400		HRRM	R9,VIOINS	; SAVE POINTER
02500		MOVE	R9,[MOVEM R9,STKSRG+9]	; CHANGE RESPONSE TO ILLEGAL
02600		MOVEM	R9,VIOASO+1	; ADDRESS BACK TO NORMAL
02700		HLLZ	R9,VIOINS	; GET OPCODE
02800		TLZ	R9,^O740
02900		CAME	R9,[MOVEM]	; IS IT A STORE?
03000		CAMN	R9,[SETZM]
03100		JRST	VIOOUT	; YES, DO OUTPUT
03200		CAMN	R9,[MOVE]	; IS IT A LOAD?
03300		JRST	VIOINP	; YES, DO INPUT
03400		CAME	R9,[SETAM]	; IS IT A NON-I/O STORE
03500		CAMN	R9,[SETM]	; OR LOAD?
03600		JRST	VIORET+1	; YES, PERFORM ISTRUCTION>
03700		SOS	VIOEXT	; BUMP POINTER BACK
03800	VIOERA:	UFERR	5,VIOEXT	; NO, ADDRESS ERROR
03900	VIORET:	MOVE	R8,STKSRG+8	; RESTORE R8
04000		MOVE	R9,STKSRG+9	; RESTORE R9
04100	S$$IOI:			; EXTERNAL NAME FOR INSTRUCTION WORD
04200	VIOINS:	.-.	; PERFORM INSTRUCTION
04300	VIOEXT:	JRST	.-.	; RETURN
04400	ILLADR:	MOVE	R9,[MOVEM R9,STKSRG+9]	; CHANGE RESPONSE TO ILLEGAL
04500		MOVEM	R9,VIOASO+1	; ADDRESS BACK TO NORMAL
04600		JRST	VIOERA	; AND TAKE ERROR EXIT
04700		VARDEF	VIOENT,1	; ASSOCIATION ENTRY POINTER
     
00100	;  INPUT PROCESSING
00200	VIOINP:	SKIPN	KINP	; IS &INPUT ON?
00300		JRST	VIORET+1	; NO, DO NOT INPUT
00400		MOVEM	R8,STKSRG+8	; SAVE R8
00500		MOVE	R8,VIOENT	; GET ENTRY POINTER
00600		SKIPN	R9,2(R8)	; GET INPUT WORD, IS IT ZERO?
00700		JRST	VIORET	; YES, NO INPUT ASSOCIATION
00800		MOVEM	R7,STKSRG+7	; SAVE R0-R7
00900		HRRZI	R7,STKSRG
01000		BLT	R7,STKSRG+6
01100		HLRZ	R0,3(R8)	; GET MAX INPUT BLOCK SIZE
01200		JSP	R6,S$$GRS	; GET BLOCK FOR INPUT STRING
01300		HRLI	R1,^O700	; FORM STRING DESCRIPTOR
01400		MOVEM	R1,@VIOINS	; SAVE IN VARIABLE LOC
01500		JRST	(R9)	; PERFORM INPUT
01600	
01700	; OUTPUT PROCESSING
01800	VIOOUT:	SKIPN	KOUT	; IS &OUTPUT ON?
01900		JRST	VIORET+1	; NO, DO NOT OUTPUT
02000		MOVE	R9,STKSRG+9	; RESTORE R9
02100		XCT	VIOINS	; DO STORE
02200		MOVEM	R9,STKSRG+9	; SAVE R9
02300		MOVEM	R8,STKSRG+8	; SAVE R8
02400		MOVE	R8,VIOENT	; GET ENTRY POINTER
02500		SKIPN	R9,1(R8)	; GET OUTPUT WORD, IS IT ZERO?
02600		JRST	VIORET	; YES, NO OUTPUT ASSOCIATION
02700		MOVEM	R7,STKSRG+7	; SAVE R0-R7
02800		HRRZI	R7,STKSRG
02900		BLT	R7,STKSRG+6
03000		MOVE	R1,@VIOINS	; GET VALUE DESCRIPTOR
03100		JSP	R7,S$$CVS	; CONVERT TO STRING FROM ANY TYPE
03200		JRST	(R9)	; PERFORM OUTPUT
     
00100	; CONTROLLING TELETYPE LINE MODE INPUT
00200	TTYLMI:	HRRI	R9,0	; START COUNT AT 0
00300		MOVE	[XWD TLILOP,TLICHR]	; MOVE LOOP INTO R2-R8
00400		BLT	TLIEND
00500		JRST	TLICHR	; START LOOP
00600	TLILOP:	PHASE	2
00700	TLICHR:	INCHWL	R0	; R2: GET CHAR
00800		CAIN	R0,^O15	; R3: IS IT A CARRIAGE RETURN?
00900		JRST	TLIFIN	; R4: YES, JUMP OUT OF LOOP
01000		IDPB	R0,R1	; R5: NO, DEPOSIT IN STRING
01100		AOBJN	R9,TLICHR	; R6: LOOP IF ASSOC LEN IS NOT EXHAUSTED
01200		MOVE	.-2,.+1	; R7: SET UP TO THROW AWAY REST OF CHARS IN LINE
01300	TLIEND:	JRST	TLICHR	; R8: AND RESUME LOOP
01400		DEPHASE
01500	TLIFIN:	INCHWL	R0	; THROW AWAY LINE FEED
01600	S$$IIX:			; EXTERNAL NAME FOR INPUT EXIT
01700	VIOIND:	MOVE	R1,@VIOINS	; GET DESCR
01800		HRRM	R9,(R1)	; SAVE CHARACTER COUNT
01900		MOVE	R1,MXLN	; ASSURE STRING LENGTH DOES NOT EXCEED &MAXLGTH
02000		CAIGE	R1,(R9)
02100		CFERR	15,VIOEXT
02200		HRLZI	R9,STKSRG	; RESTORE R0-R9
02300		BLT	R9,R9
02400		JRST	VIOINS	; EXECUTE INSTRUCTION AND RETURN
02500	
02600	; CONTROLLING TELETYPE CHARACTER MODE INPUT
02700	TTYCMI:	HRRZI	R9,1	; ONE CHARACTER
02800		INCHRW	R0	; GET IT
02900		IDPB	R0,R1	; PUT IN STRING
03000		HRRM	R9,-1(R1)	; SET CHAR COUNT
03100		JRST	VIOIND+2	; FINISH UP INPUT
     
00100	; CONTROLLING TELETYPE LINE MODE OUTPUT
00200	TTYLMO:	HRRI	R9,0	; START COUNT AT 0
00300		JUMPE	R1,CRLFTY	; DO CR,LF IF NULL
00400		HRRZ	R8,(R1)	; GET CHAR COUNT
00500		JUMPE	R8,CRLFTY	; DO CR,LF IF 0 CHARS
00600		MOVE	[XWD TLOLOP,TLOCHR]	; MOVE LOOP INTO R2-R6
00700		BLT	TLOEND
00800		JRST	TLOCHR	; START LOOP
00900	TLOLOP:	PHASE	2
01000	TLOCHR:	ILDB	R0,R1	; R2: GET CHAR FROM STRING
01100		OUTCHR	R0	; R3: OUTPUT CHARACTER
01200		SOJE	R8,CRLFTY	; R4: SKIP OUT IF NO MORE CHARS
01300		AOBJN	R9,TLOCHR	; R5: LOOP IF ASSOC LEN IS NOT EXHAUSTED
01400	TLOEND:	JRST	ASCLTY	; R6: ASSOC LEN REACHED, SKIP OUT
01500		DEPHASE
01600	ASCLTY:	OUTCHR	[^O15]	; OUTPUT CR,LF
01700		OUTCHR	[^O12]
01800		MOVNI	R9,(R9)	; GET -ASSOC LEN,0 IN R9
01900		HRLZI	R9,(R9)
02000		JRST	TLOCHR	; GO BACK TO LOOP
02100	CRLFTY:	OUTCHR	[^O15]	; OUTPUT CR,LF
02200		OUTCHR	[^O12]
02300	S$$IOX:			; EXTERNAL NAME FOR OUTPUT EXIT
02400	VIOOND:	HRLZI	R9,STKSRG	; RESTORE R0-R9
02500		BLT	R9,R9
02600		JRST	@VIOEXT	; EXIT
02700	
02800	; CONTROLLING TELETYPE CHARACTER MODE OUTPUT
02900	TTYCMO:	JUMPE	R1,VIOOND	; FINISHED IF NULL
03000		HRRZ	R8,(R1)	; GET CHAR COUNT
03100		JUMPE	R8,VIOOND	; FINISHED IF 0 CHARS
03200		MOVE	[XWD TCOLOP,TCOCHR]	; MOVE LOOP INTO R2-R5
03300		BLT	TCOEND
03400		JRST	TCOCHR	; START LOOP
03500	TCOLOP:	PHASE	2
03600	TCOCHR:	ILDB	R0,R1	; R2: GET CHAR FROM STRING
03700		OUTCHR	R0	; R3: OUTPUT CHAR
03800		SOJN	R8,TCOCHR	; R4: LOOP FOR EACH CHAR
03900	TCOEND:	JRST	VIOOND	; R5: OR FINISH UP
04000		DEPHASE
     
00100	; STORAGE AND INITIAL PARAMETERS
00200		P$ASIZ=P$ALEN/5	; COMPUTE BLOCK SIZE FOR DEFAULT ASSOCIATION LEN
00300		IFN	P$ALEN-P$ASIZ*5,<P$ASIZ=P$ASIZ+1>
00400		P$ASIZ=P$ASIZ+1
00500	S$$AST:			; EXTERNAL NAME FOR POINTER TO TOP OF ASSOC TABLE
00600	ASOTBT:	.+1	; ASSOC TABLE TOP POINTER
00700		SHD	2,P$ATXT+1,P$ATXT	; ASSOC TABLE HEADER WORD
00800		REPEAT	P$ATXT-16,<0>	; EMPTY ASSOCIATION ENTRIES
00900		XWD	S$$OUC,LOCOUC	; 'OUTPUTC' ASSOCIATION
01000		XWD	0,TTYCMO
01100		0
01200		0
01300		XWD	S$$OUT,LOCOUT	; 'OUTPUT' ASSOCIATION
01400		XWD	-P$ALEN,TTYLMO
01500		0
01600		0
01700		XWD	S$$INC,LOCINC	; 'INPUTC' ASSOCIATION
01800		0
01900		XWD	0,TTYCMI
02000		XWD	2,0
02100		XWD	S$$INP,LOCINP	; 'INPUT' ASSOCIATION
02200		0
02300		XWD	-P$ALEN,TTYLMI
02400		XWD	P$ASIZ,0
02500	S$$ASB:			; EXTERNAL NAME FOR POINTER TO BASE OF ASSOC TAB
02600	ASOTBL:	.	; ASSOC TABLE BASE POINTER
02700		XWD	TTYLMO,TTYLMI	; TTY LINE MODE OUTPUT/INPUT
02800		XWD	TTYCMO,TTYCMI	; TTY CHAR MODE OUTPUT/INPUT
     
00100		SUBTTL	RUNTIME ERRORS
00200	
00300		COMMENT/
00400	CALL:	CFERR	ERRNO,LOC	; CONDITIONALLY FATAL ERROR
00500	CALL:	UFERR	ERRNO,LOC	; UNCONDITIONALLY FATAL ERROR
00600	
00700		STORE ERRNO (ERRNO+16 FOR UFERR) IN &ERRTYPE, AND IF CFERR AND
00800	IF &ERRLIMIT IS NOT 0, DECREMENT &ERRLIMIT AND GO TO FAILPOINT ROUTINE.
00900	OTHERWISE OUTPUT ERROR NUMBER AND LOCATION (C(LOC)-1), AND GO TO SYSTEM
01000	EXIT SEQUENCE/
01100	
01200	LCFERR:	MOVEM	R7,SAVXR7	; CONDITIONAL
01300		JSP	R7,ERRCOM
01400	LUFERR:	MOVEM	R7,SAVXR7	; UNCONDITIONAL
01500		JSP	R7,ERRCOM
01600		VARDEF	SAVXR0,8	; SPACE TO SAVE R0-R7
01700		SAVXR7=SAVXR0+7
01800	ERRCOM:	SUBI	R7,LUFERR	; FORM INDEX (0 OR 2)
01900		HRRM	R7,ERXTYP	; SAVE
02000		LDB	R7,[POINT 5,.JBUUO,12]	; GET ERROR TYPE (+16 FOR UFERR)
02100		MOVEM	R7,ERRT	; SAVE IN &ERRTYPE
02200	ERXTYP:	MOVEI	R7,.-.	; RESTORE INDEX
02300		JUMPN	R7,.+3	; SKIP OVER IF UNCONDITIONAL
02400		SOSL	ERLT	; DECREMENT &ERRLIMIT AND
02500		JRST	S$$FLR	; FAIL IF >0
02600		HRRZI	R7,SAVXR0	; OTHERWISE SAVE R0-R6
02700		BLT	R7,SAVXR7-1
02800		MOVE	R1,ERRPT1	; EDIT ERROR NUMBER
02900		MOVE	R2,ERRT	; INTO ERROR MESSAGE
03000		JSP	R4,S$$ITS
03100		MOVEI	R0,6	; EDIT 6-DIGIT OCTAL ADDRESS
03200		MOVE	R1,ERRPT2	; INTO ERROR MESSAGE
03300		MOVE	R2,@.JBUUO	; RH IS ERROR ADDR + 1
03400		HRLZI	R2,-1(R2)	; LH IS ERROR ADDR
03500	EROCTL:	HLRI	R2,	; CONVERT TO 6-DIGIT OCTAL
03600		ROT	R2,3
03700		ADDI	R2,"0"
03800		IDPB	R2,R1
03900		SOJN	R0,EROCTL
04000		MOVE	R1,ERRDSC	; OUTPUT ERROR MESSAGE
04100		MOVEM	R1,@S$$OUT	; ON 'OUTPUT' DEVICE
04200		JRST	SYSEXC	; GO TO COMMON EXIT SEQUENCE
04300	; STORAGE
04400	ERRDSC:	POINT	7,.+1,35	; ERROR MESSAGE DESCRIPTOR
04500		SHD	2,6,23
04600	ERRSTR:	ASCII/ERROR    AT USER       /
04700	ERRPT1:	POINT	7,ERRSTR+1,6	; POINTER TO ERROR TYPE CHARS
04800	ERRPT2:	POINT	7,ERRSTR+3,13	; POINTER TO ERROR LOC CHARS
     
00100		SUBTTL	SYSTEM EXITS
00200	
00300		ENTRY	S$$SXT
00400		EXTERN	S$$TMX,S$$TMF,S$$DMP
00500	
00600		COMMENT/
00700	CALL:	JRST	S$$SXT	; FROM 'END' STATEMENT OF ANY PROGRAM
00800		DOES OUTPUT OF EXIT MESSAGES, AND TIMING STATISTICS IF REQUIRED.
00900	IF &ABEND IS OFF, AN EXIT 0, IS PERFORMED, OTHERWISE AN EXIT 1, IS DONE/
01000	
01100	S$$SXT:	MOVEM	R7,SAVXR7	; SAVE R0-R7
01200		HRRZI	R7,SAVXR0
01300		BLT	R7,SAVXR7-1
01400		MOVE	R1,NORDSC	; OUTPUT NORMAL TERMINATION MESSAGE
01500		MOVEM	R1,@S$$OUT	; ON 'OUTPUT' DEVICE
01600	SYSEXC:	JSP	R5,S$$TMF	; FINISH TIMING LAST STATEMENT
01700		SETZ	R0,
01800		RUNTIM	R0,	; SAVE EXECUTION TIME
01900		SUB	R0,SSTT	; = FINISH TIME - START TIME
02000		MOVEM	R0,STATV+4
02100		MOVE	R1,LOCDC1	; "/IN STATEMENT "
02200		MOVEM	R1,@S$$OUC
02300		MOVE	R1,DUMDSC	; OUTPUT STATEMENT NUMBER
02400		MOVE	R2,STNO
02500		JSP	R4,S$$ITS
02600		HRRM	R3,DUMBLK
02700		MOVE	R1,DUMDSC
02800		MOVEM	R1,@S$$OUC
02900		MOVE	R1,LOCDC2	; " OF "
03000		MOVEM	R1,@S$$OUC
03100		MOVE	R1,PBLP	; OUTPUT PROGRAM NAME
03200		MOVE	R1,-2(R1)
03300		MOVEM	R1,@S$$OUC
03400		MOVE	R1,LOCDC3	; " AT LEVEL "
03500		MOVEM	R1,@S$$OUC
03600		MOVE	R1,DUMDSC	; OUTPUT FUNCTION LEVEL
03700		MOVE	R2,FNCL
03800		JSP	R4,S$$ITS
03900		HRRM	R3,DUMBLK
04000		MOVE	R1,DUMDSC
04100		MOVEM	R1,@S$$OUT
04200		MOVE	R1,STADSC	; "////FASBOL STATISTICS SUMMARY-"
04300		MOVEM	R1,@S$$OUT
     
00100	; SET UP DATA FOR STATISTICS LOOP
00200		MOVE	R1,STATV+4	; GET EXECUTION TIME
00300		IMULI	R1,1000	; IN MICROSECONDS
00400		MOVE	R2,STCN	; TOTAL STATEMENTS EXECUTED
00500		MOVEM	R2,STATV+3
00600		JUMPE	R2,.+2	; SKIP IF 0
00700		IDIV	R1,R2	; MICROSEC PER STATEMENT
00800		MOVEM	R1,STATV
00900		MOVE	R1,STFC	; GET # OF STATEMENTS FAILED
01000		MOVEM	R1,STATV+2
01100		MOVEI	R7,4	; 5 STATISTICS
01200	
01300	; STATISTICS LOOP
01400	STATLP:	MOVE	R1,DUMDSC	; CONVERT STATISTIC TO STRING
01500		MOVE	R2,STATV(R7)
01600		JSP	R4,S$$ITS
01700		HRRM	R3,DUMBLK
01800		MOVEI	R2,INDENT	; LEFT PAD WITH BLANKS
01900		SUBI	R2,(R3)
02000		HRRM	R2,BLANKD+1
02100		MOVE	R1,BLANKD	; OUTPUT PADDING
02200		MOVEM	R1,@S$$OUC
02300		MOVE	R1,DUMDSC	; OUTPUT STATISTIC
02400		MOVEM	R1,@S$$OUC
02500		MOVE	R1,STATM(R7)	; OUTPUT STATISTIC MESSAGE
02600		MOVEM	R1,@S$$OUT
02700		SOJGE	R7,STATLP	; LOOP FOR EACH STATISTIC
02800	
02900	; POSSIBLE ADDITIONAL OUTPUT
03000		MOVE	R6,PRGL	; GET PROGRAM LIST
03100		JSP	R7,S$$TMX	; PRINT OUT TIMER STATISTICS, IF ANY
03200		SKIPE	DUMP	; IS &DUMP ON?
03300		JSP	R7,S$$DMP	; YES, DO DUMP
03400		HRLZI	R7,SAVXR0	; RESTORE R0-R7
03500		BLT	R7,R7
03600		SKIPN	ABND	; IS &ABEND=0?
03700		EXIT		; YES, EXIT NORMALLY
03800		EXIT	1,	; NO, EXIT ABNORMALLY
     
00100	; STORAGE
00200	NORDSC:	POINT	7,.+1,35
00300		SHD	2,5,18
00400		ASCII/NORMAL TERMINATION/
00500	LOCDC1:	POINT	7,.+1,35
00600		SHD	2,4,14
00700		BYTE	(7)^O12,"I","N"," ","S"
00800		ASCII/TATEMENT /
00900	DUMDSC:	POINT	7,DUMBLK,35
01000		VARDEF	DUMBLK,3
01100	LOCDC2:	POINT	7,.+1,35
01200		SHD	2,2,4
01300		ASCII/ OF /
01400	LOCDC3:	POINT	7,.+1,35
01500		SHD	2,3,10
01600		ASCII/ AT LEVEL /
01700	STADSC:	POINT	7,.+1,35
01800		SHD	2,7,30
01900		BYTE	(7)^O12,^O12,^O12,^O12,"F"
02000		ASCII/ASBOL STATISTICS SUMMARY-/
02100	STATV:	REPEAT	5,<0>	; STATISTICS VARIABLES
02200		INDENT=15
02300	BLANKD:	POINT	7,.+1,35
02400		SHD	2,4,15
02500		ASCII/               /
02600	STATM:	POINT	7,XMSG5,35
02700		POINT	7,XMSG4,35
02800		POINT	7,XMSG3,35
02900		POINT	7,XMSG2,35
03000		POINT	7,XMSG1,35
03100	XMSG1:	SHD	2,5,19
03200		ASCII/ MS. EXECUTION TIME/
03300	XMSG2:	SHD	2,5,20
03400		ASCII/ STATEMENTS EXECUTED/
03500	XMSG3:	SHD	2,5,18
03600		ASCII/ STATEMENTS FAILED/
03700	XMSG4:	SHD	2,8,33
03800		ASCII/ REGENERATIONS OF DYNAMIC STORAGE/
03900	XMSG5:	SHD	2,8,32
04000		ASCII/ MICROSECONDS AVG. PER STATEMENT/
     
00100		SUBTTL	SYMBOL TABLE
00200	
00300		ENTRY	S$$SY1,S$$SY2,S$$SYI
00400	
00500		COMMENT"
00600		SYMBOL LOOKUP
00700	CALL:	JSP	R7,S$$SY1	; WITH TYPE/NO. IN LH(R0), KEY DESCRIPTOR
00800		IN R1. IF NOT FOUND, RETURN TO 1(R7) WITH TYPE/NO.,MAJOR KEY
00900		IN R0, KEY DESCR IN R1, PTR TO NEXT LARGER ENTRY IN R2, BUCKET
01000		POINTER IN R3, AND COMPARE TYPE WORD IN R4. IF FOUND, RETURN
01100		TO 0(R7) WITH PTR TO VALUE LOC IN R2
01200	
01300		SYMBOL LOOKUP RETRY
01400	CALL:	JSP	R7,S$$SY2	; WITH R0-R4 SET TO RESULTS OF S$$SY1
01500		(NOT FOUND), EXCEPT TYPE/NO. MODIFIED. SAME RETURN CONVENTIONS
01600		AS S$$SY1
01700	
01800		SYMBOL BLOCK INITIALIZATION
01900	CALL:	JSP	R10,S$$SYI	; WITH SYMBOL BLOCK POINTER IN R9, SYM-
02000		BOL TABLE NUMBER IN LH(R8), WITH RH(R8)=0
02100	
02200		SYMBOL ENTRIES ON EACH BUCKET CHAIN ARE ORDERED FROM LEAST TO
02300	GREATEST BY THE TYPE/NO.,MAJOR KEY WORD. THE KEY DESCRIPTOR IS NOR-
02400	MALLY USED AS THE HASHWORD, EXCEPT IN THE CASE OF STRINGS, WHERE THE
02500	HASHWORD IS DERIVED BY ADDING AND SHIFTING FOR EACH CHARACTER UP TO A
02600	MAXIMUM OF 28 CHARACTERS. THE BUCKET ENTRY IS COMPUTED BY DIVIDING THE
02700	HASHWORD BY THE HASHSIZE (=BUCKET TABLE SIZE), USUALLY A PRIME NUMBER.
02800	THE REMAINDER IS USED AS THE BUCKET INDEX RELATIVE TO THE TABLE BASE,
02900	AND THE QUOTIENT TRUNCATED TO THE 18 RIGHTMOST BITS IS USED AS THE
03000	MAJOR KEY"
03100	
03200	; SYMBOL BLOCK INITIALIZATION
03300	S$$SYI:	HRL	R9,(R9)	; GET -COUNT INTO LH(R9)
03400		AOJA	R9,.+2	; POINT AT FIRST ENTRY
03500	SYILOP:	ADDI	R9,3	; 4 WORDS PER ENTRY
03600		MOVE	R0,1(R9)	; GET TYPE
03700		MOVE	R1,2(R9)	; GET KEY (STRING) DESCRIPTOR
03800		TLNE	R0,^O20000	; IS IT TYPE 1,3, OR 5 (LOCAL SYMBOL)
03900		ADD	R0,R8	; YES, ADD TABLE NUMBER
04000		JSP	R7,S$$SY1	; LOOK IT UP
04100		JRST	MLDFER	; SHOULD NOT FIND, ERROR
04200		HLRZ	R6,(R2)	; SPLICE INTO BUCKET CHAIN
04300		HRRM	R9,(R6)
04400		HRLM	R9,(R2)
04500		HRLI	R2,(R6)
04600		MOVEM	R2,(R9)
04700		MOVEM	R0,1(R9)	; SAVE TYPE/NO,MAJOR KEY
04800		AOBJN	R9,SYILOP	; LOOP
04900		JRST	(R10)	; RETURN
     
00100	; SYMBOL LOOKUP AND RETRY
00200	S$$SY1:	MOVE	R2,R1	; GET DESCR
00300		JUMPE	R2,OTHRTY	; SKIP OUT IF NULL
00400		TLNE	R2,^O770000	; IS IT STRING?
00500		JRST	OTHRTY	; NO, SKIP
00600		HRRZ	R3,(R2)	; GET CHAR COUNT
00700		CAILE	R3,28	; IS IT >28?
00800		MOVEI	R3,28	; YES, 28 IS ENOUGH
00900		SETZ	R4,	; INITIALIZE HASHWORD
01000		JUMPN	R3,STRNTY	; DO HASH IF CHARS>0
01100		SETZB	R2,R1	; OTHERWISE SAME AS NULL
01200	OTHRTY:	MOVE	R4,[CAME R1,2(R2)]	; COMPARISON FOR NON- OR NULL STRINGS
01300		JRST	DOHASH	; GO DO HASH
01400	STRNLP:	LSH	R4,1	; PREPARE FOR ONE MORE CHAR
01500	STRNTY:	ILDB	R5,R2	; GET IT
01600		ADDI	R4,(R5)	; ADD IT TO HASHWORD
01700		SOJG	R3,STRNLP	; LOOP FOR N-1 CHARS
01800		MOVE	R2,R4	; MOVE TO PROPER HASHWORD LOC
01900		MOVE	R4,[JRST STRCOM]	; COMPARISON FOR STRINGS
02000	DOHASH:	IDIVI	R2,.-.	; DIVIDE BY HASHSIZE (SET BY SYSTEM INI.)
02100		HRRI	R0,(R2)	; SET MAJOR KEY
02200		MOVM	R2,R3	; GET BUCKET INDEX
02300	BUCKTB:	ADDI	R2,.-.	; ADD TABLE BASE (SET BY SYSTEM INI.)
02400		MOVEI	R3,(R2)	; SAVE BUCKET POINTER
02500		SKIPE	(R2)	; IS BUCKET EMPTY?
02600		JRST	SRCHLP	; GO SEARCH IF NONZERO
02700		HRLM	R2,(R2)	; MAKE EMPTY BUCKET CHAIN AND SAVE IN BUCKET
02800		HRRM	R2,(R2)
02900		JRST	1(R7)	; RETURN NOT FOUND
03000	SRCHLP:	HRRZ	R2,(R2)	; GET NEXT ENTRY POINTER
03100	S$$SY2:	CAIN	R2,(R3)	; IS IT BUCKET?
03200		JRST	1(R7)	; YES, RETURN NOT FOUND
03300		CAMLE	R0,1(R2)	; IS TYPE/NO,MAJOR KEY>ENTRY?
03400		JRST	SRCHLP	; YES, CONTINUE SEARCH
03500		CAME	R0,1(R2)	; IS IT EQUAL?
03600		JRST	1(R7)	; NO, IS <, RETURN NOT FOUND
03700		XCT	R4	; COMPARE KEYS FOR TRUE EQUALITY
03800		JRST	SRCHLP	; NOT EQUAL, KEEP SEARCHING
03900		ADDI	R2,3	; EQUAL, GET PTR TO VALUE WORD
04000		JRST	(R7)	; AND RETURN FOUND
04100	STRCOM:	HRRZ	R6,(R1)	; GET CRAR COUNT OF KEY
04200		HRRZ	R5,@2(R2)	; GET CHAR COUNT OF ENTRY KEY
04300		CAIE	R6,(R5)	; SAME?
04400		JRST	SRCHLP	; NO, STRINGS CAN'T BE EQUAL
04500		MOVEM	R1,SYMDSC	; SAVE KEY DESCR
04600		HRRM	R3,BCKPTR	; SAVE BUCKET POINTER
04700		MOVE	R4,2(R2)	; GET ENTRY KEY DESCR
04800	COMLOP:	ILDB	R5,R1	; GET CHAR FROM KEY
04900		ILDB	R3,R4	; GET CHAR FROM ENTRY KEY
05000		CAIE	R5,(R3)	; SAME?
05100		JRST	STRNEQ	; NO, STRINGS NOT EQUAL
05200		SOJG	R6,COMLOP	; LOOP FOR EACH CHAR
05300		ADDI	R2,3	; OR FINISHED, STRINGS EQUAL,
05400		JRST	(R7)	; GET PTR TO VALUE WORD AND RETURN FOUND
05500	STRNEQ:	MOVE	R1,SYMDSC	; RESTORE KEY DESCR
05600	BCKPTR:	MOVEI	R3,.-.	; RESTORE BUCKET POINTER
05700		MOVE	R4,[JRST STRCOM]	; RESTORE EQUALITY TEST
05800		JRST	SRCHLP	; CONTINUE SEARCHING
05900	
06000	; MULTIPLE DEFINITION ERROR
06100	MLDFER:	MOVE	R6,MLDERM
06200		MOVEM	R6,@S$$OUC
06300		MOVE	R6,2(R9)
06400		MOVEM	R6,@S$$OUT
06500		UFERR	1,PRGLNK
06600	; STORAGE
06700	MLDERM:	POINT	7,.+1,35
06800		SHD	2,7,30
06900		ASCII/>>>> MULTIPLY-DEFINED GLOBAL: /
07000	SYMDSC:	BLOCK	1	; DANGEROUS TO USE VARDEF HERE
     
00100		SUBTTL	FUNCTION CALL HANDLER
00200	
00300		ENTRY	S$$EQA
00400	
00500		COMMENT/
00600		EUALIZE ARGUMENTS
00700	CALL:	JSP	R4,S$$EQA	; WITH ACTUAL NUMBER OF ARGS IN R2,
00800		EXPECTED NUMBER IN R3. ALL ARGUMENTS, IF ANY, ARE ON ES, AND
00900		EXTRA ONES ARE REMOVED OR NULL VALUES ADDED. R3 IS UNCHANGED
01000	
01100		FUNCTION CALL
01200	CALL:	FCALV	NARG,FLOC	; CALL FOR VALUE
01300	CALL:	FCALN	NARG,FLOC	; CALL FOR NAME
01400		WHERE NARG IS THE NUMBER OF ACTUAL ARGUMENTS IN THE FUNCTION
01500		CALL, AND FLOC IS A PTR TO THE FUNCTION WORD. THE LAST ARGUMENT,
01600		IF ANY, IS IN R1, WITH REMAINING ARGS ON ES.
01700		THE PC IS SAVED IN PRGLNK, AND IF THE A FIELD OF THE FUNCTION
01800	WORD IS 0, THE NUMBER OF ARGUMENTS SUPPLIED IS EQUALIZED TO THE NUMBER
01900	REQUIRED. THE FUNCTION IS CALLED, WITH APPROPRIATE ACTION TAKEN ON
02000	'RETURN' (JRST (LINK)) AND 'NRETURN' (JRST 1(LINK)), WITH FUNCTION
02100	VALUE RETURNED IN R1. 'FRETURN' WILL CAUSE A DIRECT JUMP TO THE FAILPOINT
02200	ROUTINE/
02300	
02400	LFCALN:	JSP	R12,LFCALV+1	; FORM INDEX FOR NAME (0)
02500	LFCALV:	JSP	R12,LFCALV+1	; FORM INDEX FOR VALUE (1)
02600		SUBI	R12,LFCALV
02700		MOVE	R2,S$$UPC	; SAVE PC
02800		MOVEM	R2,PRGLNK
02900		LDB	R2,[POINT 4,.JBUUO,12]	; GET ACTUAL NUMBER OF ARGS
03000		JUMPE	R2,.+2	; SKIP IF NO ARGS
03100		PUSH	ES,R1	; OTHERWISE PUSH LAST ONE ON STACK
03200		MOVE	R11,@.JBUUO	; GET FUNCTION WORD
03300		LDB	R3,[POINT 5,R11,12]	; GET 'A' FLAG, REQUIRED ARGS
03400		TRNN	R3,^O20	; SHOULD ARGS BE EQUALIZED? ('A'=0)
03500		JSP	R4,S$$EQA	; YES, EQUALIZE THEM
03600		XCT	FCALL(R12)	; DO FUNCTION CALL
03700		CFERR	8,PRGLNK	; 'RETURN' FOR NAME CALL, ERROR
03800		JRST	@PRGLNK	; 'NRETURN' FOR NAME, 'RETURN' FOR VALUE CALL
03900		MOVE	R1,(R1)	; 'NRETURN' FOR VALUE CALL,
04000		JRST	@PRGLNK	; GET VALUE FROM NAME
04100	FCALL:	JSP	R12,(R11)	; NAME CALL
04200		JSP	R12,.+1	; VALUE CALL
04300		AOJA	R12,(R11)	; RETURNS TO PC 1 GREATER
04400	S$$EQA:	SUBI	R2,(R3)	; GET ACTUAL-DESIRED
04500		JUMPE	R2,(R4)	; RETURN IF 0
04600		JUMPL	R2,NULPAD	; DESIRED>ACTUAL, ADD NULL ARGS
04700		POP	ES,R1	; DESIRED<ACTUAL, GET RID OF EXTRAS
04800		SOJG	R2,.-1
04900		JRST	(R4)	; AND RETURN
05000	NULPAD:	SETZ	R1,	; NULL VALUE
05100		PUSH	ES,R1	; ADD EXTRA ARGS
05200		AOJL	R2,.-1
05300		JRST	(R4)	; RETURN
     
00100		SUBTTL	DEDICATED MODE ROUTINES
00200	
00300		ENTRY	S$$MKS,S$$MKI,S$$MKR,S$$DSG
00400	
00500		COMMENT/
00600	CALL:	DASGN	TYPE,VLOC	; DEDICATED ASSIGNMENT, WHERE DESCRIPTOR
00700		IN R1 IS CONVERTED TO APPROPRIATE TYPE (1=STRING, 2=INTEGER,
00800		3=REAL), AND STORED IN THE VARIABLE LOCATION VLOC
00900	
01000	CALL:	JRST	S$$DSG	; LIKE DASGN, EXCEPT VLOC IS ALREADY
01100		IN R8, AND LINK IN R9 AND IN PRGLNK
01200	
01300	CALL:	DCONC	ARGNO,VLOC	; DEDICATED STRING CONCATENATION AND
01400		ASSIGNMENT, WHERE ARGNO IS THE NUMBER OF ELEMENTS IN THE CON-
01500		CATENATION (LAST IN R1, REST ON ES), AND VLOC IS THE DEDICATED
01600		STRING VARIABLE INTO WHICH THE CONCATENATION IS TO BE STORED
01700	
01800	CALL:	JSP	R7,S$$MKI	; MAKE INTEGER, WITH DESCRIPTOR IN R1,
01900		RETURNS TO 0(R7) IF UNABLE, OR TO 1(R7) WITH INTEGER IN R1
02000	
02100	CALL:	JSP	R7,S$$MKR	; MAKE REAL, SIMILAR TO S$$MKI
02200	
02300	CALL:	JSP	R7,S$$MKS	; MAKE STRING, WITH DESCRIPTOR IN R1.
02400		RETURNS TO 0(R7) IF UNABLE, OR TO 1(R7) WITH STRING DESCRIPTOR
02500		IN R1. IF R0<0, THEN IF R1 DOES NOT ALREADY CONTAIN A STRING
02600		DESCRIPTOR, STORAGE IS ACQUIRED FOR THE NEW STRING, THE DESCRIP-
02700		TOR FOR THE NEW STRING IS RETURNED IN R1, AND THE CHARACTER
02800		COUNT FOR THE NEW STRING IS STORED IN THE STORAGE BLOCK. IF R0
02900		=0 OR >0, THEN THE BYTE POINTER IN R2 IS USED TO STORE THE STRING,
03000		WITH THE UPDATED BYTE POINTER RETURNED IN R2, THE ORIGINAL BYTE
03100		POINTER RETURNED IN R1 IF A CONVERSION FROM INTEGER OR REAL WAS
03200		DONE, AND R0 USED TO DETERMINE THE MAXIMUM CHARACTER COUNT.
03300		IN ANY CASE, THE ACTUAL CHARACTER COUNT IS RETURNED IN R3/
     
00100	; DEDICATED ASSIGNMENT
00200	LDASGN:	MOVE	R8,.JBUUO	; GET VLOC POINTER
00300		MOVE	R9,S$$UPC	; GET LINK
00400		MOVEM	R9,PRGLNK	; SAVE RETURN LINK
00500		SKIPN	R3,[POINT 4,R8,12]	; TYPE POINTER FOR LDASGN
00600	S$$DSG:	MOVE	R3,[POINT 2,R8,5]	; TYPE POINTER FOR S$$DSG
00700		LDB	R2,R3	; GET TYPE
00800		XCT	CNVDSG-1(R2)	; DO PROPER TYPE OF CONVERSION
00900		CFERR	1,PRGLNK	; NO CONVERSION POSSIBLE, ILLEGAL TYPE
01000		MOVEM	R1,(R8)	; STORE INTEGER OR REAL IN LOC
01100		JRST	(R9)	; RETURN
01200	CNVDSG:	JRST	.+3	; STRING, GO TO CONVERSION SEQUENCE
01300		JSP	R7,S$$MKI	; INTEGER MAKE
01400		JSP	R7,S$$MKR	; REAL MAKE
01500		MOVE	R2,(R8)	; GET BYTE POINTER FO^ DEDICATED STRING
01600		HLRZ	R0,(R2)	; COMPUTE MAXIMUM CHARACTERS FROM BLOCK SIZE
01700		SUBI	R0,1
01800		IMULI	R0,5
01900		JSP	R7,S$$MKS	; MAKE STRING AND STORE
02000		CFERR	1,PRGLNK	; COULD NOT BE CONVERTED
02100		HRRM	R3,@(R8)	; SAVE CHAR COUNT IN STRING
02200		JRST	(R9)	; RETURN
02300	
02400	; DEDICATED STRING CONCATENATION AND ASSIGNMENT
02500	LDCONC:	MOVE	R8,.JBUUO	; GET ARGNO,PTR
02600		MOVE	R9,S$$UPC	; GET LINK
02700		MOVEM	R9,PRGLNK	; SAVE LINK
02800		LDB	R9,[POINT 4,R8,12]	; GET ARGNO
02900		MOVNI	R9,(R9)	; FORM -(ARGNO,ARGNO)
03000		HRLI	R9,-1(R9)
03100		PUSH	ES,R1	; PUSH LAST ELEMENT ONTO ES
03200		ADD	ES,R9	; RESET ES BELOW ARGS
03300		HRRI	R9,(ES)	; SET UP ELEMENT POINTER TO FIRST
03400		AOBJN	R9,.+1
03500		MOVE	R2,(R8)	; GET BYTE POINTER FOR DEDICATED STRING
03600		HLRZ	R0,(R2)	; COMPUTE MAX CHARS
03700		SUBI	R0,1
03800		IMULI	R0,5
03900		HRLZI	R8,(R8)	; SAVE LOC PTR, SET INITIAL CHAR COUNT TO 0
04000	DCNLOP:	MOVE	R1,(R9)	; GET NEXT ELEMENT DESCR
04100		JSP	R7,S$$MKS	; CONV IF NECESSARY, PUT IN DED STRING
04200		CFERR	1,PRGLNK	; CAN'T CONVERT
04300		ADDI	R8,(R3)	; INCREASE CHARACTER COUNT
04400		SUBI	R0,(R3)	; DECREASE MAX CHARS
04500		AOBJN	R9,DCNLOP	; LOOP FOR EACH ELEMENT
04600		MOVS	R8,R8	; SWAP LOCPTR,CHARS
04700		HLRM	R8,@(R8)	; SAVE TOTAL CHARS IN STRING
04800		JRST	@PRGLNK	; RETURN
     
00100	; MAKE INTEGER
00200	S$$MKI:	SETZ	R2,	; CLEAR AND SHIFT IN TYPE
00300		ROTC	R1,2
00400		XCT	MKITYP(R2)	; EXECUTE ACCORDING TO TYPE
00500		JRST	1(R7)	; RETURN SUCCESSFULLY
00600	MKITYP:	JRST	S$$STI-1	; STRING, TRY TO MAKE INTEGER
00700		JRST	(R7)	; NAME, ETC- NO GO
00800		ASH	R1,-2	; INTEGER
00900		JSP	R3,S$$RTI	; RESL, CONVERT TO INTEGER
01000	
01100	; MAKE REAL
01200	S$$MKR:	SETZ	R2,	; CLEAR AND SHIFT IN TYPE
01300		ROTC	R1,2
01400		XCT	MKRTYP(R2)	; EXECUTE ACCORDING TO TYPE
01500		JRST	1(R7)	; RETURN SUCCESSFULLY
01600	MKRTYP:	JRST	S$$STR-1	; STRING, TRY TO MAKE REAL
01700		JRST	(R7)	; NAME, ETC- NO GO
01800		JSP	R3,S$$ITR-1	; INTEGER, SHIFT BACK AND CONVERT
01900		JRST	1(R7)	; REAL, RETURN
02000	
02100	; MAKE STRING
02200	S$$MKS:	JUMPL	R1,MKNSTR	; IF NEG MUST BE INT OR REAL DESCR
02300		TLNE	R1,^O770000	; IS IT STRING?
02400		JRST	(R7)	; NO, CAN'T DO
02500		JUMPN	R1,.+3	; IS IT NULL?
02600		SETZ	R3,	; YES, SET CHAR COUNT TO 0
02700		JRST	1(R7)	; AND RETURN
02800		HRRZ	R3,(R1)	; GET CHAR COUNT
02900		JUMPL	R0,1(R7)	; IF R0<0, CONVERSION DONE
03000		JUMPE	R3,1(R7)	; IF CHAR COUNT=0, CONVERSION DONE
03100		CAIGE	R0,(R3)	; WILL CONVERSION OVERFLOW?
03200		CFERR	7,PRGLNK	; YES, ERROR
03300		MOVNI	R3,(R3)	; GET -CHAR COUNT,0 IN R3
03400		HRLZI	R3,(R3)
03500		ILDB	R4,R1	; MOVE CHAR FROM DESCR PTR TO BYTE PTR
03600		IDPB	R4,R2
03700		AOBJN	R3,.-2	; AND LOOP FOR EACH CHARACTER
03800		JRST	1(R7)	; RETURN
03900	MKNSTR:	MOVEM	R0,MKSMOD	; SAVE TRANSFER MODE INDICATOR
04000		JUMPGE	R0,MKNSTC	; STRING STORAGE ALREADY PROVIDED?
04100		MOVEM	R1,MKSDSC	; NO, SAVE DESCRIPTOR
04200		MOVEI	R0,4	; GET 12-CHARACTER BLOCK
04300		JSP	R6,S$$GRS
04400		MOVEI	R0,12	; 12 CHARS MAX
04500		MOVE	R2,MKSDSC	; GET DESCRIPTOR BACK
04600		HRLI	R1,^O700	; FORM STRING DESCRIPTOR
04700		MOVEM	R1,MKSDSC	; SAVE STRING DESCR
04800		JRST	.+2
04900	MKNSTC:	EXCH	R1,R2	; SWITCH DESCR,BYTE PTR
05000		SETZ	R3,	; GET TYPE (2=INT, 3=REAL)
05100		ROTC	R2,2
05200		CAIE	R3,3	; IS IT REAL?
05300		ASH	R2,-2	; NO, FORM INTEGER
05400		XCT	NTOSTR-2(R3)	; DO APPROPIIATE CONVERSION
05500		MOVE	R2,MKSDSC	; GET STRING DESCR BACK
05600		EXCH	R1,R2	; GET UPDATED BYTE PTR INTO R2
05700		SKIPGE	MKSMOD	; WAS STRING STORAGE PROVIDED?
05800		HRRM	R3,(R1)	; NO, SAVE CHARACTER COUNT IN STRIN
05900		JRST	1(R7)	; RETURN
06000	NTOSTR:	JSP	R4,S$$ITS+1	; INTEGER TO STRING
06100		JSP	R4,S$$RTS+1	; REAL TO STRING
06200	; STORAGE
06300		VARDEF	MKSMOD,1
06400		VARDEF	MKSDSC,1
     
00100		SUBTTL	DESCRIPTOR MODE CONVERSION
00200	
00300		COMMENT/
00400	CALL:	DICNV	@NLOC	; CONVERT DESCRIPTOR IN @NLOC TO INTEGER, OR IN
00500		R1 IF @NLOC=0, RETURN VALUE IN R1
00600	
00700	CALL:	DRCNV	@NLOC	; CONVERT TO REAL, LIKE DICNV/
00800	
00900	LDICNV:	JSP	R7,LDRCNV+1	; INTEGER INDEX=LDRCNV
01000	LDRCNV:	JSP	R7,LDRCNV+1	; REAL INDEX=LDRCNV+1
01100		MOVE	R6,S$$UPC	; GET LINK
01200		MOVEM	R6,PRGLNK	; SAVE
01300		MOVE	R6,.JBUUO	; GET EFF ADR
01400		TRNE	R6,^O777777	; IS IT ZERO?
01500		MOVE	R1,(R6)	; NO, GET DESCR, POSSIBLE INPUT
01600		XCT	DCNVXT-LDRCNV(R7)	; DO CONVERSION
01700		CFERR	1,PRGLNK	; NOT CONVERTIBLE
01800		JRST	@PRGLNK	; RETURN
01900	DCNVXT:	JSP	R7,S$$MKI	; MAKE INTEGER
02000		JSP	R7,S$$MKR	; MAKE REAL
     
00100		SUBTTL	ARRAY/TABLE REFERENCE HANDLER
00200	
00300		EXTERN	S$$ARF,S$$TRF
00400	
00500		COMMENT/
00600	CALL:	AREFV	NARG,VLOC	; REFERENCE FOR VALUE
00700	CALL:	AREFN	NARG,VLOC	; REFERENCE FOR NAME
00800		WHERE NARG IS THE NUMBER OF ARGUMENTS IN THE CALL, AND VLOC IS
00900	THE LOCATION OF THE NAME OF THE VARIABLE HOLDING THE ARRAY OR TABLE
01000	DESCRIPTOR. THE LAST ARGUMENT, IF ANY, IS IN R1, WITH REMAINING ARGS
01100	ON ES. THE PC IS SAVED IN PRGLNK, AND THE NUMBER OF ARGUMENTS SUPPLIED,
01200	PROVIDED THEY DO NOT EXCEED THE NUMBER OF ARGUMENTS EXPECTED,
01300	IS EQUALIZED TO (FOR ARRAYS) THE NUMBER OF DIMENSIONS OR (FOR TABLES) 1.
01400	THE ARRAY OR TABLE REFERENCE ROUTINES ARE CALLED WITH THE DESCRIPTOR IN
01500	R8 AND RETURN A POINTER TO THE ARRAY OR TABLE ELEMENT IN R2. AREFV LOADS
01600	R1 WITH THE CONTENTS OF THE ELEMENT AND RETURNS, AND AREFN FORMS A NAME
01700	DESCRIPTOR FOR THE ELEMENT AND RETURNS/
01800	
01900	LAREFV:	JSP	R12,LAREFN+1	; REFERENCE FOR VALUE, INDEX=0
02000	LAREFN:	JSP	R12,LAREFN+1	; REFERENCE FOR NAME, INDEX=1
02100		SUBI	R12,LAREFN
02200		MOVE	R2,S$$UPC	; GET LINK
02300		MOVEM	R2,PRGLNK	; SAVE
02400		LDB	R2,[POINT 4,.JBUUO,12]	; GET ACTUAL NUMBER OF ARGS
02500		JUMPE	R2,.+2	; SKIP IF NONE
02600		PUSH	ES,R1	; OR PUSH LAST ONE ONTO ES
02700		MOVE	R8,@.JBUUO	; GET NAME OF VAR
02800		SETM	R8,(R8)	; GET VALUE WITHOUT I/O
02900		HLLZ	R3,R8	; GET DESCRIPTOR TYPE
03000		ROT	R3,4
03100		MOVEI	R5,-5(R3)	; IS IT ARRAY OR TABLE?
03200		JUMPE	R5,.+2	; YES,SKIP
03300		CFERR	3,PRGLNK	; NO, ERROR
03400		JUMPGE	R3,.+3	; JUMP IF ARRAY
03500		AOS	R3,R5	; OR IF TABLE, SET EXPECTED ARGS=1, TYPE INDEX=1
03600		JRST	.+3	; AND SKIP
03700		ROT	R3,9	; GET NUMBER OF ARRAY DIMENSIONS
03800		ANDI	R3,^O377
03900		CAILE	R2,(R3)	; IS ACTUAL # OF ARGS > EXPECTED?
04000		CFERR	3,PRGLNK	; YES, ERROR
04100		JSP	R4,S$$EQA	; EQUALIZE ARGS
04200		ADDI	R12,.+2(R12)	; FORM RETURN LINK FOR VALUE OR NAME
04300		JRST	@ATBREF(R5)	; GO TO ARRAY OR TABLE REF ROUTINE
04400		MOVE	R1,(R2)	; VALUE CALL, LOAD VALUE
04500		JRST	@PRGLNK	; AND RETURN TO PROG
04600		HRLZI	R1,1B19	; NAME CALL, FORM NAME DESCRIPTOR
04700		ADDI	R1,(R2)
04800		JRST	@PRGLNK	; AND RETURN TO PROG
04900	ATBREF:	S$$ARF	; ARRAY REF
05000		S$$TRF	; TABLE REF
     
00100		SUBTTL	FAILPOINT ROUTINE
00200	
00300		ENTRY	S$$FLR
00400	
00500		COMMENT/
00600	CALL:	JRST	S$$FLR	; USED FAILPOINT STORED IN FAIL.
00700		IF LH OF FAIL IS <0, CONTROL IS PASSED TO LOCATION POINTED TO BY
00800	RH OF FAIL (ABNORMAL FAILPOINT, AS IN NEGATION, UNEVALUATED EXPR.).
00900	OTHERWISE ES AND SS ARE RESET TO THEIR PREVIOUS VALUES AND &STFCOUNT
01000	INCREMENTED BEFORE JUMPING TO THE STATEMENT FAILPOINT/
01100	
01200	S$$FLR:	MOVE	R1,FAIL	; GET CONTENTS OF FAILPOINT WORD
01300		JUMPL	R1,(R1)	; GO THERE IF NEGATIVE
01400		MOVE	ES,ESPR	; OTHERWISE GET PREVIOUS VALUE OF ES (- BASE)
01500		ADD	ES,ESBA	; (ADD BASE)
01600		MOVE	SS,SSPR	; AND PREVIOUS VALUE OF SS (- BASE)
01700		ADD	SS,SSBA	; (ADD BASE)
01800		AOS	STFC	; INCREMENT &STFCOUNT
01900		JRST	(R1)	; AND GO TO STATEMENT FAILPOINT
     
00100		SUBTTL	UTILITY ROUTINES- INTEGER TO STRING CONVERSION
00200	
00300		ENTRY	S$$ITS
00400	
00500		COMMENT/
00600	CALL:	JSP	R4,S$$ITS	; WITH BYTE POINTER FOR FIRST CHARACTER
00700		IN R1, INTEGER IN R2, RETURNS UPDATED BYTE POINTER IN R1
00800	AND CHARACTER COUNT IN R3. S$$ITS+1 MAY BE CALLED IF R0 IS ALREADY SET
00900	TO MAXIMUM ALLOWABLE CHARACTER COUNT/
01000	
01100	S$$ITS:	MOVEI	R0,12	; NO POSSIBLE STRING OVERFLOW, 11 DIGITS + SIGN
01200		MOVEM	R4,ITSBLK	; SAVE RETURN LINK FOR EXTRA POPJ
01300		MOVE	R4,ITSSTK	; GET STACK PTR
01400		HLRM	R2,NEGSW	; SET SIGN SWITCH
01500		MOVM	R2,R2	; ASSURE INTEGER IS POSITIVE
01600	DECTOS:	IDIVI	R2,10	; REM IN R3, QUOTIENT IN R2
01700		HRLM	R3,(R4)	; SAVE REM (NEXT DIGIT)
01800		JUMPN	R2,DECTO1	; CONTINUE IF ALL DIGITS NOT FORMED
01900		MOVNI	R3,ITSBLK-1	; COMPUTE NUMBER OF DIGITS
02000		ADDI	R3,(R4)
02100		CAIGE	R0,(R3)	; >MAX ALLOWABLE?
02200		CFERR	7,PRGLNK	; YES, OVERFLOW
02300		HRRE	R2,NEGSW	; GET SIGN SWITCH
02400		JUMPGE	R2,DECTO2	; IS IT -?, IF NOT, SKIP
02500		ADDI	R3,1	; YES, ADD 1 CHAR FOR - SIGN
02600		CAIGE	R0,(R3)	; >MAX ALLOWABLE
02700		CFERR	7,PRGLNK	; YES, OVERFLOW
02800		MOVEI	R2,"-"	; START OFF STRING WITH -
02900		IDPB	R2,R1
03000		JRST	DECTO2
03100	DECTO1:	PUSHJ	R4,DECTOS	; COMPUTE MORE DIGITS
03200	DECTO2:	HLRZ	R2,(R4)	; TAKE DIGITS OUT IN OPPOSITE ORDER
03300		ADDI	R2,"0"	; CONVERT TO ASCII
03400		IDPB	R2,R1	; AND PUT IN STRING
03500	NEGSW:	POPJ	R4,.-.	; RETURN TO DIGIT LOOP OR CALLING PROGRAM
03600	; STORAGE
03700	ITSSTK:	IOWD	11,ITSBLK+1	; STACK ARTIFICIALLY PUSHED ONCE
03800		ITSBLK=STKREG	; SPACE FOR STACK
     
00100		SUBTTL	UTILITY ROUTINES- REAL TO STRING CONVERSION
00200	
00300		ENTRY	S$$RTS
00400	
00500		COMMENT/
00600	CALL:	JSP	R4,S$$RTS	; WITH REAL IN R2, LIKE S$$ITS/
00700	
00800	S$$RTS:	MOVEI	R0,12	; MAX CHARS = 9 SIG DIGITS + SIGN + "." + XTRA 0
00900		MOVEM	R4,ITSBLK	; SAVE RETURN LINK
01000		HLRM	R2,NEGSW	; SET SIGN SWITCH
01100		MOVM	R2,R2	; ASSURE REAL IS POSITIVE
01200		MULI	R2,^O400	; SEPARATE FRACTION AND EXPONENT
01300		EXCH	R2,R3	; PUT SHIFTED MANTISSA INTO R2
01400		HRREI	R4,-^O243(R3)	; AND BINARY POINT SHIFT INTO R4
01500		JUMPLE	R4,.+2	; ERROR IF >0
01600		CFERR	9,PRGLNK	; BECAUSE INTEGER > 2**35
01700		SETZ	R3,	; FORM INTEGER PART IN R2
01800		ASHC	R2,(R4)
01900		MOVEM	R3,RFRACT	; SAVE FRACTION
02000		MOVE	R4,ITSSTK	; GET STACK POINTER
02100		PUSHJ	R4,DECTOS	; CONVERT INTEGER AND SIGN
02200		MOVEI	R2,"."	; PUT OUT DECIMAL POINT
02300		IDPB	R2,R1
02400		HRLZ	R2,NEGSW	; COMPUTE REMAINING SIGNIFICANCE
02500		JUMPL	R2,.+2	; -(12-#CHARS) IF "-" SIGN
02600		ADDI	R2,1	; -(11-#CHARS) IF POSITIVE
02700		ADDI	R2,(R3)
02800		HRLZI	R4,-12(R2)	; PUT -REM SIGNIFICANCE IN LH
02900		HRRI	R4,(R3)	; PUT CHAR COUNT IN RH
03000		MOVE	R2,RFRACT	; GET FRACTION
03100	FRCTLP:	MULI	R2,10	; NEXT FRACTION DIGIT
03200		CAIG	R0,(R4)	; <MAX ALLOWABLE CHARS?
03300		CFERR	7,PRGLNK	; NO, ERROR
03400		ADDI	R2,"0"	; FORM ASCII DIGIT
03500		IDPB	R2,R1	; PUT IN STRING
03600		AOBJP	R4,FRCTND	; SKIP OUT IF SIGNIFICANCE SATISFIED
03700		MOVE	R2,R3	; RESTORE FRACTION
03800		JUMPN	R2,FRCTLP	; LOOP IF STILL NONZERO
03900	FRCTND:	MOVEI	R3,(R4)	; GET CHAR COUNT IN R3
04000		JRST	@ITSBLK	; RETURN
04100	; STORAGE
04200		VARDEF	RFRACT,1
     
00100		SUBTTL	UTILITY ROUTINES- INTEGER TO REAL AND REAL TO INTEGER CONV
00200	
00300		ENTRY	S$$ITR,S$$RTI
00400	
00500		COMMENT/
00600	CALL:	JSP	R3,S$$ITR	; WITH INTEGER IN R1, RETURNS REAL IN R1.
00700		CALL TO S$$ITR-1 IF R1 CONTAINS INTEGER LEFT SHIFTED 2 BITS
00800	
00900	CALL:	JSP	R3,S$$RTI	; WITH REAL IN R1, RETURNS INTEGER IN R1.
01000		IF MAG(R1)>2**35, ARITHMETIC OVERFLOW OCCURRS/
01100	
01200		ASH	R1,-2	; RESTORE INTEGER FROM TYPE TEST
01300	S$$ITR:	IDIVI	R1,^O400	; DIVIDE INTO TWO PIECES
01400		SKIPE	R1	; IMPLIES INT < 9 BITS
01500		TLC	R1,^O243000	; SET EXP TO 243 (27 + 8 DECIMAL)
01600		TLC	R2,^O233000	; SET EXP TO 233 (27 DECIMAL)
01700		FAD	R1,R2	; NORMALIZE AND ADD
01800		JRST	(R3)	; RETURN
01900	
02000	S$$RTI:	HLL	R3,R1	; SAVE SIGN IN LINK REG
02100		MOVM	R1,R1	; ASSURE POSITIVE REAL
02200		MULI	R1,^O400	; SEPARATE FRACTION AND EXPONENT
02300		EXCH	R1,R2	; PUT PARTIAL RESULT IN R1
02400		ASH	R1,-^O243(R2)	; USE EXP AS INDEX TO GET WHOLE PART
02500		JUMPGE	R3,(R3)	; RETURN IF POSITIVE
02600		MOVN	R1,R1	; OR COMPLEMENT
02700		JRST	(R3)	; AND RETURN
     
00100		SUBTTL	UTILITY ROUTINES- STRING TO INTEGER OR REAL CONVERSION
00200	
00300		ENTRY	S$$STI,S$$STR,S$$STN
00400	
00500		COMMENT/
00600	CALL:	JSP	R7,S$$STI	; WITH STRING DESRIPTOR IN R1, RETURNS
00700		TO 0(R7) IF CANNOT BE CONVERTED OR TO 1(R7) WITH INTEGER IN R1.
00800		CALL TO S$$STI-1 IF DESCRIPTOR NEEDS TO BE SHIFTED BACK
00900	
01000	CALL:	JSP	R7,S$$STR	; SAME AS S$$STI EXCEPT RETURNS REAL IN R1
01100	
01200	CALL:	JSP	R7,S$$STN	; SAME AS S$$STI EXCEPT RETURNS SUCCESS-
01300		FULLY TO 2(R7) WITH 2 IN R2 IF VALUE IN R1 IS INTEGER, AND 3 IN
01400		R2 IF VALUE IN R1 IS REAL
01500	
01600		REAL STRINGS ARE CONVERTED TO INTEGERS AND INTEGER STRINGS TO
01700	REALS IF NECESSARY/
01800	
01900		ROTC	R1,-2	; RESTORE STRING DESCRIPTOR
02000	S$$STN:	MOVEI	R2,2	; START OUT ASSUMING INTEGER
02100		MOVEM	R2,IRSTMD	; AND SAVE MODE
02200		JUMPN	R1,S$$STR+2	; PROCESS IF NON-NULL
02300		JRST	2(R7)	; OR RETURN
02400		ROTC	R1,-2	; RESTORE STRING DESCR
02500	S$$STI:	JUMPE	R1,1(R7)	; RETURN 0 IF NULL
02600		SETOM	IRSTMD	; SET MODE TO INT
02700		JRST	S$$STR+2	; CONTINUE
02800		ROTC	R1,-2	; RESTORE STRING DESCR
02900	S$$STR:	JUMPE	R1,1(R7)	; RETURN 0 IF NULL
03000		SETZM	IRSTMD	; SET MODE TO REAL
03100		HRRZ	R6,(R1)	; GET CHAR COUNT
03200		JUMPN	R6,.+3	; SKIP IF >0
03300		SETZ	R1,	; RETURN 0 FOR EMPTY STRING
03400		JRST	TSTMOD	; RETURN
03500		SETZ	R3,	; INITIALIZE WHOLE PART
03600		SETZM	STSIGN	; INITIALIZE SIGN TO +
03700		ILDB	R2,R1	; GET FIRST CHAR
03800		CAILE	R2,"-"	; > - SIGN?
03900		JRST	NOSIGN	; YES, TRY DIGITS
04000		CAIE	R2,"-"	; IS IT - SIGN?
04100		JRST	TRYPLS	; NO, TRY +
04200		SETOM	STSIGN	; YES, SET SIGN TO -
04300		SOJG	R6,NOSIGN-1	; DECREMENT CHAR COUNT AND CONTINUE
04400		JRST	(R7)	; OR FAIL IF NO MORE
04500	TRYPLS:	CAIN	R2,"+"	; IS IT + SIGN?
04600		SOJG	R6,NOSIGN-1	; YES, DECREMENT CHAR COUNT AND CONTINUE
04700		JRST	(R7)	; NOT + OR NO MORE CHARS, FAIL
04800		ILDB	R2,R1	; GET NEXT CHAR
04900	NOSIGN:	CAILE	R2,"9"	; >9?
05000		JRST	(R7)	; YES, FAIL
05100		SUBI	R2,"0"	; FORM DIGIT
05200		JUMPL	R2,(R7)	; FAIL IF <"0"
05300	FORMIN:	IMULI	R3,10	; TOT=TOT*10+DIGIT
05400		ADDI	R3,(R2)
05500		SOJG	R6,FORMI1	; DECREMENT CHAR COUNT AND CONTINUE
05600		MOVE	R1,R3	; NO MORE CHARS, GET TOTAL
05700		SKIPN	R2,IRSTMD	; IS MODE REAL?
05800		JSP	R3,S$$ITR	; YES, CONVERT TO REAL
05900	INTFIN:	SKIPE	STSIGN	; IS SIGN +?
06000		MOVN	R1,R1	; NO, NEGATE
06100	TSTMOD:	SKIPG	IRSTMD	; IS MODE OPTIONAL?
06200		JRST	1(R7)	; NO, RETURN SUCCESSFULLY
06300		JRST	2(R7)	; YES, RETURN SUCCESSFULLY
06400	FORMI1:	ILDB	R2,R1	; GET NEXT CHAR
06500		CAILE	R2,"9"	; >"9"?
06600		JRST	(R7)	; YES, FAIL
06700		SUBI	R2,"0"	; FORM DIGIT
06800		JUMPGE	R2,FORMIN	; LOOP IF BETWEEN 0 AND 9
06900		CAME	R2,["."-"0"]	; OTHERWISE, IS IT "."?
07000		JRST	(R7)	; NO, FAIL
07100		MOVEM	R3,WHLPRT	; SAVE WHOLE PART
07200		SETZ	R3,	; INITIALIZE FRACTION
07300		MOVNI	R6,(R6)	; FORM -(REM CHARS+1),0
07400		HRLZI	R6,(R6)
07500		JRST	.+3	; AND JUMP INTO LOOP
07600	FORMFR:	IMULI	R3,10	; TOT=TOT*10+DIGIT
07700		ADDI	R3,(R2)
07800		AOBJN	R6,FORMF1	; SKIP IF ANY CHARS REMAIN
07900		MOVE	R1,WHLPRT	; OTHERWISE GET WHOLE PART
08000		SKIPGE	IRSTMD	; IS IT REAL MODE OR OPTIONAL MODE?
08100		JRST	INTFIN	; NO, GO RETURN INTEGER
08200		MOVEM	R3,FRCPRT	; SAVE FRACTION PART
08300		JUMPE	R1,.+2	; SKIP IF WHOLE PART=0
08400		JSP	R3,S$$ITR	; FORM REAL WHOLE PART
08500		EXCH	R1,FRCPRT	; EXCHANGE WITH INTEGER FRACTION
08600		JUMPE	R1,.+3	; SKIP IF FRACT PART=0
08700		JSP	R3,S$$ITR	; FORM REAL FRACTIONAL PART
08800		FMP	R1,NEGPWR(R6)	; MULTIPLY BY APPROPRIATE -PWR OF TEN
08900		FAD	R1,FRCPRT	; ADD WHOLE PART
09000		SKIPG	R2,IRSTMD	; IS MODE OPTIONAL?
09100		JRST	INTFIN	; NO, GO CHECK SIGN ON REAL
09200		AOJA	R2,INTFIN	; YES, GO CHECK SIGN AND RETURN REAL
09300	FORMF1:	ILDB	R2,R1	; GET NEXT CHAR
09400		CAILE	R2,"9"	; IS IT >"9"
09500		JRST	(R7)	; YES, FAIL
09600		SUBI	R2,"0"	; FORM DIGIT
09700		JUMPGE	R2,FORMFR	; LOOP IF NOT<"0"
09800		JRST	(R7)	; OR FAIL
09900	; STORAGE
10000		VARDEF	IRSTMD,1
10100		VARDEF	STSIGN,1
10200		VARDEF	WHLPRT,1
10300		FRCPRT=WHLPRT
10400		NEGPWR=.-2
10500		EXP	1.0E-1,1.0E-2,1.0E-3,1.0E-4,1.0E-5,1.0E-6,1.0E-7
10600		EXP	1.0E-8,1.0E-9,1.0E-10,1.0E-11
     
00100		SUBTTL	UTILITY ROUTINES- CONVERT TO STRING ALWAYS
00200	
00300		ENTRY	S$$CVS
00400	
00500		COMMENT/
00600	CALL:	JSP	R7,S$$CVS	; WITH DESCR IN R1, RETURNS STRING IN
00700		R1. NAMES RETURN 'NAME', ARRAYS 'ARRAY', TABLES 'TABLE', PATTERNS
00800		'PATTERN', AND PROGRAMMER-DEFINED DATATYPES THEIR NAME/
00900	
01000	S$$CVS:	TLNN	R1,^O770000	; IS IT A STRING?
01100		JRST	(R7)	; YES, RETURN
01200		JUMPG	R1,CVS1	; JUMP IF NOT INTEGER OR REAL
01300		SETO	R0,	; OTHERWISE SET UP NUMERICAL TO STRING CONVERSION
01400		SOJA	R7,MKNSTR	; AND JUMP IN WITH MODIFIED LINK
01500	CVS1:	SETZ	R2,	; GET TYPE BITS
01600		ROTC	R1,4
01700		XCT	CVS2-4(R2)	; GET TYPE STRING
01800		JRST	(R7)	; RETURN
01900	CVS2:	MOVE	R1,CVSNAM	; NAME, GET 'NAME'
02000		JRST	CVSTAR	; ARRAY OR TABLE
02100		MOVE	R1,CVSPAT	; PATTERN, GET 'PATTERN'
02200		JRST	.+1	; DATATYPE
02300		LSH	R1,-4	; GET DATATYPE NAME
02400		MOVE	R1,(R1)
02500		MOVE	R1,(R1)
02600		JRST	(R7)	; AND RETURN
02700	CVSTAR:	ROTC	R1,1	; GET ARRAY/TABLE BIT
02800		MOVE	R1,CVSARR-10(R2)	; GET 'ARRAY' OR 'TABLE'
02900		JRST	(R7)	; RETURN
03000	; STORAGE
03100	CVSNAM:	SDC	2,4,NAME
03200	CVSPAT:	SDC	3,7,PATTERN
03300	CVSARR:	SDC	2,5,ARRAY
03400		SDC	2,5,TABLE
     
00100		SUBTTL	DUMMY FORTRAN ENTRIES
00200	
00300		ENTRY	TYPER.,OVPCWD
00400	
00500		COMMENT/
00600	CALL:	PUSHJ	^017,TYPER.	; WITH ERROR TYPE IN R0
00700	
00800		OVPCWD IS THE PC WORD ON TRAPS/
00900	
01000	TYPER.:	CAIE	R0,2	; IS IT 2
01100		CAIN	R0,5	; OR 5?
01200		UFERR	14,PRGLNK	; YES, DIVIDE CHECK
01300		UFERR	15,PRGLNK	; NO, OVERFLOW
01400	OVPCWD:	0
     
00100		SUBTTL	LITERALS
00200		LIT
00300		END