SCANSTR

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