* * ********************************************************************** * * * * * 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 *