UPD TITLE 'DMSUPD (CMS) VM/370 - RELEASE 6' 00001000 SPACE 2 00002000 * 00003000 * MACROS FOR INTERFACE WITH CMS V1.0 AND VM/370 00004000 * 00005000 SPACE 00006000 MACRO 00007000 &NAME CMS &PLIST,&ERR,&BUFF=,&CMD= 00008000 AIF ('&NAME' EQ '').SKPNM 00009000 &NAME EQU * - CALL A CMS FUNCTION 00010000 .SKPNM AIF ('&BUFF' EQ '').SKPBF 00011000 LA R1,&BUFF - BUFFER ADDRESS 00012000 ST R1,&PLIST+28 - RESET BUFFER ADDRESS 00013000 .SKPBF LA R1,&PLIST - PARM LIST ADDRESS 00014000 AIF ('&CMD' EQ '').SKCMD 00015000 MVC 0(8,R1),=CL8'&CMD' - FILL IN COMMAND NAME 00016000 .SKCMD SVC 202 - CALL TO CMS FUNCTION 00017000 AIF ('&ERR' EQ '').NOERR 00018000 DC AL4(&ERR) - ERROR RETURN ADDRESS 00019000 MEXIT 00020000 .NOERR DC AL4(*+4) - IGNORE ANY ERROR RETURN 00021000 MEND 00022000 SPACE 2 00023000 MACRO 00024000 WARN &N 00025000 CLI RC,&N COMPARE WITH OLD RC 00026000 BH *+8 SKIP IF OLD IS HIGHER 00027000 MVI RC,&N SET HIGHER RETURN CODE 00028000 MEND 00029000 SPACE 3 00030000 MACRO 00031000 UPITEM &F 00032000 LH R1,ITEM+&F GET OLD ITEM NUMBER FROM FSCB 00033000 LA R1,1(,R1) INCREMENT IT 00034000 STH R1,ITEM+&F STORE NEW ITEM NUMBER 00035000 MEND 00036000 EJECT 00037000 MACRO 00038000 &NAME LOG &TEXT,&KEY,&CUTE 00039000 LCLA &NM 00040000 AIF ('&NAME' EQ '').SKPNM 00041000 &NAME EQU * - WRITE A RECORD TO LOGFILE 00042000 .SKPNM BAL R1,CLRLOGB - CLEAR LOGFILE BUFFER 00043000 AIF ('&TEXT'(1,1) NE '''').LABL 00044000 &NM SETA K'&TEXT-2 00045000 LA R1,=C&TEXT 00046000 MVC LOGBUFF(&NM),0(R1) - MOVE MSG TO BUFFER 00047000 .DOIT ANOP 00048000 BAL R15,LOGIT 00049000 MEXIT 00050000 .LABL AIF ('&KEY' NE 'ERR').CCTL 00051000 MVC LOGBUFF(80),&TEXT - MOVE CARD TO BUFFER 00052000 AGO .DOIT 00053000 .CCTL AIF ('&KEY' NE 'CTL').CCUE 00054000 MVC LOGBUFF+8(72),&TEXT - MOVE CARD TO BUFFER 00055000 AGO .DOIT 00056000 .CCUE AIF ('&KEY' NE 'CUE').COL8 00057000 &NM SETA K'&CUTE-2 00058000 MVC LOGBUFF(&NM),=C&CUTE - CUEING MESSAGE 00059000 .COL8 MVC LOGBUFF+16(80),&TEXT - MOVE CARD TO BUFFER 00060000 AGO .DOIT 00061000 MEND 00062000 EJECT 00063000 MACRO 00064000 &LABEL OPT &N,&MIN,&CKAD,&DO,&ARG 00065000 &LABEL DC CL8'&N' - OPTION NAME 00066000 DC AL2(&MIN-1) - (MINIMUM # LETTERS) - 1 00067000 DC AL2(&CKAD-CKADS) - CHECK ADDRESS 00068000 AIF ('&DO' EQ 'ON').ON 00069000 AIF ('&DO' EQ 'OFF').OFF 00070000 AIF ('&DO' EQ 'GO').GO 00071000 MNOTE 8,'ILLEGAL PARAMETER ''&DO''' 00072000 MEXIT 00073000 .ON AIF ('&N' EQ 'STOR').ON2 00074000 OI GLOBALS,&ARG - TURN ON FLAG 00075000 SPACE 00076000 MEXIT 00077000 .ON2 OI UPDFLAG,&ARG - TURN ON FLAG 00078000 SPACE 00079000 MEXIT 00080000 .OFF AIF ('&N' EQ 'NOSTOR').OFF2 00081000 NI GLOBALS,X'FF'-&ARG - TURN OFF FLAG 00082000 SPACE 00083000 MEXIT 00084000 .OFF2 NI UPDFLAG,X'FF'-&ARG - TURN OFF FLAG 00085000 SPACE 00086000 MEXIT 00087000 .GO B &ARG - BRANCH TO OPTION HANDLER 00088000 SPACE 00089000 MEXIT 00090000 MEND 00091000 EJECT 00092000 *. 00093000 * MODULE NAME - 00094000 * 00095000 * DMSUPD (UPDATE COMMAND) 00096000 * 00097000 * FUNCTION - 00098000 * 00099000 * CMS 'UPDATE' COMMAND -- UPDATE SOURCE FILES ACCORDING 00100000 * TO SPECIFICATIONS IN UPDATE FILES. MULTIPLE UPDATES 00101000 * MAY BE MADE, ACCORDING TO SPECIFICATIONS IN CONTROL 00102000 * FILES WHICH DESIGNATE THE UPDATE FILES. 00103000 * 00104000 * ATTRIBUTES - 00105000 * 00106000 * DISK RESIDENT, NON-RE-ENTRANT, NON-REUSABLE 00107000 * 00108000 * ENTRY POINTS - 00109000 * 00110000 * DMSUPD 00111000 * 00112000 * ENTRY CONDITIONS - 00113000 * 00114000 * LA R1,PLIST 00115000 * SVC 202 00116000 * 00117000 * WHERE THE PLIST HAS THE FORMAT DESCRIBED IN THE COMMAND 00118000 * LANGUAGE USER'S GUIDE 00119000 * 00120000 * EXIT CONDITIONS - 00121000 * 00122000 * NORMAL - 00123000 * RETURN CODE 0 IN REGISTER 15 00124000 * 00125000 * ERROR - 00126000 * RETURN CODE IN REGISTER 15 00127000 * 4 SEQUENCE ERROR IN INPUT SOURCE FILE 00128000 * 8 SEQUENCE ERROR INTRODUCED INTO OUTPUT FILE 00129000 * 12 OTHER NON-FATAL UPDATING ERROR (SUCH AS INVALID 00130000 * UPDATE FILE CONTROL CARD) 00131000 * 20-36 FATAL ERROR, CAUSING UPDATE TO ABORT (SUCH AS 00132000 * INVALID OPTION, MISSING FILENAME, INVALID CONTROL 00133000 * FILE, ETC.) 00134000 * 40 NO UPDATE FILES WERE FOUND WITH 'CTL' OPTION 00135000 * 100 I/O ERROR READING OR WRITING 00136000 * 00137000 * CALLS TO OTHER ROUTINES - 00138000 * 00139000 * ADTLKP LOOK UP ACTIVE DISK TABLE 00140000 * ADTLKW LOOK UP READ/WRITE ACTIVE DISK TABLE 00141000 * FSREAD READ RECORDS FROM INPUT FILES 00142000 * FSWRITE WRITE RECORDS TO OUTPUT FILES 00143000 * FSCLOSE CLOSE INPUT AND OUTPUT FILES 00144000 * FSERASE ERASE OLD COPIES OF OUTPUT FILES 00145000 * PRINTL PRINT THE LOG FILE 00146000 * LINEDIT TYPE MESSAGES AND FORM LINES 00147000 * DMSERR TYPE ERROR MESSAGES 00148000 * FSSTATE DETERMINE EXISTENCE OF INPUT FILES 00149000 * ATTN STACK LINES (WITH 'STK' OPTION) 00150000 * RENAME RENAME WORK FILES 00151000 * 00152000 * EXTERNAL REFERENCES - 00153000 * 00154000 * NUCON NUCLEUS CONSTANTS AND VARIABLES 00155000 * ADT ACTIVE DISK TABLE 00156000 * 00157000 * TABLES / WORKAREAS - 00158000 * 00159000 * NONE -- ALL WORK STORAGE IS IN-LINE 00160000 * 00161000 * REGISTER USAGE - 00162000 * 00163000 * R12 BASE REGISTER # 1 00164000 * R11 BASE REGISTER # 2 00165000 * R9 BASE REGISTER # 3 00166000 * R10 HOLDS SEQ8/SEQ5 COUNT FOR EX 00167000 * R2 - R8 WORK REGISTERS 00168000 * 00169000 * NOTES - 00170000 * 00171000 * NONE 00172000 * 00173000 * OPERATION - 00174000 * 00175000 * IF A SINGLE UPDATE IS TO BE PERFORMED, THEN THE INPUT 00176000 * SOURCE FILE AND THE UPDATE FILE ARE OPENED. AS THE 00177000 * CONTROL CARDS ARE READ FROM THE UPDATE FILE, INSERTIONS 00178000 * AND DELETIONS ARE MADE TO THE SOURCE FILE, WITH THE 00179000 * UPDATED VERSION WRITTEN ONTO DISK AS $FNAME. 00180000 * 00181000 * IF MULTIPLE UPDATES ARE TO BE PERFORMED, THEN THE CONTROL 00182000 * FILE IS OPENED, AND USED AS A GUIDE TO THE VARIOUS 00183000 * UPDATE FILES. UPDATE FILE CONTROL CARDS MAY REFER 00184000 * TO UPDATE FILES, OR TO 'AUX' FILES CONTAINING 00185000 * DESIGNATIONS OF UPDATE FILEIDS. (THE EXACT FORMATS OF 00186000 * THESE FILES IS DESCRIBED IN DETAIL IN THE COMMAND 00187000 * LANGUAGE USER'S GUIDE.) IF NO UPDATE FILES ARE FOUND 00188000 * AT ALL, A RETURN CODE OF 40 IS GENERATED (THIS CODE IS 00189000 * GENERATED IN ONLY THIS WAY). 00190000 * WHEN MULTIPLE UPDATES ARE BEING PERFORMED, THE INPUT 00191000 * SOURCE FILE IS READ INTO STORAGE AND THE UPDATES ARE 00192000 * THEN PERFORMED IN STORAGE. ALL UPDATES ARE DONE 00193000 * IN STORAGE BEFORE THE OUTPUT FILE IS CREATED 00194000 * ON DISK. 00195000 * 00196000 * AS A FINAL STEP, IF THE 'REP' OPTION WAS SPECIFIED, THEN 00197000 * THE $FNAME FILE IS RENAMED TO FNAME. 00198000 *. 00199000 EJECT 00200000 * "FSSTATE/FSREAD/FSWRITE/FSCLOSE/FSERASE" MACROS WITH BALR CALLS: 00201000 SPACE 00202000 MACRO 00203000 &LABEL FSSTATE &FILEID,&FSCB=,&ERROR= 00204000 GBLC &DMSNAME,&DMSTYPE,&DMSMODE 00205000 AIF (T'&FILEID EQ 'O' AND T'&FSCB EQ 'O').ERR1 00206000 AIF (T'&FILEID EQ 'O').NOID 00207000 AIF ('&FILEID'(1,1) NE '''' AND '&FILEID'(1,1) NE '(').ERR2 00208000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '1').ERR3 00209000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '0').ERR4 00210000 &DMSNAME SETC ' ' 00211000 &DMSTYPE SETC ' ' 00212000 &DMSMODE SETC ' ' 00213000 AIF ('&FILEID'(1,1) EQ '(').SKIP1 00214000 &DMSMODE SETC 'A1' 00215000 DMSPID &FILEID 00216000 AIF ('&DMSNAME' EQ ' ' OR '&DMSTYPE' EQ ' ').ERR2 00217000 .SKIP1 AIF (T'&FSCB EQ 'O').NOCB 00218000 .NOID AIF (T'&LABEL EQ 'O').NLBL 00219000 &LABEL DS 0H 00220000 .NLBL ANOP 00221000 AIF ('&FSCB'(1,1) EQ '(').REG1 00222000 LA 1,&FSCB 00223000 AGO .CONT1 00224000 .REG1 AIF ('&FSCB(1)' EQ '1').CONT1 00225000 LR 1,&FSCB(1) 00226000 .CONT1 ANOP 00227000 AIF (T'&FILEID EQ 'O').CONT2 00228000 AIF ('&FILEID'(1,1) EQ '(').REG2 00229000 MVC 8(8,1),=CL8'&DMSNAME' 00230000 MVC 16(8,1),=CL8'&DMSTYPE' 00231000 MVC 24(2,1),=CL2'&DMSMODE' 00232000 AGO .CONT2 00233000 .REG2 ANOP 00234000 MVC 8(18,1),0(&FILEID(1)) 00235000 .CONT2 ANOP 00236000 MVC 40(4,1),28(1) 00237000 ST R14,0(,R1) PRESERVE R14 (IN P-LIST) 00238000 L R15,ASTATE CALL 'STATE' VIA BALR 00239000 BALR R14,R15 ... 00240000 L R14,0(,R1) RECOVER R14 00241000 AIF (T'&ERROR EQ 'O').NOER 00242000 BNZ &ERROR 00243000 AGO .CONT3 00244000 .NOER ANOP 00245000 BNZ DMS&SYSNDX.B 00246000 .CONT3 ANOP 00247000 L 15,28(,1) 00248000 MVC 28(4,1),40(1) 00249000 LR 1,15 00250000 SR 15,15 00251000 AIF (T'&ERROR NE 'O').EXIT 00252000 DMS&SYSNDX.B EQU * 00253000 .EXIT MEXIT 00254000 .NOCB ANOP 00255000 CNOP 0,4 00256000 &LABEL BAL 1,DMS&SYSNDX.A 00257000 DC CL8'STATE' 00258000 DC CL8'&DMSNAME' 00259000 DC CL8'&DMSTYPE' 00260000 DC CL2'&DMSMODE' 00261000 DC CL2' ' 00262000 DC AL4(0) 00263000 DMS&SYSNDX.A EQU * 00264000 AIF ('&FILEID'(1,1) NE '(').SKIP2 00265000 MVC 8(18,1),0(&FILEID(1)) 00266000 .SKIP2 ANOP 00267000 ST R14,0(,R1) PRESERVE R14 (IN P-LIST) 00268000 L R15,ASTATE CALL 'STATE' VIA BALR 00269000 BALR R14,R15 ... 00270000 L R14,0(,R1) RECOVER R14 00271000 AIF (T'&ERROR EQ 'O').NERR 00272000 BNZ &ERROR 00273000 AGO .SKIP3 00274000 .NERR ANOP 00275000 BNZ *+8 00276000 .SKIP3 ANOP 00277000 L 1,28(,1) 00278000 MEXIT 00279000 .ERR1 MNOTE 8,'NEITHER FILEID OF FSCB SPECIFIED' 00280000 MEXIT 00281000 .ERR2 MNOTE 8,'INVALID FILEID SPECIFICATION' 00282000 MEXIT 00283000 .ERR3 MNOTE 8,'REGISTER 1 INVALID FOR FILEID' 00284000 MEXIT 00285000 .ERR4 MNOTE 8,'INVALID USE OF REGISTER 0' 00286000 MEND 00287000 SPACE 00288000 MACRO 00289000 &LABEL FSREAD &FILEID,&FSCB=,&RECFM=,&BUFFER=,&BSIZE=,&RECNO=,&NOREC=X00290000 ,&ERROR= 00291000 GBLC &DMSNAME,&DMSTYPE,&DMSMODE 00292000 AIF (T'&FILEID EQ 'O' AND T'&FSCB EQ 'O').ERR1 00293000 AIF (T'&FILEID EQ 'O').NOID 00294000 AIF ('&FILEID'(1,1) NE '''' AND '&FILEID'(1,1) NE '(').ERR2 00295000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '0').ERR3 00296000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '1').ERR3 00297000 &DMSNAME SETC ' ' 00298000 &DMSTYPE SETC ' ' 00299000 &DMSMODE SETC ' ' 00300000 AIF ('&FILEID'(1,1) EQ '(').CONT1 00301000 &DMSMODE SETC 'A1' 00302000 DMSPID &FILEID 00303000 AIF ('&DMSNAME' EQ ' ' OR '&DMSTYPE' EQ ' ').ERR2 00304000 .CONT1 AIF (T'&FSCB EQ 'O').NOCB 00305000 .NOID AIF (T'&LABEL EQ 'O').NLBL 00306000 &LABEL DS 0H 00307000 .NLBL ANOP 00308000 AIF ('&FSCB'(1,1) EQ '(').REG1 00309000 LA 1,&FSCB 00310000 AGO .CONT2 00311000 .REG1 AIF ('&FSCB(1)' EQ '1').CONT2 00312000 LR 1,&FSCB(1) 00313000 .CONT2 AIF (T'&FILEID EQ 'O').CONT3 00314000 AIF ('&FILEID'(1,1) EQ '(').REG2 00315000 MVC 8(8,1),=CL8'&DMSNAME' 00316000 MVC 16(8,1),=CL8'&DMSTYPE' 00317000 MVC 24(2,1),=CL2'&DMSMODE' 00318000 AGO .CONT3 00319000 .REG2 ANOP 00320000 MVC 8(18,1),0(&FILEID(1)) 00321000 .CONT3 AIF (T'&RECNO EQ 'O').SKIP1 00322000 AIF ('&RECNO'(1,1) EQ '(').STOR1 00323000 MVC 26(2,1),=H'&RECNO' 00324000 AGO .SKIP1 00325000 .STOR1 ANOP 00326000 AIF ('&RECNO(1)' EQ '1').ERR4 00327000 STH &RECNO(1),26(,1) 00328000 .SKIP1 AIF (T'&BUFFER EQ 'O').SKIP2 00329000 AIF ('&BUFFER'(1,1) EQ '(').STOR2 00330000 MVC 28(4,1),=A(&BUFFER) 00331000 AGO .SKIP2 00332000 .STOR2 ANOP 00333000 AIF ('&BUFFER(1)' EQ '1').ERR5 00334000 ST &BUFFER(1),28(,1) 00335000 .SKIP2 AIF (T'&BSIZE EQ 'O').SKIP3 00336000 AIF ('&BSIZE'(1,1) EQ '(').STOR3 00337000 MVC 32(4,1),=F'&BSIZE' 00338000 AGO .SKIP3 00339000 .STOR3 ANOP 00340000 AIF ('&BSIZE(1)' EQ '1').ERR6 00341000 ST &BSIZE(1),32(,1) 00342000 .SKIP3 AIF (T'&RECFM EQ 'O').SKIP4 00343000 AIF ('&RECFM'(1,1) EQ '(').STOR4 00344000 AIF ('&RECFM' NE 'F' AND '&RECFM' NE 'V').ERR11 00345000 MVC 36(2,1),=CL2'&RECFM' 00346000 AGO .SKIP4 00347000 .STOR4 ANOP 00348000 AIF ('&RECFM(1)' EQ '1').ERR7 00349000 STC &RECFM(1),36(,1) 00350000 .SKIP4 AIF (T'&NOREC EQ 'O').SKIP5 00351000 AIF ('&NOREC'(1,1) EQ '(').STOR5 00352000 MVC 38(2,1),=H'&NOREC' 00353000 AGO .SKIP5 00354000 .STOR5 ANOP 00355000 AIF ('&NOREC(1)' EQ '1').ERR8 00356000 STH &NOREC(1),38(,1) 00357000 .SKIP5 ANOP 00358000 ST R14,0(,R1) PRESERVE R14 (IN P-LIST) 00359000 L R15,ARDBUF CALL 'RDBUF' VIA BALR 00360000 BALR R14,R15 ... 00361000 L R14,0(,R1) RECOVER R14 00362000 AIF (T'&ERROR EQ 'O').NOER 00363000 BNZ &ERROR BRANCH IF ERROR OCCURRED 00364000 .NOER ANOP 00365000 L 0,40(,1) 00366000 MEXIT 00367000 .NOCB ANOP 00368000 AIF (T'&BUFFER EQ 'O').ERR9 00369000 AIF (T'&BSIZE EQ 'O').ERR10 00370000 CNOP 0,4 00371000 &LABEL BAL 1,DMS&SYSNDX.A 00372000 FSCB &FILEID 00373000 DMS&SYSNDX.A EQU * 00374000 AIF ('&FILEID'(1,1) EQ '(').REG2 00375000 AGO .CONT3 00376000 .ERR1 MNOTE 8,'NEITHER FILEID OR FSCB SPECIFIED' 00377000 MEXIT 00378000 .ERR2 MNOTE 8,'INVALID FILEID SPECIFICATION' 00379000 MEXIT 00380000 .ERR3 MNOTE 8,'REGISTERS 0 AND 1 INVALID FOR FILEID' 00381000 MEXIT 00382000 .ERR4 MNOTE 8,'REGISTER 1 INVALID FOR RECNO' 00383000 MEXIT 00384000 .ERR5 MNOTE 8,'REGISTER 1 INVALID FOR BUFFER' 00385000 MEXIT 00386000 .ERR6 MNOTE 8,'REGISTER 1 INVALID FOR BSIZE' 00387000 MEXIT 00388000 .ERR7 MNOTE 8,'REGISTER 1 INVALID FOR RECFM' 00389000 MEXIT 00390000 .ERR8 MNOTE 8,'REGISTER 1 INVALID FOR NOREC' 00391000 MEXIT 00392000 .ERR9 MNOTE 8,'BUFFER ADDRESS NOT SPECIFIED' 00393000 MEXIT 00394000 .ERR10 MNOTE 8,'BUFFER SIZE NOT SPECIFIED' 00395000 MEXIT 00396000 .ERR11 MNOTE 8,'INVALID RECFM SPECIFICATION' 00397000 MEND 00398000 SPACE 00399000 MACRO 00400000 &LABEL FSWRITE &FILEID,&FSCB=,&RECFM=,&BUFFER=,&BSIZE=,&RECNO=,&NORECX00401000 =,&ERROR= 00402000 GBLC &DMSNAME,&DMSTYPE,&DMSMODE 00403000 AIF (T'&FILEID EQ 'O' AND T'&FSCB EQ 'O').ERR1 00404000 AIF (T'&FILEID EQ 'O').NOID 00405000 AIF ('&FILEID'(1,1) NE '''' AND '&FILEID'(1,1) NE '(').ERR2 00406000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '0').ERR3 00407000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '1').ERR3 00408000 &DMSNAME SETC ' ' 00409000 &DMSTYPE SETC ' ' 00410000 &DMSMODE SETC ' ' 00411000 AIF ('&FILEID'(1,1) EQ '(').CONT1 00412000 &DMSMODE SETC 'A1' 00413000 DMSPID &FILEID 00414000 AIF ('&DMSNAME' EQ ' ' OR '&DMSTYPE' EQ ' ').ERR2 00415000 .CONT1 AIF (T'&FSCB EQ 'O').NOCB 00416000 .NOID AIF (T'&LABEL EQ 'O').NLBL 00417000 &LABEL DS 0H 00418000 .NLBL ANOP 00419000 AIF ('&FSCB'(1,1) EQ '(').REG1 00420000 LA 1,&FSCB 00421000 AGO .CONT2 00422000 .REG1 AIF ('&FSCB(1)' EQ '1').CONT2 00423000 LR 1,&FSCB(1) 00424000 .CONT2 AIF (T'&FILEID EQ 'O').CONT3 00425000 AIF ('&FILEID'(1,1) EQ '(').REG2 00426000 MVC 8(8,1),=CL8'&DMSNAME' 00427000 MVC 16(8,1),=CL8'&DMSTYPE' 00428000 MVC 24(2,1),=CL2'&DMSMODE' 00429000 AGO .CONT3 00430000 .REG2 ANOP 00431000 MVC 8(18,1),0(&FILEID(1)) 00432000 .CONT3 AIF (T'&RECNO EQ 'O').SKIP1 00433000 AIF ('&RECNO'(1,1) EQ '(').STOR1 00434000 MVC 26(2,1),=H'&RECNO' 00435000 AGO .SKIP1 00436000 .STOR1 ANOP 00437000 AIF ('&RECNO(1)' EQ '1').ERR4 00438000 STH &RECNO(1),26(,1) 00439000 .SKIP1 AIF (T'&BUFFER EQ 'O').SKIP2 00440000 AIF ('&BUFFER'(1,1) EQ '(').STOR2 00441000 MVC 28(4,1),=A(&BUFFER) 00442000 AGO .SKIP2 00443000 .STOR2 ANOP 00444000 AIF ('&BUFFER(1)' EQ '1').ERR5 00445000 ST &BUFFER(1),28(,1) 00446000 .SKIP2 AIF (T'&BSIZE EQ 'O').SKIP3 00447000 AIF ('&BSIZE'(1,1) EQ '(').STOR3 00448000 MVC 32(4,1),=F'&BSIZE' 00449000 AGO .SKIP3 00450000 .STOR3 ANOP 00451000 AIF ('&BSIZE(1)' EQ '1').ERR6 00452000 ST &BSIZE(1),32(,1) 00453000 .SKIP3 AIF (T'&RECFM EQ 'O').SKIP4 00454000 AIF ('&RECFM'(1,1) EQ '(').STOR4 00455000 AIF ('&RECFM' NE 'F' AND '&RECFM' NE 'V').ERR11 00456000 MVC 36(2,1),=CL2'&RECFM' 00457000 AGO .SKIP4 00458000 .STOR4 ANOP 00459000 AIF ('&RECFM(1)' EQ '1').ERR7 00460000 STC &RECFM(1),36(,1) 00461000 .SKIP4 AIF (T'&NOREC EQ 'O').SKIP5 00462000 AIF ('&NOREC'(1,1) EQ '(').STOR5 00463000 MVC 38(2,1),=H'&NOREC' 00464000 AGO .SKIP5 00465000 .STOR5 ANOP 00466000 AIF ('&NOREC(1)' EQ '1').ERR8 00467000 STH &NOREC(1),38(,1) 00468000 .SKIP5 ANOP 00469000 ST R14,0(,R1) PRESERVE R14 (IN P-LIST) 00470000 L R15,AWRBUF CALL 'WRBUF' VIA BALR 00471000 BALR R14,R15 ... 00472000 L R14,0(,R1) RECOVER R14 00473000 AIF (T'&ERROR EQ 'O').NOER 00474000 BNZ &ERROR BRANCH IF ERROR OCCURRED 00475000 .NOER ANOP 00476000 MEXIT 00477000 .NOCB ANOP 00478000 AIF (T'&BUFFER EQ 'O').ERR9 00479000 AIF (T'&BSIZE EQ 'O').ERR10 00480000 CNOP 0,4 00481000 &LABEL BAL 1,DMS&SYSNDX.A 00482000 SPACE 00483000 FSCB &FILEID 00484000 DMS&SYSNDX.A EQU * 00485000 AIF ('&FILEID'(1,1) EQ '(').REG2 00486000 AGO .CONT3 00487000 .ERR1 MNOTE 8,'NEITHER FILEID OR FSCB SPECIFIED' 00488000 MEXIT 00489000 .ERR2 MNOTE 8,'INVALID FILEID SPECIFICATION' 00490000 MEXIT 00491000 .ERR3 MNOTE 8,'REGISTERS 0 AND 1 INVALID FOR FILEID' 00492000 MEXIT 00493000 .ERR4 MNOTE 8,'REGISTER 1 INVALID FOR RECNO' 00494000 MEXIT 00495000 .ERR5 MNOTE 8,'REGISTER 1 INVALID FOR BUFFER' 00496000 MEXIT 00497000 .ERR6 MNOTE 8,'REGISTER 1 INVALID FOR BSIZE' 00498000 MEXIT 00499000 .ERR7 MNOTE 8,'REGISTER 1 INVALID FOR RECFM' 00500000 MEXIT 00501000 .ERR8 MNOTE 8,'REGISTER 1 INVALID FOR NOREC' 00502000 MEXIT 00503000 .ERR9 MNOTE 8,'BUFFER ADDRESS NOT SPECIFIED' 00504000 MEXIT 00505000 .ERR10 MNOTE 8,'BUFFER SIZE NOT SPECIFIED' 00506000 MEXIT 00507000 .ERR11 MNOTE 8,'INVALID RECFM SPECIFICATION' 00508000 MEND 00509000 SPACE 00510000 MACRO 00511000 &LABEL FSCLOSE &FILEID,&FSCB=,&ERROR= 00512000 GBLC &DMSNAME,&DMSTYPE,&DMSMODE 00513000 AIF (T'&FILEID EQ 'O' AND T'&FSCB EQ 'O').ERR1 00514000 AIF (T'&FILEID EQ 'O').NOID 00515000 AIF ('&FILEID'(1,1) NE '''' AND '&FILEID'(1,1) NE '(').ERR2 00516000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '0').ERR3 00517000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '1').ERR3 00518000 &DMSNAME SETC ' ' 00519000 &DMSTYPE SETC ' ' 00520000 &DMSMODE SETC ' ' 00521000 AIF ('&FILEID'(1,1) EQ '(').SKIP1 00522000 &DMSMODE SETC 'A1' 00523000 DMSPID &FILEID 00524000 AIF ('&DMSNAME' EQ ' ' OR '&DMSTYPE' EQ ' ').ERR2 00525000 .SKIP1 AIF (T'&FSCB EQ 'O').NOCB 00526000 .NOID AIF (T'&LABEL EQ 'O').NLBL 00527000 &LABEL DS 0H 00528000 .NLBL ANOP 00529000 AIF ('&FSCB'(1,1) EQ '(').REG1 00530000 LA 1,&FSCB 00531000 AGO .CONT1 00532000 .REG1 AIF ('&FSCB(1)' EQ '1').CONT1 00533000 LR 1,&FSCB(1) 00534000 .CONT1 ANOP 00535000 AIF (T'&FILEID EQ 'O').CONT2 00536000 AIF ('&FILEID'(1,1) EQ '(').REG2 00537000 MVC 8(8,1),=CL8'&DMSNAME' 00538000 MVC 16(8,1),=CL8'&DMSTYPE' 00539000 MVC 24(2,1),=CL2'&DMSMODE' 00540000 AGO .CONT2 00541000 .REG2 ANOP 00542000 MVC 8(18,1),0(&FILEID(1)) 00543000 .CONT2 ANOP 00544000 ST R14,0(,R1) PRESERVE R14 (IN P-LIST) 00545000 L R15,AFINIS CALL 'FINIS' VIA BALR 00546000 BALR R14,R15 ... 00547000 L R14,0(,R1) RECOVER R14 00548000 AIF (T'&ERROR EQ 'O').NOER1 00549000 BNZ &ERROR BRANCH IF ERROR OCCURRED 00550000 .NOER1 ANOP 00551000 MEXIT 00552000 .NOCB ANOP 00553000 CNOP 0,4 00554000 &LABEL BAL 1,DMS&SYSNDX.A 00555000 DC CL8'FINIS' 00556000 DC CL8'&DMSNAME' 00557000 DC CL8'&DMSTYPE' 00558000 DC CL2'&DMSMODE' 00559000 DMS&SYSNDX.A EQU * 00560000 AIF ('&FILEID'(1,1) NE '(').SKIP2 00561000 MVC 8(18,1),0(&FILEID(1)) 00562000 .SKIP2 ANOP 00563000 ST R14,0(,R1) PRESERVE R14 (IN P-LIST) 00564000 L R15,AFINIS CALL 'FINIS' VIA BALR 00565000 BALR R14,R15 ... 00566000 L R14,0(,R1) RECOVER R14 00567000 AIF (T'&ERROR EQ 'O').NOER2 00568000 BNZ &ERROR BRANCH IF ERROR OCCURRED 00569000 .NOER2 ANOP 00570000 MEXIT 00571000 .ERR1 MNOTE 8,'NEITHER FILEID OR FSCB SPECIFIED' 00572000 MEXIT 00573000 .ERR2 MNOTE 8,'INVALID FILEID SPECIFICATION' 00574000 MEXIT 00575000 .ERR3 MNOTE 8,'REGISTERS 0 AND 1 INVALID FOR FILEID' 00576000 MEND 00577000 SPACE 00578000 MACRO 00579000 &LABEL FSERASE &FILEID,&FSCB=,&ERROR= 00580000 GBLC &DMSNAME,&DMSTYPE,&DMSMODE 00581000 AIF (T'&FILEID EQ 'O' AND T'&FSCB EQ 'O').ERR1 00582000 AIF (T'&FILEID EQ 'O').NOID 00583000 AIF ('&FILEID'(1,1) NE '''' AND '&FILEID'(1,1) NE '(').ERR2 00584000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '0').ERR3 00585000 AIF ('&FILEID'(1,1) EQ '(' AND '&FILEID(1)' EQ '1').ERR3 00586000 &DMSNAME SETC ' ' 00587000 &DMSTYPE SETC ' ' 00588000 &DMSMODE SETC ' ' 00589000 AIF ('&FILEID'(1,1) EQ '(').SKIP1 00590000 &DMSMODE SETC 'A1' 00591000 DMSPID &FILEID 00592000 AIF ('&DMSNAME' EQ ' ' OR '&DMSTYPE' EQ ' ').ERR2 00593000 .SKIP1 AIF (T'&FSCB EQ 'O').NOCB 00594000 .NOID AIF (T'&LABEL EQ 'O').NLBL 00595000 &LABEL DS 0H 00596000 .NLBL ANOP 00597000 AIF ('&FSCB'(1,1) EQ '(').REG1 00598000 LA 1,&FSCB 00599000 AGO .CONT1 00600000 .REG1 AIF ('&FSCB(1)' EQ '1').CONT1 00601000 LR 1,&FSCB(1) 00602000 .CONT1 ANOP 00603000 AIF (T'&FILEID EQ 'O').CONT2 00604000 AIF ('&FILEID'(1,1) EQ '(').REG2 00605000 MVC 8(8,1),=CL8'&DMSNAME' 00606000 MVC 16(8,1),=CL8'&DMSTYPE' 00607000 MVC 24(2,1),=CL2'&DMSMODE' 00608000 AGO .CONT2 00609000 .REG2 ANOP 00610000 MVC 8(18,1),0(&FILEID(1)) 00611000 .CONT2 ANOP 00612000 ST R14,0(,R1) PRESERVE R14 (IN P-LIST) 00613000 L R15,AERASE CALL 'ERASE' VIA BALR 00614000 BALR R14,R15 ... 00615000 L R14,0(,R1) RECOVER R14 00616000 AIF (T'&ERROR EQ 'O').NOER1 00617000 BNZ &ERROR BRANCH IF ERROR OCCURRED 00618000 .NOER1 ANOP 00619000 MEXIT 00620000 .NOCB ANOP 00621000 CNOP 0,4 00622000 &LABEL BAL 1,DMS&SYSNDX.A 00623000 DC CL8'ERASE' 00624000 DC CL8'&DMSNAME' 00625000 DC CL8'&DMSTYPE' 00626000 DC CL2'&DMSMODE' 00627000 DC 8X'FF' 00628000 DMS&SYSNDX.A EQU * 00629000 AIF ('&FILEID'(1,1) NE '(').SKIP2 00630000 MVC 8(18,1),0(&FILEID(1)) 00631000 .SKIP2 ANOP 00632000 ST R14,0(,R1) PRESERVE R14 (IN P-LIST) 00633000 L R15,AERASE CALL 'ERASE' VIA BALR 00634000 BALR R14,R15 ... 00635000 L R14,0(,R1) RECOVER R14 00636000 AIF (T'&ERROR EQ 'O').NOER2 00637000 BNZ &ERROR BRANCH IF ERROR OCCURRED 00638000 .NOER2 ANOP 00639000 MEXIT 00640000 .ERR1 MNOTE 8,'NEITHER FILEID OF FSCB SPECIFIED' 00641000 MEXIT 00642000 .ERR2 MNOTE 8,'INVALID FILEID SPECIFICATION' 00643000 MEXIT 00644000 .ERR3 MNOTE 8,'REGISTERS 0 AND 1 INVALID FOR FILEID' 00645000 MEND 00646000 EJECT 00647000 DMSUPD START X'20000' @VM03093 00648000 SPACE 2 00649000 USING DMSUPD,R12,R11,R9 BASE REGISTERS FOR ROUTINE 00650000 USING NUCON,R0 00651000 SPACE 2 00652000 LR R12,R15 SET FIRST BASE REGISTER 00653000 ST R14,SAVE14 SAVE RETURN ADDRESS 00654000 LA R11,2048(0,R12) SET UP SECOND BASE REGISTER 00655000 LA R11,2048(0,R11) ... 00656000 LA R9,2048(,R11) SET THIRD BASE REG 00657000 LA R9,2048(,R9) 00658000 LR R6,R1 SAVE ADDRESS OF P-LIST BUFFER 00659000 MVI GLOBALS,SEQ8+NSTK+DISK+TERM SET OPTION DEFAULTS 00660000 LA R10,7(0,0) DEFAULT = EIGHT-DIGIT SEQUENCE 00661000 ZAP SEQMAX,=P'100000000' SET MAX SEQ NUMBER P3027 00662000 MVI UPDFLAG,X'04' INCORE DEFAULT @V2D4821 00663000 MVI UPDFLAG2,0 ZERO THE FLAG @V2D4821 00664000 MVI CTLMACS,X'40' BLANK OUT MACLIB BUFFER 00665000 MVC CTLMACS+1(71),CTLMACS ... 00666000 * NOW SET DEFAULTS IN THE DISK P-LISTS 00667000 MVC INPFILE+16(10),=C'ASSEMBLEA1' FTYPE, FMODE 00668000 MVC UPDFILE+16(10),=C'UPDATE A1' FTYPE,FMODE 00669000 MVC CTLFILE+16(10),=C'CNTRL A1' FTYPE, FMODE 00670000 MVC NEWNAME+8(10),=C'ASSEMBLEA1' FTYPE, FMODE 00671000 MVC LOGFILE+16(8),=CL8'UPDLOG ' FTYPE 00672000 DMSKEY NUCLEUS NOW RUN WITH NUCLEUS KEY, AND @VM03093 00673000 SSM NOINTS NO EXTRANEOUS INTERRUPTS PLEASE @VM03093 00674000 EJECT 00675000 * NOW WE'RE ALL SET TO EXAMINE THE INPUT PARMS 00676000 LA R2,8(0,R6) ADVANCE TO FIRST REAL PARAMETER 00677000 CLC 0(8,R2),FENCED WERE ANY PARMS GIVEN ? 00678000 BE NOFNAME NOPE - NEED AT LEAST ONE 00679000 CLC =CL2'( ',0(R2) WERE ONLY OPTIONS SPECIFIED P3059 00680000 BE NOFNAME YES, TYPE OUT AN ERROR MESSAGE P3059 00681000 MVC FNAME,0(R2) SET FILENAME 00682000 MVC INPFILE+8(8),0(R2) FILL IN DISK P-LISTS 00683000 MVC UPDFILE+8(8),0(R2) ... 00684000 MVC LOGFILE+8(8),0(R2) ... 00685000 MVC AUXFILE+8(8),0(R2) ... 00686000 MVC UPSFILE+8(8),0(R2) ... 00687000 MVC NEWNAME+1(7),0(R2) DEFAULT NAME FOR UPDATED FILE 00688000 MVI NEWNAME,C'$' ... IS '$FNAME1' 00689000 MVC SEQLABL(3),0(R2) DEFAULT THREE-CHAR LABEL 00690000 SPACE 2 00691000 BAL R14,OPTSCAN SECOND PARM, IF ANY 00692000 MVC INPFILE+16(8),0(R2) INPUT FILE FTYPE 00693000 MVC NEWNAME+8(8),0(R2) ...ALSO OUTPUT FTYPE 00694000 SPACE 00695000 BAL R14,OPTSCAN THIRD PARM 00696000 MVC INPFILE+24(2),0(R2) INPUT FMODE 00697000 CLI 2(R2),C' ' IS FMOVE > 2 CHARS? 00698000 BNE BADMODE GO IF IT IS 00699000 SPACE 00700000 BAL R14,OPTSCAN CHECK FOR FOURTH PARM... 00701000 MVC UPDFILE+8(8),0(R2) UPDATE FNAME 00702000 SPACE 00703000 BAL R14,OPTSCAN CHECK FOR FIFTH... 00704000 MVC UPDFILE+16(8),0(R2) UPDATE FTYPE 00705000 MVC CTLFILE+16(8),0(R2) SET FILETYPE OF CTL FILE 00706000 SPACE 00707000 BAL R14,OPTSCAN SIXTH.... 00708000 MVC UPDFILE+24(2),0(R2) UPDATE FMODE 00709000 MVC CTLFILE+24(2),0(R2) SET FILEMODE OF CONTROL FILE 00710000 CLI 2(R2),C' ' IS FMODE > 2 CHARS? 00711000 BNE BADMODE GO IF IT IS 00712000 SPACE 00713000 BAL R14,OPTSCAN PICK UP OPTION LIST 00714000 B EXCESIV HMMMM... TOO MANY FIELDS 00715000 EJECT 00716000 OPTSCAN EQU * SCAN COMMAND INPUT FOR OPTIONS, PARMS 00717000 LA R2,8(0,R2) NEXT PARM SLOT 00718000 CLI 0(R2),X'FF' AT END OF LIST YET ? 00719000 BE OPTEND YES - JUMP INTO PROCESSING 00720000 CLI 0(R2),C'(' START OF OPTION LIST ? 00721000 BCR 7,R14 (BNE 0(R14)) NO - JUST RETURN 00722000 OPTNEXT EQU * START DECODING OPTIONS 00723000 LA R2,8(0,R2) NEXT OPTION SLOT 00724000 CLI 0(R2),X'FF' AT END OF PLIST? 00725000 BE OPTEND YES - START MOVING 00726000 CLI 0(R2),C')' AT END OF LIST ? 00727000 BE OPTEND YES 00728000 SPACE 00729000 LA R3,7(0,R2) END OF 8-BYTE FIELD 00730000 OPTBLNK EQU * SCAN BACK TO NON-BLANK 00731000 CLI 0(R3),X'40' 00732000 BNE OPTLIST 00733000 BCT R3,OPTBLNK 00734000 OPTLIST EQU * SET-UP FOR TABLE LOOK-UP 00735000 SR R3,R2 GPR 3 = PARM LENGTH - 1 00736000 LA R7,OPTIONS TABLE START 00737000 LA R4,16(0) TABLE ENTRY LENGTH 00738000 LA R5,OPTLAST TABLE END 00739000 OPTCHEK EQU * MATCH INPUT AGAINST TABLE 00740000 CH R3,8(0,R7) ABOVE MIN. LEN FOR THIS OPTION ? 00741000 BL OPTABLE NO - SKIP OVER IT 00742000 EX R3,OPTCMP DOES IT MATCH ? 00743000 BE OPTFND GO IF FOUND 00744000 SPACE 00745000 OPTABLE EQU * 00746000 BXLE R7,R4,OPTCHEK 00747000 B INVOPTN UNRECOGNIZABLE OPTION 00748000 SPACE 2 00749000 OPTCMP CLC 0(*-*,R7),0(R2) LENGTH FILLED IN BY EX 00750000 SPACE 3 00751000 * COME HERE IF THE OPTION HAS BEEN FOUND IN THE TABLE. 00752000 OPTFND EQU * 00753000 LH R3,10(,R7) GET ADDRESS OF CHECK ADDRESS 00754000 L R4,CKADS(R3) GET VALUE IN CHECK ADDRESS 00755000 LTR R4,R4 IS THERE ALREADY AN ADDR THERE? 00756000 BNZ OPTERR THEN WE HAVE DUP OR CONF OPTIONS 00757000 ST R7,CKADS(R3) STORE ADDRESS OF OPTION TABLE 00758000 EX 0,12(,R7) EXECUTE OI, NI OR B 00759000 B OPTNEXT GO FOR NEXT OPTION 00760000 SPACE 00761000 * COME HERE IF OPTION ERROR. 00762000 OPTERR EQU * 00763000 CLR R7,R4 SAME OPTION SPECIFIED TWICE? 00764000 BE OPTDUP DUPLICATE OPTION IF SO 00765000 B OPTCONF CONFLICTING IF NOT 00766000 SPACE 5 00767000 * COME HERE AT END OF OPTIONS 00768000 OPTEND EQU * 00769000 TM GLOBALS,NSTK 'STK' SPECIFIED? 00770000 BO OPTEND1 GO IF NOT @V2D4821 00771000 TM GLOBALS,CTLF 'CTL' SPECIFIED? 00772000 BZ ERSC ERROR IF 'STK' AND NO 'CTL' 00773000 OPTEND1 EQU * @V2D4821 00774000 TM GLOBALS,CTLF 'CTL' IN EFFECT ? @V2D4821 00775000 BZ OPTEND2 SKIP THIS TEST IF NOT @V2D4821 00776000 L R4,CKCT POINT TO 'CTL' KEYWORD @V2D4821 00777000 L R7,CKIN POINT TO 'INC/NOINC' KEYWORD @V2D4821 00778000 LTR R7,R7 WAS EITHER SPECIFIED @V2D4821 00779000 BZ OPTEND2 GO IF NEITHER WAS SPECIFIED @V2D4821 00780000 CLI 0(R7),C'N' WAS IT 'NOINC' ? @V2D4821 00781000 BE OPTCONF 'NOINC' AND 'CTL' ARE CONFLICTS @V2D4821 00782000 SPACE 00783000 SPACE 00784000 OPTEND2 EQU * 00785000 B PROCESS START PROCESSING 00786000 EJECT 00787000 OPTBASE EQU * OPTION PROCESSOR BASE ADDRESS 00788000 SPACE 00789000 OPTSEQ8 EQU * EIGHT-DIGIT SEQUENCING 00790000 OI GLOBALS,SEQ8 00791000 LA R10,7(0,0) SEQUENCE FIELD LENGTH = 8 00792000 ZAP SEQMAX,=P'100000000' SET MAX SEQ NUMBER (8 DIGS)P3027 00793000 B OPTNEXT 00794000 SPACE 3 00795000 OPTNSEQ EQU * FIVE-DIGIT SEQUENCING 00796000 NI GLOBALS,X'FF'-SEQ8 00797000 LA R10,4(0,0) FIVE DIGITS ONLY 00798000 ZAP SEQMAX,=P'100000' MAX SEQ NUMBER FOR 5 DIGS P3027 00799000 MVC SEQLABL(3),INPFILE+8 DEFAULT THREE-CHAR LABEL 00800000 B OPTNEXT 00801000 SPACE 3 00802000 OPTCNTL EQU * UPDATE CONTROL FILE GIVEN 00803000 OI GLOBALS,CTLF+INCL CONTROL FILE GIVEN 00804000 L R3,CKCOR MUST CHECK TO SEE IF NOINCORE WAS SPEC@V2D4821 00805000 LTR R3,R3 PREVIOUSLY. @V2D4821 00806000 BZ OPTCNTLA IT WASN'T.. SET DEFAULT OF INCORE @V2D4821 00807000 CLI 0(R3),C'N' MAYBE IT WAS @V2D4821 00808000 BE NOINC YES, IT WAS @V2D4821 00809000 OPTCNTLA OI UPDFLAG,INCOR SET DEFAULT INCORE PROCESSING @V2D4821 00810000 NOINC MVC CTLFILE+8(8),UPDFILE+8 FNAME2 = CNTRL FNAME @V2D4821 00811000 MVC UPDFILE+8(8),INPFILE+8 UPDATE FNAME = INPUT FNAME 00812000 MVC UPDFILE+16(8),=CL8'UPDT....' FTYPE SKELETON 00813000 B OPTNEXT 00814000 EJECT 00815000 * OPTION LIST 00816000 OPTIONS DS 0D 00817000 OPT SEQ8,4,CKSE,GO,OPTSEQ8 00818000 OPT NOSEQ8,6,CKSE,GO,OPTNSEQ 00819000 OPT INC,3,CKIN,ON,INCL 00820000 OPT NOINC,5,CKIN,OFF,INCL 00821000 OPT REP,3,CKRE,ON,REPL P3027 00822000 OPT NOREP,5,CKRE,OFF,REPL P3027 00823000 OPT STK,3,CKST,OFF,NSTK 00824000 OPT NOSTK,5,CKST,ON,NSTK 00825000 OPT TERM,4,CKTE,ON,TERM 00826000 OPT NOTERM,6,CKTE,OFF,TERM 00827000 OPT CTL,3,CKCT,GO,OPTCNTL 00828000 OPT NOCTL,5,CKCT,OFF,CTLF 00829000 OPT DISK,4,CKDP,ON,DISK 00830000 OPT STOR,4,CKCOR,ON,INCOR @V2D4821 00831000 SPACE 1 00832000 OPT NOSTOR,6,CKCOR,OFF,INCOR @V2D4821 00833000 SPACE 1 00834000 OPTLAST OPT PRINT,5,CKDP,OFF,DISK 00835000 EJECT 00836000 * CHECK ADDRESSES FOR DUPLICATE OR CONFLICTING OPTIONS 00837000 CKADS EQU * 00838000 CKSE DC A(0) CHECK FOR SEQ8/NOSEQ8 00839000 CKIN DC A(0) CHECK FOR INC/NOINC 00840000 CKRE DC A(0) CHECK FOR REPLACE/NOREPLACE 00841000 CKCT DC A(0) CHECK FOR CTL/NOCTL 00842000 CKST DC A(0) CHECK FOR STK/NOSTK 00843000 CKTE DC A(0) CHECK FOR TERM/NOTERM 00844000 CKDP DC A(0) CHECK FOR DISK/PRINT 00845000 CKCOR DC A(0) CHECK FOR INCORE/NOINCOR@V2D4821 00846000 EJECT 00847000 PROCESS EQU * 00848000 STC R10,MVCPOSN+1 STORE INTO COUNT FIELDS @V2D4821 00849000 STC R10,CLCILAST+1 OF SOME PREVIOUSLY 'EX' @V2D4821 00850000 STC R10,MVCILAST+1 INSTRUCTIONS. @V2D4821 00851000 STC R10,CLCOLAST+1 @V2D4821 00852000 LA R1,INPFILE POINT TO FSCB FOR INPUT FILE 00853000 BAL R14,LOCATE CALL 'STATE' TO SEE IF IT EXISTS 00854000 B NOFILE FILE NOT FOUND -- ABORT 00855000 SPACE 00856000 * WE MUST NOW DETERMINE THE DISK UPON WHICH WE ARE GOING TO PLACE ALL 00857000 * OUR OUTPUT FILES. THE RULES ARE AS FOLLOWS: 00858000 SPACE 00859000 * 1. TRY TO PUT IT ONTO THE DISK FROM WHICH WE ARE TAKING THE ORIGINAL 00860000 * INPUT FILE. 00861000 SPACE 00862000 * 2. IF THAT DISK IS R/O, BUT IT IS AN EXTENSION OF A READ/WRITE DISK, 00863000 * THEN IT GOES ONTO THAT READ/WRITE DISK. 00864000 SPACE 00865000 * 3. IF THOSE TWO STEPS FAIL, PUT IT ONTO THE A-DISK. 00866000 SPACE 00867000 USING ADTSECT,R1 00868000 TM ADTFLG1,ADTFRW IS INPUT DISK READ/WRITE? 00869000 L R1,INPFILE+PADT POINT TO ADT FOR INPUT DISK 00870000 TM ADTFLG1,ADTFRW IS THAT DISK READ/WRITE? 00871000 BO RWFND WE'VE FOUND WHAT WE WANT, IF SO 00872000 LA R1,ADTMX-24 POINT TO PARENT DISK 00873000 L R15,VCADTLKW CALL "ADKLKW" @VM03093 00874000 BALR R14,R15 00875000 BZ RWFND GO IF IT'S READ/WRITE 00876000 LA R1,=C'A' POINT TO LETTER FOR 'A'-DISK 00877000 SH R1,=H'24' 00878000 L R15,VCADTLKP CALL "ADTLKP" TO @VM03093 00879000 BALR R14,R15 FIND ACTIVE DISK TABLE @VM03093 00880000 BNZ NOTACCER ERROR IF NOT ACCESSED P3059 00881000 TM ADTFLG1,ADTFRO+ADTFRW IS DISK ACCESSED P3059 00882000 BZ NOTACCER NO, TYPE OUT ERROR MESSAGE P3059 00883000 TM ADTFLG1,ADTFRW IS 'A' DISK IN R/W STATUS P3059 00884000 BZ ERRW NO, TYPE OUT ERROR MESSAGE P3059 00885000 SPACE 00886000 * R1 NOW POINTS TO THE ADT OF THE DISK ONTO WHICH WE ARE GOING TO 00887000 * PUT OUR FILES. 00888000 RWFND EQU * 00889000 LA R2,C'1' USE MODE NUMBER OF '1' 00890000 ICM R2,B'0010',ADTM GET MODE LETTER FROM ADT 00891000 DROP R1 00892000 STH R2,UT1FILE+24 USE FOR UTILITY FILE 00893000 STH R2,RENAME+24 00894000 STH R2,NEWNAME+16 USE FOR NEW NAME 00895000 STH R2,LOGFILE+24 USE FOR LOG FILE 00896000 STH R2,UPSFILE+24 USE FOR 'UPDATES' FILE 00897000 EJECT 00898000 * NEXT, WE DETERMINE WHETHER THE UTILITY FILE 'FNAME CMSUT1' ALREADY 00899000 * EXISTS. IF IT DOES, THEN WE ABORT. 00900000 LA R1,UT1FILE POINT TO FSCB FOR UTILITY FILE 00901000 BAL R14,LOCATE CALL 'STATE' TO SEE IF IT EXISTS 00902000 B *+8 SKIP NEXT IF FILE NOT FOUND 00903000 B ERCMSUT ERROR - ALREADY EXISTS 00904000 * IF WE ARE PUTTING THE LOG FILE ONTO DISK, WE ERASE THE OLD ONE 00905000 TM GLOBALS,DISK LOG FILE TO DISK? 00906000 BZ NOERASE DON'T ERASE IF NOT 00907000 FSERASE FSCB=LOGFILE ERASE THE OLD LOG FILE, IF ONE 00908000 SPACE 00909000 NOERASE EQU * 00910000 TM GLOBALS,CTLF CONTROL FILE OPTION ? 00911000 BZ LOCTUPD NO - SINGLE UPDATE 00912000 LA R1,CTLFILE FIND UPDATE CONTROL FILE 00913000 BAL R14,LOCATE 00914000 B NOFILE NOT FOUND 00915000 B CTLMULT PERFORM MULTI-LEVEL UPDATE 00916000 SPACE 00917000 * 'CTL' WAS NOT REQUESTED -- DO A SINGLE UPDATE 00918000 LOCTUPD EQU * CHECK SINGLE UPDATE FILE 00919000 NI UPDFLAG,255-INCOR SINGLE UPDATES DON'T BENEFIT @V2D4821 00920000 LA R1,UPDFILE 00921000 BAL R14,LOCATE 00922000 B NOFILE FILE NOT FOUND 00923000 B SINGUPD UPDATE ONLY ONCE 00924000 EJECT 00925000 * 00926000 * CTLMULT -- MULTI-LEVEL UPDATE CONTROLLED BY DATA FILE 00927000 * 'FNAME2 CNTRL'. SEARCH THROUGH CONTROL FILE LOOKING 00928000 * FOR UPDATES AGAINST THE INPUT FILE, APPLYING WHICHEVER 00929000 * UPDATES OR PTF'S ARE FOUND. 00930000 * 00931000 CTLMULT EQU * MULTI-LEVEL UPDATE W/CNTRL FILE 00932000 L R1,CTLFILE+PFST GET POINTER TO FST FOR CTL FILE 00933000 LH R8,ITEM(0,R1) TOTAL ITEM COUNT IN FILE 00934000 SR R2,R2 ITEM COUNT CURRENTLY ZERO 00935000 SPACE 00936000 * WE SEARCH THROUGH THE FILE, SKIPPING OVER THE COMMENT CARDS, 00937000 * LOOKING FOR THE FIRST REAL CONTROL CARD, WHICH HAD BETTER BE A 00938000 * 'MACS' CARD. 00939000 * GET AN AREA TO SAVE THE AUXFILE FILETYPES THAT ARE 00944000 * USED TO INSURE THAT NONE OF THEM WILL BE USED TWICE 00945000 LR R0,R8 EASIER IF AMOUNT IS IN REG 0 @V60C5CC 00946000 DMSFREE DWORDS=(0),ERR=CTLRCRD @V60C5CC 00947000 ST R1,LISTADR ADDRESS OF FREE'D LIST @V60C5CC 00948000 MVI 0(R1),LISTMARK NEXT AVAILABLE SLOT @V60C5CC 00949000 CTLRCRD DS 0H ERROR WILL CAUSE NO-CHECKING @V60C5CC 00950000 LA R2,1(,R2) INCREMENT ITEM COUNT @VA11994 00950100 CLR R2,R8 ARE WE AT END OF FILE? @VA11994 00950200 BH ERMACS ERROR -- NO 'MACS' CARD @VA11994 00950300 FSREAD FSCB=CTLFILE,RECNO=(R2),ERROR=INPERR READ A RECORD 00951000 CLI CTLBUFF,C'*' IS THIS CARD A COMMENT? 00952000 BE CTLRCRD LOOP BACK IF IT IS @VA11994 00953000 ST R2,MACSITEM SAVE ITEM NUMBER OF 'MACS' CARD 00954000 LA R1,CTLBUFF INITIALIZE FOR SCAN ROUTINE 00955000 ST R1,CTLBUFF+80 ... 00956000 BAL R14,SCANCTL FIRST PARM MUST BE THE DEFAULT... 00957000 BNZ BADCTLC ...LEVEL IDENTIFIER PARM 00958000 CLI ACTVFLD+5,X'40' FIVE CHARS IS MAX... 00959000 BNE BADCTLC OOPS...SORRY 00960000 MVC UPLEVEL(5),ACTVFLD SET THE DEFAULT 00961000 MVC DFLEVEL(5),ACTVFLD MAKE THIS ID @V2D4821 00962000 BAL R14,SCANCTL SECOND FIELD... 00963000 BNZ ERMACS THIS FIELD SHOUL READ 'MACS' P3059 00964000 CLC ACTVFLD(8),=CL8'MACS ' IF NOT THIS... 00965000 BNE ERMACS ...IT'S AN INVALID CARD @VA01031 00966000 L R1,CTLBUFF+80 PICK UP RESIDUAL SCAN POINTER 00967000 LA R3,CTLBUFF+SEQFELD-1 END OF VALID RECORD 00968000 SLR R3,R1 COMPUTE LENGTH-1 OF REMAINING DATA 00969000 LA R2,CTLMACS MOVE THE MACLIB LIST HERE 00970000 EX R3,MVCR2R1 ... 00971000 * GPR 8 STILL HOLDS TOTAL ITEM COUNT OF FILE 00972000 LA R8,1(,R8) POINT ONE RECORD BEYOND 00973000 STH R8,CTLFILE+ITEM FROM HERE ON, WE READ FROM BOTTOM... 00974000 * ...TO THE TOP, APPLYING AS WE GO 00975000 EJECT 00976000 CTLREAD EQU * READ NEXT LEVEL CONTROL STATEMENT 00977000 LH R2,CTLFILE+ITEM DECREMENT ITEM NUMBER FOR FILE 00978000 BCTR R2,0 00979000 STH R2,CTLFILE+ITEM 00980000 FSREAD FSCB=CTLFILE,ERROR=INPERR READ CARD FROM CONTROL FILE 00981000 C R2,MACSITEM HAVE WE JUST RED OUR 'MACS' CARD 00982000 BNH CTLDONE WE'RE THRU IF WE HAVE 00983000 CLI CTLBUFF,C'*' COMMENT CARD ? 00984000 BE CTLREAD YES - READ AGAIN 00985000 LA R1,CTLBUFF SETUP FOR SCAN ROUTINE 00986000 ST R1,CTLBUFF+80 ... 00987000 BAL R14,SCANCTL FIND FIRST FIELD ( LEVEL ID ) 00988000 BNZ BADCTLC ...OOPS... 00989000 CLI ACTVFLD+5,X'40' FIVE CHARS IS MAX 00990000 BNE BADCTLC ... 00991000 CLC ACTVFLD(4),=C'PTF ' IS THIS A PTF @V2D4821 00992000 BE CTLIPTF YES SPECIAL PROC @V2D4821 00993000 MVC DFLEVEL(5),ACTVFLD SAVE LEVEL ID HERE 00994000 BAL R14,SCANCTL LOOK FOR UPDATE MODIFIER 00995000 BO CTLREAD DUMMY RECORD FOR LOAD @VA01031 00996000 BM BADCTLC INVALID CONTROL CARD @VA01031 00997000 CLC ACTVFLD(8),=CL8'MACS ' 'MACS' RECORD? @VA01031 00998000 BE ERMACS YES - FINISHED @VA01031 00999000 MVC UPDFILE+16(8),=CL8'UPDT....' FILETYPE SKELETON 01000000 CLC ACTVFLD(4),=CL4'UPDT' UPDT TYPE ?? @V200930 01001000 BNE CTLAUX NO, TEST FOR AUX FILE @V200930 01002000 CLI ACTVFLD+4,C' ' IS IT UPDT ONLY ?? @V200930 01003000 BE CTLUP YES, CONT @V200930 01004000 CTLUPD MVC UPDFILE+16(8),ACTVFLD SET FILETYPE @V200930 01005000 MVC UPDFILE+24(2),=C'* ' SEARCH ALL DISKS @V200930 01006000 B CTLOCUP GO FIND FILE @V200930 01007000 CTLAUX CLC ACTVFLD(3),=CL3'AUX' AUX FILE TYPE ?? @V200930 01008000 BNE CTLUP NO, CONT @V200930 01009000 CLI ACTVFLD+3,C' ' IS IT AUX ONLY ?? @V200930 01010000 BE CTLUP YES, CONT @V200930 01011000 CLI ACTVFLD+8,C' ' NO RESTRICTION ON FTYPE LENGTH @VA04536 01012000 BNE BADCTLC @VM03203 01013000 MVC AUXFILE+16(8),ACTVFLD SET FILETYPE @V200930 01014000 MVC AUXFILE+24(2),=C'* ' SEARCH ALL DISKS @V200930 01015000 B AUXFIND GO FIND FILE @V200930 01016000 CTLUP DS 0H @V200930 01017000 MVC AUXSAVE,ACTVFLD SAVE THE MODIFIER @VA04536 01018000 CLI ACTVFLD+5,C' ' FIVE CHARACTERS MAX. @VA04536 01019000 BNE BADCTLC GREATER THAN 5 = ERROR @VA04536 01020000 MVC UPDFILE+20(4),ACTVFLD FILL IN MODIFIER 01021000 MVC UPDFILE+24(2),=C'* ' SEARCH ALL DISKS 01022000 BAL R14,SCANCTL NOW LOOK FOR OPTIONAL THIRD PARM 01023000 BO CTLOCUP MISSING - NORMAL UPDATE LEVEL @VA01031 01024000 BM BADCTLC INVALID CONTROL CARD @VA01031 01025000 CLC ACTVFLD(4),=C'AUX ' MAY BE THE 'AUX' OPTION 01026000 BNE CTLOCUP NO - ASSUME IT'S A COMMENT 01027000 B AUX OTHERWISE, IT'S AUX 01028000 SPACE 3 01029000 MACSITEM DS F ITEM NUMBER OF 'MACS' CARD 01030000 AUXSAVE DC CL5' ' SAVE AREA FOR 5 BYTE MODIFIER@VA04536 01031000 DS 0H REALIGN @VA04536 01032000 EJECT 01033000 * AUXILIARY FILE HAS BEEN SPECIFIED 01034000 AUX EQU * 01035000 MVC AUXFILE+19(5),AUXSAVE MOVE IN 5 CHAR. MODIFIER @VA04536 01036000 MVC AUXSAVE,=C' ' BLANK OUT SAVE AREA FOR NEXT @VA04536 01037000 MVC AUXFILE+24(2),=C'* ' SEARCH ALL DISKS 01038000 AUXFIND DS 0H @V200930 01039000 MVC FTSAVE,AUXFILE+16 SAVE IN CASE NOT AN AUXFILE @V60C5CC 01040000 AUXFIND1 DS 0H @V60C5CC 01041000 BAL R14,SCANCTL CHECK FOR ANOTHER PARM @V60C5CC 01042000 BNZ AUXFIND2 NOT A POSSIBLE FILE-TYPE @V60C5CC 01043000 CLI ACTVFLD+3,C' ' PARM AT LEASE 4 CHARACTERS? @V60C5CC 01044000 BE AUXFIND2 NO, USE INDICATED AUXFILE @V60C5CC 01045000 MVC AUXFILE+16(8),ACTVFLD STATE PREFERRED AUXFILE @V60C5CC 01046000 LA R1,AUXFILE FST FOR STATE @V60C5CC 01047000 BAL R14,LOCATE DOES PREFERRED FILE EXIST? @V60C5CC 01048000 B AUXFIND1 NO, CHECK FOR MORE LEVELS @VA09764 01049000 B CTLREAD YES, DON'T USE THIS AUXFILE @V60C5CC 01050000 AUXFIND2 DS 0H @V60C5CC 01051000 MVC AUXFILE+16(8),FTSAVE PREFERRED ONE. @V60C5CC 01052000 LA R1,AUXFILE ... 01053000 BAL R14,LOCATE IF IT'S THERE, WE WILL APPLY THE PTFS 01054000 B CTLREAD IF IT ISN'T, WE JUST SKIP THE LEVEL 01055000 * SCAN LIST OF AUXFILE FILETYPES TO 01056000 * INSURE WE DON'T TRY TO RE-USE ONE 01057000 L R1,LISTADR START OF LIST (OR 0) @V60C5CC 01058000 LTR R1,R1 DID WE INITIATE A LIST? @V60C5CC 01059000 BZ AUXFIND5 NO LIST. USE THE AUXFILE @V60C5CC 01060000 AUXFIND3 DS 0H @V60C5CC 01061000 CLI 0(R1),LISTMARK THIS SLOT UNUSED? @V60C5CC 01062000 BNE AUXFIND4 SLOT IN USE, CHECK THE ENTRY @V60C5CC 01063000 MVC 0(8,R1),FTSAVE SLOT FREE. INSERT FILETYPE @V60C5CC 01064000 MVI 8(R1),LISTMARK MARK NEXT SLOT AS AVAILABLE @V60C5CC 01065000 B AUXFIND5 UNIQUE AUXFILE. USE IT @V60C5CC 01066000 AUXFIND4 DS 0H CHECK THIS ENTRY @V60C5CC 01067000 CLC 0(8,R1),FTSAVE AUXFILE APPLIED BEFORE? @V60C5CC 01068000 BE CTLREAD YES, GET NEXT CNTRL ENTRY @V60C5CC 01069000 LA R1,8(R1) INCREMENT TO NEXT SLOT @V60C5CC 01070000 B AUXFIND3 CHECK NEXT LIST ENTRY @V60C5CC 01071000 AUXFIND5 DS 0H @V60C5CC 01072000 OI UPDFLAG,AUXF FOUND AN AUXILIARY FILE 01073000 L R1,AUXFILE+PFST FST POINTER FOR AUX FILE 01074000 LH R8,ITEM(0,R1) TOTAL ITEM COUNT IN AUX FILE 01075000 STH R8,AUXFILE+ITEM READ BOTTOM TO TOP 01076000 MVI TEMPSWT,X'00' RESET THE SWITCH @VA13438 01076500 EJECT 01077000 AUXREAD EQU * READ FROM AUXILIARY FILE 01078000 LH R4,AUXFILE+ITEM CHECK FOR TOP OF FILE 01079000 LTR R4,R4 AT THE TOP NOW ? 01080000 BNP AUXFINT YES - AUX LEVEL IS COMPLETE 01081000 * THE READ MUST BE TO A BUFFER TO ENABLE SAVING THE COMMENTS 01082000 FSREAD FSCB=AUXFILE,ERROR=INPERR,BUFFER=CTLBUFF @V60C5CC 01083000 BCTR R4,0 DECREMENT FOR UPWARD READ 01084000 STH R4,AUXFILE+ITEM RESET FOR NEXT READ 01085000 CLI CTLBUFF,C'*' COMMENT RECORD ? 01086000 BE AUXREAD YES - CONTINUE READING 01087000 LA R1,CTLBUFF SETUP FOR SCAN ROUTINE 01088000 ST R1,CTLBUFF+80 ... 01089000 BAL R14,SCANCTL FIND FIRST PARM 01090000 BNZ BADAUXC BAD CONTROL CARD 01091000 CLC ACTVFLD(4),=C'PTF ' IS IT THE OPTIONAL KEYWORD ? 01092000 BNE AUXTYPE NO - MUST BE 'A....6CA' FORMAT 01093000 BAL R14,SCANCTL SECOND PARM IS FILETYPE 01094000 BNZ BADAUXC ...OOPS... 01095000 AUXTYPE EQU * LOOK FOR SPECIFIED PTF 01096000 MVC UPDFILE+16(8),ACTVFLD FULL FILETYPE 01097000 MVC UPDFILE+24(2),=CL2'*' SEARCH ALL DISKS FOR PTM FILE 01098000 LA R1,UPDFILE GO CHECK FILE STATUS 01099000 BAL R14,LOCATE ... 01100000 B NOFILEW WARNING MSG IF MISSING 01101000 MVC UPLEVEL(5),DFLEVEL FOUND AT LEAST ONE UPDATE HERE 01102000 B CTLUMSG GO GIVE INFO MSG + APPLY UPDATE 01103000 AUXFINT EQU * FINISHED WITH 'AUX' LEVEL 01104000 FSCLOSE FSCB=AUXFILE CLOSE THE AUX FILE 01105000 NI UPDFLAG,X'FF'-AUXF RESET FLAG BIT 01106000 B CTLREAD AND CONTINUE WITH CONTROL FILE 01107000 EJECT 01108000 CTLOCUP EQU * STATE FOR SINGLE UPDATE FILE 01109000 CLI AUXSAVE+4,C' ' ONLY 4 BYTES FOR 'UPDT' TYPE @VA04536 01110000 BNE BADCTLC IF 5 = ERROR @VA04536 01111000 LA R1,UPDFILE SEE IF UPDATE FILE EXISTS 01112000 BAL R14,LOCATE ... 01113000 B CTLREAD NO - SKIP TO NEXT LEVEL 01114000 * FOUND AN UPDATE - NOW LET'S APPLY IT 01115000 MVC UPLEVEL(5),DFLEVEL SET LEVEL IDENTIFIER 01116000 B CTLUMSG GO GIVE INFO MSG + APPLY 01117000 CTLIPTF EQU * SINGLE PTF SPECIFIED IN CNTRL FILE 01118000 BAL R14,SCANCTL POINT TO PTF NAME @V2D4821 01119000 BNE CTLREAD SOMETHING FISHY @V2D4821 01120000 MVC UPDFILE+16(8),ACTVFLD FULL FILETYPE 01121000 MVC UPDFILE+24(2),=C'* ' SEARCH ALL DISKS 01122000 LA R1,UPDFILE 01123000 BAL R14,LOCATE 01124000 B CTLREAD SKIP TO NEXT LEVEL IF NOT FOUND 01125000 B CTLUMSG SET MESSAGE @V200930 01126000 MVC UPLEVEL(5),DFLEVEL MAKE THIS LEV @V2D4821 01127000 EJECT 01128000 * WE TYPE OUT THE 'UPDATING' MESSAGE, AND ADD RECORDS TO 'UPDATES' 01129000 * FILE. 01130000 CTLUMSG EQU * 01131000 TM GLOBALS,UPDN HAS AN UPDATE BEEN DONE? 01132000 BO CTLUMSS IF SO, THEN TYPE SHORT MESSAGE 01133000 TM UPDFLAG,INCOR IN-CORE PROCESSING WANTED?? @V2D4821 01134000 BNO SLOPPY NOPE... INCUR SOME OVERHEAD. @VM03203 01135000 USING NUCON,R0 @VM03203 01136000 IC R5,DOSFLAGS GET NUCON'S DOSFLAGS @VM03203 01137000 NI DOSFLAGS,255-DOSSVC TURN OFF DOS SVC HANDLE @VM03203 01138000 STC R5,DOSF TEMPORARILY STORE DOSFLAGS @VM03203 01139000 BAL R8,CORINIT GO INITIALIZE STORAGE @VM03203 01140000 FSSTATE FSCB=INPFILE @VM03203 01141000 LH R8,26(,R1) NUMBER OF ITEMS IN FILE @V2D4821 01142000 LA R8,50(,R8) PLUS SOME SLACK @V2D4821 01143000 C R8,SPARES WILL THE FILE FIT?? @V2D4821 01144000 BH SMALLCOR NOPE @V2D4821 01145000 XC INPFILE+ITEM(2),INPFILE+ITEM ZERO ITEM NUMBER @V2D4821 01146000 LA R0,800 GET STORAGE FOR RDBUF OF 10 RECS. @V2D4821 01147000 GETMAIN R,LV=(0) @V2D4821 01148000 ST R1,INPFILE+28 BUFAD @V2D4821 01149000 ST R0,INPFILE+32 BUFSIZE @V2D4821 01150000 LA R0,10 NUMBER OF RECS. WE'LL READ @V2D4821 01151000 STH R0,INPFILE+38 STORE INTO PLIST @V2D4821 01152000 LR R3,R1 SAVE BUFAD @V2D4821 01153000 * 01154000 INPLOOP FSREAD FSCB=INPFILE,ERROR=INPLERR @V2D4821 01155000 LR R2,R3 BUFFER STARTING ADDR. @V2D4821 01156000 LR R5,R0 NUM. OF BYTES ACTUALLY READ @V2D4821 01157000 LA R4,80 ITEM LENGTH @V2D4821 01158000 AR R5,R2 END ADDR. FOR BXLE @V2D4821 01159000 SR R5,R4 @V2D4821 01160000 * 01161000 INPL002 LR R1,R2 FOR XWRITE (ADDR. OF LINE) @V2D4821 01162000 BAL R14,XWRITE WRITE LINE INTO CORE @V2D4821 01163000 BXLE R2,R4,INPL002 @V2D4821 01164000 B INPLOOP READ SOME MORE STUFF @V2D4821 01165000 * 01166000 INPLERR CH R15,=H'12' TRUE E-O-F FROM RDBUF?? @V2D4821 01167000 BNE INPERR NO... @V2D4821 01168000 LR R1,R3 BUFFER ADDRESS @V2D4821 01169000 LA R0,800 BUFFER SIZE @V2D4821 01170000 FREEMAIN R,LV=(0),A=(1) @V2D4821 01171000 FSCLOSE FSCB=INPFILE @V2D4821 01172000 * 01173000 SLOPPY EQU * @V2D4821 01174000 LA R1,=CL8'CONWAIT' GIVE MESSAGES A CHANCE @VM03093 01175000 SVC 202 TO CATCH UP ... @VM03093 01176000 DMSERR NUM=178,LET=I,RENT=NO, *01177000 SUB=(CHAR8A,INPFILE+8), *01178490 TEXT='UPDATING ''....................''' HRC012DS 01178980 DMSERR NUM=178,LET=I,RENT=NO, *01179470 SUB=(CHAR8A,UPDFILE+8), *01179960 TEXT='APPLYING ''....................''' HRC012DS 01180450 FSERASE FSCB=UPSFILE ERASE ANY EXISTING UPDATES FILE 01181000 B CTLUF GO FINISH UP 01182000 SPACE 2 01183000 * WE HAVE ALREADY DONE A WHOLE UPDATE, SO WE TYPE ONLY THE SHORT 01184000 * MESSAGE. 01185000 CTLUMSS EQU * 01186000 LA R1,=CL8'CONWAIT' GIVE MESSAGES A CHANCE @VM03093 01187000 SVC 202 TO CATCH UP ... @VM03093 01188000 DMSERR NUM=178,LET=I,SUB=(CHAR8A,UPDFILE+8), *01189000 TEXT='APPLYING ''....................''' HRC012DS 01190490 SPACE 01191000 * NEXT, WE MUST ADD RECORDS TO THE 'UPDATES' FILE. THE FIRST RECORD IS 01192000 * THE CARD FROM THE CONTROL FILE, WHILE THE SECOND IS THE DATA ABOUT 01193000 * THE FILE FROM THE FST. 01194000 CTLUF EQU * 01195000 CLI TEMPSWT,X'00' WE WRITE FIRST ONE YET? @V60C5CC 01196000 BNE TEMP1OK YEP... @V60C5CC 01197000 MVC TEMPSAVE(2),AUXFILE+ITEM SAVE ITEM NUMBER @V60C5CC 01198000 MVC AUXFILE+ITEM(2),=H'1' @V60C5CC 01199000 READNXT EQU * READ THE NEXT ITEM @VA13438 01199500 FSREAD FSCB=AUXFILE,BUFFER=TEMPBUF,ERROR=TEMP1OK @V60C5CC 01200000 CLI TEMPBUF,C'*' DONT WRITE IT UNLESS ITS A COMMENT @V60C5CC 01201000 BNE NOTCOMM NOT A COMMENT.... I DONT KNOW WHY. @V60C5CC 01202000 FSWRITE FSCB=UPSFILE,BUFFER=TEMPBUF,ERROR=OUTERR @V60C5CC 01203000 LH R1,AUXFILE+ITEM INCREMENT @VA13438 01203500 LA R1,1(,R1) ITEM @VA13438 01203550 STH R1,AUXFILE+ITEM COUNT @VA13438 01203600 B READNXT READ NEXT ITEM @VA13438 01203650 NOTCOMM MVC AUXFILE+ITEM(2),TEMPSAVE RESTORE ITEM COUNT @V60C5CC 01204000 MVI TEMPSWT,X'FF' SIGNAL ITS DONE. @V60C5CC 01205000 TEMP1OK DS 0H @V60C5CC 01206000 FSWRITE FSCB=UPSFILE,ERROR=OUTERR,BUFFER=CTLBUFF WRITE CTL CRD 01207000 L R1,UPDFILE+PFST POINT TO FST FOR FILE 01208000 L R2,UPDFILE+PADT POINT TO ADT FOR FILE 01209000 SPACE 01210000 * THE FOLLOWING CODE IS STOLEN. 01211000 MVC NAME(8),0(1) FILE NAME 01212000 MVC TYPE(8),8(1) FILETYPE 01213000 MVC MODE(2),24(1) FILEMODE 01214000 UNPK DATE+1(5),16(3,1) MMDD 01215000 MVC DATE(2),DATE+1 01216000 MVI DATE+2,C'/' 01217000 MVI DATE+5,C'/' 01218000 UNPK TIME+1(5),18(3,1) HHMM 01219000 MVC TIME(2),TIME+1 01220000 MVI TIME+2,C':' GO, PRINTER GO @V2D4821 01221000 MVI TIME+5,C' ' 01222000 MVC YEAR(2),38(1) YEAR 01223000 MVC LABEL(6),0(2) DISK LABEL 01224000 MVC MODE(1),68(2) CORRECT DISK MODE LETTER 01225000 LH R4,AUXFILE+ITEM GET MODIFIED ITEM COUNT. @V60C5CC 01226000 STH R4,TEMPSAVE SAVE IT FOR RESTORE. @V60C5CC 01227000 LA R4,2(R4) POINT TO 1ST POSS. COMMENT. @V60C5CC 01228000 STH R4,AUXFILE+ITEM POINT AT IT... @V60C5CC 01229000 TEMPRD FSREAD FSCB=AUXFILE,ERROR=TEMPERR,BUFFER=TEMPBUF @V60C5CC 01230000 LA R4,1(R4) POINT TO NEXT RECORD. @V60C5CC 01231000 STH R4,AUXFILE+ITEM POINT AT IT. @V60C5CC 01232000 CLI TEMPBUF,C'*' COMMENT? @V60C5CC 01233000 BNE TEMPERR CLEAN UP AND LEAVE @V60C5CC 01234000 FSWRITE FSCB=UPSFILE,ERROR=OUTERR,BUFFER=TEMPBUF @V60C5CC 01235000 B TEMPRD GET NEXT ONE. @V60C5CC 01236000 TEMPERR LH R4,TEMPSAVE GET OLD POINTER. @V60C5CC 01237000 STH R4,AUXFILE+ITEM RESTORE IT AND BYE... @V60C5CC 01238000 NOTTEMP DS 0H @V60C5CC 01239000 FSWRITE FSCB=UPSFILE,ERROR=OUTERR,BUFFER=OUT WRITE OUT LINE 01240000 FSCLOSE FSCB=AUXFILE CLOSE THE AUX FILE. @VA14010 01240500 B SINGUPD GO PERFORM AN UPDATE 01241000 TEMPSAVE DC H'0' TEMPORARY ITEM-COUNT SAVE @V60C5CC 01242000 TEMPBUF DC CL80' ' MY VERY OWN BUFFER. @V60C5CC 01243000 TEMPSWT DC X'00' SWITCH FOR FIRST RECORD. @V60C5CC 01244000 DS 0H ALIGNMENT... @V60C5CC 01245000 SPACE 01246000 OUT DC C'*' 01247000 DC CL9' ' TO ALIGN FIELDS ON LOAD MAP 01248000 NAME DC CL9' ' 01249000 TYPE DC CL9' ' 01250000 MODE DC CL3' ' 01251000 LABEL DC CL7' ' 01252000 DATE DC CL6' ' 01253000 YEAR DC CL4' ' 01254000 TIME DC CL6' ' 01255000 DC CL27' ' 01256000 DS 0H 01257000 EJECT 01258000 CTLCONT EQU * MULTI-LEVEL UPDATE CONTINUATION 01259000 NI UPDFLAG,AUXF+INCOR PRESERVE ONLY TWO BITS. @V2D4821 01260000 MVI UPDFLAG2,0 RESET FINISH INDICATOR @V2D4821 01261000 TM UPDFLAG,AUXF WORKING WITH AUX @V2D4821 01262000 BO AUXREAD YES @V2D4821 01263000 B CTLREAD CONTINUE WITH CONTROL FILE 01264000 EJECT 01265000 CTLDONE EQU * MULTI-LEVEL UPDATE IS COMPLETE 01266000 * FRET THE AUXFILE-USED LIST IF IT IS PRESENT 01267000 L R1,LISTADR WAS AUXFILE LIST FREE'D @V60C5CC 01268000 LTR R1,R1 WAS LIST OBTAINED? @V60C5CC 01269000 BZ CTLDONE1 NO LIST, CONTINUE @V60C5CC 01270000 L R1,CTLFILE+PFST FST FOR CNTRL FILE @V60C5CC 01271000 LH R0,ITEM(0,R1) CNTRL LENGTH (LIST DWORDS) @V60C5CC 01272000 L R1,LISTADR @V60C5CC 01273000 DMSFRET DWORDS=(0),LOC=(1) @V60C5CC 01274000 CTLDONE1 DS 0H @V60C5CC 01275000 FSCLOSE FSCB=CTLFILE CLOSE THE CONTROL FILE 01276000 TM GLOBALS,NSTK SHOULD WE STACK THE RESULTS ? 01277000 BO RETURN NO -- RETURN 01278000 CMS STACKER SETUP FOR MACLIB LIST ALREADY 01279000 LA R1,UPLEVEL-2 NOW STACK THE UPDATE LEVEL ID 01280000 ST R1,STACKER+12 ... 01281000 MVI STACKER+12,7 LENGTH = 7 01282000 CMS STACKER ... 01283000 B RETURN RETURN 01284000 EJECT 01285000 UPDFERR EQU * EOF OR ERROR ON UPDATE FILE 01286000 LA R1,UPDFILE PTR IN CASE OF REAL ERROR 01287000 CH R15,=H'12' IS IT SIMPLE END OF FILE ? 01288000 BNE INPERR NO - A REAL ERROR 01289000 FSCLOSE FSCB=UPDFILE CLOSE THE UPDATE FILE 01290000 OI UPDFLAG,TAIL PROCESSING NORMAL END OF FILE 01291000 MVC SEQSTRT(8),FENCED THIS IS MAXIMUM NUMBER 01292000 TM UPDFLAG,INCOR IN-CORE UPDATE ??? @V2D4821 01293000 BNO INPUTRD NOPE.. GOT TO FLUSH INPUT FILE TO OUTP@V2D4821 01294000 TM UPDFLAG,RSEQ ARE WE RE-SEQUENCING ??? @V2D4821 01295000 BO INPUTRD YES.. WE'LL HAVE TO REPLACE SOME LINES @V2D4821 01296000 OI UPDFLAG2,FINISH 1 PASS FLAG @V2D4821 01297000 B INPUTRD TO CHK FOR SEQ ERRS @V2D4821 01298000 UPDFERR3 LA R15,12 SIM EOF @V2D4821 01299000 * ON INPUTRD 01300000 EJECT 01301000 INPFERR EQU * EOF OR I/O ERROR - INPFILE 01302000 LA R1,INPFILE PTR IN CASE OF REAL ERROR 01303000 CH R15,=H'12' SIMPLE END OF FILE ? 01304000 BNE INPERR NO - A REAL ERROR 01305000 FSCLOSE FSCB=UT1FILE CLOSE THE UTILITY FILE 01306000 FSCLOSE FSCB=INPFILE CLOSE THE INPUT FILE 01307000 TM UPDFLAG,TAIL WAS THIS EOF EXPECTED ? 01308000 BO UPDEND JUST FINISH UP IF SO 01309000 SPACE 01310000 * IF WE REACH A PREMATURE EOF ON A FILE, WE TYPE A WARNING MESSAGE 01311000 * AND GO ON. 01312000 BAL R14,CTLTYPE TYPE OUT THE LAST UPDATE CTL CRD 01313000 LA R14,SEQSTRT POINT TO STARTING SEQ NUMBER 01314000 TM UPDFLAG,DELT BUT WAS IT A DELETE RANGE? 01315000 BZ *+8 SKIP IF IT WAS A COPY 01316000 LA R14,SEQLAST POINT TO LAST SEQ NUM, INSTEAD 01317000 SPACE 01318000 LA R10,1(,R10) INCREMENT R10 TEMPORARILY 01319000 * NOTE THAT R10 CONTAINS THE LENGTH (5 OR 8) OF THE SEQ FIELD. 01320000 DMSERR DISP=NONE,LET=W,NUM=10,BUFFA=ERRBUFF,RENT=NO, *01321000 SUB=(CHAR8A,INPFILE+8,CHARA,((R14),(R10))), *01322000 TEXT='PREMATURE EOF ON FILE ''....................'' -- *01323000 SEQ NUMBER ''........'' NOT FOUND' 01324000 BCTR R10,0 RESET REGISTER 10 01325000 BAL R14,BUFFOUT TYPE AND PRINT MESSAGE 01326000 WARN 12 SET RETURN CODE TO 12 01327000 EJECT 01328000 * WE HAVE FINISHED AN UPDATE. WE CLEAN UP AND GO ON TO NEXT. 01329000 UPDEND EQU * 01330000 LA R15,NEWNAME POINT TO NEW NAME 01331000 TM UPDFLAG,INCOR INCORE UPDATE ??? @V2D4821 01332000 BO UPDENDA YES @V2D4821 01333000 FSERASE (R15) ERASE OLD COPY OF IT 01334000 CMS RENAME RENAME CMSUT FILE TO NEW NAME 01335000 MVC INPFILE+8(18),NEWNAME INPUT FILE IS NEW SOURCE FILE 01336000 UPDENDA EQU * @V2D4821 01337000 BAL R14,XCLOSE REWIND IN-CORE FILE @V2D4821 01338000 OI GLOBALS,UPDN INDICATE THAT AN UPDATE IS DONE 01339000 SPACE 01340000 TM GLOBALS,CTLF IS 'CTL' OPTION IN EFFECT? 01341000 BO CTLCONT GO FOR NEXT CONTROL CARD 01342000 EJECT 01343000 * WE ARE FINISHED ALL UPDATING. 01344000 RETURN EQU * 01345000 TM GLOBALS,UPDN WAS ANY UPDATE FILE FOUND? 01346000 BZ NOUPDATS ERROR IF NOT 01347000 TM UPDFLAG,INCOR IN-CORE UPDATE ??? @V2D4821 01348000 BNO RETR002 NOPE.. @V2D4821 01349000 MVC RDMVC(6),=XL6'470000000700' NO-OP MVC INTO INPL@V2D4821 01350000 * 01351000 RETR001 BAL R14,XREAD GET A LINE FRON CORE @V2D4821 01352000 B RETRD RETURN HERE ON E-O-F @V2D4821 01353000 LA R6,8(,R1) @V2D4821 01354000 ST R6,UT1FILE+28 STORE LINE ADDRESS INTO RDBUF PLI@V2D4821 01355000 FSWRITE FSCB=UT1FILE,ERROR=OUTERR @V2D4821 01356000 B RETR001 RETURN FOR NEXT @V2D4821 01357000 * 01358000 RETRD FSCLOSE FSCB=UT1FILE @V2D4821 01359000 LA R15,NEWNAME ERASE $FNAME @V2D4821 01360000 FSERASE (R15) @V2D4821 01361000 CMS RENAME REN CMSUT1 TO $FNAME @V2D4821 01362000 RETR002 EQU * @V2D4821 01363000 CLC RETCODE,=F'0' ANY WARNING MESSAGES ISSUED? 01364000 BNE WRETURN GO IF YES 01365000 TM GLOBALS,REPL WAS 'REPLACE' SPECIFIED? 01366000 BZ RRETURN NOTHING TO DO IT NOT 01367000 SPACE 01368000 * OTHERWISE, WE MUST ERASE THE OLD FILE, AND RENAME THE $FNAME FILE TO 01369000 * THE ORIGINAL FNAME. 01370000 MVC RENAME+8(18),NEWNAME SET UP RENAME PLIST 01371000 MVC NEWNAME(8),FNAME 01372000 LA R15,NEWNAME POINT TO NEWNAME 01373000 FSERASE (R15) ERASE OLD COPY OF IT 01374000 CMS RENAME RENAME NEW SOURCE 01375000 SPACE 01376000 * RESTORE REG AND RETURN 01377000 RRETURN EQU * 01378000 BAL R14,LOGCLOSE CLOSE THE LOG FILE 01379000 FSCLOSE FSCB=UPSFILE CLOSE THE UPDATES FILE @VA04077 01380000 L R1,FREEAD GET ADDRESS OF FREE STORAGE BLOCK@VM03203 01381000 LTR R1,R1 DID WE GETMAIN ??? @VM03203 01382000 BZ NOFRMN @VM03203 01383000 IC R5,DOSF GET SAVED DOSFLAGS @VM03203 01384000 STC R5,DOSFLAGS STORE BACK IN NUCON @VM03203 01385000 L R0,FREELEN LENGTH OF BLOCK @VM03203 01386000 FREEMAIN R,LV=(0),A=(1) @VM03203 01387000 NOFRMN EQU * @VM03203 01388000 OI MISFLAGS,RELPAGES TELL DMSINT WE CAN GO AWAY, @VM03093 01389000 DMSKEY RESET UN-DO OUR KEY MANIPULATING, @VM03093 01390000 L R14,SAVE14 GET RETURN ADDRESS, @VM03093 01391000 L R15,RETCODE GET RETURN CODE 01392000 BR R14 AND RETURN TO CALLER 01393000 SPACE 3 01394000 SAVE14 DS A SAVE RETURN ADDRESS HERE 01395000 RETCODE DC F'0' RETURN CODE FROM UPDATE COMMAND 01396000 RC EQU RETCODE+3 FOR 'MVI' INSTRUCTION 01397000 EJECT 01398000 * IN CASE WARNING MESSAGES WERE ISSUED, THEN WE DON'T DO A REPLACE. 01399000 * FURTHERMORE, IF THE GUY SPECIFIED 'NOTERM', SO HE DIDN'T GET THE 01400000 * MESSAGES, THEN WE TELL HIM WHAT HAPPENED, WHETHER HE WANTS IT OR NOT. 01401000 WRETURN EQU * 01402000 TM GLOBALS,TERM DID HE SPECIFY 'NOTERM' 01403000 BZ WRETURN1 IF SO, DEFINITELY GIVE HIM A MSG 01404000 TM GLOBALS,REPL DID HE SPECIFY 'REPLACE'? 01405000 BZ RRETURN NO MESSAGE NECESSARY IF NOT 01406000 SPACE 01407000 WRETURN1 EQU * 01408000 SR R2,R2 ASSUME SHORT MESSAGE 01409000 TM GLOBALS,REPL DID HE ASK FOR 'REPLACE'? 01410000 BZ *+8 SKIP IF NOT 01411000 LA R2,L'WMSG THEN GIVE HIM THE LONG MSG 01412000 SPACE 01413000 DMSERR NUM=177,LET=I,RENT=NO, *01414000 SUB=(DECA,RETCODE,CHARA,(WMSG,(R2))), *01415000 TEXT='WARNING MESSAGES ISSUED (SEVERITY = ......).......*01416000 ...............' P3027 01417000 B RRETURN 01418000 SPACE 2 01419000 WMSG DC C'. ''REP'' OPTION IGNORED' P3027 01420000 DS 0H 01421000 EJECT 01422000 * COME HERE ON ERROR TO ABORT UPDATE PROGRAM. 01423000 ERETURN EQU * 01424000 BAL R14,LOGCLOSE CLOSE THE LOG FILE 01425000 FSCLOSE FSCB=INPFILE CLOSE THE INPUT FILE 01426000 FSCLOSE FSCB=UPDFILE CLOSE THE UPDATE FILE 01427000 FSCLOSE FSCB=UT1FILE CLOSE THE CMSUT FILE 01428000 TM GLOBALS,CTLF 'CTL' OPTION SPECIFIED? 01429000 BZ RRETURN GO RETURN IF NOT 01430000 FSCLOSE FSCB=CTLFILE CLOSE THE CONTROL FILE 01431000 FSCLOSE FSCB=UPSFILE CLOSE THE UPDATES FILE 01432000 TM UPDFLAG,AUXF 'AUX' FILE IN PROGRESS? 01433000 BZ RRETURN RETURN IF NOT 01434000 FSCLOSE FSCB=AUXFILE CLOSE THE AUXILIARY FILE 01435000 B RRETURN GO RETURN TO COMMAND LEVEL 01436000 EJECT 01437000 SINGUPD EQU * INTERNAL SINGLE-UPDATE ROUTINE 01438000 MVC SEQFOLD(5),PAKZERO START RE-SEQUENCE AT ZERO 01439000 MVC SEQPOSN(8),CZEROES FILE POSITIONED AT ZERO 01440000 MVC SEQSTRT(8),CZEROES ... 01441000 MVC ISEQLAST(8),CZEROES ... 01442000 MVC OSEQLAST(8),CZEROES ... 01443000 MVI PASSFLG,0 01444000 MVC UPDFILE+ITEM(2),=H'0' START WITH ZERO ITEM NUMBER 01445000 MVC INPFILE+ITEM(2),=H'0' DITTO FOR INPUT FILE P3027 01446000 MVC CURRLINE,=A(MAXLINE) FORCE PAGE EJECT 01447000 BAL R14,XCLOSE REWIND POSSIBLE IN-CORE CMSUT1 FILE@V2D4821 01448000 SPACE 01449000 UPDREAD EQU * START READING UPDATE CONTROL CARDS 01450000 UPITEM UPDFILE INCREMENT ITEM NUMBER 01451000 FSREAD FSCB=UPDFILE,ERROR=UPDFERR READ A CARD 01452000 UPDCTLC EQU * UPDATE CONTROL CARD IS IN BUFFER 01453000 NI UPDFLAG,X'FF'-(SGEN+DELT) P3027 01454000 LA R1,UPDLINE+2 BUFFER START 01455000 ST R1,UPDLINE+80 SET FOR SCAN ROUTINE 01456000 SPACE 01457000 * PUT THE CONTROL CARD INTO THE LOG FILE. 01458000 LOG UPDLINE,CTL 01459000 SPACE 01460000 * SAVE THE CONTROL CARD IN THE 'LAST CONTROL CARD' FIELD, FOR USE IN 01461000 * ERROR MESSAGES. 01462000 MVC PREVCTLL(82),LASTCTLL CURRENT LAST BECOMES PREV P3027 01463000 MVC LASTCTLL,UPDLINE COPY CONTROL CARD 01464000 MVC LASTCTLI,UPDFILE+ITEM SAVE THE ITEM NUMBER ALSO 01465000 SPACE 01466000 CLC UPDLINE(3),=CL3'./ ' UPDATE CONTROL CARD ? 01467000 BNE INVUPCD NO - MUST BE INVALID 01468000 MVC UPDLINE+50(22),BLANKS LAST 22 COLUMNS ARE INVALIDP3027 01469000 BAL R14,SCANUPD SCAN FIRST FIELD ( FUNCTION ) 01470000 BNZ INVUPCD NO MORE FIELDS - INVALID CARD 01471000 MVC UPDCODE(1),ACTVFLD MOVE FUNCTION CHARACTER 01472000 CLI ACTVFLD+1,X'40' MORE THAN ONE CHAR.... 01473000 BNE INVUPCD ...MAKES IT AN INVALID CARD 01474000 * 01475000 * DECODE REQUESTED UPDATE FUNCTION 01476000 * 01477000 CLI UPDCODE,C'S' RE-SEQUENCE OUTPUT FILE ? 01478000 BE FCTRSEQ YES 01479000 * 01480000 CLI UPDCODE,C'R' REPLACE SOURCE RECORDS ? 01481000 BE FCTDELT YES - DELETE + INSERT 01482000 * 01483000 CLI UPDCODE,C'I' INSERT NEW RECORDS ? 01484000 BE FCTINST YES 01485000 * 01486000 CLI UPDCODE,C'D' DELETE RECORDS FROM SOURCE ? 01487000 BE FCTDELT YES 01488000 * 01489000 CLI UPDCODE,C'*' IS IT A COMMENT CARD? 01490000 BE UPDREAD JUST SKIP IT IF SO 01491000 * OOPS... IT'S AN INVALID CARD 01492000 EJECT 01493000 * INVALID CONTROL CARD 01494000 INVUPCD EQU * 01495000 BAL R14,CTLTYPE TYPE OUT THE INVALID CARD 01496000 DMSERR DISP=NONE,BUFFA=ERRBUFF,NUM=207,LET=W, P3059*01497000 TEXT='INVALID UPDATE FILE CONTROL CARD' 01498000 SPACE 01499000 * ENTER HERE FOR OTHER WARNING MESSAGES 01500000 INVUPCD1 EQU * 01501000 BAL R14,BUFFOUT TYPE AND PRINT ERROR MESSAGE 01502000 WARN 12 SET RETURN CODE TO 12 01503000 UPITEM UPDFILE INCREMENT ITEM NUMBER 01504000 FSREAD FSCB=UPDFILE,ERROR=UPDFERR READ NEXT RECORD FROM FILE 01505000 CLC =CL2'./',UPDLINE IS THIS A CONTROL CARD? 01506000 BE UPDCTLC GO PROCESS IT IF SO 01507000 SPACE 01508000 * OTHERWISE, WE LOG THE CARDS WE SKIP WITH THE CUE OF 'IGNORING'. 01509000 LOG UPDLINE,CUE,'IGNORING...' 01510000 SPACE 01511000 INVULUP EQU * 01512000 UPITEM UPDFILE 01513000 FSREAD FSCB=UPDFILE,ERROR=UPDFERR READ NEXT UPDATE CARD 01514000 CLC =CL2'./',UPDLINE IS IT A CONTROL CARD? 01515000 BE UPDCTLC GO PROCESS IT IF SO 01516000 LOG UPDLINE LOG THE IGNORED LINE 01517000 B INVULUP AND GO FOR NEXT RECORD 01518000 EJECT 01519000 RSEQERR EQU * 01520000 BAL R14,CTLTYPE TYPE OUT LAST CONTROL CARD 01521000 DMSERR NUM=184,LET=W,BUFFA=ERRBUFF,DISP=NONE, *01522000 TEXT='''./ S'' NOT FIRST CARD IN UPDATE FILE -- IGNORED' 01523000 B INVUPCD1 01524000 SPACE 3 01525000 UPDSERR EQU * 01526000 BAL R14,CTLTYPE TYPE LAST CONTROL CARD 01527000 * IF 'DELT' FLAG IS OFF, THEN WE WERE LOOKING FOR FIRST SEQUENCE 01528000 * NUMBER IN UPDATE CONTROL CARD; OTHERWISE, WE WERE LOOKING FOR 01529000 * THE 2ND (THE END OF THE DELETE OR REPLACE RANGE). 01530000 LA R14,SEQSTRT ASSUME FIRST SEQ NUMBER P3027 01531000 TM UPDFLAG,DELT WERE WE DELETING? P3027 01532000 BZ *+8 SKIP IF NOT P3027 01533000 LA R14,SEQLAST ELSE, POINT TO 2ND SEQ # P3027 01534000 LA R10,1(,R10) INCREMENT REG 10 TEMPORARILP3027 01535000 DMSERR DISP=NONE,BUFFA=ERRBUFF,LET=W,NUM=186, *01536000 SUB=(CHARA,((R14),(R10))), P3027*01537000 TEXT='SEQUENCE NUMBER ''........'' NOT FOUND' P3027 01538000 BCTR R10,0 RESTORE VALUE IN REG 10 P3027 01539000 B INVUPCD1 01540000 SPACE 3 01541000 INVCHAR EQU * 01542000 BAL R14,CTLTYPE TYPE LAST CONTROL CARD 01543000 DMSERR BUFFA=ERRBUFF,DISP=NONE,NUM=185,LET=W, *01544000 SUB=(CHARA,ACTVFLD), *01545000 TEXT=('INVALID ', P3059*01546000 'CHAR IN SEQUENCE FIELD ''.........''') P3059 01547000 B INVUPCD1 01548000 EJECT 01549000 * TYPE WARNING MESSAGE FOR ZERO SEQUENCE INCREMENT 01550000 ZERSEQ EQU * 01551000 ST R14,Z14 SAVE RETURN ADDRESS 01552000 BAL R14,CTLTYPE TYPE LAST CONTROL CARD 01553000 DMSERR BUFFA=ERRBUFF,DISP=NONE,NUM=182,LET=W, *01554000 TEXT='SEQUENCE INCREMENT IS ZERO' 01555000 BAL R14,BUFFOUT TYPE AND PRINT MESSAGE 01556000 WARN 8 SET RETURN CODE TO 8 01557000 L R14,Z14 RESTORE RETURN ADDR 01558000 BR R14 01559000 SPACE 01560000 Z14 DS A 01561000 EJECT 01562000 * 01563000 * RE-SEQUENCE THE OUTPUT FILE - REQUESTED VIA UPDATE CARD: 01564000 * ./ S STARTNO INCREMENT LABEL 01565000 * (E.G. -- './ S 100 100 DMK ') 01566000 * 01567000 FCTRSEQ EQU * RE-SEQUENCE REQUEST 01568000 CLC SEQPOSN(8),CZEROES AT BEGINNING OF INPUT FILE ? 01569000 BNE RSEQERR NO - './ S' MUST BE FIRST 01570000 BAL R14,SCANUPD FIND STARTING SEQUENCE NO. 01571000 BO RSEQDEF SET DEFAULTS @VA01031 01572000 BM INVUPCD INVALID UPDATE CARD @VA01031 01573000 BAL R14,JUSTIFY JUSTIFY + VALIDATE THE FIELD 01574000 LA R4,SEQFOLD DESTINATION 01575000 EX R10,PACKACV PACK ACTIVE FIELD INTO SEQFOLD 01576000 BAL R14,SCANUPD FIND INCREMENT 01577000 BO RSEQIDF DEFAULT THE INCREMENT @VA01031 01578000 BM INVUPCD INVALID UPDATE CARD @VA01031 01579000 BAL R14,JUSTIFY JUSTIFY + VALIDATE 01580000 LA R4,SEQINCR DESTINATION 01581000 EX R10,PACKACV PACK INTO SEQINCR 01582000 CP SEQINCR,=P'0' IS THE INCREMENT POSITIVE? 01583000 BP *+8 SKIP IF NON-ZERO INCREMENT 01584000 BAL R14,ZERSEQ TYPE WARNING MESSAGE 01585000 BAL R14,SCANUPD FIND THREE-CHARACTER LABEL, IF ANY 01586000 BO RSEQLDF NONE - SET DEFAULT @VA01031 01587000 BM INVUPCD INVALID UPDATE CARD @VA01031 01588000 CLI ACTVFLD+3,X'40' THREE-CHARS IS MAXIMUM 01589000 BNE INVUPCD BAD CARD 01590000 MVC SEQLABL(3),ACTVFLD SAVE THE LABEL 01591000 B RSEQFIN GO FINISH CHECKING 01592000 RSEQDEF EQU * DEFAULT EVERYTHING 01593000 ZAP SEQFOLD,=PL4'10' DEFAULT FIVE-DIGIT START 01594000 TM GLOBALS,SEQ8 IS IT EIGHT-DIGIT ? 01595000 BZ RSEQIDF NO 01596000 ZAP SEQFOLD,=PL4'1000' DEFAULT EIGHT-DIGIT START 01597000 RSEQIDF EQU * DEFAULT INCREMENT + LABEL 01598000 MVC SEQINCR(5),SEQFOLD INCREMENT = START NUMBER 01599000 RSEQLDF EQU * DEFAULT THREE-CHAR LABEL 01600000 MVC SEQLABL(3),INPFILE+8 = FIRST THREE CHARS OF NAME 01601000 RSEQFIN EQU * FINAL VALIDATION OF PARMS 01602000 CP SEQMAX,SEQFOLD DOES SEQ. EXCEED MAX P3059 01603000 BNL CONST NO, CONTINUE PROCESSING P3059 01604000 ZAP SEQFOLD,SEQINCR RESTART AT BEGINNING P3059 01605000 LA R0,INPLINE+SEQFELD POINT TO LAST SEQ. NO. P3059 01606000 BAL R14,WOVF WARN USER OF OVERFLOW P3059 01607000 CONST EQU * P3059 01608000 UNPK SEQNEXT(8),SEQFOLD(5) CONSTRUCT FIRST FIELD 01609000 OI SEQNEXT+7,X'F0' FORCE EBCDIC 01610000 AP SEQFOLD(5),SEQINCR(5) UPDATE FOR NEXT CARD 01611000 BNP INVUPCD INVALID UPDATE CARD 01612000 OI UPDFLAG,RSEQ RE-SEQUENCE THE OUTPUT FILE 01613000 B UPDREAD ...AND CONTINUE WITH UPDATE FILE 01614000 EJECT 01615000 * 01616000 * INSERT UPDATE RECORDS IN THE SOURCE FILE - REQUESTED VIA: 01617000 * ./ I SEQNUM $ START INCR 01618000 * 01619000 FCTINST EQU * INSERT FUNCTION 01620000 BAL R14,SCANUPD FIND FIRST FIELD = SEQUENCE NO. 01621000 BNZ INVUPCD INVALID CARD IF NOT THERE 01622000 BAL R14,JUSTIFY RIGHT-JUSTIFY 01623000 LA R8,UPDREAD RETURN IN CASE OF SEQ. ERROR 01624000 EX R10,SEQCHEK VALIDATE UPDATE SEQUENCE 01625000 MVC SEQSTRT(8),ACTVFLD MOVE TO STARTING POSITION P3059 01626000 BH UPDSERR NO GOOD -- SORRY 01627000 FCTREPL EQU * ENTRY FOR SECOND HALF OF REPLACE 01628000 BAL R14,SCANUPD SEE IF UPDATE SEQUENCE REQUESTED 01629000 BO INSTINE NO - JUST A SIMPLE INSERT @VA01031 01630000 BM INVUPCD INVALID UPDATE CARD @VA01031 01631000 CLC ACTVFLD(2),=C'$ ' DOLLAR SIGN ? 01632000 BNE INVUPCD NO - INVALID CARD 01633000 OI UPDFLAG,SGEN GENERATE SEQUENCE FOR UPDATE 01634000 ZAP UPDSTRT,PAKZERO INITIALIZE START NUMBER 01635000 BAL R14,SCANUPD ANY OPTIONS GIVEN ? 01636000 BO INDFGEN NO - USE DEFAULTS @VA01031 01637000 BM INVUPCD INVALID UPDATE CARD @VA01031 01638000 BAL R14,JUSTIFY THIS MUST BE ALL NUMERICS 01639000 LA R4,UPDSTRT DESTINATION 01640000 EX R10,PACKACV PACK STARTING NUMBER 01641000 BAL R14,SCANUPD ANY INCREMENT GIVEN ? 01642000 BO INDFGEN NO - USE DEFAULT INCREMENT @VA01031 01643000 BM INVUPCD INVALID UPDATE CARD @VA01031 01644000 BAL R14,JUSTIFY JUSTIFY + VALIDATE 01645000 LA R4,UPDINCR DESTINATION 01646000 EX R10,PACKACV PACK THE INCREMENT 01647000 CP UPDINCR,=P'0' ZERO INCREMENT???? @VA10579 01648100 BP *+8 SKIP IF NON-ZERO SEQ NUMBER 01649000 BAL R14,ZERSEQ TYPE WARNING MESSAGE 01650000 B INSTINE GO START ACTUAL INSERT 01651000 INDFGEN EQU * SET DEFAULTS FOR UPDATE SEQUENCING 01652000 L R4,FENCED GPR 4 = F'-1' 01653000 LA R3,SEQSTRT(R10) END OF SEQUENCE FIELD 01654000 LR R5,R3 WE WANT TO LIMIT THE SCAN TO AVOID.. 01655000 SH R5,=H'3' ...A PROBLEM WITH EVEN-TENS CARDS 01656000 LA R14,1 FIRST GUESS AT INCREMENT @V2D4821 01657000 INDFINC EQU * INCREMENT = (LEAST SIGNIFICANT DIGIT)/10 01658000 CLI 0(R3),C'0' LOOK FOR LAST NON-ZERO DIGIT 01659000 BNE INDFGOT 01660000 SLL R14,4 INCREMENT TIMES 10 @V2D4821 01661000 BXH R3,R4,INDFINC CONTINUE BACKWARD SCAN 01662000 LA R14,X'100' USE DEFAULT INCREMENT OF P'1000' @V2D4821 01663000 SLL R14,4 @V2D4821 01664000 INDFGOT EQU * FOUND LEAST SIG. DIGIT 01665000 STCM R14,B'1111',UPDINCR+1 SET INCREMENT @V2D4821 01666000 MVI UPDINCR,X'00' ...FOR GENERATION 01667000 OI UPDINCR+4,X'0C' ADD DECIMAL SIGN 01668000 CP UPDSTRT(5),PAKZERO(5) WAS START DEFAULTED ? 01669000 BNE INSTINE NO - READY TO START INSERTING 01670000 EX R10,PACKUPD PACK SEQSTRT INTO UPDSTRT 01671000 AP UPDSTRT(5),UPDINCR(5) SET DEFAULT START NUMBER 01672000 EJECT 01673000 INSTINE EQU * START ACTUAL INSERTION 01674000 CLI UPDCODE,C'I' IS THIS AN EXPLICIT INSERT ? 01675000 BNE INSLOOP NO - WE'RE IN THE RIGHT PLACE ALREADY 01676000 LA R8,INSBAL RETURN ADDR FROM INPUTRD... V0026 01677000 CLC ITEM+INPFILE(2),=H'0' HAS ANY RECORD BEEN READ ? V0026 01678000 BE INPUTER NO..BEWARE OF SEQ. ALL ZEROS V0026 01679000 B INPUTRD POSITION THE INPUT FILE. V0026 01680000 INSBAL EQU * V0026 01681000 BAL R7,CONDPASS COND. WRITE OUT LAST RECORD @V2D4821 01682000 INSLOOP EQU * INSERT UNTIL NEXT './' CARD 01683000 UPITEM UPDFILE INCREMENT ITEM NUMBER 01684000 FSREAD FSCB=UPDFILE,ERROR=UPDFE001 @V2D4821 01685000 CLC UPDLINE(3),=CL4'./ ' CONTROL CARD ? 01686000 BE INSCTL YES -- INSERT IS COMPLETE P3027 01687000 TM GLOBALS,INCL INCLUDE SEQUENCE FROM UPDATE ? 01688000 BZ SETSTAR NO - USE ASTERISKS 01689000 TM UPDFLAG,SGEN GENERATE SEQUENCE ? 01690000 BZ INSWLOG NO - USE IT AS IS 01691000 UNPK UPDNEXT(8),UPDSTRT(5) UNPACK SEQUENCE NUMBER 01692000 OI UPDNEXT+7,X'F0' FORCE NUMERIC 01693000 MVC UPDLINE+SEQFELD(8),UPDNEXT FULL EIGHT-DIGIT SEQ. 01694000 TM GLOBALS,SEQ8 CHECK TO MAKE SURE 01695000 BO INSGSEQ YES 01696000 MVC UPDLINE+SEQFELD(3),SEQLABL SET LABEL ALSO 01697000 INSGSEQ EQU * CALCULATE NEXT SEQUENCE FIELD 01698000 AP UPDSTRT(5),UPDINCR(5) INCREMENT 01699000 CP UPDSTRT,SEQMAX NEXT SEQ # EXCEED THE MAX? P3027 01700000 BL INSWLOG BO IF NOT P3027 01701000 SPACE 1 01702000 * OTHERWISE, THE HAVE SEQUENCE NUMBER OVERFLOW 01703000 LA R0,UPDLINE+SEQFELD POINT TO LAST CORRECT SEQ #P3027 01704000 ZAP UPDSTRT,UPDINCR RESTART AT BEGINNING 01705000 BAL R14,WOVF GO TYPE OUT WARNING MESSAGE 01706000 EJECT 01707000 INSWLOG EQU * SET NEW FILE POSITION 01708000 LA R4,UPDLINE+SEQFELD+7 01709000 SLR R4,R10 BACK UP TO START OF FIELD 01710000 EX R10,MVCPOSN RECORD CURRENT POSITION 01711000 B INSTLOG 01712000 SPACE 01713000 SETSTAR EQU * DO NOT INCLUDE SEQUENCE FIELDS 01714000 MVC UPDLINE+SEQFELD(8),=CL8'********' 01715000 INSTLOG EQU * 01716000 TM UPDFLAG,FULL IS THERE DATA ALREADY IN BUFFER ? 01717000 BO INSWUT1 YES - THIS IS NOT THE FIRST LINE 01718000 NI UPDFLAG,X'FF'-FULI INDICATE DATA IS FROM UPDATE FIL 01719000 LOG UPDLINE,CUE,'INSERTING...' FIRST LINE + CUE MSG 01720000 B INSETXT GO SETUP FOR CONTINUED INSERT 01721000 INSWUT1 EQU * WRITE PREVIOUS LINE TO CMSUT1 01722000 BAL R7,PASSOVR 01723000 LOG UPDLINE WRITE CURRENT LINE TO LOGFILE 01724000 INSETXT EQU * MOVE INSERTED LINE TO 'INPLINE' 01725000 MVC INPLINE(80),UPDLINE THIS IS AN INSERTION 01726000 OI UPDFLAG,FULL BUFFER CONTAINS DATA 01727000 B INSLOOP CONTINUE WITH INSERTION 01728000 SPACE 01729000 INSCTL EQU * 01730000 BAL R7,PASSOVR WRITE OUT LAST INSERTED CARD 01731000 B UPDCTLC GO HANDLE CONTROL CARD 01732000 UPDFE001 TM UPDFLAG,INCOR IN-CORE UPDATE @V2D4821 01733000 BNO UPDFERR NOPE @V2D4821 01734000 BAL R7,PASSOVR WRITE OUT THE LAST RECORD @V2D4821 01735000 LA R15,12 SIMULATE E-O-F @V2D4821 01736000 B UPDFERR @V2D4821 01737000 EJECT 01738000 * 01739000 * DELETE RECORDS FROM THE INPUT FILE - CONTROL CARD IMAGE: 01740000 * ./ D SEQNO1 <$> 01741000 * DELETE FROM SEQNO1 UP TO AND INCLUDING SEQNO2 01742000 * 01743000 FCTDELT EQU * DELETE FUNCTION 01744000 BAL R14,SCANUPD FIND FIRST SEQUENCE FIELD 01745000 BNZ INVUPCD INVALID IF IT'S MISSING 01746000 L R1,UPDLINE+80 SAVE SCAN POINTER IN CASE OF REPLACE 01747000 ST R1,REPSCAN 01748000 BAL R14,JUSTIFY ADJUST + VALIDATE 01749000 LA R8,UPDREAD RETURN IN CASE OF SEQ. ERROR 01750000 EX R10,SEQCHEK VALIDATE UPDATE SEQUENCE 01751000 MVC SEQSTRT(8),ACTVFLD MOVE TO START SLOT P3059 01752000 BH UPDSERR NO GOOD -- SORRY 01753000 MVC SEQLAST(8),ACTVFLD DEFAULT ENDING SLOT, ALSO 01754000 BAL R14,SCANUPD SEE IF ANY SECOND FIELD 01755000 BO DELTINE NO - JUST DELETE ONE LINE @VA01031 01756000 BM INVUPCD INVALID UPDATE CARD @VA01031 01757000 CLC ACTVFLD(2),=C'$ ' IF IT'S A DOLLAR SIGN... 01758000 BE DELTINE ...JUST DELETE A SINGLE LINE 01759000 BAL R14,JUSTIFY OTHERWISE, ADJUST IT 01760000 MVC SEQLAST(8),ACTVFLD SET LAST SEQUENCE FIELD 01761000 L R1,UPDLINE+80 SAVE SCAN POINTER IN CASE OF REPLACE 01762000 ST R1,REPSCAN ... 01763000 DELTINE EQU * POSITION THE FILE FOR DELETION 01764000 EX R10,CHKRANG CHECK FOR VALID RANGE SPECIFICATION 01765000 BH INVUPCD N.G. -- START HIGHER THAN END 01766000 BAL R8,INPUTRD POSITON FILE AT 'SEQSTRT' 01767000 OI UPDFLAG,DELT INDICATE DELETE IN PROGRESS 01768000 NI UPDFLAG,X'FF'-FULL BUFFER SHOULD NOT BE WRITTEN 01769000 LOG INPLINE,CUE,'DELETING... ' FIRST LINE + CUE MSG 01770000 TM UPDFLAG,INCOR IN-CORE UPDATE ??? @V2D4821 01771000 BNO DELTINP NOPE.. @V2D4821 01772000 BAL R14,XDELE DELETE LINE FROM CHAIN @V2D4821 01773000 NOP 0 @V2D4821 01774000 EJECT 01775000 DELTINP EQU * READ, DO NOT WRITE 01776000 EX R10,CLCDELT FINISHED YET ? 01777000 BE DELTFIN YES - CLEAN UP 01778000 BAL R14,XREAD READ A LINE @V2D4821 01779000 B INPFERR GO IF ERROR @V2D4821 01780000 CLC INPLINE+SEQFELD(8),BLANKS IS IT BLANK SEQUENCE ? 01781000 BE DELTOVR YES - SKIP OVER IT 01782000 LA R4,INPLINE+SEQFELD+7 01783000 SLR R4,R10 BACK UP TO START OF SEQUENCE 01784000 EX R10,MVCPOSN RECORD NEW FILE POSITION 01785000 EX R10,CLCDELT DID WE MISS SEQNO2 ? @VA05353 01786000 BNL DELCHEK NO; SKIP @VA05353 01787000 EX R10,MVCILAST YES; RECORD INPUT FILE'S SEQ # @VA05353 01788000 OI UPDFLAG,FULL MUSTN'T DELETE THIS LINE @VA05353 01789000 B UPDSERR BUT TELL 'EM SEQNO2 NOT FOUND @VA05353 01790000 SPACE 1 01791000 * WE CHECK TO SEE IF SEQUENCE NUMBERS IN INPUT FILE ARE ASCENDING 01792000 DELCHEK EX R10,CLCILAST @VA05353 01793000 BL *+8 SKIP IF NO SEQUENCE ERR P3027 01794000 BAL R14,INSEQW GO TYPE OUT WARNING MSG P3027 01795000 EX R10,MVCILAST SAVE VALUE OF INPUT SEQ # P3027 01796000 DELTOVR TM UPDFLAG,INCOR UPDATING IN STORAGE? @VA05353 01797000 BZ DELTLOG NO; SKIP @VA05353 01798000 BAL R14,XDELE YES; REMOVE LINE FROM CHAIN @VA05353 01799000 NOP 0 @VA05353 01800000 DELTLOG LOG INPLINE LOG THE DELETED LINE @VA05353 01801000 B DELTINP DELETE BY PASSING OVER 01802000 DELTFIN EQU * CLEAN UP AFTER DELETE 01803000 NI UPDFLAG,X'FF'-DELT-FULL DELETE NOW COMPLETE 01804000 CLI UPDCODE,C'D' WAS IT A REAL DELETE ? 01805000 BNE REPFUNC NO REPLACE @V2D4821 01806000 BAL R14,XREAD UPD LINE PTR @V2D4821 01807000 B DELTEOF MIGHT BE EOF @VA05353 01808000 OI UPDFLAG,FULL+FULI BUFFER CONTAINS IP DATA @V2D4821 01809000 B DELTEND @VA05353 01810000 DELTEOF LA R1,INPFILE POINT TO PLIST IN CASE REAL ERR @VA05353 01811000 CH R15,=H'12' EOF? @VA05353 01812000 BNE INPERR NO; BAD NEWS @VA05353 01813000 DELTEND LA R4,INPLINE+SEQFELD+7 @VA05353 01814000 SLR R4,R10 BACK UP TO @V2D4821 01815000 * START OF SEQUENCE 01816000 EX R10,MVCPOSN RECORD NEW POS @V2D4821 01817000 EX R10,MVCILAST @V2D4821 01818000 B UPDREAD @V2D4821 01819000 EJECT @VA05353 01820000 * 01821000 * FOR REPLACE FUNCTION - SETUP AND TRANSFER TO 'INSERT' 01822000 * 01823000 REPFUNC L R1,REPSCAN POINTER TO RE-SCAN CONTROL CARD @VA05353 01824000 ST R1,UPDLINE+80 SET FOR SCAN ROUTINE 01825000 MVC SEQPOSN(8),SEQSTRT RESET FILE POSITION FOR 'INSERT' 01826000 B FCTREPL GO PERFORM INSERT HALF OF REPLACE 01827000 SPACE 2 01828000 PACKUPD PACK UPDSTRT(5),SEQSTRT(*-*) FOR INSERT 01829000 CLCDELT CLC SEQLAST(*-*),SEQPOSN FOR DELETE 01830000 CHKRANG CLC SEQSTRT(*-*),SEQLAST VALIDITY CHECK 01831000 SEQCHEK CLC SEQSTRT(*-*),ACTVFLD UPDATE INPUT SEQUENCE CHECK 01832000 PACKACV PACK 0(5,R4),ACTVFLD(*-*) PACK INTO SOMEWHERE 01833000 MVCR2R1 MVC 0(*-*,R2),0(R1) 01834000 MVCOLAST MVC OSEQLAST(*-*),0(R4) MOVE INTO OUTPUT SEQ # FIELD 01835000 EJECT 01836000 * 01837000 * INPUTRD -- SUBROUTINE TO POSITION THE INPUT FILE AT THE 01838000 * SEQUENCE NUMBER SPECIFIED IN 'SEQSTRT'. INPUT RECORDS 01839000 * ARE RE-SEQUENCED IF NECESSARY AND WRITTEN OUT TO THE 01840000 * 'UPDATE CMSUT1' FILE AS THEY ARE PASSED OVER. CHECKS ARE 01841000 * PERFORMED TO CATCH SEQUENCE ERRORS IN THE INPUT FILE. 01842000 * 01843000 INPUTRD EQU * POSITION FILE AT 'SEQSTRT' 01844000 LA R4,SEQSTRT MAYBE... 01845000 EX R10,CLCILAST ...WE'RE ALREADY WHERE WE WANT TO BE 01846000 BCR 8,R8 WHY, LO AND BEHOLD, WE ARE 01847000 BNL UPDSERR TYPE ERRMSG -- SEQ# NOT FNDP3027 01848000 SPACE 1 01849000 INPUTER EQU * READ UNTIL WE FIND IT 01850000 BAL R7,CONDPASS CONDITIONALLY WRITE DATA TO CMSUT1 @V2D4821 01851000 BAL R14,XREAD READ SOME INPUT @V2D4821 01852000 B INPFERR IF ERROR @V2D4821 01853000 OI UPDFLAG,FULL+FULI BUFFER CONTAINS INPUT FILE DATA 01854000 CLC INPLINE+SEQFELD(8),BLANKS WE SKIP BLANK CARDS 01855000 BE INPUTER YES INDEED 01856000 LA R4,INPLINE+SEQFELD+7 LAST BYTE OF FIELD 01857000 SLR R4,R10 BACK UP TO START OF NUMERICS 01858000 MVCPOSN MVC SEQPOSN(*-*),0(R4) UPDATE FILE POSITION @V2D4821 01859000 CLCILAST CLC ISEQLAST(*-*),0(R4) CHECK FOR LAST INPUT SEQ. #@V2D4821 01860000 BL *+8 SKIP IF LAST LOWER P3027 01861000 BAL R14,INSEQW TYPE OUT WARNING MESSAGE P3027 01862000 MVCILAST MVC ISEQLAST(*-*),0(R4) MOVE INTO INPUT SEQ. # FIEL@V2D4821 01863000 B INPUTRD GO SEE IF WE'VE FND TARGET P3027 01864000 EJECT 01865000 * 01866000 * PASSOVR -- WRITE A RECORD TO OUTPUT FILE, RE-SEQUENCING 01867000 * IF REQUESTED. BUFFER ADDRESS IN GPR6, RETURN IN GPR 7. 01868000 * 01869000 CONDPASS TM UPDFLAG,FULL IS BUFF FULL? @V2D4821 01870000 BCR 8,R7 NO RETURN @V2D4821 01871000 TM UPDFLAG,INCOR INCORE UPD? @V2D4821 01872000 BZ PASSOVR NO @V2D4821 01873000 TM UPDFLAG,RSEQ IF SO, ARE WE RESEQUENCING?? @V2D4821 01874000 BNO PASS1B NOPE.. @V2D4821 01875000 BAL R14,XDELE DO A LOGICAL REPLACE ON INPLINE @V2D4821 01876000 NOP 0 @V2D4821 01877000 B PASSOVR @V2D4821 01878000 * 01879000 PASSOVR EQU * WRITE THE RECORD TO CMSUT1 01880000 TM UPDFLAG,FULL IS THERE DATA IN THE BUFFER ? 01881000 BCR 8,R7 NO - JUST RETURN 01882000 TM UPDFLAG,RSEQ ARE WE RE-SEQUENCING ? 01883000 BZ PASSOUT NO - JUST RE-WRITE IT 01884000 MVC INPLINE+SEQFELD(8),SEQNEXT RE-SEQUENCE 01885000 UNPK SEQNEXT(8),SEQFOLD(5) SEQFOLD IS ALL SET 01886000 OI SEQNEXT+7,X'F0' FORCE TO EBCDIC 01887000 AP SEQFOLD(5),SEQINCR(5) UPDATE FOR NEXT LAP 01888000 CP SEQFOLD,SEQMAX COMPARE NEW SEQ# WITH MAX P3027 01889000 BL PASSNOV SKIP MESSAGE IF NO OVERFLOWP3027 01890000 ZAP SEQFOLD,SEQINCR RESET SEQUENCE NUMBER P3027 01891000 LA R0,INPLINE+SEQFELD POINT TO LAST OK SEQ # P3027 01892000 BAL R14,WOVF GO TYPE OVERFLOW MESSAGE P3027 01893000 SPACE 1 01894000 PASSNOV EQU * P3027 01895000 TM GLOBALS,SEQ8 SHOULD WE ADD THE LABEL ? 01896000 BO PASSOUT NO - LEAVE IT AS IS 01897000 MVC INPLINE+SEQFELD(3),SEQLABL ADD THREE-CHAR LABEL 01898000 PASSOUT EQU * 01899000 TM UPDFLAG,INCOR INCORE UPDATE ??? @V2D4821 01900000 BZ PASS1A NO @V2D4821 01901000 LA R1,INPLINE ADDRESS OF LINE TO BE WRITTEN @V2D4821 01902000 BAL R14,XWRITE CHAIN LINE INTO LIST @V2D4821 01903000 B PASS1B @V2D4821 01904000 PASS1A EQU * @V2D4821 01905000 FSWRITE FSCB=UT1FILE,ERROR=OUTERR WRITE UTILITY FILE 01906000 PASS1B EQU * @V2D4821 01907000 NI UPDFLAG,X'FF'-FULL BUFFER IS NOW EMPTY 01908000 SPACE 01909000 * WE NOW CHECK FOR SEQUENCE ERRORS. WE FIRST CHECK TO SEE IF THE NEW 01910000 * SEQUENCE NUMBER EXCEEDS THE LAST SEQUENCE NUMBER. 01911000 LA R4,INPLINE+SEQFELD+7 GET CURRENT SEQUENCE NUMBER 01912000 CLC INPLINE+SEQFELD(8),BLANKS BLANK SEQ. FILED? @VA05075 01913000 BE PASSSET YES SKIP THIS CARD @VA05075 01914000 SLR R4,R10 POINT TO ITS ADDR (COL 73 OR 76) 01915000 CLCOLAST CLC OSEQLAST(*-*),0(R4) MOVE INTO OUTPUT SEQ. # FIE@V2D4821 01916000 BL PASSSET NOTHING TO DO IF LAST WAS LOWER 01917000 SPACE 01918000 SPACE 1 01919000 * WE HAVE DISCOVERED A SEQUENCE ERROR. WE MUST DETERMINE WHETHER 01920000 * IT'S A VALID ERROR AND, IF SO, WHAT MESSAGE TO TYPE. 01921000 * FIRST, IF WE ARE RESEQUENCING (WITH ./ S), THEN IT'S DUE EITHER 01922000 * TO A ZERO SEQUENCE INCREMENT OR TO A SEQUENCE NUMBER OVERFLOW, 01923000 * AND SO THERE'S NO NEED FOR AN EXTRA ERROR MESSAGE. 01924000 TM UPDFLAG,RSEQ ARE WE RESEQUENCING? P3027 01925000 BO PASSSET GO IF NOT -- NOTHING TO DO P3027 01926000 SPACE 1 01927000 * NEXT, IF WE ARE NOT INCLUDING SEQUENCE NUMBERS, THEN WE DON'T 01928000 * FLAG THE PROBLEM. 01929000 TM GLOBALS,INCL ARE WE INCLUDING? P3027 01930000 BZ PASSSET NOTHING TO DO IF NOT P3027 01931000 SPACE 1 01932000 * THE NATURE OF THE ACTUAL ERROR DEPENDS UPON WHERE THE LAST TWO 01933000 * LINES OF OUTPUT CAME FROM -- THE INPUT FILE OR THE UPDATE FILE 01934000 * (THE LATTER IN THE CASE OF AN INSERT). 01935000 SR R1,R1 P3027 01936000 TM UPDFLAG,FULI IS CURRENT LINE FROM INPUT?P3027 01937000 BZ *+8 SKIP IF IT IS NOT P3027 01938000 LA R1,4 4 = THIS RECORD FROM INPUT P3027*01939000 FILE P3027 01940000 CLI PASSFLG,0 LAST RECORD FROM INPUTFILE?P3027 01941000 BNE *+8 SKIP IF NOT P3027 01942000 LA R1,8(,R1) ADD 8 IF PREV RECORD FROM P3027*01943000 INPUT FILE P3027 01944000 B *+4(R1) BRANCH BASED ON CASE P3027 01945000 B PASSUU 0 BOTH RECORDS FROM UPDATE P3027 01946000 B PASSUI 4 PREV FROM UPDATE, CURRENT P3027*01947000 FROM INPUT P3027 01948000 B PASSIU 8 PREV FROM INPUT, THIS FROM P3027*01949000 UPDATE P3027 01950000 B PASSSET 12 BOTH FROM INPUT -- A MSG P3027*01951000 HAS ALREADY BEEN TYPED P3027 01952000 SPACE 1 01953000 * COME HERE IF BOTH RECORDS ARE INSERTED FROM THE UPDATE FILE. 01954000 * THERE ARE TWO CASES HERE. 01955000 SPACE 1 01956000 * (1) BOTH CARDS ARE FROM THE SAME INSERT "GROUP". THIS @VA04290 01957000 * SITUATION CAN ONLY OCCUR IF THE SEQUENCE INCREMENT IS @VA04290 01958000 * ZERO, WHICH WOULD RESULT IN IDENTICAL SEQUENCE NUMBERS, @VA04290 01959000 * OR IF THE SEQUENCE NUMBER OVERFLOWED. FOR AN EXPLICIT @VA04290 01960000 * "INSERT", BOTH OF THESE SITUATIONS WOULD ALREADY HAVE @VA04290 01961000 * BEEN NOTED VIA AN ERROR MESSAGE, BUT FOR AN INSERTION @VA04290 01962000 * DUE TO A "REPLACE", NO SUCH MESSAGE WOULD HAVE BEEN @VA04290 01963000 * ISSUED, SO WE ISSUE ONE VIA "PASSIU". @VA04290 01964000 SPACE 1 @VA04290 01965000 * (2) THE TWO CARDS ARE FROM DIFFERENT INSERT GROUPS. IN @VA04290 01966000 * THIS CASE, BOTH THE PREVIOUS AND CURRENT CONTROL CARDS @VA04290 01967000 * ARE RELEVANT, SO WE DISPLAY THEM BOTH, THEN ISSUE THE @VA04290 01968000 * ERROR MESSAGE. @VA04290 01969000 PASSUU TM UPDFLAG,SGEN "$" IN LAST CONTROL CARD? @VA04290 01970000 BZ PASSIU NO; CONTINUE @VA04290 01971000 LH R1,UPDFILE+ITEM GET ITEM NUMBER OF THE @VA04290*01972000 CURRENT RECORD BEING INSERTED @VA04290 01973000 LA R1,0(,R1) CLEAR ANY HI-ORDER BYTE @VA04290 01974000 LH R2,LASTCTLI GET ITEM # OF LAST CONTROL CARD @VA04290 01975000 LA R2,3(,R2) INCREMENT IT FOR COMPARISON @VA04290 01976000 CLR R1,R2 MORE THAN 2 CARDS SINCE LAST @VA04290*01977000 CONTROL CARD? @VA04290 01978000 BH PASSSET YES; NOTHING ELSE TO DO @VA04290 01979000 BL PASSUU2 NO; MUST BE 2 DIFFERENT GROUPS @VA04290 01980000 CLI UPDCODE,C'R' NO; SAME GROUP; WAS IT "REPLACE"?@VA04290 01981000 BNE PASSSET NO; JUST CONTINUE @VA04290 01982000 B PASSIU YES; ISSUE MESSAGE THIS TIME @VA04290 01983000 PASSUU2 BAL R14,CTLPTYPE 2 GROUPS; TYPE PREVIOUS CTL CARD @VA04290 01984000 SPACE 1 01985000 * COME HERE IF PREVIOUS CARD WAS FROM THE INPUT FILE AND THE 01986000 * CURRENT CARD IS BEING INSERTED FROM THE UPDATE FILE. 01987000 PASSIU EQU * P3027 01988000 BAL R14,CTLTYPE TYPE LAST CONTROL CARD P3027 01989000 B PASSW GO TYPE WARNING MESSAGE P3027 01990000 SPACE 1 01991000 * COME HERE IF THE PREVIOUS CARD WAS FROM THE UPDATE FILE, BUT 01992000 * THE CURRENT CARD IS FROM THE INPUT FILE. IN THIS CASE, THERE IS 01993000 * NO NEED TO TYPE THE LAST CONTROL CARD, SO WE TYPE THE PREVIOUS 01994000 * CONTROL CARD. 01995000 PASSUI EQU * P3027 01996000 TM UPDFLAG,TAIL HAS EOF BEEN REACHED P3059 01997000 BO PASSIU YES, THEN TYPE OUT CURRENT CARD P3059 01998000 BAL R14,CTLPTYPE TYPE PREVIOUS CTL CARD P3027 01999000 SPACE 1 02000000 PASSW EQU * P3027 02001000 LA R10,1(,R10) INCREMENT R10 TEMPORARILY 02002000 DMSERR DISP=NONE,BUFFA=ERRBUFF,NUM=174,LET=W,RENT=NO, *02003000 SUB=(CHARA,(OSEQLAST,(R10)),CHARA,((R4),(R10))), *02004000 TEXT='SEQUENCE ERROR INTRODUCED IN OUTPUT FILE: ''......*02005000 ..'' TO ''........''' 02006000 BCTR R10,0 RESTORE VALUE IN R10 02007000 BAL R14,BUFFOUT TYPE AND PRINT MESSAGE 02008000 WARN 8 SET RETURN CODE TO 8 02009000 SPACE 3 02010000 * FINALLY, WE SET PASSFLG TO INDICATE WHETHER THE CURRENT LINE 02011000 * IS FROM THE INPUT FILE OR FROM THE UPDATE FILE. 02012000 PASSSET EQU * 02013000 MVI PASSFLG,0 ASSUME FROM INPUT FILE 02014000 TM UPDFLAG,FULI WAS IT? 02015000 BO *+8 SKIP IF SO 02016000 MVI PASSFLG,X'FF' IT'S FROM THE UPDATE FILE 02017000 EX R10,MVCOLAST COPY LAST OUTPUT SEQUENCE NUMBER 02018000 TM UPDFLAG2,FINISH ARE WE FINISHED? @V2D4821 02019000 BO UPDFERR3 YES @V2D4821 02020000 BR R7 RETURN TO CALLER 02021000 SPACE 2 02022000 * 0 IN THE FOLLOWING FLAG MEANS THAT THE LAST CARD WAS FROM THE INPUT 02023000 * FILE, WHILE FF MEANS IT WAS FROM THE UPDATE FILE. 02024000 PASSFLG DC X'00' 02025000 DS 0H 02026000 EJECT 02027000 * SUBROUTINE TO TYPE OUT THE WARNING MESSAGE INDICATING THAT A 02028000 * SEQUENCE ERROR WAS DETECTED IN THE INPUT FILE. 02029000 INSEQW EQU * P3027 02030000 CLC ITEM+INPFILE(2),=H'1' IF THIS IS FIRST RECORD V0026 02031000 BCR 8,R14 READ,THEN SEQ IS ALL ZEROS V0026 02032000 TM GLOBALS,UPDN HAVE WE ALREADY DONE AN P3027*02033000 UPDATE? P3027 02034000 BCR 1,R14 DON'T MENTION IT AGAIN P3027 02035000 ST R14,INSW14 SAVE OLD REG 14 P3027 02036000 BAL R14,CTLTYPE TYPE LAST CONTROL CARD P3027 02037000 LA R1,INPFILE TYPE CURRENT LINE FROM P3027 02038000 BAL R14,LINTYPE INPUT FILE P3027 02039000 LA R10,1(,R10) TEMPORARILY INCREASE R10 P3027 02040000 DMSERR DISP=NONE,BUFFA=ERRBUFF, P3027*02041000 LET=W,NUM=210,RENT=NO, P3027*02042000 SUB=(CHARA,(ISEQLAST,(R10)),CHARA,((R4),(R10))), P3027*02043000 TEXT=('INPUT FILE SEQUENCE ERROR:', P3027*02044000 ' ''........'' TO ''........''') P3027 02045000 BCTR R10,0 RESET R10 P3027 02046000 BAL R14,BUFFOUT PUT OUT THE MESSAGE P3027 02047000 WARN 4 SET RETURN CODE TO 4 P3027 02048000 L R14,INSW14 RESTORE REG 14 P3027 02049000 BR R14 RETURN TO CALLER P3027 02050000 SPACE 1 02051000 INSW14 DS F P3027 02052000 EJECT 02053000 * 'LOCATE' SUBROUTINE. CALLS THE CMS 'STATE' FUNCTION TO DETERMINE 02054000 * THE EXISTENCE OF A FILE. MAKES A NORMAL RETURN IF THE FILE EXISTS, 02055000 * AND A 'JUMP' RETURN IF IT DOES NOT. OTHER ERRORS (SUCH AS ILLEGAL 02056000 * FILEMODE) ARE ALSO DETECTED, WITH IMMEDIATE DETECTION AND PROGRAM 02057000 * TERMINATION. 02058000 LOCATE EQU * 02059000 LR R2,R1 SAVE PLIST POINTER 02060000 FSSTATE FSCB=(1),ERROR=LOCER CALL 'STATE' 02061000 SPACE 02062000 * R1 NOW POINTS TO THE STATE FST FOR THE FILE 02063000 USING STATEFST,R1 HRC015DS 02064100 L R15,FVSFSTAD Point to ADT for file HRC015DS 02064200 ST R15,PTRS(,R2) SAVE IN WORD AFTER FSCB 02065000 USING ADTSECT,R15 02066000 MVC 24(1,R2),ADTM GET THE RIGHT MODE LETTER 02067000 L R15,FVSFSTAC Address of real FST HRC015DS 02068100 DROP R1 HRC015DS 02068200 ST R15,PTRS+4(,R2) SAVE AFTER ADT POINTER 02069000 USING FSTSECT,R15 02070000 MVC 25(1,R2),FSTM+1 GET CORRECT MODE NUMBER 02071000 CLI FSTFV,C'F' IS THIS FIXED FILE? 02072000 BNE FMTERR BAD FORMAT IF NOT 02073000 CLC FSTIL,=F'80' ITEM LENGTH = 80? 02074000 BNE FMTERR BAD FORMAT IF NOT 02075000 B 4(,R14) GIVE A 'JUMP' RETURN 02076000 SPACE 2 02077000 * COME HERE ON AN ERROR RETURN FROM STATE. 02078000 LOCER EQU * 02079000 CH R15,=H'36' DISK NOT ACCESSED @VA12416 02079500 BE ERRMSG36 YES, ISSUE MSG69E @VA12416 02079600 CH R15,=H'28' IS IT 'FILE NOT FOUND'? 02080000 BCR 8,R14 (BE 0(R14)) JUST RETURN IF SO 02081000 CH R15,=H'1' 02082000 BCR 8,R14 02083000 SPACE 02084000 * OTHERWISE, IT'S SOME IMPORTANT ERROR. 02085000 STC R15,RC SAVE RETURN CODE FROM 'STATE' 02086000 B ERETURN GO ABORT 02087000 EJECT 02088000 *************************************************************** 02089000 ** 02090000 ** XWRITE--INSERT A LINE INTO CORE 02091000 ** 02092000 ** INPUT-- 02093000 ** R1--ADDRESS OF LINE TO BE WRITTEN 02094000 ** R14--RETURN ADDRESS 02095000 ** 02096000 ** OUTPUT-- 02097000 ** THE UPDATED LIST 02098000 ** PTR2=>INSERT (AS IF INSERT HAS JUST BEEN READ 02099000 ** (LINE JUST READ)=>INSERT=>(NEXT LINE) 02100000 ** 02101000 ** EXIT-- 02102000 ** RETURN VIA R14 02103000 ** RETURN THROUGH CORBUST IF CORE EXHAUSTED 02104000 ** 02105000 ** 02106000 *************************************************************** 02107000 SPACE 1 02108000 XWRITE EQU * @V2D4821 02109000 ST R14,REGSAV SAVE RETURN @V2D4821 02110000 L R14,SPARES NUMBER OF SPARES LEFT IN CORE @V2D4821 02111000 LTR R14,R14 ANY? @V2D4821 02112000 BZ CORBUST BRANCH IF NOT @V2D4821 02113000 BCTR R14,0 REDUCE BY 1 @V2D4821 02114000 ST R14,SPARES AND STORE AS NEW VALUE OF SPARES@V2D4821 02115000 L R15,FPTR LOAD FREE-LIST POINTER @V2D4821 02116000 LTR R15,R15 IS LIST EMPTY @V2D4821 02117000 BNZ XWRIT08 NO, WE'RE OK @V2D4821 02118000 L R15,AEXTEND LIMIT TO WHICH WE'VE GONE SO FAR@V2D4821 02119000 SR R0,R0 CLEAR FORWARD CHAIN OF NEW LINE@V2D4821 02120000 ST R0,0(,R15) @V2D4821 02121000 LR R0,R15 COMPUTE NEW BOUND @V2D4821 02122000 A R0,CORITEM @V2D4821 02123000 ST R0,AEXTEND AND SAVE IN AEXTEND @V2D4821 02124000 SPACE 1 02125000 XWRIT08 EQU * @V2D4821 02126000 L R0,0(,R15) LOAD NEXT ENTRY ADDRESS @V2D4821 02127000 ST R0,FPTR AND UPDATE FREE-LIST POINTER @V2D4821 02128000 MVC 8(80,R15),0(R1) MOVE IN THE LINE @V2D4821 02129000 L R1,PTR2 GR1=A(OLD ITEM) @V2D4821 02130000 ST R15,PTR2 READ PTR POINTS TO ITEM @V2D4821 02131000 L R14,0(,R1) GR14=A(OLD+1) @V2D4821 02132000 ST R14,0(,R15) E =>OLD+1 @V2D4821 02133000 LTR R14,R14 IS OLD+1=EOF @V2D4821 02134000 BZ SKIPINST YES, SKIP NEXT INS. @V2D4821 02135000 ST R15,4(,R14) NO, E <= OLD+1 @V2D4821 02136000 SKIPINST ST R1,4(,R15) OLD <= E @V2D4821 02137000 ST R15,0(,R1) OLD => E @V2D4821 02138000 L R14,SPARES @V2D4821 02139000 LTR R14,R14 HOW MANY SPARES LEFT? @V2D4821 02140000 BZ CORBUST BRANCH IF NONE @V2D4821 02141000 SR R15,R15 CLEAR CONDITION CODE @V2D4821 02142000 XWRITEX EQU * RETURN FROM 'XWRITE' @V2D4821 02143000 L R14,REGSAV RESTORE RETURN ADDRESS @V2D4821 02144000 BR R14 RETURN TO CALLER @V2D4821 02145000 SPACE 2 02146000 *************************************************************** 02147000 ** 02148000 ** XREAD--READ AN LINE FROM CORE 02149000 ** 02150000 ** INPUT-- 02151000 ** R14--RETURN ADDRESS 02152000 ** 02153000 ** OUTPUT-- 02154000 ** THE NEXT LINE IN 'INPLINE' 02155000 ** 02156000 ** EXITS-- 02157000 ** VIA R14 ONLY 02158000 ** 0(,R14) = END OF FILE 02159000 ** 4(,R14) = NORMAL READ 02160000 ** 02161000 ** 02162000 *************************************************************** 02163000 SPACE 1 02164000 XREAD EQU * @V2D4821 02165000 UPITEM INPFILE @V2D4821 02166000 TM UPDFLAG,INCOR IN-CORE FILE?? @V2D4821 02167000 BNO XREADF NO.. READ FROM DISK @V2D4821 02168000 ST R14,REGSAV SAVE R14 @V2D4821 02169000 BAL R14,XNEXT CALL XNEXT TO DO THE WORK @V2D4821 02170000 B XRDEOF @V2D4821 02171000 RDMVC MVC INPLINE(80),8(R1) MOVE DATA INTO INPLINE @V2D4821 02172000 * 02173000 XREADA EQU * SECONDARY ENTRY POINT @V2D4821 02174000 L R14,REGSAV RESTORE R14 @V2D4821 02175000 B 4(,R14) AND RETURN TO CALLER @V2D4821 02176000 * 02177000 XRDEOF L R14,REGSAV RESTORE R14 @V2D4821 02178000 LA R15,12 SET E-O-F RC @V2D4821 02179000 BR R14 RETURN TO EOF @V2D4821 02180000 SPACE 1 02181000 XREADF FSREAD FSCB=INPFILE,ERROR=XREADR @V2D4821 02182000 B 4(,R14) RETURN @V2D4821 02183000 XREADR BR R14 @V2D4821 02184000 EJECT 02185000 * 02186000 SPACE 2 02187000 *************************************************************** 02188000 ** 02189000 ** XNEXT -- CHAIN TO NEXT LINE IN CORE 02190000 ** WITHOUT MOVING THE CONTENTS 02191000 ** 02192000 ** CALL: 02193000 ** BAL 14,XNEXT 02194000 ** 02195000 ** ACTION: 02196000 ** SETS NEW VALUE OF READ POINTER (PTR2); 02197000 ** 02198000 ** EXIT: 02199000 ** BR R14 IF E-O-F DETECTED 02200000 ** B 4(,R14) NORMALLY 02201000 ** 02202000 ** 02203000 *************************************************************** 02204000 SPACE 1 02205000 XNEXT EQU * @V2D4821 02206000 L R15,PTR2 LOAD POINTER @V2D4821 02207000 L R1,0(,R15) PTR TO NEXT ITEM @V2D4821 02208000 LTR R1,R1 EOF? @V2D4821 02209000 BZ XNEXT1 BRANCH IF SO @V2D4821 02210000 ST R1,PTR2 SAVE NEW READ PTR @V2D4821 02211000 B 4(,R14) @V2D4821 02212000 SPACE 1 02213000 XNEXT1 EQU * @V2D4821 02214000 LR R1,R15 RETURN OLD PTR @V2D4821 02215000 BR R14 RETURN EOF @V2D4821 02216000 SPACE 2 02217000 *************************************************************** 02218000 ** 02219000 ** XDELE--DELETE LINE FROM CORE 02220000 ** 02221000 ** INPUT-- 02222000 ** R14--RETURN REGISTER 02223000 ** PTR2-- POINTS TO LINE TO BE REMOVED 02224000 ** 02225000 ** OUTPUT-- 02226000 ** MODIFIED LIST 02227000 ** 02228000 ** EXITS-- 02229000 ** RETURN VIA R14 ONLY 02230000 ** 02231000 ** 02232000 *************************************************************** 02233000 SPACE 1 02234000 XDELE EQU * @V2D4821 02235000 ST R14,REGSAV SAVE RETURN @V2D4821 02236000 L R1,PTR2 GR1=>DEL-1 @V2D4821 02237000 L R1,4(,R1) BACKUP ONE @V2D4821 02238000 ST R1,PTR2 UPDATE POINTER @V2D4821 02239000 L R15,FPTR LOAD FREE-LIST POINTER @V2D4821 02240000 L R2,0(,R1) GR2=>DEL @V2D4821 02241000 L R14,SPARES NUMBER OF SPARES @V2D4821 02242000 LA R14,1(,R14) ADD ONE @V2D4821 02243000 ST R14,SPARES AND SAVE AS NEW VALUE @V2D4821 02244000 L R14,0(,R2) NO, GR14=>DEL+1 @V2D4821 02245000 ST R14,0(,R1) DEL-1=>DEL+1 @V2D4821 02246000 LTR R14,R14 IS DEL+1=EOF @V2D4821 02247000 BZ NOBKCHN YES, DON'T BACK-CHAIN EOF @V2D4821 02248000 ST R1,4(,R14) NO, DEL-R1<=DEL+R1 @V2D4821 02249000 NOBKCHN ST R15,0(,R2) DEL=>FREE-LIST @V2D4821 02250000 ST R2,FPTR FPTR=>DEL @V2D4821 02251000 B XREADA AND RETURN THROUGH 'XREAD' @V2D4821 02252000 EJECT 02253000 * SUBROUTINE TO RIGHT-JUSTIFY AND PAD WITH ZEROES AN EIGHT- 02254000 * CHARACTER FIELD. ADJUSTED FOR EIGHT OR FIVE-DIGIT SERIALS. 02255000 * 02256000 JUSTIFY EQU * 02257000 STM R0,R5,20(R13) SAVE REGS IN SAVE AREA 02258000 LA R1,ACTVFLD SCAN THE ACTIVE PARAMETER 02259000 LA R4,1(0,0) INCREMENT... 02260000 LA R5,ACTVFLD+7 END OF SCAN 02261000 LM R2,R3,CZEROES UNPACKED DECIMAL ZEROES 02262000 JUSTLOP EQU * SCAN INPUT FIELD 02263000 CLI 0(R1),X'40' STOP ON A BLANK 02264000 BE JUSTEND 02265000 CLI 0(R1),C'0' MUST BE VALID NUMERICS 02266000 BL JUSTSET NO - SET TO ZERO 02267000 CLI 0(R1),C'9' ...THIS IS UPPER LIMIT 02268000 BNH JUSTNUM O.K. - LET IT PASS 02269000 JUSTSET EQU * SET INVALID NUMERIC TO ZERO 02270000 B INVCHAR INVALID CHAR IN SEQ. NUM P3059 02271000 JUSTNUM EQU * CONTINUE WITH JUSTIFICATION 02272000 SLDL R2,8(0) SHIFT LEFT ONE CHARACTER 02273000 IC R3,0(0,R1) INSERT ONE LOW-ORDER 02274000 BXLE R1,R4,JUSTLOP ADVANCE + CONTINUE 02275000 JUSTEND EQU * R2,R3 NOW CONTAIN JUSTIFIED FIELD 02276000 TM GLOBALS,SEQ8 EIGHT-DIGIT SEQUENCING ? 02277000 BO *+8 YES - USE FULL FIELD 02278000 SLDL R2,24(0) LEFT-JUSTIFY FIVE DIGITS FOR COMPARE 02279000 STM R2,R3,ACTVFLD REPLACE INPUT FIELD 02280000 LM R0,R5,20(R13) RESTORE REGS USED 02281000 BR R14 RETURN TO CALLER 02282000 EJECT 02283000 * 02284000 * SUBROUTINE TO SCAN OUT NEXT FIELD FROM UPDATE CONTROL CARD 02285000 * 02286000 SCANUPD EQU * SCAN FIELD FROM 'UPDLINE' 02287000 LA R1,UPDLINE BUFFER START 02288000 B NXTPARM 02289000 SCANCTL EQU * SCAN FIELD FROM 'CTLBUFF' 02290000 LA R1,CTLBUFF BUFFER START 02291000 SPACE 02292000 NXTPARM EQU * SCAN OUT BLANK-DELIMITED FIELDS 02293000 STM R0,R4,20(R13) SAVE VOLATILE REGISTERS 02294000 LR R4,R1 SAVE BUFFER START ADDRESS 02295000 LA R3,SEQFELD-1(0,R1) LAST BYTE TO BE SCANNED 02296000 LA R2,1(0,0) INCREMENT... 02297000 L R1,80(0,R1) LAST SCANNED BYTE 02298000 MVC ACTVFLD(9),BLANKS BLANK OUT FIELD P3059 02299000 CLR R1,R3 ANYTHING LEFT TO SCAN ? 02300000 BNL NXTPEND NO - HIT END OF LINE 02301000 NBKSCAN EQU * SCAN TO NON-BLANK 02302000 CLI 0(R1),X'40' 02303000 BNE NBKFUND 02304000 BXLE R1,R2,NBKSCAN ADVANCE + CONTINUE 02305000 NXTPEND EQU * HIT END OF THE LINE 02306000 LR R1,R4 RESTORE START ADDRESS 02307000 ST R1,80(0,R1) RESET POINTERS TO BEGINNING 02308000 NXTPCC1 EQU * SET CC = 1 02309000 TM *+1,X'FF' SET COND. CODE ONE 02310000 B NXTPCCX GO TO RETURN @VA01031 02311000 NBKFUND EQU * FOUND NON-BLANK START OF FIELD 02312000 LR R0,R1 REMEMBER WHERE WE ARE 02313000 LA R1,1(0,R1) SKIP ONE CHARACTER 02314000 BLKSCAN EQU * SCAN TO BLANK 02315000 CLI 0(R1),X'40' 02316000 BE BLKFUND 02317000 BXLE R1,R2,BLKSCAN ADVANCE + CONTINUE 02318000 BLKFUND EQU * FOUND END OF FIELD 02319000 ST R1,80(0,R4) SAVE SCAN POINTER 02320000 LR R2,R0 START OF FIELD 02321000 SR R1,R0 FIELD LENGTH 02322000 BNP NXTPCC1 SET CC = 1 02323000 CH R1,=H'8' MAXIMUM LENGTH = 8 CHARACTERS 02324000 BNH MVEPRM O.K. P3059 02325000 LA R1,8 MOVE 9 CHARACTERS P3059 02326000 EX R1,NXTPMVC TO ERROR FIELD P3059 02327000 TM *,X'FF' SET COND. CODE FOUR @VA01031 02328000 B NXTPCCX GO TO RETURN @VA01031 02329000 MVEPRM EQU * P3059 02330000 EX R1,NXTPMVC MOVE DATA TO 'ACTVFLD' 02331000 CR R1,R1 SET CC = 0 02332000 NXTPCCX EQU * @VA01031 02333000 LM R0,R4,20(R13) RESTORE REGISTERS 02334000 BR R14 02335000 SPACE 02336000 NXTPMVC MVC ACTVFLD(*-*),0(R2) MOVE FIELD TO BUFFER 02337000 EJECT 02338000 * SUBROUTINES TO TYPE OUT THE LAST CONTROL CARD AND PREVIOUS 02339000 * CONTROL CARD FROM THE UPDATE FILE 02340000 * NOTHING IS TYPED IF THE 'NOTERM' OPTION WAS SPECIFIED. 02341000 CTLTYPE EQU * P3027 02342000 LA R15,LASTCTLL POINT TO LAST CONTROL CARD P3027 02343000 B CTL1 GO TO COMMON CODE P3027 02344000 SPACE 1 02345000 CTLPTYPE EQU * P3027 02346000 LA R15,PREVCTLL POINT TO PREV CONTROL CARD P3027 02347000 SPACE 1 02348000 * COMMON CODE FOR THE TWO SUBROUTINES. 02349000 CTL1 EQU * P3027 02350000 TM GLOBALS,TERM IS 'TERM' IN EFFECT? 02351000 BCR 8,R14 (BZ 0(R14)) JUST RETURN IF NOT 02352000 STM R14,R5,LTSAVE SAVE MODIFIED REGISTERS 02353000 LH R4,LASTCTLI-LASTCTLL(,R15) GET ITEM NUMBER OF THE P3027*02354000 RECORD TO BE TYPED P3027 02355000 LR R3,R15 POINT TO TEXT FOR LINE P3027 02356000 LINEDIT TEXT=' ',DOT=NO 02357000 LA R2,UPDFILE POINT TO UPDATE FILE FSCB 02358000 B LINTYPEC ENTER LINTYPE CODE 02359000 SPACE 3 02360000 LASTCTLL DS CL80 BUFFER FOR LAST CONTROL CARD 02361000 LASTCTLI DS H ITEM NUMBER FOR CONTROL CARD 02362000 PREVCTLL DS CL80 PREVIOUS CONTROL CARD P3027 02363000 PREVCTLI DS H ITEM NUMBER P3027 02364000 LTSAVE DS 8F SAVE AREA 02365000 EJECT 02366000 * SUBROUTINE TO TYPE A LINE FROM A FILE ON THE TERMINAL. DOES NOT 02367000 * TYPE IF 'NOTERM' HAS BEEN SPECIFIED. 02368000 LINTYPE EQU * 02369000 TM GLOBALS,TERM IS 'TERM' IN EFFECT? 02370000 BCR 8,R14 (BZ 0(R14)) JUST RETURN IF NOT 02371000 SPACE 02372000 * ENTER HERE INSTEAD IF YOU WANT TO TYPE IT EVEN IF 'NOTERM' IS ON. 02373000 LINTYPEF EQU * 02374000 STM R14,R5,LTSAVE SAVE REGISTERS 02375000 LR R2,R1 SAVE POINTER TO FSCB IN R2 02376000 L R3,BUFF(,R2) POINT TO BUFFER OF FSCB 02377000 LH R4,ITEM(,R2) LOAD LAST ITEM NUMBER 02378000 SPACE 3 02379000 * ENTER HERE FROM CTLTYPE CODE 02380000 LINTYPEC EQU * 02381000 LA R1,SHRTLEN ASSUME SHORT LENGTH MESSAGE 02382000 CLC SEQFELD(8,R3),BLANKS BUT IS THERE A SEQUENCE FIELD? 02383000 BE *+8 SKIP IF THERE IS NOT 02384000 LA R1,LNGLEN OTHERWISE, MUST USE LONG MSG 02385000 STC R1,LINTEXTL SET TEXT LENGTH FOR DMSERR 02386000 LINEDIT TEXTA=LINTEXTL,RENT=NO, TYPE OUT LINE *02387000 SUB=(CHAR8A,8(R2),DEC,(R4),CHARA,(R3),CHARA,SEQFELD(R3)) 02388000 LM R14,R5,LTSAVE RESTORE REGISTERS 02389000 BR R14 RETURN TO CALLER 02390000 SPACE 5 02391000 * TEXT FOR THE LINEDIT CALL 02392000 LINTEXTL DC AL1(SHRTLEN) TEXT LENGTH 02393000 LINTEXT DC C'FILE ''',20C'.',C''', REC # ......... = ',72C'.' 02394000 SHRTLEN EQU *-LINTEXT LENGTH OF SHORT MESSAGE 02395000 DC C' (........)' 02396000 LNGLEN EQU *-LINTEXT LENGTH OF LONG MESSAGE 02397000 DS 0H 02398000 EJECT 02399000 * SUBROUTINE TO TYPE AND PRINT THE ERROR MESSAGE IN ERRBUFF. IT IS 02400000 * NOT PRINTED, HOWEVER, IF THE 'NOTERM' OPTION WAS SPECIFIED. 02401000 BUFFOUT EQU * 02402000 TM GLOBALS,TERM IS 'TERM' IN EFFECT? 02403000 BZ BUFFOUTP GO PRINT IF NOT 02404000 LINEDIT TEXTA=ERRBUFF,DISP=ERRMSG TYPE OUT ERROR MSG 02405000 SPACE 02406000 BUFFOUTP EQU * 02407000 BAL R1,CLRLOGB CLEAR LOG FILE 02408000 IC R1,ERRBUFF GET LENGTH OF ERROR MSG 02409000 BCTR R1,0 GET (LENGTH-1) 02410000 EX R1,BUFFMVE MOVE INTO LOG BUFFER 02411000 BAL R15,LOGIT LOG THE LOG BUFFER 02412000 BR R14 RETURN TO OUR CALLER 02413000 SPACE 2 02414000 BUFFMVE MVC LOGBUFF(0),ERRBUFF+1 LENGTH FILLED IN BY EX 02415000 SPACE 02416000 ERRBUFF DS 97X,0H 02417000 EJECT 02418000 * LOGGING SUBROUTINES 02419000 SPACE 2 02420000 * CLEAR THE LOG BUFFER 02421000 CLRLOGB EQU * 02422000 MVI LOGBUFF,C' ' 02423000 MVC LOGBUFF+1(95),LOGBUFF CLEAR THE LOG BUFFER 02424000 BR R1 RETURN TO CALLER 02425000 SPACE 5 02426000 * SUBROUTINE TO LOG A LINE ONTO THE LOG FILE. 02427000 LOGIT EQU * 02428000 STM R14,R5,LOGSAVE SAVE IMPORTANT REGISTERS 02429000 BAL R2,CHKTITL CHECK FOR PAGE OVERFLOW 02430000 LA R3,LOGBUFF-1 POINT TO LOG BUFFER 02431000 BAL R2,LOGOUT PUT LINE INTO LOG FILE 02432000 LM R14,R5,LOGSAVE RESTORE REGS 02433000 BR R15 RETURN TO CALLER 02434000 SPACE 2 02435000 LOGSAVE DS 8F 02436000 SPACE 1 02437000 *************************************************************** 02438000 * 02439000 * XCLOSE IS A SUBROUTINE WHICH SETS THE TOP LINE AS THE 02440000 * CURRENT LINE. 02441000 * 02442000 * CALL: 02443000 * BAL 14,XCLOSE 02444000 * 02445000 * 02446000 *************************************************************** 02447000 SPACE 1 02448000 XCLOSE EQU * @V2D4821 02449000 TM UPDFLAG,INCOR IS CMSUT1 IN-CORE ??? @V2D4821 02450000 BNO 0(,R14) NO, IGNORE THIS CALL @V2D4821 02451000 LA R1,PTR1 POINT TO 'TOP' OF FILE @V2D4821 02452000 ST R1,PTR2 RESET READ POINTER @V2D4821 02453000 BR R14 AND RETURN TO CALLER @V2D4821 02454000 EJECT 02455000 ************** 02456000 * 02457000 * CORINIT IS A SUBROUTINE WHICH INITIALIZES CORE. 02458000 * 02459000 * 1. COMPUTES NO. OF BYTES REQUIRED PER LINE (CORITE 02460000 * 2. CALLS GETMAIN 02461000 * 3. COMPUTES NUMBER OF LINES WE CAN FIT IN (SPARES) 02462000 * 02463000 * CALL: 02464000 * BAL R8,CORINIT 02465000 * 02466000 * 02467000 ************** 02468000 SPACE 1 02469000 CORINIT EQU * @V2D4821 02470000 L R0,FFREE ALLOW 5K FOR STACKING & CMS IO @V2D4821 02471000 DMSFREE DWORDS=(0),ERR=*,MIN=1 @V2D4821 02472000 LR R2,R1 SAVE STORAGE LOCATION @V2D4821 02473000 ST R0,FFREE AND NO. DBLWDS OBTAINED @V2D4821 02474000 GETMAIN VC,LA=LIMITS,A=FREEAD GET ALL WE CAN @V2D4821 02475000 LR R1,R2 RESTORE STORAGE LOACTION @V2D4821 02476000 L R0,FFREE AND NO. DBLWDS OBTAINED @V2D4821 02477000 DMSFRET DWORDS=(0),LOC=(1) GIVE BACK STACKING STORAGE @V2D4821 02478000 MVC AEXTEND(4),FREEAD @V2D4821 02479000 L R15,FREELEN @V2D4821 02480000 SR R14,R14 ZERO FOR DIVIDE @V2D4821 02481000 D R14,CORITEM NO. OF LINES WE CAN HANDLE @V2D4821 02482000 ST R15,SPARES SAVE AS SPARES @V2D4821 02483000 BR R8 RETURN @V2D4821 02484000 EJECT 02485000 * SUBROUTINE TO CHECK FOR PAGE OVERFLOW, AND TO PUT A TITLE LINE 02486000 * INTO THE LOG FILE IF IT OCCURS. 02487000 CHKTITL EQU * 02488000 L R1,CURRLINE GET CURRENT LINE NUMBER 02489000 LA R1,1(,R1) INCREMENT 02490000 ST R1,CURRLINE 02491000 C R1,=A(MAXLINE) IS IT LARGER THAN MAX? 02492000 BCR 13,R2 (BNL 0(R2)) JUST RETURN IF NOT 02493000 SPACE 02494000 * OTHERWISE, WE MUST TYPE OUT A TITLE LINE. 02495000 LA R1,2 RESET LINE NUMBER TO 2 02496000 ST R1,CURRLINE 02497000 MVI LOGBCTL,C'0' FORCE NEXT LINE TO DOUBLE SPACE 02498000 L R1,CURRPAGE INCREMENT PAGE COUNT 02499000 LA R1,1(,R1) 02500000 ST R1,CURRPAGE 02501000 SPACE 02502000 LINEDIT DISP=NONE,BUFFA=TITLBUFF,TEXTA=TITLEDIT,RENT=NO, *02503000 DOT=NO,COMP=NO, *02504000 SUB=(CHAR8A,INPFILE+8,CHAR8A,UPDFILE+8,DECA,CURRPAGE) 02505000 LA R3,TITLBUFF+1 POINT TO TITLE BUFFER 02506000 B LOGOUT AND PUT IT INTO LOG BUFFER 02507000 SPACE 3 02508000 TITLEDIT DC AL1(97) LENGTH OF BUFFER 02509000 DC C'1UPDATING ''',20C'.',C''' WITH ''',20C'.',C'''' 02510000 BLCOUNT EQU 98-25-(*-TITLEDIT) 25 = L'TITUP 02511000 DC (BLCOUNT)C' ' PAD WITH BLANKS 02512000 TITUP DC C'UPDATE LOG -- PAGE ......' 02513000 SPACE 02514000 TITLBUFF DS AL1(97),C'1',CL96 02515000 LOGBCTL DC C' ' CONTROL CHAR IS BLANK 02516000 LOGBUFF DS CL96 02517000 SPACE 02518000 BLANKS DC CL97' ' 02519000 SPACE 02520000 CURRLINE DC A(MAXLINE) CURRENT LINE NUMBER 02521000 CURRPAGE DC F'0' CURRENT PAGE NUMBER 02522000 MAXLINE EQU 60 MAXIMUM LINE NUMBER BEFORE OVFL 02523000 EJECT 02524000 * SUBROUTINE TO DO THE ACTUAL READBUF OR PRINTING 02525000 LOGOUT EQU * 02526000 TM GLOBALS,DISK IS 'DISK' IN EFFECT, OR 'PRINT'? 02527000 BO LOGOUTD GO IF 'DISK' 02528000 SPACE 02529000 PRINTL (R3),97,ERROR=RETRY @VA03253 02530000 B LOGOUTX GO FINISH UP 02531000 RETRY EQU * @VA03253 02532000 CH R15,=H'2' IS IT 12 PUNCH? @VA03253 02533000 BE RESTART @VA03253 02534000 CH R15,=H'3' IS IT 9 PUNCH? @VA03253 02535000 BE RESTART @VA03253 02536000 BNE LOGOUTX NO, GET OUT @VA03253 02537000 RESTART MVI 0(R3),C'+' SUPPRESS SPACE @VA03253 02538000 PRINTL (R3),97 RETRY @VA03253 02539000 MVI 0(R3),C' ' RESTORE SINGLE SPACE @VA03253 02540000 B LOGOUTX RETURN @VA03253 02541000 SPACE 02542000 LOGOUTD EQU * 02543000 FSWRITE FSCB=LOGFILE,BUFFER=(R3),BSIZE=97,ERROR=OUTERR 02544000 SPACE 2 02545000 * A KLUDGE: IF WE DOUBLE-SPACED, THEN WE CHANGE CTL CHAR FROM '0' TO 02546000 * BLANK. 02547000 LOGOUTX EQU * 02548000 CLI 0(R3),C'0' DID WE DOUBLE-SPACE? 02549000 BNE *+8 SKIP IF NOT 02550000 MVI 0(R3),C' ' RESET TO BLANK 02551000 BR R2 RETURN TO CALLER 02552000 EJECT 02553000 * SUBROUTINE TO CLOSE THE LOG FILE 02554000 LOGCLOSE EQU * 02555000 CLC CURRPAGE,=F'0' ANYTHING WRITTEN OUT? 02556000 BCR 8,R14 (BE 0(R14)) JUST RETURN IF NOT 02557000 STM R14,R5,LOGSAVE SAVE REGS 02558000 TM GLOBALS,DISK ARE WE LOGGING TO DISK? 02559000 BO LOGCLD GO IF WE ARE 02560000 SPACE 02561000 * OTHERWISE, WE CLOSE THE PRINTER, SPECIFYING A NAME OF 'FNAME UPDLOG' 02562000 LINEDIT DISP=CPCOMM,DOT=NO, *02563000 SUB=(CHAR8A,LOGFILE+8), *02564000 TEXT='CLOSE PRT NAME .................' 02565000 B LOGCLC GO RETURN 02566000 SPACE 02567000 LOGCLD EQU * 02568000 FSCLOSE FSCB=LOGFILE CLOSE THE LOG DISK FILE 02569000 SPACE 02570000 LOGCLC EQU * 02571000 LM R14,R5,LOGSAVE RESTORE REGS 02572000 BR R14 RETURN TO CALLER 02573000 EJECT 02574000 * 02575000 * DATA AREAS, CONSTANTS, STATUS CONTROL, CMS P-LISTS 02576000 * 02577000 REPSCAN DS F SCAN SAVE FOR 'REPLACE' FUNCTION 02578000 SPACE 02579000 DS 0D 02580000 SEQSTRT DC CL8'00000000' START SEQ. FOR FUNCTION 02581000 SEQLAST DC CL8'00000000' ENDNG SEQ. FOR FUNCTION 02582000 SEQPOSN DC CL8'00000000' FILE POSITION 02583000 SEQNEXT DC CL8'00000000' NEXT RE-SEQUENCE FIELD 02584000 ISEQLAST DC CL8'00000000' LAST INPUT FILE SEQUENCE NUMBER 02585000 OSEQLAST DC CL8'00000000' LAST OUTPUT FILE SEQUENCE NUMBER 02586000 CORITEM DC F'88' TOTAL ITEM LENGTH IN-CORE @V2D4821 02587000 FFREE DC F'650' 15K WORTH OF DOUBLE WDS. @V2D4821 02588000 LIMITS DC F'88' LOWER LIMIT FOR GETMAIN @V2D4821 02589000 DC X'00FFFFF8' MAX. 16 MEG MACHINE @VA05026 02590000 FREEAD DC A(0) ADDRESS OF GETMAINED STORAGE @V2D4821 02591000 FREELEN DC F'0' LENGTH OF GETMAINED STORAGE @V2D4821 02592000 FPTR DC A(0) START OF FREELIST CHAIN @V2D4821 02593000 PTR1 DC A(0,0) 'TOP' POINTER @V2D4821 02594000 PTR2 DC A(PTR1) POINTER TO CURRENT LINE @V2D4821 02595000 AEXTEND DC A(0) CURRENT LIMIT OF EXTEND @V2D4821 02596000 SPARES DC F'0' NUMBER OF AVAILABLE LINES LEFT IN CH@V2D4821 02597000 REGSAV DS 1F REGISTER SAVE AREA @V2D4821 02598000 SEQFOLD DC PL5'0' NEXT RE-SEQUENCE FIELD VALUE 02599000 SEQINCR DC PL5'10' RE-SEQUENCE INCREMENT 02600000 SEQLABL DC CL3'000' THREE-CHAR SEQUENCE ID FIELD 02601000 SEQFELD EQU 72 SEQUENCE = COLS. 73-80 02602000 SPACE 02603000 DC C'* ' MUST PRECEDE 'UPLEVEL' 02604000 UPLEVEL DC CL5' ' HIGHEST-LEVEL UPDATE APPLIED 02605000 DFLEVEL DC CL5'TEXT ' CURRENT LEVEL BEING EXAMINED 02606000 SPACE 02607000 DS 0F 02608000 CZEROES DC CL8'00000000' CONSTANT ZEROES FIELD 02609000 FNAME DS CL8 FILENAME 02610000 UPDNEXT DC CL8'00000000' NEXT SEQUENCE FIELD FOR UPDATE P3059 02611000 ACTVFLD DC CL8' ' ACTIVE CONTROL CARD FIELD P3059 02612000 DC CL1' ' FOR OVERFLOW WHEN TOO MANY CHAR P3059 02613000 SPACE 2 02614000 UPDSTRT DC PL5'0' START FOR GENERATING SEQUENCE ON UPDATES 02615000 UPDINCR DC PL5'1000' GENERATION INCREMENT 02616000 PAKZERO DC PL5'0' CONSTANT DECIMAL ZERO 02617000 SEQMAX DC P'100000000' MAX SEQUENCE NUMBER P3027 02618000 UPDCODE DC C' ' FUNCTION-CODE CHARACTER (I,R,S,D) 02619000 SPACE 02620000 DS 0F 02621000 UPDLINE DC CL80' ',A(UPDLINE) CONTROL BUFFER 02622000 INPLINE DC CL80' ' SOURCE INPUT BUFFER 02623000 CTLBUFF DC CL80' ',A(CTLBUFF) CNTRL FILE BUFFER 02624000 SPACE 02625000 NOINTS DC X'00' SSM FOR NO EXTRANEOUS INTERRUPTS @VM03093 02626000 SPACE 02627000 DC C'* ' MUST PRECEDE 'CTLMACS' 02628000 CTLMACS DC CL72' ' SAVE BUFFER FOR 'MACS' RECORD 02629000 SPACE 02630000 ITEM EQU 26 DISP. IN P-LIST + FST TO ITEM NUMBER 02631000 BUFF EQU 28 02632000 EJECT 02633000 * 'GLOBALS' AND 'UPDFLAG' FLAG BYTES 02634000 SPACE 02635000 GLOBALS DC X'00' 02636000 SPACE 02637000 UPDN EQU X'80' AN UPDATE HAS BEEN DONE 02638000 SEQ8 EQU X'40' EIGHT-DIGIT SEQUENCE FIELDS 02639000 CTLF EQU X'20' CONTROL FILE OPTION WAS SPEC'D 02640000 INCL EQU X'10' 'INCLUDE' SEQ #'S FROM UPDATES 02641000 NSTK EQU X'08' DO NOT STACK MULTI-LEVEL RESULTS 02642000 DISK EQU X'04' UPDATE LOG ON DISK (NOT PRINTED) 02643000 REPL EQU X'02' 'REPLACE' OPTION SPECIFIED 02644000 TERM EQU X'01' WARNING MESSAGES TO TERMINAL 02645000 SPACE 2 02646000 UPDFLAG DC X'00' 02647000 SPACE 02648000 RSEQ EQU X'80' RESEQUENCE THE OUTPUT FILE 02649000 SGEN EQU X'40' GENERATE SEQ FIELDS FOR UPDATES 02650000 AUXF EQU X'20' WORKING WITH AUXILIARY FILE 02651000 DELT EQU X'10' DELETE FUNCTION NOW IN PROGRESS 02652000 FULL EQU X'08' BUFFER CONTAINS DATA IN LIMBO 02653000 INCOR EQU X'04' PROCESS CMSUT1 FILE IN-CORE @V2D4821 02654000 TAIL EQU X'02' PROCESSING NORMAL EOF ON INPUT 02655000 FULI EQU X'01' LAST BUFFER LINE FROM INPUT FILE 02656000 SPACE 1 02657000 UPDFLAG2 DC X'00' @V2D4821 02658000 SPACE 2 02659000 * FLAG DOSF IS USED TO SAVE THE CONTENTS OF THE DOS SIMULATION FLAGS 02660000 * LOCATED IN NUCON. 02661000 DOSF DS X @V305066 02662000 SPACE 2 02663000 RC28 EQU 28 RETURN CODE = 28 @V305066 02664000 SPACE 1 02665000 FINISH EQU X'01' @V2D4821 02666000 EJECT 02667000 * FSCB'S FOR ALL FILES 02668000 SPACE 02669000 * FSCB FOR INPUT FILE 02670000 INPFILE FSCB 'FNAME ASSEMBLE',BUFFER=INPLINE,BSIZE=80 02671000 INPPTRS DS 2A POINTERS TO ADT AND FST 02672000 SPACE 02673000 * FSCB FOR UPDATE FILE 02674000 UPDFILE FSCB '$FNAME UPDATE',BUFFER=UPDLINE,BSIZE=80 02675000 UPDPTRS DS 2A POINTERS TO ADT AND FST 02676000 SPACE 02677000 * FSCB FOR UTILITY FILE 02678000 UT1FILE FSCB 'UPDATE CMSUT1',BUFFER=INPLINE,BSIZE=80 02679000 SPACE 02680000 * FSCB FOR LOG-TO-DISK FILE 02681000 LOGFILE FSCB 'FNAME UPDLOG',BUFFER=LOGBUFF,BSIZE=96 02682000 SPACE 02683000 * FSCB FOR 'FNAME UPDATES' FILE 02684000 UPSFILE FSCB 'FNAME UPDATES',BSIZE=80 02685000 SPACE 02686000 * FSCB FOR CONTROL FILE 02687000 CTLFILE FSCB 'FNAME CNTRL',BUFFER=CTLBUFF,BSIZE=80 02688000 CTLPTRS DS 2A POINTERS TO ADT AND FST 02689000 SPACE 02690000 * FSCB FOR AUXILIARY FILE 02691000 AUXFILE FSCB 'FNAME AUX....',BUFFER=CTLBUFF,BSIZE=80 02692000 AUXPTRS DS 2A POINTERS TO ADT AND FST 02693000 SPACE 02694000 PTRS EQU INPPTRS-INPFILE 02695000 PADT EQU PTRS 02696000 PFST EQU PTRS+4 02697000 FTSAVE DC CL8' ' FOR PREFERRED AUXFILE @V60C5CC 02698000 LISTMARK EQU X'FE' MARKS AVAILABLE AUXFILE SLOT @V60C5CC 02699000 LISTADR DC F'0' AUXFILE LIST ADDRESS @V60C5CC 02700000 RENAME DS 0D RENAME CMSUT1 FILE 02701000 DC CL8'RENAME' 02702000 DC CL8'UPDATE',CL8'CMSUT1',CL8'A1' 02703000 NEWNAME DC CL8'*-*',CL8'ASSEMBLE',CL8'A1' 02704000 FENCED DC 2F'-1' CONSTANT = 8X'FF' 02705000 SPACE 02706000 EJECT 02707000 STACKER DS 0D STACK A CONSOLE LINE 02708000 DC CL8'ATTN' 02709000 DC CL4'LIFO',AL1(74),AL3(CTLMACS-2) 02710000 SPACE 02711000 DTSTAMP DS 0D DATE + TIME STAMP A FILE 02712000 DC 2CL8'*-*',CL8'A1' FILE TO BE RECORDED 02713000 DTFNAME DC CL8'*-*',CL8'UPDATES',CL8'A1' 02714000 DC 2F'-1' 02715000 EJECT 02716000 LTORG 02717000 SPACE 2 02718000 DS 0D CORRECT ALIGNMENT FROM HERE ON 02719000 EJECT 02720000 * WE TYPE OUT A MESSAGE INDICATING THE PROBLEM. 02721000 WOVF EQU * 02722000 ST R14,WOVF14 SAVE REG 14 02723000 ST R0,WOVF0 SAVE REG 0 P3027 02724000 BAL R14,CTLTYPE TYPE LAST UPDATE CONTROL CARD 02725000 DMSERR DISP=NONE,BUFFA=ERRBUFF,NUM=176,LET=W, *02726000 SUB=(CHARA,(R0)), P3027*02727000 TEXT='SEQUENCING OVERFLOW FOLLOWING SEQ NUMBER ''.......*02728000 .''' 02729000 BAL R14,BUFFOUT GO TYPE AND PRINT MESSAGE 02730000 WARN 8 SET RETURN CODE TO 8 02731000 L R14,WOVF14 RESTORE REG 14 02732000 BR R14 RETURN TO CALLER 02733000 SPACE 02734000 WOVF14 DS A SAVE REG 14 02735000 WOVF0 DS A P3027 02736000 EJECT 02737000 * ABORT ERROR MESSAGES 02738000 SPACE 02739000 NOFNAME EQU * 02740000 DMSERR NUM=1,LET=E,TEXT='NO FILENAME SPECIFIED' 02741000 MVI RC,24 02742000 B ERETURN 02743000 SPACE 3 02744000 EXCESIV EQU * 02745000 DMSERR NUM=70,LET=E,SUB=(CHARA,(R2)), *02746000 TEXT='INVALID PARAMETER ''........''' 02747000 MVI RC,24 02748000 B ERETURN 02749000 SPACE 3 02750000 BADMODE EQU * 02751000 DMSERR NUM=48,LET=E,SUB=(CHARA,(R2)), *02752000 TEXT='INVALID MODE ''........''' 02753000 MVI RC,24 02754000 B ERETURN 02755000 SPACE 3 02756000 ERCMSUT EQU * 02757000 DMSERR NUM=24,LET=E,SUB=(CHAR8A,UT1FILE+8), *02758000 TEXT='FILE ''....................'' ALREADY EXISTS' 02759000 MVI RC,RC28 RETURN CODE @V305066 02760000 B ERETURN 02761000 SPACE 3 02762000 FMTERR EQU * 02763000 DMSERR NUM=7,LET=E,SUB=(CHAR8A,8(R2)), *02764000 TEXT='FILE ''....................'' IS NOT FIXED, 80 CHA*02765000 R. RECORDS' 02766000 MVI RC,32 02767000 B ERETURN 02768000 SPACE 3 02769000 NOFILE EQU * 02770000 DMSERR NUM=2,LET=E,SUB=(CHAR8A,8(R2)), *02771000 TEXT='FILE ''....................'' NOT FOUND' 02772000 MVI RC,28 02773000 B ERETURN 02774000 SPACE 3 02775000 NOFILEW EQU * 02776000 DMSERR NUM=180,LET=W,SUB=(CHAR8A,8(R2)), *02777000 TEXT='MISSING PTF FILE ''....................''' 02778000 WARN 12 02779000 B AUXREAD 02780000 SPACE 3 02781000 INPERR EQU * 02782000 LR R2,R1 SAVE POINTER TO PLIST 02783000 LR R3,R15 SAVE RETURN CODE 02784000 DMSERR NUM=104,LET=S,RENT=NO, *02785000 SUB=(DEC,(R3),CHAR8A,8(R2)), *02786000 TEXT='ERROR ''.........'' READING FILE ''...............*02787000 .....''' 02788000 MVI RC,100 02789000 B ERETURN 02790000 SPACE 3 02791000 OUTERR EQU * 02792000 LR R2,R1 SAVE PLIST POINTER 02793000 LR R3,R15 SAVE WRBUF RETURN CODE 02794000 DMSERR NUM=105,LET=S,RENT=NO, *02795000 SUB=(DEC,(R3),CHAR8A,8(R2)), *02796000 TEXT='ERROR ''.........'' WRITING FILE ''...............*02797000 .....''' 02798000 MVI RC,100 02799000 B ERETURN 02800000 SPACE 3 02801000 ERMACS EQU * 02802000 DMSERR NUM=179,LET=E,SUB=(CHAR8A,CTLFILE+8), *02803000 TEXT='MISSING OR DUPLICATE ''MACS'' CARD IN CONTROL FILE*02804000 ''....................''' 02805000 MVI RC,32 02806000 B ERETURN 02807000 SPACE 3 02808000 NOUPDATS EQU * 02809000 DMSERR NUM=181,LET=E,TEXT='NO UPDATE FILES WERE FOUND' 02810000 MVI RC,40 RETURN CODE = 40 02811000 B ERETURN 02812000 SPACE 3 02813000 INVOPTN EQU * 02814000 DMSERR NUM=3,LET=E,SUB=(CHARA,(R2)), *02815000 TEXT='INVALID OPTION ''........''' 02816000 MVI RC,24 02817000 B ERETURN 02818000 SPACE 3 02819000 OPTDUP EQU * 02820000 DMSERR NUM=65,LET=E,SUB=(CHARA,(R7)), *02821000 TEXT='''........'' OPTION SPECIFIED TWICE' 02822000 MVI RC,24 02823000 B ERETURN 02824000 SPACE 3 02825000 OPTCONF EQU * 02826000 DMSERR NUM=66,LET=E,RENT=NO, *02827000 SUB=(CHARA,(R4),CHARA,(R7)), *02828000 TEXT='''........'' AND ''........'' ARE CONFLICTING OPTI*02829000 ONS' 02830000 MVI RC,24 02831000 B ERETURN 02832000 SPACE 3 02833000 ERRW EQU * 02834000 DMSERR NUM=37,LET=E,TEXT='DISK ''A'' IS READ/ONLY' 02835000 MVI RC,36 RETURN CODE IS 36 02836000 B ERETURN 02837000 SPACE 3 02838000 ERRMSG36 EQU * @VA12416 02838500 LA R0,24(R2) POINT TO MODE LETTER @VA14398 02838600 B ERRMS36A @VA14398 02838700 NOTACCER EQU * P3059 02839000 LA R0,=C'A' POINT TO MODE LETTER @VA14398 02840000 ERRMS36A EQU * @VA14398 02840500 DMSERR TEXT='DISK ".." NOT ACCESSED',NUM=69, @VA14398X02841000 LET=E,SUB=(CHARA,((R0),1)) @VA14398 02841500 MVI RC,36 RETURN CODE @VA12416 02842000 B ERETURN RETURN TO CALLER P3059 02843000 SPACE 2 02844000 ERSC EQU * 02845000 DMSERR NUM=187,LET=E, *02846000 TEXT='OPTION ''STK'' INVALID WITHOUT ''CTL''' 02847000 MVI RC,24 02848000 B ERETURN 02849000 EJECT 02850000 * BAD CONTROL FILE CARD OR AUXILIARY FILE CARD. 02851000 BADCTLC EQU * 02852000 LA R1,CTLFILE POINT TO CONTROL FILE FSCB 02853000 LA R2,=CL7'CONTROL' FOR ERROR MESSAGE BELOW 02854000 B BADCARD GO TYPE MESSAGES 02855000 SPACE 02856000 BADAUXC EQU * 02857000 LA R1,AUXFILE POINT TO AUX FILE FSCB 02858000 LA R2,=CL7'AUX' FOR ERROR MESSAGE BELOW 02859000 SPACE 2 02860000 BADCARD EQU * 02861000 BAL R14,LINTYPEF TYPE OUT LINE OF FILE 02862000 DMSERR NUM=183,LET=E,SUB=(CHARA,(R2)), *02863000 TEXT='INVALID ....... FILE CONTROL CARD' 02864000 MVI RC,32 RETURN CODE = 32 02865000 B ERETURN 02866000 SPACE 1 02867000 SMALLCOR DMSERR NUM=300,LET=E,TEXT='INSUFFICIENT STORAGE TO BEGIN UPDATX02868000 E' @V2D4821 02869000 NI UPDFLAG,255-INCOR RESET IN-CORE FLAG @V2D4821 02870000 L R3,CKCOR CHECK FOR EXPLICIT INCORE OPTION @V2D4821 02871000 CLI 0(R3),C'S' WAS IT??? @V2D4821 02872000 BNE IMPLICIT NO... JUST 'CTL' , DO UPDATE ON DISK @V2D4821 02873000 MVI RC,41 SET RETURN CODE @VA04473 02874000 B ERETURN @V2D4821 02875000 SPACE 1 02876000 IMPLICIT DMSERR NUM=304,LET=I,TEXT='UPDATE PROCESSING WILL BE DONE USINX02877000 G DISK' @V2D4821 02878000 B SLOPPY DO UPDATE USING DISK @V2D4821 02879000 SPACE 2 02880000 CORBUST DMSERR NUM=299,LET=E,TEXT='INSUFFICIENT STORAGE TO COMPLETE UP*02881000 DATE' @V2D4821 02882000 MVI RC,41 SET RETURN CODE @VA04473 02883000 B ERETURN @V2D4821 02884000 EJECT 02885000 LTORG 02886000 EJECT 02887000 REGEQU 02888000 NUCON 02889000 FSTB 02890000 ADT 02891000 FVS HRC015DS 02891100 SPACE 2 02892000 LTORG 02893000 END DMSUPD 02894000