//PSMUPDTE JOB PSMUPDTE,'PSMUPDTE',CLASS=A,MSGCLASS=H //* //PROC PROC PREFIX=SYS1, <--- DATA SET NAME PREFIX // JOBNAME=PSMIVP, <--- IVP JOB NAME // JOBCLASS=A, <--- IVP JOB CLASS // MSGCLASS=H, <--- IVP MSG CLASS // DISKUNIT=SYSDA <--- STORAGE UNIT NAME //* //* --------------------------------- //* STEP 1 - DELETE PRODUCT LIBRARIES //* --------------------------------- //* //S1 EXEC PGM=IEFBR14 //DD DD DSN=&PREFIX..PSM.SRCLIB,DISP=(MOD,DELETE,DELETE), // UNIT=&DISKUNIT,SPACE=(TRK,0) // DD DSN=&PREFIX..PSM.RUNLIB,DISP=(MOD,DELETE,DELETE), // UNIT=&DISKUNIT,SPACE=(TRK,0) //* //* --------------------------------- //* STEP 2 - CREATE PRODUCT LIBRARIES //* --------------------------------- //* //S2 EXEC PGM=IEFBR14 //DD DD DSN=&PREFIX..PSM.SRCLIB, // UNIT=&DISKUNIT,SPACE=(CYL,(2,1,16)), // DCB=(RECFM=FB,LRECL=80,BLKSIZE=6160,DSORG=PO), // DISP=(NEW,CATLG,CATLG) // DD DSN=&PREFIX..PSM.RUNLIB, // UNIT=&DISKUNIT,SPACE=(CYL,(2,1,16)), // DCB=(RECFM=U,LRECL=0,BLKSIZE=6233,DSORG=PO), // DISP=(NEW,CATLG,CATLG) //* //* ----------------------------------- //* STEP 3 - POPULATE PRODUCT LIBRARIES //* ----------------------------------- //* //S3 EXEC PGM=IEBUPDTE,PARM=MOD //SYSPRINT DD SYSOUT=* //SYSUT1 DD DSN=&PREFIX..PSM.SRCLIB,DISP=SHR //SYSUT2 DD DSN=&PREFIX..PSM.SRCLIB,DISP=SHR //SYSIN DD DUMMY //* //* -------------------------------- //* STEP 4 - ASSEMBLE PROGRAM PSU001 //* -------------------------------- //* //S4 EXEC PGM=ASMA90,PARM=RENT,COND=(8,LT,S3) //SYSLIB DD DSN=SYS1.MACLIB,DISP=SHR // DD DSN=SYS1.MODGEN,DISP=SHR // DD DSN=&PREFIX..PSM.SRCLIB,DISP=SHR //SYSUT1 DD DSN=&&SYSUT1,SPACE=(4096,(120,120),,,ROUND), // UNIT=SYSALLDA,DCB=BUFNO=1 //SYSPRINT DD SYSOUT=* //SYSLIN DD DSN=&&OBJ,SPACE=(3040,(40,40),,,ROUND), // UNIT=SYSALLDA,DISP=(MOD,PASS), // DCB=(BLKSIZE=6160,LRECL=80,RECFM=FB,BUFNO=1) //SYSIN DD DSN=&PREFIX..PSM.SRCLIB(PSU001),DISP=SHR //* //* ---------------------------- //* STEP 5 - LINK PROGRAM PSU001 //* ---------------------------- //* //S5 EXEC PGM=HEWL,PARM='MAP,LET,LIST,NCAL',COND=(8,LT,S4) //SYSLIN DD DSN=&&OBJ,DISP=(OLD,DELETE) // DD DDNAME=SYSIN //SYSLMOD DD DSN=&PREFIX..PSM.RUNLIB(PSU001),DISP=SHR //SYSUT1 DD DSN=&&SYSUT1,SPACE=(1024,(120,120),,,ROUND), // UNIT=SYSALLDA,DCB=BUFNO=1 //SYSPRINT DD SYSOUT=* //* //* -------------------------------- //* STEP 6 - ASSEMBLE PROGRAM PSU002 //* -------------------------------- //* //S6 EXEC PGM=ASMA90,PARM=RENT,COND=(8,LT,S5) //SYSLIB DD DSN=SYS1.MACLIB,DISP=SHR // DD DSN=SYS1.MODGEN,DISP=SHR // DD DSN=&PREFIX..PSM.SRCLIB,DISP=SHR //SYSUT1 DD DSN=&&SYSUT1,SPACE=(4096,(120,120),,,ROUND), // UNIT=SYSALLDA,DCB=BUFNO=1 //SYSPRINT DD SYSOUT=* //SYSLIN DD DSN=&&OBJ,SPACE=(3040,(40,40),,,ROUND), // UNIT=SYSALLDA,DISP=(MOD,PASS), // DCB=(BLKSIZE=6160,LRECL=80,RECFM=FB,BUFNO=1) //SYSIN DD DSN=&PREFIX..PSM.SRCLIB(PSU002),DISP=SHR //* //* ---------------------------- //* STEP 7 - LINK PROGRAM PSU002 //* ---------------------------- //* //S7 EXEC PGM=HEWL,PARM='MAP,LET,LIST,NCAL',COND=(8,LT,S6) //SYSLIN DD DSN=&&OBJ,DISP=(OLD,DELETE) // DD DDNAME=SYSIN //SYSLMOD DD DSN=&PREFIX..PSM.RUNLIB(PSU002),DISP=SHR //SYSUT1 DD DSN=&&SYSUT1,SPACE=(1024,(120,120),,,ROUND), // UNIT=SYSALLDA,DCB=BUFNO=1 //SYSPRINT DD SYSOUT=* //* //* -------------------------------- //* STEP 8 - ASSEMBLE PROGRAM PSU003 //* -------------------------------- //* //S8 EXEC PGM=ASMA90,PARM=RENT,COND=(8,LT,S7) //SYSLIB DD DSN=SYS1.MACLIB,DISP=SHR // DD DSN=SYS1.MODGEN,DISP=SHR // DD DSN=&PREFIX..PSM.SRCLIB,DISP=SHR //SYSUT1 DD DSN=&&SYSUT1,SPACE=(4096,(120,120),,,ROUND), // UNIT=SYSALLDA,DCB=BUFNO=1 //SYSPRINT DD SYSOUT=* //SYSLIN DD DSN=&&OBJ,SPACE=(3040,(40,40),,,ROUND), // UNIT=SYSALLDA,DISP=(MOD,PASS), // DCB=(BLKSIZE=6160,LRECL=80,RECFM=FB,BUFNO=1) //SYSIN DD DSN=&PREFIX..PSM.SRCLIB(PSU003),DISP=SHR //* //* ---------------------------- //* STEP 9 - LINK PROGRAM PSU003 //* ---------------------------- //* //S9 EXEC PGM=HEWL,PARM='MAP,LET,LIST,NCAL',COND=(8,LT,S8) //SYSLIN DD DSN=&&OBJ,DISP=(OLD,DELETE) // DD DDNAME=SYSIN //SYSLMOD DD DSN=&PREFIX..PSM.RUNLIB(PSU003),DISP=SHR //SYSUT1 DD DSN=&&SYSUT1,SPACE=(1024,(120,120),,,ROUND), // UNIT=SYSALLDA,DCB=BUFNO=1 //SYSPRINT DD SYSOUT=* //* //* --------------------------------- //* STEP 10 - ASSEMBLE PROGRAM PSU004 //* --------------------------------- //* //S10 EXEC PGM=ASMA90,PARM=RENT,COND=(8,LT,S9) //SYSLIB DD DSN=SYS1.MACLIB,DISP=SHR // DD DSN=SYS1.MODGEN,DISP=SHR // DD DSN=&PREFIX..PSM.SRCLIB,DISP=SHR //SYSUT1 DD DSN=&&SYSUT1,SPACE=(4096,(120,120),,,ROUND), // UNIT=SYSALLDA,DCB=BUFNO=1 //SYSPRINT DD SYSOUT=* //SYSLIN DD DSN=&&OBJ,SPACE=(3040,(40,40),,,ROUND), // UNIT=SYSALLDA,DISP=(MOD,PASS), // DCB=(BLKSIZE=6160,LRECL=80,RECFM=FB,BUFNO=1) //SYSIN DD DSN=&PREFIX..PSM.SRCLIB(PSU004),DISP=SHR //* //* ----------------------------- //* STEP 11 - LINK PROGRAM PSU004 //* ----------------------------- //* //S11 EXEC PGM=HEWL,PARM='MAP,LET,LIST,NCAL',COND=(8,LT,S10) //SYSLIN DD DSN=&&OBJ,DISP=(OLD,DELETE) // DD DDNAME=SYSIN //SYSLMOD DD DSN=&PREFIX..PSM.RUNLIB(PSU004),DISP=SHR //SYSUT1 DD DSN=&&SYSUT1,SPACE=(1024,(120,120),,,ROUND), // UNIT=SYSALLDA,DCB=BUFNO=1 //SYSPRINT DD SYSOUT=* //* //* -------------------------- //* STEP 12 - GENERATE IVP JOB //* -------------------------- //* //S12 EXEC PGM=PSU003,COND=(8,LT,S11), // PARM=('&&JOBNAME=&JOBNAME', // '&&JOBCLASS=&JOBCLASS', // '&&MSGCLASS=&MSGCLASS', // '&&PREF=&PREFIX') //STEPLIB DD DSN=&PREFIX..PSM.RUNLIB,DISP=SHR //SYSUT1 DD DSN=&PREFIX..PSM.SRCLIB($PSMIVP),DISP=OLD //SYSUT2 DD DSN=&PREFIX..PSM.SRCLIB($PSMIVP),DISP=OLD //* //* ------------------------------- //* STEP 14 - GENERATE GENCAL CLIST //* ------------------------------- //* //S14 EXEC PGM=PSU003,COND=(8,LT,S11), // PARM=('&&PREF=&PREFIX') //STEPLIB DD DSN=&PREFIX..PSM.RUNLIB,DISP=SHR //SYSUT1 DD DSN=&PREFIX..PSM.SRCLIB(GENCAL),DISP=OLD //SYSUT2 DD DSN=&PREFIX..PSM.SRCLIB(GENCAL),DISP=OLD // PEND //* // EXEC PROC //S3.SYSIN DD DATA,DLM=$$ ./ ADD NAME=PCALL,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO &NAME PCALL .* COPY PSMGBL01 .* LCLA &A &A SETA N'&SYSLIST(2) .* AIF (&A GT 0).L00100 &NAME CALL &SYSLIST(1) MEXIT .* .L00100 ANOP &NAME LR 1,&SP LA &SP,4*&A.(,&SP) CALL &SYSLIST(1),&SYSLIST(2),VL,MF=(E,(1)) LA 14,4*&A SR &SP,14 .* MEND ./ ADD NAME=PENTER,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO &NAME PENTER &TYPE, PROCEDURE TYPE X &BASE=12, BASE REGISTER(S) X &VARS=, LOCAL VARIABLE STORAGE X &STACK=, SIZE OF STACK IN 1K BLOCKS X &PREFIX=PSM LABEL PREFIX FOR MACRO EXPANSION .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* VARIABLE DEFINITIONS .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* COPY PSMGBL00 COPY PSMGBL01 COPY PSMGBL02 .* LCLA &I INDEX AND COUNTER LCLA &K STACK SIZE LCLA &N NUMBER OF PARAMETERS (REUSED) LCLA &S HIGHEST REGISTER USED .* LCLB &B0 STACK DEFINED FLAG LCLB &B1 PSM MAIN LINKAGE LCLB &B2 PSM CMAIN LINKAGE LCLB &B3 PSM FUNCTION LINKAGE LCLB &B4 STANDARD LINKAGE .* LCLC &C CHARACTER STRING (REUSED) LCLC &P EXPANSION PREFIX .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* VALIDATE &STACK PARAMETER .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* AIF ((T'&STACK EQ 'O') OR (&STACK EQ 0)).L0010 &K SETA ((&STACK*4)*1024) &B0 SETB ('&TYPE' EQ 'CMAIN') &B0 SETB (('&TYPE' EQ 'MAIN') OR &B0) AIF (&B0).L0010 MNOTE 4,'INVALID STACK USAGE - STACK=&STACK IGNORED' .L0010 ANOP .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* VALIDATE &TYPE PARAMETER .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &B1 SETB ('&TYPE' EQ 'MAIN') &B2 SETB ('&TYPE' EQ 'CMAIN') &B3 SETB ('&TYPE' EQ 'FUNC') &B4 SETB (T'&TYPE EQ 'O') AIF (NOT (&B1 OR &B2)).L0020 .* AIF (&B0).L0030 MNOTE 4,'TYPE &TYPE REQUIRES STACK - 4K ASSUMMED' &K SETA 4096 &B0 SETB 1 AGO .L0030 .* .L0020 ANOP AIF (&B1 OR &B2 OR &B3 OR &B4).L0030 MNOTE 4,'INVALID TYPE &TYPE - STANDARD LINKAGE ASSUMED ' &B4 SETA 1 .L0030 ANOP AIF (NOT &B4).L0040 &K SETA 64 MINIMAL STACK FOR PCALL, ETC. &B0 SETB 1 FORCE MINIMAL STACK .L0040 ANOP .* .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* MAKE EXPANSION PREFIX SHORTER FOR CLEANER EXPANSION .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &P SETC '&PREFIX' SHORTEN THE VARIABLE NAME .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* SAVE AREA STRUCTURE DEFINITION .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* AIF (&PSMSVA AND ('&P' EQ 'PSM')).L0060 .L0050 ANOP .* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - .* S T A R T O F S A V E A R E A S T R U C T U R E .* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - &PSMSVA SETB 1 &P.SVA DSECT , SAVE AREA STRUCTURE &P.PLI DS F UNUSED &P.HSA DS A HIGH SAVE AREA PTR &P.LSA DS A LOW SAVE AREA PTR &P.RET DS A RETURN ADDRESS &P.EPA DS A ENTRY POINT ADDRESS &P.GPR0 DS A REGISTER 0 &P.GPR1 DS A REGISTER 1 &P.GPR2 DS A REGISTER 2 &P.GPR3 DS A REGISTER 3 &P.GPR4 DS A REGISTER 4 &P.GPR5 DS A REGISTER 5 &P.GPR6 DS A REGISTER 6 &P.GPR7 DS A REGISTER 7 &P.GPR8 DS A REGISTER 8 &P.GPR9 DS A REGISTER 9 &P.GPR10 DS A REGISTER 10 &P.GPR11 DS A REGISTER 11 &P.GPR12 DS A REGISTER 12 &P.GDS DS A GLOBAL DATA STRUCTURE PTR &P.LDS DS A LOCAL DATA STRUCTURE PTR &P.TOS DS A TOP OF STACK PTR &P.BOS DS A BOTTOM OF STACK PTR &P.SVALN EQU *-&P.SVA LENGTH OF SAVE AREA STRUCTURE &P.LVARS DS 0F START OF LOCAL VARIABLES .* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - .* E N D O F S A V E A R E A S T R U C T U R E .* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - .L0060 ANOP .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* COMPUTE HIGHEST REGISTER USED (FROM BASE REGS DEFINED) .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &S SETA 0 START WITH NO HIGHEST .* .* SCAN THE CODE BASE REGISTERS .* &N SETA N'&BASE NUMBER OF BASE REGISTERS &I SETA 1 START WITH FIRST ONE .* .L0070 ANOP AIF (&I GT &N).L0090 WHILE (UNSCANNED REGISTERS) PSMRVAL &BASE(&I) GET VALUE OF REGISTER AIF (&S GE &PSMRVAL).L0080 IF HIGHER THAN PREVIOUS &S SETA &PSMRVAL SAVE REGISTER .L0080 ANOP ENDIF &I SETA &I+1 INCREMENT REGISTER INDEX AGO .L0070 END WHILE .L0090 ANOP .* .* SCAN THE DATA BASE REGISTERS .* &N SETA N'&VARS(3) NUMBER OF BASE REGISTERS &I SETA 1 START WITH FIRST ONE .* .L0100 ANOP AIF (&I GT &N).L0120 WHILE (UNSCANNED REGISTERS) PSMRVAL &VARS(3,&I) GET VALUE OF REGISTER AIF (&S GE &PSMRVAL).L0110 IF HIGHER THAN PREVIOUS &S SETA &PSMRVAL SAVE REGISTER .L0110 ANOP ENDIF &I SETA &I+1 INCREMENT REGISTER INDEX AGO .L0100 END WHILE .L0120 ANOP .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* GENERATE REGISTER EQUATES .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* AIF (&PSMREGS).L0170 SKIP IF ALREADY DEFINED AIF (®S).L0160 ISSUE WARNING IF EXTERNALLY DEFINED .* &PSMREGS SETB 1 MARK AS DEFINED ®S SETB 1 MARK AS DEFINED .* &I SETA 0 .L0140 ANOP REPEAT .* IF ( NOT SPECIAL REGISTER ) AIF ((&I EQ &SP) OR (&I EQ &BP)).L0150 .* AIF ((&I GT &S) AND NOT (&I LT &BP)).L0150 R&I EQU &I GENERATE REGISTER EQUATE .L0150 ANOP ENDIF &I SETA &I+1 BUMP TO NEXT REGISTER AIF (&I LE &HIREG).L0140 UNTIL ( NO MORE REGISTERS ) AGO .L0170 SKIP WARNING .* .L0160 ANOP MNOTE 4,'USE REGISTERS &SP AND &BP WITH CAUTION!!!' .* .L0170 ANOP .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* DROP PREVIOUS BASE REGISTERS .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .* DROP CODE BASE REGISTERS .* AIF ('&PSMBSEC(2)' EQ '').L0180 DROP &PSMBSEC(2) .* .* DROP DATA BASE REGISTERS .* .L0180 ANOP AIF ('&PSMBSED' EQ '').L0190 DROP &PSMBSED .* .L0190 ANOP .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* INITIALIZE THE PENTER/PEXIT GLOBAL VARIABLES .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &PSMCNAM SETC '' CLEAR THE CSECT NAME &PSMBSEC(1) SETC '' CLEAR THE FIRST CODE BASE REGISTER &PSMBSEC(2) SETC '' CLEAR THE CODE BASE REGISTER LIST &PSMBSED SETC '' CLEAR THE DATA BASE &PSMBSEH SETC '' CLEAR THE HIGHEST REGISTER USED &PSMSTKS SETC '' CLEAR THE STACK SIZE .* &PSMCNAM SETC '&NAME' INITIALIZE THE CSECT NAME .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* GENERATE THE CSECT PREFACE AREA .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* PSMRLSE , &N SETA (K'&PSMRLSE+3)/4*4 .* .* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - .* S T A R T O F C S E C T P R E F A C E .* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - .* THE CSECT ID SECTION IS MAPPED BY MACRO PSMCPREF .* ANY CHANGES TO HERE SHOULD BE DUPLICATED THERE .* &NAME CSECT , .* &C SETC '' AIF (NOT &B2).L0200 ENTRY MAIN &C SETC 'MAIN' .L0200 ANOP .* &I SETA 36+&N+(&B0*4)+(&B2*4) &C B &I.(,15) BRANCH AROUND CSECT PREFACE &I SETA 27+&N DC AL1(&I.) . LENGTH OF DUMP TEXT DC CL9'&NAME' . CSECT NAME DC CL9'&SYSDATE' . ASSEMBLY DATE DC CL9'&SYSTIME' . ASSEMBLY TIME AIF (&N LT 1).L0210 DC CL&N.'&PSMRLSE' . PRODUCT RELEASE ID .L0210 ANOP &C SETC '0' AIF (T'&VARS(2) EQ 'O').L0220 &C SETC '&VARS(2)' .L0220 ANOP &C SETC '((&P.SVALN+&C+7)/8)*8' DC A(&C) . INITIAL STACK OFFSET .* .* GENERATE STACK CONSTANTS .* AIF (NOT &B0).L0230 &PSMSTKS SETC '&K' DC AL1(&SSID),AL3(&K) . STACK ALLOCATION .* .* GENERATE PSM INITIALIZATION MODULE ADDRESS CONSTANT .* AIF (NOT &B2).L0230 DC V(PSMINIT) . PSM INITIALIZATION .* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - .* E N D O F C S E C T P R E F A C E .* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - .L0230 ANOP .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* SAVE REGISTERS FOR STANDARD LINKAGE .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* STM 14,&S,12(&BP) .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* ESTABLISH CODE BASE REGISTERS .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &N SETA N'&BASE NUMBER OF BASE REGISTERS &C SETC '&BASE(1)' FIRST BASE REGISTER &PSMBSEC(1) SETC '&C' SAVE FIRST BASE REGISTER .* LR &BASE(1),15 AIF (&N LE 1).L0250 IF ( MORE THAN ONE REGISTER) &I SETA 1 SET INDEX TO FIRST REGISTER LA &BASE(&N),4095 .L0240 ANOP AIF (&I+1 GT &N).L0250 WHILE ( MORE REGISTERS ) &I SETA &I+1 GET NEXT REGISTER LA &BASE(&I),1(&BASE(&N),&BASE(&I-1)) &C SETC '&C.,&BASE(&I)' COLLECT REGISTERS AGO .L0240 END WHILE .L0250 ANOP ENDIF &PSMBSEC(2) SETC '&C' SAVE BASE REGISTER LIST USING &NAME,&C .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* COMPLETE STANDARD LINKAGE .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* LR 2,&BP &N SETA (K'&PSMRLSE+3)/4*4 AIF (&B1 OR &B4).L0260 LR &BP,&SP AGO .L0270 .* .L0260 ANOP &I SETA 36+&N L 0,&I.(,&BASE(1)) &I SETA &I-4 AL 0,&I.(,&BASE(1)) GETMAIN R,LV=(0) LR &BP,1 LR &SP,1 .* .L0270 ANOP LA 0,0(,&BP) &I SETA 32+&N L 1,&I.(,&BASE(1)) LR 14,0 SR 15,15 MVCL 0,14 .* AIF (&B1 OR &B4).L0280 MVC &P.GDS-&P.SVA(&P.LVARS-&P.GDS,&BP),&P.GDS-&P.SVA(2) .L0280 ANOP .* ST 2,4(,&BP) ST &BP,8(,2) LM 1,2,24(2) AIF (&B4).L0290 A &SP,&I.(,&BASE(1)) .L0290 ANOP .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* ESTABLISH DATA BASE REGISTERS .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* AIF (T'&VARS EQ 'O').L0340 &C SETC '&BP' &N SETA N'&VARS(3) AIF (&N LT 1).L0330 &I SETA 0 LA &VARS(3,&N),4095 .L0300 ANOP &I SETA &I+1 AIF (&I GT &N).L0330 AIF (&I GT 1).L0310 LA &VARS(3,&I),1(&VARS(3,&N),&BP) AGO .L0320 .L0310 ANOP LA &VARS(3,&I),1(&VARS(3,&N),&VARS(3,&I-1)) .L0320 ANOP &C SETC '&C.,&VARS(3,&I)' AGO .L0300 .L0330 ANOP USING &VARS(1)-&P.SVALN,&C &PSMBSED SETC '&C' .L0340 ANOP .* &PSMBSEH SETC '&S' .* MEND ./ ADD NAME=PEXIT,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO &NAME PEXIT &RC=0 RETURN CODE .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* VARIABLE DEFINITIONS .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* COPY PSMGBL00 COPY PSMGBL01 COPY PSMGBL02 .* LCLA &A,&I,&J,&N LCLC &C .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* SETUP .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L1000 ANOP .* &N SETA (K'&PSMRLSE+3)/4*4 &C SETC '&PSMCNAM' .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* GENERATE INITIAL RETURN CODE .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &C CSECT , &NAME LR 1,&BP L &BP,4(,&BP) .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* STORE SPECIFIED REGISTERS IN CALLERS SAVE AREA .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &A SETA N'&SYSLIST &I SETA 1 .L1020 ANOP AIF (&I GT &A).L1060 PSMROP &SYSLIST(&I) AIF (&PSMROP1 GT &PSMROP2).L1040 AIF (&PSMROP1 LT 0 OR &PSMROP1 GT 12).L1040 AIF (&PSMROP2 LT 0 OR &PSMROP1 GT 12).L1040 &J SETA 20+(&PSMROP1*4) AIF (&PSMROPC GT 1).L1030 ST &PSMROP1,&J.(,&BP) AGO .L1050 .L1030 ANOP STM &PSMROP1,&PSMROP2,&J.(&BP) AGO .L1050 .L1040 ANOP MNOTE 4,'REGISTER &SYSLIST(&I) OUT OF RANGE, IGNORED.' .L1050 ANOP &I SETA &I+1 AGO .L1020 .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* STORE RETURN CODE .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L1060 ANOP AIF ('&RC' EQ '').L1090 AIF ('&RC'(1,1) EQ '(').L1070 LA 15,&RC AGO .L1080 .L1070 ANOP .* &C SETC '&RC'(2,K'&RC-2) PSMRVAL &C AIF (&PSMRVAL EQ 15).L1080 LR 15,&PSMRVAL .* .L1080 ANOP ST 15,16(,&BP) .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* FREE THE STACK (IF ONE IS THERE) .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L1090 ANOP AIF (T'&PSMSTKS EQ 'O').L1100 &I SETA 36+&N L 0,&I.(,&PSMBSEC(1)) &I SETA &I-4 AL 0,&I.(,&PSMBSEC(1)) FREEMAIN R,LV=(0),A=(1) .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* RETURN TO CALLER .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L1100 ANOP .* RETURN (14,&PSMBSEH) LM 14,&PSMBSEH,12(&BP) OI 15(&BP),1 MARK RETURN BR 14 .* LTORG , MEND ./ ADD NAME=PLINK,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO &NAME PLINK .* COPY PSMGBL01 .* LCLA &A &A SETA N'&SYSLIST(2) .* &NAME LR 1,&SP LA &SP,4*&A.(,&SP) LINK EP=&SYSLIST(1),PARAM=&SYSLIST(2),VL=1,MF=(E,(1)) LA 14,4*&A SR &SP,14 .* MEND ./ ADD NAME=POPREG,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO &NAME POPREG .* COPY PSMGBL01 COPY PSMGBL02 LCLA &I,&J,&K,&N .* AIF (T'&NAME EQ 'O').A000 &NAME DS 0H .A000 ANOP .* &N SETA N'&SYSLIST AIF (&N GT 0).A010 MEXIT .* .* COMPUTE AMOUNT OF STACK SPACE TO RELEASE .* .A010 ANOP &I SETA 1 &K SETA 0 .A020 ANOP PSMROP &SYSLIST(&I) &I SETA &I+1 &K SETA &K+&PSMROPC AIF (&I LE &N).A020 .* .* RELEASE STACK SPACE .* .B010 ANOP PSMRVAL &SYSLIST(1,1) &PSMROP1 SETA &PSMRVAL LA &PSMROP1,4*&K SR &SP,&PSMROP1 .* .* POP REGISTERS FROM STACK .* .C010 ANOP &I SETA &N &J SETA 4*&K .C020 ANOP PSMROP &SYSLIST(&I) AIF (&PSMROPC GT 1).C030 &J SETA &J-4 L &PSMROP1,&J.(,&SP) AGO .C060 .* .C030 ANOP &J SETA &J-(4*&PSMROPC) LM &PSMROP1,&PSMROP2,&J.(&SP) .* .C060 ANOP &I SETA &I-1 AIF (&I GE 1).C020 .* MEND ./ ADD NAME=PSMASYM,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO PSMASYM .* COPY PSMGBL02 .* &PSMASYM SETA &SYSLIST(1,1) .* MEND ./ ADD NAME=PSMCPREF,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO &NAME PSMCPREF &PREFIX=PSM .* LCLA &N LCLC &P .* &P SETC '&PREFIX' .* AIF (T'&NAME NE 'O').L0100 &NAME SETC '&P'.'CPREF' .L0100 ANOP .* .L0200 ANOP .* &NAME DSECT , &P.PJUMP DS F BRANCH AROUND CSECT PREFIX * * ID STRING &P.PLENG DS FL1 LENGTH OF IDENTIFIER STRING &P.PID DS 0C . S &P.PNAME DS CL8,CL1 . CSECT NAME &P.PDATE DS 0CL8 . ASSEMBLY DATE &P.PDTEM DS CL2,CL1 . MONTH &P.PDTED DS CL2,CL1 . DAY &P.PDTEY DS CL2,CL1 . YEAR &P.PTIME DS 0CL8 . ASSEMBLY TIME &P.PTMEH DS CL2,CL1 . HOUR &P.PTMEM DS CL2,CL1 . MINUTES &P.PTMES DS CL2,CL1 . SECONDS .* &P.PRLSE DS 0C . PRODUCT RELEASE .* &P.PLOCL DS FL4 SIZE OF SVA PLUS LOCAL VARIABLES DS FL1 STACK SUBPOOL ID DS FL3 SIZE OF STACK DS A PTR TO PSMINIT MODULE .* ./ ADD NAME=PSMGBL00,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* GBLB &PSMREGS PSM REGISTERS DEFINED FLAG GBLB ®S IBM REGISTERS DEFINED FLAG GBLC &PSMBSEC(2) PROCEDURE BASE REGISTERS GBLC &PSMBSED AUTO STORAGE BASE REGISTERS GBLC &PSMBSEH HIGHEST REGISTER USED GBLC &PSMCNAM PROCEDURE NAME GBLC &PSMSTKS STACK SIZE .* ./ ADD NAME=PSMGBL01,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* GBLA &SSID STACK SUBPOOL ID GBLA &SP STACK POINTER GBLA &BP STACK BASE POINTER GBLA &HIREG HIGHEST REGISTER AVAILABLE .* GBLB &PSMSVA SAVE AREA DEFINED FLAG GBLC &PSMSIG UNIQUE SIGNATURE .* &SSID SETA 127 INITIALIZE STACK SUBPOOL ID &SP SETA 3 INITIALIZE STACK POINTER &BP SETA 13 INITIALIZE STACK BASE POINTER &HIREG SETA 15 INITIALIZE HI-REG VALUE .* &PSMSIG SETC 'CAFE' ./ ADD NAME=PSMGBL02,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* .* SYMBOL-NAME MACRO-ID COMMENT .* _________________ ________ ________________________ .* GBLA &PSMRVAL PSMRVAL - RETURN REGISTER VALUE GBLA &PSMROPC PSMROP - RETURN REGISTER COUNT GBLA &PSMROP1,&PSMROP2 PSMROP - RETURN REGISTER OPERANDS GBLA &PSMASYM PSMASYM - RETURN VALUE .* GBLC &PSMSUBP PSMSUBP - RETURN VALUE GBLC &PSMRLSE PSMRLSE - RETURN VALUE .* ./ ADD NAME=PSMGDS,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 MACRO PSMGDS &PREFIX=GDS LCLC &P &P SETC '&PREFIX' .***************************************************************** .* PSEUDO-STACK MACHINE GLOBAL DATA STRUCTURE * .*---------------------------------------------------------------* .* NAME: GDS * .* POINTED TO BY: LABEL PSMGDS IN PSMSVA (SAVE AREA +72) * .* DESCRIPTION: THE GDS IS GENERATED DURING PENTER PROCESSING* .* IF TYPE HAS BEEN CODED AS MAIN. IN THEORY * .* THE GDS IS AN ADDRESS SPACE LEVEL CONTROL * .* BLOCK WHILE THE LDS IS AT THE TASK LEVEL. * .* INFORMATION IN THE GDS IS LIMITED TO THAT * .* WHICH COULD BE CONSIDERED APPLICABLE OR * .* COMMON TO ALL TASKS WITHIN THE ADDRESS SPACE * .* * .* MAIN TASK * .* ________ SUB TASK * .* | GDS |<-----. <--------------------. * .* |--------| | ________ | * .* | LDS |<----.| | LDS | | * .* |--------| || |--------| | * .* | PSMSVA |=====-' | PSMSVA |---' * .* |--------| |--------| * .* | STACK | | STACK | * .* |________| |________| * .* * .* * .***************************************************************** GDS DSECT , * &P.ID DS CL8'PSMGDS' EYE CATCHER * &P.IN DS A(0) STANDARD INPUT WORK AREA &P.OUT DS A(0) STANDARD OUTPUT WORK AREA &P.ERROR DS A(0) STANDARD ERROR WORK AREA &P.PRINT DS A(0) STANDARD PRINT WORK AREA * &P.ARGC DS F'0' ARGUMENT COUNT &P.ARGV DS A(0) PTR TO LIST OF ARGUMENT PTRS &P.ENVPT DS A(0) PTR TO ENVIRONMENT STRINGS * &P.HEAPF DS A(0) PTR TO FIRST HEAP BLOCK (PSMHEAP) &P.HEAPL DS A(0) PTR TO LAST HEAP BLOCK &P.HLOCK DS A(0) HEAP LOCK (SERIALIZATION WITH CS) * &P.ENVSW DS X ENVIRONMENT SWITCH &P.ESXA DS X'01' .... ...1 MVS/XA (SP VERSION 2) &P.ESJ2 DS X'02' .... ..1. JES2 &P.ESJ3 DS X'04' .... .1.. JES3 &P.ESTSO DS X'08' .... 1... TSO &P.ESSPF DS X'10' ...1 .... TSO/ISPF &P.ESJOB DS X'20' ..1. .... JOB &P.ESSTC DS X'40' .1.. .... STARTED TASK &P.NAME DS CL8 ADDRESS SPACE NAME &P.JOBID DS CL8 ADDRESS SPACE JOBID &P.SSNAM DS CL4 SUBSYSTEM NAME &P.SPVER DS CL8 MVS/SP VERSION (CVTPRODN) * * PSM LOCKS ARE SERIALIZED USING COMPARE AND SWAP. THE VALUE * SWAPPED IN X'FFFFFFFF' IF THE LOCK IS HELD AND ZERO IF IT IS * NOT. ALL LOCKS MUST PROVIDE 2 WORDS. * &P.LOCKS DS CL8'LOCKS>' START OF PSM LOCKS SECTION &P.HPLOC DS F HEAP LOCK &P.HPECB DS F HEAP LOCK ECB IF QUEUED * &P.LENG EQU *-PSMGDS LENGTH OF GLOBAL DATA AREA MEND ./ ADD NAME=PSMRLSE,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO PSMRLSE .* COPY PSMGBL02 .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* THIS MACRO DEFINES THE PRODUCT NAME AND RELEASE DATA .* WHICH WILL BE INCLUDED IN THE CSECT PREFIX AREA. .* KEEP A COPY OF THIS MACRO IN EACH PRODUCT MACRO LIBRARY .* AND CHANGE THE GLOBAL VARIABLE &PSMRLSE AS APPROPRIATE. .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &PSMRLSE SETC 'PSM 1.0.0' .* MEND ./ ADD NAME=PSMROP,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO PSMROP .* COPY PSMGBL02 LCLA &A .* .A010 ANOP .* &PSMROPC SETA 0 &PSMROP1 SETA 17 &PSMROP2 SETA 17 &A SETA N'&SYSLIST(1) AIF (&A LT 1).A040 .* AIF (&A GT 1).A020 PSMRVAL &SYSLIST(1,1) &PSMROP1 SETA &PSMRVAL &PSMROP2 SETA &PSMRVAL &PSMROPC SETA 1 AGO .A040 .* .A020 ANOP PSMRVAL &SYSLIST(1,1) &PSMROP1 SETA &PSMRVAL PSMRVAL &SYSLIST(1,2) &PSMROP2 SETA &PSMRVAL AIF (&PSMROP1 GT &PSMROP2).A030 &PSMROPC SETA 1+(&PSMROP2-&PSMROP1) AGO .A040 .A030 ANOP &PSMROPC SETA (1+(15-&PSMROP1))+(1+&PSMROP2) .* .A040 ANOP .* MEND ./ ADD NAME=PSMROPS,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED MACRO &LABEL PSMROPS .* COPY PSMGBL02 LCLA &I,&K LCLC &C,&R1,&R2 .* .A010 ANOP .* &C SETC '&SYSLIST(1,1)' AIF ('&C'(1,1) NE '(').A020 &C SETC '&C'(2,K'&C-2) .* .A020 ANOP &I SETA 1 &K SETA K'&C .* .A030 ANOP AIF (&I GT &K).A040 AIF ('&C'(&I,1) EQ ',').A040 &I SETA &I+1 AGO .A030 .* .A040 ANOP &R1 SETC '0' &R2 SETC '0' .* AIF ('&C'(1,1) EQ ',').A050 &R1 SETC '&C'(1,&I-1) .* .A050 ANOP AIF (&I GE &K).A060 &R2 SETC '&C'(&I+1,&K-&I) .* .A060 ANOP PSMROP (&R1,&R2) .* MEND ./ ADD NAME=PSMRVAL,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO PSMRVAL .* COPY PSMGBL02 LCLC &C .* &C SETC '&SYSLIST(1,1)' AIF ('&C'(1,1) NE 'R').A010 &C SETC '&C'(2,K'&C-1) .* .A010 ANOP PSMASYM &C .* &PSMRVAL SETA &PSMASYM .* AIF (&PSMRVAL GT 15).MSG1 MEXIT .* .* ERROR PROCESSING .* .MSG1 MNOTE 8,'OOPS, ONLY 15 REGISTERS ON THIS MACHINE' MNOTE 8,'PARM 1 CAN BE 0-15 (R1-R15)' MEND ./ ADD NAME=PUSHREG,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED .* MACRO &NAME PUSHREG .* COPY PSMGBL01 COPY PSMGBL02 LCLA &I,&J,&K,&N .* AIF (T'&NAME EQ 'O').A000 &NAME DS 0H .A000 ANOP .* &N SETA N'&SYSLIST AIF (&N GT 0).A010 MEXIT .* .A010 ANOP &I SETA 1 &J SETA 0 &K SETA 0 .A020 ANOP PSMROP &SYSLIST(&I) AIF (&PSMROPC GT 1).A030 ST &PSMROP1,&J.(,&SP) AGO .A040 .* .A030 ANOP STM &PSMROP1,&PSMROP2,&J.(&SP) .* .A040 ANOP &I SETA &I+1 &J SETA &J+(4*&PSMROPC) &K SETA &K+&PSMROPC AIF (&I LE &N).A020 .* LA &SP,4*&K.(,&SP) .* MEND ./ ADD NAME=ZIC,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED MACRO &LABEL ZIC &P1,&P2 ZERO AND INSERT CHARACTER .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* VARIABLE DEFINITIONS .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* COPY PSMGBL02 .* LCLA &I,&K LCLC &C,&R1,&R2 .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* CHECK FOR REGISTER NOTATION IN OPERAND 2 .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &I SETA 1 &K SETA K'&P2 .L0100 ANOP AIF (&I GT &K).L0130 AIF ('&P2'(&I,1) EQ '(').L0110 &I SETA &I+1 AGO .L0100 .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* CHECK IF TARGET REG IS ALSO BASE OR INDEX REG .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L0110 ANOP &C SETC '&P2'(&I,(&K-&I)+1) PSMROPS &C PSMRVAL &P1 &I SETA &PSMRVAL AIF (&I EQ 0).L0130 AIF ((&I NE &PSMROP1) AND (&I NE &PSMROP2)).L0130 .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* CLEAR UNUSED BITS AFTER OPERATION (SLOWER) .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L0120 ANOP &LABEL IC &P1,&P2 SLL &P1,24 SRL &P1,24 MEXIT .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* CLEAR UNUSED BITS BEFORE OPERATION (FASTER) .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L0130 ANOP .* &LABEL XR &P1,&P1 ZERO TARGET REGISTER IC &P1,&P2 INSERT CHARACTER MEND ./ ADD NAME=ZICM,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 .* COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED MACRO &LABEL ZICM &P1,&P2,&P3 ZERO AND INSERT CHARS UNDER MASK .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* VARIABLE DEFINITIONS .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* COPY PSMGBL02 .* LCLA &I,&K LCLC &C .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* CHECK FOR REGISTER NOTATION IN OPERAND 3 .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* &I SETA 1 &K SETA K'&P3 .L0100 ANOP AIF (&I GT &K).L0130 AIF ('&P3'(&I,1) EQ '(').L0110 &I SETA &I+1 AGO .L0100 .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* CHECK IF TARGET REG IS ALSO BASE OR INDEX REG .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L0110 ANOP &C SETC '&P3'(&I,(&K-&I)+1) PSMROPS &C PSMRVAL &P1 AIF ((&PSMRVAL EQ 0) OR (&PSMRVAL NE &PSMROP1)).L0130 .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* CLEAR UNUSED BITS AFTER OPERATION (SLOWER) .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L0120 ANOP .* &B0 SETB ((&P2/16*2) NE &P2/8) &B1 SETB ((&P2/8*2) NE &P2/4) &B2 SETB ((&P2/4*2) NE &P2/2) &B3 SETB ((&P2/2*2) NE &P2) &C SETC '00FF'(&B0*2+1,2) &C SETC '&C'.'00FF'(&B1*2+1,2) &C SETC '&C'.'00FF'(&B2*2+1,2) &C SETC '&C'.'00FF'(&B3*2+1,2) .* &LABEL ICM &P1,&P2,&P3 N &P1,=A(X'&C') MEXIT .* .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* CLEAR UNUSED BITS BEFORE OPERATION (FASTER) .* /*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/ .* .L0130 ANOP .* &LABEL XR &P1,&P1 ZERO TARGET REGISTER ICM &P1,&P2,&P3 INSERT CHARACTER MASK MEND ./ ADD NAME=PSU001,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 * COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED * ANY USE OF THIS CODE MUST RETAIN THE ABOVE COPYRIGHT NOTICE * * PSU001 IS RENT,REUS * * COMPARES TWO CONSTANTS OR SYMBOLICS SPECIFIED IN THE PARM FIELD. * A TRUE CONDITION RESULTS IN A ZERO RETURN CODE, AND A FALSE * CONDITION RESULTS IN A RETURN CODE OF 1. * THE FORMAT OF THE PARM FIELD IS: FIELD1,OP,FIELD2 * WHERE FIELD1 AND FIELD2 ARE EITHER A CONSTANT OR A SYMBOLIC * AND OP IS ONE OF THE FOLLOWING OPERATORS: * EQ, NE, LT, LE, GT, GE * * EXAMPLE: * //STEP1 EXEC PGM=PSU001, * // PARM=(&JESNAME,EQ,JES2) * * PSU001 PENTER MAIN,VARS=(@VARS,@VARSLEN),STACK=1 * *---------------------------------------------------------------------* * MAINLINE * *---------------------------------------------------------------------* * L R2,0(,R1) PARM PTR LH R4,0(,R2) PARM LENGTH * LTR R4,R4 ANY PARM PRESENT ? BZ INVALID NO, REPORT ERROR * * PARSE PARM FOR 'STRING1,OP,STRING2' * LA R5,1(R4,R2) POINT TO LAST BYTE OF PARM LA R4,1 STEP ONE BYTE AT A TIME LA R2,2(,R2) POINT TO FIRST BYTE OF PARM LR R7,R2 SAVE PTR TO FIRST BYTE OF PARM * A00100 CLI 0(R2),C',' FOUND A COMMA? BNE A00200 NO, CHECK NEXT BYTE BAL R14,SVFIELD YES, SAVE CURRENT FIELD A00200 BXLE R2,R4,A00100 LOOP THROUGH EVERY BYTE OF PARM BAL R14,SVFIELD SAVE LAST FIELD * * DO STRING COMPARISON * L R4,@STR1 STRING1 PTR L R5,@STR1L STRING1 LENGTH L R6,@STR2 STRING2 PTR L R7,@STR2L STRING2 LENGTH * OR R4,R4 HAVE VALID STRING1 PTR ? BZ INVALID NO, REPORT ERROR OR R5,R5 HAVE VALID STRING1 LENGTH ? BZ INVALID NO, REPORT ERROR OR R6,R6 HAVE VALID STRING2 PTR ? BZ INVALID NO, REPORT ERROR OR R7,R7 HAVE VALID STRING2 LENGTH ? BZ INVALID NO, REPORT ERROR * LA R1,OPTABLE START OF OPERATOR TABLE LA R14,L'OPTABLE LENGTH OF EACH ENTRY LA R15,OPEND END OF OPERATOR TABLE * USING OPTABLE,R1 * A00300 CLC OP,@OP FOUND LOGICAL OPERATOR ? BE A00400 YES, CONTINUE BXLE R1,R14,A00300 NO, SCAN ENTIRE TABLE * A00400 XR R14,R14 CLEAR CLCL R4,R6 COMPARE STRINGS EX R14,COND EXECUTE BRANCH TRUE CONDITION B EXITFALS LOGICAL CONDITION WAS FALSE * DROP R1 * INVALID WTO 'PSU0011I - INVALID PARAMETERS',ROUTCDE=11,DESC=6 WTO 'PSU0012I - USE ''STRING1,OP,STRING2''',ROUTCDE=11,DESC=6 ABEND 1 * EXITFALS MVC @RC,=F'1' RETURN FALSE EXITTRUE L R15,@RC RETURN TRUE * PEXIT RC=(R15) RETURN TO CALLER * *---------------------------------------------------------------------* * SVFIELD SUBROUTINE * *---------------------------------------------------------------------* * * INPUT REGS: R2 - PTR TO COMMA AT END OF CURRENT FIELD * R7 - PTR TO START OF CURRENT FIELD * * OUTPUT REGS: R7 - PTR TO FIRST BYTE OF NEXT FIELD * * SVFIELD PUSHREG R14 SAVE RETURN ADDRESS * OC @STR1,@STR1 NOW AT STRING1 ? BNZ S00100 NO, TRY OPERATOR * ST R7,@STR1 STORE START OF FIELD LR R14,R2 CURRENT LOCATION SR R14,R7 COMPUTE LENGTH OF PARM ST R14,@STR1L SAVE ZERO RELATIVE LENGTH LA R7,1(,R2) COMPUTE START OF NEXT FIELD B S00400 * S00100 OC @OP,@OP NOW AT OPERATOR ? BNZ S00300 NO, TRY STRING2 * MVC @OP,0(R7) SAVE THE OPERATOR LA R7,1(,R2) COMPUTE START OF NEXT FIELD B S00400 * S00300 OC @STR2,@STR2 NOW AT STRING2 ? BNZ S00400 NO, IGNORE EXCESS FIELDS * ST R7,@STR2 STORE START OF FIELD LR R14,R2 CURRENT LOCATION SR R14,R7 COMPUTE LENGTH OF PARM ST R14,@STR2L SAVE ZERO RELATIVE LENGTH LA R7,1(,R2) COMPUTE START OF NEXT FIELD * S00400 POPREG R14 RESTORE RETURN ADDRESS BR R14 RETURN TO CALLER * *---------------------------------------------------------------------* * OPERATION CODE TABLE * *---------------------------------------------------------------------* * * THE OPCODE TABLE MATCHES THE CHARACTER OPERATION CODE WITH * ITS CORRESPONDING 'BRANCH ON CONDITION' INSTRUCTION. * * THE LAST ENTRY IN THE TABLE IS A HARD BRANCH TO THE LABEL * THAT SETS A FALSE CONDITION. THIS SIMPLIFIES THE PROGRAM * LOGIC SUCH THAT NO SPECIAL END-OF-TABLE CHECK IS NECESSARY. * OPTABLE DS 0CL6 OPERATOR TABLE * OP DC CL2'EQ' EQUAL OPERATOR COND BE EXITTRUE BRANCH ON EQUAL DC CL2'NE' NOT EQUAL OPERATOR BNE EXITTRUE BRANCH ON NOT EQUAL DC CL2'LT' LESS THAN OPERATOR BL EXITTRUE BRANCH ON LESS THAN DC CL2'LE' LESS THAN OR EQUAL OPERATOR BNH EXITTRUE BRANCH ON NOT GREATER DC CL2'GT' GREATER THAN OPERATOR BH EXITTRUE BRANCH ON GREATER THAN DC CL2'GE' GREATER OR EQUAL OPERATOR BNL EXITTRUE BRANCH ON NOT LESS OPEND EQU *-1 DC CL2'FF' MARK END OF TABLE B INVALID FORCE FALSE CONDITION * *---------------------------------------------------------------------* * LOCAL (AUTO) STORAGE * *---------------------------------------------------------------------* * * N.B. AUTO STORAGE INITIALIZED TO BINARY ZEROS ON PROGRAM ENTRY * @VARS DSECT , LOCAL STORAGE @RC DS F . RETURN CODE @STR1 DS F . STRING1 PTR @STR1L DS F . STRING1 LENGTH @STR2 DS F . STRING2 PTR @STR2L DS F . STRING2 LENGTH @OP DS CL2 . OPERATOR @VARSLEN EQU *-@VARS LENGTH OF LOCAL STORAGE * END PSU001 ./ ADD NAME=PSU002,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 * COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED * ANY USE OF THIS CODE MUST RETAIN THE ABOVE COPYRIGHT NOTICE * * PSU002 IS RENT,REUS * * COPIES PARM FIELD TO A DATA SET ON ONE OR MORE RECORDS. * THE OUTPUT DATASET (SYSOUT) CAN HAVE F, FB, V, OR VB * FORMAT RECORDS. * THE RECORD SEPARATOR IS THE FIRST CHARACTER OF THE PARM * AND IS NOT INCLUDED IN THE OUTPUT RECORDS. * IF A COMMA IMMEDIATELY FOLLOWS A RECORD SEPARATOR, THE * COMMA IS NOT INCLUDED IN THE OUTPUT RECORD. * * EXAMPLE: * //STEP1 EXEC PGM=PSU002, * // PARM=('\', RECORD SEPARATOR * // ' C INDD=SYSUT1,OUTDD=SYSUT2\', CARD #1 * // ' S M=(MEMBERA,MEMBERB) ') CARD #2 * //SYSOUT DD DSN=&&IEBCOPY,UNIT=VIO,ETC... * PSU002 PENTER MAIN,VARS=(@VARS,@VARSLEN),STACK=1 * *---------------------------------------------------------------------* * MAINLINE * *---------------------------------------------------------------------* * L R2,0(,R1) PARM PTR LH R4,0(,R2) PARM LENGTH * MVC @SYSOUT(DCBL),DCB INITIALIZE DCB MVC @OPEN(OPENL),OPEN INITIALIZE OPEN PARAMETER LIST OPEN (@SYSOUT,(OUTPUT)), OPEN OUTPUT FILE C MF=(E,@OPEN) * CH R4,=H'2' PARM PRESENT ? BL EXIT NO, NOTHING TO WRITE * MVC @SEP,2(R2) SAVE THE LINE SEPARATOR * LA R5,1(R4,R2) POINT TO LAST BYTE OF PARM LA R4,1 STEP ONE BYTE AT A TIME LA R2,3(,R2) POINT TO 1ST BYTE PAST SEPARATOR LR R7,R2 SAVE PTR TO RECORD DATA * A00100 CLC 0(1,R2),@SEP FOUND A SEPARATOR? BNE A00200 NO, KEEP LOOKING BAL R14,MOVECARD YES, WRITE A RECORD A00200 BXLE R2,R4,A00100 LOOP THROUGH EVERY BYTE OF PARM BAL R14,MOVECARD WRITE LAST RECORD * EXIT MVC @CLOSE(CLOSEL),CLOSE INITIALIZE CLOSE PARAMETER LIST CLOSE (@SYSOUT), CLOSE OUTPUT FILE C MF=(E,@CLOSE) * L R15,@RC PICK UP RETURN CODE PEXIT RC=(R15) RETURN TO CALLER * *---------------------------------------------------------------------* * MOVECARD SUBROUTINE * *---------------------------------------------------------------------* * * INPUT REGS: R2 - PTR TO RECORD SEPARATOR AT END OF RECORD * R7 - PTR TO START OF CURRENT RECORD * * OUTPUT REGS: R7 - PTR TO START OF NEXT RECORD * * MOVECARD PUSHREG R14,R6 * LR R6,R2 CURRENT LOCATION SR R6,R7 COMPUTE LENGTH OF CARD BCTR R6,0 MAKE LENGTH ZERO RELATIVE * * REMOVE A COMMA FOLLOWING A RECORD SEPERATOR * * ONE CAN EASILY IMAGINE A SITUATION IN WHICH * A COMMA FOLLOWING A RECORD SEPARATOR SHOULD * NOT BE REMOVED. BUT AS THERE IS NO POSSIBLE * METHOD TO DETERMINE WHEN SUCH A CASE EXISTS * WE ESTABLISH THE LAW THAT A COMMA FOLLOWING * A RECORD SEPARATOR SHALL ALWAYS BE REMOVED. * * A FULL DISCUSSION OF ALL THE POINTS LEADING * TO THIS RULE IS NOT APPROPRIATE HERE. TRUST * ME, THOUGH, THERE IS NO BUG HERE, SO PLEASE * DON'T TRY TO FIX IT. ;-) * CLI 0(R7),C',' TRAILING COMMA ? BNE B00100 NO, TIME TO WRITE RECORD LA R7,1(,R7) SKIP OVER THE COMMA BCTR R6,0 ADJUST LENGTH TO COMPENSATE * * WRITE THE RECORD, TAKING INTO ACCOUNT THE * SUBTLETIES OF THE ALLOWED RECORD FORMATS. * B00100 LA R8,@SYSOUT POINT TO OUTPUT DCB USING IHADCB,R8 ESTABLISH ADDRESSABILITY * TM DCBRECFM,DCBRECU UNDEFINED RECORD FORMAT ? BO B00400 YES, FORMAT NOT SUPPORTED * PUT @SYSOUT LOCATE RECORD BUFFER --> R1 TM DCBRECFM,DCBRECV VARIABLE RECORD FORMAT ? BNO B00200 NO, TRY FIXED FORMAT * LA R14,5(,R6) ADJUST LENGTH FOR RDW STCM R14,B'0011',0(R1) STUFF LENGTH INTO RDW STCM R14,B'1100',2(R1) CLEAR HIGH-ORDER RDW BITS LA R1,4(,R1) SKIP RDW, POINT TO RECORD AREA LR R14,R6 ACTUAL RECORD LENGTH BCTR R14,0 MINUS ONE FOR CLEARING BUFFER B B00300 CLEAR BUFFER * B00200 TM DCBRECFM,DCBRECF FIXED RECORD FORMAT ? BNO B00400 NO, FORMAT NOT SUPPORTED LH R14,DCBLRECL FIXED RECORD LENGTH BCTR R14,0 MAKE LENGTH ZERO RELATIVE BCTR R14,0 MINUS ONE FOR CLEARING BUFFER * B00300 MVI 0(R1),C' ' CLEAR RECORD BUFFER EX R14,CLRINSTR TO ALL SPACES * LTR R6,R6 ACTUAL RECORD LENGTH > 0 ? BM B00400 NO, USE BLANK RECORD EX R6,MVCINSTR YES, COPY RECORD TO BUFFER * B00400 LA R7,1(,R2) COMPUTE START OF NEXT RECORD * POPREG R14,R6 RESTORE RETURN ADDRESS BR R14 RETURN TO CALLER * *---------------------------------------------------------------------* * PROTOTYPE INSTRUCTIONS AND DATA * *---------------------------------------------------------------------* * CLRINSTR MVC 1(0,R1),0(R1) MVCINSTR MVC 0(0,R1),0(R7) * DCB DCB DDNAME=SYSOUT, X DSORG=PS, X MACRF=PL DCBL EQU *-DCB * OPEN OPEN (,), X MF=L OPENL EQU *-OPEN * CLOSE CLOSE (,), X MF=L CLOSEL EQU *-CLOSE * DCBD DSORG=PS * *---------------------------------------------------------------------* * LOCAL (AUTO) STORAGE * *---------------------------------------------------------------------* * * N.B. AUTO STORAGE INITIALIZED TO BINARY ZEROS ON PROGRAM ENTRY * @VARS DSECT , @RC DS F @STR1 DS F @STR1L DS F @STR2 DS F @STR2L DS F @OP DS CL2 @SEP DS B @OPEN OPEN (,),MF=L @CLOSE CLOSE (,),MF=L @SYSOUT DCB DSORG=PS,MACRF=(PL) @VARSLEN EQU *-@VARS * END PSU002 ./ ADD NAME=PSU003,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 * COPYRIGHT (C) 1988, PAUL A. SCOTT, ALL RIGHTS RESERVED * ANY USE OF THIS CODE MUST RETAIN THE ABOVE COPYRIGHT NOTICE * * MODULE PSU003 * AUTHOR P. SCOTT * * PSU003 IS RENT,REUS * * EXAMPLE: * //STEP1 EXEC PGM=PSU003, * // PARM=('&&PREFIX=PROD.LOAN.SL') * * PSU003 TITLE ' - MAINLINE PROCESSING ' *---------------------------------------------------------------------* * MAINLINE PROCESSING * *---------------------------------------------------------------------* * PSU003 PENTER MAIN,VARS=(ZVARS,ZVARL),STACK=1 * BAL R14,B0000 PARSE OUT STRINGS * LA R0,ZSTRINGS START OF STRING PTRS C R0,ZSTREPTR WERE ANY STRINGS FOUND ? BL A0100 YES, PROCESS THEM * LA R0,28 MESSAGE LENGTH LA R1,=C'PSU0030I NO STRINGS DEFINED.' BAL R14,W0000 WRITE MESSAGE TO JOB LOG MVC ZRC,=A(8) SET RETURN CODE B EXIT AND EXIT * A0100 BAL R14,W0100 WRITE STRINGS TO LOG BAL R14,P0000 PROCESS INPUT DATA SET * EXIT L R15,ZRC GET RETURN CODE PEXIT RC=(15) RETURN TO CALLER * TITLE ' - B0000 - PARSE OUT STRINGS ' *---------------------------------------------------------------------* * B0000 - PARSE OUT STRINGS * *---------------------------------------------------------------------* * B0000 PUSHREG R14 SAVE RETURN PTR * LA R6,ZSTRINGS TABLE OF STRPTR'S AND STRLEN'S USING STRINGS,R6 * BAL R14,B1000 PROCESS PARM STRINGS BAL R14,B2000 PROCESS SYSIN STRINGS * BCTR R6,0 LAST BYTE USED IN STRING TABLE ST R6,ZSTREPTR SAVE END OF TABLE PTR * B0990 POPREG R14 RETORE RETURN PTR BR R14 RETURN * TITLE ' - B1000 - PROCESS PARM DATA ' *---------------------------------------------------------------------* * B1000 - PROCESS PARM DATA * *---------------------------------------------------------------------* * B1000 PUSHREG R14 SAVE RETURN PTR * L R2,0(,R1) PARM PTR LH R4,0(,R2) PARM LENGTH * LTR R4,R4 CHECK FOR PRESENCE OF PARM BZ B1990 SKIP IF NO PARM * BCTR R4,0 COMPUTE ZERO RELATIVE LENGTH MVC STRBFR(0),2(R2) MODEL EX R4,*-6 SAVE THE STRING * LA R15,STRBFR(R4) POINT TO LAST BYTE OF PARM DATA LA R2,STRBFR POINT TO FIRST BYTE OF PARM DATA BAL R14,C0000 PARSE FIELDS * B1990 POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - B2000 - PROCESS SYSIN DATA ' *---------------------------------------------------------------------* * B2000 - PROCESS SYSIN DATA * *---------------------------------------------------------------------* * B2000 PUSHREG R14 SAVE RETURN PTR * LA R2,=CL8'SYSIN' BAL R14,D1000 OBTAIN SYSIN DATA SET INFO BNZ B2990 NO, RETURN * LA R2,ZDCBPS1 ESTABLISH DCB ADDRESSABILITY USING IHADCB,R2 * MVC ZDCBPS1(DCBPSL),DCBPS INITIALIZE DCB MVC DCBDDNAM,=CL8'SYSIN' DDNAME=SYSIN LA R0,B2980 SYSIN END-OF-DATA ROUTINE STCM R0,B'0111',DCBEODA EODAD=B2980 * MVC ZOPEN(OPENL),OPEN OPEN (ZDCBPS1,(INPUT)),MF=(E,ZOPEN) TM DCBOFLGS,DCBOFOPN DID SYSIN OPEN SUCCESSFULLY? BNO B2990 NO, RETURN * DROP R2 * B2100 GET ZDCBPS1 OBTAIN A RECORD MVC STRBFR(80),0(R1) * LA R15,STRBFR+70 POINT TO LAST BYTE OF PARM DATA LA R2,STRBFR POINT TO FIRST BYTE OF PARM DATA BAL R14,C0000 PARSE FIELDS * B B2100 * B2980 MVC ZCLOSE(CLOSEL),CLOSE CLOSE (ZDCBPS1),MF=(E,ZCLOSE) * B2990 POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - C0000 - PARSE FIELDS ' *---------------------------------------------------------------------* * C0000 - PARSE FIELDS * * ENTRY: * * R2 - START OF DATA AREA * * R15 - LAST BYTE OF DATA AREA * *---------------------------------------------------------------------* * C0000 PUSHREG R14 SAVE RETURN PTR * * REMOVE LEADING SPACES * LR R4,R2 SAVE STARTING LOCATION LA R14,1 INCREMENT A BYTE AT A TIME * C0100 CLI 0(R4),C' ' SPACE CHARACTER ? BNE C0150 NO, FOUND SIGNIFICANT CHARACTER BXLE R4,R14,C0100 SCAN ALL OF DATA B C0990 RETURN, NO DATA * * REMOVE TRAILING SPACES * C0150 LR R2,R4 NEW LOCATION OF DATA LR R4,R15 START WITH END OF RECORD LA R14,1 DECREMENT A BYTE AT A TIME LNR R14,R14 MAKE NEGATIVE INCREMENT LR R15,R2 FINISH WITH START OF RECORD * C0200 CLI 0(R4),C' ' CHECK FOR SPACE BNE C0250 FOUND A CHARACTER BXH R4,R14,C0200 KEEP LOOKING * * COMPUTE SCAN LENGTH - 1 * C0250 SR R4,R2 COMPUTE LENGTH OF STRING - 1 LTR R4,R4 COMPUTED VALUE SHOULD NEVER BM C0990 BECOME NEGATIVE * * LOCATE AND SAVE START AND LENGTH OF EACH FIELD * LA R5,0(R4,R2) POINT TO LAST BYTE OF PARM LA R4,1 STEP ONE BYTE AT A TIME LR R7,R2 SAVE PTR TO FIRST BYTE OF PARM * C0300 CLI 0(R2),C'=' FOUND END OF FIRST FIELD ? BE C0350 YES, SAVE FIRST FIELD CLI 0(R2),C',' FOUND END OF SECOND FIELD ? BNE C0400 NO, TRY NEXT CHARACTER C0350 MVC ZSEPCHAR,0(R2) SAVE SEPARATER CHARACTER BAL R14,C1000 SAVE CURRENT FIELD C0400 BXLE R2,R4,C0300 SCAN ENTIRE PARM * MVI ZSEPCHAR,C'!' INDICATE END OF DATA BAL R14,C1000 SAVE CURRENT FIELD * C0990 POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - C1000 - SAVE CURRENT FIELD ' *---------------------------------------------------------------------* * C1000 - SAVE CURRENT FIELD * *---------------------------------------------------------------------* * C1000 PUSHREG R14 SAVE RETURN PTR * L R14,=A(STRNUM*STRLEN) LA R0,ZSTRINGS(R14) CR R0,R6 MAXIMUM NUMBER OF STRINGS ? BH C1100 NO, CONTINUE * LA R0,43 MESSAGE LENGTH LA R1,=C'PSU0031I EXCEEDED MAXIMUM NUMBER OF STRINGS' BAL R14,W0000 WRITE MESSAGE TO JOB LOG ABEND 1 * C1100 CLI ZSEPCHAR,C',' IS THIS THE SECOND STRING ? BE C1150 YES, PROCESS SECOND * OC STR1PTR,STR1PTR IS THIS THE FIRST STRING ? BNZ C1150 NO, PROCESS SECOND * ST R7,STR1PTR STORE START OF FIELD LR R14,R2 CURRENT LOCATION SR R14,R7 COMPUTE LENGTH OF PARM ST R14,STR1LEN SAVE LENGTH LA R7,1(,R2) COMPUTE BEGINNING OF NEXT FIELD * CLI ZSEPCHAR,C'!' END OF DATA ? BE C1175 YES, POINT TO NEXT GROUP OF STRINGS * B C1200 RETURN * C1150 CLI ZSEPCHAR,C'=' FIRST STRING SEPARATOR ? BE C1200 YES, BUT MUST BE DATA * OC STR2PTR,STR2PTR ALREADY ACCOUNTED FOR END OF PARM ? BNZ C1200 YES, RETURN * ST R7,STR2PTR STORE START OF FIELD LR R14,R2 CURRENT LOCATION SR R14,R7 COMPUTE LENGTH OF PARM ST R14,STR2LEN SAVE LENGTH LA R7,1(,R2) COMPUTE BEGINNING OF NEXT FIELD * C1175 LA R6,STRLEN(,R6) POINT TO NEXT GROUP OF STRINGS * C1200 POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - D0000 - DYNAMIC ALLOCATION ' *---------------------------------------------------------------------* * D0000 - DYNAMIC ALLOCATION * *---------------------------------------------------------------------* * D0000 PUSHREG R14 SAVE RETURN PTR * LA R1,ZDRB ST R1,ZDRBP OI ZDRBP,X'80' LA R1,ZDRBP DYNALLOC , * D0990 POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - D1000 - OBTAIN DATA SET INFO ' *---------------------------------------------------------------------* * D1000 - OBTAIN DATA SET INFO * *---------------------------------------------------------------------* * D1000 PUSHREG R14 SAVE RETURN PTR * LA R14,ZINTU1 ALLOCATION TEXT UNIT 1 LA R15,ZINTU2 ALLOCATION TEXT UNIT 2 LA R0,ZINTU3 ALLOCATION TEXT UNIT 3 LA R1,ZINTU4 ALLOCATION TEXT UNIT 4 O R1,=A(X'80000000') MARK END OF LIST STM R14,R1,ZDTUP STORE LIST OF POINTERS * XC ZDRB,ZDRB MVI ZDRBL,20 MVI ZDRBVERB,S99VRBIN LA R14,ZDTUP ST R14,ZDRBTUP * MVC ZINTU1V,=Y(DINDDNAM) DDNAME REFERENCE MVC ZINTU1N,=Y(1) NUMBER OF ENTRIES MVC ZINTU1L,=Y(8) LENGTH OF EACH ENTRY MVC ZINTU1E(8),0(R2) * MVC ZINTU2V,=Y(DINRTDSN) RETURN DSNAME MVC ZINTU2N,=Y(1) NUMBER OF ENTRIES MVC ZINTU2L,=Y(44) LENGTH OF EACH ENTRY MVI ZINTU2E,C' ' INITIALIZE ENTRY MVC ZINTU2E+1(L'ZINTU2E-1),ZINTU2E * MVC ZINTU3V,=Y(DINRTTYP) RETURN DATA SET TYPE MVC ZINTU3N,=Y(1) NUMBER OF ENTRIES MVC ZINTU3L,=Y(1) LENGTH OF EACH ENTRY MVI ZINTU3E,0 INITIALIZE ENTRY * MVC ZINTU4V,=Y(DINRTORG) RETURN DATA SET ORGANIZATION MVC ZINTU4N,=Y(1) NUMBER OF ENTRIES MVC ZINTU4L,=Y(2) LENGTH OF EACH ENTRY MVC ZINTU4E,=Y(0) INITIALIZE ENTRY * BAL R14,D0000 * POPREG R14 RESTORE RETURN PTR LTR R15,R15 SET CONDITION CODE BR R14 RETURN * TITLE ' - D2000 - OBTAIN MEMBER NAME ' *---------------------------------------------------------------------* * D2000 - OBTAIN MEMBER NAME * *---------------------------------------------------------------------* * D2000 PUSHREG R14 SAVE RETURN PTR * LA R14,ZINTU1 ALLOCATION TEXT UNIT 1 LA R15,ZINTU5 ALLOCATION TEXT UNIT 2 O R15,=A(X'80000000') MARK END OF LIST STM R14,R15,ZDTUP STORE LIST OF POINTERS * XC ZDRB,ZDRB MVI ZDRBL,20 MVI ZDRBVERB,S99VRBIN LA R14,ZDTUP ST R14,ZDRBTUP * MVC ZINTU1V,=Y(DINDDNAM) DDNAME REFERENCE MVC ZINTU1N,=Y(1) NUMBER OF ENTRIES MVC ZINTU1L,=Y(8) LENGTH OF EACH ENTRY MVC ZINTU1E(8),0(R2) * MVC ZINTU5V,=Y(DINRTMEM) RETURN MEMBER NAME MVC ZINTU5N,=Y(1) NUMBER OF ENTRIES MVC ZINTU5L,=Y(8) LENGTH OF EACH ENTRY MVI ZINTU5E,C' ' INITIALIZE ENTRY MVC ZINTU5E+1(L'ZINTU5E-1),ZINTU5E * BAL R14,D0000 * POPREG R14 RESTORE RETURN PTR LTR R15,R15 SET CONDITION CODE BR R14 RETURN * TITLE ' - P0000 - PROCESS STRINGS ' *---------------------------------------------------------------------* * P0000 - PROCESS STRINGS ' * *---------------------------------------------------------------------* * P0000 PUSHREG R14 SAVE RETURN PTR * * OBTAIN SYSUT1 DATA SET INFORMATION * LA R2,=CL8'SYSUT1' DDNAME FOR INFO RETRIEVAL BAL R14,D1000 OBTAIN DATA SET INFORMATION BZ P0100 BRIF SUCCESSFUL * LA R0,37 MESSAGE LENGTH LA R1,=C'PSU0032I SYSUT1 DD STATEMENT MISSING.' BAL R14,W0000 WRITE MESSAGE TO JOB LOG ABEND 2 * P0100 MVC ZSYSUT1O,ZINTU4E SAVE SYSUT1 ORGANIZATION MVC ZSYSUT1T,ZINTU3E SAVE SYSUT1 DATA SET TYPE MVC ZSYSUT1D,ZINTU2E SAVE SYSUT1 DATA SET NAME MVI ZSYSUT1M,C' ' CLEAR MEMBER NAME MVC ZSYSUT1M+1(L'ZSYSUT1M-1),ZSYSUT1M * CLC ZSYSUT1O,=Y(DOPO) PARTITIONED DATA SET ? BE P0150 YES, DO PO CLC ZSYSUT1O,=Y(DOPOU) PARTITIONED DATA SET ? BNE P0200 NO, MUST BE SEQUENTIAL * P0150 LA R2,=CL8'SYSUT1' DDNAME FOR INFO RETRIEVAL BAL R14,D2000 OBTAIN MEMBER NAME BNZ P0200 BRIF NO MEMBER FOUND * MVC ZSYSUT1M,ZINTU5E CLI ZSYSUT1M,C' ' BE P0200 * MVC ZSYSUT1O,=Y(DOPS) TREAT AS SEQUENTIAL DATA SET * * OBTAIN SYSUT2 DATA SET INFORMATION * P0200 LA R2,=CL8'SYSUT2' DDNAME FOR INFO RETRIEVAL BAL R14,D1000 OBTAIN DATA SET INFORMATION BZ P0250 BRIF SUCCESSFUL * LA R0,37 MESSAGE LENGTH LA R1,=C'PSU0032I SYSUT2 DD STATEMENT MISSING.' BAL R14,W0000 WRITE MESSAGE TO JOB LOG ABEND 2 * P0250 MVC ZSYSUT2O,ZINTU4E SAVE SYSUT2 ORGANIZATION MVC ZSYSUT2T,ZINTU3E SAVE SYSUT2 DATA SET TYPE MVC ZSYSUT2D,ZINTU2E SAVE SYSUT2 DATA SET NAME MVI ZSYSUT2M,C' ' CLEAR MEMBER NAME MVC ZSYSUT2M+1(L'ZSYSUT2M-1),ZSYSUT2M * CLC ZSYSUT2O,=Y(DOPO) PARTITIONED DATA SET ? BE P0300 YES, DO PO CLC ZSYSUT2O,=Y(DOPOU) PARTITIONED DATA SET ? BNE P0350 NO, MUST BE SEQUENTIAL * P0300 LA R2,=CL8'SYSUT2' DDNAME FOR INFO RETRIEVAL BAL R14,D2000 OBTAIN MEMBER NAME BNZ P0350 BRIF NO MEMBER FOUND * MVC ZSYSUT2M,ZINTU5E CLI ZSYSUT2M,C' ' BE P0350 * MVC ZSYSUT2O,=Y(DOPS) TREAT AS SEQUENTIAL DATA SET * * SET IDENTICAL DATA SET FLAG * P0350 NI ZFLAG1,255-ZF1IDENT RESET FLAG - DATASETS ARE DIFFERENT CLC ZSYSUT1D,ZSYSUT2D ARE DSNAMES THE SAME ? BNE P0400 NO, THEN THEY'RE DIFFERENT CLC ZSYSUT1M,ZSYSUT2M ARE MEMBER NAMES THE SAME ? BNE P0400 NO, THEN THEY'RE DIFFERENT OI ZFLAG1,ZF1IDENT OTHERWISE, SET IDENTICAL FLAG * * PROCESS DATA SET BASED ON ORGANIZATION * P0400 LA R15,PTABLE START OF TABLE LA R0,L'PTABLE LENGTH OF EACH ENTRY LA R1,PTBLEND LAST BYTE OF LAST ENTRY * USING PTABLE,R15 * P0450 CLC PTBLORG,ZDSORGS FOUND COMPATIBLE DSORG'S ? BE P0500 YES, GO PROCESS DATA BXLE R15,R0,P0450 SCAN ENTIRE TABLE * P0500 L R15,PTBLRTN GET ROUTINE ADDRESS BALR R14,R15 GO TO ROUTINE * DROP R15 * P0990 POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - P1000 - PROCESS PO - PO DATA SETS ' *---------------------------------------------------------------------* * P1000 - PARTITIONED TO PARTITIONED * *---------------------------------------------------------------------* * P1000 PUSHREG R14 SAVE RETURN PTR * * * CURRENTLY UNIMPLEMENTED * * * ADD CODE HERE TO APPLY STRINGS TO EVERY MEMBER. * * SYSUT1 AND SYSUT2 COULD BE THE SAME DATA SET OR * DIFFERENT DATA SETS. SEE ROUTINE P3000 FOR AN * EXAMPLE OF HOW TO HANDLE UPDATE-IN-PLACE. * * LA R0,44 MESSAGE LENGTH LA R1,=C'PSU0033I SYSUT1/PO SYSUT2/PO NOT IMPLEMENTED' BAL R14,W0000 WRITE MESSAGE TO JOB LOG ABEND 3 ABEND UNTIL IMPLEMENTED * POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - P2000 - PROCESS PO - PS DATA SETS ' *---------------------------------------------------------------------* * P2000 - PARTITIONED TO SEQUENTIAL * *---------------------------------------------------------------------* * P2000 PUSHREG R14 SAVE RETURN PTR * * * CURRENTLY UNIMPLEMENTED * * * ADD CODE HERE TO APPLY STRINGS TO EVERY MEMBER. * * SINCE SYSUT2 IS SEQUENTIAL, ALL MEMBERS MUST BE * CONCATENATED ON OUTPUT. * LA R0,44 MESSAGE LENGTH LA R1,=C'PSU0033I SYSUT1/PO SYSUT2/PS NOT IMPLEMENTED' BAL R14,W0000 WRITE MESSAGE TO JOB LOG ABEND 3 ABEND UNTIL IMPLEMENTED * POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - P3000 - PROCESS PS - PS DATA SETS ' *---------------------------------------------------------------------* * P3000 - SEQUENTIAL TO SEQUENTIAL * *---------------------------------------------------------------------* * P3000 PUSHREG R14 SAVE RETURN PTR * * HANDLE THE CASE WHERE BOTH SYSUT1 AND SYSUT2 HAVE DSORG=PS * OR ARE TREATED AS DSORG=PS BECAUSE A MEMBER NAME IS GIVEN. * * SYSUT1 AND SYSUT2 COULD BOTH POINT TO THE IDENTICAL DATA * SET OR MEMBER. IF SO, RECORDS ARE UPDATED IN PLACE. * * OPEN SYSUT1 FOR INPUT (OR UPDATE-IN-PLACE) * LA R2,ZDCBPS1 ESTABLISH DCB ADDRESSABILITY USING IHADCB,R2 * MVC ZDCBPS1(DCBPSL),DCBPS INITIALIZE DCB MVC DCBDDNAM,=CL8'SYSUT1' DDNAME=SYSUT1 LA R0,P3980 SYSIN END-OF-DATA ROUTINE STCM R0,B'0111',DCBEODA EODAD=P3980 * TM ZFLAG1,ZF1IDENT ARE SYSUT1 AND SYSUT2 IDENTICAL ? BNO P3100 NO, OPEN FOR INPUT PROCESSING * MVC ZOPEN(OPENL),OPEN YES, OPEN SYSUT1 FOR UPDATE OPEN (ZDCBPS1,(UPDAT)),MF=(E,ZOPEN) B P3150 * P3100 MVC ZOPEN(OPENL),OPEN OPEN (ZDCBPS1,(INPUT)),MF=(E,ZOPEN) * DROP R2 * * OPEN SYSUT2 FOR OUTPUT (IF SYSUT1 IS OPEN FOR INPUT) * LA R2,ZDCBPS2 ESTABLISH DCB ADDRESSABILITY USING IHADCB,R2 * MVC ZDCBPS2(DCBPSL),DCBPS INITIALIZE DCB MVC DCBDDNAM,=CL8'SYSUT2' DDNAME=SYSUT1 * MVC ZOPEN(OPENL),OPEN OPEN (ZDCBPS2,(OUTPUT)),MF=(E,ZOPEN) * DROP R2 * * PROCESS THE REPLACEMENT STRINGS AGAINST SYSUT1 * P3150 GET ZDCBPS1 GET A RECORD * BAL R14,R0000 REPLACE STRINGS IN RECORD * TM ZFLAG1,ZF1IDENT SYSSUT1 AND SYSUT2 IDENTICAL ? BNO P3200 NO, THEN WRITE NEW RECORD PUTX ZDCBPS1 REPLACE OLD RECORD B P3150 PROCESS THE ENTIRE DATA SET * P3200 LR R0,R1 COPY RECORD PTR PUT ZDCBPS2,(0) OUTPUT NEW RECORD B P3150 PROCESS THE ENTIRE DATA SET * * CLOSE THE DATA SETS AND RETURN * P3980 MVC ZCLOSE(CLOSEL),CLOSE CLOSE (ZDCBPS1),MF=(E,ZCLOSE) TM ZFLAG1,ZF1IDENT SYSUT1 AND SYSUT2 IDENTICAL ? BO P3990 YES, SKIP CLOSE CLOSE (ZDCBPS2),MF=(E,ZCLOSE) * P3990 POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - P4000 - INCOMPATIBLE DSORGS ' *---------------------------------------------------------------------* * P4000 - INCOMPATIBLE DSORGS * *---------------------------------------------------------------------* * P4000 PUSHREG R14 SAVE RETURN PTR * * * UNIMPLEMETABLE * * LA R0,28 LA R1,=C'SYSUT2 REQUIRES MEMBER NAME.' BAL R14,W0000 * LA R0,44 MESSAGE LENGTH LA R1,=C'PSU0033I SYSUT1 OR SYSUT2 DSORG INCOMPATIBLE' BAL R14,W0000 WRITE MESSAGE TO JOB LOG ABEND 3 ABEND ALWAYS * POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - R0000 - REPLACE STRINGS IN RECORD ' *---------------------------------------------------------------------* * R0000 - REPLACE STRINGS IN RECORD * *---------------------------------------------------------------------* * * THIS ROUTINE OBEYS JCL RULES OF STRING CONCATENATION. * THAT IS, A SEARCH STRING THAT BEGINS WITH & ENDS AT * EITHER A NON-ALPHANUMERIC OR . CHARACTER. IF IT ENDS * WITH A . THEN THE . IS REMOVED. * * FOR EXAMPLE IF THE PARM IS CODED AS ('&&PREF=PSCOTT') * (NOTE THE && IN JCL WILL BE SEEN AS A SINGLE & HERE) * THEN &PREF..MY.CNTL WILL BE REPLACED BY PSCOTT.MY.CNTL * BUT &PREFIX..MY.CNTL WILL NOT MATCH AND NO REPLACEMENT * WILL BE MADE. * * SEARCH STRINGS THAT DO NOT BEGIN WITH & HAVE NO SUCH * RULES APPPLIED, SO THAT IF THE PARM IS ('PREF=PSCOTT') * THEN &PREF..MY.CNTL WITLL BE BECOME &PSCOTT..MY.CNTL * AND &PREFIX..MY.CNTL WILL BECOME &PSCOTTIX..MY.CNTL * R0000 PUSHREG R14 SAVE RETURN PTR PUSHREG R1 SAVE RECORD PTR * MVI ZWORKREC,C' ' CLEAR WORK RECORD MVC ZWORKREC+1(L'ZWORKREC-1),ZWORKREC MVC ZWORKREC(71),0(R1) COPY DATA RECORD * LA R6,ZSTRINGS START OF PTRS LA R4,STRLEN LENGTH OF EACH ENTRY L R5,ZSTREPTR LAST BYTE OF LAST ENTRY * R0100 L R7,STR1PTR PTR TO STRING TO LOCATE L R8,STR1LEN PTR TO STRING LENGTH LTR R7,R7 NULL STRING PTR ? BZ R0900 YES, SKIP STRING LTR R8,R8 LENGTH ZERO ? BZ R0900 YES, SKIP STRING * BCTR R8,0 GET ZERO RELATIVE LENGTH LA R1,ZWORKREC POINT AT RECORD LA R14,1 SCAN A BYTE AT A TIME LA R15,ZWORKREC+L'ZWORKREC-1 LAST BYTE IN RECORD TO SCAN SR R15,R8 ADJUST FOR LENGTH OF STRING * R0150 CLC 0(0,R1),0(R7) MODEL COMPARE INSTRUCTION EX R8,*-6 HAS STRING BEEN LOCATED ? BNE R0300 NO, KEEP LOOKING * CLI 0(R7),C'&&' FIRST CHAR AN AMPERSAND ? BNE R0350 NO, THEN REPLACE STRING * SR R2,R2 CLEAR REGISTER IC R2,1(R8,R1) GET CHARACTER AFTER STRING LA R2,TCHARTBL(R2) INDEX INTO TABLE * CLI 0(R2),C'.' CONCATENATION CHARACTER ? BNE R0250 NO, THEN KEEP LOOKING FOR STRING LA R8,1(,R8) REMOVE THE PERIOD WITH THE STRING B R0350 REMOVE STRING * R0250 CLI 0(R2),0 STRING TERMINATION CHARACTER ? BE R0350 YES, REPLACE THE STRING * R0300 BXLE R1,R14,R0150 SCAN ENTIRE RECORD B R0900 STRING WAS NOT FOUND * R0350 LR R2,R1 SAVE STRING PTR LR R0,R2 DESTINATION PTR (STRING) LA R1,ZWORKREC+L'ZWORKREC COMPUTE THE SR R1,R0 DESTINATION LENGTH LA R14,1(R8,R2) SOURCE PTR (CHAR AFTER STRING) LA R15,ZWORKREC+L'ZWORKREC COMPUTE THE SR R15,R14 SOURCE LENGTH ICM R15,B'1000',=C' ' SPACE FILL MVCL R0,R14 SHIFT THE STRING OVER LR R1,R2 RESTORE STRING PTR * L R7,STR2PTR PTR TO REPLACEMENT STRING L R8,STR2LEN LENGTH OF REPLACEMENT STRING LTR R7,R7 NULL STRING PTR ? BZ R0900 YES, NOTHING TO REPLACE LTR R8,R8 LENGTH ZERO ? BZ R0900 YES, NOTHING TO REPLACE * LA R2,ZWORKREC+L'ZWORKREC-1 PTR TO TARGET LR R15,R2 COMPUTE THE SR R15,R8 PTR TO SOURCE LA R14,1(,R15) SR R14,R1 * R0400 MVC 0(1,R2),0(R15) MOVE (PTR-N) TO (PTR) BCTR R2,0 BCTR R15,0 BCT R14,R0400 FINISH WITH START OF FIELD * BCTR R8,0 MVC 0(0,R1),0(R7) EX R8,*-6 * R0900 BXLE R6,R4,R0100 REPLACE ALL STRINGS IN RECORD * POPREG R1 RESTORE RECORD PTR MVC 0(71,R1),ZWORKREC REPLACE RECORD * POPREG R14 RESTORE RETURN PTR BR R14 RETURN * TITLE ' - W0000 - WRITE TO LOG ' *---------------------------------------------------------------------* * W0000 - WRITE TO LOG * *---------------------------------------------------------------------* * W0000 PUSHREG R14 SAVE RETURN PTR * MVC ZWTO,WTO INITIALIZE WTO PARAMETER LIST MVI ZMSG,C' ' CLEAR MESSAGE BUFFER MVC ZMSG+1(L'ZMSG-1),ZMSG TO ALL SPACES * LR R15,R0 GET MESSAGE LENGTH CH R15,=Y(L'ZMSG) TOO LARGE FOR MESSAGE BUFFER ? BNH W0010 NO, MESSAGE WILL FIT LH R15,=Y(L'ZMSG) TRUNCATE MESSAGE TO BUFFER SIZE W0010 BCTR R15,0 MAKE LENGTH ZERO RELATIVE MVC ZMSG(0),0(R1) INSTRUCTION TEMPLATE EX R15,*-6 MOVE MESSAGE TO WTO BUFFER * WTO MF=(E,ZWTO) WRITE TO JOB LOG * POPREG R14 RESTORE RETURN PTR BR R14 RETURN * * DUMP THE REPLACEMENT STRINGS TO THE JOB LOG * W0100 PUSHREG R14 * LA R6,ZSTRINGS START OF PTRS LA R4,STRLEN LENGTH OF EACH ENTRY L R5,ZSTREPTR LAST BYTE OF LAST ENTRY * W0120 MVC ZWTO,WTO INITIALIZE WTO PARAMETER LIST MVI ZMSG,C' ' CLEAR MESSAGE BUFFER MVC ZMSG+1(L'ZMSG-1),ZMSG TO ALL SPACES LA R1,ZMSG * USING STRINGS,R6 USING ZMSG,R1 * MVC ZMSG(8),=C'PSU0034I' MESSAGE PREFIX LA R1,9(0,R1) NEXT AVAILABLE SLOT * MVC ZMSG(6),=C'(NULL)' DEFAULT SEARCH STRING L R7,STR1PTR SEARCH STRING PTR L R8,STR1LEN SEARCH STRING LENGTH LTR R7,R7 NULL SEARCH STRING PTR ? BZ W0130 YES, MOVE ON LTR R8,R8 NULL SEARCH STRING LENGTH ? BZ W0130 YES, MOVE ON MVC ZMSG(6),=CL6' ' CLEAR '(NULL)' BCTR R8,0 MAKE ZERO RELATIVE LENGTH MVC ZMSG(0),0(R7) INSTRUCTION TEMPLATE EX R8,*-6 COPY SEARCH STRING TO BUFFER LA R1,1(R8,R1) NEXT AVAILABLE SLOT * W0130 MVI ZMSG,C'=' SET DEMARCATION LITERAL LA R1,1(0,R1) NEXT AVAILABLE SLOT * MVC ZMSG(6),=C'(NULL)' DEFAULT REPLACEMENT STRING L R7,STR2PTR REPLACEMENT STRING PTR L R8,STR2LEN REPLACEMENT STRING LEN LTR R7,R7 NULL REPLACEMENT STRING PTR ? BZ W0150 YES, MOVE ON LTR R8,R8 NULL REPLACEMENT STRING LENGTH ? BZ W0140 YES, MOVE ON MVC ZMSG(6),=CL6' ' CLEAR '(NULL)' BCTR R8,0 MAKE ZERO RELATIVE LENGTH MVC ZMSG(0),0(R7) INSTRUCTION TEMPLATE EX R8,*-6 COPY REPLACEMENT STRNG TO BUFFER LA R1,1(R8,R1) NEXT AVAILABLE SLOT DROP R1 * W0140 WTO MF=(E,ZWTO) * W0150 BXLE R6,R4,W0120 SCAN ENTIRE OPERATOR TABLE * POPREG R14 RESET ALL BITS BR R14 * TITLE ' - TABLES ' *---------------------------------------------------------------------* * DATA SET PROCESSING TABLE * *---------------------------------------------------------------------* DS 0F ALIGN TABLE ON FULLWORD BOUNDARY PTABLE DS 0CL8 DATA SET PROCESSING TABLE PTBLORG DS A . ORGANIZATION (SYSUT1,SYSUT2) PTBLRTN DS A . ROUTINE ORG PTABLE DC Y(DOPO,DOPO),A(P1000) DC Y(DOPO,DOPS),A(P2000) DC Y(DOPS,DOPS),A(P3000) PTBLEND EQU *-1 DC Y(-001,-001),A(P4000) * *---------------------------------------------------------------------* * TABLE OF STRING TERMINATION CHARACTERS * *---------------------------------------------------------------------* * TCHARTBL DC 256X'00' ORG TCHARTBL+C'A' DC C'ABCDEFGHI' ORG TCHARTBL+C'J' DC C'JKLMNOPQR' ORG TCHARTBL+C'S' DC C'STUVWXYZ' ORG TCHARTBL+C'0' DC C'0123456789' ORG TCHARTBL+C'Z' DC C'Z' ORG TCHARTBL+C'#' DC C'#' ORG TCHARTBL+C'$' DC C'4' ORG TCHARTBL+C'.' DC C'.' ORG , * *---------------------------------------------------------------------* * STRING TABLE * *---------------------------------------------------------------------* * STRINGS DSECT , MAP STRING TABLE STR1PTR DS F . STRING 1 PTR STR1LEN DS F . STRING 1 LENGTH STR2PTR DS F . STRING 2 PTR STR2LEN DS F . STRING 2 LENGTH STRBFR DS CL100 . STRING BUFFER STRLEN EQU *-STRINGS LENGTH OF EACH ENTRY STRNUM EQU 500 TOTAL NUMBER OF ENTRIES PSU003 CSECT , RESTORE CSECT * TITLE ' - CONSTANTS AND TEMPLATES' *---------------------------------------------------------------------* * CONSTANTS AND TEMPLATES * *---------------------------------------------------------------------* * ERROR4 EQU 4 ERROR8 EQU 8 ERROR12 EQU 12 * WTO WTO '4....10...15...20...25...30...35...40...45...50...55', C DESC=6,ROUTCDE=11,MF=L WTOL EQU *-WTO * DS 0F OPEN OPEN (*),MF=L OPENL EQU *-OPEN * DCBPS DCB DDNAME=Z,DSORG=PS,MACRF=(GL,PM),RECFM=FB,LRECL=80 DCBPSL EQU *-DCBPS * DCBPO DCB DDNAME=Z,DSORG=PO,MACRF=(R,W),RECFM=FB,LRECL=80 DCBPOL EQU *-DCBPO * DS 0F CLOSE CLOSE (*),MF=L CLOSEL EQU *-CLOSE * TITLE ' - LOCAL VARIABLE STORAGE ' *---------------------------------------------------------------------* * LOCAL VARIABLE STORAGE * *---------------------------------------------------------------------* * ZVARS DSECT , ZSAVEALL DS 18F SAVE AREA ZRC DS F RETURN CODE * * FLAG BYTES * ZFLAG1 DS B FLAG BYTE 1 ZF1IDENT EQU B'10000000' . SYSUT1 & SYSUT2 ARE IDENTICAL * EQU B'01000000' . UNUSED * EQU B'00100000' . UNUSED * EQU B'00010000' . UNUSED * EQU B'00001000' . UNUSED * EQU B'00000100' . UNUSED * EQU B'00000010' . UNUSED * EQU B'00000001' . UNUSED * * I/O WORK AREAS * ZDIRREC DS CL256 ZDATAREC DS CL80 ZWORKREC DS CL(L'ZDATAREC*2) * * DATA SET VARIABLE AND CONTROL BLOCKS * * WTO MF=L ZWTO DS XL(WTOL) ZMSG EQU ZWTO+4,52 * ZOPEN DS 0F,(OPENL)X OPEN PARAMETER LIST ZCLOSE DS 0F,(CLOSEL)X CLOSE PARAMETER LIST * ZDCBPS1 DS 0D,(DCBPSL)X SYSUT1 SEQUENTIAL DATA SET DCB ZDCBPO1 DS 0D,(DCBPOL)X SYSUT1 PARTITIONED DATA SET DCB ZJFCB1 DS 0F,(JFCBLGTH)X SYSUT1 JFCB * ZDCBPS2 DS 0D,(DCBPSL)X SYSUT2 SEQUENTIAL DATA SET DCB ZDCBPO2 DS 0D,(DCBPOL)X SYSUT2 PARTITIONED DATA SET DCB ZJFCB2 DS 0F,(JFCBLGTH)X SYSUT2 JFCB * ZEXLST1 DS 3F SYSUT1 EXIT LIST ZEXLST2 DS 3F SYSUT2 EXIT LIST * ZDSNAMES DS 0CL88 ZSYSUT1D DS CL44 SYSUT1 DATA SET NAME ZSYSUT2D DS CL44 SYSUT2 DATA SET NAME * ZMEMBERS DS 0CL16 ZSYSUT1M DS CL8 SYSUT1 MEMBER NAME ZSYSUT2M DS CL8 SYSUT2 MEMBER NAME * ZDSORGS DS 0AL4 ZSYSUT1O DS Y SYSUT1 DATA SET ORGANIZATION ZSYSUT2O DS Y SYSUT2 DATA SET ORGANIZATION * ZDSTYPES DS 0AL2 ZSYSUT1T DS X SYSUT1 DATA SET TYPE ZSYSUT2T DS X SYSUT2 DATA SET TYPE * * DYNAMIC ALLOCATION PARAMETER LISTS * ZDRBP DS A(ZDRB) REQUEST BLOCK PTR * ZDRB DS 0CL20 REQUEST BLOCK ZDRBL DS AL1(20) . LENGTH OF RB ZDRBVERB DS AL1(S99VRBAL) . VERB CODE (ALLOCATION) ZDRBFLAG DS AL2(0) . FLAGS ZDRBECD DS AL2(0) . ERROR CODE FIELDS ZDRBRCD DS AL2(0) . REASON CODE FIELDS ZDRBTUP DS A(ZDTUP) . ADR OF TEXT UNIT PTRS DS A(0) . RESERVED DS AL4(0) . FLAGS FOR AUTHORIZED FUNCTIONS * ZDTUP DS 8A TEXT UNIT POINTER LIST * ZINTU1 DS 0CL14 TEXT UNIT 1 ZINTU1V DS AL2(DINDDNAM) . DDNAME REFERENCE ZINTU1N DS AL2(1) . NUMBER OF ENTRIES ZINTU1L DS AL2(8) . LENGTH OF ENTRY ZINTU1E DS CL8' ' . ENTRY PARAMETER * ZINTU2 DS 0CL50 TEXT UNIT 2 ZINTU2V DS AL2(DINRTDSN) . RETURN DATA SET NAME ZINTU2N DS AL2(1) . NUMBER OF ENTRIES ZINTU2L DS AL2(44) . LENGTH OF ENTRY ZINTU2E DS CL44 . ENTRY PARAMETER * ZINTU3 DS 0CL7 TEXT UNIT 3 ZINTU3V DS AL2(DINRTTYP) . RETURN DATA SET TYPE ZINTU3N DS AL2(1) . NUMBER OF ENTRIES ZINTU3L DS AL2(1) . LENGTH OF ENTRY ZINTU3E DS XL1'00' . ENTRY PARAMETER DTDUMMY EQU X'80' DTTERM EQU X'40' DTSYSIN EQU X'20' DTSYSOUT EQU X'10' DTFILE EQU X'00' * ZINTU4 DS 0CL8 TEXT UNIT 4 ZINTU4V DS AL2(DINRTORG) . RETURN DATA SET ORGANIZATION ZINTU4N DS AL2(1) . NUMBER OF ENTRIES ZINTU4L DS AL2(2) . LENGTH OF ENTRY ZINTU4E DS AL2(0) . ENTRY PARAMETER DOUNK EQU X'0000' DOVSAM EQU X'0008' DOPO EQU X'0200' DOPOU EQU X'0300' DODA EQU X'2000' DODAU EQU X'2100' DOPS EQU X'4000' DOPSU EQU X'4100' * ZINTU5 DS 0CL14 TEXT UNIT 5 ZINTU5V DS AL2(DINRTMEM) . RETURN MEMBER NAME ZINTU5N DS AL2(1) . NUMBER OF ENTRIES ZINTU5L DS AL2(8) . LENGTH OF ENTRY ZINTU5E DS CL8' ' . ENTRY PARAMETER * * STRING STORAGE * ZSTREPTR DS F ZSEPCHAR DS C ZSTRINGS DS (STRNUM*STRLEN)X STORAGE FOR STRING PTRS AND LENGTHS * ZVARL EQU *-ZVARS * PUSH PRINT PRINT NOGEN * DCBD DSORG=PS IEFZB4D0 , IEFZB4D2 , IEFJFCBN , IKJDAP08 , * POP PRINT * END PSU003 ./ ADD NAME=PSU004,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 * COPYRIGHT (C) PAUL A. SCOTT, 1989. ALL RIGHTS RESERVED. * ANY USE OF THIS CODE MUST RETAIN THE ABOVE COPYRIGHT NOTICE * * MODULE PSU004 * AUTHOR P. SCOTT * * PSU004 IS RENT,REUS * * EXAMPLE: * //STEP1 EXEC PGM=PSU004,PARM=('1989') * //SYSOUT DD SYSOUT=* * PSU004 PENTER MAIN,VARS=(WRKDSECT,WRKLEN),STACK=1 * *---------------------------------------------------------------------* * MAINLINE * *---------------------------------------------------------------------* * * GET FULL FOUR DIGIT YEAR IN CHARACTER FORMAT * ACCOUNTING FOR CENTURY CHANGES. USE CURRENT * YEAR UNLESS PARM SPECIFIES A YEAR. * PUSHREG R1 SAVE PARM ADDRESS * TIME DEC * LR R15,R1 COPY DATE SRL R15,24 ISOLATE CENTURY SLL R15,4 MAKE ROOM FOR SIGN LA R15,12(,R15) INSERT SIGN ST R15,WRKDWORD+4 SAVE IN DOUBLEWORD CVB R15,WRKDWORD MAKE BINARY VALUE MH R15,=H'100' CONVERT TO YEARS AH R15,=H'1900' ADD IN BASE CENTURY * SLL R1,8 STRIP OFF CENTURY SRL R1,24 STRIP OFF DAYS SLL R1,4 MAKE ROOM FOR SIGN LA R1,12(,R1) INSERT SIGN ST R1,WRKDWORD+4 SAVE IN DOUBLEWORD CVB R1,WRKDWORD MAKE BINARY VALUE * AR R1,R15 INCLUDE CENTURIES STH R1,WRKYEAR SAVE YEAR * POPREG R1 RESTORE PARM ADDRESS * L R1,0(,R1) CALLER'S PARM LH R15,0(,R1) GET PARM LENGTH CH R15,=H'4' CORRECT LENGTH FOR YEAR ? BNE A0010 NO, IGNORE IT PACK WRKDWORD,2(4,R1) MAKE PACKED DECIMAL CVB R1,WRKDWORD MAKE BINARY STH R1,WRKYEAR SAVE YEAR * A0010 LH R1,WRKYEAR YEAR IN BINARY CVD R1,WRKDWORD MAKE PACKED DECIMAL UNPK WRKYEARZ,WRKDWORD MAKE ZONED DECIMAL OI WRKYEARZ+3,C'0' REMOVE SIGN * * COMPUTE FIRST DAY OF EACH MONTH * LA R2,12 NUMBER OF MONTHS LA R11,WRKDAY1-1 FIRST DAY OF MONTH TABLE A0020 STH R2,WRKMONTH SAVE MONTH FOR DAYOFWK PCALL DAYOFWK,(WRKMONTH,=H'1',WRKYEAR) STC R15,0(R2,R11) SAVE FIRST DAY OF MONTH BCT R2,A0020 COMPUTE FOR ALL MONTHS * * CHECK FOR LEAP YEAR * MVC WRKDAYS(12),DAYS SET DEFAULT WEEKDAYS PCALL DAYOFWK,(=H'2',=H'28',WRKYEAR) LR R2,R15 SAVE WEEKDAY OF 2/28 PCALL DAYOFWK,(=H'3',=H'1',WRKYEAR) CR R15,R2 DID WEEKDAY WRAP AROUND ? BH A0030 NO, COMPARE DIFFERENCE IN DAYS LA R15,7(,R15) ADJUST FOR WEEKDAY WRAP A0030 SR R15,R2 COMPUTE DIFFERENCE IN DAYS CH R15,=H'1' ONE DAY BETWEEN 2/28 AND 3/1 ? BNE A0040 NO, IT'S A LEAP YEAR MVI WRKDAYS+1,28 RESET * * CLEAR CALENDAR TO ALL BLANKS * A0040 LA R15,29 NUMBER OF LINES LA R14,WRKLINE START OF LINES A0050 MVC 0(L'WRKLINE,R14),BLANKS CLEAR LINE LA R14,L'WRKLINE(,R14) ADVANCE TO NEXT LINE BCT R15,A0050 CLEAR NEXT LINE * * FILL IN NAME OF EACH MONTH AND YEAR * LA R15,WRKLINE START OF LINE MVI 0(R15),C'1' EJECT TO TOP OF FORM MVC 1(7,R15),=C'JANUARY' SET JANUARY MVC 24(4,R15),WRKYEARZ SET YEAR MVC 32(8,R15),=C'FEBRUARY' SET FEBRUARY MVC 55(4,R15),WRKYEARZ SET YEAR MVC 63(5,R15),=C'MARCH' SET MARCH MVC 86(4,R15),WRKYEARZ SET YEAR MVC 94(5,R15),=C'APRIL' SET APRIL MVC 117(4,R15),WRKYEARZ SET YEAR * LA R15,10*L'WRKLINE(,R15) SKIP TO NEXT ROW MVC 1(3,R15),=C'MAY' SET MAY MVC 24(4,R15),WRKYEARZ SET YEAR MVC 32(4,R15),=C'JUNE' SET JUNE MVC 55(4,R15),WRKYEARZ SET YEAR MVC 63(5,R15),=C'JULY' SET JULY MVC 86(4,R15),WRKYEARZ SET YEAR MVC 94(6,R15),=C'AUGUST' SET AUGUST MVC 117(4,R15),WRKYEARZ SET YEAR * LA R15,10*L'WRKLINE(,R15) SKIP TO NEXT ROW MVC 1(9,R15),=C'SEPTEMBER' SET SEPTEMBER MVC 24(4,R15),WRKYEARZ SET YEAR MVC 32(7,R15),=C'OCTOBER' SET OCTOBER MVC 55(4,R15),WRKYEARZ SET YEAR MVC 63(8,R15),=C'NOVEMBER' SET NOVEMBER MVC 86(4,R15),WRKYEARZ SET YEAR MVC 94(8,R15),=C'DECEMBER' SET DECEMBER MVC 117(4,R15),WRKYEARZ SET YEAR * * FILL IN NAME OF DAY OF WEEK FOR EACH MONTH * LA R14,3 NUMBER OF ROWS LA R15,WRKLINE ADDRESS FIRST ROW SH R15,=Y(9*L'WRKLINE) BACK UP FOR LOOP A0060 LA R15,10*L'WRKLINE(,R15) NEXT ROW MVC 1(27,R15),=C'SUN MON TUE WED THU FRI SAT' MVC 32(27,R15),1(R15) FILL NEXT COLUMN MVC 63(27,R15),1(R15) FILL NEXT COLUMN MVC 94(27,R15),1(R15) FILL NEXT COLUMN BCT R14,A0060 ADVANCE TO NEXT ROW * * UNDERLINE DAY OF WEEK FOR EACH MONTH * LA R14,3 NUMBER OF ROWS LA R15,WRKLINE ADDRESS FIRST ROW SH R15,=Y(8*L'WRKLINE) BACK UP FOR LOOP A0070 LA R15,10*L'WRKLINE(,R15) NEXT ROW MVI 1(R15),C'-' UNDERLINE WEEKDAYS MVC 2(26,R15),1(R15) FILL FIRST COLUMN MVC 32(27,R15),1(R15) FILL NEXT COLUMN MVC 63(27,R15),1(R15) FILL NEXT COLUMN MVC 94(27,R15),1(R15) FILL NEXT COLUMN BCT R14,A0070 ADVANCE TO NEXT ROW * * GENERATE CALENDAR OF DAYS IN EACH MONTH * LA R2,1 INITIALIZE MONTH LA R4,3 NUMBER OF ROWS LA R5,WRKLINE START OF LINE SH R5,=Y(7*L'WRKLINE) BACK UP FOR LOOP A0080 LA R5,10*L'WRKLINE(,R5) NEXT ROW SR R6,R6 CLEAR OFFSET TO MONTH LA R11,4 NUMBER OF MONTHS PER ROW A0090 LA R7,0(R6,R5) ADDRESS MONTH SR R8,R8 CLEAR DAYS IN MONTH SR R9,R9 CLEAR DAY OF WEEK IC R8,WRKDAYS-1(R2) GET DAYS IN MONTH IC R9,WRKDAY1-1(R2) GET FIRST DAY OF WEEK LA R10,1 GET FIRST DAY OF MONTH A0100 LR R15,R9 COPY DAY OF WEEK MH R15,=H'4' COMPUTE OFFSET IN LINE LA R15,0(R15,R7) COMPUTE ADDRESS IN LINE CVD R10,WRKDWORD MAKE DAY PACKED DECIMAL MVC 0(4,R15),=X'40202120' EDIT PATTERN ZZ9 ED 0(4,R15),WRKDWORD+6 MAKE DAY DISPLAYABLE LA R10,1(,R10) NEXT DAY LA R9,1(,R9) NEXT DAY OF WEEK CH R9,=H'7' GREATER THAN SATURADAY ? BL A0110 NO, CONTINUE SR R9,R9 YES, RESET TO SUNDAY LA R7,L'WRKLINE(,R7) GO TO NEXT LINE A0110 BCT R8,A0100 DO ALL DAYS LA R2,1(,R2) NEXT MONTH LA R6,31(,R6) ADDRESS OF NEXT MONTH BCT R11,A0090 ALL MONTHS THIS ROW BCT R4,A0080 ALL ROWS * * PUT CALENDAR TO DDNAME SYSOUT * OPEN (DCB,(OUTPUT)) LA R2,29 LA R11,WRKLINE PUT PUT DCB,(R11) LA R11,L'WRKLINE(,R11) BCT R2,PUT CLOSE (DCB) * * RETURN TO CALLER * PEXIT RC=0 LTORG , * DAYS DC AL1(31,29,31,30,31,30,31,31,30,31,30,31) BLANKS DC 256C' ' * DCB DCB DDNAME=SYSOUT, + DSORG=PS, + MACRF=PM, + RECFM=FBA, + LRECL=121, + BLKSIZE=6171 * WRKDSECT DSECT , WRKSAVEA DS 18F FIRST SAVE AREA WRKSAVE2 DS 18F SECOND SAVE AREA WRKID EQU WRKSAVEA,4 * WRKDWORD DS D DOUBLE WORD WRKFWORD DS F FULL WORD WRKHWORD DS H HALF WORD WRKBYTE DS B BYTE * WRKYEARZ DS CL4 CHARACTER YEAR WRKYEAR DS H NUMERIC YEAR WRKMONTH DS H NUMERIC MONTH WRKDAY1 DS 12AL1 FIRST DAY OF EACH MONTH WRKDAYS DS 12AL1 NUMBER OF DAYS EACH MONTH * WRKLINE DS 29CL121 * WRKEND DS 0D WRKLEN EQU *-WRKDSECT * EJECT , *---------------------------------------------------------------------* * DAYOFWK SUBROUTINE * *---------------------------------------------------------------------* * DAYOFWK PENTER FUNC * L R4,0(,R1) MONTH LH R4,0(,R4) * L R5,4(,R1) DAY LH R5,0(,R5) * L R6,8(,R1) YEAR LH R6,0(,R6) * * COMPUTE CENTURY = YEAR / 100 * COMPUTE DECADE = YEAR MOD 100 * XR R14,R14 CLEAR HIGH WORD OF DIVISOR LR R15,R6 GET DIVISOR ( YEAR ) LA R2,100 GET DIVIDEND DR R14,R2 COMPUTE LR R7,R15 R7 = CENTURY (QUOTIENT) LR R8,R14 R8 = DECADE (REMAINDER) * * THE DAY OF THE MONTH INCREMENTS THE BASE BY THE * SAME NUMBER OF DAYS, THE PASSING OF EACH YEAR ADDS * A DAY, AND EACH LEAP YEAR ADDS A DAY * * WEEKDAY = ( ( YEAR / 4 ) - CENTURY ) + ( YEAR / 400 ) + * DAY + YEAR + BMC( MONTH-1 ) * LR R9,R6 GET YEAR SRL R9,2 WEEKDAY = ( YEAR / 4 ) * SR R9,R7 WEEKDAY = WEEKDAY - CENTURY * LR R14,R7 GET CENTURY ( YEAR / 100 ) SRL R14,2 COMPUTE ( YEAR / 400 ) AR R9,R14 WEEKDAY = WEEKDAY + ( YEAR / 400 ) * AR R9,R5 WEEKDAY = WEEKDAY + DAY * AR R9,R6 WEEKDAY = WEEKDAY + YEAR * LR R14,R4 GET MONTH BCTR R14,0 MINUS 1 SR R15,R15 CLEAR REGISTER IC R15,BMC(R14) INDEX INTO BASE MONTH CODE TABLE AR R9,R15 WEEKDAY = WEEKDAY + BMC( MONTH-1 ) * * FOR A LEAP YEAR, REMOVE THE EXTRA DAY BEFORE IT OCCURS, * I.E. JANUARY AND FEBRUARY * * IF ( ( YEAR MOD 400 = 0 ) OR * ( ( YEAR MOD 4 = 0 ) AND ( DECADE ^= 0 ) ) ) * IF ( MONTH < 3 ) * WEEKDAY = WEEKDAY - 1 * XR R14,R14 CLEAR HIGH WORD OF DIVISOR LR R15,R6 GET DIVISOR ( YEAR ) LA R2,400 GET DIVIDEND DR R14,R2 COMPUTE ( YEAR MOD 400 ) * LTR R14,R14 CHECK LEAP CENTURY ( YEAR MOD 400 ) BZ D0010 YES, ALSO LEAP YEAR XR R14,R14 CLEAR HIGH WORD OF DIVISOR LR R15,R6 GET DIVISOR ( YEAR ) LA R2,4 GET DIVIDEND DR R14,R2 COMPUTE ( YEAR MOD 4 ) LTR R14,R14 POSSIBLE LEAP YEAR ? BNZ D00005 NO, SHOW NOT A LEAP YEAR LTR R8,R8 YES, BUT IS IT A CENTURY YEAR ? BNZ D0010 NO, SO IT'S A LEAP YEAR D00005 LA R14,1 YES, NOT A LEAP CENTURY YEAR * D0010 LTR R14,R14 LEAP YEAR ? BNZ D0020 NO, SKIP ADJUSTMENT CH R4,=H'3' JANUARY OR FEBRUARY ? BNL D0020 NO, SKIP ADJUSTMENT BCTR R9,0 WEEKDAY = WEEKDAY - 1 * * RETURN ( WEEKDAY MOD 7 ) * D0020 XR R14,R14 CLEAR HIGH WORD OF DIVISOR LR R15,R9 GET LOW WORD OF DIVISOR (WEEKDAY) LA R2,7 GET DIVIDEND DR R14,R2 COMPUTE WEEKDAY MOD 7 LR R15,R14 RETURN VALUE (WEEKDAY MOD 7) * PEXIT RC=(15) LTORG , * SUN EQU 0 MON EQU 1 TUE EQU 2 WED EQU 3 THU EQU 4 FRI EQU 5 SAT EQU 6 * * BASE MONTH CODE TABLE BMC DC AL1(SAT) JANUARY 1, 0000 DC AL1(TUE) FEBRUARY 1, 0000 DC AL1(TUE) MARCH 1, 0000 DC AL1(FRI) APRIL 1, 0000 DC AL1(SUN) MAY 1, 0000 DC AL1(WED) JUNE 1, 0000 DC AL1(FRI) JULY 1, 0000 DC AL1(MON) AUGUST 1, 0000 DC AL1(THU) SEPTEMBER 1, 0000 DC AL1(SAT) OCTOBER 1, 0000 DC AL1(TUE) NOVEMBER 1, 0000 DC AL1(THU) DECEMBER 1, 0000 * END PSU004 ./ ADD NAME=$$$DOC,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 Complete documentation may be found at: http://skycoast.us/pscott/software/mvs/ If you require assistance, contact pscott@skycoast.us ./ ADD NAME=GENCAL,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 PROC 0 YEAR() /* /* GENERATE CALENDAR FOR CURRENT (OR SPECIFIED) YEAR /* AUTHOR: P. SCOTT /* CONTROL NOMSG NOLIST NOFLUSH ALLOC F(SYSOUT) UNIT(SYSDA) TRACKS SPACE(1) DELETE REUSE CALL '&PREF..PSM.RUNLIB(PSU004)' '&YEAR' ISPEXEC LMINIT DATAID(SYSOUT) DDNAME(SYSOUT) ENQ(SHR) ISPEXEC EDIT DATAID(&SYSOUT) FREE F(SYSOUT) ./ ADD NAME=$PSMIVP,LEVEL=00 ./ NUMBER NEW1=10000,INCR=10000 //&JOBNAME JOB PSMIVP,'PSMIVP',CLASS=&JOBCLASS,MSGCLASS=&MSGCLASS //* //IVP PROC PREFIX=&PREF, <--- YOUR USER ID // FMT=U //* //* --------------------------------- //* STEP 1 - PSU001 (V) //* --------------------------------- //* //S1 EXEC PGM=PSU001,PARM=('&FMT,EQ,VB') //STEPLIB DD DSN=&PREFIX..PSM.RUNLIB,DISP=SHR //* //* --------------------------------- //* STEP 2 - PSU002 (V) //* --------------------------------- //* //S2 EXEC PGM=PSU002,COND=(0,NE,S1),PARM=('/', // 'PSU002 - INSTALLATION VERIFICATION PROCEDURE/', // ' VARIABLE RECORD FORMAT/', // ' ') //STEPLIB DD DSN=&PREFIX..PSM.RUNLIB,DISP=SHR //SYSOUT DD SYSOUT=H,DCB=(RECFM=VB,LRECL=255,BLKSIZE=6233) //* //* --------------------------------- //* STEP 3 - PSU001 (F) //* --------------------------------- //* //S3 EXEC PGM=PSU001,PARM=('&FMT,EQ,FB') //STEPLIB DD DSN=&PREFIX..PSM.RUNLIB,DISP=SHR //* //* --------------------------------- //* STEP 4 - PSU002 (F) //* --------------------------------- //* //S4 EXEC PGM=PSU002,COND=(0,NE,S3),PARM=('/', // 'PSU002 - INSTALLATION VERIFICATION PROCEDURE/', // ' FIXED RECORD FORMAT/', // ' ') //STEPLIB DD DSN=&PREFIX..PSM.RUNLIB,DISP=SHR //SYSOUT DD SYSOUT=H,DCB=(RECFM=FB,LRECL=80,BLKSIZE=6160) //* //IVP PEND //* //IVP1 EXEC IVP,FMT=VB //IVP2 EXEC IVP,FMT=FB // //* $$ //