I'm working on a program. I think, now, there's better than a 50% chance it will eventually work, but it's definitely not a sure thing. There's a good chance that I'm not up to the complication required. It's somewhat similar to the DUMPER and Compuware's FILEAID programs, but different. DUMPER started at Fireman's Fund insurance, and Joe Blank took it public. Compuware copied it and sold their own. I liked Joe Blank. In any case, control cards are the same for the batch versions of those 2 programs, and look like:
IF=(2,EQ,C'ABC')
AND=(5,EQ,X'C4C5C6')
OR=(4,EQ,C'WXYZ')
OR=(9,33,C'JKLMN') (the last is search for the string)
I'd like to do the same, but add
IF=(2,EQ,C'ABC'),ANDOR=(5,EQ,X'C4C5C6),(5,22,C'WXYZ)
IFOR=(2,EQ,C'ABC'),(2,EQ,C'DEF') ANDOR=(5,EQ,'RST',W=2A),(5,EQ,C'UVW',W=4A)
So first, the 2nd and 3rd parameters can be combined in one statement, and then there are additional combined statements that write to output files, if the conditions are met correctly.
The former keywords are, IF= AND= OR=
The 9 keywords I'd like are, IF= IFAND= IFOR= AND= ANDAND= ANDOR= OR= OROR= ORAND=
And I want a WRITE (W=##) option available in each of those keywords, to write to individual output files if the request is true at that point.
I've written a REPLACE=(1,99,C"ABC",X'C4C5C6') which is like EDIT if the strings are the same length. There are a couple other things I'm thinking about, but so far, the EVAL routine that processes all 9 keywords is giving me the most trouble. (Their contents are all the same, so just 1 routine makes sense.)
This isn't done yet, not by a long shot, but if I can get this working, it will help a lot.
I expect this page will be updated/replaced again, either when it works, or when I give up. (could happen, sigh.)
The program so far is 1100 lines, with the first 100 being description, 600 being setup, 300 being processing, and the rest being work areas and dsects. Doing the setup, formatting control cards into a parameter table is always the hard part (but maybe not this time), but if you do it right, it makes execution easier and faster. In any case, I think (hope) it's done. (Again, it looks like it is.)
Anyway, this is the current source. (Yeah, I know, makes no sense. I'm having considerable trouble here too.)
AGO .START
HISTORY. I, LIKE MANY SYSTEMS GUYS, WROTE A PROGRAM TO SELECT RECORDS
FROM A FILE THAT CONTAINED THE PARM STRING. AFTER I'D WRITTEN MINE,
JOE BLANK, WHO'D WRITTEN PGM=DUMPER AT FIREMEN'S FUND, GOT PERMISSION
TO LEAVE FIREMEN'S FUND AND LICENSE IT ON HIS OWN. EVENTUALLY,
COMPUWARE WROTE A SIMILAR PROGRAM AND SOLD THAT. DUMPER/FILEAID
WERE REALLY NICE, BUT EVENTUALLY IBM PROVIDED SIMILAR ONLINE
FUNCTION, SO THERE WAS LESS CALL FOR THE OLD PROGRAM.
AT FIREMEN'S FUND, THE PRIMARY OBJECTIVE WAS TO RUN DUMPER AFTER THE
WEEKLY MAIN POST OF THE VERY LARGE MASTER FILE. THEY USED DUMPER TO
STRIP OUT VARIOUS TYPES OF RECORDS FOR VARIOUS APPLICATIONS, SO THAT
EACH APPLICATION DIDN'T NEED TO READ THE ENTIRE MASTER FILE TO GET
ONLY THE FEW RECORDS THAT THEY WERE INTERESTED IN.
THAT IS THE FUNCTION THAT THIS PROGRAM PROVIDES, STRIPPING OUT
VARIOUS RECORD TYPES FOR DIFFERENT USERS. DUMPER/FILEAID CONTROL
CARDS LOOK LIKE:
$$DD01 COPY IF=(2,EQ,C"ABC")
AND=(9,33,C"DEF") AND THEN WRITE A SUBFILE.
I'VE BEEN THINKING OF EXPANDING THE SELECTION CRITERIA. EG:
IFOR=(2,EQ,C'ABC',W=A1),(2,EQ,C'GHI',W-A3),(2,EQ,C'RST',W=BB)
IE SELECT THE 3 RECORD TYPES AND WRITE THEM EACH TO AN OUTPUT FILE.
THE KEYWORDS I USE ARE:
IFOR=(2,EQ,C'ABC',W=1A),(2,EQ,C'GHI',W-1C),(2,EQ,C'RST',W=2B)
IE SELECT THE 3 RECORD TYPES AND WRITE THEM EACH TO AN OUTPUT FILE.
THE KEYWORDS I USE ARE:
IF=, IFAND=, IFOR=, AND=, ANDAND=, ANDOR=, OR=, ORAND=, OROR=
THERE'S ALSO A BASIC EDIT THAT ALLOWS REPLACEING A STRING WITH
ANOTHER OF THE SAME LENGTH.
THE KEYWORDS I USE ARE:
IFOR=(2,EQ,C'ABC',W=1A),(2,EQ,C'GHI',W-1C),(2,EQ,C'RST',W=2B)
IE SELECT THE 3 RECORD TYPES AND WRITE THEM EACH TO AN OUTPUT FILE.
THE KEYWORDS I USE ARE:
IF=, IFAND=, IFOR=, AND=, ANDAND=, ANDOR=, OR=, ORAND=, OROR=
THERE'S ALSO A BASIC EDIT THAT ALLOWS REPLACEING A STRING WITH
ANOTHER OF THE SAME LENGTH.
THE KEYWORDS I USE ARE:
IF= IF THIS IS TRUE
IFAND= IF ALL OF THESE CONDITIONS ARE TRUE
IFOR= IF ANY ONE OF THESE CONDITIONS ARE TRUE
AND= IF THIS IS ALSO TRUE
ANDAND= IF ALL OF THESE ARE TRUE
ANDOR= IF ANY ONE OF THESE ARE TRUE
OR= IF THE PRIOR TEST FAILED, BUT THIS IS TRUE
ORAND= IF THE PRIOR TEST FAILED, BUT ALL OF THESE ARE TRUE
OROR= IF THE PRIOR TEST FAILED, BUT ANY ONE OF THESE ARE TRUE
THERE'S ALSO A BASIC EDIT [R=(1,99,C'ABC',C'DEF') THAT ALLOWS REPLACING
A STRING WITH ANOTHER OF THE SAME LENGTH.
IF OPEN IS SPECIFIED, THEN ALL THE OUTPUT FILES ARE OPENED.
IF NOT, THEN FILES ARE ONLY OPENED AS THEY ARE USED.
LIST DISPLAYS THE INTERNAL TABLE OF THE CONTROL CARDS (FOR TESTING).
MAX=## SPECIFIES THE NUMBER OF TABLE ENTRIES FOR CONTROL CARDS.
OTHERWISE GETMAIN IS ABOUT 4K.
--ASSEMBLE, LINK, AND GO -----------------------
C:\USERS\LIN\DOCUMENTS\Z390CODE\SPLITOUT
SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\SPLITOUT
SET IN=%G%.PRN
SET OUT1A=%G%.OUT1A.TXT
SET OUT1B=%G%.OUT1B.TXT
SET OUT=%G%.OUT.TXT
SET SYSIN=%G%.SYSIN.TXT
SET SYSPRINT=%G%.SYSPRINT.TXT
BAT\ASMLG %G%.MLC TIME(1) PARM(C$A$ X$C2$)
BAT\EZ390 %G%.MLC TIME(1) PARM(C$A$ X$C2$)
BAT\EZ390 %G%.MLC TIME(2000) PARM(C$A$ X$C2$) TEST
------------QBREAK------------------
SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\SPLITOUT
SET LISTING=%G%.PRN
SET SYSPRINT=%G%.BREAK.SYSPRINT.TXT
SET BREAK=%G%.BREAK.BREAK.TXT
SET SYSIN=%G%.BREAK.SYSIN.TXT
BAT\EZ390 C:\USERS\LIN\DOCUMENTS\Z390CODE\QBREAK.MLC
--//SYSIN INPUT TO CREATE BREAKPOINT COMMANDS. ------------
LOADLOC=FF000 13R%
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\SPLITOUT ASMLG
-----------------------------------------------------------
.START ANOP
MACRO
&LABEL REVB &COND,&TO
LCLC &A,&N
AIF ('&COND' EQ 'B').B
AIF ('&COND' EQ 'BR').BR
&N SETC ('&COND'(2,1))
AIF ('&N' EQ 'N').ERASEN
&A SETC ('&COND'(2,2))
&LABEL BN&A &TO
MEXIT
.ERASEN ANOP
&A SETC ('&COND'(3,2))
&LABEL B&A &TO
MEXIT
.B ANOP
&LABEL NOP &TO
MEXIT
.BR ANOP
&LABEL BR &TO
MEND
* -----------------------------------------------------------
* ERR BE,'ERR MSG' = ERR MSG, ABEND
* ERR BE,' MESSAGE' JUST MSG, RETURN
* ERR BE,'$MESSAGE' = SYNTAX ERR IN COMMAND, PRINT COMMAND
* IF MSG STARTS WITH
* BLANK, PRINT THE MSG AND RETURN
* $, THERE'S A SYNTAX ERR, PRINT COMMAND
* JUST THE MESSAGE, PRINT MSG AND ABEND.
MACRO
&LABEL ERR &BC,&MSG
LCLA &A
LCLC &L
&L SETC 'SYS&SYSNDX'
&A SETA K'&MSG
&LABEL REVB &BC,&L.Z
BAL R14,ERR
DC AL1(&A-3),C&MSG
&L.Z DS 0H
MEND
* -----------------------------------------------------------
*
SPLITOUT START 0
YREGS
USING *,12,11
B START-SPLITOUT(R15)
DC 17F'0',AL1(L'INITMSG)
INITMSG DC C'SPLITOUT V01.01 ASM &SYSDATE &SYSTIME'
*
* THIS SECTION IS FOR CLOSING FILES WHEN WE'R DONE.
*
CLOSLIST DC A(CLOSLIST+8,CLOSLIST+16)
DC A(SYSIN,IN,0)
*
START STM 14,12,12(13)
LA 12,0(15)
LA R11,4095
LA R11,1(R11,R12)
LA 2,SAVEAREA
ST 13,SAVEAREA+4
ST 2,8(13)
LR 13,2
L R3,0(R1)
LH R2,0(R3)
SH R2,=H'1'
BM NOPARM
MVC CARD(0),2(R3)
EX R2,*-6
NOPARM LA R2,SYSPRINT
BAL R9,OPENOUT
LA R2,SYSIN
BAL R9,OPENIN
CLI CARD,C' ' IF THERE WAS ANYTHING IN THE PARM, USE IT
BNE PARMT OTHERWISE READ //SYSIN
B GETPARM
BADPARM ERR B,'INVALID MAX=, OPEN, LIST'
PARMLIST DC A(OPENALLF),CL4'OPEN'
DC A(FLAGLIST),CL4'LIST'
DC A(LGETMAIN),CL4'MAX=',X'FF'
GETPARM GET SYSIN
MVC CARD,0(R1)
MVC CARD-7(5),=C'SYSIN'
CLI CARD,C' '
BE GETPARM
*
PARMT CLI CARD,C' '
BE GETPARM
PARMTNEX CLI CARD,C'I'
BE GETMAIN
CLI CARD,C' '
BE GETMAIN
PUT SYSPRINT,CARD-8
LA R1,PARMLIST-8
PARMTL LA R1,8(R1)
CLI 0(R1),X'FF'
BE BADPARM
CLC 4(4,R1),CARD
BNE PARMTL
CLI CARD+3,C'='
BE PARM##
L R14,0(R1)
MVC 0(1,R14),CARD
MVC CARD,CARD+5
B PARMTNEX
PARM## L R5,0(R1)
LA R15,CARD+4
BAL R9,GET##
LTR R1,R1
BM BADPARM
ST R0,0(R5)
B PARMTNEX
*
* CLC =C'MAX=',CARD
* BNE NMAX
* LA R15,CARD+4
* BAL R9,GET##
* LTR R0,R0
* BM BADPARM
* * MH R0,=AL2(LFILES+LDSECT)
* SLL R0,8
* ST R0,LGETMAIN
* B PARMT
* *
* NMAX CLC =C'OPENALL',CARD
* BNE BADPARM
* MVI OPENALLF,C'O'
* MVC CARD,CARD+8
* B PARMT
*
PUSH PRINT
PRINT NOGEN
USING IHADCB,2
OPENOUT MVC DCBLINE(8),DCBDDNAM
CLC =H'0',DCBLRECL
BNE *+16
MVC DCBRECFM-IHADCB+OUT,DCBRECFM-IHADCB+IN
MVC DCBLRECL-IHADCB+OUT,DCBLRECL-IHADCB+IN
*
CLC =C'OUT',DCBDDNAM
BNE OPENOU
L R1,CLOSLIST+4 SAVE OUTPUT DCBS SO WE CAN
ST R2,0(R1) CLOSE 'EM WHEN WE'RE DONE.
LA R1,4(R1)
ST R1,CLOSLIST+4
*
OPENOU OPEN ((2),OUTPUT)
MVC DCBLINE+16(3),=C'OUT'
CLC =C'SYSPRINT',DCBLINE
BNE NOTSYSP
MVC LINE(L'INITMSG),INITMSG
PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
B NOTSYSP
OPENIN MVC DCBLINE(8),DCBDDNAM-IHADCB(R2)
OPEN ((2),INPUT)
POP PRINT
MVC DCBLINE+16(3),=C' IN'
NOTSYSP UNPK DCBLINE+30(3),DCBRECFM-IHADCB(2,R2)
TR DCBLINE+30(2),HEX-240
MVI DCBLINE+32,C' '
LH R0,DCBLRECL-IHADCB(R2)
CVD R0,12(R13)
OI 19(R13),X'0F'
MVC LINE(L'DCBLINE),DCBLINE
UNPK LINE+L'DCBLINE(5),17(3,R13)
PUT SYSPRINT,LINE-1
BR R9
POP USING
DROP 2
DCBLINE DC C'........ OPENED OUTPUT, RECFM=.. LRECL='
* =========================================================
PACK## PACK DW,0(0,R15)
GET## SR R0,R0
BCTR 0,0
CLI 0(R15),C'0'
BLR R9
LR R1,R15
LA R1,1(R1)
CLI 0(R1),C'0'
BNL *-8
LA R2,1(R1)
SR R1,R15
BCTR R1,0
EX R1,PACK##
CVB R0,DW
MVC CARD,0(R2)
BR R9
* =========================================================
* ERR BE,'ERR MSG' = ERR MSG, ABEND
* ERR BE,' MESSAGE' JUST MSG, RETURN
* ERR BE,'$MESSAGE' = SYNTAX ERR IN COMMAND, PRINT COMMAND
* IF MSG STARTS WITH
* BLANK, PRINT THE MSG AND RETURN
* $, THERE'S A SYNTAX ERR, PRINT COMMAND
* JUST THE MESSAGE, PRINT MSG AND ABEND.
DC F'0'
ERR MVC LINE,LINE-1
LA R14,0(R14)
ST R14,ERR-4
LR R0,R14 CALC OFFSET IN PGM
SR R0,R12 AND SAVE
ST R0,12(R13)
*
UNPK LINE+4(5),14(3,R13) SAVE LOCATION IN MSG
TR LINE+4(4),HEX-240
MVI LINE+08,C' '
*
MVC LINE(3),=C'ERR' INDICAERROR
CLI 1(R14),C' ' Q. IS THIS A MSG (CIRST CHAR SPACE)
BNE *+10 NO, OKAY
MVC LINE(4),=CL4'MSG' YES, INDICATE MSG, NOT ERROR
*
SR R1,R1
IC R1,0(R14) ABOVE THE LINE IS THE IMPORTANT
MVC LINE+10(0),1(R14) PART, LOCATION AND MSG.
EX R1,*-6 THE REST IS JUST FLUFF.
*
CLI 1(R14),C'$'
BNE *+20
MVC CARD+14(80),CARD+15
LA R1,LINE+12(R1)
MVC 0(32,R1),CARD-8
*
TM DCBOFLGS-IHADCB+SYSPRINT,DCBOFOPN
BO ERRPUT Q. IS THE FILE OPEN?
OPEN (SYSPRINT,OUTPUT) NO, OPEN IT.
ERRPUT PUT SYSPRINT,LINE-1 PRINT ERROR MSG
WTO MF=(E,LINE-5)
MVC LINE,LINE-1 THIS SECTION PRINTS REGISTERS
*
L R14,ERR-4 LOAD MSG ADDERSS
CLI 1(R14),C'$'
BE ERRGET
CLI 1(R14),C' ' Q. FIRST CHAR BLANK = MSG, NOT ERR
BNE ERRABE NOT BLANK, ABEND
*
LA R1,240 REG-1 = 'F0'
SH R14,=H'8' POINT TO PRIOR BRANCH
EX R1,0(R14) AND GO BACK AFTER MSG
ERRABE ABEND 1
* =================================================
*
* IF=(1,EQ,C'0')
* IF=(1,X,X'0D0A')
* IF=(1,EQ,X'EE',W=1A)
* IFAND= IFOR=((1,EQ,C'0')(3,NE,X'C3'))
* AND= ANDAND= ANDOR=
* OR= ORAND= OROR=
* W=?? 2 CHARACTERS OF DDNAME, EG 1A = //OUT1A
* REPLACE=(C'ABCD',X'C1C1C3C4',W=D1)
* =================================================
GETMAIN L R2,LGETMAIN
SLL R2,8
ST R2,LGETMAIN
LR R0,R2
GETMAIN R,LV=(0)
AR R2,R1
STM R1,R2,AGETMAIN + EGETAMAIN
LR R0,R1
STM R0,R1,ALIST +ELIST
SR R8,R8
B ANAL
*
ERRGET GET SYSIN
CLI 0(R1),C'I'
BNE ERRGET
B ANALGOT
*
ANALGET GET SYSIN
ANALGOT CLI 0(1),C' '
BE ANALGET
MVC CARD,0(R1)
* ----------------------- FIRST LOOK FOR IF=(
USING DSECT,8
ANALCLC CLC CARD(0),1(R1)
B ANAL
ANAL2 MVC CARD,CARD+2
ANAL PUT SYSPRINT,CARD-8
WTO MF=(E,WTOCARD)
CLI CARD,C'('
BE ANALIF GETMAIN NEXT DSECT
LA R1,IFTBL-IFTBLL
LA R0,IFTBL#
LA R1,IFTBLL(R1)
SR R2,R2
ANALOOP IC R2,0(R1)
EX R2,ANALCLC
BE ANALIF
LA R1,IFTBLL(R1)
BCT R0,ANALOOP
ERR B,'$INVALID IF,AND,OR='
*
IFTBL DC AL1(3),CL9'IF=( ',CL2'I '
IFTBLL EQU *-IFTBL
DC AL1(6),CL9'IFAND=( ',CL2'IA'
DC AL1(5),CL9'IFOR=( ',CL2'IO'
DC AL1(4),CL9'AND=( ',CL2'A '
DC AL1(6),CL9'ANDOR=( ',CL2'AO'
DC AL1(7),CL9'ANDAND=( ',CL2'AA'
DC AL1(3),CL9'OR=( ',CL2'O '
DC AL1(6),CL9'ORAND=( ',CL2'OA'
DC AL1(5),CL9'OROR=( ',CL2'OO'
DC AL1(8),CL9'REPLACE=( ',CL2'R '
DC AL1(2),CL9'R=( ',CL2'R '
* EQU 11
IFTBL# EQU (*-IFTBL)/IFTBLL
DC X'FF'
*
* --------------------- OKAY, GOT IF=, INIT THE DSECT WE USE
ANALIF CLI CARD,C'R'
BNE *+8
MVI FLAGREP,C'R'
*
LR R14,R8
L R8,ELIST
LA R0,LDSECT(R8)
ST R0,ELIST
C R0,EGETMAIN
ERR BNL,'LIST OVERFLOW'
MVI 0(R8),0
MVC 1(LDSECT,R8),0(R8) INIT THE DSECT TO 000
MVC DSTRING1,SPACES
MVC DSTRING1,SPACES
MVC DDDNAME(12),SPACES
MVC DOPCODE(3),SPACES
MVI DFREQCHR,C' '
*
CLI CARD,C'('
BE SETCONT
MVC DOPCODE,IFTBLL-2(R1) SAVE OPCODE-CHARS
LA R1,CARD+1(R2) MOVE NEXT PARAM TO FRONT OF CARD
MVC CARD,0(R1)
B SETCONT+10
SETCONT MVI DCONTINU,C'C'
MVC CARD,CARD+1
* ---------------------------- NEXT DO LOCATION AND LENGTH OR EQ/NE/??
CLI CARD,C'+' FIRST, IS LOCATION RELATIVE?
BNE *+14 NO.
MVI DLOCPLUS,C'+' YES, INDICATE IT IS
MVC CARD,CARD+1 AND MOVE NEXT PARAM UP
*
LA R15,CARD
BAL R9,GET## GET THE ##
LTR R0,R0 Q. ERROR,
ERR BM,'$INVALID LOCATION' YES, SAY SO
STH R0,DLOC NO, SAVE LOC
* -------------------------GET LENGTH OR STRING COMPARE
CLI CARD,C'0' Q. LENGTH?
BL BRANGET NO, GET BRANCH COND
LA R15,CARD
BAL R9,GET##
LTR R0,R0
ERR BM,'$INVALID LENGTH'
STH R0,DLEN
B GETSTRIN
*
BRANGET LA R2,CARD+3 NO, WE HAVE (45,EQ,C'ABC' OR ?
LA R3,BRANCOND POINT TO CONDITIONS
LA R0,BRANCON#
BRANLOOP CLC CARD(2),0(R3)
BE BRANFND
* CLI 1(R3),C' '
* BNE BRANNEXT
* CLC CARD(1),0(R3)
* BNE BRANNEXT
* BCTR R2,0
* B BRANFND
BRANNEXT LA R3,4(R3)
BCT R0,BRANLOOP
ERR B,'$EQ/NE/GE/?? INVALID'
BRANFND MVC DBRANCHC(2),2(R3)
MVC CARD,0(R2)
* ----------------------- GET THE STRINGS
GETSTRIN LA R3,DTYPE1 LOOK FOR C'ABC',X'DEFG')
BAL R9,QSTRING OR C'ABD',X'DEFG',W=DD)
LA R14,DFREQPRE PRE LENG, POST LENG, CHAR
LA R15,DSTRING1-2 STRING LENG/STRING
BAL R9,QFREQ
*
CLI CARD,C',' OR C'ABC',W=DD)
BNE QEND NO 2ND STRING
MVC CARD,CARD+1
CLI CARD,C'W'
BE QWRITE
*
LA R3,DTYPE2
BAL R9,QSTRING
CLI CARD,C','
BNE QEND
*
QWRITE CLC =C'W=',CARD ,W=DD
BE SAVEDD
CLC =C'WRITE=',CARD
BNE NOTDD
MVC CARD,CARD+4 HERE, WE CAN WRITE TO 2 OR MORE
SAVEDD MVC DDDNAME,CARD+2 FILEES. WE CAN SAVE 2 NORMALLY.
MVC CARD,CARD+4 MORE THAN 2 AND WE NEED AN
CLI CARD,C')'
BE QEND
CLI CARD,C','
BNE NOTDD
MVC CARD,CARD+1
CLC =C'W=',CARD EXTRA TABLE ENTRY.
BNE QEND
MVC DDDNAME+6,CARD+2
MVC CARD,CARD+4
CLI CARD,C')'
BE QEND
CLI CARD,C','
BNE NOTDD
MVC CARD,CARD+1
CLC =C'W=',CARD
BNE QEND
*
LA R2,LDSECT(R8)
XC 0(LDSECT,R2),0(R2)
MVC 0(4,R2),=CL4'DCBL'
MVC 4(12,R2),DDDNAME
MVC DDDNAME(12),=CL12'EXTRA DD REC'
LA R5,LDSECT-8(R2)
LA R4,16(R2) 4+6+6=16
*
EXTRAW CR R4,R5
ERR BNL,'TOO MANY W= RERQUESTS'
*
PUT SYSPRINT,CARD-1
MVC 0(2,R4),CARD+2
LA R4,6(R4)
MVI R4,X'FF'
MVC CARD,CARD+4
CLI CARD,C')'
BE QEND
CLI CARD,C','
BNE NOTDD
MVC CARD,CARD+1 W=A1,W=A2,W=A3,W=A4
CLC =C'W=',CARD
BE EXTRAW
ERR B,'BAD W= LIST END'
*
NOTDD ERR B,'$UNKNOWN PARAM VALUE'
*
QEND CLI CARD,C')'
ERR BNE,'$UNKNOWN PARAM SYNTAX'
CLI CARD+1,C' '
BE ANALGET
CLC =C'), ',CARD
BE ANALGET
CLC =C'),',CARD
BE ANAL2
CLC =C',(',CARD+1
ERR BNE,'$UNKNOWN CONTINUATION'
MVC CARD,CARD+2
B ANAL
* ======================= SAVE HEX OR CHAR STRING ============
QSTRING MVC 0(1,R3),CARD
LA R0,L'DSTRING1-1 SET MAX LENGTH
CLI CARD,C'X'
BNE *+8
SLL R0,1
LA R15,CARD+2
*
QSTRINGA LA R15,1(R15) R15 = ENDING QUOTE
CLC CARD+1(1),0(R15)
BE QSTRINGB
BCT R0,QSTRINGA
ERR B,'$END QUOTE MISSING FROM STRING'
QSTRINGB LR R4,R15 C"A"
S R4,=A(CARD+3) R4 = LENGTH-1
CLI CARD,C'C'
BE QSTRINGC
CLI CARD,C'X'
ERR BNE,'$BAD DATA TYPE, C" AND X" ONLY'
*
QSTRINGX LA R0,1(R4)
ST R0,DW SAVE # CHARS
TM DW+3,1 Q. ODD # HEX CHARS?
ERR BNZ,'$ODD # HEX DIGITS' YEP, ERROR.
SRL R0,1 CALC # HEX CHARS
LR R1,R0
BCTR R1,0 # HEX CHARS-1
STH R1,1(R3) SAVE FOR CLC
*
STM R14,R1,DW
LA R15,CARD+2 POINT TO STRING
LA R14,3(R3) POINT TO DSECT
PACKHEX TRT 0(2,R15),TESTHEX-193
ERR BNZ,'$INVALID HEX DIGIT'
TR 0(2,R15),MAKEHEX-193
PACK 0(2,R14),0(3,R15)
LA R14,1(R14)
LA R15,2(R15)
BCT R0,PACKHEX
L R15,DW+4
*
MVC CARD,1(R15)
BR R9
*
MVC 3(0,R3),CARD+2
QSTRINGC STH R4,1(R3)
EX R4,QSTRINGC-6
MVC CARD,1(R15)
BR R9
* DETERMINE LEAST REQQUENTLY CHAR.
* R15 = STR LEN+STR
* R14 = PRE LENG, POST LENG, CHAR
*
* W/A = 60(R13)
*
QFREQ STM R14,R6,12(R13)
LA R6,2(R15) STR
LH R4,0(R15) LOAD COUNT-1
ST R4,0(R14) STORE PRE=0 + POST- LENG-1 INIT
MVC 4(1,R14),0(R6) FIRST CHAR
LA R0,1(R4) COUNT OF CHARS -1
LR R3,R6 SAVE START ADDR
SR R1,R1
MVI 60(R13),255 INIT WITH HIGHEST FREQ
QFREQL IC R1,0(R3) LOAD CHAR
LA R2,FREQTBL(R1) LOAD OFFSET INTO FREQ TBL
CLC 0(1,R2),60(R13) Q. LOWER THAN PRIOR LOW
BNL QFREQNXT NO.
QFREQSAV MVC 60(1,R13),0(R2) YES, SAVE FREQ VALUE
MVC 4(1,R14),0(R3) SAVE CHAR
LR R5,R3 SAVE LOC OF LEAST FREQ CHAR
QFREQNXT LA R3,1(R3) BUMP TO NEXT
BCT R0,QFREQL AND LOOP.
* -------------------- CALC OFSET TO BEG OR CHAR + LENGTH AFTER
QFREQZ LR R0,R5 ADDR OF LOC CHAR
SR R0,R6 CALC OFFSET TO LEAST FREQ CHAR
STH R0,0(R14) AND SAVE IT.
LR R1,R3 END
SR R1,R5 MINUS OFFSET TO LOW CHAR = CHARS PAST END
BCTR R1,0
STH R1,2(R14) SAVE
LM R14,R6,12(R13)
BR R9
*
LIST L R8,ALIST
MVC LINE,LINE-1
MVC LINE(3),DOPCODE OP=CODE + CONTINUE FLAG
UNPK LINE+4(5),DBRANCHC(3) BRANCH + OPPOSITE
TR LINE+4(4),HEX-240
* MVI LINE+8,C' '
LA R14,DLOC-1 LOCA, LEN, FREQ PRE, FREQ POST
LA R15,LINE+8
LA R0,4
BAL R3,LISTHW
*
MVC 1(1,R15),DFREQCHR LEAST FREQ FOUND CHAR
LA R2,2 2 STRING ENTRIES
LA R14,DTYPE1 STARTING WITH TYPE
LA R15,2(R15) PRINT LOC
LIST20 MVC 0(1,R15),0(R14) DATA TYPE
LA R15,1(R15) POINT TO STRING LEN
LA R0,1 1 HW CONSTANT
BAL R3,LISTHW PRINTABLE
*
CH R1,=H'7' Q. LONG
BNH *+8 NO.
LA R1,7 YES, 7 MAX (8 CHARS)
MVC 1(0,R15),1(R14)
EX R1,*-6
LA R15,10(R15) NEXT PRINT LOC
LA R14,DTYPE2 2ND STRING
CLI 0(R14),C'C' Q. VALID DATA TYPE C/X
BL LISTDD NO.
BCT R2,LIST20 YES, GO LIST IT TOO
LISTDD MVC 1(2,R15),DDDNAME SHOW 2 DDNAMES
PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
LA R8,LDSECT(R8)
CLI 0(R8),C'D'
BE *-8
C R8,ELIST
BL LIST+4
BR R9
*
LISTHW LH R1,1(R14)
CVD R1,DW
OI DW+7,X'0F'
UNPK 0(3,R15),DW+6(2)
MVI 0(R15),C' '
LA R15,3(R15)
LA R14,2(R14)
BCT R0,LISTHW
BR R3
*
* ======================= INPUT DONE, MORE SETUP ====================
ZZ CLI FLAGLIST,C'L'
BNE *+8
BAL R9,LIST
*
LA R2,IN
BAL R9,OPENIN
L R8,ALIST
CLI DOPCODE,C'I'
ERR BNE,'FIRST PARAM MUST BE IF'
L R7,ELIST
ST R7,ADCB
ST R7,EDCB
MVC TRTTBL+1(255),TRTTBL-255
SR R6,R6
ZZLOOP IC R6,DFREQCHR
LA R0,TRTTBL
SR R0,R6
ST R0,DTRTTBL
CLI DDDNAME,C' '
BNH ZZNEXT
*
USING FILES,7
MVC DW,SPACES
MVC DW(3),=C'OUT'
MVC DW+3(2),DDDNAME
L R7,ADCB
S R7,=A(LFILES)
QDDNAME LA R7,LFILES(R7)
C R7,EDCB
BNL SAVEDCB
CLC DW,FDD
BNE QDDNAME
ST R7,DDCB
MVC SAMEDD+10(6),DW
SAMEDD ERR B,' ALREADY SET UP'
B ZZNEXT
*
SAVEDCB LA R0,LFILES(R7)
ST R0,EDCB
C R0,EGETMAIN
ERR BNL,'MAX=## TABLE LENGTH EXCEEDED'
MVC FDD,DW
MVC DCBDDNAM-IHADCB+OUT(5),FDD
MVC FDCB,OUT
ZAP FCOUNT,P0
XC FEDIT,FEDIT
LA R2,FDCB
BAL R9,OPENOUT
ZZNEXT LA R8,LDSECT(R8)
C R8,ELIST
BL ZZLOOP
CLI FLAGREP,C' '
SR R10,R10
BE GET
*
L R0,DCBLRECL-IHADCB+IN
ST R0,LGETMREC
GETMAIN R,LV=(0)
ST R1,AGETMREC
B GET
DROP 7
LGETMREC DC F'0'
AGETMREC DC F'0'
* =================== SET UP DONE, PROCESSING NEXT =================
ENDREC DC 2F'0' END OF THE RECORD
AREC DC 2F'0' EDITED RECORD
EREC DC F'0' RECORD
LASTLOC DC F'0' LAST TESTED LOCATION
LREC DC F'0'
*
COPYREC CLI FLAGREP,C'R'
BNER R9
LR R1,R15 ONLY DO THIS IF R=(B,A) ETC
LR R14,R3 IS SPECIFIED.
L R0,AGETMREC WE NEED A 2ND COPY
MVCL R0,R14 TO PLAY WITH.
*
* READ A REC, MAKE A COPY IF REPLACE=( WAS SPECIFIED.
*
GET GET IN
LA R3,0(R1)
ST R3,AREC
ST R3,AREC+4
LA R10,1(R10)
AP #RECIN,P1
LH R15,DCBLRECL-IHADCB+IN
TM DCBRECFM-IHADCB+IN,X'40'
BNO *+8
LH R15,0(R3)
ST R15,LREC
LA R0,0(R15,R3)
LR R1,R0
STM R0,R1,ENDREC
BAL R9,COPYREC
*
MVC LINE(99),0(R3) DISPLAY THE REC FOR TESTING
WTO MF=(E,LINE-5)
MVC LINE,LINE-1
L R8,ALIST
B IF
*
* OKAY THIS, + EVAL, ARE THE HEART OF THE PROGRAM.
* REPLACE JUST DOES THAT.
* IF= AND= OR= ALL USE THE EVAL ROUTINE TO DO THE ANALSIS
* LET'S SEE WHAT HAPPENS.
*
NEXTIF LA R8,LDSECT(R8)
C R8,ELIST
BNL GET
CLI DOPCODE,C'I'
BNE NEXTIF
IF MVC AREC,AREC+4
MVC OPCODE,DOPCODE
ST R8,IFADDR
BAL R9,EVAL
C R8,IFADDR
BNE *+8
LA R8,LDSECT(R8)
C R8,ELIST
BNL GET
*
CLI GOOD,C'N' Q. ERROR
BE IFBAD
B IFGOOD
*
IFGOOD BAL R9,QREPLACE
BAL R9,NEXTOP
CLI DOPCODE,C'A'
BE AND
B NEXTIF
*
IFBAD BAL R9,NEXTOP
CLI DOPCODE,C'O'
BE OR
B NEXTIF
*
AND MVC OPCODE,DOPCODE
BAL R9,EVAL
CLI GOOD,C'N'
BNE IFGOOD
B NEXTIF
*
OR MVC OPCODE,DOPCODE
BAL R9,EVAL
CLI GOOD,C'N'
BNE IFGOOD
B NEXTIF
*
IFADDR DC F'0'
*
NEXTOP C R8,IFADDR
BNE *+8
NEXTOPL LA R8,LDSECT(R8)
ST R8,IFADDR
CLI DOPCODE,C'I'
BE IF
CLI DOPCODE,C'A'
BER R9
CLI DOPCODE,C'O'
BER R9
B NEXTOPL
*
QREPLACE CLI DOPCODE,C'R'
BNER R9
REPLACE LH R14,DSTRING1-2
LR R15,R3
AH R14,DLOC
MVC 0(0,R15),DSTRING2
EX R15,REPLACE-6
LA R8,LDSECT(R8)
BR R9
* --------------------------------------------------
* EVAL IS THE HEART OF THE PROGRAM. IT DOES ALL OF THE SCANS,
* BOTH LOC,EQ AND TRT LOC,LEN.
*
* IF THERE ARE REPEATED REQUESTS, EG FOR IFAND=
* IT DOES THEM ALL, UNTIL 'AND' FAILS.
* TOOK ME A WHILE TO UNDERSTAND WHAT CODE NEEDED.
* FIGURED IT OUT WHILE I SHOULD HAVE BEEN SLEEPING.
*
* THERE IS A PHILOSOPHY PROBLEM HERE. SUPPOSE THE REQUEST IS,
* IF=(1,EQ,C'A'),ANDAND=(2,EQ,C'B'),(3,EQ,C'C'),(4,EQ,C'D',WRITE=A1)
* AND #2 AND #3 FAIL, BUT #4 IS TRUE, DO WE DO THE WRITE?
* I THINK THE ANSWER IS "NO". AND IT'S LIKE AND= FAILS FOR THE NEXT
* 'REAL' REQUEST.
* HOWEVER, ONE COULD CODE
* IF=(1,EQ,C'A'),ANDOR=(2,EQ,C'B'),(3,EQ,C'C'),(4,EQ,C'D',WRITE=A1)
* THEN #4 WOULD WRITE IF MATCH.
*
* WHEN DOING THE SCAN, LOOK FOR THE LEAST FREQUENTLY USED CHAR,
* THAT WE GOT FROM THE FREQTBL, (FROM WIKIPEDIA, OH WELL).
* WHEN WE FIND A TARGET CHAR, BACK UP TO WHAT WOULD BE THE BEGINNING
* OF THE STRING, AND ALSO TEST TO SEE IF THE STRING IS PAST THE END
* OF THE RECORD, OR THE SEARCH LENGTH SPECIFIED.
* IF IT DOESN'T FIT, EXIT "NOT FOUND"
* IF IT DOES, THEN DO THE CLC,
* AND USE THE BRANCH CONDITION SPECIFIED BY THE USER.
* -----------------------------------------------------
FLAGREP DC C' '
GOOD DC C' '
OPCODE DC CL2' '
EVAL MVC OPCODE,DOPCODE
EVALOOP MVI GOOD,C'N'
L R3,LASTLOC LOAD LAST LOC
CLI DLOCPLUS,C'+' Q. RELATIVE LOC?
BE *+8 YES, USE IT
L R3,AREC NO, USE REAL RECORD LOCATION
LR R1,R3
CLI DBRANCHC,0 Q. TEST A SPECIFIC LOC?
BNE EVALEQ YES, GO DO THAT.
* NO, DO A TRT SCAN.
*
* OKAY, WE'RE GOING TO DO A SCAN, AND 'FOUND' = YES.
* FIRST CALC LOCATION TO START, AND 'ENDING' LOCATION,
* EITHER SPECIFIED, OR END OF RECORD.
*
LH R4,DLEN
LTR R4,R4
BZ USERECL
AR R4,R3
B USERECL+4
*
LA R1,1(R1) FOR FOUND NOT EQUAL, COME HERE.
*
USERECL L R4,ENDREC LOAD END OF REC
LH R2,DSTRING1-2 SUBT STRING LENGTH
LA R0,0(R2,R3) CALC A(END OF REC-STR LENGTH)
C R4,ENDREC Q. SCAN TO END OF RECORD?
BL *+12 NO, USE SPECIFIED LENGTH
L R4,ENDREC YES, USE REC LENG - STRING LENGTH
SH R4,DFREQPOS
*
L R14,DTRTTBL AND GET LOC FOR TRT.
*
EVALTRTL LR R2,R4 CALC END
SR R2,R1 - CURRENT
CH R2,=H'255' Q. SHORT (UNDER 256)
BNH EVALSHRT YES, GO DO SHORT TRT
TRT 0(256,R1),0(R14) NO, TEST 256 BYTES
BNZ EVALFND GO TO 'FOUND' ROUTINE
LA R1,256(R1) NOTHING, BUMP BY 256
B EVALTRTL AND TEST AGAIN.
*
TRT 0(0,R1),0(R14)
EVALSHRT EX R2,EVALSHRT-6 TEST
BZ EVALBAD
* ----------------------------------
EVALFND LR R15,R1
SH R15,DFREQPRE
LH R2,DSTRING1-2
EVALFNDC CLC 0(0,R14),DSTRING1
LH R2,DSTRING1-2
EX R2,EVALFNDC
BE EVALGOOD
B USERECL-4
* ------------------------------------
EVALEQ LR R2,R3
AH R2,DLEN
C R4,ENDREC
BH EVALRET
LR R2,R3
SH R2,DFREQPRE
LH R4,DSTRING1-2
IC R1,DBRANCHC+1
*
EX R4,EVALCLC
EX R1,BEVALRET
EVALGOOD MVI GOOD,C'Y'
ST R2,LASTLOC
CLI DDDNAME,C' '
BNH EVALRET
LA R5,DDDNAME
CLC =C'EXTR',0(R5)
BNE EVALPUT
LA R8,LDSECT(R8)
LA R5,4(R8)
USING FILES,7
EVALPUT L R7,2(R5)
PUT (7),(3)
AP FCOUNT,P1
LA R5,6(R5)
CLI 0(R5),C' '
BH EVALPUT
B EVALRET
DROP 7
EVALBAD MVI GOOD,C'N'
EVALRET CLI DCONTINU,C'C'
BNER R9
LA R8,LDSECT(R8)
CLI OPCODE+1,C'O'
BE EVALOOP+4
B EVALOOP
*
EVALCLC CLC 0(0,R3),DSTRING1
BEVALRET NOP EVALRET
* ------------------------------------
* ========================== WORK AREAS =======================
Z LM R2,R3,CLOSLIST
USING FILES,4
USING IHADCB,5
ZCLO L R4,0(R2)
LR R5,R4
TM DCBOFLGS,DCBOFOPN
BZ NOTOPEN
CLOSE ((4))
CLC =C'OUT',DCBDDNAM
BNE NOTOPEN
MVC LINE,LINE-1
MVC LINE(5),DCBDDNAM
LA R1,LINE+3+L'ED15
MVC LINE+5+(L'ED15),ED15
EDMK LINE+5+(L'ED15),FCOUNT
MVC LINE+6(L'ED15),0(R1)
PUT SYSPRINT,LINE-1
NOTOPEN LA R2,4(R2)
CR R2,R3
BL ZCLO
CLOSE (SYSPRINT)
*
L 13,4(13)
LM 14,12,12(13)
SR 15,15
BR 14
LTORG
*
LGETMAIN DC A(40) (LFILES+LDSECT)*5)
AGETMAIN DC F'0'
EGETMAIN DC F'0'
ALIST DC F'0'
ELIST DC F'0'
ADCB DC F'0'
EDCB DC F'0'
*
* BH=20 BL=40 BE=80 BRANCH CONDITIONS
BRANCOND DC CL2'EQ',X'8070' COND AND OPPOSITE
DC CL2'NE',X'7080'
DC CL2'GT',X'20D0'
DC CL2'H ',X'20D0'
DC CL2'NH',X'40B0'
DC CL2'LT',X'40B0'
DC CL2'L ',X'40B0'
DC CL2'M ',X'40B0'
DC CL2'GE',X'A050'
DC CL2'LE',X'C030',C' '
LBRANCO EQU 4
BRANCON# EQU (*-BRANCOND)/LBRANCO
*
* BRANCON# EQU 10
*
FLAGLIST DC C' '
OPENALLF DC C' '
P1 DC X'1C'
P0 DC X'0C'
ED15 DC 0CL20' ',X'40202020',4X'6B202020'
#RECIN DC PL8'0',CL16'RECORDS READ'
HEX DC C'0123456789ABCDEF'
DW DC 2D'0'
SAVEAREA DC 18F'0'
WTOCARD DC H'80,0'
DC CL8' PARM = '
CARD DC CL80' '
SPACES DC CL53' '
WTOLINE DC H'80,0',C' '
LINE DC CL133' '
TESTHEX DC 6X'00',41C' ',10X'00',6C' '
MAKEHEX DC X'0A0B0C0D0E0F',41C' ',X'00010203040506070809'
XL DC A(XL+4+X'97000000')
SR 0,0
CH R0,DCBLRECL-IHADCB+OUT
BNER 14
MVC DCBLRECL-IHADCB+OUT,DCBLRECL-IHADCB+IN
MVC DCBRECFM-IHADCB+OUT,DCBRECFM-IHADCB+IN
BR 14
PUSH PRINT
PRINT NOGEN
IN DCB DDNAME=IN,DSORG=PS,MACRF=GL,RECFM=FT,LRECL=399, X
EODAD=Z ,EXITLIST=XL
LIN EQU *-IN
*UT DCB DDNAME=OUT,DSORG=PS,MACRF=PM,EXLST=XL
OUT DCB DDNAME=OUT,DSORG=PS,MACRF=PM,RECFM=FT,LRECL=133
LOUT EQU *-OUT
SYSPRINT DCB DDNAME=SYSPRINT,DSORG=PS,MACRF=PM,RECFM=FT,LRECL=133
LSYSP EQU *-SYSPRINT
SYSIN DCB DDNAME=SYSIN,DSORG=PS,MACRF=GL,RECFM=FT,LRECL=80,EODAD=ZZ
LSYSIN EQU *-SYSIN
POP PRINT
*
DC 255X'00'
TRTTBL DC X'FF'
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
*
*
@@PAD#0 EQU *-SPLITOUT+4096
@@PAD#1 EQU @@PAD#0/(4097)
@@PAD#2 EQU (@@PAD#1*4096)
ORG SPLITOUT+@@PAD#2
*
* =================================================
FILES DSECT
FDCB DS XL100'00' DCB
FDD DS D DDNAME
FCOUNT DS D PL8 REC COUNT
FEDIT DS F EDIT LOC
DS 0D
LFILES EQU *-FILES
* ----------------------------------
DSECT DSECT
DOPCODE DS CL2 OP-CODE I,J,K A,B,C O,P,Q
DCONTINU DS C CONTINUATION OF OPCODE
DBRANCHC DS 2X BRANCH COND AND REVERSE
DLOCPLUS DS C LOC=+23
DLOC DS H STRING LOCATION
DLEN DS H LENGTH
*
DFREQPRE DS HL2
DFREQPOS DS HL2
DFREQCHR DS C
*
DTYPE1 DS C STRING-1 DATA TYPE
DS HL2 STR LENGTH
DSTRING1 DS CL12 STRING (I'LL MAKE IT LONGER LATER)
DSTRINGL EQU *-DSTRING1
*
DS 0H
DS CL1
DTYPE2 DS C STRING-2 DATA TYPE
DS HL2 STR-2 LENGTH
DSTRING2 DS CL12 STRING-2
*
DTRTTBL DS F
DDDNAME DS CL2
DDCB DS AL4
DS CL6
DS 0D
LDSECT EQU *-DSECT
* =================================================
* DCBD DEVD=DA
*
END SPLITOUT