PRINT NOGEN MACRO &N BEGIN &R,&R2,&RENT=N,&VER= *---------------------------------------------------------------------* * B E G I N * *---------------------------------------------------------------------* * * * Generate a CSECT statement, specify and load the base * * registers and 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 register USING &LAB,®2 Establish Addressability STM 14,12,12(13) Save callers registers * AIF ('&BASE2' EQ '1').AONE LAE ®3,2048(R15,0) Set ®3 as second base register LAE ®3,2048(®3,0) Set ®3 as second base register USING &LAB+4096,®4 * .AONE ANOP AIF ('&RENTGBL' EQ 'N').ANOTR GETMAIN R,LV=72,LOC=BELOW Storage for our save area * ST 13,4(1) Cross link save areas * ST 1,8(13) Cross link our save area in callers* XR 13,1 * * XR 1,13 * Swap R13 and R1 * XR 13,1 * * BAS 1,PRGMSAVE * Skip passed eyecatcher * * * 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' * Register save area for non-rent * .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 his save area * LM 0,1,20(1) Restore R0 and R1 to keep parms * AGO .EXIT .ANOTR2 ANOP ST 13,8(15) Cross save save areas * ST 15,4(13) Cross save save areas * .EXIT ANOP *---------------------------------------------------------------------* * ©Copyright of Abbydale Systems LLC. * *---------------------------------------------------------------------* 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 * *---------------------------------------------------------------------* * ©Copyright of Abbydale Systems LLC. * *---------------------------------------------------------------------* MEND MACRO &NAME GETPARM * ******************************************************************* * * * * G E T P A R M * * * * Put the address of the passed parameter (if one is passed) * * into R1 and the length into R15 * * * &NAME DS 0H * L 15,4(13) Previous save area address * L 14,4(15) Next previous area address * LTR 14,14 Are we at the OS area? * BZ *+10 Yes - Go and check the parm * LR 15,14 Make r15 same as r14 and go try next * B *-12 Branch back to main loop * L 14,24(15) Are we in the OS yet? * L 14,0(14) Load the address of the address * XR 1,1 Clear register 1 for parm address * XR 15,15 Clear length counter * LH 15,0(14) Put length into r15 * LTR 15,15 Do we have a parm? * BZ *+8 No - Skip putting addreaa into r1 * LA 1,2(14) Load address of parm * * * * R15 contain the length of the passed parmeter, * * If R15 is zero (no parm) then r1 will also contain zero, * * otherwise R1 contains the length of the parameter and R15 * * contains the length of the passed parameter. * * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEND * COPY ASLEQUC Register equates *---------------------------------------------------------------------* * A S L E Q U C * *---------------------------------------------------------------------* * 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 * *---------------------------------------------------------------------* * ©Copyright of Abbydale Systems LLC. * *---------------------------------------------------------------------* TITLE 'Return CC - Copyright Abbydale Systems LLC' ASLDAYCC AMODE 31 ASLDAYCC RMODE ANY IEFJSSIB IEFSSOBH SSOBGN EQU * IEFSSVI COPY ASLDATE *---------------------------------------------------------------------* * ASLDAYCC * *---------------------------------------------------------------------* * * * Description : Return day of week as condition code. * * * * The program supports two potential parameters these are: * * * * DAY1 : Specifies what day of the week is to be used as the start * * of the week. The parameter is a 3 character day name i.e * * SUN, MON, TUE, WED, THU, FRI or SAT. The default is Sun. * * The first day of the week will return 0, the next day is * * 1, then 2 etc. * * * * OFFSET : Allows you to specify a one digit number that is used as * * hour that is to be considered as the start of a new day * * hour. i.e OFFSET=3 means that 03:00 is considered that * * start of a new day. The default is Midnight (0). If the * * time of day is before the offset time, the previous day * * return code will be used. * * * * Created on : 23 Jul 2022 * * Created by : Kevin Ferguson * * : Userid(MIT001) * * : Using ABBYDALE.DEVL.SOURCE(ASLDAYCC) * * * * Called by ; * * * * Calls : ASLDATER * * * * Change Activity : * * * *---------------------------------------------------------------------* * ©Copyright of Abbydale Systems LLC. * *---------------------------------------------------------------------* ASLDAYCC BEGIN R12,VER=1.0 * DISCLAIM * COPYRITE SPACE 4 LA R1,ASLDTEL Load length of data into R1 STORAGE OBTAIN,ADDR=(9),SP=0,LENGTH=(R1),LOC=ANY LTR R15,R15 Did it work? BZ Crack_On Yes - branch to keep going WTO 'ASLDAY13E - Storage obtain failed. Abend S0C3' Crash EX R15,Crash Abend out Crack_On DS 0H USING ASLDATE,R9 Address the data DSECT ST R9,PARMPASS Save area address LINK EP=ASLDATER,PARAM=PARMPASS Go get date and time GETPARM Process any parms LR R3,R1 Save parm location LR R4,R15 Save length MVC Offset,=c'00' Set default LTR R4,R4 Any parms? BZ Skip_Parm No - Skip C R4,=F'5' Check size is long enough BNH Invalid_Parm If it isn't go and fail Parm_Loop DS 0H Switch1 NOP Try_Offset One time switch CLC =C'DAY1=',0(R3) Day1=? BNE Try_Offset No - Try offset S R4,=F'5' Decrease length by 5 LA R3,5(R3) Skip along past DAY= LA R5,7 Loop Counter LA R6,DayTable Point at start of day table LOOP_Back DS 0H CLC 0(3,R3),0(R6) Day match? BE Start_Day Yes - Set it as the start day LA R6,4(R6) No - Up to next day BCT R5,Loop_Back Go and check for a number B Invalid_Parm2 Error out Start_Day DS 0H XR R7,R7 Ready the count LA R8,OurTable Point at start of Our day table LA R2,Day_Table_End Point at end of daytable Loop_it DS 0H MVC 0(3,R8),0(R6) Move out day STH R7,Halfword Save value MVC 3(1,R8),Halfword+1 Save value LA R7,1(R7) Increase count C R7,=F'7' BNL Loop_Out LA R8,4(R8) Up to next entry LA R6,4(R6) Next CR R6,R2 end of table? BL Loop_It No - Go and check next one LA R6,DayTable Point back to first day B Loop_It ... and then loop back Loop_Out DS 0H LA R3,3(R3) Skip day OI Switch1+1,X'F0' Set Switch to skip S R4,=F'3' Subtract length Check_4_More DS 0H LTR R4,R4 End of parms? BZ Skip_Out Yes - Skip out of parms process CLI 0(r3),c',' More ? BNE Invalid_Parm LA R3,1(R3) Skip the comma BCTR R4,0 Subtract one from length LTR R4,R4 Is length zero? BZ Invalid_Parm Yes - then it is an error B Parm_loop No - Process the parms Try_Offset DS 0H Switch2 NOP Invalid_Parm CLC =C'OFFSET=',0(R3) Offset=? BNE Invalid_Parm No - Skip to fail S R4,=F'7' Decrease length by 7 LA R3,7(R3) Skip along past Offset= CLI 0(R3),c'0' Less than 0? BL Show_Error Yes - Error out CLI 0(R3),c'9' Greater than 9? BH Show_Error Yes - Error out MVC Hour_Num(1),0(R3) Move in the hour BCTR R4,0 Subtract one from length LA R3,1(R3) Skip the number OI Switch2+1,X'F0' Set Switch to skip B Check_4_More Skip_Parm DS 0H LA R6,DayTable Point at start of day table LA R8,OurTable Point at start of Our day table LA R7,7 Set loop counter XR R2,R2 Counter Default_loop DS 0H MVC 0(3,R8),0(R6) Move day STH R2,Halfword Save value MVC 3(1,R8),Halfword+1 Move day number in LA R2,1(R2) Increment counter LA R8,4(R8) Up to next entry LA R6,4(R6) Up to next entry BCT R7,Default_Loop Skip_Out DS 0H CLC OurTable(3),=x'000000' Table built? BE Skip_Parm No - Go and build the table LA R2,OurTable LA R3,7 Maximum Number of loops Try_Day DS 0H CLC 0(3,R2),ASLDNAME Day match? BE Try_Hour Yes - Try hour LA R2,4(R2) No - Skip to next day BCT R3,Try_Day ... and loop back WTO 'ASLDAY04E - Logic Error. Contact support' B Crash Go to abend Try_Hour DS 0H CLC ASLTHOUR,OFFSET Offset match? BNL Set_CC ICM R7,B'0001',3(R2) Load our Cond Code LTR R7,R7 Cond code 0? BNZ Subtract_it No - Go ahead and subtract 1 LA R7,7 Switch back Subtract_it DS 0H BCTR R7,0 Set for yesterday B Save_it Set_Cc DS 0H ICM R7,B'0001',3(R2) Load our Cond Code Save_it DS 0H LA R1,ASLDTEL STORAGE RELEASE,LENGTH=(R1),ADDR=(R9) LR R15,R7 Move condition code to r15 EOJ c=(R15) Get out Invalid_Parm DS 0H WTO 'ASLDAY01E - Invalid parameter passed. Abend S0C3' B Crash Invalid_Parm2 DS 0H WTO 'ASLDAY02E - Invalid day passed. Abend S0C3' B Crash Show_Error DS 0H WTO 'ASLDAY03E - Invalid numeric' B Crash Go to abend Offset DS 0CL2 Hour offset area DC CL1'0' Force in 0 Hour_Num DS CL1 CondCode DS F Condition code DayTable DS 0H DC C'SUN',X'00' DC C'MON',X'01' DC C'TUE',X'02' DC C'WED',X'03' DC C'THU',X'04' DC C'FRI',X'05' DC C'SAT',X'06' Day_Table_End DS 0H OurTable DS CL28 Halfword DS H DC C'====>' DS 0D PARMPASS DS F DC XL4'00000000' LTORG *----------------------------------------