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) 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 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 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