Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
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