IKJCT441 Entry Codes

IBM Mainframe Forums -> CLIST & REXX

Quick References

View previous topic :: View next topic

Author

Message

Akatsukami

Global Moderator

Joined: 03 Oct 2009
Posts: 1787
Location: Bloomington, IL

Posted: Tue Oct 09, 2012 1:22 am

Can someone provide a pointer to a list of the values of the entry codes for IKJCT441?

enrico-sorichetti

Superior Member

Joined: 14 Mar 2007
Posts: 10888
Location: italy

Posted: Tue Oct 09, 2012 1:32 am

is this what You are looking for ? publibz.boulder.ibm.com/cgi-bin/bookmgr_OS390/BOOKS/ikj4b760/24.2.1?ACTION=MATCHES&REQUEST=ikjct441&TYPE=FUZZY&SHELF=IKJ4BK90.bks&DT=20070510005632&CASE=&searchTopic=TOPIC&searchText=TEXT&searchIndex=INDEX&rank=RANK&ScrollTOP=FIRSTHIT#FIRSTHIT let me know if You want also some working examples

Akatsukami

Global Moderator

Joined: 03 Oct 2009
Posts: 1787
Location: Bloomington, IL

Posted: Tue Oct 09, 2012 1:40 am

Unfortunately, the documentation does not indicate the values, only the symbolic names. In HLASM I could, I think, get those values by defining an A-type constant, but as I'm writing PL/I, this option is not available. I'd greatly appreciate examples.

enrico-sorichetti

Superior Member

Joined: 14 Mar 2007
Posts: 10888
Location: italy

the values are <equated> in SYS1.MACLIB(IKJTSVT)

here is an assembler REXX external function to return a list of variable names

Code:

TITLE 'RXVARS - RETURN THE NAMES OF THE KNOWN VARIABLES'
GBLA &STEMLEN
&STEMLEN SETA 64
RXVARS $ENTR BASE=(R12),SAVE=RENT,RENT=RENTL
RXVARS AMODE 31
RXVARS RMODE ANY
*
LR R10,R1 SAVE EFPL POINTER
USING EFPL,R10
XC RETCODE,RETCODE
MVC RCV(1),=C'0'
LA R15,RCV
ST R15,RCVPTR
MVC RCVLEN,=F'1'
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
GETBUF DS 0H
L R0,BUFFMAX
XC BUFFPTR,BUFFPTR
GETBUF0 DS 0H
ST R0,BUFFSZ
GETMAIN RC,LV=(0),LOC=ANY
LTR R15,R15
BZ GETBUF1
L R0,BUFFSZ
SRL R0,1
B GETBUF0
GETBUF1 DS 0H
ST R1,BUFFPTR
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ST R1,BUFF$
LA R15,&STEMLEN
ST R15,PREFLEN
*
L R15,BUFFSZ
SRL R15,1
AR R1,R15
ST R1,BUFFLIM
*
LA R15,STEMPAR
ST R15,STEMPTR
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
MVC STEMLEN,FW1
MVI STEMPAR,C'*'
MVC SORTLEN,FW1
MVI SORTPAR,C'Y'
*
L R9,EFPLARG POINT TO FIRST PARAMETER
LM R6,R7,8*1-8(R9) GET FIRST PARM ADDRESS AND LENGTH
C R6,X4FF
BE ENDP
BAL R11,GETPARM
LTR R7,R7
BZ ENDP1
ST R7,STEMLEN
LA R4,STEMPAR
LR R5,R7
MVCL R4,R6
TR STEMPAR,UPPER
ENDP1 DS 0H
*
LM R6,R7,8*2-8(R9) GET SECOND PARM ADDRESS AND LENGTH
C R6,X4FF
BE ENDP
BAL R11,GETPARM
LTR R7,R7
BZ ENDP2
CLI 0(R6),C'Y'
BE ENDP2
CLI 0(R6),C'N'
BNE ENDP2
MVI SORTPAR,C'N'
ENDP2 DS 0H
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ENDP DS 0H
INIT DS 0H
LA R15,TSVELOC
ST R15,ECODE
LA R15,TSVRNOM
ST R15,EVARS
XC TOKEN,TOKEN
NEXTVAR DS 0H
BAL R11,INVOKE
C R15,EVARS
BE SORT
LTR R15,R15
BZ CONT
MVC RCV(2),=C'20'
MVC RCVLEN,=F'2'
B SORT
CONT DS 0H
CLI STEMPAR,C'*'
BE KEEPVAR
LM R4,R5,STEM$
LTR R5,R5
BZ KEEPVAR
LM R6,R7,NAME$
CR R5,R7
BH NEXTVAR
LR R7,R5
CLCL R4,R6
BNE NEXTVAR
KEEPVAR DS 0H
LM R4,R5,BUFF$
C R4,BUFFLIM
BL CONT2
MVC RCV(1),=C'8'
MVC RCVLEN,=F'1'
B SORT
CONT2 DS 0H
LM R6,R7,NAME$
O R7,FWFILL
*
MVCL R4,R6
*
ST R4,BUFF$
B NEXTVAR
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
SORT DS 0H
L R15,BUFF$
S R15,BUFFPTR
ST R15,USEDSZ
CLC USEDSZ,FW0
BNE SORT1
MVC RCV(1),=C'4'
MVC RCVLEN,=F'1'
B MOVE
SORT1 DS 0H
CLI SORTPAR,C'Y'
BNE PACK
L R4,BUFFPTR
L R5,BUFF$
S R5,=F'&STEMLEN'
$SORT FIELDS=(1,&STEMLEN,CH,A),LENGTH=&STEMLEN, *
FIRST=(R4),LAST=(R5)
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PACK DS 0H
L R4,BUFFLIM
L R6,BUFFPTR
PACK1 DS 0H
LA R7,&STEMLEN
TRT 0(&STEMLEN,R6),TBLFIND
SR R1,R6
LA R5,1(,R1)
MVCL R4,R6
AR R6,R7
C R6,BUFF$
BL PACK1
S R4,BUFFLIM
ST R4,USEDSZ
*
L R4,BUFFPTR
L R5,BUFFLIM
SR R5,R4
*
L R6,BUFFLIM
L R7,USEDSZ
O R7,FWFILL
MVCL R4,R6
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
DONE DS 0H
CLC USEDSZ,FW250
BL MOVE
LA R1,GETBLOCK 'GETBLOCK'
ST R1,GETBLKID IS PARM 1
L R1,EFPLEVAL EVALBLOCK ADCON
ST R1,GETBLKA IS PARM 2
LA R1,USEDSZ LENGTH IN BYTES
ST R1,GETBLKL IS PARM 3
OI GETBLKL,X'80' SET VL BIT
*
LA R1,GETBPLST POINT TO LIST
LINK EP=IRXRLT LINK TO THE ROUTINE
LTR R15,R15
BZ MOVE
MVC RCV(2),=C'24'
MVC RCVLEN,=F'2'
B FREEBUFF
*
MOVE DS 0H
L R9,EFPLEVAL
L R9,0(R9)
USING EVALBLOCK,R9
L R6,BUFFPTR
L R7,USEDSZ
ST R7,EVALBLOCK_EVLEN SET LENGTH
LA R4,EVALBLOCK_EVDATA
LR R5,R7
MVCL R4,R6
FREEBUFF DS 0H
L R0,BUFFSZ GET ACTUAL BUFFER SIZE
L R1,BUFFPTR
LTR R1,R1
BZ RETURN
FREEMAIN RU,A=(1),LV=(0)
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
RETURN DS 0H
LA R15,TSVEUPDT
ST R15,ECODE
XC TOKEN,TOKEN
MVC NAME$(8),RCN$
MVC DATA$(8),RCV$
BAL R11,INVOKE
*
$RTRN RC=(R15),RENT=RENTL
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
INVOKE DS 0H
XC CALLPLST,CALLPLST
L R15,CVTPTR
L R15,CVTTVT-CVT(,R15)
L R15,TSVTVACC-TSVT(,R15)
LTR R15,R15
BZ LINK441
CALL441 DS 0H
CALL (15), *
(ECODE, *
NAMEPTR,NAMELEN, *
DATAPTR,DATALEN, *
TOKEN), *
MF=(E,CALLPLST),VL
BR R11
LINK441 DS 0H
LINK EP=IKJCT441, *
PARAM=(ECODE, *
NAMEPTR,NAMELEN, *
DATAPTR,DATALEN, *
TOKEN), *
MF=(E,CALLPLST),VL=1
BR R11
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
GETPARM DS 0H
C R6,X4FF
BE G01PARM
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* SKIP LEADING BLANKS
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
BCTR R7,0
EX R7,TRTSKIP
BZ G01PARM
SR R1,R6
SR R7,R1
LA R6,0(R1,R6)
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
* FIND ENDING BLANK
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
EX R7,TRTFIND
BZ G02PARM NO ENDING BLANK
SR R1,R6
LR R7,R1
BR R11
SPACE
G01PARM DS 0H
SR R7,R7
BR R11
G02PARM DS 0H
LA R7,1(,R7)
BR R11
SPACE 1
DS 0D
TRTSKIP TRT 0(0,R6),TBLSKIP
TRTFIND TRT 0(0,R6),TBLFIND
DS 0D
TBLFIND $TRTB SCAN,FIND=C' '
TBLSKIP $TRTB SCAN,SKIP=C' '
EJECT
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
SPACE 1
UPPER $TRTB UPPER
DS 0D
GETBLOCK DC CL8'GETBLOCK'
DS 0D
BUFFMAX DC AL4(2*10240*&STEMLEN) MAX POOL LENGHT
FW0 DC F'0'
FW1 DC F'1'
FW250 DC F'250'
FWFILL DC X'40000000'
X4FF DC X'FFFFFFFF'
*
RCN$ DS 0D
RCNPTR DC AL4(RCN)
RCNLEN DC AL4(2)
RCN DC CL4'RC'
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
LTORG
*---------------------------------------------------------------------*
* DYNAMIC WORK AREA
*---------------------------------------------------------------------*
RENT DSECT
SAVE DS 9D SAVE AREA - MUST BE FIRST
DWORD DS D
RETCODE DS F
BUFFPTR DS F
BUFFLIM DS F
BUFFSZ DS F
USEDSZ DS F
*
BUFF$ DS 0D
DS F
PREFLEN DS F
*
STEM$ DS 0D
STEMPTR DS F
STEMLEN DS F
STEMPAR DS CL&STEMLEN
*
SORT$ DS 0D
SORTPTR DS F
SORTLEN DS F
SORTPAR DS CL4
*
NAME$ DS 0D
NAMEPTR DS F
NAMELEN DS F
*
DATA$ DS 0D
DATAPTR DS F
DATALEN DS F
*
RCV$ DS 0D
RCVPTR DS F
RCVLEN DS F
RCV DS F
*
TOKEN DS F
ECODE DS F
EVARS DS F
*
CALLPLST DS 9D
*
GETBPLST DS 0D IRXRLT PARM LIST
GETBLKID DS A 1 - POINTER TO 'GETBLOCK'
GETBLKA DS A 2 - POINTER TO NEW EVAL BLOCK
GETBLKL DS A 3 - POINTER TO DATA LENGTH
*
DS 0D
RENTL EQU *-RENT
EJECT
*---------------------------------------------------------------------*
* DSECTS FOR MVS / TSO INTERFACE *
*---------------------------------------------------------------------*
CVT DSECT=YES
IKJTSVT
EJECT
*---------------------------------------------------------------------*
* DSECTS FOR MVS / REXX INTERFACE *
*---------------------------------------------------------------------*
IRXEFPL , EXTERNAL FUNCTION PARAMETER LIST
EJECT
IRXEVALB , EVALUATION BLOCK
EJECT
END RXVARS

not too many comments
if You want I' ll post also the macros that go with it

the function is pretty handy when building variable names using the interpret and the value functions

it saves the hassle of keeping a table of the <used> variable names in order to drop them when not needed

used it in my JCL parser/reformatter

cheers

P.S.

if You are interested I have also an external function to access ( read/write) PDS/PDSE

Akatsukami

Global Moderator

Joined: 03 Oct 2009
Posts: 1787
Location: Bloomington, IL

Posted: Tue Oct 09, 2012 2:12 am

Thank you very much, Dr. Sorichetti; this is exactly what I need (if I can make it work; but if I can't, that's my failing, not yours).

enrico-sorichetti

Superior Member

Joined: 14 Mar 2007
Posts: 10888
Location: italy

konnichiwa Akatsukami Sama

follow on ...
here are the macros used to build the <thing>

$entr

Code:

MACRO
&LABL $ENTR &NAME, +
&BASE=R11,&CSECT=YES,&SAVE=,&RENT=,&SP=1,&SPM=NO, +
&CHAIN=YES
.**********************************************************************
.* *
.* $ENTR *
.* *
.* FUNCTION PROVIDE ENTRY CODING TO ESTABLISH BASE REGISTERS, *
.* ALLOCATE AND CHAIN SAVE AREAS, SET PROGRAM MASK, *
.* AND OBTAIN WORK AREA FOR RE-ENTRANT PROGRAMS. *
.* *
.* DESCRIPTION THE MACRO WILL GENERATE CODE TO ESTABLISH ONE OR *
.* MORE BASE REGISTERS. IT IS ASSUMED THAT STANDARD *
.* IBM LINKAGE CONVENTIONS HAVE BEEN FOLLOWED AND THAT *
.* REGISTER 15 CONTAINS THE ADDRESS OF THE ENTRY *
.* POINT. USER SPECIFIED OR DEFAULT BASE REGISTERS *
.* ARE INITIALIZED. THE FIRST BASE REGISTER CONTAINS *
.* THE ADDRESS OF THE ENTRY POINT, AND SUCCESSIVE BASE *
.* REGISTER ADDRESSES ARE INCREMENTED BY 4096. THE *
.* DEFAULT BASE REGISTER IS REGISTER 11, IF REGISTER 2 *
.* IS SPECIFIED AS A BASE REGISTER, IT WILL BE *
.* ALLOWED, BUT A WARNING MESSAGE WILL BE DISPLAYED. *
.* REGISTERS 0, 1, 13, 14, AND 15 MAY NOT BE *
.* SPECIFIED AS BASE REGISTERS. ALL REGISTER *
.* SPECIFICATIONS MUST BE MADE AS MNEMONICS (EG, *
.* REGISTER 3 IS R3). *
.* *
.* IDENTIFICATION CONSTANTS SPECIFYING THE DATE AND *
.* TIME OF ASSEMBLY ARE CONSTRUCTED IN THE ENTRY *
.* CODING. THESE VALUES ARE DISPLAYED IN DUMPS AND *
.* MAY BE USED TO VERIFY THAT THE PROPER VERSION OF *
.* THE ROUTINE HAS BEEN USED. *
.* *
.* ALL BITS OF THE PROGRAM MASK ARE SET. IBM *
.* TRANSFERS CONTROL TO THE USER PROGRAM WITH ALL *
.* PROGRAM MASK BITS OFF. IF SPM=NO IS SPECIFIED, *
.* THE PROGRAM MASK WILL BE UNALTERED. *
.* *
.* THE USER MAY SPECIFY THE NAME OF A WORK AREA OF 18 *
.* FULLWORDS TO BE USED AS A SAVE AREA. IF A USER *
.* AREA IS NOT SUPPLIED, AN 18 FULLWORD AREA IS *
.* ALLOCATED AND INITIALIZED TO ZERO. THE ADDRESS OF *
.* THE SAVE AREA IS LOADED INTO REGISTER 13 AND IT IS *
.* CHAINED TO THE SAVE AREA OF THE CALLING PROGRAM. *
.* *
.* THE USER MAY SPECIFY THAT THE MACRO IS NOT TO *
.* OBTAIN A SAVE AREA OR CHAIN SAVE AREAS BY *
.* SPECIFYING CHAIN=NO. THE USER IS THEN *
.* RESPONSIBLE FOR SAVE AREA CHAINING. *
.* *
.* REGISTER EQUIVALENCES (R0 EQU 0, ETC.) ARE *
.* GENERATED FOR THE FIRST USAGE OF THE MACRO. *
.* *
.* A CSECT DEFINITION WILL BE GENERATED UNLESS *
.* CSECT=NO IS SPECIFIED. IF CSECT=NO IS SPECIFIED, *
.* AN ENTRY STATEMENT WILL BE GENERATED. *
.* *
.* RE-ENTRANT CODING IS SUPPORTED. FOR RE-ENTRANT *
.* CODING, THE USER MUST SPECIFY THE LENGTH OF A *
.* WORK AREA. THE WORK AREA IS OBTAINED FROM SUBPOOL *
.* 1 UNLESS OTHERWISE SPECIFIED. THE FIRST 18 WORDS *
.* OF THE WORK AREA ARE USED FOR THE SAVE AREA. *
.* *
.* SYNTAX $ENTR NAME,BASE=(REG1,...,REGN) *
.* ..........................OR *
.* NAME $ENTR BASE=(REG1,...,REGN) *
.* CSECT=NO *
.* SAVE=SYM *
.* RENT=LEN *
.* SP=NUMBER *
.* SPM=NO *
.* CHAIN=NO *
.* *
.* NAME - A SYMBOLIC TAG ASSIGNED TO THE FIRST *
.* INSTRUCTION GENERATED. *
.* *
.* BASE - THE REGISTERS TO BE USED AS BASE *
.* REGISTERS. THE DEFAULT IS R11. THE FIRST *
.* REGISTER SPECIFIED WILL CONTAIN THE *
.* ADDRESS OF THE ENTRY POINT, AND SUCCEEDING *
.* BASE VALUES WILL BE INCREMENTED BY 4096. *
.* REGISTERS 0, 1, 13, 14, AND 15 MAY NOT BE *
.* SPECIFIED AS BASE REGISTERS. REGISTERS *
.* MUST BE SPECIFIED IN MNEMONIC FORM (EG, *
.* R3 FOR REGISTER 3). *
.* *
.* CSECT - CSECT=NO SPECIFIES THAT CODING FOR AN *
.* ENTRY POINT RATHER THAN A CSECT IS TO BE *
.* GENERATED. *
.* *
.* SAVE - SPECIFIES THE NAME OF A USER DEFINED 18 *
.* WORD SAVE AREA TO BE USED INSTEAD OF *
.* GENERATING AN IN-LINE SAVE AREA. IF RENT *
.* IS SPECIFIED, SAVE MUST SPECIFY THE NAME *
.* ASSIGNED TO THE FIRST 18 WORDS IN THE *
.* WORK AREA. *
.* *
.* RENT - SPECIFIES THAT RE-ENTRANT CODE IS TO BE *
.* GENERATED. LEN IS THE LENGTH OF A WORK *
.* AREA TO BE OBTAINED BY A GETMAIN. *
.* *
.* SP - SPECIFIES THE SUBPOOL FROM WHICH THE WORK *
.* AREA FOR RE-ENTRANT CODING IS TO BE *
.* OBTAINED. DEFAULT IS SUBPOOL 1. *
.* *
.* SPM - SPM=NO SPECIFIES THAT THE PROGRAM MASK IS *
.* NO TO BE ALTERED. *
.* *
.* CHAIN - CHAIN=NO SPECIFIES THAT SAVE AREA ARE NOT *
.* TO BE CHAINED. THIS OPTION IS INTENDED *
.* FOR USE ONLY BY HIGH ACTIVITY RE-ENTRANT *
.* MODULES WHERE THE OVERHEAD OF *
.* GETMAIN/FREEMAIN IS TO BE AVOIDED. *
.* *
.* ERRORS THE NAME FIELD MUST BE SPECIFIED. IF IT IS NOT, A *
.* GENERATED NAME, $ENTNNNN WILL BE GENERATED AND A *
.* SEVERITY 8 MNOTE IS GENERATED. IF NO CODE WERE *
.* GENERATED AND NO BASE REGISTER DEFINED, THE ERROR *
.* LISTING WOULD BE LARGE. TO REDUCE THE SIZE OF THE *
.* ERROR LISTING AND ALLOW OTHER ERRORS TO BE FOUND, *
.* THE MACRO WILL EXPAND. *
.* *
.* *
.* EXAMPLE EX1 $ENTR *
.* *
.* EX2 $ENTR CSECT=NO *
.* *
.* EX3 $ENTR BASE=(R3,R4,R5) *
.* *
.* EX4 $ENTR BASE=R12,RENT=DSECTLEN,SAVE=SAVEAREA*
.* *
.* GLOBAL SYMBOLS *
.* *
.* NAME TYPE USE *
.* *
.* &REGS B SET TO 1 AFTER REGISTER EQUIVALENCES *
.* GENERATED TO PREVENT EQUIVALENCES *
.* FROM BEING GENERATED FOR LATER USES. *
.* *
.* MACROS USED *
.* *
.* GETMAIN *
.* *
.* *
.**********************************************************************
.*
GBLB &REGS
.*
LCLA &PARMNO,&REGNO
LCLC &REG,&CHAR,&LAST,&USING,&TEMP,&ID,&FIRST,&IDUSE
.*
&ID SETC '&NAME'
AIF ('&NAME' NE '').CKCSECT
&ID SETC '&LABL'
AIF ('&LABL' NE '').CKCSECT
&ID SETC '$ENT&SYSNDX'
MNOTE 8,'NAME OPERAND REQUIRED, NOT SPECIFIED. &ID WILL BE USE+
D.'
.CKCSECT ANOP
.* MNOTE *,'CSECT NAME IS ( &SYSECT )'
AIF ('&CSECT' EQ 'YES').CSECT
AIF ('&SYSECT' NE '').CKEQU
MNOTE 8,'ENTRY POINT SPECIFIED, BUT NO CSECT DEFINED'
.CSECT ANOP
SPACE
&ID CSECT
&IDUSE SETC '&ID'
.CKEQU AIF (&REGS).SKIPEQU
SPACE
***********************************************************************
* *
* REGISTER EQUIVALENCES *
* *
***********************************************************************
SPACE
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
R9 EQU 9
R10 EQU 10
R11 EQU 11
R12 EQU 12
R13 EQU 13
R14 EQU 14
R15 EQU 15
.*
&REGS SETB 1
SPACE
.SKIPEQU ANOP
AIF ('&CSECT' EQ 'YES').CSECT2
AIF ('&SYSECT' EQ '').CSECT2
&IDUSE SETC '&ID'
AIF ('&CSECT' EQ 'NO').ENTRY2
&IDUSE SETC '&CSECT'
.*-------ENTRY POINT
ENTRY &ID
.* USING &ID,R15
CNOP 0,4
&ID B 20(0,R15) BRANCH AROUND ID
DC AL1(9) IDENTIFIER LENGTH
DC CL8'&ID' ENTRY POINT NAME
DC CL1' ' SPACER
DC XL2'0000'
DC A(&IDUSE)
STM R14,R12,12(R13) SAVE REGISTERS
AGO .STREGS
.*-------ENTRY POINT
.ENTRY2 ANOP
ENTRY &ID
CNOP 0,4
&ID B 14(0,R15) BRANCH AROUND ID
DC AL1(9) IDENTIFIER LENGTH
DC CL8'&ID' ENTRY POINT NAME
DC CL1' ' SPACER
STM R14,R12,12(R13) SAVE REGISTERS
AGO .STREGS
.*-------CSECT
.CSECT2 ANOP
B 28(0,R15) BRANCH AROUND ID
DC AL1(23) IDENTIFIER LENGTH
DC CL8'&ID' CSECT NAME
DC CL1' ' SPACER
DC CL8'&SYSDATE' DATE OF ASSEMBLY
DC CL1' ' SPACER
DC CL5'&SYSTIME' TIME OF ASSEMBLY
STM R14,R12,12(R13) SAVE REGISTERS
.STREGS ANOP
&PARMNO SETA 1 INITIALIZE COUNTER
.CKBASE ANOP
&REG SETC '&BASE(&PARMNO)'(1,3)
AIF ('&REG'(1,1) NE 'R').SKIPBAS
&TEMP SETC '&REG'(2,2)
&REGNO SETA &TEMP
AIF (&REGNO LT 2).BADBASE
AIF (&REGNO GT 12).BADBASE
AIF (&REGNO NE 2).SETBASE
MNOTE 0,'*** WARNING - R2 IS A BASE REGISTER. TRANSLATE AND TE+
ST INSTRUCTION WILL DESTROY CONTENTS.'
.SETBASE ANOP
AIF ('&FIRST' NE '').SETBAS2
AIF ('&CSECT' EQ 'YES').COMBAS
AIF ('&CSECT' EQ 'NO').COMBAS
L &REG,16(,R15) LOAD BASE ADDRESS
&FIRST SETC '&REG' SAVE REGISTER
AGO .SETLAST
.COMBAS ANOP
LR &REG,R15 LOAD BASE ADDRESS
&FIRST SETC '&REG' SAVE REGISTER
AGO .SETLAST
.SETBAS2 LA &REG,4095(&LAST) ADD 4095 TO LAST BASE
LA &REG,1(&REG) ADD 1 MORE
.SETLAST ANOP
&LAST SETC '&REG'
&USING SETC '&USING.,&REG'
AGO .NEXTBAS
.SKIPBAS MNOTE 8,'*&REG* IS AN INVALID REGISTER FORM, IGNORED'
AGO .NEXTBAS
.BADBASE MNOTE 8,'*&REG* IS AN INVALID BASE REGISTER, IGNORED'
.NEXTBAS ANOP
&PARMNO SETA &PARMNO+1
AIF (&PARMNO LE N'&BASE).CKBASE
USING &IDUSE.&USING DEFINE BASE REGISTERS
.*-------SEE IF PROGRAM MASK IS TO BE SET
AIF ('&SPM' EQ 'NO').NOSPM
LA R15,15 LOAD PGM MASK SETTING
SLA R15,24 SHIFT TO BITS 4-7
SPM R15 SET PGM MASK AND COND
.NOSPM AIF ('&CHAIN' EQ 'NO').DONE
AIF ('&RENT' NE '').GETMAIN
* LR R15,R13 SAVE OLD SAVEAREA ADDR
AIF ('&SAVE' NE '').LOADSAV
CNOP 0,4 FULL WORD ALIGNMENT
BAL R1,*+76 LOAD SAVEAREA ADDR
DC 18F'0' SAVE AREA
AGO .CHAIN
.LOADSAV LA R1,&SAVE LOAD NEW SAVEAREA ADDR
AGO .CHAIN
ST R13,4(R1)
ST R1,8(R13) CHAIN NEW IN OLD
AGO .RELOAD
.GETMAIN ANOP
.* MNOTE *,' GETMAIN R,LV=&RENT,SP=&SP,LOC=BELOW'
GETMAIN R,LV=&RENT,SP=&SP,LOC=BELOW GET STORAGE
ST R13,4(R1)
ST R1,8(R13) CHAIN NEW IN OLD
LA R14,72(,R1)
LA R15,&RENT-72
SR R1,R1
MVCL R14,R0
.* END OF GETMAIN - $ENTR
USING &SAVE,R13 DEFINE BASE REGISTER
.RELOAD ANOP
LM R13,R1,8(R13) RELOAD REGS 13 TO 1 CONTENTS
.DONE ANOP
MEND

$rtrn

Code:

MACRO
&NAME $RTRN &RC=,&RENT=,&SP=1,&SPM=NO, C
&FLAG=NO,&CHAIN=YES
.**********************************************************************
.* *
.* $RTRN *
.* *
.* FUNCTION GENERATE CODE REQUIRED TO RETURN CONTROL TO THE *
.* CALLING PROGRAM. *
.* *
.* DESCRIPTION STANDARD IBM LINKAGE CODE IS GENERATED BY THE MACRO *
.* TO RETURN CONTROL TO THE CALLING PROGRAM. THE USER *
.* MAY SPECIFY THE RETURN CODE TO BE RETURNED. *
.* RE-ENTRANT CODE IS SUPPORTED. *
.* *
.* REGISTERS 0 THROUGH 14 (OR OPTIONALLY, REGISTERS *
.* 2 THROUGH 14) WILL BE RESTORED TO THEIR STATUS *
.* UPON ENTRY TO THE ROUTINE. REGISTER 15 WILL BE *
.* USED FOR A DEFAULT OR USER SPECIFIED RETURN CODE. *
.* AN X'FF' WILL BE PLACED IN THE HIGH ORDER BYTE OF *
.* WORD 4 OF THE OLD SAVE AREA TO INDICATE THAT *
.* CONTROL HAS BEEN RETURNED TO THE CALLING PROGRAM *
.* *
.* CODE IS ALSO GENERATED TO RESTORE THE PROGRAM MASK *
.* TO ITS STATUS UPON ENTRY TO THE ROUTINE. THE *
.* VALUE OF THE MASK IS OBTAINED FROM THE HIGH ORDER *
.* BYTE OF REGISTER 14. THE ASSUMPTION IS MADE THAT *
.* STANDARD LINKAGE WAS USED TO INVOKE THE ROUTINE, *
.* THAT IS, THAT ENTRY WAS MADE BY A BALR R14,R15. *
.* IF THIS IS NOT TRUE, THE PROGRAM MASK WILL BE *
.* RESTORED INCORRECTLY. IF SPM=NO IS SPECIFIED, THE *
.* PROGRAM MASK WILL NOT BE ALTERED. *
.* *
.* *
.* SYNTAX NAME $RTRN RC=NUM1 *
.* (ANY REGISTER) *
.* RENT=LEN *
.* SP=NUM2 *
.* SPM=NO *
.* *
.* NAME - A SYMBOLIC TAG ASSIGNED TO THE FIRST *
.* INSTRUCTION GENERATED. *
.* *
.* RC - SPECIFIES THE RETURN CODE TO BE PLACED IN *
.* REGISTER 15. A NUMBER MAY BE SPECIFIED, *
.* OR (R15) INDICATES THAT THE RETURN CODE *
.* HAS ALREADY BEEN PLACED IN REGISTER 15 BY *
.* THE USER. THE DEFAULT RETURN CODE IS 0. *
.* *
.* RENT - INDICATES THAT THE WORK AREA OBTAINED BY *
.* $ENTER IS TO BE FREED. LEN SPECIFIES THE *
.* LENGTH OF THE AREA. THE ADDRESS IS *
.* OBTAINED FROM REGISTER 13. *
.* *
.* SP - SPECIFIES THE SUBPOOL OF THE WORK AREA. *
.* IT MUST AGREE WITH THE SUBPOOL SPECIFIED *
.* IN $ENTER. THE DEFAULT IS 1. *
.* *
.* SPM - SPM=NO SPECIFIES THAT THE PROGRAM MASK *
.* IS NOT TO BE ALTERED. *
.* *
.* ERRORS NO ERROR MESSAGES ARE GENERATED *
.* *
.* EXAMPLE EX1 $RTRN *
.* *
.* EX2 $RTRN RC=4 *
.* *
.* EX3 $RTRN RC=(R15),RENT=DSECTLEN *
.* *
.* GLOBAL SYMBOLS *
.* *
.* NONE *
.* *
.* MACROS CALLED *
.* *
.* FREEMAIN *
.* *
.**********************************************************************
.*
LCLC &RCR
&NAME DS 0H
AIF ('&CHAIN' EQ 'NO').NCHAIN1
AIF ('&RENT' EQ '').NRENT1
LR R1,R13 LOAD STORAGE ADDRESS
.NRENT1 ANOP
L R13,4(R13) RESTORE OLD SAVEAREA
.NCHAIN1 ANOP
AIF ('&RC' EQ '').RCNONE
AIF ('&RC'(1,1) EQ '(' AND '&RC'(K'&RC,1) EQ ')' ).RCREG
LA R15,&RC
AGO .COMMN2
.RCREG ANOP
&RCR SETC '&RC'(2,K'&RC-2)
AIF ('&RCR' EQ 'R15' OR '&RCR' EQ '15' ).COMMN2
LR R15,&RCR
.COMMN2 ANOP
ST R15,16(,R13)
.RCNONE ANOP
AIF ('&RENT' EQ '').NRENT2
.* MNOTE *,' FREEMAIN R,LV=&RENT,A=(1),SP=&SP'
FREEMAIN R,LV=&RENT,A=(1),SP=&SP FREE STORAGE
.NRENT2 ANOP
LM R14,R12,12(R13) RESTORE RETURN ADDRESS
.SETFLAG ANOP
.*-------TEST FOR SAVE AREA FLAGGING
AIF ('&FLAG' EQ 'NO').NOFLAG
OI 15(R13),X'01' SET RETURNED FLAG
.NOFLAG ANOP
.*-------TEST FOR SPM RESET OR BSM
AIF ('&SPM' EQ 'SPM').SPM
AIF ('&SPM' EQ 'BSM').BSM
.BR14 ANOP
BR R14 RETURN
MEXIT
.SPM ANOP
SPM R14 RESTORE PROGRAM MASK
MEXIT
.BSM ANOP
BSM 0,R14 RESTORE ADDRESSING MODE
MEXIT
MEND

$sort

Code:

MACRO
&NAME $SORT &FIELDS=(1,1,CH,A),&FIRST=,&LAST=,&LENGTH=
.**********************************************************************
.* *
.* $SORT *
.* *
.* FUNCTION GENERATE CODING TO SORT A TABLE IN ASCENDING OR *
.* DESCENDING ORDER BASED ON A KEY FIELD IN EACH *
.* ENTRY. *
.* *
.* DESCRIPTION A BUBBLE SORT IS SORT IS PERFORMED. THE KEYS *
.* OF CONSECUTIVE ITEMS ARE COMPARED. THE ITEMS *
.* ARE SWITCHED IF NECESSARY. PROCESSING PROCEEDS *
.* TO THE NEXT PAIR OF ENTRIES. AT THE END OF ONE *
.* PASS, AT LEAST THE HIGHEST KEY IS IN THE PROPER *
.* POSITION. THE LIST IS REDUCED TO A SUBLIST *
.* FROM THE FIRST ENTRY TO THE LAST ENTRY WHICH *
.* WAS SWITCHED AND THE SUBLIST IS THEN PROCESSED *
.* AS WAS THE ORIGINAL LIST. THIS CONTINUES UNTIL *
.* THE ENTIRE LIST HAS BEEN SORTED. IF AT ANY POINT, *
.* PROCESSING THE LIST RESULTS IN NO ENTRIES BEING *
.* SWITCHED, THE LIST IS IN ORDER AND PROCESSING *
.* IS TERMINATED. *
.* *
.* REGISTERS 0, 1, 14, AND 15 ARE USED BY THE *
.* SORT AND MUST NOT BE SPECIFIED AS FIRST OR *
.* LAST VALUES. *
.* *
.* SYNTAX NAME #SORT FIELDS=(KEYPOS,KEYLEN,FMT,ORDER), *
.* FIRST=SYMBOL1, *
.* LAST=SYMBOL2, *
.* LENGTH=NUM *
.* *
.* NAME - SPECIFIES THE SYMBOLIC TAG TO BE *
.* ASSIGNED TO THE FIRST INSTRUCTION *
.* GENERATED. THIS OPERAND IS OPTIONAL. *
.* *
.* FIELDS - SPECIFIES THE SORT PARAMETERS. *
.* KEYPOS - SPECIFIES THE RELATIVE KEY *
.* POSITION IN THE RECORD. *
.* KEYLEN - SPECIFIES THE LENGTH OF THE KEY. *
.* FMT - SPECIFIES THE FORMAT OF THE *
.* DATA TO BE SORTED. THE ONLY *
.* VALID FORMAT IS CHARACTER (CH). *
.* ORDER - SPECIFIES IF THE LIST IS TO BE *
.* SORTED IN ASCENDING ORDER (A), *
.* OR DESCENDING ORDER (D). THE *
.* DEFAULT IS A. *
.* *
.* FIRST - SPECIFIES THE SYMBOLIC NAME OF THE FIRST *
.* ENTRY IN THE TABLE OR A REGISTER WHICH *
.* CONTAINS THE ADDRESS OF THE FIRST ENTRY. *
.* IF A SYMBOLIC NAME IS SPECIFIED, IT MUST *
.* BE ADDRESSABLE. IF A REGISTER IS *
.* SPECIFIED, IT MUST BE ENCLOSED IN *
.* PARENTHESES. THIS PARAMETER IS REQUIRED. *
.* *
.* LAST - SPECIFIES THE SYMBOLIC NAME OF THE LAST *
.* ENTRY IN THE TABLE OR A REGISTER WHICH *
.* CONTAINS THE ADDRESS OF THE LAST ENTRY. *
.* IF A SYMBOLIC NAME IS SPECIFIED, IT MUST *
.* BE ADDRESSABLE. IF A REGISTER IS *
.* SPECIFIED, IT MUST BE ENCLOSED IN *
.* PARENTHESES. THIS PARAMETER IS REQUIRED. *
.* *
.* LENGTH - SPECIFIES THE LENGTH OF THE ENTRIES IN *
.* THE TABLE. THIS PARAMETER IS REQUIRED. *
.* *
.* *
.* ERRORS INVALID NUMBER OF ENTRIES IN FIELDS PARAMETER - 8 *
.* FORMAT TYPE NOT SUPPORTED - 8 *
.* FIRST VALUE NOT SPECIFIED - 8 *
.* LAST VALUE NOT SPECIFIED - 8 *
.* LENGTH VALUE NOT SPECIFIED - 8 *
.* *
.* EXAMPLE SORT A TABLE OF ENTRIES WHERE THE FIRST 8 BYTES *
.* ARE THE KEYS. THE LENGTH OF EACH ENTRY IS 50 *
.* BYTES. *
.* *
.* #SORT FIELDS=(1,8,CH,A),LENGTH=50, *
.* FIRST=BEGIN,LAST=END *
.* *
.* BEGIN DC CL8'A',CL42'ENTRY 1' *
.* DC CL8'D',CL42'ENTRY 2' *
.* DC CL8'X',CL42'ENTRY 3' *
.* DC CL8'$',CL42'ENTRY 4' *
.* DC CL8'Q',CL42'ENTRY 5' *
.* END DC CL8'M',CL42'ENTRY 6' *
.* *
.* GLOBALS *
.* *
.* NONE *
.* *
.* MACROS USED *
.* *
.* NONE *
.* *
.**********************************************************************
.*
LCLA &X,&Y,&Z,&LEN
LCLC &HI,&I
LCLC &OFFST
.*
&I SETC '#SOR'.'&SYSNDX'(2,3)
&X SETA N'&FIELDS
AIF (&X NE 4).ERR1
AIF ('&FIELDS(3)' NE 'CH').ERR2
&HI SETC 'H'
AIF ('&FIELDS(&X)' NE 'D').TESTA
&HI SETC 'L'
AGO .SETREGS
.TESTA AIF ('&FIELDS(&X)' EQ 'A').SETREGS
MNOTE *,'*** SORT TYPE NOT A OR D - A ASSUMED'
.SETREGS ANOP
&LEN SETA &LENGTH
&X SETA &FIELDS(1)-1 OFFSET WITHIN RECORD
&Y SETA &FIELDS(2) LENGTH OF SORT-KEY
&Z SETA &X+&LEN OFFSET WITHIN NEXT RECORD
AIF ('&FIRST' EQ '').ERR3
AIF ('&LAST' EQ '').ERR4
AIF ('&LENGTH' EQ '').ERR5
.*
&NAME LA R0,&LENGTH LOAD LENGTH OF AN ENTRY
&OFFST SETC '0'
AIF ('&LAST'(1,1) EQ '(').CONT1
&OFFST SETC ''
.CONT1 ANOP
LA R1,&OFFST.&LAST LOAD LAST ENTRY ADDRESS
&I.A SR R14,R14 CLEAR LAST SWITCH ADDRESS
&OFFST SETC '0'
AIF ('&FIRST'(1,1) EQ '(').CONT2
&OFFST SETC ''
.CONT2 ANOP
LA R15,&OFFST.&FIRST LOAD FIRST ENTRY ADDRESS
SR R1,R0 POINT TO PENULTIMATE
CR R15,R1 TEST AGAINST FIRST ENTRY
BH &I.D IF HIGH, LIST SORTED
&I.B CLC &X.(&Y,R15),&Z.(R15) COMPARE KEYS
BN&HI &I.C
XC 0(&LEN,R15),&LEN.(R15) SWITCH ENTRIES
XC &LEN.(&LEN,R15),0(R15)
XC 0(&LEN,R15),&LEN.(R15)
LR R14,R15 SAVE ADDRESS OF SWITCHED ENTRY
&I.C BXLE R15,R0,&I.B POINT TO NEXT ENTRY
LTR R1,R14 COPY AND TEST LAST SWITCHED ADDR
BNZ &I.A
&I.D EQU *
MEXIT
.ERR1 MNOTE 8,'INVALID NO. OF ENTRIES IN FIELDS PARAMETER'
MEXIT
.ERR2 MNOTE 8,'FORMAT TYPE IS NOT SUPPORTED'
MEXIT
.ERR3 MNOTE 8,'FIRST ENTRY ADDRESS NOT SPECIFIED.'
MEXIT
.ERR4 MNOTE 8,'LAST ENTRY ADDRESS NOT SPECIFIED.'
MEXIT
.ERR5 MNOTE 8,'LENGTH NOT SPECIFIED.'
MEND

hope that it will be useful
cheers
enrico

enrico-sorichetti

Superior Member

Joined: 14 Mar 2007
Posts: 10888
Location: italy

forgot
$trtb

Code:

MACRO
&N $TRTB &TYPE,&BAD=X'FF',&GOOD=X'00',&SKIP=,&FIND=,&FILL=C' '
LCLA &NS,&NF,&IX
AIF ('&TYPE' EQ 'ALPHA').ALPHA
AIF ('&TYPE' EQ 'ALPHANUM').ALPHAN
AIF ('&TYPE' EQ 'BAD').BAD
AIF ('&TYPE' EQ 'GOOD').GOOD
AIF ('&TYPE' EQ 'NUMERIC').NUMERIC
AIF ('&TYPE' EQ 'PRINT').PRINT
AIF ('&TYPE' EQ 'SCAN').SCAN
AIF ('&TYPE' EQ 'TRALPHA').TRALPH
AIF ('&TYPE' EQ 'UPPER').UPPER
AIF ('&TYPE' EQ 'ZFILL').ZFILL
MNOTE 8,'TABLE TYPE INVALID'
MEXIT
.PRINT ANOP
&N DC (X'49'-X'00'+1)&FILL
DC (X'50'-X'4A'+1)AL1(*-&N)
DC (X'59'-X'51'+1)&FILL
DC (X'61'-X'5A'+1)AL1(*-&N)
DC (X'6A'-X'62'+1)&FILL
DC (X'6F'-X'6B'+1)AL1(*-&N)
DC (X'79'-X'70'+1)&FILL
DC (X'7F'-X'7A'+1)AL1(*-&N)
DC (X'C0'-X'80'+1)&FILL
DC (X'C9'-X'C1'+1)AL1(*-&N)
DC (X'D0'-X'CA'+1)&FILL
DC (X'D9'-X'D1'+1)AL1(*-&N)
DC (X'E1'-X'DA'+1)&FILL
DC (X'E9'-X'E2'+1)AL1(*-&N)
DC (X'EF'-X'EA'+1)&FILL
DC (X'F9'-X'F0'+1)AL1(*-&N)
DC (X'FF'-X'FA'+1)&FILL
MEXIT
.TRALPH ANOP
&N DC (X'80'-X'00'+1)&FILL
DC (X'89'-X'81'+1)AL1(*-&N+X'40')
DC (X'90'-X'8A'+1)&FILL
DC (X'99'-X'91'+1)AL1(*-&N+X'40')
DC (X'A1'-X'9A'+1)&FILL
DC (X'A9'-X'A2'+1)AL1(*-&N+X'40')
DC (X'C0'-X'AA'+1)&FILL
DC (X'C9'-X'C1'+1)AL1(*-&N)
DC (X'D0'-X'CA'+1)&FILL
DC (X'D9'-X'D1'+1)AL1(*-&N)
DC (X'E1'-X'DA'+1)&FILL
DC (X'E9'-X'E2'+1)AL1(*-&N)
DC (X'EF'-X'EA'+1)&FILL
DC (X'F9'-X'F0'+1)AL1(*-&N)
DC (X'FF'-X'FA'+1)&FILL
MEXIT
.UPPER ANOP
&N DC (X'80'-X'00'+1)AL1(*-&N)
DC (X'89'-X'81'+1)AL1(*-&N+X'40')
DC (X'90'-X'8A'+1)AL1(*-&N)
DC (X'99'-X'91'+1)AL1(*-&N+X'40')
DC (X'A1'-X'9A'+1)AL1(*-&N)
DC (X'A9'-X'A2'+1)AL1(*-&N+X'40')
DC (X'FF'-X'AA'+1)AL1(*-&N)
MEXIT
.NUMERIC ANOP
&N DC 240&BAD,10&GOOD,6&BAD
MEXIT
.ALPHA ANOP
&N DC 193&BAD,9&GOOD,7&BAD,9&GOOD,8&BAD,8&GOOD
DC 22&BAD
MEXIT
.ALPHAN ANOP
&N DC 193&BAD,9&GOOD,7&BAD,9&GOOD,8&BAD,8&GOOD
DC 6&BAD,10&GOOD,6&BAD
MEXIT
.ZFILL ANOP
&N DC 64AL1(*-&N),C'0',191AL1(*-&N)
MEXIT
.BAD ANOP
&N DC 256&BAD
MEXIT
.GOOD ANOP
&N DC 256&GOOD
MEXIT
.SCAN ANOP
AIF (T'&SKIP NE 'O').SKIP
AIF (T'&FIND NE 'O').FIND
MNOTE 8,'TRT SCAN SKIP OR FIND CHARACTER NOT FOUND'
MEXIT
.SKIP ANOP
&N DC 256&BAD
&NS SETA N'&SKIP
&IX SETA 1
.SL ANOP
ORG &N+&SKIP(&IX)
DC &GOOD
&IX SETA &IX+1
AIF (&IX LE &NS).SL
ORG
MEXIT
.FIND ANOP
&N DC 256&GOOD
&NF SETA N'&FIND
&IX SETA 1
.FL ANOP
ORG &N+&FIND(&IX)
DC &FIND(&IX)
&IX SETA &IX+1
AIF (&IX LE &NF).FL
ORG
MEXIT
MEND

View previous topic :: :: View next topic

View Bookmarks
All times are GMT + 6 Hours

Forum Index -> CLIST & REXX

Topic		Forum	Replies
Similar Topics
	Return codes-Normal & Abnormal te...	JCL & VSAM	7
	AI writing DFSORT, REXX codes..	All Other Mainframe Topics	3
	RXSUBCOM Return Codes / Documentation	CLIST & REXX	6
	Multiple Entry	PL/I & Assembler	5
	Automation of data entry using Rexx i...	CLIST & REXX	4

Search our Forums:

IBMMainframes.com is not an official and/or affiliated with IBM^® in anyway
Board Rules \| FAQ \| Downloads \| Wiki \| SiteMap \| Contact Us