Portal | Manuals | References | Downloads | Info | Programs | JCLs | Master the Mainframes
IBM Mainframe Computers Forums Index
 
Register
 
IBM Mainframe Computers Forums Index Mainframe: Search IBM Mainframe Forum: FAQ Memberlist Usergroups Profile Log in to check your private messages Log in
 

 

IKJCT441 Entry Codes

 
Post new topic   Reply to topic    IBMMAINFRAMES.com Support Forums -> CLIST & REXX
View previous topic :: :: View next topic  
Author Message
Akatsukami

Global Moderator


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

PostPosted: Tue Oct 09, 2012 1:22 am    Post subject: IKJCT441 Entry Codes
Reply with quote

Can someone provide a pointer to a list of the values of the entry codes for IKJCT441?
Back to top
View user's profile Send private message

enrico-sorichetti

Global Moderator


Joined: 14 Mar 2007
Posts: 10210
Location: italy

PostPosted: Tue Oct 09, 2012 1:32 am    Post subject: Reply to: IKJCT441 Entry Codes
Reply with quote

is this what You are looking for ?

http://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
Back to top
View user's profile Send private message
Akatsukami

Global Moderator


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

PostPosted: Tue Oct 09, 2012 1:40 am    Post subject:
Reply with quote

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.
Back to top
View user's profile Send private message
enrico-sorichetti

Global Moderator


Joined: 14 Mar 2007
Posts: 10210
Location: italy

PostPosted: Tue Oct 09, 2012 1:50 am    Post subject: Reply to: IKJCT441 Entry Codes
Reply with quote

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
Back to top
View user's profile Send private message
Akatsukami

Global Moderator


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

PostPosted: Tue Oct 09, 2012 2:12 am    Post subject:
Reply with quote

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).
Back to top
View user's profile Send private message
enrico-sorichetti

Global Moderator


Joined: 14 Mar 2007
Posts: 10210
Location: italy

PostPosted: Wed Oct 10, 2012 3:24 pm    Post subject: Reply to: IKJCT441 Entry Codes
Reply with quote

konnichiwa Akatsukami Sama icon_biggrin.gif

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
Back to top
View user's profile Send private message
enrico-sorichetti

Global Moderator


Joined: 14 Mar 2007
Posts: 10210
Location: italy

PostPosted: Wed Oct 10, 2012 3:35 pm    Post subject: Reply to: IKJCT441 Entry Codes
Reply with quote

icon_redface.gif
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
Back to top
View user's profile Send private message
View previous topic :: :: View next topic  
Post new topic   Reply to topic    IBMMAINFRAMES.com Support Forums -> CLIST & REXX All times are GMT + 6 Hours
Page 1 of 1

 

Search our Forum:

Similar Topics
Topic Author Forum Replies Posted
No new posts Automation of data entry using Rexx i... zingy.rajeev CLIST & REXX 4 Mon Aug 22, 2016 4:13 pm
This topic is locked: you cannot edit posts or make replies. Automation of data entry using Rexx i... zingy.rajeev CICS 0 Mon Aug 22, 2016 4:11 pm
No new posts what will happen improper PCB order s... srinivasulu.p IMS DB/DC 1 Mon Mar 24, 2014 8:27 am
No new posts JCL Cond Codes Vivek Anand JCL & VSAM 7 Tue Sep 03, 2013 4:49 pm
No new posts Bulk Data entry in CICS Suceender Kumar CICS 9 Tue May 21, 2013 2:37 pm


Facebook
Back to Top
 
Mainframe Wiki | Forum Rules | Bookmarks | Subscriptions | FAQ | Tutorials | Contact Us