NEWEDS,SINTS,INTPERMS,INTSYSS,PDIAGS,SOAPS,UTILITS,INTEXTS,VAGRENS,NEWINTPS,SOA PDOC,INTDOC %CONTROL 0 %EXTERNALROUTINESPEC RIM(%INTEGER CNSL, %STRING (15) MES) %EXTERNALINTEGERFNSPEC TESTINT(%INTEGER C %STRING(15) S) %EXTERNALROUTINE EDINNER(%INTEGER INTOP,INSIZE,SINTOP,SINSIZE,TOP %C %INTEGERNAME SIZE) %SHORTROUTINE %OWNINTEGER MON; !MONITOR INDIC %OWNINTEGER PRINT1, PRINT2; !PRINT INDICS %OWNINTEGER STOP = -5000; !LOOP STOP (CONST) %INTEGER I, J, FP0, FP1, SYM %BYTEINTEGER K %OWNINTEGER PFLIP; !PROMPT FLIP-FLOP %OWNSTRING (2) PROM = '>'; !COMMAND PROMPT %OWNINTEGER CMAX; !COMMAND CELL MAX %INTEGER CI; !COMMAND INDEX %INTEGER TI; !TEXT INDEX %INTEGER CODE; !COMMAND CODE %INTEGER LIM; !SEARCH LIM %INTEGER CODELIM; !LIM/CODE %INTEGER TEXT; !TEXT STRING POINTER %INTEGER NUM; !REPETITION NUMBER %INTEGER LEN; !TEXT LENGTH (-1) %INTEGER LBEG; !LINE START (AD) %INTEGER LEND; !LINE END (AD) %REGISTER FP(5); !FILE POINTER (AD) %REGISTER PP(6); !PREVIOUS FILE POINTER %INTEGER FEND; !END OF FILE (AD) %OWNINTEGER MS; !MATCH START (AD) %OWNINTEGER ML; !MATCH LIMIT (AD) %OWNINTEGER SIN = 0; !SECONDARY INPUT IND %OWNINTEGER MARKER %INTEGER MFP, SFP, MEND, SEND %INTEGER CB; !COMMAND BASE (CONST AD) %INTEGER TB; !TEXT BASE (CONST AD) %INTEGERARRAY CC(1 : 164); !COMMAND SEQUENCE (4*41) %BYTEINTEGERARRAY TT(1 : 80); !TEXT STRINGS %INTEGER TRTLIM; !LIM AD FOR TRT %OWNBYTEINTEGERARRAY TTAB(0 : 255) = 0(10), 2, 0(245) %INTEGER TYPE, CTYPE, QUOTE, CHAIN; !COMMAND INPUT VARS !SYMBOL TYPES:- 0:NUM, 1:TERMIN, 2:ILLEGAL, 3:QUOTE, 4:FIND, .... !HIGH ORDER 4 BITS RELEVANT FOLLOWING PERCENT %OWNBYTEINTEGERARRAY SYMTYPE(33 : 95) = %C 64, 3, 3, 3, 2, 3, 3,75,73,64, 3,76, 2, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 1, 3, 3, 3,64, 3,202,10,18, 5, 8,116,10, 2, 6,10,10,10,120,202, 2, 74,50,10,38,69, 5, 6, 2, 2, 2, 2, 3,10, 3, 3, 3 ! ! # $ % & ' ( ) * + , - . / ! 0 1 2 3 4 5 6 7 8 9 : < = > ? ! @ A B C D E F G H I J K L M N O ! P Q R S T U V W X Y Z [ \ ] ^ _ %ROUTINE READ ITEM %SHORTROUTINE %INTEGER I TYPE = 1 READ SYMBOL(SYM) %UNTIL SYM # ' ' %IF SYM > 32 %START SYM = SYM-32 %IF SYM >= 96; !ENSURE UPPER CASE TYPE = SYMTYPE(SYM) %IF TYPE&15 = 0 %START %IF TYPE = 0 %START NUM = SYM-'0' %WHILE '0' <= NEXT SYMBOL <= '9' %CYCLE READ SYMBOL(I) NUM = 10NUM+I-'0' %REPEAT %FINISH %ELSE %START TYPE = 0; NUM = 0 NUM = STOP+1 %IF SYM = '?' NUM = STOP %IF SYM = '!' %FINISH %FINISH %FINISH %END %ROUTINE UNCHAIN %SHORTROUTINE 1: TEXT = CHAIN %IF TEXT # 0 %START CHAIN = INTEGER(TEXT+4) INTEGER(TEXT+4) = CI -> 1 %IF INTEGER(TEXT) # 'X' %FINISH %END %ROUTINE PRINT LINE %SHORTROUTINE %INTEGER P, Q PRINT1 = LEND; PRINT2 = PP+FP %IF SIN # 0 %START P = SFP; Q = FP %FINISH %ELSE %START P = LBEG; Q = PP %FINISH P = FP %IF P = Q %WHILE P # LEND %CYCLE PRINT SYMBOL(BYTEINTEGER(P)) P = P+1 %IF P = Q %START PRINT SYMBOL(94) %IF NUM = 1 P = FP %FINISH %REPEAT %PRINTTEXT '**END**' %IF P > FEND NEWLINE %END %SWITCH C(0 : 12) %SWITCH S('A' : 92) !INITIALISE PFLIP = 0 TB = ADDR(TT(1)); CB = ADDR(CC(1)) PP = TOP; LBEG = PP MEND = PP+SIZE-64; FP = MEND-INSIZE+1 *L_1,INSIZE; *L_2,INTOP; *LR_3,5 *BAL_15,; !MOVE(INSIZE,INTOP,FP) MEND = MEND-1 %WHILE MEND >= FP %AND BYTEINTEGER(MEND) # NL FEND = MEND SEND = SINTOP+SINSIZE-1 SEND = SEND-1 %WHILE SEND >= SINTOP %AND BYTEINTEGER(SEND) # NL SFP = SINTOP SET: TRTLIM = FEND-255 LEND = FP LEND = LEND+1 %WHILE LEND < FEND %AND BYTEINTEGER(LEND) # NL !READ COMMAND LINE 1: CI = CB; TI = TB; CHAIN = 0 READ ITEM; -> 1 %IF TYPE = 1; !(IGNORE NLS) %IF TYPE = 0 %AND CMAX # 0 %START; !REPETITION INTEGER(CMAX+8) = NUM READ ITEM; -> ER1 %IF TYPE # 1 -> GO %FINISH %IF SYM = '%' %START READ ITEM; CTYPE = TYPE>>4&3 CODE = SYM READ ITEM; -> ER1 %IF TYPE # 1 -> C(CTYPE) %FINISH 2: CTYPE = TYPE&15; -> ER2 %IF CTYPE < 4 -> ER0 %IF (\SIN!!TYPE)&192 = 0; !(WORKS) CODE = SYM; !COMMAND LETTER TEXT = 0; NUM = 1; LEN = 0; !DEFAULT VALUES READ ITEM -> C(CTYPE) C(4): !FIND NUM = 0 %UNLESS TYPE = 0 C(5): !+DEL,TRAV,UNCOVER CODE = NUM<<7+CODE; NUM = 1 READ ITEM %IF TYPE = 0 C(6): !+INSERT,SUBST,VERIFY -> ER4 %IF TYPE # 3 QUOTE = SYM; TEXT = TI 61: READ SYMBOL(SYM) %IF SYM # NL %START %IF SYM # QUOTE %START -> ER6 %IF TI-TB > 78 BYTEINTEGER(TI) = SYM; TI = TI+1 -> 61 %FINISH READ ITEM %FINISH %ELSE %START -> ER4 %UNLESS CODE = 'I' %OR CODE = 'S' TYPE = 1 %FINISH LEN = TI-TEXT-1; !LENGTH - 1 -> ER4 %IF LEN < 0 %AND CODE # 'S' BYTEINTEGER(TI) = 0; TI = TI+1 -> 101 C(8): !MOVE,ERASE -> 100 %UNLESS SYM = '-' CODE = CODE+10; READ ITEM -> 101 C(9): !CLOSE BRACKET UNCHAIN; -> ER3 %IF TEXT = 0 CODE = 'Z'; INTEGER(TEXT+8) = NUM C(10): !GET, KILL, ETC. 100: -> ER1 %IF TYPE = 3 101: READ ITEM %IF TYPE = 0 -> PUT C(11): !OPEN BRACKET CODE = 'X' -> 121 C(12): !COMMA CODE = 'Y' READ ITEM %IF TYPE = 1; !IGNORE FOLLOWING NL 121: TEXT = CHAIN; CHAIN = CI NUM = 0 PUT: INTEGER(CI) = CODE; INTEGER(CI+4) = TEXT INTEGER(CI+8) = NUM; INTEGER(CI+12) = LEN CI = CI+16; -> ER6 %IF CI-CB > 640 -> 2 %UNLESS TYPE = 1 UNCHAIN; -> ER3 %IF TEXT # 0 CMAX = CI INTEGER(CI) = 'Z'; INTEGER(CI+4) = CB-16 INTEGER(CI+8) = 1; INTEGER(CI+12) = 0 -> GO ER0: %PRINTTEXT ' SIN' -> ER2 ER1: SPACE; PRINT SYMBOL(CODE) ER2: CODE = SYM -> ER5 ER3: %PRINTTEXT ' BRACKETS' -> ERQ ER4: %PRINTTEXT ' TEXT FOR' C(0): ER5: SPACE; PRINT SYMBOL(CODE&127) -> ERQ ER6: %PRINTTEXT ' SIZE' ERQ: PRINT SYMBOL('?') NEWLINE; CMAX = 0 %IF CI # CB SKP: -> 1 %IF SYM = NL; READ SYMBOL(SYM) -> SKP !EXECUTE COMMAND LINE GO: CI = CB-16 GET: CI = CI+16 CODELIM = INTEGER(CI); TEXT = INTEGER(CI+4) NUM = INTEGER(CI+8); LEN = INTEGER(CI+12) CODE = CODELIM&127 -> S(CODE) !*I* IMP LOCATE LINE END !LOK:LEND = FP ! ->OK %IF FP > FEND %OR BYTEINTEGER(FP) = NL ! %UNTIL BYTEINTEGER(LEND) = NL %CYCLE ! LEND = LEND+1 ! %REPEAT !*M* MCODE LOCATE LINE END LOK: *L_15,TTAB; !R15 = BASE OF TTAB *LR_1,5; !R1 = FP *C_1,TRTLIM; !R1 <= TRTLIM *BC_12,; !YES -> *L_2,FEND; !R2 = FEND-R1 *SR_2,1 *BC_12,; !<= 0 -> *EX_2,; !LOCATE NL *BC_15, TRT: *TRT_0(0,1),0(15); !FOR LOCATE & FIND LK1: *TRT_0(256,1),0(15); !LOCATE NL *BC_8,; !NOT FOUND -> LK2: *ST_1,LEND; !LEND = R1 !*E* LOCATE OK: NUM = NUM-1 -> GET %IF NUM = 0 %OR NUM = STOP -> S(CODE) S(92): !INVERT NO: -> GET %IF NUM <= 0 CI = CI+16 -> GET %IF INTEGER(CI) = 92 %WHILE INTEGER(CI)&127 <= 'X' %CYCLE CI = INTEGER(CI+4) %IF INTEGER(CI) = 'X' CI = CI+16 %REPEAT NUM = INTEGER(CI+8) -> NO %UNLESS CI = CMAX -> 99 %IF NUM <= 0 %PRINTTEXT 'FAILURE: ' %IF CODE = 'O' %OR CODE = 'W' %START PRINT SYMBOL(CODE-10); CODE = '-' %FINISH PRINT SYMBOL(CODE) %IF TEXT # 0 %START PRINT SYMBOL('''') %WHILE LEN >= 0 %CYCLE PRINT SYMBOL(BYTEINTEGER(TEXT)) TEXT = TEXT+1; LEN = LEN-1 %REPEAT PRINT SYMBOL('''') %FINISH NEWLINE PRINT1 = 0 READ SYMBOL(SYM) %WHILE SYM # NL 99: %IF SYM = NL %AND ((MON >= 0 %AND PRINT1 # LEND) %OR (MON > 0 %C %AND PRINT2 # PP+FP)) %START NUM = 1; PRINT LINE %FINISH -> 1 %IF PFLIP > 0 RIM(0,PROM); PFLIP = 1 -> 1 !INDIVIDUAL COMMANDS S('X'): !OPEN BRACKET INTEGER(TEXT+8) = NUM -> GET S('Z'): !CLOSE BRACKET NUM = NUM-1 %IF NUM = 0 %OR NUM = STOP %START -> GET %UNLESS CI = CMAX -> 99 %FINISH INTEGER(CI+8) = NUM CI = TEXT -> GET S('Y'): !COMMA CI = TEXT-16 -> GET S('R'): !RIGHT-SHIFT -> NO %IF FP = LEND BYTEINTEGER(PP) = BYTEINTEGER(FP) PP = PP+1; FP = FP+1 -> OK S('L'): !LEFT-SHIFT -> NO %IF PP = LBEG FP = FP-1; PP = PP-1 BYTEINTEGER(FP) = BYTEINTEGER(PP) MS = 0 -> OK S('E'): !ERASE -> NO %IF FP = LEND FP = FP+1 -> OK S('O'): !ERASE BACK -> NO %IF PP = LBEG PP = PP-1 -> OK S('V'): !VERIFY !*I* VERIFY ! ->NO %IF BYTEINTEGER(FP) # BYTEINTEGER(TEXT) ! I = FP ! J = TEXT ! %UNTIL BYTEINTEGER(I) # BYTEINTEGER(J) %CYCLE ! I = I+1 ! J = J+1 ! %REPEAT ! ->NO %IF BYTEINTEGER(J) # 0 ! MS = FP ! ML = I ! ->GET !*M* VERIFY *L_3,TEXT; !R3 = TEXT *L_1,LEN; !R1 = LENGTH (-1) *EX_1,; !COMPARE *BC_7,; !NO MATCH -> *ST_5,MS; !MS = FP *LA_1,1(1,5); !R1 = FP+R1+1 (AD) *ST_1,ML; !ML = R1 -> GET VC: *CLC_0(0,5),0(3); !CLC FOR VERIFY !*E* VERIFY S('D'): !DELETE S('T'): !+TRAVERSE J = 0 -> F0 S('F'): !FIND S('U'): !+UNCOVER J = MS F0: LIM = CODELIM>>7; K = BYTEINTEGER(TEXT) FP1 = FP !*I* FIND ! FP0 = FP ! FP = FP+1 %IF FP = J ! ->F2 %IF FP > FEND !F1: %WHILE BYTEINTEGER(FP) # NL %CYCLE ! %IF BYTEINTEGER(FP) = K %START ! I = FP ! J = TEXT ! I=I+1 %AND J=J+1 %UNTIL BYTEINTEGER(I)#BYTEINTEGER(J) ! ->F5 %IF BYTEINTEGER(J) = 0 ! %FINISH ! FP = FP+1 ! %REPEAT ! LIM = LIM-1 ! ->F2 %IF LIM = 0 ! FP = FP+1 ! FP1 = FP ! SFP = FP %IF SIN # 0 ! ->F1 %UNLESS FP > FEND !F2: LEND = FP ! FP = FP1 ! ->NO %IF SIN # 0 %OR CODE = 'U' ! J = FP1-FP0 ! K = 0 ! ->F6 !F5: MS = FP ! ML = I ! FP = ML %IF CODE = 'T' ! ->F7 %IF SIN # 0 %OR CODE = 'U' ! J = FP-FP0 !F6: LBEG = PP+FP1-FP0 %IF FP1 # FP0 ! MOVE(J,FP0,PP) ! PP = PP+J ! ->NO %IF K = 0 ! FP = ML %IF CODE = 'D' !F7: ->OK %IF FP1 = FP0 ! ->LOK !*M* FIND I = ADDR(TTAB(K)); !SET SLOT IN TRANS TABLE BYTEINTEGER(I) = 1 *L_0,LIM; !R0 = LIM *LR_1,5; !R1 = FP *SLR_2,2; !R2 = 0 (FOR TRT) *L_3,TEXT; !R3 = TEXT *L_15,TTAB; !R15 = BASE OF TTAB *C_1,J; !R1 = MS? *BC_7,; !NO -> F1: *LA_1,1(0,1); !R1 = R1+1 (AD) F2: *C_1,TRTLIM; !R1 > TRTLIM? *BC_2,; !YES -> *TRT_0(256,1),0(15); !LOCATE K OR NL *BC_7,; !FOUND -> *LA_1,256(0,1); !R1 = R1+256 (AD) *BC_15, FC: *CLC_0(0,1),0(3); !CLC FOR FIND F21: *L_2,FEND; !R2 = FEND-R1 *SR_2,1 *BC_4,; !< 0 -> *EX_2,; !(MUST FIND) F3: *BCT_2,; !R2-1 # 0 (NL) -> *L_2,LEN; !R2 = LENGTH (-1) *EX_2,; !COMPARE *BC_7,; !NO MATCH -> *ST_1,MS; !MS = R1 *LA_2,1(2,1); !R2 = R1+R2+1 (AD) *ST_2,ML; !UPDATE ML *LA_0,84(0,0); !CODE = 'T'? *C_0,CODE *BC_7,; !NO -> *LR_1,2; !R1 = ML F4: *BAL_15,; !MOVE FP = ML %IF CODE = 'D' -> OK %IF FP1 = 0 -> LOK F5: *SR_0,2; !DEC R0 (R2=1) *BC_8,; !ZERO -> *AR_1,2; !R1 = R1+1 (R2=1) *ST_1,FP1; !FP1 = R1 *BC_15, F7: *ST_1,LEND; !LEND = R1 *L_1,FP1; !R1 = FP1 *BAL_15,; !MOVE -> NO !*** MCODE BULK MOVE SUBROUTINE !*** CALL: BAL 15, -- FOR FIND !*** R1:NEW FP !*** CALL: BAL 15, !*** R1:LENGTH R2:SOURCE R3:DEST FMV: *SLR_0,0; !R0 = 0 *L_3,I; !R3 = I *STC_0,0(0,3); !CLEAR TTAB SLOT *LR_2,5; !R2 = OLD FP *LR_5,1; !FP = R1 *L_3,FP1; !R3 = FP1 - OLD FP *SR_3,2 *ST_3,FP1; !STORE AS INDIC *C_0,SIN; !SIN # 0? *BC_8,; !NO -> *LTR_3,3; !FP1 CHANGED? *BCR_8,15; !NO => *AR_3,2 *ST_3,SFP; !UPDATE SFP *BCR_15,15 MV0: *LA_0,85(0,0); !CODE = 'U'? *C_0,CODE *BCR_8,15; !YES => *LTR_3,3; !TEST FP1 - OLD FP *BC_8,; !ZERO -> *AR_3,6; !UPDATE LBEG *ST_3,LBEG MV1: *SR_1,2; !NEW FP - OLD FP (LENGTH) *LR_3,6; !R3 = OLD PP (DEST) *AR_6,1; !UPDATE PP MOV: *LA_0,256(0,0); !R0 = 256 MV2: *CR_1,0; !R1 <= 256? *BC_12,; !YES -> *MVC_0(256,3),0(2); !MOVE 256 *AR_2,0; !R2 = R2+256 *AR_3,0; !R3 = R3+256 *SR_1,0; !R1 = R1-256 *BC_15, MV3: *LTR_1,1 *BCR_8,15; !ZERO => *BCTR_1,0; !R1 = R1-1 *EX_1,; !MOVE REST *BCR_15,15; !EXIT MV: *MVC_0(0,3),0(2) !*E* FIND S('S'): !SUBSTITUTE -> NO %IF FP # MS FP = ML -> OK %IF LEN < 0 S('I'): !+INSERT -> NO %IF PP-LBEG > 160 %OR FP > FEND !*I* INSERT ! J = TEXT ! %UNTIL BYTEINTEGER(J) = 0 %CYCLE ! BYTEINTEGER(PP) = BYTEINTEGER(J) ! PP = PP+1 ! J = J+1 ! %REPEAT !I1: ->OK %UNLESS PP+256 >= FP ! ->C1 !*M* INSERT *L_3,TEXT; !R3 = TEXT *L_1,LEN; !R1 = LENGTH (-1) *EX_1,; !MOVE *LA_6,1(1,6); !UPDATE PP (AD) I1: -> OK %UNLESS PP+256 >= FP -> C1 IM: *MVC_0(0,6),0(3); !MVC FOR INSERT !*E* INSERT S('G'): !GET (LINE FROM TT) RIM(0,':') %AND PFLIP = -1 %IF PFLIP >= 0 READ SYMBOL(K) -> NO %IF K = ':' %WHILE PP # LBEG %CYCLE FP = FP-1; PP = PP-1 BYTEINTEGER(FP) = BYTEINTEGER(PP) %REPEAT %WHILE K # NL %CYCLE BYTEINTEGER(PP) = K; PP = PP+1 READ SYMBOL(K) %REPEAT S('B'): !+BREAK BYTEINTEGER(PP) = NL; PP = PP+1 LBEG = PP -> I1 S('P'): !PRINT PRINT LINE -> 1 %IF TESTINT(0,'ENOUGH') # 0 -> OK %IF NUM = 1 S('M'): !MOVE -> NO %IF FP > FEND -> M5 %IF SIN # 0 !*I* MOVE ! J = LEND-FP+1 ! MOVE(J,FP,PP) ! PP = PP+J ! LBEG = PP ! FP = LEND+1 ! ->LOK !*M* MOVE *L_1,LEND; !R1 = LEND-FP *SR_1,5 *LA_0,256(0,0); !R0 = 256 *CR_1,0; !R1 >= R0? *BC_10,; !YES -> *EX_1,; !MOVE (+1) *LA_6,1(1,6); !UPDATE PP,LBEG *ST_6,LBEG *LA_5,1(1,5); !UPDATE FP -> LOK MM: *MVC_0(0,6),0(5) !*E* MOVE M5: FP = LEND+1 SFP = FP -> LOK S('K'): !KILL -> NO %IF FP > FEND PP = LBEG K1: FP = LEND+1 -> LOK S('J'): !JOIN -> NO %IF LEND >= FEND %WHILE FP # LEND %CYCLE BYTEINTEGER(PP) = BYTEINTEGER(FP) PP = PP+1; FP = FP+1 %REPEAT -> NO %IF PP-LBEG > 120 -> K1 S('W'): !MOVE BACK MS = 0 -> W10 %IF SIN # 0 !*I* MOVE BACK ! ->NO %IF LBEG = TOP ! LEND = FP-PP+LBEG-1 ! %UNTIL LBEG=TOP %OR BYTEINTEGER(LBEG-1)=NL %CYCLE ! LBEG = LBEG-1 ! %REPEAT ! J = PP-LBEG ! FP = FP-J ! PP = LBEG ! MOVE(J,PP,FP) ! ->OK !*M* MOVE BACK *L_2,LBEG; !R2 = LBEG *L_1,TOP; !R1 = TOP *CR_2,1; !EQUAL? *BC_8,; !YES -> *SLR_0,0; !R0 = 0 *C_0,NUM; !NUM = 0? *BC_8,; !YES -> *BCTR_0,0; !R0 = -1 *AR_1,0; !R1 = TOP-1 *AR_2,0; !R2 = R2-1 *LR_3,5; !LBEG = FP-PP+LBEG-1 *SR_3,6 *AR_3,2 *ST_3,LEND *CNOP_0,4; !WORD BOUNDARY W1: *BXLE_2,0,; !DEC R2 *CLI_0(2),10; !BYTE(R2) = NL? *BC_7,; !NO -> W2: *SR_2,0; !R2 = R2+1 *LR_1,6; !R1 = LENGTH *SR_1,2 *LR_6,2; !UPDATE PP *SR_5,1; !UPDATE FP *LR_3,5; !R3 = FP (DEST) *BAL_15,; !MOVE LBEG = PP -> OK W5: *LA_0,256(0,0); !R0 = 256 *LR_2,6; !R2 = PP-TOP *SR_2,1 W6: *CR_2,0; !R2 <= 256 *BC_12,; !YES -> *SR_6,0; !PP = PP-256 *SR_5,0; !FP = FP-256 *MVC_0(256,5),0(6); !MOVE DOWN 256 *SR_2,0; !R2 = R2-256 *BC_7,; !NON-ZERO -> *BC_15, W7: *SR_6,2; !PP = PP-R2 *SR_5,2; !FP = FP-R2 *BCTR_2,0; !R2 = R2-1 *EX_2,; !MOVE DOWN REST W8: LBEG = PP -> LOK WM: *MVC_0(0,5),0(6); !MVC FOR MOVE BACK !*E* MOVE BACK W10: -> NO %IF SFP = SINTOP; !SECONDARY INPUT FP = SFP; LEND = FP-1 %UNTIL FP = SINTOP %OR BYTEINTEGER(FP-1) = NL %CYCLE FP = FP-1 %REPEAT SFP = FP -> OK S('N'): !NOTE MARKER = FP -> OK S('A'): !ABSTRACT -> NO %UNLESS SINTOP <= MARKER <= SFP J = SFP-MARKER -> C1 %IF PP+J+256 >= MFP *L_1,J; *L_2,MARKER; *LR_3,6 *BAL_15,; !MOVE(J,MARKER,PP) PP = PP+J; LBEG = PP -> OK !SPECIAL COMMANDS C(3): !%F, %M, %Q MON = 'M'-CODE -> 1 C(2): !%S: SWITCH INPUTS %IF SIN = 0 %START MFP = FP; FP = SFP; FEND = SEND SIN = -1; PROM = '>>' %FINISH %ELSE %START FP = MFP; FEND = MEND SIN = 0; PROM = '>' %FINISH PFLIP = -1 -> SET C(1): !%C: CLOSE C1: FP = MFP %IF SIN # 0 J = MEND-FP+1 *L_1,J; *LR_2,5; *LR_3,6 *BAL_15,; !MOVE(J,FP,PP) SIZE = PP-TOP+J %END %SYSTEMROUTINESPEC AGENCY(%INTEGER P1, P2) %DYNAMICROUTINESPEC RENAME(%STRING (63) S) %DYNAMICROUTINESPEC CHERISH(%STRING (63) S) %ROUTINE FDP(%INTEGER EP, %STRING (17) S, %INTEGER P1, P2, %C %INTEGERNAME FLAG) *OI_4(13),5 AGENCY(1,ADDR(EP)) *XI_4(13),5 %END %EXTERNALROUTINE E(%STRING (63) IN) %STRING (63) SEC, OUT %INTEGER INHEAD, SECHEAD, OUTHEAD; !HEADER ADS %INTEGER INSIZE, SECSIZE, OUTSIZE %INTEGER I, J, F %ROUTINE NEWGENS %RECORDFORMAT RFM(%INTEGER X, Y, Z, REPLY) %RECORDFORMAT NFM( %C %SHORTINTEGER DSNO, DACT, SSNO, SACT, X1, X2, FLAG, %C %STRING (8) OLD FILE, NEW FILE) %RECORDNAME R(RFM) %LONGREAL ONTO DOUBLE WORD BOUNDARY %RECORD P(NFM) %INTEGER FLAG FDP(2,'SS#ETEMP',0,0,FLAG); ! DISCON. WORK FILE R == P; ! FOR REPLIES %CYCLE P = 0; ! CLEAR THE RECORD P_DSNO = 164 P_OLD FILE = 'SS#ETEMP'; ! OLF FILE NAME P_NEW FILE = OUT; ! NEW FILE NAME ! SVC(P); ! CALL THE SERVICE **1,@P;! ADDRESS OF P TO R1 *LD_0,0(1) *LD_2,8(1) *LD_4,16(1) *LD_6,24(1) *SVC_254 **1,@P *STD_0,0(1) *STD_2,8(1) *STD_4,16(1) *STD_6,24(1) ! %EXIT %UNLESS R_REPLY = 6 %AND FLAG = 0; ! FILE2 STILL CONNECTED FDP(2,OUT,0,0,FLAG) FLAG = 1 %REPEAT %IF R_REPLY = 5 %START; ! FILE2 DOES NOT EXIST R_REPLY = 0 RENAME('SS#ETEMP,'.OUT) %FINISH %IF R_REPLY # 0 %START PRINTSTRING('RENAME SS#ETEMP FAILS ') WRITE(R_REPLY,1) NEWLINE %FINISH %ELSE CHERISH(OUT); ! CHERISH OUTPUT FILE FDP(2,IN,0,0,FLAG); ! DISCONNECT INPUT FILE %END %ROUTINE REPORT FLAG %PRINTTEXT ' FDP FLAG =' WRITE(F,1); NEWLINE %END %ROUTINE WRITE HEX(%INTEGER V) %INTEGER I, J SPACE; SPACE %CYCLE I = 28,-4,0 J = V>>I&15 %IF J <= 9 %THEN J = J+'0' %ELSE J = J-10+'A' PRINT SYMBOL(J) %REPEAT %END %ROUTINE CONNECT INPUT(%STRING(15) FILE %INTEGERNAME H,SIZE) %INTEGER I H = 0; SIZE = 0; F = 0 %RETURN %IF FILE = '.N' %OR FILE = '.NULL' FDP(7,FILE,0,ADDR(H),F); !CONNECT READ SHARED %IF F = 0 %START %IF 16 <= INTEGER(H) %AND 16 <= INTEGER(H+4) <= 256 %C %AND INTEGER(H+12) = 0 %START SIZE = INTEGER(H)-16 %FINISH %ELSE %START PRINTSTRING(' '.FILE.' HEADER FAULTY: ') %CYCLE I = H,4,H+12 WRITE HEX(INTEGER(I)) %REPEAT NEWLINE F = 1; ! INDICATE FAILURE %RETURN %FINISH %FINISH %ELSE %START %IF F = 3 %OR F = 13 %START PRINTSTRING(' '.FILE.' NOT AVAILABLE') NEWLINE %FINISH %ELSE REPORT FLAG %FINISH %END %ROUTINE CONNECT OUTPUT(%STRING(8) FILE %INTEGERNAME H,SIZE) %INTEGER PAGES H = 0 PAGES = (SIZE+4095)//4096 FDP(162,FILE,PAGES,0,F); !CREATE OUTPUT FILE %IF F = 3 %START FDP(3,FILE,0,0,F); !DESTROY -> ER %IF F # 0 FDP(162,FILE,PAGES,0,F); !CREATE %FINISH -> ER %IF F # 0 FDP(1,FILE,3,ADDR(H),F); !CONNECT -> ER %IF F # 0 INTEGER(H) = 16 INTEGER(H+4) = 16 INTEGER(H+8) = PAGES*4096; SIZE = INTEGER(H+8)-16 INTEGER(H+12) = 0 %RETURN ER: PRINTSTRING(' CANNOT CREATE '.FILE); NEWLINE %END %IF IN -> IN.('/').OUT %START SEC = '.N' %UNLESS IN -> IN.(',').SEC %FINISH %ELSE %START -> ER1 %IF IN -> IN.(',').SEC OUT = IN; SEC = '.N' %FINISH -> ER2 %UNLESS 1 <= LENGTH(IN) <= 15 %AND 1 <= LENGTH(OUT) <= 8 %C %AND LENGTH(SEC) <= 15 %IF OUT # '.N' %AND OUT # '.NULL' %AND OUT # IN %START %CYCLE I = 1,1,LENGTH(OUT) J = CHARNO(OUT,I) -> ER3 %UNLESS 'A' <= J <= 'Z' %OR (I # 1 %C %AND '0' <= J <= '9') %REPEAT %FINISH CONNECT INPUT(IN,INHEAD,INSIZE) -> ER %IF F # 0 CONNECT INPUT(SEC,SECHEAD,SECSIZE) -> ER %IF F # 0 OUTSIZE = INSIZE+16384; !PREDICTED CONNECT OUTPUT('SS#ETEMP',OUTHEAD,OUTSIZE) -> ER %IF F # 0 RIM(0,'EDIT'.TOSTRING(13).TOSTRING(NL).'>') EDINNER(INHEAD+16,INSIZE,SECHEAD+16,SECSIZE,OUTHEAD+16,OUTSIZE) INTEGER(OUTHEAD) = OUTSIZE+16 %RETURN %IF OUT = '.N' %OR OUT = '.NULL' NEWGENS %RETURN ER3: ER2: ER1: PRINTSTRING('FAULTY PARAMETERS') NEWLINE ER: WRITE(INSIZE,1); WRITE(OUTSIZE,1) WRITE(F,1) NEWLINE %END %ENDOFFILE @@@@@@@@@@@@@@@ %ENDOFLIST %CONSTSHORTINTEGERARRAY MAIN(1 : 359) = %C 1, 7, 13, 18, 22, 25, 29, 33, 37, 40, 47, 51, 54, 59, 62, 65, 68, 72, 76, 80, 84, 90, 94, 98, 103, 108, 113, 118, 122, 127, 135, 139, 0, 141, 144, 145, 152, 0, 157, 159, 161, 163, 0, 165, 167, 168, 169, 174, 0, 178, 181, 182, 186, 187, 188, 189, 0, 199, 202, 0, 205, 206, 207, 209, 0, 211, 213, 0, 215, 218, 0, 220, 226, 230, 233, 235, 238, 241, 243, 245, 247, 249, 0, 251, 253, 254, 256, 257, 259, 261, 263, 0, 265, 267, 268, 269, 272, 274, 275, 277, 279, 281, 0, 283, 285, 0, 287, 289, 0, 291, 294, 298, 301, 303, 304, 305, 306, 308, 309, 311, 312, 0, 316, 320, 321, 324, 325, 331, 0, 333, 338, 339, 341, 343, 347, 0, 351, 353, 355, 356, 357, 359, 361, 363, 365, 367, 369, 371, 373, 375, 377, 379, 0, 381, 382, 383, 0, 389, 396, 402, 403, 409, 410, 416, 417, 419, 422, 0, 424, 426, 0, 428, 435, 439, 0, 442, 444, 445, 447, 449, 451, 453, 455, 457, 459, 0, 461, 464, 0, 466, 469, 472, 476, 479, 481, 483, 485, 487, 490, 493, 495, 498, 501, 504, 506, 508, 511, 514, 517, 521, 523, 525, 529, 534, 536, 538, 540, 543, 0, 546, 547, 548, 550, 0, 552, 554, 555, 556, 557, 559, 560, 562, 0, 564, 566, 0, 569, 572, 573, 580, 589, 596, 0, 601, 605, 0, 607, 610, 0, 614, 616, 619, 622, 624, 627, 0, 630, 634, 635, 638, 639, 0, 645, 647, 648, 0, 653, 658, 659, 661, 0, 664, 666, 0, 668, 670, 671, 673, 0, 675, 677, 679, 680, 681, 682, 683, 686, 687, 688, 693, 694, 697, 700, 704, 0, 706, 710, 711, 712, 713, 718, 0, 720, 721, 722, 724, 728, 733, 736, 742, 750, 0, 756, 759, 760, 0, 768, 772, 773, 775, 776, 777, 778, 779, 780, 785, 790, 797, 801, 806, 811, 816, 819, 822, 0, 828, 829, 830, 832, 833, 835, 0, 838, 841, 842, 845, 0, 848, 854, 857, 858, 865, 0, 870, 873, 0, 877, 880, 882 %CONSTSHORTINTEGERARRAY SUB(2 : 883) = %C 24576, 4167, 28672, 4191, -4096, 0, 4202, 4251, 4156, 4364, -4096, 0, 4153, 4156, 4367, -4096, 0, 1, 4149, -4096, 0, 7, -4096, 0, 14, 4370, -4096, 0, 4345, 4342, -4096, 0, 21, 4205, -4096, 0, 25, -4096, 0, 4375, 4260, 4379, -8192, 4384, -4096, 0, 31, -8192, -4096, 0, 4158,-24576, 0, 39, -8192, 4384, -4096, 0, 44, -4096, 0, 50, -4096, 0, 55, -4096, 0, 64, -8192, -4096, 0, 69, -8192, -4096, 0, 76, 4334, -4096, 0, 83, 12288, -4096, 0, 91,-32768, 4410, 4412, -4096, 0, 16384, 98, 4096, 0, 100, 4285, -4096, 0, 102, 107, 4161, -4096, 0, -8192, 4352, 98, 4096, 0, 4134, 4345, 4142, -4096, 0, 109, 76, 4131, -4096, 0, 119, 125, -4096, 0, 133, 4222, 4129, -4096, 0, 135, 24576, 4216, 28672, 4181, 4179, -4096, 0, 137, 4420, -4096, 0, -4096, 0, 139, 4222, 4129, 0, 24576, 4342, 28672, 141, -8192, 143, 0, 141, -8192, 143, 4339, 0, 109, 0, 145, 0, 149, 0, 155, 0, 164, 0, 166, 0, 168, -8192, 4410, -16384, 0,-32768, 4145, 4147, 0, 174, 4139, 20480, 0, 139,-32768, 4145, 4147, 0, 4151, 0, 4216, 174, 24576, 4222, 139, 28672, 4222, 139, 4222, 0, 4199, 4251, 0, 176, 4151, 0, 180, 0, 185, 0, 187, 0, 195, 0, 200, 0, 174, 4216, 0, 4222, 0, 24576, 4216, 28672, 4181, 4179, 0, 207,-28672, 4179, 0, 217, 4329, 0, 220, 0, 227, 4164, 0, 235, 4188, 0, 243, 0, 248, 0, 253, 0, 262, 0, 267, 0, 273, 4167, 0, 4183, 4222, 0, 277, 0, 174, 0, 280, 0, 217, 0, 243, 0, 12288, 0, 4194, 4251, 0, 176, 4151, 0, 283, 0, 286, 0, 293, 0, 299, 0, 293, 0, 299, 0, 283, 0, 286, 0, 305, 50, 0, 305, 308, 4210, 0, 305, 316, 0, 305, 321, 0, 325, 0, 328, 4216, 0, 328, -8192, 0, -8192, 4218, 4212, 0, 141, 4222, 4220, 143, 0, 139, 4222, 4220, 0, 4232, 24576, 4227, 28672, 4225, 0,-20480, 0, 4236, 24576, 4227, 28672, 4225, 0, 20480, 0, 4216, 0, 141, 4222, 143, 0, 185, 4222, 185, 0, 164, 0, 166, 0, 330, 0, 164, 0, 166, 0, 332, 0, 334, 0, 185, 0, 337, 0, 340, 0, 343, 0, 137, 0, 346, 0, 349, 0, 135, 0, 351, 0, 24576, 4249, 4267, 28672, 4253, 0, 273, 24576, 4249, 4267, 28672, 4256, 0, 355, 24576, 4249, 4267, 28672, 4258, 0, 273, 24576, 4249, 4267, 28672, 4256, 0, 355, 24576, 4249, 4267, 28672, 4258, 0, 125, 0, 4345, 4264, 0, 358, 0, 368, 0, 371, 0, 24576, 4222, 28672, 4273, 4222, 4414, 0, 141, 4251, 143, 0, 4216, 4271, 0, 277, 4216, 0, 174, 0, 133, 0, 375, 0, 378, 0, 380, 0, 383, 0, 385, 0, 217, 0, 135, -8192, 0, -8192, 0, 388, -8192, 0, 393, -8192, 0, 401, 4315, -8192, 0, 406, -8192, 0, 411, 0, 416, 0, 422, 0, 427, 0, 431, 4282, 0, 437, 4282, 0, 444, 0, 451, 444, 0, 454, -8192, 0, 461, 4326, 0, 468, 0, 475, 0, 483, 4322, 0, 486, 4322, 0, 491, 4322, 0, 498, 12288, 4324, 0, 503, 0, 510, 0, 516, -8192, 4320, 0, 521, -8192, 98, 16384, 0, 526, 0, 532, 0, 539, 0, 545, -8192, 0, 550, 4317, 0, 556, 0, 559, 0, 562, 0, 349, 4282, 0, 12288, 0, 139, 12288, 0, 137, 0, 12288, 0, 16384, 0, -8192, 4332, 0, 141, 4222, 143, 0, 566, -8192, 141, 4400, 4408, 143, 0, 39, 24576, -8192, 4214, 141, 28672, -8192, 143, 0, 24576, 4342, 141, 28672, -8192, 143, 0, 141, -8192, 143, 4339, 0, 39, -8192, 4214, 0, 4342, 0, 4381,-32768, 0, 168, 4416, 4356, 0, 573, 0, 581, 573, 0, 119, 573, 0, 102, 0, 195, 102, 0, 586, 4354, 0, 141, 4232, 12288, 143, 0, 141, 12288, 143, 0,-32768, 141, 4360, 143, 4358, 0, 139, 4356, 0, 4222, 98, 4222, 4362, 0, 139, 4222, 98, 4222, 4362, 0, 44, 0, 4167, 4370, 0, 1, 0, 4167, 0, 593, 4372, 0, 44, 0, 4167, 0, 155, 0, 598, 0, 605, 0, 39, 0, 168, 613, 0, 613, 0, 141, 4386,-32768, 4391, 143, 0, 4260, 4418, 0, 4345, 4381, 0, 76, 4393, 613, 0, 613, 0, 4398, 4386,-32768, 4391, 0, 168, 0, 168,-32768, 4410, 4412, 0,-32768, 0, 139, 0,-20480, 0, 4345, 4381,-32768, 0, 76, 4393, 613,-32768, 0, 613,-32768, 0, 4345, 168,-32768, 4410, 4412, 0, 76, 24576, 4395, 141, 28672, -8192, 143, 0, 76, 141, -8192, 143, 4395, 0, 4398, 4400, 4408, 0, 141, 4232, 12288, 98, 4232, 12288, 143, 0, 139,-32768, 4410, 4412, 0, 4273, 4222, 0, 566, 0, 613, 0, 8192, 12288, 139, 12288, 0, 8193, 12288, 139, 4440, 0, 8195, 12288, 139, 12288, 139, 4435, 0, 8197, 4435, 4433, 0, 8199, 12288, 139, 4435, 0, 8201, 4446, 139, 4435, 0, 8203, 4446, 139, 4446, 0, 8205, 12288, 0, 618, 12288, 0, 137, 12288, 139, 4431, 4216, 0, 623, 0, 139, 12288, 0, 4449, 0, 12288, 4438, 0, 141, 12288, 143, 0, 4449, 4438, 0, 12288, 4443, 0, 141, 12288, 139, 12288, 143, 0, 141, 12288, 143, 0, 12288, 141, 12288, 139, 12288, 143, 0, 4449, 141, 12288, 143, 0, -8192, 4452, 0, 378, 4329, 383, 0, 164, 12288, 0, 166, 12288, 0 %CONSTBYTEINTEGERARRAY LITERAL(1 : 624) = %C 5, 99, 121, 99, 108, 101, 6, 114, 101, 112, 101, 97, 116, 6, 102, 105, 110, 105, 115, 104, 3, 101, 110, 100, 5, 98, 101, 103, 105, 110, 7, 99, 111, 109, 112, 105, 108, 101, 4, 115, 112, 101, 99, 5, 115, 116, 97, 114, 116, 4, 108, 105, 115, 116, 8, 36, 82, 69, 83, 84, 65, 82, 84, 4, 101, 100, 105, 116, 6, 115, 101, 110, 100, 116, 111, 6, 114, 101, 99, 111, 114, 100, 7, 99, 111, 110, 116, 114, 111, 108, 6, 115, 119, 105, 116, 99, 104, 1, 58, 1, 36, 4, 114, 101, 97, 108, 1, 115, 9, 101, 120, 116, 114, 105, 110, 115, 105, 99, 5, 115, 104, 111, 114, 116, 7, 114, 111, 117, 116, 105, 110, 101, 1, 35, 1, 46, 1, 42, 1, 44, 1, 40, 1, 41, 3, 111, 119, 110, 5, 99, 111, 110, 115, 116, 8, 101, 120, 116, 101, 114, 110, 97, 108, 1, 43, 1, 45, 5, 97, 114, 114, 97, 121, 1, 61, 3, 102, 111, 114, 4, 116, 104, 101, 110, 1, 33, 7, 99, 111, 109, 109, 101, 110, 116, 4, 108, 111, 110, 103, 6, 110, 111, 114, 109, 97, 108, 9, 112, 114, 105, 110, 116, 116, 101, 120, 116, 2, 45, 62, 6, 114, 101, 116, 117, 114, 110, 7, 114, 101, 115, 117, 108, 116, 61, 7, 109, 111, 110, 105, 116, 111, 114, 4, 115, 116, 111, 112, 4, 101, 120, 105, 116, 8, 99, 111, 110, 116, 105, 110, 117, 101, 4, 116, 114, 117, 101, 5, 102, 97, 108, 115, 101, 3, 97, 110, 100, 2, 61, 61, 2, 60, 45, 2, 105, 102, 6, 117, 110, 108, 101, 115, 115, 5, 119, 104, 105, 108, 101, 5, 117, 110, 116, 105, 108, 2, 111, 102, 7, 112, 114, 111, 103, 114, 97, 109, 4, 102, 105, 108, 101, 3, 105, 110, 116, 2, 109, 101, 1, 95, 1, 92, 1, 38, 2, 33, 33, 2, 60, 60, 2, 62, 62, 2, 42, 42, 2, 47, 47, 1, 47, 3, 110, 111, 116, 2, 111, 114, 9, 112, 114, 101, 100, 105, 99, 97, 116, 101, 2, 102, 110, 3, 109, 97, 112, 2, 60, 61, 1, 60, 2, 62, 61, 1, 62, 2, 92, 61, 4, 69, 68, 73, 84, 7, 67, 79, 77, 80, 73, 76, 69, 4, 83, 69, 78, 68, 4, 73, 78, 70, 79, 4, 67, 79, 68, 69, 5, 78, 65, 77, 69, 83, 4, 68, 85, 77, 80, 3, 77, 65, 80, 5, 73, 78, 80, 85, 84, 6, 79, 85, 84, 80, 85, 84, 6, 83, 89, 78, 84, 65, 88, 2, 78, 79, 6, 68, 69, 76, 69, 84, 69, 6, 77, 76, 69, 86, 69, 76, 6, 67, 65, 78, 67, 69, 76, 7, 77, 79, 78, 73, 84, 79, 82, 2, 85, 80, 4, 68, 79, 87, 78, 6, 82, 69, 83, 85, 77, 69, 4, 84, 82, 65, 80, 6, 73, 71, 78, 79, 82, 69, 5, 87, 72, 69, 82, 69, 4, 76, 73, 83, 84, 4, 70, 73, 78, 68, 5, 70, 79, 82, 67, 69, 6, 83, 89, 83, 79, 85, 84, 5, 67, 76, 69, 65, 82, 4, 76, 79, 79, 75, 5, 84, 82, 65, 67, 69, 2, 84, 79, 2, 79, 78, 3, 79, 70, 70, 6, 102, 111, 114, 109, 97, 116, 7, 105, 110, 116, 101, 103, 101, 114, 4, 98, 121, 116, 101, 6, 115, 116, 114, 105, 110, 103, 4, 101, 108, 115, 101, 6, 115, 121, 115, 116, 101, 109, 7, 100, 121, 110, 97, 109, 105, 99, 4, 110, 97, 109, 101, 4, 80, 85, 84, 95, 1, 64 %CONSTSHORTINTEGERARRAY FAULT NO(0 : 110) = %C 0, 14, 31, 47, 60, 87, 106, 129, 149, 169, 193, 212, 226, 257, 273, 287, 300, 318, 332, 352, 379, 418, 437, 468, 490, 514, 542, 555, 583, 605, 627, 650, 673, 691, 706, 724, 742, 760, 780, 798, 812, 0, 835, 0, 862, 877, 893, 915, 930, 954, 0, 970, 987, 1003, 1019, 1034, 1057, 1074, 0, 0, 0, 0, 1089, 1102, 1120, 1136,0, 0, 0, 1150, 1173, 1195, 1235, 1274, 1300, 1328, 0, 0, 0, 0, 0, 1360, 1374, 1389, 1405, 0, 0, 0, 1420, 1440, 0, 0, 0, 0, 0, 0, 0, 1454, 1470, 1490, 0, 1507, 1521, 1542, 1562, 1577, 1593, 1609, 1619, 1639, 1657 %CONSTBYTEINTEGERARRAY FAULT TEXT(0 : 1672) = %C 13, 'U', 'N', 'K', 'N', 'O', 'W', 'N', ' ', 'F', 'A', 'U', 'L', 'T', 16, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'R', 'E', 'P', 'E', 'A', 'T', 'S', 15, 'L', 'A', 'B', 'E', 'L', ' ', 'S', 'E', 'T', ' ', 'T', 'W', 'I', 'C', 'E', 12, '%', 'S', 'P', 'E', 'C', ' ', 'F', 'A', 'U', 'L', 'T', 'Y', 26, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'V', 'E', 'C', 'T', 'O', 'R', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'C', 'L', 'A', 'R', 'E', 'D', 18, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'L', 'A', 'B', 'E', 'L', ' ', 'E', 'R', 'R', 'O', 'R', 22, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'L', 'A', 'B', 'E', 'L', ' ', 'S', 'E', 'T', ' ', 'T', 'W', 'I', 'C', 'E', 19, 'N', 'A', 'M', 'E', ' ', 'D', 'E', 'C', 'L', 'A', 'R', 'E', 'D', ' ', 'T', 'W', 'I', 'C', 'E', 19, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', 'S', 23, 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', ' ', 'O', 'F', ' ', 'W', 'R', 'O', 'N', 'G', ' ', 'T', 'Y', 'P', 'E', 18, 'T', 'O', 'O', ' ', 'F', 'E', 'W', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', 'S', 13, 'L', 'A', 'B', 'E', 'L', ' ', 'N', 'O', 'T', ' ', 'S', 'E', 'T', 30, 'G', 'E', 'N', 'E', 'R', 'A', 'L', ' ', 'T', 'Y', 'P', 'E', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', ' ', 'M', 'I', 'S', 'U', 'S', 'E', 'D', 15, '%', 'R', 'E', 'P', 'E', 'A', 'T', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 13, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'E', 'N', 'D', 'S', 12, 'T', 'O', 'O', ' ', 'F', 'E', 'W', ' ', 'E', 'N', 'D', 'S', 17, 'N', 'A', 'M', 'E', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'C', 'L', 'A', 'R', 'E', 'D', 13, 'N', 'O', 'T', ' ', 'A', ' ', 'R', 'O', 'U', 'T', 'I', 'N', 'E', 19, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'V', 'E', 'C', 'T', 'O', 'R', ' ', 'E', 'R', 'R', 'O', 'R', 26, 'W', 'R', 'O', 'N', 'G', ' ', 'N', 'U', 'M', 'B', 'E', 'R', ' ', 'O', 'F', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', 'S', '&', 'S', 'W', 'I', 'T', 'C', 'H', '/', 'R', 'E', 'C', 'O', 'R', 'D', 'F', 'O', 'R', 'M', 'A', 'T', '/', 'P', 'R', 'E', 'D', 'I', 'C', 'A', 'T', 'E', ' ', 'I', 'N', ' ', 'E', 'X', 'P', 'R', 'N', 18, 'N', 'A', 'M', 'E', ' ', 'N', 'O', 'T', ' ', 'S', 'P', 'E', 'C', 'I', 'F', 'I', 'E', 'D', 30, 'A', 'C', 'T', 'U', 'A', 'L', ' ', 'P', 'A', 'R', 'A', 'M', 'E', 'T', 'E', 'R', ' ', 'O', 'F', ' ', 'W', 'R', 'O', 'N', 'G', ' ', 'T', 'Y', 'P', 'E', 21, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'N', 'A', 'M', 'E', ' ', 'I', 'N', ' ', 'E', 'X', 'P', 'R', 'N', 23, 'R', 'E', 'A', 'L', ' ', 'I', 'N', 'S', 'T', 'E', 'A', 'D', ' ', 'O', 'F', ' ', 'I', 'N', 'T', 'E', 'G', 'E', 'R', 27, 'C', 'Y', 'C', 'L', 'E', ' ', 'V', 'A', 'R', 'I', 'A', 'B', 'L', 'E', ' ', 'N', 'O', 'T', ' ', '%', 'I', 'N', 'T', 'E', 'G', 'E', 'R', 12, '%', 'F', 'A', 'U', 'L', 'T', ' ', 'E', 'R', 'R', 'O', 'R', 27, '%', 'T', 'R', 'U', 'E', '/', '%', 'F', 'A', 'L', 'S', 'E', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 21, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'S', 'C', 'R', 'I', 'B', 'E', 'D', 21, 'L', 'H', 'S', ' ', 'N', 'O', 'T', ' ', 'A', ' ', 'D', 'E', 'S', 'T', 'I', 'N', 'A', 'T', 'I', 'O', 'N', 22, '%', 'R', 'E', 'T', 'U', 'R', 'N', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 22, '%', 'R', 'E', 'S', 'U', 'L', 'T', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 17, 'L', 'A', 'B', 'E', 'L', ' ', 'M', 'E', 'A', 'N', 'I', 'N', 'G', 'L', 'E', 'S', 'S', 14, 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 17, 'T', 'E', 'X', 'T', 'U', 'A', 'L', ' ', 'L', 'E', 'V', 'E', 'L', ' ', '>', ' ', '9', 17, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'L', 'E', 'V', 'E', 'L', ' ', '>', ' ', '5', 17, 'F', 'A', 'U', 'L', 'T', ' ', 'U', 'N', 'T', 'R', 'A', 'P', 'P', 'A', 'B', 'L', 'E', 19, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'D', 'I', 'M', 'E', 'N', 'S', 'I', 'O', 'N', 'S', 17, 'C', 'O', 'N', 'S', 'T', 'A', 'N', 'T', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W', 13, 'R', 'E', 'A', 'L', ' ', 'E', 'X', 'P', 'O', 'N', 'E', 'N', 'T', 22, 'D', 'E', 'C', 'L', 'A', 'R', 'A', 'T', 'I', 'O', 'N', 'S', ' ', 'M', 'I', 'S', 'P', 'L', 'A', 'C', 'E', 'D', 26, 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'I', 'N', ' ', 'A', 'R', 'I', 'T', 'H', 'M', 'E', 'T', 'I', 'C', ' ', 'E', 'X', 'P', 'R', 'N', 14, 'C', 'O', 'N', 'S', 'T', 'A', 'N', 'T', ' ', 'E', 'R', 'R', 'O', 'R', 15, 'O', 'W', 'N', ' ', 'A', 'R', 'R', 'A', 'Y', ' ', 'E', 'R', 'R', 'O', 'R', 21, 'R', 'E', 'C', 'O', 'R', 'D', ' ', 'L', 'E', 'N', 'G', 'T', 'H', 'S', ' ', 'D', 'I', 'F', 'F', 'E', 'R', 14, 'D', 'A', 'N', 'G', 'L', 'I', 'N', 'G', ' ', '%', 'E', 'L', 'S', 'E', 23, 'S', 'U', 'B', 'S', 'T', 'I', 'T', 'U', 'T', 'E', ' ', 'C', 'H', 'A', 'R', ' ', 'I', 'N', ' ', 'T', 'E', 'X', 'T', 15, 'N', 'O', 'T', ' ', 'A', ' ', 'P', 'R', 'E', 'D', 'I', 'C', 'A', 'T', 'E', 16, 'S', 'P', 'U', 'R', 'I', 'O', 'U', 'S', ' ', '%', 'F', 'I', 'N', 'I', 'S', 'H', 15, '%', 'R', 'E', 'P', 'E', 'A', 'T', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 15, '%', 'F', 'I', 'N', 'I', 'S', 'H', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 14, 'S', 'P', 'U', 'R', 'I', 'O', 'U', 'S', ' ', '%', 'E', 'X', 'I', 'T', 22, '%', 'E', 'X', 'T', 'E', 'R', 'N', 'A', 'L', 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'F', 'O', 'U', 'N', 'D', 16, '%', 'E', 'N', 'D', 'O', 'F', 'F', 'I', 'L', 'E', ' ', 'F', 'O', 'U', 'N', 'D', 14, '%', 'B', 'E', 'G', 'I', 'N', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 12, 'W', 'R', 'O', 'N', 'G', ' ', 'F', 'O', 'R', 'M', 'A', 'T', 17, '%', 'R', 'E', 'C', 'O', 'R', 'D', 'S', 'P', 'E', 'C', ' ', 'E', 'R', 'R', 'O', 'R', 15, 'S', 'U', 'B', 'N', 'A', 'M', 'E', ' ', 'M', 'I', 'S', 'S', 'I', 'N', 'G', 13, 'W', 'R', 'O', 'N', 'G', ' ', 'S', 'U', 'B', 'N', 'A', 'M', 'E', 22, 'S', 'U', 'B', 'N', 'A', 'M', 'E', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 21, 'I', 'N', 'V', 'A', 'L', 'I', 'D', ' ', 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'L', 'E', 'N', 'G', 'T', 'H','''', 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'E', 'X', 'P', 'R', 'N', ' ', 'C', 'O', 'N', 'T', 'A', 'I', 'N', 'S', ' ', 'N', 'O', 'N', '-', 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'E', 'N', 'T', 'I', 'T', 'Y', '&', 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'E', 'X', 'P', 'R', 'N', ' ', 'C', 'O', 'N', 'T', 'A', 'I', 'N', 'S', ' ', 'I', 'N', 'V', 'A', 'L', 'I', 'D', ' ', 'O', 'P', 'E', 'R', 'A', 'T', 'O', 'R', 25, 'R', 'E', 'S', 'O', 'L', 'U', 'T', 'I', 'O', 'N', ' ', 'O', 'U', 'T', ' ', 'O', 'F', ' ', 'C', 'O', 'N', 'T', 'E', 'X', 'T', 27, 'R', 'E', 'S', 'O', 'L', 'U', 'T', 'I', 'O', 'N', ' ', 'F', 'O', 'R', 'M', 'A', 'T', ' ', 'I', 'N', 'C', 'O', 'R', 'R', 'E', 'C', 'T', 31, 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'E', 'X', 'P', 'R', 'N', ' ', 'C', 'O', 'N', 'T', 'A', 'I', 'N', 'S', ' ', 'S', 'U', 'B', '-', 'E', 'X', 'P', 'R', 'N', 13, 'I', 'T', 'E', 'M', ' ', '=', '=', ' ', 'E', 'X', 'P', 'R', 'N', 14, 'N', 'O', 'T', ' ', 'A', 'N', ' ', 'A', 'D', 'D', 'R', 'E', 'S', 'S', 15, 'N', 'O', 'N', ' ', 'E', 'Q', 'U', 'I', 'V', 'A', 'L', 'E', 'N', 'C', 'E', 14, 'R', 'E', 'C', 'O', 'R', 'D', ' ', 'M', 'I', 'S', 'U', 'S', 'E', 'D', 19, 'N', 'O', 'T', ' ', 'A', 'N', ' ', 'A', 'R', 'R', 'A', 'Y', ' ', 'F', 'O', 'R', 'M', 'A', 'T', 13, 'A', 'R', 'R', 'A', 'Y', ' ', 'M', 'I', 'S', 'U', 'S', 'E', 'D', 15, 'N', 'O', ' ', 'A', 'C', 'T', 'I', 'V', 'E', ' ', 'B', 'R', 'E', 'A', 'K', 19, 'O', 'W', 'N', ' ', 'A', 'R', 'R', 'A', 'Y', ' ', 'T', 'O', 'O', ' ', 'L', 'A', 'R', 'G', 'E', 16, 'N', 'O', ' ', 'B', 'A', 'S', 'E', ' ', 'R', 'E', 'G', 'I', 'S', 'T', 'E', 'R', 13, 'L', 'I', 'N', 'E', ' ', 'T', 'O', 'O', ' ', 'L', 'O', 'N', 'G', 20, 'L', 'O', 'N', 'G', ' ', 'A', 'N', 'A', 'L', 'Y', 'S', 'I', 'S', ' ', 'R', 'E', 'C', 'O', 'R', 'D', 19, 'D', 'I', 'C', 'T', 'I', 'O', 'N', 'A', 'R', 'Y', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W', 14, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'N', 'A', 'M', 'E', 'S', 15, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'L', 'E', 'V', 'E', 'L', 'S', 15, 'S', 'T', 'R', 'I', 'N', 'G', ' ', 'T', 'O', 'O', ' ', 'L', 'O', 'N', 'G', 9, 'A', 'S', 'L', ' ', 'E', 'M', 'P', 'T', 'Y', 19, 'E', 'N', 'D', ' ', 'O', 'F', ' ', 'F', 'I', 'L', 'E', ' ', 'R', 'E', 'A', 'C', 'H', 'E', 'D', 17, 'T', 'O', 'O', ' ', 'M', 'A', 'N', 'Y', ' ', 'R', 'O', 'U', 'T', 'I', 'N', 'E', 'S', 15, 'B', 'U', 'F', 'F', 'E', 'R', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W' %CONSTBYTEINTEGERARRAY OPC(0 : 120) = 0, 8,9,X'10',X'11',X'12', X'13',X'20',X'21',X'22',X'23', X'30',X'31',X'32',X'33',X'24', X'34',0,X'45',X'46',X'47', X'54',X'55',X'56',X'57',X'58',X'59',X'5A',X'5B',X'5C', X'5D',X'5E',X'5F',X'68',X'69',X'6A', X'6B',X'6C',X'6D',X'6E',X'6F', X'78',X'79',X'7A',X'7B',X'7C', X'7D',X'7E',X'7F',0,X'70', X'60',X'50',X'4E',X'4F',X'4C', X'4B',X'4A',X'49',X'48',X'44', X'43',X'42',X'41',X'40',0, X'90',X'98',X'86',X'87',0, X'91',X'92',X'94',X'95',X'96', X'97',X'9C',X'9E',X'9D',X'9F', X'82',X'84',X'85',0,X'88', X'89',X'8A',X'8B',X'8C',X'8D', X'8E',X'8F',0,X'D0',X'D1', X'D2',X'D4',X'D5',X'D6',X'D7', X'D8',X'DC',X'DD',X'DE',X'DF', X'D3',0,X'F1',X'F2',X'F3', X'F8',X'F9',X'FA',X'FB',X'FC', X'FD',0,10,4,X'80' %CONSTINTEGERARRAY NEM(0 : 120) = M'CNOP', M'SSK',M'ISK',M'LP',M'LN',M'LT', M'LC',M'LPD',M'LND',M'LTD',M'LCD', M'LPE',M'LNE',M'LTE',M'LCE',M'HD', M'HE',0,M'BAL',M'BCT',M'BC', 'N',M'CL','O','X','L','C','A','S','M','D', M'AL',M'SL',M'LD',M'CD',M'AD', M'SD',M'MD',M'DD',M'AW',M'SW', M'LE',M'CE',M'AE',M'SE',M'ME', M'DE',M'AU',M'SU',0,M'STE', M'STD',M'ST',M'CVD',M'CVB',M'MH', M'SH',M'AH',M'CH',M'LH',M'EX', M'IC',M'STC',M'LA',M'STH',0, M'STM',M'LM',M'BXH',M'BXLE',0, M'TM',M'MVI',M'NI',M'CLI',M'OI', M'XI',M'SDV',M'HDV',M'TDV',M'CKC', M'PC',M'WRD',M'RDD',0,M'SRL', M'SLL',M'SRA',M'SLA',M'SRDL',M'SLDL', M'SRDA',M'SLDA',0,M'SSP',M'MVN', M'MVC',M'NC',M'CLC',M'OC',M'XC', M'LSP',M'TR',M'TRT',M'ED',M'EDMK', M'MVZ',0,M'MVO',M'PACK',M'UNPK', M'ZAP',M'CP',M'AP',M'SP',M'MP', M'DP',0,M'SVC',M'SPM',M'IDL' %TRUSTEDPROGRAM %LIST !*********************************************************************** !* * !* * !* IMP INTERPRETER VERSION 8 WITH MONITORING * !* * !* * !*********************************************************************** ! ! ! !**************************************************************** !* * !* STACKTOP : CODE TOP : ASTACK : APERM : GLA HEAD * !* * !* R9 : R10 : R11 : R12 : R13 * !* * !**************************************************************** ! ! !*** STREAM DEFINITIONS *** ! ! STREAM 79 OUTPUT ! STREAM 78 INPUT ! ! ! !*************************************************************** !* * !* GLA LAYOUT * !* * !* 0 : 0 - 0 ARRAY DEC FLAG * !* 0+: 1 - 3 0 TRAP RECORD ADDR * !* 1 : 4 - 7 X'50000000' LANGUAGE FLAG * !* 2 : 8 - 11 X'E2E2E2E2' DIAGS TERMINATOR * !* 3 : 12 - 15 FAULT TRAP WORD * !* 4 : 16 - 19 -1 CONSTANT FOR '\' * !* 5 : 20 - 21 DIAG BLOCK INDEX * !* 5+: 22 - 23 DIAG LINE NUMBER * !* 6 : 24 - 27 X'000000FF' BYTE MASK * !* 7 : 28 - 31 8 DIAG TABLE DISP * !* 8 : 32 - 35 FREE ARRAY SPACE * !* 9 : 36 - 39 ARRAY SPACE LIMIT * !* 10 : 40 - 43 PERM WORK SPACE * !* 11 : 44 - 55 PERM ENTRY INFO * !* 14 : 56 - 59 STRING LENGTH (RSLN) * !* 15 : 60 - 63 @ END OF STACK * !* 16 : 64 - 67 PERM WORK * !* 17 : 68 - 71 X'80000000' FLOATING CONSTANT * !* 18 : 72 - 75 X'4E000000' FLOATING CONSTANT * !* 19 : 76 - 81 *MVC_0(0,1),0(14) * !* 20+: 82 - 87 *MVC_0(0,2),0(1) * !* 22 : 88 - 95 X'8080808080808080' * !* 24 : 96 - 101 *MVC_0(0,1),0(2) * !* * !*************************************************************** ! !********************************************* !* * !* PERM ENTRY TABLE * !* * !* 0 : STOP SEQUENCE * !* 1 : 1-DIM ARRAY REFERENCE * !* 2 : N-DIM ARRAY REFERENCE * !* 3 : UNASSIGNED VARIABLE * !* 4 : CAPACITY EXCEEDED * !* 5 : MONITORSTOP * !* 6 : FAULT TRAP * !* 7 : MONITOR * !* 8 : SWITCH CHECKING + JUMP * !* 9 : RESOLUTION FAILS * !* 10 : CYCLE TESTING * !* 11 : INTEGER EXPONENTIATION * !* 12 : REAL EXPONENTIATION * !* 13 : NON-INTEGER QUOTIENT * !* 14 : STRING CONCATENATION * !* 15 : STRING RESOLUTION (FIRST ENTRY) * !* 16 : STRING RESOLUTION (OTHER ENTRIES) * !* 17 : SET ARRAY SPACE UNASSIGNED * !* 18 : ARRAY DECLARATION * !* 19 : STRING COMPARISON * !* 20 : PRINTTEXT * !* 21 : RESULT NOT SPECIFIED * !* 22 : EXCESS BLOCKS * !* 23 : CALL IOCP * !* 24 : TEST FOR EXCESS BLOCKS IN ROUTINE * !* 25 : ROUTINE FAULTY * !* 26 : RELOCATE ARRAYS * !* 27 : CLAIM LEVEL 1 ARRAY SPACE * !* 28 : CLAIM LEVEL N ARRAY SPACE * !* 29 : CORRUPT DOPE-VECTOR * !* 30 : BULK MOVE * !* 31 : ROUTINE NOT DESCRIBED * !* 32 : SET RECORD TO ZERO * !* 33 : MONITORING ENTRY FOR ROUTINES * !* * !********************************************* ! ! ! ! !****************************************************** !* * !* COMPILER FAULTS * !* * !* 200 : NO FREE REGISTERS * !* 201 : REGISTER NOT CLAIMED * !* * !* 208 : REAL INDEX REGISTER * !* 209 : REMOVE NON-EXISTANT LABEL * !* 210 : ZERO ASSOP * !* * !* 212 : CORRUPT COMPILER NAME * !* * !* 220 : ROUTINE ENTRY NOT CLAIMED * !* 221 : MAIN ROUTINE ENTRY LOST * !* 222 : ROUTINE HAS NO ENTRY POINT * !* * !* 240 : CANNOT RESTORE ROUTINE ENTRY POINT * !* * !* 250 : DUPLICATE BLOCK FOR SEND TO * !* 255 : DUPLICATE COMPILER NAME * !* * !****************************************************** ! ! ! !********************************************************************** !* * !* VAR FLAGS : 1 %SPEC WANTED * !* 2 %SPEC GIVEN : DEFINITION WANTED * !* 4 PARAMETER * !* 8 ASSIGN VIA '==' * !* 16 TYPE OF ROUTINE * !* 32 TYPE OF ROUTINE * !* 64 ASSOP = 1 * !* 128 ASSOP = 2 * !* * !********************************************************************** ! ! !************************************************ !* * !* VAR TYPES * !* * !* 0 : CONSTANT * !* 4 : INTEGER * !* 5 : BYTEINTEGER * !* 6 : SHORTINTEGER * !* 7 : RECORD * !* 8 : REAL * !* 10 : LONGREAL * !* 13 : GENERAL TYPE * !* 14 : PREDICATE * !* 15 : ROUTINE * !* 31 : RECORDFORMAT * !* 64 : SWITCH * !* 128+: ARRAYFORMAT * !* * !************************************************ !********************************************************* !* * !* VAR_FORM : 1 SCALAR * !* 2 NAME * !* 4 ARRAY * !* 8 RFMP / INDEX LIST * !* 16 == * !* 32 * !* 64 * !* 128 IN A REGISTER * !* * !********************************************************* ! ! ! !*************************************************** !* * !* COMP MODE 1 INPUT FROM TEXTP * !* 2 %EDIT * !* 4 ROUTINE/FN/MAP/BEGIN * !* 8 START/CYCLE * !* 16 ROUTINE/FN/MAP * !* 32 EDIT FLAG * !* 64 INPUT NOT FROM .TT * !* 128 FAULTY BLOCK * !* * !*************************************************** ! ! !******************************************** !* * !* CONTROL OPTIONS * !* * !* 1 : OUTPUT COMPILED CODE * !* 2 : PERMIT SIGNAL REPORTING * !* 3 : PRINT REGISTER USEAGE * !* 4 : EXTRA INFO * !* 5 : GIVE DUMP AT SIGNALS * !* 6 : MAKE INT:Q == INT:H * !* 7 : INHIBIT DIAG TABLE * !* 8 : INHIBIT UNASSIGNED CHECKING * !* * !******************************************** ! %CONSTINTEGERARRAY FIXEDGLA(0 : 29) = %C 0, X'50000000', X'E2E2E2E2', 0, -1, 0, X'FF', 8, 0(9), X'80000000', X'4E000000', X'D2001000', X'E000D200', X'20001000', X'80808080', X'80808080', X'D2001000', X'20000000', 0(3), X'FF000000' %CONSTBYTEINTEGERARRAY DIAGMAP(0 : 191) = %C 0, 0, 4, 97, 99, 0, 4, 0(9), 0, 0, 8, 97, 99, 0, 4, 0(9), 0, 0, 16, 97, 99, 0, 255, 132, 0(8), 0, 0, 5, 97, 99, 0(11), 0, 0, 6, 97, 99, 0, 2, 0(9), 0, 0, 10, 97, 99, 0, 8, 0(9), 0, 0, 4, 83, 99, 0, 4, 0(9), 0, 0, 8, 83, 99, 0, 4, 0(9), 0, 0, 16, 83, 99, 0, 4, 0(9), 0, 0, 5, 83, 99, 0(11), 0, 0, 6, 83, 99, 0, 4, 0(9), 0, 0, 10, 83, 99, 0, 4, 0(9) ! ! ABOVE ARE VAR TAGS RECORDS FOR EXTERNAL DIAGS ! %CONSTBYTEINTEGERARRAY DTAB MAP(0 : 13) = %C 0, 1, 2, 0, 3, 0(3), 4, 0(4), 5 ! ! ! ! ! STRING FOR INITIAL '%BEGIN' PROMPT ! %CONSTBYTEINTEGERARRAY INITP(0 : 15) = %C 15, ' ', ' ', ' ', '%', 'B', 'E', 'G', 'I', 'N', 13, 10, ' ', ' ', ' ', ':' %CONSTBYTEINTEGERARRAY NAME FLAG(4 : 16) = %C 1, 9, 17, 0, 2, 0, 26, 0, 0, 0, 0, 0, 5 %CONSTBYTEINTEGERARRAY TYPE CODE(1 : 7) = 4,5,6,8,10,16,7 %CONSTSHORTINTEGERARRAY ROUND(0 : 16) = %C 3, 3, 3, 3, 3, 0, 1, 3, 3, 3, 7, 3, 3, 3, 3, 3, 3 %CONSTSHORTINTEGERARRAY VBYTES(1 : 6) = %C 4, 1, 2, 4, 8, 4 %CONSTINTEGERARRAY OPCODE(0 : 24) = %C 0, X'1A', X'1B', X'14', X'17', X'16', 0(3), X'1C', X'1D', X'1D', 0, X'2A', X'2B', 0(6), X'2C', 0, X'2D', 0 %CONSTSHORTINTEGERARRAY CONCODE(1 : 8) = %C 8, 7, 13, 4, 11, 2, 7, 0 %CONSTSHORTINTEGERARRAY PARMMASK(0 : 7) = %C 15,12,13,0,26,26,15,15 %CONSTSHORTINTEGERARRAY PATTERN(0 : 7) = %C 0, 4, 1,0,24,26, 0, 0 %CONSTSHORTINTEGERARRAY LOADTYPE(0 : 16) = %C 4, 0(3), 4(3), 0, 10, 0, 10, 10, 0(4), 16 %CONSTSHORTINTEGERARRAY LOADCODE(0 : 16) = %C X'41', 0(3), X'58', X'43', X'48', -64, X'7A', 0, X'68', X'68', 0, -12, -23(2), X'41' %CONSTSHORTINTEGERARRAY STORECODE(0 : 16) = %C 0(4), X'50', X'42', X'40', -64, X'70', 0, X'60', 0(3), -20, 0, -71 %CONSTBYTEINTEGERARRAY CNTYPE(0 : 54) = %C 4, 4, 4, 4, 10, 10, 16, 4, 4, 16, 4, 4, 16, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 16, 4, 16, 4, 4, 4, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 4, 4, 4, 4, 4, 4, 4 %CONSTINTEGER RTMONENTRY = X'45FC0084'; ! ENTRY FOR MONITORING %CONSTINTEGER PERMSNL = X'4110C0C0' %CONSTINTEGER RTBASE = X'D070'; ! ADDRESS OF FIRST ROUTINE DESC. %CONSTINTEGER RESFLOP = X'C024'; ! PERM ENTRY FOR 'RESOLUTION FAILS' %CONSTINTEGER LIST SIZE = 4000; ! SIZE OF ARRAY FOR CELLS %CONSTINTEGER DATA FDP = 28; ! FDP NUMBER FOR LOADING DATA AREAS %CONSTINTEGER LOAD FDP = 28; ! FDP NUMBER FOR DYNAMIC LOADING %CONSTINTEGER FDP DATA REF = 'X'; ! SPECIAL FOR NOW %CONSTINTEGER FDP REF = 'E'; ! TYPE OF LOAD ! !######################## START OF MAIN PROGRAM ######################## ! %BEGIN %RECORDFORMAT AGFM(%INTEGER EP,%STRING(17) NAME, %C %INTEGER P1,P2, %INTEGERNAME FLAG) %RECORDFORMAT MON DIAG HEAD FM(%INTEGER DIAGS, %C %SHORTINTEGER LINE, NAME, %INTEGER INDEX, LINK) %RECORDFORMAT RTFM(%INTEGER CODE, GLA, EP, ENVIR) %RECORDFORMAT RBFM(%INTEGER LINK, TEXT, LENGTH, ENTRIES) %RECORDFORMAT BFM(%BYTEINTEGER FLAGS, TYPE, TYPE2, MODE, %C %SHORTINTEGER DISP, MAX DISP, %C %INTEGER SHEAD, LHEAD, R10, AD, X1, X2, X3) %RECORDFORMAT BLOCKFM(%SHORTINTEGER ADDR, %C %BYTEINTEGER SPARE, TYPE, %INTEGER CYCLE, ELSE, LINK) %RECORDFORMAT LABELFM(%INTEGER LABEL, ADDRESS, USE, LINK) %RECORDFORMAT VARFM(%SHORTINTEGER ADDRESS, %C %BYTEINTEGER TYPE, FORM, LEVEL, DIMENSION, LENGTH, %C FLAGS, %INTEGER INDEX, LINK) %DYNAMICROUTINESPEC HEX(%INTEGER N) %SYSTEMROUTINESPEC IIGEN(%STRING (8) S, %INTEGERNAME J, K) %SYSTEMROUTINESPEC IIDUMP(%INTEGER J, K) %SYSTEMROUTINESPEC DECODE(%INTEGER J, K, L) %DYNAMICROUTINESPEC CLEAR(%STRING (63) S) %DYNAMICROUTINESPEC DEFINE(%STRING (63) S) %SYSTEMROUTINESPEC RIM(%INTEGER CONSOLE, %STRING (15) S) %DYNAMICROUTINESPEC EDINNER( %C %INTEGER ST, SL, SEC1, SEC2, AWSP, %INTEGERNAME L) ! ST = @ START OF TEXT ! SL = LENGTH OF INPUT FILE ! AWSP = @ WORK SPACE ! L = INITIAL/FINAL LENGTH OF OUTPUT FILE %DYNAMICSTRINGFNSPEC TIME %DYNAMICSTRINGFNSPEC DATE %DYNAMICINTEGERFNSPEC TESTINT(%INTEGER C, %STRING (15) S) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %SYSTEMROUTINESPEC I8INIT( %C %INTEGER DICT, NLADDR, DIAG, SYSOUT, IOUT, GLA, PERM, %C MODE) %SYSTEMROUTINESPEC AGENCY(%INTEGER EP, %RECORDNAME P) %SYSTEMROUTINESPEC PDIAG(%INTEGER A, B, C) %SYSTEMROUTINESPEC ITRAP(%INTEGER X, Y) %SYSTEMROUTINESPEC UNTRAP ! !*** LOCAL SPECS *** ! %ROUTINESPEC SIGNAL(%INTEGER EP,PARM,X,%INTEGERNAME FLAG) %ROUTINESPEC FDP(%INTEGER EP,%STRING(17) S, %C %INTEGER P1,P2,%INTEGERNAME F) %ROUTINESPEC RESET IO %ROUTINESPEC LOAD PERM %ROUTINESPEC STOP %ROUTINESPEC D C NAMES %ROUTINESPEC SEND TO %ROUTINESPEC DOT NAME %ROUTINESPEC HASH EXPRNS %ROUTINESPEC SKIPEXPRN %ROUTINESPEC FMESSAGE(%INTEGER N) %ROUTINESPEC FAULT(%INTEGER N) %ROUTINESPEC FAULT2(%INTEGER N, NAME) %INTEGERFNSPEC R V LEN(%INTEGER PT) %ROUTINESPEC C B PAIR(%INTEGERNAME L, R) %ROUTINESPEC SET UAV PAT(%INTEGER BYTES, AD1) %INTEGERFNSPEC NEW RT %ROUTINESPEC VTYPE(%RECORDNAME V) %ROUTINESPEC QNAME(%RECORDNAME V) %ROUTINESPEC RT(%RECORDNAME V) %ROUTINESPEC D DEC(%INTEGER N, AD, L, MODE) %ROUTINESPEC C NAME LIST(%INTEGER NAMES, BYTES) %ROUTINESPEC C L NAME LIST(%INTEGER BYTES) %ROUTINESPEC DECLARE %ROUTINESPEC COMP P LIST(%INTEGER NEW, OLD) %ROUTINESPEC DEC FP LIST(%INTEGER HEAD) %ROUTINESPEC C REC DEC(%INTEGER FLAG) %ROUTINESPEC C FP DEFN(%RECORDNAME HEADER) %ROUTINESPEC C RFM DEC %ROUTINESPEC C A DECLN %ROUTINESPEC RELEASE RT(%INTEGER N) %ROUTINESPEC MOVE(%INTEGER L, F, T) %ROUTINESPEC EDIT(%BYTEINTEGER MODE) %ROUTINESPEC DEFINE RT %ROUTINESPEC RESTRUCTURE(%INTEGER BP) %ROUTINESPEC TIDY LABELS %ROUTINESPEC TIDY STARTS %ROUTINESPEC TIDY(%INTEGERNAME CELL) %ROUTINESPEC TIDY ALL %ROUTINESPEC OLD BLOCK %ROUTINESPEC C END %ROUTINESPEC SET DIAG(%INTEGER AD, NAME) %ROUTINESPEC NEW DIAG(%INTEGER AD) %INTEGERFNSPEC NEW CELL %ROUTINESPEC NEW BLOCK(%BYTEINTEGER T) %ROUTINESPEC PUSH(%INTEGERNAME HEAD, %INTEGER X, Y, Z) %INTEGERFNSPEC ENAME(%INTEGER LIST) %ROUTINESPEC GET4(%INTEGERNAME N) %ROUTINESPEC GET8(%LONGREALNAME R) %ROUTINESPEC GET CYCLE SPACE(%INTEGERNAME A) %INTEGERFNSPEC GET FORMAT(%INTEGER FNAME) %INTEGERFNSPEC GET NAME(%INTEGER NAME) %ROUTINESPEC S LOAD(%INTEGER STRING, REGISTER) %ROUTINESPEC CSEXPRN(%INTEGERNAME ADDRESS) %ROUTINESPEC FILL JUMPS(%RECORDNAME HEAD) %ROUTINESPEC REMOVE LABEL(%INTEGER LABEL) %ROUTINESPEC LABEL FOUND(%INTEGER LABEL) %ROUTINESPEC JUMP TO(%INTEGER LABEL, MASK) %INTEGERFNSPEC FORWARD ADDRESS(%INTEGER LEN) %INTEGERFNSPEC FORWARD REF(%INTEGER MASK) %INTEGERFNSPEC COND TYPE %ROUTINESPEC S COND(%INTEGER MASK, LABEL) %ROUTINESPEC COND(%INTEGER VALIDITY, FARLABEL) %ROUTINESPEC C COND(%INTEGER CTYPE) %ROUTINESPEC S CPE(%RECORDNAME V, %INTEGER EX) %ROUTINESPEC GETSVAR(%RECORDNAME V) %ROUTINESPEC GET NAME VAR(%RECORDNAME V, %INTEGER FLT) %ROUTINESPEC AVAILABLE(%INTEGERNAME REGISTER, %BYTEINTEGER TYPE) %ROUTINESPEC STUAV(%INTEGER REG) %ROUTINESPEC TESTUAV(%BYTEINTEGER T, %INTEGER REGISTER) %ROUTINESPEC SETTEXT(%BYTEINTEGER FLAG) %ROUTINESPEC PUT4(%INTEGER N) %ROUTINESPEC PUT8(%LONGREAL R) %ROUTINESPEC CCONST(%RECORDNAME V) %ROUTINESPEC GETINFO(%INTEGER NAME, %RECORDNAME VAR) %ROUTINESPEC RT SAVE(%INTEGER R2) %ROUTINESPEC C C NAME(%RECORDNAME V) %ROUTINESPEC VAR(%RECORDNAME V) %ROUTINESPEC CLAIMSAFEREGISTER(%INTEGERNAME REGISTER) %ROUTINESPEC RELEASEREGISTER(%INTEGER REGISTER) %ROUTINESPEC PROTECT(%BYTEINTEGER TYPE) %ROUTINESPEC EQUATETYPES(%RECORDNAME LHS, RHS) %ROUTINESPEC LOAD(%RECORDNAME V, %INTEGER R) %ROUTINESPEC LOADADDR(%RECORDNAME V, %INTEGER REG) %ROUTINESPEC EXPRN(%RECORDNAME LHS) %ROUTINESPEC STORE(%RECORDNAME VAR, DEST) %ROUTINESPEC ASSIGN(%RECORDNAME LHS, %INTEGER ASSOP) %ROUTINESPEC CUI(%INTEGER UTYPE) %INTEGERFNSPEC FOR CLAUSE; ! COMPILES (VAR) = A,B,C %ROUTINESPEC C FINISH %ROUTINESPEC PUT LINE %ROUTINESPEC CSS(%INTEGER SST) %ROUTINESPEC COMPILE BLOCK %ROUTINESPEC EXECUTE CODE %ROUTINESPEC PLANT(%INTEGER N) %ROUTINESPEC SPLANT(%INTEGER N) %ROUTINESPEC DRR(%INTEGER OPCODE, R1, R2) %ROUTINESPEC DRX(%INTEGER OPCODE, R1, X, AD) %ROUTINESPEC DSS(%INTEGER OPCODE, LENGTH, AD1, AD2) %ROUTINESPEC DSI(%INTEGER OPCODE, ADDR, IM) %INTEGERFNSPEC FIND(%INTEGER NAME) %INTEGERFNSPEC CONSTANT(%BYTEINTEGER TYPE) %INTEGERFNSPEC NAME %ROUTINESPEC RECONSTRUCT %ROUTINESPEC DEC CONST ARRAY(%INTEGER LEN) %ROUTINESPEC PRINT LABEL(%INTEGER LABEL) %ROUTINESPEC FIND CYCLE(%INTEGERNAME P) %ROUTINESPEC GET RESLN VAR(%INTEGERNAME ENTRY) %ROUTINESPEC FLOAT(%RECORDNAME VAR, %INTEGER REG) %ROUTINESPEC TEMPREAL(%INTEGERNAME ADDRESS) %ROUTINESPEC CRES(%INTEGER LABEL, MASK) %ROUTINESPEC SET CONST(%INTEGER WTYPE, SLEN, PLUS) %ROUTINESPEC C OWN DEC %ROUTINESPEC DUMP SIGNAL(%INTEGER L) %ROUTINESPEC CREATE DIAG LIST(%INTEGERNAME NLINK) %ROUTINESPEC DEFINE DIAGS(%INTEGER AGLA, BLOCK) %ROUTINESPEC SET UP MONITOR(%BYTEINTEGER MODE) %INTEGERFNSPEC ASL LENGTH %ROUTINESPEC SET FILE(%BYTEINTEGER FLAG, %STRING (3) STREAM) %ROUTINESPEC DEFINE TRACE %ROUTINESPEC SET CONTROL(%INTEGER N) %ROUTINESPEC COMPARE RT(%RECORDNAME V, %INTEGER LIST) %ROUTINESPEC SPECIAL(%INTEGER ST) %ROUTINESPEC UN CLAIM %ROUTINESPEC ABORT %ROUTINESPEC PRINT USE %ROUTINESPEC NAME INFO(%INTEGER NAME) %ROUTINESPEC PRINT RECORD(%RECORDNAME N) %ROUTINESPEC I8DIAG(%INTEGER EP) %ROUTINESPEC C SWITCH %ROUTINESPEC SW REF %ROUTINESPEC CREATE DUMMY REFS(%INTEGER LIST) %ROUTINESPEC INT DUMP %INTEGERFNSPEC MCODE(%INTEGER J) %ROUTINESPEC CNOP(%INTEGER A, B) %ROUTINESPEC CUCI ! ! EXTERNAL BREAK CONTROL ! %SHORTINTEGER MONITOR BLOCK, MONITOR LINE %INTEGER DPT, MONENTRY, MONITOR GLA %RECORDARRAYNAME DIAG VAR(VARFM) %RECORDARRAYFORMAT DIAGMAPFORM(0 : 11)(VARFM) %RECORDNAME DIAG HEAD(MON DIAG HEAD FM) %RECORD DIAG BASE(MON DIAG HEAD FM) ! ! ANALYSIS RECORD ARRAY ! %SHORTINTEGERARRAY REC(0 : 300) %INTEGERARRAY LISTS(1 : LIST SIZE), DICT(0 : 2048), DIAG TAB(-2048 : %C 0) %BYTEINTEGERARRAY LINE(0 : 301), REGUSE(4 : 8) %BYTEINTEGERARRAY RENTRY(0 : 127) %INTEGER RTP, BLOCK NAME, BLOCK ENTRY ! ! VECTOR FOR CO-ROUTINE ENTRY FROM S#IMPMON ! %OWNINTEGER BR9, BR10, BR11, BR12, BR13, BR14 %EXTERNALINTEGER BRK R9 AD; ! ADDRESS OF BR9 ! ! ! INTERRUPT HANDLING BUFFERS ! %OWNINTEGERARRAY INT SAVES(0 : 14); ! FOR MON ? %OWNINTEGERARRAY SAVEAREA(4 : 16); ! FOR SIGNAL %OWNINTEGERARRAY DCONTAREA(4 : 16); ! FOR DOUBLE CONTINGENCY %OWNINTEGERARRAY DLENV(4 : 14); ! ENVIRONMENT FOR DYNAMIC LOADING %OWNBYTEINTEGER WT, ERRNUM, INTQ FLAG, SPECIAL INT %OWNINTEGER SIGAREA, ELISTP, FAIL INFO %OWNBYTEINTEGER INTQ INFO, INTQ SYM ! ! VARIABLES FOR DYNAMIC LOADING OF EXTERNALS ! %OWNINTEGER D LOAD ENV, D LOAD ENTRY, DR11, D ENTRY %OWNINTEGER DLC, DLG, DLEP, DLRA, MISSING EP ! ! PROMPT CONTROL WORDS ! %OWNINTEGER PAT1 = X'04202020' %OWNBYTEINTEGER PROMPTCH = ':' ! ! BUFFER FOR EXTERNAL NAMES ! %STRING (8) IOFILE %BYTEINTEGERARRAY ENTRY LIST(0 : 127) ! ! CONTROL VARIABLES ! %BYTEINTEGER DCOMP, PERMIT, USE, HALT, DUMP, SHORT FORM, DIAGS, TUAV ! ! ! %INTEGER LAST ASL, ASL; ! KEEP IN THIS ORDER ! ! CODE CONTROL VARIABLES ! %INTEGER STACK, CSTART, CODEIN, CODE HEAD, CODE START %INTEGER CODE TOP, CODE END ! ! GLA AND OWN CONTROL VARIABLES ! %RECORDARRAY RTS(-7 : 255)(RTFM) %INTEGER OWN DISP, OWN TOP, OWN END, OWN LIST HEAD %INTEGER GLA, GLAP, OWNLIST, OWNNAME, OWNHEAD ! ! LABEL PROCESSING VARIABLES ! %INTEGER ILAB, START HEAD, LABEL HEAD, LABEL ADDRESS %INTEGER CYCLE LABEL, ELSE LABEL ! ! BASIC LEVEL TEXT CONTROL ! %INTEGER DEC START, DEC FILE, DEC LIMIT, DEC1, DEC2, FIRST CHAR ! ! ROUTINE TEXT CONTROL VARIABLES ! %INTEGER TEXT HEAD, XFLAG %INTEGER TEXTIN, TEXTP, OLD TEXT, LINE ENTRY, LINE START, LINE LENGTH ! ! DICTIONARY CONTROL VARIABLES ! %INTEGER DICTHEAD, DICTFREE, DICT MAX, FIRST, LAST ! ! DIAGNOSTIC CONTROL VARIABLES ! %INTEGER DIAG PT, DIAG END, DIAG SAVE, MON LABEL, PERM ERROR, %C DIAG FLAG ! ! NAME PROCESSING VARIABLES ! %RECORDNAME WORK(VARFM) %INTEGER FORMATP, VNAME, FMLEN, LHS INDEX, OLD INDEX, DOPE VECTOR ! ! REGISTER CONTROL VARIABLES ! %INTEGER BASE REG, GPR1, FPR2, AREG ! ! ! ! ! ! ROUTINE MONITORING CONTROL VARIABLES ! %BYTEINTEGER RTMONENABLE, MON FILE CREATED %INTEGER RT MON FILE, RT MON NAMES, RT MON HEAD %SHORTINTEGERARRAY MONNAME(0 : 127) ! ! %INTEGER CYC NUM, LINE NUM, RTNAME ! ! ! %BYTEINTEGER LIST, SYNTAX, FAULTY, REALS, SUSPEND, RUNNING, PRINTED, %C ACCESS ! %BYTEINTEGER DEC FLAG, FN TYPE, FN TYPE 2, MAPV, ZERO EXP %BYTEINTEGER C LIST, UAVFLAG, LEVEL, DIS FLAG, R14, EXPRN TYPE %BYTEINTEGER NLFLAG, NASTY, EXTRINSIC, SPEC, RTYPE, ALLIGNMENT %BYTEINTEGER FP MODE, CPE LEN, SNLEN, S CONST, BLOCKTYPE, DEFNUM, %C EDDEF ! %OWNBYTEINTEGER STUDENT = 1; ! DEFAULT IS A STUDENT %INTEGER J, K, L ! %INTEGER SM, SYM, RP, SMAX, DISP, MAX DISP ! %INTEGER ASSOP, EFREE, COND1, COND2, COM36, SYSOUT, IOUT, MLEVEL %BYTEINTEGER FIDDLE FACTOR ! ! SAVE VARIABLES FOR RUNNING CODE'S R9 - R14 ! MUST BE LEFT IN THIS ORDER! ! %INTEGER STACKTOP, R10, ASTACK, APERM, GLA HEAD, RTFAULTY ! %OWNINTEGER CONNECT ADDRESS ! %OWNINTEGER CODE, INITIAL STACK, OLD CODE TOP SAVE ! %OWNBYTEINTEGER RESTART = 0; ! FLAG FOR RESTARTING %INTEGERNAME DIAG BLOCK, END A SPACE, A SPACE %INTEGERNAME LIST HEAD, LIST END, ENDOFSTACK, INDEXPT %RECORDARRAY BLOCK INF(0 : 11)(BFM) %RECORDNAME BLOCK(BFM) %RECORD LHS, DUMMYNAME, NEW NAME(VARFM) ! ! COMMUNICATION VARIABLES FOR INTSYSTY ! %EXTERNALBYTEINTEGER INSTREAM = 0; ! INPUT STREAM WHEN RUNNING %EXTRINSICSTRING(15) P STRING %EXTRINSICINTEGER INTSIZE, REG9, MON REP %EXTERNALBYTEINTEGER COMP MODE = 0, IOFLAG = 0 %EXTRINSICBYTEINTEGER MONLOCK %EXTERNALINTEGER MONFRAME, MONINFO ! ! *OI_4(13),5 *ST_11,INITIAL STACK ! ! RELOAD:!************ RETURN HERE TO RESTART THE PROCESS ************ ! ! *L_11,INITIAL STACK L = INTSIZE+24; K = L<<12-16 %IF RESTART = 0 %START IIGEN('II#CODE',L,J); ! SET UP II#CODE PRINTSTRING('CANNOT CREATE WORK FILE ') %ANDSTOP %IF J # 0 CONNECT ADDRESS = L %FINISH *LH_1, *ST_1,J %STOP %IF J # X'0AFE' CODE = CONNECT ADDRESS DEC START = (CODE+K>>1)&X'FFFFF8' DECLIMIT = DECSTART+8000 DECFILE = DEC START; BYTEINTEGER(DEC FILE) = NL STACK = DEC LIMIT ! ! SET UP THE CO-ROUTINE VECTOR ! *LA_14, *STM_9,14,BR9 BRK R9 AD = ADDR(BR9) ! ! SET UP RETURN ADDRESS FOR I8DIAG. ! *LA_1, *ST_1,MON LABEL ! ! PRINTED = 2 %IF IOFLAG # 0 ! DISP = X'9040' ! ! SET UP DUMMY NAME (USED AFTER FAULT 16 ETC.) ! DUMMY NAME = 0 DUMMY NAME_LEVEL = 255 DUMMY NAME_TYPE = B'100' DUMMY NAME_FORM = B'10001'; ! SET THE NAME BIT FOR UNDECLARED NAMES DUMMY NAME_FLAGS = B'10010000'; ! ASSOP = 2, RT TYPE = 1 ! ! SET UP ROUTINE ENTRY LIST ! %CYCLE RTP = 0,1,127; RENTRY(RTP) = RTP %REPEAT ! ! DEFINE DEFAULT %CONTROL OPTIONS ! !! DCOMP = 0 ! NO CODE OUTPUT !! PERMIT = 0 ! NO SIGNAL REPORTING !! USE = 0 ! NO REGISTER USEAGE PRINTING !! HALT = 1 ! REPORT INT:Q !! DUMP = 0 ! NO DUMPS AFTER SIGNALS !! SHORT FORM = 0 ! NO EXTRA INFO !! DIAGS = 3 ! DUMP DIAG TABLES/ LINE NOS !! TUAV = 1 ! UNASSIGNED CHECKING ON SET CONTROL(X'00010031') ! INITIALIZE ROUTINE MONITORING ! MON FILE CREATED = 0 RT MON ENABLE = 0 ! UAVFLAG = 0; SNLEN = 0; SPECIAL INT = 0 START HEAD = 0; SMAX = 0; CYC NUM = 0; DEFNUM = 0 MAPV = 0; NLFLAG = 0 LIST = 'Y'; RUNNING = 'N'; SYNTAX = 'Y' DIS FLAG = 0; C LIST = 0; PRINTED = 0 EXTRINSIC = 0; ! NOT OWN OR EXTRINSIC LABEL HEAD = 0; LINE ENTRY = 0 R14 = 0; REALS = 4; LEVEL = 0; FN TYPE = 3 ! '%BEGIN' EFREE <- X'B000'; BASE REG = 9; ILAB = X'FFFF0000' ! ! SET UP THE USER'S GLA ! GLA HEAD = ADDR(RTS(-7)_CODE); GLA = ADDR(RTS(128)_CODE) *L_1,FIXED GLA; *L_2,GLA HEAD; *MVC_0(120,2),0(1) ! SET UP GLA *ST_2,12(2,0) LOAD PERM STRING(GLA) = '*CONSTANTS:'; GLA = GLA+12 ! ! SET UP THE END OF STACK MARKER IN GLA ! ENDOFSTACK == RTS(-4)_ENVIR *L_2,ENDOFSTACK *L_1,68(13) *LA_0,4092(0,0); *SR_1,0 *ST_1,0(2) ! ! NOW SET UP TEXT HEAD HALF WAY DOWN THE FREE STACK ! *AR_1,11 *SRL_1,1(0); ! DIVIDE BY TWO *ST_1,TEXT HEAD ! ! ! A SPACE == RTS(-5)_CODE; END A SPACE == RTS(-5)_GLA A SPACE = STACK+4096; END A SPACE = CODE+K ! ! DEFINE ENTRY POINTS INTO PERM ERROR ROUTINES ETC. ! RTFAULTY = 25<<2+APERM PERM ERROR = APERM+31<<2 ! ! ! MLEVEL = X'FFFF' DIAG BLOCK == RTS(-6)_GLA CODE = CODE+32; ! TO LEAVE A BIT OF SPACE IN CASE OF TROUBLE CODEIN = CODE; CODE HEAD = CODEIN; R10 = CODEIN CODE END = DEC START-16 DIAG VAR == ARRAY(ADDR(DIAG MAP(0)),DIAG MAP FORM) DIAG BASE = 0; ! BASE FOR EXTERNAL DIAG INFO DIAGEND = ADDR(DIAG TAB(0)); DIAG SAVE = DIAG END DIAG PT = DIAG SAVE STACKTOP = STACK REG9 = STACK TOP BLOCK == BLOCK INF(0); BLOCK_TYPE = 0 BLOCK TYPE = 0; BLOCK ENTRY = -1; ! '%BEGIN' ! AREG = ADDR(REG USE(4)) *L_1,AREG; *XC_0(5,1),0(1); ! CLEAR REGUSE ! ! CLEAR THE HASHING AREA FOR NAMES ! *L_1,DICT *LA_2,17 DZER: *XC_0(250,1),0(1) *LA_1,250(1) *BCT_2, ! ! SET UP THE ASL (THIS TAKES TIME !!! ! J = ADDR(LISTS(1))&X'FFFFF0' ASL = ADDR(LISTS(LIST SIZE))&X'FFFFF0'-16 *L_1,J; *LA_2,16; *L_3,ASL; *XC_12(4,1),12(1) 117: *ST_1,28(1); *BXLE_1,2,<117> ! %CYCLE P=J,16,ASL: INTEGER(J+28)=J: %REPEAT ! ! DICT HEAD = ADDR(DICT(0)) DICT FREE = DICT HEAD+4096 DICT MAX = DICTHEAD+8180 CODESTART = CODE HEAD CODE TOP = CODE HEAD A STACK = STACKTOP+128 D C NAMES; ! DECLARE INTRINSIC NAMES SYSOUT = 0; IOUT = 0 ! ! GIVE INTSYSTY ITS PARAMETERS FOR COMMUNICATING BACK HERE ! THESE ARE NOT DONE USING EXTERNALS TO SAVE LODING TIME ! I8INIT(DICTHEAD,ADDR(NLFLAG),ADDR(DIAGPT),ADDR(SYSOUT), %C ADDR(IOUT),GLAHEAD,APERM,RESTART) ! ! DISCRIMINATE AGAINST STUDENTS ! *XC_80(16,11),80(11); ! CLEAR THE BUFFER *MVI_81(11),160; ! SERVICE NUMBER *MVI_95(11),7; ! SFI NUMBER *LD_0,80(11) *LD_2,88(11) SVCX: *SVC_254 *STD_4,80(11) *MVC_STUDENT(1),81(11) *NI_STUDENT,1 ! ! ! COMPILE IN THE INITIAL %BEGIN TO GET THINGS GOING ! CSS(9); COMP MODE = COMP MODE&64; ! LEAVE I/O BIT FOR SETTING SPECS ! INTEGER(CODE HEAD) = 0; ! NOTE: CODEIN=CODEHEAD HERE SO CSS(9) ! WILL HAVE CORRUPTED THIS WORD !!! IOFLAG = IOFLAG&1; ! REMOVE EXTRA BIT SET BY IMPIP %IF RESTART = 0 %START ! ! RESET COMREG(36) TO POINT TO TOP OF USER'S STACK, INSTEAD OF ! THE INTERPRETER'S STACK, TO HELP RECOVER FROM FAILURES ! IN EXTERNAL ROUTINES ! COM36 = COMREG(36); COMREG(36) = STACKTOP %FINISH ! ! THIS CODE IS TO DIRECT RETURNS FROM THE SYSTEM ! MONITOR INTO THE INTERPRETER, INSTEAD OF DIRECT BACK ! TO COMMAND LEVEL. ! *L_3,96(13); ! STOP VECTOR ADDRESS *SLR_1,1 ; ! NO FAULTS TRAPPED *L_2,STACKTOP; ! INITIAL STACK VALUE *STM_1,2,16(3); ! SET UP FOR FIRST ERROR *STM_1,2,0(2); ! SET UP FOR SUBSEQUENT ERRORS ! !****************. ! DIAG PT = DIAG PT-2; SHORTINTEGER(DIAG PT) = 0 ! END OF BASIC DIAGS SIGNAL(1,0,0,J); ! REMOVE 'DIAGS' SIGNAL SO AS TO TRAP ERRORS ! IN EXTERNAL ROUTINES DIAG SAVE = DIAG PT I8DIAG(0) %IF RESTART = 0; ! INITIALIZE DIAGS ! ! NOW SET UP THE DATA FOR DYNAMIC LOADING ! *L_1,DLENV+4; ! @ DLENV(4) *ST_1,D LOAD ENV *STM_4,14,0(1); ! SAVE CONTEXT *LA_1, *ST_1,D LOAD ENTRY *LA_1, *ST_1,MISSING EP ! RESTART = 1; ! SHOW RUNNING ONCE %PRINTTEXT ' IMP Interpreter' %IF STUDENT = 0 %THEN %PRINTTEXT ' Version 8d' %C %ELSE %PRINTTEXT ' Student Version' NEWLINES(2) ! ! GIVE %BEGIN PROMPT ! RIM(0,STRING(ADDR(INITP(0)))); J = NEXTSYMBOL ! TO FORCE IT OUT SKIPSYMBOL %AND J = NEXTSYMBOL %WHILE J = NL ! ! SET UP PROMPT INFO ! P STRING = 'DATA:'; ! IN CASE OF $RESTART INTEGER(STACKTOP+16) = COMREG(50);! TEMP @ CURPROMPT INTEGER(STACKTOP+20) = ADDR(P STRING) ! ! SET TRAP FOR DOUBLE CONTINGENCY ! DCONT: *L_1,DCONTAREA; ! J = ADDR(DCONTAREA(0)) *ST_1,J *LA_15,; ! RETURN ADDRESS FROM DOUBLE CONTINGENCY *STM_4,15,16(1); ! SAVE RECOVERY INFO *MVI_60(1),8; ! SET PROGRAM MASK (I THINK ??) SIGNAL(0,J+16,0,K); ! STACK SIGNAL ! ! RESET DIAGNOSTIC POINTERS & OWN ARRAY INFO ! DIAG PT = DIAG SAVE ! OWN DISP = 0 OWN LIST HEAD = 0 OWN END = END A SPACE OWN TOP = OWN END ! ! ! FIDDLE FACTOR = STUDENT -> SET ERROR ! ! DOUBLE CONTINGENCIES COME HERE ! DCTRAP: *STC_2,WT; ! WEIGHT OF SIGNAL RESET IO LEVEL = 1; ! IN CASE OF TROUBLE %IF WT # 128 %START %PRINTTEXT ' ***** CATASTROPHIC FAILURE'; WRITE(WT,1) %PRINTTEXT ' ***** ' %STOP %IF RESTART = 2 %FINISH %PRINTTEXT ' ' -> DCONT ! ! I8DIAG RETURNS TO HERE AFTER GIVING DIAGNOSTICS FOR ! CONTINGENCIES. ! INT RETURN: *L_1,INT SAVES; ! ADDRESS OF RECOVERY INFO FROM %MONITOR *LM_0,13,0(1); ! RESET REGISTERS -> SET ERROR ! ! TOP LEVEL SIGNALS COME HERE ! ERROR: *ST_1,SIGAREA; ! SAVE THE ADDRESS OF FAILURE SAVE AREA *STC_2,WT; ! SAVE THE WEIGHT *ST_3,INTQ INFO; ! SAVE INTQ SYMBOL (FOR INT:H) *L_1,4(1); ! L = FAILURE ADDRESS *ST_1,FAIL INFO *L_1,INT SAVES *STM_0,13,0(1) RESET IO %AND %PRINTTEXT ' ** CANCEL ** ' %C %AND -> CANCEL %IF WT = 244 -> RELOAD %IF WT = 240; ! RESTART FROM '%ENDOFINT' ! ! EXAMINE THE SIGNAL WEIGHT AND CONVERT IT INTO THE IMP FAULT NUMBER ! %IF RUNNING = 'N' %START %IF WT = 120 %OR WT = 100 %START FAULT(38) INTEGER(SIGAREA+8) = 0; ! CLEAR NEW REG 0 TO PREVENT ! TOO MANY FAULT 38'S INT Q FLAG = 1 -> RESUME COMPILATION %FINISH %IF WT = 132 %OR WT = 128 %START %IF WT = 128 %START %PRINTTEXT ' ' %AND -> CANCEL %IF INTQ SYM = 'H'+32 ! LOWER CASE %PRINTTEXT ' INT:Q ignored ' %FINISH %ELSE %PRINTTEXT ' TIME EXCEEDED (IGNORED) ' INT Q FLAG = 1 -> RESUME COMPILATION %FINISH %FINISH RESET IO %IF RUNNING = 'Y' %AND PERMIT&1 = 0 %START ERRNUM = 255 ERRNUM = 34 %IF WT = 92; ! ADDRESS ERROR ERRNUM = 13 %IF WT = 128; ! INT Q ERRNUM = 17 %IF WT = 104; ! DIVIDE ERROR ERRNUM = 1 %IF WT = 120; ! INTEGER OVERFLOW ERRNUM = 2 %IF WT = 100; ! REAL OVERFLOW ERRNUM = 12 %IF WT = 132; ! TIME EXCEEDED ERRNUM = 29 %IF WT = 136; ! OUTPUT EXCEEDED ERRNUM = 35 %IF WT = 84; ! UNEXPLAINED INTERRUPT %IF WT = 88 %START; ! ILLEGAL OPCODE %IF SPECIAL INT = 0 %THEN ERRNUM = 36 %ELSE %START SPECIAL INT = 0 ERRNUM = 0 %FINISH %FINISH ERRNUM = 18 %IF WT = 144; ! SUBSTITUTE CHAR IN DATA ERRNUM = 37 %IF WT = 152; ! STREAM NOT DEFINED %PRINTTEXT ' ' %AND -> SET ERROR %C %IF WT = 128 %AND (INTQ SYM = 'H' %C %OR INTQ SYM = 'H'+32) ! INT:H I8DIAG(ERRNUM) %IF ERRNUM # 255 %FINISH %IF WT = 140 %START; ! INPUT FILE ENDED I8DIAG(9) %IF RUNNING = 'Y' FAULT(108) CLOSE STREAM(78); CLEAR('ST78') COMPMODE = COMP MODE&B'10111111' -> SET ERROR %FINISH ! ! ALL HAS FAILED, SO SAY WHAT HAS HAPPENED ! ! ! SHOW A SIGNAL OCCURED ! %PRINTTEXT ' * SIGNAL WT' WRITE(WT,1) %PRINTTEXT ' at ' %AND HEX(FAIL INFO) %IF PERMIT&2 # 0 ! ! CALL I8DIAG FOR A MONITOR IF THE SIGNAL CAME FROM THE USER ! NEWLINES(2) %AND I8DIAG(0) %IF RUNNING = 'Y' %AND DUMP = 0 %IF RUNNING = 'N' %START ! ! THE INTERPRETER HAS FAILED !!!!! ! CLOSE OFF ANY OUTSTANDING BLOCKS AND TRY TO CARRY ON SAFELY ! %PRINTTEXT ' in compiler ' FAULT(48) %IF LEVEL > 1; ! JUST FOR FUN CANCEL: ! ENTRY POINT FROM ** CANCEL INTERRUPT %WHILE LEVEL > 1 %CYCLE RP = 0; REC(1) = 5; ! PSEUDO %END C END; ! FORCE AN END JUST IN CASE %REPEAT TIDY STARTS; TIDY LABELS DEFINE RT %IF COMP MODE&16 # 0 DIAG PT = DIAG SAVE %FINISH %PRINTTEXT ' ' -> SET ERROR %IF DUMP = 0 ! ! GIVE A DUMP OF THE CONTEXT OF THE ERROR ! DUMP SIGNAL(FAIL INFO); -> SET ERROR ! ! ! CO-ROUTINE ENTRY POINT FOR S#IMPMON ! EXT BREAK:SET UP MONITOR(0); -> EXT BREAK0 ! ! ! MEP: ! UNSATISFIED ENTRIES COME HERE ! *L_1,12(12); ! POINTER TO NAME *LR_2,11; ! STACK FRAME POINTER *LM_4,14,0(13); ! RESTORE INT ENVIRONMENT *LA_11,64(2); ! TO FREE SPACE *STM_1,2,J; ! REMEMBER THEM PRINTSTRING(' invalid call on '.STRING(J).' ') SPECIAL INT = 1; ! SHOW A FORCED SIGNAL COMING *L_2,K; ! OLD STACK FRAME POINTER *LM_4,14,16(2); ! RESTORE CONTEXT OF CALL ATTEMPT *PUT_0; ! FORCE ILLEGAL OPCODE ! ! DYNAMIC LOAD: ! DYNAMIC REFERENCES COME HERE FOR LOADING *LR_1,11 *LR_2,12 *LM_4,14,0(13) ; ! PICK UP THE INTERPRETER'S CONTEXT *STM_1,2,DR11; ! SAVE PARAMETERS *LA_11,4000(1); ! BUT LEAVE THE STACK ALONE *ST_15,DLRA ; ! REMEMBER THE RETURN ADDRESS ! IOFILE <- STRING(INTEGER(D ENTRY+12)); ! PICK UP THE ROUTINE NAME DLG = D LOAD ENV DLEP = D LOAD ENTRY; ! IN CASE OF OTHER DYNAMICS FDP(LOAD FDP,IOFILE,FDP REF,ADDR(DLC),L) %IF L # 0 %START; ! IF FAILED PRINTSTRING('dynamic loading of '.IOFILE.' fails ') SPECIAL INT = 1; ! SHOW FORCED INT COMING *L_11,DR11; ! RESTORE STACK FRAME *LM_4,14,16(11); ! RESTORE ENTRY CONTEXT *PUT_0; ! FORCE ILLEGAL OPCODE ! %FINISH ! I8DIAG WILL SEND ERRORS MILES AWAY FROM HERE !! L = COMREG(7) CREATE DUMMY REFS(L) %IF L # 0 INTEGER(D ENTRY) = DLC INTEGER(D ENTRY+4) = DLG INTEGER(D ENTRY+8) = DLEP ! FROM NOW ON THE ROUTINE WILL BE ENTRED DIRECTLY *L_11,DR11 *LM_12,15,DLC *BCR_15,14; ! GET INTO IT AT LAST ! !*** END OF DYNAMIC LOADING *** ! ! !*********************************************************************** ! %ROUTINE SIGNAL(%INTEGER EP, PARM, X, %INTEGERNAME FLAG) %RECORD P(AGFM) P_EP = EP P_P1 = PARM P_P2 = X P_FLAG == FLAG AGENCY(2, P) %END %ROUTINE FDP(%INTEGER EP,%STRING(17) S,%INTEGER P1,P2,%INTEGERNAME F) AGENCY(1, RECORD(ADDR(EP))) %END %ROUTINE SEND TO %SHORTROUTINE %INTEGER P, T, L, N, TP, J, M %RECORDNAME BLOCK(RBFM) %INTEGERARRAY NUM, TXT, TL(0 : 255) %CYCLE P = 0,1,255; NUM(P) = -1 %REPEAT P = CODE N = 0 %WHILE INTEGER(P) # 0 %CYCLE N = N+1 BLOCK == RECORD(P) P = BLOCK_LINK T = BLOCK_TEXT L = BLOCK_LENGTH TP = T>>24 FAULT(250) %IF NUM(TP) >= 0 NUM(TP) = N TXT(N) = T; TL(N) = L %REPEAT ! NOW OUTPUT LEVEL 1 DECLARATIONS %CYCLE J = DEC START,1,DEC FILE PRINTSYMBOL(BYTEINTEGER(J)) %REPEAT ! %CYCLE P = 0,1,DEFNUM M = NUM(P) %IF M >= 0 %START %PRINTTEXT ' ' T = TXT(M) %CYCLE J = T,1,T+TL(M)-1 PRINTSYMBOL(BYTEINTEGER(J)) %REPEAT %PRINTTEXT ' ' %FINISH %REPEAT %PRINTTEXT ' %ENDOFFILE ' SELECT OUTPUT(0) CLOSE STREAM(79) WRITE(N,1) %PRINTTEXT ' procedure' %PRINTTEXT 's' %IF N # 1 %PRINTTEXT ' output to file ' PRINTSTRING(IOFILE) NEWLINE %END %ROUTINE LOAD PERM %SHORTROUTINE %INTEGER F, R12, R13, R14 FDP(LOAD FDP,'S#I8PERM',FDP REF,ADDR(R12),F) %IF F # 0 %START %PRINTTEXT 'FAILED TO LOAD PERM'; WRITE(F,1) %PRINTTEXT ' '; %STOP %FINISH *L_1,GLA HEAD *MVC_44(12,1),R12; ! PERM REFERENCE IN GLA APERM = R14 %END %ROUTINE STOP ! COMREG 36 IS USED TO RETURN TO PREVIOUS LEVEL ! FROM THE IMP/IMPS MONITOR COMREG(36) = COM36; ! RESET 'TOP OF STACK' POINTER SIGNAL(1,0,0,J); ! REMOVE MY SIGNAL INFO *LM_4,15,16(9) *BCR_15,15 %END %ROUTINE D C NAMES ! DECLARES COMPILER NAMES E.G. ADDR,PRINT,READ ETC. ! THE INITIAL CALL ON NEW CELL IS TO STOP A DUBIOUS ADDRESS ! BEING PLANTED IN THE INDEX FIELD OF THE FIRST NAME. ! THE FORMAT OF THE NAME LIST IN 'BINAMES' IS :: ! , ,,,....., ! THE LIST IS TERMINATED BY A ZERO NAME NUMBER %SHORTROUTINE %ENDOFLIST %CONSTBYTEINTEGERARRAY BINAMES(0 : 467) = %C 1, 7, 73, 78, 84, 69, 71, 69, 82, 2, 11, 66, 89, 84, 69, 73, 78, 84, 69, 71, 69, 82, 3, 12, 83, 72, 79, 82, 84, 73, 78, 84, 69, 71, 69, 82, 4, 4, 82, 69, 65, 76, 5, 8, 76, 79, 78, 71, 82, 69, 65, 76, 6, 6, 83, 84, 82, 73, 78, 71, 7, 6, 82, 69, 67, 79, 82, 68, 8, 6, 76, 69, 78, 71, 84, 72, 9, 8, 84, 79, 83, 84, 82, 73, 78, 71, 10, 4, 65, 68, 68, 82, 11, 2, 78, 76, 12, 3, 83, 78, 76, 13, 4, 82, 69, 65, 68, 14, 10, 82, 69, 65, 68, 83, 89, 77, 66, 79, 76, 15, 6, 82, 69, 65, 68, 67, 72, 16, 10, 82, 69, 65, 68, 83, 84, 82, 73, 78, 71, 17, 8, 82, 69, 65, 68, 73, 84, 69, 77, 18, 5, 87, 82, 73, 84, 69, 19, 5, 80, 82, 73, 78, 84, 20, 7, 80, 82, 73, 78, 84, 70, 76, 21, 11, 80, 82, 73, 78, 84, 83, 84, 82, 73, 78, 71, 22, 11, 80, 82, 73, 78, 84, 83, 89, 77, 66, 79, 76, 23, 7, 80, 82, 73, 78, 84, 67, 72, 24, 7, 78, 69, 87, 76, 73, 78, 69, 25, 8, 78, 69, 87, 76, 73, 78, 69, 83, 26, 7, 78, 69, 87, 80, 65, 71, 69, 27, 5, 83, 80, 65, 67, 69, 28, 6, 83, 80, 65, 67, 69, 83, 29, 10, 78, 69, 88, 84, 83, 89, 77, 66, 79, 76, 30, 8, 78, 69, 88, 84, 73, 84, 69, 77, 31, 10, 83, 75, 73, 80, 83, 89, 77, 66, 79, 76, 32, 10, 70, 82, 79, 77, 83, 84, 82, 73, 78, 71, 33, 6, 67, 72, 65, 82, 78, 79, 34, 3, 73, 78, 84, 35, 5, 73, 78, 84, 80, 84, 36, 6, 70, 82, 65, 67, 80, 84, 37, 3, 83, 73, 78, 38, 3, 67, 79, 83, 39, 3, 84, 65, 78, 40, 6, 65, 82, 67, 83, 73, 78, 41, 6, 65, 82, 67, 67, 79, 83, 42, 6, 65, 82, 67, 84, 65, 78, 43, 6, 82, 65, 68, 73, 85, 83, 44, 4, 83, 81, 82, 84, 45, 3, 77, 79, 68, 46, 3, 76, 79, 71, 47, 3, 69, 88, 80, 48, 6, 80, 82, 79, 77, 80, 84, 49, 11, 'S', 'E', 'L', 'E', 'C', 'T', 'I', 'N', 'P', 'U', 'T', 50, 12, 'S', 'E', 'L', 'E', 'C', 'T', 'O', 'U', 'T', 'P', 'U', 'T', 51, 11, 'C', 'L', 'O', 'S', 'E', 'S', 'T', 'R', 'E', 'A', 'M', 52, 6, 'R', 'E', 'S', 'U', 'M', 'E', 53, 5, 'D', 'R', 'A', 'I', 'N', 54, 5, 'A', 'R', 'R', 'A', 'Y', 55, 3, 'M', 'O', 'N', 0 %LIST %INTEGER N, A, NP, P, AD; %BYTEINTEGER PACK P = 0; PACK = 0; A = NEW CELL %CYCLE N = BINAMES(P); ! NAME NUMBER A = NEWCELL %AND %RETURN %IF N = 0 P = P+1; ! ONTO THE STRING AD = ADDR(BINAMES(P)); ! POINTER TO STRING FIRST = BYTEINTEGER(AD+1) LAST = BYTEINTEGER(AD+BYTEINTEGER(AD)) NP = FIND(AD); ! LOOK FOR IT (AND FIND FREE SPACE TO PLUG IT) FAULT(255) %AND STOP %IF NP >= 0; ! ALREADY IN !!!!! A = A+8; ! COMPILER NAMES ONLY USE 8 BYTES OF LIST ! SO PACK TWO ENTRIES INTO ONE CELL %IF PACK = 0 %THEN A = NEWCELL-4 PACK = PACK!!1 INTEGER(A+8) = N; ! SET INDEX FIELD TO NAME NUMBER N = DICTHEAD+(\NP); ! ADDRESS OF FREE CELL INTEGER(N) = AD; INTEGER(N+4) = A ! INSERT THE INFO P = P+BYTEINTEGER(AD)+1;! ONTO THE NEXT NAME %REPEAT; ! AND ROUND AGAIN %END %ROUTINE RESET I O IN STREAM = 0 I OUT = 0 PRINTED = 0 I O FLAG = 0 SELECTINPUT(0) SELECTOUTPUT(SYSOUT) %END %ROUTINE DOT NAME %SHORTROUTINE %INTEGER J, K, M, N %STRING (255) PARAM, LINE SAVE ! SET UP AND COMPILE AN EXTERNAL SPEC, AND CALL THE ROUTINE N = REC(RP+3); ! PICK UP NAME POINTER FAULT2(40,N) %AND %RETURN %C %IF LEVEL # 1 %OR FIRST CHAR # OLD TEXT LINE(0) <- LINE LENGTH LINE SAVE = STRING(ADDR(LINE(0))) PARAM = '' PARAM = ' (%STRING(63) S)' %IF REC(RP+4) = 1 M = 150; ! PRESERVE CURRENT ANALYSIS RECORD J = REC(RP+1)+6; ! ROUGH END OF AREC. %CYCLE K = RP,1,J REC(M) = REC(K) M = M+1 %REPEAT TEXTP = ADDR(LINE(150)); ! THIS WILL DO FOR A BUFFER ! NOW PUT IN THE SOURCE TEXT STRING(TEXTP) = '%EXTERNALROUTINESPEC '.STRING( %C INTEGER(DICTHEAD+N)).PARAM.' '.TOSTRING(0) ! ZERO IS THE TERMINATOR FOR 'INPUT SYMBOL' TEXTP = TEXTP+1; ! ONTO TEXT PROPER COMP MODE = COMP MODE!1; ! SHOW INPUT COMING FROM 'TEXTP' COMPILE BLOCK; ! COMPILE THE SPEC COMP MODE = COMP MODE&254; ! JUST IN CASE !!! %RETURN %IF XFLAG # 0; ! ROUTINE NOT LOADED RP = 150; ! BACK FOR THE ROUTINE CALL STRING(ADDR(LINE(0))) = LINE SAVE; ! PRESERVE STRING CONSTANT DEC FLAG = 0; ! PREVENT DUPLICATING THE TEXT FOR THE SPEC CUI(1); ! IT LOOKS LIKE A UI OF TYPE 1 %END %ROUTINE HASH EXPRNS %SHORTROUTINE %INTEGER J, A %BYTEINTEGER REAL %RECORD V(VARFM) FAULT(33) %AND %RETURN %IF LEVEL # 1 %OR CODEIN # CSTART REAL = 0 %UNTIL REC(RP) = 2 %CYCLE COND1 = RP; COND2 = COND1 EXPRN TYPE = COND TYPE RP = COND1 %IF EXPRNTYPE&16 # 0 %START; ! STRING EXPRN C S EXPRN(A) EFREE = EFREE+256; ! PROTECT THE STRING S LOAD(A,1) PLANT(X'4100000B') %FINISH %ELSE %START EXPRN TYPE = B'1100';! SET TO AMBIGUOUS EXPRN(V) %IF EXPRN TYPE = B'1100' %START ! INTEGER LOAD(V,1) PLANT(X'41200001') J = X'41000013' %FINISH %ELSE %START LOAD(V,2) PLANT(X'41100007') REAL = 1 J = X'4100000A' %FINISH PLANT(J) %FINISH RTSAVE(2) PLANT(X'6040B050') %IF REAL # 0 PLANT(X'45FC0000'+23<<2) RP = RP+1 %REPEAT %END %ROUTINE RESTORE ENTRIES %SHORTROUTINE %WHILE ELISTP > 0 %CYCLE RELEASE RT(ENTRY LIST(ELISTP)) ELISTP = ELISTP-1 %REPEAT %END %ROUTINE SKIPEXPRN !* RP SET BEFORE P(EXPRN) RP = RP+1; ! ONTO P(EXPRN) RP = REC(RP+2) %UNTIL REC(RP) = 2; ! HOP OVER (OPERAND) %END %ROUTINE FMESSAGE(%INTEGER N) %SHORTROUTINE %RETURN %IF SYNTAX = 'N' %IF N >= 200 %C %THEN %PRINTTEXT ' (COMPILER OVERWORKED)' %C %ELSE %START N = 0 %IF N > 110; ! ONLY 110 FAULT MESSAGES ! MESSAGE(0) = (UNKNOWN FAULT) PRINTSTRING(' ('.STRING(ADDR(FAULTTEXT(FAULTNO(N)))). %C ')') %FINISH %END %ROUTINE FAULT(%INTEGER N) %SHORTROUTINE %INTEGER M, SPAC, J %BYTEINTEGER S, Q, S OPTION ! ! LIST THE LINE IF IT HAS NOT ALREADY BEEN LISTED ! %IF PRINTED = 2 %AND DEC2 > DEC1 %AND (N # 0 %C %OR SYNTAX = 'N') %START PRINTED = 3 WRITE(LINE NUM,4); SPACES(2) M = DEC1+72-5; M = DEC2 %IF DEC2 < M %CYCLE J = DEC1,1,M-2 S = BYTEINTEGER(J); PRINTSYMBOL(S) %EXIT %IF S = NL %REPEAT NEWLINE %IF S # NL %FINISH %PRINTTEXT '*' %IF COMP MODE&B'01000011' # 0 %OR PRINTED = 3 %START WRITE(LINENUM,3); SPAC = 16;! GIVE LINE NUMBER IN EDIT %FINISH %ELSE SPAC = 12 %IF N = 100 %START; ! ACCESS %PRINTTEXT ' ACCESS ' ACCESS = 1 %RETURN %FINISH FAULTY = 1 %IF N = 0 %START; ! FAULT(0) == SYNTAX S OPTION = SYNTAX SOPTION = 'N' %IF LINELENGTH-LINE START+SPAC > 70 %PRINTTEXT ' SYNTAX ' Q = 0; ! FLAG TO COUNT QUOTES ! NOW OUTPUT RECONSTRUCTED LINE %CYCLE J = LINE START,1,LINE LENGTH S = LINE(J) Q = Q!!1 %IF S = '''' PRINTSYMBOL(S) %IF S OPTION = 'Y' NEWLINE %AND %EXIT %C %IF S = ';' %AND J >= SM %AND Q = 0 %REPEAT %IF S OPTION = 'Y' %START SPACES(SM+SPAC-LINE START); %PRINTTEXT '!' %FINISH LINE ENTRY = 0 LINE ENTRY = J+2 %IF S = ';';! MORE ON THIS LINE %FINISH %ELSE %START %PRINTTEXT ' FAULT' M = !N!; ! N < 0 => NO NEWLINE WRITE(M,3) %IF SYNTAX = 'N' %OR M > 100 %PRINTTEXT ' disaster ' %IF M > 100 FMESSAGE(M) ! NOW PREVENT FAULTY ROUTINES FROM BEING CALLED RTS(BLOCK ENTRY)_EP = RT FAULTY %C %IF BASE REG # 9 %AND COMP MODE&68 # 0 %FINISH NEWLINE %UNLESS N < 0 PRINT USE %AND UN CLAIM %IF N >= 200 *XC_GPR1(8),GPR1; ! FORGET THEM JUST IN CASE !!!! %END %ROUTINE FAULT2(%INTEGER N, NAME) FAULT(-N) ! OUTPUT THE TEXT FOR 'NAME' SPACES(2) PRINTSTRING(STRING(INTEGER(NAME+DICTHEAD))) NEWLINE %END %INTEGERFN R V LEN(%INTEGER PT) ! THIS ROUTINE SEARCHES FOR THE RECORDFORMAT WITH A ! LIST OF 'PT', AND FROM IT EXTRACTS THE LENGTH OF ! EACH RECORD WITH THAT FORMAT ! VERY NASTY !! BUT ONLY USED FOR RECORD1 = RECORD2 %SHORTROUTINE %INTEGER N; %INTEGERNAME P %RECORDNAME V(VARFM) PT = PT&X'FFFFFF'; ! REMOVE TIDY BIT !!!! %CYCLE N = DICTHEAD,8,DICTHEAD+4088 P == INTEGER(N+4) %IF P # 0 %START V == RECORD(P) %CYCLE %RESULT = V_ADDRESS %C %IF V_TYPE = 31 %AND V_INDEX = PT %EXIT %IF V_LINK = 0 V == RECORD(V_LINK) %REPEAT %FINISH %REPEAT %RESULT = 0 %END %ROUTINE C B PAIR(%INTEGERNAME L, R) ! EVALUATES THE BOUND PAIR FOR SWITCHES AND ARRAYS IN RECORDS !* RP BEFORE P(CBPAIR) %SHORTROUTINE %BYTEINTEGER P P <- REC(RP+2); ! PLUS RP = RP+3; ! SKIP TYPE GET4(L) %IF P = 2 %THEN L = -L %ELSE %START %IF P = 3 %THEN L = \L %FINISH P <- REC(RP+1); RP = RP+2; GET4(R) %IF P = 2 %THEN R = -R %ELSE %START %IF P = 3 %THEN R = \R %FINISH R = L %AND FAULT(45) %UNLESS L <= R %END %ROUTINE SET UAV PAT(%INTEGER BYTES, AD1) %SHORTROUTINE %INTEGER A %IF UAV FLAG # 0 %AND T UAV # 0 %AND BYTES > 2 %START DSI(X'92',AD1,128) BYTES = BYTES-1; A = BYTES>>8; BYTES = BYTES&255 %WHILE A > 0 %CYCLE; A = A-1 DSS(X'D2',256,AD1+1,AD1) AD1 = AD1+256 %REPEAT DSS(X'D2',BYTES,AD1+1,AD1) %FINISH %END %INTEGERFN NEW RT ! RETURNS THE NEXT FREE ROUTINE VECTOR IN GLA ! THIS WHOLE AREA (ROUTINE ENTRY INFO ETC.) ! CAN BE IMPROVED BY GIVING EACH 'NORMAL' ROUTINE ! A TWO WORD VECTOR ( ,<@ ROUTINE BLOCK> ) ! OR EVEN JUST ONE WORD WITH THE ENTRY POINT (AS THE ! ADDRESS OF THE BLOCK IS SIMPLY 4 WORDS BACK) ! ANY FOUR WORD VECTORS WOULD THEN BE CLAIMED FROM GLA ! WHEN NEEDED (EXTERNALS AND ROUTINE PARMS) %INTEGER J RTP = (RTP+1)&127; ! WRAP AROUND J = RENTRY(RTP); RENTRY(RTP) = 255 FAULT(109) %IF J = 255; ! ALREADY CLAIMED %RESULT = J %END %ROUTINE VTYPE(%RECORDNAME V) ! SETS UP THE TYPE OF A VARIABLE ! AND DEALS WITH STRING MAX LENGTHS %SHORTROUTINE %RECORDSPEC V(VARFM) %BYTEINTEGER T RP = RP+1; T = REC(RP); ! TYPE T = REALS %IF T = 4; ! REALSLONG %IF T = 6 %START; ! STRINGS RP = RP+1; ! LOOK FOR LENGTH %IF REC(RP) = 2 %THEN SMAX = 0 %ELSE %START RP = RP+1; GET4(SMAX); ! ALSO SKIPPING TYPE SMAX = 0 %AND FAULT(70) %IF SMAX > 255 ! TOO BIG %FINISH %FINISH %ELSE SMAX <- VBYTES(T) V_LENGTH <- SMAX V_TYPE <- TYPE CODE(T) DIAG FLAG = V_TYPE DIAG FLAG = DIAG FLAG!128 %IF T = 6 %END %ROUTINE QNAME(%RECORDNAME V) ! SETS UP FLAGS FOR '%ARRAYNAME':'%NAME': %SHORTROUTINE %RECORDSPEC V(VARFM) %BYTEINTEGER F, T RP = RP+1; T <- REC(RP) %IF EXTRINSIC = 1 %START FAULT(46) %UNLESS T = 3 T = 2 %FINISH %IF T = 1 %START; ! %ARRAYNAME F = B'10111'; DIAGFLAG = 0 V_LENGTH = 16; UAV FLAG = 0 %FINISH %ELSE %START F = 1; ! (NULL) %IF T = 2 %START; ! %NAME F = B'10011'; DIAGFLAG = DIAG FLAG!128 SMAX = 0; V_LENGTH = 4 %FINISH %FINISH V_FORM = T<<5!F %END %ROUTINE RT(%RECORDNAME V) %SHORTROUTINE %RECORDSPEC V(VARFM) V_FORM = B'1000'; ! CHANGED FROM B'1001' FOR FN = 0 ?? RP = RP+1; RTYPE <- REC(RP) ! RTYPE 1 - %ROUTINE ! 2 - %FN/%MAP ! 3 - %PREDICATE %IF RTYPE = 1 %THEN V_TYPE = 15 %ELSE %START %IF RTYPE = 3 %THEN V_TYPE = 14 %ELSE %START VTYPE(V) RP = RP+1 %IF REC(RP) = 2 %THEN V_FORM = V_FORM!2 ! SET %NAME %FINISH %FINISH %IF RTYPE = 2 %AND V_FORM&2 # 0 %C %THEN V_FORM = V_FORM!224 %ELSE V_FORM = V_FORM!96 RTYPE = RTYPE+3 %END %ROUTINE D DEC(%INTEGER N, AD, L, MODE) ! FILLS IN THE HEADER OF A STRING OR RECORD WITH THE ! ADDRESS OF THE FREE SPACE, AND UPDATES THE POINTER ! INTO THAT SPACE ! AS THE DYNAMIC STACK IS USED BY THE COMPILATION PROCESS ! ALL DATA ON IT MUST BE VOLATILE. THEREFORE D DEC ! WILL TAKE SPACE FROM THE ARRAY SPACE IF THE DECLARATION ! IS AT LEVEL 1 (BASIC LEVEL) %SHORTROUTINE %INTEGER REG, RLEN, LENGTH, LIMIT, UAD, LAD %BYTEINTEGER LEN, FLAG %IF LEVEL = 1 %START; ! USE ARRAY SPACE PLANT(X'584D0000'+8<<2); REG = 4 FLAG = 1; LIMIT = 9<<2; UAD = X'4000' %FINISH %ELSE %START; ! USE THE STACK REG = 11; FLAG = 0; LIMIT = 15<<2; UAD = X'B000' %FINISH LEN = 0 %IF MODE = 0 %THEN MODE = L-1 %AND LEN = 1 LENGTH = N*L; RLEN = (LENGTH+3)&(\3) UAV FLAG = UAV FLAG!128 SET UAV PAT(RLEN,UAD) %IF TUAV # 0 UAV FLAG = UAV FLAG&127 %CYCLE N = 1,1,N DRX(X'50',REG,0,AD) %IF LEN = 1 %START DSI(X'92',AD,MODE) DSS(X'D2',2,REG<<12,X'D000'!22<<2) %IF TUAV # 0 %FINISH LAD = CODEIN DRX(X'41',REG,REG,L) ! TEST EXCESS BLOCKS DRX(X'59',REG,13,LIMIT); PLANT(X'472C0000'+22<<2) AD = AD+4 %REPEAT N = LENGTH&7; ! DOUBLE WORD ALLIGNED ? %IF N # 0 %THEN SHORTINTEGER(LAD+2) <- 8+L-N ! ROUND UP ! UPDATE POINTER INTO ARRAY SPACE %IF FLAG = 1 %THEN PLANT(X'504D0000'+8<<2) %END %ROUTINE C NAME LIST(%INTEGER NAMES, BYTES) ! COMPILES NAME LISTS PUTTING THE NEW TAGS FOR ! EACH NAME ONTO THEIR RESPECTIVE LISTS IN THE DIRECTORY. ! IT MAY BE POSSIBLE TO COMBINE 'C L NAME LIST' WITH THIS ! ROUTINE WITH VERY LITTLE OVERHEAD. %SHORTROUTINE %INTEGERNAME P %RECORDNAME V(VARFM) %INTEGER NAME, NAMEP, AD, L, UAD1, FLAG %STRING (8) EX NAME UAD1 = NEWNAME_ADDRESS; ! FIRST ADDRESS FOR SETTING UNASSIGNED GLA = (GLA+3)&(\3) %AND BYTES = 4 %IF EXTRINSIC = 1 ! EXTRINSICS ARE INDIRECT %CYCLE NAMES = 1,1,NAMES RP = RP+1; NAME = REC(RP); NAMEP = NAME+DICTHEAD P == INTEGER(NAMEP+4) %IF P # 0 %START %IF BYTEINTEGER(P+4) = LEVEL %C %THEN FAULT2(7,NAME) %AND -> E1 %FINISH %IF EXTRINSIC = 0 %THEN AD = NEWNAME_ADDRESS %C %ELSE %START AD = X'D000'!(GLA-GLA HEAD) NEW NAME_ADDRESS <- AD %IF EXTRINSIC = 1 %START EX NAME <- STRING(INTEGER(DICTHEAD+NAME)) INTEGER(GLA) = 0; ! JUST IN CASE FDP(DATA FDP,EXNAME,FDP DATA REF,GLA,FLAG) ! LOOK UP NAME %IF FLAG # 0 %START PRINTSTRING('* CANNOT LOAD '.EX NAME.' ') -> E1 %FINISH BYTEINTEGER(GLA) <- FMLEN; ! STRINGS ?? FLAG = COMREG(7); ! UNSAT. REF LIST CREATE DUMMY REFS(FLAG) %IF FLAG # 0 %FINISH GLA = GLA+BYTES %FINISH V == RECORD(NEW CELL) V = NEWNAME NEWNAME_ADDRESS = NEWNAME_ADDRESS+BYTES %C %IF EXTRINSIC = 0 V_LINK = P; P = ADDR(V); ! LINK IN NAME SET DIAG(AD,NAME) %UNLESS DIAGFLAG = 0 E1: %REPEAT L = NEWNAME_ADDRESS-UAD1 %IF EXTRINSIC # 0 %THEN NEWNAME_ADDRESS <- UAD1 %C %ELSE SET UAV PAT(L,UAD1) %END %ROUTINE C L NAME LIST(%INTEGER BYTES) %SHORTROUTINE ! COMPILES A LINKED NAME LIST FOR ROUTINES AND RECORD FORMATS !* RP BEFORE LENGTH OF NAMELIST !* 'LIST HEAD' == HEAD OF LIST !* 'LIST END' == END OF LIST ! %RECORDNAME P(VARFM) %INTEGER NAME, PT, NAMES, AD, TNAME RP = RP+1 %CYCLE NAMES = RP+1,1,REC(RP)+RP NAME = REC(NAMES) TNAME = NAME!NEWNAME_DIMENSION&3 SHORTINTEGER(ADDR(NEWNAME_LEVEL)) <- TNAME %IF FPMODE = 1 %START; ! FORMAT SO CHECK FOR DUPLICATION PT = LIST HEAD %WHILE PT # 0 %CYCLE P == RECORD(PT) %IF SHORTINTEGER(ADDR(P_LEVEL)) = TNAME %START FAULT2(7,NAME); -> NOUT;! DON'T RE-DECLARE IT %FINISH PT = P_LINK %REPEAT %FINISH P == RECORD(NEW CELL) P = NEWNAME LIST END = ADDR(P); LIST END == P_LINK; LIST END = 0 AD = NEWNAME_ADDRESS NEWNAME_ADDRESS <- AD+BYTES SET DIAG(AD,NAME) %UNLESS DIAGFLAG = 0 %OR SPEC # 0 NOUT: %REPEAT RP <- NAMES %END %ROUTINE DECLARE ! STRINGS (AND RECORDS) CAUSE PROBLEMS AS THERE ! ARE TWO TYPES OF STRING TYPE VARIABLE ! STRINGS DECLARED BY %STRING(8) S ARE ACCESSED INDIRECTLY ! THROUGH A ONE WORD HEADER, BUT STRING PARAMETERS ! AND STRINGS IN RECORDS ARE ACCESSED DIRECTLY ! I.E. ADDR(STRING) == *L_1,STRING ! ADDR(STRING PARM) == *LA_1,STRING ! AT THE MOMENT THIS IS FRIGGED BY A BIT IN FLAGS ! BUT A BETTER SOLUTION WOULD BE TO MODIFY 'LOAD ADDR' ! TO LOOK AFTER IT. %SHORTROUTINE %INTEGER J, L, M, N NEWNAME_LEVEL = LEVEL FAULT(40) %AND -> 1 %IF COMP MODE&B'101000' # 0 DEC FLAG = 1; ! SAVE ANY LEVEL 1 DECS RP = RP+1; J = REC(RP) %IF J = 1 %START; ! SCALARS QNAME(NEW NAME) DIAG FLAG = 0 %IF NEWNAME_TYPE = 7 ! RECORDS L = 3 %IF NEWNAME_FORM&2 = 0 %THEN L = ROUND(NEWNAME_TYPE) DISP = (DISP+L)&(\L); NEWNAME_ADDRESS = DISP RP = RP+1; N = REC(RP);! NUMBER OF NAMES J = NEW NAME_LENGTH; ! LENGTH OF EACH ITEM %IF NEW NAME_TYPE = B'10000' %C %AND NEWNAME_FORM&4 = 0 %START ! STRINGS L = 0 %IF NEWNAME_FORM&2 = 0 %START FAULT(70) %AND -> 1 %IF J = 0 L = J+1; ! TOTAL LENGTH, STRING+LENGTH BYTE %FINISH NEWNAME_LENGTH = 0 M = NEWNAME_ADDRESS UAVFLAG = 0 %IF L # 0; C NAME LIST(N,4) %IF L # 0 %START PUT LINE D DEC(N,M,L,0); ! CLAIM SPACE OFF THE STACK %FINISH %FINISH %ELSE %START %IF NEWNAME_TYPE = 7 %AND NEWNAME_FORM&2 = 0 %START M = NEWNAME_ADDRESS UAV FLAG = 0 C NAMELIST(N,4) PUT LINE D DEC(N,M,FMLEN,1) %FINISH %ELSE C NAME LIST(N,J) %FINISH DISP = NEW NAME_ADDRESS %FINISH %ELSE PUT LINE %AND C A DECLN UAV FLAG = 0 EXTRINSIC = 0 1: %END %ROUTINE COMP P LIST(%INTEGER NEW, OLD) %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE COMPARES THE TWO LINKED NAME LISTS SET UP * !* BY 'C RFM DEC'. THE OLD LIST ('OLD') IS DESTROYED. * !* * !************************************************************* ! %RECORDNAME NL, OL(VARFM) %INTEGER NP, F %BYTEINTEGER DEST DEST = 0 NP = NEW; DEST = 1 %IF NP > 0; NEW = !NEW! NL == RECORD(NEW); OL == RECORD(OLD) %WHILE NEW # 0 # OLD %CYCLE NL == RECORD(NEW); OL == RECORD(OLD) SHORTINTEGER(ADDR(OL_LEVEL)) = SHORTINTEGER(ADDR(NL_ %C LEVEL)) %IF DEST # 0 ! COPY NAME INFO NEW = NL_LINK; OLD = OL_LINK FAULT(9) %IF NL_TYPE # OL_TYPE %C %OR NL_FORM # OL_FORM %OR NL_LENGTH # OL_LENGTH %REPEAT %IF NEW # OLD %START F = 8; F = 10 %IF NEW = 0 FAULT(F) %FINISH %IF DEST # 0 %START; ! DESTROY NEW LIST NL_LINK = ASL; ASL = NP %FINISH %END %ROUTINE DEC FP LIST(%INTEGER HEAD) %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE DECLARES THE LINKED NAME LIST SET UP * !* BY 'C FP DEFN'. DUPLICATED NAMES ARE NOT REDECLARED. * !* * !************************************************************* ! %INTEGER BASE, NAME, NAMEP %INTEGERNAME PT %RECORDNAME PARM, P(VARFM) BASE = BASE REG<<12 %WHILE HEAD # 0 %CYCLE P == RECORD(HEAD) NAME = SHORTINTEGER(ADDR(P_LEVEL))&X'FFFC' ! & OFF DIM NAMEP = NAME+DICTHEAD PT == INTEGER(NAMEP+4) %IF PT # 0 %AND BYTEINTEGER(PT+4) = LEVEL %C %THEN FAULT2(7,NAME) %ELSE %START PARM == RECORD(NEW CELL) PARM = P PARM_LEVEL = LEVEL ! CHANGE BASE FROM R11 PARM_ADDRESS <- PARM_ADDRESS&X'FFF'!BASE PARM_LINK = PT; PT = ADDR(PARM) %FINISH HEAD = P_LINK; ! ONTO NEXT NAME %REPEAT %END %ROUTINE C REC DEC(%INTEGER FLAG) %SHORTROUTINE %INTEGER NAME, FNAME, FORMAT %INTEGERNAME PT %RECORDNAME HEAD(VARFM) %SWITCH RTYPE(1 : 4) SPEC = 1; ALLIGNMENT = 0 -> RTYPE(FLAG) ! RTYPE(1): ! '%FORMAT'(NAME)'('(RFDEC)(REST OF RFDEC')')' ! RP = RP+1; NAME = REC(RP) PT == INTEGER(NAME+DICTHEAD+4) %IF PT # 0 %AND BYTEINTEGER(PT+4) = LEVEL %START FAULT2(7,NAME); -> 1 %FINISH HEAD == RECORD(NEW CELL) HEAD_TYPE = 31; ! '%FORMAT' HEAD_LEVEL = LEVEL FPMODE = 1; CFPDEFN(HEAD) HEAD_DIMENSION = ALLIGNMENT FORMAT = (NEWNAME_ADDRESS+ALLIGNMENT)&(\ALLIGNMENT) HEAD_ADDRESS <- FORMAT HEAD_LINK = PT; PT = ADDR(HEAD) TIDY(PT) %IF FAULTY # 0 %AND LEVEL = 1 -> 1 ! RTYPE(2): ! '%SPEC'(HOLE)(ENAME'')'(' (MARK)(NAME) ')' ! RP = RP+1; FNAME = REC(REC(RP)) RT2: FORMAT = GET FORMAT(FNAME) -> 1 %IF FORMAT = 0 FORMAT = INTEGER(FORMAT+8);! F-LIST RP = RP+1; VNAME = REC(RP) HEAD == RECORD(GETNAME(VNAME)) RP = RP+1 %IF REC(RP) = 1 %START; ! '_(NAME)' RP = RP+1; VNAME = REC(RP) %IF HEAD_TYPE # 31 %THEN FAULT2(63,VNAME) %AND -> 1 HEAD == RECORD(ENAME(HEAD_INDEX)) %FINISH %ELSE %START %IF HEAD_TYPE = 31 %THEN FAULT2(64,VNAME) %AND -> 1 %FINISH %IF HEAD_TYPE # 7 %THEN FAULT2(63,VNAME) %AND -> 1 BYTEINTEGER(ADDR(FORMAT)) <- BYTEINTEGER(ADDR(FORMAT))!128 ! TO FOOL 'TIDY' HEAD_INDEX = FORMAT HEAD_FLAGS = HEAD_FLAGS&B'11111110' -> 1 ! RTYPE(3): ! (HOLE)(DECLN)'(' (MARK)(NAME) ')' ! RP = RP+1; FNAME = REC(REC(RP)) RT3: FORMATP = GET FORMAT(FNAME); -> 1 %IF FORMATP = 0 FMLEN = SHORTINTEGER(FORMATP); ! LENGTH OF EACH RECORD FLAG = BYTEINTEGER(FORMATP+5); ! ALLIGNMENT FORMATP = INTEGER(FORMATP+8); ! FORMAT LIST BYTEINTEGER(ADDR(FORMATP))<-BYTEINTEGER(ADDR(FORMATP))!128 ! TO FOOL 'TIDY' NEWNAME_TYPE = B'111' NEWNAME_FLAGS = 0 NEWNAME_INDEX = FORMATP; ! POINTER INTO FORMAT LIST NEWNAME_DIMENSION = 0 DIAG FLAG = 0; UAV FLAG = 15 DISP = (DISP+FLAG)&(\FLAG);! TO CORRECT BOUNDARY DECLARE; ! DECLARE RECORDS -> 1 ! RTYPE(4): ! NEW FORMAT RECORDS !!! ! RP = RP+1; FNAME = REC(RP); ! PICK UP NAME RP = RP+1 -> RT2 %IF REC(RP) = 1; ! '%SPEC' -> RT3; ! (DECLN) 1: %END %ROUTINE C FP DEFN(%RECORDNAME HEADER) %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE COMPILES FORMAL PARAMETER LISTS FOR BOTH * !* RECORDS AND ROUTINES. FPDELIM 5,6 ARE ONLY FOUND IN * !* RECORDS AND FPDELIM 1 CAN NEVER OCCUR IN RECORDS * !* (IT CORRESPONDS TO A BIP. (DUMMY) WHICH ALWAYS FAILS. * !* * !************************************************************* ! %RECORDSPEC HEADER(VARFM) %INTEGER L, U, N, NP, A, STR %IF FPMODE = 0 %START RP = RP+1 %IF REC(RP) = 2 %START HEADER_INDEX = 0; NEWNAME_ADDRESS <- 64 %RETURN %FINISH %FINISH HEADER_FORM = HEADER_FORM!8; ! SET INDEX LIST BIT %SWITCH FPDELIM(1 : 7) LIST HEAD == HEADER_INDEX LIST END == LIST HEAD; LIST END = 0 NEWNAME_FLAGS = 0; NEWNAME_DIMENSION = 0 NEWNAME_ADDRESS <- X'B040' %IF FPMODE # 0 %THEN NEWNAME_ADDRESS <- 0 MORE: NEWNAME_INDEX = 0; RP = RP+1; -> FP DELIM(REC(RP)) ! FPDELIM(2): ! (TYPE)(%QNAME)(NAME LIST) ! VTYPE(NEWNAME); QNAME(NEWNAME) NEWNAME_FLAGS = B'10000100' DIAG FLAG = DIAG FLAG&B'01111111' %IF NEWNAME_FORM&2 = 0 STR = -1; STR = 0 %IF NEWNAME_TYPE&B'10000' # 0 ! STRING L = 3 %IF NEWNAME_FORM&2 = 0 %THEN L = ROUND(NEWNAME_TYPE)&STR ALLIGNMENT = ALLIGNMENT!L NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+L)&(\L) NEWNAME_FLAGS = B'10000100' %IF NEWNAME_FORM&16 # 0 %C %THEN NEWNAME_FLAGS = B'01000100' L = NEWNAME_LENGTH %IF STR = 0 %START %IF NEWNAME_FORM&2 = 0 %START FAULT(70) %IF L = 0 L = L+1 %FINISH %ELSE %START NEWNAME_FLAGS = NEWNAME_FLAGS&B'11111011' NEWNAME_LENGTH = 0 %FINISH %FINISH C L NAMELIST(L); -> NEXT ! FPDELIM(1): ! (RT)(NAME')(NAMELIST) ! RT(NEWNAME); U = NEW RT; DIAGFLAG = 0 RP = RP+1; ! SKIP (NAME') ELISTP = ELISTP+1; ENTRY LIST(ELISTP) <- U NEW NAME_DIMENSION <- U NEWNAME_FORM = NEWNAME_FORM!16 NEWNAME_FLAGS = B'01111101'; ! NO '%SPEC' ALLIGNMENT = ALLIGNMENT!3 NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+3)&(\3) C L NAMELIST(4) -> NEXT ! FPDELIM(7): ! NEW FORMAT SCALAR RECORDS ! NP = RP+1; RP = NP -> FP6 ! FPDELIM(6): ! SCALAR RECORD ! RP = RP+1; NP = REC(RP); ! HOLE FP6: N = GET FORMAT(REC(NP)); -> RFAIL %IF N = 0 L = BYTEINTEGER(N+5); ! ALLIGNMENT FMLEN = SHORTINTEGER(N) A = INTEGER(N+8) BYTEINTEGER(ADDR(A)) <- BYTEINTEGER(ADDR(A))!128 RFAIL: NEWNAME_TYPE = 7 NEWNAME_INDEX = A NEWNAME_DIMENSION = 0 ALLIGNMENT = ALLIGNMENT!L NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+L)&(\L) RP = RP+1 %IF REC(RP) = 1 %START NEWNAME_FORM = B'1010001' DEC CONST ARRAY(FMLEN) %FINISH %ELSE %START NEWNAME_FORM = B'0110001' NEWNAME_FLAGS = B'10111100' C L NAMELIST(FMLEN) %FINISH RP = NP %IF NP > RP -> NEXT ! FPDELIM(3): ! RECORD(ARRAY')'%NAME' ! DIAG FLAG = 0 RP = RP+1 %IF REC(RP) = 1 %START; ! %ARRAY L = 16; NEWNAME_FORM = B'0110111' %FINISH %ELSE %START L = 4; NEWNAME_FORM = B'1010011' %FINISH NEWNAME_TYPE = 7; NEWNAME_FLAGS = B'01000101' ! NO %SPEC ALLIGNMENT = ALLIGNMENT!3 NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+3)&(\3) C L NAMELIST(L); -> NEXT ! FPDELIM(4): ! '%NAME'(NAMELIST) ! NEWNAME_FLAGS = B'01001000' DIAG FLAG = 0 NEWNAME_TYPE = 13; NEWNAME_FORM = 18 ALLIGNMENT = ALLIGNMENT!3 NEWNAME_ADDRESS <- (NEWNAME_ADDRESS+3)&(\3) C L NAMELIST(8) -> NEXT ! FPDELIM(5): ! (TYPE)'%ARRAY'(NAMELIST)(CBPAIR)(R SW LIST') ! ALLIGNMENT = ALLIGNMENT!7 VTYPE(NEWNAME); DEC CONST ARRAY(NEWNAME_LENGTH) ! NEXT: RP = RP+1; RP = RP+1 %AND -> MORE %IF REC(RP) = 1 %END %ROUTINE C RFM DEC ! COMPILES A ROUTINE DEFINITION OR SPEC. %SHORTROUTINE %RECORDNAME RTINF(RTFM) %INTEGER RTP %BYTEINTEGER EXTERNAL, SPECD, FLAG, RFM TYPE %INTEGER NAMEP, A, L, PT %INTEGERNAME P %RECORDNAME SPHEAD, HEAD(VARFM) %INTEGER XPT %STRING (8) XNAME FAULT(40) %AND COMPMODE = COMPMODE!128 %C %IF COMPMODE&8 # 0 %OR (MON LOCK # 0 %AND HALT # 7) RP = RP+1; EXTERNAL <- REC(RP) A = NEW CELL; HEAD == RECORD(A) FPMODE = 0; SPECD = 0; FLAG = 0 RT(HEAD); RFM TYPE = R TYPE RP = RP+1; SPEC = (2-REC(RP))<<1 %IF SPEC = 0 %AND EXTERNAL # 4 %THEN EXTERNAL = 4 ! IGNORE EXTERNAL/SYSTEM/DYNAMIC RP = RP+1; RTNAME = REC(RP); NAMEP = RTNAME+DICTHEAD P == INTEGER(NAMEP+4) %IF P # 0 %AND BYTEINTEGER(P+4) = LEVEL %START SPHEAD == RECORD(P) %IF SPHEAD_TYPE # HEAD_TYPE %C %OR SPHEAD_FORM # HEAD_FORM %OR SPEC # 0 %C %OR SPHEAD_FLAGS&2 = 0 %START FAULT2(7,RTNAME) %IF SPEC # 0 %START INTEGER(A+12) = ASL; ASL = A ! RECLAIM CELL -> 1; ! GET OUT QUICK %FINISH COMP MODE = COMP MODE!128 %FINISH %ELSE %START SPECD = 1; PT = P; P = SPHEAD_LINK %FINISH %FINISH %IF SPECD = 0 %THEN RTP = NEW RT %C %ELSE RTP = SPHEAD_DIMENSION MONNAME(RTP) = RTNAME; ! SAVE NAME FOR MONITORING HEAD_ADDRESS <- RTP<<4+RTBASE HEAD_DIMENSION = RTP; ! SAVE ENTRY INDEX HEAD_LEVEL = LEVEL; HEAD_FLAGS <- SPEC!B'00010000' %IF SPEC = 0 %START %IF LEVEL # 1 %START L = FORWARD REF(15) %FINISH %ELSE PLANT(X'07FC');! TO SKIP HEADER %IF BASEREG = 9 %C %THEN BLOCKNAME = NAMEP %AND BLOCKENTRY = RTP NEW BLOCK(RFM TYPE) ELISTP = ELISTP+1 ENTRY LIST(ELISTP) <- RTP; ! STACK ENTRY INFO EFREE = X'B000' FN TYPE = HEAD_TYPE; FN TYPE 2 = FN TYPE FN TYPE = B'100' %IF HEAD_FORM&2 # 0 ! MAP BLOCK_AD = L %FINISH C FPDEFN(HEAD) HEAD_LINK = P; P = A RTINF == RTS(RTP); RTINF_EP = PERM ERROR %IF EXTERNAL # 4 %START HEAD_FLAGS = HEAD_FLAGS!!B'00110000' XNAME <- STRING(INTEGER(NAMEP)) XNAME <- 'S#'.XNAME %IF EXTERNAL = 2 %AND STUDENT = 0 XPT = ADDR(RTINF_CODE) INTEGER(XPT+4) = D LOAD ENV INTEGER(XPT+8) = D LOAD ENTRY; ! IN CASE OF DYNAMICS FDP(LOAD FDP,XNAME,FDP REF,XPT,XFLAG) L = COMREG(7); ! UNSAT ENTRY POINT LIST CREATE DUMMY REFS(L) %IF L # 0 %IF XFLAG # 0 %START PRINTSTRING('* CANNOT LOAD '.XNAME.' ') TIDY(P) %FINISH %ELSE DEC FLAG = 1 HEAD_FLAGS = HEAD_FLAGS&B'11111101' -> 1 %FINISH %IF SPECD = 1 %START; ! SPEC WAS GIVEN, SO COMPARE COMP P LIST(HEAD_INDEX,SPHEAD_INDEX) HEAD_INDEX = SPHEAD_INDEX; ! PRESERVE OLD LIST SPHEAD_LINK = ASL; ASL = PT;! DESTROY SPEC LIST %FINISH DEC FLAG = SPEC RTINF_CODE = APERM; RTINF_GLA = GLA HEAD %IF SPEC = 0 %START; ! THIS ISN'T A SPEC ACCESS = 1 DEC FP LIST(HEAD_INDEX);! DECLARE THE PARAMETERS RTINF_EP = CODEIN; ! SET THE ENTRY POINT PLANT(X'50FB003C'); DRR(X'18',BASE REG,11) PLANT(X'41BB0040'); ! AT LEAST NEW DIAG(BASE REG<<12) LINE NUM = LINE NUM!X'80000000'; ! TO FORCE OUT DIAGS DIAGS = DIAGS!4 NASTY = 1; PUT LINE DIAGS = DIAGS&3 LINE NUM = LINE NUM&X'7FFFFFFF'; ! REMOVE TOP BIT ! SET UP CODE ADDRESSABILITY PLANT(X'45AC0000'!24<<2); ! EXCESS BLOCKS & SETS R10 R10 = CODEIN ! SET LOCALS TO THE END OF THE PARAMETERS DISP = NEWNAME_ADDRESS&X'FFF'!BASEREG<<12 MAX DISP = DISP BLOCK TYPE = RFM TYPE BLOCKTYPE = BLOCKTYPE!128 %IF HEAD_FORM&2 # 0 ! MAP %FINISH 1: %END %ROUTINE C A DECLN %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE DUMPS CODE TO SET UP THE DOPE VECTOR * !* FOR A LIST OF ARRAYS. THE D.V. IS PUT ONTO THE STACK * !* AT 'EFREE'. IF THE ARRAY IS AT BASIC LEVEL, PERM 26,27 * !* ARE USED TO RELOCATE THE D.V. AND ARRAY SPACE AT THE * !* END OF THE STACK. * !* * !************************************************************* ! !* RP ON P(ADECLN) %INTEGER A, N, NP, D, AD, DIM, DVEC, HEADER %RECORD DV(VARFM) %BYTEINTEGER STFLAG, FORMAT DEC NEWNAME_FORM = B'111'; STFLAG = NEWNAME_TYPE RP = RP+1; FORMAT DEC = REC(RP); ! ARRAY FORMAT ? NEWNAME_TYPE = NEWNAME_TYPE!128 %IF FORMAT DEC = 1 DEC1: NP = RP+2; N = REC(NP); ! NUMBER OF NAMES RP = NP+N+1; ! ONTO P(BPLIST) DIM = 0; ! DIMENSION ! NOW COUNT THE DIMENSION ! THIS HAS TO BE DONE HERE ELSE ARRAY A(4096:5112) WILL ! HAVE ITS CONSTANT TABLE CORRUPTED AT RUN TIME ! AS IT WILL BE OVERLAID BY THE DOPE-VECTOR A = RP; ! REMEMBER FOR LATER %UNTIL REC(RP) = 2 %CYCLE SKIP EXPRN; SKIP EXPRN; DIM = DIM+1 RP = RP+1; ! ON PAST (NULL R EXPRN) %REPEAT RP = A; ! RESTORE IT %IF DIM > 6 %START FAULT(37) %RETURN %IF LEVEL = 1 %FINISH %IF LEVEL = 1 %START GLA = (GLA+3)&(\3) EFREE <- GLA-GLAHEAD+X'D004' GLA = GLA+DIM*12+4; ! BUMP IT UP PAST DOPE VECTOR %FINISH %ELSE EFREE <- X'B004' DVEC = EFREE-4 DV_ADDRESS <- EFREE; ! ADDRESS OF DOPE-VECTOR DV_TYPE = B'100' DV_FORM = 1 DV_FLAGS = 0 DV_INDEX = 0 ASSOP = 2; ! FOR ASSIGN %UNTIL REC(RP) = 2 %CYCLE ASSIGN(DV,2); EFREE = EFREE+4; DV_ADDRESS <- EFREE ASSIGN(DV,2); EFREE = EFREE+8; DV_ADDRESS <- EFREE RP = RP+1 %REPEAT FMLEN = FMLEN+1 %IF STFLAG = B'10000' ! STRINGS PLANT(X'41000000'+FMLEN) PLANT(X'50000000'!DVEC&X'FFFF') DSI(X'92',DVEC+1,DIM) DRX(X'41',2,0,DVEC); ! PICK UP THE ADDRESS OF THE DOPE VECTOR PLANT(X'45FC0000'+18<<2); ! SET UP DOPE-VECTOR ! ! HEADER IN R0 : R1 : R2 : R3 ! LENGTH OF ARRAY IN R14 ! GLA = GLAHEAD+EFREE&X'FFF' %IF LEVEL = 1 A = (DISP+3)&(\3) AD = 27<<2+X'45FC0000' %IF LEVEL # 1 %THEN AD = 28<<2+X'45FC0000' NEWNAME_DIMENSION <- DIM NEWNAME_INDEX = FORMATP NEWNAME_ADDRESS <- A D = RP RP = NP DIAG FLAG = 0 %CYCLE N = 1,1,N PLANT(AD) %IF FORMAT DEC # 1;! ALLOCATE SPACE HEADER = A PLANT(X'1B011F11') %IF FORMAT DEC = 1 DRX(X'90',0,3,HEADER); ! SET UP HEADER DSI(X'92',HEADER,FMLEN) %IF STFLAG&16 # 0 A = A+16 %REPEAT ! ! LEVEL 1 ARRAYS NEED TO BE ALLOCATED BEFORE THE NAME IS DEFINED ! TO PREVENT 'EXCESS BLOCKS' OR 'ARRAY INSIDE-OUT' FORM ! LEAVING AN INCONSISTENT HEADER ! %IF LEVEL = 1 %START PLANT(X'9201D000'); ! SET FAILURE FLAG BYTEINTEGER(GLAHEAD) = 0; ! CLEAR FAILURE FLAG *BCR_0,0; ! FORCE THE COMPILER TO FORGET EXECUTE CODE; ! DECLARE THE ARRAYS CODEIN = CSTART SHORTINTEGER(CODEIN) = X'05FC' RUNNING = 'N' ! NOW SEE IF THE DECLARATION SUCCEEDED, IF NOT ! OMIT THE SETTING UP OF THE NAME REFERENCE -> 1 %IF BYTEINTEGER(GLAHEAD) = 0 %FINISH UAV FLAG = 0; C NAME LIST(N,16); UAV FLAG = 15 DISP <- A 1: RP = D+1 -> DEC1 %IF REC(RP) = 1 EFREE = X'B000' %END %ROUTINE RELEASE RT(%INTEGER N) %INTEGER J J = RENTRY(RTP); RENTRY(RTP) = N RTP = (RTP-1)&127 FAULT(220) %UNLESS J = 255 %END ! THIS ROUTINE IS USED IN PREFERENCE TO THE EXTERNALROUTINE MOVE ! IN ORDER TO SAVE TIME WHEN LOADING THE INTERPRETER AND ! TO PREVENT MORE PAGES OF MANAGR BEING BROUGHT IN WHEN THE ! ROUTINE IS CALLED. %ROUTINE MOVE(%INTEGER L, F, T) %CONSTINTEGER CC = 256 *LM_1,3,L M1: *C_1,CC; *BC_13, *MVC_0(256,3),0(2) *LA_2,256(2); *LA_3,256(3) *S_1,CC *BC_15, M2: *LTR_1,1; *BC_8, *BCTR_1,0 *EX_1, M3: %RETURN M4: *MVC_0(0,3),0(2) %END %ROUTINE EDIT(%BYTEINTEGER MODE) ! ! MODE : 0 - $EDIT ! 1 - $DELETE ! 2 - $LOOK ! %SHORTROUTINE %RECORDNAME V(VARFM) %INTEGER DESC, LEN, ESTART, ELEN, WSPLEN, N, R, END %INTEGERNAME PT %RECORDNAME BLOCK(RBFM) %RECORD RTHEAD(RTFM) %CONSTBYTEINTEGERARRAY EDPROMPT(0:8) = 8,'E','D', 'I', 'T',7,13,10,'>' %BYTEINTEGER SPARE, REPLY FAULT(33) %AND -> 1 %C %IF COMP MODE # 0 %OR LEVEL # 1 %OR (MON LOCK # 0 %C %AND HALT # 7) PRINTED = 2 %IF LIST = 'N' REPLY = 0 RP = RP+1; N = REC(RP)+DICT HEAD PT == INTEGER(N+4) %IF PT = 0 %START E1: PRINTSTRING('* cannot edit '.STRING(INTEGER(N)).' ') -> 1 %FINISH V == RECORD(PT) -> E1 %IF V_TYPE = 31 %OR V_FORM&8 = 0 %OR V_FLAGS&34 # 0 ! IT SEEMS OK TO EDIT THIS THING PT = V_LINK %IF MODE # 2; ! REMOVE OLD NAME REF DESC = V_DIMENSION RELEASE RT(DESC) %IF MODE # 2 RTHEAD = RTS(DESC); ! ROUTINE VECTOR BLOCK == RECORD(RTHEAD_ENVIR); ! BLOCK DESCRIPTOR TEXTP = A SPACE; WSPLEN = END A SPACE-TEXTP-64 ESTART = BLOCK_TEXT; END = BLOCK_LINK EDDEF = ESTART>>24; ! PICK OFF BLOCK NUMBER ESTART = ESTART&X'00FFFFFF'; ! LOOSE TOP BYTE ELEN = BLOCK_LENGTH-1 %IF ELEN+100 > WSPLEN %START %PRINTTEXT '* workspace full ' -> RESET %IF MODE # 2; %RETURN %FINISH E2: LEN = WSPLEN ! ! CALL THE EDITOR TO MODIFY THE TEXT ! %IF MODE # 1 %START RIM(0,STRING(ADDR(EDPROMPT(0)))) EDINNER(ESTART,ELEN,ESTART,ELEN,TEXTP,LEN) BYTEINTEGER(TEXTP+LEN) = 0; ! END MARKER %FINISH %ELSE LEN = 0; ! TO FORCE A DESTROY %RETURN %IF MODE = 2 ! ! ! COMP MODE = COMP MODE!35; ! SET FLAGS %IF LEN < 5 %START; ! NOT ENOUGH FOR '%REALFN A' PRINTSTRING('procedure '.STRING(INTEGER(N)). %C ' deleted ') -> DEST %FINISH NEWLINE ! ! COMPILE NEW VERSION OF TEXT ! RIM(0,'e:'); COMPILE BLOCK; ! PROMPT IN CASE %END IS LOST %IF FAULTY = 1 %OR COMP MODE&B'10000' = 0 %START RIM(0,'edit new file? ') READ: READSYMBOL(REPLY) SPARE = REPLY READSYMBOL(SPARE) %WHILE SPARE # NL -> READ %IF 'Y' # REPLY # 'N' %AND REPLY # 'L' %IF REPLY = 'Y' %START ELEN = TEXTIN-TEXT HEAD %C %AND TIDY(INTEGER(BLOCKNAME+4)) %C %IF COMP MODE&16 # 0 E START = TEXT HEAD TEXT P = A SPACE RESTORE ENTRIES -> E2 %FINISH %IF REPLY = 'L' %START; ! LET -> DEST %IF COMP MODE&B'10000' # 0 %PRINTTEXT 'cannot define procedure ' -> READ %FINISH RESTORE ENTRIES %IF COMP MODE&16 # 0 %C %THEN TIDY(INTEGER(BLOCKNAME+4)) %ELSE %START RESET: FAULT(240) %IF DESC # NEW RT %FINISH V_LINK = PT; ! RESTORE OLD NAME REF PT = ADDR(V) RTS(DESC) = RTHEAD; ! RESTORE ENTRY INFO -> E3 %FINISH DEST: N = BLOCK_ENTRIES %WHILE N < END %CYCLE R = INTEGER(N) RELEASE RT(R) %UNLESS R = DESC N = N+4 %REPEAT PT == ELEN; ELEN = ADDR(V) TIDY(PT) %IF LEN >= 5 %THEN DEFINE RT RESTRUCTURE(ADDR(BLOCK)) RTS(DESC)_EP = RT FAULTY %IF REPLY = 'L' E3: CODEIN = 0; ! TO STOP TWO CALLS ON DECODE COMP MODE = 0 1: PRINTED = 0 %END %ROUTINE DEFINE RT %SHORTROUTINE ! !************************************************************* !* * !* THE ROUTINE CREATES THE PROCEDURE BLOCK FOR THE LAST * !* PROCEDURE DEFINED, BY COPYING THE TEXT ONTO THE END * !* OF THE CODE AREA, AND FILLING IN THE HEADER BLOCK * !* * !************************************************************* ! %RECORDNAME BHEAD, WORKR(RBFM) %RECORDNAME RTINF(RTFM) %INTEGER LINK, TEXT, LENGTH, ENTRIES, SP, EP RTINF == RTS(BLOCK ENTRY) RTINF_ENVIR = CODE TOP BHEAD == RECORD(CODE TOP) TEXT = CODEIN BYTEINTEGER(TEXTIN) = 0; ! END MARKER FAULT(110) %AND ABORT %IF TEXT > STACK LENGTH = TEXTIN-TEXT HEAD+1 MOVE(LENGTH,TEXT HEAD,TEXT); ! MOVE IN THE TEXT ENTRIES = (CODEIN+LENGTH+7)&(\7) ENTRIES = ENTRIES+4 %IF ELISTP&1 # 0;! TO MAKE SURE THAT ! THE NEXT BLOCK STATRS ON A DOUBLE WORD BOUNDARY EP = ENTRIES %IF BLOCK ENTRY # ENTRY LIST(1) %THEN FAULT(221) %IF ELISTP > 0 %START %CYCLE SP = 1,1,ELISTP INTEGER(EP) <- ENTRY LIST(SP) EP = EP+4 %REPEAT %FINISH %ELSE FAULT(222) ELISTP = 0 %UNLESS COMPMODE&2 # 0 LINK = EP; INTEGER(LINK) = 0 FAULT(110) %AND -> 1 %IF EP > STACK %IF COMP MODE&2 = 0 %START DEFNUM = DEFNUM+1 EDDEF = DEF NUM %FINISH BYTEINTEGER(ADDR(TEXT)) <- EDDEF WORKR == RECORD(ADDR(LINK)) BHEAD = WORKR CODE TOP = LINK 1: NEWLINE %IF LIST = 'Y' %END %ROUTINE RESTRUCTURE(%INTEGER BP) ! REMOVE THE PROCEDURE BLOCK 'BP' AND MOVE UP ALL ! SUBSEQUENT BLOCKS TO FILL THE SPACE. ! THIS ENTAILS RELOCATING THE ENTRY POINTS AND ENTRY LISTS. %SHORTROUTINE %RECORDNAME BLOCK(RBFM) %RECORDNAME RD(RTFM) %INTEGER NB, ENTRIES, BLEN, MLEN, NEWSPACE BLOCK == RECORD(BP) NB = BLOCK_LINK NEWSPACE = BP; MLEN = NB-NEWSPACE BP = NB %WHILE INTEGER(BP) # 0 %CYCLE BLOCK == RECORD(BP) NB = BLOCK_LINK; ENTRIES = BLOCK_ENTRIES %UNTIL ENTRIES >= NB %CYCLE RD == RTS(INTEGER(ENTRIES)) RD_EP = RD_EP-MLEN RD_ENVIR = NEWSPACE ENTRIES = ENTRIES+4 %REPEAT BLEN = NB-BP MOVE(BLEN,BP,NEWSPACE) BP = NEWSPACE NEWSPACE = NEWSPACE+BLEN BLOCK == RECORD(BP); ! NEW POSN OF HEADER BLOCK_LINK = NEWSPACE; ! LINK TO NEXT BLOCK BLOCK_TEXT = BLOCK_TEXT-MLEN;! TO NEW TEXT BLOCK_ENTRIES = BLOCK_ENTRIES-MLEN ! TO NEW ENTRIES BP = NB %REPEAT CODE TOP = NEWSPACE CODE START = CODE TOP+12 INTEGER(CODE TOP) = 0; ! SHOW IT'S THE END OF THE LIST FAULTY = 1 %END %ROUTINE TIDY LABELS %SHORTROUTINE %RECORDNAME LAB(LABELFM) %INTEGER L %WHILE LABEL HEAD # 0 %CYCLE LAB == RECORD(LABEL HEAD) %IF LAB_USE # 0 %START L = LAB_LABEL REMOVE LABEL(L) ! FAULT LABEL NOT SET IF A USER DEFINED LABEL ! UNSET COMPILER LABELS SHOULD HAVE BEEN ACCOUNTED ! FOR BY OTHER FAULTS FAULT(-11) %AND PRINT LABEL(L) %IF L > X'FFFF0000' %FINISH %ELSE %START L = LABEL HEAD; LABEL HEAD = LAB_LINK LAB_LINK = ASL; ASL = L %FINISH %REPEAT %END %ROUTINE TIDY STARTS %SHORTROUTINE %INTEGER L, N %RECORDNAME ST(BLOCKFM) L = START HEAD %RETURN %IF L = 0 %UNTIL L = 0 %CYCLE ST == RECORD(L) L = ST_LINK N = 53 %IF ST_TYPE&15 = 0 %THEN N = 13 FAULT(N) %REPEAT ST_LINK = ASL; ASL = START HEAD; START HEAD = 0 %END ! ! %ROUTINE TIDY(%INTEGERNAME CELL) ! RELEASES A CELL AND ANY OF ITS LISTS TO THE ASL. %SHORTROUTINE %RECORDNAME CR(VARFM) %INTEGER P CR == RECORD(CELL) P = CR_LINK; CR_LINK = ASL; ASL = CELL; CELL = P %IF CR_INDEX > X'FFFF' %START CELL == CR_INDEX CELL == INTEGER(CELL+12) %UNTIL CELL = 0 CELL = ASL; ASL = CR_INDEX %FINISH %END %ROUTINE TIDY ALL ! REMOVE ALL THE TAGS FOR NAMES SET AT THIS LEVEL ( GIVING FAULT 28 ! WHERE NESC. AND CHECK THERE ARE NO REPEATS/FINISHES/LABELS ! OUTSTANDING. %SHORTROUTINE %INTEGER N %RECORDNAME TV(VARFM) %CYCLE N = DICTHEAD,8,DICTHEAD+4088 %IF INTEGER(N+4) # 0 %START TV == RECORD(INTEGER(N+4)) %IF TV_LEVEL = LEVEL %START FAULT2(28,N-DICTHEAD) %IF TV_FLAGS&2 # 0 TIDY(INTEGER(N+4)) %FINISH %FINISH %REPEAT TIDY STARTS TIDY LABELS %END %ROUTINE OLD BLOCK ! RESTORES THE CONTEXT OF THE CONTAINING BLOCK WHEN ! THE %END OF THE CURRENT BLOCK IS FOUND ! NOTE THAT 'DISP' MUST NOT BE RESET AT THE END OF BEGIN/END ! BLOCKS AS R11 WILL NOT THEN BE BUMPED UP PAST THEM WHEN ! THEN CONTAINING ROUTINE IS ENTERED COMP MODE <- BLOCK_MODE FN TYPE <- BLOCK_X3 FN TYPE 2 <- BLOCK_TYPE2 EFREE <- BLOCK_X1 START HEAD = BLOCK_SHEAD LABEL HEAD = BLOCK_LHEAD R10 = BLOCK_R10 LEVEL = LEVEL-1 %IF BLOCK TYPE # 0 %START ACCESS = BLOCK_FLAGS REG USE(BASE REG) = 0; BASE REG = BASE REG+1 MAX DISP = BLOCK_MAX DISP; DISP = BLOCK_DISP %FINISH BLOCK TYPE = BLOCK_TYPE BLOCK == BLOCK INF(LEVEL) %END %ROUTINE C END ! DEALS WITH ALL FORMS OF %END ! THIS INCLUDES THE RELOCATION OF OWN ARRAYS AND THE DIAG TABLE ! FOR THE BLOCK %SHORTROUTINE %RECORDNAME OWN INF(LABEL FM) %INTEGER J, K, LAB, L, RSAVE, OLD CODE BASE %BYTEINTEGER B OLD CODE BASE = R10 J = REC(RP+1) ! ! 1 : %ENDOFLIST ! 2 : %ENDOFPROGRAM ! 3 : %ENDOFFILE ! 4 : %ENDOFINT ! 5 : %END ! STOP %IF J = 4 %IF J = 1 %START ! ! %ENDOFLIST ! LIST = 'N' PRINTED = 2 %IF COMP MODE&3 # 0 -> 1 %FINISH %IF J = 3 %START ! ! %ENDOFFILE ! FAULT(56) %AND -> 1 %IF IOFLAG = 0 PRINTED = 0 IOFLAG = 0; COMPMODE = COMPMODE&B'10111111' SELECTINPUT(0); CLOSESTREAM(78); CLEAR('ST78') -> 1 %FINISH %IF LIST = 'Y' %START %IF IOFLAG = 1 %START WRITE(LINE NUM,4) SPACES((LEVEL-2)<<2+3) %PRINTTEXT 'END ' %FINISH %FINISH %IF LEVEL = 1 %AND J # 2 %THEN FAULT(14) %AND -> 1 STOP %IF J = 2; ! %ENDOFPROGRAM TIDY ALL J = DISP&X'FFF' MAX DISP = MAX DISP&X'FFF' MAX DISP = J %IF J > MAX DISP MAX DISP = (MAX DISP+7)&(\7) K = R10 RSAVE = R10-28 %IF BLOCK TYPE = 0 %THEN RSAVE = RSAVE+10 B = BLOCK TYPE; LAB = BLOCK_AD ! FILL IN INITIAL 'LA_11,??(11)' SHORTINTEGER(RSAVE) <- MAX DISP %UNLESS B = 0 OLD BLOCK LINE ENTRY = 0 %IF LEVEL = 1; ! IGNORE REST OF LINE %IF B&3 # 0 %THEN PUT LINE %C %AND PLANT(X'47FC0000'+21<<2) %ELSE %START DSS(X'D2',4,X'D014',SHORTINTEGER(RSAVE+4)) %IF B = 0 %C %THEN DRX(X'98',10,11,BLOCK INF(LEVEL+1)_DISP) %C %ELSE %START PLANT(X'984F0010'+(BASE REG-1)<<12) SPLANT(X'07FF') %FINISH %FINISH ! ! REMOVE ROUTINE REFERENCES INSIDE BEGIN/END BLOCKS ! %IF B = 0 %AND LEVEL = 1 %THEN RESTORE ENTRIES ! BRANCH AROUND DIAG TABLE AFTER BEGIN/END BLOCKS %IF B = 0 %THEN J = FORWARD REF(15) ! ! CONSTRUCT DIAGNOSTIC TABLE ! K = CODEIN-K %IF K > 4095 %START GLA = (GLA+3)&(\3) INTEGER(GLA) = K SHORTINTEGER(RSAVE+8) = X'580D' K = GLA-GLAHEAD GLA = GLA+4 %FINISH SHORTINTEGER(RSAVE+10) = K *L_1,CODEIN; *L_2,DIAG END; *LA_3,6(0,0) *SR_2,3; *MVC_0(6,1),0(2) L = 6 %IF DIAGS # 0 %START L = DIAG END-DIAG PT MOVE(L-6,DIAG PT,CODEIN+6) %FINISH CODEIN = CODEIN+L SHORTINTEGER(CODEIN) = 0; ! END MARKER CODEIN = CODEIN+2 DIAG PT = DIAG END+4; DIAG END = INTEGER(DIAG END) ! DEAL WITH OWN ARRAYS %IF OWN DISP # 0 %START; ! OWN ARRAY USED L = OWN END-OWN TOP; ! SIZE OF OWN ARRAYS CODEIN = (CODEIN+7)&(\7); ! ARRAYS START ON DOUBLE WORDS MOVE(L,OWN TOP,CODEIN); ! SHIFT IN THE ARRAYS CODEIN = CODEIN+L INTEGER(OWN DISP) = CODEIN-OLD CODE BASE %FINISH ! ! NOW RESTORE OWN DESCRIPTORS ! OWN INF == RECORD(OWN LIST HEAD) OWN LIST HEAD = OWN INF_LINK OWN INF_LINK = ASL ASL = ADDR(OWN INF) OWN DISP = OWN INF_LABEL OWN TOP = OWN INF_ADDRESS OWN END = OWN INF_USE ! ! REMOVE ANY UNDEFINED ROUTINE (FAULT 7 ETC.) ! %IF COMP MODE&128 # 0 %AND B # 0 %AND LEVEL = 1 %START CODEIN = RTS(BLOCK ENTRY)_EP-4 TIDY(INTEGER(BLOCK NAME+4)) COMP MODE = COMP MODE&B'01101111' FAULTY = 1; ! TO STOP IT BEING CALLED RESTORE ENTRIES %FINISH ! ! INHIBIT EXECUTION OF FAULTY ROUTINES ! %IF FAULTY # 0 %START %PRINTTEXT '* routine faulty ' %C %IF LEVEL = 1 %AND LIST = 'Y' RTS(BLOCK ENTRY)_EP = RT FAULTY %IF BLOCK ENTRY >= 0 %FINISH ! ! FILL IN JUMP ROUND DIAGS AND OWNS AND ROUTINES ! %IF B = 0 %THEN REMOVELABEL(J) %ELSE %START REMOVE LABEL(LAB) %UNLESS LEVEL = 1 %FINISH 1: %END %ROUTINE SET DIAG(%INTEGER AD, NAME) ! PLANT DIAGNOSTIC INFORMATION FOR 'NAME' DIAGPT = DIAGPT-6 SHORTINTEGER(DIAGPT) <- AD SHORTINTEGER(DIAGPT+2) <- NAME SHORTINTEGER(DIAGPT+4) <- DIAG FLAG ! ENABLE FLAG SHOULD BE ZERO ? DIAG SAVE = DIAG PT %IF LEVEL = 1 %END %ROUTINE NEW DIAG(%INTEGER AD) ! PRESERVE THE CURRENT DIAGS POINTERS AND SET UP A NEW ! BLOCK POINTER IN BYTES 20-21 OF GLA DSS(X'D2',4,AD,X'D014') PLANT(X'41000000'); PLANT(X'4000D014') %END %INTEGERFN NEW CELL ! %INTEGER CELL ! FAULT(107) %AND ABORT %IF ASL = 0 ! CELL = ASL ! ASL = INTEGER(ASL+12) ! INTEGER(CELL)=0: INTEGER(CELL+4)=0: ..... *L_1,ASL; *LTR_1,1; *BC_7,; FAULT(107); ABORT OK: *L_2,12(0,1); *STM_1,2,LAST ASL; *XC_0(16,1),0(1) %RETURN %END %ROUTINE NEW BLOCK(%BYTEINTEGER T) ! PRESERVE THE CURRENT CONTEXT AND CREATE A NEW CONTEXT FOR ! THE COMING BLOCK ! !* BLOCK TYPES 0 = '%BEGIN' !* 4 = '%ROUTINE' !* 5 = '%FN'/'%MAP' !* 6 = '%PREDICATE' %SHORTROUTINE %INTEGER AD %IF LEVEL = 11 %THEN FAULT(105) %AND %RETURN ! ! PRESERVE %OWN ARRAY INFO ! PUSH(OWN LIST HEAD,OWN DISP,OWN TOP,OWN END) OWN DISP = 0 OWN END = OWN TOP-4 OWN TOP = OWN END ! ! ! %IF IOFLAG = 1 %AND LIST = 'Y' %START %IF TESTINT(0,'NO') # 0 %START LIST = 'N' DCOMP = 0 %FINISH %ELSE %START WRITE(LINE NUM,4) SPACES((LEVEL-1)<<2+3) %IF T = 0 %THEN %PRINTTEXT 'BEGIN' %C %ELSE PRINTSTRING('RT/FN/MAP '.STRING(INTEGER( %C RTNAME+DICTHEAD))) NEWLINE %FINISH %FINISH %IF LEVEL = 1 %THEN ELISTP = 0 LEVEL = LEVEL+1 FAULT(34) %IF LEVEL > 9 BLOCK == BLOCK INF(LEVEL) BLOCK_TYPE <- BLOCK TYPE %IF T # 0 %START BASE REG = BASE REG-1 %IF BASE REG <= 4 %THEN FAULT(35) %AND BASE REG = 4 REG USE(BASE REG) = 'L';! LOCK THE REGISTER %FINISH %IF COMP MODE&12 = 0 %AND T # 0 %C %THEN COMP MODE = COMP MODE!16 BLOCK_MODE = COMP MODE; COMP MODE = COMP MODE!4 BLOCK_X3 = FNTYPE BLOCK_TYPE2 <- FN TYPE 2 BLOCK_X1 = EFREE BLOCK_FLAGS = ACCESS; COMP MODE = COMP MODE&B'11010111' BLOCK_DISP <- DISP BLOCK_MAX DISP <- MAX DISP BLOCK_SHEAD = START HEAD BLOCK_LHEAD = LABEL HEAD BLOCK_R10 = R10 START HEAD = 0; LABEL HEAD = 0 DIAGPT = DIAGPT-4; INTEGER(DIAGPT) = DIAGEND DIAGEND = DIAGPT; DIAGFLAG <- LINENUM AD = BASE REG %IF T = 0 %THEN AD = DISP SET DIAG(AD,RTNAME) %END %ROUTINE PUSH(%INTEGERNAME HEAD, %INTEGER X, Y, Z) %SHORTROUTINE %RECORDNAME P(LABELFM) %INTEGER CELL CELL = NEW CELL P == RECORD(CELL) P_LINK = HEAD HEAD = CELL P_LABEL = X P_ADDRESS = Y P_USE = Z %END %INTEGERFN ENAME(%INTEGER LIST) ! SEARCH THE FORMAT LIST 'LIST' FOR THE SUB-NAME 'VNAME' ! AND RETURN THE ADDRESS OF ITS DESCRIPTOR. ! GIVE FAULT 65 (WRONG SUBNAME) AND RETURN A DUMMY VALUE IF ! THE NAME IS NOT FOUND %SHORTROUTINE %RECORDNAME NEW(VARFM) %IF LIST # 0 %START NEW == RECORD(LIST) %CYCLE %IF SHORTINTEGER(ADDR(NEW_LEVEL))&X'FFFC' = %C VNAME %START ! NAME FOUND %RESULT = ADDR(NEW) %FINISH %EXIT %IF NEW_LINK = 0; ! END OF LIST NEW == RECORD(NEW_LINK) %REPEAT %FINISH FAULT2(65,VNAME) %RESULT = ADDR(DUMMY NAME) %END %ROUTINE GET4(%INTEGERNAME N) ! N = REC(RP+1)<<16!(REC(RP+2)&X'FFFF') ! RP = RP+2 *L_1,RP; *LA_2,2(1,1); *A_2,REC *L_3,N; *MVC_0(4,3),0(2) *LA_1,2(0,1); *ST_1,RP %END %ROUTINE GET8(%LONGREALNAME R) ! GET4(INTEGER(ADDR(R))) ! GET4(INTEGER(ADDR(R)+4)) *L_1,RP; *LA_2,2(1,1); *A_2,REC *L_3,R; *MVC_0(8,3),0(2) *LA_1,4(0,1); *ST_1,RP %END %ROUTINE GET CYCLE SPACE(%INTEGERNAME A) %INTEGER J A = (DISP+3)&(\3); J = A+12 DISP = J; MAX DISP = J %IF J > MAX DISP MAX DISP = J %IF J > MAX DISP %END %INTEGERFN GET FORMAT(%INTEGER FNAME) %INTEGER A A = GET NAME(FNAME) %IF BYTEINTEGER(A+2) # 31 %C %THEN FAULT2(62,FNAME) %AND %RESULT = 0 %RESULT = A %END %INTEGERFN GET NAME(%INTEGER NAME) %SHORTROUTINE %INTEGER NAMEP NAMEP = INTEGER(NAME+DICTHEAD+4) %IF NAMEP = 0 %START FAULT2(16,NAME); NAMEP = ADDR(DUMMYNAME) %FINISH %RESULT = NAMEP %END %ROUTINE S LOAD(%INTEGER STRING, REGISTER) %SHORTROUTINE %IF STRING < 16 %START; ! ADDRESS IN A REGISTER DRR(X'18',REGISTER,STRING) %UNLESS REGISTER = STRING %FINISH %ELSE %START DRX(X'58',REGISTER,0,STRING); STUAV(REGISTER) %FINISH GPR1 = 0 %IF REGISTER = 1 %END %ROUTINE CSEXPRN(%INTEGERNAME ADDRESS) ! COMPILES STRING EXPRESSIONS ! IF THE EXPRESSION IS SIMPLE (I.E. A SINGLE VARIABLE ! OR A CONSTANT) ADDRESS IS SET TO THE ADDRESS OF THAT ! ENTITY (POSSIBLY A REGISTER (FN,MAP,CONSTANTS ETC.) ! FOR CONCATENATION A TEMPORARY STRING OF 256 BYTES ! IS CLAIMED OFF THE STACK, SET TO THE NULL STRING ! AND THE COMPONENT PARTS OF THE EXPRESSION ARE ! CONCATENATED ONTO IT USING PERM 14 ! THE ADDRESS OF THIS STRING IS RETURNED IN REGISTER 1 %SHORTROUTINE %INTEGER P, ESAVE, LOADOP; %BYTEINTEGER XSAVE %RECORD S(VARFM) S CONST = 0 XSAVE = EXPRN TYPE; EXPRN TYPE = B'10000' RP = RP+1; ! SKIP P(EXPRN) P = REC(RP+2); ! MARK TO (ROX) %IF REC(P) = 1 %START; ! COMPLEX EXPRESSION (CONCATENATION) %IF R14 # 0 %START; ! RESOLUTION USING R14 CLAIMSAFEREGISTER(P);! PRESERVE IT DRR(X'18',P,14) %FINISH ! GET @ OF WORK STRING ON STACK PLANT(EFREE&X'FFFF'+X'41E00000') ESAVE = EFREE EFREE = EFREE+256; ! CLAIM STRING WORKSPACE ADDRESS <- 1; PROTECT(4) PLANT(X'9200E000'); ! SET WORK STRING TO NULL FAULT(72) %UNLESS REC(RP+1) = 4 %CYCLE RP = RP+2 GETSVAR(S) S_FORM = S_FORM&B'11111101' LOAD(S,1); STUAV(1) %IF S CONST = 0 PLANT(X'45FC0000'!14<<2); ! CONCATENATE GPR1 = 0; ! NOW FORGET IT RP = RP+1 %EXIT %IF REC(RP) # 1; ! NO MORE LEFT FAULT(72) %UNLESS REC(RP+1) = 12 ! '.' %REPEAT EFREE = ESAVE SPLANT(X'181E'); ! R1 POINTS TO RESULT %IF R14 # 0 %START RELEASE REGISTER(P) SPLANT(X'18E0'+P); ! RESTORE R14 FOR RESOLUTION %FINISH %FINISH %ELSE %START; ! SIMPLE EXPRN (SINGLE ENTITY) FAULT(73) %UNLESS REC(RP+1) = 4; ! NULL (PLUS) RP = RP+2; ! ONTO P(HOLE) GETSVAR(S) RP = RP+1; ! SKIP (ROX') %IF S_INDEX # 0 %OR S_FLAGS&4 # 0 %START ADDRESS <- S_ADDRESS PROTECT(4) %UNLESS ADDRESS = 1 ADDRESS = ADDRESS<<12 %IF S_FORM&128 # 0 LOADOP = X'58' %IF S_FLAGS&4 # 0 %THEN LOADOP = X'41' DRX(LOADOP,1,S_INDEX,ADDRESS) RELEASEREGISTER(S_INDEX) ADDRESS <- 1; STUAV(1) %IF S CONST = 0 %FINISH %ELSE ADDRESS <- S_ADDRESS&X'FFFF' %FINISH EXPRN TYPE = XSAVE %END %ROUTINE FILL JUMPS(%RECORDNAME HEAD) ! WORKS DOWN THE LIST 'HEAD' FILLING IN THE LABEL ! REFERENCES TO 'LABEL ADDRESS' %SHORTROUTINE %RECORDSPEC HEAD(LABELFM) %RECORDNAME LIST(LABELFM) %INTEGER R, P, Z, A, AD Z = (LABEL ADDRESS>>12&15)<<2 FAULT(99) %IF Z > 15*4 P = HEAD_USE HEAD_USE = 0; ! SHOW LABEL FOUND R = P AD = LABEL ADDRESS&X'FFF'!X'A000' %UNTIL P = 0 %CYCLE LIST == RECORD(P) A = LIST_LABEL %IF Z # 0 %START FAULT(99) %UNLESS SHORTINTEGER(A) = X'41DD' SHORTINTEGER(A) = X'58FC' SHORTINTEGER(A+2) = Z+X'00C8' FAULT(99) %IF BYTEINTEGER(A+5)&15 # 0 BYTEINTEGER(A+5) = BYTEINTEGER(A+5)!15 %FINISH SHORTINTEGER(A+6) = AD P = LIST_LINK %REPEAT LIST_LINK = ASL; ! RETURN CELLS TO ASL ASL = R %END %ROUTINE REMOVE LABEL(%INTEGER LABEL) ! FILLS ANY FORWARD REFERENCES TO 'LABEL' WITH HERE AND REMOVES ! THE REFERENCES. %SHORTROUTINE %RECORDNAME LAB(LABELFM) %INTEGER P %INTEGERNAME LAST LABEL ADDRESS <- CODEIN-R10 LAST == LABEL HEAD P = LAST %WHILE P # 0 %CYCLE LAB == RECORD(P) %IF LAB_LABEL = LABEL %START LAST = LAB_LINK %IF LAB_USE # 0 %THEN FILL JUMPS(LAB) LAB_LINK = ASL ASL = P %RETURN %FINISH LAST == LAB_LINK P = LAST %REPEAT FAULT(209); ! IT DON'T EXIST %END %ROUTINE LABEL FOUND(%INTEGER LABEL) ! FILLS IN ANY OUTSTANDING REFERENCES TO 'LABEL' ! AND REPLACES THE REFERENCE LIST WITH THE RELATIVE ! ADDRESS OF THE LABEL FROM REGISTER 10 %SHORTROUTINE %INTEGER P %RECORDNAME LAB(LABELFM) P = LABEL HEAD %CYCLE %IF P = 0 %START; ! A NEW LABEL PUSH(LABEL HEAD,LABEL,CODEIN-R10,0) %RETURN %FINISH LAB == RECORD(P) %EXIT %IF LAB_LABEL = LABEL; ! FOUND IT P = LAB_LINK; ! MOVE DOWN THE LIST %REPEAT %IF LAB_USE = 0 %START FAULT(-2); ! ALREADY SET PRINT LABEL(LABEL) %RETURN %FINISH LABEL ADDRESS <- CODEIN-R10 LAB_ADDRESS <- LABEL ADDRESS FILL JUMPS(LAB); ! REMOVE OUTSTANDING REFERENCES %END %ROUTINE JUMP TO(%INTEGER LABEL, MASK) %SHORTROUTINE %INTEGER A, X %RECORDNAME LAB(LABELFM) %IF LABEL HEAD = 0 %START; ! FIRST LABEL PUSH(LABEL HEAD,LABEL,0,0) LAB == RECORD(LABEL HEAD) -> 2 %FINISH LAB == RECORD(LABEL HEAD) %CYCLE %IF LAB_LABEL = LABEL %START;! ALREADY USED %IF LAB_USE = 0 %START; ! LABEL ALREADY SET A = LAB_ADDRESS X = 0 %IF A > 4095 %START PLANT(X'58FC00C8'+(A>>12&15)<<2) X = 15 A = A&X'0FFF' %FINISH DRX(X'47',MASK,X,A!X'A000') %RETURN %FINISH 2: PUSH(LAB_USE,CODEIN,0,0); ! ADD NEW REFERENCE PLANT(X'41DD0000'); ! NO-OP DRX(X'47',MASK,0,0) %RETURN %FINISH %IF LAB_LINK = 0 %START;! INSERT FIRST REFERENCE PUSH(LABEL HEAD,LABEL,0,0) LAB == RECORD(LABEL HEAD) -> 2 %FINISH LAB == RECORD(LAB_LINK) %REPEAT %END %INTEGERFN FORWARD ADDRESS(%INTEGER LEN) %INTEGER A A = (CODEIN-R10)&X'00FFFFFF'+LEN %IF A > X'0FFF' %START A = A+4 PLANT(X'58FC00C8'+(A>>12&15)<<2) A = A!X'F000' %FINISH %RESULT = A %END %INTEGERFN FORWARD REF(%INTEGER MASK) %INTEGER L L = ILAB-1; ILAB = L JUMP TO(ILAB,MASK) %RESULT = L %END %INTEGERFN COND TYPE ! EXAMINES THE COMPONENTS OF A CONDITION TO DETERMINE ! WHETHER IT IS STRING OR NUMERICAL. ! THE AMBIGUOUS CASE OF %IF 'A' > 'Z' %THEN ... ! IS DEEMED TO BE A NUMERICAL CONDITION ! ONLY THE FIRST TWO EXPRESSIONS ARE SEARCHED. %SHORTROUTINE %INTEGERFNSPEC TYPE(%INTEGER EP) ! %INTEGER T T = TYPE(COND2+2); ! LOOK AT SECOND EXPRN FIRST %IF T = B'10100' %START; ! SYMBOL OR STRING T = TYPE(COND1+2); ! LOOK AT FIRST EXPRN %IF T = B'10100' %THEN %RESULT = B'100' %FINISH %RESULT = T %INTEGERFN TYPE(%INTEGER EP) %INTEGER P %RECORDNAME WORK(VARFM) %RECORD R(VARFM) %RESULT = B'1100' %UNLESS REC(EP) = 4 ! NULL (PLUS) P = REC(EP+1); ! MARK %IF REC(P) = 1 %START; ! EXAMINE OPERATOR %IF REC(P+1) = 12 %THEN %RESULT = B'10000' ! '.' %RESULT = B'1100' %FINISH %RESULT = B'1100' %IF REC(EP+2) > 2 ! '(' (EXPRN) ')' ETC. %IF REC(EP+2) = 1 %THEN %RESULT = REC(EP+3) ! CONSTANT GET INFO(REC(EP+4),R); ! EXAMINE NAME RP = EP+4 %CYCLE %WHILE R_TYPE = 7 %CYCLE ! RECORD, SO SKIP DOWN FOR ENAME RP = RP+1 %AND SKIP EXPRN %WHILE REC(RP+1) = 1 ! THAT SKIPS ANY PARAMETERS. %RESULT = 4 %IF REC(RP+2) = 2 ! ENAME MISSING RP = RP+4; VNAME = REC(RP);! SKIP P(VAR) ? WORK == RECORD(ENAME(R_INDEX)); R = WORK %REPEAT %RESULT = LOAD TYPE(R_TYPE) %IF R_LEVEL # 0 ! COMPILER NAMES NEED SPECIAL TREATMENT %RESULT = CNTYPE(R_INDEX) %IF R_INDEX # 55 ! PRETEND 'MON_' IS A RECORD R_TYPE = 7 R_INDEX = DIAG HEAD_INDEX %REPEAT %END %END %ROUTINE S COND(%INTEGER MASK, LABEL) ! COMPILES 'SIMPLE' CONDITIONS, VERY DEVIOUS ALTER WITH CARE ! %SHORTROUTINE %RECORD LHS, RHS(VARFM) %INTEGER COMP, TLAB, R, A1, A2, NOT, ESAVE %BYTEINTEGER CTYPE %ROUTINESPEC COMPARE(%INTEGER WAY) %ROUTINESPEC LA(%RECORDNAME R, %INTEGER REG) TLAB = 0 NOT = REC(RP+1)-2 RP = RP+2 %IF REC(RP) = 1 %START; ! (EXPRN)(COMP)(EXPRN)(RSCOND) ESAVE = EFREE; R = 0 COND1 = RP+1; COND2 = REC(COND1) COMP = REC(COND2) %IF COMP = 8 %START; ! RESOLUTION RP = COND1 GET RESLN VAR(COND2) %IF COND2 # 0 %START RP = COND2 CRES(LABEL,(MASK+8!!NOT)&15) %FINISH RP = RP+1 %IF REC(RP) = 1 %START; ! DOUBLE SIDED FAULT(73) RP = RP+2 SKIP EXPRN %FINISH %RETURN %FINISH CTYPE <- COND TYPE %IF CTYPE&B'10000' # 0 %START; ! STRINGS RP = COND2; CSEXPRN(A2); COND2 = RP %IF A2 < 16 %START RELEASE REGISTER(A2) EFREE = EFREE+256;! PROTECT LAST STRING CLAIM SAFE REGISTER(R) DRR(X'18',R,A2) %FINISH %ELSE R = A2 RP = COND1; CSEXPRN(A1); RP = COND2+1 SLOAD(A1,1); SLOAD(R,2) PLANT(X'45FC0000'+19<<2) GPR1 = 0; ! FORGET IT %FINISH %ELSE %START; ! NUMERICAL EXPRN TYPE = B'1100';! SET TO AMBIGUOUS EXPRN RP = COND2; EXPRN(RHS); COND2 = RP RP = COND1; EXPRN(LHS); RP = COND2+1 EQUATE TYPES(RHS,LHS); COMPARE(0) RELEASE REGISTER(LHS_ADDRESS) %IF LHS_TYPE&8 = 0 %FINISH %IF REC(RP) = 1 %START; ! DOUBLE SIDED COMP = (\CONCODE(COMP))&15; ! SET TO 'FALSE' %IF MASK = NOT %START TLAB = FORWARD REF(COMP) %FINISH %ELSE JUMP TO(LABEL,COMP) RP = RP+1; COMP = REC(RP) FAULT(73) %IF COMP = 8 %IF CTYPE&B'10000' # 0 %START CSEXPRN(A1); SLOAD(A1,2); SLOAD(R,1) PLANT(X'45FC0000'+19<<2); GPR1 = 0 ! FORGET IT %FINISH %ELSE %START EXPRN(LHS); EQUATE TYPES(LHS,RHS) COMPARE(-1) RELEASE REGISTER(LHS_ADDRESS) %IF LHS_TYPE&8 = 0 %FINISH %FINISH RELEASE REGISTER(R) %IF 0 # R # A2 EFREE = ESAVE; ! RELEASE STRING WORKSPACE TC: COMP = (CONCODE(COMP)!!MASK!!NOT)&15 JUMP TO(LABEL,COMP) RELEASE REGISTER(RHS_ADDRESS) %C %IF CTYPE # 16 %AND RHS_TYPE&8 = 0 REMOVE LABEL(TLAB) %IF TLAB # 0 %FINISH %ELSE %START %IF REC(RP) = 3 %START COMP = 1; ASSOP = 2; VAR(LHS) RP = RP+1 %IF REC(RP) = 2 %START FAULT(49) %UNLESS LHS_TYPE = 14 ! %PREDICATE %FINISH %ELSE %START;! %IF (VAR) == (VAR) ASSOP = 2; VAR(RHS) LA(RHS,2); LA(LHS,1) SPLANT(X'1912'); GPR1 = 0 %FINISH -> TC %FINISH %ELSE COND(MASK!!NOT,LABEL) ! '(' (COND) ')' %FINISH FPR2 = 0 %RETURN %ROUTINE COMPARE(%INTEGER WAY) ! LOADS AND COMPARES THE TWO EXPRESSIONS 'LHS' AND 'RHS' ! THE TYPES OF WHICH WILL BE THE SAME ! POSSIBLY 'EQUATE TYPES SHOULD BE CALLED IN HERE ? %INTEGER OP, L, R AVAILABLE(R,RHS_TYPE) %AND LOAD(RHS,R) %C %IF RHS_FORM&128 = 0 %OR RHS_FORM&2 # 0 LOAD(LHS,3) %IF LHS_FORM&128 = 0 %OR LHS_FORM&2 # 0 LHS_TYPE = 1 %IF LHS_TYPE = 0; ! FOR ADDRESS COMPARISONS OP = (LHS_TYPE&B'1100')<<2!9 %IF WAY = 0 %C %THEN L = LHS_ADDRESS %AND R = RHS_ADDRESS %C %ELSE R = LHS_ADDRESS %AND L = RHS_ADDRESS DRR(OP,L,R) %END %ROUTINE LA(%RECORDNAME V, %INTEGER REG) ! GET THE ADDRESS OF 'V' INTO REGISTER 'REG' ! AND LOOSE THE TOP BYTE IN THE CASE OF STRINGS %RECORDSPEC V(VARFM) %BYTEINTEGER FLAG, MODE FLAG = V_TYPE %IF FLAG = 16 %START V_FORM = V_FORM!2 %IF V_FLAGS&4 = 0 %FINISH %IF FLAG # 7 %START MODE = V_FORM LOAD ADDR(V,REG) %IF FLAG = 16 %AND MODE&2 # 0 %C %THEN DRX(X'41',REG,REG,0) %FINISH %ELSE %START V_TYPE = 4 V_FORM = V_FORM!2 %IF V_FLAGS&4 = 0 LOAD ADDR(V,REG) %FINISH %END %END %ROUTINE COND(%INTEGER VALIDITY, FARLABEL) %SHORTROUTINE ! !************************************************************* !* * !* THIS ROUTINE COMPILES (COND), TRYING TO PROVE IT * !* 'VALIDITY' AND IF SO, JUMPING TO 'FARLABEL' * !* VALIDITY = -1 FOR 'FALSE', = 0 FOR 'TRUE' * !* * !************************************************************* ! %INTEGER P, MASK, LABEL RP = RP+2; P = REC(REC(RP)); ! SKIP P(COND) %IF P # 3 %START MASK = P-2; ! -1 FOR %AND, 1 FOR %OR %IF (P+VALIDITY)&1 = 0 %THEN LABEL = FARLABEL %C %ELSE LABEL = ILAB-1 %AND ILAB = LABEL SCOND(MASK,LABEL) %AND RP = RP+2 %C %UNTIL REC(REC(RP)) = 2 %FINISH SCOND(VALIDITY,FARLABEL); ! LAST CONDITION ALWAYS THE SAME RP = RP+1 REMOVE LABEL(LABEL) %UNLESS P = 3 %OR LABEL = FARLABEL %END %ROUTINE C COND(%INTEGER CTYPE) %SHORTROUTINE ! CTYPE = 1 => %IF ! = 2 => %UNLESS ! = 3 => %WHILE ! = 4 => %UNTIL %INTEGER ULAB, TRUTH TRUTH = -(CTYPE&1); ! -1 FOR IF & WHILE, 1 FOR UNLESS & UNTIL ELSE LABEL = ILAB-1; ILAB = ELSE LABEL %IF CTYPE > 2 %START ULAB = FORWARD REF(15) %IF CTYPE = 4 CYCLE LABEL = ILAB-1; ILAB = CYCLE LABEL LABEL FOUND(CYCLE LABEL) PUT LINE %FINISH COND(TRUTH,ELSE LABEL) %IF CTYPE = 4 %THEN REMOVE LABEL(ULAB) ! %CYCLE PRESERVES 'CYCLE LABEL' %AND 'ELSE LABEL' ! %START PRESERVES 'ELSE LABEL' %END %ROUTINE S CPE(%RECORDNAME V, %INTEGER EX) ! TESTS FOR STRING CAPACITY EXCEEDED ! A VERY NASTY THING IF RECORDS ARE ABOUT !!!!!! %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER B %IF V_LENGTH # 255 %AND TUAV # 0 %START %IF V_DIMENSION = 7 %START DRX(X'58',15,0,DOPE VECTOR+8) B = X'F003' -> 1 %FINISH B = V_ADDRESS %IF V_LENGTH # 0 %THEN DSI(X'95',EX,V_LENGTH) %C %ELSE %START %IF V_INDEX # 0 %START DRX(X'41',15,V_INDEX,B); B = X'F000' %FINISH 1: DSS(X'D5',1,EX,B) %FINISH PLANT(X'472C0000'!4<<2) %FINISH %END %ROUTINE GETSVAR(%RECORDNAME V) ! RP ON (HOLE) %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER P RP = RP+1 %IF REC(RP) = 2 %THEN VAR(V) %ELSE %START %IF REC(RP) = 1 %START CCONST(V) %IF V_TYPE = B'10100' %C %THEN V_ADDRESS <- V_ADDRESS!256 %C %AND V_TYPE = B'10000' %FINISH %ELSE %START P = 72 %IF REC(RP) = 3 %THEN P = 75 FAULT(P) RP = REC(RP-1)-1; ! SKIP PAST THE OPERAND V_INDEX = 0 V_ADDRESS = 0 V_TYPE = B'10000' V_FORM = 1 ! ALL DUMMY VALUES %FINISH %FINISH FAULT(71) %IF V_TYPE&B'10000' = 0 %AND V_LEVEL # 255 V_TYPE = 4 %IF V_FLAGS&4 # 0 %THEN V_TYPE = 0 %END %ROUTINE GET NAME VAR(%RECORDNAME V, %INTEGER FLT) %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER ASSP %SHORTINTEGER ENTRY ENTRY = RP %IF REC(RP+2) # 4 %OR REC(RP+4) # 2 %THEN -> FLTY ASSP = ASSOP; ASSOP = 1 RP = RP+4; VAR(V); ASSOP = ASSP; RP = RP+1 %IF REC(RP) = 1 %START RP = ENTRY FLTY: FAULT(FLT); SKIP EXPRN V = DUMMY NAME %FINISH %END %ROUTINE AVAILABLE(%INTEGERNAME REGISTER, %BYTEINTEGER TYPE) ! SEARCHES THE REGISTER LIST AND RETURNS A FREE REGISTER ! TRYING REGISTER 1 FIRST ! REAL EXPRESSIONS WILL ALWAYS GET FPR2 %SHORTROUTINE %IF TYPE&B'100' # 0 %START %IF GPR1 = 0 %THEN REGISTER = 1 %C %ELSE CLAIMSAFEREGISTER(REGISTER) %RETURN %FINISH PROTECT(8) REGISTER = 1 %END %ROUTINE STUAV(%INTEGER REG) ! CHECK THE STRING AT 'REG' FOR UNASSIGNED %RETURN %IF TUAV = 0 DSS(X'D5',2,REG<<12,X'D000'!22<<2) PLANT(X'478C000C') S CONST = 0 %END %ROUTINE TESTUAV(%BYTEINTEGER T, %INTEGER REGISTER) %SHORTROUTINE %RETURN %IF TUAV = 0 %IF T = B'100' %THEN T = X'59' %ELSE %START %IF T = B'1010' %THEN T = X'69' %ELSE %START %RETURN %UNLESS T = B'1000' T = X'79' %FINISH %FINISH DRX(T,REGISTER,13,22<<2) PLANT(X'478C000C') %END %ROUTINE SETTEXT(%BYTEINTEGER FLAG) ! DUMPS THE GIVEN TEXT IN-LINE, PREFIXED BY A SUITABLE ! BRANCH AND LINK %SHORTROUTINE ! RP ON P(TYPE) %INTEGER AD, T, L RP = RP+1; L = REC(RP); ! LENGTH OF TEXT RP = RP+1; AD = ADDR(LINE(REC(RP))) BYTEINTEGER(AD) <- L T = (L+2)&(\1); ! FOR HALFWORD ALLIGNMENT %IF FLAG = 0 %START; ! NORMAL STRINGS PROTECT(4) PLANT(X'451A0000'+FORWARD ADDRESS(T+4)) %FINISH %ELSE %START DRX(X'41',14,0,(EFREE+7)&(\7)); ! NEW R11 FOR PTXT PLANT(X'45FC0000'!20<<2); ! PRINTTEXT %FINISH STRING(CODEIN) = STRING(AD); ! MOVE IN TEXT CODEIN = CODEIN+T %END %ROUTINE PUT4(%INTEGER N) ! REC(RP) <- SHORTINTEGER(ADDR(N)) ! REC(RP+1) <- SHORTINTEGER(ADDR(N)+2) ! RP = RP+2 *L_1,RP; *LA_2,0(1,1); *A_2,REC *MVC_0(4,2),N *LA_1,2(0,1); *ST_1,RP %END %ROUTINE PUT8(%LONGREAL R) ! PUT4(INTEGER(ADDR(R))) ! PUT4(INTEGER(ADDR(R)+4)) *L_1,RP; *LA_2,0(1,1); *A_2,REC *MVC_0(8,2),R *LA_1,4(0,1); *ST_1,RP %END %ROUTINE CCONST(%RECORDNAME V) %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER IC, T, F %LONGREAL RC F = 1; ! FORM RP = RP+1 T = REC(RP); ! TYPE OF CONSTANT %IF T&B'100' # 0 %START; ! INTEGER (OR SYMBOL) GET4(IC); ! PICK UP THE CONSTANT %IF T = B'10100' %AND EXPRNTYPE&B'10000' # 0 %START PROTECT(4) %IF IC = 0 %THEN PLANT(X'411D0006') %ELSE %START PLANT(X'451A0000'+FORWARD ADDRESS(6)) IC = IC+256 %UNLESS IC = 0; ! ZERO LENGTH FOR NULL SHORTINTEGER(CODEIN) <- IC; ! PLUG IN STRING CODEIN = CODEIN+2 %FINISH -> STR %FINISH %ELSE T = B'100' %IF EXPRN TYPE&B'100' = 0 %START T = B'1011'; ! EXTRA BIT FOR '$** ETC %IF IC = 0 %THEN -> 1; ! WASTE OF TIME FLOATING RC = IC; -> REAL %FINISH %IF IC>>12 = 0 %START; ! CAN USE 'LA' ZERO EXP = ZERO EXP!1 %IF IC = 0 F = 0; T = 0 1: V_TYPE = T V_FORM = F V_ADDRESS <- IC V_INDEX = 0 %RETURN %FINISH INTEGER(GLA) = IC; ! PUT INTO GLA IC = GLA-GLAHEAD!X'D000' GLA = GLA+4 -> 1 %FINISH %IF T&B'1000' # 0 %START; ! REAL EXPRNTYPE = B'1010' %IF EXPRNTYPE = B'1100' ! SET TO REAL (FOR COND-EXPRNS) GET8(RC) REAL: IC = (GLA+7)&(\7) GLA = IC+8 LONGREAL(IC) = RC; ! PUT INTO GLA IC = IC-GLAHEAD!X'D000' -> 1 %FINISH ! STRINGS :: (TYPE)(LENGTH)(TEXT) SET TEXT(0); S CONST = 1 STR: V_ADDRESS <- 1 V_TYPE = B'10000' V_FORM = 128 V_FLAGS = 0 V_LENGTH = 0 V_INDEX = 0 GPR1 = ADDR(V) %END ! %ROUTINE GETINFO(%INTEGER NAME, %RECORDNAME VAR) !* RP SET BEFORE P(VAR) %RECORDSPEC VAR(VARFM) *LM_1,2,NAME *L_3,DICT HEAD *L_1,4(3,1) *LTR_1,1; *BC_7, **1,@DUMMYNAME SET: *MVC_0(12,2),0(1) ! !***** IMP VERSION ***** ! ! NAME=INTEGER(NAME+DICT HEAD+4) ! VAR = RECORD(NAME) %END %ROUTINE RT SAVE(%INTEGER R2) ! SAVES REGISTERS 4 - 'R2' ON THE STACK AND BUMPS ! EFREE ON PAST THEM (MORE OR LESS !) %INTEGER A EFREE = (EFREE+7)&(\7); ! DOUBLE WORD BOUNDARY A = EFREE+16; ! WHERE TO START STM DRX(X'90',4,R2,A) %IF EFREE # X'B000' %THEN DRX(X'41',11,0,EFREE) EFREE <- A+60; ! BUMP R11 PAST SAVE AREA %END %ROUTINE TEST STUDENT %IF STUDENT # FIDDLE FACTOR %START; ! DEVIOUS GOINGS ON *LM_4,15,16(9) *BCR_15,15 %FINISH FAULT2(16,VNAME) %IF STUDENT # 0 %END %ROUTINE C C NAME(%RECORDNAME V) ! !**************************************************************** !* * !* THIS ROUTINE DUMPS CODE FOR BUILT IN NAMES. * !* IT IS VERY MESSY AND COULD DO WITH A COMPLETE * !* RETHINK AND REWRITE. HOWEVER THE SETTING OF * !* ALL THE FLAGS IS CRITICAL SO LOOK OUT ! * !* * !**************************************************************** ! %SHORTROUTINE %RECORDSPEC V(VARFM) %RECORDNAME WORK VAR(VARFM) %RECORD X2, X3(VARFM) %OWNBYTEINTEGER ADDR TYPE %INTEGER A, P, R, N, BINAME, R2, ESAVE, FORMAT NAME %BYTEINTEGER RFLAG, XSAVE %CONSTBYTEINTEGERARRAY EP(13 : 54) = %C 1, 2, 3, 4, 5,19, 9,10,11,12,13,14,15,16,17,18, 6, 7, 8,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,38,39,40, 41,42,0 %ROUTINESPEC CIOCP(%INTEGER R) %SWITCH CN(0 : 55) BINAME = VNAME ESAVE = EFREE; XSAVE = EXPRN TYPE RFLAG = 0; R2 = 0 P = V_INDEX; V = 0 PROTECT(4) %AND PROTECT(8) %IF P >= 12 -> CN(P) CN(0): FAULT(212); V = DUMMYNAME; -> 1 ! CN(1): ! INTEGER CN(2): ! BYTEINTEGER CN(3): ! SHORTINTEGER CN(4): ! REAL CN(5): ! LONGREAL CN(6): ! STRING CN(7): ! RECORD ! TEST STUDENT -> F19 %IF REC(RP) = 2 FAULT(84) %IF P = 7 %AND ASSOP # 1 EXPRN TYPE = B'100'; EXPRN(V) %IF P = 7 %START CLAIM SAFE REGISTER(R); LOAD(V,R) V_FORM = B'10000011' %FINISH %ELSE %START %IF V_TYPE # 0 %START %IF V_FORM&2 = 0 %THEN V_FORM = V_FORM!2 %C %ELSE %START CLAIM SAFE REGISTER(R); LOAD(V,R) V_FORM = V_FORM!2;! IT'S STILL INDIRECT %FINISH V_FLAGS = V_FLAGS&B'11111011' %FINISH %ELSE %START V_FORM = V_FORM!2 %IF V_FORM&128 # 0 %FINISH V_FORM = V_FORM!1; ! SET VARIABLE BIT %FINISH V_DIMENSION <- V_TYPE V_TYPE = TYPE CODE(P); V_LENGTH = 255 -> TINDEX ! CN(10): ! ADDR ! TEST STUDENT -> F19 %IF REC(RP) = 2 GET NAME VAR(V,22) FAULT(22) %IF V_FORM&3 = 0 ADDR TYPE = V_TYPE; BINAME = VNAME %IF V_FORM&128 = 0 %START V_FORM = V_FORM!2 %C %IF (V_TYPE = B'10000' %AND V_LENGTH = 0) %C %OR (V_TYPE = B'111' %AND V_FLAGS&4 = 0) V_TYPE = 4 %IF V_FORM&2 = 0 %THEN V_TYPE = 0 V_FLAGS = V_FLAGS!4 V_FORM = V_FORM&B'11111100' TINDEX: %IF V_INDEX # 0 %START CLAIM SAFE REGISTER(R) LOAD(V,R) %FINISH -> NMP %FINISH V_TYPE = 0 %IF V_INDEX # 0 %START DRR(X'1A',V_INDEX,V_ADDRESS) RELEASE REGISTER(V_ADDRESS) V_ADDRESS = V_INDEX V_INDEX = 0; V_TYPE = B'100' %FINISH V_FLAGS = V_FLAGS!4 V_FORM = 128 -> NMP ! CN(55): ! MON_..... FAULT(97) %IF MON LOCK = 0 -> SF19 %IF REC(RP) # 2 RP = RP+1 FAULT(64) %AND %RETURN %IF REC(RP) # 1 ! SUBNAME RP = RP+2; VNAME = REC(RP); ! PICK UP NAME WORK VAR == RECORD(ENAME(DIAG HEAD_INDEX)) V = WORK VAR A = V_ADDRESS; V_ADDRESS = A&X'FFF' V_LENGTH = 255; ! FIDDLE FOR STRINGS AS LENGTH UNKNOWN R = A>>10&X'3C' CLAIM SAFE REGISTER(R2) INDEX PT = R2 DRX(X'58',R2,13,0); ! PICK UP FRAME POINTER DRX(X'58',R2,R2,R); ! PICK UP BASE REGISTER -> NMP CN(54): ! ARRAY(EXPRN, FORMAT) ! TEST STUDENT -> F19 %IF REC(RP) = 2 FAULT(89) %IF ASSOP # 1 INDEX PT = 4 EXPRN TYPE = 4; ! ADDRESSES ARE INTEGERS EXPRN(X2) RP = RP+1; -> F19 %IF REC(RP) = 2 R2 = RP %IF REC(RP+2) # 4 %OR REC(RP+4) # 2 %START AF22: FAULT(22) RP = R2 SKIP EXPRN V = DUMMY NAME %FINISH %ELSE %START RP = RP+6; FORMATNAME = REC(RP) GET INFO(FORMATNAME,V) -> AF22 %IF REC(RP+1) # 2 %OR REC(RP+2) # 2 %C %OR REC(RP+3) # 2 RP = RP+3 %FINISH FAULT2(88,VNAME) %IF V_TYPE&132 = 0; ! NOT A FORMAT LOAD(X2,4); ! REGISTER 4 WILL BE FREE REGUSE(4) = 'C'; ! LOCK REGISTER 4 V_TYPE = V_TYPE&127; ! REMOVE FORMAT BIT V_FORM = B'00000101'; ! MAKE IT LOOK LIKE A RECORD ARRAY -> NMP ! CN(8): ! LENGTH ! -> F19 %IF REC(RP) = 2 C S EXPRN(A) %IF A < 16 %START STUAV(A) GPR1 = ADDR(V) %IF A = 1 EFREE = EFREE+1; ! PROTECT LENGTH BYTE V_FORM = B'10000011' %FINISH %ELSE V_FORM = B'11' V_ADDRESS <- A; V_TYPE = B'101' -> NMP ! CN(11): ! ! NL -> SF19 %IF REC(RP) = 1 V_TYPE = 0; V_FORM = 0; V_ADDRESS <- 10 -> 1 ! CN(12): ! SNL ! -> SF19 %IF REC(RP) = 1 PLANT(PERM SNL) V_TYPE = B'10000'; V_FORM = 128; V_ADDRESS <- 1 S CONST = 1 GPR1 = ADDR(V) -> 1 CN(9): ! TOSTRING -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'100'; EXPRN(V); LOAD(V,1) STR: EFREE = (EFREE+1)&(\1); ! WORK SPACE PLANT(X'40100000'+EFREE&X'FFFF'); GPR1 = 0 ! FORGET IT S CONST = 1 DSI(X'92',EFREE,1) V_TYPE = B'10000'; V_FORM = 1; V_ADDRESS <- EFREE V_LENGTH = 1; V_FLAGS = 4 EFREE = EFREE+2 -> NMP %UNLESS RFLAG = 4; -> 1 CN(13): ! READ CN(14): ! READSYMBOL CN(15): ! READCH -> F19 %IF REC(RP) = 2 GET NAME VAR(X2,22) PROTECT(4) A = CODEIN CIOCP(0) V_ADDRESS = 1; V_TYPE = B'100'; V_FORM = 128 %IF P = 13 %START; ! READ FAULT(22) %IF X2_TYPE&B'10000' # 0 %OR X2_FORM&3 = 0 %IF X2_TYPE&B'1000' # 0 %START; ! REAL PARM V_TYPE = B'1010'; ! LONGREAL V_ADDRESS = 2; ! RESULT IN FPR2 SHORTINTEGER(A+2) = 37 %FINISH %FINISH %ELSE %START FAULT(22) %IF X2_TYPE&B'11000' # 0 %OR X2_FORM&3 = 0 %FINISH ASSOP = 2 STORE(V,X2) V_TYPE = 15; V_FORM = 0 -> NMP CN(16): ! READSTRING CN(17): ! READ ITEM -> F19 %IF REC(RP) = 2 V_INDEX = 10; C C NAME(V) LOAD(V,1) FAULT(22) %UNLESS ADDR TYPE = B'10000' ! STRING CIOCP(1) V_FORM = 0; V_TYPE = 15 -> 1 CN(18): ! WRITE -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'100' EXPRN(V) RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN(X2); R2 = 2 LOAD(X2,2); LOAD(V,1) V_TYPE = 15; V_FORM = 0 RFLAG = 8 -> RT ENTRY CN(19): ! PRINT CN(20): ! PRINTFL -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'1010'; EXPRN(V) RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN TYPE = B'100'; EXPRN(X2); RFLAG = 2 R2 = 1 %IF P # 20 %START; ! PFL RP = RP+1; -> F19 %IF REC(RP) = 2 R2 = 2; EXPRN(X3) LOAD(X3,2) %FINISH LOAD(V,2); LOAD(X2,1) V_TYPE = 15; V_FORM = 0 -> RTENTRY CN(48): ! PROMPT CN(21): ! PRINTSTRING -> F19 %IF REC(RP) = 2; RFLAG = 8 CSEXPRN(A); EFREE = EFREE+256 %IF A < 16 S LOAD(A,1) V_TYPE = 15; V_FORM = 0 R2 = 1; -> RT ENTRY CN(49): ! SELECTINPUT CN(50): ! SELECTOUTPUT CN(51): ! CLOSESTREAM CN(22): ! PRINTSYMBOL CN(23): ! PRINTCH R2 = 1; N = 0; -> NS2 CN(24): ! NEWLINE N = X'4110000A' NS0: P = 22 PLANT(N) V_TYPE = 15; V_FORM = 0; CIOCP(1) -> SF19 %IF REC(RP) = 1 -> 1 CN(25): ! NEWLINES N = 10 NS1: P = 28; R2 = 2 NS2: -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'100'; EXPRN(V); LOAD(V,R2) PLANT(X'41100000'+N) %UNLESS N = 0 RFLAG = 8 CN(53): ! DRAIN CN(52): ! RESUME V_TYPE = 15; V_FORM = 0; -> RT ENTRY CN(26): ! NEWPAGE N = X'4110000C'; -> NS0 CN(27): ! SPACE N = X'41100020'; -> NS0 CN(28): ! SPACES N = 32; -> NS1 CN(29): ! NEXTSYMBOL CN(30): ! NEXTITEM CN(31): ! SKIPSYMBOL -> SF19 %IF REC(RP) = 1 CIOCP(0) -> STR %IF P = 30 V_TYPE = 15; V_FORM = 0 %IF P = 29 %START V_ADDRESS = 1; V_FORM = 128; V_TYPE = B'100' GPR1 = ADDR(V) %FINISH -> 1 CN(32): ! FROMSTRING CN(33): ! CHARNO -> F19 %IF REC(RP) = 2 A = RP; SKIP EXPRN RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN TYPE = B'100'; ! INTEGER PARM WANTED EXPRN(V) R2 = 2 %IF P = 32 %START; ! FROM STRING S CONST = 1 R2 = 3 RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN(X2) %FINISH N = RP; RP = A; C S EXPRN(A); RP = N EFREE = EFREE+256 %IF A < 16 S LOAD(A,1) LOAD(V,2) LOAD(X2,3) %IF P = 32 CIOCP(R2) V = 0 V_ADDRESS = 1; V_FORM = 128 V_TYPE = 4; ! INTEGER (SYMBOL) %IF P = 32 %THEN V_TYPE = 16; ! STRING GPR1 = ADDR(V) -> NMP CN(34): ! INT CN(35): ! INTPT CN(36): ! FRACPT CN(37): ! SIN CN(38): ! COS CN(39): ! TAN CN(40): ! ARCSIN CN(41): ! ARCCOS CN(44): ! SQRT CN(45): ! MOD CN(46): ! LOG CN(47): ! EXP -> F19 %IF REC(RP) = 2 EXPRNTYPE = B'1010'; EXPRN(V); LOAD(V,1) RFLAG = 1 %IF P = 34 %OR P = 35 %START V_ADDRESS = 1; V_TYPE = B'100' RFLAG = 9 %FINISH CIOCP(R2) %IF RFLAG # 1 %THEN GPR1 = ADDR(V) %ELSE FPR2 = ADDR(V) -> NMP CN(42): ! ARCTAN CN(43): ! RADIUS -> F19 %IF REC(RP) = 2 EXPRN TYPE = B'1000' EXPRN(V) RP = RP+1; -> F19 %IF REC(RP) = 2 EXPRN(X2) LOAD(X2,2) LOAD(V,1) RFLAG = 3 CIOCP(2) FPR2 = ADDR(V) ->NMP SF19: %UNTIL REC(RP) = 2 %CYCLE SKIP EXPRN; RP = RP+1 %REPEAT F19: FAULT2(19,BINAME); V = DUMMY NAME; -> 1 FN: -> STR %IF P = 30 %IF RFLAG = 12 %START V_ADDRESS = X'E000' V_TYPE = ADDR TYPE V_FORM = 1 %FINISH V_ADDRESS <- 1; V_TYPE = B'100'; V_FORM = 128; -> 1 RT ENTRY: CIOCP(R2) -> 1 %IF RFLAG = 0 -> FN %IF RFLAG&4 # 0 ! ! CHECK THERE ARE NO MORE PARAMETERS ! NMP: RP = RP+1; -> SF19 %IF REC(RP) = 1 1: VNAME = BINAME; EXPRN TYPE = XSAVE EFREE <- ESAVE; %RETURN ! !******************************************************************** !* * !* %SYSTEMROUTINE I8IOCP(%INTEGER EP,IP1,%LONGREAL RP1,RP2) * !* * !******************************************************************** ! %ROUTINE CIOCP(%INTEGER R) NASTY = 1 PLANT(X'41000000'+EP(P)); ! SERVICE NUMBER RTSAVE(R) *XC_GPR1(8),GPR1 %IF RFLAG&1 # 0 %THEN PLANT(X'6020B048') %IF RFLAG&2 # 0 %THEN PLANT(X'6040B050') PLANT(X'45FC0000'!23<<2) %END %END %ROUTINE VAR(%RECORDNAME V) ! RP ON P(VAR)-1 %SHORTROUTINE %RECORDSPEC V(VARFM) %RECORDNAME VV(VARFM) %ROUTINESPEC CRFM %ROUTINESPEC CAREF %INTEGER INDEX, FLIST; %BYTEINTEGER REC FLAG, NSFLAG RP = RP+2; VNAME = REC(RP); ! NAME OF VARIABLE REC FLAG = 0; NSFLAG = 0 INDEX = 0; ! INDEX REGISTER *L_1,VNAME; *L_2,V; *L_3,DICT HEAD *L_1,4(3,1) *LTR_1,1; *BC_8,; ! ZERO => NOT SET *MVC_0(12,2),0(1) -> 3 NNS: FAULT2(16,VNAME); ! NAME NOT DECLARED NSFLAG = 1 %IF LEVEL > 1 %START; ! DECLARE THE NAME VV == RECORD(NEW CELL) VV = DUMMY NAME VV_LEVEL = LEVEL INTEGER(VNAME+DICTHEAD+4) = ADDR(VV) %FINISH 1: RELEASE REGISTER(INDEX); INDEX = 0 V = DUMMYNAME; SUSPEND = 'Y' 3: %IF V_FLAGS&1 # 0 %THEN FAULT2(21,VNAME) %AND -> 1 FAULT2(20,VNAME) %AND -> 1 %IF V_TYPE > 30 OLD INDEX = V_INDEX; ! REMEMBER IT FOR REC1=REC2 RP = RP+1 %IF V_LEVEL = 0 %C %THEN INDEXPT == INDEX %AND CCNAME(V) %ELSE %START V_TYPE = 4 %AND FAULT2(12,VNAME) %IF V_TYPE = 13 %IF V_FORM&B'1100' # 0 %START; ! RFM OR ARRAY %IF V_FORM&B'100' # 0 %THEN CAREF %ELSE CRFM %FINISH %ELSE %START V_DIMENSION = 255 %AND CAREF %IF REC(RP) = 1 %FINISH %FINISH ! NOW TEST FOR (ENAME) RP = RP+1 %IF REC(RP) = 1 %START; ! (ENAME) FOUND REC FLAG = 1 FAULT2(19,VNAME) %C %IF V_FORM&B'1100' # 0 %AND NSFLAG = 0 RP = RP+2; VNAME = REC(RP); ! SKIP P(VAR) / SUB-NAME %IF V_TYPE # B'111' %START FAULT2(69,VNAME) %IF NSFLAG = 0 -> 1 %FINISH V_FORM = V_FORM!2 %IF V_FLAGS&4 = 0 FLIST = V_INDEX; V_INDEX = INDEX; V_TYPE = B'100' CLAIM SAFE REGISTER(INDEX) %IF INDEX = 0 LOAD ADDR(V,INDEX) WORK == RECORD(ENAME(FLIST)); V = WORK %IF V_LEVEL = 255 %C %THEN RELEASEREGISTER(INDEX) %AND SUSPEND = 'Y' V_DIMENSION = V_DIMENSION&3 V_LEVEL = 1 %IF V_LEVEL = 0 ! TO PREVENT FAULT 212 FROM _A ETC. -> 3 %FINISH V_INDEX = INDEX; CPELEN = V_LENGTH %RETURN ! %ROUTINE CRFM ! COMPILES ROUTINE/FN/MAP/PREDICATE REFERENCES ! MAY BE DUBIOUS IN DEALING WITH MAPNAME PARMS ! %RECORD PARM(VARFM) %LONGREAL REGS1 %INTEGER ESAVE, A, TNAME, AD %BYTEINTEGER XSAVE PROTECT(4); PROTECT(8) ESAVE = EFREE %IF REC(RP) = 2 %START; ! NO PARMS GIVEN %IF V_INDEX = 0 %START; ! NONE WANTED RT SAVE(14) %AND -> ENTRY %C %IF MAPV = 1 %OR ASSOP # 1 %RETURN %FINISH %RETURN %IF ASSOP <= 1 A = 21 %IF V_INDEX >= 0 %C %THEN A = 19 %AND RELEASEREGISTER(V_INDEX) V_INDEX = 0 FAULT2(A,VNAME) %IF NSFLAG = 0 V_FORM = 1; V_TYPE = B'100' %RETURN %FINISH ! PARMS GIVEN -> SFLT %UNLESS V_INDEX > 0 *L_1,AREG; ! %CYCLE P=4,1,8 *MVC_REGS1(5),0(1); ! REGSAVE(P)=REGUSE(P): REGUSE(P)=0 *XC_0(5,1),0(1); ! %REPEAT TNAME = VNAME RT SAVE(14) XSAVE <- EXPRN TYPE WORK == RECORD(V_INDEX); PARM = WORK 1: ASSOP = PARM_FLAGS>>6 MAPV = 0 %IF PARM_FORM&B'1000' = 0 %THEN MAPV = 1 ASSIGN(PARM,ASSOP); ! COMPILE PARAMETER RP = RP+1 %IF REC(RP) = 1 %START %IF PARM_LINK = 0 %START SFLT: FAULT2(19,VNAME) %IF NSFLAG = 0 SKIP EXPRN %AND RP = RP+1 %UNTIL REC(RP) = 2 -> ENTRY0 %FINISH WORK == RECORD(PARM_LINK); PARM = WORK EFREE = PARM_ADDRESS -> 1 %FINISH FAULT2(19,VNAME) %UNLESS PARM_LINK = 0 %OR NSFLAG = 1 ENTRY0: *L_1,AREG; *MVC_0(5,1),REGS1 ! %CYCLE P=4,1,8: REGUSE(P)=REGSAVE(P): %REPEAT VNAME = TNAME; EXPRN TYPE = XSAVE ENTRY: EFREE = ESAVE %IF 0 # V_TYPE # 15 %START %IF V_TYPE&8 = 0 %THEN GPR1 = ADDR(V) %C %ELSE FPR2 = ADDR(V) %FINISH A = V_FLAGS>>4&3; ! SORT OF ROUTINE ! 1 = NORMAL, 2 = EXTERNAL, 3 = PARAM AD = V_ADDRESS&X'FFFF' %IF RT MON ENABLE # 0 %AND A # 3 %START ! MONITOR IT PLANT(X'41E00000'+AD); ! @ENTRY VECTOR PLANT(X'41000000'+(AD-RTBASE)>>4&255) ! RT INDEX PLANT(RT MON ENTRY); ! OFF TO PERM %FINISH %ELSE %START %IF A = 1 %THEN PLANT(AD+X'58E00008') %ELSE %START %IF A = 2 %THEN PLANT(AD+X'98CE0000') %C %ELSE %START PLANT(X'58E00000'+AD) PLANT(X'98CFE000') PLANT(X'9849F010') %FINISH %FINISH SPLANT(X'05FE') %FINISH NASTY = 1 V_FORM = V_FORM&B'11' V_FORM = V_FORM!129 V_FORM = 0 %IF V_TYPE = 15 %OR V_TYPE = 14 V_ADDRESS = 1 %IF V_TYPE&B'1000' # 0 %THEN V_ADDRESS = 2 %END %ROUTINE CAREF ! COMPILES ARRAY REFERENCES ! THE TEST ON ARRAYNAMES COULD BE DONE BY THE ! COMPILER BUT IT IS VERY TEDIOUS %RECORD S, P(VARFM) %INTEGER N, XSAVE, ESAVE, PERM, R, TNAME, SINDEX N = 0; ! COUNT FOR NUMBER OF DIMENSIONS %IF REC(RP) = 1 %START; ! PARMS GIVEN PROTECT(4) S_FORM = 1 S_INDEX = 0; S_TYPE = B'100'; S_ADDRESS <- EFREE ESAVE = EFREE; XSAVE = EXPRNTYPE EXPRNTYPE = B'100' SINDEX = OLD INDEX R = 2 TNAME = VNAME %CYCLE EXPRN(P) RP = RP+1; N = N+1 %EXIT %IF REC(RP) # 1; ! NO MORE PARMS STORE(P,S); ! WILL LOAD IF NEEDED EFREE = EFREE+4 S_ADDRESS <- EFREE GPR1 = 0; ! FORGET IT %REPEAT %IF N > 1 %START; ! MULTI-DIMENSIONAL STORE(P,S); DRX(X'41',1,0,EFREE) EFREE = ESAVE; PERM = X'45FC0008' %FINISH %ELSE %START LOAD(P,1); PERM = X'45FC0004' GPR1 = 0; ! FORGET IT %FINISH EXPRNTYPE = XSAVE %IF V_DIMENSION&7 # N %START %IF V_DIMENSION&7 # 0 %START FAULT2(19,VNAME) %IF NSFLAG = 0 %FINISH %ELSE %START BYTEINTEGER(INTEGER(VNAME+DICTHEAD+4)+5) %C <- N %UNLESS REC FLAG = 1 %OR V_LEVEL = 255 %FINISH %FINISH V_DIMENSION = 0 VNAME = TNAME %FINISH %ELSE %START R = 1 FAULT2(19,VNAME) %UNLESS ASSOP = 1 %OR NSFLAG = 1 %FINISH DOPE VECTOR = V_ADDRESS&X'FFFF' %IF V_FORM&B'10000' = 0 %START %IF R = 1 %THEN R = DOPEVECTOR %C %ELSE DRX(X'41',2,0,DOPEVECTOR) %FINISH %ELSE %START %IF INDEX # 0 %START %IF R = 1 %THEN R = INDEX %C %ELSE RELEASE REGISTER(INDEX) DRX(X'41',R,INDEX,DOPEVECTOR) V_FORM = V_FORM!128 INDEX = 0 %FINISH %ELSE %START %IF R = 1 %THEN R = DOPE VECTOR %C %ELSE PLANT(X'41200000'+DOPE VECTOR) %FINISH %FINISH V_ADDRESS <- R %IF N # 0 %START %IF V_FORM&B'10000' # 0 %AND N > 1 %START PLANT(X'58F20008') DSI(X'95',X'F001',N) PLANT(X'477C0000'!29<<2); ! CORRUPT DOPE-VECTOR %FINISH PLANT(PERM) V_FORM = B'10000011' V_ADDRESS <- 1; V_FLAGS = V_FLAGS!4 ! FOR STRINGS V_DIMENSION = 7; ! TO SHOW AN ARRAY GPR1 = ADDR(V); ! PROTECT IT %FINISH OLD INDEX = S INDEX %END %END ! THE REGISTER ALLOCATION MECHANISM WILL BE IMPROVED IN FUTURE ! AS THE REGISTER SEARCH IS ONLY STARTED FROM THE CURRENT ! BASE REGISTER, THERE IS NO NEED TO CLAIM THAT REGISTER. ! THE NEW ROUTINES WILL KEEP ALL INFORMATION ABOUT REGISTERS ! IN AN INTEGER, ONE BYTE PER AVAILABLE REGISTER ! ZERO INDICATING FREE ! HENCE AFTER COMPILING EACH STATEMENT THIS INTEGER ! CAN BE CLEARED, THUS AVIODING SOME FAULT 200'S ! SO THERE ! ! %ROUTINE CLAIMSAFEREGISTER(%INTEGERNAME REGISTER) ! RETURNS A REGISTER IN THE RANGE 4 <= REGISTER <= 8, ! AS THESE REGISTERS ARE SAVED AND RESTORED ON ! FUNCTION ENTRY AND EXIT. %SHORTROUTINE REGISTER = BASE REG; ! TOP LIMIT OF FREE REGISTERS %WHILE REGISTER > 4 %CYCLE REGISTER = REGISTER-1 %IF REGUSE(REGISTER) = 0 %START REGUSE(REGISTER) = 'C'; ! LOCK THE REGISTER %RETURN %FINISH %REPEAT FAULT(200) %IF SUSPEND = 'N' REGISTER = 3 ! SUSPEND IS SET AFTER VARIOUS FAULTS (E.G. FAULT 16) ! IN ORDER TO INHIBIT SPURIOUS FAULT MESSAGES (> 200) %END %ROUTINE RELEASEREGISTER(%INTEGER REGISTER) %IF REGISTER = 1 %THEN GPR1 = 0 %AND -> 1 -> 1 %UNLESS 4 <= REGISTER <= 8 %IF REGUSE(REGISTER) # 'C' %START FAULT(201) %IF SUSPEND = 'N' %FINISH REGUSE(REGISTER) = 0 1: %END %ROUTINE PROTECT(%BYTEINTEGER TYPE) ! GPR1 CONTAINS THE ADDRESS OF THE DESCRIPTOR OF ANY ! TEMPORARY RESULT IN REGISTER 1. ! GPR1 = 0 => REGISTER 1 FREE ! SIMILARLY FOR FPR2 %SHORTROUTINE %INTEGER R %RECORDNAME V(VARFM) %IF TYPE = 4 %START %RETURN %IF GPR1 = 0 V == RECORD(GPR1) %IF REG USE(6) = 0 %START CLAIMSAFEREGISTER(R) DRR(X'18',R,V_ADDRESS); V_ADDRESS <- R %FINISH %ELSE %START TEMPREAL(R); DRX(X'50',V_ADDRESS,0,R) V_ADDRESS = R; V_FORM = V_FORM&B'01111111' %FINISH GPR1 = 0; ! FORGET IT %FINISH %ELSE %START %RETURN %IF FPR2 = 0 TEMPREAL(R) V == RECORD(FPR2) FPR2 = 0; ! FORGET IT DRX(X'60',V_ADDRESS,0,R) V_ADDRESS <- R V_FORM = 1 V_TYPE <- B'1011'; ! TO PREVENT UAV TEST %FINISH %END %ROUTINE EQUATETYPES(%RECORDNAME LHS, RHS) ! FLOATS PARTS OF EXPRNS AS NESC. ! THERE IS A FAULT AROUND THE AREA OF %IF REAL=INTEGER=REAL ! WHICH MAY BE IN HERE !!!!! %SHORTROUTINE %RECORDSPEC LHS(VARFM) %RECORDSPEC RHS(VARFM) %IF RHS_TYPE&B'1000' # 0 %START;! RHS REAL %IF LHS_TYPE&B'1000' = 0 %START; ! LHS INTEGER FLOAT(LHS,2) %FINISH %FINISH %ELSE %START %IF LHS_TYPE&B'1000' # 0 %THEN FLOAT(RHS,4) %FINISH %END %ROUTINE LOAD(%RECORDNAME V, %INTEGER R) %SHORTROUTINE %RECORDSPEC V(VARFM) %INTEGER A, X, CODE %BYTEINTEGER RFLAG %IF V_TYPE = 0 %AND V_ADDRESS = 0 %START ! ZERO PROTECT(4) %IF R = 1 %IF V_INDEX = 0 %THEN DRR(X'1F',R,R) %ELSE %START RELEASE REGISTER(V_INDEX) %C %AND DRR(X'18',R,V_INDEX) %UNLESS R = V_INDEX %FINISH V_ADDRESS = R -> SET TYPE %FINISH RFLAG = 0 %IF V_TYPE&B'1000' # 0 %THEN R = R<<1 %AND RFLAG = 1 CODE = LOADCODE(V_TYPE); ! GIVES 'LA' FOR SMALL CONSTANTS A = V_ADDRESS; X = V_INDEX; V_ADDRESS = R; V_INDEX = 0 FAULT(-CODE) %AND CODE = X'58' %IF CODE < 0 ! GIVES FAULTS 42 , 23 , 64 %IF V_FORM&2 # 0 %START; ! INDIRECT %IF V_FORM&128 # 0 %START RELEASE REGISTER(A) A = A<<12 %FINISH %ELSE %START DRX(X'58',15,X,A) RELEASE REGISTER(X) %UNLESS R = X %AND RFLAG = 0 TEST UAV(4,15) %UNLESS A&X'F000' = X'D000' A = X'F000'; X = 0 %FINISH %FINISH %ELSE %START %IF V_FORM&128 # 0 %START %IF X # 0 %START FAULT(208) %IF RFLAG # 0 %IF R = X %OR R = A %START %IF R = X %THEN X = A RELEASE REGISTER(X) DRR(X'1A',R,X) -> SET INFO %FINISH DRX(X'41',R,X,A<<12) RELEASE REGISTER(X); RELEASE REGISTER(A) -> SET INFO %FINISH %IF R # A %START %IF R = 2 %AND RFLAG = 1 %START PROTECT(8); FPR2 = ADDR(V) %FINISH %ELSE %START %IF R = 1 %AND RFLAG = 0 %AND A > 1 %START PROTECT(4); GPR1 = ADDR(V) %FINISH %FINISH %IF CODE = X'41' %THEN CODE = X'18' %ELSE %START %IF CODE = X'7A' %THEN CODE = X'38' %FINISH DRR(CODE&63,R,A) %IF RFLAG = 0 %THEN RELEASE REGISTER(A) %C %ELSE %START FPR2 = 0 %IF A = 2 %FINISH %FINISH -> SET INFO %FINISH %FINISH %IF R = 1 %AND X # 1 %AND A # X'1000' %START PROTECT(4) GPR1 = ADDR(V) %FINISH %ELSE %START %IF R = 2 %AND RFLAG = 1 %START PROTECT(8) FPR2 = ADDR(V) %FINISH %FINISH DRR(X'2B',R,R) %IF CODE = X'7A';! SRD_R,R FOR NORMAL REALS DRX(CODE,R,X,A); ! LOAD THE VAR RELEASE REGISTER(X) %UNLESS R = X %AND RFLAG = 0 DRX(X'54',R,13,6<<2) %IF CODE = X'43' ! & OFF BOTTOM BYTE TESTUAV(V_TYPE,R) %UNLESS A&X'F000' = X'D000' SET TYPE: V_TYPE = LOADTYPE(V_TYPE); ! EG SHORT => INTEGER SET INFO: V_FORM = 128 %END %ROUTINE LOADADDR(%RECORDNAME V, %INTEGER REG) %SHORTROUTINE %RECORDSPEC V(VARFM) %IF V_FORM&128 # 0 %START FAULT(82) %UNLESS V_FORM&2 # 0 %IF V_INDEX = 0 %START %IF REG # V_ADDRESS %START PROTECT(4) %AND GPR1 = ADDR(V_ADDRESS) %C %IF REG < 2 RELEASE REGISTER(V_ADDRESS) DRR(X'18',REG,V_ADDRESS) V_ADDRESS <- REG %FINISH V_FORM = 128 %RETURN %FINISH V_FORM = 128; V_TYPE = 0 %FINISH %ELSE %START FAULT(82) %IF V_FORM&3 = 0 V_TYPE = 0 %IF V_FORM&6 = 2 %START V_FORM = 1 V_TYPE = B'100' %FINISH %FINISH LOAD(V,REG) %END %ROUTINE EXPRN(%RECORDNAME LHS) %SHORTROUTINE %ROUTINESPEC OPERAND(%RECORDNAME R, %INTEGER REG) %ROUTINESPEC OPERATE %RECORDSPEC LHS(VARFM) %INTEGERARRAY OLDOP(1 : 2) %RECORDARRAY TEMP(1 : 3)(VARFM) %RECORDNAME RHS(VARFM) %CONSTBYTEINTEGERARRAY PRIORITY(0 : 16) = 0,1,1,2,1,1, 3,3,3,2,2,2,2,1,1,4,1 %INTEGER OP, NEXTOP, P, R, STACK, PT, ESAVE, NSAVE RP = RP+1; NEXTOP = REC(RP+1)+12; ! (PLUS) R = 1; ! FOR (PLUS) LOAD INTO GR1 RHS == TEMP(1) STACK = 0; PT = 0; ESAVE = EFREE; NSAVE = VNAME 1: OP = NEXTOP RP = RP+2; P = REC(RP); ! POINTER TO (REST OF EXPRN) NEXTOP = 0 %IF REC(P) = 1 %THEN NEXTOP = REC(P+1) %IF PRIORITY(NEXTOP) > PRIORITY(OP) %START R = 2; ! NEXT RHS TO REGISTER 2 PT = PT+1 OLDOP(PT) = ADDR(LHS); ! SAVE LHS LHS == TEMP(PT); RHS == TEMP(PT+1) OPERAND(LHS,1) STACK = STACK<<8!OP; ! SAVE OPERATOR RP = RP+1 -> 1 %FINISH OPERAND(RHS,R); RP = RP+1;! SKIP PAST (REST OF EXPRN) 2: OPERATE %IF STACK # 0 %START OP = STACK&255 %IF PRIORITY(OP) >= PRIORITY(NEXTOP) %START STACK = STACK>>8 RHS == LHS LHS == RECORD(OLDOP(PT)) PT = PT-1 -> 2 %FINISH %FINISH %IF NEXTOP # 0 %THEN R = 2 %AND -> 1 EFREE = ESAVE; VNAME = NSAVE %RETURN %ROUTINE OPERAND(%RECORDNAME R, %INTEGER REG) %RECORDSPEC R(VARFM) %SWITCH OTYPE(1 : 4) %INTEGER CODE %BYTEINTEGER SAVE RP = RP+1; CODE = REC(RP) -> OTYPE(CODE) ! OTYPE(2): ! VAR ! ZERO EXP = ZERO EXP!2; ! INHIBIT ZERO EXPRNS. VAR(R) %IF R_TYPE&B'1110' = B'1110' %C %THEN FAULT2(23,VNAME) %AND R_TYPE = B'100' %C %ELSE %START %IF R_TYPE = 7 %START; ! RECORD FAULT(64) %UNLESS EXPRN TYPE = 7 %FINISH %ELSE %START %IF R_TYPE = 16 %C %THEN FAULT(42) %AND R_TYPE = 4 %ELSE %START %IF R_TYPE&B'1000' # 0 %START %IF EXPRNTYPE&B'1000' = 0 %C %THEN FAULT(24) %C %ELSE EXPRN TYPE = B'1010' ! FOR COND EXPRNS %FINISH %FINISH %FINISH %FINISH %IF R_FORM&B'1100' # 0 %THEN FAULT2(19,VNAME) %RETURN ! OTYPE(1): ! CONSTANT ! CCONST(R); ! SETS TYPE FOR 'LA' IF POSSIBLE %IF R_TYPE = B'1011' %AND R_ADDRESS = 0 %START ! REAL ZERO REG = REG<<1 PROTECT(8) %AND FPR2 = ADDR(R) %IF REG = 2 DRR(X'2B',REG,REG) R_TYPE = B'1010' R_FORM = 128 R_ADDRESS = REG %RETURN %FINISH FAULT(42) %AND R = DUMMY NAME %IF R_TYPE&16 # 0 ! STRINGS %IF R_TYPE&B'1000' # 0 %START %IF EXPRNTYPE&B'1000' = 0 %THEN FAULT(24) %C %ELSE EXPRN TYPE = B'1010' ! FOR COND EXPRNS %FINISH %RETURN ! OTYPE(3): ! '(' (EXPRN) ')' OTYPE(4): ! '!' (EXPRN) '!' ! SAVE = EXPRNTYPE %IF SAVE&B'1000' # 0 %THEN EXPRNTYPE = B'1100' EXPRN(R) EXPRN TYPE = SAVE %IF R_TYPE&B'1000' # 0 %C %THEN EXPRN TYPE = B'1010' %ELSE %START ! NOW FLOAT AS NESC. BUT REMEMBER NOT TO IN THE CASE OF ! REAL = ???** (INTEGER EXPRN) %IF EXPRN TYPE&B'100' = 0 %AND OP # 8 %C %THEN FLOAT(R,REG<<1) %FINISH %IF CODE = 4 %START LOAD(R,REG) CODE = X'10' %IF R_TYPE = B'1010' %THEN CODE = X'20' DRR(CODE,R_ADDRESS,R_ADDRESS) %FINISH %END %ROUTINE OPERATE %INTEGER R %SWITCH OPT(1 : 16) R = 1; ! LHS REGISTER ZERO EXP = ZERO EXP!2 %UNLESS OP = 16 ! DISABLE ZERO EXPRNS -> OPT(OP) ! ASSN: %IF RHS_TYPE = 4 %C %THEN LHS_ADDRESS = 1 %AND GPR1 = ADDR(LHS) %C %ELSE LHS_ADDRESS = 2 %AND FPR2 = ADDR(LHS) -> COPY OPT(16): ! OPT(13): ! '+' PASSN: %IF RHS_TYPE > 1 %AND RHS_TYPE&EXPRNTYPE = 0 %C %THEN FLOAT(RHS,0) LHS_ADDRESS <- RHS_ADDRESS %IF GPR1 = ADDR(RHS) %THEN GPR1 = ADDR(LHS) %C %ELSE %START %IF FPR2 = ADDR(RHS) %THEN FPR2 = ADDR(LHS) %FINISH COPY: LHS_TYPE = RHS_TYPE LHS_FORM = RHS_FORM LHS_LEVEL = RHS_LEVEL LHS_DIMENSION = RHS_DIMENSION LHS_LENGTH = RHS_LENGTH LHS_FLAGS = RHS_FLAGS LHS_INDEX = RHS_INDEX %RETURN ! OPT(14): ! '-' ! AVAILABLE(R,RHS_TYPE); ! FIND A SAFE REGISTER: GR1 IF FREE LOAD(RHS,R) R = RHS_TYPE<<2&B'110000'!3; ! LCR / LCDR DRR(R,RHS_ADDRESS,RHS_ADDRESS) -> PASSN ! OPT(15): ! '\' ! FAULT(24) %IF RHS_TYPE&B'1000' # 0 AVAILABLE(R,4) LOAD(RHS,R) DRX(X'57',R,13,16); ! R = R!!(-1) -> PASSN ! OPT(10): ! '//' ! R = 0 ! OPT(3): ! '&' OPT(4): ! '!!' OPT(5): ! '!' OPT(6): ! '<<' OPT(7): ! '>>' ! FAULT(24) %IF LHS_TYPE&B'1000' # 0 %C %OR RHS_TYPE&B'1000' # 0 DOP: ! OPT(1): ! '+' OPT(2): ! '-' OPT(9): ! '*' ! EQUATETYPES(LHS,RHS) LOAD(RHS,2) %IF RHS_TYPE&B'1000' # 0 %START R = 1 OP = OP+12 %FINISH LOAD(LHS,R) %IF R = 0 %THEN PROTECT(4) %AND PLANT(X'8E000020') %IF OP = 9 %AND LHS_TYPE&B'1000' = 0 %START ! '*' SPLANT(X'1C02') ! SLDA TO PROVOKE OVERFLOW IF TOO BIG PLANT(X'8F000020'); SPLANT(X'1810') LHS_ADDRESS <- 1 GPR1 = ADDR(LHS) -> ASSN %FINISH %IF OP # 6 %AND OP # 7 %C %THEN DRR(OPCODE(OP),LHS_ADDRESS,RHS_ADDRESS) %C %ELSE DRX(X'8F'-OP,LHS_ADDRESS,0,RHS_ADDRESS<<12) RELEASE REGISTER(RHS_ADDRESS) %IF RHS_TYPE&B'100' # 0 %IF R = 0 %START %IF OP # 10 %START SPLANT(X'1200'); ! TEST REMAINDER PLANT(X'477C0000'+13<<2); ! NON-INTEGER QUOTIENT %FINISH GPR1 = ADDR(LHS) LHS_ADDRESS = 1 %FINISH -> ASSN ! OPT(12): ! '.' ! FAULT(42) OP = 1 -> DOP ! OPT(11): ! '/' ! %IF EXPRNTYPE&B'1000' # 0 %START; ! REAL EXPRN EXPRNTYPE = B'1010'; ! MAKE THE EXPRN REAL (CONDS) R = 1 %IF RHS_TYPE&B'1000' = 0 %THEN FLOAT(RHS,4) -> DOP %FINISH R = 0 %IF EXPRNTYPE&B'100' # 0 -> DOP ! OPT(8): ! '**' ! %IF RHS_TYPE&B'1000' # 0 %START; ! REAL %IF RHS_TYPE&1 = 0 %THEN FAULT(39) %ELSE %START ! RHS HAS BEEN FLOATED BY CCONST SO UN-FLOAT IT R = RHS_ADDRESS %IF R = 0 %THEN RHS_TYPE = B'100' %ELSE %START GLA = GLA-8; R = INT(LONGREAL(GLA)) FAULT(39) %UNLESS R>>12 = 0 RHS_TYPE = 0; RHS_ADDRESS = R %FINISH %FINISH %FINISH LOAD(RHS,2) R = LOADTYPE(LHS_TYPE) RHS_TYPE = R %IF EXPRNTYPE&B'1000' # 0 %START; ! REAL EXPRN EXPRNTYPE = B'1010'; ! MAKE THE EXPRN REAL (CONDS) %IF R # B'1010' %C %THEN FLOAT(LHS,2) %AND RHS_TYPE = B'1010' %C %ELSE LOAD(LHS,1) R = 0; ! TO FORCE A REAL EXPONENTIATION %FINISH %ELSE LOAD(LHS,1) OP = X'45FC0000'+11<<2 %IF R # B'100' %THEN OP = X'45FC0000'+12<<2 PLANT(OP) -> ASSN %END %END %ROUTINE STORE(%RECORDNAME VAR, DEST) %SHORTROUTINE %RECORDSPEC VAR(VARFM) %RECORDSPEC DEST(VARFM) %INTEGER R, CODE, MASK, A, X, L1, L2, PERM; %BYTEINTEGER TYPE X = DEST_INDEX; TYPE = DEST_TYPE %IF TYPE = 7 %AND (VAR_TYPE = 7 %OR ZERO EXP = 1) %START ! RECORD=RECORD L2 = R V LEN(LHS INDEX);! LENGTH OF LHS L1 = L2 L1 = R V LEN(OLD INDEX) %IF ZERO EXP = 1 FAULT(84) %IF L1 <= 0 %OR L2 <= 0 %C %OR (STUDENT # 0 %AND LHS INDEX # OLD INDEX) %IF L1 # L2 %START L1 = L2 %IF L2 > L1; ! MOVE IN MINIMUM FAULT(46) %IF ASSOP # 3 %OR L1 > 4096 %FINISH DEST_TYPE = 4 DEST_FORM = DEST_FORM!2 %IF DEST_FLAGS&4 = 0 LOAD ADDR(DEST,2); ! @ LHS %IF ZERO EXP = 1 %THEN PERM = X'45FC0000'+32<<2 %C %ELSE %START PERM = X'45FC0000'+30<<2 VAR_TYPE = 4 VAR_FORM = VAR_FORM!2 %IF VAR_FLAGS&4 = 0 LOAD ADDR(VAR,1); ! @ RHS %FINISH PLANT(X'41000000'+L1); ! LENGTH PLANT(PERM); ! BULK MOVE %RETURN %FINISH %IF DEST_FORM&2 # 0 %START %IF DEST_FORM&128 = 0 %START LOAD ADDR(DEST,14) ! X RELEASED IN 'LOAD ADDR' (I HOPE !) X = 0 %FINISH %FINISH RELEASE REGISTER(X) %IF VAR_FORM&128 = 0 %OR VAR_FORM&2 # 0 %C %THEN LOAD(VAR,3) ! ALWAYS SAFE IN GPR3 %OR FPR6 R = VAR_ADDRESS %IF R < 2 %AND VAR_TYPE&B'1000' = 0 %THEN GPR1 = 0 %C %ELSE %START %IF R = 2 %AND VAR_TYPE = B'1010' %THEN FPR2 = 0 %FINISH CODE = STORECODE(TYPE) FAULT(-CODE) %AND CODE = X'43' %IF CODE < 0 A = DEST_ADDRESS RELEASE REGISTER(A) %AND A = A<<12 %IF DEST_FORM&128 # 0 RELEASE REGISTER(R) %UNLESS CODE&X'F0' > X'50' DRX(CODE,R,X,A) %IF SNLEN # 0 %START; ! PLUG IN STRING MAX LENGTH %IF X # 0 %START AVAILABLE(L1,4); RELEASE REGISTER(L1) DRX(X'41',L1,X,A) L1 = L1<<12 %FINISH %ELSE L1 = A DSI(X'92',L1,SNLEN) SNLEN = 0 %FINISH %IF (TYPE = B'101' %OR TYPE = B'110') %C %AND ASSOP = 2 %AND TUAV # 0 %START %IF TYPE = B'101' %START MASK = 2; CODE = X'55'; A <- X'D018' X = 0 %FINISH %ELSE %START MASK = 7 CODE = X'49' %FINISH DRX(CODE,R,X,A) DRX(X'47',MASK,12,4<<2) %FINISH %END %ROUTINE ASSIGN(%RECORDNAME LHS, %INTEGER ASSOP) !* RP ON P(ASSOP) %SHORTROUTINE %RECORDSPEC LHS(VARFM) %RECORD RHS, TEMP(VARFM) %SWITCH ATYPE(0 : 4), NTYPE(0 : 3) %INTEGER A, B, F, X, N, DV %BYTEINTEGER SLEN, VTYPE TEMP = LHS LHS INDEX = OLD INDEX -> ATYPE(ASSOP) %ROUTINE SJAM; ! FIDDLES R3 FOR MINIMUM LENGTH IN STRING <- %IF TEMP_DIMENSION = 7 %START DRX(X'58',15,0,DOPE VECTOR+8) B = X'4330F003' -> 1 %FINISH %IF SLEN # 0 %START DSI(X'95',X'1000',SLEN) PLANT(X'474A0000'+FORWARD ADDRESS(8)) PLANT(X'41300000'+SLEN) %FINISH %ELSE %START DRX(X'41',15,X,B); B = X'4330F000' 1: PLANT(X'D5001000'); SPLANT(B) PLANT(X'474A0000'+FORWARD ADDRESS(8)) PLANT(B) %FINISH PLANT(X'443D0002'+20<<2); ! MOVE IN STRING ! NOW JAM IN LENGTH PLANT(X'42320000'); !STC_3,0(2) %END ! ASSOP = 1 FOR '==' ! = 2 FOR '=' ! = 3 FOR '<-' ! = 4 FOR '->' ATYPE(2): ! '=' ATYPE(3): ! '<-' ! EXPRN TYPE = LHS_TYPE %IF EXPRN TYPE&B'10000' = 0 %START; ! NUMERICAL EXPRNS EXPRN(RHS); STORE(RHS,LHS) %FINISH %ELSE %START SLEN <- LHS_LENGTH LHS_TYPE = B'100' B = LHS_ADDRESS; X = LHS_INDEX LHS_FORM = LHS_FORM&B'11111101' %C %UNLESS B = 1 %AND LHS_FORM&128 # 0 DV = DOPE VECTOR; C S EXPRN(A); DOPE VECTOR = DV %IF LHS_FLAGS&4 # 0 %THEN LOADADDR(LHS,2) %C %ELSE LOAD(LHS,2) SLOAD(A,1); S CPE(TEMP,X'1000') %IF ASSOP # 3 PLANT(X'43310000'); ! PICK UP ACTUAL LENGTH OF STRING %IF ASSOP = 3 %THEN SJAM %C %ELSE PLANT(X'443D0002'+20<<2) %FINISH -> 1 ! ATYPE(0): ! ????? FAULT(210); SKIP EXPRN; -> 1 ATYPE(1): ! '==' ! %IF LHS_ADDRESS&X'F000' # X'B000' %THEN F = 83 %C %ELSE F = 22 %IF REC(RP+2) # 4 %OR REC(RP+4) # 2 %C %OR REC(REC(RP+3)) # 2 %START %IF F = 83 %THEN F = 81 %ELSE F = 22 FAULT(F) SKIP EXPRN -> 1 %FINISH N = LHS_FORM>>5&3 RP = RP+4 FAULT2(19,REC(RP+2)) %IF N=3 %AND REC(RP+3) # 2 VAR(RHS); RP = RP+1 FAULT(33) %IF STUDENT # 0 %AND RHS_LEVEL > LHS_LEVEL %IF LHS_FORM&16 = 0 %THEN FAULT(82) -> NAME TYPE %IF LHS_TYPE = 13 %IF RHS_FORM&PARMMASK(N) # PATTERN(N) %C %OR LHS_TYPE # RHS_TYPE %START FAULT(F) RELEASE REGISTER(RHS_INDEX) -> 1 %FINISH -> NTYPE(N) NAME TYPE: ! %NAME TYPE PARAMETERS (VERY ODD !) ! ! WORD 1 : FLAGS<<24 ! ADDR(VAR) ! WORD 2 : LENGTH OF EACH ITEM ! VTYPE = RHS_TYPE N = ROUND(VTYPE) X = RHS_ADDRESS LOAD ADDR(RHS,1); GPR1 = 0 A = LHS_ADDRESS DRX(X'50',1,0,A) DSI(X'92',A,NAME FLAG(VTYPE)) %IF VTYPE # 16 %THEN PLANT(X'41100000'+N) %ELSE %START %IF TEMP_DIMENSION = 7 %START DRX(X'58',1,0,DOPE VECTOR+8) X = X'1003'; -> NT1 %FINISH N = RHS_LENGTH %IF N = 0 %START SPLANT(X'1F11') NT1: DRX(X'43',1,0,X); ! PICK UP MAX LENGTH %FINISH %ELSE PLANT(X'41100000'+N) %FINISH DRX(X'50',1,0,A+4); ! PLUG IT IN -> 1 ! NTYPE(2): ! %NAME ! VTYPE = RHS_TYPE %IF VTYPE = B'10000' %START SNLEN = RHS_LENGTH RHS_FORM = RHS_FORM!2 %IF SNLEN = 0 %FINISH %IF VTYPE # B'111' %START LOAD ADDR(RHS,1) %IF VTYPE = B'10000' %AND RHS_LENGTH = 255 %C %THEN PLANT(X'5610D000'+29<<2) %FINISH %ELSE %START FAULT(83) %IF STUDENT # 0 %AND LHS INDEX # OLD INDEX RHS_TYPE = B'100' RHS_FORM = RHS_FORM!2 %IF RHS_FLAGS&4 = 0 LOAD ADDR(RHS,1) %FINISH LHS_FORM = LHS_FORM!!2; LHS_TYPE = B'100' STORE(RHS,LHS) -> 1 ! NTYPE(1): ! %ARRAYNAME ! X = RHS_INDEX; A = RHS_ADDRESS RELEASE REGISTER(A) %AND A = A<<12 %IF RHS_FORM&128 # 0 LOAD ADDR(LHS,3) %IF LHS_INDEX # 0 B = LHS_ADDRESS RELEASE REGISTER(B) %AND B = B<<12 %IF LHS_FORM&128 # 0 DSS(X'D2',16,B,A); ! MOVE IN HEADER %IF X # 0 %START DRX(X'98',14,15,B); ! R14 = @A(0), R15 = @A(F) DRR(X'1A',14,X); DRR(X'1A',15,X) DRX(X'90',14,15,B); ! UPDATE THEM RELEASE REGISTER(X) %FINISH -> 1 ! NTYPE(3): ! ROUTINE/FN/MAP %NAME ! FAULT(82) %AND -> 1 %IF RHS_LEVEL = 0 N = (LHS_DIMENSION+7)<<4+X'41F0D000' PLANT(N) N = RHS_ADDRESS&X'FFFF' %IF RHS_FLAGS>>4&3 = 3 %START PLANT(X'58E00000'+N) DSS(X'D2',12,X'F000',X'E000') %FINISH %ELSE %START PLANT(X'41E00000'+N) PLANT(X'D20FF000'); SPLANT(X'E000') %FINISH PLANT(X'50B0F00C') PLANT(X'50F00000'+LHS_ADDRESS&X'FFFF') ! ! NOW CHECK FOR CONSISTENT PARAMETERS ! COMPARE RT(WORK,OLD INDEX) ! -> 1 ! ATYPE(4): ! '->' ! CRES(RESFLOP,7) 1: %END %ROUTINE CUI(%INTEGER UTYPE) ! ! COMPILE UNCONDITIONAL INSTRUCTION ! %SHORTROUTINE %SWITCH UI(1 : 11) %RECORD X, V(VARFM) %INTEGER J, K, L, NAME, P, ASSP -> UI(UTYPE) ! UI(1): ! (HOLE)(VAR)(MARK)(RUI1')(AUI') ! ! P(RUI1') ::= (ASSOP)(EXPRN): ! P(AUI') ::= %AND(UI): ! P(ASSOP) ::= '==' : '=' : '<-' : '->' RP = RP+1; P = REC(RP); ! ONTO (ASSOP) ASSOP = 0 %IF REC(P) = 1 %THEN ASSOP = REC(P+1) ASSP = ASSOP; VAR(LHS) RP = RP+1 %IF ASSP = 0 %START; ! ROUTINE/FN/MAP FAULT2(19,VNAME) %C %UNLESS LHS_FORM&B'1100' = 0 %OR V_LEVEL = 255 -> PRED %IF LHS_TYPE = 14 %AND REC(RP+1) = 2 ! NO (AUI) FAULT2(17,VNAME) %IF LHS_TYPE # 15 %AND LHS_LEVEL # 255 -> AUI %FINISH ! ASSIGNMENT ASSOP = ASSP LHS = DUMMY NAME %AND FAULT2(29,VNAME) %C %IF ASSOP # 1 %AND LHS_FORM&3 = 0 %AND V_LEVEL # 255 ZERO EXP = 0 MAPV = 0; ! CONTROL FOR %MAPNAME PARMS %IF ASSOP = 1 %AND LHS_FORM&B'1000' = 0 %THEN MAPV = 1 RP = RP+1 ASSIGN(LHS,ASSOP) ! AUI: ! TEST FOR '%AND'(UI) ! RP = RP+1 %IF REC(RP) = 1 %START RP = RP+1; UTYPE = REC(RP) -> UI(UTYPE) %FINISH -> 1 ! UI(3): ! '->'(LABEL) ! P(LABEL) ::= (INTEGER) : (NAME)(OP PARM') ! P(OP PARM') ::= '(' (EXPRN) ')' : ! ACCESS = 0 RP = RP+1 J = REC(RP); ! TYPE OF LABEL %IF J = 1 %START; ! (INTEGER) RP = RP+1; GET4(NAME) %FINISH %ELSE %START; ! (NAME) RP = RP+1; NAME = REC(RP) %FINISH %IF J = 2 %AND REC(RP+1) = 1 %START; ! SWITCH %IF INTEGER(NAME+DICTHEAD+4) = 0 %START FAULT2(4,NAME); ! SWITCH VECTOR NOT SET V = DUMMY NAME %FINISH %ELSE GETINFO(NAME,V) FAULT2(5,NAME) %UNLESS V_TYPE = B'1000000' FAULT2(4,NAME) %UNLESS V_LEVEL = LEVEL RP = RP+1 EXPRN TYPE = B'100'; ! INTEGER PARM EXPRN(X) LOAD(X,1) DRX(X'41',2,10,V_ADDRESS); ! @ VECTOR PLANT(X'45FC0000'+8<<2); GPR1 = 0 ! FORGET IT -> 1 %FINISH ! NORMAL LABEL %IF J = 1 %START; ! CONSTANT LABEL %IF NAME>>16 # 0 %THEN FAULT(44) %AND -> 1 NAME = \NAME %FINISH %IF LEVEL # 1 %THEN JUMP TO(NAME,15) %C %ELSE FAULT(-11) %AND PRINT LABEL(NAME) -> 1 ! UI(2): ! '%PRINTTEXT' (TEXT) ! RP = RP+1; ! SKIP TYPE SET TEXT(1) -> AUI ! UI(6): ! '%MONITOR'(MSTOP') ! P(MSTOP') ::= '%STOP' : (INTEGER) : ! RP = RP+1 J = REC(RP) ACCESS = 0 %UNLESS J = 3 L = (4+J)<<2+X'45FC0000' %IF J = 2 %START; ! %MONITOR 'N' RP = RP+1; ! SKIP TYPE GET4(K) FAULT(44) %IF K>>7 # 0 PLANT(X'41000000'+K) %FINISH PLANT(L) ! ->AUI %IF J = 3 !***** ALTER ***** -> 1 ! UI(7): ! '%STOP' ! SPLANT(X'05FC'); ! TO STOP SEQUENCE ACCESS = 0 -> 1 ! UI(4): ! '%RETURN' ! BACK: FAULT(UTYPE+26) %UNLESS BLOCK TYPE&127 = UTYPE BACK2: DSS(X'D2',4,X'D014',BASE REG<<12) PLANT(X'984F0010'+BASE REG<<12) SPLANT(X'07FF') *XC_GPR1(8),GPR1 -> 1 ! UI(5): ! '%RESULT='(=EXPRN) ! RP = RP+1 %IF REC(RP) = 1 %START; ! ==(VAR) FAULT(29) %IF BLOCK TYPE&128 = 0 VAR(X) FAULT2(19,VNAME) %IF X_FORM&B'1100' # 0 FAULT(83) %IF X_TYPE # FNTYPE2 LOAD ADDR(X,1); -> BACK %FINISH ! ! STOP STUDENTS FROM USING '=' IN MAPS ! FAULT(82) %IF STUDENT # 0 %AND BLOCKTYPE&128 # 0 %IF FNTYPE&B'10000' # 0 %START; ! %STRINGFN C S EXPRN(P); S LOAD(P,2) DRR(X'18',1,BASE REG); ! POINTER TO SAVE AREA (FOR RESULT) PLANT(X'984F0010'+BASE REG<<12); ! RESTORE CONTEXT DSS(X'D2',4,X'D014',X'1000') ! NOW SHIFT IN RESULT. PLANT(X'43320000'); PLANT(X'443D0000'+24<<2) SPLANT(X'07FF'); ! %RETURN *XC_GPR1(8),GPR1; -> 1 %FINISH EXPRN TYPE = FN TYPE EXPRN(X) LOAD(X,1) -> BACK ! UI(8): ! %EXIT UI(9): ! %CONTINUE ! FIND CYCLE(P) %IF P = 0 %THEN FAULT(54) %ELSE %START %IF UTYPE = 8 %START; ! %EXIT ! SHOW ELSE LABEL HAS BEEN USED BYTEINTEGER(P+3) = BYTEINTEGER(P+3)!64 P = INTEGER(P+8); ! ELSE LABEL %FINISH %ELSE P = INTEGER(P+4); ! CYCLE LABEL FOR CONTINUE JUMP TO(P,15) %FINISH ACCESS = 0 -> 1 ! UI(10): ! '%TRUE' ! P = X'19BB'; ! CR FOR CC = 8 TF: SPLANT(P); ! SET CONDITION CODE PRED: FAULT(27) %UNLESS BLOCK TYPE = 6 -> BACK2 ! UI(11): ! '%FALSE' ! P = X'14BB'; ! NR FOR CC = 7 -> TF 1: %END; ! OF CUI ! !****************** C MAIN PROGRAM *********************** ! SET ERROR:! PUT DOWN A LAYER OF SIGNALS !! LINE ENTRY = 0; ! TO BRING IN A NEW LINE MON LOCK = 0; DIAG HEAD == DIAG BASE ! RESUME COMPILATION: ! ENTRY FROM IGNORED INTQ ! *L_1,SAVEAREA *ST_1,J *STM_4,14,16(1) *LA_2, *ST_2,60(1) *MVI_60(1),8; ! ??????????????? SIGNAL(0,J+16,0,K) INTQ FLAG = 0 %AND SIGNAL(5,SIGAREA,0,K) %IF INTQ FLAG = 1 ! ! CO-ROUTINE ENTRY JOINS MAIN LOOP HERE FROM EXT BREAK ! EXT BREAK0: *LA_11,2048(11); ! TO LEAVE SPACE FOR DIAGS ! %BEGIN %SHORTROUTINE %CYCLE COMP MODE = 0; COMPILE BLOCK; BASE REG = 9 ! JUST IN CASE %IF COMP MODE&16 # 0 %THEN DEFINE RT %ELSE %START %IF CODEIN > CODE START %AND FAULTY = 0 %START COMP MODE = 0; SELECTOUTPUT(IOUT) %IF IOUT # 0 SELECTINPUT(INSTREAM) %IF INSTREAM # 0 *BCR_0,0; ! FORCE THE COMPILER TO FORGET EXECUTE CODE SELECTINPUT(0) %IF IOFLAG = 0 RUNNING = 'N'; SELECTOUTPUT(SYSOUT) ! FORCE ANY OUTPUT %FINISH %FINISH COMP MODE = 0 %REPEAT %END !********************************************************************* ! %INTEGERFN FOR CLAUSE; ! COMPILES (VAR) = A,B,C %SHORTROUTINE %INTEGER J, K, L, RSAVE %RECORD V, V1, V2(VARFM) RP = RP+1; ! SKIP P(F CLAUSE) VAR(V) V_TYPE = 4 %AND FAULT(25) %IF V_TYPE # 4 REG USE(4) = 'L'; ! CLAIM REG 4 GET CYCLE SPACE(K); ! SAVE AREA FOR PARMS EXPRN TYPE = B'100'; ! INTEGER PARMS RSAVE = RP+1; RP = REC(RSAVE)-1 EXPRN(V1); ! INCR EXPRN(V2); ! FINAL L = RP RP = RSAVE LOAD ADDR(V,4); LOAD(V1,2); LOAD(V2,3) PLANT(X'90240000'+K&X'FFFF'); ! STM 2,4,SAVE AREA J = K+8 EXPRN(V); LOAD(V,1); GPR1 = 0;! FORGET IT RP = L CYC NUM = CYC NUM+1 DSI(X'92',J,CYC NUM); ! SET CYCLE FLAG DRX(X'41',2,0,K); PLANT(X'45FC0000'+10<<2) ! TEST IVC REG USE(4) = 0; ! RELEASE REGISTER 4 PLANT(X'47FA0000'+FORWARD ADDRESS(32)) ! JUMP ROUND ! NOW PLANT CODE FOR THE REPEAT ! THIS IS DONE HERE TO ENABLE ALL FORMS OF ! CYCLE/REPEAT BLOCKS TO BE DEALT WITH IN THE SAME MANNER CYCLE LABEL = ILAB-1 ELSE LABEL = CYCLE LABEL-1 ILAB = ELSE LABEL LABEL FOUND(CYCLE LABEL) DSI(X'95',J,CYCNUM); ! TEST VALID DESCRIPTOR PLANT(X'477C000C'); ! UNASSIGNED VARIABLE IF NOT PLANT(X'98240000'+K&X'FFFF'); ! PICK UP PARMS PLANT(X'58140000'); ! LOAD CONTROL VARIABLE SPLANT(X'1913'); JUMP TO(ELSE LABEL,8) SPLANT(X'1A12') !*** FILL IN INITIAL JUMP TO HERE *** PLANT(X'50140000'); ! STORE CONTROL VARIABLE %RESULT = K<<16+32 %END %ROUTINE C FINISH ! ! SFINF_TYPE : 1 - THENSTART ! : 2 - ELSESTART ! : 3 - START ! %SHORTROUTINE %RECORDNAME SFINF(BLOCKFM) %INTEGER J, L %IF START HEAD = 0 %START; ! NO START F51: FAULT(51); -> 1 %FINISH SFINF == RECORD(START HEAD) -> F51 %IF SFINF_TYPE&15 = 0; ! CYCLE WANTED RP = RP+1 %IF REC(RP) = 1 %START; ! %ELSE GIVEN ! WAS THE START A 'THENSTART' ? NASTY = 1 %IF SFINF_TYPE # 1 %THEN FAULT(47) %AND -> NE RP = RP+1 %IF REC(RP) = 1 %START; ! ...%ELSESTART L = FORWARD REF(15) REMOVE LABEL(SFINF_ELSE); ! %ELSE IS HERE SFINF_ELSE = L SFINF_TYPE = 2; ! NO CONDITION -> 1 %FINISH L = FORWARD REF(15); ! JUMP PAST ELSE REMOVE LABEL(SFINF_ELSE) PUT LINE RP = RP+1; CUI(REC(RP)) REMOVE LABEL(L); ! FILL IN JUMP AROUND %FINISH %ELSE %START; ! NO ELSE REMOVE LABEL(SFINF_ELSE) %UNLESS SFINF_TYPE = 3 %FINISH NE: J = START HEAD; START HEAD = SFINF_LINK COMP MODE = COMP MODE&B'11110111' %IF START HEAD = 0 SFINF_LINK = ASL; ASL = J;! REMOVE CELL 1: %END %ROUTINE PUT LINE %SHORTROUTINE ! PLANT A 'MVI' INSTRUCTION TO UPDATE THE LINE NUMBER ! FOR DIAGS. %INTEGER L, U %OWNINTEGER LL, UL = 0 %IF LINE NUM # 1 %AND DIAGS&6 # 0 %START U = LINE NUM>>8 L = LINENUM&255 %IF L # LL %OR NASTY # 0 %START LL = L DSI(X'92',X'D017',LL) UL = U %AND DSI(X'92',X'D016',UL) %C %IF UL # U %OR NASTY # 0 NASTY = 0 %FINISH %FINISH %END !????? %ROUTINE WARNING(%STRING (15) S) %PRINTTEXT ' The syntax of this command has been changed. Please use the new form in future. The new form is: ' PRINTSTRING('$'.S.' NAME ') %END %ROUTINE CSS(%INTEGER SST) %SHORTROUTINE %SWITCH SS(1 : 32) %INTEGER K, L, N, NEXT, RSAVE, MARK %BYTEINTEGER COND TYPE %RECORDNAME TV(VARFM) %RECORDNAME SFINF(BLOCKFM) *XC_GPR1(8),GPR1; SUSPEND = 'N' -> SS(SST) ! TA: *CLI_ACCESS,0 *BCR_7,15 *ST_15,K FAULT(100) *L_15,K *BCR_15,15 ! SS(1): ! (UI)(R SS1) ! *BAL_15, PUT LINE COND TYPE = 0; ! NO CONDITION AS YET RP = RP+1; MARK = REC(RP);! PAST (UI) NEXT = REC(MARK); ! (OP COND') %IF NEXT # 3 %START; ! CONDITION GIVEN RSAVE = RP; RP = MARK; ! ONTO CONDITION %IF NEXT = 1 %START; ! (IUWU) RP = RP+1 CONDTYPE = REC(RP); ! IF/UNLESS/WHILE/UNTIL C COND(CONDTYPE) %FINISH %ELSE K = FOR CLAUSE RP = RSAVE %FINISH RP = RP+1 CUI(REC(RP)) %IF NEXT = 2 %OR COND TYPE > 2 %C %THEN JUMP TO(CYCLE LABEL,15) %C %AND REMOVE LABEL(CYCLE LABEL) ACCESS = 1 %AND REMOVE LABEL(ELSE LABEL) %IF NEXT # 3 ! FOR JUMP AROUND -> 1 ! SS(2): ! (IU)(COND)(R IU) ! *BAL_15, PUT LINE RP = RP+1; C COND(REC(RP)); RP = RP+2 %IF REC(RP) = 2 %START; ! '%THEN' (UI) RP = RP+1; CUI(REC(RP)) RP = RP+1 %IF REC(RP) = 1 %START; ! %ELSE RP = RP+1 %IF REC(RP) = 2 %START; ! UI L = FORWARD REF(15); ! JUMP ROUND REMOVE LABEL(ELSE LABEL) RP = RP+1; CUI(REC(RP)) REMOVE LABEL(L) %FINISH %ELSE %START;! '%START' L = FORWARD REF(15) REMOVE LABEL(ELSE LABEL) PUSH(STARTHEAD,2,0,L); ! PRESERVE INFO COMPMODE = COMP MODE!8 -> STERR; ! SEE IF IT'S OK TO BE LEFT %FINISH %FINISH %ELSE REMOVE LABEL(ELSE LABEL) %FINISH %ELSE %START LINE NUM = 1 %IF LINE NUM = 0 PUSH(START HEAD,1,0,ELSE LABEL) COMPMODE = COMPMODE!8 STERR: C FINISH %IF FAULTY # 0 %AND LEVEL = 1 ! REMOVE '%START' %FINISH ACCESS = 1 -> 1 ! SS(3): ! (WU)(COND)(R WU) ! *BAL_15, NASTY = 1 RP = RP+1 %IF REC(RP) = 2 %THEN K = FOR CLAUSE %ELSE %START K = 0 RP = RP+1; C COND(REC(RP)+2) %FINISH RP = RP+2 %IF REC(RP) = 2 %START; ! '%THEN' (UI) RP = RP+1; CUI(REC(RP)); JUMP TO(CYCLE LABEL,15) REMOVELABEL(CYCLE LABEL); REMOVELABEL(ELSE LABEL) ACCESS = 1 %FINISH %ELSE %START; ! '%CYCLE' PUSH(START HEAD,K,CYCLE LABEL,ELSE LABEL) COMPMODE = COMPMODE!8 -> CYCERR %FINISH -> 1 ! SS(4): ! %CYCLE(CPARM')(S): ! ! P(CPARM') ::= (VAR)'='(EXPRN)','(EXPRN)','(EXPRN): *BAL_15, RP = RP+1 %IF REC(RP) = 2 %START CYCLE LABEL = ILAB-1 ELSE LABEL = CYCLE LABEL-1; ILAB = ELSE LABEL LABEL FOUND(CYCLE LABEL) PUSH(START HEAD,16,CYCLE LABEL,ELSE LABEL) COMPMODE = COMPMODE!8 -> 1 %FINISH PUT LINE; NASTY = 1 K = FOR CLAUSE PUSH(START HEAD,K,CYCLE LABEL,ELSE LABEL) COMPMODE = COMPMODE!8 CYCERR: -> 1 %UNLESS FAULTY # 0 %AND LEVEL = 1 ! REMOVE %CYCLE ! SS(5): ! '%REPEAT'(S) ! *BAL_15, %IF START HEAD # 0 %START SFINF == RECORD(START HEAD) %IF SFINF_TYPE&15 = 0 %START K = START HEAD; START HEAD = SFINF_LINK COMP MODE = COMP MODE&B'11110111' %IF STARTHEAD = 0 SFINF_LINK = ASL; ASL = K PUT LINE JUMP TO(SFINF_CYCLE,15) REMOVELABEL(SFINF_CYCLE) REMOVELABEL(SFINF_ELSE) %UNLESS SFINF_TYPE = 16 %IF SFINF_TYPE&32 # 0 %START DISP = SFINF_ADDR %IF LEVEL = 1 DSI(X'92',SFINF_ADDR+8,0); ! CLEAR FLAG %FINISH NASTY = 1 -> 1 %FINISH %FINISH FAULT(1); ! SPURIOUS REPEAT -> 1 ! SS(6): ! '%FINISH'(ELSE')(S) ! ACCESS = 1 C FINISH; -> 1 ! SS(7): ! (TYPE)(DECLN)(S) ! *BAL_15, UAV FLAG = 15 VTYPE(NEWNAME) -> 1 %IF FAULTY # 0 %AND LEVEL = 1; ! STRING LENGTH FAULTY NEW NAME_FLAGS = 0 NEW NAME_INDEX = 0 NEW NAME_DIMENSION = 0 FMLEN = NEWNAME_LENGTH FORMATP = 0 DECLARE; -> 1 ! SS(8): ! '%END'(OF')(S) ! C END; -> 1 ! SS(9): ! '%BEGIN'(S) ! RT NAME = 0 DISP = (DISP+3)&(\3) NEW BLOCK(0); ! BEGIN PLANT(X'90AB0000'+DISP&X'FFFF') NEW DIAG(DISP+8); SPLANT(X'05A0') R10 = CODEIN DISP = DISP+12; ! LEAVING SPACE FOR DIAGS LINE NUM = 1 %IF LINE NUM = 0 FN TYPE = 3; BLOCK TYPE = 0 BLOCK ENTRY = -1 %IF LEVEL = 2 -> 1 ! SS(10): ! (EXTERNAL')(RFM)(SPEC')(NAME)(FPDEFN')(S) ! C RFM DEC; -> 1 ! SS(11): ! '%COMPILE'(CFILE)(S) ! WARNING('COMPILE') SPECIAL(2); -> 1 ! SS(13): ! '%SPEC'(NAME)(FPDEFN')(S) ! RP = RP+1; N = REC(RP) TV == RECORD(GET NAME(N)); MARK = TV_INDEX ! FOR LATER MARK = -1 %IF TV_FORM&128 = 0; ! IT'S NEW %IF TV_FLAGS&1 = 0 %OR TV_TYPE = 7 %C %THEN FAULT2(3,N) %AND -> 1 FPMODE = 0; SPEC = 1; C FPDEFN(TV) TV_FLAGS = TV_FLAGS&B'11111110' COMPARE RT(TV,MARK) %IF MARK >= 0; ! CHECK FOR CONSISTENCY -> 1 ! SS(14): ! '%START'(S) ! PUSH(START HEAD,3,0,0) COMPMODE = COMPMODE!8; -> 1 ! SS(15): ! '%LIST'(S) ! LIST = 'Y' PRINTED = 0 %IF IOFLAG = 0 -> 1 ! SS(16): ! '$RESTART'(S) ! RESTART = 2 SIGNAL(2,240,0,K); ! FORCE SIG WT 240 TO RESTART ! SS(17): ! '%EDIT'(NAME)(S) ! WARNING('EDIT') SPECIAL(1); -> 1 ! SS(18): ! '%SENDTO'(NAME)(S) ! WARNING('SEND') RP = RP-1; ! BACK AS 'TO' IS NOT OPTIONAL WITH THIS FORM SPECIAL(3); -> 1 ! SS(19): ! '%RECORD'(REC DEC)(S) ! DEC FLAG = 1 RP = RP+1 C REC DEC(REC(RP)); -> 1 ! SS(20): ! '%CONTROL'(INTEGER)(S) ! RP = RP+1; ! PAST TYPE GET4(N); ! INTEGER SET CONTROL(N) %IF STUDENT = 0 -> 1 ! SS(21): ! '%SWITCH'(NAMELIST)(CBPAIR)(R SW LIST)(S) ! C SWITCH; -> 1 ! SS(22): ! (NUMBER)':' ! ACCESS = 1 RP = RP+1; ! SKIP TYPE OF CONSTANT. MUST BE B'100' NASTY = 1 GET4(N); ! LABEL %IF N>>16 # 0 %THEN FAULT(4) %ELSE %START %IF LEVEL = 1 %THEN FAULT(32) %ELSE LABEL FOUND(\N) %FINISH ! RP = RP+1; -> SS(REC(RP)) ! SS(23): ! '$'(SPECIAL)(S) ! RP = RP+1 SPECIAL(REC(RP)) -> 1 ! SS(24): ! '%REALS'(LN)(S) ! DEC FLAG = 1 REALS <- 6-REC(RP+1); -> 1 ! SS(25): ! (NAME)(SW PARM')':'(SS) ! ACCESS = 1 NASTY = 1 SW REF RP = RP+1; -> SS(REC(RP)) ! SS(27): ! '%EXTRINSICRECORD' ! EXTRINSIC = 1; DEC FLAG = 1 RP = RP+1; C REC DEC(REC(RP)+2) -> 1 ! SS(26): ! '%OWN'(OWN DEC) ! DEC FLAG = 1 C OWN DEC %IF C LIST # 2; C LIST = 0 -> 1 ! SS(29): ! #(EXPRN)(R # LIST') ! HASH EXPRNS -> 1 ! SS(30): ! '.'(HOLE)(VAR)(MARK)(R UI')(AUI'): ! DOT NAME -> 1 ! SS(31): ! '*'(MCINST) ! FAULT(33) %IF LEVEL <= 1 CUCI -> 1 SS(12): ! (COMMENT) SS(28): ! %SHORTROUTINE SS(32): ! (S) ! ! FAULT & GET OUT QUICK (VIA $CANCEL) IF NO SPACE LEFT 1: FAULT(110) %AND SPECIAL(15) %IF CODEIN > DEC START %END; ! OF CSS %ROUTINE COMPILE BLOCK %SHORTROUTINE %INTEGER J %BYTEINTEGER FLAG FLAG = 0 LINE NUM = 0 MAX DISP = DISP FAULTY = 0; ACCESS = 1 CODE START = CODE TOP+12; CODEIN = CODE START R10 = CODEIN; TEXTIN = TEXT HEAD; -> 1 %INTEGERFN PARSE(%INTEGER MP) %SHORTROUTINE %SWITCH BIP(0 : 15) %INTEGER TSYM, TRP, ALT, S, HOLE, SP, ALTNUM, L, P ALTNUM = MP ALT = RP; ! HOLE FOR ALTERNATIVE RP = RP+1 TSYM = SYM; ! SAVE TEXT POINTER TRP = RP; ! SAVE ANALYSIS RECORD POINTER ! BIP(11): ! DUMMY - ALWAYS FAILS ! FAILURE: ! RESET PARAMS SM = SYM %IF SYM > SM SYM = TSYM RP = TRP MP = MP+1; ! ONTO NEXT ALTERNATIVE SP = MAIN(MP) %RESULT = 1 %IF SP = 0; ! CONTEXT MUST BE SAFE !!! SUCCESS: SP = SP+1 S = SUB(SP); ! NEXT ATOM %IF S = 0 %START; ! SUCCESS REC(ALT) = MP-ALTNUM;! SET WHICH ALTERNATIVE FOUND %RESULT = 0 %FINISH -> BIP(S>>12&15) ! BIP(0): ! LITERAL ! P = LITERAL(S) %CYCLE P = S+1,1,S+P -> FAILURE %IF LINE(SYM) # LITERAL(P) SYM = SYM+1 %REPEAT -> SUCCESS ! BIP(1): ! SUB-PHRASE ! -> SUCCESS %IF PARSE(S&X'FFF') = 0 -> FAILURE ! BUILT IN PHRASES ! BIP(6): ! (HOLE) ! HOLE = RP RP = HOLE+1 -> SUCCESS ! BIP(7): ! (MARK) ! REC(HOLE) = RP; ! FILL IN HOLE -> SUCCESS ! BIP(14): ! (NAME) ! -> SUCCESS %IF NAME = 0 -> FAILURE ! BIP(5): ! (CONSTANT) ! -> SUCCESS %IF CONSTANT(B'11111') = 0 -> FAILURE ! BIP(4): ! (NUMBER) ! -> FAILURE %UNLESS '0' <= LINE(SYM) <= '9' ! BIP(3): ! (INTEGER) ! -> SUCCESS %IF CONSTANT(B'100') = 0 -> FAILURE ! BIP(8): ! (NAME LIST) ! P = RP; RP = RP+1; ! HOLE FOR NUMBER OF NAMES -> FAILURE %IF NAME # 0 L = 1; ! NAME COUNT NLIST1: %IF LINE(SYM) = ',' %START SYM = SYM+1 %IF NAME = 0 %THEN L = L+1 %AND -> NLIST1 SYM = SYM-1 %FINISH REC(P) = L -> SUCCESS ! BIP(9): ! (STRING) ! -> SUCCESS %IF CONSTANT(B'10000') = 0 -> FAILURE ! BIP(10): ! (C TEXT) ! SYM = SYM+1 %WHILE LINE(SYM) # NL PROMPTCH = ':'; ! TO IGNORE QUOTES -> SUCCESS ! BIP(15): ! (S) ! -> SUCCESS %UNLESS NL # LINE(SYM) # ';' -> FAILURE ! BIP(12): ! (C LIST) ! REC(ALT) = 1; ! FILL IT IN NOW !!! C OWN DEC -> SUCCESS %IF C LIST # 0 -> FAILURE BIP(2):!**MCODE -> FAILURE %IF STUDENT # 0 -> FAILURE %IF MCODE(S&15) = 0 -> SUCCESS ! BIP(13): ! SPARE BIPS *** BLOOP *** BLOP *** ! -> FAILURE %END; ! OF PARSE %ROUTINE FETCH AR %INTEGER LAST LINE 1: %IF LINE ENTRY = 0 %START; ! LAST LINE EXHAUSTED OLD TEXT = TEXTIN FIRST CHAR = OLD TEXT RECONSTRUCT; ! PICK UP A NEW LINE LINE ENTRY = 1 %FINISH DEC1 = OLD TEXT DEC2 = TEXTIN RP = 1; SYM = LINE ENTRY; SM = SYM LINE START = SM %IF PARSE(0) # 0 %START;! FAILURE LAST LINE = LINE NUM LAST LINE = LAST LINE-1 %IF LINE ENTRY = 1 FAULT(0) TEXTIN = OLD TEXT %IF COMPMODE&2 = 0 PROMPTCH = ':' LINE NUM = LAST LINE FAULTY = 0 %IF COMP MODE&2 = 0;! DON'T IGNORE WHEN EDITING FLAG = 1 %AND %RETURN %C %IF COMPMODE&2 # 0 %AND LINENUM = 0 -> 1 %FINISH LINE ENTRY = 0 %IF LINE(SYM) = ';' %START OLD TEXT = FIRST CHAR+LINE(SYM+1) LINE ENTRY = SYM+2; ! MORE HERE DEC2 = OLD TEXT %FINISH %END 1: %UNTIL COMP MODE&B'1100' = 0 %AND LINE ENTRY = 0 %CYCLE DEC FLAG = 0; PRINTED = PRINTED&2 C START = CODEIN FETCH AR; %RETURN %IF FLAG # 0 RP = 1; CSS(REC(1)) %IF FAULTY = 1 %AND LEVEL = 1 %AND REC(1) # 8 %START ! VERY DUBIOUS !!!!! FAULTY = 0 CODEIN = C START TEXTIN = OLD TEXT LINE NUM = LINE NUM-1 %IF LINE ENTRY = 0 %FINISH %ELSE %START %IF DEC FLAG # 0 %AND LEVEL = 1 %C %AND TEXTIN-OLDTEXT+DECFILE < DEC LIMIT %START %CYCLE J = DEC1,1,DEC2-1 DEC FILE = DEC FILE+1 BYTEINTEGER(DEC FILE) = BYTEINTEGER(J) %REPEAT BYTEINTEGER(DEC FILE) = NL %C %IF BYTEINTEGER(DEC FILE) # NL %FINISH %FINISH %IF DCOMP = 1 %AND CODEIN > CSTART %START DECODE(CSTART,CODEIN,R10) PRINT USE %IF USE # 0 %FINISH %REPEAT %END %ROUTINE EXECUTE CODE RIM(0,PSTRING) RUNNING = 'Y' EFREE = X'B000'; ! SET UP FOR NEXT R11 *ST_11,A STACK SHORTINTEGER(CODEIN) <- X'05FC';! %STOP *LM_9,13,STACKTOP; ! CONTROL REGISTERS FOR CODE *MVC_24(40,9),24(8); ! MAKE THE RETURN ADDRESS OF THE CODE ! AND ITS SAVED REGISTERS THE SAME ! AS THIS ROUTINE, SO THAT IT WILL ! RETURN FROM WHENCE 'EXECUTE..' ! WAS CALLED ! *XC_20(4,13),20(13); ! CLEAR DIAGS POINTERS *BCR_15,10; ! ENTER CODE %END; ! NEVER REACHED !!!!! ! !******* CODE PLANTING ROUTINES ******* ! %ROUTINE PLANT(%INTEGER N) ! CODEIN NOT NESC. WORD ALLIGNED !!!! *L_1,CODEIN *MVC_0(4,1),N; ! INTEGER(CODEIN) = N *LA_1,4(1) *ST_1,CODEIN; ! CODEIN=CODEIN+4 %END %ROUTINE SPLANT(%INTEGER N) *L_1,CODEIN *MVC_0(2,1),N+2; ! SHORTINTEGER(CODEIN) = N *LA_1,2(1) *ST_1,CODEIN; ! CODEIN=CODEIN+2 %END %ROUTINE DRR(%INTEGER OPCODE, R1, R2) SHORTINTEGER(CODEIN) <- (OPCODE<<4!R1)<<4!R2 CODEIN = CODEIN+2 %END %ROUTINE DRX(%INTEGER OPCODE, R1, X, AD) SHORTINTEGER(CODEIN) <- (OPCODE<<4!R1)<<4!X SHORTINTEGER(CODEIN+2) <- AD CODEIN = CODEIN+4 %END %ROUTINE DSS(%INTEGER OPCODE, LENGTH, AD1, AD2) SHORTINTEGER(CODEIN) <- OPCODE<<8!LENGTH-1 SHORTINTEGER(CODEIN+2) <- AD1 SHORTINTEGER(CODEIN+4) <- AD2 CODEIN = CODEIN+6 %END %ROUTINE DSI(%INTEGER OPCODE, ADDR, IM) SHORTINTEGER(CODEIN) <- OPCODE<<8!IM SHORTINTEGER(CODEIN+2) <- ADDR CODEIN = CODEIN+4 %END ! !* * * * * * * * * * * * * * * * * * * * * ! %INTEGERFN FIND(%INTEGER NAME) %SHORTROUTINE %INTEGER ENTRY, STR, INDEX ENTRY = (BYTEINTEGER(NAME)*FIRST*LAST)&(\7) ! HASH ENTRY %CYCLE ENTRY = ENTRY,8,ENTRY+4088 INDEX = ENTRY&4095; ! WRAP AROUND STR = INTEGER(INDEX+DICTHEAD) %RESULT = \INDEX %IF STR = 0;! NOT YET IN %RESULT = INDEX %IF STRING(STR) = STRING(NAME) %REPEAT FAULT(104); ! DICTIONARY FULL %RESULT = INDEX; ! JUST TO KEEP GOING %END %INTEGERFN CONSTANT(%BYTEINTEGER TYPE) %SHORTROUTINE %CONSTLONGREAL MAX INTEGER = 2.14748364699999@9 %LONGREALFNSPEC NUMBER %LONGREALFNSPEC FRACTION %LONGREAL RR,NR %INTEGER IR, N, K %BYTEINTEGER S, SIGN S = LINE(SYM) %IF '0' <= S <= '9' %START;! INTEGER -> FLT %IF TYPE = B'10000'; ! STRING WANTED RR = NUMBER ->FRAC %IF LINE(SYM) = '.' %IF LINE(SYM) = '@' %START SYM = SYM+1 SIGN = LINE(SYM) SYM = SYM+1 %UNLESS '-' # SIGN # '+' K = SYM NR = NUMBER; -> FLT %IF K = SYM NR = 0 %AND FAULT(38) %IF NR > MAX INTEGER N = INT(NR) RR = RR*10.0**(-N) %AND -> REAL %IF SIGN = '-' RR = RR*10.0**N %FINISH ->REAL %IF RR > MAX INTEGER IR = INT(RR) INT: REC(RP) = B'100'; RP = RP+1 PUT4(IR) %RESULT = 0 %FINISH %IF S = '.' %START RR = 0 FRAC: %UNLESS TYPE&B'1000' # 0 %START FLT: %RESULT = 1 %FINISH RR = FRACTION+RR %IF LINE(SYM) = '@' %START SYM = SYM+1 SIGN = LINE(SYM) SYM = SYM+1 %UNLESS '-' # SIGN # '+' K = SYM NR = NUMBER; -> FLT %IF K = SYM NR = 0 %AND FAULT(38) %IF NR > MAX INTEGER N = INT(NR) N = -N %IF SIGN = '-' RR = RR*10.0**N %FINISH REAL: REC(RP) = B'1010'; RP = RP+1 PUT8(RR) %RESULT = 1 %IF TYPE&8 = 0; ! DID NOT WANT A REAL %RESULT = 0 %FINISH %IF S = ''''+128 %START -> FLT %IF TYPE&B'10000' = 0 %C %AND LINE(SYM+1) # ''''+128 # LINE(SYM+2) N = SYM IR = N %UNTIL S = ''''+128 %CYCLE SYM = SYM+1; S = LINE(SYM) RECONSTRUCT %IF S = NL %REPEAT N = SYM-N-1 %IF N < 2 %AND TYPE&B'100' # 0 %START ! POSSIBLE SYMBOL N = LINE(IR+1) %UNLESS N = 0 REC(RP) <- B'10100'; RP = RP+1; SYM = SYM+1 PUT4(N); %RESULT = 0 %FINISH SYM = SYM+1 REC(RP) <- B'10000' REC(RP+1) <- N REC(RP+2) <- IR RP = RP+3 %RESULT = 0 %FINISH %IF LINE(SYM+1) = ''''+128 %START SYM = SYM+1 IR = 0 %IF S = 'X' %START; ! HEX %CYCLE K = 1,1,8 SYM = SYM+1; S = LINE(SYM) -> FOUND %IF S = ''''+128 %IF '0' <= S <= '9' %THEN S = S-'0' %ELSE %START -> FLT %UNLESS 'A' <= S <= 'F' S = S-'A'+10 %FINISH IR = IR<<4!S %REPEAT %FINISH %ELSE %START %IF S = 'B' %START; ! BINARY %CYCLE K = 1,1,32 SYM = SYM+1; S = LINE(SYM) -> FOUND %IF S = ''''+128 -> FLT %IF '1' # S # '0' IR = IR<<1!(S-'0') %REPEAT %FINISH %ELSE %START %RESULT = 1 %UNLESS S = 'M';! MULTI CHAR %CYCLE K = 1,1,4 SYM = SYM+1; S = LINE(SYM) RECONSTRUCT %IF S = NL -> FOUND %IF S = ''''+128 IR = IR<<8!S %REPEAT %FINISH %FINISH SYM = SYM+1; -> FLT %UNLESS LINE(SYM) = ''''+128 FOUND: SYM = SYM+1; -> INT %FINISH ! THE ONLY POSSIBILITY LEFT IS 'PI' %IF S = '$' %THEN RR = $ %AND SYM = SYM+1 %AND ->REAL %RESULT = 1; ! FAILURE %LONGREALFN NUMBER %LONGREAL R %BYTEINTEGER S R = 0 %CYCLE S = LINE(SYM) %RESULT = R %UNLESS '0' <= S <= '9' R = R*10.0+ (S-'0') SYM = SYM+1 %REPEAT %END %LONGREALFN FRACTION %LONGREAL R, POINT %BYTEINTEGER S R = 0 POINT = 1 1: SYM = SYM+1 S = LINE(SYM) %RESULT = R %UNLESS '0' <= S <= '9' POINT = POINT/10 R = (S-'0')*POINT+R -> 1 %END %END %INTEGERFN NAME %SHORTROUTINE %INTEGER SPT, N %BYTEINTEGER S S = LINE(SYM) %RESULT = 1 %UNLESS 'A' <= S <= 'Z' FIRST = S; ! SAVE FIRST SYMBOL FOR HASHING SPT = DICT FREE %UNTIL S < '0' %OR 'A' > S > '9' %OR S > 'Z' %CYCLE LAST = S; ! SAVE LAST SYMBOL FOR HASHING SPT = SPT+1 BYTEINTEGER(SPT) <- S SYM = SYM+1 S = LINE(SYM) %REPEAT BYTEINTEGER(DICT FREE) <- SPT-DICT FREE ! SET LENGTH N = FIND(DICT FREE); ! LOOK FOR IT %IF N < 0 %START ! NOT IN YET FAULT(103) %AND ABORT %IF DICTFREE > DICT MAX N = \N INTEGER(N+DICTHEAD) = DICT FREE DICT FREE = SPT+1; ! ONTO FREE SPACE %FINISH REC(RP) = N; RP = RP+1 FAULT(102) %AND %RESULT = 1 %IF RP > 290 %RESULT = 0; ! SUCCESS %END %ROUTINE RECONSTRUCT %SHORTROUTINE %ROUTINESPEC SET LINE %INTEGERFNSPEC INPUT SYMBOL %OWNINTEGER P, SL %BYTEINTEGER S LINE NUM = LINE NUM+1 -> QMORE %IF PROMPTCH = ''''; ! CALLED FROM 'CONSTANT' PROMPTCH = ':' P = 0; L = 0; ! COUNTER FOR NUMBER OF SYMBOLS READ IN NLOOP: SET LINE LOOP: S = INPUTSYMBOL PLOOP: -> LOOP %IF S = ' ' %IF S = NL %START; ! END OF LINE TEXTIN = TEXTIN-1 %AND -> LOOP %IF P = 0 FAULT(101) %AND -> NL1 %IF P > 297 %IF LINE(P) = 'C'+32 %START; ! CONTINUATION PROMPTCH = 'C' P = P-1; ! REMOVE '%C' -> NLOOP %FINISH P = P+1 LINE(P) = S NL1: LINE LENGTH <- P %RETURN %FINISH %IF S = '''' %START %IF LINE(P) = ''''+128 %START LINE(P) = '''' -> QLOOP %FINISH P = P+1 LINE(P) = ''''+128 QLOOP: S = INPUTSYMBOL %IF S = '''' %START S = INPUTSYMBOL %IF S # '''' %START P = P+1 DIS106: LINE(P) = ''''+128 SL = 0 -> PLOOP %FINISH %FINISH P = P+1; SL = SL+1 FAULT(106) %AND -> DIS106 %IF SL > 255 LINE(P) = S %IF S = NL %START FAULT(101) %AND -> NL1 %IF P > 297 PROMPTCH = ''''; -> NL1 QMORE: SET LINE PROMPTCH = ':' %FINISH -> QLOOP %FINISH %IF S = '%' %START PCLOOP: S = INPUTSYMBOL -> PLOOP %UNLESS 'A' <= S <= 'Z' P = P+1 LINE(P) = S!32 -> PCLOOP %FINISH P = P+1 LINE(P) = S %IF S = ';' %START P = P+1 LINE(P) = TEXTIN-OLD TEXT %FINISH -> LOOP %INTEGERFN INPUTSYMBOL ! GET THE NEXT SYMBOL OF THE INPUT FILE ! AND SAVE IT AT TEXTIN %SHORTROUTINE %INTEGER S %IF COMP MODE&1 = 0 %THEN READSYMBOL(S) %ELSE %START ! INSIDE THE EDITOR, SO THE TEXT IS IN CORE ! AT 'TEXTP' TERMINATED BY A ZERO (NULL) CHARACTER S = BYTEINTEGER(TEXTP); TEXTP = TEXTP+1 ! PRODUCE A LISTING IF IN THE EDITOR %IF S = 0 %THEN READSYMBOL(S) %C %AND COMPMODE = COMPMODE&254 %FINISH BYTEINTEGER(TEXTIN) <- S; TEXTIN = TEXTIN+1 PRINTSYMBOL(S) %IF COMPMODE&2 # 0 %AND LIST = 'Y' %RESULT = S %END %ROUTINE SET LINE %CONSTSHORTINTEGER ONE = 1 %CONSTINTEGER NPAT1 = X'3F3F3F3F' %CONSTINTEGER NPAT2 = X'3F33FFFF' %LONGREAL WORK, WORK2 %IF COMP MODE&2 # 0 %START %IF LIST = 'Y' %OR DCOMP # 0 %START %IF TESTINT(0,'NO') # 0 %START ! INHIBIT OUTPUT LIST = 'N'; DCOMP = 0; PRINTED = 2 %FINISH %ELSE %START WRITE(LINENUM,4) %IF PROMPTCH = ':' %C %THEN %PRINTTEXT ' ' %C %ELSE PRINTSYMBOL(PROMPTCH) %PRINTTEXT ' ' %FINISH %FINISH %FINISH %ELSE %START ! CONVERT 'LINE NUM' INTO A STRING WITH THE ! CORRECT TERMINATOR *L_1,LINE NUM *CH_1,ONE *BC_7, *SLR_1,1 OK: *CVD_1,WORK *OI_WORK+7,1 *MVC_WORK2(5),PAT1 *ED_WORK2+1(4),WORK+6 *BC_7, *MVC_WORK2+4(1),PROMPTCH NZ: *NC_WORK2(4),NPAT1 RIM(0,STRING(ADDR(WORK2))) %FINISH %END %END %ROUTINE DEC CONST ARRAY(%INTEGER LEN) ! SETS UP THE DOPE-VECTOR AND HEADERS FOR CONSTANT BOUNDED ARRAYS ! SUCH AS ARE FOUND IN RECORDS AND OWN ARRAYS ! THE SPACE FOR THESES HEADERS+DOPE VECTORS IS TAKEN FROM GLA %SHORTROUTINE %INTEGER L, U, NP, N, A, SAVE, TGLA %STRING (8) EXNAME %INTEGER FLAG %RECORDNAME V(VARFM) NEWNAME_FLAGS = 0 AMORE: GLA = (GLA+3)&(\3) TGLA = GLA; DIAG FLAG = 0 N = 1 %IF EXTRINSIC = 0 %START NP = RP; N = REC(RP+1); RP = 1+RP+N %FINISH CBPAIR(L,U) LEN = LEN+1 %IF NEWNAME_TYPE = B'10000' INTEGER(TGLA) = LEN!X'00010000' INTEGER(TGLA+4) = L; INTEGER(TGLA+8) = U INTEGER(TGLA+12) = U-L+1 NEWNAME_FORM = B'111'; NEWNAME_DIMENSION = 1 A = NEWNAME_ADDRESS NEWNAME_ADDRESS <- (TGLA-GLA HEAD)+X'D010' %IF EXTRINSIC # 0 %START; ! OWN/EXTRINSIC ARRAY NEWNAME_LEVEL = LEVEL NP = OWNNAME+DICTHEAD FAULT2(7,OWNNAME) %AND %RETURN %C %IF INTEGER(NP+4) # 0 %C %AND BYTEINTEGER(INTEGER(NP+4)+4) = LEVEL %IF EXTRINSIC # 1 %THEN A = OWN HEAD %ELSE %START ! ! TRY TO LOAD EXTRINSICS ! EXNAME <- STRING(INTEGER(NP)) A = 0; ! JUST IN CASE FDP(DATA FDP,EXNAME,FDP DATA REF,ADDR(A),FLAG) %IF FLAG # 0 %START PRINTSTRING('* cannot load '.EXNAME.' ') %RETURN %FINISH FLAG = COMREG(7); ! UNSAT REF LIST CREATE DUMMY REFS(FLAG) %IF FLAG # 0 %FINISH V == RECORD(NEWCELL) V = NEW NAME V_LINK = INTEGER(NP+4); INTEGER(NP+4) = ADDR(V) %FINISH %ELSE %START SAVE = RP; RP = NP C L NAMELIST(16); ! FOR HEADERS IN GLA %FINISH ! NOW FILL HEADERS U = LEN*(U-L+1); ! TOTAL LENGTH OF THE ARRAY L = -L*LEN; ! DISP OF @A(0) FROM @A(FIRST) !! NP = ROUND(NEWNAME_TYPE) !! NP = 0 %IF NEWNAME_TYPE = B'10000' A = (A+7)&(\7) %IF EXTRINSIC # 1 %CYCLE N = GLA+16,16,GLA+N<<4 INTEGER(N) = A+L INTEGER(N+4) = A INTEGER(N+8) = GLA INTEGER(N+12) = OWN LIST BYTEINTEGER(N) <- LEN-1 A = A+U %REPEAT GLA = N+16 %IF EXTRINSIC = 0 %START NEWNAME_ADDRESS <- A RP = SAVE+1; -> AMORE %IF REC(RP) = 1 %FINISH ! %END %ROUTINE PRINT LABEL(%INTEGER LABEL) %SHORTROUTINE %IF LABEL < 0 %THEN WRITE(\LABEL,3) %ELSE %START SPACES(2) PRINTSTRING(STRING(INTEGER(LABEL+DICT HEAD))) %FINISH NEWLINE %END %ROUTINE FIND CYCLE(%INTEGERNAME P) ! SEARCH THE START/CYCLE LIST (HEADED BY 'START HEAD') FOR ! THE LAST CYCLE ENCOUNTERED. ! P WILL HAVE THE VALUE ZERO IF THERE ARE NO CYCLES. ! THIS IS USED BY '%EXIT' AND '%CONTINUE' TO FIND THE ! LABEL TO WHICH THEY MUST JUMP. %SHORTROUTINE P = START HEAD %WHILE P # 0 %CYCLE %RETURN %IF BYTEINTEGER(P+3)&15 = 0 !FOR A CYCLE/REPEAT BLOCK P = INTEGER(P+12); ! LINK %REPEAT %END %ROUTINE GET RESLN VAR(%INTEGERNAME ENTRY) %SHORTROUTINE -> FLT74 %IF REC(RP+2) # 4 %OR REC(RP+4) # 2 RP = RP+4 VAR(LHS) RP = RP+1 %IF REC(RP) # 2 %START FLT74: FAULT(74) RP = ENTRY ENTRY = 0 SKIP EXPRN %FINISH %END %ROUTINE FLOAT(%RECORDNAME VAR, %INTEGER REG) ! THE METHOD OF FLOATING AN INTEGER IS AS FOLLOWS : ! !*L_14,N PICK UP THE INTEGER !*LPR_15,14 ABSOLUTE VALUE TO R15 !*N_14,=X'80000000' MASK OFF THE SIGN BIT !*O_14,=X'4E000000' OR IN THE EXPONENT !*STM_14,15,STACK DUMP THEM SOMEWHERE SAFE !*SDR_2,2 CLEAR THE FLOATING POINT REGISTER !*AD_2,STACK PICK UP THE TWO WORDS AND NORMALIZE %RECORDSPEC VAR(VARFM) PROTECT(8) %AND FPR2 = ADDR(VAR) %IF REG = 2 LOAD(VAR,14) SPLANT(X'10FE') PLANT(X'54ED0000'!17<<2) PLANT(X'56ED0000'!18<<2) EFREE = (EFREE+7)&(\7); ! GET SPACE PLANT(X'90EF0000'+EFREE&X'FFFF'); !SAFE ENOUGH HERE (METHINKS !) DRR(X'2B',REG,REG) DRX(X'6A',REG,0,EFREE) VAR_TYPE = B'1010' VAR_FORM = 128 VAR_ADDRESS <- REG %END %ROUTINE TEMPREAL(%INTEGERNAME ADDRESS) ! TAKES 8 BYTES OF LOCALS FOR INTERMEDIATE EXPRNS. %INTEGERNAME PT %IF MON LOCK # 0 %START ADDRESS = (EFREE+7)&(\7) EFREE = ADDRESS+8 %FINISH %ELSE %START PT == DISP %IF LEVEL = 1 %THEN PT == MAX DISP ADDRESS <- (PT+7)&(\7) PT <- PT+8 %FINISH %END %ROUTINE CRES(%INTEGER LABEL, MASK) %SHORTROUTINE ! COMPILES A -> B . ( C ) . D . ( E ) . F ETC. ! THIS CAN BE VERY HAIRY ESP. IN CONDITIONS, IN WHICH ! CASE 'LABEL' IS SET TO AN INTERNAL LABEL TO BE JUMPED ! TO IF THE RESOLUTION FAILS ! PERM RETURNS A CONDITION CODE OF 8 FOR SUCCESS ! AND 7 FOR FAILURE. %INTEGER A, P, TLAB, ENTRY %RECORD V(VARFM) %BYTEINTEGER F, BASE, SLEN ! 'LHS' SET ON 'A' : RP ON 'ASSOP' : ASSOP=4 BASE = 1 %IF LABEL = RESFLOP %THEN BASE = 0 F = 0 ENTRY = 15<<2+X'45FC0000'; ! FIRST ENTRY INTO PERM TLAB = LABEL %IF MASK # 7 %THEN TLAB = ILAB-1 %AND ILAB = TLAB REG USE(4) = 'S' FAULT(73) %UNLESS LHS_TYPE = B'10000' LHS_FORM = LHS_FORM&B'11111101' LHS_TYPE = 4 %IF LHS_FLAGS&4 # 0 %THEN LHS_TYPE = 0 LOAD(LHS,14); STUAV(14) P = RP R14 = 1 RP = P+2 -> FLT74 %IF REC(RP) # 4; ! NULL (PLUS) R1: %IF REC(RP+2) = 3 %START; ! 'B' MISSING F = 2 -> EXP %FINISH RP = RP+1 -> FLT74 %UNLESS REC(RP+1) = 2; ! OPERAND TYPE 2 = VARIABLE GETSVAR(V); SLEN = CPE LEN RP = RP+1 %IF REC(RP) = 2 %START; ! END OF EXPRN -> FLT74 %IF F = 0 ! ! ASSIGN FINAL STRING ! V_FORM = V_FORM&B'11111101' DRX(X'42',4,0,EFREE) %IF TUAV # 0 V_LENGTH = SLEN S CPE(V,EFREE) LOAD(V,1); GPR1 = 0; ! FORGET IT PLANT(X'444D0000'!19<<2); PLANT(X'42410000') ! RMOV: MVC_0(0,1),0(14) ! JUMP TO(LABEL,15) %UNLESS MASK = 7 -> 10 %FINISH RP = RP+1 -> FLT74 %UNLESS REC(RP) = 12 %AND REC(RP+2) = 3 ! '.(' EXP: RP = RP+2 CSEXPRN(A) RP = RP+1 %IF REC(RP) = 2 %THEN F = F!4 %ELSE %START -> FLT74 %UNLESS REC(RP+1) = 12; ! '.' %FINISH S LOAD(A,1) %IF F&2 # 0 %THEN SPLANT(X'1F00') %ELSE %START %IF V_FLAGS&4 # 0 %THEN DSI(X'92',X'D03B',SLEN) %C %ELSE %START %IF V_INDEX = 0 %THEN A = V_ADDRESS %ELSE %START DRX(X'41',15,V_INDEX,V_ADDRESS); A = X'F000' %FINISH DSS(X'D2',1,X'D03B',A) %FINISH V_FORM = V_FORM&B'11111101' LOAD(V,0) %FINISH PLANT(ENTRY) ENTRY = 16<<2+X'45FC0000'; ! SECOND AND SUBSEQUENT ENTRY POINT GPR1 = 0; ! NOW FORGET IT %IF BASE = 0 %THEN DRX(X'47',7,0,TLAB) %C %ELSE JUMP TO(TLAB,7) %IF F&4 # 0 %START SPLANT(X'1244') !*LTR_4,4 %IF BASE = 0 %THEN DRX(X'47',7,0,TLAB) %C %ELSE JUMP TO(TLAB,7) F = 1 -> 10 %FINISH F = 1 RP = RP+1 -> R1 FLT74: RP = P SKIPEXPRN FAULT(74) 10: REGUSE(4) = 0 %IF F = 1 %AND MASK # 7 %THEN REMOVE LABEL(TLAB) R14 = 0 %END %ROUTINE SET CONST(%INTEGER WTYPE, SLEN, PLUS) ! THIS ROUTINE PICKS UP THE CONSTANT FROM 'REC' AND STORES ! IT AT 'GLAP', FAULTING IF THE SIZE OR TYPE IS WRONG. %SHORTROUTINE %BYTEINTEGER CTYPE, TYPE HOLD %LONGREAL WORK %CONSTINTEGER M1 = X'80000000' %CONSTINTEGER SWLIST = X'0C040800' %CONSTINTEGER SWL2 = X'10001400' %CONSTINTEGER M2 = X'4E000000' %CONSTINTEGER C255 = X'000000FF' ! *CLI_PLUS+3,0; ! PLUS = 0 => NO CONSTANTS *BC_7, *MVI_CTYPE,255; ! SHOW OK *XC_WORK(8),WORK; ! WORK = 0 -> ZZ NZ: *L_4,K; ! RP *LA_6,0(4,4) *A_6,REC *IC_0,1(6); ! TYPE OF CONSTANT FOUND *STC_0,CTYPE *MVC_WORK(8),2(6); ! MOVE IN INFO (NOW DOUBLE WORD ALLIGNED !) *CLI_CTYPE,4; ! \INTEGER ? *BC_7,<1>; ! NO, SO I'VE GOT AN INTEGER *TM_WTYPE+3,8 *BC_8,<1>; ! NO, SO I WANT A REAL, THEREFORE FLOAT IT *MVI_CTYPE,10; ! SET TYPE TO REAL *BCTR_4,0 *BCTR_4,0; ! KNOCK R4 BACK 2 AS 'REAL' WILL UP ITBY 2 *L_14,WORK; ! SEE ALSO ROUTINE FLOAT *LPR_15,14 *N_14,M1 *O_14,M2 *STM_14,15,WORK *SDR_0,0 *AD_0,WORK *STD_0,WORK 1: *LA_4,2(4); ! RP PAST CONST (2 SHORTS) *MVC_TYPE HOLD(1),CTYPE; ! PRESERVE OLD TYPE *NC_CTYPE(1),WTYPE+3 *NI_CTYPE,B'11100'; ! CLEARS 'CTYPE' IF TYPES DIFFER ZZ: *TR_WTYPE+3(1),SWLIST-4; ! GET SWITCHING INDEX *SLR_5,5 *IC_5,WTYPE+3 *L_1,GLAP; ! WHERE TO PLUG THE CONSTANT *BC_15,<2>(5); ! SWITCH ON TYPE ICOMP: *L_2,WORK; ! ROUTINE TO GET AN INTEGER + SIGN *CLI_PLUS+3,2; ! '-' *BCR_7,15 *LCR_2,2; ! NEGATE IT *BCR_15,15; ! RETURN 2: *BC_15, *BC_15, *BC_15, *BC_15, *BC_15, !LONGREAL: *LA_4,2(4); ! REAL USES TWO SHORTS EXTRA *LD_0,WORK *CLI_PLUS+3,2; ! '-' *BC_7,<11> *LCDR_0,0; ! NEGATE IT 11: *STD_0,0(1); ! STORE IT -> 6; ! RETURN REAL: *LA_4,2(4) *LD_0,WORK *CLI_PLUS+3,2 *BC_7,<12> *LCDR_0,0 12: *STE_0,0(1) -> 6 INT: *BAL_15,; ! GET VALUE *ST_2,0(1) -> 6 SHORT: *BAL_15, *STH_2,0(1) *XC_WORK(1),WORK+1 *MVC_CTYPE(1),WORK *XI_CTYPE,255 -> 6 BYTE: *BAL_15, *STC_2,0(1) *CL_2,C255; ! > 255 ? *BC_13,<6> *MVI_CTYPE,0; ! CAPACITY EXCEEDED MOVE: *MVC_0(0,1),0(2) STR: *CLI_TYPE HOLD,B'10100'; ! POSSIBLE SYMBOL *BC_7, *MVI_0(1),1; ! LENGTH 1 *MVC_1(1,1),WORK+3; ! MOVE IN SYMBOL *CLI_1(1),0; ! NULL STRING ? *BC_7,<6> *MVI_0(1),0; ! SET LENGTH TO ZERO -> 6 NSYM: *CLC_SLEN+3(1),WORK+1; ! TOO BIG ? *BC_11,<5> *MVI_CTYPE,0; ! CAPACITY EXCEEDED *MVC_WORK+1(1),SLEN+3; ! SET TO MINIMUM LENGTH 5: *IC_5,WORK+1 *LH_2,WORK+2; ! INDEX INTO LINE FOR TEXT *A_2,LINE; ! NOW @ TEXT *STC_5,0(2) *EX_5,; ! MOVE IN TEXT *TM_PLUS+3,3; ! '+' OR '-' *BC_9,<6> *MVI_CTYPE,0; ! INVALID OPERATOR 6: *ST_4,K; ! UPDATE 'TEMP' RP FAULT(44) %IF CTYPE = 0 %END %ROUTINE C OWN DEC ! THIS ROUTINE DEALS WITH ALL %OWN/%CO !!! %SHORTROUTINE %INTEGER LL, UU, M, S, LENV %INTEGER BP, CW, CG, REP, ML, GP %INTEGER L, T, Z, R, N, PLUS, ZZ DECFLAG = 1; ! SAVE OWN DECLARATIONS RP = 2; ! SKIP OWN/CONST/EXTERNAL/EXTRINSIC EXTRINSIC = REC(RP) EXTRINSIC = 3 %IF EXTRINSIC # 1 NEWNAME = 0 VTYPE(NEWNAME) NEWNAME_LEVEL = LEVEL L = NEWNAME_LENGTH T = NEWNAME_TYPE %IF EXTRINSIC = 1 %OR NEWNAME_TYPE = 16 %C %THEN DIAGFLAG = DIAGFLAG!128 %C %AND NEWNAME_FORM = 3 %ELSE NEWNAME_FORM = 1 R = ROUND(T) Z = L; ZZ = Z; LENV = ZZ %IF T = 16 %START FAULT(70) %AND -> FAIL %IF Z = 0 Z = Z+1; ZZ = 4 %FINISH RP = RP+1 %IF REC(RP) = 2 %START; ! SCALARS GLAP = (GLA+R)&(\R) GLA = GLAP %UNTIL REC(RP) = 2 %CYCLE RP = RP+1; N = REC(RP) C NAME LIST(N,ZZ) %IF T = 16 %AND EXTRINSIC # 1 %START ! STRINGS TO ARRAY SPACE S = A SPACE %CYCLE GLAP = GLAP,4,GLAP+N<<2 INTEGER(GLAP) = S; S = S+Z BYTEINTEGER(GLAP) <- L %REPEAT GLAP = A SPACE %FINISH PLUS = 0 RP = RP+1 %IF EXTRINSIC = 1 %START RP = RP+4 %AND FAULT(45) %IF REC(RP) = 1 %FINISH %ELSE %START %IF REC(RP) = 1 %C %THEN RP = RP+1 %AND PLUS = REC(RP) K = RP+1 SET CONST(T,L,PLUS); ! BRING IN THE CONSTANT RP = K %IF PLUS # 0 MOVE((N-1)*Z,GLAP,GLAP+Z) %IF N > 1 ! DUPLICATE IT A SPACE = S %IF T = 16 %FINISH GLAP = GLA RP = RP+1 %REPEAT %IF T = 16 %AND EXTRINSIC # 1 %C %THEN ASPACE = (ASPACE+7)&(\7) CLIST = 1 -> EX %FINISH ! OWN ARRAYS '%ARRAY'(NAME)(CBPAIR)(C LIST): FAULT(40) %AND -> FAIL %IF COMP MODE&B'1000' # 0 %IF OWN DISP = 0 %START GLA = (GLA+3)&(\3) OWN DISP = GLA GLA = OWN DISP+4 %FINISH CLIST = 2; ! FLAG TO STOP CSS FROM CALLING THIS ROUTINE ! AGAIN, ALSO FLAG FOR PARSE RP = RP+1; OWN NAME = REC(RP) BP = RP; ! SAVE IT FOR DEC CONST ARRAY C B PAIR(LL,UU); ! GET THE BOUNDS CG = 0 -> DEC %IF EXTRINSIC = 1; ! CANNOT GIVE CONSTANTS CW = UU-LL+1; ! CONSTANTS WANTED M = CW*Z; ! TOTAL LENGTH OF THE ARRAY %IF LEVEL = 1 %START; ! TREAT AS NORMAL GLAP = (A SPACE+7)&(\7) FAULT(98) %AND -> FAIL %IF GLAP+M > OWN TOP ! TOO BIG %FINISH %ELSE %START; ! THE ARRAY WILL HAVE TO BE ! MOVED UP TO THE ROUTINE BLOCK AT END GLAP = (OWN TOP-M)&X'FFFFF8';! UP FROM THE BOTTOM FAULT(98) %AND -> FAIL %IF GLAP < A SPACE ! TOO BIG %FINISH OWN HEAD = GLAP; ! ABSOLUTE TOP OF THE ARRAY %UNLESS NL # LINE(SYM) # ';' %START; ! NO CONSTANTS => ZERO INTEGER(GLAP) = 0; MOVE(M-4,GLAP,GLAP+4) GLAP = GLAP+M -> DEC %FINISH -> FAIL %UNLESS LINE(SYM) = '=' CG = -CW; SYM = SYM+1 1: RP = 20; PLUS = 3; S = LINE(SYM) %IF S = '+' %OR S = '-' %START SYM = SYM+1; PLUS = 2 %IF S = '-' %FINISH -> FAIL %IF CONSTANT(T) # 0 REP = 1; K = 20; SET CONST(T,L,PLUS) %IF LINE(SYM) = '(' %START SYM = SYM+1; RP = 20 -> FAIL %IF CONSTANT(4) # 0 RP = 20; GET4(REP) ->FFAIL %IF REP&X'FFFF0000' # 0 -> FAIL %UNLESS LINE(SYM) = ')' SYM = SYM+1 %FINISH CG = CG+REP -> FFAIL %IF CG > 0 ML = (REP-1)*Z MOVE(ML,GLAP,GLAP+Z) %IF ML > 0 GLAP = GLAP+ML+Z -> DEC %IF LINE(SYM) # ',' SYM = SYM+1 %IF LINE(SYM) = NL %START; ! END OF THIS LINE SM = 0 RECONSTRUCT; ! BRING IN NEXT LINE SYM = 1 DEC2 = TEXTIN; ! TO SAVE DECLARATION %FINISH -> 1 FFAIL: FAULT(45) FAIL: SM = SYM %IF SYM > SM C LIST = 0 -> EX DEC: -> FAIL %IF NL # LINE(SYM) # ';' -> FFAIL %IF CG # 0 RP = BP; GP = GLA-GLAHEAD+X'D010' OWN LIST = OWN HEAD-OWN END DEC CONST ARRAY(LENV) -> EX %IF EXTRINSIC = 1 %IF LEVEL = 1 %START A SPACE = (GLAP+7)&(\7) %FINISH %ELSE OWN TOP = OWN HEAD %IF BASE REG # 9 %START !*LM_14,1,HEADER !*SR_14,15 !*LA_10,0(1,10) !*A_15,??(13) !*AR_14,15 !*STM_14,15,HEADER DRX(X'98',14,1,GP) SPLANT(X'1BEF') PLANT(X'41F1A000'); ! R15 = R1+R10 PLANT(X'5AFD0000'-GLAHEAD+OWN DISP) ! DISP OF ARRAY SPLANT(X'1AEF') DRX(X'90',14,15,GP) %FINISH EX: EXTRINSIC = 0; ! RESTORE IT %END %ROUTINE DUMP SIGNAL(%INTEGER L) %SHORTROUTINE %INTEGER J %PRINTTEXT ' REGISTERS ' %CYCLE J = 0,1,15; NEWLINE %IF J&3 = 0 WRITE(J,3); SPACES(3) HEX(INTEGER(SIGAREA+J<<2+8)) SPACES(2) %REPEAT %PRINTTEXT ' CODE ' L = (L+7)&X'FFFFF8' IIDUMP(L-80,L+56) NEWLINES(3) %END %ROUTINE CREATE DIAG LIST(%INTEGERNAME NLINK) %SHORTROUTINE %RECORDNAME DVAR(VARFM) %INTEGER VNUM, J %BYTEINTEGER FLAG %CYCLE %WHILE INTEGER(DPT) > 0 %CYCLE DVAR == RECORD(NEW CELL) FLAG = BYTEINTEGER(DPT); ! TYPE & FORM FLAG VNUM = D TAB MAP(FLAG>>1&15) VNUM = VNUM+6 %IF FLAG&X'40' # 0 ! NAME TYPE DVAR = DIAG VAR(VNUM); ! COPY IN VAR INFO *L_1,DPT; **2,@DVAR_ADDRESS *MVC_0(2,2),1(1); ! MOVE IN ADDRESS FIRST = BYTEINTEGER(DPT+4); ! FIRST CHAR FOR HASHING LAST = BYTEINTEGER(DPT+BYTEINTEGER(DPT+3)+3) ! LAST CHAR J = FIND(DPT+3); ! LOOK FOR NAME IN DICTIONARY %IF J < 0 %START; ! NOT IN J = \J; ! POSITION OF FREE CELL INTEGER(J+DICT HEAD) = DICTFREE STRING(DICTFREE) = STRING(DPT+3) DICTFREE = DICTFREE+BYTEINTEGER(DICTFREE)+1 FAULT(104) %AND ABORT %IF DICTFREE > DICT MAX %FINISH SHORTINTEGER(ADDR(DVAR_LEVEL)) = J ! NAME INFO FORMAT LIST NLINK = ADDR(DVAR) NLINK == DVAR_LINK DPT = (DPT+BYTEINTEGER(DPT+3)+7)&(\3) %REPEAT %EXIT %IF INTEGER(DPT) # -2 DPT = DPT+4 %REPEAT NLINK = 0; ! MARK THE END OF THE LIST %END ! %ROUTINE DEFINE DIAGS(%INTEGER AGLA, BLOCK) %SHORTROUTINE %INTEGER P DIAG HEAD == DIAG BASE DPT = INTEGER(AGLA+28)+INTEGER(AGLA+12) %WHILE DIAG HEAD_LINK # 0 %CYCLE DIAG HEAD == RECORD(DIAG HEAD_LINK) %RETURN %IF DIAG HEAD_DIAGS = DPT %C %AND DIAG HEAD_LINE = BLOCK %REPEAT ! NOT IN SO PUT IT IN P = NEWCELL DIAG HEAD_LINK = P; DIAG HEAD == RECORD(P) DIAG HEAD_DIAGS = DPT %CYCLE %RETURN %IF INTEGER(DPT) = X'E2E2E2E2' ! END OF DIAGS %EXIT %IF INTEGER(DPT) = X'C2C2C2C2' %C %AND SHORTINTEGER(DPT+4) = BLOCK DPT = DPT+4 %REPEAT DIAG HEAD_LINE = BLOCK DIAG HEAD_NAME = DPT-DIAG HEAD_DIAGS+7 %IF BYTEINTEGER(DPT+7) = 0 %START; ! BEGIN BLOCK DPT = DPT+12 %FINISH %ELSE %START DPT = (DPT+11+BYTEINTEGER(DPT+7))&(\3) %FINISH CREATE DIAG LIST(DIAG HEAD_INDEX) %END %ROUTINE SET UP MONITOR(%BYTEINTEGER MODE) %SHORTROUTINE %ROUTINESPEC POP %ROUTINESPEC PUSH %RECORDFORMAT HFM(%RECORDNAME HEAD, %INTEGER FRAME, L, B, GLA) %RECORDSPEC HFM_HEAD(MON DIAG HEAD FM) %OWNRECORDARRAY HOLD(1 : 8)(HFM) %OWNINTEGER PPS %INTEGER PT, R, OLD GLA %STRING (31) NAME ! %IF MODE = 0 %START; ! INITIAL CALL NEWLINE OLD CODE TOP SAVE = CODE TOP ! ! PROTECT THE CALLING CODE FROM THE INTERPRETER ! CODE TOP = (CODEIN+31)&(\7) MON ENTRY = MON FRAME MONITORGLA = MON INFO PPS = 0 MONITOR BLOCK = SHORTINTEGER(MONITORGLA+20) MONITOR LINE = SHORTINTEGER(MONITORGLA+22) %FINISH %ELSE %START PT = DIAG HEAD_DIAGS+DIAG HEAD_NAME-1 %IF MODE = '-' %START; !BACK ALONG FRAME OLD GLA = MONITOR GLA PUSH; ! PRESERVE INFO %IF OLD GLA # MONITOR GLA %START %IF MONITOR GLA = GLA HEAD %THEN POP %C %ELSE %START MONITOR BLOCK = SHORTINTEGER(MONITOR GLA+20) MONITOR LINE = SHORTINTEGER(MONITOR GLA+22) %FINISH %FINISH %ELSE %START %IF BYTEINTEGER(PT+1) = 0 %START ! BLOCK MONITOR LINE = MONITOR BLOCK MONITOR BLOCK = INTEGER(PT+2) %FINISH %ELSE %START R = BYTEINTEGER(PT)<<2 MON FRAME = INTEGER(MON FRAME+R) MONITOR BLOCK = SHORTINTEGER(MONFRAME) MONITOR LINE = SHORTINTEGER(MON FRAME+2) %FINISH %FINISH %FINISH %ELSE POP; ! FORWARD ALONG FRAME %FINISH ! DEFINE DIAGS(MONITORGLA,MONITOR BLOCK) ! INTEGER(GLA HEAD) = MON FRAME ! %IF DIAG HEAD_LINE = 0 %THEN NAME = '?' %ELSE %START NAME = STRING(DIAG HEAD_DIAGS+DIAG HEAD_NAME) %FINISH NAME = 'BLOCK' %IF NAME = '' PRINTSTRING('break: '.NAME.' (') WRITE(MONITOR BLOCK,1) %PRINTTEXT ' ) line' WRITE(MONITOR LINE,1) NEWLINE %RETURN %ROUTINE POP %RECORDNAME T(HFM) %RETURN %IF PPS <= 0 T == HOLD(PPS); PPS = PPS-1 DIAG HEAD == T_HEAD MON FRAME = T_FRAME MONITOR GLA = T_GLA MONITOR LINE = T_L MONITOR BLOCK = T_B %END %ROUTINE PUSH %RECORDNAME T(HFM) POP %IF PPS >= 8 PPS = PPS+1; T == HOLD(PPS) T_HEAD == DIAG HEAD T_FRAME = MON FRAME T_GLA = MONITOR GLA T_L = MONITOR LINE T_B = MONITOR BLOCK MONITOR GLA = INTEGER(MON FRAME+52) %END %END %INTEGERFN ASL LENGTH *SR_2,2 *L_1,ASL *LA_3, *BC_15, LOOP: *L_1,12(1) IN: *LTR_1,1 *BC_8, *BCTR_2,3 OUT: *LCR_1,2 *LM_4,14,16(8) *BCR_15,15 %END %ROUTINE SET FILE(%BYTEINTEGER FLAG, %STRING (3) STREAM) %BYTEINTEGER DOT STREAM = 'ST'.STREAM %IF FLAG # 0 %THEN RP = RP+1 %AND DOT = REC(RP) %C %ELSE DOT = 0 RP = RP+1; IOFILE <- STRING(INTEGER(REC(RP)+DICTHEAD)) IOFILE <- '.'.IOFILE %IF DOT = 1 CLEAR(STREAM) DEFINE(STREAM.','.IOFILE) %END %ROUTINE DEFINE TRACE %SHORTROUTINE %STRING (8) RTNAME %INTEGER N, J %BYTEINTEGER ON ! RP = RP+1; ON = REC(RP); ! 1 = ON, 2 = OFF %IF ON = 2 %START; ! OFF, SO DUMP NAME LIST %RETURN %IF MON FILE CREATED = 0; ! NO MONITOR FILE RT MON ENABLE = 0; ! STOP SPECIAL RT ENTRY %CYCLE N = 0,1,127; ! LOOK FOR ROUTINES %IF R ENTRY(N) = 255 %START; ! ROUTINE ENTRY ACTIVE RTNAME <- STRING(INTEGER(DICTHEAD+MONNAME(N))) STRING(RT MON NAMES+9*N) = RTNAME %FINISH %REPEAT ! ! NOW SET UP HEADER ! INTEGER(RT MON FILE) = INTEGER(STACKTOP+12)- %C RT MON FILE BYTEINTEGER(RT MON FILE) = 0 INTEGER(RT MON FILE+12) = RT MON HEAD-RT MON FILE BYTEINTEGER(STACKTOP+11) = 0;! DYNAMIC OFF %FINISH %ELSE %START %IF MON FILE CREATED = 0 %START N = 64; ! FOUR SEGMENTS SHOULD BE ENOUGH IIGEN('II#DATA',N,J); ! CREATE IT %IF J # 0 %START %PRINTTEXT '* cannot create II#DATA ' %RETURN %FINISH MON FILE CREATED = 1 RT MON FILE = N RT MON NAMES = RT MON FILE+16; ! PAST HEADER RT MON HEAD = RT MON NAMES+9*128 INTEGER(STACKTOP+12) = RT MON HEAD %FINISH BYTEINTEGER(STACKTOP+11) = 128; ! DYNAMIC ON RT MON ENABLE = 1 %FINISH %END %ROUTINE SET CONTROL(%INTEGER N) ! ! RESETS THE VALUE OF THE CONTROL VARIABLES ! A HEX DIGIT OF 'F' LEAVES THE CURRENT VALUE OF THAT VARIABLE ! %OWNINTEGER M1, M2 = X'0F0F0F0F' %OWNINTEGER T1, T2, T3 = 0, T4 = 15 %OWNINTEGER MIN1,MIN2=-1 %LONGREAL WORK1, WORK2 ! *UNPK_WORK1(9),N(5) *NC_WORK1(8),M1 *MVC_WORK2(8),WORK1 *TR_WORK2(8),T1 *NC_DCOMP(8),WORK2 *XC_WORK2(8),MIN1 *NC_WORK1(8),WORK2 *OC_DCOMP(8),WORK1 ! %END %ROUTINE COMPARE RT(%RECORDNAME V, %INTEGER LIST) %SHORTROUTINE %RECORDSPEC V(VARFM) %IF V_FORM&128 = 0 %START; ! NOT YET DEFINED V_INDEX = LIST; ! SET IT FROM THE FIRST USE V_FORM = V_FORM!128; ! DEFINED NOW %RETURN %FINISH COMP P LIST(-V_INDEX,LIST);! DON'T DESTROY THE LIST %END %ROUTINE SPECIAL(%INTEGER ST) %SHORTROUTINE %SWITCH SPS(0 : 29) %INTEGER GLA WORD %INTEGERNAME P, NAME %BYTEINTEGER FIND %RECORDNAME VAR(VARFM) %RECORDNAME RT(RTFM) %RECORDNAME TB(RBFM) %INTEGER LINE, J, N -> SPS(ST) ! SPS(29): ! TRACE (ON/OFF) ! DEFINE TRACE -> END ! ! SPS(28): ! $LOOK ! EDIT(2); -> END ! SPS(1): ! 'EDIT' [NAME] ! EDIT(0); -> END ! SPS(2): ! 'COMPILE' [NAME] ! FAULT(33) %AND -> END %IF IOFLAG # 0 %OR COMP MODE # 0 SELECTINPUT(0) SET FILE(0,'78') SELECTINPUT(78) PRINTED = 2 IOFLAG = 1; COMP MODE = COMP MODE!64 -> END ! SPS(3): ! 'SENDTO' [NAME] ! %IF COMP MODE # 0 %START FAULT(33); -> END %FINISH SELECTOUTPUT(0) RP = RP+1; ! SKIP OPTIONAL 'TO' SET FILE(0,'79') ! SPS(0): ! SEND TO FROM ABORT ! SELECT OUTPUT(79) SEND TO; -> END ! SPS(24): ! $FIND [NAME]':'[NUMBER] ! FIND = 1 LINE = REC(RP+4); ! LINE NUMBER WANTED LINE = LINE-1 %IF LINE > 1 LIST = 'N' -> P LIST ! SPS(23): ! $LIST NAME ! FIND = 0 LIST = 'Y' P LIST: FAULT(33) %AND -> END %IF LEVEL # 1 %OR COMP MODE # 0 RP = RP+1; N = REC(RP)+DICT HEAD; ! NAME VAR == RECORD(INTEGER(N+4)) %IF ADDR(VAR) = 0 %OR VAR_TYPE = 31 %C %OR VAR_FORM&8 = 0 %OR VAR_FLAGS&34 # 0 %C %OR VAR_LEVEL = 0 %START PRINTSTRING('* cannot list '.STRING(INTEGER(N)).' ') -> END %FINISH %IF FIND = 0 %START RP = RP+1 %IF REC(RP) = 1 %START SELECTOUTPUT(0) SET FILE(1,'79') SELECTOUTPUT(79) FIND = 3 %FINISH %FINISH RT == RTS(VAR_DIMENSION) TB == RECORD(RT_ENVIR) NEWLINE COMP MODE = 3 TEXTP = TB_TEXT N = TB_LENGTH+TEXTP-1; ! END OF TEXT LINE NUM = 0 %CYCLE LIST = 'Y' %AND FIND = 2 %C %IF FIND = 1 %AND LINE NUM = LINE-1 RECONSTRUCT %EXIT %IF COMP MODE&1 = 0 %OR TEXTP >= N %C %OR (FIND = 2 %AND LINE NUM-1 > LINE) %REPEAT %IF FIND = 1 %THEN %PRINTTEXT 'line not found' NEWLINE PROMPTCH = ':'; ! IN CASE OF UNFINISHED STRINGS !!! COMP MODE = 0 %IF FIND = 3 %START SELECTOUTPUT(0) CLOSESTREAM(79) CLEAR('ST79') %FINISH -> END ! SPS(17): ! $UP ! FIND = '-'; -> UD ! SPS(18): ! $DOWN ! FIND = '+' UD: -> END %IF MON LOCK = 0 N = 1 RP = RP+1 %IF REC(RP) = 1 %START RP = RP+1; ! OVER TYPE GET4(N); N = N&15 %FINISH %WHILE N > 0 %CYCLE SET UP MONITOR(FIND) N = N-1 %REPEAT -> END ! SPS(22): ! $WHERE SPS(16): ! $MONITOR ! GLA WORD = INTEGER(MONITOR GLA+20) INTEGER(MONITOR GLA+20) = INTEGER(ADDR(MONITOR BLOCK)) PDIAG(MON FRAME-4,0,0) %IF MON LOCK # 0 INTEGER(MONITOR GLA+20) = GLA WORD -> END ! SPS(19): ! $RESUME ! %PRINTTEXT 'nothing to resume ' %AND -> END %C %IF MON LOCK = 0 RP = RP+1 %IF REC(RP) = 1 %START RP = RP+1; GET4(N) N = 1 %AND UNTRAP %IF N <= 0 MON REP = N-1 %FINISH MON LOCK = 0 DIAG HEAD == DIAG BASE CODE TOP = OLD CODE TOP SAVE; ! RELEASE CALLING CODE J = MON ENTRY RUNNING = 'Y' *L_1,J *LM_4,15,16(1) *BCR_15,15 ! SPS(20): ! $TRAP (NUMBER)(BDEF') ! MON REP = 0 RP = RP+1; ! SKIP TYPE GET4(J) N = 0 RP = RP+1 %IF REC(RP) = 1 %START RP = RP+1; ! SKIP TYPE GET4(N) %FINISH ITRAP(N,J) -> END ! SPS(21): ! $IGNORE ! MON REP = 0 UNTRAP -> END ! SPS(15): ! $CANCEL ! FAULTY = 1 SIGNAL(2,244,0,J); ! FIRE OFF SIGNAL WT 244 -> END ! SPS(14): ! MLEVEL (LEV) ! RP = RP+1 %IF REC(RP) = 1 %THEN MLEVEL = X'FFFF' %C %ELSE MLEVEL = REC(RP+3) -> END ! SPS(13): ! DELETE (NAME) ! %IF LEVEL # 1 %START NO: %PRINTTEXT 'no ! ' -> END %FINISH N = REC(RP+1); ! NAME NAME == INTEGER(N+DICTHEAD+4) FAULT2(16,N) %AND -> END %IF NAME = 0 VAR == RECORD(NAME) %IF VAR_LEVEL = 0 %THEN -> NO %IF VAR_TYPE = 31 %START; ! RECORDFORMAT SO REMOVE RECORDS J = VAR_INDEX!X'80000000'; ! FORMAT LIST %CYCLE N = DICTHEAD,8,DICTHEAD+4088 P == INTEGER(N+4) %IF P # 0 %START VAR == RECORD(P) TIDY(P) %IF VAR_INDEX = J %FINISH %REPEAT %FINISH %ELSE %START %IF VAR_FORM&B'1000' # 0 %START; ! ROUTINE %IF VAR_FLAGS>>4&3 # 2 %AND VAR_FLAGS&2 = 0 %START ! DELETE ORDINARY ROUTINE EDIT(1); -> END %FINISH J = VAR_ADDRESS&X'FFF'+GLAHEAD RELEASE RT(VAR_DIMENSION) *L_15,J; *MVC_0(12,15),APERM %FINISH %ELSE %START J = DIAGPT %WHILE SHORTINTEGER(J) # 0 %CYCLE BYTEINTEGER(J+4) = '?' %AND %EXIT %C %IF SHORTINTEGER(J+2) = N ! DISABLE DIAG TABLE ENTRY J = J+6; ! TRY NEXT ENTRY %REPEAT %FINISH %FINISH TIDY(NAME) -> END ! SPS(9): ! INPUT (FILE NAME) ! SELECTINPUT(0) SET FILE(1,'78') SELECTINPUT(78) -> END ! SPS(10): ! OUTPUT (FILE NAME) ! -> END %IF STUDENT # 0 SELECTOUTPUT(0) SET FILE(1,'79') SELECTOUTPUT(79) SYSOUT = 79 -> END ! SPS(11): ! SYNTAX ! SYNTAX = 'Y'; -> END ! SPS(12): ! NOSYNTAX ! SYNTAX = 'N'; -> END ! SPS(26): ! SYSOUT ! -> END %IF STUDENT # 0 RIM(0,'sysout:'); READ(SYSOUT); SKIPSYMBOL SELECTOUTPUT(SYSOUT) -> END ! SPS(4): ! INFO NAME ! RP = RP+1; N = REC(RP)+DICT HEAD; NAME INFO(N) -> END ! SPS(6): ! NAMES ! %CYCLE J = DICT HEAD,8,DICTHEAD+4088 NAME INFO(J) %UNLESS INTEGER(J) = 0 %REPEAT -> END ! SPS(25): ! FORCE ! ->END %IF STUDENT # 0 -> END %IF SIGAREA = 0; ! NO INTERRUPTS HANDLED RUNNING = 'Y'; ! TO ALLOW INT:Q WT = BYTEINTEGER(SIGAREA+3); ! SIGNAL WT N = INTEGER(SIGAREA+4); ! ADDRESS OF ERROR %PRINTTEXT ' $ SIGNAL WT'; WRITE(WT,1) %PRINTTEXT ' at '; HEX(N) DUMP SIGNAL(N) RUNNING = 'N' -> END ! SPS(27): ! CLEAR ! *L_1,AREG; *XC_0(5,1),0(1); ! CLEAR REGUSE -> END ! SPS(7): ! DUMP ! INT DUMP STOP ! SPS(8): ! MAP ! N = 0 %CYCLE J = 0,1,127 N = N+1 %IF RENTRY(J) # 255 %REPEAT %PRINTTEXT 'asl '; HEX(ASL) WRITE(ASL LENGTH,7); NEWLINE %PRINTTEXT 'routines ' HEX(GLAHEAD+RTBASE&X'FFF'); WRITE(N,7); NEWLINE %PRINTTEXT 'code top '; HEX(CODETOP); NEWLINE %PRINTTEXT 'astack '; HEX(ASTACK); NEWLINE %PRINTTEXT 'text head '; HEX(TEXT HEAD); NEWLINE %PRINTTEXT 'perm '; HEX(APERM); NEWLINE %PRINTTEXT 'gla ' HEX(GLAHEAD); WRITE(4096-GLA+GLAHEAD,7); NEWLINE -> END ! SPS(5): ! CODE ! IIDUMP(GLAHEAD,GLAHEAD+320) END: %END %ROUTINE UN CLAIM %SHORTROUTINE %INTEGER J %CYCLE J = 4,1,8 REG USE(J) = 0 %UNLESS REG USE(J) = 'L' %REPEAT SUSPEND = 'Y' %END %ROUTINE ABORT ! SOMETHING VERY NASTY HAS HAPPENED, SO TRY TO COLLAPSE ! IN A GRACEFULL MANNER RESET IO %PRINTTEXT ' ************ ABORT ************ ABORT ************ ABORT ************ ' SELECTOUTPUT(0); CLEAR('ST79') IOFILE = 'II#ABORT' DEFINE('ST79,II#ABORT') SPECIAL(0); ! SAVE ROUTINES IF POSSIBLE DECODE(CODESTART,CODEIN,R10) PRINT USE SPECIAL(7) %END ! THE NEXT THREE ROUTINES ARE ONLY USED FOR DEBUGGING ! OBSCURE COMPILER FAULTS AND CAN BE REMOVED IF NESC. ! !****************************************************** %ROUTINE PRINT USE %SHORTROUTINE %INTEGER N; %BYTEINTEGER P %CYCLE N = 4,1,8 P = REG USE(N) %IF P # 0 %START WRITE(N,1); SPACES(3) %IF P = 'C' %THEN %PRINTTEXT 'claimed' %ELSE %START %IF P = 'L' %THEN %PRINTTEXT 'locked' %C %ELSE %START %IF P = 'S' %C %THEN %PRINTTEXT 'string wk' %C %ELSE %PRINTTEXT 'unknown' %FINISH %FINISH NEWLINE %FINISH %REPEAT %END %ROUTINE NAME INFO(%INTEGER NAME) %SHORTROUTINE %INTEGER P, S P = INTEGER(NAME+4) %RECORDNAME V(VARFM) %STRINGNAME SN V == RECORD(P) %RETURN %IF P = 0 %OR V_LEVEL = 0 SN == STRING(INTEGER(NAME)) S = LENGTH(SN) S = 12 %IF S > 12 PRINTSTRING(SN) SPACES(12-S) %CYCLE PRINT RECORD(V); NEWLINE P = INTEGER(P+12); %EXIT %IF P = 0 V == RECORD(P); SPACES(12) %REPEAT %END %ROUTINE PRINT RECORD(%RECORDNAME N) %SHORTROUTINE %RECORDSPEC N(VARFM) WRITE(N_TYPE,3) %AND SPACE %IF SHORT FORM # 0 %IF N_TYPE = B'100' %THEN %PRINTTEXT 'INTEGER' %C %ELSE %START %IF N_TYPE = B'101' %THEN %PRINTTEXT 'BYTE ' %C %ELSE %START %IF N_TYPE = B'110' %C %THEN %PRINTTEXT 'SHORT ' %ELSE %START %IF N_TYPE = B'1000' %C %THEN %PRINTTEXT 'REAL ' %ELSE %START %IF N_TYPE = B'1010' %C %THEN %PRINTTEXT 'LONG ' %ELSE %START %IF N_TYPE = B'10000' %C %THEN %PRINTTEXT 'STRING ' %ELSE %START %IF N_TYPE = B'111' %C %THEN %PRINTTEXT 'RECORD ' %C %ELSE %START %IF N_TYPE = 31 %C %THEN %PRINTTEXT 'FORMAT ' %C %ELSE %START %IF N_TYPE = 64 %C %THEN %PRINTTEXT 'SWITCH ' %C %ELSE %START %IF N_LEVEL = 0 %C %THEN %PRINTTEXT %C 'PRE-DEC' %C %ELSE %PRINTTEXT 'UNKNOWN' %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH %FINISH WRITE(N_FORM,3) %AND SPACE %IF SHORT FORM # 0 %IF N_FORM&B'100' # 0 %THEN %PRINTTEXT 'ARRAY' %C %ELSE %START %IF N_FORM&B'1000' # 0 %THEN %PRINTTEXT ' RFM' %C %ELSE %PRINTTEXT ' ' %FINISH %IF N_FORM&B'10000' # 0 %C %OR (N_FORM&2 # 0 = N_FORM&B'1100') %C %THEN %PRINTTEXT 'NAME' %ELSE %PRINTTEXT ' ' %IF SHORT FORM # 0 %START WRITE(N_ADDRESS&X'FFF',4) %PRINTTEXT '(' WRITE(N_ADDRESS>>12&15,2) %PRINTTEXT ')' %PRINTTEXT ' D=' WRITE(N_DIMENSION,2) %PRINTTEXT ' L=' WRITE(N_LENGTH,2) %PRINTTEXT ' X=' HEX(N_INDEX) %PRINTTEXT ' TL=' WRITE(N_LEVEL,1) %PRINTTEXT ' F=' WRITE(N_FLAGS,1) %FINISH %END !****************************************************** ! %ROUTINE I8DIAG(%INTEGER EP) %SHORTROUTINE ! THIS ROUTINE CALLS S#I8DIAG FOR A MONITOR FOLLOWING A SIGNAL. ! THE CONTEXT OF THE ERROR MUST BE RESET ! TO ALLOW THE STACK TO BE UNWOUND BY THE MONITOR ! THE RETURN ADDRESS IS CORRUPTED TO BRING THE MONITOR BACK ! TO 'INT RETURN' TO RESET THE SIGNAL. %OWNINTEGER R12, R13, R14 %INTEGER FLAG RUNNING = 'N' %IF R12 = 0 %START; ! FIRST CALL TO LOAD S#I8DIAG FDP(LOAD FDP,'S#I8DIAG',FDP REF,ADDR(R12),FLAG) %IF FLAG # 0 %START %PRINTTEXT '*** cannot load I8DIAGS' WRITE(FLAG,1); %PRINTTEXT ' *** ' R12 = 0 %FINISH %RETURN %FINISH *L_1,SIGAREA; ! OLD REG SAVE AREA *L_11,52(1); ! OLD REG 11 *MVC_16(44,11),24(1); ! SET SAVE AREA TO ERROR REGS *MVC_64(4,11),EP; ! PLUG IN PARAMETER *L_1,STACKTOP; ! SAVE AREA IF RETURNS FROM PDIAG *L_15,MON LABEL; ! TO RESET SIGNAL *ST_15,60(8); ! CHANGE RETURN ADDRESS *MVC_16(48,1),16(8); ! DUPLICATE THEM ON CODE'S STACK *ST_8,16(11); ! REG4 TO RETURN OLD REG 8 *LM_12,14,R12; ! ENTRY INFO FOR S#I8DIAG *BALR_15,14; ! CALL IT *LR_8,4; ! RESTORE BASE REGISTER %END %ROUTINE C SWITCH %SHORTROUTINE %INTEGER J, K, L, M, N, MARK, RSAVE, LOWER, UPPER FAULT(32) %AND -> 1 %IF LEVEL = 1 EXTRINSIC = 0 N = FORWARD REF(15); ! JUMP ROUND SWITCH TABLE NEWNAME = 0 NEWNAME_TYPE = B'1000000' NEWNAME_LEVEL = LEVEL SW1: NEWNAME_ADDRESS = CODEIN-R10 RP = RP+1; MARK = REC(RP);! NUMBER OF NAMES RSAVE = RP; RP = MARK+RP; ! TO CBPAIR CBPAIR(LOWER,UPPER) J = RP; RP = RSAVE; M = (UPPER-LOWER+1)<<1 L = M+4; ! LENGTH OF HEADER+VECTOR DIAG FLAG = 0; C NAME LIST(MARK,L) %CYCLE K = 1,1,MARK SHORTINTEGER(CODEIN) <- LOWER SHORTINTEGER(CODEIN+2) <- UPPER L = CODEIN+4 CODEIN = L+M %CYCLE L = L,2,CODEIN SHORTINTEGER(L) = 0 %REPEAT %REPEAT RP = J+1 -> SW1 %IF REC(RP) = 1; ! REST OF SW LIST REMOVE LABEL(N) 1: %END %ROUTINE SW REF %SHORTROUTINE %INTEGER N, M, J %RECORD V(VARFM) %BYTEINTEGER B N = REC(RP+1); ! NAME RP = RP+2 %IF REC(RP) = 1 %START; ! PARMS B <- REC(RP+1); ! PLUS' RP = RP+2; ! SKIP TYPE GET4(M); ! INTEGER %IF B = 2 %THEN M = -M %ELSE %START %IF B = 3 %THEN M = \M %FINISH FAULT2(4,N) %AND -> 1 %IF INTEGER(N+DICTHEAD+4) = 0 GETINFO(N,V) %IF V_TYPE # B'1000000' %THEN FAULT2(3,N) %ELSE %START J = V_ADDRESS+R10; ! ADDR OF VECTOR %UNLESS SHORTINTEGER(J) <= M <= SHORTINTEGER(J+2 %C ) %THEN FAULT2(5,N) %ELSE %START J = (M-SHORTINTEGER(J))<<1+J %IF SHORTINTEGER(J+4) = 0 %C %THEN SHORTINTEGER(J+4) <- CODEIN-R10 %C %ELSE FAULT2(6,N) %FINISH %FINISH %FINISH %ELSE %START %IF LEVEL = 1 %THEN FAULT(32) %ELSE LABEL FOUND(N) %FINISH 1: %END %ROUTINE CREATE DUMMY REFS(%INTEGER LIST) %SHORTROUTINE %INTEGER K COMREG(7) = 0; ! DESTROY LIST %UNTIL LIST = 0 %CYCLE K = INTEGER(LIST+4) INTEGER(K) = K INTEGER(K+4) = D LOAD ENV INTEGER(K+8) = MISSING EP LIST = INTEGER(LIST) %REPEAT %END %ROUTINE INT DUMP %EXTERNALSTRING (8) DUMP FILE = '.LP' %DYNAMICROUTINESPEC SETMARGINS(%INTEGER J, K, L) %DYNAMICROUTINESPEC LPDUMP(%INTEGER J, K) %INTEGER J, K %STRING (40) FILE %SHORTROUTINE DEFINE('ST79,'.DUMP FILE) FILE = ' '.DATE.' '.TIME PRINTSTRING('*** DUMP STARTED'.FILE.' *** ') SELECTOUTPUT(79); SET MARGINS(79,1,132) SHORT FORM = 15 NEWPAGE %PRINTTEXT ' IMP INTERPRETER VERSION 8A *** DUMP ***' PRINTSTRING(FILE) NEWLINES(3) %PRINTTEXT 'GLA === ' LPDUMP(GLA HEAD,GLA+16) NEWPAGE %PRINTTEXT 'CODE ==== ' LPDUMP(CODE,CODEIN+300) NEWPAGE %PRINTTEXT 'STATIC STACK ============ ' LPDUMP(STACK,ASPACE+60) NEWPAGE %PRINTTEXT 'NAMES ===== ' %CYCLE J = DICT HEAD,8,DICTHEAD+4088 %IF INTEGER(J) # 0 %START HEX(J-DICTHEAD); SPACES(4) FILE <- STRING(INTEGER(J)); PRINTSTRING(FILE) SPACES(44-LENGTH(FILE)); HEX(INTEGER(J+4)) NEWLINE %FINISH %REPEAT NEWLINES(5); SPECIAL(6) NEWPAGE %PRINTTEXT 'LISTS ===== ' J = 1 J = J+1 %WHILE ADDR(LISTS(J))&15 # 0 %CYCLE K = J,4,LIST SIZE-4+J J = K %AND %EXIT %IF LISTS(K+7) # ADDR(LISTS(K)) %REPEAT LPDUMP(ADDR(LISTS(J)),ADDR(LISTS(LIST SIZE))) NEWPAGE %PRINTTEXT 'ENTRY LIST ========== ' %CYCLE J = 0,1,127; NEWLINE %IF J&7 = 0 WRITE(J,5) K = R ENTRY(J) %IF K = 255 %THEN %PRINTTEXT ' -*-' %ELSE WRITE(K,3) %REPEAT NEWLINES(5); SPECIAL(8) NEWPAGE %PRINTTEXT ' LOCALS ====== ' *ST_9,J; LPDUMP(J,J+2280) NEWPAGE SPECIAL(25); ! DUMP LAST SIGNAL *ST_11,J %IF SIGAREA # 0 %START K = INTEGER(SIGAREA+52);! FAILING R11 J = K %IF J > K %PRINTTEXT ' DYNAMIC STACK ============= ' LPDUMP(J,K) %FINISH NEWPAGE %PRINTTEXT ' INTERPRETER GLA =============== ' *ST_13,J LPDUMP(J,J+4095) %END %INTEGERFN MCODE(%INTEGER S) %SHORTROUTINE %CONSTSHORTINTEGERARRAY EP(0 : 14) = 0, 18, 64, 66, 69, 71, 83, 85, 92, 94, 106, 108, 116, 118, 120 %INTEGER P, L L = 0 %CYCLE P = 1,1,4 %EXIT %UNLESS 'A' <= LINE(SYM) <= 'Z' L = L<<8!LINE(SYM) SYM = SYM+1 %REPEAT %RESULT = 0 %IF L = 0 %OR LINE(SYM) # '_' SYM = SYM+1 %IF S = 0 %START; ! RR %IF BYTEINTEGER(ADDR(L)+3) = 'R' %START L = L>>8 %CYCLE P = 2,1,48 -> RR %IF L = NEM(P) %REPEAT %RESULT = 0 %FINISH %CYCLE P = 0,1,2 -> RR %IF L = NEM(P) %REPEAT %RESULT = 0 RR: REC(RP) = OPC(P)&63 RP = RP+1 %RESULT = 1 %FINISH %CYCLE P = EP(S),1,EP(S+1) %IF L = NEM(P) %START REC(RP) = OPC(P) RP = RP+1 %RESULT = 1 %FINISH %REPEAT %RESULT = 0 %END %ROUTINE CNOP(%INTEGER A, B) FAULT(33) %AND %RETURN %C %IF B&1 # 0 %OR (A&B = 0 %AND A # 0) B = B-1 SPLANT(X'0700') %WHILE CODEIN&B # A %END %ROUTINE CUCI %SHORTROUTINE %INTEGER J, K, N %INTEGERNAME LAB REF %INTEGER CODE, OPCODE %RECORD V(VARFM) %SWITCH MC(1 : 12) %INTEGER REG, INDEX, LENGTH, BASE, DISP %INTEGERFNSPEC GET(%INTEGER LIMIT) %ROUTINESPEC DXB %ROUTINESPEC DLB %ROUTINESPEC DB %ROUTINESPEC CUCS LAB REF == N; ! DUMMY VALUE RP = RP+1; CODE = REC(RP) RP = RP+1; OPCODE = REC(RP) ! -> MC(CODE) ! MC(1): ! [INTEGER]','[INTEGER] ! %IF OPCODE = 0 %THEN CNOP(GET(4096),GET(4096)) %C %ELSE DRR(OPCODE,GET(15),GET(15)) %RETURN ! MC(2): ! [INTEGER]','(DXB) MC(3): ! [INTEGER]','[INTEGER]','(DB) MC(5): ! [INTEGER]','(DB) ! REG = GET(15) %IF CODE = 2 %THEN DXB %ELSE %START %IF CODE = 5 %THEN INDEX = 0 %ELSE INDEX = GET(15) DB %FINISH DRX(OPCODE,REG,INDEX,BASE<<12!DISP) LR: LABREF = CODEIN-8; ! UPDATE LABEL LIST REFERENCE %RETURN ! MC(4): ! (DB)(VAL') ! DB RP = RP+1; %IF REC(RP) = 2 %THEN N = 0 %ELSE N = GET(255) DSI(OPCODE,BASE<<12!DISP,N) -> LR ! MC(6): ! (DLB)','(DB) MC(7): ! (DLB)','(DLB) ! DLB J = BASE<<12!DISP K = LENGTH; K = 1 %IF K = 0 LAB REF = CODEIN+2 %IF CODE = 6 %THEN DB %ELSE %START DLB; LENGTH = 1 %IF LENGTH = 0 K = (K-1)<<4!LENGTH %FINISH DSS(OPCODE,K,J,BASE<<12!DISP) -> LR ! MC(8): ! [INTEGER] ! %IF OPCODE = X'80' %THEN DSI(OPCODE,GET(255),0) %C %ELSE %START %IF OPCODE = 10 %THEN SPLANT(X'0A00'!GET(255)) %C %ELSE DRR(OPCODE,GET(15),0) %FINISH %RETURN ! ! MC(9):!*PUT_ ! SPLANT(REC(RP+2)); ! BOTTOM SHORT ONLY %RETURN ! MC(10):!**,(@')(VAR) ! RP = RP-1; ! BACK FROM 'OPCODE' REG = GET(15) RP = RP+1; J = REC(RP); ! ADDR OR NOT VAR(V) %IF J = 1 %THEN %START V_TYPE = 4 %AND V_FORM = V_FORM!2 %C %IF V_TYPE = 16 %AND V_FLAGS&4 # 0 V_TYPE = 4 %IF V_TYPE = 7; ! RECORDS LOAD ADDR(V,REG) %FINISH %ELSE %START %IF V_TYPE&B'1000' # 0 %START; ! REAL FAULT(44) %UNLESS REG&1 = 0 %AND REG <= 6 REG = REG>>1 %FINISH LOAD(V,REG) %FINISH RELEASE REGISTER(REG) %RETURN %INTEGERFN GET(%INTEGER LIMIT) %INTEGER N RP = RP+1; ! SKIP TYPE GET4(N) FAULT(33) %UNLESS 0 <= N <= LIMIT %RESULT = N %END %ROUTINE DXB %INTEGER NUM INDEX = 0 RP = RP+1 %IF REC(RP) = 1 %START CUCS RP = RP+1; %IF REC(RP) = 1 %THEN INDEX = GET(15) %FINISH %ELSE %START DISP = GET(4095); BASE = 0 RP = RP+1; NUM = REC(RP) %IF NUM = 1 %THEN INDEX = GET(15) %IF NUM <= 2 %THEN BASE = GET(15) %FINISH FAULT(99) %IF DISP > 4095 %END %ROUTINE DLB RP = RP+1 %IF REC(RP) = 1 %START DISP = GET(4095) LENGTH = GET(255) BASE = GET(15) %FINISH %ELSE %START CUCS; LENGTH = GET(255) %FINISH FAULT(99) %IF DISP > 4095 %END %ROUTINE DB RP = RP+1 %IF REC(RP) = 1 %THEN CUCS %ELSE %START DISP = GET(4095) RP = RP+1 %IF REC(RP) = 2 %THEN BASE = 0 %ELSE BASE = GET(15) %FINISH FAULT(99) %IF BASE > 4095 %END %ROUTINE CUCS %RECORD V(VARFM) %INTEGER X, ALT, LABEL RP = RP+1; ALT = REC(RP) %IF ALT = 2 %START; ! LABEL ???? BASE = 10; DISP = 0 RP = RP+1; LABEL = REC(RP) %IF LABEL = 1 %START RP = RP+1; GET4(LABEL) FAULT(44) %AND %RETURN %IF LABEL>>16 # 0 LABEL = \LABEL %FINISH %ELSE %START RP = RP+1; LABEL = REC(RP) RP = RP+1 FAULT2(33,LABEL) %AND SKIPEXPRN %IF REC(RP) # 2 %FINISH JUMP TO(LABEL,0) CODEIN = CODEIN-8 DISP = SHORTINTEGER(CODEIN+6) %IF SHORTINTEGER(CODEIN) # X'41DD' %C %THEN CODEIN = CODEIN+4 %C %ELSE LAB REF == INTEGER(LAST ASL) FAULT(99) %IF DISP>>12&15 # 0 %FINISH %ELSE %START RP = RP+1; VNAME = REC(RP) GET INFO(VNAME,V) FAULT2(33,VNAME) %C %IF 64 # V_TYPE >= 31 %OR V_FORM&8 # 0 DISP = V_ADDRESS BASE = DISP>>12&15 DISP = DISP&X'0FFF' RP = RP+1; ALT = REC(RP) %IF ALT # 3 %START X = GET(4095) %IF ALT = 1 %THEN DISP = DISP+X %C %ELSE DISP = DISP-X %FINISH %FINISH %END %END %ENDOFPROGRAM @@@@@@@@@@@@@@@ * * ********************************************************************** * * * * * PERM FOR IMP INTERPRETER VERSION 8 * * * * * ********************************************************************** * * * * PERM CONVENTIONS * GPR 0 : 3 ARE ALWAYS AVAILABLE FOR WORK REGISTERS * ALL OTHERS MUST BE SAVED AND RESTORED * * ALL PERM ROUTINES ARE ENTERED BY '*BAL_15,PERM00' * EXCEPT WHERE OTHERWISE STATED * * IMP START WSP EQU 11 GLA EQU 13 SWK EQU 14 RA EQU 15 * HEADER FOR INTPERMY DC A(PEND-IMP) LENGTH OF FILE DC F'16' LENGTH OF HEADER DC A(PERMGLA-IMP) RELETIVE START OF GLAP DC A(LOADDATA-IMP) RELATIVE START OF LOAD DATA USING USERGLA,GLA GLA BASE REGISTER USING *,12 PERM BASE REGISTER EJECT * ENTRY BRANCH TABLE P0 B STOPSEQ %STOP P1 B ABC10 SINGLE DIM ARRAY REF P2 B ABC20 MULTI-DIMENSION ARRAY REFERENCE P3 B UAV0 UNASSIGNED VARIABLE TRAP P4 B CPE CAPACITY EXCEEDED TRAP P5 B MSTOP MONITORSTOP P6 B FTRAP FAULT TRAP TEST (NOT IN YET) P7 B MON0 MONITOR P8 B SW0 SWITCH TEST + JUMP P9 B RESFLOP RESOLUTION FAILS TRAP P10 B TVC1 INVALID CYCLE TEST P11 B EXP0 INTEGER EXPONENTIATION P12 B REXP1 REAL EXPONENTIATION P13 B NIQ NON-INTEGER QUOTIENT TRAP P14 B CONCAT CONCATENATION P15 B RESE1 RESOLUTION (FIRST ENTRY) P16 B RESE2 RESOLUTION (SUBSEQUENT ENTRIES) P17 B SETUAV ROUTINE TO SET ARRAYS UNASSIGNED P18 B ADEC ARRAY DECLARATION P19 B SWCOMP STRING COMPARISON P20 B PTXT P21 B RSNS P22 B EXB P23 B CIOCP P24 B RTEXB P25 B RTFALTY P26 B RELOCATE P27 B ASPACE1 P28 B ASPACE2 P29 B CDVF P30 B BULKMOVE P31 B RTNDSC P32 B ZEROREC P33 B RTMON EJECT ORG P0+192 SNL DC X'010A' ORG P0+200 LABELS DC X'00000000' DC X'00001000' DC X'00002000' DC X'00003000' DC X'00004000' DC X'00005000' DC X'00006000' DC X'00007000' DC X'00008000' DC X'00009000' DC X'0000A000' DC X'0000B000' DC X'0000C000' DC X'0000D000' DC X'0000E000' DC X'0000F000' EJECT FTRAP LA 15,STOPSEQ B FTRAP1 MSTOP LA 15,STOPSEQ MON0 SLR 0,0 FTRAP1 STM 4,1,16(WSP) USING PERMGLA,14 L 14,PERMINF+4 @ PERM GLA LM 12,14,MONAD DROP 14 BR 14 * * IOCP ENTRY SEQUENCE: REGISTERS ALREADY SAVED * CIOCP EQU * USING PERMGLA,14 L 14,PERMINF+4 @ PERM GLA LM 12,14,IOAD DROP 14 BR 14 * * * * EJECT EXBR SR 11,14 RESTORE R11 B EXB * * * ENTERED BY '*BAL_10,RTEXB' RTEXB C 11,STACKEND BC 2,EXB FAULT EXCESS BLOCKS BR 10 RETURN * EXB LA 0,4 B FTRAP RTNDSC LA 0,8 B FTRAP * * EJECT * * TESTS FOR A VALID SWITCH LABEL AND JUMPS TO IT * R1 = EXPRN, UNALTERED SO AS TO BE PRINTABLE IF SWITCH * LABEL NOT SET * R2 = @SWITCH VECTOR * SW0 CH 1,0(2) BL SLNS CH 1,2(2) BH SLNS LR 3,1 SAVE INDEX FOR LABEL NOT SET SH 3,0(2) SUBTRACT LOWER BOUND AR 3,3 GET DISPLACEMENT LH 3,4(3,2) LOAD ADDR OF LABEL LTR 3,3 ZERO => NOT SET BC 7,0(3,10) JUMP THERE IF NON-ZERO SLNS LA 0,7 SWITCH LABEL NOT SET B FTRAP EJECT * SINGLE DIMENSIONAL ARRAY REFERENCE * R1 = SUBSCRIPT * R2 = @ HEADER * ADDRESS RETURNED IN R1 ABC10 L 3,8(2) @DOPE VECTOR CLI 1(3),1 CORRECT DIMENSION ? BNE CDV1 NO => CORRUPT DOPE-VECTOR C 1,4(3) CF LOWER BOUND BL ABE FAULT IF LOW C 1,8(3) UPPER BOUND BH ABE FAULT IF HIGH MH 1,2(3) ADJUST INDEX FOR TYPE A 1,0(2) ADD IN @A(0) BR 15 RETURN ABE LA 0,32 ARRAY BOUNDS EXCEEDED B FTRAP * * MULTI-DIMENSIONAL ARRAYS * RETURNS WITH ADDRESS IN R1 * ABC20 ST 4,GRA SAVE R4 L 4,8(2) @ DOPE-VECTOR LH 3,0(4) DIMENSION BCT 3,ABC21 DIM-1 B CDV2 CORRUPT DOPE-VECTOR ABC21 LR 14,1 @ LAST SUBSCRIPT MH 3,=H'12' AR 3,4 SKIP PAST LEADING ELEMENTS OF DOPE-V SR 0,0 ABC22 L 1,0(14) GET SUBSCRIPT C 1,4(3) COMPARE WITH LOWER BOUND BL ABE FAULT IF LOW C 1,8(3) COMPARE WITH UPPER BOUND BH ABE FAULT IF HIGH AR 1,0 ADD IN TO ADDR COUNT MH 1,2(3) *MULTIPLIER CR 3,4 BE ABC23 LAST ONE DONE LR 0,1 RESET ADDR COUNT SH 14,=H'4' MOVE BACK FOR NEXT SUBSCRIPT SH 3,=H'12' BACK ALONG DOPE-VECTOR B ABC22 AROUND AGAIN ABC23 A 1,0(2) ADD IN @A(0,0) L 4,GRA RESTORE R4 BR 15 EJECT * * EXPONENTIATION ROUTINES. * OPERAND IN R1 * EXPONENT IN R2 * RESULT IN R1 * EXP0 LTR 3,2 BZ EXPZERO SRA 2,6 BC 7,EXPFAIL LR 2,1 B EXP3 EXP2 MR 0,2 SLDA 0,32 PROVOKE OVERFLOW LR 1,0 EXP3 BCT 3,EXP2 BR 15 EXPZERO LA 1,1 X**0=1 BR 15 EXPFAIL LA 0,21 ILLEGAL EXPONENT LR 1,3 B FTRAP * *** EXPONENT IN REAL EXPRN **** * * OPERAND IN FPR2 * EXPONENT IN R2 * RESULT IN FPR2 * REXP1 ST 2,GRA LPR 3,2 BZ ZREXP CH 3,=H'255' IN RANGE ? BH EXPFAIL TOO BIG LDR 0,2 B REXP3 REXP2 MDR 2,0 REXP3 BCT 3,REXP2 CLI GRA,0 TEST FOR ZERO SIGN BC 8,REXP4 EXPONENT POSITIVE LDR 0,2 LD 2,=D'1.0' DDR 2,0 REXP4 BR 15 ZREXP LD 2,=D'1.0' BR 15 EJECT * * TEST CYCLE J=P,Q,R * P IN R1. R2 POINTS TO Q,R * TVC1 LM 2,3,0(2) PICK UP Q,R LTR 0,2 TEST INCREMENT BZ IVC FAULT IF ZERO SR 3,1 (R-P) LR 2,3 SRDA 2,32 PROPAGATE SIGN FOR DIVISION DR 2,0 R3=(R-P)/Q LTR 2,2 BC 7,IVC NON-INTEGRAL LTR 3,3 P STILL IN R1 TO STORE IN 0(4) BCR 10,15 RETURN IF R3>=0 * * * VARIOUS ERROR ROUTINES * * IVC LA 0,3 B FTRAP CPE LA 0,30 CAPACITY EXCEEDED B FTRAP CDVF LH 1,0(15) B CDV CDV1 LH 1,0(3) B CDV CDV2 LA 1,1 CDV LA 0,33 CORRUPT DOPE-VECTOR B FTRAP UAV0 LA 0,31 UNASSIGNED VARIABLE B FTRAP RESFLOP LA 0,26 RESOLUTION FAILS B FTRAP RSNS LA 0,11 %RESULT NOT SPECIFIED B FTRAP NIQ LA 0,10 NON-INTEGER QUOTIENT B FTRAP RTFALTY LA 0,15 ROUTINE FAULTY B FTRAP EJECT * * CONCATENATES THE STRING AT R1 ONTO THE STACK AT R14 * FIRST CALL PRECEEDED BY *MVI_0(SWK),0 * CONCAT SLR 2,2 IC 2,0(SWK) PRESENT LENGTH OF STRING LR 0,2 SAVE IT AR 2,SWK NEW BASE FOR CONCAT SLR 3,3 IC 3,0(1) LENGTH OF NEXT STRING AR 0,3 NEW TOTAL LENGTH STC 0,0(SWK) SET NEW LENGTH CL 0,=F'255' >255 ? BH CPE YES EX 3,PMOVE1 BCR 15,15 RETURN PMOVE1 MVC 1(0,2),1(1) * * * SWCOMP EQU * SUBROUTINE TO COMPARE STRINGS AT R1 & R2 SR 3,3 IC 3,0(2) STRCEX CLC 0(1,1),0(2) BALR 0,0 SAVE CC BH STRCMP2 BL STRCMP3 EX 3,STRCEX BR RA STRCMP3 IC 3,0(1) STRCMP2 LTR 3,3 BC 8,STRCMP4 BCTR 3,0 EX 3,SCOMPL BCR 7,RA STRCMP4 SPM 0 BR RA SCOMPL CLC 1(1,1),1(2) * * * PTXT EQU * PRINTTEXT RA POINTS TO TEXT LR 1,RA SLR 2,2 IC 2,0(1) LA RA,2(2,RA) N RA,=F'-2' LA 0,11 ENTRY POINT FOR S#I8IOCP STM 4,1,16(14) SAFE HERE I HOPE !!! LR 11,14 ADJUST STACK POINTER B CIOCP CALL IOCP * EJECT * * STRING RESOLUTION * * S -> A . ( B ) . C . ( D ) . E * * ON ENTRY R0 = @ A * R1 = @ B * R4 = * R14 = @ S * * FOR THE SECOND AND SUBSEQUENT RESOLUTIONS, R4 = REMAINING * LENGTH OF S. * * * RESE1 SLR 4,4 N 14,=X'00FFFFFF' REMOVE LENGTH !!!! IC 4,0(14) LENGTH OF 'S' RESE2 ST 15,GRA SR 2,2 IC 2,0(1) LENGTH OF 'B' LCR 15,2 SETS CC ! BZ FOUND ->FOUND %IF B='' AR 15,4 MAXIMUM NUMBER OF TESTS LA 15,1(15) BM FAIL LR 3,14 BCTR 2,0 LTR 0,0 BZ NULLRES 'A' OMITTED RLOOP EX 2,COMP1 COMPARE BE FOUND LA 3,1(3) MOVE ALONG TO NEXT BYTE BCT 15,RLOOP FAIL L 15,GRA NR 11,11 RESOLUTION FAILS: CC=7 BCR 15,15 %RETURN * NULLRES EX 2,COMP1 ONLY DO FIRST COMPARE BNE FAIL LA 2,1(2) AR 14,2 SR 4,2 B YES FOUND LR 1,0 LA 2,0(2,3) SR 3,14 C 3,STRLEN BH CPE EX 3,MOVE1 STC 3,0(1) SR 14,2 AR 4,14 BCTR 4,0 LA 14,1(2) YES L 15,GRA CR 11,11 SUCCESS: CC=8 BCR 15,15 %RETURN MOVE1 MVC 0(0,1),0(14) COMP1 CLC 1(0,3),1(1) EJECT DV EQU 2 ADEC EQU * * ARRAY DECLARATION * * R2 POINTS TO DOPE-VECTOR * * RETURNS WITH :- * * R0 = @A(0) * R1 = @A(1) * R2 = @ DV * R3 = ????? * * ST RA,GRA STM 4,6,DECSAVE SAVE WORK REGISTERS LH 14,2(DV) ITEM LENGTH LH 3,0(DV) DIMENSION LR 6,3 BCTR 6,0 MH 6,=H'12' LA 6,4(6,DV) LA 11,15(6,0) N 11,=F'-8' SR 5,5 DECLOOP L 1,4(6,0) UPPER BOUND S 1,0(6,0) LOWER BOUND LTR 1,1 BC 11,BOK LA 0,28 ARRAY INSIDE-OUT B FTRAP BOK LA 1,1(1,0) ST 1,8(6,0) MULTIPLIER MR 4,1 A 5,0(6,0) MR 0,14 LR 14,1 S 6,=F'12' BCT 3,DECLOOP MH 5,2(DV) LCR 0,5 AR 0,11 @A(0) LR 1,11 @A(1) LA 14,7(14,0) N 14,=F'-8' TO DOUBLE WORD BOUNDARY LM 4,6,DECSAVE BR 15 * EJECT * * RELMOVE MVC 0(0,2),0(11) * * THIS ROUTINE RELOCATES THE DOPE-VECTOR OF AN ARRAY AT LEVEL 1 * * RELOCATE LR 3,11 SR 3,2 LENGTH OF D-V LR 11,2 BACK TO OLD VALUE L 2,STACKEND N 2,=F'-8' SR 2,3 @ NEW D-V EX 3,RELMOVE ST 2,STACKEND UPDATE STACK POINTER BR 15 * * ASPACE1 EQU * * * THIS ROUTINE ALLOCATES THE SPACE FOR AN ARRAY AT LEVEL 1 * SR 0,1 L 1,ARRAYPT LA 1,7(0,1) N 1,=F'-8' DOUBLE WORD BOUNDARY AR 0,1 LA 4,0(14,1) C 4,ARRAYMAX BNL EXB ST 4,ARRAYPT B SETUAV * ASPACE2 EQU * * * THIS ROUTINE ALLOCATES THE SPACE FOR AN ARRAY AT LEVEL > 1 * SR 0,1 LR 1,11 AR 0,11 AR 11,14 C 11,STACKEND BNL EXBR AND RESTORE R11 * * SETUAV EQU * * * ROUTINE TO SET ARRAY SPACE UNASSIGNED * LD 0,UAVPAT LR 3,1 LR 4,14 AR 4,3 MOREUAV STD 0,0(3) LA 3,8(3) CR 3,4 BL MOREUAV BR 15 * EJECT * * BULK MOVE FOR RECORDS * * R2 = @ LHS * R1 = @ RHS * R0 = LENGTH * BULKMOVE C 0,=F'256' BNH BM1 MVC 0(256,2),0(1) LA 1,256(1) LA 2,256(2) S 0,=F'256' B BULKMOVE BM1 LTR 3,0 BCR 8,15 BCTR 3,0 EX 3,BM0 BCR 15,15 BM0 MVC 0(0,2),0(1) * * * ROUTINE TO CLEAR A RECORD * R0 = LENGTH * R2 = @RECORD * ZEROREC C 0,=F'256' BL C1 XC 0(255,2),0(2) S 0,=F'256' LA 2,256(2) B ZEROREC C1 LTR 1,0 BCR 8,15 BCTR 1,0 EX 1,C2 BCR 15,15 C2 XC 0(0,2),0(2) * * STOP SEQUENCE: DIRECT BACK TO INTERPRETER EJECT * * ROUTINE MONITORING * * R0 = ROUTINE INDEX * R14= @ ROUTINE EP * R15= RA * * 12(9) = FREE @ OF II#DUMP * RTMON CLI 11(9),128 BE RTMON1 LM 12,14,0(14) BCR 15,14 RTMON1 L 1,12(9) LD 0,SVCP1 LD 2,SVCP2 SVC 254 STD 2,64(1) STD 6,72(1) MVC 0(4,1),68(1) MOVE IN CPU MVC 4(4,1),76(1) MOVE IN PAGE FAULTS OI 0(1),128 SHOW ENTERING STC 0,4(1) REMEMBER ROUTINE INDEX LA 1,8(1) ONTO FREE SPACE ST 1,12(9) LR 1,11 STM 15,1,8(11) LM 12,14,0(14) BALR 15,14 * * RETURNS TO HERE * MUST PRESERVE GPR1 & FPR2 * L 2,12(9) STD 2,16(2) LM 15,0,8(4) LD 0,SVCP1 LD 2,SVCP2 SVC 254 METER STD 2,64(2) STD 6,72(2) LD 2,16(2) MVC 0(4,2),68(2) MOVE IN CPU MVC 4(4,2),76(2) MOVE IN PAGE FAULTS STC 0,4(2) LA 2,8(2) ST 2,12(9) BCR 15,15 * STOPSEQ EQU * LM 4,15,16(9) RESET REGISTERS * R4 -> SYSTEM PROMPT * R5 -> INTERPRETER INPUT PROMPT MVC 0(16,5),0(4) UPDATE INTERPRETER'S PROMPT BCR 15,15 RETURN * * DS 0D UAVPAT DC X'8080808080808080' LTORG DS 0D SVCP1 DC X'00D6000000000000' SVCP2 DC X'0000000000000000' DS 0D * * * EJECT PERMGLA DS 2D STACKLIM DS 2F EXREF1 DS 0D DC A(EXREF2-PERMGLA) IOAD DC 3F'0' DC X'80000000' DC X'0853234938494F4350' 'S#I8IOCP' EXREF2 DS 0D DC F'0' MONAD DC 3F'0' DC X'80000000' DC X'085323493844494147' 'S#I8DIAG' * LOADDATA DS 0D DC F'6' DC A(MAINEP-LOADDATA) DC A(EXREF1-PERMGLA) DC 3F'0' DC A(STACKLIM-PERMGLA) MAINEP DS 0D DC F'0' DC 3F'0' DC X'80000000' DC X'08532349385045524D' 'S#I8PERM' PEND DS 0D * * * USERGLA EQU * FLTFLAG DS F LNGFLAG DC X'10000000' IMP EMARK DC X'E2E2E2E2' TOPLINK DC F'0' MIN1 DC F'-1' BLOCKNO DS H LINENO DS H BMASK DS 0F ZEROBYTE DC 3X'00' ONESBYTE DC X'FF' MONDISP DC F'8' ARRAYPT DS F ARRAYMAX DS F GRA DS F TEMP LOCN FOR RETURN ADDRESSES PERMINF DS 3F STRLEN DS F STACKEND DS F WSPSAVE DS F FMASK DC X'80000000' FCONST DC X'4E000000' STRMVS DC 3F'0' GLAUAV DC X'8080808080808080' STRFNMVC DC X'D20010002000' DECSAVE DS 3F * * * END * @@@@@@@@@@@@@@@ ! !******************************************************************* !* * !* SYSTEM ROUTINES FOR IMP INTERPRETER VERSION 8 * !* * !******************************************************************* ! ! %TRUSTEDPROGRAM %RECORDFORMAT AGFM(%INTEGER EP, %STRING (17) NAME, %C %INTEGER P1, P2, %INTEGERNAME FLAG) %EXTERNALINTEGER INTSIZE = 16; ! DEFAULT OF 16 PAGES %EXTERNALBYTEINTEGER INIMPI = 0 %EXTERNALINTEGER INTGLA = 0 %OWNSTRING (6) INT OWNER = 'CONLIB' %EXTERNALSTRING (8) OBJECT = 'IMPIOBJ' %EXTRINSICBYTEINTEGER INSTREAM, COMPMODE, IOFLAG, MDACTIVE %SYSTEMINTEGERFNSPEC COMREG(%INTEGER N);! TO GIVE ADDRESSES %EXTERNALINTEGER REG9 = -1 %OWNINTEGER DIAGPT, OUTSTREAM, SYSOUT, INTPERM %OWNINTEGER INPUT = 0, ILEN = 0, DICT HEAD, NLADDR, MLEVEL %OWNBYTEINTEGER IMPIUSE = 0, FAST BACK = 0, PRINTED = 0 %OWNINTEGER PCOUNTER = 0 %OWNBYTEINTEGERARRAY INBUF(0 : 160) ! ! %EXTERNALROUTINESPEC EXTINIT %EXTERNALROUTINESPEC HEX(%INTEGER N) %DYNAMICROUTINESPEC RUN(%STRING (63) S) %SYSTEMROUTINESPEC PDIAG(%INTEGER REGS, FAULT, EXTRA) %SYSTEMROUTINESPEC AGENCY(%INTEGER P1, %RECORDNAME P) %EXTERNALSTRING (15) PSTRING = 'DATA:'; ! DEFAULT PROMPT ! %SYSTEMROUTINESPEC RIM(%INTEGER CONSOLE, %STRING (15) PROMPT) %ROUTINE FDP(%INTEGER EP, %STRING (17) NAME, %C %INTEGER P1, P2, %INTEGERNAME FLAG) %RECORD P(AGFM) **1,@P *LA_2,EP *MVC_0(36,1),0(2); ! SHIFT IN PARAMETERS AGENCY(1,P) %END %ROUTINE SIGNAL(%INTEGER J, K, L, %INTEGERNAME FLAG) %RECORD P(AGFM) P_EP = J P_P1 = K P_P2 = L P_FLAG == FLAG AGENCY(2,P) %END %SYSTEMROUTINE I8INIT( %C %INTEGER DICT, NLFLAGAD, DIAG, SO, IO, IGLA, IPERM, %C I8MODE) %INTEGER MON HEX ADDR %IF IMPIUSE = 0 %AND I8MODE = 0 %START %PRINTTEXT 'IMPI FAILS ' %STOP %FINISH EXTINIT; ! SET LANG FLAG TO 55 IN INTEXTS *MVI_4(13),X'55'; ! SPECIAL FOR MDIAG TO SKIP THIS ! ! ! MON HEX ADDR = COMREG(25) BYTEINTEGER(MON HEX ADDR) = BYTEINTEGER(MON HEX ADDR)!128 !ROUTINE DICT HEAD = DICT; NLADDR = NLFLAGAD SYSOUT = SO; OUTSTREAM = IO MLEVEL = IO+4 INTPERM = IPERM; INTGLA = IGLA DIAGPT = DIAG INIMPI = 1 ! OTHER INITIALISATIONS IN HERE %END ! ! %SYSTEMROUTINE I8IOCP(%INTEGER EP, IP1, %LONGREAL RP1, RP2) %SHORTROUTINE %CONSTLONGREAL MAX INTEGER = 2.14748364699999@9 %INTEGER S, L %BYTEINTEGER FLAG, SIGN %LONGREAL DIV, VAL %STRING (255) IOSTR %STRINGNAME SN %SWITCH EPT(1 : 42) -> EPT(EP) %INTEGERFN SYMBOL %BYTEINTEGER S %IF ILEN <= 0 %THEN %START %UNTIL S = NL %THEN %CYCLE READSYMBOL(S) ILEN = ILEN+1; INBUF(ILEN) = S %REPEAT INPUT = 0 %FINISH INPUT = INPUT+1; ILEN = ILEN-1 %RESULT = INBUF(INPUT) %END %ROUTINE BACK INPUT = INPUT-1 ILEN = ILEN+1 %END %ROUTINE MONITOR(%INTEGER EP, EXTRA) *LM_0,1,EP; ! PICK UP PARAMETERS *LM_4,14,16(8); ! CONTEXT OF CALL OF IOCP *BC_15,24(12,0); ! CALL DIAGS FROM PERM %END %LONGREALFN NUMBER %LONGREAL N FLAG = 0 N = 0 %CYCLE %RESULT = N %UNLESS '0' <= S <= '9' FLAG = 1 N = N*10+(S-'0') S = SYMBOL %REPEAT %END EPT(41): ! RESUME -> END EPT(1): ! READ EPT(37): ! R#READ SIGN = 0 S = SYMBOL %UNTIL S # ' ' %AND S # NL SIGN = S %AND S = SYMBOL %IF S = '-' %OR S = '+' %IF S # '.' %START VAL = NUMBER %IF FLAG = 0 %START RFAIL: BACK; ! BACK OVER LAST SYMBOL MONITOR(14,S); ! SYMBOL IN DATA %FINISH %FINISH %IF S = '.' %START DIV = 0.1 S = SYMBOL -> RFAIL %UNLESS '0' <= S <= '9' %CYCLE VAL = VAL+(S-'0')*DIV S = SYMBOL %EXIT %UNLESS '0' <= S <= '9' DIV = DIV/10.0 %REPEAT %FINISH VAL = -VAL %IF SIGN = '-' %IF S = '@' %START S = SYMBOL %UNTIL S # ' ' SIGN = 0 SIGN = S %AND S = SYMBOL %IF S = '-' %OR S = '+' RP1 = NUMBER -> RFAIL %IF FLAG = 0 MONITOR(1,0) %IF RP1 > MAX INTEGER IP1 = INT(RP1) IP1 = -IP1 %IF SIGN = '-' %IF IP1 = -99 %THEN VAL = 0.0 %ELSE VAL = VAL*10**IP1 %FINISH BACK; ! RESTORE FINAL SYMBOL %IF EP = 37 %START; ! R#READ *LD_2,VAL; -> END %FINISH MONITOR(16,0) %UNLESS FRACPT(VAL) = 0.0 %C %AND !VAL! <= MAX INTEGER IP1 = INT(VAL) -> LOADI EPT(40): ! CLOSESTREAM -> END %UNLESS 0 < IP1 <= 99 %IF INSTREAM = IP1 %THEN %START INSTREAM = 0; SELECTINPUT(0) %FINISH %ELSE %START %IF INTEGER(OUTSTREAM) = IP1 %THEN %START INTEGER(OUTSTREAM) = 0 SELECTOUTPUT(0) %FINISH %FINISH CLOSESTREAM(IP1) -> END EPT(38): ! SELECT INPUT INSTREAM = IP1; SELECTINPUT(IP1) EPT(42): ! DRAIN ILEN = 0 -> END EPT(39): ! SELECT OUTPUT INTEGER(OUTSTREAM) = IP1; SELECTOUTPUT(IP1); -> END EPT(2): ! READSYMBOL EPT(3): ! READCH EPT(8): ! SKIPSYMBOL EPT(5): ! READ ITEM S = SYMBOL %IF EP = 5 %THEN STRING(IP1) = TOSTRING(S) %ELSE IP1 = S -> LOADI EPT(4): ! READSTRING SN == STRING(IP1) L = IP1>>24+1; L = 256 %IF L = 1 S = SYMBOL %UNTIL ' ' # S # NL BACK %AND MONITOR(14,S) %UNLESS S = '''' SN = '' STR1: S = SYMBOL %IF S = '''' %THEN %START %IF INBUF(INPUT+1) # '''' %THEN %RETURN INPUT = INPUT+1 %FINISH L = L-1; MONITOR(30,0) %IF L = 0 SN = SN.TOSTRING(S) -> STR1 EPT(6): ! NEXTSYMBOL EPT(7): ! NEXTITEM IP1 = SYMBOL BACK; -> LOADI EPT(11): ! PRINTSTRING PRINTSTRING(STRING(IP1)) -> END EPT(12): ! PRINTSYMBOL PRINTSYMBOL(IP1) -> END EPT(13): ! PRINTCH PRINTCH(IP1); -> END EPT(18): ! SPACES/NEWLINES EP = INTEGER(ADDR(RP1)); -> END %UNLESS EP > 0 %CYCLE EP = 1,1,EP; PRINTSYMBOL(IP1) %REPEAT -> END EPT(20): ! FROM STRING IOSTR = FROM STRING(STRING(IP1),INTEGER(ADDR(RP1)), %C INTEGER(ADDR(RP1)+4)) **1,@IOSTR -> END EPT(21): ! CHARNO IP1 = CHARNO(STRING(IP1),INTEGER(ADDR(RP1))) -> LOADI EPT(22): ! INT IP1 = INT(RP1); -> LOADI EPT(23): ! INTPT IP1 = INTPT(RP1); -> LOADI EPT(24): ! FRACPT RP1 = FRACPT(RP1); -> LOADR EPT(25): ! SIN RP1 = SIN(RP1); -> LOADR EPT(26): ! COS RP1 = COS(RP1); -> LOADR EPT(27): ! TAN RP1 = TAN(RP1); -> LOADR EPT(28): ! ARCSIN RP1 = ARCSIN(RP1); -> LOADR EPT(29): ! ARCCOS RP1 = ARCCOS(RP1); -> LOADR EPT(30): ! ARCTAN RP1 = ARCTAN(RP1,RP2); -> LOADR EPT(32): ! SQRT RP1 = SQRT(RP1); -> LOADR EPT(33): ! MOD *LD_2,RP1; *LPDR_2,2; -> END EPT(34): ! LOG RP1 = LOG(RP1); -> LOADR EPT(35): ! EXP RP1 = EXP(RP1); -> LOADR EPT(31): ! RADIUS RP1 = RADIUS(RP1,RP2); -> LOADR EPT(36): ! PROMPT PSTRING <- STRING(IP1); RIM(0,PSTRING); -> END EPT(19): ! WRITE WRITE(IP1,INTEGER(ADDR(RP1))); -> END EPT(9): ! PRINT PRINT(RP2,IP1,INTEGER(ADDR(RP1))); -> END EPT(10): ! PRINTFL PRINTFL(RP2,IP1) LOADR: *LD_2,RP1 LOADI: *L_1,IP1 END: %END %ROUTINE PRINT MESSAGE(%INTEGER EP, FNUM) %SHORTROUTINE %CONSTBYTEINTEGERARRAY FSYM(0 : 681) = %C 0, '', '', '', ' ', 'M', 'O', 'N', 'I', 'T', 'O', 'R', ' ', '', '', '', 16, 'I', 'N', 'T', 'E', 'G', 'E', 'R', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W', 13, 'R', 'E', 'A', 'L', ' ', 'O', 'V', 'E', 'R', 'F', 'L', 'O', 'W', 13, 'I', 'N', 'V', 'A', 'L', 'I', 'D', ' ', 'C', 'Y', 'C', 'L', 'E', 13, 'E', 'X', 'C', 'E', 'S', 'S', ' ', 'B', 'L', 'O', 'C', 'K', 'S', 13, 'S', 'Q', 'R', 'T', ' ', 'N', 'E', 'G', 'A', 'T', 'I', 'V', 'E', 12, 'L', 'O', 'G', ' ', 'N', 'E', 'G', 'A', 'T', 'I', 'V', 'E', 23, 'S', 'W', 'I', 'T', 'C', 'H', ' ', 'V', 'A', 'R', 'I', 'A', 'B', 'L', 'E', ' ', 'N', 'O', 'T', ' ', 'S', 'E', 'T', 21, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'S', 'C', 'R', 'I', 'B', 'E', 'D', 16, 'I', 'N', 'P', 'U', 'T', ' ', 'F', 'I', 'L', 'E', ' ', 'E', 'N', 'D', 'E', 'D', 20, 'N', 'O', 'N', '-', 'I', 'N', 'T', 'E', 'G', 'E', 'R', ' ', 'Q', 'U', 'O', 'T', 'I', 'E', 'N', 'T', 20, 'R', 'E', 'S', 'U', 'L', 'T', ' ', 'N', 'O', 'T', ' ', 'S', 'P', 'E', 'C', 'I', 'F', 'I', 'E', 'D', 13, 'T', 'I', 'M', 'E', ' ', 'E', 'X', 'C', 'E', 'E', 'D', 'E', 'D', 20, 'O', 'P', 'E', 'R', 'A', 'T', 'O', 'R', ' ', 'T', 'E', 'R', 'M', 'I', 'N', 'A', 'T', 'I', 'O', 'N', 14, 'S', 'Y', 'M', 'B', 'O', 'L', ' ', 'I', 'N', ' ', 'D', 'A', 'T', 'A', 14, 'R', 'O', 'U', 'T', 'I', 'N', 'E', ' ', 'F', 'A', 'U', 'L', 'T', 'Y', 31, 'R', 'E', 'A', 'L', ' ', 'I', 'N', 'S', 'T', 'E', 'A', 'D', ' ', 'O', 'F', ' ', 'I', 'N', 'T', 'E', 'G', 'E', 'R', ' ', 'I', 'N', ' ', 'D', 'A', 'T', 'A', 12, 'D', 'I', 'V', 'I', 'D', 'E', ' ', 'E', 'R', 'R', 'O', 'R', 23, 'S', 'U', 'B', 'S', 'T', 'I', 'T', 'U', 'T', 'E', ' ', 'C', 'H', 'A', 'R', ' ', 'I', 'N', ' ', 'D', 'A', 'T', 'A', 19, 'G', 'R', 'A', 'P', 'H', ' ', 'P', 'L', 'O', 'T', 'T', 'E', 'R', ' ', 'F', 'A', 'U', 'L', 'T', 18, 'S', 'T', 'R', 'E', 'A', 'M', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'F', 'I', 'N', 'E', 'D', 128, 16, 'I', 'L', 'L', 'E', 'G', 'A', 'L', ' ', 'E', 'X', 'P', 'O', 'N', 'E', 'N', 'T', 18, 'T', 'R', 'I', 'G', ' ', 'F', 'N', ' ', 'I', 'N', 'A', 'C', 'C', 'U', 'R', 'A', 'T', 'E', 13, 'T', 'A', 'N', ' ', 'T', 'O', 'O', ' ', 'L', 'A', 'R', 'G', 'E', 13, 'E', 'X', 'P', ' ', 'T', 'O', 'O', ' ', 'L', 'A', 'R', 'G', 'E', 16, 'L', 'I', 'B', 'R', 'A', 'R', 'Y', ' ', 'F', 'N', ' ', 'F', 'A', 'U', 'L', 'T', 16, 'R', 'E', 'S', 'O', 'L', 'U', 'T', 'I', 'O', 'N', ' ', 'F', 'A', 'I', 'L', 'S', 19, 'I', 'N', 'T', '/', 'I', 'N', 'T', 'P', 'T', ' ', 'T', 'O', 'O', ' ', 'L', 'A', 'R', 'G', 'E', 16, 'A', 'R', 'R', 'A', 'Y', ' ', 'I', 'N', 'S', 'I', 'D', 'E', '-', 'O', 'U', 'T', 15, 'O', 'U', 'T', 'P', 'U', 'T', ' ', 'E', 'X', 'C', 'E', 'E', 'D', 'E', 'D', 17, 'C', 'A', 'P', 'I', 'C', 'I', 'T', 'Y', ' ', 'E', 'X', 'C', 'E', 'E', 'D', 'E', 'D', 19, 'U', 'N', 'A', 'S', 'S', 'I', 'G', 'N', 'E', 'D', ' ', 'V', 'A', 'R', 'I', 'A', 'B', 'L', 'E', 21, 'A', 'R', 'R', 'A', 'Y', ' ', 'B', 'O', 'U', 'N', 'D', 'S', ' ', 'E', 'X', 'C', 'E', 'E', 'D', 'E', 'D', 19, 'C', 'O', 'R', 'R', 'U', 'P', 'T', ' ', 'D', 'O', 'P', 'E', '-', 'V', 'E', 'C', 'T', 'O', 'R', 13, 'A', 'D', 'D', 'R', 'E', 'S', 'S', ' ', 'E', 'R', 'R', 'O', 'R', 21, 'U', 'N', 'E', 'X', 'P', 'L', 'A', 'I', 'N', 'E', 'D', ' ', 'I', 'N', 'T', 'E', 'R', 'R', 'U', 'P', 'T', 14, 'I', 'L', 'L', 'E', 'G', 'A', 'L', ' ', 'O', 'P', 'C', 'O', 'D', 'E', 18, 'S', 'T', 'R', 'E', 'A', 'M', ' ', 'N', 'O', 'T', ' ', 'D', 'E', 'F', 'I', 'N', 'E', 'D' %CONSTSHORTINTEGERARRAY FAULT(0 : 37) = %C 0, 16, 33, 47, 61, 75, 89, 102, 126, 148, 165, 186, 207, 221, 242, 257, 272, 304, 317, 341, 361, 381, 398, 417, 431, 445, 462, 479, 499, 516, 532, 550, 570, 592, 612, 626, 648, 663 %PRINTTEXT ' ' %IF PCOUNTER = 0 %AND INIMPI # 0 %UNLESS 0 <= EP <= 37 %THEN %START %PRINTTEXT 'UNKNOWN FAULT'; WRITE(EP,2) %FINISH %ELSE %START PRINTSTRING(STRING(ADDR(FSYM(FAULT(EP))))) %IF EP = 14 %C %THEN PRINTSTRING(' '''.TOSTRING(FNUM).'''') %C %ELSE %START %IF EP = 7 %OR EP = 32 %OR EP = 21 %OR EP = 33 %C %THEN WRITE(FNUM,2) %FINISH %FINISH %PRINTTEXT ' ' %PRINTTEXT ' ' %IF INIMPI # 0 %END %SYSTEMROUTINE I8DIAG(%INTEGER EP, FNUM) %SHORTROUTINE %INTEGER R10, BASE, DIAGS, NEWD, R9, VBASE, GLA, LEVEL, BRIEF AD %SHORTINTEGER BLOCK, LINE %SHORTINTEGER ADR, NAME, BLINE %OWNINTEGER FIRST DIAG = -1 %BYTEINTEGER FROM MDIAG BRIEF AD = COMREG(25)+1 PRINTED = 0 %IF EP >= 0 LEVEL = INTEGER(MLEVEL) FROM MDIAG = 0 %IF EP = -1 %START FROM MDIAG = 1 BASE = FNUM -> X2 %FINISH %ELSE FIRST DIAG = -1 %IF EP # 0 %START SELECTOUTPUT(INTEGER(SYSOUT)) PRINT MESSAGE(EP,FNUM) FAST BACK = 1 %FINISH %IF PCOUNTER # 0 %START BASE = PCOUNTER+4 PCOUNTER = 0 -> X2 %FINISH -> M1 %ROUTINE P N LIST(%INTEGER NLP, BASE) %INTEGER IN %BYTEINTEGER DELETE; ! FLAG FROM **DELETE %BYTEINTEGER TYPE; %SHORTINTEGER AD, NAME %INTEGER ADR, MASK, T, N, BREG %SWITCH PVAR(0 : 6) %CONSTSHORTINTEGERARRAY VTYPE(0 : 15) = %C 6,0(3),1,2,3,0,4,0,5,0(5) %CONSTSHORTINTEGERARRAY VMASK(0 : 6) = 0,3,0,1,3,7,0 LEVEL = LEVEL-1 -> QRET %IF LEVEL < 0 %IF SHORTINTEGER(NLP) = 0 %THEN %START %PRINTTEXT 'NO LOCAL VARIABLES ' %RETURN %FINISH %PRINTTEXT 'LOCAL VARIABLES ' %UNTIL SHORTINTEGER(NLP) = 0 %THEN %CYCLE AD <- SHORTINTEGER(NLP)&X'FFFC' NAME <- SHORTINTEGER(NLP+2) TYPE <- BYTEINTEGER(NLP+5) DELETE = BYTEINTEGER(NLP+4) N = INTEGER(NAME+DICTHEAD) %IF N = 0 %THEN %START PVAR(0): %PRINTTEXT '*** DIAGS CORRUPT *** ' QRET: %PRINTTEXT ' ' PRINTED = 0 **1,REG9 *LM_4,15,16(8) *BCR_15,15 %FINISH %IF DELETE = 0 %START PRINTSTRING(STRING(N).' =') ADR = AD&X'FFF'; BREG = AD>>12&15 %IF BREG = 13 %THEN BREG = GLA %ELSE BREG = BASE ADR = ADR+BREG T = VTYPE(TYPE&15); -> IVA %IF T = 0 MASK = VMASK(T) %IF TYPE&128 # 0 %THEN %START -> IVA %IF ADR&3 # 0 %C %OR ADR&X'FF0000' < X'100000' ADR = INTEGER(ADR) -> UAV %IF ADR = X'80808080' %FINISH -> IVA %IF ADR&MASK # 0 %OR ADR = 0 -> PVAR(T) ! PVAR(1): ! INTEGER IN = INTEGER(ADR); -> UAV %IF IN = X'80808080' %IF 0 # SHORTINTEGER(ADR) # -1 %START %PRINTTEXT ' X'''; HEX(IN); %PRINTTEXT '''' -> WRIT %FINISH WRITE(IN,1); -> WRIT PVAR(2): ! BYTEINTEGER WRITE(BYTEINTEGER(ADR),1); -> WRIT PVAR(3): ! SHORTINTEGER WRITE(SHORTINTEGER(ADR),1); -> WRIT PVAR(4): ! REAL -> UAV %IF INTEGER(ADR) = X'80808080' PRINTFL(REAL(ADR),7); -> WRIT PVAR(5): ! LONGREAL -> UAV %IF INTEGER(ADR) = X'80808080' PRINTFL(LONGREAL(ADR),14); -> WRIT PVAR(6): ! STRING -> UAV %IF BYTEINTEGER(ADR) = X'80' = %C BYTEINTEGER(ADR+1) PRINTSTRING(' '''.STRING(ADR).''''); -> WRIT IVA: ! INVALID ADDRESS %PRINTTEXT ' INVALID ADDRESS' -> WRIT UAV: %IF BYTEINTEGER(BRIEF AD) = 0 %C %THEN %PRINTTEXT ' NOT ASSIGNED' %C %ELSE %PRINTTEXT ' ?' WRIT: NEWLINE %FINISH NLP = NLP+6 %REPEAT NEWLINE %END M1: BASE = ADDR(EP)-64 X2: R9 = INTEGER(BASE+9<<2) GLA = INTEGER(BASE+13<<2); NEWD = GLA+20 R10 = INTEGER(BASE+10<<2) %IF GLA = INT GLA %START FIRST DIAG = INTEGER(NEWD) %IF FIRST DIAG < 0 %PRINTTEXT ' MONITOR ' %IF PRINTED = 0 %FINISH PRINTED = 1 1: ! INTEGER(ADDR(BLOCK)) = INTEGER(NEWD) *L_1,NEWD; *MVC_BLOCK(4),0(1) GLA = INTEGER(BASE+13<<2) %IF GLA # INTGLA %START INTEGER(INT GLA+20) = INTEGER(BASE) %IF FIRST DIAG >= 0 PDIAG(BASE-4,0,0) %AND %RETURN %IF FROM MDIAG = 0 FROM MDIAG = 0 *L_1,BASE *LM_4,15,16(8) *BCR_15,15; ! RETURN TO MDIAG %FINISH %PRINTTEXT 'ENTERED FROM ' -> 3 %IF LINE = 0 -> DF %IF LINE < 0 %OR R9 # REG9 %PRINTTEXT 'LINE'; WRITE(LINE,1) %PRINTTEXT ' OF '; -> 3 %IF BLOCK = 0 -> DF %IF BLOCK < 0 DIAGS = R10+BLOCK *L_1,DIAGS *MVC_ADR(6),0(1) %IF ADR&X'FFF0' = 0 %THEN %START PRINTSTRING('RT/FN/MAP '.STRING(INTEGER(NAME+DICTHEAD))) BASE = INTEGER(BASE+ADR<<2); NEWD = BASE R10 = INTEGER(BASE+10<<2) VBASE = BASE %FINISH %ELSE %START %PRINTTEXT 'BLOCK' VBASE = INTEGER(BASE+ADR>>10&60) R10 = VBASE+ADR&X'FFF' NEWD = R10+8 R10 = INTEGER(R10) %FINISH %PRINTTEXT ' STARTING AT LINE' %AND WRITE(BLINE,1) %C %IF BLINE # 1 NEWLINE P N LIST(DIAGS+6,VBASE) NEWLINE -> 1 DF: %PRINTTEXT ' *** DIAGS FAILURE *** ' 3: %PRINTTEXT 'BASIC LEVEL ' P N LIST(INTEGER(DIAGPT),REG9) NEWLINE PRINTED = 0 ! MDACTIVE = 0; ! CLEAR MY MDIAG ! ! VERY DUBIOUS ! %IF FAST BACK # 0 %START FAST BACK = 0 **1,REG9 *LM_4,15,16(1) *BCR_15,15 %FINISH INTEGER(INT GLA+20) = FIRST DIAG; ! RESTORE GLA FOR '%MONITOR' **1,REG9 %END %SYSTEMROUTINE ERMESS(%INTEGER FAULT, EXTRA) ! ! TAKE IT STRAIGHT TO I8DIAG ! %ROUTINESPEC CALL(%ROUTINENAME DIAG) %INTEGER N %IF INIMPI = 0 %START PRINT MESSAGE(FAULT,EXTRA) %IF FAULT # 0 %RETURN %FINISH SIGNAL(1,0,0,N); ! REMOVE SIGNAL CALL(I8DIAG) %ROUTINE CALL(%ROUTINENAME DIAG) *L_2,64(7); ! DESCRIPTOR OF 'DIAG' *LM_0,1,64(8) *L_8,32(8); ! REG 8 OF MDIAG *L_3,64(8); ! PCOUNTER FROM MDIAG *ST_3,PCOUNTER; ! R13 SHOULD BE SAFE ? *LM_4,15,16(8); ! ENTRY INFO TO MDIAG *STM_4,1,16(11) *LM_12,14,0(2) *BCR_15,14 %END %END %SYSTEMROUTINE IIGEN(%STRING (8) FILE, %INTEGERNAME CON, FLAG) %SHORTROUTINE %INTEGER X1, X2, X3, X4, P *L_1,52(8) *MVC_4(1,13),4(1); ! COPY FLAG P = CON FDP(5,FILE,ADDR(X1),0,FLAG); ! GET FILE INFO %IF FLAG # 0 %THEN %START %RETURN %UNLESS FLAG = 3; ! DOES NOT EXIST X2 = CON FDP(162,FILE,X2,0,FLAG); ! CREATE FILE %RETURN %IF FLAG # 0 X1 = 0 %FINISH %IF X2 # P %THEN %START FDP(2,FILE,0,0,FLAG); ! DISCONNECT FILE (MAY FAIL) FDP(6,FILE,P-X2,ADDR(X1),FLAG); ! EXTEND FILE X1 = 0; ! IT'S NO LONGER CONNECTED %RETURN %IF FLAG # 0 %FINISH %IF X1 = 0 %THEN %START; ! NOT CONNECTED CON = (CON+15)>>4; ! NUMBER OF SEGMENTS FDP(1,FILE,3,ADDR(CON),FLAG); ! CONNECT FILE %RETURN %IF FLAG # 0 %FINISH %ELSE %START %IF X3 # 3 %THEN %START FDP(171,FILE,3,0,FLAG); ! CHANGE ACCESS MODE %FINISH CON = X1<<16 %FINISH %END %EXTERNALROUTINE IMPI(%STRING (1) PARM) %INTEGER MON HEX ADDR %SHORTROUTINE %INTEGER FLAG %OWNSTRING (1) DOT = '.' %IF IMPIUSE # 0 %START %PRINTTEXT 'IMPI FAILS ' %RETURN %FINISH IMPIUSE = 1 %IF PARM # '' %AND '1' <= PARM <= '9' %C %THEN INTSIZE = (CHARNO(PARM,1)-'0'+1)<<4 PRINTCH(7); NEWLINE DOT = '' %IF INT OWNER = '' RUN(INT OWNER.DOT.OBJECT) %PRINTTEXT '#CLOSE ' MON HEX ADDR = COMREG(25) BYTEINTEGER(MON HEX ADDR) = BYTEINTEGER(MON HEX ADDR)&127 FDP(3,'II#CODE',0,0,FLAG) %END %EXTERNALROUTINE IMPIP(%STRING (17) S) %DYNAMICROUTINESPEC DEFINE(%STRING (63) S) %STRING (15) T T = '' %UNLESS S -> S.(',').T DEFINE('ST78,'.S) SELECTINPUT(78) IOFLAG = 3 COMP MODE = 64 IMPI(T) %END %EXTERNALROUTINE IMPIT(%STRING (1) S) INT OWNER = '' OBJECT = 'IMPIOBJT' IMPI(S) %END %EXTERNALROUTINE ITEST(%STRING (15) S) OBJECT = S INT OWNER = '' IMPI('') %END %EXTERNALROUTINE BRIEF(%STRING (1) S) BYTEINTEGER(COMREG(25)+1) = LENGTH(S) %END %ENDOFFILE @@@@@@@@@@@@@@@ ! !****************************************** !* * !* MODIFIED MDIAG TO CO-OPERATE WITH * !* THE IMP INTERPRETER (FLAG = 5) * !* * !****************************************** ! %DYNAMICROUTINESPEC DEFINE(%STRING(63) S) %SYSTEMINTEGERFNSPEC I8DIAG(%INTEGER EP, EXTRA) %OWNINTEGER MON HEX ADDR, BRIEF ADDR %OWNINTEGER DTLAST = 0 %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %ROUTINE SIGNAL(%INTEGER J,K,L,%INTEGERNAME FLAG) %RECORDFORMAT AGFM(%INTEGER EP,%STRING(17) S,%INTEGER P1,P2,%C %INTEGERNAME FLAG) %SYSTEMROUTINESPEC AGENCY(%INTEGER P1,%RECORDNAME P) %RECORD P(AGFM) P_EP=J P_P1=K P_P2=L P_FLAG==FLAG AGENCY(2,P) %END %SYSTEMROUTINE PDIAG(%INTEGER PCOUNT, FAULT, INF) !*********************************************************************** !* FAILED ROUTINE FROM BYTE 4 OF THE GLA AND CALLS APPROPRIATE * !* GIVEN. * !* PCOUNT = ADDR(PCOUNTER+REGISTERS AT FAILURE) * !* FAULT = FAILURE (0=%MONITOR REQUESTED) * !* INF =ANY FURTHER INFORMATION * !*********************************************************************** %SHORTROUTINE ! ! COMMUNICATION VARIABLES FOR IMPI ! %EXTRINSICBYTEINTEGER INIMPI; ! SHOW IF IN INTERPRETER %EXTRINSICINTEGER REG9; ! REG 9 FROM IMPI %EXTRINSICINTEGER INTGLA; ! GLA OF IMPI ! %SYSTEMROUTINESPEC IIDUMP(%INTEGER I, J) %SYSTEMROUTINESPEC FINDEP(%STRING (8) EP, %INTEGERNAME I) %ROUTINESPEC ASSDUMP(%INTEGER I, J) %ROUTINESPEC ENTER(%INTEGER NUM, PARS, %INTEGERNAME F) %OWNSTRING (8) %ARRAY EPS(0 : 5) = 'S#ERMESS','S#INDIAG', 'S#FDIA','F#LABS', ''(2) %OWNINTEGERARRAY CGE(0 : 14) %EXTERNALBYTEINTEGER MDACTIVE = 0 %INTEGER LANGFLAG, I, J, GLA, OLDREG, ANEWREG, NEWREG, SGLA %SWITCH LANGUAGE(0 : 5) %STRING (1) FAILNO %INTEGERARRAY REGS(-1 : 24); ! PCOUNTER,GRS & FRS IN HERE %OWNSTRING(9)%ARRAY LT(0:5)' !???! ',' IMP ',' FORTRAN ', ' IMPS ',' ASMBLR ',' IMPI ' *OI_4(13),5 MON HEX ADDR = ADDR(COMREG(25)) BRIEF ADDR = MON HEX ADDR+1 DTLAST = 0 %CYCLE I = 0, 1, 14; CGE(I) = 0 %REPEAT; ! ONLY NEEDED ON EMAS ANEWREG = ADDR(NEWREG) ! LAY DOWN A CONTINGENCY AGAINST ERRORS IN MDIAGS I = 0 %IF INIMPI = 0 %START *LA_15, *L_1,REGS; *STM_4,15,16(1); ! STUFF OFF REGISTERS SIGNAL(0, ADDR(REGS(4)), 0, I) %FINISH MDACTIVE = MDACTIVE+1 FAILNO = '1' %IF MDACTIVE > 5 %THEN -> EOUT FAILNO = '2' %IF I > 0 %THEN -> EOUT; ! CONTINGENCY DID NOT GO DOWN ! COPY FAILURE REGS INTO ARRAY FOR CONVENIENCE *L_1,PCOUNT; *L_2,REGS+4; *MVC_0(100,2),0(1) GLA = REGS(13) FAILNO = '3' -> EOUT %UNLESS 0 < GLA < X'FFFFFF' %AND GLA&7 = 0 ! ! NOW SET UP OUTPUT FILE IF NESC. ! SGLA = INTEGER(GLA+20) LANGFLAG = BYTE INTEGER(GLA+4)>>4 LANGFLAG = 0 %IF LANGFLAG > 5 PRINT STRING(' MONITOR ENTERED FROM'.LT(LANGFLAG).' ') %C %IF INIMPI = 0 ! ONLY IF NOT IN IMPI %UNLESS (FAULT = 35 %AND INF = 0) %THEN %START ! ! ON THE 370 THERE NEEDS TO BE A MECHANISM TO GIVE ! THE FOLLOWING CODE IS EXECUTED EXCEPT AFTER SUCH A MESSAGE. ! ! %IF LANGFLAG = 2 %THEN ENTER(3, ADDR(FAULT), I) ! LABEL TRACE ENTER(0, ADDR(FAULT), I) %IF INIMPI = 0 %OR FAULT # 0 ! ERROR MESSAGE %IF I < 0 %THEN %START %PRINTTEXT ' FAULT NO='; WRITE(FAULT, 2) %FINISH %FINISH ! ! I = GLA OLDREG = ADDR(REGS(0)); -> LANGUAGE(LANGFLAG) LANGUAGE(0): -> EXIT %IF INIMPI # 0 LANGUAGE(4): ! UNKNOWN & ASSEMBLER ASSDUMP(PCOUNT, 1) -> EXIT; ! NO WAY OF TRACING BACK LANGUAGE(1): LANGUAGE(3): ! IMP & IMPS ENTER(1, ADDR(OLDREG), I); ! IDIAGS -> EXIT %IF I < 0 %OR NEWREG = 0 NEXTRT: ! CONTINUE TO UNWIND STACK OLDREG = NEWREG -> EXIT %IF (REG9 = 0 %OR INIMPI = 0) %C %AND INTEGER(OLDREG+44) <= COMREG(36) ! FAR ENOUGH I = INTEGER(OLDREG+52) -> IMPI %IF I = INTGLA LANGFLAG = BYTEINTEGER(I+4)>>4 LANGFLAG = 0 %IF LANGFLAG > 5 -> LANGUAGE(LANGFLAG) IMPI: LANGUAGE(5): ! IMPI %IF BYTEINTEGER(I+4) = X'55' %START; ! FROM I8IOCP SO SKIP IT NEW REG = INTEGER(OLD REG+32); ! OLD REG 8 %FINISH %ELSE %START NEWLINE NEW REG = I8DIAG(-1, OLDREG); ! CALL IMPI MONITOR -> EXIT %IF NEW REG = REG 9; ! END FROM '%MONITOR' %FINISH -> NEXT RT LANGUAGE(2): ! FORTRAN ENTER(2, ADDR(OLDREG), I) -> EXIT %IF I < 0; -> NEXT RT MDERROR: ! ENTER FROM CONTINGENCY *ST_2,I; *LA_1,4(1); *ST_1,J %PRINTTEXT ' INTERRUPT DURING DIAGNOSTICS WT = ' WRITE(I, 3) ASSDUMP(J, 1) -> QUIT EOUT: ! ERRROR EXIT PRINTSTRING(' PDIAG FAILS '.FAILNO) NEWLINE; -> QUIT EXIT: NEWLINE %IF NEW REG = 0 SIGNAL(1, 0, 0, I) %IF INIMPI = 0; ! POP UP CONTINGENCY MDACTIVE = 0; INTEGER(GLA+20) = SGLA %IF FAULT = 0 %THEN -> END %IF COMREG(27)&X'400000' # 0 %THEN -> END;! FTRAN ERROR RECOV QUIT: **1,COMREG(36) *LM_4,15, 16(1) *BCR_15,15 %ROUTINE ENTER(%INTEGER NUM, PARS, %INTEGERNAME FLAG) !*********************************************************************** !*THIS ROUTINE ATTEMPTS TO ENTER THE ROUTINE WHOSE NAME IS EPS(NUM) * !* USING FINDEP. IF THE ROUTINE IS NOT IN STORE IT TRIES TO LOAD IT AS * !* AN OVERLAY ON 4-70J AND 360OS. ON EMAS THE ROUTINES SHOULD ALWAYS BE* !* IN VIRTUAL STORE. THE ARRAY CGE IS USED TO REMEMBER ROUTINES ENTERED* !* AS THE FIND/LOAD/ENTER SEQUENCE IS EXPENSIVE * !*********************************************************************** %INTEGER I, J, K; ! ALL OF THESE ARE NEEDED %IF CGE(3*NUM+2) \= 0 %THEN -> ALREADY ENTERED FIND EP(EPS(NUM), I) %IF I <= 0 %THEN %START; ! ERROR, ROUTINE SHOULD BE !LOADED PRINTSTRING(' UNABLE TO ENTER '.EPS(NUM)) FLAG = -1 -> END %FINISH ! INSERT ENTRY INFORMATION INTO ARRAY CGE - USE M/C CODE **3,ADDR(CGE(3*NUM)) *L_2,I; *LM_0,2,4(2); *STM_0,2,0(3) ALREADY ENTERED: ! ENTRY INFO IN ARRAY CGE **3,ADDR(CGE(3*NUM)) *L_1,PARS; *MVC_64(16,11),0(1); ! MOVE IN UPTO 4 PARAMETERS *STM_0,15,0(11); ! 4 EXTRA REGS STORED IN CASE ! OF IIDUMPS WHILE DEBUGGING *LM_12,14,0(3); *BALR_15,14 FLAG = 0; ! FLAG TO 'SUCCESS' END: %END; ! OF ENTER %ROUTINE ASSDUMP(%INTEGER PCOUNT, FLAG) %INTEGER I COMREG(28) = 16; ! EMAS ONLY PERMIT HEX IIDUMP %PRINTTEXT ' P COUNTER AND REGISTERS ' IIDUMP(PCOUNT, PCOUNT+96) %PRINTTEXT ' CODE ' I = INTEGER(PCOUNT)&X'FFFFFF' IIDUMP(I-64, I+64) %RETURN %IF FLAG = 0 %PRINTTEXT ' GLA ' I = INTEGER(PCOUNT+56) IIDUMP(I, I+128) %END END: %END; ! OF MDIAGS ! ! INDIAGS FOR IMPI ! %SYSTEMROUTINE INDIAGS(%INTEGER OLDREG, %INTEGERNAME NEWREGS) %SHORTROUTINE %ROUTINESPEC FIND BLOCK %ROUTINESPEC PRINT LOCALS %ROUTINESPEC PRINT VAR %BYTEINTEGERNAME MONHEX %EXTERNALROUTINESPEC HEX(%INTEGER N) %STRING (40) NAME %INTEGER UGLAREG, FLINE, FBLINE, ADATA, BASEREG %BYTEINTEGER BTYPE, NAM, TYPE, PREC %INTEGER TSTART, PREV BLOCK ! MON HEX ADDR = ADDR(COMREG(25)) BRIEF ADDR = MON HEX ADDR + 1 MON HEX == BYTEINTEGER(MON HEX ADDR) UGLA REG = INTEGER(OLDREG+4*13); ! GLA REGISTER FLINE = SHORTINTEGER(UGLAREG+22); ! LINE NUMBER FBLINE = SHORTINTEGER(UGLAREG+20); ! START OF RT/BLOCK %CYCLE FIND BLOCK %IF ADATA <= 0 %START; ! NOT FOUND %PRINTTEXT 'NO FURTHER DIAGNOSTICS AVAILABLE ' NEWREGS = 0 %RETURN %FINISH %PRINTTEXT 'ENTERED FROM ' %IF FLINE >= FBLINE %START %PRINTTEXT 'LINE' WRITE(FLINE, 1) %PRINTTEXT ' OF ' %FINISH %IF BTYPE = 0 %THEN %PRINTTEXT 'BLOCK' %C %ELSE PRINTSTRING('RT/FN/MAP '.NAME) %PRINTTEXT ' STARTING AT LINE' WRITE(FBLINE, 1) PRINT LOCALS %IF BTYPE # 0 %THEN %START ! RESTORE LINE NUMBER NEWREGS = INTEGER(OLDREG+4*BASEREG) INTEGER(UGLAREG+20) = INTEGER(NEWREGS) NEWLINE %RETURN %FINISH %IF PREV BLOCK = 0 %START NEWREGS = 0 NEWLINE %RETURN %FINISH FLINE = FBLINE FBLINE = PREV BLOCK %PRINTTEXT ' ' %REPEAT ! %ROUTINE PRINT LOCALS ! ADATA POINTS TO FIRST ENTRY IN DIAG TABLES NEWLINE PRINTSTRING('NO LOCAL VARIABLES ') %IF INTEGER(ADATA) < 0 %CYCLE %WHILE INTEGER(ADATA) >= 0 %CYCLE PRINT VAR ADATA = (ADATA+7+BYTEINTEGER(ADATA+3))&X'FFFFFC' %REPEAT %RETURN %UNLESS INTEGER(ADATA) = -2 %AND DTLAST # TSTART DTLAST = TSTART %PRINTTEXT ' ENVIRONMENTAL VARIABLES ' ADATA = ADATA+4 %REPEAT %END ! %ROUTINE FIND BLOCK ! SEARCH THE DIAG TABLES FOR BLOCK STARTING AT 'FBLINE' %CONSTINTEGER BMARK = X'C2C2C2C2' %CONSTINTEGER SMARK = X'E2E2E2E2' %INTEGER K, L TSTART = INTEGER(UGLAREG+28)+INTEGER(UGLAREG+12) ! HEAD OF TABLES L = TSTART %CYCLE %IF INTEGER(L) = BMARK %START %EXIT %IF SHORTINTEGER(L+4) = FBLINE L = L+8 %FINISH %IF INTEGER(L) = SMARK %START ADATA = 0 %RETURN %FINISH L = L+4 %REPEAT ! BLOCK FOUND OK BASE REG = BYTEINTEGER(L+6) K = BYTEINTEGER(L+7) NAME <- STRING(L+7) %IF K = 0 %START; ! BEGIN BTYPE = 0 PREV BLOCK = INTEGER(L+8) ADATA = L+12 %FINISH %ELSE %START; ! ROUTINE BTYPE = 1 ADATA = (K+L+11)&X'FFFFFC' %FINISH %END ! %ROUTINE PRINT VAR ! ! OUTPUT THE NEXT VARIABLE IN THE CURRENT BLOCK ! THE ENTRY IS :- ! FLAG<<24 ! VBREG<<20 ! DISP<<8 ! L ! %INTEGER K, L, DISP, VBREG, VADDR, BYTES %CONSTINTEGER UNASSI = X'80808080' %CONSTINTEGER BTRTAB = X'03000107' %SWITCH S(0 : 7) ! L = INTEGER(ADATA) DISP = L>>8&4095 VBREG = L>>20&15 K = L>>24 TYPE = K&7 PREC = K>>3&3 NAM = K>>6&1 BYTES = PREC *TR_BYTES+3(1),BTRTAB; ! ROUNDING FACTOR FOR EACH PREC ! PRINTSTRING(STRING(ADATA+3).' =') VADDR = INTEGER(OLDREG+4*VBREG)+DISP %IF NAM # 0 %START -> INVALID %UNLESS VADDR&3 = 0 VADDR = INTEGER(VADDR) -> NOT ASS %IF VADDR = UNASSI %FINISH -> STR %IF TYPE = 5 -> INVALID %UNLESS VADDR&BYTES = 0 -> S(PREC+4*((TYPE-1)&1)) ! S(0): ! INTEGER -> NOT ASS %IF INTEGER(VADDR) = UNASSI %IF MONHEX # 0 %AND 0 # SHORTINTEGER(VADDR) # -1 %START %PRINTTEXT ' X''' HEX(INTEGER(VADDR)) %PRINTTEXT '''' %FINISH %ELSE WRITE(INTEGER(VADDR), 1) -> NEXT S(1): !BYTEINTEGER WRITE(BYTEINTEGER(VADDR), 1); -> NEXT S(2): ! SHORTINTEGER WRITE(SHORTINTEGER(VADDR), 1); -> NEXT S(4): ! REAL -> NOT ASS %IF INTEGER(VADDR) = UNASSI PRINTFL(REAL(VADDR), 7); -> NEXT S(7): ! LONGREAL -> NOTASS %IF INTEGER(VADDR) = UNASSI = INTEGER(VADDR+4) PRINTFL(LONGREAL(VADDR), 14); -> NEXT S(3): S(5): S(6): INVALID: %PRINTTEXT ' INVALID ADDRESS'; -> NEXT NOT ASS: %IF BYTEINTEGER(BRIEF ADDR) # 0 %THEN %PRINTTEXT ' ?' %C %ELSE %PRINTTEXT ' NOT ASSIGNED' -> NEXT STR: -> NOT ASS %C %IF BYTEINTEGER(VADDR) = X'80' = BYTEINTEGER(VADDR+1) %PRINTTEXT ' ''' PRINTSTRING(STRING(VADDR)) %PRINTTEXT '''' NEXT: NEWLINE %END %END %EXTERNALROUTINE MONHEX(%STRING (1) S) BYTEINTEGER(ADDR(COMREG(25))) = LENGTH(S) %END %ENDOFFILE @@@@@@@@@@@@@@@ %CONSTSHORTINTEGERARRAY MAIN(1 : 217) = %C 1, 5, 14, 20, 26, 38, 43, 48, 54, 61, 68, 74, 79, 82, 84, 89, 96, 102, 108, 115, 122, 126, 0, 129, 133, 137, 142, 145, 152, 156, 161, 164, 168, 0, 171, 0, 178, 184, 185, 189, 190, 193, 196, 199, 0, 202, 205, 206, 208, 0, 211, 213, 215, 216, 219, 222, 225, 0, 228, 231, 236, 241, 244, 249, 0, 253, 259, 260, 264, 266, 267, 270, 271, 274, 277, 279, 280, 283, 286, 289, 292, 295, 298, 302, 305, 308, 311, 314, 317, 320, 324, 328, 332, 336, 340, 344, 348, 352, 355, 358, 0, 361, 363, 365, 373, 0, 381, 0, 385, 392, 393, 396, 397, 400, 403, 405, 406, 410, 0, 413, 418, 425, 432, 0, 435, 437, 0, 440, 445, 446, 450, 453, 456, 0, 459, 462, 463, 0, 469, 472, 473, 475, 0, 477, 489, 499, 506, 0, 509, 511, 512, 517, 0, 520, 0, 530, 534, 535, 538, 539, 0, 543, 546, 547, 0, 558, 565, 566, 571, 572, 576, 579, 0, 585, 587, 588, 591, 0, 594, 597, 0, 600, 602, 603, 608, 609, 614, 615, 618, 0, 620, 622, 623, 627, 628, 631, 634, 637, 0, 640, 646, 0, 651, 656, 657, 660, 661, 665, 0, 667, 0, 670, 674, 675, 678, 681, 683 %CONSTSHORTINTEGERARRAY SUB(2 : 684) = %C 4119, 4288, -8192, 0, 4149, 4168, 4197, 4166, 4286, 4119, 4230, -8192, 0, 1, 8200, 24576, 4230, -8192, 0, 8, 8221, 24576, 16384, -8192, 0, 15, 8204, 20480, 16384, 4202, 21, 8244, 4168, 4197, 4166, -8192, 0, 4154, 4246,-20480, -8192, 0, 4290, 4154, 4295, -20480, 0, 23, 8223, 4255, -8192,-20480, 0, 4208, 4271, 4212, -4096, 4261, -8192, 0, 30, 8197, -4096, 4261, -8192,-20480, 0, 35, 8196, 20480, -8192,-16384, 0, 41, 8198, 4215, -8192, 0, 4130, 4096, 0, 4225, 0, 45, 8199, -8192,-20480, 0, 4309, 50, 8201, 4239, -8192,-20480, 0, 57,-20480, 8202, 12288, -8192, 0, 65, 8203, 4232, -8192,-20480, 0, 71, 77, 8193, 8205, -8192,-20480, 0, 85, 93, 8206, 8207, -8192,-20480, 0, 101, 8257,-32768, 0,-12288, -8192, 0, 4202, 4134, 4141, 0, 103, 8246, 4143, 0, 106, 8208, 12288, 4141, 0, 116, 8209, 0, 123, 8210, 4136, 4168, 4197, 4166, 0, 130, 8211, 20480, 0, 15, 8204, 20480, 16384, 0, 136, 8212, 0, 141, 8213, 4146, 0, 149, 8214, 0, 8292, 4220, 154, 8245, 8192, 4132, 0, 8292, 4220, 154, 8245, 8192, 4132, 0, 4136, 4168, 4197, 4166, 0, 156, 8247, 0, 21, 8244, 0, 159, 8248, 0, 103, 8246, 0, 162, 8215, 4119, 0, 12288, 0, -4096, 4204, 0, 12288, 0, 136, 8212, 0, 166, 8216, 0, 169, 8218, 0, 175, 8217, 0, 182, 8219, 0, 188, 8220, 0, 196, 188, 8194, 8220, 0, 71, 188, 8193, 8220, 0, 201, 8222, 0, 206, 201, 8195, 8222, 0, 211, 8224, 4161, 0, 218, 8249, 12288, 220, 8250, 8271, 0, 222, 8225, 8226, 0, 232, 8226, 0, 4172, 4197, 4166, 0, 237, 8251, 0, 239, 8252, 0, 241, 8253, 0, 237, 8251, 0, 103, 8246, 0, 239, 8252, 0, 243, 8254, 0, 245, 8255, 0, 248, 8256, 0, 250, 8257, 8257, 0, 101, 8257, 0, 253, 8258, 0, 256, 8259, 0, 258, 8260, 0, 260, 8261, 0, 263, 8262, 0, 21, 8244, 4168, 0, 266, 8263, 4168, 0, 269, 8264, 4168, 0, 271, 8267, 4168, 0, 273, 8265, 4168, 0, 276, 8266, 4168, 0, 278, 8268, 4168, 0, 281, 8272, 4168, 0, 162, 8215, 0, 283, 8227, 0, 154, 8245, 0, 12288, 0, 4202, 0, 218, 8249, 4168, 4197, 4166, 220, 8250, 0, 248, 8256, 4168, 4197, 4166, 248, 8256, 0, -4096, 4204, 4206, 0, 218, 8249, 4168, 4197, 4166, 220, 8250, 0, 286, 8270, 4202, 0, 288, 8231, 0, 297, 8232, 0, 304, 8233, 0, 30, 8197,-20480, 0, 20480,-16384, 0, 312, 8234, 8199,-20480, 0, 319, 8234, 8207, 28672, 24576, 20480, 0, 329, 8234, 8235, 28672, 24576, 20480, 0, 24576, 28672, 0, 12288, 0, -4096, 4223, 0, 218, 8249, 12288, 220, 8250, 0, 248, -8191,-28672, 0, 336, -24576, 0, 248,-28672, 0, 339,-28672, 0, 347, 8237, 4119, 0, 12288, 103, 8246, 4236, 4234, 0, 281, 8269, 4232, 0, 12288, 0, -4096, 0, 352, 8238, -4096, 218, 8249, 4283, 4246, 4279, 4281, 220, 8250, 0, 30, 8197, -4096, 4253, 218, 8249, -4096, 220, 8250, 0, 4246, 218, 8249, -4096, 220, 8250, 0, 232, 8226, 0, 352, 8238, 0, 359, 8225, 4244, 4249, 0, 4163, 4305, 0, 4305, 218, 8249, 4168, 4197, 4166, 220, 8250, 4251, 0, 281, 8269, 4249, 4251, 0, 286, 8270, -4096, 0, 4305, 4259, 4257, 0, 281, 8269, 4255, 0, 218, 8249, 4168, 12288, 154, 8245, 4168, 12288, 220, 8250, 0, 218, 8249, 4265, 4305, 4263, 220, 8250, 0, 281, 8269, 4265, 4305, 4263, 0, 4271, 232, 8226, 0, 4154, 4163, 0, 50, 8201, 4269, 232, 8226, 0, 359, 8225, 0, 77, 8205, 0, 4154, 4274, 0, 365, 8239, 0, 368, 8240, 0, 281, 8269, 0, 218, 8249, -4096, 220, 8250, 0, 4277, 4283, 4246, 4279, 4281, 0, 50, 8201, 0, 4154, 0, 372, 8241, 0, 4149, 4168, 4197, 4166, 0, 377, 8228, 0, 381, 8229, 0, 387, 8230, 0, 288, 8231, 0, 359, 8225, -4096, 4259, 4302, 0, 4305, 4300, 4298, -8192, 0, 281, 8269, 4305, 4300, 4298, 0, 21, 8244, 12288, 0, 21, 8244,-32768, 0, -8192, 0, -4096, 4307, 0, 281, 8269, -4096, 4307, 0, 377, 8228, 0, 288, 8231, 0, 387, 8230, 0 %CONSTBYTEINTEGERARRAY LITERAL(1 : 396) = %C 6, 102, 105, 110, 105, 115, 104, 6, 114, 101, 112, 101, 97, 116, 5, 99, 121, 99, 108, 101, 1, 61, 6, 115, 119, 105, 116, 99, 104, 4, 115, 112, 101, 99, 5, 98, 101, 103, 105, 110, 3, 101, 110, 100, 4, 108, 105, 115, 116, 6, 114, 101, 99, 111, 114, 100, 7, 99, 111, 110, 116, 114, 111, 108, 5, 102, 97, 117, 108, 116, 5, 115, 104, 111, 114, 116, 7, 114, 111, 117, 116, 105, 110, 101, 7, 116, 114, 117, 115, 116, 101, 100, 7, 112, 114, 111, 103, 114, 97, 109, 1, 42, 2, 45, 62, 9, 112, 114, 105, 110, 116, 116, 101, 120, 116, 6, 114, 101, 116, 117, 114, 110, 6, 114, 101, 115, 117, 108, 116, 5, 115, 116, 97, 114, 116, 4, 115, 116, 111, 112, 7, 109, 111, 110, 105, 116, 111, 114, 4, 101, 120, 105, 116, 1, 58, 2, 61, 61, 2, 60, 45, 3, 97, 110, 100, 2, 105, 102, 5, 119, 104, 105, 108, 101, 6, 117, 110, 108, 101, 115, 115, 5, 117, 110, 116, 105, 108, 7, 105, 110, 116, 101, 103, 101, 114, 4, 98, 121, 116, 101, 4, 114, 101, 97, 108, 4, 108, 111, 110, 103, 6, 115, 116, 114, 105, 110, 103, 1, 40, 1, 41, 9, 97, 114, 114, 97, 121, 110, 97, 109, 101, 4, 110, 97, 109, 101, 1, 43, 1, 45, 1, 92, 1, 38, 2, 33, 33, 1, 33, 2, 42, 42, 2, 47, 47, 1, 47, 1, 46, 2, 60, 60, 2, 62, 62, 2, 60, 61, 1, 60, 1, 35, 2, 62, 61, 1, 62, 2, 92, 61, 1, 44, 2, 111, 114, 1, 95, 8, 101, 120, 116, 101, 114, 110, 97, 108, 6, 115, 121, 115, 116, 101, 109, 7, 100, 121, 110, 97, 109, 105, 99, 6, 111, 102, 108, 105, 115, 116, 9, 111, 102, 112, 114, 111, 103, 114, 97, 109, 6, 111, 102, 102, 105, 108, 101, 2, 33, 42, 7, 99, 111, 109, 109, 101, 110, 116, 4, 101, 108, 115, 101, 6, 102, 111, 114, 109, 97, 116, 5, 97, 114, 114, 97, 121, 2, 102, 110, 3, 109, 97, 112, 4, 116, 104, 101, 110, 3, 111, 119, 110, 5, 99, 111, 110, 115, 116, 9, 101, 120, 116, 114, 105, 110, 115, 105, 99 %CONSTBYTEINTEGERARRAY SFLAGS(1 : 80) = %C 3, 3, 3, 0, 0, 0, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 1, 1, 1, 1, 4, 0, 4, 0, 4, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 %CONSTBYTEINTEGERARRAY KEYSYMS(1 : 381) = %C 5, 83, 72, 79, 82, 84, 4, 66, 89, 84, 69, 4, 76, 79, 78, 71, 5, 66, 69, 71, 73, 78, 4, 83, 80, 69, 67, 3, 69, 78, 68, 4, 76, 73, 83, 84, 6, 70, 73, 78, 73, 83, 72, 6, 82, 69, 67, 79, 82, 68, 7, 67, 79, 78, 84, 82, 79, 76, 5, 70, 65, 85, 76, 84, 5, 67, 89, 67, 76, 69, 7, 82, 79, 85, 84, 73, 78, 69, 7, 84, 82, 85, 83, 84, 69, 68, 7, 80, 82, 79, 71, 82, 65, 77, 9, 80, 82, 73, 78, 84, 84, 69, 88, 84, 6, 82, 69, 84, 85, 82, 78, 6, 82, 69, 83, 85, 76, 84, 5, 83, 84, 65, 82, 84, 4, 83, 84, 79, 80, 7, 77, 79, 78, 73, 84, 79, 82, 4, 69, 88, 73, 84, 3, 65, 78, 68, 2, 73, 70, 6, 85, 78, 76, 69, 83, 83, 5, 87, 72, 73, 76, 69, 5, 85, 78, 84, 73, 76, 7, 73, 78, 84, 69, 71, 69, 82, 6, 82, 69, 80, 69, 65, 84, 4, 82, 69, 65, 76, 6, 83, 87, 73, 84, 67, 72, 6, 83, 84, 82, 73, 78, 71, 5, 65, 82, 82, 65, 89, 4, 78, 65, 77, 69, 2, 79, 82, 3, 79, 87, 78, 5, 67, 79, 78, 83, 84, 9, 69, 88, 84, 82, 73, 78, 83, 73, 67, 8, 69, 88, 84, 69, 82, 78, 65, 76, 6, 83, 89, 83, 84, 69, 77, 7, 68, 89, 78, 65, 77, 73, 67, 2, 79, 70, 4, 70, 73, 76, 69, 7, 67, 79, 77, 77, 69, 78, 84, 4, 69, 76, 83, 69, 6, 70, 79, 82, 77, 65, 84, 2, 70, 78, 3, 77, 65, 80, 4, 84, 72, 69, 78, 5, 82, 69, 65, 76, 83, 6, 78, 79, 82, 77, 65, 76, 1, 61, 1, 58, 2, 45, 62, 2, 61, 61, 2, 60, 45, 1, 40, 1, 41, 1, 43, 1, 45, 1, 92, 1, 38, 2, 33, 33, 1, 33, 1, 42, 2, 47, 47, 1, 47, 1, 46, 2, 60, 60, 2, 62, 62, 2, 60, 61, 1, 60, 2, 62, 61, 1, 62, 1, 35, 2, 92, 61, 1, 44, 1, 95, 1, 32, 1, 44 %CONSTSHORTINTEGERARRAY KEYWORD(1 : 80) = %C 0, 6, 11, 16, 22, 27, 31, 36, 43, 50, 58, 64, 70, 78, 86, 94, 104, 111, 118, 124, 129, 137, 142, 146, 149, 156, 162, 168, 176, 183, 188, 195, 202, 208, 213, 216, 220, 226, 236, 245, 252, 260, 263, 268, 276, 281, 288, 291, 295, 300, 306, 313, 315, 317, 320, 323, 326, 328, 330, 332, 334, 336, 338, 341, 343, 345, 348, 350, 352, 355, 358, 361, 363, 366, 368, 370, 373, 375, 377, 379 %CONSTBYTEINTEGERARRAY KFLAGS(1 : 80) = %C 144, 144, 144, 128, 129, 128, 128, 128, 128, 128, 128, 128, 128, 144, 128, 128, 128, 128, 128, 128, 144, 128, 160, 130, 130, 130, 130, 128, 128, 128, 128, 128, 145, 129, 128, 144, 144, 144, 144, 144, 144, 145, 128, 128, 162, 129, 129, 129, 160, 144, 128, 8, 8, 8, 8, 8, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 8, 8, 8, 8, 8, 64, 0, 0, 0 %OWNBYTEINTEGER ISOLATE BRACKETS = 0; ! 'IB' %OWNBYTEINTEGER LEAVE BLANKS = 0; ! 'LB' %OWNBYTEINTEGER SEP BLOCKS = 1; ! 'SB' %OWNBYTEINTEGER INDENT BLOCKS = 1; ! 'TB' %OWNBYTEINTEGER SPLIT KEYWORDS = 0; ! 'SK' %OWNBYTEINTEGER PACK NAMES = 0; ! 'PN' %OWNBYTEINTEGER SPLIT STATS = 0; ! 'SS' %OWNBYTEINTEGER COMMENTS NORMAL = 0; ! 'CN' %OWNBYTEINTEGER BREAK COMMENTS = 1; ! 'BC' %OWNBYTEINTEGER LEAVE STARS = 1; ! 'LS' %OWNBYTEINTEGER JUSTIFY ALL = 0; ! 'JA' %OWNBYTEINTEGER LABELS RELATIVE = 0; ! 'LR' %OWNBYTEINTEGER SPLIT CONDS = 1; ! 'SC' %OWNBYTEINTEGER DECS RELATIVE = 1; ! 'DR' %OWNBYTEINTEGER SPACE LISTS = 1; ! 'SL' %OWNBYTEINTEGER SPACE EQUALS = 1; ! 'SE' %OWNBYTEINTEGER ISOLATE LOOPS = 1; ! 'IL' %OWNBYTEINTEGER EXTRA MARGIN = 0; ! 'EM' %OWNBYTEINTEGER LEAVE OWNS = 0; ! 'LO' %OWNBYTEINTEGER COMMENTS RELATIVE = 1; ! 'CR' %OWNBYTEINTEGER EXTEND COMMENTS = 1; ! 'EC' %OWNBYTEINTEGER MI = 3; ! MARGIN INCREMENT %OWNBYTEINTEGER LL = 72; ! LINE LENGTH %OWNBYTEINTEGER CT = 40; ! COMMENT TAB %OWNBYTEINTEGER ML = 40; ! MARGIN LIMIT %OWNBYTEINTEGER COMMENT EXTENSION = 5; ! 'CE' %OWNBYTEINTEGER EXT NUM = 2; ! 'XN' %OWNBYTEINTEGER INITIAL MARGIN = 7; ! 'IM' %OWNBYTEINTEGER SECONDARY MARGIN = 3; ! 'SM' %OWNBYTEINTEGER COMMENT LIMIT = 20; ! 'CL' %OWNBYTEINTEGER COMMENT LINE = 120; ! 'LC' %OWNSHORTINTEGER SAFETY FACTOR = 5 %OWNINTEGER DELTA MARGIN = 3 %OWNINTEGER LINE LENGTH = 70 %OWNINTEGER COMMENT TAB = 40 %OWNINTEGER LEVEL = 1, MLIMIT = 0, SEC MARGIN = 3 %OWNBYTEINTEGER COMMENT FLAG %OWNBYTEINTEGER CMODE, LOOP FLAG %OWNINTEGER LINESIZE, CS, DISP, D, RMARGIN, FIRST DISP %OWNINTEGER SIZE, CSTART, LINE BASE, FULL LINE %EXTERNALROUTINESPEC PROMPT(%STRING (63) S) %EXTERNALROUTINESPEC DEFINE(%STRING (63) S) %EXTERNALROUTINESPEC SEND(%STRING (63) S) %EXTERNALROUTINESPEC LIST(%STRING (63) S) %EXTERNALROUTINESPEC DESTROY(%STRING (63) S) %EXTERNALROUTINESPEC RENAME(%STRING (63) S) %INTEGERFNSPEC PARSE(%INTEGER EP) %OWNSTRING (255) INPUT, OUTPUT, OPTION FILE, ST, OPLIST %OWNINTEGER SPT, SAD, S %OWNBYTEINTEGER SPACES, MODE %OWNBYTEINTEGER OK, THIS SEP %CONSTINTEGER LAST TEXT = 51 %OWNINTEGER HEADER, SEGS %OWNINTEGERARRAY STRINGS(-100 : -1) %OWNINTEGER COMMENT LENGTH %OWNSHORTINTEGERARRAY REM(1 : 4) %OWNBYTEINTEGERARRAY SYMFILE(0 : 300) %OWNBYTEINTEGERARRAY TLENGTH(-100 : -1) %OWNINTEGERARRAY REC(1 : 100) %OWNBYTEINTEGER STATUS, OPTIONS, LAST SEP, FLAG, PMODE %OWNBYTEINTEGER QUOTES = 0, OWNFLAG = ';' %OWNINTEGER NVAL %REGISTER CURRIN(14) %OWNINTEGER CURROUT, SLENGTH, LIMIT, MARGIN, INBASE, STATSIZE %OWNINTEGER STAT, KEYBASE, TEXTBASE, J, SN, RP, RPLIM, RPINC %OWNINTEGER MAXMARGIN, ENDOFFILE %CONSTINTEGER CCC = X'2025430A' %CONSTINTEGER CONNEKTEP = 1 %CONSTINTEGER CREATEEP = 162 %CONSTINTEGER READEP = 7 %CONSTINTEGER INFOEP = 5 %CONSTINTEGER CHANGEEP = 6 %ROUTINESPEC SET UP FILES(%STRINGNAME S) %ROUTINESPEC CLOSE FILES %ROUTINESPEC SET OPTIONS %DYNAMICROUTINESPEC CHERISH(%STRING(63) S) %ROUTINE FDP(%INTEGER EP,%STRING(17) NAME,%INTEGER P1,P2,%C %INTEGERNAME FLAG) %SYSTEMROUTINESPEC AGENCY(%INTEGER P1,P2) *OI_4(13),5 AGENCY(1,ADDR(EP)) %END %ROUTINE CONTINUE %SHORTROUTINE %ROUTINESPEC ADJUST %INTEGERARRAY HOLD(1 : 4) %INTEGER J, K, L, M, N, Z, LIM, XES %BYTEINTEGERARRAYFORMAT NFM(1 : 4) %BYTEINTEGERARRAYNAME NEST %BYTEINTEGER S, CFLAG NEST == ARRAY(ADDR(NVAL),NFM) THIS SEP = NL; LIM = MARGIN+SAFETY FACTOR+SEC MARGIN Z = SLENGTH+CURROUT %RETURN %IF Z < LIMIT %OR (Z-SAFETY FACTOR-LIMIT < -4 %C %AND REC(RP+1) = 0) ! LEAVE TWO SPACES FOR ' %' IF NESC. XES = Z-LIMIT; ! EXCESS LINE LENGTH %CYCLE J = 1,1,4; HOLD(J) = NEST(J)+CURROUT-LINE BASE %REPEAT %IF LAST SEP = ';' %THEN %START N = CURROUT; QUOTES = 0 %UNTIL S = ';' %AND QUOTES = 0 %CYCLE N = N-1; S = BYTEINTEGER(N) QUOTES = QUOTES!!1 %IF S = '''' %REPEAT BYTEINTEGER(N) = NL; LIMIT = N+LINELENGTH LINE BASE = N K = CURROUT+80; M = K %CYCLE L = N+3,1,CURROUT K = K+1; BYTEINTEGER(K) = BYTEINTEGER(L) %REPEAT %CYCLE L = 1,1,MARGIN N = N+1; BYTEINTEGER(N) = ' ' %REPEAT %CYCLE L = M+1,1,K N = N+1; BYTEINTEGER(N) = BYTEINTEGER(L) %REPEAT CURROUT = N LAST SEP = NL ADJUST %RETURN %IF CURROUT+SLENGTH < LIMIT %FINISH NEST(3) = 0 %IF NEST(4) # 0 %AND REC(REM(4)-1) >= 4 CFLAG = 0 %CYCLE J = 1,1,4 N = NEST(J) %IF N > LIM %START N = N+LINE BASE CFLAG = 1 %AND %EXIT %IF N < CURROUT %FINISH %REPEAT %IF CFLAG # 0 %START %IF NEST(J)-MARGIN-SEC MARGIN-SAFETY FACTOR < XES %START K = J %WHILE K < 4 %CYCLE K = K+1 CFLAG = 0 %AND %EXIT %IF NEST(K) # 0 %REPEAT %IF CFLAG = 0 %START L = NEST(K)+LINE BASE J = K %AND N = L %C %IF NEST(K) > LIM %AND L < CURROUT %FINISH %FINISH J = 3 %AND N = NEST(3)+LINE BASE %C %IF J = 4 %AND REM(3) = REM(4)-1 LIM = NEST(J)+SAFETY FACTOR+SEC MARGIN K = CURROUT+80; M = K %CYCLE L = N+1,1,CURROUT K = K+1; BYTEINTEGER(K) = BYTEINTEGER(L) %REPEAT *L_1,N *MVC_1(4,1),CCC *LA_1,4(1) *ST_1,CURROUT *ST_1,LINEBASE %CYCLE J = 1,1,MARGIN+SEC MARGIN CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = ' ' %REPEAT M = M+1 %IF BYTEINTEGER(M+1) = ' ' %IF BYTEINTEGER(M+1) # '%' %START CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = '%' %FINISH %CYCLE L = M+1,1,K CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = BYTEINTEGER(L) %REPEAT !?? ADJUST %FINISH %ELSE %START LIM = CURROUT-LINEBASE+SAFETY FACTOR *L_1,CURROUT *MVC_1(4,1),CCC *LA_1,4(1) *ST_1,CURROUT *ST_1,LINE BASE %CYCLE J = 1,1,MARGIN+SEC MARGIN CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = ' ' %REPEAT PMODE = 128; ! NO LONGER IN RANGE OF '%' %FINISH LIMIT = LINEBASE+LINE LENGTH STATSIZE = STATSIZE-LINELENGTH+MARGIN RPLIM = RPLIM+RPINC %IF STATSIZE+MARGIN >= LINE LENGTH NVAL = 0 %ROUTINE ADJUST %CYCLE J = 1,1,4 %IF NEST(J) <= LIM %THEN NEST(J) = 0 %C %ELSE NEST(J) = HOLD(J)-CURROUT+LINE BASE %REPEAT %END %END %ROUTINE BREAK %SHORTROUTINE CURROUT = CURROUT-2 %UNLESS BYTEINTEGER(CURROUT) = ';' BYTEINTEGER(CURROUT) = NL SIZE = 0; LINE BASE = CURROUT LIMIT = LINE BASE+LINE SIZE NVAL = 0 %END %EXTERNALROUTINE SOAP(%STRING (128) FILES) %SHORTROUTINE %OWNINTEGER MOVEX = X'D2002001', MOVEY = X'10010000' %ROUTINESPEC PERCENT %ROUTINESPEC SPACE %INTEGERNAME MID MARGIN %INTEGER N, P, K, M, Z %BYTEINTEGERARRAYFORMAT NFM(1 : 4) %BYTEINTEGERARRAYNAME NEST %PRINTTEXT 'SOAP'; PRINTCH(7); NEWLINE NEST == ARRAY(ADDR(NVAL),NFM) SET UP FILES(FILES); %RETURN %IF OK = 0 SET OPTIONS; %RETURN %IF OK = 0 MID MARGIN == MARGIN MID MARGIN == RMARGIN %IF COMMENTS RELATIVE = 0 !* 32 16 8 4 2 1 !* STATUS: SPECIAL COMMENT : COMMENT : OWN : END : DOWN : UP TOP: ! HEAD OF MAIN LOOP %CYCLE NVAL = 0 LOOP FLAG = 0 RP = 0; SPT = 0; MODE = 0; STATUS = 0 SAD = TEXTBASE LIMIT = CURROUT+LINELENGTH %IF LAST SEP # ';' INBASE = CURRIN %IF PARSE(0) # 0 %THEN %START ! SYNTAX ?? OWNS: J = CURRIN; QUOTES = 0; K = 0 %UNTIL (S = NL %OR S = ';') %AND (QUOTES = 0 %C %OR K > 300) %CYCLE K = K+1 J = J+1; S = BYTEINTEGER(J) QUOTES = QUOTES!!1 %IF S = '''' %REPEAT SLENGTH = J-CURRIN %IF CURROUT+SLENGTH > LIMIT %AND LAST SEP = ';' %C %THEN %START BREAK STAT = CURROUT+MARGIN %CYCLE J = 1,1,MARGIN CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = ' ' %REPEAT %FINISH %IF OWNFLAG = 0 %THEN %START OWNFLAG = ';' %IF CURROUT+SLENGTH+SAFETY FACTOR > LIMIT %C %THEN %START *L_1,CURROUT *MVC_1(4,1),CCC; ! PUSH IN CONTINUATION *LA_1,4(1) *ST_1,CURROUT *ST_1,LINE BASE %FINISH %FINISH %CYCLE J = 1,1,SLENGTH CURRIN = CURRIN+1; CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = BYTEINTEGER(CURRIN) %REPEAT LAST SEP = BYTEINTEGER(CURRIN) %IF LAST SEP = ';' %THEN %START BYTEINTEGER(CURROUT+1) = ' ' BYTEINTEGER(CURROUT+2) = ' ' CURROUT = CURROUT+2 %FINISH %ELSE LINE BASE = CURROUT %FINISH %ELSE %START PMODE = 128 STATSIZE = CURRIN-INBASE %IF STATSIZE+MARGIN > LINE LENGTH %START RPINC = RP//(STATSIZE//(LINE LENGTH-MARGIN)) RPLIM = RPINC %FINISH %ELSE RPLIM = RP %IF STATUS&11 # 0 %AND LAST SEP = ';' %THEN %START LAST SEP = NL BREAK %FINISH %IF STATUS&136 # 0 %THEN %START ! BLANK LINE OR BLOCK %IF (LEAVE BLANKS # 0 %AND THIS SEP # ';') %C %OR (STATUS&128 # 0 %AND SEP BLOCKS # 0) %C %THEN %START NULL: CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = NL LINE BASE = CURROUT %FINISH -> TOP %IF STATUS&8 # 0 %AND RP <= 1 ! IN CASE OF LONELY LABELS %FINISH RP = 0 %IF LOOP FLAG # 0 %AND STATUS&1 # 0 %C %AND BYTEINTEGER(CURROUT-1) # NL %START CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = NL LINE BASE = CURROUT LIMIT = LIMIT+1 %FINISH %IF STATUS&2 # 0 %THEN %START ! DOWN STATUS = STATUS!64 %C %IF EXTRA MARGIN # 0 %AND STATUS&4 # 0 LEVEL = LEVEL>>1 LEVEL = 1 %IF LEVEL = 0 MARGIN = MARGIN-DELTA MARGIN %IF MLIMIT&1 = 0 MLIMIT = MLIMIT>>1 MARGIN = 0 %IF MARGIN < 0 %FINISH STAT = CURROUT+MARGIN %IF LAST SEP # ';' %WHILE REC(RP+1) = 100 %CYCLE ! DEAL WITH LABELS RP = RP+1 %IF LAST SEP = ';' %OR LAST SEP = ':' %THEN %START N = -2; N = 1 %IF LAST SEP = ':' CURROUT = CURROUT+N; BYTEINTEGER(CURROUT) = NL LINE BASE = CURROUT LIMIT = CURROUT+LINELENGTH STAT = CURROUT+MARGIN LAST SEP = NL %FINISH %IF LABELS RELATIVE # 0 %AND LAST SEP # ':' %C %THEN %START N = LEVEL; M = MARGIN M = M+FIRST DISP %C %IF EXTRA MARGIN # 0 %AND LEVEL = 1 %CYCLE M = M-DELTA MARGIN %EXIT %IF N&1 # 0 N = N>>1 %REPEAT %WHILE M > 0 %CYCLE M = M-1 CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = ' ' %REPEAT %FINISH %CYCLE RP = RP+1; N = REC(RP); %EXIT %IF N = 0 %IF N < 0 %THEN SN = STRINGS(N) %C %ELSE SN = KEYWORD(N)+KEYBASE %CYCLE J = SN+1,1,SN+BYTEINTEGER(SN) CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = BYTEINTEGER(J) %REPEAT %REPEAT %IF CURROUT > STAT %AND STATUS&16 = 0 %THEN %START CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = NL LINE BASE = CURROUT LIMIT = CURROUT+LINELENGTH STAT = CURROUT+MARGIN %FINISH LAST SEP = ':' %REPEAT RP = 0 %AND -> NULL %IF STATUS&8 # 0 ! NOW DEAL WITH COMMENTS %IF STATUS&16 # 0 %THEN %START RP = RP+1; DISP = REC(RP) ! STARTING DISP OF INPUT ! COMMENT D = 0; CMODE = 0 J = CURRIN; ! FIND THE END OF THE COMMENT J = J+1 %WHILE BYTEINTEGER(J) # NL %C %AND BYTEINTEGER(J) # ';' CS = J-CURRIN; ! COMMENT SIZE %IF COMMENT FLAG = 0 %C %THEN CSTART = COMMENT TAB %ELSE %START %IF COMMENTS NORMAL # 0 %START CMODE = 1; CSTART = MARGIN %FINISH %ELSE %START %IF LAST SEP = ';' %C %THEN CSTART = COMMENT TAB %ELSE %START %IF DISP = 0 %THEN CSTART = 0 %ELSE %START %IF DISP <= MID MARGIN %C %AND STATUS&32 = 0 %C %THEN CSTART = MARGIN %C %ELSE CSTART = COMMENT TAB %FINISH %FINISH %FINISH %FINISH CSTART = 0 %IF STATUS&32 # 0 %AND LEAVE STARS # 0 SIZE = CURROUT-LINE BASE %IF LAST SEP = ';' %START %IF BYTEINTEGER(CURROUT) = NL %START ! COMMENT AFTER REPEAT+NL LOOP FLAG = 1 LINE BASE = LINE BASE-1 %C %UNTIL BYTEINTEGER(LINE BASE) = NL SIZE = CURROUT-LINE BASE %FINISH CURROUT = CURROUT-2; SIZE = SIZE-2 ! TO REMOVE SPACES AFTER SEMI'S %IF EXTEND COMMENTS # 0 %AND CSTART < SIZE %START P = CSTART; ! REMEMBER IT JUST IN CASE N = EXT NUM; ! NUMBER OF EXTENSION TRIES %CYCLE %EXIT %IF N <= 0 CSTART = CSTART+COMMENT EXTENSION %EXIT %IF CSTART >= SIZE N = N-1 %REPEAT CSTART = P %IF N <= 0 %C %OR CS+CSTART > COMMENT LINE ! RESTORE IT IF TOO LONG %FINISH %IF CSTART < SIZE %START %IF CMODE # 0 %THEN CSTART = 0 %ELSE BREAK %FINISH %ELSE %START D = COMMENT LINE-CSTART-CS %IF D < 0 %AND BREAK COMMENTS = 0 %START CSTART = LINE SIZE-CS BREAK D = 0 %FINISH %FINISH %FINISH %ELSE %START D = COMMENT LINE-CSTART-CS %IF D < 0 %AND BREAKCOMMENTS = 0 %THEN %START CSTART = COMMENT LINE-CS D = 0 %FINISH %FINISH %CYCLE N = CSTART-SIZE %WHILE N > 0 %CYCLE N = N-1; CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = ' ' %REPEAT CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = '!' CURROUT = CURROUT+1 %C %AND BYTEINTEGER(CURROUT) = '*' %C %IF STATUS&32 # 0 P = J %IF D < 0 %START P = J+D P = P-1 %WHILE BYTEINTEGER(P) # ' ' %C %AND BYTEINTEGER(P) # ',' %C %AND BYTEINTEGER(P) # '.' %AND P > CURRIN P = P-1 P = J+D %IF P = CURRIN %FINISH %CYCLE K = CURRIN+1,1,P CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = BYTEINTEGER(K) %REPEAT CURRIN = P %EXIT %IF D >= 0 CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = NL SIZE = 0; D = LINE LENGTH-MARGIN+D %REPEAT BYTEINTEGER(CURROUT) = NL %IF LOOP FLAG # 0 %START LOOP FLAG = 0 CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = NL %FINISH SIZE = 0; LINE BASE = CURROUT; LAST SEP = NL ! END OF COMMENT HANDLING %FINISH %ELSE %START N = 0 %IF STATUS&64 # 0 %START N = DELTA MARGIN N = MARGIN %IF EXTRA MARGIN # 0 %FINISH STAT = STAT-N CURROUT = CURROUT+1 %C %AND BYTEINTEGER(CURROUT) = ' ' %C %WHILE CURROUT < STAT LIMIT = CURROUT+LINELENGTH-MARGIN+N %C %IF LAST SEP # ';' %CYCLE RP = RP+1; N = REC(RP); %EXIT %IF N = 0 %IF N > 0 %THEN %START SN = KEYWORD(N)+KEYBASE FLAG = KFLAGS(N) Z = SFLAGS(N) SLENGTH = BYTEINTEGER(SN) %FINISH %ELSE %START SN = STRINGS(N) FLAG = 0; Z = 0 SLENGTH = TLENGTH(N) %FINISH %IF RP >= RPLIM %C %OR (SLENGTH+CURROUT > LIMIT %C %AND N <= LAST TEXT) %THEN CONTINUE %IF Z # 0 %START NEST(Z) = CURROUT-LINE BASE REM(Z) = RP %FINISH SPACE %IF FLAG&OPTIONS&15 # 0 %C %OR (PMODE!!FLAG)&128 = 0 PERCENT %IF FLAG&PMODE # 0 !* %CYCLE J=SN+1, 1, SN+BYTEINTEGER(SN) !* CURROUT=CURROUT+1 !* BYTEINTEGER(CURROUT)=BYTEINTEGER(J) !* %REPEAT *L_1,SN *L_2,CURROUT *SLR_3,3 *IC_3,0(1) *EX_3,MOVEX *AR_2,3 *ST_2,CURROUT SPACE %IF FLAG&OPTIONS&120 # 0 PMODE = 128 %UNLESS 0 < N <= LAST TEXT %REPEAT -> OWNS %IF OWNFLAG = 0 CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = THIS SEP LAST SEP = THIS SEP %IF LOOP FLAG # 0 %AND STATUS&2 # 0 %START CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = NL %FINISH %IF STATUS&1 # 0 %THEN %START ! UP LEVEL = LEVEL<<1 LEVEL = LEVEL!1 %IF STATUS&128 # 0 MLIMIT = MLIMIT<<1 MLIMIT = MLIMIT!1 %C %IF MARGIN >= MAX MARGIN %OR ( %C INDENT BLOCKS = 0 %AND STATUS&128 # 0) %IF MARGIN = 0 %AND EXTRA MARGIN # 0 %C %THEN MARGIN = INITIAL MARGIN %ELSE %START MARGIN = MARGIN+DELTA MARGIN %IF MLIMIT&1 = 0 %FINISH %FINISH %IF LAST SEP = ';' %THEN %START BYTEINTEGER(CURROUT+1) = ' ' CURROUT = CURROUT+2 BYTEINTEGER(CURROUT) = ' ' %FINISH %ELSE LINE BASE = CURROUT %EXIT %IF CURRIN >= ENDOFFILE %OR STATUS&7 = 7 %FINISH %FINISH %REPEAT CLOSE FILES %RETURN %ROUTINE SPACE %IF ' ' # BYTEINTEGER(CURROUT) # NL %C %AND BYTEINTEGER(CURROUT) # '(' %THEN %START CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = ' ' PMODE = 128 %FINISH %END %ROUTINE PERCENT %IF PMODE # 0 %THEN %START %IF ' ' # BYTEINTEGER(CURROUT) # NL %C %AND BYTEINTEGER(CURROUT) # '(' %THEN %START CURROUT = CURROUT+1; BYTEINTEGER(CURROUT) = ' ' %FINISH CURROUT = CURROUT+1 BYTEINTEGER(CURROUT) = '%' PMODE = 0 %FINISH %END %END %ROUTINE CONNEKT(%STRING (17) FILE, %INTEGERNAME MODE, FLAG) %INTEGER J J = 0 FDP(CONNEKTEP,FILE,MODE,ADDR(J),FLAG) MODE = J FLAG = 0 %IF FLAG = 5 %END %INTEGERFN PARSE(%INTEGER ENTRY) %SHORTROUTINE %INTEGER SS, SP, TRP, TPT, L %BYTEINTEGER MODES %INTEGERFN PUT SPT = SPT-1 RP = RP+1 REC(RP) = SPT TLENGTH(SPT) = SLENGTH STRINGS(SPT) = SAD STRING(SAD) = ST SAD = SAD+1+BYTEINTEGER(ADDR(ST)) %RESULT = SPT %END %ROUTINE SYM %CYCLE CURRIN = CURRIN+1; S = BYTEINTEGER(CURRIN) MODE = 0 %UNLESS 'A' <= S <= 'Z' %IF S = '%' %THEN MODE = 32 %ELSE %START %IF S # ' ' %THEN %START S = S+MODE %RETURN %IF S # 'C'+32 %C %OR BYTEINTEGER(CURRIN+1) # NL CURRIN = CURRIN+1 MODE = 0 %FINISH SPACES = PACK NAMES %FINISH %REPEAT %END %INTEGERFN CONSTANT %INTEGER T, LIM %INTEGER CS SLENGTH = 0 ST = '' SYM CS = CURRIN %AND ST = ST.TOSTRING(S) %AND SYM %C %WHILE '0' <= S <= '9' %OR S = '.' %OR S = '@' CURRIN = CS %AND %RESULT = PUT %IF ST # '' %IF S = 'M' %OR S = 'X' %OR S = 'B' %THEN %START ST = TOSTRING(S) T = CURRIN SYM CURRIN = T %AND %RESULT = 0 %IF S # '''' %FINISH LIM = CURRIN+255 %WHILE S = '''' %CYCLE %UNTIL S = '''' %OR CURRIN > LIM %CYCLE SLENGTH = BYTEINTEGER(ADDR(ST)) %C %IF S = NL %AND SLENGTH = 0 ST = ST.TOSTRING(S) CURRIN = CURRIN+1 S = BYTEINTEGER(CURRIN) %REPEAT ST = ST.'''' CS = CURRIN SYM %REPEAT SLENGTH = BYTEINTEGER(ADDR(ST)) %IF SLENGTH = 0 CURRIN = CS %AND %RESULT = PUT %IF ST # '' %RESULT = 0 %END %INTEGERFN NAME %INTEGER Z SYM %RESULT = 0 %UNLESS 'A' <= S <= 'Z' ST = '' %CYCLE SPACES = 1 ST = ST.TOSTRING(S) Z = CURRIN SYM SLENGTH = BYTEINTEGER(ADDR(ST)) %AND CURRIN = Z %C %AND %RESULT = PUT %C %UNLESS 'A' <= S <= 'Z' %OR '0' <= S <= '9' ST = ST.' ' %IF SPACES = 0 %REPEAT %END %SWITCH BIP(0 : 15) ! TRP = RP TPT = CURRIN MODES = MODE FAILURE: RP = TRP CURRIN = TPT MODE = MODES ENTRY = ENTRY+1 SP = MAIN(ENTRY) %RESULT = 1 %IF SP = 0 SUCCESS: SP = SP+1 SS = SUB(SP) %RESULT = 0 %IF S S = 0 -> BIP(SS>>12&15) BIP(1): ! SUB-PHRASE -> SUCCESS %IF PARSE(SS&X'FFF') = 0 -> FAILURE BIP(0): ! LITERAL SS = SS&X'FFF' L = LITERAL(SS); ! LENGTH %CYCLE SS = SS+1,1,SS+L SYM -> FAILURE %UNLESS S = LITERAL(SS) %REPEAT -> SUCCESS BIP(15): ! (NAME) -> SUCCESS %IF NAME # 0 -> FAILURE BIP(3): ! CONSTANT -> SUCCESS %IF CONSTANT # 0 -> FAILURE BIP(4): ! (*LOOP) LOOP FLAG = 1 %IF ISOLATE LOOPS # 0 -> SUCCESS BIP(5): ! (UP) STATUS = STATUS!1; -> SUCCESS BIP(6): ! (DOWN) STATUS = STATUS!2; -> SUCCESS BIP(7): ! (END) STATUS = STATUS!4; -> SUCCESS BIP(8): ! (OWN) -> FAILURE %IF LEAVE OWNS # 0 %C %AND BYTEINTEGER(CURRIN) # '*' ! MACHINE CODE OWN FLAG = 0 RP = RP+1; REC(RP) = 0 ! TO FIDDLE THE END OF STAT. THIS SEP = NL -> SUCCESS BIP(10): ! (SPECIAL COMMENT) INBASE = INBASE+1; ! TO SET DISP PROPERLY STATUS = STATUS!32 BIP(9): ! (COMMENT) STATUS = STATUS!16 RP = RP+1; REC(RP) = CURRIN-INBASE-1 -> SUCCESS BIP(11): ! (*DEC) STATUS = STATUS!64 %IF DECS RELATIVE # 0; -> SUCCESS BIP(12): ! (*BLOCK) STATUS = STATUS!64 %IF EXTRA MARGIN # 0 STATUS = STATUS!128; -> SUCCESS BIP(13): ! (*NULL) STATUS = STATUS!8; -> SUCCESS BIP(14): ! (S) SYM -> FAILURE %UNLESS S = NL %OR S = ';' THIS SEP = S THISSEP = NL %IF SPLIT STATS # 0 RP = RP+1 REC(RP) = 0 -> SUCCESS BIP(2): ! <> RP = RP+1 REC(RP) = SS&X'FFF' -> SUCCESS %END %ROUTINE CREATE(%STRING (8) FILE, %INTEGERNAME SIZE, FLAG) FDP(CREATEEP,FILE,SIZE,0,FLAG) SIZE = 3 %IF FLAG = 0 %OR FLAG = 3 %THEN CONNEKT(FILE,SIZE,FLAG) %END %ROUTINE COMPRESS(%STRING (8) FILE) %INTEGER P, F, S, W, X, Y, Z FDP(READEP,FILE,0,ADDR(P),F) %IF F # 0 %THEN %RETURN FDP(INFOEP,FILE,ADDR(W),0,F) S = INTEGER(P); ! SIZE OF FILE S = (S+4095)>>12 FDP(CHANGEEP,FILE,S-X,ADDR(S),F) %END %ROUTINE SET UP FILES(%STRINGNAME S) %SHORTROUTINE %INTEGER FLAG, SIZE OK = 0 INPUT = '' OUTPUT = '' OPTION FILE = '' INPUT = S %UNLESS S -> INPUT.('/').OUTPUT OPTION FILE = '' %UNLESS INPUT -> INPUT.(',').OPTION FILE OUTPUT = INPUT %IF OUTPUT = '' SIZE = 0 FDP(7, INPUT, 0, ADDR(SIZE), FLAG) CURRIN = SIZE %IF FLAG # 0 %THEN %START PRINTSTRING('CANNOT CONNECT '.INPUT); WRITE(FLAG,1) NEWLINE %RETURN %FINISH %IF INTEGER(CURRIN+12) # 0 %THEN %START PRINTSTRING(INPUT.' IS NOT A SOURCE FILE ') %RETURN %FINISH SIZE = INTEGER(CURRIN) %IF SIZE < 10 %THEN %START PRINTSTRING(INPUT.' IS A NULL FILE ') %RETURN %FINISH ENDOFFILE = CURRIN+SIZE ENDOFFILE = ENDOFFILE-1 %WHILE BYTEINTEGER(ENDOFFILE) # NL CURROUT = ((SIZE*6)+4095)>>12;! I HOPE IT'S BIG ENOUGH SEGS = (CURROUT+15)>>4 CREATE('SP#WORK',CURROUT,FLAG) %IF FLAG # 0 %THEN %START %PRINTTEXT 'CANNOT CREATE WORK FILE'; WRITE(FLAG,1) NEWLINE %RETURN %FINISH HEADER = CURROUT CURROUT = CURROUT+16 BYTEINTEGER(CURROUT) = NL CURRIN = CURRIN+15 INTEGER(HEADER) = 1<<16; ! JUST FOR TESTING INTEGER(HEADER+4) = 16 INTEGER(HEADER+8) = SEGS INTEGER(HEADER+12) = 0 OK = 1 %END %ROUTINE CLOSE FILES %ROUTINE NEWGENS %RECORDFORMAT RFM(%INTEGER X, Y, Z, REPLY) %RECORDFORMAT NFM( %C %SHORTINTEGER DSNO, DACT, SSNO, SACT, X1, X2, FLAG, %C %STRING (8) OLD FILE, NEW FILE, %LONGREAL DUMMY) %RECORD P(NFM) %RECORDNAME R(RFM) %INTEGER FLAG FDP(2,'SP#WORK',0,0,FLAG); ! DISCON. WORK FILE R == P; ! FOR REPLIES %CYCLE P = 0; ! CLEAR THE RECORD P_DSNO = 164 P_OLD FILE = 'SP#WORK'; ! OLF FILE NAME P_NEW FILE = OUTPUT; ! NEW FILE NAME ! SVC(P); ! CALL THE SERVICE **1,@P;! ADDRESS OF P TO R1 *LD_0,0(1) *LD_2,8(1) *LD_4,16(1) *LD_6,24(1) *SVC_254 **1,@P *STD_0,0(1) *STD_2,8(1) *STD_4,16(1) *STD_6,24(1) ! %EXIT %UNLESS R_REPLY = 6 %AND FLAG = 0; ! FILE2 STILL CONNECTED FDP(2,OUTPUT,0,0,FLAG) FLAG = 1 %REPEAT %IF R_REPLY = 5 %START; ! FILE2 DOES NOT EXIST R_REPLY = 0 RENAME('SP#WORK,'.OUTPUT) %FINISH %IF R_REPLY # 0 %START PRINTSTRING('RENAME SP#WORK FAILS ') WRITE(R_REPLY,1) NEWLINE %FINISH %ELSE CHERISH(OUTPUT); ! CHERISH OUTPUT FILE FDP(2,INPUT,0,0,FLAG); ! DISCONNECT INPUT FILE %END BYTEINTEGER(CURROUT) = NL INTEGER(HEADER) = CURROUT-HEADER+1 INTEGER(HEADER+4) = 16 INTEGER(HEADER+8) = SEGS INTEGER(HEADER+12) = 0 %IF CHARNO(OUTPUT,1) = '.' %THEN %START %IF OUTPUT = '.TT' %THEN %START LIST('SP#WORK,.TT') DESTROY('SP#WORK') %FINISH %ELSE SEND('SP#WORK,'.OUTPUT) %FINISH %ELSE %START COMPRESS('SP#WORK') NEWGENS %FINISH PRINTCH(7); NEWLINE %END %ROUTINE SET OPTIONS %SHORTROUTINE %STRING (255) S, T %INTEGER J %BYTEINTEGER OPT FLAG %BYTEINTEGERARRAYFORMAT FM(1 : 31) %BYTEINTEGERARRAYNAME WORD %ROUTINE LINE(%STRINGNAME S) %INTEGER J %RETURN %IF OPT FLAG = 0 S = '' %UNTIL S # '' %CYCLE %CYCLE READSYMBOL(J) %UNTIL J # ' ' %EXIT %IF J = NL S = S.TOSTRING(J) %REPEAT %REPEAT %END %ROUTINE SET(%STRINGNAME S) %STRING (255) N, OPT %INTEGER V, K, C, NUM %BYTEINTEGER NOT %CONSTSTRING (2) %ARRAY PARAM(1 : 31) = %C 'IB', 'LB', 'SB', 'TB', 'SK', 'PN', 'SS', 'CN', 'BC', 'LS','JA', 'LR', 'SC', 'DR', 'SL', 'SE', 'IL', 'EM', 'LO', 'CR', 'EC', 'MI', 'LL', 'CT', 'ML', 'CE', 'XN', 'IM', 'SM', 'CL', 'LC' %OWNINTEGER PARAMS = 31, BOOLS = 21 OPT = S NOT = 1; NUM = 0 %IF S -> S.('=').N %THEN %START NUM = -1; V = 0; J = ADDR(N) %CYCLE J = J+1,1,J+LENGTH(N) C = BYTEINTEGER(J)-'0' %UNLESS 0 <= C <= 9 %THEN %START PRINTSTRING(N.' ? ') %RETURN %FINISH V = V*10+C %REPEAT %IF V > 255 %THEN %START PRINTSTRING(N.' ? ') %RETURN %FINISH %FINISH NOT = 0 %IF NUM = 0 %AND S -> ('\').S %CYCLE J = 1,1,PARAMS %IF PARAM(J) = S %THEN %START %IF (BOOLS-J)!!NUM < 0 %THEN %START PRINTSTRING(S.'= ? ') %RETURN %FINISH K = NOT; K = V %IF NUM < 0 WORD(J) = K OPLIST = OPLIST.' '.OPT %RETURN %FINISH %REPEAT PRINTSTRING(S.' ? ') %END OPLIST = ' !! OPTIONS:' WORD == ARRAY(ADDR(ISOLATE BRACKETS),FM) OK = 1 %IF OPTIONFILE # '' %THEN %START OK = 0 OPT FLAG = 0 %IF OPTIONFILE -> ('[').S %THEN %START OPT FLAG = 0 %IF S -> S.(']') S = S.',*' %FINISH %ELSE %START OPT FLAG = 1 PROMPT('OPTIONS:') DEFINE('ST76,'.OPTION FILE) SELECTINPUT(76) %FINISH %CYCLE LINE(S) SET(T) %WHILE S -> T.(',').S %EXIT %IF S = '*' SET(S) %REPEAT %IF CHARNO(OUTPUT,1) = '.' %START ! SHOW OPTIONS STRING(CURROUT) = OPLIST.' ' BYTEINTEGER(CURROUT) = NL CURROUT = CURROUT+LENGTH(OPLIST)+2 %FINISH %FINISH DELTA MARGIN = MI LINE LENGTH = LL COMMENT TAB = CT MAXMARGIN = ML SEC MARGIN = SECONDARY MARGIN %UNLESS 40 < LINELENGTH < 133 %THEN %START %PRINTTEXT 'INVALID LINE LENGTH ' %RETURN %FINISH %UNLESS 0 < COMMENT TAB < LINE LENGTH-20 %THEN %START %PRINTTEXT 'INVALID COMMENT MARGIN ' %RETURN %FINISH %UNLESS MAX MARGIN < LINE LENGTH-20 %THEN %START %PRINTTEXT 'INVALID MAX MARGIN ' %RETURN %FINISH %UNLESS DELTA MARGIN <= MAX MARGIN<<1 %START %PRINTTEXT 'INVALID MARGIN INCREMENT ' %RETURN %FINISH %IF SEC MARGIN > DELTA MARGIN<<1+SAFETY FACTOR %START %PRINTTEXT 'INVALID SECONDARY MARGIN ' %RETURN %FINISH %IF INITIAL MARGIN > 30 %THEN %START %PRINTTEXT 'INVALID INITIAL MARGIN ' %RETURN %FINISH MARGIN = 1 %IF DELTA MARGIN = 0 %AND SEC MARGIN = 0 %C %AND INITIAL MARGIN = 0 MARGIN = INITIAL MARGIN %IF EXTRA MARGIN # 0 SPLIT CONDS = 1 %IF SPLIT KEYWORDS # 0 COMMENT LENGTH = LINE LENGTH-COMMENT TAB TEXTBASE = ADDR(SYMFILE(0)) KEYBASE = ADDR(KEYSYMS(1)) RMARGIN = COMMENT LIMIT FULL LINE = LINE LENGTH LINE LENGTH = LINE LENGTH-SAFETY FACTOR OPTIONS = 17*SPLIT KEYWORDS+34*SPLIT CONDS+SPACE LISTS<<6 %C +ISOLATE BRACKETS<<2+SPACE EQUALS<<3+128 LINE BASE = CURROUT; SIZE = 0 COMMENT FLAG = JUSTIFY ALL<<1!COMMENTSNORMAL COMMENT FLAG = COMMENT FLAG!!B'010' FIRST DISP = DELTA MARGIN-INITIAL MARGIN COMMENT LINE = FULL LINE %IF COMMENT LINE = 0 OK = 1 %END %ENDOFFILE @@@@@@@@@@@@@@@ %EXTERNALROUTINESPEC PROTECT(%STRING (63) S) %EXTERNALROUTINESPEC CHERISH(%STRING (63) S) %EXTERNALROUTINESPEC DEFINE(%STRING (63) S) %EXTERNALROUTINE FAULTS(%STRING (63) FILE) %ROUTINE READ LINE(%STRINGNAME L) %INTEGER S L = '' READCH(S) %IF S = 25 %START PRINTCH(7); NEWLINE *LM_4,15,16(8) *BCR_15,15 %FINISH %CYCLE L = L.TOSTRING(S) %RETURN %IF S = NL READCH(S) %REPEAT %END %STRING (255) L1, L2 FILE = 'SS#LIST' %IF FILE = '' DEFINE('ST01,'.FILE) SELECTINPUT(1) READ LINE(L1) %CYCLE READ LINE(L2) %IF CHARNO(L2,1) = '*' %START PRINTSTRING(L1) %CYCLE PRINTSTRING(L2) READ LINE(L2) %EXIT %UNLESS CHARNO(L2,1) = '*' %REPEAT %FINISH L1 = L2 %REPEAT %END %EXTERNALROUTINE C(%STRING (255) FILE) %DYNAMICROUTINESPEC PARM(%STRING (63) S) %DYNAMICROUTINESPEC IMPS(%STRING (63) S) %SYSTEMINTEGERMAPSPEC COMREG(%INTEGER N) %STRING (63) SOURCE, OBJECT, LISTING, PARMS, TEMP %IF FILE -> FILE.(':').PARMS %START PRINTSTRING('PARM('.PARMS.') ') PARM(PARMS) %FINISH PARMS = '' %IF CHARNO(FILE,LENGTH(FILE)) = 'S' %C %THEN FILE = FROMSTRING(FILE,1,LENGTH(FILE)-1) %C %AND PARMS = 'S' %IF (FILE -> LISTING.('.').TEMP %AND LENGTH(TEMP) > 7) %C %OR LENGTH(FILE) > 7 %START PRINTSTRING('NAME TOO LONG: '.TEMP.' ') %RETURN %FINISH SOURCE = FILE.PARMS OBJECT = FILE.'Y' LISTING = FILE.'L' FILE = SOURCE.','.OBJECT.','.LISTING PRINTSTRING('IMPS('.FILE.') ') IMPS(FILE) %IF COMREG(24) # 0 %THEN FAULTS(LISTING) %C %ELSE CHERISH(SOURCE) %AND PROTECT(OBJECT) %END %EXTERNALROUTINE PAGE(%STRING (63) FILE) %INTEGER LINES, S DEFINE('ST01,'.FILE) DEFINE('ST02,.LP,500') SELECTINPUT(1); SELECTOUTPUT(2) S = 0 %CYCLE NEWPAGE %UNLESS S = 12 NEWLINE %CYCLE LINES = 1,1,60 %UNTIL S = 10 %OR S = 12 %CYCLE READCH(S) %IF S = 25 %START SELECTOUTPUT(0); SELECTINPUT(0) PRINTSTRING(FILE.' PAGINATED ') %RETURN %FINISH PRINTCH(S) %REPEAT %EXIT %IF S = 12 %REPEAT %REPEAT %END %INTEGERFN STOI(%STRING (15) SYM) %INTEGER J, S, N %RESULT = 0 %IF LENGTH(SYM) = 0 N = 0 %CYCLE J = 1,1,LENGTH(SYM) S = CHARNO(SYM,J) %IF S > '9' %THEN S = S-'A'+10 %ELSE S = S-'0' N = N*16+S %REPEAT %RESULT = N %END %SYSTEMROUTINE CDUMP(%STRING (63) FILES) %SYSTEMROUTINESPEC IIDUMP(%INTEGER J, K) %SYSTEMROUTINESPEC LPDUMP(%INTEGER J, K) %STRING (63) START, FINISH, FILE %INTEGER ST, FN FILE = '' %IF FILES -> FILES.('/').FILE %START DEFINE('ST01,'.FILE) SELECTOUTPUT(1) %FINISH %UNLESS FILES -> START.(',').FINISH %START PRINTSTRING('PARAM: '.FILES.' ? ') %RETURN %FINISH ST = STOI(START) FN = STOI(FINISH)+ST %IF FILE = '.LP' %START SET MARGINS(1,1,132) LPDUMP(ST,FN) %FINISH %ELSE IIDUMP(ST,FN) %END %SYSTEMROUTINE CODE(%STRING (63) FILES) %STRING (15) START, LENGTH, FILE %INTEGER ST, LEN %SYSTEMROUTINESPEC DECODE(%INTEGER J, K, L) %IF FILES -> FILES.('/').FILE %START DEFINE('ST02,'.FILE) SELECTOUTPUT(2) %FINISH %UNLESS FILES -> START.(',').LENGTH %START PRINTSTRING('PARAM: '.FILES.' ? ') %RETURN %FINISH ST = STOI(START) LEN = STOI(LENGTH) DECODE(ST,ST+LEN,ST) %END %ENDOFFILE @@@@@@@@@@@@@@@ ! !************************************************** !* * !* VARIOUS EXTERNAL ROUTINES FOR IMPI * !* * !*************************************************** ! %TRUSTEDPROGRAM %EXTERNALINTEGER MON REP = 0; ! REPETITION COUNTER FOR RESUMES %EXTERNALBYTEINTEGER MONLOCK %EXTRINSICINTEGER MONFRAME, MONINFO, BRKR9AD %OWNSHORTINTEGER TRAP BLOCK, TRAP LINE ! %EXTERNALROUTINE EXTINIT *MVI_4(13),X'55'; ! FLAG FOR MDIAG %END %EXTERNALROUTINE HEX(%INTEGER N) %SHORTROUTINE %CONSTBYTEINTEGERARRAY XSYM(0 : 15) = %C '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' %INTEGER J, S %CYCLE J = 1,1,8 S = N>>28 N = N<<4 PRINTSYMBOL(XSYM(S)) %REPEAT %END %CONSTBYTEINTEGERARRAY TRT(0 : 255) = %C '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', ' ', '!', 34, '#', '$', '%', '&','''', '(', ')', '*', '+', ',', '-', '.', '/', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', ':', ';', '<', '=', '>', '?', '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '\', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_', '_' %ROUTINE PHSYMBOLS(%INTEGER AD) %STRING (18) TEXT **1,@TEXT; *L_2,AD *MVC_2(16,1),0(2) *L_2,TRT *TR_2(16,1),0(2) *MVI_0(1),18 *MVI_1(1),'*' *MVI_18(1),'*' *->P5 %END %SYSTEMROUTINE IIDUMP(%INTEGER FROM, TO) %SHORTROUTINE %INTEGER N, M, D, LINES %BYTEINTEGER STOP %ROUTINESPEC HEAD LINES = 30 STOP = 0; ! TO STOP FROM HEAD M = (FROM&15)>>2 FROM = FROM&(\15); TO = (TO+15)&(\15) *LA_1,1(13); *ST_1,D HEAD FROM = FROM+M<<2 N = M SPACES(M*10) %WHILE FROM < TO %THEN %CYCLE %IF N = 4 %START HEAD %RETURN %IF STOP # 0 %FINISH N = N+1 %PRINTTEXT ' '; HEX(INTEGER(FROM)) FROM = FROM+4 %REPEAT NEWLINE %RETURN %ROUTINE HEAD %INTEGER NN LINES = LINES-1 LINES = 30 %AND NEWLINES(2) %IF LINES <= 0 %PRINTTEXT ' ' *SLR_0,0; ! DUPLICATE LINE COUNTER *L_1,D; *L_2,FROM 1: *CLC_0(16,1),0(2); *BC_7,<2> *LA_2,16(2) *C_2,TO; *BC_2,; ! END REACHED *BCT_0,<1> S: *MVI_STOP,255; ! SET STOP FLAG 2: *ST_0,NN *LTR_0,0 *BC_8,<3> *ST_2,FROM %PRINTTEXT 'NEXT' %IF NN = -1 %THEN %PRINTTEXT ' LINE' %ELSE %START WRITE(-NN,1) %PRINTTEXT ' LINES' %FINISH %PRINTTEXT ' THE SAME ' 3: %RETURN %IF STOP # 0 PHSYMBOLS(FROM) D = FROM %PRINTTEXT ' ('; HEX(FROM); %PRINTTEXT ') ' N = 0 %END %END %ROUTINE PSYMBOLS(%INTEGER AD) %STRING (34) TEXT **1,@TEXT; *L_2,AD *MVC_2(32,1),0(2) *L_2,TRT *TR_2(32,1),0(2) *MVI_0(1),34 *MVI_1(1),'*' *MVI_34(1),'*' *->P5 %END %SYSTEMROUTINE LPDUMP(%INTEGER FROM, TO) %SHORTROUTINE %INTEGER N, M, D, LINES %BYTEINTEGER STOP %ROUTINESPEC HEAD LINES = 60 STOP = 0; ! STOP FLAG FROM HEAD M = (FROM&15)>>2 FROM = FROM&(\15); TO = (TO+15)&(\15) *LA_1,1(13); *ST_1,D HEAD FROM = FROM+M<<2 N = M SPACES(M*10) %WHILE FROM < TO %CYCLE %PRINTTEXT ' ' %IF N = 4 HEAD %IF N = 8 N = N+1 %PRINTTEXT ' '; HEX(INTEGER(FROM)) FROM = FROM+4 %REPEAT NEWLINE %RETURN %ROUTINE HEAD %INTEGER NN LINES = LINES-1 LINES = 60 %AND NEWPAGE %IF LINES <= 0 %PRINTTEXT ' ' *SLR_0,0; ! DUPLICATE LINE COUNTER *L_1,D; *L_2,FROM 1: *CLC_0(32,1),0(2); *BC_7,<2> *LA_2,32(2) *C_2,TO; *BC_2,; ! END REACHED *BCT_0,<1> S: *MVI_STOP,255 2: *ST_0,NN *LTR_0,0 *BC_8,<3> *ST_2,FROM %PRINTTEXT 'NEXT' %IF NN = -1 %THEN %PRINTTEXT ' LINE' %ELSE %START WRITE(-NN,1) %PRINTTEXT ' LINES' %FINISH %PRINTTEXT ' THE SAME ' 3: %RETURN %IF STOP # 0 PSYMBOLS(FROM) D = FROM %PRINTTEXT ' ('; HEX(FROM); %PRINTTEXT ') ' N = 0 %END %END %SYSTEMROUTINE ITRAP(%INTEGER B, L) %SHORTROUTINE %IF 0 # TRAPLINE # L %START %PRINTTEXT 'LINE' WRITE(TRAPLINE,1) %PRINTTEXT ' RELEASED ' %FINISH TRAP BLOCK = B TRAP LINE = L %END ! %SYSTEMROUTINE UNTRAP TRAP BLOCK = 0 TRAP LINE = 0 %END ! %SYSTEMROUTINE IMPMON %INTEGER GLA %INTEGER R8, FLAG *L_1,52(8); ! CALLING GLA *CLC_22(2,1),TRAP LINE; ! COMPARE LINE NUMBER *BC_7,; ! DIFFERENT *LH_2,TRAP BLOCK; ! BLOCK NUMBER WANTED *LTR_2,2 *BC_8,; ! ZERO MEANS ANY BLOCK *CH_2,20(1); ! LOOK AT GLA WORD *BC_7,; ! DIFFERENT ANY: %RETURN %IF MON LOCK # 0; ! CALLED RECURSIVELY MONREP = MONREP-1 %AND %RETURN %IF MONREP > 0 *ST_1,GLA MONINFO = GLA MONLOCK = 1 *ST_8,R8 MONFRAME = R8 FLAG = BRKR9AD *L_1,FLAG *LA_11,4000(11); ! PROTECT STACK *ST_11,8(1) *LM_9,14,0(1) *BCR_15,14; ! CALL THE INTERPRETER AS A !CO-ROUTINE BACK: %END %SYSTEMROUTINE DECODE(%INTEGER S, TO, BASE) %SHORTROUTINE %CONSTINTEGERARRAY OPCODES(0 : 255) = %C 0(4), M'SPM ',M'BALR',M'BCTR',M'BCR ',M'SSK ',M'ISK ',M'SVC ', 0(5), M'LPR ', M'LNR ',M'LTR ',M'LCR ',M'NR ',M'CLR ',M'OR ',M'XR ',M'LR ', M'CR ', M'AR ',M'SR ',M'MR ',M'DR ',M'ALR ',M'SLR ',M'LPDR',M'LNDR', M'LTDR', M'LCDR',M'HDR ',M'LRDR',M'MXR ',M'MXDR',M'LDR ',M'CDR ',M'ADR ',M'SDR ', M'MDR ', M'DDR ',M'AWR ',M'SWR ',M'LPER',M'LNER',M'LTER',M'LCER',M'HER ',M'LRER', M'AXR ', M'SXR ',M'LER ',M'CER ',M'AER ',M'SER ',M'MER ',M'DER ',M'AUR ',M'SUR ', M'STH ', M'LA ',M'STC ',M'IC ',M'EX ',M'BAL ',M'BCT ',M'BC ',M'LH ',M'CH ', M'AH ', M'SH ',M'MH ', 0, M'CVD ', M'CVB ',M'ST ', 0(3),M'N ',M'CL ',M'O ', M'X ', M'L ',M'C ',M'A ',M'S ',M'M ',M'D ',M'AL ',M'SL ',M'STD ', 0(6), M'MXD ', M'LD ',M'CD ',M'AD ',M'SD ',M'MD ',M'DD ',M'AW ',M'SW ', M'STE ', 0(7), M'LE ', M'CE ',M'AE ',M'SE ',M'ME ',M'DE ',M'AU ',M'SU ', M'SSM', 0,M'LPSW',M'DIAG',M'WRD ',M'RDD ',M'BXH ',M'BXLE',M'SRL ',M'SLL ', M'SRA ', M'SLA ',M'SRDL',M'SLDL',M'SRDA',M'SLDA',M'STM ',M'TM ',M'MVI ', M'TS ', M'NI ',M'CLI ',M'OI ',M'XI ',M'LM ', 0(3), M'SIO ', M'TIO ',M'HIO ', M'TCH ', 0(49), M'MVN ', M'MVC ',M'MVZ ',M'NC ',M'CLC ',M'OC ',M'XC ', 0(4), M'TR ', M'TRT ',M'ED ',M'EDMK', 0(17),M'MVO ',M'PACK',M'UNPK', 0(4), M'ZAP ', M'CP ',M'AP ',M'SP ',M'MP ',M'DP ', 0, 0 %INTEGER J, K, L, M %INTEGER T %ROUTINESPEC HEX(%INTEGER N) %ROUTINESPEC PUT(%INTEGER S, C) S = S&(\1) 1: NEWLINE NEWLINE %AND %RETURN %IF S >= TO HEX(S-BASE) SPACES(4) J = SHORTINTEGER(S); S = S+2 M = J>>8&255 T = OPCODES(M) HEX(J) -> 1 %IF T = 0 %IF M>>6 = 0 %THEN %START; ! RR PUT(12,T) WRITE(J>>4&15,4) %PRINTTEXT ',' WRITE(J&15,2) -> 1 %FINISH K = SHORTINTEGER(S); S = S+2 HEX(K) %IF M>>6 = 1 %THEN %START; ! RX PUT(8,T) WRITE(J>>4&15,4); %PRINTTEXT ',' WRITE(K&X'FFF',4); %PRINTTEXT '(' WRITE(J&15,2); %PRINTTEXT ',' 3: WRITE(K>>12&15,2); %PRINTTEXT ')' -> 1 %FINISH %IF M&X'F8' = X'88' %THEN %START PUT(8,T) WRITE(J>>4&15,4); %PRINTTEXT ',' 2: WRITE(K&X'FFF',4); %PRINTTEXT '(' -> 3 %FINISH %IF M > 192 %THEN %START L = SHORTINTEGER(S); S = S+2 HEX(L) PUT(4,T) WRITE(K&X'FFF',5); %PRINTTEXT '(' %IF M>>4&15 # 15 %THEN WRITE(J&255+1,2) %C %ELSE WRITE(J>>4&15,2) %PRINTTEXT ',' WRITE(K>>12&15,2); %PRINTTEXT ')'; %PRINTTEXT ',' WRITE(L&X'FFF',4); %PRINTTEXT '(' %IF M>>4&15 = 15 %THEN %START WRITE(J&15,2); %PRINTTEXT ',' %FINISH WRITE(L>>12&15,2); %PRINTTEXT ')' -> 1 %FINISH %IF M = 134 %OR M = 135 %OR M = 144 %OR M = 152 %THEN %START PUT(8,T) WRITE(J>>4&15,4); %PRINTTEXT ',' WRITE(J&15,2); %PRINTTEXT ',' -> 2 %FINISH PUT(8,T) WRITE(K&X'FFF',5); %PRINTTEXT '(' WRITE(K>>12&15,2); %PRINTTEXT ')' %PRINTTEXT ',' WRITE(J&255,2) -> 1 %ROUTINE HEX(%INTEGER N) %CONSTINTEGER S1 = M'0123', S2 = M'4567', S3 = M'89AB', S4 = M'CDEF' %INTEGER W1, W2, W3 %OWNINTEGER MASK = X'0F0F0F0F', M2 = X'0F0F0F0F' *UNPK_W1+1(9),N(5) *NC_W1+1(8),MASK *TR_W1+1(8),S1 *LA_1,W1+4 *MVI_0(1),4 *->P5 %END %ROUTINE PUT(%INTEGER SP, SYMS) SPACES(SP) SP = 4 PRINTSTRING(STRING(ADDR(SP)+3)) %END %END ! %SYSTEMINTEGERFN RTINFO(%INTEGER X, %ROUTINENAME R) *L_1,X+4; ! @ OF ENTRY VECTOR FOR R *L_2,X *BCTR_2,0 *SLL_2,2 !*4 *L_1,0(1,2) %RETURN %END %ENDOFFILE @@@@@@@@@@@@@@@ %CONTROL 0 ! !VAGRANCY AIDS FOR USERS MK.1 !J.C.A. 17:05:74 ! %EXTERNALROUTINE VAGRANCY(%STRING(63) S) ! !TAKES A FILE OF TRACE INFO FROM BUGGED COMPILER OR INTERPRETER !GIVES SUMMARY OF RESULTS IN FILE !GIVES PAGE TURNS & CPU USED IN EACH CALL OF A ROUTINE !PLUS RATIOS OF PAGEFAULTS V CPU TIME ! %EXTERNALROUTINESPEC DEFINE(%STRING(63) S) %EXTERNALROUTINESPEC SET MARGINS(%INTEGER STREAM,LHM,RHM) ! %RECORDFORMAT HOLDE(%INTEGER CPU,PTURN,%SHORTINTEGER ENTRY,EXIT) %INTEGER FILE,DATAPTR,ENDPTR,F %INTEGER RTWAS,CPUIS,CPUWAS,PTURNIS,PTURNWAS %INTEGER RTIS %RECORDARRAY HOLD(0:127)(HOLDE) %OWNSTRING(8) RESULT='.TT' %CONSTINTEGER FLTCH=2 ;!CHARGE IN CPU MILLISECS FOR PAGE FAU %CONSTINTEGER SVCCH=2 ! ! %ROUTINE FDP(%INTEGER EP,%STRING(17) NAME,%INTEGER P1,P2,%C %INTEGERNAME FLAG) %RECORDFORMAT AGFM(%INTEGER EP,%STRING(17) NAME,%INTEGER P1,P2,%C %INTEGERNAME FLAG) %SYSTEMROUTINESPEC AGENCY(%INTEGER P1,%RECORDNAME P) %RECORD P(AGFM) *OI_4(13),5 **1,@P *LA_2,EP *MVC_0(36,1),0(2);! MOVE IN PARMS AGENCY(1,P) %END %INTEGERFN OLDFILE(%STRING(17) FILE,%INTEGER MODE,SIZE) %SHORTROUTINE !CONNECTS FILE AND CHECKS SUCESS !RETURNS START ADDRESS OF FILE %INTEGER FLAG,PTR PTR=ADDR(SIZE) FDP(1,FILE,MODE,PTR,FLAG) %IF FLAG=0 %OR FLAG=5 %THEN %RESULT=SIZE PRINTSTRING('CONNECT FAIL '.FILE) WRITE(FLAG,6) NEWLINES(2) %RESULT=-1 ;!FAIL RESULT %END ;!FN OLDFILE %ROUTINE HEADING !PRINTS HEADING FOR RESULTS ! PRINTSTRING('*** ANTI-VAGRANCY AIDS FOR USERS MK.1 *** ') PRINTSTRING('*** PAGEFAULTS AND CPUTIME(MILLISECS)') PRINTSTRING(' PER ROUTINE CALL *** ') PRINTSTRING('*** PAGEFAULT CHARGE(2 CPU MILLISECS)') PRINTSTRING(' REMOVED FROM CPU TIME *** ') NEWLINE PRINTSTRING('ROUTINE CALL EXIT CPUTOT') PRINTSTRING(' PTTOT CPUAV PTRNAV PTURN/SEC') NEWLINE %END ;!RT HEADING ! %ROUTINE GATHER !GATHERS INFO ON CPU & PAGEFAULTS USED IN CALL ON RT'S !IF TOP BIT OF RECORD SET - A CALL ON A RT ! - RECURSIVE CALL ON GATHER TO DEAL WITH LOWER !IF TOP BIT OF RECORD CLEAR - AN EXIT FROM A RT ! - RETURN FROM THIS LEVEL OF GATHER ! %INTEGER RT ! %ROUTINE IS TO WAS !COPY CURRENT INTO PAST VALUES RTWAS=RTIS CPUWAS=CPUIS PTURNWAS=PTURNIS DATAPTR=DATAPTR+8 ;!TO NEXT RECORD %END ;!RT ISTOWAS ! %ROUTINE UPDATE(%INTEGER RT) !UPDATE INFO ON THIS RT HOLD(RT)_CPU=HOLD(RT)_CPU+(CPUIS-CPUWAS) HOLD(RT)_PTURN=HOLD(RT)_PTURN+(PTURNIS-PTURNWAS) %END ;!RT UPDATE ! !MAIN RT BODY ! 1: %IF DATAPTR>ENDPTR %THEN %RETURN ;!END OF DATA CPUIS=INTEGER(DATAPTR)&X'7FFFFFFF' ;!CPU SO FAR PTURNIS=INTEGER(DATAPTR+4)&X'00FFFFFF' ;!PAGE FLTS SO FAR RTIS=BYTEINTEGER(DATAPTR+4)&127 ;!ROUTINE NUMBER !ENTRY OR EXIT ? %IF BYTEINTEGER(DATAPTR)&X'80'=0 %THEN ->EXIT ;!EXIT! !ENTRY HOLD(RTIS)_ENTRY=HOLD(RTIS)_ENTRY+1 UPDATE(RTWAS) ;!UPDATE DATE FOR SUPERIOR RT RT=RTWAS ;!REMEMEBER SUPERIOR RT ISTOWAS GATHER ;!DEAL WITH LOWER LEVELS ! RTWAS=RT ;!BACK AT THIS LEVEL RESTORE SUPERIOR RT ->1 ;!DEAL WITH NEXT RECORD !EXIT EXIT: HOLD(RTIS)_EXIT=HOLD(RTIS)_EXIT+1 UPDATE(RTIS) ISTOWAS %RETURN ;!GO BACK UP A LEVEL ! %END ;!RT GATHER ! %ROUTINE PRLINE(%INTEGER F) !DUMPS A LINE OF SUMMARY INFO FOR ONE RT %INTEGER J %RECORDNAME H(HOLDE) %CONSTINTEGER WRP=7 %CONSTINTEGER MARG=10 ! J=FILE+9*F+16 ;!ADDR OF RT NAME PRINTSTRING(STRING(J)) SPACES(MARG-LENGTH(STRING(J))) H == HOLD(F) WRITE(H_ENTRY,WRP-2) WRITE(H_EXIT,WRP-2) WRITE(H_CPU,WRP) WRITE(H_PTURN,WRP) PRINT(H_CPU/H_ENTRY,WRP-3,3) PRINT(H_PTURN/H_ENTRY,WRP-3,3) %IF H_CPU#0 %THEN PRINT(H_PTURN*1000/H_CPU,WRP,0) %C %ELSE PRINTSTRING(' ZERO CPU') NEWLINE %END ;!RT PRLINE ! !GET FILE ! FILE=OLDFILE('II#DATA',3,0) %IF FILE=-1 %THEN %STOP DATAPTR=INTEGER(FILE+12)+FILE ENDPTR=INTEGER(FILE)+FILE RESULT<-S %UNLESS S='' ;!RESULTFILE DEFINE('STREAM09,'.RESULT) SELECTOUTPUT(9) SETMARGINS(9,1,132) ! %CYCLE F=0,1,127 HOLD(F)_CPU=0 HOLD(F)_PTURN=0 HOLD(F)_ENTRY=0 HOLD(F)_EXIT=0 %REPEAT ! ! !GET FIRST VALUES ! CPUWAS=INTEGER(DATAPTR)&X'7FFFFFFF' PTURNWAS=INTEGER(DATAPTR+4)&X'00FFFFFF' RTWAS=BYTEINTEGER(DATAPTR+4)&127 ! !COLLECT DATA ! GATHER !REMOVE CHARGE FOR PAGEFAULTS %CYCLE F=0,1,127 %IF HOLD(F)_ENTRY#0 %THEN%START HOLD(F)_CPU=HOLD(F)_CPU-HOLD(F)_PTURN*FLTCH !REMOVE CHARGE FOR SVC HOLD(F)_CPU=HOLD(F)_CPU-(HOLD(F)_ENTRY+HOLD(F)_EXIT)*SVCCH %IF HOLD(F)_CPU<0 %THEN HOLD(F)_CPU=0 %FINISH %REPEAT ! !NOW DROP RESULTS ! HEADING %CYCLE F=0,1,127 %IF HOLD(F)_ENTRY#0 %THEN PRLINE(F) %REPEAT ! %END ;!RT VAGRANCY ! %ENDOFFILE @@@@@@@@@@@@@@@ * PHRASE STRUCTURE DEFINITION FOR IMP INTERPRETER B[S] = 15 B[NAME] = 14 B[C LIST] = 12 B[FAIL] = 11 B[C TEXT] = 10 B[STRING] = 9 B[NAMELIST] = 8 B[MARK] = 7 B[HOLE] = 6 B[CONSTANT] = 5 B[NUMBER] = 4 B[MC] = 2 B[INTEGER] = 3 P(SS) [HOLE](UI)[MARK](R SS1)[S]: (IU)(COND)(THEN')(R IU)[S]: (WUF)(THEN')(R WU)[S]: '%CYCLE'(CPARM')[S]: '%REPEAT'[S]: '%FINISH'(ELSE')[S]: (TYPE)(DECLN)[S]: '%END'(OF')[S]: '%BEGIN'[S]: (EXTERNAL')(RFM)(SPEC')[NAME](FPDEFN')[S]: '%COMPILE'[NAME][S]: (COMMENT)[C TEXT]: '%SPEC'[NAME](FPDEFN')[S]: '%START'[S]: '%LIST'[S]: '$RESTART'[S]: '%EDIT'[NAME][S]: '%SENDTO'[NAME][S]: '%RECORD'(REC DEC)[S]: '%CONTROL'[INTEGER][S]: '%SWITCH'[NAMELIST](CBPAIR)(R SW LIST')[S]: [NUMBER]':'(SS): '$'(SPECIAL)[S]: '%REAL' '%S'(LN)[S]: [NAME](SW PARM')':'(SS): (OWN)(TYPE)(OWN DEC)[S]: '%EXTRINSIC' '%RECORD'(XRDEC)[S]: '%SHORT' '%ROUTINE'[S]: '#'(EXPRN)(R # LIST')[S]: '.'[HOLE](VAR)[MARK](R UI')(A UI')[S]: '*'(MC INST)[S]: [S]; P(R # LIST') ','(EXPRN)(R # LIST'):; P(XRDEC) [HOLE](DECLN)[MARK]'(' [NAME] ')': '(' [NAME] ')' (R R DEC2); P(OWN) '%EXTRINSIC':'%OWN':'%CONST':'%EXTERNAL'; P(O PLUS') '+':'-':; P(OWN DEC) '%ARRAY'[NAME](CBPAIR)[C LIST]: [NAMELIST](INIT')(R S OWN'); P(INIT') '='(O PLUS')[CONSTANT]:; P(R S OWN') ','[NAMELIST](INIT')(R S OWN'):; P(CPARM') (F CLAUSE):; P(F CLAUSE) (VAR)'='[HOLE](EXPRN)','[MARK](EXPRN)','(EXPRN); P(WUF) (WU)(COND): '%FOR'(F CLAUSE); P(THEN') '%THEN':; P(COMMENT) '!':'%COMMENT'; P(LN) '%LONG':'%NORMAL'; P(=EXPRN) '='(VAR): (EXPRN); P(UI) [HOLE](VAR)[MARK](R UI')(AUI'): '%PRINTTEXT'[STRING](AUI'): '->'(LABEL): '%RETURN': '%RESULT='(=EXPRN): '%MONITOR'(MON'): '%STOP': '%EXIT': '%CONTINUE': '%TRUE': '%FALSE'; P(AUI') '%AND'(UI):; P(R UI') (ASSOP)(EXPRN):; P(ASSOP) '==' : '=' : '<-' : '->' ; P(MON') '%STOP': [INTEGER] :; P(R SS1) (IUWU)(COND):'%FOR'(F CLAUSE):; P(IUWU) '%IF' : '%UNLESS' : '%WHILE' : '%UNTIL' ; P(WU) '%WHILE' : '%UNTIL' ; P(IU) '%IF' : '%UNLESS' ; P(OF') '%OF' '%LIST': '%OF' '%PROGRAM'(ME'): '%OF' '%FILE': '%OF' '%INT':; P(ME') '%ME':; P(ENAME') '_'(VAR):; P(ENAME'') '_'[NAME]:; P(VAR) [NAME](APP')(ENAME'); P(APP') '(' (EXPRN)(R APP') ')':; P(R APP') ','(EXPRN)(R APP'):; P(EXPRN) (PLUS')[HOLE](OPERAND)[MARK](REST OF EXPRN'):[FAIL]; P(REST OF EXPRN') (OPERATOR)[HOLE](OPERAND)[MARK](REST OF EXPRN'):; P(OPERAND) [CONSTANT]: (VAR): '(' (EXPRN) ')': '!' (EXPRN) '!'; P(PLUS') '+' : '-' : '\' :; P(OPERATOR) '+': '-': '&': '!!': '!': '<<': '>>': '**': '*': '//': '/': '.'; P(NOT') '%NOT':; P(COND) [HOLE](NOT')(S COND)[MARK](R COND'); P(R COND') '%AND'[HOLE](NOT')(S COND)[MARK](R A COND'): '%OR' [HOLE](NOT')(S COND)[MARK](R O COND'):; P(R A COND') '%AND'[HOLE](NOT')(S COND)[MARK](R A COND'):; P(R O COND') '%OR'[HOLE](NOT')(S COND)[MARK](R O COND'):; P(RFM) '%ROUTINE':(TYPE)(FM):'%PREDICATE'; P(FM) '%FN':'%MAP'; P(S COND) [HOLE](EXPRN)[MARK](COMP)(EXPRN)(R S COND'): '(' (COND) ')': (VAR)(EE VAR'); P(EE VAR') '=='(VAR):; P(COMP) '=' : '#' : '<=' : '<' : '>=' : '>' : '\=' : '->' ; P(FILE NAME) '.'[NAME]: [NAME]; P(SPECIAL) 'EDIT'[NAME]: 'COMPILE'[NAME]: 'SEND'(TO')[NAME]: 'INFO'[NAME]:'CODE':'NAMES': 'DUMP':'MAP':'INPUT'(FILE NAME):'OUTPUT'(FILE NAME): 'SYNTAX':'NO' 'SYNTAX':'DELETE'[NAME]:'MLEVEL'(ML):'CANCEL': 'MONITOR': 'UP'(VALUE): 'DOWN'(VALUE): 'RESUME'(VALUE): 'TRAP' [INTEGER](BDEF'):'IGNORE': 'WHERE': 'LIST' [NAME](LP'): 'FIND'[NAME]':'[NUMBER]: 'FORCE':'SYSOUT':'CLEAR': 'LOOK'[NAME]: 'TRACE'(ON/OFF); P(TO') 'TO':; P(ON/OFF) 'ON': 'OFF'; P(LP') '/'(FILE NAME):; P(VALUE) [INTEGER]:; P(BDEF') ','[INTEGER]:; P(ML) '*':[INTEGER]; P(LABEL) [NUMBER]:[NAME](OP PARM'); P(OP PARM') '(' (EXPRN) ')' :; P(REC DEC) '%FORMAT'[NAME]'('(RFDEC)(REST OF RFDEC') ')': '%SPEC'[HOLE][NAME](ENAME'')'(' [MARK][NAME] ')': [HOLE](DECLN)'(' [MARK][NAME] ')' : '(' [NAME] ')' (R R DEC2); P(R R DEC2) '%SPEC'[NAME](ENAME''): (DECLN); P(DECLN) (%QNAME)[NAMELIST]: '%ARRAY'(FORMAT')(ADECLN); P(TYPE) '%INTEGER':'%BYTE' '%INTEGER':'%SHORT' '%INTEGER':'%REAL': '%LONG' '%REAL':'%STRING'(QUALIFIER'); P(SW PARM') '(' (PLUS')[INTEGER] ')':; P(QUALIFIER') '(' [INTEGER] ')' :; P(ADECLN) [NAMELIST]'('(BPLIST)')'(R A LIST'); P(R A LIST') ',' (ADECLN):; P(BPLIST) (EXPRN)':'(EXPRN)(R BPLIST'); P(R BPLIST') ','(EXPRN)':'(EXPRN)(R BPLIST'):; P(R IU) '%START':(UI)(ELSE'); P(R WU) '%CYCLE':(UI); P(ELSE') '%ELSE'(START' UI):; P(START' UI) '%START':(UI); P(EXTERNAL') '%EXTERNAL':'%SYSTEM':'%DYNAMIC':; P(SPEC') '%SPEC':; P(%QNAME) '%ARRAY' '%NAME':'%NAME':; P(FPDEFN') '('(FP-DEL)[NAMELIST](R FPDEFN')')':; P(FP-DEL) (RFM)(NAME'): (TYPE)(%QNAME): '%RECORD'(ARRAY')'%NAME': '%NAME'; P(R FPDEFN') (COMMA')(FP-DEL)[NAMELIST](R FPDEFN'):; P(ARRAY') '%ARRAY':; P(S R DEC) '%ARRAY'[NAMELIST](CBPAIR)(R SW LIST'): [NAMELIST]; P(COMMA') ',':; P(RFDEC) [FAIL]: (TYPE)(%QNAME)[NAMELIST]: '%RECORD'(ARRAY')'%NAME'[NAMELIST]: '%NAME'[NAMELIST]: (TYPE)'%ARRAY'[NAMELIST](CBPAIR)(R SW LIST'): '%RECORD'[HOLE](S R DEC) '(' [MARK][NAME] ')': '%RECORD' '(' [NAME] ')' (S R DEC); P(REST OF RFDEC') (COMMA')(RFDEC)(REST OF RFDEC'):; P(CBPAIR) '('(PLUS')[INTEGER]':'(PLUS')[INTEGER]')'; P(R SW LIST') ','[NAMELIST](CBPAIR)(R SW LIST'):; P(R S COND') (COMP)(EXPRN):; P(FORMAT') '%FORMAT':; P(NAME') '%NAME':; P(MC INST) [MC=0][INTEGER]','[INTEGER]: [MC=1][INTEGER]','(DXB): [MC=3][INTEGER]','[INTEGER]','(DB): [MC=5](DB)(VAL'): [MC=7][INTEGER]','(DB): [MC=9](DLB)','(DB): [MC=11](DLB)','(DLB): [MC=13][INTEGER]: 'PUT_'[INTEGER]: '*'[INTEGER]','(@')(VAR); P(@') '@':; P(VAL') ','[INTEGER]:; P(DB) (UCS): [INTEGER](REST OF DB'); P(REST OF DB') '('[INTEGER]')':; P(DXB) (UCS)(REST OF DB'): [INTEGER](REST OF DXB'); P(REST OF DXB') '('[INTEGER]','[INTEGER]')': '('[INTEGER]')':; P(DLB) [INTEGER]'('[INTEGER]','[INTEGER]')': (UCS)'('[INTEGER]')'; P(UCS) [NAME](DISPP'): '<'(LABEL)'>'; P(DISPP') '+'[INTEGER]: '-'[INTEGER]:; @ @@@@@@@@@@@@@@@ _________________ SOAP USER'S GUIDE SOAP is a routine which inputs IMP source programs and outputs them formatted according to predefined control options. It is assumed that the input source will compile under the standard IMP compilers. Statements which are found to be syntactically incorrect are output unchanged. 1 = = __________ USING SOAP Before using SOAP for the first time it is nescessary to connect the library in which it resides. This is done with the command: APPENDLIB(ECSC17.IMPILIB) Providing that this has been done, SOAP can be called with one of the following types of command: 1. SOAP(INPUT/OUTPUT) 2. SOAP(INPUT,OPTIONS/OUTPUT) 3. SOAP(INPUT) 4. SOAP(INPUT,OPTIONS) 1&3 specify that all default options are to be used. 2&4 specify changes to be made to the default options. 1&2 define a new output file. If this new file exists and is different from the input file, the output file is left alone and the output is in a temporary file 'SP#WORK'. This is indicated by the message: RENAME SP#WORK FAILS 3&4 specify that the output file is the same as the input file. NOTE: '.TT' ______ cannot be used for the input file. 2 = = ________________________ CHANGING DEFAULT OPTIONS In the examples of calling SOAP 'OPTIONS' can have two forms:- 1. The name of a file (including.'.tt') from which the list of options (terminated with *) is to be taken. 2. The list of options enclosed in square brackets. e.g. SOAP(FRED,.TT/JIM) SOAP(FRED,OPFILE/JIM) SOAP(FRED,[LL=120,CT=80]/JIM) Any options not mentioned retain their default values. The format of the option list is (term),(term), ......... ,(term),* where (term) = OPTION __ __ or \OPTION or OPTION=VALUE and any comma may be replaced with a newline. If the [....] form is used the final * may be omitted (NOTE that the command interpreter deletes newlines within commands !) ________ EXAMPLES EM enable extra margin \EM disable extra margin MI=4 set margin increment to 4 The default options are: \IB, \LB, SB, IB, \SK, \PN, \SS, \CN BC, LS, \JA, \LR, SC, DR, SL, SE, SL, EM \LO, CR, EC MI=3, LL=72, CT=40, ML=40, LC=100 CE=5, XN=2, IM=7, SM=3, CL=20 lc= value of LL 3 = = _________________ OPTIONS AVAILABLE _____________________________________________ OPTION DEFAULT DESCRIPTION IB \IB Isolate Brackets Spaces will be inserted before left brackets and after right brackets. LB \LB Leave Blank lines Blank lines in the input will be transfered to the output. SB SB Separate Blocks A newline will be inserted before BEGIN, ROUTINE, FN, MAP. IB IB Indent Blocks The start of a block will increase the margin by 'MARGIN INCREMENT' SK \SK Split Keywords All keywords will be split into their components e.g. %BYTE %INTEGER X PN \PN Pack Names Spaces will be removed from names. SS \SS Split Statements All separators will become newlines on output. CN \CN Comments Normal Comments will be treated as ordinary statements i.e. they will not be tabbed to the comment margin etc. BC BC Break Comments Comments will be broken into as many smaller comments as will be needed to aviod overflowing the output line. If this option is turned off, large comments will be right justified. LS LS Leave Stars Comments of the form !*...... will start at the beginning of a line. This is to preserve block comments exclosed in stars. 4 = = JA \JA Justify All comments All comments (excluding those controled by 'LS') will be indented to the comment tab. If this option is turned off, comments will be indented according to the following scheme: 1. The output comment will start at the beginning of the line if did the input comment. 2. If the input comment started after the current value of the comment limit (see 'CR') the output comment will be indented to the comment tab. 3. Otherwise the comment will be tabbed to the current margin setting. LR \LR Labels Relative Labels will be tabbed to the margin which was current when the enclosing block was encountered. If this option is disabled all labels are output at the start of a line. SC SC Split Conditions The keywords '%THEN' and '%ELSE' are separated from any ajoining keywords e.g. %FINISH %ELSE %START 'SC' is implied by 'SK' DR DR Declarations Relative Declarations will be tabbed to the margin of the enclosing block. SL SL Space Lists Spaces will be inserted after commas. SE SE Space Equals etc. Spaces will be inserted around '=', '==', '#', '<=' etc. IL IL Isolate Loops An extra newline will be inserted before '%CYCLE' and after '%REPEAT'. 5 = = EM EM Extra Margin This also implies '\TB' and 'DR' Each time the margin is increased from zero the increment will be 'IM' and thereafter 'MI' LO \LO Leave Owns Declarations of %OWN and %CONST arrays will be output exactly as found. If this option is turned off, the declaration will be formatted up to and including the '=' (if it exists) CR CR Comments Relative The comment limit (see 'JA') will echo the value of the current margin. Otherwise it will be set to 'CL' EC EC Extend Comments If a comment is the second or subsequent statement on the input line and the previous statements exceed the comment tab, this option will increase the comment tab (for this comment only) 'XN' times by 'CE' spaces in an attempt to make the comment fit on the current output line. If this process fails, or the option is disabled, the comment will be placed on a line of its own. MI= MI=3 Margin Increment The amount by which the margin will be altered. (see 'TB', 'DR' and 'EM') LL= LL=72 Line Length The length of the output line (see 'LC') CT= CT=40 Comment Tab The position to which comments will be tabbed (see 'JA' etc.). ML= ML=40 Margin Limit The margin will not be increased once it reaches this limit. 6 = = CE= CE=5 Comment Extension The amount by which 'EC' will extend the comment tab. XN= XN=2 eXtension Number The number of times 'EC' will apply 'CE'. IM= IM=7 Initial Margin The initial margin for 'EM'. SM= SM=3 Secondary Margin The extra margin added when a line is split by '%C'. CL= CL=20 Comment Limit The static limit for 'CR'. LC= LC=100 Line length for Comments A line length for comments which overrides 'LL'. _________________ PETER S ROBERTSON ____________________________ C/O DEPT OF COMPUTER SCIENCE 7 @@@@@@@@@@@@@@@ = = _____________________________ IMP8 INTERPRETER USER'S GUIDE The IMP8 INTERPRETER is an interactive IMP compiler with editing facilities, which runs under the EDINBURGH MULTI-ACCESS SYSTEM on the ICL 4/75. IMP statements are read in from the console, compiled, executed immediately, and then discarded. Compound statements and complete procedures are saved pending later execution. _______________________ CALLING THE INTERPRETER Before using the interpreter for the first time, it is necessary to connect the interpreter library. This is done by command: APPENDLIB(CONLIB.IMPILIB) Provided that this has been done, the interpreter can be called by the command: IMPI _____________________ USING THE INTERPRETER When it has been called, the interpreter identifies itself on the console and waits for input. The user may type an IMP statement (see facilities available). In general, the statement typed in is executed immediatly; in relation to questions of scope these statements are effectively executed at main program level (the initial %BEGIN is provided by the interpreter). The 'execution' of declarations introduces names and assigns storage for use in subsequent statements. Allocation and deallocation of storage follows the normal rules, which means that variables declared at the outermost (basic) level remain available throughout the session. However, if the statement typed is the first line of a compound statement (start/finish group or cycle/repeat group), or a procedure (routine, function or map), the interpreter enters storage mode. In this mode statements are not executed as they are typed in, but stored for subsequent use. The interpreter remains in storage mode until it has read the group terminating statement or procedure end statement. At this point the complete text is either executed and then discarded, (compound statement) or retained for use through the normal procedure calling mechanism (routine, function, map). The interpreter is terminated with the statement %ENDOFPROGRAM #CLOSE is output to show that the interpreter has stopped. 1 = = __________ INTERRUPTS The interpreter recognises three interrupts: INT:Q returns control to the interpreter from the running program, by forcing the run-time fault OPERATOR TERMINATION INT:H returns control to the interpreter from the running program _______ without giving diagnostics. INT:NO turns off listing by forcing %ENDOFLIST Other interrupts have the meanings assigned to them by the sub-system. _______ PROMPTS During the running of the interpreter, input is requested by the following types of prompt:- : the interpreter is expecting a command at main program level. C the last line ended with '%C'. ' the last line contained an unterminated string constant. n: this is statement number 'n' of the present block (storage mode). DATA: the running program requires data. This prompt may be changed by the _________ intrinsic routine PROMPT (see facilities available). E: the final %END of a procedure has been edited away, so subsequent text will be taken from the console. This text will be echoed if listing is enabled. 2 = = _______ EDITING Having typed in the text of a routine, function or map, the user may well realise, possibly after testing it, that it contains an error. Accordingly the interpreter provides facilities for editing any stored procedure. These facilities are provided by the __________ _______ ______ COMPATIBLE CONTEXT EDITOR (see separate documentation for a description of the command language). The editor is called by the statement:- $EDIT routine name When the editing operation is terminated (by %C) the new version of the procedure is compiled (see prompt 'E:'). If it contains any faults, the prompt EDIT NEW FILE ? is given. There are three valid replies: YES causes the editor to be recalled to edit the new version of the text (as if the previous '%C' used to close the editor had been 'M-0') NO causes the new version of the text to be destroyed and leaves the process in the same state as prior to the original '$EDIT' command which invoked the editor. LET causes the old version of the procedure to be destroyed and replaced by the new (______ faulty) version. (see FAULTS and ERROR REPORTS) When a version of the procedure has been produced which is found to have no faults (or LET has been specified), it replaces the old version, which is destroyed. During the compilation of the block, a line-numbered listing is produced on the console. The commands %LIST and %ENDOFLIST respectively enable and disable this listing (see INT:NO). NOTE: the first statement of any stored procedure must be a valid procedure head. e.g. %ROUTINE FRED If other statements are inserted in front of this head, or the head is made syntactically incorrect, the compilation will be abandoned with the prompt EDIT NEW FILE ? as above. If the whole of the file is deleted (eg. using K0) the procedure is destroyed. This is indicated by the message PROCEDURE name DELETED 3 = = ____________________ FACILITIES AVAILABLE The interpreter will accept the majority of statements accepted by the IMPS VERSION 8 compiler on EMAS. Statements not accepted include: 1. machine code instructions 2. fault trapping 3. %OWN records (coming shortly) 4. %EXTERNAL variables (these are treated as if the were %OWN variables) The interpreter is terminated by the statement %ENDOFPROGRAM %EXTERNAL and %SYSTEM routines are compiled as normal routines. Inside comments a semi-colon is not treated as a separator, i.e. it forms part of the comment text. As statements at basic level are thrown away after execution, labels and jump statements can have no meaning. Hence they are only allowed inside procedures. In addition the following non-standard facilities are provided: 1. %ROUTINE PROMPT(%STRING(15) S) is provided as an intrinsic routine. 2. the string function SNL equivalent to TOSTRING(NL) 3. DRAIN This intrinsic routine will remove any pending input. 4. %CONTINUE This statement is similar to %EXIT, but causes a jump to the %REPEAT of the enclosing %CYCLE/%REPEAT group. 5. %FOR This can be used to control a %CYCLE in a similar way to %CYCLE J=1,1,5 e.g. A(J) = 0 ___ FOR J=1, 1, 6 4 = = _________________________________ LIMITATIONS OF THE IMPLEMENTATION In order to ensure good response, the following restrictions have had to be imposed: 1. No more than 512 distinct names. 2. No more than 127 routines (including externals). 3. The total space allocated to basic level arrays, strings and records is limited to a maximum of about 48K bytes. This limit can be raised by specifying the number of extra segments (0 <= n <= 9) to be used for arrays and routines when the interpreter is called. e.g. IMPI(4) If the space allocated to routines (text+code) is filled FAULT 110 (BUFFER OVERFLOW) is given. 4. Streams 77, 78, 79 are reserved for use by the interpreter. 5 = = ______________________ INTERPRETER DIRECTIVES These are special commands used to control the operation of the interpreter. 1. $EDIT rtname see EDITING 2. $COMPILE filename will compile statements from the given file (which must be terminated by %ENDOFFILE). a block map will be produced on the console if listing is enabled. 3. $SENDTO filename outputs the text of all previously defined procedures and all basic level declarations to the given file. The routines are output in the order in which they were first presented to the interpreter. The statement %ENDOFFILE is added to the end of this file. 4. $RESTART will restart the interpreter from scratch without the need for returning to system command level and reloading. 5. $NOSYNTAX Listings of syntactically incorrect statements and descriptions of fault numbers are inhibited. 6. $SYNTAX The inverse of 1. 7. $DELETE name the specified named entity is destroyed and can therefore be redefined (useful for removing faulty external specs). This command should be used with care, as the space allocated to the name ______ cannot be reclaimed. 8. $MLEVEL N Limits to 'n' the number of routine levels which will be unwound as a result of an implicit/explicit %MONITOR. $MLEVEL * will reset full monitoring. 9. $CANCEL 6 = = This command closes off any outstanding textual blocks and returns to basic level without executing any of the code. e.g. %CYCLE J = 1,1,5 A(J) = 0 $ CANCEL It can also be used to abandon an external routine following a break (see PROGRAM MONITORING). 10.#EXPRESSION The value of the (integer, real or string) expression is output to the console (only valid at basic level). e.g. #J-K*17 A list of expressions may be given separated by commas. e.g. #J$3, FROMSTRING(S,1,7), $/3 7 = = 11..ROUTINE CALL The dot supplies an external spec for the routine, with either no parameters, or the single parameter (%STRING(63) S). The routine is then called, and remains available for calling through the normal mechanisms. If the statement is at basic level, the text of the %SPEC will be output with the other declarations following a %SEND %TO. e.g. .LIST('SS#LIST') FAULT 40 will be given if there are any other statements on the same line. 12.$LIST name A line-numbered listing of the named procedure will be output. This listing will be inhibited by %ENDOFLIST and hence an INT:NO will terminate the listing. The given name not corresponding to the name of a stored procedure will cause the message: * CANNOT LIST 'NAME' 13.$FIND name:nn will list the three lines nn-1, nn, and nn+1 of the routine 'name'. This is useful for discovering the statement identified by a monitor message. NOTE: that in order to find a line in a nested routine the name must correspond to that of the outermost routine. 8 = = __________________ PROGRAM MONITORING The Interpreter contains facilities for examining and modifying the scalar variables of IMP programs. These programs must first have been compiled under the IMPS compiler in diagnostic mode, and then called from the interpreter. To prepare the program (or file of external routines), each group of lines at which the user may wish to suspend to program must first be enclosed in the two statements: %CONTROL X'FFFFFF3F' & %CONTROL X'FFFFFF1F' After compilation, the program (or routines) may be called from outside the interpreter in the usual way. However, from inside the Interpreter, the user can specify that the program is to be suspended, and control is to be returned to the interpreter, when the execution reaches a predetermined line. When the program has been interrupted, the local scalar variables can be accessed via the built-in name 'MON', which may be thought of as a %RECORDNAME which has sub-names corresponding to the scalar variables local to the block being executed when the suspension occured. e.g. WRITE(MON_FRED, 3); MON_JIM = 'GREEN' NOTE: When the interpreter is called at the suspension of the program, routines can neither be defined nor edited. Also all furthur calls for suspension will be inhibited until the current suspension has been resolved. Any interrupt (e.g. OPERATOR TERMINATION) during a suspension, causes the program to be abandoned, and the interpreter is returned to basic level. 9 = = The commands available are: $TRAP nn Execution of the program is to be suspended when line 'nn' is reached ( ______ before it is executed !). If a previous trap has been set for a different line, the old trap is removed, producing the message: LINE nn RELEASED It is possible for the execution of a program to pass line 'nn' in more than one routine. For this reason, the TRAP can be qualified with the starting line number of the exclosing 'block'. e.g. $TRAP 74, 60 which means: trap the program at line 74 of the 'block' starting at line 60. When a trap is reached and control is passed to the interpreter, the point of the trap is indicated with the message: BREAK: LINE 74 OF R/F/M FRED STARTING AT LINE 60 for example. $IGNORE Any trap is removed, and so the program will not be suspended. $MONITOR The system monitor (MDIAG) will be called to monitor the state of the block in which execution was suspended. $RESUME Continue execution of the program. If no trap has been made this will have no effect other than producing the message: NOTHING TO RESUME $UP Change the apparent break point to the line from which the current block was entered. $DOWN Has the effect of nullifying the previous **UP command. There is a limit of 8 blocks for the scope of **UP & **DOWN, and any attempt to exceed this limit, or to move past the ends of the program's stack, will be ignored. 10 = = ______ FAULTS ____________ COMPILE TIME Syntax faults cause the faulty statement to be completely ignored. At basic level all faults cause the faulty statement to be completely ignored. At other levels the fault will inhibit the execution of a block and mark a procedure as being faulty. This is indicated by the message * ROUTINE FAULTY An attempt to call such a procedure (before the faults have been edited out) will result in the monitor being called with the run-time fault ROUTINE FAULTY ________ RUN TIME An execution error will cause the interpreter to give a diagnostic trace of the execution path leading to the error. 11 = = _____________ ERROR REPORTS 1. * CANNOT LOAD NAME A spec has been given for an external entity which cannot be loaded. The reason for the failure will have been given by the loader. 2. * CANNOT EDIT NAME / * CANNOT LIST NAME 'NAME' does not refer to a stored procedure. 3. CANNOT DEFINE PROCEDURE A routine has been so badly corrupted by the editing operation just performed that it is unsafe to allow 'LET' as a reply to EDIT NEW FILE ? 4. * FAULT 2nn (COMPILER OVERWORKED) DISASTER These fault messages are usually produced by giving the interpreter excessively long or complex statements, and can therefore be removed by splitting the offending statement into two or more statements. Corruption of compiler tables will also cause these faults. 5. INT:Q IGNORED An INT:Q has been given when the interpreter was not in a position to accept it safely. 6. * SIGNAL WT ww The interpreter has received an interrupt for which there is not an IMP fault message. Usually the interrupts have come from the input/output routines in the sub-system. If the message is postfixed by 'IN COMPILER' it means that a serious error has occurred during compilation. This is nearly always caused by the user giving an 'INT:Q' and will almost certainly lead to corruption of the compiler tables. 7. *********** CATASTROPHIC FAILURE NN *********** An interrupt has been given while the interpreter was dealing with a previous interrupt. 8. ******* ABORT ******* ABORT ******* The interpreter has discovered that its tables are corrupted beyond repair. All stored procedures are sent to a temporary file 'II#ABORT', and the user is returned to command level. The chances of this happening are very remote but can be attributed to misuse of 'INT:Q' 12 = = Error reports (with evidence please) and/or suggestions for improving the interpreter will be received with thanks from: PETER S. ROBERTSON C/O COMPUTER SCIENCE DEPT. 13 @@@@@@@@@@@@@@@ @@@@@@@@@@@@@@@