TITLE 'IMP PERM FOR SIM2 P.STEPHENS' * FOR RELEASE 8 BACK COMPATIBLE TO RELEASE 7 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,EXP0 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' 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,7 *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 BC 15,BETA+4 PRINT STRING(&DEAL WITH NULL) 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 EQU * MONITOR EQU * TODIAGS EQU * PS0 EQU * GTSL0 EQU * CONCAT1 EQU * RESEND EQU * RESFLOP EQU * RES1 EQU * MONST1 EQU * STOP1 EQU * STOP3 EQU * STOP2 EQU * TOJCL IDL 0(0),0 EJECT * ARRAY DECLARATION 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 C WSP,PTOPSTRE DROP 4 BCR 4,RA LR WSP,1 RESTORE OLD VALUE LA 0,4 EXCESS BLOCKS B RUNFLT1 * 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 * UNASSGND EQU UNASSGN 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 BC 15,BETA PRPAGTE MVC TIME+2(1),TIME+1 * * VARIOUS MINOR ERROR ROUTINES * CPLRERR EQU RUNFLT1 COMPILE TIME ERROR (TRAPPED) TVC2 EQU CPLRERR INVALID CYCLE NIQ0 EQU CPLRERR NON INTEGER QUOTIENT RNSP1 EQU CPLRERR RESULT (OF FN) NOT SPECIFIED CPE1 EQU CPLRERR CAPACITY EXCEEDED UVU EQU CPLRERR UNASSIGNED VARIABLE USED * NST1 EQU CPLRERR NF1 EQU CPLRERR PTIME EQU CPLRERR STRJT1 EQU CPLRERR FRACPT EQU CPLRERR FLOAT EQU CPLRERR EXP0 EQU CPLRERR INT EQU CPLRERR INTPT EQU CPLRERR REXP1 EQU CPLRERR EXPFAIL EQU CPLRERR RSS EQU CPLRERR NS0 EQU CPLRERR SELECTIO EQU CPLRERR * SUBROUTINE TO CHECK IMP STATEMENT %CYCLE I=P,Q,R * P IN R1. R2 POINTS TO Q AND R * TVC1 EQU CPLRERR * ARRAY BOUND CHECKING SUBROUTINES. NOT USED IN OPTIMISING MODE *THIS SU BRIUTINE CHECKS BOUNDS FOR 1D ARRAY SUFFIX IN R(1) ABC10 EQU CPLRERR * MULTIDIMENSIONAL * R1 POINTS TO LAST SUFFIXES. R2 TO ARRAY HEAD ABC20 EQU CPLRERR EJECT * THIS LONG ROUTINE WORK DOWN A PARTIAL RECORD FORMAT DOPE VECTOR * CALCULATING DISPLACEMENTS THAT CAN NOT BE DONE AT COMPILE TIME AND * COMPLETES THE DOPE VECTOR FROM THE INFORMATION DEDUCED. * G.R.1 POINTS TO DOPE VECTOR * RFD1 EQU CPLRERR 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 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 RES 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 EX 7,NRMOVE LA 7,1(7) CLI 12(6),0 WAS A MAX LENGTH GIVE BC 8,NRNOCT CLC 0(1,3),12(6) YES SO PERFORM CAPACITY TEST BC 2,CPE1 NRNOCT LA 2,1(7,2) BIT USED UP IN THIS RELSN A 2,4(6) + ANY USED IN EARLIER RESNS 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 * 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) EJECT * * FAULT ROUTINE SETS UP TRAP FOR ALL TRAPPABLE FAULTS FAULT NO IN R1 * FTRAP1 EQU CPLRERR * RUN TIME INITIALISE ROUTINE RTI1 LA 1,8 SLL 1,24 SPM 1 MASK OUT ALL BAR O/FLOW B LINKUP * * DEAL WITH SIM2 CONTINGENCY * RESETC EQU CPLRERR 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 * * BASE REGISTER COVER NEED ONLY REACH HERE * LTORG DS 0D PERMGLA DC 4F'0' 4 WORDS FOR SYSTEM STANDARDS FWORD DC F'0' RECOVER DC F'0' PTOPLINK DC F'0' PTOPSTRE DC F'0' NTRTAB DC 256X'00' XREF1 DC F'0' IOCPEP DC 3F'0' DC X'80000000' DC X'065323494F4350' 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' NEW FORMAT 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