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 <SEQNO2> <$> 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