./ ADD SSI=02013192,NAME=IEMJD,SOURCE=0 JD TITLE 'IEMJD - CONSTANT TRIPLE EVALUATION - PL/I(F)' 00100015 * 00200015 * STATUS - CHANGE LEVEL 0. 00300015 * 00320064 * 5.4 C 803000,821000 MCB 52164 00340064 * 00360064 * 00400015 * FUNCTION/OPERATION - THIS PHASE CONDENSES THE TEXT BY 00500015 * EVALUATING CERTAIN TRIPLES HAVING CONSTANT OPERANDS, MAKING 00600015 * NEW DICTIONARY REFERENCES AS APPROPRIATE, AND PASSING THE 00700015 * RESULTS THROUGH A STACK INTO THE SINK OPERANDS. 00800015 * 00900015 * FOR THE FIRST RELEASE OF THIS PHASE, ONLY PREFIXED AND 01000015 * CONCATENATED CONSTANTS ARE BEING PROCESSED. 01100015 * 01200015 * ENTRY POINT - START 01300015 * 01400015 * INPUT - TEXT BLOCKS 01500015 * 01600015 * OUTPUT - MODIFIED TEXT BLOCKS 01700015 * 01800015 * EXTERNAL ROUTINES - ZUGC GET SCRATCH CORE 01900015 * ZURC RELEASE SCRATCH CORE 02000015 * ZABORT DUMP AND EXIT 02100015 * ZDICRF MAKE DICTIONARY ENTRY 02200015 * ZDRFAB CONVERT DICRY REF TO ABS 02300015 * RLSCTL RELEASE CONTROL 02400015 * ZTXTAB CONVERT TEXT REF TO ABS 02500015 * ZCHAIN GET NEXT TEXT BLOCK 02600015 * ZALTER ALTER TEXT BLOCK STATUS 02700015 * 02800015 * 02900015 * EXITS-NORMAL - WINDUP 03000015 * (VIA RELCOR,RETURN, TO RLSCTL) 03100015 * 03200015 * EXITS-ERROR - RELESE 03300015 * (FROM INIT SECT, TO RLSCTL) 03400015 * 03500015 * OUT (TO ZABORT) 03600015 * 03700015 * TABLES/WORK AREAS - 03800015 * 03900015 * NEWAR 04000015 * 300 BYTES IN WHICH NEW DICTIONARY ENTRY 04100015 * IS CONSTRUCTED. BACK END IS USED AS 04200015 * REG SAVE AREA PRIOR TO ABORT. 04300015 * 04400015 * TRTAB 04500015 * 256 BYTES TRANSLATE AND TEST TABLE USED 04600015 * IN SCANT 04700015 * 04800015 * BSTACK 04900015 * 1024 BYTES OF SCRATCH CORE USED FOR 05000015 * RESULTS STACK IN SCANT 05100015 * 05200015 * 05300015 EJECT 05400015 SPACE 05500015 IEMJD START 0 05600015 USING PGMBLK,BASE 05700015 USING CONBLK,CBASE 05800015 USING DICBLK,DBASE 05900015 SPACE 2 06000015 * DEFINITIONS OF 4K BLOCKS REFERENCED IN USING STATEMENTS 06100015 * TO PROVIDE PROGRAM BASE,AND PSEUDO BASES FOR FACILITAT- 06200015 * ING REFERENCES TO SLOT OFFSETS BY AUTOMATIC REGISTER 06300015 * ASSIGNMENT. 06400015 SPACE 06500015 PGMBLK EQU * 06600015 CONBLK EQU *+X'1000' 06700015 DICBLK EQU *+X'2000' 06800015 SPACE 2 06900015 * DEFINITIONS OF CONTROL PHASE OFFSETS 07000015 SPACE 07100015 ZUGOFF EQU CONBLK+X'10' (ZUGC) GET SCRATCH CORE 07200015 ZUROFF EQU CONBLK+X'18' (ZURC) RELEASE SCRATCH 07300015 ZBOFF EQU CONBLK+X'20' (ZABORT) ERROR RELEASE AND DUMP 07400015 ZDCROF EQU CONBLK+X'2C' (ZDICRF) MAKE DICTIONARY ENTRY,RETURN REF 07500015 ZUEROF EQU CONBLK+X'30' (ZUERR) PUT OUT ERROR MESSAGE 07600015 ZDFAOF EQU CONBLK+X'34' (ZDRFAB) FIND DICTIONARY REF,RETURN ADDR 07700015 RLSCOF EQU CONBLK+X'48' (RLSCTL) RELEASE NAMED PHASES AND RETURN 07800015 ZTABOF EQU CONBLK+X'54' (ZTXTAB) CONVERT TEXT REF TO ADDRESS 07900015 ZCHOFF EQU CONBLK+X'58' (ZCHAIN) GET NEXT TEXT BLOCK IN CHAIN 08000015 ZALTOF EQU CONBLK+X'5C' (ZALTER) ALTER TEXT BLOCK STATUS 08100015 SPACE 2 08200015 * DEFINITIONS OF COMMUNICATIONS REGION OFFSETS 08300015 SPACE 08400015 SAVE EQU DICBLK SAVE REGISTER AREA 08500015 ZMYNAM EQU DICBLK+X'70' CURRENT PHASE SLOT 08600015 PAR1 EQU DICBLK+X'80' PARAMETER 1 SLOT 08700015 PAR2 EQU DICBLK+X'84' PARAMETER 2 SLOT 08800015 PAR3 EQU DICBLK+X'88' ALL 08900015 PAR4 EQU DICBLK+X'8C' THE 09000015 PAR5 EQU DICBLK+X'90' REMAINING 09100015 PAR6 EQU DICBLK+X'94' PARAMETER 09200015 PAR7 EQU DICBLK+X'98' SLOT 09300015 PAR8 EQU DICBLK+X'9C' DEFINITIONS 09400015 STARTX EQU DICBLK+X'100' START TEXT REF 09500015 ZCONCH EQU DICBLK+X'17E' ADDR OF HEAD OF CONSTANTS CHAIN 09600015 SPACE 4 09700015 * G.P. REGISTER USAGE 09800015 SPACE 09900015 TSR EQU 1 TEXT SCAN REGISTER 10000015 TIR EQU 2 TEXT INDEX REGISTER 10100015 SPR EQU 3 STACK POINTER REGISTER 10200015 EREG EQU 4 EVEN REG 10300015 OREG EQU 5 ODD REG 10400015 FIVE EQU 6 REG CONTAINING HEX 5 10500015 UNIT EQU 7 REG CONTAINING HEX 1 10600015 R8 EQU 8 10700015 BASE EQU 10 BASE REGISTER OF THIS BLOCK 10800015 CBASE EQU 11 CONTROL BASE REG 10900015 DBASE EQU 13 DICTIONARY BASE REG 11000015 LR EQU 14 LINK REGISTER 11100015 BR EQU 15 BRANCH REGISTER 11200015 SPACE 11300015 SPACE 2 11400015 * TEST BYTE CODES 11500015 SPACE 11600015 ENDP2 EQU X'EE' END PROGRAM 2 11700015 ENDBLK EQU X'ED' END OF TEXT BLOCK 11800015 CAT EQU X'49' CONCATENATION 11900015 UPLUS EQU X'7D' UNARY PLUS 12000015 UMINUS EQU X'7B' UNARY MINUS 12100015 UNICON EQU X'88' DICTIONARY FLAG FOR CONSTANT. 12200015 STERL EQU X'08' WAS A STERLING CONSTANT. 12300015 NULL EQU X'27' NULL TRIPLE. 12400015 MINUS EQU X'73' MINUS. 12500015 CON0F EQU X'0F' DICTIONARY FLAG FOR STRING. 12600015 CHRBIT EQU X'04' CHARACTER BIT TEST MASK 12700015 STRING EQU X'80' TEST MASK FOR STRING 12800015 SPACE 12900015 SPACE 2 13000015 * CONDITIONAL BRANCH MNEMONICS 13100015 SPACE 13200015 B EQU 15 BRANCH UNCONDITIONAL 13300015 NOP EQU 0 NO OPERATION 13400015 SPACE 13500015 BE EQU 8 COMPARE: EQUAL 13600015 BH EQU 2 (FIRST HIGH 13700015 BL EQU 4 OPERAND) LOW 13800015 BNE EQU 7 NOT EQUAL 13900015 BNH EQU 13 NOT HIGH 14000015 BNL EQU 11 NOT LOW 14100015 SPACE 14200015 BZ EQU 8 (TM ZEROS) ARITHMETIC ZERO 14300015 BP EQU 2 RESULT: PLUS 14400015 BM EQU 4 (TM MIXED) MINUS 14500015 BNZ EQU 7 NOT ZERO 14600015 BNP EQU 13 NOT PLUS 14700015 BNM EQU 11 NOT MINUS 14800015 BO EQU 1 (TM ONES) OVERFLOW 14900015 SPACE 4 15000015 * SET INCREMENT REGISTERS AND BRANCH TO INITIALISATION 15100015 SPACE 15200015 DC C'JD' 15300015 L BASE,PAR1 LOAD PROGRAM BASE REGISTER 15400015 LA UNIT,1 LOAD REG WITH 1 15500015 LA FIVE,5 LOAD REG WITH 5 15600015 LA SPR,1000 SET SPR TO LOOP FOR SCRATCH CORE 15700015 BC B,INIT1 15800015 EJECT 15900015 SPACE 16000015 * INITIALISATION 16100015 * 16200015 * THIS SECTION IS ENTERED ONLY ONCE, AT THE BEGINING OF 16300015 * THE PHASE. ITS FUNCTIONS ARE - 16400015 * 16500015 * 1. TO INSERT CURRENT PHASE ID INTO NAME SLOT 16600015 * 16700015 * 2. TO SET TSR AT ADDRESS OF FIRST TEXT BLOCK 16800015 * 16900015 * 3. TO OBTAIN SCRATCH CORE FOR STACK, INITIALISE 17000015 * POINTER, AND SET STACK LIMITS. 17100015 * 17200015 * ENTRY POINT INIT1 FROM START 17300015 * 17400015 * EXTERNAL ROUTINES - ZTXTAB,ZUGC,ZURC,RLSCTL 17500015 * 17600015 * EXITS (NORMAL) - NOREX (TO SCANT) 17700015 * 17800015 * (ERROR) - RELESE (TO RLSCTL, DROP PHASE) 17900015 SPACE 2 18000015 INIT1 MVC ZMYNAM(2),NAME SET PHASE NAME IN COMM SLOT 18100015 SPACE 18200015 INIT2 MVC PAR1+1(3),STARTX+1 PUT TEXT REF IN LAST 3 BYTES 18300015 L EREG,STARTX PUT FIRST TEXT BLOCK REFERENCE 18400015 ST EREG,TREF INTO TREF 18500015 L BR,ZTABOF LOAD BRANCH REG WITH ZTXTAB ADDR 18600015 BALR LR,BR BRANCH TO OBTAIN TEXT ADDRESS 18700015 L TSR,PAR1 POINT TSR AT FIRST TEXT BLOCK 18800015 SPACE 18900015 INIT3 LA EREG,2 SET PAR1 TO CALL FOR TWO 512 BYT 19000015 ST EREG,PAR1 BLOCKS OF SCRATCH CORE FOR THE 19100015 * STACK USED IN SCANT. 19200015 L BR,ZUGOFF LOAD BR WITH ZUGC ADDRESS 19300015 BALR LR,BR BRANCH TO ZUGC FOR SCRATCH CORE 19400015 SPACE 19500015 * CHECK HERE FOR CORE AVAILIBILITY 19600015 SPACE 19700015 L EREG,PAR2 SCRATCH SIZE IN EREG 19800015 LTR EREG,EREG SET CONDITION CODE 19900015 BC BZ,NOCORE BRANCH IF ZERO 20000015 LA OREG,1024 SET OREG TO NOMINAL STACK SIZE 20100015 CR EREG,OREG COMPARE SIZES 20200015 BC BL,NOTALL BRANCH IF ALLOCATION IS LOW 20300015 MVI STSIZE,X'02' STACK SIZE TO 2 BLOCKS 20400015 SPACE 20500015 SSADDR L SPR,PAR1 SET STACK POINTER TO ADDRESS OF 20600015 ST SPR,BSTACK BOTTOM OF STACK, AND SET BSTACK 20700015 AR EREG,SPR SLOT. SET ADDR OF STACK TOP LIMIT 20800015 ST EREG,TSTACK IN TSTACK. 20900015 SR SPR,UNIT POSITION STACK POINTER 21000015 SR SPR,UNIT TWO BYTES ABOVE THE STACK 21100015 NOREX BC B,SCANT BRANCH TO SCANT (MAIN) ROUTINE 21200015 SPACE 21300015 NOTALL LA OREG,512 SET OREG TO 1/2 NOMINAL SIZE 21400015 CR EREG,OREG COMPARE 21500015 BC BL,NOCORE BRANCH IF STILL LOW 21600015 MVI STSIZE,X'01' SET SIZE FLAG TO INDIC. 1 BLOCK 21700015 BC B,SSADDR BRANCH TO SET STACK ADDRESS 21800015 SPACE 21900015 NOCORE MVI STSIZE,X'00' SET SIZE TO ZERO 22000015 ST UNIT,PAR1 SET PAR1 TO 1 22100015 L BR,ZUROFF LOAD ZURC ADDRESS 22200015 BALR LR,BR BRANCH TO RELEASE LAST SCRATCH 22300015 BCT SPR,INIT3 RETURN TO TRY AGAIN, SPR NOT 0 22400015 SPACE 22500015 * NO CORE WAS ALLOCATED FOR THE STACK. THIS OPTIMISATION 22600015 * PHASE WILL BE RELEASED AND CONTROL PASSED NORMALLY TO 22700015 * THE NEXT PHASE 22800015 SPACE 22900015 RELESE BC B,RETURN BRANCH TO END OF SCANT 23000015 EJECT 23100015 SPACE 23200015 * MAIN PROGRAM - SCANT 23300015 * 23400015 * 23500015 * THE TEXT IS SCANNED FOR TRIPLES OF POTENTIAL 23600015 * INTEREST, I.E. UNARY PREFIX,CONCATENATION, OR ARITHMETIC 23700015 * OPERATORS. 23800015 * 23900015 * WHEN FOUND, THE APPROPRIATE ROUTINE IS CALLED TO 24000015 * INVESTIGATE THE OPERANDS AND, IF BOTH CONSTANT, TO CARRY 24100015 * OUT THE OPERATION, MAKE A NEW DICTIONARY ENTRY WHERE 24200015 * NECESSARY, AND NULL THE TRIPLE. 24300015 * 24400015 * THE RESULTING REFERENCE IS PASSED, VIA A STACK, 24500015 * INTO ITS RESULT SLOT, STACKING AND UNSTACKING DUMMY ZERO 24600015 * REFERENCES AS REQUIRED TO ACHIEVE CORRESPONDENCE. 24700015 * 24800015 * 24900015 * ENTRY POINT SCANT FROM INITIALISATION SECTION 25000015 * 25100015 * EXTERNAL ROUTINES - ZCHAIN,ZABORT 25200015 * 25300015 * INTERNAL ROUTINES - MORTXT,UNSTAK,PREFIX,CONCAT 25400015 * 25500015 * EXITS (NORMAL) - RETURN (TO RLSCTL) 25600015 * 25700015 * (ERROR) - OUT (TO ZABORT ) 25800015 SPACE 4 25900015 SCANT MVI SFLAG,X'00' ZERO STACK FLAG BYTE 26000015 SPACE 26100015 TRTEST SR TIR,TIR ZERO INDEX RETURN REG 26200015 TRT 0(1,TSR),TRTAB TRANSLATE AND TEST 26300015 BC BZ,NOTHIN BRANCH IF TRIPLE UNWANTED 26400015 BORIG BC B,BORIG(TIR) BRANCH DOWN BRANCH LIST 26500015 BC B,ERROR ERROR - ILLEGAL TRIPLE 04 26600015 BC B,ENDEX END OF EXPRESSION TRIPLE 08 26700015 BC B,CON CONCATENATE 0C 26800015 BC B,RES RESULT GIVER 10 26900015 BC B,PRE PREFIX 14 27000015 BC B,ENDPGM END OF PROGRAM 2 18 27100015 BC B,ENDTXT END OF TEXT BLOCK 1C 27200015 SPACE 27300015 * THE FOLLOWING ARE TRIPLES WHICH MAY HAVE '0000' 27400015 * UNUSED OPERANDS. NO RESULT MUST BE UNSTACKED. 27500015 SPACE 27600015 BC B,UPTXT IGNORE TRIPLE 20 27700015 BC B,RESIG RESULT GIVING IGNORE TRIPLE 24 27800015 SPACE 2 27900015 BC B,MULTAS MULTIPLE ASSIGN TRIPLE 28 28000015 * (SPECIAL CASE) 28100015 SPACE 2 28200015 * NORMAL CONDITIONS 28300015 SPACE 28400015 NOTHIN MVI TFLAG,X'FF' INERT TRIPLE, SET TFLAG TO SUIT 28500015 CLI SFLAG,X'00' 28600015 BC BE,UPTXT 28700015 BC B,SECOND 28800015 * (MAY ACCEPT, BUT NOT GIVE, RESULT) 28900015 RES MVC STEMP(2),FZERO RESULT PRODUCER, SET STEMP TO 0 29000015 BC B,STAKOP AND BRANCH TO UNSTACK/STACK OPS. 29100015 RESIG MVC STEMP(2),FZERO SET STEMP TO '0000' 29200015 BC B,ENTRY1 AND BRANCH TO STACK IT, MAYBE. 29300015 PRE BAL LR,PREFIX CALL PREFIX 29400015 BC B,STAKOP AND BRANCH TO UNSTACK/STACK OPS. 29500015 CON BAL LR,CONCAT CALL CONCAT 29600015 BC B,STAKOP AND BRANCH TO UNSTACK/STACK OPS. 29700015 ENDTXT BAL LR,MORTXT CALL IN NEXT TEXT BLOCK 29800015 BC B,TRTEST BRANCH TO NEXT TEST 29900015 SPACE 2 30000015 * THE FOLLOWING REPRESENT ERROR CONDITIONS, CAUSED BY THE 30100015 * DISCOVERY OF AN ILLEGAL TRIPLE TYPE, OR BY THE PREMATURE 30200015 * TERMINATION OF THE EXPRESSION, OR RUNNING OUT OF STACK 30300015 SPACE 30400015 ERROR BC B,NOTHIN TREAT AS INERT - LEAST DANGEROUS 30500015 SPACE 30600015 ENDEX CLI SFLAG,X'00' TEST FOR EMPTY STACK 30700015 BC BE,UPTXT OK IF IT IS. OTHERWISE - 30800015 MVC LNKWD(8),ENDX FLAG - PREMATURE END OF EXPRN. 30900015 BC B,OUT 31000015 SPACE 31100015 ENDPGM CLI SFLAG,X'00' TEST FOR EMPTY STACK 31200015 BC BE,WINDUP IF SO, BRANCH TO FINISH 31300015 MVC LNKWD(8),ENDP FLAG - PREMATURE END OF PROGRAM 31400015 BC B,OUT 31500015 SPACE 31600015 SETMTY MVC LNKWD(8),EMPTY FLAG - PREMATURELY EMPTY STACK 31700015 BC B,OUT 31800015 SPACE 31900015 SETFUL MVC LNKWD(8),FULL FLAG - PREMATURELY FULL STACK 32000015 BC B,OUT 32100015 SPACE 2 32200015 * OPERAND STACKING/UNSTACKING 32300015 SPACE 32400015 STAKOP CLI SFLAG,X'00' 32500015 BC BE,UPTXT SKIP STACKING IF STACK EMPTY 32600015 CLC 1(4,TSR),FZERO TEST IF BOTH OPERANDS ZERO 32700015 BC BNE,STACAT BRANCH ROUND IF NOT 32800015 SPACE 32900015 LA EREG,3 UNSTACK INTO SECOND OPERAND 33000015 BAL LR,UNSTAK BEFORE THE FIRST ONE, 33100015 BC B,TRYFLG - EMPTY STACK RETURN - 33200015 LA EREG,1 TO ENSURE CORRECT FUNCTION 33300015 BC B,STAPRE OF RESULT TRIPLE 33400015 STACAT DS 0H 33500015 CLC FZERO(2),1(TSR) TEST FIRST OPERAND FOR ZEROS 33600015 BC BNE,SECOND 33700015 LA EREG,1 SET EREG TO 1 33800015 BAL LR,UNSTAK BRANCH TO UNSTACK 33900015 BC B,TRYFLG EMPTY STACK RETURN 34000015 SECOND CLC FZERO(2),3(TSR) TEST SECOND OPERAND FOR ZEROS 34100015 BC BNE,TRYFLG 34200015 LA EREG,3 SET EREG TO 3 34300015 STAPRE DS 0H 34400015 BAL LR,UNSTAK BRANCH TO UNSTACK 34500015 BC NOP,TRYFLG EMPTY STACK NO-OP 34510015 CLI 0(TSR),X'42' IS THIS A FUNCTION COMMA 34530015 BC BE,FNCM 34560015 TRYFLG CLI TFLAG,X'FF' TEST TRIPLE FLAG 34700015 BC BE,UPTXT 34800015 ENTRY1 DS 0H 34900015 CLI SFLAG,X'00' SEE IF STACK FLAG IS STILL ON 35000015 BC BNE,ENTRY2 IF SO, MAKE ENTRY IMMEDIATELY 35100015 CLC STEMP(2),FZERO TEST IF GENUINE REF 35200015 BC BE,STEST NO. BRANCH ROUND 35300015 OI SFLAG,X'01' YES. ENSURE SFLAG IS STILL SET 35400015 ENTRY2 DS 0H 35500015 LA SPR,2(SPR) INCREMENT SPR BY 2 35600015 MVC 0(2,SPR),STEMP MAKE NEW STACK ENTRY 35700015 SPACE 35800015 * NOW TO TEST FOR A FULL STACK 35900015 SPACE 36000015 STEST DS 0H 36100015 L OREG,TSTACK SET OREG TO TOP OF STACK 36200015 CR OREG,SPR TEST SPR 36300015 BC BE,SETFUL BRANCH IF FULL (ERROR) 36400015 UPTXT AR TSR,FIVE INCREMENT TSR 36500015 MVI TFLAG,X'00' RESET TRIPLE FLAG 36600015 BC B,TRTEST BRANCH TO NEXT TEST 36700015 FNCM EQU * 36710015 MVC PAR1+2(2),3(TSR) D.R. OF JD CREATED ENTRY 36720015 L BR,ZDFAOF 36730015 BALR LR,BR 36740015 L LR,PAR1 36750015 NI 8(LR),X'FE' SET LAST BIT OFF 36760015 MVC 9(3,LR),5(LR) MOVE SOURCE DED TO TARGET DED 36770015 BC B,TRYFLG 36780015 SPACE 2 36800015 * MULTIPLE ASSIGNMENT TRIPLE PROCESSOR. 36900015 * 37000015 * SPECIAL TREATMENT IS NECESSARY, AS THE STACK POINTER MUST NOT 37100015 * BE RESET DURING MULTIPLE ASSIGNMENT OF RESULTS. 37200015 * 37300015 MULTAS DS 0H 37400015 CLI SFLAG,X'00' IF STACK IS EMPTY, 37500015 BC BE,UPTXT DO NOTHING. 37600015 CLC FZERO(2),3(TSR) ELSE MOVE RESULT INTO OPERAND 37700015 BC BNE,UPTXT 2 IF IT'S ZERO, 37800015 MVC 3(2,TSR),0(SPR) AND BUMP ON 37900015 BC B,UPTXT TO NEXT TRIPLE. 38000015 SPACE 4 38100015 * ERROR EXIT VIA ZABORT 38200015 SPACE 38300015 OUT STM 0,15,NEWAR+284 STORE REGISTERS AT END OF NEWAR 38400015 MVC PAR6(4),M1076 COMPILER ERROR IN PHASE JD 38500015 L BR,ZUEROF LOAD ZUERR ADDRESS, AND BRANCH 38600015 BALR LR,BR TO PUT OUT TERMINAL MESSAGE 38700015 L BR,ZBOFF SET BR TO ZABORT OFFSET, AND 38800015 BALR LR,BR MAKE ERROR RETURN 38900015 SPACE 2 39000015 * NORMAL EXIT 39100015 SPACE 39200015 WINDUP DS 0H 39300015 L EREG,TREF PUT CURRENT TEXT REF 39400015 ST EREG,PAR1 INTO PAR1 39500015 SR EREG,EREG SET PAR2 39600015 IC EREG,UNWANT TO INDICATE THAT 39700015 ST EREG,PAR2 CURRENT TEXT BLOCK IS UNWANTED 39800015 L BR,ZALTOF LOAD ZALTER ADDRESS 39900015 BALR LR,BR AND BRANCH TO CHANGE BLOCK STATUS 40000015 SPACE 40100015 RELCOR ST UNIT,PAR1 SET PAR1 TO ONE 40200015 L BR,ZUROFF LOAD ZURC ADDRESS IN BR 40300015 BALR LR,BR BRANCH TO RELEASE SCRATCH 40400015 SPACE 40500015 RETURN LA EREG,NAME SET PHASE LIST ADDRESS 40600015 ST EREG,PAR1 INTO PAR1 40700015 SR EREG,EREG ZERO REG 40800015 ST EREG,PAR2 INTO PAR2 40900015 L BR,RLSCOF LOAD RLSCTL ADDRESS IN BR 41000015 BALR LR,BR BRANCH TO RELEASE CONTROL 41100015 EJECT 41200015 SPACE 41300015 * ROUTINE TO CALL IN NEXT TEXT BLOCK AND RESET SCAN REG 41400015 SPACE 2 41500015 MORTXT ST LR,LNKWD SAVE RETURN ADDRESS 41600015 L EREG,TREF PUT CURRENT TEXT REF 41700015 ST EREG,PAR1 INTO PAR1 41800015 SR OREG,OREG PUT STATUS 41900015 IC OREG,UNWANT (UNWANTED) 42000015 ST OREG,PAR2 INTO PAR2 42100015 L BR,ZCHOFF LOAD BR WITH ADDRESS OF ZCHAIN 42200015 BALR LR,BR BRANCH TO GET NEXT TEXT BLOCK 42300015 SPACE 42400015 L EREG,PAR1 RESET CURRENT 42500015 ST EREG,TREF TEXT REFERENCE FROM PAR1 42600015 L TSR,PAR2 REPOINT TEXT SCAN REGISTER 42700015 L LR,LNKWD RESTORE 42800015 BCR B,LR RETURN 42900015 SPACE 4 43000015 * ROUTINE TO MOVE AN ENTRY FROM THE RESULTS STACK 43100015 SPACE 2 43200015 UNSTAK AR EREG,TSR SET EREG TO NEXT OPERAND ADDRESS 43300015 L OREG,BSTACK SET OREG TO BOTTOM OF STACK ADDR 43400015 CR OREG,SPR TEST FOR EMPTY STACK 43500015 BC BH,SETMTY BRANCH IF EMPTY ** ERROR ** 43600015 MVC 0(2,EREG),0(SPR) MOVE HALFWORD FROM STACK INTO OP 43700015 SR SPR,UNIT DECREMENT 43800015 SR SPR,UNIT SPR BY 2 43900015 CR OREG,SPR TEST IF NOW EMPTY 44000015 BC BNH,4(LR) NO. RETURN 4 BYTES ON 44100015 MVI SFLAG,X'00' YES. TURN SFLAG OFF 44200015 BCR B,LR AND RETURN TO BRANCH INST. 44300015 EJECT 44400015 SPACE 2 44500015 * ROUTINE PREFIX. 44600015 * 44700015 * WILL DEAL WITH PREFIX + AND PREFIX -. 44800015 * 44900015 * IN THE CASE OF PREFIX PLUS, THE TRIPLE WILL BE MADE NULL 45000015 * AND THE DICTIONARY REFERENCE PUT INTO THE TEMPARY STACK. 45100015 * 45200015 * IN THE CASE OF PREFIX MINUS, THE TRIPLE WILL BE MADE 45300015 * NULL AND A NEW DICTIONARY REFERENCE MADE FOR A NEGATIVE 45400015 * CONSTANT. 45500015 * 45600015 * REG1 CONTAINS POINTER TO TEXT. 45700015 * 45800015 PREFIX ST LR,LNKWD STORE RETURN ADDRESS 45900015 CLC 3(2,TSR),FZERO TEST REF FOR ZERO 46000015 BC BE,ZERENT 46100015 XC PAR1(8),PAR1 ZERO PAR1 AND PAR2 46200015 MVC PAR1+2(2),3(TSR) MOVE DICTIONARY REF. INTO PAR1. 46300015 L BR,ZDFAOF LOAD BR WITH ADDRESS OF ZDRFAB. 46400015 BALR LR,BR 46500015 L TIR,PAR1 LOAD TIR WITH ABS. ADDR. OF 46600015 * DICTIONARY ENTRY. 46700015 CLI 0(TIR),UNICON IS ENTRY A CONSTANT. 46800015 BC BNE,ZERENT NO. 46900015 TM 8(TIR),STERL WAS THIS A STERLING CONSTANT ? 47000015 BC BO,ZERENT IGNORE IF SO, TO AVOID 47100015 * CONVERSION TROUBLES WITH BLANKS. 47200015 TM 5(TIR),STRING IS ENTRY A STRING 47300015 BC BZ,ZERENT YES-SKIP THIS ENTRY 47400015 * NEXT TEST FOR PREFIX PLUS OR MINUS 47500015 CLI 0(TSR),UPLUS 47600015 BC BNE,PREMIN MINUS - GO TO PREMIN. 47700015 MVC STEMP(2),3(TSR) PUT DICREF INTO STEMP. 47800015 SETFLG MVI SFLAG,X'02' SET SFLAG TO 02 47900015 MVI 0(TSR),NULL MAKE TRIPLE NULL. 48000015 PREND L LR,LNKWD RETURN TO MAIN PROGRAM. 48100015 BCR B,LR 48200015 SPACE 2 48300015 * SET UP A ZERO ENTRY IN STEMP AND GO TO END OF ROUTINE. 48400015 * 48500015 SPACE 2 48600015 ZERENT MVC STEMP(2),FZERO SET STEMP=0. 48700015 BC B,PREND RETURN TO MAIN PROGRAM. 48800015 SPACE 2 48900015 * 49000015 * CHANGE SIGN OF PREFIX MINUS CONSTANT. 49100015 * 49200015 SPACE 2 49300015 PREMIN MVC WORKDC(2),1(TIR) MOVE TOTAL LENGTH OF ENTRY TO 49400015 LH EREG,WORKDC WORKAREA. 49500015 SPACE 49600015 MVC NEWAR(14),0(TIR) 49700015 MVC NEWAR+3(2),ZCONCH POINT ADDR. TO FIRST ELEMENT IN 49800015 * CHAIN. 49900015 AR EREG,UNIT ADD 1 TO LENGTH. 50000015 STH EREG,WORKDC 50100015 MVC NEWAR+1(2),WORKDC 50200015 SPACE 50300015 MVI NEWAR+14,MINUS SET MINUS IN ENTRY 50400015 SPACE 50500015 SH EREG,FRTEEN EREG CONTAINS SIZE OF CONSTANT. 50600015 EX EREG,MVC MOVE CONSTANT. 50700015 SPACE 2 50800015 * SET UP PAR1 AND PAR2 FOR ZDICREF CALL. 50900015 * 51000015 MVC PAR2+2(2),NEWAR+1 LENGTH OF ENTRY. 51100015 LA EREG,NEWAR 51200015 ST EREG,PAR1 ADDRESS OF ENTRY. 51300015 SPACE 2 51400015 L BR,ZDCROF 51500015 BALR LR,BR 51600015 MVC ZCONCH(2),PAR1+2 PUT NEW CHAIN POINTER IN ZCONCH 51700015 MVC STEMP(2),PAR1+2 PUT NEW DICREF INSTEMP. 51800015 BC B,SETFLG 51900015 EJECT 52000015 * 52100015 * CONCATENATION ROUTINE. WILL CONCATENATE BOTH ENTRIES AND 52200015 * CREATE A NEW DICTIONARY ENTRY. 52300015 * 52400015 SPACE 52500015 CONCAT ST LR,LNKWD STORE RETURN ADDRESS. 52600015 XC PAR1(8),PAR1 ZERO PAR1 AND PAR2 52700015 LA TIR,NEWAR 52800015 CLC 1(4,TSR),FZERO 52900015 BC BE,CONZER 53000015 CLC 1(2,TSR),FZERO IS 1ST OPERAND 00. 53100015 BC BE,PKSTK YES 53200015 MVC PAR1+2(2),1(TSR) NO SET UP PARAMETERS FOR ZDRFAB 53300015 LOADZ1 L BR,ZDFAOF 53400015 BALR LR,BR 53500015 L EREG,PAR1 LOAD EREG WITH ABSOLUTE ADDRESS 53600015 * OF DICTIONARY ENTRY1. 53700015 SPACE 2 53800015 CLC 3(2,TSR),FZERO IS SECOND OPERAND 00. 53900015 BC BE,PK2STK 54000015 MVC PAR1+2(2),3(TSR) NO SET UP PAR1 FOR ZDRFAB 54100015 LOADZ2 L BR,ZDFAOF 54200015 BALR LR,BR 54300015 L OREG,PAR1 LOAD OREG WITH ABSOLUTE ADDRESS 54400015 * OF DICTIONARY ENTRY2. 54500015 SPACE 2 54600015 CLI 0(EREG),UNICON IS FIRST ENTRY A CONSTANT. 54700015 BC BNE,CONZER NO. 54800015 CLI 0(OREG),UNICON IS 2ND ENTRY A CONSTANT. 54900015 BC BNE,CONZER NO. 55000015 SPACE 2 55100015 TM 5(EREG),STRING IS ENTRY1 A STRING. 55200015 BC BO,CONZER NO 55300015 TM 5(OREG),STRING IS ENTRY2 A STRING. 55400015 BC BO,CONZER NO 55500015 SPACE 2 56400015 * WE MUST NOW DETERMINE WHETHER EITHER OF THE ENTRIES 56500015 * IS A NULL LENGTH STRING. 56600015 SPACE 56700015 CRENT EQU * 56800015 CLC 6(2,EREG),FZERO 56900015 BC BNE,CRENT1 57000015 CLC 3(2,TSR),FZERO WAS THE OPERAND ZERO ? 57100015 BC BE,CRENT3 BRANCH IF SO 57200015 MVC PAR1+2(2),3(TSR) ELSE - SET PAR1 FROM TEXT 57300015 BC B,NULCON 57400015 CRENT1 EQU * 57500015 CLC 6(2,OREG),FZERO 57600015 BC BNE,CRENT2 57700015 CLC 1(2,TSR),FZERO WAS THE OPERAND ZERO ? 57800015 BC BE,CRENT3 BRANCH IF SO 57900015 MVC PAR1+2(2),1(TSR) ELSE - SET PAR1 FROM TEXT 58000015 BC B,NULCON 58100015 CRENT3 DS 0H 58200015 MVC PAR1+2(2),0(SPR) SET PAR1 FROM THE STACK 58300015 BC B,NULCON AND BRANCH OUT. 58400015 CRENT2 EQU * 58500015 MVC WORKDC(2),1(EREG) 58600015 LH BR,WORKDC PICK UP LENGTH OF ENTRY1. 58700015 MVC WORKDC(2),1(OREG) 58800015 AH BR,WORKDC ADD LENGTH OF ENTRY2 58900015 S BR,SIZE SUB 28. 59000015 C BR,THOW IS IT GREATER THAN 1000. 59100015 BC BH,CONZER YES 59200015 * 59300015 * NO CREATE NEW DICTIONARY ENTRY IN NEWAR (FOR A 59400015 * CHARACTER STRING. 59500015 SPACE 2 59600015 STH BR,WORKDC 59700015 MVC 6(2,TIR),WORKDC 59800015 MVI 0(TIR),UNICON SET 88 IN 1ST BYTE. 59900015 MVC 3(2,TIR),ZCONCH HASH CHAIN 60000015 AH BR,FRTEEN 60100015 LR R8,BR 60200015 MVC 5(1,TIR),5(EREG) MOVE DATA BYTE 60300015 CLC 5(1,EREG),5(OREG) BOTH STRINGS SAME TYPE ? 60320015 BC BE,CRENT4 OK IF SO, ELSE, FOR MIXED, 60340015 OI 5(TIR),CHRBIT ENSURE RESULT IS CHARACTER. 60360015 CRENT4 DS 0H 60380015 MVC 8(1,TIR),8(EREG) TYPE. 60400015 OI 8(TIR),X'01' (ENSURE NO-CONVERSION BIT IS ON) 60450015 MVC 9(4,TIR),FZERO 60500015 MVC 13(1,TIR),FZERO 60600015 L LR,MASK STORE 255 IN LR 60700015 LH BR,6(EREG) LENGTH OF ENTRY1 60800015 MVC WORKDC(2),FZERO ZEROISE WORK AREA 60900015 LA TIR,14(TIR) MOVE POINTER OF OUTPUT 61000015 EX1 SR BR,UNIT 61100015 EX BR,EVNMVC MOVE UP TO 256 CHARS 61200015 AR TIR,UNIT 61300015 STC BR,WORKDC+1 61400015 AH TIR,WORKDC OF CHARS. INSERTED INTO NEWAR. 61500015 CLR BR,LR 61600015 BC 12,ALLEVN BRANCH IF REGISTER EQUAL 61700015 SH BR,WORKDC 61800015 AH EREG,WORKDC 61900015 AR EREG,UNIT INCREMENT POINTER TO ENTRY1 62000015 BC B,EX1 62100015 ALLEVN LH BR,6(OREG) LENGTH OF ENTRY2 62200015 EX2 SR BR,UNIT 62300015 EX BR,ODDMVC MOVE UP TO 256 CHARS FROM 62400015 CLR BR,LR ENTRY2 62500015 BC 12,NULLTR 62600015 AR TIR,UNIT 62700015 STC BR,WORKDC+1 INCREMENT TIR 62800015 AH TIR,WORKDC 62900015 SH BR,WORKDC 63000015 AH OREG,WORKDC 63100015 AR OREG,UNIT INCREMENT ENTRY2 POINTER 63200015 BC B,EX2 63300015 NULLTR EQU * 63400015 STH R8,WORKDC 63500015 LA EREG,NEWAR POINT EREG AT NEW ENTRY 63600015 MVC 1(2,EREG),WORKDC MOVE IN THE LENGTH 63700015 ST EREG,PAR1 ADDRESS IN PAR1 63800015 ST R8,PAR2 LENGTH IN PAR2 63900015 L BR,ZDCROF 64000015 BALR LR,BR PUT ENTRY INTO DICTIONARY. 64100015 MVC ZCONCH(2),PAR1+2 NEW CHAIN POINTER IN ZCONCH. 64200015 NULCON EQU * 64300015 MVI 0(TSR),NULL MAKE TRIPLE NULL. 64400015 MVC STEMP(2),PAR1+2 NEW CHAIN POINTER IN STEMP. 64500015 STC UNIT,SFLAG SET FLAG=1. 64600015 CONEND L LR,LNKWD 64700015 BCR B,LR RETURN. 64800015 CONZER MVC STEMP(2),FZERO PUT ZERO ENTRY IN STEMP. 64900015 BC B,CONEND 65000015 SPACE 2 65100015 PKSTK DS 0H 65200015 CLI SFLAG,X'00' TEST FOR EMPTY STACK 65300015 BC BE,CONZER 65400015 CLC 0(2,SPR),FZERO TEST REF FOR ZERO 65500015 BC BE,CONZER 65600015 MVC PAR1+2(2),0(SPR) PICK UP LAST DICREF FROM STACK 65700015 * STORE IN PAR1. 65800015 BC B,LOADZ1 65900015 SPACE 2 66000015 PK2STK DS 0H 66100015 CLI SFLAG,X'00' TEST FOR EMPTY STACK 66200015 BC BE,CONZER 66300015 CLC 0(2,SPR),FZERO TEST REF FOR ZERO 66400015 BC BE,CONZER 66500015 MVC PAR1+2(2),0(SPR) NO 66600015 BC B,LOADZ2 66700015 EJECT 67500015 * EXECUTE INSTRUCTIONS 67600015 SPACE 2 67700015 MVC MVC NEWAR+15(0),14(TIR) 67800015 EVNMVC MVC 0(0,TIR),14(EREG) 67900015 ODDMVC MVC 0(0,TIR),14(OREG) 68000015 SPACE 4 68100015 * DEFINED CONSTANTS 68200015 SPACE 2 68300015 LNKWD DC F'0' STORE LINK ADDRESS 68400015 BSTACK DC F'0' BOTTOM STACK LIMIT ADDR 68500015 TSTACK DC F'0' TOP STACK LIMIT ADDR 68600015 TREF DC F'0' CURRENT TEXT BLOCK REFERENCE 68700015 FZERO DC F'0' ZERO FULL WORD 68800015 NEWAR DC 300F'0' NEW AREA 68900015 ********************************************************************** 68910015 PATCH DC 30F'0' PATCH AREA 68920015 ********************************************************************** 68930015 ENDX DC C'ENDXXXXX' DUMP FLAGS. 68940015 ENDP DC C'ENDPPPPP' DUMP FLAGS. 68950015 EMPTY DC C'EMPTYSSS' DUMP FLAGS. 68960015 FULL DC C'FULLSSSS' DUMP FLAGS. 68970015 UNWANT DC X'02' 68980015 FRTEEN DC H'14' FOURTEEN 69000015 STEMP DC H'0' TEMPORARY STACK HALFWORD 69100015 NAME DC C'JDZZ' PHASE ID NAME AND TERM CODE 69200015 WORKDC DC F'0' WORK WORD 69300015 TWO DC F'2' TWO 69400015 STSIZE DC X'02' STACK SIZE IN 1/2 K BLOCKS 69500015 SFLAG DC X'00' STACK FLAG 69600015 WBYTE DC C' ' WORK BYTE 69700015 AFLAG DC X'00' STACK ACCESS FLAG 69800015 SIZE DC F'28' 2*PRE-BCD LENGTH FOR DICT CONST 69900015 THOW DC F'1000' THOUSAND - CONCATENATION LIMIT 70000015 MASK DC F'255' MASK TO AND OUT FIRST 3 BYTES 70100015 TFLAG DC X'00' TRIPLE FLAG 70200015 M1076 DC X'00043400' COMPILER ERROR IN PHASE JD 70300015 EJECT 70400015 SPACE 4 70500015 * TRANSLATE AND TEST TABLE 70600015 SPACE 2 70700015 DS 0F 70800015 TRTAB DC X'04' 00 70900015 DC X'04' 01 71000015 DC X'04' 02 71100015 DC X'04' 03 71200015 DC X'00' 04 71300015 DC X'00' 05 71400015 DC X'00' 06 71500015 DC X'00' 07 71600015 DC X'00' 08 71700015 DC X'04' 09 71800015 DC X'00' 0A 71900015 DC X'00' 0B 72000015 DC X'04' 0C 72100015 DC X'00' 0D 72200015 DC X'04' 0E 72300015 DC X'00' 0F 72400015 DC X'00' 10 72500015 DC X'04' 11 72600015 DC X'00' 12 72700015 DC X'00' 13 72800015 DC X'00' 14 72900015 DC X'00' 15 73000015 DC X'00' 16 73100015 DC X'00' 17 73200015 DC X'00' 18 73300015 DC X'00' 19 73400015 DC X'00' 1A 73500015 DC X'00' 1B 73600015 DC X'00' 1C 73700015 DC X'00' 1D 73800015 DC X'00' 1E 73900015 DC X'00' 1F 74000015 DC X'00' 20 74100015 DC X'00' 21 74200015 DC X'00' 22 74300015 DC X'00' 23 74400015 DC X'00' 24 74500015 DC X'00' 25 74600015 DC X'04' 26 74700015 DC X'20' 27 BUY CHAMELEON 74800015 DC X'00' 28 74900015 DC X'04' 29 75000015 DC X'04' 2A 75100015 DC X'04' 2B 75200015 DC X'04' 2C 75300015 DC X'04' 2D 75400015 DC X'20' 2E **** 75500015 DC X'04' 2F 75600015 DC X'20' 30 **** 75700015 DC X'04' 31 75800015 DC X'20' 32 **** 75900015 DC X'04' 33 76000015 DC X'20' 34 **** 76100015 DC X'04' 35 76200015 DC X'04' 36 76300015 DC X'00' 37 76400015 DC X'00' 38 76500015 DC X'04' 39 76600015 DC X'20' 3A **** 76700015 DC X'04' 3B 76800015 DC X'20' 3C **** 76900015 DC X'04' 3D 77000015 DC X'20' 3E **** 77100015 DC X'00' 3F 77200015 DC X'04' 40 77300015 DC X'00' 41 COMMA 77400015 DC X'00' 42 FUNCTION COMMA 77500015 DC X'04' 43 77600015 DC X'00' 44 COMPILER FUNCTION COMMA 77700015 DC X'00' 45 77800015 DC X'00' 46 COMPILER ASSIGN 77900015 DC X'00' 47 ASSIGN 78000015 DC X'00' 48 78100015 DC X'0C' 49 CONCATENATE 78200015 DC X'00' 4A 78300015 DC X'10' 4B OR (RESULT GIVING). 78400015 DC X'04' 4C 78500015 DC X'10' 4D AND 78600015 DC X'04' 4E 78700015 DC X'10' 4F NOT 78800015 DC X'04' 50 78900015 DC X'04' 51 79000015 DC X'00' 52 79100015 DC X'00' 53 79200015 DC X'00' 54 79300015 DC X'00' 55 79400015 DC X'00' 56 79500015 DC X'28' 57 MULTIPLE ASSIGNMENT 79600015 DC X'20' 58 TMPD. 79700015 DC X'04' 59 79800015 DC X'04' 5A 79900015 DC X'00' 5B 80000015 DC X'00' 5C 80100015 DC X'04' 5D 80200015 DC X'24' 5E LITC 52164 80300064 DC X'00' 5F 80400015 DC X'00' 60 80500015 DC X'00' 61 80600015 DC X'00' 62 80700015 DC X'00' 63 80800015 DC X'04' 64 80900015 DC X'10' 65 LESS/EQUAL. 81000015 DC X'04' 66 81100015 DC X'10' 67 GREATER/EQUAL. 81200015 DC X'00' 68 81300015 DC X'10' 69 NOT EQUAL. 81400015 DC X'04' 6A 81500015 DC X'10' 6B EQUAL. 81600015 DC X'04' 6C 81700015 DC X'10' 6D GREATER. 81800015 DC X'20' 6E **** 81900015 DC X'10' 6F LESS 82000015 DC X'24' 70 C*F' 52164 82100064 DC X'04' 71 82200015 DC X'20' 72 **** 82300015 DC X'10' 73 - MINUS 82400015 DC X'20' 74 COMPILER PS-VARIABLE 82500015 DC X'10' 75 + PLUS. 82600015 DC X'00' 76 82700015 DC X'10' 77 DIVIDE. 82800015 DC X'04' 78 82900015 DC X'10' 79 MULTIPLY. 83000015 DC X'20' 7A PSEUDO VARIABLE 83100015 DC X'14' 7B PREFIX MINUS 83200015 DC X'24' 7C FUNCTION PRIMED 83300015 DC X'14' 7D PREFIX PLUS 83400015 DC X'24' 7E SUBSCRIPT PRIMED 83500015 DC X'10' 7F EXPONENTIATE. 83600015 DC X'00' 80 83700015 DC X'00' 81 83800015 DC X'00' 82 83900015 DC X'00' 83 84000015 DC X'20' 84 **** 84100015 DC X'04' 85 84200015 DC X'00' 86 84300015 DC X'04' 87 84400015 DC X'04' 88 84500015 DC X'04' 89 84600015 DC X'04' 8A 84700015 DC X'00' 8B 84800015 DC X'00' 8C 84900015 DC X'00' 8D 85000015 DC X'04' 8E 85100015 DC X'00' 8F 85200015 DC X'00' 90 85300015 DC X'00' 91 85400015 DC X'00' 92 85500015 DC X'04' 93 85600015 DC X'00' 94 85700015 DC X'00' 95 85800015 DC X'00' 96 85900015 DC X'00' 97 86000015 DC X'00' 98 86100015 DC X'00' 99 86200015 DC X'00' 9A 86300015 DC X'04' 9B 86400015 DC X'04' 9C 86500015 DC X'04' 9D 86600015 DC X'00' 9E 86700015 DC X'04' 9F 86800015 DC X'00' A0 86900015 DC X'00' A1 87000015 DC X'00' A2 87100015 DC X'00' A3 87200015 DC X'00' A4 87300015 DC X'00' A5 87400015 DC X'00' A6 87500015 DC X'00' A7 87600015 DC X'00' A8 87700015 DC X'04' A9 87800015 DC X'04' AA 87900015 DC X'04' AB 88000015 DC X'00' AC 88100015 DC X'00' AD 88200015 DC X'00' AE 88300015 DC X'00' AF 88400015 DC X'04' B0 88500015 DC X'04' B1 88600015 DC X'04' B2 88700015 DC X'00' B3 88800015 DC X'04' B4 88900015 DC X'00' B5 89000015 DC X'04' B6 89100015 DC X'20' B7 **** 89200015 DC X'04' B8 89300015 DC X'20' B9 **** 89400015 DC X'04' BA 89500015 DC X'00' BB 89600015 DC X'00' BC 89700015 DC X'04' BD 89800015 DC X'00' BE 89900015 DC X'00' BF 90000015 DC X'00' C0 90100015 DC X'04' C1 90200015 DC X'00' C2 90300015 DC X'04' C3 90400015 DC X'00' C4 90500015 DC X'04' C5 90600015 DC X'04' C6 90700015 DC X'20' C7 90800015 DC X'04' C8 90900015 DC X'20' C9 91000015 DC X'04' CA 91100015 DC X'04' CB 91200015 DC X'00' CC 91300015 DC X'04' CD 91400015 DC X'04' CE 91500015 DC X'04' CF 91600015 DC X'08' D0 STATEMENT NUMBER 91700015 DC X'00' D1 91800015 DC X'08' D2 STATEMENT LABEL 91900015 DC X'00' D3 92000015 DC X'00' D4 92100015 DC X'00' D5 92200015 DC X'00' D6 92300015 DC X'00' D7 92400015 DC X'00' D8 92500015 DC X'20' D9 92600015 DC X'00' DA 92700015 DC X'20' DB 92800015 DC X'04' DC 92900015 DC X'00' DD 93000015 DC X'00' DE 93100015 DC X'00' DF 93200015 DC X'04' E0 93300015 DC X'00' E1 93400015 DC X'04' E2 93500015 DC X'04' E3 93600015 DC X'00' E4 93700015 DC X'04' E5 93800015 DC X'04' E6 93900015 DC X'04' E7 94000015 DC X'04' E8 94100015 DC X'04' E9 94200015 DC X'04' EA 94300015 DC X'00' EB 94400015 DC X'04' EC 94500015 DC X'1C' ED END OF TEXT 94600015 DC X'18' EE END PROG2 94700015 DC X'04' EF 94800015 DC X'04' F0 94900015 DC X'00' F1 95000015 DC X'04' F2 95100015 DC X'00' F3 95200015 DC X'04' F4 95300015 DC X'00' F5 95400015 DC X'04' F6 95500015 DC X'00' F7 95600015 DC X'04' F8 95700015 DC X'00' F9 95800015 DC X'04' FA 95900015 DC X'00' FB 96000015 DC X'04' FC 96100015 DC X'04' FD 96200015 DC X'04' FE 96300015 DC X'00' FF 96400015 END IEMJD 96500015 ./ ADD SSI=19011851,NAME=IEMJI,SOURCE=0 JI TITLE 'IEMJI, STRUCTURE MAPPING PREPROCESSOR, OS/360, PL/1 COM*00040015 PILER(F)' 00080015 IEMJI START 0 00120015 SPACE 10 00160015 * STATUS - CHANGE LEVEL 0 00200015 *3330 539600,540400 H39 00220016 * R18 898860 23103 00230001 * 21123 RLSE18 $326400 00235001 SPACE 5 00240015 * FUNCTION / OPERATION - 00280015 SPACE 5 00320015 * THIS PHASE IS PRIMARILY A &REPROCESSOR FOR 00360015 * THE AGGREGATES LOGICAL PHASE IEMJK. ITS ACTIONS ARE 00400015 * 00440015 * (1) TO OBTAIN 4K OF SCRATCH CORE FOR USE AS WORK 00480015 * AREAS ETC. 00520015 * 00560015 * (2) TO LOAD PHASE IEMJJ, SHIFT ITS CONTENTS INTO 00600015 * SCRATCH CORE AND THEN TO RELEASE IT. 00640015 * 00680015 * (3) TO LOAD PHASES IEMJK AND IEMJL. 00720015 * 00760015 * (4) TO RE-ORDER THE STATIC, AUTOMATIC (AND CONTROLLED) 00800015 * CHAINS SO THAT VARIABLES WHICH ARE TO BE PROCESSED 00840015 * BY PHASE IEMJK APPEAR BEFORE THOSE WHICH ARE NOT. 00880015 * DURING THIS SCAN ARRAYS AND STRUCTURES ARE EXAMINED 00920015 * FOR THE PRESENCE OF ADJUSTABLE ELEMENTS AND IF ANY 00960015 * EXIST, A DICTIONARY ENTRY IS MADE FOR THE LIBRARY 01000015 * ROUTINE IHESTRB. 01040015 * 01080015 * (5) DVDS ARE CONSTRUCTED FOR THOSE ARRAYS WHICH ARE 01120015 * THE BASE ELEMENTS OF STRUCTURES AND ARE ARGUMENTS 01160015 * TO THE STRING BUILT-IN FUNCTION. 01200015 * 01240015 * (6) THE COBOL CHAIN IS SCANNED AND THE STRUCTURES ARE 01280015 * MAPPED ACCORDING TO THE COBOL ALGORITHM. IF ANY PROVE 01320015 * TO BE ADJUSTABLE, THEN A DICTIONARY ENTRY IS MADE 01360015 * FOR THE LIBRARY ROUTINE IHESTRC. 01400015 * 01440015 * (7) THE COBOL STRUCTURES ARE TRANSFERED FROM THE COBOL 01480015 * CHAIN TO THEIR RESPECTIVE AUTOMATIC CHAINS - THE 01520015 * DICTIONARY REFERENCE OF THE APPROPRIATE ENTRY TYPE 1 01560015 * BEING HELD IN THE LEVEL AND COUNT SLOT. 01600015 * 01640015 * (8) TO LOAD AND PASS CONTROL TO PHASE IEMJM WHEN ALL 01680015 * THE PREPROCESSING IS COMPLETED. 01720015 * 01760015 * 01800015 * 01840015 * ENTRY POINTS - 01880015 * 01920015 * JI + 2 FROM COMPILER CONTROL 01960015 * 02000015 * 02040015 * 02080015 * INPUT - 02120015 * 02160015 * THE DICTIONARY 02200015 * 02240015 * 02280015 * 02320015 * OUTPUT - 02360015 * 02400015 * DICTIONARY ENTRIES 02440015 * 02480015 * 02520015 * 02560015 * EXTERNAL ROUTINES - 02600015 * 02640015 * (1) ZDRFAB 02680015 * 02720015 * (2) ZUERR 02760015 * 02800015 * (3) ZDICRF 02840015 * 02880015 * (4) ELSIZ 02920015 * 02960015 * 03000015 * 03040015 * EXITS - NORMAL - 03080015 * 03120015 * TO JM + 2 VIA COMPILER CONTROL 03160015 * 03200015 * 03240015 * 03280015 * EXITS - ERROR - 03320015 * 03360015 * NONE 03400015 * 03440015 * 03480015 * 03520015 * NOTES 03560015 * 03600015 * (1) REGISTER 15 IS SET TO POINT TO ZDRFAB THROUGHOUT 03640015 * PROCESSING 03680015 * 03720015 * (2) FOR COBOL STRUCTURES THE OFFSET 1 SLOT IS USED 03760015 * TO TRANSFER INFORMATION FROM IEMJI TO IEMJK. IT IS 03800015 * USED AS FOLLOWS 03840015 * 03880015 * BYTES 0 AND 1 DOPE VECTOR SIZE 03920015 * BYTE 2 - 03960015 * BIT 0 UNUSED 04000015 * BIT 1 UNUSED 04040015 * BIT 2 UNUSED 04080015 * BIT 3 UNUSED 04120015 * BIT 4 UNUSED 04160015 * BIT 5 COBOL 04200015 * BIT 6 ADJUSTABLE 04240015 * BIT 7 JK'S 'PROCESSED' BIT 04280015 SPACE 10 04320015 USING *,R12 04360015 SPACE 04400015 USING *+X'1000',R9 04440015 SPACE 04480015 USING *+X'2000',R10 04520015 SPACE 04560015 USING *+X'3000',DICBAS 04600015 SPACE 04640015 USING *+X'4000',CCBAS 04680015 SPACE 04720015 USING *+X'5000',R8 04760015 EJECT 04800015 * REGISTER USAGE 04840015 SPACE 10 04880015 R0 EQU 0 04920015 R1 EQU 1 04960015 R2 EQU 2 05000015 R3 EQU 3 05040015 R4 EQU 4 05080015 R5 EQU 5 05120015 R6 EQU 6 05160015 R7 EQU 7 05200015 R8 EQU 8 05240015 R9 EQU 9 05280015 R10 EQU 10 05320015 CCBAS EQU 11 05360015 R12 EQU 12 05400015 DICBAS EQU 13 05440015 RR EQU 14 05480015 LR EQU 15 05520015 EJECT 05560015 * CONDITION CODES 05600015 SPACE 10 05640015 B EQU 15 05680015 NOP EQU 0 05720015 BH EQU 2 05760015 BL EQU 4 05800015 BE EQU 8 05840015 BNH EQU 13 05880015 BNL EQU 11 05920015 BNE EQU 7 05960015 BO EQU 1 06000015 BP EQU 2 06040015 BM EQU 4 06080015 BZ EQU 8 06120015 BNO EQU 14 06160015 BNP EQU 13 06200015 BNM EQU 11 06240015 BNZ EQU 7 06280015 EJECT 06320015 * OFFSETS IN DICTIONARY ENTRIES 06360015 SPACE 10 06400015 DATOT1 EQU 10 06440015 VARBYT EQU 11 06480015 DATOT2 EQU 12 06520015 DATOT3 EQU 13 06560015 DATOT4 EQU 14 06600015 DATBYT EQU 15 06640015 EJECT 06680015 * SOME USEFUL EQUS 06720015 SPACE 10 06760015 ON EQU X'FF' 06800015 OFF EQU X'00' 06840015 STATIC EQU X'00' 06880015 AUTO EQU X'C0' 06920015 CONTRL EQU X'80' 06960015 STYPE EQU X'C0' 07000015 SPACE 10 07040015 * EQUS FOR OFFSETS IN THE STRUCTURE STACK 07080015 SPACE 10 07120015 XSTART EQU 0 07160015 XLENT EQU 4 07200015 XINHDM EQU 8 07240015 XREF EQU 10 07280015 XPROCS EQU 12 07320015 XALIGN EQU 13 07360015 XLEVEL EQU 14 07400015 EJECT 07440015 * OFFSETS IN IEMJK 07480015 SPACE 10 07520015 JK EQU *+X'1000' 07560015 SPACE 07600015 * ROUTINES 07640015 SPACE 07680015 PROCST EQU JK+2 07720015 SP54 EQU PROCST+4 07760015 ELSIZ EQU SP54+4 07800015 MKDVD EQU ELSIZ+4 07840015 MOVEMP EQU MKDVD+4 07880017 SPACE 07920015 * GENERAL STORAGE 07960015 SPACE 08000015 SCRACH EQU *+X'5000' 08040015 BASED EQU SCRACH+4 08050017 SPEC EQU BASED+4 08060017 TRIAL EQU SPEC+4 08070017 SPACE 08080015 REGSAV EQU SCRACH+X'638' 08120001 STCKPT EQU REGSAV+X'78' 08160015 FRSTBD EQU STCKPT+4 08200015 OACC EQU FRSTBD+2 08240015 OWRK1 EQU OACC+2 08280015 OWRK2 EQU OWRK1+2 08320015 OOFF EQU OWRK2+2 08360015 OSTACK EQU OOFF+2 08400015 OLNGTH EQU OSTACK+2 08440015 AREF EQU OLNGTH+2 08480015 BREF EQU AREF+2 08520015 MREF EQU BREF+2 08560015 RREF EQU MREF+2 08600015 VREF EQU RREF+2 08640015 TREF EQU VREF+2 08680015 OFFSET EQU TREF+2 08720015 BOUND EQU OFFSET+2 08760015 MAXBND EQU BOUND+2 08800015 DIM1 EQU MAXBND+2 08840015 N EQU DIM1+2 08880015 DREF1 EQU N+2 08920015 CLASS EQU DREF1+2 08960015 WRKSW EQU CLASS+1 09000015 OBJSW EQU WRKSW+1 09040015 DIMSW EQU OBJSW+1 09080015 PS EQU DIMSW+1 09120015 WRKSW1 EQU PS+48 09160015 MAJSW EQU WRKSW1+1 09200015 LENGTH EQU MAJSW+1 09240015 DIMREF EQU LENGTH+4 09280015 NREF EQU DIMREF+2 09320015 DEFSW EQU NREF+2 09360015 SIZSW EQU DEFSW+1 09400015 DIM EQU SIZSW+1 09440015 DREF EQU DIM+2 09480015 DVOFF EQU DREF+2 09520015 BITSW EQU DVOFF+2 09560015 ADJSW EQU BITSW+1 09600015 VARYSW EQU ADJSW+1 09640015 MPL1 EQU VARYSW+1 09680015 MCOBOL EQU MPL1+2 09720015 QUFLAG EQU MCOBOL+2 I4A 09750016 DUMMY EQU QUFLAG+1 I4A 09780016 COBLSW EQU DUMMY+1 I4A 09810016 CNTGSW EQU COBLSW+1 09840015 AREASW EQU CNTGSW+1 09880015 BASESW EQU AREASW+1 09920015 ADJ1SW EQU BASESW+1 09960015 V1SW EQU ADJ1SW+1 10000015 EJECT 10040015 * OFFSETS IN IEMJL 10080015 SPACE 10 10120015 JL EQU *+X'2000' 10160015 SPACE 10200015 * ROUTINES 10240015 SPACE 10280015 SETBRF EQU JL+2 10320015 ADDCN EQU SETBRF+4 10360015 SUBCN EQU ADDCN+4 10400015 LOADCN EQU SUBCN+4 10440015 CMPILE EQU LOADCN+4 10480015 INOBJ EQU CMPILE+4 10520015 CMPIL1 EQU INOBJ+4 10560015 TERMWS EQU CMPIL1+4 10600015 FINISH EQU TERMWS+4 10640015 CHNSCN EQU FINISH+4 10680015 SVARY EQU CHNSCN+4 10720015 VOBJC EQU SVARY+4 10760015 ALVACA EQU VOBJC+4 10800015 BUMPEQ EQU ALVACA+4 10840015 MKCNST EQU BUMPEQ+4 10880015 CS2 EQU MKCNST+4 10920015 MP13 EQU CS2+4 10960015 SPACE 11000015 * GENERAL STORAGE 11040015 SPACE 11080015 BLOCK EQU MP13+8 I4A 11120016 LEVEL EQU BLOCK+2 11160015 MAXLVL EQU LEVEL+2 11200015 DONSW EQU MAXLVL+2 11240015 TXTNM EQU DONSW+1 I4A 11260016 EJECT 11280015 * COMMUNICATIONS REGION OFFSETS 11320015 SPACE 10 11360015 DB EQU *+X'3000' 11400015 SPACE 11440015 ZSTAT EQU DB+124 11480015 PAR1 EQU DB+128 11520015 PAR2 EQU PAR1+4 11560015 PAR3 EQU PAR2+4 11600015 PAR4 EQU PAR3+4 11640015 PAR5 EQU PAR4+4 11680015 PAR6 EQU PAR5+4 11720015 PAR7 EQU PAR6+4 11760015 PAR8 EQU PAR7+4 11800015 TXTSZ EQU DB+268 11840015 ZNXTLC EQU DB+276 11880015 LOCK EQU DB+274 11920015 ZMYNAM EQU DB+112 11960015 ZCOMM EQU DB+304 12000015 ZSTACH EQU ZCOMM+68 12040015 ZCONCH EQU ZCOMM+78 12080015 ZEQMAX EQU ZCOMM+82 12120015 ZSMREG EQU ZCOMM+40 12160015 ZPROC1 EQU ZCOMM+64 12200015 ZCITEM EQU ZCOMM+80 12240015 ZCOBOL EQU ZCOMM+86 12280015 EJECT 12320015 * COMPILER CONTROL OFFSETS 12360015 SPACE 10 12400015 CC EQU *+X'4000' 12440015 SPACE 12480015 ZUGC EQU CC+X'10' 12520015 ZUTXTC EQU CC+X'14' 12560015 ZURC EQU CC+X'18' 12600015 ZABORT EQU CC+X'20' 12640015 ZLOADW EQU CC+X'24' 12680015 ZDICRF EQU CC+X'2C' 12720015 ZUERR EQU CC+X'30' 12760015 ZDRFAB EQU CC+X'34' 12800015 RELESE EQU CC+X'44' 12840015 RLSCTL EQU CC+X'48' 12880015 ZTXTRF EQU CC+X'50' 12920015 ZTXTAB EQU CC+X'54' 12960015 ZCHAIN EQU CC+X'58' 13000015 ZALTER EQU CC+X'5C' 13040015 ZDABRF EQU CC+X'60' 13080015 EJECT 13120015 SPACE 10 13160015 JI DC C'JI' 13200015 SPACE 10 13240015 L R12,PAR1 13280015 SPACE 13320015 MVC ZMYNAM(2),NAME1 13360015 EJECT 13400015 * INITIALISATION ROUTINE 13440015 * 13480015 * 13520015 * 13560015 * FUNCTIONS 13600015 * 13640015 * (1) TO LOAD PHASES IEMJK AND IEMJL. PHASE IEMJM IS 13680015 * LOADED WHEN IEMJI IS RELEASED. 13720015 * 13760015 * (2) TO OBTAIN 4K OF SCRATCH CORE FOR USE BY 13800015 * THE STRUCTURE MAPPING ROUTINE 13840015 * 13880015 * (3) TO SET REGISTER LR TO POINT TO ZDRFAB 13920015 * IN COMPILER CONTROL 13960015 * 14000015 * 14040015 * 14080015 * ENTRY POINT - BEGIN 14120015 * 14160015 * 14200015 * 14240015 * EXTERNAL ROUTINES 14280015 * 14320015 * (1) ZUGC IN COMPILER CONTROL 14360015 * 14400015 * (2) ZDRFAB IN COMPILER CONTROL 14440015 * 14480015 * 14520015 * 14560015 * EXITS -NORMAL - TO SCANA 14600015 * 14640015 * 14680015 * 14720015 * EXITS - ERROR - NONE 14760015 SPACE 10 14800015 BEGIN LA R1,8 14840015 ST R1,PAR1 OBTAIN 4K OF SCRATCH CORE 14880015 L LR,ZUGC 14920015 BALR RR,LR 14960015 L R8,PAR1 AND SET R8 TO POINT TO IT 15000015 SPACE 15040015 LA R1,NAME5 15080015 ST R1,PAR1 15120015 L LR,ZLOADW 15160015 BALR RR,LR LOAD IEMJJ 15200015 SPACE 15240015 L R1,PAR1 15280015 LR R2,R8 15320015 LA R3,256 15360015 LH R4,2(R1) SIZE OF IEMJJ 15400015 SPACE 15440015 BEGIN1 CR R4,R3 15480015 BC BNH,BEGIN2 15520015 MVC 0(256,R2),0(R1) MOVE 256 BYTES OF TEXT 15560015 AR R1,R3 15600015 AR R2,R3 15640015 SR R4,R3 15680015 BC B,BEGIN1 15720015 SPACE 15760015 BEGIN2 BCTR R4,0 15800015 STC R4,BEGIN3+1 15840015 BEGIN3 MVC 0(1,R2),0(R1) MOVE REMAINING TEXT 15880015 SPACE 15920015 LA R1,NAME5 15960015 ST R1,PAR1 16000015 L LR,RELESE 16040015 BALR RR,LR RELEASE IEMJJ 16080015 SPACE 16120015 LA R1,NAME2 16160015 ST R1,PAR1 16200015 L LR,ZLOADW 16240015 BALR RR,LR LOAD IEMJK 16280015 L R9,PAR1 16320015 SPACE 16360015 LA R1,NAME3 16400015 ST R1,PAR1 16440015 BALR RR,LR LOAD IEMJL 16480015 L R10,PAR1 16520015 SPACE 16560015 LA R0,4 SET R0 TO CONTAIN 4 16600015 SPACE 1 I4A 16610016 MVI PAR2+3,X'00' I4A 16620016 L LR,ZUTXTC I4A 16630016 BALR RR,LR I4A 16640016 MVC TXTNM(1),PAR1+1 I4A 16650016 MVC STCKPT(4),PAR2 USE TEXT BLOCK FOR SCRATCH I4A 16660016 SPACE 1 I4A 16670016 LA R7,REGSAV REGISTER SAVE AREA 16720015 L LR,ZDRFAB 16760015 EJECT 16800015 * SCANA 16840015 * 16880015 * 16920015 * 16960015 * FUNCTIONS 17000015 * 17040015 * TO SCAN DOWN THE STATIC, AUTOMATIC AND 17080015 * CONTROLLED CHAINS AND 17120015 * 17160015 * (1) SORT THEM INTO THE ORDER - DATA VARIABLES 17200015 * FOLLOWED BY NON-DATA VARIABLES 17240015 * 17280015 * (2) MAP CONTIGUOUS STRUCTURES 17320015 * 17360015 * 17400015 * 17440015 * ENTRY POINT - SCANA 17480015 * 17520015 * 17560015 * 17600015 * EXTERNAL ROUTINES 17640015 * 17680015 * (1) MAP TO PROCESS CONTIGUOUS STRUCTURES 17720015 * 17760015 * (2) MAPA TO PROCESS PL/1 STRUCTURES 17800015 * 17840015 * (3) ZDRFAB IN COMPILER CONTROL 17880015 * 17920015 * 17960015 * 18000015 * EXITS - NORMAL - TO SCAN 18040015 * 18080015 * 18120015 * 18160015 * EXITS - ERROR - NONE 18200015 SPACE 10 18240015 SCANA MVI CLASS,STATIC SET CLASS SWITCH TO STATIC 18280015 SPACE 18320015 MVC PAR1+2(2),ZSTACH+4 GET STATIC HEAD 18360015 SPACE 18400015 SCANAA MVC HEAD1(6),K0 BASIC LOOP INITIALISATION 18440015 NI SCANAB+1,X'0F' 18480015 SPACE 18520015 SCANAC CLC PAR1+2(2),K0 18560015 BC BE,SCANAD BRANCH IF END OF CHAIN 18600015 SPACE 18640015 MVC REF(2),PAR1+2 18680015 BALR RR,LR SAVE AND DECODE REFERENCE 18720015 L R4,PAR1 18760015 SPACE 18800015 TM 0(R4),X'40' 18840015 BC BO,SCANAE BRANCH FOR NON DATA VARIABLES 18880015 SPACE 18920015 TM 0(R4),X'06' 18960015 BC BNO,SCANAF BRANCH FOR NON DATA VARIABLES 19000015 SPACE 19040015 TM 0(R4),X'09' BRANCH IF NOT DATA ITEM, LABEL 19080015 BC BZ,SCANAH OR STRUCTURE 19120015 SPACE 19160015 SCANAG MVC REF2(2),3(R4) 19200015 MVC 3(2,R4),HEAD1 CHAIN ITEM FROM HEAD1 19240015 MVC HEAD1(2),REF 19280015 SPACE 19320015 MVC 5(3,R4),K0 SET OFFSET 1 SLOT TO ZERO 19360015 NI DATOT4(R4),X'7F' INITIALISE BIT ONE TO ZERO I1 19380016 SPACE 19400015 SCANAB BC B,SCANAJ 19440015 SPACE 19480015 OI SCANAB+1,X'F0' RESET BRANCH 19520015 SPACE 19560015 MVC HEAD3(2),REF SET HEAD3 19600015 SPACE 19640015 SCANAJ TM 0(R4),X'0F' 19680015 BC BO,SCANAK BRANCH FOR DATA ITEM 19720015 SPACE 19760015 TM 0(R4),X'0E' 19800015 BC BNO,SCANAK BRANCH IF NOT STRUCTURE 19840015 SPACE 19880015 BAL RR,CHECK I4A 19980016 SPACE 20160015 SCANAM MVC PAR1+2(2),REF 20200015 BALR RR,LR DECODE STRUCTURE REFERENCE 20240015 L R4,PAR1 20280015 SPACE 20320015 SCANAN MVC PAR1+2(2),REF2 20360015 BC B,SCANAC 20400015 SPACE 20440015 SCANAK TM 0(R4),X'10' 20480015 BC BZ,SCANAN BRANCH IF NOT ARRAY 20520015 SPACE 20560015 TM DATOT1(R4),X'04' 20600015 BC BO,SCANAO BRANCH IF ADJUSTABLE BOUNDS 20640015 SPACE 20680015 TM 0(R4),X'0F' 20720015 BC BNO,SCANAN BRANCH IF NOT DATA ITEM 20760015 SPACE 20800015 TM DATBYT(R4),X'80' 20840015 BC BO,SCANAN BRANCH IF NOT STRING 20880015 SPACE 20920015 TM DATBYT(R4),X'40' 20960015 BC BZ,SCANAN BRANCH IF NOT ADJUSTABLE 21000015 SPACE 21040015 SCANAO LA RR,SCANAN 21080015 ST RR,MAPRR MAKE DICTIONARY ENTRY FOR 21120015 BC B,MAPA1 LIBRARY ROUTINE 21160015 SPACE 21200015 SCANAE MVC PAR1+2(2),3(R4) 21240015 MVC 3(2,R4),HEAD2 CHAIN ITEM FROM HEAD2 21280015 MVC HEAD2(2),REF 21320015 BC B,SCANAC 21360015 SPACE 21400015 SCANAF TM 0(R4),X'0C' 21440015 BC BO,SCANAG BRANCH FOR EVENT AND TASK 21480015 SPACE 21520015 SCANAH TM CLASS,STYPE *** NON VARIABLE 21560015 BC BNO,SCANAE BRANCH IF NOT AUTOMATIC 21600015 SPACE 21640015 CLI 0(R4),X'84' 21680015 BC BE,SCANAI BRANCH IF ENTRY TYPE 3 21720015 SPACE 21760015 CLI 0(R4),X'83' 21800015 BC BE,SCANAI BRANCH IF ENTRY TYPE 5 21840015 SPACE 21880015 CLI 0(R4),X'03' 21920015 BC BNE,SCANAE 21960015 SPACE 22000015 SCANAI MVC PAR1+2(2),11(R4) 22040015 MVC 11(2,R4),HEAD2 CHAIN ITEM FROM HEAD2 22080015 MVC HEAD2(2),REF 22120015 BC B,SCANAC 22160015 SPACE 22200015 SCANAD CLI CLASS,STATIC 22240015 BC BNE,SCANAP BRANCH IF CLASS IS NOT STATIC 22280015 SPACE 22320015 MVC STATH1(6),HEAD1 SAVE STATIC DATA 22360015 SPACE 22400015 MVI CLASS,AUTO SET CLASS TO AUTO 22440015 SPACE 22480015 MVC PAR1+2(2),ZPROC1+2 SET FIRST PROCEDURE 22520015 SPACE 22560015 SCANAR CLC PAR1+2(2),K0 22600015 BC BE,SCANAQ BRANCH IF END OF PROCEDURES 22640015 SPACE 22680015 MVC BREF(2),PAR1+2 22720015 BALR RR,LR SAVE AND DECODE PROC REFERENCES 22760015 L R4,PAR1 22800015 SPACE 22840015 MVC PAR1+2(2),11(R4) SET HEAD OF AUTO CHAIN 22880015 BC B,SCANAA 22920015 SPACE 22960015 SCANAQ MVI CLASS,CONTRL SET CLASS TO CONTROLLED 23000015 SPACE 23040015 MVC PAR1+2(2),ZCITEM 23080015 BC B,SCANAA 23120015 SPACE 23160015 SCANAP CLC HEAD1(2),K0 23200015 BC BE,SCANAS BRANCH IF HEAD1 CHAIN IS EMPTY 23240015 SPACE 23280015 MVC PAR1+2(2),HEAD3 23320015 BALR RR,LR DECODE HEAD3 REFERENCE 23360015 L R4,PAR1 23400015 SPACE 23440015 MVC 3(2,R4),HEAD2 AND LINK CHAINS 23480015 BC B,SCANAT 23520015 SPACE 23560015 SCANAS MVC HEAD1(2),HEAD2 23600015 SPACE 23640015 SCANAT CLI CLASS,AUTO 23680015 BC BNE,SCANAU BRANCH IF CLASS IS CONTROLLED 23720015 SPACE 23760015 MVC PAR1+2(2),BREF 23800015 BALR RR,LR DECODE PROCEDURE REFERENCE 23840015 L R4,PAR1 23880015 SPACE 23920015 MVC 11(2,R4),HEAD1 SET CHAIN IN ET1 AND GET 23960015 MVC PAR1+2(2),9(R4) NEXT ONE 24000015 BC B,SCANAR 24040015 SPACE 24080015 SCANAU MVC ZCITEM(2),HEAD1 RESET CONTROLLED CHAIN 24120015 SPACE 24160015 MVI CLASS,OFF SET CLASS SWITCH OFF 24200015 EJECT 24240015 * SCAN 24280015 * 24320015 * 24360015 * 24400015 * FUNCTIONS 24440015 * 24480015 * (1) TO SCAN DOWN THE COBOL CHAIN AND PASS EACH 24520015 * STRUCTURE IN TURN TO THE MAPPING ROUTINES 24560015 * 24600015 * 24640015 * 24680015 * ENTRY POINT - SCAN 24720015 * 24760015 * 24800015 * 24840015 * EXTERNAL ROUTINES 24880015 * 24920015 * (1) MAP TO PROCESS THE STRUCTURE 24960015 * 25000015 * (2) ZDRFAB IN COMPILER CONTROL 25040015 * 25080015 * 25120015 * 25160015 * EXITS - NORMAL - RECHAN 25200015 * 25240015 * 25280015 * 25320015 * EXITS - ERROR - NONE 25360015 SPACE 10 25400015 SCAN MVC REF(2),ZCOBOL 25440015 SPACE 25480015 SCAN1 CLC REF(2),K0 BRANCH TO RECHAN ON FINDING 25520015 BC BE,RECHAN END OF CHAIN 25560015 SPACE 25600015 MVC PAR1+2(2),REF 25640015 BALR RR,LR DECODE MAJOR STRUCTURE REF 25680015 L R4,PAR1 25720015 SPACE 25760015 MVC 5(3,R4),K0 SET OFFSET1 SLOT TO ZERO 25800015 MVI COBLSW,ON 25840015 BAL RR,MAP PROCESS STRUCTURE 25880015 MVI COBLSW,OFF 25920015 SPACE 25960015 MVC PAR1+2(2),REF 26000015 BALR RR,LR DECODE MAJOR STRUCTURE REF 26040015 L R4,PAR1 26080015 SPACE 26120015 OI 7(R4),X'04' SET COBOL 26160015 SPACE 26200015 MVC REF(2),3(R4) 26240015 SPACE 26280015 BC B,SCAN1 26320015 EJECT 26360015 * RECHAN 26400015 * 26440015 * 26480015 * 26520015 * FUNCTIONS 26560015 * 26600015 * TO SCAN DOWN THE COBOL CHAIN TO PUT THE ENTRIES 26640015 * ON THE APPROPRIATE AUTOMATIC CHAINS 26680015 * 26720015 * 26760015 * 26800015 * ENTRY POINT - RECHAN 26840015 * 26880015 * 26920015 * 26960015 * EXTERNAL ROUTINES 27000015 * 27040015 * (1) ZDRFAB IN COMPILER CONTROL 27080015 * 27120015 * 27160015 * 27200015 * EXITS - NORMAL - TERMIN 27240015 * 27280015 * 27320015 * 27360015 * EXITS - ERROR - NONE 27400015 SPACE 10 27440015 RECHAN MVC PAR1+2(2),ZCOBOL 27480015 SPACE 27520015 RECHN1 CLC PAR1+2(2),K0 BRANCH IF END OF CHAIN 27560015 BC BE,TERMIN 27600015 SPACE 27640015 BALR RR,LR DECODE STRUCTURE REFERENCE 27680015 L R2,PAR1 27720015 SPACE 27760015 MVC FWORD+2(2),1(R2) 27800015 LH R3,FWORD+2 27840015 AR R3,R2 POINT R3 TO ENTRY TYPE 1 SLOT 27880015 BCTR R3,0 27920015 BCTR R3,0 27960015 SPACE 28000015 MVC PAR1+2(2),0(R3) 28040015 BALR RR,LR DECODE ET1 REFERENCE 28080015 L R4,PAR1 28120015 SPACE 28160015 MVC PAR1+2(2),3(R2) SET NEXT COBOL REFERENCE IN PAR1 28200015 MVC 3(2,R2),11(R4) SET AUTO CHAIN IN STRUCTURE 28240015 MVC 11(2,R4),ZCOBOL SET AUTO CHAIN IN ET1 28280015 MVC ZCOBOL(2),PAR1+2 SET ZCOBOL TO NEXT COBOL ITEM 28320015 MVC 0(2,R3),3(R4) SET LEVEL AND COUNT 28360015 SPACE 28400015 BC B,RECHN1 28440015 EJECT 28480015 * TERMIN 28520015 * 28560015 * 28600015 * 28640015 * FUNCTIONS 28680015 * 28720015 * PASSES CONTROL FROM IEMJI TO IEMJM 28760015 * 28800015 * 28840015 * 28880015 * ENTRY POINT - TERMIN 28920015 * 28960015 * 29000015 * 29040015 * EXTERNAL ROUTINES 29080015 * 29120015 * (1) RLSCTL IN COMPILER CONTROL 29160015 * 29200015 * 29240015 * 29280015 * EXITS - NORMAL - TO IEMJM VIA COMPILER CONTROL 29320015 * 29360015 * 29400015 * 29440015 * EXITS - ERROR - NONE 29480015 SPACE 10 29520015 TERMIN CLC STATH1(2),K0 29560015 BC BE,TERMN1 BRANCH IF STATH1 CHAIN IS EMPTY 29600015 SPACE 29640015 MVC PAR1+2(2),STATH3 29680015 BALR RR,LR DECODE STATH3 REFERENCE 29720015 L R4,PAR1 29760015 SPACE 29800015 MVC 3(2,R4),STATH2 AND LINK CHAINS 29840015 SPACE 29880015 MVC ZSTACH+4(2),STATH1 SET STATIC CHAIN HEAD 29920015 BC B,TERMN2 29960015 SPACE 30000015 TERMN1 MVC ZSTACH+4(2),STATH2 SET STATIC CHAIN HEAD 30040015 SPACE 30080015 TERMN2 LA R1,NAME1 30120015 LA R2,NAME4 30160015 STM R1,R2,PAR1 30200015 L RR,RLSCTL 30240015 BCR B,RR 30280015 EJECT 30320015 * MAP 30360015 * 30400015 * 30440015 * 30480015 * FUNCTIONS 30520015 * 30560015 * TO SCAN THROUGH A STRUCTURE AND MAP IT ACCORDING 30600015 * TO THE COBOL OR THE CONTIGUOUS MAPPING 30640015 * ALGORITHM. 30680015 * FOR ADJUSTABLE STRUCTURES, DICTIONARY ENTRIES 30720015 * ARE MADE FOR THE RELEVANT LIBRARY MODULES AND THE 30760015 * REFERENCES ARE PLACED IN MCOBOL AND MCNTIG 30800015 * RESPECTIVELY. 30840015 * 30880015 * 30920015 * 30960015 * ENTRY POINT - MAP 31000015 * 31040015 * 31080015 * 31120015 * EXTERNAL ROUTINES 31160015 * 31200015 * (1) NXTRF1 TO OBTAIN THE NEXT MEMBER OF THE STRUCTURE 31240015 * 31280015 * (2) NXTRF2 TO OBTAIN THE NEXT ELEMENT OF THE STRUCTURE 31320015 * 31360015 * (3) CHECK TO CHECK FOR VALIDITY OF DATA TYPES IN CONTIGUOUS 31400015 * STRUCTURES. 31440015 * PHASE IEMGC HAS DONE THIS FOR COBOL STRUCTURES 31480015 * 31520015 * (4) ERROR TO INSET ERROR MESSAGES INTO THE DICTIONARY 31560015 * 31600015 * (5) ZDRFAB IN COMPILER CONTROL 31640015 * 31680015 * (6) ZDICRF IN COMPILER CONTROL 31720015 * 31760015 * 31800015 * 31840015 * EXITS - NORMAL - TO CALLING ROUTINE 31880015 * 31920015 * 31960015 * 32000015 * EXITS - ERROR - TO CALLING ROUTINE IF THE 32040015 * STRUCTURE IS TOO LARGE 32080015 * 32120015 * 32160015 * 32200015 * N.B. 32240015 * 32280015 * THE COBOL MAPPING ALGORITHM IS - 32320015 * THE STRUCTURE STARTS ON A D-BOUNDARY AND EACH ELEMENT STARTS 32360015 * ON THE NEXT AVAILABLE D-, F-, H-, BY- OR BI -BOUNDARY 32400015 * 32440015 * THE CONTIGUOUS MAPPING ALGORITHM IS - 32480015 * THE STRUCTURE STARTS ON A BY-BOUNDARY AND EACH ELEMENT 32520015 * STARTS ON THE NEXT AVAILABLE BY- OR BI- BOUNDARY 32560015 SPACE 10 32600015 MAP ST RR,MAPRR 32640015 CLI COBLSW,X'FF' IS IT COBOL STRUCTURE 21123 32650001 BNE *+8 NO 21123 32660001 NI DATOT4(R4),X'7F' INITIALIXE BIT 1 TO 0 21123 32670001 SPACE 32680015 MVC PAR1+2(2),8(R4) 32720015 BALR RR,LR 32760015 L R3,PAR1 DECODE 'BASE' REFERENCE 32800015 MVC ZSTAT+2(2),8(R3) 32840015 SPACE 32880015 TM DATOT2(R3),X'03' 32920015 BC BNO,MAP1 BRANCH IF NOT CONTROLLED 32960015 SPACE 33000015 TM VARBYT(R3),X'02' 33040015 BC BZ,MAP9 BRANCH IF NOT BASED 33080015 EJECT 33120015 * MAP1 33160015 * 33200015 * 33240015 * 33280015 * FUNCTIONS 33320015 * 33360015 * TO STACK THE NECESSARY INFORMATION AT THE 33400015 * START OF A NEW STRUCTURE 33440015 * THE INFORMATION STACKED IS POINTED TO BY 33480015 * R6 AND IS 33520015 * 33560015 * (1) XSTART START OF THE STRUCTURE IN BITS 33600015 * (2) XLENT LENGTH OF THE STRUCTURE IN BITS 33640015 * (3) XINHDM NUMBER OF INHERITED DIMENSIONS 33680015 * (4) XREF REFERENCE OF THE STRUCTURE 33720015 * (5) XPROCS SET TO X'FF' WHEN XSTART IS FILLED 33760015 * (6) XALIGN ALIGNMENT OF THE STRUCTURE 33800015 * (7) XLEVEL LEVEL OF THE STRUCTURE 33840015 * 33880015 * 33920015 * 33960015 * ENTRY POINT - MAP1 34000015 * 34040015 * 34080015 * 34120015 * EXTERNAL ROUTINES 34160015 * 34200015 * (1) NXTRF1 TO OBTAIN THE NEXT ITEM IN THE STRUCTURE 34240015 * 34280015 * 34320015 * 34360015 * EXITS - NORMAL - 34400015 * 34440015 * (1) MAP2 TO PROCESS THE BASE ELEMENT 34480015 * 34520015 * (2) MAP12 TO PROCESS A FURTHER STRUCTURE 34560015 * 34600015 * 34640015 * 34680015 * EXITS - ERROR - NONE 34720015 SPACE 10 34760015 MAP1 MVI BASESW,OFF 34800015 MVI ADJ1SW,OFF 34840015 MVI ENDSW,OFF 34880015 MVI MULTSW,OFF 34920015 MVI V1SW,OFF 34960015 MVI RCIOSW,OFF 35000015 SPACE 35040015 CLI CLASS,CONTRL 35080015 BC BNE,MAP11 BRANCH IF NOT CONTROLLED 35120015 SPACE 35160015 TM VARBYT(R4),X'02' 35200015 BC BZ,MAP11 BRANCH IF NOT BASED 35240015 SPACE 35280015 MVI BASESW,ON SET BASED SWITCH ON 35320015 SPACE 35360015 MAP11 TM DATOT4(R4),X'01' 35400015 BC BZ,MAP16 BRANCH IF NO RDV 35440015 MVI RCIOSW,ON 35480015 SPACE 35520015 MAP16 SR R2,R2 BASIC INITIALISATION 35560015 ST R2,START 35600015 STH R2,DVOFF 35640015 STH R2,NDIMS 35680015 STH R2,STRBND 35700015 SPACE 35720015 L R6,STCKPT POINT AT STACK AREA 35760015 SPACE 35800015 XC 0(16,R6),0(R6) CLEAR STACK AREA 35840015 SPACE 35880015 MVC XREF(2,R6),REF 35920015 MVI XPROCS(R6),X'FF' 35960015 SPACE 36000015 MVI XALIGN(R6),X'40' D-WORD BOUNDARY 36040015 SPACE 36080015 MAP13 LR R3,R4 36120015 SPACE 36160015 TM VARBYT(R4),X'80' 36200015 BC BZ,MAP14 NO OFFSET 2 36240015 LA R3,4(R3) 36280015 SPACE 36320015 MAP14 TM VARBYT(R4),X'40' 36360015 BC BZ,MAP15 NO DIMENSIONS 36400015 LA R3,3(R3) 36440015 SPACE 36480015 MVC NDIMS+1(1),12(R3) 36520015 SPACE 36560015 MAP15 MVC XLEVEL(1,R6),16(R3) 36600015 SPACE 36640015 BAL RR,NXTRF1 36680015 SPACE 36720015 TM 0(R4),X'0F' 36760015 BC BO,MAP2 BRANCH IF DATA 36800015 SPACE 36840015 TM 0(R4),X'0E' 36880015 BC BNO,MAP2 BRANCH IF NOT STRUCTURE 36920015 SPACE 36960015 MAP12 LA R6,16(R6) UPDATE STACK POINTER 37000015 XC 0(16,R6),0(R6) CLEAR STACK AREA 37040015 SPACE 37080015 MVC XREF(2,R6),REF1 37120015 MVC XINHDM(2,R6),NDIMS 37160015 SPACE 37200015 TM 0(R4),X'10' 37240015 BC BZ,MAP13 BRANCH IF UNDIMENSIONED 37280015 SPACE 37320015 LR R3,R4 37330015 TM VARBYT(R4),X'80' 37340015 BC BZ,MAP176 37350015 LA R3,4(R3) 37360015 SPACE 37370015 MAP176 SR R5,R5 37380015 IC R5,19(R3) 37390015 STH R5,CURLEV 37480015 XC MAXALG(2),MAXALG CLEAR SLOT 37520015 MVC SVREF2(2),REF1 SAVE REFERENCE 37560015 SPACE 37600015 ST R6,0(R7) PRESERVE R6 37640015 AR R7,R0 37680015 SPACE 37720015 MAP17 BAL RR,NXTRF1 GET NEXT ITEM 37760015 SPACE 37800015 LR R3,R4 37840015 TM 0(R4),X'0F' 37880015 BC BNO,MAP171 BRANCH IF NOT DATA 37920015 LA R3,6(R3) 37960015 SPACE 38000015 MAP171 TM VARBYT(R4),X'80' 38040015 BC BZ,MAP172 BRANCH IF NO OFFSET 2 38080015 LA R3,4(R3) 38120015 SPACE 38160015 MAP172 TM VARBYT(R4),X'40' 38200015 BC BZ,MAP173 BRANCH IF NO DIMENSIONS 38240015 LA R3,3(R3) 38280015 SPACE 38320015 MAP173 SR R5,R5 38360015 IC R5,16(R3) LEVEL OF ITEM BEING TESTED 38400015 CH R5,CURLEV 38440015 BC BNH,MAP18 BRANCH IF END OF MINOR STRUCT 38480015 SPACE 38520015 TM 0(R4),X'0F' 38560015 BC BO,MAP174 BRANCH IF DATA 38600015 SPACE 38640015 TM 0(R4),X'0E' 38680015 BC BO,MAP17 BRANCH IF STRUCTURE 38720015 SPACE 38760015 MAP174 MVC DVOFFA(2),DVOFF 38780015 BAL RR,ELSIZ 38800015 BC B,*+4 ALLOW FOR BOTH RETURNS 38840015 MVC DVOFF(2),DVOFFA 38860015 SPACE 38880015 LH R3,BOUND 38920015 CH R3,MAXALG UPDATE MAX ALIGN IF NECESSARY 38960015 BC BNH,MAP175 39000015 STH R3,MAXALG 39040015 SPACE 39080015 MAP175 TM DATOT1(R4),X'08' 39120015 BC BZ,MAP17 BRANCH IF NOT END OF STRUCT 39160015 SPACE 39200015 MAP18 SR R7,R0 39240015 L R6,0(R7) RESTORE R6 39280015 SPACE 39320015 MVC PAR1+2(2),SVREF2 39360015 MVC REF1(2),SVREF2 I4A 39380016 BALR RR,LR RESTORE STRUCTURE ENTRY 39400015 L R4,PAR1 39440015 SPACE 39480015 L R1,START 39520015 LH R2,MAXALG 39560015 AR R1,R2 39600015 BCTR R1,0 START + BOUND - 1 39640015 SPACE 39680015 LCR R2,R2 SET UP MASK 39720015 NR R1,R2 SET START TO CORRECT VALUE 39760015 ST R1,START 39800015 ST R1,XSTART(R6) 39840015 MVC XALIGN(1,R6),MAXALG+1 39880015 BC B,MAP13 39920015 EJECT 39960015 * MAP2 40000015 * 40040015 * 40080015 * 40120015 * FUNCTIONS 40160015 * 40200015 * (1) TO DETERMINE THE LENGTH AND BOUNDARY 40240015 * REQUIREMENTS FOR A BASE ELEMENT 40280015 * 40320015 * (2) TO DETERMINE THE OFFSET OF THE ELEMENT 40360015 * RELATIVE TO THE START OF THE STRUCTURE 40400015 * 40440015 * (3) TO SET XSTART, XPROCS AND XALIGN FOR THOSE 40480015 * STRUCTURES FOR WHICH THIS ELEMENT IS THE FIRST 40520015 * 40560015 * 40600015 * 40640015 * ENTRY POINT - MAP2 40680015 * 40720015 * 40760015 * 40800015 * EXTERNAL ROUTINES 40840015 * 40880015 * (1) ELSIZ TO DETERMINE THE LENGTH AND BOUNDARY 40920015 * 40960015 * 41000015 * 41040015 * EXITS - NORMAL - MAP3 TO PROCESS THE BASE 41080015 * ELEMENT FURTHER 41120015 * 41160015 * 41200015 * 41240015 * EXITS - ERROR - NONE 41280015 * 41320015 * 41360015 * 41400015 * N.B. 41440015 * 41480015 * FOR ADJUSTABLE STRINGS IN BASED STRUCTURES - A 41520015 * LENGTH OF 1, 8 OR 136 BITS IS ASSUMED SO THAT THE 41560015 * VARIOUS OFFSETS MAY BE SET 41600015 SPACE 10 41640015 MAP2 LR R3,R4 41680015 SPACE 41720015 TM 0(R4),X'0F' 41760015 BC BNO,MAP21 BRANCH IF NOT DATA 41800015 LA R3,6(R3) 41840015 SPACE 41880015 MAP21 TM VARBYT(R4),X'80' 41920015 BC BZ,MAP22 BRANCH IF NO OFFSET 2 41960015 LA R3,4(R3) 42000015 SPACE 42040015 MAP22 MVC NDIMS1(2),K0 SET NDIMS1 42080015 SPACE 42120015 TM VARBYT(R4),X'40' 42160015 BC BZ,MAP23 42200015 LA R3,3(R3) 42240015 SPACE 42280015 MVC NDIMS1+1(1),12(R3) 42320015 MVC DIMTAB(2),13(R3) DIMTAB REFERENCE 42360015 SPACE 42400015 MAP23 MVC 22(2,R3),DVOFF SET DOPE VECTOR OFFSET 42440015 NI DATOT3(R4),X'FB' 42480015 SPACE 42520015 LH R2,NDIMS1 42560015 SLL R2,3 42600015 AR R2,R0 BUMP DOPE VECTOR OFFSET 42640015 AH R2,DVOFF 42680015 STH R2,DVOFF 42720015 SPACE 42760015 ST R6,0(R7) 42800015 AR R7,R0 42840015 SPACE 42880015 BAL RR,ELSIZ FIND LENT AND BOUND 42920015 BC B,MAP24 BRANCH IF NON ADJUSTABLE 42960015 SPACE 43000015 SR R7,R0 43040015 L R6,0(R7) 43080015 SPACE 43120015 CLI BASESW,ON 43160015 BC BNE,MAP9 BRANCH IF NOT BASED 43200015 SPACE 43240015 MVI ADJ1SW,ON 43280015 SPACE 43320015 LA R5,1 43360015 TM DATBYT(R4),X'04' 43400015 BC BZ,MAP25 BRANCH IF BIT 43440015 SPACE 43480015 LA R5,8 43520015 TM DATBYT(R4),X'02' 43560015 BC BZ,MAP25 BRANCH IF CHARACTER 43600015 SPACE 43640015 LA R5,136 AREA 43680015 MAP25 ST R5,LENGTH 43720015 BC B,MAP26 43760015 SPACE 43800015 MAP24 SR R7,R0 43840015 L R6,0(R7) 43880015 SPACE 43920015 MAP26 L R1,START 43960015 LH R2,BOUND 44000015 SPACE 44040015 CH R2,STRBND 44050015 BC BNH,MAP27 44060015 STH R2,STRBND UPDATE STRUCTURE BOUND 44070015 SPACE 44080015 MAP27 AR R1,R2 44090015 BCTR R1,0 START + BOUND - 1 44120015 SPACE 44160015 LCR R2,R2 SET UP MASK 44200015 NR R1,R2 SET START TO CORRECT VALUE 44240015 ST R1,START 44280015 EJECT 44320015 * MAP3 44360015 * 44400015 * 44440015 * 44480015 * FUNCTIONS 44520015 * 44560015 * (1) FOR SCALAR VARIABLES - TO SET THE BYTE AND BIT 44600015 * OFFSETS OF THE VARIABLE FROM THE START OF THE STRUCTURE 44640015 * INTO THE OFFSET1 AND OFFSET2 SLOTS OF ITS DICTIONARY 44680015 * ENTRY 44720015 * 44760015 * (2) FOR ARRAYS - TO SET THE BIT OFFSET OF THE FIRST 44800015 * ELEMENT INTO THE VIRTUAL ORIGIN SLOT, AND TO CALCULATE 44840015 * MULTIPLIERS FOR ANY UNINHERITED DIMENSIONS 44880015 * 44920015 * 44960015 * 45000015 * ENTRY POINT - MAP3 45040015 * 45080015 * 45120015 * 45160015 * EXTERNAL ROUTINES 45200015 * 45240015 * (1) MAP8 TO PROCESS THE MULTIPLIERS 45280015 * 45320015 * (2) NXTRF1 TO OBTAIN THE NEXT MEMBER OF THE STRUCTURE 45360015 * 45400015 * 45440015 * 45480015 * EXITS - NORMAL - 45520015 * 45560015 * (1) TO MAP2 IF THE NEXT MEMBER IS A BASE ELEMENT 45600015 * 45640015 * (2) TO MAP12 IF THE NEXT MEMBER IS A STRUCTURE AT 45680015 * THE SAME LEVEL AS THE CURRENT BASE ELEMENT 45720015 * 45760015 * (3) TO MAP4 IN ANY OTHER CASE 45800015 * 45840015 * 45880015 * 45920015 * EXITS - ERROR - TO CALLING ROUTINE IF THE AGGREGATE 45960015 * IS TOO LARGE 46000015 SPACE 10 46040015 MAP3 TM 0(R4),X'10' 46080015 BC BO,MAP31 BRANCH IF DIMENSIONED 46120015 SPACE 46160015 L R2,START *** SCALAR 46200015 SR R3,R3 46240015 SRDL R2,3 BYTE IN R2 46280015 SRL R3,24 BIT IN R3 46320015 SPACE 46360015 ST R2,0(R7) 46400015 MVC 5(3,R4),1(R7) BYTE OFFSET 46440015 SPACE 46480015 LR R2,R4 46520015 TM 0(R4),X'0F' 46560015 BC BNO,MAP32 NOT DATA 46600015 LA R2,6(R2) 46640015 SPACE 46680015 MAP32 TM VARBYT(R4),X'80' 46720015 BC BZ,MAP33 NO OFFSET 2 46760015 SPACE 46800015 STC R3,15(R2) BIT OFFSET 46840015 BC B,MAP33 46880015 SPACE 46920015 MAP31 CLI AREASW,ON 46960015 BC BNE,MAP311 BRANCH IF NOT AREA 47000015 SPACE 47040015 L RR,LENGTH 47080015 ST RR,LNGTH1 47120015 LA RR,63(RR) 47160015 SRL RR,6 47200015 SLL RR,6 47240015 ST RR,LENGTH M'PLIER MUST BE MULT OF 8 47280015 S RR,LNGTH1 47320015 ST RR,LNGTH1 ADJUSTMENT FACTOR 47360015 SPACE 47400015 MAP311 MVC PAR1+2(2),DIMTAB 47440015 BALR RR,LR DECODE DIMTAB REFERENCE 47480015 L R5,PAR1 47520015 SPACE 47560015 MVC 8(4,R5),START SET VO SLOT TO START 47600015 SPACE 47640015 ST R6,0(R7) SAVE R6 47680015 AR R7,R0 47720015 SPACE 47760015 LH R1,NDIMS1 47800015 SLA R1,3 8 * DIMENSIONS 47840015 LA R5,4(R5,R1) LAST LBOUND/HBOUND PAIR 47880015 SPACE 47920015 LH R1,NDIMS1 47960015 SLA R1,2 4 * DIMENSIONS 48000015 LA R6,4(R5,R1) LAST MULTIPLIER 48040015 SPACE 48080015 LH R1,NDIMS1 48120015 SH R1,NDIMS NO. DIMS OWNED 48160015 BC BZ,MAP34 BRANCH IF ALL INHERITED 48200015 SPACE 48240015 MVI MULTSW,ON 48280015 BAL RR,MAP8 48320015 MVI MULTSW,OFF 48360015 SPACE 48400015 CLI AREASW,ON 48440015 BC BNE,MAP34 BRANCH IF NOT AREA 48480015 SPACE 48520015 L RR,LENGTH 48560015 S RR,LNGTH1 48600015 ST RR,LENGTH XORRECT LENGTH 48640015 SPACE 48680015 MAP34 SR R7,R0 48720015 L R6,0(R7) 48760015 SPACE 48800015 MAP33 L R2,START 48840015 A R2,LENGTH UPDATE START 48880015 ST R2,START 48920015 SPACE 48960015 TM DATOT1(R4),X'08' 49000015 BC BZ,MAP39 BRANCH IF NOT END OF STRUCTURE 49040015 SPACE 49080015 MVI ENDSW,ON 49120015 MVC SVREF1(2),EFFS SET SVREF1 TO IMPOSSIBLE VALUE 49160015 BC B,MAP4 49200015 SPACE 49240015 MAP39 BAL RR,NXTRF1 GET NEXT MEMBER 49280015 SPACE 49320015 LR R3,R4 49350015 TM 0(R4),X'0F' 49380015 BC BNO,MAP391 BRANCH IF NOT DATA 49410015 LA R3,6(R3) 49440015 SPACE 49470015 MAP391 TM VARBYT(R4),X'80' 49500015 BC BZ,MAP392 BRANCH IF NO OFFSET 2 49530015 LA R3,4(R3) 49560015 SPACE 49590015 MAP392 TM VARBYT(R4),X'40' 49620015 BC BZ,MAP393 BRANCH IF UNDIMNESIONED 49650015 LA R3,3(R3) 49680015 SPACE 49710015 MAP393 CLC XREF(2,R6),17(R3) COMPARE CONT STR REF 49740015 BC BNE,MAP394 BRANCH IF NOT THE SAME 49770015 SPACE 49800015 TM 0(R4),X'0F' 49830015 BC BO,MAP2 BRANCH IF DATA ITEM 49860015 SPACE 49890015 TM 0(R4),X'0E' 49920015 BC BO,MAP12 BRANCH IF STRUCTURE 49950015 BC B,MAP2 49980015 SPACE 50010015 MAP394 MVC SVREF1(2),REF1 SAVE REFERENCE 50040015 EJECT 50120015 * MAP4 50160015 * 50200015 * 50240015 * 50280015 * FUNCTIONS 50320015 * 50360015 * (1) TO DETERMINE THE MULTIPLIERS FOR A MINOR 50400015 * STRUCTURE 50440015 * 50480015 * (2) TO UPDATE START 50520015 * 50560015 * (3) TO COPY THE MULTIPLIERS INTO THE BASE 50600015 * ELEMENTS OF THE MINOR STRUCTURE 50640015 * 50680015 * 50720015 * 50760015 * ENTRY POINT - MAP4 50800015 * 50840015 * 50880015 * 50920015 * EXTERNAL ROUTINES 50960015 * 51000015 * (1) MAP8 TO PROCESS THE MULTIPLIERS 51040015 * 51080015 * (2) NXTRF1 TO OBTAIN THE NEXT MEMBER OF THE STRUCTURE 51120015 * 51160015 * 51200015 * 51240015 * EXITS - NORMAL - 51280015 * 51320015 * (1) TO MAP5 AT THE END OF THE MINOR STRUCTURE 51360015 * IF ENDSW IS OFF 51400015 * 51440015 * (2) TO MAP6 AT THE END OF THE MINOR STRUCTURE 51480015 * IF ENDSW IS OFF 51520015 * 51560015 * 51600015 * 51640015 * EXITS - ERROR - NONE 51680015 SPACE 10 51720015 MAP4 MVC PAR1+2(2),XREF(R6) 51760015 BALR RR,LR DECODE MOST RECENT XREF 51800015 L R4,PAR1 51840015 XC REDUCT(4),REDUCT 51880015 SPACE 51920015 TM DATOT4(R4),X'04' 51930015 BC BZ,MAP46 BRANCH IF NOT MAJOR STR 51940015 MVC XALIGN(1,R6),STRBND+1 51950015 SPACE 51960015 MAP46 TM 0(R4),X'10' 51970015 BC BZ,MAP41 BRANCH IF UNDIMENSIONED 52000015 SPACE 52040015 LR R3,R4 52080015 TM VARBYT(R4),X'80' 52120015 BC BZ,MAP42 BRANCH IF NO OFFSET 2 52160015 LA R3,4(R3) 52200015 SPACE 52240015 MAP42 SR R1,R1 52280015 IC R1,15(R3) ACTUAL NUMBER OF DIMENSIONS 52320015 SPACE 52360015 CH R1,XINHDM(R6) 52400015 BC BE,MAP41 BRANCH IF ALL INHERITED 52440015 SPACE 52480015 STH R1,NDIMS2 52520015 SH R1,XINHDM(R6) 52560015 STH R1,NDIMS3 52600015 SPACE 52640015 L R2,START 52680015 S R2,XSTART(R6) TRUE LENGTH IN BITS 52720015 ST R2,REDUCT 52760015 SPACE 52800015 IC R1,XALIGN(R6) 52840015 AR R2,R1 TRUE LENGTH + ALIGNMENT 52880015 BCTR R2,0 52920015 SPACE 52960015 LCR R1,R1 53000015 NR R2,R1 REQUIRED LENGTH FOR MULTIPLIERS 53040015 ST R2,BASMLT 53080015 ST R2,LENGTH 53120015 S R2,REDUCT 53160015 ST R2,REDUCT 53200015 SPACE 53240015 MVC PAR1+2(2),16(R3) 53280015 BALR RR,LR DECODE DIMTAB REFERENCE 53320015 L R5,PAR1 53360015 SPACE 53400015 ST R6,0(R7) SAVE R6 53440015 AR R7,R0 53480015 SPACE 53520015 LH R1,NDIMS3 53560015 SLA R1,3 8 * DIMENSIONS 53600015 LA R5,4(R5,R1) LAST LBOUND / HBOUND PAIR 53640015 SPACE 53680015 LH R1,NDIMS3 53720015 SLA R1,2 4 * DIMENSIONS 53760015 LA R6,4(R5,R1) LAST MULTIPLIER 53800015 SPACE 53840015 LH R1,NDIMS3 NO. DIMENSIONS OWNED 53880015 SPACE 53920015 BAL RR,MAP8 54000015 SPACE 54080015 SR R7,R0 54120015 L R6,0(R7) RESTORE R6 54160015 SPACE 54200015 L R2,XSTART(R6) 54240015 A R2,LENGTH 54280015 ST R2,START RESET START 54320015 SPACE 54360015 MAP43 TM DATOT1(R4),X'08' 54400015 BC BO,MAP6 BRANCH IF END OF STRUCTURE 54440015 SPACE 54480015 MAP44 BAL RR,NXTRF1 GET NEXT MEMBER OF STRUCTURE 54520015 SPACE 54560015 CLC REF1(2),SVREF1 54600015 BC BE,MAP5 BRANCH IF END OF MINOR STRUCTURE 54640015 SPACE 54680015 LR R3,R4 54720015 TM 0(R4),X'0F' 54760015 BC BNO,MAP45 BRANCH IF NOT DATA VARIABLE 54800015 SPACE 54840015 LA R3,6(R3) UPDATE R3 54880015 BC B,MAP451 54920015 SPACE 54960015 MAP45 TM 0(R4),X'0E' 55000015 BC BO,MAP44 BRANCH IF STRUCTURE 55040015 SPACE 55080015 MAP451 TM VARBYT(R4),X'80' 55120015 BC BZ,MAP452 BRANCH IF NO OFFSET 2 55160015 LA R3,4(R3) 55200015 SPACE 55240015 MAP452 ST R6,0(R7) SAVE R6 55280015 AR R7,R0 55320015 SPACE 55360015 MVC NDIMS4+1(1),15(R3) NO DIMS FOR ELEMENT 55400015 MVC PAR1+2(2),16(R3) DECODE DIMTAB REFERENCE 55440015 BALR RR,LR 55480015 L R5,PAR1 55520015 SPACE 55560015 LH R6,NDIMS4 55600015 SLA R6,3 8 * NDIMS4 IN R6 55640015 SPACE 55680015 LH R1,NDIMS2 55720015 SLA R1,2 4 * NDIMS2 IN R1 55760015 SPACE 55800015 LA R6,0(R1,R6) 55840015 LA R6,8(R5,R6) POINT TO APPROPRIATE MULTIPLIER 55880015 SPACE 55920015 AR R1,R1 8 * NDIMS2 IN R2 55960015 LA R5,4(R1,R5) POINT TO APPROPRIATE LBOUND 56000015 SPACE 56040015 LH R1,NDIMS3 NO. DIMS TO BE PROCESSED 56080015 MVC LENGTH(4),BASMLT BASE MULTIPLIER 56120015 SPACE 56160015 MVI MULTSW,ON H39 56180016 BAL RR,MAP8 SET UP MULTIPLIERS 56200015 MVI MULTSW,OFF H39 56220016 SPACE 56240015 SR R7,R0 56280015 L R6,0(R7) RESTORE R6 56320015 SPACE 56360015 BC B,MAP43 RETURN FOR NEXT ELEMENT 56400015 SPACE 56440015 MAP41 CLI ENDSW,ON ENTRY FOR STRS WITH 'NO DIMS' 56480015 BC BE,MAP6 BRANCH IF END OF STRUCTURE 56520015 SPACE 56560015 MVC REF1(2),SVREF1 H39 56580016 MVC PAR1+2(2),SVREF1 56600015 BALR RR,LR DECODE SVREF1 56640015 L R4,PAR1 56680015 EJECT 56720015 * MAP5 56760015 * 56800015 * 56840015 * 56880015 * FUNCTIONS 56920015 * 56960015 * TO REMOVE THE CURRENT STACK ENTRY AND TO 57000015 * TEST FOR THE FOLLOWING CONDITIONS 57040015 * (A) THE NEW 'XREF' DOES NOT IMMEDIATELY 57080015 * CONTAIN 'SVREF1' 57120015 * (B) THE NEW 'XREF' DOES IMMEDIATELY CONTAIN 57160015 * 'SVREF1' WHICH IS A DATA ITEM OR LEFT 57200015 * (C) THE NEW 'XREF' DOES IMMEDIATELY CONTAIN 57240015 * 'SVREF1' WHICH IS A STRUCTURE 57280015 * 57320015 * 57360015 * 57400015 * ENTRY POINT - MAP5 57440015 * 57480015 * 57520015 * 57560015 * EXITS - NORMAL - 57600015 * 57640015 * (1) IN CASE A TO MAP4 57680015 * 57720015 * (2) IN CASE B TO MAP2 57760015 * 57800015 * (3) IN CASE C TO MAP12 57840015 * 57880015 * 57920015 * 57960015 * EXITS - ERROR - NONE 58000015 SPACE 10 58040015 MAP5 S R6,K16 REMOVE ENTRY FROM STACK 58080015 MVC NDIMS(2),XINHDM+16(R6) I4A 58100016 SPACE 58120015 LR R3,R4 58160015 TM 0(R4),X'0F' 58200015 BC BNO,MAP51 BRANCH IF NOT DATA 58240015 LA R3,6(R3) 58280015 SPACE 58320015 MAP51 TM VARBYT(R4),X'80' 58360015 BC BZ,MAP52 BRANCH IF NO OFFSET 2 58400015 LA R3,4(R3) 58440015 SPACE 58480015 MAP52 TM VARBYT(R4),X'40' 58520015 BC BZ,MAP53 BRANCH IF UNDIMENSIONED 58560015 LA R3,3(R3) 58600015 SPACE 58640015 MAP53 CLC XREF(2,R6),17(R3) COMPARE CONT STR REF 58680015 BC BNE,MAP4 BRANCH IF NOT THE SAME 58720015 SPACE 58760015 TM 0(R4),X'0F' 58800015 BC BO,MAP2 BRANCH IF DATA 58840015 SPACE 58880015 TM 0(R4),X'0E' 58920015 BC BO,MAP12 BRANCH IF STRUCTURE 58960015 BC B,MAP2 BRANCH IF A 'LEFT' 59000015 EJECT 59040015 * MAP6 59080015 * 59120015 * 59160015 * 59200015 * FUNCTIONS 59240015 * 59280015 * (1) FOR MINOR STRUCTURES, TO RETURN TO PROCESS 59320015 * THE IMMEDIATELY CONTAINING STRUCTURE 59360015 * 59400015 * (2) FOR MAJOR STRUCTURES, TO SET THE 59440015 * (A) DOPE VECTOR SIZE 59480015 * (B) OFFSET FROM THE MAXIMUM BOUND 59520015 * (C) THE BOUNDARY REQUIREMENT 59560015 * (D) THE LENGTH IN BITS 59600015 * 59640015 * (3) FOR BASE ELEMENTS WHICH ARE ARRAYS, THE 59680015 * MULTIPLIERS AND VIRTUAL ORIGIN ARE SET TO 59720015 * THEIR REQUIRED FORMAT 59760015 * 59800015 * 59840015 * 59880015 * ENTRY POINT - MAP6 59920015 * 59960015 * 60000015 * 60040015 * EXTERNAL ROUTINES 60080015 * 60120015 * (1) NXTRF2 TO OBTAIN THE NEXT BASE ELEMENT 60160015 * 60200015 * 60240015 * 60280015 * EXITS - NORMAL - TO CALLING ROUTINE 60320015 * 60360015 * 60400015 * 60440015 * EXITS - ERROR - NONE 60480015 * 60520015 * 60560015 * 60600015 * N.B. 60640015 * 60680015 * ON ENTRY TO MAP6, THE VIRTUAL ORIGIN SLOT 60720015 * CONTAINS THE ADDRESS OF THE FIRST ELEMENT OF 60760015 * THE ARRAY IN BITS AND THE MULTIPLIERS ARE 60800015 * EXPRESSED AS BIT LENGTHS 60840015 SPACE 10 60880015 MAP6 MVC PAR1+2(2),XREF(R6) 60920015 BALR RR,LR DECODE STRUCTURE REFERENCE 60960015 L R4,PAR1 61000015 SPACE 61040015 TM DATOT4(R4),X'04' 61080015 BC BO,MAP61 BRANCH IF MAJOR STRUCTURE 61120015 SPACE 61160015 S R6,K16 61200015 MVC NDIMS(2),XINHDM+16(R6) H39 61220016 BC B,MAP4 BRANCH TO PROCESS CONT STRUCT 61240015 SPACE 61280015 MAP61 LR R3,R4 61320015 TM VARBYT(R4),X'80' 61360015 BC BZ,MAP62 BRANCH IF NO OFFSET 2 61400015 LA R3,4(R3) 61440015 SPACE 61480015 MAP62 TM VARBYT(R4),X'40' 61520015 BC BZ,MAP63 BRANCH IF UNDIMENSIONED 61560015 LA R3,3(R3) 61600015 SPACE 61640015 MAP63 MVC 5(2,R4),DVOFF SET DOPE VECTOR SIZE 61680015 MVI 17(R3),X'00' SET OFFSET FROM MAX BOUND 61720015 MVI 21(R3),X'40' SET ALIGNMENT 61760015 L R2,START 61800015 S R2,REDUCT ALLOW FOR SPACE AT END 61840015 ST R2,REDUCT 61880015 MVC 22(3,R3),REDUCT+1 SET LENGTH 61920015 SPACE 61960015 MAP631 BAL RR,NXTRF2 GET NEXT BASE ELEMENT 62000015 SPACE 62040015 TM 0(R4),X'10' 62080015 BC BZ,MAP64 BRANCH IF NOT ARRAY 62120015 SPACE 62160015 MVI BITSW,OFF 62200015 LR R3,R4 62240015 SPACE 62280015 TM 0(R4),X'0F' 62320015 BC BNO,MAP65 BRANCH IF NOT DATA 62360015 LA R3,6(R3) 62400015 SPACE 62440015 TM DATBYT(R4),X'84' 62480015 BC BNZ,MAP65 BRANCH IF NOT BIT STRING 62520015 MVI BITSW,ON 62560015 SPACE 62600015 MAP65 TM VARBYT(R4),X'80' 62640015 BC BZ,MAP66 62680015 LA R3,4(R3) 62720015 SPACE 62760015 MAP66 MVC NDIMS1+1(1),15(R3) NUMBER OF DIMENSIONS 62800015 MVC PAR1+2(2),16(R3) 62840015 BALR RR,LR DECODE DIMTAB REF 62880015 L R5,PAR1 62920015 SPACE 62960015 CLI BITSW,ON 63000015 BC BE,MAP67 BRANCH IF BIT STRING ARRAY 63040015 SPACE 63080015 L R6,8(R5) 63120015 SRA R6,3 CONVERT 'V.O.' TO BYTES 63160015 ST R6,8(R5) 63200015 SPACE 63240015 LH R1,NDIMS1 NO. DIMS. IN R1 63280015 LR R2,R1 63320015 SLA R2,3 8 * NDIMS1 IN R2 63360015 LA R2,12(R2,R5) POINT TO FIRST MULTIPLIER 63400015 SPACE 63440015 MAP68 L R6,0(R2) 63480015 SRA R6,3 63520015 ST R6,0(R2) CONVERT MULTIPLIERS TO BYTES 63560015 LA R2,4(R2) 63600015 BCT R1,MAP68 63640015 SPACE 63680015 MAP67 LH R1,NDIMS1 NO. DIMS. IN R1 63720015 LR R3,R1 63760015 SLA R3,3 8 * NDIMS1 IN R3 63800015 LA R3,12(R3,R5) POINT TO FIRST MULTIPLIER 63840015 LA R2,12(R5) POINT TO FIRST LBOUND 63880015 L RR,8(R5) 'V.O.' 63920015 SPACE 63960015 MAP69 L R6,0(R3) 64000015 MH R6,2(R2) 64040015 SR RR,R6 INCREMENT 'V.O.' 64080015 LA R2,8(R2) 64120015 LA R3,4(R3) UPDATE POINTERS 64160015 BCT R1,MAP69 64200015 SPACE 64240015 CLI BITSW,ON 64280015 BC BNE,MAP691 BRANCH IF NOT BIT STRING ARRAY 64320015 SPACE 64360015 LR R1,RR 64400015 SLL R1,29 CONVERT VIRTUAL ORIGIN TO 64440015 SRL RR,3 BIT - BYTE FORMAT 64480015 OR RR,R1 64520015 SPACE 64560015 MAP691 ST RR,8(R5) STORE VIRTUAL ORIGIN 64600015 SPACE 64640015 MAP64 TM DATOT1(R4),X'08' 64680015 BC BZ,MAP631 BRANCH IF NOT END OF STRUCTURE 64720015 SPACE 64760015 NC V1SW(1),RCIOSW 64800015 BC BZ,MAP641 BRANCH IF NO VAR STRINGS AND RDV 64840015 SPACE 64880015 CLI COBLSW,ON 64920015 BC BE,MAP641 64960015 SPACE 65000015 MVC PAR7+2(2),REF 65040015 BAL RR,ERROR 65080015 DC X'00044254' 65120015 SPACE 65160015 MAP641 L RR,MAPRR 65200015 BCR B,RR RETURN 65240015 EJECT 65280015 * MAP8 65320015 * 65360015 * 65400015 * 65440015 * FUNCTIONS 65480015 * 65520015 * TO SET MULTIPLIERS IN A DIMENSION TABLE 65560015 * GIVEN POINTERS TO THE DIMENSION TABLE AND A 65600015 * COUNT OF DIMENSIONS TO BE PROCESSED 65640015 * 65680015 * 65720015 * 65760015 * ENTRY POINT - MAP8 65800015 * 65840015 * 65880015 * 65920015 * EXITS - NORMAL - 65960015 * 66000015 * (1) TO CALLING ROUTINE FOR FIXED BOUNDS OR 66040015 * ADJUSTABLE BASED 66080015 * 66120015 * (2) TO MAP9 FOR ADJUSTABLE BOUNDS 66160015 * 66200015 * 66240015 * 66280015 * EXITS - ERROR - TO ERROR IF AGGREGATE 66320015 * IS TOO LARGE 66360015 * 66400015 * 66440015 * 66480015 * N.B. 66520015 * 66560015 * R5 POINTS TO THE LEAST MAJOR LBOUND TO BE PROCESSED 66600015 * 66640015 * R6 POINTS TO THE LEAST MAJOR MULTIPLIER 66680015 * 66720015 * R1 CONTAINS THE DIMENSION COUNT 66760015 * 66800015 * LENGTH CONTAINS THE INITIAL MULTIPLIER AND 66840015 * IS RETURNED CONTAINING THE AGGREGATE LENGTH 66880015 SPACE 10 66920015 MAP8 CLI MULTSW,OFF 66960015 BC BE,MAP81 BRANCH IF NO MULTS TO BE SET UP 67000015 SPACE 67040015 MVC 0(4,R6),LENGTH SET MULTIPLIERS 67080015 SPACE 67120015 MAP81 TM 4(R5),X'FF' 67160015 BC BZ,MAP36 BRANCH IF NON ADJUSTABLE 67200015 SPACE 67240015 CLI BASESW,ON 67280015 BC BE,MAP351 67320015 SPACE 67360015 SR R7,R0 67400015 L R6,0(R7) RESET R6 AND R7 67440015 BC B,MAP9 67480015 SPACE 67520015 MAP351 MVI ADJ1SW,ON 67560015 LA R3,1 DUMMY INFORMATION FOR BASED 67600015 BC B,MAP37 67640015 SPACE 67680015 MAP36 LH R3,6(R5) HBOUND 67720015 SPACE 67760015 TM 0(R5),X'FF' 67800015 BC BZ,MAP361 BRANCH IF NOT ADJUSTABLE 67840015 SPACE 67880015 SR R7,R0 67920015 L R6,0(R7) RESET R6 AND R7 67960015 BC B,MAP9 68000015 SPACE 68040015 MAP361 SH R3,2(R5) HB-LB 68080015 LA R3,1(R3) HBOUND-LBOUND+1 68120015 SPACE 68160015 MAP37 M R2,LENGTH 68200015 SPACE 68240015 LTR R2,R2 68280015 BC BNZ,MAP38 BRANCH IF AGGREGATE TOO LARGE 68320015 SPACE 68360015 CL R3,CMAXSZ 68400015 BC BNH,MAP381 BRANCH IF NOT TOO LARGE 68440015 SPACE 68480015 MAP38 MVC PAR7+2(2),REF 68520015 BAL RR,ERROR GENERATE ERROR MESSAGE 68560015 DC X'00044014' 68600015 SPACE 68640015 SR R7,R0 68680015 L R6,0(R7) RESET R6 AND R7 68720015 SPACE 68760015 L RR,MAPRR AND RETURN 68800015 BCR B,RR 68840015 SPACE 68880015 MAP381 ST R3,LENGTH 68920015 SPACE 68960015 SR R5,R0 69000015 SR R5,R0 RESET R5 69040015 SR R6,R0 AND R6 69080015 SPACE 69120015 BCT R1,MAP8 REPEAT LOOP 69160015 SPACE 69200015 BCR B,RR RETURN 69240015 EJECT 69280015 * MAP9 69320015 * 69360015 * 69400015 * 69440015 * FUNCTIONS 69480015 * 69520015 * TO MAKE A DICTIONARY ENTRY FOR ONE OR THE 69560015 * OTHER OF THE LIBRARY ROUTINES IHESTRC AND 69600015 * IHESTRD. THE REFERENCES ARE PLACED IN MCOBOL 69640015 * AND MCNTIG RESPECTIVELY FOR USE BY IEMJK AND 69680015 * THE PART OF THE ROUTINE USED IS THEN BY-PASSED. 69720015 * 69760015 * 69800015 * 69840015 * ENTRY POINT - MAP9 69880015 * 69920015 * 69960015 * 70000015 * EXTERNAL ROUTINES 70040015 * 70080015 * (1) ZDICRF IN COMPILER CONTROL 70120015 * 70160015 * 70200015 * 70240015 * EXITS - NORMAL - TO ROUTINE WHICH CALLED MAP 70280015 * 70320015 * 70360015 * 70400015 * EXITS - ERROR - NONE 70440015 SPACE 10 70480015 MAP9 MVC PAR1+2(2),REF 70520015 BALR RR,LR DECODE MAJOR STRUCTURE REFERENCE 70560015 L R4,PAR1 70600015 SPACE 70640015 OI 7(R4),X'02' SET ADJUSTABLE BIT ON 70680015 SPACE 70720015 MAP93 BC NOP,MAP92 70760015 SPACE 70800015 MVC LIBENT+3(2),STATH2 70840015 MVI LIBENT+8,X'D1' IHESTRC 70880015 SPACE 70920015 LA R2,LIBENT 70960015 LA R3,LIBNT1-LIBENT SET UP PARAMETERS 71000015 STM R2,R3,PAR1 71040015 L RR,ZDICRF MAKE DICTIONARY ENTRY 71080015 BALR RR,RR 71120015 SPACE 71160015 MVC STATH2(2),PAR1+2 71200015 MVC MCOBOL(2),PAR1+2 71240015 SPACE 71280015 OI MAP93+1,X'F0' SET BYPASS 71320015 SPACE 71360015 MAP92 BAL RR,NXTRF2 GET NEXT ELEMENT 71400015 SPACE 71440015 TM 0(R4),X'10' 71480015 BC BZ,MAP94 BRANCH IF OT DIMENSIONED 71520015 SPACE 71560015 LR R3,R4 71600015 TM 0(R4),X'0F' 71640015 BC BNO,MAP95 BRANCH IF NOT DATA 71680015 SPACE 71720015 TM DATBYT(R4),X'84' 71760015 BC BZ,MAP94 BRANCH IF BIT STRING 71800015 LA R3,6(R3) 71840015 SPACE 71880015 MAP95 MVC PAR1+2(2),20(R3) 71920015 BALR RR,LR DECODE DIMTAB REFERENCE 71960015 L R3,PAR1 72000015 SPACE 72040015 SR R1,R1 72080015 IC R1,5(R3) NO OF DIMENSIONS 72120015 LR R2,R1 72160015 SLL R2,3 8 * N IN R2 72200015 LA R3,12(R2,R3) POINT TO MULTIPLIERS 72240015 SPACE 72280015 MAP96 L R2,0(R3) 72320015 SRA R2,3 CONVERT MULT TO BYTES 72360015 ST R2,0(R3) 72400015 LA R3,4(R3) UPDATE POINTER 72440015 BCT R1,MAP96 72480015 SPACE 72520015 MAP94 TM DATOT1(R4),X'08' 72560015 BC BZ,MAP92 BRANCH IF NOT END OF STR 72600015 SPACE 72640015 MVC PAR1+2(2),REF 72680015 BALR RR,LR DECODE MAJOR STR REF 72720015 L R4,PAR1 72760015 SPACE 72800015 L RR,MAPRR 72840015 BCR B,RR AND RETURN 72880015 EJECT 72920015 * CHECK 72960015 * 73000015 * 73040015 * 73080015 * FUNCTIONS 73120015 * 73160015 * TO SCAN THROUGH A CONTIGUOUS STRUCTURE TO CHECK 73200015 * FOR THOSE ELEMENTS THAT COULD GIVE RISE TO ERRORS 73240015 * 73280015 * (1) AREAS 73320015 * (2) EVENTS 73360015 * (3) TASKS 73400015 * 73440015 * 73480015 * 73520015 * ENTRY POINT - CHECK 73560015 * 73600015 * 73640015 * 73680015 * EXTERNAL ROUTINES 73720015 * 73760015 * (1) NXTRF2 TO FIND THE NEXT ELEMENT OF THE STRUCTURE 73800015 * 73840015 * (2) ERROR TO GENERATE ERROR MESSAGES 73880015 * 73920015 * 73960015 * 74000015 * EXITS - NORMAL - TO MAPA 74040015 * 74080015 * 74120015 * 74160015 * EXITS - ERROR - NONE 74200015 SPACE 10 74240015 CHECK ST RR,MAPRR 74280015 SPACE 74320015 CHECK1 BAL RR,NXTRF2 GET NEXT ELEMENT 74360015 MVC PAR7+2(2),REF1 SET PAR7 UP 74400015 SPACE 74440015 TM 0(R4),X'10' I4A 75040016 BC BZ,CHECK6 BRANCH IF NOT ARRAY 75680015 SPACE 75720015 TM DATOT1(R4),X'10' 75760015 BC BO,DVD BRANCH TO MAKE A DVD 75800015 SPACE 75840015 CHECK6 TM DATOT1(R4),X'08' 75880015 BC BZ,CHECK1 BRANCH IF NOT END OF STRUCTURE 75920015 SPACE 75960015 MVC PAR1+2(2),REF 76000015 BALR RR,LR DECODE STRUCTURE REFERENCE 76040015 L R4,PAR1 76080015 SPACE 76120015 L RR,MAPRR DROP THROUGH TO MAPA 76160015 EJECT 76200015 * MAPA 76240015 * 76280015 * 76320015 * 76360015 * FUNCTIONS 76400015 * 76440015 * TO SCAN THROUGH A STRUCTURE, MAPPED ACCORDING 76480015 * TO THE PL/1 ALGORITHM, TO CHECK FOR ADJUSTABLE 76520015 * EXTENTS 76560015 * ON THE FIRST TIME THAT ONE IS FOUND, A 76600015 * DICTIONARY ENTRY IS MADE FOR THE LIBRARY 76640015 * MODULE IHESTRB AND ITS REFERENCE IS PLACED 76680015 * IN MPL1. THE ROUTINE IS THEN BY-PASSED 76720015 * 76760015 * 76800015 * 76840015 * ENTRY POINTS - 76880015 * 76920015 * (1) MAPA FOR STRUCTURES 76960015 * 77000015 * (2) MAPA1 FOR ADJUSTABLE ARRAYS 77040015 * 77080015 * 77120015 * 77160015 * EXTERNAL ROUTINES 77200015 * 77240015 * (1) NXTRF2 TO OBTAIN THE NEXT ELEMENT IN THE STRUCTURE 77280015 * 77320015 * (2) ZDICRF IN COMPILER CONTROL 77360015 * 77400015 * 77440015 * 77480015 * EXITS - NORMAL - TO CALLING ROUTINE 77520015 * 77560015 * 77600015 * 77640015 * EXITS - ERROR - NONE 77680015 SPACE 10 77720015 MAPA BCR NOP,RR 77760015 SPACE 77800015 ST RR,MAPRR 77840015 SPACE 77880015 TM DATOT1(R4),X'04' 77920015 BC BO,MAPA1 BRANCH IF ADJUSTABLE EXTENTS 77960015 SPACE 78000015 MAPA2 BAL RR,NXTRF2 GET NEXT ELEMENT 78040015 SPACE 78080015 TM DATOT1(R4),X'04' 78120015 BC BO,MAPA1 BRANCH IF ADJ DIMS 78160015 SPACE 78200015 TM 0(R4),X'0F' 78240015 BC BNO,MAPA4 BRANCH IF NOT DATA 78280015 SPACE 78320015 TM DATBYT(R4),X'80' 78360015 BC BZ,MAPA3 BRANCH IF STRING 78400015 SPACE 78440015 MAPA4 TM DATOT1(R4),X'08' 78480015 BC BZ,MAPA2 BRANCH IF NOT END OF STRUCTURE 78520015 SPACE 78560015 L RR,MAPRR 78600015 BCR B,RR RETURN 78640015 SPACE 78680015 MAPA3 TM DATBYT(R4),X'40' 78720015 BC BZ,MAPA4 BRANCH IF NOT ADJUSTABLE 78760015 SPACE 78800015 MAPA1 BCR NOP,RR 78840015 SPACE 78880015 MVC LIBENT+3(2),STATH2 78920015 MVI LIBENT+8,X'D0' IHESTRB 78960015 SPACE 79000015 LA R2,LIBENT 79040015 LA R3,LIBNT1-LIBENT SET UP PARAMETERS 79080015 STM R2,R3,PAR1 79120015 L RR,ZDICRF MAKE DICTIONARY ENTRY 79160015 BALR RR,RR 79200015 SPACE 79240015 MVC STATH2(2),PAR1+2 79280015 MVC MPL1(2),PAR1+2 79320015 SPACE 79360015 OI MAPA+1,X'F0' SET BY-PASS TO ROUTINE 79400015 OI MAPA1+1,X'F0' 79440015 SPACE 79480015 L RR,MAPRR 79520015 BCR B,RR 79560015 EJECT 79600015 * DVD 79640015 * 79680015 * 79720015 * 79760015 * FUNCTIONS 79800015 * 79840015 * TO CREATE A DVD FOR AN ARRAY WHICH IS 79880015 * THE BASE ELEMENT OF A STRUCTURE 79920015 * 79960015 * 80000015 * 80040015 * ENTRY POINT - DVD 80080015 * 80120015 * 80160015 * 80200015 * EXTERNAL ROUTINES 80240015 * 80280015 * (1) ZDICRF IN COMPILER CONTROL 80320015 * 80360015 * 80400015 * 80440015 * EXITS - NORMAL - TO CHECK6 80480015 * 80520015 * 80560015 * 80600015 * EXITS - ERROR - NONE 80640015 SPACE 10 80680015 DVD LR R3,R4 80720015 TM 0(R4),X'0F' 80760015 BC BNO,DVDA NOT DATA ITEM 80800015 LA R3,6(R3) 80840015 SPACE 80880015 DVDA TM VARBYT(R4),X'80' 80920015 BC BZ,DVDB NO OFFSET 2 80960015 LA R3,3(R3) 81000015 SPACE 81040015 DVDB MVC DVD1(1),15(R3) NO OF DIMENSIONS 81080015 SPACE 81120015 BAL RR,ELSIZ GET ELEMENT LENGTH 81160015 BC B,DVDC ALLOW FOR BOTH RETURNS 81200015 SPACE 81240015 DVDC LH R3,BOUND 81280015 BCTR R3,0 81320015 STC R3,DVD2 81360015 MVC DVD3(1),LENGTH+3 81400015 SPACE 81440015 TM 0(R4),X'0F' 81480015 BC BNO,DVDG BRANCH IF NOT DATA 81520015 SPACE 81560015 TM DATBYT(R4),X'80' 81600015 BC BO,DVDD BRANCH IF ARITHMETIC 81640015 SPACE 81680015 MVI DVD3,X'00' ZERO FOR STRINGS 81720015 TM DATBYT(R4),X'02' 81760015 BC BZ,DVDE BRANCH IF NOT AREA 81800015 OI DVD1,X'80' SET AREA FLAG 81840015 SPACE 81880015 DVDE TM DATBYT(R4),X'10' 81920015 BC BZ,DVDF BRANCH IF NOT VARYING 81960015 OI DVD2,X'40' SET VARYING FLAG 82000015 SPACE 82040015 DVDF TM DATBYT(R4),X'04' 82080015 BC BO,DVDD BRANCH IF NOT BIT 82120015 SPACE 82160015 TM DATBYT(R4),X'20' 82200015 BC BZ,DVDD BRANCH IF PACKED 82240015 OI DVD2,X'80' SET ALIGNED BIT BIT 82280015 BC B,DVDD 82320015 SPACE 82360015 DVDG TM 0(R4),X'0D' 82400015 BC BNO,DVDD BRANCH IF NOT EVENT 82440015 MVI DVD3,X'FF' 82480015 OI DVD1,X'40' SET EVENT BIT 82520015 SPACE 82560015 DVDD MVC DVD0(2),STATH2 STATIC CHAIN 82600015 MVC DVD5(2),REF1 REFERENCE OF ITEM 82640015 MVC DVD6(2),8(R4) 82680015 LA R2,DVDSKL 82720015 LA R3,DVD4-DVDSKL 82760015 STM R2,R3,PAR1 82800015 L RR,ZDICRF INSERT DVD INTO DICT 82840015 BALR RR,RR 82880015 MVC STATH2(2),PAR1+2 RESET STATIC CHAIN 82920015 MVC 8(2,R4),PAR1+2 82960015 SPACE 83000015 BC B,CHECK6 83040015 EJECT 83080015 * NXTRF1 AND NXTRF2 83120015 * 83160015 * 83200015 * 83240015 * FUNCTIONS 83280015 * 83320015 * TO SCAN FOR THE NEXT ELEMENT OR FOR THE 83360015 * NEXT MEMBER OF A STRUCTURE 83400015 * 83440015 * (1) ON ENTRY R4 POINTS TO THE CURRENT STRUCTURE MEMBER 83480015 * 83520015 * (2) ON EXIT R4 POINTS TO THE REQUIRED MEMBER AND 83560015 * REF1 CONTAINS ITS REFERENCE 83600015 * 83640015 * 83680015 * 83720015 * ENTRY POINTS - 83760015 * 83800015 * (1) NXTRF1 TO FIND THE NEXT MEMBER 83840015 * 83880015 * (2) NXTRF2 TO FIND THE NEXT ELEMENT 83920015 * 83960015 * 84000015 * 84040015 * EXTERNAL ROUTINES 84080015 * 84120015 * (1) ZDRFAB IN COMPILER CONTROL 84160015 * 84200015 * 84240015 * 84280015 * EXITS - NORMAL - TO CALLING ROUTINE 84320015 * 84360015 * 84400015 * 84440015 * EXITS - ERROR - NONE 84480015 SPACE 10 84520015 NXTRF1 OI NXTRF3+1,X'F0' SET NEXT MEM SWITCH ON 84560015 BC B,NXTRF4 84600015 SPACE 84640015 NXTRF2 NI NXTRF3+1,X'0F' SET NEXT MEM SWITCH OFF 84680015 SPACE 84720015 NXTRF4 ST RR,NXTRR 84760015 SPACE 84800015 NXTRF5 LR R3,R4 84840015 SPACE 84880015 TM 0(R4),X'10' 84920015 BC BZ,NXTRF6 BRANCH IF NOT DIMENSIONED 84960015 LA R3,3(R3) 85000015 SPACE 85040015 NXTRF6 TM 0(R4),X'0F' 85080015 BC BNO,NXTRF7 BRANCH IF NOT DATA ITEM 85120015 LA R3,6(R3) 85160015 SPACE 85200015 NXTRF7 MVC REF1(2),23(R3) SET REF1 85240015 SPACE 85280015 MVC PAR1+2(2),23(R3) 85320015 BALR RR,LR DECODE REFERENCE 85360015 L R4,PAR1 85400015 SPACE 85440015 NXTRF3 BC B,NXTRF8 NEXT MEM SWITCH 85480015 SPACE 85520015 TM 0(R4),X'0F' 85560015 BC BO,NXTRF8 BRANCH IF DATA ITEM 85600015 SPACE 85640015 TM 0(R4),X'0E' 85680015 BC BO,NXTRF5 BRANCH IF STRUCTURE 85720015 SPACE 85760015 NXTRF8 L RR,NXTRR 85800015 BCR B,RR RETURN 85840015 EJECT 85880015 * ERROR 85920015 * 85960015 * 86000015 * 86040015 * FUNCTIONS 86080015 * 86120015 * TO INSERT ERROR MESSAGES INTO THE DICTIONARY 86160015 * 86200015 * 86240015 * 86280015 * ENTRY POINT - ERROR 86320015 * 86360015 * 86400015 * 86440015 * EXTERNAL ROUTINES 86480015 * 86520015 * (1) ZUERR IN COMPILER CONTROL 86560015 * 86600015 * 86640015 * 86680015 * EXITS - NORMAL - TO CALLING POINT + 8 86720015 * 86760015 * 86800015 * 86840015 * EXITS - ERROR - NONE 86880015 * 86920015 * 86960015 * 87000015 * N.B. 87040015 * 87080015 * THE MESSAGE INFORMATION IS FOUND AT 0(RR) 87120015 * 87160015 * THE DICTIONARY REFERENCE IS AT PAR5+2 87200015 * 87240015 * THE STATEMENT NUMBER IS AT ZSTAT+2 87280015 SPACE 10 87320015 ERROR ST RR,ERR 87360015 SPACE 87400015 MVC PAR6(4),0(RR) 87440015 L RR,ZUERR 87480015 BALR RR,RR MAKE ERROR ENTRY 87520015 SPACE 87560015 L RR,ERR 87600015 BC B,4(RR) 87640015 EJECT 87680015 * CONSTANTS AND WORK AREAS 87720015 SPACE 10 87760015 K0 DC 2F'0' TWO FULL WORD ZEROS 87800015 K16 DC F'16' 87840015 CMAXSZ DC X'03FFFFFF' 87880015 NAME1 DC C'JIZZ' 87920015 NAME2 DC C'JKZZ' PHASE NAMES 87960015 NAME3 DC C'JLZZ' 88000015 NAME4 DC C'JMZZ' 88040015 NAME5 DC C'JJZZ' 88080015 FWORD DC F'0' 88120015 EFFS DC H'-1' 88160015 SPACE 88200015 BASMLT DC F'0' 88240015 ERR DC F'0' 88280015 MAPRR DC F'0' 88320015 START DC F'0' 88360015 NXTRR DC F'0' 88400015 REDUCT DC F'0' 88440015 LNGTH1 DC F'0' 88480015 NDIMS1 DC H'0' 88520015 NDIMS2 DC H'0' 88560015 NDIMS3 DC H'0' 88600015 NDIMS4 DC H'0' 88640015 DIMTAB DC H'0' 88680015 NDIMS DC H'0' 88720015 STATH1 DC H'0' 88760015 STATH2 DC H'0' 88800015 STATH3 DC H'0' 88840015 SVREF1 DC H'0' 88880015 SVREF2 DC H'0' 88920015 MAXALG DC H'0' 88960015 CURLEV DC H'0' 89000015 HEAD1 DC H'0' 89040015 HEAD2 DC H'0' 89080015 HEAD3 DC H'0' 89120015 REF DC H'0' 89160015 REF1 DC H'0' 89200015 REF2 DC H'0' 89240015 STRBND DC H'0' 89260015 DVOFFA DC H'0' 89270015 ENDSW DC X'00' 89280015 MULTSW DC X'00' 89320015 RCIOSW DC X'00' 89360015 LIBENT DC X'C2000E0000' 89400015 DC X'0000000000' 89440015 DC X'00000000' 89480015 LIBNT1 EQU * 89520015 DVDSKL DC X'CC0010' 89560015 DVD0 DC X'0000000000' STATIC CHAIN 89600015 DVD5 DC X'0000' ITEM REFERENCE 89640015 DVD6 DC X'0000' STATEMENT NUMBER 89680015 DC X'C1' 89720015 DVD1 DC X'00' DIMENSIONS 89760015 DVD2 DC X'00' ALIGNMENT 89800015 DVD3 DC X'00' LENGTH 89840015 DVD4 EQU * 89880015 SPACE 89886001 * JI IS MADE UP TO 4K SO THAT JM MAY BE LOADED INTO 23103 89892001 * THE SPACE WHICH JI VACATES 23103 89898001 SPACE 89904001 ORG IEMJI+X'1000' 23103 89910001 SPACE 5 89920015 END IEMJI 89960015 ./ ADD SSI=04010014,NAME=IEMJJ,SOURCE=0 JJ TITLE 'IEMJJ, STRUCTURE PROCESSOR TEXT SKELETONS, OS/360, PL/1*00200015 COMPILER(F)' 00400015 * STATUS - CHANGE LEVEL 0 00480015 *3344 5037 00520016 *0681 THIS MODULE CONTAINS A FIX FOR APAR H140 00540017 * APAR 23283 R19 899600 23283 00550019 SPACE 5 00560015 * FUNCTION / OPERATION - 00640015 * 00720015 * THIS PHASE CONTAINS THE TEXT SKELETONS, MOST 00800015 * OF THE WORK AREAS AND SOME ROUTINES REQUIRED BY 00880015 * THE STRUCTURE PROCESSOR PHASES IEMJK, IEMJL AND 00960015 * IEMJM. 01040015 * THIS PHASE IS LOADED BY PHASE IEMJI AND ITS 01120015 * CONTENTS ARE SHIFTED TO THE 4K OF SCRATCH CORE BOUGHT 01200015 * BY IEMJI AND THEN 2EMJJ IS RELEASED. IN ORDER TO 01280015 * EFFECT THE MOVE OF TEXT, THE LENGTH OF THE PHASE 01360015 * IS ASSEMBLED INTO THE THIRD AND FOURTH BYTES OF THE 01440015 * PHASE. 01520015 EJECT 02600015 IEMJJ START 0 02800015 SPACE 5 03000015 USING *,8 03200015 SPACE 03240015 USING *+X'1000',13 03280015 SPACE 03320015 USING *+X'2000',10 03360015 SPACE 1 I4A 03370016 USING *+X'3000',12 I4A 03380016 SPACE 5 03400015 JJ DC C'JJ' 03600015 SPACE 2 03800015 DC AL2(ENDJJ-JJ) 04000015 SPACE 5 04060015 BC B,BASED 04120015 BC B,SPEC I4A 04140016 BC B,TRIAL 04160016 EJECT 04200015 * THE TEXT SKELETONS FOLLOW AT THIS POINT. 04400015 * CARE MUST BE TAKEN TO ENSURE THAT 'CONENT' 04600015 * STARTS ON AN ODD HALF WORD BOUNDARY, NO 04800015 * OTHER TEXT SKELETON HAS SUCH A REQUIREMENT. 05000015 SPACE 5 05200015 ORG JJ+X'12' I4A 05400016 SPACE 2 05600015 CONENT DC X'88001200009C1F80C09C1F800000' 05800015 CBCD DC X'00000000' 06000015 BNMC DC X'400B' 06200015 SKLTN1 DC X'C808000000000000' 06400015 ERMSG DC X'000E01' 06600015 DC C'COMPILER ERROR' 06800015 AI1 DC X'923FF80000100004' 07000015 AI2 EQU * 07200015 DC X'A0BFF83FF8100010' LA ACC,16(ACC) 07400015 AI9 EQU * 07600015 AI3 DC X'90000F0000100004' 07800015 DC X'A0800F000F100007' 08000015 DC X'78000F0003' 08200015 DC X'4A3FF8000F' 08400015 AI6 EQU * 08600015 AI7 DC X'A53FF80000' 08800015 AI8 EQU * 09000015 FN2 DC X'5B0000' 09200015 FN3 DC X'0000' 09400015 FN6 DC X'ED00000000' 09600015 FN7 DC X'0000EE00000000' 09800015 FN9 EQU * 10000015 FN8 DC X'D4000700000000' 10200015 AV14 DC X'1A0000' 10400015 AV2 DC X'A0BFF83FF8100000' 10600015 DC X'853FF800001A0000' 10800015 AV8 EQU * 11000015 AV10 DC X'4B000E000E' 11200015 DC X'8E000E0000100004' 11400015 DC X'4A3FF8000E' 11600015 AV11 EQU * 11800015 AV17 DC X'8A3FF80000100004' 12000015 DC X'A0BFF83FF8' 12200015 AV18 EQU * 12400015 AV20 DC X'88000F0000100004' 12600015 DC X'4A3FF8000F' 12800015 AV22 DC X'74000F0000' 13000015 DC X'4B000E000E' 13200015 DC X'8D000E0000100000' 13400015 DC X'4A0000000F' 13600015 AV23 EQU * 13800015 AV12 DC X'88000E0000100000' 14000015 DC X'4A000E3FF8' 14200015 DC X'A5000E0000100000' 14400015 AV13 EQU * 14600015 AR5 DC X'78000F0003' 14800015 AR1 DC X'A5000F0000' 15000015 DC X'D900073FFE3FFF' 15200015 AR2 EQU * 15400015 SPACE 15600015 SV31 DC X'D880053FFD' 15800015 SV32 DC X'883FFD0000100000' 16000015 SV33 DC X'C7780C0F3FFD3FFD00000000' 16200015 DC X'C1580C013FFD000000020004' 16400015 SV34 DC X'D980053FFD' 16600015 SV35 EQU * 16800015 SPACE 17000015 SV21 DC X'D880053FFD' 17200015 SV22 DC X'883FFD0000100000' 17400015 SV23 DC X'B180003FFD100000' 17600015 SV24 DC X'A0000F0000100000' 17800015 DC X'A5800F3FFD100008' 18000015 SV25 DC X'D980053FFD' 18200015 SV26 EQU * 18400015 SPACE 18600015 SV27 DC X'D9800D3FFB3FFD3FF93FFE3FFF' 18800015 SV28 EQU * 19000015 SPACE 19200015 SV41 DC X'D880053FFD' 19400015 SV42 DC X'883FFD0000100000' 19600015 SV43 DC X'4B000F000F' 19800015 DC X'A4800F3FFD100000' 20000015 DC X'A5800F3FFD100004' 20200015 DC X'A5800F3FFD100010' 20400015 SV44 DC X'D980053FFD' 20600015 SV45 EQU * 20800015 SPACE 21000015 INSRT1 DC X'88000F0000100000' 21200015 DC X'4A000F3FF8' 21400015 DC X'88800F000F100000' 21600015 INSRT2 DC X'95000F0000100000' 21800015 INSRT3 EQU * 22000015 AR4C DC X'A0000F0000100000' 22200015 AR4D DC X'A5000F0000100000' 22400015 AR4E EQU * 22600015 SPACE 22800015 CR5 DC X'0000ED' 23000015 SPACE 23200015 AD1 DC X'C10008' 23400015 AD2 DC X'00' 23600015 AD3 DC X'0000' 23800015 AD4 DC X'0000' 24000015 SB21 DC X'D800073FFF3FFE' 24200015 SB22 EQU * 24400015 SPACE 24600015 CD16 DC X'88000E0000' 24800015 DC X'78000E0003' 25000015 DC X'4A000E000F' 25200015 CD17 DC X'A5000E0000' 25400015 CD18 EQU * 25600015 CD91 DC X'88000E0000' 25800015 DC X'4A000E000F' 26000015 CD92 DC X'A5000E0000' 26200015 CD93 EQU * 26400015 SPACE 26600015 CD19 DC X'88000E0000' 26800015 DC X'4A000E000F' 27000015 DC X'483FFF000E' 27200015 DC X'78000E0003' 27400015 DC X'743FFF0005' 27600015 CD20 DC X'A5000E0000' 27800015 DC X'A43FFF0000' 28000015 CD21 EQU * 28200015 SPACE 28400015 CD19A DC X'88000E0000' 28600015 DC X'483FFF000E' 28800015 DC X'78000E001D' 29000015 DC X'743FFF0003' 29200015 DC X'46000E3FFF' 29400015 CD19B EQU * 29600015 CD26 DC X'D900073FFF3FFE' 29800015 CD27 EQU * 30000015 SPACE 30200015 CD30 DC X'A5000F0000' 30400015 CD31 EQU * 30600015 SPACE 30800015 CD32 DC X'48000E000F' 31000015 DC X'74000E0005' 31200015 DC X'78000F0003' 31400015 CD33 DC X'A5000F0000' 31600015 DC X'A4000E0000' 31800015 CD34 EQU * 32000015 SPACE 32200015 SB6 DC X'A0000F0000100000' 32400015 SB7 EQU * 32600015 SPACE 32800015 SB9 DC X'88000F0000' 33000015 DC X'48000E000F' 33200015 DC X'74000F0003' 33400015 DC X'78000E001D' 33600015 SB11 DC X'A0800E000E100000' H140 33700017 DC X'4A000F000E' H140 33800017 SB10 EQU * 34000015 SPACE 34200015 SB16 DC X'A0BFFE0000100000' 34400015 DC X'A0BFFF0000100004' 34600015 SB17 DC X'070000' 34800015 DC X'88000E0000BD00003FFE' 35000015 DC X'94000E0000BD00003FFE' 35200015 DC X'4A000F000E' 35400015 DC X'4B3FFE3FFF' 35600015 SB18 DC X'8140070000' 35800015 SB19 EQU * 36000015 SPACE 36200015 RD8 DC X'A0BFFD3FFD100007' 36400015 DC X'783FFD0003' 36600015 RD9 DC X'A53FFD0000100004' 36800015 DC X'A0BFFA3FFA100000' 37000015 DC X'783FFA0003' 37200015 RD10 DC X'A43FFA0000100004' 37400015 RD11 EQU * 37600015 SPACE 37800015 RD16 DC X'90000F0000100004' 38000015 RD12 DC X'A5000F0000100004' 38200015 DC X'B100000000100004' 38400015 RD13 EQU * 38600015 SPACE 38800015 SA1 DC X'C90014' 39000015 SA2 DC X'0000000000' 39200015 SA3 DC X'0000' 39400015 SA4 DC X'00000000' 39600015 SA5 DC X'00000000' 39800015 SA7 DC X'0000' 40000015 SA6 EQU * 40200015 SPACE 40400015 MP9 DC X'0D0000' 40600015 DC X'A00001' 40800015 MP6 DC X'0000A00002' 41000015 MP8 DC X'0000A00003' 41200015 MP7 DC X'000088000F' 41400015 MP5 DC X'00004F000E000F' 41600015 DC X'1D0000' 41800015 MP10 EQU * 42000015 SPACE 42200015 MP25 DC X'D800093FFC3FFD3FFF' 42400015 SDVSIZ DC X'A0BFFF000010' 42600015 N1 DC X'0000A03FFD' 42800015 DREF20 DC X'0000100004' 43000015 DC X'A0800F000010000807' 43200015 EQU51 DC X'000090BFFC3FFD93BFFC3FFD100002' 43400015 DC X'A0BFFC3FFC1000014C000E3FFC' 43600015 DC X'A0BFFD3FFD100004' 43680001 DC X'443FFF0000' BCTR * EXPANSION 43760001 DC X'523FFF3FFF' LTR * FOR 43840001 DC X'814007' BC * BCTA' 43920001 EQU52 DC X'00004A0000000F' 44000015 DC X'D900093FFC3FFD3FFF' 44200015 MP26 EQU * 44400015 SPACE 44600015 SV7 DC X'D8800D3FFB3FF93FFF3FFD3FFE' 44800015 SV8 EQU * 45000015 SPACE 45200015 BITCVN DC X'883FFF' L OWRK1,DV 45400015 DREF11 DC X'0000100000483FFE3FFF' LR OWRK2,OWRK1 45600015 DC X'743FFF0003783FFE001D' SLL OWRK1,3 SRL OWRK2,29 45800015 DC X'463FFF3FFE' 46000015 DC X'A53FFF' ST OWRK1,DV 46200015 DREF17 DC X'0000100000' 46400015 SV9 EQU * 46600015 SPACE 46800015 DC X'483FF93FF8' SAVE SDV POINTER 47000015 DC X'A03FFB' 47200015 TREF1 DC X'0000' SLOT FOR TREF 47400015 DC X'C1480A' MVC 0(4*N-1,OSTACK),DV+4*N+4 47600015 L1 DC X'003FFB' SLOT FOR 4*N-1 47800015 DREF12 DC X'0000' SLOT FOR DREF1 48000015 BNDPT DC X'000007' SLOT FOR 4*N+4 48200015 SPACE 48400015 INSET1 EQU BNDPT+2 INSERTION MADE HERE FOR BASED 48600015 SPACE 48800015 EQU11 DC X'0000' SLOT FOR EQU1 49000015 DC X'4B000F000F4B3FFD3FFD' SR OMUTO,OMULTO CLEAR INDEX 49200015 DC X'A0BFFF000010' SR OACC,OACC CLEAR ACC 49400015 DCNT1 DC X'000007' SLOT FOR N SET DIM CNT 49600015 EQU21 DC X'000088000E' 49800015 DREF13 DC X'0000BD0004000F' SLOT FOR DREF1 LOAD MULTPR 50000015 DC X'94800E3FFBBD0002000F' MH OMULTO,2(OMULTO,OSTACK) 50200015 DC X'4A3FFD000E' AR OACC,OMULTE CALC ADDRESS 50400015 DC X'A0800F000F100004' LA OMULTO,4(OMULTO) BUMP INDEX 50600015 DC X'443FFF0000' BCTR * EXPANSION 50700001 DC X'523FFF3FFF' LTR * FOR 50800001 DC X'814007' BC * BCTA' 50900001 EQU22 DC X'0000' SLOT FOR EQU2 51000015 DC X'8A3FFD' A OACC,DV ADD ORIGIN TO ACC 51200015 DREF14 DC X'0000100000' SLOT FOR DREF1 51400015 SV10 EQU * 51600015 SPACE 51800015 DC X'A5BFFD3FF8' ST OACC,0(SDVPT) 52000015 DC X'4B000F000F' SR OMULTO,OMULTO CLEAR INDEX 52200015 DC X'95800F3FF8100006' STH 14,6(SDVPT) 52400015 DC X'C1580C013FF8' MOVE IN STRING LENGTH 52600015 DREF15 DC X'00000004' SLOT FOR DREF1 SET STRING LENGTH 52800015 SLPT DC X'0000' SLOT FOR N*8+4 53000015 DC X'A0BFF83FF8100008' BUMP SDV POINTER 53200015 SV16 DC X'A0800F0000100000' 53400015 DC X'A0BFFF000010' LA OWRK1,N(0) SET COUNT 53600015 DCNT2 DC X'000007' SLOT FOR N 53800015 EQU31 DC X'0000' SLOT FOR BRANCH IN POINT 54000015 DC X'A0800E0000100001' LA OMULTE,1(0) BUMP SUBSCR 54200015 DC X'92800E3FFBBD0002000F' AH OMULTE,2(OMULTO,OSTACK) 54400015 DC X'91800E3FFB11000F' CH OMULTE,0(OMULTO,OSTACK) 54600015 DC X'814002' BC BH,EQU4 HBOUND EXCEEDED 54800015 EQU41 DC X'0000' SLOT FOR EQU4 55000015 DC X'95800E3FFBBD0002000F' STH OMULTE,2(OMULTO,OSTACK) 55200015 DC X'81400F' BC B,EQU1 GET NEXT POINTER 55400015 EQU12 DC X'000007' SLOT FOR EQU1 55600015 EQU42 DC X'0000' SLOT FOR EQU4 55800015 DC X'90000E' LH OMULTE,DV+6(OMULTO) 56000015 DREF16 DC X'0000BD0006000F' SLOT FOR DREF RESET SUBSCRIPT 56200015 DC X'95800E3FFBBD0002000F' STH OMULTE,2(OMULTO,OSTACK) 56400015 DC X'A0800E0000100004' 56600015 DC X'4B000F000E' 56800015 DC X'443FFF0000' BCTR * EXPANSION 56900001 DC X'523FFF3FFF' LTR * FOR 57000001 DC X'814007' BC * BCTA' 57100001 EQU32 DC X'0000' 57200015 SV12 EQU * 57400015 SPACE 57600015 SV13 DC X'48000F3FFD' 57800015 DC X'74000F001D' 58000015 DC X'783FFD0003' 58200015 DC X'463FFD000F' 58400015 SV14 EQU * 58600015 SPACE 58800015 IP1 DC X'A53FF90000100000' ST SDVPT,DR1+DVOFF 59000015 IP2 DC X'A0BFFF0000100004' LA R1,4(0) 59200015 DC X'A0800F0000100008' LA 15,8 59400015 IP3 DC X'A0BFFE0000100000' LA R2,4*N 59600015 IP4 DC X'070000' LABEL 59800015 IP10 DC X'A5000F0000BD00003FFE' ST 15,DR1+DVOFF(R3) 60000015 DC X'40000E000F' LCR 14,15 60200015 IP5 DC X'94000E0000BD00003FFE' MH 14,DR1+DVOFF+4*N(R3) 60400015 IP6 DC X'8A000E0000100000' A 14,DR1+DVOFF 60600015 IP7 DC X'A5000E0000100000' ST 14,DR1+DVOFF 60800015 IP8 DC X'90000E0000BD00003FFE' LH 14,DR1+DVOFF+4*N+2(R3) 61000015 IP11 DC X'93000E0000BD00003FFE' SH 14,DR1+DVOFF+4*N+2(R3) 61200015 DC X'A0800E000E100001' LA 14,1(14) 61400015 DC X'4C000E000E' MR 14,14 61600015 DC X'4B3FFE3FFF' SR R3,R1 61800015 IP9 DC X'8140070000' BC BNZ,CL 62000015 DC X'D9800D3FFB3FFD3FF93FFE3FFF' 62200015 IP12 EQU * 62400015 SPACE 62600015 SD33 DC X'88000F0000100004' 62800015 SD15 DC X'A0BFF8000F100000' 63000015 DC X'A0800E0000100004' 63200015 DC X'40000E000E' 63400015 DC X'453FF8000E' 63600015 SD18 DC X'74000F0000' 63800015 SD16 DC X'4B000E000E8D000E0000100000' 64000015 SD19 DC X'A08000000F113FF8' 64200015 SD34 EQU * 64400015 SPACE 64600015 SD35 DC X'88000F0000100004' 64800015 SD21 DC X'A08000000F100000' 65000015 SD36 EQU * 65200015 SPACE 65400015 SD37 DC X'4B000F000F' 65600015 DC X'8E000F0000100004' 65800015 DC X'8A000F0000100004' 66000015 DC X'A0800F000F' 66200015 SD38 EQU * 66400015 SPACE 66600015 SD40 DC X'A0BFF8000F100000' 66800015 DC X'853FF80000' 67000015 DC X'4800003FF8' 67200015 SD41 EQU * 67400015 SPACE 67600015 SD42 DC X'A08000000F100000' 67800015 SD43 EQU * 68000015 SPACE 68010015 SD37A DC X'88000F0000100004' 68020015 SD38A EQU * 68030015 SPACE 68040015 FAST1 DC X'A53FF80000100000' 68050015 FAST1A EQU * 68060015 SPACE 68070015 FAST2 DC X'8A3FF80000100004' 68080015 FAST2A EQU * 68090015 SPACE 68100015 RD16A DC X'90000F0000100004' 68110015 DC X'A0800F000F100010' 68120015 DC X'4A3FF8000F' 68130015 RD12A DC X'A5000F0000100004' 68140015 DC X'B100400000100004' 68150015 RD13A EQU * 68160015 SPACE 1 I4A 68163016 P1 DC X'4A3FFD3FF8' I4A 68166016 P2 EQU * I4A 68169016 SPACE 1 I4A 68172016 MP25A DC X'90000F0000100000' I4A 68175016 DC X'93000F0000100000' I4A 68178016 DC X'A0800F000F100001' I4A 68181016 DC X'71000F0003' I4A 68184016 DC X'4A0000000F' I4A 68187016 MP26A EQU * I4A 68190016 EJECT 68200015 * WORK AREAS FOLLOW AT THIS POINT. THE FIRST 68300015 * GROUP CONTAINS ITEMS WHICH ARE COMMON TO IEMJI, 68400015 * IEMJK, IEMJL AND IEMJM. THE SECOND GROUP CONTAINS 68500015 * ITEMS WHICH ARE PRIVATE TO IEMJM 68800001 SPACE 5 69200015 ORG JJ+X'638' 69400001 SPACE 2 69600015 DC 30F'0' REGISTER SAVE AREA 69800015 STCKPT DC F'0' 70000015 FRSTBD DC H'0' FIRST BOUND REQ 70100015 OACC DC X'3FFD' SYMBOLIC ACCUMULATOR REGISTER 70200015 OWRK1 DC X'3FFF' SYMBOLIC WORK REGISTER 70400015 OWRK2 DC X'3FFE' SYMBOLIC WORK REGISTER 70600015 OOFF DC X'3FFA' SYMBOLIC OFFSET REGISTER 70800015 OSTACK DC X'3FFB' SYMBOLIC STACK REGISTER 71000015 OLNGTH DC X'3FFC' SYMBOLIC LENGTH REGISTER 71200015 AREF DS H REFERENCE OF PROCESSED ITEM 71400015 BREF DS H REFERENCE OF CURRENT ENTRY TYPE1 71600015 MREF DS H 71800015 RREF DS H 72000015 VREF DS H 72200015 TREF DS H 72400015 OFFSET DS H BIT OFFSET TO START OF STRUCTURE 72600015 * FROM MAXIMUM ALIGNMENT BOUNDARY 72800015 BOUND DC H'0' CURRENT ALIGNMENT 73000015 MAXBND DC H'0' MAXIMUM ALIGNMENT 73200015 DIM1 DC H'0' CURRENT STRUCTURE DIMENSIONALITY 73400015 N DC H'0' TOTAL ELEMENT DIMENSIONALITY 73600015 DREF1 DS H DICTIONARY REFERENCE+1 73800015 CLASS DS C STORAGE CLASS SWITCH 74000015 WRKSW DC X'00' WORKSPACE NEEDED SWITCH 74200015 OBJSW DC X'00' OBJECT CODE GENERATED SWITCH 74400015 DIMSW DC X'00' PROCESS ARRAY SWITCH 74600015 PS DS 48C OBJECT CODE BUFFER FOR CMPILE 74800015 WRKSW1 DS C WORKSPACE NEEDED SWITCH 75000015 MAJSW DS C MAJOR STRUCTURE SWITCH 75200015 LENGTH DS F ELEMENT LENGTH 75400015 DIMREF DS H DIMENSION TABLE REFERENCE 75600015 NREF DS H NEXT STRUCTURE MEMBER REFERENCE 75800015 DEFSW DS C DEFINED SWITCH 76000015 SIZSW DS C SIZE SWITCH 76200015 DIM DC H'0' CONTAINING STRUCTURE DIMENSIONS 76400015 DREF DS H REFERENCE OF CURRENT ELEMENT 76600015 DVOFF DS H 76800015 BITSW DC X'00' BIT STRING SWITCH 77000015 ADJSW DC X'00' ADJUSTABLE ITME SWITCH 77200015 VARYSW DC X'00' VARYING STRING ARRAY SWITCH 77400015 MPL1 DC X'0000' LIB ROUTINE FOR PL/1 MAPPING 77600015 MCOBOL DC X'0000' LIB ROUTINE FOR COBOL MAPPING 77800015 QUFLAG DC X'00' SET ON TO SHOW IEMQU IS NEEDED I4A 77900016 DUMMY DC X'00' DUMMY TO FILL UP SPACE I4A 78000016 COBLSW DC X'00' SET ON FOR COBOL STRUCTURES 78200015 CNTGSW DC X'00' SET ON FOR CONTIG STRUCTURES 78400015 AREASW DC X'00' SET ON FOR AREAS 78600015 BASESW DC X'00' SET ON FOR BASED ITEMS 78800015 ADJ1SW DC X'00' SET ON IF CODE NEEDED FOR BASED 79000015 V1SW DC X'00' 79200015 SUPRDV DC X'00' I4A 79300016 SPACE 10 79400015 SPACE 5 88800015 SPACE 5 88840015 ORG JJ+X'730' 88880001 SPACE 2 88920015 SDSLOT DS F 88960015 SVEBIT DC F'7' CLEAR BYTE PATTERN OF OFFSET 89000015 CM8 DC F'-8' 89040015 CM32 DC F'-32' 89080015 SVZ DC F'0' 89120015 GTSLOT DS F 89160015 SBSLOT DS F 89200015 CDSLOT DS F 89240015 RDSLOT DS F 89280015 SAVERD DS F 89320015 SPACE 89360015 POSOP DS H 89400015 BASREF DS H 89440015 AC4096 DC H'4096' 89480015 DIMZ DS H 89520015 BTREF DS H 89560015 DFREF DS H 89600015 AC1 DC H'1' 89640015 ACM1 DC H'-1' 89680015 C7 DC H'7' 89720015 C2 DC H'2' 89760015 C12 DC H'12' 89800015 REG15 DC H'15' 89840015 SPACE 89880015 MESS DC X'00044010' 89920001 MESS2 DC X'00044110' 23283 89960019 SPACE 90000015 ABSW DC X'00' 90040015 CSW DC X'00' 90080015 NEWFLG DC X'00' 90120015 CNSIDR DC X'00' 90160015 SPACE 90164016 CD91A DC X'88000E0000' SKELETON TO RELOCATE 5037 90168017 DC X'483FFF000E' DOPE VECTOR FOR BIT 5037 90172017 DC X'78000E0003' STRINGS IN NON ADJ 5037 90176017 DC X'4A000E000F' DEFINED WHEN BASE IS NOT 5037 90180017 CD91B DC X'A5000E0000' BIT STRING 5037 90184017 DC X'743FFF0005' 90188017 CD91C DC X'A43FFF0000' 90192017 CD91D EQU * 90196017 SPACE 5 90196501 * CONSTANTS USED BY THIS PHASE 90197001 SPACE 2 90197501 C1 DC H'1' 90198001 OMULTO DC H'15' 90198501 OMULTE DC H'14' 90199001 EJECT 90200015 * 90207016 * 90214016 * 90221016 * FUNCTIONS 90228016 * 90235016 * THIS ROUTINE SETS UP THE OFFSET1 AND OFFSET2 90242016 * SLOTS FOR BASED ITEMS. THIS IS POSSIBLE BECAUSE 90249016 * THE SUBSET IMPLEMENTED ALLOWS FOR THE CALCULATION 90256016 * OF ALL MULTIPLIERS AND OFFSETS. 90263016 * 90270016 * (1) THE OFFSET1 SLOT IS SET TO ZERO IN ALL SCALARS 90277016 * THAT ARE NOT MEMBERS OF STRUCTURES. 90284016 * 90291016 * (2) THE OFFSET1 SLOT AND \HE FIRST BYTE OF THE 90298016 * OFFSET2 SLOT OF ARRAYS WHICH ARE NOT MEMBERS OF 90305016 * STRUCTURES ARE SET TO THE BYTE AND BIT OFFSET OF 90312016 * THE VIRTUAL ORIGIN FROM THE START OF THE ARRAY. 90319016 * 90326016 * (3) FOR ITEMS IN STRUCTURES THE FIRST AND SECOND OFFSET 90333016 * SLOTS ARE SET RELATIVE TO THE FIRST BYTE OF THE STRUCTURE. 90340016 * 90347016 * 90354016 * 90361016 * ENTRY POINT - BASED 90368016 * 90375016 * 90382016 * 90389016 * EXTERNAL ROUTINES 90396016 * 90403016 * (1) ZDRFAB IN COMPILER CONTROL 90410016 * 90417016 * 90424016 * 90431016 * EXIT - NORMAL - CS2 90438016 * 90445016 * 90452016 * 90459016 * EXITS - ERROR - NONE 90466016 SPACE 10 90473016 BASED MVC AREF(2),3(RD) SET UP AREF 90480016 SPACE 90487016 TM 0(RD),X'30' 90494016 BC BNZ,BASED1 BRANCH IF DIM OR STR 90501016 SPACE 90508016 XC 5(3,RD),5(RD) SET OFFSET1 SLOT TO ZERO 90515016 OI FDOT3B(RD),X'02' SET GOOD VALUE BIT 90522016 SPACE 90529016 TM 0(RD),X'0F' 90536016 BC BNO,CS2 BRANCH IF NOT DATA 90543016 SPACE 90550016 TM FDVARB(RD),X'80' 90557016 BC BZ,CS2 BRANCH IF NO OFFSET2 SLOT 90564016 SPACE 90571016 TM FDDATA(RD),X'84' 90578016 BC BNZ,CS2 BRANCH IF NOT BIT STRING 90585016 SPACE 90592016 MVI 21(RD),X'00' OFFSET2 SET TO ZERO 90599016 OI FDOT3B(RD),X'01' SET GOOD VALUE BIT 90606016 BC B,CS2 90613016 SPACE 90620016 BASED1 TM 0(RD),X'20' 90627016 BC BO,BASED8 BRANCH IF STRUCTURE 90634016 SPACE 90641016 LA RR,CS2 90648016 BASED2 ST RR,0(RS) SAVE RETURN REGISTER 90655016 SPACE 90662016 LR RC,RD 90669016 TM 0(RD),X'0F' 90676016 BC BNO,*+8 BRANCH IF NOT DATA 90683016 LA RC,6(RC) 90690016 LR RE,RC SAVE RC 90697016 SPACE 90704016 TM FDVARB(RD),X'80' 90711016 BC BZ,*+8 BRANCH IF NO OFFSET2 90718016 LA RC,4(RC) 90725016 SPACE 90732016 MVC PAR1+2(2),16(RC) DIMTABLE REF 90739016 BALR RR,RL 90746016 L RC,PAR1 90753016 SPACE 90760016 MVC 5(3,RD),9(RC) BYTE OFFSET 90767016 OI FDOT3B(RD),X'02' 90774016 SPACE 90781016 TM FDVARB(RD),X'80' 90788016 BC BZ,BASED3 BRANCH IF NO OFFSET2 90795016 SPACE 90802016 MVC 15(1,RE),8(RC) BIT OFFSET 90809016 OI FDOT3B(RD),X'01' 90816016 SPACE 90823016 BASED3 L RR,0(RS) 90830016 BCR B,RR RETURN 90837016 SPACE 90844016 BASED8 LR RC,RD 90851016 TM 0(RD),X'10' 90858016 BC BZ,*+8 BRANCH IF UNDIMENSIONED 90865016 LA RC,3(RC) 90872016 SR RR,RR 90879016 IC RR,FSSSTI+2(RC) OFFSET FROM MAJOR BOUNDARY 90886016 SRL RR,3 CONVERT TO BYTES 90893016 ST RR,4(RS) 90900016 SPACE 90907016 BASED4 TM 0(RD),X'0F' 90914016 BC BO,BASED5 BRANCH IF DATA 90921016 TM 0(RD),X'0E' 90928016 BC BNO,BASED5 NOT STRUCTURE 90935016 SPACE 90942016 BASED6 LR RC,RD 90949016 BASED7 TM FDVARB(RD),X'80' 90956016 BC BNO,*+8 BRANCH IF NOT OFFSET 2 90963016 LA RC,4(RC) 90970016 SPACE 90977016 TM FDVARB(RD),X'40' 90984016 BC BNO,*+8 NOT DIMENSIONED 90991016 LA RC,3(RC) 90998016 SPACE 91005016 MVC PAR1+2(2),19(RC) 91012016 BALR RR,RL NEXT MEMBER OF STRUCTURE 91019016 L RD,PAR1 91026016 BC B,BASED4 91033016 SPACE 91040016 BASED5 TM 0(RD),X'10' 91047016 BC BZ,*+8 BRANCH IF NOT DIMENSIONED 91054016 SPACE 91061016 BAL RR,BASED2 91068016 SPACE 91075016 L RR,4(RD) 91082016 LA RR,0(RR) ADJUST OFFSET1 VALUE 91089016 S RR,4(RS) 91096016 SPACE 91103016 ST RR,8(RS) 91110016 MVC 5(3,RD),9(RS) 91117016 TM 0(RD),X'10' 91124016 BC BZ,*+10 BRANCH IF NOT DIMENSIONED 91131016 MVC 9(3,RC),9(RS) ALTER VO SLOT 91138016 SPACE 91145016 TM FDOT1B(RD),X'08' 91152016 BC BO,CS2 BRANCH IF END OF STRUCTURE 91159016 SPACE 91166016 TM 0(RD),X'0F' 91173016 BC BNO,BASED6 BRANCH IF NOT DATA 91180016 LA RC,6(RD) 91187016 BC B,BASED7 91194016 EJECT 91201016 * I4A 91208016 * I4A 91215016 * I4A 91222016 * FUNCTIONS I4A 91229016 * I4A 91236016 * THIS ROUTINE GENERATES THE CODE SE8UENCES I4A 91243016 * FOR THE INITIALIS1TION OF SINGLE DIMENSIONED I4A 91250016 * ARRAYS OF AREAS, TASKS AND EVENTS, AND THE SETTING I4A 91257016 * UP OF STRING DOPE VECTORS FOR SINGLE DIMENSIONED I4A 91264016 * ARRAYS OF V1RYING STRINGS. ALL SINGLE DIMENSIONED I4A 91271016 * 1RRAYS ARE SUSCEPTIBLE TO SPECIAL C1SE TREATMENT I4A 91278016 * REGARDLESS OF WHETHER THEIR BOUNDS OR MULTIPLIERS I4A 91285016 * ARE CONSTANT OR NOT. I4A 91292016 * I4A 91299016 * I4A 91306016 * I4A 91313016 * ENTRY POINT - SPEC I4A 91320016 * I4A 91327016 * I4A 91334016 * I4A 91341016 * EXTERNAL ROUTINES I4A 91348016 * I4A 91355016 * (1) ZDRFAB IN COMPILER CONTROL I4A 91362016 * I4A 91369016 * (2) CMPIL1 IN IEMJL I4A 91376016 * I4A 91383016 * (3) LOADCN IN IEMJL I4A 91390016 * I4A 91397016 * (4) 1DDCN IN IEMJL I4A 91404016 * I4A 91411016 * I4A 91418016 * I4A 91425016 * EXITS - NORMAL - TO CALLING ROUTINE I4A 91432016 * I4A 91439016 * I4A 91446016 * I4A 91453016 * EXITS - ERROR - NONE I4A 91460016 * I4A 91467016 * I4A 91474016 * I4A 91481016 * N.B. I4A 91488016 * I4A 91495016 * PARTS OF THIS ROUTINE 1RE USED TO GENERATE I4A 91502016 * CODE FOR THOSE MULTI-DIMENSIONAL 1RRAYS WHICH I4A 91509016 * CAN BE TREATED AS SPECIAL C1SES. I4A 91516016 SPACE 10 I4A 91523016 SPEC MVC PAR1+2(2),DIMREF I4A 91530016 BALR RR,RL DECODE DIMTAB REFERENCE I4A 91537016 L RC,PAR1 I4A 91544016 SPACE 1 91551016 LA RE,SKL1 I4A 91558016 LA RF,SKL1A-SKL1 COMPILE USSL FOR 3FFE AND 3FFF I4A 91565016 BAL RR,CMPIL1 I4A 91572016 SPACE 1 I4A 91579016 TM 0(RD),X'0F' I4A 91586016 BC BNO,SPEC21 BRANCH IF NOT DATA I4A 91593016 SPACE 1 I4A 91600016 TM FDDATA(RD),X'02' I4A 91607016 BC BO,SPEC21 BRANCH IF AREA I4A 91614016 SPACE 1 I4A 91621016 LA RE,SKL18 I4A 91628016 LA RF,SKL18A-SKL18 I4A 91635016 BAL RR,CMPIL1 I4A 91642016 SPACE 1 I4A 91649016 SPEC21 MVC SKL2+3(2),DREF1 I4A 91656016 MVC SKL3+3(2),DREF1 I4A 91663016 SPACE 1 I4A 91670016 TM 16(RC),X'FF' I4A 91677016 BC BNZ,SPEC1 BRANCH IF ADJUSTABLE HBOUND I4A 91684016 SPACE 1 I4A 91691016 TM 12(RC),X'FF' I4A 91698016 BC BNZ,SPEC2 BRANCH IF ADJUSTABLE LBPUND I4A 91705016 SPACE 1 I4A 91712016 LH RF,18(RC) I4A 91719016 SH RF,14(RC) I4A 91726016 LA RF,1(RF) HBOUND - LBOUND + 1 I4A 91733016 LA RE,SKL1+3 POINT TO NAME OF 3FFE I4A 91740016 BAL RR,LOADCN COMPILE L 3FFE,NO OF ELEMS I4A 91747016 BC B,SPEC3 I4A 91754016 SPACE 1 I4A 91761016 SPEC1 CLI BASESW,ON I4A 91768016 BC BE,SPEC4 BRANCH IF BASED I4A 91775016 SPACE 1 I4A 91782016 LA RE,SKL2 I4A 91789016 LA RF,SKL3-SKL2 COMPILE LH 3FFE,HBOUND I4A 91796016 BAL RR,CMPIL1 I4A 91803016 BC B,SPEC5 I4A 91810016 SPACE 1 I4A 91817016 SPEC4 LA RE,SKL5 REFER VARIABLE SKELETON 91827001 LA RF,SKL5A-SKL5 91837001 BAL RB,SPEC22 OUTPUT 91847001 SPACE 1 I4A 91859016 SPEC5 LA RE,SKL3 I4A 91866016 LA RF,SKL2A-SKL3 I4A 91873016 SPACE 1 I4A 91880016 TM 12(RC),X'FF' I4A 91887016 BC BNZ,SPEC6 BRANCH IF ADJUSTABLE LOW BOUND I4A 91894016 SPACE 1 I4A 91901016 CLC 14(2,RC),C1 I4A 91908016 BC BNE,SPEC6 BRANCH IF LBOUND NOT EQUAL TO 1 I4A 91915016 BC B,SPEC3 I4A 91922016 SPACE 1 I4A 91929016 SPEC2 LA RE,SKL2 I4A 91936016 LA RF,SKL2A-SKL2 I4A 91943016 SPEC6 BAL RR,CMPIL1 I4A 91950016 SPACE 1 I4A 91957016 SPEC3 TM 0(RD),X'0F' I4A 91964016 BC BNO,SPEC7 BRANCH IF NOT DATA I4A 91971016 SPACE 1 I4A 91978016 TM FDDATA(RD),X'04' I4A 91985016 BC BO,SPEC7 BRANCH IF NOT BIT STRING I4A 91992016 SPACE 1 I4A 91999016 MVC SKL6+3(2),DREF1 I4A 92006016 LA RE,SKL6 I4A 92013016 LA RF,SKL6A-SKL6 SET VO IN BITS IN REG 14 I4A 92020016 BC B,SPEC8 I4A 92034016 SPACE 1 I4A 92041016 SPEC7 MVC SKL7+3(2),DREF1 I4A 92048016 LA RF,SKL8-SKL7 I4A 92055016 CLI BASESW,ON I4A 92062016 BC BNE,SPEC9 BRANCH IF NOT BASED I4A 92069016 LA RF,SKL7A-SKL7 I4A 92076016 SPEC9 LA RE,SKL7 SET VO IN REG 14 I4A 92083016 * 92090001 SPEC8 BAL RR,CMPIL1 92097001 TM 12(RC),X'FF' 92104001 BC BNZ,SPEC10 BRANCH IF LOW BOUND ADJ I4A 92111016 SPACE 1 I4A 92118016 TM 20(RC),X'F0' I4A 92125016 BC BNZ,SPEC11 BRANCH IF MULT NOT KNOWN I4A 92132016 SPACE 1 I4A 92139016 L RF,20(RC) MULT I4A 92146016 MH RF,14(RC) LBOUND I4A 92153016 * 92157001 SPEC81 LA RE,OMULTE R14 POINTS TO FIRST ELEMENT 92161001 BAL RR,ADDCN I4A 92167016 BC B,SPEC12 I4A 92174016 SPACE 1 I4A 92181016 SPEC10 MVC SKL9+3(2),DREF1 I4A 92188016 MVC SKL9+11(2),DREF1 I4A 92195016 LA RE,SKL9 I4A 92202016 LA RF,SKL9A-SKL9 I4A 92209016 BC B,SPEC121 92219001 SPACE 1 I4A 92230016 SPEC11 CLC 14(2,RC),C1 I4A 92237016 BC BNE,SPEC10 LOW BOUND IS NOT 1 I4A 92244016 SPACE 1 I4A 92251016 MVC SKL10+3(2),DREF1 I4A 92258016 LA RE,SKL10 I4A 92265016 LA RF,SKL10A-SKL10 COMPILE A 14,DV+4 I4A 92272016 SPEC121 BAL RR,CMPIL1 92279001 SPACE 1 I4A 92286016 SPEC12 TM 0(RD),X'0F' I4A 92293016 BC BNO,SPEC13 BRANCH IF TASK OR EVENT I4A 92300016 SPACE 1 I4A 92307016 LH RB,N 92314016 SLL RB,3 92321016 AR RB,R4 92328016 ST RB,4(RS) 92335016 MVC SKL11+6(2),6(RS) 92342016 MVC SKL12+6(2),6(RS) 92349016 MVC SKL13B+6(2),6(RS) 92356016 SPACE 1 92363016 TM FDDATA(RD),X'02' I4A 92370016 BC BZ,SPEC14 BRANCH IF NOT AREA I4A 92377016 SPACE 1 I4A 92384016 MVC SKL11+3(2),DREF1 *** AREAS I4A 92391016 MVC SKL11+9(2),ZEQMAX I4A 92398016 LA RE,SKL11 I4A 92405016 LA RF,SKL11A-SKL11 I4A 92412016 BC B,SPEC15 I4A 92426016 SPACE 1 I4A 92433016 SPEC14 TM FDDATA(RD),X'04' I4A 92440016 BC BZ,SPEC16 BRANCH IF VARYING BITS I4A 92447016 SPACE 1 I4A 92454016 MVC SKL12+3(2),DREF1 *** VARYING CHARACTERS I4A 92461016 MVC SKL12+14(2),ZEQMAX I4A 92468016 LA RE,SKL12 I4A 92475016 LA RF,SKL12A-SKL12 I4A 92482016 BC B,SPEC15 I4A 92496016 SPACE 1 I4A 92503016 SPEC16 MVC SKL13B+3(2),DREF1 *** VARYING BITS I4A 92510016 MVC SKL13C+3(2),DREF1 I4A 92517016 MVC SKL13+6(2),ZEQMAX I4A 92524016 LH RB,N I4A 92531016 AR RB,RB I4A 92538016 AR RB,RB I4A 92545016 STC RB,SKL13C+7 OFFSET OF LAST MULT I4A 92552016 LA RE,SKL13 I4A 92559016 LA RF,SKL13A-SKL13 I4A 92566016 BAL RR,CMPIL1 I4A 92573016 SPACE 92574016 CLC N(2),C1 92575016 BC BNE,IMPS11 92576016 BC B,SPEC17 I4A 92580016 SPACE 1 I4A 92587016 SPEC13 TM 0(RD),X'0D' I4A 92594016 BC BNO,SPEC18 BRANCH IF TASK I4A 92601016 SPACE 1 I4A 92608016 MVC SKL14+6(2),ZEQMAX *** EVENT I4A 92615016 LA RE,SKL14 I4A 92622016 LA RF,SKL14A-SKL14 I4A 92629016 BC B,SPEC15 I4A 92643016 SPACE 1 I4A 92650016 SPEC18 SR RE,RE *** TASK I4A 92657016 IC RE,2(RD) I4A 92664016 AR RE,RD I4A 92671016 SR RE,R4 POINT TO SYMTAB I4A 92678016 SPACE 1 I4A 92685016 MVC SKL15+3(2),0(RE) I4A 92692016 MVC SKL15+9(2),ZEQMAX I4A 92699016 LA RE,SKL15 I4A 92706016 LA RF,SKL15A-SKL15 I4A 92713016 SPEC15 BAL RR,CMPIL1 92722001 CLC N(2),C1 92731001 BC BNE,IMPS10 I4A 92741016 SPACE 1 I4A 92748016 TM 20(RC),X'F0' I4A 92755016 BC BNZ,SPEC19 BRANCH IF ADJ MULT I4A 92762016 SPACE 1 I4A 92769016 LA RE,OMULTE I4A 92776016 L RF,20(RC) I4A 92783016 BAL RR,ADDCN I4A 92790016 BC B,SPEC17 I4A 92797016 SPACE 1 I4A 92804016 SPEC19 MVC SKL16+3(2),DREF1 I4A 92811016 LA RE,SKL16 I4A 92818016 LA RF,SKL16A-SKL16 I4A 92825016 BAL RR,CMPIL1 I4A 92832016 SPACE 1 I4A 92839016 SPEC17 MVC SKL17+13(2),ZEQMAX 92846001 BAL RR,BUMPEQ RESET LABEL VALUE I4A 92853016 LA RE,SKL17 I4A 92860016 LA RF,SKL17A-SKL17 I4A 92867016 SPACE 1 I4A 92874016 TM 0(RD),X'0F' I4A 92881016 BC BNO,SPEC20 BRANCH IF NOT DATA I4A 92888016 SPACE 1 I4A 92895016 TM FDDATA(RD),X'02' I4A 92902016 BC BO,SPEC20 BRANCH IF AREAS I4A 92909016 SPACE 1 I4A 92916016 LA RF,SKL17B-SKL17 I4A 92923016 BAL RR,CMPIL1 I4A 92930016 SPACE 1 I4A 92937016 MVC SKL19B+3(2),DREF1 I4A 92944016 MVC SKL19C+3(2),DREF1 I4A 92951016 MVC SKL19D+3(2),DREF1 I4A 92958016 LA RE,SKL19 I4A 92965016 LA RF,SKL19A-SKL19 I4A 92972016 SPACE 1 I4A 92979016 SPEC20 BAL RR,CMPIL1 I4A 92986016 SR RS,R4 I4A 92993016 L RR,0(RS) I4A 93000016 BCR B,RR I4A 93007016 * 93007301 * 93007601 * REFER VARIABLE CODE 93007901 * RE = ADDRESS OF SKELETON, RF = LENGTH, RB = RETURN ADDRESS 93008201 * THE SKELETON WILL BE MODIFIED ACCORDING TO WHETHER THE REFER 93008501 * VARIABLE IS HALFWORD OR FULLWORD. 93008801 * 93009101 SPEC22 MVC 3(2,RE),18(RC) MOVE REFER VARIABLE TO SKELETON 93009401 OI 4(RE),X'01' SET O DOPE VECTOR BIT 93009701 MVI LDOFF(RE),X'88' SET TEMPORARY LOAD 93010001 MVC PAR1+2(2),18(RC) 93010301 BALR RR,RL 93010601 L RA,PAR1 ABS ADDRESS OF REFER VARIABLE 93010901 LR RR,RB SET RETURN ADDRESS 93011201 TM FDDATA+1(RA),X'F0' TEST PRECISION 93011501 BC BNZ,CMPIL1 OUTPUT CODE 93011801 MVI LDOFF(RE),X'90' SET LOAD HALFWORD IN SKELETON 93012101 BC B,CMPIL1 93012401 * 93012701 SPACE 5 I4A 93014016 * THE TEXT SKELETONS FOR SPEC FLOOW. I4A 93021016 SPACE 5 I4A 93028016 SKL1 DC X'D880093FFE3FF93FFF' 93035016 SKL1A EQU * I4A 93042016 SPACE 1 I4A 93049016 SKL2 DC X'903FFE0000100008' I4A 93056016 SKL3 DC X'933FFE000010000A' I4A 93063016 SKL4 DC X'A0BFFE3FFE100001' I4A 93070016 SKL2A EQU * I4A 93077016 SPACE 1 I4A 93084016 SKL5 DC X'883FFE0000100000' I4A 93091016 DC X'4A3FFE3FF8' I4A 93098016 LDOFF EQU *-SKL5 93101001 DC X'88BFFE3FFE100000' I4A 93105016 SKL5A EQU * I4A 93112016 SPACE 1 I4A 93119016 SKL6 DC X'88000F0000100000' I4A 93126016 DC X'48000E000F' I4A 93133016 DC X'74000E0003' I4A 93140016 DC X'78000F001D' I4A 93147016 DC X'46000E000F' I4A 93154016 SKL6A EQU * I4A 93161016 SPACE 1 I4A 93168016 SKL7 DC X'88000E0000100000' I4A 93175016 SKL8 DC X'4A000E3FF8' I4A 93182016 SKL7A EQU * I4A 93189016 SPACE 1 I4A 93196016 SKL9 DC X'88000F0000100004' I4A 93203016 DC X'94000F000010000A' I4A 93210016 DC X'4A000E000F' I4A 93217016 SKL9A EQU * I4A 93224016 SPACE 1 I4A 93231016 SKL10 DC X'8A000E0000100004' I4A 93238016 SKL10A EQU * I4A 93245016 SPACE 1 I4A 93252016 SKL11 DC X'90000F000010000C' I4A 93259016 DC X'070000' I4A 93266016 DC X'C7780C0F000E000E00000000' I4A 93273016 DC X'95800F000E100002' I4A 93280016 SKL11A EQU * I4A 93287016 SPACE 1 I4A 93294016 SKL12 DC X'90000F000010000C' I4A 93301016 DC X'74000F0010' I4A 93308016 DC X'070000' I4A 93315016 DC X'79800E3FF811000F' I4A 93322016 DC X'A0BFF83FF8100008' I4A 93329016 SKL12A EQU * I4A 93336016 SPACE 1 I4A 93343016 SKL13 DC X'483FFF000E' I4A 93350016 DC X'070000' I4A 93357016 DC X'48000E3FFF' I4A 93364016 DC X'48000F3FFF' I4A 93371016 DC X'74000F001D' I4A 93378016 DC X'78000E0003' I4A 93385016 DC X'46000E000F' I4A 93392016 SKL13B DC X'90000F000010000C' I4A 93399016 DC X'74000F0010' I4A 93406016 DC X'79800E3FF811000F' I4A 93413016 DC X'A0BFF83FF8100008' I4A 93420016 SKL13C DC X'8A3FFF0000100004' I4A 93427016 SKL13A EQU * I4A 93434016 SPACE 1 I4A 93441016 SKL14 DC X'4B000F000F' I4A 93448016 DC X'070000' I4A 93455016 DC X'A4800F000E100000' I4A 93462016 DC X'A5800F000E100004' I4A 93469016 DC X'A5800F000E100010' I4A 93476016 SKL14A EQU * I4A 93483016 SPACE 1 I4A 93490016 SKL15 DC X'A0000F0000100000' I4A 93497016 DC X'070000' I4A 93504016 DC X'B18000000E100000' I4A 93511016 DC X'A5800F000E100008' I4A 93518016 SKL15A EQU * I4A 93525016 SPACE 1 I4A 93532016 SKL16 DC X'8A000E0000100004' I4A 93539016 SKL16A EQU * I4A 93546016 SPACE 1 I4A 93553016 SKL17 DC X'443FFE0000' BCTR * EXPANSION 93556001 DC X'523FFE3FFE' LTR * FOR 93559001 DC X'8140070000' BC * BCTA' 93563001 SKL17B DC X'D980093FF93FFE3FFF' I4A 93567016 SKL17A EQU * I4A 93574016 SPACE 1 I4A 93581016 SKL18 DC X'483FF93FF8' I4A 93588016 SKL18A EQU * I4A 93595016 SPACE 1 I4A 93602016 SKL19 DC X'A0800F0000100008' I4A 93609016 SKL19B DC X'A5000F0000100004' I4A 93616016 SKL19C DC X'94000F000010000A' I4A 93623016 DC X'4B3FF9000F' I4A 93630016 SKL19D DC X'A53FF90000100000' I4A 93637016 DC X'D980093FF93FFE3FFF' I4A 93644016 SKL19A EQU * I4A 93651016 EJECT 93658016 * I4A 93665016 * I4A 93672016 * I4A 93679016 * FUNCTIONS I4A 93686016 * I4A 93693016 * THIS ROUTINE DETERMINES WHICH MULTI- I4A 93700016 * DIMENSIONED ARRAYS OF VARYING STRINGS, TASKS, I4A 93707016 * EVENTS AND AREAS ARE ELIGIBLE FOR SPECIAL CASE I4A 93714016 * TREATMENT. I4A 93721016 * THE CONDITIONS ARE - I4A 93728016 * I4A 93735016 * (1) OF THE HIGH BOUNDS, ONLY THE ROW MAJOR I4A 93742016 * HIGH BOUND MAY BE ADJUSTABLE. I4A 93749016 * I4A 93756016 * (2) NO LOW BOUNDS MAY BE ADJUSTABLE. I4A 93763016 * I4A 93770016 * (3) ALL MULTIPLIERS MUST BE KNOWN. I4A 93777016 * I4A 93784016 * (4) IF ANY DIMENSIONS ARE INHERITED, THEN ALL 93791016 * MUST BE INHERITED AND THEY MUST BE INHERITED 93798016 * FROM THE SAME LEVEL. 93805016 * I4A 93812016 * I4A 93819016 * I4A 93826016 * ENTRY POINT - TRIAL I4A 93833016 * I4A 93840016 * I4A 93847016 * I4A 93854016 * EXTERNAL ROUTINES I4A 93861016 * I4A 93868016 * (1) ZDRFAB IN COMPILER CONTROL I4A 93875016 * I4A 93882016 * I4A 93889016 * I4A 93896016 * EXITS - NORMAL I4A 93903016 * I4A 93910016 * (1) TO VOBJC IF THE CONDITIONS ARE NOT MET. I4A 93917016 * I4A 93924016 * (2) TO IMPS IF THE CONDITIONS ARE MET. I4A 93931016 * I4A 93938016 * I4A 93945016 * I4A 93952016 * EXITS - ERROR - NONE I4A 93959016 SPACE 10 I4A 93966016 TRIAL ST RR,0(RS) I4A 93973016 MVC PAR1+2(2),DIMREF I4A 93980016 BALR RR,RL DECODE DIMTAB REF I4A 93987016 L RC,PAR1 I4A 93994016 SPACE 1 I4A 94001016 LA RE,12(RC) POINT TO BOUNDS I4A 94008016 LH RB,N I4A 94015016 LR RF,RB 94022016 SLL RF,3 I4A 94029016 LA RF,0(RE,RF) POINT TO MULTS I4A 94036016 SR RR,RR I4A 94043016 SPACE 1 I4A 94050016 TRIAL1 TM 0(RF),X'F0' I4A 94057016 BC BNZ,TRIAL2 UNKNOWN MULT I4A 94064016 SPACE 1 I4A 94071016 TM 0(RE),X'FF' I4A 94078016 BC BNZ,TRIAL2 UNKNOWN LBOUND I4A 94085016 SPACE 1 94092016 TM 4(RE),X'FF' I4A 94099016 BC BZ,TRIAL3 I4A 94106016 LA RR,1(RR) UNKNOWN HBOUND I4A 94113016 SPACE 1 I4A 94120016 TRIAL3 STM RC,RF,4(RS) SAVE REGISTERS I4A 94127016 LA RE,8(RE) UPDATE POINTERS I4A 94134016 LA RF,4(RF) I4A 94141016 BCT RB,TRIAL1 I4A 94148016 SPACE 1 I4A 94155016 CH RR,C1 I4A 94162016 BC BNH,TRIAL4 BRANCH IF FEW ADJ HBS I4A 94169016 SPACE 1 I4A 94176016 TRIAL2 L RR,0(RS) I4A 94183016 BCR B,RR RETURN FOR GENERAL CASE I4A 94190016 SPACE 1 I4A 94197016 TRIAL4 LA RC,1 I4A 94204016 LA RD,0 I4A 94211016 STM RC,RD,CON1 INIT CON1,CON2 I4A 94218016 SPACE 1 I4A 94225016 LH RD,N 94232016 LM RE,RF,12(RS) I4A 94239016 SPACE 1 I4A 94246016 TRIAL5 L RC,0(RF) 94253016 MH RC,2(RE) 94260016 A RC,CON2 OFFSET FROM VO 94267016 ST RC,CON2 94274016 SPACE 1 I4A 94281016 TM 4(RE),X'FF' I4A 94288016 BC BNZ,TRIAL6 1ADJ HBOUND I4A 94295016 SPACE 1 I4A 94302016 LH RC,6(RE) 94309016 SH RC,2(RE) 94316016 LA RC,1(RC) 94323016 LR RR,RC 94330016 M RB,CON1 PARTIAL PRODUCT OF 94337016 ST RC,CON1 ELEMENTS 94344016 SPACE 1 I4A 94351016 TRIAL6 L RC,0(RF) SET UP POSS VALUE FOR NEXT 94358016 MR RB,RR MULTIPLIER 94365016 SPACE 1 I4A 94372016 SR RE,R4 I4A 94379016 SR RE,R4 ALTER POINTERS I4A 94386016 SR RF,R4 I4A 94393016 SPACE 1 I4A 94400016 CH RD,C1 94407016 BC BE,TRIAL8 BRANCH IF LAST TIME ROUND 94414016 SPACE 1 94421016 C RC,0(RF) BRANCH IF POSS ANE ACTUAL 94428016 BC BNE,TRIAL7 VALUES DIFFER I4A 94435016 SPACE 1 I4A 94442016 TRIAL8 BCT RD,TRIAL5 REPEAT LOOP 94449016 SPACE 1 I4A 94456016 LM RC,RD,4(RS) RESTORE RC,RD I4A 94463016 BC B,IMPS I4A 94470016 SPACE 1 I4A 94477016 TRIAL7 LM RC,RD,4(RS) RESTORE RC,RD I4A 94484016 BC B,TRIAL2 I4A 94491016 EJECT 94498016 * I4A 94505016 * I4A 94512016 * I4A 94519016 * FUNCTION I4A 94526016 * I4A 94533016 * THIS ROUTINE GENERATES THE CODE SEQUENCES I4A 94540016 * FOR THE INITIAILISATION OF THOSE MULTI-DIMENSIONED I4A 94547016 * ARRAYS OF AREAS, TASKS AND EVENTS, AND THE SETTING I4A 94554016 * UP OF STRING DOPE VECTORS FOR THOSE MULTI-DIMENSIONED I4A 94561016 * ARRAYS OF VARYING STRINGS WHICH HAVE BEEN FOUND I4A 94568016 * ELIGIBLE FOR SPECIAL CASE TREATMENT. I4A 94575016 * I4A 94582016 * I4A 94589016 * I4A 94596016 * ENTRY POINT - IMPS I4A 94603016 * I4A 94610016 * I4A 94617016 * I4A 94624016 * EXTERNAL ROUTINES I4A 94631016 * I4A 94638016 * (1) ZDRFAB IN COMPILER CONTROL I4A 94645016 * I4A 94652016 * (2) CMPIL1 IN IEMJL I4A 94659016 * I4A 94666016 * (3) LOADCN IN IEMJL I4A 94673016 * I4A 94680016 * (4) ADDCN IN IEMJL I4A 94687016 * I4A 94694016 * (5) SPEC I4A 94701016 * I4A 94708016 * I4A 94715016 * I4A 94722016 * EXITS - NORMAL I4A 94729016 * I4A 94736016 * (1) TO IPDV FOR VARYING STRINGS I4A 94743016 * I4A 94750016 * (2) TO CALLING ROUTINE FOR ALL OTHER ARRAYS I4A 94757016 * I4A 94764016 * I4A 94771016 * I4A 94778016 * EXITS - ERROR - NONE I4A 94785016 SPACE 10 I4A 94792016 IMPS LH RB,N I4A 94799016 SLL RB,2 94809001 AR RB,R4 I4A 94820016 STC RB,SKL50+7 I4A 94827016 LA RB,2(RB) I4A 94834016 STC RB,SKL52+7 I4A 94841016 SPACE 1 I4A 94848016 LA RE,SKL1 I4A 94855016 LA RF,SKL1A-SKL1 I4A 94862016 SPACE 1 I4A 94869016 TM 0(RD),X'0F' I4A 94876016 BC BNO,IMPS1 BRANCH IF NOT DATA I4A 94883016 SPACE 1 I4A 94890016 TM FDDATA(RD),X'02' I4A 94897016 BC BO,IMPS1 BRANCH IF AREA I4A 94904016 SPACE 1 I4A 94911016 LA RE,SV7 I4A 94918016 LA RF,SV8-SV7 I4A 94925016 BAL RR,CMPIL1 94926016 SPACE 94927016 LA RE,SKL18 94928016 LA RF,SKL18A-SKL18 94929016 IMPS1 BAL RR,CMPIL1 COMPILE USING STMT I4A 94932016 SPACE 1 I4A 94939016 TM 16(RC),X'FF' I4A 94946016 BC BNZ,IMPS2 BRANCH IF 1DJUST1BLE HB I4A 94953016 SPACE 1 I4A 94960016 LA RE,SKL1+3 I4A 94967016 L RF,CON1 I4A 94974016 BAL RR,LOADCN COMILE L 3FFE,NO ELMS I4A 94981016 BC B,IMPS3 I4A 94988016 SPACE 1 I4A 94995016 IMPS2 LA RE,OMULTO I4A 95002016 L RF,CON1 I4A 95009016 BAL RR,LOADCN COMP L 15,PART SUM I4A 95016016 SPACE 1 I4A 95023016 CLI BASESW,ON I4A 95030016 BC BE,IMPS4 BRANCH IF BASED I4A 95037016 MVC SKL50+3(2),DREF1 I4A 95044016 LA RE,SKL50 I4A 95051016 LA RF,SKL50A-SKL50 I4A 95058016 BAL RR,CMPIL1 95061001 BC B,IMPS5 I4A 95065016 SPACE 1 I4A 95072016 IMPS4 LA RE,SKL51 REFER VARIABLE 95081001 LA RF,SKL51A-SKL51 95090001 BAL RB,SPEC22 OUTPUT CODE 95099001 * 95108001 IMPS5 CLC 14(2,RC),C1 95117001 BC BE,IMPS6 BRANCH IF LBOUND = 1 I4A 95128016 SPACE 1 I4A 95135016 MVC SKL52+3(2),DREF1 I4A 95142016 LA RE,SKL52 I4A 95149016 LA RF,SKL52A-SKL52 I4A 95156016 BAL RR,CMPIL1 COMP SH 1ND LA I4A 95163016 SPACE 1 I4A 95170016 IMPS6 LA RE,SKL53 I4A 95177016 LA RF,SKL53A-SKL53 I4A 95184016 BAL RR,CMPIL1 I4A 95191016 SPACE 1 I4A 95198016 IMPS3 TM 0(RD),X'0F' I4A 95205016 BC BNO,IMPS7 BRANCH IF NOT DATA I4A 95212016 SPACE 1 I4A 95219016 TM FDDATA(RD),X'04' I4A 95226016 BC BO,IMPS7 BRANCH IF NOT BIT STRING I4A 95233016 SPACE 1 I4A 95240016 MVC SKL6+3(2),DREF1 I4A 95247016 LA RE,SKL6 I4A 95254016 LA RF,SKL6A-SKL6 I4A 95261016 BC B,IMPS8 I4A 95268016 SPACE 1 I4A 95275016 IMPS7 MVC SKL7+3(2),DREF1 I4A 95282016 LA RF,SKL8-SKL7 I4A 95289016 CLI BASESW,ON I4A 95296016 BC BNE,IMPS9 BRANCH IF NOT BASED I4A 95303016 LA RF,SKL7A-SKL7 I4A 95310016 IMPS9 LA RE,SKL7 I4A 95317016 IMPS8 BAL RR,CMPIL1 I4A 95324016 SPACE 1 95331016 L RF,CON2 95341001 BC B,SPEC81 95351001 SPACE 1 I4A 95366016 IMPS10 LH RB,N I4A 95373016 AR RB,RB I4A 95380016 AH RB,N I4A 95387016 SLL RB,2 95397001 L RF,8(RB,RC) POINT TO LAST MULT I4A 95408016 LA RE,OMULTE I4A 95415016 BAL RR,ADDCN I4A 95422016 SPACE 1 I4A 95429016 TM 0(RD),X'0F' I4A 95436016 BC BNO,SPEC17 I4A 95443016 SPACE 1 I4A 95450016 TM FDDATA(RD),X'02' I4A 95457016 BC BO,SPEC17 I4A 95464016 SPACE 1 I4A 95471016 IMPS11 MVC SKL17+13(2),ZEQMAX 95478001 BAL RR,BUMPEQ I4A 95485016 LA RE,SKL17 I4A 95492016 LA RF,SKL17B-SKL17 I4A 95499016 BAL RR,CMPIL1 I4A 95506016 BC B,IPDV I4A 95513016 SPACE 5 I4A 95520016 * THE TEXT SKELETONS FOR IMPS FOLLOW I4A 95527016 SPACE 5 I4A 95534016 SKL50 DC X'90000E0000100004' I4A 95541016 SKL50A EQU * I4A 95548016 SPACE 1 I4A 95555016 SKL51 DC X'88000E0000100000' I4A 95562016 DC X'4A000E3FF8' I4A 95569016 DC X'88800E000E100000' I4A 95576016 SKL51A EQU * I4A 95583016 SPACE 1 I4A 95590016 SKL52 DC X'93000E0000100006' I4A 95597016 DC X'A0800E000E100001' I4A 95604016 SKL52A EQU * I4A 95611016 SPACE 1 I4A 95618016 SKL53 DC X'4C000E000E' I4A 95625016 DC X'483FFE000F' I4A 95632016 SKL53A EQU * I4A 95639016 SPACE 5 I4A 95646016 CON1 DC F'0' I4A 95653016 CON2 DC F'0' I4A 95660016 EJECT 95920015 * REGISTER EQUS 95960015 SPACE 2 96000015 RA EQU 1 96040015 RB EQU 2 96080015 RC EQU 3 96120015 RD EQU 4 96160015 RE EQU 5 96200015 RF EQU 6 96240015 RS EQU 7 96280015 R1 EQU 8 96320015 R4 EQU 0 96360015 CC EQU 11 96400015 DIC EQU 13 96440015 RR EQU 14 96480015 RL EQU 15 96520015 SPACE 2 96560015 * CONDITION CODE EQUS 96600015 SPACE 2 96640015 B EQU 15 96680015 BH EQU 2 96720015 BL EQU 4 96760015 BE EQU 8 96800015 BNH EQU 13 96840015 BNL EQU 11 96880015 BNE EQU 7 96920015 BP EQU 2 96960015 BM EQU 4 97000015 BZ EQU 8 97040015 BNM EQU 11 97080015 BNP EQU 13 97120015 BNZ EQU 7 97160015 BO EQU 1 97200015 BNO EQU 14 97240015 SPACE 2 97280015 * DICTIONARY ENTRY OFFSET EQUS 97320015 SPACE 2 97360015 FDOT1B EQU 10 97400015 FDVARB EQU 11 97440015 FDOT2B EQU 12 97480015 FDOT3B EQU 13 97520015 FDOT4B EQU 14 97560015 FDDATA EQU 15 97600015 FSSSTI EQU 19 97640015 SPACE 2 I4A 97646016 * OTHER EQUS I4A 97652016 SPACE 2 I4A 97658016 ON EQU X'FF' I4A 97664016 OFF EQU X'00' I4A 97670016 SPACE 2 97680015 * OFFSETS IN THE COMMUNICATIONS REGION 97720015 SPACE 2 97760015 DB EQU JJ+X'1000' 97800015 SPACE 97840015 PAR1 EQU DB+X'80' 97880015 ZCOMM EQU DB+304 I4A 97890016 ZEQMAX EQU ZCOMM+82 I4A 97900016 SPACE 2 97920015 * OFFSETS IN IEMJL 97960015 SPACE 2 98000015 JL EQU JJ+X'2000' 98040015 SPACE 98080015 ADDCN EQU JL+X'06' I4A 98088016 LOADCN EQU JL+X'0E' I4A 98096016 CMPIL1 EQU JL+X'1A' I4A 98104016 BUMPEQ EQU JL+X'36' I4A 98112016 CS2 EQU JL+X'3E' 98120015 SPACE 2 I4A 98125016 * OFFSETS IN IEMJM I4A 98130016 SPACE 2 I4A 98135016 JM EQU JJ+X'3000' I4A 98140016 SPACE 1 I4A 98145016 IPDV EQU JM+X'0E' 98152016 SPACE 10 98154001 LTORG 98156001 ORG IEMJJ+4095 98158001 SPACE 5 98160015 ENDJJ EQU * 98200015 SPACE 2 98240015 END IEMJJ 98280015 ./ ADD SSI=03010242,NAME=IEMJK,SOURCE=0 JK TITLE 'IEMJK, STRUCTURE PROCESSOR, OS/360, PL/I COMPILER(F)' 00040015 * 00080015 * 00120015 * 00160015 * STATUS - CHANGE LEVEL 0 00200015 * 00202056 * 00204056 * 5.5 A 369200,370000 KT 62572 00205072 * 5.3B A 286400,468000,469200,973900 PJMG 47673 00206056 * C 067600,084000,308400-308800,428800-429200, PJMG 47673 00208056 * 556400-557200 PJMG 47673 00210056 * D 320400-320800,643200-643600,650400-650800, PJMG 47673 00212056 * 654000-654800 PJMG 47673 00214056 * 5.3A C 973900 MJG/KT 42010 00216056 * 5.2 A 682000 MJG/KT 31708 00218056 * 00220056 * 23274 RLSE18 492400 00230001 * 00240015 * FUNCTIONS - (1) CALL COMPILER CONTROL TO LOAD MODULES 00280015 * IEMJL AND IEMJM OF THIS PHYSICAL PHASE, AND TO OBTAIN SCRATCH 00320015 * CORE FOR THE OPERATION OF A STACKING PROCESS. 00360015 * (2) LOCATION OF EACH STRUCTURE BASE ELEMENT 00400015 * ON THE ALIGNMENT BOUNDARY REQUIRED BY ITS DATA TYPE. 00440015 * (3) CALCULATION OF THE OFFSET OF THE START 00480015 * OF EACH BASE ELEMENT FROM THE BEGINNING OF THE MAJOR STRUCTURE 00520015 * (4) CALCULATION OF THE MULTIPLIERS OF ALL 00560015 * ARRAYS APPEARING IN STRUCTURES, AND CALCULATION OF THE OFFSET 00600015 * PF THE VIRTUAL ORIGIN OF THE ARRAYS FROM THE MAJOR STRUCTURE. 00640015 * (5) CALCULATION OF THE SIZE OF ALL MINOR 00680015 * STRUCTURES AND THE SIZE OF THE MAJOR STRUCTURE. 00720015 * (6) CALCULATION OF THE MAXIMUM ALIGNMENT 00760015 * BOUNDARY IN THE STRUCTURE, AND THE OFFSET FROM THIS BOUNDARY 00800015 * OF THE START OF THE FIRST ELEMENT. 00840015 * (7) COMPILATION OF OBJECT CODE TO CARRY OUT 00880015 * FUNCTIONS (2) TO (6) ABOVE IN THE EVENT OF AN ADJUSTABLE 00920015 * EXPRESSION MAKING IT IMPOSSIBLE AT COMPILE TIME 00960015 * (8) THE DYNAMIC STORAGE ALLOCATION FOR 01000015 * ANY ADJUSTABLY SIZED STRUCTURES BY COMPILING OBJECT CODE 01040015 * TO ALIGN THE CONTENTS OF AN OBJECT ACCUMULATOR REGISTER TO 01080015 * THE ALIGNMENT BOUNDARY REQUIRED BY THE STRUCTURE, AND THEN 01120015 * COMPILING CODE TO ADD THE CONTENTS OF THIS REGISTER TO EACH 01160015 * BASE ELEMENT OF THE STRUCTURE. THE STORAGE ALLOCATION PHASE 01200015 * THEN COMPLETES THE PROCESS AT A LATER STAGE BY COMPILING 01240015 * CODE TO ADD THE ADDRESS OF THE STORAGE ALLOCATED TO THE 01280015 * VARIABLE REGION TO WHICH THE STRUCTURE BELONGS TO EACH BASE 01320015 * ELEMENT. 01360015 * 01400015 * 01440015 * 01480015 * ENTRY POINTS - (1) ENTRY FROM COMPILER CONTROL. THE 01520015 * MODULE BASE REGISTER IS LOADED, AND CONTROL IS TRANSFERRED TO 01560015 * THE ROUTINE BEGIN 01600015 * (2) BEGIN. THE OTHER TWO MODULES ARE 01640015 * LOADED, AND SCRATCH CORE IS OBTAINED. 01680015 * (3) PROCST. THE ENTRY POINT FOR THE 01720015 * STRUCTURE PROCESSOR. ON ENTRY REGISTER RD CONTAINS THE 01760015 * DICTIONARY ADDRESS OF A MAJOR STRUCTURE, AND THE HALF WORD 01800015 * LOCATION AREF CONTAINS ITS DICTIONARY REFERENCE. THE 2-BIT 01840015 * SWITCH CLASS HAS BEEN SET ACCORDING TO THE TYPE OF STORAGE OF 01880015 * THE STRUCTURE, DIMSW HAS BEEN SET OFF 01920015 * (4) SP54. ENTRY POINT FOR NON-STRUCTURED 01960015 * ARRAYS. ON ENTRY RD CONTAINS THE DICTIONARY ADDRESS OF AN 02000015 * ARRAY, AND AREF CONTAINS ITS DICTIONARY REFERENCE. DIMSW HAS 02040015 * BEEN SET ON. 02080015 * 02120015 * 02160015 * 02200015 * INPUT - THERE IS NO SPECIAL INPUT TO THIS MODULE EXCEPT 02240015 * THE PARAMETERS AND THE DICTIONARY 02280015 * 02320015 * 02360015 * 02400015 * OUTPUT - THE RESULTS OF THE OPERATION CARRIED OUT BY 02440015 * THIS MODULE ARE PLACED IN THE DICTIONARY ENTRIES OF THE ITEMS 02480015 * CONCERNED. ANY OBJECT CODE GENERATED IN EXECUTING FUNCTION (7) 02520015 * IS PLACED IMMEDIATELY AFTER THE LAST ITEM IN THE EXISTING 02560015 * TEXT FILE. 02600015 * 02640015 * 02680015 * 02720015 * EXTERNAL ROUTINES. (1) ZDRFAB. THIS COMPILER CONTROL 02760015 * ROUTINE TO CONVERT DICTIONARY REFERENCES TO ADDRESSES IS 02800015 * VERY FREQUENTLY. AFTER THE INITIAL LOAD ROUTINE, THE ADDRESS 02840015 * OF ZDRFAB IS PERMANENTLY MAINTAINED IN REGISTER RL 02880015 * (2) ZLOADW IS USED TO LOAD THE OTHER 02920015 * MODULES OF THE PHASE. 02960015 * (3) ZUGC IS USED TO GET CORE FOR THE 03000015 * STACKING MECHANISM. 03040015 * (4) CMPILE AND CMPIL1. THESE ARE TWO 03080015 * ENTRY POINTS TO THE SAME ROUTINE, LOCATED IN MODULE IEMJL. 03120015 * THE ROUTINES MOVE TEXT SKELETONS INTO THE TEXT FILE, KEEPING 03160015 * A COUNT OF THE AMOUNT COMPILED, AND OBTAINING NEW TEXT BLOCKS 03200015 * WHENEVER NECESSARY. 03240015 * (5) CHNSCN. LOCATED IN MODULE IEMJL, 03280015 * THIS IS THE CONTROLLING BLOCK FOR THE PHYSICAL PHASE. IT SCANS 03320015 * THE STATIC, AUTOMATIC, AND CONTROLLED CHAINS IN TURN 03360015 * TRANSFERRING CONTROL TO THE STRUCTURE PROCESSOR AND DIMENSION 03400015 * TABLE PROCESSOR ON FINDING THE APROPRIATE TYPE OF DICTIONARY 03440015 * ENTRY 03480015 * (6) LOADCN. LOCATED IN MODULE IEMJL 03520015 * THIS ROUTINE COMPILES AN OBJECT INSTRUCTION TO LOAD A CONSTANT 03560015 * THE VALUE OF WHICH IS KNOWN AT COMPILE TIME INTO AN OBJECT 03600015 * REGISTER. 03640015 * (7) MKCNST LOCATED IN IEMJL, MAKES 03680015 * CONSTANT DICTIONARY ENTRIES FOR LATER USE BY THE DYNAMIC 03720015 * STORAGE ALLOCATION PHASE. 03760015 * (8) OBJALG LOCATED IN IEMJL COMPILES 03800015 * OBJECT CODE TO ALIGN A LENGTH IN AN OBJECT REGISTER TO A 03840015 * BOUNDARY KNOWN AT COMPILE TIME 03880015 * (9) INOBJ LOCATED IN IEMJL OBTAINS 03920015 * THE TEXT POINTER TO THE NEXT AVAILABLE TEXT LOCATION, AND 03960015 * INITIALIZES THE COMPILED TEXT COUNT. 04000015 * (10) UPVO1, UPVO2, UPVO3 LOCATED IN 04040015 * IEMJL COMPILE OBJECT CODE TO UPDATE A VIRTUAL ORIGIN PARTIAL 04080015 * SUM IN A DOPE VECTOR BY THE PRODUCT OF A MULTIPLIER AND A 04120015 * LOW BOUND. 04160015 * (11) CMPLMT LOCATED IN IEMJL COMPILES 04200015 * CODE TO COMPLEMENT AN OBJECT REGISTER. 04240015 * (12) OALGM LOCATED IN IEMJL COMPILES 04280015 * OBJECT CODE TO PAD A MINOR STRUCTURE LENGTH TO A MULTIPLE OF 04320015 * THE MAXIMUM ALIGNMENT WITHIN THE MINOR STRUCTURE 04360015 * (13) OALGS LOCATED IN IEMJL COMPILES 04400015 * CODE TO ALIGN A PREVIOUS MINOR STRUCTURE AND INSERT PADDING 04440015 * BETWEEN IT AND AN ADJACENT MINOR STRUCTURE 04480015 * (14) SVARY LOCATED IN IEMJL EXAMINES 04520015 * EVERY STRUCTURE ELEMENT FOR ARRAYS OF VARYING STRINGS. ON 04560015 * FINDING SUCH AN ARRAY OBJECT CODE IS GENERATED TO INITIALIZE 04600015 * THE ARRAY OF STRING DOPE VECTORS. 04640015 * (15) EXTNT LOCATED IN IEMJL COMPILES 04680015 * OBJECT CODE TO CALCULATE THE EXTENT OF A BOUND PAIR. 04720015 * (16) BUMPEQ LOCATED IN IEMJL BUMPS 04760015 * THE VALUE OF THE EQU LABEL COUNT IN THE COMMUNICATIONS REGION. 04800015 * (17) INDEF LOCATED IN IEMJM 04840015 * INITIALIZES THE DOPE VECTORS OF DEFINED ITEMS BY COMPILING 04880015 * SUITABLE OBJECT CODE. 04920015 * 04960015 * 05000015 * 05040015 * EXITS-- NORMAL (1) PS39 IS THE NORMAL EXIT FROM THE 05080015 * STRUCTURE PROCESSOR FOR A NON-DEFINED STRUCTURE 05120015 * (2) SP75 IS THE NORMAL EXIT FROM THE 05160015 * PART OF THE STRUCTURE PROCESSOR USED BY THE DIMENSION TABLE 05200015 * PROCESSOR. EXIT OCCURS IF DIMSW IS ON. 05240015 * (3) PS56 IS THE NORMAL EXIT VIA THE 05280015 * ROUTINE INDEF FOR DEFINED ARRAYS. 05320015 * 05360015 * 05400015 * 05440015 * EXITS-- ABNORMAL - THERE ARE NO ABNORMAL EXITS FROM THIS 05480015 * MODULE. 05520015 * 05560015 * 05600015 * 05640015 * WORK AREA - THIS MODULE USES A 4K AREA OF SCRATCH CORE 05680015 * FOR A STACK. THIS STACK IS USED TO HOLD THE SIZE, ALIGNMENT, 05720015 * OFFSET AND DIMENSIONALITY OF MINOR STRUCTURES, WHILST 05760015 * PROCESSING OTHER ELEMENTS AT THE SAME OR A HIGHER LEVEL. 05800015 * 05840015 * 05880015 * 05920015 * ATTRIBUTES - REUSABLE 05960015 * 06000015 * 06040015 * 06080015 * NOTES (1) THIS PHASE REQUIRES NO MODIFICATION AS A 06120015 * RESULT OF CHANGES IN THE INTERNAL REPRESENTATION OF EXTERNAL 06160015 * GRAPHICS. 06200015 * (2) REFERENCES TO EXTERNAL ROUTINES. IN GENERAL 06240015 * NAMES OF EXTERNAL ROUTINES ARE RELOCATABLE SYMBOLS, RATHER 06280015 * THAN ABSOLUTE OFFSETS AND SPECIFIC BASE REGISTERS. THESE 06320015 * RELOCATABLE SYMBOLS ARE OBTAINED BY MEANS OF USING 06360015 * INSTRUCTIONS WITH SUITABLY ADJUSTED DECLARED CONTENTS SO THAT 06400015 * THE SYMBOLS ALWAYS ASSEMBLE WITH THE CORRECT BASE 06440015 * (3) REGISTER USAGE. REGISTERS ARE USED AS FOLLOWS 06480015 * RA ACCUMULATOR REGISTER FOR THE SIZE OF STRUCTURE ELEMENTS 06520015 * RB,RC - GENERAL PURPOSES 06560015 * RD - POINTER TO DICTIONARY ENTRIES 06600015 * RE,RF - GENERAL PURPOSES 06640015 * RS - STACK POINTER TO A SMALL INTERNAL STACK USED FOR 06680015 * SUBROUTINE LINKS 06720015 * R1 POINTS TO SCRATCH CORE 06760056 * R4 CONTAINS THE CONSTANT 4 06800015 * RR RETURN REGISTER 06840015 * DIC DICTIONARY REGISTER 06880015 * CC COMPILER CONTROL REGISTER 06920015 * RL COMPILER CONTROL BRANCH REGISTER. IT IS MAINTAINED POINTING 06960015 * TO ZDRFAB AFTER THE INITIALIZATION ROUTINE. 07000015 EJECT 07040015 IEMJK START 0 07080015 SPACE 2 07120015 USING *,9 07160015 SPACE 2 07200015 EJECT 07240015 * THE FOLLOWING USING INSTRUCTIONS ENABLE ALL EXTERNAL 07280015 * ROUTINE NAMES AND EXTERNAL STORAGE NAMES TO ASSEMBLE ON THE 07320015 * APPROPRIATE BASE REGISTERS 07360015 SPACE 07400015 USING *+X'1000',DIC 07440015 DB EQU *+X'1000' DICTIONARY BLOCK 07480015 USING *+X'2000',CC 07520015 CB EQU *+X'2000' CONTROL BLOCK 07560015 USING *+X'3000',10 07600015 B2 EQU *+X'3000' 07640015 USING *+X'4000',12 07680015 B3 EQU *+X'4000' 07720015 USING *+X'5000',R1 07760015 SCRACH EQU *+X'5000' 07800015 SPACE 2 07840015 NAME DC C'JK' 07880015 EJECT 07920015 * PARAMETERS USED IN MODULE IEMJK 07960015 SPACE 2 08000015 * REGISTER PARAMETERS 08040015 SPACE 2 08080015 RA EQU 1 ACCUMULATOR REGISTER 08120015 RB EQU 2 GENERAL PURPOSE REGISTER 08160015 RC EQU 3 GENERAL PURPOSE REGISTER 08200015 RD EQU 4 DICTIONARY POINTER 08240015 RE EQU 5 GENERAL PURPOSE REGISTER 08280015 RF EQU 6 GENERAL PURPOSE REGISTER 08320015 RS EQU 7 LINK STACK REGISTER 08360015 R1 EQU 8 SCRATCH CORE 08400056 R4 EQU 0 CONSTANT 4 08440015 CC EQU 11 COMPILER CONTROL BASE 08480015 DIC EQU 13 DICTIONARY BASE 08520015 RR EQU 14 RETURN REGISTER 08560015 RL EQU 15 BRANCH REGISTER 08600015 * 9 IEMJK BASE 08640015 * 10 IEMJL BASE 08680015 * 12 IEMJM BASE 08720015 SPACE 08760015 * CONDITION CODE PARAMETERS 08800015 SPACE 2 08840015 B EQU 15 UNCONDITIONAL BRANCH 08880015 BH EQU 2 BRANCH ON HIGH 08920015 BL EQU 4 BRANCH ON LOW 08960015 BE EQU 8 BRANCH ON EQUAL 09000015 BNH EQU 13 BRANCH ON NOT HIGH 09040015 BNL EQU 11 BRANCH ON NOT LOW 09080015 BNE EQU 7 BRANCH ON NOT EQUAL 09120015 BP EQU 2 BRANCH ON POSITIVE 09160015 BM EQU 4 BRANCH ON NEGATIVE 09200015 BZ EQU 8 BRANCH ON ZERO 09240015 BNM EQU 11 BRANCH ON NOT MINUS 09280015 BNP EQU 13 BRANCH ON NOT POSITIVE 09320015 BNZ EQU 7 BRANCH ON NOT ZERO 09360015 BO EQU 1 BRANCH ON ALL ONES 09400015 BNO EQU 14 BRANCH ON NOT ALL ONES 09440015 SPACE 09480015 * PSEUDO-CODE OPERATION CODE PARAMETERS 09520015 SPACE 09560015 ST EQU X'A5' THE SAME MNEMONICS ARE USED AS 09600015 SR EQU X'4B' IN THE ASSEMBLER LANGUAGE 09640015 LH EQU X'90' 09680015 SRL EQU X'78' 09720015 LR EQU X'48' 09760015 MR EQU X'4C' 09800015 AR EQU X'4A' 09840015 L EQU X'88' 09880015 STC EQU X'A4' 09920015 SRDL EQU X'77' 09960015 BCTR EQU X'44' 10000015 NR EQU X'45' 10040015 A EQU X'8A' 10080015 S EQU X'8B' 10120015 STH EQU X'95' 10160015 SLL EQU X'74' 10200015 OSM1 EQU X'10' LITERAL OFFSET 10240015 EQU EQU X'07' COMPILER INSERTED LABEL 10280015 SN3 EQU X'25' SECOND FILE STATEMENT MARKER 10320015 SPACE 10360015 * DICTIONARY ACCESS PARAMETERS 10400015 SPACE 10440015 DIMVAR EQU X'17' DIMENSIONED VARIABLE TEST MASK 10480015 STRUCT EQU X'2E' STRUCTURE TEST MASK 10520015 RDVBIT EQU X'01' RDV REQUIRED BIT 10560015 FSDIMI EQU 19 OFFSET TO DIMENSIONED STRUCTURE 10600015 * INFORMATION 10640015 FPRECN EQU 16 OFFSET TO PRECISION INFORMATION 10660001 FSDSTI EQU 22 OFFSET TO DIMENSIONED STRUCTURE 10680015 * STRUCTURING INFORMATION 10720015 FSSSTI EQU 19 OFFSET TO SCALAR STRUCTURE 10760015 * STRUCTURING INFORMATION 10800015 FDSYMI EQU 19 OFFSET TO DATA ITEM SYMBOL SLOT 10840015 FDDATA EQU 15 OFFSET TO DATA ITEM DATA BYTE 10880015 FPWIDB EQU 11 OFFSET TO PICTURE WIDTH BYTE 10920015 FDOT1B EQU 10 OFFSET TO OTHER 1 BYTE 10960015 FDOT2B EQU 12 OFFSET TO OTHER 2 BYTE 11000015 FDOT3B EQU 13 OFFSET TO OTHER 3 BYTE 11040015 FDOT4B EQU 14 OFFSET TO OTHER 4 BYTE 11080015 FDVARB EQU 11 OFFSET TO VARIABLE BYTE 11120015 FDDIMI EQU 25 OFFSET TO DATA ITEM DIMENSION 11160015 * INFORMATION 11200015 OTHER1 EQU 10 OFFSET OF OTHER1 CODE BYTE 11240015 VAR EQU 11 VARIABLE BYTE 11280015 STRINF EQU 19 LENGTH TO END OF OFFSET2 SLOT 11320015 BSEINF EQU 25 IN STRUCTURE AND BASE ELEMENT 11360015 TL EQU 1 OFFSET OF TRUE LEVEL FROM START 11400015 * OF STRUCTURE INFORMATION. 11440015 NXTSTR EQU 4 AND OFFSET OF NEXT STRUCTURE. 11480015 DN EQU 8 OFFSET OF DECLARE NUMBER IN 11520015 * MAJOR STRUCTURE 11560015 SPACE 2 11600015 * MISCELLANEOUS PARAMETERS 11640015 SPACE 11680015 STATIC EQU X'00' MASK FOR STATIC STORAGE FOR 11720015 * TESTING THE CLASS SWITCH 11760015 CONTRL EQU X'80' MASK FOR CONTROLLED STORAGE 11800015 AUTO EQU X'C0' MASK FOR AUTOMATIC STORAGE 11840015 STYPE EQU X'C0' TEST MASK FOR STORAGE TYPE 11880015 OFF EQU X'00' OFF CONDITION FOR SWITCHES 11920015 ON EQU X'FF' ON CONDITION FOR SWITCHES 11960015 ADD EQU X'C0' MASK FOR ADD CONSTANT 12000015 SUB EQU X'80' MASK FOR SUBTRACT CONSTANT 12040015 LOAD EQU X'00' MASK FOR LOAD CONSTANT 12080015 OTYPE EQU X'C0' OPERATION TYPE TEST MASK 12120015 DALG EQU X'20' ALIGNED BIT IN DATA BYTE 12160015 DIMS EQU X'40' 12200015 EOS EQU X'08' 12240015 DVD EQU X'CC' 12280015 TMP2 EQU X'40' 12320015 LJN EQU 2 OFFSET TO LENGTH OF PHASE JN 12360015 SPACE 2 12400015 * COMMUNICATIONS REGION PARAMETERS 12440015 SPACE 12480015 PAR1 EQU DB+128 PARAMETER1 12520015 PAR2 EQU DB+132 PARAMETER2 12560015 PAR6 EQU DB+X'94' 12600015 PAR7 EQU DB+X'98' 12640015 STATNO EQU DB+X'7E' 12680015 ZCOMM EQU DB+304 12720015 LOCK EQU DB+274 DICTIONARY BLOCK LOCK SLOT 12760015 TXTSZ EQU DB+264 SIZE OF TEXT BLOCKS 12800015 ZNXTLC EQU DB+276 NEXT AVAILABLE BYTE IN TEXT 12840015 ZMYNAM EQU DB+112 CURRENT MODULE NAME SLOT 12880015 ZSTACH EQU ZCOMM+68 START OF STATIC CHAIN 12920015 ZCITEM EQU ZCOMM+80 START OF CONTROLLED CHAIN 12960015 ZPROC1 EQU ZCOMM+64 START OF ENTRY TYPE 1 CHAIN 13000015 ZSMREG EQU ZCOMM+40 SYMBOLIC REGISTER SLOT 13040015 ZCONCH EQU ZCOMM+78 START OF CONTROLLED CHAIN 13080015 ZEQMAX EQU ZCOMM+82 MAXIMUM COMPILER LABEL 13120015 ZLOCK EQU DB+X'112' LOCK SLOT 13160015 SPACE 2 13200015 * COMPILER CONTROL ROUTINES 13240015 SPACE 13280015 ZDICRF EQU CB+X'2C' MAKE A DICTIONARY ENTRY 13320015 ZDRFAB EQU CB+X'34' CONVERT REFERENCE TO ADDRESS 13360015 ZUPL EQU CB+X'08' PRINT A LINE 13400015 ZUGC EQU CB+X'10' GET SCRATCH CORE 13440015 ZURC EQU CB+X'18' RELEASE SCRATCH CORE 13480015 ZABORT EQU CB+X'20' ABORT DUMP 13520015 ZTXTAB EQU CB+X'54' CONVERT TEXT REFERENCE TO 13560015 * ADDRESS 13600015 ZCHAIN EQU CB+X'58' CHAIN TO NEXT TEXT BLOCK 13640015 ZALTER EQU CB+X'5C' ALTER TEXT BLOCK STATUS 13680015 ZLOADW EQU CB+X'24' LOAD NEXT MODULE 13720015 RELESE EQU CB+X'44' RELEASE MODULES 13760015 ZUERR EQU CB+X'30' ERROR EDITOR ROUTINE 13800015 SPACE 2 13840015 * EXTERNALLY REFERENCED ROUTINES 13880015 SPACE 13920015 SETBRF EQU B2+2 SET BREF 13960015 ADDCN EQU SETBRF+4 14000015 SUBCN EQU ADDCN+4 SUBTRACT CONSTANT 14040015 LOADCN EQU SUBCN+4 LOAD CONSTANT 14080015 CMPILE EQU LOADCN+4 COMPILE OBJECT CODE 14120015 INOBJ EQU CMPILE+4 INITIALIZE OBJECT CODE 14160015 CMPIL1 EQU INOBJ+4 14200015 TERMWS EQU CMPIL1+4 TERMINATE WORKSPACE 14240015 FINISH EQU TERMWS+4 END MODULE AND RELEASE CONTROL 14280015 CHNSCN EQU FINISH+4 SCAN DICTIONARY DATA CHAINS 14320015 SVARY EQU CHNSCN+4 PRODUCE VARYING CODE FOR 14360015 * STRUCTURES 14400015 VOBJC EQU SVARY+4 INITIALIZE OBJECT CODE FOR 14440015 * VARYING STRINGS 14480015 ALVACA EQU VOBJC+4 ALIGN VARIABLE STORAGE AREA 14520015 * ACCUMULATOR FOR ARRAY 14560015 BUMPEQ EQU ALVACA+4 BUMP COMPILER LABEL COUNT 14600015 MKCNST EQU BUMPEQ+4 MAKE CONSTANT DICTIONARY ENTRY 14640015 CS2 EQU MKCNST+4 14680015 MP13 EQU CS2+4 14700015 BEGIN EQU MP13+4 14710016 * 14720015 PROCDT EQU B3+6 PROCESS DIMENSION TABLE 14760016 ERR2 EQU PROCDT+4 14800015 IPDV EQU ERR2+4 14840015 DP5 EQU IPDV+4 PROCDT ENTRY FROM PROCST 14880015 SETDVS EQU DP5+4 SET DOPE VECTOR FOR STRUCTURE 14920015 STDVS1 EQU SETDVS+4 DITTO FOR ADJUSTABLE STRUCTURE 14960015 ERR1 EQU STDVS1+4 15000015 CHKDEF EQU ERR1+4 15040015 RDV1 EQU CHKDEF+4 15080015 RDV2 EQU RDV1+4 15120015 RDV3 EQU RDV2+4 15160015 RDV4 EQU RDV3+4 15200015 RDV5 EQU RDV4+4 15240015 STBAS1 EQU RDV5+4 15280015 NXTREF EQU STBAS1+4 15320015 NXTRF1 EQU NXTREF+4 15360015 RD6 EQU NXTRF1+4 15380015 SPACE 2 15400015 * EXTERNALLY REFERENCED STORAGE 15440015 SPACE 15480015 BLOCK EQU BEGIN+4 15520016 LEVEL EQU BLOCK+2 CURRENT BLOCK LEVEL 15560015 MAXLVL EQU LEVEL+2 MAXIMUM STRUCTURE LEVEL 15600015 * 15640015 DONSW EQU MAXLVL+2 15680015 SPACE 15720015 ACC EQU RD6+6 15760015 DVOFF1 EQU ACC+4 15800015 BSREF EQU DVOFF1+2 15840015 VSW EQU BSREF+2 15880015 DVDSW EQU VSW+1 15920015 EJECT 15960015 * SUBROUTINES HELD IN SCRATCH CORE 15968015 SPACE 5 15976015 BASED EQU SCRACH+4 15984015 SPEC EQU BASED+4 I1 15986016 TRIAL EQU SPEC+4 15988016 SPACE 5 15992015 * EQUS FOR TEXT SKELETONS HELD IN SCRATCH CORE 16000015 SPACE 5 16040015 AD1 EQU SCRACH+X'1C2' I1 16080016 AD2 EQU AD1+3 16120015 AD3 EQU AD2+1 16160015 AD4 EQU AD3+2 16200015 SB21 EQU AD4+2 16240015 SB22 EQU SB21+7 16280015 SPACE 16320015 CD16 EQU SB22 16360015 CD17 EQU CD16+15 16400015 CD18 EQU CD17+5 16440015 CD91 EQU CD18 16480015 CD92 EQU CD91+10 16520015 CD93 EQU CD92+5 16560015 SPACE 16600015 CD19 EQU CD93 16640015 CD20 EQU CD19+25 16680015 CD21 EQU CD20+10 16720015 SPACE 16760015 CD19A EQU CD21 16800015 CD19B EQU CD19A+25 16840015 SPACE 16880015 CD26 EQU CD19B 16920015 CD27 EQU CD26+7 16960015 SPACE 17000015 CD30 EQU CD27 17040015 CD31 EQU CD30+5 17080015 SPACE 17120015 CD32 EQU CD31 17160015 CD33 EQU CD32+15 17200015 CD34 EQU CD33+10 17240015 SPACE 17280015 SB6 EQU CD34 17320015 SB7 EQU SB6+8 17360015 SPACE 17400015 SB9 EQU SB7 17440015 SB11 EQU SB9+20 17480015 SB10 EQU SB11+13 17520017 SPACE 17560015 SB16 EQU SB10 17600015 SB17 EQU SB16+16 17640015 SB18 EQU SB17+33 17680015 SB19 EQU SB18+5 17720015 SPACE 17760015 RD8 EQU SB19 17800015 RD9 EQU RD8+13 17840015 RD10 EQU RD9+21 17880015 RD11 EQU RD10+8 17920015 SPACE 17960015 RD16 EQU RD11 18000015 RD12 EQU RD16+8 18040015 RD13 EQU RD12+16 18080015 SPACE 18120015 SA1 EQU RD13 18160015 SA2 EQU SA1+3 18200015 SA3 EQU SA2+5 18240015 SA4 EQU SA3+2 18280015 SA5 EQU SA4+4 18320015 SA7 EQU SA5+4 18360015 SA6 EQU SA7+2 18400015 SPACE 18440015 MP9 EQU SA6 18480015 MP6 EQU MP9+6 18520015 MP8 EQU MP6+5 18560015 MP7 EQU MP8+5 18600015 MP5 EQU MP7+5 18640015 MP10 EQU MP5+10 18680015 SPACE 18720015 MP25 EQU MP10 18760015 SDVSIZ EQU MP25+9 18800015 N1 EQU SDVSIZ+6 18840015 DREF20 EQU N1+5 18880015 EQU51 EQU DREF20+14 18920015 EQU52 EQU EQU51+49 18960001 MP26 EQU EQU52+16 19000015 SPACE 19040015 SV7 EQU MP26 19080015 SV8 EQU SV7+13 19120015 SPACE 19160015 BITCVN EQU SV8 19200015 DREF11 EQU BITCVN+3 19240015 DREF17 EQU DREF11+28 19280015 SV9 EQU DREF17+5 19320015 TREF1 EQU SV9+8 19360015 L1 EQU TREF1+5 19400015 DREF12 EQU L1+3 19440015 BNDPT EQU DREF12+2 19480015 INSET1 EQU BNDPT+2 19520015 EQU11 EQU BNDPT+3 19560015 DCNT1 EQU EQU11+18 19600015 EQU21 EQU DCNT1+3 19640015 DREF13 EQU EQU21+5 19680015 EQU22 EQU DREF13+43 19720001 DREF14 EQU EQU22+5 19760015 SV10 EQU DREF14+5 19800015 DREF15 EQU SV10+24 19840015 SLPT EQU DREF15+4 19880015 SV16 EQU SLPT+10 19920015 DCNT2 EQU SV16+14 19960015 EQU31 EQU DCNT2+3 20000015 EQU41 EQU EQU31+31 20040015 EQU12 EQU EQU41+15 20080015 EQU42 EQU EQU12+3 20120015 DREF16 EQU EQU42+5 20160015 EQU32 EQU DREF16+43 20200001 SV12 EQU EQU32+2 20240015 SPACE 20280015 SV13 EQU SV12 20320015 SV14 EQU SV13+20 20360015 SPACE 20400015 IP1 EQU SV14 20440015 IP2 EQU IP1+8 20480015 IP3 EQU IP2+16 20520015 IP4 EQU IP3+8 20560015 IP10 EQU IP4+3 20600015 IP5 EQU IP10+15 20640015 IP6 EQU IP5+10 20680015 IP7 EQU IP6+8 20720015 IP8 EQU IP7+8 20760015 IP11 EQU IP8+10 20800015 IP9 EQU IP11+28 20840015 IP12 EQU IP9+18 20880015 SPACE 20920015 SD33 EQU IP12 20960015 SD15 EQU SD33+8 21000015 SD18 EQU SD15+26 21040015 SD16 EQU SD18+5 21080015 SD19 EQU SD16+13 21120015 SD34 EQU SD19+8 21160015 SPACE 21200015 SD35 EQU SD34 21240015 SD21 EQU SD35+8 21280015 SD36 EQU SD21+8 21320015 SPACE 21360015 SD37 EQU SD36 21400015 SD38 EQU SD37+26 21440015 SPACE 21480015 SD40 EQU SD38 21520015 SD41 EQU SD40+18 21560015 SPACE 21600015 SD42 EQU SD41 21640015 SD43 EQU SD42+8 21680015 SPACE 21682015 SD37A EQU SD43 21684015 SD38A EQU SD37A+8 21686015 SPACE 21688015 FAST1 EQU SD38A 21690015 FAST1A EQU FAST1+8 21692015 SPACE 21694015 FAST2 EQU FAST1A 21696015 FAST2A EQU FAST2+8 21698015 SPACE 21700015 RD16A EQU FAST2A 21702015 RD12A EQU RD16A+21 21704015 RD13A EQU RD12A+16 21706015 SPACE 1 I1 21708016 P1 EQU RD13A I1 21710016 P2 EQU P1+5 I1 21712016 SPACE 1 I1 21714016 MP25A EQU P2 I1 21716016 MP26A EQU MP25A+34 I1 21718016 SPACE 5 21720015 * WORK AREAS COMMON TO IEMJK, IEMJL AND IEMJM 21760015 SPACE 21800015 REGSAV EQU SCRACH+X'638' 21840001 STCKPT EQU REGSAV+X'78' 21880015 FRSTBD EQU STCKPT+4 21900015 OACC EQU FRSTBD+2 21920015 OWRK1 EQU OACC+2 21960015 OWRK2 EQU OWRK1+2 22000015 OOFF EQU OWRK2+2 22040015 OSTACK EQU OOFF+2 22080015 OLNGTH EQU OSTACK+2 22120015 AREF EQU OLNGTH+2 22160015 BREF EQU AREF+2 22200015 MREF EQU BREF+2 22240015 RREF EQU MREF+2 22280015 VREF EQU RREF+2 22320015 TREF EQU VREF+2 22360015 OFFSET EQU TREF+2 22400015 BOUND EQU OFFSET+2 22440015 MAXBND EQU BOUND+2 22480015 DIM1 EQU MAXBND+2 22520015 N EQU DIM1+2 22560015 DREF1 EQU N+2 22600015 CLASS EQU DREF1+2 22640015 WRKSW EQU CLASS+1 22680015 OBJSW EQU WRKSW+1 22720015 DIMSW EQU OBJSW+1 22760015 PS EQU DIMSW+1 22800015 WRKSW1 EQU PS+48 22840015 MAJSW EQU WRKSW1+1 22880015 LENGTH EQU MAJSW+1 22920015 DIMREF EQU LENGTH+4 22960015 NREF EQU DIMREF+2 23000015 DEFSW EQU NREF+2 23040015 SIZSW EQU DEFSW+1 23080015 DIM EQU SIZSW+1 23120015 DREF EQU DIM+2 23160015 DVOFF EQU DREF+2 23200015 BITSW EQU DVOFF+2 23240015 ADJSW EQU BITSW+1 23280015 VARYSW EQU ADJSW+1 23320015 MPL1 EQU VARYSW+1 23360015 MCOBOL EQU MPL1+2 23400015 QUFLAG EQU MCOBOL+2 I1 23430016 DUMMY EQU QUFLAG+1 I1 23460016 COBLSW EQU DUMMY+1 I1 23490016 CNTGSW EQU COBLSW+1 23520015 AREASW EQU CNTGSW+1 23560015 BASESW EQU AREASW+1 23600015 ADJ1SW EQU BASESW+1 23640015 V1SW EQU ADJ1SW+1 23680015 SUPRDV EQU V1SW+1 I1 23700016 SPACE 5 23720015 EJECT 25280015 * TRANSFER VECTOR TO ENABLE MODULES IEMJL AND IEMJM TO 25320015 * BRANCH TO ROUTINES IN THIS MODULE. 25360015 SPACE 2 25400015 SPACE 2 25440015 BC B,PROCST 25480015 BC B,SP54 25520015 BC B,ELSIZ 25560015 BC B,MKDVD 25600015 BC B,MOVEMP 25640017 SPACE 2 25680015 EJECT 25720015 EJECT 25760015 * PROCESS STRUCTURE - INITIALIZATION ROUTINE 25800015 * 25840015 * FUNCTIONS - INITIALIZES ALL NECESSARY SWITCHES, THE DOPE 25880015 * VECTOR OFFSET AND THE FIRST 8 BYTES OF THE STACK. THE 25920015 * ACCUMULATOR IS SET TO ZERO, AND THE CURRENT LEVEL COUNT,CLEVEL 25960015 * IS SET TO ONE. 26000015 * 26040015 * ENTRY POINT - PROCST FROM CHNSCN IN MODULE IEMJL. ON 26080015 * ENTRY RD CONTAINS THE DICTIONARY ADDRESS OF A MAJOR STRUCTURE, 26120015 * AND AREF CONTAINS ITS DICTIONARY REFERENCE. IF THE STRUCTURE 26160015 * IS AUTOMATIC, DREF1 CONTAINS THE DICTIONARY REFERENCE +1, IF 26200015 * IT IS CONTROLLED, THE CONTROLLED WORKSPACE REFERENCE, AND IF 26240015 * IT IS A BOUGHT TEMPORARY (TYPE2), THE TEMPORARY WORKSPACE 26280015 * REFERENCE. 26320015 * 26360015 * EXTERNAL ROUTINES - NONE 26400015 * 26440015 * EXITS - NORMAL - TO SP60 26480015 * 26520015 * EXITS - ERROR - NONE 26560015 SPACE 2 26600015 PROCST TM FDOT4B(RD),X'02' EXIT IF 'NEEDS NO DIMENSION 26640015 BCR BO,RR TABLE PROCESSING' BIT ON 26680015 ST RR,0(RS) 26720015 AR RS,R4 STACK SUBROUTINE LINK 26760015 MVI OBJSW,OFF SET OBJECT SWITCH OFF 26800015 MVI DIMSW,OFF DIMENSIONED SW=OFF 26840015 MVI ADJSW,OFF 26880015 MVI MAJSW,OFF SET MAJOR STRUCTURE SWITCH OFF 26920015 MVI ADJ1SW,OFF 26960015 MVI FSW,OFF 27000015 MVI FESW,OFF SET FIRST ELEMENT SWITCH OFF 27040015 MVI V1SW,OFF 27080015 MVI TASKSW,OFF 27120015 MVI RDVSW,OFF 27160015 TM FDOT4B(RD),RDVBIT 27200015 BC BZ,*+8 BRANCH IF NO RDV 27240015 MVI RDVSW,ON 27280015 MVI COBLSW,OFF 27320015 MVI CNTGSW,OFF 27360015 XC STATNO(2),STATNO 27520015 MVC DVOFF(2),5(RD) SET DOPE VECTOR OFFSET 27560015 MVC 0(1,RS),7(RD) SAVE FLAG BYTE 27600015 MVC 5(3,RD),ERROR+1 RESET OFFSET1 SLOT 27640015 TM 0(RS),X'04' 27680015 BC BZ,STR111 BRANCH IF NOT COBOL 27720015 MVI COBLSW,ON 27880015 TM 0(RS),X'02' 27920015 BC BO,SP5 BRANCH IF ADJUSTABLE 27960015 LA RC,FSSSTI(RD) 28000015 TM FDVARB(RD),X'40' 28040015 BC BZ,STR666 BRANCH IF UNDIMENSIONED 28080015 LA RC,3(RC) 28120015 STR666 MVC OFFSET+1(1),2(RC) 28160015 MVC MAXBND+1(1),6(RC) SET UP LENGTHS ETC AS 28200015 MVC ACC+1(3),7(RC) FOUND BY JI 28240015 BC B,PS63 28280015 STR111 MVC STATNO(2),8(RD) SET DECLARE NUMBER 28320015 MVC DREF(2),AREF 28360015 SR RA,RA CLEAR ACCUMULATOR 28400015 STH RA,DVOFF ZEROIZE DOPE VECTOR OFFSET 28440015 L RC,STCKPT 28480015 ST RA,0(RC) ZEROIZE FIRST WORK OF STACK 28520015 ST RA,4(RC) 28560015 STH RA,STKOFF ZEROIZE STACK OFFSET 28600015 MVC CLEVEL(2),C1 SET CLEVEL=1 28640015 MVC SPACE(4),CMAXSZ SPACE CONTAINS AMOUNT OF 28650056 * STORE LEFT AFTER DEDUCTION OF EACH ELEMENT LENGTH 28660056 EJECT 28680015 * PROCESS STRUCTURE - STACK STRUCTURE ELEMENT 28720015 * 28760015 * FUNCTIONS - (1) TO STACK THE NECESSARY INFORMATION AT 28800015 * THE START OF A NEW MINOR STRUCTURE. THE INFORMATION STACKED 28840015 * IS THE LENGTH OF THE PREVIOUS MINOR STRUCTURE, THE MAXIMUM 28880015 * ALIGNMENT BOUNDARY, THE OFFSET OF THE START OF THE STRUCTURE 28920015 * FROM THAT BOUNDARY, AND THE NUMBER OF DIMENSIONS OF THE 28960015 * CONTAINING STRUCTURE. 29000015 * (2) IF THE PREVIOUS MINOR STRUCTURE HAD 29040015 * ADJUSTABLE ITEMS IN IT, CODE IS COMPILED TO PERFORM AN EXACTLY 29080015 * PARALLEL OPERATION AT OBJECT TIME. 29120015 * (3) TO CHAIN TO THE NEXT ITEM, AND SET THE 29160015 * CURRENT LEVEL, AND REFERENCE TO THE NEXT ELEMENT. 29200015 * (4) TO EXAMINE THE NEXT ELEMENT AND TAKE 29240015 * THE FOLLOWING ACTION: (A) TRANSFER CONTROL TO THE PROCESS 29280015 * MINOR STRUCTURE DIMENSIONS ROUTINE IF THE NEXT ELEMENT HAS 29320015 * A LOWER LEVEL NUMBER THAN THE CURRENT ELEMENT. 29360015 * (B) TRANSFER CONTROL TO THE PROCESS BASE 29400015 * ELEMENT ROUTINE IF THE NEXT ITEM IS NOT A STRUCTURE 29440015 * (C) REENTER THIS ROUTINE IF THIS ELEMENT 29480015 * IS A STRUCTURE. 29520015 * 29560015 * ENTRY POINTS (1) SP60. ENTERED FROM INITIALIZE ROUTINE. 29600015 * (2) PS6. ENTERED FROM THE ALIGN MINOR 29640015 * STRUCTURE ROUTINE. 29680015 * (3) SP63. ENTERED FROM THE PROCESS BASE 29720015 * ELEMENT ROUTINE. IN EACH CASE DREF CONTAINS THE CURRENT 29760015 * ELEMENT REFERENCE. 29800015 * 29840015 * EXTERNAL ROUTINES (1) ZDRFAB IN COMPILER CONTROL. 29880015 * (2) CMPILE IN IEMJL, WHICH ADDS OBJECT 29920015 * CODE TO THE TEXT STREAM FROM THE BUFFER PS. 29960015 * 30000015 * EXITS - NORMAL (1) TO SP4 TO PROCESS BASE ELEMENTS, ON 30040015 * FINDING A BASE ELEMENT. 30080015 * (2) TO SP3 TO PROCESS MINOR STRUCTURE 30120015 * DIMENSIONS ON FINDING THE END OF A MINOR STRUCTURE. I.E. A 30160015 * LEVEL NUMBER LESS THAN THE CURRENT ONE. 30200015 * 30240015 * EXITS - ERROR - NONE. 30280015 SPACE 2 30320015 SP60 MVC MAXBND(2),C1 SET MAXBND=1 30360015 LH RB,STKOFF 30400015 LA RB,8(RB) BUMP STACK OFFSET 30440015 STH RB,STKOFF BUMP STACK OFFSET 30480015 SP61 SR RA,RA CLEAR ACCUMULATOR 30520015 STH RA,OFFSET CLEAR OFFSET 30560015 MVC BOUND(2),C1 SET BOUND=1 30600015 SP2 TM 0(RD),X'10' 30640015 BC BZ,SP62 BRANCH IF STRUCTURE NOT ARRAY 30680015 MVC DIM+1(2),FSDIMI(RD) SET DIMENSIONALITY 30720015 MVC DREF(2),FSDSTI+4(RD) SET DREF TO NEXT MEMBER 30760015 BC B,SP63 30800015 SP62 STH RA,DIM DIM=0 30860056 MVC DREF(2),FSSSTI+4(RD) SET DREF TO NEXT MEMBER 30920015 SP63 MVC PAR1+2(2),DREF 30960015 BALR RR,RL GET ADDRESS OF NEXT ENTRY 31000015 L RD,PAR1 31040015 LR RC,RD 31080015 TM 0(RD),X'0F' 31120015 BC BNO,*+8 31160015 LA RC,6(RC) BUMP POINTER IF DATA ITEM 31200015 TM 0(RD),X'10' 31240015 BC BZ,*+8 31280015 LA RC,3(RC) BUMP POINTER IF DIMENSIONED 31320015 MVC NREF(2),FSSSTI+4(RC) SET REFERENCE TO NEXT ELEMENT 31360015 MVC SLEVEL+1(1),FSSSTI+1(RC) SET SLEVEL 31400015 LH RB,SLEVEL 31440015 CH RB,MAXLVL 31480015 BC BNH,*+8 BRANCH IF SLEVEL NOT> MAXLEVEL 31520015 STH RB,MAXLVL 31560015 CH RB,CLEVEL BRANCH IF SLEVEL LESS THAN 31600015 BC BL,SP3 CLEVEL I.E. END OF MINOR STRUCT 31640015 TM 0(RD),X'0F' 31680015 BC BO,SP4 BRANCH IF DATA 31720015 TM 0(RD),X'0E' 31760015 BC BNO,SP4 BRANCH IF NOT STRUCTURE 31800015 STH RB,CLEVEL 31840015 PS6 L RC,STCKPT 31880015 LH RB,STKOFF 31920015 AR RC,RB CALCULATE STACK POINTER 31960015 ST RA,0(RC) STACK ACCUMULATOR 32000015 PS78 MVC 4(2,RC),OFFSET STACK OFFSET 32120015 MVC 6(1,RC),DIM+1 STACK DIM 32160015 MVC 7(1,RC),MAXBND+1 STACK MAXIMUM BOUND 32200015 BC B,SP60 32240015 EJECT 32280015 * PROCESS STRUCTURE - PROCESS BASE ELEMENT 32320015 * 32360015 * FUNCTIONS - TO DETERMINE THE AMOUNT OF STORAGE REQUIRED 32400015 * AND THE BOUNDARY ON WHICH IT MUST BE ALLOCATED. IF THE ITEM 32440015 * CONCERNED IS AN ADJUSTABLE STRING CONTROL IS TRANSFERRED TO 32480015 * A ROUTINE WHICH COMPILES CODE TO LOAD THE STRING LENGTH INTO 32520015 * AN OBJECT REGISTER. 32560015 * 32600015 * ENTRY POINTS - (1) SP4. FROM THE STACK STRUCTURE ELEMENT 32640015 * ROUTINE. 32680015 * (2) SP54. FROM PROCDT ROUTINE IN IEMJM. 32720015 * WHEN CONTROL ENTERS AT THIS POINT DIMSW IS ON, AND DIMREF HAS 32760015 * BEEN SET TO THE ARRAY DIMENSION TABLE. 32800015 * 32840015 * EXTERNAL ROUTINES - ZDRFAB IN COMPILER CONTROL. 32880015 * 32920015 * EXITS - NORMAL (1) TO SP26 IN CALCULATE BASE MULTIPLIERS 32960015 * FOR EVERYTHING EXCEPT ADJUSTABLE STRINGS. 33000015 * (2) TO SP5 IN ADJUSTABLE STRING ROUTINE. 33040015 * 33080015 * EXITS - ERROR - THERE ARE NO ERROR EXITS. 33120015 SPACE 2 33160015 SPACE 33200015 SP4 MVC CREF(2),FSSSTI+2(RC) SET REF TO CONTAINING STRUCTURE 33240015 MVC FSSSTI+7(2,RC),DVOFF SAVE DV OFFSET IN DICTIONARY 33280015 MVC DVOFF1(2),DVOFF SET DVOFF1 FOR USE IN CODE 33320015 NI FDOT3B(RD),X'FB' 33360015 TM 0(RD),X'10' 33400015 BC BZ,SP64 BRANCH IF NOT DIMENSIONED 33440015 MVC DIM1+1(1),16(RC) 33480015 MVC N(2),DIM1 SET DIMENSIONALITY IN N AND DIM1 33520015 MVC DIMREF(2),17(RC) SET REFERENCE TO DIMENSION TABLE 33560015 BC B,SP54 33600015 SP64 SR RB,RB *** ITEM NOT DIMENSIONED 33640015 STH RB,DIM1 33680015 STH RB,N 33720015 STH RB,DIMREF CLEAR DIM1, N, AND DIMREF 33760015 SPACE 33800015 SP54 LH RB,N *** ENTRY FROM PROCDT 33840015 SLL RB,3 33880015 AR RB,R4 BUMP DVOFF ACCORDING TO 33920015 AH RB,DVOFF DIMENSIONALITY 33960015 STH RB,DVOFF 34000015 SPACE 34040015 BAL RR,ELSIZ DETERMINE ELEMENT SIZE 34080015 BC B,SP26 BRANCH IF NOT ADJUSTABLE 34120015 SPACE 34160015 CLI BASESW,OFF 34200015 BC BE,SP5 ADJUST. NOT BASED 34240015 SPACE 34280015 MVI ADJ1SW,ON BASED ADJUSTABLE 34320015 SPACE 34360015 LA RE,1 34400015 TM FDDATA(RD),X'04' 34440015 BC BZ,SP541 BRANCH IF BIT 34480015 LA RE,8 34520015 TM FDDATA(RD),X'02' 34560015 BC BZ,SP541 BRANCH IF CHARACTER 34600015 LA RE,136 AREA 34640015 SP541 ST RE,LENGTH SET DUMMY LENGTH 34680015 BC B,SP26 34720015 SPACE 34760015 ELSIZ MVI BITSW,OFF 34800015 MVI AREASW,OFF 34820015 TM 0(RD),X'0F' 34840015 BC BO,SP65 BRANCH IF DATA ITEM 34880015 MVI TASKSW,ON SET ON IF TASK OR EVENT PRESENT 34920015 TM 0(RD),X'07' 34960015 BC BO,SP651 BRANCH IF LABEL 35000015 LA RB,32 EVENT OR TASK 35040015 STH RB,BOUND F-WORD BOUNDARY 35080015 LA RB,224 35120015 TM 0(RD),X'0D' 35160015 BC BNO,*+8 BRANCH IF TASK 35200015 LA RB,256 EVENT 35240015 ST RB,LENGTH 35280015 BC B,SP652 35320015 SP651 LA RB,64 *** LABEL VARIABLE 35360015 ST RB,LENGTH SET LENGTH 35400015 LA RB,32 35440015 STH RB,BOUND SET BOUND 35480015 SP652 TM 0(RD),X'20' I1 35500016 BCR BZ,RR RETURN IF UNSTRUCTURED I1 35520016 CLC BOUND(2),C8 I1 35540016 BCR BE,RR RETURN IF BOUND = 8 I1 35560016 TM FDOT4B(RD),X'08' I1 35580016 BCR BO,RR RETURN IF ALIGNED I1 35600016 MVC BOUND(2),C8 SET BOUND TO 8 FOR PACKED I1 35620016 BCR B,RR I1 35660016 SPACE 35680015 SP65 TM FDDATA(RD),X'80' *** DATA VARIABLE 35720015 BC BZ,SP66 BRANCH IF A STRING 35760015 TM FDDATA(RD),X'08' 35800015 BC BZ,SP71 BRANCH IF NUMERIC FIELD 35840015 TM FDDATA(RD),X'02' *** CODED ARITHMETIC DATA ROUTINE 35880015 BC BZ,SP67 BRANCH IF FIXED 35920015 SP70 TM FDDATA(RD),X'10' *** FLOAT OR BINARY ROUTINE 35960015 BC BZ,SP68 BRANCH IF SHORT 36000015 LA RB,64 36040015 SP69 LR RE,RB SET LENGTH IN REGISTER 36080015 SP73 STH RB,BOUND SET BOUND 36120015 TM FDDATA(RD),X'01' 36160015 BC BZ,*+6 BRANCH IF REAL 36200015 AR RE,RE DOUBLE LENGTH 36240015 ST RE,LENGTH SET LENGTH 36280015 BC B,SP652 36320015 SPACE 36360015 SP68 LA RB,32 *** SHORT. SET BOUND 36400015 BC B,SP69 36440015 SP67 TM FDDATA(RD),X'04' *** FIXED ROUTINE 36480015 BC BO,SP681 B IF BINARY 36520001 SR RE,RE 36560015 IC RE,FDDATA+1(RD) SET PRECISION IN RB 36600015 LA RE,2(RE) 36640015 SRL RE,1 SET LENGTH 36680015 SLL RE,3 CONVERT TO BITS 36720015 LA RB,8 SET BOUND 36760015 BC B,SP73 36800015 SP681 TM FDDATA(RD),X'40' 36801001 BC BO,SP68 FULLWD ALLOC IF PTR OR OFFSET 36802001 TM FDOT4B(RD),X'60' TEST FOR TEMPORARY 36803001 BM SP682 YES, BUT NOT COBOL TEMP 36806001 * 36809001 * EITHER NOT A TEMP OR A COBOL TEMP - SO MAP HW ITEMS AS HWDS. 36812001 SP683 TM FPRECN(RD),X'F0' TEST PRECISION 36815001 BC BNZ,SP68 FULLWORD BINARY 36818001 LA RB,16 36821001 BC B,SP69 HALFWORD BINARY 36824001 * 36827001 SP682 TM 18(RD),X'80' IS TEMP USED AS AN ARGUMENT ? 36830001 BZ SP68 NO - SO MAP AS A FULLWORD 36833001 B SP683 36836001 SPACE 36840015 SP71 MVC PAR1+2(2),FDSYMI(RD) *** NUMERIC FIELD ROUTINE 36880015 ST RR,0(RS) 36920015 MVC ZLOCK(2),AREF * LOCK IN DATA ITEM DICREF 62572 36940072 BALR RR,RL GET PICTURE ADDRESS 36960015 L RF,PAR1 37000015 L RR,0(RS) 37040015 SR RE,RE 37080015 IC RE,FPWIDB(RF) SET FIELD WIDTH 37120015 TM FDDATA(RD),X'04' 37160015 BC BO,SP72 BRANCH IF BINARY 37200015 LA RB,8 SET BOUND 37240015 SLL RE,3 CONVERT LENGTH TO BITS 37280015 BC B,SP73 37320015 SP72 LH RB,C1 SET BOUND 37360015 BC B,SP73 37400015 SPACE 37440015 SP66 LH RB,DVOFF *** STRING 37480015 AR RB,R4 BUMP DVOFF BY STRING DOPE VECTOR 37520015 STH RB,DVOFF 37560015 TM FDDATA(RD),X'10' 37600015 BC BZ,SP34 SKIP IF NOT VARYING 37640015 MVI V1SW,ON 37680015 TM 0(RD),X'10' 37720015 BC BZ,SP34 SKIP IF NOT DIMENSIONED 37760015 MVI VSW,ON SET VSW IF VARYING 37800015 SP34 TM FDDATA(RD),X'04' 37840015 BC BZ,SP74 BRANCH IF BIT STRING 37880015 LA RB,8 *** CHARACTER STRING 37920015 SR RE,RE 38000015 TM FDDATA(RD),X'02' *** CHAR STRING OR AREA 38040015 BC BZ,SP655 38080015 MVI AREASW,ON 38120015 LA RE,128 38160015 LA RB,64 38200015 SP655 STH RB,BOUND 38240015 TM FDDATA(RD),X'40' GO TO SP5 IF STRING HAS 38280015 BC BZ,*+12 38320015 LA RR,4(RR) ADJUSTABLE 38360015 BC B,SP652 38400015 MVC LENGTH+2(2),FDDATA+1(RD) SET STRING LENGTH 38440015 LH RB,LENGTH+2 38480015 SLL RB,3 38520015 AR RB,RE 38560015 ST RB,LENGTH 38600015 BC B,SP652 38640015 SPACE 38680015 SP74 MVI BITSW,ON *** BIT STRING 38720015 LH RB,C8 I1 38750016 TM FDDATA(RD),X'20' I1 38780016 BC BO,SP74A BRANCH IF ALIGNED I1 38810016 LH RB,C1 I1 38840016 MVI CNTGSW,ON SET PACKED BIT FLAG ON I1 38870016 SP74A STH RB,BOUND SET BOUND I1 38900016 TM FDDATA(RD),X'40' 38960015 BC BO,4(RR) BRANCH IF ADJUSTABLE STRING 39000015 SR RB,RB 39040015 STH RB,LENGTH 39080015 MVC LENGTH+2(2),FDDATA+1(RD) SET STRING LENGTH 39120015 TM FDDATA(RD),DALG 39160015 BCR BZ,RR EXIT IF NOT ALIGNED 39200015 L RB,LENGTH 39240015 LA RB,7(RB) 39280015 ST RB,LENGTH 39320015 NI LENGTH+3,X'F8' ALIGN LENGTH TO BYTE BOUNDARY 39360015 BCR B,RR EXIT 39400015 EJECT 39440015 * PROCESS STRUCTURE - CALCULATE BASE ELEMENT MULTIPLIERS 39480015 * 39520015 * FUNCTIONS (1) TO CALCULATE ALL THE MULTIPLIERS OF BASE 39560015 * ELEMENTS AND UNSTRUCTURED ARRAYS OF WHICH THE BOUNDS ARE 39600015 * KNOWN AT COMPILE TIME. 39640015 * (2) TO GENERATE CODE TO CALCULATE MULTIPLIERS 39680015 * WHEN THE ARRAY BOUNDS ARE EXPRESSIONS. AS MUCH WORK AS 39720015 * POSSIBLE IS DONE AT COMPILE TIME; ON ENCOUNTERING AN 39760015 * ADJUSTABLE BOUND THE PARTIALLY CALCULATED QUANTITIES ARE 39800015 * LOADED INTO OBJECT REGISTERS, AND OBJECT CODE IS GENERATED TO 39840015 * CARRY ON FROM THAT POINT. 39880015 * 39920015 * ENTRY POINTS (1) SP26. ENTERED FROM PROCESS BASE ELEMENT 39960015 * ROUTINE OR FROM THE ADJUSTABLE STRING ROUTINE. 40000015 * (2) SP10. THE ROUTINE IS REENTERED AT SP10 40040015 * AFTER BRANCHING OUT TO PRODUCE OBJECT CODE TO CALCULATE 40080015 * MULTIPLIERS 40120015 * 40160015 * EXTERNAL ROUTINES (1) ZDRFAB IN COMPILER CONTROL 40200015 * (2) UPVO1 IN IEMJL. COMPILES CODE TO 40240015 * UPDATE THE VIRTUAL ORIGIN IN THE DOPE VECTOR. 40280015 * 40320015 * EXIT POINTS - NORMAL (1) TO SP77 ON COMPLETION OF ALL 40360015 * THE MULTIPLIERS, OR IF THE ELEMENT IS NOT DIMENSIONED 40400015 * (2) TO SP7 ON ENCOUNTERING AN 40440015 * ADJUSTABLE LOWBOUND. CONTROL IS RETURNED AT SP10 AFTER 40480015 * COMPILING SUITABLE OBJECT CODE. 40520015 * (3) TO SP9 ON ENCOUNTERING AN 40560015 * ADJUSTABLE HIGH BOUND. CONTROL IS RETURNED TO SP10 AFTER 40600015 * COMPILING CODE. 40640015 * (4) TO SP28 AFTER CALCULATING AN 40680015 * EXTENT AT COMPILE TIME AFTER GENERATING OBJECT CODE. CONTROL 40720015 * IS RETURNED TO SP10. 40760015 * THE LAST THREE EXIT POINTS ARE ALL ENTRY POINTS TO THE 40800015 * CALCULATE OBJECT MULTIPLIER ROUTINE. 40840015 * 40880015 * EXITS - ERROR. THERE ARE NO ERROR EXITS. 40920015 SPACE 40960015 SP26 CLI DIMSW,ON 41000015 BC BE,SP77 BRANCH IF IN PROCESS DIMTAB 41040015 LH RB,BOUND LOAD ALIGNMENT 41080015 CLI BITSW,ON SET ALIGNMENT TO 1 IF BIT, EVEN 41120015 BC BNE,*+8 ALIGNED. ALIGNMENT FROM DIC 41160015 LH RB,C1 ENTRY USED ONLY TO SET MULTIPLIERS 41200015 STC RB,25(RC) TO BIT OR BYTE SUBSEQUENTLY 41240015 SP77 LH RB,DIM1 41280015 LTR RB,RB 41320015 BC BZ,SP6 LEAVE ROUTINE IF UNDIMENSIONED 41360015 CLI AREASW,ON 41367015 BC BNE,SP77A BRANCH IF NOT AREA 41374015 SPACE 41381015 L RR,LENGTH 41388015 ST RR,LNGTH1 41391015 LA RR,63(RR) 41395015 SRL RR,6 41402015 SLL RR,6 41409015 ST RR,LENGTH M'PLIER MUST BE MULT OF 8 41416015 S RR,LNGTH1 41418015 ST RR,LNGTH1 41420015 SPACE 41423015 SP77A MVC PAR1+2(2),DIMREF 41430015 BALR RR,RL GET DIMENSION TABLE ADDRESS 41440015 L RD,PAR1 41480015 SR RC,RC 41520015 ST RC,8(RD) CLEAR VIRTUAL ORIGIN SLOT 41560015 SP10 CH RB,DIM 41600015 BC BE,SP75 LEAVE ROUTINE IF DIM1=DIM 41640015 LH RE,N 41680015 SLL RE,3 N*8 41720015 AR RB,RB 41760015 AR RB,RB DIM1*4 41800015 AR RE,RB N*8+DIM1*4 41840015 L RC,LENGTH 41880015 CLI BITSW,ON 41920015 BC BE,PS15 BRANCH IF BIT BOUND 41960015 SRL RC,3 42000015 PS15 ST RC,8(RE,RD) SET MULTIPLIER 42040015 SPACE 42080015 SP27 AR RB,RB *** ROUTINE TO EVALUATE EXTENTS. 42120015 LA RE,4(RB,RD) SET POINTER TO DIM1TH LBOUND 42160015 TM 0(RE),X'FF' 42200015 BC BNZ,SP5 LEAVE ROUTINE IF ADJUSTABLE 42240015 LH RC,2(RE) LOAD LBOUND 42280015 SP8 M RB,LENGTH LENGTH*LBOUND 42320015 L RB,8(RD) LOAD ORIGIN SUM 42360015 SR RB,RC OS=OS-LBOUND*LENGTH 42400015 C RB,CMINSZ COMPAR WITH MIN SIZE 42440015 BC BL,ERR2 ERROR IF TOO SMALL 42480015 ST RB,8(RD) STORE ORIGIN SUM 42520015 SP30 TM 4(RE),X'FF' 42560015 BC BNZ,SP301 42600015 LH RC,6(RE) LOAD HBOUND 42640015 SH RC,2(RE) SUBTRACT LBOUND 42680015 AH RC,C1 EXTENT=HBOUND-LBOUND+1 42720015 SP302 M RB,LENGTH LENGTH=LENGTH*EXTENT 42760015 LTR RB,RB 42800015 BC BNZ,ERR1 ENTER ERROR ROUTINE OF TOO LARGE 42840015 CL RC,SPACE LENGTH > SPACE LEFT ? 42870056 BH ERR1 IF AVAILABLE SPACE EXCEEDED 42900056 * IEM1088 ROUTINE 42930056 ST RC,LENGTH 42960015 LH RB,DIM1 43000015 BCTR RB,0 DIM1=DIM1-1 43040015 STH RB,DIM1 43080015 BC B,SP10 CALCULATE NEXT MULTIPLIER 43120015 SPACE 43160015 SP301 CLI BASESW,OFF 43200015 BC BE,SP5 NOT BASED ITEM 43240015 SPACE 43280015 MVI ADJ1SW,ON BASED ADJUSTABLE 43320015 SPACE 43360015 LA RC,1 HBOUND-LBOUND=1 43400015 BC B,SP302 43440015 EJECT 43480015 * PROCESS STRUCTURE - CALCULATE OFFSET IN MINOR STRUCTURE. 43520015 * 43560015 * FUNCTIONS (1) TO CALCULATE THE OFFSET OF A BASE ELEMENT 43600015 * FROM THE START OF ITS IMMEDIATELY CONTAINING STRUCTURE, IF 43640015 * ALL THE INFORMATION IS KOWN AT COMPILE TIME 43680015 * (2) TO PLACE THE OFFSET IN THE OFFSET 1 SLOT 43720015 * OF A SCALAR BASE ELEMENT. 43760015 * (3) TO ADD THE OFFSET INTO THE VIRTUAL ORIGIN 43800015 * SLOT OF THE DIMENSION TABLE OF A DIMENSIONED BASE ELEMENT. 43840015 * 43880015 * ENTRY POINTS(1) SP75. ENTRY FROM CALCULATE BASE ELEMENT 43920015 * MULTIPLIERS. 43960015 * (2) SP31. RETURN FROM PRODUCE OBJECT CODE 44000015 * TO ADD MINOR STRUCTURE OFFSET INTO DOPE VECTOR ROUTINE. 44040015 * 44080015 * EXTERNAL ROUTINES - ZDRFAB. 44120015 * 44160015 * EXIT POINTS - NORMAL (1) TO DP5 IN PROCESS ARRAY IN 44200015 * MODULE IEMJM. EXITS IF DIMSW IS ON, I.E. ARRAY PROCESSING IS 44240015 * COMPLETE. 44280015 * (2) TO SP76 IN THE ROUTINE TO 44320015 * COMPILE OBJECT CODE TO ADD MINOR STRUCTURE OFFSET INTO DOPE 44360015 * VECTOR. EXIT TAKES PLACE IF ANY ADJUSTABLE ITEM HAS BEEN 44400015 * FOUND PREVIOUSLY IN THIS MINOR STRUCTURE. CONTROL RETURNS AT 44440015 * SP31. 44480015 * (3) TO SP63 IN THE STACK STRUCTURE 44520015 * ELEMENT ROUTINE. THIS EXIT IS TAKEN BY ALL STRUCTURE BASE 44560015 * ELEMENTS EXCEPT THE LAST ELEMENT IN THE STRUCTURE. 44600015 * (4) TO SP3 IN THE ALIGN STRUCTURE 44640015 * MULTIPLIER ROUTINE. THIS EXIT IS TAKEN BY THE LAST MEMBER 44680015 * OF THE STRUCTURE. 44720015 * 44760015 * EXITS - ERROR. THERE ARE NO ERROR EXITS. 44800015 SPACE 2 44840015 SP75 CLI AREASW,ON 44848015 BC BNE,SP75A BRANCH IF NOT AREA 44856015 SPACE 44864015 L RB,LENGTH 44872015 S RB,LNGTH1 44880015 ST RB,LENGTH 44888015 SPACE 44896015 SP75A CLI DIMSW,ON 44904015 BC BE,DP5 LEAVE ROUTINE IF PROCESS DIMTAB 44920015 CLI DONSW,OFF 44960015 BC BE,SP6 SKIP IF NOT DEFINED NOR BASE 45000015 SPACE 45040015 L RB,LENGTH *** SET LENGTH IN DIM TABLE 45080015 STC RB,3(RD) SET LEAST SIGNIFICANT BYTE 45120015 SRL RB,8 45160015 STH RB,6(RD) STORE MOST SIGNIFICANT BYTES 45200015 SPACE 45240015 SP6 MVI FESW,ON 45280015 LH RB,BOUND 45320015 LCR RF,RB SET MASK 45360015 BCTR RB,0 BOUND-1 45400015 LCR RC,RA -ACC 45440015 AR RA,RB ACC+BOUND-1 45480015 NR RA,RF MASK OUT LAST BITS TO ALIGN 45520015 AR RC,RA CALCULATE ALIGNMENT INCREMENT 45560015 LH RB,MAXBND SET ACCUMULATOR PRIORITY 45600015 LCR RB,RB SET TRUNCATION MASK 45640015 NR RB,RC CALCULATE AMOUNT BY WHICH PAD 45680015 AH RB,OFFSET CAN BE REDUCED, AND ADD THIS 45720015 STH RB,OFFSET AMOUNT TO THE OFFSET 45760015 LR RC,RA CALCULATE ACTUAL LENGTH OF 45800015 SR RC,RB PACKED STRUCTURE 45840015 PS27 CLC C1(2),N 45880015 BC BNH,SP95 BRANCH IF NO DIMENSIONS 45920015 SPACE 45960015 ST RC,0(RS) *** SET OFFSET IN DICTIONARY 46000015 MVC 5(3,RD),1(RS) 46040015 BC B,PS28 46080015 SPACE 46120015 SP95 A RC,8(RD) *** SET OFFSET IN VIRTUAL ORIGIN 46160015 ST RC,8(RD) 46200015 SPACE 46240015 MVC PAR1+2(2),DREF 46280015 BALR RR,RL 46320015 L RD,PAR1 GET DICTIONARY ENTRY 46360015 SPACE 46400015 PS28 A RA,LENGTH ADD LENGTH OF ELEMENT TO ACC 46440015 SP31 LH RB,BOUND 46480015 CH RB,MAXBND 46520015 BC BNH,*+8 46560015 STH RB,MAXBND SET MAX BOUND 46600015 MVC LREF(2),DREF SET LAST REF 46640015 TM FDOT1B(RD),X'08' 46680015 BC BO,SP78 BRANCH IF END OF STRUCTURE 46720015 MVC CLEVEL(2),SLEVEL CLEVEL=SLEVEL 46760015 MVC DREF(2),NREF SET DREF FROM NEXT REF 46800015 L RB,SPACE SUBTRACT LENGTH 46810056 S RB,LENGTH OF ELEMENT FROM 46820056 ST RB,SPACE SPACE LEFT. 46830056 BC B,SP63 EXAMINE NEXT STRUCTURE MEMBER 46840015 SPACE 46880015 SP78 MVC SLEVEL(2),C1 46920015 MVC SPACE(4),CMAXSZ NEW STRUCTURE: RESET TO 46930056 * MAXIMUM AVAILABLE SPACE 46940056 EJECT 46960015 * PROCESS STRUCTURE - ALIGN STRUCTURE MULTIPLIERS 47000015 * 47040015 * FUNCTIONS (1) IF THE MINOR STRUCTURE HAS DIMENSIONS OF 47080015 * ITS OWN, THIS ROUTINE PADS THE LENGTH SO FAR CALCULATED SO 47120015 * THAT IT IS A MULTIPLE OF THE MAXIMUM ALIGNMENT BOUNDARY 47160015 * APPEARING WITHIN IT. 47200015 * (2) THE AMOUNT OF PADDING NEEDED FOR (1) IS 47240015 * STORED SO THAT IT CAN BE REMOVED AFTER CALCULATING ALL THE 47280015 * MINOR STRUCTURE MULTIPLIERS. 47320015 * (3) IF THE MINOR STRUCTURE HAS ANY ADJUSTABLE 47360015 * QUANTITIES IN IT, THE ROUTINE OALGM IS CALLED TO COMPILE CODE 47400015 * TO CARRY OUT FUNCTIONS (1) AND (2). 47440015 * (4) THE ROUTINE SETS MAJSW IF THE STRUCTURE 47480015 * ELEMENT BEING PROCESSED IS A MAJOR STRUCTURE, SO THAT LATER 47520015 * ROUTINES CAN BY-PASS SOME UNSTACKING AND ALIGNMENT PROCESSES. 47560015 * 47600015 * ENTRY POINT - SP3. THIS ENTRY POINT MAY BE ENTERED FROM 47640015 * THREE PLACES (1) FROM STACK STRUCTURE ELEMENT ROUTINE ON 47680015 * FINDING THE END OF A MINOR STRUCTURE, I.E. A NEXT MEMBER OF 47720015 * STRUCTURE WITH A LOWER LEVEL THAN THE CURRENT MEMBER. 47760015 * (2) FROM CALCULATE MINOR STRUCTURE OFFSET ON 47800015 * FINDING THE LAST MEMBER OF STRUCTURE. 47840015 * (3) FROM STACK MINOR STRUCTURE ROUTINE, HAVING 47880015 * ALREADY PASSED THROUGH THIS ROUTINE FROM (1) OR (2) ABOVE, AND 47920015 * FINDING THAT THE NEXT MEMBER HAS A LOWER LEVEL THAN THE MINOR 47960015 * STRUCTURE JUST PROCESSED. 48000015 * 48040015 * EXTERNAL ROUTINES (1) ZDRFAB. 48080015 * (2) OALGM IN MODULE IEMJL. COMPILES 48120015 * CODE TO ALIGN THE ACCUMULATED STRUCTURE LENGTH TO A MULTIPLE 48160015 * OF THE MAXIMUM ALIGNMENT BOUNDARY WITHIN THE STRUCTURE. 48200015 * 48240015 * EXIT POINTS - NORMAL (1) TO SP13, IN THE ALIGN ADJACENT 48280015 * STRUCTURE ROUTINE. THIS EXIT IS TAKEN IF THE STRUCTURE DOES 48320015 * NOT HAVE ITS OWN DIMENSIONS. 48360015 * (2) TO SP81 IN THE CALCULATE MINOR 48400015 * STRUCTURE MULTIPLIER ROUTINE. 48440015 * 48480015 * EXIT POINTS - ERROR - THERE ARE NO ERROR EXITS. 48520015 SPACE 2 48560015 SP3 MVC PAR1+2(2),CREF 48600015 BALR RR,RL GET ADDRESS OF CONTAINING STR 48640015 L RD,PAR1 48680015 TM FDOT4B(RD),X'04' 48720015 BC BZ,*+8 SKIP IF NOT MAJOR STRUCTURE 48760015 MVI MAJSW,ON 48800015 LH RB,STKOFF 48840015 SR RB,R4 48880015 SR RB,R4 48920015 STH RB,STKOFF REDUCE STACK OFFSET 48960015 TM FDVARB(RD),X'40' 49000015 BC BO,SP79 BRANCH IF DIMENSIONED 49040015 SR RB,RB 49080015 STH RB,DIM1 DIM1=0 49120015 BC B,SP13 LEAVE ROUTINE 49160015 SPACE 49200015 SP79 EQU * 23274 49220001 MVI CNTGSW,ON 23274 49240001 MVC DIM1+1(1),FSDIMI(RD) SET DIM1 23274 49260001 L RC,STCKPT 49280015 IC RF,6(RB,RC) INSERT STACKED DIMENSIONALITY 49320015 STC RF,DIM+1 SET DIM 49360015 LH RB,DIM1 49400015 CH RB,DIM BRANCH IF THIS STRUCTURE MEMBER 49440015 BC BE,SP13 IS NOT DIMENSIONED 49480015 LH RB,MAXBND 49520015 LCR RF,RB SET MASK 49560015 BCTR RB,0 49600015 SH RA,OFFSET SUBTRACT OFFSET 49640015 LCR RC,RA NEGATE ELEMENT LENGTH 49680015 AR RA,RB ACC+BOUND-1 49720015 NR RA,RF ALIGN PACKED ELEMENT LENGTH 49760015 AR RC,RA CALCULATE ALIGNMENT INCREMENT 49800015 STH RC,ALGINC 49840015 EJECT 49880015 * PROCESS STRUCTURE - CALCULATE MINOR STRUCTURE MULTIPLIER 49920015 * 49960015 * FUNCTIONS (1) TO SCAN FROM THE MINOR STRUCTURE TO THE 50000015 * FIRST BASE ELEMENT. 50040015 * (2) TO CALCULATE THE MINOR STRUCTURE 50080015 * MULTIPLIER FROM THE DIMENSION TABLE OF THE FIRST ELEMENT IF 50120015 * POSSIBLE. 50160015 * (3) TO PASS CONTROL TO THE ROUTINE TO GENERATE 50200015 * OBJECT CODE TO CALCULATE THE MULTIPLIER IF NECESSARY. 50240015 * 50280015 * ENTRY POINTS (1) SP81 FROM ALIGN STRUCTURE MULTIPLIERS 50320015 * (2) SP85 FROM SET STRUCTURE MULTIPLIERS 50360015 * 50400015 * EXTERNAL ROUTINES - ZDRFAB 50440015 * 50480015 * EXIT POINTS - NORMAL (1) SP14 IN OBJECT MINOR STRUCTURE 50520015 * MULTIPLIER ROUTINE IF AN ADJUSTABLE QUANTITY HAS ALREADY BEEN 50560015 * FOUND. 50600015 * (2) SP86 IN OBJECT MINOR STRUCTURE 50640015 * MULTIPLIER ON DISCOVERING AN ADJUSTABLE LOWBOUND. 50680015 * (3) SP36 IN OBJECT MINOR STRUCTURE 50720015 * MULTIPLIER ON DISCOVERING AN ADJUSTABLE HIGH BOUND 50760015 * (4) SP15 IN SET MINOR STRUCTURE 50800015 * MULTIPLIER. 50840015 * 50880015 * EXITS - ERROR - THERE ARE NO ERROR EXITS. 50920015 SPACE 2 50960015 SP81 MVC SREF(2),FSDSTI+4(RD) SET SCAN REF TO NEXT MEMBER 51000015 SP85 MVC PAR1+2(2),SREF 51040015 BALR RR,RL GET SREF ADDRESS 51080015 L RD,PAR1 51120015 TM 0(RD),X'0F' 51160015 BC BO,SP84 BRANCH IF DATA ITEM 51200015 LA RC,FSDIMI(RD) SET POINTER TO DIM INFORMATION 51240015 BC B,SP84+4 51280015 SP84 LA RC,FDDIMI(RD) SET POINTER TO DIM INFORMATION 51320015 MVC SREF1(2),7(RC) SET REF TO NEXT STRUCTURE MEMBER 51360015 TM 0(RD),X'0F' 51400015 BC BO,SP89 BRANCH IF DATA 51440015 TM 0(RD),X'0E' 51480015 BC BNO,SP89 BRANCH IF NOT STRUCTURE 51520015 MVC SREF(2),SREF1 51560015 BC B,SP85 51600015 SP89 MVC BOUND+1(1),9(RC) SET BOUND 51640015 MVC N+1(1),0(RC) SET N TO DIMENSIONALITY OF ITEM 51680015 MVC DVOFF1(2),10(RC) SET DOPE VECTOR OFFSET 51720015 MVC PAR1+2(2),1(RC) 51760015 BALR RR,RL GET DIM TAB ADDRESS 51800015 L RD,PAR1 51840015 LH RB,DIM1 51880015 SLL RB,3 DIM1*8 51920015 LA RE,4(RB,RD) DIMPT+DIM1*8+4 51960015 TM 0(RE),X'FF' 52000015 BC BNZ,SP5 BRANCH IF ADJUSTABLE LBOUND 52040015 MVC LBOUND(2),2(RE) SET LOWBOUND 52080015 LH RC,2(RE) 52120015 MR RB,RA 52160015 ST RC,LENGTH LENGTH=ACC*LBOUND 52200015 MVC HBOUND(2),6(RE) 52210015 TM 4(RE),X'FF' 52220015 BC BZ,SP15 BRANCH IF NON ADJUSTABLE 52230015 SPACE 52240015 CLI BASESW,ON 52250015 BC BNE,SP5 BRANCH IF NON BASED 52260015 SPACE 52270015 MVI ADJ1SW,ON 52280015 LH RR,LBOUND 52290015 AH RR,C1 DUMMY VALUE FOR BASED ADJ 52300015 STH RR,HBOUND 52310015 EJECT 52400015 * PROCESS STRUCTURE - SET MINOR STRUCTURE MULTIPLIERS. 52440015 * 52480015 * FUNCTIONS (1) TO SCAN THROUGH ALL THE BASE ELEMENTS 52520015 * BELONGING TO THE MINOR STRUCTURE. 52560015 * (2) TO UPDATE THE VIRTUAL ORIGIN OF EACH 52600015 * ELEMENT BY SUBTRACTING THE PRODUCT OF THE LOW BOUND AND 52640015 * MULTIPLIER. 52680015 * (3) TO SET THE MULTIPLIER IN THE DIMENSION 52720015 * TABLE OF EACH BASE ELEMENT 52760015 * (4) TO PASS CONTROL TO THE ROUTINE TO GENERATE 52800015 * CODE TO CARRY OUT (2) AND (3) IF NECESSARY. 52840015 * 52880015 * ENTRY POINTS (1) SP15 FROM CALCULATE MINOR STRUCTURE 52920015 * MULTIPLIER. 52960015 * (2) SP91 RETURN FROM OBJECT SET MULTIPLIER 53000015 * ROUTINE. 53040015 * 53080015 * EXTERNAL ROUTINES - ZDRFAB. 53120015 * 53160015 * EXIT POINTS NORMAL (1) TO SP87 IF OBJECT CODE IS 53200015 * REQUIRED. 53240015 * (2) TO SP13 IN ALIGN ADJACENT MINOR 53280015 * STRUCTURES AFTER PROCESSING THE LAST MINOR STRUCTURE DIMENSION 53320015 * (3) TO SP85 IN CALCULATE MINOR 53360015 * STRUCTURE MULTIPLIER IF SOME DIMENSIONS REMAIN. 53400015 * 53440015 * EXITS - ERROR - NONE. 53480015 * 53520015 * NOTES - FOR ARRAYS OF BIT STRINGS THE MULTIPLIERS ARE 53560015 * SET IN BITS. OTHERWISE THEY ARE SET IN BYTES. 53600015 SPACE 2 53640015 SP15 LH RB,N 53680015 AR RB,RB 53720015 AH RB,DIM1 53760015 AR RB,RB 53800015 AR RB,RB (2N+DIM1)*4 53840015 CLC C1(2),BOUND 53880015 BC BE,PS13 BRANCH IF BIT MULTIPLIER 53920015 LR RF,RA 53960015 SRL RF,3 54000015 ST RF,8(RB,RD) SET DIM1 TH MULTIPLIER IN BYTES 54040015 BC B,PS14 54080015 SPACE 54120015 PS13 ST RA,8(RB,RD) SET DIM1 TH MULTIPLIER IN BITS 54160015 PS14 L RB,8(RD) 54200015 S RB,LENGTH ORIGIN SUM-MULT*LBOUND 54240015 C RB,CMINSZ 54280015 BC BL,ERR2 ERROR IF VO TOO SMALL 54320015 ST RB,8(RD) 54360015 PS60 CLC SREF(2),LREF 54400015 BC BE,PS75 BRANCH IF END OF MIN STRUCTURE 54440015 SP91 MVC SREF(2),SREF1 54480015 MVC PAR1+2(2),SREF 54520015 BALR RR,RL GET ADDRESS OF NEXT MEMBER 54560015 L RD,PAR1 54600015 TM 0(RD),X'0F' 54640015 BC BO,*+12 54680015 LA RC,FSDIMI(RD) 54720015 BC B,*+8 54760015 LA RC,FDDIMI(RD) 54800015 MVC N+1(1),0(RC) SET N 54840015 MVC SREF1(2),7(RC) SET REF TO NEXT ELEMENT 54880015 TM 0(RD),X'0F' 54920015 BC BO,*+12 BRANCH IF DATA 54960015 TM 0(RD),X'0E' 55000015 BC BO,SP91 BRANCH IF STRUCTURE 55040015 SPACE 55080015 MVC DVOFF1(2),10(RC) *** BASE ELEMENT. SET DV OFFSET 55120015 MVC BOUND+1(1),9(RC) SET BOUND 55160015 MVC PAR1+2(2),1(RC) 55200015 BALR RR,RL GET NEXT DIMTAB ADDRESS 55240015 L RD,PAR1 55280015 BC B,SP15 PROCESS NEXT ELEMENT DIM TABLE 55320015 SPACE 55360015 PS75 LH RC,HBOUND 55400015 SH RC,LBOUND 55440015 AH RC,C1 EXTENT=HBOUND-LBOUND+1 55480015 MR RB,RA CALCULATE NEXT MULTIPLIER 55520015 LTR RB,RB 55560015 BC BNZ,ERR1 ENTER ERROR ROUTINE OF TOO LARGE 55600015 L RB,SPACE RESET TO PREVIOUS 55620056 AR RB,RA SPACE LEFT 55640056 LR RA,RC RA = RA * EXTENT 55660056 CLR RB,RA ERROR IEM1088 55680056 BL ERR1 IF SPACE TOO SMALL 55700056 SR RB,RA REDUCE SPACE LEFT 55720056 ST RB,SPACE 55740056 PS23 LH RB,DIM1 55760015 BCTR RB,0 REDUCE DIM1 55800015 STH RB,DIM1 55840015 CH RB,DIM 55880015 BC BNE,PS36 55920015 AH RA,OFFSET ADD OFFSET TO ACC 55960015 SH RA,ALGINC SUBTRACT ALIGNMENT INCREMENT 56000015 BC B,SP13 56040015 SPACE 56080015 PS36 MVC SREF(2),CREF 56120015 BC B,SP85 RETURN FOR NEXT MULTIPLIER 56160015 SPACE 2 56200015 EJECT 56240015 * PROCESS STRUCTURE - ALIGN ADJACENT STRUCTURE 56280015 * 56320015 * FUNCTIONS (1) TO UNSTACK ALL THE INFORMATION AT THE TOP 56360015 * OF THE STACK, WHICH REFERS TO THE ADJACENT PRECEDING MINOR 56400015 * STRUCTURE AT THE SAME LEVEL AS THE PRESENT ONE. 56440015 * (2) TO CALCULATE THE AMOUNT OF PADDING WHICH 56480015 * MUST BE PLACED BETWEEN THE PRECEDING AND PRESENT STRUCTURES 56520015 * IN ORDER THAT THEY ARE BOTH ALIGNED ON THE CORRECT BOUNDARIES. 56560015 * (3) TO CALCULATE THE AMOUNT OF THE OFFSET 56600015 * FROM THE NEAREST PRECEDING MAXIMUM ALIGNMENT BOUNDARY TO THE 56640015 * START OF FIRST MINOR STRUCTURE. 56680015 * (4) IF ANY PART OF THE STRUCTURE IS ADJUSTABLE 56720015 * CODE IS GENERATED TO CARRY OUT OPERATIONS (1),(2) AND (3) AT 56760015 * OBJECT TIME. 56800015 * 56840015 * ENTRY POINT - SP13. ENTERED FROM CALCULATE MINOR 56880015 * STRUCTURE MULTIPLIER ROUTINE. 56920015 * 56960015 * EXTERNAL ROUTINES (1) ZDRFAB 57000015 * (2) LOADCN IN MODULE IEMJL. LOADS A 57040015 * CONSTANT KNOWN AT COMPILE TIME INTO AN OBJECT REGISTER. 57080015 * 57120015 * EXIT POINTS - NORMAL (1) TO SP93 IN OBJECT ALIGN 57160015 * ADJACENT STRUCTURE. 57200015 * (2) TO SP99 IN OBJECT ALIGN 57240015 * ADJACENT STRUCTURE. 57280015 * (3) PS25 IN ADD STORAGE OFFSET 57320015 * ROUTINE. THIS EXIT IS TAKEN ONLY FOR THE MAJOR STRUCTURE. 57360015 * (4) TO SP97 IN ADD ADJACENT 57400015 * STRUCTURE OFFSET ROUTINE. 57440015 * 57480015 * EXITS - ERROR - NONE. 57520015 SPACE 2 57560015 SP13 L RB,STCKPT 57600015 AH RB,STKOFF SET STACK POINTER 57640015 MVC BOUND+1(1),7(RB) UNSTACK BOUND 57680015 SPACE 57720015 ST RA,ACC 57760015 SPACE 57800015 PS1 CLI MAJSW,ON *** COMPILE TIME ACCUMULATOR 57840015 BC BNE,PS50 BRANCH IF NOT MAJOR STRUCTURE 57880015 CLI DEFSW,ON 57920015 BC BE,PS51 EXIT IF DEFINED 57960015 SR RA,RA 58000015 TM CLASS,STYPE 58040015 BC BNM,PS24 BRANCH IF NOT CONTROLLED 58080015 LH RA,OFFSET 58120015 BC B,PS57 58160015 SPACE 58200015 PS50 MVI FSW,ON 58240015 MVC OFFST1(2),4(RB) 58280015 L RA,0(RB) LOAD STACKED QUANTITY 58320015 LH RC,MAXBND 58360015 LCR RF,RC 58400015 BCTR RC,0 58440015 LR RE,RC CALCULATE AMOUNT BY WHICH ACC1 58480015 NR RE,RA INTRUDES INTO BOUND FIELD 58520015 LCR RE,RE 58560015 AH RE,OFFSET COMPARE INTRUSION WITH OFFSET 58600015 BC BNM,*+8 58640015 SR RE,RF ADD ONE ALIGNMENT LENGTH TO PAD 58680015 AR RA,RC ADD BOUND TO ACC1 58720015 NR RA,RF ALIGN ACC1 58760015 AH RA,OFFSET 58800015 LH RB,BOUND CALCULATE NUMBER OF UNITS OF 58840015 LCR RB,RB BOUND REQUIRED TO ALIGN ACC1 TO 58880015 NR RE,RB MAX BOUND 58920015 AH RE,OFFST1 58960015 STH RE,OFFST1 59000015 SR RA,RE CALCULATE STRUCTURE OFFSET 59040015 BC B,PS24 59080015 SPACE 59120015 PS57 CLI DEFSW,ON 59160015 BC BE,PS51 SKIP IF DEFINED 59200015 PS24 MVC PAR1+2(2),CREF 59240015 BALR RR,RL GET MINOR STRUCTURE ENTRY 59280015 L RD,PAR1 59320015 TM 0(RD),X'10' 59360015 BC BO,SP94 BRANCH IF STRUCTURE DIMENSIONED 59400015 MVC CLEVEL+1(1),FSSSTI+1(RD) SET CLEVEL 59440015 MVC CREF(2),FSSSTI+2(RD) SET REF TO CONTAINING STRUCTURE 59480015 MVC SREF(2),FSSSTI+4(RD) SET REF TO NEXT STRUCTURE ITEM 59520015 MVC FSSSTI+7(3,RD),ACC+1 SET MINOR STRUCTURE SIZE IN DE 59560015 BC B,SP97 59600015 SP94 MVC CLEVEL+1(1),FSDSTI+1(RD) SET CLEVEL 59640015 MVC CREF(2),FSDSTI+2(RD) SET REF TO CONTAINING STRUCTURE 59680015 MVC SREF(2),FSDSTI+4(RD) SET REF TO NEXT STRUCTURE MEMBER 59720015 MVC FSDSTI+7(3,RD),ACC+1 SET MINOR STRUCTURE SIZE IN DE 59760015 EJECT 59800015 * PROCESS STRUCTURE - ADD ADJACENT STRUCTURE OFFSET 59840015 * 59880015 * FUNCTIONS (1) TO ADD THE OFFSET FROM THE START OF THE 59920015 * PRECEDING MINOR STRUCTURE TO THE START OF THE PRESENT MINOR 59960015 * STRUCTURE INTO EACH PARTIAL OFFSET SUM OF EACH BASE ELEMENT 60000015 * OF THE PRESENT MINOR STRUCTURE. 60040015 * (2) FOR THE MAJOR STRUCTURE, TO CONVERT THE 60080015 * FINAL COMPLETE OFFSET INTO A BYTE LENGTH AND BIT OFFSET. 60120015 * 60160015 * ENTRY POINT - SP97 FROM ALIGN ADJACENT STRUCTURE ROUTINE 60200015 * 60240015 * EXTERNAL ROUTINE - ZDRFAB. 60280015 * 60320015 * EXIT POINTS - NORMAL (1) TO SP96 TO GENERATE PARALLEL 60360015 * OBJECT CODE. 60400015 * (2) TO PS24 IN STACK MINOR 60440015 * STRUCTURE ROUTINE. 60480015 * (3) TO SP42 IN STACK MINOR 60520015 * STRUCTURE ROUTINE. 60560015 * (4) TO PS51 IN THE TERMINATE 60600015 * ROUTINE IF A MAJOR STRUCTURE 60640015 * 60680015 * EXITS - ERROR - NONE. 60720015 SPACE 2 60760015 SP97 MVC PAR1+2(2),SREF 60800015 BALR RR,RL GET ADDRESS OF NEXT MEMBER 60840015 L RD,PAR1 60880015 LR RC,RD 60920015 TM 0(RD),X'0F' 60960015 BC BNO,PS41 BRANCH IF NOT A DATA ITEM 61000015 LA RC,6(RC) BUMP POINTER 61040015 CLI MAJSW,ON 61080015 BC BNE,PS41 BRANCH IF NOT MAJOR STRUCTURE 61120015 MVI VARYSW,OFF 61160015 MVI BITSW,OFF 61200015 TM FDDATA(RD),X'80' 61240015 BC BO,PS41 SKIP IF NOT A STRING 61280015 TM FDDATA(RD),X'24' 61320015 BC BNZ,*+8 SKIP IF NOT A PACKED BIT STRING 61360015 MVI BITSW,ON 61400015 TM FDDATA(RD),X'02' 61440015 BC BO,*+12 BRANCH IF AREA 61480015 TM FDDATA(RD),X'10' 61520015 BC BZ,PS41 BRANCH IF NOT VARYING 61560015 TM 0(RD),X'10' 61600015 BC BZ,PS41 BRANCH IF SCALAR STRING 61640015 MVC N+1(1),FDDIMI(RD) SET N 61680015 MVI VARYSW,ON 61720015 SPACE 61760015 PS41 TM 0(RD),X'10' 61800015 BC BNO,*+8 61840015 LA RC,3(RC) BUMP POINTER IF DIMENSIONED 61880015 MVC SREF1(2),FSSSTI+4(RC) SET REF TO NEXT MEMBER 61920015 TM 0(RD),X'0F' 61960015 BC BO,*+12 BRANCH IF DATA 62000015 TM 0(RD),X'0E' 62040015 BC BO,SP98 BRANCH IF STRUCTURE 62080015 MVC DVOFF1(2),FSSSTI+7(RC) SET DOPE VECTOR OFFSET 62120015 TM 0(RD),X'10' 62160015 BC BO,PS9 BRANCH IF STRUCTURE DIMENSIONED 62200015 SPACE 62240015 MVC 1(3,RS),5(RD) *** ADD ACC1 INTO DIC ENTRY 62280015 L RB,0(RS) 62320015 LA RB,0(RA,RB) CLEAR TOP BYTE AND ADD ACC1 62360015 CLI MAJSW,ON 62400015 BC BE,PS10 BRANCH IF MAJOR STRUCTURE 62440015 PS12 ST RB,0(RS) 62480015 MVC 5(3,RD),1(RS) SET BIT LENGTH IN DICTIONARY 62520015 BC B,PS11 62560015 SPACE 62600015 PS10 CLI DEFSW,ON 62640015 BC BE,PS12 BRANCH IF DEFINED 62680015 LR RE,RB *** MAJOR STRUCTURE 62720015 SRL RB,3 CONVERT TO BYTE AND BIT OFFSET 62760015 SLL RE,5 62800015 STC RE,15(RC) SET BIT OFFSET IN DICTIONARY 62840015 BC B,PS12 62880015 SPACE 62920015 PS9 MVC PAR1+2(2),FSDIMI-2(RC) *** ADD ACC1 TO VIRTUAL ORIGIN 62960015 BALR RR,RL 63000015 L RD,PAR1 63040015 L RB,8(RD) LOAD VIRTUAL ORIGIN SUM 63080015 AR RB,RA ADD ACC1 63120015 CLI MAJSW,ON 63160015 BC BE,PS8 BRANCH IF MAJOR STRUCTURE 63200015 PS54 ST RB,8(RD) STORE VIRTUAL ORIGIN SUM 63240015 BC B,PS11 63280015 SPACE 63320015 PS8 CLI DEFSW,ON 63360015 BC BE,PS54 BRANCH IF DEFINED 63400015 SRDL RB,3 SET BYTE VIRTUAL ORIGIN 63440015 ST RB,8(RD) 63480015 SRL RC,24 63520015 STC RC,8(RD) SET BIT OFFSET 63560015 PS11 CLC SREF(2),LREF 63600015 BC BNE,SP98 BRANCH IF NOT END OF STRUCTURE 63640015 CLI MAJSW,ON 63680015 BC BE,PS51 BRANCH IF MAJOR STRUCTURE 63720015 BC B,SP42 63760015 SP98 MVC SREF(2),SREF1 63800015 BC B,SP97 63840015 EJECT 63880015 * PROCESS STRUCTURE - STACK MINOR STRUCTURE ROUTINE. 63920015 * 63960015 * FUNCTIONS - TO STACK THE ACCUMULATED LENGTH, MAXIMUM 64000015 * BOUND, DIMENSIONALITY OF THE CONTAINING STRUCTURE, AND OFFSET 64040015 * FROM THE PRECEDING MAXIMUM BOUND TO THE START OF THE 64080015 * STRUCTURE. IF THE ACCUMULATED LENGTH IS UNKNOWN AT COMPILE 64120015 * TIME, CODE IS GENERATED TO DO IT AT OBJECT TIME. 64160015 * 64200015 * ENTRY POINTS (1) SP42 FROM ADD ADJACENT STRUCTURE OFFSET 64240015 * IF NON ADJUSTABLE. 64280015 * 64400015 * EXTERNAL ROUTINES - NONE. 64440015 * 64480015 * EXIT POINTS - NORMAL (1) TO SP3 IN ALIGN STRUCTURE 64520015 * MULTIPLIERS IF MORE CONTAINING STRUCTURES NEED TO BE PROCESSED 64560015 * (2) TO PS6 IN STACK STRUCTURE 64600015 * ELEMENT IF THE NEXT UNSCANNED ELEMENT IS A STRUCTURE. 64640015 * (3) TO SP4 IN PROCESS BASE ELEMENT 64680015 * IF THE NEXT UNSCANNED MEMBER IS A BASE ELEMENT. 64720015 * 64760015 * EXITS - ERROR - NONE. 64800015 SPACE 2 64840015 SP42 A RA,ACC ADD CURRENT ACC TO ACC1 64880015 SH RA,OFFSET SUBTRACT OFFSET (WHICH IS 64920015 AH RA,OFFST1 INCLUDED IN ACC) 64960015 MVC OFFSET(2),OFFST1 SET OFFSET=OFFSET1 65000015 LH RC,BOUND 65120015 CH RC,MAXBND 65160015 BC BNH,*+8 SET MAXBOUND IF STACKED VALUE 65200015 STH RC,MAXBND GREATER THAN PRESENT VALUE 65240015 LH RC,SLEVEL 65280015 CH RC,CLEVEL PROCESS NEXT CONTAINING 65320015 BC BNE,SP3 STRUCTURE IF CLEVEL NOT=SLEVEL 65360015 MVI FESW,OFF SET FIRST ELEMENT SWITCH OFF 65520015 MVC PAR1+2(2),DREF 65560015 BALR RR,RL GET NEXT STRUCTURE MEMBER 65600015 L RD,PAR1 65640015 TM 0(RD),X'0F' 65680015 BC BO,*+12 BRANCH IF DATA 65720015 TM 0(RD),X'0E' 65760015 BC BO,PS6 BRANCH IF STRUCTURE 65800015 LR RC,RD 65840015 TM 0(RD),X'0F' 65880015 BC BNO,*+8 65920015 LA RC,6(RC) BUMP POINTER IF DATA ITEM 65960015 TM 0(RD),X'10' 66000015 BC BZ,SP4 66040015 LA RC,3(RC) BUMP POINTER IF DIMENSIONED 66080015 BC B,SP4 EXAMINE BASE ELEMENTS 66120015 EJECT 66160015 * PROCESS STRUCTURE - TERMINATE ROUTINE 66200015 * 66240015 * FUNCTIONS (1) SETS THE OFFSET FROM THE NEAREST PRECEDING 66280015 * MAXIMUM ALIGNMENT BOUNDARY TO THE MAJOR STRUCTURE START AND 66320015 * THE MAXIMUM ALIGNMENT IN THE MAJOR STRUCTURE ENTRY. 66360015 * (2) TRANSFERS CONTROL TO (A) VARYING STRING 66400015 * ROUTINE, SVARY, (B) DEFINED ROUTINE, INDEF, OR (C) RETURNS 66440015 * CONTROL TO CHNSCN AS APPROPRIATE. 66480015 * 66520015 * ENTRY POINT - PS51 FROM ADD ADJACENT STRUCTURE OFFSET. 66560015 * 66600015 * EXTERNAL ROUTINES (1) ZDRFAB. 66640015 * (2) SVARY IN IEMJL, TO INITIALIZE 66680015 * DOPE VECTORS FOR VARYING STRINGS. 66720015 * 66760015 * EXIT POINTS - NORMAL (1) RETURN TO CHNSCN, IN IEMJL. 66800015 * (2) TO INDEF IN IEMJM TO INITIALIZE 66840015 * THE DOPE VECTORS OF DEFINED ARRAYS. 66880015 * 66920015 * EXIT POINTS - ERROR - NONE. 66960015 SPACE 2 67000015 PS51 MVC PAR1+2(2),AREF 67040015 BALR RR,RL GET MAJOR STRUCTURE ADDRESS 67080015 L RD,PAR1 67120015 SPACE 1 I1 67125016 CLI CLASS,STATIC I1 67130016 BC BNE,PS63 BRANCH IF NOT STATIC I1 67135016 NI FDOT4B(RD),X'F7' SET BIT TO SHOW PACKED I1 67140016 CLI CNTGSW,ON I1 67145016 BC BE,PS63 BRANCH IF STR HAS PACK BIT STR I1 67150016 OI FDOT4B(RD),X'08' I1 67155016 SPACE 67160015 PS63 TM CLASS,STYPE 67200015 BC BNM,PS52 BRANCH IF NOT DYNAMIC 67240015 CLI ADJ1SW,ON 67280015 BC BE,PS53 ADJUSTABLE BASED STRUCTURE 67320015 TM FDVARB(RD),X'02' 67360015 BC BO,PS52 BRANCH IF BASED 67400015 MVC ACC1(4),ACC 67420015 L RF,ACC *** CONTROLLED 67440015 BAL RR,SETDVS SET DOPE VECTOR FOR DYNAMIC 67480015 SR RB,RB 67520015 STH RB,OFFSET CLEAR OFFSET 67560015 CLI COBLSW,ON 67570015 BC BE,PS53A MAKE RDV FOR COBOL STR 67580015 BC B,PS53 67600015 SPACE 67640015 PS52 L RA,ACC *** NOT CONTROLLED 67680015 SH RA,OFFSET 67720015 ST RA,ACC 67760015 TM FDOT4B(RD),RDVBIT 67800015 BC BZ,*+12 67840015 NI FDOT1B(RD),X'EF' SET DVD BIT OFF 67880015 BAL RR,RDV1 SET RDV ENTRY 67920015 SPACE 67960015 SPACE 68000015 PS53 LA RC,FSSSTI(RD) 68040015 TM 0(RD),X'10' 68080015 BC BZ,*+8 BRANCH IF NOT DIMENSIONED 68120015 LA RC,3(RC) SET POINTER TO STRUCTURING 68160015 MVC 2(1,RC),OFFSET+1 SET OFFSET FROM BOUNDARY 68200015 CLC MAXBND(2),C1 BIT STRUCTURES 31708 68208020 BNE PS55 MUST BE 31708 68216020 MVC MAXBND(2),C8 BYTE ALIGNED 31708 68224020 PS55 EQU * 31708 68232020 MVC 6(1,RC),MAXBND+1 SET ALIGNMENT 68240015 CLI ADJ1SW,ON 68280015 BC BE,PS38A ADJUSTABLE BASED STRUCTURE 68320015 MVC 7(3,RC),ACC+1 SET STRUCTURE LENGTH 68360015 PS16 TM CLASS,STYPE 68400015 BC BZ,PS39 BRANCH IF STATIC STORAGE 68440015 BAL RR,SVARY CHECK STRUCTURE FOR VARYING 68480015 PS39 CLI COBLSW,ON 68520015 BC BE,PS38 BRANCH IF COBOL STRUCTURE 68560015 L RB,ZUERR 68580015 NC TASKSW(1),RDVSW MERGE SWITCHES 68600015 BC BZ,PS38B 68620015 SPACE 68640015 MVC PAR6(4),MESS5 GENERATE ERROR MESSAGE 68660015 MVC PAR7+2(2),AREF 68680015 BALR RR,RB 68700015 SPACE 68720015 PS38B NC V1SW(1),RDVSW 68740015 BC BZ,PS38 68760015 SPACE 68780015 MVC PAR6(4),MESS3 GENERATE ERROR MESSAGE 68800015 MVC PAR7+2(2),AREF 68820015 BALR RR,RB 68880015 BC B,PS38 68920015 SPACE 68960015 PS38A NI FDOT4B(RD),X'FE' SET RDV BIT OFF 69000015 BAL RR,MKDVD MAKE DVD 69040015 LA RC,FSSSTI(RD) 69046015 TM 0(RD),X'10' 69052015 BC BZ,*+8 69058015 LA RC,3(RC) 69064015 BAL RR,SVARY 69070015 SPACE 69080015 PS38 MVC PAR1+2(2),AREF 69090015 BALR RR,RL RESTORE ENTRY 69100015 L RD,PAR1 69110015 SR RS,R4 AND RETURN 69120015 L RR,0(RS) 69160015 BCR B,RR 69260015 SPACE 69360015 PS53A MVC ACC2(4),ACC 69460015 MVC ACC(4),ACC1 69560015 BAL RR,RDV1 MAKE AN RDV FOR THE TENP 69660015 MVC ACC(4),ACC2 69760015 BC B,PS53 69860015 EJECT 70600015 * ADJUSTABLE ROUTINE 70640015 SPACE 70680015 SP5 MVI VARYSW,OFF *** ADJUSTABLE ROUTINE 70720015 NC MAXLVL(2),MAXLVL 70760015 BC BNZ,*+8 BRANCH IF MAXLVL IS SET 70800015 MVI MAXLVL+1,1 SET TO 1 TO SET 8 BYTES 70840015 BAL RR,INOBJ INITIALIZE OBJECT CODE 70880015 CLI CLASS,TMP2 70920015 BC BNE,MP1 BRANCH IF NOT TEMP TYPE2 70960015 SPACE 71000015 MP21A BAL RR,RDV2 MAKE RDV I4A 71020016 MVI SUPRDV,ON I4A 71040016 MP21 MVI ADJSW,ON 71080015 MVI DVDFLG,ON 71120015 BAL RR,MKDVD MAKE DVD 71160015 MVI DVDFLG,OFF 71200015 SPACE 71240015 MVC MP5(2),MCOBOL 71280015 CLI COBLSW,ON 71320015 BC BE,MP2 BRANCH IF COBOL 71360015 MVC MP5(2),MPL1 71400015 SPACE 71440015 MP2 MVC MP6(2),DREF1 SET UP LIBRARY CALL TO MAP 71480015 MVC MP7(2),RREF ROUTINE 71520015 MVC MP8(2),VREF 71560015 LA RE,MP9 71600015 LA RF,MP10-MP9 71640015 BAL RR,CMPIL1 71680015 SPACE 71720015 CLI DIMSW,ON 71760015 BC BE,DP5 LEAVE ROUTINE IF ARRAY 71800015 SPACE 71840015 MP11 TM CLASS,STYPE *** VARYING DV SIZE CALCULATED 71880015 BC BNM,MP15 BRANCH IF NOT TEMP OR CTL 71920015 SPACE 71960015 BAL RR,STDVS1 SET DOPE VECTOR SIZE 72000015 BC B,MP22 72040015 SPACE 72080015 MP15 MVC BOUND(2),MAXBND *** GENERATE ACCUMULATOR ALIGN 72120015 CLI DEFSW,ON 72160015 BC BE,PS38 72200015 BAL RR,ALVACA CODE. 72240015 SPACE 72280015 MP22 MVC NREF(2),AREF SCAN FOR VARYING ARRAYS 72320015 BAL RR,NXTRF1 GET MAJOR STRUCTURE REF 72360015 MP23 BC B,MP19 END OF STRUCTURE 72400015 SPACE 72440015 MP14 TM 0(RD),X'1F' 72480015 BC BNO,MP12 BRANCH IF NOT DATA ARRAY 72520015 TM FDDATA(RD),X'80' 72560015 BC BO,MP12 BRANCH IF NOT STRING 72600015 MVC N+1(1),FDDIMI(RD) 72640015 MVC DVOFF1(2),FSSSTI+7(RC) SET DOPE VECTOR OFFSET 72680015 TM FDDATA(RD),X'10' 72720015 BC BZ,MP12 72740015 BAL RR,MP13 CREATE SDV CODE 72760015 SPACE 72800015 MP12 LA RR,MP23 72840015 BC B,NXTREF GET NEXT BASE ELEMENT 72880015 SPACE 72920015 MP19 MVC PAR1+2(2),AREF 72960015 BALR RR,RL 73000015 L RD,PAR1 GET MAJOR STRUCTURE 73040015 LA RC,FSSSTI(RD) 73080015 TM 0(RD),X'10' 73120015 BC BZ,*+8 SKIP IF NOT DIMENSIONED 73160015 LA RC,3(RC) BUMP POINTER 73200015 BAL RR,SVARY SET VARYING ARRAY CODE 73240015 BC B,PS39 EXIT 73280015 SPACE 73320015 MP1 MVC PAR1+2(2),AREF 73360015 BALR RR,RL GET DICTIONARY ENTRY 73400015 L RD,PAR1 73440015 SPACE 73480015 CLI CLASS,CONTRL *** NON TEMP 73520015 BC BE,MP20 BRANCH IF CONTROLLED 73560015 TM 0(RD),X'20' I4A 73610016 BC BO,MP21A BRANCH IF STRUCTURE I4A 73660016 TM FDOT4B(RD),RDVBIT I4A 73710016 BC BO,MP21A BRANCH IF RDV REQUIRED I4A 73760016 SPACE 1 I4A 73810016 MP20 MVC RREF(2),TREF *** RDV NOT REQUIRED. SET WORK I4A 73860016 BC B,MP21 SPACE REFERENCE 73920015 EJECT 73960015 MKDVD ST RR,SAVE 74000015 SPACE 74040015 XC DVOFF(2),DVOFF 74080015 XC MAXBND(2),MAXBND 74120015 MVC ZLOCK(2),AREF LOCK IN MAJOR STRUCTURE 74160015 NI BS6+1,X'0F' SET BRANCH TO NOP 74180015 SPACE 74200015 MVC PAR1+2(2),AREF 74240015 BALR RR,RL 74280015 SPACE 74320015 L RD,PAR1 SET RD TO POINT TO STRUCTURE 74360015 OI FDOT1B(RD),X'10' SET DVD BIT ON 74400015 ST RD,MAJSTR SAVE ABSOLUTE POINTER 74440015 SPACE 74480015 L RC,STCKPT POINT TO START OF SCRATCH 74520015 LA RC,12(0,RC) BUMP TO FIRST DVD SLOT 74560015 ST RC,DVDST SAVE 74600015 ST R4,0(RC) CLEAR TOP TWO BYTES OF SLOT 74640015 SPACE 74680015 TM 0(RD),X'20' IS THIS A STRUCTURE 74720015 BC BO,STR3 BRANCH IF SO 74760015 SPACE 5 74800015 * ITEM REQUIRING A DVD IS NOT A STRUCTURE 74840015 SPACE 74880015 MVI 0(RC),X'C1' SET BASE ELEMENT AND END OF 74920015 * STRUCTURE FLAGS AND SET STRUCTURE 74960015 * LEVEL TO 1. 75000015 TM 0(RD),X'10' 75040015 BC BO,STR7 75080015 MVI 1(RC),X'00' 75120015 BC B,BS2 75160015 STR7 LR RR,RD 75200015 TM 0(RD),X'0F' 75240015 BC BNO,*+8 75280015 LA RR,6(RR) 75320015 TM FDVARB(RD),X'80' 75360015 BC BNO,*+8 75400015 LA RR,4(RR) 75440015 MVC 1(1,RC),15(RR) 75480015 BC B,BS2 75520015 STR2 MVC PAR1+2(2),NXTSTR(RA) PICK UP POINTER TO NEXT STRUCT- 75560015 * URE. 75600015 SPACE 75640015 BALR RR,RL CONVERT IT TO ABSOLUTE 75680015 L RD,PAR1 75720015 SPACE 75760015 AR RC,R4 BUMP SCRATCH POINTER TO NEXT 75800015 ST R4,0(RC) DVD SLOT CLEAR TOP BYTES 75840015 SPACE 75880015 TM 0(RD),X'0F' 75920015 BC BO,BASE BRANCH IF DATA 75960015 TM 0(RD),X'0E' 76000015 BC BNO,BASE BRANCH IF LABEL EVENT TASK 76040015 SPACE 2 76080015 STR3 LA RA,STRINF(0,RD) SET RA TO DIMENSION OR STRUCTURE 76120015 LA RR,STR4 INFORMATION. SET RETURN REG. 76160015 * THE NUMBER OF DIMENSIONS AND STRUCTURE LEVEL ARE NOW 76200015 * MOVED INTO THE DVD ENTRY. 76240015 LANDN TM VAR(RD),DIMS IS ITEM DIMENSIONED 76280015 BC BZ,NODIMS BRANCH IF NOT 76320015 MVC 1(1,RC),0(RA) MOVE NO. OF DIMS INTO DVD. 76360015 LA RA,3(0,RA) POINT TO STRUCTURE INFORMATION 76400015 SPACE 76440015 NODIMS IC RB,TL(0,RA) PICK UP STRUCTURE LEVEL 76480015 STC RB,0(0,RC) STORE IN DVD 76520015 BCR B,RR 76560015 * THE OFFSET IN THE DVD OF THE CONTAINING STRUCTURE'S SLOT 76600015 * IS NOW FOUND. 76640015 STR4 C RC,DVDST IS THIS THE MAJOR STRUCTURE 76680015 BC BNE,STR4A BRANCH IF NOT. 76720015 MVC 2(2,RC),CM1 OTHERWISE SET SLOT TO X'FFFF' 76760015 BC B,STR2 RETURN FOR NEXT MEMBER OF STRUC. 76800015 SPACE 76840015 STR4A BCTR RB,0 REDUCE RB TO LEVEL OF CONTAINING 76880015 STC RB,STR5+1 STRUCTURE. MODIFY LATER INSTRUCT. 76920015 * SET UP REGISTERS FOR BXH LOOP 76960015 LCR RE,R4 INCREMENT=-4 (REVERSE SCAN) 77000015 LA RB,0(RC,RE) MOVING POINTER 77040015 L RF,DVDST END OF SCAN 77080015 SPACE 77120015 STR5 CLI 0(RB),0 IS RB POINTING AT SLOT FOR 77160015 BC BE,STR6 CONTAINING LEVEL (IMMEDIATE FIELD 77200015 BXH RB,RE,STR5 SET UP EALIER) 77240015 BC B,ERROR 77280015 SPACE 77320015 * RB IS POINTING AT SLOT FOR 77360015 STR6 SR RB,RF CONTAINING STRUCTURE. COMPUTE 77400015 STH RB,2(0,RC) OFFSET 77440015 CLI DVDFLG,OFF 77480015 BC BE,STR2 77520015 SPACE 77560015 CLI ADJSW,ON IF BOTH ADJSW AND DONSW ARE ON 77600015 BC BNE,STR2 THEN SET ELEMENT LENGTH SLOT TO 77640015 CLI DONSW,ON X'FFFFFF'. OTHERWISE, RETURN TO 77680015 BC BNE,STR2 PROCESS NEXT MEMBER OF STRUCTURE 77720015 MVC 7(3,RA),CMAXSZ+1 77760016 BC B,STR2 77800015 SPACE 10 77840015 BASE LA RA,15(RD) 77850015 TM 0(RD),X'0F' 77860015 BC BNO,*+8 BRANCH IF NOT DATA 77870015 LA RA,6(RA) 77880015 SPACE 77890015 CLI COBLSW,ON 77900015 BC BNE,*+10 BRANCH IF NOT COBOL 77910015 MVC 2(2,RA),DVOFF SET UP DV OFF SET 77920015 LA RA,4(RA) 77930015 SPACE 77940015 BAL RR,LANDN GO TO FIND STRUC. LEVEL AND NO. 78040015 MVC 7(2,RA),DVOFF OF DIMS. INSERT OFFSET IN D.V. 78080015 BS2 BAL RR,ELSIZ CALCULATE ELEMENT LENGTH 78120015 BC B,*+4 TO ALLOW FOR BOTH RETURNS FROM 78160015 * ELSIZ 78200015 SPACE 78240015 BS6 BC B,BS7 SKIP ROUND CODE 78250015 OI BS6+1,X'F0' CHANGE BRANCH BACK 78260015 MVC FRSTBD(2),BOUND 78270015 SPACE 78280015 BS7 OI 0(RC),X'80' SET BASE ELEMENT BIT 78290015 LH RB,BOUND 78320015 BCTR RB,0 78360015 STC RB,2(RC) SET ALIGNMENT 78400015 SPACE 78440015 CLC MAXBND+1(1),BOUND+1 78480015 BC BH,*+10 78520015 MVC MAXBND+1(1),BOUND+1 78560015 TM 0(RD),X'0F' 78600015 BC BNO,BS5 BRANCH IF LABEL EVENT TASK 78640015 TM FDDATA(RD),X'80' 78680015 BC BZ,BS4 BRANCH IF STRING 78720015 SPACE 78760015 BS5 MVC 3(1,RC),LENGTH+3 SET ELEMENT SIZE 78800015 TM 0(RD),X'0F' 78805015 BC BO,BS3 BRANCH IF DATA 78810015 TM 0(RD),X'0D' 78815015 BC BNO,BS3 BRANCH IF NOT EVENT 78820015 MVI 3(RC),X'FF' 78825015 OI 1(RC),X'40' SET EVENT BIT 78830015 BC B,BS3 78840015 BS4 MVI 3(RC),X'00' *** STRING. SET LENGTH TO ZERO 78880015 TM FDDATA(RD),X'02' 78920015 BC BZ,*+8 BRANCH IF NOT AREA 78960015 OI 1(RC),X'80' SET AREA FLAG 79000015 TM FDDATA(RD),X'10' 79040015 BC BZ,*+8 SKIP IF NOT VARYING 79080015 OI 2(RC),X'40' SET VARYING FLAG 79120015 TM FDDATA(RD),4 79160015 BC BO,BS3 BRANCH IF NOT BIT STRING 79200015 TM FDDATA(RD),X'20' 79240015 BC BZ,BS3 BRANCH IF NOT ALIGNED 79280015 OI 2(RC),X'80' SET ALIGNED BIT STRING FLAG 79320015 SPACE 79360015 BS3 SR RB,RB CALCULATE DOPE VECTOR SIZE 79400015 IC RB,1(0,RC) 79440015 N RB,ARAMSK 79480015 SLL RB,3 79520015 AR RB,R4 79560015 AH RB,DVOFF 79600015 STH RB,DVOFF 79640015 TM FDVARB(RD),X'20' 79680015 BC BZ,DVDCOM BRANCH IF NOT STRUCTURE 79720015 SPACE 79760015 TM OTHER1(RD),EOS IS THIS THE END OF THE STRUCTURE 79800015 BC BZ,STR2 IF NOT, CONTINUE STRUCTURE SCAN. 79840015 OI 0(RC),X'40' OTHERWISE, SET END OF STRUCTURE 79880015 * BIT IN DVD. 79920015 L RD,MAJSTR 79960015 CLI DVDFLG,OFF 80000015 BC BE,DVDCOM 80040015 LR RA,RD 80080015 TM VAR(RD),DIMS 80120015 BC BZ,*+8 80160015 LA RA,3(0,RA) 80200015 MVC STRINF+6(1,RA),MAXBND+1 SET UP STRONGEST BOUNDARY IN 80240015 * ALIGNMENT SLOT OF MAJOR STRUCTURE 80280015 CLI ADJSW,ON 80320015 BC BNE,DVDCOM 80360015 CLI DONSW,ON 80400015 BC BNE,DVDCOM 80440015 MVC STRINF+7(3,RA),CMAXSZ+1 80480016 SPACE 5 80520015 * THE DVD IS NOW COMPLETED BY SETTING UP THE 12 INITIAL 80560015 * BYTES. 80600015 SPACE 80640015 DVDCOM L RB,STCKPT RESET RC TO START OF DVD 80680015 MVI 0(RB),DVD MOVE IN CODE BYTE 80720015 XC 5(3,RB),5(RB) CLEAR OFFSET ELOT 80760015 MVC 8(2,RB),AREF INSERT POINTER TO STRUCTURE OR 80800015 * ARRAY. 80840015 MVC 10(2,RB),DN(RD) MOVE POINTER TO RDV (IF ANY) 80880015 * FROM DECLARE NUMBER SLOT 80920015 SR RC,RB COMPUTE LENGTH 80960015 AR RC,R4 81000015 ST RC,PAR2 81040015 ST RB,PAR1 PASS ADDRESS 81080015 MVC 1(2,RB),PAR2+2 LENGTH AND 81120015 MVC 3(2,RB),ZSTACH+4 HEAD OF CHAIN INTO ENTRY 81160015 SPACE 81200015 L RR,ZDICRF 81240015 BALR RR,RR 81280015 SPACE 81320015 LH RB,PAR1+2 STORE REFERENCE OF DVD IN - 81360015 STH RB,ZSTACH+4 HEAD OF STATIC 81400015 STH RB,DN(0,RD) DECLARE NUMBER SLOT OF ASSOCIAT- 81440015 STH RB,VREF ED ITEM 81480015 MVI ZLOCK,0 CLEAR SYMBOLIC NAME IN ZLOCK 81520015 L RR,SAVE 81560015 BCR B,RR 81600015 SPACE 5 86880015 * RB POINTS TO BASE ITEM DIMENSION TABLE 87680017 * RD POINTS TO DEFINED ITEM DIMENSION TABLE 88480017 SPACE 89280017 MOVEMP LH RE,N 90080017 LR RF,RE 90880017 SLA RE,3 8 * N 91680017 SLA RF,2 4 * N 92480017 BCTR RF,0 93280017 STC RF,CD11A+1 94080017 LA RB,12(RB,RE) POINT AT BASE ITEM MULTIPLIERS 94880017 LA RD,12(RD,RE) 95680017 CD11A MVC 0(1,RD),0(RB) CPY MULTIPLIERS ACROSS 96480017 BCR B,RR 97280017 EJECT 97290001 * STORAGE PRIVATE TO MODULE JK 97300001 * THIS STORAGE SPACE HAS BEEN MOVED FROM MODULE JJ TO MAKE 97310001 * SPACE ON JJ FOR CHANGES FOR VERSION 5. 97320001 SPACE 3 97330001 * WORD STORAGE 97340001 SPACE 1 97350001 LBOUND DS F 97360001 HBOUND DS F 97370001 RESLOT DS F 97380001 CMAXSZ DC X'00FFFFFF' 42010 97390021 SPACE DC X'00FFFFFF' AMOUNT OF SPACE LEFT 97395056 CMINSZ DC X'F8000000' 97400001 ARAMSK DC X'FFFFFF7F' 97410001 SAVE DS 1F SAVE RETURN REGISTER 97420001 MAJSTR DS 1F ADDRESS OF MAJOR STRUCTURE 97430001 DVDST DS 1F ADDRESS OF FIRST DVD SLOT 97440001 ACC1 DS 1F 97450001 ACC2 DS 1F 97460001 LNGTH1 DS 1F 97470001 SPACE 2 97480001 * HALFWORD STORAGE 97490001 SPACE 1 97500001 OFFST1 DS H 97510001 STKOFF DS H STACK OFFSET 97520001 CREF DS H REF TO CONTAIN STRUCTURE 97530001 SREF DS H SCAN REFERENCE 97540001 LREF DS H LAST REFERENCE 97550001 SREF1 DS H 97560001 CLEVEL DC H'0' 97570001 SLEVEL DC H'0' 97580001 ERROR DC H'0' 97590001 C1 DC H'1' 97600001 CM1 DC H'-1' 97610001 C3 DC H'3' 97620001 C5 DC H'5' 97630001 C8 DC H'8' 97640001 C32 DC H'32' 97650001 C4096 DC H'4096' 97660001 OMULTO DC H'15' 97670001 OMULTE DC H'14' 97680001 OZERO DC H'0' 97690001 ALGINC DS H 97700001 SPACE 2 97710001 * BYTE STORAGE 97720001 SPACE 1 97730001 USW DC X'00' 97740001 FESW DC X'00' 97750001 FSW DC X'00' 97760001 TASKSW DC X'00' 97770001 LOWSW DC X'00' 97780001 RDVSW DC X'00' 97790001 DVDFLG DC X'00' 97800001 MESS3 DC X'00044254' 97810001 MESS5 DC X'0004445C' 97820001 SPACE 10 97830001 LTORG 97840001 ORG IEMJK+4095 97850001 END IEMJK 98080017 ./ ADD SSI=20011362,NAME=IEMJL,SOURCE=0 JL TITLE 'IEMJL, STRUCTURE PROCESSOR, OS/360, PL/I COMPILER(F)' 00050015 * 00100015 * 22543 RLSE18 317500,349500 00120001 * 25903 RLSE19 483600,483700 25903 00130019 * H212 RLSE20 $416500 H212 00140000 * 00150015 * 00200015 * STATUS - CHANGE LEVEL 0 00250015 * 00300015 * 00350015 * FUNCTIONS - THIS MODULE CONTAINS A NUMBER OF SUBROUTINES 00400015 * USED IN PROCESSING STRUCTURES, ARRAYS, ADJUSTABLE STRINGS AND 00450015 * DEFINED ITEMS. THE FUNCTIONS OF THESE SUBROUTINES INCLUDE THE 00500015 * FOLLOWING- (1) SCANS THE STATIC, AUTOMATIC AND CONTROLLED 00550015 * CHAINS FOR DATA,LABEL AND STRUCTURE ITEMS, CALLING THE 00600015 * APPROPRIATE PROCESSING ROUTINES 00650015 * (2) SETS THE ENTRY TYPE1 REFERENCE FOR CONTROLLED 00700015 * ITEMS ACCORDING TO THE BLOCK IN WHICH THEY ARE ALLOCATED 00750015 * (3) GENERATES ALIGNMENT CODE FOR STRUCTURE ELEMENTS 00800015 * MINOR STRUCTURES AND MINOR STRUCTURE MULTIPLIERS. 00850015 * (4) GENERATES CODE TO CALCULATE ARRAY EXTENTS AND 00900015 * TO UPDATE ARRAY VIRTUAL ORIGINS. 00950015 * (5) GENERATES CODE TO LOAD CONSTANTS KNOWN AT 01000015 * COMPILE TIME INTO OBJECT REGISTERS. 01050015 * (6) ADDS TEXT SKELETONS TO THE OUTPUT TEXT 01100015 * (7) SETS UP OUTPUT TEXT POINTERS AND ADDS 01150015 * SECOND FILE STATEMENT MARKERS TO THE OUT PUT 01200015 * (8) MARKS THE AMOUNT OF WORKSPACE REQUIRED FOR 01250015 * PROCESSING ADJUSTABLE STRUCTURES IN THE ENTRY TYPE1 WORKSPACE 01300015 * DICTIONARY ENTRY 01350015 * (9) SCANS STRUCTURE ENTRIES FOR ARRAYS OF VARYING 01400015 * STRINGS. 01450015 * (10) GENERATES CODE TO INITIALIZE SECONDARY DOPE 01500015 * VECTORS FOR ARRAYS OF VARYING STRINGS. 01550015 * (11) GENERATES CODE TO ADD THE SIZE OF ADJUSTABLE 01600015 * STRINGS TO THE V.D.A. ACCUMULATOR REGISTER 01650015 * (12) GENERATES CODE TO ADD THE SIZE OF ADJUSTABLE 01700015 * (13) MAKES DICTIONARY ENTRIES FOR CONSTANTS. 01750015 * ARRAYS TO THE V.D.A ACCUMULATOR REGISTER 01800015 * (14) SETS THE LENGTH OF CODE GENERATED IN A JMP 01850015 * TRIPLE SURROUNDING THE GENERATED CODE. 01900015 * 01950015 * 02000015 * 02050015 * ENTRY POINTS - (1) SETBRF ENTERED WITH DICTIONARY 02100015 * ADDRESS IN RD SETS THE APPROPRIATE ENTRY TYPE1 REFERENCE, 02150015 * USING THE LEVEL AND COUNT OF THE DICTIONARY ENTRY 02200015 * (2) OALGS GENERATES CODE TO ALIGN TWO 02250015 * ADJACENT MINOR STRUCTURES. 02300015 * (3) OALGE GENERATES CODE TO ALIGN 02350015 * ADJACENT STRUCTURE BASE ELEMENTS. 02400015 * (4) OALGM GENERATES CODE TO ALIGN 02450015 * MINOR STRUCTURE MULTIPLIERS TO THE MAXIMUM BOUNDARY WITHIN 02500015 * THE MINOR STRUCTURE. 02550015 * (5) LOADLB GENERATES CODE TO CALCULATE 02600015 * INCREMENTS TO BE ADDED TO THE VIRTUAL ORIGINS OF BASE ELEMENTS 02650015 * OF MINOR STRUCTURES. 02700015 * (6) CMPLMT GENERATES OBJECT CODE TO 02750015 * COMPLEMENT A REGISTER 02800015 * (7) UPVO1 AND UPVO2 GENERATE OBJECT 02850015 * CODE TO UPDATE A VIRTUAL ORIGIN AT OBJECT TIME. 02900015 * (8) ADDCN, SUBCN AND LOADCN GENERATE 02950015 * CODE TO ADD, SUBTRACT OR LOAD A CONSTANT KNOWN AT COMPILE 03000015 * TIME INTO AN OBJECT REGISTER. 03050015 * (9) INOBJ AND INOBJ1 SET UP TEXT POINTERS 03100015 * TO THE CURRENT OUTPUT TEXT ON THE FIRST CALL, AND GENERATE 03150015 * SN3 STATEMENT MARKERS ON EVERY CALL. 03200015 * (10) OBJALG GENERATES CODE TO ALIGN BIT 03250015 * STRINGS IN STRUCTURES. 03300015 * (11) CMPIL1 AND CMPILE ADD TEXT SKELETONS 03350015 * TO THE OUTPUT TEXT. 03400015 * (12) TERMWS SETS THE AMOUNT OF STORAGE 03450015 * REQUIRE IN THE WORKSPACE DICTIONARY ENTRY FOR ADJUSTABLE 03500015 * STRUCTURES. 03550015 * (13) CHNSCN SCANS THE STATIC, CONTROLLED 03600015 * AND AUTOMATIC CHAINS FOR ITEMS WHICH REQUIRE PROCESSING. 03650015 * (14) SVARY SCANS THROUGH STRUCTURE 03700015 * DICTIONARY ENTRIES FOR ARRAYS OF VARYING STRINGS. 03750015 * (15) VOBJC GENERATES OBJECT CODE TO 03800015 * INITIALIZE THE SECONDARY DOPE VECTORS OF ARRAYS OF VARYING 03850015 * STRINGS. 03900015 * (16) ALVACA GENERATES OBJECT CODE TO 03950015 * ADD AN ADJUSTABLE ARRAY TO THE VDA ACCUMULATOR REGISTER, AND 04000015 * TO RELOCATE THE VIRTUAL ORIGIN OF THE ARRAY FROM THE START 04050015 * OF THE VDA. 04100015 * (17) BUMPER BUMPS THE COMPILER LABEL 04150015 * COUNT BY 1. 04200015 * (18) MKCNST MAKES CONSTANT DICTIONARY 04250015 * ENTRIES 04300015 * 04350015 * 04400015 * 04450015 * INPUT - DICTIONARY 04500015 * 04550015 * 04600015 * 04650015 * OUTPUT - TEXT STATEMENTS IN THE SECOND FILE FOR LATER 04700015 * INCLUSION IN PROLOGUES, ALLOCATE STATEMENTS AND BUY STATEMENTS 04750015 * 04800015 * 04850015 * 04900015 * EXTERNAL ROUTINES (1) COMPILER CONTROL ROUTINES AS 04950015 * LISTED IN IEMJK. 05000015 * (2) PROCST IN IEMJK PROCESSES 05050015 * STRUCTURES 05100015 * (3) PROCDT IN IEMJM PROCESSES ARRAYS 05150015 * (4) CHKDEF IN IEMJM PROCESSES 05200015 * DEFINED ITEMS 05250015 * (5) IPDV IN IEMJM GENERATES CODE TO 05300015 * RESET THE PRIMARY DOPE VECTORS OF ARRAYS OF VARYING STRINGS 05350015 * TO REFER TO THE SECONDARY DOPE VECTORS. 05400015 * (6) SETDVS IN IEMJM CALCULATES THE 05450015 * TOTAL STORAGE REQUIRED FOR DYNAMIC ALLOCATIONS OF ARRAYS AND 05500015 * STRUCTURES. 05550015 * (7) STDVS1 IN IEMJM GENERATES CODE 05600015 * TO CALCULATE THE TOTAL STORAGE REQUIRED FOR DYNAMIC 05650015 * ALLOCATIONS OF AJUSTABLE STRUCTURES AND ARRAYS. 05700015 * 05750015 * 05800015 * 05850015 * EXITS - NORMAL - GENERALLY TO CALLING ROUTINE. CHNSCN 05900015 * PASSES CONTROL TO FINISH ROUTINE, WHICH RELEASES CONTROL TO 05950015 * COMPILER CONTROL. 06000015 * 06050015 * 06100015 * 06150015 * EXITS ERROR - N/A 06200015 * 06250015 * 06300015 * 06350015 * TABLES AND WORK AREAS - N/A 06400015 * 06450015 * 06500015 * 06550015 * ATTRIBUTES - N/A 06600015 EJECT 06650015 IEMJL START 0 06700015 USING *,10 06750015 SPACE 2 06800015 * BLOCK ADDRESSING PARAMETERS 06850015 SPACE 2 06900015 SPACE 06950015 USING *+X'1000',DIC 07000015 DB EQU *+X'1000' DICTIONARY BLOCK 07050015 USING *+X'2000',CC 07100015 CB EQU *+X'2000' CONTROL BLOCK 07150015 USING *+X'3000',9 07200015 B1 EQU *+X'3000' 07250015 USING *+X'4000',12 07300015 B3 EQU *+X'4000' 07350015 USING *+X'5000',R1 07400015 SCRACH EQU *+X'5000' 07450015 SPACE 2 07500015 B2 DC C'JL' 07550015 EJECT 07600015 * REGISTER PARAMETERS 07650015 SPACE 2 07700015 RA EQU 1 07750015 RB EQU 2 07800015 RC EQU 3 07850015 RD EQU 4 07900015 RE EQU 5 07950015 RF EQU 6 08000015 RS EQU 7 08050015 R1 EQU 8 08100015 R4 EQU 0 08150015 CC EQU 11 08200015 DIC EQU 13 08250015 RR EQU 14 08300015 RL EQU 15 08350015 SPACE 2 08400015 * PSEUDO CODE PARAMETERS 08450015 SPACE 2 08500015 DROP EQU X'06' 08550015 AH EQU X'92' 08600015 LA EQU X'A0' 08650015 BC EQU X'81' 08700015 LCR EQU X'40' 08750015 JMP EQU X'5B' 08800015 OSM1 EQU X'10' 08850015 ST EQU X'A5' 08900015 SR EQU X'4B' 08950015 LH EQU X'90' 09000015 SRL EQU X'78' 09050015 LR EQU X'48' 09100015 MR EQU X'4C' 09150015 AR EQU X'4A' 09200015 L EQU X'88' 09250015 STC EQU X'A4' 09300015 SRDL EQU X'77' 09350015 BCTR EQU X'44' 09400015 NR EQU X'45' 09450015 EQU EQU X'07' 09500015 A EQU X'8A' 09550015 S EQU X'8B' 09600015 SN3 EQU X'25' 09650015 MH EQU X'94' 09700015 EOB EQU X'ED' 09750015 SPACE 2 09800015 * DICTIONARY PARAMETERS 09850015 SPACE 2 09900015 DIMVAR EQU X'17' MASK FOR DIMENSIONED VARIABLE 09950015 STRUCT EQU X'2E' MASK FOR STRUCTURE 10000015 RDVBIT EQU X'01' RDV REQUIRED BIT 10050015 FSDIMI EQU 19 10100015 FSDSTI EQU 22 10150015 FSSSTI EQU 19 10200015 FDSYMI EQU 19 10250015 FDDATA EQU 15 10300015 FPWIDB EQU 11 10350015 FDOT1B EQU 10 10400015 FDVARB EQU 11 10450015 FDOT4B EQU 14 10500015 FDOT2B EQU 12 10550015 FSOFF2 EQU 15 10600015 VARBIT EQU X'40' 10650015 FPBIT EQU X'08' FORMAT PARAMETER BIT 10700015 DVDBIT EQU X'10' 10750015 SPACE 2 10800015 * MISCELLANEOUS PARAMETERS 10850015 SPACE 2 10900015 STATIC EQU X'00' STATIC STORAGE 10950015 CONTRL EQU X'80' CONTROLLED STORAGE 11000015 TMP2 EQU X'40' TEMPORARY TYPE 2 CLASS 11050015 AUTO EQU X'C0' AUTOMATIC STORAGE 11100015 STYPE EQU X'C0' TEST MASK FOR STORAGE TYPE 11150015 OFF EQU X'00' 11200015 ON EQU X'FF' 11250015 ADD EQU X'C0' 11300015 SUB EQU X'80' 11350015 LOAD EQU X'00' 11400015 OTYPE EQU X'C0' 11450015 SPACE 2 11500015 * CONDITION CODE PARAMETERS 11550015 SPACE 2 11600015 B EQU 15 11650015 BH EQU 2 11700015 BL EQU 4 11750015 BE EQU 8 11800015 BNH EQU 13 11850015 BNL EQU 11 11900015 BNE EQU 7 11950015 BP EQU 2 12000015 BM EQU 4 12050015 BZ EQU 8 12100015 BNM EQU 11 12150015 BNP EQU 13 12200015 BNZ EQU 7 12250015 BO EQU 1 12300015 BNO EQU 14 12350015 SPACE 2 12400015 * COMMUNICATIONS PARAMETERS 12450015 SPACE 2 12500015 ZCOMM EQU DB+304 12550015 ZUTXTC EQU CB+X'14' 12600015 PAR1 EQU DB+128 PARAMETER 1 12650015 PAR2 EQU DB+132 PARAMETER 2 12700015 LOCK EQU DB+274 12750015 ZDICRF EQU CB+X'2C' 12800015 ZDRFAB EQU CB+X'34' 12850015 TXTSZ EQU DB+266 12900015 ZNXTLC EQU DB+276 12950015 ZUPL EQU CB+X'08' 13000015 ZUGC EQU CB+X'10' 13050015 ZURC EQU CB+X'18' 13100015 ZABORT EQU CB+X'20' 13150015 ZTXTAB EQU CB+X'54' 13200015 ZCHAIN EQU CB+X'58' 13250015 ZALTER EQU CB+X'5C' 13300015 ZMYNAM EQU DB+112 13350015 ZSTACH EQU ZCOMM+68 13400015 ZCONCH EQU ZCOMM+78 13450015 ZEQMAX EQU ZCOMM+82 13500015 ZSMREG EQU ZCOMM+40 13550015 ZPROC1 EQU ZCOMM+64 13600015 ZCITEM EQU ZCOMM+80 13650015 RLSCTL EQU CB+X'48' 13700015 ZDABRF EQU CB+X'60' 13750015 REQEST EQU CB+X'40' I4A 13770016 SPACE 2 13800015 * OUT OF BLOCK STORAGE 13850015 SPACE 2 13900015 PROCST EQU B1+2 13950015 SP54 EQU PROCST+4 14000015 ELSIZ EQU SP54+4 14050015 MKDVD EQU ELSIZ+4 14100015 MOVEMP EQU MKDVD+4 14120017 BASED EQU SCRACH+4 14150015 SPEC EQU BASED+4 I4A 14170016 TRIAL EQU SPEC+4 14190016 REGSAV EQU SCRACH+X'638' 14220001 STCKPT EQU REGSAV+X'78' 14250015 FRSTBD EQU STCKPT+4 14280015 OACC EQU FRSTBD+2 14310015 OWRK1 EQU OACC+2 14350015 OWRK2 EQU OWRK1+2 14400015 OOFF EQU OWRK2+2 14450015 OSTACK EQU OOFF+2 14500015 OLNGTH EQU OSTACK+2 14550015 AREF EQU OLNGTH+2 14600015 BREF EQU AREF+2 14650015 MREF EQU BREF+2 14700015 RREF EQU MREF+2 14750015 VREF EQU RREF+2 14800015 TREF EQU VREF+2 14850015 OFFSET EQU TREF+2 14900015 BOUND EQU OFFSET+2 14950015 MAXBND EQU BOUND+2 15000015 DIM1 EQU MAXBND+2 15050015 N EQU DIM1+2 15100015 DREF1 EQU N+2 15150015 CLASS EQU DREF1+2 15200015 WRKSW EQU CLASS+1 15250015 OBJSW EQU WRKSW+1 15300015 DIMSW EQU OBJSW+1 15350015 PS EQU DIMSW+1 15400015 WRKSW1 EQU PS+48 15450015 ALLSW EQU WRKSW1+1 15500015 LENGTH EQU ALLSW+1 15550015 DIMREF EQU LENGTH+4 15600015 NREF EQU DIMREF+2 15650015 DEFSW EQU NREF+2 15700015 SIZSW EQU DEFSW+1 15750015 DIM EQU SIZSW+1 15800015 DREF EQU DIM+2 15850015 DVOFF EQU DREF+2 15900015 BITSW EQU DVOFF+2 15950015 ADJSW EQU BITSW+1 16000015 VARYSW EQU ADJSW+1 16050015 MPL1 EQU VARYSW+1 16100015 MCOBOL EQU MPL1+2 16150015 QUFLAG EQU MCOBOL+2 I4A 16180016 DUMMY EQU QUFLAG+1 I4A 16210016 COBLSW EQU DUMMY+1 I4A 16240016 CNTGSW EQU COBLSW+1 16300015 AREASW EQU CNTGSW+1 16350015 BASESW EQU AREASW+1 16400015 ADJ1SW EQU BASESW+1 16450015 V1SW EQU ADJ1SW+1 16500015 SUPRDV EQU V1SW+1 I4A 16520016 PROCDT EQU B3+6 16560016 ERR2 EQU PROCDT+4 16600015 IPDV EQU ERR2+4 16650015 DP5 EQU IPDV+4 16700015 SETDVS EQU DP5+4 16750015 STDVS1 EQU SETDVS+4 16800015 ERR1 EQU STDVS1+4 16850015 CHKDEF EQU ERR1+4 16900015 RDV1 EQU CHKDEF+4 16950015 RDV2 EQU RDV1+4 17000015 RDV3 EQU RDV2+4 17050015 RDV4 EQU RDV3+4 17100015 RDV5 EQU RDV4+4 17150015 STBAS1 EQU RDV5+4 17200015 NXTREF EQU STBAS1+4 17250015 NXTRF1 EQU NXTREF+4 17300015 RD6 EQU NXTRF1+4 17330015 ACC EQU RD6+6 17360015 DVOFF1 EQU ACC+4 17400015 BSREF EQU DVOFF1+2 17450015 VSW EQU BSREF+2 17500015 DVDSW EQU VSW+1 17520015 EJECT 17550015 * EQUS FOR TEXT SKELETONS HELD IN SCRATCH CORE 17600015 SPACE 5 17650015 CONENT EQU SCRACH+X'12' I4A 17700016 CBCD EQU CONENT+14 17750015 BNMC EQU CBCD+4 17800015 SKLTN1 EQU BNMC+2 17850015 ERMSG EQU SKLTN1+8 17900015 AI1 EQU ERMSG+17 17950015 AI2 EQU AI1+8 18000015 AI9 EQU AI2+8 18050015 SPACE 18100015 AI3 EQU AI9 18150015 AI6 EQU AI3+26 18200015 SPACE 18250015 AI7 EQU AI6 18300015 AI8 EQU AI7+5 18350015 SPACE 18400015 FN2 EQU AI8 18450015 FN3 EQU FN2+3 18500015 FN6 EQU FN3+2 18550015 FN7 EQU FN6+5 18600015 FN9 EQU FN7+7 18650015 SPACE 18700015 FN8 EQU FN9 18750015 AV14 EQU FN8+7 18800015 AV2 EQU AV14+3 18850015 AV8 EQU AV2+16 18900015 SPACE 18950015 AV10 EQU AV8 19000015 AV11 EQU AV10+18 19050015 SPACE 19100015 AV17 EQU AV11 19150015 AV18 EQU AV17+13 19200015 SPACE 19250015 AV20 EQU AV18 19300015 AV22 EQU AV20+13 19350015 AV23 EQU AV22+23 19400015 SPACE 19450015 AV12 EQU AV23 19500015 AV13 EQU AV12+21 19550015 SPACE 19600015 AR5 EQU AV13 19650015 AR1 EQU AR5+5 19700015 AR2 EQU AR1+12 19750015 SPACE 19800015 SV31 EQU AR2 19850015 SV32 EQU SV31+5 19900015 SV33 EQU SV32+8 19950015 SV34 EQU SV33+24 20000015 SV35 EQU SV34+5 20050015 SPACE 20100015 SV21 EQU SV35 20150015 SV22 EQU SV21+5 20200015 SV23 EQU SV22+8 20250015 SV24 EQU SV23+8 20300015 SV25 EQU SV24+16 20350015 SV26 EQU SV25+5 20400015 SPACE 20450015 SV27 EQU SV26 20500015 SV28 EQU SV27+13 20550015 SPACE 20600015 SV41 EQU SV28 20650015 SV42 EQU SV41+5 20700015 SV43 EQU SV42+8 20750015 SV44 EQU SV43+29 20800015 SV45 EQU SV44+5 20850015 SPACE 20900015 INSRT1 EQU SV45 20950015 INSRT2 EQU INSRT1+21 21000015 INSRT3 EQU INSRT2+8 21050015 SPACE 21100015 AR4C EQU INSRT3 21150015 AR4D EQU AR4C+8 21200015 AR4E EQU AR4D+8 21250015 SPACE 21300015 CR5 EQU AR4E 21350015 SPACE 5 21450015 AD1 EQU SCRACH+X'1C2' I4A 21500016 AD2 EQU AD1+3 21550015 AD3 EQU AD2+1 21600015 AD4 EQU AD3+2 21650015 SB21 EQU AD4+2 21700015 SB22 EQU SB21+7 21750015 SPACE 21800015 CD16 EQU SB22 21850015 CD17 EQU CD16+15 21900015 CD18 EQU CD17+5 21950015 CD91 EQU CD18 22000015 CD92 EQU CD91+10 22050015 CD93 EQU CD92+5 22100015 SPACE 22150015 CD19 EQU CD93 22200015 CD20 EQU CD19+25 22250015 CD21 EQU CD20+10 22300015 SPACE 22350015 CD19A EQU CD21 22400015 CD19B EQU CD19A+25 22450015 SPACE 22500015 CD26 EQU CD19B 22550015 CD27 EQU CD26+7 22600015 SPACE 22650015 CD30 EQU CD27 22700015 CD31 EQU CD30+5 22750015 SPACE 22800015 CD32 EQU CD31 22850015 CD33 EQU CD32+15 22900015 CD34 EQU CD33+10 22950015 SPACE 23000015 SB6A EQU CD34 23050015 SB7A EQU SB6A+8 23100015 SPACE 23150015 SB9 EQU SB7A 23200015 SB11 EQU SB9+20 23250015 SB10 EQU SB11+13 23300017 SPACE 23350015 SB16 EQU SB10 23400015 SB17 EQU SB16+16 23450015 SB18 EQU SB17+33 23500015 SB19 EQU SB18+5 23550015 SPACE 23600015 RD8 EQU SB19 23650015 RD9 EQU RD8+13 23700015 RD10 EQU RD9+21 23750015 RD11 EQU RD10+8 23800015 SPACE 23850015 RD16 EQU RD11 23900015 RD12 EQU RD16+8 23950015 RD13 EQU RD12+16 24000015 SPACE 24050015 SA1 EQU RD13 24100015 SA2 EQU SA1+3 24150015 SA3 EQU SA2+5 24200015 SA4 EQU SA3+2 24250015 SA5 EQU SA4+4 24300015 SA7 EQU SA5+4 24350015 SA6 EQU SA7+2 24400015 SPACE 24450015 MP9 EQU SA6 24500015 MP6 EQU MP9+6 24550015 MP8 EQU MP6+5 24600015 MP7 EQU MP8+5 24650015 MP5 EQU MP7+5 24700015 MP10 EQU MP5+10 24750015 SPACE 24800015 MP25 EQU MP10 24850015 SDVSIZ EQU MP25+9 24900015 N1 EQU SDVSIZ+6 24950015 DREF20 EQU N1+5 25000015 EQU51 EQU DREF20+14 25050015 EQU52 EQU EQU51+49 25100001 MP26 EQU EQU52+16 25150015 SPACE 25200015 SV7 EQU MP26 25250015 SV8 EQU SV7+13 25300015 SPACE 25350015 BITCVN EQU SV8 25400015 DREF11 EQU BITCVN+3 25450015 DREF17 EQU DREF11+28 25500015 SV9 EQU DREF17+5 25550015 TREF1 EQU SV9+8 25600015 L1 EQU TREF1+5 25650015 DREF12 EQU L1+3 25700015 BNDPT EQU DREF12+2 25750015 INSET1 EQU BNDPT+2 25800015 EQU11 EQU BNDPT+3 25850015 DCNT1 EQU EQU11+18 25900015 EQU21 EQU DCNT1+3 25950015 DREF13 EQU EQU21+5 26000015 EQU22 EQU DREF13+43 26050001 DREF14 EQU EQU22+5 26100015 SV10 EQU DREF14+5 26150015 DREF15 EQU SV10+24 26200015 SLPT EQU DREF15+4 26250015 SV16 EQU SLPT+10 26300015 DCNT2 EQU SV16+14 26350015 EQU31 EQU DCNT2+3 26400015 EQU41 EQU EQU31+31 26450015 EQU12 EQU EQU41+15 26500015 EQU42 EQU EQU12+3 26550015 DREF16 EQU EQU42+5 26600015 EQU32 EQU DREF16+43 26650001 SV12 EQU EQU32+2 26700015 SPACE 26750015 SV13 EQU SV12 26800015 SV14 EQU SV13+20 26850015 SPACE 26900015 IP1 EQU SV14 26950015 IP2 EQU IP1+8 27000015 IP3 EQU IP2+16 27050015 IP4 EQU IP3+8 27100015 IP10 EQU IP4+3 27150015 IP5 EQU IP10+15 27200015 IP6 EQU IP5+10 27250015 IP7 EQU IP6+8 27300015 IP8 EQU IP7+8 27350015 IP11 EQU IP8+10 27400015 IP9 EQU IP11+28 27450015 IP12 EQU IP9+18 27500015 SPACE 27550015 SD33 EQU IP12 27600015 SD15 EQU SD33+8 27650015 SD18 EQU SD15+26 27700015 SD16 EQU SD18+5 27750015 SD19 EQU SD16+13 27800015 SD34 EQU SD19+8 27850015 SPACE 27900015 SD35 EQU SD34 27950015 SD21 EQU SD35+8 28000015 SD36 EQU SD21+8 28050015 SPACE 28100015 SD37 EQU SD36 28150015 SD38 EQU SD37+26 28200015 SPACE 28250015 SD40 EQU SD38 28300015 SD41 EQU SD40+18 28350015 SPACE 28400015 SD42 EQU SD41 28450015 SD43 EQU SD42+8 28500015 SPACE 28503015 SD37A EQU SD43 28506015 SD38A EQU SD37A+8 28509015 SPACE 28512015 FAST1 EQU SD38A 28515015 FAST1A EQU FAST1+8 28518015 SPACE 28521015 FAST2 EQU FAST1A 28524015 FAST2A EQU FAST2+8 28527015 SPACE 28530015 RD16A EQU FAST2A 28533015 RD12A EQU RD16A+21 28536015 RD13A EQU RD12A+16 28539015 SPACE 1 I4A 28540016 P1 EQU RD13A I4A 28541016 P2 EQU P1+5 I4A 28542016 SPACE 1 I4A 28543016 MP25A EQU P2 I4A 28544016 MP26A EQU MP25A+34 I4A 28545016 EJECT 28550015 * EXTERNALLY REFERENCED ROUTINES 28600015 SPACE 28650015 BC B,SETBRF 28700015 BC B,ADDCN 28750015 BC B,SUBCN 28800015 BC B,LOADCN 28850015 BC B,CMPILE 28900015 BC B,INOBJ 28950015 BC B,CMPIL1 29000015 BC B,TERMWS 29050015 BC B,FINISH 29100015 BC B,CHNSCN 29150015 BC B,SVARY 29200015 BC B,VOBJC 29250015 BC B,ALVACA 29300015 BC B,BUMPEQ 29350015 BC B,MKCNST 29400015 BC B,CS2 29450015 BC B,MP13 29470015 BC B,BEGIN 29480016 SPACE 2 29500015 * EXTERNALLY REFERENCED STORAGE 29550015 SPACE 29600015 BLOCK DC H'0' 29650015 LEVEL DC H'0' 29700015 MAXLVL DS H MAXIMUM LEVEL 29750015 DONSW DS C DEFINED OR BASE SWITCH 29800015 TXTNM DS C I4A 29820016 * INITIALISATION ROUTINE 29822016 * 29824016 * ENTRY POINT- BEGIN - ENTERED FROM THE TRANSFER 29826016 * VECTOR FROM COMPILER CONTRIL 29828016 * 29830016 * EXITS - NORMAL - TO CHNSCN ROUTINE IN IEMJL 29832016 * 29834016 * EXITS - ERROR - NONE 29836016 * 29838016 BEGIN L 12,PAR1 29840016 MVC ZMYNAM(2),B1 29842016 BAL RR,BUMPEQ 29844016 EJECT 29850015 * CHAIN SCAN ROUTINE 29900015 * 29950015 * FUNCTIONS - SCANS THE STATIC, AUTOMATIC AND CONTROLLED 30000015 * CHAINS IN TURN FOR STRUCTURES, ARRAYS, ADJUSTABLE STRINGS 30050015 * AND DEFINED ITEMS. ON ENCOUNTERING ANY ONE OF THESE CONTROL 30100015 * IS PASSED TO THE APPROPRIATE PROCESSING ROUTINE. 30150015 * 30200015 * ENTRY POINT - CHNSCN FROM THE PHASE INITIALIZATION 30250015 * ROUTINE IN IEMJK. 30300015 * 30350015 * EXTERNAL ROUTINES (1) CHKDEF IN IEMJM TESTS IF THE 30400015 * CURRENT ITEM IS DEFINED, AND IF SO, PROCESSES IT. 30450015 * (2) PROCST IN IEMJK PROCESSES 30500015 * STRUCTURES. 30550015 * (3) PROCDT IN IEMJL PROCESSES ARRAYS. 30600015 * (4) SETBRF IN IEMJL FINDS THE ENTRY 30650015 * TYPE1 FOR THE BLOCK IN WHICH A CONTROLLED VARIABLE IS 30700015 * ALLOCATED. 30750015 * (5) INOBJ IN IEMJL IS USED TO 30800015 * INITIALIZE OBJECT CODE FOR ADJUSTABLE STRINGS. 30850015 * (6) ALVACI IN IEMJL COMPILES CODE TO 30900015 * ADD THE SIZE OF AN ADJUSTABLE STRING TO THE VDA ACCUMULATOR 30950015 * REGISTER, AND TO RELOCATE THE STRING DOPE VECTOR FROM THE 31000015 * START OF THE VDA. 31050015 * 31100015 * EXITS - NORMAL - TO FINISH ROUTINE, AFTER SCANNING ALL 31150015 * THE DATA CHAINS. 31200015 * 31250015 * EXITS - ERROR - N/A 31300015 SPACE 2 31350015 CHNSCN MVC AREF(2),ZSTACH+4 SET AREF FROM STATIC SLOT 31400015 MVI CLASS,STATIC SET CLASS SW TO STATIC 31450015 MVI WRKSW1,OFF 31550015 SR RB,RB 31600015 STH RB,MAXLVL MAX LEVEL=0 31650015 STH RB,MAXDIM MAXDIM=0 31700015 CS2 MVI WRKSW,OFF 22543 31730001 CS2A LH RC,AREF 22543 31760001 LTR RC,RC 31800015 BC BZ,CS8 GO TO CS8 IF END OF CHAIN 31850015 MVC PAR1+2(2),AREF 31900015 BALR RR,RL GET DICTIONARY ADDRESS OF AREF 31950015 L RD,PAR1 SET DICTIONARY POINTER 32000015 TM 0(RD),X'40' 32050015 BC BO,CS8 BRANCH IF NON DATA VARIABLE 32100015 TM 0(RD),X'06' 32150015 BC BNO,CS17A BRANCH IF NOT DATA 32200015 TM 0(RD),X'09' 32250015 BC BZ,CS8 BRANCH IF NOT DATA LABEL STRUCTURE 32300015 CS17B BAL RR,CHKDEF CHECK DEFINED 32350015 BC B,CS4 32400015 SPACE 32450015 TM 0(RD),X'0F' 32500015 BC BO,CS17C BRANCH IF DATA 32550015 TM 0(RD),X'0E' 32600015 BC BO,CS10 BRANCH IF STRUCTURE 32650015 CS17C TM 0(RD),X'10' 32700015 BC BO,CS9 BRANCH IF DIMENSIONED 32750015 BC B,CS12 32800015 SPACE 32850015 CS17A TM 0(RD),X'0C' 32900015 BC BO,CS17B BRANCH IF EVENT OR TASK 32950015 BC B,CS8 33000015 SPACE 33050015 CS9 BAL RR,SETBRF *** ROUTINE FOR DIMENSIONED ITEM 33100015 BAL RR,PROCDT PROCESS DIMENSION TABLE 33150015 CLI DVDSW,ON 33200015 BC BNE,CS14 NO DVD REQUIRED 33250015 TM FDOT1B(RD),X'10' 33300015 BC BO,CS14 BRANCH IF DVD EXISTS 33350015 BAL RR,MKDVD 33400015 CS14 MVC CLASS(1),SWSAV RESTORE CLASS SWITCH 33450015 TM FDOT4B(RD),RDVBIT 33500015 BC BO,*+8 33550015 BAL RR,TERMWS TERMINATE WORKSPACE 33600015 MVC PAR1+2(2),AREF 33650015 BALR RR,RL GET ADDRESS OF AREF 33700015 L RD,PAR1 33750015 NI FDOT2B(RD),X'BF' SET VARYING ARRAY BIT OFF 33800015 CLI VSW,ON 33850015 BC BNE,*+8 SKIP IF NO VARYING ARRAYS 33900015 OI FDOT2B(RD),VARBIT SET VARYING ARRAY BIT 33950015 SPACE 34000015 CS4 MVC SAVREF(2),AREF 34050015 TM FDOT4B(RD),RDVBIT 34100015 BC BZ,CS5A BRANCH IF NO RDV 34150015 CLI ADJ1SW,ON 34200015 BC BE,*+8 BRANCH IF ADJUSTABLE BASED 34250015 BAL RR,ADRDV GENERATE CODE TO SET RDV ADDRESS 34300015 BAL RR,TERMWS 34350015 MVC PAR1+2(2),SAVREF 34400015 BALR RR,RL 34450015 L RD,PAR1 34500015 SPACE 34550015 CS5A CLI CLASS,CONTRL 34600015 BC BNE,CS5 BRANCH IF NOT CONTROLLED 34650015 SPACE 34700015 TM FDVARB(RD),X'02' 34750015 BC BO,BASED BRANCH IF BASED 34800015 SPACE 34850015 CS5 MVC AREF(2),3(RD) *** CHAIN TO NEXT ITEM 34900015 B CS2A 22543 34950001 SPACE 35000015 CS10 CLI CLASS,CONTRL *** ROUTINE FOR STRUCTURE 35050015 BC BNE,CS16 BRANCH IF NOT CONTROLLED 35100015 SPACE 35150015 TM FDVARB(RD),X'02' 35200015 BC BO,CS16 BRANCH IF BASED 35250015 TM FDVARB(RD),X'01' 35300015 BC BZ,CS16A OMIT PROCESSING IF DECLARED 35350015 TM FDOT1B(RD),X'01' 35400015 BC BZ,CS16 BRANCH IF NOT ALL STAR SPEC 35450015 TM FDOT2B(RD),X'40' 35500015 BC BZ,CS4 BRANCH IF NO VARYING ARRAYS 35550015 SPACE 35600015 CS16 BAL RR,SETBRF *** MAP STRUCTURE 35650015 BAL RR,PROCST PROCESS STRUCTURE 35700015 CLI DVDSW,ON 35750015 BC BNE,CS14 NO DVD REQUIRED 35800015 TM FDOT1B(RD),X'10' 35850015 BC BO,CS14 BRANCH IF DVD EXISTS 35900015 BAL RR,MKDVD 35950015 BC B,CS14 36000015 SPACE 36008015 CS16A TM FDOT1B(RD),X'10' 36016015 BC BZ,CS4 BRANCH IF NO DVD IS REQUIRED 36024015 BAL RR,MKDVD 36032015 BC B,CS4 36040015 SPACE 36050015 CS8 TM CLASS,STYPE *** END CHAIN ROUTINE 36100015 BC BM,FINISH EXIT IF END OF CONTROLLED 36150015 BC BZ,CS11 BRANCH IF STATIC 36200015 MVC PAR1+2(2),BREF 36250015 BALR RR,RL GET ADDRESS OF BREF 36300015 L RD,PAR1 36350015 MVC BREF(2),9(RD) SET BREF TO NEXT CHAIN LINK 36400015 CS6 LH RB,BREF 36450015 LTR RB,RB 36500015 BC BZ,CS13 BRANCH IF END OF AUTO CHAIN 36550015 STH RB,PAR1+2 36600015 BALR RR,RL GET ADDRESS OF NEXT CHAIN LINK 36650015 L RD,PAR1 36700015 MVC AREF(2),11(RD) SET AREF FROM CHAIN LINK 36750015 BC B,CS2 EXAMINE NEXT ITEM 36800015 SPACE 36850015 CS13 MVI SB4+1,X'01' SET COUNT TO 1 36900015 MVC BREF(2),ZPROC1+2 SER BREF TO FIRST BLOCK 36950015 MVI CLASS,CONTRL SET CLASS TO CONTROLLED 37000015 MVC AREF(2),ZCITEM SET AREF TO CONTROLLED CHAIN 37050015 BC B,CS2 37100015 SPACE 37150015 CS11 MVI CLASS,AUTO *** END OF STATIC ROUTINE 37200015 MVC BREF(2),ZPROC1+2 SET BREF FROM CHAIN START 37250015 BC B,CS6 37300015 SPACE 37350015 CS12 MVI V1SW,OFF 37400015 NI FDOT1B(RD),X'EF' SET DVD BIT OFF 37450015 SPACE 37500015 BAL RR,ELSIZ 37550015 BC B,CS18 BRANCH IF NON ADJUSTABLE 37600015 SPACE 37650015 TM CLASS,STYPE 37700015 BC BM,CS19 BRANCH IF DYNAMIC 37750015 SPACE 37800015 MVI DIMSW,ON 37850015 BAL RR,SETBRF 37900015 BAL RR,INOBJ INIT OBJECT CODE 37950015 BAL RR,ALVACI ALIGN DSA CODE 38000015 MVI DIMSW,OFF 38050015 BC B,CS14 38100015 SPACE 38150015 CS18 CLI CLASS,STATIC 38450015 BC BNE,CS18A 38500015 SPACE 38550015 CLI V1SW,ON 38600015 BC BNE,CS18B 38650015 SPACE 38700015 NI FDOT4B(RD),X'FE' SET RDV BIT OFF 38750015 BC B,CS4 38800015 SPACE 38850015 CS18B TM FDOT4B(RD),RDVBIT 38900015 BC BZ,CS4 BRANCH IF NO RDV NEEDED 38950015 BAL RR,RDV3 39000015 BC B,CS4 39050015 SPACE 39100015 CS18A TM CLASS,STYPE 39150015 BC BNM,CS18B 39200015 SPACE 39250015 TM 0(RD),X'0F' 39300015 BC BNO,CS18B BRANCH IF LET 39350015 SPACE 39400015 TM FDDATA(RD),X'80' 39450015 BC BO,CS18B 39500015 CS19 NI FDOT4B(RD),X'FE' SET RDV BIT OFF 39550015 BC B,CS4 39600015 EJECT 39650015 * SET ENTRY TYPE1 DICTIONARY REFERENCE ROUTINE. 39700015 * 39750015 * FUNCTIONS (1) TO FIND THE ENTRY TYPE1 DICTIONARY ENTRY 39800015 * CORRESPONDING TO THE BLOCK IN WHICH A CONTROLLED VARIABLE 39850015 * CURRENTLY BEING PROCESSED IS ALLOCATED. 39900015 * (2) TO SET THE REFERENCE TO THE DOPE VECTOR 39950015 * IN WHICH THE ITEM IS TO BE INITIALIZED, IF OBJECT CODE IS 40000015 * NECESSARY. FOR AUTOMATIC VARIABLES THIS IS THE DOPE VECTOR IN 40050015 * THE DSA, FOR TEMPORARY VARIABLES, THE TEMPORARY VARIABLE 40100015 * INITIALIZATION WORKSPACE IN THE DSA, AND FOR CONTROLLED 40150015 * VARIABLES, THE CONTROLLED VARIABLE INITIALIZATION WORKSPACE IN 40200015 * THE DSA. 40250015 * 40300015 * ENTRY POINT - SETBRF -FROM CALLING ROUTINE. 40350015 * 40400015 * EXTERNAL ROUTINES - ZDRFAB. 40450015 * 40500015 * EXITS - NORMAL - TO CALLING ROUTINE. 40550015 * 40600015 * EXITS - ERROR - N/A. 40650015 SPACE 2 40700015 SETBRF MVI VARYSW,OFF 40750015 MVI VSW,OFF SET ANY VARYING SWITCH OFF 40800015 MVC SWSAV(1),CLASS SAVE STORAGE CLASS SWITCH 40850015 MVI DVDSW,OFF 40900015 TM FDOT1B(RD),X'10' 40950015 BC BZ,*+12 NO DVD REQUIRED 41000015 MVI DVDSW,ON SET FLAG ON 41050015 NI FDOT1B(RD),X'EF' SET DVD BIT OFF 41100015 TM CLASS,STYPE 41150015 BCR BZ,RR EXIT IF STATIC 41200015 BC BM,SB1 BRANCH IF CONTROLLED 41250015 SPACE 41300015 TM FDOT4B(RD),X'60' *** AUTOMATIC 41350015 BC BNZ,SB2 BRANCH IF TEMPORARY 41400015 SB3 MVC DREF1(2),AREF SET DICTIONARY REFERENCE FOR 41450015 OI DREF1+1,X'01' REFERENCES TO DV IN GENERATED CODE 41500015 BCR B,RR EXIT 41550015 SPACE 41600015 SB2 TM FDOT4B(RD),X'20' *** TEMPORARY 41650015 MVI CLASS,TMP2 H212 41670000 BC BZ,SB3 BRANCH IF NOT TEMP 2 41700015 MVC DREF1(2),WREF SET REF TO TEMP 2 WORKSPACE 41750015 OI DREF1+1,X'02' 41800015 BCR B,RR EXIT 41900015 SPACE 41950015 SB1 MVC DREF1(2),WREF *** CONTROLLED 42000015 OI DREF1+1,X'01' SET REF TO CONTROLLED WORKSPACE 42050015 SPACE 42100015 SR RB,RB *** FIND CORRECT ENTRY TYPE 1 42150015 IC RB,2(RD) SET LENGTH OF DICTIONARY ENTRY 42200015 BCTR RB,0 42250015 AR RB,RD SET POINTER TO COUNT 42300015 MVC LOCK(2),AREF LOCK CURRENT ENTRY 42350015 ST RR,0(RS) SAVE LINK 42400015 TM FDOT2B(RD),FPBIT 42450015 BC BZ,SB7 SKIP IF NOT FORMAL PARAMETER 42500015 SPACE 42550015 BCTR RB,0 *** FORMAL PARAMETER 42600015 MVC PAR1+2(2),0(RB) 42650015 BALR RR,RL GET FORMAL PARAMETER TYPE1 ENTRY 42700015 L RB,PAR1 42750015 MVC 4(1,RS),8(RB) SAVE COUNT 42800015 LA RB,4(RS) POINT RB AT COUNT 42850015 SPACE 42900015 SB7 MVC NBREF(2),ZPROC1+2 SET BREF TO START OF CHAIN 42950015 SPACE 43000015 SB4 CLI 0(RB),X'00' COMPARE CURRENT BLOCK NO WITH 43050015 BC BE,SB6 ENTRY TYPE1 IN BREF. EXIT IF EQUAL 43100015 SPACE 43150015 SB5 MVC BREF(2),NBREF 43200015 MVC PAR1+2(2),BREF 43250015 BALR RR,RL 43300015 L RC,PAR1 GET ENTRY TYPE 1 ENTRY 43350015 MVC NBREF(2),9(RC) SET REFERENCE TO NEXT ENTRY 1 43400015 MVC SB4+1(1),4(RC) SET COUNT IN COMPARE INSTRUCTION 43450015 BC B,SB4 43500015 SPACE 43550015 SB6 SR RB,RB 43600015 STH RB,LOCK UNLOCK VARIABLE 43650015 L RR,0(RS) 43700015 BCR B,RR EXIT 43750015 EJECT 43800015 * ADDRESS RDV ROUTINE 43850015 SPACE 2 43900015 ADRDV CLI CLASS,STATIC 43950015 BCR BE,RR EXIT IF STATIC 44000015 CLI CLASS,CONTRL 44050015 BC BE,AR6 44100015 TM FDOT4B(RD),X'60' 44150015 BCR BO,RR RETURN IF COBOL TEMP 44200015 TM FDOT4B(RD),X'20' 44250015 BCR BO,RR EXIT IF TEMPORARY 44300015 CLI SUPRDV,ON I4A 44310016 BCR BE,RR I4A 44320016 AR6A ST RR,ADSLOT 44350015 TM FDOT1B(RD),DVDBIT 44400015 BC BZ,AR7 BRANCH IF NO DVD 44450015 MVC PAR1+2(2),8(RD) 44500015 BALR RR,RL GET DVD ENTRY 44550015 L RB,PAR1 44600015 MVC RREF(2),10(RB) SET REFERENCE TO RDV 44650015 BC B,AR8 44700015 SPACE 44750015 AR7 MVC RREF(2),8(RD) *** NO DVD, SET REF TO RDV 44800015 AR8 MVC BSREF(2),AREF 44850015 MVC AREF(2),RREF SET RDV REF IN AREF 44900015 NI OC2+1,X'0F' SET RDV SWITCH 44950015 BAL RR,INOBJ INITIALIZE OBJECT CODE 45000015 OI OC2+1,X'F0' RESET RDV SWITCH 45050015 MVI OBJSW,OFF 45100015 TM 0(RD),X'30' 45150015 BC BZ,AR4A BRANCH IF SCALAR 45200015 BAL RR,STBAS1 SET STARTING ADDRESS 45250015 CLI BITSW,ON 45300015 BC BNE,AR3 BRANCH IF NOT BIT 45350015 LA RE,AR5 *** BIT 45400015 LA RF,AR2-AR5 45450015 BC B,AR4 45500015 SPACE 45550015 AR3 LA RE,AR1 45600015 LA RF,AR2-AR1 45650015 AR4 MVC AR1+3(2),AREF 45700015 AR4B BAL RR,CMPIL1 45750015 L RR,ADSLOT 45800015 BCR B,RR 45850015 SPACE 45900015 AR4A MVC AR4C+3(2),BSREF 45950015 MVC AR4D+3(2),AREF 46000015 LA RE,AR4C COMPILE LA 15,ITEM 46050015 LA RF,AR4E-AR4C ST 15,RDV..ITEM 46100015 BC B,AR4B 46150015 SPACE 46200015 AR6 TM FDVARB(RD),X'02' 46250015 BCR BO,RR RETURN IF BASED 46300015 TM 0(RD),X'30' *** CTL WITH RDV BIT ON 46350015 BCR BZ,RR EXIT IF SCALAR 46400015 * 46500001 AR8C NI FDOT4B(RD),X'FE' SET RDV BIT OFF 46650015 TM FDOT1B(RD),X'10' 46700015 BCR BO,RR RETURN IF DVD MADE 46750015 BC B,MKDVD MAKEDVD 46800015 EJECT 46900015 * ADD, SUBTRACT OR LOAD CONSTANT ROUTINE 46950015 * 47000015 * FUNCTION - TO GENERATE OBJECT CODE TO ADD, SUBTRACT OR 47050015 * LOAD A CONSTANT KNOWN AT COMPILE TIME INTO AN OBJECT REGISTER. 47100015 * 47150015 * ENTRY POINTS (1) ADDCN 47200015 * (2) SUBCN 47250015 * (3) LOADCN 47300015 * 47350015 * EXTERNAL ROUTINES - CMPIL1 ADDS TEXT SKELETONS TO THE 47400015 * OUTPUT. 47450015 * 47500015 * EXIT - NORMAL - TO CALLING ROUTINE 47550015 * 47600015 * EXIT - ERROR - N/A 47650015 SPACE 2 47700015 ADDCN MVI OP,ADD SET OPERATION TO ADD 47750015 BC B,LC1 47800015 SPACE 47850015 SUBCN MVI OP,SUB 47900015 BC B,LC1 47950015 SPACE 48000015 LOADCN MVI OP,LOAD 48050015 LC1 ST RF,CBCD STORE CONSTANT 48100015 LTR RF,RF TEST CONSTANT VALUE 48150015 BC BZ,LC2 BRANCH IF ZERO 48200015 BC BM,LC4 BRANCH IF NEGATIVE 48250015 CL RF,C4096 48300015 BC BNL,LC5 BRANCH IF CONST>4096 48350015 TM FDDATA(RD),X'84' IF BIT STRING - NO LA 25903 48360019 BC BZ,LC5 THEN NOT LA 25903 48370019 TM OP,OTYPE TEST OPERATION TYPE 48400015 BC BO,LC3 BRANCH IF ADD 48450015 BC BM,LC5 BRANCH IF SUB 48500015 MVI PS,LA 48550015 MVC PS+1(2),0(RE) 48600015 MVC PS+3(2),OZERO 48650015 OI PS+1,X'80' 48700015 MVI PS+5,OSM1 48750015 MVC PS+6(2),CBCD+2 COMPILE LA OREG,CONST(0) 48800015 LA RF,8 48850015 BC B,CMPILE 48900015 SPACE 48950015 LC5 LA RF,CONENT *** CONSTANT NOT CONDUCIVE TO LA 49000015 ST RF,PAR1 SET ENTRY ADDRESS IN PAR1 49050015 LA RF,18 49100015 ST RF,PAR2 SET ENTRY LENGTH IN PAR2 49150015 MVC CONENT+3(2),ZCONCH CHAIN NEW ENTRY 49200015 L RF,ZDICRF 49250015 ST RR,0(RS) 49300015 BALR RR,RF MAKE CONSTANT DIC ENTRY 49350015 L RR,0(RS) 49400015 MVC PS+1(2),0(RE) SET OREG IN SKELETON INSTRUCTION 49450015 MVC ZCONCH(2),PAR1+2 SET REF IN CONSTANTS CHAIN 49500015 MVC PS+3(2),PAR1+2 SET CONSTANT REF IN INSTRUCTION 49550015 TM OP,OTYPE TEST OP TYPE 49600015 BC BO,LC6 BRANCH IF ADD 49650015 BC BM,LC7 BRANCH IF SUB 49700015 MVI PS,L SET OP TO LOAD 49750015 LC8 LA RF,5 49800015 BC B,CMPILE 49850015 SPACE 49900015 LC6 MVI PS,A SET OP TO ADD 49950015 BC B,LC8 50000015 LC7 MVI PS,S SET OP TO SUBTRACT 50050015 BC B,LC8 50100015 SPACE 50150015 LC2 TM OP,OTYPE *** CONSTANT IS ZERO 50200015 BCR BNZ,RR EXIT IF ADD OR SUB 50250015 MVI PS,SR 50300015 MVC PS+1(2),0(RE) 50350015 MVC PS+3(2),0(RE) COMPILE SR OREG,OREG 50400015 BC B,LC8 EXIT 50450015 SPACE 50500015 LC4 LCR RF,RF *** NEGATIVE CONSTANT 50550015 CL RF,C4096 50600015 BC BNL,LC5 BRANCH IF ³CONST³>4096 50650015 TM OP,OTYPE 50700015 BC BO,LC5 BRANCH IF ADD 50750015 BC BM,LC9 BRANCH IS SUB 50800015 MVI PS,LA 50850015 MVC PS+1(2),0(RE) 50900015 MVC PS+3(2),OZERO 50950015 OI PS+1,X'80' 51000015 ST RF,0(RS) 51050015 MVI PS+5,OSM1 51100015 MVC PS+6(2),0(RS) COMPILE LA OREG,POSCONS(0) 51150015 MVI PS+8,LCR 51200015 MVC PS+9(2),0(RE) 51250015 MVC PS+11(2),0(RE) COMPILE LCR OREG,OREG 51300015 LA RF,12 51350015 BC B,CMPILE 51400015 SPACE 51450015 LC9 ST RF,CBCD *** SUBTRACT NEGATIVE CONSTANT 51500015 LC3 MVI PS,LA 51550015 MVC PS+1(2),0(RE) 51600015 MVC PS+3(2),0(RE) 51650015 OI PS+1,X'80' 51700015 MVI PS+5,OSM1 51750015 MVC PS+6(2),CBCD+2 COMPILE LA OREG,CONST(OREG) 51800015 LA RF,8 51850015 BC B,CMPILE 51900015 EJECT 51950015 * MAKE CONSTANT DICTIONARY ENTRY ROUTINE 52000015 * 52050015 * FUNCTIONS - MAKES CONSTANT DICTIONARY ENTRIES FOR 52100015 * FIXED BINARY CONSTANTS. 52150015 * 52200015 * ENTRY POINT - MKCNST. ON ENTRY REGISTER RF CONTAINS 52250015 * THE FIXED BINARY CONSTANT. 52300015 * 52350015 * EXTERNAL ROUTINES - ZDICRF IN COMPILER CONTROL 52400015 * 52450015 * EXITS - NORMAL - TO CALLING ROUTINE 52500015 * 52550015 * EXITS - ERROR - N/A 52600015 SPACE 2 52650015 MKCNST ST RR,0(RS) SAVE LINK 52700015 ST RF,CBCD STORE CONSTANT IN SKELETON 52750015 LA RF,CONENT 52800015 ST RF,PAR1 SET ADDRESS OF SKELETON IN PAR1 52850015 LA RF,18 52900015 ST RF,PAR2 SET LENGTH OF ENTRY ON PAR2 52950015 MVC CONENT+3(2),ZCONCH SET HEAD OF CHAIN IN ENTRY 53000015 L RF,ZDICRF 53050015 BALR RR,RF 53100015 MVC ZCONCH(2),PAR1+2 SET REF IN CONSTANTS CHAIN 53150015 L RR,0(RS) RESTORE LINK 53200015 BCR B,RR EXIT 53250015 EJECT 53300015 * VARYING ARRAYS IN STRUCTURES ROUTINE. 53350015 * 53400015 * FUNCTION - SCANS STRUCTURE DICTIONARY ENTRIES FOR BASE 53450015 * ELEMENTS WHICH ARE ARRAYS OF VARYING STRINGS. ON FINDING SUCH 53500015 * A BASE ELEMENT, CONTROL IS PASSED TO VOBJC. 53550015 * 53600015 * ENTRY POINT - SVARY. ON ENTRY AREF CONTAINS THE 53650015 * DICTIONARY REFERENCE OF THE MAJOR STRUCTURE. 53700015 * 53750015 * EXTERNAL ROUTINES - VOBJC IN IEMJL GENERATES OBJECT CODE 53800015 * TO INITIALIZE THE SECONDARY DOPE VECTOR OF STRING DOPE VECTORS 53850015 * 53900015 * EXITS - NORMAL - TO CALLING ROUTINE. 53950015 * 54000015 * EXITS - ERROR - N/A 54050015 SPACE 2 54100015 SVARY ST RR,0(RS) 54150015 AR RS,R4 SAVE SUBROUTINE LINK 54200015 MVC XREF(2),AREF 54250015 MVI ENDSW,OFF 54300015 MVC DREF1(2),4(RC) SET DREF1 TO FIRST ELEMENT 54350015 MVC PAR1+2(2),4(RC) GET ADDRESS OF NEXT ELEMENT 54400015 SV4 MVC AREF(2),PAR1+2 54450015 BALR RR,RL 54500015 L RD,PAR1 SET POINTER TO ELEMENT 54550015 LR RC,RD 54600015 TM 0(RD),X'0F' 54650015 BC BNO,*+8 SKIP IF NOT DATA ITEM 54700015 LA RC,6(RC) BUMP POINTER 54750015 TM 0(RD),X'10' 54800015 BC BZ,*+8 SKIP IF NOT DIMENSIONED 54850015 LA RC,3(RC) BUMP POINTER 54900015 TM FDOT1B(RD),X'08' 54950015 BC BZ,*+8 SKIP IF NOT END OF STRUCTURE 55000015 MVI ENDSW,ON 55050015 MVC NREF(2),FSSSTI+4(RC) SET REF TO NEXT STRUCTURE ITEM 55100015 TM 0(RD),X'1F' 55150015 BC BO,SV1 BRANCH IF DIMENSIONED DATA ITEM 55200015 TM 0(RD),X'0F' 55250015 BC BO,SV2 BRANCH IF DATA 55300015 TM 0(RD),X'0E' 55350015 BC BNO,SV60 BRANCH IF TASK OR EVENT 55400015 SV2 CLI ENDSW,ON 55450015 BC BNE,SV3 BRANCH IF NOT END OF STRUCTURE 55500015 MVC AREF(2),XREF 55550015 SR RS,R4 55600015 L RR,0(RS) 55650015 BCR B,RR LEAVE ROUTINE 55700015 SPACE 55750015 SV3 MVC PAR1+2(2),NREF 55800015 MVC DREF1(2),NREF 55850015 BC B,SV4 55900015 SPACE 55950015 SV1 TM FDDATA(RD),X'80' *** DIMENSIONED DATA ITEM 56000015 BC BO,SV2 BRANCH IF NOT STRING 56050015 TM FDDATA(RD),X'02' 56100015 BC BO,SV1A BRANCH IF AREA 56150015 TM FDDATA(RD),X'10' 56200015 BC BZ,SV2 BRANCH IF NOT VARYING 56250015 SV1A MVC N+1(1),25(RD) 56300015 MVC DIMREF(2),26(RD) SET DIMENSION TABLE REFERENCE 56350015 OI DREF1+1,X'01' 56400015 XC DVOFF1(2),DVOFF1 CLEAR DVOFF1 56450015 BAL RR,VOBJC CREATE VARYING OBJECT CODE 56500015 BC B,SV2 56550015 SPACE 56600015 SV60 TM 0(RD),X'07' 56650015 BC BO,SV2 BRANCH IF LABEL 56700015 TM 0(RD),X'10' TASK OR EVENT 56750015 BC BNO,SV2 BRANCH IF NOT DIMENSIONED 56800015 SPACE 56850015 MVC N+1(1),19(RD) 56900015 MVC DIMREF(2),20(RD) DIM TAB REFERENCE 56950015 BC B,SV1A+12 57000015 EJECT 57050015 * VARYING ARRAY OBJECT CODE ROUTINE. 57100015 * 57150015 * FUNCTIONS - GENERATES OBJECT CODE TO CREATE AN ARRAY OF 57200015 * STRING DOPE VECTORS, EACH ONE OF WHICH POINTS TO AN ELEMENT OF 57250015 * AN ARRAY OF VARYING STRINGS. THE MAXIMUM LENGTH SLOT OF THE 57300015 * DOPE VECTOR IS SET TO THE MAXIMUM LENGTH OF THE STRING, AND 57350015 * THE CURRENT LENGTH SLOT IS SET TO ZERO. THE CODE GENERATED IN 57400015 * THIS ROUTINE IS INSERTED INTO THE PROLOGUE SO THAT IT IS 57450015 * EXECUTED AFTER THE PRIMARY DOPE VECTOR HAS BEEN INITIALIZED 57500015 * TO POINT TO THE STORAGE. THE CODE USES THE PRIMARY DOPE VECTOR 57550015 * TO CALCULATE THE POINTER TO THE ARRAY BASE ELEMENTS TO SET IN 57600015 * THE SECONDARY STRING DOPE VECTOR. 57650015 * 57700015 * ENTRY POINT - VOBJC 57750015 * 57800015 * EXTERNAL ROUTINES - (1) INOBJ IN IEMJL ADD AN 8N3 57850015 * STATEMENT TO THE TEXT. 57900015 * (2) CMPIL1 ADDS TEXT SKELETONS TO 57950015 * THE OUTPUT TEXT. 58000015 * (3) BUMPEQ IN IEMJL BUMPS THE VALUE 58050015 * OF THE EQU LABEL COUNT. 58100015 * EXITS - NORMAL - TO ROUTINE IPDV IN MODULE IEMJM 58150015 * 58200015 * EXITS - ERROR - N/A 58250015 SPACE 2 58300015 VOBJC ST RR,0(RS) 58350015 AR RS,R4 SAVE SUBROUTINE LINK 58400015 MVI VARYSW,ON 58450015 BAL RR,INOBJ INITIALIZE OBJECT CODE 58500015 MVC PAR1+2(2),AREF 58650015 BALR RR,RL 58700015 L RD,PAR1 58750015 CLI N+1,X'01' I4A 58758016 BC BE,SPEC BRANCH FOR SINGLE DIMENSIONS I4A 58766016 BAL RR,TRIAL CHECK FOR SPECIAL CASE I4A 58774016 LA RE,SV7 I4A 58782016 LA RF,SV8-SV7 SET TO COMPILE USSL I4A 58790016 TM 0(RD),X'0F' 58800015 BC BNO,SV5 BRANCH IF NOT DATA 58850015 TM FDDATA(RD),X'04' 58900015 BC BO,SV5 BRANCH IF CHARACTER STRING 58950015 MVC DREF11(2),DREF1 SET DICTIONARY REFERENCES IN 59000015 MVC DREF17(2),DREF1 PSEUDO CODE SKELETONS 59050015 LA RF,SV9-SV7 59100015 SPACE 59150015 SV5 BAL RR,CMPIL1 COMPILE CONVERSION TO BIT 59200015 SPACE 59250015 LH RB,N 59300015 CH RB,MAXDIM SET MAXDIM IF NECESSARY 59350015 BC BNH,*+8 59400015 STH RB,MAXDIM 59450015 AR RB,RB 59500015 AR RB,RB 59550015 LR RE,RB 59600015 SR RE,R4 CALCULATE 4*N-4 59650015 STH RE,0(RS) 59700015 MVC SV16+6(2),0(RS) 59750015 LR RC,RB 59800015 BCTR RC,0 CALCULATE LENGTH FOR MVC 59850015 STC RC,L1 SET LENGTH IN PSEUDO CODE 59900015 AH RC,DVOFF1 ADD OFFSET TO DOPE VECTOR 59950015 LA RC,5(RC) CALCULATE 4*N+4, WHICH IS THE 60000015 STH RC,0(RS) OFFSET TO THE BOUNDS FROM THE 60050015 MVC BNDPT(2),0(RS) BEGINNING OF THE DOPE VECTOR 60100015 LA RE,2(RC) CLACULATE OFFSET TO FIRST LOW 60150015 STH RE,0(RS) BOUND TO RESTORE COUNT 60200015 MVC DREF16+3(2),0(RS) 60250015 AR RC,RB CALCULATE 8*N+4, WHICH IS THE 60300015 STH RC,0(RS) OFFSET TO THE STRING LENGTH IN THE 60350015 MVC SLPT(2),0(RS) DOPE VECTOR 60400015 MVC SV34-2(2),0(RS) SET 8N+4 IN AREA CODE 60450015 CLI CLASS,TMP2 60500015 BC BE,SV6 BRANCH IF TEMP TYPE 2 60550015 SPACE 60600015 MVC TREF1(2),TREF SET WORK SPACE REF IN CODE 60650015 BC B,*+10 60700015 SPACE 60750015 SV6 MVC TREF1(2),WP2 SET TEMP WORKSPACE REF 60800015 MVC DREF12(2),DREF1 SET DOPE VECTOR REFERENCES IN 60850015 MVC DREF13(2),DREF1 PSEUDOCODE SKELETON 60900015 LH RB,DVOFF1 60950015 AR RB,R4 SET OFFSET TO FIRST MULTIPLIER 61000015 STH RB,0(RS) 61050015 MVC DREF13+3(2),0(RS) 61100015 MVC DREF14(2),DREF1 61150015 MVC DREF14+3(2),DVOFF1 61200015 MVC DREF15(2),DREF1 61250015 MVC DREF16(2),DREF1 61300015 MVC DCNT1(2),N SET DIMENSIONALITY IN PSEUDOCODE 61350015 MVC DCNT2(2),N 61400015 MVC EQU11(2),ZEQMAX SET EQU LABELS IN PSEUDO CODE 61450015 MVC EQU12(2),ZEQMAX 61500015 BAL RR,BUMPEQ BUMP EQU LABEL 61550015 MVC EQU21(2),ZEQMAX 61600015 MVC EQU22(2),ZEQMAX 61650015 BAL RR,BUMPEQ 61700015 MVC EQU31(2),ZEQMAX 61750015 MVC EQU32(2),ZEQMAX 61800015 BAL RR,BUMPEQ 61850015 MVC EQU41(2),ZEQMAX 61900015 MVC EQU42(2),ZEQMAX 61950015 BAL RR,BUMPEQ 62000015 LA RE,SV9 62050015 LA RF,SV12-SV9 62100015 TM 0(RD),X'0F' 62150015 BC BNO,SV30 BRANCH IF TASK OR EVENT 62200015 TM FDDATA(RD),X'02' 62250015 BC BO,SV30 AREA 62300015 TM FDDATA(RD),X'04' BRANCH IF CHAR TO COMPILE 62350015 BC BO,SV15 ENTIRE ROUTINE 62400015 SPACE 62450015 LA RF,SV10-SV9 *** BIT COMPILE CODE UP TO STORE 62500015 BAL RR,CMPIL1 POINTER IN SDV 62550015 LA RE,SV13 62600015 LA RF,SV14-SV13 CONVERT POINTER TO BYTE AND BIT 62650015 BAL RR,CMPIL1 OFFSET 62700015 SPACE 62750015 LA RE,SV10 62800015 LA RF,SV12-SV10 COMPILE REMAINING CODE 62850015 SV15 BAL RR,CMPIL1 62900015 BC B,IPDV 62950015 SPACE 63000015 SV30 LA RE,SV9+5 AREA TASK OR EVENT 63050015 LA RF,SV10-SV9-5 OMIT SAVE SDV PTR 63100015 SPACE 63150015 CLI BASESW,ON 63200015 BC BNE,SV30A BRANCH IF NOT BASED 63250015 SPACE 63300015 LA RF,INSET1-SV9-5 63350015 BAL RR,CMPIL1 63400015 SPACE 63450015 MVC PAR1+2(2),DIMREF 63500015 BALR RR,RL LOOK FOR REFER VARIABLE 63550015 L RC,PAR1 63600015 SPACE 63650015 TM 16(RC),X'FF' 63700015 BC BZ,SV30B 63750015 SPACE 63800015 MVC INSRT1+3(2),18(RC) MOVE REFER REF IN 63850015 OI INSRT1+4,X'01' SET DV BIT 63900015 MVC INSRT2+3(2),TREF1 SET WORK SPACE 63950015 SPACE 64000015 MVI INSRT1+13,X'88' MOVE LOAD TO SKELETON 64010001 MVC PAR1+2(2),18(RC) 64020001 BALR RR,RL 64030001 L RE,PAR1 ABS ADDRESS OF REFER VARIABLE 64040001 TM FDDATA+1(RE),X'F0' TEST PRECISION 64050001 BC BNZ,SV30D FULLWORD 64060001 MVI INSRT1+13,X'90' LOAD HALFWORD 64070001 * 64080001 SV30D LA RE,INSRT1 SKELETON ADDRESS 64090001 LA RF,INSRT3-INSRT1 64100015 BAL RR,CMPIL1 64150015 SPACE 64200015 SV30B LA RE,INSET1 64250015 LA RF,SV10-INSET1 64300015 SPACE 64350015 SV30A BAL RR,CMPIL1 64400015 SPACE 64450015 CLI BASESW,ON 64455015 BC BNE,SV30C BRANCH IF NOT BASED 64460015 SPACE 64465015 LA RE,P1 64475015 LA RF,P2-P1 64485015 BAL RR,CMPIL1 COMPILE A 3FFD,3FF8 64495015 SPACE 64540015 SV30C TM 0(RD),X'0F' 64545015 BC BNO,SV20 BRANCH IF NOT AREA 64550015 SPACE 64600015 MVC SV33+18(2),DREF1 64650015 SPACE 64700015 LA RE,SV33 64750015 LA RF,SV34-SV33 64800015 BC B,SV29 64850015 SPACE 64900015 SV20 TM 0(RD),X'0D' 64950015 BC BO,SV40 BRANCH IF EVENT 65000015 SPACE 65050015 MVC 16(2,RS),1(RD) 65100015 LR RE,RD 65150015 AH RE,16(RS) 65200015 SR RE,R4 SYMTAB FOR TASK 65250015 MVC SV24+3(2),0(RE) 65300015 SPACE 65350015 LA RE,SV23 65400015 LA RF,SV25-SV23 65450015 SV29 BAL RR,CMPIL1 65500015 SPACE 65550015 LA RE,SV16 65600015 LA RF,SV12-SV16 65650015 BAL RR,CMPIL1 65700015 SPACE 65750015 LA RE,SV27 65800015 LA RF,SV28-SV27 65850015 BAL RR,CMPIL1 65900015 SPACE 65950015 SR RS,R4 66000015 L RR,0(RS) RETURN 66050015 BCR B,RR 66100015 SPACE 66150015 SV40 LA RE,SV43 EVENT 66200015 LA RF,SV44-SV43 66250015 BC B,SV29 66300015 EJECT 66350015 * BUMP EQU LABEL ROUTINE 66400015 * 66450015 * FUNCTION - BUMPS EQU LABEL COUNT IN COMMUNICATIONS AREA. 66500015 * 66550015 * ENTRY POINT BUMPEQ 66600015 * 66650015 * EXTERNAL ROUTINES - N/A 66700015 * 66750015 * EXITS - NORMAL - TO CALLING ROUTINE 66800015 * 66850015 * EXIT - ERROR - N/A 66900015 SPACE 2 66950015 BUMPEQ LH RB,ZEQMAX 67000015 AH RB,C1 67050015 STH RB,ZEQMAX 67100015 BCR B,RR 67150015 EJECT 67200015 * ADD ADJUSTABLE ARRAY SIZE TO VDA ACCUMULATOR 67250015 * 67300015 * FUNCTIONS (1) GENERATES CODE TO ALIGN THE VDA ACCUMLATOR 67350015 * REGISTER TO THE BOUNDARY REQUIRED BY THE ARRAY, IF NECESSARY. 67400015 * THIS CODE IS BRACKETED BY A SPECIAL PSEUDO-CODE MARKER SO THAT 67450015 * IF THE ARRAY IS THE FIRST ITEM IN A VDA REGION (I.E. IT WILL 67500015 * BE ALLOCATED ON AN 8-BYTE BOUNDARY) THE ALIGNMENT CODE CAN BE 67550015 * REMOVED BY THE PROLOGUE CONSTRUCTION PHASE. 67600015 * (2) GENERATES CODE TO RELOCATE THE VIRTUAL 67650015 * ORIGIN OF AN ADJUSTABLE ARRAY BY THE ALIGNED CONTENTS OF THE 67700015 * VDA ACCUMULATOR 67750015 * (3) GENERATES CODE TO ADD THE SIZE OF THE 67800015 * ARRAY TO THE VDA ACCUMULATOR. 67850015 * 67900015 * ENTRY POINT - ALVACA 67950015 * 68000015 * EXTERNAL ROUTINES - CMPIL1 ADDS TEXT SKELETONS TO THE 68050015 * OUTPUT 68100015 * 68150015 * EXITS - NORMAL - TO CALLING ROUTINE 68200015 * 68250015 * EXITS - ERROR - N/A 68300015 SPACE 2 68350015 ALVACA ST RR,AVSLOT 68400015 LH RB,BOUND 68450015 CH RB,C8 68500015 BC BNH,AV1 BRANCH IF BYTE OR BIT BOUND 68550015 SPACE 68600015 LR RF,RB *** 2,4 OR 8 BYTE BOUND 68650001 SRL RF,3 CONVERT TO BYTES 68700015 LR RE,RF 68750015 BCTR RE,0 68800015 STC RE,AV2+7 68850015 CH RF,C8 68900015 BC BE,AV3 BRANCH IF 8 BYTE BOUND 68950015 CH RF,C4 68955001 BC BE,AV5 B IF 4 BYTE BOUND 68960001 AV24 BC 0,AV25 2 BYTE BOUND 68965001 LCR RF,RF 68970001 BAL RR,MKCNST 68975001 MVC CM2R(2),PAR1+2 SET MASK REFERENCE 68980001 OI AV24+1,X'F0' IGNORE CODE NEXT TIME 68985001 BC B,AV25 68990001 SPACE 69000015 AV5 BC 0,AV4 *** MAKE MASK 69050015 LCR RF,RF 69100015 BAL RR,MKCNST 69150015 MVC CM4R(2),PAR1+2 SET MASK REFERENCE 69200015 OI AV5+1,X'F0' 69250015 BC B,AV4 69300015 SPACE 69350015 AV3 BAL RR,AV30 8 BYTE BOUND 69400015 BC B,AV6 69450015 SPACE 69500015 AV30 BCR 0,RR 69550015 ST RR,0(RS) 69600015 AR RS,R4 69650015 SPACE 69700015 LCR RF,RF 69750015 BAL RR,MKCNST 69800015 MVC CM8R(2),PAR1+2 SET MASK REFERENCE 69850015 SPACE 69900015 OI AV30+1,X'F0' 69950015 SPACE 70000015 SR RS,R4 70050015 L RR,0(RS) 70100015 SPACE 70150015 BCR B,RR 70200015 AV25 MVC AV2+11(2),CM2R SET CONSTANT REF IN CORE 70210001 BC B,AV7 70220001 SPACE 70250015 AV6 MVC AV2+11(2),CM8R SET CONSTANT REFERENCE IN CORE 70300015 BC B,AV7 70350015 SPACE 70400015 AV4 MVC AV2+11(2),CM4R SET CONSTANT REF IN CODE 70450015 AV7 LA RE,AV14 70500015 LA RF,AV8-AV14 70550015 BAL RR,CMPIL1 70600015 SPACE 70650015 CLI DIMSW,ON 70700015 BC BE,AV9 BRANCH IF ARRAY 70750015 SPACE 70800015 AV19 CLC FRSTBD(2),BOUND COMPARE BOUNDS OF FIRST ELEM 70810015 BC BE,AV19A AND STRUCTURE 70820015 CLC BOUND(2),C8 70830015 BC BE,AV19A BRANCH IF TOTAL BYTE BOUNE 70840015 SPACE 70850015 MVC AV10+8(2),RREF *** STRUCTURE. ADD OFFSET 70860015 LA RE,AV10 70900015 LA RF,AV11-AV10 70950015 BAL RR,CMPIL1 71000015 SPACE 71050015 AV19A MVC FAST1+3(2),RREF I4A 71150016 LA RE,FAST1 I4A 71250016 LA RF,FAST1A-FAST1 I4A 71350016 BAL RR,CMPIL1 COMPILE ST 3FF8,RDV I4A 71450016 SPACE 71700015 AV16 CLC FRSTBD(2),BOUND 71708015 BC BE,AV16C 71716015 CLC BOUND(2),C8 71724015 BC BNE,AV16A BRANCH IF TOTAL BYTE BOUND 71732015 SPACE 71740015 AV16C MVC FAST2+3(2),RREF 71748015 LA RE,FAST2 71756015 LA RF,FAST2A-FAST2 COMPILE A 3FF8,RDV+4 71764015 BC B,AV16B 71772015 SPACE 71780015 AV16A MVC AV17+3(2),RREF END OF STRUCTURE 71788015 LA RE,AV17 TO ACCUMULATOR 71800015 LA RF,AV18-AV17 71850015 AV16B BAL RR,CMPIL1 71900015 SPACE 71950015 L RR,AVSLOT 72000015 BCR B,RR EXIT 72050015 SPACE 72100015 AV1 CLI DIMSW,ON *** BYTE BOUND 72150015 BC BNE,AV19 BRANCH IF STRUCTURE 72200015 SPACE 72250015 AV9 CLI SUPRDV,ON *** ARRAY I4A 72259016 BC BNE,AV9B BRANCH IF NO RDV I4A 72268016 SPACE 1 I4A 72277016 MVC FAST1+3(2),RREF I4A 72286016 LA RE,FAST1 I4A 72295016 LA RF,FAST1A-FAST1 I4A 72304016 BAL RR,CMPIL1 COMPILE ST 3FF8,RDV I4A 72313016 BC B,AV9A I4A 72322016 SPACE 1 I4A 72331016 AV9B XC AV12+6(2),AV12+6 I4A 72340016 XC AV12+19(2),AV12+19 72350015 MVC AV12+3(2),DREF1 72400015 MVC AV12+16(2),DREF1 72450015 LA RE,AV12 72500015 LA RF,AV13-AV12 COMPILE RELOCATION CODE 72550015 BAL RR,CMPIL1 72600015 AV9A CLI VSW,ON I4A 72650016 BC BNE,AV16 BRANCH IF NOT VARYING ARRAY 72700015 SPACE 72750015 MVC AV20+3(2),RREF 72800015 LA RB,3 72850015 CLI BITSW,ON 72900015 BC BNE,*+8 SKIP IF NOT BIT 72950015 LA RB,6 73000015 STC RB,AV22+4 SET LENGTH OF SHIFT 73050015 MVC AV22+13(2),DREF1 73100015 LH RB,N 73150015 AR RB,RB 73200015 AR RB,RB 73250015 STH RB,0(RS) SET OFFSET TO SMALLEST MULT 73300015 MVC AV22+16(2),0(RS) 73350015 LA RE,AV20 73400015 LA RF,AV23-AV20 73450015 BAL RR,CMPIL1 73500015 L RR,AVSLOT 73550015 BCR B,RR 73600015 EJECT 73650015 * AAD ADJUSTABLE STRING TO VDA ACCUMULATOR ROUTINE 73700015 * 73750015 * FUNCTION - ADDS THE SIZE OF AN ADJUSTABLE STRING ROUNDED 73800015 * UP AND CONVERTED TO BYTES IF NECESSARY TO THE VDA ACCUMULATOR 73850015 * 73900015 * ENTRY POINT - ALVACI 73950015 * 74000015 * EXTERNAL ROUTINES - CMPIL1 ADDS TEXT SKELETONS TO THE 74050015 * OUTPUT TEXT. 74100015 * 74150015 * EXITS - NORMAL - TO CALLING ROUTINE 74200015 * 74250015 * EXITS -ERROR - N/A 74300015 SPACE 2 74350015 ALVACI ST RR,0(RS) 74400015 AR RS,R4 74450015 SPACE 74500015 TM FDDATA(RD),X'02' 74550015 BC BZ,AI10 BRANCH IF NOT AREA 74600015 SPACE 74650015 LA RF,8 8 BYTE BOUND 74700015 BAL RR,AV30 FOR AREA 74750015 MVI AV2+7,X'07' 74800015 MVC AV2+11(2),CM8R 74850015 LA RE,AV14 ALIGN VDA ACCUMULATOR 74900015 LA RF,AV8-AV14 74950015 BAL RR,CMPIL1 75000015 SPACE 75002015 TM FDOT4B(RD),X'01' 75004015 BC BZ,AI10 BRANCH IF NO RDV 75006015 SPACE 75008015 BAL RR,RD6 MAKE RDV 75010015 SPACE 75012015 MVC RD16A+3(2),DREF1 DV REFERENCE 75014015 MVC RD12A+3(2),PAR1+2 RDV REFERENCE 75016015 MVC RD12A+11(2),PAR1+2 75018015 LA RE,RD16A 75020015 LA RF,RD13A-RD16A 75022015 BAL RR,CMPIL1 COMPILE CODE 75024015 SPACE 75026015 SR RS,R4 75028015 L RR,0(RS) 75030015 BCR B,RR AND RETURN 75032015 SPACE 75050015 AI10 MVC AI7+3(2),DREF1 RELOCATE DOPE VECTOR FROM 75100015 LA RE,AI7 START OF VDA 75150015 LA RF,AI8-AI7 75200015 BAL RR,CMPIL1 75250015 TM FDDATA(RD),X'04' 75300015 BC BZ,AI4 BRANCH IF ADJUSTABLE BIT STRING 75350015 SPACE 75400015 MVC AI1+3(2),DREF1 *** CHARACTER STRING 75450015 LA RE,AI1 75500015 LA RF,AI2-AI1 COMPILE CODE TO ADD LENGTH TO 75550015 TM FDDATA(RD),X'02' 75600015 BC BZ,*+8 BRANCH IF NOT AREA 75650015 LA RF,AI9-AI1 75700015 BAL RR,CMPIL1 VDA ACCUMULATOR 75750015 BC B,AI5 75800015 SPACE 75850015 AI4 MVC AI3+3(2),DREF1 *** BIT STRING 75900015 LA RE,AI3 75950015 LA RF,AI6-AI3 76000015 BAL RR,CMPIL1 76050015 SPACE 76100015 AI5 TM FDOT4B(RD),RDVBIT 76150015 BC BZ,*+8 SKIP IF NO RDV REQUIRED 76200015 BAL RR,RDV5 SET RDV 76250015 SR RS,R4 76300015 L RR,0(RS) 76350015 BCR B,RR EXIT 76400015 EJECT 76450015 * COMPILE ROUTINE 76500015 * 76550015 * FUNCTION - ADDS PSEUDO-CODE TEXT SKELETONS TO THE OUTPUT 76600015 * TEXT, AND CARRIES OUT HOUSEKEEPING FUNCTIONS SUCH AS 76650015 * MAINTAINING A COUNT OF THE COMPILED CODE, AND OBTAINING NEW 76700015 * TEXT BLOCKS. 76750015 * 76800015 * ENTRY POINTS (1) CMPIL1. ON ENTRY RE CONTAINS A POINTER 76850015 * TO A TEXT SKELETON WHICH IS TO BE ADDED TO THE OUTPUT, AND RF 76900015 * CONTAINS THE LENGTH OF THE SKELETON. 76950015 * (2) CMPILE. ON ENTRY THE BUFFER PS CONTAINS 77000015 * A TEXT SKELETON AND RF CONTAINS ITS LENGTH. 77050015 * 77100015 * EXTERNAL ROUTINES - ZUTXTC IN COMPILER CONTROL OBTAINS 77150015 * NEW TEXT BLOCKS. 77200015 * 77250015 * EXITS - NORMAL - TO CALLING ROUTINE 77300015 * 77350015 * EXITS - ERROR - N/A 77400015 SPACE 2 77450015 CMPILE ST RE,16(RS) SAVE RE 77500015 LA RE,PS SET POINTER TO BUFFER 77550015 CMPIL1 LH RB,REML LOAD REMAINING LENGTH 77600015 SR RB,RF SUBTRACT NEW LENGTH 77650015 BC BM,CR1 BRANCH IF STATEMENT WILL NOT FIT 77700015 STH RB,REML 77750015 CR3 LH RB,COUNT 77800015 AR RB,RF BUMP GENERATED TEXT COUNT 77850015 STH RB,COUNT 77900015 BCTR RF,0 77950015 L RB,TXTPT LOAD TEXT PT 78000015 EX RF,CR2 MOVE TEXT 78050015 AH RF,C1 78100015 AR RB,RF 78150015 ST RB,TXTPT SET NEW TEXT PT 78200015 ST RE,20(RS) 78250015 L RE,16(RS) RESET RE 78300015 BCR B,RR EXIT 78350015 SPACE 78400015 CR2 MVC 0(0,RB),0(RE) EXECUTED INSTRUCTION 78450015 SPACE 78500015 CR1 ST RR,0(RS) *** BLOCK FULL ROUTINE 78550015 ST RF,4(RS) 78600015 ST RE,20(RS) 78650015 LCR RB,RB CALCULATE EXCESS 78700015 STH RB,8(RS) SAVE EXCESS 78750015 LH RF,REML 78800015 LTR RF,RF 78850015 BC BZ,CR4 SKIP IF NOTHING TO MOVE 78900015 SPACE 78950015 BAL RR,CR3 MOVE AS MUCH AS POSSIBLE 79000015 SPACE 79050015 CR4 L RB,TXTREF *** COMPLETE JUMP TRIPLE 79100015 MVC 1(2,RB),COUNT SET COUNT IN JUMP TRIPLE 79150015 L RB,TXTPT 79200015 MVC 0(3,RB),CR5 MOVE ZERO BYTES AND EOB TO TEXT 79250015 SPACE 79300015 MVC PAR1+1(1),ZNXTLC+1 79350015 MVI PAR2+3,X'82' SET PRESENT BLOCK TO UNWANTED 79400015 L RB,ZUTXTC 79450015 BALR RR,RB GET NEW TEXT BLOCK AND CHAIN 79500015 MVC ZNXTLC+1(1),PAR1+1 SET CURRENT TEXT BLOCK 79550015 L RB,PAR2 79600015 ST RB,TXTREF SET JUMP TRIPLE POINTER 79650015 ST RB,TXSTRT 79700015 SPACE 79750015 MVC 0(5,RB),FN2 MOVE JUMP TRIPLE TO TEXT 79800015 LA RB,5(RB) 79850015 ST RB,TXTPT SET TEXT POINTER 79900015 MVC COUNT(2),C5 SET COUNT 79950015 LH RB,TXTSZ 80000015 SH RB,C12 CALCULATE REMAINING LENGTH 80050015 SPACE 80100015 L RE,20(RS) 80150015 AR RE,RF BUMP BUFFER POINTER 80200015 LH RF,8(RS) SET EXCESS LENGTH 80250015 BAL RR,CMPIL1+4 80300015 L RF,4(RS) RESTORE ORIGINAL LENGTH 80350015 L RR,0(RS) 80400015 BCR B,RR EXIT 80450015 EJECT 80500015 * INITIALIZE OBJECT CODE ROUTINE 80550015 * 80600015 * FUNCTIONS (1) OBTAINS THE TEXT ADDRESS OF THE NEXT 80650015 * AVAILABLE LOCATION AT THE END OF THE PROGRAM, IF THIS HAS NOT 80700015 * BEEN DONE BY A PREVIOUS CALL TO THIS ROUTINE. 80750015 * (2) SETS THE REFERENCE OF PSEUDO-CODE WORK 80800015 * SPACE FOR USE IN COMPILED CODE. 80850015 * (3) COMPILES AN SN3 PSEUDO-CODE ITEM WHICH 80900015 * IS SET TO POINT TO A DICTIONARY ENTRY SLOT USED TO CONTAIN A 80950015 * TEXT REFERENCE TO THIS CODE. THIS IS USED IN PROLOGUES AND 81000015 * DYNAMIC STORAGE ALLOCATION TO ARRANGE THIS CODE IN THE 81050015 * CORRECT SEQUENCE. 81100015 * (4) COMPILES A USE LIST OF REGISTERS(SYMBOLIC) 81150015 * USED IN CALCULATING MULTIPLIERS FOR ARRAYS AND STRUCTURES. 81200015 * (5) ON THE FIRST ENTRY, INITIALIZES A COUNT 81250015 * OF PSEUDO CODE GENERATED, AND PLACES A JUMP TRIPLE IN THE 81300015 * TEXT. 81350015 * 81400015 * ENTRY POINTS - (1) INOBJ1. ENTRY AT THIS POINT CAUSES 81450015 * A USE LIST OF SYMBOLIC REGISTERS TO BE GENERATED. 81500015 * (2) INOBJ. ON ENTRY AREF CONTAINS THE 81550015 * DICTIONARY REFERENCE OF THE ITEM FOR WHICH THE CODE IS TO BE 81600015 * GENERATED. VARYSW IS SET ON IF THE CODE TO BE GENERATED IS FOR 81650015 * ARRAYS OF VARYING STRINGS. 81700015 * 81750015 * EXTERNAL ROUTINES - CMPIL1. 81800015 * 81850015 * EXITS - NORMAL - TO CALLING ROUTINE 81900015 * 81950015 * EXITS - ERROR - N/A. 82000015 SPACE 2 82050015 INOBJ ST RR,0(RS) 82100015 AR RS,R4 82150015 STM RA,RD,0(RS) SAVE REGISTERS AND SUBROUTINE 82200015 LA RS,16(RS) LINK 82250015 MVI OBJSW,ON 82300015 CLI WRKSW,ON 82350015 BC BE,OC2 BRANCH IF WORKSPACE OBTAINED 82400015 OC6 BC B,OC7 SET JUMP TRIPLE (CHANGED TO NOP) 82450015 SPACE 82500015 OC9 MVI WRKSW,ON 82550015 MVC PAR1+2(2),BREF 82600015 BALR RR,RL GET ENTRY TYPE1 ADDRESS 82650015 L RD,PAR1 82700015 MVC TREF(2),13(RD) 82750015 SPACE 82800015 OC2 BC B,OC3 BRANCH IF NOT RDV 82850015 LA RB,11 82900015 MVC HOLD(2),AREF SET REF TO RDV SLOT 82950015 BC B,OC13 83000015 SPACE 83050015 OC3 CLI VARYSW,ON 83100015 BC BNE,OC12 BRANCH IF NOT IN VARY CODE 83150015 LH RB,N 83200015 AR RB,RB 83250015 AR RB,RB 83300015 LA RC,13(RB,RB) 83350015 AR RB,RC CALCULATE 12*N+13 83400015 MVC HOLD(2),DIMREF ADD TO DIMENSION TABLE REFERENCE 83450015 BC B,OC13 83500015 SPACE 83550015 OC12 CLI CLASS,TMP2 *** NOT VARYING CODE 83600015 BC BE,OC17 BRANCH IF TEMP TYPE 2 83650015 SPACE 83700015 MVC HOLD(2),AREF 83750015 SR RB,RB 83800015 LA RB,5(RB) SET 2ND FILE STAT REF 83850015 MVC PAR1+2(2),AREF 83900015 BALR RR,RL 83950015 L RC,PAR1 GET ITEM ADDRESS 84000015 OI FDOT1B(RC),X'04' SET ADJUSTABLE BIT 84050015 BC B,OC13 84100015 SPACE 84150015 OC17 MVC PAR1+2(2),AREF *** TEMP TYPE 2 84200015 BALR RR,RL 84250015 L RC,PAR1 GET ITEM REFERENCE 84300015 OI FDOT1B(RC),X'04' SET CODE GENERATED BIT 84350015 LA RB,FSOFF2+1 SET OFFSET TO OFFSET 2 SLOT FOR 84400015 TM 0(RC),X'0F' STRUCTURE 84450015 BC BNO,*+8 SKIP IF NOT DATA ITEM 84500015 LA RB,6(RB) BUMP OFFSET 84550015 MVC HOLD(2),AREF 84600015 SPACE 84650015 OC13 MVC PAR1+2(2),HOLD 84700015 BALR RR,RL 84750015 A RB,PAR1 84800015 ST RB,PAR2 84850015 MVC PAR1+2(2),HOLD 84900015 L RB,ZDABRF 84950015 BALR RR,RB 85000015 MVC OC18+2(2),PAR1+2 SET SN3 REFERENCE 85050015 LA RE,OC18+1 85100015 LA RF,3 85150015 BAL RR,CMPIL1 COMPILE SN3 85200015 SPACE 85250015 OC11 LA RB,20 85300015 SR RS,RB 85350015 LM RA,RD,4(RS) RESTORE REGISTERS 85400015 L RR,0(RS) 85450015 BCR B,RR EXIT 85500015 SPACE 85550015 * ROUTINE ENTERED ONCE ONLY FOR EACH PHASE TO SET THE 85600015 * SYMBOLIC REGISTERS 85650015 SPACE 85700015 OC7 NI OC6+1,X'0F' CONVERT BRANCH INSTRUCTION TO 85750015 MVI WRKSW1,ON 85800015 SR RB,RB 85850015 STH RB,COUNT ZEROIZE COUNT 85900015 SPACE 85950015 ST RB,PAR1 86000015 MVC PAR1+1(1),ZNXTLC+1 86050015 L RB,ZTXTAB 86100015 BALR RR,RB GET ADDRESS OF TEXT LOCATION 86150015 L RB,PAR1 86200015 ST RB,TXTPT SET TEXT POINTER 86250015 ST RB,TXSTRT 86300015 AH RB,ZNXTLC+2 86350015 ST RB,TXTREF SAVE ADDRESS OF JUMP TRIPLE 86400015 LH RC,TXTSZ 86450015 SH RC,ZNXTLC+2 CALCULATE REMAINING LENGTH 86500015 SPACE 86550015 SH RC,C12 86600015 BC BNM,OC19 BRANCH IF ROOM FOR JUMP AND EOB 86650015 SPACE 86700015 MVI 0(RB),EOB *** NO ROOM FOR JUMP. SET EOB 86750015 MVC PAR1+1(1),ZNXTLC+1 86800015 MVI PAR2+3,X'82' SET PRESENT BLOCK TO UNWANTED 86850015 L RB,ZUTXTC 86900015 BALR RR,RB GET NEW TEXT BLOCK AND CHAIN 86950015 MVC ZNXTLC+1(1),PAR1+1 SET CURRENT TEXT BLOCK 87000015 L RB,PAR2 87050015 ST RB,TXTPT SET NEW TEXT POINTERS 87100015 ST RB,TXTREF 87150015 ST RB,TXSTRT 87200015 SPACE 87250015 LH RC,TXTSZ 87300015 SH RC,C7 CALCULATE REMAINING LENGTH 87350015 SPACE 87400015 OC19 STH RC,REML SET REMAINING LENGTH IN BLOCK 87450015 MVC 0(5,RB),FN2 MOVE JUMP TRIPLE TO TEXT 87500015 LA RB,5(RB) 87550015 ST RB,TXTPT SET TEXT POINTER 87600015 MVC COUNT(2),C5 SET COUNT 87650015 BC B,OC9 87700015 EJECT 87750015 * WIND UP OBJECT CODE ROUTINE 87800015 * 87850015 * FUNCTION - ENSURES THAT THE PSEUDO-CODE WORKSPACE 87900015 * DICTIONARY ENTRY CONTAINS SUFFICIENT WORKSPACE FOR USE IN 87950015 * INITIALIZING STRUCTURES AND ARRAYS OF VARYING STRINGS AT 88000015 * OBJECT TIME 88050015 * 88100015 * ENTRY POINT - TERMWS 88150015 * 88200015 * EXTERNAL ROUTINES - N/A. 88250015 * 88300015 * EXITS -NORMAL - TO CALLING ROUTINE 88350015 * 88400015 * EXITS - ERROR - N/A 88450015 SPACE 2 88500015 TERMWS CLI WRKSW,ON EXIT IF NO CODE COMPILED IN THE 88550015 BCR BNE,RR CURRENT DSA 88600015 ST RR,0(RS) SAVE SUBROUTINE LINK 88650015 MVI WRKSW,OFF 88700015 MVC PAR1+2(2),TREF 88750015 BALR RR,RL GET ADDRESS OF TEMP TYPE 1 88800015 L RD,PAR1 88850015 LH RB,MAXLVL 88900015 CH RB,MAXDIM 88950015 BC BNL,*+8 89000015 LH RB,MAXDIM 89050015 SLL RB,3 CALCULATE MAX LEVEL*8 89100015 MVC 4(2,RS),3(RD) MOVE SPACE SIZE TO HALF WORD 89150015 CH RB,4(RS) 89200015 BC BNH,TW1 SKIP IF AREADY ENOUGH SPACE 89250015 STH RB,4(RS) 89300015 MVC 3(2,RD),4(RS) SET SPACE SIZE 89350015 SR RB,RB 89400015 STH RB,MAXLVL 89450015 STH RB,MAXDIM 89500015 TW1 L RR,0(RS) 89550015 BCR B,RR EXIT 89600015 EJECT 89650015 * FINISH ROUTINE 89700015 * 89750015 * FUNCTIONS (1) COMPLTES A JUMP TRIPLE CONTAINING A COUNT 89800015 * OF ALL THE PSEUDO-CODE GENERATED. 89850015 * (2) MARKS THE LAST TEXT BLOCK NOT WANTED 89900015 * (3) RELEASES CONTROL TO THE NEXT PHASE 89950015 * 90000015 * ENTRY POINT - FINISH. CALLED FROM CHAIN SCAN ROUTINE 90050015 * 90100015 * EXTERNAL ROUTINES - CMPIL1 90150015 * 90200015 * EXITS - NORMAL - TO COMPILER CONTROL ROUTINES. 90250015 * 90300015 * EXITS - ERROR - N/A 90350015 SPACE 2 90400015 FINISH CLI WRKSW1,ON 90450015 BC BNE,FN1 BRANCH IF NO OBJECT CODE 90500015 L RB,TXTREF 90550015 MVC 1(2,RB),COUNT SET COUNT IN JUMP TRIPLE 90600015 L RB,TXTPT 90650015 MVC 0(7,RB),FN7 MOVE ZERO EOP TRIPLE INTO TEXT 90700015 S RB,TXSTRT 90750015 STH RB,ZNXTLC+2 SET REFERENCE TO END OF TEXT 90800015 MVC PAR1+1(1),ZNXTLC+1 90850015 MVI PAR2+3,X'02' 90900015 L RL,ZALTER 90950015 BALR RR,RL MARK LAST BLOCK UNWANTED 91000015 SPACE 91050015 FN1 EQU * 91060016 LA RB,QUZZ+2 I4A 91071016 LA RC,QUZZ QU IS NOT WANTED I4A 91078016 FIN3 STM RB,RC,PAR1 I4A 91113016 L RL,REQEST I4A 91120016 BALR RR,RL MARK QU AS REQIRED I4A 91127016 SPACE 1 I4A 91134016 LA RB,1 I4A 91141016 ST RB,PAR1 91150015 L RL,ZURC RELEASE SCRATCH CORE 91200015 BALR RR,RL 91250015 SPACE 1 I4A 91258016 MVC PAR1+1(1),TXTNM I4A 91266016 MVI PAR2+3,X'01' I4A 91274016 L RL,ZALTER I4A 91282016 BALR RR,RL I4A 91290016 SPACE 91300015 LA RB,NAME1 91350015 ST RB,PAR1 91400015 XC PAR2(4),PAR2 91450015 L RL,RLSCTL 91500015 BCR B,RL 91550015 SPACE 2 91600015 * COMPILER ERROR ROUTINE 91650015 SPACE 91700015 ERROR LA RB,ERMSG 91750015 ST RB,PAR1 91800015 L RL,ZUPL 91850015 BALR RR,RL 91900015 L RL,ZABORT 91950015 BCR B,RL 92000015 EJECT 92000715 * PROCESS STRUCTURE - CALCULATE SIZE OF ARRAY OF STRING 92001415 * DOPE VECTORS. 92002115 * 92002815 * FUNCTION - TO GENERATE CODE TO CALCULATE 92003515 * THE SIZE OF THE ARRAY OF STRING DOPE VECTORS FOR 92004215 * VARYING STRINGS 92004915 * 92005615 * ENTRY POINT - FROM OBJECT ALIGN ADJACENT MINOR STRUCTURE 92006315 * 92007015 * EXTERNAL ROUTINES - (1) BUMPEQ IN IEMJL BUMPS THE EQU 92007715 * LABEL COUNT IN THE COMMUNICATIONS REGION 92008415 * (2) CMPIL1 IN IEMJL 92009115 * 92009815 * EXIT POINT - NORMAL - TO PS11 IN ADD ADJACENT STRUCTURE 92010515 * OFFSET 92011215 * 92011915 * EXIT - ERROR - NONE 92012615 SPACE 5 92013315 MP13 ST RR,0(RS) SAVE RETURN REGISTER 92014015 AR RS,R4 92014715 SPACE 92015415 CLC N(2),C1 92016115 BC BE,MP13A BRANCH IF ONLY ONE DIMENSION 92016815 SPACE 92017515 MVC N1(2),N *** SEVERAL DIMENSIONS 92018215 MVC DREF20(2),DREF1 92018915 LH RB,N 92019615 AR RB,RB 92020315 LA RB,4(RB,RB) CALCULATE 4*N+4 92021015 AH RB,DVOFF1 CALCULATE OFFSET TO BOUNDS 92021715 STH RB,0(RS) 92022415 MVC DREF20+3(2),0(RS) 92023115 MVC EQU51(2),ZEQMAX 92023815 MVC EQU52(2),ZEQMAX 92024515 BAL RR,BUMPEQ 92025215 LA RE,MP25 92025915 LA RF,MP26-MP25 92026615 BAL RR,CMPIL1 92027315 SPACE 92028015 MP13B SR RS,R4 92028715 L RR,0(RS) RESTORE RETURN REGISTER 92029415 BCR B,RR 92030115 SPACE 92030815 MP13A MVC MP25A+3(2),DREF1 *** SPECIAL CASE FOR 1 DIMENSION 92031515 MVC MP25A+11(2),DREF1 92032215 LH RB,DVOFF1 92032915 LA RB,8(RB) OFFSET IN STRC DV + 8 92033615 STH RB,0(RS) 92034315 MVC MP25A+6(2),0(RS) 92035015 LA RB,2(RB) OFFSET IN STRC DV + 10 92035715 STH RB,0(RS) 92036415 MVC MP25A+14(2),0(RS) 92037115 LA RE,MP25A 92037815 LA RF,MP26A-MP25A 92038515 BAL RR,CMPIL1 COMPILE CODE 92039215 BC B,MP13B 92039915 EJECT 92050015 * WORD STORAGE 92100015 SPACE 92150015 TXSTRT DS F 92200015 TXTPT DS F 92250015 TXTREF DS F 92300015 C4096 DC F'4096' 92350015 ADSLOT DC F'0' 92400015 AVSLOT DS F 92450015 OC18 DC X'00250000' 92500015 NAME1 DC C'JKJLJMZZ' 92550015 QUZZ DC C'QUZZ' I4A 92570016 SPACE 2 92600015 * HALF WORD STORAGE 92650015 SPACE 92700015 COUNT DS H 92750015 NBREF DS H 92800015 CM2R DS H 92820001 CM4R DS H 92850015 CM8R DS H 92900015 BLOCK1 DC H'0' 92950015 REML DS H 93000015 OMULTO DC H'15' 93050015 OMULTE DC H'14' 93100015 OZERO DC H'0' 93150015 MAXDIM DS H 93200015 WREF DC AL2(ZSTACH-DB) 93250015 WP2 DC AL2(ZSTACH-DB+2) TEMP WORKSPACE REF 93300015 C4 DC H'4' 93320001 C8 DC H'8' 93350015 C1 DC H'1' 93400015 C12 DC H'12' 93450015 C9 DC H'9' 93470015 C7 DC H'7' 93500015 C5 DC H'5' 93550015 XREF DC H'0' 93600015 SAVREF DC H'0' 93650015 SPACE 2 93700015 * BYTE STORAGE 93750015 SPACE 93800015 OP DS C OPERATION 93850015 ENDSW DS C 93900015 SWSAV DC X'00' 93950015 HOLD DC X'0000' 94000015 SPACE 5 94050015 END IEMJL 94100015 ./ ADD SSI=08010014,NAME=IEMJM,SOURCE=0 JM TITLE 'IEMJM, STRUCTURE PROCESSOR, OS/360, PL/1 COMPILER(F)' 00050015 * 00100015 * 00150015 * 00200015 * STATUS - CHANGE LEVEL 0 00250015 *3211 5037 00270016 * H249 RLSE18 259500,304000 00280001 * 25903 RLSE19 577200 25903 00290019 * APAR 23283 R19 DELETE 862000 23283 00295019 * 00300015 * 00350015 * 00400015 * FUNCTIONS - THIS MODULE CONTAINS A NUMBER OF SUBROUTINES 00450015 * USED IN PROCESSING ARRAYS, STRUCTURES AND DEFINED ITEMS. THESE 00500015 * SUBROUTINES ARE AS FOLLOWS- (1) CALCULATES THE MULTIPLIERS OF 00550015 * ARRAYS, OR GENERATES OBJECT CODE TO DO THIS. 00600015 * (2) CHECKS FOR DEFINED ITEMS, AND 00650015 * GENERTES CODE TO SET THE STORAGE ADDRESS ON FINDING THEM. 00700015 * (3) GENERATES CODE TO CALCULATE 00750015 * THE AMOUNT OF STORAGE REQUIRED FOR CONTROLLED ITEMS AND 00800015 * ADJUSTABLE TEMPORARIES. 00850015 * (4) CALCULATES THE AMOUNT OF 00900015 * STORAGE REQUIRED FOR STRING DOPE VECTORS OF ARRAYS OF VARYING 00950015 * STRINGS FOR DYNAMIC ITEMS. 01000015 * (5) GENERATES CODE TO SET THE 01050015 * PRIMARY DOPE VECTORS OF ARRAYS OF VARYING STRINGS TO REFER TO 01100015 * THE ARRAYS OF STRING DOPE VECTORS, RATHER THAN THE STORAGE. 01150015 * (6) GENERATES ERROR MESSAGES 01200015 * 01250015 * 01300015 * 01350015 * ENTRY POINTS (1) PROCDT PROCESSES NON STRUCTURED ARRAYS. 01400015 * (2) CHKDEF DETERMINES WHETHER OR NOT AN 01450015 * ITEM IS DEFINED, AND IF SO, GENERATES CODE TO SET THE ADDRESS 01500015 * OF STORAGE FOR THE ITEM. 01550015 * (3) STBASE GENERATES CODE TO CALCULATE THE 01600015 * START OF STORAGE USED BY A DEFINED ITEM. 01650015 * (4) NXTREF SCANS A STRUCTURE DICTIONARY 01700015 * ENTRY, AND RETURNS THE ADDRESS OF THE NEXT MEMBER 01750015 * (5) IPDV GENERATES CODE TO INITIALIZE THE 01800015 * PRIMARY DOPE VECTOR OF AN ARRAY OF VARYING STRINGS TO POINT TO 01850015 * THE ARRAY OF STRING DOPE VECTORS. 01900015 * (6) SETDVS, SETDVA CALCULATE THE SIZE OF 01950015 * DOPE VECTORS OF ARRAYS AND STRUCTURES WHICH REQUIRE DYNAMIC 02000015 * STORAGE, ALIGN THESE QUANTITIES SO THAT STORAGE IS ON A 02050015 * DOUBLE WORD BOUNDARY, AND ADD THIS QUANTITY TO THE ELEMENT 02100015 * STORAGE SIZE, TO GIVE THE TOTAL AMOUNT OF STORAGE TO BE 02150015 * OBTAINED DYNAMICALLY. 02200015 * (7) STDVS1, STDVA1 UAVE THE SAME FUNCTIONS 02250015 * AS IN (6) ABOVE, EXCEPT THAT OBJECT CODE IS GENERATED TO 02300015 * CARRY OUT THESE FUNCTIONS. 02350015 * (8) SVASZ CALCULATES THE SIZE OF ARRAYS OF 02400015 * STRING DOPE VECTORS FOR VARYING STRINGS IN STRUCTURES. 02450015 * (9) ERR1,ERR2 CALL THE ERROR EDITOR TO 02500015 * MAKE ERROR MESSAGE DICTIONARY ENTRIES. 02550015 * 02600015 * 02650015 * 02700015 * INPUT DICTIONARY. 02750015 * 02800015 * 02850015 * 02900015 * OUTPUT - (1) DIMENSION TABLES IN THE DICTIONARY ARE 02950015 * COMPLETED. 03000015 * (2) TEXT IS GENERATED FOR INCLUSION IN 03050015 * PROLOGUES, ALLOCATE, AND BUY STATEMENTS. 03100015 * 03150015 * 03200015 * 03250015 * EXTERNAL ROUTINES (1) SP54 IN IEMJK CALCULATES 03300015 * MULTIPLIERS AND GENERATES CODE FOR ADJUSTABLE ARRAYS. 03350015 * (2) ALVACA IN IEMJL GENERATES CODE 03400015 * TO ACCUMULATE THE SIZE OF AUTOMATIC ADJUSTABLE ARRAYS. 03450015 * (3) VOBJC IN IEMJL GENERATES CODE 03500015 * FOR ARRAYS OF VARYING STRINGS 03550015 * (4) CMPIL1 IN IEMJL ADDS TEXT TO THE 03600015 * OUTPUT STREAM. 03650015 * (5) PROCST IN IEMJK PROCESSES 03700015 * STRUCTURES 03750015 * (6) SET BREF IN IEMJL DETERMINES THE 03800015 * CORRECT ENTRY TYPE1. 03850015 * (7) INOBJ IN IEMJL INITIALIZES AN 03900015 * OBJECT CODE STATEMENT. 03950015 * 04000015 * 04050015 * 04100015 * EXITS - NORMAL - RETURN TO CALLING ROUTINE . 04150015 * 04200015 * 04250015 * 04300015 * EXITS - ERROR - N/A 04350015 * 04400015 * 04450015 * 04500015 * TABLES - N/A 04550015 * 04600015 * 04650015 * 04700015 * ATTRIBUTES - N/A 04750015 EJECT 04800015 IEMJM START 0 04850015 SPACE 4 04900015 USING *,12 04950015 SPACE 4 05000015 * BLOCK ORGANIZATION PARAMETERS 05050015 SPACE 05100015 USING *+X'1000',DIC 05150015 USING *+X'2000',CC 05200015 USING *+X'3000',9 05250015 USING *+X'4000',10 05300015 USING *+X'5000',R1 05350015 SPACE 2 05400015 DB EQU *+X'1000' 05450015 CB EQU *+X'2000' 05500015 B1 EQU *+X'3000' 05550015 B2 EQU *+X'4000' 05600015 SCRACH EQU *+X'5000' 05650015 SPACE 4 05700015 NAME DC C'JM' 05750015 SPACE 4 05800015 EJECT 05850015 * REGISTER PARAMETERS 05900015 SPACE 2 05950015 RA EQU 1 06000015 RB EQU 2 06050015 RC EQU 3 06100015 RD EQU 4 06150015 RE EQU 5 06200015 RF EQU 6 06250015 RS EQU 7 06300015 R1 EQU 8 06350015 R4 EQU 0 06400015 CC EQU 11 06450015 DIC EQU 13 06500015 RR EQU 14 06550015 RL EQU 15 06600015 SPACE 2 06650015 * CONDITION CODE PARAMETERS 06700015 SPACE 2 06750015 B EQU 15 06800015 BH EQU 2 06850015 BL EQU 4 06900015 BE EQU 8 06950015 BNH EQU 13 07000015 BNL EQU 11 07050015 BNE EQU 7 07100015 BP EQU 2 07150015 BM EQU 4 07200015 BZ EQU 8 07250015 BNM EQU 11 07300015 BNP EQU 13 07350015 BNZ EQU 7 07400015 BO EQU 1 07450015 BNO EQU 14 07500015 SPACE 2 07550015 * DICTIONARY PARAMETERS 07600015 SPACE 2 07650015 FSDIMI EQU 19 07700015 FSDSTI EQU 22 07750015 FSSSTI EQU 19 07800015 FDSYMI EQU 19 07850015 FDDATA EQU 15 07900015 FPWIDB EQU 11 07950015 FDOT1B EQU 10 08000015 FDVARB EQU 11 08050015 FDOT2B EQU 12 08100015 FDOT3B EQU 13 08150015 FDDIMI EQU 25 08200015 FDOT4B EQU 14 08250015 FSVARI EQU 15 08300015 NOPRC EQU X'02' 08350015 RDVBIT EQU X'01' 08400015 STATIC EQU X'00' 08450015 NDVBIT EQU X'80' NEEDS DOPE VECTOR BIT 08500015 SPACE 2 08550015 * MISCELLANEOUS PARAMETERS 08600015 SPACE 2 08650015 STYPE EQU X'C0' 08700015 OFF EQU X'00' 08750015 ON EQU X'FF' 08800015 CONTRL EQU X'80' 08850015 AUTO EQU X'C0' 08900015 SPACE 2 08950015 * COMMUNICATIONS PARAMETERS 09000015 SPACE 2 09050015 ZCOMM EQU DB+304 09100015 PAR1 EQU DB+128 09150015 PAR2 EQU DB+132 09200015 LOCK EQU DB+274 09250015 ZDICRF EQU CB+X'2C' 09300015 ZDRFAB EQU CB+X'34' 09350015 TXTSZ EQU DB+266 09400015 ZNXTLC EQU DB+276 09450015 ZUPL EQU CB+X'08' 09500015 ZUGC EQU CB+X'10' 09550015 ZURC EQU CB+X'18' 09600015 ZABORT EQU CB+X'20' 09650015 ZTXTAB EQU CB+X'54' 09700015 ZCHAIN EQU CB+X'58' 09750015 ZALTER EQU CB+X'5C' 09800015 ZMYNAM EQU DB+112 09850015 ZSTACH EQU ZCOMM+68 09900015 ZCITEM EQU ZCOMM+80 09950015 ZPROC1 EQU ZCOMM+64 10000015 ZSMREG EQU ZCOMM+40 10050015 ZCONCH EQU ZCOMM+78 10100015 ZEQMAX EQU ZCOMM+82 10150015 ZLOADW EQU CB+X'24' 10200015 PAR6 EQU DB+148 10250015 PAR7 EQU PAR6+4 10300015 ZLOCK EQU DB+X'112' 10320017 ZUERR EQU CB+X'30' 10350015 SPACE 2 10400015 * OUT OF BLOCK ROUTINES 10450015 SPACE 2 10500015 PROCST EQU B1+2 10550015 SP54 EQU PROCST+4 10600015 ELSIZ EQU SP54+4 10650015 MKDVD EQU ELSIZ+4 10700015 MOVEMP EQU MKDVD+4 10720017 BASED EQU SCRACH+4 10750015 SPEC EQU BASED+4 I4A 10760016 TRIAL EQU SPEC+4 10770016 SETBRF EQU B2+2 10800015 ADDCN EQU SETBRF+4 10850015 SUBCN EQU ADDCN+4 10900015 LOADCN EQU SUBCN+4 10950015 CMPILE EQU LOADCN+4 11000015 INOBJ EQU CMPILE+4 11050015 CMPIL1 EQU INOBJ+4 11100015 TERMWS EQU CMPIL1+4 11150015 FINISH EQU TERMWS+4 11200015 CHNSCN EQU FINISH+4 11250015 SVARY EQU CHNSCN+4 11300015 VOBJC EQU SVARY+4 11350015 ALVACA EQU VOBJC+4 11400015 BUMPEQ EQU ALVACA+4 11450015 MKCNST EQU BUMPEQ+4 11500015 CS2 EQU MKCNST+4 11550015 MP13 EQU CS2+4 11570015 BEGIN EQU MP13+4 11580016 SPACE 2 11600015 * OUT OF BLOCK STORAGE 11650015 SPACE 2 11700015 REGSAV EQU SCRACH+X'638' 11750001 STCKPT EQU REGSAV+X'78' 11800015 FRSTBD EQU STCKPT+4 11830015 OACC EQU FRSTBD+2 11860015 OWRK1 EQU OACC+2 11900015 OWRK2 EQU OWRK1+2 11950015 OOFF EQU OWRK2+2 12000015 OSTACK EQU OOFF+2 12050015 OLNGTH EQU OSTACK+2 12100015 AREF EQU OLNGTH+2 12150015 BREF EQU AREF+2 12200015 MREF EQU BREF+2 12250015 RREF EQU MREF+2 12300015 VREF EQU RREF+2 12350015 TREF EQU VREF+2 12400015 OFFSET EQU TREF+2 12450015 BOUND EQU OFFSET+2 12500015 MAXBND EQU BOUND+2 12550015 DIM1 EQU MAXBND+2 12600015 N EQU DIM1+2 12650015 DREF1 EQU N+2 12700015 CLASS EQU DREF1+2 12750015 WRKSW EQU CLASS+1 12800015 OBJSW EQU WRKSW+1 12850015 DIMSW EQU OBJSW+1 12900015 PS EQU DIMSW+1 12950015 WRKSW1 EQU PS+48 13000015 ALLSW EQU WRKSW1+1 13050015 LENGTH EQU ALLSW+1 13100015 DIMREF EQU LENGTH+4 13150015 NREF EQU DIMREF+2 13200015 DEFSW EQU NREF+2 13250015 SIZSW EQU DEFSW+1 13300015 DIM EQU SIZSW+1 13350015 DREF EQU DIM+2 13400015 DVOFF EQU DREF+2 13450015 BITSW EQU DVOFF+2 13500015 ADJSW EQU BITSW+1 13550015 VARYSW EQU ADJSW+1 13600015 MPL1 EQU VARYSW+1 13650015 MCOBOL EQU MPL1+2 13700015 QUFLAG EQU MCOBOL+2 I4A 13730016 DUMMY EQU QUFLAG+1 I4A 13760016 COBLSW EQU DUMMY+1 I4A 13790016 CNTGSW EQU COBLSW+1 13850015 AREASW EQU CNTGSW+1 13900015 BASESW EQU AREASW+1 13950015 ADJ1SW EQU BASESW+1 14000015 V1SW EQU ADJ1SW+1 14050015 SUPRDV EQU V1SW+1 I4A 14070016 BLOCK EQU MP13+8 I4A 14110016 LEVEL EQU BLOCK+2 14150015 MAXLVL EQU LEVEL+2 14200015 DONSW EQU MAXLVL+2 14250015 EJECT 14300015 * EQUS FOR TEXT SKELETONS HELD IN SCRATCH CORE 14350015 SPACE 5 14400015 AD1 EQU SCRACH+X'1C2' I4A 14450016 AD2 EQU AD1+3 14500015 AD3 EQU AD2+1 14550015 AD4 EQU AD3+2 14600015 SB21 EQU AD4+2 14650015 SB22 EQU SB21+7 14700015 SPACE 14750015 CD16 EQU SB22 14800015 CD17 EQU CD16+15 14850015 CD18 EQU CD17+5 14900015 CD91 EQU CD18 14950015 CD92 EQU CD91+10 15000015 CD93 EQU CD92+5 15050015 SPACE 15100015 CD19 EQU CD93 15150015 CD20 EQU CD19+25 15200015 CD21 EQU CD20+10 15250015 SPACE 15300015 CD19A EQU CD21 15350015 CD19B EQU CD19A+25 15400015 SPACE 15450015 CD26 EQU CD19B 15500015 CD27 EQU CD26+7 15550015 CD30 EQU CD27 15600015 SPACE 15650015 CD31 EQU CD30+5 15700015 SPACE 15750015 CD32 EQU CD31 15800015 CD33 EQU CD32+15 15850015 CD34 EQU CD33+10 15900015 SPACE 15950015 SB6 EQU CD34 16000015 SB7 EQU SB6+8 16050015 SPACE 16100015 SB9 EQU SB7 16150015 SB11 EQU SB9+20 16200015 SB10 EQU SB11+13 16250017 SPACE 16300015 SB16 EQU SB10 16350015 SB17 EQU SB16+16 16400015 SB18 EQU SB17+33 16450015 SB19 EQU SB18+5 16500015 SPACE 16550015 RD8 EQU SB19 16600015 RD9 EQU RD8+13 16650015 RD10 EQU RD9+21 16700015 RD11 EQU RD10+8 16750015 SPACE 16800015 RD16 EQU RD11 16850015 RD12 EQU RD16+8 16900015 RD13 EQU RD12+16 16950015 SPACE 17000015 SA1 EQU RD13 17050015 SA2 EQU SA1+3 17100015 SA3 EQU SA2+5 17150015 SA4 EQU SA3+2 17200015 SA5 EQU SA4+4 17250015 SA7 EQU SA5+4 17300015 SA6 EQU SA7+2 17350015 SPACE 17400015 MP9 EQU SA6 17450015 MP6 EQU MP9+6 17500015 MP8 EQU MP6+5 17550015 MP7 EQU MP8+5 17600015 MP5 EQU MP7+5 17650015 MP10 EQU MP5+10 17700015 SPACE 17750015 MP25 EQU MP10 17800015 SDVSIZ EQU MP25+9 17850015 N1 EQU SDVSIZ+6 17900015 DREF20 EQU N1+5 17950015 EQU51 EQU DREF20+14 18000015 EQU52 EQU EQU51+49 18050001 MP26 EQU EQU52+16 18100015 SPACE 18150015 SV7 EQU MP26 18200015 SV8 EQU SV7+13 18250015 SPACE 18300015 BITCVN EQU SV8 18350015 DREF11 EQU BITCVN+3 18400015 DREF17 EQU DREF11+28 18450015 SV9 EQU DREF17+5 18500015 TREF1 EQU SV9+8 18550015 L1 EQU TREF1+5 18600015 DREF12 EQU L1+3 18650015 BNDPT EQU DREF12+2 18700015 INSET1 EQU BNDPT+2 18750015 EQU11 EQU BNDPT+3 18800015 DCNT1 EQU EQU11+18 18850015 EQU21 EQU DCNT1+3 18900015 DREF13 EQU EQU21+5 18950015 EQU22 EQU DREF13+43 19000001 DREF14 EQU EQU22+5 19050015 SV10 EQU DREF14+5 19100015 DREF15 EQU SV10+24 19150015 SLPT EQU DREF15+4 19200015 SV16 EQU SLPT+10 19250015 DCNT2 EQU SV16+14 19300015 EQU31 EQU DCNT2+3 19350015 EQU41 EQU EQU31+31 19400015 EQU12 EQU EQU41+15 19450015 EQU42 EQU EQU12+3 19500015 DREF16 EQU EQU42+5 19550015 EQU32 EQU DREF16+43 19600001 SV12 EQU EQU32+2 19650015 SPACE 19700015 SV13 EQU SV12 19750015 SV14 EQU SV13+20 19800015 SPACE 19850015 IP1 EQU SV14 19900015 IP2 EQU IP1+8 19950015 IP3 EQU IP2+16 20000015 IP4 EQU IP3+8 20050015 IP10 EQU IP4+3 20100015 IP5 EQU IP10+15 20150015 IP6 EQU IP5+10 20200015 IP7 EQU IP6+8 20250015 IP8 EQU IP7+8 20300015 IP11 EQU IP8+10 20350015 IP9 EQU IP11+28 20400015 IP12 EQU IP9+18 20450015 SPACE 20500015 SD33 EQU IP12 20550015 SD15 EQU SD33+8 20600015 SD18 EQU SD15+26 20650015 SD16 EQU SD18+5 20700015 SD19 EQU SD16+13 20750015 SD34 EQU SD19+8 20800015 SPACE 20850015 SD35 EQU SD34 20860016 SD21 EQU SD35+8 20870016 SD36 EQU SD21+8 20880016 SPACE 20890016 SD37 EQU SD36 20900016 SD38 EQU SD37+26 20910016 SPACE 20920016 SD40 EQU SD38 20930016 SD41 EQU SD40+18 20940016 SPACE 20950016 SD42 EQU SD41 20960016 SD43 EQU SD42+8 20970016 SPACE 20980016 SD37A EQU SD43 20990016 SD38A EQU SD37A+8 21000016 SPACE 21010016 FAST1 EQU SD38A 21020016 FAST1A EQU FAST1+8 21030016 SPACE 21040016 FAST2 EQU FAST1A 21050016 FAST2A EQU FAST2+8 21060016 SPACE 21070016 RD16A EQU FAST2A 21080016 RD12A EQU RD16A+21 21090016 RD13A EQU RD12A+16 21100016 SPACE 1 I4A 21110016 P1 EQU RD13A I4A 21120016 P2 EQU P1+5 I4A 21130016 SPACE 1 I4A 21140016 MP25A EQU P2 I4A 21150016 MP26A EQU MP25A+34 I4A 21160016 EJECT 21489315 * WORK AREAS PRIVATE TO IEMJM 21489615 SPACE 21489915 SDSLOT EQU SCRACH+X'730' 21490201 SVEBIT EQU SDSLOT+4 21490515 CM8 EQU SVEBIT+4 21490815 CM32 EQU CM8+4 21491115 SVZ EQU CM32+4 21491415 GTSLOT EQU SVZ+4 21491715 SBSLOT EQU GTSLOT+4 21492015 CDSLOT EQU SBSLOT+4 21492315 RDSLOT EQU CDSLOT+4 21492615 SAVERD EQU RDSLOT+4 21492915 SPACE 21493215 POSOP EQU SAVERD+4 21493515 BASREF EQU POSOP+2 21493815 C4096 EQU BASREF+2 21494115 DIMZ EQU C4096+2 21494415 BTREF EQU DIMZ+2 21494715 DFREF EQU BTREF+2 21495015 C1 EQU DFREF+2 21495315 CM1 EQU C1+2 21495615 C7 EQU CM1+2 21495915 C2 EQU C7+2 21496215 C12 EQU C2+2 21496515 REG15 EQU C12+2 21496815 SPACE 21497115 MESS EQU REG15+2 21497415 MESS2 EQU MESS+4 21497715 SPACE 21498015 ABSW EQU MESS2+4 21498315 CSW EQU ABSW+1 21498615 NEWFLG EQU CSW+1 21498915 CNSIDR EQU NEWFLG+1 21499215 SPACE 21499316 CD91A EQU CNSIDR+1 5037 21499416 CD91B EQU CD91A+20 21499517 CD91C EQU CD91B+10 21499617 CD91D EQU CD91C+5 21499717 EJECT 21500015 * EXTERNALLY REFERENCED ROUTINES 21550015 SPACE 21600015 BC B,BEGIN 21700015 BC B,PROCDT 21750015 BC B,ERR2 21800015 BC B,IPDV 21850015 BC B,DP5 21900015 BC B,SETDVS 21950015 BC B,STDVS1 22000015 BC B,ERR1 SIZE OVERFLOW ROUTIEN 22050015 BC B,CHKDEF 22100015 BC B,RDV1 22150015 BC B,RDV2 22200015 BC B,RDV3 22250015 BC B,RDV4 22300015 BC B,RDV5 22350015 BC B,STBAS1 22400015 BC B,NXTREF 22450015 BC B,NXTRF1 22500015 BC B,RD6 22520015 SPACE 2 22550015 * EXTERNALLY REFERENCED STORAGE 22600015 SPACE 22650015 ACC DS F 22700015 DVOFF1 DS H 22750015 BSREF DS H 22800015 VSW DS C 22850015 DVDSW DS C 22900015 SPACE 2 23600015 EJECT 23650015 * PROCESS DIMENSION TABLE ROUTINE. 23700015 * 23750015 * FUNCTIONS - (1) CALCULATES ARRAY MULTIPLIERS AND VIRTUAL 23800015 * ORIGINS WHERE POSSIBLE AT COMPILE TIME 23850015 * (2) GENERATES CODE TO CARRY OUT THESE 23900015 * FUNCTIONS AT OBJECT TIME WHEN BOUNDS OR STRING LENGTHS ARE 23950015 * SPECIFIED BY EXPRESSIONS 24000015 * 24050015 * ENTRY POINT - PROCDT. ON ENTRY RD CONTAINS THE ADDRESS 24100015 * OF AN ARRAY DICTIONARY ENTRY, AND AREF CONTAINS THE REFERENCE. 24150015 * 24200015 * EXTERNAL ROUTINES (1) SP54 IN THE STRUCTURE PROCESSOR 24250015 * ROUTINE CALCULATES MULTIPLIERS AND GENERATES OBJECT CODE. 24300015 * (2) SETDVA AND STDVA1 CALCULATE THE 24350015 * SIZE OF DOPE VECTOR OF THE ARRAY AND RELOCATE THE VIRTUAL 24400015 * ORIGIN OF THE ARRAY BY THAT AMOUNT 24450015 * (3) ALVACA IN IEMJL GENERATES CODE TO 24500015 * ALIGN THE VDA ACCUMULATOR REGISTER WHERE NECESSARY, TO 24550015 * RELOCATE THE VIRTUAL ORIGIN OF THE ARRAY FROM THE START OF THE 24600015 * VDA, AND TO DUMP THE VDA ACCUMULATOR BY THE SIZE OF THE ARRAY. 24650015 * (4) CMPJL1 IN IEMJL COMPILES TEXT 24700015 * SKELETONS 24750015 * (5) VOBJC IN IEMJL COMPILES CODE TO 24800015 * SET UP THE SECONDARY DOPE VECTORS FOR ARRAYS OF VARYING 24850015 * STRINGS. 24900015 * 24950015 * EXITS - NORMAL - TO CALLING ROUTINE 25000015 * 25050015 * EXITS - ERROR - N/A 25100015 SPACE 2 25150015 PROCDT TM FDOT4B(RD),X'02' 25200015 BCR BO,RR EXIT IF NEEDS NO PROCESSING 25250015 SPACE 25300015 ST RR,0(RS) SAVE LINK 25350015 AR RS,R4 25400015 NI DP16+1,X'0F' SET STAR SWITCH OFF 25450015 CLI CLASS,CONTRL 25500015 BC BNE,DP14 BRANCH IF NOT CONTROLLED 25550015 TM FDVARB(RD),X'02' 25600015 BC BO,DP14 BRANCH IF BASED 25650015 TM FDVARB(RD),X'01' 25700015 BC BZ,DP7 OMIT PROCESSING IF DECLARED 25750015 TM FDOT1B(RD),X'03' 25800015 BC BZ,DP14 BRANCH IF NO STARS 25850015 TM 0(RD),X'0F' 25900015 BO DAT1 DATA ITEM? H249 25920001 TM 0(RD),X'0C' IS IT EVENT OR TASK H249 25940001 BNO DP7 NO H249 25960001 DAT1 EQU * H249 25980001 TM FDDATA(RD),X'80' 26000015 BC BO,DP7 BRANCH IF NO STRINGS 26050015 OI DP16+1,X'F0' SET STAR SWITCH ON 26100015 SPACE 26150015 DP14 MVI DIMSW,ON 26200015 MVI OBJSW,OFF 26250015 SR RB,RB 26300015 STH RB,DIM CLEAR DIM 26350015 STH RB,DVOFF CLEAR DVOFF 26400015 STH RB,DVOFF1 CLEAR DVOFF1 26450015 SPACE 26500015 LR RC,RD 26550015 TM 0(RD),X'0F' 26600015 BC BNO,*+8 BRANCH IF NOT DATA 26650015 LA RC,6(RC) BUMP POINTER 26700015 TM FDVARB(RD),X'80' 26750015 BC BZ,*+6 SKIP IF NO 2ND OFFSET SLOT 26800015 AR RC,R4 BUMP POINTER 26850015 MVC N+1(1),15(RC) SET DIMENSIONALITY 26900015 MVC DIM1+1(1),15(RC) 26950015 MVC DIMREF(2),16(RC) SET REF TO DIMENSION TABLE 27000015 SPACE 27050015 DP16 BC B,DP15 *** STAR SWITCH. BRANCH IF STAR 27100015 SPACE 27150015 MVI ADJ1SW,OFF SET ADJ1SW OFF 27200015 SPACE 27250015 BC B,SP54 *** PROCESS DIMENSION TABLE 27300015 SPACE 27350015 * RETURNS AFTER PROCESSING 27400015 DP5 CLI ADJ1SW,ON 27450015 BC BE,DP8 BRANCH IF BASED ADJUSTABLE 27500015 CLI OBJSW,ON 27550015 BC BE,DP6 BRANCH IF ADJUSTABLE 27600015 CLI DEFSW,ON 27650015 BC BE,DP18 BRANCH IF DEFINED NON-ADJUSTABLE 27700015 TM CLASS,STYPE 27750015 BC BNM,DP10+6 BRANCH IF NOT CONTROLLED 27800015 CLI BASESW,ON 27850015 BC BE,DP10+6 BRANCH IF BASED 27900015 L RF,LENGTH 27950015 BAL RR,SETDVA SET DOPE VECTOR FOR DYNAMIC 28000015 BC B,DP12 28050015 SPACE 28100015 DP10 MVC 3(2,RD),LENGTH+2 SET ARRAY SIZE IN DIM TABLE 28150015 MVI DP11+1,X'00' UNSET SET CONSTANT BIT 28200015 SPACE 28250015 DP12 L RB,8(RD) 28300015 LR RC,RB 28350015 SRL RB,3 CONVERT VIRTUAL ORIGIN TO BYTES 28400015 ST RB,8(RD) 28450015 SLL RC,5 CALCULATE BIT OFFSET AND STORE 28500015 STC RC,8(RD) IN DIMENSION TABLE 28550015 SPACE 28600015 TM CLASS,STYPE 28650015 BC BNM,*+12 NOT DYNAMIC 28700015 CLI BASESW,ON 28750015 BC BNE,DP8 BRANCH IF NOT BASED 28800015 SPACE 28850015 L RB,LENGTH *** STORE LENGTH IN DIM TABLE 28900015 STC RB,3(RD) STORE LEAST SIGNIFICANT BYTE 28950015 SRL RB,8 29000015 STH RB,6(RD) STORE MOST SIGNIFICANT BYTES 29050015 BAL RR,RDV6 MAKE RDV ENTRY IF NECESSARY 29100015 BAL RR,SYBA RESTORE ABS ADDRESS OF ARRAY 29120001 BC B,DP11+4 29150015 SPACE 29200015 DP6 CLI DEFSW,ON *** ADJUSTABLE 29250015 BC BE,DP19 BRANCH IF DEFINED 29300015 MVI ADJSW,OFF 29350015 TM CLASS,STYPE 29400015 BC BNM,DP13 BRANCH IF NOT DYNAMIC 29450015 CLI BASESW,ON 29500015 BC BE,DP13 BRANCH IF BASED 29550015 BAL RR,STDVA1 SET DOPE VECTOR FOR ADJUSTABLE 29600015 BC B,*+8 DYNAMIC ARRAY 29650015 SPACE 29700015 DP13 BAL RR,ALVACA ALIGN FOR VDA 29750015 SPACE 29800015 DP8 BAL RR,SYBA GET ADDRESS OF ARRAY 29860001 * 29920001 DP11 OI FDOT4B(RD),X'00' SET CONSTANT FOR SIZE BIT 30000015 TM 0(RD),X'0F' 30050015 BC BNO,DP20 BRANCH IF NOT DATA 30100015 TM FDDATA(RD),X'80' 30150015 BC BO,DP7 BRANCH IF NOT A STRING 30200015 TM CLASS,STYPE 30250015 BC BZ,DP7 BRANCH IF STATIC STORAGE 30300015 SPACE 30350015 DP15 EQU * H249 30370001 TM 0(RD),X'0F' H249 30390001 BNO DP21 MUST BE VENT OR TASK H249 30410001 TM FDDATA(RD),X'02' H249 30430001 BC BO,*+12 BRANCH IF AREA 30450015 TM FDDATA(RD),X'10' 30500015 BC BZ,DP7 BRANCH IF NOT VARYING 30550015 DP21 MVC DREF1(2),AREF 30600015 OI DREF1+1,X'01' 30650015 BAL RR,VOBJC CREATE VARYING OBJECT CODE 30700015 SPACE 30750015 DP7 MVI DIMSW,OFF 30800015 MVI OBJSW,OFF 30850015 * 30870001 DP17 BAL RR,SYBA RESTORE ENTRY 30890001 * AND RETURN 30910001 DP22 SR RS,R4 30930001 L RR,0(RS) 30950015 BCR B,RR EXIT 31000015 SPACE 31050015 SPACE 31100015 DP19 LH RB,CM1 31150015 MVC PAR1+2(2),DIMREF SET DIM TABLE ADDRESS 31200015 BALR RR,RL 31250015 L RD,PAR1 31300015 BC B,*+8 31350015 SPACE 31400015 DP18 L RB,LENGTH *** DEFINED NON-ADJUSTABLE 31450015 STC RB,3(RD) STORE LEAST SIGNIFICANT BYTE 31500015 SRL RB,8 31550015 STH RB,6(RD) STORE MOST SIGNIFICANT BYTES 31600015 BC B,DP17 EXIT 31650015 SPACE 31700015 DP20 TM CLASS,STYPE 31750015 BC BZ,DP7 BRANCH IF STATIC 31800015 TM 0(RD),X'07' 31850015 BC BO,DP7 BRANCH IF LABEL 31900015 BC B,DP21 31950015 EJECT 32000015 * CHECK DEFINED ROUTINE 32050015 * 32100015 * FUNCTIONS (1) CHECK WHETHER OR NOT A DATA ELEMENT IS 32150015 * DEFINED. 32200015 * (2) IF AN ITEM IS DEFINED, SET UP CODE TO 32250015 * ADDRESS THE DEFINED ITEM, PROCESSING THE BASE FIRST, IF 32300015 * NECESSARY. 32350015 * 32400015 * ENTRY POINT - CHKDEF. ON ENTRY RD CONTAINS THE ADDRESS 32450015 * OF A DICTIONARY ENTRY, AND AREF CONTAINS ITS DICTIONARY 32500015 * REFERENCE. 32550015 * 32600015 * EXTERNAL ROUTINES -(1) PROCST IN IEMJK MAPS STRUCTURES 32650015 * (2) PROCDT IN IEMJM MAPS ARRAYS 32700015 * (3) TERMWS IN IEMJL SETS THE AMOUNT 32750015 * OF WORKSPACE REQUIRED. 32800015 * (4) CMPIL1 IN IEMJL COMPILES TEXT. 32850015 * (5) STBASE IN IEMJM GENERATES CODE 32900015 * TO SET THE STARTING ADDRESS OF THE DEFINED ITEM IN AN OBJECT 32950015 * REGISTER. 33000015 * 33050015 * EXITS - NORMAL -(1) IF ITEM NEEDS FURTHER PROCESSING TO 33100015 * THE CALLING ADDRESS+8, AND IF NO FURTHER PROCESSING IS 33150015 * REQUIRED, TO THE CALLING ADDRESS+4. 33200015 * 33250015 * EXITS - ERROR - N/A 33300015 SPACE 2 33350015 CHKDEF MVI DEFSW,OFF 33400015 MVI BASESW,OFF SET BASESW OFF 33450015 MVI COBLSW,OFF SET COBOL SWITCH OFF 33500015 MVI ADJ1SW,OFF 33600015 MVI DONSW,OFF 33650015 MVI ADJSW,OFF 33700015 MVI OBJSW,OFF 33750015 MVI VARYSW,OFF 33800015 MVI SUPRDV,OFF I4A 33820016 TM FDOT4B(RD),NOPRC EXIT IF NEEDS NO DOPE VECTOR 33850015 BC BZ,CD112 INITIALISATION BIT IS SET 33860016 TM 0(RD),X'30' 33870016 BCR BZ,RR 33880016 TM FDOT1B(RD),X'10' 33890016 BCR BZ,RR 33900016 BC B,MKDVD 33910016 SPACE 33920016 CD112 TM FDVARB(RD),X'02' 33930016 BC BO,CD1 BRANCH IF DEFINED 34000015 SPACE 34050015 CD111 TM 7(RD),X'01' 34100015 BCR BO,RR EXIT IF ALREADY PROCESSED 34150015 OI 7(RD),X'01' SET PROCESSED BIT 34200015 TM FDOT1B(RD),X'40' 34250015 BC BZ,4(RR) PROCESS ITEM IF NOT DEFINED ON 34300015 MVI DONSW,ON SET DEFINED ON SWITCH 34350015 BC B,4(RR) PROCESS ITEM 34400015 SPACE 34450015 CD1 CLI CLASS,CONTRL 34500015 BC BNE,*+12 BRANCH IF NOT BASED 34550015 MVI BASESW,ON SET BASESW ON 34600015 BC B,CD111 34650015 ST RR,CDSLOT *** DEFINED 34700015 MVI ABSW,OFF SET ADJUSTABLE BASE SW OFF 34750015 MVI CNSIDR,OFF 34770015 MVI DONSW,ON 34800015 SR RB,RB 34850015 IC RB,2(RD) SET LENGTH TO BCD 34900015 SH RB,C7 34950015 TM 0(RD),X'0E' 35000015 BC BO,*+8 35050015 SH RB,C2 35100015 AR RB,RD 35150015 MVC BSREF(2),0(RB) SET REFERENCE TO BASE 35200015 MVC DFREF(2),AREF SAVE REFERENCE TO DEF 35250015 SPACE 35300015 MVC PAR1+2(2),BSREF 35350015 BALR RR,RL 35400015 L RC,PAR1 GET BASE ENTRY 35450015 TM 0(RC),X'30' 35500015 BC BZ,CD37 BRANCH IF SCALAR 35550015 TM 0(RC),X'20' 35600015 BC BZ,CD3 BRANCH IF ARRAY 35650015 SPACE 35700015 MVC BTREF(2),BSREF *** STRUCTURE OR MEMBER BASE 35750015 CD5 TM FDOT4B(RC),X'04' 35800015 BC BO,CD4 BRANCH IF MAJOR STRUCTURE 35850015 LR RB,RC 35900015 TM 0(RC),X'0F' 35950015 BC BNO,*+8 SKIP IF NOT DATA ITEM 36000015 LA RB,6(RB) 36050015 TM 0(RC),X'10' 36100015 BC BZ,*+8 SKIP IF NOT DIMENSIONED 36150015 LA RB,3(RB) 36200015 MVC BTREF(2),FSVARI+6(RB) SET REF TO CONTAINING STRUCT 36250015 CD7 MVC PAR1+2(2),BTREF 36300015 BALR RR,RL GET CONTAINING ENTRY 36350015 L RC,PAR1 36400015 BC B,CD5 36450015 SPACE 36500015 CD4 TM 7(RC),X'01' *** MAJOR STRUCTURE FOUND 36550015 BC BO,CD6 BRANCH IF STRUCTURE PROCESSED 36600015 SPACE 36650015 OI 7(RC),X'01' SET PROCESSED BIT 36700015 MVC AREF(2),BTREF PROCESS BASE STRUCTURE 36750015 LR RD,RC 36800015 BAL RR,SETBRF 36850015 BAL RR,PROCST 36900015 CLI DVDSW,ON 36950015 BC BNE,CD4A BRANCH IF NO DVD REQUIRED 37000015 TM FDOT1B(RD),X'10' 37050015 BC BO,CD4A DVD EXISTS 37100015 BAL RR,MKDVD 37150015 CD4A BAL RR,TERMWS TERMINATE WORK SPACE 37200015 MVI OBJSW,OFF 37250015 BC B,CD7 37300015 SPACE 37350015 CD6 MVI ABSW,ON SET ADJUSTABLE BASE SWITCH ON 37400015 MVI CNSIDR,ON 37420015 OI FDOT3B(RC),NDVBIT SET NEEDS DOPE VECTOR BIT 37450015 BC B,CD8 CHECK TYPE OF DEFINING 37500015 SPACE 37550015 CD3 MVC BTREF(2),BSREF ARRAY BASE 37580015 TM 7(RC),X'01' 37610015 BC BO,CD6 BRANCH IF PROCESSED 37640015 MVC AREF(2),BSREF 37700015 LR RD,RC 37750015 OI 7(RD),X'01' SET PROCESSED BIT 37800015 BAL RR,SETBRF SET BREF 37850015 BAL RR,PROCDT PROCESS DIMENSION TABLE 37900015 CLI DVDSW,ON 37950015 BC BNE,CD3A BRANCH IF NO DVD REQUIED 38000015 TM FDOT1B(RD),X'10' 38050015 BC BO,CD3A DVD EXISTS 38100015 BAL RR,MKDVD 38150015 CD3A BAL RR,TERMWS 38170015 MVI OBJSW,OFF 38190015 LR RC,RD 38210015 BC B,CD6 CHECK FOR ADJUSTABLE BASE 38250015 SPACE 38300015 CD8 MVC PAR1+2(2),DFREF 38350015 BALR RR,RL 38400015 L RD,PAR1 GET DEFINED ADDRESS 38450015 TM FDOT3B(RD),X'10' 38500015 BC BZ,CD10 BRANCH IF OVERLAY DEFINED 38550015 SPACE 38600015 CD11 MVC AREF(2),DFREF *** ADJUSTABLE CORESSPONDENCE 38650015 TM FDOT1B(RD),X'10' 38660016 BC BZ,*+8 38670016 BAL RR,MKDVD 38680016 BAL RR,INOBJ SET TEXT START 38700015 BAL RR,GETDT GET DIM TABLE 38750015 MVC N+1(1),5(RD) SET DIMENSIONALITY 38800015 LH RB,N 38850015 AR RB,RB 38900015 AR RB,RB 38950015 LA RB,3(RB) 39000015 STC RB,AD2 39050015 MVC AD3(2),DFREF 39100015 OI AD3+1,X'01' 39150015 MVC AD4(2),BSREF 39200015 OI AD4+1,X'01' 39250015 LA RE,AD1 39300015 LA RF,8 GENERATE CODE TO SET MULTIPLIERS 39350015 BAL RR,CMPIL1 39400015 SPACE 39450015 MVC PAR1+2(2),BSREF 39500015 BALR RR,RL 39550015 L RD,PAR1 POINT AT BASE 39600015 BAL RR,GETDT GET DIM TABLE FOR BASE 39650015 ST RD,SAVERD 39700015 MVC ZLOCK(2),FSVARI+1(RB) 39720017 SPACE 39750015 MVC PAR1+2(2),DFREF 39800015 BALR RR,RL 39850015 L RD,PAR1 POINT TO DEFINED ITEM 39900015 BAL RR,GETDT GET DT FOR DEFINED ITEM 39950015 L RB,SAVERD 40000015 BAL RR,MOVEMP MOVE MULTIPLIERS ACROSS 40020017 SPACE 40050015 MVI ZLOCK,0 40350017 SPACE 40750015 SPACE 40800015 CD13 MVC PAR1+2(2),DFREF RESET DEFINED ADDRESS 40850015 BALR RR,RL 40900015 L RD,PAR1 40950015 MVI OBJSW,OFF 41000015 L RR,CDSLOT 41050015 BCR B,RR 41100015 SPACE 41150015 CD37 TM FDOT2B(RC),X'0C' TREAT BASE AS ADJUSTABLE IF 41200015 BC BNZ,CD41 EXTERNAL OR PARAMETER 41250015 TM 0(RC),X'0F' 41300015 BC BNO,CD8 BRANCH IF NOT DATA 41350015 TM FDDATA(RC),X'80' 41400015 BC BO,CD8 BRANCH IF NOT STRING 41450015 TM FDDATA(RC),X'40' BRANCH IF FIXED LENGTH 41500015 BC BZ,CD8 41550015 CD41 MVI ABSW,ON 41600015 BC B,CD8 GET DEFINED REFERENCE 41650015 SPACE 41700015 CD10 MVC AREF(2),DFREF *** OVERLAY DEFINED 41750015 TM 0(RD),X'30' 41800015 BC BZ,CD14 BRANCH IF SCALAR 41850015 MVI DEFSW,ON 41900015 BAL RR,SETBRF 41950015 TM 0(RD),X'20' 42000015 BC BZ,CD15 BRANCH IF ARRAY 42050015 SPACE 42100015 BAL RR,PROCST *** STRUCTURE 42150015 CLI DVDSW,ON 42200015 BC BNE,CD10A BRANCH IF DVD NOT REQUIRED 42250015 TM FDOT1B(RD),X'10' 42300015 BC BO,CD10A DVD EXISTS 42350015 BAL RR,MKDVD 42400015 * IF NO CODE HAS BEEN PRODUCED THEN THE ITEM MAY BE 42450015 * ADDRESSED DIRECTLY 42500015 CD10A MVC PAR1+2(2),DFREF 42550015 BALR RR,RL 42600015 L RD,PAR1 42650015 MVI NEWFLG,ON 42700015 TM FDOT1B(RD),4 42750015 BC BO,*+8 42800015 MVI NEWFLG,OFF 42850015 TM FDOT1B(RD),X'04' 42900015 BC BO,CD40 BRANCH IF CODE HAS BEEN PRODUCED 42950015 CLI ABSW,ON OR IF BASE IS ADJUSTABLE 43000015 BC BE,CD40 43050015 CLI BITSW,ON 43100015 BC BNE,*+12 43150015 MVI ABSW,ON 43200015 BC B,CD40 43250015 NI FDOT3B(RD),X'7F' TURN OFF NEEDS DOPE VECTOR BIT 43300015 BC B,CD13 EXIT 43350015 SPACE 43400015 CD40 BAL RR,STBASE SET BASE REFERENCE AND POS 43450015 SPACE 43500015 NI CD28+1,X'0F' SET STRUCTURE SWITCH 43550015 MVC NREF(2),DFREF 43600015 BAL RR,NXTRF1 GET FIRST ELEMENT 43650015 BAL 0,ERROR ERROR IF END OF STRUCTURE 43700015 CD24 OI DREF+1,X'01' 43750015 CLI BITSW,ON 43800015 BC BE,CD22 BRANCH IF BIT 43850015 SPACE 43900015 MVC CD16+3(2),DREF *** NON BIT 43950015 MVC CD17+3(2),DREF SET STORAGE ADDRESS 44000015 CLI NEWFLG,ON 44050015 BC BNE,CD9 44100015 MVC CD91+3(2),DREF 44150015 MVC CD92+3(2),DREF 44200015 LA RE,CD91 44250015 LA RF,CD93-CD91 44300015 BC B,CD25 44350015 SPACE 44357016 CD9 TM 0(RD),X'0F' 5037 44364016 BC BNO,CD9A BRANCH IF NOT DATA ITEM 5037 44371016 TM FDDATA(RD),X'84' 5037 44378016 BC BNZ,CD9A BRANCH IF NOT BIT STRING 5037 44385016 SPACE 1 5037 44392016 MVC CD91A+3(2),DREF **DEF ITEM IS A BIT STRING 5037 44399016 MVC CD91B+3(2),DREF 5037 44406016 MVC CD91C+3(2),DREF 5037 44409017 LA RE,CD91A 5037 44413016 LA RF,CD91D-CD91A 5037 44420017 BC B,CD25 COMPILE CODE 5037 44427016 SPACE 44434016 CD9A LA RE,CD16 NON BIT 5037 44441016 LA RF,CD18-CD16 44450015 CD25 BAL RR,CMPIL1 44500015 CD28 BC B,CD23 *** BRANCH IF NOT STRUCTURE 44550015 SPACE 44600015 BAL RR,NXTREF GET NEXT BASE ELEMENT 44650015 BC B,CD23 BRANCH IF END OF STRUCTURE 44700015 BC B,CD24 44750015 SPACE 44800015 CD22 MVC CD19+3(2),DREF *** BIT CLASS DEFINED 44850015 MVC CD20+3(2),DREF 44900015 MVC CD20+8(2),DREF 44950015 CLI NEWFLG,ON 45000015 BC BE,CD22A 45050015 LA RE,CD19 45100015 LA RF,CD21-CD19 45150015 BC B,CD25 45200015 SPACE 45250015 CD22A MVC CD19A+3(2),DREF 45300015 LA RE,CD19A 45350015 LA RF,CD19B-CD19A 45400015 BAL RR,CMPIL1 45450015 LA RE,CD19+5 45500015 LA RF,CD21-CD19-5 45550015 BC B,CD25 45600015 SPACE 45650015 CD23 LA RE,CD26 *** END OF CODE GENERATION 45700015 LA RF,CD27-CD26 COMPILE DRPL 45750015 BAL RR,CMPIL1 45800015 BC B,CD13 45850015 SPACE 45900015 CD15 BAL RR,PROCDT *** PROCESS ARRAY 45950015 MVC PAR1+2(2),DFREF 46000015 BALR RR,RL SET RD TO POINT AT DEFINED ITEM 46050015 L RD,PAR1 46100015 CLI DVDSW,ON 46150015 BC BNE,CD15A BRANCH IF DVD (OT REQUIRED 46200015 TM FDOT1B(RD),X'10' 46250015 BC BO,CD15A BRANCH IF DVD EXITS 46300015 BAL RR,MKDVD 46350015 CD15A MVI NEWFLG,ON 46400015 TM FDOT1B(RD),4 46450015 BC BO,*+8 46500015 MVI NEWFLG,OFF 46550015 CLI ABSW,ON BRANCH IF ARRAY DEFINED ON 46600015 BC BE,CD43 ADJUSTABLE ITEM 46650015 TM FDOT1B(RD),4 46700015 BC BO,CD44 BRANCH IF CODE IS REQUIRED TO 46750015 * MAP ARRAY 46800015 TM 0(RD),X'0F' 46850015 BC BNO,CD45 BRANCH IF NOT DATA 46900015 TM FDDATA(RD),X'84' 46950015 BC BZ,CD44 BRANCH IF BIT STRING 47000015 CD45 NI FDOT3B(RD),X'7F' TURN OFF DOPE VECTOR BIT 47050015 BC B,CD13 BRANCH TO PROCESS NEXT ITEM 47100015 CD44 MVI ABSW,ON 47150015 SPACE 47200015 CD43 BAL RR,STBASE SET BASE IF ADJUSTABLE 47250015 OI CD28+1,X'F0' 47300015 MVC DREF(2),DFREF 47350015 BC B,CD24 47400015 SPACE 47450015 CD14 CLI ABSW,ON *** SCALAR DEFINED ITEM 47500015 BC BE,CD38 BRANCH IF ADJUSTABLE BASE 47550015 TM 0(RD),X'0F' 47600015 BC BNO,CD39 BRANCH IF NOT ARITH OR STRING 47650015 TM FDDATA(RD),X'84' 47700015 BC BNZ,CD42 BRANCH IF NOT BIT STRING 47750015 MVI ABSW,ON DO NOT TREAT AS DIRECT DEFINED 47800015 BC B,CD38 IF BIT STRING 47850015 CD42 TM FDDATA(RD),X'40' 47900015 BC BO,CD13 BRANCH IF ADJUSTABLE 47950015 CD39 NI FDOT3B(RD),X'7F' TURN OFF NEEDS DV BIT 48000015 BC B,CD13 EXIT 48050015 SPACE 48100015 CD38 BAL RR,STBASE SET BASE 48150015 MVC DREF(2),DFREF 48200015 OI DREF+1,X'01' 48250015 CLI BITSW,ON 48300015 BC BE,CD29 BRANCH IF BIT 48350015 SPACE 48400015 MVC CD30+3(2),DREF *** NON BIT 48450015 LA RE,CD30 48500015 LA RF,CD31-CD30 48550015 CD35 BAL RR,CMPIL1 COMPILE STORE IN DOPE VECTOR 48600015 BC B,CD23 48650015 SPACE 48700015 CD29 NI FDDATA(RD),X'DF' *** BIT SCALAR. SET TO PACKED 48750015 MVC CD33+3(2),DREF 48800015 MVC CD33+8(2),DREF 48850015 LA RE,CD32 48900015 LA RF,CD34-CD32 48950015 BC B,CD35 49000015 EJECT 49050015 * SET BASE ADDRESS ROUTINE 49100015 * 49150015 * FUNCTIONS - TO GENERATE CODE TO SET UP THE STARTING 49200015 * ADDRESS OF A DEFINED ITEM IN AN OBJECT REGISTER, INCLUDING 49250015 * ANY POSITION OPTION. 49300015 * 49350015 * ENTRY POINT STBASE. ON ENTRY DFREF CONTAINS THE 49400015 * DICTIONARY REFERENCE OF THE DEFINED ITEM, AND BSREF CONTAINS 49450015 * THE REFERENCE OF THE BASE. 49500015 * 49550015 * EXTERNAL ROUTINES - CMPIL1 IN IEMJL COMPILES TEXT. 49600015 * 49650015 * EXIT - NORMAL - TO CALLING ROUTINE 49700015 * 49750015 * EXIT - ERROR - N/A 49800015 SPACE 2 49850015 STBAS1 ST RR,SBSLOT 49900015 MVI CNSIDR,OFF 49920015 XC POSOP(2),POSOP 49950015 MVC DFREF(2),BSREF 50000015 BC B,SB23 50050015 SPACE 50100015 STBASE ST RR,SBSLOT 50150015 CLI OBJSW,ON 50200015 BC BE,SB1 BRANCH IF DEF IN OBJECT CODE 50250015 CLI ABSW,ON 50300015 BC BNE,CD13 EXIT IF NOT ADJUSTABLE BASE 50350015 SPACE 50400015 BAL RR,INOBJ 50450015 SB1 MVI OBJSW,OFF 50500015 SPACE 50550015 SPACE 50600015 MVC PAR1+2(2),DFREF 50650015 BALR RR,RL GET DEFINED ADDRESS 50700015 L RD,PAR1 50750015 LR RC,RD 50800015 TM 0(RD),X'0F' 50850015 BC BNO,*+8 50900015 LA RC,6(RC) SKIP IF NOT DATA ITEM 50950015 TM FDVARB(RD),X'80' 51000015 BC BZ,*+6 SKIP IF NO OFFSET 2 51050015 AR RC,R4 51100015 TM FDVARB(RD),X'40' 51150015 BC BZ,*+8 SKIP IF NOT DIMENSIONED 51200015 LA RC,3(RC) 51250015 TM FDVARB(RD),X'20' 51300015 BC BZ,*+8 SKIP IF NOT STRUCTURE 51350015 LA RC,10(RC) 51400015 MVC POSOP(2),C1 51450015 TM FDVARB(RD),X'10' 51500015 BC BZ,SB2 BRANCH IF NO POS 51550015 TM 0(RD),X'0F' 51600015 BC BO,*+12 BRANCH OF DATA 51650015 TM 0(RD),X'0E' 51700015 BC BNO,SB2 BRANCH IF NOT STRUCTURE 51750015 MVC POSOP(2),FSVARI(RC) SET POSOP FROM DICTIONARY 51800015 SPACE 51850015 SB2 LH RB,POSOP 51900015 SH RB,C1 51950015 STH RB,POSOP 52000015 SB23 MVI BITSW,OFF *** ENTRY FOR STBAS1 52050015 SPACE 52100015 LA RE,SB21 52150015 LA RF,SB22-SB21 52200015 BAL RR,CMPIL1 COMPILE USSL 52250015 SPACE 52300015 MVC DREF1(2),BSREF 52350015 OI DREF1+1,X'01' 52400015 SPACE 52450015 MVC PAR1+2(2),BSREF 52500015 BALR RR,RL GET BASE DICTIONARY ENTRY 52550015 L RD,PAR1 52600015 TM 0(RD),X'0F' 52650015 BC BO,SB3 DATA 52700015 TM 0(RD),X'0E' 52750015 BC BNO,SB3 LABEL,EVENT TASK 52800015 SPACE 52850015 MVC NREF(2),BSREF *** STRUCTURE 52900015 BAL RR,NXTRF1 GET NEXT BASE ELEMENT 52950015 BAL 0,ERROR 53000015 MVC BSREF(2),DREF SET BSREF TO FIRST ELEMENT 53050015 SPACE 53100015 SB3 TM 0(RD),X'0F' 53150015 BC BNO,SB4 SKIP IF NOT DATA ITEM 53200015 TM FDDATA(RD),X'84' 53250015 BC BNZ,SB4 53300015 MVI BITSW,ON 53350015 SPACE 53400015 SB4 TM 0(RD),X'10' 53450015 BC BO,SB5 BRANCH IF AN ARRAY 53500015 SPACE 53550015 NI SB13+1,X'0F' SET SCALAR SWITCH 53600015 SB15 CLI BITSW,ON *** SCALAR BASE 53650015 BC BE,SB8 BRANCH IF BIT 53700015 MVC SB6+3(2),BSREF 53750015 MVC SB6+6(2),POSOP 53800015 LA RE,SB6 53850015 LA RF,SB7-SB6 COMPILE LA 15,BSREF+POSOP 53900015 SPACE 53950015 SPACE 54000015 SB12 BAL RR,CMPIL1 54050015 SPACE 54100015 SB13 BC B,SB14 *** BRANCH IF ARRAY 54150015 SPACE 54200015 SB20 CLI CNSIDR,OFF NEEDS DV BIT FOR BASE MAY 54207015 BC BE,SB20A BE RESET , BRANCH IF NOT SO 54214015 CLI BITSW,ON 54221015 BC BE,SB20A BRANCH IF BIT CLASS DEFINING 54228015 SPACE 54235015 MVC PAR1+2(2),BTREF 54242015 BALR RR,RL DECODE BASE REFERENCE 54249015 L RD,PAR1 54256015 SPACE 54263015 TM FDOT1B(RD),X'04' 54270015 BC BO,SB20A BRANCH IF ADJUSTABLE DIMS 54277015 NI FDOT3B(RD),X'7F' SET NEEDS DV BIT OFF 54284015 SB20A MVC PAR1+2(2),DFREF 54291015 BALR RR,RL RESET DEFINED ENTRY 54300015 L RD,PAR1 54350015 L RR,SBSLOT 54400015 BCR B,RR EXIT 54450015 SPACE 54500015 SB8 OI FDOT3B(RD),NDVBIT SET DOPE VECTOR BIT ON 54550015 MVC SB9+3(2),DREF1 *** BIT SCALAR BASE 54600015 MVC SB11+6(2),POSOP 54650015 LA RE,SB9 CONVERT TO BITS AND ADD POSOP 54700015 LA RF,SB10-SB9 INTO R15 54750015 BC B,SB12 54800015 SPACE 54850015 SB5 OI SB13+1,X'F0' ** ARRAY BASE 54900015 BC B,SB15 LOAD VIRTUAL ORIGIN AND POSOP 54950015 SPACE 55000015 SB14 TM FDOT1B(RD),X'04' 55050015 BC BO,SB14A BRANCH IF ADJUSTABLE BOUNDS 55100015 SPACE 55150015 TM 0(RD),X'0F' 55200015 BC BNO,SB14B BRANCH IF NON DATA 55250015 TM FDDATA(RD),X'80' 55300015 BC BO,SB14B BRANCH IF NOT STRING 55350015 SPACE 55400015 TM FDDATA(RD),X'40' 55450015 BC BZ,SB14B BRANCH IF NON ADJUSTABLE 55500015 SPACE 55550015 SB14A OI 13(RD),X'80' 55600015 BAL RR,GETDT 55650015 SR RB,RB 55700015 IC RB,5(RD) SET DIMENSIONALITY 55750015 AR RB,RB CALCULATE 4*N 55800015 AR RB,RB 55850015 STC RB,SB16+7 GENERATE CODE TO CALCULATE 55900015 LA RB,2(RB) FIRST ELEMENT ADDRESS 55950015 STC RB,SB17+20 56000015 MVC SB17+6(2),DREF1 56050015 MVC SB17+16(2),DREF1 56100015 MVC SB17+1(2),ZEQMAX 56150015 MVC SB18+3(2),ZEQMAX 56200015 BAL RR,BUMPEQ 56250015 LA RE,SB16 56300015 LA RF,SB19-SB16 56350015 BAL RR,CMPIL1 56400015 BC B,SB20 56450015 SPACE 56500015 SB14B ST RD,0(RS) SAVE RD 56530015 BAL RR,GETDT 56560015 SPACE 56600015 SR RB,RB 56650015 IC RB,5(RD) NO OF DIMENSIONS 56700015 SPACE 56750015 SLA RB,3 56800015 LA RC,12(RB,RD) MPLIER INDEX 56850015 SPACE 56900015 SR RB,RB 56950015 IC RB,5(RD) 57000015 LA RD,12(RD) LBOUND INDEX 57050015 SPACE 57100015 SR RF,RF 57150015 SPACE 57200015 SB14C L RE,0(RC) MPLIER 57250015 LTR RE,RE 57260015 BC BM,SB14D BRANCH IF MULT NOT CALC 57270015 MH RE,2(RD) LBOUND 57300015 AR RF,RE 57350015 SPACE 57400015 LA RC,4(RC) 57450015 LA RD,8(RD) 57500015 SPACE 57550015 BCT RB,SB14C 57600015 SPACE 57650015 LA RE,REG15 57700015 L RD,0(RS) RESET DIC POINTER 25903 57720019 BAL RR,ADDCN ADD CONSTANT 57750015 BC B,SB20 57800015 SPACE 57810015 SB14D L RD,0(RS) 57820015 BC B,SB14A 57830015 SPACE 2 57850015 * GET DIMENSION TABLE ROUTINE 57900015 SPACE 57950015 GETDT ST RR,GTSLOT 58000015 LR RB,RD 58050015 TM 0(RD),X'0F' 58100015 BC BNO,*+8 SKIP IF NOT DATA ITEM 58150015 LA RB,6(RB) BUMP POINTER 58200015 TM FDVARB(RD),X'80' 58250015 BC BZ,*+6 SKIP IF NO OFFSET 2 58300015 AR RB,R4 58350015 SPACE 58400015 MVC PAR1+2(2),FSVARI+1(RB) 58450015 BALR RR,RL GET DIMENSION TABLE 58500015 L RD,PAR1 58550015 L RR,GTSLOT 58600015 BCR B,RR EXIT 58650015 EJECT 58700015 * NEXT STRUCTURE ELEMENT ROUTINE 58750015 * 58800015 * FUNCTIONS - RETURNS THE ADDRESS AND DICTIONARY REFERENCE 58850015 * OF THE NEXT BASE ELEMENT OF A STRUCTURE 58900015 * 58950015 * ENTRY POINTS - (1) NXTRF1. ENTERED WITH THE MAJOR 59000015 * STRUCTURE REFERENCE IN AREF RETURNS THE FIRST BASE ELEMENT. 59050015 * (2) NXTREF IS ENTERED AFTER THE FIRST 59100015 * BASE ELEMENT HAS BEEN OBTAINED. 59150015 * 59200015 * EXTERNAL ROUTINES - ZDRFAB, 59250015 * 59300015 * EXITS - NORMAL - (1) AT END OF STRUCTURE, TO THE CALLING 59350015 * ADDRESS. 59400015 * (2) WITH A BASE ELEMENT, TO THE CALLING 59450015 * ADDRESS+4. 59500015 * 59550015 * EXITS - ERROR - N/A 59600015 SPACE 2 59650015 NXTRF1 ST RR,0(RS) 59700015 BC B,NR1 59750015 SPACE 59800015 NXTREF ST RR,0(RS) 59850015 TM FDOT1B(RD),X'08' 59900015 BC BO,NR2 BRANCH IF LAST MEMBER OF STRUCT 59950015 NR1 MVC PAR1+2(2),NREF 60000015 BALR RR,RL GET NEXT STRUCTURE MEMBER 60050015 L RD,PAR1 60100015 LR RC,RD 60150015 TM 0(RD),X'10' 60200015 BC BZ,*+8 SKIP IF NOT DIMENSIONED 60250015 LA RC,3(RC) 60300015 TM 0(RD),X'0F' 60350015 BC BNO,*+8 SKIP IF NOT DATA ITEM 60400015 LA RC,6(RC) 60450015 MVC DREF(2),NREF SET DREF 60500015 MVC NREF(2),23(RC) SET REFERENCE TO NEXT MEMBER 60550015 TM 0(RD),X'0F' 60600015 BC BO,NR3 BRANCH IF DATA ITEM 60650015 TM 0(RD),X'0E' 60700015 BC BO,NR1 BRANCH IF STRUCTURE 60750015 NR3 L RR,0(RS) 60800015 BC B,4(RR) NORMAL EXIT 60850015 SPACE 60900015 NR2 L RR,0(RS) *** END OF STRUCTURE EXIT 60950015 BCR B,RR 61000015 EJECT 61050015 * INITIALIZE PRIMARY DOPE VECTOR ROUTINE 61100015 * 61150015 * FUNCTIONS - GENERATES OBJECT CODE TO SET THE PRIMARY 61200015 * DOPE VECTORS OF ARRAYS OF VARYING STRINGS TO REFER TO THE 61250015 * SECONDARY DOPE VECTORS OF STRING DOPE VECTORS INSTEAD OF TO 61300015 * THE STORAGE OF THE STRINGS. 61350015 * 61400015 * ENTRY POINT - IPDV. FROM VOBJC IN IEMJL 61450015 * 61500015 * EXTERNAL ROUTINE - CMPIL1 61550015 * 61600015 * EXITS - NORMAL - TO THE ROUTINE WHICH CALLED VOBJC 61650015 SPACE 2 61700015 IPDV MVC IP1+3(2),DREF1 61750015 MVC IP1+6(2),DVOFF1 61800015 LH RC,N 61850015 AR RC,RC 61900015 AR RC,RC 61950015 STH RC,0(RS) 62000015 MVC IP3+6(2),0(RS) 62050015 MVC IP4+1(2),ZEQMAX 62100015 MVC IP10+3(2),DREF1 62150015 MVC IP10+6(2),DVOFF1 62200015 AH RC,DVOFF1 62250015 STH RC,0(RS) 62300015 MVC IP5+3(2),DREF1 62350015 MVC IP8+6(2),0(RS) 62400015 MVC IP6+3(2),DREF1 62450015 MVC IP6+6(2),DVOFF1 62500015 MVC IP7+3(2),DREF1 62550015 MVC IP7+6(2),DVOFF1 62600015 MVC IP8+3(2),DREF1 62650015 MVC IP11+3(2),DREF1 62700015 LA RC,2(RC) 62750015 STH RC,0(RS) 62800015 MVC IP5+6(2),0(RS) 62850015 MVC IP11+6(2),0(RS) 62900015 MVC IP9+3(2),ZEQMAX 62950015 BAL RR,BUMPEQ 63000015 LA RE,IP1 63050015 LA RF,IP12-IP1 63100015 SR RS,R4 63150015 L RR,0(RS) COMPILE CONVERSION CODE AND 63200015 BC B,CMPIL1 RETURN TO CALLING ROUTINE 63250015 EJECT 63300015 * SET DYNAMIC DOPE VECTOR SIZE ROUTINE. 63350015 * 63400015 * FUNCTIONS - (1) TO CALCULATE THE SIZE OF DOPE VECTORS 63450015 * REQUIRED BY ITEMS WHICH NEED DYNAMIC STORAGE, AND TO ALIGN 63500015 * THIS AMOUNT SO THAT AFTER ALLOWANCE FOR THE DOPE VECTOR THE 63550015 * ELEMENT STORAGE APPEARS ON AN 8-BYTE BOUNDARY. 63600015 * (2) TO RELOCATE THE VIRTUAL ORIGIN(S) OF 63650015 * THE ITEM BY THIS AMOUNT. 63700015 * 63750015 * ENTRY POINTS (1) SETDVS FOR NON ADJUSTABLE STRUCTURES 63800015 * (2) STDVS1 FOR ADJUSTABLE STRUCTURES 63850015 * (3) SETDVA FOR NON ADJUSTABLE ARRAYS 63900015 * (4) STDVA1 FOR ADJUSTABLE ARRAYS. 63950015 * 64000015 * EXTERNAL ROUTINES (1) NXTREF OBTAINS ELEMENT ADDRESSES. 64050015 * (2) CMPIL1 COMPILES TEXT SKELETONS. 64100015 * 64150015 * EXITS - NORMAL - TO CALLING ROUTINE 64200015 * 64250015 * EXITS - ERROR - NIA 64300015 SPACE 2 64350015 SETDVS OI SD1+1,X'F0' SET STRUCTURE SWITCH ON 64400015 BC B,*+8 64450015 SPACE 64500015 SETDVA NI SD1+1,X'0F' SET STRUCTURE SWITCH OFF 64550015 MVI CSW,OFF 64600015 ST RR,SDSLOT 64650015 CLI CLASS,CONTRL 64700015 BC BNE,SD47 BRANCH IF TEMP 64750015 OI DVOFF+1,X'04' ALIGN DOPE VECTOR SIZE 64800015 BC B,SD48 64850015 SPACE 64900015 SD47 LH RB,DVOFF *** TEMP 64950015 LA RB,7(RB) 65000015 N RB,CM8 ALIGN TO EIGHT BYTES 65050015 STH RB,DVOFF 65100015 SPACE 65150015 SD48 LA RF,31(RF) ALIGN AGGREGATE TO 4 BYTES 65200015 N RF,CM32 BOUNDARY 65250015 SRL RF,3 CONVERT TO BYTES 65300015 AH RF,DVOFF ADD DOPE VECTOR SIZE 65350015 CH RF,C4096 65400015 BC BL,SD2 BRANCH IF LESS THAN 4096 65450015 BAL RR,MKCNST MAKE CONSTANT DICTIONARY ENTRY 65500015 SPACE 65550015 SD1 BC 0,SD3 *** STRUCTURE SWITCH 65600015 SPACE 65650015 MVC 3(2,RD),PAR1+2 *** ARRAY . SET REF IN DIM TABLE 65700015 MVI DP11+1,X'80' SET SET CONSTANT BIT 65750015 SPACE 65800015 SD5 LH RB,DVOFF *** RELOCATE VIRTUAL ORIGIN 65850015 SLL RB,3 CONVERT DOPE VECTOR SIZE TO BITS 65900015 SD27 A RB,8(RD) ADD TO VIRTUAL ORIGIN 65950015 ST RB,8(RD) 66000015 CLI VSW,ON 66050015 BC BNE,SD31 BRANCH IF NOT VARYING 66100015 SPACE 66150015 SR RB,RB 66200015 L RC,LENGTH 66250015 LH RE,N CALCULATE OFFSET TO SMALLEST 66300015 MH RE,C12 MULTIPLIER 66350015 D RB,8(RD,RE) CALCULATE SDV SIZE 66400015 CLI BITSW,ON 66450015 BC BNE,*+8 SKIP IF NOT BIT 66500015 SLL RC,3 66550015 SPACE 66600015 CH RC,C4096 66650015 BC BL,SD32 BRANCH IF LESS THAN 4096 66700015 SPACE 66750015 LR RF,RC 66800015 BAL RR,MKCNST MAKE CONSTANT D.E. 66850015 MVC 6(2,RD),PAR1+2 SET REF IN DIM TABLE 66900015 OI 1(RD),X'80' SET CONSTANT BIT 66950015 BC B,SD31 67000015 SPACE 67050015 SD32 STH RC,6(RD) SET SIZE IN DIM TABLE 67100015 SD31 L RR,SDSLOT 67150015 BCR B,RR EXIT 67200015 SPACE 67250015 SD2 TM SD1+1,X'F0' NO CONSTANT REQUIRED 67300015 BC BO,SD4 BRANCH IF STRUCTURE 67350015 STH RF,0(RS) 67400015 MVC 3(2,RD),0(RS) SET LENGTH IN DIMENSION TABLE 67450015 MVI DP11+1,X'00' UNSET SET CONSTANT BIT 67500015 BC B,SD5 67550015 SPACE 67600015 SD3 MVC ACC+1(3),PAR1+1 *** STRUCTURE WITH CONSTANT FOR 67650015 OI FDOT4B(RD),X'80' LENGTH. SET CONSTANT CREATED BIT 67700015 BC B,SD6 67750015 SPACE 67800015 SD4 ST RF,ACC *** STRUCTURE WITH NO CONSTANT 67850015 SPACE 67900015 SD6 MVC NREF(2),AREF *** RELOCATE DOPE VECTORS 67950015 BAL RR,NXTRF1 GET FIRST BASE ELEMENT 68000015 BAL 0,ERROR 68050015 SD8 TM 0(RD),X'10' 68100015 BC BZ,SD7 BRANCH IF NOT DIMENSIONED 68150015 SPACE 68200015 MVC DIMREF(2),17(RC) SAVE DIMREF 68250015 MVC PAR1+2(2),17(RC) *** DIMENSIONED BASE ELEMENT 68300015 BALR RR,RL GET DIMENSION TABLE 68350015 L RC,PAR1 68400015 BAL RR,SVASZ CALCULATE VARYING ARRAY SIZE 68450015 LH RB,DVOFF 68500015 A RB,8(RC) ADD DOPE VECTOR OFFSET TO V.O. 68550015 ST RB,8(RC) 68600015 CLI CSW,ON 68650015 BC BE,*+8 68700015 NI 8(RC),X'E0' CLEAR OVERFLOW BITS 68750015 SD9 BAL RR,NXTREF 68800015 BC B,*+8 SKIP IF END OF STRUCTURE 68850015 BC B,SD8 PROCESS NEXT ELEMENT 68900015 SPACE 68950015 BAL RR,SVASZ1 RESET VARYING ARRAY ROUTINE 69000015 BAL RR,SYBA GET STRUCTURE ENTRY 69100001 BC B,SD31 EXIT 69200001 SPACE 69300015 SD7 MVC 1(3,RS),5(RD) *** NON-DIMENSIONED BASE ELEMENT 69350015 L RB,0(RS) 69400015 AH RB,DVOFF ADD DOPE VECTOR OFFSET INTO 69450015 ST RB,0(RS) OFFSET1 SLOT 69500015 MVC 5(3,RD),1(RS) 69550015 BC B,SD9 PROCESS NEXT ELEMENT 69600015 SPACE 2 69650015 * ROUTINE TO SET DPPE VECTORS FOR ADJUSTABLE ARRAYS 69700015 * STRUCTURES 69750015 SPACE 2 69800015 STDVS1 ST RR,SDSLOT 69850015 BAL RR,SYBA GET MAJOR STRUCTURE 69950001 MVC FSVARI(1,RD),MAXLVL+1 SET MAX LEVEL IN OFFSET 1 SLOT 70050015 OI SD10+1,X'F0' SET STRUCTURE SWITCH ON 70100015 BC B,*+12 70150015 SPACE 70200015 STDVA1 NI SD10+1,X'0F' SET STRUCTURE SWITCH OFF 70250015 ST RR,SDSLOT 70300015 MVI CSW,ON 70350015 CLI CLASS,CONTRL 70400015 BC BNE,SD49 BRANCH IF TEMP 70450015 OI DVOFF+1,X'04' ALIGN DOPE VECTOR SIZE 70500015 LH RB,DVOFF 70550015 BC B,SD10 70600015 SPACE 70650015 SD49 LH RB,DVOFF *** TEMP 70700015 LA RB,7(RB) 70750015 N RB,CM8 ALIGN DVOFF 70800015 STH RB,DVOFF 70850015 SPACE 70900015 SD10 BC 0,SD13 BRANCH IF STRUCTURE 70950015 SPACE 71000015 CLI VSW,ON 71050015 BC BNE,SD14 BRANCH IF NOT A VARYING ARRAY 71100015 SPACE 71150015 LA RB,3(RB) 71200015 MVC SD33+3(2),RREF 71250015 STH RB,0(RS) 71300015 MVC SD15+6(2),0(RS) COMPILE LA ACC,DVL(15) 71350015 MVC SD16+8(2),DREF1 COMPILE SLL ACC,5 AR ACC,ACC 71400015 LH RC,N AR ACC,ACC 71450015 AR RC,RC 71500015 AR RC,RC 71550015 STH RC,0(RS) 71600015 MVC SD16+11(2),0(RS) SET OFFSET OF 4*N 71650015 LA RC,3 71700015 CLI BITSW,ON 71750015 BC BNE,*+8 SKIP IF NOT BIT 71800015 LA RC,6 71850015 STC RC,SD18+4 SET LENGTH OF SHIFT 71900015 LA RE,SD33 71950015 LA RF,SD34-SD33 72000015 BAL RR,CMPIL1 72050015 BC B,SD20 72100015 SPACE 72150015 SD14 STH RB,0(RS) *** NON VARYING ARRAY 72200015 MVC SD21+6(2),0(RS) 72250015 MVC SD35+3(2),RREF 72300015 LA RE,SD35 72350015 LA RF,SD36-SD35 72400015 BAL RR,CMPIL1 COMPILE CODE TO SET SIZE 72450015 SPACE 72500015 SD20 MVC PAR1+2(2),DIMREF 72550015 BALR RR,RL GET DIM TABLE 72600015 L RC,PAR1 72650015 MVC 6(2,RC),DVOFF SAVE DVOFF IN DIM TABLE 72700015 SPACE 72750015 BC B,SD31 EXIT 72820001 SPACE 72900015 SD13 TM FDOT4B(RD),X'60' *** STRUCTURE 72910015 BC BNO,SD13A 72915015 MVC SD37A+3(2),RREF *** COBOL TEMPORARY 72920015 LA RE,SD37A 72930015 LA RF,SD38A-SD37A COMPILE L 15,RDV+4 72940015 BC B,SD13B 72950015 SPACE 72960015 SD13A MVC SD37+8(2),RREF 72970015 MVC SD37+16(2),RREF LOAD SIZE OF STRUCTURE AND HANG 73000015 LA RE,SD37 73050015 LA RF,SD38-SD37 73100015 SD13B BAL RR,CMPIL1 73150015 SPACE 73200015 CLI VSW,ON 73250015 BC BNE,SD39 BRANCH IF NO VARYING STRINGS 73300015 SPACE 73350015 LH RB,DVOFF *** VARYING STRINGS 73400015 LA RB,3(RB) SET DVOFF+3 IN CODE 73450015 STH RB,0(RS) 73500015 MVC SD40+6(2),0(RS) 73550015 SD46 BC 0,SD45 SKIP IF CONSTANT MADE 73600015 LCR RF,R4 MAKE A MASK CONSTANT 73650015 BAL RR,MKCNST 73700015 MVC SD40+11(2),PAR1+2 SET CONSTANT REF IN CODE 73750015 OI SD46+1,X'F0' SET SWITCH 73800015 SPACE 73850015 SD45 LA RE,SD40 ALIGN AND LOAD SIZE OF STORAGE 73900015 LA RF,SD41-SD40 73950015 BC B,SD44 74000015 SPACE 74050015 SD39 MVC SD42+6(2),DVOFF *** NON VARYING STRINGS 74100015 LA RE,SD42 74150015 LA RF,SD43-SD42 COMPILE CODE TO SET SIZE 74200015 SD44 BAL RR,CMPIL1 74250015 SPACE 74300015 BAL RR,SYBA GET MAJOR STRUCTURE 74400001 LR RC,RD 74500015 TM 0(RD),X'10' 74550015 BC BZ,*+8 SKIP IF NOT DIMENSIONED 74600015 LA RC,3(RC) 74650015 MVC FSSSTI+2(2,RC),RREF SAVE RESULT REFERENCE 74700015 MVC FSSSTI+7(2,RC),DVOFF SAVE DV SIZE 74750015 BC B,SD31 EXIT 74820001 SPACE 2 74900015 * ROUTINE TO CALCULATE THE SIZE OF DOPE VECTORS FOR 74950015 * SECONDARY DOPE VECTORS IN STRUCTURES 75000015 SPACE 75050015 SVASZ CLI CSW,ON 75100015 BCR BE,RR 75150015 SPACE 75200015 CLI VSW,ON 75250015 BCR BNE,RR 75300015 SPACE 75350015 TM FDDATA(RD),X'80' 75400015 BCR BO,RR EXIT IF NOT STRING 75450015 SPACE 75500015 TM FDDATA(RD),X'02' 75550015 BC BO,*+10 BRANCH IF AREA 75600015 SPACE 75650015 TM FDDATA(RD),X'10' 75700015 BCR BZ,RR EXIT OF NOT VARYING 75750015 SPACE 75800015 SZ3 LR RF,RC 75850015 SR RE,RE 75900015 IC RE,5(RF) SET DIMENSIONALITY 75950015 SR RA,RA CLEAR INDEX 76000015 LA RC,8 76050015 SPACE 76100015 SZ1 LH RB,18(RA,RF) SET LBOUND 76150015 SH RB,14(RA,RF) 76200015 AH RB,C1 CALCULATE EXTENTS 76250015 MR RB,RB 76300015 LA RA,8(RA) BUMP INDEX 76350015 BCT RE,SZ1 RETURN FOR NEXT DIM 76400015 SPACE 76450015 A RC,SVZ ADD TO TOTAL 76500015 ST RC,SVZ 76550015 SPACE 76600015 LR RC,RF RESTORE DIMTABLE POINTER 76650015 SZ2 BCR 0,RR *** FIRST SWITCH 76700015 SPACE 76750015 MVC DIMZ(2),DIMREF SAVE DIMREF 76800015 OI SZ2+1,X'F0' SET FIRST SWITCH 76850015 BCR B,RR EXIT 76900015 SPACE 76950015 SVASZ1 TM SZ2+1,X'F0' 77000015 BCR BZ,RR EXIT IF FIRST SWITCH NOT SET 77050015 ST RR,0(RS) 77100015 AR RS,R4 77150015 MVC PAR1+2(2),DIMZ 77200015 BALR RR,RL GET FIRST DIM TABLE 77250015 L RC,PAR1 77300015 L RF,SVZ 77350015 BAL RR,MKCNST MAKE CONSTANT FOR SIZE 77400015 MVC 6(2,RC),PAR1+2 SET CONSTANT IN DIM TABLE 77450015 SR RE,RE 77500015 ST RE,SVZ CLEAR ACCUMULATOR 77550015 NI SZ2+1,X'0F' RESET FIRST SWITCH 77600015 BC B,DP22 77700001 EJECT 77800015 * SET RECORD DESCRIPTION VECTOR ROUTINE 77850015 SPACE 2 77900015 RDV6 ST RR,RDSLOT 77950015 BAL RR,SYBA 78050001 SPACE 78150015 CLI CLASS,CONTRL 78200015 BC BNE,*+12 BRANCH IF NOT CONTROLLED 78250015 TM FDVARB(RD),X'02' 78300015 BC BZ,RD1 BRANCH IF NOT BASED 78350015 TM FDOT4B(RD),RDVBIT 78400015 BC BZ,RD1 EXIT IF NO RDV REQUIRED 78450015 SPACE 78500015 RD2 XC OFFSET(2),OFFSET 78550015 MVC MAXBND(2),BOUND 78600015 SPACE 78650015 RD3 MVC LOCK(2),AREF LOCK DICTIONARY BLOCK 78700015 L RB,LENGTH 78750015 LA RB,7(RB) 78800015 SRL RB,3 78850015 ST RB,LENGTH ROUND LENGTH TO BYTES 78900015 LH RB,OFFSET 78950015 SRL RB,3 79000015 STC RB,LENGTH 79050015 MVI SA4,X'00' CLEAR CODE FLAG 79100015 CLI CLASS,STATIC 79150015 BC BE,RD4 BRANCH IF STATIC 79200015 SPACE 79250015 L RF,LENGTH *** AUTOMATIC 79300015 CLI COBLSW,ON 79310015 BC BNE,*+8 BRANCH IF NOT COBOL 79320015 LA RF,0(RF) 79330015 BAL RR,MKCNST MAKE CONSTANT DICT ENTRY 79350015 MVC SA5(2),PAR1+2 SET CONSTANT REFERENCE 79400015 RD19 CLI CLASS,CONTRL 79450015 BC BE,RD18 BRANCH IF CONTROLLED 79500015 RD7 MVC PAR1+2(2),BREF 79550015 BALR RR,RL 79600015 L RF,PAR1 GET ENTRY TYPE 1 79650015 MVC SA2(2),11(RF) SET HEAD OF AUTOMATIC CHAIN 79700015 BAL RE,MKRDV MAKE RDV ENTRY 79750015 MVC 11(2,RF),PAR1+2 SET REFERENCE IN AUTO CHAIN 79800015 RD5 XC LOCK(2),LOCK 79850015 RD1 L RR,RDSLOT 79900015 BCR B,RR 79950015 SPACE 80000015 RD18 XC SA2(2),SA2 80050015 LA RE,RD5 *** CONTROLLED SCALAR 80100015 BC B,MKRDV MAKE RDV ENTRY 80150015 SPACE 80200015 RD4 MVC SA5(4),LENGTH *** STATIC 80250015 MVC SA2(2),ZSTACH+4 SET STATIC CHAIN REFERENCE 80300015 BAL RE,MKRDV 80350015 MVC ZSTACH+4(2),PAR1+2 SET IN STATIC CHAIN 80400015 BC B,RD5 80450015 SPACE 80500015 RDV1 ST RR,RDSLOT 80520015 LH RR,OFFSET 80540015 N RR,SVEBIT 80560015 A RR,ACC 80580015 ST RR,LENGTH 80600015 BAL RR,SYBA 80700001 SPACE 80800015 CLI CLASS,CONTRL 80850015 BC BNE,RD3 BRANCH IF NOT CONTROLLED 80900015 TM FDVARB(RD),X'02' 80950015 BC BO,RD3 BRANCH IF BASED 81000015 BC B,RD1 81050015 SPACE 81100015 RDV3 ST RR,RDSLOT *** NON ADJUSTABLE SCALAR 81150015 TM CLASS,STYPE 81200015 BC BNM,RD2 BRANCH IF NOT CONTROLLED 81250015 TM FDVARB(RD),X'02' 81300015 BC BO,RD2 81350015 TM 0(RD),X'0F' 81400015 BC BNO,RD2 CREATE RDV IF NOT DATA ITEM 81450015 TM FDDATA(RD),X'80' 81500015 BC BO,RD2 CREATE RDV IF NOT STRING 81550015 NI FDOT1B(RD),X'EF' TURN OFF DVD REQUIRED BIT 81600015 NI FDOT4B(RD),X'FE' TURN OFF RDV BIT 81650015 BCR B,RR EXIT 81700015 SPACE 81750015 RD6 ST RR,RDSLOT *** ADJUSTABLE ITEM 81800015 XC SA5(4),SA5 CLEAR LENGTH SLOT 81850015 MVI SA4,X'F0' SET NO CONSTANT FLAG 81900015 BC B,RD7 81950015 SPACE 82000015 RDV2 ST RR,RDSLOT *** MAKE RDV TO MAP 82050015 MVI SA4,X'F0' SET NO CONSTANT FLAG 82100015 MVC SA4+1(3),CM8 SET TEXT REF SLOT TO X'FFFFFF' I4A 82120016 BAL RR,SYBA GET ITEM REFERENCE 82210001 MVC LOCK(2),AREF LOCK CURRENT ITEM IN CORE 82300015 BC B,RD19 82350015 SPACE 82400015 SPACE 82450015 RDV4 ST RR,SBSLOT *** ADJUSTABLE ARRAY 82500015 SPACE 82550015 RDV5 ST RR,SBSLOT *** ADJUSTABLE STRING 82600015 BAL RR,RD6 MAKE ENTRY AND CHAIN 82650015 SPACE 82700015 LA RE,RD16 DEFAULT SET TO CHAR 82750015 LA RF,RD13-RD16 82800015 MVC RD16+3(2),DREF1 82850015 RD17 MVC RD12+3(2),PAR1+2 82900015 MVC RD12+11(2),PAR1+2 82950015 LH RB,BOUND 83000015 SRL RB,3 SET CODE 83050015 STC RB,RD12+10 83100015 SPACE 83150015 TM FDDATA(RD),X'04' 83200015 BC BO,RD14 BRANCH IF CHAR 83250015 SPACE 83300015 LA RE,RD12 BIT STRING 83350015 LA RF,RD13-RD12 83400015 RD14 L RR,SBSLOT RDV 83450015 BC B,CMPIL1 83500015 SPACE 83550015 * MAKE RDV DICTIONARY ENTRY ROUTINE 83600015 SPACE 83650015 MKRDV MVC SA3(2),AREF SET AREF IN DICTIONARY ENTRY 83700015 MVC SA7(2),8(RD) SAVE DECLARE NUMBER 83750015 LA RB,SA1 83800015 ST RB,PAR1 83850015 LA RB,SA6-SA1 SET PARAMETERS 83900015 ST RB,PAR2 83950015 L RB,ZDICRF 84000015 BALR RR,RB MAKE DICTIONARY ENTRY 84050015 MVC 8(2,RD),PAR1+2 SET RDV REF IN DIC ENTRY 84100015 MVC RREF(2),PAR1+2 SET RDV REF 84150015 NI FDOT1B(RD),X'EF' SET DVD BIT OFF 84200015 OI FDOT4B(RD),RDVBIT SET RDV BIT OM 84250015 XC SA4+1(3),SA4+1 I4A 84270016 BCR B,RE 84300015 SPACE 84350015 EJECT 84400015 * ERROR MESSAGE ROUTINES 84450015 * 84500015 * FUNCTIONS - MAKE CALLS TO THE ERROR EDITOR ROUTINES 84550015 * 84600015 * ENTRY POINTS - (1) ERR1 84650015 * (2) ERR2 84700015 * 84750015 * EXTERNAL ROUTINES - ZUERR IN COMPILER CONTROL 84800015 * 84850015 * EXITS - NORMAL - TO ROUTINE WHICH CALLED PROCST OR 84900015 * PROCDT 84950015 * 85000015 * EXITS-ABORTS IF MESSAGE 1088 HAS BEEN PUT OUT 85050001 SPACE 2 85100015 SPACE 2 85150015 ERROR DC H'0' 85200015 SPACE 2 85250015 * SIZE OVERFLOW ERROR MESSAGE ROUTINE 85300015 SPACE 85350015 ERR1 MVC PAR6(4),MESS SET MESSAGE IN PAR6 85400015 MVI BRANCH,X'00' SET BRANCH OFF 85403001 * 85406001 ERR3 MVC PAR1+2(2),AREF ARRAY DICT REF 85409001 BALR RR,RL CONVERT TO ABSOLUTE 85412001 L RB,PAR1 85418001 NI FDOT4B(RB),X'FE' REMOVE RDV BIT IF SET. THIS IS 85424001 * NECESSARY AS THE RETURN 85430001 * FROM THIS SEVERE MESSAGE ROUTINE BYPASSES THE RDV ROUTINE 85436001 * 85442001 MVC PAR7+2(2),AREF 85450015 L RB,ZUERR 85500015 BALR RR,RB MAKE ERROR MESSAGE ENTRY 85550015 BRNCH BC B,ERRX 85570001 BRANCH EQU BRNCH+1 85590001 L RB,ZABORT IF TERMINAL MESSAGE PUT OUT 85610001 BALR RR,RB THEN ABORT 85630001 ERRX EQU * 85650001 BC B,DP22 85670001 SPACE 2 85750015 ERR2 MVC PAR6(4),MESS2 85800015 MVI BRANCH,X'00' SET BRANCH OFF 23283 86000019 BC B,ERR3 86300001 * 86400001 * 86500001 * 86600001 * SUBROUTINE TO PLACE IN RD THE ABS ADDRESS OF SYMB(AREF). 86700001 * 86800001 SYBA MVC PAR1+2(2),AREF 86900001 LR RD,RR SAVE RR 87000001 BALR RR,RL CONVERT TO ABSOLUTE 87100001 LR RR,RD RESTORE RR 87200001 L RD,PAR1 87300001 BCR B,RR RETURN 87400001 * 87500001 * 87600001 SPACE 2 87700015 SPACE 4 87750015 END IEMJM 87800015 ./ ADD SSI=03010242,NAME=IEMJP,SOURCE=0 JP TITLE 'IEMJP, DEFINED CHECK, AGGREGATES, PL/I(F)' 00080013 SPACE 00160013 * PHASE JP. DEFINED CHECK. 00240013 * 5.5 A 122400,864800 KT 57452 00247072 * 5.5 C 126400-127200,865200,865220-865230,866000 KT 57452 00252072 * 5.5 D 123300,123660,425600-427200 KT 57452 00257072 * 5.3B A 482883 KT 47632 00262072 * 5.3B C 482892 KT 47632 00267072 * 5.3B A 051200,123780,790400,865300,875600 KT 47616 00272072 * 5.3B A 123840 MAC 45933 00277072 * 5.2C C 482400,483180,486400,891200 MJG 41949 00282072 * 5.2B C 865600 MJG 38198 00287072 * 5.2 C 173200 MJG 34358 00292072 * 5.0 C 472600,488800,490400 24175 00297072 * 5.0 C 760800,763200 21156 00302072 * 21127 00307072 * 20106 00312072 SPACE 3 00320013 * STATUS - CHANGE LEVEL 0 00400013 SPACE 3 00480013 * FUNCTION/OPERATION - 00560013 SPACE 5 00640013 * THIS PHASE CHECKS THE VALIDITY OF DEFINING SPECIFIED 00720013 * IN A COMPILATION. PHASE FV HAS ALREADY DISTINGUISHED 00800013 * BETWEEN THE CASES OF CORRESPONDENCE AND OVERLAY DEFINING. 00880013 * IF IT IS OVERLAY THE PHASE EXAMINES THE DEFINED ITEM. 00960013 * IF IT IS CODED ARITH, LABEL, TASK OR EVENT DATA THE DEFINING 01040013 * IS ONLY VALID IF BOTH BASE AND DEFINED ITEM ARE SCALARS WITH 01120013 * THE SAME CHARACTERISTICS. IF BOTH DEFINED ITEM AND BASE ARE 01200013 * EXAMINED TO DETERMINE WHETHER THEY MATCH. IF THEY DO IT IS 01280013 * A VALID CASE OF DEFINING. IF THEY DO NOT MATCH THE STRUCTURES 01360013 * ARE EXAMINED TO DETERMINE WHETHER IT IS A VALID CASE OF 01440013 * STRING CLASS DEFINING. ALL OTHER CASES OF DEFINING ARE 01520013 * EXAMINED FOR STRING CLASS DEFINING. FOR VALIDITY THIS REQUIRES 01600013 * 1. ALL ELEMENTS OF THE DEFINED ITEM AND THE BASE TO BE 01680013 * STRINGS OR NUMERIC FIELDS OF THE SAME CLASS. 01760013 * 2. BOTH BASE AND DEFINED ITEM, IF AGGREGATES, TO BE PACKED. 01840013 * 3. THE BASE, IF AN ARRAY, NOT TO BE CONTAINED IN A 01920013 * DIMENSIONED STRUCTURE. 02000013 * 4. THE LENGTH OF THE BASE, LESS ANY POS VALUE, TO BE 02080013 * GREATER THAN THE LENGTH OF THE DEFINED ITEM. 02160013 SPACE 02240013 * IF IT IS CORRESPONDENCE DEFINING THE PHASE CHECKS THAT 02320013 * THE DESCRIPTION OF THE ELEMENTS OF THE DEFINED ARRAY MATCHES 02400013 * THAT OF THE ELEMENTS OF THE BASE ARRAY. 02480013 SPACE 3 02560013 * ENTRY POINTS - JP+2. FROM COMPILER CONTROL. 02640013 SPACE 3 02720013 * INPUT - THE DICTIONARY 02800013 SPACE 3 02880013 * OUTPUT - ERROR MESSAGES 02960013 SPACE 3 03040013 * EXTERNAL ROUTINES - (1) ZDRFAB (2) ZUERR 03120013 SPACE 3 03200013 * EXITS NORMAL - JP1 03280013 SPACE 3 03360013 * EXITS ERROR - JP650. INVALID DEFINING IN COMPILATION 03440013 SPACE 3 03520013 * TABLES/WORKAREAS - TABLE 1. A TRANSLATE AND TEST TABLE 03600013 * FOR CLASSIFYING DICTIONARY ENTRY DATA BYTES. 03680013 SPACE 3 03760013 * ATTRIBUTES - N/A 03840013 SPACE 3 03920013 * NOTES - (1) THIS BLOCK IS EXTERNAL CHARACTER SET 04000013 * INDEPENDANT. 04080013 * (2) THIS PHASE IS NOT LOADED IF THE COMPILATION 04160013 * DOES NOT INCLUDE THE DEFINED ATTRIBUTE 04240013 EJECT 04320013 IEMJP START 0 04400013 JP EQU * 04480013 USING JP,JPBASE 04560013 DICT EQU *+8192 04640013 USING DICT,GRDIC 04720013 CC EQU *+12288 04800013 USING CC,CCBASE 04880013 DC C'JP' 04960013 SPACE 5 05040013 * EQU CARDS FOR JP 05120013 X00 EQU X'00' 47616 05140056 XF0 EQU X'F0' 47616 05160056 SPACE 5 05200013 * COMPILER CONTROL TRANSFER VECTOR 05280013 SPACE 3 05360013 ZABORT EQU CC+X'20' 05440013 ZUERR EQU CC+X'30' 05520013 ZDRFAB EQU CC+X'34' 05600013 RLSCTL EQU CC+X'48' 05680013 SPACE 5 05760013 * DICTIONARY COMMUNICATIONS REGION. 05840013 SPACE 3 05920013 ZMYNAM EQU DICT+112 06000013 ZSTAT EQU DICT+126 06080013 PAR1 EQU DICT+128 06160013 PAR2 EQU DICT+132 06240013 PAR6 EQU DICT+148 06320013 PAR7 EQU DICT+152 06400013 LOCK EQU DICT+274 06480013 ZCOMM EQU DICT+304 06560013 ZDEFCH EQU ZCOMM+74 06640013 SPACE 5 06720013 * DICTIONARY OFFSETS 06800013 SPACE 3 06880013 STRVAR EQU 15 OFFSET OF VARIABLE INFORMATION 06960013 * IN STRUCTURE DICT ENTRY 07040013 DATVAR EQU 21 OFFSET OR VARIABLE INFORMATION 07120013 * IN STRING OR ARITH DICT 07200013 * ENTRY 07280013 OTH1 EQU 10 OFFSET OF OTHER 1 CODE BYTE 07360013 OTH2 EQU 12 OFFSET OF OTHER 2 CODE BYTE 07440013 OTH3 EQU 13 OFFSET OF OTHER 3 CODE BYTE 07520013 OTH4 EQU 14 OFFSET OF OTHER 4 CODE BYTE 07600013 VARBYT EQU 11 OFFSET OF VARIABLE BYTE 07680013 DATBYT EQU 15 OFFSET OF DATA BYTE 07760013 SPACE 5 07840013 * REGISTERS 07920013 SPACE 3 08000013 P0 EQU 0 GENERAL REGISTER 08080013 P1 EQU 1 TRT ADDRESS. 08160013 P2 EQU 2 TRT VALUE. 08240013 DREG EQU 3 DEFINED ITEM DICT ENTRY PTR. 08320013 BREG EQU 4 BASE DICTIONARY ENTRY POINTER 08400013 P5 EQU 5 GENERAL REGISTER 08480013 P4 EQU 6 GENERAL REGISTER 08560013 P6 EQU 6 GENERAL REGISTER 08640013 P7 EQU 7 DREG OR BREG FOR SUBROUTINES. 08720013 P8 EQU 8 GENERAL REGISTER 08800013 P9 EQU 9 GENERAL REGISTER 08880013 JPBASE EQU 10 PROGRAM BASE 08960013 CCBASE EQU 11 COMPILER CONTROL BASE 09040013 JQBASE EQU 12 2ND BASE REGISTER, IF REQUIRED 09120013 GRDIC EQU 13 FIRST DICTIONARY BLOCK 09200013 GR14 EQU 14 LINK REGISTER 09280013 GR15 EQU 15 BRANCH REGISTER 09360013 SPACE 5 09440013 * BITS 09520013 SPACE 3 09600013 BIT1 EQU X'80' 09680013 BIT2 EQU X'40' 09760013 BIT3 EQU X'20' 09840013 BIT4 EQU X'10' 09920013 BIT5 EQU X'08' 10000013 BIT6 EQU X'04' 10080013 BIT7 EQU X'02' 10160013 BIT8 EQU X'01' 10240013 BIT78 EQU X'03' 10320013 BIT678 EQU X'07' 10400013 SPACE 5 10480013 * BRANCH MNEMONICS. 10560013 SPACE 5 10640013 BO EQU 1 10720013 BP EQU 2 10800013 BH EQU 2 10880013 BL EQU 4 10960013 BM EQU 4 11040013 BNE EQU 7 11120013 BNZ EQU 7 11200013 BE EQU 8 11280013 BZ EQU 8 11360013 BNM EQU 11 11440013 BNL EQU 11 11520013 BNH EQU 13 11600013 BNO EQU 14 11680013 B EQU 15 11760013 EJECT 11840013 L JPBASE,PAR1 11920013 MVC ZMYNAM(2),0(JPBASE) 12000013 XR P2,P2 12080013 MVC DR(2),ZDEFCH STORE DICT REF OF START OF 12160013 * DEFINED CHAIN IN DR. 12240013 L GR15,ZDRFAB * POINT GR15 AT ZDRFAB 57452 12243072 B FIRST 21127 12246001 JP530 EQU * I21127 12252001 TM BDFLG,X'01' I21127 12258001 BO FIRST 21127 12264001 TM BDFLG,X'FE' 21127 12270001 BNO FIRST 21127 12276001 OI BDFLG,X'01' 21127 12282001 * THE DEFINED AND BASE ITEM LENGTHS ARE NOW IN 21127 12288001 * THEIR SLOTS. TEST FOR LENGTHS NOT KNOWN AT COMPILE21127 12294001 * TIME AND THEN COMPARE 21127 12300001 CLC DLTH(4),OOFF DEF LENGTH KNOWN? 21127 12306001 BNL FIRST NO 21127 12312001 L P8,BLTH BASE LENGTH KNOWN? 21127 12318001 LTR P8,P8 21127 12324001 BNP NOLTH 21127 12336001 CLC BLTH(4),DLTH 21127 12342001 BNL FIRST BASE < DEF ITEM? 21127 12348001 NOLTH EQU * 21127 12354001 MVC DR(2),LOCK RESET D.R. OF DEF ITEM 21127 12360001 B PERR13 BASE SHORTER THAN DFE ITEM 12372001 FIRST EQU * 21127 12378001 MVI FLAG,X00 * INITIALIZE TO ZERO 47616 12381056 MVI BDFLG,X'00' 21127 12384001 XC BLTH(4),BLTH CLEAR OUT BASE LENGTH 45933 12387056 CLC DR(2),STOPR 21127 12390001 BC BE,JP1 BRANCH IF YES. 12400013 MVC LOCK(2),DR LOCK IN DICT BLOCK CONTAINING DR 12480013 MVC PAR1+2(2),DR LOAD DREG WITH ADDRESS OF DICT 12560013 BALR GR14,GR15 * ENTRY FOR D.R. 57452 12640072 L DREG,PAR1 12800013 CLI 0(DREG),X'C8' TEST FOR DELETED ITEM 12880013 BC BNE,JP533 12960013 LA P5,STRVAR+14(DREG) ALLOW FOR STRUCTURE AND LIKE 13040013 TM VARBYT(DREG),X'80' OFFSET 2 13120013 BC BNO,*+8 13200013 LA P5,4(P5) 13280013 TM VARBYT(DREG),X'40' DIMENSION 13360013 BC BNO,*+8 13440013 LA P5,3(P5) 13520013 TM VARBYT(DREG),X'10' POSITION 13600013 BC BNO,*+8 13680013 LA P5,2(P5) 13760013 TM VARBYT(DREG),X'04' EXTERNAL 13840013 BC BNO,*+8 13920013 LA P5,2(P5) 14000013 MVC DR(2),0(P5) 14080013 BC B,JP530 14160013 JP533 SR P5,P5 I1 14240016 IC P5,2(DREG) LENGTH OF ENTRY I1 14320016 AR P5,DREG I1 14400016 S P5,NINE I1 14480016 TM 0(DREG),X'0E' I1 14560016 BC BO,JP2 BRANCH IF STRUCTURE OR DATA I1 14640016 BCTR P5,0 I1 14720016 BCTR P5,0 ALLOW FOR SYMTAB SLOT I1 14800016 JP2 MVC NDR(7),0(P5) P5 HAS ADDR OF DEFINED SLOT I1 14880016 * CHAIN ITEM IN NDR. 15040013 * STORE DICT REF OF BASE IN BDR. 15120013 * STORE SECOND FILE POINTER IN SUB 15200013 TM VARBYT(DREG),BIT4 WAS POS DECLARED. 15280013 BC BZ,JP3 BRANCH IF NO. 15360013 MVI PSW,X'FF' SET PSW ON. 15440013 JP3 MVC PAR1+2(2),BDR LOAD BREG WITH ADDRESS OF BASE 15520013 BALR GR14,GR15 DICTIONARY ENTRY. 15600013 L BREG,PAR1 15680013 TM OTH2(BREG),BIT5 IS BASE A FORMAL PARAMETER. 15760013 BC BZ,JP4 BRANCH IF NO. 15840013 MVI FPSW,X'FF' SET FPSW ON. 15920013 JP4 TM OTH2(BREG),BIT78 IS BASE CONTROLLED. 16000013 BC BNO,JP5 BRANCH IF NO. 16080013 MVI CONTSW,X'FF' SET CONTSW ON. 16160013 JP5 TM OTH3(DREG),BIT4 IS IT CORRESPONDENCE DEFINING 16240013 BC BO,JP200 BRANCH IF YES 16320013 TM 0(DREG),X'0F' IS DEFINED ITEM STRING OR ARITH 16400013 BC BO,JP7 BRANCH IF YES. 16480013 TM 0(DREG),X'0E' IS DEFINED ITEM STRUCTURE 16560013 BC BO,JP8 BRANCH IF YES. 16640013 TM 0(DREG),BIT4 IS DEFINED ITEM DIMENSIONED. 16720013 BC BO,PERR9 ERROR IF YES. 16800013 TM 0(BREG),BIT4 IS BASE DIMENSIONED 16880013 BC BO,PERR9 ERROR IF YES. 16960013 JP541 MVC CODE(1),0(BREG) ARE DATA TYPES OF DEFINED ITEM 17040013 XC CODE(1),0(DREG) AND BASE THE SAME. 17120013 TM CODE,X'0F' 17200013 BC BNZ,PERR8 ERROR IF NO. 17280013 TM 0(DREG),X'07' IS DEFINED ITEM A LABEL 17300016 BO JP20 YES,NO FURTHER TEST 34358 17330020 JP12 CLI PSW,X'00' WAS POS GIVEN. 17360013 BC BE,JP20 17440013 BC B,PERR19 ERROR IF YES. 17520013 SPACE 5 18240013 * DEFINED ITEM IS STRING OR ARITH DATA. 18320013 JP7 TRT DATBYT(1,DREG),TABLE1 TEST DEFINED ITEM DATA BYTE. 18400013 BC B,*(P2) 18480013 BC B,JP10 BIT CLASS 18560013 BC B,JP10 CHARACTER CLASS. 18640013 BC B,JP11 CODED ARITH. 18720013 BC B,PERR10 VARYING STRING. 18800013 SPACE 5 18880013 * DEFINED ITEM IS CODED ARITH. 18960013 SPACE 3 19040013 JP11 TM 0(DREG),BIT4 IS DEFINED ITEM DIMENSIONED. 19120013 BC BO,PERR9 ERROR IF YES. 19200013 TM 0(BREG),BIT4 IS BASE DIMENSIONED. 19280013 BC BZ,JP543 BRANCH IF NO. 19360013 CLC SUB(3),FFFF IS BASE SUBSCRIPTED 19440013 BC BE,PERR9 ERROR IF NO. 19520013 JP543 TM 0(BREG),X'0F' IS BASE ARITH OR STRING. 19600013 BC BNO,PERR8 ERROR IF NO. 19680013 TM DATBYT(DREG),X'C0' 19700015 BC BO,JP543A BRANCH IF OFFSET OR POINTER 19720015 CLC DATBYT(3,DREG),DATBYT(BREG) ARE DATA CHARACTERISTICS OF 19760013 * DEFINED ITEM AND BASE THE SAME. 19840013 BC BE,JP12 19920013 BC B,PERR8 ERROR IF NO. 20000013 SPACE 20010015 JP543A CLC DATBYT(1,DREG),DATBYT(BREG) 20020015 BC BE,JP12 BRANCH IF SAME DAT A TYPE 20030015 BC B,PERR8 20040015 SPACE 5 20080013 * DEFINED ITEM IS OF STRING CLASS. 20160013 SPACE 3 20240013 JP10 ST P2,DCLASS STORE CLASS IN DCLASS. 20320013 TM 0(DREG),BIT4 IS DEFINED ITEM DIMENSIONED. 20400013 BC BO,JP501 BRANCH IF YES. 20480013 LR P7,DREG STORE LENGTH OF ITEM IN DLTH. 20560013 BAL GR14,GETLTH 20640013 ST P8,DLTH 20720013 OI BDFLG,X'0E' 21127 20760001 BC B,JP502 20800013 SPACE 5 20880013 * THE DEFINED ITEM IS AN ARRAY OF THE STRING CLASS. 20960013 SPACE 3 21040013 JP501 TM OTH4(DREG),BIT5 IS DEFINED ARRAY PACKED. 21120013 BC BO,PERR11 ERROR IF NO. 21200013 TM OTH1(DREG),BIT78 IS ARRAY LENGTH KNOWN 21280013 BC BNZ,JP503 BRANCH IF NO. 21360013 MVC PAR1+2(2),DATVAR+5(DREG) LOAD P5 WITH ADDRESS OF 21440013 JP506 BALR GR14,GR15 DIMENSION TABLE DICT ENTRY. 21520013 L P5,PAR1 21600013 LH P8,6(0,P5) STORE ARRAY LENGTH IN DLTH. 21680013 SLL P8,8 21760013 IC P8,3(0,P5) 21840013 ST P8,DLTH 21920013 OI BDFLG,X'0E' 21127 21960001 BC B,JP502 22000013 SPACE 5 22080013 * ARRAY LENGTH IS ADJUSTABLE. 22160013 SPACE 3 22240013 JP503 MVC DLTH(4),OOFF 22320013 BC B,JP502 22400013 SPACE 5 22480013 * THE DEFINED ITEM IS A STRUCTURE. 22560013 SPACE 3 22640013 JP8 TM 0(DREG),BIT4 IS DEFINED ITEM DIMENSIONED. 22720013 BC BZ,JP505 BRANCH IF NO 22800013 MVC DDR(8),STRVAR+5(DREG) MOVE STRUCTURE LEVEL TO LEV, 23040013 * DICT REF OF NEXT STRUCTURE 23120013 * ELEMENT TO NXDR, AND DICT REF OF 23200013 * DIMENSION TABLE TO DDR. 23280013 MVC DLTH+1(3),STRVAR+14(DREG) SET DEFINED ITEM LENGTH 23360013 OI BDFLG,X'0E' 21127 23400001 BC B,JP504 OBTAIN DEFINING CLASS 23440013 SPACE 5 23520013 * DEFINED ITEM IS AN UNDIMENSIONED STRUCTURE. 23600013 SPACE 3 23680013 JP505 TM 0(BREG),X'0F' IS BASE ARITH OR STRING. 23760013 BC BO,JP507 BRANCH IF YES. 23840013 TM 0(BREG),X'0E' IS BASE A STRUCTURE 23920013 BC BNO,PERR8 ERROR IF NO. 24000013 TM 0(BREG),BIT4 IS BASE DIMENSIONED. 24080013 BC BZ,JP508 BRANCH IF NO. 24160013 CLC SUB(3),FFFF IS BASE SUBSCRIPTED 24240013 BC BNE,JP531 BRANCH IF YES. 24320013 JP507 MVC LEV(5),STRVAR+5(DREG) I1 24420016 * DICT REF OF NEXT ELEMENT TO NXDR 24640013 MVC DLTH+1(3),STRVAR+11(DREG) MOVE STRUCTURE LENGTH TO DLTH. 24720013 OI BDFLG,X'0E' 21127 24760001 JP504 BAL GR14,GETCLS STORE DEFINING CLASS OF DEFINED 24800013 ST P2,DCLASS STRUCTURE IN DCLASS. 24880013 SPACE 5 24960013 * IT IS STRING CLASS OVERLAY DEFINING. THE DEFINED ITEM 25040013 * HAS BEEN EXAMINED. ITS CLASS NUMBER (4 FOR BIT AND 8 FOR 25120013 * CHARACTER) IS IN CELL DCLASS AND ITS LENGTH IN BITS IS IN 25200013 * DLTH. THE DEFINING BASE IS NOW EXAMINED. 25280013 SPACE 3 25360013 JP502 MVC PAR1+2(2),BDR LOAD BREG WITH ADDRESS OF BASE 25440013 BALR GR14,GR15 DICT ENTRY. 25520013 L BREG,PAR1 25600013 TM 0(BREG),X'0F' IS BASE STRING OR ARITH. 25680013 BC BO,JP509 BRANCH IF YES. 25760013 TM 0(BREG),X'0E' IS BASE A STRUCTURE. 25840013 BC BNO,PERR8 ERROR IF NO. 25920013 TM 0(BREG),BIT4 IS BASE DIMENSIONED. 26160013 BC BZ,JP510 BRANCH IF NO. 26240013 CLC SUB(3),FFFF IS BASE SUBSCRIPTED. 26320013 BC BNE,JP512 BRANCH IF YES. 26400013 MVC DDR(8),STRVAR+5(BREG) MOVE DICT REF OF DIMENSION TABLE 26480013 * TO DDR, DICT REF OF CONTAINING 26560013 * STRUCTURE TO CSTR, STRUCTURE 26640013 * LEVEL TO LEV, AND DICT REF OF 26720013 * NEXT ELEMENT TO NXDR. 26800013 MVC BLTH+1(3),STRVAR+14(BREG) SET LENGTH OF BASE 26880013 OI BDFLG,X'F0' 21127 26920001 BAL GR14,GETCLS OBTAIN DEFINING CLASS OF 26960013 * ELEMENTS OF BASE STRUCTURE. 27040013 C P2,DCLASS IS THIS THE SAME AS THE CLASS 27120013 * OF THE DEFINED ITEM. 27200013 BC BNE,PERR8 ERROR IF NO. 27280013 SPACE 27360013 CLI FPSW,X'FF' GIVE WARNING IF FORMAL PARAMETER 27440013 BC BE,WERR2 27520013 BC B,JP514 27600013 SPACE 5 27680013 * THE BASE IS AN UNDIMENSIONED STRUCTURE. 27760013 SPACE 3 27840013 JP510 MVC LEV(5),STRVAR+5(BREG) MOVE STRUCTURE LEVEL TO LEV, 27920013 * DICT REF OF NEXT ELEMENT TO NXDR 28000013 MVC BLTH+1(3),STRVAR+11(BREG) AND LENGTH TO BLTH. 28080013 OI BDFLG,X'F0' 21127 28120001 BC B,JP513 28160013 SPACE 5 28240013 * BASE IS AN ELEMENT OF AN ARRAY OF STRUCTURES. 28320013 SPACE 3 28400013 JP512 MVC LEV(5),STRVAR+8(BREG) MOVE STRUCTURE LEVEL TO LEV, 28480013 * DICT REF OF NEXT ELEMENT TO NXDR 28560013 MVC BLTH+1(3),STRVAR+14(BREG) AND LENGTH TO BLTH. 28640013 OI BDFLG,X'F0' 21127 28680001 JP513 CLI FPSW,X'FF' IS BASE A FORMAL PARAMETER. 28720013 BC BNE,JP6 BRANCH IF NO. 28800013 MVC BLTH(4),OOFF SET BLTH TO X'00FFFFFF' 28880013 JP6 BAL GR14,GETCLS OBTAIN DEFINING CLASS OF 28960013 * ELEMENTS OF BASE. 29040013 C P2,DCLASS IS THIS THE SAME AS THE CLASS 29120013 * OF THE DEFINED ITEM. 29200013 BC BE,JP514 29280013 BC B,PERR8 ERROR IF NO. 29360013 SPACE 5 29440013 * BASE IS STRING OR ARITH DATA. 29520013 SPACE 3 29600013 JP509 TRT DATBYT(1,BREG),TABLE1 TEST BASE DATA BYTE. 29680013 BC B,*(P2) 29760013 BC B,JP515 BIT CLASS. 29840013 BC B,JP515 CHARACTER CLASS. 29920013 BC B,PERR8 CODED ARITH, ERROR. 30000013 BC B,PERR10 VARYING STRING, ERROR. 30080013 SPACE 5 30160013 * BASE IS OF STRING CLASS. 30240013 SPACE 3 30320013 JP515 C P2,DCLASS IS BASE CLASS THE SAME AS 30400013 * DEFINED ITEM CLASS. 30480013 BC BNE,PERR8 ERROR IF NO. 30560013 TM 0(BREG),BIT4 IS BASE DIMENSIONED. 30640013 BC BO,JP516 BRANCH IF YES. 30720013 JP517 LR P7,BREG OBTAIN BASE LENGTH. 30800013 BAL GR14,GETLTH 30880013 ST P8,BLTH STORE IN BLTH. 30960013 OI BDFLG,X'F0' 21127 31000001 BC B,JP514 31040013 SPACE 5 31120013 * BASE IS DIMENSIONED. 31200013 SPACE 3 31280013 JP516 CLC SUB(3),FFFF IS BASE SUBSCRIPTED. 31360013 BC BNE,JP517 BRANCH IF YES. 31440013 TM OTH4(BREG),BIT5 IS BASE PACKED. 31520013 BC BO,PERR11 ERROR IF NO. 31600013 TM VARBYT(DREG),BIT1 31680013 BC BZ,JP600 31760013 MVC DDR(6),DATVAR+5(BREG) MOVE DICT REF OF DIMENSION TABLE 31840013 * TO DDR, AND IF BASE IS A 31920013 * STRUCTURE ELEMENT, DICT REF OF 32000013 * CONTAINING STRUCTURE TO CSTR. 32080013 BC B,JP511 32160013 SPACE 3 32240013 JP600 MVC DDR(6),DATVAR+1(BREG) 32320013 JP511 CLI FPSW,X'FF' IS BASE A FORMAL PARAMETER. 32400013 BC BE,WERR2 GIVE WARNING IF YES. 32480013 MVC PAR1+2(2),DDR LOAD P6 WITH ADDRESS OF BASE 32560013 BALR GR14,GR15 DIMENSION TABLE. 32640013 L P6,PAR1 32720013 LH P8,6(0,P6) LOAD P8 WITH LENGTH OF ARRAY 32800013 SLL P8,8 STORE IN BLTH. 32880013 IC P8,3(0,P6) 32960013 ST P8,BLTH 33040013 OI BDFLG,X'F0' 21127 33060001 JP514 CLC BLTH(4),OOFF IS BASE LENGTH KNOWN AT COMPILE 33120013 BC BNL,JP20 TIME. BRANCH IF NO. 33200013 L P8,BLTH 33280013 CLI PSW,X'00' WAS POS DECLARED. 33360013 BC BE,JP547 33440013 MVC PAR1+2(2),DR LOAD DREG WITH ADDRESS OF 33520013 BALR GR14,GR15 DEFINED ITEM DICT ENTRY. 33600013 L DREG,PAR1 33680013 MVC TEMP(2),1(DREG) LOAD P5 WITH ADDRESS OF END OF 33760013 LH P5,TEMP DEFINED ITEM DICT ENTRY. 33840013 AR P5,DREG 33920013 S P5,ELEVEN 34000013 TM VARBYT(DREG),BIT5 IS THERE A FIFTH VARIABLE FIELD. 34080013 BC BZ,JP47 BRANCH IF NO 34160013 S P5,FOUR 34240013 SPACE 5 34320013 * P5 NOW CONTAINS ADDRESS OF POS INFORMATION IN DICT ENTRY 34400013 SPACE 3 34480013 JP47 MVC TEMP(2),0(P5) LOAD P5 WITH POS VALUE-1 34560013 LH P5,TEMP 34640013 BCTR P5,0 34720013 CLI DCLASS+3,X'08' IS DEFINED ITEM CHARACTER CLASS. 34800013 BC BNE,JP50 34880013 AR P5,P5 34960013 AR P5,P5 CONVERT POS VALUE TO A BIT 35040013 AR P5,P5 OFFSET. 35120013 JP50 SR P8,P5 SUBTRACT POS VALUE-1 FROM BASE 35200013 ST P8,BLTH LENGTH 35400001 JP547 B JP20 21127 35680001 SPACE 5 36080013 SPACE 5 36160013 * BOTH BASE AND DEFINED ITEM ARE SCALAR STRUCTURES. 36240013 SPACE 3 36320013 JP508 MVC LEV(5),STRVAR+5(BREG) MOVE STRUCTURE LEVEL OF BASE TO 36400013 * LEV AND DICTREF OF NEXT ELEMENT 36480013 * TO NXDR. 36560013 MVI BDIM+3,X'00' MOVE DIMENSIONALITY OF BASE TO 36640013 BC B,JP532 BDIM. 36720013 SPACE 3 36800013 JP531 MVC LEV(5),STRVAR+8(BREG) MOVE STRUCTURE LEVEL OF BASE TO 36880013 * LEV AND DICTREF OF NEXT ELEMENT 36960013 * TO NXDR. 37040013 MVC BDIM+3(1),STRVAR+4(BREG) MOVE DIMENSIONALITY OF BASE TO 37120013 * BDIM. 37200013 JP532 MVI DDIM+3,X'00' MOVE DIMENSIONALITY OF DEFINED 37280013 * ITEM TO DDIM. 37360013 MVC NXDDR(2),STRVAR+8(DREG) MOVE DICT REF OF NEXT ELEMENT OF 37440013 * DEFINED ITEM TO NXDDR. 37520013 CLI PSW,X'00' WAS POS DECLARED. 37600013 BC BNE,JP507 BRANCH IF YES. 37680013 BAL GR14,STRCMP DO STRUCTURE DESCRIPTIONS OF 37760013 * BASE AND DEFINED ITEM MATCH. 37840013 BC B,JP20 BRANCH IF YES. 37920013 MVC PAR1+2(2),DR LOAD DREG WITH ADDRESS OF 38000013 BALR GR14,GR15 DEFINED ITEM DICT ENTRY. 38080013 L DREG,PAR1 38160013 BC B,JP507 BRANCH TO SEE IF IT IS STRING 38240013 * CLASS OVERLAY DEFINING. 38320013 SPACE 5 38400013 * IT IS CORRESPONDENCE DEFINING. 38480013 JP200 EQU * 38490001 TM OTH3(DREG),X'80' DV BIT SET ON? 38500001 BC BNO,CHECK 38510001 OI OTH3(BREG),X'80' DV BIT ON IN BASE 38520001 CHECK EQU * TEST TO SEE IF ONE ITEM IS 38530001 SPACE 3 38560013 MVC PICBYT(1),DATBYT(BREG) PICTURED. IF SO -ERROR 5087 38600016 XC PICBYT(1),DATBYT(DREG) 5087 38620016 TM PICBYT,X'08' 5087 38640016 BC BO,PERR8 5087 38660016 TM 0(DREG),X'0F' IS DEFINED ITEM STRING OR ARITH 5087 38680016 BC BO,JP540 BRANCH IF YES. 38720013 TM 0(DREG),X'0E' IS DEFINED ITEM AN ARRAY OF 38800013 * STRUCTURES. 38880013 BC BNO,JP541 BRANCH IF NO. 38960013 MVC DDIM+3(1),STRVAR+4(DREG) MOVE DIMENSIONALITY OF DEFINED 39040013 * ITEM TO DDIM AND DIMENSIONALITY 39120013 MVC BDIM+3(1),STRVAR+4(BREG) OF BASE TO BDIM. 39200013 MVC LEV(5),STRVAR+8(BREG) MOVE STRUCTURE LEVEL OF BASE TO 39280013 * LEV AND DICT REF OF NEXT ELEMENT 39360013 * TO NXDR 39440013 MVC NXDDR(2),STRVAR+11(DREG) MOVE DICT REF OF NEXT ELEMENT 39520013 * OF DEFINED ITEM TO NXDDR. 39600013 BAL GR14,STRCMP ARE STRUCTURE DESCRIPTIONS OF 39680013 * BASE AND DEFINED ITEM THE SAME. 39760013 BC B,JP20 BRANCH IF YES. 39840013 BC B,PERR20 ERROR IF NO. 39920013 SPACE 5 40000013 * DEFINED ITEM IS ARITH OR STRING. 40080013 SPACE 3 40160013 JP540 TRT DATBYT(1,DREG),TABLE1 TEST DEFINED ITEM DATA BYTE. 40240013 BC B,*(P2) 40320013 BC B,JP542 BIT CLASS 40400013 BC B,JP542 CHARACTER CLASS. 40480013 BC B,JP543 CODED ARITH. 40560013 BC B,PERR10 VARYING STRING. ERROR. 40640013 SPACE 5 40720013 * DEFINED ARRAY IS OF STRING CLASS. 40800013 SPACE 3 40880013 JP542 ST P2,DCLASS STORE CLASS IN DCLASS. 40960013 LR P7,DREG OBTAIN LENGTH OF DEFINED ITEM 41040013 BAL GR14,GETLTH AND STORE IN DLTH. 41120013 ST P8,DLTH 41200013 OI BDFLG,X'0E' 21127 41240001 TM 0(BREG),X'0F' IS BASE STRING OR ARITH. 41280013 BC BNO,PERR8 ERROR IF NO. 41360013 TRT DATBYT(1,BREG),TABLE1 TEST BASE DATA BYTE 41440013 BC B,*(P2) 41520013 BC B,JP545 BIT CLASS 41600013 BC B,JP545 CHARACTER CLASS 41680013 BC B,PERR8 CODED ARITH. ERROR. 41760013 BC B,PERR10 VARYING STRING. ERROR. 41840013 SPACE 5 41920013 * THE BASE IS AN ARRAY OF THE STRING CLASS. 42000013 SPACE 3 42080013 JP545 C P2,DCLASS IS DEFINING CLASS OF BASE THE 42160013 * SAME AS THAT OF DEFINED ITEM. 42240013 BC BNE,PERR8 ERROR IF NO. 42320013 LR P7,BREG OBTAIN LENGTH OF BASE IN 42400013 BAL GR14,GETLTH REGISTER P8. 42480013 SPACE 5 42800013 * WE HAVE COMPLETED THE PROCESSING OF A DEFINED ITEM. 42880013 SPACE 3 42960013 JP20 MVC PSW(3),STOPR 43040013 MVC DR(2),NDR 43120013 BC B,JP530 43200013 SPACE 5 43280013 * WE HAVE COMPLETED THE SCAN OF THE DEFINED CHAIN. 43360013 SPACE 3 43440013 JP1 CLI ERRFLG,X'00' DOES COMPILATION INCLUDE ERRORS 43520013 BC BNE,JP560 BRANCH IF YES 43600013 LA P2,JPLST 43680013 ST P2,PAR1 43760013 XR P2,P2 43840013 ST P2,PAR2 43920013 L GR15,RLSCTL FREE PHASE JP. 44000013 BCR B,GR15 RETURN TO CONTROL PHASE. 44080013 SPACE 5 44160013 * THE COMPILATION CONTAINS ILLEGAL DEFINING. THE 44240013 * COMPILATION IS ABORTED. 44320013 SPACE 3 44400013 JP560 L GR15,ZABORT 44480013 BCR B,GR15 44560013 EJECT 44640013 * SUBROUTINE GETLTH 44720013 SPACE 5 44800013 * FUNCTION/OPERATION- 44880013 * THIS SUBROUTINE OBTAINS THE LENGTH IN BITS OF A 44960013 * NUMERIC FIELD OR STRING HAVING A DICTIONARY ENTRY 45040013 * POINTED TO BY REGISTER P7. 45120013 * ON ENTRY REGISTER P2 CONTAINS 4 IF THE ITEM IS OF THE 45200013 * BIT CLASS, AND 8 IF IT IS OF THE CHARACTER CLASS. 45280013 * THE SUBROUTINE RETURNS THE LENGTH IN REGISTER P8. IF 45360013 * THE ITEM IS A STRING AND THE LENGTH IS ADJUSTABLE THE 45440013 * LENGTH IS SET TO X'00FFFFFF' 45520013 SPACE 3 45600013 * ENTRY POINTS - GETLTH 45680013 SPACE 3 45760013 * EXTERNAL ROUTINES - ZDRFAB (BRANCH ADDRESS IN GR15) 45840013 SPACE 3 45920013 * EXITS NORMAL - (1) JPGL3 (2) JPGL2 46000013 SPACE 3 46080013 * EXITS ERROR - N/A 46160013 SPACE 3 46240013 * TABLES/WORK AREAS - N/A 46320013 SPACE 3 46400013 * NOTES - N/A 46480013 SPACE 5 46560013 GETLTH TM DATBYT(P7),BIT1 IS ITEM STRING 46640013 BC BO,JPGL1 BRANCH IF NO. 46720013 TM DATBYT(P7),BIT2 IS LENGTH ADJUSTABLE 46800013 BC BO,JPGL2 BRANCH IF YES. 46880013 MVC TEMP(2),DATBYT+1(P7) LOAD P8 WITH LENGTH OF STRING. 46960013 LH P8,TEMP 47040013 JPGL3 C P2,EIGHT IS IT CHARACTER CLASS 47120013 BCR BNE,GR14 RETURN IF NO. 47200013 TM DATBYT(P7),X'02' 47220015 BC BZ,*+8 BRANCH IF NOT AREA 47240015 LA P8,16(P8) ALLOW FOR CONTROL BYTES 47260015 JPGL4 EQU * ENTRR HERE FOR CAD PICTURES. 24175 47270001 AR P8,P8 CONVERT LENGTH TO BITS. 47280013 AR P8,P8 47360013 AR P8,P8 47440013 BCR B,GR14 RETURN 47520013 SPACE 5 47600013 * STRING LENGTH IS ADJUSTABLE. 47680013 SPACE 3 47760013 JPGL2 L P8,OOFF LOAD P8 WITH X'00FFFFFF' 47840013 BCR B,GR14 RETURN 47920013 SPACE 5 48000013 * ITEM IS A NUMERIC FIELD. 48080013 SPACE 3 48160013 JPGL1 ST GR14,TEMP STORE RETURN ADDRESS. 48240013 * IF THIS ITEM IS PICTURED THEN GET THE LENGTH FROM THE PICTURE 41949 48242046 * DIC ENTRY. OTHERWISE WE OBTAIN THE LENGTH IN THE FOLLOWING WAY 48244046 * FLOAT 41949 48246046 * IF DEC AND>=6 THEN 8 BYTES 41949 48248046 * IF DEC AND<6 THEN 4 BYTES 4194 48250046 * IF BIN AND PRECISION>=21 THEN 8 BYTES 41949 48252046 * IF BIN AND PRECISION<21 THEN 4 BYTES 41949 48254046 * 41949 48256046 * FIXED 41949 48258046 * IF DEC THENP/2+1 BYTES 41949 48260046 * IF BIN THEN P BITS. 41949 48262046 XR P8,P8 CLEAR REG 8 41949 48264046 TM DATBYT(P7),X'08' IS IT PICTURE 41949 48266046 BNO PICT YES - BRANCH 41949 48268046 TM DATBYT(P7),X'02' IS IT FLOAT 41949 48270046 BO FLOT YES BRANCH 4194 48272046 TM DATBYT(P7),X'04' IS IT BINARY 41949 48274046 BO BIN YES SO BRANCH 41949 48276046 * DECIMAL FIXED. 41949 48278046 IC P8,DATBYT+1(P7) INSERT PRECISION 48280046 SRL P8,1 DIVIDE BY 2 41949 48282046 A P8,ONE ADD IN 1 41949 48284046 B CMPLX TEST FOR CMPLX 41949 48286046 BIN EQU * BINARY FIXED 4164 48288046 LA P8,2 MIN OF 2 BYTES 41949 48288346 TM DATBYT(P7),BIT2 * IS THIS A POINTER 47632 48288456 BO FULWRD * OR OFFSET , YES SET LEN=4 7632 48288556 CLI DATBYT+1(P7),X'10' IF P<16 THEN 1/2 WORD 41949 48288646 BL HAFWRD 41949 48288946 FULWRD SLL P8,1 * SET LENGTH TO 32 BITS 47632 48289256 HAFWRD EQU * 48289546 B CMPLX TEST FOT COMPLEX 41949 48290546 FLOT EQU * FLOATING POINT VARIABLE 41949 48292046 LA P8,4 LENGTH AT LEAST 4 41949 48294046 TM DATBYT(P7),X'04' IS IT BINARY 41949 48296046 BO FLBIN YES - BRANCH 41949 48298046 * FLOAT DECIMAL 41949 48300046 CLI DATBYT+1(P7),X'06' IS IT LONG 41949 48302046 BNL LONG YES SO BRANCH 41949 48304046 B CMPLX TEST FOR COMPLEX 41949 48306046 FLBIN CLI DATBYT+1(P7),X'15' IS IT LONG 41949 48308046 BL SHRT NO SO BRANCH 41949 48310046 LONG A P8,FOUR 8 BYTES FOR LONG 41949 48312046 B CMPLX 41949 48314046 PICT EQU * 41949 48316046 MVC PAR1+2(2),DATBYT+4(P7) LOAD P6 WITH ADDRESS OF PICTURE 48320013 BALR GR14,GR15 TABLE DICT ENTRY. 48400013 L P6,PAR1 48480013 L GR14,TEMP RELOAD RETURN ADDRESS. 48560013 * LOAD P8 WITH APPARENT LENGTH OF41949 48640046 IC P8,11(0,P6) PICTURE. 48720013 SHRT EQU * 48740046 CMPLX EQU * 41949 48760046 TM DATBYT(P7),BIT8 IS DATA OF MODE COMPLEX. 48800013 BZ JPGL4 BRANH IF NO 24175 48880001 AR P8,P8 DOUBLE APPARENT LENGTH. 48960013 B JPGL4 24175 49040001 EJECT 49120013 * SUBROUTINE GETCLS 49200013 SPACE 5 49280013 * FUNCTION/OPERATION - 49360013 * THIS SUBROUTINE SCANS A STRUCTURE DESCRIPTION AND 49440013 * DETERMINES THAT ALL THE BASE ELEMENTS OF THE STRUCTURE ARE OF 49520013 * THE SAME DEFINING CLASS. 49600013 * IT IS ENTERED WITH THE DICT REF OF THE FIRST ELEMENT OF 49680013 * THE STRUCTURE IN NXDR AND THE STRUCTURE LEVEL IN LEV. 49760013 * THE SUBROUTINE RETURNS THE CLASS VALUE OF THE ELEMENTS 49840013 * IN REGISTER P2. 49920013 SPACE 3 50000013 * ENTRY POINTS - GETCLS 50080013 SPACE 3 50160013 * EXTERNAL ROUTINES - (1) ZDRFAB 50240013 SPACE 3 50320013 * EXITS NORMAL - JPGC7 50400013 SPACE 3 50480013 * EXITS ERROR - ALL BRANCHES TO LABELS OF FORM PERR I 50560013 SPACE 3 50640013 * TABLES/WORK AREAS - TABLE 1 FOR TESTING DATA BYTES. 50720013 SPACE 3 50800013 * NOTES - N/A 50880013 SPACE 5 50960013 GETCLS ST GR14,TEMP STORE RETURN ADDRESS. 51040013 MVC PAR1+2(2),NXDR LOAD DREG WITH ADDRESS OF DICT 51120013 JPGC3 BALR GR14,GR15 ENTRY OF NEXT STRUCTURE ELEMENT 51200013 L DREG,PAR1 51280013 TM 0(DREG),X'0F' IS ITEM STRING OR ARITH DATA. 51360013 BC BO,JPGC1 BRANCH IF YES. 51440013 TM 0(DREG),X'0E' IS ITEM A STRUCTURE. 51520013 BC BNO,PERR1 ERROR IF NO. 51600013 TM 0(DREG),BIT4 IS STRUCTURE DIMENSIONED. 51680013 BC BZ,JPGC2 BRANCH IF NO. 51760013 MVC PAR1+2(2),STRVAR+11(DREG) MOVE DICT REF OF NEXT ELEMENT 51840013 * TO PARAMETER SLOT. 51920013 BC B,JPGC3 52000013 SPACE 5 52080013 * THE STRUCTURE IS UNDIMENSIONED. 52160013 SPACE 3 52240013 JPGC2 MVC PAR1+2(2),STRVAR+8(DREG) MOVE DICT REF OF NEXT ELEMENT 52320013 * TO PARAMETER SLOT. 52400013 BC B,JPGC3 52480013 SPACE 5 52560013 * THE ITEM IS STRING OR ARITH DATA. 52640013 SPACE 3 52720013 JPGC1 TM OTH4(DREG),BIT5 I1 52750016 BC BO,PERR11 BRANCH IF NOT PACKED I1 52780016 SPACE 1 I1 52810016 TRT DATBYT(1,DREG),TABLE1 TEST STR ELEMENT DATA BYTE I1 52840016 BC B,*(P2) 52880013 BC B,JPGC4 BIT CLASS. 52960013 BC B,JPGC4 CHARACTER CLASS. 53040013 BC B,PERR1 CODED ARITH. ERROR. 53120013 BC B,PERR10 VARYING STRING. ERROR. 53200013 SPACE 5 53280013 * STRUCTURE ELEMENT IS OF THE STRING CLASS. 53360013 SPACE 3 53440013 JPGC4 ST P2,CLASS STORE CLASS VALUE IN CLASS. 53520013 TM OTH1(DREG),BIT5 IS ITEM THE LAST OF THE 53600013 BC BO,JPGC7 STRUCTURE. BRANCH IF YES. 53680013 TM 0(DREG),BIT4 IS ITEM DIMENSIONED. 53760013 BC BZ,JPGC5 BRANCH IF NO. 53840013 MVC PAR1+2(2),DATVAR+11(DREG) MOVE DICT REF OF NEXT 53920013 * STRUCTURE ELEMENT TO PARAMETER 54000013 * SLOT. 54080013 BC B,JPGC6 54160013 JPGC5 MVC PAR1+2(2),DATVAR+8(DREG) LOAD DREG WITH ADDRESS OF DICT 54240013 JPGC6 BALR GR14,GR15 ENTRY FOR NEXT STRUCTURE 54320013 L DREG,PAR1 ELEMENT. 54400013 TM 0(DREG),X'0F' IS ELEMENT STRING OR ARITH DATA. 54480013 BC BO,JPGC8 BRANCH IF YES. 54560013 TM 0(DREG),BIT4 IS ITEM DIMENSIONED 54640013 BC BO,JPGC9 BRANCH IF YES. 54720013 MVC ELEV(5),STRVAR+5(DREG) MOVE ITEM STRUCTURE LEVEL TO 54800013 BC B,JPGC10 ELEV AND DICT REF OF NEXT 54880013 JPGC9 MVC ELEV(5),STRVAR+8(DREG) STRUCTURE ELEMENT TO EDR. 54960013 JPGC10 CLC ELEV(1),LEV IS ELEV GREATER THAN THE LEVEL 55040013 * OF THE STRUCTURE BEING EXAMINED. 55120013 BC BNH,JPGC7 BRANCH IF NO. 55200013 TM 0(DREG),X'0E' IS ITEM A STRUCTURE. 55280013 BC BNO,PERR1 ERROR IF NO. 55360013 JPGC11 TM OTH1(DREG),BIT5 IS IT THE END OF THE STRUCTURE. 55440013 BC BO,JPGC7 BRANCH IF YES. 55520013 MVC PAR1+2(2),EDR MOVE DICT REF OF NEXT ELEMENT TO 55600013 * THE PARAMETER SLOT. 55680013 BC B,JPGC6 55760013 SPACE 5 55840013 * STRUCTURE ELEMENT IS STRING OR ARITH DATA 55920013 SPACE 3 56000013 JPGC8 TM 0(DREG),BIT4 IS ITEM DIMENSIONED. 56080013 BC BZ,JPGC12 BRANCH IF NO. 56160013 MVC ELEV(5),DATVAR+8(DREG) MOVE STRUCTURE LEVEL OF ITEM TO 56240013 BC B,JPGC13 ELEV AND THE DICT REF OF THE 56320013 JPGC12 MVC ELEV(5),DATVAR+5(DREG) NEXT ELEMENT TO EDR. 56400013 JPGC13 CLC ELEV(1),LEV IS LEVEL GREATER THAN THAT OF 56480013 * STRUCTURE BEING EXAMINED. 56560013 BC BNH,JPGC7 BRANCH IF NO. 56640013 TRT DATBYT(1,DREG),TABLE1 TEST ITEM DATA BYTE. 56720013 BC B,*(P2) 56800013 BC B,JPGC14 BIT CLASS. 56880013 BC B,JPGC14 CHAR CLASS. 56960013 BC B,PERR1 CODED ARITH. ERROR. 57040013 BC B,PERR10 VARYING STRING. ERROR. 57120013 SPACE 5 57200013 * STRUCTURE ELEMENT IS OF THE STRING CLASS. 57280013 SPACE 3 57360013 JPGC14 C P2,CLASS IS CLASS THE SAME AS THAT OF 57440013 * PRECEDING ITEMS. 57520013 BC BE,JPGC11 57600013 BC B,PERR15 ERROR IF NO. 57680013 SPACE 5 57760013 * THE WHOLE OF THE STRUCTURE HAS BEEN EXAMINED AND 57840013 * FOUND TO CONTAIN ELEMENTS ALL OF THE SAME STRING 57920013 * DEFINING CLASS. 58000013 SPACE 3 58080013 JPGC7 L GR14,TEMP RELOAD RETURN ADDRESS. 58160013 BCR B,GR14 RETURN 58240013 EJECT 58320013 * SUBROUTINE STRCMP 58400013 SPACE 5 58480013 * FUNCTION/OPERATION - 58560013 * THIS SUBROUTINE EXAMINES TWO STRUCTURE DESCRIPTIONS 58640013 * AND DETERMINES WHETHER THEY ARE THE SAME. 58720013 * ON ENTRY THE DICT REFERENCES OF THE FIRST ELEMENTS OF 58800013 * THE TWO STRUCTURES ARE IN NXDDR AND NDR. THE LEVEL OF THE 58880013 * FIRST STRUCTURE IS ASSUMED TO BE ONE AND THE LEVEL OF THE 58960013 * SECOND IS IN LEV. THE DIMENSIONALITY OF THE FIRST STRUCTURE 59040013 * IS IN DDIM AND THAT OF THE SECOND IN BDIM. 59120013 * THE STRUCTURE DESCRIPTIONS ARE SCANNED IN PARALLEL 59200013 * AND EACH PAIR OF ELEMENTS EXAMINED FOR A MATCH OF DATA 59280013 * CHARACTERISTICS, DIMENSIONALITY (IN EXCESS OF THAT OF THE 59360013 * CONTAINING STRUCTURE) AND BOUNDS. 59440013 * IF THE STRUCTURE DESCRIPTIONS MATCH CONTROL IS 59520013 * RETURNED VIA THE FIRST RETURN POINT, OTHERWISE VIA THE SECOND 59600013 * RETURN. 59680013 SPACE 3 59760013 * ENTRY POINTS - STRCMP 59840013 SPACE 3 59920013 * EXTERNAL ROUTINES - (1) ZDRFAB 60000013 SPACE 3 60080013 * EXITS NORMAL - JPSC24 60160013 SPACE 3 60240013 * EXITS ERROR - ALL BRANCHES TO LABELS OF FORM PERR I. 60320013 SPACE 3 60400013 * TABLES/WORK AREAS - TABLE1. FOR TESTING DATA BYTES. 60480013 SPACE 3 60560013 * NOTES - N/A 60640013 SPACE 5 60720013 STRCMP ST GR14,SCTEMP STORE RETURN ADDRESS. 60800013 MVC NXBDR(2),NXDR MOVE DICT REF OF FIRST ELEMENT 60880013 * OF BASE TO NXBDR. 60960013 JPSC9 MVC PAR1+2(2),NXDDR LOAD DREG WITH ADDRESS OF DICT 61040013 BALR GR14,GR15 ENTRY OF NEXT ELEMENT OF 61120013 L DREG,PAR1 DEFINED STRUCTURE. 61200013 MVC PAR1+2(2),NXBDR LOAD BREG WITH ADDRESS OF DICT 61280013 BALR GR14,GR15 ENTRY OF NEXT ELEMENT OF BASE 61360013 L BREG,PAR1 STRUCTURE. 61440013 TM 0(BREG),X'0F' IS BASE STRING OR ARITH DATA. 61520013 BC BO,JPSC1 BRANCH IF YES. 61600013 TM 0(BREG),BIT4 IS BASE DIMENSIONED. 61680013 BC BZ,JPSC2 BRANCH IF NO. 61760013 MVC BDIM2+3(9),STRVAR+4(BREG) MOVE DIMENSIONALITY OF BASE 61840013 * TO BDIM2, DICT REF OF DIM TABLE 61920013 * TO BDIMDR, STRUCTURE LEVEL TO 62000013 * BLEV, AND DICT REF OF NEXT 62080013 * STRUCTURE ELEMENT TO NXBDR. 62160013 BC B,JPSC3 62240013 SPACE 5 62320013 * ITEM IS UNDIMENSIONED. 62400013 SPACE 3 62480013 JPSC2 MVI BDIM2+3,X'00' MOVE DIMENSIONALITY OF BASE TO 62560013 * BDIM2. 62640013 MVC BLEV(5),STRVAR+5(BREG) MOVE STRUCTURE LEVEL TO BLEV AND 62720013 * DICT REF OF NEXT ELEMENT TO 62800013 * NXBDR. 62880013 JPSC3 CLC BLEV(1),LEV IS LEVEL OF BASE ELEMENT GREATER 62960013 * THAN THAT OF BASE STRUCTURE. 63040013 BC BNH,JPSC4 BRANCH IF NO. 63120013 MVC CODE(1),0(DREG) IS NUMERIC PART OF CODE BYTE 63200013 XC CODE(1),0(BREG) OF BASE ELEMENT DICT ENTRY THE 63280013 TM CODE,X'0F' SAME AS THAT OF THE DEFINED 63360013 BC BNZ,JPSC4 ELEMENT. BRANCH IF NOT. 63440013 TM 0(DREG),X'0F' ARE ELEMENTS STRING OR ARITH. 63520013 BC BO,JPSC5 BRANCH IF YES 63600013 TM 0(DREG),BIT4 IS DEFINED ELEMENT DIMENSIONED. 63680013 BC BZ,JPSC11 BRANCH IF NO. 63760013 MVC DDIM2+3(9),STRVAR+4(DREG) MOVE DIMENSIONALITY OF DEFINED 63840013 * ITEM TO DDIM2, DICT REF OF DIM 63920013 * TABLE TO DDIMDR AND DICT REF OF 64000013 * NEXT ELEMENT TO NXDDR. 64080013 BC B,JPSC12 64160013 SPACE 5 64240013 * DEFINED ITEM IS UNDIMENSIONED 64320013 SPACE 3 64400013 JPSC11 MVI DDIM2+3,X'00' MOVE DIMENSIONALITY OF DEFINED 64480013 * ITEM TO DDIM2. 64560013 MVC NXDDR(2),STRVAR+8(DREG) MOVE DICT REF OF NEXT ELEMENT 64640013 * TO NXDDR. 64720013 JPSC12 L P2,BDIM2 LOAD P2 WITH THE DIFFERENCE 64800013 * BETWEEN DIMENSIONALITY OF BASE 64880013 S P2,BDIM ELEMENT AND BASE STRUCTURE. 64960013 L P1,DDIM2 LOAD P1 WITH THE DIFFERENCE 65040013 * BETWEEN DIMENSIONALITY OF 65120013 S P1,DDIM DEFINED ELEMENT AND DEFINED 65200013 * STRUCTURE. 65280013 CR P1,P2 ARE THESE DIFFERENCES THE SAME. 65360013 BC BNE,JPSC4 BRANCH IF NO. 65440013 MVN NUMIC(1),0(DREG) ARE ELEMENTS BEING CONSIDERED 65520013 CLI NUMIC,X'0E' STRUCTURES. 65600013 BC BE,JPSC9 BRANCH IF YES. 65680013 LTR P2,P2 IS DIMENSIONALITY DIFFERENCE 65760013 BC BZ,JPSC6 ZERO. BRANCH IF YES. 65840013 MVC PAR1+2(2),DDIMDR LOAD DREG WITH ADDRESS OF 65920013 BALR GR14,GR15 DIMENSION TABLE FOR DEFINED 66000013 L DREG,PAR1 ELEMENT. 66080013 MVC PAR1+2(2),BDIMDR LOAD BREG WITH ADDRESS OF 66160013 BALR GR14,GR15 DIMENSION TABLE FOR BASE 66240013 L BREG,PAR1 ELEMENT. 66320013 L P1,DDIM LOAD P1 WITH 8 * THE 66400013 AR P1,P1 DIMENSIONALITY OF THE DEFINED 66480013 AR P1,P1 STRUCTURE. 66560013 AR P1,P1 66640013 LA DREG,12(P1,DREG) BUMP DREG BY 12+ VALUE IN P1 66720013 L P1,BDIM LOAD P1 WITH 8* DIMENSIONALITY 66800013 AR P1,P1 OF BASE STRUCTURE. 66880013 AR P1,P1 66960013 AR P1,P1 67040013 LA BREG,12(P1,BREG) BUMP BREG BY 12 + VALUE IN P1 67120013 SPACE 5 67200013 * DREG AND BREG NOW POINT TO THE FIRST ENTRIES OF THE 67280013 * DIMENSION TABLES FOR BOUNDS WHICH ARE NOT INHERITED FROM THE 67360013 * DEFINED AND BASE STRUCTURES RESPECTIVELY. 67440013 SPACE 3 67520013 AR P2,P2 DOUBLE P2 FOR USE AS A BOUND 67600013 * COUNTER. 67680013 JPSC8 CLI 0(DREG),X'00' IS BOUND CONSTANT 67760013 BC BNE,JPSC7 BRANCH IF NO. 67840013 CLI 0(BREG),X'00' IS BOUND CONSTANT 67920013 BC BNE,JPSC7 BRANCH IF NO. 68000013 CLC 1(3,DREG),1(BREG) ARE BASE AND DEFINED ELEMENT 68080013 * BOUNDS THE SAME. 68160013 BC BNE,JPSC4 BRANCH IF NO. 68240013 JPSC7 LA DREG,4(0,DREG) BUMP BREG AND DREG TO NEXT BOUND 68320013 LA BREG,4(0,BREG) 68400013 BCT P2,JPSC8 IS IT THE LAST BOUND. BRANCH 68480013 * IF NO. 68560013 JPSC6 CLC NXDDR(2),STOPR IS IT THE END OF THE DEFINED 68640013 * STRUCTURE. 68720013 BC BE,JPSC10 BRANCH IF YES. 68800013 CLC NXBDR(2),STOPR IS IT THE END OF THE BASE 68880013 * STRUCTURE. 68960013 BC BNE,JPSC9 BRANCH IF NO. 69040013 SPACE 5 69120013 * THE STRUCTURE DESCRIPTIONS OF BASE AND DEFINED ITEM DO 69200013 * NOT MATCH. WE RETURN VIA THE SECOND RETURN POINT. 69280013 SPACE 3 69360013 JPSC4 L GR14,SCTEMP 69440013 BC B,4(0,GR14) 69520013 SPACE 5 69600013 * BASE ITEM IS STRING OR ARITH DATA. 69680013 SPACE 3 69760013 JPSC1 TM 0(BREG),BIT4 IS BASE ELEMENT DIMENSIONED. 69840013 BC BZ,JPSC13 BRANCH IF NO. 69920013 MVC BDIM2+3(9),DATVAR+4(BREG) MOVE DIMENSIONALITY TO BDIM2, 70000013 * DICTREF OF DIM TABLE TO BDIMDR, 70080013 * LEVEL OF ITEM TO BLEV AND DICT 70160013 * REF OF NEXT ITEM IN STRUCTURE 70240013 * TO NXBDR. 70320013 BC B,JPSC3 70400013 SPACE 5 70480013 * BASE ITEM IS UNDIMENSIONED. 70560013 SPACE 3 70640013 JPSC13 MVI BDIM2+3,X'00' MOVE DIMENSIONALITY OF BASE TO 70720013 * BDIM2. 70800013 MVC BLEV(5),DATVAR+5(BREG) MOVE ITEM LEVEL TO BLEV AND DICT 70880013 * REF OF NEXT STRUCTURE ELEMENT TO 70960013 * NXBDR. 71040013 BC B,JPSC3 71120013 SPACE 5 71200013 * BOTH BASE AND DEFINED ITEM ARE STRING OR ARITH. 71280013 SPACE 3 71360013 JPSC5 TM 0(DREG),BIT4 IS DEFINED ELEMENT DIMENSIONED. 71440013 BC BZ,JPSC17 BRANCH IF NO. 71520013 MVC DDIM2+3(9),DATVAR+4(DREG) MOVE DIMENSIONALITY OF DEFINED 71600013 * ITEM TO DDIM2, DIM TABLE DICT 71680013 * REF TO DDIMDR AND DICT REF OF 71760013 * NEXT ELEMENT TO NXDDR. 71840013 BC B,JPSC18 71920013 SPACE 5 72000013 * DEFINED ITEM IS UNDIMENSIONED. 72080013 SPACE 3 72160013 JPSC17 MVI DDIM2+3,X'00' MOVE DIMENSIONALITY TO DDIM2. 72240013 MVC NXDDR(2),DATVAR+8(DREG) MOVE DICT REF OF NEXT STRUCTURE 72320013 * ELEMENT TO NXDDR. 72400013 JPSC18 TRT DATBYT(1,DREG),TABLE1 TEST DEFINED ELEMENT DATA BYTE 72480013 ST P2,CLASS STORE CLASS IN CLASS. 72560013 TRT DATBYT(1,BREG),TABLE1 TEST BASE ELEMENT DATA BYTE. 72640013 C P2,CLASS ARE CLASSES THE SAME. 72720013 BC BNE,JPSC4 BRANCH IF NO. 72800013 BC B,*(P2) 72880013 BC B,JPSC15 BIT CLASS. 72960013 BC B,JPSC15 CHARACTER CLASS. 73040013 BC B,JPSC16 CODED ARITH. 73120013 BC B,PERR10 VARYING STRING. ERROR. 73200013 SPACE 5 73280013 * BOTH BASE AND DEFINED ITEMS ARE OF THE STRING CLASS. 73360013 SPACE 3 73440013 JPSC15 LR P7,DREG LOAD P8 WITH LENGTH OF DEFINED 73520013 BAL GR14,GETLTH ELEMENT. 73600013 C P8,OOFF IS LENGTH ADJUSTABLE. 73680013 BC BE,JPSC12 BRANCH IF YES. 73760013 ST P8,DLTH STORE LENGTH IN DLTH. 73840013 OI BDFLG,X'0E' 21127 73880001 LR P7,BREG LOAD P8 WITH LENGTH OF BASE 73920013 BAL GR14,GETLTH ELEMENT. 74000013 C P8,OOFF IS LENGTH ADJUSTABLE. 74080013 BC BE,JPSC12 BRANCH IF YES. 74160013 C P8,DLTH ARE LENGTHS OF DEFINED ELEMENT 74240013 BC BE,JPSC12 AND BASE THE SAME. BRANCH IF YES 74320013 BC B,JPSC4 74400013 SPACE 5 74480013 * BOTH BASE AND DEFINED ELEMENT ARE CODED ARITH. 74560013 SPACE 3 74640013 JPSC16 TM DATBYT(DREG),X'C0' 74670015 BC BO,JPSC25 BRANCH IF POINTER OR OFFSET 74700015 SPACE 74730015 CLC DATBYT(3,DREG),DATBYT(BREG) ARE DATA CHARACS OF 74760015 * DEFINED AND BASE ELEMENTS THE 74800013 BC BE,JPSC12 SAME. BRANCH IF YES. 74880013 BC B,PERR20 74960013 SPACE 74970015 JPSC25 CLC DATBYT(1,DREG),DATBYT(BREG) 74980015 BC BE,JPSC12 BRANCH IF SAME DATA TYPEWS 74990015 BC B,PERR20 75000015 SPACE 5 75040013 * IT IS THE END OF THE DEFINED STRUCTURE. 75120013 SPACE 3 75200013 JPSC10 CLC NXBDR(2),STOPR IS IT THE END OF THE BASE 75280013 BC BNE,JPSC20 STRUCTURE. BRANCH IF NO 75360013 JPSC24 L GR14,SCTEMP RETURN. 75440013 BCR B,GR14 75520013 SPACE 5 75600013 * MORE STRUCTURE ELEMENTS FOLLOW IN THE BASE. 75680013 SPACE 3 75760013 JPSC20 MVC PAR1+2(2),NXBDR LOAD BREG WITH ADDRESS OF DICT 75840013 BALR GR14,GR15 ENTRY OF NEXT ELEMENT OF BASE 75920013 L BREG,PAR1 STRUCTURE. 76000013 LR P4,BREG 21156 76080001 TM 0(BREG),BIT4 LOAD P4 WITH ADDRESS OF 76160013 BC BZ,JPSC21 STRUCTURE INFORMATION IN DICT 76240013 LA P4,3(0,P4) ENTRY. 21156 76320001 JPSC21 TM 0(BREG),X'0F' 76400013 BC BO,JPSC22 76480013 LA P4,STRVAR(0,P4) 76560013 BC B,JPSC23 76640013 JPSC22 LA P4,DATVAR(0,P4) 76720013 JPSC23 CLC LEV(1),1(P4) IS ELEMENT LEVEL GREATER THAN 76800013 * LEVEL OF BASE STRUCTURE. 76880013 BC BL,JPSC4 BRANCH IF YES. 76960013 BC B,JPSC24 77040013 EJECT 77120013 * PROGRAMMER ERRORS 77200013 SPACE 5 77280013 * THE DEFINING OF DELTA DECLARED IN STATEMENT NO $ 77360013 * INVOLVES DATA NOT ALLOWED FOR STRING CLASS OVERLAY DEFINING. 77440013 SPACE 3 77520013 PERR1 MVI PAR6+2,X'50' 77600013 BC B,ERROR8 77680013 SPACE 5 77760013 * THE DATA CHARACTERISTICS OF DELTA DECLARED IN STATEMENT 77840013 * NO $ DO NOT MATCH THOSE OF THE DEFINING BASE. 77920013 SPACE 3 78000013 PERR8 MVI PAR6+2,X'51' 78080013 BC B,ERROR8 78160013 SPACE 5 78240013 * THE DIMENSIONALITY OF DELTA DECLARED IN STATEMENT NO $ 78320013 * IS NOT THE SAME AS THAT OF THE DEFINING BASE. 78400013 SPACE 3 78480013 PERR9 MVI PAR6+2,X'52' 78560013 BC B,ERROR1 78640013 SPACE 5 78720013 * THE DEFINING OF DELTA DECLARED IN STATEMENT NO $ 78800013 * ILLEGALLY INVOLVES VARYING STRINGS. 78880013 SPACE 3 78960013 PERR10 MVI PAR6+2,X'53' 79040013 MVI FLAG,XF0 * SAY THIS COND DETECTED 47616 79080056 BC B,ERROR1 79120013 SPACE 5 79200013 * THE DEFING OF DELTA DECLARED IN STATEMENT NO $ 79280013 * ILLEGALLY INVOLVES DATA AGGREGATES THAT ARE NOT PACKED. 79360013 SPACE 3 79440013 PERR11 MVI PAR6+2,X'54' 79520013 BC B,ERROR8 79600013 SPACE 5 79680013 PERR12 DC X'0000' NOW REDUNDANT. 79760013 SPACE 5 79840013 PERR13 CLI CONTSW,X'FF' 79920013 BC BE,WERR1 80000013 SPACE 5 80080013 * THE DEFINING BASE OF DELTA DECLARED IN STATEMENT NO $ 80160013 * IS SHORTER THAN THE DEFINED ITEM. 80240013 SPACE 3 80320013 MVI PAR6+2,X'56' 80400013 BC B,ERROR1 80480013 SPACE 5 80560013 * THE DEFINING OF DELTA DECLARED IN STATEMENT NO $ 80640013 * INVOLVES A STRUCTURE HAVING ELEMENTS NOT ALL OF THE SAME 80720013 * DEFINING CLASS. 80800013 SPACE 3 80880013 PERR15 MVI PAR6+2,X'57' 80960013 BC B,ERROR8 81040013 SPACE 5 81120013 * THE DEFINING OF DELTA DECLARED IN STATEMENT NO $ 81200013 * ILLEGALLY INVOLVES THE POS ATTRIBUTE. 81280013 SPACE 3 81360013 PERR19 MVI PAR6+2,X'58' 81440013 BC B,ERROR1 81520013 SPACE 5 81600013 * THE STRUCTURE DESCRIPTION OF DELTA DECLARED IN 81680013 * STATEMENT NO $ DOES NOT MATCH THAT OF THE BASE IT IS 81760013 * DEFINED ON. 81840013 SPACE 3 81920013 PERR20 MVI PAR6+2,X'59' 82000013 BC B,ERROR8 82080013 SPACE 5 82160013 * PROGRAMMER WARNINGS. 82240013 SPACE 5 82320013 * IF THE BASE OF DELTA DECLARED IN STATEMENT 82400013 * NO $ IS ALLOCATED WITH THE DECLARED EXTENTS THE DEFINING WILL 82480013 * BE IN ERROR. 82560013 SPACE 3 82640013 WERR1 MVI PAR6+2,X'5A' 82720013 MVI PAR6+3,X'5C' 82800013 BC B,ERROR2 82880013 SPACE 5 82960013 * THE DEFINING BASE OF DELTA DECLARED IN $ IS AN ARRAY 83040013 * FORMAL PARAMETER. IF THE MATCHING ARGUMENT IS AN ELEMENT OF 83120013 * AN ARRAY OF STRUCTURES THE DEFINING WILL BE IN ERROR. 83200013 SPACE 3 83280013 WERR2 MVI PAR6+2,X'5B' 83360013 MVI PAR6+3,X'58' 83440013 BC B,ERROR2 83520013 SPACE 5 83600013 SPACE 5 83680013 ERROR8 MVI PAR6+3,X'58' 83760013 BC B,ERROR2 83840013 ERROR1 MVI ERRFLG,X'FF' SET ERROR FLAG ON. 83920013 MVI PAR6+3,X'50' MOVE ERROR CODE TO PARAMETER 84000013 ERROR2 MVI PAR6+1,X'04' SLOT. 84080013 MVC PAR7+2(2),DR MOVE DICT REF OF DEFINED ITEM 84160013 * TO PARAMETER SLOT. 84240013 MVC PAR1+2(2),DR LOAD DREG WITH ADDRESS OF DICT 84320013 BALR GR14,GR15 ENTRY OF DEFINED ITEM. 84400013 L DREG,PAR1 84480013 SR P5,P5 84560013 SR P6,P6 84640013 TM OTH1(DREG),BIT4 84720013 BC BO,*+8 SKIP IF DVD PRESENT 84800013 LA P5,ERROR4-ERROR3 SET JUMP INDEX 84880013 SPACE 84960013 TM OTH4(DREG),BIT8 85040013 BC BO,*+8 SKIP IF RDV PRESENT 85120013 LA P6,ERROR6-ERROR5 SET JUMP INDEX 85200013 BC B,ERROR3(P5) BRANCH IF NO DVD 85280013 SPACE 85360013 ERROR3 MVC PAR1+2(2),8(DREG) *** DVD PRESENT 85440013 BALR GR14,GR15 GET DVD ENTRY 85520013 L DREG,PAR1 85600013 LA DREG,2(DREG) 85680013 ERROR4 BC B,ERROR5(P6) BRANCH IF NO RDV 85760013 SPACE 85840013 ERROR5 MVC PAR1+2(2),8(DREG) *** RDV PRESENT 85920013 BALR GR14,GR15 GET RDV ENTRY 86000013 L DREG,PAR1 86080013 LA DREG,10(DREG) 86160013 SPACE 86240013 ERROR6 MVC ZSTAT(2),8(DREG) SET STATEMENT NUMBER 86320013 ERROR7 L GR15,ZUERR ADD ERROR MESSAGE TO DICTIONARY 86400013 BALR GR14,GR15 86480013 L GR15,ZDRFAB * RESTORE REG 15 57452 86485072 TM BDFLG,X'0E' HAS DEF ITEM LENGTH BEEN 38198 86490042 BNO JP20 SET - NO ,SO NO TEST 38198 86500042 TM BDFLG,X'F0' HAS BASE LEN BEEN SET 38198 86510042 BO JP514 * YES, SO NORM CHECK 57452 86520072 MVC PAR1+2(2),DR RESTORE REGISTERS 38198 86521046 BALR GR14,GR15 * TO POINT AT DEF & BASE 57452 86522072 L DREG,PAR1 THEY COULD HAVE BEEN 38198 86524046 MVC PAR1+2(2),BDR CORRUPTED IN ROUTINE STRCOMP 86525046 BALR GR14,GR15 86526046 L BREG,PAR1 38198 86527046 LR P7,BREG LOAD R7 WITH BASE ADDR 38198 86530042 TM FLAG,XF0 * HAVE WE SPOTTED VAR BASE 47616 86531056 BO JP20 * YES, THEN CARRY ON 47616 86532056 TM DATBYT(BREG),BIT1 * IS THIS A STRING ? 47616 86533056 BO CAD * NO, THEN NO POINT IN NEXT TEST 86534056 TM DATBYT(BREG),BIT4 * IS BASE A VARYING STRING 47616 86535056 BO PERR10 * YES THEN GO RAISE ERROR 47616 86536056 CAD EQU * 86537056 TM 0(BREG),X'0F' IS IT DARA 38198 86540042 BNO STRLEN NO SO STRUC 38198 86550042 TRT DATBYT(1,BREG),TABLE1 SET P2 WITH CLASS 38198 86560042 TM 0(BREG),X'10' IS IT DIMENSIONED 41949 86562046 BO DIMVA 86564046 NODIM EQU * NOT DIMENSIONED 41949 86566046 BAL GR14,GETLTH GET LENGTH IN P8 38198 86570042 ST P8,BLTH STORE LENGTH OF BASE 38198 86576046 SETLEN EQU * 86582046 OI BDFLG,X'F0' SET FLAG 38198 86590042 B JP514 * YES, THEN CARRY ON 57452 86600072 STRLEN EQU * GET LENGTH OF STRUC BASE 38198 86610042 TM 0(BREG),X'10' IS BASE DIMENED 38198 86620042 BO DIMSTR YES 38198 86630042 MVC BLTH+1(3),STRVAR+11(BREG) SET LENGTH 38198 86640042 B SETLEN 86650042 DIMSTR EQU * 86660042 CLC SUB(3),FFFF IS BASE SUBSCRIPTED 41949 86663046 BNE NODIM 41949 86666046 MVC BLTH+1(3),STRVAR+14(BREG) SET LENGTH 38198 86670042 B SETLEN 38198 86680042 DIMVA EQU * 86685046 CLC SUB(3),FFFF IS BASE SUBSCRIPTED 41949 86690046 BNE NODIM JUST ONE ELEMENT 41949 86695046 * WE CANNOT CHECK ANY FURTHER. SET BASE LENGTH TO 'UNKNOWN' 86700046 MVC BLTH(4),OOFF 86705046 B JP20 86710046 EJECT 86720013 * DATA AREAS FOR PHASE JP. 86800013 SPACE 5 86880013 * ONE BYTE ITEMS. 86960013 SPACE 3 87040013 NUMIC DC X'00' 87120013 CODE DC X'00' 87200013 PSW DC X'00' 87280013 CONTSW DC X'00' 87360013 FPSW DC X'00' 87440013 ERRFLG DC X'00' 87520013 PICBYT DC X'00' 5087 87560016 FLAG DC X'00' 47616 87580056 SPACE 5 87600013 * TWO BYTE ITEMS. 87680013 SPACE 3 87760013 DR DC H'0' DICT REF OF DEFINED ITEM. 87840013 SPACE 5 87920013 * FOUR BYTE ITEMS. 88000013 SPACE 3 88080013 STOPR DC F'0' WORD OF ZERO BYTES. 88160013 TEMP DC F'0' TEMPORARY WORD ALIGNED WORKSPACE 88240013 NINE DC F'9' 88320013 DCLASS DC F'0' DEFINED ITEM CLASS. 88400013 BCLASS DC F'0' BASE CLASS. 88480013 DLTH DC F'0' DEFINED ITEM LENGTH. 88560013 BLTH DC F'0' BASE LENGTH. 88640013 FOUR DC F'4' 88720013 TWO DC F'2' 88800013 BDIM DC F'0' DIMENSIONALITY OF BASE. 88880013 DDIM DC F'0' DIMENSIONALITY OF DEFINED ITEM. 88960013 CLASS DC F'0' 89040013 EIGHT DC F'8' 89120013 ONE DC F'1' 41949 89140046 SIX DC F'6' 41949 89160046 OOFF DC X'00FFFFFF' 89200013 SCTEMP DC F'0' 89280013 FFFF DC X'FFFFFFFF' 89360013 JPLST DC C'JPZZ' 89440013 ELEVEN DC F'11' 89520013 SPACE 5 89600013 * OTHER ITEMS. 89680013 SPACE 3 89760013 ELEV DC X'00' 89840013 DC X'0000' 89920013 EDR DC X'0000' 90000013 SPACE 90080013 NDR DC X'0000' 90160013 BDR DC X'0000' 90240013 SUB DC X'000000' 90320013 SPACE 2 90400013 CNOP 0,4 90480013 DDR DC X'0000' 90560013 DC X'00' 90640013 LEV DC X'00' 90720013 CSTR DC X'0000' 90800013 NXDR DC X'0000' 90880013 DDIM2 DC F'0' 90960013 DDIMDR DC H'0' 91040013 DC X'00' 91120013 DLEV DC X'00' 91200013 DC X'0000' 91280013 NXDDR DC X'0000' 91360013 BDIM2 DC F'0' 91440013 BDIMDR DC H'0' 91520013 DC X'00' 91600013 BLEV DC X'00' 91680013 DC X'0000' 91760013 NXBDR DC X'0000' 91840013 BDFLG DC X'00' 21127 91880001 SPACE 5 91920013 * TRANSLATE AND TEST TABLE FOR A DATA BYTE 92000013 * GIVING DEFINING CLASS. 92080013 SPACE 5 92160013 TABLE1 DC 2X'0404040408080808' 00-0F 92240013 DC 4X'10101010' 10-1F 92320013 DC 2X'0404040408080808' 20-2F 92400013 DC 4X'10101010' 30-3F 92480013 DC 2X'0404040408080808' 40-4F 92560013 DC 4X'10101010' 50-5F 92640013 DC 2X'0404040408080808' 60-6F 92720013 DC 4X'10101010' 70-7F 92800013 DC 8X'08080808040404040C0C0C0C0C0C0C0C' 80-FF 92880013 SPACE 5 92960013 EJECT 93040013 LTORG 94040056 ORG IEMJP+X'1000' 95040056 END IEMJP 96040056 ./ ADD SSI=02012963,NAME=IEMJZ,SOURCE=0 * R20.6 +190000 Z2155 00200046 JZ TITLE 'IEMJZ,SECOND HALF PHASE DIRECTORY,OS/360 PL/1(F)' 00500013 * 01000013 * STATUS-CHANGE LEVEL 0 01500013 * 02000013 * 02500013 * FUNCTIONS- 1)CONSTRUCTS A BUILD LIST OF PHASES IN THE 03000013 * SECOND HALF OF THE COMPILER 03500013 * 2)ISSUES A BLDL ON THIS LIST 04000013 * 3)RECONSTRUCTS THE PHASE DIRECTORY FOR THE 04500013 * SECOND HALF OF THE COMPILER 05000013 * 05500013 * 06000013 * ENTRY POINT-BEGIN 06500013 * 07000013 * 07500013 * INPUT-THE INPUT IS THE SECOND HALF LIST IN THE RESIDENT 08000013 * CONTROL PHASE(AA) 08500013 * 09000013 * 09500013 * OUTPUT-THE RECONSTRUCTED PHASE DIRECTORY 10000013 * 10500013 * 11000013 * EXTERNAL ROUTINES-1)ZUPL TO INDICATE AN ERROR HAS OCCRRD 11500013 * 2)ZEND TO KILL COMPILER 12000013 * 3)BLDL TO FILL THE BLDL LIST OF PHASES 12500013 * 13000013 * 13500013 * EXIT-NORMAL THROUGH RLSCTL TO THE NEXT PHASE 14000013 * ABNORMAL THROUGH ZEND TO KILL COMPILER 14500013 * 15000013 * 15500013 * ATTRIBUTES-NONE 16000013 EJECT 16500013 IEMJZ START 0 17000013 USING *,GR8 17500013 NAME DC C'JZ' 18000013 BEGIN L GR8,PAR1(0,DICR) BASE THIS PHASE 18500013 ST DICR,DICTEM 19000013 MVC MYNAM(2,DICR),NAME TELL THE WORLD ITS US Z2155 19200046 MVI SECHF(DICR),X'FF' SHOW IS IN SECOND HALF 19500013 SPACE 20000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*JZ 001-TSS 20200019 LA GRA,PHASE1 POINT AT AREA TO CONSTRUCT BLD 20500013 L GRB,PAROF(0,CNTL) LIST. THEN POINT AT LIST OF PHASES 21000013 L GRC,SECPDOF(0,GRB) IN THE SECOND HALF OF COMPILER 21500013 XR GRD,GRD SET COUNTER TO ZERO 22000013 SPACE 22500013 BLDLOOP MVC PHSNAM+3(2),0(GRC) PICK UP PHASE NAME 23000013 MVC 0(8,GRA),PHSNAM INSERT IN BUILD LIST 23500013 LA GRA,30(0,GRA) BUMP TO NEXT IN BUILD LIST 24000013 LA GRC,3(0,GRC) BUMP TO NEXT IN NAME LIST 24500013 LA GRD,1(0,GRD) COUNT 1 25000013 CLI 0(GRC),X'00' SEE IF END OF LIST 25500013 BC BNE,BLDLOOP 26000013 SPACE 26500013 STH GRD,BLDLST STORE NUMBER OF ENTRIES 27000013 SPACE 27500013 XR 1,1 SET TO ZERO FOR BLDL 28000013 LA 0,BLDLST POINT AT BLD LIST 28500013 SPACE 29000013 LA DICR,SAVAR POINT AT SAVE AREA FOR BLDL 29500013 BLDL (1),(0) 30000013 L DICR,DICTEM POINT AT DICTIONARY AGAIN 30500013 SPACE 31000013 BC B,HERE(15) TEST IF BLDL COMPLETED CORRECTLY 31500013 HERE BC B,OK 32000013 BC B,OK 32500013 BC B,BLDERR ERROR ON BUILDING 33000013 SPACE 33500013 OK LA GRA,PHASE1 POINT AT FILLED BLDL LIST 34000013 LH GRB,LENGTH PICK UP LENGTH 34500013 L GRE,PAROF(0,CNTL) 35000013 L GRD,PDOF(0,GRE) PICK UP AREA TO CONSTRUCT NEW PD 35500013 L GRE,SECPDOF(0,GRE) NAME LIST TO PICK UP STATUS 36000013 LH GRF,BLDLST SET COUNT TO NO OF PHASES 36500013 SPACE 37000013 CONTIN MVC 0(2,GRD),3(GRA) MOVE IN ID 37500013 MVC 3(2,GRD),11(GRA) CONCAT AND ZERO 38000013 MVC 5(3,GRD),14(GRA) TTR 38500013 MVC 8(2,GRD),25(GRA) TOTAL CORE 39000013 MVC 10(2,GRD),27(GRA) LENGTH OF FST TEXT RCD 39500013 MVC 2(1,GRD),2(GRE) PICK UP CURRENT STATUS 40000013 LA GRD,12(0,GRD) BUMP TO NEXT IN BUILD LIST 40500013 LA GRE,3(0,GRE) NEXT IN SECOND HALF LIST 41000013 LA GRA,0(GRB,GRA) BUMP TO NEXT IN BLDL LIST 41500013 BCT GRF,CONTIN COUNT THE PHASES 42000013 SPACE 42500013 MVI 0(GRD),X'00' MOVE IN STOPPER BYTE 43000013 SPACE 43500013 MVI SCNOF(DICR),X'00' CAUSE POINTERS TO BE REINIT 44000013 * ----------------------------------------------------JZ 001-TSS 44200019 TM CCCODE(DICR),X'40' SEE IF COMPILER HAS ABORTED 44500013 BC BZ,CARYON 45000013 LA GRA,XANAM 45500013 ST GRA,PAR2(0,DICR) POINT AT ERROR MESSAGE PHASE 46000013 BC B,RLSTHS 46500013 CARYON XC PAR2(4,DICR),PAR2(DICR) LOAD NEXT REQUESTED PHASE 47000013 RLSTHS LA GRA,RLSNAM POINT AT NAME TO RELEASE PHASE 47500013 ST GRA,PAR1(0,DICR) 48000013 L LR,RLSCTL(0,CNTL) 48500013 BALR RR,LR PASS CONTROL TO NEXT PHASE 49000013 * +++++++++++++++++++++++++++++++++++++++++++++++++++*JZ 002-TSS 49200001 SPACE 49500013 BLDERR LA GRA,BLDMES SAY I/O ERROR ON BUILDING 50000013 ST GRA,PAR1(0,DICR) DIRECTORY 50500013 L LR,ZUPLOF(0,CNTL) 51000013 BALR RR,LR 51500013 LA GRA,16 SHOW TERMINAL ERROR HAS OCCURRED 52000013 ST GRA,ERCODE(0,DICR) 52500013 L LR,ZEND(0,CNTL) KILL COMPILER 53000013 BALR RR,LR 53500013 * ----------------------------------------------------JZ 002-TSS 53700001 EJECT 54000013 PHSNAM DC C'IEMXY ' 54500013 XANAM DC C'XA' 55000013 BLDMES DC X'0029' 55500013 DC C'-' 56000015 DC C'IEM3841I I/O ERROR ON SEARCHING DIRECTORY' 56500013 SAVAR DS 18F 57000013 DICTEM DS F 57500013 RLSNAM DC C'JZZZ' 58000013 BLDLST DC H'0' 58500013 LENGTH DC H'30' 59000013 PHASE1 DC 1800H'0' SPACE FOR 120 ENTRIES 59300001 * ** THIS MUST BE AS BIG AS SCNDLST IN AA 59600001 LAST DC X'00' 60000013 EJECT 60500013 * 61000013 * REGISTER EQUATES 61500013 * 62000013 GR0 EQU 0 62500013 GRA EQU 1 63000013 GRB EQU 2 63500013 GRC EQU 3 64000013 GRD EQU 4 64500013 GRE EQU 5 65000013 GRF EQU 6 65500013 GR8 EQU 8 66000013 CNTL EQU 11 66500013 DICR EQU 13 67000013 RR EQU 14 67500013 LR EQU 15 68000013 * 68500013 * BRANCH EQUATES 69000013 * 69500013 B EQU 15 70000013 BR EQU 15 70500013 BE EQU 8 71000013 BZ EQU 8 71500013 BNE EQU 7 72000013 * 72500013 * TRANSFER VECTOR EQUATES 73000013 * 73500013 ZUPLOF EQU X'08' 74000013 PAROF EQU X'1C' 74500013 RLSCTL EQU X'48' 75000013 ZEND EQU X'6C' 75500013 * 76000013 * INITIALISATION LIST EQUATES 76500013 * 77000013 PDOF EQU 28 77500013 SECPDOF EQU 84 78000013 * 78500013 * COMMUNICATION REGION EQUATES 79000013 * 79500013 MYNAM EQU 112 80000013 PAR1 EQU 128 80500013 PAR2 EQU PAR1+4 81000013 SCNOF EQU 184 81500013 SECHF EQU 185 82000013 ERCODE EQU 224 82500013 CCCODE EQU 232 83000013 SPACE 83500013 END IEMJZ 84000013 ./ ADD SSI=00012600,NAME=IEMKA,SOURCE=0 KA TITLE 'PL/1 (F) COMPILER K PHASES RESIDENT CONTROL MODULE.' 00060001 * 00070001 * 00080001 * FUNCTIONS - (1) TO PROVIDE UTILITY ROUTINES FOR THE 00090001 * K PHASES FOR HANDLING TABLES IN TEXT BLOCKS.THE ROUTINES 00100001 * PROVIDE FACILITIES FOR BUILDING,SCANNING,MAKING DIRECT 00110001 * REFERENCE,LOCKING,UNLOCKING AND FREEING TABLE ENTRIES. 00120001 * THE NORMAL TEXT MAY ALSO BE PROCESSED BY THE TABLE 00130001 * HANDLING ROUTINES. 00140001 * 00150001 * (2) TO PROVIDE A LOCAL COMMUNICATIONS REGION 00160001 * FOR THE K PHASES. THIS DATA AREA IS BASED ON GRLCOM, 00170001 * WHICH ALSO ACTS AS A BASE REGISTER FOR THIS MODULE. 00180001 * 00190001 * 00200001 * 00210001 * EXTERNAL ROUTINES CALLED(IN COMPILER CONTROL): 00220001 * RLSCTL,ZTXTAB,ZUTXTC,ZUERR,ZABORT,ZALTER,ZCHAIN. 00230001 * 00240001 * 00250001 * 00260001 * ENTRY POINTS(1) NORMAL ENTRY FROM PREVIOUS PHASE. 00270001 * 00280001 * (2) ENTRIES FROM K PHASES FOR CALLS TO 00290001 * UTILITIES - SEE TRANSFER VECTOR KAVECT. 00300001 * 00310001 * 00320001 * 00330001 * EXIT POINTS (1) EXIT TO NEXT PHASE BY CALL TO RLSCTL. 00340001 * KA REMAINS IN STORE FO USE BY OTHER K PHASES BUT IS 00350001 * DELETED BY A CALL TO RLSCTL IN KO JUST BEFORE LOADING 00360001 * MODULE KT. 00370001 * 00380001 * (2) TERMINAL ERROR BY CALL TO ZABORT. 00390001 * 00400001 * 00410001 * 00420001 * WORK AREA XLCR - THE K PHASES COMMUNICATIONS REGION 00430001 * IN THIS MODULE KA. 00440001 * 00450001 * 00460001 * 00470001 * NOTE THIS MODULE REQUIRES THE IEMK... MACROS 00480001 * FOR ASSEMBLY 00490001 EJECT 00780001 * 00840001 EQUD DSECT DUMMY DSECT STATEMENT 00847001 * PREVENTS THE ASSEMBLER GIVING 00854001 * RISE TO A CSECT WITH NAME BLANK 00861001 * AND LENGTH ZERO 00868001 * ON MEETING THE FIRST EQU 00875001 * STATEMENT 00882001 * 00889001 ** LOCAL EQUATES 00900001 * 00960001 SAVARNO EQU 5 DEPTH OF TYPE 1 SAVE AREA NESTING 01020001 GRX EQU 2 WORK REGISTER 01080001 * 01140001 SPACE 2 01200001 COPY IEMKEQU 01260001 COPY IEMKCOM 01320001 COPY IEMKUTL 01380001 COPY IEMKTRP 01440001 * * 01500001 ** THE XTCA DSECT DESCRIBES THE FORMAT OF A TABLE CONTROL AREA ** 01560001 ** AS SET UP BY THE DTCA MACRO-INSTRUCTION. ** 01620001 * * 01680001 XTCA DSECT 01740001 * 01800001 USING *,GR9 ALWAYS BASED BY GR9 01860001 * 01920001 XTCAENTL DS H LENGTH OF ENTRY OR DISP TO LENG FLD 01980001 XTCADISP DS H DISPLACEMENT TO LENGTH IN V.L. ENTRY 02040001 * 02100001 XTCACODE DS X TABLE TYPE AND STATUS CODE BYTE: 02160001 XTCANULL EQU X'80' ON IF NO ENTRIES IN TABLE 02220001 XTCAACTV EQU X'40' ON IF TABLE TO BE DEACTIVATED 02280001 XTCAFIXL EQU X'20' TABLE CONTAINS FIXED LENGTH ENTRIS 02340001 XTCAVARL EQU X'10' TABLE CONTAINS VAR. LENGTH ENTRIES 02400001 XTCAMIXD EQU X'08' TABLE CONTAINS MIXED ENTRIES 02460001 XTCACPTR DS X CURRENT POINTER - SET BY CALLER 02520001 XTCALLEN DS H LENGTH OF LAST ENTRY 02580001 * 02640001 XTCASTBL DS A ADDRESS OF FIRST BLOCK LIST ENTRY 02700001 XTCASTCD DS X START OF TABLE CODE (AS XPRGCODE) 02760001 XTCASTSA DS XL3 SYMBOLIC ADDRESS OF START OF TABLE 02820001 * 02880001 XTCAETAA DS A ABSOLUTE ADDRESS OF LAST ENTRY MADE 02940001 XTCAETBL DS A ADDRESS OF LAST BLOCK LIST ENTRY 03000001 XTCAETCD DS X END OF TABLE CODE (AS XPRGCODE) 03060001 XTCAETSA DS XL3 SYMBOLIC ADDRESS OF END OF TABLE 03120001 * 03180001 ** AT THIS POINT THE TCA CONTAINS UA TO 'NPTRS+1' POINTER REGIONS WHICH 03240001 ** ARE DESCRIBED BY THE XPRG DSECT. IF A DIRECT REFERENCE POINTER IS 03300001 ** IS PRESENT IT WILL APPEAR FIRST. THE REMAINING 'NPTRS' POINTERS 03360001 ** ARE SEQUENTIAL SCAN POINTERS. 03420001 * 03480001 XTCAPTRS EQU * START OF LIST OF POINTERS 03540001 * 03600001 ** THE FOLLOWING SECTION DESCRIBES THE TCA FOR TEXT TABLES 03660001 * 03720001 ORG XTCA 03780001 XTCATPAR DS A PARAMETER SLOT 03840001 XTCATNAA DS A A.A. OF NEXT ENTRY 03900001 XTCATCDE DS X CODE BYTE: 03960001 XTCATLOK EQU X'40' ON IF CURRENT ENTRY LOCKED 04020001 XTCATACT EQU X'20' 04080001 XTCATNSA DS XL3 S.A. OF NEXT ENTRY 04140001 XTCATCAA DS A A.A. OF CURRENT ENTRY 04200001 DS X NOT UESD 04260001 XTCATCSA DS XL3 S.A. OF CURRENT ENTRY 04320001 DS X NOT USED 04380001 XTCATPSA DS XL3 S.A. OF PREVIOUS ENTRY 04440001 * 04500001 EJECT 04560001 * 04620001 ** THE XPRG DSECT DESCRIBES THE FORMAT OF A POINTER REGIONS. 04680001 * 04740001 XPRG DSECT 04800001 * 04860001 XPRGAATE DS A ABSOLUTE ADDRESS OF TABLE ENTRY 04920001 XPRGABLE DS A ADDRESS OF BLOCK LIST ENTRY 04980001 XPRGCODE DS X CODE BYTE: 05040001 XPRGLPRG EQU X'80' ON FOR LAST POINTER REGION 05100001 XPRGLOCK EQU X'40' ON IF ENTRY LOCKED 05160001 XPRGSETD EQU X'20' ON IF 'SET' WAS LAST OPERATION 05220001 XPRGSETZ EQU X'10' ON IF 'SETZ' WAS LAST OPERATION 05280001 XPRGPACT EQU X'08' ON IF POINTER IS ACTIVE 05340001 XPRGTOLK EQU X'04' ON IF ENTRY TO BE LOCKED 05400001 XPRGFBOP EQU X'02' ON IF BACKWARD OPTION SPECIFIED 05460001 XPRGKDOP EQU X'01' ON IF DELETE OPTION SPECIFIED 05520001 XPRGSATE DS XL3 SYMBOLIC ADDRESS OF ENTRY 05580001 * 05640001 XPRGEND EQU * 05700001 * 05760001 EJECT 05820001 COPY IEMKBLE 05880001 * * 05940001 ** Y VERSION OF XBLE DSECT ** 06000001 * * 06060001 YBLE DSECT 06120001 * 06180001 YBLELCNT DS PL1 FOR FIELD DESCRIPTIONS 06240001 YBLEANLE DS AL3 SEE XBLE 06300001 YBLEBLKN DS X DSECT 06360001 YBLEAPLE DS AL3 06420001 YBLEDFEN DS H 06480001 YBLEDLEN DS H 06540001 * 06600001 YBLEEND EQU * 06660001 * 06720001 EJECT 06780001 DCBD 06960001 EJECT 07020001 IEMKA CSECT 07080001 DC C'KA' PHASE IDENTIFIER 07140001 * 07200001 ** THE FOLLOWING SECTION IS ENTERED FROM COMPILER CONTROL, PERFORMS 07260001 ** INITIALISATION AND PASSES CONTROL TO THE PHASE LOADING ROUTINE. 07320001 * 07380001 BALR LR,0 USE LR AS 07440001 USING *,LR TEMPORARY BASE 07500001 MVC ZMYNAM(2),=C'KA' 07560001 LA GRLCOM,KAXLCR BASE LOCAL COMMUNICATIONS REGION 07620001 LA GR2,=C'ZZ' STORE ADDRESS FO DELETE PHASE LIST 07630001 ST GR2,PAR1 IN PAR1 07640001 SR GR2,GR2 SET ZERO FOR STORE 07650001 ST GR2,PAR2 INDICATE NO LOAD LIST 07660001 L LR,RLSCTL CALL RLSCTL TO LOAD 07670001 BR LR NEXT PHASE 07680001 SPACE 07740001 USING KAXLCR,GRLCOM GRLCOM IS NOW BASE 07800001 DROP LR 07860001 EJECT 07920001 * 07980001 ** KAXLCR IS THE LOCAL COMMUNICATIONS REGION. IT HAS THE SAME LABELS AS 08040001 ** THE XLCR DSECT MACRO WHICH IS USED TO DESCRIBE THIS AREA IN OTHER 08100001 ** PHASES. THE XLCR MACRO MAY NOT THEREFORE BE USED IN THIS PHASE. 08160001 * 08220001 KAXLCR DS 0D 08280001 XLCRASCR DS 0A ADDRESS OF START OF SCRATCH CORE 08340001 XLCRXISP DC A(0) AND OF INITIAL SCAN PARAMETER BLOCK 08400001 XLCRCODE DC X'0' CODE BYTE: 08460001 XLCRPRBG EQU X'01' ON IF ABNORMAL UNSAFE VARIABLE PRESENT 08520001 XLCRABSF EQU X'02' ON IF PROC OR BEGIN IN CURRENT ITDO 08580001 XLCRFMAP DC XL3'0' TEXT REF. OF FIRST LOGICAL DO-MAP ENTRY 08640001 XLCRBSE1 DC A(0) 08820001 XLCRUASC DC A(0) UPPER ADDRESS OF SCRATCH CORE 08880001 DC X'00' 08940001 XLCRONUS DC XL3'0' ON UNITS MASK 09000001 XLCRAFFE DC A(0) ADDRESS OF FIRST FREE ENTRY IN -09060001 BLOCK LIST TABLE 09120001 XLCRTXT DC A(0) POINTERS 09180001 XLCRMAP DC A(0) TO 09240001 XLCRUSE DC A(0) TCAS 09300001 XLCRSRG DC A(0) FILLED IN 09360001 XLCRSRT DC A(0) BY 09420001 XLCRPCH DC A(0) PHASE KB 09480001 XLCREND EQU * 09540001 * 09600001 SPACE 2 09660001 * 09720001 ** THE KAVECT TRANSFER VECTOR PROVIDES LINKAGE BETWEEN OTHER KA PHASES 09780001 ** AND THE COMMON ROUTINES IN THIS PHASE. IN THE XLCR DSECT, EACH 09840001 ** BRANCH INSTRUCTION HAS THE SAME LABEL AS THE ROUTINE TO WHICH 09900001 ** IT LINKS. 09960001 * 10020001 KAVECT DS 0H 10080001 B KAHBLD TABLE HANDLING - BLDC/T 10260001 B KAHMDR DR 10320001 B KAHUDR ULDR 10380001 B KAHSET SET/SETZ 10440001 B KAHSCN SCAN 10500001 B KAHDAC DEACT 10560001 B KAHFRE FREE 10620001 B KAHTST SET/SETZ TEXT 10650001 B KAHTSC SCAN TEXT 10680001 B KAHTDA DEACT TEXT 10710001 B KAHERR ERROR HANDLER 10740001 * 10860001 EJECT 10920001 *********************************************************************** 21720001 * * 21780001 * ROUTINE KAHBLD. (HANDLES BLDC/T OPERATIONS). * 21840001 * * 21900001 * THIS ROUTINE MAKES AN ENTRY IN THE SPECIFIED TABLE. FOR BLDC THE * 21960001 * TNTRY IS MOVED INTO THE NEXT AVAILABLE SPACE IN THE TABLE. FOR * 22020001 * BLDT A SPACE FOR AN ENTRY IS ALLOCATED AND ITS ADDRESS RETURNED * 22080001 * TO THE CALLER. IF THERE IS INSUFFICIENT SPACE IN THE CURRENT TEXT * 22140001 * BLOCK FOR A NEW ENTRY OR THE TABLE IS NULL (HAS NO ENTRIES) A NEW * 22200001 * TEXT BLOCK IS OBTAINED FROM COMPILER CONTROL AND AN ENTRY FOR THE * 22260001 * BLOCK IS ADDED TO THE BLOCK LIST. * 22320001 * * 22380001 * REGISTER USAGE: * 22440001 * * 22500001 * GR2 - LENGTH OF NEW ENTRY * 22560001 * GR5 - ADDRESS OF BLOCK LIST ENTRY * 22620001 * GR6 - ADDRESS OF BLOCK LIST ENTRY * 22680001 * GR7 - ADDRESS OF NEW ENTRY IN CORE IF BLDC * 22740001 * GR8 - ABSOLUTE ADDRESS OF NEW OR CURRENT ENTRY * 22800001 * GR9 - ADDRESS OF TCA. * 22860001 * * 22920001 * PARAMETERS PASSED: * 22980001 * * 23040001 * ON ENTRY - PR0 - ADDRESS OF ENTRY IF BLDC, ELSE ZERO * 23100001 * PR1 - ADDRESS OF TCA * 23160001 * * 23220001 * ON EXIT - PR0 - ABSOLUTE ADDRESS OF NEW ENTRY. * 23280001 * PR1 - ADDRESS OF S.A. FIELD IN PRG * 23340001 * * 23400001 * RETURN CODE: NONE. * 23460001 * * 23520001 * FAILS: THE ONLY FAIL OCCURS WHEN THE BLOCK LIST TABLE BECOMES * 23580001 * FULL AND A NEW BLOCK IS TO BE ADDED TO A TABLE. THE * 23640001 * FAIL MAY BE OVERCOME BY INCREASING THE SIZE OF THE * 23700001 * BLOCK LIST TABLE. A FAIL MAY ALSO OCCUR IN MODULE KAHLOK. * 23760001 * * 23820001 *********************************************************************** 23880001 SPACE 2 23940001 KAHBLD IEMKENT TYPE=1 24000001 * * 24060001 USING XBLE,GR6 24120001 USING YBLE,GR5 24180001 * 24240001 LR GR9,PR1 BASE XTCA DSECT 24300001 L GR6,XTCAETBL BASE XBLE DSECT 24360001 SPACE 24420001 * * 24480001 LR GR7,PR0 SAVE BLDC ENTRY ADDRESS 24540001 * * 24600001 * DETERMINE LENGTH OF ENTRY. IF ENTRIES ARE FIXED LENGTH, THE LENGTH * 24660001 * IS OBTAINED FROM XTCAENTL. OTHERWISE IT IS OBTAINED FROM THE ENTRY * 24740001 * SKELETON ITSELF. * 24820001 * * 24900001 TM XTCACODE,XTCAFIXL TEST IF FIXED LENGTH 24960001 BO HBLDLDLN BRANCH IF SO 25020001 MVC XTHRWORK(2),0(GR7) ALIGN LENGTH FIELD OF ENTRY 25120001 LH GR2,XTHRWORK LOAD LENGTH 25260001 B HBLDTNUL SKIP FIXED LENGTH LOAD 25320001 SPACE 25380001 HBLDLDLN LH GR2,XTCAENTL LOAD LENGTH OF ENTRY INTO GR2 25440001 SPACE 25500001 HBLDTNUL TM XTCACODE,XTCANULL IF NULL TABLE, 25560001 BO HBLDGNTB GO TO ROUTINE TO GET NEW TEXT BLCK 25620001 SPACE 25680001 TM XTCAETCD,XPRGLOCK TEST IF CURRENT ENTRY LOCKED 25740001 BO HBLDUPDT BRANCH IF SO 25800001 LA PR1,XTCAETAA LOAD PRG ADDRESS FOR KAHLOK 25860001 BAL RR,KAHLOK CALL KAHLOK TO LOCK CURRENT ENTRY 25920001 MVC PAR1+1(3),XTCAETSA MOVE S.A. TO PAR1 25980001 MVI PAR1,X'80' INDICATE NO STATUS CHANGE 26040001 L LR,ZTXTAB CALL ZTXTAB 26100001 BALR RR,LR TO CONVERT S.A. TO ABSOLUTE 26160001 MVC XTCAETAA+1(3),PAR1+1 STORE ABSOLUTE ADDRESS 26220001 SPACE 26280001 * * 26340001 * UPDATE CREATION POINTER WITH LENGTH OF LAST ENTRY MADE AND * 26400001 * DETERMINE WHETHER SUFFICIENT SPACE EXISTS IN CURRENT TEXT BLOCK * 26460001 * TO ADD A NEW ENTRY. IF INSUFFICIENT SPACE GO TO ROUTINE TO GET * 26520001 * NEW TEXT BLOCK. * 26580001 * * 26640001 HBLDUPDT L GR3,XTCAETAA LOAD ABSOLUTE ADDRESS 26700001 AH GR3,XTCALLEN ADD LAST ENTRY'S LENGTH 26760001 ST GR3,XTCAETAA STORE UPDATED ADDRESS 26820001 LH GR3,XTCAETSA+1 LOAD TEXT REF. DISPLACEMENT 26880001 AH GR3,XTCALLEN ADD LENGTH 26940001 STH GR3,XTCAETSA+1 STORE UPDATED DISPLACEMENT 27000001 AR GR3,GR2 ADD LENGTH OF NEW ENTRY 27060001 C GR3,TXTSZ COMPARE SUM WITH TEXT BLOCK SIZE 27120001 BH HBLDULPE IF HIGH GO TO GET NEW TEXT BLOCK 27180001 SPACE 27240001 MVC XBLEDLEN,XTCAETSA+1 UPDATE BLE END OF TABLE POINTER 27300001 SPACE 27360001 * * 27420001 * TEST WHETHER OPERATION WAS BLDC. IF SO, MOVE ENTRY INTO BLOCK. * 27480001 * * 27540001 HBLDTBDC L GR8,XTCAETAA LOAD ADDRESS OF NEW ENTRY 27600001 LTR GR7,GR7 TEST IF BLDT 27660001 BZ HBLDSTOL BRANCH IF SO 27720001 LR GR3,GR2 FORM LENGTH-1 27780001 BCTR GR3,0 FOR MVC 27840001 EX GR3,HBLDMVCI EXECUTE MOVE TO MOVE ENTRY TO BLOCK 27900001 SPACE 27960001 HBLDSTOL STH GR2,XTCALLEN SAVE LENGTH FOR UPDATING NEXT TIME 28020001 LR PR0,GR8 LOAD RETURN PARAMETER REGISTER 28080001 LA PR1,XTCAETSA LOAD RETURN PARAMETER REGISTER 28140001 B HBLDEXIT EXIT 28200001 SPACE 28260001 * * 28320001 * ROUTINE TO ADD A NEW BLOCK TO THE TABLE. THIS ROUTINE IS ENTERED * 28380001 * AT HBLDULPE IF THE TABLE ALREADY HAS ENTRIES AND AT HBLDGNTB IF * 28440001 * THE TABLE IS NULL. A NEW BLOCK IS OBTAINED FROM COMPILER CONTROL * 28500001 * AND AN ENTRY FOR THE BLOCK ADDED TO THE BLOCK LIST FOR THE TABLE. * 28560001 * THE CREATION POINTER IS UPDATED TO REFERENCE THE NEW BLOCK. FOR A * 28620001 * NULL TABLE THE START OF TABLE POINTER IS UPDATED TO SHOW THE START * 28680001 * OF THE TABLE AND THE TABLE IS MARKED NON-NULL. * 28740001 * * 28800001 HBLDULPE LA PR1,XTCAETAA LOAD ADDRESS OF PRG FOR KAHULK 28860001 BAL RR,KAHULK CALL KAHULK TO UNLOCK ENTRY 28920001 SPACE 28980001 HBLDGNTB MVI PAR2+3,X'00' INDICATE NO CHAINING 29040001 L LR,ZUTXTC CALL ZUTXTC 29100001 BALR RR,LR TO GET TEXT BLOCK 29160001 MVC XTCAETSA,PAR1+1 STORE TEXT REF. 29220001 MVC XTCAETAA+1(3),PAR2+1 AND ABSOLUTE ADDRESS OF NEW BLOCK 29280001 SPACE 29340001 * * 29400001 * ADD NEW ENTRY TO BLOCK LIST * 29460001 * * 29520001 CLI XTHRAFFE+1,X'FF' TEST IF BLOCK LIST TABLE FULL 29580001 BNE HBLDGNFE BRANCH IF NOT 29640001 XC PAR5(5),PAR5 CLEAR PAR5 29660001 MVC PAR6+1(3),=X'0F0600' MOVE MESSAGE NUMBER TO PAR6 29680001 L LR,ZUERR CALL ZUERR 29700001 BALR RR,LR TO INSERT MESSAGE IN DICTIONARY 29720001 L LR,ZABORT CALL ZABORT 29740001 BR LR TO TERMINATE COMPILATION 29760001 SPACE 29820001 HBLDGNFE L GR5,XTHRAFFE BASE YBLE FOR FIRST FREE BLT ENTRY 29880001 MVC XTHRAFFE+1(3),YBLEANLE UPDATE NEXT FREE ENTRY POINTER 29940001 XC YBLEANLE,YBLEANLE CLEAR POINTER TO NEXT ENTRY 30000001 MVC YBLEBLKN,XTCAETSA MOVE BLOCK NUMBER 30060001 MVC YBLEDFEN,XTCAETSA+1 AND DISPLACEMENTS 30120001 MVC YBLEDLEN,XTCAETSA+1 TO NEW LIST ENTRY 30180001 MVI YBLELCNT,X'0C' SET LOCK COUNT FIELD TO ZERO 30210001 SPACE 30240001 TM XTCACODE,XTCANULL TEST IF NULL TABLE 30300001 BO HBLDNULT BRANCH IF SO 30360001 MVC YBLEAPLE,XTCAETBL+1 SET BACKWARDS CHAIN 30420001 ST GR5,XTCAETBL UPDATE BLE POINTER IN TCA 30480001 MVC XBLEANLE,XTCAETBL+1 SET FORWARD CHAIN IN PREVIOUS BLE 30540001 B HBLDLOCK GO TO LOCK/UNLOCK ENTRY 30600001 SPACE 30660001 HBLDNULT ST GR5,XTCAETBL UPDATE BLE POINTER IN TCA 30720001 XC YBLEAPLE,YBLEAPLE CLEAR BACKWARDS CHAIN 30780001 SPACE 30840001 MVC XTCASTBL(8),XTCAETBL INITIALIZE START OF TABLE POINTER 30900001 MVI XTCASTCD,X'0' CLEAR CODE BYTE 30960001 SPACE 31020001 XI XTCACODE,XTCANULL TURN OFF NULL TABLE BIT 31080001 SPACE 31140001 HBLDLOCK LA PR1,XTCAETAA LOAD PRG ADDRESS FOR KAHLOK 31200001 BAL RR,KAHLOK CALL KAHLOK TO LOCK ENTRY 31260001 B HBLDTBDC RETURN TO MAINLINE 31320001 SPACE 31380001 * 31440001 HBLDMVCI MVC 0(0,GR8),0(GR7) MVC FOR EXECUTE 31500001 * 31560001 HBLDEXIT IEMKLVE NORC 31620001 DROP GR5,GR6 31680001 EJECT 31740001 *********************************************************************** 31800001 * * 31860001 * ROUTINE KAHMDR. (HANDLES DR OPERATION). * 31920001 * * 31980001 * THIS ROUTINE RETURNS THE ABSOLUTE ADDRESS OF AN ENTRY IDENTIFIED * 32040001 * BY A SYMBOLIC ADDRESS SUPPLIED BY THE CALLER. IF LOCK IS * 32100001 * SPECIFIED, ANY CURRENT LOCKED DIRECT REFERENCE IS UNLOCKED AND * 32160001 * THE NEW ENTRY IS LOCKED. * 32220001 * * 32280001 * REGISTER USAGE: * 32340001 * * 32400001 * GR6 - ADDRESS OF DIRECT REFERENCE POINTER * 32460001 * GR7 - ADDRESS OF SYMBOLIC ADDRESS * 32520001 * GR8 - ADDRESS OF BLOCK LIST ENTRY * 32580001 * GR9 - ADDRESS OF TCA * 32640001 * * 32700001 * PARAMETERS PASSED: * 32760001 * * 32820001 * ON ENTRY - PR0 - ADDRESS OF SYMBOLIC ADDRESS * 32880001 * PR1 - ADDRESS OF TCA * 32940001 * * 33000001 * ON EXIT - PR0 - ABSOLUTE ADDRESS OF ENTRY * 33060001 * * 33120001 * RETURN CODE: NONE * 33180001 * * 33240001 * FAILS: THE ROUTINE WILL FAIL IF LOCK IS SPECIFIED AND FOUR * 33300001 * LOCKED ENTRIES ALREADY EXIST IN THE SYSTEM. * 33360001 * A FAIL WILL OCCUR IF THE REFERENCED TABLE IS NULL, OR * 33420001 * IF THE SUPPLIED SYMBOLIC ADDRESS SPECIFIES A BLOCK NOT * 33480001 * IN THE TABLE. * 33540001 * * 33600001 *********************************************************************** 33660001 SPACE 2 33720001 KAHMDR IEMKENT TYPE=1 33780001 * * 33840001 USING XBLE,GR8 33900001 USING XPRG,GR6 33960001 * * 34020001 LR GR9,PR1 BASE XTCA DSECT 34080001 LR GR7,PR0 SAVE ADDRESS OF SA 34140001 LA GR6,XTCAPTRS BASE XPRG DSECT 34200001 SPACE 34260001 * * 34620001 * THIS ROUTINE SCANS THE BLOCK LIST TO DETERMINE WHETHER ANY ENTRY * 34680001 * HAS THE SAME BLOCK NUMBER AS THE SUPPLIED SYMBOLIC ADDRESS. IF * 34740001 * NO SUCH ENTRY IS FOUND, THE ROUTINE FAILS. * 34800001 * * 34860001 HMDRTSAD L GR8,XTCASTBL GET FIRST BLOCK LIST ENTRY 34920001 SPACE 34980001 HMDRTBLP CLC XBLEBLKN,0(GR7) TEST IF SAME BLOCK NO. AS SA 35040001 BE HMDRFOUN EXIT FROM LOOP IF SO 35100001 L GR8,XBLEANLE-1 LOAD CHAIN TO NEXT ENTRY 35280001 B HMDRTBLP LOOP TO TRY NEXT ENTRY 35340001 SPACE 35400001 * * 35640001 * THE FOLLOWING ROUTINE CONVERTS THE SUPPLIED SYMBOLIC ADDRESS TO * 35700001 * ABSOLUTE. IF NO LOCK IS SPECIFIED THE ROUTINE THEN EXITS. * 35760001 * OTHERWISE, IF A CURRENT LOCKED ENTRY EXISTS IT IS UNLOCKED BY * 35820001 * KAHULK. THE NEW REFERENCE IS THEN LOCKED AND THE DIRECT REFERENCE * 35880001 * POINTER UPDATED. * 35940001 * * 36000001 HMDRFOUN MVC PAR1+1(3),0(GR7) MOVE SYMBOLIC ADDRESS TO PAR1 36060001 MVI PAR1,X'80' INDICATE NO STATUS CHANGE 36120001 L LR,ZTXTAB CALL ZTXTAB 36180001 BALR RR,LR TO CONVERT TO ABSOLUTE 36240001 MVC XPRGAATE+1(3),PAR1+1 STORE ABSOLUTE ADDRESS 36300001 SPACE 36360001 TM XPRGCODE,XPRGTOLK TEST IF ENTRY TO BE LOCKED 36420001 BZ HMDREXIT EXIT IF NOT 36480001 TM XPRGCODE,XPRGLOCK TEST IF A CURRENT LOCKED ENTRY 36540001 BO HMDRUNLK BRANCH IF SO 36600001 CP XTHRLCNT,=P'4' TEST IF FOUR LOCKED ENTRIES ALREADY 36660001 BNE HMDRULCT BRANCH IF NOT 36720001 LA PR1,4 LOAD ERROR NUMBER 36780001 B KAHERR CALL ERROR HANDLER 36840001 SPACE 36900001 HMDRULCT AP XTHRLCNT,=P'1' ADD 1 TO LOCK COUNT 36960001 SPACE 37080001 HMDRMNBB MVC PAR1+1(3),0(GR7) MOVE S.A. TO PAR1 37140001 MVI PAR1,X'00' CLEAR H.O. BYTE 37200001 MVI PAR2+3,X'04' INDICATE BUSY 37260001 L LR,ZALTER CALL ZALTER 37320001 BALR RR,LR TO MARK BLOCK BUSY 37380001 AP XBLELCNT,=P'1' ADD 1 TO BEL LOCK COUNT 37440001 OI XPRGCODE,XPRGLOCK INDICATE LOCKED ENTRY 37470001 SPACE 37500001 HMDRUDRP MVC XPRGSATE,0(GR7) MOVE S.A. TO D.R. POINTER 37560001 ST GR8,XPRGABLE STORE ADDRESS OF BLE 37620001 B HMDREXIT EXIT 37680001 SPACE 37740001 HMDRUNLK L GR4,XPRGABLE LOAD ADDRESS OF CURRENT BLE 37800001 CLC 0(1,GR7),XBLEBLKN-XBLE(GR4) TEST IF SAME BLOCK NO. AS SA 37860001 BE HMDRUDRP BRANCH IF SO 37920001 SPACE 37980001 LR PR1,GR6 LOAD ADDRESS OF PRG FOR KAHULK 38040001 BAL RR,KAHULK CALL KAHULK TO UNLOCK CURRENT ENTRY 38100001 B HMDRULCT BRANCH TO MARK NEW BLOCK BUSY 38160001 SPACE 38220001 * 38280001 HMDREXIT L PR0,XPRGAATE LOAD RETURN PARAMETER REGISTER 38340001 NI XPRGCODE,X'FF'-XPRGTOLK TURN OF 'TO BE LOCKED' BIT 38400001 IEMKLVE NORC 38460001 DROP GR6,GR8 38520001 EJECT 38580001 *********************************************************************** 38640001 * * 38700001 * ROUTINE KAHUDR. (HANDLES ULDR OPERATION). * 38760001 * * 38820001 * THIS ROUTINE CALLS KAHULK TO UNLOCK THE DIRECT REFERENCE POINTER. * 38880001 * IF THE ENTRY IS NOT LOCKED THE ROUTINE EXITS. * 38940001 * * 39000001 * REGISTER USAGE: * 39060001 * * 39120001 * GR9 - ADDRESS OF TCA * 39180001 * * 39240001 * PARAMETERS PASSED: * 39300001 * * 39360001 * ON ENTRY - PR1 - ADDRESS OF TCA * 39420001 * * 39480001 * ON EXIT - NONE * 39540001 * * 39600001 * RETURN CODE: NONE * 39660001 * * 39720001 * FAILS: NONE * 39780001 * * 39840001 *********************************************************************** 39900001 SPACE 2 39960001 KAHUDR IEMKENT TYPE=1 40020001 * 40080001 LR GR9,PR1 BASE XTCA DSECT 40140001 SPACE 40200001 LA PR1,XTCAPTRS LOAD DR PRG ADDRESS FOR KAHULK 40260001 BAL RR,KAHULK CALL KAHULK TO UNLOCK ENTRY 40320001 SPACE 40380001 * 40440001 HUDREXIT IEMKLVE NORC 40500001 EJECT 40560001 *********************************************************************** 40620001 * * 40680001 * ROUTINE KAHSET. (HANDLES SET/SETZ OPERATIONS). * 40740001 * * 40800001 * THIS ROUTINE POSITIONS A SCAN TO THE START OR END OF A TABLE * 40860001 * FOR SETZ OR TO AN ENTRY IDENTIFIED BY A SYMBOLIC ADDRESS * 40920001 * SUPPLIED BY THE CALLER FOR SET. IF A CURRENT LOCKED ENTRY EXISTS * 40980001 * IT IS UNLOCKED. FOR SET THE SUPPLIED SYMBOLIC ADDRESS IS CHECKED * 41040001 * TO ENSURE THAT IT REFERS TO A BLOCK WITHIN THE TABLE. THE POINTER * 41100001 * IS IDENTIFIED BY THE XTCACPTR FIELD. THE TYPE OF OPERATION * 41160001 * IS DETERMINED FROM THE CONTENTS OF PR0. THE * 41220001 * OPTION FOR SETZ IS DETERMINED FROM THE SETTING OF A BIT IN THE * 41280001 * XPRGCODE FIELD OF THE POINTER REGION. THIS BIT IS SET BY THE * 41340001 * CALLER. * 41400001 * * 41460001 * REGISTER USAGE: * 41520001 * * 41580001 * GR6 - ADDRESS OF POINTER REGION * 41640001 * GR7 - ADDRESS OF SYMBOLIC ADDRESS * 41700001 * GR8 - ADDRESS OF BLOCK LIST ENTRY * 41760001 * GR9 - ADDRESS OF TCA * 41820001 * * 41880001 * PARAMETERS PASSED: * 41940001 * * 42000001 * ON ENTRY - PR0 - ADDRESS OF SYMBOLIC ADDRESS IF SET * 42060001 * PR1 - ADDRESS OF TCA * 42120001 * * 42180001 * ON EXIT - NONE * 42240001 * * 42300001 * RETURN CODE: NONE * 42360001 * * 42420001 * FAILS: THE ROUTINE WILL FAIL IF THE TABLE IS NULL. FOR SET A * 42480001 * FAIL WILL OCCUR IF THE SUPPLIED SYMBOLIC ADDRESS DOES * 42540001 * NOT REFER TO A BLOCK WITHIN THE TABLE. * 42600001 * * 42660001 *********************************************************************** 42720001 SPACE 2 42780001 KAHSET IEMKENT TYPE=1 42840001 * 42900001 USING XPRG,GR6 42960001 USING XBLE,GR8 43020001 * 43080001 LR GR9,PR1 BASE XTCA DSECT 43140001 LR GR7,PR0 SAVE S.A. ADDRESS 43200001 LH GR6,0(0,RR) LOAD DISP. TO PRG 43300001 LA GR6,XTCAPTRS(GR6) LOAD ADDRESS OF PRG 43400001 SPACE 43680001 HSETNNUL NI XPRGCODE,X'FF'-(XPRGSETD+XPRGSETZ) CLEAR SET/SETZ BITS 43740001 SPACE 43800001 LTR GR7,GR7 TEST IF SETZ 43860001 BZ HSETSETZ BRANCH IF SO 43920001 * * 43980001 * THE FOLLOWING ROUTINE SCANS THE BLOCK LIST TO FIND AN ENTRY WITH * 44040001 * THE SAME BLOCK NUMBER AS THAT IN THE SUPPLIED SYMBOLIC ADDRESS. * 44100001 * IF NO SU