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