New version of QBREAK. Does have a bug, but seems to work anyway. Description and source.
a
AGO .START
I INTEND THIS TO BE QBREAK, BUT I CANNOT FIX THAT AT THE MOMENT.
I INTEND THAT THE PRIOR QBREAK BE RENAMD QQBREAK
IT WORKS. DEMENTIA HAS GOT ME. THERE'S AT LEAST 1 MISTAKE,
BUT IT DOES WORK.
C:\USERS\LIN\DOCUMENTS\Z390CODE\ZX
S FF230.!=C'DCB' (=,!=,<,<=,>,>=) (CAUSE I FORGET)
ASSEMBLE AND TEST
SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\ZX
SET SYSPRINT=%G%.SYSPRINT.TXT
SET SYSIN=%G%.SYSIN.TXT
SET IN=%G%.PRN
SET OUT=%G%.OUT.TXT
SET BREAK=%G%.BREAK.TXT
BAT\ASMLG %G%.MLC TIME(1)
TEST
SET G=C:\USERS\LIN\DOCUMENTS\Z390CODE\ZX
SET SYSPRINT=%G%.SYSPRINT.TXT
SET SYSIN=%G%.SYSIN.TXT
SET IN=%G%.PRN
SET BREAK=%G%.OUT.TXT
SET OUT=%G%.OUT2.TXT
BAT\EZ390 %G%.MLC TIME(1999) TEST(BREAK)
V02.20 DOES HAVE AN ERROR, BUT DOES SEEM TO WORK
DEFAULT GETMAIN IS 8K (PARM='2') YOUI CAN HAVE MORE (PARM='4')
SYSIN KEYWORDS ARE:
LOADLOC= 80000 FF000 FE000 (4K BOUNDS ARE NICE.
LOADLOC= 4R%, 13R% TO CREATE LIST COMMANDS FOR DSECT LABELS
LISTLEN=32 LENGTH OF LIST=LABEL DISPLAY
INSTLEN=32 LENGTH OF INST OPERAND DISPLAY
BREAK=LABEL,LABEL PLACES TO SET BREAK POINTS
LIST=LABEL, GENERATE LIST COMMANDS FOR THESE
STOPAT= LISTING LOC TO ABEND S0C3 TO HEPL WITH TESTING
STOP#= PRN RECORD # TO ABEND S0C3 "
USER MUST !!! PUT LABELS WITH CORRECT LOADLOC LOCATIONS/REGISTERS.
YOU CAN DO THIS WRONG. I HAVE DONE IT WRONG. IT'S PRETTY EASY
.START ANOP
* ---------------------------------
MACRO
&LBL ERR &BC,&MSG
LCLA &N
&L SETC 'SYS&SYSNDX'
&LBL REVB &BC,&L.Z
BAL R14,ERR
DC AL1(L'&L.M-1)
&L.M DC C&MSG
&L.Z DS 0H
MEND
* ---------------------------------
MACRO
&LBL $$LA ®,&FLD
LCLC &F,&G,&H
&F SETC ' &FLD(1)'
&G SETC '&FLD(1,1)'
&H SETC '&FLD'(1,1)
MNOTE ,'FLD(1,1) (2) IN THIS CASE, = &FLD(1,1) &F &G &H'
AIF ('&H.' NE '(').A
&LBL LA ®,0&FLD
MEXIT
.A ANOP
&LBL LA ®,&FLD
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
&LABEL BUBBLE &FIRST=,&END=,&ENTLEN=,&KEY=,&KEYLEN=
LCLC &SYS
LCLA &K
&K SETA &KEY
&SYS SETC 'SYS&SYSNDX.'
&LABEL $$LA 1,&FIRST
$$LA 15,&ENTLEN
$$LA 0,&END
LR 14,0
SR 0,15
ST 1,12(13)
CH 15,=H'56'
BNL *+8
LA 14,16(13)
&SYS.C CLC &K.(&KEYLEN,1),&ENTLEN+&K.(1)
BNH *+22
MVC 0(&ENTLEN,14),0(1)
MVC 0(&ENTLEN,1),&ENTLEN.(1)
MVC &ENTLEN.(&ENTLEN.,1),0(14)
LA 1,&ENTLEN.(1)
CR 1,0
BL &SYS.C
SR 0,15
L 1,12(13)
CR 1,0
BL &SYS.C
MEND
* -----------------------------------------------------------
* DOESN'T WORK. DON'T KNOW WHY. BUBBLE DOES WORK.
*
MACRO
&LABEL SELSORT &FIRST=,&END=,&ENTLEN=,&KEY=,&KEYLEN=
.*
.* THE SELSORT IS ABOUT THE SAME LENGTH AS THE BUBBLE SORT,
.* HOWEVER, EACH MOVE PUTS AN ENTRY INTO IT'S FINAL POSITION,
.* SO FEWER ENTRY SWAPS ARE DONE, THUS IT'S FASTER.
.* "AND" IT HAS THE SAME BENEFIT OF KEEPING DUPLICATE KEYS
.* IN THEIR SAME RELATIVE POSITIONS. (YES, I JUST WROTE IT.)
.*
.* WRITING A SELSORT, ONE CAN EITHER MOVE THE LOWEST ENTRY TO
.* THE TOP, OR HIGHEST TO THE BOTTOM. THEY'RE EQUALLY EFFICIENT.
.*
LCLC &SYS
LCLA &K,&KL,&EL
&L SETC 'SYS&SYSNDX'
&K SETA &KEY
&KL SETA &KEYLEN
&EL SETA &ENTLEN
&SYS SETC 'SYS&SYSNDX.'
&LABEL $$LA 0,&END
LA 15,&ENTLEN
AIF (T'&ENTLEN EQ 'N').A
MNOTE 12,'ENTLEN=## MUST BE A DISCRETE #, NOT REG OR LABEL'
MEXIT
.A AIF (T'&KEYLEN EQ 'N').B
MNOTE 12,'ENTLEN=## MUST BE A DISCRETE #, NOT REG OR LABEL'
MEXIT
.B AIF (T'&KEY EQ 'N').C
MNOTE 12,'KEY=## MUST BE A DISCRETE #, NOT REG OR LABEL'
MEXIT
.C ANOP
$$LA 1,&FIRST
STM 15,1,8(13) <---- ENTLEN, END, BEGINNING
S 0,12(13)
AIF (&EL GT 52).LAST
LA 14,20(13)
AGO .LOAD2
.LAST $$LA 14,&END
.LOAD2 ANOP
&L.A LA 15,&EL.(1)
&L.C CLC &KEY.(&KL,1),&K.(15)
BL *+6
LR 1,15
LA 15,&EL.(15)
CR 15,0
BNH &L.C
CR 1,15
BE *+22
MVC 0(&EL,14),0(1)
MVC 0(&EL,15),0(1)
MVC 0(&EL,1),0(14)
L 1,16(13)
S 0,12(13)
CR 1,0
BL &L.A
AIF (&ENTLEN LT 53).Z
MVI 0(14),X'FF'
MVC A(&ENTLEN-1,14),0(14)
.Z MEND
* -----------------------------------------------------------
MACRO
&LBL $ &TEXT
LCLA &N
LCLC &L
&L SETC 'SYS&SYSNDX'
&N SETA K'&TEXT-3
&LBL DC AL1(&N),C&TEXT
&L EQU *
MEND
* ---------------------------------
ZX START 0
USING *,12,11
YREGS
B BEG-ZX+2(15)
*
IDMSG DC C'ZX V02.20 ASM &SYSTIME &SYSDATE'
BEG DC H'-1'
STM 14,12,12(13)
LR 12,15
LA 11,4095
LA 11,1(12,11) INIT DONE.
L 1,0(1)
CLI 1(R1),0
BE *+10
MVC LGETMAIN+3(1),2(R1)
L R2,LGETMAIN
N R2,=F'15'
SLL R2,12
SH R2,=H'42'
ST R2,LGETMAIN
LR R0,R2
LR R3,R13 SAVE CALLER'S R13
GETMAIN R,LV=(0)
ST R1,AGETMAIN
LR R14,R1
$$LA R15,(2)
LA R15,2
MVI 0(R14),C' '
CLEAR2 LA R0,5
CLEAR6 MVC 1(256,R14),0(R14)
LA R14,256(R14)
BCT R0,CLEAR6
MVI 0(R14),0
LA R0,7
BCT R15,CLEAR6
* ------------------------------------
LR R13,R1
ST R3,4(R13)
ST R13,8(R3)
USING SAVEAREA,13
LA R14,0(R1,R2)
SH R14,=H'128'
ST R14,EGETMAIN
ST R14,ETABLE
LA R15,TABLE
ST R15,ATABLE
ST R15,ETABLE
ST R15,LAST
ST R15,LAST+4
* ------------------------------------
MVI FINDSPAC+C' ',C' '
MVI FINDCHAR+C' ',0
MVC TESTHEX+C'A'(60),TESTHEXI
*
MVI FINDEND+C' ',1
MVI FINDEND+C',',2
MVI FINDEND+C'*',3
MVI FINDEND+C'+',4
MVI FINDEND+C'-',5
* MVC ATLINEI(17),INITATL A FF000.+12345.
MVC LINE-5(5),=X'0040000040'
MVC ATLINE-5(5),=X'0040000040'
** MVC CARD-5(5),=X'0054000040'
B OPEN
INITATL DC C'A F0123.+12345. '
TESTHEXI DC 6X'00',41C' ',10X'00',6C' '
* ------------------------------------
PUSH PRINT
PRINT NOGEN
USING IHADCB,2
OPENMSG DC C'........ OPENED FOR OUTPUT, RECFM= LRECL=..... '
OPENSYSP MVC OPENMSG(8),DCBDDNAM
OPEN ((2),OUTPUT)
MVC LINE(L'IDMSG),IDMSG
PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
B OPENM
OPENO MVC OPENMSG(8),DCBDDNAM
MVC OPENMSG+20(3),=C'OUT'
OPEN ((2),OUTPUT)
B OPENM
OPENI MVC OPENMSG(8),DCBDDNAM
MVC OPENMSG+20(3),=C' IN'
OPEN ((2),INPUT)
OPENM UNPK OPENMSG+34(3),DCBRECFM(2)
TR OPENMSG+34(2),HEX-240
MVI OPENMSG+36,C' '
LH R0,DCBLRECL
CVD R0,16(13)
OI 23(13),X'0F'
UNPK OPENMSG+43(5),21(3,13)
NOTSYSP MVC LINE(L'OPENMSG),OPENMSG
BAL R10,PUTLINE
BR R9
DROP 2
POP PRINT
* ------------------------------------
* ========================= COMMON WRITE ROUTINES ===============
*
* PUTBADDR DC CL20' ' THIS PREVENTS DUPLICATE BREAK
* PUTBREAK CLC PUTBADDR,LINE POINT LOCATIONS, WHEN A LABEL
* BER R9 IS FOUND ON A LABEL + CODE.
* MVC PUTBADDR,LINE
* PUTBREAP PUT OUT,LINE
* ** B PUTLINE
WTOATLIN MVC LINE,ATLINE
WTOLINE WTO MF=(E,LINE-5)
B PUTLINE
*
PUTATLIN MVC LINE,ATLINE
PUTOUT CLC LINE(33),SPACES
BE PUTLINE
PUT OUT,LINE
B PUTLINE
*
PUTCARD MVC LINE(80),CARD
PUTLINE CLC LINE(44),SPACES
BNE PUTLINEP
MVI LINE+5,C'-'
MVC LINE+6(55),LINE+5
LR R0,R10
SR R0,R12
ST R0,12(R13)
UNPK LINE+33(5),14(3,R13)
TR LINE+33(4),HEX-240
MVI LINE+37,C'-'
MVC LINE+17(16),=C'BLANK LINE FROM '
MVC LINE+40(6),0(R3)
PUTLINEP PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
BR R10
* ============================================
* ERROR ROUTINE CAN BE USED FROM SEVERAL TESTS.
* IT LISTS THE PROGRAM LOCATION, ALONG WITH THE ERROR MSG.
* -------------------------------------------------
DC F'0'
ERR LA R1,0(R14)
ST R1,ERR-4
SR R1,R12
ST R1,12(R13)
UNPK ERRMSG+13(5),14(3,R13)
TR ERRMSG+13(4),HEX-240
MVI ERRMSG+17,C' '
MVC LINE+1(L'ERRMSG),ERRMSG
CLI LINE+19,C'$'
BNE *+8
MVI LINE+19,C' '
SR R2,R2
IC R2,0(R14)
MVC LINE+1+L'ERRMSG(0),1(R14)
EX R2,*-6
TM DCBOFLGS-IHADCB+SYSPRINT,DCBOFOPN
BO ERR$
OPEN (SYSPRINT,OUTPUT)
ERR$ L R14,ERR-4
CLI 1(R14),C'$'
BNE ERRWRITE
LA R15,LINE+5+L'ERRMSG(R2)
MVC 0(40,R15),CARD
ERRWRITE WTO MF=(E,LINE-5)
OI RC,12
B GETSYSIN
ERRMSG DC C'SYSIN ERR AT .... '
ERRABEND ABEND 1
* ========================== SAVE OPCODE ===================
LOPCDENT EQU 16
SAVEOPCD CLI BEG,0
BE *+8
LA R6,BEG+4
MVC CARD,CARD+7 OPCODE=
B SAVEOPL
SAVEOPL LA R0,LOPCDENT(R6)
ST R0,BEG
C R0,=A(ZX+200)
ERR BNL,'$OPCODE= TABLE OVERFLOW'
* PUT SYSPRINT,CARD-1
BAL R10,PUTCARD
MVI LOPCDENT(R6),X'FF'
TRT CARD,FINDEND
ERR BZ,'$ERROR IN OPCODE= ANALYSIS'
LR R2,R1
S R1,=A(CARD+1)
MVC 0(LOPCDENT,R6),SPACES
LA R0,1(R1)
STH R0,0(R6)
MVC 2(6,6),LOADLOC
MVC 8(0,R6),CARD
EX R1,*-6
MVC CARD,1(R2)
CLI CARD,C' '
BE GETSYSIN
LA R6,LOPCDENT(R6)
B SAVEOPL
* ==========================CHECK OPCODE=================
CLC 8(0,R6),OPCODE
CHECKOPC CLI BEG,0 Q. ANY OPCODES SPECIFIED
BNER R9 NO.
LA R6,BEG+4 YES, LOAD START ADDR
CHECKOPL LH R2,0(R6)
EX R2,CHECKOPC-6
BE CHECKOPF FOUND
LA R6,LOPCDENT(R6)
CLI 0(R6),C'9'
BL CHECKOPL
BR R9
** C R6,BEG
*
CHECKOP$ MVC ATLINE(2),=C'A '
MVC ATLINE+2(6),2(R6) FF000.+
MVC ATLINE+7(2),=C'.+'
MVC ATLINE+9(5),1(R3)
MVI ATLINE+14,C','
MVC ATLINE+17,OPCODE
BR R14
*
CHECKOPF BAL R14,CHECKOP$
BAL R10,PUTOUT
* PUT SYSPRINT,LINE-1
* PUT OUT,LINE
CHECKOPG BAL R9,READIN
CLI 52(R3),C'+'
BE CHECKOPG
BAL R14,CHECKOP$
BAL R10,PUTOUT
* PUT SYSPRINT,LINE-1
* PUT OUT,LINE
MVC LINE,LINE-1
B GETIN
* ------------------------------------
SAVINSTL LA R5,INSTLEN INSTLEN=
B SAVLISTL+4
SAVLISTL LA R5,LISTLEN+1 LISTLEN=
CLI CARD+8,C'0'
ERR BL,'$BAD LENGTH REQUEST'
TRT CARD+8(5),FINDEND
ERR BZ,'$LEN REQ TOO LONG'
LR R2,R1
S R2,=A(CARD+9)
MVC 0(0,R5),CARD+8
EX R2,*-6
B GETSYSIN
* ------------------------------------
SAVLOADL MVC CARD+4(4),SPACES LOADLOC=9R% <== +9
MVC LOADLOC(6),CARD+6
CLC =C'R%',CARD+9
BE SAVLOADM
MVC LOADLOC(6),CARD+7 LOADLOC=11R% LOADL00011R%
CLC =C'R%',CARD+10 LOADLO..11R%
BE SAVLOADM
MVC LOADLOC(5),CARD+8
MVI LOADLOC+5,C'.' LOADLOC=FF000
SAVLOADM MVC LINE+16(8),=C'LOADLOC='
MVC LINE+16+8(6),LOADLOC
MVI LINE+16+8+6,C'+'
BAL R10,PUTLINE
B GETSYSIN
* ===================================== OPEN======================-
OPEN LA R2,SYSPRINT
BAL R9,OPENSYSP
LA R2,SYSIN
BAL R9,OPENI
LA R2,IN THESE ARE THE FILE OPEN ROUTINES.
BAL R9,OPENI ONCE DONE, WE COULD USE THIS AREA
LA R2,OUT FOR WORK AREAS.
BAL R9,OPENO
* ========================FALL THROUGH TO READ
GETSYSIN GET SYSIN
MVC CARD(80),0(R1)
GOTSYSIN CLI CARD,C' '
BE GETSYSIN SKIP BLANKS
MVC LINE(80),CARD
* -----------------------------------
CLC =C'LOADLOC=',CARD
BE SAVLOADL
WTO MF=(E,LINE-5)
BAL R10,PUTLINE
CLC =C'INSTLEN=',CARD
BE SAVINSTL
CLC =C'LISTLEN=',CARD
BE SAVLISTL
CLC =C'OPCODE=',CARD
BE SAVEOPCD
CLC =C'BREAK=',CARD
BE SETBREAK
CLC =C'LIST=',CARD
BE SETLIST
CLC =C'STOPAT=',CARD
BE SETSTOPA
CLC =C'STOP#=',CARD
BE SETSTOP#
* ERR B,'$UNKNOWN CONTROL CARD INPUT'
B PRINTDOC
*
SETSTOPA MVC STOPAT,CARD+7
B GETSYSIN
SETSTOP# MVC CARD,CARD+7
MVC REC#+4,DW+4
B GETSYSIN
*
PACK DW,CARD(0)
GET## CLI CARD,C'0'
BL GET##X
LA R1,CARD
LA R1,1(R1)
CLI 0(R1),C'0'
BNL *-8
CLI 0(R1),C' '
BNE GET##X
S R1,=A(CARD+1)
EX R1,GET##-6
CVB R0,DW
BR R9
GET##X ERR B,'$BAD NUMERIC REQUEST'
* -----------------------------------
GETR8 L R8,LAST
USING DSECT,R8
MVC 0(LDSECT,R8),SPACES
** MVC DSTRLEN,ZEROS
*
LA R0,LDSECT(R8)
ST R0,LAST
C R0,EGETMAIN
ERR BNL,'$TABLE OVERFLOW'
TRT CARD(12),FINDEND
ERR BZ,'$UNKNOWN ERR LOOKING FOR END OF LABEL'
*
STC 2,INDEX
LR R2,R1
S R2,=A(CARD)
STH R2,DSTRLEN
BCTR R2,0
CH R2,=H'32'
BL *+8
EX 0,*
MVC DSTRING(0),CARD
EX R2,*-6
MVC DTYPE,TYPE
MVC DLOADLOC,LOADLOC FF000. <==
** MVC DLOADLOC(1),TYPE LABEL*+06.
*
CLI INDEX,3
BE GOTAST
BLR R9
*
MVC CARD,0(R1)
TRT CARD,FINDEND
ERR BZ,'$BREAK=LABEL+.0C PROBLEM'
MVC CARD,0(R1)
TRT CARD+1(5),FINDEND
ERR BZ,'$BREAK=LABEL+.0C PROBLEM'
LR R2,R1
S R1,=A(CARD+1)
MVC DADDLOC(0),CARD
EX R1,*-6
MVC CARD,0(R2)
BR R9
*
GOTAST SH R2,H2
STH R2,DSTRLEN
MVC CARD,1(R1)
NOTAST TRT CARD(9),FINDEND
ERR BZ,'$ERR IN LABEL*'
MVC CARD,0(R1)
STC 2,INDEX
BR R9
* -----------------------------------
SETLIST MVC CARD,CARD+5 LIST=LABEL,LABEL
MVI TYPE,C'L'
LA R5,SETLISTL
SETLISTL BAL R9,GETR8
CLI INDEX,3
ERR BH,'$CANNOT HAVE +/_ ON LIST REQUEST'
MVC DDISPLEN,LISTLEN
SETLISTZ TRT CARD,FINDEND
CLI 0(R1),C' '
BE GETSYSIN
CLI 0(R1),C','
ERR BNE,'$UNKNOWN SYSIN SYNTAX'
CLC =C', ',0(R1)
BE SETLIST$
MVC CARD,1(R1)
BR R5
SETLIST$ BAL R9,READIN
MVC CARD,0(R1)
BR R5
*
SETBREAK MVC CARD,CARD+6 BREAK=LABEL,LABEL+.0C
MVI TYPE,C'A'
LA R5,SETBREAL
*
SETBREAL BAL R9,GETR8
B SETLISTZ
* -----------------------------------
LISTABLE L R8,LAST+4
LISTLOOP MVC LINE,LINE-1
MVC LINE(1),DTYPE
MVC LINE+03(4),DDISPLEN
LH R1,DSTRLEN
STC R1,LINE+8
OI LINE+8,C'0'
MVC LINE+10(0),DSTRING
EX R1,*-6
BAL R10,PUTLINE
* PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
LA R8,LDSECT(R8)
C R8,LAST
BL LISTLOOP
*
CLI BEG,0
BNER R9
LA R2,BEG+4
LISTOPC MVC LINE+6(6),2(R2)
MVC LINE+14(1),1(R2)
OI LINE+14,C'0'
LH R1,0(R2)
MVC LINE+16(0),8(R2)
EX R1,*-6
BAL R10,PUTLINE
* PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
LA R2,LOPCDENT(R2)
C R2,BEG
BL LISTOPC
BR R9
*
ZZ BAL R9,LISTMEM
BAL R9,LISTABLE
* AGO .NOSORT
LA R2,TABLE
L R3,LAST
LA R4,DSTRING-DSECT
LA R5,L'DSTRING
* SELSORT FIRST=(R2),END=(R3),ENTLEN=32,KEY=15,KEYLEN=17
** ENTLEN=LDSECT,KEY=DSTRING-DSECT,KEYLEN=L'DSTRING
*
BUBBLE FIRST=(R2),END=(R3),ENTLEN=32,KEY=15,KEYLEN=17
** ENTLEN=LDSECT,KEY=DSTRING-DSECT,KEYLEN=L'DSTRING
*
SR R1,R1
SR R15,R15
LA R8,TABLE
LA R2,DSTRING
SETLOC LA R1,1(R1)
CLC DSTRING(1),0(R2)
BE SETLOCN
*
LA R2,DSTRING
IC R15,DSTRING
LA R14,LBLTBL(R15)
CLI 0(R14),0
BNE *+8
STC R1,0(R14)
*
SETLOCN LA R8,LDSECT(R8)
C R8,LAST
BL SETLOC
BAL R9,LISTABLE
*
.NOSORT ANOP
B GETIN
REL DC X'E985D340'
DC F'0'
READIN ST R9,READIN-4
GET IN
AP REC#,P1
CP REC#,REC#+4
BE S0C3
CLI 0(R1),C'0' Q. LOCATION?
BNE READIN NO.
CLI 53(R1),C'*'
BE READIN YES, SKIP
CLC =C'000000',0(R1) Q. DUMB FIRST RECORDS?
BE READIN YES, SKIP
CLC REL,0(R1)
BE Z
CLC =C'SYM=',1(R1) Q. IN CASE WE MISSED END?
BE Z YES, EOF OF //PRN
MVC RECORD,NEXTREC
MVC NEXTREC,0(R1)
CLC RECORD(6),NEXTREC
BE READIN
LA R3,RECORD
LA R4,53(R3)
CLI STOPAT,C' '
BER R9
*
LA R14,STOPAT-7
STOPLOOP LA R14,7(R14)
CLI 0(R14),C' '
BER R9
CLC 0(6,R14),0(R3)
BNE STOPLOOP
S0C3 EX 0,*
RESTART L R9,READIN-4
LA R3,RECORD
LA R4,53(R3)
BR R9
* -----------------------------------------
MVCFLD MVC 0(0,R1),0(R14)
*
GETIN BAL R9,READIN
GOTPRN SR R2,R2
TRT 0(1,R4),LBLTBL A. VALID FIRST CHAR
BZ GETIN NO.
SAVLABEL MVC LBOPOPER,SPACES
*
* HERE WE'RE GOING TO SAVE THE LABEL, OPCODE, AND 2 BYTES OF OPERAND
* JUST MAKES PROCESSING EASIER.
*
LR R7,R2
SLL R7,5
*
LA R5,LABEL
LA R1,31
BAL R14,GETSTR GET THE LABEL, MAX LENG=31
LA R5,OPCODE
LA R1,8
BAL R14,GETSTR GET THE OPCODE, MAX LENG=8
MVC OPERAND(3),0(R4) SAVE 3 BYTES OF OPERAND (FOR DS 0H)
*
LA R8,TABLE-32(R7)
* LA R8,TABLE
CHKLBL LH R2,DSTRLEN
EX R2,CLCSTR
BE FOUND
LA R8,LDSECT(R8)
CLC DSTRING(1),LABEL
BE CHKLBL
* C R8,LAST
* BL CHKLBL
BAL R9,CHECKOPC
B GETIN
CLCSTR CLC DSTRING(0),LABEL
* -------------------------------------------
MVC 0(0,R5),0(R4)
TRT 0(0,R4),FINDEND
GETSTR EX R1,GETSTR-6 THIS ROUTINE SAVES A STRING,
BZ GETIN AND POINTS TO THE NEXT ONE.
LR R2,R1 LABEL, THEN OPCODE,
SR R2,R4 AND SAVE ADDR OF OPERAND
EX R2,GETSTR-12
TRT 0(15,R1),FINDCHAR
BZ GETIN
LR R4,R1
BR R14
* -------------------------------------------
* OKAY, GOT THE LABEL, SEE IF IT'S IN THE TABLE.
* IF NOT, GO READ
* IF YES, SET UP THE COMMAND,
* AND DETERMINE IF IT'S DATA OR INSTRUCTION.
* -------------------------------------------
* =======================
DC F'0'
FOUND ST R8,FOUND-4
MVC ATLINE(99),SPACES
MVC ATLINE+7(2),=C'.+'
MVC ATLINE+9(5),1(R3)
MVI ATLINE+14,C'.'
MVC ATLINE+15(4),DDISPLEN
CLI DLOADLOC,C' '
BNE CPYLOADL
MVC ATLINE+3(5),DLOADLOC
B CPYLOADL+6
CPYLOADL MVC ATLINE+2(5),DLOADLOC
CLI DTYPE,C'L'
BNE INST
* CLC =C'DC',OPCODE Q. DATA OR INST.
* BE DATA GO TO EITHER DATA OR INST
* CLC =C'DS',OPCODE ROUTINE.
* BNE INST CONSIDER DS 0H TO BE INST.
* CLC =C'0H',OPERAND
* BE INST
DATA MVI ATLINE,C'L'
* MVC ATLINE+15(4),DDISPLEN
* CLC ATLINE+15(4),SPACES
* CLC DDISPLEN,SPACES
* BNE *+10
* MVC ATLINE+17(3),DATALEN DEFAULT DATA LENGTH=48
MVC ATLINE+20(12),LABEL WE WRITE DATA DISPLAY TO THE
* MVC LINE(L'ATLINE),ATLINE CONSOLE, BUT NOT THE //BREAK FILE
** MVC LINE(8),DLOADLOC
BAL R10,WTOATLIN
* WTO MF=(E,ATLINE-5)
* PUT SYSPRINT,ATLINE-1
MVC ATLINE,SPACES
B TRYMORE
*** MVC ATLINE+24(12),STRING
INST MVI ATLINE,C'A'
* MVC ATLINE+22(4),DADDLOC
** MVC ADDLOC,SPACES
MVC ATLINE+20(8),LABEL
*** MVC ATLINE+31(3),OPCODE WRONG !!!!!
LA R4,ATLINE+30
MVC 0(36,R4),SPACES
** MVC ATLINE(6),DLOADLOC
MVC ATLINE+15(4),DADDLOC
CLC ATLINE+15(2),SPACES
BNE *+8
BAL R9,MAKELIST
BAL R10,PUTATLIN
* PUT SYSPRINT,ATLINE-1
* PUT OUT,ATLINE
MVC ATLINE,SPACES
B TRYMORE
*
CLC DSTRING(0),LABEL
TRYMORE L R8,FOUND-4
LA R8,LDSECT(R8)
C R8,LAST
BNL GETIN
LH R1,DSTRLEN
EX R1,TRYMORE-6
BNE GETIN
B FOUND
* -------------------------------------------------
MAKELIST CLI 6(R3),C' '
BNER R9
CLI 7(R3),C' '
BER R9
LA R14,11(R3) FIRST RDDD STRING
CLI 8(R14),C' ' Q. STRING TOO LONG?
BNE R9 YES, SKIP IT
MVC 32(5,R4),OPCODE
MVC 37(12,R4),7(R3) SAVE STRING SO I CAN SEE IT
*
* ---------------------ALL THIS IS TO GET THE REGISTER-------------
MAKELOOP LR R1,R14
CLI 0(R14),C'0'
BNE *+6
BCTR R1,0
IC R1,0(R1) LOAD REGISTER
N R1,=F'255'
*
CH R1,=H'239' C 0-9 AND A=F
BH *+8 0-9, OKAY
LA R1,57(R1) A-F MAKE 'EM FA-FF
N R1,=F'15'
CVD R1,DW
MVC MAKESAMP(4),ED3
ED MAKESAMP(4),DW+6
* ---------------------------------ALL THAT WAS TO GET THE REGISTER--
MVI MAKESAMP,C'L'
MVC MAKESAMP+7(3),1(R14)
MVC 0(16,R4),MAKESAMP
MAKELZ LA R4,L'MAKESAMP(R4)
LA R14,4(R14)
CLI 0(R14),C' '
BNE MAKELOOP
BR R9
ED3 DC X'40202120'
*
MAKESAMP DC C'L 3R%+123. 32 '
* ============================================
ZDCBLIST DC A(SYSIN,OUT,IN,SYSPRINT,0)
CLOSE LA R3,ZDCBLIST
L R2,0(R3)
MVC LINE+2(5),=C'CLOSE'
BAL R10,PUTLINE
* PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
CLOSETM TM DCBOFLGS-IHADCB(R2),DCBOFOPN
BZ NOCLOSE
CLOSE ((2))
CLI 6(R3),0
BZ NOCLOSE
MVC LINE+2(8),DCBDDNAM-IHADCB(R2)
MVC LINE+11(6),=C'CLOSED'
BAL R10,PUTLINE
* PUT SYSPRINT,LINE-1
NOCLOSE LA R3,4(R3)
L R2,0(R3)
LTR R2,R2
BP CLOSETM
BR R9
* -------------------------------------------------
Z MVC LINE,LINE-1
MVC LINE(11),=C'INTERACTIVE'
PUT OUT,LINE
MVC LINE,LINE-1
BAL R9,CLOSE
L 13,4(13)
FREEMAIN LM R0,R1,LGETMAIN
FREEMAIN R,LV=(0),A=(1)
SR 15,15
IC 15,RC
L 14,12(13)
LM 0,12,20(13)
BR 14
* -------------------------------------------------
LTORG
DC 10C'XYZ'
REC# DC PL4'0',PL4'89999999'
LISTLEN DC CL4' '
INSTLEN DC CL4' '
DC C'A '
LOADLOC DC CL6' '
LTABLE EQU LDSECT
ATABLE DC 2A(0)
ETABLE DC A(0)
*
LAST DS 2F'0'
LGETMAIN DC F'2'
AGETMAIN DC F'0'
EGETMAIN DC F'0'
INDEX DC 2C' '
RC DC X'00'
TYPE DC C' '
P0 DC X'0C'
P1 DC X'1C'
H0 DC H'0'
H1 DC H'1'
H2 DC H'2'
DW DC D'0'
HEX DC C'0123456789ABCDEF '
DC H'64,0',C' '
CARD DC CL80' ',CL19' '
DATALEN DC C'48 '
* ---------------------------------
PUSH PRINT
PRINT NOGEN
DS 0D
IN DCB DDNAME=IN,DSORG=PS,MACRF=GL,RECFM=FT,LRECL=366,EODAD=Z
OUT DCB DDNAME=OUT,DSORG=PS,MACRF=PM,RECFM=FT,LRECL=80
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
* -------------------------------------------------
*
LISTMEM MVC LINE,LINE-1
PUT SYSPRINT,LINE-1
LA R2,2
L R3,LAST
S R3,ATABLE
L R4,EGETMAIN
S R4,ATABLE
B MEMCVD
*
LISTMEML MVC LISTMEMM+16(7),=C'ENTRIES'
SR R0,R0
LR R1,R3
D R0,=A(LDSECT)
LR R3,R1
SR R0,R0
LR R1,R4
D R0,=A(LDSECT)
LR R4,R1
*
MEMCVD CVD R3,16(R13)
CVD R4,24(R13)
MVC LINE(L'EDIT5),EDIT5
ED LINE(L'EDIT5),21(R13)
MVC LINE+2+L'EDIT5(2),=C'OF'
MVC LINE+4+L'EDIT5(L'EDIT5),EDIT5
ED LINE+4+L'EDIT5(L'EDIT5),29(R13)
MVC LINE+6+L'EDIT5+L'EDIT5(L'LISTMEMM),LISTMEMM
PUT SYSPRINT,LINE-1
MVC LINE,LINE-1
BCT R2,LISTMEML
PUT SYSPRINT,LINE-1
BR R9
*
LISTMEMM DC C'AVAILABLE TABLE BYTES USED'
EDIT5 DC X'4020206B202120'
LTORG
*
* -------------------------------------------------
* AGO .NODOC
MVC LINE+2(0),1(R2)
PRINTDOC LA R2,DOC
SR R3,R3
PRINTLOP IC R3,0(R2)
EX R3,PRINTDOC-6
BAL R10,PUTLINE
LA R2,2(R2,R3)
CLI 0(R2),99
BL PRINTLOP
B ERRABEND
DOC $ 'SYSIN KEYWORD ERROR'
$ '.'
$ 'PARM CAN BE 1 # CHAR FOR LENGTH * 4K OF GETMAIN. DEFAULT="2" (8K)'
$ '.'
$ 'SYSIN KEYWORDS ARE'
$ 'LOADLOC= 80000, FF000, 4R%, 13R% (REQUIRED)'
$ 'LISTLEN=32 LENGTH OF LIST=LABEL DISPLAY'
$ 'INSTLEN=32 LENGTH OF INST OPERAND DISPLAY'
$ 'BREAK=LABEL,LABEL PLACES TO SET BREAK POINTS'
$ 'LIST=LABEL, GENERATE LIST COMMANDS FOR THESE (CAN BE IN DSECT)'
$ 'STOPAT= LISTING LOC TO ABEND S0C3'
$ 'STOP#= PRN RECORD # TO ABEND S0C3'
$ '.'
$ 'USER MUST PUT LABELS WITH CORRECT LOADLOC LOCATIONS/REGISTERS!'
DC X'FF'
* .NODOC ANOP
* -------------------------------------
* UNFORTUNATELY, GONE OVER 4K. THAT'S THE WAY IT GOES.
* -------------------------------------
@@PAD#0 EQU *-ZX+4095
@@PAD#1 EQU @@PAD#0/(4097)
@@PAD#2 EQU (@@PAD#1*4096)
ORG ZX+@@PAD#2
*
SAVEAREA DSECT 0
DS XL768
ORG SAVEAREA
DS XL72
*
LBOPOPER DS 0CL36
LABEL DS CL12
OPCODE DS CL12
OPERAND DS CL12
DS XL5
LINE DS CL133
DS CL5
ATLINE DS CL80,CL53
RECORD DS CL80
NEXTREC DS CL80
STOPAT DS CL80
* ------------------ TABLES BELOW ARE MOSTLY SPACES
ORG
FINDCHAR DS XL256
TESTHEX DS XL256
SPACES EQU FINDCHAR+66
ZEROS EQU FINDSPAC+66
* ------------------ TABLES BELOW ARE MOSTLY ZEROS
LBLTBL DS XL256 THE FIRST CHAR OF EACH LABEL IS KEPT,
FINDCOMA EQU *+C' '-C','
FINDSPAC DS XL256
FINDEND DS XL256
DS 0D
TABLE DS XL64
*
DSECT DSECT 0
DADDLOC DS 0CL4 LABEL+0C.
DDISPLEN DS CL4 LABEL 32
DLOADLOC DS CL8 A FF000.
DSTRLEN DS H 05
DTYPE DS C A/L
DSTRING DS CL17
LDSECT EQU *-DSECT
*
* DCBD DEVD=DA
END ZX
z