STRING R203 - March 1989

STRING Macro Page
*  STRING   02.03 1989-01-09 1989-03-27 12:39:00   528    25    24 WCZ07
*
*/WCZ07STR JOB (9775,GSF),STRING-MACRO,
*/ NOTIFY=WCZ07,
*/ CLASS=X,MSGCLASS=T,COND=(0,NE)
*/ASMH   EXEC  PGM=IEV90,PARM=(OBJECT,NODECK,NORLD,NOXREF)
         MACRO ,
&NAME    STRING &INTO=,&PRINT=NOGEN
         AIF   ('&PRINT' EQ 'NOGEN').NOGEN
         PUSH  PRINT
         PRINT GEN
.NOGEN   LCLA  &I,&J,&N
         GBLA  &$_FIELD,&$_MAXBL
         GBLC  &$_FIELDS(9999)
         AIF   (N'&SYSLIST EQ 1 AND '&SYSLIST(1)' EQ 'FINAL_CALL'      X
               AND T'&INTO EQ 'O').GENL
&LABEL   SETC  'IHB&SYSNDX'            stem for local labels
&LQ      SETC  'L'''                   length attribute
&NAME    BAL   R14,$STRING             Call @STRING sub-routine
         AIF   (N'&SYSLIST EQ 0).ERR1
         AIF   (T'&INTO EQ 'O').ERR2
         DC    AL2(&LABEL.P-*)
         AIF   (D'$STRING).LOCTR2
$LTORG   LOCTR ,                       ADDRESSABLE CONSTANTS
         CNOP  0,4
$STRING  BALR  R15,0                   local base
         L     R15,6(,R15)          0  routine address
         BR    R15                  4  go there
         DC    A(@STRING)           6  routine address
.LOCTR2  ANOP
$LITERAL LOCTR ,                       NON-ADDRESSABLE CONSTANTS
&TO1     SETC  '&INTO(1)'
&TO2     SETC  '&LQ&INTO'
         AIF   (N'&INTO EQ 1).PUNTO8            JUMP IF INTO=XXX
         AIF   ('&INTO(1)'(1,1) NE '(').PUNTO3  JUMP IF INTO=(XXX,44)
&TO1     SETC  '0&INTO(1)'                              INTO=((R3),44)
.PUNTO3  ANOP
&TO2     SETC  '&INTO(2)'                               INTO=(XXX,LL)
         AIF   ('&INTO(2)'(1,1) NE '(').PUNTO8  JUMP IF INTO=(XXX,44)
&TO2     SETC  '0&INTO(2)'                              INTO=(XXX,(R1))
.PUNTO8  ANOP
&LABEL.P DC    S(&TO1,&TO2)
.*---------------------------------------------------------------------
.*-------      FIELDS       -------------------------------------------
.*---------------------------------------------------------------------
         LCLB  &LAST,&BIN,&HEXA,®,&PACKED,&LEFT,&ZERO,&TRUNC
&I       SETA  1
.*
.LOOP1   ANOP
&LAST    SETB  (&I EQ N'&SYSLIST)                LOOP
         AIF   ('&SYSLIST(&I)'(1,1) EQ '''').LIT00
.*---------------------------------------------------------------------
.*       PROCESS FIRST SUBPARAMETER (ADDRESS)
.*---------------------------------------------------------------------
&P1S     SETC  '&SYSLIST(&I,1)'
&P2L     SETC  '0'                     INPUT LENGTH
&P3L     SETC  '0'                     OUTPUT LENGTH
         AIF   ('&SYSLIST(&I)'(1,1) GE '0').FLD180 SPACES
         AIF   ('&SYSLIST(&I)' EQ '%TIME').FLD190 %TIME
         AIF   ('&SYSLIST(&I,1)'(1,1) NE '(').FLD115 (R2)
         AIF   (T'&SYSLIST(&I,2) EQ 'O').FLD250
&P1S     SETC  '0&SYSLIST(&I,1)'       CHANGE (R1) TO 0(R1)
.FLD115  ANOP
.*
         AIF   (T'&SYSLIST(&I,2) NE 'O').FLD200
.*
         AIF   (NOT D'&SYSLIST(&I)).FLD140
&P2C     SETC  T'&SYSLIST(&I)
.*MNOTE *,'&P1 &P2C'
         AIF   ('&P2C' EQ 'F' OR '&P2C' EQ 'H' OR '&P2C' EQ 'P').FLD220
         AIF   ('&P2C' EQ 'G').FLD210  FL2
.FLD140  ANOP
&P2L     SETC  '&LQ&SYSLIST(&I,1)'     L'ABCDEF
         AGO   .FLD300
.*
.FLD180  AIF   ('&SYSLIST(&I)'(K'&SYSLIST(&I),1) NE 'X').FLD800
&P1S     SETC  'BLANKS'
&P2L     SETC  '&SYSLIST(&I)'(1,K'&SYSLIST(&I)-1) 12
&L       SETA  &P2L                    NUMBER OF BLANKS
         AIF   (&L LE &$_MAXBL).FLD800
&$_MAXBL SETA   &L                     MAX NUMBER OF BLANKS
         AGO   .FLD800
.*
.FLD190  ANOP                          %TIME
&P1S     SETC  '1(14)'                 %TIME
         AGO   .FLD800
.*---------------------------------------------------------------------
.*       PROCESS SECOND SUBPARAMETER (LENGTH/TYPE)
.*---------------------------------------------------------------------
.FLD200  AIF   (T'&SYSLIST(&I,2) EQ 'O').FLD300 NO LENGTH SPECIFIED
&P2C     SETC  '&SYSLIST(&I,2)'
         AGO   .FLD220
.*T'&P1=G
.FLD210  ANOP
&L       SETA  L'&SYSLIST(&I)          T'&P1 = 'G'
&P2C     SETC  'FL&L'                  T'&P1 = 'G'
.*
.FLD220  ANOP
&P2L     SETC  '0&P2C'                 (R2) LENGTH
         AIF   ('&P2C'(1,1) EQ '(').FLD300
&P2L     SETC  '&P2C'                  3(R2) LENGTH
         AIF   ('&P2C'(K'&P2C,1) EQ ')').FLD300
&P2L     SETC  '0'
&PACKED  SETB  ('&P2C' EQ 'P')
         AIF   (&PACKED).FLD300
&P2L     SETC  '1'
         AIF   ('&P2C' EQ 'FL1').FLD240
&P2L     SETC  '3'
         AIF   ('&P2C' EQ 'FL2' OR '&P2C' EQ 'H').FLD240
&P2L     SETC  '7'
         AIF   ('&P2C' EQ 'FL3').FLD240
&P2L     SETC  '15'
         AIF   ('&P2C' EQ 'F').FLD240
&P2L     SETC  '&P2C'                  IMMEDIATE LENGTH, FIELD
         AGO   .FLD300
.*
.FLD240  ANOP                          BINARY VARIABLE
&BIN     SETB  1
         AGO   .FLD300
.*
.FLD250  ANOP                          REGISTER CONTENT
®     SETB  1
.*---------------------------------------------------------------------
.*       PROCESS THIRD SUBPARAMETER (OUTPUT FORMAT)
.*---------------------------------------------------------------------
.FLD300  AIF   (T'&SYSLIST(&I,3) EQ 'O').FLD800
&HEXA    SETB  ('&SYSLIST(&I,3)' EQ 'X') HEXADECIMAL
&TRUNC   SETB  ('&SYSLIST(&I,3)' EQ 'T') TRUNCATE
         AIF   (&HEXA OR &TRUNC).FLD800
.*
&P3C     SETC  '&SYSLIST(&I,3)'
&P3L     SETC  '0'
         AIF   (T'&SYSLIST(&I,2) NE 'N').FLD310
         MNOTE 8,'EDIT PATTERN NOT ALLOWED WITH CHARACTER STRING'
.*LOOP
.FLD310  AIF   ('&P3C'(1,1) EQ 'R').FLD318       DEFAULT
         AIF   ('&P3C'(1,1) EQ 'B').FLD318       DEFAULT
         AIF   ('&P3C'(1,1) NE 'L').FLD311
&LEFT    SETB  1
         AGO   .FLD318
.FLD311  AIF   ('&P3C'(1,1) NE 'Z').FLD312
&ZERO    SETB  1
         AGO   .FLD318
.FLD312  AIF   ('&P3C'(1,1) LT '0').FLD993
&P3L     SETC  '&P3L'.'&P3C'(1,1)
.FLD318  ANOP
.*MNOTE *,'&SYSLIST(&I) P3C=/&P3C/ P3L=/&P3L/'
&P3C     SETC  '&P3C'(2,K'&P3C-1)     STRIP OFF FIRST CHARACTER
         AIF   (K'&P3C GT 0).FLD310
.*ENDLOOP
.*---------------------------------------------------------------------
.FLD800  AIF   ('&BIN&PACKED®' EQ '000').FLD810
         AIF   (&LEFT OR '&P3L' NE '0').FLD810
         AIF   (&HEXA).FLD810
&P3L     SETC  '7'                     DEFAULT OUTPUT LENGTH ((R3))
         AIF   (®).FLD810
&P3L     SETC  '3'                     DEFAULT OUTPUT LENGTH
         AIF   ('&P2C' EQ 'FL1').FLD810
&P3L     SETC  '5'                     DEFAULT OUTPUT LENGTH
         AIF   ('&P2C' EQ 'H' OR '&P2C' EQ 'FL2').FLD810
&P3L     SETC  '7'                     DEFAULT OUTPUT LENGTH
.FLD810  ANOP
&FLAG    SETA  &LAST*128+&HEXA*8+&BIN*4+&PACKED*2+®*1
&LEN2    SETA  &TRUNC*128+&LEFT*128+&ZERO*64+&P3L
         DC    S(&P1S,&P2L),AL1(&FLAG,&LEN2)
&BIN     SETB  0                    RESET FLAGS
&HEXA    SETB  0                    RESET FLAGS
®     SETB  0                    RESET FLAGS
&PACKED  SETB  0                    RESET FLAGS
&LEFT    SETB  0                    RESET FLAGS
&ZERO    SETB  0                    RESET FLAGS
&TRUNC   SETB  0                    RESET FLAGS
         AGO   .LIT99
.FLD990  MNOTE 8,'MISSING OR INCORRECT PARAMETER'
         AGO   .LIT99
.FLD993  MNOTE 8,'THIRD SUBPARAMETER IS INVALID: ''&SYSLIST(&I,3)'''
         AGO   .LIT99
.*---------------------------------------------------------------------
.*------------ LITERALS -----------------------------------------------
.*---------------------------------------------------------------------
.LIT00   AIF   (&$_FIELD EQ 0).LIT50
&N       SETA  1
.LIT10   AIF   (&N GT &$_FIELD).LIT50                LOOP
&L       SETA  &N+1000                               LOOP
         AIF   ('&SYSLIST(&I)' EQ '&$_FIELDS(&N)').LIT80 LOOP
&N       SETA  &N+1                                  LOOP
         AGO   .LIT10                                LOOP
.LIT50   ANOP
&$_FIELD SETA  &$_FIELD+1
&$_FIELDS(&$_FIELD) SETC '&SYSLIST(&I)'
&L       SETA  &$_FIELD+1000
.LIT80   ANOP
&J       SETA  X'4000'+&LAST*X'8000'
         DC    AL2($LIT&L-*,&LQ.$LIT&L,&J)
.LIT99   ANOP
.*---------------------------------------------------------------------
&I       SETA  1+&I                              LOOP
         AIF   (&I LE N'&SYSLIST).LOOP1          LOOP
&SYSLOC  LOCTR
         AGO   .MEND
.ERR1    MNOTE 12,'AT LEAST ONE INPUT FIELD MUST BE SPECIFIED'
         AGO   .MEND
.ERR2    MNOTE 12,'INVALID OUTPUT AREA SPECIFICATION'
         AGO   .MEND
.**********************************************************************
.*       FINAL_CALL: GENERATE LITERALS
.**********************************************************************
.GENL    AIF   (&$_FIELD EQ 0).GENL3
$LITERAL LOCTR
.GENL2   ANOP                                LOOP
&N       SETA  &N+1                          LOOP
&I       SETA  &N+1000                       LOOP
$LIT&I   DC    C&$_FIELDS(&N)                LOOP
         AIF   (&N LT &$_FIELD).GENL2        LOOP
.GENL3   ANOP
.**********************************************************************
.*
.*       STRING SUB-ROUTINE
.*
.*             CAUTION: BYTES 49-72 OF THE CALLER'S SAVE AREA
.*                      (R7-R12 SLOTS) ARE USED AS WORK SPACE
.*
.**********************************************************************
@STRING  CSECT
@STRING  RMODE ANY
.*R0     EQU   0                       WORK REGISTER
.*R1     EQU   1                       WORK REGISTER
.*R2     EQU   2                       WORK REGISTER
.*R3     EQU   3                       WORK REGISTER
.*R4     EQU   4                       WORK REGISTER
.*R5     EQU   5                       WORK REGISTER
.*R6     EQU   6                       WORK REGISTER
.*R7     EQU   7                       NOT SAVED, NOT USED
.*R8     EQU   8                       NOT SAVED, NOT USED
.*R9     EQU   9                       NOT SAVED, NOT USED
.*R10    EQU   10                      NOT SAVED, NOT USED
.*R11    EQU   11                      NOT SAVED, NOT USED
.*R12    EQU   12                      NOT SAVED, NOT USED
.*R13    EQU   13                      NOT SAVED, NOT USED
.*R14    EQU   14                      WORK REGISTER
.*R15    EQU   15                      WORK REGISTER
         SAVE  (14,6),,@STRING
         ST    R11,8(,R13)             SAVE R11
         BALR  R11,0
         USING *,R11
         USING @STRSAVE,R13
         LR    R6,R14                  KEEP ADDRESS OF PARMLIST OFFSET
         USING @STRPARM,R6
         SLR   R0,R0
         ICM   R0,B'0011',0(R6)        PICK UP PARM LIST OFFSET
         ALR   R6,R0                   GET PARM LIST ADDRESS
         BAL   R14,SCON2A1H            GET FIELD ADDRESS
         LR    R4,R1                   KEEP ADDRESS OF "INTO" FIELD
         BAL   R14,SCON2A2             GET FIELD LENGTH
         CR    R1,R4                   UPPER ADDR?
         BL    @STR282                 NO, JUMP
         SR    R1,R4                   CALCULATE LENGTH
@STR282  LR    R5,R1                   KEEP LENGTH OF "INTO" FIELD
.*******************************************************************
.*       MOVE FIELDS TO OUTPUT AREA                               *
.*******************************************************************
         LA    R6,PARMFLAG             POINT TO 1ST FIELD DESC
.*LOOP
@STR310  CLI   PARMSCON,X'E0'          CHECK FOR %TIME
         BE    @STR380                 JUMP IF %TIME
         BAL   R14,SCON2A1             GET ADDRESS
         LR    R2,R1                   KEEP ADDRESS
         BAL   R14,SCON2A2             GET LENGTH
         CR    R1,R2                   UPPER ADDR?
         BL    @STR312                 NO, JUMP
         SR    R1,R2                   CALCULATE LENGTH
@STR312  LR    R3,R1                   KEEP LENGTH
         TM    PARMFLAG,PARMPACK       CHECK CONVERSION TYPE
         BO    @STR330                 JUMP IF HEX STRING
         TM    PARMFLAG,PARMREG        CHECK CONVERSION TYPE
         BO    @STR335                 JUMP IF REGISTER
         TM    PARMFLAG,PARMHEX        CHECK CONVERSION TYPE
         BO    @STR360                 JUMP IF HEX STRING
         TM    PARMFLAG,PARMBIN        CHECK CONVERSION TYPE
         BZ    @STR370                 JUMP IF NO CONVERSION REQ'D
.*BINARY VARIABLE: R3 CONTAINS THE ICM MASK (1 3 7 F)
@STR320  SLR   R0,R0
         EX    R3,M320ICM              LOAD THE BINARY VARIABLE
         B     @STR340                 EDIT R0 VALUE
M320ICM  ICM   R0,B'0000',0(R2)        LOAD A BINARY VARIABLE
.*PACKED FIELD
@STR330  LR    R15,R2                  FIRST BYTE OF PACKED FIELD
         BALR  R14,0
         TM    0(R15),X'0C'            IS IT THE LAST ONE?
         LA    R15,1(,R15)             NEXT BYTE
         BNOR  R14                     LOOP
         SLR   R15,R2                  GET LENGTH OF PACKED FIELD
         BCTR  R15,0
         EX    R15,M330ZAP             EXECUTE ZAP
         B     @STR341                 EDIT DWD
M330ZAP  ZAP   @STRDWD,0(,R2)          MOVE TO @STRDWD
.*REGISTER
@STR335  LH    R2,PARMSCON             RELOAD FOR (R0)
         SLL   R2,2(0)                 MULTIPLY REG NUMBER BY 4
         STM   R7,R12,48(R13)          MAKE IT LOOK NORMAL
         LA    R2,20(R2,R13)           POINT TO REGISTER SLOT
         LA    R3,0004(0,0)            LENGTH FOR HEX CONVERSION
         TM    PARMFLAG,PARMHEX        CHECK CONVERSION TYPE
         BO    @STR360                 JUMP IF HEX STRING
         L     R0,0(,R2)               LOAD THE REGISTER VALUE FOR EDIT
.*EDIT @STRDWD
@STR340  CVD   R0,@STRDWD              CONVERT VALUE TO DECIMAL
@STR341  IC    R0,PARMLEN2             OUTPUT LENGTH
         LA    R3,X'003F'              MASK FOR "AND"
         NR    R3,R0                   OUTPUT LENGTH
         TM    PARMLEN2,PARMLEFT       CHECK JUSTIFICATION
         BO    @STR350                 JUMP IF LEFT JUSTIFICATION
         UNPK  @STRWK16(16),@STRDWD    UNPACK
         OI    @STRWK16+15,C'0'        SUPPRESS SIGN
         TM    PARMLEN2,PARMZERO       CHECK LEADING CHARS
         BO    @STR345                 JUMP IF LEADING ZEROES REQ'D
         MVC   @STRWK16(16),@STRHEX    EDIT MASK
         ED    @STRWK16(16),@STRDWD    ZONED DECIMAL
@STR345  CR    R5,R3                   SUBTRACT LEN FROM REMAINING LEN
         BNL   @STR346                 JUMP IF LARGE ENOUGH
         LR    R3,R5                   TRUNCATE TO REMAINING LENGTH
@STR346  LA    R2,@STRWK16+16          FIRST POSITION AFTER STRING
         SR    R2,R3                   FIRST STRING POSITION
         B     @STR390                 MOVE STRING TO OUTPUT LINE
@STRHEX  DC    X'4020202020202020,2020202020202120'
.*L
@STR350  MVC   @STRWK16(16),@STRHEX    EDIT MASK
         LA    R1,@STRWK16+15          PREVENT BAD R1
         EDMK  @STRWK16(16),@STRDWD    ZONED DECIMAL
         LR    R2,R1                   FIRST STRING POSITION
         LTR   R3,R3                   CHECK OUTPUT LENGTH
         BNZ   @STR353                 JUMP IF NOT ZERO
         LA    R3,@STRWK16+16          FIRST POSITION AFTER STRING
         SR    R3,R2                   COMPUTE STRING LENGTH
         B     @STR390
.*L0
@STR353  CR    R5,R3                   SUBTRACT LEN FROM REMAINING LEN
         BNL   @STR354                 JUMP IF LARGE ENOUGH
         LR    R3,R5                   TRUNCATE TO REMAINING LENGTH
@STR354  SR    R5,R3                   COMPUTE REMAINING LENGTH
         LR    R14,R4                  POINTER IN OUTPUT LINE
         LR    R15,R3                  LENGTH WITH PADDING
         LA    R3,@STRWK16+16          FIRST POSITION AFTER STRING
         SR    R3,R2                   COMPUTE STRING LENGTH
         O     R3,@STRPAD              PAD WITH BLANKS
         B     @STR392                 MOVE FIELD TO OUTPUT LINE
.*
.*       HEX STRING
.*
@STR360M MVC   @STRDWD(*-*),0(R2)      PREVENT S0C4 IN UNPK BELOW
@STR360  LTR   R3,R3                   ZERO LENGTH?
         BZ    @STR398                 YES, IGNORE IT
         LA    R0,0008(0,0)            MAX LENGTH
         CLR   R3,R0                   CHECK LENGTH
         BNH   @STR361                 JUMP IF LE 8
         LR    R3,R0                   TRUNCATE TO MAXIMUM LENGTH
@STR361  BCTR  R3,0
         EX    R3,@STR360M             MOVE DATA TO SAFE STORAGE
         UNPK  @STRWK16+00(9),@STRDWD+0(5) EXPAND SOURCE BYTES FOR "TR"
         UNPK  @STRWK16+08(9),@STRDWD+4(5) EXPAND SOURCE BYTES FOR "TR"
         LA    R2,@STRWK16
         LA    R3,2(R3,R3)             NUMBER OF OUTPUT BYTES
         NI    0(R2),X'0F'             KEEP DIGITS ONLY
         MVZ   1(15,R2),0(R2)          KEEP DIGITS ONLY
         TR    0(16,R2),@STRHEXT       =C'0123456789ABCDEF'
.*
.*       TRUNCATE CHARACTER STRING
.*
@STR370  CLI   PARMLEN2,PARMLEFT       CHECK JUSTIFICATION, OUTPUT LEN
         BNE   @STR390                 NO STRING TRUNCATION, JUMP
         LA    R1,0(R3,R2)             FIRST BYTE AFTER FIELD
@STR372  BCTR  R1,0                    DOWN 1 BYTE                 LOOP
         CLI   0(R1),C' '              IS IT A SPACE ?             LOOP
         BNE   @STR390                 LAST NON-BLANK BYTE         LOOP
         BCT   R3,@STR372              LOOP UNTIL 1ST BYTE         LOOP
         B     @STR398                 BLANK FIELD, DO NOT EDIT
@STRHEXT DC    C'0123456789ABCDEF'
.*
.*       %TIME
.*
@STR380  TIME  DEC                     GET HHMMSSHH
         ST    R0,@STRDWD              STORE HHMMSSHH
         MVC   @STRWK16(13),@STRTIME   MOVE EDIT MASK
         ED    @STRWK16(13),@STRDWD    EDIT HH:MM:SS:HH
         LA    R2,@STRWK16+1           WORK AREA
         LA    R3,012(0)               HH:MM:SS:HH+ SPACE
         B     @STR390
@STRTIME DC    X'4021207A20207A20207A20204000'    0X.XX.XX.XX
.*MOVE
@STR390  CR    R5,R3                   COMPARE REM. LEN TO CURR LEN
         BNM   @STR391                 JUMP IF POSITIVE OR ZERO
         LR    R3,R5                   TRUNCATE TO REMAINING LENGTH
@STR391  SR    R5,R3                   COMPUTE REMAINING LENGTH
         LR    R14,R4                  POINTER IN OUTPUT LINE
         LR    R15,R3                  PASS REMAINING LENGTH
@STR392  MVCL  R14,R2                  MOVE FIELD TO OUTPUT LINE
         LR    R4,R14                  NEW POINTER IN OUTPUT LINE
@STR398  TM    PARMFLAG,PARMLAST       TEST LAST-ENTRY INDICATOR
         LA    R6,PARMNEXT             BUMP UP TO NEXT ENTRY
         BNO   @STR310                 PROCESS NEXT ENTRY
.*ENDLOOP
.*
.*       END-OF-LINE PROCESSING
.*
         L     R1,@STRPAD              DEST IS A FIELD
         MVCL  R4,R0                   PAD WITH BLANKS
         L     R11,8(,R13)             RESTORE R11
         STM   R7,R12,48(R13)          MAKE IT LOOK NORMAL
         LM    R14,R6,12(R13)
         OI    15(R13),1               SIMULATE "T" OPTION
         B     2(,R14)                 RETURN TO CALLER
@STRPAD  DC    A(X'40000000')          PADDING
.*******************************************************************
.*             CONVERT S-CON TO FULL ADDRESS IN R1
.*******************************************************************
SCON2A1  TM    PARMFLAG,PARMLIT        IS IT A FIELD OR A LITERAL?
         BO    SCON2A50                PROCESS OFFSET IF A LITERAL
SCON2A1H LA    R15,PARMSCON            RESOLVE FIRST SCON   (ADDR)
         B     SCON2A10                PROCESS S-CON IF A FIELD
SCON2A2  LA    R15,PARMFLEN            RESOLVE SECOND S-CON (LEN)
SCON2A10 TM    0(R15),X'F0'            CHECK BASE REG
         BZ    SCON2AR0                RBASE IS R0
         SLR   R0,R0                   SEC. ENTRY POINT W/ R15 SET
         ICM   R0,B'0011',0(R15)       R0 = 0000BDDD
         SRDL  R0,12(0)                R0 = 0000000B, R1= BBB.....
         SRL   R1,20(0)                R1 = 00000DDD DISPLACEMENT
         CLI   0(R15),X'70'            R7-R13?
         BL    SCON2A12                NO, JUMP
         TM    0(R15),X'D0'            CHECK BASE REG VALUE
         BO    SCON2A13                JUMP IF BASE REG IS R13
         STM   R7,R12,48(R13)          STORE R7-R12
         MVC   64(4,R13),8(R13)        STORE R11
SCON2A12 LR    R15,R0                  R15= 0000000B BASE
         SLL   R15,2(0)                R15= 000000BB BASE * 4
         AR    R15,R13                 ADD CALLER'S SAVE AREA ADDR
         A     R1,20(,R15)             ADD BASE REG VALUE TO DISPL
         LA    R1,0(,R1)               CLEAR HI-ORDER BIT/BYTE
         BR    R14
SCON2A13 AR    R1,R13                  ADD CALLER'S SAVE AREA ADDR
         BR    R14
SCON2AR0 LH    R1,0(,R15)              PICK UP 12-BIT ADDRESS
         LTR   R1,R1                   CHECK FOR 0(R0)
         BNZR  R14                     GOBACK IF NOT X'0000'
         L     R1,20(,R13)             PICK UP R0 SLOT
         BR    R14                     GOBACK IF BASE REG IS ZERO
SCON2A50 SLR   R1,R1
         ICM   R1,B'0011',PARMSCON     LOAD LITERAL OFFSET
         LA    R1,PARMSCON(R1)         CONVERT OFFSET TO FULL ADDRESS
         BR    R14
.**********************************************************************
@STRSAVE DSECT                         24-BYTE WORK AREA
         DS    A(0,@STRSAVE,@STRSAVE,14,15,0,1,2,3,4,5,6)
@STRWK16 DS    F'7,8,9,10'             WORK AREA
@STRDWD  DS    D'1112'                 WORK AREA
@STRPARM DSECT
PARMSCON DS    S                   +0  FIELD ADDRESS
PARMFLEN DS    S                   +2  FIELD LENGTH
PARMFLAG DS    B                   +4  FORMAT, FLAGS
PARMLAST EQU   X'80'                     LAST ENTRY
PARMLIT  EQU   X'40'                     LITERAL, PARMSCON IS AN OFFSET
.*             X'3F'                   CONVERSION REQUIRED
PARMHEX  EQU   X'08'                     HEXADECIMAL
PARMBIN  EQU   X'04'                     BINARY
PARMPACK EQU   X'02'                     PACKED
PARMREG  EQU   X'01'                     REGISTER
PARMLEN2 DS    B                   +5  FORMAT, OUTPUT LENGTH
PARMLEFT EQU   X'80'                     LEFT JUSTIFICATION
PARMZERO EQU   X'40'                     LEADING ZEROES
.*             X'3F'                     OUTPUT LENGTH, 0 MEANS TRUNC.
PARMNEXT EQU   *                   +6
$LTORG   LOCTR
         AIF   (D'BLANKS).MEND
BLANKS   DC    &$_MAXBL.C' '       A BUNCH OF BLANKS
.MEND    AIF   ('&PRINT' EQ 'NOGEN').MEND99
         POP   PRINT
.MEND99  MEND
**********************************************************************
TESTPGM  START X'E010'
         BALR  R12,0
         USING *,R12
         OPEN  (SYSPRINT,OUTPUT)
         STRING 'CVTPTR=X''',(CVTPTR,4,X),'''',INTO=XXX
         PUT   SYSPRINT,XXX
         L     R1,CVTPTR
         STRING 'CVTDATE=',(56(R1),P),INTO=XXX
         PUT   SYSPRINT,XXX
         LA    R0,1000
         LA    R3,0033
         STRING 'D1=/',D1,'/,WWWW=/',WWWW,'/',                         X
               ((R3),,L),'/',((R3),,X),'/',((R0),,L),INTO=XXX
         PUT   SYSPRINT,XXX
         STRING WWWW,                                                  X
               (4(R13),4,X),'''',(4(R13),F),'''',                      X
               (4(R13),F,L),'''',                                      X
               (4(R13),F,L11),'''',                                    X
               (4(R13),F,Z9),'''',                                     X
               INTO=XXX
         PUT   SYSPRINT,XXX
         STRING %TIME,D1,'B12345678B',5X,(CTR1,P),1X,PARM1,1X,PARM2,   X
               INTO=XXX
         PUT   SYSPRINT,XXX
         STRING INTO=XXX,'CCC1234A',(D1,(R3))
         PUT   SYSPRINT,XXX
         STRING 'DDN2(',(D1,,T),')',INTO=XXX
         PUT   SYSPRINT,XXX
.EXIT    SLR   R15,R15
         SVC   3                     GOBACK
D1       DC    C'D1-----D1    '
WWWW     DC    C'WWWW'
CTR1     DC    P'1'
PARM1    DC    C'          '
PARM2    DC    C'          '
XXX      DS    CL132
*LANKS   DC    CL132' '
CVTPTR   EQU   0016,4,C'A'
         STRING FINAL_CALL
SYSPRINT DCB   DSORG=PS,DDNAME=SYSPRINT,MACRF=PM,RECFM=FB,LRECL=121
         YREGS
         END
//SYSPRINT DD SYSOUT=*
//SYSLIB   DD DSN=SYS1.MACLIB,DISP=SHR
//SYSUT1   DD UNIT=SYSDA,SPACE=(CYL,2)
//SYSLIN   DD UNIT=SYSDA,SPACE=(TRK,1),DISP=(,PASS),DCB=BLKSIZE=3120
//*
//GO      EXEC PGM=LOADER,PARM=NOPRINT
//SYSLIN   DD DSN=*.ASMH.SYSLIN,DISP=(OLD,DELETE)
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*