* TITLE 'IMP PERM FOR SIM2 P.STEPHENS' * FOR RELEASE 8 BACK COMPATIBLE TO RELEASE 7 * UPDATED TO SEND DIAGNOSTIC OUTPUT TO STREAM 89 * UPDATED TO CALL S#STOP RATHER THAN RETURNING ON REGISTER 9 IMP START CODE EQU 12 WSP EQU 11 GLA EQU 13 RA EQU 15 DC A(PEND-IMP) DC A(BASE-IMP) DC A(PERMGLA-IMP) DC A(PLOADATA-IMP) USING BASE,CODE USING WKSTART,WSP USING USERGLA,GLA BASE B CPLRERR P1 BC 15,RSS P2 BC 15,NS0 P3 BC 15,PS0 P4 BC 15,W0 P5 BC 15,PSTRO P6 BC 15,STOP1 P7 BC 15,GTSL0 P8 B RESETC P9 B SELECTIO P10 B UVU P11 BC 15,RNSP1 P12 BC 15,MONST1 P13 BC 15,AD0 P14 BC 15,PC0 P15 BC 15,GTSL1 P16 BC 15,NIQ0 P17 BC 15,TVC1 P18 B EXPFAIL P19 BC 15,RTI1 P20 BC 15,FTRAP1 P21 B RUNFLT1 P22 BC 15,CPE1 P23 BC 15,ABC10 P24 BC 15,ABC20 P25 BC 15,RFD1 P26 BC 15,CONCAT1 P27 B RES1 P28 BC 15,NRES1 P29 BC 15,NREND P30 BC 15,NPT1 P31 BC 15,MONITOR P32 BC 15,NEWLINK P33 BC 15,INT P34 BC 15,FRACPT P35 B STRCMP1 P36 BC 15,REXP1 P37 B RESEND P38 B RESFLOP P39 B STRJT1 P40 B LINKUP P41 B TOJCL P42 BC 15,INTPT P43 BC 15,FLOAT P44 BC 15,PTIME DS F IN CASE MORE ENTRIES NEEDED HALF DC D'0.5' D0 DC D'0' D1 DC D'1' FLTA DC X'4E00000000000000' UNASSGN DC X'8080808080808080' SIGNBIT DC X'80000000' ONE DC F'1' TWO DC F'2' THREE DC F'3' FF00 DC X'FF000000' F255 DC F'255' MINUS4 DC F'-4' MINUS8 DC F'-8' EJECT * REGISTER CONVENTIONS IN PERM * ALL ROUTINES WHICH APPEAR AS ROUTINES OR FUNCTIONS MUST RESTORE 4-15 * SUBROUTINES OF CSEXP(EG FLOAT,EXPONENTIATION) SHOULD RESTORE ALL * SAVE PARAMETER REGISTERS AND G.R.0 * ORG BASE+256 PAGES DC F'0' DC F'4096' DC F'8192' DC F'12288' DC F'16384' DC F'20480' DC F'24576' DC F'28672' DC F'32768' DC F'36864' DC F'40960' DC F'45056' DC F'49152' DC F'53248' DC F'57344' DC F'61440' DC F'65536' DC F'69632' DC F'73728' DC F'77824' DC F'81920' DC F'86016' DC F'90112' DC F'94208' DC F'98304' DC F'102400' DC F'106496' DC F'110592' DC F'114688' DC F'118784' DC F'122880' DC F'126976' DC F'131072' DC F'135168' DC F'139264' DC F'143360' DC F'147456' DC F'151552' DC F'155648' DC F'159744' DC F'163840' DC F'167936' DC F'172032' DC F'176128' DC F'180224' DC F'184320' DC F'188416' DC F'192512' DC F'196608' DC F'200704' DC F'204800' DC F'208896' DC F'212992' DC F'217088' DC F'221184' DC F'225280' DC F'229376' DC F'233472' DC F'237568' DC F'241664' DC F'245760' DC F'249856' DC F'253952' DC F'258048' DC F'262144' PS0 LA 0,3 STM 2,1,8(11) L 14,UPERMREF+8 USING PERMGLA,14 LM 12,14,IOCPEP DROP 14 BR 14 SELECTIO LTR 0,0 BC 8,INPUT OUTPUT LA 0,9 *EXPANSION OF ICALL!!!! SELBTH STM 2,1,8(11) L 14,UPERMREF+8 USING PERMGLA,14 LM 12,14,IOCPEP DROP 14 BR 14 INPUT LA 0,8 BC 15,SELBTH W0 LA 0,32 'SP' LTR 1,1 BNL W1 LA 0,45 '-' W1 CVD 1,DEC N 2,=F'127' MAX OF 127 PLACES MVC EDNUM(13),EDPAT LA 1,EDNUM+11 EDMK EDNUM(13),DEC+2 BCTR 1,0 NC EDNUM(12),FMASK TR EDNUM(12),ISOTAB STC 0,0(1) SIGN INDEPENDENT OF M/C MODE LA 3,EDNUM+12 SR 3,1 R3 = NO. OF PRINTING PLACES BCTR 1,0 STC 3,0(1) TURN INTO STRING SR 2,3 R2 = NO. OF LEADING SPACES * BC 4,ALPHA NEGATIVE MVI TIME+1,32 SPE 00 EX 2,PRPAGTE LEADING SPACES CONSTRUCTED LA 0,1(2,3) LENGTH=SPACES+DIGITS STC 0,TIME STR2NG FORMAT LA 2,TIME+2(2) BACK OF LEADING SPACES MVC 0(13,2),1(1) MOV) DIGITS BEHIND SPACES BETA LA 1,TIME LA 0,15 *EXPANSION OF ICALL!!!! ST 15,260(11) LA 11,264(11) STM 2,1,8(11) L 14,UPERMREF+8 USING PERMGLA,14 LM 12,14,IOCPEP DROP 14 BALR 15,14 SH 11,=H'264' L 15,260(11) BR 15 ALPHA MVC TIME(13),0(1) MOVE IN WHOLE STRINGINCL L B BETA NPT1 LR 1,RA NEW PRINTTEXT RA POINTS TO TXT. SR 2,2 IC 2,0(1) PICK UP LENGTH LA RA,2(2,RA) N RA,=F'-2' RETURN ADDR SET UP IN RA PSTRO LA 0,7 PRINT STRING(&DEAL WITH NULL) B SELBTH EDPAT DC X'40' DC 9X'20' DC X'212060' FMASK DC 12X'0F' IDIAGS L 0,64(11) ! PICK UP FAULT NUMBER L 13,52(11) PICK UP OLD VALUE OF GLA RUNFLT1 LA 3,0 LTR 9,9 BC 12,*+8 ENVIRONMENT INVALID L 3,8(9) *ABOVE FOUR LINES ARE IN CASE OF EXTERNAL PROCEDURES *CALLED FORMALLY WHEN THE ENVIRONMENT IS A DUMMY AND *REG 9 INVALID. IN THIS CASE FAULT TRAPPING WILL NOT WORK LA 15,STOP1 DIRECT FROM DIAGS TO STOP SEQUENCE B TODIAGS MONITOR SR 0,0 FAULT 0 IE. NO FAULT RECORDED TODIAGS STM 4,14,16(WSP) MAKE A SYSTEM STANDARD ENTRY USING SAVEREG,WSP ST 15,UPC STM 5,14,UREG5 REGISTERS FOR DIAGS USING WKSTART,WSP BC 15,DIAGS LINK ALREADY SET IN R15 MONST1 LA 0,11 STM 2,1,8(11) L 14,UPERMREF+8 USING PERMGLA,14 LM 12,14,IOCPEP DROP 14 BALR 15,14 LA 15,STOP3 B MONITOR STOP1 LA 0,1 LA 1,99 BAL RA,36(CODE) SELECT 99 LA 0,11 STM 2,1,8(11) L 14,UPERMREF+8 USING PERMGLA,14 LM 12,14,IOCPEP DROP 14 BALR 15,14 STOP3 LH 1,22(GLA) LTR 1,1 BZ STOP2 BAL RA,NPT1 DC X'110A' DC X'0A53544F' \STO DC X'50504544' PPED DC X'20415420' DC X'4C494E45' LINE LH 1,22(GLA) PICK UP LINE NO LA 2,3 BAL RA,W0 WRITE IT BAL RA,NPT1 DC X'010A' SINGLE NEWLIE STOP2 L 14,UPERMREF+8 USING PERMGLA,14 LM 12,14,STOPEP DROP 14 BR 14 GO TO SYSTEMROUTINE STOP EJECT * THIS SUBROUTINE CHECKS FOR VALID SWITCH LABEL AND JUMPS TO IT * THE CODE (LESS CHECKS) IS PUT LINE IN OPTIMISING MODE * R1 HAS COMPUTED EXPRESSION AND R2 HAS ADDR OF SWITCH VECTOR * R1 NOT ALTERED SO IT CAN BE PRINTED OUT IF LABEL NOT SET GTSL0 CH 1,2(2) CF WITH LOWER BOUND BC 4,GTSL1 FAULT IF LESS CH 1,6(2) CF WITH UPPER BOUND BC 2,GTSL1 FAULT IF HIGH LR 3,1 SH 3,2(2) SUBTRACT LOWER BOUND CLI 0(2),2 BC 8,GTSL4 HALF LENGTH SWITCHES SLL 3,2 L 3,8(3,2) PICK UP ADDR GTSL2 LTR 3,3 TEST FOR ZERO = NOT SET BC 7,0(3,10) GTSL1 LA 0,7 SWITCH LABEL NOT SET B RUNFLT1 GTSL4 AR 3,3 LH 3,8(3,2) LTR 3,3 BC 7,0(3,10) B GTSL1 * * * ARRAY D&CLARATION NEEDS A REWRITE TO REACH NEW SYSTEM STANDARDS AD0 L 3,36(GLA) @ DOPE VECTOR LA 3,0(3) LOSE TOP 8 BITS AD1 LA WSP,7(WSP) N WSP,MINUS8 TO DOUBLE WORD BOUNDARY ST 3,DV+8 AD2 ST WSP,DV+4 @ 1ST ELEMENT CLI 1(3),2 BNL AD20 L 1,8(3) UPPERBOUND S 1,4(3) LOWER BOUND A 1,ONE C 1,12(3) BC 8,*+8 ST 1,12(3) TOTAL LENGTH FOR 1DIM LTR 1,1 BC 2,AD3 ADFAIL LA 0,28 ARRAY INSIDEOUT B RUNFLT1 AD3 LH 2,2(3) MULTIPLIER = ITEM LENGTH ST 2,DV+12 FOR 1 DIMENSION ARRAYS MH 1,2(3) LA 4,7(1) TO ADVANCE WSP L 1,4(3) AD6 MH 1,2(3) L 0,DV+4 SR 0,1 @A(0) AD7 LM 1,3,DV+4 LOAD REST OF ARRAY HEAD TM 36(GLA),128 SPACE INHIBIT BIT SET? BCR 1,RA YESY SO ALLOCATE NO SPACE AR WSP,4 N WSP,MINUS8 TO DOUBLE WORD BOUNDARY L 4,UPERMREF+8 USING PERMGLA,4 TM PTOPLINK,128 CHECK FOR IBM METHOD BC 1,*+12 C WSP,PTOPSTRE BC 15,*+12 L 4,PTOPSTRE C WSP,0(4) HERE PTOPSTRE IS V-CONST DROP 4 BC 4,AD10 LR WSP,1 RESTORE OLD VALUE LA 0,4 EXCESS BLOCKS B RUNFLT1 AD10 CLI 36(GLA),0 BCR 8,RA EXIT IF UNASSIGNED CHECK OFF LD 0,UNASSGN FUNNY MARKER LR 4,1 AD11 STD 0,0(4) FILL ARRAY WITH MARKERS LA 4,8(4) CR 4,WSP BNH AD11 BR RA * MULTIDIMENSIONAL ARRAY DECL - R3 POINTS TO DV WHICH *IS DIM (2 BYTES)-ITEM LENGTH(2BYTES) LB1,UB1,M2,LB2,UB2,...UBN,TOTAL *LENGTH ROUTINE USES R0&1 TO WORK OUT SPACES R5 TO WORK OUT * A(1,0) AND R6 TO COUNT AD20 STM 5,6,ADSAVE LH 6,0(3) DIMENSION BCTR 6,0 LA 1,1 L 2,8(3) 1ST BOUND PAIR S 2,4(3) LA 2,1(2) BC 4,ADFAIL ST 2,DV+12 M2 INTO ARRAY HEAD LR 5,6 AD21 LA 3,12(3) ST 2,0(3) STORE MULTIPLIER MR 0,2 SPACE TO R1 L 2,8(3) S 2,4(3) LA 2,1(2) BC 4,ADFAIL BCT 6,AD21 MR 0,2 SPACE AS ELEMENTS ST 1,12(3) TOTAL NO. OF ELEMENTS L 6,4(3) LOWER BOUND N AD22 SH 3,=H'12' MOVE BACK DV POINTER MH 6,14(3) MULTUPLY BY MULTIPLIER A 6,4(3) ADD IN LB(N-1) BCT 5,AD22 ROUND AGAIN MH 1,2(3) SPACE AS BYTES LA 4,7(1) TO ADVANCE WSP MH 6,2(3) (@A(LB,LB)-@A(UB,UB))*BYTES/ITEM LCR 0,6 AR 0,WSP @ A(0,0) LM 5,6,ADSAVE B AD7 * EXPFAIL LA 0,21 B RUNFLT1 EJECT * SUBROUTINE TO PRINT SYMBOL IN R1 R2 TIMES * FORMS A STRING AND USES PRINT STRING FOR EFFICIENCY. PC0 LTR 2,2 BCR 13,RA RETURN IF R2<=0 STC 2,TIME LENGTH STC 1,TIME+1 1ST CHAR EX 2,PRPAGTE PROPAGATE CHAR THRO STRING LA 1,TIME LA 0,7 PRINT SRING IN IOCP B BETA+8 PRPAGTE MVC TIME+2(1),TIME+1 * * VARIOUS MINOR ERROR ROUTINES * TVC2 LA 0,3 INVALID CYCLE B RUNFLT1 NIQ0 LA 0,10 NON INTEGER QUOTIENT B RUNFLT1 RNSP1 LA 0,11 RESULT (OF FN) NOT SPECIFIED B RUNFLT1 CPE1 LA 0,30 CAPACITY EXCEEDED B RUNFLT1 UVU LA 0,31 UNASSIGNED VARIABLE USED B RUNFLT1 CPLRERR LA 0,8 COMPILE TIME ERROR (TRAPPED) B RUNFLT1 * PTIME EQU CPLRERR STRJT1 EQU CPLRERR RSS EQU CPLRERR NS0 EQU CPLRERR FLOAT EQU CPLRERR REXP1 EQU CPLRERR FRACPT EQU CPLRERR RFD1 EQU CPLRERR CONCAT1 EQU CPLRERR INT EQU CPLRERR INTPT EQU CPLRERR RES1 EQU CPLRERR RESEND EQU CPLRERR TOJCL EQU * * * SUBROUTINE TO CHECK IMP STATEMENT %CYCLE I=P,Q,R * P IN R1. R2 POINTS TO Q AND R * TVC1 LM 2,3,0(2) P,Q,R,NOW IN R1,R2,R3 LTR 0,2 Q TO R0 BZ TVC2 FAULT ZERO INCREMENT SR 3,1 (R-P) LR 2,3 SRDA 2,32 SET UP DIVISION DR 2,0 R3 = (R-P)/Q LTR 2,2 BC 7,TVC2 LTR 3,3 P STILL IN R1 BCR 10,RA RETURN IF R3 >=0 B TVC2 EJECT * ARRAY BOUND CHECKING SUBROUTINES. NOT USED IN OPTIMISING MODE *THIS SU BRIUTINE CHECKS BOUNDS FOR 1D ARRAY SUFFIX IN R(1) ABC10 ST RA,R13 L RA,8(3) ADDR DV TO R 13 CLI 1(RA),1 RIGHT DIMENSION? BC 7,ADW1 C 1,4(RA) COMPARE WITH LB BC 4,ABE1 FAULT IF LOW C 1,8(RA) COMPARE WITH UB BC 2,ABE1 FAULT IF HIGH ABC11 MH 1,2(RA) ADJUST FOR PREC L RA,0(3) ADDR A (0) L 2,R13 LINK BCR 15,2 RETURN ABE2 LR 1,2 ABE1 LA 0,32 ARRAY BOUNDS EXCEEDED B RUNFLT1 * MULTIDIMENSIONAL * R1 POINTS TO LAST SUFFIXES. R2 TO ARRAY HEAD ABC20 ST RA,RFSAVE STM 3,4,RFSAVE+4 L RA,0(2) @ A(0,0) L 4,8(2) @ DV LH 3,0(4) DIM BCTR 3,0 DIM-1 LTR 3,3 BZ ADW1 CHECK MORE THAN 1 DIMENSION LR 2,1 LAST SUFFIX MH 3,=H'12' AR 3,4 SR 0,0 ABC21 L 1,0(2) C 1,4(3) LOWER BOUND BC 4,ABE1 C 1,8(3) BC 2,ABE1 UPPER BOUND AR 1,0 MH 1,2(3) LR 0,1 CR 3,4 BC 8,ABC22 A 2,MINUS4 SH 3,=H'12' B ABC21 ABC22 LM 2,4,RFSAVE BR 2 ADW1 LA 0,33 CORRUPT DOPE VECTOR 00 B RUNFLT1 EJECT * * A SUBROUTINE FOR STRING COMPARISONS OTHER THAN = & \= USING ISO * COLLATION R1 & R2 HOLD STRINGS -R0 & R3 USABLE STRCMP1 EQU * SR 3,3 IC 3,0(1) STRCEX CLC 0(1,2),0(1) COMPARE LENGTH BYTE BALR 0,0 SAVE CONDITION CODE BH STRCMP2 BL STRCMP3 EX 3,STRCEX LENGTHS EQUAL -NO PROBLEM BR RA STRCMP3 IC 3,0(2) STRCMP2 LTR 3,3 BC 8,STRCMP4 BCTR 3,0 EX 3,SCOMPL BCR 7,RA ALL CHARS EQUAL STRCMP4 SPM 0 RESULT BASED ON LENGTHS BR RA SCOMPL CLC 1(1,2),1(1) EJECT * NEW RESOLUTION -R1 POINTS TO STRING TO BE SEARCHED FOR. R2 * POINTS TO A FOUR WORD WORK AREA:- * W1 START OF STRING TO BE SEARCHED * W2 BYTE AT WHICH SEARCH IS TO START * W3 ORIGINAL LENGTH OF LHS (SET ON FORST ENTRY) * W4 STRINGNAME TO HOLD FRAGMENT RESOLVED OFF * * METHOD IS TO USE TRT TO SEARCH FOR 1ST CHAR THEN CLC TO * TEST THE REST.A DUMMY TRTAB IS KEPT IN PERM GLA NRES1 STM 4,8,TIME+260 SAVE REGISTERS NEEDED CLI 7(2),0 FIRST ENTRY ? BC 7,NRES2 L 3,0(2) SR 0,0 IC 0,0(3) ST 0,8(2) SET ORIGINAL LENGTH LHS INTO W3 NRES2 CLI 0(1),0 BC 8,NRNULL SEARCHING FOR A NULL STRING L 4,UPERMREF+8 R4 TO PERMGLA USING PERMGLA,4 LR 5,1 R5 STRING BEING SEARCHED FOR SR 6,6 R6 SET TO L-1 FOR EX OF CLC IC 6,0(5) THIS IS PUT INTO TRTAB AND * REAPPEARS IN R2 ON TRT L 3,8(2) LENGTH OF LHS ORIGINALLY S 3,4(2) MINUS BIT ALREADY USED SR 3,6 MINUS LHS LENGTH BL NRESFAIL NOT ENOUGH ROOM * R3 HOLDS(POSSIBLE POSNS-1) * I.E. READY TO EX A TRT SR 7,7 NOW GET FIRST CHAR OF LHS AND IC 7,1(5) MAKE AN ENTRY INTO THE TRTABLE * PUT (L) INTO TR TAB -THIS STC 6,NTRTAB(7) WILL APPEAR AGAIN IN R2 LR 6,2 SR 2,2 TO RECEIVE LENGTH L 1,0(6) ORIGINAL START OF LHS A 1,4(6) LESS BIT ALREADY USED LA 1,1(1) LR 8,1 AND SAVE IT NRLOOP LCR 0,1 TO WORK OUT HOW FAR TRT WENT EX 3,NRTRT BC 8,NRMISS FIRST CHAR NOT FOUND BCTR 2,0 REMEMBER 1 CHAR STRINGS!!! EX 2,NRCOMP BC 8,NRESOK REST FOUND ALSO LA 1,1(1) PAST SPURIOUS FIRST CHAR AR 0,1 SR 3,0 NEW LENGTH BC 10,NRLOOP ROUND AGAIN NRMISS SR 3,3 STC 3,NTRTAB(7) RESET TRTAB LR 2,6 RESET POINTER TO WK AREA NRESFAIL LM 4,8,TIME+260 NR 11,11 SET CC FOR FAILURE BR RA NRTRT TRT 0(0,1),NTRTAB TO FIND FIRST CHAR NRCOMP CLC 0(0,1),1(5) TO CHECK THE REST NRMOVE MVC 1(0,3),0(8) TO MOVE FRAGMENT NRNULL L 3,12(2) MVI 0(3),0 SET NAME TO NULL CR 11,11 SET CC BR RA AND EXIT NRESOK EQU * * CURRENTLY R1 POINTS TO START OF EXPR. R2 HAS L-1 FOR REST EXPR * R8 HOLDS START OF STRING+1 SO POINTS TO BIT TO BE MOVED * STRING NOW USED UP = BYTES TO BE MOVED INTO NAME + L SR 3,3 STC 3,NTRTAB(7) RESTORE TABLE L 3,12(6) POINTER FOR STRING TO BE STORED LR 7,1 SR 7,8 LENGTH OF FRAGMENT STC 7,0(3) BC 8,NRNOCT ZERO BCTR 7,0 CLI 12(6),0 WAS A MAX LENGTH GIVE BC 8,NREX CLC 0(1,3),12(6) YES SO PERFORM CAPACITY TEST BC 2,NRCPE NREX EX 7,NRMOVE LA 7,1(7) NRNOCT LA 2,1(7,2) BIT USED UP IN THIS RESLN A 2,4(6) PLUS BIT USED IN EARLIER RESLNS ST 2,4(6) RESET IN WORK AREA LR 2,6 RESET POINTER TO WORK AREA LM 4,8,TIME+260 CR 0,0 SET CC TO SUCCESS BR RA DROP 4 NRCPE LM 4,8,TIME+260 BC 15,CPE1 * THIS ROUTINE DEALS WITH FINAL FRAGMENT AFTER ALL RESOLUTIONS * R2 AS FOR RESOLUTIONS NREND LR 0,4 L 3,8(2) ORIGINAL MAX LENGTH L 1,0(2) A 1,4(2) POINTS TO FIRST BYTE-1 S 3,4(2) L 4,12(2) STC 3,0(4) CLI 12(2),0 BC 8,*+14 CLC 0(1,4),12(2) BC 2,CPE1 CAPACITY FAIL LTR 3,3 BC 8,*+10 BCTR 3,0 EX 3,NRENDM LR 4,0 BR RA NRENDM MVC 1(0,4),1(1) RESFLOP LA 0,26 B RUNFLT1 EJECT * * FAULT ROUTINE SETS UP TRAP FOR ALL TRAPPABLE FAULTS FAULT NO IN R1 * FTRAP1 EQU * * NC FWORD(4),FWORD CONTROL VECTOR SET? NC 8(4,9),8(9) BC 7,FTRAP2 YES ST 11,8(9) SET 32 WORDS ON STACK XC 0(128,11),0(11) ZEROISE IT LA 11,128(11) FTRAP2 BCTR 1,0 SLL 1,2 A 1,8(9) FWORD L 2,0(1) POINTER TO SAVE AREA LTR 2,2 FOR THIS FAULT BC 7,FTRAP3 FTRAPOBT LR 2,11 ST 2,0(1) LA 11,24(11) FTRAP3 STM 9,11,0(2) ST RA,12(2) ST GLA,16(2) MVC 20(4,2),20(GLA) DIAG POINTERS * ADVANCE STACK POINTER STORED WITH PREVIOUSLY * TRAPPED FAULTS SO THIS INFO WON'T BE LOST * IF AN EARLIER TRAPPED FAULT IS ENCOUNTERED * THIS GI0ES A VERY OBSCURE SYSTEM FAIL LA 3,32 L 1,8(9) FWORD FTRAP5 L 2,0(1) POINTER LTR 2,2 FAULT NOT TRAPPED ? BZ FTRAP4 C 11,8(2) COMPARE WITH R11 AT TRAP BC 12,FTRAP4 ST 11,8(2) FTRAP4 LA 1,4(1) BCT 3,FTRAP5 BC 15,8(RA) EXIT PAST JUMP TO FAILURE * RUN TIME INITIALISE ROUTINE RTI1 LR 5,RA SAVE RETURN ADDRESS LR 9,11 SET R9=FRAME OF MAIN PROGRAM BAL RA,RESETC AND PUT DOWN CONTINGENCY * ZERO THE POINTER TO FVECTOR XC 8(4,9),8(9) FWORD(4),FWORD LR RA,5 B LINKUP * * DEAL WITH SIM2 CONTINGENCY * CONTIN LA 0,35 R1 TO REGS ETC R2 INT WT LR 3,1 LR 6,1 L WSP,52(1) USERS STACK PTR LA WSP,64(WSP) PAST SAVE AREA IF RT CALL LR 1,2 WEIGHT FOR DIAGS N 2,F255 SRL 2,2 IC 0,FLTTAB(2) CORRECT NO FOR DIAGS CONT2 LA 3,0 LTR 9,9 BC 12,*+8 ENVIRONMENT INVALID L 3,8(9) *ABOVE FOUR LINES ARE IN CASE OF EXTERNAL PROCEDURES *CALLED FORMALLY WHEN THE ENVIRONMENT IS A DUMMY AND *REG 9 INVALID. IN THIS CASE FAULT TRAPPING WILL NOT WORK USING SAVEREG,WSP MVC UPC(100),4(6) REGISTERS ETC FROM SIM USING WKSTART,WSP LA 15,STOP1 STM 4,14,16(WSP) B DIAGS FLTTAB DC 22X'23' UNEXPLAINED DC X'24' ILLEGAL OP CODE DC X'22230211' ADDRESS//UNEXPL/REALO-F/DIV DC 3X'23' UNEXPLAINED DC X'01' FIXED OVERFLOW DC X'230D' TESTMODE AND OPERATOR=128 DC X'0C1D' TIME AND OUTPUT LIMITS=132/6 DC X'0912' INPUTENDED & SUBSCHAR DC X'2514' IOCP RERR & UNDEFND STRM DC X'26' 156= RT NOT THERE AFTER LET DC 24X'23' THE REST TO MAKE 64 IN ALL RESETC LR 4,RA RESET CONTINGENCY LA RA,CONTIN USER FAULT TRAP STM 4,15,128(11) LA 1,128(11) LA 11,256(11) LR 3,11 REPORT WORD (IGNORED) SR 0,0 STM 4,3,16(11) L 14,UPERMREF+8 USING PERMGLA,14 LM 12,14,SIGEP DROP 14 BALR 15,14 SH 11,=H'256' LA 1,8 SLL 1,24 SPM 1 RESTORE IMP PRGM MASK BR 4 EJECT ISOTAB DC X'30313233343536373839' DC X'414243444546' * NEWLINK IS FOR RELEASE 8 EXTERNAL ROUTINES ONLY. IT IS ENTERED VIA * A 'BC' INSTRUCTION AND RETURNS TO 8(10). THIS SAVES ENTERING PERM * ON EVERY EXTERNAL ROUTINE ENTRY JUST IN CASE IT IS THE FIRST TIME NEWLINK ST 4,28(GLA) HEAD OF CODE COPIED TO R4 LA 15,8(10) SET UP RETURN ADDR AND DROP * DROP THROUGH INTO LINKUP * TOP BIT OF LINK IS SET TO INDICATE STRING -NOT SET FOR ARRAYS * NEXT BIT SET TO INDICATE EXTRINSIC * X'20' BIT SET IF DATA IN SHARABLE SYMBOL TABLES -OTHERWISE GLA S.T. LINKUP EQU * LINK UP OWN ARRAYS CLI 5(GLA),0 BCR 8,RA RETURN IF DONE L 4,32(GLA) LISTHEAD L 0,0(GLA) LTR 0,0 RELEASE 8 GLA? BC 7,NEXTLINK NO L 0,12(GLA) POINTER TO SST A 0,28(GLA) + ADDR OF START OF CODE ST 0,0(GLA) = RELOCATED POINTER IN WORD 0 NEXTLINK LA 4,0(4) LOSE TOP BYTE LTR 4,4 BC 12,LINKED AR 4,GLA TM 12(4),X'20' BO SSTDATA L 0,8(GLA) POINTER TO GLA S.T. AR 0,GLA RELOCATE B TESTSTR SSTDATA L 0,12(GLA) POINTER TO SHARABLE S.T. A 0,28(GLA) ADD HEAD OF CODE TESTSTR EQU * REGISTER 0 HAS RELOCATE VALUE TM 12(4),X'80' BO STRLINK1 LM 1,3,0(4) ARRAYHEAD REL TO SYMTAB TM 12(4),X'40' BZ NOTXTR NOT AN EXTRINSIC L 2,4(2,13) ADDR A(1) POINTS TO XREF(REL) AR 1,2 ADJUST ADDR(A(0)) B ARRCOM NOTXTR AR 1,0 RELOCATE ADDR(A(0)) AR 2,0 ARRCOM AR 3,0 RELOCATE ADDR(DOPE VECTOR) STM 1,3,0(4) LR 2,4 SAVE ADDR OF ARRAYHEAD L 4,12(4) LH 1,2(3) M0 = BYTES/ITEM NEW SYS STNDS ST 1,12(2) INTO ARRAYHEAD OVERWRITING LINK B NEXTLINK LINKED MVI 5(GLA),0 BR RA * STRINGS TWO WORD REF LINK 16 BYTES BACK-MAX LENGTH IN TOP BITS STRLINK1 TM 12(4),X'40' TEST NORMAL OR EXTRINSIC L 3,8(4) POINTER REL TO HEAD S-ST BO STRXTR AR 3,0 RELOCATE TOP BYTE UNDISTURBED STRLINK2 ST 3,8(4) L 4,12(4) B NEXTLINK STRXTR L 2,4(3,13) FROM XREF GET START OR DATA N 3,FF00 OR 3,2 SUBSTITUTE WITHOUT UPSETTING B STRLINK2 THE TOP(LMAX) BYTE EJECT * TITLE 'IMP 50 DIAGNOSTICS PROGRAM' DIAGS EQU * USING SAVEREG,9 LR 9,WSP ST RA,RTRNAD SYSTEM STANDARDS * LA WSP,200(WSP) RESERVE WORK SPACE FROM STACK * LTR 0,0 BNH NOTRAP1 ZERO OR NEGATIVE CH 0,=H'32' BH NOTRAP1 LR 2,0 BCTR 2,0 LTR 3,3 ANY FAULTS TRAPPED? BZ NOTRAP1 SLL 2,2 L 3,0(2,3) PTR TO THIS FAULT LTR 3,3 HAS IT BEEN TRAPPED? BC 8,NOTRAP1 L GLA,16(3) L RA,12(3) MVC 20(4,GLA),20(3) LM 9,11,0(3) USERS MAIN REG,CODE REG & STACK SRL 2,2 (FAULT NO-1) IN R2 LA 3,1 SLL 3,0(2) N 3,FBITS #0 IF CAME VIA CONTIGENCY BC 7,32(12) TO RESET CONTINGENCY AND * THEN ON TO USERS FAULT ROUTINE (ADDR IN RA) BCR 15,15 DS 0F FBITS DC X'00030103' BITS SET FOR EXTRA CONTIGENCY * OFLOW(2),INPUT ENDED,EOFILE,ZERODIV,SUBSCHAR NOTRAP1 LTR 8,0 FAULT NO TO R8 BZ DCALL1 ST 1,FVALUE SAVE ANY VALUE LA 1,89 LA 0,1 BAL RA,36(CODE) SELECT OUTPUT 89 DCALL1 LA 1,1000(11) L 3,UPERMREF+8 USING PERMGLA,3 TM PTOPLINK,128 CHECK FOR IBM METHOD BC 1,*+12 C 1,PTOPSTRE ROOM TO LOAD MDIAGS? BC 15,*+12 L 2,PTOPSTRE C 1,0(2) BH NOROOM LA 0,UPC LR 1,8 L 2,FVALUE STM 4,2,16(11) LA 15,EXIT LM 12,14,MDIAGEP BR 14 NOROOM LA 1,NRTEXT BAL RA,20(CODE) PRINTTEXT IN PERM B EXIT NRTEXT DC X'230A' DC X'4E4F20524F4F4D20' NO_ROOM_ DC X'544F204C4F414420' TO_LOAD_ DC X'444941474E4F53544943' DIAGNOSTIC DC X'20524F5554494E45' _ROUTINE EXIT LM 4,15,SAVEREG+16 SYSTEM STANDARDS BR RA LTORG DS 0D PERMGLA DC 4F'0' 4 WORDS FOR SYSTEM STANDARDS PTOPLINK DC F'0' PTOPSTRE DC F'0' NTRTAB DC 256X'00' XREF1 DC A(XREF2-PERMGLA) SIGEP DC 3F'0' DC X'80000000' DC X'0853235349474E414C' 'S#SIGNAL' XREF2 DC A(XREF3-PERMGLA) IOCPEP DC 3F'0' DC X'80000000' DC X'065323494F4350' XREF3 DC A(XREF4-PERMGLA) MDIAGEP DC 3F'0' DC X'80000000' DC X'0753234D44494147' S#MDIAG XREF4 DC F'0' END OF LIST STOPEP DC 3F'0' DC X'80000000' DC X'06532353544F50' S#STOP PLOADATA DS 0D DC F'6' SIX POINTERS DEFINED DC A(EP1-PLOADATA) DC A(XREF1-PERMGLA) DC 3F'0' DC A(PTOPLINK-PERMGLA) EP1 DC F'0' DC 2F'0' DC F'1' TO CAUSE ADDRESS ERROR DC X'80000000' DC X'0649235045524D' I#PERM PEND DS 0D * EJECT *WKAREA DSECT WKSTART DS 64F RWSP1 DS D FLAG DS B K DS B RMODE DS B RDLINK DS F SAVE13 DC F'0' R13 DC F'0' DEC DS D DOUB DS D LINK DS F PBLINK DS F ADDR DS F EDNUM DS 13C DV DS 4F RDUMP DC 3F'0' RFSAVE DS 2F ADSAVE DS 3F BDR DS H BDF DS H RECFST DS F ITEMS DS F MOST DS H RSTORE DS F LMAX DS 4B TIME EQU WKSTART DS 0D EJECT *USERGLAP DSECT USERGLA DS F RESERVED AS POSSIBLE ST PTR UPRGL DS C UGLAFREE DS 3C UGLASTPT DS 2F POINTERS TO CODESYMTAB & GLAST UMINOS1 DC F'-1' USED FOR INITIAL 'NOT' UBLCKNO DS H ULINENO DS H UBYTEMSK DC F'255' UHDCODE DS F HEAD OF CODE STORED HERE UWKSPACE DS D UZERO DC D'0' DOUBLE WORD OF ZEROS UREAL1 DC D'1' UREAL2 DC D'2' UTPSTLNK DC F'0' UTOPSTRE DC F'0' UFLOAT DC X'4E00000000000000' UMASK1 DC F'-4' UMASK2 DC F'-8' UPERMREF DC F'0' XREF TO PERM R12 LOADED FROM DC A(BASE) HERE ON ENTRY - PERM USES THIS DC A(PERMGLA) TO FIND ITS OWN GLA ON THE DC A(BASE+1) FEW OCCASIONS IT NEEDS IT DC F'6' UPERMID DC X'4923504552404141' URTENTRY STM 4,14,16(WSP) SUBROUTINE TO SAVE SPACE A 1,UHDCODE WHEN ENTERING AN INTERNAL BR 1 ROUTINE OR FUNCTION BCR 0,0 UUNASS DC 8X'80' FOR UNASSIGNED CHECKING UIOCPREF DC 4F'0' DC F'6' DC X'5323494F43502020' 'S#IOCP' USERSTR DS 100F USER OWNS ETC START HERE DS 0D EJECT *FREESP DSECT SAVEREG DS 15F RTRNAD DS F FVALUE DS F NUM DS F PRADDR DS F VCOMREG DS F UPC DS F UREG0 DS F DS 4F UREG5 DS F UREG6 DS F UREG7 DS F UREG8 DS F UREG9 DS F UREGGS DS 3F USERS R10,R11,R12 UGLAREG DS F COPY OF USERS CURRENT GLA REG * UREG14 DS F END %ENDOFFILE