./ ADD SSI=01053530,NAME=IEX00,SOURCE=0 TITLE 'IEX00 - OS/360 ALGOL COMPILER DIRECTORY' 00020000 * 00040000 *STATUS.. CHANGE LEVEL 0. 00060000 * 00080000 *FUNCTION/OPERATION.. 00100000 * THIS MODULE HAS TWO FUNCTIONS.. 00120000 * 1. IT PROVIDES THE INITIAL ENTRY POINT TO AND FINAL EXIT POINT 00140000 * FROM THE ALGOL COMPILER. 00160000 * 2. IT CONTAINS ROUTINES AND DATA WHICH MAY BE NEEDED BY SOME OR ALL 00180000 * OF THE FOLLOWING COMPILER PHASES. 00200000 * 00220000 *ENTRY POINTS.. 00240000 * IEX00000 - INITIAL ENTRY POINT. MAY BE ENTERED BY AN 00260000 * '// EXEC' STATEMENT OR BY ANY ONE OF THE MACROS LINK, CALL, XCTL 00280000 * OR ATTACH. 00300000 * IEX00PIC - PROGRAM INTERRUPT ROUTINE 00320000 * IEX00ED1 - END OF DATA ROUTINE FOR SYSUT1 00340000 * EODAD2 - END OF DATA ROUTINE FOR SYSUT2 00360000 * EODAD3 - END OF DATA ROUTINE FOR SYSUT3 00380000 * IEX00EDI - END OF DATA ROUTINE FOR SYSIN 00400000 * (THE FOUR END OF DATA ROUTINES ABOVE ARE DUMMIES WHICH ONLY 00420000 * TRANSFER CONTROL TO THE ACTUAL ROUTINES, THE ADDRESSES OF WHICH 00440000 * HAVE BEEN STORED IN THE COMMON WORK AREA). 00460000 * IEX00SYN - SYNCHRONOUS ERROR ROUTINE FOR ALL DATA SETS 00480000 * EXCEPT SYSPRINT. 00500000 * SYNPR - SYNCHRONOUS ERROR ROUTINE FOR SYSPRINT. 00520000 * IEX00PRI - A COMMON SUBROUTINE FOR WRITING OUTPUT TO SYSPRINT. 00540000 * 00560000 *INPUT.. N/A 00580000 * 00600000 *OUTPUT.. 00620000 * THE SUBROUTINE PRINT EXECUTES ALL OUTPUT OPERATIONS ON SYSPRINT. 00640000 * THE FINAL DESTINATION IS A PRINTER, ALTHOUGH A TAPE OR DIRECT 00660000 * ACCESS DEVICE MAY BE USED AS INTERMEDIATE MEDIUM. THE FORMAT IS 00680000 * FIXED BLOCKED WITH RECORD LENGTH 91 BYTES. THE MACHINE CODE CONTROL 00700000 * CHARACTERS FOR THE PRINTER ARE USED. 00720000 * 00740000 *EXTERNAL ROUTINES.. 00760000 * IEX00001 - THE COMMON WORK AREA. THIS IS NOT AN EXECUTABLE 00780000 * ROUTINE BUT RATHER A COLLECTION OF TABLES, DATA AND WORK AREAS 00800000 * WHICH ARE NEEDED BY SOME OR ALL OF THE COMPILER PHASES, THUS 00820000 * SUPPLEMENTING THE FUNCTION OF THIS MODULE. IT IS ASSEMBLED 00840000 * SEPARATELY AND LINKAGE EDITED WITH THIS MODULE. ITS CONTENTS AND 00860000 * FORMAT CAN BE FOUND IN THE DUMMY CONTROL SECTION WORKAREA. 00880000 * IEX10000 - THE COMPILER INITIALIZATION PHASE. THE WHOLE CHAIN 00900000 * OF COMPILER PHASES STARTING WITH IEX10000 AND ENDING WITH IEX51002 00920000 * CAN BE REGARDED AS A SUBROUTINE TO THIS MODULE. IT IS ENTERED BY 00940000 * A MACRO 'LINK EP=IEX10000'. ON ENTRY, REG 0 CONTAINS THE ADDRESS 00960000 * OF THE COMMON WORK AREA. CONTROL IS FINALLY RETURNED TO THIS 00980000 * MODULE FROM IEX51002 BY A RETURN MACRO WITH THE COMPLETION CODE 01000000 * IN REG. 15. 01020000 * 01040000 *EXITS - NORMAL: 01060000 * THE FINAL EXIT FROM THE COMPILER IS BY A RETURN MACRO TO THE 01080000 * INVOKING PROGRAM. REG. 15 THEN CONTAINS A RETURN CODE TO 01100000 * INDICATE WHETHER THE COMPILATION WAS SUCCESSFUL OR NOT. 01120000 * 01140000 * EXIT FROM THE SUBROUTINE PRINT IS BY A RETURN MACRO. REG. 1 THEN 01160000 * CONTAINS THE ADDRESS OF A BUFFER AREA INTO WHICH THE NEXT OUTPUT 01180000 * LINE CAN BE MOVED. 01200000 * 01220000 *EXITS - ERRORS: 01240000 * EXIT FROM THE COMMON ERROR ROUTINES PIROUT, SYNAD AND SYNPR IS 01260000 * NORMALLY TO AN ERROR ROUTINE WHICH IS PRIVATE TO EACH COMPILER 01280000 * PHASE. THE ADDRESS OF THIS ROUTINE HAS BEEN STORED IN ERET IN THE 01300000 * COMMON WORK AREA. HOWEVER, IF THE PIROUT ROUTINE IS ENTERED FOR 01320000 * THE SECOND TIME, EXIT IS MADE TO THE ROUTINE GOTOEND IN THIS MODULE 01340000 * WHICH IN ITS TURN XCTL'S TO THE TERMINATING PHASE IEX51002. 01360000 * 01380000 * EXIT FROM THE ROUTINES SYNAD AND SYNPR IS BY LOADING ERET INTO REG. 01400000 * 15 AND BRANCHING. 01420000 * 01440000 * EXIT FROM THE ROUTINE PIROUT IS BY MOVING THE RETURN ADDRESS INTO 01460000 * THE OLD PSW AND EXECUTING A RETURN MACRO. 01480000 * 01500000 *TABLES/WORK AREAS.. 01520000 * SAVE - THE SAVE AREA IN STANDARD FORMAT. 01540000 * PICA - THE PROGRAM INTERRUPT CONTROL AREA. 01560000 * DCBPRINT - DCB FOR SYSPRINT. 01580000 * DCBLIN - DCB FOR SYSLIN. 01600000 * DCBPCH - DCB FOR SYSPUNCH. 01620000 * DCBUT2 - DCB FOR SYSUT2. 01640000 * DCBUT3 - DCB FOR SYSUT3. 01660000 * WORKAREA - THE COMMON WORKAREA IN THE EXTERNAL CONTROL SECTION 01680000 * IEX0001. 01700000 * 01720000 *ATTRIBUTES.. NOT SERIALLY REUSABLE. 01740000 * 01760000 *NOTES.. 01780000 * THIS MODULE IS TO BE LINKAGE EDITED WITH THE COMMON WORK AREA 01800000 * (MODULE IEX00001). THE RESULTING LOAD MODULE FORMS THE RESIDENT 01820000 * PART (IEX00) OF THE ALGOL COMPILER. 01840000 * 01860000 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL REPRESEN- 01880000 * TATION OF THE EXTERNAL CHARACTER SET WHICH IS EQUIVALENT TO THE 01900000 * ONE USED AT ASSEMBLY TIME. 01920000 EJECT 01940000 IEX00000 START 0 01960000 SPACE 01980000 * REGISTER ASSIGNMENTS 02000000 SPACE 02020000 R0 EQU 0 02040000 R1 EQU 1 02060000 R2 EQU 2 02080000 R3 EQU 3 02100000 RA EQU 4 02120000 RB EQU 5 02140000 R13 EQU 13 02160000 R15 EQU 15 02180000 SPACE 02200000 NXT EQU 6 ADDR OF CURRENT ENTRY IN ERROR POOL 02220000 IDX EQU 7 USED AS INDEX 02240000 SPACE 02260000 * BIT PATTERNS 02280000 SPACE 02300000 ONSW EQU X'F0' ON SWITCH IN BRANCH INSTR 02320000 OFFSW EQU X'0F' OFF SWITCH IN BRANCH INSTR 02340000 SPACE 02360000 * ENTRY POINTS 02380000 SPACE 02400000 ENTRY IEX00LIN,IEX00PCH,IEX00PRT,IEX00UT2,IEX00UT3 02420000 ENTRY IEX00SYN,IEX00ED1,IEX00EDI,IEX00PIC,IEX00PRI 02440000 EJECT 02460000 SPACE 02480000 * ENTRY POINT OF THE COMPILER 02500000 SPACE 02520000 * UPON ENTRY, REG 15 CONTAINS THE ADDR OF THE ENTRY POINT, REG 14 CON- 02540000 * TAINS THE RETURN ADDR AND REG 1 CONTAINS THE ADDR OF THE PARAM LIST. 02560000 SPACE 02580000 EXTRN IEX00001 02600000 SPACE 02620000 USING *,15 02640000 SAVE (14,12) 02660000 ST R13,SAVE+4 02680000 MVC 8(4,R13),=A(SAVE) 02700000 L R13,=A(SAVE) 02720000 L R0,=A(IEX00001) ADDR OF COMMON WORKAREA 02740000 LINK EP=IEX10 LINK TO PHASE 10 02760000 SPACE 02780000 * TWO PARAMTERS ARE TRANSMITTED TO PHASE 10, REG 0 CONTAINS THE ADDR 02800000 * OF THE COMMON WORKAREA, REG 1 CONTAINS THE ADDR OF THE PARAMETER LIST 02820000 * OF THE INVOKER 02840000 SPACE 2 02860000 * FINAL EXIT OF THE COMPILER 02880000 SPACE 02900000 * PHASE 51 GENERATED THE RETURN CODE IN REG 15, THE RETURN CODE IS 02920000 * TRANSMITTED BACK TO THE INVOKER 02940000 BALR 14,0 0219 02950015 SPACE 02960000 USING *,14 02980000 L R13,SAVE+4 03000000 RETURN (14,12),RC=(15) 03020000 SPACE 2 03040000 * SAVEAREA FOR THIS LEVEL OF CONTROL 03060000 SPACE 03080000 SAVE DC 18F'0' 03100000 SPACE 2 03120000 LTORG 03140000 EJECT 03160000 * THE FOLLOWING SECTION CONTAINS THE PROG. INTERRUPT CONTROL AREA,THE 03180000 * PROG CHECK AND I/O ERROR ROUTINES, THE PRINT ROUTINE AND THE DCBS FOR 03200000 * SYSLIN, SYSPUNCH, SYSPRINT, SYSUT2 AND SYSUT3 03220000 SPACE 2 03240000 USING WORKAREA,R13 03260000 SPACE 2 03280000 * PROGRAM INTERRUPT CONTROL AREA 03300000 SPACE 03320000 PICA SPIE PIROUT,((1,15)),MF=L 03340000 IEX00PIC EQU PICA 03360000 SPACE 2 03380000 * PROGRAM INTERRUPT ROUTINE 03400000 SPACE 03420000 USING *,R15 03440000 PIROUT TM HCOMPMOD+1,TERM IF PROG INTERRUPT IN TERMINATING PHA 03460000 BO TERMERR SE 03480000 TM HCOMPMOD+1,ERR 03500000 BO ERRERR IF PROG INTERRUPT IN ERROR ROUT 03520000 STM RA,IDX,PISAVE SAVE REGISTERS 03540000 L NXT,NEXTERR ADDR OF NEXT BYTE IN ERROR POOL 03560000 MVC 0(2,NXT),=AL1(20,209) PATTERN FOR MSG 209 03580000 MVC 2(2,NXT),SEMCNT SEMICOLON COUNTER 03600000 TM HCOMPMOD+2,NOSC 03620000 BZ *+8 03640000 OI 0(NXT),X'80' INDICATE SCNTR NOT VALID 03660000 SR IDX,IDX INITIALIZE INDEX 03680000 L RB,4(R1) FIRST HALF OF PSW 03700000 LOOP SR RA,RA 03720000 SLDL RA,4 GET HALF A BYTE OF OLD PSW 03740000 STC RA,4(IDX,NXT) AND STORE IT FOR CONVERSION 03760000 LA IDX,1(IDX) INCREASE INDEX 03780000 CH IDX,=H'8' PERFORM LOOP 03800000 BL LOOP EIGHT TIMES 03820000 L RB,8(0,R1) SECOND HALF OF PSW 03840000 LOOP2 SR RA,RA 03860000 SLDL RA,4 GET HALF A BYTE OF OLD PSW 03880000 STC RA,4(IDX,NXT) AND STORE IT FOR CONVERSION 03900000 LA IDX,1(IDX) INCREASE INDEX 03920000 CH IDX,=H'16' PERFORM LOOP 03940000 BL LOOP2 EIGHT TIMES 03960000 TR 4(16,NXT),=C'0123456789ABCDEF' TRANSLATE TO PRINTABLE HX 03980000 LA NXT,20(NXT) UPDATE POINTER 04000000 ST NXT,NEXTERR TO ERROR POOL 04020000 FIRSTERR OI HCOMPMOD+1,ERR SET ERROR ROUT SWITCH ON 04040000 LM RA,IDX,PISAVE RESTORE REGISTERS 04060000 TERMERR MVC 9(3,R1),ERET+1 ADDR OF ERR ROUT TO OLD PSW 04080000 OI HCOMPMOD,X'08' INDICATE TERMINATING ERROR 04100000 RETURN 04120000 PISAVE DC 4F'0' REGISTER SAVE AREA 04140000 SPACE 04160000 ERRERR MVC 9(3,R1),=AL3(GOTOEND) SET ADDR IN OLD PSW 04180000 RETURN 04200000 DROP R15 04220000 GOTOEND BALR R15,0 04240000 USING *,R15 04260000 XCTL EP=IEX51002 GO TO TERMINATING PHASE 04280000 DROP R15 04300000 SPACE 2 04320000 * ENTRY OF THE END OF DATA EXIT ROUTINES 04340000 SPACE 04360000 IEX00ED1 EQU * 04380000 EODAD1 L R15,EODUT1 SYSUT1 04400000 BR R15 04420000 EODAD2 L R15,EODUT2 SYSUT2 04440000 BR R15 04460000 EODAD3 L R15,EODUT3 SYSUT3 04480000 BR R15 04500000 IEX00EDI EQU * 04520000 EODADIN L R15,EODIN SYSIN 04540000 BR R15 04560000 SPACE 2 04580000 * SYNAD ROUTINE (ENTRY POINT FOR SYSPRINT) 04600000 SPACE 04620000 SYNPR OI HCOMPMOD+2,PRT SET SYSPRINT DOWN SWITCH ON 04640000 BALR R15,0 04660000 SPACE 2 04680000 * SYNAD ROUTINE (ENTRY POINT FOR ALL DATA SETS EXCEPT SYSPRINT) 04700000 SPACE 04720000 USING *,R15 04740000 IEX00SYN EQU * 04760000 SYNAD LR R2,R1 GET DCB ADDRESS 04780000 LA R2,0(R2) REMOVE HIGH-ORDER BYTE 04800000 CLOSE ((R2)) 04820000 DROP R15 04840000 BALR R15,0 04860000 USING *,R15 04880000 L R3,NEXTERR STORE ERROR PATTERN 04900000 MVC 0(2,R3),PTTRN210 IN ERROR POOL 04920000 MVC 2(2,R3),SEMCNT 04940000 USING IHADCB,R2 04960000 MVC 4(8,R3),DCBDDNAM 04980000 DROP R2 05000000 LA R3,12(R3) UPDATE ERROR POINTER 05020000 ST R3,NEXTERR 05040000 OI HCOMPMOD,X'08' INDICATE TERMINATING ERROR 05060000 TM HCOMPMOD+2,PRT 05080000 BZ *+8 BRANCH IF NOT SYSPRINT 05100000 LM LINKP,RETURN,SAVEP RESTORE REGS. F*OM PRINT ROUT. 05120000 L R15,ERET EXIT TO ERROR ROUTINE 05140000 BR R15 IN CURRENT PHASE 05160000 PTTRN210 DC AL1(12),AL1(210) 05180000 DROP R15 05200000 EJECT 05220000 PRINT EQU * 05240000 IEX00PRI EQU * 05260000 SPACE 05280000 * THIS ROUTINE PRINTS ONE LINE ON SYSPRINT. IT ALSO TAKES CARE 05300000 * OF LINE COUNTING, PAGE COUNTING AND PRINTING OF HEADING LINES AT 05320000 * THE TOP AF EACH NEW PAGE. 05340000 SPACE 05360000 * CALLING SEQUENCE 05380000 SPACE 05400000 * L ENTRY,PRTRTADD ENTRY ADDRESS IN CWA 05420000 * BALR RETURN,ENTRY 05440000 * --- ON RETURN, GR1 CONTAINS ADDRESS OF PRINT BUFF. 05460000 SPACE 05480000 * GENERAL REGISTERS 05500000 GR1 EQU 1 05520000 LINKP EQU 4 05540000 BASEP EQU 5 05560000 LCT EQU 6 LINE COUNTER 05580000 PCT EQU 7 PAGE CPUNTER 05600000 LINC EQU 8 LINE COUNTER INCREMENT FOR HEADLINES 05620000 HDNG EQU 9 ADDRESS OF CURRENT HEADLINE (MUST BE ODD REG) 05640000 DCB EQU 12 SYSPRINT DCB ADDRESS 05660000 RETURN EQU 14 05680000 ENTRY EQU 15 05700000 SPACE 05720000 NOPRINT EQU X'FF' IF IN FIRST PRINT POSITION-SKIP THIS HEADLINE 05740000 SPACE1 EQU X'09' CTL CHAR FOR SINGLE SPACE 05760000 SKIP EQU X'89' CTL CHAR FOR PAGE SKIP 05780000 SPACE 05800000 USING PRINT,ENTRY 05820000 STM LINKP,RETURN,SAVEP 05840000 DROP ENTRY 05860000 LR BASEP,ENTRY 05880000 USING PRINT,BASEP 05900000 L DCB,PRINTADD ADDR OF SYSPRINT DCB 05920000 LH LCT,LINCNT TEST LINE COUNTER 05940000 PRINTSW EQU *+1 SWITCH FOR NEW PAGE 05960000 NOP PRINTA 05980000 TM LINCNTA+1,X'FF' 06000000 BNZ PRINTG IF FIRST PAGE 06020000 PRINTF CH LCT,MAXLINES 06040000 BL PRINTD IF NOT END OF PAGE 06060000 L GR1,PREVLIN ADDRESS OF PREV. LINE 06080000 MVI 0(GR1),SKIP SKIP AFTER PREV. LINE 06100000 SR LCT,LCT RESET LINE COUNTER 06120000 PRINTG OI PRINTSW,ONSW TO PRINT HEADING NEXT TIME 06140000 PRINTD EQU * 06160000 BAL LINKP,PRINTP 06180000 TM LINCNT,X'7F' 06200000 BNZ PRINTH IF FORCED NEW PAGE 06220000 PRINTE EQU * 06240000 MVI 0(GR1),SPACE1 CONTROL CHARACTER 06260000 MVI 1(GR1),C' ' 06280000 MVC 2(89,GR1),1(GR1) BLANK PRINT AREA 06300000 STH LCT,LINCNT 06320000 LA GR1,1(0,GR1) RETURN ADDRESS OF PRINT AREA TO USER 06340000 LM LINKP,RETURN,SAVEP 06360000 BR RETURN 06380000 SPACE 06400000 PRINTA EQU * PRINT HEADLINES AT TOP OF NEW PAGE 06420000 SPACE 06440000 L GR1,PREVLIN ADDRESS OF PREVIOUS LINE 06460000 MVC SAVELINE(91),0(GR1) SAVE TEXT LINE 06480000 PRINTH EQU * 06500000 NI PRINTSW,OFFSW 06520000 LH LCT,LINCNTA RESET LINE COUNTER 06540000 MVI LINCNTA+1,0 06560000 L PCT,PAGECNT 06580000 LA PCT,1(0,PCT) STEP PAGE COUNTER 06600000 ST PCT,PAGECNT 06620000 CVD PCT,DBWORD CONVERT PAGE NUMBER 06640000 OI DBWORD+7,X'0F' 06660000 UNPK PAGEHEAD+89(3),DBWORD+6(2) INSERT PAGE CT INTO HEADLINE 06680000 LA HDNG,PAGEHEAD SET UP COUNTER FOR HEADLINES 06700000 LA HDNG+1,HDLG 06720000 LA HDNG+2,PAGEHEND 06740000 PRINTC CLI 2(HDNG),NOPRINT 06760000 BE PRINTB BR IF HEADING IS TO BE SKIPPED 06780000 MVC 0(HDLG,GR1),1(HDNG) MOVE HEADING TO PRINT BUFFER 06800000 BAL LINKP,PRINTP 06820000 PRINTB BXLE HDNG,HDNG+1,PRINTC 06840000 TM LINCNT,X'7F' 06860000 BNZ PRINTE IF FORCED NEW PAGE 06880000 MVC 0(91,GR1),SAVELINE RESTORE TEXT LINE 06900000 B PRINTD RETURN TO REGULAR PRINTING 06920000 SPACE 06940000 PRINTP EQU * SUBROUTINE FOR PRINTING A LINE 06960000 SPACE 06980000 L GR1,PREVLIN ADDRESS OF PREVIOUS LINE 07000000 SR LINC,LINC 07020000 IC LINC,0(GR1) EXTRACT NUMBER OF LINES 07040000 SLL LINC,25 FROM CONTROL CHARACTER 07060000 SRL LINC,28 07080000 AR LCT,LINC STEP LINE COUNTER 07100000 PUT (DCB) 07120000 ST GR1,PREVLIN 07140000 BR LINKP 07160000 SPACE 07180000 LINCNTA DC H'2' INITIAL LINECOUNT (SET TO ZERO 07200000 * AFTER THE FIRST PAGE) 07220000 PREVLIN DC A(*) ADDR. OF PREV. LINE CTL CHAR 07240000 SAVEP DS 11F SAVE REG LINKP TO RETURN 07260000 DBWORD DS 1D USED AT BINARY-DECIMAL CONVERSION 07280000 SAVELINE DS CL91 TEMP. STORAGE FOR TEXT LINE 07300000 EJECT 07320000 LTORG 07340000 EJECT 07360000 * DATA CONTROL BLOCKS 07380000 SPACE 4 07400000 DCBPRINT DCB DDNAME=SYSPRINT, X07420000 DSORG=PS, 207440000 MACRF=(PL), X07460000 RECFM=FBM, X07480000 LRECL=91, 507500000 BFTEK=S, X07520000 SYNAD=SYNPR 07540000 SPACE 4 07560000 DCBLIN DCB DDNAME=SYSLIN, 107580000 DSORG=PS, 207600000 MACRF=(PL), X07620000 RECFM=FB, 407640000 LRECL=80, 507660000 BFTEK=S, X07680000 SYNAD=SYNAD 07700000 SPACE 4 07720000 DCBPCH DCB DDNAME=SYSPUNCH, 107740000 DSORG=PS, 207760000 MACRF=(PL), X07780000 RECFM=FB, 407800000 LRECL=80, 507820000 BFTEK=S, X07840000 SYNAD=SYNAD 07860000 SPACE 4 07880000 DCBUT2 DCB DDNAME=SYSUT2, 107900000 DSORG=PS, 207920000 MACRF=(R,W), 307940000 RECFM=F, X07960000 SYNAD=SYNAD, X07980000 EODAD=EODAD2 08000000 SPACE 4 08020000 DCBUT3 DCB DDNAME=SYSUT3, 108040000 DSORG=PS, 208060000 MACRF=(RP,WP), X08080000 BLKSIZE=2000, X08100000 RECFM=U, X08120000 SYNAD=SYNAD, 808140000 EODAD=EODAD3 08160000 SPACE 08180000 IEX00PRT EQU DCBPRINT 08200000 IEX00LIN EQU DCBLIN 08220000 IEX00PCH EQU DCBPCH 08240000 IEX00UT2 EQU DCBUT2 08260000 IEX00UT3 EQU DCBUT3 08280000 EJECT 08300000 SPACE 08320000 WORKAREA DSECT 08340000 COPY WORKAREA 08360000 EJECT 08380000 * DUMMY CONTROL SECTION TO PROVIDE ADRESSABILITY OF DCB 08400000 SPACE 08420000 DCBD DSORG=(PS) 08440000 END IEX00000 08460000 ./ ADD SSI=00015216,NAME=IEX10,SOURCE=0 TITLE 'IEX10 - OS/360 ALGOL COMPILER INITIALIZATION PHASE' 00020000 *STATUS: CHANGE LEVEL 0. 00040000 * 00060000 *FUNCTION/OPERATION: 00080000 * THIS MODULE PERFORMS THE FOLLOWING INITIALIZATION ACTIONS: 00100000 * 1. SAVE THE REGISTERS AND ESTABLISH THE LOWER PART OF THE COMMON 00120000 * WORKAREA AS THE NEW SAVE AREA TO BE USED THROUGHOUT THE COMPILATION 00140000 * 2. EXECUTE A SPIE MACRO. 00160000 * 3. SCAN THE OPTION PARAMETER FIELD PROVIDED BY THE USER AND SET 00180000 * THE SWITCHES IN HCOMPMOD ACCORDINGLY. 00200000 * 4. IF PROVIDED BY THE USER, INSERT NEW DD NAMES INTO THE DCB'S AND 00220000 * STORE THE INITIAL PAGECOUNT IN THE COMMON WORKAREA. 00240000 * 5. ACCORDING TO THE VALUE OF THE SIZE OPTION PARAMETER, SELECT 00260000 * A TABLE OF SIZES FOR CERTAIN STORAGE-SIZE DEPENDENT STORAGE AREAS 00280000 * AND MOVE THE TABLE TO THE COMMON WORKAREA. 00300000 * 6. OBTAIN STORAGE FOR THE ERROR POOL AND MOVE ANY ERROR PATTERNS 00320000 * ALREADY STORED FROM THE PRELIMINARY ERROR POOL INTO THE NEW POOL. 00340000 * 7. COMPLETE AND OPEN THE DCB'S FOR ALL DATA SETS TO BE USED. 00360000 * 8. OBTAIN THE CALENDAR DATE BY MEANS OF A TIME MACRO AND STORE 00380000 * IT IN EDITED FORM IN A HEADLINE, WHICH IS PRINTED AT THE TOP OF THE 00400000 * FIRST PAGE. 00420000 * 9. TRANSFER CONTROL TO THE SCANI/II PHASE (IEX11). 00440000 * 00460000 * IF ERRORS ARE DETECTED IN THE STEPS DESCRIBED ABOVE (SUCH AS 00480000 * INVALID OPTION PARAMETERS OR INCORRECT DD CARDS), SOME OF THE STEPS 00500000 * MAY BE BYPASSED, AND AN ERROR EXIT MAY BE TAKEN. 00520000 * 00540000 *ENTRY POINTS: 00560000 * IEX10000 - THE ONLY ENTRY POINT TO THIS MODULE. CONTROL IS 00580000 * TRANSFERRED HERE FROM IEX00 BY THE MACRO 'LINK EP=IEX10'. REG. 0 00600000 * THEN CONTAINS THE ADDRESS OF THE COMMON WORKAREA AND REG. 1 THE 00620000 * ADDRESS OF THE PARAMETER LIST PROVIDED BY THE USER. 00640000 * 00660000 *INPUT: N/A. 00680000 * 00700000 *OUTPUT: THE TEXT STORED AT FIRSTLIN IS OUTPUT TO SYSPRINT AS A 00720000 * 91-CHARACTER RECORD WITH MACHINE CONTROL CHARACTER. 00740000 * 00760000 *EXTERNAL ROUTINES: N/A. 00780000 * 00800000 * IF NO TERMINATING ERRORS ARE FOUND, CONTROL IS TRANSFERRED TO 00820000 * THE SCANI/II PHASE BY MEANS OF THE MACRO 'XCTL EP=IEX11'. 00840000 * 00860000 *EXITS - ERRORS: 00880000 * IF A PROGRAM CHECK OR UNRECOVERABLE I/O ERROR OCCURS DURING ONE 00900000 * OF THE INITIALIZATION STEPS, CONTROL IS TRANSFERRED (VIA AN ERROR 00920000 * ROUTINE IN IEX00) TO THE ROUTINE GOTOTERM IN THIS MODULE. FROM 00940000 * THERE AN EXIT IS MADE TO THE TERMINATING PHASE BY MEANS OF THE 00960000 * MACRO 'XCTL EP=IEX51002'. 00980000 * 01000000 * IF ANY OTHER TERMINATING ERROR IS DETECTED, CONTROL IS TRANSFERRED 01020000 * TO THE ROUTINE GOTOEDIT IN THIS MODULE. FROM THERE AN EXIT IS 01040000 * MADE TO THE ERROR EDITING MODULE BY MEANS OF THE MACRO 01060000 * 'XCTL EP=IEX21000'. 01080000 * 01100000 *TABLES/WORK AREAS: 01120000 * ARTAB - A TABLE OF SIZES OF WORK AREAS AND BUFFERS WHICH DEPEND 01140000 * ON THE STORAGE SIZE. 01160000 * STARTING AT PTRN200 - ERROR PATTERNS FOR ALL ERRORS WHICH MAY BE 01180000 * DETECTED IN THIS MODULE. 01200000 * FIRSTLIN - THE FIRST OUTPUT LINE TO BE PRINTED. CONTAINS PROGRAM 01220000 * IDENTIFICATION AND LEVEL AND THE DATE OF THE RUN. 01240000 * JANUARY - A TABLE OF THE MONTHS OF THE YEAR. USED WHEN EDITING 01260000 * THE DATE FOR FIRSTLIN. 01280000 * PARMLIST - A TABLE USED FOR DECODING THE OPTION PARAMETERS. 01300000 * 01320000 *ATTRIBUTES: NOT REUSABLE. 01340000 * 01360000 *NOTES: 01380000 * THIS MODULE IS ONLY INTENDED TO BE USED IN CONNECTION WITH THE 01400000 * OTHER MODULES COMPRISING THE ALGOL COMPILER. 01420000 * 01440000 * THE OPERATION OF THIS MODULE DEPENDS UPON AN INTERNAL REPRESEN- 01460000 * TATION OF THE EXTERNAL CHARACTER SET WHICH IS EQUIVALENT TO THE 01480000 * ONE USED AT ASSEMBLY TIME. 01500000 EJECT 01520000 IEX10000 START 0 01540000 SPACE 01560000 * REGISTER ASSIGNMENTS 01580000 SPACE 01600000 RA EQU 4 01620000 RB EQU 5 01640000 RC EQU 6 01660000 RD EQU 7 01680000 RE EQU 8 01700000 RF EQU 9 01720000 RG EQU 10 01740000 RH EQU 11 01760000 SPACE 01780000 R0 EQU 0 01800000 R1 EQU 1 01820000 R2 EQU 2 01840000 R3 EQU 3 01860000 R4 EQU 4 01880000 R5 EQU 5 01900000 R6 EQU 6 01920000 R7 EQU 7 01940000 R8 EQU 8 01960000 R9 EQU 9 01980000 R10 EQU 10 02000000 R11 EQU 11 02020000 R12 EQU 12 02040000 R13 EQU 13 02060000 R14 EQU 14 02080000 R15 EQU 15 02100000 SPACE 02120000 BASE EQU 2 BASE REGISTER 02140000 IDX EQU 7 INDEX USED BY EDITDATE ROUT. 02160000 SPACE 02180000 REGA EQU 4 RUNNING ADDR OF PARAMETER FIELD MINUS 2 02200000 REGB EQU 5 ADDR OF BYTE FOLLOWING LAST BYTE OF FIELD MINUS 2 02220000 REGC EQU 6 RUNNING ADDR OF PARAMETER LIST 02240000 REGD EQU 7 ADDR OF LAST ENTRY OF PARAMETER LIST 02260000 REGE EQU 8 LENGTH -1 OF PARAMETER 02280000 REGF EQU 9 CURRENT FIELD IN ERROR POOL 02300000 REGG EQU 10 NEXT FIELD IN ERROR POOL 02320000 REGH EQU 11 BYTE COUNT OF PARAMETER IN ERROR 02340000 EJECT 02360000 SPACE 2 02380000 SAVE (14,12) 02400000 BALR BASE,0 GET BASE 02420000 USING *,BASE 02440000 ST R0,8(R13) ADDR OF LOWER LEVEL SAVAREA 02460000 LR R12,R13 02480000 LR R13,R0 02500000 ST R12,4(R13) ADDR OF HIGHER LEVEL SAVEAREA 02520000 USING WORKAREA,R13 02540000 SPACE 2 02560000 * EXECUTE THE SPIE MACRO 02580000 SPACE 02600000 L R3,PICAADD ADDR OF PICA OF COMPILER 02620000 SPIE MF=(E,(3)) 02640000 ST R1,OLDPICA STORE ADDR OF OLD PICA IN WORKAREA 02660000 SPACE 2 02680000 MVC ERET,=A(GOTOTERM) ERROR ROUT FOR NEXT PART OF PHASE 02700000 * INTERROGATE THE CONTROL PARAMETERS AND SET SWITCHES IN WORKAREA 02720000 SPACE 02740000 L R14,4(R13) 02760000 L R14,24(R14) 02780000 LTR R14,R14 02800000 BC 8,OPEN NO OPTIONS ARE SPECIFIED 02820000 SPACE 02840000 L REGA,0(0,14) ADDRESS OF PARMETERFIELD 02860000 LA REGA,0(0,REGA) RESET HIGH ORDER BYTE 02880000 LH REGB,0(REGA) FIELDLENGTH 02900000 LTR REGB,REGB TEST FIELDLENGTH 02920000 BZ DDNAMES NO CONTROL PARAMETERS SPECIFIED 02940000 SPACE 02960000 AR REGB,REGA END OF FIELD 02980000 LA REGD,LSTENTRY LAST ENTRY OF LIST 03000000 SR REGE,REGE ZERO REGISTER 03020000 FNDCOMMA CLI 2(REGA),C',' 03040000 BNE FNDPAR IF NOT COMMA 03060000 STEP1 LA REGA,1(REGA) STEP FIELD 03080000 COMP1 CR REGA,REGB 03100000 BL FNDCOMMA IF NOT END OF FIELD YET 03120000 TM HCOMPMOD+1,X'60' 03140000 BC 14,*+8 03160000 OI HCOMPMOD,X'80' 03180000 B DDNAMES END OF FIELD 03200000 USING LENGTH,REGC 03220000 COMPINST CLC 2(0,REGA),PARAM 03240000 FNDPAR CLC 2(5,REGA),=C'SIZE=' 03260000 BE FNDSIZE 03280000 LA REGC,PARMLIST 03300000 NXTPAR IC REGE,LENGTH 03320000 EX REGE,COMPINST 03340000 BNE NOTFOUND 03360000 LA REGG,1(REGA,REGE) ADDR OF BYTE FOLLOWING PARAMETER -2 03380000 CLI 2(REGG),C',' IS IT COMMA 03400000 BE SETBIT 03420000 CR REGG,REGB IS IT END OF PARAMETERFIELD 03440000 BL ERROR200 IF NO 03460000 SETBIT LR REGA,REGG 03480000 EX 0,INSTR 03500000 DROP REGC 03520000 B COMP1 03540000 NOTFOUND CR REGC,REGD 03560000 LA REGC,LENGTH-PARMLIST(REGC) STEP LIST ADDR 03580000 BL NXTPAR IF NOT END OF LIST YET 03600000 SPACE 03620000 ERROR200 L REGF,NEXTERR ADDR OF NEXT FREE BYTE IN ERRORPOOL 03640000 CLI 0(REGF),C'X' TEST IF THE PRELIMINARY ERROR 03660000 BE FULLPOOL POOL IS FILLED 03680000 LA REGG,16(REGF) 03700000 ST REGG,NEXTERR 03720000 MVC 0(16,REGF),PTRN200 PATTERN WITH BLANKS TO ERROR POOL 03740000 LA REGH,12(0) 03760000 MOVE MVC 4(1,REGF),2(REGA) 03780000 LA REGF,1(REGF) 03800000 MOVENOT LA REGA,1(REGA) 03820000 CLI 2(REGA),C',' 03840000 BE STEP1 IF END OF PARAMETER 03860000 CLR REGA,REGB 03880000 BNL DDNAMES IF END OF PARAMETER LIST 03900000 SH REGH,=H'1' 03920000 BP MOVE 03940000 B MOVENOT 03960000 SPACE 03980000 FNDSIZE LA REGG,5(REGA) ADDR OF FIRST DIGIT -2 04000000 SR REGH,REGH SET COUNT OF DIGITS TO ZERO 04020000 TSTDIGIT CLI 2(REGG),C'0' TEST IF 04040000 BL ERROR200 THE CHARACTER 04060000 CLI 2(REGG),C'9' IS A DIGIT 04080000 BH ERROR200 04100000 LA REGG,1(REGG) 04120000 CR REGG,REGB TEST IF END OF PARAMTER FIELD 04140000 BE PCKSIZE 04160000 CLI 2(REGG),C',' TEST IF DIGIT IS FOLLOWED BY A COMMA 04180000 BE PCKSIZE 04200000 LA REGH,1(REGH) ADD 1 TO DIGIT COUNT 04220000 CH REGH,=H'7' TEST IF TOO MANY DIGITS 04240000 BE ERROR200 04260000 B TSTDIGIT 04280000 PCKINSTR PACK FIELD1,7(0,REGA) 04300000 PCKSIZE EX REGH,PCKINSTR L2 IS IN TEGH 04320000 CVB REGC,FIELD1 04340000 LR REGA,REGG 04360000 C REGC,=F'45056' TEST IF SPECIFIED STORAGE SIZE 04380000 BL ERROR208 IS TOO SMALL 04400000 ST REGC,SIZE 04420000 B COMP1 04440000 SPACE 04460000 ERROR208 L REGF,NEXTERR 04480000 MVC 0(4,REGF),PTRN208 PATTERN FOR MSG 208 TO ERROR POOL 04500000 LA REGF,4(REGF) UPDATE POINTER TO NEXT 04520000 CLI 0(REGF),C'X' TEST IF THE PRELIMINARY ERROR 04540000 BE FULLPOOL POOL IS FILLED 04560000 ST REGF,NEXTERR FREE ENTRY 04580000 B COMP1 04600000 SPACE 04620000 FULLPOOL MVC 0(4,REGF),PTRN206 PATTERN FOR MESSAGE 206 04640000 LA REGF,4(REGF) UPDATE POINTER TO 04660000 ST REGF,NEXTERR NEXT FREE ENTRY 04680000 B DDNAMES NO PARAMERER TESTING ANY MORE 04700000 SPACE 2 04720000 * FIND THE DD NAMES 04740000 SPACE 04760000 DDNAMES TM 0(14),X'80' 04780000 BO OPEN IF NO DDNAMES AND HEADING INFO 04800000 L REGA,4(14) 04820000 LH REGB,0(REGA) 04840000 LTR REGB,REGB 04860000 BZ HEADINFO IF NO DDNAMES SPECIFIED 04880000 CL REGB,=F'80' MORE THAN TEN 04900000 BNH FNDDCB-4 DD NAMES 04920000 L REGB,=F'80' NOT ALLOWED 04940000 L REGF,NEXTERR 04960000 MVC 0(4,REGF),PTRN207 PATTERN TO ERROR POOL 04980000 LA REGF,4(REGF) UPDATE POINTER 05000000 ST REGF,NEXTERR TO ERROR POOL 05020000 LA REGC,LINADD 05040000 FNDDCB L REGD,0(REGC) 05060000 LTR REGD,REGD 05080000 BC 8,NXTDDNAM IF THIS DATASET DOES NOT EXIST 05100000 CLC 2(8,REGA),=XL8'00' 05120000 BE NXTDDNAM IF THIS DDNAME WAS NOT SPECIFIED 05140000 USING IHADCB,REGD 05160000 MVC DCBDDNAM,2(REGA) 05180000 DROP REGD 05200000 NXTDDNAM LA REGA,8(REGA) 05220000 LA REGC,4(REGC) 05240000 SH REGB,=H'8' 05260000 BP FNDDCB 05280000 SPACE 2 05300000 * HANDLE HEADING INFORMATION 05320000 SPACE 05340000 HEADINFO TM 4(14),X'80' 05360000 BO OPEN IF NO HEADING INFORMATION 05380000 L RA,8(14) POINTER TO HEADING INFO 05400000 ST RA,HDING STORE POINTER FOR USE IN LAST PHASE 05420000 MVC PAGECNT(4),2(RA) 05440000 SPACE 2 05460000 * OPEN THE SYSPRINT DCB IF THE SIZE PARAMETER WAS INCORRECT 05480000 SPACE 05500000 OPEN L R8,PRINTADD ADDR OF SYSPRINT DCB 05520000 USING IHADCB,R8 05540000 MVC DCBEXLST+1(3),=AL3(PRINTEX) ADDR OF EXLIST FOR PRINT DCB 05560000 DROP R8 05580000 SPACE 2 05600000 * FIND THE CORRECT AREA SIZE TABLE AND MOVE IT TO THE COMMON WORKAREA 05620000 SPACE 05640000 FNDARSIZ LA RA,ARTAB-(ARTAB1-ARTAB) ADDR OF TABLES - LNGTH OF 1 TAB 05660000 L RB,SIZE SIZE OF AVAILABLE STORAGE 05680000 FNDARTAB LA RA,ARTAB1-ARTAB(RA) STEP TO NEXT TABLE 05700000 C RB,0(RA) 05720000 BNL FNDARTAB 05740000 MVC INBLKS(ARTAB1-ARTAB-4),4(RA) MOVE TABLE TO COM WORKAREA 05760000 SPACE 2 05780000 * ACQUIRE THE ERROR POOL AND THE SOURCE PROG BUFFER 1 05800000 * STORE CONTENT OF PRELIMINARY ERROR POOL IN NEW ERROR POOL 05820000 SPACE 05840000 L R0,POOLS SIZE OF ERROR POOL 05860000 LR RA,R0 05880000 A R0,SRCE1S SIZE OF SOURCE PROG BUFFER 1 05900000 LR RC,R0 SIZE OF TOTAL AREA 05920000 GETMAIN R,LV=(0) 05940000 XI HCOMPMOD+1,NOBUF COMMON BUFFER AREA PRESENT 05960000 L RB,NEXTERR ADDR OF NEXT FREE BYTE IN PREL POOL 05980000 LA RD,PRELPOOL ADDR OF BEGIN OF PREL POOL 06000000 SR RB,RD NUMBER OF BYTES IN ERROR POOL 06020000 EX RB,MOVEPOOL 06040000 B *+10 BRANCH AROUND MVC INSTR 06060000 MOVEPOOL MVC 0(0,R1),PRELPOOL 06080000 ST R1,ERRPOOL ADDR OF FIRST BYTE OF POOL 06100000 AR RB,R1 ADDR OF NEXT FREE BYTE 06120000 ST RB,NEXTERR 06140000 AR RA,R1 ADDR OF END OF POOL +1 06160000 ST RA,SRCE1ADD ADDR OF SOURCE PROG BUFFER 1 06180000 AR RC,R1 END ADDR OF SOURCE PROG BUFFER 1 06200000 ST RC,SRCE1END 06220000 SH RA,=H'24' ADDR OF END OF POOL -23 06240000 ST RA,ENDPOOL 06260000 SPACE 2 06280000 * COMPLETE THE DATA CONTROL BLOCKS 06300000 SPACE 06320000 LM R3,R12,LINADD ADDRESSES OF THE DCBS 06340000 USING IHADCB,R3 SYSLIN DCB 06360000 MVC DCBEXLST+1(3),=AL3(LINEX) ADDR OF EXLIST 06380000 DROP R3 06400000 USING IHADCB,R7 SYSIN DCB 06420000 MVC DCBEXLST+1(3),=AL3(INEX) ADDR OF EXLIST 06440000 DROP R7 06460000 USING IHADCB,R9 SYSPUNCH DCB 06480000 MVC DCBEXLST+1(3),=AL3(PCHEX) ADDR OF EXLIST 06500000 DROP R9 06520000 USING IHADCB,R10 SYSUT1 DCB 06540000 LH R4,SRCE1S+2 SOURCE PROG BUFFER 1 SIZE 06560000 STH R4,DCBBLKSI BLOCK SIZE 06580000 DROP R10 06600000 USING IHADCB,R11 SYSUT2 DCB 06620000 STH R4,DCBBLKSI BLOCK SIZE 06640000 DROP R11 06660000 SPACE 2 06680000 * OPEN ALL DATA CONTROL BLOCKS 06700000 SPACE 06720000 MVC ERET,=A(OPEXERR) ERROR ROUT FOR OPEN EXIT ROUTINES 06740000 OPEN ((3),OUTPUT,(8),OUTPUT,(9),OUTPUT,(11),OUTIN,(12),OUTIN)X06760000 OPEN THE SYSLIN-, SYSPRINT-, X06780000 SYSPUNCH-, SYSUT2- AND SYSUT3 DCBS 06800000 OPEN ((10),OUTIN) OPEN THE SYSUT1 DCB 06820000 OPEN ((R7),) OPEN THE SYSIN DCB 06840000 MVC ERET,=A(GOTOTERM) 06860000 SPACE 2 06880000 * TEST IF THE SYSPRINT DCB HAS BEEN OPENED 06900000 SPACE 06920000 USING IHADCB,8 06940000 TSTDCB TM DCBOFLGS,X'10' TERMINATE THE COMPILATION IF THE 06960000 DROP 8 06980000 BO EDITDATE 07000000 OI HCOMPMOD+2,PRTNO SYSPRINT DCB NOT OPENED 07020000 LR R7,R8 DCB ADDRESS 07040000 L R4,NEXTERR 07060000 B ERROR201 07080000 SPACE 2 07100000 * GET DATE AND TRANSLATE IT TO MMM DD 19YY 07120000 SPACE 07140000 EDITDATE EQU * 07160000 TIME , GET SYSTEM DATE 07180000 ST R1,FIELD2 07200000 MVI FIELD2,X'19' TWENTIETH CENTURY 07220000 UNPK FIELD1(7),FIELD2(4) 07240000 MVC YEAR(4),FIELD1 YEAR IN UNPACKED FORM 07260000 MVO FIELD1(8),FIELD2+1(1) YEAR IN PACKED FORM 07280000 CVB RB,FIELD1 07300000 SR RA,RA 07320000 D RA,=F'4' 07340000 LTR RA,RA 07360000 BC 7,NOLEAP LEAP-YEAR IF NO REMAINDER 07380000 MVI FEBRUARY+1,X'1D' FEBRUARY HAS 29 DAYS 07400000 NOLEAP MVC FIELD1+6(2),FIELD2+2 PACKED DAY OF THE YEAR 07420000 CVB RA,FIELD1 BINARY DAY OF THE YEAR 07440000 LA IDX,JANUARY-6 INITIALIZE FOR THE LOOP TO FIND 07460000 * THE ACTUAL MONTH 07480000 FNDMONTH LA IDX,6(IDX) INCREASE INDEX FOR NEXT MONTH 07500000 LR RB,RA SAVE DAY 07520000 SH RA,0(IDX) THE MONTH IS FOUND IF 07540000 BC 12,MONFOUND THE DIFFERENCE IS ZERO OR NEG 07560000 CLI 5(IDX),X'FF' 07580000 BNE FNDMONTH IF NOT END OF YEAR 07600000 MVC MONTH-1(12),=C'IS INCORRECT' 07620000 B DATEND THE SYSTEM DATE IS INCORRECT 07640000 MONFOUND MVC MONTH(3),2(IDX) 3-LETTER MONTH NAME 07660000 CVD RB,FIELD1 PACKED DAY OF THE MONTH 07680000 UNPK DAY(2),FIELD1+6(2) UNPACKED DAY OF THE MONTH 07700000 MVZ DAY+1(1),DAY MOVE IN PROPER ZONE 07720000 DATEND EQU * 07740000 SPACE 2 07760000 * WRITE FIRST RECORD ON SYSPRINT 07780000 SPACE 07800000 L R1,PRINTADD 07820000 PUT (1) SKIP TO NEW PAGE 07840000 MVC 0(2,1),SKIP BY PRINTING A BLANK LINE 07860000 MVC 2(89,1),1(1) 07880000 L R1,PRINTADD 07900000 PUT (1) 07920000 MVC 0(91,1),FIRSTLIN FIRST LINE ON FIRST PAGE 07940000 SPACE 2 07960000 MVC ERET,=A(GOTOEDIT) ERROR ROUT FOR REST OF PHASE 07980000 SPACE 2 08000000 * TEST IF THE OTHER DCBS HAVE BEEN OPENED 08020000 SPACE 08040000 LM R3,R12,LINADD 08060000 L R4,NEXTERR 08080000 SPACE 08100000 USING IHADCB,R3 TEST SYSLIN 08120000 TM HCOMPMOD+1,NLOAD 08140000 BO TSTPUNCH IF NOLOAD SPECIFIED 08160000 TM DCBOFLGS,X'10' 08180000 BO TSTPUNCH IF DCB HAS BEEN OPENED 08200000 OI HCOMPMOD+1,NLOAD SET NOLOAD OPTION BIT ON 08220000 MVC 0(4,R4),PTRN202 PATTERN FOR MSG 202 08240000 LA R4,4(R4) POINTER TO NEXT FREE ENTRY 08260000 DROP R3 08280000 SPACE 08300000 USING IHADCB,R9 TEST SYSPUNCH 08320000 TSTPUNCH TM HCOMPMOD+1,NDCK 08340000 BO TSTIN IF NODECK SPECIFIED 08360000 TM DCBOFLGS,X'10' 08380000 BO TSTIN IF DCB HAS BEEN OPENED 08400000 OI HCOMPMOD+1,NDCK SWT NODECK OPTION BIT ON 08420000 MVC 0(4,R4),PTRN203 PATTERN FOR MSG 203 08440000 LA R4,4(R4) POINTER TO NEXT FREE ENTRY 08460000 DROP R9 08480000 SPACE 08500000 TSTIN BAL R14,TSTDCBRT DCB ADDR FOR SYSIN IS IN REG 7 08520000 LR R7,R10 TEST SYSUT1 08540000 BAL R14,TSTDCBRT 08560000 LR R7,R11 TEST SYSUT2 08580000 BAL R14,TSTDCBRT 08600000 LR R7,R12 TEST SYSUT3 08620000 ERROR201 EQU * ENTRY IF SYSPRINT NOT OPENED 08640000 LA R14,STPOINTR DO NOT RETURN 08660000 USING IHADCB,R7 08680000 TSTDCBRT TM DCBOFLGS,X'10' TEST IF DCB OPENED 08700000 BCR 1,R14 RETURN IF OK 08720000 MVC 0(4,R4),PTRN201 PATTERN FOR MSG 201 08740000 MVC 4(8,R4),DCBDDNAM DDNAM 08760000 LA R4,12(R4) UPDATE POINTER 08780000 OI HCOMPMOD+1,NOGO SET NOGO SWITCH ON 08800000 BR R14 RETURN 08820000 DROP R7 08840000 STPOINTR ST R4,NEXTERR 08860000 SPACE 2 08880000 * END OF INITIALIZATION OF THE COMPILER GO TO SCAN 1/2 OR TO PHASE 21 08900000 * FOR ERROR EDITING IF COMPILATION IS IMPOSSIBLE 08920000 SPACE 08940000 TM HCOMPMOD+1,NOGO 08960000 BO GOTOEDIT IF COMPILATION IMPOSSIBLE 08980000 L BASE,=A(IEX10001) 09000000 BR BASE TO INITIALIZE IEX11 09020000 SPACE 2 09040000 * DCB EXIT ROUTINES 09060000 SPACE 09080000 USING IHADCB,R1 09100000 SPACE 09120000 INEXRT LH RC,INBLKS MAX BLOCKSIZE ALLOWED 09140000 BAL RE,COMEXRT BRANCH TO ROUT COMMON TO ALL EXIT RT 09160000 OI HCOMPMOD+1,NOGO ABNORMAL RETURN, SET NOGO SWITCH ON 09180000 MVC 0(4,RF),PTRN204 ERROR PATTERN FOR MSG 204 09200000 LA RF,4(RF) UPDATE POINTER TO 09220000 ST RF,NEXTERR NEXT ENTRY 09240000 BR R14 RETURN TO OPEN ROUT 09260000 SPACE 09280000 LINEXRT LH RC,LINBLKS MAX BLOCKSIZE ALLOWED 09300000 BAL RE,COMEXRT BRANCH TO COMMON ROUTINE 09320000 MVC 0(12,RF),PTRN205A PATTERN FOR MSG 205 AND SYSLIN 09340000 LA RF,12(RF) UPDATE POINTER TO 09360000 ST RF,NEXTERR NEXT ENTRY 09380000 BR R14 RETURN TO OPEN ROUT 09400000 SPACE 09420000 PCHEXRT LH RC,PCHBLKS MAX BLOCKSIZE ALLOWED 09440000 BAL RE,COMEXRT BRANCH TO COMMON ROUTINE 09460000 MVC 0(12,RF),PTRN205B PATTERN FOR MSG 205 AND SYSPUNCH 09480000 LA RF,12(RF) UPDATE POINTER TO 09500000 ST RF,NEXTERR NEXT ENTRY 09520000 BR R14 RETURN TO OPEN ROUTINE 09540000 SPACE 09560000 PRTEXRT LH RC,PRTBLKS MAX BLOCKSIZE ALLOWED 09580000 BAL RE,COMEXRT BRANCH TO COMMON ROUTINE 09600000 MVC 0(12,RF),PTRN205C PATTERN FOR MSG 205 AND SYSPRINT 09620000 LA RF,12(RF) UPDATE POINTER TO 09640000 ST RF,NEXTERR NEXT ENTRY 09660000 BR R14 RETURN TO OPEN ROUTINE 09680000 SPACE 09700000 COMEXRT LH RB,DCBBLKSI BLOCKSIZE FROM DCB 09720000 LH RD,DCBLRECL RECORD LENGTH FROM DCB 09740000 LTR RB,RB TEST IF BLKSIZE WAS SPECIFIED IN DD 09760000 BC 7,DIVTEST IF SPECIFIED. 09780000 STH RD,DCBBLKSI SET BLKSIZE EQU LRECL 09800000 BR R14 RETURN TO OPEN ROUTINE 09820000 DIVTEST L RF,NEXTERR ADD OF NEXT ENTRY IN ERROR POOL 09840000 SR RA,RA TEST IF BLKSIZE 09860000 DR RA,RD IS A MULTIPLE 09880000 LTR RA,RA OF LRECL 09900000 BC 7,NOTOK IF NOT MULTIPLE 09920000 TM HCOMPMOD+1,NOBUF GO BACK TO OPEN ROUTINE IF THE 09940000 BCR 1,R14 SIZE PARAMETER WAS INCORRECT 09960000 LH RA,DCBBLKSI 09980000 CLR RA,RC TEST IF BLOCKSIZE TOO LARGE 10000000 BCR 12,R14 IF OK 10020000 NOTOK STH RD,DCBBLKSI SET BLOCKSIZE EQU RECORD LENGTH 10040000 BR RE ERROR RETURN 10060000 DROP R1 10080000 SPACE 2 10100000 * ERROR ROUTINES 10120000 SPACE 10140000 * ROUTINE FOR UNEXPECTED ERROR DURING OPEN. ENTERED VIA ERET. 10160000 SPACE 10180000 OPEXERR OI HCOMPMOD+1,NOGO 10200000 BR R14 GO BACK TO OPEN ROUTINE 10220000 DROP BASE 10240000 SPACE 10260000 * EXIT TO TERMINATING PHASE IF ERROR EDITING NOT POSSIBLE. 10280000 SPACE 10300000 GOTOTERM BALR BASE,0 10320000 USING *,BASE 10340000 BAL RA,CLOSE 10360000 XCTL EP=IEX51002 GO TO TERMINATING PHASE 10380000 DROP BASE 10400000 SPACE 10420000 * TERMINATE VIA ERROR EDITING PHASE. 10440000 SPACE 10460000 GOTOEDIT BALR BASE,0 10480000 USING *,BASE 10500000 BAL RA,CLOSE 10520000 OI HCOMPMOD,X'08' INDICATE TERMINATING ERROR 10540000 XCTL EP=IEX21000 GO TO EDIT PHASE 10560000 DROP BASE 10580000 SPACE 10600000 * SUBROUTINE FOR CLOSING SYSIN AND SYSUT1 10620000 SPACE 10640000 CLOSE BALR R3,0 10660000 USING *,R3 10680000 L R6,INADD 10700000 USING IHADCB,R6 10720000 TM DCBOFLGS,X'10' TEST IF OPENED 10740000 DROP R6 10760000 BO *+8 10780000 OI SWITCH+1,X'F0' IF SYSIN NOT OPENED 10800000 L R7,UT1ADD 10820000 CLOSE ((6),,(7)) CLOSE SYSIN AND SYSUT1 10840000 SWITCH NOPR RA RETURN IF SYSIN NOT OPENED 10860000 FREEPOOL (R6) FREE SYSIN BUFFER 10880000 BR RA RETURN 10900000 DROP R3 10920000 SPACE 2 10940000 LTORG 10960000 EJECT 10980000 * DCB EXIT LIST FOR SYSIN, SYSLIN, SYSPUNCH AND SYSPRINT 11000000 SPACE 11020000 DS 0F 11040000 INEX DC X'85',AL3(INEXRT) 11060000 LINEX DC X'85',AL3(LINEXRT) 11080000 PCHEX DC X'85',AL3(PCHEXRT) 11100000 PRINTEX DC X'85',AL3(PRTEXRT) 11120000 SPACE 2 11140000 * TABLE OF THE SIZES OF WORKAREAS WHICH VARY WITH THE AVAILABLE MAIN- 11160000 * STORAGE 11180000 SPACE 11200000 * AVAILABLE SPACE IS BETWEEN 44K AND 50K 11220000 ARTAB EQU * 11240000 DC F'51200' 50K 11260000 DC H'400' MAX BLKSIZE FOR SYSIN 11280000 DC H'455' MAX BLKSIZE FOR SYSPRINT 11300000 DC H'400' MAX BLKSIZE FOR SYSLIN 11320000 DC H'80' MAX BLKSIZE FOR SYSPUNCH 11340000 DC F'600' SIZE OF ERROR POOL 11360000 DC F'1024' SOURCE PROG BUFFERS 1 AND 2 11380000 DC F'8184' ITAB FOR PHASE 10 11400000 DC F'25000' ITAB FOR PHASE 20 11420000 DC F'8800' ITAB FOR PHASE 30 11440000 DC F'450' CRIDTAB FOR PHASE 30 11460000 DC F'1400' SUTAB BUFFER FOR PHASE 30 11480000 DC F'800' LVTAB BUFFER FOR PHASE 30 11500000 DC F'224' OPTAB BUFFERS 1 AND 2 FOR PHASES 40 AND 50 11520000 DC F'7200' LVTAB UNSORTED AND SORTED FOR PHASE 40 11540000 DC F'14000' SUTAB UNSORTED AND SORTED FOR PHASE 40 11560000 DC F'768' OPERATOR OPERAND STACK FOR PHASE 50 11580000 SPACE 11600000 * AVAILABLE SPACE IS BETWEEN 50K AND 58K 11620000 ARTAB1 EQU * 11640000 DC F'59392' 58K 11660000 DC H'400' MAX BLKSIZE FOR SYSIN 11680000 DC H'455' MAX BLKSIZE FOR SYSPRINT 11700000 DC H'400' MAX BLKSIZE FOR SYSLIN 11720000 DC H'400' MAX BLKSIZE FOR SYSPUNCH 11740000 DC F'1000' SIZE OF ERROR POOL 11760000 DC F'1536' SOURCE PROGRAM BUFFERS 1 AND 2 11780000 DC F'11924' ITAB FOR PHASE 10 11800000 DC F'29500' ITAB FOR PHASE 20 11820000 DC F'11500' ITAB FOR PHASE 30 11840000 DC F'450' CRIDTAB FOR PHASE 30 11860000 DC F'1400' SUTAB BUFFER FOR PHASE 30 11880000 DC F'800' LVTAB BUFFER FOR PHASE 30 11900000 DC F'910' OPTAB BUFFERS FOR PHASE 40 AND 50 11920000 DC F'8000' LVTAB UNSORTED AND SORTED FOR PHASE 40 11940000 DC F'15400' SUTAB UNSORTED AND SORTED FOR PHASE 40 11960000 DC F'3072' OPERATOR/OPERAND STACK FOR PHASE 50 11980000 SPACE 12000000 * AVAILABLE SPACE IS BETWEEN 58K AND 66K 12020000 DC F'67584' 66K 12040000 DC H'400' MAX BLKSIZE FOR SYSIN 12060000 DC H'455' MAX BLKSIZE FOR SYSPRINT 12080000 DC H'400' MAX BLKSIZE FOR SYSLIN 12100000 DC H'400' MAX BLKSIZE FOR SYSPUNCH 12120000 DC F'1304' SIZE OF ERROR POOL 12140000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 12160000 * INCREASE TO 2048 WHEN TRACK OVFL SUPPORTED 12180000 DC F'17754' ITAB FOR PHASE 10 12200000 DC F'36500' ITAB FOR PHASE 20 12220000 DC F'15000' ITAB FOR PHASE 30 12240000 DC F'900' CRIDTAB FOR PHASE 30 12260000 DC F'1400' SUTAB BUFFER FOR PHASE 30 12280000 DC F'800' LVTAB BUFFER FOR PHASE 30 12300000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 12320000 DC F'9600' LVTAB UNSORTED AND SORTED FOR PHASE 40 12340000 DC F'18200' SUTAB UNSORTED AND SORTED FOR PHASE 40 12360000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 12380000 SPACE 12400000 * AVAILABLE SPACE IS BETWEEN 66K AND 76K 12420000 DC F'77824' 76K 12440000 DC H'400' MAX BLKSIZE FOR SYSIN 12460000 DC H'455' MAX BLKSIZE FOR SYSPRINT 12480000 DC H'400' MAX BLKSIZE FOR SYSLIN 12500000 DC H'400' MAX BLKSIZE FOR SYSPUNCH 12520000 DC F'1600' SIZE OF ERROR POOL 12540000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 12560000 * INCREASE TO 4096 WHEN TRACK OVFL SUPPORTED 12580000 DC F'21054' ITAB FOR PHASE 10 12600000 DC F'41000' ITAB FOR PHASE 20 12620000 DC F'16000' ITAB FOR PHASE 30 12640000 DC F'900' CRIDTAB FOR PHASE 30 12660000 DC F'1400' SUTAB BUFFER FOR PHASE 30 12680000 DC F'800' LVTAB BUFFER FOR PHASE 30 12700000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 12720000 DC F'11200' LVTAB UNSORTED AND SORTED FOR PHASE 40 12740000 DC F'21000' SUTAB UNSORTED AND SORTED FOR PHASE 40 12760000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 12780000 SPACE 12800000 * AVAILABLE SPACE IS BETWEEN 76K AND 88K 12820000 DC F'90112' 88K 12840000 DC H'400' MAX BLKSIZE FOR SYSIN 12860000 DC H'455' MAX BLKSIZE FOR SYSPRINT 12880000 DC H'400' MAX BLKSIZE FOR SYSLIN 12900000 DC H'400' MAX BLKSIZE FOR SYSPUNCH 12920000 DC F'2000' SIZE OF ERROR POOL 12940000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 12960000 * INCREASE TO 6144 WHEN TRACK OVFL SUPPORTED 12980000 DC F'23584' ITAB FOR PHASE 10 13000000 DC F'48000' ITAB FOR PHASE 20 13020000 DC F'16000' ITAB FOR PHASE 30 13040000 DC F'1350' CRIDTAB FOR PHASE 30 13060000 DC F'1400' SUTAB BUFFER FOR PHASE 30 13080000 DC F'800' LVTAB BUFFER FOR PHASE 30 13100000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 13120000 DC F'12800' LVTAB UNSORTED AND SORTED FOR PHASE 40 13140000 DC F'23800' SUTAB UNSORTED AND SORTED FOR PHASE 40 13160000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 13180000 SPACE 13200000 * AVAILABLE SPACE IS BETWEEN 88K AND 102K 13220000 DC F'104448' 102K 13240000 DC H'1600' MAX BLKSIZE FOR SYSIN 13260000 DC H'1820' MAX BLKSIZE FOR SYSPRINT 13280000 DC H'3200' MAX BLKSIZE FOR SYSLIN 13300000 DC H'1600' MAX BLKSIZE FOR SYSPUNCH 13320000 DC F'2000' SIZE OF ERROR POOL 13340000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 13360000 * INCREASE TO 6144 WHEN TRACK OVFL SUPPORTED 13380000 DC F'23584' ITAB FOR PHASE 10 13400000 DC F'50000' ITAB FOR PHASE 20 13420000 DC F'16000' ITAB FOR PHASE 30 13440000 DC F'1350' CRIDTAB FOR PHASE 30 13460000 DC F'1400' SUTAB BUFFER FOR PHASE 30 13480000 DC F'800' LVTAB BUFFER FOR PHASE 30 13500000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 13520000 DC F'13600' LVTAB UNSORTED AND SORTED FOR PHASE 40 13540000 DC F'25200' SUTAB UNSORTED AND SORTED FOR PHASE 40 13560000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 13580000 SPACE 13600000 * AVAILABLE SPACE IS BETWEEN 102K AND 118K 13620000 DC F'120832' 118K 13640000 DC H'1600' MAX BLKSIZE FOR SYSIN 13660000 DC H'1820' MAX BLKSIZE FOR SYSPRINT 13680000 DC H'3200' MAX BLKSIZE FOR SYSLIN 13700000 DC H'1600' MAX BLKSIZE FOR SYSPUNCH 13720000 DC F'2000' SIZE OF ERROR POOL 13740000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 13760000 * INCREASE TO 8192 WHEN TRACK OVFL SUPPORTED 13780000 DC F'32736' ITAB FOR PHASE 10 13800000 DC F'62000' ITAB FOR PHASE 20 13820000 DC F'19000' ITAB FOR PHASE 30 13840000 DC F'2250' CRIDTAB FOR PHASE 30 13860000 DC F'1400' SUTAB BUFFER FOR PHASE 30 13880000 * INCREASE TO 2800 WHEN TRACK OVFL SUPPORTED 13900000 DC F'1600' LVTAB BUFFER FOR PHASE 30 13920000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 13940000 DC F'16000' LVTAB UNSORTED AND SORTED FOR PHASE 40 13960000 DC F'30800' SUTAB UNSORTED AND SORTED FOR PHASE 40 13980000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 14000000 SPACE 14020000 * AVAILABLE SPACE IS BETWEEN 118K AND 136K 14040000 DC F'139264' 136K 14060000 DC H'1600' MAX BLKSIZE FOR SYSIN 14080000 DC H'1820' MAX BLKSIZE FOR SYSPRINT 14100000 DC H'3200' MAX BLKSIZE FOR SYSLIN 14120000 DC H'1600' MAX BLKSIZE FOR SYSPUNCH 14140000 DC F'2000' SIZE OF ERROR POOL 14160000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 14180000 * INCREASE TO 8192 WHEN TRACK OVFL SUPPORTED 14200000 DC F'32736' ITAB FOR PHASE 10 14220000 DC F'75000' ITAB FOR PHASE 20 14240000 DC F'25000' ITAB FOR PHASE 30 14260000 DC F'3600' CRIDTAB FOR PHASE 30 14280000 DC F'1400' SUTAB BUFFER FOR PHASE 30 14300000 * INCREASE TO 7000 WHEN TRACK OVFL SUPPORTED 14320000 DC F'1600' LVTAB BUFFER FOR PHASE 30 14340000 * INCREASE TO 4800 WHEN TRACK OVFL SUPPORTED 14360000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 14380000 DC F'19200' LVTAB UNSORTED AND SORTED FOR PHASE 40 14400000 DC F'35000' SUTAB UNSORTED AND SORTED FOR PHASE 40 14420000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 14440000 SPACE 14460000 * AVAILABLE SPACE IS BETWEEN 136K AND 156K 14480000 DC F'159744' 156K 14500000 DC H'1600' MAX BLKSIZE FOR SYSIN 14520000 DC H'1820' MAX BLKSIZE FOR SYSPRINT 14540000 DC H'3200' MAX BLKSIZE FOR SYSLIN 14560000 DC H'1600' MAX BLKSIZE FOR SYSPUNCH 14580000 DC F'2000' SIZE OF ERROR POOL 14600000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 14620000 * INCREASE TO 8192 WHEN TRACK OVFL SUPPORTED 14640000 DC F'32736' ITAB FOR PHASE 10 14660000 DC F'95000' ITAB FOR PHASE 20 14680000 DC F'38000' ITAB FOR PHASE 30 14700000 DC F'3600' CRIDTAB FOR PHASE 30 14720000 DC F'1400' SUTAB BUFFER FOR PHASE 30 14740000 * INCREASE TO 7000 WHEN TRACK OVFL SUPPORTED 14760000 DC F'1600' LVTAB BUFFER FOR PHASE 30 14780000 * INCREASE TO 4800 WHEN TRACK OVFL SUPPORTED 14800000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 14820000 DC F'24000' LVTAB UNSORTED AND SORTED FOR PHASE 40 14840000 DC F'35000' SUTAB UNSORTED AND SORTED FOR PHASE 40 14860000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 14880000 SPACE 14900000 * AVAILABLE SPACE IS BETWEEN 156K AND 180K 14920000 DC F'184320' 180K 14940000 DC H'1600' MAX BLKSIZE FOR SYSIN 14960000 DC H'1820' MAX BLKSIZE FOR SYSPRINT 14980000 DC H'3200' MAX BLKSIZE FOR SYSLIN 15000000 DC H'1600' MAX BLKSIZE FOR SYSPUNCH 15020000 DC F'2000' SIZE OF ERROR POOL 15040000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 15060000 * INCREASE TO 8192 WHEN TRACK OVFL SUPPORTED 15080000 DC F'32736' ITAB FOR PHASE 10 15100000 DC F'115000' ITAB FOR PHASE 20 15120000 DC F'58000' ITAB FOR PHASE 30 15140000 DC F'3600' CRIDTAB FOR PHASE 30 15160000 DC F'1400' SUTAB BUFFER FOR PHASE 30 15180000 * INCREASE TO 7000 WHEN TRACK OVFL SUPPORTED 15200000 DC F'1600' LVTAB BUFFER FOR PHASE 30 15220000 * INCREASE TO 6400 WHEN TRACK OVFL SUPPORTED 15240000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 15260000 DC F'25600' LVTAB UNSORTED AND SORTED FOR PHASE 40 15280000 DC F'56000' SUTAB UNSORTED AND SORTED FOR PHASE 40 15300000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 15320000 SPACE 15340000 * AVAILABLE SPACE IS BETWEEN 180K AND 208K 15360000 DC F'212992' 208K 15380000 DC H'3200' MAX BLKSIZE FOR SYSIN 15400000 DC H'3640' MAX BLKSIZE FOR SYSPRINT 15420000 DC H'3200' MAX BLKSIZE FOR SYSLIN 15440000 DC H'3200' MAX BLKSIZE FOR SYSPUNCH 15460000 DC F'2000' SIZE OF ERROR POOL 15480000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 15500000 * INCREASE TO 8192 WHEN TRACK OVFL SUPPORTED 15520000 DC F'32736' ITAB FOR PHASE 10 15540000 DC F'135000' ITAB FOR PHASE 20 15560000 DC F'58000' ITAB FOR PHASE 30 15580000 DC F'3600' CRIDTAB FOR PHASE 30 15600000 DC F'1400' SUTAB BUFFER FOR PHASE 30 15620000 * INCREASED TO 7000 WHEN TRACK OVFL SUPPORTED 15640000 DC F'1600' LVTAB BUFFER FOR PHASE 30 15660000 * INCREASE TO 6400 WHEN TRACK OVFL SUPPORTED 15680000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 15700000 DC F'25600' LVTAB UNSORTED AND SORTED FOR PHASE 40 15720000 DC F'56000' SUTAB UNSORTED AND SORTED FOR PHASE 40 15740000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 15760000 SPACE 15780000 * AVAILABLE SPACE IS 208K OR MORE 15800000 DC F'16777216' 15820000 DC H'3200' MAX BLKSIZE FOR SYSIN 15840000 DC H'3640' MAX BLKSIZE FOR SYSPRINT 15860000 DC H'3200' MAX BLKSIZE FOR SYSLIN 15880000 DC H'3200' MAX BLKSIZE FOR SYSPUNCH 15900000 DC F'2000' SIZE OF ERROR POOL 15920000 DC F'2000' SOURCE PROGRAM BUFFERS 1 AND 2 15940000 * INCREASE TO 8192 WHEN TRACK OVFL SUPPORTED 15960000 DC F'32736' ITAB FOR PHASE 10 15980000 DC F'162000' ITAB FOR PHASE 20 16000000 DC F'58000' ITAB FOR PHASE 30 16020000 DC F'3600' CRIDTAB FOR PHASE 30 16040000 DC F'1400' SUTAB BUFFER FOR PHASE 30 16060000 * INCREASE TO 11200 WHEN TRACK OVFL SUPPORTED 16080000 DC F'1600' LVTAB BUFFER FOR PHASE 30 16100000 * INCREASE TO 6400 WHEN TRACK OVFL SUPPORTED 16120000 DC F'1792' OPTAB BUFFERS FOR PHASE 40 AND 50 16140000 DC F'25600' LVTAB UNSORTED AND SORTED FOR PHASE 40 16160000 DC F'56000' SUTAB UNSORTED AND SORTED FOR PHASE 40 16180000 DC F'6144' OPERATOR/OPERAND STACK FOR PHASE 50 16200000 SPACE 2 16220000 * PATTERNS FOR THE ERROR MESSAGES OF THE INITIALIZATION PHASE 16240000 SPACE 16260000 * W OPTION PARAMETER ... IS INVALID. THE PARAMETER IS DISREGARDED 16280000 PTRN200 DC AL1(128+16,200),AL2(0),CL12' ' 16300000 SPACE 16320000 * T DD CARD FOR ... IS INCORRECT OR MISSING 16340000 PTRN201 DC AL1(128+12,201),AL2(0) 16360000 SPACE 16380000 * W DD CARD FOR SYSLIN IS INCORRECT OR MISSING. OPTION NOLOAD IS 16400000 * ASSUMED 16420000 PTRN202 DC AL1(128+4,202),AL2(0) 16440000 SPACE 16460000 * W DD CARD FOR SYSPUNCH IS INCORRECT OF MISSING. OPTION NODECK IS 16480000 * ASSUMED 16500000 PTRN203 DC AL1(128+4,203),AL2(0) 16520000 SPACE 16540000 * T BLOCKSIZE SPECIFIED FOR SYSIN IS INCORRECT 16560000 PTRN204 DC AL1(128+4,204),AL2(0) 16580000 SPACE 16600000 * W BLOCKSIZE SPECIFIED FOR ... IS INCORRECT. UNBLOCKED OUTPUT IS 16620000 * GENERATED INSTEAD 16640000 PTRN205A DC AL1(128+12,205),AL2(0),CL8'SYSLIN' 16660000 PTRN205B DC AL1(128+12,205),AL2(0),CL8'SYSPUNCH' 16680000 PTRN205C DC AL1(128+12,205),AL2(0),CL8'SYSPRINT' 16700000 SPACE 16720000 * W INCORRECT PARAMETER FIELD. NO OPTION PARAMETERS ARE HANDLED ANY 16740000 * MORE 16760000 PTRN206 DC AL1(128+4,206),AL2(0) 16780000 SPACE 16800000 * W POSSIBLE ERROR IN DD NAMES PARAMETER 16820000 PTRN207 DC AL1(128+4,207),AL2(0) 16840000 SPACE 16860000 * T SIZE PARAMERER IS INCORRECT. MINIMUM STORAGE SIZE FOR ALGOL F COM- 16880000 * PILER IS 45056 BYTES 16900000 PTRN208 DC AL1(128+4,208),AL2(0) 16920000 SPACE 2 16940000 * FIRST LINE OF PRINTED OUTPUT 16960000 SPACE 16980000 SKIP DC X'89',C' ' RECORD WITH SKIP CTL CHAR. 17000000 FIRSTLIN DC X'11' CTL PRINT AND DOUBLE SPACE 17020000 LEVEL DC C'LEVEL 1JUL67',CL28' ',C'OS ALGOL F',CL23' ',C'DATE ' 17040000 MONTH DC CL4' ' 17060000 DAY DC CL3' ' 17080000 YEAR DC CL4' ' 17100000 SPACE 2 17120000 * TABLE OF THE MONTH NAMES AND THE NUMBER OF DAYS 17140000 SPACE 17160000 JANUARY DC H'31' 17180000 DC C'JAN ' 17200000 FEBRUARY DC H'28' 17220000 DC C'FEB ' 17240000 DC H'31' 17260000 DC C'MAR ' 17280000 DC H'30' 17300000 DC C'APR ' 17320000 DC H'31' 17340000 DC C'MAY ' 17360000 DC H'30' 17380000 DC C'JUN ' 17400000 DC H'31' 17420000 DC C'JUL ' 17440000 DC H'31' 17460000 DC C'AUG ' 17480000 DC H'30' 17500000 DC C'SEP ' 17520000 DC H'31' 17540000 DC C'OCT ' 17560000 DC H'30' 17580000 DC C'NOV ' 17600000 DC H'31' 17620000 DC C'DEC' 17640000 DC X'FF' END OF YEAR INDICATOR 17660000 SPACE 2 17680000 * TABLE OF OPTION PARAMETERS 17700000 SPACE 17720000 PARMLIST DC HL1'6' 17740000 DC CL9'PROGRAM' 17760000 NI PARMFLD,PGR 17780000 LENGTH DC HL1'8' (LENGTH-1) OF PARAM 17800000 PARAM DC CL9'PROCEDURE' PARAMETER 17820000 INSTR OI PARMFLD,PROC SET SWITCH IN HCOMPMOD 17840000 DC HL1'4' 17860000 DC CL9'SHORT' 17880000 NI PARMFLD,SHRT 17900000 DC HL1'3' 17920000 DC CL9'LONG' 17940000 OI PARMFLD,LNG 17960000 DC HL1'5' 17980000 DC CL9'SOURCE' 18000000 NI PARMFLD+1,SRCE 18020000 DC HL1'7' 18040000 DC CL9'NOSOURCE' 18060000 OI PARMFLD+1,NSRCE 18080000 DC HL1'3' 18100000 DC CL9'LOAD' 18120000 NI PARMFLD+1,LOAD 18140000 DC HL1'5' 18160000 DC CL9'NOLOAD' 18180000 OI PARMFLD+1,NLOAD 18200000 DC HL1'3' 18220000 DC CL9'DECK' 18240000 NI PARMFLD+1,DCK 18260000 DC HL1'5' 18280000 DC CL9'NODECK' 18300000 OI PARMFLD+1,NDCK 18320000 DC HL1'5' 18340000 DC CL9'EBCDIC' 18360000 NI PARMFLD+1,EBCDIC 18380000 DC HL1'5' 18400000 DC CL9'NOTEST' 18420000 OI PARMFLD+2,NOTEST 18440000 DC HL1'3' 18460000 DC CL9'TEST' 18480000 NI PARMFLD+2,TEST 18500000 DC HL1'2' 18520000 DC CL9'ISO' 18540000 OI PARMFLD+1,ISO 18560000 DC HL1'1' 18580000 DC CL9'NS' 18600000 OI PARMFLD+1,NSRCE 18620000 DC HL1'1' 18640000 DC CL9'ND' 18660000 OI PARMFLD+1,NDCK 18680000 DC HL1'1' 18700000 DC CL9'NL' 18720000 OI PARMFLD+1,NLOAD 18740000 DC HL1'1' 18760000 DC CL9'EB' 18780000 NI PARMFLD+1,EBCDIC 18800000 DC HL1'1' 18820000 DC CL9'PG' 18840000 NI PARMFLD,PGR 18860000 DC HL1'1' 18880000 DC CL9'PC' 18900000 OI PARMFLD,PROC 18920000 DC HL1'1' 18940000 DC CL9'NT' 18960000 OI PARMFLD+2,NOTEST 18980000 DC HL1'1' 19000000 DC CL9'SP' 19020000 NI PARMFLD,SHRT 19040000 DC HL1'1' 19060000 DC CL9'LP' 19080000 OI PARMFLD,LNG 19100000 DC HL1'0' 19120000 DC CL9'D' 19140000 NI PARMFLD+1,DCK 19160000 DC HL1'0' 19180000 DC CL9'I' 19200000 OI PARMFLD+1,ISO 19220000 DC HL1'0' 19240000 DC CL9'L' 19260000 NI PARMFLD+1,LOAD 19280000 DC HL1'0' 19300000 DC CL9'S' 19320000 NI PARMFLD+1,SRCE 19340000 LSTENTRY DC HL1'0' 19360000 DC CL9'T' 19380000 NI PARMFLD+2,TEST 19400000 SPACE 2 19420000 * WORKSPACE FOR TRANSLATING THE SIZE PARAMTER AND THE ACTUAL DATE 19440000 SPACE 19460000 FIELD1 DS 0D 19480000 DC PL8'0' 19500000 FIELD2 DS F 19520000 EJECT 19540000 IEX10001 CSECT 19560000 USING IEX10001,BASE 19580000 SPACE 2 19600000 * (INSTRUCTIONS FOR INITIALIZING IEX11 CAN BE INSERTED HERE) 19620000 SPACE 2 19640000 XCTL EP=IEX11000 EXIT TO NEXT PHASE 19660000 EJECT 19680000 * DUMMY CONTROL SECTION TO PROVIDE ADRESSABILITY OF DCB 19700000 SPACE 19720000 DCBD DSORG=(PS) 19740000 EJECT 19760000 WORKAREA DSECT 19780000 COPY WORKAREA 19800000 SPACE 2 19820000 * CWA SYMBOL DEFINITIONS FOR IEX11 CAN BE INSERTED HERE 19840000 SPACE 2 19860000 END IEX10000 19880000 ./ ADD SSI=03012827,NAME=IEX11,SOURCE=0 TITLE 'SCAN I/II IEX11000' 00020000 *STATUS: CHANGE LEVEL 000 * 00040000 * * 00060000 *FUNCTION/OPERATION: TO TRANSFORM THE SOURCE PROGRAM TO * 00080000 * MODIFICATION LEVEL 1, WHICH INCLUDES A ONE FOR ONE TRANSLATION OF * 00100000 * ALL CHARACTERS, THE REPLACEMENT OF ALL ALGOL DELIMITERS BY ONE * 00120000 * BYTE OPERATORS AND THE REMOVAL OR MODIFICATION OF ALL * 00140000 * DECLARATIONS. * 00160000 * TO TABULATE AND CLASSIFY ALL VALID IDENTIFIERS. * 00180000 * TO ASSIGN A SERIAL PROGRAM BLOCK NUMBER TO ALL BLOCKS AND * 00200000 * PROCEDURES AND A SERIAL GROUP NUMBER TO ALL BLOCKS, PROCEDURES * 00220000 * AND FOR STATEMENTS. * 00240000 * TO RECOGNIZE SYNTACTICAL ERRORS IN THE SOURCE PROGRAM AND TO * 00260000 * GENERATE APPROPRIATE ERROR PATTERNS. * 00280000 * TO PRINT A LISTING ON SYSPRINT OF THE SOURCE PROGRAM IF OPTION * 00300000 * 'SOURCE' IS SPECIFIED. * 00320000 * TO PREPARE TABLES TO BE USED BY THE SUCCEEDING PHASES. THE TABLES * 00340000 * ARE PBTAB1, GROUPTABLE, AND SCOPETABLE. * 00360000 * * 00380000 *ENTRY POINTS: * 00400000 * IEX11000 SCAN I/II XCTL EP=IEX11000 * 00420000 * * 00440000 *INPUT: THE SOURCE PROGRAM IS READ IN FROM SYSIN. * 00460000 * * 00480000 *OUTPUT: THE SOURCE PROGRAM, MODIFICATION LEVEL 1, IS WRITTEN ON * 00500000 * SYSUT1. * 00520000 * AN ITAB RECORD IS WRITTEN FOR EACH BLOCK ON SYSUT3. * 00540000 * ESD CARD FOR THE OBJECT MODULE AND TXT CARDS FOR THE CONSTANTS 0 * 00560000 * THROUGH 15 AND THE STRINGS IN THE CONSTANT POOL ARE WRITTEN ON * 00580000 * SYSLIN AND OR SYSPUNCH IF THE OPTIONS 'LOAD' AND OR 'DECK' IS * 00600000 * SPECIFIED. * 00620000 * THE SOURCE PROGRAM IS LISTED ON SYSPRINT IF OPTION 'SOURCE' IS * 00640000 * SPECIFIED. * 00660000 * * 00680000 *EXITS-NORMAL: CONTROL IS GIVEN TO ITAB MANIPULATION, XCTL EP=IEX20000* 00700000 * IF NO TERMINATING ERROR HAS BEEN DETECTED. * 00720000 * * 00740000 *EXITS-ERROR: IF A TERMINATING ERROR HAS BEEN DETECTED CONTROL IS * 00760000 * GIVEN TO THE ERROR MESSAGE HANDLING PHASE XCTL EP=IEX21000* 00780000 * * 00800000 *EXTERNAL ROUTINES: THE PRINT ROUTINE IN IEX00 IS USED. * 00820000 * * 00840000 *TABLES/WORKAREAS: * 00860000 * BPRTAB BRANCH ADDRESS TABLE * 00880000 * TESTTABL FOR MAINLOOP SCANNING * 00900000 * RETRANS FOR TRANSLATION FROM INTERNAL TO EBCDIC CHARACTER SET * 00920000 * COMTABLE USED BY COMMENT PROGRAM * 00940000 * STRTABLE USED BY STRING PROGRAM * 00960000 * BTABLE USED BY BLANK PROGRAM * 00980000 * KEYTAB USED BY TRANSOP * 01000000 * PTTABLE USED BY POINT AND POINT IN LIST PROGRAMS * 01020000 * TRLTABLE FOR TRANSLATION FROM EBCDIC TO INTERNAL CHARACTER SET * 01040000 * KOPOOL CONTAIN THE CONSTANTS 0 THROUGH 15 * 01060000 * ATABLE USED BY APOSTROF * 01080000 * SCTAB USED TO SAVE THE STARTING SC COUNTER FOR THE BLOCKS * 01100000 * WITAB USED FOR THE ALGOL DELIMITERS * 01120000 * LITAB FOR DISPLACEMENTS TO WITAB * 01140000 * DELPRGTB BRANCH ADDRESS TABLE AFTER A DELIMITER HAS BEEN FOUND * 01160000 * ARTABLE USED BY LIST PROGRAM * 01180000 * WA 80 BYTE WORKAREA WITH 17 PRECEEDING CHARACTERS, USED FOR* 01200000 * INPUT RECORDS. THE 17 EXTRA BYTES USED TO OVERLAP * 01220000 * BETWEEN ONE RECORD AND THE NEXT ONE. * 01240000 * STACK USED FOR THE SCOPE STRUCTURE HANDLING * 01260000 * ITAB USED TO TABULATE ALL VALID IDENTIFIERS * 01280000 * SAVEPRT DUMMY PRINTAREA. USED TO PICK UP STRINGS FROM IN EBCDIC * 01300000 * FORM IF THE OPTION 'NOSOURCE IS SPECIFIED. * 01320000 * * 01340000 *ATTRIBUTES: NONE * 01360000 * * 01380000 *NOTES: CHARACTER CODE DEPENDENCE * 01400000 * IF THE SOURCE PROGRAM IS IN ISO CODE A SCAN IS MADE IN THE * 01420000 * PROGRAM CIB TO EXCHANGE THE CHARACTERS 4C, 7B, 7C, 6C, 50, * 01440000 * WITH THE EBCDIC CHARACTERS 5D, 7E, 7D, 4D, 4E. * 01460000 * THEN WHEN THE SOURCE PROGRAM IN WA IS IN EBCDIC FORM IT IS * 01480000 * TRANSFERRED TO THE PRINTBUFFER, POSSIBLY THE DUMMY PRINTAREA. * 01500000 * THE SOURCE PROGRAM IN WA IS THEN TRANSLATED TO INTERNAL CODE BY * 01520000 * MEANS OF THE HEXADECIMAL TABLE TRLTABLE. * 01540000 * THE INVERS TABLE, TRANSLATING FROM INTERNAL TO EBCDIC CODE IS * 01560000 * CALLED RETRANS AND IS IN CHARACTER FROM. * 01580000 * THE TRANSFER OF PRECOMPILED AND CODE PROCEDURE NAMES, THE * 01600000 * TRANSFER OF STRINGS AND CONSTANTS TO THE CONSTANT POOL AND THE * 01620000 * OPERATION OF THE ROUTINE GENERATE DEPENDS ON AN INTERNAL * 01640000 * REPRESENTATION OF THE EXTERNAL CHARACTER SET WHICH IS * 01660000 * EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. 01680000 * THE OPERATION OF THE OTHER PARTS DOES NOT DEPEND UPON A * 01700000 * PARTICULAR INTERNAL REPRESENTATION OF THE EXTERNAL CHARACTER SET. * 01720000 * * 01740000 * THIS MODULE IS ONLY INTENDED TO BE EXECUTED IN CONNECTION * 01760000 * WITH THE OTHER MODULES OF THE ALGOL COMPILER. IN PARTICULAR IT * 01780000 * REQUIRES THE COMMON WORKAREA. * 01800000 * * 01820000 * * 01840000 * * 01860000 SPACE 2 01880000 SPACE 2 01900000 SPACE 2 01920000 * CONTROL SECTION 1 CONTAINS: 01940000 * INITIALIZATION 01960000 * MAINLOOP AND ITS SUBPROGRAMS 01980000 * BLANK 02000000 * TRANSOP (*,/,(,>,<,NOT,) 02020000 * RIGHTPAR 02040000 * POINT 02060000 * COLON 02080000 * LABEL 02100000 * LETDEL 02120000 * ASSIGN 02140000 * APOSTROPHE 02160000 * SCALE 02180000 * BLKAPOS 02200000 * ZETAAPOS 02220000 * NPAFAPO (NOT PERMITTED) 02240000 * SOME GENERAL ROUTINES 02260000 * STATE (STATEMENT PROGRAM) 02280000 * ERROR ROUTINES 02300000 * ITABCLEA 02320000 * IDCHCK1 02340000 * FINDSEMCO 02360000 * AND TABLES AND CONSTANTS OUTSIDE CWA 02380000 * CONTROL SECTION 2 CONTAINS: 02400000 * COB (CHANGE OUTPUT BUFFER) 02420000 * CIB (CHANGE INPUT BUFFER) 02440000 * DELIMITER 02460000 * EROUT (DELIMITER ERROR ROUTINE) 02480000 * NORMAL (/ OR AND NOT STEP LESS 02500000 * IMPL UNTIL WHILE POWER EQUIU 02520000 * NOTLESS GREATER NOTEQUAL 02540000 * NOT GREATER) 02560000 * BOLCON ('TRUE', 'FALSE') 02580000 * GIF (GOTO, IF) 02600000 * TED (THEN, ELSE, DO) 02620000 * BEGIN 02640000 * BEGI (BLOCKHEAD) 02660000 * END 02680000 * FOREND 02700000 * PBLCKEND 02720000 * COM (COMMENT) 02740000 * FOR 02760000 * TYPE ( REAL, INTEGER, BOOLEAN) 02780000 * IER (IDENT. ERROR ROUTINE) 02800000 * CODE 02820000 * CONTROL SECTION 3 CONTAINS: 02840000 * IDCHECK (SPECIFIED IDENTIFIERS) 02860000 * VALUE 02880000 * TYPEARRAY 02900000 * ARRAY 02920000 * TRATE (ARRAY AND SWITCH LIST) 02940000 * PONTLST 02960000 * SEMCLST 02980000 * LEFTPARL 03000000 * RIGHTPARL 03020000 * SLASHLST 03040000 * COMMALST 03060000 * COLONLST 03080000 * SWITCH 03100000 * STRING 03120000 * TYPPROC 03140000 * PROCEDURE 03160000 * PROCEDEL (PROC. LETTERSTRING) 03180000 * ENDMISSIN (UNBALLANCED BEGIN END COUNT) 03200000 * CONTROL SECTION 4 CONTAINS: 03220000 * TERMINATION 03240000 * 03260000 * 03280000 * 03300000 IEX11000 START 03320000 * RELEASE 19 CHANGES 03325019 * 777400 A22571 03330019 * A28230 03335019 * A28251 03337019 * RELEASE 20 CHANGES 03337300 * 112800,348000 A32949 03337600 REG0 EQU 0 03340000 REGI EQU 1 INPUT POINTER 03360000 K EQU 2 03380000 REGZ EQU 2 03400000 EAP EQU 3 OUTPUT POINTER 03420000 REGM EQU 4 POINTS TO FIRST APOSTROPHE 03440000 KEY EQU 4 TRANSOP REGISTER 03460000 REGE EQU 4 LINKREGISTER FOR PRGBLOCKEND 03480000 REGF EQU 4 LINKREGISTER FOR FDREND 03500000 REGB EQU 6 RETURN REG. FROM ERROR ROUTINES 03520000 IN EQU 7 ITAB POINTER 03540000 REGN EQU 7 03560000 REG7 EQU 7 03580000 REG8 EQU 8 BASE REGISTER 03600000 REGX EQU 9 RETURN REGISTER FROM BEGI 03620000 REG9 EQU 9 03640000 REGIX EQU 9 RETURN REG. FROM CIB 03660000 REGA EQU 9 03680000 RET EQU 10 TESTLOOP AND LIST MAIN RETURN REG. 03700000 REG11 EQU 11 BASE REGISTER 03720000 REGPS EQU 12 SPECIFICATION HANDLING 03740000 REG12 EQU 12 03760000 REGOX EQU 12 RETURN REG. FROM COB 03780000 PIN EQU 14 LABEL POINTER 03800000 REGL EQU 14 03820000 REGY EQU 15 03840000 REGH EQU 15 03860000 SPACE 2 03880000 ***** INITIALIZATION ********************************************** 03900000 * GETMAIN FOR KOPOOL 03920000 * STACK 03940000 * ITABBUF 03960000 * OUTPUTAREA2 03980000 * ITAB 04000000 * ALPHA 00 IS PUT IN STACK AND SP (STACK POINTER) 04020000 * IS MADE TO POINT TO NEXT BYTE * 04040000 * ADDRESS OF THE FIRST O/P AREA IS TAKEN FROM CWA 04060000 * AND PUT IN ADDARI. THE ADDRESS OF SECOND 04080000 * O/P AREA (FROM GETMAIN) IS PUT IN ADDARI+4 04100000 * AITAB, LIGP, LPBP, AITAB AND ELI ARE INITILIZED IN* 04120000 * ITAB. HEADLINE FOR PB0 IS CREATED. * 04140000 * AITAB, LPBP, LIGP WILL POINT TO PB0 HEAD 04160000 * AITL TO NEXT FREE ENTRY 04180000 * ELI TO LAST POSITION+1 OF ITAB * 04200000 * APE WILL POINT TO LAST POSSITION IN FIRST 04220000 * OUTPUT BUFFER 04240000 * WADDARI (CURRENT OUTPUT BUFFER) WILL POINT TO 04260000 * FIRST OUTPUT BUFFER 04280000 * EAP (REGISTR 3) WILL POINT TO FIRST O/P BUFFER 04300000 * PRINTING OF HEADLINES IS INITILIZED IF SOURCE 04320000 * WAS SPECIFIED 04340000 * SWITCHES ARE SET TO ZERO 04360000 * FIRST ENTRIES IN TABLES ARE SET TO ZERO 04380000 SPACE 2 04400000 USING IEX11001,8 04420000 USING IEX11002,11 04440000 BALR 5,0 GET BASE REGISTERS 04460000 USING *,5 04480000 USING WORKAREA,13 04500000 L REG8,VIEX1 04520000 L REG11,VIEX2 04540000 LA REGOX,SLUT2 04560000 ST REGOX,ERET INTERUPT BEFORE GETMAIN 04580000 LH REGI,FOURKA KOPOOL 04600000 LA REGI,1000(0,REGI) STACK 04620000 A REGI,SRCE1S O/P BUFFER 1 04640000 A REGI,ITAB10S ITAB 04660000 LA REGI,2000(0,REGI) ITAB BUF 04680000 ST REGI,POOLLEN STORE TOTAL LENGTH 04700000 LR REG0,REGI 04720000 GETMAIN R,LV=(0) GET AREAS NEEDED 04740000 ST REGI,POOLLOC SAVE LOCATION 04760000 LA REGOX,ENDMISS END OF DATA ADDRESS 04780000 ST REGOX,EODIN 04800000 LA REGOX,EODADIN 04820000 ST REGOX,ERET INTERUPT ADDRESS AFTER GETMAIN 04840000 ST REGI,AKOPOOL ADDRESS OF KOPOOL 04860000 LA REGI,4095(0,REGI) 04880000 MVC 1(4,REGI),KOPOOL INITILIZE STACK 04900000 LA REGI,2(0,REGI) 04920000 ST REGI,SP ADDRESS OF SECOND BYTE IN STACK 04940000 LA REGI,999(0,REGI) 04960000 ST REGI,AITABBUF INITILIZE ITAB BUFFER 04980000 LA REGI,2000(0,REGI) 05000000 ST REGI,ADDARI+4 OUTPUTAREA 2 05020000 A REGI,SRCE1S 05040000 ST REGI,AITAB ITAB 05060000 ST REGI,LIGP SURROUNDING GROUP ADDRESS 05080000 ST REGI,LPBP BLOCK ADDRESS 05100000 MVI 0(REGI),X'00' CLEAR FIRST TWO ITABENTRIES 05120000 MVC 1(21,REGI),0(REGI) 05140000 MVI 3(REGI),X'FF' CONSTRUCT CONTINUATION 05160000 MVI 5(REGI),X'2B' LINE FOR PB0 05180000 LA REGOX,11(0,REGI) 05200000 ST REGOX,AITL ADDRESS OF FIRST FREE ENTRY 05220000 A REGI,ITAB10S 05240000 ST REGI,ELI END OF ITAB 05260000 L EAP,SRCE1ADD ADD OF FIRST OUTPUT BUFFER 05280000 A EAP,SRCE1S 05300000 BCTR EAP,0 05320000 ST EAP,APE END OF FIRST O/P BUFFER 05340000 L EAP,SRCE1ADD OUTPUTAREAS' CONSTANTS 05360000 MVC ADDARI(4),SRCE1ADD 05380000 MVC WADDARI(4),ADDARI CURRENT O/P AREA ADDRESS 05400000 LA REGOX,SAVEPRNT APRNTAR IS INITILIZED WITH 05420000 ST REGOX,APRNTAR DUMMY PRINTAREA ADDRESS 05440000 MVI PAGEHEAD+2,X'40' CREATE HEADLINES 05460000 MVC PAGEHEAD+3(81),PAGEHEAD+2 05480000 MVC PAGEHEAD+39(14),HDING1 05500000 MVI PAGEHEAD+92,X'02' 05520000 MVI PAGEHEAD+93,X'11' 05540000 MVI PAGEHEAD+94,X'40' 05560000 MVC PAGEHEAD+95(81),PAGEHEAD+94 05580000 MVC PAGEHEAD+94(24),HDING2 05600000 MVI PAGEHEAD+186,X'FF' 05620000 MVI LINCNT,X'7F' 05640000 BAL REGIX,CIB GET FIRST RECORD AND ADDRESS 05660000 * OF FIRST PRINTAREA 05680000 SR REGZ,REGZ 05700000 STC REGZ,ONC USE REGZ TO ZERO COUNTERS 05720000 STC REGZ,DISP AND SWITCHES 05740000 LA REGOX,64 INITIAL VALUE FOR KOPOOL ASSAIGNMENT 05760000 ST REGOX,SPCLT 05780000 STH REGZ,IGC ITABGROUPCOUNTER AND 05800000 ST REGZ,MGESITL 05820000 STC REGZ,PBC INITIAL VALUE OF PROGRAMBLOCKCOUNTER 05840000 STC REGZ,ONC OUTPUTRECORDCOUNTER 05860000 STC REGZ,BITS1 INITIAL VALUE OF SWITCHBITS 05880000 STC REGZ,BITS2 05900000 STC REGZ,BITS3 05920000 STH REGZ,SC INITIAL VALUE OF SC COUNTER 05940000 STC REGZ,FSN INITIAL VALUE OF FSN 05960000 STC REGZ,PBTAB1 INITIAL VALUE OF PB0 05980000 ST REGZ,GPTAB+3 INITILIZE GROUP AND SCOUP TABLE 06000000 STC REGZ,SPTAB 06020000 STC REGZ,0(0,EAP) FIRST BYTE IN FIRST OUTPUTRECORD 06040000 ST EAP,OPIN 06060000 ST EAP,LAPIN SET LABEL POINTERS 06080000 STC REGZ,OPIN+4 06100000 LA REGOX,GPTAB 06120000 ST REGOX,AGT ADDRESS TO GROUPTABLE 06140000 LA REGOX,0 MAKE A28251 06146019 ST REGOX,BRACKET BRACKETCOUNTER ZERO A28251 06152019 L REGOX,AITABBUF 06160000 BCTR REGOX,0 06180000 ST REGOX,ATOPSTAK HIGHEST BYTE IN STACK TO USE 06200000 B TESTLOOP GO TO START PROCESSING 06220000 DS 0H 06240000 MOVE MVC 0(1,EAP),0(REGM) 06260000 SPACE 3 06280000 SAVE1 DS 7F 06300000 SAVEPRNT DS CL88 06320000 SPACE 2 06340000 ***** BPRTAB ****************************************************** 06360000 * CONTAINS ADDRESSCONSTANTS OF PROGRAMS UTILIZED BY 06380000 * TEST 06400000 * LIST 06420000 * POINT 06440000 * APOSTROF 06460000 * POINTLST 06480000 * THE ADDRESSES ARE PICKED UP WITH DISPLACEMENTS FROM 06500000 * TESTTABL 06520000 * ARTABLE 06540000 * PTTABLE 06560000 * ATABLE 06580000 * PTTABLE FOR POINTLST 56 IS ADDED TO DISP GIVEN 06600000 SPACE 2 06620000 DS 0F 06640000 BPRTAB DS 0CL140 06660000 DC 4X'00' 06680000 DC A(TRANSOP) 06700000 DC A(TRANSOP) 06720000 DC A(TRANSOP) 06740000 DC A(TRANSOP) 06760000 DC A(TRANSOP) 06780000 DC A(TRANSOP) 06800000 DC A(COLON) COLON 06820000 DC A(SEMCO) SEMICOLON 06840000 DC A(RIGHTPAR) 06860000 DC A(BLANK) 06880000 DC A(ERR1) 06900000 DC A(POINT) 06920000 DC A(APOSTROF) 06940000 DC A(CIB) 06960000 DC A(ASSIGN) 06980000 DC A(DECPOINT) 07000000 DC A(ERR5) ERROR AFTER POINT 07020000 DC A(BLKAPOS) BLANK AFTER APOSTROPHE 07040000 DC A(NPAFTAPO) NOT PERMITTED AFTER APOSTR 07060000 DC A(SCALE) DIGIT OR SIGN AFTER APOSTROPHE 07080000 DC A(COLONLST) COLON IN LIST 07100000 DC A(SEMCLST) SEMICOLON IN LIST 07120000 DC A(DELIMIT) DELIMITER PROGRAM 07140000 DC A(ZETAAPO) ZETA AFTER APOSTROPHE 07160000 DC A(EROUT) ERROR (FROM W1,W2OR W3 TAB) 07180000 DC A(LEFTPARL) LEFT PARENTHESIS IN LIST 07200000 DC A(RIGTPARL) RIGHT PARENTHESIS IN LIST 07220000 DC A(PZETA) ZETA AFTER POINT IN LIST 07240000 DC A(ASSIGN) ASSIGNMENT POINT IN LIST 07260000 DC A(DECPOINT) DECPOINT IN LIST 07280000 DC A(ERR5A) POINT ERROR IN LIST 07300000 DC A(COMMALST) COMMA IN LIST 07320000 DC A(PONTLST) POINT IN LIST 07340000 DC A(SLASHLST) SLASH IN LIST 07360000 DC A(QUOTE) QUOTE 07380000 DC A(SEMC60) 07400000 SPACE 2 07420000 ***** TESTTABL ****************************************************** 07440000 * USED BY TEST - GIVES DISPLACEMENTS TO BPRTAB 07460000 SPACE 2 07480000 TESTTABL DS 0CL90 07500000 DC 2X'00' 07520000 DC X'0408' 07540000 DC 2X'00' 07560000 DC X'0C1C' 07580000 DC 3X'00' 07600000 DC X'90' 07620000 DC 4X'00' 07640000 DC X'001014' 07660000 DC 13X'00' 07680000 DC X'18' 07700000 DC 5X'00' 07720000 DC X'24' 07740000 DC 4X'00' 07760000 DC X'282C303438' 07780000 DC 42X'00' 07800000 SPACE 2 07820000 ***** RETRANS ****************************************************** 07840000 * CONVERT TABLE FOR INTERNAL CODE TO EBCDIC 07860000 * USED BY CODE TO TRANSLATE PROCEDURE NAME 07880000 * PROCEDURE TO TRANSLATE PROCEDURE NAME FOR 07900000 * ESD CARD IF PRECOMPILED SPECIFIED 07920000 SPACE 2 07940000 RETRANS DS 0CL90 07960000 DC C' ' 07980000 DC 47C'"' 08000000 DC C'0123456789' 08020000 DC 6C'"' 08040000 DC C'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 08060000 SPACE 2 08080000 ***** COMTABLE ****************************************************** 08100000 * USED BY COMMENT PROGRAM 08120000 * TESTS FOR POINT, SEMICOLON, ZETA AND APOSTROPHE 08140000 * GIVES DISPLACEMENT TO PROGRAMS FROM COMCEE2+2 08160000 COMTABLE DS 0CL90 08180000 DC 11X'00' 08200000 DC X'2A' 08220000 DC 33X'00' 08240000 DC X'220E1E' 08260000 DC 42X'00' 08280000 SPACE 2 08300000 ***** STRTABLE ****************************************************** 08320000 * USED BY STRING PROGRAM. SCANS FOR APOSTROPHE OR * 08340000 * ZETA 08360000 * GIVES DISPLACEMENTS TO BPRTAB 08380000 SPACE 2 08400000 STRTABLE DS 0CL90 TRT-TABLE USED BY STRING-PROGRAM 08420000 DC 46X'00' 08440000 DC X'8C38' 08460000 DC 42X'00' 08480000 SPACE 2 08500000 ***** BTABLE ****************************************************** 08520000 * BLANK TABLES - SCANNES FOR FIRST NONBLANK CHARACTER 08540000 * USED BY BLANK 08560000 * BLKAPOS BLANK AFTER APOSTROPHE 08580000 * READROUT IN TERMINATION 08600000 SPACE 2 08620000 BTABLE DS 0CL90 08640000 DC 4X'FF' 08660000 DC 2X'00' 08680000 DC 2X'FF' 08700000 DC 3X'00' 08720000 DC X'FF' 08740000 DC 4X'00' 08760000 DC 3X'FF' 08780000 DC 13X'00' 08800000 DC X'FF' 08820000 DC X'00' 08840000 DC 2X'FF' 08860000 DC X'00' 08880000 DC 2X'FF' 08900000 DC 5X'00' 08920000 DC 14X'FF' 08940000 DC 6X'00' 08960000 DC 26X'FF' 08980000 DS 0F 09000000 SPACE 2 09020000 ***** KEYTAB ****************************************************** 09040000 * USED BY TRANSOP 09060000 * BYTE 3 IS EXCPECTED BYTE, IF THAT ONE MATCHES CHAR. 09080000 * IN INPUT BYTE 1 IS PUT OUT OTHERWISE BYTE 2 09100000 * THE DISPLACEMENT FROM TESTTABL OR ATABLE IS USED * 09120000 * TO GET THE APPROPRIATE ENTRY IN KEYTAB 09140000 * USED WHEN * FOUND EXCPECTED * 09160000 * / ) 09180000 * ( / 09200000 * < LESS THAN = EQUAL 09220000 * > GREATER THAN = 09240000 * ª NOT = 09260000 SPACE 2 09280000 KEYTAB DS 0CL28 09300000 DS CL4 09320000 DC X'00050202' 09340000 DC X'00280326' 09360000 DC X'00080603' 09380000 DC X'00141110' 09400000 DC X'00151210' 09420000 DC X'00132010' 09440000 SPACE 2 09460000 ***** PTTABLE ****************************************************** 09480000 * USED BY POINT 09500000 * PONTLST 09520000 * GIVES DISPLACEMENTS TO BPRTAB 09540000 * WHEN USED BY PONTLST 56 IS ADDED TO ORIGINAL DISP. 09560000 SPACE 2 09580000 PTTABLE DS 0CL90 09600000 DC 4X'44' 09620000 DC 2X'00' 09640000 DC 2X'44' 09660000 DC 3X'00' 09680000 DC X'44' 09700000 DC 4X'00' 09720000 DC X'3C' 09740000 DC 2X'44' 09760000 DC 13X'00' 09780000 DC X'44' 09800000 DC X'00' 09820000 DC 2X'44' 09840000 DC X'00' 09860000 DC X'2044' 09880000 DC 5X'00' 09900000 DC X'441C4438' 09920000 DC 10X'40' 09940000 DC 6X'00' 09960000 DC 26X'44' 09980000 SPACE 2 10000000 ***** TRLTABLE ****************************************************** 10020000 * USED IN CIB TO TRANSLAT FROM EBCDIC TO INTERNAL 10040000 * CODE 10060000 SPACE 2 10080000 TRLTABLE DS 0CL256 10100000 DC 64X'2C' 10120000 DC X'2B' 10140000 DC 10X'2C' 10160000 DC X'2D1106002223' 10180000 DC 11X'2C' 10200000 DC X'02260B200103' 10220000 DC 9X'2C' 10240000 DC X'25' 10260000 DC 2X'2C' 10280000 DC X'12' 10300000 DC 11X'2C' 10320000 DC X'07' 10340000 DC 2X'2C' 10360000 DC X'2E10' 10380000 DC 66X'2C' 10400000 DC X'404142434445464748' 10420000 DC 7X'2C' 10440000 DC X'494A4B4C4D4E4F5051' 10460000 DC 8X'2C' 10480000 DC X'5253545556575859' 10500000 DC 6X'2C' 10520000 DC X'30313233343536373839' 10540000 DC 6X'2C' 10560000 SPACE 2 10580000 ***** KOPOOL ****************************************************** 10600000 * KEEPS THE CONSTANTS 0 THROUGH 15 10620000 * THE CONSTANS ARE USED WITHIN SCAN 1/2 FOR 10640000 * CALCULATION AND ARE THEN INSERTED AS 10660000 * THE FIRST 64 BYTES OF THE CONSTANT POOL 10680000 SPACE 2 10700000 KOPOOL DC F'0' 10720000 DC F'1' 10740000 DC F'2' 10760000 DC F'3' 10780000 DC F'4' 10800000 DC F'5' 10820000 DC F'6' 10840000 DC F'7' 10860000 DC F'8' 10880000 DC F'9' 10900000 DC F'10' 10920000 DC F'11' 10940000 DC F'12' 10960000 DC F'13' 10980000 DC F'14' 11000000 DC F'15' 11020000 SPACE 2 11040000 ***** ATABLE ****************************************************** 11060000 * USED BY THE APOSTROPHE PROGRAM 11080000 * GIVES DISPLACEMENTS TO BPRTAB 11100000 SPACE 2 11120000 ATABLE DS 0CL90 11140000 DC 2X'50' 11160000 DC X'64' 11180000 DC X'00' 11200000 DC 2X'00' 11220000 DC X'0064' 11240000 DC 3X'00' 11260000 DC X'64' SEMICOLON A32949 11280000 DC 4X'00' 11300000 DC 3X'64' 11320000 DC 13X'00' 11340000 DC X'64' 11360000 DC X'00' 11380000 DC 2X'64' 11400000 DC X'00' 11420000 DC 2X'64' 11440000 DC 4X'00' 11460000 DC X'484C645C60' 11480000 DC 10X'50' 11500000 DC 32X'00' 11520000 SPACE 2 11540000 ***** CONSTANTS **************************************************** 11560000 TWOFIVEK DC F'25000' 11580000 TWOK DC F'2000' 11600000 FOURK DC F'4095' 11620000 FOURKA DC H'4096' 11640000 DOUBLE DC D'0' 11660000 D256 DC F'256' 11680000 INT DC X'2EC8030000' COMMON PART OF THE INTERNAL 11700000 * NAMES OF BOOLEAN CONSTANTS 11720000 ENDCOUNT DC H'0' 11740000 ERRSAVE DS 4F 11760000 SAVAR EQU ERRSAVE 11780000 VIEX1 DC A(IEX11001) 11800000 VIEX2 DC A(IEX11002) 11820000 VIEX14 DC V(IEX11003) 11840000 ESDPARAM DC 8C' ' 11860000 HDING1 DC C'SOURCE PROGRAM' 11880000 HDING2 DC C' SC SOURCE STATEMENT' 11900000 OPINCHAR DC C'0' 11920000 BRACKET DS F BRACKET COUNTER A28251 11930019 SPACE 2 11940000 SPACE 2 11960000 ***** MAINLOOP ****************************************************** 11980000 * 12000000 * SCANS THE INPUT STREAM 12020000 * EVERYTHING PRECEDING THE FIRST REAL ALGOL WORD WILL BE 12040000 * SKIPED WITH THE HELP OF BITS2,X'20' 12060000 SPACE 2 12080000 TESTLOOP BALR RET,0 12100000 LR REGIX,RET RETURNADDRESS FOR CIBPROGRAM 12120000 LR REGM,REGI 12140000 SR REGZ,REGZ 12160000 TRT 0(73,REGI),TESTTABL 12180000 TM BITS2,X'20' Q. FIRST BEGIN FOUND 12200000 BZ FIRSTSTR NO 12220000 CONT LR REGH,REGI FIND LENGTH OF SCANNED BYTES 12240000 SR REGH,REGM 12260000 BZ SUBROUT 12280000 BAL REGOX,COB 12300000 LA REG0,0(REGH,EAP) 12320000 C REG0,APE Q. SPACE LEFT IN O/P BUFFER 12340000 BH MSBLOOP 12360000 BCTR REGH,0 12380000 EX REGH,MOVE MOVE SCANNED BYTES 12400000 LR EAP,REG0 INCREASE OUTPUTPOINTER 12420000 SUBROUT L REGB,BPRTAB(REGZ) 12440000 BCR 15,REGB BRANCH TO PROGRAM 12460000 * MSBLOOP- USED WHEN SCANNED BYTES HAS 12480000 * TO BE PLACED IN TWO O/P AREAS 12500000 MSBLOOP L REGB,APE 12520000 SR REGB,EAP 12540000 BCTR REGB,0 12560000 EX REGB,MOVE MOVE TO FIRST O/P AREA 12580000 LA EAP,1(REGB,EAP) 12600000 BAL REGOX,COB+8 CHANGE O/P BUFFER 12620000 LA REGOX,1(REGB,REGM) 12640000 SR REGH,REGB 12660000 BCTR REGH,0 12680000 BCTR REGH,0 12700000 EX REGH,MOVERST MOVE TO 2ND O/P BUFFER 12720000 LA EAP,1(REGH,EAP) 12740000 B SUBROUT RETURN 12760000 CNOP 0,4 12780000 MOVERST MVC 0(1,EAP),0(REGOX) 12800000 FIRSTSTR CLI 0(REGI),X'2E' Q APOSTROPHY 12820000 BE APOSTROF 12840000 CLI 0(REGI),X'2F' Q. ZETA 12860000 BE CIB 12880000 LA REGI,1(0,REGI) IF NEITHER- CONTINUE SCANNING 12900000 B TESTLOOP 12920000 SPACE 2 12940000 ***** BLANK ****************************************************** 12960000 * SCANS TO THE NEXT NONBLANK CHARACTER 12980000 * ALL BLANK CHARACTER WILL BE SKIPPED 13000000 * USED BY MAIN LOOP AND ARRAYLIST 13020000 SPACE 2 13040000 BLANK LA REGI,1(0,REGI) INCREASE INPUTPOINTER 13060000 CLI 0(REGI),X'2B' COMPARE BLANK 13080000 BCR 7,RET IF NO , RETURN 13100000 LA REGI,1(0,REGI) IF YES, INCREASE INPUTPOINTER 13120000 SR REGZ,REGZ 13140000 TRT 0(73,REGI),BTABLE SCAN INPUT TO NEXT DELIMITER 13160000 BCR 15,RET RETURN 13180000 SPACE 2 13200000 ***** TRANSOP ****************************************************** 13220000 * 13240000 * CHECKS THE NEXT BYTE IN THE INPUT INPUTAREA AGAINS A KEY 13260000 * I.E. IF ( FOUND, NEXT BYTE WILL BE CHECKED FOR /, IF A 13280000 * SLASH IS FOUND A LEFT SQUARE BRACKET WILL BE TRANSFERED 13300000 * OTHERWISE A ( 13320000 * USED BY MAIN LOOP AND ARRAYLIST 13340000 SPACE 2 13360000 TRANSOP LA KEY,KEYTAB(REGZ) GET CORRECT ENTRY IN TABLE 13380000 CNOP 0,4 13400000 INCR LA REGI,1(0,REGI) 13420000 CLC 0(1,REGI),3(KEY) Q. INPUT EQUAL EXPECTED ONE 13440000 BE TROE YES TAKE SUBSTITUTE CHAR. 13460000 CLI 0(REGI),X'2B' Q. BLANK 13480000 BE INCR 13500000 CLI 0(REGI),X'2F' Q. ZETA 13520000 BNE TRONE IF NEITHER TAKE CHAR. IN I/P 13540000 LA REGIX,INCR+4 13560000 BC 15,CIB 13580000 TRONE BAL REGOX,COB CHECK IF O/P AREA FILLED 13600000 MVC 0(1,EAP),2(KEY) TAKE CHAR FOUND IN INPUT 13620000 LA EAP,1(0,EAP) 13640000 BCR 15,RET RETURN 13660000 TROE BAL REGOX,COB CHECK IF O/P AREA FILLED 13680000 MVC 0(1,EAP),1(KEY) TAKE SUBSTITUE CHAR FROM TABLE 13700000 L REGOX,BRACKET A28251 13702019 TM 0(EAP),X'28' IS IT RIGHT BRACKET A28251 13704019 BC 14,TSTMORE NO A28251 13706019 BCTR REGOX,0 YES SUBTRACT 1 FROM CTR A28251 13708019 BC 15,NOUPDAT A28251 13710019 TSTMORE TM 0(EAP),X'08' IS IT LEFT BRACKET A28251 13712019 BC 14,NOUPDAT NO A28251 13714019 LA REGOX,1(REGOX) YES ADD 1 TO CTR A28251 13716019 NOUPDAT ST REGOX,BRACKET A28251 13718019 LA EAP,1(0,EAP) 13720000 LA REGI,1(0,REGI) 13740000 BCR 15,RET RETURN 13760000 SPACE 2 13780000 ***** RIGHTPAR ****************************************************** 13800000 * INSERTS A ) IN O/P, SETS THE LABEL POINTERS 13820000 SPACE 2 13840000 RIGHTPAR BAL REGOX,COB CHECK IF O/P AREA FILLED 13860000 MVI 0(EAP),X'26' TRANSFER ) TO OUTPUTBUFFER 13880000 ST EAP,OPIN NOTE ITS POSITION 13900000 MVI OPINCHAR,X'26' 13920000 MVC OPIN+4(1),ONC AND THE OUTPUTRECORDNUMBER 13940000 LA EAP,1(0,EAP) 13960000 ST EAP,LAPIN NOTE POSITION WHERE LETTERSTRING 13980000 LA REGI,1(0,REGI) MAY START 14000000 B TESTLOOP 14020000 SPACE 2 14040000 ***** POINT ****************************************************** 14060000 * SCANS FOR : DECPOINT 14080000 * ERROR 14100000 * COLON 14120000 * SEMICOLON 14140000 * ASSIGN 14160000 * USED BY MAIN LOOP AND ARRAYLIST 14180000 SPACE 2 14200000 POINT LA REGI,1(0,REGI) SCAN SOURCESTRING 14220000 CNOP 0,4 14240000 LA REGIX,* RETURNADDRESS FOR CIBPROGRAM 14260000 SR REGZ,REGZ 14280000 TRT 0(73,REGI),PTTABLE TO NEXT DELIMITER 14300000 L REGB,BPRTAB(REGZ) BRANCH TO SUITABLE 14320000 BCR 15,REGB SUBROUTINE 14340000 SPACE 2 14360000 ***** DECPOINT ****************************************************** 14380000 * TRANSFERS A DECIMAL POINT 14400000 SPACE 2 14420000 DECPOINT BAL REGOX,COB CHECK IF O/P AREA FILLED 14440000 MVI 0(EAP),X'3E' TRANSFER DECIMALPOINT 14460000 LA EAP,1(0,EAP) 14480000 BCR 15,RET 14500000 SPACE 2 14520000 ***** ASSIGN ****************************************************** 14540000 * TRANSFERS A ASSIGN CHAR TO O/P. RETURNS VIA STATEMENT 14560000 SPACE 2 14580000 ASSIGN BAL REGOX,COB CHECK IF O/P AREA FILLED 14600000 MVI 0(EAP),X'16' TRANSFER .= TO OUTPUTBUFFER 14620000 LA REGI,1(0,REGI) INCREASE INPUT- AND 14640000 LA EAP,1(0,EAP) OUTPUTPOINTER 14660000 BC 15,STATE BRANCH TO STATEMENT PROGRAM 14680000 SPACE 2 14700000 ***** STATE ****************************************************** 14720000 * 14740000 * CHECKS WITH PROBIT IF FIRST LABEL, FOR, IF, GOTO 14760000 * OR ASSIGN STATMENT AFTER A PROCEDURE 14780000 * CHECKS THAT ALL PARAMETERS HAVE BEEN SPECIFIED 14800000 * TURNS OFF THE PROBIT 14820000 * AND THE BEGBIT, POSSIBLE PROCEEDING BEGIN WILL BE 14840000 * COMPOOND BEGIN 14860000 SPACE 2 14880000 STATE NI BITS1,X'7F' BEGBIT = 0 14900000 L REGY,SP 14920000 CLI 0(REGY),X'0C' Q. PROC IN STACK 14940000 BCR 7,RET IF NO.RETURN 14960000 MVI 0(REGY),X'14' 14980000 NI BITS1,X'BF' PROBIT.=0 15000000 CLI PZ,X'00' Q. ALL PARAMETERS SPECIFIED 15020000 BCR 8,RET YES RETURN 15040000 BAL REGOX,ERROR10 NO- GENERATE E10 15060000 BCR 15,RET RETURN 15080000 SPACE 2 15100000 ***** APOSTROF ****************************************************** 15120000 * SCANS FOR : SCALE 15140000 * BLANK 15160000 * ZETA 15180000 * NOT PERMITTED 15200000 * ONE MORE APOSTROPHE (DELIMITER) 15220000 * REGM WILL POINT TO THE APOSTROPHE 15240000 * USED BY TESTLOOP AND LIST 15260000 SPACE 2 15280000 APOSTROF MVI FBYTE,X'00' ZEROSET FBYTE 15300000 ENTRAPR LR REGM,REGI REGM WILL POINT TO FIRST APOSTROPHE 15320000 LA REGI,1(0,REGI) 15340000 BALR REGIX,0 15360000 SR REGZ,REGZ 15380000 TRT 0(73,REGI),ATABLE SOURCESTRING IS SCANNED TO THE NEXT 15400000 L REGB,BPRTAB(REGZ) SIGNIFICANT DELIMITER AND THE 15420000 BCR 15,REGB SUITABLE SUBROUTINE SELECTED 15440000 SPACE 2 15460000 ***** SCALE ****************************************************** 15480000 * CORRECT ONLY DIRECT AFTER TESTLOOP OR LIST 15500000 * CHECK THAT THE APOSTROPHE IS ONLY ONE CHAR. IN FRONT 15520000 * OF DIGIT 15540000 SPACE 2 15560000 SCALE TM FBYTE,X'FF' 15580000 BO COMCEE2 COMMENT UNDER PROCESS 15600000 BM TYPESPEC DECLARATION UNDER PROCESS 15620000 SCALEOK LR REGB,REGI 15640000 TM BITS2,X'20' Q. PROGRAM STARTED YET 15660000 BZ TESTLOOP NO - RETURN 15680000 BCTR REGB,0 15700000 CLI 0(REGB),X'2E' Q APOSTOF ONE BYTE BEFORE SIGN OR DIGIT 15720000 BNE EROUT IF NO,BRANCH TO ERROR-ROUTINE 15740000 BAL REGOX,COB CHECK IF O/P AREA FILLED 15760000 MOVETEN MVI 0(EAP),X'3F' MOVE SCALEFACTOR TO OUTPUT RECORD 15780000 LA EAP,1(0,EAP) INCREASE OUTPUT- AND 15800000 BCR 15,RET RETURN 15820000 SPACE 2 15840000 ***** BLKAPOS ****************************************************** 15860000 * SHIFT THE BLANK OR BLANKS AWAY AND MOVES THE 15880000 * APOSTROPHE AND VALID CHARACTERS UP TO THE RIGHT 15900000 * SETS REGM TO POINT NEW LOCATION OF THE 15920000 * APOSTROPHE 15940000 * USED BY MAINLOOP AND INDIRECT BY THE ARRYLIST 15960000 * AND THE NPAFTAPO 15980000 SPACE 2 16000000 BLKAPOS LR REGH,REGI NOTE POSITION OF FIRST BLANK. 16020000 TRT 0(73,REGI),BTABLE 16040000 LR REGB,REGI COMPUTE NUMBER OF BLANKS . 16060000 SR REGB,REGH NUMBER OF BLANKS IN REGB . 16080000 LR REGL,REGH 16100000 SR REGL,REGM 16120000 C REGL,KOPOOL+44 Q BYTES EXEED THE LIMIT ALLREADY 16140000 BH EROUT 16160000 BCTR REGL,0 NUMBER OF BYTES TO BE SHIFTED 16180000 LA REGH,0(REGB,REGM) COMPUTE NEW POSITION OF APOSTPOPHE, 16200000 EX REGL,MAPOS MOVE APOSTROPHE AND SCANNED CHARACTERS 16220000 EX REGL,MAPOS2 16240000 LR REGM,REGH NOTE NEW POSITION OF APOSTROPHE . 16260000 BCR 15,REGIX RETURN 16280000 CNOP 0,4 16300000 MAPOS MVC BUCKET(1),0(REGM) 16320000 CNOP 0,4 16340000 MAPOS2 MVC 0(1,REGH),BUCKET 16360000 BUCKET DC 11X'00' 16380000 SPACE 2 16400000 ***** ZETAAPO ****************************************************** 16420000 * MOVES SCANED BYTES AND APOSTROPHE IN FRONT OF WA 16440000 * AND PUTS REGM TO NEW START LOCATION 16460000 * OF POSSIBLE DELIMITER 16480000 * USED BY MAINLOOP AND ARRAYLIST 16500000 SPACE 2 16520000 ZETAAPO LR REGY,REGM COMPUTE 16540000 LR REGL,REGI NR OF SCANNED 16560000 SR REGL,REGM BYTES 16580000 C REGL,KOPOOL+44 Q EXEED LIMIT 16600000 BH EROUT YES 16620000 LA REGM,WA NO- CALCULATE WHERE TO MOVE 16640000 SR REGM,REGL CHAR. STRING 16660000 BCTR REGL,0 16680000 EX REGL,MOVBEFWA MOVE CHAR IN FRONT OF WA 16700000 B CIB CHANGE INPUT BUFFER 16720000 CNOP 0,4 16740000 MOVBEFWA MVC 0(1,REGM),0(REGY) 16760000 SPACE 2 16780000 ***** NPAFAPO ****************************************************** 16800000 * GIVES ERROR MESSAGE AND UTILIZES BLANKAPO TO SHIFT 16820000 * THE INVALID CHARACTER AWAY 16840000 * USED BY MAINLOOP AND ARRAYLIST 16860000 SPACE 2 16880000 NPAFTAPO TM FBYTE,X'FF' 16900000 BM TYPESPEC INVALID IDENTIFIER 16920000 BO COMCED2 COMMENT UNDER PROCESS 16940000 TM BITS2,X'20' Q. PROGRAM STARTED YET 16960000 BZ *+10 NO 16980000 BAL REGB,ERR7 17000000 DC X'0401' E1 17020000 LR REGH,REGI 17040000 LA REGI,1(0,REGI) GO TO BLKAPOS TO SHIFT AWAY 17060000 B BLKAPOS+2 INVALID CHARACTER 17080000 SPACE 2 17100000 ***** COLON ****************************************************** 17120000 * ENTERD FROM MAINLOOP OR POINT 17140000 * CHECKS FOR := ASSIGN 17160000 * :( DELIMITER 17180000 * LABEL 17200000 SPACE 2 17220000 COLON LR REGB,REGI STORE PRECEEDING 6 CHARACTERS 17240000 S REGB,KOPOOL+24 TO BE USED ONLY IF INCORRECT 17260000 MVC BUCKET(6),0(REGB) USE OF COLON E3 17280000 COLON2 LA REGI,1(0,REGI) 17300000 EQUAL CLI 0(REGI),X'10' IF COLON IS FOLLOWED BY EQUALSIGN 17320000 BE ASSIGN BRANCH TO ASSIGN-PROGRAM 17340000 CLI 0(REGI),X'06' IF COLON IS FOLLOWED BY LEFT PAREN- 17360000 BE LETDEL THESIS,BRANCH TO DELIMITERPROCESSING 17380000 CLI 0(REGI),X'2B' IF COLON IS FOLLOWED BY BLANK 17400000 BE COLON2 REPEAT SEARCH 17420000 CLI 0(REGI),X'2F' IF COLON IS FOLLOWED BY ZETA 17440000 BNE *+12 17460000 LA REGIX,EQUAL PROVIDE RETURNADDRESS AND 17480000 BC 15,CIB CHANGE INPUTBUFFER 17500000 SPACE 2 17520000 ***** LABEL ****************************************************** 17540000 * OPIN POINTS TO LAST OPERATOR WHICH MIGHT BE * 17560000 * FOLLOWED BY A LABEL. * 17580000 * PIN IS THE POINTER, STEPPING UP BETWEEN LAPIN AND 17600000 * THE COLON WHICH EAP POINTS TO 17620000 * OPIN+4 CONTAINS THE O/P REC. NUMBER WHEN OPIN 17640000 * WAS SET 17660000 * LABEL IS CHECKED FOR VALIDITY. THE FIRST 6 CHAR. 17680000 * ARE MOVED TO OUTPUT AND ITAB. * 17700000 * CHECKS IF THE LABEL IS SPLIT OVER MORE THAN 17720000 * ONE O/P BUFFER 17740000 * IF THE LABEL IS SPLIT BY ONE O/P BUFFER END THE 17760000 * HANDLING IS THE SAME AS IF NOT EXEPT THAT WHEN 17780000 * ZETA- RECORD END - IS FOUND PIN IS UPDATED TO 17800000 * THE FIRST CHARACTER OF THE CURRENT O/P REC. * 17820000 * E3 IF THERE IS NO LABEL 17840000 * E6 IF LABEL LONGER THAN 1024 BYTES 17860000 * E7 IF LABEL CONTAINS INVALID CHARACTER 17880000 * E8 IF LABEL STARTS WITH INVALID CHAR. 17900000 SPACE 2 17920000 CLC ONC(1),OPIN+4 Q. LABEL EXCEEDS ONE O/P REC. 17940000 BE LABEL NO 17960000 SR REGM,REGM 17980000 IC REGM,OPIN+4 18000000 LA REGM,1(0,REGM) 18020000 IC REGZ,ONC 18040000 CR REGZ,REGM Q. LABEL EXCEEDS 2 O/P REC. 18060000 BE *+10 NO 18080000 BAL REGB,ERR4 18100000 DC X'0406' E6 TERMINATING ERROR 18120000 LABEL L PIN,LAPIN 18140000 CR EAP,PIN IS THERE ANY IDENTIFIER 18160000 BE ERROR3 E3 COLON DELETED 18180000 CLI OPINCHAR,X'26' Q LABEL PROCEEDED BY RIGHT 18200000 BE ERROR3 PARENTHESIS IF YES E3 IS GIVEN 18220000 LABNAME CLI 0(PIN),X'40' Q. FIRST CHAR. IS LETTER 18240000 BL LABNAMER 18260000 L IN,AITL 18280000 MVC 0(1,IN),0(PIN) MOVE CONTENTS OF PIN TO ITAB 18300000 LA IN,1(0,IN) INCREABE IN 18320000 LA K,1 INITILIZE K WITH 1 18340000 LABID LA PIN,1(0,PIN) GET NEXT CHAR. 18360000 CR PIN,EAP Q(PIN=EAP 18380000 BE LABEND 18400000 LABCHECK CLI 0(PIN),X'2F' Q. LETTER, DIGIT 18420000 * OR ZETA 18440000 BNE *+12 18460000 L PIN,WADDARI GET START OF CURRENT O/P AREA 18480000 B LABCHECK 18500000 BL ERROR7 18520000 C K,KOPOOL+24 Q. K=6 18540000 BE LABID YES- DON'T MOVE MORE CHAR. TO 18560000 * ITAB 18580000 MVC 0(1,IN),0(PIN) MOVE CONTENT OF PINTOIN 18600000 LA IN,1(0,IN) INCREASE IN ANO PIN 18620000 LA K,1(0,K) AND K 18640000 B LABID 18660000 LABNAMER CLI 0(PIN),X'2F' Q. ZETA OR DIGIT 18680000 BNE *+12 18700000 L PIN,WADDARI UPDATE PIN TO CURRENT O/P BUFFER 18720000 B LABNAME 18740000 CLI 0(PIN),X'2B' Q. BLANK 18760000 BE LABNAME 18780000 BAL REGB,ERR7 18800000 DC X'0408' E8 18820000 B ERROR7+6 18840000 ERROR7 BAL REGB,ERR2 18860000 DC X'0007' E7 INCORRECT LABEL 18880000 L REGY,AITL 18900000 BAL REGOX,ITABCLEA+8 CLEAR THE ITAB ENTRY 18920000 BCR 15,RET 18940000 SPACE 2 18960000 ********LABEND ****************************************************** 18980000 * IF (LABEL:LABELX) THE LN (LABEL NUMBER) 19000000 * WILL ONLY BE INCREASE ONCE 19020000 * INTERNAL NAME IS CREATED AND LN INSERTED 19040000 * X'27' IS MOVED TO THE O/P TO INDICATE LABEL 19060000 * OPIN, OPIN+4 AND LAPIN ARE UPDATED 19080000 * ITABCLEA IS ACTIVATED TO PREPARE NEXT ITABENTRY 19100000 SPACE 2 19120000 LABEND CLI OPINCHAR,X'27' +. LABEL PRECEEDED BY LABEL 19140000 BE LABLAHEI YES- DO NOT UPDATE LN 19160000 LH REGY,LN LN=LN+4 19180000 LA REGY,4(0,REGY) 19200000 LABCREAT CLC LN(2),FOURKA Q. LN= 2**12 19220000 BL *+14 19240000 BAL REGB,ERR7 19260000 DC X'04D8' E216 19280000 LA REGY,LATBEG RESET LN 19300000 STH REGY,LN 19320000 LABLAHEI L REGY,AITL 19340000 MVI 6(REGY),X'CC' CREATE INTERNAL NAME 19360000 MVI 7(REGY),X'08' 19380000 L REGL,LPBP 19400000 MVC 8(1,REGY),10(REGL) PROGRAMMBLOCKNR AITL + 7 19420000 MVC 9(2,REGY),LN LN IN AITL+9 19440000 BAL REGOX,COB CHECK IF O/P AREA FILLED 19460000 MVI 0(EAP),X'27' MOVE LABEL IND. TO O/P 19480000 ST EAP,OPIN SET LABEL POINTERS 19500000 MVI OPINCHAR,X'27' 19520000 MVC OPIN+4(1),ONC 19540000 LA EAP,1(0,EAP) 19560000 ST EAP,LAPIN 19580000 BAL REG12,ITABCLEA CHECK AND CLEAR NEXT ITABENTRY 19600000 B STATE RETURN VIA STATEMENT PCM 19620000 SPACE 2 19640000 ***** LETDEL ****************************************************** 19660000 * :( HAS BEEN FOUND IN THE I/P 19680000 * IF OPIN POINTS TO A RIGHT PARENTHESIS IT SHOULD BE 19700000 * LETTER DELIMITER, WHITCH SHOULD BE REMOVED AND 19720000 * REPLACED BY A COMMA 19740000 * IT IS CHECKED THAT ALL CHARACTERS ARE LETTERS 19760000 * OTHERWISE E3 IS GIVEN 19780000 SPACE 2 19800000 LETDEL CLI OPINCHAR,X'26' Q. OPIN POINTS TO A RIGHT PAREN 19820000 BNE ERROR3 NO- E3- COLON DELETED 19840000 CLC ONC(1),OPIN+4 Q LETDEL EXCEEDS ONE O/P REC 19860000 BNE LETDELB2 YES 19880000 L PIN,OPIN 19900000 LA REGB,1(0,PIN) 19920000 CR REGB,EAP Q. AT LEAST ONE CHAR. 19940000 BE ERROR3 NO- E3 DELETE COLON 19960000 LETDELE1 LA PIN,1(0,PIN) OTHER CHAR. THAN 19980000 CLI 0(PIN),X'39' LETTERS 20000000 BNH ERROR3 20020000 LA REGB,1(0,PIN) 20040000 CR REGB,EAP Q. ALL CHAR. CHECKED 20060000 BNE LETDELE1 NO- CHECK NEXT 20080000 L EAP,OPIN SET O/P POINTER TO BEGINING OF 20100000 MVI 0(EAP),X'25' THE STRING,MOVE IN A COMMA 20120000 LA EAP,1(0,EAP) 20140000 LA REGI,1(0,REGI) GET NEXT CHAR. 20160000 BCR 15,RET 20180000 * DELIMITER EXCEEDS ONE O/P RECORD 20200000 LETDELB2 SR REGB,REGB Q. DOES THE STRING 20220000 IC REGB,OPIN+4 Q. EXCEED 2 O/P RECORDS 20240000 LA REGB,1(0,REGB) 20260000 IC REGZ,ONC 20280000 CR REGB,REGZ 20300000 BE *+10 NO 20320000 BAL REGB,ERR4 20340000 DC X'0404' E4 GOES TO COMPFIN 20360000 L PIN,OPIN MAKE PIN POINT TO LETTER DEL. 20380000 LETDELB3 LA PIN,1(0,PIN) 20400000 CLI 0(PIN),X'40' Q LETTER 20420000 BNL *-8 YES 20440000 CLI 0(PIN),X'2F' NO-Q ZETA 20460000 BNE ERROR3 20480000 L PIN,WADDARI CHANGE BACK SO PIN POINT TO CURR.O/P 20500000 LETDELF4 CLI 0(PIN),X'40' Q LETTER 20520000 BL ERROR3 E3 DELETE COLON 20540000 LA PIN,1(0,PIN) SKIP ALL LETTERS 20560000 CR PIN,EAP UNTIL END OF DELIMITERS 20580000 BNE LETDELF4 20600000 L EAP,WADDARI LOAD ADD. OF CURRENT O/P REC 20620000 MVI 0(EAP),X'3D' MOVE IN $ RHO 20640000 LA EAP,1(0,EAP) 20660000 LA REGI,1(0,REGI) GET NEXT CHAR 20680000 BCR 15,RET 20700000 SPACE 2 20720000 ***** SEMCO ****************************************************** 20740000 * IF THE DELTA BIT IS ON, THE DELTA AND SEMICOLON 20760000 * COUNTER (SC) IS MOVED TO THE OUTPUT 20780000 * IF THE DELTABIT IS OFF THE STACK IS INSPECTED 20800000 * BEGIN, BETA OR PROC* - A SEMICOLON AND THE SC 20820000 * IS MOVED TO THE O/P AND PROCESSING IS 20840000 * CONTINUES VIA TEST 20860000 * FOR - THE FORSTATMENT IS COMPLETE, THE FOREND 20880000 * PROGRAM IS ACTIUATED 20900000 * THE RETURN IS TO STACKTST TO SEE IF ONE 20920000 * MORE FOR STATEMENT OR A PROC** HAS ENDED 20940000 * AT THE SAME TIME 20960000 * PROC - A PROCEDURE CONSISTING OF ONLY ONE 20980000 * STATMENT OR A DOMMY STATMENT HAS ENDED 21000000 * IT IS CHECKED THAT ALL PARAMETERS HAVE 21020000 * BEEN SPECIFIED, AND THE PROC** PGM IS 21040000 * JOINED 21060000 * PROC** - A PROCEDURE CONSISTING OF ONE LABELED 21080000 * STATEMENT OR ONE FOR, IF, GOTO OR ASSIGN 21100000 * STATEMENT HAS ENDED 21120000 * THE PROGRAM BLOCKEND PROGRAM IS ACTIVATED 21140000 * AND A DELTA AND THE SC IS MOVED OUT 21160000 * THE FINAL EXIT IS IN ALL CASES TO TEST 21180000 SPACE 2 21200000 SEMC60 OI HCOMPMOD+2,SET60 SET SWITCH FOR 60 CHAR. SET 21220000 SEMCO LH REGM,SC 21240000 C REGM,SCOVFL TEST SC OVERFLOW 21260000 BL SEMCO01 21280000 BAL REGB,ERR7 21300000 DC X'0411' E17 21320000 MVC SC(2),KOPOOL RESET SC COUNTER TO ZERO 21340000 SEMCO01 LA REGM,1(0,REGM) INCREASE SC 21360000 STH REGM,SC 21380000 LA REG0,3(0,EAP) PROVIDE 3 BYTES IN OUTPUTBUFFER 21400000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 21420000 NI BITS3,FMOFF 21440000 TM BITS1,X'20' TEST DELTABIT 21460000 BO DELTA IF 1 BRANCH TO DELTATRANSFER 21480000 LA REGE,STACKTST RETURN REGISTER ( FOREND, PBLCKEND ) 21500000 L REGY,SP SELECT 21520000 IC REGZ,0(0,REGY) BRANCH 21540000 L REGB,PROG2(REGZ) ADDRESS 21560000 BCR 15,REGB DEPENDING ON WHAT IS IN STACK 21580000 DS 0F 21600000 PROG2 DC A(ERR8) SHOULD NOT OCCUR, TOPBYTE IS ALPHA 21620000 DC A(SCTRANS) BETA 21640000 DC A(SCTRANS) BEGIN 21660000 DC A(SEMPROC) PROC 21680000 DC A(SCTRANS) PROC* 21700000 DC A(SEMPROC2) PROC** 21720000 DC A(FOREND) FOR 21740000 DELTA NI BITS1,X'DF' DELTA BIT= 0 21760000 MVI 0(EAP),X'29' TRANSFER DELTA 21780000 BC 15,SCTRANS+4 21800000 SCTRANS MVI 0(EAP),X'0B' TRANSFER SEMICOLON 21820000 MVI OPINCHAR,X'0B' 21840000 ST EAP,OPIN NOTE POSITION OF SEMICOLON IN OPIN 21860000 MVC OPIN+4(1),ONC AND O/P NO 21880000 MVC 1(2,EAP),SC TRANSFER SEMICOLONCOUNTER 21900000 LA EAP,3(0,EAP) INCREASE OUTPUTPOINTER 21920000 ST EAP,LAPIN 21940000 NI BITS1,X'7F' BEGBIT.=0 21960000 LA REGI,1(0,REGI) INCREASE INPUTPOINTER 21980000 B TESTLOOP 22000000 SCOVFL DC F'65535' (2**16)-1 22020000 SEMPROC NI BITS1,X'BF' PROBIT.=0 22040000 CLI PZ,X'00' ALL PARAMETERS SPECIFIED 22060000 BE *+8 22080000 BAL REGOX,ERROR10 22100000 SEMPROC2 BAL REGE,PBLCKEND 22120000 LA REG0,3(0,EAP) PROVIDE 3 BYTES IN OUTPUTBUFFER 22140000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 22160000 MVI 0(EAP),X'29' TRANSFER DELTA 22180000 BC 15,SCTRANS+4 22200000 STACKTST CLI 0(REGY),X'14' 22220000 BE SEMPROC2 PROC** 22240000 BH FOREND FOR 22260000 LA REG0,3(0,EAP) 22280000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 22300000 B SCTRANS 22320000 SPACE 2 22340000 SPACE 2 22360000 ***** ERROR ROUTINE ************************************************ 22380000 * GENERATES ERROR PATTERNS 22400000 * MAINLY CLOSED SUBROUTINES, ENTERED WITH BAL REGB 22420000 * FOLLOWED BY TWO BYTES. FIRST BYTE SPECIFIES 22440000 * THE LENGTH, IF KNOW AND SECOND BYTE ERROR 22460000 * NUMBER 22480000 * USES ERROR1 TO CHECK FOR ERRORPOL OVERFLOW AND 22500000 * TO INSERT NUMBER, LENGTH AND SC 22520000 SPACE 2 22540000 ***** ERR0 ****************************************************** 22560000 * GENERATES E212 PATTERN 22580000 * EXITS TO COMFIN 22600000 SPACE 2 22620000 ERR0 MVI 0(REGY),X'02' 22640000 MVI 1(REGY),X'D4' E212 22660000 LA REGY,2(0,REGY) 22680000 ST REGY,NEXTERR 22700000 B COMPFIN 22720000 SPACE 2 22740000 ***** ERR1 ****************************************************** 22760000 * E1 22780000 * ACTIVATES ERR7, SKIPPS INVALID CHARACTER AND 22800000 * RETURNS TO EITHER TESTLOOP OR LIST 22820000 * ENTERED VIA BPRTAB WHEN USED BY TESTLOOP OR 22840000 * LIST 22860000 * INVALID CHARACTER FOLLOWING AN APOSTROPHE IS 22880000 * TREATED SPECIALLY IN NPAFTAPO 22900000 SPACE 2 22920000 ERR1 BAL REGB,ERR7 NOT PERMITTED CHARACTER 22940000 DC X'0401' E1 22960000 LA REGI,1(0,REGI) 22980000 BCR 15,RET RETURN TO TEST OR TRATE 23000000 SPACE 2 23020000 ***** ERR2 ****************************************************** 23040000 * ERR2 7, 16, 31, 32, 33, 34 23060000 * ENTERED ERROR7, IER, ARRAYERR, SWITCHERR 23080000 * SLASHERR, SEMCLST, SEMCLER, ARRYSLSH 23100000 * SLASHLST, PNAMERR 23120000 * NAME TAKE FROM AITL 23140000 * ERR2B 10, 36, 37 23160000 * ERROR10, PROCFIN, ERROP37 23180000 * NAME TAKEN FROM LPBP-11 23200000 * ERR2C 14 23220000 * EROUT 23240000 * DELIMITER TAKEN FROM BUCKET 23260000 * ERR2E 16, 26, 27, 30 23280000 * IDVALCHK, VALDLB2, IDSELSE, NOTFOUND 23300000 * NAME TAKEN FROM IDBUCKET 23320000 * ERR2D UTILISES ERROR2 TO FIND LENGTH 23340000 * ERROR1 TO CREATE MESSAGE 23360000 * MOVES IN INFORMATION 23380000 * RETURNS TO CALLING SEQUENCE 23400000 SPACE 2 23420000 ERR2 L IN,AITL NAME FROM AITL 23440000 B ERR2D 23460000 ERR2B L IN,LPBP NAME FRM LPBP-11 23480000 S IN,KOPOOL+44 23500000 B ERR2D 23520000 ERR2C MVC BUCKET(6),1(REGM) DELIMITER FROM BUCKET 23540000 LA IN,BUCKET 23560000 B ERR2D 23580000 ERR2E LA IN,IDBUCKET E26 NAME FROM IDBUCKET 23600000 ERR2D STM 12,15,ERRSAVE 23620000 BAL REG12,ERROR2 GET NAME AND LENGTHS 23640000 BAL REG12,ERROR1 CREATE ENTRY IN ERRPOOL 23660000 EX K,ERRMOVE MOVE THE NAME 23680000 LM 12,15,ERRSAVE 23700000 BC 15,2(0,REGB) 23720000 SPACE 2 23740000 ***** ERROR3 ****************************************************** 23760000 * GENERATES PATTERN FOR E3 23780000 * ENTERED FROM LABEL, COLONLST 23800000 * TAKES INFORMATION FROM BUCKET 23820000 SPACE 2 23840000 ERROR3 STM 12,15,ERRSAVE GET PARAMETER FIELD 23860000 LA REGB,PARAM3 23880000 BAL REG12,ERROR1 CREATE PATTERN 23900000 MVC 4(6,REGY),BUCKET MOVE IN INFORMATION 23920000 LM 12,15,ERRSAVE 23940000 BCR 15,RET 23960000 PARAM3 DC X'0A03' 23980000 SPACE 2 24000000 ***** ERR4 ****************************************************** 24020000 * TAKES CARE OF ALL TERMINATING ERRORS THAT ARE 24040000 * 4 BYTETS LONG 24060000 * THAT IS 4, 6, 20, 22, 38, 41, 44, 213, 215, 216 24080000 * ENTERED FROM LABEL, ITABCLEA, COB, BEGIN, BEG1, 24100000 * PBLCKEND, FOR, PROCEDUR, ENDMISS 24120000 * EXITS TO COMPFIN 24140000 SPACE 2 24160000 ERR4 BAL REG12,ERROR1 24180000 SPACE 2 24200000 ***** COMPFIN ****************************************************** 24220000 * TERMINATING ERROR HAS BEEN FOUND 24240000 * SETS TERMBIT IN HCOMPMOD 24260000 * EXITS TO KOPOOLRL IN TERMINATION 24280000 * 24300000 COMPFIN OI HCOMPMOD,X'08' SET TERMINATING ERROR BIT 24320000 L REG11,VIEX14 24340000 USING IEX11003,11 24360000 B KOPOOLRL EXIT TO ERMINATION 24380000 USING IEX11002,11 24400000 SPACE 2 24420000 ***** ERR5 ****************************************************** 24440000 * ERR5A E35 FROM BPRTAB, DISP IN TESTTABL 24460000 * ERR5 E2 FROM BPRTAB, DISP IN ARTABLE 24480000 * GENERATES ERROR PATTERN RETURNS TO TESTLOOP OR LIST 24500000 * 24520000 SPACE 2 24540000 ERR5A LA REGB,PPARLST GET PARAMETER FIELD 24560000 B *+8 24580000 ERR5 LA REGB,PONTPAR GET PARAMETER FIELD 24600000 STM 12,15,ERRSAVE 24620000 BAL REGOX,ERROR1 GENERATE PATTERN 24640000 LM 12,15,ERRSAVE 24660000 BCR 15,RET RETURN TO TESTLOOP OR LIST 24680000 PPARLST DC X'0423' 24700000 PONTPAR DC X'0402' E2 24720000 SPACE 2 24740000 ***** ERR6 ****************************************************** 24760000 * GENERATES PATTERN FOR E6 24780000 * TESTS IF PROGRAM STARTED IF NOT, NO ERROR MESSAGE 24800000 * TEST IF IN COMMENT OR IDENTIFIER PROGRAM 24820000 * TAKES THE 6 CHARACTERS PRECEEDING THE FIRST 24840000 * APOSTROPHE 24860000 * RETURNS TO APOSTROPHE PROGRAM TO TEST ON SECOND 24880000 * APOSTROPHE 24900000 SPACE 2 24920000 ERR6 TM BITS2,X'20' Q. FIRST BEGIN FOUND YET 24940000 BZ TESTLOOP NO 24960000 TM FBYTE,X'FF' 24980000 BO ENTRAPR INVALID IDENTIFIER 25000000 BZ *+12 COMMENT 25020000 LA REGI,1(0,REGI) 25040000 B TPSPECER 25060000 BCTR REGI,0 25080000 STM 12,15,ERRSAVE 25100000 BAL REG12,ERROR1 25120000 S REGI,KOPOOL+24 SUBTRACT 6 25140000 MVC 4(6,REGY),0(REGI) MOVE OUT INFORMATION TO POOL 25160000 LA REGI,7(0,REGI) 25180000 LM 12,15,ERRSAVE 25200000 B ENTRAPR RETURN TO TEST SECOND APOSTROPHE 25220000 SPACE 2 25240000 ***** ERR7 ****************************************************** 25260000 * TAKES CARE OF ALL SERIOUS AND WARNING MESSAGES THAT 25280000 * ARE 4 BYTES LONG 25300000 * ENTERED FROM ERR1, IERSPEC, ARNAMSE, SWITCHNSE 25320000 * PNAMESE, LABNAMER, CODE, SEMCO, ERR18 25340000 * ERR23, CODE, SPEC, VALUE, VALDLB2, 25360000 * FIRSTBEG, ERR9, LABEL, PROCEDURE, 25380000 * SWITCH, COM 25400000 * 1, 5, 8, 15, 17, 18, 23, 24, 25, 28, 29, 42, 43,216 25420000 * RETURNS TO CALLING SEQUENCE 25440000 SPACE 2 25460000 ERR7 STM 12,15,ERRSAVE 25480000 BAL REG12,ERROR1 CREATE ENTRY 25500000 LM 12,15,ERRSAVE 25520000 BC 15,2(0,REGB) 25540000 SPACE 2 25560000 ***** ERR8 ****************************************************** 25580000 * GENERATES ERROR PATTERN E11 ONCE 25600000 * IF FOUND DELIMITER IS COMMENT E18 IS GIVEN 25620000 * INSTEAD 25640000 * ENTERED FROM TYPESPEC 25660000 * STARTDEL 25680000 * EXITS TO TESTLOOP 25700000 SPACE 2 25720000 ERR8 TM BITS3,E11BIT Q. MESSAGE ALLREADY GIVEN ONCE 25740000 LA REGI,1(0,REGI) GET NEXT CARACTER 25760000 BO TESTLOOP YES- RETURN 25780000 CLI BCHAR,X'38' Q COMMENT FOUND 25800000 BE E18 YES GENERATE E18 INSTEAD 25820000 OI BITS3,E11BIT SET E11BIT 25840000 BAL REGB,ERR7 GENERATE E11 PATTERN 25860000 DC X'040B' 25880000 B *+10 25900000 E18 BAL REGB,ERR7 25920000 DC X'0412' 25940000 BCR 15,RET RETURN 25960000 SPACE 2 25980000 ***** ERR9 ******************************************************* 26000000 * GENERATE E9 PATTERN 26020000 * ENTERED FROM TED 26040000 * END 26060000 * READROUT 26080000 * EXITS TO EODADIN 26100000 SPACE 2 26120000 ERR9 BAL REGB,ERR7 PROGRAM CONTINIUED AFTER LAST END 26140000 DC X'042B' 26160000 B EODADIN 26180000 SPACE 2 26200000 ***** ERROR10 ****************************************************** 26220000 * GENERATES E10 PATTERN 26240000 * INSERTS IN THE NOT SPECIFID PARAMETERS A 26260000 * ALLPURPOS IDENTIFIER 26280000 * RETURNS TO CALLING PROGRAM 26300000 SPACE 2 26320000 ERROR10 BAL REGB,ERR2B 26340000 DC X'000A' E10 26360000 L REGB,LPBP 26380000 FINDEMTY LA REGB,11(0,REGB) GET FIRST PARAMETER 26400000 C REGB,AITL Q. ALL PARAMETERS CHECKED 26420000 BCR 8,REGOX WHEN ALL CHECKED RETURN 26440000 CLI 6(REGB),X'00' INSERT ALL PURPOSE IDENTIFIER 26460000 BNE FINDEMTY IN EMPTY INTERNAL NAMES 26480000 MVC 6(5,REGB),ALLPUPOS 26500000 B FINDEMTY 26520000 ALLPUPOS DC X'91FF010000' 26540000 SPACE 2 26560000 ***** ERR13 ****************************************************** 26580000 * GENERATES E13 PATTERN 26600000 * PICKS UP THE DELIMITER FROM W1TAB 26620000 SPACE 2 26640000 ERR13 STM 12,15,ERRSAVE 26660000 LA REGOX,5(0,REGL) INCREASE TO GET WHOLE LENGTH 26680000 STC REGOX,0(REGB) 26700000 BAL REGOX,ERROR1 26720000 L REGL,ERRSAVE+8 GET LENGTH OF DELIMITER 26740000 LA IN,1(0,REGM) GET START ADDRESS OF DELIMITER 26760000 EX REGL,ERRMOVE MOVE DELIMITER TO ERROR PATTER 26780000 LM 12,15,ERRSAVE 26800000 BC 15,2(0,REGB) RETURN 26820000 SPACE 2 26840000 ***** ERROR21 ****************************************************** 26860000 * GENERATES E21 PATTERN 26880000 * PICKS UP DELIMITER FROM DELIMITER TABLE 26900000 * EXITS TO PROGRAM WHICH CALLED FOR BEG1 26920000 SPACE 2 26940000 ERROR21 STM 12,15,ERRSAVE 26960000 LA REGB,5(0,REGL) INCREASE L TO GET WHOLE LENGTH 26980000 STC REGB,E21PAR 27000000 LA REGB,E21PAR 27020000 BAL REG12,ERROR1 27040000 L IN,SAVE1 GET DEK. FROM DELIMITER TABEL 27060000 L REGL,ERRSAVE+8 LENGTH FROM SAVEAREA 27080000 EX REGL,ERRMOVE MOVE IN DEK. IN ERROR MESSAGE 27100000 LA EAP,1(0,EAP) SUBSTITUTE BEG1 DECREASION 27120000 LM 12,15,ERRSAVE BEGIN WILL REMAIN COMPOUND 27140000 BCR 15,REGX RETURN 27160000 E21PAR DC X'0015' E21 27180000 SPACE 2 27200000 SPACE 2 27220000 ***** ERROR1 ****************************************************** 27240000 * CHECKS IF SPACE LEFT IN ERRORPOOL 27260000 * INSERTS LENGTH, SC, ERROR NUMBER 27280000 * RETURNS TO CALLIN ERROR PUTINE 27300000 SPACE 2 27320000 ERROR1 MVC ERRMOD1+3(1),0(REGB) MOVES IN THE LENGTH AND 27340000 MVC ERRMOD2+1(1),0(REGB) ERRORNUMBER IN THE FOLLOWING 27360000 MVC ERRMOD3+1(1),1(REGB) INSTRUCTIONS 27380000 L REGY,NEXTERR 27400000 ERRMOD1 LA REGL,0(0,REGY) 27420000 C REGL,ENDPOOL Q. ROOM LEFT IN ERRORPOOL 27440000 BNH *+8 FOR THIS MESSAGE 27460000 B ERR0 NO- GENERATE E212 27480000 L REGY,NEXTERR 27500000 ST REGL,NEXTERR CORRECT NEXTERR POINTER 27520000 ERRMOD2 MVI 0(REGY),X'00' MOVE IN LENGTH 27540000 ERRMOD3 MVI 1(REGY),X'00' ERRORNUMBER 27560000 MVC 2(2,REGY),SC SC COUNTER 27580000 LR REGL,REGI MAKE REGL POINT TO SIX CHAR 27600000 SH REGL,SEVEN BEFORE CURRENT INPUT POINTER 27620000 BCR 15,REG12 27640000 SPACE 2 27660000 ***** ERROR2 ****************************************************** 27680000 * FINDS FIRST NONZERO CHAR. IN BUCKET, ITAB, 27700000 * IDBUCKET OR BUCKET 27720000 SPACE 2 27740000 ERROR2 LA K,5 INITILIZE K FOR THE LOOP 27760000 STC K,ERRKCAL+3 27780000 ERRKCAL CLI 0(IN),X'00' LOOP TO FIND THE FIRST 0 CHAR 27800000 BNE *+8 OR END OF EXTERNALNAME 27820000 BCT K,ERRKCAL-4 27840000 LA REGY,5(0,K) INCREASE TO GET THE WHOLE 27860000 STC REGY,0(0,REGB) ERROR MESSAGE LENGTH 27880000 BCR 15,REG12 27900000 CNOP 0,4 27920000 ERRMOVE MVC 4(1,REGY),0(IN) 27940000 SEVEN DC X'0007' 27960000 SPACE 2 27980000 ***** IDCHECK1 ****************************************************** 28000000 * CHECKS IDENTIFIER NAMES FOR ARRAY, PROCEDURE AND 28020000 * SWITCH 28040000 * MOVES THE FIRST 6 CHARATERS OF THE NAME TO ITAB 28060000 * AND THE OUTPUT 28080000 * RETURNS VIA REGB WHEN A CHARACTER IS FOUND THAT 28100000 * IS NOT LETTER, DIGIT, BLANK OR ZETA 28120000 SPACE 2 28140000 IDCHECK1 BAL REGOX,COB CHECK IF O/P AREA FILLED 28160000 MVC 0(1,EAP),0(REGI) MOVE OUT FIRST CHAR. 28180000 LA EAP,1(0,EAP) 28200000 L IN,AITL GET ITAB POINTER 28220000 MVC 0(1,IN),0(REGI) MOVE IN FIRST CHAR. TO ITAB 28240000 LA IN,1(0,IN) 28260000 LA K,1 INITILIZE K 28280000 LA REGIX,*+8 28300000 IDCHECK2 LA REGI,1(0,REGI) GET NEXT CHAR. 28320000 CLI 0(REGI),X'2F' Q.WHAT IS CHAR. 28340000 BCR 4,REGB NOT LETTER OR ZETA 28360000 BE CIB ZETA 28380000 C K,KOPOOL+24 LETTER Q. 6 CHAR. MOVED ALLREADY 28400000 BE IDCHECK2 YES SKIP ADDITIONAL CHAR 28420000 BAL REGOX,COB CHECK IF O/P AREA FILLED 28440000 MVC 0(1,EAP),0(REGI) MOVE CHAR TO OUTPUT 28460000 LA EAP,1(0,EAP) 28480000 MVC 0(1,IN),0(REGI) TO ITAB 28500000 LA IN,1(0,IN) INCREASE 28520000 LA K,1(0,K) POINTERS 28540000 B IDCHECK2 GO AND CHECK NEXT CHAR. 28560000 SPACE 2 28580000 ***** FINDSEMC ****************************************************** 28600000 * CHECKS FOR SEMICOLON OR POINT- COMMA 28620000 * BLANKS AND I/P BUFFER CHANGE IS HANDLED 28640000 * IF SEMICOLON IS FOUND THE RETURN IS VIA REG12 28660000 * IF NOT THE RETURN IS VIA REGB 28680000 SPACE 2 28700000 LA REGI,1(0,REGI) 28720000 FINDSEMC LA REGIX,* 28740000 CLI 0(REGI),X'0B' Q. SEMICOLON 28760000 BC 8,0(0,REG12) EQUAL- SEMICOLON FOUND 28780000 CLI 0(REGI),X'2D' Q POINT 28800000 BE FINDCOMA YES- LOOK FOR COMMA 28820000 CLI 0(REGI),X'2B' Q BLANK 28840000 BE FINDSEMC-4 28860000 CLI 0(REGI),X'2F' 28880000 BE CIB 28900000 BCR 15,REGB ERROR- NO SEMICOLON 28920000 FINDCOMA LA REGIX,*+8 28940000 LA REGI,1(0,REGI) 28960000 CLI 0(REGI),X'25' Q COMMA 28980000 BC 8,0(0,REG12) EQUAL- SEMICOLON FOUND 29000000 CLI 0(REGI),X'2B' Q BLANK 29020000 BE FINDCOMA+4 29040000 CLI 0(REGI),X'2F' 29060000 BE CIB 29080000 BCR 15,REGB ERROR NO SEMICOLON 29100000 SPACE 2 29120000 ***** ITABCLEA *** 29140000 * CHECKS FOR ITABOVERFLOW AND CLEARS THE NEXT ENTRY 29160000 SPACE 2 29180000 ITABCLEA L REGY,AITL 29200000 LA REGY,11(0,REGY) 29220000 C REGY,ELI Q ROOM FOR ONE MORE ITAB ENTRY 29240000 BL *+10 29260000 BAL REGB,ERR4 29280000 DC X'04D5' E213 29300000 LR IN,REGY INCREASE ITAB POINTERS 29320000 ST REGY,AITL 29340000 MVI 0(REGY),X'00' CLEAR NEXT 29360000 MVC 1(10,REGY),0(REGY) ITAB ENTRY 29380000 BCR 15,REG12 RETURN 29400000 IEX11001 CSECT 29420000 SPACE 2 29440000 ***** COB ****************************************************** 29460000 * CHECKS IF NEW O/P BUFFER IS NEEDED 29480000 * ENTRY IS TO COBSPEC IF TWO OR MORE CONTINIOUS 29500000 * BYTES ARE NEEDED 29520000 * THE CHANGE OF ADDRESS BETWEEN THE TWO BUFFERS IS 29540000 * DONE WITH DISP. DISP IS EITHER 0 OR 4 29560000 * SO ADDARI+DISP WILL PICK UP EITHER ADDARI OR 29580000 * THE ADDRESS OF THE ALTERNATE O/P BUFFER 29600000 * WADDARI POINTS TO THE FIRST BYTE OF THE CURRENT 29620000 * O/P BUFFER 29640000 * EAP IS THE CURRENT O/P POINTER 29660000 * APE POINTS TO THE LAST BYTE OF THE CORRENT BUFFER 29680000 * ONC CONTAINS THE CURRENT O/P RECORD NUMBER 29700000 * ZETA IS THE BUFFER END INDICATION 29720000 SPACE 2 29740000 COBSPEC C REG0,APE Q. SPACE LEFT FOR X MORE BYTES 29760000 BC 4,0(0,REGOX) YES- RETURN 29780000 B *+12 NO CHANGE OUTPUT BUFFER FIRST 29800000 COB C EAP,APE Q. SPACE LEFT FOR ONE MORE BYTE 29820000 BC 4,0(0,REGOX) YES- RETURN 29840000 MVI 0(EAP),X'2F' MOVE ZETA TO O/P BUFFER 29860000 STM 14,2,SAVE1 SAVE REGISTERS 29880000 ST REGB,SAVE1+24 29900000 CLI ONC,X'FF' Q ALREADY 256 OUTPUTRECORDS 29920000 BL *+10 29940000 BAL REGB,ERR4 IF YES TERMINATE COMPILATION 29960000 DC X'04D7' E215 29980000 L EAP,WADDARI LOAD ADD. OF CURRENT O/P REC 30000000 LA REGB,DCBUT1 DCBADDRESS 30020000 CLI ONC,X'00' Q FIRST OUTPUTRECORD 30040000 BE WRITEOB IF YES SKIP CHECK 30060000 CHECK ODECB CHECK IF BEFORELAST RECORD IS 30080000 * WRITTEN 30100000 WRITEOB WRITE ODECB,SF,(REGB),(EAP) 30120000 XI DISP,X'04' CHANGE ADDRESSDISPLACEMENT 30140000 IC REGZ,DISP 30160000 L EAP,ADDARI(REGZ) COMPUTE VALID O/P BUFFERADD 30180000 ST EAP,WADDARI STORE IT IN WADDARI 30200000 LR REGL,EAP COMPUTE ADDRESS OF LAST BYTE IN 30220000 A REGL,SRCE1S THE NEW OUTPUT AREA 30240000 BCTR REGL,0 AND SAVE IT 30260000 ST REGL,APE IN APE 30280000 IC REGZ,ONC INCREASE OUTPUTRECORDCOUNTER 30300000 LA REGZ,1(0,REGZ) 30320000 STC REGZ,ONC 30340000 L REGB,SAVE1+24 30360000 LM 14,2,SAVE1 30380000 BCR 15,REGOX RETURN TO CALLING SEQUENCE 30400000 SPACE 2 30420000 ***** CIB ****************************************************** 30440000 * GET NEXT RECORD AND PRINTS IT WITH THE SC 30460000 * IF ISO CODE IS SPECIFIED A TRANSLATION IS FIRST 30480000 * MADE TO EBCDIC 30500000 * THE RECORD IS TRANSLATE AND THE RECORD END 30520000 * INDICATION - ZETA- IS INSERTED 30540000 SPACE 2 30560000 CIB STM 14,2,SAVE1 SAVE REGISTERS 30580000 SH REGI,SEVEN MOVE SEVEN CHAR INFRONT 30600000 MVC WABEFOR(7),0(REGI) OF WORKAREA 30620000 TM HCOMPMOD+1,NSRCE Q. NOSOURCE SPECIFIED 30640000 BO GETREC YES SKIP PRINTING 30660000 L 15,PRTRTADD PRINT 30680000 BALR 14,15 30700000 ST REGI,APRNTAR SAVE NEW PRINT BUFFER ADDRESS 30720000 GETREC L REGI,INADD DCBADDRESS 30740000 GET (1),WA GET NEXT RECORD 30760000 TESTISO TM HCOMPMOD+1,ISO TEST IF ISO INPUT 30780000 BO ISOTRANS YES TRANSLATE ISO TO EBCDIC 30800000 L REGI,APRNTAR 30820000 TM HCOMPMOD+1,NSRCE Q. NOSOURCE SPECIFIED 30840000 BO NOPRINT YES- MOVE TO DUMMY PRINTAREA 30860000 LH REGY,SC CONVERT SEMICOLON COUNTER 30880000 CVD REGY,DOUBLE 30900000 UNPK 0(5,REGI),DOUBLE(8) 30920000 MVZ 4(1,REGI),3(REGI) MOVE OUT SC COUNTER 30940000 MVC 8(80,REGI),WA MOVE RECORD TO PRINTAREA 30960000 B *+10 30980000 NOPRINT MVC SAVEPRNT+8(72),WA IF NSRCE MOVE RECORD TO DUMMY PRINT 31000000 LM 14,2,SAVE1 31020000 LA REGI,WA SET INPUT POINTER 31040000 TR WA(72),TRLTABLE TRANSLATE RECORD 31060000 MVI 72(REGI),X'2F' MOVE RECORD END IDENTIFIER 31080000 BCR 15,REGIX RETURN 31100000 ISOTRANS ST REGB,SAVE1+24 31120000 LA REGB,WA GET START OF WA 31140000 LA REGY,79(0,REGB) GET END OF WA 31160000 LOOP CLI 0(REGB),X'4C' ) 31180000 BE IRPAR 31200000 CLI 0(REGB),X'7B' = 31220000 BE IEQUAL 31240000 CLI 0(REGB),X'7C' ' 31260000 BE IAPOST 31280000 CLI 0(REGB),X'6C' ( 31300000 BE ILPAR 31320000 CLI 0(REGB),X'50' + 31340000 BNE LOOPEND 31360000 MVI 0(REGB),X'4E' + 31380000 B LOOPEND 31400000 IRPAR MVI 0(REGB),X'5D' ) 31420000 B LOOPEND 31440000 IEQUAL MVI 0(REGB),X'7E' = 31460000 B LOOPEND 31480000 IAPOST MVI 0(REGB),X'7D' ' 31500000 B LOOPEND 31520000 ILPAR MVI 0(REGB),X'4D' ( 31540000 LOOPEND LA REGB,1(0,REGB) 31560000 CR REGB,REGY Q. ALL CHAR. CHECKE IN WA 31580000 BNH LOOP NO- CHECK NEXT 31600000 L REGB,SAVE1+24 YES RETURN 31620000 B TESTISO+8 31640000 SPACE 2 31660000 ***** WITAB ****************************************************** 31680000 * CONTAINS ALL DELIMITERS, EACH FOLLOWED BY 31700000 * 3 BYTES OF INFORMATION, 2 CHARACTERISTICS 31720000 * AND A DISPLACEMENT TO DELPRGTB 31740000 SPACE 2 31760000 W1TAB DS 0CL256 31780000 B1 DC X'020304000006000004' 31800000 * SLASH STRING 31820000 B2 DC X'03434E1C000848451D000C4E51220000' 31840000 * DO IF OR 31860000 B3 DC X'04444D43000010454E51000014404D432300004D4E53200000' 31880000 * END AND NOT 31900000 B4 DC X'095144404BC212185253444F1900005347444D1E0008444B52441F$31920000 0008464E534E17000C5351544407001C4B445252110000424E4344' 31940000 * REAL STEP THEN ELSE 31960000 * GOTO TRUE LESS CODE 31980000 DC X'000020484C4F4B210000' 32000000 * IMPL 32020000 * IMPL 32040000 B5 DC X'0A414446484D000024544D53484B1A00004051514058CA16285540$32060000 4B544400002C4B4041444BCA18305647484B441B000045404B5244' 32080000 * BEGIN UNTIL ARRAY VA 32100000 * LUE LABEL WHILE FALSE 32120000 DC X'00001C4F4E564451050000445054404B10000044' 32140000 * POWER EQUAL 32160000 DC X'50544855240000' 32180000 * EQUIV 32200000 B6 DC X'02525648534247CA1C34525351484D46CB1030' 32220000 * SWITCH STRING 32240000 B7 DC X'05484D5344464451C21118414E4E4B44404DC21318424E4C4C444D$32260000 530000384D4E534B44525215000046514440534451120000' 32280000 * INTEGER BOOLEAN COMMENT 32300000 * NOTLESS GREATER 32320000 B8 DC X'014D4E53445054404B130000' 32340000 * NOTEQUAL 32360000 B9 DC X'014F514E424443545144CAD03C' 32380000 * PROCEDURE 32400000 B10 DC X'014D4E5346514440534451140000' 32420000 * NOTGREATER 32440000 DS 0F 32460000 SPACE 2 32480000 ***** LITAB ****************************************************** 32500000 * USED TO SET REFERENCE IN W1TAB TO STRING 32520000 * DELIMITERS WITH A PATICULARY LENGTH 32540000 SPACE 2 32560000 L1TAB DC A(B1) 32580000 DC A(B2) 32600000 DC A(B3) 32620000 DC A(B4) 32640000 DC A(B5) 32660000 DC A(B6) 32680000 DC A(B7) 32700000 DC A(B8) 32720000 DC A(B9) 32740000 DC A(B10) 32760000 SPACE 2 32780000 ***** DELPRGTB ****************************************************** 32800000 * BRANCH ADDRESS TABLE USED AFTER A DELIMITER 32820000 * HAS BEEN FOUND 32840000 SPACE 2 32860000 DELPRGTB DS 0CL68 32880000 DC A(NORMAL) 32900000 DC A(STRING) 32920000 DC A(TED) 32940000 DC A(GIF) 32960000 DC A(END) 32980000 DC A(FOR) 33000000 DC A(TYPE) 33020000 DC A(BOLCON) 33040000 DC A(CODE) 33060000 DC A(BEGIN) 33080000 DC A(ARRAY) 33100000 DC A(VALUE) 33120000 DC A(SPEC) 33140000 DC A(SWITCH) 33160000 DC A(COM) 33180000 DC A(PROCEDUR) 33200000 DC A(TYPEARRY) 33220000 DC A(TYPPROC) 33240000 SPACE 2 33260000 ***** DELTMIT ****************************************************** 33280000 * TWO APOSTROPHES HAVE BEEN FOUND 33300000 * IT IS CHECKED THAT THE LENGTH IS NOT ZERO OR EXCEED 33320000 * THE LIMIT FOR A DELIMITER (10 CHARACTERS) 33340000 * REGM POINTS TO THE FIRST AND REGI TO THE LAST 33360000 * APOSTROPHE 33380000 * THE LENGTH IS USED TO GET A DISPLACEMENT FROM THE 33400000 * LITAB FOR A SECTION IN THE WITAB 33420000 * A SECTION IN THE WITAR CONTAINS ALL DELIMITERS 33440000 * OF THE SAME LENGTH 33460000 * THE FIRST BYTE IN EACH SECTION SAYS HOW MANY 33480000 * ENTRIES THERE ARE IN THE SECTION 33500000 * THEREAFTER A DELIMITER PLUS 3 BYTES OF 33520000 * INTERNAL CODE MAKES A SUBSECTION 33540000 * THE FIRST 2 BYTES OF THE INTERNAL CODE IS 33560000 * CHARECTERISTCS FOR THE DELIMITER 33580000 * THE THIRD BYTE IS A DISPLACEMENT TO THE 33600000 * DELPRGTB, WHERE THE ADDRESS IS PICKED UP 33620000 * TO THE PROGRAM TO HANDLE THE DELIMITER 33640000 * A CHECK IS MADE WHEN A DILIMITER IS FOUND IF IF IS 33660000 * THE FIRST FOUND IN THE PROGRAM - THE EXIT IS 33680000 * THEN TO STARTDEL. THE TEST IS ON BITS2 X'20' 33700000 * IF NO DELIMITER IS FOUND THE EXIT IS TO THE EROUT 33720000 * PROGRAM 33740000 * FBYTE- SWITCH 33760000 * THE FBYTE IS FF IF AN APOSTROPHE IS FOUND IN 33780000 * THE COMMENT PROGRAM 33800000 * THE FBYTE IS F0 IF AN APOSTROPHE IS FOUND IN 33820000 * THE TYPE PROGRAM INSTEAD OF THE FIRST 33840000 * CHARACTER OF THE NAME 33860000 * OTHERWISE IT IS 00 33880000 SPACE 2 33900000 DELIMIT SR REGY,REGY 33920000 SR REGL,REGL 33940000 LR REGL,REGI 33960000 BCTR REGL,0 33980000 SR REGL,REGM COMPUTE LENGTH L 34000000 BP *+10 Q. GREATER THAN ZERO 34020000 BAL REGB,ERR6 34040000 DC X'0A0C' E12 DELETE FIRST APOSTROPHE 34060000 C REGL,KOPOOL+44 Q. LIMIT EXEEDED ALLREADY 34080000 BH EROUT BRANCH TO ERRORROUTINE 34100000 BCTR REGL,0 34120000 LA REGX,L1TAB 34140000 TM FBYTE,X'FF' TEST FBYTE 34160000 BO COMSPEC 34180000 BM TYPESPEC 34200000 SLA REGL,2(0) START OF LOOKUP STRING 34220000 L REGX,0(REGL,REGX) 34240000 IC REGY,0(0,REGX) NUMBER OF ENTRIES IN THIS SECTION 34260000 LA REGX,1(0,REGX) AND ADDRESS OF FIRST WORDENTRY 34280000 SRA REGL,2(0) 34300000 CLC EX REGL,COMPARE Q. DELIMITER FOUND 34320000 BNE NOTEQUAL NO- TRY NEXT IN SAME SECTION 34340000 IC REGZ,3(REGL,REGX) 34360000 TM BITS2,X'20' Q. PROGRAM STARTED YET 34380000 BO *+8 YES 34400000 B STARTDEL NO- CHECK FOR CORRECT START 34420000 L REGB,DELPRGTB(REGZ) BRANCH TO APPROPRIATE SUBPGM 34440000 BCR 15,REGB DEPENDING ON DISP IN WITAB 34460000 NOTEQUAL LA REGX,4(REGL,REGX) GET NEXT DELIMITER 34480000 BCT REGY,CLC Q. AMY DELIMITERS LEFT TO CHECK 34500000 BC 15,EROUT BRANCH TO ERRORROUTINE 34520000 CNOP 0,4 34540000 COMPARE CLC 1(1,REGM),0(REGX) 34560000 SPACE 2 34580000 ***** EROUT ****************************************************** 34600000 * CHECKS ALL SECTIONS OF THE WITAB FOR AN EQUAL 34620000 * DELIMITER TO THE ONE IN I/P, DISREGARDING LENGTH 34640000 * IF NO EQUAL FOUND E14 IS GENERATED AND THE FIRST 34660000 * APOSTROPHE IS DELETED. EXIT IS THEN TO TEST 34680000 * IF AN EQUAL IS FOUND E13 IS FENERATED AND AN BRANCH 34700000 * IS TAKEN TO THE APPROPRIATE SUBPROGRAM 34720000 SPACE 2 34740000 EROUT TM FBYTE,X'FF' 34760000 BM TYPESPEC INVALID IDENTIFIER 34780000 BO COMCEE2 COMMENT A32949 34800000 EROUTOK LA REGZ,10 GO THROUGH ALL POSSIBILITIES 34820000 SR REGY,REGY 34840000 LA REGL,0 INITILIZE REGL= 0 34860000 EROUT2 SLA REGL,2(0) 34880000 LA REGX,L1TAB 34900000 L REGX,0(REGL,REGX) GET SECTION IN WITAB 34920000 IC REGY,0(0,REGX) NUMBER OF ENTRIES IN STRING 34940000 LA REGX,1(0,REGX) FIRST ENTRY 34960000 SRA REGL,2(0) 34980000 CLCERR EX REGL,COMPARE Q. DELIMITER FOUND 35000000 BNE EROUT3 NO 35020000 TM BITS2,STARTBIT Q. PROGRAM STARTED YET 35040000 BZ STARTDEL NO- CHECK FOR A CORRECT START 35060000 BAL REGB,ERR13 35080000 DC X'000D' E13 35100000 LA REGI,1(REGL,REGM) SET REGI TO ONE BEYOND DELIMITER 35120000 IC REGZ,3(REGL,REGX) GET DISPLACEMENT OF PROGRAM 35140000 L REGB,DELPRGTB(REGZ) IN DELPRGTB 35160000 BCR 15,REGB BRANCH TO PROGRAM 35180000 EROUT3 LA REGX,4(REGL,REGX) NO GET NEXT DELIMITER 35200000 BCT REGY,CLCERR Q ALL DEL IN STRING CHECKED 35220000 LA REGL,1(0,REGL) YES-GET NEXT STRING 35240000 BCT REGZ,EROUT2 35260000 TM BITS2,X'20' Q. PROGRAM STARTED YET 35280000 BZ TESTLOOP NO RETURN TO MAINLOOP SCANNING 35300000 BAL REGB,ERR2C 35320000 DC X'0A0E' E14 35340000 LA REGI,1(0,REGM) GET NEXT CHAR 35360000 BCR 15,RET RETURN 35380000 SPACE 2 35400000 ***** TYPESPEC ****************************************************** 35420000 * 'REAL'' OR 'INTEGER'' OR 'BOOLEAN'' HAS BEEN FOUND 35440000 * THE ONLY VALID DELIMITERS ARE AT THIS POINT 35460000 * ARRAY OR PROCEDURE 35480000 SPACE 2 35500000 TYPESPEC CLC 1(9,REGM),B9+1 Q. TYPE PROCEDURE 35520000 BE TYPPROC YES 35540000 TM BITS2,X'20' Q. PROGRAM STARTED YET 35560000 BZ ERR8 NO- GENERATE E11 35580000 CLC 1(5,REGM),B5+17 Q. TYPE ARRAY 35600000 BE TYPEARRY YES 35620000 * INVALID IDENTIFIER HAS BEEN 35640000 * FOUND GO TO IER SPEC 35660000 TPSPECER TM BITS1,X'40' Q. SPECIFICATION 35680000 BO *+12 35700000 LA REGH,TYPEDAFI NO- SET RETURN TO TYPE PGM. 35720000 B IERSPEC 35740000 LA REGH,IDCHECK YES- SET RETURN TO IDCHECK 35760000 B IERSPEC 35780000 SPACE 2 35800000 ***** COMSPEC ****** 35820000 * TWO APOSTROPHES HAVE BEEN FOUND IN A COMMENT 35840000 * VALID DELIMITERS TO END A COMMENT ARE 35860000 * END OR ELSE 35880000 SPACE 2 35900000 COMSPEC LA REGX,B4+22 Q.COMMENT ENDING WITH ELSE 35920000 CLC 1(4,REGM),B4+22 35940000 BNE *+16 NO 35960000 C REGL,KOPOOL+12 CHECK CORRECT LENGTH 35980000 BE TED 36000000 B ENTRAPR RETURN TO FIND ANOTHER APOSTROPHE 4762 36020016 CLC 1(3,REGM),B3+1 Q. COMMENT ENDED WITH END 36040000 BNE ENTRAPR RETURN TO FIND ANOTHER APOSTROPHE 4762 36060016 C REGL,KOPOOL+8 CHECK CORRECT LENGTH 36080000 BE END END 36100000 B ENTRAPR RETURN TO FIND ANOTHER APOSTROPHE 4762 36120016 SPACE 2 36140000 ***** STARTDEL ****************************************************** 36160000 * THE ONLY VALID DELIMITERS TO START A PROGRAM IS 36180000 * BEGIN OR IF PRECOMPILED PROCEDURE IS SPECIFIED 36200000 * PROCEDURE OR TYPE PROCEDURE 36220000 SPACE 2 36240000 STARTDEL STC REGZ,BCHAR GET DELIMITERS CHARACTERISTIC 36260000 * FROM WITAB 36280000 CLI BCHAR,X'24' Q. BEGIN FOUND 36300000 BE FIRSTBEG YES 36320000 TM HCOMPMOD,PROC Q. PRECOMPIELED SPECIFIED 36340000 BZ ERR8 NO- GENERATE E11 36360000 CLI BCHAR,X'3C' Q. FOUND WORD IS PROCEDURE 36380000 BNE TYPEPREC-8 NO 36400000 B PROCEDUR YES 36420000 CLI BCHAR,X'18' Q. TYPE FOUND 36440000 BNE ERR8 NO 36460000 TYPEPREC LA REGI,1(0,REGI) LOOK FOR APOSTROPHE- TYPE PROC 36480000 CLI 0(REGI),X'2E' Q. APOSTROPHE FOUND 36500000 BNE *+10 36520000 BCTR REGI,0 YES- DECREASE TO LET TYPE PGM 36540000 B TYPE FIND THE APOSTROPHE AGAIN 36560000 CLI 0(REGI),X'2B' Q. BLANK 36580000 BE TYPEPREC 36600000 CLI 0(REGI),X'2F' Q. ZETA 36620000 BNE ERR8 NEITHER- GENERATE E11 36640000 ST REGX,SAVE1+20 CHANGE I/P AND LOOK AGAIN 36660000 BAL REGIX,CIB 36680000 L REGX,SAVE1+20 36700000 B TYPEPREC+4 36720000 SPACE 2 36740000 SPACE 2 36760000 ***** NORMAL ****************************************************** 36780000 * INSERTS IN THE O/P THE INTERNAL CODE FROM WITAB 36800000 SPACE 2 36820000 NORMAL BAL REGOX,COB CHECK IF O/P AREA FILLED 36840000 LA REGX,1(REGL,REGX) COMPUTE ADDRESS OF CODE 36860000 MVC 0(1,EAP),0(REGX) MOVE CODE TO OUTPUTBUFFER 36880000 LA EAP,1(0,EAP) INCREASE OUTPUT- AND 36900000 LA REGI,1(0,REGI) INPUTPOINTERS 36920000 BCR 15,RET 36940000 SPACE 2 36960000 ***** BOLCON ****************************************************** 36980000 * MOVES OUT SIX BYTES OF INTERNAL CODE FOR 37000000 * FALSE OR TRUE 37020000 SPACE 2 37040000 BOLCON LA REG0,6(0,EAP) 37060000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 37080000 MVC 0(5,EAP),INT TRANSFER FIRST PART OF INTERNAL NAME 37100000 LA REGN,1(REGL,REGX) AND 37120000 MVC 5(1,EAP),0(REGN) LAST PART 37140000 LA EAP,6(0,EAP) INCREASE OUTPUT- 37160000 LA REGI,1(0,REGI) AND INPUTPOINTERS 37180000 BCR 15,RET 37200000 SPACE 2 37220000 ***** GIF ****************************************************** 37240000 * TRANSFERS INTERNAL CODEBYTE AND EXITS 37260000 * TO THE STATEMENT PROGRAM TO CHECK IF A PROCEDURE 37280000 * BOBY HAS STARTED 37300000 SPACE 2 37320000 GIF BAL REGOX,COB CHECK IF O/P AREA FILLED 37340000 LA REGN,1(REGL,REGX) TRANSFER INTERNAL CODE 37360000 MVC 0(1,EAP),0(REGN) 37380000 LA EAP,1(0,EAP) INCREASE OUTPUT- 37400000 LA REGI,1(0,REGI) AND INPUTPOINTER 37420000 BC 15,STATE BRANCH TO STATEMENTPROGRAM 37440000 SPACE 2 37460000 ***** TED ****************************************************** 37480000 * TRANSFERS INTERNAL CODE 37500000 * SETS POSSIBLE LABEL POINTERS 37520000 SPACE 2 37540000 TED TM BITS2,ENDBIT Q. ELSE ENDED FINAL END COMMENT 37560000 BO ERR9 YES 37580000 BAL REGOX,COB 37600000 LA REGX,1(REGL,REGX) 37620000 MVC 0(1,EAP),0(REGX) TRANSFER INTERNAL CODE 37640000 ST EAP,OPIN SET LABEL POINTERS 37660000 MVC OPIN+4(1),ONC 37680000 MVC OPINCHAR(1),0(REGX) 37700000 LA EAP,1(0,EAP) 37720000 ST EAP,LAPIN 37740000 LA REGI,1(0,REGI) 37760000 NI BITS2,X'FE' SET ENDELSE BIT TO ZERO 37780000 BCR 15,RET 37800000 SPACE 2 37820000 ***** BEGIN ****************************************************** 37840000 * TEST IF PROC IN STACK 37860000 * TRANSFERS 'BEGIN' TO OUTPUT AND STACK 37880000 * SETS OPIN, OPIN+4, LAPIN, BEGBIT 37900000 * BEGBIT IS USED TO DISTINGUISH BETWEEN COMPOUND 37920000 * BEGIN AND BLOCK BEGIN. IF A DECLARATION IS 37940000 * FOUND WHEN THE BEGBIT IS ON IT'S A BLOCK BEGIN 37960000 * THE BEGBIT IS TURNED OF BY THE STATEMENT 37980000 * PROGRAM AND THE BEG1 PROGRAM 38000000 SPACE 2 38020000 BEGIN L REGY,SP 38040000 CLI 0(REGY),X'0C' Q. PROC IN STACK 38060000 BE BEGPROC IF YES BRANCH TO PROC PROCESSING 38080000 LA REG0,4(0,EAP) 38100000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 38120000 MVI 0(EAP),X'0C' TRANSFER BEGIN TO O/P 38140000 MVI OPINCHAR,X'0C' SET LABELSAVE 38160000 ST EAP,OPIN NOTE ITS POSITION IN OPIN AND 38180000 MVC OPIN+4(1),ONC THE NUMBER OF THE OUTPUTBUFFER 38200000 LA EAP,1(0,EAP) INCREASE OUTPUTPOINTER 38220000 ST EAP,LAPIN NOTE WHERE LABEL MAY START 38240000 OI BITS1,X'80' BEGBIT.= 1 38260000 LA REGY,1(0,REGY) INCREASE STACKPOINTER 38280000 C REGY,ATOPSTAK 38300000 BL *+10 38320000 BAL REGB,ERR4 STACK OVERFLOW 38340000 DC X'0414' E20 38360000 MVI 0(REGY),X'08' PUT BEGIN IN STACK 38380000 ST REGY,SP 38400000 LA REGI,1(0,REGI) 38420000 B TESTLOOP 38440000 SPACE 2 38460000 ***** BEGPROC ****************************************************** 38480000 * PROCEDURE- SPECIFICATIONS- BEGIN HAS BEEN FOUND 38500000 * PROC BOBY IS TO COME. PROC IS CHANGED TO PROC* 38520000 * ITS CHECKED THAT ALL PARAMETERS HAVE BEEN 38540000 * SPECIFIED 38560000 * THE RETURN IS TO TEST VIA THE BEGIN PROGRAM 38580000 SPACE 2 38600000 BEGPROC MVI 0(REGY),X'10' CONVERT PROC INTO PROC* 38620000 NI BITS1,X'BF' PROBIT=0 38640000 CLI PZ,X'00' TEST IF ALL PARAMETERS SPECIFIED 38660000 BE BEGPROC-8 YES 38680000 BAL REGOX,ERROR10 NO- GENERATE E11 38700000 B BEGPROC-8 38720000 SPACE 2 38740000 ***** FIRSTBEG ****************************************************** 38760000 * THE FIRST BEGIN IS CONSIDERED AS A BLOCK BEGIN 38780000 * THE START BIT IS TURNED OFF 38800000 * THE BEG1 PROGRAM IS JOINED 38820000 * IF PRECOMPILED PROCEDURE HAS BEEN SPECIFID E42 IS 38840000 * GIVEN AS A WARNING AND THE BEGIN IS 38860000 * DISREGARDED 38880000 SPACE 2 38900000 FIRSTBEG TM HCOMPMOD,PROC Q. PRECOMPIELED PROCEDURE 38920000 BZ *+18 38940000 BAL REGB,ERR7 YES GIVE WARNING MESSAGE 38960000 DC X'042A' 38980000 LA REGI,1(0,REGI) DISREGARD THE BEGIN 39000000 B TESTLOOP 39020000 OI BITS2,X'20' NO TURN STARTBIT OFF 39040000 LA REGX,TESTLOOP MAKE RETURN FROM BEGI BE TEST 39060000 LA REGI,1(0,REGI) 39080000 B BEG1FRST FIRST BEGIN =BLOCK BEGIN 39100000 SPACE 2 39120000 ***** BEGI ****************************************************** 39140000 * BLOCKBEGIN PROGRAM 39160000 * CHANGES BEGIN TO BETA IN STACK AND OUTPUT 39180000 * INCREASES ITAB GROUP NR. AND PROGRAM BLOCK NR. 39200000 * ENTRIES ARE MADE IN. 39220000 * GROUPTABEL 39240000 * SORROUNDING BLOCKS IG. NR 39260000 * PBTAB1 39280000 * SURROUNDING PBN 39300000 * SCTAB - CURRENTSC COUNTER 39320000 * ITAB 39340000 * ADDRESSES OF SORROUNDIN BLOCK AND 39360000 * IG HEADENTRIES, NEW PBN AND IGN. 39380000 * LPBP (ADDRESS OF CURRENT PROGRAM BLOCK HEAD ENTRY) 39400000 * AND 39420000 * LIGP (ADDRESS OF CURRENT ITAB GROUP HEAD ENTRY) 39440000 * ARE UPDATED 39460000 * PUTS BETA + NEW PBN AND IGN TO OUTPUT REC. 39480000 SPACE 2 39500000 BEG1 BCTR EAP,0 39520000 NI BITS1,BEGOFF BEGBIT 0 39540000 CLI 0(EAP),X'0C' Q. BEGIN IN O/P 39560000 BNE ERROR21 NO- DECLARATION INCORRECT PLACE 39580000 BEG1FRST MVI 0(EAP),X'0D' MOVE BETA TO O/P 39600000 L REGY,SP AND 39620000 MVI 0(REGY),X'04' STACK 39640000 SR REGB,REGB 39660000 LH REGB,IGC 39680000 LA REGB,1(0,REGB) INCREASE ITABGROUPNUMBER 39700000 STH REGB,IGC 39720000 AR REGB,REGB ENTRY IS TO GO INTO 39740000 AH REGB,IGC A(GT)+3*(IGC) 39760000 A REGB,AGT 39780000 L REG7,LIGP 39800000 MVC 0(2,REGB),8(REG7) ENTRY INTO GROUPTABLE 39820000 MVI 2(REGB),X'00' 39840000 NI 0(REGB),X'7F' CLEAR POSSIBLE PHI IND. 39860000 CLI PBC,X'FF' Q. MORE THAN 255 BLOCKS 39880000 BNE *+10 39900000 BAL REGB,ERR4 39920000 DC X'0416' E22 39940000 IC REGZ,PBC INCREASE 39960000 LA REGZ,1(0,REGZ) PROGRAMBLOCKNUMBER 39980000 STC REGZ,PBC 40000000 L REG7,LPBP 40020000 LA REGB,PBTAB1 40040000 AR REGB,REGZ 40060000 MVC 0(1,REGB),10(REG7) ENTRY INTO PROGRAMBLOCKTABLE 40080000 STC REGZ,1(0,EAP) TRANSFER PBN TO O/P 40100000 AR REGZ,REGZ MAKE ENTRY OF CURRENT 40120000 LA REGB,SCTAB(REGZ) SC COUNTER IN SCTAB 40140000 MVC 0(2,REGB),SC 40160000 MVC 2(2,EAP),IGC IGN IN OUTPUT BUFFER 40180000 LA EAP,4(0,EAP) 40200000 ST EAP,LAPIN SET LABEL POINTERS 40220000 L REGY,AITL MAKE BLOCK HEAD IN ITAB 40240000 MVC 0(4,REGY),LIGP 40260000 MVC 4(4,REGY),LPBP 40280000 MVC 8(2,REGY),IGC 40300000 MVC 10(1,REGY),PBC 40320000 ST REGY,LPBP UPDATE LIGP AND LPBP 40340000 ST REGY,LIGP 40360000 BAL REG12,ITABCLEA CHECK AND CLEAR NEXT ITABENTRY 40380000 BCR 15,REGX 40400000 SPACE 2 40420000 ***** END ****************************************************** 40440000 * ACTION DEPENDS ON WHAT IS IN THE STACK 40460000 * TURNS IN ALL CASES OFF THE DELTABIT AND THE 40480000 * END ELSE BIT 40500000 * GENERAL RETURN POINT IS CSPEND IF RETURN 40520000 * ADDRESS - IN REGE- IS NOT CHANGED 40540000 * FINAL RETURN IS TO TEST VIA SEMCO OR COMMENT 40560000 * PROGRAM 40580000 * PROC** IN STACK ACTIVATES PBLOCKEND AND RETURNS 40600000 * TO END TO INSPECT THE STACK AGAIN 40620000 SPACE 2 40640000 END NI BITS1,X'DF' DELTABIT.=0 40660000 TM BITS2,ENDBIT Q. END FINISHED FINAL END COMMENT 40680000 BO ERR9 YES 40700000 NI BITS2,X'FE' SET ENDELSE BIT TO ZERO 40720000 CSPEND LA REGE,* RETURN FOR PBLCKEND, FOREND 40740000 L REGY,SP 40760000 IC REGZ,0(0,REGY) BRANCH 40780000 L REGB,PROG1(REGZ) DEPENDING ON TOPBYTE 40800000 BCR 15,REGB OF THE STACK 40820000 CNOP 0,4 40840000 PROG1 DC A(ERR8) E11 IF ALPHA 40860000 DC A(BLOCKEND) BETA 40880000 DC A(COMPDEND) BEGIN 40900000 DC A(PREND) PROC 40920000 DC A(STAREND) PROC* 40940000 DC A(PBLCKEND) 40960000 DC A(FOREND) FOR 40980000 SPACE 2 41000000 ***** STAREND ****************************************************** 41020000 * PROC* HAS ENDED 41040000 * ACTIVATES THE PBLOCKEND PROGRAM AND RETURNS 41060000 * AFTERWARDS TO TEST VIA COMMENT PROGRAM 41080000 SPACE 2 41100000 STAREND OI BITS1,X'20' DELTABIT= 1 41120000 LA REGE,COMMEND LOAD ADDRESS OF ENDENTRY INTO COM- 41140000 * MENTPROGRAM 41160000 BC 15,PBLCKEND 41180000 SPACE 2 41200000 ***** PREND ****************************************************** 41220000 * PROC HAS ENDED 41240000 * CHECKS IF ALL PARAMETERS SPECIFIED 41260000 * TURNS OFF THE PROBIT 41280000 * A PROC THAT ENDS WITH 'END' IS NOT CORRECTED, 41300000 * THEREFOR THE STACK IS AGAIN INSPECTED AFTER 41320000 * THE PBLOCKEND PROGRAM HAS BEEN ACTIVATED 41340000 SPACE 2 41360000 PREND NI BITS1,X'BF' PROBIT.=0 41380000 CLI PZ,X'00' ALL PARAMETERS SPECIFIED 41400000 BE PBLCKEND YES- ACTIVATE PBLCKEND 41420000 BAL REGOX,ERROR10 NO- GENERATE E10 FIRST 41440000 B PBLCKEND 41460000 SPACE 2 41480000 ***** COMPDEND ****************************************************** 41500000 * A COMPOUND STATMENT HAS ENDED 41520000 * TRANSFERS END '2C' TO OUTPUT AND RELEASES 41540000 * BEGIN IN STACK 41560000 * THEN- IT CHECKS IF THE END OF THIS COMPOUND 41580000 * STATEMENT INDICATETS THE END OF ANY 41600000 * FORSTATMENT(S) OR PROC**. 41620000 * THIS IS DONE WITH BITS2 X'01' AND THE 41640000 * COMMENT PROGRAM 41660000 * IF THE END IS FOLLOWED BY A ., OR 'END' THE 41680000 * STACK IS INSPECTED AGAIN 41700000 * IF THE END IS FOLLOWED BY AN 'ELSE' THE 41720000 * COUMPOUND STATMENT ITSELF IS ALL THAT HAS 41740000 * ENDED AT THIS POINT 41760000 SPACE 2 41780000 COMPDEND BAL REGOX,COB CHECK IF O/P AREA FILLED 41800000 MVI 0(EAP),X'2C' TRANSFER END TO OUTPUTBUFFER 41820000 LA EAP,1(0,EAP) INCREASE OUTPUTPOINTER 41840000 L REGY,SP RELEASE BEGIN IN 41860000 BCTR REGY,0 STACK 41880000 ST REGY,SP 41900000 COMPENDI CLI 0(REGY),X'00' Q. ALPHA IN STACK 41920000 BE PGMEND YES- LOGICAL PROGRAM END 41940000 CLI 0(REGY),X'14' Q. PROC** 41960000 BL COMMEND BRANCH TO COM-PROGRAM,END-ENTRY 41980000 * FOR BEGIN OR BETA OR PROC* IN STACK 42000000 OI BITS2,X'01' SET END-ELSE BIT 42020000 B COMMEND CHECK HOW ENDCOMMENT ENDS 42040000 * ENDCOMMENT ENDED WITH A SEMICOLON 42060000 COMPEND2 NI BITS2,X'FE' RESET END ELSE BIT 42080000 L REGY,SP INSPECT STACK AGAIN 42100000 CLI 0(REGY),X'14' Q. PROC** OR FOR IN STACK 42120000 BE *+12 PROC** 42140000 LA REGE,COMPEND4 FOR GOTO FORENS AND THEN 42160000 B FOREND TEST AGAIN - COMPEND4 42180000 COMPEND3 OI BITS1,X'20' PROC**- SET DELTABIT 42200000 LA REGE,SEMCO RETURN FROM PBLCKEND 42220000 B PBLCKEND BLOCKEND FOR PROC** 42240000 COMPEND4 CLI 0(REGY),X'14' Q. PROC**,FOR OR S.E. 42260000 BE COMPEND3 PROC** 42280000 BH FOREND FOR 42300000 B SEMCO SOMETHING ELSE 42320000 SPACE 2 42340000 ***** BLOCKEND ****************************************************** 42360000 * A BETA BLOCK HAS ENDED 42380000 * THE RETURN AFTER THE PBLOCKEND PROGRAM IS 42400000 * TO THE COMPENDI TO CHECK IF SOME MORE 42420000 * ITAB GROUP SHOULD END AT THIS POINT 42440000 SPACE 2 42460000 BLOCKEND BAL REGE,PBLCKEND EXECUTE PROGRAMBLOCKEND-PROGRAM 42480000 B COMPENDI 42500000 SPACE 2 42520000 ***** FOREND ****************************************************** 42540000 * CORRECTS THE LIGP POINTER 42560000 * INSERTS A CONTINUATION LINE IN ITAB IF THE 42580000 * FORSTATMENT CONTAINED ANY LABEL 42600000 * IF THE FORSTATMENT DID NOT CONTAIN ANY DEKLARATIONS 42620000 * THE PREVIOUSC CREATED FOR HEADENTRY IS 42640000 * ERASED 42660000 * IF ONE CONTINUATION LINE IS CREATED, FOLLOWING 42680000 * ENCLOSING FORSTATEMENTS WILL OVERLAY THE 42700000 * FIRST CONTINUATION LINE, IF LABELS OR NOT 42720000 * ETA AND SURROVNDING ITABGROUPS IG NR. IS MOVED 42740000 * TO THE OUTPUT 42760000 * FOR IS RELEASED IN THE STACK 42780000 * ENTERED FROM SEMCO 42800000 * END 42820000 * EXITS TO END 42840000 * COMPEND4 42860000 * STACKTST (IN SEMCO) 42880000 SPACE 2 42900000 FOREND L REGB,LIGP 42920000 MVC LIGP(4),0(REGB) GET PREVIOUS LIGP HEAD 42940000 L REGY,AITL CURRENT ENTRY 42960000 S REGY,KOPOOL+44 MINUS ELEVEN 42980000 TM 6(REGY),X'FF' Q. IS CONTINUATION LINE NEEDED 43000000 BZ EMPTYFOR NO 43020000 BO *+8 OVERLAY PREVIOUS CONT. LINE 43040000 LA REGY,11(0,REGY) CREATE NEW CONT. LINE 43060000 L REGB,LIGP 43080000 MVC 8(2,REGY),8(REGB) COPY IG NUMBER 43100000 MVI 6(REGY),X'FF' CONTINUATION LINE INDICATOR 43120000 NI 8(REGY),X'7F' CLEAR POSSIBLE PHI INDICATOR 43140000 MVI 5(REGY),X'2B' 43160000 BAL REG12,ITABCLEA+4 CLEA NEXT ENTRY 43180000 B *+8 43200000 EMPTYFOR BAL REG12,ITABCLEA+8 CLEAR FORHEAD FOR EMPTY FORGROUP 43220000 LA REG0,3(0,EAP) 43240000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 43260000 MVI 0(EAP),X'2B' INSERT ETA 43280000 L REGB,LIGP 43300000 MVC 1(2,EAP),8(REGB) AND CURRENT IGN IN OUTPUTBUFFER 43320000 NI 1(EAP),X'7F' CLEAR EVENTUALLY PHI 43340000 LA EAP,3(0,EAP) 43360000 L REGY,SP RELEASE FOR IN STACK 43380000 BCTR REGY,0 43400000 ST REGY,SP 43420000 BCR 15,REGF RETURN 43440000 SPACE 2 43460000 ***** PBLCKEND ****************************************************** 43480000 * ERASES EMPTY CONTINUATION LINES 43500000 * WRITES OUT THE PROGRAMBLOCK TO SYSUT 3 43520000 * LENGTH IS CALCULATED AND SAVED IN ITABLEN 43540000 * AND STORED IN THE FIRST TWO BYTES OF THE 43560000 * ITAB RECORD 43580000 * THE SC IS PICKED UP FROM SCTAB AND ENTERED IN BYTES 43600000 * 6 AND 7 43620000 * THE BLOCK IS MOVED TO THE ITABBUFFER WHERE 43640000 * FROM IT IS WRITTEN OUT. 43660000 * THE SURROUNDING BLOCKS NEW DECLARATIONS WILL 43680000 * BE OVERLAYING THE OUTWRITTEN RECORD 43700000 * AITL WILL POINT TO THE HEADENTRY'S PLACE OF THE 43720000 * BLOCK WHICH NOW WAS WRITTEN OUT 43740000 * LPBP TO THE SURROUNDING BLOCKS HEADENTRY 43760000 * LIGP TO THE SURROUNDING ITABGROUPS HEADENTRY 43780000 * AITL, LPBP AND LIGP WILL BE MODIFIED ACCORDINLY 43800000 * EPSILON, THE SURROUNDING BLOCKS PBN AND IGN WILL 43820000 * BE PUT TO THE OUTPUT 43840000 * THE BLOCK INDICATOR IN THE STACK WILL BE RELEASED 43860000 * IF STACK NOW IS EMPTY - ALPHA IN STACK - PGMEND 43880000 * WILL SET THE END BIT AND CHANGE END OF DATA 43900000 * EXIT TO EODADIN. THIS WILL CAUSE THE COMMENT 43920000 * PROGRAM TO CHECK FOR AN CORRECT ENDCOMMENT 43940000 * BUT NOTHING MORE IS TO BE PROCESSED 43960000 * FOR PROGRAM BLOCK 0, IF ANY, THE BLOCK WILL ONLY 43980000 * BE WRITTEN OUT AND NO FURTHER ACTIONS TAKEN 44000000 * ENTERED FROM END (BETA, PROC* ) 44020000 * SEMCO (PROC, PROC**) 44040000 * EXITS TO COMMEND (NORMAL) 44060000 * COMPEND4 ( PROC OR PROC** FOLLOWED BY 44080000 * END) 44100000 * TERMINATION (NOPBN0) 44120000 SPACE 2 44140000 PBLCKEND L REGY,AITL 44160000 S REGY,KOPOOL+44 SUBTRACT 11 TO EARSE 44180000 CLI 6(REGY),X'00' EMPTY 44200000 BE *-8 CONTINUATION 44220000 LA REGY,11(0,REGY) 44240000 WRTITAB S REGY,LPBP COMPUTE LENGTH OFITABSECTION 44260000 ST REGY,ITABLEN 44280000 C REGY,TWOK Q. ITAB SECTION TOO LONG 44300000 BL *+10 44320000 BAL REGB,ERR4 44340000 DC X'0426' E38 MORE THAN 184 IDENTIFIERS 44360000 MVC AITL(4),LPBP UPDATE AITL 44380000 L REGB,LPBP 44400000 MVC LIGP(4),0(REGB) UPDATE LIGP 44420000 MVC LPBP(4),4(REGB) UPDATE LPBP 44440000 MVC 0(2,REGB),ITABLEN+2 INSERT LENGTH IN HEADENTRY 44460000 MVI 5(REGB),X'2B' 44480000 STM 14,3,SAVE1 SAVE REGISTERS 44500000 SR REGZ,REGZ 44520000 IC REGZ,10(0,REGB) GET CORRENT PBN 44540000 AR REGZ,REGZ INSERT SC AT BLOCKSTART 44560000 LA REG7,SCTAB(REGZ) IN HEADING 44580000 MVC 6(2,REGB),0(REG7) 44600000 TM BITS2,X'08' IS IT PB0 A28230 44604019 BC 8,*+12 NO A28230 44608019 MVI 6(REGB),X'00' CORRECT SC A28230 44612019 MVI 7(REGB),X'00' FOR PB0 A28230 44616019 TM BITS3,FRSITB Q. FIRST BLOCK TO BE WRITEN 44620000 BZ WRT1 YES- DO NOT CHECK 44640000 STM 14,15,ERRSAVE CHECK PREVIOUS WRITE 44660000 CHECK ITABC 44680000 LM 14,15,ERRSAVE 44700000 WRT L REG7,AITABBUF ADDRESS OF BUFFER 44720000 COMPARE1 C REGY,D256 Q. MORE THAN 256 BYTES TO MOVE 44740000 BL EX1 NO MOVE ALL AT ONCE 44760000 MVC 0(256,REG7),0(REGB) YES- MOVE A SECTION OF 256 44780000 LA REGB,256(0,REGB) BYTES AT A TIME 44800000 LA REG7,256(0,REG7) 44820000 S REGY,D256 44840000 C REGY,D256 Q. STILL MORE THAN 256 LEFT 44860000 BH COMPARE1+8 YES MOVE NEXT SECTION 44880000 EX1 EX REGY,MOVE4 MOVE A SECTION OF LESS THAN 256 44900000 LA EAP,0(REGY,REG7) 44920000 L REG7,AITABBUF LOAD ADD. OF ITABBUFFER 44940000 L REGY,UT3ADD DCB 44960000 L REGL,ITABLEN LENGTH 44980000 WRITE ITABC,SF,(REGY),(REG7),(REGL) 45000000 LM 14,3,SAVE1 45020000 TM BITS2,X'08' Q. PB0 WAS WRITTEN 45040000 BCR 1,REGE BRANCH BACK IF TERBIT ON 45060000 L REGB,AITL CLEAR 45080000 MVI 0(REGB),X'00' NEXT 45100000 MVC 1(10,REGB),0(REGB) ITABENTRY 45120000 LA REG0,4(0,EAP) 45140000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 45160000 MVI 0(EAP),X'2A' INSERT EPSILON 45180000 L REGB,LPBP 45200000 MVC 1(1,EAP),10(REGB) PBN 45220000 L REGB,LIGP 45240000 MVC 2(2,EAP),8(REGB) IGN 45260000 NI 2(EAP),X'7F' CLEAR FIRST BIT OF IGN (PHI IND) 45280000 LA EAP,4(0,EAP) 45300000 L REGY,SP RELEASE 45320000 BCTR REGY,0 TOPBYTE 45340000 ST REGY,SP IN STACK 45360000 TM BITS1,X'01' Q. TERMINATION BIT ON 45380000 BCR 1,REGE YES- RETURN TO ENDMISS PGM. 45400000 CLI 0(REGY),X'00' Q. STACK EMPTY 45420000 BE PGMEND YES- LOGICAL PROGRAM ENP 45440000 BCR 15,REGE RETURN 45460000 PGMEND OI BITS2,ENDBIT SET ENDBIT 45480000 LA REGOX,EODADIN NEW.EOD ADDRESS 45500000 ST REGOX,EODIN 45520000 B COMMEND 45540000 WRT1 OI BITS3,FRSITB DON'T CHECK FIRST TIME 45560000 B WRT 45580000 CNOP 0,4 45600000 MOVE4 MVC 0(1,REG7),0(REGB) PBLCKEND MOVE FOR ITAB 45620000 SCTAB DS CL510 45640000 SPACE 2 45660000 ***** COMMENT ****************************************************** 45680000 * THREE ENTRIES 45700000 * 1 COM FOR THE ALGOL WORD COMMENT 45720000 * SETS CODIT=1, CHECKS THAT COMMENT IS IN 45740000 * A LEGAL POSSITION 45760000 * 2 COMERR FOR ERRORS IN DECLARATIONS ALL CHAR 45780000 * TO NEXT SEMICOLON WILL BE SKIPPED 45800000 * SET COBIT AND DELTABIT=1 45820000 * 3 COMMEND ENTERED AFTER AN END IS FOUND. 45840000 * SKIPPS ALL CHARACTERS TO NEXT ., OR END 45860000 * OR ELSE 45880000 * SETS THE COBIT =0 45900000 SPACE 2 45920000 COMERR OI BITS2,X'40' SET COBIT AND 45940000 OI BITS1,X'20' DELTABIT ON 45960000 B COMCEE2 45980000 COMMEND NI BITS2,X'BF' SET COBIT TO 0 46000000 BC 15,COMCED2 46020000 COM OI BITS2,X'40' SET COBIT TO I 46040000 LR REGM,EAP 46060000 BCTR REGM,0 46080000 CLI 0(REGM),X'0C' Q. BEGIN IN O/P 46100000 BE COMCED2 46120000 BCTR REGM,0 46140000 BCTR REGM,0 46160000 CLI 0(REGM),X'0B' Q. BETA IN O/P 46180000 BE COMCED2 46200000 CLI 0(REGM),X'29' Q. DELTA IN O/P 46220000 BE COMCED2 46240000 BCTR REGM,0 46260000 CLI 0(REGM),X'0D' SEMICOLON IN O/P 46280000 BE COMCED2 46300000 BAL REGB,ERR7 E18 46320000 DC X'0412' 46340000 COMCED2 LA REGI,1(0,REGI) INCREASE REGI BY I 46360000 COMCEE2 BALR REGIX,0 46380000 SR REGZ,REGZ 46400000 TRT 0(73,REGI),COMTABLE SCAN THE COMMENT 46420000 LA REGM,0(REGZ,REGIX) BRANCH WITH HELP OF DISP. 46440000 BCR 15,REGM TO APPROPRIATE SUB. PGM. 46460000 SPACE 2 46480000 ***** COMAPOST ***** 46500000 * IF AN END COMMENT IS PROCESSED, COBIT= 0, CHECK IF 46520000 * APOSTROPHE IS THE START OF END OR ELSE 46540000 * OTHERWISE RETURN TO SCAN THE COMMENT AGAIN 46560000 SPACE 2 46580000 COMAPOST TM BITS2,X'40' Q. COBIT ON 46600000 BO COMCED2 YES- RETURN TO SCANNING AGAIN 46620000 MVI FBYTE,X'FF' SET FBYTE 46640000 BC 15,ENTRAPR RETUN TO APOSTROFPROGRAM 46660000 COMZETA B CIB ZETA - RETURN TO COMERR 46680000 SPACE 2 46700000 ***** COMPOINT ***** 46720000 * CHECK FOR SEMICOLON ., IF NOT RETURN 46740000 SPACE 2 46760000 COMPOINT LA REGB,COMCEE2 RETURN IF NOT SEMCOLON 46780000 BAL REG12,FINDSEMC 46800000 SPACE 2 46820000 ***** COMSEMCO ***** 46840000 * ENDELSE BIT ON- END COMMENT AFTER BEGIN OR BETA 46860000 * ENDED WITH A ., MEANS THAT THE END MIGHT ALSO 46880000 * CLOSE AN FORSTATEMENT OR A PROCEDURE 46900000 * ENDBIT ON- FINAL END HAS BEEN REACHED NOTHING IS TO 46920000 * FOLLOW THIS COMMENT IN THE CORRECT CASE 46940000 * AN SEMICOLON AFTER AN COMMENT IS NOT TO BE COUNTED 46960000 * THAT IS COBIT= 1 AND DELTABIT=0 RETURN TO 46980000 * TEST OTHERWISE RETURN VIA SEMICOLON PROGRAM 47000000 SPACE 2 47020000 COMSEMCO TM BITS2,X'01' END ELSE BIT 47040000 BO COMPEND2 YES 47060000 TM BITS2,ENDBIT Q.FINAL END COMMENT HAS ENDED 47080000 BO READROUT YES OK 47100000 TM BITS2,X'40' Q. COMMENT 47120000 BZ SEMCO NO 47140000 TM BITS1,X'20' Q. DELIMITER ERROR 47160000 BO SEMCO YES 47180000 LA REGI,1(0,REGI) FOR A COMMENT SKIP SEMICOLON 47200000 B TESTLOOP 47220000 SPACE 2 47240000 ***** FOR ****************************************************** 47260000 * INCREASES IG AND FSN NUMBER 47280000 * MAKES ENTRIES IN SCOPE AND GROUPTABEL 47300000 * MOVES FOR (18) TO OUTPUT FOLLOWED BY NEW IG NUMBER 47320000 * CHECKS IF PROC IN STACK, IF YES PROC IS CHANGED TO 47340000 * PROC** 47360000 * PUTS FOR IN STACK 47380000 * AN FORHEAD ENTRY IS MADE IN ITAB 47400000 * THE RETURN IS TO TEST 47420000 SPACE 2 47440000 FOR LA REG0,3(0,EAP) 47460000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 47480000 LH REGY,IGC INCREASE ITABGROUPNUMBER 47500000 LA REGY,1(0,REGY) 47520000 MVI 0(EAP),X'18' MOVE 'FOR' 47540000 STH REGY,IGC AND IGN 47560000 MVC 1(2,EAP),IGC 47580000 LA EAP,3(0,EAP) TO OUTPUTBUFFER 47600000 CLI FSN,X'FF' Q. MORE THAN 255 FOR STATEMENTS 47620000 BNE *+10 47640000 BAL REGB,ERR4 47660000 DC X'0429' E41 47680000 IC REGZ,FSN INCREASE FSN 47700000 LA REGZ,1(0,REGZ) 47720000 STC REGZ,FSN 47740000 LA REG12,SPTAB-1 47760000 AR REG12,REGZ 47780000 L REGY,LPBP 47800000 MVC 0(1,REG12),10(REGY) MAKE ENTRY IN SCOUPTABLE 47820000 NI BITS1,X'7F' BEGBIT= 0 47840000 L REG12,SP 47860000 C REG12,ATOPSTAK Q. STACK OVERFLOW 47880000 BL *+10 47900000 BAL REGB,ERR4 47920000 DC X'0414' E20 47940000 CLI 0(REG12),X'0C' Q. PROC IN STACK 47960000 BNE NOPROCBY NO 47980000 MVI 0(REG12),X'14' MAKE PROC BE PROC** 48000000 NI BITS1,X'BF' PROBIT=0 48020000 CLI PZ,X'00' Q.ALLPARAMETERS SPECIFIED 48040000 BE *+8 YES 48060000 BAL REGOX,ERROR10 NO- GENERATE E10 48080000 NOPROCBY L REG12,SP 48100000 LA REG12,1(0,REG12) INCREASE STACKPOINTER 48120000 MVI 0(REG12),X'18' PUT FOR INTO STACK 48140000 ST REG12,SP 48160000 LH REG12,IGC 48180000 AR REG12,REG12 48200000 AH REG12,IGC 48220000 A REG12,AGT 48240000 L REGY,LIGP 48260000 MVC 0(2,REG12),8(REGY) ENTRY INTO GROUPTABLE 48280000 STC REGZ,2(REG12) 48300000 NI 0(REGOX),X'7F' CLEAR POSSIBLE PHI IND. 48320000 L REGY,AITL 48340000 MVC 0(4,REGY),LIGP CONSTRUCT FOR HEADENTRY IN ITAB 48360000 MVI 5(REGY),X'2B' 48380000 MVC 8(2,REGY),IGC 48400000 ST REGY,LIGP UPDATE LIGP 48420000 BAL REG12,ITABCLEA CHECK AND CLEAR NEXT ITABENTRY 48440000 LA REGI,1(0,REGI) 48460000 B TESTLOOP 48480000 SPACE 2 48500000 ***** TYPE ****************************************************** 48520000 * ENTRED FOR INTEGER, REAL AND BOOLEAN 48540000 * TESTS FOR NEWBLOCK, BEGBIT, AND IF IDENTIFIER IS 48560000 * SPECIFIED, PROBIT 48580000 * MOVES INTERNAL NAME CHARACTERISTICS AND PBN TO ITAB 48600000 * CHECKS THE IDENTIFIER FOR VALIDITY AND MOVES UP TO 48620000 * 6 CHARACTERS TO ITAB EXTERNAL NAME 48640000 * IF THE FIRST CHARACTER FOUND IS AN OPOSTROPHE THE 48660000 * CHECK IS VIA APOSTROF, DELIMITER AND TYPESPEC 48680000 * FOR ARRAY OR PROCEDURE (FBYTE=F0) 48700000 SPACE 2 48720000 TYPE TM BITS1,X'40' Q PROBIT = 1 48740000 BO SPECENT YES 48760000 TM BITS1,X'80' Q BEGBIT = 1 48780000 BZ *+16 48800000 ST REGX,SAVE1 IF YES GO TO BEGI PGM 48820000 BAL REGX,BEG1 48840000 L REGX,SAVE1 48860000 L REGY,AITL MOVE CHARACTERISTICS TO ITAB 48880000 MVI 6(REGY),X'C0' TO THE 7TH AND 8TH 48900000 MVI 7(REGY),X'30' BYTE OF THE ENTRY 48920000 LA REGB,2(REGL,REGX) MODIFIY THE LAST 4 BITS WITH 48940000 MVN 7(1,REGY),0(REGB) INFORMATION FROM THE WITAB 48960000 L REGB,LPBP 48980000 MVC 8(1,REGY),10(REGB) MOVE IN PROGRAMBLOCK NUMBER 49000000 TYPEDAFI LA REGI,1(0,REGI) GET NEXT CHARACTER 49020000 CLI 0(REGI),X'40' Q IS CHAR A LETTER 49040000 BNL TYPENAME YES 49060000 CLI 0(REGI),X'2B' Q IS IT BLANK 49080000 BE TYPEDAFI 49100000 CLI 0(REGI),X'2F' Q. IS IT ZETA 49120000 BNE *+12 49140000 LA REGIX,TYPEDAFI+4 CHANGE INPUT 49160000 BC 15,CIB BUFFER 49180000 CLI 0(REGI),X'2E' Q IS IT APOSTROPHE 49200000 BE *+12 49220000 LA REGH,TYPEDAFI STORE RETURN ADDR 49240000 B IERSPEC GO TO ERRORROUTINE 49260000 MVI FBYTE,X'F0' MOVE F0 TO FBYTE 49280000 BC 15,ENTRAPR CHECK FOR TYPE ARRAY OR PROC 49300000 TYPENAME L IN,AITL GET ITAB POINTER 49320000 MVC 0(1,IN),0(REGI) MOVE FIRST CHAR. TO ITAB 49340000 LA IN,1(0,IN) INCREASE POINTER 49360000 LA K,1 INITILIZE COUNTER 49380000 LA REGIX,*+8 RETURN IF CHANGE OF I/P BUF. NEEDED 49400000 TYPENM02 LA REGI,1(0,REGI) GET NEXT CHAR. 49420000 CLI 0(REGI),X'2F' Q. LETTER, ZETA OR SOMETHING ELSE 49440000 BE CIB CHANGE I/P BUFFER 49460000 BL TLISTSE CHECK FURTHER 49480000 C K,KOPOOL+24 Q. 6 CHAR. ALLREADY MOVED IN 49500000 BE TYPENM02 YES 49520000 MVC 0(1,IN),0(REGI) NO- MOVE IN NEXT CHAR 49540000 LA IN,1(0,IN) INCREASE 49560000 LA K,1(0,K) POINTERS 49580000 B TYPENM02 TAKE NEXT CHAR. 49600000 TLISTSE CLI 0(REGI),X'2B' Q. BLANK 49620000 BE TYPENM02 49640000 CLI 0(REGI),X'25' Q. COMMA 49660000 BE TYPECOMA 49680000 LA REGH,TYPEDAFI RETURN ADDRESS FOR IER 49700000 LA REGB,IER RETURN ADDRESS IF NO SEMICOLON 49720000 BAL REG12,FINDSEMC LOOK FOR SEMICOLON 49740000 SPACE 2 49760000 ***** TYPESEMC ****** 49780000 * SEMICOLON FOUND 49800000 * END OF THIS DECLARATION 49820000 * DELTABIT IS TURNED ON AND THE RETURN TO TEST IS 49840000 * VIA SEMCO 49860000 SPACE 2 49880000 TYPESEMC BAL REG12,ITABCLEA CLEAR NEXT ITAB ENTRY 49900000 OI BITS1,X'20' SET DELTABIT TO ONE 49920000 B SEMCO GO TO SEMICOLON PROGRAM 49940000 SPACE 2 49960000 ***** TYPECOMA ****** 49980000 * AN COMMA ENDED THE IDENTIFIER 50000000 * THE INTERNAL NAME IS COPIED AND TYPEPROGRAM 50020000 * UTILIZED AGAIN 50040000 SPACE 2 50060000 TYPECOMA L REGA,AITL 50080000 BAL REG12,ITABCLEA CHECK AND CLEAR NEXT ITABENTRY 50100000 MVC 6(3,REGY),6(REGA) COPY ID AND PBN FIELDS 50120000 B TYPEDAFI RETURN TO CHECK NEXT IDENTIFIER 50140000 SPACE 2 50160000 ***** IER ****************************************************** 50180000 * IDENTIFIER ERROR ROUTINE 50200000 * HAS 2 ENTRIES 50220000 * 1. IERSPEC IF FIRST CHARACTER IS IN ERROR, E5 50240000 * 2. IER ANY OTHER CHARACTER, E16 50260000 * THE RETURN 50280000 * 1. VIA REGH IF AN COMMA IS FOUND AFTER THE 50300000 * IDENTIFIER IN ERROR 50320000 * 2. TO TEST VIA SEMCO IF AN SEMICOLON IS FOUND 50340000 * 3. TO PROCFIN IF AN RIGHT PARENTHESIS IS FOUND 50360000 * AND THE FMBIT IS ON WHITCH INDICATES 50380000 * THAT THE FORMAL PARAMETER LIST OF A 50400000 * PROCEDURE IS UNDER PROCESS 50420000 * REGH MIGHT LEAD TO TYPEDAFI 50440000 * IDCHECK 50460000 * PROCID 50480000 SPACE 2 50500000 IERSPEC BAL REGB,ERR7 50520000 DC X'0405' E5 50540000 B *+10 50560000 IER BAL REGB,ERR2 50580000 DC X'0010' E16 50600000 L IN,AITL RESET IN TO START 50620000 MVI 0(IN),X'00' CLEAR EXTERNAL NAME PART 50640000 MVC 1(5,IN),0(IN) 50660000 IERCOMMA LA REGI,1(0,REGI) 50680000 LA REGB,IERSELSE RETURN IF NO SEMICOLON FOUND 50700000 BAL REG12,FINDSEMC LOOK FOR SEMICOLON 50720000 IERSEMCO L REGY,AITL SEMICOLON FOUND - END OF DECLARATION 50740000 BAL REG12,ITABCLEA+8 CLEAR ITAB ENTRY 50760000 TM BITS3,FMBIT Q. FORMAL PARAMETER LIST PROCESSED 50780000 BO SCYES3-8 YES RETURN TO PROCEDURE END 50800000 OI BITS1,X'20' DELTABIT = 1 50820000 NI BITS2,X'EF' VALBIT=0 50840000 MVC KB(2),KOPOOL CKB = 00 50860000 B SEMCO RETURN TO TEST VIA SEMCO 50880000 IERSELSE CLI 0(REGI),X'25' Q COMMA 50900000 BCR 8,REGH RETURN IF COMMA FOUND 50920000 TM BITS3,FMBIT Q. FORMAL PARAMETER LIST PROCESSED 50940000 BZ IERCOMMA NO 50960000 CLI 0(REGI),X'26' Q CHAR IS RIGHT PARENTHESIS 50980000 BE PROCFIN YES GO TO PROCEDURE END HANDLING 51000000 B IERCOMMA CONTINUE CHECKING NEXT CHAR 51020000 SPACE 2 51040000 ***** CODE ****************************************************** 51060000 * SETS THE PROBIT TO ZERO 51080000 * CHECKS THAT CODE IS IN THE CORRECT PLACE AND IS 51100000 * FOLLOWED BY A SEMICOLON 51120000 * CORRECTS THE INTERNAL NAME OF THE PROCEDURE 51140000 * TRANSFER THE NAME IN EXTERNAL FORM TO OUTPUT 51160000 * RETURNS VIA PROGRAM BLOCK END TO TEST 51180000 SPACE 2 51200000 CODE NI BITS1,X'BF' PROBIT=0 51220000 CLI PZ,X'00' Q. ALL PARAMETERS SPECIFIED 51240000 BZ *+8 YES 51260000 BAL REGOX,ERROR10 NO- GENERATE E10 51280000 L REGY,SP 51300000 CLI 0(REGY),X'0C' PROC IN STACK 51320000 BNE CODERR IF NO BRANCH TO ERROR 51340000 LR REGL,EAP 51360000 S REGL,KOPOOL+12 51380000 CLI 0(REGL),X'29' Q. DELTA IN O/P 51400000 BNE CODERR IF NO BRANCH TO ERROR 51420000 L REGY,LPBP 51440000 S REGY,KOPOOL+44 GET PROCEDURE NAME 51460000 XI 7(REGY),X'80' INTERNAL NAME IS CORRECTED 51480000 TM 19(REGY),X'80' Q. TYPE PROCEDURE 51500000 BZ *+8 51520000 XI 29(REGY),X'80' YES- CORRECT SECOND NAME ENTRY 51540000 LA REG0,9(0,EAP) 51560000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 51580000 MVI 0(EAP),X'3C' TRANSFER GAMMA 51600000 MVC 1(6,EAP),0(REGY) TRANSFER NAME AND 51620000 TR 1(6,EAP),RETRANS CONVERT TO EXTERNAL CODE 51640000 MVC 7(1,EAP),RETRANS INSERT EXTERNAL BLANKS 51660000 MVC 8(1,EAP),RETRANS 51680000 LA EAP,9(0,EAP) 51700000 OI BITS1,X'20' DELTABIT.=1 51720000 SEARCH LA REGB,NOSEMC RETURN IF NO SEMICOLON FOUND 51740000 LA REGE,SEMCO RETURN ADD. FOR PBLCKEND 51760000 LA REGI,1(0,REGI) 51780000 BAL REG12,FINDSEMC Q. SEMICOLON FOLLOWS 51800000 B PBLCKEND SEMICOLON FOUND- GO TO PBLCKEND 51820000 NOSEMC BAL REGB,ERR7 51840000 DC X'040F' E15 51860000 LA REGB,FINDSEMC Q WAS A PERIOD FOUND 51880000 CR REGB,REGIX 51900000 BE PBLCKEND NO 51920000 BCTR REGI,0 YES- 51940000 MVI 0(REGI),X'2D' MOVE IN A PERIOD 51960000 BCTR REGI,0 DECREASE REGI, WILL BE INCREASED 51980000 B PBLCKEND BY SEMCO. RETURN VIA PBLCKEND 52000000 * AND SEMCO TO TEST 52020000 CODERR BAL REGB,ERR7 52040000 DC X'0418' E24 52060000 B COMERR SKIP TO NEXT SEMICOLON 52080000 SPACE 2 52100000 IEX11002 CSECT 52120000 SPACE 2 52140000 ***** SPEC ****************************************************** 52160000 * ENTERED FOR LABEL AND STRING 52180000 * CHECKS THAT THEY ARE IN PROCEDURE HEAD 52200000 SPACE 2 52220000 SPEC TM BITS1,X'40' Q. PROBIT ON 52240000 BO SPECENT YES PROCESS SPECIFIED LABEL OR STRING 52260000 BAL REGB,ERR7 52280000 DC X'0419' E25 52300000 B COMERR SKIP TO NEXT SEMICOLON 52320000 SPACE 2 52340000 ***** SPECENT ****************************************************** 52360000 * ENTERED FOR SPECIFICATIONS FROM 52380000 * TYPE 52400000 * SPEC 52420000 * ARRAY 52440000 * SWITCH 52460000 * PROCEDURE 52480000 * SAVES IN KB THE CHARACTERISTICS TAKEN FROM THE 52500000 * DELIMITER TABLE 52520000 SPACE 2 52540000 SPECENT LA REGY,1(REGL,REGX) MOVE IN IDFIELD 52560000 MVC KB(2),0(REGY) 52580000 SPACE 2 52600000 ***** IDCHECK ****************************************************** 52620000 * ENTERED FROM VALUE 52640000 * TYPEARRAY 52660000 * TYPEPROCEDURE 52680000 * SPECENT 52700000 * CHECKS THE NAME FOR FORMAL PARAMETERS 52720000 * FINDS THE ENTRY IN ITAB AND INSERTS THERE THE 52740000 * CHARACTERISTICS AND PROGRAM BLOCK NUMBER 52760000 * DECREASES THE PARAMETER COUNT PZ BY ONE FOR EACH 52780000 * CORRECT PARAMETER FOUND 52800000 * IF A COMMA ENDS THE IDENTIFIER IDCHECK WILL BE 52820000 * ACTIVATED AGIAN 52840000 * IF A SEMICOLON ENDS THE DELIMITER THE RETURN IS TO 52860000 * TEST VIA SEMICOLON PROGRAM 52880000 SPACE 2 52900000 IDCHECK LA REGI,1(0,REGI) GET NEXT CHAR 52920000 CLI 0(REGI),X'39' Q IS IT A LETTER 52940000 BNH IDNOLETR NO 52960000 MVC IDBUCKET(6),KOPOOL CLEAR BUCKET WITH ZEROS 52980000 LA IN,IDBUCKET 53000000 LA REGL,1 53020000 MVC 0(1,IN),0(REGI) MOVE FIRST CHAR. TO BOCKET 53040000 LA IN,1(0,IN) 53060000 LA REGIX,*+8 RETURN IF CIB NEEDED 53080000 IDLOOP LA REGI,1(0,REGI) GET NEXT CHAR. 53100000 CLI 0(REGI),X'2F' Q ZETA 53120000 BE CIB YES 53140000 BL IDSEARCH SOMETHING ELSE 53160000 C REGL,KOPOOL+24 LETTER OR DIGIT 53180000 BE IDLOOP Q 6 CHAR MOVED ALLREADY YES 53200000 MVC 0(1,IN),0(REGI) NO MOVE CHAR 53220000 LA IN,1(0,IN) INCREASE POINTERS 53240000 LA REGL,1(0,REGL) 53260000 B IDLOOP TAKE NEXT CHAR. 53280000 IDNOLETR CLI 0(REGI),X'2B' FIRST CHAR WAS NOT LETTER. Q. BLANK 53300000 BE IDCHECK YES . GET NEXT CHAR 53320000 CLI 0(REGI),X'2F' Q IS IT A ZETA 53340000 BNE *+12 53360000 LA REGIX,IDCHECK+4 YES- CHANGE I/P-BUFFER 53380000 BC 15,CIB BUFFER 53400000 CLI 0(REGI),X'2E' Q IS IT A APOSTROPHE 53420000 BE *+12 53440000 LA REGH,IDCHECK NO- SET RETURN ADD AND GOTO 53460000 B IERSPEC IDENTIFIER ERROR ROUTINE 53480000 MVI FBYTE,X'F0' SET FBYTE- LOOK FOR TYPE 53500000 BC 15,ENTRAPR ARRAY OR TYPE PROC 53520000 IDSELSE BAL REGB,ERR2E 53540000 DC X'0010' E16 53560000 LA REGH,IDCHECK RETURN ADD FOR IER 53580000 B IERCOMMA GO TO IDENTIFIER ERROR ROUTINE 53600000 IDBUCKET DC 6X'00' 53620000 IDSEARCH CLI 0(REGI),X'2B' Q BLANK 53640000 BE IDLOOP 53660000 CLI 0(REGI),X'25' Q COMMA 53680000 BE IDCOMMA 53700000 LA REGB,IDSELSE IF NOT SEMICOLON FOUND 53720000 BAL REG12,FINDSEMC LOOK FOR SEMICOLON 53740000 OI BITS1,X'20' SEMICOLON FOUND SET DELTABIT 53760000 IDCOMMA CLC PRIMPAR(4),KOPOOL Q. ARE THERE ANY PARAMETER 53780000 BE NOTFOUND NO 53800000 L REGPS,PRIMPAR GET FIRST PARAMETER 53820000 SPACE 2 53840000 ***** COMPID ****** 53860000 * A LOOP TO FIND THE PARAMETER IN ITAB 53880000 SPACE 2 53900000 COMPID CLC IDBUCKET(6),0(REGPS) CHECK IF IDENTIFIER FOUND 53920000 BE IDVALCHK FOUND 53940000 LA REGPS,11(0,REGPS) NOT FOUND TRY NEXT PARAMETER 53960000 C REGPS,AITL IF THERE ARE ANY LEFT 53980000 BNE COMPID YES 54000000 NOTFOUND BAL REGB,ERR2E 54020000 DC X'001B' E27 54040000 B IDENDER 54060000 IDVALCHK TM BITS2,X'10' VALUE CALL 54080000 BO VALDLB2 YES - GO TO VAL ROUTINE 54100000 TM 6(REGPS),X'06' Q SPECIAL USE BITS ON 54120000 BZ IDCHKEND NO 54140000 BAL REGB,ERR2E YES CREATE 54160000 DC X'001A' E26 54180000 B IDENDER GET NEXT IDENTIFIER 54200000 SPACE 2 54220000 ***** IDCHKEND ****** 54240000 * INSERTS CHARACTERISTICS AND PBN, DECRESES PZ 54260000 * IF BOTH VALUE AND NAME BIT ON BYTE 7 EQVALS 30 54280000 * A VALUE SPECIFICATION HAS BEEN MADE EARLIER 54300000 * SO IT IS CORRECTED TO BE A CALL BY VALUE 54320000 SPACE 2 54340000 IDCHKEND L REGB,LPBP 54360000 MVC 8(1,REGPS),10(REGB) INSERT PBN 54380000 OC 6(2,REGPS),KB 54400000 IC REGB,PZ CORRECT IDFIELD IS CREATED 54420000 BCTR REGB,0 PZ= PZ-1 54440000 STC REGB,PZ 54460000 TM 7(REGPS),X'30' Q. VALUE BIT ON 54480000 BM *+8 54500000 VALCALL NI 7(REGPS),X'EF' YES- ZERO NAME BIT 54520000 IDENDER TM BITS1,X'20' Q. DELTABIT ON 54540000 BZ IDCHECK NO-GET NEXT IDENT. 54560000 MVC KB(2),KOPOOL YES CLEAR IDFIELD 54580000 NI BITS2,X'EF' SET VALBIT TO ZERO 54600000 BC 15,SEMCO GO TO SEMICOLON PROGRAM. 54620000 SPACE 2 54640000 ***** VALUE ****** 54660000 * CHECKS THAT SPECIFICATION IS IN A PROCEDURE HEAD 54680000 * EXITS FIRST TO IDCHECK TO FIND THE PARAMETER 54700000 * WILL THEN RETURN TO VALDLB2 FOR FUTHER CHECKS AND 54720000 * TO INSERT THE VALUE BIT IN THE INTERNAL NAME 54740000 SPACE 2 54760000 VALUE TM BITS1,X'40' Q PROCEDDRE PROCECED 54780000 BZ *+12 NO- ERROR 54800000 OI BITS2,X'10' YES- SET VALUE BIT TO ONE 54820000 BC 15,IDCHECK AND GO TO IDCHEK 54840000 BAL REGB,ERR7 E28 VALVE 54860000 DC X'041C' OUTSIDE PROC. 54880000 B COMERR SKIP TO NEXT SEMICOLON 54900000 VALDLB2 TM 7(REGPS),X'20' Q. VALUE BIT ON IN IDENTIFIER 54920000 BZ *+14 NO 54940000 BAL REGB,ERR2E 54960000 DC X'001E' E30 54980000 B IDENDER GET NEXT IDENTIFIER 55000000 TM 6(REGPS),X'06' Q SPECIAL USE BIT ENTERED 55020000 BZ *+18 NO 55040000 BAL REGB,ERR7 55060000 DC X'041D' E29 55080000 XI 7(REGPS),X'30' MOVE IN IDFIELD 55100000 B IDENDER GET NEXT IDENTIFIER 55120000 MVI 7(REGPS),X'30' CORRECT - MOVE IN IDFIELD 55140000 B IDENDER GET NEXT IDENTIFIER 55160000 SPACE 2 55180000 ***** TYPEARRAY ***************************************************** 55200000 * ENTERED FROM TYPESPEC 55220000 * TEST FOR PROBIT, BEGBIT 55240000 * INSERTS CHARACTERISTICS IN INTERNAL NAME WITHOUT 55260000 * DESTROYING THE TYPE SPECIFICATIONS ENTERED BY 55280000 * THE TYPE PROGRAM 55300000 * JOINS ARRAY PROGRAM 55320000 * FOR A SPECIFIED TYPEARRAY THE EXIT IS TO IDCHECK 55340000 SPACE 2 55360000 TYPEARRY TM BITS1,X'40' Q IS PROBIT ON 55380000 BO TARYDHB3 YES - SPECIFICATION 55400000 TM BITS1,X'80' Q. BEGBIT ON 55420000 BZ *+16 55440000 ST REGX,SAVE1 YES 55460000 BAL REGX,BEG1 GO AND PROCESS PROGRAMBLOCK HEAD 55480000 L REGX,SAVE1 55500000 L IN,AITL 55520000 MVI 6(IN),X'C8' MOVE IN 55540000 XI 7(IN),X'34' ID FIELD 55560000 BC 15,ARRYDME1 GO TO ARRAY PROCECING 55580000 TARYDHB3 MVI KB,X'CA' MOVE IN 55600000 OI KB+1,X'04' TYPE ARRAY SPECIFICATION ID 55620000 BC 15,IDCHECK 55640000 SPACE 2 55660000 ***** ARRAY ****************************************************** 55680000 * TESTS FOR PRO AND BEGBIT 55700000 * ENTERS CHARACTERISTICS IN INTERNAL NAME 55720000 * TYPEARRAY JOINS HERE 55740000 * PBN IS ENTERED IN INTERNAL NAME 55760000 * 09 FOR ARRAY IS MOVED TO OUTPUT 55780000 * THE NAME IS CHECKED AND MOVED TO OUTPUT AND ITAB 55800000 * SHOULD BE FOLLOWED BY A COMMA OR LEFT PARENTHISIS 55820000 * SETS N (NUMBER OF ARRAYS WITH SAME DIMENSIONS) TO ONE 55840000 SPACE 2 55860000 ARRAY TM BITS1,X'40' Q PROBIT ON 55880000 BO SPECENT YES 55900000 TM BITS1,X'80' Q BEGBITI ON 55920000 BZ *+16 55940000 ST REGX,SAVE1 YES- GO TO PROCESS PROGRAMBLOCKHEAD 55960000 BAL REGX,BEG1 55980000 L REGX,SAVE1 56000000 L IN,AITL 56020000 MVI 6(IN),X'C8' MOVE IN 56040000 MVI 7(IN),X'06' IO-FIELD 56060000 ARRYDME1 L REGB,LPBP 56080000 MVC 8(1,IN),10(REGB) MOVE IN PROGRAMBLOCK NR. 56100000 LA REGB,9(0,IN) MOVE ADD OF AITL+9 56120000 ST REGB,DIM TO DIM 56140000 BAL REGOX,COB 56160000 MVI 0(EAP),X'09' MOVE ARRAY ID TO O/P 56180000 LA EAP,1(0,EAP) 56200000 ARRYNAME LA REGI,1(0,REGI) GET FIRST CHAR 56220000 CLI 0(REGI),X'39' Q. LETTER 56240000 BNH ARNAMESE NO 56260000 TM BITS1,X'04' Q. LISTBIT ON 56280000 BO ARRYMULT YES 56300000 MVC N(1),KOPOOL+7 SET N=1 56320000 ARRYID BAL REGB,IDCHECK1 CHECK, MOVE IDENT. TO ITAB AND O/P 56340000 ARRYSE CLI 0(REGI),X'2B' Q. BLANK 56360000 BE IDCHECK2 56380000 CLI 0(REGI),X'06' Q LEFT PARENTHESIS 56400000 BE ARRYLPAR 56420000 CLI 0(REGI),X'25' Q. COMMA 56440000 BE ARCOMMA 56460000 ARRAYERR BAL REGB,ERR2 SOMETHING ELSE FOUND 56480000 DC X'0010' E16 56500000 BAL REGOX,COB 56520000 MVI 0(EAP),X'3D' MOVE IN RHA 56540000 LA EAP,1(0,EAP) 56560000 ARYEXIT L REGY,AITL 56580000 BAL REG12,ITABCLEA+8 CLEAR ITAB-ENTRY 56600000 NI BITS1,X'F7' TURN OFF ARBIT 56620000 LA RET,TESTLOOP RESET RETURN REGISTER TO MAINLOOP 56640000 B COMERR SKIP TO NEXT SEMICOLON 56660000 ARNAMESE CLI 0(REGI),X'2B' Q. NAME STARTS WITH BLANK 56680000 BE ARRYNAME 56700000 CLI 0(REGI),X'2F' Q. ZETA 56720000 BNE *+12 56740000 LA REGIX,ARRYNAME+4 56760000 B CIB 56780000 BAL REGB,ERR7 FIRST CHAR. OF NAME IN ERROR 56800000 DC X'0405' 56820000 B ARYEXIT DELETE DECLARATION 56840000 SPACE 2 56860000 ***** ARRAYPAR ****** 56880000 * ENTERED WHEN A LEFT PARENTHESIS IS FOUND AFTER THE 56900000 * NAME 56920000 * INITILIZES D DIMENSION COUNTER=0 56940000 * SETS THE ARBIT 56960000 * C PARENTHESIS COUNT=1 56980000 * SEARCHES FOR A SLASH 57000000 * MOVES OUT SUBSCRIPT BRACKETS TO OUTPUT 57020000 * EXITS TO ARRAYLIST 57040000 SPACE 2 57060000 ARRYLPAR OI BITS1,X'08' ARBIT = 1 57080000 LA REGOX,1 57100000 STH REGOX,C C=1 57120000 LA REGOX,0 57140000 STC REGOX,D D=0 57160000 LA REGI,1(0,REGI) GET NEXT CHAR 57180000 ARRYSLSH CLI 0(REGI),X'03' Q SLASH 57200000 BE ARRYLSQB YES- MOVE IN LEFT SQ. BRACKET 57220000 CLI 0(REGI),X'2B' Q CHAR IS BLANK 57240000 BE ARRYSLSH-4 YES-GET NEXT CHAR. 57260000 CLI 0(REGI),X'2F' Q CHAR IS ZETA 57280000 BNE *+12 NO-GOTO ERROR ROUTIEN 57300000 LA REGIX,ARRYSLSH YES- CHANGE 57320000 BC 15,CIB INPUT BUFFER 57340000 BAL REGB,ERR2 57360000 DC X'001F' E31 57380000 BCTR REGI,0 57400000 ARRYLSQB BAL REGOX,COB CHECK IF O/P AREA FILLED 57420000 MVI 0(EAP),X'08' MOVE IN LEFT SQUAREBRACKET 57440000 LA EAP,1(0,EAP) INCREASE 57460000 LA REGI,1(0,REGI) POINTERS 57480000 B LIST GO TO PROCESS ARRAY LIST 57500000 SPACE 2 57520000 ***** ARCOMMA ****** 57540000 * COPIES INTERNAL PART OF ITAB ENTRY SETS THE LISBIT 57560000 * EXITS TO ARRAYNAME TO CHECK FIRST CHARACTER OF NEXT 57580000 * NAME. THE LIST BIT WILL THEN CAUSE ARRAYMULT 57600000 * TO BE EXECUTED BEFORE THE REST OF THE NAME 57620000 * IS CHECKED 57640000 * INCREASES N, NUMBER OF ARRAYS WITH THE SAME 57660000 * DIMENSIONS, BY ONE 57680000 SPACE 2 57700000 ARCOMMA L REGA,AITL SAVE AITL 57720000 BAL REG12,ITABCLEA CHECK AND CLEAR NEXT ITABENTRY 57740000 MVC 6(3,REGY),6(REGA) COPY ID AND PBN FIELDS 57760000 IC REGB,N INCREASE 57780000 LA REGB,1(0,REGB) N 57800000 STC REGB,N BY ONE 57820000 OI BITS1,X'04' SET LISTBIT TO ONE 57840000 B ARRYNAME GET NEXT EXTERNAL NAME 57860000 SPACE 2 57880000 ***** ARRAYMULT ****** 57900000 * MOVES OUT THE COMMA PREVIONSLY FOUND 57920000 * SETS THE LISTBIT TO ZERO 57940000 * RETURNS TO ARRAYID (AVOIDS RESETING N TO ONE) 57960000 SPACE 2 57980000 ARRYMULT BAL REGOX,COB 58000000 MVI 0(EAP),X'25' MOVE OUT THE COMMA 58020000 LA EAP,1(0,EAP) 58040000 NI BITS1,X'FB' SET LISTBIT TO ZERO 58060000 B ARRYID 58080000 SPACE 2 58100000 ***** ARTABLE ****************************************************** 58120000 * USED BY LIST EQUIVALENT TO THE USE OF TESTTABLE 58140000 * BY TESTLOOP. GIVES DISPLACEMENT TO BPRTAB 58160000 SPACE 2 58180000 ARTABLE DS 0CL90 58200000 DC 2X'00' 58220000 DC X'0488' 58240000 DC 2X'00' 58260000 DC X'6854' 58280000 DC 3X'00' 58300000 DC X'58' 58320000 DC 5X'00' 58340000 DC X'1014' 58360000 DC 13X'00' 58380000 DC X'18' 58400000 DC 4X'00' 58420000 DC X'806C' 58440000 DC 4X'00' 58460000 DC X'282C843438' 58480000 DC 42X'00' 58500000 SPACE 2 58520000 ***** LIST ****************************************************** 58540000 * USED FOR ARRAY AND SWITCH LIST PROCESSING 58560000 * MAKES THE TRT AGAINST ARTABLE AND UTILIZES MAINLOOP 58580000 * TO MOVE SCANNED BYTES AND BRANCH TO THE 58600000 * APPROPRIATE PROGRAM, EITHER A LIST PROGRAM 58620000 * OR ONE OF THE COMMON PROGRAMS 58640000 * THE RETURN WILL BE TO LIST VIA REGISTER 10, 58660000 * RET WILL POINT TO LIST UNTIL CHANGED BY ENDLIST 58680000 * TO POINT TO TESTLOOP AGAIN 58700000 SPACE 2 58720000 LIST BALR RET,0 SET RETURN REGISTER 58740000 LR REGM,REGI START CHAR IN SCAN 58760000 LR REGIX,RET RETURN FROM CIB 58780000 SR REGZ,REGZ 58800000 TRT 0(73,REGI),ARTABLE SCAN AGAINST AR TABLE 58820000 B CONT UTILIZE TESTLOOP 58840000 SPACE 2 58860000 ***** PONTLST ****** 58880000 * USES THE SAME POINTABEL AS MAINLOOP BUT 58900000 * ADDS 56 TO THE DISPLACEMENTS 58920000 SPACE 2 58940000 PONTLST LA REGI,1(0,REGI) GET NEXT CHAR. 58960000 SR REGZ,REGZ 58980000 TRT 0(73,REGI),PTTABLE SCAN TO NEXT DELIMITER 59000000 LA REGB,BPRTAB IN PTTABLE 59020000 L REGB,56(REGB,REGZ) 59040000 BCR 15,REGB BRANCH ACCORDING TO 56+ DISP+ BPRTAB 59060000 SPACE 2 59080000 PZETA LA REGIX,PONTLST+4 ZETA IN POINTLIST 59100000 BC 15,CIB 59120000 SPACE 2 59140000 ***** RIGTPARL ****** MOVES OUT THE RIGHT PARENTHESIS DECREASES THE 59160000 * PARENTHESIS COUNT AND RETURNS TO LIST 59180000 SPACE 2 59200000 RIGTPARL BAL REGOX,COB CHECK IF O/P AREA FILLED 59220000 MVI 0(EAP),X'26' MOVE IN $ RIGHT PAREN. 59240000 LA EAP,1(0,EAP) 59260000 LA REGI,1(0,REGI) GET NEXT CHAR. 59280000 LH REGB,C 59300000 BCTR REGB,0 DECREASE PARENTHESIS COUNT 59320000 STH REGB,C 59340000 BCR 15,RET 59360000 SPACE 2 59380000 ***** LEFTPARL ****** 59400000 * INCREASES THE PARENTHESIS COUNT 59420000 * CHECKS IF NEXT CHARACTER IS A SLASH, IF IT IS 59440000 * MOVES A SUBSCRIPT BRACKET OUTPUT, IF NOT 59460000 * MOVES A SIMPLE PARENTHESIS 59480000 SPACE 2 59500000 LEFTPARL LH REGB,C INCREASE PARENTHESIS COUNT 59520000 LA REGB,1(0,REGB) 59540000 STH REGB,C 59560000 LPARDQC3 LA REGI,1(0,REGI) GET NEXT CHAR. 59580000 CLI 0(REGI),X'03' Q SLASH 59600000 BNE SIMPLPAR NO SIMPLE PARENTHESIS 59620000 BAL REGOX,COB CHECK IF O/P AREA FILLED 59640000 MVI 0(EAP),X'08' YES - MOVE IN SQUARE BRACKET 59660000 LPARDQ63 LA REGI,1(0,REGI) INCREASE POINTERS 59680000 LA EAP,1(0,EAP) 59700000 BCR 15,RET RETURN 59720000 SIMPLPAR CLI 0(REGI),X'2B' Q IS NEXT CHAR BLANK 59740000 BE LPARDQC3 YES 59760000 CLI 0(REGI),X'2F' NO - Q ZETA 59780000 BNE *+12 59800000 LA REGIX,LPARDQC3+4 1520 59820018 BC 15,CIB 59840000 BAL REGOX,COB CHECK IF O/P AREA FILLED 59860000 MVI 0(EAP),X'06' MOVE IN LEFT PARENTHESIS 59880000 B LPARDQ63+4 59900000 SPACE 2 59920000 ***** COMMALST ****** 59940000 * INCREASES THE DIEMSION COUNTER D IF C THE 59960000 * PARENTHESIS COUNTER IS 1 FOR ARRAY OR 0 FOR 59980000 * SWITCH LIST 60000000 SPACE 2 60020000 COMMALST TM BITS1,X'08' Q AR BIT = 0 60040000 BZ COMMAG3 60060000 CLC C(2),KOPOOL+6 Q. C=1 60080000 BNE COMMAJ2 NO 60100000 COMMAH2 IC REGZ,D INCREASE D-COUNTER 60120000 LA REGZ,1(0,REGZ) 60140000 STC REGZ,D 60160000 COMMAJ2 BAL REGOX,COB CHECK IF O/P AREA FILLED 60180000 MVI 0(EAP),X'25' MOVE COMMA TO OUTPUT 60200000 LA EAP,1(0,EAP) INCREASE POINTERS 60220000 LA REGI,1(0,REGI) 60240000 BCR 15,RET 60260000 COMMAG3 CLC C(2),KOPOOL Q. C=0 60280000 BE COMMAH2 60300000 BC 15,COMMAJ2 60320000 SPACE 2 60340000 ***** COLONLST ****** 60360000 * CORRECT ONLY FOR AN ARRAYLIST 60380000 SPACE 2 60400000 COLONLST TM BITS1,X'08' Q. ARBIT ON 60420000 BZ ERROR3 E3 COLON DELETE D 60440000 BAL REGOX,COB CHECK IF O/P AREA FILLED 60460000 MVI 0(EAP),X'07' MOVE $ COLON TO O/P 60480000 LA EAP,1(0,EAP) 60500000 LA REGI,1(0,REGI) GET NEXT CHAR 60520000 BCR 15,RET AND RETURN 60540000 SPACE 2 60560000 ***** SEMCLST ****** 60580000 * IS ONLY VALID FOR AN SWITCH IN WHITCH CASE 60600000 * INDICATES THE END OF THE SWITCH LIST 60620000 * THE NUMBER OF COMPONENTS IS INSERTED IN THE 60640000 * INTERNAL NAME 60660000 * EXIT IS TO ENDLIST 60680000 SPACE 2 60700000 SEMCLST TM BITS1,X'08' Q ARBIT=1 60720000 BO SEMCLER YES- ERROR 60740000 * END OF SWITCH HANDLING 60760000 CLI D,X'10' Q. MORE THAN 15 COMPONENTS 60780000 BL *+14 60800000 BAL REGB,ERR2 60820000 DC X'0021' E33 60840000 B COMPFIN 60860000 L IN,AITL INSERT DIMENSION COUNTER 60880000 SR REGB,REGB 60900000 IC REGB,D 60920000 SLA REGB,4(0) IN LEFTMOST 4 BYTES 60940000 STC REGB,D 60960000 MVZ 9(1,IN),D IN DECLARATION 60980000 B ENDLIST GO TO ENDLIST 61000000 SPACE 2 61020000 ***** SEMCLER ****** 61040000 * ENTERED IF A SEMICOLON IS FOUND IN AN ARRAY 61060000 * LIST 61080000 * GIVES E32, CLEAR THE ITAB ENTRY SETS THE 61100000 * ARBIT OFF, DELTABIT ON AND RETURNS TO 61120000 * TEST VIA SEMCO 61140000 SPACE 2 61160000 SEMCLER BAL REGB,ERR2 61180000 DC X'0020' E32 61200000 L REGY,AITL 61220000 BAL REG12,ITABCLEA+8 CLEAR THE ENTRY 61240000 OI BITS1,X'20' DELTABIT ON 61260000 NI BITS1,X'F7' ARRAYBIT OFF 61280000 B SEMCO RETURN TO SEMCO- WILL RESET RET 61300000 SPACE 2 61320000 ***** SLASHLST ****** 61340000 * CHECKS IF NEXT CHARACTER IS A RIGHT PARENTHESIS 61360000 * IT IS NOT MOVES OUT A SLASH 61380000 * IF IT IS MOVES OUT A RIGHT SQUARE BRACKET 61400000 * DECREASES THE PARENTHESIS COUNT 61420000 * RETURNS TO LIST IF EITHER AN SWITCH LIST IS 61440000 * PROCESSED OR THE PARENTHESIS COUNT NOT IS 0 61460000 SPACE 2 61480000 SLASHLST LA REGI,1(0,REGI) GET NEXT CHAR. 61500000 CLI 0(REGI),X'26' Q LEFT PARENTHWSIS 61520000 BNE SLASHSE NO SOMETHING ELSE 61540000 BAL REGOX,COB CHECK IF O/P AREA FILLED 61560000 MVI 0(EAP),X'28' TRANSFER A RIGHT SQUARE BRACKET 61580000 LA EAP,1(0,EAP) 61600000 LA REGI,1(0,REGI) 61620000 LH REGB,C 61640000 BCTR REGB,0 DECREASE PARENTHESIS COUNT 61660000 STH REGB,C 61680000 TM BITS1,X'08' Q ARBIT = 1 61700000 BC 8,0(0,RET) NO- RETURN 61720000 CLC C(2),KOPOOL Q. C=0 61740000 BC 7,0(0,RET) NO- RETURN 61760000 SPACE 2 61780000 ***** ARRAY END HANDLING 61800000 * INSERT THE DIMENSION COUNTERS IN THE INTERNAL 61820000 * NAME OR NAMES IF MORE THAN ONE ARRAY WITH 61840000 * THE SAME DIMENSIONS 61860000 * IF A COMMA FOLLOWS THE CHARACTERISTICS AND THE PBN 61880000 * IS COPIED AND THE NEXT ARRAY NAME IS HANDLED 61900000 * IF A SEMICOLON FOLLOWS ENDLIST IS ACTIVATED 61920000 SPACE 2 61940000 IC REGZ,D 61960000 CLI D,X'10' Q. MORE THAN 16 DIMENSIONS 61980000 BL *+14 62000000 BAL REGB,ERR2 62020000 DC X'0021' EOO 62040000 B COMPFIN 62060000 SLA REGZ,4 SHIFT DIMENSION COUNTER 62080000 STC REGZ,D 62100000 SLASHREP L REGB,DIM 62120000 MVZ 0(1,REGB),D INSERT DIMENSION COUNTER 62140000 LA REGB,11(0,REGB) INCREASE DIM POINTER 62160000 ST REGB,DIM 62180000 IC REGOX,N DECREASE 62200000 BCTR REGOX,0 REP.DECLARATION COUNTER 62220000 STC REGOX,N 62240000 CLC N(1),KOPOOL Q. IS IT ZERO 62260000 BNE SLASHREP NO INSERT DIM IN NEXT 62280000 B SLASHEND+4 ITAB ENTRY 62300000 SLASHSE CLI 0(REGI),X'2B' Q. BLANK 62320000 BE SLASHLST 62340000 CLI 0(REGI),X'2F' Q. ZETA 62360000 BNE *+12 62380000 LA REGIX,SLASHLST+4 62400000 BC 15,CIB 62420000 BAL REGOX,COB CHECK IF O/P AREA FILLED 62440000 MVI 0(EAP),X'03' MOVE IN A SLASH 62460000 LA EAP,1(0,EAP) 62480000 BCR 15,RET 62500000 SLASHEND LA REGI,1(0,REGI) GET NEXT CHAR. 62520000 CLI 0(REGI),X'25' Q COMMA 62540000 BNE SLSHENSE NO SOMETHING ELSE 62560000 BAL REGOX,COB CHECK IF O/P AREA FILLED 62580000 MVI 0(EAP),X'25' MOVE IN A COMMA 62600000 LA EAP,1(0,EAP) 62620000 L REGA,AITL SAVE AITL 62640000 BAL REG12,ITABCLEA CHECK AND CLEAR NEXT ITABENTRY 62660000 MVC 6(3,REGY),6(REGA) COPY ID AND PBN FIELDS 62680000 B ARRYNAME GET NEXT NAME 62700000 SLSHENSE CLI 0(REGI),X'2B' Q BLANK 62720000 BE SLASHEND 62740000 CLI 0(REGI),X'2F' Q ZETA 62760000 BNE *+12 62780000 LA REGIX,SLASHEND+4 62800000 B CIB 62820000 LA REGB,SLASHERR RETURN IF NO SEMICOLON FOUND 62840000 BAL REG12,FINDSEMC LOOK FOR SEMICOLON 62860000 SPACE 2 62880000 ***** ENDLIST ****** 62900000 * SETS DELTABIT TO ONE, ARBIT TO ZERO, CLEARS NEXT 62920000 * ITABENTRY 62940000 * RESETS THE RETUN REGISTER TO TEST 62960000 * RETURNS TO TESTLOOP VIA SEMCO 62980000 SPACE 2 63000000 ENDLIST OI BITS1,X'20' DELTA BIT =1 63020000 NI BITS1,X'F7' ARBIT= 0 63040000 BAL REG12,ITABCLEA CHECK AND CLEAR NEXT ITABENTRY 63060000 LA RET,TESTLOOP RESET RETURN REGISTER TO MAINLOOP 63080000 B SEMCO GO TO SEMICOLONPROGRAM 63100000 SLASHERR BAL REGB,ERR2 63120000 DC X'0022' E34 63140000 BAL REG12,ITABCLEA CHECK AND CLEA NEXT ITABENTRY 63160000 B ARYEXIT+8 CLEAR THE ENTRY IN ITAB AND RETURN 63180000 SPACE 2 63200000 ***** SWITCH ****************************************************** 63220000 * TESTS ON PROBIT (SPECIFICATION) AND BEGBIT 63240000 * (PROGRAM BLOCK HEAD) 63260000 * INSERTS CHARACTERISTICS AND PBN IN INTERNAL NAME 63280000 * INCREASES AND INSERTS LABELNUMBER LN 63300000 * MOVES 0A SWITCH TO OUTPUT 63320000 * SETS ARBIT TO ZERO 63340000 * CHECKS THE NAME FOR VALIDITY AND MOVES FIRST 6 63360000 * CHARACTERS TO OUTPUT AND ITAB VIA IDCHECK 63380000 * SEARCHES FOR ASSIGN TO FOLLOW THE SWITCHNAME 63400000 * INITILIZES C PARENTHESIS COUNT AND D DIMENSION 63420000 * COUNT WITH ZERO AND N WITH ONE 63440000 * EXITS TO LIST 63460000 SPACE 2 63480000 SWITCH TM BITS1,X'40' Q PROCEDURE HEAD 63500000 BO SPECENT YES 63520000 TM BITS1,X'80' Q BLOCK START 63540000 BZ *+16 63560000 ST REGX,SAVE1 63580000 BAL REGX,BEG1 YES- PROCESS BLOCKBEGIN 63600000 L REGX,SAVE1 63620000 L REGY,AITL MOVE IN ID FIELDS 63640000 MVI 6(REGY),X'CC' 63660000 MVI 7(REGY),X'0C' 63680000 L REGOX,LPBP 63700000 MVC 8(1,REGY),10(REGOX) AND PBN- NUMBER 63720000 LH REGOX,LN IN CREASE LABELNUMBER 63740000 LA REGOX,4(0,REGOX) 63760000 CLC LN(2),FOURKA Q. LN OVERFLOW 63780000 BL *+14 63800000 BAL REGB,ERR7 63820000 DC X'04D8' E216 63840000 LA REGOX,LATBEG RESET LN 63860000 STH REGOX,LN 63880000 MVC 9(2,REGY),LN MOVE IN LABEL NUMBER 63900000 BAL REGOX,COB CHECK IF O/P AREA FILLED 63920000 MVI 0(EAP),X'0A' MOVE IN $ SWITCH 63940000 LA EAP,1(0,EAP) 63960000 NI BITS1,X'F7' SET ARBIT TO ZERO 63980000 SWTCHB3 LA REGI,1(0,REGI) GET FIRST CHAR. 64000000 CLI 0(REGI),X'39' Q IS IT A LETTER 64020000 BL SWTCHNSE NO 64040000 BAL REGB,IDCHECK1 INIILIZ N WITH ONE 64060000 SWITCHSE CLI 0(REGI),X'2B' Q IS CHAR A BLANK 64080000 BE IDCHECK2 64100000 CLI 0(REGI),X'07' Q COLON 64120000 BE SWCOLON 64140000 CLI 0(REGI),X'2D' Q. POINT 64160000 BNE SWITCHER 64180000 SWPOINT LA REGI,1(0,REGI) ONE POINT HAS BEEN FOUND 64200000 CLI 0(REGI),X'2D' Q. ONE MORE POINT 64220000 BE SWCOLON 64240000 CLI 0(REGI),X'10' Q. EQUALSIGN E.G. .= 64260000 BE EQUALOK 64280000 CLI 0(REGI),X'2B' Q. BLANK 64300000 BE SWPOINT 64320000 CLI 0(REGI),X'2F' Q.ZETA 64340000 BNE SWITCHER 64360000 LA REGIX,SWPOINT+4 64380000 B CIB 64400000 SWCOLON LA REGI,1(0,REGI) NOW A COLON OR TWO POINTS ARE FOUND 64420000 CLI 0(REGI),X'10' Q EQUALSIGN 64440000 BE EQUALOK IF YES '= OR .= OR ..= ARE FOUND 64460000 CLI 0(REGI),X'2B' Q BLANK 64480000 BE SWCOLON 64500000 CLI 0(REGI),X'2F' Q ZETA 64520000 BNE SWITCHER 64540000 LA REGIX,SWCOLON+4 64560000 B CIB 64580000 EQUALOK BAL REGOX,COB CHECK IF O/P AREA FILLED 64600000 MVI 0(EAP),X'16' MOVE IN $ EQUALSIGN 64620000 LA EAP,1(0,EAP) INCREASE O/P POINTER 64640000 SR REGB,REGB 64660000 STH REGB,C C=0 1514 64680018 MVI N,X'01' N=1 64700000 STC REGB,D D=0 64720000 LA REGI,1(0,REGI) GET NEXT CHAR 64740000 B LIST GO TO PROCESS LIST 64760000 SWTCHNSE CLI 0(REGI),X'2B' Q. BLANK 64780000 BE SWTCHB3 64800000 CLI 0(REGI),X'2F' Q. ZETA 64820000 BNE *+12 64840000 LA REGIX,SWTCHB3+4 64860000 B CIB 64880000 BAL REGB,ERR7 64900000 DC X'0405' E5 64920000 B SWITCHER+18 64940000 SWITCHER BAL REGB,ERR2 64960000 DC X'0010' E16 64980000 BAL REGOX,COB 65000000 MVI 0(EAP),X'3D' MOVE IN RHA 65020000 LA EAP,1(0,EAP) 65040000 L REGB,AITL CLEAR ITAB-ENTRY 65060000 MVI 0(REGB),X'00' 65080000 MVC 1(10,REGB),0(REGB) 65100000 BC 15,COMERR COM-PRGM ERROR-ENTRY 65120000 SPACE 2 65140000 ***** STRING ****************************************************** 65160000 * MOVES INTERNAL NAME TO OUTPUT 65180000 * THE STRING IS TAKEN FROM THE PRINTAREA (OR DUMMY) 65200000 * AND MOVED TO KOPOOL, START ADDRESS IS IN 65220000 * SPCLT 65240000 * THE STRINGS TWO FIRST BYTES SPECIFIES ITS LENGTH 65260000 * THE TRT TESTS ONLY FOR APOSTROPHE AND ZETA 65280000 SPACE 2 65300000 STRING LA REG0,6(0,EAP) PROVIDE 6 BYTES IN O/P 65320000 BAL REGOX,COBSPEC 65340000 MVC 0(4,EAP),SINT MOVE FIRST 4 BYTES OF INTERNAL NAME 65360000 MVC 4(2,EAP),SPCLT+2 AND LAST TWO BYTES IN O/P 65380000 LA EAP,6(0,EAP) 65400000 L REGL,SPCLT GET CURRENT DISP WITHIN KOPOOL 65420000 LA REGL,2(0,REGL) INCREASE FOR LENGTH SPECIFICATION 65440000 C REGL,FOURK Q STRINGPOOL OVERFLOW 65460000 BNH *+8 65480000 BAL REGOX,E23 65500000 LA REGI,1(0,REGI) 65520000 MVC SQC(4),KOPOOL+4 STRINQUOTE=1 65540000 CDE2 LA REGIX,* PROVIDE RETURNADDRESS FOR CIB 65560000 LR REGM,REGI 65580000 SR REGZ,REGZ 65600000 TRT 0(73,REGI),STRTABLE SCAN STRING 65620000 LR REGN,REGI COMPUTE NUMBER OF SCANNED BYTES 65640000 SR REGN,REGM 65660000 BZ SROUT 65680000 LA REG0,0(REGN,REGL) Q. STRINGPOOL OVERFLOW 65700000 C REG0,FOURK 65720000 BNH *+8 65740000 BAL REGOX,E23 65760000 BCTR REGN,0 MOVE SCANNED BYTES TO KOPOOL 65780000 L REGB,AKOPOOL 65800000 LA REGY,0(REGB,REGL) COMPUTE NEW KOPOOL ADDRESS 65820000 LA REG0,WA COMPUTE ADDRESS 65840000 LR REG12,REGM OF STRING IN 65860000 SR REG12,REG0 PRINTBUFFER 65880000 L REGB,APRNTAR 65900000 LA REG12,8(REGB,REG12) GET STRING FROM PRINTBUFFER 65920000 EX REGN,MV1 65940000 LA REGL,1(REGN,REGL) INCREASE SPCLT 65960000 SROUT L REG12,BPRTAB(REGZ) BRANCH TO APPROPRIATE 65980000 BCR 15,REG12 SUBROUTINE 66000000 SPACE 2 66020000 ***** QUOTE ***** 66040000 * CHECKS IF THE APOSTROPHE IS THE START OF A QUOTE 66060000 * SIGN 66080000 * USES REPL TO MOVE THE FOUND CHARACTER(S) TO 66100000 * KOPOOL. REPL+1 WILL BE A LEFT OR RIGHT 66120000 * PARENTHESIS 66140000 * HOW MUCH OF REPL THAT IS TO BE MOVED TO KOPOOL 66160000 * IS KEPT TRACK OF IN REGN 66180000 * IF A COMPLETE LEFT STRING QUOTE IS FOUND THE 66200000 * STRING QUOTE COUNTER IS INCREASED AND THE 66220000 * REPL MOVED TO KOPOOL 66240000 * IF A COMPLETE RIGHT STRING QUOTE IS FOUND IT IS 66260000 * CHECKED IF IT IS THE CLOSING ONE FOR THE 66280000 * STRING (SQC=0) IF IT IS ENDSTRING IS ACTIVATED 66300000 * IF NOT REPL IS MOVED TO KOPOOL AFTER 66320000 * SQC IS DECREASED 66340000 * IF NO COMPLETE QUOTE IS FOUND THE CHARACTER(S) 66360000 * FOUND ARE MOVED TO KOPOOL FROM REPL, LENGTH 66380000 * SPECIFIED BY REGN AND THE SCANNING OF 66400000 * THE STRING IS REASSUMED 66420000 SPACE 2 66440000 QUOTE LA REGI,1(0,REGI) 66460000 LA REGIX,*+4 66480000 CLI 0(REGI),X'26' Q RIGHT PARENTHESIS IN SOURCE 66500000 BNE NORIP 66520000 MVI REPL+1,C')' MAKE REPL A RIGHT STRING QUOTE 66540000 B TESTAPOS LOOK FOR APOSTROPHE 66560000 NORIP CLI 0(REGI),X'06' Q. LEFT PARENTHESIS 66580000 BNE TESTZETA NO 66600000 MVI REPL+1,C'(' MAKE REPL A LEFT STRING QUOTE 66620000 B TESTAPOS LOOK FOR APOSTROPHE 66640000 TESTZETA CLI 0(REGI),X'2F' Q.ZETA 66660000 BE CIB YES 66680000 LA REGN,1 NO MOVE TO STRING ONLY FIRST APOST . 66700000 B CID1 MOVE REPL 66720000 TESTAPOS LA REGI,1(0,REGI) 66740000 LA REGIX,*+4 NEW RETURN FOR CIB 66760000 CLI 0(REGI),X'2E' Q. SECOND APOSTROPHE 66780000 BE CID YES 66800000 CLI 0(REGI),X'2F' ZETA 66820000 BE CIB YES 66840000 LA REGN,2 NO MOVE TO STRING ONLY THE FIRST 66860000 B CID1 APOSTROPHE AND THE PARENTHESIS 66880000 CID LA REGI,1(0,REGI) 66900000 L REGOX,SQC 66920000 CLI REPL+1,X'4D' Q. LEFT STRING QUOTE 66940000 BNE *+12 NO 66960000 LA REGOX,1(0,REGOX) YES- INCREASE STRING QUOTE COUNT 66980000 B *+12 67000000 S REGOX,KOPOOL+4 RIGHT QUOTE- DECREASE QUOTE COUNT 67020000 BC 13,ENDSTRIN BRANCH IF LAST QUOTE 67040000 ST REGOX,SQC 67060000 LA REGN,3 67080000 CID1 LA REG0,0(REGN,REGL) 67100000 C REG0,FOURK Q STRINGPOOL OVERFLOW 67120000 BNH *+8 67140000 BAL REGOX,E23 67160000 L REGB,AKOPOOL 67180000 LA REGB,0(REGB,REGL) COMPUTE NEW KOPOOL ADDRESS 67200000 BCTR REGN,0 67220000 EX REGN,MV2 MOVE CONTENTS OF REPL TO KOPOOL 67240000 LA REGL,1(REGN,REGL) INCREASE SPCLT 67260000 BC 15,CDE2 RESUME SCAN OF STRING 67280000 SPACE 2 67300000 ***** ENDSTRIN ***** 67320000 * INCREASES SPCLT 67340000 * PUTS THE LENGTH OF THE STRING (DIFFERENCE BETWEEN 67360000 * NEW AND OLD SPCLT) AS TWO FIRST BYTES IN THE 67380000 * STRING 67400000 SPACE 2 67420000 ENDSTRIN L REG9,SPCLT COMPUTE LENGTH AND PUT IT 67440000 STH REGL,SPCLT+2 AS THE FIRST 2 BYTES IN STRING 67460000 L REGB,AKOPOOL AND 67480000 LA REGOX,0(REGB,REG9) STORE NEW DISPLACEMENT 67500000 SR REGL,REG9 IN SPCLT 67520000 STH REGL,LENSTRIG 67540000 MVC 0(2,REGOX),LENSTRIG 67560000 BCR 15,RET RETURN TO TESTLOOP 67580000 E23 BC 0,*+10 NO BRANCH FIRST TIME 0208 67590014 BAL REGB,ERR7 RECORD ERROR 0208 67600014 DC X'0417' E23 67620000 OI E23+1,X'F0' NO ERROR RECORDING NEXT 0208 67630014 LA REGL,64 67640000 ST REGL,SPCLT RESETSPCLT TO 64 AGAIN 67660000 BCR 15,REGOX RESUME STRING PROCESSING 67680000 CNOP 0,4 67700000 MV1 MVC 0(1,REGY),0(REG12) 67720000 LENSTRIG DS H MUST NOT BE MOVED 67740000 MV2 MVC 0(1,REGB),REPL 67760000 SQC DC F'0' STRINGQOUTECOUNTER (AFTER MV2 67780000 SINT DC X'2EC90000' STRING INTERNAL NAME 67800000 * OF THE CONSTANT POOL NAMED KOPOOL 67820000 REPL DC C''' ''' BUCKET TO BUILD STRING QUOTES 67840000 SPACE 2 67860000 ***** TYPPROC ****************************************************** 67880000 * TEST PRO AND BEGBIT (FORMAL PARAMETER, BLOCKSTART) 67900000 * MOVE PHI TO OUTPUT 67920000 * INSERT CHARACTERISTICS IN INTERNAL NAME 67940000 * JOIN PROCEDURE PROGRAM 67960000 SPACE 2 67980000 TYPPROC TM BITS1,X'40' QPROCEDURE PROCEDED 68000000 BZ *+16 NO 68020000 MVI KB,X'CA' YES-MOVE IN IDFIELD 68040000 OI KB+1,X'C0' 68060000 BC 15,IDCHECK 68080000 TM BITS1,X'80' Q. BEGBIT ON 68100000 BZ *+16 NO 68120000 ST REGX,SAVE1 68140000 BAL REGX,BEG1 GO TO PROCESS PROGRAM BLOCK HEAD 68160000 L REGX,SAVE1 68180000 LA REG0,4(0,EAP) PROVIDE FOUR BYTES IN OUTPUT 68200000 BAL REGOX,COBSPEC CHECK IF ENOUGH SPACE IN O/P 68220000 MVI 0(EAP),X'0F' MOVE PHI TO O/P 68240000 L REGY,AITL 68260000 XI 7(REGY),X'F0' MOVE IN THE IDCODE 68280000 MVI 6(REGY),X'CA' TO ITAB 68300000 B PROCEAG1 JOIN THE PROCEDUR PROGRAM 68320000 SPACE 2 68340000 ***** PROCEDURE ***************************************************** 68360000 * TEST PRO AND BEGBIT 68380000 * MOVE PI TO OUTPUT 68400000 * INSERT CHARACTERISTICS IN INTERNAL NAME 68420000 * TYPEPROCEDURE JOINS PROCEDURE PROGRAM AT THIS POINT 68440000 * IF ALPHA IN STACK, PRECOMPILED PROCEDURE, 68460000 * THE STARTBIT IS TURNED ON 68480000 * PROC IS PUT IN STACK 68500000 * PROGRAM BLOCK AND ITAB GROUP NUMBER ARE INCREASED 68520000 * THE NEW PBN IS INSERTED IN THE INTERNAL NAME 68540000 * LABELNUMBER IS INCREASED AND INSERTED IN THE 68560000 * INTERNAL NAME 68580000 * THE SURRONDING BLOCKNUMBET IS ENTERED IN PBTAB1 68600000 * THE SURROUNDING ITABGROUP NUMBER IN GROUPTABLE 68620000 * THE SC IS ENTERED IN SCTAB 68640000 * PROBIT AND IDBIT ARE SET TO ONE 68660000 * PROBIT WILL STAY AS ONE TILL THE WHOLE PROCEDURE 68680000 * HEAD IS PROCESSED. THE IDBIT IS ONLY ONE 68700000 * WHILE THE PROCEDURE NAME IS PROCESSED 68720000 * THE FM (FORMAL PARAMETER)BIT IS ONE WHEN THE 68740000 * FORMAL PARAMETER LIST IS PROCESSED 68760000 * THE ITABGROUP NUMBER IS MOVED TO O/P 68780000 SPACE 2 68800000 PROCEDUR TM BITS1,X'40' IF PROBIT IS ONE 68820000 BO SPECENT GOTO IDCHECK VIA SPECENT 68840000 TM BITS1,X'80' Q. BEGBIT ON 68860000 BZ *+16 NO 68880000 ST REGX,SAVE1 68900000 BAL REGX,BEG1 GO TO PROCESS PROGRAMBLOCKHEAD 68920000 L REGX,SAVE1 68940000 LA REG0,4(0,EAP) PROVIDE FOUR BYTES IN OUTPUT 68960000 BAL REGOX,COBSPEC 68980000 MVI 0(EAP),X'0E' TRANSFER PI IN OUTPUTBUFFER 69000000 L REGY,AITL 69020000 MVI 6(REGY),X'CA' CONSTRUCT FIRST PART 69040000 MVI 7(REGY),X'C0' OF INTERNAL NAME 69060000 PROCEAG1 L REGL,SP 69080000 CLI 0(REGL),X'00' Q ALPHA IN STACK 69100000 BNE L3 69120000 OI BITS2,X'20' TURN ON THE STARTBIT 69140000 OI BITS3,PROCESD 69160000 L3 LA REGL,1(0,REGL) INCREASE STACKPOINTER 69180000 C REGL,ATOPSTAK Q STACKOVERFLOW 69200000 BL *+10 69220000 BAL REGB,ERR4 69240000 DC X'0414' E20 69260000 MVI 0(REGL),X'0C' PUT PROC IN STACK 69280000 ST REGL,SP 69300000 CLI PBC,X'FF' Q.PBN OVERFLOW 69320000 BNE *+10 NO 69340000 BAL REGB,ERR4 69360000 DC X'0416' E22 69380000 IC REGZ,PBC 69400000 LA REGZ,1(0,REGZ) INCREASE PROGRAMBLOCKNUMBER 69420000 STC REGZ,8(0,REGY) INSERT PBN IN INTERVAL NAME 69440000 STC REGZ,PBC 69460000 LA REGL,PBTAB1(REGZ) CONSTRUCTION 69480000 L REGB,LPBP PBTAB1-ENTRY 69500000 MVC 0(1,REGL),10(REGB) 69520000 AR REGZ,REGZ 69540000 LA REGL,SCTAB(REGZ) 69560000 MVC 0(2,REGL),SC MAKE ENTRY IN SCTAB 69580000 LH REGL,LN INCREASE 69600000 LA REGL,4(0,REGL) LABELNUMBER BY 4 69620000 CLC LN(2),FOURKA Q. LNOVERFLOW 69640000 BL *+14 69660000 BAL REGB,ERR7 69680000 DC X'04D8' E216 69700000 LA REGL,LATBEG RESET LN 69720000 STH REGL,LN 69740000 L REGY,AITL 69760000 MVC 9(2,REGY),LN PUT LN IN INTERNAL NAME 69780000 LH REGY,IGC INCREASE 69800000 LA REGY,1(0,REGY) ITABGROUPNUMBER 69820000 STH REGY,IGC 69840000 MVC 1(2,EAP),IGC INSERT IT IN OUTPUT BUFFER 69860000 LA EAP,3(0,EAP) 69880000 AR REGY,REGY 69900000 AH REGY,IGC 69920000 A REGY,AGT 69940000 L REG7,LIGP 69960000 MVC 0(2,REGY),8(REG7) CONSTRACT ENTRY 69980000 MVI 2(REGY),X'00' IN GROUPTABEL 70000000 NI 0(REGY),X'7F' CLEAR POSSIBLE PHI IND. 70020000 MVC PRIMPAR(4),KOPOOL CLEARPRIMPAR WITH ZEROS 70040000 OI BITS1,X'50' PROBIT =1,IDBIT =1 70060000 MVI PZ,X'00' SET PARAMTER COUNT TO ZERO 70080000 SPACE 2 70100000 ***** PROCID ***** 70120000 * PROCESSES PROCEDURE NAME (IDBIT=1) 70140000 * AND THE FORMAL PARAMETER LIST (IDBIT=0) 70160000 * CHECKS THE NAMES FOR VALIDITY AND MOVES THEM 70180000 * TO ITAB AND OUTPUT 70200000 * THIS IS DONE VIA IDCHECK1 70220000 SPACE 2 70240000 PROCID LA REGI,1(0,REGI) 70260000 CLI 0(REGI),X'40' Q IDENTIFIER STARTS WITH LETTER 70280000 BL NOLETTER 70300000 BAL REGB,IDCHECK1 CHECK AND MOVE IDENTIFIER TO O/P AND ITAB 70320000 CLI 0(REGI),X'2B' Q BLANK 70340000 BE IDCHECK2 70360000 TM BITS1,X'10' Q IDBIT ONE 70380000 BZ EDA1 GOTO PROCESS FORMAL PARAMETER NAME 70400000 SPACE 2 70420000 ***** PROCEDURE NAME ***** 70440000 * CHECKS IF NAME IS FOLLOWED BY (A FORMAL PARAMETER 70460000 * LIST FOLLOWS OR ., NO PARAMETERS 70480000 * CHECKS IF PROCEDURE IS TO BE PRECOMPILED, IF YES 70500000 * THE NAME IN EXTERNAL FORM AND EXPANDED WITH 70520000 * TWO ZEROS IS PUT FOR AN ESDCARD IF SYLIN OR 70540000 * DECK HAS BEEN SPECIFIED 70560000 * THE NEW BLOCK ENTRY IS DONE IN ITAB 70580000 * ADD, OF SURROUNDIN BLOCK AND ITAB GROUP, PBN 70600000 * AND IGN ARE INSERTED 70620000 * IF TYPEPROCEDURE, BIT 0 IN BYTE 8 IS 70640000 * TURNED ON AND A SECOND ENTRY OF THE NAME 70660000 * IS DONE AFTER THE HEAD ENTRY 70680000 * IDBIT IS SET TO ZERO, FMBIT TO ONE 70700000 * IF THE NAME WAS FOLLOWED BY A SEMICOLON THE 70720000 * SEMCO IS ACTIUATED 70740000 * IF THE NAME WAS FOLLOWED BY A(PROCID IS 70760000 * ACTIVATED TO PROCESS THE NAME IN THE LIST 70780000 SPACE 2 70800000 CLI 0(REGI),X'06' Q IDENTIFIER FOLLOWED BY ) 70820000 BE EBF4 70840000 LA REGB,ERROR16 RETURN IF NOT SEMICOLON 70860000 BAL REG12,FINDSEMC Q SEMICOLON 70880000 OI BITS1,X'20' YES DELTABIT = 1 70900000 EBF4 TM BITS3,PROCESD 70920000 BZ DEL1 NO 70940000 NI BITS3,PROCOFF 70960000 TM HCOMPMOD+1,X'60' Q. DECK AND OR LOAD SPECIFIED 70980000 BO DEL1 NO- NO NEED FOR ESDCARD 71000000 L REGY,AITL 71020000 LA REGB,ESDPARAM 71040000 MVC 0(6,REGB),0(REGY) MOVE IN AND TRANSLATE EXTERNAL NAME 71060000 TR 0(6,REGB),RETRANS 71080000 DEL1 TM BITS1,X'20' Q DELTABIT = 1 71100000 BO ECA3 71120000 BAL REGOX,COB CHECK IF O/P AREA FILLED 71140000 MVI 0(EAP),X'06' INSERT ) 71160000 LA EAP,1(0,EAP) 71180000 ECA3 BAL REG12,ITABCLEA 71200000 MVC 0(4,REGY),LIGP MOVE ADDRESS HEADINGENTRY OF EMBRAC 71220000 MVC 4(4,REGY),LPBP ING ITABGROUP AND PBLOCK TO ENTRY 71240000 MVC 8(2,REGY),IGC INSERT CURRENT IGN 71260000 MVC 10(1,REGY),PBC AND CURRENT PBN 71280000 ST REGY,LIGP NEW VALUE OF LIGP 71300000 ST REGY,LPBP AND LPBP 71320000 S REGY,KOPOOL+44 DECREASE REGY BY 11 71340000 TM 7(REGY),X'03' Q TYPEPROCEDURE 71360000 BC 5,TPROHEAD 71380000 LA REGY,22(0,REGY) IF NO INCREASE ITABPOINTER 71400000 ECJ3 BAL REG12,ITABCLEA+8 71420000 OI BITS3,FMBIT FMBIT 71440000 TM BITS1,X'20' Q DELTABIT = 1 71460000 BO SEMCO IF YES BRANCH TO SEMICOLONPROGRAM 71480000 NI BITS1,X'EF' IDBIT'= 0 71500000 BC 15,PROCID CHECK NEXT IDENTIFIER 71520000 * CONSTRUCT TYPE PROCEDURE ENTRIES 71540000 TPROHEAD OI 19(REGY),X'80' FLAGBIT IN IGN IS SET ON 71560000 LA REG0,22(0,REGY) Q ONE MORE ENTRY IN ITAB AVAILABLE 71580000 C REG0,ELI 71600000 BNE *+10 71620000 BAL REGB,ERR4 71640000 DC X'04D5' E213 71660000 MVC 22(11,REGY),0(REGY) ENTER PROCEDURE NAME ONCE MORE 71680000 XI 28(REGY),X'08' NO-ASSIGNMENTBIT IS SWITCHED OFF 71700000 LA REGY,33(0,REGY) INCREASE ITABPOINTER 71720000 BC 15,ECJ3 BRANCH BACK TO MAINPROGRAM 71740000 NOLETTER CLI 0(REGI),X'2B' Q BLANK INSTEAD OF LETTER 71760000 BE PROCID 71780000 LA REGIX,PROCID+4 71800000 CLI 0(REGI),X'2F' Q ZETA 71820000 BE CIB CHANGE INPUTBUFFER 71840000 TM BITS1,X'10' 71860000 BO PNAMERR-10 71880000 LA REGH,PROCID LOAD RETURN ADDRESS 71900000 B IERSPEC BRANCH TO IDENTIFIER ERROR ROUTINE 71920000 ERROR16 BAL REGOX,COB 71940000 MVI 0(EAP),X'3D' MOVE IN RHA 71960000 LA EAP,1(0,EAP) 71980000 TM BITS1,X'10' Q. PROC NAME UNDER PROCESS 72000000 BO PNAMERR YES 72020000 LA REGH,PROCID LOAD RETURN ADDRESS 72040000 B IER GO TO IDENTIFIER ERROR ROUTINE 72060000 BAL REGB,ERR7 72080000 DC X'0405' E5 72100000 B *+10 72120000 PNAMERR BAL REGB,ERR2 72140000 DC X'0010' E16 72160000 L IN,AITL 72180000 MVI 0(IN),X'00' CLEAR ERRONEOUS NAME 72200000 MVC 1(5,IN),0(IN) 72220000 LA REGB,PROCIDSE THE PROCEDURE HEAD SHOULD 72240000 BAL REGOX,FINDSEMC 72260000 B EBF4-4 BE FOLLOWED BY EITHER ( OR ., 72280000 PROCIDSE CLI 0(REGI),X'06' KEEP LOOPING UNTIL ONE OF TWO FOUND 72300000 BE EBF4 LEFT PARENTHESIS FOUND 72320000 BAL REGOX,FINDSEMC-4 72340000 B EBF4-4 SEMICOLON FOUND 72360000 SPACE 2 72380000 ***** FORMAL PARAMETER LIST ***** 72400000 * IF A COMMA TERMINATES THE NAME, THE COMMA IS 72420000 * TRANSFERED TO OUTPUT AND THE PARAMETER COUNT 72440000 * (PZ) IS INCREASED BY ONE 72460000 * AND PROCID IS ACTIVATED AGAIN TO TAKE NEXT 72480000 * NAME 72500000 * IF A ) FOLLOWED BY A SEMICOLON TERMINATES THE NAME 72520000 * PROCFIN IS ACTIVATED 72540000 * IF A ) BUT NO SEMICOLON TERMINATES THE NAME 72560000 * PROCDEL IS ACTIVATED 72580000 * IS SOMETHING ELSE IS FOUND RHA IS MOVED TO OUTPUT, 72600000 * THE PARAMETER COUNT IS NOT INCREASED AND IER 72620000 * ACTIVATED (NOLETTER, ERROR16) 72640000 SPACE 2 72660000 EDA1 CLI 0(REGI),X'25' Q COMMA TERMINATES IDENTIFIER 72680000 BNE PAR 72700000 PROCEND IC REGZ,PZ INCREASE 72720000 LA REGZ,1(0,REGZ) PARAMETER 72740000 STC REGZ,PZ COUNT BY ONE 72760000 BAL REG12,ITABCLEA CHECK AND CLEAR NEXT ITABENTRY 72780000 BAL REGOX,COB CHECK IF O/P AREA FILLED 72800000 CLI 0(REGI),X'25' Q COMMA 72820000 BNE PROCFIN 72840000 MVI 0(EAP),X'25' MOVE COMMA TO OUTPUTBUFFER 72860000 LA EAP,1(0,EAP) INCREASE OUTPUTPOINTER 72880000 BC 15,PROCID BRANCK TO CHECK THE NEXT IDENTIFIER 72900000 PAR CLI 0(REGI),X'26' Q ( TERMINATES IDENTIFIER 72920000 BE PROCEND 72940000 BAL REGOX,COB 72960000 MVI 0(EAP),X'3D' MOVE IN RHA 72980000 LA EAP,1(0,EAP) 73000000 LA REGH,PROCID NOTE RETURN ADDRESS AND BRANCH 73020000 BC 15,IER TO IER 73040000 SPACE 2 73060000 ***** PROCFIN ***** 73080000 * THE PARAMERER LIST HAS BEEN COMPLETLY CHECKED 73100000 * THE RIGHT PARENTHESIS IS MOVED TO OUTPUT 73120000 * DELTABIT IS SET TO ONE 73140000 * THE PARENTHESIS COUNT IS INSERTED IN THE 73160000 * PROCEDURE NAME (NAMES IF TYPEPROCEDURE) 73180000 * FMBIT IS TURNED OFF 73200000 * THE RETURN TO TEST IS VIA SEMCO 73220000 * IF SOMETHING ELSE, E5 OR E16 IS GENERATED AND 73240000 * EVERYTHING SKIPPED TILL A (OR A., IS 73260000 * FOUND (NOLETTER, PNAMERR) 73280000 SPACE 2 73300000 PROCFIN LA REGI,1(0,REGI) 73320000 LA REGB,PROCDEL RETURN IF NO SEMICOLON 73340000 BAL REG12,FINDSEMC Q SEMICOLON 73360000 BAL REGOX,COB 73380000 LA REGL,SEMCO EXIT FROM PROCEDUR 73400000 SCYES3 MVI 0(EAP),X'26' MOVE RIGHT PARENTHESIS 73420000 LA EAP,1(0,EAP) 73440000 OI BITS1,X'20' DELTABIT'=1 73460000 CLI PZ,X'10' Q.MORE THAN 15 PARAMETERS 73480000 BL *+14 73500000 BAL REGB,ERR2B 73520000 DC X'0024' E36 73540000 B COMPFIN 73560000 L REGY,LPBP 73580000 S REGY,KOPOOL+44 REGY CONTAINS ADDRESS OF PROC ENTRY 73600000 SR REGB,REGB 73620000 IC REGB,PZ 73640000 SLA REGB,4(0) 73660000 STC REGB,PZ 73680000 MVZ 9(1,REGY),PZ INSERT NUMBER OF PARAMETERS INTO 73700000 * INTERNAL NAME OF THE PROCEDURE 73720000 SRA REGB,4(0) 73740000 STC REGB,PZ NOTE NUMBER OF PARAMETER 73760000 NI BITS3,FMOFF FMBIT=0 73780000 TM 19(REGY),X'80' Q TYPE PROCEDURE 73800000 BZ TESTPAR NO 73820000 MVZ 31(1,REGY),9(REGY) INSERT NUMBER OF PARAMETERS INTO 73840000 * SECOND NAME-ENTRY IN ITAB 73860000 LA REGY,33(0,REGY) GET ADDRESS OF FIRST PARAMETER 73880000 B *+8 73900000 TESTPAR LA REGY,22(0,REGY) 73920000 CLI PZ,X'00' Q. IS THERE ANY PARAMETERS 73940000 BCR 8,REGL NO BRANCH TO SEMCO OR COMERR 73960000 ST REGY,PRIMPAR YES- SAVE ADDRESS OF FIRST 73980000 BCR 15,REGL B TO SEMCO OR COMERR 74000000 SPACE 2 74020000 ***** PROCDEL ***** 74040000 * A RIGHT PARENTHESIS HAS BEEN FOUND IN THE LIST 74060000 * THAT NOT WAS FOLLOWED BY A ., 74080000 * IF A LETTERSTRING IS FOUND, NOTHING BUT LETTERS 74100000 * AND BLANKS FOLLOWED BY ..(A COMMA IS MOVED 74120000 * TO OUTPUT AND PROCID ACTIVATED TO TAKE 74140000 * NEXT NAME 74160000 * IF ANYTHING ELSE IS FOUND E37 IS GENERATED 74180000 * AND COMERR ACTIVATED TO SKIP TO NEXT 74200000 * SEMICOLON 74220000 * ADDRESS OF COMERR IS PUT IN REGL 74240000 SPACE 2 74260000 PROCDEL LA REGIX,DELCHECK+4 74280000 DELCHECK LA REGI,1(0,REGI) 74300000 CLI 0(REGI),X'40' Q. LETTER 74320000 BNL DELCHECK 74340000 CLI 0(REGI),X'2F' Q. ZETA 74360000 BE CIB 74380000 CLI 0(REGI),X'07' Q. COLON 74400000 BE DELCOLON 74420000 CLI 0(REGI),X'2B' 74440000 BE DELCHECK 74460000 CLI 0(REGI),X'2D' Q. POINT 74480000 BNE ERROR37 74500000 DELPOINT LA REGI,1(0,REGI) 74520000 CLI 0(REGI),X'2D' Q. ONE MORE POINT 74540000 BE DELCOLON 74560000 CLI 0(REGI),X'2B' 74580000 BE DELPOINT 74600000 CLI 0(REGI),X'2F' Q ZETA 74620000 BNE ERROR37 74640000 LA REGIX,DELPOINT+4 74660000 B CIB 74680000 DELCOLON LA REGI,1(0,REGI) 74700000 CLI 0(REGI),X'06' Q LEFT PARENTHESIS 74720000 BE DELPAREN 74740000 CLI 0(REGI),X'2B' Q. BLANK 74760000 BE DELCOLON 74780000 CLI 0(REGI),X'2F' Q. ZETA 74800000 BNE *+12 74820000 LA REGIX,DELCOLON+4 74840000 B CIB 74860000 BCTR REGI,0 NO PARENTHESIS FOLLOWS THE COLON 74880000 B ERROR37 RESET REGI AND GO TO ERROR 37 74900000 DELPAREN BAL REGOX,COB 74920000 MVI 0(EAP),X'25' MOVE COMMA TO OUTPUT INSTEAD OF 74940000 LA EAP,1(0,EAP) DELIMITER INCREASE O/P POINTER 74960000 B PROCID RETURN TO PROCEDURE CHECKING 74980000 ERROR37 BAL REGB,ERR2B 75000000 DC X'0025' E37 75020000 LA REGL,COMERR 75040000 B SCYES3 75060000 SPACE 2 75080000 ***** ENDMISS ****************************************************** 75100000 * ENTERED VIA OS IF END OF DATA SENSED BEFORE 75120000 * LOGICAL PROGRAM END IS FOUND BY SCAN I/II 75140000 * CLOSES WHAT REMAINS OPEN IN STACK 75160000 * GENERATES PATTERN FOR ERR. MESS. 39. 75180000 SPACE 2 75200000 ENDMISS TM BITS2,STARTBIT Q. FIRST BEGIN FOUND 75220000 BO *+10 YES 75240000 BAL REGB,ERR4 75260000 DC X'042C' E44 NOTHING PROCESSED 75280000 OI BITS1,TERBIT 75300000 TERMSEAC LA REGE,TERMSEAC RETURN FOR PBLCKEND PROG. 75320000 L REGY,SP GET STACKPOINTER 75340000 CLI 0(REGY),X'04' Q.BETA IN STACK 75360000 BE STEPUP 75380000 CLI 0(REGY),X'08' Q.BEGIN 75400000 BE STEPUP 75420000 CLI 0(REGY),X'10' Q. PROC* 75440000 BNE TERMBRNC 75460000 STEPUP LH REGB,ENDCOUNT INCREASE ENDCOUNT 75480000 LA REGB,1(0,REGB) 75500000 STH REGB,ENDCOUNT 75520000 TERMBRNC IC REGZ,0(0,REGY) 75540000 L REGB,TERMTAB(REGZ) BRANCH ACORDING TO STACKBYTE 75560000 BCR 15,REGB 75580000 CNOP 0,4 75600000 TERMTAB DC A(ERROR39) 75620000 DC A(PBLCKEND) BEGIN 75640000 DC A(TERMBGN) BETA 75660000 DC A(PBLCKEND) PROC 75680000 DC A(PBLCKEND) PROC* 75700000 DC A(PBLCKEND) PROC** 75720000 DC A(FOREND) FOR 75740000 TERMBGN BAL REGOX,COB 75760000 MVI 0(EAP),X'2C' MOVE OUT END TO O/P 75780000 LA EAP,1(0,EAP) 75800000 L REGY,SP 75820000 BCTR REGY,0 RELEASE BEGIN IN STACK 75840000 ST REGY,SP 75860000 B TERMSEAC 75880000 SPACE 2 75900000 ***** SLUT2 ****************************************************** 75920000 * INTERED FROM IEX00 IF INTERUPT OCCURS BEFORE 75940000 * GETMAIN 75960000 SPACE 2 75980000 SLUT2 OI BITS3,NOFREE INTERUPT OCCURED PRIOR TO GETMAIN 76000000 L REG11,VIEX14 76020000 USING IEX11003,11 76040000 B SCANEND GO TO PROCESS TERMINATING PART 76060000 USING IEX11002,11 76080000 SPACE 2 76100000 ***** READROUT ****************************************************** 76120000 * ENTERED AFTER FINAL ENDCOMMENT HAS BEEN CHECKED 76140000 * SHOULD EXIT TO EODADIN VIA OS EOD ROUTINE 76160000 SPACE 2 76180000 READROUT LA REGI,1(0,REGI) 76200000 LA REGIX,*+4 76220000 TRT 0(73,REGI),BTABLE ONLY VALID CHARACTER AFTER 76240000 CLI 0(REGI),X'2F' FINAL END COMMENT IS ZETA 76260000 BE CIB 76280000 B ERR9 ANYTHING ELSE FOUND 76300000 E39PAR DC X'0727' E39 76320000 ERROR39 LA REGB,E39PAR 76340000 BAL REG12,ERROR1 CREATE E39 PATTERN 76360000 LH REGB,ENDCOUNT 76380000 CVD REGB,DOUBLE 76400000 UNPK SAVE1(4),DOUBLE+5(3) 76420000 MVZ SAVE1+3(1),SAVE1+2 INSERT NUMBER OF ENDS MISSING 76440000 MVC 4(3,REGY),SAVE1+1 IN ERROR PATTERN 76460000 SPACE 2 76480000 ***** EODADIN ****************************************************** 76500000 * FALL THROUGH TO TERMINATION SECTION 76520000 SPACE 2 76540000 EODADIN L REG11,VIEX14 76560000 USING IEX11003,11 76580000 B TERMOK 76600000 IEX11003 CSECT 76620000 SPACE 2 76640000 ***** TERMINATION ************************************************** 76660000 * WRITES PB0 ITAB BLOCK FOR A PRECOMPILED PROCEDURE 76680000 * WRITES LAST O/P REC IF MORE THAN ONE O/P REC 76700000 * CORRECTS SPCLT AND MOVES THE CONSTANTS 0 TROUGH 76720000 * 15 TO THE CONSTANT POOL 76740000 * IF NO TERMINATION ERROR AND EITHER DECK OR LOAD 76760000 * IS SPECIFIED ESD CARD AND TXT CARDS ARE 76780000 * GENERATED WITH GENERATE 76800000 * CHECKS LAST ITAB RECORD WRITTEN, IF ANY 76820000 * CLOSES SYSIN, SYSUT1, SYSUT3 76840000 * MAKES A FREEMAIN 76860000 * EXITS TO IEX20 IF NO TERMINATING ERROR 76880000 * IEX21 IF TERMINATING ERROR 76900000 SPACE 2 76920000 TERMOK TM HCOMPMOD,X'08' Q. TERMINATING ERROR 76940000 BO KOPOOLRL YES- DO NOT WRITE OUT ANYTHING 76960000 L REGI,AITAB CHECK IF PB0 76980000 LA REGI,11(0,REGI) CONTAINS ANYTHING 77000000 C REGI,AITL 77020000 BE NOPBN0 NO PB0 77040000 L REGY,AITL 77060000 OI BITS2,X'08' SET SWITCH 77080000 BAL REGE,WRTITAB WRITE OUT PB0 77100000 NOPBN0 BAL REGOX,COB 77120000 MVI 0(EAP),X'2D' MOVE OMEGA TO O/P 77140000 LA EAP,1(0,EAP) 77160000 CLI ONC,X'00' Q ONLY ONE O/P RECORD 77180000 BE *+12 EQUAL=YES 77200000 BAL REGOX,COB+8 NO- WRITE LAST O/P BUFFER 77220000 B KOPOOLRL 77240000 OI HCOMPMOD+2,X'40' YES- LEAVE THE SINGLE BUFFER IN CORE 77260000 KOPOOLRL L REG7,POOLLOC 77280000 MVC 0(64,REG7),KOPOOL MOVE THE CONSTANTS 0 TO 15 77300000 L REGB,SPCLT 77320000 A REGB,KOPOOL+28 MAKE SPCLT POINT 77340000 ST REGB,SPCLT TO THE NEAREST 77360000 NI SPCLT+3,X'F8' DOUBLE WORD BOUNDARY 77380000 MVC PBN+1(1),PBC SAVE NUMBER OF BLOCKS 77400000 IC REGI,FSN 77420000 BCTR REGI,0 CORRECT FSN 77440000 STC REGI,ZFSNMAX SET FOR SCAN 3 77460000 CLC MGESITL,TWOFIVEK Q. WILL ITAB OVERFLOW 77480000 BL *+10 77500000 BAL REGB,ERR7 77520000 DC X'0413' E 19 77540000 TM HCOMPMOD+1,X'60' DECK AND OR LOAD SPECIFIED 77560000 BO SCANEND NO SKIP ESD CARD GENERATION 77580000 SR PRPOINT,PRPOINT 77600000 TM HCOMPMOD,PROC Q. PRECOMPILED PROCEDURE 77620000 BZ *+10 NO 77640000 MVC ESDPAR2(8),ESDPARAM GET NAME OF PROCEDURE 77660000 BAL INFORM,GENESD WRITE ESD 77680000 ESDPAR2 DC 8X'40' 77700000 DC X'00' 77720000 MVC 29(3,OUTAREA),KOPOOL CORRECT FIRST ESD CARD A22571 77740019 SKIPESD L INFORM,AKOPOOL 77760000 MVC *+10(2),SPCLT+2 GET LENGTH OF KOPOOL FOR TXT 77780000 BAL LENGTH,GENTXTS GENERATE TXT CARD 77800000 DC H'0' 77820000 SCANEND TM BITS3,FRSITB 77840000 BZ CLSYSUT3 77860000 CHECK ITABC 77880000 CLSYSUT3 L REGB,UT3ADD 77900000 CLOSE ((REGB),REREAD),TYPE=T RESET SYSUT3 77920000 L REGB,INADD CLOSE SYSIN 77940000 CLOSE ((REGB),REREAD) 77960000 L 1,INADD FREE QSAM BUFFER POOL 77980000 FREEPOOL (1) 78000000 L REGB,UT1ADD 78020000 TM HCOMPMOD,X'08' Q. TERMINATING ERROR 78040000 BO CLSPERM YES- CLOSE SYSUT1 FOR GOOD 78060000 CLOSE ((REGB),REREAD),TYPE=T RESET SYSUT1 78080000 B FREE 78100000 CLSPERM CLOSE ((REGB),REREAD) CLOSE SYSUT1 78120000 FREE TM BITS3,NOFREE Q. INTERUPT BEFOR GETMAIN 78140000 BO GETERRPH YES- DONOT MAKE FREEMAIN 78160000 L REG0,POOLLEN 78180000 L REGI,POOLLOC 78200000 FREEMAIN R,LV=(0),A=(1) 78220000 OI HCOMPMOD+2,NOSC SET SWITCH FOR ERROR MESSAGES 78240000 TM HCOMPMOD,X'08' Q. TERMINATING ERROR 78260000 BO GETERRPH YES- CALL IEX21 78280000 L REGB,BRACKET A28251 78283019 SR REGOX,REGOX A28251 78286019 CR REGOX,REGB IS BRACKETCOUNTER ZERO A28251 78289019 BC 8,*+8 YES A28251 78292019 OI HCOMPMOD,X'90' NO SET SYNTAX MODE A28251 78295019 XCTL EP=IEX20000 GO TO ITAB-MANIPULATION 78300000 GETERRPH XCTL EP=IEX21000 GO TO ERROR MESSAGE HANDLING 78320000 SPACE 2 78340000 SPACE 2 78360000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 78380000 * * 78400000 * S U B R O U T I N E G E N E R A T E * 78420000 * * 78440000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 78460000 SPACE 3 78480000 * REGISTER DEFINITIONS 78500000 OUTAREA EQU 1 OUTPUT RECORD POINTER 78520000 INFORM EQU 2 ADDRESS OF INFORMATION 78540000 TYPER EQU 3 TYPE OF RECORD TO BE GENERATED 78560000 RETURN EQU 4 RETURN REGISTER 78580000 PRPOINT EQU 6 78600000 LENGTH EQU 14 LENGTH OF INFORM. FROM CALL 78620000 L EQU 15 LENGTH WITHIN RECORD 78640000 SPACE 3 78660000 * BIT PATTERNS 78680000 SDENTRY EQU X'00' SD-ENTRY IDENTIFICATION 78700000 LDENTRY EQU X'01' LD-ENTRY IDENTIFICATION 78720000 RLDFLAG EQU B'00001101' FLAG USED IN RLD-ENTRY 78740000 *ADDRESS DISPLACEMENTS 78760000 RSTART EQU 0 START OF RECORD TYPE TABLE 78780000 RTYP EQU 1 RECORD IDENTIFICATION 78800000 RLEN EQU 4 INITIAL LENGTH 0 OR 4 78820000 RESID EQU 6 ESID OR BLANKS 78840000 RMAX EQU 12 MAXIMUM NUMBER OF BYTES IN REC 78860000 RMOV EQU 14 START OF MOVE ROUTINE 78880000 INFL EQU 10 LENGTH OF INFORM IN A RECORD 78900000 SPACE 3 78920000 GENESD LA LENGTH,16 LENGTH ALLWAYS 16 78940000 LA TYPER,ESDT INDICATE ESD-CALL 78960000 MVC PIDENT(4),0(INFORM) NAME TO IDENT. PART 78980000 B GEN3 CALLFOR FIRST OUT REC 79000000 * 79020000 GENTXTS LA RETURN,2(0,LENGTH) COMPUTE RETURN ADDRESS 79040000 LH LENGTH,0(0,LENGTH) LOAD LENGTH GIVEN IN CALL 79060000 GEN2 LA TYPER,TXTT INDICATE TXT-CALL 79080000 SPACE 3 79100000 GEN1 L OUTAREA,SAVOUTA LOAD ADDRESS OF OUT RECORD 79120000 CLC RTYP(3,OUTAREA),RTYP(TYPER) RECORD RIGTH TYPE 79140000 BNE GEN3 NO,CALL IOR NEW 79160000 CLC INFL(2,OUTAREA),RMAX(TYPER) RECORD FILLED 79180000 BNL GEN3 YES,CALL FOR NEW 79200000 GEN6 LA L,56 79220000 LH REG0,INFL(0,OUTAREA) REG0=LENGTH OF INFORM IN REC 79240000 SR L,REG0 L=EMPTY POS LEFT IN RECORD 79260000 CR L,LENGTH ENOUTH SPACE LEFT 79280000 BL *+6 NO 79300000 LR L,LENGTH YES L=LENGTH FROM CALL 79320000 AR L,REG0 79340000 STH L,INFL(0,OUTAREA) INSERT NEW LENGTH INTO RECORD 79360000 * 79380000 SR L,REG0 79400000 AR OUTAREA,REG0 START ADDRESS WITHIN RECORD 79420000 SR LENGTH,L REMAINING LENGTH 79440000 B RMOV(TYPER) TO DIFFERENT MOVE ROUTINES 79460000 * 79480000 GEN4 LTR LENGTH,LENGTH MORE INFORMATION MUST BE MOVED 79500000 BH GEN3 YES 79520000 BR RETURN 79540000 SPACE 3 79560000 GEN3 EQU * CALL FOR NEW OUTPUT RECORD 79580000 PUNCH ST 14,SAVAR 79600000 TM HCOMPMOD+1,X'60' Q. BOTH DECK AND LOAD SPECIFIED 79620000 BZ BOTH YES 79640000 TM HCOMPMOD+1,NDCK Q. ONLY DECK 79660000 L OUTAREA,PCHADD IF ONLY DECK 79680000 BZ PUT1 YES 79700000 L OUTAREA,LINADD ONLY SYSLIN 79720000 PUT1 PUT (OUTAREA) PUT FOR SYSLIN AND SYSPUNCH IF 79740000 ST OUTAREA,SAVOUTA ONLY SYSPUNCH SPECIFIED 79760000 L 14,SAVAR 79780000 B PUNCHOUT 79800000 BOTH TM BITS2,X'02' Q. FIRST PUT 79820000 BZ FIRSTPUT YES 79840000 L LENGTH,OUTAREA2 COPY SYSLIN BUFFER TO SYSPUNCH 79860000 L OUTAREA,SAVOUTA 79880000 MVC 0(80,LENGTH),0(OUTAREA) BUFFER 79900000 PUT2 L OUTAREA,PCHADD 79920000 PUT (OUTAREA) PUT FOR SYSPUNCH WHEN BOTH HAS 79940000 ST OUTAREA,OUTAREA2 BEEN SPECIFIED 79960000 B PUT1-4 GO TO PUT SYSLIN 79980000 FIRSTPUT OI BITS2,X'02' 80000000 B PUT2 80020000 PUNCHOUT EQU * 80040000 MVC 0(4,OUTAREA),RSTART(TYPER) INSERT FIRST 4 BYTES 80060000 MVI 4(OUTAREA),C' ' INSERT ONE BLANK 80080000 MVC 5(67,OUTAREA),4(OUTAREA) BLANK OUTPUT RECORD 80100000 MVC 72(4,OUTAREA),PIDENT INSERT PROGRAM IDENT 80120000 L L,SEQU 80140000 LA L,1(0,L) 80160000 ST L,SEQU 80180000 CVD L,DOUBLE 80200000 UNPK 76(4,OUTAREA),DOUBLE+5(3) 80220000 MVZ 79(1,OUTAREA),76(OUTAREA) 80240000 MVC 10(2,OUTAREA),RLEN(TYPER) INSERT INITIAL LENGTH 80260000 MVC 14(6,OUTAREA),RESID(TYPER) INSERT ESID+R AND P 80280000 CLC TXTT+1(3),RTYP(TYPER) TXT-RECORD PROCESSED 80300000 BNE GEN6 NO 80320000 ST PRPOINT,4(OUTAREA) YES INSERT PRPOINT 80340000 MVI 4(OUTAREA),C' ' 80360000 B GEN6 80380000 SPACE 3 80400000 * TABLES AND MOVE ROUTINES 80420000 SPACE 3 80440000 ESDT DS 0H START OF ESD-RECORD TABLE 80460000 DC X'02' CARD CODE 80480000 DC C'ESD' IDENTIFICATION 80500000 DC H'0' INITIAL LENGTH 0 80520000 DC C' ' 80540000 DC H'48' MAXIMUM LENTH IN RECORD 80560000 GEN7 EQU * MOVE ESD-INFORMATION TO OUTAREA 80580000 MVC 16(16,OUTAREA),0(INFORM) MOVE INFORM TO OUTAREA 80600000 MVC 25(7,OUTAREA),ESDCON CHANGE LAST PART OF ENTRY 80620000 LA TYPER,1 ESID NR IS 1 80640000 STH TYPER,14(OUTAREA) YES INSERT ESID NUMBER 80660000 B 10(INFORM) RETURN TO CALLING ROUTINE 80680000 SPACE 3 80700000 TXTT DS 0H START OF TXT-RECORD TABLE 80720000 DC X'02' CARD CODE 80740000 DC C'TXT' IDENTIFICATION 80760000 DC H'0' INITIAL LENGTH 0 80780000 DC H'1' ESID 80800000 DC C' ' 80820000 DC H'56' MAXIMUM LENGTH 80840000 GEN8 EQU * MOVE TXT-INFORMATION TO OUTAREA 80860000 BCTR L,0 L=L-1 80880000 STC L,*+5 INSERT PROPER LENGTH TO MOVE 80900000 MVC 16(0,OUTAREA),0(INFORM) MOVE INFORM TO OUTAREA 80920000 LA PRPOINT,1(L,PRPOINT) INCREASE PROGRAM POINTER 80940000 LA INFORM,1(L,INFORM) MODIFY DATA ADDRESS 80960000 B GEN4 OUT OF MOVE TXT ROUTINE 80980000 SPACE 3 81000000 * VARIABLES AND CONSTANTS 81020000 DEC1 DC P'1' ADD CONSTANT 81040000 ESDCON DC X'000000' ESD- 81060000 DC C' ' *CONSTANT,7 BYTES 81080000 SPACE 3 81100000 WORKAREA DSECT 81120000 COPY WORKAREA 81140000 C DS H PARENTHESIS COUNT 81160000 KB DS H HOLDS ID FIELD FOR SPECIFICATIONS 81180000 POOLLEN DS F LENGTH OF AREA GOTTEN FROM GETMAIN 81200000 POOLLOC DS F START LOC. OF AREA FROM GETMAIN 81220000 AITABBUF DS F ADD. OF ITAB BUFFER 81240000 ELI DS F ADD. OF ONE LOC. BEYOND ITAB AREA 81260000 ADDARI DS A ADDRESS OF FIRST O/P BUFFER 81280000 DS A ADD. OF SECOND O/P BUFFER 81300000 DISP DS C DISPLACEMENT TO ADDARI 81320000 D DS C DIMENSION COUNTER 81340000 SPCLT EQU PRPT 81360000 SP DS F CURRENT STACK POINTER 81380000 SC EQU SEMCNT 81400000 APE DS F LAST AVAILABLE BYTE IN CURRENT O/P 81420000 WASAVE DS CL12 81440000 WABEFOR DS CL7 81460000 WA DS CL80 INPUT AREA 81480000 APRNTAR DS A ADD. OF CURRENT PRINTAREA 81500000 ATOPSTAK DS A LAST BYTE IN THE STACK 81520000 IGC DS H ITAB GROUP COUNTER 81540000 AGT DS A ADD. OF GROUPE TAB. -3 81560000 AKOPOOL DS A ADD. OF THE CONSTANT POOL (0) 81580000 LAPIN DS A ADD. OF LAST POSS. LABEL START 81600000 DIM DS A ADD. FOR DIMENSION IN ITAB NAME 81620000 PRIMPAR DS A ADD. OF FIRST SPECIFICATION 81640000 AITAB DS A START ADD. OF ITAB 81660000 AITL DS A CURRENT ITAB ENTRY ADD. 81680000 LIGP DS A POINTER TO CURRENT IG HEAD ENTRY 81700000 LPBP DS A POINTER TO CURRENT PBHEADING 81720000 WADDARI DS A CURRENT O/P BUFFER ADD. 81740000 ITABLEN DS F ITAB LENGTH 81760000 MGESITL DS F ACCUMULATED ITAB LENGTH 81780000 BCHAR DS C SAVE CHAR. 81800000 FBYTE DS CL1 SWITCH BYTE FOR APOSTROPHE 81820000 FSN DS C FORSTATEMENR COUNTER 81840000 ZFSNMAX DS C 81860000 PBC DS C PROGRAM BLOCK COUNTER 81880000 ONC DS C O/P REC. COUNTER 81900000 N DS C NR. OF ARRAYS WITH SAME DIM. 81920000 OPIN DS A POINTS TO LAST LABEL OPERATER 81940000 DS C O/P REC. NR. WHEN OPIN WAS SET 81960000 PZ DS C COUNTS NR. OF PARMETERS 81980000 BITS1 DS C INTERNAL SWITCHES 82000000 BEGBIT EQU X'80' BLOCK BEGIN 82020000 BEGOFF EQU X'7F' 82040000 PROBIT EQU X'40' PROCEDURE HEAD PROCESSING 82060000 DELTABIT EQU X'20' SEMICOLON FOUND AFTER DECLARATION 82080000 IDBIT EQU X'10' PROCEDURE NAME 82100000 ARBIT EQU X'08' ARRAY PROCESSED 82120000 LISTBIT EQU X'04' COMMA FOUND AFTER ARRAY NAME 82140000 TERBIT EQU X'01' RETURN TO TERM. AFTER PBLCKEND 82160000 BITS2 DS C 82180000 ENDBIT EQU X'80' LOGICAL END HAS BEEN FOUND 82200000 COBIT EQU X'40' COMMENT 82220000 STARTBIT EQU X'20' ZERO UNTIL FIRST BEGIN FOUND 82240000 VALBIT EQU X'10' VALUE 82260000 PB0BIT EQU X'08' WRITE PB0 FOR PRE. COMP. PROC. 82280000 FRSTPUT EQU X'02' FIRST PUT IN GENERATE 82300000 ENDELSE EQU X'01' END MAY CLOSE FOR OR PROC** 82320000 BITS3 DS C 82340000 E11BIT EQU X'80' E11 HAS BEEN GENERATED ONCE 82360000 FMBIT EQU X'40' FORMAL PARAMETER BIT 82380000 FMOFF EQU X'BF' 82400000 NOFREE EQU X'20' INTERUPT BEFORE GETMAIN 82420000 FRSITB EQU X'10' FIRST ITAB REC. IS WRITTEN 82440000 PROCESD EQU X'08' WRITE SED CARD FOR PRE. COMP. PROC. 82460000 PROCOFF EQU X'F7' 82480000 END IEX11000 82500000 ./ ADD SSI=01010360,NAME=IEX20,SOURCE=0 TITLE 'ITAB MANIPULATION IEX20' 00020000 *STATUS: CHANGE LEVEL 000 * 00040000 * * 00060000 *FUNCTION/OPERATION: EACH ITAB BLOCK IS SCANNED FOR DUPLICATE * 00080000 * IDENTIFIERS. * 00100000 * RELATIVE DISPLACEMENTS IN DSA IS ALLOCATED FOR ALL IDENTIFIERS, * 00120000 * EXCEPT PROCEDURES, LABELS AND SWITCHES. * 00140000 * THE ITAB BLOCKS ARE WRITTEN IN PROGRAM BLOCK NUMBER ORDER TO * 00160000 * SYSUT3. * 00180000 * THE ITAB BLOCKS ARE PRINTED ON SYSPRINT IN PROGRAM BLOCK NUMBER * 00200000 * ORDER AND WITH THE IDENTIFIERS IN ALPHABETIC FORM WITHIN EACH * 00220000 * BLOCK, IF THE OPTION 'SOURCE' IS SPECIFIED. * 00240000 * CREATES PBTAB2 * 00260000 * * 00280000 *ENTRY POINT: * 00300000 * IEX20000 ITAB MANIPULATION XCTL EP=IEX20 * 00320000 * * 00340000 *INPUT: THE ITAB BLOCKS ARE READ IN FROM SYSUT3. * 00360000 * * 00380000 *OUTPUT: THE ITAB BLOCKS ARE WRITTEN TO SYSUT3 AND PRINTED ON SYSPRINT* 00400000 * IF THE OPTION 'SOURCE' IS SPECIFIED. * 00420000 * * 00440000 *EXTERNAL ROUTINES: THE PRINT ROUTINE IN IEX00 IS USED. * 00460000 * * 00480000 *EXITS-NORMAL: CONTROL IS GIVEN TO IEX21 XCTL EP=IEX21 * 00500000 * * 00520000 * -ERROR: N/A * 00540000 * * 00560000 *TABLES/WORKAREA: * 00580000 * ATAB FOR ADDRESS IS OF THE ITAB RECORDS IN PROGRAM BLOCK NUMBER * 00600000 * ORDER * 00620000 * TRTAB FOR TRANSLATION OC INTERNAL CHATACTERS TO EBCDIC CHARACTERS.* 00640000 * TAB FOR PRINTING OF HEXADECIMAL DIGITS. * 00660000 * WORK FOR BUILDING THE PRINT ENTRIES. * 00680000 * * 00700000 *ATTRIBUTES: NONE. * 00720000 * * 00740000 *NOTES: CHARACTER CODE DEPENDENCE. * 00760000 * THE OUTPUT ON SYSPRINT: * 00780000 * THE IDENTIFIER NAME IS TRANSLATED BY MEANS OF TRTAB, WHICH IS * 00800000 * A CHARACTER TABLE. * 00820000 * THE HEXADECIMAL PART IS TRANSLATED BY MEANS OF TAB. * 00840000 * THE REMAININ PARTS DEPEND ON THE INTERNAL REPRESENTATION OF THE * 00860000 * EXTERNAL CHARACTER SET WHICH IS EQUIVALENT TO THE ONE USED AT * 00880000 * ASSEMBLY TIME. * 00900000 * THE OPERATION OF THE OTHER PARTS OF THE PHASE DOES NOT DEPEND * 00920000 * UPON A PARTICULAT INTERNAL REPRESENTATION OF THE EXTERNAL * 00940000 * CHARACTER SET * 00960000 IEX20000 START 00980000 * RELEASE 19 CHANGES 00985019 * 110600 A28230 00990019 REG0 EQU 0 CALCULATIONS 01000000 REGI EQU 1 PBN 01020000 REGZ EQU 2 CALCULATIONS 01040000 REGD EQU 3 PARAMETER FOR CONVERT ROUTINE 01060000 DP EQU 3 DOUBLE WORD POINTER 01080000 WP EQU 4 WORD POINTER 01100000 REGC EQU 5 KEEPS TRACK OF WHEN TO PRINT 01120000 HP EQU 5 HALF WORD POINTER 01140000 BP EQU 6 BYTE POINTER 01160000 RAID EQU 7 CURRENT IDENTIFIER 01180000 AIB EQU 8 CURRENT BLOCKHEAD 01200000 RAKOM EQU 9 SCANS FOR DUPLICATES 01220000 REGY EQU 10 01240000 REGDIM EQU 10 ARRAY STORAGE ALLOCATIONS 01260000 REG11 EQU 11 BASE REGISTER 01280000 REGB EQU 12 RETURN FROM CONVERT, PRINT ROUTINE 01300000 REGP EQU 14 PBN DURING PRINTING 01320000 REG15 EQU 15 01340000 SPACE 2 01360000 ***** INITIALIZATION *********************************************** 01380000 * GETMAIN FOR ITAB AND ATAB 01400000 * FIRST ENTRY IN ATAB IS MADE ZERO IF NO PBN 0 01420000 * PRINTING OF HEADLINES IS INTITLIZED IF SOURCE SPECIFIED 01440000 * C IS MADE 4 IF SHORT SPECIFIED OTHERWISE IT REMAINS 8 01460000 SPACE 2 01480000 BALR REG11,0 01500000 USING *,REG11 01520000 USING WORKAREA,13 01540000 LA REG15,SLUT2 INTERUPT BEFORE GETMAIN 01560000 ST REG15,ERET 01580000 L REGI,ITAB20S ITAB 01600000 LA REGI,1024(0,REGI) ATAB 01620000 LR REG0,REGI 01640000 GETMAIN R,LV=(0) GET ITAB ATAB AREAS 01660000 LA REG15,SLUT 01680000 ST REG15,ERET INTERUPT ADD. AFTER GETMAIN 01700000 ST REGI,AREALOC 01720000 ST REGI,AITAB ITAB START LOCATION 01740000 A REGI,ITAB20S 01760000 ST REGI,ATABAD ATAB START LOCATION 01780000 SR REGZ,REGZ 01800000 ST REGZ,KOPOOL 01820000 ST REGZ,SAVEPB 01840000 TM HCOMPMOD,PROC Q. IS THERE A PB0 01860000 BO *+12 01880000 LA REG15,1 NO- PROGRAM BLOCK 1 IS FIRST BLOCK 01900000 ST REG15,SAVEPB 01920000 MVC 0(4,REGI),KOPOOL 01940000 ST REGZ,SAVE INITILIZE WITH ZEROS 01960000 MVC SAVE1(16),SAVE 01980000 STC REGZ,BITS1 INITILIZE SWITCHES 02000000 LA REGY,PBTAB2 02020000 ST REGY,APBTAB2 START ADDRESS OF PBTAB2 02040000 TM HCOMPMOD+1,NSRCE Q. SOURCE SPECIFIED 02060000 BO INITIAL NO 02080000 MVI LINCNT,X'7F' 02100000 MVI PAGEHD1,X'02' 02120000 MVI PAGEHD1+1,X'11' 02140000 MVI PAGEHEAD+2,X'40' 02160000 MVC PAGEHEAD+3(81),PAGEHEAD+2 02180000 MVC PAGEHEAD+39(16),HDING1 02200000 MVI PAGEHD2,X'01' 02220000 MVI PAGEHD2+1,X'09' 02240000 MVC PAGEHD2+2(90),HEAD1 02260000 MVI PAGEHD3,X'01' 02280000 MVI PAGEHD3+1,X'11' 02300000 MVC PAGEHD3+2(90),HEAD2 02320000 BAL REGB,PRINTITB INITILIZE PRINTING FOR ITAB 02340000 INITIAL SR REGI,REGI 02360000 TM HCOMPMOD,LNG LONG OR SHORT PRECISION 02380000 BO *+8 LONG 02400000 MVI C+1,X'04' SHORT C=4 02420000 ***** SCAN FOR DUPLICATES ***************************************** 02440000 * READS IN A NEW BLOCK 02460000 * START ADDRESS IN AIB END ADDRESS IN AITAB 02480000 * COMPARES EACH IDENTIFIER WITH ALL IDENTIFIERS 02500000 * FOLLOWING IT IN THE BLOCK 02520000 * IF TWO EQUAL FOUND AND IF NOT FIRST ONE IS A 02540000 * FORMAL PARAMETER AND SECOND NOT E45 IS 02560000 * GENERATED 02580000 * WHEN ALL IDENTIFIERS IN THE BLOCK HAVE BEEN 02600000 * CHECK THE EXIT IS TO ALLOSTUR 02620000 READBLK L REGB,AITAB START ADD. OF NEW BLOCK 02640000 L REGZ,UT3ADD READ IN NEW BLOCK 02660000 READ ITABC,SF,(REGZ),(REGB),'S' 02680000 CHECK ITABC 02700000 SR REGZ,REGZ 02720000 IC REGZ,10(0,REGB) GET NEW PBN 02740000 SLA REGZ,2 02760000 L RAID,ATABAD 02780000 ST REGB,0(REGZ,RAID) SAVE ADD. OF BLOCK IN ATAB 02800000 LR AIB,REGB 02820000 MVC LENCOUNT(2),0(REGB) GET LENTH OF BLOCK 02840000 AH REGB,LENCOUNT 02860000 ST REGB,AITAB SAVE END ADDRESS OF BLOCK 02880000 LR RAID,AIB 02900000 TM 8(AIB),X'80' Q. IS BLOCK TYPE PROC 02920000 BZ SCANNXT NO 02940000 LA RAID,22(0,AIB) YES- SKIP CHECKING AGAINST 02960000 B SCANNXT+4 TYPE PROCEDURE NAME 02980000 SCANNXT LA RAID,11(0,RAID) 03000000 C RAID,AITAB Q. ALL IDENTIFIERS CHECKED 03020000 BE ALLOSTOR YES- GO TO ALLOCATE STORAGE 03040000 CLI 5(RAID),X'2B' Q. FOR HEAD OR CONT. ENTRY 03060000 BE SCANNXT YES- SKIP CHECKING 03080000 CLI 0(RAID),X'00' Q. INVALID PROCEDURE NAME 03100000 BE SCANNXT YES- SKIP CHECKING 03120000 LR RAKOM,RAID 03140000 CHECKNXT LA RAKOM,11(0,RAKOM) 03160000 C RAKOM,AITAB Q. ALL IDENT. CHECKED AGAINST 03180000 BE SCANNXT THE ONE PROCESSED 03200000 CLI 5(RAKOM),X'2B' Q. FOR HEAD OR CONT ENTRY 03220000 BE CHECKNXT 03240000 CLC 0(6,RAKOM),0(RAID) COMPARE EACH IDENTIFIER AGAINST 03260000 *ALL FOLLOWING INDENTIFIERS IN THE BLOCK 03280000 BNE CHECKNXT 03300000 TM 7(RAID),X'30' TWO EQUAL FOUND Q. PROCESSED 03320000 BM *+8 ONE FORMAL PARAMETER 03340000 B E43 NO 03360000 TM 7(RAKOM),X'30' Q. COMPARED ONE IS FORMAL PARAMETER 03380000 BM E43 YES 03400000 B CHECKNXT NO 03420000 SPACE 2 03440000 ***** ALLOSTOR ****************************************************** 03460000 * ALLOCATETS STORAGE FOR THE IDENTIFIERS 03480000 * FOR A TYPE PROC BLOCK ALLOCATION STARTS AT 32 03500000 * OTHERWISE AT 24 03520000 * NO BLOCK MAY GET MORE THAN 4K ALLOCATED 03540000 * IT IS ALSO CHECKED THAT THERE IS NO PROC, STRING 03560000 * OR SWITCH CALLED BY VALUE 03580000 * WHEN ALL DECLARATIONS IN THE BLOCK ARE 03600000 * PROCESSED DP-C WILL BE PUT IN PBTAB2 03620000 * IF THERE ARE MORE BLOCKS TO BE PROCESSED THE 03640000 * EXIT IS TO IDENTIFIER SCAN OTHERWISE 03660000 * TO WRITE ITAB 03680000 * FOUR POINTERS ARE USED DP DOUBLE WORD POINTER 03700000 * WP WORD 03720000 * HP HALF WORD 03740000 * BP BOOLEAN 03760000 * DP IS INCREASED BY C WHICH IS 8 FOR LONG 03780000 * 4 FOR SHORT 03800000 * FOR LONG PRESITION ALL 4 POINTERS ARE USED 03820000 * FOR SHORT WP IS NEVER USED, WILL CONTAIN 0 03840000 * ALL THE TIME 03860000 * REAL WILL BE ALLOCATED TO DP, 4 OR 8 BYTES 03880000 * INTEGER WILL GET DP OR WP. DP ALLWAYS IF SHORT 03900000 * WP IF LONG AND WP NOT ZERO 03920000 * OTHERWISE DP, IN WHITCH CASE WP WILL 03940000 * EQUAL DP+4 FOR THE NEXT INTEGER 03960000 * BOOLEAN WILL GET DP, WP, HP OR BP IF LONG 03980000 * DP, HP OR BP IF SHORT 04000000 * FIRST BOOLEAN FOUND WILL GET EITHER WP OR DP 04020000 * HP IS THEN INITILIZED TO WP+2 OR DP+2 04040000 * BP WP+1 DP+1 04060000 * SECOND BOOLEND WILL GET THE VALUE OF BP 04080000 * AND BP WILL BE 0 04100000 * THIRD BOOLEAN WILL GET HP AND HP WILL BE 0 04120000 * BP=HP+1 04140000 * FORTH BOOLEAN WILL GET BP AND BP WILL BE 0 04160000 * THIS WILL THEN BE REPEATED FOR EVERY FOUR 04180000 * BOOLEAN IDENTIFIERS 04200000 * ALL FORMAL PARAMETERS WILL GET THE DP VALUE 04220000 * AND DP WILL BE INCREASED BY 8 04240000 * ARRAYS WILL GET DP VALUE AND DP WILL BE 04260000 * INCREASED BY 4(DIM+6)+X WHERE X IS 4 04280000 * WHEN LONG PRECITION AND DIM IS AN UNEVAN 04300000 * NUMBER, OTHERWISE X IS 0 04320000 * LABEL, SWITCH , PROCEDURE WILL NOT GET ANYTHIN 04340000 * EX. OF STORAGE ALLOCATION 04360000 * LONG SHORT 04380000 * 01234567 01234567 FP FORMAL PARAMETER 04400000 * FP FP R REAL 04420000 * FP FP INT INTEGER 04440000 * R R INT B BOOLEAN 04460000 * INT INT INT INT NU NOT USED SPACE 04480000 * INT BBB BBB R 04500000 * R INT R 04520000 * INT NU 04540000 * R 04560000 SPACE 2 04580000 ALLOSTOR TM 8(AIB),X'80' Q. IS THE BLOCK A TYPE PROCEDURE 04600000 BZ STARTALL-4 NO 04620000 LA DP,32 YES- SET DOUBLE WORD POINTER 04640000 NI 8(AIB),X'7F' CLEAR TYPE PROCEDURE INDICATION 04660000 B *+8 04680000 LA DP,24 SET DOUBLE WORD POINTER 04700000 STARTALL LA WP,0 SET ALL POINTERS TO ZERO 04720000 LA HP,0 04740000 LA BP,0 04760000 LR RAID,AIB GET FIRST VARIABLE 04780000 B GETNEXT 04800000 STORALLO AH DP,C INCREASE ALLOCATION POINTER 04820000 C DP,FOURK Q. HAS FOURK BEEN ALLOCATED ALLREADY 04840000 BH E44 04860000 GETNEXT LA RAID,11(0,RAID) GET NEXT VARIABLE 04880000 STM DP,BP,DPC STORE ALL POINTERS 04900000 C RAID,AITAB Q. ALL VARIABLES TAKEN CARE OF 04920000 BE LASTREC YES 04940000 CLI 5(RAID),X'2B' Q. FOR HEADING OR CONTINUATION 04960000 BE GETNEXT 04980000 CLI 6(RAID),X'91' Q. ALL PURPOS IDENTIFIER 05000000 BE GETNEXT 05020000 TM 7(RAID),X'30' Q. FORMPARAM, DEK. VARIABL. OR CONST 05040000 BM FORMPARM 05060000 BZ CONST 05080000 TM 7(RAID),X'03' Q. BOOLEAN VARIABLE 05100000 BO BOOLEAN 05120000 TM HCOMPMOD,LNG Q,SHORT PRESISION 05140000 BZ REAL YES- ALLOCATE SAME FOR REAL AND 05160000 * INTEGER 05180000 TM 7(RAID),X'01' Q. INTEGER OR REAL 05200000 BO INTEGER 05220000 REAL MVC 9(2,RAID),DPC+2 MOVE IN DISPLACEMENT 05240000 B STORALLO 05260000 INTEGER LTR WP,WP Q. EMTY HOLE LEFT FOR INTEGER 05280000 BZ *+18 NO 05300000 MVC 9(2,RAID),WPC+2 YES- FILL THE HOLE AND MAKE 05320000 LA WP,0 WORDPOINTER= 0. 05340000 B GETNEXT 05360000 MVC 9(2,RAID),DPC+2 MOVE IN DOUBLEWORD POINTER AND MAKE 05380000 LA WP,4(0,DP) WORDPOINTER POINT TD EMPTY HOLE NEXT 05400000 B STORALLO TO IT 05420000 BOOLEAN LTR BP,BP Q SPACE LEFT NEXT TO PREVIOUS BOOL. 05440000 BZ *+18 NO 05460000 MVC 9(2,RAID),BPC+2 YES- MOVE IN DISPLACEMENT AND MAKE 05480000 LA BP,0 BYTE POINTER 0 05500000 B GETNEXT 05520000 LTR HP,HP Q.SPACE LEFT NEXT TO 2 PREVIOUS BOOL 05540000 BZ TESTWP-8 NO 05560000 MVC 9(2,RAID),HPC+2 YES- MOVE IN DISPLACEMENT AND MAKE 05580000 LA BP,1(0,HP) MAKE BYTEPOINTER POINT TO NEXT 05600000 LA HP,0 HALFWORD POINTER 0 05620000 B GETNEXT FREE BYTE 05640000 TM HCOMPMOD,LNG Q, SHORT PRECISION 05660000 BZ TAKEDP YES- DO NOT USE WP POINTER 05680000 TESTWP LTR WP,WP Q. WPPOINTE FREE 05700000 BZ TAKEDP NO- TAKE DP POINTER INSTEAP 05720000 MVC 9(2,RAID),WPC+2 YES- USE WP AS DISPLACEMENT 05740000 LA BP,1(0,WP) SET HP AND BP TO FREE BYTES IN WORD 05760000 LA HP,2(0,WP) 05780000 LA WP,0 SET WP TO ZERO 05800000 B GETNEXT 05820000 TAKEDP MVC 9(2,RAID),DPC+2 USE DP AS DISPLACEMENT 05840000 LA BP,1(0,DP) SET WP, HP, BP TO FREE BYTES WITHIN 05860000 LA HP,2(0,DP) THE DOUBLE WORD 05880000 LA WP,4(0,DP) 05900000 B STORALLO 05920000 CONST TM 7(RAID),X'04' FOR LABEL, STRING, PROCEDURE DO NOT 05940000 BZ GETNEXT 05960000 TM 7(RAID),X'08' ALLOCATE ANY STORAGE 05980000 BO GETNEXT 06000000 SR REGDIM,REGDIM 06020000 IC REGDIM,9(RAID) 06040000 SRA REGDIM,4 FOR AN ARRAY 06060000 LA REGDIM,6(0,REGDIM) STORAGE NEEDED IS 4(DIM+6)+X 06080000 SLA REGDIM,2 06100000 OC 9(2,RAID),DPC+2 OR IN THE DISP. TO SAVE DIMENSIONS 06120000 TM HCOMPMOD,LNG X IS 4 IF LONG PRECITION AND DIM IS 06140000 BZ *+16 06160000 TM 9(RAID),X'10' AN UNEVAN NUMBER 06180000 BZ *+8 INCREASE IF NEEDED TO GET 06200000 LA REGDIM,4(0,REGDIM) ON DOUBLE WORD BOUNDARY 06220000 LA DP,0(REGDIM,DP) 06240000 B STORALLO+4 06260000 FORMPARM TM 7(RAID),X'03' Q. TYPE PARAMETER 06280000 BZ NOTTYPE NO 06300000 FORMPALL MVC 9(2,RAID),DPC+2 MOVE IN DISPLACEMENT 06320000 LA DP,8(0,DP) 06340000 B STORALLO+4 06360000 NOTTYPE TM 7(RAID),X'10' Q. CALL BY NAME 06380000 BO FORMPALL YES 06400000 TM 7(RAID),X'03' NO- CHECK IF VALUE CALL CORRECT 06420000 BZ *+8 06440000 B FORMPALL 06460000 CLI 7(RAID),X'28' Q. LABLE CALLED BY VALUE 06480000 BE FORMPALL 06500000 B E45 PROC SWITCH OR STRING CALLED BY VALUE 06520000 LASTREC SR REGZ,REGZ CONSTRUCT ENTRY OF PBTAB2 06540000 IC REGZ,10(0,AIB) GET PBN 06560000 SLA REGZ,1 06580000 L REGP,APBTAB2 06600000 LA REGP,0(REGZ,REGP) 06620000 SH DP,C GET LAST BYTE USED 06640000 STH DP,0(0,REGP) 06660000 L REGI,SAVEPB 06680000 CH REGI,PBN Q.ALL ITAB-REC WRITTEN OUT 06700000 LA REGI,1(0,REGI) 06720000 ST REGI,SAVEPB 06740000 BNE READBLK NO 06760000 SPACE 2 06780000 ***** WRITITAB ****************************************************** 06800000 * WRITES THE ITABRECORD TO SYSUT3 IN PROGRAM BLOCK 06820000 * NUMBER ORDER 06840000 * THE ADDRESS TO WHERE THE BLOCK IS GOING TO BE 06860000 * WRITTEN IS PICKED UP FROM ATAB 06880000 * IN EACH BLOCK THE LENGTH OF THE NEXT BLOCK IS 06900000 * INSERTED 06920000 SPACE 2 06940000 WRITITAB L REGB,ATABAD START OF ADDRESS TABLE 06960000 L REGY,UT3ADD DCB ADDRESS 06980000 CLOSE ((REGY),REREAD),TYPE=T GET TO START OF SYSUT3 07000000 SR REGZ,REGZ 07020000 TM HCOMPMOD,PROC Q. IS THERE A PB0 07040000 BZ ITLP2 NO 07060000 ITABLOOP L REGY,0(0,REGB) GET ADDRESS OF BLOCK 07080000 L RAID,UT3ADD DCB ADDRESS 07100000 L REGC,4(0,REGB) GET ADDRESS OF NEXT BLOCK 07120000 CH REGZ,PBN Q. LAST BLOCK 07140000 BE *+10 YES 07160000 MVC 2(2,REGY),0(REGC) INSERT LENGTH OF NEXT BLOCK 07180000 MVC LENCOUNT(2),0(REGY) GET LENGTH OF CURRENT BLOCK 07200000 LH REG15,LENCOUNT 07220000 WRITE PRCH4,SF,(RAID),(REGY),(REG15) 07240000 CHECK PRCH4 07260000 ITLP2 LA REGB,4(0,REGB) GET ADDRESS OF NEXT BLOCK 07280000 CH REGZ,PBN Q.ALL ITAB-REC WRITTEN OUT 07300000 LA REGZ,1(0,REGZ) 07320000 BNE ITABLOOP NO 07340000 B ITABPRNT YES 07360000 SPACE 2 07380000 ***** E43 **************************************************** 07400000 * GENERATES ERROR MESSAGE 45 07420000 * RETURNS TO SCANNING FOR DUPLICATES 07440000 SPACE 2 07460000 E43 BAL REG15,ERRNAME 07480000 MVI 1(REGY),X'2D' E45 07500000 B SCANNXT 07520000 SPACE 2 07540000 ***** E45 ****************************************************** 07560000 * GENERATER ERROR MESSAGE 47 07580000 * RETURNS TO FORMPALL AS IF VAR. WAS CORRECT 07600000 SPACE 2 07620000 E45 BAL REG15,ERRNAME 07640000 MVI 1(REGY),X'2F' E47 07660000 B FORMPALL 07680000 SPACE 2 07700000 ***** E44 ****************************************************** 07720000 * GENERATES ERROR MESSAGE 214 07740000 * RETURNS TO LASTREC TO TAKE NEXT BLOCK, IF ANY 07760000 * * 07780000 * * 07800000 E44 L REGD,SAVEPB 07820000 BAL REGB,CONVERT CONVERT PBN 07840000 L REGY,NEXTERR 07860000 LA REGB,7(0,REGY) Q. SPACE LEFT IN ERRORPOOL 07880000 C REGB,ENDPOOL 07900000 BH E0 07920000 ST REGB,NEXTERR 07940000 MVI 0(REGY),X'87' MOVE LENGTH AND BLANK SC INDICATOR 07960000 MVI 1(REGB),X'D6' E214 07980000 MVC 4(3,REGY),SAVE+1 PBN 08000000 B LASTREC 08020000 SPACE 2 08040000 ***** ERRNAME ***** 08060000 * FINDS THE LENGTH OF THE VAR. IN ERROR CHECKS FOR 08080000 * ERRPOOL OVERFLOW, MOVES IN THE NAME OF THE 08100000 * VAR. AND LENGTH OF MESSAGE 08120000 * RETURNS TO CALLING PROGRAM, E43 OR E44 08140000 SPACE 2 08160000 ERRNAME LA REGB,5 08180000 STC REGB,*+7 08200000 CLI 0(RAID),X'00' FIND LENGTH OF NAME 08220000 BNE *+8 08240000 BCT REGB,ERRNAME+4 08260000 L RAKOM,NEXTERR 08280000 LA RAKOM,5(REGB,RAKOM) 08300000 C RAKOM,ENDPOOL CHECK SPACE IN ERRORPOOL 08320000 BH E0 08340000 L REGY,NEXTERR 08360000 ST RAKOM,NEXTERR 08380000 EX REGB,MOVE INSERT NAME IN ERROR PATTERN 08400000 LA REGB,5(0,REGB) 08420000 STC REGB,0(REGY) 08440000 OI 0(REGY),X'80' BLANK SC INDICATOR 08460000 BCR 15,REG15 08480000 CNOP 0,4 08500000 MOVE MVC 4(1,REGY),0(RAID) 08520000 E0 LA REGB,NEXTERR 08540000 MVI 0(REGB),X'02' 08560000 MVI 1(REGB),X'D4' E212 08580000 ST REGB,NEXTERR 08600000 B SLUT 08620000 SPACE 2 08640000 SPACE 2 08660000 ***** ITABPRNT ****************************************************** 08680000 * PRINTS ON SYSPRINT, IF SOURCE SPECIFIED, ALL VAR. 08700000 * THE BLOCKS IN PBN NUMBER ORDER AND WITH THE VAR 08720000 * SORTED WITHIN EACH BLOCK 08740000 * REGC KEEPS TRACK OF WHEN PRINTING IS NEEDED, THE 08760000 * INFORMATION ABOUT EACH VAR. IS BUILT UP IN 08780000 * WORK AND THEN TRANSFERD TO PRINTAREA. WHEN 08800000 * 3 VAR. HAVE BEEN PLACED IN THE PRINTAREA THE 08820000 * LINES IS PRINTED 08840000 * THE ADDRESS TO THE BLOCK IS TAKEN FROM ATAB 08860000 * THE LENGTH IS TAKEN FROM THE FIRST 2 BYTES IN THE 08880000 * BLOCK. 08900000 * THE SURROUNDING PBN FROM PBTAB1 08920000 * THE STARTING SC COUNTER FOR THE BLOCK FROM BYTE 6 08940000 * AND 7 IN THE BLOCK 08960000 * IF THE BLOCK DOES NOT CONTAIN ANY VAR. ONLY THE 08980000 * PBN AND SURROUNDING PBN ARE PRINTED 09000000 * ALL HEADENTRIES, FOR AND CONTLINES ARE SKIPPED 09020000 * EACH NEW BLOCK IS PRECEEDED BY A BLANK LINE 09040000 * START ADDRESS OF THE BLOCK IS IN AIB 09060000 * END ADDRESS OF THE BLOCK IS IN AITAB, THIS ADD. 09080000 * WILL BE AIB+11 WHEN ALL VAR. PROCESSED 09100000 SPACE 2 09120000 ITABPRNT TM HCOMPMOD+1,NSRCE Q. SOURCE SPECIFIED 09140000 BO SLUT NO 09160000 SR REGP,REGP CLEAR REGISTER 09180000 TM HCOMPMOD,PROC IS THERE A PB0 09200000 BO GETPB+4 YES- PROCESS PB0, REGP=0 09220000 GETPB LA REGP,1(0,REGP) INCREASE PBN 09240000 LR REGB,REGP 09260000 SLA REGB,2 09280000 L AIB,ATABAD GET ADDRESS OF NEW BLOCK 09300000 L AIB,0(REGB,AIB) VIA ATAB+ 4 TIMES PBN 09320000 MVC LENCOUNT(2),0(AIB) GET LENGTH OF THE BLOCK 09340000 LH REGB,LENCOUNT 09360000 LA REGB,0(REGB,AIB) GET END OF BLOCK 09380000 ST REGB,AITAB STORE END OF IT 09400000 BAL REGB,PRINTITB PRINT A BLANK LINE 09420000 LR REGD,REGP CONVERT PBN 09440000 BAL REGB,CONVERT 09460000 MVC 0(3,REGI),SAVE+1 NEW PBN 09480000 IC REGD,PBTAB1(REGP) CONVERT SURROUNDING PBN 09500000 BAL REGB,CONVERT 09520000 MVC 10(3,REGI),SAVE+1 SURROUNDING PBN 09540000 MVC SCSAVE(2),6(AIB) CONVERT SC COUNTER TO DECIMAL 09560000 LH REGB,SCSAVE 09580000 CVD REGB,DOUBLE STARTING SC OF BLOCK IS INSERTED 09600000 UNPK 4(5,REGI),DOUBLE(8) 09620000 MVZ 8(1,REGI),7(REGI) 09640000 CLC LENCOUNT(2),ELEVEN Q. EMPTY BLOCK 09660000 BNE *+12 NO 09680000 BAL REGB,PRINTITB FOR AN EMPTY BLOCK PRINT 09700000 B ENDBLOCK ONLY THE BLOCK NUMBERS 09720000 SR REGC,REGC 09740000 SPACE 2 09760000 ***** GETNVAR ***** 09780000 * LOOPS THROUGH BLOCK TO GET THE CURRENT LOWEST 09800000 * VAR. 09820000 * EXITS TO ENDBLOCK WHEN ALL VAR. IN THE BLOCK HAVE 09840000 * BEEN PROCESSED, OTHERWISE TO TESTVAR 09860000 SPACE 2 09880000 GETNVAR LA RAID,11(0,AIB) GET FIRST VAR. AFTER HEADING 09900000 LR REGY,RAID 09920000 C RAID,AITAB Q. ALL VAR. PROCESSED 09940000 BE ENDBLOCK YES 09960000 CLI 5(RAID),X'2B' Q. HEAD OR CONTINUATION LINE 09980000 BE ENDVAR2 10000000 TESTNXT LA REGY,11(0,REGY) GET NEXT VAR. 10020000 C REGY,AITAB Q. ALL VAR. COMPARED 10040000 BE TESTVAR 10060000 CLI 5(REGY),X'2B' Q. HEAD OR CONTINUATION LINE 10080000 BE TESTNXT YES- SKIP THAT LINE 10100000 CLC 0(6,RAID),0(REGY) Q. COMPARE CURRENT LOWEST - NEW 10120000 BL TESTNXT CURRENT LOWEST STILL LOW 10140000 LR RAID,REGY NO- SHIFT RAID TO NEW 10160000 B TESTNXT 10180000 SPACE 2 10200000 ***** TESTVAR ***** 10220000 * CHECKS THE INTERNAL NAME TO FIND TYPE AND MOVES 10240000 * CHARACTERISTICS TO WORKAREA 10260000 SPACE 2 10280000 TESTVAR TM 6(RAID),X'91' Q. ALL PURPOSE IDENTIFIER 10300000 BO ENDVAR YES 10320000 TM 7(RAID),X'03' Q. TYPE 10340000 BO BOL TYPE=BOOLEAN 10360000 BZ BOL+4 NOT TYPE 10380000 TM 7(RAID),X'01' Q.INTEGER OR REAL 10400000 BZ *+12 10420000 MVI WORK+7,C'I' INTEGER 10440000 B BOL+4 10460000 MVI WORK+7,C'R' REAL 10480000 B BOL+4 10500000 BOL MVI WORK+7,C'B' BOOLEAN 10520000 TM 7(RAID),X'0C' 10540000 BZ TESTPROC 10560000 BO SWITCH 10580000 TM 7(RAID),X'08' Q. ARRAY OR LABEL 10600000 BZ ARRAY 10620000 MVI WORK+8,C'L' LABEL 10640000 TESTPROC TM 7(RAID),X'C0' 10660000 BO PROCEDUR 10680000 BZ FORMAL 10700000 TM 7(RAID),X'40' 10720000 BZ FORMAL 10740000 MVI WORK+11,C'C' CODE PROCEDURE 10760000 B PROCEDUR 10780000 FORMAL TM 7(RAID),X'30' Q. SPECIFIED IDENTIFIER 10800000 BO ENDVAR 10820000 BZ ENDVAR 10840000 NI BITS1,PROCOFF RESET PROCEDURE BIT 10860000 TM 6(RAID),X'01' 10880000 BZ *+8 10900000 MVI WORK+8,C'T' STRING 10920000 TM 7(RAID),X'10' Q. NAME OR VALUE CALL 10940000 BZ *+12 10960000 MVI WORK+10,C'N' NAME 10980000 B ENDVAR 11000000 MVI WORK+10,C'V' VALUE 11020000 B ENDVAR 11040000 SWITCH MVI WORK+8,C'S' SWITCH A28230 11060019 B CONVERT2 CONVERT NR. OF COMPONENTS 11080000 PROCEDUR MVI WORK+9,C'P' PROCEDURE 11100000 OI BITS1,PROCBIT SET PROCEDURE BIT 11120000 B CONVERT2 CONVERT NR. OF PARAMETERS 11140000 ARRAY MVI WORK+9,C'A' ARRAY 11160000 SPACE 2 11180000 ***** CONVERT2 ***** 11200000 * ENTERED FOR PROCEDURE, ARRAY AND SWITCH CONVERTS 11220000 * THE NUMBER OF PARAMETERS, DIMENSIONS OR 11240000 * COMPONENTS TO DECIMAL FORM AND PUTS IT IN 11260000 * WORK 11280000 * FOR ARRAY OR SWITCH THE COUNTER IS FIRST 11300000 * INCREASED BY ONE TO GET THE REAL VALUE 11320000 SPACE 2 11340000 CONVERT2 TM 7(RAID),X'30' 11360000 BM FORMAL+12 11380000 IC REGD,9(0,RAID) 11400000 SRA REGD,4 SWITCH OR PROCEDURE 11420000 TM BITS1,PROCBIT TEST IF PROC PARAMETERS 11440000 BO *+8 YES 11460000 LA REGD,1(0,REGD) NO- INCREASE DIM COUNTER 11480000 NI BITS1,PROCOFF TO GIVE CORRECT VALUE 11500000 BAL REGB,CONVERT CONVERT IT TO DECIMAL 11520000 MVC WORK+13(2),SAVE+2 AND MOVE IT OUT 11540000 B FORMAL 11560000 SPACE 2 11580000 ***** CONVERT ***** 11600000 * CONVERTS FROM HEXADECIMAL TO DECIMAL 11620000 * USED FOR LN, DISP AND PBN TO BE WRITEN OUT 11640000 SPACE 2 11660000 CONVERT CVD REGD,DOUBLE CONVERT TO DECIMAL 11680000 UNPK SAVE(4),DOUBLE+5(3) UNPACK AND 11700000 MVZ SAVE+3(1),SAVE+2 CLEAR SIGN 11720000 BCR 15,REGB RETURN 11740000 SPACE 2 11760000 ***** PRINTITB ***** 11780000 * PRINTS A LINE, SAVES NEW PRINTAREA ADDRESS, RESETS 11800000 * REGC, RETURNS 11820000 SPACE 2 11840000 PRINTITB STM 14,15,SAVE1 11860000 L 15,PRTRTADD PRINT A RECORD 11880000 BALR 14,15 11900000 ST REGI,APRNTAR SAVE ADD. OF NEXT PRINT AREA 11920000 LM 14,15,SAVE1 11940000 SR REGC,REGC RESET REGC 11960000 BCR 15,REGB RETURN 11980000 SPACE 2 12000000 ***** ENDVAR ***** 12020000 * MOVES EXTERNAL NAME TO WORK, TRANSLATES IT 12040000 * CONVERTS LN OR DISP AND MOVES THAT TO WORK 12060000 * MOVES WORK TO CURRENT PRINTAREA WITH HELP OF AN 12080000 * EXECUTET MOVE 12100000 * INCREASES REGC AND CHECKS IF ONE LINE HAS BEEN 12120000 * FILLED UP. IN THAT CASE - PRINTS THAT LINE 12140000 * SHIFTS AWAY THE NOW PROCESSED VAR. AND STORES THE 12160000 * NEW ENDING ADDRESS OF THE BLOCK IN AITAB 12180000 * RETURNS TO PROCESS NEXT VAR. 12200000 SPACE 2 12220000 ENDVAR MVC WORK(6),0(RAID) MOVE EXTERNAL NAME 12240000 TR WORK(6),TRTAB 12260000 MVC SAVE2+1(1),10(RAID) MOVE 12280000 MVN SAVE2(1),9(RAID) AND 12300000 UNPK SAVE3(5),SAVE2(3) CONVERT DISP. OR LABELNUMBER 12320000 TR SAVE3+1(3),TAB-X'EF' TO BE WRITTEN OUT 12340000 MVC WORK+16(3),SAVE3+1 12360000 EX REG0,MOVEVAR(REGC) MOVE OUT WORK TO PRINTAREA 12380000 MVI WORK,C' ' CLEAR WORKAREA 12400000 MVC WORK+1(29),WORK 12420000 LA REGC,8(0,REGC) 12440000 C REGC,TWOFOUR Q. TIME TO PRINT 12460000 BNE *+8 NO 12480000 BAL REGB,PRINTITB YES- CALL FOR PRINTROUTINE 12500000 ENDVAR2 L REGY,AITAB 12520000 LA REGB,12(0,RAID) LEN. TO MOVE ITAB UP TO 12540000 C REGB,AITAB Q. NOTHING TO MOVE 12560000 BNH *+12 12580000 ST RAID,AITAB STOREADD. OF CURRENT AS END ADD. 12600000 B GETNVAR 12620000 SR REGY,REGB CALCULATE NEW END ADDRESS OF THE 12640000 LA REGB,1(REGY,RAID) BLOCKAND STORE IT IN AITAB 12660000 ST REGB,AITAB 12680000 COMPARE C REGY,D256 12700000 BNH EX1 12720000 MVC 0(256,RAID),11(RAID) TRANSFER A 256 BYTE SECTION 12740000 LA RAID,256(0,RAID) OF THE BLOCK AT THE TIME 12760000 S REGY,D256 12780000 B COMPARE 12800000 EX1 EX REGY,MOVEITAB MOVE LAST PARTIAL SECTION 12820000 B GETNVAR 12840000 SPACE 2 12860000 ***** ENDBLOCK ***** 12880000 * PRINTS LAST LINE OF BLOCK, IF NEEDED 12900000 * EXITS TO GETPB IF ANY BLOCK LEFT TO BE PROCESSED 12920000 * OTHERWISE A FREEMAIN IS DONE AND IEX21 IS LINKED 12940000 * TO 12960000 SPACE 2 12980000 ENDBLOCK C REGC,ZERO Q VAR LEFT TO BE WRITTEN OUT 13000000 BE *+8 13020000 BAL REGB,PRINTITB 13040000 LA REGB,1(0,REGP) 13060000 CH REGB,PBN Q ALL BLOCKS PROCESSED 13080000 BNH GETPB NO- TAKE NEXT 13100000 SLUT L REGI,ITAB20S ITAB AREA 13120000 LA REGI,1024(0,REGI) AND ATAB AREA ARE MADE 13140000 LR REG0,REGI FREEMAIN FOR 13160000 L REGI,AREALOC 13180000 FREEMAIN R,LV=(0),A=(1) 13200000 SLUT2 XCTL EP=IEX21000 13220000 HDING1 DC C'IDENTIFIER TABLE' 13240000 HEAD1 DC CL90'PBN SC PBN NAME TYPE DM DSP NAME X13260000 TYPE DM DSP NAME TYPE DM DSP' 13280000 HEAD2 DC CL90' SURR PR LN X13300000 PR LN PR LN ' 13320000 SCSAVE DS H SAVE SEMICOLON COUNTER 13340000 D256 DC F'256' USED BY MOVE LOOP 13360000 SAVE2 DC C'000' USED FOR CONVERTION 13380000 SAVE3 DC 5X'EF' 13400000 DOUBLE DC D'0' 13420000 MOVEITAB MVC 0(1,RAID),11(RAID) USED BY ENDVAR 13440000 WORK DC 30C' ' USED TO BUILD PRINT REC. 13460000 FOURK DC F'4095' STORAGE ALLOCATION MAXIMUM 13480000 MOVEVAR MVC 19(27,REGI),WORK USED TO SORT REC. TO BE PRINTED 13500000 CNOP 0,4 13520000 MVC 45(27,REGI),WORK 13540000 CNOP 0,4 13560000 MVC 71(19,REGI),WORK 13580000 TWOFOUR DC F'24' USED BY ENDVAR 13600000 C DC H'8' INCREASE VALUE DURING STORAGE ALLOCATION 13620000 * USED TO TRANSLATE FROM INTERNAL 13640000 * TO EBCDIC CODE 13660000 TRTAB DS 0CL90 13680000 DC C' ' 13700000 DC 47C')' 13720000 DC C'0123456789' 13740000 DC 6C')' 13760000 DC C'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 13780000 TAB DC C' 0123456789ABCDEF' FOR PRINTABLE HEXADECIMAL 13800000 ELEVEN DC X'000B' 13820000 WORKAREA DSECT 13840000 COPY WORKAREA 13860000 KOPOOL DS F ZERO CONSTANT 13880000 ZERO EQU KOPOOL 13900000 SAVE DS F 13920000 SAVE1 DS 4F 13940000 APBTAB2 DS A START ADD. OF PBTAB2 13960000 ATABAD DS A START ADD. OF ATAB 13980000 DPC DS F SAVE AREAS FOR DP, WP, HP AND BP 14000000 WPC DS F 14020000 HPC DS F 14040000 BPC DS F 14060000 AITAB DS F ITAB ADDRESS 14080000 APRNTAR DS A ADDRESS OF CURRENT PRINTAREA 14100000 AREALOC DS A ADDRESS OF GETMAIN POOL 14120000 SAVEPB DS F COUNTS NR. OF BLOCKS READ 14140000 LENCOUNT DS H SAVES LENGTH OF BLOCK 14160000 BITS1 DS C 14180000 PROCBIT EQU X'02' PROCEDURE IS PROCESSED 14200000 PROCOFF EQU X'FD' 14220000 END IEX20000 14240000 ./ ADD SSI=01050762,NAME=IEX21,SOURCE=0 TITLE 'IEX21, ERROR MESSAGE EDITING' 00020000 * * 00040000 *STATUS: CHANGE LEVEL 000. * 00060000 * * 00080000 *FUNCTION/OPERATION: THE ERROR PATTERNS GENERATED DURING SCANI/II * 00100000 * AND ITAB-MANIPULATION ARE HANDLED AND THE CORRESPONDING DIAGNOSTIC* 00120000 * MESSAGES ARE GENERATED. * 00140000 * * 00160000 *ENTRY POINT: * 00180000 * IEX21000 - ERROR MESSAGE EDITING XCTL EP=IEX21 * 00200000 * THE MODULE IS ENTERED FROM IEX20. * 00220000 * * 00240000 *INPUT: N/A * 00260000 * * 00280000 *OUTPUT: THE DIAGNOSTIC MESSAGES ARE PUT OUT ON SYSPRINT. IF SYSPRINT * 00300000 * IS DOWN THIS IS REPORTED ON THE CONSOLE TYPEWRITER. * 00320000 * * 00340000 *EXTERNAL ROUTINE: THE PRINT ROUTINE IN IEX00 IS USED. * 00360000 * * 00380000 *EXIT-NORMAL: IF NO TERMINATING ERROR HAS OCCURRED, CONTROL IS GIVEN * 00400000 * TO THE NEXT PHASE BY MEANS OF XCTL EP=IEX30000. * 00420000 * * 00440000 *EXIT-ERROR: IF A TERMINATING ERROR HAS OCCURRED (IN THIS MODULE OR * 00460000 * ONE OF THE PRECEDING) CONTROL IS GIVEN TO THE TERMINATING MODULE * 00480000 * BY MEANS OF XCTL EP=IEX51002. * 00500000 * * 00520000 *TABLES/WORKAREAS: THE MESSAGE TEXTS WITH CORRESPONDING ADDRESS TABLE * 00540000 * ARE IN THE LOAD MODULE IEX21M. * 00560000 * THE ERROR MESSAGE EDITING ROUTINE, CSECT IEX60000, ALSO USES THE * 00580000 * FOLLOWING TABLES: * 00600000 * WINTEBC FOR TRANSLATION OF INTERNAL CHARACTERS TO EBCDIC * 00620000 * WSYMBSRC FOR TRANSLATION OF * 00640000 * WSYMBSTK INTERNAL SYMBOLS TO EBCDIC * 00660000 * WORDSEBC FOR TRANSLATION OF COMPOUND SYMBOLS IF SOURCE IN EBCDIC * 00680000 * WORDSISO FOR TRANSLATION OF COMPOUND SYMBOLS IF SOURCE IN ISOCODE* 00700000 * WEBCDIC FOR TRANSLATION EBCDIC-EBCDIC * 00720000 * * 00740000 * A WORKAREA OF 270 BYTES, WAREA, IS USED FOR BUILDING THE MESSAGES.* 00760000 * * 00780000 *ATTRIBUTES: NONE. * 00800000 * * 00820000 *NOTES: CHARACTER CODE DEPENDENCE: FOR THE BUILDING OF A MESSAGE * 00840000 * (CODE PART BETWEEN COT03 AND COT12) THE FOLLOWING APPLIES: * 00860000 * IN CASE NO SOURCE INFORMATION IS TO BE INSERTED (COT31), OR IF * 00880000 * THE INFORMATION IS EBCDIC-CHARACTERS (COT07), THE OPERATION OF * 00900000 * CSECT IEX60000 DEPENDS UPON AN INTERNAL REPRESENTATION OF THE * 00920000 * EXTERNAL CHARACTER SET WHICH IS EQUIVALENT TO THE ONE USED AT * 00940000 * ASSEMBLY TIME. * 00960000 * IF THE SOURCE INFORMATION TO BE INSERTED IS INTERNAL CHARACTERS * 00980000 * (COT33) THE OPERATION OF CSECT IEX60000 DEPENDS UPON A TRANSLATION* 01000000 * FROM THE INTERNAL REPRESENTATION TO THE EBCDIC CHARACTER SET BY * 01020000 * MEANS OF THE TABLE 'WINTEBC'. * 01040000 * IF THE SOURCE INFORMATION TO BE INSERTED IS INTERNAL ALGOL SYMBOLS* 01060000 * (COT10) THE OPERATION OF CSECT IEX60000 DEPENDS UPON A TRANSLATION* 01080000 * FROM THE INTERNAL REPRESENTATION TO THE EBCDIC CHARACTER SET BY * 01100000 * MEANS OF THE TABLES 'WSYMBSTK'/'WSYMBSRC' AND 'WORDSISO'/ * 01120000 * 'WORDSEBC'. * 01140000 * FOR THE OUTPUT OF A MESSAGE (CODE PART BETWEEN COT12 AND COT21) * 01160000 * THE FOLLOWING APPLIES: * 01180000 * WHEN A MESSAGE HAS BEEN BUILT IN EBCDIC, AN EBCDIC-EBCDIC TRANSLA-* 01200000 * TION IS PERFORMED BEFORE OUTPUT BY MEANS OF THE TABLE 'WEBCDIC'. * 01220000 * THUS THE OUTPUT MAY BE MODIFIED BY MAKING CHANGES IN THIS TABLE. * 01240000 * * 01260000 * THE OPERATION OF CSECT IEX21000 DOES NOT DEPEND UPON A PARTICULAR * 01280000 * INTERNAL REPRESENTATION OF THE EXTERNAL CHARACTER SET. * 01300000 * * 01320000 * AT SYSTEM GENERATION THIS MODULE WILL BE LINKED TOGETHER WITH * 01340000 * THE MODULE IEX21M TO FORM THE MODULE IEX21 IN LINKLIB. * 01360000 * * 01380000 * THIS MODULE IS ONLY INTENDED TO BE EXECUTED IN CONNECTION * 01400000 * WITH THE OTHER MODULES OF THE ALGOL COMPILER. IN PARTICULAR IT * 01420000 * REQUIRES THE COMMON WORKAREA. * 01440000 * * 01460000 EJECT 01480000 IEX21000 CSECT 01500000 SPACE 01520000 * REGISTER DEFINITIONS 01540000 SPACE 01560000 RINFO EQU 1 01580000 RCOT EQU 2 01600000 RET EQU 14 01620000 RENT EQU 15 01640000 SPACE 2 01660000 USING *,RENT 01680000 SPACE 01700000 L RCOT,=A(IEX60000) ADDRESS ERROR MSG EDIT ROUTINE 01720000 LA RET,SCAN3 LOAD RETURN ADDRESS 01740000 LA RINFO,ERRINFO ADDRESS INFO FOR ERROR ED ROUT 01760000 BR RCOT GO TO ERROR MESSAGE EDITING 01780000 SPACE 2 01800000 DS 0F 01820000 SCAN3 EQU * INITIALIZATION OF SCAN III 01840000 XCTL EP=IEX30000 01860000 SPACE 2 01880000 ERRINFO DC V(IEX21M00) ADDRESS OF MESSAGE TEXTS 01900000 DC V(IEX21M01) ADDRESS OF ADDRESS-TABLE 01920000 DC H'152' MODIFICATION NUMBER 01940000 SPACE 01960000 LTORG 01980000 EJECT 02000000 COPY IEX60000 02020000 EJECT 02040000 WORKAREA DSECT 02060000 COPY WORKAREA 02080000 END 02100000 ./ ADD SSI=00055220,NAME=IEX21M,SOURCE=0 TITLE 'IEX21M, ERROR MESSAGE TEXT POOL 1' 00020000 * * 00040000 *STATUS: CHANGE LEVEL 000. * 00060000 * * 00080000 *FUNCTION/OPERATION: THIS MODULE CONTAINS MESSAGE TEXTS FOR ALL * 00100000 * ERRORS THAT MAY BE DETECTED BY IEX00, IEX10, IEX11, AND IEX20, * 00120000 * AND THE CORRESPONDING ADDRESS TABLE. * 00140000 * * 00160000 *ENTRY POINT: N/A. * 00180000 * * 00200000 *INPUT: N/A. * 00220000 * * 00240000 *OUTPUT: N/A. * 00260000 * * 00280000 *EXTERNAL ROUTINES: N/A. * 00300000 * * 00320000 *EXITS-NORMAL: N/A. * 00340000 * * 00360000 *EXITS-ERROR: N/A. * 00380000 * * 00400000 *TABLES/WORKAREAS: N/A. * 00420000 * * 00440000 *ATTRIBUTES: N/A. * 00460000 * * 00480000 *NOTES: AT SYSTEM GENERATION THIS MODULE WILL BE LINKED TOGETHER WITH * 00500000 * THE MODULE IEX21 TO FORM THE MODULE IEX21 IN LINKLIB. * 00520000 * * 00540000 IEX21M00 CSECT 00560000 SPACE 00580000 ENTRY IEX21M01 00600000 SPACE 00620000 WEMPOOL1 EQU * ERROR MESSAGE POOL 1 00640000 SPACE 00660000 W001 DC X'1C00' 00680000 DC CL27'WINVALID CHARACTER DELETED.' 00700000 W002 DC X'2100' 00720000 DC CL32'WILLEGAL PERIOD. PERIOD DELETED.' 00740000 W003 DC X'2F0300130C240020000F20' 00760000 DC CL37'WINVALID COLON AFTER . COLON DELETED.' 00780000 W004 DC X'1900' 00800000 DC CL24'TLETTER STRING TOO LONG.' 00820000 W005 DC X'3F00' 00840000 DC CL62'SIDENTIFIER BEGINS WITH INVALID CHARACTER. IDENTIFIX00860000 ER DELETED.' 00880000 W006 DC X'2500' 00900000 DC CL36'TLABEL CONTAINS TOO MANY CHARACTERS.' 00920000 W007 DC X'5005001412240027001B27F00000000D43' 00940000 DC CL64'WLABEL BEGINNING WITH CONTAINS INVALID CHARACTER.CX00960000 OLON DELETED.' 00980000 W008 DC X'3500' 01000000 DC CL52'WLABEL BEGINS WITH INVALID CHARACTER. COLON DELETEDX01020000 .' 01040000 W010 DC X'3703001F0C24002C000B2C' 01060000 DC CL45'SSPECIFICATION PART OF PROCEDURE INCOMPLETE.' 01080000 W011 DC X'2800' 01100000 DC CL39'SPROGRAM STARTS WITH ILLEGAL DELIMITER.' 01120000 W012 DC X'3C0300150C240022001A22' 01140000 DC CL50'WTWO APOSTROPHES AFTER . FIRST APOSTROPHE DELETED.' 01160000 W013 DC X'3E0300310C24003E00003E' 01180000 DC CL52'WAPOSTROPHE ASSUMED AFTER DELIMITER BEGINNING WITH X01200000 .' 01220000 W014 DC X'470300180C240025002225' 01240000 DC CL61'SDELIMITER BEGINNING WITH INVALID. FIRST APOSTROPHX01260000 E DELETED.' 01280000 W015 DC X'3400' 01300000 DC CL51'WMISSING SEMICOLON AFTER ''CODE''. SEMICOLON ASSUMEX01320000 D.' 01340000 W016 DC X'5A0500191224002C001B2CF00000001248' 01360000 DC CL74'SIDENTIFIER BEGINNING WITH CONTAINS INVALID CHARACX01380000 TER.IDENTIFIER DELETED.' 01400000 W017 DC X'3E00' 01420000 DC CL61'SMORE THAN 65535 SEMICOLONS. SEMICOLON COUNTER RESEX01440000 T TO ZERO.' 01460000 W018 DC X'2A00' 01480000 DC CL41'WDELIMITER ''COMMENT'' IN ILLEGAL POSITION.' 01500000 W020 DC X'6200' 01520000 DC CL97'TBLOCKS, COMPOUND STATEMENTS, FOR STATEMENTS AND PRX01540000 OCEDURE DECLARATIONSNESTED TO TOO MANY LEVELS.' 01560000 W021 DC X'2B03000A0C240017001417' 01580000 DC CL33'SDECLARATOR IN ILLEGAL POSITION.' 01600000 W022 DC X'1F00' 01620000 DC CL30'TMORE THAN 255 PROGRAM BLOCKS.' 01640000 W023 DC X'1700' 01660000 DC CL22'SSTRING POOL OVERFLOW.' 01680000 W024 DC X'3700' 01700000 DC CL54'SDELIMITER ''CODE'' IN ILLEGAL POSITION. ''CODE'' DX01720000 ELETED.' 01740000 W025 DC X'530300310CF0000000153E' 01760000 DC CL73'SSPECIFIER ''STRING'' OR ''LABEL'' IN ILLEGAL POSITX01780000 ION.SPECIFICATION DELETED.' 01800000 W026 DC X'430300090C240016002D16' 01820000 DC CL57'WPARAMETER MULTIPLY SPECIFIED. FIRST SPECIFICATIONX01840000 USED.' 01860000 W027 DC X'550500091224001C00231CF00000001540' 01880000 DC CL69'SPARAMETER MISSING FROM FORMAL PARAMETER LIST.SPECX01900000 IFICATION IGNORED.' 01920000 W028 DC X'3E00' 01940000 DC CL61'SDELIMITER ''VALUE'' IN ILLEGAL POSITION. ''VALUE''X01960000 PART DELETED.' 01980000 W029 DC X'2900' 02000000 DC CL40'WSPECIFICATION PART PRECEDES VALUE PART.' 02020000 W030 DC X'2D0300090C240016001716' 02040000 DC CL35'WPARAMETER REPEATED IN VALUE PART.' 02060000 W031 DC X'660500391224004C00004CF0000000194D' 02080000 DC CL86'WLEFT PARENTHESIS NOT FOLLOWED BY / AFTER ARRAY IDEX02100000 NTIFIER .SUBSCRIPT BRACKET ASSUMED.' 02120000 W032 DC X'5C05003512240048000048F00000001349' 02140000 DC CL76'SMISSING RIGHT PARENTHESIS IN BOUND PAIR LIST OF ARX02160000 RAY .DECLARATION DELETED.' 02180000 W033 DC X'440300370C240044000044' 02200000 DC CL58'TMORE THAN 16 DIMENSIONS OR COMPONENTS IN DECLARATIX02220000 ON OF .' 02240000 W034 DC X'6805000D12240020002320F00000002444' 02260000 DC CL88'SARRAY SEGMENT NOT FOLLOWED BY SEMICOLON OR COMMA.X02280000 CHARACTERS TO NEXT SEMICOLON DELETED.' 02300000 W035 DC X'3900' 02320000 DC CL56'WILLEGAL PERIOD IN ARRAY OR SWITCH LIST. PERIOD DELX02340000 ETED.' 02360000 W036 DC X'360300290C240036000036' 02380000 DC CL44'TMORE THAN 15 PARAMETERS IN DECLARATION OF .' 02400000 W037 DC X'6805003012240043000043F00000002444' 02420000 DC CL88'SSEMICOLON MISSING AFTER FORMAL PARAMETER LIST OF .X02440000 CHARACTERS TO NEXT SEMICOLON DELETED.' 02460000 W038 DC X'2B00' 02480000 DC CL42'TTOO MANY IDENTIFIERS DECLARED IN A BLOCK.' 02500000 W039 DC X'790484000F00390FF00000003049' 02520000 DC CL108'S MISSING ''END'' BRACKETS. OPEN BLOCKS, COMPOUND X02540000 STATEMENTS,FOR STATEMENTS AND PROCEDURE DECLARATIONS CLOX02560000 SED.' 02580000 W041 DC X'1F00' 02600000 DC CL30'TMORE THAN 255 FOR STATEMENTS.' 02620000 W042 DC X'3A00' 02640000 DC CL57'W''BEGIN'' PRECEDES PRECOMPILED PROCEDURE. ''BEGIN'X02660000 ' DELETED.' 02680000 W043 DC X'5E0300300CF0000000213D' 02700000 DC CL84'SEQUAL NUMBER OF ''BEGIN'' AND ''END'' BRACKETS FOUX02720000 ND.REMAINING PART OF PROGRAM IGNORED.' 02740000 W044 DC X'1A00' 02760000 DC CL25'TNO SOURCE PROGRAM FOUND.' 02780000 W045 DC X'4003000A0C240017002917' 02800000 DC CL54'SIDENTIFIER MULTIPLY DECLARED. LAST DECLARATION USX02820000 ED.' 02840000 W045B DC X'300300230C240030000030' 02860000 DC CL38'SILLEGAL CALL BY VALUE OF IDENTIFIER .' 02880000 SPACE 02900000 * 02920000 * DIRECTORY MESSAGES, INITIATION PHASE 02940000 * 02960000 SPACE 02980000 W200 EQU * 03000000 W046 DC X'380300100C84001D001B1D' 03020000 DC CL46'WOPTION PARAMETER INVALID. PARAMETER IGNORED.' 03040000 W201 EQU * 03060000 W047 DC X'2D03000B0C840018001518' 03080000 DC CL35'TDD CARD FOR INCORRECT OR MISSING.' 03100000 W202 EQU * 03120000 W048 DC X'4100' 03140000 DC CL64'WDD CARD FOR SYSLIN INCORRECT OR MISSING. OPTION NOX03160000 LOAD ASSUMED.' 03180000 W203 EQU * 03200000 W049 DC X'4300' 03220000 DC CL66'WDD CARD FOR SYSPUNCH INCORRECT OR MISSING. OPTION X03240000 NODECK ASSUMED.' 03260000 W204 EQU * 03280000 W050 DC X'2A00' 03300000 DC CL41'TBLOCKSIZE SPECIFIED FOR SYSIN INCORRECT.' 03320000 W205 EQU * 03340000 W051 DC X'480300170C840024002424' 03360000 DC CL62'WBLOCKSIZE SPECIFIED FOR INCORRECT. UNBLOCKED OUTPX03380000 UT ASSUMED.' 03400000 W206 EQU * 03420000 W052 DC X'4200' 03440000 DC CL65'WTOO MANY OPTION PARAMETER ERRORS. SUBSEQUENT PARAMX03460000 ETERS IGNORED.' 03480000 W207 EQU * 03500000 W053 DC X'2700' 03520000 DC CL38'WPOSSIBLE ERROR IN DD NAMES PARAMETER.' 03540000 W208 EQU * 03560000 W054 DC X'2D00' 03580000 DC CL44'WSIZE PARAMETER INVALID. SIZE 45056 ASSUMED.' 03600000 SPACE 03620000 * 03640000 * OTHER DIRECTORY MESSAGES 03660000 * 03680000 SPACE 03700000 W209 EQU * 03720000 W055 DC X'460400360FF00000840046000046' 03740000 DC CL57'TCOMPILATION UNSUCCESSFUL DUE TO PROGRAM INTERRUPT.X03760000 PSW .' 03780000 W056 EQU * 03800000 W210 EQU * 03820000 DC X'300300230C840030000030' 03840000 DC CL38'TUNRECOVERABLE I/O ERROR ON DATA SET .' 03860000 W057 EQU * 03880000 W211 EQU * 03900000 DC CL56'PROGRAM INTERRUPT IN ERROR MESSAGE EDITING ROUTINE.X03920000 PSW ' 03940000 W058 EQU * 03960000 W212 DC X'1200' 03980000 DC CL17'TTOO MANY ERRORS.' 04000000 W059 EQU * 04020000 W213 DC X'2800' 04040000 DC CL39'TINTERNAL OVERFLOW OF IDENTIFIER TABLE.' 04060000 W060 EQU * 04080000 W214 DC X'3903002D0C84003A00003A' 04100000 DC CL48'SDATA STORAGE AREA EXCEEDED, PROGRAM BLOCK NO. .' 04120000 W215 EQU * 04140000 W061 DC X'1A00' 04160000 DC CL25'TSOURCE PROGRAM TOO LONG.' 04180000 W216 DC X'2600' 04200000 DC CL37'STOO MANY LABELS. LABEL NUMBER RESET.' 04220000 EJECT 04240000 DS 0F 04260000 SPACE 2 04280000 IEX21M01 EQU * ADDRESS TABLE FOR WEMPOOL1 04300000 SPACE 04320000 DC F'0' 04340000 DC A(W001) 04360000 DC A(W002) 04380000 DC A(W003) 04400000 DC A(W004) 04420000 DC A(W005) 04440000 DC A(W006) 04460000 DC A(W007) 04480000 DC A(W008) 04500000 DS A 04520000 DC A(W010) 04540000 DC A(W011) 04560000 DC A(W012) 04580000 DC A(W013) 04600000 DC A(W014) 04620000 DC A(W015) 04640000 DC A(W016) 04660000 DC A(W017) 04680000 DC A(W018) 04700000 DC F'0' 04720000 DC A(W020) 04740000 DC A(W021) 04760000 DC A(W022) 04780000 DC A(W023) 04800000 DC A(W024) 04820000 DC A(W025) 04840000 DC A(W026) 04860000 DC A(W027) 04880000 DC A(W028) 04900000 DC A(W029) 04920000 DC A(W030) 04940000 DC A(W031) 04960000 DC A(W032) 04980000 DC A(W033) 05000000 DC A(W034) 05020000 DC A(W035) 05040000 DC A(W036) 05060000 DC A(W037) 05080000 DC A(W038) 05100000 DC A(W039) 05120000 DS F 05140000 DC A(W041) 05160000 DC A(W042) 05180000 DC A(W043) 05200000 DC A(W044) 05220000 DC A(W045) 05240000 DC F'0' 05260000 DC A(W045B) 05280000 DC A(W046) 05300000 DC A(W047) 05320000 DC A(W048) 05340000 DC A(W049) 05360000 DC A(W050) 05380000 DC A(W051) 05400000 DC A(W052) 05420000 DC A(W053) 05440000 DC A(W054) 05460000 DC A(W055) 05480000 DC A(W056) 05500000 DC A(W057) 05520000 DC A(W058) 05540000 DC A(W059) 05560000 DC A(W060) 05580000 DC A(W061) 05600000 DC A(W216) 05620000 END 05640000 ./ ADD SSI=03012812,NAME=IEX30,SOURCE=0 TITLE 'IEX30, SCAN III' 00020000 * * 00040000 *STATUS: CHANGE LEVEL 000. * 00060000 * * 00080000 *FUNCTION/OPERATION: THE SOURCE PROGRAM IS TRANSFORMED FROM MODIFICA- * 00100000 * TION LEVEL 1 INTO MODIFICATION LEVEL 2. MAIN FUNCTIONS: EXTERNAL * 00120000 * NAMES OF IDENTIFIERS ARE REPLACED BY THE INTERNAL NAMES CONTAINED * 00140000 * IN THE ITAB-ENTRY OF THE IDENTIFIER, AND CONSTANTS ARE REPLACED BY* 00160000 * INTERNAL NAMES CONSTRUCTED IN IEX30. * 00180000 * OBJECT CODE IS PRODUCED FROM THE CONSTANT POOL IF ANY OF THE PARA-* 00200000 * METERS DECK OR LOAD IS SPECIFIED IN THE EXEC-CARD. * 00220000 * FOR STATEMENTS ARE CLASSIFIED FOR FUTHER USE BY IEX50. * 00240000 * THE SUBSCRIPT TABLE (SUTAB)AND THE LEFT VARIABLE TABLE (LVTAB) ARE* 00260000 * CONSTRUCTED FOR FUTHER USE BY IEX40. * 00280000 * SOURCE PROGRAM ERRORS CAUSES GENERATION OF ERROR PATTERNS FOR * 00300000 * FUTHER USE BY 1EX31. * 00320000 * * 00340000 *ENTRY POINT: * 00360000 * IEX30000. * 00380000 * * 00400000 *INPUT: THE SOURCE PROGRAM MODIFICATION LEVEL 1 IS READ IN FROM * 00420000 * SYSUT1. * 00440000 * THE IDENTIFIER TABLE (ITAB) IS READ IN FROM SYSUT3. * 00460000 * * 00480000 *OUTPUT: THE SOURCE PROGRAM MODIFICATION LEVEL 2 IS WRITTEN OUT ON * 00500000 * SYSUT2. * 00520000 * OBJECT TXT-RECORDS IS WRITTEN ON SYSLIN OR/AND SYSPUNCH IF THE * 00540000 * PARAMETERS LOAD OR/AND DECK ARE SPECIFIED IN THE EXEC-CARD. * 00560000 * THE SUBSCRIPT TABLE (SUTAB) IS WRITTEN OUT ON SYSUT3. A LINEAR * 00580000 * SUBSCRIPT EXPRESSION ENCOUNTED IN A FOR STATEMENT THAT IS OPTIMI- * 00600000 * ZABLE IN REGARD TO SUBSCRIPTS WILL GENERATE AN ENTRY IN THIS * 00620000 * TABLE. * 00640000 * THE LEFT VARIABLE TABLE (LVTAB) IS WRITTEN OUT ON SYSUT3. INTEGER * 00660000 * LEFT VARIABLES ENCOUNTED IN FOR STATEMENT THAT IS OPTIMIZABLE IN * 00680000 * REGARD TO SUBSCRIPTS WILL GENERATE AN ENTRY IN THIS TABLE. * 00700000 * * 00720000 *EXTERNAL ROUTINES: THE INTERRUPT ROUTINE OF IEX00 ARE USED FOR ALL * 00740000 * INTERRUPTS EXCEPT FLOATING POINT OVERFLOW. * 00760000 * * 00780000 *EXITS-NORMAL: CONTROL IS ALWAYS GIVEN TO IEX31 BY MEANS OF * 00800000 * XCTL EP=IEX31. * 00820000 * * 00840000 *TABLES/WORKAREAS: GROUP TABLE (GPTAB) CONSTRUCTED IN IEX11, USED TO * 00860000 * DIAGNOSE BRANCHES INTO FOR STATEMENTS. * 00880000 * SCOPE TABLE (SPTAB) CONSTRUCTED IN IEX11, USED TO CHECK SUBSCRIPT * 00900000 * EXPRESSIONS FOR POSSIBLE OPTIMIZATION. * 00920000 * FOR STATEMENT TABLE (FSTAB) CONSTRUCTED IN IEX30 COMPLEATED IN * 00940000 * IEX40 AND FINALLY USED IN IEX50, CONTAINS A CLASSIFICATION BYTE * 00960000 * FOR EVERY FOR STATEMENT * 00980000 * ERROR POOL CONSTRUCTED IN IEX30 AND USED IN IEX31, CONTAINS ERROR * 01000000 * PATTERNS GENERATED FROM SOURCE PROGRAM ERRORS. * 01020000 * CONSTANT POOL INTERNAL TABLE IN IEX30. THE FIRST APPEARANCE OF A * 01040000 * CONSTANT IN THE SOURCE STREAM GENERATES AN ENTRY IN THE TABLE. THE* 01060000 * RELATIVE ADDRESS OF THE CONSTANT POOL ENTRY IS USED IN CONSTRUCT- * 01080000 * ING THE INTERNAL NAME OF A CONSTANT. * 01100000 * CRITICAL VARIABLE TABLE (CRIDTAB) INTERNAL TABLE IN IEX30. DURING * 01120000 * THE TREATMENT OF A FOR STATEMENT THE TABLE CONTAINS ENTRIES * 01140000 * CORRESPONDING TO THE IDENTIFIERS IN THE FOR LIST. * 01160000 * * 01180000 *ATTRIBUTES: NONE. * 01200000 * * 01220000 *NOTES: THE OPERATION OF THIS MODULE DOES NOT DEPEND ON ANY SPECIAL * 01240000 * REPRESENTATION OF THE CHARACTER SET. * 01260000 * THIS MODULE IS ONLY INTENDED TO BE EXECUTED IN CONNECTION * 01280000 * WITH THE OTHER MODULES OF THE ALGOL COMPILER. IN PARTICULAR IT * 01300000 * REQUIRES THE COMMON WORKAREA. * 01320000 * * 01340000 EJECT 01360000 R0 EQU 0 01380000 R1 EQU 1 01400000 R2 EQU 2 01420000 ZINR EQU 3 INPUT RECORD POINTER REGISTER 01440000 ZOUR EQU 4 OUTPUT RECORD POINTER REGISTER 01460000 R5 EQU 5 01480000 R6 EQU 6 01500000 R7 EQU 7 01520000 R8 EQU 8 01540000 R9 EQU 9 01560000 R10 EQU 10 BASE REGISTER 01580000 R11 EQU 11 BASE REGISTER 01600000 R12 EQU 12 BASE REGISTER 01620000 WAREG EQU 13 WORKAREA BASE REGISTER 01640000 R14 EQU 14 01660000 R15 EQU 15 01680000 WORKR EQU R5 01700000 WORKX EQU R6 01720000 SPACE 01740000 * LENGTHS OF VARIABEL AREAS 01760000 FIXITABL EQU 319 LENGTH OF ITAB FIXED PART 01780000 SPACE 01800000 * BIT PATTERNS 01820000 ONEREC EQU X'40' SOURCE INPUT IN CORE STORAGE 01840000 MANYREC EQU X'BF' SOURCE INPUT ON SYSUT1 01860000 SYNTAX EQU X'80' SYNTAX CHECK MODE 01880000 SARRAY EQU X'80' HANDLING ARRAY DECLARATION 01900000 SSWITCH EQU X'40' HANDLING SWITCH DECLARATION 01920000 FF EQU X'FF' 01940000 SPACE 01960000 * SCALE FACTOR MASKS 01980000 SFSIGN EQU X'80' SIGNED SCALE FACTOR 02000000 SFL0 EQU X'40' LEADING ZERO IN SCALE FACTOR 02020000 SF19 EQU X'20' SIGNIFICANT DIGIT IN SCALE FAC. 02040000 SF EQU X'10' SCALE FACTOR PRESENT 02060000 SFDIGIT EQU X'60' 02080000 SFLSIGN EQU X'E0' 02100000 PRECERR EQU X'08' REAL CONSTANT EXCEEDS PRECITION 02120000 SPACE 02140000 * CLASSIFICATION MASKS OF I/O STATUS ON SYSUT3 02160000 READM EQU X'80' UNCHECKED READ OPERATION 02180000 WRITEM EQU X'40' UNCHECKED WRITE OPERATION 02200000 READC EQU X'20' CHECKED READ OPERATION 02220000 WRITEC EQU X'10' CHECKED WRITE OPERATION 02240000 SPACE 02260000 * FOR STATEMENT CLASSIFICATION MASKS 02280000 NOCOUNT EQU X'80' COUNTING LOOP IMPOSSIBLE 02300000 NOSUOP EQU X'40' NO SUBSCRIPT OPTIMIZATION 02320000 OUTOFFOR EQU X'20' BRANCH OUT OF FOR STATEMENT 02340000 NORMAL EQU X'F0' NORMAL LOOP 02360000 STEPM EQU X'08' STEP IN FORLIST 02380000 WHILEM EQU X'84' WHILE IN FOR LIST 02400000 EJECT 02420000 IEX30000 CSECT 02440000 *3491 1511 02446018 *3491265600 1513 02452018 * RELEASE 20 CHANGES A32962 02454000 * 205400-206400 A32962 02456000 START BALR R12,0 02460000 USING *,R12 02480000 USING IEX30001,R11 02500000 USING IEX30002,R10 02520000 USING WORKAREA,WAREG 02540000 L R11,ASEC1 02560000 L R10,ASEC2 02580000 B INITIATE 02600000 EJECT 02620000 ZERO DC 3H'0' 02640000 ONE DC H'1' 02660000 FIVE DC H'5' 02680000 SEVEN DC H'7' 02700000 EIGHT DC H'8' 02720000 NINE DC H'9' 02740000 TEN DC H'10' 02760000 ELEVEN DC H'11' 02780000 TWELVE DC H'12' 02800000 FIFTEEN DC H'15' 02820000 EIGHTEEN DC H'18' 02840000 FIVSIX DC H'56' 02860000 SIXFOUR DC H'64' 02880000 TWOFIVFI DC H'255' 02900000 C1792 DC H'1792' 02920000 FOURK DC H'4096' 02940000 SPACE 02960000 * ERROR MESSAGE NUMBERS 02980000 INVOP DC H'80' SYNTAX ERROR IN OPERAND 03000000 UNDEFOP DC H'81' UNDEFINED IDENTIFIER 03020000 RANGEREA DC H'82' REAL CONSTANT OUT OF RANGE 03040000 RANGEINT DC H'83' INTEGER OUT OF RANGE 03060000 PRECREAL DC H'84' PRECITION OF REAL TOO GREAT 03080000 GOTOFOR DC H'85' GO TO INTO FOR STATEMENT 03100000 MANYCON DC H'86' TOO MANY CONSTANTS 03120000 TABOVER DC H'87' OPTIMIZATION TABLE OVERFLOW 03140000 ARRAYERR DC H'88' INVALID ARRAY LIST IDENTIFIER 03160000 SWITCHER DC H'89' SWITCH DECLARATION ERROR 03180000 ITABOVER DC H'213' ITAB OVERFLOW 03200000 TOOMANY EQU 212 TOO MANY ERRORS 03220000 TOOLONG DC H'215' TOO MUCH SOURCE OUTPUT 03240000 SPACE 03260000 * SUBSCRIPT TABLE 03280000 ZSUTAPO DS F CURRENT SUTAB PT 03300000 ZSUDAD DS F ADDRESS OF FIRST SUTAB ENTRY 03320000 ZSUTMAX DS F SUTAB END PT 03340000 SUSTRT DS F START ADDRESS OF SUTAB RECORD 03360000 SUKEY DC C'SUTB' SUTAB RECORD IDENTIFICATION 03380000 SULENGTH DC F'0' ACCUMULATED LENGTH OF SUTAB 03400000 SUCNT DC H'0' NUMBER OF WRITTEN SUTAB RECORDS 03420000 SPACE 03440000 * LEFT VARIABLE TABLE 03460000 ZLESTA DS F ADDRESS OF FIRST LVTAB ENTRY 03480000 ZLEVA DS F CURRENT LVTAB PT 03500000 ZLEMAX DS F LVTAB END PT 03520000 LVSTRT DS F START ADDRESS OF LVTAB RECORD 03540000 LVKEY DC C'LVTB' LVTAB RECORD IDENTIFICATION 03560000 LVLENGTH DC F'0' ACCUMULATED LENGTH OF LVTAB 03580000 LVCNT DC H'0' NUMBER OF WRITTEN LVTAB RECORDS 03600000 SPACE 03620000 * INPUT RECORD 03640000 ZIBRUN DS F START OF ACTIVE INPUT BUF 03660000 ZIBREAD DS F START OF NEXT INPUT BUFFER 03680000 SPACE 03700000 * OUTPUT RECORD 03720000 ZOBWORK DS F START OF ACTIVE OUTPUT BUFFER 03740000 ZOBWRITE DS F START OF LAST OUTPUT BUFFER 03760000 ZFILE1 DS F OUTPUT RECORD END - 1 03780000 ZFILE2 DS F OUTPUT RECORD END - 2 03800000 ZFILE3 DS F OUTPUT RECORD END - 3 03820000 ZFILE5 DS F OUTPUT RECORD END - 5 03840000 ZFILE6 DS F OUTPUT RECORD END - 6 03860000 ZFILE9 DS F OUTPUT RECORD END - 9 03880000 ZOUTCOT DC H'1' OUTPUT RECORD NUMBER 03900000 SPACE 03920000 * IDENTIFIER TABLE 03940000 ZIBSTAO DS F ITAB START ADDRESS 03960000 ZITAN DS F ADDR OF ITAB ENTRY OF LAST ID. 03980000 ZCURITEN DS F ADDRESS OF LAST ITAB ENTRY 04000000 ZITREC DS F START OF NEXT ITAB RECORD 04020000 ZITEND DS F ITAB END ADDRESS 04040000 ZCURITLE DS H LENGTH OF LAST ITAB RECORD 04060000 SPACE 04080000 * ERROR MESSAGES 04100000 ZBEGERR DS F START OF VARIABLE INFORMATION 04120000 ZENDERR DS F END OF VARIABLE INFORMATION 04140000 ZERRONU DS H ERROR NUMBER 04160000 SPACE 04180000 * ARRAY IDENTIFIER STACK 04200000 ZARMAX DC A(ZARSTACK+28) END ADDRESS IN ARIDSTACK 04220000 ZARNO DC A(ZARSTACK-7) START ADDRESS OF ARIDSTACK 04240000 ZARSPO DC A(ZARSTACK-7) CURRENT PT IN ARIDSTACK 04260000 ZPOSIX DC H'0' COMPONENT NUMBER IN ARRAY 04280000 ZARSTACK DS CL35 ARIDSTACK 04300000 SPACE 04320000 * SUBSCRIPT TEST ROUTIN2 04340000 SUBEND DS F SUBSCRIPT END ADDRESS 04360000 ADDEND DS 3H SAVE AREA FOR ADDEND 04380000 FACTOR DS 3H SAVE AREA FOR FACTOR 04400000 ZEROELEM DC XL6'00C801000000' INTERNAL CODE FOR +0 04420000 ONEELEM DC XL6'00C801000004' INTERNAL CODE FOR +1 04440000 ZBRACK DS F SUBSCRIPT START ADDRESS - 1 04460000 SPACE 04480000 ZSTO DS F TEMPORARY STORAGE 04500000 ZSTO1 DC X'0670' A32962 04506000 ZSTO2 DC X'0240' A32962 04512000 ZIGN DC H'0' CURRENT IDENTIFIER GROUP NUMBER 04520000 ZPOINT DC X'3E3E3E3E3E3E' 04540000 ZALLPUP DC X'91FF010000' ALL PURPOSE IDENTIFIER 04560000 ZALLPU EQU ZALLPUP-6 04580000 ZIDEX DS 37C WORKAREA 04600000 NUMBER EQU ZIDEX+1 04620000 OPSTART DC A(ZIDEX) 04640000 SPACE 04660000 BRCNT DS H BRACKET COUNTER IN ARRAY DECL. 04680000 STATUS DC X'00' STATUS BYTE 04700000 CURPBN DS C PBN OF LAST BLOCK 04720000 ZCLOBRA DC X'00' SUBSCRIPT TEST BYTE 04740000 ZFORTEST DC X'00' FOR STATEMENT TEST BYTE 04760000 ZLVOV DC X'00' SET X'FF' IF NO MORE SUBSC OPT 04780000 ZFSN DS C CURRENT FOR STATEMENT NUMBER 04800000 FSNEMBR DS C NUMBER OR EMBRACING BLOCK 04820000 IOBYTE DS C STATUS BYTE FOR SYSUT3 04840000 NOTEW DS F ID. OF LAST WRITTEN RECORD 04860000 NOTER DS F ID. OF LAST READ ITAB RECORD 04880000 SPACE 04900000 * CRITICAL VARIABLE TABLE 04920000 PFA DS F CURRENT CRIDTAB PT 04940000 PFANO DS F START ADDRESS OF CRIDTAB 04960000 PFAMAX DS F END ADDRESS OF CRIDTAB 04980000 ZFSPTR DS F PT TO CURRENT FSTAB ENTRY 05000000 ZFOCRI DS F 05020000 SPACE 05040000 * CONSTANT POOL 05060000 ZKOPOOL DS F START ADDRESS OF POOL 05080000 ZKOPEND DS F END ADDRESS OF POOL 05100000 ZLITSTA DS F START ADDRESS OF USED PART 05120000 ZTEXTCO DS F END ADDRESS OF TXT PIECE 05140000 ZKBNMAX DS H NUMBER OF NEXT POOL 05160000 TXTPUT DC H'56' LENGTH OF TXT PIECE 05180000 SPACE 05200000 ZPACK DS D WORKAREA TO PACK NUMBERS 05220000 ZEROFLOA DC D'0.0' 05240000 ZONEFLOA DC D'1.0' 05260000 ZTEN9 DC D'1.0E+9' 05280000 ZFLOFIEL DC X'4E00000000000000' WORKAREA FOR FLOATING CONVERS. 05300000 ROUND DC X'0000000080000000' USED TO ROUND SHORT FORM REAL 05320000 ZWP DS F WORD PT IN CONSTANT POOL 05340000 ZDWP DS F DOUBLE WORD PT IN CONSTANT POOL 05360000 NSTART DC A(NUMBER) PTR TO NUMBER 05380000 SCALEMSK DC XL4'38' 05400000 LREAL DC F'8' SHORT PREC 4, LONG PREC 8 05420000 NREAL DC F'18' SHORT PREC 7, LONG PREC 18 05440000 ZLIRE DS H 05460000 ZINTYP DC X'C801' ID. OF INTEGER CONSTANT 05480000 ZREALTYP DC X'C802' ID. OF REAL CONSTANT 05500000 SREF DC P'+1' PLUS 05520000 DC P'-1' MINUS, MUST FOLLOW SREF 05540000 SCATEST DS C SCALE FACTOR TEST BYTE 05560000 SCALEQ DC X'2E00' 05580000 SCALE EQU SCALEQ+1 05600000 MAXNR DC X'32313437343833363437' INTERNAL CODE OF MAX INTEGER 05620000 SCAWORK DS 10C STORE FOR SCALE FACTOR 05640000 ZTO DS F 05660000 ZEXCORR DS F 05680000 ZTOSCA DS F 05700000 SCAWORKA DC A(SCAWORK+1) 05720000 SPACE 05740000 OLDSPIE DS F ADDRESS OF OLD PICA 05760000 TABSIZE DS F ACCUMULATED SIZE OF TABLES 05780000 REGSAVE DS 5F SAVE AREA FOR REGISTERS 05800000 SPECUSE DC XL4'06' 05820000 ALIGN DC F'0' FULL WORD ALIGNMENT 05840000 ALIGNH EQU ALIGN+2 HALF WORD ALIGNMENT 05860000 SPACE 05880000 ZEXTABP DC D'1.0E+1' 05900000 DC D'1.0E+2' 0892 05920000 DC D'1.0E+3' 0900 05940000 DC D'1.0E+4' 0908 05960000 DC D'1.0E+5' 0916 05980000 DC D'1.0E+6' 0924 06000000 DC D'1.0E+7' 0932 06020000 SPACE 06040000 DC D'1.0E+8' 0940 06060000 DC D'1.0E+16' 06080000 DC D'1.0E+24' 0956 06100000 DC D'1.0E+32' 0964 06120000 DC D'1.0E+40' 0972 06140000 DC D'1.0E+48' 0980 06160000 DC D'1.0E+56' 0988 06180000 DC D'1.0E+64' 0996 06200000 SPACE 06220000 ZEXTABN DC D'1.0E-1' 06240000 DC D'1.0E-2' 1024 06260000 DC D'1.0E-3' 1032 06280000 DC D'1.0E-4' 1040 06300000 DC D'1.0E-5' 1048 06320000 DC D'1.0E-6' 1056 06340000 DC D'1.0E-7' 1064 06360000 SPACE 06380000 DC D'1.0E-8' 1072 06400000 DC D'1.0E-16' 1080 06420000 DC D'1.0E-24' 1088 06440000 DC D'1.0E-32' 06460000 DC D'1.0E-40' 1104 06480000 DC D'1.0E-48' 1112 06500000 DC D'1.0E-56' 1120 06520000 DC D'1.0E-64' 1128 06540000 GENER EQU * 06560000 DC X'5454546854685454' 06580000 DC X'3C606438541C2020' 06600000 DC 8X'54' 06620000 DC X'245C543430' 06640000 DC 8X'54' 06660000 DC X'4054544438282C545018480C' 06680000 DC 9X'08' 06700000 DC X'00004C581014' 06720000 DC 26X'04' 06740000 IDENTI DC 45X'10' 1292 06760000 DC X'000C04' 06780000 DC 13X'00' 06800000 DC X'080C0C' 06820000 DC 26X'00' 06840000 DIG19 DC 45X'18' 06860000 DC X'000C10' 1372 06880000 DC 13X'00' 06900000 DC X'140408' 06920000 DC 26X'0C' 06940000 DIG0 DC 45X'1C' 1452 06960000 DC X'00081400' 06980000 DC 9X'04' 07000000 DC X'000000180C10' 07020000 DC 26X'08' 07040000 DECPO DC 45X'14' 1532 07060000 DC X'00081004' 07080000 DC 13X'00' 07100000 DC X'080C' 07120000 DC 26X'08' 07140000 SCAFAC DC X'0C0C' 1612 07160000 DC 43X'18' 07180000 DC X'00101408' 07200000 DC 9X'04' 07220000 DC 4X'00' 07240000 DC 28X'10' 07260000 SPACE 07280000 * ITAB ENTRIES OF STANDARD PROCEDURES 07300000 FIXITAB EQU * 07320000 DC X'013F0000002B0000000000' HEADER FOR PBN O 07340000 DC X'4041520000008882002080' ABS 07360000 DC X'5248464D000088810020C0' SIGN 07380000 DC X'4B444D46534788810000E0' LENGTH 07400000 DC X'5258524042538A80911203' SYSACT 07420000 DC X'5250515300008882002004' SQRT 07440000 DC X'52484D0000008882002008' SIN 07460000 DC X'424E52000000888200200C' COS 07480000 DC X'40514253404D8882002010' ARCTAN 07500000 DC X'4B4D000000008882002014' LN 07520000 DC X'44574F0000008882002018' EXP 07540000 DC X'444D5348445188810020F0' ENTIER 07560000 DC X'484D52584C418A8090181F' INSYMB 07580000 DC X'484D5144404B8A800A1822' INREAL 07600000 DC X'484D484D53448A80091826' ININTE 07620000 DC X'484D414E4E4B8A800B182A' INBOOL 07640000 DC X'484D4051514088800E182E' INARRA 07660000 DC X'484D5340515188800D1832' INTARR 07680000 DC X'484D414051518880071836' INBARR 07700000 DC X'4E545352584C888010143B' OUTSYM 07720000 DC X'4E5453514440888002143E' OUTREA 07740000 DC X'4E5453484D538880011442' OUTINT 07760000 DC X'4E5453414E4E8880031446' OUTBOO 07780000 DC X'4E5453405151888006144A' OUTARR 07800000 DC X'4E5453534051888005144E' OUTTAR 07820000 DC X'4E54534140518880071452' OUTBAR 07840000 DC X'4E54535253518880001456' OUTSTR 07860000 DC X'4F54530000008A8004115A' PUT 07880000 DC X'4644530000008A8004115E' GET 07900000 SPACE 07920000 ASEC1 DC A(IEX30001) 07940000 ASEC2 DC A(IEX30002) 07960000 EJECT 07980000 INITIATE EQU * 08000000 LA WORKR,TERM1 ERROR EXIT ADDRESS 08020000 ST WORKR,ERET 08040000 LA WORKR,LOMEGA6 PROVIDE EOD ADDR 2846 08046015 ST WORKR,EODUT1 FOR UT1 2846 08052015 MVC SEMCNT(2),ZERO SET SEMICOLON COUNTER TO ZERO 08060000 SPIE INTERUPT,((1,7),9,11,12,15) 08080000 ST R1,OLDSPIE SAVE ADDRESS OF OLD PICA 08100000 SPACE 08120000 * ALLOCATE STORAGE FOR TABLESD 08140000 LH R0,FOURK CONSTANT POOL SIZE 08160000 A R0,ITAB30S ITABSIZE 08180000 A R0,SRCE1S INPUT BUFFER SIZE 08200000 A R0,SRCE3S OUTPUT BUFFER SIZE 08220000 A R0,SRCE3S OUTPUT BUFFER SIZE 08240000 A R0,CRIDTABS CRIDTAB SIZE 08260000 A R0,SUTAB30S SUTAB SIZE 08280000 A R0,LVTAB30S LVTAB SIZE 08300000 AH R0,EIGHT RECORD KEY LENGTH 08320000 ST R0,TABSIZE SAVE TABLE AREA LENGTH 08340000 GETMAIN R,LV=(0) ALLOCATE STORAGE 08360000 LA WORKR,TERM2 ERROR RETURN ADDRESS 08380000 ST WORKR,ERET 08400000 ST R1,ZKOPOOL CONSTANT POOL START ADDRESS 08420000 AH R1,FOURK 08440000 ST R1,ZIBSTAO ITAB START ADDRESS 08460000 A R1,ITAB30S 08480000 ST R1,ZIBREAD SECOND INPUT BUFFER START ADDR. 08500000 A R1,SRCE1S 08520000 ST R1,ZOBWORK OUTPUT BUFFER START ADDRESS 08540000 A R1,SRCE3S 08560000 ST R1,ZOBWRITE OUTPUT BUFFER START ADDRESS 08580000 A R1,SRCE3S 08600000 ST R1,ZFOCRI CRIDTAB START ADDRESS 08620000 A R1,CRIDTABS 08640000 ST R1,SUSTRT SUTAB START ADDRESS 08660000 A R1,SUTAB30S 08680000 LA R1,4(0,R1) 08700000 ST R1,LVSTRT LVTAB START ADDRESS 08720000 SPACE 08740000 * INITILIZE INPUT BUFFERS 08760000 L ZINR,SRCE1ADD ADDRESS OF FIRST INPUT BUFFER 08780000 ST ZINR,ZIBRUN 08800000 TM HCOMPMOD+2,ONEREC INPUT ALREADY IN CORE 08820000 BO INCORE YES 08840000 BAL R15,ICHAI READ FIRST RECORD 08860000 INCORE EQU * 08880000 SPACE 08900000 * ITAB POINTERS INITIALIZATION 08920000 L R1,ZIBSTAO ITAB START ADDRESS 08940000 MVC 0(256,R1),FIXITAB INSERT ITAB FIXED PART 08960000 MVC 256(FIXITABL-256,R1),FIXITAB+256 08980000 LA WORKR,FIXITABL-11(0,R1) ADDRESS LAST FIXED ENTRY 09000000 ST WORKR,ZCURITEN 09020000 LA WORKR,11(0,WORKR) ADDRESS FIRST FREE ITAB ENTRY 09040000 ST WORKR,ZITREC 09060000 A R1,ITAB30S ITAB END ADDRESS PLUS 1 09080000 ST R1,ZITEND 09100000 L R1,UT3ADD ADDRESS OF DCB-SUSUT3 09120000 NOTE (1) ID OF LAST ITAB BLOCK 09140000 ST R1,SULTSTRT TRANSFER TO SUBSCRIPT HANDLING 09160000 ST R1,NOTEW PREPARE WRITE OF SUTAB OR LVTAB 09180000 L WORKR,UT3ADD DCB ADDRESS 09200000 CLOSE ((WORKR),REREAD),TYPE=T TEMPORARY CLOSE 09220000 BAL R15,ITABREAD READ FIRST ITAB RECORD 09240000 SPACE 09260000 * INITILIZE OUTPUT BUFFERS 09280000 L ZOUR,ZOBWORK START OF ACTIVE OUTPUT BUFFER 09300000 L WORKR,SRCE3S LENGTH OF OUTPUT BUFFER 09320000 SH WORKR,TWELVE SET BUFFER END PTRS 09340000 AR WORKR,ZOUR 09360000 ST WORKR,ZFILE9 09380000 LA WORKR,3(0,WORKR) 09400000 ST WORKR,ZFILE6 09420000 LA WORKR,1(0,WORKR) 09440000 ST WORKR,ZFILE5 09460000 LA WORKR,2(0,WORKR) 09480000 ST WORKR,ZFILE3 09500000 LA WORKR,1(0,WORKR) 09520000 ST WORKR,ZFILE2 09540000 LA WORKR,1(0,WORKR) 09560000 ST WORKR,ZFILE1 09580000 BCTR ZOUR,0 09600000 SPACE 09620000 * CRIDTAB AND FSTAB INITIALIZATION 09640000 L R1,ZFOCRI CRIDTAB START ADDRESS 09660000 SH R1,NINE INITILIZE PTRS 09680000 ST R1,PFANO 09700000 ST R1,PFA CURRENT CRIDTAB PTR 09720000 A R1,CRIDTABS GET ADDRESS OF LAST ENTRY 09740000 ST R1,PFAMAX END PTR 09760000 MVI ZFOSTA,X'00' ZEROIZE FSTAB 09780000 MVC ZFOSTA+1(254),ZFOSTA 09800000 LA WORKR,FSTAB-1 START ADDRESS OF FSTAB -1 09820000 ST WORKR,ZFSPTR INITILIZE FORSTATEMENT ZERO 09840000 SPACE 09860000 * SUTAB INITIALIZATION 09880000 L R1,SUSTRT SUTAB START ADDRESS 09900000 MVC 0(4,R1),SUKEY SET SUTAB KEY 09920000 SH R1,TEN INITILIZE PTRS 09940000 ST R1,ZSUDAD START PTR 09960000 ST R1,ZSUTAPO CURRENT PTR 09980000 A R1,SUTAB30S 10000000 ST R1,ZSUTMAX END PTR 10020000 SPACE 10040000 * LVTAB INITIALIZATION 10060000 L R1,LVSTRT LVTAB START ADDRESS 10080000 MVC 0(4,R1),LVKEY SET LVTAB KEY 10100000 ST R1,ZLESTA START PTR 10120000 ST R1,ZLEVA CURRENT PTR 10140000 A R1,LVTAB30S 10160000 ST R1,ZLEMAX END PTR 10180000 SPACE 10200000 * LITERAL HANDLING INITIALIZATION 10220000 TM HCOMPMOD,X'02' LONG PRECITION 10240000 BNZ INLIT2 YES 10260000 LA WORKR,4 10280000 ST WORKR,LREAL 10300000 LA WORKR,7 10320000 ST WORKR,NREAL MAXIMAL PRECITION 10340000 INLIT2 EQU * 10360000 SPACE 10380000 * CONSTANT POOL INITALIZATION 10400000 L R1,ZKOPOOL CONSTANT POOL START ADDRESS 10420000 LH WORKR,FOURK LENGTH OF CONSTANT POOL 10440000 AR WORKR,R1 CONSTANT POOL END ADDRESS 10460000 ST WORKR,ZKOPEND END PTR 10480000 A R1,PRPT 10500000 ST R1,ZWP WORD PTR 10520000 ST R1,ZDWP DOUBLE WORD PTR 10540000 ST R1,ZLITSTA START ADDRESS OF ACTIVE POOL 10560000 AH R1,TXTPUT TXT OUTPUT PTR 10580000 ST R1,ZTEXTCO 10600000 MVC ZKBNMAX(2),PBN PREPARE CONSTANT POOL EXCHANGE 10620000 MVC KBN(2),ZERO CURRENT POOL NUMBER 10640000 SPACE 10660000 * START READ INTO ALTERNATE INPUTBUFFER IF NECCESSARY 10680000 TM HCOMPMOD+2,ONEREC 10700000 BO INITEND YES 10720000 BAL R15,ICHA 10740000 INITEND EQU * 10760000 SPACE 10780000 NI HCOMPMOD+2,X'FF'-NOSC SET SEMICOLON COUNTER ACTIVE 10800000 TM HCOMPMOD,PROC PRECOMPILED PROCEDURE 10820000 BZ *+8 NO 10840000 BAL R15,ITABMOVE YES, GET ITAB RECORD 10860000 B GENTEST 10880000 EJECT 10900000 GENTEST1 LA ZINR,1(0,ZINR) 10920000 GENTEST SR R2,R2 10940000 TRT 0(80,ZINR),GENER 10960000 B *(R2) 10980000 B LETTER 11000000 B DIGIT19 11020000 B DIGIT0 11040000 B DECPOIN 11060000 B SCAFACT 11080000 B QUOTE 11100000 B BETA 11120000 B PIPHI 11140000 B FOR 11160000 B EPSILON 11180000 B ETA 11200000 B DO 11220000 B WHILE 11240000 B SEMIDELT 11260000 B OPBRACK 11280000 B COMMA 11300000 B CLOBRACK 11320000 B ZETA 11340000 B GAMMA 11360000 B OMEGA 11380000 B OTHOP 11400000 B RHO 11420000 B STEP 11440000 B ARRAY 11460000 B SWITCH 11480000 B DIPOW 11500000 SPACE 3 11520000 * STRING OR LOGICAL VALUE 11540000 QUOTE EQU * 11560000 C ZOUR,ZFILE5 OUTPUT BUFFER EXCHANGE 11580000 BH LQUOT2 YES 11600000 LQUOT3 MVC 1(5,ZOUR),1(ZINR) OUTPUT INTERNAL NAME 11620000 LA ZINR,6(0,ZINR) 11640000 CLI 0(ZINR),X'2E' FOLLOWS AN OPERATOR 11660000 BNL LQUOT1 PROBABLY NOT, MIGHT BE ZETA 11680000 LQUOT5 LA ZOUR,5(0,ZOUR) STEP OUTPUT PTR 11700000 B GENTEST BRANCH TO GENTEST 11720000 LQUOT2 BAL R15,OUCHA BRANCH TO SUBROUTINE OUCHA 11740000 B LQUOT3 BRANCH TO LQUOT3 11760000 LQUOT1 CLI 0(ZINR),X'2F' ZETA 11780000 BNE LQUOT4 NO, GIVE ERROR MESSAGE 11800000 BAL R15,ICHA CHANGE INPUT BUFFER 11820000 CLI 0(ZINR),X'2E' FOLLOWS OPERATOR 11840000 BL LQUOT5 YES 11860000 LQUOT4 MVC ZIDEX(6),ZPOINT REPLACE OPERAND BY SIX POINTS 11880000 LA RTO,ZIDEX+6 11900000 LA R0,ZIDEX+12 11920000 MVC ZERRONU(2),INVOP 11940000 B INCOROP INCORRECT OPERAND ERROR ROUTINE 11960000 SPACE 3 11980000 * PROGRAM BLOCK BEGIN 12000000 BETA EQU * 12020000 CLI LETTERB,X'F0' PROCEDURE BLOCK TO READ 12040000 BE LBETA4 YES 12060000 BETA1 BAL R15,ITABMOVE READ ITAB BLOCK 12080000 LBETA2 C ZOUR,ZFILE2 COMPARE ZOUT WITH ZFILE(2) 12100000 BH LBETA1 BRANCH IF HIGH 12120000 LBETA3 MVC 1(2,ZOUR),0(ZINR) 12140000 LA ZOUR,2(0,ZOUR) ZOUT IS INCREASED BY 2 12160000 MVC ZIGN(2),2(ZINR) IGN IS RECOGNIZED AND STORED 12180000 LA ZINR,4(0,ZINR) ZIN IS INCREASED BY 4 12200000 B GENTEST BRANCH TO GENTEST 12220000 LBETA1 BAL R15,OUCHA BRANCH TO SUBROUTINE OUCHA 12240000 B LBETA3 BRANCH TO LBETA 2 12260000 LBETA4 BAL R15,ITABMOP READ PROCEDURE BLOCK 12280000 B BETA1 12300000 SPACE 3 12320000 * PROCEDURE BLOCK BEGIN 12340000 PIPHI EQU * 12360000 NI PROCHD,X'0F' PROC. HEAD SWITCH ON 0209 12370014 CLI LETTERB,X'F0' PROCEDURE BLOCK TO READ 12380000 BE LPIPHI6 12400000 PIPHI1 MVC ZIGN(2),1(ZINR) SAVE CURRENT IGN 12420000 C ZOUR,ZFILE6 SPACE IN OUTPUT BUFFER 12440000 BH LPIPHI1 BRANCH IF HIGH 12460000 LPIPHI2 MVC 1(1,ZOUR),0(ZINR) OPERATOR IS MOVED TO O-BUFFER 12480000 LA ZOUR,1(0,ZOUR) ZOUT IS INCREASED BY 1 12500000 LA ZINR,3(0,ZINR) ZIN IS INCREASED BY 3 12520000 LPIPHI3 CLI 0(ZINR),X'40' LETTER FOLLOWS IN SOURCE INPUT 12540000 BL LPIPHI4 NO 12560000 OI LETTERB,X'F0' YES, SET PROCEDURE SWITCH 12580000 B LETTER GET IDENT. AND READ ITAB 0209 12600014 SPACE 12620000 LPIPHI4 CLI 0(ZINR),X'2F' ZETA IN SOURCE INPUT 12640000 BE LPIPHI5 YES 12660000 BAL R15,ITABMOVE NO, READ ITAB BLOCK 12680000 B GENTEST 12700000 SPACE 12720000 LPIPHI5 BAL R15,ICHA GET NEXT INPUT RECORD 12740000 B LPIPHI3 12760000 LPIPHI1 BAL R15,OUCHA BRANCH TO SUBROUTINE OUCHA 12780000 B LPIPHI2 BRANCH TO LPIPHI2 12800000 LPIPHI6 BAL R15,ITABMOP READ PROCEDURE BLOCK 12820000 B PIPHI1 12840000 SPACE 3 12860000 * FOR STATEMENT BEGIN 12880000 FOR MVI ZFORTEST,X'C0' ZFORTEST IS SET TO X'C0' 12900000 L WORKR,ZFSPTR UPDATE PTR TO FSTAB ENTRY 12920000 LA WORKR,1(0,WORKR) 12940000 ST WORKR,ZFSPTR 12960000 LA WORKX,FSTAB GET FOR STATEMENT NUMBER 12980000 SR WORKR,WORKX 13000000 STC WORKR,ZFSN 13020000 LFOR3 MVC ZIGN(2),1(ZINR) IGN IS RECOGNIZED AND STORED 13040000 C ZOUR,ZFILE1 TEST IF SPACE IN OUTPUT-BUFFER 13060000 BH LFOR1 BRANCH IF HIGH 13080000 LFOR4 MVC 1(1,ZOUR),0(ZINR) 13100000 LA ZOUR,1(0,ZOUR) ZOUT IS INCREASED BY 1 13120000 LA ZINR,3(0,ZINR) ZIN IS INCREASED BY 3 13140000 B GENTEST BRANCH TO GENTEST 13160000 LFOR1 BAL R15,OUCHA BRANCH TO SUBROUTINE OUCHA 13180000 B LFOR4 BRANCH TO LFOR2 13200000 SPACE 3 13220000 * END OF PROGRAM OR PROCED URE BLOCK 13240000 EPSILON EQU * 13260000 CLI LETTERB,X'F0' ITAB BLOCK TO READ 13280000 BE EPSILON2 YES 13300000 EPSILON1 L R6,ZCURITEN ADDRESS LAST ITAB ENTRY 13320000 SH R6,ZCURITLE ZCURITEN=ZCURITEN-ZCURITLE 13340000 ST R6,ZCURITEN ZCURITEN IS STORED 13360000 MVC ZCURITLE(2),17(R6) ZCURITLE IS UPDATED 13380000 B LBETA2 BRANCH TO LBETA2 13400000 EPSILON2 BAL R15,ITABMOP READ ITAB BLOCK 13420000 B EPSILON1 13440000 SPACE 3 13460000 * FOR STATEMENT END 13480000 ETA MVI ZFORTEST,X'00' ZFORTEST IS SET TO X'00' 13500000 TM HCOMPMOD,SYNTAX COMPILE MODE 13520000 BO LFOR3 NO 13540000 BAL R15,CRIFODEL BRANCH TO SUBROUTINE CRIFODEL 13560000 B LFOR3 BRANCH TO LFOR3 13580000 SPACE 3 13600000 * FOR LIST END 13620000 DO MVI ZFORTEST,X'00' ZFORTEST IS SET TO X'00' 13640000 LDO3 C ZOUR,ZFILE1 COMPARE ZOUT WITH ZFILE(1) 13660000 OTHOP EQU LDO3 13680000 BH LDO1 BRANCH IF HIGH 13700000 LDO2 MVC 1(1,ZOUR),0(ZINR) OPERATOR IS MOVED TO O-BUFFER 13720000 LA ZOUR,1(0,ZOUR) ZOUT IS INCREASED BY 1 13740000 B GENTEST1 13760000 LDO1 BAL R15,OUCHA BRANCH TO SUBROUTINE OUCHA 13780000 B LDO2 BRANCH TO LDO2 13800000 SPACE 3 13820000 * WHILE 13840000 WHILE EQU * 13860000 L WORKR,ZFSPTR ADDRESS FSTAB ENTRY 13880000 OI 0(WORKR),WHILEM INDICATE 'WHILE HAS APPEARED' 13900000 B LDO3 13920000 SPACE 3 13940000 * STEP OPERATOR 13960000 STEP EQU * 13980000 L WORKR,ZFSPTR ADDRESS FSTAB ENTRY 14000000 OI 0(WORKR),STEPM INDICATE 'STEP HAS APPEARED' 14020000 B LDO3 14040000 SPACE 3 14060000 * DIVIDE AND POWER ROUTINE 14080000 DIPOW EQU * 14100000 CLI ZFORTEST,X'00' OPERATOR IN FOR LIST 14120000 BE OTHOP NO, MOVE TO OUTPUT STREAM 14140000 L WORKR,ZFSPTR YES, ADDRESS FSTAB ENTRY 14160000 OI 0(WORKR),NOCOUNT COUNTING LOOP IMPOSSIBLE 14180000 B OTHOP MOVE TO OUTPUT STREAM 14200000 SPACE 3 14220000 * SEMICOLON OR DELTA 14240000 SEMIDELT MVC SEMCNT(2),1(ZINR) SAVE SEMICOLON COUNTER 14260000 OI PROCHD,X'F0' PROC. HEAD SWITCH OFF 0209 14270014 C ZOUR,ZFILE3 COMPARE ZOUT WITH ZFILE(3) 14280000 BH LSEM1 BRANCH IF HIGH 14300000 LSEM2 MVC 1(3,ZOUR),0(ZINR) OPERATOR,SC ARE MOVED TO O-BUFF 14320000 LA ZOUR,3(0,ZOUR) ZOUT IS INCREASED BY 3 14340000 LA ZINR,3(0,ZINR) ZIN IS INCREASED BY 3 14360000 MVI STATUS,X'00' TURN OFF SWITCH OR ARRAY BITS 14380000 B GENTEST BRANCH TO GENTEST 14400000 LSEM1 BAL R15,OUCHA BRANCH TO SUBROUTINE OUCHA 14420000 B LSEM2 BRANCH TO LSEM2 14440000 SPACE 3 14460000 SWITCH OI STATUS,SSWITCH SET ON SWITCH SWITCH 14480000 B OTHOP 14500000 SPACE 3 14520000 ARRAY OI STATUS,SARRAY SET ON ARRAY SWOTCH 14540000 MVC BRCNT(2),ZERO ZEROISE BRACKET COUNTER 14560000 B OTHOP OUTPUT OPERATOR 14580000 SPACE 3 14600000 * PROGRAM END 14620000 OMEGA MVC 1(1,ZOUR),0(ZINR) 14640000 OI HCOMPMOD+2,NOSC SET SEMICOLON COUNTER INACTIVE 14660000 TM HCOMPMOD+2,ONEREC INPUT AT ONCE IN CORE 2846 14668015 BO LOMEGA6 YES 2846 14676015 CHECK SREAD 2846 14684015 LOMEGA6 L WORKR,UT1ADD 2846 14692015 CLOSE ((WORKR)) CLOSE UTILITY 1 FINALY 14700000 CLC ONE(2),ZOUTCOT COMPARE ZOUTCOT WITH 1 14720000 BE LOMEGA1 14740000 LA ZOUR,1(0,ZOUR) SAVE OMEGA FROM OVERLAY 14760000 BAL R15,OUCHA WRITE LAST RECORD 14780000 NI HCOMPMOD+2,MANYREC OUTPUT ON SECONDARY STORAGE 14800000 CHECK SWRITE CHECK LAST OUTPUT RECORD 14820000 SPACE 14840000 LOMEGA3 EQU * 14860000 * WRITE OUT CONSTANT POOL 14880000 L RWP,ZDWP ADDRESS OF FREE BYTE IN C.POOL 14900000 LR WORKR,RWP 14920000 AH WORKR,TXTPUT MORE TXT TO WRITE 14940000 C WORKR,ZTEXTCO 14960000 BE LOMEGA2 14980000 BAL R14,TXTTRAF YES, WRITE REST OF CONST.POOL 15000000 SPACE 15020000 LOMEGA2 EQU * 15040000 TERM2 EQU * 15060000 SR WORKR,WORKR 15080000 IC WORKR,ZFSN 15100000 STH WORKR,FSNMAX 15120000 MVC SUCOUNT(2),SUCNT NUMBER OF SUTAB RECORDS 15140000 MVC LVCOUNT(2),LVCNT NUMBER OF LVTAB RECORDS 15160000 SPACE 15180000 L R1,SULENGTH GET FULL LENGTH OF SUTAB 15200000 A R1,ZSUTAPO 15220000 S R1,ZSUDAD 15240000 ST R1,ZSUTEN LENGTH OF SUTAB 15260000 BZ LOMEGA4 15280000 CLC ZSUTAPO(4),ZSUDAD ANYTHING IN SUTAB BUFFER 15300000 BE LOMEGA5 NO 15320000 SPACE 15340000 BAL WORKR,CHECK CHECK LAST I/O OPERATION ON UT3 15360000 L WORKR,SUSTRT WRITE START ADDRESS 15380000 L WORKX,SUTAB30S LENGTH OF RECORD 15400000 BAL R15,WRITE WRITE 15420000 SPACE 15440000 LOMEGA5 EQU * 15460000 L R1,LVLENGTH GET FULL LENGTH OF LVTAB 15480000 A R1,ZLEVA 15500000 S R1,ZLESTA 15520000 ST R1,ZLEVEN LENGTH OF LVTAB 15540000 BZ LOMEGA4 15560000 CLC ZLEVA(4),ZLESTA ANYTHING IN LVTAB BUFFER 15580000 BE LOMEGA4 NO 15600000 SPACE 15620000 BAL WORKR,CHECK CHECK LAST I/O OPERATION ON UT3 15640000 L WORKR,LVSTRT LVTAB BUFFER START ADDRESS 15660000 L WORKX,LVTAB30S LENGTH OF LVTAB BUFFER 15680000 BAL R15,WRITE WRITE 15700000 SPACE 15720000 LOMEGA4 BAL WORKR,CHECK CHECK LAST I/O OPERATION ON UT3 15740000 L WORKR,UT2ADD 15760000 CLOSE ((WORKR),REREAD),TYPE=T CLOSE UTILITY 2 TEMPORARILY 15780000 SPACE 15800000 * RELEASE MAIN STORAGE 15820000 L R0,TABSIZE 15840000 L R1,ZKOPOOL 15860000 FREEMAIN R,LV=(0),A=(1) 15880000 TERM1 EQU * 15900000 L R1,OLDSPIE 15920000 SPIE MF=(E,(1)) 15940000 XCTL EP=IEX31 TRANSFER TO NEXT PHASE 15960000 SPACE 15980000 LOMEGA1 OI HCOMPMOD+2,ONEREC INDICATE ONLY ONE OUTPUT RECORD 16000000 L R1,SRCE1ADD ADDRESS OF RESIDENT BUFFER 16020000 L R2,ZOBWORK ADDRESS OF OUTPUT BUFFER 16040000 L WORKR,SRCE1S BUFFER LENGTH 16060000 BCTR WORKR,0 16080000 LR WORKX,WORKR 16100000 SRA WORKX,8 GET MULTIPLE OF 256 16120000 LTR WORKX,WORKX MAXIMUM 256 16140000 BZ LOMEGA12 YES 16160000 LOMEGA11 MVC 0(256,R1),0(R2) MOVE BLOCK OF 256 16180000 LA R1,256(0,R1) 16200000 LA R2,256(0,R2) 16220000 BCT WORKX,LOMEGA11 16240000 LOMEGA12 EX WORKR,ONERM MOVE REST OF BUFFER 16260000 B LOMEGA3 16280000 ONERM MVC 0(0,R1),0(R2) LENGTH IN WORKR 16300000 SPACE 3 16320000 * CODE PROCEDURE 16340000 GAMMA C ZOUR,ZFILE9 COMPARE ZOUT WITH ZFILE9 16360000 BH LGAMMA1 BRANCH IF HIGH 16380000 LGAMMA2 MVI 1(ZOUR),X'2E' NEW CODE FOR GAMMA IS SET 16400000 MVC 2(8,ZOUR),1(ZINR) OPT,EXTERN.NAME TO O-BUFF. 16420000 LA ZINR,9(0,ZINR) ZIN IS INCREASE BY 9 16440000 LA ZOUR,9(0,ZOUR) 16460000 B GENTEST BRANCH TO GENETEST 16480000 LGAMMA1 BAL R15,OUCHA 16500000 B LGAMMA2 BRANCH TO LGAMMA2 16520000 SPACE 3 16540000 * END OF INPUT BUFFER 16560000 ZETA EQU * 16580000 BAL R15,ICHA BRANCH TO SUBROUTINE ICHA 16600000 B GENTEST BRANCH TO GENTEST 16620000 SPACE 3 16640000 * OPENING BRACKET 16660000 OPBRACK EQU * 16680000 TM STATUS,SARRAY HANDLING ARRAY DECLARATION 16700000 BO LOPBRA5 YES 16720000 TM HCOMPMOD,SYNTAX COMPILE MODE 16740000 BO OTHOP NO 16760000 L R7,ZITAN ZITEAN IS LOADED INTO R7 16780000 TM 7(R7),X'08' IS IT AN ARRAY IDENTIFIER 16800000 BO LDO3 NO 16820000 TM 7(R7),X'04' 16840000 BZ LDO3 16860000 CLC PFA(4),PFANO PFA IS COMPARED WITH PFANO 16880000 BE LDO3 BRANCH IF EQUAL 16900000 CLI ZLVOV,X'FF' TABLE OVERFLOW 16920000 BE LDO3 YES 16940000 CLC ZARSPO(4),ZARNO COMPARE ZARSPO WITH ZARNO 16960000 BE LOPBRA4 NO SUBSCRIPT NESTING 16980000 BAL SUCRIDX,SUCRIDEL 17000000 L R8,ZARSPO ZARSPO IS SET INTO R8 17020000 C R8,ZARMAX COMPARE ZARSPO WITH ZARMAX 17040000 BE LOPBRA4 BRANCH IF EQUAL 17060000 MVC 10(1,R8),ZPOSIX+1 NUMBER OF COMMAS TO ARIDSTACK 17080000 LA R8,7(0,R8) ADDRESS NEXT ENTRY 17100000 LOPBRA3 ST R8,ZARSPO ZARSPO IS SET TO ZARSTACK 17120000 MVC 0(3,R8),8(R7) ARRAY IDENTIFIER IS STORED 17140000 LA R0,1(0,ZOUR) 17160000 ST R0,ZBRACK ZBRACK IS SET TO ZOUT+1 17180000 S R0,ZOBWORK 17200000 ST R0,ALIGN RELATIVE BUFFER ADDRESS 17220000 MVC 5(2,R8),ALIGNH 17240000 MVC 4(1,R8),ZOUTCOT+1 RECORD COUNTER TO ARIDSTAB 17260000 MVC ZPOSIX(2),ZERO ZPOSIX IS SET TO 0 17280000 MVI ZCLOBRA,X'00' ZCLOBRA IS SET TO X'00' 17300000 B LDO2 PUT OUT OPERATOR 17320000 LOPBRA4 LA R8,ZARSTACK STARTADDRESS OF ARIDSTAB 17340000 B LOPBRA3 BRANCH TO LOPBRA3 17360000 LOPBRA5 LH WORKR,BRCNT INCREASE BRACKET COUNTER 17380000 LA WORKR,1(0,WORKR) 17400000 STH WORKR,BRCNT 17420000 B OTHOP OUTPUT OPERATOR 17440000 SPACE 3 17460000 * COMMA 17480000 COMMA EQU * 17500000 TM HCOMPMOD,SYNTAX COMPILE MODE 17520000 BO OTHOP YES 17540000 CLC ZARSPO(4),ZARNO ZARSPO=ZARNO 17560000 BE LDO3 BRANCH IF EQUAL 17580000 CLC ZPOSIX(2),FIFTEEN ZPOSIX=15 17600000 BE LCOMMA1 BRANCH IF EQUAL 17620000 CLI ZCLOBRA,X'00' IS ZCLOBRA = X'FF' 17640000 BNE LCOMMA2 17660000 L R7,ZBRACK ZBRACK IS SET INTO R7 17680000 LA R7,18(0,R7) 17700000 CR ZOUR,R7 COMPARE ZOUT AND ZBRACK+18 17720000 BH LCOMMA3 17740000 BAL SUBTSTX,SUSCRITE TEST IF OPTIMIZATION POSSIBLE 17760000 LCOMMA4 LH R7,ZPOSIX ZPOSIX IS SET INTO R7 17780000 LA R7,1(0,R7) ZPOSIX IS INCREASED BY 1 17800000 STH R7,ZPOSIX 17820000 LA R7,1(0,ZOUR) 17840000 ST R7,ZBRACK ZBRACK IS SET TO ZOUT+1 17860000 B LDO2 PUT OUT OPERATOR 17880000 LCOMMA1 OI HCOMPMOD,X'80' SWITCH SYNTAX CHECK MODE 17900000 B LDO3 BRANCH TO LDO3 17920000 LCOMMA2 MVI ZCLOBRA,X'00' ZCLOBRA IS SET TO X'00' 17940000 LCOMMA3 BAL SUCRIDX,SUCRIDEL 17960000 B LCOMMA4 BRANCH TO LCOMMA4 17980000 SPACE 3 18000000 * CLOSING BRACKET 18020000 CLOBRACK EQU * 18040000 TM STATUS,SARRAY HANDLING ARRAY DECLARATION 18060000 BO CLOBRA3 18080000 TM HCOMPMOD,SYNTAX COMPILE MODE 18100000 BO OTHOP YES 18120000 CLC ZARSPO(4),ZARNO IS THERE AN ARIDSTAB-ENTRY 18140000 BE LDO3 NO 18160000 CLI ZCLOBRA,X'00' PRECEEDING SUBSCR.OPER. CLOBRA. 18180000 BNE CLOBRA1 YES 18200000 L R7,ZBRACK SUBSCRIPT MORE THAN 18 BYTES 18220000 LA R7,18(0,R7) 18240000 CR ZOUR,R7 18260000 BH CLOBRA1 YES, NO OPTIMIZATION 18280000 BAL SUBTSTX,SUSCRITE TEST IF OPTIMIZABLE 18300000 CLOBRA2 L R7,ZARSPO UPDATE CURRENT ARIDSTAB PTR 18320000 SH R7,SEVEN 18340000 ST R7,ZARSPO 18360000 C R7,ZARNO ARIDSTAB EMPTY 18380000 BE LDO3 YES 18400000 MVC ZPOSIX+1(1),10(R7) RESET SUBSC.POSITION CNTR. 0217 18420015 LA R7,1(0,ZOUR) SET ZBRACK 18440000 ST R7,ZBRACK 18460000 MVI ZCLOBRA,X'FF' LAST SUBSCR. OPER. CLOBRACK 18480000 B LDO3 18500000 CLOBRA1 BAL SUCRIDX,SUCRIDEL NO OPTIMIZATION POSSIBLE 18520000 B CLOBRA2 18540000 CLOBRA3 LH WORKR,BRCNT DECREASE BRACKET COUNTER 18560000 BCTR WORKR,0 18580000 STH WORKR,BRCNT 18600000 B OTHOP OUTPUT OPERATOR 18620000 EJECT 18640000 IEX30001 CSECT 18660000 * ***** LETTER ***** 18680000 SPACE 18700000 * SCAN FOR END OF IDENTIFIER. BRANCH TO IDENT TO SEARCH 18720000 * FOR THE IDENTIFIER IN ITAB. REPLACE IDENTIFIER BY INTER- 18740000 * NAL NAME. 18760000 SPACE 18780000 * INITILIZED REG ZIDSTAR = IDENTIFIER START ADDRESS 18800000 * SUBROUTINE LINK IDENTX 18820000 SPACE 18840000 LETTER5 BAL R15,ITABMOP READ ITAB RECORD 18860000 B LETTERP 18880000 LETTER NOP LETTER5 BRANCH TO READ ITAB RECORD 18900000 LETTERB EQU LETTER+1 18920000 LETTERP LA RTO,ZIDEX 18940000 LA R0,ZIDEX+6 18960000 LETTER4 LR RFI,ZINR 18980000 SR R2,R2 19000000 SR R1,R1 19020000 LETTER6 TRT 0(256,ZINR),IDENTI 19040000 BZ LETTER0 STILL SAME IDENTIFIER 19060000 LR ZINR,1 UPDATE ZINR 19080000 B *(R2) 19100000 B ZETALET 19120000 B RHO 19140000 B ERROR1 19160000 * END OF IDENTIFIER IS FOUND 19180000 B IDENT ITAB SEARCH 19200000 LETTER1 ST ZITANR,ZITAN SAVE POINTER TO LAST IDENTIFIER 19220000 C ZOUR,ZFILE5 SPACE IN OUTPUTBUFFER 19240000 BH LETTER2 NO SPACE 19260000 LETTER3 MVC 1(5,ZOUR),6(ZITANR) MOVE INTERNAL NAME TO OUTPUTBUF 19280000 LA ZOUR,5(0,ZOUR) 19300000 B GENTEST 19320000 LETTER2 BAL R15,OUCHA 19340000 B LETTER3 19360000 LETTER0 LA ZINR,256(0,ZINR) UPDATE INPUT PTR 19380000 B LETTER6 19400000 SPACE 3 19420000 * END OF INPUT BUFFER IN THE MIDLE OF AN IDENTIFIER 19440000 ZETALET BAL MOVEX,MOVE 19460000 BAL R15,ICHA 19480000 B LETTER4 19500000 SPACE 3 19520000 * LETTER STRING USED AS PARAMETER DELIMITER. REPLACE 19540000 * STRING BY COMMA. 19560000 RHO CLI 0(ZOUR),X'26' RIGHT PARENTHES 19580000 BNE GENTEST1 NO 19600000 MVI 0(ZOUR),X'25' REPLACE PARENTHES BY COMMA 19620000 B GENTEST1 19640000 SPACE 3 19660000 * INVALID CHARACTER IN IDENTIFIER 19680000 ERROR1 EQU * 19700000 BAL MOVEX,MOVE 19720000 MVC ZERRONU(2),INVOP 19740000 B INCOROP 19760000 SPACE 3 19780000 * ***** IDENT ***** 19800000 SPACE 19820000 * A SEARCH THRU ITAB FOR THE IDENTIFIER WITH THE STARTADD- 19840000 * RESS IN ZIDSTAR IS DONE. IF FOUND BRANCH TO ROUTINE FOL1 19860000 * FOR TYPECHECK, IF NOT REPLACE IDENTIFIER WITH ALL PUR- 19880000 * POSE IDENTIFIER. 19900000 SPACE 19920000 * RECIEVED REG ZIDSTAR = ADDRESS OF IDENTIFIER START *D* 19940000 * INITILIZED REG ZITANR 19960000 SPACE 19980000 FOLIR EQU WORKR 20000000 ZITANR EQU R7 20020000 IDENT BAL MOVEX,MOVE MOVE IDENTIFIER 20040000 MVC 0(5,RTO),ZERO FILL UP WITH ZERO 20060000 * START ITAB SEARCH 20080000 L ZITANR,ZCURITEN ADDRESS OF LAST ITAB-ENTRY 20100000 L R1,ZIBSTAO ITAB START ADDRESS 20120000 LH R0,ELEVEN 20140000 LCR R0,R0 MINUS ELEVEN 20160000 IDENT2 LA FOLIR,IDENT4 20180000 IDENT3 CLC 0(6,ZITANR),ZIDEX IDENTIFIER SEARCH 20200000 BCR 8,FOLIR FOUND 20220000 IDENT6 BXH ZITANR,R0,IDENT3 PROCEED SEARCH, IF NOT ITAB0209 20240014 SPACE 20260000 MVC ZBEGERR(4),OPSTART 20280000 ST RTO,ZENDERR 20300000 MVC ZERRONU(2),UNDEFOP 20320000 BAL MOVERROX,MOVERRO 20340000 OI HCOMPMOD,X'80' SWITCH SYNTAX CHECK MODE 20360000 LA ZITANR,ZALLPU ALL PURPOSE IDENTIFIER 20380000 B LETTER1 20400000 SPACE 20420000 IDENT4 BC 15,IDENT5 BRANCH IF NOT PROC.HEAD 0209 20425014 PROCHD EQU IDENT4+1 PROC.HEAD SWITCH 0209 20430014 TM 6(ZITANR),X'02' PROC.OR FORMAL PARAMETER 0209 20435014 BZ IDENT6 NO,CONTINUE SEARCH 0209 20440014 CLC 8(1,ZITANR),CURPBN DECLARED IN LAST BLOCK 0209 20445014 BNE IDENT6 NO,CONTINUE SEARCH 0209 20450014 IDENT5 TM STATUS,SARRAY HANDLING ARRAY DECLARATION 0209 20455014 BZ FOLI NO 20460000 CLC BRCNT(2),ZERO IDENTIFIER IN ARRAY LIST 20480000 BE FOLI NO, ARRAY IDENTIFIER 20500000 CLC 8(1,ZITANR),CURPBN DECLARED IN LAST BLOCK 20520000 BL FOLI NO A32962 20530000 MVC ZSTO(2),6(ZITANR) IDENT CHARACTERISTIC A32962 20540000 NC ZSTO(2),ZSTO1 A32962 20550000 CLC ZSTO(2),ZSTO2 FUNCTION PROCEDURE? A32962 20560000 BE IDENT7 YES A32962 20570000 CLI ZSTO,X'02' FORMAL PARAM OR PROC? A32962 20580000 BE FOLI YES A32962 20590000 IDENT7 MVC ZBEGERR(4),OPSTART GIVE WARNING MESSAGE A32962 20600000 ST RTO,ZENDERR 20660000 MVC ZERRONU(2),ARRAYERR 20680000 BAL MOVERROX,MOVERRO 20700000 AR ZITANR,R0 PROCEED SEARCH FOR IDENTIFIER 20720000 B IDENT2 20740000 SPACE 3 20760000 * ***** FOLI ***** 20780000 SPACE 20800000 * CHECK TYPE OF IDENTIFIER 20820000 FOLI IC WORKR,6(0,ZITANR) ISOLATE SPECIAL USE BITS 20840000 N WORKR,SPECUSE X'6' 20860000 AR WORKR,WORKR SPECIALUSE BITS MULTIPLIED BY 4 20880000 B *+4(WORKR) 20900000 B NOCRI NON-CRITICAL IDENTIFIER 20920000 B PROFU PROCEDURE OR FORMAL PARAMETER 20940000 B SWILA LABEL OR SWITCH 20960000 B CRITI CRITICAL IDENTIFIER 20980000 NOCRI EQU * 21000000 TM HCOMPMOD,SYNTAX COMPILE MODE 21020000 BO LETTER1 21040000 CLI ZFORTEST,X'00' APPEARS IDENT. BETWEEN FOR - DO 21060000 BNE NOCRI1 YES 21080000 * SHOULD ENTRY TO LVTAB BE DONE 21100000 CLC PFA(4),PFANO FOR-STATMENT 21120000 BE LETTER1 NO, NO LVTAB-ENTRY 21140000 CLI 0(ZINR),X'16' IDENTIFIER FOLLOWED BY ASSIGN. 21160000 BC 7,LETTER1 NO, NO LVTEB-ENTRY 21180000 TM 7(ZITANR),X'02' INTEGER 21200000 BO LETTER1 NO, NO LVTAB-ENTRY 21220000 BAL LETRAFX,LETRAF MAKE ENTRY IN LVTAB 21240000 B LETTER1 RETURN 21260000 NOCRI1 BAL CRIMAX,CRIMA MAKE CRIDTAB ENTRY 21280000 B LETTER1 21300000 SPACE 3 21320000 * ***** PROFU ***** 21340000 SPACE 21360000 * BECAUSE OF POSSIBLE SIDE EFFECTS OF A PROCEDURE, OPTIMI- 21380000 * ZATION OF SUBSCRIPTS AND FOR-STATEMENTS IS INHIBITED 21400000 SPACE 21420000 * SUBROUTINE LINK DELCRIVX 21440000 SPACE 21460000 PROFU EQU * 21480000 TM HCOMPMOD,SYNTAX SYNTAX CHECK MODE 21500000 BO LETTER1 YES 21520000 MVC ZARSPO(4),ZARNO SKIP ARIDSTAB 21540000 CLI ZFORTEST,X'C0' CONTROLLED VARIABLE 21560000 BNE PROFU1 NO 21580000 L WORKR,ZFSPTR YES, CLASSIFIE NORMAL 21600000 OI 0(WORKR),NORMAL 21620000 PROFU1 EQU * 21640000 MVI ZFORTEST,X'00' TURN OFF FOR-SWITCH 21660000 CLC PFA(4),PFANO CRIDTAB EMPTY 21680000 BE LETTER1 YES, RETURN 21700000 BAL DELCRIVX,DELCRIV DELETE ALL CRIDTAB-ENTRIES 21720000 B LETTER1 RETURN 21740000 SPACE 2 21760000 * ***** SWILA ***** 21780000 SPACE 21800000 * IN CASE OF SWITCH OF LABEL DECLARATION NO ACTION IS 21820000 * TAKEN. IF USED IN A GO-TO-STATEMENT A TEST IS DONE IF 21840000 * THE ALFOL-RULES IS FOLLOWED. IF NOT GIVE MESSAGE 21860000 SPACE 21880000 * RECIEVED REG ZITANR, ZIDSTAR 21900000 * WORK REG ZITHEADR, SIGNEMBR, ZFOSTAR, ZIGNDECR 21920000 SPACE 21940000 ZITHEADR EQU R1 21960000 ZFOSTAR EQU R1 21980000 ZIGNEMBR EQU R2 22000000 ZIGNDECR EQU R9 22020000 SPACE 22040000 SWILA LR ZITHEADR,ZITANR START SEARCH FOR HEADING ENTRY 22060000 SWILA1 SH ZITHEADR,ELEVEN 22080000 CLI 5(ZITHEADR),X'2B' HEADING TEST 22100000 BNE SWILA1 NO HEADING 22120000 MVC ALIGNH(2),8(ZITHEADR) 22140000 L ZIGNDECR,ALIGN 22160000 LH ZIGNEMBR,ZIGN ACTUELL IGN 22180000 LA ZFOSTAR,ZFOSTA-1 ADDRESS OF BYTE PRECEED. FSTAB 22200000 SWILA2 CR ZIGNEMBR,ZIGNDECR COMPORE DECLARAD AND CUR. IGN 22220000 BH SWILA3 CHECK EMBRACING IGN TO CUR. IGN 22240000 BE LETTER1 22260000 TM STATUS,SSWITCH IN SWITCH DECLARATION 22280000 BZ SWILA21 NO, SERIOUS ERROR 22300000 MVC ZBEGERR(4),OPSTART YES, GEVE WARNING MESSAGE 22320000 ST RTO,ZENDERR 22340000 MVC ZERRONU(2),SWITCHER 22360000 BAL MOVERROX,MOVERRO 22380000 B LETTER1 22400000 SWILA21 EQU * 22420000 MVC ZERRONU(2),GOTOFOR 22440000 B INCOROP 22460000 SWILA3 LR WORKR,ZIGNEMBR COMPUTE ADDRESS OF IGN-TAB-ENTR 22480000 AR WORKR,ZIGNEMBR 22500000 AR WORKR,ZIGNEMBR 3+ZIGNEMB 22520000 LA WORKR,GPTAB(WORKR) GPTAB+3*ZIGNEMB 22540000 CLI 2(WORKR),X'00' TEST IF FORGROUP 22560000 BE SWILA4 NO 22580000 MVC *+9(1),2(WORKR) ADDRESS ACTUELL ENTRY IN FSTAB 22600000 OI 0(ZFOSTAR),X'20' SET BIT INDICAT BRANCH OUTOF FS 22620000 SWILA4 MVC ALIGNH(2),0(WORKR) 22640000 L ZIGNEMBR,ALIGN LOAD EMBRACING IGN 22660000 B SWILA2 22680000 SPACE 3 22700000 * ***** CRITI ***** 22720000 SPACE 22740000 * ROUTINE ENTRED WHEN A CRITICAL IDENTIFIER IS FOUND IN 22760000 * ITAB. IF THE IDENTIFIER APPEARS BETWEEN FOR AND DO A 22780000 * NEW CHAINED CRIDTAB-ENTRY IS MADE. OTHERWISE ONLY THE 22800000 * FSTAB-ENTRY IS TREATED. 22820000 SPACE 22840000 * WORK REG ZMR,PFAR 22860000 SPACE 22880000 ZMR EQU R1 22900000 CRITI CLI ZFORTEST,X'00' CRITICAL IDENTIFIER IN FOR-LIST 22920000 BNE CRITIF YES 22940000 SPACE 22960000 * IDENTIFIER NOT FOR-LIST-ELEMENT 22980000 CLC ZARSPO(4),ZARNO CURRENTLY HANDLING SUBSCR.EXPR. 23000000 BC 7,LETTER1 YES 23020000 L ZMR,PFA POINTER TO LAST CRIDTAB-ENTRY 23040000 CRITI1 CLC 1(3,ZMR),8(ZITANR) SCAN CRIDTAB FOR LAST ENTRY 23060000 BE CRITI2 FOUND 23080000 SH ZMR,NINE 23100000 B CRITI1 23120000 SPACE 23140000 CRITI2 CLI 0(ZINR),X'16' IDENTIFIER FOLLOWED BY ASSIGNM 23160000 BE CRITI3 YES 23180000 TM 4(ZMR),X'80' CONTROLLED VARIABEL 23200000 BZ LETTER1 NO, RETURN 23220000 SR WORKR,WORKR ADDRESS FSTAB-ENTRY 23240000 IC WORKR,0(0,ZMR) 23260000 LA WORKR,ZFOSTA(WORKR) 23280000 OI 0(WORKR),X'80' ELEMENTARY LOOP 23300000 B LETTER1 RETURN 23320000 SPACE 23340000 * IDENTIFIER FOLLOWED BY ASSIGNMENT 23360000 CRITI3 SR WORKR,WORKR GET ADDRESS OF FSTAB-ENTRY 23380000 IC WORKR,0(0,ZMR) 23400000 LA WORKR,ZFOSTA(WORKR) 23420000 TM 4(ZMR),X'80' CONTROLLED VARIABEL 23440000 BO CRITI4 YES 23460000 OI 0(WORKR),NORMAL NORMAL LOOP 23480000 TM 4(ZMR),X'40' MORE CHAINED ENTRIES 23500000 BZ LETTER1 NO, RETURN 23520000 MVC ALIGNH(2),5(ZMR) GET ADDRESS OF NEXT ENTRY 23540000 L ZMR,ALIGN 23560000 A ZMR,ZFOCRI 23580000 B CRITI3 HANDLE NEXT ENTRY 23600000 CRITI4 OI 0(WORKR),X'40' INDICATE ASSIGN. TO CTR VAR 23620000 B LETTER1 23640000 SPACE 23660000 * TREATMENT OF CRIT. ID. IN FOR-LIST 23680000 CRITIF BAL CRIMAX,CRIMA MAKE CRIDTAB-ENTRY 23700000 L PFAR,PFA PTR TO LAST CRIDTAB-ENTRY 23720000 LR ZMR,PFAR START SCAN FOR PREVIOUS ENTRY 23740000 CRITIF1 SH ZMR,NINE 23760000 C ZMR,PFANO IS THARE A PREVIOUS ENTRY 23780000 BC 12,LETTER1 NO, DELETED AT CRIDTAB-OVERFLOW 23800000 CLC 1(3,ZMR),1(PFAR) PREVIOUS ENTRY 23820000 BNE CRITIF1 NO 23840000 SPACE 23860000 * PREVIOUS ENTRY IN CRIDTAB FOUND 23880000 BAL PUTCHX,PUTCHAIN CHAIN NEW ENTRY TO PREVIOUS 23900000 TM 4(PFAR),X'80' NEW ENTRY CONTROLLED VARIABEL 23920000 BZ CRITIN NO 23940000 SPACE 23960000 * TREATMENT OF CONTROLLED VARIABEL 23980000 CRITIC SR WORKR,WORKR 24000000 IC WORKR,0(0,ZMR) FSN OF CHAINED CRIDTAB-ENTRY 24020000 LA WORKR,ZFOSTA(WORKR) ADDRESS OF CHAINED FSTAB-ENTRY 24040000 TM 4(ZMR),X'80' CHAINED ENTRY CONTROLLED 24060000 BO CRITIC1 YES 24080000 OI 0(WORKR),NORMAL INDICATE NORMAL LOOP 24100000 TM 4(ZMR),X'40' MORE CHAINED ENTRIES 24120000 BZ LETTER1 NO, RETURN 24140000 MVC ALIGNH(2),5(ZMR) GET ADDRESS OF NEXT CHAINED ENTRY 24160000 L ZMR,ALIGN 24180000 A ZMR,ZFOCRI 24200000 B CRITIC 24220000 SPACE 24240000 CRITIC1 OI 0(WORKR),X'40' BIT FOR ASSIGN. TO CONTR. VAR. 24260000 B LETTER1 24280000 SPACE 24300000 * TREATMENT OF NON-CONTROLLED VARIABEL 24320000 CRITIN TM 4(ZMR),X'80' CHAINED ENTRY CONTROLLED 24340000 BO CRITIN1 YES 24360000 TM 4(ZMR),X'40' MORE CHAINED ENTRIES 24380000 BZ LETTER1 NO 24400000 MVC ALIGNH(2),5(ZMR) GET ADDRESS OF CHAINED ENTRY 24420000 L ZMR,ALIGN 24440000 A ZMR,ZFOCRI 24460000 B CRITIN 24480000 SPACE 24500000 CRITIN1 SR WORKR,WORKR GET ADDRESS OF CHAINED FSTAB-EN 24520000 IC WORKR,0(0,ZMR) 24540000 LA WORKR,ZFOSTA(WORKR) 24560000 CLC 0(1,ZMR),ZFSN CHAINED ENTRY PART OF ACTIV FOR 24580000 BE CRITIN2 YES 24600000 CLC ZARSPO(4),ZARNO CURRENTLY HANDLING A SUBSCRIPT 24620000 BC 7,LETTER1 YES, RETURN 24640000 OI 0(WORKR),X'80' SET ELEMENTARY LOOP 24660000 B LETTER1 24680000 CRITIN2 OI 0(WORKR),NORMAL INDICATE NORMAL LOOP 24700000 B LETTER1 24720000 SPACE 3 24740000 * ***** PUTCHAIN ***** 24760000 SPACE 24780000 * ROUTINE TO CHAIN NEW CRIDTAB-ENTRY TO PREVIOUS 24800000 SPACE 24820000 * RETURN REG PUTCHX 24840000 * RECIEVED REG PFAR, ZMR 24860000 SPACE 24880000 PUTCHX EQU R15 24900000 PUTCHAIN OI 4(PFAR),X'40' BIT FOR PREVIOUS CRITICAL IDENT 24920000 OI 4(ZMR),X'20' BIT FOR SUBSEQUENT CRIT. IDENT 24940000 L WORKX,ZFOCRI CRIDTAB START ADDRESS 24960000 LR WORKR,ZMR GET BACKWARD CHAIN 24980000 SR WORKR,WORKX 25000000 ST WORKR,ALIGN 25020000 MVC 5(2,PFAR),ALIGNH 25040000 LR WORKR,PFAR GET FORWARD CHAIN 25060000 SR WORKR,WORKX 25080000 ST WORKR,ALIGN 25100000 MVC 7(2,ZMR),ALIGNH 25120000 BR PUTCHX RETURN 25140000 SPACE 3 25160000 * ***** CRIMA ***** 25180000 SPACE 25200000 * SUBROUTINE TO MAKE A NEW CRIDTAB-ENTRY. IN CASE OF 25220000 * CRIDTAB OVERFLOW THE ROUTINE CRIFLOW IS ENTRED TO 25240000 * DELETE FROM CRIDTAB ALL ENTRIES BELONG TO THE MOST 25260000 * EMBRACING FOR-STATEMENT. CRIFODEL IS ENTERED IF AN 25280000 * ARRAY ELEMENT IS HANDELED. 25300000 SPACE 25320000 * RETURN REG CRIMAX 25340000 * RECIEVED REG ZITANR POINTER TO ACTUELL ITAB ENTRY 25360000 * WORK REG PFAR 25380000 * SUBROUTINE CRIFLOW, LETRAF,CRIFODEL, SUCRIDEL 25400000 SPACE 25420000 PFAR EQU R8 25440000 CRIMAX EQU R14 25460000 SPACE 25480000 CRIMA TM 7(ZITANR),X'04' ARRAY 25500000 BO CRIMA1 YES, NO OPTIMIZATION POSSIBLE 25520000 L PFAR,PFA CURRENT CRIDTAB PTR 25540000 TM ZFORTEST,X'C0' CONTROLLED VARIABLE 25560000 BO CRIMAC YES 25580000 SPACE 25600000 * TREATMENT OF 'NOT CONTROLLED' VARIAB 25620000 C PFAR,PFAMAX CRIDTAB OVERFLOW 25640000 BE CRIMAN1 YES 25660000 CRIMAN2 LA PFAR,9(0,PFAR) UPDATE CURRENT PTR 25680000 MVI 4(PFAR),X'00' FLAG-BYTE SHOWS NO CTR.VARIABEL 25700000 TM 7(ZITANR),X'02' INTEGER 25720000 BZ CRIMA2 YES 25740000 L WORKR,ZFSPTR ADDRESS FSTAB ENTRY 25760000 OI 0(WORKR),NOCOUNT CLASSIFY AS NOT COUNTING LOOP 25780000 SPACE 25800000 CRIMA2 MVC 1(3,PFAR),8(ZITANR) MOVE ADDRESS PART TO CRIDTAB 25820000 MVC 0(1,PFAR),ZFSN MOVE FSN TO CRIDTAB 25840000 LR WORKR,ZITANR GET RELATIVE ADDRESS IN ITAB 25860000 S WORKR,ZIBSTAO 25880000 ST WORKR,ALIGN ITAB RELATIVE ADDRESS 25900000 MVC 5(2,PFAR),ALIGNH 25920000 OI 6(ZITANR),X'06' TURN ON SPECIAL USE BITS 25940000 ST PFAR,PFA SAVE CURRENT PTR 25960000 BR CRIMAX RETURN 25980000 SPACE 26000000 CRIMAN1 EQU * 26020000 BAL CRIFLOWX,CRIFLOW DELETE MOST EMBRACING FOR-STAT. 26040000 C PFAR,PFANO ALL CRIDTAB DELETED 26060000 BNE CRIMAN2 NO 26080000 MVI ZFORTEST,X'00' NO MOR CRIDTABENTRIES TO BE DON 26100000 BR CRIMAX 26120000 SPACE 26140000 CRIMAC TM 7(ZITANR),X'02' INTEGER 26160000 BZ CRIMAC1 YES 26180000 L WORKR,ZFSPTR CURRENT FSTAB PTR 26200000 OI 0(WORKR),X'80' SET BIT FOR ELEMENTARY LOOP 26220000 CRIMAC4 C PFAR,PFAMAX OVERFLOW 26240000 BE CRIMAC2 YES 26260000 CRIMAC3 LA PFAR,9(0,PFAR) UPDATE CURRENT PTR 26280000 MVI ZFORTEST,X'80' INDICATE CONTR. VAR. TREATED 26300000 MVI 4(PFAR),X'80' SET BIT FOR CONTROLLED VAR. 26320000 B CRIMA2 26340000 SPACE 26360000 CRIMAC1 C PFAR,PFANO NESTED FOR STATEMENT 26380000 BE CRIMAC3 NO 26400000 BAL LETRAFX,LETRAF MAKE LVTAB ENTRY 26420000 B CRIMAC4 26440000 CRIMAC2 BAL CRIFLOWX,CRIFLOW CRIDTAB OVERFLOW 26460000 B CRIMAC3 26480000 CRIMA1 L WORKR,ZFSPTR CURRENT FSTAB PTR 26500000 OI 0(WORKR),NORMAL NORMAL LOOP 26520000 MVI ZFORTEST,X'00' NO MORE CRIDTAB-ENTRIES 26540000 BR CRIMAX RETURN 26580000 SPACE 3 26600000 * ***** CRIFLOW ***** 26620000 SPACE 26640000 * THE SUBROUTINE IS ENTERED AT CRIDTAB OVERFLOW TO DELETE 26660000 * ALL CRIDTAB-ENTRIES BELONGING TO THE MOST EMBRACING 26680000 * FOR-STATEMENT 26700000 SPACE 26720000 * RETURN REG CRIFLOWX 26740000 * WORK REG ZMAR, ZMIR, ZMATOR 26760000 SPACE 26780000 ZMIR EQU R1 26800000 ZMATOR EQU R9 26820000 CRIFLOWX EQU R15 26840000 SPACE 26860000 CRIFLOW L ZMAR,ZFOCRI CRIDTAB START ADDRESS 26880000 CLC 0(1,ZMAR),0(PFAR) ALL ENTRIES FROM SAME FOR-ST. 26900000 BE DELCRIV YES, DELETE WHOLE CRIDTAB 26920000 MVC FSNEMBR(1),0(ZMAR) SAVE MOST EMBRACING FSN 26940000 CRIFLOW1 CLC 0(1,ZMAR),FSNEMBR ENTRY OF MOST EMBRACING FOR-ST. 26960000 BNE CRIFLOW2 NO 26980000 TM 4(ZMAR),X'20' SUBSEQUENT CHAINED ENTRY 27000000 BO CRIFLOW3 YES 27020000 SPACE 27040000 MVC ALIGNH(2),5(ZMAR) ADDRESS ITAB-ENTRY 27060000 L WORKR,ALIGN 27080000 A WORKR,ZIBSTAO 27100000 NI 6(WORKR),X'F9' SET SPECIAL USE BITS TO 00 27120000 CRIFLOW4 LA ZMAR,9(0,ZMAR) ADDRESS NEXT CRIDTAB ENTRY 27140000 B CRIFLOW1 27160000 SPACE 27180000 CRIFLOW3 MVC ALIGNH(2),7(ZMAR) ADDRESS CHAINED ENTRY 27200000 L WORKR,ALIGN 27220000 A WORKR,ZFOCRI 27240000 NI 4(WORKR),X'B0' TURN OFF BIT FOR PRECEED. ENTRY 27260000 MVC 5(2,WORKR),5(ZMAR) INSERT RELATIVE ITAB-ADDRESS 27280000 B CRIFLOW4 27300000 SPACE 27320000 CRIFLOW2 SR WORKR,WORKR ADDRESS FSTAB-ENTRY OF DEL. FOR 27340000 IC WORKR,FSNEMBR 27360000 LA WORKR,ZFOSTA(WORKR) 27380000 OI 0(WORKR),NORMAL NORMAL LOOP 27400000 L ZMATOR,ZFOCRI CRIDTAB START ADDRESS 27420000 LR ZMIR,ZMAR 27440000 SR ZMIR,ZMATOR GET LENGTH OF DELETED PART 27460000 SPACE 27480000 CRIFLOW5 TM 4(ZMAR),X'40' PRECEEDING CRIDTAB-ENTRY 27500000 BZ CRIFLOW6 NO 27520000 MVC ALIGNH(2),5(ZMAR) DECREASE CHAIN-ADDRESS 27540000 L WORKR,ALIGN 27560000 SR WORKR,ZMIR 27580000 ST WORKR,ALIGN 27600000 MVC 5(2,ZMAR),ALIGNH 27620000 CRIFLOW6 TM 4(ZMAR),X'20' SUBSEQUENT CRITAB-ENTRY 27640000 BZ CRIFLOW7 27660000 MVC ALIGNH(2),7(ZMAR) DECREASE CHAIN-ADDRESS 27680000 L WORKR,ALIGN 27700000 SR WORKR,ZMIR 27720000 ST WORKR,ALIGN 27740000 MVC 7(2,ZMAR),ALIGNH 27760000 CRIFLOW7 MVC 0(9,ZMATOR),0(ZMAR) MOVE ENTRY DOWN IN CRIDTAB 27780000 CR ZMAR,PFAR LAST ENTRY 27800000 BE CRIFLOW8 YES 27820000 LA ZMAR,9(0,ZMAR) ADDRESS NEXT ENTRY 27840000 LA ZMATOR,9(0,ZMATOR) 27860000 B CRIFLOW5 27880000 SPACE 27900000 CRIFLOW8 SR PFAR,ZMIR GET ADDRESS OF LAST CRIDTAB-ENT 27920000 BR CRIFLOWX 27940000 SPACE 3 27960000 * ***** DELCRIV ***** 27980000 SPACE 28000000 * ROUTINE TO DELETE ALL ENTRIES IN CRIDTAB AND TURN OFF 28020000 * THE SPECIAL USE BITS OF CORRESPONDING ITAB ENTRY. ALL 28040000 * FOR-STATEMENTS WITH CRIDTAB-ENTRIES WILL BE CLASSIFIED 28060000 * NORMAL 28080000 SPACE 28100000 * RETURN REG DELCRIVX 28120000 * INITILIZED REG PFAR 28140000 SPACE 28160000 DELCRIVX EQU CRIFLOWX 28180000 SPACE 28200000 DELCRIV L WORKR,ZFOCRI CRIDTAB START ADDRESS 28220000 DELCRIV1 SR WORKX,WORKX ADDRESS FSTAB-ENTRY 28240000 IC WORKX,0(0,WORKR) 28260000 LA WORKX,ZFOSTA(WORKX) 28280000 OI 0(WORKX),NORMAL CLASSIFIE NORMAL 28300000 TM 4(WORKR),X'40' IDENT. CRIT.IN EMBR. FOR-STAT. 28320000 BO DELCRIV2 YES, ITAB-ENTRY ALREADY NON-CRI 28340000 MVC ALIGNH(2),5(WORKR) ADDRESS ITAB ENTRY 28360000 L WORKX,ALIGN 28380000 A WORKX,ZIBSTAO 28400000 NI 6(WORKX),X'F9' CLEAR SPEC. USE BITS 28420000 DELCRIV2 C WORKR,PFA LAST CRIDTAB-ENTRY 28440000 BE DELCRIV3 YES 28460000 LA WORKR,9(0,WORKR) ADDRESS NEXT CRIDTAB-ENTRY 28480000 B DELCRIV1 28500000 DELCRIV3 L PFAR,PFANO 28520000 ST PFAR,PFA 28540000 BR DELCRIVX 28560000 SPACE 3 28580000 * ***** CRIFODEL ***** 28600000 SPACE 28620000 * ROUTINE TO DELETE THE CRIDTAB ENTRIES OF THE LAST FOR- 28640000 * STATEMENT 28660000 SPACE 28680000 * RETURN REG R15 28700000 * WORK REG PFAR 28720000 SPACE 28740000 CRIFODEL L PFAR,PFA POINTER TO LAST CRIDTAB-ENTRY 28760000 MVC CRIFODS+1(1),0(PFAR) INSERT FOR STATEMENT NUMBER 28780000 CRIFOD1 C PFAR,PFANO CRIDTAB EMPTY 28800000 BE CRIFOD4 YES, RETURN 28820000 CRIFODS CLI 0(PFAR),X'00' NEW FORSTATEMENT, OLD FSN INSER 28840000 BNE CRIFOD4 YES, RETURN 28860000 TM 4(PFAR),X'40' IDENTIFIER USED IN EMBR. FOR-ST 28880000 BO CRIFOD2 YES 28900000 SPACE 28920000 MVC ALIGNH(2),5(PFAR) CLEAR SPECIAL USE BITS IN CRIDTAB 28940000 L WORKR,ALIGN 28960000 A WORKR,ZIBSTAO ABSOLUTE ITAB ADDRESS 28980000 NI 6(WORKR),X'F9' CLEAR SPECIAL USE BITS IN ITAB 29000000 CRIFOD3 SH PFAR,NINE POINT TO PRECEEDING ENTRY 29020000 B CRIFOD1 29040000 SPACE 29060000 CRIFOD2 L WORKR,ZFOCRI TURN OFF BIT FOR SUBSEQUENT ENTRY 29080000 MVC ALIGNH(2),5(PFAR) ADDRESS OF PREVIOUS CRIDTAB-ENT 29100000 A WORKR,ALIGN 29120000 NI 4(WORKR),X'CF' TURN OFF BIT FOR SUBSEQ. ENTRY 29140000 B CRIFOD3 GET NEXT ENTRY 29160000 SPACE 29180000 CRIFOD4 ST PFAR,PFA 29200000 BR R15 29220000 SPACE 3 29240000 * ***** SUCRIDEL ***** 29260000 * THE SUBROUTINE IS ENTERED WHEN UNOPTIMIZABLE SUB- 29280000 * SCRIPT EXPRESSION IS FOUND. A SCAN BETWEEN THE TWO LAST 29300000 * SUBSCRIPT OPERATORS IS DONE IN THE OUTPUT BUFFER. IF A 29320000 * CONTROLLED CRITICAL IDENTIFIER IS FOUND, CORRESPONDING 29340000 * ENTRY IN FSTAB IS MADE ELEMENTARY. OTHERWISE NO ACTION. 29360000 SPACE 29380000 * RETURN REG SUCRIDX 29400000 * WORK REG ZSUPOR, ZLESUR, ZMSR 29420000 SPACE 29440000 ZSUPOR EQU R1 29460000 ZLESUR EQU R2 29480000 ZMSR EQU R14 29500000 SUCRIDX EQU R15 29520000 SUCRIDEL CLC PFA(4),PFANO CRIDTAB EMPTY 29540000 BCR 8,SUCRIDX YES, RETURN 29560000 LA ZLESUR,1(0,ZOUR) ADDRESS OF LAST SUBSCR. OPERAND 29580000 L ZSUPOR,ZBRACK ADDRESS OF FIRST SUBSCR.OPERAND 29600000 SPACE 29620000 SUCRID1 LA ZSUPOR,1(0,ZSUPOR) CHECK NEXT BYTE 29640000 SUCRID2 CR ZSUPOR,ZLESUR END OF SCAN 29660000 BCR 10,SUCRIDX YES, RETURN 29680000 TM 0(ZSUPOR),X'80' IS AN OPERAND FOUND 29700000 BZ SUCRID1 NO 29720000 TM 0(ZSUPOR),X'06' CRITICAL IDENTIFIER 29740000 BO SUCRID4 YES 29760000 SUCRID3 LA ZSUPOR,5(0,ZSUPOR) ADDRESS NEXT ELEMENT 29780000 B SUCRID2 29800000 SPACE 29820000 * TREATMENT OF CRITICAL IDENTIFIERS 29840000 SUCRID4 L ZMSR,PFA ADDRESS OF LAST CRIDTAB ENTRY 29860000 LA ZMSR,9(0,ZMSR) 29880000 SUCRID5 SH ZMSR,NINE FIND IDENTIFIER IN CRIDTAB 29900000 CLC 1(3,ZMSR),2(ZSUPOR) IDENTIFIER FOUND 29920000 BNE SUCRID5 NO 29940000 SPACE 29960000 SUCRID6 TM 4(ZMSR),X'80' CONTROLLED VARIABEL 29980000 BZ SUCRID7 NO 30000000 LA WORKR,ZFOSTA ADDRESS OF FSTAB 30020000 MVC *+9(1),0(ZMSR) DISPLACEMENT EQVALS FOR-NUMBER 30040000 OI 0(WORKR),X'80' ELEMENTARY LOUP 30060000 B SUCRID3 30080000 SPACE 30100000 * FIND CHAINED CONTROLLED VARIABEL 30120000 SUCRID7 TM 4(ZMSR),X'40' ANY CHAINING 30140000 BZ SUCRID3 NO 30160000 MVC ALIGNH(2),5(ZMSR) CRIDTAB CHAIN 30180000 L ZMSR,ALIGN 30200000 A ZMSR,ZFOCRI ADDRESS CHAINED ENTRY 30220000 B SUCRID6 30240000 SPACE 3 30260000 * ***** LETRAF ***** 30280000 SPACE 30300000 * MAKE ENTRIES IN LVTAB CORRESPONDING TO ALL SUBSCRIPTABLE 30320000 * NESTED FOR-STATEMENTS 30340000 SPACE 30360000 * RETURN REG LETRAFX 30380000 * RECIEVED REG ZITANR 30400000 * WORK REG ZMER, ZMAR, ZLEVAR 30420000 SPACE 30440000 ZMER EQU R1 30460000 ZMAR EQU R2 30480000 ZLEVAR EQU WORKX 30500000 LETRAFX EQU R9 30520000 LETRAF EQU * 30540000 CLI ZLVOV,X'FF' HAS TABLE OVERFLOW OCCURED 30560000 BCR 8,LETRAFX YES 30580000 L ZMER,PFA ADDRESS OF LAST CRIDTAB ENTRY 30600000 LETRAF1 LR ZMAR,ZMER 30620000 LA WORKR,ZFOSTA 30640000 MVC *+9(1),0(ZMER) ADDRESS ACTUAL FSTAB-ENTRY 30660000 TM 0(WORKR),NOSUOP 30680000 BO LETRAF2 30700000 L ZLEVAR,ZLEVA 30720000 C ZLEVAR,ZLESTA HAS A WRITE BEEN ISSUED 30740000 BNE LETRAF5 NO 30760000 BAL WORKR,CHECK YES, CHECK 30780000 CLC LVLENGTH(4),LVTAB40S MORE OUTPUT ALLOWED 30800000 BNL LETRAF4 NO 30820000 LH WORKR,LVCNT STEP RECORD COUNTER 30840000 LA WORKR,1(0,WORKR) 30860000 STH WORKR,LVCNT 30880000 LETRAF5 LA ZLEVAR,4(0,ZLEVAR) 30900000 MVC 0(1,ZLEVAR),0(ZMER) PLUG IN FS-NUMBER 30920000 MVC 1(3,ZLEVAR),8(ZITANR) PLUG IN ADDRESSPART OF CUR. ID. 30940000 C ZLEVAR,ZLEMAX LVTAB FILLED UP 30960000 BE LETRAF3 YES 30980000 LETRAF6 ST ZLEVAR,ZLEVA 31000000 LETRAF2 SH ZMER,NINE GET NEXT CRIDTAB-ENTRY 31020000 C ZMER,PFANO BEGINNING OF CRIDTAB 31040000 BCR 8,LETRAFX YES, RETURN 31060000 CLC 0(1,ZMER),0(ZMAR) IS IT AN ENTRY IN SAME FS 31080000 BE LETRAF2 SAME 31100000 B LETRAF1 NEW 31120000 SPACE 31140000 LETRAF3 EQU * 31160000 BAL WORKR,CHECK CHECK POSSIBLE WRITE 31180000 L WORKR,LVSTRT WRITE START ADDRESS 31200000 L WORKX,LVTAB30S LENGTH OF WRITE 31220000 BAL R15,WRITE WRITE 31240000 L WORKR,LVLENGTH LENGTH OF LVTAB 31260000 A WORKR,LVTAB30S BUFFER LENGTH 31280000 ST WORKR,LVLENGTH 31300000 L ZLEVAR,ZLESTA START ADDRESS OF LVTAB 31320000 B LETRAF6 31340000 LETRAF4 EQU * 31360000 BAL R15,TABOFLO 31380000 BAL MOVERROX,MOVERRO 31400000 BR LETRAFX 31420000 EJECT 31440000 * ***** SUSCRITE ****** 31460000 SPACE 31480000 * ROUTINE TO CHECK IF AN SUBSCRIPT EXPRESSION IS OPTIMIZA- 31500000 * BLE IN WHAT CASE AN SUTAB-ENTRY IS DONE, OTHER SUBROU- 31520000 * TINE SUCRIDEL IS ENTRED BEFORE RETURN. 31540000 SPACE 31560000 * RETURN REG SUBTSTX 31580000 * WORK REG ZARSPOR, SUBR, OPPTR, ADDENDR, CVR, SUTR 31600000 * SUBROUTINE LINKS OPERANDX, SUBMULTX, SUTABX 31620000 SPACE 31640000 SUBR EQU R1 31660000 SUTR EQU R1 31680000 OPPTR EQU R2 31700000 ZARSPOR EQU R2 31720000 ADDENDR EQU R7 31740000 CVR EQU R8 31760000 SUTABX EQU R14 31780000 SUBTSTX EQU R9 31800000 SUBMULTX EQU R14 31820000 OPERANDX EQU R15 31840000 SPACE 31860000 SUSCRITE L SUBR,ZBRACK INITILIZE CURRENT POINTER 31880000 LR WORKR,ZOUR ADDRESS OF LAST BYTE OF SUBSCR. 31900000 SH WORKR,FIVE ADDRESS OPERATOR BEFOR LAST OPD 31920000 ST WORKR,SUBEND 31940000 CLI 1(SUBR),X'01' SUBSCRIPT START WITH + OR - 31960000 BH SUB1 NO 31980000 LA SUBR,1(0,SUBR) POINT TO BYTE BEFORE OPERAND 32000000 SPACE 32020000 SUB1 C SUBR,SUBEND ANY OPERAND IN SUBSCRIPT 32040000 BCR 2,SUBTSTX NO, RETURN 32060000 BAL OPERANDX,OPERAND TEST OPERAND 32080000 C SUBR,SUBEND END OF SUBSCRIPT 32100000 BE SUBONE 32120000 CLI 6(SUBR),X'02' WHAT FOLLOWS FIRST OPERAND 32140000 BL SUBPM PLUS OR MINUS 32160000 BE SUBAST ASTERISK 32180000 SPACE 32200000 * UNOPTIMIZABLE SUBSCRIPT EXPRESSION 32220000 SUBNOOP BAL SUCRIDX,SUCRIDEL HANDLE UNOPTIMIZABLE EXPRESSION 32240000 BR SUBTSTX RETURN 32260000 SPACE 32280000 SPACE 32300000 * ONLY ONE OPERAND 32320000 SUBONE LTR CVR,OPPTR CONTROLLED VARIABLE 32340000 BP SUBONE3 YES 32360000 MVC ADDEND(6),0(SUBR) OPERAND IS ADDEND 32380000 MVC FACTOR(6),ZEROELEM SET FACTOR TO ZERO 32400000 L CVR,ZFOCRI ADDRESS OF LAST CRIDTAB ENTRY 32420000 L ZARSPOR,ZARSPO ADDRESS CURRENT ARIDSTAB-ENTRY 32440000 SUBONE1 SR WORKR,WORKR GET FSN 32460000 IC WORKR,0(0,CVR) 32480000 STC WORKR,OLDFSN 32500000 LA WORKX,ZFOSTA(WORKR) ADDRESS FSTAB-ENTRY 32520000 TM 0(WORKX),X'40' SUBSCRIPT OPTIMIZATION POSSIBLE 32540000 BO SUBONE2 32560000 L ZARSPOR,ZARSPO ADDRESS LAST ARIDSTACK ENTRY 32580000 LA WORKX,SPTAB(WORKR) ADDRESS SPTAB-ENTRY 32600000 CLC 0(1,WORKX),0(ZARSPOR) SCOPE OF ARRAY OK 32620000 BL SUBONE2 NO 32640000 TM ADDEND+2,X'30' CONSTANT 32660000 BZ SUBONE4 YES 32680000 CLC 0(1,WORKX),ADDEND+3 SCOPE-TEST OF ADDEND 32700000 BL SUBONE2 NOT OK 32720000 SUBONE4 BAL SUTABX,SUTABENT MAKE SUTAB-ENTRY 32740000 SUBONE2 C CVR,PFA END OF CRIDTAB 32760000 BCR 8,SUBTSTX YES,RETURN 32780000 LA CVR,9(0,CVR) FIND ENCLOSED FOR STATEMENT 32800000 OLDFSN EQU *+1 32820000 CLI 0(CVR),X'00' ENTRY TO SAME FOR-STATEMENT 32840000 BE SUBONE2 YES, CHECK NEXT ENTRY 32860000 B SUBONE1 NO, POSSIBLY NEW SUTAB-ENTRY 32880000 SPACE 32900000 * OPERAND IS CONTROLLED VARIABEL 32920000 SUBONE3 MVC FACTOR(1),0(SUBR) OPERATOR TO FACTOR 32940000 MVC FACTOR+1(5),ONEELEM+1 SET FACTOR TO ONE 32960000 SUBONE5 MVC ADDEND(6),ZEROELEM SET ADDEND TO ZERO 32980000 B SUBFIN1 33000000 * FIRST OPERAND FOLLOWED BY + OR -. 33020000 SUBPM MVC ADDEND(6),0(SUBR) FIRST OPERAND PROBABLY ADDEND 33040000 LR ADDENDR,OPPTR SAVE CRIDTAB POINTER 33060000 LA SUBR,6(0,SUBR) ADDRESS SIGN OF SECOND OPERAND 33080000 BAL OPERANDX,OPERAND CHECK SECOND OPERAND 33100000 C SUBR,SUBEND END OF SUBSCRIPT 33120000 BE SUBPM1 YES 33140000 CLI 6(SUBR),X'02' ASTERISK SHOULD FOLLOW 33160000 BNE SUBNOOP NOT OPTIMIZABLE 33180000 BAL SUBMULTX,SUBMULT CHECK MULTIPLICATION 33200000 B SUBFIN TERMINATE 33220000 SPACE 33240000 SUBPM1 CR OPPTR,ADDENDR WHAT IS SECOND OPERAND 33260000 BL SUBPM3 ADDEND 33280000 BE SUBPM4 NOT OPTIMIZABLE EXPRESSION 33300000 LR CVR,OPPTR ADDRESS CRIDTAB-ENTRY OF CONTR. 33320000 MVC FACTOR(1),0(SUBR) SIGN OF FACTOR 33340000 SUBPM2 MVC FACTOR+1(5),ONEELEM+1 SET FACTOR TO ONE 33360000 B SUBFIN 33380000 SUBPM3 LR CVR,ADDENDR SECOND OPERAND ADDEND, SHIFT 33400000 LR ADDENDR,OPPTR 33420000 MVC FACTOR(1),ADDEND SIGN OF FACTOR 33440000 MVC ADDEND(6),0(SUBR) 33460000 B SUBPM2 33480000 SUBPM4 LTR CVR,ADDENDR CONTROLLED VARIABEL 33500000 BCR 8,SUBTSTX NO 33520000 B SUBFIN4 YES 33540000 SPACE 33560000 * FIRST OPERAND FOLLOWED BY ASTERISK 33580000 SUBAST BAL SUBMULTX,SUBMULT CHECK MULTIPLICATION 33600000 C SUBR,SUBEND END OF SUBSCRIPT 33620000 BE SUBONE5 YES, SET ADDEND TO ZERO 33640000 CLI 6(SUBR),X'01' PLUS OR MINUS 33660000 BH SUBNOOP NO, NO SUBSCRIPT OPTIMIZATION 33680000 LA SUBR,6(0,SUBR) ADDRESS SIGN 33700000 BAL OPERANDX,OPERAND CHECK OPERAND 33720000 MVC ADDEND(6),0(SUBR) SAVE ADDEND 33740000 LR ADDENDR,OPPTR LAST OPERAND WAS ADDEND 33760000 SPACE 33780000 SUBFIN LTR ADDENDR,ADDENDR ADDEND CONTROLLED VARIABEL 33800000 BZ SUBFIN1 NO 33820000 SR WORKR,WORKR YES INDICATE ELEMENTARY LOOP 33840000 IC WORKR,0(0,ADDENDR) 33860000 LA WORKX,ZFOSTA(WORKR) 33880000 OI 0(WORKX),X'80' 33900000 CR CVR,ADDENDR OPTIMIZATION POSSIBLE 33920000 BNH SUBFIN4 NO 33940000 SUBFIN1 SR WORKR,WORKR FSN OF CONTROLLED VAR.TO RE6 33960000 IC WORKR,0(0,CVR) 33980000 L ZARSPOR,ZARSPO ADDRESS LAST ARIDSTAB-ENTRY 34000000 LA WORKX,ZFOSTA(WORKR) ADDRESS FSTAB-ENTRY 34020000 TM 0(WORKX),X'40' SUBSCRIPT OPTIMIZATION POSSIBLE 34040000 BO SUBFIN4 NO, NO OPTIMIZATION 34060000 LA WORKX,SPTAB(WORKR) ADDRESS SPTAB-ENTRY 34080000 CLC 0(1,WORKX),0(ZARSPOR) SCOPE OF ARRAY OK 34100000 BL SUBFIN4 NO, NO OPTIMIZATION 34120000 TM FACTOR+2,X'30' FACTOR CONSTANT 34140000 BZ SUBFIN2 YES 34160000 CLC 0(1,WORKX),FACTOR+3 SCOPE OF FACTOR OK 34180000 BL SUBFIN4 NO, NO OPTIMIZATION 34200000 SUBFIN2 TM ADDEND+2,X'30' ADDEND CONSTANT 34220000 BZ SUBFIN3 YES 34240000 CLC 0(1,WORKX),ADDEND+3 SCOPE OF ADDEND OK 34260000 BL SUBFIN4 NO, NO OPTIMIZATION 34280000 SUBFIN3 BAL SUTABX,SUTABENT MAKE SUTAB ENTRY 34300000 BR SUBTSTX RETURN 34320000 SPACE 34340000 SUBFIN4 SR WORKR,WORKR 34360000 IC WORKR,0(0,CVR) FSN OF CONTROLLED VARIABEL 34380000 LA WORKX,ZFOSTA(WORKR) ADDRESS FSTAB-ENTRY 34400000 OI 0(WORKX),X'80' ELEMENTARY LOOP 34420000 BR SUBTSTX 34440000 SPACE 3 34460000 * ***** OPERAND ***** 34480000 SPACE 34500000 * SUBROUTINE TO SUSCRITE TO CHECK WHAT FOLLOWS AN OPERATOR 34520000 * IF NOT AN INTEGER OPERAND AN ERROR-EXIT IS TAKEN. OTHER- 34540000 * WISE THE SETTING OF REGISTER OPPTR SHOWS TYPE OF OPERAND 34560000 SPACE 34580000 * INITILIZED REGISTER OPPTR 34600000 SPACE 34620000 OPERAND TM 1(SUBR),X'80' OPERAND 34640000 BZ SUBNOOP NO 34660000 TM 2(SUBR),X'CE' INTEGER 34680000 BM SUBNOOP NO 34700000 TM 1(SUBR),X'06' CRITICAL IDENTIFIER 34720000 BO OPERAND1 YES 34740000 OPERAND4 SR OPPTR,OPPTR INDICATE 'NO-CONTROLLED VARIAB. 34760000 BR OPERANDX RETURN 34780000 SPACE 34800000 * IS OPERAND CONTROLLED VARIABEL 34820000 OPERAND1 L OPPTR,PFA ADDRESS OF LAST CRIDTAB ENTRY 34840000 LA OPPTR,9(0,OPPTR) INITILIZE LOOP 34860000 OPERAND2 SH OPPTR,NINE GET NEXT ENTRY 34880000 CLC 1(3,OPPTR),3(SUBR) OPERAND FOUND 34900000 BNE OPERAND2 NO, GET NEXT CRIDTAB ENTRY 34920000 SPACE 34940000 OPERAND3 TM 4(OPPTR),X'80' CONTROLLED VARIABEL 34960000 BCR 1,OPERANDX YES 34980000 TM 4(OPPTR),X'40' PRECEEDING CRITICAL IDENTIFIER 35000000 BZ OPERAND4 NO 35020000 MVC ALIGNH(2),5(OPPTR) GET CRIDTAB CHAIN 35040000 L OPPTR,ALIGN GET ADDRESS OF CHAINED ENTRY 35060000 A OPPTR,ZFOCRI 35080000 B OPERAND3 CHECK THIS ENTRY 35100000 SPACE 3 35120000 * ***** SUBMULT ***** 35140000 SPACE 35160000 * SUBROUTINE TO SUSCRITE TO CHECK WHAT FOLLOWS AN ASTERISK 35180000 * IF NOT INTEGER FACTOR TIMES INTEGER CONTROLLED VARIABEL 35200000 * AN ERROR-EXIT IS TAKEN. OTHERWISE REGISTER CVR AND BUC- 35220000 * KET FACTOR ARE INITILIZED. 35240000 SPACE 35260000 * INITILIZED REG CVR 35280000 SPACE 35300000 SUBMULT MVC FACTOR(6),0(SUBR) MOVE OPERAND TO FACTOR 35320000 LR CVR,OPPTR SAVE PTR 35340000 LA SUBR,6(0,SUBR) ADDRESS NEXT OPERAND 35360000 BAL OPERANDX,OPERAND CHECK SECOND OPERAND 35380000 CR OPPTR,CVR WHICH OPERAND IS FACTOR 35400000 BH SUBMULT2 FIRST 35420000 BE SUBNOOP NONE, NO OPTIMIZATION 35440000 MVC FACTOR+1(5),1(SUBR) SECOND, MOVE OPERAND TO FACTOR 35460000 SUBMULT1 LTR OPPTR,OPPTR FACTOR CONTROLLED VARIABEL 35480000 BCR 8,SUBMULTX NO, RETURN 35500000 SR WORKR,WORKR SET FOR-LOOP OF FACTOR ELEMENTARY 35520000 IC WORKR,0(0,OPPTR) FSN OF FACTOR 35540000 LA WORKX,ZFOSTA(WORKR) ADDRESS FSTAB-ENTRY 35560000 OI 0(WORKX),X'80' MAKE LOOP ELEMENTARY 35580000 BR SUBMULTX RETURN 35600000 SUBMULT2 LR WORKR,OPPTR EXCHANGE REGISTERS 35620000 LR OPPTR,CVR 35640000 LR CVR,WORKR 35660000 B SUBMULT1 35680000 SPACE 3 35700000 * ***** SUTABENT ***** 35720000 SPACE 35740000 * SUBROUTINE TO SUBSCRITE TO MAKE AN SUTAB-ENTRY. 35760000 SPACE 35780000 SUTABENT L SUTR,ZSUTAPO CURRENT SUTAB PTR 35800000 C SUTR,ZSUDAD HAS A WRITE MACRO BEEN GIVEN 35820000 BNE SUTAB1 NO 35840000 BAL WORKR,CHECK CHECK LAST OPERATION NO UT3 35860000 CLC SULENGTH(4),SUTAB40S TABLE OVERFLOW 35880000 BNL SUTAB4 YES 35900000 LH WORKR,SUCNT STEP RECORD COUNTER 35920000 LA WORKR,1(0,WORKR) 35940000 STH WORKR,SUCNT 35960000 SUTAB1 LA SUTR,14(0,SUTR) ADDRESS NEW SUTAB-ENTRY 35980000 ST SUTR,ZSUTAPO SAVE SUTAB PTR 36000000 * MAKE SUTAB ENTRY 36020000 MVC 0(1,SUTR),0(CVR) INSERT FSN 36040000 MVC 1(3,SUTR),0(ZARSPOR) ADDRESS PART OF ARRAY 36060000 MVC 4(3,SUTR),FACTOR+3 ADDRESS PART OF FACTOR 36080000 MVC 7(3,SUTR),ADDEND+3 ADDRESS PART OF ADDEND 36100000 MVC 10(1,SUTR),ZPOSIX+1 SUBSCRIPT NUMBER 36120000 CLI FACTOR,X'01' SIGN OF FACTOR MINUS 36140000 BNE SUTAB2 NO 36160000 OI 10(SUTR),X'80' YES, SET 1.BIT TO ONE 36180000 SUTAB2 CLI ADDEND,X'01' SIGN OF ADDEND MINUS 36200000 BNE SUTAB3 NO 36220000 OI 10(SUTR),X'40' YES, SET 2.BIT TO ONE 36240000 SUTAB3 MVC 11(3,SUTR),4(ZARSPOR) POSITION OF OPENING BRACKET 36260000 SPACE 36280000 C SUTR,ZSUTMAX SUTAB FILLED UP 36300000 BCR 4,SUTABX 36320000 BAL WORKR,CHECK CHECK POSSIBLE WRITE 36340000 L WORKR,SUSTRT WRITE START ADDRESS 36360000 L WORKX,SUTAB30S LENGTH OF WRITE 36380000 BAL R15,WRITE WRITE 36400000 L WORKR,SULENGTH GET FULL SUTAB LENGTH 36420000 A WORKR,SUTAB30S 36440000 ST WORKR,SULENGTH 36460000 MVC ZSUTAPO(4),ZSUDAD INITILIZE CURRENT SUTAB PTR 36480000 BR SUTABX 36500000 SPACE 36520000 SUTAB4 EQU * 36540000 BAL R15,TABOFLO HANDLE TABLE OVERFLOW 36560000 BAL MOVERROX,MOVERRO 36580000 B SUBFIN4 NO OPT, MAKE LOOP ELEMENTARY 36600000 SPACE 3 36620000 OUCHA EQU * 36640000 STM R14,R2,REGSAVE SAVE REGISTERS 36660000 LOUCHAF B LOUCHA7 BRANCH ONLY IF FIRST RECORD 36680000 CHECK SWRITE 36700000 LOUCHA6 CLC ZARSPO(4),ZARNO BUFFER EXCHANGE IN SUBSCR.EXPR. 36720000 BNE LOUCHA1 YES 36740000 LOUCHA5 MVI 1(ZOUR),X'2F' ZETA TERMINATES O-BUFFER 36760000 L ZOUR,ZOBWRITE 36780000 LR WORKX,ZOUR 36800000 BCTR ZOUR,0 INITILIZE ZOUR 36820000 LOUCHA4 L WORKR,SRCE3S OUTPUT BUFFER LENGTH 36840000 SH WORKR,TWELVE SET END PTRS 36860000 AR WORKR,WORKX 36880000 ST WORKR,ZFILE9 36900000 LA WORKR,3(0,WORKR) 36920000 ST WORKR,ZFILE6 36940000 LA WORKR,1(0,WORKR) 36960000 ST WORKR,ZFILE5 36980000 LA WORKR,2(0,WORKR) 37000000 ST WORKR,ZFILE3 37020000 LA WORKR,1(0,WORKR) 37040000 ST WORKR,ZFILE2 37060000 LA WORKR,1(0,WORKR) 37080000 ST WORKR,ZFILE1 37100000 MVC ZOBWRITE(4),ZOBWORK ZOBWRITE=ZOBWORK 37120000 ST WORKX,ZOBWORK STARTADDRESS OF NEW OUT-BUFFER 37140000 LH WORKR,ZOUTCOT OUTPUT RECORD COUNTER 37160000 CH WORKR,TWOFIVFI TOO MUCH SOURCE OUTPUT 37180000 BE LOUCHA8 YES 37200000 LA WORKR,1(0,WORKR) 37220000 STH WORKR,ZOUTCOT 37240000 L WORKR,UT2ADD DCB ADDRESS 37260000 L WORKX,ZOBWRITE AREA ADDRESS 37280000 WRITE SWRITE,SF,(WORKR),(WORKX) 37300000 LM R14,R2,REGSAVE 37320000 BR R15 37340000 LOUCHA1 L WORKR,ZBRACK GET CURRENT LENGTH OF SUBSCRIPT 37360000 LR WORKX,ZOUR 37380000 SR WORKX,WORKR SUBSCRIPT LENGTH 37400000 BM LOUCHA5 NOTHING TO SAVE 37420000 CH WORKX,EIGHTEEN SUBSCRIPT ALREADY TOO LONG 37440000 BH LOUCHA2 YES 37460000 STC WORKX,LOUCHAM+1 LENGTH OF SUBSCRIPT 37480000 STC WORKX,LOUCHAL+3 37500000 L WORKX,ZOBWRITE STARTADDRESS OF NEW OUT-BUFFER 37520000 LOUCHAM MVC 0(1,WORKX),0(WORKR) SAVE SUBSCRIPT 37540000 MVI 0(WORKR),X'2F' REPLACE OPENING BRACKET BY ZETA 37560000 LOUCHAL LA ZOUR,0(0,WORKX) DISPLACEMENT LENGTH OF SUB 37580000 ST WORKX,ZBRACK ADDRESS OF OPENING BRACKET 37600000 CLI 0(WORKX),X'08' IS SUBSCRIPT OPERATOR OPEN BRAC 37620000 BNE LOUCHA4 NO 37640000 L WORKR,ZARSPO YES, UPDATE ARIDSTAB-ENTRY 37660000 LH WORKX,ZOUTCOT OUTPUT-RECORD COUNTER 37680000 LA WORKX,1(0,WORKX) UPDATE 37700000 STC WORKX,4(0,WORKR) STORE RECORD COUNTER 37720000 MVC 5(2,WORKR),ZERO SET RELATIVE ADDRESS TO ZERO 37740000 L WORKX,ZOBWRITE START ADDRESS OF NEW BUFFER 37760000 B LOUCHA4 37780000 LOUCHA2 BAL SUCRIDX,SUCRIDEL 37800000 MVI ZCLOBRA,X'FF' ZCLOBRA IS SET TO X'FF' 37820000 L WORKR,ZOBWRITE START ADDRESS OF NEW BUFFER 37840000 BCTR WORKR,0 37860000 ST WORKR,ZBRACK 37880000 B LOUCHA5 BRANCH TO LOUCHA5 37900000 LOUCHA7 MVI LOUCHAF+1,X'00' TURN OFF SWITCH 37920000 B LOUCHA6 37940000 LOUCHA8 MVC ZERRONU(2),TOOLONG 37960000 MVC ZBEGERR(4),ZENDERR 37980000 BAL MOVERROX,MOVERRO 38000000 B LOMEGA3 38020000 SPACE 3 38040000 * ***** ICHA ***** 38060000 SPACE 38080000 * THE ROUTINE IS ENTERED WHEN OPERATOR ZETA (END OF INPUT- 38100000 * BUFFER) IS FOUND. IF NECESSARY A PART OF THE OLD BUFFER 38120000 * IS SAVED IMMEDIATLY BEFORE THE NEW BUFFER. START ADDRESS 38140000 * OF SAVED AREA IS STORED IN ZIBWORK 38160000 SPACE 38180000 * RETURN REG R15 38200000 SPACE 38220000 ICHA EQU * 38240000 STM R14,R2,REGSAVE SAVE REGISTERS 38260000 CHECK SREAD CHECK LAST READ 38280000 ICHA1 L WORKR,UT1ADD DCB ADDRESS 38300000 L WORKX,ZIBRUN AREA ADDRESS 38320000 READ SREAD,SF,(WORKR),(WORKX) 38340000 LM R14,R2,REGSAVE RESTORE REGISTERS 38360000 L ZINR,ZIBREAD BEGIN OF ACTIVITED BUFFER 38380000 MVC ZIBREAD(4),ZIBRUN EXCHANGE POINTERS 38400000 ST ZINR,ZIBRUN 38420000 BR R15 38440000 ICHAI STM R14,R2,REGSAVE 38460000 B ICHA1 38480000 SPACE 3 38500000 * ***** ITABMOVE **** 38520000 SPACE 38540000 * ITABMOVE IS ENTERD AT THE BEGINNING OF A NEW PROGRAM- 38560000 * BLOCK AND DURING INITIALIZATION. THE READ OF NEXT ITAB- 38580000 * RECORD IS ALREADY INITILIZED. IF A MOVE OF NEXT RECORD 38600000 * IS NECESSARY IT IS DONE BY THE SUBROUTINE ITABM. ALL 38620000 * CURRENT ITAB-POINTERS IS UPDATED 38640000 SPACE 38660000 * RETURN REG R15 38680000 * WORKREG ZITRECR, ZITABSTR 38700000 * SUBROUTINE ITABM, MOVERRO 38720000 SPACE 38740000 ZITRECR EQU R7 38760000 ZITABSTR EQU R8 38780000 ITABMOP MVI LETTERB,X'00' TURN OFF PROCEDURE SWITCH 38800000 ITABMOVE EQU * 38820000 STM R14,R2,REGSAVE 38840000 CLI IOBYTE,READM INITILIZED READ OPERATION 38860000 BNE ITAB4 NO 38880000 CHECK RITAB YES, CHECK 38900000 MVI IOBYTE,READC SET READ CHECK MASK 38920000 ITAB4 EQU * 38940000 L ZITRECR,ZITREC ADDRESS OF BLOCKBEGIN 38960000 MVC 6(2,ZITRECR),ZCURITLE ITAB REC LENGTH OF EMBR BLOCK 38980000 MVC ZCURITLE(2),0(ZITRECR) LENGTH OF BLOCK 39000000 SPACE 39020000 L ZITABSTR,ZCURITEN TEST IF A MOVE IS NECESSARY 39040000 LA ZITABSTR,11(0,ZITABSTR) 39060000 CR ZITABSTR,ZITRECR 39080000 BE ITAB1 NO MOVE 39100000 SPACE 39120000 * MOVE ITAB RECORD 39140000 LH WORKX,ZCURITLE LENGTH OF ITAB RECORD 39160000 EX WORKX,ITABMEX MOVE FIRST PART 39180000 LR WORKR,WORKX 39200000 AR ZITRECR,WORKR END ADDRESS OF MOVED RECORD 39220000 AR WORKR,ZITABSTR END ADDRESS OR UNMOVED RECORD 39240000 SH ZITRECR,C1792 PREPARE MOVE 39260000 SH WORKR,C1792 PREPARE MOVE 39280000 SRA WORKX,8 PREPARE BRANCH 39300000 SLA WORKX,2 39320000 B *+4(WORKX) 39340000 B ITABM8 39360000 B ITABM7 39380000 B ITABM6 39400000 B ITABM5 39420000 B ITABM4 39440000 B ITABM3 39460000 B ITABM2 39480000 MVC 0(256,WORKR),0(ZITRECR) 39500000 ITABM2 MVC 256(256,WORKR),256(ZITRECR) 39520000 ITABM3 MVC 512(256,WORKR),512(ZITRECR) 39540000 ITABM4 MVC 768(256,WORKR),768(ZITRECR) 39560000 ITABM5 MVC 1024(256,WORKR),1024(ZITRECR) 39580000 ITABM6 MVC 1280(256,WORKR),1280(ZITRECR) 39600000 ITABM7 MVC 1536(256,WORKR),1536(ZITRECR) 39620000 ITABM8 EQU * 39640000 SPACE 39660000 ITAB1 LH WORKR,ZCURITLE GET ADDRESS OF LAST ITAB ENTRY 39680000 A WORKR,ZCURITEN ACTUELL RECORDLENGTH + PREV.ADD 39700000 ST WORKR,ZCURITEN 39720000 LA WORKR,11(0,WORKR) ADDRESS OF FIRST FREE BYTE 39740000 ST WORKR,ZITREC 39760000 CLC 10(1,ZITABSTR),PBN+1 LAST ITAB RECORD 39780000 BE ITAB7 YES 39800000 MVC ALIGNH(2),2(ZITABSTR) LENGTH OF NEXT BLOCK 39820000 A WORKR,ALIGN END ADDRESS OF NEXT BLOCK 39840000 C WORKR,ZITEND ITAB OVERFLOW 39860000 BH ITAB10 YES 39880000 CLI IOBYTE,READC WHICH I/O STATUS 39900000 BE ITAB6 CHECKED READ OPERATION 39920000 BL ITAB5 CHECKED WRITE OPERATION 39940000 CHECK TWRITE INITILIZED WRITE OPERATION 39960000 ITAB5 EQU * 39980000 L R1,UT3ADD DCB ADDRESS 40000000 NOTE (1) SAVE ID OF LAST BLOCK 40020000 ST R1,NOTEW 40040000 L R1,UT3ADD DCB ADDRESS 40060000 MVI NOTER+3,X'01' ADDRESS NEXT ITAB BLOCK 40080000 POINT (1),NOTER 40100000 ITAB6 EQU * 40120000 L WORKR,UT3ADD DCB ADDRESS 40140000 L WORKX,ZITREC READ START ADDRESS 40160000 READ RITAB,SF,(WORKR),(WORKX),'S' 40180000 MVI IOBYTE,READM SET ITAB READ 40200000 ITAB7 EQU * 40220000 LM R14,R2,REGSAVE 40240000 MVC CURPBN(1),10(ZITABSTR) SAVE CURRENT PBN 40260000 BR R15 RETURN 40280000 ITAB10 ST ZINR,ZBEGERR ERROR EDIT 40300000 ST ZINR,ZENDERR 40320000 MVC ZERRONU(2),ITABOVER 40340000 BAL MOVERROX,MOVERRO 40360000 B LOMEGA3 40380000 ITABREAD EQU * 40400000 STM R14,R2,REGSAVE 40420000 LA ZITABSTR,GENER ADDRESS DUMMY HEADER 40440000 B ITAB6 40460000 SPACE 40480000 ITABMEX MVC 0(1,ZITABSTR),0(ZITRECR) 40500000 SPACE 3 40520000 * INVALID OPERAND FOUND. SET SYNTAX CHECK MODE AND GIVE 40540000 * ERRORMESSAGE. 40560000 INCOROP OI HCOMPMOD,X'80' SET SYNTAX CHECK MODE 40580000 LA R0,ZIDEX+12 40600000 INCOROP5 LR RFI,ZINR 40620000 INCOROP1 CLI 0(ZINR),X'2E' END OF OPERAND 40640000 BL INCOROP2 YES 40660000 BE INCOROP3 STRING OR LOGICAL VALUE 40680000 CLI 0(ZINR),X'2F' END OF INPUT BUFFER 40700000 BE INCOROP4 YES 40720000 LA ZINR,1(0,ZINR) PROCEED SCAN FOR OPERAND END 40740000 B INCOROP1 40760000 SPACE 40780000 INCOROP4 EQU * 40800000 LR R1,ZINR 40820000 BAL MOVEX,MOVE 40840000 BAL R15,ICHA 40860000 B INCOROP5 40880000 INCOROP2 EQU * 40900000 LR R1,ZINR 40920000 BAL MOVEX,MOVE 40940000 ST RTO,ZENDERR 40960000 MVC ZBEGERR,OPSTART 40980000 BAL MOVERROX,MOVERRO 41000000 LA ZITANR,ZALLPU REPLACE INCOR.ID. BY ALL PUB.ID 41020000 B LETTER1 41040000 SPACE 41060000 INCOROP3 MVC 0(6,ZINR),ZPOINT REPLACE INT.NAME BY SIX PERIODS 41080000 LA ZINR,6(0,ZINR) 41100000 B INCOROP1 41120000 SPACE 2 41140000 * ***** MOVERRO ***** 41160000 SPACE 41180000 * ERROR-EDITING ROUTINE. OUTPUTS ALWAYS FIXED PART CON- 41200000 * TAINING LENGTH OF ENTRY, ERROR NUMBER AND SEMICOLON 41220000 * COUNTER. SOMETMES VARIABEL PART WHOS STARTADDRESS IS 41240000 * STORED IN ZBEGERR AND (END ADDRESS + 1) IN ZENDERR. 41260000 SPACE 41280000 * RETURN REG MOVERROX 41300000 SPACE 41320000 ZERRPOR EQU WORKR 41340000 ZLER EQU WORKX 41360000 MOVERROX EQU R15 41380000 MOVERRO EQU * 41400000 L ZERRPOR,NEXTERR 41420000 C ZERRPOR,ENDPOOL ERROR POOL OVERFLOW 41440000 BH MOVERRO2 YES 41460000 L ZLER,ZENDERR GET LENGTH OF VARIABEL PART 41480000 S ZLER,ZBEGERR 41500000 CH ZLER,TWELVE DOES LENGTH EXCEEDS MAXIMUM 41520000 BNH MOVERRO1 NO 41540000 LH ZLER,TWELVE YES, SET LENGTH TO MAX 41560000 MOVERRO1 LA ZLER,4(0,ZLER) LENGTH OF FULL ERROR ENTRY 41580000 SPACE 41600000 AR ZERRPOR,ZLER GET ADDRESS OF NEXT ERROR ENTRY 41620000 ST ZERRPOR,NEXTERR 41640000 SR ZERRPOR,ZLER 41660000 SPACE 41680000 STC ZLER,0(0,ZERRPOR) FIXED PART OF ERROR ENTRY, LENGTH 41700000 MVC 1(1,ZERRPOR),ZERRONU+1 ERROR NUMBER 41720000 MVC 2(2,ZERRPOR),SEMCNT SEMICOLON COUNTER 41740000 SPACE 41760000 SH ZLER,FIVE ANY VARIABEL PART 41780000 BM MOVERRO3 NO 41800000 STC ZLER,MOVERROM+1 LENGTH OF MOVE 41820000 L ZLER,ZBEGERR START ADD OF ADDITIONAL PART 41840000 MOVERROM MVC 4(1,ZERRPOR),0(ZLER) MOVE ADDITIONAL PART 41860000 MOVERRO3 BR MOVERROX 41880000 MOVERRO2 EQU * 41900000 MVI 0(ZERRPOR),X'04' TERMINATING ERROR ENTRY 41920000 MVI 1(ZERRPOR),TOOMANY 41940000 MVC 2(2,ZERRPOR),SEMCNT 41960000 LA ZERRPOR,4(0,ZERRPOR) 41980000 ST ZERRPOR,NEXTERR 42000000 B LOMEGA3 42020000 SPACE 3 42040000 MOVEX EQU R15 42060000 RTO EQU R8 42080000 RFI EQU R9 42100000 SPACE 42120000 MOVEP EQU * 42140000 LR WORKR,ZINR FIELD OF ONE BYTE 42160000 SR WORKR,RFI 42180000 BC 7,MOVE 42200000 LTR REXCORR,REXCORR POINT FOLLOWED BY ZERO 42220000 BCR 4,MOVEX YES, NO SYNTAX ERROR 42240000 LA WORKR,NUMBER(REXCORR) ADDRESS IMPLIED POINT 42260000 CR WORKR,RTO POINT TERMINATE NUMBER 42280000 BE QTORLT1 YES 42300000 SPACE 42320000 MOVE EQU * 42340000 SR R1,RFI LENGTH OF MOVE 42360000 LR WORKR,RTO CALCULATE END ADDRESS 42380000 AR WORKR,R1 42400000 CR WORKR,R0 FULL MOVE POSSIBLE 42420000 BH MOVE1 NO 42440000 EX R1,MOVEEX MOVE 42460000 LR RTO,WORKR STEP PTR 42480000 BR MOVEX 42500000 SPACE 42520000 MOVE1 LR WORKR,R0 CALCULATE LENGTH OF POSSI .MOVE 42540000 SR WORKR,RTO 42560000 EX WORKR,MOVEEX 42580000 LR RTO,R0 42600000 BR MOVEX 42620000 SPACE 42640000 MOVEEX MVC 0(0,RTO),0(RFI) 42660000 SPACE 3 42680000 CHECK EQU * 42700000 CLI IOBYTE,WRITEM INITILIZED WRITE OPERATION 42720000 BCR 7,WORKR NO, RETURN 42740000 STM R14,R2,REGSAVE 42760000 CHECK TWRITE CHECK LAST WRITE 42780000 MVI IOBYTE,WRITEC SET WRITE CHECK MASK 42800000 LM R14,R2,REGSAVE 42820000 BR WORKR 42840000 SPACE 3 42860000 WRITE EQU * 42880000 STM R14,R2,REGSAVE 42900000 CLI IOBYTE,READC WHICH I/O STATUS 42920000 BL WRITE2 CHECKED WRITE OPERATION 42940000 BE WRITE1 CHECKED READ OPERATION 42960000 CHECK RITAB INITILIZED READ OPERATION 42980000 WRITE1 EQU * 43000000 L R1,UT3ADD DCB ADDRESS 43020000 NOTE (1) SAVE ID OF LAST BLOCK 43040000 ST R1,NOTER 43060000 L R1,UT3ADD DCB ADDRESS 43080000 MVI NOTEW+3,X'01' ADDRESS NEXT OUTPUT BLOCK 43100000 POINT (1),NOTEW 43120000 WRITE2 EQU * 43140000 L R0,UT3ADD DCB ADDRESS 43160000 LA WORKX,4(0,WORKX) ADD KEY-LENGTH 43180000 WRITE TWRITE,SF,(R0),(WORKR),(WORKX) 43200000 MVI IOBYTE,WRITEM SET WRITE MASK 43220000 LM R14,R2,REGSAVE 43240000 BR R15 43260000 SPACE 43280000 TABOFLO EQU * 43300000 L WORKR,PFA ADDRESS OF LAST CRIDTAB ENTRY 43320000 TABOFLO1 SR WORKX,WORKX 43340000 IC WORKX,0(0,WORKR) FOR STATEMENT NUMBER 43360000 LA WORKX,FSTAB(WORKX) ADDRESS FOR STATEMENT ENTRY 43380000 OI 0(WORKX),NOSUOP 43400000 SH WORKR,NINE 43420000 C WORKR,PFANO END OF CRIDTAB 43440000 BNH TABOFLO1 NO 43460000 SPACE 43480000 MVI ZLVOV,X'FF' SET ERROR SWITCH 43500000 MVC ZARSPO(4),ZARNO SKIP ALL ARIDSTAB-ENTRIES 43520000 ST ZINR,ZBEGERR ERROR EDITING 43540000 ST ZINR,ZENDERR 43560000 MVC ZERRONU(2),TABOVER 43580000 BR R15 43600000 EJECT 43620000 IEX30002 CSECT 43640000 RET EQU R14 43660000 REXCORR EQU R7 43680000 SPACE 43700000 DIGIT19 EQU * 43720000 LA RTO,NUMBER 43740000 LA R0,NUMBER+19 MAX LENGTH OF CONSTANT + 1 43760000 SR REXCORR,REXCORR 43780000 LR RFI,ZINR SET FIELD START 43800000 MVI SCATEST,X'00' 43820000 DIG191 LA R1,1(0,ZINR) TRT START 43840000 DIG192 SR R2,R2 43860000 DIG193 TRT 0(256,R1),DIG19 43880000 BZ DIGL19 MORE THAN 256 BYTES 43900000 LR ZINR,R1 UPDATE ZINR 43920000 B *(R2) BRANCH TABLE 43940000 B DECPTM 43960000 B SCAFACTM 43980000 B QTORLT 44000000 B ZETAM 44020000 B RHO 44040000 B OTHER 44060000 SPACE 44080000 DECPTM EQU * 44100000 BAL MOVEX,MOVE 44120000 AR REXCORR,R1 EXPONENT CORRECTION 44140000 B DECPOIN1 44160000 SPACE 44180000 SCAFACTM BAL MOVEX,MOVE 44200000 AR REXCORR,R1 EXPONENT CORRECTION 44220000 B SCA1 44240000 SPACE 44260000 QTORLT EQU * 44280000 BAL MOVEX,MOVE 44300000 AR REXCORR,R1 NUMBER OF INTEGERS 44320000 QTORLT1 ST REXCORR,ZEXCORR 44340000 BAL CERRX,CERR REBUILD CONSTANT 44360000 MVC ZERRONU(2),INVOP 44380000 B INCOROP 44400000 SPACE 44420000 ZETAM EQU * 44440000 BAL MOVEX,MOVE 44460000 AR REXCORR,R1 EXPONENT CORRECTION 44480000 BAL R15,ICHA 44500000 LR R1,ZINR 44520000 LR RFI,ZINR 44540000 B DIG192 44560000 SPACE 44580000 OTHER EQU * 44600000 C RTO,NSTART BUFFER EXCHANGE WITHIN INTEGER 44620000 BNE OTHER1 YES 44640000 LR REXCORR,ZINR COMPUTE NUMBER OF DIGITS 44660000 SR REXCORR,RFI 44680000 B INTCON 44700000 OTHER1 BAL MOVEX,MOVE 44720000 AR REXCORR,R1 GET NUMBER OF DIGITS 44740000 LR R1,RTO ADJUST POINTERS 44760000 LA RFI,NUMBER 44780000 B INTCON 44800000 SPACE 44820000 DIGL19 LA R1,256(0,R1) UPDATE INPUT PTR 44840000 B DIG193 44860000 SPACE 44880000 DIGIT0 EQU * 44900000 LA RTO,NUMBER 44920000 LA R0,NUMBER+19 MAX LENGTH OF CONSTANT + 1 44940000 SR REXCORR,REXCORR 44960000 MVI SCATEST,X'00' 44980000 LA R1,1(0,ZINR) 45000000 DIG01 SR R2,R2 45020000 DIG02 TRT 0(256,R1),DIG0 45040000 BZ DIGL0 MORE THAN 256 BYTES 45060000 LR ZINR,R1 45080000 LR RFI,ZINR 45100000 B *(R2) 45120000 B DIG191 45140000 B QTORLT 45160000 B DECPOIN1 45180000 B SCA0 45200000 B ZETA0 45220000 B RHO 45240000 B OTHOP0 45260000 SPACE 45280000 SCA0 EQU * 45300000 LD XFLOAT,ZEROFLOA FLOATING ZERO 45320000 B SCA1 45340000 SPACE 45360000 ZETA0 EQU * 45380000 BAL R15,ICHA CHANGE INPUT BUFFER 45400000 LR R1,ZINR 45420000 B DIG01 45440000 SPACE 45460000 OTHOP0 EQU * 45480000 C ZOUR,ZFILE5 OUTPUT BUFFER FULL 45500000 BNH *+8 NO 45520000 BAL R15,OUCHA YES 45540000 MVC 3(3,ZOUR),ZERO ADDRESSPART OF INTERNAL NAME 45560000 MVC 1(2,ZOUR),ZINTYP INDICATE INTEGER 45580000 LA ZOUR,5(0,ZOUR) 45600000 B GENTEST 45620000 SPACE 45640000 DIGL0 LA R1,256(0,R1) UPDATE INPUT PTR 45660000 B DIG02 45680000 SPACE 45700000 DECPOIN EQU * 45720000 LA RTO,NUMBER 45740000 LA R0,NUMBER+19 MAX LENGTH OF CONSTANT + 1 45760000 SR REXCORR,REXCORR 45780000 MVI SCATEST,X'00' 45800000 DECPOIN1 LA RFI,1(0,ZINR) 45820000 DECPOIN2 LA R1,1(0,ZINR) 45840000 DECPOIN3 SR R2,R2 45860000 DECPOIN4 TRT 0(256,R1),DECPO 45880000 BZ DECPOINL MORE THAN 256 BYTES 45900000 LR ZINR,R1 45920000 B *(R2) 45940000 B DECP0 ZERO 45960000 B QTORLTP 45980000 B DECPSCA SCALE FACTOR 46000000 B DECPZETA ZETA 46020000 B DECPOT OTHER OPERATOR 46040000 SPACE 46060000 DECP0 EQU * 46080000 CR RFI,ZINR ZERO FOLLOWING POINT 46100000 BNE DECPOIN2 NO 46120000 C RTO,NSTART PRECEEDING SIGNIFICANT DIGIT 46140000 BNE DECPOIN2 YES 46160000 BCTR REXCORR,0 NO, DECREASE EXPONENT 46180000 B DECPOIN1 46200000 SPACE 46220000 QTORLTP BAL MOVEX,MOVE 46240000 B QTORLT1 46260000 SPACE 46280000 DECPSCA EQU * 46300000 BAL MOVEX,MOVEP SYNTAX CHECK AND MOVE 46320000 C RTO,NSTART ZERO 46340000 BNE SCA1 NO 46360000 LD XFLOAT,ZEROFLOA YES, FLOATING ZERO 46380000 B SCA1 46400000 SPACE 46420000 DECPZETA EQU * 46440000 BAL MOVEX,MOVE 46460000 BAL R15,ICHA 46480000 LR RFI,ZINR 46500000 LR R1,ZINR 46520000 B DECPOIN3 46540000 SPACE 46560000 DECPOT EQU * 46580000 ST REXCORR,ZEXCORR 46600000 BAL MOVEX,MOVEP SYNTAX CHECK AND MOVE 46620000 C RTO,NSTART ZERO 46640000 BNE REALCON NO, CONVERT NUMBER 46660000 LD XFLOAT,ZEROFLOA YES, NUMBER IS FLOATING ZERO 46680000 B REALHAN MAKE A CONSTANT POOL ENTRY 46700000 SPACE 46720000 DECPOINL LA R1,256(0,R1) UPDATE INPUT PTR 46740000 B DECPOIN4 46760000 SPACE 46780000 SCAFACT EQU * 46800000 SR REXCORR,REXCORR 46820000 LD XFLOAT,ZONEFLOA MANTISSA SET TO ONE 46840000 LA RTO,NUMBER NO MANTISSA DIGIT 46860000 SCA1 ST RTO,ZTO 46880000 ST REXCORR,ZEXCORR 46900000 LA RTO,SCAWORK 46920000 LA R0,SCAWORK+9 46940000 MVI SCATEST,X'10' SCALE FACTOR PRESENT 46960000 MVI SCALE,X'00' CLEAR OLD SIGN 46980000 SCA20 LA RFI,1(0,ZINR) 47000000 SCA2 LA R1,1(0,ZINR) 47020000 SCA3 SR R2,R2 47040000 SCA4 TRT 0(256,R1),SCAFAC 47060000 BZ SCAL MORE THAN 256 BYTES 47080000 LR ZINR,R1 47100000 B *(R2) 47120000 B SCA19 47140000 B SCAZERO 47160000 B SCASIGN 47180000 B SCAQL 47200000 B SCAZETA 47220000 B SCAOT 47240000 SPACE 47260000 SCA19 EQU * 47280000 OI SCATEST,SF19 SIGNIFICANT DIGIT PRESENT 47300000 B SCA2 47320000 SPACE 47340000 SCAZERO EQU * 47360000 TM SCATEST,SF19 ANY SIGNIFICANT DIGIT 47380000 BO SCA2 YES 47400000 OI SCATEST,SFL0 LEADING ZERO 47420000 B SCA20 47440000 SPACE 47460000 SCASIGN EQU * 47480000 TM SCATEST,SFLSIGN LEADING SIGN 47500000 BC 7,SCAOT NO,TREAT AS OTHER OPERATOR 47520000 MVC SCALE(1),0(ZINR) SAVE SIGN 47540000 OI SCATEST,SFSIGN SIGNED SCALE FACTOR 47560000 B SCA20 47580000 SPACE 47600000 SCAZETA EQU * 47620000 BAL MOVEX,MOVE SAVE FIELD 47640000 BAL R15,ICHA 47660000 LR R1,ZINR 47680000 LR RFI,ZINR 47700000 B SCA3 47720000 SPACE 47740000 SCAOT EQU * 47760000 TM SCATEST,SFDIGIT ANY DIGIT 47780000 BZ SCAQL NO, ERROR MESSAGE 47800000 TM SCATEST,SF19 ANY SIGNIFICANT DIGIT 47820000 BZ SCAOT1 NO 47840000 BAL MOVEX,MOVE 47860000 S RTO,SCAWORKA 47880000 EX RTO,SCAPACK 47900000 MVN ZPACK+7(1),SREF SET SIGN TO PLUS 47920000 CLI SCALE,X'01' MUNUS SIGN 47940000 BNE *+10 NO 47960000 MVN ZPACK+7(1),SREF+1 YES, REPLACE PLUS SIGN 47980000 CVB WORKR,ZPACK CONVERT 48000000 AR REXCORR,WORKR GET EXPONENT 48020000 SPACE 48040000 SCAOT1 ST RTO,ZTOSCA 48060000 L RTO,ZTO 48080000 B REALCON 48100000 SCAPACK PACK ZPACK(8),SCAWORK(0) 48120000 SPACE 48140000 SCAQL EQU * 48160000 BAL MOVEX,MOVE 48180000 S RTO,SCAWORKA SCALE FACTOR LENGTH 48200000 ST RTO,ZTOSCA 48220000 L RTO,ZTO 48240000 BAL CERRX,CERR REBUILD CONSTANT 48260000 MVC ZERRONU(2),INVOP 48280000 B INCOROP 48300000 SPACE 48320000 SCAL LA R1,256(0,R1) UPDATE INPUT PTR 48340000 B SCA4 48360000 SPACE 3 48380000 CERRX EQU R2 48400000 SPACE 48420000 CERR EQU * CONSTANT ERROR ROUTINE 48440000 TM SCATEST,PRECERR CONSTANT ALREADY REBUILT 48460000 BCR 1,CERRX YES 48480000 L WORKR,ZEXCORR NUMBER OF INTEGERS IN MANTISSA 48500000 LTR WORKR,WORKR LEADING ZEROS AFTER POINT 48520000 BM CERR1 YES 48540000 CH WORKR,TWELVE CONSTANT TOO LONG 48560000 BNH *+8 NO 48580000 LH WORKR,TWELVE SET MAXIMAL LENGTH 48600000 EX WORKR,CERREX MOVE CONSTANT INTEGERS 48620000 A WORKR,OPSTART ADDRESS DECIMAL POINT 48640000 MVI 0(WORKR),X'3E' INSERT POINT 48660000 BCTR RTO,0 48680000 CR RTO,WORKR ANY DECIMAL POINT 48700000 BE *+8 NO 48720000 LA RTO,1(0,RTO) PREVENT POINT OVERLAY 48740000 B CERR2 48760000 SPACE 48780000 CERR1 MVI ZIDEX,X'3E' INSERT POINT 48800000 CERR2 EQU * 48820000 TM SCATEST,SF SCALE FACTOR PRESENT 48840000 BZ CERR3 NO 48860000 LA R0,NUMBER+21 48880000 MVC 0(2,RTO),SCALEQ INSERT QUOTE AND SIGN 48900000 TM SCATEST,SFSIGN SIGNED SCALE FACTOR 48920000 BO *+6 YES 48940000 BCTR RTO,0 48960000 LA RTO,2(0,RTO) 48980000 L R1,ZTOSCA 49000000 LA R1,1(0,R1) SCALE FACTOR LENGTH 49020000 LA RFI,SCAWORK 49040000 AR R1,RFI SCALE FACTOR END ADDRESS 49060000 BAL MOVEX,MOVE MOVE SCALE FACTOR 49080000 SPACE 49100000 CERR3 LA WORKR,ZIDEX+12 49120000 CR RTO,WORKR MORE THAN 12 CHARACTERS 49140000 BNH *+6 NO 49160000 LR RTO,WORKR YES SET LENGTH TO 12 49180000 ST RTO,ZENDERR 49200000 MVC ZBEGERR(4),OPSTART 49220000 BR CERRX 49240000 CERREX MVC ZIDEX(0),NUMBER 49260000 EJECT 49280000 RLIT EQU R1 49300000 RBIN EQU R2 49320000 RCNT EQU R9 49340000 REXNU EQU R9 49360000 REXNX EQU R1 49380000 REXTAB EQU R2 49400000 XFLOAT EQU 0 49420000 SPACE 49440000 INTCON EQU * 49460000 CH REXCORR,TEN NUMBER OF DIGITS 49480000 BL INTCON1 NO 49500000 BH INTCON2 YES, REAL CONSTANT 49520000 CLC 0(10,RFI),MAXNR MAXIMAL INTEGER 49540000 BH INTCON2 GREATER, REAL CONSTANT 49560000 INTCON1 BCTR REXCORR,0 49580000 EX REXCORR,INTPACK PACK 49600000 MVN ZPACK+7(1),SREF SET PLUS SIGN 49620000 CVB RBIN,ZPACK PACK 49640000 B INTHAN 49660000 INTCON2 ST RFI,ZBEGERR GIVE ERROR MESSAGE 49680000 ST R1,ZENDERR 49700000 MVC ZERRONU(2),RANGEINT 49720000 BAL MOVERROX,MOVERRO 49740000 ST REXCORR,ZEXCORR 49760000 L RTO,NSTART 49780000 BAL MOVEX,MOVE 49800000 B REALCON 49820000 INTPACK PACK ZPACK(8),0(0,RFI) LENGTH IN R1 49840000 EJECT 49860000 REALCON EQU * 49880000 LR WORKX,RTO GET LENGTH OF CONSTANT 49900000 S WORKX,NSTART 49920000 BZ REALCON7 49940000 SPACE 49960000 * CONVERT MANTISSA TO FLOATING FORM 49980000 LD XFLOAT,ZEROFLOA ZEROIZE REGISTER 50000000 LR RCNT,WORKX NUMBER OF DIGITS 50020000 SR REXCORR,RCNT UPDATE EXPONENT CORRECTION 50040000 CH RCNT,NINE CONVERSION IN ONE STEP 50060000 BH REALCON1 NO 50080000 BCTR RCNT,0 50100000 EX RCNT,REPACK PACK 50120000 REALCON2 MVN ZPACK+7(1),SREF SET PLUS SIGN 50140000 CVB WORKR,ZPACK CONVERT TO BINARY 50160000 ST WORKR,ZFLOFIEL+4 CONVERT TO FLOATING FORM 50180000 AD XFLOAT,ZFLOFIEL GET NORMALIZED FLOATING NUMBER 50200000 SPACE 50220000 C WORKX,NREAL MORE DIGITS THAN ALLOWED 50240000 BNH REALCON3 NO 50260000 BAL CERRX,CERR REBUILD CONSTANT 50280000 MVC ZERRONU(2),PRECREAL 50300000 BAL MOVERROX,MOVERRO 50320000 OI SCATEST,PRECERR INDICATE PRECITION ERROR 50340000 B REALCON3 50360000 SPACE 50380000 * CONVERT EXPONENT TO FLOATING FORM 50400000 REALCON7 EQU * 50420000 LTDR XFLOAT,XFLOAT FLOATING ZERO 50440000 BZ REALHAN YES 50460000 REALCON3 LPR REXNU,REXCORR ZERO EXPONENT 50480000 BZ REALHAN YES 50500000 LR REXNX,REXNU 50520000 LA REXTAB,ZEXTABP-8 TABLE FOR POSITIVE EXPONENT 50540000 LTR REXCORR,REXCORR POSITIVE EXPONENT 50560000 BP *+8 YES 50580000 LA REXTAB,ZEXTABN-8 N/, TABLE FOR NEGATIVE EXPONENT 50600000 REALCON6 CH REXNU,SIXFOUR EXPONENT MORE THAN 64 50620000 BNL REALCON5 YES 50640000 N REXNU,SCALEMSK NO, X'38' 50660000 BZ REALCON8 50680000 MD XFLOAT,56(REXNU,REXTAB) 50700000 REALCON8 EQU * 50720000 SLA REXNX,3 MULTIPLY BY 8 50740000 N REXNX,SCALEMSK 50760000 BZ REALCON9 50780000 MD XFLOAT,0(REXNX,REXTAB) 50800000 REALCON9 EQU * 50820000 LTDR XFLOAT,XFLOAT EXPONENT UNDERFLOW 50840000 BZ REALERR1 50860000 B REALHAN 50880000 REALCON5 MD XFLOAT,120(0,REXTAB) 10 ** +- 64 50900000 LTDR XFLOAT,XFLOAT 50920000 BZ REALERR1 50940000 SH REXNU,SIXFOUR ADJUST EXPONENT 50960000 B REALCON6 50980000 REALCON1 SH RCNT,TEN 51000000 CH RCNT,NINE CONSTANT TOO LONG 51020000 BL *+10 NO 51040000 BCTR RCNT,0 YES, SKIP THE NINETEENTH DIGIT 51060000 AH REXCORR,ONE UPDATE REXCORR 51080000 EX RCNT,REPACK PACK FIRST PART 51100000 MVN ZPACK+7(1),SREF SET PLUS SIGN 51120000 CVB WORKR,ZPACK CONVERT TO BINARY 51140000 ST WORKR,ZFLOFIEL+4 CONVERT TO FLOATING FORM 51160000 AD XFLOAT,ZFLOFIEL NORMALIZE 51180000 MD XFLOAT,ZTEN9 MULTIPLY BY 10 ** 9 51200000 LA RCNT,NUMBER+1(RCNT) ADDRESS SECOND PART 51220000 PACK ZPACK(8),0(9,RCNT) PACK SECOND PART 51240000 B REALCON2 TERMINATE CONVERSION 51260000 REPACK PACK ZPACK(8),NUMBER(0) LENGTH OF NUMBER IN RCNT 51280000 SPACE 51300000 REALERR EQU * 51320000 LA WORKR,REALHAN SET EXIT ADDRESS 51340000 ST WORKR,ZSTO 51360000 MVC 9(3,R1),ZSTO+1 MODIFIE OLD PSW IN PIE 51380000 BAL CERRX,CERR REBUILD CONSTANT 51400000 MVC ZERRONU(2),RANGEREA 51420000 BAL MOVERROX,MOVERRO 51440000 OI HCOMPMOD,X'80' 51460000 BR R14 51480000 REALERR1 BAL CERRX,CERR REBUILD CONSTANT 51500000 MVC ZERRONU(2),RANGEREA 51520000 BAL MOVERROX,MOVERRO 51540000 OI HCOMPMOD,SYNTAX 51560000 B REALHAN 51580000 EJECT 51600000 RWP EQU R9 CANNOT BE CHANGED 51620000 RDWP EQU R7 CANNOT BE CHANGED 51640000 RINTL EQU R14 51660000 REALL EQU R14 51680000 SPACE 51700000 INTHAN EQU * INTEGER HANDLING 51720000 C ZOUR,ZFILE5 SPACE ENOUGH IN OUTPUT BUFFER 51740000 BNH *+8 YES 51760000 BAL R15,OUCHA NO, CHANGE BUFFER 51780000 MVC 1(2,ZOUR),ZINTYP FIRST TWO BYTES OF INTERNAL NAM 51800000 INTHANR EQU * 51820000 CH RBIN,FIFTEEN IS NUMBER GREATER THAN 15 51840000 BH INTHAN2 YES 51860000 SLA RBIN,2 NO, MULTIPLY BY 4 51880000 STH RBIN,ZLIRE 51900000 MVI 3(ZOUR),X'00' OUTPUT 51920000 MVC 4(2,ZOUR),ZLIRE FIELD 51940000 LA ZOUR,5(0,ZOUR) UPDATE OUTPUT POINTER 51960000 B GENTEST RETURN 51980000 INTHAN2 EQU * 52000000 TM HCOMPMOD,SYNTAX COMPILE MODE 52020000 BO INTHAN1 NO 52040000 LA RINTL,INTHAN6 INITILIZE INTEGER SEARCH 52060000 LA R8,4 52080000 L RWP,ZWP 52100000 L RDWP,ZDWP 52120000 L RLIT,ZLITSTA 52140000 SR RLIT,R8 52160000 SR RWP,R8 52180000 INTHAN6 BXH RLIT,R8,INTHAN3 EXIT FOR END OF SEARCH 52200000 C RBIN,0(0,RLIT) INTEGER FOUND 52220000 BCR 7,RINTL NO, PROCEED SEARCH 52240000 SPACE 52260000 REALH1 EQU * 52280000 INTHAN1 EQU * 52300000 S RLIT,ZKOPOOL GET REL ADDRESS 52320000 STH RLIT,ZLIRE IN CONST POOL 52340000 MVC 3(1,ZOUR),KBN+1 INSERT CONSTANT BLOCK NUMBER 52360000 MVC 4(2,ZOUR),ZLIRE DISPLACEMENT ADDRESS 52380000 LA ZOUR,5(0,ZOUR) 52400000 B GENTEST 52420000 SPACE 52440000 INTHAN3 EQU * 52460000 AR RWP,R8 52480000 CR RWP,RDWP DOUBLE WORD BOUNDARY 52500000 BE INTHAN9 YES 52520000 SPACE 52540000 INTHAN4 LA RLIT,4(0,RLIT) SCAN REST OF CONSTANT POOL 52560000 CR RLIT,RDWP CURRENT END OF CONSTANT POOL 52580000 BE INTHAN10 YES 52600000 C RBIN,0(0,RLIT) LITERAL FOUND 52620000 BNE INTHAN4 NO 52640000 BE INTHAN1 52660000 SPACE 52680000 INTHAN10 LR RLIT,RWP 52700000 LR RWP,RDWP 52720000 INTHAN7 ST RWP,ZWP SAVE PTR 52740000 ST RBIN,0(0,RLIT) MAKE LITERAL POOL ENTRY 52760000 B INTHAN1 52780000 INTHAN9 C RWP,ZKOPEND END OF LITERAL POOL 52800000 BNL INTHAN8 52820000 C RWP,ZTEXTCO WRITE TXT-CARD 52840000 BL INTHAN5 NO 52860000 BAL R14,TXTTRAF WRITE 52880000 INTHAN5 LA RWP,4(0,RWP) UPDATE POINTERS 52900000 A RDWP,LREAL 52920000 ST RDWP,ZDWP SAVE UPDATE ZDWP 52940000 B INTHAN7 52960000 SPACE 52980000 INTHAN8 CLC ZKBNMAX(2),TWOFIVFI LAST CONST POOL 53000000 BE INTHAN11 YES, GIVE ERROR MESSAGE 53020000 L RWP,ZDWP 1511 53030018 BAL R14,TXTTRAF OUTPUT TXT-RECORD 53040000 BAL R14,CPOLEX CONSTANT POOL EXCHANGE 53060000 L RLIT,ZKOPOOL START ADDRESS OF CONSTANT POOL 53080000 LA RWP,4(0,RLIT) UPDATE POINTERS 53100000 LR RDWP,RLIT 53120000 A RDWP,LREAL 53140000 ST RWP,ZWP 53160000 ST RDWP,ZDWP 53180000 ST RLIT,ZLITSTA 53200000 ST RBIN,0(0,RLIT) 53220000 B INTHAN1 53240000 SPACE 53260000 INTHAN11 ST R1,ZBEGERR GIVE 53280000 ST R1,ZENDERR ERROR 53300000 MVC ZERRONU(2),MANYCON 53320000 BAL R15,MOVERRO GO TO ERROR RTN 53340000 OI HCOMPMOD,X'80' SET SYNTAX CHECK BIT 53360000 B INTHAN1 53380000 EJECT 53400000 REALHAN EQU * 53420000 C ZOUR,ZFILE5 SPACE ENOUGH IN OUTPUT BUFFER 53440000 BNH *+8 YES 53460000 BAL R15,OUCHA NO, CHANGE BUFFER 53480000 MVC 1(2,ZOUR),ZREALTYP FIRST TWO BYTES OF INTERNAL NAM 53500000 CLI ZFORTEST,X'00' IN FOR LIST 53520000 BE REALHAN1 NO 53540000 L WORKR,ZFSPTR ADDRESS FSTAB ENTRY 53560000 OI 0(WORKR),NOCOUNT CLASSIFY AS NO COUNTING LOOP 53580000 REALHAN1 EQU * 53600000 TM HCOMPMOD,X'02' WHICH PRESITION 53620000 BO REALH LONG 53640000 STE XFLOAT,ZSTO START ROUNDING 53660000 MVC ROUND(1),ZSTO 53680000 AD XFLOAT,ROUND ROUND 53700000 STE XFLOAT,ZSTO SHORT, TREAT AS INTEGER 53720000 L RBIN,ZSTO 53740000 B INTHANR 53760000 SPACE 53780000 REALH EQU * 53800000 L RLIT,ZLITSTA INITILIZE LITERAL SEARCH 53820000 TM HCOMPMOD,SYNTAX COMPILE MODE 53840000 BO REALH1 YES 53860000 LA R6,8 53880000 LR R8,R6 53900000 SR RLIT,R6 53920000 L RWP,ZWP 53940000 L RDWP,ZDWP 53960000 CR RWP,RDWP 53980000 BE REALH2 54000000 SR RDWP,R6 54020000 LA REALL,REALH3 54040000 REALH3 BXH RLIT,R8,REALH4 EXIT AT END OF SEARCH 54060000 CD XFLOAT,0(0,RLIT) LITERAL FOUND 54080000 BCR 7,REALL NO 54100000 SPACE 54120000 REALH4 LA REALL,REALH5 54140000 SR RLIT,R6 54160000 REALH5 BXH RLIT,R6,REALH6 EXIT AT END OF SCAN 54180000 CD XFLOAT,0(0,RLIT) CONSTANT FOUND 54200000 BCR 7,REALL NO 54220000 B REALH1 YES 54240000 SPACE 54260000 REALH6 AR RDWP,R6 54280000 C RDWP,ZKOPEND END OF LITERAL POOL 54300000 BNL REALH10 YES 54320000 REALH8 AR RDWP,R6 UPDATE ZDWP 54340000 ST RDWP,ZDWP 54360000 STD XFLOAT,0(0,RLIT) 54380000 B REALH1 54400000 SPACE 54420000 REALH7 BAL RET,TXTTRAF OUTPUT TXT 54440000 REALH9 AR R8,RDWP UPDATE ZWP 54460000 ST R8,ZWP 54480000 B REALH8 54500000 SPACE 54520000 REALH2 LA REALL,REALH21 54540000 SR RDWP,R6 54560000 REALH21 BXH RLIT,R6,REALH22 EXIT AT END OF SCAN 54580000 CD XFLOAT,0(0,RLIT) LITERAL FOUND 54600000 BCR 7,REALL NO 54620000 B REALH1 YES 54640000 SPACE 54660000 REALH22 AR RDWP,R6 54680000 C RDWP,ZKOPEND END OF LITERAL POOL 54700000 BNL REALH10 54720000 C RDWP,ZTEXTCO TXT TO BE PUT OUT 54740000 BL REALH9 NO 54760000 B REALH7 YES 54780000 SPACE 54800000 REALH10 CLC ZKBNMAX(2),TWOFIVFI LAST CONSTANT POOL 54820000 BE REALH11 YES 54840000 L RWP,ZDWP 1511 54850018 BAL RET,TXTTRAF OUTPUT TXT 54860000 BAL RET,CPOLEX CONSTANT POOL EXCHANGE 54880000 L RLIT,ZKOPOOL START ADDRESS OF CONSTANT POOL 54900000 LA RDWP,8(0,RLIT) UPDATE PTRS 54920000 ST RDWP,ZDWP 54940000 ST RDWP,ZWP 54960000 ST RLIT,ZLITSTA 54980000 STD XFLOAT,0(0,RLIT) LITERAL ENTRY 55000000 B REALH1 55020000 SPACE 55040000 REALH11 ST ZINR,ZBEGERR TOO MANY LITERALS, MESSAGE 55060000 ST ZINR,ZENDERR 55080000 MVC ZERRONU(2),MANYCON 55100000 BAL MOVERROX,MOVERRO 55120000 OI HCOMPMOD,X'80' SYNTAX CHECK MODE 55140000 B REALH1 55160000 EJECT 55180000 CPOLEX EQU * CONSTANT POOL EXCHANGE 55200000 L R15,ZKOPOOL UPDATE 55220000 ST R15,ZLITSTA 55240000 AH R15,TXTPUT 55260000 ST R15,ZTEXTCO TXT-RECORD POINTER 55280000 LH R15,ZKBNMAX 55300000 LA R15,1(0,R15) 55320000 STH R15,ZKBNMAX CONSTANT POOL 55340000 STH R15,KBN NUMBER 55360000 BR R14 RETURN 55380000 SPACE 55400000 TXTTRAF EQU * TRANSFER TXT-RECORD 55420000 STM 14,6,TXTSAV SAVE REGISTERS 55440000 L INFORM,ZTEXTCO 55460000 SH INFORM,TXTPUT ADDRESS OUTPUT TXT 55480000 LR WORKR,RWP CALCULATE LENGTH OF TXT 55500000 SR WORKR,INFORM 55520000 STH WORKR,TXTLE 55540000 LR WORKR,RWP GET NEW PUT ADDRESS 55560000 AH WORKR,TXTPUT 55580000 ST WORKR,ZTEXTCO 55600000 L PRPOINT,PRPT LOAD PROGRAM PTR 55620000 TM HCOMPMOD+1,X'60' NOLOAD AND NODECK 55640000 BO TXTLE2 YES 55660000 BAL LENGTH,GENTXT OUTPUT OF TEXT 55680000 TXTLE DS H INSERT LENGTH OF TEXT 55700000 TXTLE1 ST PRPOINT,PRPT STORE PROGRAM PTR 55720000 LM 14,6,TXTSAV RESTORE REGISTERS 55740000 BR R14 RETURN 55760000 TXTLE2 AR PRPOINT,WORKR UPDATE PROGRAM PTR 55780000 B TXTLE1 55800000 SPACE 55820000 REG0 EQU 0 55840000 OUTAREA EQU 1 55860000 TYPER EQU 3 55880000 RETURN EQU 4 55900000 L EQU 15 55920000 PRPOINT EQU 6 55940000 INFORM EQU 2 55960000 LENGTH EQU 14 55980000 SPACE 56000000 GENTXT EQU * GENERATE TXT-RECORDS 56020000 LA RETURN,2(0,LENGTH) COMPUTE RETURN ADDRESS 56040000 LH LENGTH,0(0,LENGTH) LOAD LENGTH GIVEN IN CALL 56060000 LA TYPER,TXTT INDICATE TXT-CALL 56080000 SPACE 56100000 L OUTAREA,SAVOUTA LOAD ADDRESS OF OUT RECORD 56120000 CLC RTYP(3,OUTAREA),RTYP(TYPER) RECORD RIGTH TYPE 56140000 BNE GEN3 NO,CALL IOR NEW 56160000 CLC INFL(2,OUTAREA),RMAX(TYPER) RECORD FILLED 56180000 BNL GEN3 YES,CALL FOR NEW 56200000 SPACE 56220000 GEN6 LA L,56 56240000 LH REG0,INFL(0,OUTAREA) REG0=LENGTH OF INFORM IN REC 56260000 SR L,REG0 L=EMPTY POS LEFT IN RECORD 56280000 CR L,LENGTH ENOUTH SPACE LEFT 56300000 BL *+6 NO 56320000 LR L,LENGTH YES L=LENGTH FROM CALL 56340000 AR L,REG0 56360000 STH L,INFL(0,OUTAREA) INSERT NEW LENGTH INTO RECORD 56380000 SR L,REG0 56400000 AR OUTAREA,REG0 START ADDRESS WITHIN RECORD 56420000 SR LENGTH,L REMAINING LENGTH 56440000 B GEN8 GO TO MOVE TEXT 56460000 SPACE 56480000 GEN4 LTR LENGTH,LENGTH MORE INFORMATION MUST BE MOVED 56500000 BCR 8,RETURN NO, RETURN TO CALLING ROUTINE 56520000 SPACE 56540000 GEN3 EQU * CALL FOR NEW OUTPUT RECORD 56560000 ST LENGTH,SAVELT SAVE LENGTH 56580000 TM HCOMPMOD+1,X'60' Q. BOTH DECK AND LOAD SPECIFIED 56600000 BZ BOTH YES 56620000 TM HCOMPMOD+1,NDCK Q. ONLY DECK 56640000 L OUTAREA,PCHADD IF ONLY DECK 56660000 BZ PUT1 YES 56680000 L OUTAREA,LINADD ONLY SYSLIN 56700000 PUT1 PUT (OUTAREA) PUT FOR SYSLIN AND SYSPUNCH IF 56720000 ST OUTAREA,SAVOUTA ONLY SYSPUNCH SPECIFIED 56740000 L LENGTH,SAVELT RESTORE LENGTH 56760000 B PUNCHOUT 56780000 SAVELT DS F SAVE AREA FOR LENGTH 56800000 BOTH L LENGTH,OUTAREA2 COPY SYSLIN BUFFER TO SYSPUNCH 56820000 L OUTAREA,SAVOUTA 56840000 MVC 0(80,LENGTH),0(OUTAREA) BUFFER 56860000 L OUTAREA,PCHADD 56880000 PUT (OUTAREA) PUT FOR SYSPUNCH WHEN BOTH HAS 56900000 ST OUTAREA,OUTAREA2 BEEN SPECIFIED 56920000 B PUT1-4 GO TO PUT SYSLIN 56940000 SPACE 56960000 PUNCHOUT EQU * 56980000 MVC 0(4,OUTAREA),RSTART(TYPER) INSERT FIRST 4 BYTES 57000000 MVI 4(OUTAREA),C' ' INSERT ONE BLANK 57020000 MVC 5(67,OUTAREA),4(OUTAREA) BLANK OUTPUT RECORD 57040000 MVC 72(4,OUTAREA),PIDENT INSERT PROGRAM IDENT 57060000 L L,SEQU STEP SEQUENCE NUMBER 57080000 LA L,1(0,L) 57100000 ST L,SEQU 57120000 CVD L,ZPACK CONVERT TO DECIMAL 57140000 UNPK 76(4,OUTAREA),ZPACK+5(3) 57160000 MVZ 79(1,OUTAREA),76(OUTAREA) 57180000 MVC 10(2,OUTAREA),RLEN(TYPER) INSERT INITIAL LENGTH 57200000 MVC 14(6,OUTAREA),RESID(TYPER) INSERT ESID+R AND P 57220000 ST PRPOINT,4(0,OUTAREA) 57240000 MVI 4(OUTAREA),C' ' 57260000 B GEN6 57280000 SPACE 57300000 * TABLE AND MOVE ROUTINE 57320000 SPACE 57340000 TXTT DS 0H START OF TXT-RECORD TABLE 57360000 DC X'02' CARD CODE 57380000 DC C'TXT' IDENTIFICATION 57400000 DC H'0' INITIAL LENGTH 0 57420000 DC H'1' ESID 57440000 DC C' ' 57460000 DC H'56' MAXIMUM LENGTH 57480000 SPACE 57500000 GEN8 EQU * MOVE TXT-INFORMATION TO OUTAREA 57520000 BCTR L,0 L=L-1 57540000 STC L,*+5 INSERT PROPER LENGTH TO MOVE 57560000 MVC 16(0,OUTAREA),0(INFORM) MOVE INFORM TO OUTAREA 57580000 LA PRPOINT,1(L,PRPOINT) INCREASE PROGRAM POINTER 57600000 LA INFORM,1(L,INFORM) MODIFY DATA ADDRESS 57620000 B GEN4 OUT OF MOVE TXT ROUTINE 57640000 * ADDRESS DISPLACEMENTS FOR GENTXT 57660000 SPACE 57680000 RSTART EQU 0 START OF RECORD TYPE TABLE 57700000 RTYP EQU 1 RECORD IDENTIFICATION 57720000 RLEN EQU 4 INITIAL LENGTH 0 OR 4 57740000 RESID EQU 6 ESID OR BLANKS 57760000 RMAX EQU 12 MAXIMUM NUMBER OF BYTES IN REC 57780000 INFL EQU 10 LENGTH OF INFORM IN A RECORD 57800000 SPACE 57820000 * AREAS AND CONSTANTS LOCAL FOR GENTXT 57840000 SPACE 57860000 TXTSAV DS 9F REGISTER SAVE AREA 57880000 SPACE 57900000 EJECT 57920000 INTERUPT CLI 7(R1),X'0C' FLOATING POINT OVERFLOW 57940000 BE REALERR YES 57960000 L WORKR,OLDSPIE NO, USE DIRECTORY ROUTINE 57980000 L R15,0(0,WORKR) ADDRESS ERROR ROUTINE OF DIREC. 58000000 BR R15 ENTER ERROR ROUTINE 58020000 EJECT 58040000 WORKAREA DSECT 58060000 COPY WORKAREA 58080000 ZFOSTA EQU FSTAB 58100000 ORG DCBUT1 58120000 FSNMAX DS H 58140000 LVCOUNT DS H 58160000 SUCOUNT DS H 58180000 ZLEVEN DS F 58200000 ZSUTEN DS F 58220000 END START 58240000 ./ ADD SSI=01050762,NAME=IEX31,SOURCE=0 TITLE 'IEX31, ERROR MESSAGE EDITING' 00020000 * * 00040000 *STATUS: CHANGE LEVEL 000. * 00060000 * * 00080000 *FUNCTION/OPERATION: THE ERROR PATTERNS GENERATED DURING SCANIII ARE * 00100000 * HANDLED AND THE CORRESPONDING DIAGNOSTIC MESSAGES ARE GENERATED. * 00120000 * * 00140000 *ENTRY POINT: * 00160000 * IEX31000 - ERROR MESSAGE EDITING XCTL EP=IEX31 * 00180000 * THE MODULE IS ENTERED FROM IEX30. * 00200000 * * 00220000 *INPUT: N/A * 00240000 * * 00260000 *OUTPUT: THE DIAGNOSTIC MESSAGES ARE PUT OUT ON SYSPRINT. IF SYSPRINT * 00280000 * IS DOWN, THIS IS REPORTED ON THE CONSOLE TYPEWRITER. * 00300000 * * 00320000 *EXTERNAL ROUTINE: THE PRINT ROUTINE IN IEX00 IS USED. * 00340000 * * 00360000 *EXIT-NORMAL: IF NO TERMINATING ERROR HAS OCCURRED CONTROL IS GIVEN * 00380000 * TO THE NEXT PHASE BY MEANS OF XCTL EP=IEX40. * 00400000 * * 00420000 *EXIT-ERROR: IF A TERMINATING ERROR HAS OCCURRED (IN THIS MODULE OR * 00440000 * THE PRECEDING) CONTROL IS GIVEN TO THE TERMINATING MODULE BY MEANS* 00460000 * OF XCTL EP=51002. * 00480000 * * 00500000 *TABLES/WORKAREAS: THE MESSAGE TEXTS WITH CORRESPONDING ADDRESS TABLE * 00520000 * ARE IN THE LOAD MODULE IEX31M. * 00540000 * THE ERROR MESSAGE EDITING ROUTINE, CSECT IEX60000, ALSO USES THE * 00560000 * FOLLOWING TABLES: * 00580000 * WINTEBC FOR TRANSLATION OF INTERNAL CHARACTERS TO EBCDIC * 00600000 * WSYMBSRC FOR TRANSLATION OF * 00620000 * WSYMBSTK INTERNAL SYMBOLS TO EBCDIC * 00640000 * WORDSEBC FOR TRANSLATION OF COMPOUND SYMBOLS IF SOURCE IN EBCDIC * 00660000 * WORDSISO FOR TRANSLATION OF COMPOUND SYMBOLS IF SOURCE IN ISOCODE* 00680000 * WEBCDIC FOR TRANSLATION EBCDIC-EBCDIC * 00700000 * * 00720000 * A WORKAREA OF 270 BYTES, WAREA, IS USED FOR BUILDING THE MESSAGES.* 00740000 * * 00760000 *ATTRIBUTES: NONE. * 00780000 * * 00800000 *NOTES: CHARACTER CODE DEPENDENCE: FOR THE BUILDING OF A MESSAGE * 00820000 * (CODE PART BETWEEN COT03 AND COT12) THE FOLLOWING APPLIES: * 00840000 * IN CASE NO SOURCE INFORMATION IS TO BE INSERTED (COT31), OR IF * 00860000 * THE INFORMATION IS EBCDIC-CHARACTERS (COT07), THE OPERATION OF * 00880000 * CSECT IEX60000 DEPENDS UPON AN INTERNAL REPRESENTATION OF THE * 00900000 * EXTERNAL CHARACTER SET WHICH IS EQUIVALENT TO THE ONE USED AT * 00920000 * ASSEMBLY TIME. * 00940000 * IF THE SOURCE INFORMATION TO BE INSERTED IS INTERNAL CHARACTERS * 00960000 * (COT33) THE OPERATION OF CSECT IEX60000 DEPENDS UPON A TRANSLATION* 00980000 * FROM THE INTERNAL REPRESENTATION TO THE EBCDIC CHARACTER SET BY * 01000000 * MEANS OF THE TABLE 'WINTEBC'. * 01020000 * IF THE SOURCE INFORMATION TO BE INSERTED IS INTERNAL ALGOL SYMBOLS* 01040000 * (COT10) THE OPERATION OF CSECT IEX60000 DEPENDS UPON A TRANSLATION* 01060000 * FROM THE INTERNAL REPRESENTATION TO THE EBCDIC CHARACTER SET BY * 01080000 * MEANS OF THE TABLES 'WSYMBSTK'/'WSYMBSRC' AND 'WORDSISO'/ * 01100000 * 'WORDSEBC'. * 01120000 * FOR THE OUTPUT OF A MESSAGE (CODE PART BETWEEN COT12 AND COT21) * 01140000 * THE FOLLOWING APPLIES: * 01160000 * WHEN A MESSAGE HAS BEEN BUILT IN EBCDIC, AN EBCDIC-EBCDIC TRANSLA-* 01180000 * TION IS PERFORMED BEFORE OUTPUT BY MEANS OF THE TABLE 'WEBCDIC'. * 01200000 * THUS THE OUTPUT MAY BE MODIFIED BY MAKING CHANGES IN THIS TABLE. * 01220000 * * 01240000 * THE OPERATION OF CSECT IEX31000 DOES NOT DEPEND UPON A PARTICULAR * 01260000 * INTERNAL REPRESENTATION OF THE EXTERNAL CHARACTER SET. * 01280000 * * 01300000 * AT SYSTEM GENERATION THIS MODULE WILL BE LINKED TOGETHER WITH * 01320000 * THE MODULE IEX31M TO FORM THE MODULE IEX31 IN LINKLIB. * 01340000 * * 01360000 * THIS MODULE IS ONLY INTENDED TO BE EXECUTED IN CONNECTION * 01380000 * WITH THE OTHER MODULES OF THE ALGOL COMPILER. IN PARTICULAR IT * 01400000 * REQUIRES THE COMMON WORKAREA. * 01420000 * * 01440000 EJECT 01460000 IEX31000 CSECT 01480000 SPACE 01500000 * REGISTER DEFINITIONS 01520000 SPACE 01540000 RINFO EQU 1 01560000 RCOT EQU 2 01580000 RET EQU 14 01600000 RENT EQU 15 01620000 SPACE 2 01640000 USING *,RENT 01660000 SPACE 01680000 L RCOT,=A(IEX60000) ADDRESS ERROR MSG EDIT ROUTINE 01700000 LA RET,SUSCR LOAD RETURN ADDRESS 01720000 LA RINFO,ERRINFO ADDRESS INFO FOR ERROR ED ROUT 01740000 BR RCOT GO TO ERROR MESSAGE EDITING 01760000 SPACE 01780000 DS 0F 01800000 SUSCR EQU * INITIALIZATION OF SUBSCR HANDLING 01820000 SPACE 01840000 XCTL EP=IEX40000 01860000 SPACE 2 01880000 ERRINFO DC V(IEX31M00) ADDRESS OF MESSAGE TEXTS 01900000 DC V(IEX31M01) ADDRESS OF ADDRESS-TABLE 01920000 DC H'119' MODIFICATION NUMBER 01940000 LTORG 01960000 EJECT 01980000 COPY IEX60000 02000000 EJECT 02020000 WORKAREA DSECT 02040000 COPY WORKAREA 02060000 END 02080000 ./ ADD SSI=00055223,NAME=IEX31M,SOURCE=0 TITLE 'IEX31M, ERROR MESSAGE TEXT POOL 2' 00020000 * * 00040000 *STATUS: CHANGE LEVEL 000. * 00060000 * * 00080000 *FUNCTION/OPERATION: THIS MODULE CONTAINS MESSAGE TEXTS FOR ALL * 00100000 * ERRORS THAT MAY BE DETECTED BY IEX00 AND IEX30, AND THE CORRE- * 00120000 * SPONDING ADDRESS TABLE. * 00140000 * * 00160000 *ENTRY POINT: N/A. * 00180000 * * 00200000 *INPUT: N/A. * 00220000 * * 00240000 *OUTPUT: N/A. * 00260000 * * 00280000 *EXTERNAL ROUTINES: N/A. * 00300000 * * 00320000 *EXITS-NORMAL: N/A. * 00340000 * * 00360000 *EXITS-ERROR: N/A. * 00380000 * * 00400000 *TABLES/WORKAREAS: N/A. * 00420000 * * 00440000 *ATTRIBUTES: N/A. * 00460000 * * 00480000 *NOTES: AT SYSTEM GENERATION THIS MODULE WILL BE LINKED TOGETHER WITH * 00500000 * THE MODULE IEX31 TO FORM THE MODULE IEX31 IN LINKLIB. * 00520000 * * 00540000 IEX31M00 CSECT 00560000 SPACE 00580000 ENTRY IEX31M01 00600000 SPACE 00620000 WEMPOOL2 EQU * ERROR MESSAGE POOL 2 00640000 SPACE 00660000 W080 DC X'3E0300160C240023001B23' 00680000 DC CL52'SOPERAND BEGINNING WITH IS SYNTACTICALLY INCORRECTX00700000 .' 00720000 W081 DC X'2403000A0C240017000D17' 00740000 DC CL26'SIDENTIFIER NOT DECLARED.' 00760000 W082 DC X'3603001C0C240029000D29' 00780000 DC CL44'SREAL CONSTANT BEGINNING WITH OUT OF RANGE.' 00800000 W083 DC X'5A05001612240029001E29F00000001149' 00820000 DC CL74'WINTEGER BEGINNING WITH OUT OF RANGE. INTEGER CONSX00840000 TANT CONVERTED TO REAL.' 00860000 W084 DC X'750500291224003C00083CF00000003045' 00880000 DC CL101'WPRECISION OF REAL CONSTANT BEGINNING WITH EXCEEDX00900000 S INTERNALLY HANDLED PRECISION. CONSTANT TRUNCATED.' 00920000 W085 DC X'210300140C240021000021' 00940000 DC CL23'SILLEGAL USE OF LABEL .' 00960000 W086 DC X'1500' 00980000 DC CL20'STOO MANY CONSTANTS.' 01000000 W087 DC X'3A00' 01020000 DC CL57'WFULL OPTIMIZATION NOT POSSIBLE DUE TO INTERNAL OVEX01040000 RFLOW.' 01060000 W088 DC X'8805000A1224001C002C1DF00000003D4B' 01080000 DC CL120'WIDENTIFIER IN BOUND EXPRESSION DECLARED IN SAME X01100000 PROGRAM BLOCK AS ARRAY. DECLARATION IN SURROUNDING BLOCKX01120000 SEARCHED FOR.' 01140000 W089 DC X'450300040C240011003411' 01160000 DC CL59'WGOTO INVALID OUTSIDE FOR STATEMENT CONTAINING THIX01180000 S LABEL.' 01200000 SPACE 01220000 * 01240000 * DIRECTORY MESSAGES 01260000 * 01280000 SPACE 01300000 W090 EQU * 01320000 W209 EQU * 01340000 DC X'460400360FF00000840046000046' 01360000 DC CL57'TCOMPILATION UNSUCCESSFUL DUE TO PROGRAM INTERRUPT.X01380000 PSW .' 01400000 W091 EQU * 01420000 W210 EQU * 01440000 DC X'300300270C840030000030' 01460000 DC CL38'TUNRECOVERABLE I/O ERROR ON DATA SET .' 01480000 W092 EQU * 01500000 W211 EQU * 01520000 DC CL56'PROGRAM INTERRUPT IN ERROR MESSAGE EDITING ROUTINE.X01540000 PSW ' 01560000 W093 EQU * 01580000 W212 DC X'1200' 01600000 DC CL17'TTOO MANY ERRORS.' 01620000 W094 EQU * 01640000 W213 DC X'2800' 01660000 DC CL39'TINTERNAL OVERFLOW OF IDENTIFIER TABEL.' 01680000 W095 EQU * 01700000 W215 EQU * 01720000 DC X'1A00' 01740000 DC CL25'TSOURCE PROGRAM TOO LONG.' 01760000 EJECT 01780000 DS 0F 01800000 SPACE 2 01820000 IEX31M01 EQU *-320 ADDRESS TABLE FOR WEMPOOL2 01840000 SPACE 01860000 DC A(W080) 01880000 DC A(W081) 01900000 DC A(W082) 01920000 DC A(W083) 01940000 DC A(W084) 01960000 DC A(W085) 01980000 DC A(W086) 02000000 DC A(W087) 02020000 DC A(W088) 02040000 DC A(W089) 02060000 DC A(W090) 02080000 DC A(W091) 02100000 DC A(W092) 02120000 DC A(W093) 02140000 DC A(W094) 02160000 DS F 02180000 DC A(W095) 02200000 END 02220000 ./ ADD SSI=01010770,NAME=IEX40,SOURCE=0 TITLE 'IEX40, SUBSCRIPT HANDLING AND INITIALIZATION OF COMPILATION PHAX00020000 SE' 00040000 * * 00060000 *STATUS: CHANGE LEVEL 000. * 00080000 * * 00100000 *FUNCTION/OPERATION: CSECT IEX40000 BUILDS THE OPTIMIZATION TABLE * 00120000 * (OPTAB) USING THE SUBSCRIPT TABLE, THE LEFT VARIABLE TABLE AND * 00140000 * THE FOR STATEMENT TABLE. AN OPTAB ENTRY "ORRESPOND TO AN OPTIMI- * 00160000 * ZABLE SUBSCRIPT EXPRESSION INSIDE A FORSTATEMENT. IF NO OPTAB IS * 00180000 * PRODUCED THIS IS INDICATED IN THE COMPILER STATUS BYTES * 00200000 * (HCOMPMOD). * 00220000 * CSECT IEX40001 IS THE INITIALIZATION OF NEXT MODULE, IEX50, AND * 00240000 * PERFORMS THE FOLLOWING FUNCTIONS: CALCULATION AND RESERVATION OF * 00260000 * CORE STORAGE AREAS NEEDED, LOADING REGISTERS WITH START ADDRESSES,* 00280000 * READING THE FIRST RECORDS OF SOURCE PROGRAM AND OPTAB, AND SETTING* 00300000 * INITIAL VALUES IN THE PRIVATE PART OF COMMON WORKAREA. * 00320000 * * 00340000 *ENTRY POINT: * 00360000 * IEX40000. * 00380000 * * 00400000 *INPUT: CSECT IEX40000 READS TWO TABLES CONSTRUCTED IN IEX30 FROM * 00420000 * SYSUT3. THE SUBSCRIPT TABLE (SUTAB) CONTAINS ENTRIES FOR LINEAR * 00440000 * SUBSCRIPT EXPRESSIONS IN FOR STATEMENTS THAT ARE OPTIMIZABLE IN * 00460000 * REGARD TO SUBSCRIPTS. * 00480000 * THE LEFT VARIABLE TABLE (LVTAB) CONTAINS ENTRIES FOR INTEGER LEFT * 00500000 * VARIABLES IN FOR STATEMENTS THAT ARE OPTIMIZABLE IN REGARD TO * 00520000 * SUBSCRIPTS. * 00540000 * CSECT IEX40001 READS THE FIRST TWO RECORDS OF THE SOURCE PROGRAM * 00560000 * FROM SYSUT2 INTO TWO SOURCE BUFFERS. * 00580000 * THE FIRST TWO RECORDS OF OPTAB ARE READ IN FROM SYSUT3 TO TWO * 00600000 * OPTAB BUFFERS. * 00620000 * * 00640000 *OUTPUT: THE OPTIMIZATION TABLE (UPTAB)IS WRITTEN OUT ON SYSUT3. OPTAB* 00660000 * CONTAINS ONE ENTRY FOR EVERY OPTIMIZABLE SUBSCRIPT EXPRESSION IN * 00680000 * A FOR STATEMENT * 00700000 * * 00720000 *EXTERNAL ROUTINES: THE INTERRUPT ROUTINES OF IEX00 ARE USED. * 00740000 * * 00760000 *EXIT-NORMAL: CONTROL IS GIVEN TO THE NEXT LOAD MODULE BY MEANS OF * 00780000 * XCTL EP=IEX50. * 00800000 * * 00820000 *EXITS-ERROR: INPUT/OUTPUT ERRORS AND PROGRAM INTERRUPTS ARE HANDLED * 00840000 * BY A DIRECTORY ROUTINE WHICH RETURNS CONTROL TO THE INTERRUPTED * 00860000 * MODULE. IF THE ERROR OCCURED BEFORE THE GETMAIN IN IEX40001 * 00880000 * CONTROL IS GIVEN TO THE \ERMINATING MODULE BY MEANS OF * 00900000 * XCTL EP=IEX51ER2. * 00920000 * IF THE ERROR OCCURED AFTER THE GETMAIN CONTROL IS GIVEN TO THE * 00940000 * TERMINATING MODULE BY MEANS OF * 00960000 * XCTL EP=IEX51ER1. * 00980000 * * 01000000 *TABLES/WORKAREAS: THE FOR STATEMENT TABLE (FSTAB) CONSTRUCTED IN * 01020000 * IEX30 AND POSSIBLY REVISED BY IEX40000 CONTAINS CLASSIFICATIONS * 01040000 * OF THE FOR STATEMENTS. * 01060000 * * 01080000 *ATTRIBUTES: NONE. * 01100000 * * 01120000 *NOTES: THE OPERATION OF THIS MODULE DOES NOT DEPEND UPON ANY SPECIAL * 01140000 * REPRESENTATION OF THE EXTERNAL CHARACTER SET. * 01160000 * THIS MODULE IS ONLY INTENDED TO BE EXECUTED IN CONNECTION * 01180000 * WITH THE OTHER MODULES OF THE ALGOL COMPILER. IN PARTICULAR IT * 01200000 * REQUIRES THE COMMON WORKAREA. * 01220000 * * 01240000 EJECT 01260000 R0 EQU 0 01280000 R1 EQU 1 01300000 R2 EQU 2 01320000 R3 EQU 3 01340000 R4 EQU 4 01360000 R5 EQU 5 01380000 R6 EQU 6 01400000 R7 EQU 7 01420000 R8 EQU 8 01440000 R9 EQU 9 01460000 R10 EQU 10 01480000 R11 EQU 11 01500000 R12 EQU 12 01520000 R13 EQU 13 01540000 R14 EQU 14 01560000 R15 EQU 15 01580000 WORKR EQU R2 01600000 WORKX EQU R3 01620000 SPACE 01640000 * BIT PATTERNS 01660000 FIRSTM EQU X'20' FIRST ENTRY IN SUTAB CHAIN 01680000 SUCM EQU X'10' SUCCEDING ENTRY IN SUTAB CHAIN 01700000 LASTM EQU X'30' LAST ENTRY IN SUTAB CHAIN 01720000 OFFM EQU X'CF' TURN OFF SUTAB CHAIN BITS 01740000 SUOP EQU X'40' SUBSCRIPT OPTIMIZATION BIT 01760000 NOOP EQU X'20' NO SUBSCRIPT OPTIMIZATION 01780000 SYNTAX EQU X'80' SYNTAX CHEXK MASK 01800000 EJECT 01820000 IEX40000 CSECT 01840000 * RELEASE 19 CHANGES A27002 01846019 * 020800,056000,068800 A27002 01852019 START BALR R12,0 01860000 USING *,R12 01880000 USING WORKAREA,R13 01900000 TM HCOMPMOD,SYNTAX SYNTAX CHECK MODE 01920000 BO NOSUTAB YES 01940000 SPACE 01960000 * INITILIZE SUTAB 01980000 SPACE 02000000 SPACE 02020000 CLC ZSUTEN(4),ZERO SUTAB EMPTY 02040000 BE NOSUTAB YES 02060000 * A27002 02061019 * ANY NESTED FOR LOOPS A27002 02062019 * A27002 02063019 SR WORKR,WORKR A27002 02064019 ST WORKR,FOR1 A27002 02065019 MVC FOR1+4(255),FOR1+3 SET FOR STMNT COUNT A27002 02066019 MVC FOR2+2(255),FOR2+1 AREAS TO ZERO A27002 02067019 LH R0,FSNMAX A27002 02068019 AH R0,FOR5 NO OF FOR STMNT A27002 02069019 LA R1,GPTAB A27002 02070019 GP1 LA R1,3(0,R1) PTR TO NEXT GPTAB RECORD A27002 02071019 CLC ZERO(1),2(R1) FOR STATEMENT? A27002 02072019 BE GP1 NO A27002 02073019 SH R0,FOR5 ALL FOR STMNT CHECKED? A27002 02074019 BM GP10 YES A27002 02075019 MVC FOR4(3),0(R1) MOVE GPTAB RECORD A27002 02076019 LH WORKX,FOR4 MULTIPLY GPTAB PTR BY 3 A27002 02077019 AR WORKX,WORKX GIVES CORRECT ADDRESS A27002 02078019 AH WORKX,FOR4 IN GPTAB A27002 02079019 LA WORKX,GPTAB(WORKX) A27002 02080019 CLC ZERO(1),2(WORKX) Q. NESTED A27002 02081019 BE GP1 NO A27002 02082019 IC WORKR,FOR4+2 FOR STMNT NO+1 A27002 02083019 LA R4,FOR2-1(WORKR) A27002 02084019 MVC 0(1,R4),2(WORKX) STORE ENCLOSING FSN A27002 02085019 B GP1 A27002 02086019 SPACE 1 02087019 GP10 LA WORKR,TERMIN2 TERMINATION ADDRESS A27002 02088019 ST WORKR,ERET 02100000 L R0,SUTAB40S RESERVE TABLE AREA 02120000 A R0,OPTABS 02140000 AR R0,R0 02160000 AH R0,EIGHT 02180000 ST R0,TABSIZE SAVE LENGTH OF TABLE AREA 02200000 GETMAIN R,LV=(0) ALLOCATE STORAGE TO SUTAB 02220000 LA WORKR,TERM1 ERROR RETURN ADDRESS 02240000 ST WORKR,ERET 02260000 ST R1,TSTART SUTAB START ADDRESS 02280000 SPACE 02300000 * READ SUTAB 02320000 SPACE 02340000 LH RCOUNT,SUCOUNT NUMBER OF SUTAB RECORDS - 1 02360000 L RTYPE,SUTYPE SUTAB RECORD IDENTIFICATION 02380000 L RLE,SUTAB30S LENGTH OF WRITTEN SUTAB RECORDS 02400000 L RSTART,TSTART TABLE START ADDRESS 02420000 BAL READX,READ READ FULL SUTAB 02440000 EJECT 02460000 RSUDEN EQU R11 END ADDRESS OF UNSORTED SUTAB 02480000 RFSN EQU R10 FOR STATEMENT NUMBER 02500000 RSEARCH EQU R9 CURRENT PTR IN UNSORTED SUTAB 02520000 RS EQU R8 PTR FOR CHAINING CHECK 02540000 RFALL EQU R7 FULL LENGTH OF DELETED ENTRIES 02560000 SPACE 02580000 * SCAN SUTAB FOR ENTRY CHAINING AND ENTRY DELETION 02600000 SPACE 02620000 L RSEARCH,TSTART TABLE START ADDRESS WITH KEY 02640000 LA RSEARCH,4(0,RSEARCH) DELETE KEY 02660000 LR RSUDEN,RSEARCH CLACULATE END.ADDRESS 02680000 A RSUDEN,ZSUTEN 02700000 SR RFSN,RFSN 02720000 SR RFALL,RFALL 02740000 SPACE 02760000 SUTABS IC RFSN,0(0,RSEARCH) ISOLATE ACTUELL FOR STATEM.NUMB 02780000 LA WORKR,FSTAB(RFSN) ADDRESS ACRUELL FOR ENTRY 02800000 TM 0(WORKR),SUOP SUBSCRIPT OPTIMIZATION POSSIBLE 02820000 BZ SUTABS2 YES 02840000 LA RFALL,14(0,RFALL) LENGTH OF DELETED ENTRIES 02860000 MVI 0(RSEARCH),X'FF' NOT OPTIMIZABLE ENTRY 02880000 LA RSEARCH,14(0,RSEARCH) GET NEXT ENTRY 02900000 CR RSEARCH,RSUDEN SUTAB END 02920000 BE SORTSU YES 02940000 B SUTABS 02960000 SPACE 02980000 SUTABS2 LR RS,RSEARCH CHECK ENTRY CHAINING 03000000 SUTABS3 EQU * 03020000 LA RS,14(0,RS) SCAN SUTAB FOWORD FOR CHAINING 03040000 CR RS,RSUDEN SUTAB END 03060000 BE SORTSU YES 03080000 CLC 10(4,RSEARCH),10(RS) CHAIN 03100000 BE SUTABS4 YES 03120000 LR RSEARCH,RS PROCESS NEW ENTRY AS FIRST 03140000 B SUTABS 03160000 SPACE 03180000 SUTABS4 IC RFSN,0(0,RS) ISOLATE FSN OF NEW ENTRY 03200000 LA WORKR,FSTAB(RFSN) ADDRESS FSTAB ENTRY 03220000 TM 0(WORKR),SUOP SUBSCRIPT OPTIMIZABLE 03240000 BZ SUTABS5 YES 03260000 MVI 0(RS),X'FF' NO, DELETE ENTRY 03280000 LA RFALL,14(0,RFALL) COUNT LENGTH OF DELETED ENTRIES 03300000 B SUTABS3 CHECK NEXT ENTRY 03320000 SPACE 03340000 SUTABS5 OI 10(RSEARCH),FIRSTM INDICATE FIRST ENTRY IN CHAIN 03360000 SUTABS6 LR RSEARCH,RS ADDRESS CURRENT LAST CHAIN ENTR 03380000 SUTABS7 EQU * 03400000 LA RS,14(0,RS) CHECK NEXT SUTAB ENTRY 03420000 CR RS,RSUDEN SUTAB END 03440000 BE SUTABS9 YES 03460000 CLC 10(4,RSEARCH),10(RS) ANOTHER CHAINED ENTRY 03480000 BE SUTABS8 YES 03500000 OI 10(RSEARCH),LASTM INDICATE ENTRY IN CHAEN 03520000 LR RSEARCH,RS PROCESS NEW ENTRY AS FIRST 03540000 B SUTABS 03560000 SPACE 03580000 SUTABS8 IC RFSN,0(0,RS) NEW FOR STATEMENT NUMBER 03600000 LA WORKR,FSTAB(RFSN) ADDRESS FSTAB ENTRY 03620000 TM 0(WORKR),SUOP SUBSCRIPT OPTIMIZATION POSSIBLE 03640000 BZ SUTABS10 YES, CHAIN 03660000 SPACE 03680000 MVI 0(RS),X'FF' DELETE ENTRY 03700000 LA RFALL,14(0,RFALL) CALCULATE DELETED LENGTH 03720000 B SUTABS7 03740000 SPACE 03760000 SUTABS9 OI 10(RSEARCH),LASTM INDICATE LAST ENTRY IN CHAIN 03780000 B SORTSU 03800000 SPACE 03820000 SUTABS10 OI 10(RSEARCH),SUCM INDICATE BETWEEN ENTRY 03840000 B SUTABS6 03860000 SPACE 03880000 SORTSU EQU * 03900000 L WORKX,TSTART 03920000 LA WORKR,4(0,WORKX) START ADDRESS OF UNSORTED SUTAB 03940000 ST WORKR,ZSTAD START OF UNSORTED TABLE 03960000 L REND,ZSUTEN GET END OF UNSORTED SUTAB 03980000 AR REND,WORKR 04000000 A WORKX,TABSIZE END ADDRESS OF SORTED SUTAB 04020000 ST WORKX,ZSUDEN 04040000 S WORKX,ZSUTEN 04060000 AR WORKX,RFALL START OF SORTED SUTAB 04080000 C WORKX,ZSUDEN WHOLE SUTAB DELETED 04100000 BE NOSUTAB1 YES 04120000 ST WORKX,ZSUDAD 04140000 ST WORKX,ZSORTSTA 04160000 LA RENTRY,14 ENTRY LENGTH 04180000 BAL SORTX,SORT SORT SUTAB 04200000 SPACE 04220000 * INITILIZE OPTAB BUFFERS 04240000 L WORKR,TSTART 04260000 ST WORKR,ZOTAWRI SECOND OPTAB BUFFER 04280000 A WORKR,OPTABS 04300000 ST WORKR,ZOTAFILL FIRST OPTAB BUFFER 04320000 A WORKR,OPTABS 04340000 ST WORKR,ZOTMAX ACTUELL BUFFER END 04360000 SPACE 04380000 CLC ZLEVEN(4),ZERO LVTAB EMPTY 04400000 BNE SORTLE NO 04420000 MVC ZLESTA(4),ZOTMAX SET DUMMY START ADDRESS 04440000 B SORTLE1 04460000 SPACE 04480000 SORTLE EQU * 04500000 LH RCOUNT,LVCOUNT NUMBER OF LVTAB RECORDS -7 04520000 L RTYPE,LVTYPE LVTAB-RECORD IDENTIFICATION 04540000 L RLE,LVTAB30S LENGTH OF LVTAB RECORD 04560000 L RSTART,TSTART START ADDRESS OF TABLE AREA 04580000 BAL READX,READ READ LVTAB INTO CORE 04600000 SPACE 04620000 L WORKR,TSTART 04640000 LA WORKR,4(0,WORKR) 04660000 ST WORKR,ZSTAD START ADDRESS OF UNSORTED TABLE 04680000 A WORKR,ZLEVEN 04700000 LR REND,WORKR END OF UNSORTED TABLE 04720000 C WORKR,ZOTMAX LVTAB LONGER THAN OPTAB BUFFER 04740000 BH *+8 YES 04760000 L WORKR,ZOTMAX NO,START SORTED TAB AFTER OPTAB 04780000 ST WORKR,ZSORTSTA START ADDRESS OF SORTED TABLE 04800000 ST WORKR,ZLESTA 04820000 LA RENTRY,4 ENTRY LENGTH 04840000 BAL SORTX,SORT SORT LVTAB 04860000 SPACE 04880000 SORTLE1 L WORKR,ZLESTA 04900000 A WORKR,ZLEVEN 04920000 MVI 0(WORKR),X'FF' SET LVTAB END 04940000 SPACE 04960000 L WORKR,UT3ADD 04980000 CLOSE ((WORKR),REREAD),TYPE=T POINT TO BEGINNING OF DATA SET 05000000 SPACE 05020000 RLV EQU R4 PTR TO START OF LVTAB GROUP 05040000 RL EQU R5 CURRENT PTR IN LVTAB GROUP 05060000 RSUPO EQU R6 CURRENT SUTAB PTR 05080000 RSU EQU R7 SUTAB CHAIN SEARCHING PTR 05100000 ROTPO EQU R8 CURRENT OPTAB BUFFER PTR 05120000 OTACHAX EQU R9 05140000 OPTAB EQU * 05160000 L RLV,ZLESTA START OF LVTAB 05180000 L RSUPO,ZSUDAD START OF SUTAB 05200000 L ROTPO,ZOTAFILL START OF FIRST OPT AB BUFFER 05220000 SPACE 05240000 OPT1 EQU * 05260000 * DOES LVTAB-GROUP CORRESPOND TO THIS SUTAB ENTRY 05280000 CLC 0(1,RSUPO),0(RLV) 05300000 BL OPT3 NO LVTAB-ENTRIES TO THIS FOR-ST 05320000 LR RL,RLV INITILIZE CURRENT GROUP PTR 05340000 BH OPT6 SCAN FOR NEXT LVTAB GROUP 05360000 OPT2 CLC 1(3,RL),4(RSUPO) CHECK FACTOR 05380000 BE OPT71 NO OPTIMIZATION 05400000 CLC 1(3,RL),7(RSUPO) CHECK ADDEND 05420000 BE OPT7 NO OPTIMIZATION 05440000 LA RL,4(0,RL) ADDRESS NEXT LVTAB ENTRY 05460000 CLC 0(1,RL),0(RLV) NEW ENTRY OF SAME GROUP 05480000 BE OPT2 YES, PROCEED CHECK 05500000 SPACE 05520000 OPT3 C ROTPO,ZOTMAX END OF OPTAB BUFFER 05540000 BNL OPT10 YES 05560000 OPT4 MVC 0(14,ROTPO),0(RSUPO) MOVE SUTAB ENTRY TO OPTAB 05580000 SR R2,R2 A27002 05582019 IC R2,0(0,ROTPO) FOR STATEMENT NO A27002 05584019 SR R0,R0 A27002 05586019 OPT42 IC R0,FOR1(R2) FOR STATEMENT COUNT A27002 05588019 AH R0,FOR5 INCREASE FS COUNT A27002 05590019 CL R0,FOR3 >85 ENTRIES IN OPTAB A27002 05592019 BL OPT44 NO A27002 05594019 LA R1,FSTAB(R2) A27002 05596019 OI 0(R1),X'80' SET ELEMENTARY LOOP A27002 05598019 OPT44 STC R0,FOR1(R2) RESTORE FSN COUNT A27002 05600019 IC R2,FOR2(R2) A27002 05602019 CL R2,ZERO ANY ENCLOSING FOR STMT A27002 05604019 BE OPT46 NO A27002 05606019 SH R2,FOR5 GIVES CORRECT FSN A27002 05608019 B OPT42 ADD UP ENCLOSING LOOP A27002 05610019 OPT46 LA ROTPO,14(0,ROTPO) UPDATE OPTAB PTR A27002 05612019 OPT5 LA RSUPO,14(0,RSUPO) GET NEXT SUTAB ENTRY 05620000 C RSUPO,ZSUDEN SUTAB END 05640000 BE TERMIN YES 05660000 TM 10(RSUPO),SUCM ACTIVE ENTRY 05680000 BZ OPT1 YES 05700000 B OPT5 NO, GET NEXT ENTRY 05720000 SPACE 05740000 OPT6 EQU * SCAN FOR NEXT LVTAB GROUP 05760000 LA RL,4(0,RL) GET NEXT LVTAB ENTRY 05780000 CLC 0(1,RL),0(RLV) SAME GROUP 05800000 BE OPT6 YES 05820000 LR RLV,RL NO, SET LVTAB GROUP PTR 05840000 B OPT1 05860000 SPACE 05880000 OPT7 EQU * 05900000 CLC 4(3,RSUPO),ZERO FACTOR ZERO 05920000 BE OPT72 YES 05940000 OPT71 SR WORKR,WORKR ADDRESS FSTAB ENTRY 05960000 IC WORKR,0(0,RSUPO) 05980000 LA WORKR,FSTAB(WORKR) 06000000 OI 0(WORKR),X'80' SET ELEMENTARY LOOP 06020000 SPACE 06040000 OPT72 EQU * HANDLE SUTAB CHAINING 06060000 TM 10(RSUPO),FIRSTM ANY CHAINING 06080000 BZ OPT5 06100000 LR RSU,RSUPO INITILIZE CHAIN SZARCH 06120000 OPT8 LA RSU,14(0,RSU) NEXT SUTAB ENTRY 06140000 CLC 11(3,RSU),11(RSUPO) ENTRY IN CHAIN 06160000 BNE OPT8 NO 06180000 MVN SUPOS(1),10(RSU) SUBSCRIPT NUMBER 06200000 MVN *+7(1),10(RSUPO) SUBSCRIPT NUMBER 06220000 CLI SUPOS,X'00' SUBSCRIPT NUMBER EQUAL 06240000 BNE OPT8 NO 06260000 SPACE 06280000 TM 10(RSU),LASTM LAST ENTRY IN CHAIN 06300000 BO OPT9 YES 06320000 NI 10(RSU),OFFM TURN OFF CHAIN BITS 06340000 OI 10(RSU),FIRSTM SET FIRST ENTRY BIT 06360000 B OPT5 06380000 SPACE 06400000 OPT9 NI 10(RSU),OFFM TURN OFF CHAIN BITS 06420000 B OPT5 06440000 SPACE 06460000 OPT10 BAL OTACHAX,OTACHA CHANGE OPTAB BUFFER 06480000 B OPT4 06500000 SPACE 06520000 TERMIN EQU * 06540000 C ROTPO,ZOTAFILL ANY OPTAB 06560000 BNE *+12 YES 06580000 OI HCOMPMOD+2,NOOP NO OPTAB PRESENT 06600000 B TERM1 06620000 SPACE 06640000 C ROTPO,ZOTMAX END OF OPTAB BUFFER 06660000 BNE TERMIN1 NO 06680000 BAL OTACHAX,OTACHA CHANGE OUTPUT BUFFER 06700000 TERMIN1 MVI 0(ROTPO),X'FF' INDICATE END OF SUTAB 06720000 BAL OTACHAX,OTACHA WRITE LAST OPTAB RECORD 06740000 CHECK OWRITE CHECK LAST OPTAB RECORD 06760000 SPACE 06780000 L R0,UT3ADD DCB ADDRESS 06800000 CLOSE ((R0),REREAD),TYPE=T POINT TO BEGINNING OF DATASET 06820000 SPACE 06840000 SPACE 1 06841019 TERM1 LH R4,FSNMAX A27002 06842019 SR R3,R3 A27002 06843019 SR R1,R1 A27002 06844019 TERM12 LA R1,1(0,R1) A27002 06845019 CLR R1,R4 ALL FOR STMNT CHECKED A27002 06846019 BH TERM15 YES A27002 06847019 LA R2,FOR2(R1) A27002 06848019 CLC ZERO(1),0(R2) ANY ENCLOSING LOOP? A27002 06849019 BE TERM12 NO A27002 06850019 IC R3,0(R2) GET NO OF OPTAB ENTRIES A27002 06851019 SR R2,R2 A27002 06852019 IC R2,FOR1-1(R3) IN ENCLOSING LOOP A27002 06853019 CL R2,FOR3 MORE THAN 85 A27002 06854019 BL TERM12 NO A27002 06855019 LA R2,255 MARK FOR SUCCEDING FS A27002 06856019 STC R2,FOR1(R1) THAT THIS FS IS ELEMEN. A27002 06857019 LA R2,FSTAB(R1) A27002 06858019 OI 0(R2),X'80' SET ELEMENTARY LOOP A27002 06859019 B TERM12 A27002 06860019 SPACE 1 06861019 TERM15 L R0,TABSIZE LENGTH OF TABLE AREA A27002 06862019 L R0,TABSIZE LENGTH OF TABLE AREA 06880000 L R1,TSTART 06900000 FREEMAIN R,LV=(0),A=(1) 06920000 SPACE 06940000 TERMIN2 EQU * 06960000 TM HCOMPMOD,ERR ERROR CONDITION 06980000 BO TERMERR YES 07000000 L R12,VSEC1 ADDRESS OF NEXT CSECT 07020000 BR R12 07040000 SPACE 07060000 TERMERR EQU * 07080000 XCTL EP=IEX51ER2 07100000 SPACE 07120000 NOSUTAB EQU * 07140000 OI HCOMPMOD+2,NOOP NO SUBSCRIPT OPTIMIZATION BIT 07160000 B TERMIN2 07180000 SPACE 07200000 NOSUTAB1 EQU * 07220000 OI HCOMPMOD+2,NOOP NO OPTAB BIT 07240000 B TERM1 07260000 EJECT 07280000 OTACHA EQU * 07300000 B OTACHA2 FIRST TIME SWITCH 07320000 CHECK OWRITE 07340000 OTACHA1 EQU * 07360000 L R0,UT3ADD DCB ADDRESS 07380000 L WORKR,ZOTAFILL ADDRESS OF BUFFER TO WRITE 07400000 L WORKX,OPTABS SIZE OF OPTAB BUFFER 07420000 WRITE OWRITE,SF,(R0),(WORKR),(WORKX) 07440000 L ROTPO,ZOTAWRI CHANGE OPTAB BUFFERS 07460000 MVC ZOTAWRI(4),ZOTAFILL 07480000 ST ROTPO,ZOTAFILL 07500000 LR WORKR,ROTPO 07520000 A WORKR,OPTABS BUFFER END ADDRESS 07540000 ST WORKR,ZOTMAX 07560000 BR OTACHAX 07580000 OTACHA2 MVI OTACHA+1,X'00' SET OFF FIRST TIME SWITCH 07600000 B OTACHA1 07620000 SPACE 3 07640000 RSTART EQU R11 START ADDRESS OF INPUT AREA 07660000 RCOUNT EQU R10 RECORD COUNT 07680000 RTYPE EQU R9 RECORD IDENTIFICATION 07700000 RLE EQU R8 RECORD LENGTH 07720000 READX EQU R7 RETURN REGISTER 07740000 READ EQU * 07760000 L R1,UT3ADD DCB ADDRESS 07780000 MVI SULTSTRT+3,X'01' ADDRESS FIRST INPUT RECORD 07800000 POINT (1),SULTSTRT 07820000 SPACE 07840000 READ1 L WORKR,UT3ADD DCB ADDRESS 07860000 READ READR,SF,(WORKR),(RSTART),'S' 07880000 CHECK READR 07900000 C RTYPE,0(0,RSTART) 07920000 BNE READ1 07940000 SPACE 07960000 MVC 0(4,RSTART),SAVETAB RESTORE OVERLAYED PART 07980000 BCT RCOUNT,READ2 MORE RECORDS TO READ 08000000 BR READX NO 08020000 SPACE 08040000 READ2 AR RSTART,RLE UPDATE CURRENT PT2 08060000 MVC SAVETAB(4),0(RSTART) 08080000 B READ1 08100000 SPACE 3 08120000 RENTRY EQU R11 LENGTH OF TABLE ENTRY 08140000 RPO EQU R10 CURRENT PTR IN UNSORTED TABLE 08160000 REND EQU R9 END OF UNSORTED TABLE 08180000 SORTX EQU R15 RETURN REGISTER 08200000 SPACE 08220000 REL EQU RPO RELATIVE ADDRESS IN SORTED TAB. 08240000 RPAD EQU R8 PTR TO ACTUEL ADDRESS TAB ENTRY 08260000 RGO EQU R7 PTR TO ACTUEL COUNT TAB ENTRY 08280000 RE EQU WORKX ADDRESS OF LAST COUNT TAB ENTRY 08300000 SPACE 08320000 RTO EQU RPAD START ADDRESS OF SORTED TABLE 08340000 SPACE 3 08360000 SORT EQU * 08380000 MVC ZCOSTA(1),ZERO ZEROIZE TABLES 08400000 MVC ZCOSTA+1(254),ZCOSTA 08420000 MVC ZCOSTA+255(255),ZCOSTA 08440000 MVC ZADSTA(255),ZCOSTA 08460000 MVC ZADSTA+255(255),ZCOSTA 08480000 L RPO,ZSTAD CURRENT PTR 08500000 SPACE 08520000 SORT1 CLI 0(RPO),X'FF' DELETED ENTRY 08540000 BE SORT2 YES 08560000 SR WORKR,WORKR ISOLATE ACTUELL FSN 08580000 IC WORKR,0(0,RPO) 08600000 AR WORKR,WORKR FSN * 2 08620000 LH WORKX,ZCOSTA(WORKR) GET OLD COUNTER 08640000 LA WORKX,1(0,WORKX) INCREASE BY ONE 08660000 STH WORKX,ZCOSTA(WORKR) STORE NEW COUNTER 08680000 SPACE 08700000 SORT2 AR RPO,RENTRY ADDRESS NEXT ENTRY 08720000 CR RPO,REND END OF TABLE 08740000 BL SORT1 NO 08760000 SPACE 08780000 * BUILD ADDRESS TABLE 08800000 LH WORKR,FSNMAX GET ADDRESS OF LAST COUNT ENTRY 08820000 AR WORKR,WORKR 08840000 LA RE,ZCOSTA(WORKR) LAST ENTRY 08860000 SPACE 08880000 SR REL,REL RELATIVE ADDRESS IN NEW TABLE 08900000 LA RGO,ZCOSTA CURRENT COUNT TABLE PTR 08920000 LA RPAD,ZADSTA+2 CURRENT ADDRESS TABLE PTR 08940000 SORT3 EQU * 08960000 CR RGO,RE LAST ENTRY 08980000 BH SORT4 YES 09000000 LH R1,0(0,RGO) NUMBER OF ENTRIES 09020000 MR R0,RENTRY COMPUTE TABLE LENGTH 09040000 AR REL,R1 RELATIVE TABLE ADDRESS 09060000 STH REL,0(0,RPAD) MAKE ENTRY IN ADDRESS TABLE 09080000 LA RGO,2(0,RGO) ADDRESS NEXT ENTRY 09100000 LA RPAD,2(0,RPAD) ADDRESS NEXT ENTRY 09120000 B SORT3 09140000 SPACE 09160000 * BUILD SORTED TABLE 09180000 SORT4 EQU * 09200000 L RPO,ZSTAD START OF UNSORTED TABLE 09220000 L RTO,ZSORTSTA START OF SORTED TABLE 09240000 LR WORKR,RENTRY INITLIZE MOVE OF ENTRY 09260000 BCTR WORKR,0 09280000 STC WORKR,SORTM+1 09300000 SPACE 09320000 SORT5 CLI 0(RPO),X'FF' DELETED ENTRY 09340000 BE SORT6 YES 09360000 SR WORKR,WORKR ISOLATE FSN 09380000 IC WORKR,0(0,RPO) 09400000 AR WORKR,WORKR FSN * 2 09420000 LH WORKX,ZADSTA(WORKR) GET RELATIVE ADDRESS 09440000 LR R0,WORKX UPDATE RELATIVE ADDRESS 09460000 AR R0,RENTRY 09480000 STH R0,ZADSTA(WORKR) 09500000 AR WORKX,RTO GET ADDRESS IN SORTED TABLE 09520000 SORTM MVC 0(0,WORKX),0(RPO) MOVE ENTRY 09540000 SORT6 EQU * 09560000 AR RPO,RENTRY GET NEXT ENTRY 09580000 CR RPO,REND END OF TABLE 09600000 BNE SORT5 NO 09620000 BR SORTX 09640000 EJECT 09660000 VSEC1 DC V(IEX40001) ADDRESS OF IEX40001 09680000 SUTYPE DC C'SUTB' SUTAB IDENTIFICATION 09700000 LVTYPE DC C'LVTB' LVTAB IDENTIFICATION 09720000 ZERO DC F'0' 09740000 EIGHT DC H'8' 09760000 SUPOS DC X'00' 09780000 DS 0F A27002 09782019 FOR1 DS CL256 FOR STMNT COUNT AREA A27002 09784019 FOR2 DS CL256 ENCLOSING FS MARK AREA A27002 09786019 FOR3 DC F'86' MAX ENTRIES IN OPTAB A27002 09788019 FOR4 DS 3H WORK AREA FOR GPTAB REC A27002 09790019 FOR5 DC H'1' A27002 09792019 EJECT 09800000 TITLE 'IEX40001, INITIALIZATION OF COMPILATION PHASE' 09820000 IEX40001 CSECT 09840000 SPACE 2 09860000 * REGISTER DEFINITIONS 09880000 SPACE 09900000 RESAR EQU 1 09920000 RLTOTAR EQU 2 09940000 WRK1 EQU 2 09960000 RLIBUF1 EQU 3 09980000 WRK2 EQU 3 10000000 WRK3 EQU 4 10020000 RLOPBUF1 EQU 4 10040000 WRK4 EQU 5 10060000 RLOPDST EQU 6 10080000 RPRPT EQU 6 10100000 RLLAT EQU 7 10120000 RSOURCE EQU 8 10140000 ROPDK EQU 9 10160000 ROPTK EQU 10 10180000 RBASE EQU 12 10200000 RWRKA EQU 13 10220000 EJECT 10240000 USING *,RBASE 10260000 USING WORKAREA,RWRKA 10280000 SPACE 2 10300000 * CALCULATE AND RESERVE SPACE NEEDED 10320000 LA WRK1,INERR1 PROVIDE DIRECTORY 10340000 ST WRK1,ERET RETURN ADDR 10360000 SR RLTOTAR,RLTOTAR INITIATE LENGTH OF RES AREA 10380000 L RLIBUF1,SRCE1S GET LENGTH OF 1ST SOURCE BUFFER 10400000 TM HCOMPMOD+2,X'40' IS SOURCE PRG IN CORE 10420000 BO IN16 YES 10440000 LR RLTOTAR,RLIBUF1 NO, OBTAIN A SECOND BUFFER 10460000 IN16 TM HCOMPMOD+2,X'20' ANY OPTAB 10480000 BO IN17 NO 10500000 L RLOPBUF1,OPTABS OBTAIN LENGTH OF OPTAB-BUFFER 10520000 AR RLTOTAR,RLOPBUF1 ADD TO TOTAL LENGTH 10540000 AR RLTOTAR,RLOPBUF1 ADD LENGTH OF 2ND OPTAB-BUFFER 10560000 IN17 L RLOPDST,OOSTACKS OBTAIN LENGTH OF OPERATOR STACK 10580000 AR RLTOTAR,RLOPDST ADD TO TOTAL LENGTH 10600000 LH RLLAT,LLAT OBTAIN LENGTH OF LAT 10620000 AR RLTOTAR,RLLAT ADD TO TOTAL LENGTH 10640000 ST RLTOTAR,FREEMSIZ STORE LENGTH OF RESERVED AREA 10660000 SPACE 10680000 GETMAIN R,LV=(2) RESERVE AREA 10700000 SPACE 10720000 LA WRK4,INERR2 PROVIDE NEW 10740000 ST WRK4,ERET DIR RETURN ADDRESS 10760000 ST RESAR,FREEMADR STORE ADDRESS OF RESERVED AREA 10780000 SPACE 2 10800000 * LOAD REGISTERS FOR REST OF PHASE 10820000 L RSOURCE,IBUF1 SET 1ST BUFFER 10840000 ST RSOURCE,SOURCEB AS CURRENT 10860000 LR ROPTK,RESAR GET CORRECT REG FOR OPT ST ADR 10880000 SPACE 10900000 TM HCOMPMOD+2,X'40' IS SOURCE PROGRAM IN CORE 10920000 BO IN18 YES 10940000 SPACE 10960000 ST ROPTK,IBUF2 NO, STORE ADDR OF 2ND INPUT BUF 10980000 ST ROPTK,RSRCB SECOND BUFFER = READ BUFFER 11000000 LA ROPTK,0(RLIBUF1,ROPTK) GET ADDR OF NEXT RESERVED AREA 11020000 SPACE 11040000 IN18 TM HCOMPMOD+2,X'20' ANY OPTAB 11060000 BO IN19 NO 11080000 SPACE 11100000 ST ROPTK,OPBUF1 YES, STORE ADDR OF 1ST OPTBUF 11120000 ST ROPTK,AOPTABE ADDRESS FIRST OPTAB ENTRY 11140000 ST ROPTK,OPBUFB 1ST OPTBUF = CURRENT 11160000 LA ROPTK,0(RLOPBUF1,ROPTK) GET ADDR OF 2ND OPTABBUFFER 11180000 ST ROPTK,OPBUF2 STORE -''- 11200000 ST ROPTK,ROPTB 2ND OPTBUF = READ BUFFER 11220000 LA ROPTK,0(RLOPBUF1,ROPTK) GET ADDR OF OPERATOR STACK 11240000 SPACE 11260000 IN19 LA ROPDK,0(RLOPDST,ROPTK) GET ADDR OF LAT 11280000 ST ROPDK,LATAB STORE IT 11300000 BCTR ROPDK,0 GET ADDR OF OPERAND STACK 11320000 L RPRPT,PRPT PRPOINTER 11340000 SPACE 2 11360000 * INITILIZE WORKAREA FOR REST OF PHASE 11380000 TM HCOMPMOD+2,NOPT ANY OPTAB 11400000 BZ *+12 YES 11420000 LA WRK3,MAXFSN NO, STORE ADDRESS OF 11440000 ST WRK3,AOPTABE MAX FS NR 11460000 LA WRK3,SUTABC-9 INITIATE LAST USED 11480000 ST WRK3,SUTABCA SUTAB ENTRY 11500000 SPACE 11520000 LA WRK3,IOTAB COMPUTE 11540000 LA WRK2,GPBN LENGTH OF AREA 11560000 SR WRK2,WRK3 WITH 0 11580000 STC WRK2,*+9 STORE IN MOVE-INSTR 11600000 MVI 0(WRK3),X'00' MOVE 11620000 MVC 1(0,WRK3),0(WRK3) ZEROES 11640000 SPACE 11660000 MVI MAXFSN,X'FF' INSERT MAX FS NUMBER 11680000 MVI CII+1,X'07' 11700000 MVI CIR+1,X'06' 11720000 MVI CLEARDIS,X'F0' INSERT 11740000 MVI ONEENTRY+1,X'08' VALUES FOR 11760000 MVC MAXOVERF(2),LONG LONG PREC 11780000 TM HCOMPMOD,X'02' TEST PRECISION 11800000 BO IN3 LONG 11820000 MVI ONEENTRY+1,X'04' SHORT, 11840000 MVI PRECMASK,X'10' CHANGE 11860000 MVC MAXOVERF(2),SHORT VALUES 11880000 IN3 MVI GPBN+1,X'FF' 11900000 MVC SEMCNT(2),ZEROHW INITIATE SEMICOLON COUNTER 11920000 SPACE 2 11940000 * INITILIZE OPERATOR STACK 11960000 MVI 0(ROPTK),X'25' INSERT OPERATOR ALPHA 11980000 SPACE 2 12000000 * INITIALIZATION OF LABEL ADDRESS TAB 12020000 L WRK1,LATAB 12040000 MVI 0(WRK1),X'00' ZERO BEGIN 12060000 MVC 1(LATBEG-1,WRK1),0(WRK1) OF LAT 12080000 LA 1,15 * ZERO 12100000 LA 11,79(0,WRK1) * REST 12120000 TSTZER MVC 1(256,11),0(11) * OF 12140000 LA 11,256(0,11) * LAT 12160000 BCT 1,TSTZER * FOR 12180000 MVC 1(176,11),0(11) * TEST 12200000 LA WRK2,LATNR 12220000 IN4 MVI 0(WRK1),X'80' TURN ON FIRST BIT IN LAT-ENTRY 12240000 LA WRK1,4(0,WRK1) STEP ADDRESS 12260000 BCT WRK2,IN4 HANDLE NEXT ENTRY IF ANY 12280000 SPACE 2 12300000 * START READ-IN OF SOURCE PRG, IF NEC 12320000 TM HCOMPMOD+2,X'40' IS SOURCE PRG IN CORE 12340000 BZ IN6 NO, NO BRANCHES WILL BE TAKEN 12360000 OI IN6+1,X'F0' YES, ALL 12380000 OI IN9+1,X'F0' BRANCHES WILL 12400000 OI IN14+1,X'F0' BE TAKEN 12420000 SPACE 12440000 IN6 BC 0,IN22 BRANCH IF SOURCE PRG IN CORE 12460000 L WRK2,UT2ADD LOAD ADDRESS OF DCB 12480000 READ SRC1,SF,(3),(8) READ 1ST SOURCE RECORD 12500000 IN22 BCTR RSOURCE,0 INITIATE SOURCE POINTER 12520000 SPACE 2 12540000 * CONSTRUCT PBTAB3 12560000 LA WRK1,PBTAB2 START ADDR OF PBTAB2 IN WORKAR 12580000 LA WRK4,PBTAB3 START ADDR OF PBTAB3 IN WORKAR 12600000 LH WRK3,PBN GET NR OF PRG BLOCKS 12620000 LA WRK3,1(0,WRK3) 12640000 IN8 MVC 0(2,WRK4),0(WRK1) MOVE ONE PBTAB2 ENTRY 12660000 MVC 2(2,WRK4),ZEROHW ZERO REST OF ENTRY 12680000 LA WRK1,2(0,WRK1) STEP 12700000 LA WRK4,4(0,WRK4) ADDRESSES 12720000 BCT WRK3,IN8 MOVE NEXT IF NOT ALL MOVED 12740000 SPACE 2 12760000 IN9 EQU * CHECK READ OF 1ST SOURCE REC IF NEC 12780000 BC 0,IN10 BRANCH IF SOURCE PRG IN CORE 12800000 CHECK SRC1 12820000 SPACE 12840000 IN10 LA WRK1,1 INITIATE RECORD COUNT 12860000 STC WRK1,NUMBBL STORE IT 12880000 SPACE 12900000 SPACE 12920000 * START READING OF OPTAB 12940000 TM HCOMPMOD+2,X'20' IS OPTAB EMPTY 12960000 BO IN14 YES, BYPASS READING 12980000 SPACE 13000000 LA WRK1,IN14 GIVE ADDR OF 13020000 ST WRK1,EODUT3 EOD RTN TO DIR 13040000 L WRK1,OPBUF1 GET ADDRESS OF 1ST BUFFER 13060000 L WRK3,UT3ADD GET ADDRESS OF DCB 13080000 SPACE 13100000 IN12 READ OPTB1,SF,(4),(2),'S' READ 1ST RECORD 13120000 SPACE 13140000 CHECK OPTB1 13160000 SPACE 13180000 IN13 BC 0,IN14 BRANCH AFTER 2ND CHECK 13200000 L WRK1,OPBUF2 GET ADDRESS OF 2ND BUFFER 13220000 OI IN13+1,X'F0' 13240000 B IN12 READ 2ND RECORD 13260000 SPACE 13280000 SPACE 13300000 IN14 EQU * READ 2ND SOURCE RECORD IF ANY 13320000 BC 0,IN15 BRANCH IF SOURCE PRG IN CORE 13340000 LA WRK1,IN15 GIVE ADDR OF 13360000 ST WRK1,EODUT2 EOD RTN TO DIR 13380000 L WRK1,IBUF2 GET ADDRESS OF 2ND BUFFER 13400000 READ SRC2,SF,(3),(2) READ 2ND RECORD 13420000 SPACE 13440000 CHECK SRC2 13460000 SPACE 13480000 SPACE 13500000 IN15 EQU * GO TO NEXT LOAD MODULE 13520000 NI HCOMPMOD+2,X'F7' SET OFF NOSC SWITCH 13540000 XCTL EP=IEX50000 13560000 SPACE 13580000 SPACE 13600000 INERR1 EQU * DIRECTORY RETURN BEFORE GETMAIN 13620000 XCTL EP=IEX51ER2 13640000 SPACE 13660000 SPACE 13680000 INERR2 EQU * DIRECTORY RETURN AFTER GETMAIN 13700000 XCTL EP=IEX51ER1 13720000 EJECT 13740000 * CONSTANTS 13760000 SPACE 13780000 LLAT DC H'4096' LENGTH OF LABEL ADDRESS TABLE 13800000 SHORT DC H'4092' TO CHECK OBJ TIME STACK OVFLOW 13820000 LONG DC H'4088' -''- 13840000 EJECT 13860000 WORKAREA DSECT 13880000 COPY WORKAREA 13900000 ORG DCBUT1 13920000 FSNMAX DS H 13940000 LVCOUNT DS H 13960000 SUCOUNT DS H 13980000 ZLEVEN DS F 14000000 ZSUTEN DS F 14020000 ZCOSTA DS 255H SORT COUNT TABLE 14040000 ZADSTA DS 255H SORT ADDRESS TABLE 14060000 TSTART DS F START OF TABLE AREA 14080000 SAVETAB DS F AREA TO SAVE TABLE END 14100000 ZSTAD DS F START ADDRESS OF UNSORTED TABLE 14120000 ZSORTSTA DS F START ADDRESS OF SORTED TABLE 14140000 ZSUDAD DS F START OF SORTED SUTAB 14160000 ZSUDEN DS F END ADDRESS OF SORTED SUTAB 14180000 ZLESTA DS F START ADDRESS OF SORTED LUTAB 14200000 ZOTAFILL DS F OPTAB WORK-BUFFER ADDRESS 14220000 ZOTAWRI DS F OPTAB WRITE-BUFFER ADDRESS 14240000 ZOTMAX DS F END OF OUTPUT BUFFER IN USE 14260000 TABSIZE DS F SIZE OF TABLE AREA 14280000 EJECT 14300000 * 14320000 * AREA USED BY COMPILATION PHASE 14340000 * 14360000 SPACE 14380000 ORG DCBUT1 14400000 SPACE 14420000 RETADR DS 17F SAVE AREA 14440000 PLACE14 DS F -''- 14460000 RUTI DS 9F GPR CONTROL 14480000 RUTR DS 4F FLREG CONTROL 14500000 GPROLN DS H LABEL NR OF OBJ PRG ENTRY POINT 14520000 KONSUM DS H WORKPLACE 14540000 WORKPL DS F WORKPLACE 14560000 IBUF1 EQU SRCE1ADD ADDR OF FIRST SOURCE BUFFER 14580000 IBUF2 DS A -'' SECOND -''- 14600000 SOURCEB DS A -'' CURRENT -''- 14620000 RSRCB DS A -'' READ -''- 14640000 OPBUF1 DS A ADDR OF FIRST OPTAB BUFFER 14660000 OPBUF2 DS A -''- SECOND -''- 14680000 OPBUFB DS A -''- CURRENT -''- 14700000 ROPTB DS A -''- READ -''- 14720000 AOPTABE DS A ADDRESS OF CURRENT OPTAB ENTRY 14740000 LATAB DS A ADDR OF LABEL ADDRESS TABLE 14760000 APBTAB4 EQU LATAB ADDRESS OF PBTAB4 14780000 SUTABCA DS A ADDR OF LAST USED SUTAB ENTRY 14800000 STRETURN DS F RETURN ADDRESS 14820000 FREEMADR DS A ADR FOR FREEMAIN IN 50000 14840000 FREEMSIZ DS F SIZE -''- 14860000 SPACE 14880000 PBTAB3 DS 1024C PROGRAM BLOCK TABLE, 3RD VERS 14900000 SPACE 14920000 IOTAB DC 18X'00' LIST OF DATA SETS 14940000 CII DC H'0' REGISTER CONTROL 14960000 CIR DC H'0' -''- 14980000 RII DC H'0' -''- 15000000 RIR DC H'0' -''- 15020000 OPDPBN DC H'0' PROGRAM BLOCK NR (BYTE 2 OF OPD 15040000 OPDADR DC H'0' BYTES 3 AND 4 OF OPERAND 15060000 OPDLN DC H'0' LABEL NUMBER TIMES FOUR 15080000 SCSC EQU SEMCNT SEMICOLON COUNTER 15100000 ZEROHW DC H'0' ZEROES 15120000 CFSN DC X'00' CURRENT FS NUMBER 15140000 MAXFSN DC X'FF' MAX FS NUMBER 15160000 CLEARDIS DC X'F000' FOR CLEARING OF DISPLACEM PART 15180000 ONEENTRY DC H'4' SHORT, FOR INCR OF OT STACK PTR 15200000 ORG ONEENTRY 15220000 DC H'8' LONG -''- 15240000 PRECMASK DC X'10' SHORT, TO MODIFY INSTRUCTIONS 15260000 ORG PRECMASK 15280000 DC X'00' LONG -''- 15300000 NUMBBL DC X'00' RECORD COUNTER 15320000 DS H 15340000 SPBNST DC H'0' CURRENT PBN 15360000 DS H AND DISPLACEMENT 15380000 GPBN DC H'255' GLOBAL DSA CONTROL 15400000 MAXOVERF DC H'4092' SHORT, TO CHECK OT STACK OVERFL 15420000 ORG MAXOVERF 15440000 DC H'4088' LONG -''- 15460000 HALFW DS H WORKPLACE 15480000 USPEI2 DS H FOR ARRAY DECLA- 15500000 USPEI4 DS H RATION HANDLING 15520000 WPLACE DS H FOR INSTRUCTION GENERATION 15540000 XPLACE DS H 15560000 YPLACE DS H 15580000 UPLACE DS H 15600000 VPLACE DS C -''- 15620000 STRDNAME DS 5C TO STORE OPERAND 15640000 CBVTAB DS 48C CALLED-BY-VALUE TABLE 15660000 SUTABC DS 768C FOR SUBSCRIPT OPTIMIZATION 15680000 ORG SUTABC 15700000 DSTAB DS 608C DATA SET TABLE 15720000 END START 15740000 ./ ADD SSI=01012912,NAME=IEX50,SOURCE=0 TITLE 'IEX50, COMPILATION PHASE' 00020000 * * 00040000 *STATUS CHANGE LEVEL 000. * 00060000 * * 00080000 *FUNCTION/OPERATION THIS MODULE PERFORMS THE REAL TRANSLATION OF THE * 00100000 * SOURCE PROGRAM INTO SYSTEM/360 INSTRUCTIONS. THE SOURCE PROGRAM * 00120000 * IS AT MODIFICATION LEVEL 2 AND CONSISTS OF A SEQUENCE OF ONE-BYTE * 00140000 * OPERATORS AND FIVE-BYTE OPERANDS, WHICH IS SCANNED SEQUENTIALLY. * 00160000 * THE STATUS OF RECOGNITION OF THE SOURCE PROGRAM IS DESCRIBED BY * 00180000 * 1. A SEQUENCE OF CONTEXTS (SEE BELOW) * 00200000 * 2. A SEQUENCE OF STACKED OPERATORS (THE OPERATOR STACK) * 00220000 * THE ACTION OF THE COMPILER IS DETERMINED BY THE OPERATOR PAIR * 00240000 * STACK-SOURCE OPERATOR AND THE CURRENT CONTEXT. THE OPERATOR PAIR * 00260000 * DETERMINES AN ELEMENT IN A DECISION MATRIX, WHICH IS DETERMINED * 00280000 * BY THE CONTEXT. THE MATRIXELEMENTS REPRESENT ADDRESSES OF THE * 00300000 * COMPILER PROGRAMS, WHICH PERFORM THE ACTIONS REQUESTED BY ALL * 00320000 * POSSIBLE OPERATOR PAIRS. * 00340000 * THERE ARE THREE CONTEXTS, PROGRAM, STATEMENT, AND EXPRESSION CON- * 00360000 * TEXT, AND THE CURRENT CONTEXT IS INDICATED BY A REGISTER. SWITCH- * 00380000 * ING FROM ONE CONTEXT TO ANOTHER IS IN MOST CASES DETERMINED BY * 00400000 * THE STACK-SOURCE OPERATOR PAIR, I.E., THE COMPILER PROGRAM ACTI- * 00420000 * VATED JUST PERFORMS THE CHANGE OF CONTEXT, BUT IN A FEW CASES THE * 00440000 * SOURCE OPERATOR ALONE DETERMINES THE NEW CONTEXT. IN THIS LATTER * 00460000 * CASE THE OPERATOR IS STACKED TOGETHER WITH A CONTEXT OPERATOR, * 00480000 * INDICATING THE PRECEDING CONTEXT. * 00500000 * * 00520000 * BESIDES THE COMPILER PROGRAMS THERE ARE OTHER ROUTINES PROVIDING * 00540000 * DIFFERENT SERVICES. THE MOST IMPORTANT ARE (THOSE MARKED WITH * * 00560000 * ARE USED AS SUBROUTINES BY THE COMPILER PROGRAMS) * 00580000 * SNOT SCAN TO NEXT OPERATOR IN SOURCE PROGRAM * 00600000 * COMP CHOOSE COMPILER PROGRAM AND BRANCH * 00620000 * JBUFFER READ A NEW SOURCE PROGRAM RECORD * 00640000 * NXTOPT *GET NEXT ENTRY OF OPTAB * 00660000 * SERR *GENERATE AN ERROR PATTERN * 00680000 * CPEND NORMAL TERMINATION * 00700000 * CPERRI ABNORMAL TERMINATION * 00720000 * GENERATE *GENERATE TXT AND RLD-RECORDS * 00740000 * * 00760000 * A COMPILER PROGRAM IS ALWAYS FOLLOWED BY SNOT OR COMP OR A BRANCH * 00780000 * TO ANOTHER COMPILER PROGRAM. * 00800000 * * 00820000 * THE MODULE CONSISTS OF SEVEN CONTROL SECTIONS * 00840000 * IEX50000 - INITIALIZATION AND SUBROUTINES * 00860000 * IEX50001 - DECICION MATRIXES * 00880000 * IEX50002 - COMPILER PROGRAMS HANDLING FOR-STATEMENTS AND SUBSCRIPT* 00900000 * OPTIMIZATION * 00920000 * IEX50003 - COMPILER PROGRAMS HANDLING BEGIN AND END OF COMPOUND * 00940000 * STATEMENTS AND BLOCKS, PROCEDURE DECLARATIONS, ARRAY * 00960000 * DECLARATIONS, SWITCH DECLARATIONS, GOTO STATEMENTS, * 00980000 * SUBSCRIPTED VARIABLES AND SWITCH DESIGNATORS, * 01000000 * SEMICOLON COUNTER. * 01020000 * IEX50004 - COMPILER PROGRAMS HANDLING ASSIGNMENTS, * 01040000 * PROCEDURE CALLS, STANDARD PROCEDURE CALLS. * 01060000 * IEX50005 - COMPILER PROGRAMS HANDLING ERRONEOUS CASES, BOOLEAN * 01080000 * OPERATIONS, ARITHMETIC MINUS, IF, THEN, ELSE. * 01100000 * IEX50006 - COMPILER PROGRAM HANDLING ARITHMETICAL OPERATIONS. * 01120000 * * 01140000 *ENTRY POINT * 01160000 * IEX50000 - COMPILATION PHASE XCTL EP=IEX50. * 01180000 * THE MODULE IS ENTERED FROM IEX40 * 01200000 * * 01220000 *INPUT THE SOURCE PROGRAM IS READ FROM SYSUT2. * 01240000 * OPTAB IS READ FROM SYSUT3. * 01260000 * * 01280000 *OUTPUT THE MAIN PART OF THE OBJECT MODULE IS PUT OUT ON SYSLIN AND/ * 01300000 * OR SYSPUNCH IF THE OPTIONS 'LOAD' AND/OR 'DECK' ARE SPECIFIED. * 01320000 * * 01340000 *EXTERNAL ROUTINES N/A * 01360000 * * 01380000 *EXIT-NORMAL IF NO TERMINATING ERROR HAS OCCURRED, CONTROL IS GIVEN * 01400000 * TO THE TERMINATING MODULE BY MEANS OF XCTL EP=IEX51000. * 01420000 * * 01440000 *EXIT-ERROR IF A TERMINATING ERROR HAS OCCURED, CONTROL IS GIVEN TO * 01460000 * THE TERMINATING MODULE BY MEANS OF XCTL EP=IEX51ER1. * 01480000 * * 01500000 *TABLES/WORKAREAS * 01520000 * SCPTAB - COMPILER PROGRAM ADDRESS TABLE USED BY ROUTINE COMP * 01540000 * TXTT - INFORMATION FOR TXT-RECORDS USED BY ROUTINE GENERATE * 01560000 * RLDT - INFORMATION FOR RLD-RECORDS USED BY ROUTINE GENERATE * 01580000 * DECAREA - DECISION MATRIXES USED BY ROUTINE COMP * 01600000 * * 01620000 * THE PART OF COMMON WORKAREA STARTING AT DCBUT1 IS INITIALIZED BY * 01640000 * THE PRECEDING LOAD MODULE AND USED BY THIS AND THE NEXT LOAD * 01660000 * MODULE. * 01680000 * * 01700000 *ATTRIBUTES NONE. * 01720000 * * 01740000 *CHARACTER CODE DEPENDENCE THE OPERATION OF THE ROUTINE GENERATE * 01760000 * DEPENDS UPON AN INTERNAL REPRESENTATION OF THE EXTERNAL CHARACTER * 01780000 * SET WHICH IS EQUIVALENT TO THE ONE USED AT ASSEMBLY TIME. * 01800000 * * 01820000 * THIS MODULE IS ONLY INTENDED TO BE EXECUTED IN CONNECTION * 01840000 * WITH THE OTHER MODULES OF THE ALGOL COMPILER. IN PARTICULAR IT * 01860000 * REQUIRES THE COMMON WORKAREA. * 01880000 * 01900000 EJECT 01920000 IEX50000 CSECT 01940000 * RELEASE 19 CHANGES 01945019 * 090620-090740 A28233 01950019 *C090200,090250 A32978 01955021 SPACE 01960000 SPACE 01980000 * COMPILETIME REGISTER DEFINITIONS 02000000 SPACE 02020000 R0 EQU 0 * 02040000 R1 EQU 1 * 02060000 R2 EQU 2 * 02080000 R3 EQU 3 * VARIABLE USE 02100000 R4 EQU 4 * 02120000 WRK EQU 4 * 02140000 SBR EQU 5 ADDRESSES SUBROUTINE POOL 02160000 PRPOINT EQU 6 CONTAINS REL ADDRESS IN OBJ PROGRAM 02180000 P EQU 7 CONTAINS DISP IN OBJECT TIME STACK 02200000 SOURCE EQU 8 SOURCE PROGRAM POINTER 02220000 OPDK EQU 9 OPERAND STACK POINTER 02240000 OPTK EQU 10 OPERATOR STACK POINTER 02260000 RCCT EQU 11 INDICATES CURRENT CONTEXT 02280000 CCT EQU 11 - '' - 02300000 BASE EQU 12 CONTAINS BASE ADDR OF COMP PROGRAMS 02320000 WAREG EQU 13 ADDRESSES COMMON WORKAREA 02340000 GREG EQU 14 ARRAY IDENTIFIER COUNT 02360000 R14 EQU 14 VARIABLE 02380000 R15 EQU 15 USE 02400000 SPACE 02420000 * OBJECTTIME REGISTER DEFINITIONS 02440000 SPACE 02460000 FPR0 EQU 0 * 02480000 FPR2 EQU 2 * 02500000 GPRA EQU 3 * VARIABLE USE 02520000 GPRB EQU 5 * 02540000 GPRC EQU 6 * 02560000 ADR EQU 8 FOR TRANSFER OF ADDRESSES 02580000 STH EQU 14 FOR TEMPORARY USE 02600000 CDSA EQU 10 ADDRESSES CURRENT DSA 02620000 GDSA EQU 9 ADDRESSES GLOBAL DSA 02640000 PBT EQU 11 ADDRESSES PROGRAM BLOCK TABLE 02660000 LAT EQU 12 ADDRESSES LABEL ADDRESS TABLE 02680000 FSA EQU 13 ADDRESSES FIXED STORAGE AREA 02700000 ENTRY EQU 15 ENTRY POINT OF LIBRARY SUBROUTINES 02720000 BRR EQU 15 LINK REGISTER 02740000 EJECT 02760000 * 02780000 * INITIALIZATION THIS ROUTINE PERFORMS THE REMAINING INITIALIZATION, 02800000 * THE MAIN PART IS MADE IN IEX40001 02820000 * 02840000 USING *,R15 USE ENTRY POINT REG AS BASE 02860000 LA SBR,SNOT LOAD BASE REG 02880000 USING SNOT,SBR FOR SNOT 02900000 SPACE 02920000 LA WRK,CPERR1 PROVIDE DIRECTORY 02940000 ST WRK,ERET(WAREG) RETURN ADDRESS 02960000 SPACE 02980000 L RCCT,DECAADD(SBR) LOAD ADDR OF CCT 03000000 LA WRK,JB3 PROVIDE 03020000 ST WRK,EODUT2(0,WAREG) EOD ADDR 03040000 LA WRK,NX4 FOR UT2 03060000 ST WRK,EODUT3(0,WAREG) & UT3 03080000 DROP R15 03100000 CNOP 0,8 03120000 TITLE 'IEX50, COMPILATION PHASE, SUBROUTINE POOL' 03140000 * SUBROUTINE POOL 03160000 SPACE 03180000 SBRPOOL EQU * START OF SUBROUTINE POOL 03200000 SNOT EQU SBRPOOL 03220000 SBRSTRT EQU SNOT SUBROUTINE POOL START 03240000 SPACE 3 03260000 * SCAN SOURCE INPUT TO NEXT OPERATOR 03280000 SPACE 03300000 ABB1 NI HCOMPMOD(WAREG),X'FE' OPERAND FLAG OFF 03320000 ABC1 CLI 1(SOURCE),X'2F' TEST SOURCE 03340000 BL ABD3 OPERATOR 03360000 BH ABD1 OPERAND 03380000 BAL R4,JBUFFCH BUFFERCHANGE 03400000 B ABC1 CONTINUE 03420000 ABD3 LA SOURCE,1(0,SOURCE) SOURCE REG INCREASE 03440000 B ACB1 CHOOSE CP 03460000 ABD1 OI HCOMPMOD(WAREG),X'01' OPERAND FLAG ON 03480000 SH OPDK,CON5(0,SBR) SOURCE OPERAND 03500000 CR OPTK,OPDK * TO 03520000 BNL STERMERR * STACK 03540000 MVC 0(5,OPDK),1(SOURCE) * 03560000 LA SOURCE,5(0,SOURCE) SOURCE REG INCREASE 03580000 B ABC1 CONTINUE 03600000 SPACE 03620000 * AN OPERAND IS NOT ALLOWED IN SOURCE 03640000 SPACE 03660000 SPEC EQU *-ABB1 03680000 SNOTSP EQU SPEC 03700000 ABC3 CLI 1(SOURCE),X'2F' SPECIAL TEST 03720000 BL ABD3 OPERATOR 03740000 BH ABD5 OPERAND 03760000 BAL R4,JBUFFCH BUFFER CHANGE 03780000 B ABC3 03800000 ABD5 LA SOURCE,6(SOURCE) SOURCE REG INCREASE 0220 03810015 BAL R4,SERR3(0,SBR) 0220 03820015 ERROR DC H'191' 0220 03830015 BCTR SOURCE,0 SOURCE REG MINUS ONE 0220 03840015 B ABC3 03880000 SPACE 03900000 * CHOOSE CP PROGRAM 03920000 SPACE 03940000 COMP EQU *-ABB1 03960000 ACB1 SR R1,R1 03980000 LR R2,R1 04000000 IC R1,0(0,SOURCE) FETCH SOURCE OPERATOR 04020000 IC R1,0(R1,CCT) COLUMN VECTOR 04040000 IC R2,0(0,OPTK) FETCH STACK OPERATOR 04060000 IC R2,50(R2,CCT) ROW VECTOR 04080000 AR R1,R2 04100000 IC R1,100(R1,CCT) 04120000 SLL R1,2(0) COMPILER PROGRAM FROM MATRIX 04140000 L BASE,SCPTAB(R1) FIND BASE ADDRESS 04160000 BR BASE BRANCH TO COMPILER PROGRAM 04180000 EJECT 04200000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 04220000 * * 04240000 * JBUFFER PERFORMS CHANGE OF INPUT BUFFER 04260000 * * 04280000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 04300000 * CALL BAL RETURN,JBUFFCH ( FROM SNOT ) * 04320000 * BAL RETURN,JBUFFER(0,SBR) ( FROM COMPILER PROGRAMS ) * 04340000 SPACE 2 04360000 * REGISTER DEFINITIONS 04380000 SPACE 04400000 RDCB EQU 3 ADDRESS OF DCB FOR UT2 04420000 RCUR EQU 2 ADDRESS OF CURRENT BUFFER 04440000 RREAD EQU SOURCE ADDRESS OF CURRENT INPUT BUFFER 04460000 RWRK EQU RDCB WORKREG 04480000 SPACE 2 04500000 JBUFFER EQU *-ABB1 CHANGE OF INPUT BUFFER 04520000 JBUFFCH L RDCB,UT2ADD(0,WAREG) GET DCB ADDRESS 04540000 L RCUR,SOURCEB(0,WAREG) GET ADDRESS OF CURRENT BUFFER 04560000 SPACE 04580000 JB1 BC 15,JB2 NO CHECK FIRST TIME 04600000 SPACE 04620000 CHECK SRCECO CHECK PREVIOUS READ 04640000 SPACE 04660000 JB2 READ SRCECO,SF,(RDCB),(RCUR) 04680000 SPACE 04700000 JB3 L RREAD,RSRCB(0,WAREG) GET ADDRESS OF OLD READ BUFFER 04720000 ST RCUR,RSRCB(0,WAREG) CHANGE 04740000 ST RREAD,SOURCEB(0,WAREG) ADDRESSES 04760000 BCTR RREAD,0 GET START ADDRESS - 1 04780000 IC RWRK,NUMBBL(0,WAREG) STEP 04800000 LA RWRK,1(0,RWRK) RECORD 04820000 STC RWRK,NUMBBL(0,WAREG) COUNTER 04840000 SPACE 04860000 MVI JB1+1,X'00' CHANGE BRANCH CONDITION 04880000 BR RETURN RETURN 04900000 EJECT 04920000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 04940000 * * 04960000 * NXTOPT ACQUIRES NEXT ENTRY OF OPTAB 04980000 * * 05000000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 05020000 * CALL BAL RETURN,NXTOPT(0,SBR) * 05040000 SPACE 05060000 * REGISTER DEFINITIONS 05080000 SPACE 05100000 RREL EQU 3 05120000 SPACE 2 05140000 NXTOPT EQU *-ABB1 GET NEXT ENTRY OF OPTAB 05160000 L RCUR,OPBUFB(0,WAREG) GET ADDR OF CURRENT BUFFER 05180000 L RREL,OPREL GET REL ADDR 05200000 LA RREL,14(0,RREL) OF NEW ENTRY 05220000 C RREL,OPTABS(0,WAREG) IS ANEW BUFFER REQUIRED 05240000 BNL NX1 YES 05260000 SPACE 05280000 AR RCUR,RREL NO, STORE 05300000 ST RCUR,AOPTABE(WAREG) ADDRESS OF 05320000 B NX3 NEW ENTRY 05340000 SPACE 05360000 NX1 BC 15,NX2 NO CHECK FIRST TIME 05380000 CHECK OPTCO CHECK PREVIOUS READ 05400000 SPACE 05420000 NX2 L RDCB,UT3ADD(0,WAREG) GET DCB ADDRESS 05440000 READ OPTCO,SF,(RDCB),(RCUR),'S' READ OPTAB RECORD 05460000 SPACE 05480000 MVI NX1+1,X'00' CHANGE BRANCH CONDITION 05500000 NX4 L R1,ROPTB(0,WAREG) GET ADDR OF OLD READ BUFFER 05520000 ST R1,OPBUFB(0,WAREG) CHANGE 05540000 ST RCUR,ROPTB(0,WAREG) ADDRESSES 05560000 ST R1,AOPTABE(WAREG) STORE 05580000 SR RREL,RREL ADDRESSES OF 05600000 NX3 ST RREL,OPREL NEW ENTRY 05620000 BR RETURN RETURN 05640000 SPACE 2 05660000 OPREL DC F'0' REL ADDRESS IN CURRENT BUFFER 05680000 * CONSTANTS LOCATED IN SUBROUTINE POOL 05700000 SPACE 05720000 CON2 EQU *-ABB1 05740000 DC H'2' 05760000 CON4 EQU *-ABB1 05780000 DC H'4' 05800000 CON5 EQU *-ABB1 05820000 DC H'5' 05840000 CON8 EQU *-ABB1 05860000 DC H'8' 05880000 CON9 EQU *-SBRPOOL 05900000 DC H'9' 05920000 CON10 EQU *-ABB1 05940000 DC H'10' 05960000 CON15 EQU *-ABB1 05980000 DC H'15' 06000000 CON20 EQU *-ABB1 06020000 DC H'20' 06040000 CON290 EQU *-ABB1 06060000 DC H'290' 06080000 CON324 EQU *-ABB1 06100000 DC H'324' 06120000 CON614 EQU *-ABB1 06140000 DC H'614' 06160000 API EQU *-ABB1 ALL PURPOSE IDENTIFIER 06180000 DC X'91FF01000000' 06200000 DS 0F 06220000 TYPETEST EQU *-ABB1 TO EXTRACT TYPE BITS 06240000 DC F'3' 06260000 SWVAL EQU *-ABB1 SWITCH FOR VALUE 06280000 DC H'0' 06300000 SWREL EQU *-SBRPOOL SWITCH FOR VARIABLE USE 06320000 DC H'0' 06340000 GREGN EQU *-SBRPOOL NUMBER OF ARRAY IDENTIFIERS-1 06360000 DC H'0' 06380000 DS 0F 06400000 DECAADD EQU *-SBRSTRT 06420000 DC A(DECAREA) ADDR OF DECISION AREA 06440000 HEXFFF EQU *-SBRPOOL 06460000 DC X'00000FFF' 06480000 PRC EQU DECAADD ADDR OF PROG CONTEXT COL VECTOR 06500000 DC A(ADRSTC) 06520000 STC EQU *-SBRPOOL-4 ADDR OF STATEM CONTEXT COL VECT 06540000 DC A(ADREXC) 06560000 EXC EQU *-SBRPOOL-4 ADDR OF EXPR CONTEXT COL VECTOR 06580000 EJECT 06600000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 06620000 * * 06640000 * COMPILER PROGRAM ADDRESS TABLE * 06660000 * * 06680000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 06700000 DS 0F 06720000 DSCPTAB EQU *-ABB1 06740000 SCPTAB DC A(CP0,CP1,CP84,CP3,CP4,CP84,CP6,CP7,CP8,CP84,CP84,CP84,CX06760000 P12,CP84,CP84,CP84,CP16,CP17,CP18,CP19,CP20,CP21,CP22) 06780000 DC A(CP23,CP24,CP25,CP26,CP27,CP28,CP29,CP30,CP31,CP84) 06800000 DC A(CP33) 06820000 DC A(CP34,CP84,CP36,CP84,CP38,CP84,CP40,CP41,CP84,CP43,CP84X06840000 ,CP45,CP84,CP47,CP84,CP49,CP84,CP51,CP52,CP84,CP54) 06860000 DC A(CP84,CP56,CP57,CP84,CP59,CP84,CP61,CP62,CP63,CP64,CP65X06880000 ) 06900000 DC A(CP66,CP67,CP68,CP69,CP70,CP71,CP72,CP73,CP74,CP75,CP76X06920000 ,CP77,CP78,CP79,CP80,CP81,CP84,CP83,CP84,CP85,CP86,CP87) 06940000 SPACE 3 06960000 * LIST OF NOT EXISTING COMPILER PROGRAMS 06980000 * 07000000 * CP2, CP5, CP9, CP10, CP11, CP13, CP14, CP15, CP32, CP35, CP37, 07020000 * CP39, 07040000 * CP42, CP44, CP46, CP48, CP50, CP53, CP55, CP58, CP60, CP82 07060000 * 07080000 EJECT 07100000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 07120000 * * 07140000 * ERROR PATTERN GENERATION 07160000 * * 07180000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 07200000 * CALL BAL RETURN,SERRX(0,SBR) X=1, 2, 3, 4, SP * 07220000 * DC H'N' N=MSG NR * 07240000 SPACE 2 07260000 * REGISTER DEFINITIONS 07280000 SPACE 07300000 SWORK EQU 1 07320000 SHERPIN EQU 2 07340000 SWITCH EQU 3 07360000 SRETURN EQU 4 07380000 RPOOL EQU 15 07400000 SPACE 2 07420000 SERR4 EQU *-SBRPOOL ENTRY BOTH OPERATORS 07440000 LA SWITCH,2 07460000 LA SHERPIN,6 GET LENGTH OF ENTRY 07480000 B ER2 07500000 SPACE 2 07520000 SERR2 EQU *-SBRPOOL ENTRY STACK OPERATOR 07540000 LA SWITCH,3 07560000 B ER1 07580000 SPACE 2 07600000 SERR3 EQU *-SBRPOOL ENTRY SOURCE OPERATOR 07620000 LA SWITCH,1 07640000 ER1 LA SHERPIN,5 GET LENGTH OF ENTRY 07660000 ER2 L RPOOL,NEXTERR(0,WAREG) GET ADDRESS OF POOL ENTRY 07680000 STC SHERPIN,0(0,RPOOL) INSERT LENGTH OF ENTRY 07700000 SPACE 07720000 LA SHERPIN,4 SET POINTER FOR OPERATOR INSERT 07740000 BCT SWITCH,ER4 BRANCH IF STACK OR BOTH 07760000 SPACE 07780000 ER3 MVC EP212+3(1),0(SOURCE) GET SOURCE OP 07800000 OI EP212+3,X'80' AND PUT A TAG 07820000 IC SWORK,EP212+3 INSERT SOURCE OPERATOR 07840000 B ER5 07860000 SPACE 07880000 ER4 IC SWORK,0(0,OPTK) FETCH STACK OPERATOR 07900000 ER5 STC SWORK,0(SHERPIN,RPOOL) INSERT OPERATOR 07920000 SPACE 07940000 LA SHERPIN,1(0,SHERPIN) INCREASE POINTER 07960000 BCT SWITCH,ER6 BRANCH IF STACK OR SOURCE 07980000 B ER3 IF BOTH 08000000 SPACE 2 08020000 SERRSP EQU *-SBRPOOL SPECIAL ENTRY FOR MSG 214 08040000 L RPOOL,NEXTERR(0,WAREG) GET ADDR OF POOL ENTRY 08060000 LH SWITCH,SPBNST(0,WAREG) GET CURRENT PBN 08080000 CVD SWITCH,ERDOUBLE CONVERT 08100000 UNPK ERDOUBLE(3),ERDOUBLE+6(2) TO 08120000 MVZ ERDOUBLE+2(1),ERDOUBLE DECIMAL 08140000 MVC 4(3,RPOOL),ERDOUBLE MOVE TO ERROR PATTERN 08160000 SPACE 08180000 LA SHERPIN,7 GET LENGTH 08200000 STC SHERPIN,0(0,RPOOL) OF ENTRY 08220000 B ER6 08240000 SPACE 08260000 SPACE 08280000 SERR1 EQU *-SBRPOOL 08300000 L RPOOL,NEXTERR(0,WAREG) ENTRY NO OPERATOR 08320000 LA SHERPIN,4 INSERT LENGTH 08340000 STC SHERPIN,0(0,RPOOL) OF ENTRY 08360000 SPACE 08380000 ER6 MVC 2(2,RPOOL),SEMCNT(WAREG) INSERT SEMICOLON COUNTER 08400000 IC SWITCH,1(0,SRETURN) INSERT 08420000 STC SWITCH,1(0,RPOOL) ERROR NUMBER 08440000 SPACE 08460000 LA RPOOL,0(SHERPIN,RPOOL) UPDATE PTR 08480000 ST RPOOL,NEXTERR(0,WAREG) TO NEXT ENTRY 08500000 C RPOOL,ENDPOOL(0,WAREG) IS POOL FULL 08520000 BNH ER7 NO 08540000 SPACE 08560000 MVC EP212+2(2),SEMCNT(WAREG) YES, MOVE PATTERN 08580000 MVC 0(4,RPOOL),EP212 FOR M212 08600000 LA RPOOL,4(0,RPOOL) UPDATE PTR TO 08620000 ST RPOOL,NEXTERR(0,WAREG) NEXT ENTRY 08640000 B CPERR1 GO TO TERMINATION 08660000 SPACE 08680000 ER7 OI HCOMPMOD(WAREG),X'80' SET COMPILE MODE FALSE 08700000 LA SWITCH,2 STEP 08720000 AR SRETURN,SWITCH RETURN ADDRESS 08740000 BR SRETURN RETURN TO CALLER 08760000 SPACE 2 08780000 EP212 DC X'04D40000' ERROR PATTERN FOR MSG 212 08800000 ERDOUBLE DS D 08820000 EJECT 08840000 * OPERAND /OPERATOR STACK OVERFLOW CALL IS B STACKOFL(SBR) 08860000 SPACE 08880000 STACKOFL EQU *-ABB1 08900000 STERMERR BAL R4,SERR1(0,SBR) 08920000 DC H'186' 08940000 B CPERR1 08960000 SPACE 2 08980000 CPEND EQU * NORMAL TERMINATION 09000000 TM HCOMPMOD+2(WAREG),X'40' SOURCE IN CORE 2846 09005015 BC 1,CPEND1 YES 2846 09010015 BAL RETURN,JBUFFER(0,SBR) NO CHECK LAST READ 2846 09015015 CPEND1 TM NX1+1,X'F0' OPTAB READ IN IEX50? A32978 09020021 BC 1,CPEND2 NO A32978 09025021 BAL RETURN,NXTOPT(0,SBR) NO CHECK LAST READ 2846 09030015 CPEND2 XCTL EP=IEX51000 BRANCH TO NEXT MODULE 2846 09035015 SPACE 09040000 CPERR1 EQU * DIRECTORY RETURN ADDRESS 09060000 TM JB1+1,X'F0' READ TO INPUT BUFFERS A28233 09062019 BC 1,CPERR10 NO A28233 09064019 CHECK SRCECO CHECK LAST READ A28233 09066019 CPERR10 TM NX1+1,X'F0' OPTAB READ A28233 09068019 BC 1,CPERR11 NO A28233 09070019 CHECK OPTCO CHECK LAST READ A28233 09072019 CPERR11 EQU * A28233 09074019 XCTL EP=IEX51ER1 TO ERROR MSG EDITING AND TERM 09080000 EJECT 09100000 DS 0H 09120000 SPACE 09140000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 09160000 * * 09180000 * CONVERTION INTEGER TO REAL * 09200000 * * 09220000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 09240000 * GENERATES CALL OF CONVERTION ROUTINE FROM INTEGER TO REAL AFTER 09260000 * LOCATING THE OPERAND. RESERVES ONE OBJECT STACK TIME ENTRY SETS 09280000 * RIR INTRODUCES OPERAND ADDRESSS INTO RUTR AND ADJUSTS OPERAND 09300000 * * 09320000 * CALL BAL RETURN,TRINRE(0,SBR) 09340000 * * 09360000 * * 09380000 TRINRE EQU *-SBRPOOL 09400000 ST RETURN,RETADR(0,WAREG) STORE RETURN ADDRESS 09420000 LA RETURN,HQF21 09440000 BAL R3,ROUTIN15(0,SBR) 09460000 SR R1,R1 09480000 IC R1,3(OPDK) PREPARE INSTRUCTION 09500000 SRL R1,4 09520000 LA R2,1 09540000 SLL R2,0(R1) 09560000 STC R2,HQD2+1 09580000 XI HQD2+1,X'FF' 09600000 HQD2 NI RII+1(WAREG),X'00' 09620000 BAL RETURN,ROUTINE8(0,SBR) RELILO 09640000 MVN HQG1+1(1),VPLACE(WAREG) 09660000 BAL INFORM,GENTXT2(0,SBR) 09680000 HQG1 LR STH,0 ***GENERATE*** 09700000 HQH1 TM RIR+1(WAREG),X'01' IS FPRO FREE 09720000 BZ HQJ1 BRANCH IF FREE 09740000 BAL RETURN,ROUTIN14(0,SBR) STFPR0 09760000 HQJ1 TM RII(WAREG),X'01' IS ADR FREE 09780000 BZ HQJ11 09800000 BAL RETURN,ROUTIN10(0,SBR) 09820000 HQJ11 BAL INFORM,GENTXT4(0,SBR) CALL CONVER. ROUTINE 09840000 BAL ADR,CNVIRD(0,FSA) ***GENERATE*** 09860000 OI 0(OPDK),X'80' ADJUST OPDK ENTRY 09880000 NI 0(OPDK),X'9F' 09900000 OI 1(OPDK),X'32' 09920000 NI 1(OPDK),X'FE' 09940000 MVC 2(1,OPDK),SPBNST+1(WAREG) 09960000 AH P,ONEENTRY(0,WAREG) 09980000 STH P,WORKPL(0,WAREG) 10000000 MVC 3(2,OPDK),WORKPL(WAREG) INTRODUCE STACK ADD 10020000 ST OPDK,RUTR(0,WAREG) INTRODUCE OPDK ADD IN RUTR 10040000 OI RIR+1(WAREG),X'01' SET RIR TO ONE 10060000 MVI CIR+1(WAREG),X'00' CIR=0 10080000 L RETURN,RETADR(0,WAREG) LOAD RETURN ADDRESS 10100000 BR RETURN 10120000 HQF21 MVN HQG2+1(1),VPLACE(WAREG) PREPARE INSTRUCTION 10140000 MVC HQG2+2(2),WPLACE(WAREG) 10160000 BAL INFORM,GENTXT4(0,SBR) 10180000 HQG2 L STH,0(0,0) ***GENERATE*** 10200000 B HQH1 10220000 EJECT 10240000 DS 0H 10260000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 10280000 * * 10300000 * CONVERSION REAL TO INTEGER * 10320000 * * 10340000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 10360000 * CALL BAL RETURN,TRRE IN(SBR) 10380000 * AT OBJECT TIME THE INTEGER VALUE IS IN REGISTER STH AFTER CONVERSION 10400000 SPACE 2 10420000 * BIT PATTERNS 10440000 SPACE 10460000 OBJSTM EQU X'C0' OBJECT STACK MASK 10480000 RADRFREM EQU X'01' REG. ADR FREE MASK 10500000 FPROOCM EQU X'01' FPR0 MASK 10520000 OPDVALUM EQU X'20' VALUE MASK 10540000 OPDREGM EQU X'40' REGISTER MASK 10560000 DISP EQU 0 10580000 SPACE 2 10600000 TRREIN EQU *-SBRSTRT SUBROUTINE TO GENERATE CODE TO CALL 10620000 * REAL-INTEGER CONVERSION ROUTINE 10640000 ST RETURN,SAVTRREI SAVE RETURN ADDRESS 10660000 TM RIR+1(WAREG),FPROOCM FPR0 OCCUPIED 10680000 BZ TRREIN1 NO 10700000 C OPDK,RUTR(0,WAREG) IS OPERAND IN FRR0 10720000 BE TRREIN8 YES, REALEASE FPREG0 10740000 BAL RETURN,ROUTIN14(0,SBR) STORE FLOTING REGISTER 0 10760000 NI RIR+1(WAREG),X'FE' 10780000 TRREIN1 LA R3,TRREIN4 ADDRESS IF VALUE IN REG 10800000 BAL RETURN,ROUTIN15(SBR) FIND DISPL AND REG 10820000 TRREIN2 MVN TRREIN3+1(1),VPLACE(WAREG) INSERT REGISTER AND 10840000 MVC TRREIN3+2(2),WPLACE(WAREG) DISPL. IN LOAD INSTR. 10860000 BAL INFORM,GENTXTP4(0,SBR) GENERATE A LOAD FPR0 10880000 TRREIN3 LD FPR0,DISP(0,0) *INSTRUCTION,FLOATING POINT A. 10900000 TRREIN6 TM RII(WAREG),RADRFREM REG. ADR FREE 10920000 BC 8,TRREIN9 YES 10940000 BAL RETURN,ROUTIN10(0,SBR) STORE ADR AND RETURN 10960000 NI RII(WAREG),X'FE' 10980000 TRREIN9 BAL INFORM,GENTXT4(0,SBR) GENERATE A CALL TO THE REAL- 11000000 BAL ADR,CNVRDI(FSA,0) *INTEGER CONVERSION ROUTINE 11020000 L RETURN,SAVTRREI 11040000 BR RETURN 11060000 TRREIN4 MVN TRREIN5+1(1),VPLACE(WAREG) 11080000 BAL INFORM,GENTXTP2(0,SBR) GENERATE A LOAD FPR0 11100000 TRREIN5 LDR FPR0,0 *INSTRUCTION,FLOATING POINT A. 11120000 TRREIN8 BAL RETURN,ROUTIN12(SBR) RELEASE REG.CONTAINING OPD 11140000 B TRREIN6 11160000 SPACE 2 11180000 SAVTRREI DS F SAVE AREA FOR RETURN 11200000 EJECT 11220000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 11240000 * * 11260000 * S U B R O U T I N E G E N E R A T E * 11280000 * * 11300000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 11320000 SPACE 3 11340000 * GENERATE RLD-RECORDS 11360000 * CALL L INFORM, VALUE OF PROGRAM POINTER 11380000 * BAL LENGTH,GENRLD(SBR) 11400000 * DC H' ' LENGTH OF ADDRESS TABLE 11420000 * DC H' ' ESID OF RELOCATION FACTOR R 11440000 * DC H' ' ESID OF POSITION IDENTIFIER P 11460000 * --- RETURN AFTER CALL GENERATE 11480000 * 11500000 * 11520000 * GENERATE TXT-RECORDS SIX DIFFERENT CALLS 11540000 * BAL INFORM,GENTXT2(SBR) 11560000 * RR FORMAT INSTRUCTION OR DATA 2 BYTES LONG 11580000 * --- RETURN AFTER CALL GENERATE 11600000 * 11620000 * BAL INFORM,GENTXTP2(SBR) 11640000 * RR FORMAT FLOATING POINT LONG FORM INSTRUCTION 11660000 * --- RETURN AFTER CALL GENERATE 11680000 * 11700000 * BAL INFORM,GENTXT4(SBR) 11720000 * INSTRUCTION(S) OR DATA 4 BYTES LONG 11740000 * --- RETURN AFTER CALL GENERATE 11760000 * 11780000 * BAL INFORM,GENTXTP4(SBR) 11800000 * RX FORMAT FLOATING POINT LONG FORM INSTRUCTION 11820000 * --- RETURN AFTER CALL GENERATE 11840000 * 11860000 * BAL INFORM,GENTXT6(SBR) 11880000 * INSTRUCTIONS OR DATA 6 BYTES LONG 11900000 * --- RETURN AFTER CALL GENERATE 11920000 * 11940000 * LA INFORM, ADDRESS OF CODE TO BE GENERATED 11960000 * BAL LENGTH,GENTXT8(SBR) 11980000 * DC H' ' LENGTH OF CODE IN BYTES 12000000 * --- RETURN AFTER CALL GENERATE 12020000 EJECT 12040000 * REGISTER DEFINITIONS 12060000 REG0 EQU 0 VARIABLE USE 12080000 OUTAREA EQU 1 OUTPUT RECORD POINTER 12100000 INFORM EQU 2 ADDRESS OF INFORMATION 12120000 TYPER EQU 3 TYPE OF RECORD TO BE GENERATED 12140000 RETURN EQU 4 RETURN REGISTER 12160000 LENGTH EQU 14 LENGTH OF INFORM. FROM CALL 12180000 L EQU 15 LENGTH WITHIN RECORD 12200000 SPACE 2 12220000 *ADDRESS DISPLACEMENTS 12240000 RSTART EQU 0 START OF RECORD TYPE TABLE 12260000 RTYP EQU 1 RECORD IDENTIFICATION 12280000 RLEN EQU 4 INITIAL LENGTH 0 OR 4 12300000 RESID EQU 6 ESID OR BLANKS 12320000 RMAX EQU 12 MAXIMUM NUMBER OF BYTES IN REC 12340000 RMOV EQU 14 START OF MOVE ROUTINE 12360000 INFL EQU 10 LENGTH OF INFORM IN A RECORD 12380000 SPACE 2 12400000 * BIT PATTERNS 12420000 SDENTRY EQU X'00' SD-ENTRY IDENTIFICATION 12440000 LDENTRY EQU X'01' LD-ENTRY IDENTIFICATION 12460000 RLDFLAG EQU B'00001100' FLAG USED IN RLD-ENTRY 12480000 SPACE 3 12500000 DS 0H 12520000 GENRLD EQU *-ABB1 START OF GENERATE RLD-RECORDS 12540000 LA RETURN,6(0,LENGTH) COMPUTE RETURN ADDRESS 12560000 LA TYPER,RLDT INDICZTE RLD-CALL 12580000 LH LENGTH,0(0,LENGTH) LOAD LENGTH GIVEN IN CALL 12600000 SLL LENGTH,1 DOUBLE LENGTH 12620000 B GEN1 CONTINUE COMMON PART 12640000 * 12660000 GENTXTS EQU *-ABB1 START OF GENERATE TXT-RECORD,S 12680000 LA RETURN,2(0,LENGTH) COMPUTE RETURN ADDRESS 12700000 LH LENGTH,0(0,LENGTH) LOAD LENGTH GIVEN IN CALL 12720000 B GEN2 CONTINUE TXT-ENTRY 12740000 * 12760000 * 12780000 GENTXTP4 EQU *-SBRSTRT GENERATE RX OR RS INST.,CHANGE PREC. 12800000 XI GENTXT6+7(SBR),X'06' MODIFY LENGTH INSTRUCTION 12820000 GENTXTP2 EQU *-SBRSTRT GENERATE RR INST.,CHANGE PRECISION 12840000 OC 0(1,INFORM),PRECMASK(WAREG) MODIFY INSTR. L OR S 12860000 GENTXT2 EQU *-ABB1 START OF GENERATE TXT-RECORD,2 12880000 XI GENTXT6+7(SBR),X'06' MODIFY LENGTH INSTRUCTION 12900000 * 12920000 GENTXT4 EQU *-ABB1 START OF GENERATE TXT-RECORD,4 12940000 XI GENTXT6+7(SBR),X'02' MODIFY LENGTH INSTRUCTION 12960000 * 12980000 GENTXT6 EQU *-ABB1 START OF GENERATE TXT-RECORD,6 13000000 ST LENGTH,PLACE14(0,WAREG) SAVE LENGTH REGISTER 13020000 LA LENGTH,6 LENGTH=2,4 OR 6 13040000 MVI GENTXT6+7(SBR),X'06' RESTORE MODIFIED INSTR. 13060000 LA RETURN,0(INFORM,LENGTH) COMPUTE RETURN ADDRESS 13080000 GEN2 LA TYPER,TXTT INDICATE TXT-CALL 13100000 SPACE 3 13120000 GEN1 L OUTAREA,SAVOUTA(WAREG) FETCH OLD OUTPUT RECORD ADD. 13140000 TM HCOMPMOD+1(WAREG),X'60' LOAD OR DECK SPECIFIED 13160000 BO GEN4+6 NO OUT OF GENERATE 13180000 TM HCOMPMOD(WAREG),X'80' 13200000 BO GEN4+6 13220000 CLC RTYP(3,OUTAREA),RTYP(TYPER) RECORD RIGTH TYPE 13240000 BNE GEN3 NO,CALL IOR NEW 13260000 CLC INFL(2,OUTAREA),RMAX(TYPER) RECORD FILLED 13280000 BNL GEN3 YES,CALL FOR NEW 13300000 GEN6 EQU * 13320000 LA L,56 13340000 LH REG0,INFL(0,OUTAREA) REG0=LENGTH OF INFORM IN REC 13360000 SR L,REG0 L=EMPTY POS LEFT IN RECORD 13380000 CR L,LENGTH ENOUTH SPACE LEFT 13400000 BL *+6 NO 13420000 LR L,LENGTH YES L=LENGTH FROM CALL 13440000 AR L,REG0 13460000 STH L,INFL(0,OUTAREA) INSERT NEW LENGTH INTO RECORD 13480000 * 13500000 SR L,REG0 13520000 AR OUTAREA,REG0 START ADDRESS WITHIN RECORD 13540000 SR LENGTH,L REMAINING LENGTH 13560000 B RMOV(TYPER) TO DIFFERENT MOVE ROUTINES 13580000 * 13600000 GEN4 LTR LENGTH,LENGTH MORE INFORMATION MUST BE MOVED 13620000 BH GEN3 YES 13640000 L LENGTH,PLACE14(0,WAREG) RESTORE REG LENGTH 13660000 BR RETURN 13680000 SPACE 3 13700000 GEN3 EQU * CALL FOR NEW OUTPUT RECORD 13720000 PUNCH ST LENGTH,SAVELT SAVE LENGTH 13740000 TM HCOMPMOD+1(WAREG),X'60' BOTH LOAD AND DECK SPECIFIED 13760000 BZ BOTH YES 13780000 TM HCOMPMOD+1(WAREG),NDCK ONLY DECK 13800000 L OUTAREA,PCHADD(WAREG) IF ONLY DECK 13820000 BZ PUT1 YES 13840000 L OUTAREA,LINADD(WAREG) SYSLIN OUTPUT 13860000 PUT1 PUT (OUTAREA) PUT FOR SYSLIN AND SYSPUNCH IF 13880000 ST OUTAREA,SAVOUTA(WAREG) SYSPUNCH OR SYSLIN ADDRESS 13900000 L LENGTH,SAVELT RESTORE LENGTH 13920000 B PUNCHOUT OUT OF ROUTINE PUNCH 13940000 BOTH L LENGTH,OUTAREA2(WAREG) COPY SYSLIN B. INTO SYSPUNCH 13960000 L OUTAREA,SAVOUTA(WAREG) 13980000 MVC 0(80,LENGTH),0(OUTAREA) BUFFER 14000000 PUT2 L OUTAREA,PCHADD(WAREG) 14020000 PUT (OUTAREA) PUT FOR SYSPUNCH WHEN BOTH HAS 14040000 ST OUTAREA,OUTAREA2(WAREG) *BEEN SPECIFIED 14060000 B PUT1-4 GO TO PUT SYSLIN 14080000 PUNCHOUT EQU * 14100000 MVC 0(4,OUTAREA),RSTART(TYPER) INSERT FIRST 4 BYTES 14120000 MVI 4(OUTAREA),C' ' INSERT ONE BLANK 14140000 MVC 5(67,OUTAREA),4(OUTAREA) BLANK OUTPUT RECORD 14160000 MVC 72(4,OUTAREA),PIDENT(WAREG) INSERT PROGRAM IDENT 14180000 L L,SEQU(WAREG) STEP 14200000 LA L,1(0,L) SEQUENCE 14220000 ST L,SEQU(WAREG) NR 14240000 CVD L,DBL CONVERT 14260000 UNPK 76(4,OUTAREA),DBL+5(3) TO DECIMAL 14280000 MVZ 79(1,OUTAREA),76(OUTAREA) 14300000 MVC 10(2,OUTAREA),RLEN(TYPER) INSERT INITIAL LENGTH 14320000 MVC 14(6,OUTAREA),RESID(TYPER) INSERT ESID+R AND P 14340000 CLC TXTT+1(3),RTYP(TYPER) TXT-RECORD PROCESSED 14360000 BNE GEN6 NO 14380000 ST PRPOINT,4(OUTAREA) YES INSERT PRPOINT 14400000 MVI 4(OUTAREA),C' ' 14420000 B GEN6 14440000 SPACE 3 14460000 * TABLES AND MOVE ROUTINES 14480000 SPACE 2 14500000 TXTT DS 0H START OF TXT-RECORD TABLE 14520000 DC X'02' CARD CODE 14540000 DC C'TXT' IDENTIFICATION 14560000 DC H'0' INITIAL LENGTH 0 14580000 DC H'1' ESID 14600000 DC C' ' 14620000 DC H'56' MAXIMUM LENGTH 14640000 GEN8 EQU * MOVE TXT-INFORMATION TO OUTAREA 14660000 BCTR L,0 L=L-1 14680000 STC L,*+5 INSERT PROPER LENGTH TO MOVE 14700000 MVC 16(0,OUTAREA),0(INFORM) MOVE INFORM TO OUTAREA 14720000 LA PRPOINT,1(L,PRPOINT) INCREASE PROGRAM POINTER 14740000 LA INFORM,1(L,INFORM) MODIFY DATA ADDRESS 14760000 B GEN4 OUT OF MOVE TXT ROUTINE 14780000 SPACE 3 14800000 RLDT DS 0H START OF RLD-RECORD TABLE 14820000 DC X'02' CARD CODE 14840000 DC C'RLD' IDENTIFICATION 14860000 DC H'0' INITIAL LENGTH 0 14880000 DC C' ' 14900000 RANDP DC H'1',H'1' R AND P ESID ARE 1 AT START 14920000 DC H'56' MAXIMUM LENGTH IN RECORD 14940000 GEN9 EQU * MOVE RLD-INFORMATION TO OUTAREA 14960000 AR L,OUTAREA INDICATE LAST ENTRY 14980000 GEN5 MVC 16(4,OUTAREA),RANDP 15000000 ST INFORM,20(OUTAREA) MOVE PROGRAM POINTER VALUE AND 15020000 MVI 20(OUTAREA),RLDFLAG * FLAG TO OUTAREA 15040000 LA OUTAREA,8(OUTAREA) NEXT ENTRY 15060000 LA INFORM,4(0,INFORM) NEXT PROGRAM POINTER VALUE 15080000 CR OUTAREA,L LAST COLUMN FILLED 15100000 BL GEN5 NO,CONTINUE 15120000 B GEN4 OUT OF MOVE RLD ROUTINE 15140000 SPACE 3 15160000 * VARIABLES AND CONSTANTS 15180000 SPACE 15200000 DBL DS D FOR CONV OF SEQUENCE NR 15220000 SAVELT DS F SAVE AREA FOR LENGTH 15240000 EJECT 15260000 DS 0H 15280000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 15300000 * * 15320000 * SUBROUTINE CLEAR REGISTERS 15340000 * * 15360000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 15380000 * * 15400000 * CALL BAL RETURN,CLEARRG(0,SBR) * 15420000 * GENERATES STORE INSTRUCTIONS FOR ALL REGISTERS THAT CONTAIN 15440000 * VALID INFORMATION- SET CII,CIR,RII,RIR. 15460000 * * 15480000 SPACE 2 15500000 CLEARRG EQU *-SBRPOOL 15520000 MVI GPBN+1(WAREG),X'FF' DESTROY GDSA 15540000 ST RETURN,RETADR(0,WAREG) STORE RETURN ADDRESS 15560000 SR R14,R14 15580000 BCTR R14,0 15600000 BCTR R14,0 15620000 LH R2,RIR(0,WAREG) 15640000 KIF22 LA R14,2(0,R14) 15660000 LTR R2,R2 15680000 BZ KIF21 BRANCH IF YES 15700000 SRDL R2,1 15720000 LTR R3,R3 15740000 BC 10,KIF22 BRANCH IF NO 15760000 ST R2,RETADR+64(WAREG) 15780000 BAL RETURN,ROUTIN13(0,SBR) 15800000 L R2,RETADR+64(0,WAREG) 15820000 B KIF22 15840000 KIF21 MVI CIR(WAREG),X'00' 15860000 MVI CIR+1(WAREG),X'06' 15880000 MVC RIR(2,WAREG),ZEROHW(WAREG) CLEAR RIR 15900000 SR R14,R14 15920000 BCTR R14,0 15940000 LH R2,RII(0,WAREG) 15960000 KIF25 LA R14,1(0,R14) 15980000 LTR R2,R2 16000000 BZ KIF24 BRANCH IF YES 16020000 SRDL R2,1 16040000 LTR R3,R3 16060000 BC 10,KIF25 BRANCH IF NO 16080000 ST R2,RETADR+64(WAREG) 16100000 BAL RETURN,ROUTINE9(0,SBR) 16120000 L R2,RETADR+64(WAREG) 16140000 B KIF25 16160000 KIF24 MVI CII(WAREG),X'00' 16180000 MVI CII+1(WAREG),X'07' 16200000 MVC RII(2,WAREG),ZEROHW(WAREG) CLEAR RII 16220000 L RETURN,RETADR(0,WAREG) LOAD RETURN ADDRESS 16240000 BR RETURN 16260000 EJECT 16280000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 16300000 * * 16320000 * O P E R A N D R E C O G N I Z E R * 16340000 * * 16360000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 16380000 * CALL BAL RETURN,OPDREC(SBR) 16400000 * CHECK IF OPERAND IN STACK IS A FORMAL PARAMETER OR A PROCEDURE 16420000 * WITHOUT PARAMETERS .OPDREC GENERATES AN ACTUAL PARAMETER OR A 16440000 * PROCEDURE CALL . 16460000 * IF OPERAND IS A FORMAL PARAMETER CALLED BY VALUE LABEL OR ARRAY 16480000 * OPDREC GENERATES LOAD OF REGISTERS GDSA AND/OR ADR 16500000 SPACE 2 16520000 * ADDRESS DISPLACEMENTS 16540000 TYPS EQU 1 SECOND BYTE TYPE IN IDENTIFIER 16560000 NUMP EQU 3 NR OF PARAMETERS IN IDENTIFIER 16580000 PBNP EQU 2 DISP OF PBN IN IDENTIFIER 16600000 TYPF EQU 0 FIRST BYTE TYPE IN IDENTIFIER 16620000 RUTIADR EQU 4*8 ENTRY IN RUTI-TABLE FOR ADR 16640000 SPACE 2 16660000 * BIT PATTERNS 16680000 VARIAM EQU X'30' MASK FOR VARIABLE 16700000 INTRVM EQU X'7F' INTERMIDIATE VALUE IN STACK 16720000 INTRRM EQU X'60' INTERMIDIATE VALUE ADDR.IN REG. 16740000 DESTROY EQU X'FF' INDICATE THAT GDSA IS NOT VALID 16760000 ARRAYM EQU X'04' ARRAY IDENTIFIER MASK 16780000 LABARRM EQU X'0C' LABEL OR ARRAY IDENTIFIER MASK 16800000 NOTMIX EQU 9 16820000 RIIADRM EQU X'01' RII-MASK FOR RESERVATION OF ADR 16840000 FORMPM EQU X'30' FORMAL PARAMETER MASK 16860000 PROCM EQU X'C0' PROCEDURE MASK 16880000 ZERO EQU 8 16900000 NOTZERO EQU 5 16920000 STPROCM EQU X'40' STANDARD PROCEDURE MASK 16940000 PARAM EQU X'F0' NUMBER OF PARAMETER MASK 16960000 FUNCPM EQU X'03' FUNCTION PROCEDURE MASK 16980000 VALUEM EQU X'20' VALUE PARAMETER SPEC. 17000000 REGADRM EQU ADR*16 REGISTER ADR MASK 17020000 SPACE 2 17040000 DS 0H 17060000 OPDREC EQU *-SBRSTRT START OF OPERAND RECOGNIZER IN SBR 17080000 TM 0(OPDK),X'C0' IDENTIFIER FROM ITAB 17100000 BCR 12,RETURN NO RETURN 17120000 TM TYPS(OPDK),FORMPM OPERAND FORMAL PARAMETER 17140000 ST RETURN,SAVRT SAVE RETURN ADDRESS 17160000 BM OPDREC1 YES,FORMAL 17180000 TM TYPS(OPDK),PROCM PROCEDURE IDENTIFIER 17200000 BCR ZERO,RETURN NO,RETURN 17220000 TM TYPS(OPDK),STPROCM STANDARD PROCEDURE 17240000 BCR ZERO,RETURN YES,RETURN 17260000 TM NUMP(OPDK),PARAM PARAMETERLESS PROCEDURE 17280000 BCR NOTZERO,RETURN NO,RETURN 17300000 SPACE 1 17320000 * EQU * PARAMETERLESS PROCEDURE FOUND 17340000 BAL RETURN,CLEARRG(0,SBR) CLEAR ALL OBJ.TIME REGISTERS 17360000 MVC PPCODE+2(2),NUMP(OPDK) INSERT DISPL. OF LABEL 17380000 MVC PPCODE+5(1),PBNP(OPDK) INSERT PROGRAM BLOCK NR 17400000 LA INFORM,PPCODE GENERATE A PARAMETERLESS 17420000 BAL LENGTH,GENTXTS(0,SBR) *PROCEDURE 17440000 DC H'12' *CALL 17460000 TM TYPS(OPDK),FUNCPM FUNCTION PROCEDURE 17480000 L RETURN,SAVRT 17500000 BCR ZERO,RETURN NO,RETURN 17520000 SPACE 1 17540000 * EQU * PARAMETERLESS FUNCTION PROC.FOUND 17560000 B OPDREC4 17580000 OPDREC1 EQU * FORMAL PARAMETER FOUND 17600000 TM TYPS(OPDK),VALUEM CALLED BY NAME 17620000 BO OPDREC3 NO 17640000 SPACE 1 17660000 * EQU * FORMAL PARAMETER CALLED BY NAME 17680000 BAL RETURN,CLEARRG(0,SBR) CLEAR ALL OBJ.TIME REGISTERS 17700000 SR REGGEN,REGGEN 17720000 IC REGGEN,PBNP(0,OPDK) PROCEDURE PBN FROM IDENTIFIER 17740000 SLL REGGEN,3 DISPLACEMENT IN PBT 17760000 STH REGGEN,CAP+4 *INSERTED IN CAP CODE 17780000 LH REGGEN,SPBNST(0,WAREG) CURRENT PBN 17800000 SLL REGGEN,3 *DISPLACEMENT IN PBT 17820000 STH REGGEN,CAP+6 *INSERTED IN CAP CODE 17840000 MVC CAP+10(2),NUMP(OPDK) INSERT FORMAL PARAM. DISPL 17860000 LA INFORM,CAP GENERATE CALL ACTUAL PARAMETER 17880000 BAL LENGTH,GENTXTS(0,SBR) *CODE 17900000 DC H'12' 17920000 TM TYPS(OPDK),PROCM PROCEDURE 17940000 BZ OPDREC4 NO 17960000 TM PROCWPS(SBR),X'80' 17980000 BO OPDREC4 NOT PARAMETERLESS,SET IN CP57 18000000 LA INFORM,OPDREC6 GENERATE 18020000 BAL LENGTH,GENTXTS(SBR) * CHECK FOR PARAMETERLESS 18040000 DC H'10' *PROCEDURE 18060000 OPDREC4 AH P,ONEENTRY(0,WAREG) RESERVE ONE ENTRY IN OBJ.STACK 18080000 STH P,SPBNST+2(0,WAREG) INSERT NEW DISPL. AND 18100000 MVC PBNP(3,OPDK),SPBNST+1(WAREG) *PBN IN INTERNAL NAME 18120000 XI TYPF(OPDK),INTRRM ADDRESS OF OPERAND IN REGISTER 18140000 OI NUMP(OPDK),REGADRM INDICATE REGISTER ADR 18160000 ST OPDK,RUTI+RUTIADR(0,WAREG) GPR CONTROL ENTRY RUTI 18180000 OI RII(WAREG),RIIADRM GPR CONTROL ENTRY RII 18200000 L RETURN,SAVRT 18220000 TM TYPS(OPDK),ARRAYM 18240000 BCR 1,RETURN 18260000 TM TYPS(OPDK),X'03' 18280000 BCR 8,RETURN 18300000 MVI PBNP(OPDK),X'00' INDICATE SPECIAL ADDRESS.ADR 18320000 * MAY POINT TO FCTVALST IN FSA 18340000 * ROUTINE 9 CHECK THIS 18360000 BR RETURN RETURN 18380000 SPACE 1 18400000 OPDREC3 EQU * FORMAL PARAMETER CALLED BY VALUE 18420000 TM TYPS(OPDK),LABARRM LABEL OR ARRAY IDENTIFIER 18440000 BCR NOTMIX,RETURN NO,RETURN 18460000 BAL RETURN,ROUTINE3(0,SBR) GENERATE LOAD ADR 18480000 AH P,ONEENTRY(0,WAREG) OBJECT TIME STACK NOT RELEASED 18500000 TM TYPS(OPDK),ARRAYM ARRAY IDENTIFIER 18520000 BO OPDREC4 YES,INTERNAL NAME AND REG.CONTR 18540000 LA REGGEN,4 18560000 AH REGGEN,GRD3+2 ADD 4 TO DISP,GRD3 IN ROUTINE3 18580000 STH REGGEN,OPDREC5+2 INSERT DISP.+4(CDSA OR GDSA) 18600000 MVN OPDREC5+1(1),GRD3+1 * IN LOAD GDSA INSTR. 18620000 BAL INFORM,GENTXT4(0,SBR) GENERATE A LOAD GDSA 18640000 OPDREC5 L GDSA,DISP+4 *INSTRUCTION 18660000 MVI GPBN+1(WAREG),DESTROY NOTE THAT GDSA IS DESTROYED 18680000 B OPDREC4 INTERNAL NAME AND REG.CONTROL 18700000 SPACE 3 18720000 *CONSTANTS AND VARIABLES 18740000 SPACE 18760000 PPCODE L ADR,DISP(LAT,0) PARAMETERLESS PROCEDURE CALL 18780000 MVI PROLPBN(FSA),DISP *CODE,DISP INSERTED 18800000 BAL BRR,PROLOG(0,FSA) *CODE IS 12 BYTES 18820000 SPACE 18840000 * CALL ACTUAL PARAMETER,GENERATED CODE,DISPL,PBNP AND PBNC INSERTED 18860000 CAP EQU * CALL ACTUAL PARAMETER CODE 18880000 BAL BRR,CAP1(0,FSA) TO CAP SUBROUTINE FIRST PART 18900000 DS H PBNP,PBN-DISP OF PROCEDURE 18920000 DS H PBNC,PBN-DISP OF CURRENT BLOCK 18940000 L ADR,DISP(CDSA,0) THUNK-ADDR FROM PROCEDURE DSA 18960000 OPDREC6 LA STH,FCTVALST(FSA) CHECK THAT ACTUAL 18980000 CR STH,ADR *PARAMETER PROCEDURE 19000000 BNE OERR21(FSA) *IS PARAMETERLESS 19020000 SPACE 19040000 SAVRT DS F SAVE AREA FOR RETURN 19060000 PROCWPS EQU *-SBRSTRT SWITCH TO AVOID PARAMETER- 19080000 DC X'00' *LESS PROCEDURE CHECK 19100000 EJECT 19120000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 19140000 * * 19160000 * S U B R O U T I N E M A X C H E C K * 19180000 * * 19200000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 19220000 DS 0H 19240000 MAXCH EQU *-SBRSTRT SUBROUTINE TO CHECK THAT OBJECT TIME 19260000 * STACK POINTER VALUE IS LESS THAN MAX 19280000 * VALUE PLACED IN WORKPL BY 19300000 * CALLING ROUTINE 19320000 SPACE 1 19340000 * CALL BAL RETURN,MAXCH(SBR) 19360000 * 19380000 SPACE 19400000 * REGISTER DEFINITIONS 19420000 REGGEN EQU 3 VARIABLE USE 19440000 R EQU RETURN VARIABLE USE 19460000 REGONE EQU 15 FIRST REG DESTROYED BY SERR1 19480000 SPACE 19500000 * BIT PATTERNS 19520000 SYNTCM EQU X'80' SYNTAX CHECK MODE MASK 19540000 SPACE 2 19560000 STM REGONE,RETURN,MCHSAV SAVE REGISTERS 19580000 LH R,WORKPL(0,WAREG) FETCH CHECKVALUE FROM WORKAREA 19600000 LH REGGEN,SPBNST(0,WAREG) CURRENT PBN FROM WORKAREA 19620000 SLL REGGEN,2 PBT-DISPLACEMENT 19640000 CH R,PBTAB3(REGGEN,WAREG) R LESS THAN MAX IN PBTAB3 19660000 BNH MAXCH1 YES,RETURN 19680000 STH R,PBTAB3(REGGEN,WAREG) INSERT R AS NEW MAX 19700000 CH R,MAXOVERF(0,WAREG) OVERFLOW OF OBJECT TIME STACK 19720000 BNH MAXCH1 NO,RETURN 19740000 CR P,R HAS P ALREADY BEEN RESET 19760000 BL MAXCH1 YES, NO ERROR MSG 19780000 SR P,P NO, RESET P TO ZERO 19800000 BAL SRETURN,SERRSP(0,SBR) ERROR PATTERN GENERATION 19820000 DC H'214' ERROR 214 19840000 MAXCH1 LM REGONE,RETURN,MCHSAV RESTORE REGISTERS 19860000 BR RETURN RETURN 19880000 SPACE 2 19900000 * VARIABLES AND CONSTANTS 19920000 SPACE 19940000 MCHSAV DS 6F SAVE AREA FOR REGISTERS 19960000 EJECT 19980000 DS 0H 20000000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 20020000 * * 20040000 * SEMICOLON COUNTER HANDLING * 20060000 * * 20080000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 20100000 * CALL BAL RETURN,SCHDL(SBR) 20120000 * SET SEMICOLON COUNTER AND MOVE SOURCE POINTER 20140000 * IN SOURCE STRING 20160000 * GENERATES SEMICOLON TRACE IF OPTION SPECIFIED 20180000 * 20200000 SPACE 2 20220000 SCHDL EQU *-SBRPOOL 20240000 ST RETURN,SCHDLR(SBR) SAVE RETURN ADDRESS 20260000 MVC SCSC(2,WAREG),1(SOURCE) STORE SEMICOLON NR 20280000 LA SOURCE,2(SOURCE) STEP SOURCE POINTER 20300000 * 20320000 * GENERATE BRANCH TO TRACE-ROUTINE 20340000 * 20360000 MVC SCHDL1(2),SCSC(WAREG) SC NR TO GENERATED CODE 20380000 TM HCOMPMOD+2(WAREG),NOTEST 20400000 BO SCHDL1+2 NO SEMICOLON TRACE GEN 20420000 BAL INFORM,GENTXT6(SBR) 20440000 BAL BRR,TRACE(FSA) **GENERATED CODE** 20460000 SCHDL1 DC H'0' **GENERATED CODE** 20480000 SPACE 20500000 L RETURN,SCHDLR(SBR) 20520000 BR RETURN 20540000 SPACE 20560000 DS 0F 20580000 SCHDLR EQU *-SBRPOOL TO SAVE RETURN ADDRESS 20600000 DS F 20620000 EJECT 20640000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 20660000 * * 20680000 * ROUTINE NR. 1 * 20700000 * * 20720000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 20740000 * * 20760000 * * 20780000 * LOAD IN W-PLACE THE DISPLACEMENT OF AN OPERAND THAT IS NOT AN ADDRESS 20800000 * LOAD IN V-PLACE AA OR 99 DEPENDING ON WHERE THE VARIABLE,CONSTANT OR 20820000 * INTERMEDIATE RESULT IS AND GENERATES A LOADING OF GDSA IF NECESSARY 20840000 * * 20860000 * * 20880000 * CALL BAL RETURN,ROUTINE1(0,SBR) 20900000 SPACE 20920000 ROUTINE1 EQU *-SBRPOOL 20940000 MVC WPLACE(2,WAREG),3(OPDK) MOVE DISPL OF LO TO W 20960000 GPE2 MVI VPLACE(WAREG),X'AA' MOVE CDSA REG TO V 20980000 CLC 2(1,OPDK),SPBNST+1(WAREG) IS PBN OF LO CDSA 21000000 BCR 8,RETURN RETURN IF CURRENT DSA 21020000 GPE3 MVI VPLACE(WAREG),X'99' MOVE GLOBAL DSA REG TO V 21040000 CLI GPBN+1(WAREG),X'FF' IS C(GDSA) DESTROYED 21060000 BE GPC3 BRANCH IF DESTROYED 21080000 CLC GPBN(1,WAREG),2(OPDK) COMPARE GDSA WITH PBN OF LO 21100000 BCR 8,RETURN RETURN IF EQUAL 21120000 GPC31 SR R1,R1 CLEAR R1 21140000 ST RETURN,RETADR+4(0,WAREG) STORE RETURN ADDRESS 21160000 MVC GPBN(1,WAREG),2(OPDK) KEEP NEW LOADED GDSA 21180000 IC R1,2(0,OPDK) LOAD IN R1 PBN OF LO 21200000 SLA R1,3 MULTIPLY BY 8 21220000 STH R1,WORKPL(0,WAREG) PREPARE INSTRUCTION 21240000 MVC GPC4+2(2),WORKPL(WAREG) 21260000 BAL INFORM,GENTXT4(0,SBR) GENERATE 21280000 GPC4 L GDSA,0(PBT,0) 21300000 L RETURN,RETADR+4(0,WAREG) LOAD RETURN ADDRESS 21320000 BR RETURN RETURN 21340000 GPC3 MVI GPBN+1(WAREG),X'00' RECONSTRUCT GDSA 21360000 B GPC31 21380000 EJECT 21400000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 21420000 * * 21440000 * ROUTINE NR. 2 * 21460000 * * 21480000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 21500000 * * 21520000 * * 21540000 * GENERATES A LOAD INSTRUCTION INTO THE FLOATING POINT REGISTER 21560000 * SPECIFIED BY R14 OF AN OPERAND THAT IS AN ADDRESS- ADJUSTS THE 21580000 * OPERAND, STORES OPERAND STACK ADDRESS INTO RUTR 21600000 * * 21620000 * * 21640000 * CAL BAL RETURN,ROURINE2(0,SBR) 21660000 SPACE 2 21680000 ROUTINE2 EQU *-SBRPOOL 21700000 ST RETURN,RETADR+8(WAREG) STORE RETURN ADDRESS 21720000 LA OPDK,5(0,OPDK) INCREASE OPDK 21740000 BAL RETURN,ROUTINE3(0,SBR) BRANCH TO ROUTINE NR.3 21760000 GQE3 SLL R14,1 INTRODUCE OPDK ADD IN RUTR 21780000 ST OPDK,RUTR(R14,WAREG) 21800000 SLL R14,3 PREPARE INSTRUCTION 21820000 STC R14,GQD3+1 21840000 MVN GQD3+1(1),VPLACE(WAREG) 21860000 MVC GQD3+2(2),WPLACE(WAREG) 21880000 BAL INFORM,GENTXTP4(0,SBR) 21900000 GQD3 LD 0,0(0,0) ***GENERATE*** 21920000 GQF3 SRL R14,4 21940000 SH OPDK,CON5(0,SBR) REDUCE OPDK 21960000 STH P,WORKPL(0,WAREG) INTROD. P INTO OPDK ENTRY 21980000 MVC 8(2,OPDK),WORKPL(WAREG) 22000000 MVZ 8(1,OPDK),GQD3+1 INTROD. REG. NUMBER 22020000 MVC 7(1,OPDK),SPBNST+1(WAREG) INTROD. PBN 22040000 OI 5(OPDK),X'80' ADJUST OPDK ENTRY 22060000 NI 5(OPDK),X'9F' 22080000 L RETURN,RETADR+8(WAREG) LOAD RETURN ADDRESS 22100000 BR RETURN 22120000 EJECT 22140000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 22160000 * * 22180000 * ROUTINE NR. 3 22200000 * * 22220000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 22240000 * * 22260000 * * 22280000 * LOAD IN W-PLACE ZERO. LOAD IN V-PLACE 88. GENERATES A LOADING OF ADR 22300000 * IF NECCESSARY, IN THIS CASE THE OPERAND IS AN ADDRESS 22320000 * * 22340000 * * 22360000 * CALL BAL RETURN, ROUTINES3(0,SBR) 22380000 SPACE 22400000 ROUTINE3 EQU *-SBRPOOL 22420000 ST RETURN,RETADR+12(0,WAREG) STORE RETURN ADDRESS 22440000 TM 0(OPDK),X'40' IS ADDRESS OF LO IN ADR 22460000 BO GRC3 BRANCH IF NOT 22480000 MVI RII(WAREG),X'00' CLEAR RIT OF ADR 22500000 GRE3 SH P,ONEENTRY(0,WAREG) REDUCE P BY 8 22520000 GRG2 MVI VPLACE(WAREG),X'88' V EQUAL ADR 22540000 MVC WPLACE(2,WAREG),ZEROHW(WAREG) W EQUAL ZERO 22560000 L RETURN,RETADR+12(0,WAREG) LOAD RETURN ADDRESS 22580000 BR RETURN RET 22600000 GRC3 TM RII(WAREG),X'01' IS ADR FREE 22620000 BZ GRD31 BRANCH IF FREE 22640000 GRC4 ST R14,RETADR3 22660000 BAL RETURN,ROUTIN10(0,SBR) 22680000 L R14,RETADR3 22700000 GRD31 BAL RETURN,ROUTINE1(0,SBR) BRANCH TO ROUTINE1 22720000 MVC GRD3+2(2),WPLACE(WAREG) MOVE DISPLACEMENT 22740000 MVN GRD3+1(1),VPLACE(WAREG) MOVE BASE REG 22760000 BAL INFORM,GENTXT4(0,SBR) GENERATE 22780000 GRD3 L ADR,0(0,0) ***GENERATE*** 22800000 ST OPDK,RUTI+32(0,WAREG) 5601 22810018 B GRE3 22820000 DS 0F 22840000 RETADR3 DS F 22860000 EJECT 22880000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 22900000 * * 22920000 * ROUTINE NR. 4 22940000 * * 22960000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 22980000 * * 23000000 * * 23020000 * GENERATES A LOAD INSTRUCTION INTO THE FLOATING POINT REGISTER 23040000 * SPECIFIED BY R14 OF AN OPERAND THAT IS NOT AN ADDRESS- ADJUSTS THE 23060000 * OPERAND AND STORES THE OPERAND STACK ADDRESS INTO RUTR 23080000 * * 23100000 * * 23120000 * CALL BAL RETURN,ROUTINE4(0,SBR) 23140000 SPACE 23160000 ROUTINE4 EQU *-SBRPOOL 23180000 ST RETURN,RETADR+8(WAREG) STORE RETURN ADDRESS 23200000 LA OPDK,5(0,OPDK) INCREASE OPDK 23220000 BAL RETURN,ROUTINE1(0,SBR) BRANCH TO ROUTINE NR1 23240000 OI 1(OPDK),X'30' SET TO VARIABLE 23260000 B GQE3 BRANCH TO ROUTINE NR2 23280000 SPACE 2 23300000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 23320000 * * 23340000 * ROUTINE NR. 5 23360000 * * 23380000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 23400000 * * 23420000 * * 23440000 * GENERATES A LOAD INSTRUCTION INTO A GENERAL PURPOSE REGISTER 23460000 * SPECIFIED BY R14 OF AN OPERAND THAT IS NOT AN ADDRESS- ADJUSTS THE 23480000 * OPERAND AND STORES THE OPERAND STACK ADDRESS INTO RUTI 23500000 * * 23520000 * * 23540000 * CALL BAL RETURN,ROUTINE5(0,SBR) 23560000 SPACE 23580000 ROUTINE5 EQU *-SBRPOOL 23600000 ST RETURN,RETADR+8(WAREG) STORE RETURN ADDRESS 23620000 LA OPDK,5(0,OPDK) INCREASE OPDK 23640000 BAL RETURN,ROUTINE1(0,SBR) BRANCH TO ROUTINE NR.1 23660000 OI 1(OPDK),X'30' SET TO VARIABLE 23680000 GTE3 SLL R14,2 INTRODUCE OPDK ADD IN RUTI 23700000 ST OPDK,RUTI(R14,WAREG) 23720000 SLL R14,2 PREPARE INSTRUCTION 23740000 STC R14,GTD3+1 23760000 STC R14,GQD3+1 23780000 MVN GTD3+1(1),VPLACE(WAREG) 23800000 MVC GTD3+2(2),WPLACE(WAREG) 23820000 BAL INFORM,GENTXT4(0,SBR) 23840000 GTD3 L 0,0(0,0) ***GENERATE*** 23860000 B GQF3 BRANCH TO ROUTINE NR.2 23880000 EJECT 23900000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 23920000 * * 23940000 * ROUTINE NR. 6 23960000 * * 23980000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 24000000 * * 24020000 * * 24040000 * GENERATES A LOAD INSTRUCTION INTO A GENRAL PURPOSE REGISTER 24060000 * SPECIFIED BY R14 OF AN OPERAND THAT IS AN ADDRESS- ADJUSTS THE 24080000 * OPERAND AND STORES THE OPERAND STACK ADDRESS INTO RUTI. 24100000 * * 24120000 * * 24140000 * CALL BAL RETURN,ROUTINE6(0,SBR) 24160000 SPACE 24180000 ROUTINE6 EQU *-SBRPOOL 24200000 ST RETURN,RETADR+8(WAREG) STORE RETURN ADDRESS 24220000 LA OPDK,5(0,OPDK) INCREASE OPDK 24240000 BAL RETURN,ROUTINE3(0,SBR) BRANCH TO ROUTINE NR 3 24260000 B GTE3 BRANCH TO ROUTINE NR 5 24280000 SPACE 24300000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 24320000 * * 24340000 * ROUTINE NR. 7 24360000 * * 24380000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 24400000 * * 24420000 * * 24440000 * LOADS INTO R14 THE NUMBER OF THE NEXT GENERAL PURPOSE REGISTER TO BE 24460000 * USED ACCORDING TO CII. IF IT IS OCCUPIED IT BRANCHES TO ROUTINE NR. 24480000 * 9 THAT GENERATES A STORE INSTRUCTION. CII AND RII ARE SET. RESERVES 24500000 * ONE OBJECT TIME STACK ENTRY. 24520000 * * 24540000 * * 24560000 * CALL BALL RETURN,ROUTINE7(0,SBR) 24580000 SPACE 24600000 ROUTINE7 EQU *-SBRPOOL 24620000 SR R14,R14 24640000 CLI CII+1(WAREG),X'07' CHECK IF CII IS 7 24660000 BE GVC2 BRANCH IF CII IS 7 24680000 IC R14,CII+1(0,WAREG) INCREASE CII BY ONE 24700000 LA R14,1(0,R14) 24720000 GVC2 STC R14,CII+1(0,WAREG) 24740000 LA R15,1 LOAD ONE INTO R15 24760000 SLL R15,0(R14) GENERATE MASK 24780000 STC R15,GVC21+1 24800000 GVC21 TM RII+1(WAREG),X'00' IS GPR OCCUPIED 24820000 BZ GVE2 BRANCH IF NOT OCCUPIED 24840000 ST RETURN,RETADR+28(0,WAREG) STORE RETURN ADDRESS 24860000 BAL RETURN,ROUTINE9(0,SBR) STOPINT 24880000 L RETURN,RETADR+28(0,WAREG) LOAD RETURN ADDRESS 24900000 GVE2 OC RII+1(1,WAREG),GVC21+1 SET TO ONE RII 24920000 GVF2 AH P,ONEENTRY(0,WAREG) INCREASE P 24940000 BR RETURN 24960000 EJECT 24980000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 25000000 * * 25020000 * ROUTINE NR.8 25040000 * * 25060000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 25080000 * * 25100000 * * 25120000 * THE LAST GENERAL PURPOSE REGISTER RESERVED IS RELEASED. CII AND RII 25140000 * ARE SET. ONE OBJECT STACK ENTRY IS RELEASED 25160000 * * 25180000 * * 25200000 * CALL BAL RETURN,ROUTINE8(0,SBR) 25220000 SPACE 25240000 ROUTINE8 EQU *-SBRPOOL 25260000 SR R14,R14 CLEAR R14 25280000 IC R14,CII+1(0,WAREG) LOAD CII INTO R14 25300000 LA R15,1 CLEAR RII OF LO 25320000 SLL R15,0(R14) 25340000 STC R15,GWD51+1 25360000 XI GWD51+1,X'FF' 25380000 GWD51 NI RII+1(WAREG),X'00' 25400000 SH P,ONEENTRY(0,WAREG) REDUCE P 25420000 GWD5 CLI CII+1(WAREG),X'00' IS CII EQUAL TO ZERO 25440000 BZ GWD3 BRANCH IF YES 25460000 BCTR R14,0 REDUCE BY ONE 25480000 STC R14,CII+1(0,WAREG) STORE NEW CII 25500000 SRL R15,1 IS GPR INDICATED BY 25520000 GWD6 STC R15,GWD4+1 CII FREE 25540000 GWD4 TM RII+1(WAREG),X'00' 25560000 BZ GWD5 BRANCH IF FREE 25580000 BR RETURN RETURN 25600000 GWD3 MVI CII+1(WAREG),X'07' MAKE CII = 7 25620000 LA R14,7 25640000 CLI RII+1(WAREG),X'00' ARE ALL GPR FREE 25660000 BCR 8,RETURN RETURN IF ALL FREE 25680000 LA R15,128 LOAD MASK 25700000 B GWD6 25720000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 25740000 * * 25760000 * ROUTINE NR. 10 25780000 * * 25800000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 25820000 * * 25840000 * * 25860000 * CLEARS RII OF ADR, LOADS 8 INTO R14 AND BRANCHES TO ROUTINE 9- 25880000 * * 25900000 * * 25920000 * CALL BAL RETURN,ROUTIN10(0,SBR) 25940000 SPACE 25960000 ROUTIN10 EQU *-SBRPOOL 25980000 MVI RII(WAREG),X'00' 26000000 LH R14,CON8(0,SBR) 26020000 EJECT 26040000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 26060000 * * 26080000 * ROUTINE NR. 9 26100000 * * 26120000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 26140000 * * 26160000 * * 26180000 * GENERATES CODE TO STORE GENERAL PURPOSE REGISTER SPECIFIED BY 214 26200000 * IF THE PBN IS NOT ZERO- IF THE PBN IS ZERO IT GENERATES A MOVE 26220000 * INSTRUCTION- THE OPERAND IS ADJUSTED 26240000 * * 26260000 * * 26280000 * CALL BAL RETURN,ROUTIN9(0,SBR) 26300000 SPACE 26320000 ROUTINE9 EQU *-SBRPOOL 26340000 ST RETURN,RETADR+36(0,WAREG) STORE RETURN ADDRESS 26360000 SLL R14,2 MULTIPLY BY 4 26380000 LA R15,RUTI(0,WAREG) LOAD ADD OF RUTI 26400000 L R15,0(R14,R15) LOAD ADD OF OPD TO STORE 26420000 SLL R14,2 PREPARE INSTRUCTION 26440000 NI 3(R15),X'0F' 26460000 ST R15,RETADR+48(WAREG) 26480000 TM 2(R15),X'FF' 26500000 BZ GXC4 26520000 LA R14,10(0,R14) 26540000 STC R14,GXC3+1 26560000 MVC GXC3+2(2),3(R15) PREPARE INSTRUCTION 26580000 BAL INFORM,GENTXT4(0,SBR) 26600000 GXC3 ST 0,0(CDSA,0) ***GENERATE*** 26620000 B HBC2 26640000 GXC4 MVC GXC5+2(2),3(R15) 26660000 OI GXC5+2,X'A0' 26680000 MVI GXC5+1,X'07' 26700000 TM HCOMPMOD(WAREG),X'02' 26720000 BO GXC6 26740000 MVI GXC5+1,X'03' 26760000 GXC6 NI 0(R15),X'DF' 26780000 MVC 2(1,R15),SPBNST+1(WAREG) 26800000 BAL INFORM,GENTXT6(0,SBR) 26820000 GXC5 MVC 0(4,CDSA),0(ADR) 26840000 B HBC2 26860000 EJECT 26880000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 26900000 * * 26920000 * ROUTINE NR. 11 26940000 * * 26960000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 26980000 * * 27000000 * * 27020000 * LOADS INTO R14 THE NUMBER OF THE NEXT FLOATING POINT REGISTER TO BE 27040000 * USED ACCORDING TO CIR, IF IT IS OCCUPIED IT BRANCHES TO ROUTINE 27060000 * NR. 13 THAT GENERATES A STORE INSTRUCTION. CIR AND RIR ARE 27080000 * SET. ONE OBJECT TIME ENTRY IS RESERVED 27100000 * * 27120000 * * 27140000 * CALL BAL RETURN,ROUTIN11(0,SBR) 27160000 SPACE 27180000 ROUTIN11 EQU *-SBRPOOL 27200000 SR R14,R14 CLEAR R14 27220000 CLI CIR+1(WAREG),X'06' CHECK IF CIR IS 6 27240000 BE GZC2 27260000 IC R14,CIR+1(WAREG) LOAD CIR INTO R14 27280000 LA R14,2(0,R14) INCREASE CIR BY 2 27300000 GZC2 STH R14,CIR(0,WAREG) STORE NEW CIR 27320000 SRL R14,1 DIVIDE R14 BY 2 27340000 LA R15,1 LOAD ONE INTO R15 27360000 SLL R15,0(R14) GENERATE MASK 27380000 SLL R14,1 27400000 STC R15,GZC21+1 27420000 GZC21 TM RIR+1(WAREG),X'00' IS FPR OCCUPIED 27440000 BZ GZE2 BRANCH IF FPR FREE 27460000 ST RETURN,RETADR+44(0,WAREG) STORE RETURN ADDRESS 27480000 BAL RETURN,ROUTIN13(0,SBR) STOPREAL 27500000 L RETURN,RETADR+44(0,WAREG) LOAD RETURN ADDRESS 27520000 GZE2 OC RIR+1(1,WAREG),GZC21+1 27540000 GZF2 AH P,ONEENTRY(0,WAREG) INCREASE P 27560000 BR RETURN 27580000 EJECT 27600000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 27620000 * * 27640000 * ROUTINE NR. 12 27660000 * * 27680000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 27700000 * * 27720000 * * 27740000 * THE LAST FLOATING POINT REGISTER RESERVED IS RELEASED. CIR AND RIR 27760000 * ARE SET. ONE OBJECT STACK ENTRY IS RELEASED 27780000 * * 27800000 * * 27820000 * CALL BAL RETURN,ROUTIN12(0,SBR) 27840000 SPACE 27860000 ROUTIN12 EQU *-SBRPOOL 27880000 LH R14,CIR(0,WAREG) LOAD INTO R14 CIR 27900000 LA R15,1 CLEAR RIR OF BLO 27920000 SRL R14,1 27940000 SLL R15,0(R14) 27960000 STC R15,HAD4+1 27980000 XI HAD4+1,X'FF' 28000000 HAD4 NI RIR+1(WAREG),X'00' 28020000 SH P,ONEENTRY(0,WAREG) REDUCE P 28040000 SLL R14,1 28060000 HAD1 CLI CIR+1(WAREG),X'00' 28080000 BZ HAD3 BRANCH IF YES 28100000 SH R14,CON2(0,SBR) 28120000 STC R14,CIR+1(0,WAREG) 28140000 SRL R15,1 28160000 HAD0 STC R15,HAD2+1 28180000 HAD2 TM RIR+1(WAREG),X'00' 28200000 BZ HAD1 28220000 BR RETURN 28240000 HAD3 MVI CIR+1(WAREG),X'06' MAKE CIR=6 28260000 LH R14,CIR(0,WAREG) 28280000 CLI RIR+1(WAREG),X'00' 28300000 BCR 8,RETURN 28320000 LA R15,8 28340000 B HAD0 28360000 EJECT 28380000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 28400000 * * 28420000 * ROUTINE NR. 14 28440000 * * 28460000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 28480000 * * 28500000 * * 28520000 * LOAD ZERO INTO R14 28540000 * * 28560000 * * 28580000 * CALL BAL RETURN,ROUTIN14(0,SBR) 28600000 SPACE 28620000 ROUTIN14 EQU *-SBRPOOL 28640000 SR R14,R14 28660000 SPACE 2 28680000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 28700000 * * 28720000 * ROUTINE NR. 13 28740000 * * 28760000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 28780000 * * 28800000 * * 28820000 * GENERATES CODE TO STORE FLOATING POINT REGISTER SPECIFIED BY R14 28840000 * THE OPERAND IS ADJUSTED 28860000 * * 28880000 * * 28900000 SPACE 28920000 ROUTIN13 EQU *-SBRPOOL STORE EPR INDICATED BY R14 28940000 ST RETURN,RETADR+36(0,WAREG) STORE RETURN ADDRESS 28960000 SLL R14,1 MULTIPLY R14 BY 2 28980000 LA R15,RUTR(0,WAREG) LOAD ADDRESS OF RUTR 29000000 L R15,0(R14,R15) LOAD OPDK ADDRESS OF OPERAND 29020000 SLL R14,3 SHIFT REG NR TO OREOARE INSTRUC 29040000 LA R14,10(0,R14) INTRODUCE CDSA 29060000 STC R14,HBC3+1 29080000 NI 3(R15),X'0F' 29100000 MVC HBC3+2(2),3(R15) 29120000 ST R15,RETADR+48(WAREG) 29140000 BAL INFORM,GENTXTP4(0,SBR) 29160000 HBC3 STD 0,0(CDSA,0) 29180000 HBC2 L R15,RETADR+48(WAREG) 29200000 XI 0(R15),X'C0' 29220000 MVC WORKPL(2,WAREG),3(R15) 29240000 BAL RETURN,MAXCH(0,SBR) 29260000 SRL R14,4 29280000 L RETURN,RETADR+36(0,WAREG) 29300000 BR RETURN RETURN 29320000 EJECT 29340000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 29360000 * * 29380000 * ROUTINE NR. 15 29400000 * * 29420000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 29440000 * * 29460000 * * 29480000 * IF THE OPERAND IS AN ADDRESS IT BRANCHES TO ROUTINE NR.3 IF THE 29500000 * OPERAND IS NOT AN ADDRESS AND IS IN A REGISTER IT GETS THE REGISTER 29520000 * NUMBER TO V-PLACE, ELSE IT BRANCHES TO ROUTINE NR. 1 29540000 * * 29560000 * * 29580000 * CALL BAL RETURN,ROUTIN15(0,SBR) 29600000 ROUTIN15 EQU *-SBRPOOL 29620000 TM 0(OPDK),X'20' 29640000 BO ROUTINE3(0,SBR) 29660000 TM 0(OPDK),X'40' 29680000 BZ ROUT151 29700000 TM 0(OPDK),X'80' 29720000 BO ROUTINE1(0,SBR) 29740000 SH P,ONEENTRY(WAREG) 29760000 B ROUTINE1(0,SBR) 29780000 ROUT151 IC R15,3(OPDK) GET 29800000 SRL R15,4 REG 29820000 STC R15,VPLACE(WAREG) NUMBER 29840000 MVZ VPLACE(1,WAREG),3(OPDK) TO VPLACE 29860000 BR R3 RETURN 29880000 EJECT 29900000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 29920000 * * 29940000 * DECOMPOSE OPERAND BY MOVING ITS PARTS 29960000 * INTO LOW ENDS OF HALFWORDS 29980000 * * 30000000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 30020000 * CALL BAL RETURN,DECOMP(0,SBR) * 30040000 SPACE 2 30060000 DECOMP EQU *-SBRPOOL 30080000 MVC OPDPBN+1(1,WAREG),2(OPDK) MOVE PBN 30100000 MVC OPDADR(2,WAREG),3(OPDK) MOVE ADDRESS 30120000 LH R1,OPDADR(WAREG) 30140000 N R1,HEXFFF(SBR) 30160000 STH R1,OPDLN(WAREG) LABEL NUMBER 30180000 BR RETURN 30200000 SPACE 3 30220000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 30240000 * * 30260000 * STACK ALL PURPOSE IDENTIFIER (API) 30280000 * * 30300000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 30320000 * CALL BAL RETURN,STACKAPI(SBR) 30340000 SPACE 30360000 STACKAPI EQU *-SBRPOOL 30380000 SH OPDK,CON5(SBR) 30400000 CR OPTK,OPDK 30420000 BNL STACKOFL(SBR) 30440000 MVC 0(5,OPDK),API(SBR) 30460000 BR RETURN 30480000 SPACE 3 30500000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 30520000 * * 30540000 * PROGRAM BLOCK NUMBER HANDLING * 30560000 * * 30580000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 30600000 * CALL BAL RETURN,PBNHDL(SBR) 30620000 * PROGRAM BLOCK NUMBER HANDLING INSERTS NEW PBN IN WORKAREA,SPBNST. 30640000 * SAVES REGISTER P IN PBTAB2 AND INSERTS NEW OBJECT TIME STACK POINTER 30660000 * VALUE TO P 30680000 SPACE 30700000 PBNHDL EQU *-SBRPOOL 30720000 SR R2,R2 30740000 IC R2,3(SOURCE) 30760000 CLI 0(SOURCE),X'0D' IS SOURCE OPERATOR BETA 30780000 BE PBNHDL1(SBR) YES 30800000 CLI 0(SOURCE),X'2A' IS SOURCE OPERATOR EPSILON 30820000 BNE PBNHDL2(SBR) NO 30840000 * (=BRANCH IF OPTR IS PI OR PHI) 30860000 PBNHDL1 EQU *-SBRPOOL 30880000 IC R2,1(SOURCE) OPERATOR IS BETA OR EPSILON 30900000 LA SOURCE,1(SOURCE) 30920000 PBNHDL2 EQU *-SBRPOOL 30940000 LH R1,SPBNST(WAREG) STORE 30960000 SLL R1,1 OLD 30980000 STH P,PBTAB2(R1,WAREG) P-VALUE 31000000 STC R2,SPBNST+1(WAREG) INSERT NEW PBN 31020000 SLL R2,1 GET DISP IN PBTAB2 31040000 LH P,PBTAB2(R2,WAREG) LOAD NEW P-VALUE 31060000 TM HCOMPMOD(WAREG),X'80' CMT 31080000 BCR 1,RETURN FALSE 31100000 B CLEARRG(SBR) CLEAR REGISTERS RETURN DIRECT 31120000 SPACE 3 31140000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 31160000 * * 31180000 * PARAMETERLESS PROCEDURE STATEMENT HANDLING 31200000 * * 31220000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 31240000 * CALL BAL RETURN,PLPRST(SBR) 31260000 * CHECKS THAT OPERAND IS A PARAMETERLESS PROCEDURE. 31280000 * 31300000 SPACE 31320000 PLPRST EQU *-SBRPOOL 31340000 ST RETURN,STRETURN(WAREG) SAVE RETURN ADDRESS 31360000 BAL RETURN,DECOMP(SBR) DECOMPOSE OPERAND 31380000 TM 1(OPDK),X'C0' TEST IF PROCEDURE IDENTIFIER 31400000 BZ PLPRST4(SBR) ERROR IF NOT 31420000 LH RETURN,OPDADR(WAREG) 31440000 SRL RETURN,12 GET NR OF PARAMETERS 31460000 LTR RETURN,RETURN IS NR ZERO 31480000 BZ PLPRST1(SBR) YES 31500000 PLPRST0 EQU *-SBRPOOL 31520000 BAL RETURN,SERR1(SBR) ERROR 31540000 DC H'187' 31560000 B PLPRST3(SBR) 31580000 PLPRST4 EQU *-SBRPOOL 31600000 BAL RETURN,SERR3(SBR) ERROR 31620000 DC H'183' 31640000 B PLPRST3(SBR) 31660000 PLPRST1 EQU *-SBRPOOL 31680000 TM HCOMPMOD(WAREG),X'80' COMPILE MODE TEST 31700000 BO PLPRST3(SBR) BRANCH IF FALSE 31720000 BAL RETURN,OPDREC(SBR) OPERAND RECOGNIZER 31740000 TM 3(OPDK),REGADRM OPERAND IN ADR 31760000 BZ PLPRST3(SBR) NO 31780000 SH P,ONEENTRY(WAREG) RELEASE STACK 31800000 XI RII(WAREG),RIIADRM ADR NOT OCCUPIED 31820000 PLPRST3 EQU *-SBRPOOL 31840000 L RETURN,STRETURN(WAREG) LOAD RETURN ADDRESS 31860000 BR RETURN 31880000 EJECT 31900000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 31920000 * * 31940000 * SUBROUTINE 'LOAD VPLACE, WPLACE' 31960000 * * 31980000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 32000000 * CALL BAL RETURN,LDVWPLC(0,SBR) 32020000 * 32040000 SPACE 32060000 LDVWPLC EQU *-SBRPOOL 32080000 ST RETURN,LDRET 32100000 BAL RETURN,OPDREC(SBR) OPERAND RECOGNIZER 32120000 TM 0(OPDK),X'20' ADDRESS OR VALUE 32140000 BO LDVW1 ADDRESS 32160000 SPACE 32180000 TM 0(OPDK),X'40' IS IT VALUE IN REG 32200000 BO LDVW3 NO 32220000 SR R4,R4 32240000 IC R4,3(OPDK) GET REG 32260000 SRL R4,4 NR 32280000 SLL R4,1 DOUBLE IT 32300000 TM 1(OPDK),X'01' IS VALUE INTEGER 32320000 BZ LDVW4 NO 32340000 SLL R4,1 YES, 4 TIMES REG NR 32360000 ST OPDK,RUTI(R4,WAREG) INTRODUCE CORRECT OPDK ADDR 32380000 B LDVW3 32400000 LDVW4 ST OPDK,RUTR(R4,WAREG) INTRODUCE CORRECT OPDK ADDR 32420000 LDVW3 BAL RETURN,CLEARRG(SBR) CLEAR REGISTERS 32440000 BAL RETURN,ROUTINE1(SBR) USE ROUTINE 1 TO LOAD VW-PLACE 32460000 B LDVWR 32480000 LDVW1 CLI 2(OPDK),X'00' FUNCTION VALUE IN FSA 32500000 BNE *+16 0216 32510015 ST OPDK,RUTI+32(WAREG) INTRODUCE CORRECT OPDK ADD 0216 32520015 CLI 0(SOURCE),X'25' SOURCE OPERATOR COMMA 0216 32530015 BE LDVW3 YES 0216 32540015 SPACE 32580000 TM 0(OPDK),X'40' IS ADDRESS IN STACK 32600000 BO LDVW2 YES 32620000 SPACE 32640000 MVI VPLACE(WAREG),X'88' ADDRESS IN REG ADR 32660000 MVC WPLACE(2,WAREG),ZEROHW(WAREG) 32680000 B LDVWR 32700000 SPACE 32720000 LDVW2 MVI VPLACE(WAREG),X'AA' ADDRESS 32740000 MVC WPLACE(2,WAREG),3(OPDK) IN STACK 32760000 SPACE 32780000 LDVWR L RETURN,LDRET 32800000 BR RETURN 32820000 SPACE 32840000 LDRET DS F 32860000 EJECT 32880000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 32900000 * 32920000 * SUBROUTINES FOR MOVING STACK POINTERS 32940000 * 32960000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 32980000 MOVEOPTK EQU *-SBRPOOL ENTRY FOR MOVING OPERATOR STACK PTR 33000000 LA OPTK,1(OPTK) 33020000 B MOVERET(SBR) 33040000 MOVEOPDK EQU *-SBRPOOL ENTRY FOR MOVING OPDSTACK POINTER 33060000 SH OPDK,CON5(SBR) 33080000 MOVERET EQU *-SBRPOOL 33100000 CR OPTK,OPDK 33120000 BNL STACKOFL(SBR) 33140000 BR RETURN 33160000 SPACE 3 33180000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 33200000 * * 33220000 * TARITHM * 33240000 * * 33260000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 33280000 * CALL BAL RETURN,TARITHM(SBR) RETURN TO RETURN IF OPERAND 33300000 * INTEGER OR REAL.OTHERWISE RETURN TO RETURN+4 AFTER ERROR MESSAGE 33320000 * 163 IS GIVEN 33340000 * CHECK ALSO FOR ARRAY OR PROCEDURE IDENTIFIER 33360000 * 33380000 SPACE 33400000 TARITHM EQU *-SBRPOOL TEST IF OPERAND IS ARETHMETIC 33420000 TM 0(OPDK),APIMASK API IN STACK 5603 33440018 BCR 1,RETURN YES ,RETURN NO ERROR 33460000 TM 1(OPDK),X'03' OPERAND ARITHMETIC 33480000 BM PROGARR YES CONTINUE CHECK 33500000 ST RETURN,SAVTARIT SAVE RETURN 33520000 BAL RETURN,SERR2(SBR) 33540000 DC H'163' ERROR 163 33560000 L RETURN,SAVTARIT 33580000 B 4(RETURN) RETURN ERROR MESSAGE 163 GIVEN 33600000 PROGARR LA R1,4(RETURN) 33620000 ST R1,SAVTARIT ERROR RETURN FROM ARRTEST 33640000 B ARRTEST1+4(SBR) CHECK FOR PROCEDURE OR ARRAY 33660000 SAVTARIT EQU SAVTRREI SAVE AREA FOR RETURN 33680000 SPACE 3 33700000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 33720000 * * 33740000 * LATRES * 33760000 * * 33780000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 33800000 * CALL BAL RETURN,LATRES(0,SBR) 33820000 * RESERVE ONE ENTRY IN LABEL ADDRESS TABLE 33840000 * AND CHECK IF OVERFLOW 33860000 * 33880000 SPACE 33900000 LATRES EQU *-SBRPOOL RESERVE NEXT LAT-ENTRY 33920000 LH R1,LN(0,WAREG) GET CURRENT LN 33940000 LA R1,4(0,R1) ADD ONE ENTRY 33960000 STH R1,LN(0,WAREG) STORE NEW LN 33980000 SPACE 34000000 LATOVFLO EQU *-SBRPOOL CHECK IF LAT-OVERFLOW 34020000 TM LN(WAREG),X'F0' IS LAT FULL 34040000 BCR 8,RETURN NO 34060000 ST RETURN,LATRET SAVE RETURN ADDRESS 34080000 BAL RETURN,SERR1(SBR) GENERATE ERROR PATTERN 34100000 DC H'216' 34120000 SPACE 34140000 LA R1,LATBEG RESET POINTER 34160000 STH R1,LN(0,WAREG) TO FIRST ENTRY 34180000 SPACE 34200000 L RETURN,LATRET 34220000 BR RETURN 34240000 SPACE 34260000 LATRET EQU LDRET 34280000 SPACE 3 34300000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 34320000 * * 34340000 * ARRAY AND PROCEDURE TEST * 34360000 * * 34380000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 34400000 * CALL BAL RETURN,ARRTEST1(0,SBR) 34420000 * 34440000 SPACE 34460000 ARRTEST1 EQU *-SBRPOOL 34480000 ST RETURN,SAVTARIT SAVE RETURN 34500000 TM 0(OPDK),APIMASK IS OPERAND API 5603 34520018 BCR 1,RETURN RETURN IF API 34540000 TM 1(OPDK),X'C0' PROCEDURE 0224 34544015 BC 9,*+12 0224 34548015 TM 1(OPDK),X'40' STANDARD PROCEDURE 0224 34552015 BZ PROCTES1 YES ERROR 0224 34556015 TM 0(OPDK),X'C0' IDENTIFIER FROM ITAB 34560000 BCR 12,RETURN NO RETURN 34580000 TM 1(OPDK),X'04' 34600000 BZ PROCTEST NO ARRAY CONTINUE TEST 34620000 BAL RETURN,SERR3(0,SBR) 34640000 DC H'196' 34660000 ARRTEST3 L RETURN,SAVTARIT RESTORE RETURN 34680000 BR RETURN 34700000 PROCTEST TM 1(OPDK),X'C0' PROCEDURE 34720000 BCR 8,RETURN NO RETURN 34740000 TM 3(OPDK),X'F0' PARAMETERLESS 34800000 BCR 8,RETURN YES RETURN 34820000 PROCTES1 BAL RETURN,SERR1(SBR) ERROR 187 34840000 DC H'187' 34860000 B ARRTEST3 34880000 ARRTEST2 EQU *-SBRPOOL 34900000 ST RETURN,RETARR2 34920000 LA OPDK,5(0,OPDK) 34940000 BCTR OPTK,0 34960000 BAL RETURN,ARRTEST1(0,SBR) 34980000 LA OPTK,1(0,OPTK) 35000000 SH OPDK,CON5(0,SBR) 35020000 L RETURN,RETARR2 35040000 B ARRTEST1(0,SBR) 35060000 SPACE 35080000 DS 0F 35100000 RETARR2 DS F 35120000 SPACE 3 35140000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 35160000 * * 35180000 * OPERAND TEST * 35200000 * * 35220000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 35240000 * CALL BAL RETURN,OPDTESF(0,SBR) * 35260000 SPACE 2 35280000 OPDTESF EQU *-SBRPOOL GIVE ERROR MESSAGE 162 IF OPERAND 35300000 * IS MISSING,STACK ALL PURPOUSE IDENT. 35320000 * AND RETURN VIA REG.RETURN IF NO 35340000 * ERROR RETURN VIA REG 3 35360000 OPDTEST EQU OPDTESF 35380000 TM HCOMPMOD(WAREG),X'01' OPERAND PRESENT 35400000 BCR 1,R3 YES,RETURN 35420000 ST RETURN,STRETURN(WAREG) 35440000 BAL RETURN,SERR4(SBR) ERROR 162 35460000 DC H'162' 35480000 L RETURN,STRETURN(WAREG) 35500000 OI HCOMPMOD(WAREG),X'01' OPERAND SWITCH ON 35520000 B STACKAPI(SBR) STACK API RETURN DIRECT 35540000 ERR166 EQU *-SBRPOOL 35560000 BVB1 ST RETURN,RETADR(0,WAREG) STORE RETURN ADDRESS 35580000 TM HCOMPMOD(WAREG),X'01' OPDT 35600000 BZ BYB2 BRANCH IF FALSE 35620000 LA OPDK,5(0,OPDK) CLOPD 35640000 NI HCOMPMOD(WAREG),X'FE' OPDFL=FALSE 35660000 BYB2 BAL RETURN,SERR1(SBR) ERROR 166 35680000 DC H'166' 35700000 L RETURN,RETADR(0,WAREG) LOAD RETURN ADDRESS 35720000 BR RETURN RETURN 35740000 TITLE 'IEX50, COMPILATION PHASE, DECISION MATRIXES' 35760000 IEX50001 CSECT 35780000 SPACE 35800000 * DECISION MATRICIES 35820000 SPACE 35840000 DECAREA EQU * START OF DECICION AREA 35860000 SPACE 2 35880000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 35900000 * * 35920000 * PROGRAM CONTEXT COLUMN VECTOR * 35940000 * * 35960000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 35980000 DC X'0A0A0A0A0A0A09120703030B000002020A0A0A0A0A0A080404' 36000000 DC X'121212120512060A0A0A0A0A121201120C0D0E0F1110000000' 36020000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36040000 * * 36060000 * PROGRAM CONTEXT ROW VECTOR * 36080000 * * 36100000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36120000 DC X'ABABABABABABABABABAB853926131313ABABABABABAB72ABAB' 36140000 DC X'ABABAB98ABABABABABABABAB00AB4C5FABABABABABAB000030' 36160000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36180000 * * 36200000 * PROGRAM CONTEXT MATRIX * 36220000 * * 36240000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36260000 DC X'00010454545454545454545454545454540354' 36280000 DC X'0001040407074B0707074B191810545453544B' 36300000 DC X'00011D1D06084B290C404B191C54541054544B' 36320000 DC X'00011A1A06084B290C404B171C17171754544B' 36340000 DC X'00011A1A064B11290C404B121C12121254544B' 36360000 DC X'00011A1A06084B290C404B121C12121254544B' 36380000 DC X'1B1E1A1A1B131429151616141C14141454544B' 36400000 DC X'5454545454545454555454541C545454545454' 36420000 DC X'00011D1D06084B290C404B1A1C54515454544B' 36440000 DC X'1F1E1F1F1F1F1F1F1F1F1F1F1C1F1F1F545416' 36460000 EJECT 36480000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36500000 * * 36520000 * STATEMENT CONTEXT COLUMN VECTOR * 36540000 * * 36560000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36580000 ADRSTC EQU * 36600000 DC X'090909090909010D030F0F0C0F0F0F0F0A0A0A0A0A0A060F0F' 36620000 DC X'0708070B000F0C0A0A0A0A0A05020F040E0C0C0C0F0F000000' 36640000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36660000 * * 36680000 * STATEMENT CONTEXT ROW VECTOR * 36700000 * * 36720000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36740000 DC X'D0D0D0D0D0D0D0B03040D0D0D0D0D0D0D0D0D0D0D0D0D00060' 36760000 DC X'8090A0D0D0D0D0D0D0D0D0D0D0D0D0D02050D0C07010000033' 36780000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36800000 * * 36820000 * STATEMENT CONTEXT MATRIX * 36840000 * * 36860000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 36880000 DC X'22384B294B4B4B4B4B4B4B4B3E4B1C1B' 36900000 DC X'22384B294B3B544B4B4B4B4B1B543B1B' 36920000 DC X'224039294B394B4B4B21214B1B4B1C1B' 36940000 DC X'22404B2926264B4B4B214B4B1B4B1C1B' 36960000 DC X'5454543454345454545454541B543654' 36980000 DC X'22403D294B3D4B4B4B21214B1B4B1C1B' 37000000 DC X'4B4B4B294B4B284B4B4B4B1B1B4B1C1B' 37020000 DC X'22404B294B2B4B2B4B214B2B1B4B1C1B' 37040000 DC X'22404B294B4B4B4B2D214B1B1B4B1C1B' 37060000 DC X'22404B294B2F4B4B4B214B2F1B4B1C1B' 37080000 DC X'22404B294B314B4B4B2121311B4B1C1B' 37100000 DC X'22404B2933334B4B4B214B4B1B4B1C1B' 37120000 DC X'22404B294B4B544B4B214B4B1B241C1B' 37140000 DC X'224B4B4B4B4B4B4B4B4B4B4B474B1C47' 37160000 EJECT 37180000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 37200000 * * 37220000 * EXPRESSION CONTEXT COLUMN VECTOR * 37240000 * * 37260000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 37280000 ADREXC EQU * 37300000 DC X'0B0B0C0C0C0D050F070F0F0F0F0F0F0F0E0E0E0E0E0E0F0F0F' 37320000 DC X'0F0F0F0F08090A00020304010F060F0F0F0F0F0F0F0F000000' 37340000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 37360000 * * 37380000 * EXPRESSION CONTEXT ROW VECTOR * 37400000 * * 37420000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 37440000 DC X'A0A0B0B0B0C050E0E0E0E0E0E0E0E0E0D0D0D0D0D0D0E0E0E0' 37460000 DC X'E0E0E0E06070800020304010E060E0E0E0E090E0E0E000003F' 37480000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 37500000 * * 37520000 * EXPRESSION CONTEXT MATRIX * 37540000 * * 37560000 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 37580000 DC X'4B4D4D4D4D404D29494D4D424343434D' 37600000 DC X'414C434343404C29494C4C424343434C' 37620000 DC X'414C4C4343404C29494C4C424343434C' 37640000 DC X'414C4C4C43404C29494C4C424343434C' 37660000 DC X'414C4C4C4C404C29494C4C424343434C' 37680000 DC X'4143434343404429501B1B424343431B' 37700000 DC X'4143434343404B29414E56424343431B' 37720000 DC X'4143434343404B29494B57424343431B' 37740000 DC X'4143434343404F29414F48424343434F' 37760000 DC X'4B3F3F3F3F403F29493F3F3F3F433F3F' 37780000 DC X'4B454545454045294945454543434545' 37800000 DC X'4B454545454045294945454545434545' 37820000 DC X'4B454545454045294945454545454545' 37840000 DC X'4B454545454045294945454243434A45' 37860000 DC X'4143434343404629464B464243434346' 37880000 TITLE 'IEX50, COMPILATION PHASE, WORKAREA DSECT' 37900000 CPWORKAR DSECT 37920000 SPACE 37940000 * DUMMY CONTROL SECTION TO PROVIDE ADDRESSABILITY OF WORKAREA 37960000 * AUG 16 1966 37980000 SPACE 38000000 WKST EQU * 38020000 DS 0F WORKAREA START 38040000 SAVEAREA EQU *-WKST *** 38060000 DS F 38080000 DS F HIGHER LEVEL SAVEAREA ADDR * 38100000 DS F LOWER LEVEL SAVEAREA ADDR * 38120000 DS F RETURN ADDR * 38140000 DS F ENTRY POINT ADDR * 38160000 SVEREG0 EQU *-WKST *** * 38180000 DS F 38200000 SVEREG1 EQU *-WKST * * 38220000 DS F 38240000 SVEREG2 EQU *-WKST * * 38260000 DS F 38280000 SVEREG3 EQU *-WKST * * SAVEAREA 38300000 DS F 38320000 SVEREG4 EQU *-WKST * * 38340000 DS F 38360000 SVEREG5 EQU *-WKST * * 38380000 DS F 38400000 SVEREG6 EQU *-WKST * SAVEAREA FOR REGISTERS * 38420000 DS F 38440000 SVEREG7 EQU *-WKST * * 38460000 DS F 38480000 SVEREG8 EQU *-WKST * * 38500000 DS F 38520000 SVEREG9 EQU *-WKST * * 38540000 DS F 38560000 SVEREG10 EQU *-WKST * * 38580000 DS F 38600000 SVEREG11 EQU *-WKST * * 38620000 DS F 38640000 SVEREG12 EQU *-WKST *** *** 38660000 DS A 38680000 SPACE 38700000 LINADD EQU *-WKST *** 38720000 DS A 38740000 DS A * 38760000 DS A * 38780000 DS A * 38800000 INADD EQU *-WKST * ADDRESSES OF DATA CONTROL BLOCKS 38820000 DS A 38840000 ./ ADD SSI=01053331,NAME=IEX51,SOURCE=0 TITLE 'IEX51, TERMINATION OF COMPILATION' 00020000 * * 00040000 *STATUS: CHANGE LEVEL 000 * 00060000 * * 00080000 *FUNCTION/OPERATION: * 00100000 * CSECT IEX51000: THE TABLES NEEDED AT OBJECT TIME ARE PREPARED AND * 00120000 * INCLUDED IN THE OBJECT MODULE. THEY ARE PROGRAM BLOCK TABLE, LABEL* 00140000 * ADDRESS TABLE, AND DATA SET TABLE. ESD-CARDS FOR THE REQUIRED * 00160000 * LIBRARY ROUTINES ARE GENERATED. THE INFORMATION REQUIRED TO START * 00180000 * THE EXECUTION, INCLUDING THE END-CARD, IS GENERATED. A TABLE * 00200000 * CONTAINING THE DSA-SIZES FOR THE PROGRAM BLOCKS IS PREPARED AND * 00220000 * TOGETHER WITH THE OBJECT MODULE SIZE PUT OUT TO SYSPRINT. * 00240000 * CSECT IEX60000: THE ERROR PATTERNS GENERATED DURING COMPILATION * 00260000 * PHASE ARE HANDLED AND THE CORRESPONDING DIAGNOSTIC MESSAGES ARE * 00280000 * GENERATED. * 00300000 * CSECT IEX51002: ALL AREAS RESERVED ARE RELEASED AND THE DATA * 00320000 * CONTROL BLOCKS NOT CLOSED EARLIER ARE CLOSED, THE ORIGINAL PICA IS* 00340000 * RESTORED, THE RETURN CODE IS FOUND, AND CONTROL IS GIVEN TO * 00360000 * COMPILER DIRECTORY, IEX00. * 00380000 * * 00400000 *ENTRY POINTS: * 00420000 * IEX51000 - NORMAL END OF COMPILATION. XCTL EP=IEX51000 * 00440000 * THE MODULE IS NORMALLY ENTERED FROM IEX40. * 00460000 * IEX51ER1 - ABNORMAL END OF COMPILATION. XCTL EP=IEX51ER1 * 00480000 * IS USED BY IEX40 AND IEX50. * 00500000 * IEX51ER2 - ABNORMAL END OF COMPILATION. XCTL EP=IEX51ER2 * 00520000 * IS USED BY IEX40. * 00540000 * IEX51002 - ABNORMAL END OF COMPILATION. XCTL EP=IEX51002 * 00560000 * IS USED BY IEX00, IEX21, AND IEX31. * 00580000 * * 00600000 *INPUT: N/A * 00620000 * * 00640000 *OUTPUT: PART OF THE OBJECT MODULE IS GENERATED AND PUT OUT ON SYSLIN * 00660000 * AND/OR SYSPUNCH. * 00680000 * STORAGE REQUIREMENTS AND DIAGNOSTIC MESSAGES ARE PUT OUT ON * 00700000 * SYSPRINT. * 00720000 * * 00740000 *EXTERNAL ROUTINES: THE PRINT ROUTINE IN IEX00 IS USED. * 00760000 * * 00780000 *EXIT-NORMAL: CONTROL IS GIVEN TO COMPILER DIRECTORY, IEX00, BY MEANS * 00800000 * OF THE RETURN MACRO INSTRUCTION AT LOCATION RETURN. * 00820000 * * 00840000 *EXIT-ERROR: AFTER PROGRAM INTERRUPTS AND I/O-ERRORS THE MODULE GETS * 00860000 * CONTROL BACK AND EXITS NORMALLY. * 00880000 * * 00900000 *TABLES/WORKAREAS: THE MESSAGE TEXTS WITH CORRESPONDING ADDRESS TABLE * 00920000 * ARE IN THE LOAD MODULE IEX51M. * 00940000 * THE ERROR MESSAGE EDITING ROUTINE, CSECT IEX60000, ALSO USES THE * 00960000 * FOLLOWING TABLES: * 00980000 * WINTEBC FOR TRANSLATION OF INTERNAL CHARACTERS TO EBCDIC * 01000000 * WSYMBSRC FOR TRANSLATION OF * 01020000 * WSYMBSTK INTERNAL SYMBOLS TO EBCDIC * 01040000 * WORDSEBC FOR TRANSLATION OF COMPOUND SYMBOLS IF SOURCE IN EBCDIC * 01060000 * WORDSISO FOR TRANSLATION OF COMPOUND SYMBOLS IF SOURCE IN ISOCODE* 01080000 * WEBCDIC FOR TRANSLATION EBCDIC-EBCDIC * 01100000 * A WORKAREA OF 270 BYTES, WAREA, IS USED FOR BUILDING THE MESSAGES.* 01120000 * * 01140000 * FOR THE EXTERNAL REFERENCES TO THE LIBRARY ROUTINES ONE OF THE * 01160000 * TABLES SHRTAB AND LNGTAB, CONTAINING THE MODULE NAMES, IS USED. * 01180000 * THE GENERATE ROUTINE USES THREE TABLES, ESDT, TXTT, AND RLDT, FOR * 01200000 * GENERATION OF THE DIFFERENT TYPES OF OBJECT RECORDS. * 01220000 * * 01240000 * THE PART OF COMMON WORKAREA STARTING AT DCBUT1 IS INITIALIZED BY * 01260000 * THE LOAD MODULE IEX40 AND IS USED BY THIS AND THE PRECEDING LOAD * 01280000 * MODULE. * 01300000 * * 01320000 *ATTRIBUTES: NONE. * 01340000 * * 01360000 *NOTES: CHARACTER CODE DEPENDENCE: * 01380000 * CSECT IEX51000: THE OPERATION OF THE ROUTINES 'GENERATE' AND * 01400000 * 'PRINT STORAGE REQUIREMENTS' DEPENDS UPON AN INTERNAL REPRESENTA- * 01420000 * TION OF THE EXTERNAL CHARACTER SET WHICH IS EQUIVALENT TO THE ONE * 01440000 * USED AT ASSEMBLY TIME. * 01460000 * * 01480000 * CSECT IEX60000: FOR THE BUILDING OF A MESSAGE (CODE PART BETWEEN * 01500000 * COT03 AND COT12) THE FOLLOWING APPLIES: * 01520000 * IN CASE NO SOURCE INFORMATION IS TO BE INSERTED (COT31), OR IF * 01540000 * THE INFORMATION IS EBCDIC-CHARACTERS (COT07), THE OPERATION OF * 01560000 * CSECT IEX60000 DEPENDS UPON AN INTERNAL REPRESENTATION OF THE * 01580000 * EXTERNAL CHARACTER SET WHICH IS EQUIVALENT TO THE ONE USED AT * 01600000 * ASSEMBLY TIME. * 01620000 * IF THE SOURCE INFORMATION TO BE INSERTED IS INTERNAL CHARACTERS * 01640000 * (COT33) THE OPERATION OF CSECT IEX60000 DEPENDS UPON A TRANSLATION* 01660000 * FROM THE INTERNAL REPRESENTATION TO THE EBCDIC CHARACTER SET BY * 01680000 * MEANS OF THE TABLE 'WINTEBC'. * 01700000 * IF THE SOURCE INFORMATION TO BE INSERTED IS INTERNAL ALGOL SYMBOLS* 01720000 * (COT10) THE OPERATION OF CSECT IEX60000 DEPENDS UPON A TRANSLATION* 01740000 * FROM THE INTERNAL REPRESENTATION TO THE EBCDIC CHARACTER SET BY * 01760000 * MEANS OF THE TABLES 'WSYMBSTK'/'WSYMBSRC' AND 'WORDSISO'/ * 01780000 * 'WORDSEBC'. * 01800000 * FOR THE OUTPUT OF A MESSAGE (CODE PART BETWEEN COT12 AND COT21) * 01820000 * THE FOLLOWING APPLIES: * 01840000 * WHEN A MESSAGE HAS BEEN BUILT IN EBCDIC, AN EBCDIC-EBCDIC TRANSLA-* 01860000 * TION IS PERFORMED BEFORE OUTPUT BY MEANS OF THE TABLE 'WEBCDIC'. * 01880000 * THUS THE OUTPUT MAY BE MODIFIED BY MAKING CHANGES IN THIS TABLE. * 01900000 * * 01920000 * THE OPERATION OF THE OTHER PARTS DOES NOT DEPEND UPON A PARTICULAR* 01940000 * INTERNAL REPRESENTATION OF THE EXTERNAL CHARACTER SET. * 01960000 * * 01980000 * AT SYSTEM GENERATION THIS MODULE WILL BE LINKED TOGETHER WITH * 02000000 * THE MODULE IEX51M TO FORM THE MODULE IEX51 IN LINKLIB. * 02020000 * * 02040000 * THIS MODULE IS ONLY INTENDED TO BE EXECUTED IN CONNECTION * 02060000 * WITH THE OTHER MODULES OF THE ALGOL COMPILER. IN PARTICULAR IT * 02080000 * REQUIRES THE COMMON WORKAREA. * 02100000 * * 02120000 EJECT 02140000 IEX51000 CSECT 02160000 *0057056200 1511 02170018 SPACE 2 02180000 * REGISTER DEFINITIONS 02200000 SPACE 02220000 WRK EQU 1 02240000 RAREA EQU 1 02260000 RINFO EQU 1 ADDRESSES INFO FOR ERROR ED 02280000 RCOT EQU 2 ADDRESSES ERROR ED ROUTINE 02300000 WRK1 EQU 2 02320000 WRK2 EQU 3 02340000 WRK3 EQU 4 02360000 WRK4 EQU 5 02380000 RMDSN EQU 5 02400000 RPRPT EQU 6 02420000 WRK8 EQU 6 02440000 RIO EQU 7 02460000 WRK5 EQU 7 02480000 RZERO EQU 8 02500000 WRK9 EQU 8 02520000 WRK6 EQU 9 02540000 RBASE EQU 10 02560000 WRK7 EQU 11 02580000 RWRKA EQU 13 02600000 RET EQU 14 02620000 RENTRY EQU 15 02640000 SPACE 2 02660000 * OTHER DEFINITIONS 02680000 SPACE 02700000 RASLGT EQU 2048 LENGTH OF RETURN ADDRESS STACK 02720000 LPGCF EQU 28