STRING R203 - March 1989 |
 |
* 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=*