./ ADD NAME=$$$INDEX *---------------------------------------------------------------------* * Directory list of ABBYDALE.ALLFREE.MACLIB * *---------------------------------------------------------------------* | Member | Description | *---------------------------------------------------------------------* | $$$INDEX | This member. | *---------------------------------------------------------------------* | ASLFILL | Fill a field with a passed character. | *---------------------------------------------------------------------* | CRASH | Fail a program with a SOC3 abend. | *---------------------------------------------------------------------* | GETMODE | Returns a value into a passed area that denotes the | | | addressing mode of the executing program. | *---------------------------------------------------------------------* | GETPARM | Puts the address of a passed parm into R1 and the length | | | into R15. Both registers will be 0 if no parm was passed.| *---------------------------------------------------------------------* | GETUSER | Save the userid of the user running the program into | | | a storage area. | *---------------------------------------------------------------------* | HEXPRINT | Make the contents of a register printable. | *---------------------------------------------------------------------* | JOBNAME | Save the current jobname into a storage area. | *---------------------------------------------------------------------* | PRINTHEX | Make the contents of a register printable. | *---------------------------------------------------------------------* | POS | Returns the position of a character in a string. The | | | position of the character is returned in register 15. | *---------------------------------------------------------------------* | RANDOM | Generate a random number between 2 specified numbers. | *---------------------------------------------------------------------* | SWAPREG | Swap the contents of two registers. | *---------------------------------------------------------------------* | UPPER | Folds a string to uppercase. | *---------------------------------------------------------------------* | USERCVT | Sample mapping macro for a user CVT. | *---------------------------------------------------------------------* | WTP | write a message to the programmer. | *---------------------------------------------------------------------* | ©Copyright of Abbydale Systems LLC. | *---------------------------------------------------------------------* ./ ADD NAME=ASLFILL MACRO &NAME ASLFILL &FIELD,&X * ********************************************************************* * A S L F I L L * * * * Fill a passed area with the string passed as a second * * parameter. If a second parm is omitted space x'40' is * * used as the fill character. * * * * NOTE: The passed fill character must be the hex value * * i.e. to fill a field with binary zeros pass 00 to * * the macro like this: ASLFILL AREANAME,00 * * * * ********************************************************************* LCLC &CHAR,®,&LEN,&LEN2 AIF (K'&FIELD NE 0).OK MNOTE 12,'***** No field specified *****' AGO .EXIT .OK ANOP AIF (K'&X NE 0).SETOK MNOTE 0,'***** No pad character specified. Space assumed' &CHAR SETC '40' AGO .CONT .SETOK ANOP &CHAR SETC '&X' .CONT ANOP AIF (K'&Name EQ 0).SKIPNAME &NAME EQU * .SKIPNAME ANOP AIF ('&FIELD'(1,1) NE '(').DOFIELD &LEN SETC '&Field(2)' ® SETC '&FIELD(1)' LR 0,® Point to passed area AIF ('&LEN'(1,1) NE '(').NOTREG &LEN2 SETC '&LEN'(2,3) AIF ('&LEN'(4,1) NE ')').SKIPSET &LEN2 SETC '&LEN'(2,2) .SKIPSET ANOP LR 1,&LEN2 Load length of area into R1 AGO .REJOIN .NOTREG ANOP LA 1,&LEN Load length of area into R1 AGO .REJOIN .DOFIELD ANOP LA 0,&FIELD Point to passed area LA 1,L'&FIELD Load length of area into R1 .REJOIN ANOP XR 14,14 Clear register 14 LA 15,X'&CHAR' Set pad character... SLL 15,24 ... and shift to high order MVCL 0,14 Now intialise the area .EXIT ANOP MEXIT * * * Copyright - Abbydale Systems LLC. * * ********************************************************************* MEND ./ ADD NAME=CRASH MACRO &N CRASH * ******************************************************************* * * * * C R A S H * * * * Fail the program with a SOC3 abend which leaves the * * register contents unchanged * * * GBLA &K AIF ('&K' GT '1').GO2 &K SETA 1 .GO2 AIF (K'&K EQ 0).BOOM &N DS 0H .BOOM ANOP ASLCR&K EX R15,ASLCR&K Crash out with SOC3 &K SETA &K+1 MEXIT * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEND ./ ADD NAME=GETMODE MACRO &NAME GETMODE &A *---------------------------------------------------------------------* * G E T M O D E * *---------------------------------------------------------------------* * * * Description : Store a value indicating the addressing mode of the * * executing program. 2 for 24, 3 for 31 or 6 for 64 bit* * * * Created on : 19 Oct 2022 * * Created by : Kevin Ferguson * * : Userid(MIT001) * * * * Used by : ASLPRINT * * * * Change Activity : * * * *---------------------------------------------------------------------* * ©Copyright of Abbydale Systems LLC. * *---------------------------------------------------------------------* LCLC &LAB &KK SETC '' AIF (K'&A NE 0).LABOK &LAB SETC 'ASLADDRM' MNOTE 0,'***** No area name specified, ASLADDRM used *****' AGO .LABCNT .LABOK ANOP AIF ('&A'(1,1) NE '(').SKIP &END SETA K'&A AIF ('&A'(&END,1) NE ')').SKIPME &KK SETC '&A' &LAB SETC '&A'(2,K'&A-2) MNOTE 0,'**** Using &LAB as storage area ****' AGO .LABCNT .SKIP ANOP &LAB SETC '&A' .LABCNT ANOP &NAME DS 0H * MVI &LAB,C'3' Set for 31 bit * TAM , * JZ ASLM24 24 bit * JO ASLM64 64 bit * B $MDEEXIT ... exit as it is 31 bit * ASLM24 DS 0H * MVI &LAB,C'2' Set for 24 bit ... B $MDEEXIT ... exit * ASLM64 DS 0H * MVI &LAB,C'6' Set for 64 bit ... AIF ('&LAB' EQ 'ASLADDRM').SKIPA AIF ('&A'(1,1) EQ '(').SKIPA B $MDEEXIT ... exit * &LAB DS CL1 * .SKIPA ANOP $MDEEXIT DS 0H * MEXIT * * *---------------------------------------------------------------------* .SKIPME ANOP MNOTE 8,'**** Invalid area specification ****' MEXIT MEND *---------------------------------------------------------------------* * E N D O F G E T M O D E * * K.E.F * *---------------------------------------------------------------------* ./ ADD NAME=GETPARM 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 contains the length of the passed parmeter, * * If R15 is zero (no parm) then r1 will also contain zero, * * otherwise R1 contains the address of the parameter and R15 * * contains the length of the passed parameter. * * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEND ./ ADD NAME=GETUSER MACRO &NAME GETUSER &A LCLC &LAB AIF (K'&A NE 0).LABOK &LAB SETC 'ASLUSERI' MNOTE 0,'***** NO AREA NAME SPECIFIED, ASLUSERI USED ********' AGO .LABCNT .LABOK ANOP &LAB SETC '&A' .LABCNT ANOP * ******************************************************************* * * * * G E T U S E R * * * * Get the userid of the user executing the program into a * * storage area. * * * &NAME L 1,548 PSAAOLD * L 1,108(1) ASCB * L 1,200(1) ASXB * MVC &LAB,21(1) MOVE IN USERID * B $USREXIT AND EXIT * AIF ('&LAB' NE 'ASLUSERI').SKIPA &LAB DS CL8 * .SKIPA ANOP $USREXIT DS 0H * * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEND ./ ADD NAME=HEXPRINT MACRO &N HEXPRINT &R1,&R2 LCLC ®1,®2 GBLB &HEXPRNT GBLC &RENTGBL GBLA &X * ******************************************************************* * * * * H E X P R I N T * * * * Convert Field from hex to printable hex equivalent * * * AIF ('&N' EQ '').GO &N DS 0H .GO ANOP AIF ('&X' GT '1').GO2 &X SETA 1 .GO2 AIF (K'&R1 NE 0).REG1OK MNOTE 8,'***** No registers specified ***********************' AGO .END .REG1OK ANOP AIF ('&R1'(1,1) NE 'R').NUMB ®1 SETC '&R1'(2,2) AGO .COMP .NUMB ANOP ®1 SETC '&R1' .COMP ANOP AIF ('®1' GT '15').E1 ®1 SETC '&R1' AIF (K'&R2 NE 0).REG2OK MNOTE 8,'***** No second register specified *****************' AGO .END .REG2OK ANOP AIF ('&R2'(1,1) NE 'R').NUMB2 ®2 SETC '&R2'(2,2) AGO .COMP2 .NUMB2 ANOP ®2 SETC '&R2' .COMP2 ANOP AIF ('®2' GT '15').E1 ®2 SETC '&R2' AIF ('®1' EQ '®2').E2 .CONT ANOP AIF (&HEXPRNT).SKIPPY B ASLBR&X Skip workarea * * H E X P R I N T W O R K A R E A * ASLSAV1 DS F Save area for register with number * ASLSAV2 DS CL9 Temporary area for convert * DS 0H * &HEXPRNT SETB 1 Set flag for one time defines * * .SKIPPY ANOP ASLBR&X ST ®1,ASLSAV1 Save number * LA ®1,ASLSAV1 Get address of where it is * UNPK ASLSAV2+0(9),0(5,®1) Convert to printable * NC ASLSAV2+0(8),=8X'0F' * TR ASLSAV2+0(8),=CL16'0123456789ABCDEF' * MVC 0(8,®2),ASLSAV2 Put answer into passed field * L ®1,ASLSAV1 Restore register * &X SETA &X+1 * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEXIT .E2 MNOTE 8,'Duplicate register specification' AGO .END .E1 MNOTE 8,'Improper register specified, No statements generated' .END ANOP MEND ./ ADD NAME=JOBNAME MACRO &NAME JOBNAME &A *---------------------------------------------------------------------* * J O B N A M E * *---------------------------------------------------------------------* * * * Description : Place the current jobname into the passed storage * * area. If no area is passed ASLJOBNM is used. * * * * Created on : 15 April 1999 * * Created by : Kevin Ferguson * * : Userid(MIT001) * * * * Used by : Many programs. * * * * Change Activity : * * * * Change By Date Reason * * -------------------------------------------------------------- * * VAR01 KF 10/19/2022 Added logic to support indirect * * storage using brackets( ) * * * *---------------------------------------------------------------------* * ©Copyright of Abbydale Systems LLC. * *---------------------------------------------------------------------* LCLC &LAB &KK SETC '' VAR01 AIF (K'&A NE 0).LABOK &LAB SETC 'ASLJOBNM' MNOTE 0,'**** No area name specified, ASLJOBNM used ****' AGO .LABCNT .LABOK ANOP AIF ('&A'(1,1) NE '(').SKIP VAR01 &END SETA K'&A VAR01 AIF ('&A'(&END,1) NE ')').SKIPME VAR01 &KK SETC '&A' VAR01 &LAB SETC '&A'(2,K'&A-2) VAR01 MNOTE 0,'**** Using &LAB as storage area ****' VAR01 AGO .LABCNT VAR01 .SKIP ANOP &LAB SETC '&A' .LABCNT ANOP &NAME DS 0H VAR01* L 1,16 CVT ADDRESS VAR01* L 1,0(0,1) TCB WORDS ADDRESS * L 1,4(0,1) OUR TCB ADDRESS * L 1,12(0,1) TIOT ADDRESS * MVC &LAB,0(1) MOVE IN JOBNAME * B $JOBEXIT AND EXIT * AIF ('&LAB' EQ 'ASLJOBNM').SKIPA AIF ('&A'(1,1) EQ '(').SKIPA VAR01 &LAB DS CL8 * .SKIPA ANOP $JOBEXIT DS 0H * MEXIT * * *---------------------------------------------------------------------* .SKIPME ANOP MNOTE 8,'**** Invalid area specification ****' VAR01 MEXIT MEND *---------------------------------------------------------------------* * E N D O F J O B N A M E * * K.E.F * *---------------------------------------------------------------------* ./ ADD NAME=POS MACRO &NAME POS &FIELD,&X * ********************************************************************* * P O S * * * * This macro will return the position of a passed character * * within a string. By default this will a x'40' * * * * By using space as the 'end' character you can determine * * the length of a word in a string. * * * * The length of the string is returned in register 15 * * * * ********************************************************************* LCLC &CHAR GBLB &LENGTH GBLA &LN AIF (K'&FIELD NE 0).OK MNOTE 12,'***** No field specified *****' AGO .EXIT .OK ANOP AIF ('LN' GT '1').GO2 &LN SETA 1 .GO2 ANOP AIF (K'&X NE 0).SETOK MNOTE 0,'***** No end character specified. Space assumed' &CHAR SETC '40' AGO .CONT .SETOK ANOP &CHAR SETC '&X' .CONT ANOP AIF (K'&CHAR LT 3).SETOK2 MNOTE 12,'***** Length error on passed character ******' AGO .EXIT .SETOK2 ANOP AIF (&LENGTH).SKIPPY B ASLLX&LN Skip workarea * * P O S W O R K A R E A LNREG2 DS F DS 0H &LENGTH SETB 1 Set flag for one time defines * .SKIPPY ANOP ASLLX&LN DS 0H AIF (K'&Name EQ 0).SKIPNAME &NAME DS 0H .SKIPNAME ANOP ST R2,LNREG2 Save register 2 XR 15,15 Clear counter LA 2,&FIELD Point to passed area LA 1,L'&FIELD Load length of area into R1 ASLLN&LN DS 0H AIF (K'&CHAR EQ 1).SKIPCLI CLI 0(2),X'&CHAR' Match for string yet? AGO .BRANCH .SKIPCLI ANOP CLI 0(2),C'&CHAR' Match for string yet? .BRANCH ANOP BE END&LN Yes - Go to exit LA 15,1(15) Increase counter LA 2,1(2) Next character BCT 1,ASLLN&LN Loop back LA 15,L'&FIELD Set length to full field END&LN DS 0H LA 15,1(15) Increase counter L R2,LNREG2 Reload register 2 .EXIT ANOP &LN SETA &LN+1 MEXIT * * * Copyright - Abbydale Systems LLC. * * ********************************************************************* MEND ./ ADD NAME=PRINTHEX MACRO &N PRINTHEX &R1,&OUTAREA * ******************************************************************* * * * * P R I N T H E X * * * * Make the contents of a register printable and place * * the result into the passed area. * * * * Registers R0-R3 are saved and restored. * * * LCLC ®1 GBLA &H GBLB &PRNTHEX AIF ('&N' EQ '').GO &N DS 0H .GO ANOP AIF ('&H' GT '1').GO2 &H SETA 1 .GO2 AIF (K'&R1 NE 0).REG1OK MNOTE 8,'***** No register specified ************************' AGO .END .REG1OK ANOP AIF ('&R1'(1,1) NE 'R').NUMB ®1 SETC '&R1'(2,2) AGO .CONT .NUMB ANOP ®1 SETC '&R1' AIF (K'&OUTAREA EQ 0).E2 .CONT ANOP AIF ('®1' GT '15').E1 AIF (&PRNTHEX).SKIPPY B ASLPX&H * P R I N T H E X W O R K A R E A * ASLPRX1 DS 4F &PRNTHEX SETB 1 .SKIPPY ANOP ASLPX&H DS 0H STM 0,3,ASLPRX1 Save the registers LA 0,8 Set loop counter LA 1,&OUTAREA Get target arear LR 3,®1 Load source register LA 2,X'0F' Prime R2 with 0F SLDL 2,4 Shift first nibble from R3 CH 2,=x'00FA' Is it F0 to F9? BL *+8 ... No, skip the subtract SH 2,=x'0039' Subtract 39 to get hex letter STC 2,0(1) Store it in R1 LA 1,1(1) Skip up outout field BCT 0,*-28 LM 0,3,ASLPRX1 Restore the registers &H SETA &H+1 MEXIT .E1 MNOTE 8,'Improper register specified. No statements generated' AGO .END .E2 MNOTE 8,'**** Output area not specified *********************' .END ANOP * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEND ./ ADD NAME=RANDOM MACRO &N RANDOM &R1,&R2 * ******************************************************************* * * * * R A N D O M * * * * Returns a random number between the 2 specified numbers * * * * The generated random number is returned in R0 as a binary * * number. * * * LCLC &LAB LCLA &R3 AIF (K'&N EQ 0).LABEND &LAB SETC '&N' &LAB EQU * * .LABEND ANOP AIF (K'&R1 NE 0).NUM1OK MNOTE 8,'***** No numbers specified ***********************' AGO .END .NUM1OK ANOP AIF (K'&R2 NE 0).NUM2OK MNOTE 8,'***** No second number specified *****************' AGO .END .NUM2OK ANOP AIF ('&R1' NE '&R2').NUM2OK2 MNOTE 8,'***** Same number specified for both *************' AGO .END .NUM2OK2 ANOP AIF ('&R1' LT '&R2').NUM2OK3 MNOTE 8,'***** First number is the greated of the 2 *******' AGO .END .NUM2OK3 ANOP &R3 SETA &R2-&R1 TIME BIN LR 1,0 e SLL 1,20 SRL 1,20 SLL 0,24 SRL 0,24 AR 0,1 SRL 1,8 AR 0,1 BCT 1,*-2 LA 1,&R2 CR 0,1 BNH *+10 SR 0,1 B *-8 LA 1,&R1 CR 0,1 BNL *+14 LA 1,&R3 AR 0,1 B *-16 * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * .END ANOP MEXIT MEND ./ ADD NAME=SWAPREG MACRO &N SWAPREG &R1,&R2 * ******************************************************************* * * * * S W A P R E G * * * * Swaps the contents of two registers. * * * LCLC ®1,®2,®3,&LAB AIF (K'&N EQ 0).LABEND &LAB SETC '&N' &LAB DS 0H .LABEND ANOP AIF (K'&R1 NE 0).REG1OK MNOTE 8,'***** No registers specified ***********************' AGO .END .REG1OK ANOP AIF ('&R1'(1,1) NE 'R').NUMB ®1 SETC '&R1'(2,2) AGO .COMP .NUMB ANOP ®1 SETC '&R1' .COMP ANOP AIF ('®1' GT '15').E1 ®1 SETC '&R1' AIF (K'&R2 NE 0).REG2OK MNOTE 8,'***** No second register specified *****************' AGO .END .REG2OK ANOP AIF ('&R2'(1,1) NE 'R').NUMB2 ®2 SETC '&R2'(2,2) AGO .COMP2 .NUMB2 ANOP ®2 SETC '&R2' .COMP2 ANOP AIF ('®2' GT '15').E1 ®2 SETC '&R2' AIF ('®1' EQ '®2').E2 .CONT ANOP ®3 SETC '®1 * Exchange registers ®1 and ®2' CR ®1,®2 * See if registers are the smae * BE *+10 * Skip if they are * XR ®1,®2 * * XR ®2,®3 * Swap them * XR ®1,®2 * * * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEXIT .E2 MNOTE 8,'Duplicate register specification' AGO .END .E1 MNOTE 8,'Improper register specified, No statements generated' .END ANOP MEND ./ ADD NAME=UPPER MACRO &N UPPER &AREA * ******************************************************************* * * * * U P P E R * * * * Fold the passed area to uppercase. * * * AIF (K'&AREA EQ 0).E12 &N OC &Area,=256C' ' Fold to uppercase MEXIT .E12 MNOTE 8,'***** No Area passed *****************************' * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEND ./ ADD NAME=USERCVT *********************************************************************** * * * This DSECT defines the fields that are in the area pointed to * * by the "CVTUSER" feild in the system CVT. * * * * To Enqueue on this table specify: * * * USERCVTQ DC CL8'USERCVT' -- QNAME * USERCVTR DC C'USERCVT.TABLE' -- RNAME * * * * You MUST enqueue with the options "EXCLUSIVE,SYSTEMS" for * * updating and "SHARED,SYSTEMS" for reading. * * * USERCVT DSECT CSAEYECT DS D Eyecatcher location TAPESTKR DS A Address of tape stacker area HASPLINE DS A Address of JES2 lines work area DS 3D Reserved for future expansion SPACE 1 USERCVTL EQU (((*-USERCVT)/8)+1)*8 Length of the USER CVT area * * * Copyright - Abbydale Systems LLC. * *********************************************************************** ./ ADD NAME=WTP MACRO &NAME WTP &MSG * ******************************************************************* * * * * W T P * * * * Issue a Write To Operator with a route code of 11 * * * &NAME WTO &MSG,ROUTCDE=11,DESC=7 * * * Copyright - Abbydale Systems LLC. * * ******************************************************************* * MEND ./ ENDUP "REVIEW" PDS MEMBER OFFLOAD AT 08:54 ON 23-03-20