Program in development. Not public. Licensed.
AGO .START
C:\USERS\LIN\DOCUMENTS\Z390CODE\SPLITNEW
SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\SPLITNEW
SET SYSPRINT=%G%.SYSPRINT
SET SYSIN=%G%.SYSIN
SET IN=%G%.INPUT
SET OUT=%G%.OUT
SET BREAK=%G%.BRAKE.BRAKE.TXT
BAT\ASMLG %G%.MLC TEST(BREAK)
C:\USERS\LIN\DOCUMENTS\Z390CODE\QBREAK
SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\SPLITNEW
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
PROGRAM CONSTRUCTION:
- NORMAL INIT STUFF.
- OPEN FILES, GO TO GETSYSIN
- COMMON SUBROUTINES
- SUROUTINES USED BY CARD ANAL
- GETSYSIN READ SYSIN AND SET UP DSECT TABLE.
USES ROUTINES ABOVE
-ZZ EODAD ON SYSIN
GET READ DATA RECORD, SAVE BEG,END ADDRESS
- IF, AND, OR LOGIC
- EVAL IS REALLY THE HEART OF THE RECORD ANALYSIS
IF THERE ARE MULTIPLE PARAMS, IT DOES THEM ALL.
-Z CLOSE, FREEMAIN, LIST COUNTS, END
V02.01 ORIGINAL WRITE. GOT PRETTY SPHECETTIIE
V02.02 REWRITE OF FIELD HANDLING. ABANDONED.
V02.03 ADDED FIELDS TO SAVE REC FOR ERR ROUTINE.
.START ANOP
* --------INTERESTING. ABOUT 10% OF THE MEMORY USED BY ERR MSGS.------
MACRO
&LBL ERR &BC,&MSG
LCLC &L
LCLA &N
&N SETA K&MSG-3
&L SETC 'SYS&SYSNDX'
&LBL REVB &BC,&L.Z
BAL R14,ERR
&L.L DC AL1(&N) L'&L.M-1)
&L.M DC C&MSG
&L.Z DS 0H
MEND
* ---------------------------------
MACRO
&LBL $$LA ®,&FLD $$LA REVB ????
AIF ('&FLD(1,1)' NE '(').A
&LBL LA ®,0&FLD
MEXIT
.A ANOP
&LBL LA ®,&FLD
MEND
* ---------------------------------
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 MNOTE ,'CANNOT DO REVB R#,MSG'
MEND
* ---------------- FOR EVAL ROUTINE AFTER COMPARE ---------
MACRO
&LBL YES ,
CLI EVALOPC+1,C'A' Q. DOES STRING MATCH RECORD
BE *+8 YES, LEAVE IT ALONE
MVI GOOD,C'N'
MEND
MACRO
&LBL NO ,
CLI EVALOPC+1,C'A' Q. DOES STRING MATCH RECORD
BE *+8 IF 'AND' TURN OFF.
MVI GOOD,C'N'
MEND
* ---------------------------------
SPLITNEW START 0
USING *,13,12,11
YREGS
B BEGIN-*(15)
DC 17F'0'
IDMSG DC CL44'SPLITNEW V01.03 ASM &SYSDATE &SYSTIME'
*
BEGIN STM 14,12,12(13)
ST 15,8(13)
ST 13,4(15)
LA 13,0(15)
LA 10,4095
LA 12,1(13,10)
LA 11,1(12,10)
LA 10,1(11,10)
L 1,0(1)
LH 2,0(1)
SH 2,=H'1'
BM *+14
MVC CARD(0),2(1)
EX 2,*-6
*
LA R2,SYSPRINT
BAL R9,OPENSYSP
LA R2,SYSIN
BAL R9,OPENI
LA R2,IN
BAL R9,OPENI
LA R5,$$PARAM
CLI CARD,C' '
BNE GOTPARA
*
GETPARA BAL R14,GETCARD
CLI 0(R1),C' '
BE GETPARA
B GOTPARA+4
GOTPARA BAL R14,PUTCARD
B QPARAM
* =========================== OPEN + ERR ROUTINES =========
PUSH PRINT
PRINT NOGEN
USING IHADCB,2
OPENSYSP MVC DW,DCBDDNAM
OPEN ((2),OUTPUT)
MVC LINE(L'IDMSG),IDMSG
PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
B LISTDCBM
OPENOUT MVC DW,DCBDDNAM
SR R0,R0
CH R0,DCBLRECL
BNE OPENO
MVC DCBRECFM,DCBRECFM-IHADCB+IN
MVC DCBLRECL,DCBLRECL-IHADCB+IN
B OPENO
OPENI MVC DW,DCBDDNAM
OPEN ((2),INPUT)
MVC OPENMSG+12(3),=C' IN'
B LISTDCBM+6
OPENMSG DC C' OPENED FOR OUTPUT, RECFM= LRECL=..... '
OPENO OPEN ((2),OUTPUT)
LISTDCBM MVC OPENMSG+12(3),=C'OUT'
UNPK OPENMSG+26(3),DCBRECFM(2)
TR OPENMSG+26(2),HEX-240
MVI OPENMSG+28,C' '
LH R0,DCBLRECL
CVD R0,16(13)
OI 23(13),X'0F'
UNPK OPENMSG+35(5),21(3,13)
MVC LINE(8),DW
MVC LINE+8(L'OPENMSG),OPENMSG
DROP 2
POP PRINT
*
PUTLINE PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
BR R9
* -------------------THIS IS BOTH A MSG AND AN ERROR MSG RTN---------
* IF MSG STARTS WITH BLANK, IT'S A MSG
* IF MSG STARTS WITH $, PRINT CARD
MVC LINE+11(0),1(R14)
ERR LA 14,0(14)
ST 14,DW
LR 15,14
SR 15,13
ST 15,8(13)
MVC LINE,LINE-1
MVC LINE(3),=C'MSG'
UNPK LINE+4(5),10(3,13)
TR LINE+4(4),HEX-240
MVI LINE+8,C' '
IC 15,0(14)
CLI 1(R14),C' '
BE ERRMSG
MVC LINE(3),=C'ERR'
MVC LINE+11(7),=C'ROUTINE'
MVC LINE+19(8),0(R5)
CLI 0(R14),1
BNE *+14
MVC LINE+19(26),=CL26'UNKNOWN OR INVALID PARAM'
B ERR$
ERRMSG EX R15,ERR-6
CLI LINE+11,C' '
BNE *+10
MVC LINE(3),=C'MSG'
*
ERR$ CLI 1(R14),C'$' IF ERR MSG STARTS WITH $, THEN
BNE ERRPUT PRINT, THE CURRENT CARD IMAGE.
PUT SYSPRINT,CARD-8
MVI LINE+11,C' '
ERRPUT PUT SYSPRINT,LINE-1
L 14,DW
CLI 1(R14),C' '
BE ERRRET
ABEND 1
**ABEND AFTER ERROR FOUND
*
ERRRET MVC LINE,LINE-1
LA R15,240
SH R14,=H'8'
EX R15,0(R14)
* ------------------------------- GET A # FROM R15 INTO R0 ---
PACK## PACK DW,0(0,R14)
GET##0 MVI 0(R15),C'0'
GET## CLI 0(R14),C'0'
ERR BL,'$## NOT NUMERIC'
**LOCATION,LENGTH BOTH USE THE GET## ROUTINE.
**WRITE= ALSO USES IT FOR FIELD SELECTION.
* BLR R9
CLI 1(R14),C'0'
BNL NOTSINGL
IC R0,0(R14)
N R0,=F'15'
STH R0,0(R15)
LA 1,1(R14)
B GET##Z
*
NOTSINGL LA R0,2(R14)
LR R1,R14
LA R1,1(R1)
CLI 0(R1),C'0'
BNL *-8
*
CLI 0(R1),C','
BE GET##LA
CLI 0(R1),C' '
BE GET##LA
CLI 0(R1),C')'
* BE GET##LA
ERR BNE,'$## SYNTAX ERROR'
**END OF GET## PROCESSING. DIDN'T FIND COMMA OR )BLANK OR ),
**AND DON'T KNOW WHAT TO DO NEXT.
*
GET##LA ST R1,DW+8
LA R1,1(R1)
SR R1,R0
EX R1,PACK##
CVB R0,DW
LTR R0,R0
BP GET##STH
CLI 0(R15),C'0'
ERR BNE,'## CANNOT BE 0'
GET##STH STH R0,0(R15)
**GET## ROUTINE FOUND 00 WHICH CANNOT BE USED FOR LOCATION.
L R1,DW+8
GET##Z CLI 0(R1),C')'
BE *+8
LA R1,1(R1)
MVC CARD,0(R1)
BR R9
* ================================= SYSIN PROCESSING KEYWORDS ======
* ----------------------- GETMAIN MAIN TABLE AND INIT -----------
LGETMAIN DC F'20'
AGETMAIN DC F'0'
ATABLE DC F'0'
ETABLE DC F'0'
AFILES DC F'0'
EFILES DC F'0'
* ----------------------------
INITDSCT DC CL5' ',XL2'00',C' ',XL8'00',CL2' ',XL2'00',CL12' '
LINIDSEC EQU *-INITDSCT
INIDSECT MVC 0(LINIDSEC,R8),INITDSCT
BR R9
USING DSECT,8
GETDSECT L R8,ETABLE -----STRING----
LTR R8,R8
BZ GETMAIN
LA R0,LDSECT(R8)
ST R0,ETABLE
C R0,AFILES
ERR BNL,'TABLE OVERFLOW'
**TABLE PROCESSING PUTS ELEMENTS AT THE BEGINNING OF THE GETMAIN,
**AND DCB'S AT TTHE END. TRYING TO LOAD A DCB AND NEED LARGER GETIAIN.
MVI 0(R8),0
MVC 1(LDSECT-1,R8),0(R8)
BR R9
*
GETMAIN L R0,LGETMAIN
AH R0,=H'5'
SLL R0,8
ST R0,LGETMAIN
GETMAIN R,LV=(0)
ST R1,AGETMAIN
ST R1,ATABLE
ST R1,ETABLE
A R1,LGETMAIN
ST R1,AFILES
ST R1,EFILES
B GETDSECT
* ------------------------------ SAVE A DCB TO WRITE A RECORD -----
GETDCB L R2,AFILES
USING FILES,2
MVC FDCB,OUT
MVC DCBDDNAM-IHADCB(8,R2),DW
MVC FDDNAME,DW
ZAP FCOUNT,P0
* BAL R9,OPENOUT
B OPENOUT
* ------------------------------ GET OPCODE FOR EQ,NE,GT,GE,LT,LE ----
CCTABLE DC C'EQ',X'8070'
DC C'NE',X'7080'
DC C'GT',X'20D0'
DC C'GE',X'A060'
DC C'LT',X'40B0'
DC C'LE',X'C030'
DC C' '
TESTEQ LA R1,CCTABLE
CLC CARD(2),0(R1)
BE THISEQ
LA R1,4(R1)
CLI 0(R1),C'A'
BNL TESTEQ+4
ERR BNE,'$INVALID COMPARE TYPE'
**(LOCATION,BRANCH CONDITION ERROR. VALIED OPTIONS ARE
**EQ, NE, GT, GE, LT, LE
THISEQ MVC DEQ,2(R1)
MVC CARD,CARD+3
BR R9
* --------------------------- PUT LENGTH-1 AND STRING IN PRT LINE ----
QSTRING CLI CARD+1,X'80'
ERR BNL,'$STRING QUOTE INVALID'
**(LOC,LEN,C' ' OR C" " OR X" " BAD QUOTE
LA R0,L'DSTRING-1
LA R2,CARD+2
LA R15,LINE
CLI CARD,C'X'
BE QSTRINGX-2
QSTRINGA LA R2,1(R2)
CLC CARD+1(1),0(R2)
BE QSTRINGB
BCT R0,QSTRINGA
ERR B,'$CHAR STRING TOO LONG'
**C" " MAX STRING LENGTH EXCEECED.
QSTRINGB LR R1,R2
S R1,=A(CARD+3)
QSTRINGZ STH R1,0(R15)
MVC 2(0,R15),CARD+2
EX R1,*-6
MVC CARD,1(R2)
BR R9
*
LR R14,R15
QSTRINGX TRT 0(2,R2),TESTHEX-193
ERR BNZ,'$INVALID HEX'
**LOOKING FOR X'ABCD1234' AND FOUND NON HEX CHARACTER.
MVC DW(2),0(R2)
TR DW(2),MAKEHEX-193
PACK 2(2,R14),DW(3)
LA R14,1(R14)
LA R2,2(R2)
CLC CARD+1(1),0(R2)
BE QSTRINGY
CLI 0(R2),C'A'
ERR BL,'$INVALID HEX'
**LOOKING FOR X'ABCD1234' AND FOUND NON HEX CHARACTER.
BCT R0,QSTRINGX
ERR B,'$HEX STRING TOO LONG'
QSTRINGY LR R1,R14
SR R1,R15
STH R1,0(R15)
MVC CARD,1(R2)
BR R9
* ------------------------------- GET THE OPCODE ----------
* ONLY TEST 4 BYTES. IF THEY MATCH, SET OPCODE IN DSECT.
* THEN LOOK FOR =( AND MOVE AFTER THAT TO FRONT OF CARD.
* SO EACH TABLE ENTRY IS 2 BYTES OF OPCODE AND FIRST 4 BYTES OF KEYWORD
*
IFTBL DC CL6'I IF=('
DC CL6'IAIFAN'
DC CL6'IOIFOR'
DC CL6'A AND='
DC CL6'AAANDA'
DC CL6'AOANDO'
DC CL6'O OR=('
DC CL6'OAORAN'
DC CL6'OOOROR'
DC C' '
*
GETIF LA R2,IFTBL-6
LA R2,6(R2)
CLC CARD(4),2(R2)
BE IFFOUND
CLC 2(4,R2),CARD
BE IFFOUND
CLI 6(R2),C' '
BH GETIF+4
GETIFERM MVC GETIFERR+10(6),CARD
GETIFERR ERR B,'$...... IS NOT A VALID KEYWORD='
**INVLID ELEMENT KEY. VALID KEYS ARE:
IFFOUND MVC DOPCODE(2),0(R2)
LA R1,CARD
LA R0,8
IFFLOOP LA R1,1(R1)
CLC =C'=(',0(R1)
BNE *+12
MVC CARD,2(R1)
BR R9
BCT R0,IFFLOOP
ERR B,'$=( NOT FOUND AFTER KEY='
**EG, LOOKING FOR ANDAND=( DIDN'T FIND =(
*
MOVSYS5 MVC CARD,CARD+5
QPARAM CLI CARD,C'I'
BE GOTSYSIN
CLI CARD,C' '
BE GETSYSIN
LA R5,$$PARAM
CLC =C'TEST',CARD
BNE *+12
MVI FLAGTEST,C'T'
B MOVSYS5
CLC =C'LIST',CARD
BNE *+12
MVI FLAGTEST,C'L'
B MOVSYS5
CLC =C'MAX=',CARD
ERR BNE,'$UNKNOWN KEYWORD'
**DURING INITIALIZATION, WE CAN HAVE TEST,LIST,MAX=##
**FOR TESTING DISPLAYS, AND TO MAKE GETMAIN LARGER.
**## MEANS # OF ELEMENTS, WITH SPACE FOR BOTH ELEMENT AND DCB
LA R14,CARD+4
LA R15,LGETMAIN+2
BAL R9,GET##
CLI CARD,C' '
BE GETSYSIN
CLI CARD,C'I'
BE GOTSYSIN
B QPARAM
*
$$PARAM DC CL8'PARAM' THESE ARE USED TO KEEP TRACK OF
$$KEY DC CL8'KEY=' WHAT WE'RE DOING.
$$LOC DC CL8'LOCATION' MAYBE MOST HANDY IN THE ERR ROUTINE.
$$LEN DC CL8'LENGTH'
$$STRING DC CL8'STRING'
$$EDIT DC CL8'EDITSTR'
$$WRITE DC CL8'WRITE='
$$LIST DC CL8'LIST'
$$MAIN DC CL8'MAIN'
$$CONT DC CL8'CONTINUE'
$$QFREQ DC CL8'QFREQ '
*
GETCSAV DC CL80' '
DC 2F'9'
GETCARD ST R14,GETCARD-8
GETCARDG GET SYSIN
CLI 0(R1),C' '
BE GETCARDG
ST R1,GETCARD-4
MVC CARD-7(5),=C'SYSIN'
MVC CARD,0(R1)
MVC SAVE1,CARD
MVC SAVE2,CARD
B PUTCARDP
PUTCARD ST R14,GETCARD-8
CLC GETCSAV,CARD
BER R14
PUTCARDP PUT SYSPRINT,CARD-8
MVC GETCSAV,CARD
L R14,GETCARD-8
BR R14
* ==========================MAIN LINE INIT ========================
DC F'0'
GETSYSIN BAL R14,GETCARD
ST R1,GETSYSIN-4
MVC CARD-7(5),=C'SYSIN'
B GOTSYSIN
CHKCONT LA R5,$$CONT
EX 0,*
TRYNEXT MVC CARD,CARD+2 AS IN IF=(...),AND=
B GOTSYSIN
GOTSYSIN CLI CARD,C' '
BE GETSYSIN
BAL R14,PUTCARD
CLI CARD,C'I'
BE SYSINBEG
CLI CARD,C'A'
BE SYSINBEG
CLI CARD,C'O'
BE SYSINBEG
MVC GOTSYERR+10(6),CARD
GOTSYERR ERR B,'$...... IS NOT A VALID KEYWORD='
**ANOTHER TEST FOR IF/AND/OR WHEN ELEMENTS ARE CONTINUED IN SYSIN
* ------------------------------------------------
GETCONT BAL R14,GETCARD
LA R5,$$CONT
CLI CARD,C'('
BE DOCONT1
ERR B,'INVALID CONTINUATION'
**EXPECTED IFOR=( ),( ),( ) AND "(" NOT FOUND
DOCONT3 MVC CARD,CARD+2
DOCONT1 MVC CARD,CARD+1
BAL R14,PUTCARD
BAL R9,GETDSECT
BAL R9,INIDSECT
MVI DOPCODE+2,C'C'
B TESTLOC
* ------------------------------------------------
SYSINBEG LA R5,$$KEY
BAL R9,GETDSECT IF=(1,EQ,C'ABC OR X'C1C2'
BAL R9,INIDSECT IF=(1,0,C'ABC')
BAL R9,GETIF IF=(1,EQ,C'ABC',WRITE=DDNAME,DDNAME)
TESTLOC LA R5,$$LOC
CLI CARD,C'+'
BNE *+14
MVI DLOCPLUS,C'+'
MVC CARD,CARD+1
* ---------------------
CLI CARD,C'0'
ERR BL,'$INVALID LOC'
**=(LOC,EQ,...) LOCATION NOT NUMERIC
LA R5,$$LEN
LA R14,CARD
LA R15,DLOC
BAL R9,GET##
* ---------------------
CLI CARD,C'0'
BNL GETLEN
BAL R9,TESTEQ
B GETSTR
GETLEN LA R14,CARD
LA R15,DLEN
BAL R9,GET##0
* ---------------------
GETSTR MVC DTYPE,CARD
LA R5,$$STRING
LA R15,DSTRING-2
BAL R9,QSTRING
*
CLI DEQ,0
BNE *+16
LA R15,DSTRING-2
LA R14,DFREQPRE
BAL R9,QFREQ
*
CLI CARD,C' '
BE GETSYSIN
CLC =C') ',CARD
BE GETSYSIN
CLC =C',W',CARD
BE CHKWRITE
CLC =C'),(',CARD
BE DOCONT3
CLC =C'), ',CARD
BE GETCONT
CLC =C'),',CARD
BE TRYNEXT
*
CLI CARD,C'C'
BE GETEDIT
CLI CARD,C'X'
BE GETEDIT
CLI CARD,C','
ERR BNE,'$SYNTAX ERR AT WRITE OR CONTINUATION'
**AT END OF KEY=( ) DIDN'T FIND EXPECTED COMMA, WRITE=, OR ???
MVC CARD,CARD+1
GETEDIT LA R5,$$EDIT
CLI CARD,C'C'
BE GETNXDSE
CLI CARD,C'X'
BE GETNXDSE
CLC =C',C',CARD
BE GETNXDSE-6
CLC =C',X',CARD
BE GETNXDSE-6
ERR B,'$SYNTAX ERR LOOKING FOR EDIT STRING'
**AFTER KEY=(LOC,EQ, ONLY C" OR X" ALLOWED. NOT FOUND.
MVC CARD,CARD+1
GETNXDSE ST R8,DW+4
BAL R9,GETDSECT
MVC DOPCODE,=C'RR'
** LA R15,LINE
BAL R9,QSTRING
MVC DSTRING-2(L'DSTRING+2),LINE
MVC LINE,LINE-1
L R8,DW+4
*
* SET UP WRITE=DDNAME1,DDNAME2,DDNAME3)
*
* FIRST CHECK TO SEE IF WE HAVE A WRITE COMMAND.
* THEN ISOLATE THE DDNAME, UP TO 8 CHARS, AND SAVE IT IN DW.
* SEE IF WE ALREADY HAVE IT AND IT'S OPEN
* IF YES, SAVE THAT DCB ADDR IN THIS ENTRY
* NO, SET UP NEW DCB WITH DDNAME AND OPEN IT. CHECK FOF OVERFLOW TOO.
*
CHKWRITE LA R5,$$WRITE
CLI CARD,C','
BNE *+10
MVC CARD,CARD+1
CLI CARD,C'W'
ERR BNE,'$UNKNOWN COMMAND LOOKING FOR WRITE'
**AFTER KEY=(....., DIDN'T FIND ) OR WRITE=
CLC =C'W=',CARD
BE CHKWRIA
CLC =C'WRITE=',CARD
ERR B,'$UNKNOWN COMMAND, LOOKING FOR WRITE'
**EXPECTED WRITE= AND DIDN'T FIND IT. OR ELEMENT DIDN'T END WITH )
MVC CARD,CARD+4
CHKWRIA MVC CARD,CARD+2
* -------------------------- ISOLATE THE NAME IN DW --------------
CHKWRIB LA R3,CARD
LA R3,1(R3)
CLI 0(R3),C'A'
BNL *-8
LR R1,R3
S R1,=A(CARD+1)
LA R0,8
CR R1,R0
ERR BH,'DDNAME TOO LONG'
**AW, COME-ON, YOU KNOW DDNAMES CAN'T BE MORE THAN 8 BYTES.
MVC DW,SPACES
MVC DW(0),CARD
EX R1,*-6
* ----------------------------- CHK TO SEE IF WE ALREADY HAVE THE DD.
CHKWRIC MVC DUPMSG+10(8),DW
MVC CARD,0(R3)
LM R2,R3,AFILES
CR R2,R3
BE CHKDCBA
USING FILES,2
CHECKDUP CLC DW,FDDNAME
BE DUPMSG
LA R2,LFILES(R2)
CR R2,R3
BNH CHECKDUP
B CHKDCBA
DUPMSG ERR B,' ...... ALREADY OPEN'
**DDNAMES (FILES) CAN BE WRITTEN TO BY MULTIPLE REQUESTS.
**THIS INDICATES THAT A PRIOR REQUEST HAS ALREADY SPECIFIED THAT FILEL.
B CHKDCBN BRANCH PAST THE OPEN
* ------------------- SAVE DCB ADDR IN THE LIST. (6 MAX)
* ------------------- CHECK FOR START OF LIST, AND FOR LIST OVERFLOW.
CHKDCBA L R2,AFILES
SH R2,=AL2(LFILES)
ST R2,AFILES
* GOT THE ADDRESS TO PUT THE DCB.
* NEXT MAKE SURE WE DON'T OVERRUN THE END OF THE LIST IN THE MAIN TBL
LA R0,DTRTTBL
L R1,DDCB-4 LIST INDEX
LTR R1,R1 Q. FIRST TIME?
BNZ *+8 NO.
LA R1,DDCB-4 YES, FIRST LIST ENTRY-4
LA R1,4(R1) BUMP TO FIRST/NEXT
ST R2,0(R1) SAVE DCB ADDR IN LIST
ST R1,DDCB-4 SAVE LIST LOC
CR R1,R0 Q. PAST END OF LIST?
ERR BNL,'TOO MANY WRITE= FILES' YES, ERROR.
*
CHKDCBB BAL R9,GETDCB SET UP AND OPEN TEH FILE
* ------------------------------- CHECK TO SEE IF THERE ARE MORE FILES.
* MAYBE ON CONTINUATION RECORDS.
CHKDCBN CLC =C') ',CARD
BE GETSYSIN
CLC =C'),(',CARD
BE DOCONT3
CLC =C'), ',CARD
BNE CHKWRICL
BAL R14,GETCARD
LA R5,$$CONT
CLI CARD,C'('
BE DOCONT1
ERR B,'UNKNOWN CONDITION'
**AGAIN LOOKING AT END OF KEY=(.... FOR ) OR W= AND NOT FINDING IT.
*
CHKWRICL CLI CARD,C','
ERR BNE,'$SYNTAX ERROR IN WRITE= CONTINUATION'
MVC CARD,CARD+1
CLI CARD,C'A'
ERR BL,'$UNKNOWN WRITE= SYNTAX'
**MORE WRITE= SYNTAX CHECKING. MORE WRITE= SYNTAX CHECKING.
MVC CARD,CARD+1
B CHKWRIB
*
LA R0,1
LISTUNPK LH R1,0(R15)
CVD R1,DW
OI DW+7,X'0F'
UNPK 0(3,R2),DW+6(2)
MVI 0(R2),C' '
LA R2,3(R2)
LA R15,2(R15)
BCT R0,LISTUNPK
BR R7
*
LIST L R8,ATABLE
LA R5,$$LIST
LISTL LA R2,LINE+2
MVC 0(5,R2),DOPCODE
UNPK 6(5,R2),DEQ(3)
TR 6(4,R2),HEX-240
MVI 10(R2),C' '
LA R2,LINE+11
LA R15,DLOC
LA R0,4
BAL R7,LISTUNPK
MVC 1(1,R2),DTYPE
LA R2,3(R2)
LA R15,DSTRING-2
BAL R7,LISTUNPK-4
LH R3,DSTRING-2
MVC 0(0,R2),DSTRING
EX R3,*-6
PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
LA R8,LDSECT(R8)
CLI DOPCODE,C'R'
BE *-8
C R8,ETABLE
BL LISTL
BR R9
* ====================== SET UP DONE, PROCESS ===========
ZZ BAL R9,LIST
LA R5,$$MAIN
B GET
BEGEND DC 4F'0'
GET GET IN
AP #IN,P1
LA R3,0(R1)
LH R4,DCBLRECL-IHADCB+IN
TM DCBRECFM-IHADCB+IN,X'80'
BO *+8
LH R4,0(R3)
AR R4,R3
STM R3,R4,BEGEND
STM R3,R4,BEGEND+8
L R8,AGETMAIN
BAL R9,EVAL
B GET
* ---------------------------------
EVOP DC 2F'0'
EVAL MVC EVOP,DOPCODE
CLI EVOP+4,C'A'
BNO *+8
MVI EVOP,C'A'
SR R2,R2
LH R3,DLOC
LH R4,DLEN
LA R5,0(R3,R4)
L R1,GET-8
AH R1,DLOC
CLI DEQ,0
* BE SCAN
* A R3,GET-8 LOC+OFFSET
* LH R2,DSTRING-2
* EVALCLC CLC 0(0,R1),DSTRING
* EX R2,EVALCLC
* BE EVALY
* EVALN NO
* B EVALNEXT
* EVALY YES
* EVALNEXT QNEXT
*
* ====================== ALL DONE, CLOSE AND EXIT =======
Z BAL R9,CLOSE
L 13,4(13)
LM 14,12,12(13)
SR 15,15
BR 14
*
CLOSE DS 0F
BAL R3,CLOSEL
DC A(SYSIN,IN,OUT,SYSPRINT,0)
CLOSEL L R2,0(R3)
LTR R2,R2
BZR R9
LA R3,4(R3)
TM DCBOFLGS-IHADCB(R2),DCBOFOPN
BZ CLOSEL
CLOSE ((2))
B CLOSEL
LTORG
#IN DC PL8'0'
FLAGLIST DC C' '
FLAGTEST DC C' '
P0 DC X'0C'
P1 DC X'1C'
DW DC 2D'0'
HEX DC C'0123456789ABCDEF'
DC CL9' PARM= '
CARD DC 2CL80' '
DC CL9' RECORD='
SAVE1 DC 2CL80' '
DC CL9' REQUST='
SAVE2 DC 2CL80' '
LINE DC CL133' '
* ---------------------------------
PUSH PRINT
PRINT NOGEN
IN DCB DDNAME=IN,DSORG=PS,MACRF=GL,RECFM=FT,LRECL=399,EODAD=Z
OUT DCB DDNAME=OUT,DSORG=PS,MACRF=PM
SYSIN DCB DDNAME=SYSIN,DSORG=PS,MACRF=GL,RECFM=FT,LRECL=80,EODAD=ZZ
SYSPRINT DCB DDNAME=SYSPRINT,DSORG=PS,MACRF=PM,RECFM=FT,LRECL=133
POP PRINT
* -------------------------------------------------
*
* NEW FREQ CALC IS A BIT SHORTER AND MUCH CLEANER.
* MOVE STRING TO W/A W/A = SAVEAREA IF LENGTH LESS THAN 50
* TRANSLATE STRING TO FREQ VALUES
* FIND LOWEST FREQ VALUE
* CALC POST LEN (LENGTH AFTER CHAR)
* PRE LEN (LEN BEFORE CHAR) AND SAVE 'EM BOTH
* GET LOW CHAR AND SAVE THAT.
* RELOAD WORK REGS AND RETURN
*
TR 0(0,R3),QFREQTBL
MVC 0(0,R3),2(R15)
QFREQ STM R2,7,54(R13) 15 = STRING LENGTH
LA R3,8(13) 14 = PRE-LEN, POST-LEN, CHAR
LA R5,$$QFREQ POINT TO ROUTINE WE'RE IN
LH R1,0(R15)
EX R1,QFREQ-6 MOVE STRING TO WORK AREA (UP TO 50)
EX R1,QFREQ-12 TRAN TO FREQ VALUES
LR R0,R1 LOAD CHAR COUNT-1
LR R4,R3 POINT TO FIRST FREQ VALUE
LR R7,R3 R7 = PLACE TO SAVE LOWEST
LA R6,1(R3,R1) R6 = LAST TO CALC POST LEN (CHARS AFTER)
QFREQL CLC 0(1,R4),0(R7) Q. IS THIS THE LOWEST SO FAR?
BNL *+6 NO
LR R7,R4 YES, SAVE IT
LA R4,1(R4) BUMP TO NEXT
BCT R0,QFREQL AND LOOP
LR R0,R6 CALC LAST
SR R0,R7 - LOW LOC
STH R0,2(R14) = POST LENG, SAVE IT
LR R0,R7 CALC LOW
SR R0,R3 - FIRST = PRE LENG
STH R0,0(R14) = PRE LENG, SAVE THAT
SR R5,R3 CALC LOC LOC - FIRST = OFFSET OF CHAR
LA R1,2(R5,R15) POINT TO LOW CHAR
MVC 4(1,R14),0(R1) AND SAVE THAT
LM R2,R7,54(R13) RELOAD REGS
BR R9 AND RETURN
*
* HTTPS://EN.WIKIPEDIA.ORG/WIKI/LETTER_FREQUENCY
QFREQTBL DC X'898887',253X'86' ASCII FIRST (WIKIOPEDIA)
ORG QFREQTBL+X'30'
DC X'59585756555453525150' NUMBERS
ORG QFREQTBL+X'40'
DC X'27161D20291A18222513141F1B242617112123281E151C121910' UPPER
ORG QFREQTBL+X'60'
DC X'47363D40493A38424533343F3B444637314143463E353C323930' LOWER
*
ORG QFREQTBL+X'C1' EBCDIC UPPER
DC X'27161D20291A182225'
ORG QFREQTBL+X'D1'
DC X'13141F1B2426171121'
ORG QFREQTBL+X'E2'
DC X'23281E151C121910'
*
ORG QFREQTBL+X'81' LOWER
DC X'47363D40493A384245'
ORG QFREQTBL+X'91'
DC X'33343F3B4446373141'
ORG QFREQTBL+X'A2'
DC X'43463E353C323930' LOWER
*
ORG QFREQTBL+X'F0'
DC X'59585756555453525150' NUMBERS
ORG
*
TESTHEX DC 6X'00',41C' ',10X'00',6C' '
MAKEHEX DC X'0A0B0C0D0E0F'
SPACES DC 41C' ',X'00010203040506070809'
* -------------------------------------------------
@@PAD#0 EQU *-SPLITNEW+4095
@@PAD#1 EQU @@PAD#0/(4097)
@@PAD#2 EQU (@@PAD#1*4096)
ORG SPLITNEW+@@PAD#2
*
* DCBD DEVD=DA
* =================================================
FILES DSECT
FDCB DS XL104'00' DCB
FDDNAME DS D DDNAME
FCOUNT DS D PL8 REC COUNT
DS 0D
LFILES EQU *-FILES
* ----------------------------------
DSECT DSECT
DOPCODE DS CL2 OP-CODE I,J,K A,B,C O,P,Q
DOPCONT DS C CONTINUATION OF PRIOR OPCODE
DOPSEL DS C WRITE SELECT FIELDS
DOPMORE DS C THERE ARE MORE CONTINUATIONS
DEQ DS 2X BRANCH COND AND REVERSE
DLOCPLUS DS C LOC=+23
DLOC DS H STRING LOCATION
DLEN DS H LENGTH
*
DFREQPRE DS HL2 BYTES BEFORE LEAST FREQ
DFREQPOS DS HL2 BYTES FOLLOWING THE LEAST FREQ (POST)
DFREQCHR DS C LEAST FREQ CHAR.
*
DTYPE DS C STRING-1 DATA TYPE
DS HL2 STR LENGTH
DSTRING DS CL12 STRING <== I'LL MAKE THIS LONGER LATER.
DSTRINGL EQU *-DSTRING
* 28,44,? I LIKE NICE BOUNDARIES.
DS F
DDCB DS 6FL4
LDDCB EQU *-DDCB
* FIX THE GETMAIN LENGTH CALC.)
DTRTTBL DS F
DS 0D
LDSECT EQU *-DSECT
* =================================================
END SPLITNEW