MYSCAN

MYSCAN is (well, will be when it's finished) yet another "read a file and copy selected records" program. In the '70s, I wrote a simple program that read the parm field, which could contain multiple arguments and would read the input file and copy only records that contained one of those arguments. A couple years after I did that, the bank leased DUMPER, from Joe Blank, who wrote it while he worked at Fireman's Fund Insurance Company. They had a huge master file, and ran updates once a week. After the update, they'd use DUMPER to rad the file and split out selected records to various extract files, to be used by applications, so they didn't have to pass the entire mater file. He also created ISPF panels to use DUMPER from your desk. His program wasn't faster than mine, but it was worlds better. In any case, I've always liked that idea, and have written several such, some of which are also in google-sites.

DUMPER record select control cards look like:
IF=(1,0,C'My Name') which would copy all records with My Name somewhere in them.
IF=(9,EQ,X'C1'),AND=(12,EQ,P'12345'),OR=(12,EQ,P'54321') Which checks for 'A' in col-9 and looks for 12345 or 54321 in col-12

For the program I'm working on, currently titled MYSCAN, there are 3 parts.

1. loading the file links I'll be using.

2. loading the record select entries.
2b. connecting the file links to the record select entries that will use them.

3. actually scanning and selecting records and writing them.

I think that the first 2 steps work. A few days ago, I rewrote most of that code, more simply than it had been. And there's a trace that seems to show that it works correctly. Right this minute, there's error correction, and more code needs to be written, step-3 and I'm tired and not sure I'm up to it. When that happens, it's time to write notes.

There are rules, but you have to know them to know whether "OR" applies to the IF or to the AND.

To address that, I'd like to be able to code:

IF=(1,EQ,C'ABC'),ANDOR=(11,0,C'MY NAME,WRITE=A,11,0,C'YOUR NAME',WRITE=B)

meaning you're still dealing with ABC records, and if 'my name' appears in one of those records, write that record to file-A, or if 'your name' appears, write the record to file-B.

So, in addition to IF=, AND=, OR=, you have:

IF= IFAND= IFOR=

AND= ANDAND= ANDOR=

OR= ORAND= OROR=

DUMPER had a very nice edit function in it. I have a limited edit function, that, at the moment, will only replace a string with another of the same length. (I hope I can improve on that, to process different lengths, but the same length is much easier.)

When you're writing a record, you can write the entire record. OR, you can write selected parts of the record, inserting hard coded strings in the record if you'd like.

The 5 data types, that can be used in either/both the record select, or the WRITE specs, are:

C'ABC' normal character data

T'Abc' either upper of lower case data

L'ABC' lower case data

P'1234' or P'-1234' packed decimal numeric data

F'4321' of F'-4321' 4-byte binary data

You can GOTO=ALABEL (skip ahead in the instruction stream).

And the control file can have several logical files within it, using STARTEND= (17 chars).

You can code that, and processing will start where it finds the STARTEND=jobname.stepname that you specify, and stop when it encounters any other STARTEND= in the instruction stream. (So I can have all my various test streams in a single file, and use the one I want to test specifically.)

AGO .START

C:\USERS\LIN\DOCUMENTS\Z390CODE\MYSCAN

SET PA="DETAIL,MAX=16000 "

SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\MYSCAN

SET IN=%G%.PRN

SET OUT=%G%.OUTPUT.OUT.TXT

SET DSDC=%G%.OUTPUT.DSDC.TXT

SET ORG=%G%.OUTPUT.ORG.TXT

SET MVI=%G%.OUTPUT.MVI.TXT

SET MVC=%G%.OUTPUT.MVC.TXT

SET ST=%G%.OUTPUT.ST.TXT

SET FILE0000=%G%.OUTPUT.FILE0000.TXT

SET SYSPRINT=%G%.OUTPUT.SYSPRINT.TXT

SET SYSIN=%G%.SYSIN.TXT

BAT\ASMLG %G%.MLC TIME(1) PARM(%PA%)

SET LISTING=C:\USERS\LIN\DOCUMENTS\Z390CODE\MYSCAN.PRN

SET SYSIN=C:\USERS\LIN\DOCUMENTS\Z390CODE\MYSCAN.BREAK.SYSIN.TXT

BAT\EZ390 C:\USERS\LIN\DOCUMENTS\Z390CODE\RANDY.MLC

LOADLOC=FD000 13R%

LRECL=90

LABEL=PRINTR2,ERR*,MSG*,Z,ZS,GETMAIN,TRY*,SET*,SAV*,QFREQ,QS1*,QS9*

LABEL=TES*,EDIT0*,GETIN,WRITOUT,

IF=(1,0,C'ABE'),WRITE=(1,4,11,12,33,22)=DDNAME

IFAND=(1,0,T'DEF',4,EQ,X'22'),SUM=(NAME,22,8)

IFOR=(1,EQ,C'ABC',1,EQ,X'C1C2C3'),GOTO=.LABEL

AND=(11,9,C'DEF')

OR=(12,GT,X'121313')

ANDAND=(11,9,C'DEF',22,23,T"GHI")

ANDOR=(

ORAND=(

OROR=(

.LABEL

THERE IS A LOGIC PROBLEM

WHEN THERE IS A FAILURE, DO YOU ALWAYS GO TO THE NEXT IF=

IF=( SUCCESSFUL

AND=( FAIL

OR=( DOES THIS GO BACK TO IF= OR GET SKIPPED BECAUSE OF AND=

OR GET DONE, BECAUSE OF AND=?

ALLOWING THE DOUBLE VERB HELPS THAT LOGIC QUITE A BIT.

DATA TYPES ARE

X HEX

C CHARACTER

T TEXT (EITHER UPPER OR LOWER CASE CHARACTER)

L LOWER CASE (LOWER CASE CHARACTER)

P PACKED DECIMAL

F 4 BYTES

.START ANOP

* ---------------------------------------

MACRO

&LBL MSG &BC,&MSG,&TYPE,&ERRLOC=EXIT8 MSG, ERR, OR TRACE

CNOP 0,2

&LBL REVB &BC,SYS&SYSNDX+4

BAL R0,SYS&SYSNDX

DC AL3(&ERRLOC)

@ &MSG

CNOP 0,2

SYS&SYSNDX BAL R14,PUT&TYPE

MEND

* ---------------------------------------

MACRO

&LBL @ &MSG

LCLA &L

&L SETA (K'&MSG-3)

&LBL DC AL1(&L),C&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 $$LA &R,&F

* AIF ('&F'(1,1) EQ '(').ADD0

* &LBL LA &R,&F

* MEXIT

* .ADD0 ANOP

* &LBL LA &R,0&F

* MEND

* ----------------------------------------

MYSCAN START 0

YREGS

LSTRING EQU 30

USING *,13,12,11

DS 18F

ORG *-72

STM 14,12,12(13)

ST 13,4(15)

ST 15,8(13)

LR 13,15

LA 11,4095

LA 12,1(11,13)

LA 11,1(11,12)

L R4,0(R1)

B SETUP

ORG

TRTTB EQU *

TRTTABLE EQU TRTTB+256

TRTTEXT EQU TRTTB+512

FINDSPAC EQU TRTTABLE-C' '

PUSH PRINT

PRINT NOGEN

SETUP OPEN (SYSIN,INPUT,SYSPRINT,OUTPUT)

POP PRINT

PUT SYSPRINT,LINE-1

PUT SYSPRINT,PARM-1

MVC LINE,LINE-1

MVC PARM,LINE

SR R5,R5

LH R2,0(R4)

SH R2,=H'1'

LA R7,80(R13)

BM NOPARM

MVC PARM(5),=C'PARM='

MVC PARM+5(0),2(R4)

EX R2,*-6

LA R6,PARM+5

BAL R8,TESTPARM

SR R8,R8

B NOPARM

* ALRIGHT, THIS IS ALL A RAT'S NEST. WE DO THE PARM PROCESSING NERE.

* IF THERE IS NO PARM, THEN WE READ //SYSIN WHICH CAN HAVE:

* PARM= TO COME BACK AND DO THIS.

* * INITIAL COMMENTS WHICH ARE INTENDED TO BE DOCUMENTATION

* STARTAT=LABEL USED TO SKIP INTO //SYSIN TO START OF CARDS.

* YEAH, IT CONFUSED ME AS WELL. SORRY !!!

* -------------------------------------------------------

TESTPARL MVC PARM+5(88),0(R6)

TESTPARM CLI PARM+5,C' '

BER R8

PUT SYSPRINT,PARM-1

LA R6,PARM+5

CLC =C'TEST=X''',0(R6)

BNE TRYLIST

TR 7(2,R6),TRHEX

PACK FLAGTEST(2),7(3,R6)

LA R6,11(R6)

B TESTPARL

TRYLIST CLC =C'LIST=',0(R6)

BNE NOTLIST

MVC FLAGLIST,5(R6)

CLI 5(R6),C'0'

BNL *+12

LA R6,7(R6)

B TESTPARL

MVC FLAGLIST,PARM+88

MVI FLAGLIST,C'N'

LA R6,5(R6)

BAL R9,GET#

STH R1,FLAGLIST+1

LA R6,1(R6)

LA R4,FLAGLIST+3

BAL R9,QQTEXT

MVC PARM,PARM-1

B TESTPARL

NOTLIST CLC =C'GETMAIN=',0(R6)

BNE NGETMA

LA R6,8(R6)

BAL R9,GET#

ST R1,LGETMAIN

LA R6,1(R6)

B TESTPARL

NSTA MSG B,'INVALID PARM= KEYWORD',ERR6,ERRLOC=EXIT8

NGETMA CLC =C'STARTEND=',0(R6)

BNE NSTA

LTR R5,R5

BNZ SAVSTA

MSG B,'CANNOT HAVE STARTEND= IN //SYSIN',ERR6,ERRLOC-EXIT8

SAVSTA TRT 0(23,R6),FINDEND

MSG BZ,'STARTEND= TOO LONG',ERR6,ERRLOC=EXIT8

LR R2,R1

BCTR R2,0

SR R2,R6

MVC STARTEND(0),0(R6)

EX R2,*-6

MVC 0(88,R6),1(R1)

B TESTPARL

* ----------------------------------------------------------

NOPARM MVC PARM,PARM-1

BAL R9,GETCARD

CLC =C'PARM=',0(R6)

BNE QSTART

MVC PARM(80),0(R6)

BAL R8,TESTPARM

B NOPARM

QSTART CLI STARTEND,C' '

BE GETMAIN

CLCSTART CLC STARTEND,0(R6)

BE GOTSTART

BAL R9,GETCARD

B CLCSTART

GOTSTART MVC LINE(L'STARTEND),STARTEND

MVC LINE+L'STARTEND(5),=C'FOUND'

BAL R14,PUTLINE

BAL R9,GETCARD

MVC STARTEND,PARM+88

GETMAIN L R0,LGETMAIN

GETMAIN R,LV=(0)

LA R4,0(R1)

ST R4,AGETMAIN

ST R4,IFANDOR

ST R4,IFANDORZ

L R14,LGETMAIN

SH R14,=H'400'

CVD R14,DW

LA R15,0(R1,R14)

ST R15,EGETMAIN

SR R8,R8

OI DW+7,X'0F'

MVC LINE(16),=C'USEABLE GETMAIN='

UNPK LINE+16(7),DW+4(4)

BAL R14,PUTLINE

SR R5,R5

B CHECKDD

* -----------------------------------------------

DC F'0'

GETCARD GET SYSIN

AP #SYSIN,P1

CLI 0(R1),C' '

BE GETCARD

CLI 0(R1),C'*'

BE GETCARD

MVC CARD,0(R1)

LA R6,CARD

** ST R6,GETSYSIN-4

ST R6,GETCARD-4

BAL R14,PUTR6

BR R9

PUTCARD CLI FLAGTEST,0

LA R0,CARD-1

BE PUTCARDP

LA R14,0(R9)

SR R14,R13

ST R14,12(R13)

UNPK CARD-5(5),14(3,R13)

TR CARD-5(4),HEX-240

MVI CARD-1,C' '

LA R0,CARD-6

PUTCARDP PUT SYSPRINT,(0)

BR R9

USING DCBDSECT,5

GETNEXDD BAL R9,GETCARD

CHECKDD CLC =C'DD=',0(R6)

BNE ENDOFDD

BAL R14,PUTR6

MVI FLAGWRIT,C'W'

LTR R5,R5

BZ STARTDD

L R1,LASTDCB

MVI 0(R5),X'FF'

LA R5,2(R5)

ST R5,0(R1)

ST R5,FIRSTDCB

B *+8

STARTDD L R5,AGETMAIN

* DD=NANE

ST R5,LASTDCB DD=NAME,22,33

SAVER8R5 LR R8,R5 DD=NAME,C'ABC'

LA R6,3(R6)

XC 0(LDCB+4,R5),0(R5)

TRT 0(9,R6),FINDEND

MSG BZ,'INVALID DD=NAME',ERR6,ERRLOC=GETNEXDD

LR R2,R1 DD=ABC

BCTR R2,0

SR R2,R6

MSG BM,'DD= ERROR',ERR6,ERRLOC=GETNEXDD

MVC PARM(0),0(R6) DCBDD

EX R2,*-6

MVC OUTZ-8(8),PARM DCBDD

MVC DCBDDNAM-IHADCB+OUTZ(8),PARM

* MVC DCBDCB,OUTZ

MVC DCB#(LOUTZ),OUTZ-16

MVC PARM(11),PARM-1

LA R0,DCBDCB

ST R0,DCBADDR

LA R5,LDCB(R5)

MVI 0(R5),X'FF'

LR R6,R1

CLI 0(R6),C' '

BE GETNEXDD

ST R5,DCBFLDS-DCBDSECT(R8)

GETDDL BAL R14,PUTR6

CLI 0(R6),C' '

BE GETNEXDD

BAL R9,QCOMMA

MVC CARD,0(R6)

LA R6,CARD

GETDDN BAL R14,PUTR6

CLI 0(R6),C'0'

BNL DDLOCLEN

MVC 0(1,R5),0(R6)

MVI 1(R5),C' '

LA R4,2(R5)

SR R7,R7

BAL R9,QQTEXT

L R6,SAVE6

LH R1,2(R5)

LA R5,5(R1,R5)

B DDMORE

DDLOCLEN BAL R9,GET#

STH R1,0(R5)

BAL R9,QCOMMA

BAL R9,GET#

STH R1,2(R5)

LA R5,4(R5)

DDMORE MVI 0(R5),X'FF'

MVC CARD,0(R6)

LA R6,CARD

CLI 0(R6),C' '

BNE *+12

LA R5,2(R5)

B GETNEXDD

CLI 0(R6),C'+'

BNE GETDDL

BAL R9,GETCARD

B GETDDN

PUTR6SAV DC CL20' '

DC F'0'

PUTR6 CLI FLAGLIST,C'A'

BNER R14

ST R14,PUTR6-4

LA R0,PARM-1

CLI FLAGTEST,0

BE PUTR6P

LA R14,0(R14)

SR R14,R13

ST R14,12(R13)

UNPK PARM-5(5),14(3,R13)

TR PARM-5(4),HEX-240

MVI PARM-1,C' '

LA R0,PARM-6

PUTR6P MVC PARM(70),0(R6)

PUT SYSPRINT,(0)

MVC PARM(71),PARM-1

L R14,PUTR6-4

BR R14

FINDIF GET SYSIN

CLC =C'STARTEND=',0(R1)

BE STARTENZ

AP #SYSIN,P1

CLC =C'IF=(',0(R1)

BNE FINDIF

FINDIFSV MVC CARD,0(R1)

LA R6,CARD

ST R6,GETCARD-4

BAL R14,PUTR6

B TESTIF

* -----------------------------------------------------

LQOPCODE EQU 8

QOPCODE DC CL4'AND=',CL4'A Q '

DC CL4'ANDA',CL4'AAQ '

DC CL4'ANDO',CL4'AOQ '

DC CL4'EDIT',CL4'E Q '

DC CL4'GOTO',CL4'G . '

DC CL4'IF=(',CL4'I Q '

DC CL4'IFAN',CL4'IAQ '

DC CL4'IFOR',CL4'IOQ '

DC CL4'LABE',CL4'L . '

DC CL4'OR=(',CL4'O Q '

DC CL4'ORAN',CL4'OAQ '

DC CL4'OROR',CL4'OOQ '

DC CL4'REPL',CL4'A Q '

DC CL4'WRIT',CL4'W . '

** DC CL4' ',CL4' '

DC X'FF'

* -----------------------------------------------

GETOPC LA R2,QOPCODE-LQOPCODE

LA R2,LQOPCODE(R2)

CLC 0(4,R6),0(R2)

BH GETOPC+4

BER R9

CLI 0(R6),C'0'

BE BADOPCA

CLI 2(R6),C'0'

BE BADOPCA

CLI 3(R6),C'0'

BE BADOPCA

CLI 4(R6),C'0'

BE BADOPCA

MSG BNE,'INVALID OPCODE',ERR6,ERRLOC=FINDIF

BADOPCA MSG B,'CHECK FOR 0/O IN KEYWORD',ERR6,ERRLOC=READIF

* -----------------------------------------------

B RESTART <== THIS GETS MOVED TO 0(R13)

RESTART L R8,IFANDOR

LA R6,CARD

DC H'0' GONNA ABEND HERE, AND CONTINUE.

B TESTIF

* -----------------------------------------------

PUTSEPAR CLI FLAGLIST,C'A'

BNER R14

ST R14,8(R13)

MVI PARM,C'-'

MVC PARM+1(70),PARM

PUT SYSPRINT,PARM-1

MVC PARM,PARM-1

L R14,8(R13)

BR R14

USING DI,8

USING DA,7

NOFILES DS 0H

ENDOFDD BAL R14,PUTSEPAR

LTR R5,R5

BNZ *+12

L R5,AGETMAIN

B *+12

MVI 0(R5),X'FF'

LA R5,2(R5)

ST R5,IFANDORZ

ST R5,IFANDOR

MVI 0(R5),0

MVC 1(256,R5),0(R5)

MVC 0(4,R13),RESTART-4 HANDY FOR TESTING

SR R8,R8

MVC PARM,PARM-1

L R6,GETCARD-4

CLC =C'IF',0(R6)

MSG BNE,'FIRST "REAL CC" MUST BE IF=',ABE

B TESTIF

OI RC,8

GETNEXIF BAL R9,GETCARD

CLC =C'STARTEND=',0(R6)

BE STARTENZ

LA R6,CARD

CLC =C'IF=(',0(R6)

BE FINDIFSV

CLC =C'IFAN',0(R6)

BE FINDIFSV

CLC =C'IFOR',0(R6)

BE FINDIFSV

BAL R9,PUTCARD

MSG B,'//SYSIN ERR, LOOKING FOR IF',ERR6,ERRLOC=GETNEXIF-4

SHORTR8 LA R1,LDI+2(R8)

MVI LDI(R8),X'FF'

READIF BAL R9,GETNEXIF

TESTIF BAL R9,GETOPC

LOADIF LTR R8,R8

BNZ *+12

L R8,IFANDORZ

B *+8

L R8,0(R8)

L R1,PREVR8

LTR R1,R1

BZ *+8

ST R8,0(R1)

ST R8,PREVR8

XC 0(LDI+LDA,R8),0(R8)

MVC DILABELS,99+PARM

MVC DIOPCOD2,99+PARM

MVC DIOPCODE(4),4(R2)

TRT 0(8,R6),FINDEQ

MSG BZ,'INVALID OPCODE=',ERR6,ERRLOC=READIF

CLI DISEARCH,C'.'

BE SAVR8LBL

CLI 1(R1),C'('

MSG BNE,'( MISSING FROM KEY=(##,##',ERR6,ERRLOC=READIF

LA R6,2(R1)

CLI DISEARCH,C'Q'

BE SAVEIF

EX 0,*

DC H'0'

NEXTR6IF LA R1,LDA(R7)

ST R1,DANEXT

LA R0,LDA+2(R1)

ST R0,DANEXT

B XCR7R7

SAVEIF LA R7,LDI(R8)

LA R1,LDA+2(R7)

ST R1,DINEXT

ST R7,DIR7

XCR7R7 XC 0(LDA+4,R7),0(R7)

MVC DALABELS,99+PARM

BAL R14,PUTR6

BAL R9,GETFRTO

BAL R14,PUTR6

LA R4,DALEN1

BAL R9,QQTEXT

L R6,SAVE6

BAL R14,PUTR6

MVI LDA(R7),X'FF'

CLI DAOPCODE,C'R'

BE *+12

CLI DAOPCODE,C'E'

BNE QR7END

LA R4,DALEN2

BAL R9,QQTEXT

L R6,SAVE6

LA R1,LDAEDIT(R7)

ST R1,DANEXT

MVI 0(R1),X'FF'

LA R1,2(R1)

ST R1,DINEXT

MVI 0(R1),X'FF'

B READIF

QR7END BAL R14,PUTR6

CLC =C') ',0(R6)

BE READIF

CLC =C'+ ',0(R6)

BNE *+8

BAL R9,GETCARD

CLI 0(R6),C'0'

BNL NEXTR6IF

QDAWRI BAL R14,PUTR6

TRT 0(8,R6),FINDEQ

MSG BZ,'= NOT FOUND IN KEY= WITHIN IF=',ERR6,ERRLOC=READIF

LA R3,1(R1)

TRT 0(9,R3),FINDEND

MSG BZ,'KEY=... TOO LONG',ERR6,ERRLOC=READIF

LR R2,R1

SR R2,R3

SH R2,=H'1'

MSG BM,'WRITE=/GOTO= LENGTH 0',ERR6,ERRLOC=READIF

LA R4,DAWRITE

CLI 0(R6),C'W'

BE SAVDAWRI

CLI 0(R6),C'G'

BE SAVDAWRI

MSG B,'INVVALID KEY=',ERR6,ERRLOC=READIF

SAVDAWRI CLI 0(R4),C' '

MSG BNE,'WRITE=/GOTO= ALREADY SET',ERR6,ERRLOC=READIF

MVC 0(0,R4),0(R3)

EX R2,*-6

LA R6,1(R1)

L R1,DIR7

MVI DAWRGO-DA(R1),C'Y'

B NEXTR6IF

SAVR8LBL BAL R14,PUTR6

MVI DIOPCODE,C'?'

LA R4,DIWRITE

CLI 0(R6),C'W'

BE R8WRIT

LA R4,DILABEL

CLI 0(R6),C'L'

BE R8WRIT

LA R4,DIGOTO

CLI 0(R6),C'G'

BE R8WRIT

EX 0,*

R8WRIT CLI 0(R4),C' '

MSG BNE,'LABEL=/GOTO=/WRITE= ALREADY SET',ERR6,GOTOLOC=READIF

LA R3,1(R1) BEG

TRT 0(9,R4),FINDEND

MSG BZ,'LABEL/DDNAME TOO LONG',ERR6,ERRLOC=READIF

LR R2,R1

SR R2,R3

SH R2,=H'1'

MSG BM,'LABEL/DDNAME LENG=0',ERR6,ERRLOC=READIF

MVC 0(8,R4),PARM+99

MVC 0(0,R4),0(R3)

EX R2,*-6

CLI 0(R1),C' '

BE SHORTR8

BAL R9,QCOMMA

BAL R9,GETOPC

CLI 6(R2),C'.'

BE SAVR8LBL

MSG B,'WRITE=,GOTO=,LABEL= ERROR',ERR6,READIF

* ------------------------------------

QCOMMA BAL R14,PUTR6

CLI 0(R6),C','

LA R6,1(R6)

BER R9

BCTR R6,0

LA R14,0(R9)

SR R14,R13

ST R14,DW

UNPK QCOMMAM+12(5),DW+2(3)

TR QCOMMAM+12(4),HEX-240

MVI QCOMMAM+16,C' '

QCOMMAM MSG B,'.... COMMA MISSIG',ERR6

DC F'0'

GETFRTO ST R9,GETFRTO-4

BAL R14,PUTR6

CLI 0(R6),C'0'

MSG BL,'INVALID LOC #',ERR6

BAL R9,GET#

SH R1,=H'1'

BNM SAVELOC

MSG B,'LOCATION STARTS WITH 1, NOT 0',ERR6

SAVELOC STH R1,DAFROM

BAL R9,QCOMMA

CLI 0(R6),C'0'

BL GETBRAN

BAL R9,GET#

SH R1,=H'1'

BNM *+8

LH R1,=X'7FFF'

STH R1,DATO

BAL R9,QCOMMA

B GETFRTOZ

CCTABLE DC C'EQ',X'80'

DC C'GE',X'A0'

DC C'GT',X'20'

DC C'LE',X'C0'

DC C'LT',X'40'

DC C'NE',X'70'

DC C'Z'

GETBRAN LA R1,CCTABLE-3

GETBRANL LA R1,3(R1)

CLC 0(2,R6),0(R1)

BH GETBRANL

MSG BL,'BAD BRANCH COND',ERR6

MVC DACHAREQ,0(R1)

MVC DAEQ,2(R1)

XI DAEQ,X'F0'

LA R6,2(R6)

BAL R9,QCOMMA

GETFRTOZ L R9,GETFRTO-4

BR R9

* ---------------------------------------------

SAVE6 DC F'0'

SAVE7 DC F'0'

SAVE8 DC F'0'

NEXT7 DC F'0'

* -----------------------------------

QFREQ STM R14,R9,12(R13)

*** BAL R14,PUTR6

L R7,SAVE7

CLI DACHAREQ,C' ' Q. EQ OR RANGE?

BNE QFREQZ IF EQ, SKIP THIS

LA R14,DACHAR +1 H(OFFSET) +3 H(LENGTH-1) +5(STRING)

MVI 68(R13),X'FF'

LH R1,DALEN1

CLI DALEN1,0

BE *+8

EX 0,*

LA R0,1(R1)

LA R2,DASTR1 CURR LOC IN STRING

ST R2,64(R13)

SR R15,R15

QFREQIC IC R15,0(R2)

LA R1,FREQTBL(R15)

CLC 0(1,R1),68(R13)

BNL QFREQNOT

MVC 68(1,R13),0(R1)

MVC 0(1,R14),0(R2)

LR R1,R2

S R1,64(R13)

STH R1,1(R14)

QFREQNOT LA R2,1(R2)

BCT R0,QFREQIC

SR R1,R1

IC R1,DACHAR

LA R14,TRTTABLE

LR R15,R14

SR R15,R1

CLI DATYPE,C'T'

BNE *+8

LA R15,256(R15)

ST R15,DATRTBL

* B QFREQZ

QFREQZ LM R14,R9,12(R13)

BR R9

* -------------------------------------

DC F'0'

QQTEXT ST R9,QQTEXT-4

TM FLAGTEST,X'F0'

BNO QQTEXTA

BAL R14,PUTR6

QQTEXTA LA R2,1(R6)

SR R1,R1

CLI 1(R6),C'"'

BE FINDQUOT

CLI 1(R6),C''''

BE FINDQUOT

MSG B,'INVALID QUOTED STRING',ERR6

ABEND 4

FINDQUOT LA R2,1(R2)

CLC 0(1,R2),1(R6)

BE GOTQUOTE

LA R1,1(R1)

CH R1,=H'29'

BH NOQUOTE

CLC PARM+77(33),0(R2)

BNE FINDQUOT

NOQUOTE MSG B,'INVALID STRING',TRAC

MSG B,'INVALID STRING',ERR6

MVC 2(0,R4),2(R6)

GOTQUOTE LA R0,1(R2)

ST R0,SAVE6 COMMA AFTER QUOTE

LR R3,R2

SR R3,R6

SH R3,=H'3'

STH R3,0(R4)

EX R3,GOTQUOTE-6 SAV STRING

LA R1,DATATYPS-LDATATYP

QTYPE LA R1,LDATATYP(R1)

CLC 0(1,R6),4(R1)

BE QTYPEMVC

CLI LDATATYP(R1),0

BE QTYPE

MSG B,'INVALID DATA TYPE',ERR6

QTYPEMVC MVC DW+16(4),4(R1)

L R15,0(R1)

BR R15

DATATYPS DC A($CHAR),CL4'CC '

LDATATYP EQU *-DATATYPS

DC A($TEXT),CL4'TT '

DC A($LOW),CL4'LC '

DC A($HEX),CL4'XC '

DC A($PACK),CL4'PP# '

DC A($FW),CL4'FF# ',X'FF'

TR 2(0,R4),TRLOWER

$LOW EX R3,$LOW-6 MAKE THE STRING LOWER CASE.

MVI DW+20,C'L'

B $CHAR+4

TR 2(0,R4),TRUPPER

$TEXT EX R3,$TEXT-6 MAKE THE STRING UPPER CASE.

MVI DW+20,C'T'

B $CHAR+4

$CHAR MVI DW+20,C'C'

LH R1,0(R4)

LA R4,3(R1)

L R9,QQTEXT-4

BR R9

* ---------------------------------

MVC 2(0,R4),LINE+1

PACK LINE+1(0),0(0,R6)

$PACK ST R6,DW+20

LH R1,0(R4)

LA R6,2(R6)

LA R0,2(R6,R1)

ST R0,SAVE6

MVC DW+16(1),0(R6)

CLI 0(R6),C'-'

BNE *+10

BCTR R1,0

LA R6,1(R6)

LR R15,R1

LA R15,1(R15)

SRL R15,1

LR R0,R15

SLL R0,4

OR R1,R0

STH R15,0(R4)

EX R1,$PACK-6

EX R15,$PACK-12

* MVC 2(0,R4),LINE+1

L R6,SAVE6

LA R14,2(R4,R15)

NI 0(R14),X'FC'

CLI DW+16,C'-'

BNE $CHAR+4

OI 0(R14),X'0D'

MVI DW+20,C'P'

B $CHAR+4

PACK DW+8,0(0,R15)

$FWSIGN CLI 2(R6),C'-'

BNE *+10

LA R15,1(R15)

BCTR R3,0

EX R3,$FWSIGN-6

CLI 2(R6),C'-'

BNE *+8

NI DW+15,X'FD'

CVB R0,DW+8

BR R14

$FW LA R15,2(R6)

BAL R14,$FWSIGN

ST R0,2(R4) DASTR1

MVC 0(2,R4),=H'3' DALEN1

MVI DW+20,C'F'

B $CHAR+4

TR 2(0,R6),TRHEX

$HEX TM 1(R4),1

MSG BZ,'ODD # HEX DIGITS',ERR6

EX R3,$HEX-6

LA R0,1(R3)

SRL R0,1

LR R1,R0

BCTR R1,0

STH R1,0(R4)

LA R14,2(R6)

LA R15,2(R4)

PACK 0(2,R15),0(3,R14)

LA R15,1(R15)

LA R14,2(R14)

BCT R0,*-14

LA R6,1(R14)

MVC 0(8,R15),PARM+99

MVI DW+20,C'X'

B $CHAR+4

* ---------------------------------------

GET# SR R1,R1

GET#IC IC R0,0(R6)

N R0,=F'15'

MH R1,=H'10'

AR R1,R0

LA R6,1(R6)

CLI 0(R6),C'0'

BNL GET#IC

CLI 0(R6),C','

BER R9

CLI 0(R6),C' '

BER R9

CLI 0(R6),C')'

BER R9

CLI 0(R6),C''''

BER R9

MSG B,'## SYNTAX ERR',ERR6

* -----------------------------------------

MVC LINE(0),16(R1)

PUTMSG STM R15,R1,PUTTRAC-12

LR R1,R0

IC R15,15(R1)

EX R15,PUTMSG-6

LM R15,R1,PUTTRAC-12

B PUTLINE

MVC LINE+5(0),4(R1)

PUTABE STM 15,1,PUTTRAC-12

LR R1,R0

BAL R15,PUTADDR

IC R15,15(R1)

EX R15,PUTABE-6

BAL R14,PUTLINE

ABEND 1

DC 6F'0'

PUTADDR LA R0,0(R1)

SR R0,R13

SH R0,=H'8'

ST R0,12(R13)

UNPK LINE(5),14(3,R13)

TR LINE(4),HEX-240

MVI LINE+4,C' '

BR 15

PUTERR MVI FLAGMSG,C'E'

B PUTERR6+4

PUTERR6 MVI FLAGMSG,C'6'

STM 14,3,PUTADDR-24

LR R1,R0

BAL R15,PUTADDR

SR R15,R15

IC R15,3(R1)

CH R15,=H'44'

BL *+6

DC H'0'

EX R15,PUTABE-6

LA R14,LINE+9(R15)

CLI FLAGMSG,C'6'

BNE *+14

MVC 0(20,R14),0(R6)

LA R14,23(R14)

MVC 0(7,R14),=C'*ERROR*'

BAL R14,PUTLINE

LM 14,1,PUTADDR-24

LR R1,R0

ICM R14,7,0(R1)

CLI FLAGTEST,0

BNER R14

ABEND 1

DC 16F'0'

PUTTRAC CLI FLAGTEST,0

BER R14

STM 0,15,PUTTRAC-64

LR R1,R0

BAL R15,PUTADDR

IC R15,15(R14)

EX R15,PUTABE-6

BAL R14,PUTLINE

MVC LINE+5(5),=C'R0-R7'

LA R3,2

LA R2,PUTTRAC-64

PUTTRACL LA R1,LINE+11

LA R0,8

PUTTRACU UNPK 0(9,R1),0(5,R2)

TR 0(8,R1),HEX-240

MVI 8(R1),C' '

LA R1,9(R1)

LA R2,4(R2)

BCT R0,PUTTRACU

BAL R14,PUTLINE

MVC LINE+5(5),=C'R8-RF'

BCT R3,PUTTRACL

MVC LINE,LINE-1

LM R0,R15,PUTTRAC-64

BR R14

* ---------------------------------------------

*IFAND=(1,EQ,X'01',2,9,C'THIS',11,11,T'TEXT',24,EQ,P'12345')

*IFOR=(1,EQ,C'G',1,EQ,C'?'),THEN=GOTO=LABEL

*IF=(1,EQ,C'W'),THEN=WRITE=(1,9,44,12,13,9),DDNAME

DC F'0'

PUTBLANK DS 0H

PUTPARM ST R14,PUTBLANK-4

LA R0,PARM-1

CLI FLAGTEST,0

BE PUTPARMP

LA R14,0(R9)

SR R14,R13

ST R14,12(R13)

UNPK PARM-5(5),14(3,R13)

TR PARM-5(4),HEX-240

MVI PARM-1,C' '

LA R0,PARM-6

PUTPARMP PUT SYSPRINT,(0)

L R14,PUTBLANK-4

BR R14

DC 3H'0'

PUTLINE MVI PUTLINE-6,C' '

B PUTLINEN+4

PUTLINEA MVI PUTLINE-6,C'A'

B PUTLINEN+4

PUTLINEN MVI PUTLINE-6,C'N'

ST R14,PUTLINE-4

LA R0,LINE-1

CLI FLAGTEST,0

BE PUTLINEP

LA R14,0(R14)

SR R14,R13

ST R14,12(R13)

UNPK LINE-5(5),14(3,R13)

TR LINE-5(4),HEX-240

MVI LINE-1,C' '

LA R0,LINE-6

PUTLINEP PUT SYSPRINT,(0)

L R14,PUTLINE-4

CLI PUTLINE-6,C'N'

BER R14

MVC LINE,LINE-1

CLI PUTLINE-6,C'A'

BNER R14

ABEND 3

QGETMAIN L R0,IFANDORZ

S R0,AGETMAIN

CVD R0,DW

MVC LINE(L'ED7),ED7

ED LINE(L'ED7),DW+4

MVC LINE+10(24),=C'GETMAIN TABLE BYTES USED'

BAL R14,PUTLINE

BR R9

ED7 DC X'40202020206B212020'

DC F'0'

LISTABLE ST R9,LISTABLE-4

TM FLAGTEST,X'40'

BZR R9

L R8,IFANDOR

B LISTBLJ

LISTABAD MVC LINE,LINE-1

ST R2,12(R13)

UNPK LINE+4(7),13(4,R13)

TR LINE+4(6),HEX-240

MVI LINE+10,C'='

LA R3,LINE+11

BR R14

LISTBLI L R8,DINEXT

L R9,LISTABLE-4

LTR R8,R8

BZR R9

CLI 0(R8),X'FF'

BER R9

LISTBLJ LR R2,R8

BAL R14,LISTABAD

MVC LINE(4),=C'R8=='

BAL R14,LISTWORD NEXT

BAL R14,LISTWORD R7

BAL R14,LISTBL4 OPCODE

BAL R14,LISTBL4 MORE OPCOE

BAL R14,LISTBL8 WRITE

BAL R14,LISTBL8 LABEL

BAL R14,LISTBL8 GOTO

BAL R14,PUTLINE

CLI LDI(R8),X'FF'

BNE LISTBLA-4

B LISTBLI

LISTBL8 MVC 0(8,R3),0(R2)

LA R3,9(R3)

LA R2,8(R2)

BR R14

LISTBL4 MVC 0(4,R3),0(R2)

LA R3,5(R3)

LA R2,4(R2)

BR R14

LISTBL2 MVC 0(2,R3),0(R2)

LA R3,3(R3)

LA R2,2(R2)

BR R14

L R7,DIR7

LISTBLA LTR R2,R7

BZ LISTBLI

BAL R14,LISTABAD

MVC LINE+1(3),=C'R7='

BAL R14,LISTWORD NEXT

BAL R14,LISTBL4 OPCODE

BAL R14,LISTWORD TRT TABLE

BAL R14,LISTBL4 TYPE

BAL R14,LISTBL8 GOTO

BAL R14,LISTBL8 WRITE

BAL R14,LISTHALF FROM

BAL R14,LISTHALF TO/LEN

MVC 0(3,R3),DACHAREQ EQ+SCAN CHAR

LA R3,4(R3)

LA R2,DALEN1

BAL R14,LISTHALF

LH R1,DALEN1

CLI DATYPE,C'C'

BE LISTBLAP-4

CLI DATYPE,C'L'

BE LISTBLAP-4

CLI DATYPE,C'T'

BE LISTBLAP-4

LA R14,DASTR1

LA R1,1(R1)

LISTBLU UNPK 1(3,R3),0(2,R14)

TR 1(2,R3),HEX-240

LA R14,1(R14)

LA R3,2(R3)

BCT R1,LISTBLU

MVI 1(R3),C' '

B LISTBLAP

MVC 1(0,R3),DASTR1

EX R1,*-6

LISTBLAP BAL R14,PUTLINE

L R7,DANEXT

LTR R7,R7

BZ LISTBLI

CLI 0(R7),X'FF'

BE LISTBLI

C R7,DINEXT

BL LISTBLA

EX 0,*

LISTWORD UNPK 0(9,R3),0(5,R2)

TR 0(8,R3),HEX-240

MVI 8(R3),C' '

LA R2,4(R2)

LA R3,9(R3)

BR R14

LISTHALF UNPK 0(5,R3),0(3,R2)

TR 0(4,R3),HEX-240

MVI 4(R3),C' '

LA R2,2(R2)

LA R3,5(R3)

BR R14

* ----------------------------------------------

DC F'0'

FIXDI ST R9,FIXDI-4

L R8,IFANDOR

B FIXDIA+4

FIXDIA L R8,DINEXT

LTR R8,R8

BZ FIXDI9

FIXDIB CLI 0(R8),X'FF'

BE FIXDI9

BAL R3,FIXDIW

BAL R3,FIXDIG

L R7,DIR7

LTR R7,R7

BNZ FIXDA

L R8,DINEXT

LTR R8,R8

BNZ FIXDIB

FIXDI9 L R9,FIXDI-4

BR R9

* ----------------------------------------------

L R7,DANEXT

FIXDA LTR R7,R7

BZ FIXDIA

CLI 0(R7),X'FF'

BE FIXDIA

BAL R3,FIXDAW

BAL R3,FIXDAG

B FIXDA-4

FIXDAW CLI DAWRITE,C' '

BNHR R3

LA R2,DAWRITE

BAL R9,QDD

BR R3

FIXDIW CLI DIWRITE,C' '

BNHR R3

LA R2,DIWRITE

BAL R9,QDD

BR R3

FIXDAG CLI DAGOTO,C' '

BNHR R3

LR R1,R8

LA R2,DAGOTO

BAL R9,QLABEL

BR R3

FIXDIG CLI DIGOTO,C' '

BNHR R3

LR R1,R8

LA R2,DIGOTO

BAL R9,QLABEL

BR R3

QLABEL L R1,DINEXT

MVC QLABELM+12(8),0(R2)

MVC QLABELE+12+6(8),0(R2)

L R1,DINEXT-DI(R1)

LTR R1,R1

BZ QLABELE

CLI 0(R1),X'FF'

BE QLABELE

CLI DILABEL-DI(R1),C' '

BNH QLABEL+4

CLC 0(8,R2),DILABEL-DI(R1)

BNE QLABEL+16

ST R1,4(R2)

QLABELM MSG B,' UPDATED',MSG

BR R9

QLABELE MSG BE,'GOTO= NOT FOUND',ERR,ERRLOC=FIXDI

BR R9

* ----------------------------

DC F'0'

QDD ST R9,QDD-4

MVC QDDNOTF+12(8),0(R2)

MVC QDDOP+12(08),0(R2)

L R5,FIRSTDCB

B *+8

QDDLOOP L R5,DCBNEXT

CLI 0(R5),X'FF'

BNE QDDCLC

QDDNOTF MSG B,'DDNAME WAS NOT DEFINED BY DD=',ERR,ERRLOC=FIXDI

B QDDZ

QDDCLC CLC 0(8,R2),DCBDD

BNE QDDLOOP

ST R5,4(R2)

LA R2,DCBDCB

TM DCBOFLGS-IHADCB(R2),DCBOFOPN

BZ OPENOUT

** BAL R9,OPENOUT

QDDOP MSG B,' ALREADY OPEN',MSG

QDDZ L R9,QDD-4

BR R9

* ----------------------------------

OPENMSG DC CL62'12345678 OPENED FOR OUTPUT, RECFM=...LRECL=..... BLX

KSIZE='

**ENMSG DC CL54'OPENED FOR OUTPUT, RECFM=...LRECL=..... BLKSIZE='

USING IHADCB,2

OPENIN MVC OPENMSG(8),DCBDDNAM

MVC OPENMSG+20(3),=C' IN'

PUSH PRINT

PRINT NOGEN

OPEN ((2),INPUT)

B OPENUNPK

OPENOUT MVC OPENMSG(8),DCBDDNAM

MVC OPENMSG+20(3),=C'OUT'

CLC =H'0',DCBLRECL

BNE OPENOUTO

MVC DCBRECFM,DCBRECFM-IHADCB+IN

MVC DCBLRECL,DCBLRECL-IHADCB+IN

OPENOUTO OPEN ((2),OUTPUT)

LA R0,SYSPRINT

CR R0,R2

BER R9

POP PRINT

OPENUNPK UNPK OPENMSG+34(3),DCBRECFM(2)

TR OPENMSG+34(2),HEX-240

MVI OPENMSG+36,C' '

LH R0,DCBLRECL

CVD R0,DW

OI DW+7,X'0F'

UNPK OPENMSG+43(5),DW+5(3)

LH R0,DCBBLKSI

CVD R0,DW

OI DW+7,X'0F'

UNPK OPENMSG+57(5),DW+5(3)

MVC LINE(L'OPENMSG),OPENMSG

BAL R14,PUTLINE

BR R9

DROP 2

ZS ST R8,EGETMAIN

BAL R14,PUTSEPAR

LA R2,SYSIN

BAL R9,CLOSE

BAL R9,QGETMAIN

CLI RC,0

BNE DONE

MVI TRTTB-1,0

MVC TRTTB,TRTTB-1

MVC TRTTB+256,TRTTB-1

MVC TRTTB+512,TRTTB-1

MVI TRTTABLE,C'A'

MVI TRTTEXT,C'C'

MVI TRTTEXT-64,C'B'

BAL R9,LISTABLE

BAL R9,FIXDI

BAL R9,LISTABLE

** AGO .PASTIF

B STARTIN

BEGREC DC F'0'

ENDREC DC F'0'

STARTIN LA R2,IN

BAL R9,OPENIN

B TOP

GETIN GET IN

AP #IN,P1

LA R6,0(R1)

LH R14,DCBLRECL-IHADCB+IN

AR R14,R6

ST R14,ENDREC

ST R6,BEGREC

L R8,IFANDOR

BR R9

$GOTO LR R8,R15

B TOP+4

$WRITEIN CLI YESNO,C'Y'

BNER R9

TM DCBOFLGS-IHADCB+OUT,DCBOFOPN

BZ TOP

L R0,GETIN-4

PUT (2),(0)

SH R2,=H'16'

AP 0(8,R2),P1

BR R9

TOP LA R2,OUT

BAL R9,$WRITEIN

BAL R9,GETIN

B NEXTIFT

NEXTIF L R8,DINEXT

NEXTIFT LTR R8,R8

BZ TOP

CLI 0(R8),X'FF'

BE TOP

CLI DIOPCODE,C'I'

BNE NEXTIF

L R7,DIR7

CLI DIWRITE,C' '

BNH *+10

L R15,DIWRITE+4

BALR R9,R15

CLI DIGOTO,C' '

BNH *+10

L R15,DIGOTO+4

BR R15

MVI YESNO,C' '

LTR R7,R7

BZ TOP

CLI DACHAREQ,C' '

BH $CE

B $CS

* -------------------------------------------

* THE $CS + $CE (COMPARE EQ AND COMP SCAN) ROUTINES ARE USED FOR ALL

* THE C'ABC', X'C1C2C3', L'ABD', T'ABC', P'123' + F'1234' ROUTINES.

* THE FIRST 3 OF THOSE ARE SIMPLE COMPARES.

* THE TEXT STRING HAS TO BE MOVED TO A W/A AND TRANSLATED

* TO UPPER CASE, AND THEN COMPARED.

* FULLWORD IS A SIMPLE COMPARED, MUCH LIKE CHAR.

* PACKED HAVE TO HAVE TO FIRST MAKE SURE IT'S A VALID PACKED FIELD,

* THEN ADJUST THE LENGTH TO ACCOMODATE BOTH FIELDS, THEN COMPARED.

* -------------------------------------------

$CS ST R9,ARETURN

LR R1,R6

L R0,ENDREC

SR R0,R6

SH R0,DALEN1

BNP $CEZ

CH R0,DATO

BL *+8

LH R0,DATO

A R0,BEGREC

L R14,DATRTBL

AH R1,DACHAOFF

$CSL LR R2,R0

SR R2,R1

SH R2,DACHAOFF

CH R2,=H'255'

BL *+8

LA R2,255

EX R2,$CSFOUND-12

BNZ $CSFOUND

LA R1,255(R1)

CR R1,R0

BL $CSL

B $CENOPE

TRT 0(0,R1),0(R14) R0=END OF REC TO TEST

CLC DASTR1(0),0(R1) R1=DATA TO TEST

$CSFOUND SH R1,DACHAOFF

LH R2,DALEN1

CLI DATYPE,C'T'

BE $CSTEXT

CLI DATYPE,C'P'

BE $CSPACK

CLI DATYPE,C'F'

BE $CSFULLW

B $CSCOMP

$CSFULLW L R0,DASTR1

C R0,0(R1)

B $CSCOMP+4

CP 0(0,R1),DASTR1(0)

TRT 0(0,R1),TESTPACK

$CSPACK EX R2,$CSPACK-6

BNZ $CENOPE

LA R15,0(R1,R2)

TM 0(R15),X'0C'

BNO $CENOPE

SLL R2,4

L R15,DALEN1

OR R2,R15

EX R2,$CSPACK-12

B $CSCOMP+4

MVC 12(0,R13),0(R1)

TR 12(0,R13),TRUPPER

CLC 12(0,R13),DASTR1

$CSTEXT EX R2,$CSTEXT-18

EX R2,$CSTEXT-12

EX R2,$CSTEXT-06

B $CSCOMP+4

$CSCOMP EX R2,$CSFOUND-6

BE $CEYES

AH R1,DACHAOFF

LA R1,1(R1)

CR R1,R0

BL $CSL

B $CENOPE

* ------------------------------------------

BC 0,$CENOPE

CLC DASTR1,0(R1)

$CE ST R9,ARETURN

L R1,BEGREC

AH R1,DAFROM

LH R2,DALEN1

LA R0,1(R1,R2)

C R0,ENDREC

BH $CEZ

CLI DATYPE,C'P'

BE $CEPACK

CLI DATYPE,C'T'

BE $CETEXT

CLI DATYPE,C'F'

BE $CEFULLW

B $CECOMP

CP 0(0,R1),DASTR1(0)

TRT 0(0,R1),TESTPACK

$CEPACK LH R2,DALEN1

EX R2,$CEPACK-6

BZ $CEZ

LA R14,0(R1,R2)

TM 0(R14),X'0C'

BNO $CEZ

SLL R2,4

LH R15,DALEN1

OR R2,R15

EX R2,$CEPACK-12

B $CECOMP+4

$CEFULLW L R2,0(R1)

C R2,DASTR1

B $CECOMP+4

$CETEXT EX R2,$CECOMP-18

EX R2,$CECOMP-12

EX R2,$CECOMP-06

B $CECOMP+4

MVC 12(0,R13),0(R1)

TR 12(0,R13),TRUPPER

CLC 12(0,R13),DASTR1

$CECOMP EX R2,$CE-6

EX R2,$CE-10

BNE $CENOPE

$CEYES CLI YESNO,C' '

BE $CYESY

CLI DIANDOR,C'O'

BE $CYESY

B $CYESY+4

$CYESY MVI YESNO,C'Y'

CLI DAWRITE,C' '

BNH *+10

L R15,DIWRITE+4

BALR R9,R15

CLI DAGOTO,C' '

BNH *+10

L R15,DIGOTO+4

BR R15

CLI DIOPCODE,C'E'

CLI DIOPCODE,C'R'

BNE $RETURN

LH R14,DALEN2

CR R14,R2

BE REPLMVC

BL *+6

LR R14,R2

NOP REPLMVC

OI *-3,X'0F'

MSG B,'REPLACE FROM TO STRINGS NOT SAME LENGTH',MSG

OI RC,4

MVC 0(0,R1),DASTR2

REPLMVC EX R14,*-6

EDIT EX 0,8

DC H'0'

B $RETURN

$CENOPE CLI YESNO,C' '

BE $CENOPEN

CLI DIANDOR,C'A'

BE $CENOPEN

B $CENOPEN+4

$CENOPEN MVI YESNO,C'N'

$CEZ DS 0H

$RETURN CLI LDA(R7),X'FF'

BE $RETURNZ

L R7,DANEXT

LTR R7,R7

BZ $RETURNZ

CLI 0(R7),X'FF'

BE $RETURNZ

CLI DACHAREQ,C' '

BE $CE+4

B $CS+4

$RETURNZ L R9,ARETURN

BR R9

ARETURN DC A(0)

* -------------------------------------------

$WRITE L R0,BEGREC

L R1,DCBADDR

PUT (1),(0)

AP DCB#,P1

BR R9

.PASTIF ANOP

ED15 DC X'402020206B2020206B2020206B2020206B212020'

CLOSEMSG DC CL18' RECORDS READ '

USING IHADCB,2

CLOSE TM DCBOFLGS,DCBOFOPN

BZR R9

CLOSE ((2))

TM DCBOFLGS-IHADCB+SYSPRINT,DCBOFOPN

BZR R9

MVC LINE(8),DCBDDNAM

MVC LINE+8(7),=C' CLOSED'

MVC LINE+15(L'ED15+L'CLOSEMSG),ED15

LR R15,R2

SH R15,=H'16'

LA R1,LINE+14+L'ED15

EDMK LINE+15(L'ED15),0(R15)

MVC LINE+17(54),0(R1)

BAL R14,PUTLINE

BR R9

DROP 2

EXIT8 OI RC,8

B Z

STARTENZ MSG B,'SYSIN TERMINATED BY STARTEND=',MSG

Z LA R2,IN

BAL R9,CLOSE

MVC CLOSEMSG+10(7),=C'WRITTEN'

LA R2,OUT

BAL R9,CLOSE

L R3,AGETMAIN

C R3,IFANDORZ

BNL DONE

CLOSDCB LA R2,DCBDCB

C R2,IFANDORZ

BNL DONE

BAL R9,CLOSE

L R3,DCBNEXT

B CLOSDCB

DONE LA R2,SYSPRINT

BAL R9,CLOSE

LA R2,SYSIN

BAL R9,CLOSE

LM R0,R1,LGETMAIN

FREEMAIN R,LV=(0),A=(1)

LM R0,R1,LBUFFER

LTR R1,R1

BZ SR1515

FREEMAIN R,LV=(0),A=(1)

SR1515 SR 15,15

IC 15,RC

L 13,4(13)

L 14,12(13)

LM 0,12,20(13)

BR 14

LTORG

STARTEND DC CL27' '

DC X'FF'

RC DC X'00'

P0 DC X'0C'

P1 DC X'1C'

YESNO DC C' '

FLAGDOC DC C' '

FLAGWTO DC C' '

WRITSEL DC C' '

FLAGWRIT DC C' '

FLAGMSG DC C'E'

FLAGTEST DC 2X'00' NEED 2 BYTES FOR HEX PACK

FLAGLIST DC CL35' '

DW DC 3D'0'

PREVR8 DC 4F'0'

IFANDOR DC F'0'

IFANDORZ DC F'0'

LWRITE DC F'32768'

AWRITE DC F'0'

LBUFFER DC X'00007FFC'

ABUFFER DC FL4'0'

EGETMAIN DC F'4000'

LGETMAIN DC F'4000'

AGETMAIN DC F'0'

FIRSTDCB DC F'0'

LASTDCB DC 2A(0)

NEXTDCB DC F'0'

PREVDCB DC F'0'

HEX DC C'0123456789ABCDEF '

DC CL8' '

LINE DC CL133'MYSCAN, ASM &SYSDATE AT &SYSTIME -LINWOOD LYONS E

EMAIL LINLYONS@YAHOO.COM SUBJECT=MYSCAN FOR USE AUTHOR

RIZATION.'

DC CL8' '

CARD DC CL80' ',CL53' '

TESTPACK DC 10X'00000000000000000000222200006600',CL8' '

PARM DC CL133'READ //IN FILE, SELECT (EDIT) RECORDS, AND WRITE TH

HE SELECTED RECORDS TO ONE OR MORE OUTPUT FILES.'

DC 16CL16'0123456789ABCDEF'

TESTHEX EQU *-193

DC 6X'00',41C' ',10X'00',6C' '

TRHEX EQU *-193

DC X'0A0B0C0D0E0F',CL41' ',X'00010203040506070809'

FINDEND DC XL64'00',C' ',XL64'00'

ORG FINDEND+C','

DC C','

ORG FINDEND+C')'

DC C')'

ORG

DC 128X'00'

FINDTBL DC C' ',XL192'00'

FINDEQ EQU FINDTBL-C'='

TRUPPER DC 256AL1(*-TRUPPER)

ORG TRUPPER+X'81'

DC C'ABCDEFBHI'

ORG TRUPPER+X'91'

DC C'JKLMNOPQR'

ORG TRUPPER+X'A2'

DC C'STUVWXYZ'

ORG

TRLOWER DC 256AL1(*-TRLOWER)

ORG TRLOWER+C'A'

DC X'818283848586878889' A-I

ORG TRLOWER+C'J'

DC X'919293949596979899' J-R

ORG TRLOWER+C'S'

DC X'A2A3A4A5A6A7A8A9' S-Z

ORG

PUSH PRINT

PRINT NOGEN

DS 0D

#SYSIN DC PL8'0'

DC CL8'SYSIN'

SYSIN DCB DDNAME=SYSIN,DSORG=PS,LRECL=133,RECFM=FT,MACRF=GL,EODAD=ZS

DS 0D

#IN DC PL8'0'

DC CL8'IN'

IN DCB DDNAME=IN,DSORG=PS,LRECL=133,RECFM=FT,MACRF=GL,EODAD=Z

DS 0D

DC PL8'0'

DC CL8'OUT'

OUT DCB DDNAME=OUT,DSORG=PS,LRECL=133,RECFM=FT,MACRF=PM

DC PL8'0'

DC CL8'OUTZ'

OUTZ DCB DDNAME=OUTZ,DSORG=PS,LRECL=133,RECFM=FT,MACRF=PM

DC C'ABCD'

LOUTZ EQU *-OUTZ+16

SYSPRINT DCB DDNAME=SYSPRINT,DSORG=PS,LRECL=133,RECFM=FT,MACRF=PM

POP PRINT

FREQTBL DC 256X'05'

ORG FREQTBL

DC X'191817'

ORG FREQTBL+X'20' BLANK + SPECIAL CHARS

DC X'22',15X'09'

ORG FREQTBL+X'30' ASCII NUMBERS

DC X'20191817161514131211'

ORG FREQTBL+X'40' ASCII UPPER CASE LETTERS

DC X'022407131625100818220405151220230803171921140611040903'

DC 6X'08' SPECIAL CHARS,THEN LOWER CASE LETTERS

DC X'022407131625100818220405151220230803171921140611040903'

DC 5X'08'

ORG FREQTBL+X'80'

DC X'05240713162510081822',6X'05' EBCDIC LOWER CASE

DC X'05040515122023080317',6X'05'

DC X'05051921140611040903',6X'05'

DC 16X'05'

ORG FREQTBL+X'C0'

DC X'05240713162510081822',6X'05' UPPER CASE

DC X'05040515122023080317',6X'05'

DC X'05051921140611040903',6X'05'

DC X'20191817161514131211',6X'05'

ORG

* 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

* DCBD DEVD=DA

@@PAD#1 EQU ((*-MYSCAN)/4096+1)*4096

@@PAD#2 EQU @@PAD#1-(*-MYSCAN)

ORG *+@@PAD#2

DCBDSECT DSECT 0

DCBNEXT DS A

DCBADDR DS A

DCBFLDS DS A

DCB# DS PL8

DCBDD DS CL8

DCBDCB DS XL104

DS CL4

LDCB EQU *-DCBDSECT

DI DSECT IF= DSECT

DINEXT DS A

DIR7 DS A

DIOPCODE DS C

DIANDOR DS C

DISEARCH DS C

DS C

DIOPCOD2 DS 0CL4

DIOPCODL DS C

DIOPCODG DS C

DIOPCODW DS C

DIOPCODZ DS C

DILABELS DS 0CL24

DIWRITE DS CL8

DIGOTO DS CL8

DILABEL DS CL8

LDI EQU *-DI

DA DSECT

DANEXT DS A

DALABELS DS 0CL24

DAOPCODE DS C

DAZEND DS C

DAWRGO DS C,C

DATYPE DS C

DAFLGCLC DS C

DANUMERI DS 2C

DAGOTO DS CL8

DAWRITE DS CL8

DAFROM DS H

DATO DS H

DA# DS PL6

DAEQ DS X

DACHAREQ DS CL2

DACHAR DS C

DACHAOFF DS H

DATRTBL DS A

DALEN1 DS H

* LSTRING EQU 30 DEFINED AT 'START'

DASTR1 DS CL(LSTRING)

LDA EQU *-DA

DALEN2 DS H

DASTR2 DS CL(LSTRING)

LDAEDIT EQU *-DA

END MYSCAN