AGO .START ABCDV --MVC--
ABCDVE MVCD
ABCDVE
ALL THIS HERE MVI MVC
CRUD IS CLC MVC
TEST DATA. CLI MVC
ST MVC
MVC
CLC MVC
ABCDV MVC CLI EQ TXQ MVC RTM
C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTR
SET PA="LIST,IF=(5,EG,C'ABC',C'DEF'),E=(9,0,C'MVC',C'XYZ') "
SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTR
SET IN=%G%.PRN
SET OUT=%G%.OUTPUT.OUT.TXT
SET SYSPRINT=%G%.OUTPUT.SYSPRINT.TXT
ASMLG %G%.MLC TIME(1) PARM(%PA%)
SET PA="LIST,TEST,SYSIN,IF=(2,22,C'ABC',ERROR )
SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTR
SET IN=%G%.MLC
SET SYSIN=%G%.TEST.ERROR.TXT
SET OUT=%G%.OUTPUT.OUT.TXT
SET SYSPRINT=%G%.OUTPUT.SYSPRINT.ERR.TXT
EZ390 %G%.MLC TEST PARM(%PA%)
IF=(1,XX,C'ABC')
IF=(AB,0,C'ABC')
IF=(1,EQ,E'RROR')
IF=(1,NE,C'ABC',ERR)
IF=(1,GT,C'ABC',2,GE,P'ABC')
IF=(1,LT,C'ABC',2,LE,X'ERTT')
IF=(1,1,C'ABC',C'DEF',C'',C'GHI')
IF=(1,0,P'1233454567890123345789')
IF=(1,0,C'SDFLKJASDFLKJSDFOIUREWLJHADSIURWE'
IF=(1,0,C'DONE')
SET LISTING=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTR.PRN
SET ATFILE=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTR.BREAK.ATFILE.TXT
SET COMMANDS=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTR.BREAK.COMMANDS.TXT
SET SYSIN=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTR.BREAK.SYSIN.TXT
EZ390 C:\USERS\LIN\DOCUMENTS\Z390CODE\QBR.MLC PARM(SYSIN)
LABEL=PRINTR2,ERR*,MSG*,Z,ZS,GETMAIN,TRY*,SET*,SAV*,QFREQ,QS1*,QS9*
LABEL=TES*,EDIT0*,GETIN,WRITOUT,
LABEL=AGETMAIN,CARD,LINE,
COMMAND=
COMMAND=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTR ASMLG
COMMAND=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTRT EZ390
COMMAND=C:\USERS\LIN\DOCUMENTS\Z390CODE\SCANSTRB BK PTS
COMPRESS=Y
---------- SAMPLE JCL ------ I EXPECT THE PGM NAME WILL CHANGE ------
CC
//LIST EXEC PGM=SCANSTR,PARM='LIST IF=(5,EQ,C"ABC") LIST RECORDS
//STEPLIB DD DISP=SHR,DSN=
//SYSPRINT DD SYSOUT=*
//IN DD DISP=SHR,DSN=...
//LIST EXEC PGM=SCANSTR, LIST WHAT CHANGES WOULD BE
// PARM='LIST,IF=(5,EQ,C"ABC"),EDIT=(1,0,C"ABC",X"C1C2C3") '
//STEPLIB DD DISP=SHR,DSN=
//SYSPRINT DD SYSOUT=*
//IN DD DISP=SHR,DSN=...
//UPDATE EXEC PGM=SCANSTR, MAKE CHANGES TO THE FILE
// PARM='UPDATE,IF=(5,EQ,C"ABC"),EDIT=(1,0,P"1234",X"01234F") '
//STEPLIB DD DISP=SHR,DSN=
//SYSPRINT DD SYSOUT=*
//IN DD DISP=SHR,DSN=...
//OUT DD DISP=(,CATLG),DSN=...
----------- THE PARM CAN BE MORE COMPLICATED -----------------------
FOR TESTING, AND THE DESCRIPTION, I USED THIS PGM 4 DATA.
YOU CAN USE EITHER SINGLE OF DOUBLE QUOTES,
OR, IN FACT, JUST ABOUT ANYTHIONG YOU'D LIKE
IF= AND EDIT= CAN BE CODED I= E=
IF= CAN HAVE MULTIPLE ENTRIES, ANY ONE OF WHICH
MAKES THE PARAM TRUE. UNLESS
IFALL= IS CODED, IN WHICH CASE, ALL MUST BE TRUE
IF=(LOC,LEN/BRANCH.COND,STRING,STRING,STRING)
ALL STRINGS USE THE SAME LOC/LEN REQUEST, UNLESS..
IF=(2,EQ,C'AB',4,NE,C'CD',6,6,C'EFGH',C'IJK')
PARM='LIST,IF=(1,0,C"ABCDV",C"MVC",X"8899AA",EDIT=(1,0,C"MVC",C"CLC"'
PARM='LIST,I=(1,0,C"ABC",5,EQ,P"00012",X"D1D2D3"),E=(9,NE,C"EQ",C"XX")
.START ANOP
* -------------------------------------------
MACRO
&LBL CAL &RTN
&LBL L 15,=A(&RTN)
BALR 14,15
MEND
*
MACRO
&LBL BEG ,
DS 0D
PUSH USING
USING *,10
&LBL B 12(15)
DC 2F'0'
ST 14,4(15)
ST 10,8(15)
LR 10,15
MEND
*
MACRO
&LBL RET ,
&LBL L 14,4(10)
L 10,8(10)
BR 14
POP USING
LTORG
MEND
* -------------------------------------------
MACRO
&LBL $$LA &R,&F
AIF ('&F'(1,1) EQ '(').ADD0
&LBL LA &R,&F
MEXIT
.ADD0 ANOP
&LBL LA &R,0&F
MEND
* -------------------------------------------
MACRO
&LBL MSG &MSG
&LBL BAL 1,MSG
MAKEMSG &MSG
MEND
*
MACRO
&LBL MSGRC8 &MSG
&LBL BAL 1,MSGRC8
MAKEMSG &MSG
MEND
*
MACRO
&LBL ERR &B,&MSG
&LBL REVB &B,SYS&SYSNDX
BAL 1,ERR
MAKEMSG &MSG
SYS&SYSNDX DS 0H
MEND
*
MACRO
MAKEMSG &MSG
LCLA &A,&B
&A SETA K'&MSG
&B SETA (&A-1)/2*2
MNOTE ,'# CHARS IN MSG = &A CL&B IS GOOD'
.* DC AL1(L'SYS&SYSNDX-1)
DC AL1(&B-1),CL&B&MSG
.* SYS&SYSNDX DC CL&B&MSG
MEND
* -----------------------------------------------------------
MACRO
&LABEL REVB &COND,&TO
LCLC &C,&B
LCLA &LEN
AIF ('&COND' NE 'B').ADDREM
&LABEL NOP &TO
MEXIT
.ADDREM ANOP
&LEN SETA K'&COND
AIF ('&COND'(2,1) NE 'N').ADD
&B SETC '&COND'(3,&LEN-2)
AGO .DOIT
.ADD ANOP
&B SETC '&COND'(2,&LEN-1)
&B SETC 'N&B'
.DOIT ANOP
&LABEL B&B &TO
MEND
* -----------------------------------------------------------
MACRO
&LBL QCODE &TYPE,&MSG,&OPCODE=0(R3),&GOTO=QS03 GETSYSIN
LCLA &N
LCLC &L
&A SETA &SYSNDX
&L SETC 'SYS&A'
&LBL $$LA 15,&OPCODE
BAL 1,&L.A
DC C&TYPE,C' '
&L.A CLC 0(1,R1),0(R15)
BE &L.Z
LA R1,1(R1)
CLI 0(R1),C' '
BNE &L.A
BAL R1,ERR
MAKEMSG &MSG
&L.Z DS 0H
MEND
* -----------------------------------------------------------
SCANSTR START 0
YREGS
BR EQU 9
USING *,13 ,12
STM 14,12,12(13)
ST 13,4(15)
ST 15,8(13)
LR 13,15
LA R11,4095
LA 12,1(11,13)
LA 11,1(11,12)
SR R3,R3
L R1,0(R1)
LH R2,0(R1)
SH R2,=H'1'
ERR BM,'PARM MISSING, REQUIRED'
MVC CARD(0),2(R1)
EX R2,*-6
MSG ' SCANSTR V00.00 ASM &SYSDATE AT &SYSTIME WRITTEN BY LX
IN LYONS AT THE METHUSELISTIC AGE OF 81'
*
OPEN LA R2,IN
BAL R9,OPENIN
*
MVC 0(4,R13),BRESTART
BAL R9,GETMAIN
* ------------------------------------------------------------------
CAL QSYSIN
SR R10,R10
B GETIN
*
AP #UPDATES,=P'1'
WRITOUT L R0,BUFFER1
CLI FUNCTION,C'L'
BE WRITOUTL
TM DCBOFLGS-IHADCB+OUT,DCBOFOPN
BO *+12
LA R2,OUT
BAL R9,OPENOUT
*
L R0,BUFFER1
PUT OUT,(0)
AP #OUT,=P'1'
B GETIN
WRITOUTL PUT SYSPRINT,(0)
AP #OUT,=P'1'
B GETIN
*
GETIN L R3,BUFFER1
GET IN,(3)
LA R10,1(R10)
AP #IN,=P'1'
LH R1,DCBLRECL-IHADCB+IN
A R1,BUFFER1
ST R1,ENDREC
MVI 0(R1),0
MVC 1(256,R1),0(R1)
MVI YESNO,C' '
L R8,AGETMAIN
LA R7,LDSECT1(R8)
MVI LDSECT2(R7),X'FF'
B TESTIF
* -------------------------------------------------
BRESTART B RESTART
*
CLOSE TM DCBOFLGS-IHADCB(R2),DCBOFOPN
BZR R9
CLOSE ((2))
MVC LINE+2(8),DCBDDNAM-IHADCB(R2)
MVC LINE+11(6),=C'CLOSED'
BAL R14,PRINTLIN
* PUT SYSPRINT,LINE-1
BR R9
LR R14,R9
* B PRINTLIN
BAL R14,PRINTLIN
*
ED9 DC X'402020206C2020206B202120'
Z SR R3,R3
MVC ERRGOTO,=A(ZZZ)
CLI FUNCTION,C'L'
BNE *+8
BAL R14,PUTBLANK
LA R2,=A(#IN,#UPDATES,#OUT,0)
L R1,0(R2)
Z## MVC LINE(L'ED9),ED9
ED LINE(L'ED9),3(R1)
MVC LINE+L'ED9+1(16),8(R1)
* PUT SYSPRINT,LINE-1
BAL R14,PRINTLIN
LA R2,4(R2)
L R1,0(R2)
LTR R1,R1
BNZ Z##
MVC LINE,LINE-1
*
ZZ LA R2,SYSIN
BAL R9,CLOSE
LA R2,IN
BAL R9,CLOSE
LA R2,OUT
BAL R9,CLOSE
PUSH PRINT
PRINT NOGEN
CLOSE (SYSPRINT)
POP PRINT
*
ZZZ SR 15,15
IC 15,RC
L 13,4(13)
L 14,12(13)
LM 0,12,20(13)
BR 14
*
PUSH PRINT
PRINT NOGEN
USING IHADCB,2
OPENIN TM DCBOFLGS,DCBOFOPN
BOR R9
MVC OPENMSGM+1(8),DCBDDNAM
OPEN ((2),INPUT)
B OPENMSG
* DC AL1(L'OPENMSGM)
OPENMSGM DC C' ........ OPENED, RECFM=.. LRECL=..... BLKSIZE=..... '
OPENOUT TM DCBOFLGS,DCBOFOPN
BOR R9
MVC OPENMSGM+1(8),DCBDDNAM
OPEN ((2),OUTPUT)
POP PRINT
*
OPENMSG UNPK OPENMSGM+24(3),DCBRECFM(2)
TR OPENMSGM+24(3),HEX-240
MVI OPENMSGM+26,C' '
LH R0,DCBLRECL
CVD R0,DW
OI DW+7,X'0F'
UNPK OPENMSGM+33(5),DW+5(3)
LH R0,DCBBLKSI
CVD R0,DW
OI DW+7,X'0F'
UNPK OPENMSGM+47(5),DW+5(3)
MVC LINE+1(L'OPENMSGM),OPENMSGM
B PRINTLIN
* BAL R14,PRINTLIN
* LA R1,OPENMSGM-1
* BAL R14,MSG
BR R9
* -------------------------------------------------
DC 4F'0'
MSGRC8 OI RC,8
MSG STM R14,1,MSG-20
MVC LINE(10),=C' (....)'
** OI ERRRET+1,X'F0'
TM DCBOFLGS-IHADCB+SYSPRINT,DCBOFOPN
BO ERRSR15
PUSH PRINT
PRINT NOGEN
OPEN (SYSPRINT,OUTPUT)
POP PRINT
LM R14,R1,MSG-20
B ERRSR15
ERR STM R14,1,MSG-20
MVC LINE(10),=C'ERR (....)'
** NI ERRRET+1,X'7F'
OI RC,8
ERRSR15 SR R15,R15
IC R15,0(R1)
LA R14,3(R1,R15)
ST R14,MSG-20
LR R0,R1
SR R0,R13
ST R0,12(R13)
UNPK LINE+5(5),14(3,R13)
TR LINE+5(4),HEX-240
MVI LINE+9,C')'
MVC LINE+11(0),1(R1)
EX R15,*-6
LTR R3,R3
BZ ERRPUT
LA R15,LINE+15(R15)
MVC 0(30,R15),0(R3)
ERRPUT TM DCBOFLGS-IHADCB+SYSPRINT,DCBOFOPN
BO ERRPUTP
PUSH PRINT
PRINT NOGEN
OPEN (SYSPRINT,OUTPUT)
POP PRINT
ERRPUTP CLC SPACES(2),LINE+11
BNE *+10
MVC LINE,LINE+11
B PUTPUT
PUTBLANK LA R1,SPACES
STM R14,R1,MSG-20
PUTPUT PUT SYSPRINT,LINE-1
CLI FLAGWTO,C'W'
BNE ERRCLR
MVC LINE-5(4),=X'00800000'
WTO MF=(E,LINE-5)
MVC LINE-5(4),SPACES
ERRCLR MVC LINE,LINE-1
SP ERR#,=P'1'
BP *+8
EX 0,*
CLC =C'TS',FLAGTEST
BE TESTGET
LM R14,R1,MSG-20
CLI 1(R1),C' '
ERRRET BER R14
L R15,ERRGOTO
BR R15
ERRGOTO DC A(Z)
ERR# DC PL2'99'
* -------------------------------------------------
GETMAIN L R0,LGETMAIN
LH R1,DCBLRECL-IHADCB+IN
LA R1,1000(R1)
AR R0,R1
LR R2,R1
AR R0,R2
STM R0,R2,LGETMAIN
GETMAIN R,LV=(0)
LR R14,R1 R14=BEG OF GETMAIN
LR R15,R1 R15=PAST CONTOL CARDS=BUFFER1
A R15,AGETMAIN
LR R0,R15 R0=PAST BUFFER1=BUFFER2
A R0,AGETMAIN+4
STM R14,R0,AGETMAIN
BR R9
* -------------------------------------------------
DC 4F'0'
PRINTR3 MVC LINE(90),0(R3)
PRINTLIN STM R14,R1,PRINTR3-16
TM DCBOFLGS-IHADCB+SYSPRINT,DCBOFOPN
BO PRINTLIP
PUSH PRINT
PRINT NOGEN
OPEN (SYSPRINT,OUTPUT)
POP PRINT
PRINTLIP LA R0,LINE-1
CLI FLAGTEST,C'T'
BNE PRINTLIQ
L R14,PRINTR3-16
SR R14,R13
ST R14,12(R13)
MVC LINE-8(8),SPACES
UNPK LINE-6(5),14(3,R13)
TR LINE-6(4),HEX-240
MVI LINE-2,C')'
MVI LINE-7,C'('
LA R0,LINE-8
PRINTLIQ PUT SYSPRINT,(0)
CLI FLAGWTO,C'W'
BNE CLRLINE
MVC LINE-5(4),=X'00550000'
WTO MF=(E,LINE-5)
CLRLINE MVC LINE-8,LINE-9
LM R14,R1,PRINTR3-16
BR R14
* -------------------------------------------------
GETR3#SP MVI GETR3F,C' '
B GETR3A
GETR3#CO MVI GETR3F,C','
B GETR3A
GETR3# MVI GETR3F,C'Z'
GETR3A CLI 0(R3),C'0'
BNL GETR3T
MSGRC8 'BAD NUMERIC'
L R14,ERRGOTO
BR R14
*
* SR R0,R0
* GETR3IC IC R15,0(R3)
* N R15,=F'15'
* MH R0,=H'10'
* AR R0,R15
* LA R3,1(R3)
* CLI 0(R3),C'0'
* BNL GETR3IC
* CVD R0,DW
* LR R1,R3
* LA R3,1(R3)
*
GETR3T TRT 0(9,R3),TESTNUM
ERR BZ,'NUMERIC FIELD ERR'
LR R2,R1
SR R2,R3
BCTR R2,0
EX R2,GETR3PK
CVB R0,DW
LA R3,1(R1)
*
CLI GETR3F,C'Z'
BER R14
CLC GETR3F,0(R1)
BER R14
ERR B,'INVALID #'
*
GETR3F DC C' '
GETR3PK PACK DW,0(0,R3)
* -------------------------------------------------
USING DSECT,8
USING DSECTION,7
*
RESTART L R3,BUFFER1
L R8,AGETMAIN
LA R7,LDSECT1(R8)
*
TESTIF L R4,BUFFER1 FIRST, SEE IF THE STRING WILL FIT
AH R4,DFROM INTO THE RECORD, OR RUN OVER THE END.
LH R15,DLEN STRING LENGTH-1
LA R1,1(R15) STRING LENGTH
*
L R5,ENDREC CALC LAST LOC THE STRING
SR R5,R1 WILL FIT
CR R5,R4
BL TESTIFN YES, TRY NEXT STRING
AH R5,DOFF
*
CLI DEQ,C'A' GOOD, Q. B EQ/NE/ETC
BNL TESTIFBC YES, GO DO THAT
*
SR R0,R0
IC R0,DCHAR CALC ADDR TO USE
L R14,=A(TRTTBL) FOR TRT
SR R14,R0 GOT TRT ADDRESS
B TESTIFLH AND GO DO TRT TEST
* ---------------------------- JUST COMPARE THE STRING AT THE LOC -----
CLC DSTRING(0),0(R4)
NOP TESTIFY YES, FOUND
TESTIFBC IC R1,DEQ+2
EX R15,TESTIFBC-10
EX R1,TESTIFBC-4
B TESTIFN NO, NOT FOUND
* ---------------------------- SCAN LOOKING FOR STRING -----------
CLC DSTRING+16(0),0(R1)
TESTICLC CLC DSTRING(0),0(R1)
LA R4,256(R4)
TESTIFLH LR R2,R5 END
SR R2,R4 -START
BNP TESTIFN
* ERR BNP,'LENGTH=0'
*
LA R6,12(R13) FOR PACKED FIELDS, WHERE THE CHAR IS
CLI DATATYP,C'P' EG, X'5F' THEN THE TRT WILL SEARCH
BNE NOTPACK FOR EITHER '5F' OR '5C',
TM DCHAR,X'0F' YEAH, IT'S HOKIE, BUT I DON'T SEE
BNO NOTPACK ANOTHER GOOD WAY. THE ALTERNATIVE IS
LR R6,R14 TO RISK A S0C7.
SH R6,=H'4' THEN THE CLC COMPARE WILL HAVE TO
NOTPACK DS 0H BE DONE TWICE.
*
CH R2,=H'256' Q. SHORTER THAN 256
BL TESTIFT YES, GO DO SHORT TRT
MVI 0(R6),C'P'
TRT 0(256,R4),0(R14) TEST 256
MVI 0(R6),0
BZ TESTIFLH-4 NO, BUMP START BY 256
TESTIFC LA R2,1(R1) (SAVE NEXT R4 BYTE)
SH R1,DOFF CALC BYTE TO COMPARE TO STRING
EX R15,TESTICLC COMPARE STRING
BE TESTIFY
CLI DATATYP,C'P'
BNE *+12
EX R15,TESTICLC-6 COMPARE STRING
BE TESTIFY
*
LR R4,R2
B TESTIFLH
*
TRT 0(0,R4),0(R14)
TESTIFT CR R4,R5 Q. END OF REC?
BNL TESTIFN YES, EXIT
MVI 0(R6),C'P'
EX R2,TESTIFT-6 NO, TRT FOR RARE BYTE
MVI 0(R6),0
BZ TESTIFN Q. FOUND? NO, DONE
B TESTIFC YES, GO DO COMPARE
* ------------- NO MATCH / NOT FOUND, IS THERE ANOTHER STRING ---------
TESTIFN MVI YESNO,C'N'
CLI FLAGALL,C'A'
BE TESTIFZ
LA R1,LDSECT2(R7) DIDN'T FIND STRING
C R1,DNEXT MAYBE THERE ARE 2,3 POSSIBLE
BNL TESTIFZ STRINGS. IF NOT, JUST EXIT
LR R7,R1
B TESTIF
* ------------------------- DO WE DO THE EDIT? -----------------------
TESTIFY MVI YESNO,C'Y'
CLI DOPCODE,C'E'
BE EDIT
CLI FLAGALL,C'A'
BNE TESTNXR8
L R7,LDSECT2(R7)
C R7,DNEXT
BL TESTIF
*
TESTNXR8 L R1,DNEXT
CLI 0(R1),X'FF'
BE TESTIFZ
LR R8,R1
LA R7,LDSECT1(R8)
B TESTIF
*
* TESTIED LR R6,R7
* LA R6,LDSECT2(R6)
* B EDIT
* L R1,LDSECT2(R6)
* C R1,DNEXT
* BL TESTIED+2
* BE *+8 R7=FROM STRING
* EX 0,* R2="EDIT TO" STRING
*
TESTIFZ CLI FUNCTION,C'U'
BE WRITOUT
CLI YESNO,C'Y'
BNE GETIN
CLI FLAGEDIT,C'E'
BNE GETIN
B WRITOUT
* ------------------------ EDIT ---------------------
EDIT LR R6,R7
EDIT01 LA R6,LDSECT2(R6)
LR R4,R1
LA R1,LDSECT2(R6)
C R1,DNEXT
BE EDITLH
CLI 0(R1),X'FF'
BNE EDIT01
EX 0,*
EDITLH LH R14,DLEN-DSECTION(R6)
LA R5,DSTRING-DSECTION(R6)
* R7 = 'FROM' STRING
* R6 = 'TO' STRING
* R15 = DLEN 'FROM' STRING
* R14 = DLEN 'TO' STRING
* R4 = STRING TO BE REPLACED
* R5 = REPLACEMENT STRING
*
MVC DW(1),DCBRECFM-IHADCB+IN
NI DW,X'C0'
CLI DW,X'40' Q. IS THIS A VB FILE?
BZ SKIPLLBB NO.
L R1,BUFFER1 YES, CREATE THE NEW LLBB
CLC =H'0',2(R1)
BNE SKIPLLBB
LH R0,0(R1)
AR R0,R14
SR R0,R15
STH R0,0(R1)
*
SKIPLLBB CR R14,R15
BE REPLACE REPLACE IS EASIEST, JUST MOVE STRING
BL SHORTER SIMILAR, BUT MOVE THE REST OF THE RECORD UP
BH LONGER
EX 0,*
* LONGER IS MORE WORK. SAVE END OF RECORD,
* MOVE STRING, THEN MOVE THE REST OF THE RECORD
* AFTER THE REPLACEMENT STRING.
* --------------------------------------------
MVC 0(0,R4),0(R5)
REPLACE EX R14,REPLACE-6
B WRITOUT-6
*
DC F'0'
MOVESTR L R3,ENDREC
SR R3,R1
LA R3,257(R3)
SRL R3,8
LR R0,R3
ST R0,MOVESTR-4
L R0,MOVESTR-4
MOVESTRL MVC 0(256,R2),0(R1)
LA R2,256(R2)
LA R1,256(R1)
BCT R0,MOVESTRL
BR R9
*
LONGER L R2,BUFFER2
LA R1,1(R4,R14)
BAL R9,MOVESTR
EX R14,REPLACE-6
L R1,BUFFER2
LA R2,1(R14,R4)
BAL R9,MOVESTRL-4
B WRITOUT-6
*
* L R1,BUFFER2
* LA R2,1(R4,R14)
* LR R3,R0
* BAL R4,MOVESTRL
* B WRITOUT-6
*
SHORTER EX R14,REPLACE-6
LA R1,1(R14,R4) R1=LOC TO MOVE REMAINING REC TO
LR R2,R15
SR R2,R14 R2=AMOUNT TO MOVE RECORD UP
LA R2,0(R1,R2)
MOVEUP MVC 0(256,R1),0(R2)
LA R1,256(R1)
LA R2,256(R2)
C R1,ENDREC
BL MOVEUP
B WRITOUT-6
* ---------------------------------------------------
*
LTORG
*
YESNO DC C' '
FUNCTION DC C' '
FLAGTEST DC 2C' '
FLAGEDIT DC C' '
FLAGWTO DC C' '
FLAGSEL DC C' '
FLAGALL DC C' '
RC DC X'00'
#R7 DC PL2'0'
HEX DC C'0123456789ABCDEF'
DS CL4
DW DC 2D'0'
DS CL4
#UPDATES DC PL8'0',CL16'RECORDS UPDATED'
BUFLENG DC A(0)
LGETMAIN DC F'2000'
AGETMAIN DC F'0'
BUFFER1 DC F'0'
BUFFER2 DC F'0'
ENDREC DC 2A(0)
DS CL4
ASYSIN DC A(0)
ESYSIN DC A(0)
SYSINTBE DS A(0)
DS CL4
ASELECT DC F'0'
ESELECT DC F'0'
ADCBS DS F'0'
DS CL4
#DCBS DC PL8'0',CL20'WRITE= FILES SET UP'
#GOTO DC PL8'0',CL20'GOTO= LINKS SET UP.'
DS CL4
STARTAT DC CL8' '
STOPAFT DC PL8'99999999999999'
DS CL4
*
TESTPACK DC 10X'00000000000000000001404040404040'
DC CL8' '
CARD DC 2CL133' '
*
DC CL9' '
LINE DC CL133' '
SPACES DC CL133' '
*
TESTNUM EQU *-240
DC 10X'00',6C' '
*
PUSH PRINT
PRINT NOGEN
*
OPENX DC 0F'0',X'85',AL3(OPENX+4)
CLI DCBRECFM-IHADCB(1),0 Q. BLANK DCB?
BNE 0(14) NO, JUST RETURN.
BAL 15,16(R15) LOAD A(DCB TO COPY FROM)
DC A(IN) AND COPY RECFM+LRECL.
L 15,0(15)
MVC DCBRECFM-IHADCB(1,1),DCBRECFM-IHADCB(15)
MVC DCBLRECL-IHADCB(2,1),DCBLRECL-IHADCB(15)
BR 14
*
DS 0D
DS CL8
SYSIN DCB DDNAME=SYSIN,DSORG=PS,MACRF=GM,LRECL=133,RECFM=FT,EODAD=ZS
DS CL8
IN DCB DDNAME=IN,DSORG=PS,MACRF=GM,LRECL=133,RECFM=FT,EODAD=Z
#IN DC PL8'0',CL16'RECORDS READ'
DS CL8
SYSPRINT DCB DDNAME=SYSPRINT,DSORG=PS,LRECL=133,RECFM=FT,MACRF=PM
DS CL8
OUT DCB DDNAME=OUT,DSORG=PS,LRECL=133,RECFM=FT,MACRF=PM
#OUT DC PL8'0',CL16'RECORDS WRITTEN'
* DC CL8' ',PL8'0',F'0'
POP PRINT
*
* DCB DDNAME=IN,DSORG=PS,DEVD=DA,MACRF=GL,BLKSIZE=32767,RECFM=U,EODAD=Z
*UT DCB DDNAME=OUT,DSORG=PS,DEVD=DA,LRECL=110,RECFM=FB,MACRF=PM
*
QSYSIN BEG ,
LA R3,CARD
BAL R14,PRINTR3
L R8,AGETMAIN
LA R7,LDSECT1(R8)
MVC 0(MDSECT,R8),ZEROS
LA R1,MDSECT(R8)
ST R1,DNEXT
ST R1,ESYSIN
MVI 0(R1),X'FF'
*
QS02 CLC =C'#IN=',CARD
BNE QS03
MVC CARD,CARD+4
BAL R14,GETR3#
MVC STOPAFT,DW
MVC CARD,0(R3)
LA R3,CARD
B QS02
QS03 CLC =C'LIST',CARD
BNE *+18
MVI FUNCTION,C'L'
MVC CARD,CARD+5
B QS02
CLC =C'TEST',CARD
BNE *+18
MVI FLAGTEST,C'T'
MVC CARD,CARD+5
B QS02
CLC =C'SYSIN',CARD
BNE *+18
MVI FLAGTEST+1,C'S'
MVC CARD,CARD+6
B QS02
CLC =C'UPDATE',CARD
BNE *+18
MVI FUNCTION,C'U'
MVC CARD,CARD+7
B QS02
*
CLC =C'TS',FLAGTEST
BNE *+10
MVC ERRGOTO,=A(TESTGET)
QCODE 'IE','BAD OPCODE, IF/EDIT'
B QS10
* -------------------------------------------------
TESTGET MVI CARD,C' '
QS10GET MVC DW,CARD
TM DCBOFLGS-IHADCB+SYSIN,DCBOFOPN
BO *+12
LA R2,SYSIN
BAL R9,OPENIN
QS10GETG MVC CARD,CARD-1
GET SYSIN,CARD
LA R3,CARD
BAL R14,PRINTR3
CLI CARD,C' '
BE QS10GETG
CLI DW,C' '
BNE QS10B
L R8,AGETMAIN
LA R7,LDSECT1(R8)
MVC 0(MDSECT,R8),ZEROS
B QS10
ZS MVC ERRGOTO,=A(ZZ)
MVI FLAGTEST+1,C' '
ERR B,' UNEXPECTED EOF ON SYSIN'
B Z
* -------------------------------------------------
QS10A LA R3,2(R3)
QS10B LA R0,LDSECT2(R7)
L R8,DNEXT
QS10C LA R7,LDSECT1(R8)
CR R8,R0
BE *+8
EX 0,*
MVC 0(MDSECT,R8),ZEROS
LA R1,MDSECT(R8)
ST R1,DNEXT
ST R1,ESYSIN
MVI 0(R1),X'FF'
B QS10
*
* RESTART LA R3,CARD
* L R8,AGETMAIN
* LA R7,LDSECT1(R8)
* MVC 0(MDSECT,R8),ZEROS
QS10 BAL R9,FIXKEYW CHANGE EDIT=( TO E=(
BAL R14,PRINTR3
QCODE 'IAE','BAD OPCODE IF/AND/OR/EDIT'
MVC DOPCODE,0(R3)
CLI 0(R3),C'E'
BNE *+8
MVI FLAGEDIT,C'E'
CLC =C'=(',1(R3)
ERR BNE,'KEY=(## SYNTAX ERROR'
LA R3,3(R3)
ZAP #R7,=P'1'
B QS11
*
QS11A LR R2,R7
LA R7,LDSECT2(R7)
MVC 0(LDSECT2,R7),ZEROS
LA R1,LDSECT2(R7)
ST R1,DNEXT
ST R1,ESYSIN
MVI 0(R1),X'FF'
AP #R7,=P'1'
CLI 0(R3),C'0'
BNL QS11
QCODE 'CPX','BAD DATA TYPE, C/P/X'
MVC DFROM(7),DFROM-DSECTION(R2)
B QS12
*
QS11 BAL R9,QLOCLEN
QS12 MVC DATATYP,0(R3)
LA R4,DLEN
BAL R9,QSTRING
*
LA R4,DCHAR
LA R2,DLEN
BAL R14,QFREQ
*
CLC =C'), ',0(R3)
BE QS10GET
CLC =C'),',0(R3)
BE QS10A
CLC =C') ',0(R3)
BE QS95
CLI 0(R3),C','
ERR BNE,'CONTINUATION ERR'
LA R3,1(R3)
BNL QS11A
* -------------------------------- LOC LEN / EQ/NE/GT/ETC ---------
QLOCLENC LA R7,LDSECT2(R7)
LA R1,LDSECT2(R7)
ST R1,DNEXT
ST R1,ESYSIN
MVC 0(LDSECT2,R7),ZEROS
MVI LDSECT2(R7),X'FF'
QLOCLEN BAL R14,GETR3#
SH R0,=H'1'
ERR BM,'MINIMUM LOC=1, NOT 0'
STH R0,DFROM
CLI 0(R3),C'0'
BL TRYEQNE
BAL R14,GETR3#
SH R0,=H'1'
BNM *+8
LH R0,DCBLRECL-IHADCB+IN
SH R0,DFROM
BCTR R0,0
STH R0,DTO
BR R9
*
TRYEQNET DC C'EQ',X'80',C'NE',X'70'
DC C'GE',X'B0',C'GT',X'20'
DC C'LE',X'D0',C'LT',X'40',C' '
*
TRYEQNE LA R1,TRYEQNET
CLC 0(2,R1),0(R3)
BE TRYEQNEF
LA R1,3(R1)
CLI 0(R1),C' '
BH TRYEQNE+4
ERR B,'LENGTH OR BRANCH COND BAD'
TRYEQNEF MVC DEQ(3),0(R1)
MVI DTO,X'FF'
CLI 2(R3),C','
ERR BNE,'NO COMMA AFTER BR COND'
LA R3,3(R3)
BR R9
* ----------------------------------- GET STRING ---------------
DC F'0'
QSTRING ST R9,QSTRING-4
QSTRING0 LA R1,2(R3)
CLC 0(1,R1),1(R3)
ERR BE,'DATA LENGTH=0'
QSTRING1 LA R1,1(R1)
CLC 1(1,R3),0(R1)
BE QSTRING3
CLC SPACES(19),0(R1)
BNE QSTRING1
ERR B,'STRING SPEC ERROR'
QSTRING3 ST R1,ANEXT --------- GOT CHAR STRING ------------
LR R15,R1
SR R15,R3
SH R15,=H'3'
STH R15,0(R4)
*
STM R14,R1,DW
LA R15,3(R15)
MVC LINE+7(0),0(R3)
EX R15,*-6
BAL R14,PRINTLIN
LM R14,R1,DW
*
CLI 0(R3),C'C'
BE QSTRCHAR
CLI 0(R3),C'X'
BE QSTRHEX
CLI 0(R3),C'P'
BE QSTRPACK
ERR B,'BAD DATA TYPE, C/X/P'
LONGSTR ERR B,'STRING TOO LONG'
*
ANEXT DC F'0'
* ------------------------------------- CHAR -----------------------
** MVC DLEN+2(0),2(R3)
MVC 2(0,R4),2(R3)
QSTRCHAR CH R15,=H'32'
BH LONGSTR
EX R15,QSTRCHAR-6
* ------------------------------------- BUMP ----------------------
*
QSTRNEXT L R1,ANEXT
LA R3,1(R1)
L R9,QSTRING-4
BR R9
*
* ----------------------------------------- HEX ---------
THEX TRT 2(0,R3),TESTHEX
MHEX TR LINE(0),MAKEHEX
PACKHEX PACK 2(0,R4),LINE(0)
* PACKHEX PACK DLEN+2(0),LINE(0)
* MNEX TR 2(0,R3),MAKEHEX
* PACKHEX PACK DLEN+2(0),2(R3)
QSTRHEX CH R15,=H'62'
BH LONGSTR
TM DLEN+1,1
ERR BZ,'ODD #OF HEX DIGITS'
EX R15,THEX
ERR BNZ,'INVALID HEX DIGIT'
LA R15,1(R15)
MVC LINE(0),2(R3)
EX R15,*-6
EX R15,MHEX
LR R14,R15
SLL R14,3
OR R15,R14
EX R15,PACKHEX
SRL R15,4
BCTR R15,0
N R15,=F'15'
STH R15,0(R4)
MVC LINE,LINE-1
B QSTRNEXT
* ----------------------------------------- PACK -----------
TRT 2(0,R3),TESTNUM
* PACK DLEN+2(0),2(0,R3)
PACK 2(0,R4),2(0,R3)
QSTRPACK CH R15,=H'15'
ERR BH,'MAX PACKED # LENGTH =15'
*
CLI 2(R3),C'-' Q. NEGATIVE #
BNE NOTMINUS NO
MVC 2(L'CARD,R3),3(R3) YES, MOVE UP 1 BYTE
L R0,ANEXT
BCTR R0,0
ST R0,ANEXT
MVI DATATYP,C'Q' INDICATE PACKED NEGATIVE
SH R15,=H'1'
ERR BM,'NEGATIVE LENGTH'
CLI DEQ,C'G'
BE *+12
CLI DEQ,C'L'
BNE NOTMINUS
ERR B,'CANNOT USE GT,GE,LT,LE WITH NEGATIVE PACKED #S'
*
NOTMINUS EX R15,QSTRPACK-12
ERR BNZ,'NON-NUMERIC FOUND'
LR R1,R15 1,0 2,1 3,2 4,3 5,4 6,5 7,6
LA R1,1(R1) 1,0 2,1 3,1 4,2 5,2 6,3 7,3
SRL R1,1
SLL R1,4 +1 / 2
LA R14,0(R1,R15)
EX R14,QSTRPACK-6
SRL R1,4
STH R1,0(R4)
*
LA R1,1(R4,R15)
CLI DATATYP,C'Q' Q. NEGATIVE PACKED #
BNE *+12 NO, GO MAKE 5C SIGN
NI 0(R1),X'FD'
B QSTRNEXT
*
MVC 18(15,R4),2(R4)
NI 0(R1),X'FC'
B QSTRNEXT
* ----------------------------------------------------
FIXKEYW MVI FLAGALL,C' '
TRT 1(8,R3),FINDEQ
BZ TOOLONG
*
LR R2,R1
SH R2,=H'3'
CLC =C'ALL',0(R2)
BNE *+8
MVI FLAGALL,C'A'
CLC =C'DO',1(R2)
BNE *+8
MVI FLAGALL,C'D'
MVC 1(L'CARD,R3),0(R1)
BR BR
TOOLONG ERR B,'KEYWORD= TOO LONG'
* -------------------------------------------------
DC 3F'0'
LISTABLE STM R7,R9,LISTABLE-12
** BAL R14,BYTSUSED
L R8,AGETMAIN
B LISTBLA
LISTBLZ LM R7,R9,LISTABLE-12
BR R9
*
LISTBL8 L R8,DNEXT
CLI 0(R8),X'FF'
BE LISTBLZ
C R8,DNEXT
BNL LISTBLZ
CLI 0(R8),C'A'
BNL *+8
EX 0,*
*
LISTBLA LR R3,R8
CLI 0(R8),C'A'
BNL *+8
EX 0,*
LA R7,LDSECT1(R8)
LA R2,2
MVC LINE(3),=C'R8='
BAL R4,LISTBL
B *+8
LISTBL7 LA R7,LDSECT2(R7)
C R7,DNEXT
BNL LISTBL8
CLI 0(R7),X'FF'
BE LISTBLZ
CLI 0(7),C'A'
BNL *+8
EX 0,*
*
LR R3,R7
LA R2,4 (3 OR 4, LAST 16 ALWAYS BLANK)
MVC LINE(3),=C'R7='
BAL R4,LISTBL
B LISTBL7
* ------------------------------------
LISTBL C R3,DNEXT
BNL LISTBL8
CLI 0(R3),X'FF'
BER R9
LISTBLL ST R3,12(R13)
UNPK LINE+4(7),13(4,R13)
TR LINE+4(6),HEX-240
MVI LINE+10,C' '
LA R0,4
LA R15,LINE+12
MVC LINE+51(16),0(R3)
LISTBLU UNPK 0(9,R15),0(5,R3)
TR 0(8,R15),HEX-240
MVI 8(R15),C' '
LA R3,4(R3)
LA R15,9(R15)
BCT R0,LISTBLU
BAL R14,PRINTLIN
LTR R2,R2
BNM *+8
EX 0,*
BCT R2,LISTBLL
BR R4
*
* R4=CHAR AND OFFSET
QFREQ STM R14,R6,12(R13) R2,LENGTH/STRING
QFREQFF XC 0(3,R4),0(R4) ZERO OFFSET, DEFAULT TO 1ST CHAR
MVC 0(1,R4),2(R2) AND SAVE THE CHAR
SR R1,R1
IC R1,2(R2) LOAD FREQ OF CHAR
LA R14,QFREQTBL(R1) GET LOC IN FREQ TBL
MVC 64(1,R13),0(R14) SAVE THAT.
*
* R4 = OFFSET(2) AND CHAR(1)
* R3 = H'LEN-1' AND STRING
LH R1,0(R2) LOAD LENGTH-1
LA R1,1(R1) CALC REAL LENGTH
LA R2,2(R2) POINT TO STRING
LR R0,R2 SAVE STRING ADDR
LA R14,QFREQTBL ADDR OF FREQ TABLE THAT I MADE UP.
*
QFREQ10 SR R15,R15
IC R15,0(R2) GET CHAR
AR R15,R14 GET LOC IN TABLE
CLC 64(1,R13),0(R15) Q.NEW CHAR LESS FREQ
BNH QFREQ20 NO.
MVC 64(1,R13),0(R15) YES, SAVE FREQ
MVC 0(1,R4),0(R2) SAVE CHAR
LR R15,R2 CALC OFFSET FROM
SR R15,R0 BEG OF STRING
STH R15,1(R4) AND SAVE THAT.
*
QFREQ20 LA R2,1(R2) BUMP CHAR
BCT R1,QFREQ10 LOOP THROUGH STRING
LH R0,0(R2)
SH R0,0(R4)
STH R0,3(R4)
LM R14,R6,12(R13) LOAD REGS
BR R14 AND RETURN
* ---------------------------------------------------
QS95 CLI DOPCODE,C'E'
BNE QS98
CP #R7,=P'2'
BNE QS96
LA R1,LDSECT1(R8)
LH R0,DLEN-DSECTION(R1)
CH R0,DLEN
BE QS99
MSG ' EDIT WITH UNEQUAL LENGTHS COULD MESS UP FILE'
B QS99
QS96 MSG ' EDIT FROM MORE THAN 1 "FROM" STRING IS POTENTIAL ERROR'
B QS99
QS98 MSG ' NO EDIT DONE'
QS99 CLI FLAGTEST,C'T'
BNE *+8
BAL R9,LISTABLE
CLI FUNCTION,C'L'
BNE *+8
BAL R14,PUTBLANK
RET ,
QFREQFQ DC C' '
QFREQRC DC H'0'
*
QFREQTBL DC X'5431292B2C4E2A2C2D23342027222336'
DC X'442428242125211F28213D2620212122'
DC X'2A222128392124222425252329202021'
DC X'3024213335262F242920252126202022'
DC X'944120222C37244723232089465A4522'
DC X'482024202E2021203127323C4B593227'
DC X'77842420222024202220267F497A3853'
DC X'3B2220202420202122336B5066656A5D'
DC X'3E917C8886937D818A8E212020202021'
DC X'4258748B878F9083518C20202B212120'
DC X'25318D9285768263804D2220224A2020'
DC X'272021202220202127212120214B2021'
DC X'286E62685F60575556693F4030202122'
DC X'3A4C5564675E5B5F4361292625212224'
DC X'35226F70524C5C3F4F3A23202A202020'
DC X'7B7E797273716D6C7578232120212427'
* CNOP 0,8
* QFREQTBL DC 256X'05'
* ORG QFREQTBL
* DC X'151413'
* ORG QFREQTBL+X'20' BLANK + SPECIAL CHARS
* DC X'15',15X'09'
* ORG QFREQTBL+X'30' ASCII NUMBERS
* DC X'14',9X'12',6X'09'
* ORG QFREQTBL+X'40' ASCII UPPER CASE LETTERS
* DC X'091411111114111111141011121212141110121212131010091309'
* DC 6X'08' SPECIAL CHARS,THEN LOWER CASE LETTERS
* DC X'091411111114111111141011121212141110121212131010091309'
* DC 5X'08'
* ORG QFREQTBL+X'80'
* DC X'05141111111411111114',6X'05' EBCDIC LOWER CASE
* DC X'05111112131314110013',6X'05' "
* DC X'05051313120909081209',6X'05' "
* DC 16X'05'
* ORG QFREQTBL+X'C1'
* DC X'141212121912121214',6X'05' UPPER CASE
* DC X'05121212141414120314',6X'05'
* DC X'05051414121111040904',6X'05'
* DC X'15151413131313131313',6X'05'
* ORG
*
TESTHEX EQU *-193
DC 6X'00',41C' ',10X'00',6C' '
MAKEHEX EQU *-193
DC X'0A0B0C0D0E0F',41C' ',X'00010203040506070809'
*
FNDSPCOM DC XL64'00',C' ',XL191'00' FIND COMMA OR SPACE
ORG FNDSPCOM+C','
DC C','
ORG
*
FINDEND DC XL256'00'
ORG FINDEND+C')'
DC C')'
ORG FINDEND+C','
DC C','
ORG
*
FINDSCP DC XL64'00',C' ',XL191'00'
ORG FINDSCP+C','
DC C','
ORG FINDSCP+C')'
DC C')'
ORG
*
ZEROS DC XL255'00'
TRTTBL DC C' ',XL255'00'
FINDEQ EQU TRTTBL-C'='
FINDSPAC EQU TRTTBL-C' '
*
* ------------------------------------------------------------
DSECT DSECT 0
DOPCODE DS C
DALL DS C 'AND' STRING OF PARMS RATHER THAN 'OR'
D# DS CL3
DS C
DGOTO DS CL6
DLABEL DS CL6
DS CL2
DDDNAME DS 0CL8,CL4
DDCB DS AL4
LDSECT1S EQU *-DSECTION SPACES ABOVE THIS
DNEXT DS A
LDSECT1 EQU *-DSECT
* ------------------------------------------------------------
DSECTION DSECT 0
DATATYP DS C
DCHAR DS C LEAST FREQ CHAR
DOFF DS HL2 LEAST FREQ OFFSET
DBACKUP DS HL2 BACK UP FROM END OF RECORD
DFROM DS H
DTO DS H
DEQ DS CL3
DE# DS CL3
DSGOTO DS CL6
DSDDNAME DS 0CL8,CL4 DDNAME + DCB ADDR
DSDCB DS AL4
LDSECT2S EQU *-DSECTION SPACES ABOVE THIS
* ---------------------
DLEN DS HL2
DSTRING DS CL32
LDSECT2 EQU *-DSECTION
MDSECT EQU LDSECT1+LDSECT2
* ------------------------------------------------------------
DCBDSECT DSECT 0
DCB DS XL104
DCBDDN DS CL8
DCB# DS PL8
DCBSEL DS A
LDSECT3 EQU *-DCBDSECT
END SCANSTR