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, ;;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 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 ; DESIRED0, 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) ; 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