PRINT NOGEN ASLPARMC START 0 ASLPARMC AMODE 24 ASLPARMC RMODE 24 MACRO &N BEGIN &R,&R2,&RENT=N,&VER= * ******************************************************************* * * * * B E G I N * * * * GENERATE A CSECT STATEMENT, SPECIFY AND LOAD THE BASE * * REGISTERS, GENERATE STANDARD LINKAGE WITH SAVE AREA. * * * LCLC ®,&LAB,®2,®3,®4,&BASE2,&VERSION GBLC &RENTGBL AIF (K'&VER GT 8).VERERR AIF (K'&VER NE 0).VEROK &VERSION SETC '1.0' AGO .VERCNT .VEROK ANOP &VERSION SETC '&VER' .VERCNT ANOP AIF (K'&N NE 0).LABOK &LAB SETC 'NONAME' MNOTE 4,'***** NO CSECT NAME SPECIFIED, NONAME USED *********' AGO .LABCNT .LABOK ANOP &LAB SETC '&N' .LABCNT ANOP AIF (K'&R NE 0).REGOK ® SETC '12' MNOTE 4,'***** NO BASE REGISTER SPECIFIED, 12 USED **********' AGO .REGCNT .REGOK ANOP AIF ('&R'(1,1) NE 'R').NUMB ® SETC '&R'(2,2) AGO .COMP .NUMB ANOP ® SETC '&R' .COMP ANOP AIF ('®' LT '2').E1 AIF ('®' GT '12').E1 ® SETC '&R' .REGCNT ANOP ®2 SETC '® USE ® AS BASE REGISTER' &BASE2 SETC '1' AIF (K'&R2 EQ 0).BASE1 &BASE2 SETC '2' AIF ('&R2'(1,1) NE 'R').NUMB2 ®3 SETC '&R2'(2,2) AGO .COMP2 .NUMB2 ANOP ®3 SETC '&R2' .COMP2 ANOP AIF ('®3' LT '2').E12 AIF ('®3' GT '12').E12 ®3 SETC '&R2' AIF ('®3' EQ '®').E12 ®4 SETC '®3 USE ®3 AS 2ND BASE REGISTER' MNOTE '***** THIS PROGRAM WILL HAVE 2 BASE REGISTERS ******' .BASE1 ANOP &RENTGBL SETC 'N' AIF ('&RENT'(1,1) NE 'Y').NOTRENT &RENTGBL SETC 'Y' .NOTRENT ANOP &LAB CSECT * BAKR R14,R0 LINKAGE STACK LAE ®,0(R15,0) SET ® AS BASE USING &LAB,®2 ADDRESS IT STM 14,12,12(13) SAVE REGISTERS IN CALLERS AREA * * LR ®,15 * * * USING &LAB,®2 * AIF ('&BASE2' EQ '1').AONE LAE ®3,2048(R15,0) SET ®3 AS SECOND BASE LAE ®3,2048(®3,0) SET ®3 AS SECOND BASE USING &LAB+4096,®4 * * LA ®3,2048(®) * * LA ®3,2048(®3) * .AONE ANOP AIF ('&RENTGBL' EQ 'N').ANOTR GETMAIN R,LV=72,LOC=BELOW STORAGE FOR SAVE AREA * ST 13,4(1) PUT ADDRESS OF HIS SAVE AREA IN YOURS * ST 1,8(13) PUT ADDRESS OF YOUR SAVE AREA IN HIS * XR 13,1 * * XR 1,13 *EXCHANGE REGISTERS 1 AND R13 * XR 13,1 * * BAS 1,PRGMSAVE BRANCH PASSED ASSEMBLY INFORMATION * * * MNOTE '====> RE-ENTRANT VERSION OF EOJ WILL BE USED <==== *' * * AGO .INFO .ANOTR ANOP LR 15,13 * BAS 13,PRGMSAVE+END_EYECATCHER * PRGMSAVE DC 18F'0' * .INFO ANOP * * * ASSEMBLY INFORMATION - DATE, TIME AND CSECT NAME FOLLOW * * * ASLCSECT DC CL8'&LAB' ********* CSECT NAME *********** * ASLMODV DC CL8'&VERSION' **** VERSION INFORMATION **** * * * DC CL24'WRITTEN BY K E FERGUSON ' * DC CL36'COPYRIGHT - ABBYDALE SYSTEMS LLC. ' * * * ASLASMD DC CL8'&SYSDATE' **** ASSEMBLY DATE (MM/DD/YY) **** * ASLASMT DC CL6' &SYSTIME' **** ASSEMBLY TIME (HH.MM) **** * * * END_EYECATCHER EQU *-PRGMSAVE * * * AIF ('&RENTGBL' EQ 'N').ANOTR2 PRGMSAVE L 1,4(13) RELOAD ADDRESS OF HIS SAVE AREA * LM 0,1,20(1) RESET REGISTERS 0 AND 1 * AGO .EXIT .ANOTR2 ANOP ST 13,8(15) * ST 15,4(13) * .EXIT ANOP * K.F. * * ******************************************************************* * SPACE 1 MEXIT .E12 MNOTE 8,' -- VALUE FOR SECOND BASE REGISTER INVALID -- ' .E1 MNOTE 8,'IMPROPER REGISTER SPECIFIED, NO STATEMENTS GENERATED' .VERERR MNOTE 8,'LENGTH ERROR FOR THE VER PARAMETER > 8' MEND MACRO &N EOJ &C=0 LCLC &A,&B GBLC &RENTGBL * ******************************************************************* * * * * E O J * * * * GENERATE STANDARD RETURN LINKAGE AND RETURN CODE. * * * AIF ('&N' EQ '').GO &N DS 0H .GO AIF ('&C'(1,1) EQ '(').REGCODE LA 15,&C PUT CONDITION CODE INTO REG 15 * AGO .RESTORE .REGCODE ANOP AIF ('&C'(3,1) EQ ')').MOVE1 AIF ('&C'(4,1) EQ ')').MOVE2 AIF ('&C'(5,1) EQ ')').MOVE3 .MERROR ANOP MNOTE 16,'*** INVALID REGISTER PASSED AS RETURN CODE REGISTER' MEXIT .MOVE3 ANOP &A SETC '&C'(2,3) AGO .CONT .MOVE2 ANOP &A SETC '&C'(2,2) AGO .CONT .MOVE1 ANOP &A SETC '&C'(2,1) .CONT ANOP AIF ('&A'(1,1) EQ 'R').RVALUE AIF ('&A' GT '15').MERROR AGO .LOADIT .RVALUE ANOP &B SETC '&A'(2,2) AIF ('&B' GT '15').MERROR .LOADIT ANOP LR 15,&A LOAD REGISTER 15 WITH CODE * .RESTORE ANOP AIF ('&RENTGBL' EQ 'Y').YESRENT PR AGO .EXIT .YESRENT ANOP LR 2,15 LR 1,13 PUT ADDRESS OF GOTTEN INTO REG 1 * L 13,4(1) PUT HIS SAVE AREA ADDRESS IN REG 13* FREEMAIN R,LV=72,A=(1) FREE STORAGE * LR 15,2 PR .EXIT ANOP * * K.F. * * ******************************************************************* * MEND ASLPARMC TITLE ' - LOAD A DATASET FROM PARM - ABBYDALE SYSTEMS LLC.' ASLPARMC BEGIN R12,VER=3.0 *********************************************************************** *** WELCOME TO ASLPARMC *** *********************************************************************** *** *** *** DESCRIPTION : *** *** *** *** CREATED : 14/02/2018 By MIT001 *** *** : USING ABBYDALE.ASLPARMC.SOURCE(ASLPARMC) *** *** *** *** CHANGE ACTIVITY : *** *** *** *********************************************************************** *** Copyright Abbydale Systems LLC. *** *********************************************************************** XC FLAG,FLAG Set flags off L R2,0(R1) R2 = PARMS ST R2,SAVER2 Save it XR R8,R8 Clear R8 ready for length LH R8,0(R2) R8 = Length of passed parm LTR R8,R8 Was there a parm passed? BZ PARMERR No - Go and issue an error message L 1,16 Obtain CVT address L 1,0(0,1) Get TCB Address L 1,4(0,1) ..and get our TCB L 1,12(0,1) Point to our TIOT MVC JOBNAME,0(R1) Get JOBNAME LA R3,2(R2) R3 = Address of parms BAS R9,REPLACE_JOBNAME Go replace jobnames L R2,SAVER2 Restore R2 LA R3,2(R2) Reload r3 BCTR R8,0 Adjust readyy for execute DEVTYPE =CL8'FOLD ',CVBAREA Check for FOLD DD card LTR R15,R15 Do we have one? BNZ NO_FOLD NO - Skip setting the flag OI FLAG,FOLD_Flag Set the flag NO_FOLD DS 0H DEVTYPE =CL8'CAPS ',CVBAREA Check for FOLD DD card LTR R15,R15 Do we have one? BNZ TRY_CONT NO - Skip setting the flag OI FLAG,FOLD_Flag Set the flag TRY_CONT DS 0H DEVTYPE =CL8'NOCONT ',CVBAREA Check for NOCONT DD card LTR R15,R15 Do we have one? BNZ NO_CONT NO - Skip setting the flag OI FLAG,Cont_Flag Set the flag NO_CONT DS 0H DEVTYPE =CL8'OUTPUT ',CVBAREA Check for OUTPUT DD card LTR R15,R15 Do we have one? BNZ NO_OUTPUT NO - Go and issue error message FOUND_IT DS 0H RDJFCB (OUTPUT,(OUTPUT)) Read the JFCB LA R7,JFCBAREA Get address of the JFCB ... USING INFMJFCB,R7 ... and establish addressability XR R6,R6 Clear R6 ... LH R6,JFCLRECL .. and load it with record length CH R6,=H'80' Is it greater than 80 bytes? BH Crunch Yes - go and crash out STORAGE OBTAIN,ADDR=(R1),SP=0,LENGTH=(6),LOC=(RES,ANY) LTR R15,R15 Storage obtain successful? BNZ SPACE_OUT N0 - Go and crash out LR R4,R1 Save address in R4 MVI 0(R4),C' ' Clear out area to spaces MVC 1(79,R4),0(R4) * EX R8,MOVE_IT Move parm to output TM FLAG,Fold_Flag Fold card? BNO Skip_Fold No - Skip past fold EX R8,FOLD_IT Fold to uppercase Skip_Fold DS 0H TM FLAG,Cont_Flag Process last comma as continue? BO Open_File No - Just go and write it out LA R10,0(R8,R4) Point at last character passed? CLI 0(R10),c',' Is last character a comma? BNE Open_File No - Skip adding continuation CH R8,=h'72' Is there enought room? BNH Check_for_Blank Yes - go check for blank WTO 'ASLPRM6W - LRECL less than 72. No substitution possiblec ' B Open_File Skip substitution Check_for_Blank DS 0H CLI 71(R4),C' ' Is column 72 blank? BE Sub_col72 WTO 'ASLPRM5W - Data found in column 72. No Substitution madc e' B Open_File Skip substitution Sub_col72 DS 0H MVI 71(R4),C'C' Add continuation Character *CHANGE* Open_File DS 0H OPEN (OUT,(OUTPUT)) Now open the output file LTR R15,R15 Did it work? BNZ OPEN_FAILED No - go to crash out PUT OUT,0(R4) Write it out CLOSE (OUTPUT) Close the file STORAGE RELEASE,ADDR=(R4),LENGTH=(6),SP=0 release storage EOJ C=0 and leave cond code 0 * *********************************************************************** *** REPLACE_JOBNAME Subroutine *** ***-----------------------------------------------------------------*** *** Use: Replaces all @JOBNAME variables to the jobname of *** *** the job running the program *** *** Exit: Exit via R9 *** *********************************************************************** REPLACE_JOBNAME DS 0H LR R5,R8 Load length into r5 LR R2,R8 ... and R2 Test_again equ * XR R1,R1 Clear R1 ready for TRT EX R2,SCAN_FOR_AT Scan for @ BZ NO_AT If zero - skip MVC STORE_JOB,0(R1) Save our found @ OC STORE_JOB,=X'4040404040404040' Fold to Upper case CLC STORE_JOB+1(7),=C'JOBNAME' Now check for @JOBNAME BNE Skip_First_at if not it skip MVC 0(8,R1),JOBNAME SR R1,R3 LA R3,0(R1,R3) Skip if required LR R2,R5 LR R4,R3 SR R2,R1 Take it off the length B Test_again NO_AT DS 0H BR R9 Skip_First_at DS 0H SR R1,R3 LA R3,0(R1,R3) Skip if required LR R2,R5 LR R4,R3 SR R2,R1 Take it off the length bctr r2,0 LR R5,R2 Take it off the length la r3,1(r3) B Test_Again *********************************************************************** ** Error exit points follow ** *********************************************************************** PARMERR DS 0H WTO 'ASLPRM1E - Invalid PARMS input' B CRUNCH OPEN_FAILED DS 0H WTO 'ASLPRM2E - Open for OUTPUT DD Card failed' B CRUNCH NO_OUTPUT DS 0H WTO 'ASLPRM3E - No OUTPUT DD Card. Abend S0C3' B CRUNCH SPACE_OUT DS 0H WTO 'ASLPRM4E - Get for working storage failed. Abend S0C3' CRUNCH EX R15,CRUNCH *********************************************************************** ** Executed instructions follow ** *********************************************************************** MOVE_IT MVC 0(*-*,R4),0(R3) FOLD_IT TR 0(*-*,R4),TRTABLE Fold to uppercase SCAN_FOR_AT TRT 0(*-*,R3),TRTABLE2 Scan for @Jobname *********************************************************************** JOBNAME DS CL8 Our Jobname STORE_JOB DS CL8 SAVER2 DS F Save area for R2 TRTABLE DS 0CL256 * 0 1 2 3 4 5 6 7 8 9 A B C D E F DC X'40000000000000000000000000000000' 00-0F DC X'00000000000000000000000000000000' 10-1F DC X'00000000000000000000000000000000' 20-2F DC X'00000000000000000000000000000000' 30-3F DC X'40000000000000000000004B4C000000' 40-4F DC X'0000000000000000000000005C000000' 50-5F DC X'00000000000000000000006B00000000' 60-6F DC X'00000000000000000000000000007E00' 70-7F DC X'00C1C2C3C4C5C6C7C8C9000000000000' 80-8F DC X'00D1D2D3D4D5D6D7D8D9000000000000' 90-9F DC X'0000E2E3E4E5E6E7E8E9000000000000' A0-AF DC X'00000000000000000000000000000000' B0-BF DC X'00C1C2C3C4C5C6C7C8C9000000000000' C0-CF DC X'00D1D2D3D4D5D6D7D8D9000000000000' D0-DF DC X'00E1E2E3E4E5E6E7E8E9000000000000' E0-EF DC X'F0F1F2F3F4F5F6F7F8F9000000000000' F0-FF TRTABLE2 DC 256XL1'00' ORG TRTABLE2+C'@' DC CL1'@' FLAG DS CL1 These are our flags FOLD_Flag EQU B'00000001' Used to indicate a FOLD DD card Cont_Flag EQU B'00000010' Used to indicate a NOCONT DD Card Report_Flag EQU B'00000100' Used to indicate a REPORT DD Card OUT DCB DDNAME=OUTPUT,DSORG=PS,MACRF=(PM),LRECL=80 CVBAREA DS D OUTPUT DCB DDNAME=OUTPUT,MACRF=(PM),DSORG=PS,EXLST=LSTA LSTA DS 0F DC X'87',AL3(JFCBAREA) JFCBAREA ds 0D,176C *********************************************************************** * REGISTER EQUATES * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * R0 EQU 0 * R1 EQU 1 * R2 EQU 2 * R3 EQU 3 * R4 EQU 4 * R5 EQU 5 * R6 EQU 6 * R7 EQU 7 * R8 EQU 8 A S L E Q U C * R9 EQU 9 * R10 EQU 10 EQUATE PREFIX TO NUMERIC SYMBOLS IN ORDER * R11 EQU 11 TO MAKE THE USE OF REGISTER OPERANDS IN * R12 EQU 12 INSTRUCTIONS SELF EXPLANITORY.THIS ALSO * R13 EQU 13 CREATES ENTRIES IN CROSS REFERENCE. * R14 EQU 14 * R15 EQU 15 * FPR0 EQU 0 * FPR2 EQU 2 * FPR4 EQU 4 * FPR6 EQU 6 * *********************************************************************** LTORG JFCB DSECT IEFJFCBN , JFCB MAPPING DSECT END ASLPARMC PUNCH ' MODE AMODE(24)' BINDER AMODE STATEMENT. PUNCH ' MODE RMODE(24)' BINDER RMODE STATEMENT. PUNCH ' ENTRY ASLPARMC' BINDER MODULE ENTRY POINT. PUNCH ' ALIAS BSLPARMC' BINDER MODULE ENTRY POINT. PUNCH ' NAME ASLPARMC(R)' BINDER MODULE NAME. END