EDI TITLE 'DMSEDI (CMS) VM/370 - RELEASE 6' 00001000
SPACE 2 00002000
*********************************************************************** 00003000
* 00004000
* MACROS FOR EDIT 00005000
* 00006000
*********************************************************************** 00007000
SPACE 2 00008000
* 00009000
************** 00010000
* 00011000
* REQ SETS UP THE DECLARATIONS FOR A REQUEST 00012000
* (SEE TABLE OF REQUESTS -- PRQUEST ET SEQ.) 00013000
* 00014000
************** 00015000
SPACE 00016000
MACRO 00017000
&LOC REQ &NAME,&MIN,&ADDR,&TRAV 00018000
LCLA &M,&L,&K 00019000
LCLC &A 00020000
&M SETA 1 00021000
AIF (N'&MIN EQ 0).SEQ1 00022000
&M SETA &MIN 00023000
.SEQ1 ANOP 00024000
&L SETA K'&NAME 00025000
&A SETC '&NAME' 00026000
AIF (N'&ADDR EQ 0).SEQ2 00027000
&A SETC '&ADDR' 00028000
.SEQ2 ANOP 00029000
&K SETA 0 00030000
AIF (N'&TRAV EQ 0).SEQ3 00031000
&K SETA 1 00032000
.SEQ3 ANOP 00033000
&LOC DC AL1(&M,&L,&K),C'&NAME',AL2(&A-EDIT) 00034000
MEND 00035000
EJECT 00036000
* 00037000
************** 00038000
* 00039000
* WTYPE TYPES A LINE AT THE TERMINAL 00040000
* 00041000
************** 00042000
SPACE 00043000
MACRO 00044000
&LOC WTYPE &TEXT,&NUM,&RETURN=,&VERIFY= 00045000
LCLA &A 00046000
LCLC &SUF 00047000
AIF (N'&VERIFY EQ 0).SEQ1 00048000
AIF ('&VERIFY' NE 'YES').SEQ1 00049000
&SUF SETC '1' 00050000
.SEQ1 ANOP 00051000
&LOC LA 1,&TEXT 00052000
AIF (N'&NUM EQ 0).SEQ1A 00053000
&A SETA &NUM 00054000
AGO .SEQ2 00055000
.SEQ1A ANOP 00056000
&A SETA L'&TEXT 00057000
.SEQ2 LA 0,&A 00058000
AIF (N'&RETURN EQ 0).SEQ3 00059000
LA 14,&RETURN 00060000
B WRTYPE&SUF 00061000
MEXIT 00062000
.SEQ3 BAL 14,WRTYPE&SUF 00063000
MEND 00064000
SPACE 2 00065000
* 00066000
************** 00067000
* 00068000
* VTYPE TYPES A LINE IF IN VERIFY MODE 00069000
* 00070000
************** 00071000
SPACE 00072000
MACRO 00073000
&LOC VTYPE &TEXT,&NUM,&RETURN= 00074000
&LOC WTYPE &TEXT,&NUM,RETURN=&RETURN,VERIFY=YES 00075000
MEND 00076000
EJECT 00077000
* 00078000
************** 00079000
* 00080000
* VERIFY VERIFIES THE CURRENT LINE 00081000
* 00082000
************** 00083000
SPACE 00084000
MACRO 00085000
&NAME VERIFY &RETURN= 00086000
AIF (N'&RETURN EQ 0).SEQ1 00087000
&NAME LA 14,&RETURN 00088000
B VERSUB 00089000
MEXIT 00090000
.SEQ1 ANOP 00091000
&NAME BAL 14,VERSUB 00092000
MEND 00093000
SPACE 2 00094000
* 00095000
************** 00096000
* 00097000
* CMS SETS UP THE CALLING SEQUENCE FOR SVC 202. 00098000
* 00099000
************** 00100000
SPACE 00101000
MACRO 00102000
&NAME CMS &PLIST,&PROG=,&ERROR= 00103000
&NAME LA 1,&PLIST 00104000
AIF (N'&PROG EQ 0).SEQ2 00105000
MVC 0(8,1),=CL8'&PROG' 00106000
.SEQ2 SVC X'CA' 00107000
AIF (N'&ERROR EQ 0).SEQ1 00108000
AIF ('&ERROR' EQ 'IGNORE').SEQ3 00109000
AIF ('&ERROR' EQ 'DIE').SEQ4 00110000
DC AL4(&ERROR) 00111000
MEXIT 00112000
.SEQ4 DC AL4(*) ...'DIE' IF UNEXPECTED CMS ERROR... 00113000
MEXIT 00114000
.SEQ3 DC AL4(*+4) 00115000
.SEQ1 MEND 00116000
EJECT 00117000
*. 00118000
* 00119000
* MODULE NAME: 00120000
* 00121000
* DMSEDI (EDIT) 00122000
* 00123000
* FUNCTION: 00124000
* 00125000
* TO MODIFY THE CONTENTS OF AN EXISTING FILE OR TO CREATE 00126000
* A NEW FILE. 00127000
* 00128000
* ATTRIBUTES: 00129000
* 00130000
* DISK RESIDENT 00131000
* 00132000
* ENTRY POINTS: 00133000
* 00134000
* DMSEDI - SEE FUNCTION DESCRIPTION 00135000
* 00136000
* ENTRY CONDITIONS: 00137000
* 00138000
* GPR1 - A(EDCB) 00139000
* 00140000
* EXIT CONDITIONS: 00141000
* 00142000
* NORMAL - GPR15 = 0 00143000
* 00144000
* ERROR - GPR15 ¬= 0 00145000
* 00146000
* GPR15 = 20 INVALID CHARACTER 00147000
* 00148000
* 24 INCOMPLETE FILEID 00149000
* 24 INVALID OPTION 00150000
* 24 INVALID LRECL PARAMETER 00151000
* 00152000
* 28 EDIT WORK-FILE "EDIT CMSUT1" EXISTS. 00153000
* IF IT IS WANTED, RENAME THE FILENAME OR FILETYPE; 00154000
* OTHERWISE, ERASE IT. 00155000
* 00156000
* 88 RECORD LENGTH TOO LARGE FOR EDIT 00157000
* 00158000
* 40 GIVE A LARGER RECORD-LENGTH IN THE LRECL PARAMETE 00159000
* 00160000
* 88 FILE TOO LARGE FOR EDIT - INSUFFICIENT STORAGE 00161000
* 00162000
* 100 I/O ERROR, READING/WRITING FILE 00163000
* 00164000
* 00165000
* CALLS TO OTHER ROUTINES: 00166000
* 00167000
* DMSSCR - WRITE TO DISPLAY TERMINAL 00168000
* DMSBWR - WRITE A FILE TO DISK 00169000
* DMSBRD - READ A FILE FROM DISK 00170000
* DMSSTT - VERIFY EXISTENCE OF A FILE 00171000
* DMSRNM - ALTER FILEID 00172000
* DMSCWRB - TYPE INFORMATION TO USER CONSOLE 00173000
* DMSCWT - WAIT ON CONSOLE I/O 00174000
* DMSCRD - WAIT ON CONSOLE RESPONSE 00175000
* DMSCAT - STACK CONSOLE INPUT 00176000
* DMSERS - ERASE UTILITY FILES 00177000
* DMSFNS - 'CLOSE' A FILE 00178000
* 00179000
* EXTERNAL REFERENCES: 00180000
* 00181000
* EDCANON - EXTERNAL CANONICALIZATION ROUTINE 00182000
* 00183000
* EDCMS - 00184000
* EDAFSTFN: ADDRESS OF FINISHED READ BUFFER IN 00185000
* CMS 'NUCON'. 00186000
* 00187000
* EDASTRIN: ADDRESS OF STORAGE INITIALIZATION ROUTINE 00188000
* ('STRINIT') IN CMS 'NUCON'. 00189000
* 00190000
* OPERATION: 00191000
* 00192000
* THE EDIT MODULE IS LOADED INTO STORAGE BY THE EDIT 00193000
* INITIALIZATION MODULE, DMSEDX. IT MAY RESIDE IN A 00194000
* DISCONTIGUOUS SEGMENT OR IN USER STORAGE. DMSEDX 00195000
* GETS FREE STORAGE FOR AND INITIALIZES THE EDIT 00196000
* FREE WORKING STORAGE (EDCB), THEN LOADS AND 00197000
* BRANCHES TO THE EDIT MODULEWITH REGISTER 1 00198000
* CONTAINING THE ADDRESS OF EDCB. 00199000
* UPON ENTRY, A MESSAGE IS TYPED TELLING THE 00200000
* USER HE IS IN THE EDIT ENVIRONMENT AND 'WAITRD' IS CALLED 00201000
* TO READ A LINE FROM THE TERMINAL. IF A NULL LINE IS ENTERED, 00202000
* ANOTHER READ FROM THE TERMINAL IS EXECUTED. 00203000
* IF THE LINE IS NOT NULL, THE FIRST ENTRY ON THE LINE IS 00204000
* ASSUMED TO BE AN EDIT SUB-COMMAND; IF IT IS, A BRANCH IS 00205000
* TAKEN TO THE APPROPRIATE EDIT SUB-ROUTINE TO PROCESS THE 00206000
* COMMAND. 00207000
* IF THE FIRST ENTRY IS NOT RECOGNIZED AS A SUB-COMMAND, 00208000
* AN ERROR MESSAGE IS ISSUED TO THE TERMINAL AND ANOTHER 00209000
* READ IS ISSSUED TO THE TERMINAL. 00210000
* 00211000
*. 00212000
EJECT 00213000
PUNCH 'SPB' @VM03178 00214000
DMSEDI START X'0' 00215000
EDIT EQU * 00216000
LR R10,R14 ADDRESSABILITY FOR 1ST PAGE @V305614 00217000
LA 15,4095 00218000
LA 11,1(10,15) ... FOR 2ND PAGE 00219000
LA 12,1(11,15) ... FOR 3RD PAGE 00220000
USING DMSEDI,10 00221000
USING DMSEDI+4096,11 00222000
USING DMSEDI+8192,12 00223000
USING NUCON,0 @V200714 00224000
USING EDCB,R13 @V305614 00225000
LR R13,R1 SET FREE STOR ADDRESSABILITY @V305614 00226000
DMSKEY USER RUN WITH USER KEY(FOR SAFETY)@VA04825 00227000
SSM FE ALLOW INPUT WHILE EDITTING @VA04825 00228000
CMS CWAIT SYNCHRONIZE OUTPUT @VA04825 00229000
SPACE 1 00230000
REFRESH EQU * @V2D3913 00231000
NI FLAG2,255-INMODE CANNOT BE 'INPUT' MODE @V2D3913 00232000
TM FLAG2,TUBE IS THIS A DISPLAY TERMINAL ? @V2D3913 00233000
BNO PEDIT IF NOT, TYPE 'EDIT:' @V2D3913 00234000
VERIFY RETURN=PEDIT1 @V2D3913 00235000
SPACE 1 00236000
DS 0F @VM03243 00237000
CWAIT DC CL8'CONWAIT' @VM03243 00238000
EJECT 00239000
*********************************************************************** 00240000
* 00241000
* PRINT OUT 'EDIT:' AND ENTER EDIT MODE - ACCEPTING 00242000
* REQUESTS FROM THE USER. 00243000
* 00244000
*********************************************************************** 00245000
SPACE 00246000
MPEDIT EQU * @VA07347 00247000
TM FLAG2,VER IS THIS VERIFY MODE? @VA07347 00248000
BO PEDIT BRANCH IF YES @VA07347 00249000
OI TWITCH,VEROVER SET VERIFY OVERRIDE FLAG @VA07347 00250000
SPACE 1 00251000
PEDIT VTYPE EDITXX @V2D3913 00252000
SPACE 00253000
PEDIT1 EQU * 00254000
EX 0,NEXT6 ZERO X-Y COUNT 00255000
SPACE 00256000
NEXT EQU * NORMAL RETURN POINT FOR NEXT REQUEST 00257000
NI SIGNAL,255-REPL ENSURE REPLACE FUNC IS OFF @VA04196 00258000
TM TWITCH,TOPSW+EOF ENDRANGE? @V2D3913 00259000
BZ NEXT4 BRANCH IF NOT 00260000
NEXT6 EQU * 00261000
XC XYCNT,XYCNT CLEAR X-Y COUNT JUST IN CASE 00262000
NEXT4 EQU * RETURN FROM X OR Y COMMAND 00263000
NI TWITCH,255-(TRUNC+UPWARD) RESET TWITCH, @V2D3913 00264000
MVI SCRFLGS,X'00' SCRFLGS, AND SCRFLG2 FOR @V2D3913 00265000
MVI SCRFLG2,X'00' THE NEXT COMMAND @V2D3913 00266000
L 2,XYCNT GET X-Y COUNT 00267000
LTR 2,2 IS IT ZERO? 00268000
BZ NEXT8 BRANCH IF SO 00269000
BCTR 2,0 MINUS ONE 00270000
ST 2,XYCNT STORE NEW VALUE 00271000
B NEXT5 00272000
SPACE 00273000
NEXT8 EQU * 00274000
NI XYFLAG,255-(XACT+YACT) CLEAR X-ACTIVE AND Y-ACTIVE 00275000
TM SIGNAL,QUOD WAS LAST REQUEST ? OR "? 00276000
BO NEXT10 BRANCH IF SO 00277000
LH 1,COUNT LENGTH OF REQUEST 00278000
STH 1,SAVCNT SAVE IT 00279000
LTR 1,1 TEST IT 00280000
BZ NEXT10 BRANCH IF NOUGHT 00281000
BCTR 1,0 DECREASE FOR EXEC 00282000
EX 1,SAVREQ SAVE THE REQUEST IN TABLIN 00283000
OI SIGNAL,QUOD LIE THAT IT'S A ? OR " (MAY BE NULL LINE) 00284000
NEXT10 EQU * 00285000
BAL 14,RDTYPE READ A LINE FROM THE TERMINAL 00286000
BNZ CKLINSEQ HANDLE EDIT LINE INPUT @VA08152 00286250
NI UTILFLAG,255-LINSEQ RESET ERROR FLAG @VA08152 00286500
B MPEDIT CC=0 MEANS NULL LINE @VA08152 00286750
CKLINSEQ EQU * 00287000
TM UTILFLAG,LINSEQ LINE-NUMBER CONSTRICTION? @VA08152 00287250
BO NEXT10 PURGE INPUT LINES @VA08152 00287500
NI SIGNAL,255-(QUOD+OVER) CLEAR ? AND " AND OVERLAY FLAGS 00288000
XC DITCNT,DITCNT CLEAR DITCNT 00289000
SPACE 00290000
NEXT5 EQU * COME HERE IS IT'S AN X OR Y REQUEST 00291000
XC EDCT,EDCT CLEAR EDCT 00292000
BAL 14,GET GET EDIT TOKEN 00293000
BZ INVREQ INVALID REQUEST IF CC = 0 00294000
NEXT1 EQU * @VA06391 00295000
TM GETFLAG,ALPHA+NONALNUM 00296000
BZ SFIND TOKEN NUMERIC - FIND LINENO. 00297000
SPACE 00298000
LA 2,PRQUEST ADDRESS OF PRE-REQUEST TABLE 00299000
LA 3,PRQEND END OF PRE-REQUEST TABLE 00300000
BAL 14,REQSUB SEARCH TABLE 00301000
LA 14,1 LOAD UP A CONSTANT OF 1 @V200713 00302000
ST 14,REPCNT RESET REPCNT @V200713 00303000
LA 2,RQUEST ADDRESS OF MAIN REQUEST TABLE 00304000
LA 3,REQEND END OF MAIN REQUEST TABLE 00305000
BAL 14,REQSUB SEARCH TABLE 00306000
B INVREQ BRANCH IF NOT FOUND 00307000
SPACE 00308000
SAVREQ MVC TABLIN(*-*),EDLIN SAVE THE LAST REQUEST 00309000
SPACE 00310000
EDITXX DC C'EDIT:' 00311000
EJECT 00312000
************** 00313000
* 00314000
* SUBROUTINE TO SEARCH REQUEST TABLE. 00315000
* 00316000
* CALL: 00317000
* BAL 14,REQSUB 00318000
* 00319000
* ON ENTRY: 00320000
* R1 HOLDS LENGTH-1 OF GIVEN REQUEST 00321000
* R2 HOLDS STARTING ADDRESS OF REQUEST TABLE 00322000
* R3 HOLDS END ADDRESS OF REQUEST TABLE 00323000
* 00324000
* IF MATCH IS FOUND, A DIRECT BRANCH IS TAKEN FROM HERE 00325000
* TO THE APPROPRIATE ROUTINE. OTHERWISE WE RETURN TO CALLER. 00326000
* 00327000
* (LEVEL 1 SUBROUTINE, CALLED FROM PEDIT. USES REGSAV.) 00328000
* 00329000
************** 00330000
SPACE 00331000
REQSUB DS 0H 00332000
LA R4,XXXCWD-1(R1) POINT TO END OF ARG @V2D3913 00333000
SR R15,R15 EMPTY A REGISTER @V2D3913 00334000
LR R5,R1 SAVE A COPY OF REG(1) @V2D3913 00335000
CLC 0(2,R4),=CL2'UP' WAS UP SPECIFIED? @V2D3913 00336000
BNE ISITU WASN'T CL2'UP', SO GO ON @V2D3913 00337000
BCTR R1,R0 DECREMENT THE COUNT REGISTER @V2D3913 00338000
B UORUP GO TO COMMON CODE @V2D3913 00339000
ISITU CLI 1(R4),C'U' MAYBE JUST U? @V2D3913 00340000
BNE REQLOOP IF NOT, NOT UPWARD @V2D3913 00341000
UORUP BCTR R1,R0 DECREMENT COUNT REGISTER @V2D3913 00342000
OI TWITCH,UPWARD TURN ON THE UP FLAG @V2D3913 00343000
LTR R1,R1 ANY COUNT LEFT? @V2D3913 00344000
BM NEXLIN IF NOT, IT'S JUST "UP" @V2D3913 00345000
SPACE 1 00346000
REQLOOP EQU * SEARCH THE TABLE 00347000
IC 15,0(2) PICK UP MINIMUM LENGTH OF REQUEST 00348000
BCTR 15,0 DECREASE FOR COMPARISON 00349000
CR 1,15 ENOUGH CHARACTERS TYPED IN? 00350000
IC 15,1(2) (PICK UP MAXIMUM LENGTH ANYWAY) 00351000
BL REQLP1 BRANCH IF NOT ENOUGH CHARACTERS 00352000
CR 1,15 TOO MANY CHARACTERS TYPED IN? 00353000
BNL REQLP1 BRANCH IF SO 00354000
EX 1,REQCOMP DO WE HAVE A MATCH? 00355000
BE REQGO BRANCH IF SO 00356000
REQLP1 LA R2,5(R15,R2) ADDRESS OF NEXT ENTRY IN TABLE. @V2D3913 00357000
CR 2,3 HAVE WE REACHED AND OF TABLE? 00358000
BL REQLOOP LOOP IF NOT 00359000
LR R1,R5 GET BACK THE OLD REG(1) @V2D3913 00360000
BR 14 RETURN 00361000
SPACE 00362000
REQGO EQU * WE MAY HAVE FOUND THE ROUTINE @V2D3913 00363000
TM TWITCH,UPWARD DID IT LOOK LIKE UP @V2D3913 00364000
BNO REQGO1 NOT AT ALL @V2D3913 00365000
CLI 2(R2),X'01' IS UPWARD ALLOWED @V2D3913 00366000
BE REQGO1 O.K. IF SO @V2D3913 00367000
LA R5,4(R2,R1) INDEX INTO VALID COMMAND FORM @V2D3913 00368000
CLI 0(R5),C'U' DOES A 'U' HAPPEN TO BE THERE ? @V2D3913 00369000
BNER R14 DEFINITE ERROR IF NOT @V2D3913 00370000
CLC 0(2,4),=CL2'UP' BUT NOW YOU CAN'T GO UP @V2D3913 00371000
BER R14 ERROR IF YOU TRY @V2D3913 00372000
REQGO1 LA R2,3(R15,R2) GET OFFSET TO APPROVED ROUTINE @V2D3913 00373000
ICM 15,B'0011',0(2) GET DISPL TO COMMAND RTN @V200713 00374000
LA 15,EDIT(15) OFFSET BY BASE @V200713 00375000
BR 15 GO THERE @V200713 00376000
SPACE 2 00377000
REQCOMP CLC XXXCWD(*-*),3(R2) @V2D3913 00378000
EJECT 00379000
* 00380000
************** 00381000
* 00382000
* DEAL WITH INVALID REQUEST 00383000
* 00384000
************** 00385000
SPACE 00386000
INVREQ DS 0H INVALID EDIT REQUEST. TELL HIM SO. 00387000
TM FLAG2,LONGSW ARE WE IN LONG MODE? @V1D1613 00388000
BO INVREQ1 BRANCH IF SO 00389000
WTYPE INVD,1,RETURN=INVREQX @V200713 00390000
SPACE 00391000
INVDOT EQU * INVALID MACRO REQUEST 00392000
TM FLAG2,LONGSW ARE WE IN LONG MODE? @V1D1613 00393000
BO INVREQ1 BRANCH IF SO 00394000
WTYPE INVD,2,RETURN=INVREQX @V200713 00395000
SPACE 00396000
INVREQ1 EQU * 00397000
MVC INVLD(L'INVLDHDR),INVLDHDR SET MSG HEADER @VA04733 00398000
LA 1,INVLD ADDRESS OF ERROR MESSAGE 00399000
LA 0,EDLIN-INVLD LENGTH OF '?EDIT: ' 00400000
AH 0,COUNT ADD LENGTH OF REQUEST 00401000
BAL 14,WRTYPE TYPE MESSAGE 00402000
SPACE 00403000
INVREQX EQU * ERROR MESSAGE ALREADY GIVEN 00404000
LH 2,DITCNT GET DITCNT 00405000
LTR 2,2 TEST IT 00406000
BZ NEXT6 BRANCH IF ZERO 00407000
L 3,AFSTFNRD ADDR. TO TEST EXISTENCE OF STACK 00408000
SPACE 1 00409000
UNDITTO EQU * CLEAR THE STACK 00410000
L 1,0(3) VALUE OF FSTFINRD (DOES STACK EXIST?) 00411000
LTR 1,1 00412000
BZ NEXT6 BRANCH IF STACK IS EMPTY 00413000
BAL 14,RDTYPE READ ONE STACKED LINE 00414000
BCT 2,UNDITTO AND LOOP UNTIL DONE 00415000
B NEXT6 00416000
SPACE 2 00417000
INVD DC C'¬$' SHORT FORMS FOR INVALID EDIT REQUEST 00418000
EJECT 00419000
*********************************************************************** 00420000
* 00421000
* ENTER INPUT MODE AND ACCEPT LINES FROM THE CONSOLE 00422000
* AS NEW LINES TO BE PUT IN THE FILE. A NULL LINE 00423000
* TERMINATES THIS MODE AND REVERTS TO EDIT MODE. 00424000
* 00425000
*********************************************************************** 00426000
SPACE 00427000
PINPUT DS 0H TYPE 'INPUT:' IF IN VERIFY MODE 00428000
TM FLAG2,REMOTE+TUBE DISPLAY MODE WITH REMOTE ? @V2D3914 00429000
BNO PINPUT0 NO...BR @V2D3914 00430000
OI SCRFLG2,CANCB DON'T CAUSE MORE STATUS @VM01093 00431000
BAL R14,WRTYPEX ISSUE CONCEL OP TO SCREEN @VM01093 00432000
XI FLAG2,TUBE+SWITCH FLIP TUBE FLAG AND REMEMBER @V2D3914 00433000
PINPUT0 EQU * @V2D3914 00434000
OI FLAG2,INMODE GRAPHICS FLAG @V200714 00435000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V2D3913 00436000
BNO PINPUT1 TYPE 'INPUT:' IF NOT @V2D3913 00437000
TM FLAG2,VER VERIFY ON? @VA04074 00438000
BNO INPUT NO ... BR @VA04074 00439000
MVI SCRFLGS,WRSTATB REWRITE STATUS LINE @VA04074 00440000
VERIFY @V2D3913 00441000
MVI SCRFLGS,WRCLUPB WRITE FROM CL UP @V2D3914 00442000
B INPUT NOW GET NEXT LINE @V2D3913 00443000
SPACE 1 00444000
PINPUT1 EQU * @V2D3913 00445000
VTYPE INPUTXX INDICATE INPUT MODE 00446000
SPACE 00447000
INPUT EQU * 00448000
NI SIGNAL,255-QUOD CLEAR ? AND " FLAG 00449000
TM FLAG,RIGHT+LEFT LINEMODE ON? 00450000
BM PROMPTER GO TO PROMPTING ROUTINE 00451000
SPACE 1 00452000
INP1 EQU * 00453000
BAL 14,RDTYPE READ INPUT LINE 00454000
BNZ INP2 BR IF NOT NULL ENTRY @V2D3914 00455000
NI SIGNAL,255-REPL RESET REPLACE FLAG IF ON @VA04074 00456000
MVI SCRFLGS,WRSTATB CHANGE STATUS FIELD @V2D3914 00457000
TM FLAG2,SWITCH IF WE SET TUBE FLAG OFF, @V2D3914 00458000
BNO REFRESH THEN RESET IT @V2D3914 00459000
XI FLAG2,SWITCH+TUBE ....... @V2D3914 00460000
OI SCRFLGS,WRTOPB CAUSE A FULL DISPLAY @V2D3914 00461000
B REFRESH CLEAN UP AND GO TO EDIT @V2D3914 00462000
INP2 XC EDCT(2),EDCT CLEAR EDIT COUNT @V2D3914 00463000
BAL R4,TAKELINE GO DO THE RIGHT THING @V2D3913 00464000
B INPUT GET THE NEXT LINE @V2D3913 00465000
SPACE 1 00466000
INPUTXX DC C'INPUT:' 00467000
EJECT 00468000
************************************************************** 00469000
* 00470000
* 'REPLACE' REPLACES THE CURRENT LINE BY THE LINE 00471000
* FOLLOWING THE COMMAND. IF 'REPLACE' IS TYPED ALONE, 00472000
* INPUT MODE IS ENTERED. 00473000
* 00474000
*********************************************************************** 00475000
SPACE 00476000
RETYPE DS 0H TR 00477000
LA R2,1 SET THE REPLACE SIGNAL @V2D3913 00478000
TM TWITCH,TOPSW+EOF ARE WE AT TOP OR EOF? 00479000
BZ RTYP1 FLAG IS CORRECT @V2D3913 00480000
SPACE 1 00481000
INSERT EQU * @V2D3913 00482000
SR R2,R2 SET THE INSERT FLAG @V2D3913 00483000
SPACE 00484000
RTYP1 EQU * 00485000
CLC EDCT(2),COUNT WAS NULL LINE ENTERED? 00486000
BL RTYP4 BRANCH IF NOT 00487000
LTR 2,2 IS THIS INSERT 00488000
BZ PINPUT THEN GO DIRECTLY TO INPUT @V2D3913 00489000
OI SIGNAL,REPL SET TRICKY REPLACE MODE 00490000
B PINPUT NOW GO TO INPUT @V2D3913 00491000
SPACE 00492000
RTYP4 EQU * 00493000
TM FLAG,LEFT+RIGHT LINEMODE ON? 00494000
BM INVREQ ERROR IF SO 00495000
MVI SCRFLGS,WRCLUPB WRITE ALL CHANGES @V2D3914 00496000
LTR R2,R2 IS THIS INSERT? @V2D3913 00497000
BZ RTYP5 ALL SET IN THAT CASE @V2D3913 00498000
SPACE 1 00499000
RTYP4A EQU * @V2D3913 00500000
OI SIGNAL,REPL SET THE REPLACE FLAG @V2D3913 00501000
MVI SCRFLGS,WRCLB ONLY CL CHANGED @V2D3914 00502000
SPACE 1 00503000
RTYP5 EQU * 00504000
BAL R4,TAKELINE GO DO THE RIGHT THING @V2D3913 00505000
B NEXT ALL DONE @V2D3913 00506000
EJECT 00507000
************** 00508000
* 00509000
* TAKELINE INSERTS OR REPLACES LINES IN STORAGE 00510000
* ACCORDING TO THE SETTING OF THE REPL SWITCH IN FLAG 00511000
* 00512000
************** 00513000
SPACE 1 00514000
TAKELINE DS 0H @V2D3913 00515000
BAL R14,SPREAD UN-TAB THE LINE @V2D3913 00516000
NI CHNGFLAG,255-DTYPE TURN OFF DISPLAY TYPE FLAG @VA04851 00517000
L R14,ITEM GET THE ITEM LENGTH @V2D3913 00518000
BCTR R14,R0 LESS 1 FOR EXECUTE @V2D3913 00519000
EX R14,INMOVE MOVE CHARACTERS TO 'LINE' @V2D3913 00520000
LA R1,LINE WHERE IS LINE? @V2D3913 00521000
TM FLAG,LEFT+RIGHT LINEMODE ON? @V2D3913 00522000
BZ TL1 SKIP IF NOT. @V2D3913 00523000
LR R3,R1 MAKE A COPY OF A(LINE) @V2D3913 00524000
TM SIGNAL,REPL DISPLAY TYPE CHANGE ? @V2D3914 00525000
BNO TL0 NO ... BR @V2D3914 00526000
L R3,PTR2 SAVE THE OLD LINE NUMBER @V2D3914 00527000
AH R3,LMSTART ADD LINENUMBER OFFSET @V2D3914 00528000
MVC PADBUF+3(5),8(R3) FROM THE CORE CHAIN @V2D3914 00529000
TM FLAG,LINE8 LONG LINE NUMBERS ? @V2D3914 00530000
BNO TL0 NO ... BR @V2D3914 00531000
MVC PADBUF(8),8(R3) MOVE IN OLD NUMBER @V2D3914 00532000
TL0 LR R3,R1 MAKE A COPY OF A(LINE) @V2D3914 00533000
AH R3,LMSTART GET LINENUMBER OFFSET @V2D3913 00534000
TM FLAG,RIGHT LINEMODE RIGHT ? @V2D3914 00535000
BO TLRIGHT YES ... BR @V2D3914 00536000
MVC 0(5,R3),PADBUF+3 MOVE 5 DIGIT LINENUMBER @V2D3913 00537000
TM FLAG,LINE8 IS THIS A LONG LINENUMBER? @V2D3913 00538000
BNO TL1 ALL DONE IF NOT. @V2D3913 00539000
MVC 0(8,R3),PADBUF CHANGE THE LINENUMBER @V2D3913 00540000
B TL1 DONE WITH LONG LINENUMBERS @V2D3914 00541000
TLRIGHT MVC 0(5,R3),PADBUF+3 CHANGE RIGHT LINENUMBER @V2D3914 00542000
TL1 TM SIGNAL,REPL TRICKY REPLACE MODE? @V2D3913 00543000
BNZ TL2 YEP ... BR @VA04074 00544000
BAL R14,XWRITE WRITE OUT THE LINE @V2D3913 00545000
BNL TL3 BRANCH IF NO OVERFLOW. @V2D3913 00546000
TLERR EQU * COME HERE IF AUTOSAVE ERROR @VA04190 00547000
NI FLAG2,255-INMODE RESET INPUT MODE FLAG @VA04190 00548000
TM FLAG2,TUBE DISPLAY TERMINAL? @VA04190 00549000
BNO MPEDIT NO ... GO TYPE 'EDIT' @VA04190 00550000
OI SCRFLG2,MOREB MAKE SURE SEES PREV MSG @VA04190 00551000
MVI SCRFLGS,WRSTATB CHG STATUS TO EDIT @VA04190 00552000
TM FLAG2,VER VERIFY ON? @VA04190 00553000
BZ MPEDIT NO ... JUST TYPE 'EDIT' @VA04190 00554000
OI SCRFLGS,WRFULLB REWRITE SCREEN AND @VA04190 00555000
B MPEDIT GO TYPE 'EDIT' @VA04190 00556000
SPACE 1 00557000
TL2 NI SIGNAL,255-REPL ONLY HAPPENS ONCE @V2D3913 00558000
BAL R14,XREPLX REPLACE THE CURRENT LINE. @V2D3913 00559000
TL3 TM TWITCH,TRUNC TRUNCATED? @V2D3913 00560000
BO TL4 IF NOT, CONTINUE @V2D3913 00561000
TM FLAG2,TUBE GRAPHICS? @V2D3913 00562000
BNOR R4 IF NOT, ALL DONE. @V2D3913 00563000
BAL R14,VERSUB SHOW THE NEW LINE. @V2D3913 00564000
BR R4 NOW RETURN @V2D3913 00565000
SPACE 1 00566000
TL4 WTYPE TRUNCX @V2D3913 00567000
NI TWITCH,255-TRUNC RESET TRUNCATION FLAG @V2D3913 00568000
TM FLAG2,TUBE IS THIS A SCREEN @V2D3913 00569000
BOR R4 ALL DONE IF SO @V2D3913 00570000
LH R0,TRUNCOL SET THE TYPING LENGTH @V2D3913 00571000
LA R1,LINE AND THE TARGET ADDRESS. @V2D3913 00572000
BAL R14,WRTYPE3 DISPLAY THE CURRENT RESULT @V2D3913 00573000
BR R4 @V2D3913 00574000
EJECT 00575000
*********************************************************************** 00576000
* 00577000
* 'TYPE' WILL PRINT OUT THE CURRENT LINE AND THE 00578000
* NEXT N-1 LINES. 00579000
* 00580000
*********************************************************************** 00581000
SPACE 00582000
PRINT DS 0H 00583000
BAL 14,NUM GET PARM 00584000
BAL 14,STARCHK IF NOT NUMERIC, HOPEFULLY * 00585000
LR 2,0 SAVE IN R2 00586000
LH R3,VERLEN SAVE VERIFY LENGTH FOR LATER @V2D3914 00587000
LH R4,VERCOL1 AND THE 1ST VERIFY COLUMN @V2D3914 00588000
BCTR R4,R0 MINUS 1 AS AN INDEX TO THE LINE@V2D3914 00589000
BAL 14,NUM LOOK FOR SECOND ARGUMENT 00590000
B PRINSTAR CHECK FOR '*' IF NOT NUMERIC 00591000
BL PRINT1 BRANCH IF NOTHING THERE (USE VERCOL) 00592000
C 0,ITEM COMPARE WITH ITEM LENGTH 00593000
BH INVREQ BRANCH IF GREATER (INVALID) 00594000
LR 3,0 SET COLUMN LIMIT AS GIVEN 00595000
LTR R3,R3 CHECK IF NUMBER OF COLUMNS = 0 @VA07129 00596000
BZ INVREQ YES (INVALID REQUEST) @VA07129 00597000
PRINCHK EQU * CHECK NO MORE ARGUMENTS 00598000
BAL 14,PARMCHK CHECK NO MORE PARMS 00599000
PRINT1 EQU * 00600000
LTR R0,R2 HOW MANY LINES? @V2D3913 00601000
BZ NEXT BRANCH IF NONE 00602000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V200714 00603000
BNO PRINTSK NO...BR @V200714 00604000
OI TWITCH,VEROVER SET VERIFY OVERRIDE @V2D3913 00605000
BCT R0,TYPIN DECREMENT COUNT + USE NEXT @V2D3914 00606000
B LOCFND1 UNLESS NO COUNT @V2D3914 00607000
SPACE 1 00608000
PRINTSK EQU * @V200714 00609000
L R1,PTR2 GET THE CL POINTER @V2D3913 00610000
BAL R14,EORCHK TEST FILE BOUNDS @V2D3913 00611000
B PRINTLP1 MUST TYPE 'TOF' OR 'EOF' @V2D3913 00612000
B PRINTLP2 GO TYPE THE CURENT LINE @V2D3913 00613000
SPACE 00614000
PRINTLP EQU * 00615000
BAL R14,XNEXT GET POINTER TO NEXT LINE @V2D3913 00616000
TM TWITCH,TOPSW+EOF ENDRANGE? @V2D3913 00617000
BZ PRINTLP2 CONTINUE IF NOT @V2D3913 00618000
PRINTLP1 LA R2,1 FUDGE LOOP-COUNT @V2D3913 00619000
SPACE 1 00620000
PRINTLP2 EQU * @V2D3913 00621000
LR R0,R3 REFRESH VERIFY COLUMN @V2D3913 00622000
LA R1,8(R4,R1) POINT TO THE VERIFICATION COLUMN @V2D3914 00623000
BAL 14,WRTYPE2 TYPE LINE 00624000
BCT R2,PRINTLP LOOP 'TIL COUNT EXHAUSTED @V2D3913 00625000
B NEXT BRANCH IF ALL DONE 00626000
SPACE 00627000
PRINSTAR EQU * CHECK UP ON '*' 00628000
BAL 14,STARCHK IF NOT '*', ERROR - DON'T RETURN 00629000
L 3,ITEM SET COLUMN LIMIT TO ITEM LENGTH 00630000
SR R4,R4 IGNOR VERIFY COLUMN @VA04968 00631000
B PRINCHK GO CHECK NO MORE ARGUMENTS 00632000
EJECT 00633000
*********************************************************************** 00634000
** 00635000
** XWRITE--INSERT A LINE INTO CORE 00636000
** 00637000
** INPUT-- 00638000
** R1--ADDRESS OF LINE TO BE WRITTEN 00639000
** R14--RETURN ADDRESS 00640000
** 00641000
** OUTPUT-- 00642000
** THE UPDATED LIST 00643000
** PTR2=>INSERT (AS IF INSERT HAS JUST BEEN READ) 00644000
** (LINE JUST READ)=>INSERT=>(NEXT LINE) 00645000
** 00646000
** EXIT-- 00647000
** RETURN VIA R14 00648000
** CC SET NEGATIVE IF CORE EXHAUSTED 00649000
** 00650000
** (LEVEL 1 SUBROUTINE. USES REGSAV.) 00651000
** 00652000
*********************************************************************** 00653000
SPACE 00654000
XWRITE DS 0H 00655000
NI TWITCH,255-(TOPSW+EOF) NOT AT TOP OR BOTTOM 00656000
ST 14,REGSAV SAVE RETURN 00657000
L 14,SPARES NUMBER OF SPARES LEFT IN CORE 00658000
LTR 14,14 ANY? 00659000
BZ CORBUST BRANCH IF NOT 00660000
BCTR 14,0 REDUCE BY 1 00661000
ST 14,SPARES AND STORE AS NEW VALUE OF SPARES 00662000
L 15,FPTR LOAD FREE-LIST POINTER 00663000
LTR 15,15 IS LIST EMPTY 00664000
BNZ XWRIT08 NO, WE'RE OK 00665000
L 15,AEXTEND LIMIT TO WHICH WE'VE GONE SO FAR 00666000
SR 0,0 CLEAR FORWARD CHAIN OF NEW LINE 00667000
ST 0,0(,15) 00668000
LR 0,15 COMPUTE NEW BOUND 00669000
A 0,CORITEM 00670000
ST 0,AEXTEND AND SAVE IN AEXTEND 00671000
SPACE 00672000
XWRIT08 EQU * 00673000
L 0,0(,15) LOAD NEXT ENTRY ADDRESS 00674000
ST 0,FPTR AND UPDATE FREE-LIST POINTER 00675000
L 14,ITEM LOAD ITEM LENGTH 00676000
BCTR 14,0 MINUS '1' FOR 'EX' 00677000
EX 14,XWRIT02 MOVE IN LINE 00678000
L 1,PTR2 GR1=A(OLD ITEM) 00679000
ST 15,PTR2 READ PTR POINTS TO ITEM 00680000
L 14,0(,1) GR14=A(OLD+1) 00681000
ST 14,0(,15) E =>OLD+1 00682000
LTR 14,14 IS OLD+1=EOF 00683000
BNZ XWRIT08A NO ... BR @V2D3913 00684000
ST R15,PTR3 RESET BOTTOM LINE POINTER @V2D3913 00685000
B XWRIT08B CONTINUE @V2D3913 00686000
EJECT 00687000
XWRIT08A EQU * @V2D3913 00688000
ST 15,4(,14) NO, E <= OLD+1 00689000
XWRIT08B EQU * @V2D3913 00690000
ST 1,4(,15) OLD <= E 00691000
ST 15,0(,1) OLD => E 00692000
BAL 14,AUTOCHEK CHECK FOR AUTO. SAVING @V200706 00693000
L 14,SPARES 00694000
LTR 14,14 HOW MANY SPARES LEFT? 00695000
BZ CORFULL BRANCH IF NONE 00696000
SR 15,15 CLEAR CONDITION CODE 00697000
XWRITEX EQU * RETURN FROM 'XWRITE' 00698000
L 14,REGSAV RESTORE RETURN ADDRESS 00699000
BR 14 RETURN TO CALLER 00700000
SPACE 00701000
XWRIT02 MVC 8(*-*,15),0(1) BLANK 'MVC' FOR 'EX' 00702000
EJECT 00703000
****************************************************************** 00704000
* 00705000
* 'AUTOCHEK' IS CALLED TO CHECK FOR ACTIVE AUTOMATIC SAVING 00706000
* OF THE UPDATED FILE. ANY UPDATING SUBROUTINE (XWRITE, 00707000
* XREPL OR XDELE) CALLS BY BAL 14,AUTOCHEK . 00708000
* 00709000
* (LEVEL 2 SUBROUTINE. USES AUTOREG.) 00710000
* 00711000
****************************************************************** 00712000
SPACE 1 00713000
AUTOCHEK EQU * COME HERE TOO FROM 'REPLACE'@V200706 00714000
TM SIGNAL,AUTOFLAG AUTO. SAVE ACTIVE? @V200706 00715000
BCR 8,14 IF NOT, RETURN @V200706 00716000
STM 13,9,AUTOREG SAVE CALLER'S STUFF @V200706 00717000
LH 1,AUTOCURR IF SO, BUMP THE LINE COUNT @V200706 00718000
LA 1,1(,1) @V200706 00719000
CH 1,AUTOCNT AND CHEK FOR LIMIT @V200706 00720000
BL UPAUTO @V200706 00721000
OI SIGNAL,AUTOSVFL IF LIMIT REACHED, SAVE. @V200706 00722000
MVC NEWNAME(18),FNAME MAKE SURE WE IDENTIFY IT @V200706 00723000
B FILE1 @V200706 00724000
UPAUTO STH 1,AUTOCURR @V200706 00725000
SAVRET EQU * COME HERE AFTER AUTO. SAVE @V200706 00726000
LM 13,9,AUTOREG @V200706 00727000
BR 14 RETURN TO CALLING SUBROUTINE@V200706 00728000
EJECT 00729000
*********************************************************************** 00730000
** 00731000
** XREPL--REPLACE A LINE IN CORE 00732000
** 00733000
** INPUT-- 00734000
** UPDATE LINE IN 'LINE' 00735000
** R14--RETURN REGISTER 00736000
** 00737000
** OUTPUT-- 00738000
** UPDATED LINE IN CORE 00739000
** 00740000
** EXITS-- 00741000
** RETURN TO CALLER 00742000
** 00743000
* (LEVEL N SUBROUTINE. USES REGSAV ) 00744000
** 00745000
*********************************************************************** 00746000
SPACE 00747000
XREPL DS 0H @V2D3914 00748000
TM FLAG,CAN CANONICALIZATION ON? 00749000
BZ XREPLX BRANCH IF NOT 00750000
LA 1,LINE 00751000
L 0,ITEM ITEM LENGTH IN R0 00752000
BAL 15,CANON GO CANONICALIZE 00753000
SPACE 00754000
XREPLX EQU * 00755000
ST 14,REGSAV SAVE CALLER'S ADDRESS @V200706 00756000
L 15,PTR2 LOAD READ POINTER 00757000
L 1,ITEM LOAD ITEM LENGTH 00758000
BCTR 1,0 MINUS '1' FOR 'EX' 00759000
EX 1,XREPL01 UPDATE RECORD IN LIST 00760000
TM TWITCH,SAVOVER OVERRIDE AUTOSAVE ? @V2D3914 00761000
BO NOSAV YES ... BR @V2D3914 00762000
BAL 14,AUTOCHEK CHECK FOR AUTO. SAVING @V200706 00763000
NOSAV L R14,REGSAV RESTORE RETURN REG @V2D3914 00764000
BR 14 AND RETURN TO CALLER 00765000
SPACE 00766000
XREPL01 MVC 8(*-*,15),LINE BLANK 'MVC' FOR 'EX' 00767000
EJECT 00768000
*********************************************************************** 00769000
** 00770000
** XREAD--READ AN LINE FROM CORE 00771000
** 00772000
** INPUT-- 00773000
** R14--RETURN ADDRESS 00774000
** 00775000
** OUTPUT-- 00776000
** THE NEXT LINE IN 'LINE' 00777000
** 00778000
** EXITS-- 00779000
** VIA R14 ONLY 00780000
** (EOF FLAG SET IF AT EOF) 00781000
** 00782000
** (LEVEL 1 SUBROUTINE. USES REGSAV.) 00783000
** 00784000
*********************************************************************** 00785000
SPACE 00786000
XREAD DS 0H 00787000
ST 14,REGSAV SAVE R14 00788000
BAL 14,XNEXT CALL XNEXT TO DO THE WORK 00789000
L 14,REGSAV RESTORE R14 00790000
SPACE 00791000
XREADB EQU * SECONDARY ENTRY POINT 00792000
L 15,ITEM LOAD ITEM LENGTH 00793000
L R1,PTR2 REFRESH POINTER TO CL @V2D3913 00794000
BCTR 15,0 MINUS '1' FOR 'MVC' 00795000
EX 15,XREAD02 MOVE DATA INTO 'LINE' 00796000
BR 14 AND RETURN TO CALLER 00797000
SPACE 2 00798000
XREAD02 MVC LINE(*-*),8(1) BLANK 'MVC' FOR 'EX' 00799000
EJECT 00800000
*********************************************************************** 00801000
** 00802000
** XNEXT (AND XNEXTA) -- CHAIN TO NEXT LINE IN CORE 00803000
** WITHOUT MOVING THE CONTENTS 00804000
** 00805000
** CALL: 00806000
** BAL 14,XNEXT (OR BAL 14,XNEXTA) 00807000
** 00808000
** ACTION: 00809000
** SETS NEW VALUE OF READ POINTER (PTR2); 00810000
* SETS EOF OR TOPSW AS APPROPRIATE. 00811000
** 00812000
** EXIT: 00813000
** BR 14 00814000
** 00815000
** (LEVEL 1 SUBROUTINE; LEVEL N WHEN CALLED FROM 00816000
** XREAD OR XDELE.) 00817000
** 00818000
*********************************************************************** 00819000
SPACE 00820000
XNEXT DS 0H 00821000
L R15,PTR2 GET THE CURRENT LINE POINTER @V2D3913 00822000
TM TWITCH,UPWARD IS THIS AN UP REQUEST @V2D3913 00823000
BO XNEXTA IF SO, GO HANDLE @V2D3913 00824000
L R1,0(,R15) GR1 = A(OLD+1) @V2D3913 00825000
LTR R1,R1 IS OLD+1 = EOF ? @V2D3913 00826000
BNZ XNEXTB NO ... BR @V2D3913 00827000
OI TWITCH,EOF TURN ON THE EOF INDICATOR @V2D3913 00828000
NI TWITCH,255-TOPSW TURN OFF TOF INDICATOR @V2D3913 00829000
LR R1,R15 LOAD PTR INTO PARM REG @V2D3913 00830000
BR R14 RETURN @V2D3913 00831000
SPACE 1 00832000
XNEXTA L R1,4(,R15) GR1 = A(OLD-1) @V2D3913 00833000
LTR R1,R1 IS OLD-1= TOF ? @V2D3913 00834000
BZ XNEXTC YES ... BR @V2D3913 00835000
C R15,PTR1 ARE WE AT TOF ? @V2D3913 00836000
BNE XNEXTB NO ... BR @V2D3913 00837000
TM TWITCH,EOF ARE WE AT EOF ? @V2D3913 00838000
BO XNEXTB YES ... BR @V2D3913 00839000
LA R15,PTR1 SET CURRENT LINE POINTER @V2D3913 00840000
ST R15,PTR2 TO TOF AND @V2D3913 00841000
B XNEXTC SET FLAG @V2D3913 00842000
SPACE 1 00843000
XNEXTB TM TWITCH,EOF ARE WE AT EOF ? @V2D3913 00844000
BZ XNEXTB1 NO ... BR @V2D3913 00845000
LR R1,R15 DON'T CHANGE CURRENT LINE PTR @V2D3913 00846000
XNEXTB1 ST R1,PTR2 LOAD CURRENT LINE PTR @V2D3913 00847000
NI TWITCH,255-(TOPSW+EOF) RESET LIMIT FLAGS @V2D3913 00848000
BR R14 RETURN @V2D3913 00849000
SPACE 1 00850000
XNEXTC OI TWITCH,TOPSW SET TOF @V2D3913 00851000
NI TWITCH,255-EOF RESET EOF @V2D3913 00852000
LR R1,R15 LOAD PTR INTO PARM REG @V2D3913 00853000
BR R14 RETURN @V2D3913 00854000
EJECT 00855000
*********************************************************************** 00856000
* 00857000
* CLOSE IS A SUBROUTINE WHICH SETS THE TOP LINE AS THE 00858000
* CURRENT LINE UNLESS AT TOF WHEN GOING UPWARD 00859000
* IN WHICH CASE EOF IS SET. 00860000
* 00861000
* CALL: 00862000
* BAL 14,CLOSE 00863000
* 00864000
* (LEVEL 1 SUBROUTINE) 00865000
* 00866000
*********************************************************************** 00867000
SPACE 00868000
CLOSE DS 0H 00869000
TM TWITCH,UPWARD+TOPSW TOF & UPWARD? @V2D3913 00870000
BO CLOSE1 HANDLE IF SO @V2D3913 00871000
OI TWITCH,TOPSW BACK AT TOP OF FILE 00872000
NI TWITCH,255-EOF CLEAR EOF BIT 00873000
LA 0,PTR1 POINT TO 'TOP' OF FILE 00874000
CLOSEX EQU * @V2D3913 00875000
ST 0,PTR2 RESET READ POINTER 00876000
BR 14 AND RETURN TO CALLER 00877000
SPACE 1 00878000
CLOSE1 OI TWITCH,EOF SET END-OF-FILE @V2D3913 00879000
NI TWITCH,255-TOPSW TURN OFF TOF @V2D3913 00880000
L R0,PTR3 LOAD BOTTOM LINE PTR @V2D3913 00881000
B CLOSEX JOIN COMMON CODE @V2D3913 00882000
SPACE 3 00883000
*************************************************************** 00884000
* 00885000
* EORCHK CHECKS FOR TOPSW+UPWARD OR EOF+¬UPWARD 00886000
* 00887000
*************************************************************** 00888000
SPACE 1 00889000
EORCHK DS 0H @V2D3913 00890000
TM TWITCH,TOPSW+UPWARD UPPER BOUND? @V2D3913 00891000
BOR R14 RETURN, IF SO. @V2D3913 00892000
TM TWITCH,UPWARD IS THE DIRECTION UPWARD AT ALL? @V2D3913 00893000
BO 4(,R14) NO PROBLEM, IF SO. @V2D3913 00894000
TM TWITCH,EOF THEN, IS IT END-OF-FILE? @V2D3913 00895000
BOR R14 RETURN, IF SO. @V2D3913 00896000
B 4(,R14) ALL ELSE IS OK @V2D3913 00897000
EJECT 00898000
*************************************************************** 00899000
* 00900000
* 'NOTFOUND' AND 'ENDRANGE' ARE BRANCHED TO FROM ALL 00901000
* OVER THE PLACE AND TYPE 'EOF' OR 'TOF' AS REQUIRED 00902000
* 00903000
*********************************************************************** 00904000
SPACE 00905000
NOTFOUND DS 0H (COME HERE FROM FIND, LOCATE AND CHANGE) 00906000
MVI SCRFLGS,WRFULLB REWRITE ALL TEXT @V2D3913 00907000
WTYPE FLDNTFND TELL HIM FIELD NOT FOUND 00908000
TM FLAG2,TUBE DISPLAY TUBE? @V2D3913 00909000
BO NEXT SCREEN LOOKS FINE IF SO @V2D3913 00910000
SPACE 1 00911000
ENDRANGE TM TWITCH,EOF+TOPSW ENDRANGE? @V2D3913 00912000
BZ NEXT NOPE, SO GET NEXT REQUEST @V2D3913 00913000
ENDRANG1 OI SCRFLGS,WRFULLB @V2D3913 00914000
VERIFY RETURN=NEXT @V2D3913 00915000
SPACE 1 00916000
EOFREC DC C'EOF:' 00917000
TOPMSG DC C'TOF:' @V200713 00918000
EJECT 00919000
*********************************************************************** 00920000
* 00921000
* VERSUB--VERIFY SUBROUTINE (IT FIGURES) 00922000
* 00923000
* INPUT-- 00924000
* R14--RETURN REGISTER 00925000
* 00926000
* OUTPUT-- 00927000
* TYPED OUT LINE IF IN VERIFY MODE 00928000
* 00929000
* EXITS-- 00930000
* RETURN VIA R14 ONLY 00931000
* 00932000
* (LEVEL 1 SUBROUTINE; ALSO CALLED AS LEVEL 2 SUBROUTINE 00933000
* FROM REPT ONLY. USES REGSAV.) 00934000
* 00935000
*********************************************************************** 00936000
SPACE 00937000
VERSUB DS 0H 00938000
TM FLAG2,VER VERIFY MODE? @V1D1613 00939000
BO MVERSUB YES ... BR @V2D3913 00940000
TM TWITCH,VEROVER IMMEDIATE VERIFY(OVERRIDE)? @V2D3913 00941000
BZR R14 NO ... BR @V2D3913 00942000
NI TWITCH,255-VEROVER RESET OVERRIDE FLAG @V2D3913 00943000
MVERSUB STM 14,1,REGSAV @V2D3913 00944000
TM SCRFLGS,WRCLB+WRCLUPB+WRCLDNB+WRSTATB @V2D3913 00945000
BNZ VERTYP JUST DISPLAY AS SPECIFIED @V2D3913 00946000
OI SCRFLGS,WRTOPB WRITE ALL IF NO SPECIFIC REQUEST @V2D3913 00947000
VERTYP LH R0,VERLEN LOAD VERIFY LENGTH @V2D3914 00948000
L R1,PTR2 POINT TO THE CURRENT LINE @V2D3913 00949000
LH R14,VERCOL1 SET VERIFY INDEX FOR @V2D3914 00950000
BCTR R14,R0 WRTYPE @V2D3914 00951000
LA R1,8(R14,R1) POINT TO DATA PORTION @V2D3914 00952000
BAL 14,WRTYPE2 TYPE LINE 00953000
LM 14,1,REGSAV RESTORE REGISTERS 00954000
BR 14 RETURN TO CALLER 00955000
EJECT 00956000
*********************************************************************** 00957000
* 00958000
* PARMCHK CHECKS WHETHER WE HAVE REACHED THE END OF THE 00959000
* ARGUMENT LIST. 00960000
* IF WE HAVE, IT RETURNS IMMEDIATELY. 00961000
* OTHERWISE IT JUMPS TO INVREQ. 00962000
* 00963000
* CALL: 00964000
* BAL 14,PARMCHK 00965000
* 00966000
* (LEVEL 1 SUBROUTINE) 00967000
* 00968000
*********************************************************************** 00969000
SPACE 00970000
PARMCHK DS 0H 00971000
STM 14,1,REGSAV SAVE REGS 00972000
LH 1,COUNT 00973000
SH 1,EDCT NO OF CHARS LEFT 00974000
BZ PARMRET NONE - RETURN PRONTO 00975000
BAL 14,GET CALL GET 00976000
BNZ INVREQ BRANCH IF PARMS 00977000
PARMRET EQU * 00978000
LM 14,1,REGSAV RESTORE REGS 00979000
BR 14 RETURN 00980000
SPACE 4 00981000
*********************************************************************** 00982000
* 00983000
* STARCHK CHECKS WHETHER XXXCWD CONTAINS '*' AND RETURNS WITH 00984000
* R0 = -1 AND CC +VE IF IT DOES. 00985000
* OTHERWISE IT JUMPS TO INVREQ. 00986000
* 00987000
* CALL: 00988000
* BAL 14,STARCHK 00989000
* 00990000
* (LEVEL 1 SUBROUTINE) 00991000
* 00992000
*********************************************************************** 00993000
SPACE 00994000
STARCHK DS 0H 00995000
CLI XXXCWD,C'*' 00996000
BNE INVREQ 00997000
SR 0,0 00998000
BCTR 0,0 SET FOR INFINITE LOOP 00999000
LPR 1,0 SET CC +VE 01000000
BR 14 RETURN 01001000
EJECT 01002000
*********************************************************************** 01003000
* 01004000
* GET SCANS EDLIN FROM EDCT AND PUTS THE NEXT TOKEN IN XXXCWD. 01005000
* 01006000
* CALL: 01007000
* BAL 14,GET 01008000
* 01009000
* WILL BRANCH DIRECTLY TO INVREQ (INVALID EDIT REQUEST) IF 01010000
* A TOKEN IS LONGER THAN 8 CHARACTERS, OR IF IT IS NOT 01011000
* APPROPRIATELY DELIMITED. 01012000
* 01013000
* (LEVEL 1 SUBROUTINE; LEVEL 2 WHEN CALLED FROM PARMCHK OR 01014000
* NUM. USES REGSAVX.) 01015000
* 01016000
*********************************************************************** 01017000
SPACE 01018000
GET DS 0H 01019000
MVC XXXCWD(8),XXXCWD-1 CLEAR XXXCWD 01020000
MVI GETFLAG,X'00' CLEAR GETFLAG 01021000
LH 1,EDCT START SCANNING HERE. 01022000
LH 0,COUNT DO THE NEXT COUNT-EDCT CHARACTERS. 01023000
SR 0,1 01024000
BNH GET3E IF NO MORE - RETURN EMPTY. 01025000
STM 2,4,REGSAVX 01026000
SR 2,2 NO. OF CHARS IN WORD 01027000
SPACE 01028000
GET1A EQU * @V200714 01029000
LA 3,EDLIN(1) 01030000
CLI 0(3),C' ' COMPARE FOR BLANK. 01031000
BE GET2 YES. 01032000
TM SIGNAL,GETCAT TEST GETCAT FLAG 01033000
BO GET3D BRANCH IF ON 01034000
BAL 4,CHARTYPE FIND CHARTYPE 01035000
BL GETNONAN BRANCH IF NOT ALPHANUMERIC 01036000
BH GETNUM BRANCH IF NUMERIC 01037000
TM SIGNAL,HEXSW HEX FLAG SET? 01038000
BZ GETALPH BRANCH IF NOT (ALPHABETIC) 01039000
MVI BYTE,X'40' PREPARE TO CONVERT TO UPPER CASE 01040000
OC BYTE(1),0(3) USE 'BYTE' (A USEFUL TEMP) 01041000
CLI BYTE,C'F' HEX? 01042000
BNH GETNUM BRANCH IF SO (TREAT AS NUMERIC) 01043000
SPACE 01044000
GETALPH EQU * IT'S ALPHABETIC 01045000
LTR 2,2 ANYTHING FOUND YET? 01046000
BNZ GETALPH1 BRANCH IF SO 01047000
OI GETFLAG,ALPHA SET THE ALPHABETIC FLAG 01048000
B GET3B AND CONTINUE 01049000
GETALPH1 EQU * 01050000
TM GETFLAG,ALPHA WAS THAT ALPHABETIC TOO? 01051000
BZ GET5 BRANCH IF NOT 01052000
B GET3C AND CONTINUE 01053000
SPACE 01054000
GETNONAN EQU * NOT ALPHANUMERIC 01055000
LTR 2,2 ANYTHING FOUND YET? 01056000
BNZ GET5 BRANCH IF SO (TERMINATE PRONTO) 01057000
OI GETFLAG,NONALNUM SET NON-ALPHANUMERIC FLAG 01058000
B GET3B AND CONTINUE 01059000
SPACE 01060000
GETNUM EQU * IT'S A NUMBER 01061000
LTR 2,2 ANYTHING FOUND YET? 01062000
BZ GET3B BRANCH IF NOT 01063000
TM GETFLAG,ALPHA+NONALNUM WAS THAT NUMERIC TOO? 01064000
BNZ GET5 BRANCH IF NOT (QUIT) 01065000
B GET3C CONTINUE 01066000
SPACE 01067000
GET3D EQU * 01068000
LTR 2,2 ANYTHING FOUND YET? 01069000
BNZ GET3C BRANCH IF SO 01070000
GET3B EQU * 01071000
STH 1,EDCT SAVE START OF TOKEN 01072000
GET3C EQU * 01073000
LA 2,1(2) INCREMENT TOKEN LENGTH 01074000
GET3A EQU * 01075000
LA 1,1(1) LOOK AT NEXT CHAR 01076000
BCT 0,GET1A AND LOOP UNTIL EDLIN EXHAUSTED @V200714 01077000
SPACE 01078000
LTR 2,2 ANYTHING FOUND? 01079000
BNZ GET5 BRANCH IF SO 01080000
LM 2,4,REGSAVX RESTORE REGISTERS 01081000
GET3E EQU * 01082000
NI SIGNAL,255-(GETCAT+HEXSW) CLEAR SPECIAL GET FLAGS 01083000
SR 1,1 SET CONDITION CODE 01084000
BR 14 RETURN 01085000
SPACE 01086000
GET2 EQU * FOUND A BLANK 01087000
LTR 2,2 ANYTHING FOUND YET? 01088000
BZ GET3A BRANCH IF NOT 01089000
LA 1,1(1) RESUME SEARCH AT NEXT CHARACTER 01090000
SPACE 01091000
GET5 EQU * 01092000
LH 0,EDCT SAVE STARTING POSITION 01093000
STH 1,EDCT STORE NEW START OF LOOK. 01094000
LR 1,0 01095000
LA 1,EDLIN-1(1) FORM STARTING ADDRESS. 01096000
LA 4,8 MAX ARGUMENT LENGTH @V200713 01097000
CR 2,4 SHOULDN'T BE GREATER @V200713 01098000
BH GETBUST BRANCH IF IT ISN'T 01099000
TM SIGNAL,GETCAT IS GETCAT SET? 01100000
BZ GET7 BRANCH IF NOT 01101000
CLI 0(1),C' ' CHECK THAT PRECEDING CHAR WAS BLANK 01102000
BNE GETBUST BRANCH IF IT WASN'T 01103000
SPACE 01104000
GET7 EQU * 01105000
LR 4,2 SAVE FOR SETTING COND. CODE PRESENTLY 01106000
BCTR 2,0 DECREASE FOR EXEC 01107000
EX 2,MOVCWD MOVE TOKEN INTO XXXCWD 01108000
CLI CASESW,C'S' LOWER-CASE FILE? 01109000
BNE GET9 BRANCH IF NOT 01110000
TM SIGNAL,HEXSW IS THIS A SPECIAL HEXSW CALL? 01111000
BO GET9 BRANCH IF SO 01112000
EX 2,UPCASE CONVERT TO UPPER CASE 01113000
SPACE 01114000
GET9 EQU * 01115000
NI SIGNAL,255-(GETCAT+HEXSW) CLEAR SPECIAL GET FLAGS 01116000
LR 1,2 RETURN VALUE 01117000
LTR 4,4 SET CONDITION CODE 01118000
LM 2,4,REGSAVX RESTORE REGS 01119000
BR 14 RETURN. 01120000
SPACE 01121000
GETBUST EQU * 01122000
NI SIGNAL,255-(GETCAT+HEXSW) CLEAR SPECIAL GET FLAGS 01123000
B INVREQ 01124000
SPACE 01125000
MOVCWD MVC XXXCWD(*-*),1(1) 01126000
EJECT 01127000
*********************************************************************** 01128000
* 01129000
* 'NUM' ACTS AS GET DOES, BUT DEALS WITH A NUMERIC TOKEN. 01130000
* LEAVES THE ANSWER IN R0. 01131000
* 01132000
* CALL: 01133000
* BAL 14,NUM 01134000
* 01135000
* NORMAL RETURN: 01136000
* B 4(,14) 01137000
* ERROR RETURN: 01138000
* BR 14 01139000
* 01140000
* IF NO FIELD IS PRESENT, CC IS SET -VE AND R0 = 1. 01141000
* 01142000
* (LEVEL 1 SUBROUTINE. USES REGSAV.) 01143000
* 01144000
*********************************************************************** 01145000
SPACE 01146000
NUM DS 0H 01147000
ST 14,REGSAV SAVE REGISTER 14. 01148000
BAL 14,GET CALL FOR NEXT FIELD INTO XXXCWD. 01149000
BNZ CHEKNUM BNZ IF SPECIFIED, CHECK NUMERIC-IND. 01150000
BCTR 1,0 01151000
LTR 1,1 01152000
LA 0,1 01153000
B NUM1 01154000
SPACE 01155000
CHEKNUM EQU * 01156000
TM GETFLAG,ALPHA+NONALNUM CHECK WHETHER NUMERIC TOKEN 01157000
BZ NUM2 VALID NUMERICAL ENTRY. TR 01158000
L 14,REGSAV OBTAIN RETURN ADDRESS TR 01159000
BR 14 ERROR RETURN TR 01160000
SPACE 01161000
NUM2 EQU * TR 01162000
LA 0,1(,1) SET R0 TO NUMBER OF CHARACTERS JS 01163000
LA 1,XXXCWD CALL FOR CONVERSION 01164000
BAL 14,DECBIN 01165000
LTR 0,1 RETURN CONDITION CODE. 01166000
SPACE 01167000
NUM1 EQU * 01168000
L 14,REGSAV RESTORE RETURN. 01169000
B 4(,14) NORMAL RETURN. TR 01170000
EJECT 01171000
*********************************************************************** 01172000
* 01173000
* 'SPREAD' ACCEPTS A LINE WHICH MAY CONTAIN TABS AND 01174000
* BACKSPACES, AND WHICH STARTS AT EDLIN(EDCT), AND SPREADS 01175000
* IT OUT ACCORDING TO THE CURRENT TAB SETTINGS. 01176000
* CHARACTERS ARE NOT AFFECTED BY BEING BACKSPACED OVER; 01177000
* CHARACTERS WHICH ARE MOVED OVER FORWARDS ARE REPLACED. 01178000
* 01179000
* IF CANONICALIZATION IS IN EFFECT, TABS AND BACKSPACES ARE 01180000
* NOT REPLACED; INSTEAD THE LINE IS PROCESSED BY THE CANAONI- 01181000
* CALIZING ROUTINE. 01182000
* 01183000
* IF 'IMAGE' IS OFF, THE LINE IS PASSED THROUGH AS TYPED. 01184000
* 01185000
* CALL: 01186000
* BAL 14,SPREAD 01187000
* 01188000
* (LEVEL 1 SUBROUTINE. USES REGSAV.) 01189000
* 01190000
*********************************************************************** 01191000
SPACE 01192000
SPREAD DS 0H 01193000
STM 2,6,REGSAV SAVE REGS 01194000
NI TWITCH,255-TRUNC CLEAR TRUNCATION BIT 01195000
L 1,ITEM ITEM LENGTH 01196000
BCTR 1,0 DECREASE FOR EXEC 01197000
EX 1,TABCLR CLEAR TABLIN AS FAR AS THE ITEM LENGTH 01198000
SR 5,5 CLEAR MAX. COLUMN COUNT 01199000
LA 4,TABS+1 GET LOCATION OF TABS TABLE 01200000
LH 3,COUNT NUMBER OF TYPED CHARACTERS. 01201000
LA R2,1 SET INITIAL OFFSET @VA03027 01202000
TM FLAG,LEFT @VA03536 01203000
BO BYPS YES, THEN DONT CHECK DISPLAY FLAG@VA03536 01204000
TM CHNGFLAG,DTYPE IS DISPLAY BIT ON? @VA03027 01205000
BNO BYPS NO, USE FIRST TAB @VA08298 01205300
CLI TABS,X'01' FIRST TAB BEYOND COLUMN 1? @VA08298 01205600
BNH NOTAB NO, BRANCH @VA08298 01205900
BCTR R4,0 POINT TO FIRST TAB SETTING @VA08298 01206200
B NOTAB ALL TABS AVAILABLE NOW @VA08298 01206500
BYPS SR 2,2 @VA03536 01207000
IC 2,TABS FIRST TAB IS START COLUMN 01208000
NOTAB LH 1,EDCT NUMBER CHARS ALREADY SCANNED @VA03027 01209000
SR 0,0 01210000
SR 3,1 COMPUTE NO. OF CHARACTERS LEFT TO SCAN. 01211000
BZ SPRET NONE LEFT. 01212000
LA 1,EDLIN(1) 01213000
LA 15,135 HANDY IF NOT CANON @V200713 01214000
SPACE 01215000
* CHECK FOR CANONICALIZATION ... 01216000
SPACE 01217000
TM FLAG,CAN CANONICALIZATION REQUIRED? 01218000
BZ SLOOP BRANCH IF NOT 01219000
LR 0,3 LENGTH IN R0 01220000
BCTR 3,0 DECREMENT FOR EXEC 01221000
EX 3,MOVSCRPT MOVE THE TYPED LINE INTO TABLIN 01222000
LA 1,TABLIN 01223000
BAL 15,CANON GO CANONICALIZE 01224000
LR 5,0 PUT NEW LWNGTH IN R5 01225000
B TRUNCO AND GO CHECK FOR TRUNCATION 01226000
SPACE 01227000
MOVSCRPT MVC TABLIN(0),0(1) 01228000
SPACE 01229000
* CANONICALIZATION NOT REQUIRED ... 01230000
SPACE 01231000
SLOOP EQU * 01232000
TM FLAG,IMNOT LINE IMAGE SUPPRESSED? 01233000
BO SLOOP2 BRANCH IF SO 01234000
CLI 0(1),TAB CHECK FOR TAB CHARACTER RAM 01235000
BE STBLP BRANCH IF A TAB @V200713 01236000
CLI 0(1),BACKSPAC NO, IS THIS REAL BACKSPACE 01237000
BNE SLOOP2 KEEP ON IF NOT @V200713 01238000
LA 4,TABS GET BEGINNING OF TABS @V200713 01239000
BCT 2,SLOOP1 DECREMENT COUNT @V200713 01240000
LA 2,1 @V200713 01241000
B SLOOP1 @V200713 01242000
SPACE 1 01243000
SLOOP2 EQU * 01244000
CH 2,TRUNCOL BEYOND TRUNC COL? 01245000
BH TRUNCATE BRANCH IF SO 01246000
SLOOP4 EQU * 01247000
IC 0,0(,1) PICK UP THE CHAR 01248000
STC 0,TABLIN-1(2) AND PUT IT INTO LINE IMAGE 01249000
CR 2,5 IS THIS A NEW COLUMN MAXIMUM? 01250000
BNH SLOOP3 BRANCH IF NOT 01251000
LR 5,2 SET COLUMN MAXIMUM 01252000
SLOOP3 EQU * 01253000
LA 2,1(,2) MOVE TO NEXT SPOT 01254000
SLOOP1 EQU * 01255000
LA 1,1(,1) ADVANCE INPUT IMAGE POINTER. 01256000
BCT 3,SLOOP AND GET NEXT CHARACTER. 01257000
SPACE 01258000
TRUNCO EQU * CHECK FOR TRUNCATION 01259000
LH 2,TRUNCOL TRUNCATION COLUMN 01260000
SR 5,2 LENGTH TO CHECK FOR BLANKS 01261000
BNH SPRET BRANCH IF NOTHING TO CHECK 01262000
LA 2,TABLIN(2) SPOT TO START 01263000
TRUNCLP EQU * 01264000
CLI 0(2),C' ' BLANK? 01265000
BE TRUNCLP1 BRANCH IF SO 01266000
TM SIGNAL,OVER OVERLAY FLAG SET? 01267000
BZ TRUNCLP2 BRANCH IF NOT 01268000
CLI 0(2),C'_' IS IT AN UNDERSCORE? 01269000
BE TRUNCLP1 BRANCH IF SO (THAT'S OK) 01270000
TRUNCLP2 EQU * 01271000
OI TWITCH,TRUNC SET TRUNCATION FOR REAL 01272000
MVI 0(2),C' ' CLEAR THE BYTE 01273000
TRUNCLP1 EQU * 01274000
LA 2,1(2) LOOK AT NEXT CHAR 01275000
BCT 5,TRUNCLP LOOP UNTIL FULLY CHECKED 01276000
SPACE 01277000
SPRET EQU * RETURN FROM SPREAD 01278000
LM 2,6,REGSAV RESTORE REGS 01279000
BR 14 01280000
SPACE 01281000
TRUNCATE EQU * 01282000
CLI 0(1),C' ' BLANK? 01283000
BE SPRUNC BRANCH IF SO 01284000
TM SIGNAL,OVER OVERLAY? 01285000
BZ TRUNOTO BRANCH IF NOT 01286000
CLI 0(1),C'_' UNDERSCORE? 01287000
BE SPRUNC BRANCH IF SO 01288000
TRUNOTO EQU * 01289000
CR 2,15 COMPARE WITH 135 @V200713 01290000
BNH SLOOP4 BRANCH IF NOT 01291000
OI TWITCH,TRUNC SET TRUNCATION FOR REAL 01292000
SPRUNC EQU * 01293000
CR 2,15 COMPARE WITH 135 @V200713 01294000
BNH SLOOP4 BRANCH IF SO 01295000
B SLOOP3 01296000
SPACE 01297000
STBLP EQU * 01298000
IC 0,0(,4) GET TAB VALUE 01299000
LTR 0,0 END OF TABS? 01300000
BZ SETRUNC BRANCH IF SO 01301000
LA 4,1(,4) ADVANCE TO NEXT TAB VALUE 01302000
CR 2,0 ARE WE PAST IT? 01303000
BL STBGOT BRANCH IF NOT (GOT IT) 01304000
B STBLP LOOP 01305000
SPACE 01306000
SETRUNC EQU * SET FOR TRUNCATION LATER 01307000
LA 0,255 01308000
SPACE 01309000
STBGOT EQU * 01310000
LA 6,X'40' INSERT A BLANK INTO R5 01311000
TABPADLP EQU * 01312000
CR 2,15 COMPARE WITH 135 @V200713 01313000
BH SETLCOL BRANCH IF SO 01314000
STC 6,TABLIN-1(2) PUT A BLANK INTO THE LINE IMAGE 01315000
LA 2,1(,2) MOVE ALONG ONE 01316000
CR 2,0 REACHED THE TAB STOP YET? 01317000
BL TABPADLP LOOP IF NOT 01318000
SETLCOL EQU * 01319000
LR 2,0 01320000
B SLOOP1 01321000
SPACE 01322000
TABCLR MVC TABLIN(*-*),TABLIN-1 BLANK MVC FOR CLEARING TABLIN 01323000
EJECT 01324000
*********************************************************************** 01325000
* 01326000
* NUMBER CONVERSION UTILITY ROUTINE 01327000
* 01328000
* CALL: 01329000
* BAL 14,DECBIN 01330000
* 01331000
* (LEVEL N SUBROUTINE) 01332000
* 01333000
*********************************************************************** 01334000
SPACE 01335000
DECBIN DS 0H 01336000
IC 15,PACK+1 FORM EXECUTABLE PACK INSTRUCTION 01337000
BCTR 0,0 01338000
OR 15,0 01339000
EX 15,PACK GET PACKED DECIMAL 01340000
OI DECIMAL+7,X'0F' FORCE PLUS 01341000
CVB 1,DECIMAL GET BINARY VALUE 01342000
BR 14 AND RETURN TO CALLER 01343000
SPACE 01344000
PACK PACK DECIMAL(8),0(0,1) PACK FOR 'EX' 01345000
EJECT 01346000
*********************************************************************** 01347000
* 01348000
* CHARTYPE SETS CONDITION CODE ACCORDING TO TYPE OF CHAR 01349000
* POINTED TO BY R3. 01350000
* 01351000
* -VE: NON-ALPHANUMERIC 01352000
* 0: ALPHABETIC 01353000
* +VE: NUMERIC 01354000
* 01355000
* CALL: 01356000
* BAL 4,CHARTYPE 01357000
* 01358000
* (LEVEL N SUBROUTINE) 01359000
* 01360000
*********************************************************************** 01361000
SPACE 01362000
CHARTYPE DS 0H 01363000
CLI 0(3),X'80' 01364000
BCR 4,4 RETURN IF NON-ALPHANUMERIC 01365000
CLI 0(3),X'F9' 01366000
BH EXOTIC BRANCH IF > '9' 01367000
CLI 0(3),X'EF' 01368000
BCR 2,4 RETURN IF NUMERIC 01369000
SR 15,15 SET CC = 0 01370000
BR 4 ALPHABETIC 01371000
SPACE 01372000
EXOTIC EQU * 01373000
SR 15,15 SET CC = -VE 01374000
BCTR 15,0 01375000
LTR 15,15 01376000
BR 4 01377000
SPACE 3 01378000
*********************************************************************** 01379000
* 01380000
* INTERFACE FOR EDCANON, CANONICALIZING ROUTINE. 01381000
* 01382000
* CALL: 01383000
* BAL 15,CANON 01384000
* 01385000
* (LEVEL N SUBROUTINE, CALLED FROM XREPL, SPREAD, STRING1. 01386000
* USES REGSAVX.) 01387000
* 01388000
*********************************************************************** 01389000
SPACE 01390000
CANON DS 0H 01391000
STM 14,15,REGSAVX SAVE REGISTERS 01392000
L 15,=V(EDCANON) CALL EDCANON 01393000
BALR 14,15 01394000
LM 14,15,REGSAVX RESTORE REGS 01395000
BR 15 RETURN 01396000
EJECT 01397000
*********************************************************************** 01398000
* 01399000
* RDTYPE -- READ A LINE FROM THE TERMINAL 01400000
* 01401000
* CALL: 01402000
* BAL 14,RDTYPE 01403000
* 01404000
* (LEVEL 1 SUBROUTINE) 01405000
* 01406000
*********************************************************************** 01407000
SPACE 01408000
RDTYPE DS 0H 01409000
MVC CASEREAD(1),CASESW USE CURRENT SETTING 01410000
CMS TIN CALL FOR WAITRD 01411000
LH 0,TIN+14 SET UP 'COUNT' 01412000
STH 0,COUNT 01413000
LTR 0,0 SET CONDITION CODE 01414000
BR 14 01415000
EJECT 01416000
*********************************************************************** 01417000
* 01418000
* WRTYPE -- TYPE A LINE AT THE TERMINAL 01419000
* WRTYPE1 -- TYPE A LINE IF IN VERIFY MODE 01420000
* WRTYPE2 -- TYPE A LINE WITH LEFT LINE NO., IF REQUIRED 01421000
* WRTYPE3 -- AS ABOVE IF IN VERIFY MODE 01422000
* 01423000
* CALL: 01424000
* BAL 14,WRTYPE (OR BAL 14,WRTYPE1) 01425000
* 01426000
* ON INPUT: 01427000
* R0 = LENGTH OF STRING TO BE TYPED 01428000
* R1 = ADDRESS OF STRING TO BE TYPED 01429000
* 01430000
* (LEVEL N SUBROUTINES) 01431000
* 01432000
*********************************************************************** 01433000
SPACE 01434000
WRTYPE1 DS 0H 01435000
TM FLAG2,VER VERIFY MODE? @V1D1613 01436000
BO WRTYPE YES ... BRANCH @VA04014 01437000
TM TWITCH,VEROVER IMMEDIATE VERIFY OVERRIDE? @VA04014 01438000
BCR 8,14 NO, RETURN WITH NO TYPING 01439000
NI TWITCH,255-VEROVER RESET OVERRIDE FLAG @VA04014 01440000
SPACE 01441000
WRTYPE EQU * 01442000
OI SCRFLGS,WRMSGB MESSAGE LINE ENTRY @V2D3913 01443000
WRTYPEX EQU * @V2D3913 01444000
TM MSGFLAGS,NOTYPING HT IN EFFECT ? @V200714 01445000
BO WROUT YES ... BR @V2D3913 01446000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V200714 01447000
BNO NOTGRAF NO...BR @V200714 01448000
ST R14,REGSAVX SAVE RETURN REGISTER @V2D3913 01449000
L R15,=V(DMSSCR) @V200714 01450000
BALR R14,R15 LOAD BUFFERS AND DISPLAY @V200714 01451000
BNZ IOERR BR..IF ERROR FROM SCR @VM08823 01452000
L R14,REGSAVX RESTORE RETURN @V2D3913 01453000
MVI SCRFLG2,X'00' CLEAR MORE STATUS FLAG @V2D3913 01454000
WROUT NI SCRFLGS,255-WRMSGB RESET MESSAGE FLAG @V2D3913 01455000
BR R14 RETURN TO CALLER @V200714 01456000
NOTGRAF STH 0,TOUT+14 STORE NO BYTES TO OUTPUT @V200714 01457000
STCM 1,B'0111',TOUT+9 STORE NEW ADDRESS @V200713 01458000
CMS TOUT CALL CMS 01459000
BR 14 RETURN. 01460000
WRTYPE3 EQU * 01461000
TM FLAG2,VER VERIFY MODE? @V1D1613 01462000
BCR 8,14 NO,RETURN WITH NO TYPING 01463000
WRTYPE2 EQU * 01464000
TM TWITCH,TOPSW+EOF AT TOF OR EOF ? @V2D3913 01465000
BZ WRTYPE2A NO ... BR @VA04074 01466000
LA R1,EOFREC POINT TO 'EOF:' STRING @V2D3913 01467000
LA R0,4 SET LENGTH OF MESSAGE @V2D3913 01468000
TM TWITCH,EOF AT EOF ? @V2D3913 01469000
BO WRTYPEX YES ... BR @V2D3913 01470000
LA R1,TOPMSG POINT TO 'TOF:' STRING @V2D3913 01471000
B WRTYPEX @V2D3913 01472000
WRTYPE2A EQU * @VA04074 01473000
TM FLAG,RIGHT LINEMODE RIGHT? @VA04074 01474000
BZ WRTYPEX NO ... BR @VA04074 01475000
TM FLAG2,TUBE DISPLAY TERMINAL? @VA04074 01476000
BO WRTYPEX YES ... BR @VA04074 01477000
L R15,PTR2 GET PTR TO CURRENT LINE @VA04074 01478000
AH R15,LMSTART OFFSET TO LINE NUMBER @VA04074 01479000
MVC LINENO(5),8(R15) MOVE IN NUMBER @VA04074 01480000
LR R15,R0 GET VERIFY LINE LENGTH @VA04074 01481000
EX R15,WREADX MOVE VERIFY DATA INTO 'LINE' @VA04074 01482000
LA 1,6 NOW GET 6 POSITION OFFSET @VA04074 01483000
AR 0,1 AND OFFSET THE LINE LENGTH @VA04074 01484000
LA 1,LINENO BACKUP START @VA04074 01485000
B WRTYPEX @VA04074 01486000
WREADX MVC LINE(*-*),0(R1) BLANK 'MVC' FOR 'EX' @VA04074 01487000
EJECT 01488000
*********************************************************************** 01489000
* 01490000
* TABLE OF REQUESTS (IN A NICE COMPACT FORM) 01491000
* 01492000
* REQ MACRO HAS FORM: 01493000
* 01494000
* REQ NAME<,MIN-LENGTH<,ROUTINE-NAME>> 01495000
* 01496000
* DEFAULTS ARE: MIN-LENGTH = 1; ROUTINE-NAME = NAME 01497000
* 01498000
*********************************************************************** 01499000
SPACE 01500000
PRQUEST EQU * REQUESTS WHICH DO NOT RESET THE FOR COUNT 01501000
REQ OVERLAY,1,OVRLAY 01502000
REQ X,1,XXX 01503000
REQ Y,1,YYY 01504000
REQ ?,1,QUERY 01505000
REQ REUSE,5,DITTO 01506000
REQ =,1,DITTO P3123 01507000
PRQEND EQU * 01508000
SPACE 01509000
RQUEST EQU * REQUESTS WHICH RESET THE FOR COUNT 01510000
REQ INPUT,1,INSERT 01511000
REQ REPLACE,1,RETYPE 01512000
REQ TYPE,1,PRINT 01513000
REQ TOP,3 01514000
REQ DELETE,3,DELETE @V2D3914 01515000
REQ DSTRING,2,DSTRING @V2D3914 01516000
REQ BOTTOM 01517000
REQ NEXT,1,NEXLIN 01518000
REQ DOWN,2,NEXLIN 01519000
REQ FIND 01520000
REQ /,1,PRELOC 01521000
REQ LOCATE 01522000
REQ ALTER,2 01523000
REQ CHANGE 01524000
REQ REPEAT,6,REPEAT P3123 01525000
REQ TRUNC,5,TRUNCIT 01526000
REQ ZONE 01527000
REQ TABSET,4 01528000
REQ CASE,4 01529000
REQ IMAGE,5 01530000
REQ VERIFY 01531000
REQ LONG,4 01532000
REQ SHORT,5 01533000
REQ PRESERVE,3 01534000
REQ RESTORE,3 01535000
REQ STACK,5 01536000
REQ $,1,DOT 01537000
REQ FNAME,2,NAME 01538000
REQ FMODE,2,MODE 01539000
REQ RECFM,3,RECFORM P3123 01540000
REQ SERIAL,3 01541000
REQ CMS,3 01542000
REQ QUIT,4 01543000
REQ GETFILE 01544000
REQ SAVE,4 01545000
REQ FILE,4 01546000
REQ LINEMODE,4 01547000
REQ PROMPT,6 01548000
REQ AUTOSAVE,4 @V200706 01549000
REQ SCROLL,1,,UP @V2D3913 01550000
REQ FORWARD,2,NEXLIN @V200714 01551000
REQ BACKWARD,2,BACKWD @V2D3914 01552000
REQ RENUM,3 @V242801 01553000
REQ FORMAT,4,FORMAT @V2D3914 01554000
REQEND EQU * 01555000
EJECT 01556000
*********************************************************************** 01557000
* 01558000
* EXEC INSTRUCTIONS AND MISCELLANEOUS CONSTANTS 01559000
* 01560000
*********************************************************************** 01561000
SPACE 2 01562000
LINECLR MVC LINE(*-*),LINE-1 CLEAR 'LINE' (PAGE 3) 01563000
INMOVE MVC LINE(*-*),TABLIN MOVE IN SPREAD LINE 01564000
UPCASE OC XXXCWD(*-*),CAPS CONVERT TOKEN TO UPPER CASE 01565000
SPACE 01566000
CAPS DC 8X'40' BLANKS FOR UPCASE 01567000
SPACE 01568000
TRUNCX DC C'TRUNCATED' 01569000
* NEXT TWO MESSAGE STRINGS MUST BE KEPT IN ORDER 01570000
LINNOT DC C'LINE ' @V200713 01571000
FLDNTFND DC C'NOT FOUND' 01572000
EJECT 01573000
*********************************************************************** 01574000
* 01575000
* 'DELETE' REMOVES THE NEXT N LINES FROM THE FILE. IF N IS 01576000
* OMITTED, A VALUE OF 1 IS ASSUMED. 01577000
* 01578000
*********************************************************************** 01579000
SPACE 01580000
DELETE DS 0H @V2D3913 01581000
BAL 14,NUM GET NUM OF DELETES TR 01582000
BAL 14,STARCHK THEN HOPEFULLY IT'S A STAR 01583000
BAL 14,PARMCHK CHECK NO MORE ARGUMENTS GIVEN 01584000
DSENT LTR R2,R0 DID THE USER SPECIFY ZERO? @V2D3914 01585000
BZ NEXT WE ARE ALL DONE IF HE DID. @V2D3913 01586000
BAL R14,EORCHK CHECK THE CURRENT BOUNDS @V2D3913 01587000
B ENDRANGE TYPE TOF OR EOF IF APPROPRIATE @V2D3913 01588000
L R3,PTR2 PICK UP THE CURRENT LINE POINTER @V2D3913 01589000
DELNEXT BAL R14,XNEXT GET THE NEXT POINTER @V2D3913 01590000
TM TWITCH,TOPSW+EOF AT A BOUDARY YET? @V2D3913 01591000
BNZ DELEND NO MORE LOOPING IF SO. @V2D3913 01592000
BCT R2,DELNEXT KEEP INDEXING @V2D3913 01593000
DELEND TM TWITCH,TOPSW+EOF IS IT TOF/EOF? @V2D3914 01594000
BZ DELSKIP SKIP IF NOT. @V2D3914 01595000
BCTR R2,R0 MORE ADJUSTING @V2D3913 01596000
DELSKIP L R14,4(,R3) GET OLD BACK POINTER @V2D3914 01597000
LTR R14,R14 WERE WE AT TOF ? @V2D3914 01598000
BNZ NODELTOF BR IF NOT @V2D3914 01599000
LA R4,1 COUNT IS ONE PLUS IF @V2D3914 01600000
AR R2,R4 STARTING AT TOF @V2D3914 01601000
L R3,0(,R3) AND POINT TO REAL 1ST LINE @V2D3914 01602000
MVI SCRFLGS,WRFULLB UPPER DISPLAY WILL CHANGE @V2D3914 01603000
NODELTOF SR R0,R2 HOW MANY DID WE REALLY DELETE ? @V2D3914 01604000
BZ ENDRANG1 NONE, IF ZERO @V2D3914 01605000
L R14,SPARES GET THE FREE-LINES COUNT. @V2D3914 01606000
AR R14,R0 INCREMENT IT BY DECREMENT COUNT. @V2D3913 01607000
ST R14,SPARES SAVE AS NEW FREE COUNT. @V2D3913 01608000
TM TWITCH,UPWARD GOING UP? @V2D3913 01609000
BO DELUP REQUIRES DIFFERENT PROCESSING @V2D3913 01610000
OI SCRFLGS,WRCLDNB LOWER DISPLAY WILL CHANGE @V2D3914 01611000
L R2,4(,R3) GET THE BACK POINTER @V2D3913 01612000
SR R4,R4 @V2D3914 01613000
TM TWITCH,EOF @V2D3913 01614000
BNO NOTEOF BR IF NOT EOF @V2D3914 01615000
ST R2,PTR2 SET NEW CL POINTER @V2D3914 01616000
ST R2,PTR3 SET NEW BOTTOM POINTER @V2D3914 01617000
B DELEOF MAKE SURE FWD PTR IS ZERO @V2D3914 01618000
NOTEOF LR R4,R1 GET THE NEW FORWARD PONTER @V2D3914 01619000
ST R2,4(,R1) @V2D3913 01620000
DELEOF ST R4,0(,R2) @V2D3914 01621000
B DELFCHN GO SET FREE LIST @V2D3914 01622000
SPACE 1 01623000
DELUP OI SCRFLGS,WRCLUPB UPPER DISPLAY WILL CHANGE @V2D3914 01624000
L R2,0(,R3) GET OLD FWD POINTER @V2D3914 01625000
ST R2,0(,R1) PUT IT IN NEW FWD POINTER @V2D3914 01626000
LTR R2,R2 WAS IT EOF ? @V2D3914 01627000
BZ SETPTR3 YES....BR @V2D3914 01628000
ST R1,4(,R2) SET BACK POINTER @V2D3914 01629000
B DELFCHN GO SET FREE LIST @V2D3914 01630000
SPACE 1 01631000
SETPTR3 ST R1,PTR3 SET NEW BOTTOM POINTER @V2D3914 01632000
BCTR R0,R0 AND DECREMENT COUNT @V2D3914 01633000
OI SCRFLGS,WRCLDNB LOWER AREA WILL CHANGE @V2D3914 01634000
SPACE 1 01635000
DELFCHN EQU * @V2D3914 01636000
L R2,FPTR GET OLD FREE LIST PTR @V2D3914 01637000
TM TWITCH,UPWARD GOING UP ? @V2D3914 01638000
BO DELEUP YES...BR @V2D3914 01639000
L R4,0(,R3) GET OLD FORWARD PTR @V2D3914 01640000
B DELRDY .... @V2D3914 01641000
DELEUP L R4,4(,R3) USE BACK PTR FOR DELETE UP @V2D3914 01642000
DELRDY ST R2,0(,R3) FPTR BECOMES NEW FWD PTR @V2D3914 01643000
ST R3,FPTR LOAD NEW FPTR @V2D3914 01644000
LR R3,R4 POINT TO NEXT LINE @V2D3914 01645000
BCT R0,DELFCHN DELETE SPECIFIED NUMBER @V2D3914 01646000
BAL R14,AUTOCHEK PERFORM AUTOSAVE FUNCTION @V2D3914 01647000
TM TWITCH,TOPSW+EOF AT TOP OR END OF FILE ? @VM01077 01648000
BNZ DELVER YES, THEN VERIFY FOR HIM @VM01077 01649000
TM FLAG2,TUBE NO VERIFICATION FOR @V2D3914 01650000
BNO NEXT TYPEWRITER TERMINAL @V2D3914 01651000
DELVER VERIFY RETURN=NEXT @VM01077 01652000
EJECT 01653000
*************************************************************** 01654000
* 01655000
* 'TOP' POSITIONS THE USER AT THE TOP OF HIS FILE. 01656000
* 01657000
*************************************************************** 01658000
SPACE 1 01659000
TOP DS 0H @V2D3913 01660000
BAL R14,PARMCHK NO MORE PARAMETERS ALLOWED @V2D3913 01661000
BAL R14,CLOSE BACK TO THE TOP @V2D3913 01662000
B ENDRANGE PRINT TOF @V2D3913 01663000
SPACE 4 01664000
********************************************************************** 01665000
* 01666000
* 'BOTTOM' WILL POINT TO THE LAST LINE OF FILE. 01667000
* 01668000
*********************************************************************** 01669000
SPACE 01670000
BOTTOM EQU * START OF "BOTTOM" COMMAND TR 01671000
BAL 14,PARMCHK CHECK WHETHER LAST PARM 01672000
SPACE 1 01673000
BTM2 EQU * @V2D3913 01674000
L R1,PTR3 GET BOTTOM LINE POINTER @V2D3913 01675000
LA R14,PTR1 AND TOF POINTER @V2D3913 01676000
CR R1,R14 AND COMPARE @V2D3913 01677000
BNE BTM3 BR, IF NOT A NULL FILE @V2D3913 01678000
BAL R14,CLOSE IF NULL, SET TOF FLAG @V2D3913 01679000
B ENDRANGE AND TYPE TOF MESSAGE @V2D3913 01680000
SPACE 1 01681000
BTM3 EQU * @V2D3913 01682000
ST R1,PTR2 CL PTR-> BOTTOM LINE @V2D3913 01683000
NI TWITCH,255-(EOF+TOPSW) RESET FILE LIMIT FLAGS @V2D3913 01684000
B LOCFND VERIFY @V2D3913 01685000
EJECT 01686000
*********************************************************************** 01687000
* 01688000
* 'NEXT' SKIPS THROUGH THE FILE N LINES. IF N IS OMITTED, 01689000
* THE NEXT LINE IS ASSUMED. 01690000
* 01691000
*********************************************************************** 01692000
SPACE 01693000
NEXLIN DS 0H 01694000
BAL 14,NUM GO TO NEXT (N) LINES. 01695000
B INVREQ ERROR RETURN. TR 01696000
BAL 14,PARMCHK CHECK NO MORE ARGUMENTS GIVEN 01697000
SPACE 1 01698000
TYPIN EQU * @V2D3913 01699000
LTR 2,0 01700000
BZ LOCFND JUST TYPE IT. @V2D3913 01701000
BAL R14,EORCHK CHECK CURRENT BOUNDS @V2D3913 01702000
B ENDRANGE TYPE TOF,EOF MESSAGE @V2D3913 01703000
SPACE 01704000
NEXLOOP EQU * REWRITTEN TO IMPROVE SPEED 01705000
BAL 14,XNEXT CHAIN DOWN THROUGH FILE 01706000
TM TWITCH,TOPSW+EOF ENDRANGE? @V2D3913 01707000
BNZ ENDRANGE TYPE EOF OR TOF @V2D3913 01708000
BCT 2,NEXLOOP LOOP UNTIL DONE 01709000
B LOCFND SHOW THE LINE @V2D3913 01710000
SPACE 4 01711000
************************************************************** 01712000
* 01713000
* 'BACKWARD' PERFORMS THE SAME FUNCTION AS 'UP'. 01714000
* HOWEVER, UP IS TREATED AS A SPECIAL CASE, SO THIS 01715000
* CODE IS NECESSARY. 01716000
* 01717000
************************************************************** 01718000
SPACE 1 01719000
BACKWD DS 0H @V2D3914 01720000
OI TWITCH,UPWARD TURN ON THE UP FLAG @V2D3914 01721000
B NEXLIN LET THE COMMAN ROUTINE DO IT @V2D3914 01722000
EJECT 01723000
*********************************************************************** 01724000
* 01725000
* 'FIND' LOOKS FOR AN EXACT MATCH IN THE NON-BLANK 01726000
* COLUMNS OF THE EDIT LINE. IT WILL STOP AT EOF. 01727000
* 01728000
*********************************************************************** 01729000
SPACE 01730000
FIND DS 0H TR 01731000
LH 2,TRUNCOL SAVE TRUNCOL VALUE TR 01732000
L 4,ITEM ITEM LENGTH 01733000
STH 4,TRUNCOL USE IT (TEMPORARILY) AS TRUNC. COL. 01734000
BAL 14,SPREAD SPREAD THE EDIT LINE 01735000
STH 2,TRUNCOL RESTORE PERMANENT TRUNCOL VALUE 01736000
BAL R14,EORCHK CHECK CURRENT BOUNDS @V2D3913 01737000
BAL R14,CLOSE CALL CLOSE ROUTINE @V2D3913 01738000
SPACE 1 01739000
FIND2 EQU * 01740000
BAL 14,XNEXT MOVE TO NEXT LINE 01741000
TM TWITCH,TOPSW+EOF ENDRANGE? @V2D3913 01742000
BNZ NOTFOUND REQUIRES NOT FOUND MSG @V2D3913 01743000
LA 2,TABLIN POINT TO THE SPREAD LINE 01744000
LR 3,4 SET R3 TO ITEM-LENGTH 01745000
SPACE 01746000
FIND3 EQU * 01747000
CLI 0(2),C' ' COMPARE FOR BLANK. 01748000
BE FIND4 BRANCH IF IT IS (DON'T COMPARE HERE) 01749000
CLC 0(1,2),8(1) MAKE THE COMPARISON 01750000
BNE FIND2 BRANCH IF THEY DON'T MATCH 01751000
SPACE 01752000
FIND4 EQU * 01753000
LA 1,1(,1) MOVE TO NEXT CHARACTER IN LINE OF FILE 01754000
LA 2,1(,2) AND NEXT CHARACTER IN GIVEN LINE 01755000
BCT 3,FIND3 LOOP UNTIL WE'VE EXAMINED THEM ALL 01756000
B LOCFND BRANCH INTO LOCATE ROUTINE 01757000
EJECT 01758000
*********************************************************************** 01759000
* 01760000
* 'LOCATE' SEARCHES THOSE COLUMNS OF THE FILE SPECIFIED 01761000
* BY THE CURRENT SETTINGS OF 'ZONE' FOR A MATCH WITH THE 01762000
* GIVEN DELIMITED STRING. IT WILL STOP AT EOF. 01763000
* 01764000
*********************************************************************** 01765000
SPACE 01766000
PRELOC DS 0H SPECIAL LOCATE FORM ENTRY 01767000
STH 0,EDCT SET EDCT BACK (GET TELLS US WHERE VIA R0) 01768000
SPACE 01769000
LOCATE EQU * 01770000
BAL 14,STRING1 SCAN STRING1 01771000
BAL 14,PARMCHK CHECK NO MORE PARMS 01772000
BAL R14,EORCHK CHECK CURRENT BOUNDS @V2D3913 01773000
BAL R14,CLOSE CALL CLOSE ROUTINE @V2D3913 01774000
LA R9,LOCEND THIS IS FOR LATER BRANCH @V2D3914 01775000
SPACE 1 01776000
LOCSUB EQU * @V2D3914 01777000
SR R8,R8 CLEAR LINE COUNT REG @V2D3914 01778000
LH 4,ZONE1 COLUMN TO START 01779000
LH 5,ZONE2 COLUMN TO END 01780000
SR 5,4 NO. OF COLS. TO SEARCH 01781000
SR 5,3 NO. OF COMPARISONS TO MAKE 01782000
SPACE 01783000
LOCATE2 EQU * 01784000
BAL 14,XNEXT MOVE TO NEXT LINE 01785000
LA R8,1(,R8) BUMP LINE COUNT @V2D3914 01786000
LTR R3,R3 NULL STRING IS AUTOMATIC @V2D3914 01787000
BL 4(,R9) NEXT LINE @V2D3914 01788000
TM TWITCH,TOPSW+EOF ENDRANGE? @V2D3913 01789000
BNZ 0(,R9) NOTFOUND OR NOSTRING @V2D3914 01790000
AR 1,4 R1 NOW POINTS TO FIRST COLUMN TO SEARCH 01791000
LR 0,5 AND R0 GIVES NO. OF SEPARATE COMPARISONS 01792000
SPACE 01793000
LOCLOOP EQU * 01794000
EX 3,LOCCOM COMPARE CLC 8(*-*,1),0(2) 01795000
BE 4(,R9) LOCATE OR STRING FOUND @V2D3914 01796000
LA 1,1(,1) LOOK AT NEXT SPOT 01797000
BCT 0,LOCLOOP AND LOOP 01798000
B LOCATE2 (NOT FOUND IN THIS LINE) 01799000
SPACE 01800000
LOCEND B NOTFOUND HERE IF STRING NOT FOUND @V2D3914 01801000
LOCFND EQU * 01802000
MVI SCRFLGS,WRFULLB TEXT CHANGED @V2D3914 01803000
LOCFND1 VERIFY RETURN=NEXT @V2D3914 01804000
SPACE 01805000
LOCCOM CLC 8(*-*,1),0(2) 01806000
EJECT 01807000
************************************************************** 01808000
* 01809000
* 'DSTRING' CAUSES DELETION OF LINES UP TO A LINE 01810000
* CONTAINING THE SPECIFIED CHARACTER STRING. 01811000
* 01812000
************************************************************** 01813000
SPACE 1 01814000
DSTRING DS 0H @V2D3914 01815000
BAL R14,STRING1 DELIMIT STRING @V2D3914 01816000
BAL R14,PARMCHK STRING MUST BE LAST PARAMETER @V2D3914 01817000
L R6,PTR2 SAVE CL PTR @V2D3914 01818000
IC R7,TWITCH AND CL FLAGS @V305614 01819000
BAL R14,EORCHK IF AT EOF, CAN'T POSSIBLY @V2D3914 01820000
B NOWAY FIND IT @V2D3914 01821000
SPACE 1 01822000
BAL R9,LOCSUB GO FIND LINE WITH THIS STRING @V2D3914 01823000
B NOSTRING RETURN HERE IF NOT FOUND @V2D3914 01824000
ST R6,PTR2 IF FOUND, RESTORE THE CL PTR @V2D3914 01825000
STC R7,TWITCH AND CL FLAGS @V305614 01826000
LR R0,R8 GET NUMBER OF LINES FOR DELETE @V2D3914 01827000
B DSENT AND USE DELETE TO EXECUTE @V2D3914 01828000
SPACE 1 01829000
NOSTRING ST R6,PTR2 RESTORE ORIGINAL CL PTR @V2D3914 01830000
STC R7,TWITCH AND FLAGS @V305614 01831000
NOWAY WTYPE NOSTR,RETURN=NEXT @V2D3914 01832000
SPACE 1 01833000
NOSTR DC C'STRING NOT FOUND, NO DELETIONS MADE.' @V2D3914 01834000
EJECT 01835000
* 01836000
LTORG @V305614 01837000
SPACE 4 01838000
************************************* 01839000
************************************* 01840000
***** ***** 01841000
***** END OF PAGE 1 ***** 01842000
***** ***** 01843000
************************************* 01844000
************************************* 01845000
SPACE 4 01846000
*********************************************************************** 01847000
* 01848000
* PAGE 1 MAY (PHYSICALLY) EXTEND A FEW HUNDRED BYTES BEYOND 01849000
* THIS POINT. PAGE 2 IS ARRANGED TO TAKE ADVANTAGE 01850000
* OF THIS BY HAVING AT THE BEGINNING ROUTINES WHICH ARE 01851000
* OFTEN USED AND DO NOT CALL SOUBROUTINES OR USE DATA OUTSIDE 01852000
* OF PAGE 1 OR THE BEGINNING OF PAGE 2. 01853000
* 01854000
*********************************************************************** 01855000
EJECT 01856000
*********************************************************************** 01857000
* 01858000
* 'ALTER' ENABLES ARBITRARY CHARACTERS TO BE MANIPULATED. 01859000
* AFTER DECODING THE FIRST TWO ARGUMENTS, IT TRANSFERS INTO 01860000
* THE CHANGE ROUTINE. 01861000
* 01862000
*********************************************************************** 01863000
SPACE 01864000
ALTER DS 0H 01865000
LA 2,ALCHAR1 POINT TO SPOT FOR FIRST CHAR 01866000
BAL 4,ALTSUB PUT THE FIRST ARGUMENT THERE 01867000
LA 2,ALCHAR2 POINT TO SPOT FOR SECOND CHAR 01868000
BAL 4,ALTSUB PUT THE SECOND ARGUMENT THERE 01869000
LA 2,ALCHAR1 POINT R2 TO CHAR1 01870000
SR 3,3 SET R3 = 0 01871000
LA 4,ALCHAR2 POINT R4 TO SECOND CHAR 01872000
LA 5,1(4) AND R5 ONE UP FROM THAT 01873000
B CHNGTRNS TRANSFER INTO CHANGE 01874000
SPACE 01875000
ALTSUB EQU * ALTER SUBROUTINE 01876000
OI SIGNAL,HEXSW SET HEX FLAG FOR GET 01877000
BAL 14,GET GET THE ARGUMENT 01878000
BZ INVREQ BRANCH IF NONE GIVEN 01879000
LTR 1,1 HOW MANY CHARS? 01880000
BNZ ALHEX BRANCH IF > 1 (MUST BE HEX) 01881000
MVC 0(1,2),XXXCWD MOVE THE ARGUMENT INTO THE SPOT 01882000
BR 4 RETURN 01883000
SPACE 01884000
ALHEX LA R5,1 DECODE HEX ARGUMENT @V2D3913 01885000
CR R1,R5 EXACTLY TWO CHARACTERS? @V2D3913 01886000
BNE INVREQ BRANCH IF NOT (NO GOOD) 01887000
EX 1,UPCASE CONVERT TO UPPER CASE 01888000
LA 5,XXXCWD POINT TO THE FIRST HEX DIGIT 01889000
BAL 14,HEXSUB GET IT 01890000
BCTR 0,0 AND CORRECT IT 01891000
LR 3,0 SAVE IT IN R3 01892000
LA 5,1(5) LOOK AT SECOND HEX DIGIT 01893000
BAL 14,HEXSUB GET IT 01894000
BCTR 0,0 CORRECT IT 01895000
SLL 3,4 MOVE UP THE OLD VALUE 01896000
AR 0,3 GET THE TOTAL VALUE 01897000
STC 0,0(2) STORE IT WHERE TOLD 01898000
BR 4 RETURN 01899000
SPACE 01900000
HEXSUB EQU * GET VALUE OF HEX DIGIT 01901000
LA 0,16 01902000
LA 1,HEX+15 POINT TO LAST HEX CHAR (F) 01903000
HEXSUBLP CLC 0(1,5),0(1) DOES IT MATCH? @V200713 01904000
BCR 8,14 RETURN IF SO (R0 HOLDS THE VALUE + 1) 01905000
BCTR 1,0 DECREMENT THE SPOT IN HEX 01906000
BCT 0,HEXSUBLP AND LOOP UNTIL HEX EXHAUSTED 01907000
B INVREQ CHARACTER NOT FOUND 01908000
SPACE 01909000
HEX DC C'0123456789ABCDEF' 01910000
EJECT 01911000
*********************************************************************** 01912000
* * 01913000
* 'CHANGE' WILL REPLACE THE FIRST DELIMITED FIELD BY THE * 01914000
* SECOND, FOR THE CURRENT LINE OR FOR MANY LINES, FOR * 01915000
* THE FIRST OCCURRENCE IN THE LINE OR FOR ALL OCCURRENCES. * 01916000
* THE COLUMNS AFFECTED ARE CONTROLLED BY 'ZONE'. * 01917000
* * 01918000
* (THIS ROUTINE HAS BEEN MODIFIED SO THAT STRING1 MAY BE * 01919000
* NULL, IN WHICH CASE STRING2 IS INSERTED AT THE BEGINNING * 01920000
* OF THE ZONE, AND THE 'GLOBAL' OPTION IS INVALID. * 01921000
* * 01922000
*********************************************************************** 01923000
SPACE 01924000
CHANGE DS 0H 01925000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V200714 01926000
BNO SKT NO...BR @V200714 01927000
CLC EDCT(2),COUNT ANY PARAMETERS SPECIFIED ? @V2D3913 01928000
BNE SKT YES...BR @V200714 01929000
TM TWITCH,TOPSW+EOF TOF OR EOF ? @V200714 01930000
BM NOTFOUND IF SO, CAN'T CHANGE @V200714 01931000
MVI SCRFLG2,WRCLINB SET FLAG FOR DISPLAY RTN @V2D3913 01932000
OI CHNGFLAG,DTYPE SET DISPLAY TYPE ON @VA07968 01932500
BAL 14,WRTYPEX WRITE LINE TO INPUT AREA @V2D3913 01933000
NI CHNGFLAG,255-DTYPE SET DISPLAY TYPE OFF @VA07968 01933500
BAL R14,RDTYPE READ THE LINE IN. @V2D3913 01934000
BZ NEXT EXIT, IF MIND HAS CHANGED. @V2D3913 01935000
OI CHNGFLAG,DTYPE TURN ON DISPLAY TYPE FLAG @VA07258 01936000
XC EDCT(2),EDCT CLEAR EDIT COUNT @V2D3913 01937000
B RTYP4A NOW REPLACE THE LINE. @V2D3913 01938000
SKT EQU * @VA04193 01939000
XC TRNCNUM(4),TRNCNUM ZERO TRUNCATE COUNT @VA04193 01940000
BAL 14,STRING1 DECODE STRING 1 @VA04193 01941000
LH 6,COUNT COMPUTE LENGTH OF REPLACEMENT FIELD. 01942000
LR 5,4 POSSIBLE. 01943000
LA 14,EDLIN POINT TO INPUT SPEC @V200713 01944000
SR 5,14 @V200713 01945000
SR 6,5 01946000
LR 5,4 01947000
BZ CHNG2A BRANCH IF R6=0 01948000
CHNG2 EX 7,CHNGCOMP CLI 0(5),** 01949000
BE CHNG1 01950000
LA 5,1(,5) 01951000
BCT 6,CHNG2 01952000
CHNG2A EQU * 01953000
LR R8,R5 ALLOW NO CLOSING DELIMITER @V305614 01954000
BCTR R8,R0 @V305614 01955000
B *+6 01956000
SPACE 01957000
CHNG1 EQU * CHECK FOR MULTIPLE LINES AND GLOBAL 01958000
LR R8,R5 @V305614 01959000
SR R8,R14 SUBTRACT A(EDLIN) @V305614 01960000
LA R8,1(,R8) BUMP IT @V305614 01961000
STH R8,EDCT SAVE FOR 'GET' @V305614 01962000
EJECT 01963000
CHNGTRNS EQU * @V2D3913 01964000
NI CHNGFLAG,255-(NULLSW1+NULLSW2+GLOBSW+FLDFND+CHNGSW) 01965000
BAL 14,NUM CHECK FOR NUMBER OF LINES SUPPLIED. 01966000
BAL 14,STARCHK NON-NUMERIC RETURN. TR 01967000
ST R0,CHNGNUM SAVE COUNT OF NO. OF LINES @V305614 01968000
OI SCRFLGS,WRFULLB REWRITE ALL TEXT @V2D3914 01969000
BAL R14,GET GET NEXT TOKEN @V2D3913 01970000
BZ CHNG4 NO GOOD IF CC = 0 01971000
CLC XXXCWD(2),=CL2'G ' MAYBE HE USED 'G' 01972000
BE CHNG3 BRANCH IF SO @V2D3913 01973000
BAL 14,STARCHK BETTER BE ASTERISK @V2D3913 01974000
CHNG3 EQU * 01975000
BAL 14,PARMCHK CHECK NO MORE PARMS 01976000
OI CHNGFLAG,GLOBSW INDICATE GLOBAL CHANGE REQ. 01977000
CHNG4 EQU * 01978000
SR R6,R6 CLEAR REGISTER @V2D3913 01979000
LTR 3,3 IS STRING1 NULL? 01980000
BNL CHNG5 BRANCH IF NOT 01981000
TM CHNGFLAG,GLOBSW WAS GLOBAL REQUESTED? 01982000
BO INVREQ BRANCH IF SO (THAT'S NOT ON) 01983000
OI CHNGFLAG,NULLSW1 SET TWITCH 01984000
CHNG5 EQU * 01985000
L R14,CHNGNUM ANY LINES TO CHANGE ? @V305614 01986000
LTR R14,R14 ..... @V305614 01987000
BZ NOTFOUND INDICATE NO CHANGE @VA07942 01988000
BAL R14,EORCHK CHECK CURRENT BOUNDS @V2D3913 01989000
B CEOFILE ALL DONE IN THIS CASE @V2D3913 01990000
BAL R14,XREADB FILL COMPARE BUFFER @V2D3913 01991000
SR 5,4 LENGTH OF REPLACEMENT FIELD 01992000
LTR 5,5 WAS FIELD NULL. 01993000
BZ *+10 YES. 01994000
BCTR 5,0 DECREMENT FOR ACCURATE REPLACEMENT. 01995000
B *+8 01996000
OI CHNGFLAG,NULLSW2 YES - INDICATE TO PROCESS NULL. 01997000
TM TWITCH,TOPSW+EOF @V2D3913 01998000
BZ CHNGSTRT BRANCH IF NOT 01999000
B CHNGNXT1 02000000
EJECT 02001000
CHNGNXT3 OI CHNGFLAG,CHNGSW INDICATE LINE CHANGED. 02002000
CR 3,5 COMP LENGTHS OF ORIGINAL & CHANGED. 02003000
BE DOCHNG SAME LENGTH; REPLACE ONLY. 02004000
BH MOVELEFT SHORTER - REQUIRES SHIFT TO LEFT. 02005000
* LONGER - REQUIRES SHIFT TO RIGHT. TR 02006000
LH 7,ZONE2 GET TRUNCATION COLUMN 02007000
LA 7,LINE(7) ADJUST TO COL LOCATION TR 02008000
LR 9,7 LOAD REG 9 02009000
BCTR 9,0 DECREMENT GR 9. TO POINTER TR 02010000
SR 7,1 NO. OF COLS. AVAILABLE FOR STRING2 02011000
SR 7,5 NO. OF COLS. LEFT OVER IN ZONE + 1 02012000
BH CHNG7 CHANGE FIELD WILL NOT BE TRUNCATED TR 02013000
BCTR 7,0 CHANGED FLD WILL BE TRUNCATED. TR 02014000
SPACE 02015000
* SO STRING2 IS TO BE TRUNCATED. LET'S SEE WHETHER ANY NON- 02016000
* BLANKS ARE BEING LOST. (CJS) 02017000
SPACE 02018000
* R4: START OF STRING2 02019000
* R5: LENGTH-1 OF STRING2 02020000
* R7: -(NO. OF CHARS TO THROW AWAY) 02021000
* R14 AND R15: AVAILABLE FOR SCRATCH 02022000
SPACE 02023000
LA 15,0(4,5) ADDRESS OF LAST CHAR IN STRING2 02024000
LPR 14,7 NO. OF CHARS TO THROW AWAY FROM STRING2 02025000
SPACE 02026000
STR2LP EQU * LOOP HEAD 02027000
CLI 0(15),C' ' BLANK? 02028000
BNE SIGLOST BRANCH IF NOT (SIGNIFICANT CHARS LOST) 02029000
BCTR 15,0 LOOK AT PREVIOUS CHAR 02030000
BCT 14,STR2LP AND LOOP 02031000
EJECT 02032000
* IF WE GET HERE, WE KNOW THAT SIGNIFICANT CHARACTERS ARE NOT 02033000
* BEING LOST FROM STRING2. 02034000
* BUT WHAT ABOUT THAT PART OF THE EXISTING LINE WHICH IS BEING 02035000
* PUSHED OVER THE EDGE? 02036000
SPACE 02037000
* R1: ADDRESS OF FIRST CHARACTER TO BE CHANGED 02038000
* R3: LENGTH-1 OF STRING1 02039000
* R9: ADDRESS OF LAST CHAR IN ZONE 02040000
SPACE 02041000
LR 15,9 ADDRESS OF LAST CHAR IN ZONE 02042000
LR 14,9 SAME THING 02043000
SR 14,1 TOTAL NO. OF CHARS TO BE REMOVED - 1 02044000
SR 14,3 NO. OF CHARS TO BE LOST NON-EXPLICITLY 02045000
BZ SIGNTLST BRANCH IF NONE (SIG CHARS NOT LOST) 02046000
SPACE 02047000
LOSTLP EQU * LOOP HEAD 02048000
CLI 0(15),C' ' BLANK? 02049000
BNE SIGLOST BRANCH IF NOT (SIGNIFICANT CHARS LOST) 02050000
BCTR 15,0 LOOK AT PREVIOUS CHAR 02051000
BCT 14,LOSTLP AND LOOP 02052000
B SIGNTLST SIGNIFICANT CHARS NOT LOST 02053000
SPACE 02054000
SIGLOST EQU * SIGNIFICANT CHARS ARE BEING LOST 02055000
OI TWITCH,TRUNC SET TRUNC SWITCH 02056000
SPACE 02057000
SIGNTLST EQU * SIGNIFICANT CHARS NOT LOST 02058000
AR 7,5 REDUCED LENGTH OF STRING2 02059000
B DOCHNG2 GO AND PERFORM THE CHANGE 02060000
EJECT 02061000
* END OF CHECK FOR WHETHER NON-BLANKS ARE LOST FROM STRING2 02062000
* OR FROM THAT PART OF THE EXISTING LINE WHICH IS BEING THROWN 02063000
* AWAY, IN THE CASE WHEN STRING2 IS TRUNCATED. 02064000
SPACE 02065000
CHNG7 EQU * TR 02066000
LNR 8,5 1 - L'STRING2 02067000
AR 8,3 L'STRING1 - L'STRING2 02068000
BZ DOCHNG 02069000
LPR 15,8 NO. OF BYTES TO BE DISCARDED INTO R15, JS 02070000
AR 8,9 R8 POINTS TO LAST BYTE TO BE MOVED 02071000
LR 14,8 WHERE-TO-START (LESS 1) INTO R14, JS 02072000
JCLI14 CLI 1(14),C' ' IS CHARACTER-TO-BE-DISCARDED A BLANK ? JS 02073000
BE JLAR14 BE IF YES (NO PROBLEM SO FAR) JS 02074000
OI TWITCH,TRUNC IF NOT, SET TRUNCATED-BIT AND JS 02075000
B MOVERT START MOVING AS USUAL. JS 02076000
JLAR14 LA 14,1(,14) ADVANCE TO NEXT CHARACTER, JS 02077000
BCT 15,JCLI14 AND CHECK ALL CHARACTERS THROWN AWAY. JS 02078000
MOVERT MVC 0(1,9),0(8) 02079000
BCTR 9,0 02080000
BCTR 8,0 02081000
BCT 7,MOVERT 02082000
DOCHNG EQU * SET UP TO PERFORM CHANGE 02083000
LR 7,5 LENGTH-1 OF STRING2 02084000
DOCHNG2 EQU * PERFORM CHANGE 02085000
EX 7,MOVEIN (THERE) 02086000
CHNGSCOL EQU * UPDATE R1 TO NEXT COLUMN TO CHANGE 02087000
LA 1,1(1,5) STARTING POSITION + L'STRING2 02088000
B CHNGNEXT 02089000
EJECT 02090000
MOVELEFT EQU * CHANGE INVOLVES MOVE TO LEFT 02091000
LR 15,3 L'STRING1-1 02092000
LA 8,1(1,15) ADDR. OF BYTE AFTER OCCURRENCE OF STRING1 02093000
LA 9,0(5,8) 02094000
SR 9,15 02095000
LH 7,ZONE2 GET TRUNCATION COLUMN 02096000
LA 7,LINE(7) TR 02097000
LR 14,7 SAVE COL ADDRESS TR 02098000
SR 7,8 02099000
BNH *+10 IF NOT GT 0, DO NOT MOVE ANYTHING. TR 02100000
BCTR 7,0 02101000
EX 7,MOVER 02102000
EX 5,MOVEIN GR 5 = NUMB OF REPLACING CHARACTERS 02103000
SR 15,5 02104000
BCTR 15,0 GR 15 = NUMB OG BLANKS TO BE MOVED IN 02105000
LR 9,14 LOAD REG 9 TR 02106000
BCTR 9,0 TR 02107000
SR 9,15 02108000
MVI 0(9),C' ' SET UP ONE BLANK 02109000
BCTR 15,0 COUNT-1 02110000
LTR 15,15 WAS THERE ONLY ONE BLANK 02111000
BL *+8 YES, SKIP 'EX' 02112000
EX 15,MOVEBL NO, MVC 1(*-*,9),0(9) 02113000
B CHNGSCOL 02114000
EJECT 02115000
DONULL EQU * STRING2 IS NULL, STRING1 NOT NULL 02116000
OI CHNGFLAG,CHNGSW INDICATE CHANGE MADE 02117000
LR 9,1 MOVE INTO HERE. 02118000
LA 8,1(3,9) ADDR. OF BYTE AFTER OCCURRENCE OF STRING1 02119000
LH 7,ZONE2 GET TRUNCATION COLUMN 02120000
LA 7,LINE(7) COMPUTE ADDRESS OF COL. BEYOND EOZ 02121000
SR 7,8 NO. OF ACTIVE COLS. AFTER STRING1 02122000
BNH DONULL1 BRANCH IF NONE 02123000
BCTR 7,0 DECREASE FOR EXEC 02124000
EX 7,MOVER MOVE THEM OVER 02125000
LA 9,1(9,7) POINT TO COL. AFTER WHAT WE'VE MOVED 02126000
DONULL1 EQU * (JUMP HERE IF NOUGHT TO MOVE OVER) 02127000
MVI 0(9),C' ' MOVE IN ONE BLANK 02128000
LR 15,3 L'STRING1-1 = NO. OF BLANKS LEFT TO PAD 02129000
BCTR 15,0 DECREASE FOR EXEC 02130000
LTR 15,15 WAS THERE AT LEAST ONE? 02131000
BL *+8 SKIP IF NOT 02132000
EX 15,MOVEBL MVC 1(*-*,9),0(9) 02133000
LH 7,CHNGCNT ITERATION COUNT FOR THIS LINE 02134000
BCTR 7,0 MINUS... 02135000
SR 7,3 ...L'STRING1. 02136000
BNH CHNGNXT1 BRANCH IF WE'VE EXHAUSTED THE ZONE 02137000
STH 7,CHNGCNT SAVE DECREMENTED VALUE OF CHNGCNT 02138000
SPACE 02139000
CHNGNEXT TM CHNGFLAG,GLOBSW IS GLOBAL REQUESTED. 02140000
BZ CHNGNXT1 NO. 02141000
LA 0,LINE GET LINE ADDRESS TR 02142000
AH 0,ZONE2 GET TRUNCATION COL ADDRESS 02143000
SR 0,1 02144000
SR 0,3 02145000
BH CHNGNXT2 LOOP PROTECTOR TR 02146000
EJECT 02147000
CHNGNXT1 L R14,CHNGNUM GET THE LINE COUNT @V305614 02148000
BCTR R14,R0 DECREMENT IT @V305614 02149000
ST R14,CHNGNUM AND PUT IT BACK @V305614 02150000
OI TWITCH,SAVOVER OVERRIDE AUTOSAVE @V2D3914 02151000
TM CHNGFLAG,CHNGSW HAS THE LINE BEEN CHANGED? @V2D3913 02152000
BZ CHNGNXT7 NO. 02153000
BAL 14,XREPL YES, REPLACE LINE 02154000
LA R6,1(,R6) INCREASE NUMBER OF LINES CHANGED @V2D3913 02155000
TM TWITCH,TRUNC WAS LINE TRUNCATED? 02156000
BZ CHNGVER2 NO 02157000
L R1,TRNCNUM GET TRUNCATE COUNT @VA04193 02158000
LA R1,1(R1) INCREMENT COUNT @VA04193 02159000
ST R1,TRNCNUM STORE NEW COUNT @VA04193 02160000
TM FLAG2,VER VERIFY OFF? @VA04193 02161000
BZ CHNGCLR YES ... BR @VA04193 02162000
TM FLAG2,TUBE DISPLAY TERMINAL? @VA04193 02163000
BO CHNGCLR YES ... BR @VA04193 02164000
WTYPE TRUNCX YES 02165000
CHNGVER2 TM FLAG2,TUBE DISPLAY TERMINAL ? @V2D3913 02166000
BO CHNGCLR YES ... BR @V2D3913 02167000
VERIFY @V2D3913 02168000
CHNGCLR NI TWITCH,255-TRUNC RESET TRUNC FLAG @VA04193 02169000
NI CHNGFLAG,255-CHNGSW CLEAR TWITCH. 02170000
CHNGNXT7 L R14,CHNGNUM ANY LINES LEFT TO DO ? @V305614 02171000
LTR R14,R14 ..... @V305614 02172000
BZ CEOFILE STANDARD EXIT (NOW) @V2D3913 02173000
BAL R14,XREAD READ ANOTHER LINE. @V2D3913 02174000
TM TWITCH,TOPSW+EOF ARE WE AT EITHER EXTREME? @V2D3913 02175000
BNZ CEOFILE ALL DONE, IF SO. @V2D3913 02176000
CHNGSTRT EQU * CHANGE START 02177000
LH 1,ZONE1 BEGINNING ZONE-1 02178000
LH 0,ZONE2 END ZONE 02179000
SR 0,1 WIDTH OF ZONE FIELD 02180000
STH 0,CHNGCNT SAVE FOR DONULL (MAX. INTERATION COUNT) 02181000
LA 1,LINE(1) START SEARCH HERE 02182000
TM CHNGFLAG,NULLSW1 IS STRING1 NULL? 02183000
BO CHNGNXT6 BRANCH IF SO 02184000
SR 0,3 LOOP COUNT 02185000
CHNGNXT2 EX 3,CHNGCOM 02186000
BE CHNGNXT6 FOUND STRING 02187000
LA 1,1(,1) UPDATE STARTING COLUMN. 02188000
BCT 0,CHNGNXT2 02189000
B CHNGNXT1 NOT FOUND HERE. 02190000
SPACE 02191000
CHNGNXT6 OI CHNGFLAG,FLDFND RAM 02192000
TM CHNGFLAG,NULLSW2 IS STRING2 NULL? RAM 02193000
BZ CHNGNXT3 BRANCH IF IT'S NOT 02194000
TM CHNGFLAG,NULLSW1 IS STRING1 NULL? 02195000
BO CHNGNXT1 BRANCH IF SO (BEHAVE AS NO-OP) 02196000
B DONULL ATTEND TO CASE OF STRING2 = NULL 02197000
SPACE 02198000
CEOFILE NI TWITCH,255-SAVOVER RESET SAVE OVERRIDE @V2D3914 02199000
TM CHNGFLAG,FLDFND DID WE CHANGE ANYTHING ? @V2D3914 02200000
BNO NOTFOUND NO ... BR @V2D3913 02201000
BAL R14,AUTOCHEK NOW CHECK FOR AUTOSAVE @V2D3914 02202000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V2D3913 02203000
BO CHMSG YES ... BR @VA04193 02204000
TM FLAG2,VER VERIFY ON? @VA04193 02205000
BO ENDRANGE YES ... BR @VA04193 02206000
ICM R0,15,TRNCNUM GET TRUNC COUNT; IS IT ZERO? @VA04193 02207000
BZ NEXT YES ... BR @VA04193 02208000
LA R1,CHGTRUNC GET TRUNCATE MESSAGE ADDR @VA04193 02209000
LA R6,22 AND LENGTH @VA04193 02210000
B CNVTRUNC AND GO CONVERT @VA04193 02211000
CHMSG LR R0,R6 GET NUMBER OF LINES CHANGED @V2D3914 02212000
BAL R14,BINDEC CONVERT NUMBER @V2D3913 02213000
MVC CHNGMSG(4),AREA+4 PLUG INTO MESSAGE @V2D3913 02214000
LA R1,CHNGMSG LOAD MESSAGE ADDR AND @VA04193 02215000
LA R6,20 LOAD INIT MSG LENGTH @VA04193 02216000
ICM R0,15,TRNCNUM GET TRUNC COUNT; IS IT ZERO? @VA04193 02217000
BZ TYPCHMSG YES ... BR @VA04193 02218000
LA R6,44 LOAD LONG MSG LENGTH @VA04193 02219000
CNVTRUNC EQU * 02220000
BAL R14,BINDEC CONVERT TRUNC NUMBER AND @VA04193 02221000
MVC CHGTRUNC(4),AREA+4 PLUG INTO MESSAGE @VA04193 02222000
B TYPCMSG1 TYPE, REGARDLESS OF VERIFICATION @VA05355 02223000
TYPCHMSG EQU * @VA05355 02224000
TM FLAG2,VER VERIFICATION ON ? @VA05355 02225000
BNO NEXT NO, GET NEXT COMMAND @VA05355 02226000
TYPCMSG1 EQU * BR HERE IF TRUNC OCCURRED @VA05355 02227000
LR R0,R6 GET MSG LENGTH @VA04193 02228000
LA R14,NEXT AND RETURN ADDR @VA04193 02229000
B WRTYPE AND GO TO IT! @VA04193 02230000
SPACE 1 02231000
SPACE 1 02232000
MOVER MVC 0(*-*,9),0(8) 02233000
MOVEIN MVC 0(*-*,1),0(4) 02234000
MOVEBL MVC 1(*-*,9),0(9) 02235000
CHNGCOMP CLI 0(5),*-* 02236000
CHNGCOM CLC 0(*-*,1),0(2) 02237000
EJECT 02238000
*********************************************************************** 02239000
* 02240000
* 'STRING1' IS A SUBROUTINE WHICH IS CALLED FROM 'LOCATE' 02241000
* AND 'CHANGE' TO DELIMIT STRING1. 02242000
* 02243000
* CALL: 02244000
* BAL 14,STRING1 02245000
* 02246000
* ON EXIT: 02247000
* R2 POINTS TO START OF STRING1 (WHICH WILL HAVE BEEN 02248000
* MOVED INTO TABLIN); 02249000
* R3 CONTAINS LENGTH-1 OF STRING1; 02250000
* R4 POINTS TO NEXT FIELD IN EDLIN; 02251000
* R7 CONTAINS THE DELIMITER (IN THE LOW-ORDER BYTE). 02252000
* 02253000
* IF THE LENGTH OF STRING1 IS GREATER THEN THE ZONE WIDTH, 02254000
* THE MESSAGE 'ZONE ERROR' IS TYPED, AND A DIRECT BRANCH IS 02255000
* TAKEN TO INVREQX (INVALID REQUEST, BUT DON'T SAY SO). 02256000
* 02257000
* (LEVEL 1 SUBROUTINE) 02258000
* 02259000
*********************************************************************** 02260000
SPACE 02261000
STRING1 DS 0H 02262000
LA 2,TABLIN POINT R2 TO TABLIN 02263000
LH 3,EDCT SPOT IN EDLIN TO START LOOKING 02264000
LA 4,EDLIN(3) CONVERT TO ACTUAL ADDRESS 02265000
LH 5,COUNT LENGTH OF EDLIN 02266000
SR 5,3 LENGTH OF PIECE TO LOOK AT 02267000
BNH INVREQ BRANCH IF NONE (TELL HIM BAD REQUEST) 02268000
SPACE 02269000
STRG4 EQU * LOOK FOR OPENING DELIMITER 02270000
CLI 0(4),C' ' IS THIS IT? 02271000
BNE STRG1 BRANCH IF SO 02272000
LA 4,1(,4) LOOK AT NEXT BYTE 02273000
BCT 5,STRG4 LOOP UNTIL WE FIND IT 02274000
B INVREQ BRANCH IF STRING EXHAUSTED 02275000
SPACE 02276000
STRG1 EQU * WE'VE FOUND THE OPENING DELIMITER 02277000
IC 7,0(,4) PUT IT IN R7 02278000
LA 4,1(,4) LOOK AT NEXT BYTE 02279000
LR 1,4 SAVE THE SPOT IN R1 02280000
LR 3,4 AND IN R3 02281000
BCTR 5,0 LENGTH REMAINING 02282000
LTR 5,5 IS THERE ANY? 02283000
BZ STRG2 BRANCH IF NOT 02284000
SPACE 02285000
STRG3 EQU * SEARCH FOR CLOSING DELIMITER 02286000
EX 7,STRGCOMP IS THIS IT? 02287000
BE STRG2 BRANCH IF SO 02288000
LA 4,1(,4) LOOK AT NEXT BYTE 02289000
BCT 5,STRG3 LOOP 02290000
SPACE 02291000
STRG2 EQU * WE'VE DELIMITED STRING1 02292000
SR 3,4 COMPUTE ITS LENGTH 02293000
LPR 3,3 AND PUT IT IN R3 02294000
BCTR 3,0 (NOW LENGTH-1) 02295000
LTR 5,5 WAS THE CLOSING DELIMITER GIVEN? 02296000
BZ *+8 SKIP IF NOT 02297000
LA 4,1(,4) POINT TO NEXT BYTE 02298000
LA 0,EDLIN COMPUTE NEW VALUE FOR EDCT 02299000
SR 0,4 02300000
LPR 0,0 02301000
STH 0,EDCT AND PUT IT THERE 02302000
LTR 3,3 TEST LENGTH OF STRING1 02303000
BCR 4,14 RETURN IF ZERO (LENGTH-1 -VE) 02304000
SPACE 02305000
EX 3,STRGMOV MOVE STRING1 INTO TABLIN 02306000
TM FLAG,CAN CANONICALIZATION REQUIRED? 02307000
BZ STRG6 BRANCH IF NOT 02308000
SPACE 02309000
* CANONICALIZE THE STRING 02310000
SPACE 02311000
LA 0,1(3) LENGTH OF STRING1 INTO R0 02312000
LR 1,2 ADDRESS INTO R1 02313000
BAL 15,CANON CALL CANONICALIZING ROUTINE 02314000
LR 3,0 NEW LENGTH INTO R3 02315000
BCTR 3,0 (NOW LENGTH-1) 02316000
SPACE 02317000
STRG6 EQU * 02318000
LH 0,ZONE2 END ZONE 02319000
SH 0,ZONE1 MINUS STARTING ZONE 02320000
CR 3,0 IS STRING1 TOO LONG FOR ZONE? 02321000
BCR 4,14 RETURN IF NOT 02322000
WTYPE ZONERRMS,,RETURN=INVREQX @V200713 02323000
SPACE 02324000
STRGCOMP CLI 0(4),X'00' (WE FILL IN THE IMMEDIATE FIELD VIA EXEC) 02325000
STRGMOV MVC TABLIN(*-*),0(1) 02326000
SPACE 02327000
ZONERRMS DC C'ZONE ERROR' 02328000
EJECT 02329000
*********************************************************************** 02330000
* 02331000
* 'OVERLAY' REPLACES THE CHARACTERS OF A LINE WITH ANY 02332000
* CHARACTERS IN THE INPUT LINE WHICH ARE NON-BLANK. 02333000
* 02334000
* AN UNDERSCORE IS THE INPUT LINE FORCES A BLANK INTO THE 02335000
* LINE BEING OVERLAID. 02336000
* 02337000
*********************************************************************** 02338000
SPACE 02339000
OVRLAY DS 0H 02340000
NC REPCNT,REPCNT TEST REPCNT 02341000
LA R3,1 GET AN AMIABLE COUNT @V2D3913 02342000
BNZ OVRL2 BRANCH IF NOT ZERO 02343000
ST R3,REPCNT RESET THE REPEAT COUNT @V2D3913 02344000
B NEXT AND GET NEXT REQUEST 02345000
SPACE 1 02346000
OVRL2 BAL R14,EORCHK CHECK THE CURRENT BOUNDS @V2D3913 02347000
B REPSET ALL DONE @V2D3913 02348000
BAL R14,XREADB REFRESH LINE @V2D3913 02349000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V200714 02350000
BNO SPREDOVR NO...BR @V200714 02351000
CLC EDCT(2),COUNT CHECK LENGTH @V2D3913 02352000
BNE SPREDOVR YES...BR @V200714 02353000
BAL 14,RDTYPE GET NEW LINE @V200714 02354000
XC EDCT,EDCT POINT AT FIRST CHAR FOR SPREAD @V200714 02355000
SPREDOVR OI SIGNAL,OVER SET OVERLAY FLAG FOR SPREAD @V200714 02356000
BAL 14,SPREAD SPREAD THE LINE 02357000
TM TWITCH,TRUNC TRUNCATION? @VA04193 02358000
BZ OVRLEOR NO ... BR @VA04193 02359000
WTYPE TRUNCX SET UP TRUNCATION MESSAGE @VA04193 02360000
OI SCRFLG2,MOREB MAKE SURE IT'S SEEN @VA04193 02361000
OVRLEOR EQU * @VA04193 02362000
TM TWITCH,TOPSW+EOF ENDRANGE? @V2D3913 02363000
BZ *+8 SKIP IF NOT 02364000
BAL 2,REPT1 LET REPT1 HANDLE IF SO 02365000
SPACE 02366000
OVRL EQU * 02367000
OI TWITCH,SAVOVER OVERRIDE AUTOSAVE @V2D3914 02368000
LH R0,TRUNCOL SET NUMBER OF CHARS TO OVLAY @V2D3914 02369000
LA 1,TABLIN POINT TO THE SPREAD LINE 02370000
LA 2,LINE AND THE LINE TO BE OVERLAID 02371000
OVRL1 CLI 0(R1),C' ' CHECK FOR BLANK @V2D3913 02372000
BE OVRL7 IF SO IGNORE 02373000
CLI 0(1),C'_' IS CHARACTER AN UNDERLINE? 02374000
BNE OVRL6 BRANCH IF NOT 02375000
MVI 0(2),C' ' FORCE A BLANK 02376000
B OVRL7 02377000
OVRL6 MVC 0(1,R2),0(R1) REPLACE OLD WITH NEW @V2D3913 02378000
OVRL7 AR R2,R3 MOVE ON. @V2D3913 02379000
AR R1,R3 HERE, AS WELL. @V2D3913 02380000
BCT 0,OVRL1 LOOP UNTIL DONE 02381000
BAL 2,REPT CHECK FOR MORE 02382000
B OVRL 02383000
EJECT 02384000
*********************************************************************** 02385000
* 02386000
* 'FOR' WILL CAUSE AN OVERLAY REQUEST TO BE DUPLICATED 02387000
* ON THE NEXT 'N' LINES. 02388000
* 02389000
* (REPT AND REPT1 ARE LEVEL 1 SUBROUTINES, CALLED FROM OVRLAY. 02390000
* CALL IS: BAL 2,REPT; OR BAL 2,REPT1.) 02391000
* 02392000
*********************************************************************** 02393000
SPACE 02394000
REPEAT DS 0H 02395000
BAL 14,NUM GET PARM 02396000
BAL 14,STARCHK MUST BE A STAR (HOPE) 02397000
BAL 14,PARMCHK CHECK NO MORE PARMS 02398000
ST 0,REPCNT STORE AS REPCNT 02399000
B NEXT 02400000
SPACE 02401000
REPT EQU * 02402000
BAL 14,XREPL UPDATE LINE 02403000
REPT1 L R6,REPCNT GET REPEAT COUNT @V2D3914 02404000
BCTR R6,R0 DECREMENT THE COUNT @V2D3914 02405000
TM FLAG2,TUBE IS THIS A DISPLAY TERMINAL ? @V2D3914 02406000
BNO REPTA NO ... BR @V2D3914 02407000
SPACE 1 02408000
LTR R6,R6 IS REPEAT COUNT ZERO ? @V2D3914 02409000
BNZ REPTB IF NOT, SKIP VERIFICATION @V2D3914 02410000
MVI SCRFLGS,WRTOPB REWRITE EVERYTHING @VM01058 02411000
SPACE 1 02412000
REPTA VERIFY @V2D3914 02413000
LTR R6,R6 IS REPEAT COUNT ZERO ? @V2D3914 02414000
BNZ REPTB CONTINUE IF NOT @V2D3914 02415000
BAL R14,AUTOCHEK CHECK FOR AUTOSAVE @V2D3914 02416000
NI TWITCH,255-SAVOVER RESET SAVE OVERRIDE @V2D3914 02417000
B NEXT RETURN @V2D3914 02418000
SPACE 1 02419000
REPTB ST R6,REPCNT SAVE NEW REPEAT COUNT @V2D3914 02420000
BAL R14,XREAD READ THE NEXT LINE OF TEXT @V2D3914 02421000
TM TWITCH,TOPSW+EOF AT FILE LIMIT ? @V2D3914 02422000
BZR R2 RETURN IF NOT @V2D3914 02423000
SPACE 02424000
REPSET EQU * 02425000
LA 14,1 GET A 1 @V200713 02426000
ST 14,REPCNT RESET REPCNT @V200713 02427000
B ENDRANGE TYPE EOF OR TOF @V2D3913 02428000
EJECT 02429000
*********************************************************************** 02430000
* 02431000
* X & Y COMMANDS-- 02432000
* 02433000
* FORMS-- 02434000
* 1. (X OR Y) COMMAND 02435000
* 2. (X OR Y) <NUMBER> 02436000
* 02437000
* FORM 1 CAUSES THE COMMAND TO BE SAVED. 02438000
* FORM 2 CAUSES THE SAVED COMMAND TO BE EXECUTED ONCE, OR 02439000
* THE NUMBER OF TIMES SPECIFIED. 02440000
* 02441000
*********************************************************************** 02442000
SPACE 02443000
XXX DS 0H 'X' REQUEST 02444000
LA 3,XACT NOTE THAT IT'S AN 'X' REQUEST 02445000
LA 4,XAREA POINT TO 'X' COMMAND AREA 02446000
B XYCOM AND ON TO COMMON ROUTINE 02447000
SPACE 02448000
YYY EQU * 'Y' REQUEST 02449000
LA 3,YACT NOTE THAT IT'S A 'Y' REQUEST 02450000
LA 4,YAREA POINT TO 'Y' COMMAND AREA 02451000
SPACE 02452000
XYCOM EQU * 'X' OR 'Y' REQUEST 02453000
LH 2,EDCT REMEMBER EDCT NOW 02454000
BAL 14,NUM TEST FOR NUMBER 02455000
B XYSAVE ERROR, MUST BE ALPHA, SAVE IT 02456000
BAL 14,PARMCHK CHECK NO MORE PARMS 02457000
L 1,XYCNT GET EXISTING XY COUNT 02458000
LTR 1,1 TEST IT 02459000
BNZ INVREQ BRANCH IF NOT ZERO (INVALID) 02460000
IC 1,XYFLAG PICK UP OLD VALUE OF XYFLAG 02461000
LR 2,1 SAME THING 02462000
NR 2,3 IS THIS REQUEST ALREADY ACTIVE? 02463000
BNZ INVREQ BRANCH IF SO (RECURSIVE ERROR) 02464000
OR 1,3 MAKE IT ACTIVE NOW 02465000
STC 1,XYFLAG 02466000
ST 0,XYCNT SAVE X-Y COUNT 02467000
MVC COUNT(2),0(4) GET COUNT 02468000
MVC EDLIN(L'EDLIN),2(4) MOVE IN SAVED COMMAND 02469000
B NEXT4 AND EXECUTE SAVED COMMAND 02470000
SPACE 02471000
XYSAVE EQU * 02472000
LH 1,COUNT LOAD LINE COUNT 02473000
SR 1,2 MINUS POINTER=CHARS TO MOVE 02474000
STH 1,0(4) SAVE COUNT 02475000
BCTR 1,0 MINUS 1 FOR 'EX' 02476000
LA 3,EDLIN(2) POINT TO START OF MOVE 02477000
EX 1,XYMVC MOVE IN LINE 02478000
B NEXT AND BACK TO MAIN LOOP 02479000
SPACE 02480000
XYMVC MVC 2(*-*,4),0(3) BLANK 'MVC' FOR 'EX' 02481000
EJECT 02482000
*********************************************************************** 02483000
* 02484000
* TRUNCIT SETS THE COLUMN OF TRUNCATION. 02485000
* 02486000
*********************************************************************** 02487000
SPACE 02488000
TRUNCIT DS 0H 02489000
BAL 14,NUM GET PARM 02490000
B TRUSTAR BRANCH IF NOT A NUMBER 02491000
BZ INVREQ TRUNC = 0, NOT ALLOWED 02492000
BM TRUNCTYP NOTHING THERE - TYPE CURRENT SETTINGS 02493000
C 0,ITEM TOO BIG? 02494000
BH INVREQ BRANCH IF SO 02495000
TRUNCIT1 EQU * 02496000
BAL 14,PARMCHK CHECK NO MORE PARMS 02497000
STH 0,TRUNCOL STORE IT 02498000
B NEXT 02499000
SPACE 02500000
TRUSTAR EQU * 02501000
BAL 14,STARCHK CHECK WHETHER PARM IS A STAR 02502000
L 0,ITEM USE ITEM LENGTH 02503000
B TRUNCIT1 02504000
SPACE 02505000
TRUNCTYP EQU * TYPE CURRENT TRUNC SETTING 02506000
LH 0,TRUNCOL LOAD UP R0 WITH SETTING 02507000
SPACE 1 02508000
AREATYPE BAL R14,BINDEC @V2D3913 02509000
WTYPE AREA+3,5,RETURN=NEXT @V2D3913 02510000
SPACE 3 02511000
*********************************************************************** 02512000
* 02513000
* 'BINDEC' CONVERTS THE BINARY CONTENTS OF R0 TO PACKED DECIMAL 02514000
* AND EDITS THIS DATA, PROVIDING (ONLY) THE LOW-ORDER FOUR (4) 02515000
* CHARACTERS FOR TYPING. THE ZONED DATA IS AVAILABLE 02516000
* IN THE FIELD 'AREA' UPON RETURN FROM BINDEC. 02517000
* BINDEC IS CALLED BY 'TRUNCIT', 'ZONE', 'VERIFY' AND 'CHANGE' 02518000
* 02519000
*********************************************************************** 02520000
SPACE 02521000
BINDEC DS 0H 02522000
CVD 0,DECIMAL 02523000
MVC AREA(8),PATTERN SUPPLY EDIT PATTERN V0379 02524000
ED AREA(8),HALF EDIT ALL DIGITS V0379 02525000
BR 14 RETURN TO CALLER 02526000
SPACE 1 02527000
PATTERN DC X'4020202020202021' EDIT PATTERN @V305614 02528000
EJECT 02529000
*********************************************************************** 02530000
* 02531000
* 'ZONE' Z1 <Z2> SETS THE BEGINNING AND END COLUMN FOR 02532000
* CHANGE, ALTER AND LOCATE. 02533000
* 02534000
*********************************************************************** 02535000
SPACE 02536000
ZONE DS 0H 02537000
BAL 14,NUM GET ARGUMENT 02538000
BAL 14,STARCHK HOPEFULLY A STAR 02539000
BM ZONTYPE BRANCH IF NOT GIVEN @VM08700 02540000
BZ INVREQ BRANCH IF 0 @VM08700 02541000
LPR 2,0 SAVE IT, OR 1 IF * 02542000
BAL 14,NUM GET 2ND ARG 02543000
B ZSTAR HOPEFULLY A STAR IF ERROR RETURN FROM NUM 02544000
BZ INVREQ BRANCH IF ZERO 02545000
BL ZONEC BRANCH IF 2ND ARG. ABSENT 02546000
C 0,ITEM TOO BIG? 02547000
BH INVREQ BRANCH IF SO 02548000
ZONEB EQU * 02549000
BAL 14,PARMCHK CHECK NO MORE ARGS 02550000
CR 0,2 CHECK END ZONE >= START 02551000
BL INVREQ BRANCH IF NOT 02552000
STH 0,ZONE2 SAVE END ZONE 02553000
B ZONED 02554000
ZONEC EQU * 2ND ARG IS ABSENT 02555000
CH 2,ZONE2 COMPARE 1ST WITH EXISTING ZONE2 02556000
BH INVREQ BRANCH IF GREATER 02557000
ZONED EQU * 02558000
BCTR 2,0 DECREMENT START ZONE 02559000
STH 2,ZONE1 SAVE IT 02560000
B NEXT 02561000
SPACE 02562000
ZSTAR EQU * 02563000
BAL 14,STARCHK CHECK THAT IT'S A STAR 02564000
L 0,ITEM USE THE ITEM LENGTH 02565000
B ZONEB 02566000
SPACE 2 02567000
ZONTYPE EQU * TYPE CURRENT ZONES 02568000
LH 1,ZONE1 FIRST GET ZONE-1 02569000
LA 1,1(,1) MAKE UP FOR DECREMENT (ABOVE) 02570000
LR 0,1 PUT IT IN R0 FOR 'BINDEC' 02571000
BAL 14,BINDEC GO TO EDITTING ROUTINE 02572000
MVC RANGE(4),AREA+4 SET UP ZONE-1 V0379 02573000
LH 0,ZONE2 NOW LOAD UP ZONE-2 02574000
BAL 14,BINDEC AND DO IT AGAIN (EDIT) 02575000
MVC RANGE+4(4),AREA+4 SET UP ZONE-2 V0379 02576000
WTYPE RANGE,8,RETURN=NEXT @V305614 02577000
EJECT 02578000
*********************************************************************** 02579000
* 02580000
* 'CASE' SETS THE CASE OF THE FILE TO 'U' (UPPER) OR 02581000
* 'M' (MIXED). IT AFFECTS LINES OF INPUT FROM THE TERMINAL, 02582000
* OR LINES WHICH HAVE BEEN 'STACKED'. DEFAULT DEPENDS UPON 02583000
* THE FILETYPE. 02584000
* 02585000
* IT HAS A CONFUSING EFFECT ON ANY OTHER LOGICAL LINES WHICH 02586000
* ARE STACKED BY MEANS OF THE 'LINEND' CHARACTER AFTER 02587000
* THE 'CASE' REQUEST, ON THE SAME PHYSICAL LINE. 02588000
* THESE OTHER LOGICAL LINES ARE INTERPRETED BY CMS BEFORE 02589000
* THE 'CASE' REQUEST HAS TAKEN EFFECT, AND WILL THEREFORE 02590000
* BE READ AS IF ISSUED BEFORE THE 'CASE' REQUEST. 02591000
* 02592000
*********************************************************************** 02593000
SPACE 02594000
CASE DS 0H 02595000
BAL 14,GET GET THE ARGUMENT 02596000
BZ CASETELL BRANCH IF NONE GIVEN (TELL HIM) 02597000
LTR 1,1 HOW MANY CHARACTERS HAS IT? 02598000
BNZ INVREQ BRANCH IF ¬= 1 (WON'T DO) 02599000
MVC SAVCWD(1),XXXCWD SAVE IT 02600000
BAL 14,PARMCHK CHECK NO MORE PARMS 02601000
CLI SAVCWD,C'U' IS IT 'CASE U'? 02602000
BNE CASEM BRANCH IF NOT (CHECK FOR 'CASE M') 02603000
MVI CASESW,C'U' SET CASESW 02604000
B NEXT 02605000
CASEM EQU * CHECK FOR 'CASE M' 02606000
CLI SAVCWD,C'M' WELL? 02607000
BNE INVREQ BRANCH IF NOT (INVALID REQUEST) 02608000
MVI CASESW,C'S' SET CASESW TO 'S' 02609000
B NEXT 02610000
SPACE 02611000
CASETELL EQU * TELL HIM THE CASE 02612000
MVI SAVCWD,C'U' SUPPOSE IT'S 'U' 02613000
CLI CASESW,C'U' IS IT? 02614000
BE *+8 SKIP IS SO 02615000
MVI SAVCWD,C'M' MUST BE 'M' 02616000
SPACE 1 02617000
WTYPE SAVCWD,1,RETURN=NEXT @V200713 02618000
EJECT 02619000
*********************************************************************** 02620000
* 02621000
* IMAGE TURNS ON OR OFF THE CREATION OF A LINE IMAGE, OR 02622000
* SETS CANONICAL ORDERING. DEFAULT DEPENDS UPON FILETYPE. 02623000
* 02624000
*********************************************************************** 02625000
SPACE 02626000
IMAGE DS 0H 02627000
BAL 14,GET GET PARM 02628000
BZ IMTYPE IF NOT GIVEN, TYPE CURRENT SETTING 02629000
MVC SAVCWD(8),XXXCWD SAVE THE ANSWER 02630000
BAL 14,PARMCHK ENSURE NO MORE PARMS 02631000
CLC SAVCWD(3),ON ON ? @V2D3914 02632000
BE IMON BRANCH IF SO 02633000
CLC SAVCWD(4),OFF OFF ? @V2D3914 02634000
BE IMOFF BRANCH IF SO 02635000
CLC SAVCWD(6),=CL6'CANON ' CANON? 02636000
BNE INVREQ BRANCH IF NOT 02637000
OI FLAG,CAN SET CANONICAL ORDERING 02638000
NI FLAG,255-IMNOT AND ENSURE THAT IMAGE IS NOT OFF 02639000
B NEXT 02640000
SPACE 02641000
IMON EQU * 02642000
NI FLAG,255-(CAN+IMNOT) SET CANONICAL ORDERING OFF... 02643000
B NEXT (AND IMAGE ON) 02644000
SPACE 02645000
IMOFF EQU * 02646000
OI FLAG,IMNOT SUPPRESS LINE IMAGE 02647000
NI FLAG,255-CAN AND CANONICAL ORDERING 02648000
B NEXT 02649000
SPACE 2 02650000
IMTYPE EQU * TYPE CURRENT IMAGE SETTING 02651000
TM FLAG,CAN IS 'CANON' ACTIVE ? 02652000
BZ IMOFFCK NO 02653000
MVC RANGE(5),=CL6'CANON ' 02654000
B ITYPE TYPE 'CANON' 02655000
IMOFFCK TM FLAG,IMNOT IS 'OFF' ACTIVE ? 02656000
BO LMW2 @V2D3913 02657000
IMONTYP MVC RANGE(5),ON @V2D3914 02658000
SPACE 2 02659000
ITYPE WTYPE RANGE,5,RETURN=NEXT @V200713 02660000
SPACE 1 02661000
ON DC CL5'ON' @V2D3914 02662000
OFF DC CL5'OFF' @V2D3914 02663000
EJECT 02664000
*********************************************************************** 02665000
* 02666000
* LINEMODE SWITCHES LINE-EDITING MODE ON OR OFF 02667000
* VALID FORMS ARE 02668000
* LINEMODE LEFT (COLS 1-5) 02669000
* LINEMODE RIGHT (COLS 76-80) 02670000
* LINEMODE OFF 02671000
* LINEMODE TELLS YOU WHICH MODE 02672000
*********************************************************************** 02673000
SPACE 02674000
LINEMODE DS 0H 02675000
BAL 14,GET 02676000
BZ LMWHICH TELL THE USER WHERE HE'S AT 02677000
MVC SAVCWD(8),XXXCWD SAVE THE PARAMETER @V2D3913 02678000
BAL R14,PARMCHK SHOULD ONLY BE 1. @V2D3913 02679000
CLC SAVCWD(4),MOFF IS IT "OFF"? @V2D3913 02680000
BE LMOFF GO HANDLE @V2D3913 02681000
CLC SAVCWD(2),=CL2'L' L FOR LEFT IS ALLOWED @VA03087 02682000
BE LMLEFT .... @VA03087 02683000
CLC SAVCWD(5),MLEFT IS IT "LEFT"? @V2D3913 02684000
BE LMLEFT GO HANDLE @V2D3913 02685000
CLC SAVCWD(6),MRIGHT MIGHT BE RIGHT @V2D3913 02686000
BE LMRIGHT .... @VA03087 02687000
CLC SAVCWD(2),=CL2'R' R FOR RIGHT IS ALLOWED @VA03087 02688000
BNE INVREQ IF NOT, BAD ARGUMENT @VA03087 02689000
LMRIGHT EQU * 02690000
CLI FV,C'F' F FORMAT FILE? 02691000
BNE SERBAD BRANCH IF NOT 02692000
CLI ITEM+3,80 ITEM LENGTH 80? 02693000
BNE SERBAD BRANCH IF NOT 02694000
OI FLAG,RIGHT SET MODE 02695000
MVI TRUNCOL+1,72 TRUNCATION COLUMN=72 02696000
TM FLAG2,TUBE DISPLAY TERMINAL? @VA04074 02697000
BO LMOK YES ... BR @VA04074 02698000
CLI VERCOL1+1,72 START VERIFY COL > 72 @VA04074 02699000
BNH LMCOL2 NO ... BR @VA04074 02700000
MVI VERCOL1+1,72 RESET TO 72 (=VERCOL2) @VA04074 02701000
LMCOL2 EQU * @VA04074 02702000
MVI VERCOL2+1,72 END VERIFY COL = 72 @VA04074 02703000
LH R3,VERCOL1 GET START AND @VA04074 02704000
LA R4,73 END+1 COLUMN POSITIONS @VA04074 02705000
SR R4,R3 CALC VERIFY LENGTH @VA04074 02706000
STH R4,VERLEN STORE NEW LENGTH @VA04074 02707000
LMOK EQU * @VA04074 02708000
MVI ZONE1+1,0 NEAR ZONE = 1 @VA00984 02709000
MVI ZONE2+1,72 FAR ZONE=72 02710000
LMR1 EQU * LMOFF JOINS HERE 02711000
NI FLAG,255-LEFT NOT LEFT 02712000
MVI LMSTART+1,75 SET COLUMN WHERE NUMBERS START 02713000
MVI PADCHAR,C'0' PAD WITH ZEROS 02714000
MVI TABS,1 RESET FIRST TAB 02715000
B NEXT 02716000
LMOFF EQU * 02717000
NI FLAG,255-RIGHT MODE NOT RIGHT 02718000
B LMR1 02719000
LMLEFT EQU * 02720000
TM FLAG,LINE8 8-DIGIT LINE NUMBERS? @VA08342 02720150
BNO LMLEFT1 VALID COMMAND IF NOT @VA08342 02720300
TM FLAG,LEFT LINEMODE ALREADY ON? @VA08342 02720450
BO NEXT BYPASS REDUNDANT REQUEST @VA08342 02720600
B INVREQ LINEMODE LEFT WAS CANCELLED @VA08342 02720750
LMLEFT1 EQU * @VA08342 02720900
NI FLAG,255-RIGHT CLEAR RIGHT BIT 02721000
OI FLAG,LEFT SET MODE LEFT 02722000
MVI PADCHAR,C' ' PAD WITH BLANKS 02723000
MVI LMSTART+1,0 SET COLUMN WHERE NUMBERS START 02724000
CLI ZONE1+1,6 MAY NEED TO RESET ZONE 02725000
BH LML1 OK - NOW CHECK TABS 02726000
MVI ZONE1+1,6 NOT OK - RESET TO 7 02727000
CLI ZONE2+1,6 TEST FAR ZONE 02728000
BH LML1 OK - NOW CHECK TABS 02729000
MVI ZONE2+1,6 ELSE SET NEW VALUE 02730000
LML1 EQU * CHECK TABS 02731000
CLI TABS,7 STARTING COLUMN > 7? @VA08142 02732000
BH LML2 YES, INSERT COLUMN 7 TAB @VA08142 02733000
MVI TABS,7 ELSE RESET TO 7 02734000
LML3 EQU * 02735000
CLI TABS+1,8 IS FIRST TAB GE 8? 02736000
BNL NEXT YES - ALL DONE 02737000
CLI TABS+1,0 OR ZERO? 02738000
BE NEXT YES - THAT'S OK TOO 02739000
MVC TABS+1(ENDTABS-TABS-2),TABS+2 SHIFT TABS LEFT 02740000
B LML3 REPEAT IF NECESSARY 02741000
LML2 MVC TEMPTAB(ENDTABS-TABS-1),TABS STORE FOR SHIFT @VA08142 02741150
MVI TABS,7 INSERT FIXED TAB @VA08142 02741300
MVC TABS+1(ENDTABS-TABS-2),TEMPTAB SHIFT TO RIGHT @VA08142 02741450
B NEXT FINISHED @VA08142 02741600
SPACE 1 02742000
LMWHICH EQU * 02743000
TM FLAG,RIGHT IS LINEMODE RIGHT? 02744000
BZ LMW1 BRANCH IF NOT 02745000
WTYPE MRIGHT,,RETURN=NEXT @V200713 02746000
SPACE 1 02747000
LMW1 EQU * 02748000
TM FLAG,LEFT IS LINEMODE LEFT? 02749000
BZ LMW2 BRANCH IF NOT 02750000
WTYPE MLEFT,,RETURN=NEXT @V200713 02751000
SPACE 1 02752000
LMW2 EQU * 02753000
WTYPE OFF,3,RETURN=NEXT @V2D3914 02754000
SPACE 1 02755000
SERBAD EQU * 02756000
VTYPE SERBMSG,,RETURN=NEXT @V200713 02757000
SPACE 1 02758000
SERBMSG DC C'WRONG FILE FORMAT FOR LINEMODE RIGHT' 02759000
MRIGHT DC C'RIGHT ' 02760000
MLEFT DC C'LEFT ' 02761000
MOFF DC CL5'OFF' @V200706 02762000
MON DC CL5'ON' @V200706 02763000
EJECT 02764000
*********************************************************************** 02765000
* 02766000
* 'SUPERFIND' AND 'SUPERFIX' 02767000
* VALID FORMS ARE 02768000
* NNN (FIND LINE NNN) 02769000
* NNN TEXT (INSERT/REPLACE LINE NNN) 02770000
* 02771000
*********************************************************************** 02772000
SPACE 02773000
SFIND DS 0H 02774000
TM FLAG,RIGHT+LEFT LINEMODE ON? V0263 02775000
BZ INVREQ DISABLED IF NOT V0263 02776000
LA 3,1 GET A 1 @V200713 02777000
ST 3,REPCNT RESET REPCNT @V200713 02778000
CLI PADCHAR,C' ' ARE WE PADDING WITH BLANKS? 02779000
BNE SF1 BRANCH IF NOT 02780000
CLI XXXCWD,C'0' NUMBER HAS LEADING ZERO? 02781000
BE INVREQ BRANCH INVALID IF SO 02782000
SF1 EQU * 02783000
LR 3,1 NO OF CHARS LESS ONE 02784000
LA 0,1(,1) NO OF CHARS 02785000
LA 4,5 @V1D1613 02786000
TM FLAG,LINE8 @V1D1613 02787000
BNO SF1B @V1D1613 02788000
LA 4,8 @V1D1613 02789000
SF1B CR 0,4 @V1D1613 02790000
BH SF6 @V1D1613 02791000
MVC PADBUF(8),PADCHAR @V1D1613 02792000
LA 2,PADBUF(4) @V1D1613 02793000
BCTR 4,0 @V1D1613 02794000
SR 2,0 MOVE NOS HERE 02795000
EX 3,SFX1 LEFT PADDING EFFECTED 02796000
BAL 14,CLOSE GO TO TOP OF FILE 02797000
SFL1 EQU * 02798000
BAL R14,XNEXT FIND THE NEXT LINE @V2D3913 02799000
TM TWITCH,EOF END OF FILE? 02800000
BO SF1A BRANCH IF EOF @V2D3913 02801000
LA R1,8(,R1) ELSE GET PAST THE POINTERS @V2D3913 02802000
AH 1,LMSTART 02803000
EX 4,CLCNUM @V1D1613 02804000
BH SFL1 NOT YET - GO LOOP 02805000
BE SF2 HIT - GO VERIFY 02806000
LR 0,4 @V1D1613 02807000
BAL 14,NUMCHECK OVERSHOOT - IS IT VALID? 02808000
SF1A EQU * @V2D3913 02809000
OI TWITCH,UPWARD GET SET TO BACK-UP @V2D3913 02810000
BAL R14,XNEXT NOW DO IT @V2D3913 02811000
CLC EDCT(2),COUNT NUMBER ONLY? 02812000
BL SF3 BRANCH IF NOT LOCATE @V2D3913 02813000
OI SCRFLGS,WRFULLB REWRITE ALL TEXT @V2D3914 02814000
WTYPE LINNOT,14 @V2D3913 02815000
B NEXT RETURN TO USER @V2D3914 02816000
SF1C VERIFY RETURN=NEXT @V2D3913 02817000
SF2 EQU * @V2D3913 02818000
CLC EDCT(2),COUNT NUMBER ONLY? @V2D3913 02819000
BNL SF1C GUESS SO @V2D3913 02820000
OI SIGNAL,REPL SET REPLACE INDICATOR @V2D3913 02821000
SF3 EQU * 02822000
TM FLAG,LINE8 LONG LINENUMBERS? @V2D3914 02823000
BO RTYP5 THEY'RE OK. @V2D3913 02824000
MVC PADBUF+5(3),PADBUF+2 @V2D3913 02825000
MVC PADBUF+3(2),PADBUF @V2D3913 02826000
B RTYP5 GO INSERT/REPLACE V0263 02827000
SF6 EQU * 02828000
VTYPE NONOS,,RETURN=NEXT @V200713 02829000
SPACE 1 02830000
SFX1 MVC 0(*-*,2),XXXCWD MOVE NO INTO PAD BUFFER 02831000
CLCNUM CLC PADBUF(*-*),0(1) @V1D1613 02832000
EJECT 02833000
*********************************************************************** 02834000
* 02835000
* PROMPTER - COMPUTE NEXT LINE NUMBER AND TYPE IT FOR USER 02836000
* 02837000
*********************************************************************** 02838000
SPACE 02839000
PROMPTER DS 0H 02840000
SR 1,1 02841000
LA 0,5 @V1D1613 02842000
TM FLAG,LINE8 @V1D1613 02843000
BNO PRA @V1D1613 02844000
LA 0,8 @V1D1613 02845000
PRA LR 4,0 @V1D1613 02846000
TM TWITCH,TOPSW AT TOP? 02847000
BO PR0 BRANCH IF SO (LINE=0) 02848000
L R2,PTR1 GET LINE POINTER @VA02110 02849000
LTR R2,R2 NULL FILE? @VA02110 02850000
BNZ PRAB NO,CONTINUE NORMALLY @VA02110 02851000
BAL R14,CLOSE YES,PRETEND WE ARE AT TOP @VA02110 02852000
B PR0 AND BRANCH SO @VA02110 02853000
PRAB L R1,PTR2 GET CURRENT LINE NUMBER @VA02110 02854000
LA 1,8(,1) GET PAST POINTERS 02855000
AH 1,LMSTART ON TO WHERE NUMBER IS 02856000
BAL 14,NUMCHECK CONVERT TO BINARY 02857000
LR 0,4 @V1D1613 02858000
TM SIGNAL,REPL IMMEDIATE REPLACE? @VA04074 02859000
BO PR22 YEP ... BR @VA04074 02860000
PR0 EQU * 02861000
ST 1,LMCURR SAVE CURRENT LINE NUMBER 02862000
* NOW GET NEXT LINE NUMBER. WE DON'T USE XNEXT SINCE 02863000
* WE WANT TO BACK UP AGAIN IMMEDIATELY 02864000
L 1,PTR2 CURRENT LINE POINTER 02865000
L 1,0(,1) NEXT LINE POINTER 02866000
LTR 1,1 EOF? 02867000
BNZ PR4 BRANCH IF NOT 02868000
LH 2,LMINCR COME HERE IF END OF FILE 02869000
A 2,LMCURR NEW LINE NUMBER 02870000
C 2,=F'100000' IS IT TOO LARGE? 02871000
BL PR2 BRANCH IF NOT 02872000
L 1,=F'100000' MAKE 100000 'NEXT LINE NUMBER' 02873000
B PR1 02874000
PR4 EQU * 02875000
LA 1,8(,1) BYPASS POINTERS 02876000
AH 1,LMSTART GET TO LINE NUMBER 02877000
BAL 14,NUMCHECK READ IN BINARY 02878000
* NOW R1 CONTAINS THE NEXT LINE NUMBER (OR 100000) 02879000
* LINE,EOF, TOPSW, AND PTR2 ARE UNCHANGED (IN CASE OF ERROR) 02880000
PR1 EQU * 02881000
S 1,LMCURR SUBTRACT TO GET DIFFERENCE 02882000
LA R2,1 GET A ONE @V2D3913 02883000
CR R1,R2 IS IT A ONE? @V2D3913 02884000
BNH PR3 YES - MUST RENUMBER 02885000
LH 2,LMINCR 02886000
CR 1,2 IS DIFFERENCE LESS THAN INCREMENT? 02887000
BH PR11 BRANCH IF NOT 02888000
SRL 1,2 DIVIDE DIFFERENCE BY 4 02889000
LA 2,1(,1) AND ADD ONE 02890000
PR11 EQU * 02891000
A 2,LMCURR COMPUTE NEW LINE NUMBER 02892000
PR2 EQU * 02893000
LR 1,2 SAVE R2 - WORK ON R1 02894000
LH 3,LMINCR 02895000
SR 0,0 ROUND DOWN TO MEAREST MULTIPLE OF LMINCR 02896000
DR 0,3 BY DIVIDING 02897000
MR 0,3 AND MULTIPLYING AGAIN 02898000
C 1,LMCURR CAN WE USE THIS? 02899000
BH PR22 ITS GREATER THAN PRESENT LINENO (=OK) 02900000
LR 1,2 NO - USE PREVIOUSLY CALCULATED NUMBER 02901000
PR22 EQU * TYPE NUMBER AT TERMINAL WITH NO CR 02902000
CVD 1,DECIMAL BACK TO DECIMAL 02903000
UNPK PADBUF(8),DECIMAL(8) @V1D1613 02904000
OI PADBUF+7,C'0' @V1D1613 02905000
LA 1,PADBUF 02906000
CLI PADCHAR,C' ' IS PAD CHARACTER BLANK? 02907000
BNE PR5 BRANCH IF NOT 02908000
PRLOOP EQU * 02909000
CLI 0(1),C'0' IS CHARACTER ZERO 02910000
BNE PR5 BRANCH IF NOT 02911000
MVI 0(1),C' ' IF SO MAKE IT BLANK 02912000
LA 1,1(,1) GET NEXT CHARACTER 02913000
B PRLOOP 02914000
PR5 EQU * LINE FIT TO PRINT 02915000
LA 1,PADBUF+8 @V1D1613 02916000
SR 0,0 @V1D1613 02917000
CH 4,=H'5' @V1D1613 02918000
BNE *+8 @V1D1613 02919000
LA 0,1 @V1D1613 02920000
AR 0,4 @V1D1613 02921000
SR 1,4 @V1D1613 02922000
OI TYPFLG,CRBIT SUPPRESS CARRIAGE RETURN 02923000
BAL 14,WRTYPE TYPE NUMBER 02924000
NI TYPFLG,255-CRBIT RESTORE CARRIAGE RETURN 02925000
B INP1 RETURN 02926000
PR3 EQU * 02927000
NI FLAG2,255-INMODE RESET INPUT FLAG @V200714 02928000
OI UTILFLAG,LINSEQ NO SPACE FOR LINEMODE INPUT @VA08152 02928500
OI SCRFLGS,WRSTATB REWRITE STATUS LINE @V2D3913 02929000
VTYPE NOSPACE,,RETURN=PRGRCK @V200714 02930000
SPACE 1 02931000
NUMCHECK EQU * 02932000
LA 15,0(4,1) @V1D1613 02933000
NCL EQU * 02934000
CLI 0(1),C'0' POSITIVE NUMBER? 02935000
BL NC3 BRANCH IF NOT 02936000
NC2 EQU * 02937000
LA 1,1(,1) NEXT CHARACTER 02938000
CR 1,15 02939000
BL NCL LOOP IF NOT DONE 02940000
SR 1,4 @V1D1613 02941000
B DECBIN ELSE CONVERT TO BINARY 02942000
NC3 EQU * 02943000
CLI 0(1),C' ' IS IT A BLANK? 02944000
BE NC2 BRANCH BACK IF SO 02945000
NI FLAG2,255-INMODE RESET INPUT FLAG @V200714 02946000
OI SCRFLGS,WRSTATB REWRITE STATUS LINE @V2D3913 02947000
WTYPE NUMBAD @V200714 02948000
PRGRCK EQU * @V200714 02949000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V200714 02950000
BNO PEDIT NO...BR @V200714 02951000
B PEDIT1 @V200714 02952000
NOSPACE DC C'RENUMBER LINES' 02953000
NONOS DC C'MAXIMUM LINE NUMBER EXCEEDED' 02954000
NUMBAD DC C'NON-NUMERIC CHARACTER IN LINE NUMBER COLUMNS' 02955000
EJECT 02956000
*********************************************************************** 02957000
* 02958000
* PROMPT N - RESET PROMPT INCREMENT TO N 02959000
* 02960000
*********************************************************************** 02961000
SPACE 02962000
PROMPT DS 0H 02963000
BAL 14,NUM GET INCREMENT 02964000
B INVREQ INVALID IF NOT NUMERIC 02965000
BM PROMTELL TYPE CURRENT INCR IF NO ARGS 02966000
LTR 0,0 IS IT POSITIVE? 02967000
BNP INVREQ BRANCH IF NOT 02968000
CH 0,HALFLIM COMPARE WITH 32767 @V200713 02969000
BH INVREQ ERROR IF SO V0263 02970000
STH 0,LMINCR 02971000
B NEXT 02972000
SPACE 1 02973000
PROMTELL EQU * TYPE CURRENT LINE INCR 02974000
LH 0,LMINCR LOADUP R0 WITH INCR 02975000
B AREATYPE @V2D3913 02976000
EJECT 02977000
****************************************************************** 02978000
* 02979000
* 'PRESERVE' AND 'RESTORE' PRESERVE AND RESTORE THE SETTING 02980000
* OF TRUNC, VERIFY, ZONE, LONG, TABS, IMAGE, SCOPE, SERIAL, 02981000
* CASE, NAME, MODE AND RECFORM. 02982000
* 02983000
****************************************************************** 02984000
SPACE 1 02985000
PRESERVE DS 0H @V200713 02986000
BAL 14,PARMCHK CHECK NO PARM @V200713 02987000
MVC JAR(ENDBLOC-BLOC),BLOC SAVE DATA IN PRESERVING@V200713 02988000
B NEXT @V200713 02989000
SPACE 1 02990000
RESTORE DS 0H @V200713 02991000
BAL 14,PARMCHK CHECK NO PARM @V200713 02992000
MVC BLOC(ENDBLOC-BLOC),JAR RESTORE DATA FROM JAR @V200713 02993000
B NEXT @V200713 02994000
EJECT 02995000
****************************************************************** 02996000
* 02997000
* 'AUTOSAVE' ALLOWS THE EDIT USER TO AUTOMATICALLY SAVE THE 02998000
* CURRENT COPY OF HIS FILE AFTER EVERY 'N' LINES HAVE BEEN 02999000
* ADDED, REPLACED OR DELETED. IF NO PARAMETERS ARE GIVEN, 03000000
* THE CURRENT LINE LIMIT IS TYPED. IF 'OFF' IS SPECIFIED, 03001000
* THE AUTOSAVE FEATURE IS SET OFF. 03002000
* 03003000
****************************************************************** 03004000
SPACE 1 03005000
AUTOSAVE DS 0H @V200706 03006000
BAL 14,NUM READ THE ARGUMENT @V200706 03007000
B AUTOFF IF NON-NUMERIC TOKEN @V200706 03008000
BM AUTOTELL IF NO TOKEN @V200706 03009000
LTR 0,0 IS NUMERIC POSITIVE? @V200706 03010000
BNP INVREQ ERROR IF NOT @V200706 03011000
CH 0,HALFLIM 'N' > 32767? @V200706 03012000
BH INVREQ ERROR IF SO @V200706 03013000
BAL 14,PARMCHK NO MORE TOKENS, PLEASE. @V200706 03014000
SPACE 1 03015000
STH 0,AUTOCNT SAVE THE LIMIT @V200706 03016000
OI SIGNAL,AUTOFLAG OBVIOUSLY. @V200706 03017000
B NEXT GET NEXT EDIT SUBCOMMAND @V200706 03018000
SPACE 1 03019000
AUTOFF CLC XXXCWD(4),OFF ONLY 'OFF' ALLOWED @V2D3914 03020000
BNE INVREQ TOO BAD. @V200706 03021000
NI SIGNAL,255-AUTOFLAG TURN IT ALL OFF @V200706 03022000
XC AUTOCNT(4),AUTOCNT CLEAR LIMIT AND CURRENT NO. @V200706 03023000
B NEXT GET NEXT COMMAND @V200706 03024000
SPACE 1 03025000
AUTOTELL LH 0,AUTOCNT GET LIMIT COUNT @V200706 03026000
LTR 0,0 CHEK FOR NO ENTRY @V200706 03027000
BZ LMW2 BR, IF NO ENTRY @V2D3913 03028000
B AREATYPE AND DISPLAY IT @V2D3913 03029000
SPACE 1 03030000
HALFLIM DC H'32767' HALFWORD LIMIT @V200706 03031000
EJECT 03032000
*************************************************************** 03033000
* 03034000
* 'TABSET' REDEFINES THE TAB STOPS 03035000
* 03036000
*************************************************************** 03037000
SPACE 1 03038000
TABSET DS 0H @V2D3913 03039000
LA R2,ENDTABS-TABS LENGTH OF TAB AREA @V2D3913 03040000
SR R4,R4 @V2D3913 03041000
LA R5,L'LINE GET LENGTH OF LINE @V2D3913 03042000
LA R3,TEMPTAB @V2D3913 03043000
BAL R14,NUM GET FIRST ARGUMENT @V2D3913 03044000
B INVREQ NON-NUMERIC, ERROR @V2D3913 03045000
BL INVREQ NO ARG ENTERED, ERROR @V2D3913 03046000
LA R6,7 STANDARD TAB FOR LINEMODE LEFT @VA08142 03046500
B TABBIG CONTINUE CHECKS @V2D3913 03047000
SPACE 1 03048000
TABSET1 EQU * @V2D3913 03049000
BAL R14,NUM GET FIELD. @V2D3913 03050000
B INVREQ ERROR RETURN. @V2D3913 03051000
BL TABSET2 END. @V2D3913 03052000
SR R6,R6 RESET FIRST-TIME INDICATOR @VA08142 03052500
TABBIG CR R0,R5 COMPARE WITH L'LINE @V2D3913 03053000
BH INVREQ BRANCH IF SO @V2D3913 03054000
CR R0,R4 BIGGER THAN LAST ONE? @V2D3913 03055000
BNH INVREQ BRANCH IF NOT @V2D3913 03056000
LR R4,R0 SAVE IT @V2D3913 03057000
TM FLAG,LEFT LINEMODE LEFT? @VA08142 03057060
BNO TABSET3 NO, STORE IN BUFFER @VA08142 03057120
LTR R6,R6 FIRST TIME THROUGH? @VA08142 03057180
BZ TABSET3 NO, STORE IN BUFFER @VA08142 03057240
TM FLAG,LINE8 8-DIGIT NUMBER FIELD? @VA08142 03057300
BNO COMPTAB NO, 5-DIGIT FIELD @VA08142 03057360
LA R6,9 FIRST TAB FOR FREEFORT @VA08142 03057420
COMPTAB EQU * @VA08142 03057480
CR R0,R6 TO RIGHT OF FIXED MARGIN? @VA08142 03057540
BNH TABSET3 NO, STORE IN BUFFER @VA08142 03057600
STC R6,0(,R3) YES, STORE FIXED TAB FIRST @VA08142 03057660
LA R3,1(,R3) POINT TO NEXT POSITION @VA08142 03057720
BCTR R2,0 REDUCE REMAINDER @VA08142 03057780
TABSET3 EQU * @VA08142 03057840
STC R0,0(,R3) HERE TOO @V2D3913 03058000
LA R3,1(,R3) @V2D3913 03059000
BCT R2,TABSET1 @V2D3913 03060000
B INVREQ TOO MANY TABS @V2D3913 03061000
SPACE 1 03062000
TABSET2 EQU * @V2D3913 03063000
XC 0(1,R3),0(R3) ZERO OUT LAST TAB SETTING @V2D3913 03064000
MVC TABS(ENDTABS-TABS),TEMPTAB MOVE IN NEW TABS @V2D3913 03065000
B NEXT @V2D3913 03066000
EJECT 03067000
*************************************************************** 03068000
* 03069000
* DITTO STACKS (LIFO) THE LAST EDIT REQUEST WHICH (WHETHER 03070000
* VALID OR NOT) DID NOT START WITH A DOUBLE-QUOTE OR A 03071000
* QUESTION MARK. 03072000
* 03073000
*********************************************************************** 03074000
SPACE 03075000
DITTO DS 0H 03076000
OI SIGNAL,QUOD SET ? AND " FLAG 03077000
L 1,XYCNT GET XY COUNT 03078000
LTR 1,1 MAKE SURE IT'S ZERO 03079000
BNZ INVREQ (CONFUSION REINS IF IT'S NOT) 03080000
LA 1,TABLIN @V200713 03081000
ST 1,ATTNLEN SET INTO ATTN PLIST @V200713 03082000
LH 1,DITCNT 03083000
LA 1,1(1) ADD ONE TO DITCNT 03084000
STH 1,DITCNT 03085000
LH 1,SAVCNT LENGTH OF SAVED REQUEST 03086000
STC 1,ATTNLEN SET THE LENGTH TO STACK @V200713 03087000
CMS ATTN @V200713 03088000
BAL 14,GET GET THE NEXT TOKEN 03089000
BZ NEXT BRANCH IF NONE 03090000
B NEXT1 03091000
EJECT 03092000
************************************************************** 03093000
* 03094000
* FORMAT ALLOWS A DISPLAY TERMINAL USER TO SWITCH BETWEEN 03095000
* DISPLAY AND TYPEWRITER MODE OF OPERATION WHILE IN AN EDIT 03096000
* SESSION. 03097000
* 03098000
************************************************************** 03099000
SPACE 1 03100000
FORMAT EQU * @VM03203 03101000
LA R5,INVREQ FOR INVALID REQUEST BRANCH @VM03203 03102000
TM FLAG2,NODISP NODISP OPTION INCLUDED ? @VM03203 03103000
BOR R5 INVALID IF SO @VM03203 03104000
L R4,ADEVTAB POINT TO DEVICE TABLE @VM03203 03105000
USING DEVTAB,R4 FOR CONSOLE ADDRESS @VM03203 03106000
LH R2,CONSOLE GET CONSOLE ADDRESS @VA09296 03107000
DROP R4 ..... @VM03203 03108000
SPACE 1 03109000
DC X'83230024' DIAGNOSE FOR CONSOLE CLASS @VA09296 03110000
BHR R5 INVALID IF DISCONNECTED @VM03203 03111000
CLM R4,BIN1000,GRAFCON GRAPHICS TERMINAL ! @VM03203 03112000
BE FORMOK OK, IF SO @VM03203 03113000
CLM R4,BIN1000,CLASTERM TERMINAL CLASS? @VA09296 03114000
BNER R5 NO -- ERROR @VA09296 03114200
CLM R4,BIN0100,TYP3275 3275 DISPLAY? @VA09296 03114400
BE FORMOK YES -- CONTINUE @VA09296 03114600
CLM R4,BIN0100,TYP3277 3277 DISPLAY? @VA09296 03114800
BE FORMOK YES -- CONTINUE @VA09296 03115000
CLM R4,BIN0100,TYP3278 3278 DISPLAY? @VA09296 03115200
BNER R5 NO -- ERROR @VA09296 03115400
SPACE 1 03116000
FORMOK BAL R14,GET GET OPERAND @VM03203 03117000
BZ INVREQ MUST HAVE AN OPERAND @V2D3914 03118000
SPACE 1 03119000
CLC XXXCWD(4),=C'LINE' LINE SPECIFIED ? @V2D3914 03120000
BE SNGMODE YES ... BR @V2D3914 03121000
CLC XXXCWD(7),=C'DISPLAY' OPERAND HAD BETTER @V2D3914 03122000
BNER R5 BE DISPLAY.. @V2D3914 03123000
SPACE 1 03124000
OI FLAG2,TUBE TELL EDIT IT'S A TUBE @V2D3914 03125000
NI FLAG2,255-INMODE MAKE SURE INPUT FLAG OFF @VA04190 03126000
OI SCRFLGS,WRTOPB CAUSE A FULL DISPLAY @V2D3914 03127000
VERIFY RETURN=NEXT @V2D3914 03128000
SPACE 1 03129000
SNGMODE NI FLAG2,255-TUBE TELL EDIT IT'S A TYPEWRITER @V2D3914 03130000
B NEXT @V2D3914 03131000
SPACE 1 03132000
GRAFCON DC X'40' GRAPHICS CONSOLE TYPE @VM03203 03133000
TYP3275 DC X'02' 3275 DISPLAY STATION @VA09296 03134000
TYP3277 DC X'04' 3277 DISPLAY STATION @VA09296 03134050
TYP3278 DC X'01' 3278 DISPLAY STATION @VA09296 03134100
CLASTERM DC X'80' TERMINAL CLASS @VA09296 03134150
EJECT 03135000
*********************************************************************** 03136000
* 03137000
* 'STACK' HAS 2 FORMS: 03138000
* 03139000
* 1. STACK <N> 03140000
* 2. STACK EDIT-REQUEST 03141000
* 03142000
* FORM 1 STACKS (FIFO) N LINES (OR 1 LINE IF N IS OMITTED), 03143000
* STARTING WITH THE CURRENT LINE AND MAKING THE LAST LINE 03144000
* STACKED THE NEW CURRENT LINE. 'STACK 0' IS TREATED AS A 03145000
* SPECIAL CASE, AND STACKS A NULL LINE. 03146000
* 03147000
* FORM 2 STACKS (FIFO) THE GIVEN EDIT-REQUEST. 03148000
* 03149000
* IN FORM 1, A CHECK IS MADE FOR AN EXCESSIVE NUMBERS OF LINES. 03150000
* WE WANT TO AVOID RUNNING OUT OF FREE STORAGE (WHICH IS WHERE 03151000
* LINES THAT ARE STACKED ARE PUT) 03152000
* 03153000
*********************************************************************** 03154000
SPACE 03155000
STACK DS 0H 03156000
LH 2,EDCT REMEMBER EDCT 03157000
L R3,PTR2 GET POINTER TO THE CURRENT LINE @VA04608 03158000
BAL 14,NUM GET PARM 03159000
B STACKREQ BARNCH IF NOT NUMERIC 03160000
BAL 14,PARMCHK CHECK NO MORE PARMS 03161000
LA 1,LINE ADDRESS FROM WHICH TO STACK LINES 03162000
LTR 2,0 GET NUMBER OF LINES 03163000
BZ STACKNUL GO AND STACK NULL LINE IF ZERO 03164000
LA 1,25 GET THE STACK LIMIT COUNT @V200713 03165000
CR 2,1 CHECK NUMBER REQUESTED @V200713 03166000
BH STKBUST BRANCH IF TOO MANY 03167000
MVC STACKATL(1),TRUNCOL+1 LENGTH OF LINE TO STACK 03168000
LR R1,R3 INITIALIZE LINE POINTER @VA04608 03169000
BAL R14,EORCHK CHECK CURRENT RANGE @V2D3913 03170000
B ENDRANGE ALL DONE IN THIS CASE @V2D3913 03171000
SPACE 03172000
TM TWITCH,TOPSW+EOF SOME OTHER BOUNDARY? @V2D3913 03173000
BNZ STACKIT1 SKIP IT, THEN @V2D3914 03174000
STACKIT EQU * @V200713 03175000
LA R1,8(,R1) POINT PAST THE POINTERS @V2D3913 03176000
STCM R1,B'0111',STACKATL+1 STORE THE DATA ADDRESS @V2D3913 03177000
STACKIT3 EQU * 03178000
CMS STACKAT STACK THE LINE 03179000
STACKIT1 BCT R2,STACKIT2 MORE TO DO ? @V2D3914 03180000
TM FLAG2,TUBE IS THIS A GRAPHICS DEVICE? @VA04608 03181000
BNO NEXT NO. THEN WE'RE ALL DONE @VA04608 03182000
CL R3,PTR2 HAS THE CURRENT LINE MOVED? @VA04608 03183000
BE NEXT DISPLAY IS CORRECT IF IT HASN'T @VA04608 03184000
VERIFY RETURN=NEXT @VA04608 03185000
STACKIT2 BAL R14,XNEXT GET NEXT LINE LOCATION @V2D3914 03186000
TM TWITCH,TOPSW+EOF @V2D3913 03187000
BNZ ENDRANGE @V2D3913 03188000
B STACKIT STACK THIS LINE @V2D3914 03189000
SPACE 1 03190000
SPACE 03191000
STACKREQ EQU * STACK REST OF LINE (AS EDIT REQUEST) 03192000
LA 1,EDLIN(2) WHERE IN EDLIN TO START 03193000
ST 1,STACKATL STORE IN 'ATTN' PLIST 03194000
LH 1,COUNT TOTAL LENGTH OF EDLIN 03195000
SR 1,2 MINUS EDCT MAKES LENGTH TO STACK 03196000
STC 1,STACKATL STORE FOR 'ATTN' 03197000
B STACKONE FORCE STACK COUNT TO ONE @V2D3914 03198000
STACKNUL EQU * @V200713 03199000
MVI STACKATL,X'00' STACK A NULL LINE. @V2D3913 03200000
STACKONE LA R2,1 FUDGE FOR BCT (ONCE) @V2D3914 03201000
B STACKIT3 PLIST SET TO GO @V2D3914 03202000
SPACE 03203000
STKBUST EQU * TOO MANY LINES 03204000
WTYPE STKBSTMS,,RETURN=INVREQX @V200713 03205000
SPACE 03206000
STKBSTMS DC C'TOO MANY LINES TO STACK' 03207000
EJECT 03208000
*********************************************************************** 03209000
* 03210000
* A MACRO REQUEST (STARTING WITH A PERIOD) GOES TO FIND AN 03211000
* EXEC FILE VIA CMS SUBSET. 03212000
* 03213000
*********************************************************************** 03214000
SPACE 2 03215000
DOT DS 0H 03216000
L 1,XYCNT CHECK UP ON X-Y COUNT 03217000
LTR 1,1 MUST NOT BE 03218000
BNZ INVREQ (TOO EASY TO STACK TOO MANY LINES) 03219000
TM TWITCH,TOPSW TOP OF FILE? V0263 03220000
BNO CKEOF NO, CHEK EOF V0263 03221000
LA 1,TOPMSG YES, POINT TO 'TOF' MSG V0263 03222000
B STPTR ...AND BUILD PLIST V0263 03223000
CKEOF TM TWITCH,EOF END OF FILE? V0263 03224000
BNO NOPTR NEITHER, DROP THRU V0263 03225000
LA 1,EOFREC POINT TO 'EOF' V0263 03226000
STPTR EQU * V0263 03227000
ST 1,ATTNLEN SET ADDRESS INTO ATTN PLIST @V200713 03228000
MVI ATTNLEN,X'03' SET THE LENGTH @V200713 03229000
CMS ATTN @V200713 03230000
NOPTR EQU * V0263 03231000
MVC MACRO(L'MACROHDR),MACROHDR FORCE CALL TO EXEC@VA04733 03232000
LA R1,MACRO POINT TO 'EXEC $...' COMMAND @VA04733 03233000
ST 1,ATTNLEN PUT ADDRESS INTO ATTN PLIST @V200713 03234000
LH R1,COUNT GET THE LENGTH @VA04733 03235000
LA R1,EDLIN-MACRO(R1) INCREMENTED BY L'EXEC + 1 @VA04733 03236000
STC 1,ATTNLEN PUT IT INTO THE PLIST @V200713 03237000
CMS ATTN @V200713 03238000
CMS SUBSET,ERROR=IGNORE @V200713 03239000
LTR 15,15 TEST RETURN CODE 03240000
BZ NEXT BRANCH IF ZERO (OK) 03241000
LR 2,15 @V200713 03242000
BAL 4,STACKCLR CLEAR STACK IF NECESSARY V0379 03243000
LA 2,1(,2) @V200713 03244000
LTR 2,2 @V200713 03245000
BZ INVDOT @V200713 03246000
B NEXT 03247000
SPACE 1 03248000
SUBSET DS 0F 03249000
DC CL8'SUBSET' 03250000
DC CL8'(RETURN' 03251000
DC 8X'FF' 03252000
EJECT 03253000
*********************************************************************** 03254000
* 03255000
* 'CMS' PUTS THE USER INTO CMS SUBSET 03256000
* 03257000
*********************************************************************** 03258000
SPACE 03259000
CMS DS 0H 03260000
BAL 14,PARMCHK CHECK NO PARMS 03261000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V200714 03262000
BNO MODESW NO...BR @V200714 03263000
MVI SCRFLG2,CANCB CAUSE TUBE CANCEL OP @V200714 03264000
BAL R14,WRTYPEX @V2D3913 03265000
NI SCRFLG2,255-CANCB RESET CANCEL FLAG @VA04074 03266000
MODESW EQU * @V200714 03267000
CMS CMSSUB,ERROR=INVREQ CALL CMS SUBSET 03268000
B REFRESH @V2D3913 03269000
SPACE 03270000
CMSSUB DS 0F 03271000
DC CL8'SUBSET' 03272000
DC X'FF' 03273000
SPACE 4 03274000
*********************************************************************** 03275000
* 03276000
* 'QUIT' CAUSES EXIT FROM THE EDITOR, ABANDONING CONTENTS 03277000
* 03278000
*********************************************************************** 03279000
SPACE 03280000
QUIT DS 0H 03281000
BAL 14,PARMCHK CHECK NO PARMS 03282000
XR 2,2 RETURN CODE = 0 03283000
B EDEXIT1 GO EXIT 03284000
EJECT 03285000
*********************************************************************** 03286000
* 03287000
* 'STACKCLR' IS A SUBROUTINE WHICH CLEARS THE READ STACK 03288000
* BY CALLING THE CMS 'DESBUF' FUNCTION. 03289000
* 03290000
* CALL: 03291000
* BAL 4,STACKCLR 03292000
* 03293000
* (LEVEL N SUBROUTINE) 03294000
* 03295000
*********************************************************************** 03296000
SPACE 03297000
STACKCLR DS 0H 03298000
L 1,AFSTFNRD ADDRESS OF ANCHOR FOR STACKED READS 03299000
L 1,0(1) ARE THERE ANY? 03300000
LTR 1,1 03301000
BCR 8,4 @V200713 03302000
CMS CONWAIT WAIT FOR PEACE AND QUIET 03303000
CMS DESBUF DESTROY STACKED LINES 03304000
WTYPE KILMES TYPE WARNING MESSAGE 03305000
BR 4 RETURN 03306000
SPACE 03307000
CONWAIT DS 0F 03308000
DC CL8'CONWAIT' 03309000
DC CL4'CON1' 03310000
SPACE 03311000
DESBUF DS 0F 03312000
DC CL8'DESBUF' 03313000
SPACE 03314000
KILMES DC C'STACKED LINES CLEARED' 03315000
EJECT 03316000
************** 03317000
* 03318000
* 'KTCLR' IS A SUBROUTINE TO CLEAR THE 'KT' FLAG IN ORDER 03319000
* TO TYPE AN IMPORTANT MESSAGE WHICH SHOULD NOT BE MISSED. 03320000
* IT DOES SO BY STACKING A NULL LINE (LIFO) AND THEN 03321000
* READING IT. 03322000
* 03323000
* CALL IS: 03324000
* BAL 4,KTCLR 03325000
* 03326000
* (LEVEL N SUBROUTINE, CALLED FROM XWRITE, SAVE/FILE AND 03327000
* TERMINAL ERRORS.) 03328000
* 03329000
************** 03330000
SPACE 03331000
KTCLR DS 0H 03332000
ICM R1,3,COUNT GET REQUEST LENGTH @VA04190 03333000
STH R1,SAVCNT SAVE IT @VA04190 03334000
BZ KTNEXT BRANCH IF NULL @VA04190 03335000
BCTR R1,0 MINUS ONE FOR 'EX' @VA04190 03336000
EX R1,SAVREQ SAVE REQUEST IN TABLIN @VA04190 03337000
OI SIGNAL,QUOD MAKE LIKE A ? OR " @VA04190 03338000
KTNEXT EQU * @VA04190 03339000
MVI ATTNLEN,X'00' STACK ZERO CHARACTERS. @V200713 03340000
CMS ATTN @V200713 03341000
BAL 14,RDTYPE THEN READ IT, THEREBY CLEARING KT FLAG 03342000
BR 4 RETURN 03343000
EJECT 03344000
****************************************************************** 03345000
* 03346000
* QUERY TYPES OUT THE LAST EDIT REQUEST WHICH (WHETHER 03347000
* VALID OR NOT) DID NOT START WITH A DOUBLE QUOTE OR A 03348000
* QUESTION MARK. 03349000
* 03350000
****************************************************************** 03351000
SPACE 1 03352000
QUERY DS 0H @V200713 03353000
OI SIGNAL,QUOD SET ? AND " FLAG @V200713 03354000
BAL 14,PARMCHK ENSURE NO MORE PARMS @V200713 03355000
LH 0,SAVCNT GET LENGTH OF SAVED REQUEST @V200713 03356000
LA 1,TABLIN AND ADDRESS @V200713 03357000
OI SCRFLG2,CMDINB SET FLAG FOR DISPLAY RTN @V2D3913 03358000
LA R14,NEXT WRITE LAST COMMAND TO INPUT AREA @V2D3913 03359000
B WRTYPEX THEN GET NEXT SUBCOMMAND @V2D3913 03360000
EJECT 03361000
****************************************************************** 03362000
* 03363000
* 'LONG' AND 'SHORT' CHANGE BETWEEN LONG AND SHORT 03364000
* DIAGNOSTIC MESSAGES. 03365000
* 03366000
****************************************************************** 03367000
SPACE 1 03368000
LONG DS 0H @V200713 03369000
BAL 14,PARMCHK AT END OF PARMS? @V200713 03370000
OI FLAG2,LONGSW SET 'LONG' MODE @V200713 03371000
B NEXT @V200713 03372000
SPACE 2 03373000
SHORT EQU * @V200713 03374000
BAL 14,PARMCHK AT END OF PARMS? @V200713 03375000
NI FLAG2,255-LONGSW SET 'SHORT' MODE @V200713 03376000
B NEXT @V200713 03377000
EJECT 03378000
****************************************************************** 03379000
* 03380000
* 'FNAME' RESETS THE FILENAME FOR SUBSEQUENT UNQUALIFIED 03381000
* AND SAVE REQUESTS. 03382000
* IF ISSUED WITHOUT AN ARGUMENT, IT DISPLAYS THE CURRENT 03383000
* NAME 03384000
****************************************************************** 03385000
SPACE 1 03386000
NAME DS 0H @V200713 03387000
OI SIGNAL,GETCAT SET GETCAT FLAG @V200713 03388000
BAL 14,GET GET NAME @V200713 03389000
BZ NAMETELL BRANCH IF NONE GIVEN @V200713 03390000
CLI XXXCWD,C'*' NAME STAR WITH A STAR? @V200713 03391000
BE INVREQ BRANCH IF SO (NO ALLOWED) @V200713 03392000
MVC SAVCWD(8),XXXCWD SAVE NAME @V200713 03393000
BAL 14,PARMCHK CHECK NO MORE PARMS @V200713 03394000
MVC FNAME(8),SAVCWD MOVE IN NEW NAME @V200713 03395000
B VERSTAT VERIFY IF TUBE TERMINAL @V200714 03396000
SPACE 1 03397000
NAMETELL EQU * TYPE THE CURRENT NAME @V200713 03398000
WTYPE FNAME,8,RETURN=NEXT @V305614 03399000
EJECT 03400000
****************************************************************** 03401000
* 03402000
* 'FMODE' RESETS THE FILEMODE FOR THE NEW FILE. 03403000
* IF CALLED WITHOUT ANY PARM, DISPLAYS THE CURRENT 03404000
* SETTING 03405000
****************************************************************** 03406000
SPACE 1 03407000
MODE DS 0H @V200713 03408000
OI SIGNAL,GETCAT SET GETCAT FLAG @V200713 03409000
BAL 14,GET GET PARM @V200713 03410000
BZ MODETELL BRANCH IF NONE @V200713 03411000
BCTR 1,0 DECREMENT THE COUNT @V200713 03412000
LTR 1,1 CHECK IT NOW @V200713 03413000
BP INVREQ ERROR IF TOO MANY @V200713 03414000
MVC CMODE(4),XXXCWD READY FOR 'MODECHK' @V200713 03415000
BAL 14,MODECHK GO CHEK FOR VALID MODE @V200713 03416000
BNZ MODERR ERROR IF CC IS -VE @V200713 03417000
MVC FMODE(2),CMODE SAVE NEW FILEMODE @V200713 03418000
BAL 14,PARMCHK NO MORE ARGS, PLEASE @V200713 03419000
B VERSTAT VERIFY IF TUBE TERMINAL @V200714 03420000
SPACE 1 03421000
MODETELL EQU * TYPE THE CURRENT MODE @V200713 03422000
WTYPE FMODE,2,RETURN=NEXT @V305614 03423000
VERSTAT EQU * @V200714 03424000
TM FLAG2,TUBE DISPLAY TERMINAL ? @V200714 03425000
BNO NEXT NO...BR @V200714 03426000
MVI SCRFLGS,WRSTATB STATUS CHANGE ONLY @V2D3914 03427000
VERIFY RETURN=NEXT @V2D3913 03428000
EJECT 03429000
LTORG @V200713 03430000
* *********************************** 03431000
* *********************************** 03432000
* ***** ***** 03433000
* ***** END OF PAGE 2 ***** 03434000
* ***** ***** 03435000
* *********************************** 03436000
* *********************************** 03437000
EJECT 03438000
****************************************************************** 03439000
* 03440000
* 'RECFORM' RESETS RECORD FORMAT BETWEEN F AND V. 03441000
* DEFAULT DEPENDS UPON THE FILETYPE. 03442000
* 03443000
****************************************************************** 03444000
SPACE 1 03445000
RECFORM DS 0H @V200713 03446000
MVI SCRFLGS,WRSTATB MAY CHANGE STATUS LINE @V2D3914 03447000
BAL 14,GET GET PARM @V200713 03448000
BZ FORMTELL BRANCH IF NONE @V200713 03449000
LTR 1,1 HOW MANY CHARS WERE TYPED? @V200713 03450000
BNZ INVREQ BRANCH IF NOT ONE @V200713 03451000
MVC SAVCWD(8),XXXCWD AND MOVE INTO SAVCWD @V200713 03452000
BAL 14,PARMCHK CHECK NO MORE PARMS @V200713 03453000
CLI SAVCWD,C'F' F? @V200713 03454000
BNE RECFORM1 BRANCH IF NOT @V200713 03455000
MVI FV,C'F' SAVE NEW FORMAT @V200713 03456000
B VERSTAT VERIFY IF TUBE TERMINAL @V200714 03457000
SPACE 1 03458000
RECFORM1 EQU * @V200713 03459000
CLI SAVCWD,C'V' V FORMAT? @V200713 03460000
BNE INVREQ BRANCH IF NOT @V200713 03461000
TM FLAG,RIGHT LINEMODE RIGHT? @V200713 03462000
BZ RECFORM2 SKIP IF NOT @V200713 03463000
WTYPE SERBMSG,,RETURN=NEXT @V200713 03464000
SPACE 1 03465000
RECFORM2 EQU * @V200713 03466000
MVI FV,C'V' SAVE NEW FORMAT @V200713 03467000
TM FLAG,SERSW SERIALIZATION? @V200713 03468000
BZ VERSTAT VERIFY IF TUBE TERMINAL @V200714 03469000
NI FLAG,255-SERSW TURN SERIALIZATION OFF @V200713 03470000
OI SCRFLG2,WRTOPB CAUSE FULL WRITE @V200714 03471000
WTYPE SEROFFMS,,RETURN=NEXT @V200713 03472000
SPACE 1 03473000
FORMTELL EQU * @V200713 03474000
WTYPE FV,1,RETURN=NEXT @V305614 03475000
SPACE 2 03476000
SEROFFMS DC C'SERIALIZATION TURNED OFF FOR V FORMAT' @V200713 03477000
EJECT 03478000
************************************************************** 03479000
* 03480000
* VERIFY SETS THE VERIFY-MODE AND/OR VERIFY COLUMN 03481000
* 03482000
************************************************************** 03483000
VERIFY DS 0H @V2D3914 03484000
LA R5,INVREQ FOR MORE EFFICIENT USE OF CORE @V2D3914 03485000
SR R3,R3 CLEAR A REG @V2D3914 03486000
L R2,ITEM GET LINE LENGTH @V2D3914 03487000
BAL R14,NUM SEE IF NUMERIC PARAMETER @V2D3914 03488000
B VEROFFCK NO, SEE IF 'OFF' @V2D3914 03489000
BM VERTYPE BR IF NO PARAMETER @V2D3914 03490000
BZR R5 ZERO IS INVALID @V2D3914 03491000
B SETVER USE VALID NUMBER @V2D3914 03492000
SPACE 1 03493000
VEROFFCK CLC XXXCWD(4),MOFF WAS 'OFF' SPECIFIED ? @V2D3914 03494000
BNE VERONCK NO, SEE IF IT WAS 'ON' @V2D3914 03495000
BCTR R3,R0 SET MINUS AS INDICATOR @V2D3914 03496000
B VERMORE SEE IF NUMBER SPECIFIED @V2D3914 03497000
SPACE 1 03498000
VERONCK CLC XXXCWD(3),MON WAS 'ON' SPECIFIED ? @V2D3914 03499000
BNE VERSTAR NO, IT BETTER BE ASTERISK @V2D3914 03500000
LR R3,R2 YES, SET POSITIVE AS INDICATOR @V2D3914 03501000
VERMORE BAL R14,NUM SEE IF NUMBER SPECIFIED @V2D3914 03502000
VERSTAR BAL R14,STARCHK BETTER BE ASTERISK @V2D3914 03503000
BM SETVER5 BR IF NOTHING SPECIFIED @V2D3914 03504000
BZR R5 ZERO NOT ALLOWED @V2D3914 03505000
LTR R0,R0 ASTERISK SPECIFIED ? @V2D3914 03506000
BNM SETVER NO...BR @V2D3914 03507000
LR R0,R2 VERIFY WHOLE LINE @V2D3914 03508000
B SETVER2 DO SOME CHECKING @V2D3914 03509000
SPACE 1 03510000
SETVER LR R4,R0 SAVE FIRST NUMBER @V2D3914 03511000
BAL R14,NUM GET NEXT NUMBER @V2D3914 03512000
BAL R14,STARCHK MIGHT BE AN ASTERISK @V2D3914 03513000
BNM SETVER1 BR IF 2ND NUMBER EXISTS @V2D3914 03514000
LR R0,R4 SHIFT 'EM BACK @V2D3914 03515000
B SETVER2 ..AND CONTINUE @V2D3914 03516000
SPACE 1 03517000
SETVER1 LTR R0,R0 ASTERISK SPECIFIED ? @V2D3914 03518000
BNM SETVER3 NO ... BR @V2D3914 03519000
LR R0,R2 USE LRECL FOR END COLUMN @V2D3914 03520000
B SETVER3 DO SOME CHECKING @V2D3914 03521000
SPACE 1 03522000
SETVER2 LA R4,1 USE DEFAULT START COLUMN @V2D3914 03523000
SETVER3 BAL R14,PARMCHK NO MORE PARAMETERS ALLOWED @V2D3914 03524000
CR R4,R0 2ND NUMBER > OR = 1ST NUMBER ? @V2D3914 03525000
BHR R5 INVALID IF NOT @V2D3914 03526000
CR R0,R2 2ND NUMBER > LRECL ? @V2D3914 03527000
BHR R5 INVALID IF SO @V2D3914 03528000
SPACE 1 03529000
SETVER4 STH R4,TVERCOL1 PLUG VALUES INTO TEMPORARY @V2D3914 03530000
STH R0,TVERCOL2 ATTRIBUTE LIST @V2D3914 03531000
SR R0,R4 CALCULATE LENGTH OF @V2D3914 03532000
LR R4,R0 OUTPUT REQUESTED @V2D3914 03533000
LA R4,1(,R4) ..... @V2D3914 03534000
STH R4,VERLEN AND PLUG INTO ATTRIBUTE LIST @V2D3914 03535000
MVC VERCOL1(4),TVERCOL1 ALSO PUT IN COLUMNS @V2D3914 03536000
SPACE 1 03537000
SETVER5 LTR R3,R3 CHECK OUR INDICATING REG @V2D3914 03538000
BZ NEXT BR, IF ONLY NUMBER SPECIFIED @V2D3914 03539000
BM VEROFF BR, IF 'OFF' SPECIFIED @V2D3914 03540000
VERON OI FLAG2,VER SET VERIFICATION ON @V2D3914 03541000
B NEXT GET NEXT COMMAND @V2D3914 03542000
VEROFF NI FLAG2,255-VER RESET VERIFICATION FLAG @V2D3914 03543000
B NEXT GET NEXT COMMAND @V2D3914 03544000
SPACE 1 03545000
VERTYPE LH R0,VERCOL1 CONVERT BINARY VALUE @V2D3914 03546000
BAL R14,BINDEC TO DECIMAL @V2D3914 03547000
MVC RANGE(4),AREA+4 PUT IT INTO AN OUTPUT AREA @V2D3914 03548000
LH R0,VERCOL2 DO IT AGAIN @V2D3914 03549000
BAL R14,BINDEC FOR 2ND VALUE @V2D3914 03550000
MVC RANGE+4(4),AREA+4 ....... @V2D3914 03551000
WTYPE RANGE,8,RETURN=NEXT AND PRINT IT @VM03203 03552000
EJECT 03553000
*********************************************************************** 03554000
* 03555000
* 'SERIAL' ALLOWS THE USER TO CONTROL SERIALIZATION. 03556000
* 03557000
*********************************************************************** 03558000
SPACE 03559000
SERIAL DS 0H 03560000
MVI SERTSEQ,C' ' SET TEMP. SERIAL DATA TO DEFAULTS 03561000
MVI SERTSW,X'00' CLEAR TEMPORARY SERNAME SWITCH 03562000
LA R3,10 KEEP INCREMENT IN R3 (INIT. TO 10 03563000
OI SIGNAL,GETCAT SET GETCAT FLAG (CONCATENATE EDIT 03564000
BAL R14,GET GET 1ST PARM 03565000
BZ INVREQ INVALID FOR NO ARGS 03566000
CLC XXXCWD(4),MOFF CHECK FOR 'OFF' V0379 03567000
BE SERIAL1 03568000
CLC XXXCWD(4),=CL4'ALL' CHECK 'ALL 03569000
BE SERIAL5 USE 8 DIGITS 03570000
OI SERTSW,SERNAME SET SERIAL. WITH NAME 03571000
CLC XXXCWD(3),MON CHECK 'ON' @V200706 03572000
BE SERIAL5 BRANCH IF EQUAL (FILE USES FN) 03573000
MVC SERTSEQ(3),XXXCWD FILL IN THE NAME 03574000
SERIAL5 EQU * 03575000
BAL R14,NUM LOOK FOR INCREMENT 03576000
B INVREQ BRANCH IF NOT VALID 03577000
BL SERIAL4 BRANCH IF NONE GIVEN 03578000
LR R3,R0 PUT IT INTO R3 03579000
BAL R14,PARMCHK CHECK NO MORE PARMS 03580000
SPACE 03581000
SERIAL4 EQU * 03582000
CLI FV,C'F' F FORMAT FILE? 03583000
BNE BADFORM BRANCH IF NOT 03584000
CLI ITEM+3,80 ITEM LENGTH 80? 03585000
BNE BADFORM BRANCH IF NOT 03586000
CLI TRUNCOL+1,72 CHECK TRUNCOL 03587000
BNH CHKZON IT'S OK 03588000
MVI TRUNCOL+1,72 SET IT TO 72 03589000
WTYPE TRUNCMES TELL HIM SO 03590000
SPACE 03591000
CHKZON EQU * NOW CHECK ZONES 03592000
CLI ZONE1+1,72 FINALLY CHECK BEGINNING ZONE 03593000
BL SERSET BRANCH IF < 03594000
MVI ZONE1+1,71 SET BEGINNING ZONE TO 72 03595000
SPACE 03596000
SERSET EQU * VALID COMMAND -- SET THINGS FOR FILE 03597000
OI FLAG,SERSW SET SERIALIZATION (FOR REAL) 03598000
NI FLAG,255-SERNAME CLEAR NAME SWITCH 03599000
OC FLAG(1),SERTSW AND DO AS TOLD 03600000
MVC SEQNAME(3),SERTSEQ MOVE IN SEQUENCE NAME (IF ANY) 03601000
ST R3,CARDINCR AND USE GIVEN (OR DEFAULT) INCREMENT 03602000
CLI ZONE2+1,72 COMPARE END ZONE TO 72 @V200713 03603000
BNH NEXT BRANCH IF <= @V200713 03604000
MVI ZONE2+1,72 SET TO 72 IF NOT @V200713 03605000
WTYPE ZONMES,,RETURN=NEXT @V200713 03606000
SPACE 03607000
BADFORM EQU * 03608000
WTYPE BADFMES,,RETURN=NEXT @V200713 03609000
SPACE 03610000
SERIAL1 EQU * 03611000
BAL R14,PARMCHK CHECK NO MORE PARMS 03612000
NI FLAG,255-SERSW INDICATE SERIALIZATION SUPPRESSED 03613000
B NEXT 03614000
SPACE 2 03615000
TRUNCMES DC C'TRUNC SET TO 72' 03616000
ZONMES DC C'END ZONE SET TO 72' 03617000
BADFMES DC C'WRONG FILE FORMAT FOR SERIALIZATION' 03618000
EJECT 03619000
*********************************************************************** 03620000
* 03621000
* GETFILE LOADS A FILE, OR PART OF A FILE, INTO THE FILE BEING 03622000
* EDITED. 03623000
* 03624000
*********************************************************************** 03625000
SPACE 03626000
GETFILE DS 0H 03627000
OI SIGNAL,GETCAT SET GETCAT FLAG (CONCATENATE EDIT TOKS) 03628000
BAL 14,GET GET FILENAME 03629000
BZ INVREQ BRANCH IF NOT GIVEN 03630000
MVC IOLIST+8(8),XXXCWD MOVE IN FILENAME 03631000
SR 2,2 KEEP ZERO HERE 03632000
MVC IOLIST+16(8),FTYPE SET CURRENT FILETYPE 03633000
MVC IOLIST+24(2),=CL2'* ' AND ANY MODE 03634000
STH 2,IOLIST+26 SET FOR SEQUENTIAL READING 03635000
SR 3,3 INITIALIZE FLAG FOR READING TO EOF 03636000
OI SIGNAL,GETCAT RESET GETCAT FLAG (CONCATENATE EDIT TOKS) 03637000
BAL 14,GET GET FILETYPE (IF GIVEN) 03638000
BZ GETFGO BRANCH IF NOT GIVEN 03639000
CLI XXXCWD,C'*' STAR? 03640000
BNE GETFMVTY BRANCH IF NOT 03641000
LTR 1,1 ONLY THE ONE CHARACTER GIVEN? 03642000
BH INVREQ BRANCH IF NOT (WON'T DO) 03643000
B GETFMODE 03644000
GETFMVTY EQU * USE THE GIVEN FILETYPE 03645000
MVC IOLIST+16(8),XXXCWD MOVE IN GIVEN FILETYPE 03646000
GETFMODE EQU * LOOK FOR GIVEN FILEMODE 03647000
OI SIGNAL,GETCAT SET GETCAT FLAG (CONCATENATE EDIT TOKS) 03648000
BAL 14,GET GET FILEMODE 03649000
BZ GETFGO BRANCH IF NOT GIVEN 03650000
MVC CMODE(3),XXXCWD PROVIDE GIVEN MODE TO CHECKER 03651000
BAL 14,MODECHK AND GO THERE... 03652000
BNZ MODERR ERROR IF MODE INVALID 03653000
MVC IOLIST+24(2),XXXCWD MOVE IN GIVEN FILEMODE 03654000
BAL 14,NUM GET STARTING LINE NUMBER 03655000
B INVREQ BRANCH IF NOT NUMERIC 03656000
BZ INVREQ OR ZERO 03657000
STH 0,IOLIST+26 STORE IT 03658000
BAL 14,NUM GET NO. OF LINES 03659000
BAL 14,STARCHK IF NOT NUMERIC, HOPEFULLY IT'S * 03660000
BZ NEXT BRANCH IF NO LINES 03661000
BL GETFGO BRANCH IF LINES NOT SPECIFIED 03662000
LR 3,0 SAVE LINES IN R3 03663000
SPACE 03664000
GETFGO EQU * 03665000
BAL 14,PARMCHK CHECK NO MORE PARMS 03666000
CMS IOLIST,PROG=STATE,ERROR=IGNORE 03667000
LTR 15,15 ANY ERRORS? 03668000
BZ GETFST NO, WE FOUND IT 03669000
CH 15,=H'28' IS THIS A 'NOT FOUND' ERR? 03670000
BE NOGETF THAT'S RIGHT 03671000
B INVREQX BAD FILEID, NO MSG PLEASE. 03672000
GETFST EQU * 03673000
L 1,IOLIST+28 GET FST 03674000
L 4,ITEM GET ITEM LENGTH 03675000
C 4,32(1) COMPARE WITH THAT OF NEW FILE 03676000
BL BADGETF BRANCH IF NEW ONE TOO LARGE 03677000
CLC IOLIST+26(2),26(1) CHECK STARTING LINE NO. 03678000
BH BADGETF1 BRANCH IF NOT ENOUGH LINES 03679000
MVC IOLIST+24(2),24(1) USE ACTUAL FILEMODE 03680000
MVC IOLIST+36(2),30(1) AND ACTUAL F OR V 03681000
LA 1,LINE USE LINE FOR INPUT 03682000
ST 1,IOLIST+28 STORE ITS ADDRESS IN PARM LIST 03683000
LA 1,L'LINE LENGTH OF LINE 03684000
ST 1,IOLIST+32 PUT IN RDBUF PARM LIST 03685000
TM SIGNAL,AUTOFLAG AUTOSAVE ACTIVE? @VA02879 03686000
BZ NOTAUT IF NOT GO @VA02879 03687000
NI SIGNAL,255-AUTOFLAG IF SO DISABLE TEMPORARILY @VA02879 03688000
OI SIGNAL,AUTOSVFL USE OTHER FLAG TO REMEMBER @VA02879 03689000
NOTAUT EQU * @VA02879 03690000
MVI SCRFLGS,WRTOPB REWRITE FULL DISPLAY @V2D3913 03691000
SPACE 03692000
DMSKEY NUCLEUS NEED NUCLEUS KEY FOR BALR CALLS @VM03083 03693000
GETFLOOP EQU * LOOP TO "GET" DESIRED FILE: @VM03083 03694000
EX 4,LINECLR CLEAR NECESSARY PART OF LINE 03695000
SSM DISABLE DISABLE INTERRUPTS @VA05354 03696000
LA R1,IOLIST POINT TO PARAMETER LIST, @VM03083 03697000
L R15,ARDBUF CALL 'RDBUF' @VM03083 03698000
BALR R14,R15 (VIA BALR FOR SPEED) @VM03083 03699000
SSM FE ENABLE INTERRUPTS @VA05354 03700000
BNZ GETFIN BRANCH IF ERROR (E.G. EOF) @VM03083 03701000
LA 1,LINE PARM FOR XWRITE 03702000
BAL 14,XWRITE INSERT THE LINE 03703000
BH GETFOFL BRANCH IF NO MORE ROOM 03704000
BL GETCLOS BRANCH IF CORE OVERFLOW (NB: R4 IS LOST) 03705000
L 0,SPARES LOAD NO. OF SPARES LEFT 03706000
STH 2,IOLIST+26 ENSURE WE'RE SET FOR SEQUENTIAL 03707000
BCT 3,GETFLOOP AND READ NEXT LINE 03708000
GETVER VERIFY @VA03087 03709000
SPACE 03710000
GETCLOS EQU * CLOSE THE FILE 03711000
SSM DISABLE DISABLE INTERRUPTS @VA05354 03712000
LA R1,IOLIST POINT TO PARAMETER LIST, @VM03083 03713000
L R15,AFINIS CALL 'FINIS' @VM03083 03714000
BALR R14,R15 (VIA BALR FOR SPEED) @VM03083 03715000
SSM FE ENABLE INTERRUPTS @VA05354 03716000
DMSKEY RESET RESTORE USER KEY AFTER BALR CALLS@VM03083 03717000
TM SIGNAL,AUTOSVFL ARE WE AUTOSAVING? @V200706 03718000
BZ NEXT IF NOT, GET NEXT COMMAND @V200706 03719000
NI SIGNAL,255-AUTOSVFL IF SO, RESTORE AUTO FLAGS @V200706 03720000
OI SIGNAL,AUTOFLAG @V200706 03721000
LA 14,NEXT SETUP RETURN ADDRESS @V200706 03722000
B AUTOCHEK AND PERFORM AN AUTOSAVE @V200706 03723000
SPACE 03724000
GETFIN EQU * ERROR FROM RDBUF 03725000
CH 15,=H'12' EOF? 03726000
BNE GETFERR BRANCH IF NOT (BAD NEWS) 03727000
VTYPE REACHEOF TYPE MESSAGE IF IN VER MODE 03728000
B GETVER @VA03087 03729000
SPACE 03730000
GETFERR EQU * BAD ERROR 03731000
WTYPE GETFERRM TYPE MESSAGE 03732000
B GETCLOS CLOSE FILE 03733000
SPACE 03734000
GETFOFL EQU * CORE OVERFLOW 03735000
WTYPE GETFOFMS TYPE MESSAGE 03736000
B GETCLOS CLOSE FILE 03737000
SPACE 03738000
NOGETF EQU * FILE NOT FOUND 03739000
WTYPE FILNTFND,,RETURN=INVREQX @V200713 03740000
SPACE 03741000
BADGETF EQU * EXCESSIVE ITEM LENGTH 03742000
WTYPE BADGETIT,,RETURN=INVREQX @V200713 03743000
SPACE 03744000
BADGETF1 EQU * NOT ENOUGH LINES 03745000
WTYPE GETFSHT,,RETURN=INVREQX @V200713 03746000
SPACE 2 03747000
REACHEOF DC C'EOF REACHED' 03748000
GETFERRM DC C'READ ERROR - GETFILE IS INCOMPLETE' 03749000
GETFOFMS DC C'GETFILE IS INCOMPLETE' 03750000
FILNTFND DC C'FILE NOT FOUND' 03751000
BADGETIT DC C'RECORD LENGTH OF FILE TOO LARGE' 03752000
GETFSHT DC C'GIVEN STARTING LINE IS BEYOND EOF' 03753000
EJECT 03754000
*********************************************************************** 03755000
* 03756000
* 'MODECHK' VALIDATES THE FILEMODE IN 'CMODE' PROVIDED BY THE 03757000
* CALLING ROUTINE. 03758000
* MODECHK SETS THE CONDITION CODE BEFORE RETURNING VIA R14. ANY 03759000
* ERROR DETECTED BY MODECHK WILL RESULT IN A NON-ZERO CONDITION 03760000
* CODE. 03761000
* 03762000
*********************************************************************** 03763000
MODECHK DS 0H 03764000
CLI CMODE,C'G' 03765000
BE CONT1 O.K. IF = 'G' 03766000
BL TESTA CHECK IF A - F 03767000
CLI CMODE,C'Y' 03768000
BE CONT1 03769000
CLI CMODE,C'Z' 03770000
BE CONT1 03771000
CLI CMODE,C'S' 03772000
BE CONT1 03773000
BCR 15,14 RETURN WITH ERROR CC 03774000
TESTA CLI CMODE,C'A' MODE LETTER < A 03775000
BNL CONT1 IF NOT, CONTINUE 03776000
CLI CMODE,C'*' IF SO, BETTER BE STAR... 03777000
BCR 7,14 ERROR RETURN IF NOT 03778000
CLI CMODE+1,C' ' BETTER HAVE BLANK NEXT.. 03779000
BCR 7,14 ERROR IF NOT 03780000
B CONT2 CONTINUE 03781000
CONT1 CLI CMODE+1,C'5' MODE NUMBER GT '5' 03782000
BCR 2,14 IF SO, ERROR RETURN 03783000
CLI CMODE+1,C'0' NUMBER LESS THAN ZERO? @V200713 03784000
BNL CONT2 IF NOT, SHE'S IN THE RANGE... 03785000
CLI CMODE+1,C' ' IF SO, COULD BE BLANK 03786000
BCR 7,14 ERROR IF NOT BLANK 03787000
MVC CMODE+1(1),FMODE+1 DEFAULT TO OLD MODE NUMBER @VA05071 03788000
CONT2 CLI CMODE+2,C' ' ANYTHING AFTER MODE NUMBER ? 03789000
BCR 7,14 IF SO, ERROR RETURN 03790000
SR 15,15 OTHERWISE, 15 = 0 03791000
LTR 15,15 CC = 0 03792000
BR 14 NORMAL RETURN... 03793000
EJECT 03794000
*********************************************************************** 03795000
* 03796000
* 'SAVE' AND 'FILE' WRITE OUT THE CONTENTS OF THE EDITOR, 03797000
* REPLACING THE EXISTING FILE (IF ANY). 03798000
* 03799000
*********************************************************************** 03800000
SPACE 03801000
SAVE DS 0H 03802000
OI SIGNAL,SVFL SET SAVE FLAG 03803000
B FILEA 03804000
SPACE 03805000
FILE EQU * 03806000
NI SIGNAL,255-SVFL SET SAVE FLAG OFF 03807000
NI SIGNAL,255-AUTOSVFL SET ALL SAVE FLAGS OFF @VA02449 03808000
SPACE 03809000
FILEA EQU * 03810000
CMS ALTLIST,PROG=ERASE,ERROR=IGNORE 03811000
MVC NEWNAME(18),FNAME INITIALIZE TO OLD NAME,TYPE AND MODE 03812000
OI SIGNAL,GETCAT SET GETCAT FLAG (CONCATENATE EDIT TOKS) 03824000
BAL 14,GET LOOK FOR FILE NAME 03825000
BZ FILE1 03826000
CLI XXXCWD,C'*' NO STARS ALLOWED P3123 03827000
BE INVREQ P3123 03828000
CLI XXXCWD,C'=' NO EQUALS ALLOWED @VM08629 03829000
BE INVREQ @VM08629 03830000
MVC NEWNAME(8),XXXCWD MOVE IN GIVEN NAME 03831000
OI SIGNAL,GETCAT 03832000
BAL 14,GET GET NEXT PARM 03833000
BZ FILE1 CONTINUE IF NOTHING THERE 03834000
CLI XXXCWD,C'*' NO STARS ALLOWED P3123 03835000
BE INVREQ P3123 03836000
CLI XXXCWD,C'=' NO EQUALS ALLOWED @VM08629 03837000
BE INVREQ @VM08629 03838000
MVC NEWTYPE(8),XXXCWD IT'S GOOD ENOUGH 03839000
OI SIGNAL,GETCAT NOW LET'S TRY THE MODE, IF GIVEN 03840000
BAL 14,GET GET THE PARM 03841000
BZ FILE1 CONTINUE IF NOTHING THERE 03842000
MVC CMODE(3),XXXCWD PROVIDE MODE TO CHECKER... 03843000
BAL 14,MODECHK AND GO TO HIM 03844000
BNZ MODERR INVALID MODE 03845000
CLI XXXCWD,C'*' IS IT STAR? 03846000
BE INVREQ SORRY, THAT'S A NO-NO TOO. 03847000
MVC NEWMODE(2),CMODE IT'S GOOD 03848000
BAL 14,PARMCHK CHECK NO MORE PARMS 03849000
SPACE 03850000
FILE1 EQU * 03851000
TM FLAG,RIGHT+SERSW LINEMODE RIGHT? 03852000
BNO FILE2A SKIP IF NOT 03853000
VTYPE SERPRESS TELL NOW - SUPRESS LATER 03854000
FILE2A EQU * 03855000
DMSKEY NUCLEUS NEED NUCLEUS KEY FOR BALR CALLS @VM03083 03856000
LA R1,IOLIST POINT TO PARAMETER LIST @VA08977 03856050
SSM DISABLE DISABLE INTERRUPTS @VA08977 03856100
MVC IOID(IDL18),NEWNAME MOVE IN NEW FILEID @VA08977 03856150
L R15,ASTATE STATE FUNCTION WILL @VA08977 03856200
BALR R14,R15 VALIDATE FILEID @VA08977 03856250
SSM FE ENABLE INTERRUPTS @VA08977 03856300
CLM R15,BIN0001,INVCHAR RETURN CODE 20? @VA08977 03856350
BE ALTERR YES,INVALID ID @VA08977 03856400
L 2,PTR1 LOAD TOP PTR 03857000
LTR 2,2 IS FILE NULL ? 03858000
BZ NULLFILE YES, TELL USER 03859000
SR 0,0 PUT ZERO HERE 03860000
MVC EDCT(2),COUNT TO FOOL 'INPUT' (IF SAVE REQ.) 03861000
MVC IOLIST+8(16),ALTLIST+8 SET WORK-FILE NAME,TYPE 03862000
MVC IOLIST+24(2),NEWMODE 03863000
STH 0,IOLIST+26 ENSURE WE'RE SET FOR SEQUENTIAL 03864000
MVC IOLIST+32(4),ITEM SET UP ITEM LENGTH IN PARM 03865000
MVC IOLIST+36(1),FV SET FV BYTE 03866000
ST 0,CARDNO INITIALIZE SEQUENCE NO. 03867000
MVC SERSAV(8),72+8(R2) SAVE COLS 73-80 FOR ERROR @VA04190 03868000
SPACE 03869000
FILE3 EQU * 03870000
LA 1,8(,2) POINT TO DATA AREA ON RECORD 03871000
ST 1,IOLIST+28 STORE IN PARM LIST 03872000
TM FLAG,SERSW IS SERIALIZATION REQUIRED 03873000
BZ FILE5 NO, SKIP THIS JAZZ 03874000
TM FLAG,RIGHT LINEMODE RIGHT? 03875000
BO FILE7 YES, SKIP SERIAL'N. 03876000
TM FLAG,SERNAME SERIALIZATION WITH NAME? 03877000
BZ FILE4A BRANCH IF NOT 03878000
CLI SEQNAME,C' ' CHECK FOR ALPHA SUPPLIED 03879000
BNE FILE4 BRANCH IF THEY ARE 03880000
MVC 72(3,1),NEWNAME USE CURRENT FILENAME 03881000
B FILE4A 03882000
FILE4 EQU * 03883000
MVC 72(3,1),SEQNAME MOVE IN ALPHA SEQUENCE 03884000
SPACE 03885000
FILE4A EQU * 03886000
L 0,CARDNO CARD NUMBER 03887000
A 0,CARDINCR INCREMENT IT 03888000
ST 0,CARDNO UPDATE COUNT 03889000
CVD 0,DECIMAL CONVERT TO PACKED 03890000
TM FLAG,SERNAME SERIALIZATION WITH NAME? 03891000
BO FILE4C BRANCH IF SO 03892000
UNPK 72(8,1),DECIMAL(8) 8 DIGIT SERIALIZATION 03893000
B FILE4D 03894000
FILE4C EQU * 03895000
UNPK 75(5,1),DECIMAL(8) 5 DIGIT SERIALIZATION 03896000
FILE4D EQU * 03897000
OI 79(1),C'0' CORRECT LOUSY SIGN 03898000
SPACE 03899000
FILE5 EQU * 03900000
CLI FV,C'V' V FORMAT FILE? 03901000
BNE FILE7 BRANCH IF NOT 03902000
CLC FTYPE,=CL8'VSBDATA' VSBASIC DATA CAN SPAN RCDS @VA04596 03903000
BE FILE7 TRAILING BLANKS MAY BE DATA @VA04596 03904000
LR 0,1 03905000
AH 1,ITEM+2 DELETE ALL TRAILING BLANKS 03906000
BCTR 1,0 POINT TO LAST BYTE 03907000
SPACE 03908000
FILE5A EQU * 03909000
CLI 0(1),C' ' 03910000
BNE FILE8 IF NOT BLANK, SEARCH IS OVER 03911000
BCT 1,FILE5A LOOK AGAIN 03912000
SPACE 03913000
FILE8 EQU * 03914000
SR 1,0 03915000
BNM FILE8A 03916000
SR 1,1 03917000
FILE8A EQU * 03918000
LA 1,1(,1) CORRECT LENGTH 03919000
ST 1,IOLIST+32 STORE IT IN PARAMETER LIST 03920000
SPACE 03921000
FILE7 EQU * 03922000
SSM DISABLE DISABLE INTERRUPTS @VA05354 03923000
LA R1,IOLIST POINT TO PARAMETER LIST, @VM03083 03924000
L R15,AWRBUF CALL 'WRBUF' @VM03083 03925000
BALR R14,R15 (VIA BALR FOR SPEED) @VM03083 03926000
SSM FE ENABLE INTERRUPTS @VA05354 03927000
BNZ FILERR BRANCH IF ERROR WRITING FILE @VM03083 03928000
L 2,0(,2) LOAD NEXT RECORD ADDRESS 03929000
LTR 2,2 ARE WE AT EOF 03930000
BNZ FILE3 NO, OUTPUT NEXT RECORD 03931000
BAL 4,UPDLINE UPDATE 'LINE' IF NECESSARY 03932000
SPACE 03933000
FILCLOS EQU * COME HERE FROM 'NULLFILE' V0263 03934000
SSM DISABLE DISABLE INTERRUPTS @VA05354 03935000
LA R1,IOLIST CLOSE TEMP FILE @VM03083 03936000
L R15,AFINIS CALL 'FINIS' @VM03083 03937000
BALR R14,R15 (VIA BALR FOR SPEED) @VM03083 03938000
SPACE 03939000
MVC IOLIST+8(8),NEWNAME MOVE IN NEW FILENAME 03940000
MVC IOLIST+16(8),NEWTYPE AND THE FILETYPE 03941000
TM TWITCH,NULL NULL FILE ? @VM08785 03942000
BNO ERASCLOS NO..BR @VM08785 03943000
MVC IOMODE(2),NEWMODE YES..INCLUDE FM @VM08785 03944000
ERASCLOS EQU * @VM08785 03945000
LA R1,IOLIST ERASE OLD FILE (IF ANY), @VM03083 03946000
L R15,AERASE CALL 'ERASE' @VM03083 03947000
BALR R14,R15 (VIA BALR FOR SPEED) @VM03083 03948000
DMSKEY RESET RESTORE USER KEY AFTER BALR CALLS@VM03083 03950000
SPACE 03951000
TM TWITCH,NULL NULL FILE? V0263 03952000
BZ FILREN NO, RENAME AS USUAL V0263 03953000
STCM R15,1,CMODE GET LAST BYTE OF RETURN CODE @VA04190 03954000
TM CMODE,X'0C' CHECK FOR FILEMODE ERRORS @VA04190 03955000
BNM FILEND NO ... SKIP RENAME @VA04190 03956000
SSM FE ENABLE INTERRUPTS @VA07669 03956100
NI TWITCH,255-NULL TURN OFF NULL FLAG @VA04190 03957000
B MODERR AND GO TYPE ERROR MSG @VA04190 03958000
FILREN EQU * V0263 03959000
MVC ALTLIST+32(16),IOLIST+8 SET UP RENAME LIST 03960000
MVC ALTLIST+24(2),NEWMODE 03961000
MVC ALTLIST+48(2),NEWMODE 03962000
CMS ALTLIST,PROG=RENAME,ERROR=ALTERR RENAME WORK @VA00984 03963000
TM FLAG,SERSW SERIALIZATION DONE? @VA04190 03964000
BNO FILEND NO ... BR @VA04190 03965000
TM FLAG,RIGHT LINEMODE RIGHT? @VA04190 03966000
BO FILEND YES ... BR @VA04190 03967000
CLC VERCOL2(2),=H'80' VERIFY TO 80? @VA04190 03968000
BL FILEND NO ... BR @VA04190 03969000
MVI SCRFLGS,WRTOPB FORCE FULL DISPLAY REWRITE @VA04190 03970000
SPACE 03971000
FILEND EQU * 03972000
SSM FE ENABLE INTERRUPTS @VA07669 03972100
TM SIGNAL,SVFL+AUTOSVFL ANY SAVE BEING DONE? @V200706 03973000
BZ EDEXIT1 NO, MUST BE 'FILE' @V200706 03974000
LA 2,PEDIT LOAD RETURN ADDRESS @VA04190 03975000
TM SIGNAL,AUTOSVFL+AUTOFLAG ANY 'AUTO' ACTIVE? @V200706 03976000
BZ CKNULL NO, 'SAVE' W/O AUTO @VA04190 03977000
BNO ZERAUTO 'SAVE' WITH AUTO ACTIVE @VA04190 03978000
LA 2,SAVRET WE'VE COME A LONG WAY, BABY @V200706 03979000
NI SIGNAL,255-AUTOSVFL MUST BE AUTO SAVE @V200706 03980000
ZERAUTO EQU * CLEAR THE CURRENT LINE COUNT@V200706 03981000
XR 1,1 @V200706 03982000
STH 1,AUTOCURR @V200706 03983000
VTYPE AUTOMSG TELL USER IT'S SAVED @V200706 03984000
MVI SCRFLGS,WRTOPB FORCE FULL DISPLAY REWRITE @V2D3913 03985000
SPACE 03986000
CKNULL EQU * @VA04190 03987000
TM TWITCH,NULL CK FOR NULL FILE @VA04190 03988000
BZR R2 NO ... RETURN @VA04190 03989000
WTYPE NULLMES TELL USER FILE EMPTY @VA04190 03990000
NI TWITCH,255-NULL TURN OFF NULL FLAG @VA04190 03991000
TM FLAG2,TUBE DISPLAY TERMINAL? @VA04190 03992000
BO PEDIT1 YES ... GET NEXT REQUEST @VA04190 03993000
BR R2 NO ... GO TYPE 'EDIT' @VA04190 03994000
SPACE 03995000
NULLFILE EQU * FILE IS EMPTY 03996000
OI TWITCH,NULL SIGNAL NULL FILE V0263 03997000
B FILCLOS MAKE SURE OLD FILE IS ERASED V0263 03998000
SPACE 03999000
FILERR EQU * ERROR FROM WRBUF 04000000
TM FLAG,SERSW HAVE WE BEEN SERIALIZING? 04001000
BZ *+10 SKIP IF NOT 04002000
MVC 8+72(8,2),SERSAV RESTORE COLS 73-80 04003000
BAL 4,UPDLINE UPDATE 'LINE' IF NECESSARY 04004000
CH 15,=H'13' IS IT ERROR 13 (DISK FULL)? 04005000
BE DISKFUL BRANCH IF SO 04006000
LR R14,R15 IF NOT 13, REMEMBER ERROR CODE, @VM03083 04007000
DMSKEY RESET RESTORE USER KEY AFTER BALR CALLS@VM03083 04008000
C 2,PTR1 FIRST LINE? 04009000
BNE ERR105S BRANCH IF NOT (FATAL ERROR) 04010000
CH R14,=H'10' TOO MANY FILES ? @VM03083 04011000
BE DISKFUL1 BRANCH IF SO 04012000
MODERR BAL 4,KTCLR CLEAR THE 'KT' FLAG 04013000
MVC FILEMS+12(4),=CL4'MODE' PATCH THE MESSAGE 04014000
WTYPE FILEMS,26 TYPE SOME GOOD ADVICE @V305614 04015000
B SVFLERR 04016000
SPACE 04017000
DISKFUL EQU * 04018000
SSM DISABLE DISABLE INTERRUPTS @VA05354 04019000
LA R1,IOLIST ERASE WORK-FILE, @VM03083 04020000
L R15,AERASE CALL 'ERASE' @VM03083 04021000
BALR R14,R15 (VIA BALR FOR SPEED) @VM03083 04022000
SSM FE ENABLE INTERRUPTS @VA05354 04023000
DMSKEY RESET RESTORE USER KEY AFTER BALR CALLS@VM03083 04024000
OI SCRFLGS,WRMSGB REWRITE MESSAGE LINE @V2D3913 04025000
TM FLAG,SERSW ARE WE DOING SERIALIZATION? 04026000
BZ DISKFUL1 BRANCH IF NOT 04027000
WTYPE SERMS TYPE A WARNING 04028000
OI SCRFLG2,MOREB MAKE SURE ALL DISPLAYED @VM08703 04029000
DISKFUL1 EQU * 04030000
BAL 4,KTCLR CLEAR THE 'KT' FLAG 04031000
WTYPE DISKMS TYPE SOME GOOD ADVICE 04032000
B SVFLERR 04033000
SPACE 04034000
ALTERR EQU * ERROR FROM RENAME 04035000
SSM FE ENABLE INTERRUPTS @VA07669 04035100
DMSKEY RESET RESET KEY @VA08977
BAL 4,KTCLR CLEAR THE 'KT' FLAG 04036000
MVC FILEMS+12(4),=CL4'NAME' PATCH THE MESSAGE 04037000
WTYPE FILEMS,26 SOME ADVICE (MAY NOT BE GOOD) @V305614 04038000
SPACE 04039000
SVFLERR EQU * ERROR RETURN FROM SAVE AND FILE 04040000
NI SIGNAL,255-AUTOSVFL INCASE 'AUTO' ACTIVE @V200706 04041000
OI SCRFLG2,MOREB MAKES SURE SEES ERROR MSG @VA04190 04042000
OI SCRFLGS,WRTOPB ALONG WITH SCREEN @VA04190 04043000
BAL 4,STACKCLR CLEAR THE STACK, SINCE HE EXPECTED TO GO 04044000
NI SCRFLG2,255-MOREB TURN OFF MORE FLAG @VA04190 04045000
TM FLAG2,TUBE GRAPHICS? @VA03883 04046000
BNO MPEDIT NO ... GO TYPE 'EDIT' @VA04190 04047000
TM FLAG2,INMODE INPUT MODE? @VA04190 04048000
BO TLERR YES ... GO CHG STATUS TO 'EDIT' @VA04190 04049000
B NEXT ELSE, GET ANOTHER REQUEST @VA04190 04050000
SPACE 1 04051000
FE DC X'FE' @VM03120 04052000
DISABLE DC X'00' DISABLE ALL CHANNELS @VA06347 04053000
INVCHAR DC X'14' RETURN CODE 20 @VA06347 04054000
IDL18 EQU 18 FILEID LENGTH = 18 BYTES @VA06347 04055000
EJECT 04056000
* 04057000
************** 04058000
* 04059000
* SUBROUTINE TO UPDATE 'LINE' IF NECESSARY AFTER SERIALIZING. 04060000
* CALLED ONLY FROM 'FILE' (AND 'SAVE'), THUS: BAL 4,UPDLINE. 04061000
* USES R1. 04062000
* 04063000
************** 04064000
SPACE 04065000
UPDLINE DS 0H 04066000
TM FLAG,SERSW HAVE WE BEEN SERIALIZING? 04067000
BCR 8,4 RETURN PRONTO IF NOT 04068000
TM TWITCH,TOPSW ARE WE AT THE TOP OF THE FILE? 04069000
BCR 1,4 RETURN IF SO 04070000
L 1,PTR2 A(CURRENT LINE) 04071000
MVC LINE+72(8),8+72(1) UPDATE COLS 73-80 OF 'LINE' 04072000
BR 4 RETURN 04073000
SPACE 04074000
* 04075000
************** 04076000
* 04077000
* DATA FOR 'FILE' AND 'SAVE'... 04078000
* 04079000
************** 04080000
SPACE 04081000
NULLMES DC C'FILE IS EMPTY' 04082000
AUTOMSG DC C'_SAVED' @V200706 04083000
SPACE 04084000
SERPRESS DC C'RESERIALIZATION SUPRESSED' 04085000
SERMS DC C'SERIALIZATION IS INCOMPLETE' 04086000
DISKMS DC C'SET NEW FILEMODE, OR ENTER CMS SUBSET AND CLEAR SOME SPACE' 04087000
EJECT 04088000
*********************************************************************** 04089000
* 04090000
* TERMINAL ERRORS ... 04091000
* 04092000
*********************************************************************** 04093000
SPACE 04094000
DS 0H 04095000
SPACE 04096000
ERR105S LR R2,R14 PUT WRBUF ERROR RETURN IN R2, @VM03083 04097000
DMSERR NUM=105,LET=S,SUB=(DEC,(2),CHAR8A,IOID),TEXT='ERROR ''.*04098000
..'' WRITING FILE ''....................'' ON DISK', *04099000
MF=(E,'SYS') @V305614 04100000
IOERR LA R2,100 RETURN CODE = 100 @VM08823 04101000
CMS IOLIST,PROG=FINIS,ERROR=IGNORE 04102000
B EDEXIT2 GO 'FREEMAIN' IF NEEDED, THEN EXIT. JS 04103000
EJECT 04104000
*********************************************************************** 04105000
* 04106000
* 'CORFULL' AND 'CORBUST' ARE ERROR MESSAGE ROUTINES WHICH 04107000
* ARE BRANCHED TO FROM 'XWRITE' WHEN THE AVAILABLE CORE 04108000
* IS FULL. THEY ARE PUT HERE (RATHER THAN WITH 'XWRITE') 04109000
* SO THAT THEY DO NOT OCCUPY ROOM IN THE FIRST PAGE. THEY 04110000
* RETURN TO 'XWRITE'. 04111000
* 04112000
*********************************************************************** 04113000
SPACE 04114000
CORFULL DS 0H THIS WAS THE LAST LINE WE CAN FIT IN CORE 04115000
WTYPE CORFLMS WARN HIM THAT IT'S FULL 04116000
LA 15,1 ERROR CODE 1 04117000
LTR 15,15 AND SET CONDITION CODE 04118000
B XWRITEX RETURN TO 'XWRITE' 04119000
SPACE 04120000
CORBUST EQU * ATTEMPT TO WRITE AFTER CORE FULL WARNING 04121000
BAL 4,KTCLR CLEAR THE 'KT' FLAG, IF SET 04122000
BAL 4,STACKCLR CLEAR STACK @VA04190 04123000
WTYPE NOROOM TELL HIM NO ROOM @VA04190 04124000
SR 15,15 04125000
BCTR 15,0 SET ERROR CODE -VE 04126000
LTR 15,15 SET CONDITION CODE 04127000
B XWRITEX RETURN TO 'XWRITE' 04128000
SPACE 2 04129000
CORFLMS DC C'AVAILABLE STORAGE IS NOW FULL' 04130000
NOROOM DC C'NO ROOM' 04131000
EJECT 04132000
*********************************************************************** 04133000
* 04134000
* TIDY UP AND RETURN TO CALLER 04135000
* 04136000
*********************************************************************** 04137000
SPACE 04138000
EDEXIT1 DS 0H 04139000
SPACE 04140000
EDEXIT2 EQU * 04141000
SPACE 04142000
LTR 2,2 WHAT IS IT? 04143000
BZ *+8 SKIP IF ZERO 04144000
EDEXIT4 BAL 4,STACKCLR CLEAR STACKED READS 04145000
LTR R15,R2 PUT RETURN CODE IN R15 @VM08823 04146000
BNZ EXREST GET OUT @V2D3914 04147000
SPACE 1 04148000
TM FLAG2,TUBE DISPLAY TERMINAL ? @VM01040 04149000
BZ EXREST NO...BR @V2D3914 04150000
MVI SCRFLG2,CANCB CAUSE TUBE CANCEL OP @V200714 04151000
BAL R14,WRTYPEX @V2D3913 04152000
EXREST L 14,EDRET RESTORE RETURN ADDRESS @V200714 04153000
SR R4,R4 R4=0 MEANS DOSFLAGS IS OK @VM03083 04154000
TM DOSFLAGS,DOSSVC INTERNAL SVC-BIT SET ? @VM03083 04155000
BZ DOSFOK1 IF 0 WE'RE OK @VM03083 04156000
IC R4,DOSFLAGS IF NOT 0, REMEMBER DOSFLAGS, @VM03083 04157000
DMSEXS NI,DOSFLAGS,255-DOSSVC AND RESET FLAGBIT @VM03083 04158000
DOSFOK1 LM R0,R1,FREELEN GET FREE STORAGE POINTERS @VM03083 04159000
FREEMAIN R,LV=(0),A=(1) RETURN THE USER STORAGE @VM03083 04160000
LTR R4,R4 WAS DOSFLAGS OK BEFORE ? @VM03083 04161000
BZ DOSFOK2 IF YES WE'RE OK @VM03083 04162000
DMSEXS STC,R4,DOSFLAGS IF NOT, RESTORE IT AS IT WAS @VM03083 04163000
DOSFOK2 DMSKEY RESET TURN OFF USER KEY, @VM03083 04164000
DMSEXS OI,MISFLAGS,RELPAGES SET RELPAGE SW ON @VA05711 04165000
LTR R15,R2 MAKE SURE RETURN-CODE IN R15, @VM03083 04166000
BR 14 RETURN. 04167000
EJECT 04168000
*********************************************************************** 04169000
* 04170000
* RENUM SUBCOMMAND ALLOWS USER TO RENUMBER HIS VSBASIC 04171000
* PROGRAM, CORRELATING ALL LINE NUMBER REFERENCES TO 04172000
* THE NEW LINE NUMBERS PRODUCED FROM THE STRTNO AND 04173000
* INCRNO PARAMETERS. 04174000
* FREEFORT FILES ARE RENUMBERED IN COLS 1 THROUGH 8 04175000
* USING THE STRTNO AND INCRNO PARAMETERS TO CREATE 04176000
* THE NEW LINE NUMBERS. 04177000
* 04178000
*********************************************************************** 04179000
SPACE 04180000
RENUM DS 0H @V242801 04181000
LA R14,10 GET DEFAULT VALUE @V242801 04182000
ST R14,STRTNO SAVE AS STARTING NO. @V242801 04183000
ST R14,INCRNO SAVE AS INCREMENT VALUE @V242801 04184000
BAL R14,NUM GET FIRST PARAM @V242801 04185000
B INVREQ INVALID REQUEST EXIT @V242801 04186000
BM RENUM2 NONE SPECIFIED..USE DEFAULTS @V242801 04187000
BZ INVREQ ZERO NOT ALLOWED @V2D3914 04188000
ST R0,STRTNO SAVE AS STARTING NUMBER @V242801 04189000
ST R0,INCRNO AND AS INCREMENT ALSO @V242801 04190000
BAL R14,NUM CHECK INCREMENT @V242801 04191000
B INVREQ INVALID REQUEST EXIT @V242801 04192000
BM RENUM2 LOOKS LIKE NO INCREMENT @V242801 04193000
BZ INVREQ ZERO NOT ALLOWED @V2D3914 04194000
ST R0,INCRNO SAVE AS INCREMENT VALUE @V242801 04195000
BAL R14,PARMCHK NO MORE ALLOWED @V242801 04196000
RENUM2 L R14,PTR1 GET TOP OF FILE @V242801 04197000
ST R14,AINCORE SAVE AS INCORE ADDRESS @V242801 04198000
L R14,ITEM GET RECORD LENGTH @V242801 04199000
ST R14,FSIZE SAVE AS ITEM LENGTH @V242801 04200000
MVC RPLIST(12),FTYPE SET UP RENUM FILEID @V242801 04201000
LA R1,RPLIST-8 GET RENUM PLIST @V242801 04202000
SVC 202 CALL RENUM @V242801 04203000
DC AL4(RENUME) ERROR RETURN @V242801 04204000
B REFRESH @V2D3913 04205000
EJECT 04206000
RENUME CH R15,=H'-3' IS IT NOT FOUND ERROR ? @V242801 04207000
BNE RENUM4 NO, CHECK FOR I/O ERROR @V242801 04208000
WTYPE NORNE,,RETURN=NEXT @V242801 04209000
RENUM4 CH R15,=H'100' IS IT I/O ERROR ? @V242801 04210000
BE EDEXIT2 YES, FREEMAIN AND GET OUT @V242801 04211000
CH R15,=H'13' IS IT DISK FULL ? @V242801 04212000
BE DISKFUL1 YES, GO TYPE MSG @V242801 04213000
LM R0,R1,0(R15) GET MSG LEN AND ADDR @V242801 04214000
LA R14,NEXT GET RETURN ADDRESS @V242801 04215000
B WRTYPE GO TYPE MSG @V242801 04216000
NORNE DC C'RENUM MODULE NOT FOUND' @V242801 04217000
EJECT 04218000
******************************************************** 04219000
* 04220000
* SCROLL SUBCOMMAND ALLOWS USER TO MOVE THE CURRENT 04221000
* LINE POINTER IN EITHER DIRECTION BY ENOUGH TO FILL A 04222000
* NEW DISPLAY PAGE. 04223000
* 04224000
****************************************************** 04225000
SPACE 1 04226000
SCROLL EQU * @V200714 04227000
TM FLAG2,TUBE IN DISPLAY MODE ? @V2D3914 04228000
BNO INVREQ IF NOT, AN INVALID COMMAND @V2D3914 04229000
MVI SCRFLGS,WRTOPB WRITE FULL SCREEN @V2D3914 04230000
LA R5,10 GUESS NUMBER OF LINES @V2D3913 04231000
LA R3,80 DO WE NEED MORE THAN ONE @V200714 04232000
CH R3,VERLEN DISPLAY LINE PER RECORD @V2D3914 04233000
BNL SNGL NO..BR @V200714 04234000
SR R5,R5 REDUCE THE COUNT OF LINES @V2D3913 04235000
SNGL LA R5,10(,R5) ADD 10 TO THE LINE COUNT @V2D3913 04236000
BAL R14,NUM DID WE GET A NUMBER ? @V200714 04237000
BAL R14,STARCHK LOOK FOR ASTERISK @V2D3913 04238000
LTR R3,R0 SAVE NUMBER SPECIFIED @V200714 04239000
BZ NEXT IF ZERO..DO NOTHING @V200714 04240000
BAL R14,PARMCHK NO MORE ARGS ALLOWED @V200714 04241000
BAL R14,EORCHK CHECK THE RANGE @V2D3913 04242000
B ENDRANGE OBVIOUSLY DONE, IN THIS CASE. @V2D3913 04243000
B FWD1 DONT CAUSE MORE STATUS ON 1ST SCR@V200714 04244000
SCRFWD EQU * LOOP FOR FORWARD SCROLL @V200714 04245000
MVI SCRFLG2,MOREB CAUSE MORE STATUS @V2D3913 04246000
FWD1 LR R4,R5 REFRESH THE COUNT @V2D3913 04247000
FLOOP BAL R14,XNEXT LOCATE THE LINE @V2D3913 04248000
TM TWITCH,EOF+TOPSW IS IT ENDRANGE? @V2D3913 04249000
BNZ ENDRG IF SO, WHY BOTHER. @V2D3914 04250000
BCT R4,FLOOP ENOUGH TO REFILL BUFFER @V200714 04251000
ENDRG BAL R14,WRTYPEX REWRITE DISPLAY @V2D3913 04252000
NOWRT TM TWITCH,EOF+TOPSW ENDRANGE? @V2D3913 04253000
BNZ NEXT ALL DONE. @V2D3913 04254000
BCT R3,SCRFWD DO IT N TIMES @V200714 04255000
B NEXT @V200714 04256000
EJECT 04257000
*********************************************************************** 04258000
* 04259000
* EQUS. 04260000
* 04261000
*********************************************************************** 04262000
SPACE 04263000
TAB EQU X'05' TAB CHARACTER 04264000
BACKSPAC EQU X'16' BACKSPACE 04265000
SPACE 04266000
* BITS FOR FLAG ... 04267000
* (DON'T ALTER THESE WITHOUT TELLING EDFILES ABOUT IT) 04268000
SPACE 04269000
CAN EQU X'01' CANONICALIZATION IS REQUIRED 04270000
IMNOT EQU X'02' LINE IMAGE (OR CANONLZTN) SUPPRESSED 04271000
SERSW EQU X'04' SERIALIZATION IS REQUIRED 04272000
SERNAME EQU X'08' SERIALIZATION IS TO BE WITH 3-CHAR NAME 04273000
LINE8 EQU X'10' LINENUMBERS ARE 8 DIGITS LONG @V1D1613 04274000
ZEROPAD EQU X'20' LINENUMBERS ARE ZERO-FILLED @V1D1613 04275000
LEFT EQU X'40' LINEMODE LEFT IF ON 04276000
RIGHT EQU X'80' LINEMODE RIGHT IF ON 04277000
SPACE 1 04278000
* BITS FOR FLAG2... 04279000
VER EQU X'01' VERIFY IS SET @V1D1613 04280000
LONGSW EQU X'02' LONG IS SET @V1D1613 04281000
TUBE EQU X'04' CONSOLE IS DISPLAY TYPE @V200714 04282000
NUFILE EQU X'08' NEW FILE @V200714 04283000
INMODE EQU X'10' INPUT MODE IN EFFECT @V200714 04284000
REMOTE EQU X'20' REMOTE DISPLAY TERMINAL @V2D3914 04285000
SWITCH EQU X'40' INPUT REMINDER TO RESET MODE @V2D3914 04286000
NODISP EQU X'80' NODISPLAY OPTION IN EFFECT @V2D3914 04287000
SPACE 1 04288000
* BITS FOR TWITCH... 04289000
SPACE 04290000
TOPSW EQU X'01' WE ARE AT TOP OF FILE 04291000
EOF EQU X'02' EOF CONDITION IS RAISED 04292000
NULL EQU X'04' FILE IS EMPTY V0263 04293000
UPWARD EQU X'08' @V2D3913 04294000
VEROVER EQU X'10' @V2D3913 04295000
TRUNC EQU X'20' TRUNCATION HAS OCCURRED 04296000
SAVOVER EQU X'40' OVERRIDE AUTOSAVE @V2D3914 04297000
* EQU X'80' 04298000
SPACE 04299000
* BITS FOR SCRFLGS ... 04300000
SPACE 1 04301000
WRCLUPB EQU X'02' WRITE FROM CL UP @V2D3913 04302000
WRMSGB EQU X'10' WRITE DISPLAY MESSAGE AREA @V2D3913 04303000
WRCLDNB EQU X'20' WRITE FROM CL DOWN @V200714 04304000
WRCLB EQU X'40' WRITE CL ONLY @V200714 04305000
WRSTATB EQU X'80' WRITE STATUS AREA @V2D3913 04306000
WRFULLB EQU WRCLDNB+WRCLUPB WRITE ALL TEXT @V2D3913 04307000
WRTOPB EQU WRSTATB+WRFULLB WRITE COMPLETE DISPLAY @V2D3913 04308000
SPACE 1 04309000
* BITS FOR SCRFLG2 ... 04310000
SPACE 1 04311000
MOREB EQU X'80' CAUSE MORE STATUS @V200714 04312000
CANCB EQU X'40' CAUSE CANCEL OP @V200714 04313000
WRCLINB EQU X'08' WRITE CL INTO INPUT AREA @V2D3913 04314000
CMDINB EQU X'04' WRITE LAST COMMAND TO INPUT AREA @V2D3913 04315000
SPACE 1 04316000
* BITS FOR SIGNAL ... 04317000
SPACE 04318000
GETCAT EQU X'01' TELLS GET TO CONCATENATE TOKS UNTIL BLANK 04319000
HEXSW EQU X'02' TELLS GET TO LOOK FOR HEXADECIMAL TOKEN 04320000
QUOD EQU X'04' LAST REQUEST WAS ? OR " 04321000
REPL EQU X'08' TRICKY REPLACE MODE (1ST LINE AFTER 'R') 04322000
OVER EQU X'10' REQUEST IS 'OVERLAY' 04323000
SVFL EQU X'20' REQUEST IS 'SAVE' 04324000
AUTOFLAG EQU X'40' AUTO. SAVE ACTIVE @V200706 04325000
AUTOSVFL EQU X'80' AUTO. SAVE BEING EXECUTED @V200706 04326000
SPACE 04327000
* BITS FOR GETFLAG ... 04328000
SPACE 04329000
ALPHA EQU X'01' TOKEN IS ALPHABETIC 04330000
NONALNUM EQU X'02' TOKEN IS NON-ALPHANUMERIC 04331000
SPACE 04332000
* BITS FOR CHNGFLAG ... 04333000
SPACE 04334000
NULLSW1 EQU X'01' STRING1 IS NULL 04335000
NULLSW2 EQU X'02' STRING2 IS NULL 04336000
DTYPE EQU X'04' DISPLAY TYPE CHANGE BIT @VA03027 04337000
GLOBSW EQU X'08' GLOBAL OPTION IS GIVEN 04338000
* EQU X'10' 04339000
CHNGSW EQU X'20' LINE HAS BEEN CHANGED 04340000
FLDFND EQU X'40' MATCHING FIELD HAS BEEN FOUND 04341000
* EQU X'80' 04342000
SPACE 04343000
* BITS FOR XYFLAG 04344000
SPACE 04345000
XACT EQU X'01' 'X' IS ACTIVE 04346000
YACT EQU X'02' 'Y' IS ACTIVE 04347000
SPACE 04347100
* BITS FOR UTILFLAG ... 04347200
SPACE 04347300
CLGT80B EQU X'01' LENGTH > 80 BYTES @VA08152 04347400
MSG EQU X'02' MESSAGE IN BUFFER @VA08152 04347500
TWOLINES EQU X'04' LENGTH > 80 BYTES @VA08152 04347600
LINSEQ EQU X'08' NO SPACE FOR LINEMODE INPUT @VA08152 04347700
SPACE 2 04348000
* MASKS FOR CLM INSTRUCTION 04349000
BIN1000 EQU B'1000' @V305066 04350000
BIN1100 EQU B'1100' @V305066 04351000
BIN0001 EQU B'0001' MASK FOR BYTE 3 @VA06347 04352000
BIN0100 EQU B'0100' @VA09296 04352100
SPACE 04353000
EDCB @V305614 04354000
EJECT 04355000
NUCON @V200714 04356000
DEVTAB , @V305014 04357000
REGEQU @V200714 04358000
DMSEDI CSECT @V200714 04359000
EJECT 04360000
* 04361000
LTORG 04362000
SPACE 2 04363000
END 04364000