ERS TITLE 'DMSERS (CMS) VM/370 - RELEASE 6' 00001000
SPACE 2 00002000
*. 00003000
* MODULE NAME: 00006000
* 00007000
* DMSERS (ERASE) 00008000
* 00009000
* FUNCTION: 00010000
* 00011000
* TO DELETE A FILE OR RELATED GROUP OF FILES FROM 00012000
* READ-WRITE DISK(S). 00013000
* 00014000
* ATTRIBUTES: 00015000
* 00016000
* NUCLEUS RESIDENT 00017000
* 00018000
* ENTRY POINTS: 00019000
* 00020000
* DMSERS 00021000
* 00022000
* ENTRY CONDITIONS: 00023000
* 00024000
* LA R1,PLIST R1 MUST POINT TO P-LIST AS USUAL 00025000
* 00026000
* THEN EITHER 00027000
* 00028000
* SVC X'CA' CALL ERASE VIA SVC 00029000
* DC AL4(ERROR) ERROR-RETURN (FOR EXAMPLE, IF FILE 00030000
* NOT FOUND) 00031000
* OR 00032000
* 00033000
* L R14,AERASE WHERE AERASE=V(DMSERS) 00034000
* BALR R14,R15 CALL ERASE VIA BALR WITHIN NUCLEUS 00035000
* BNZ ERROR TRANSFER IF ERROR (FOR EXAMPLE, FILE 00036000
* NOT FOUND) 00037000
* 00038000
* R1 MUST POINT TO ERASE PARAMETER LIST: 00039000
* DS 0F 00040000
* 00041000
* PLIST DC CL8'ERASE' (IMMATERIAL IF BALR-CALL) 00042000
* DC CL8' ' FILENAME OR '*' 00043000
* DC CL8' ' FILETYPE OR '*' 00044000
* DC CL2' ' FILEMODE OR 'BLANK' 00045000
* DC CL8'(' START OF OPTIONS, IF SUPPLIED 00046000
* DC CL8'TYPE'|'NOTYPE' 00047000
* DC X'FFFFFFFF' DELIMITER (NECESSARY IF FM 00048000
* OMITTED) 00049000
* 00050000
* EXIT CONDITIONS: 00051000
* 00052000
* NORMAL RETURN 00053000
* R15=0 (AND CONDITION - CODE=0) 00054000
* 00055000
* ERROR RETURN 00056000
* R15= NON-ZERO (AND CONDITION CODE 2) 00057000
* RETURN CODE 24 - PARAMETER LIST ERROR 00058000
* RETURN CODE 25 - INSUFFICIENT FREE STORAGE @VA02374 00058500
* RETURN CODE 28 - FILE NOT FOUND 00059000
* RETURN CODE 36 - DISK IS READ-ONLY 00060000
* RETURN CODE 36 - DISK NOT ACCESSED @VA12416 00060500
* 00061000
* CALLS TO OTHER ROUTINES: 00062000
* 00063000
* DMSLAD - LOCATE THE FIRST R/W DISK 00064000
* DMSLAF - FIND THE ACTIVE FILE TABLE FOR THE GIVEN FILE 00065000
* DMSLAFFE -FIND THE NEXT ACTIVE FILE TABLE 00066000
* DMSFNSD - 'DIE' IF PERMANENT ERROR READING DISK 00067000
* DMSFNST - TEMPORARILY CLOSE A FILE 00068000
* DMSFREE - GET FREE STORAGE 00069000
* DMSFRET - RETURN FREE STORAGE 00070000
* DMSLFS - FIND THE SPECIFIED FILE STATUS TABLE 00071000
* DMSTQQ - ALLOCATE A 200 BYTE DISK AREA 00072000
* DMSDIOR - 00073000
* DMSTRKW - 00074000
* DMSAUD - CLOSE ALL FILES AND UPDATE THE USER FILE DIRECTORY 00075000
* DMSCWRB - TYPE A LINE TO THE TERMINAL 00076000
* DMSTQQX - 00077000
* 00078000
* EXTERNAL REFERENCES: 00079000
* 00080000
* ADT - ACTIVE DISK TABLE 00081000
* AFT - ACTIVE FILE TABLE 00082000
* FSTB - FILE STATUS TABLE BLOCK 00083000
* FVS - INFORMATION FOR THE FILE SYSTEM 00084000
* 00085000
* TABLES/WORKAREAS: 00086000
* 00087000
* MISCELLANEOUS CONSTANTS 00088000
* 00089000
* REGISTER USAGE: 00090000
* 00091000
* GPR1 = A(PLIST) 00092000
* GPR12 = BASE REGISTER 00093000
* GPR13 = A(FVS) 00094000
* 00095000
* NOTES: 00096000
* 00097000
* | ERASE IS TREATED AS A "COMMAND" OR A "FUNCTION" 00097100
* | ACCORDING TO THE HIGH-ORDER BYTE OF R1 AT INPUT, VIZ: 00097200
* | IF = X'0C', IT WAS ISSUED AS A COMMAND FROM DMSINT. 00097300
* | IF = X'0D', IT WAS ISSUED FROM AN EXEC FILE (DMSEXT), 00097400
* | WITH "&CONTROL" SET TO EITHER "CMS" OR "ALL". 00097500
* | IF = X'0E', IT WAS ISSUED FROM AN EXEC FILE (DMSEXT), 00097600
* | WITH "&CONTROL OFF" IN EFFECT. 00097700
* | IF < X'0C' OR > X'0E', IT IS ASSUMED TO BE A FUNCTION. 00097800
* 00097900
* | IF DMSERS IS CALLED AS A FUNCTION, THERE IS NO CHECK FOR 00098000
* | THE "(TYPE" OPTION, AND ALL ERROR MESSAGES ARE OMITTED. 00098100
* 00098200
* | ALSO, IF ERASE IS CALLED FROM EXEC WITH "&CONTROL OFF" IN 00098300
* | EFFECT, THE "FILE NOT FOUND" ERROR MESSAGE IS OMITTED. 00098400
* 00099000
* OPERATION: 00100000
* 00101000
* DMSERS CHECKS THE PARAMETER LIST FOR ERRORS BY THE 00102000
* CALLER. THE FILENAME 00103000
* AND FILETYPE MUST EACH BE GIVEN, OR ELSE A ASTERISK 00104000
* IN PLACE OF FILENAME OR FILETYPE TO INDICATE ALL 00105000
* NAMES AND/OR ALL TYPES. THE FILEMODE MAY BE OMITTED 00106000
* IN WHICH CASE THE FIRST READ-WRITE DISK IS ASSUMED. 00107000
* IF NOT OMITTED, THE FILEMODE MUST BE ALPHABETIC. IF 00108000
* ALPHABETIC, A MODE NUMBER IS ACCEPTABLE. 00109000
* 00110000
* FOR EXAMPLE, A CALL OF ERASE * TEXT A5 WOULD ERASE 00111000
* ALL TEXT FILES ON THE A-DISK THAT HAD A MODE NUMBER 00112000
* OF 5. ALL OTHER TEXT FILES ON ANY DISKS WOULD REMAIN 00113000
* INTACT, AND ALL OTHER A5 FILES WOULD REMAIN ALSO. 00114000
* 00115000
* IF ANY ERRORS ARE DETECTED IN THE PARAMETER LIST, 00116000
* ERROR 1 IS RETURNED, AND NOTHING IS ERASED. 00117000
* 00118000
* AFTER CHECKING THE PARAMETER LIST AND SETTING 00119000
* FLAGBITS AS NEEDED, DMSERS CHECKS FOR A 00120000
* GIVEN FILE AND DELETES IT, IF FOUND, USING THE 00121000
* FOLLOWING PROCEDURE: 00122000
* 00123000
* 1. DMSLAF IS CALLED TO DETERMINE IF THE FILE 00124000
* TO BE ERASED IS STILL ACTIVE - THAT IS, IN THE 00125000
* ACTIVE FILE TABLE (AFT). IF IT IS (ONLY A FILE ON 00126000
* A READ-WRITE DISK IS ACCEPTABLE, OF COURSE), THEN 00127000
* IT IS TEMPORARILY CLOSED VIA A CALL TO EFINIS IN 00128000
* THE DMSFNT ROUTINE, WHICH PERFORMS JUST ENOUGH OF 00129000
* THE NORMAL CLOSING STEPS ORDINARILY PERFORMED BY 00130000
* DMSFNS TO PERMIT THE FILE TO BE SUCCESSFULLY 00131000
* ERASED. PROCEEDS 00132000
* THEN TO STEP 3 BELOW. 00133000
* 00134000
* 2. IF NOT FOUND BY DMSLAF, THEN DMSERS CALLS DMSLFS 00135000
* TO FIND THE FILE. IF NOT FOUND, EXIT IS MADE FROM 00136000
* DMSERS AS DESCRIBED IN STEP 14 BELOW. 00137000
* 00138000
* 3. WHEN THE FILE HAS BEEN FOUND EITHER BY DMSLAF (AND 00139000
* DMSFNSE CALLED), OR BY DMSLFSW, THEN DMSFNST IS 00140000
* CALLED TO TEMPORARILY CLOSE ALL OUTPUT FILES FOR 00141000
* THIS 00142000
* PARTICULAR DISK (UNLESS THIS WAS ALREADY 00143000
* ACCOMPLISHED BY AN EARLIER EXCURSION THROUGH THIS 00144000
* PROCEDURE FOR ANOTHER FILE ON THE SAME DISK). 00145000
* 00146000
* 4. DMSERS THEN CHECKS THE TYPE OPTION FLAG BIT TO 00147000
* DETERMINE IF THE USER SPECIFIED 00148000
* THAT THE IDENTIFIER(S) OF THE FILE(S) BEING ERASED 00149000
* ARE TO BE TYPED TO THE CONSOLE. 00150000
* IF THE BIT IS ON, THE PLIST IS SET UP, AND A CALL 00151000
* IS MADE TO DMSCWR. 00152000
* 00153000
* 5. BEFORE RELEASING ANY TRACKS BELONGING TO THE FILE 00154000
* THAT HAS BEEN FOUND, DMSERS CALLS A SPECIAL ENTRY 00155000
* IN THE DMSAUD ROUTINE TO RESERVE ENOUGH DISK 00156000
* RECORDS FOR A NEW FILE DIRECTORY TO BE UPDATED 00157000
* WHEN THE FILE HAS BEEN ERASED. THIS PROCEDURE IS 00158000
* PART OF CMS'S DOUBLE DIRECTORY SCHEME, AND ENSURES 00159000
* THAT THE FILE DIRECTORY FOR THE DISK FROM WHICH 00160000
* THE FILE IS BEING ERASED IS UPDATED WHEN AND ONLY 00161000
* WHEN THE ERASE HAS BEEN COMPLETED. (IF ANY SYSTEM 00162000
* MALFUNCTION OR USER INTERVENTION INTERRUPTS THE 00163000
* PROCESS BEFORE COMPLETION, THE OLD FILE DIRECTORY 00164000
* AND THE FILE BEING ERASED ARE BOTH STILL INTACT.) 00165000
* 00166000
* 6. THEN (UNLESS IT IS ALREADY AVAILABLE), 1000 BYTES 00167000
* OF FREE STORAGE ARE OBTAINED VIA 00168000
* DMSFREE, FOR USE IN READING IN THE FIRST AND OTHER 00169000
* (IF ANY) CHAIN LINKS OF THE FILE. 00170000
* 00171000
* 7. NEXT THE FIRST CHAIN LINK OF THE FILE IS READ INTO 00172000
* CORE, INTO THE FIRST 200 BYTES OF 00173000
* FREE STORAGE AREA, VIA DMSDIOR. 00174000
* 00175000
* 8. THE DATA BLOCKS POINTED TO BY THE FIRST CHAIN LINK 00176000
* ARE THEN RELEASED VIA DMSTRKX, AND THE FIRST CHAIN 00177000
* LINK ITSELF VIA DMSTQQX (THE FIRST CHAIN LINK 00178000
* REMAINING IN CORE, HOWEVER). 00179000
* 00180000
* 9. IF ANY DATA BLOCKS REMAIN, ACCORDING TO THE FSTDBC 00181000
* DATA-BLOCK-COUNT IN THE FST ENTRY, THEN ADDITIONAL 00182000
* CHAIN LINKS ARE READ INTO CORE, AS POINTED TO BY 00183000
* THE FIRST CHAIN LINK. FOR EACH OF THESE NTH CHAIN 00184000
* LINKS, THE DATA BLOCKS POINTED TO THEREBY ARE 00185000
* RELEASED VIA DMSTRKX, AND THEN THE CHAIN LINK 00186000
* ITSELF. THIS PROCESS CONTINUES, WITH 00187000
* A COUNT OF DATA BLOCKS RETURNED BEING DECREMENTED, 00188000
* UNTIL THERE ARE NONE LEFT, OR ALL AVAILABLE CHAIN 00189000
* LINKS HAVE BEEN EXHAUSTED. 00190000
* 00191000
* 10. AT THIS POINT, ALL DATA BLOCKS AND CHAIN LINKS 00192000
* HAVE BEEN GIVEN BACK TO THE QMSK AND 00193000
* QQMSK VIA APPROPRIATE CALLS TO DMSTRKX AND THE ONE 00194000
* CALL TO DMSTQQX. NOW A CHECK IS MADE 00195000
* TO SEE IF PERCHANCE THE FILE BEING ERASED HAPPENS 00196000
* TO BE CONTAINED IN STATEFST. IF SO, 00197000
* THE CONTENTS OF STATEFST ARE CLEARED TO REFLECT HRC015DS 00198100
* THE DELETION OF THE GIVEN FILE. (NOTE - DMSBRD 00199000
* UTILIZES THE STATEFST INFORMATION IN SOME 00200000
* CIRCUMSTANCES; THUS IT MUST BE EITHER CORRECT OR 00201000
* NULL.) 00202000
* 00203000
* 11. NEXT PROVISIONS ARE MADE TO KEEP THE FST 00204000
* HYPERBLOCKS COMPACTED, FOR THE DISK ON WHICH THE 00205000
* FILE WAS FOUND AND ERASED. IN THIS PROCESS, THE 00206000
* LAST FST ENTRY FOR THE DISK INVOLVED IS MOVED TO 00207000
* WHERE THE FST ENTRY WAS FOR THE FILE THAT WE JUST 00208000
* ERASED, AND THE 00209000
* PLACE FROM WHICH IT WAS MOVED IS CLEARED. A CHECK 00210000
* IS MADE OF THE ACTIVE FILE TABLE VIA DMSLAFNX 00211000
* IN CASE AN ACTIVE FILE ENTRY POINTS TO THE FILE 00212000
* MOVED, IN WHICH CASE THE POINTER IS CORRECTED; THE 00213000
* POINTER FOLLOWING STATEFST IS ALSO CHECKED, AND 00214000
* CORRECTED IF NECESSARY. IN ANY EVENT, THE 00215000
* COMPACTING IS CAREFULLY ACCOMPLISHED, WITH ALL 00216000
* POINTERS, DISPLACEMENTS, BLOCK COUNTS, ETC., BEING 00217000
* CORRECTED AS NECESSARY. 00218000
* 00219000
* 12. FINALLY, A CALL TO THE OTHER ENTRY OF DMSAUD 00220000
* IS MADE TO COMPLETE THE UPDATING OF 00221000
* THE FILE DIRECTORY FOR THE DISK INVOLVED. 00223000
* 00224000
* 13. AT THIS POINT, IF THE ENTIRE FST HYPERBLOCK AND 00225000
* THE LAST FST ENTRY IN THE PRECEDING HYPERBLOCK 00226000
* HAVE ALL BECOME CLEAR, THE LAST HYPERBLOCK IS 00227000
* RETURNED TO FREE STORAGE, AND ALL POINTERS AND 00228000
* COUNTS CORRECTED ACCORDINGLY. (THIS IS DONE TO 00229000
* AVOID KEEPING A NUMBER OF EMPTY HYPERBLOCKS IN 00230000
* CORE IN CASE A LARGE NUMBER OF FILES ARE ERASED.) 00231000
* 00232000
* 14. FINALLY, THE ENTIRE PROCEDURE IS REPEATED STARTING 00233000
* AT STEP 1, IF THE PARAMETER LIST SPECIFIED ALL 00234000
* NAMES, TYPES, OR MODES. 00235000
* 00236000
* 15. WHEN ALL APPROPRIATE ERASING (IF ANY) HAS BEEN 00237000
* COMPLETED, DMSERS RETURNS THE 1000-BYTE 00238000
* BUFFER TO FREE STORAGE, AND EXISTS TO THE CALLER 00239000
* WITH THE APPROPRIATE ERROR CODE. 00240000
* 00241000
* IF NO FILES AT ALL WERE ERASED, DMSERS RETURNS AN 00242000
* ERROR CODE 2, BUT WITHOUT AN ERROR MESSAGE. (SEVERAL 00243000
* SYSTEM PROGRAMS CALL DMSERS TO ELIMINATE OLD 00244000
* LISTINGS, OLD TEXT FILES, ETC., IN CASE THEY MIGHT 00245000
* EXIST, SO THAT AN ERROR MESSAGE FOR FILE NOT FOUND IN 00246000
* DMSERS ITSELF WOULD BE IMPRACTICAL.) 00247000
* 00248000
* SEVERAL ERROR CONDITIONS ARE DETECTED BY DMSERS. ON 00249000
* ONE OF THESE, A PERMANENT I/O ERROR IN READING IN A 00250000
* CHAIN LINK DUE TO HARDWARE DISK ERRORS, DMSERS 00251000
* PURPOSELY INVOKES 00252000
* THE CODE AT DMSFNSD (WITHIN THE FINIS COMMAND) TO 00253000
* LEAVE THE FILE DIRECTORY INTACT UNTIL 00254000
* THE DISK ERROR CAN BE CORRECTED. 00255000
* 00256000
* ON ALL OTHERS, WHEN THE ERROR IS DETECTED, DMSERS 00257000
* CEASES TO GIVE BACK RECORDS USING 00258000
* DMSTKX AND/OR DMSTQQX, BUT DELETES THE FILES AND 00259000
* COMPACTS THE DIRECTORY AS USUAL. AN ERROR 3 IS GIVEN 00260000
* ON EXIT, WHEN DMSERS IS FINISHED. 00261000
* 00262000
* THIS FEATURE MAKES IT FEASIBLE TO ERASE A FAULTY FILE 00263000
* FROM ONE'S DIRECTORY WITHOUT ENDANGERING THE 00264000
* INTEGRITY OF OTHER FILES ON THE SAME DISK. 00265000
* 00266000
*. 00267000
EJECT 00268000
DMSERS START 0 00269000
ERASE EQU * 00270000
SPACE 00271000
ENTRY ERASE 00272000
EXTRN DISKDIE 00273000
SPACE 00274000
USING NUCON,R0 00275000
L R15,AFVS A(FVS) INTO R15 00277000
USING FVSECT,R15 00278000
STM R0,R14,REGSAV1 SAVE REGISTERS. 00279000
DROP R15 00280000
LR R13,R15 REFERENCE FVS INFO. 00281000
USING FVSECT,R13 00282000
BALR R12,0 ESTABLISH OUR OWN ADDRESSIBILITY 00283000
SPACE 00284000
USING *,R12 00285000
OI UFDBUSY,ERBIT SET OUR BIT IN THE UFDBUSY FLAG. 00286000
XC FVSERAS0(12),FVSERAS0 CLEAR 3 WORDS OF ERASE STORAGE, 00287000
MVI ERSFLAG,QUIET DEFAULT FLAG FOR A FUNCTION CALL @VA01154 00288100
LA R1,0(,R1) MAKE PLIST REGISTER PRESENTABLE. 00289000
ST R1,FVSERAS1 STORE R1 FOR USE BY ACTLKP & FSTLKP. 00290000
MVI ERRCOD1,00 INITIALIZE RETURN CODE TO ZERO. 00291000
CLI REGSAV1+4,X'0C' CALLED AS COMMAND FROM "INIT" ? @VA01154 00292100
BL PRESCAN IF < X'0C', TREAT AS A FUNCTION @VA01154 00292200
CLI REGSAV1+4,X'0E' CALLED AS COMMAND FROM "EXEC" ? @VA01154 00292300
BH PRESCAN IF > X'0E', TREAT AS A FUNCTION @VA01154 00292400
MVI ERSFLAG,00 CLEAR FLAG IF IT'S A "COMMAND" @VA01154 00292500
* SCAN FOR PARAMETER LIST ERRORS 00295000
PRESCAN LA R2,ERR1 INITIALIZE ERROR PATH. 00296000
LA R3,PARMCKN AND THE CONTINUATION PATH. 00297000
BALR R6,0 MIGHT AS WELL MARK THE SPOT. 00298000
SCAN LA R1,8(,R1) INCREMENT THE PLIST POINTER. 00299000
CLI 0(R1),X'FF' END OF PARAMETERS? 00300000
BCR 8,R2 YES. THEN, DONE WITH SCAN. 00301000
CLI 0(R1),C'(' IS THERE AN OPTION LIST? 00302000
BE OPTSCAN YES. GO DECIPHER IT. 00303000
BR R3 GO TO THE PROPER ROUTINE. 00304000
EJECT 00305000
PARMCKN LA R2,ERR1 RESET ERROR PATH. 00306000
LA R3,PARMCKT AND CONTINUATION PATH. 00307000
LA R4,ERR2 AND ALSO BE READY FOR JUNK FILEID. 00308000
BAL R5,CKSTAR EVALUATE FILENAME. 00309000
OI ERSFLAG,ALLNAMES SIGNAL ANYTHING WILL DO. 00310000
BR R6 CONTINUE. 00311000
SPACE 00312000
PARMCKT LA R2,CHECKALL SET CONTINUED... 00313000
LA R3,PARMCKM ...SCAN PATHS. 00314000
BAL R5,CKSTAR EVALUATE FILETYPE. 00315000
OI ERSFLAG,ALLTYPES ANYTHING GOES. 00316000
BR R6 CONTINUE. 00317000
SPACE 00318000
PARMCKM LA R2,CHECKALL RESET CONTINUATION PATH. 00319000
LA R3,ERR3 AND ERROR PATH. 00320000
LA R4,ERR2 AND THE OTHER ONE P1035 00321000
BAL R5,CKSTAR EVALUATE FILEMODE. 00322000
OI ERSFLAG,ALLMODES ANYOLD MODE IS FINE. 00323000
TM ERSFLAG,ALLNAMES+ALLTYPES+ALLMODES 00324000
BO ERR6 '* * *' IS NOT ALLOWED. 00325000
CLI 0(R1),C'*' WAS MODE AN ASTERISK? 00326000
BNE CKLET BETTER VERIFY IT THEN. 00327000
TM ERSFLAG,QUIET WAS THIS A FUNCTION CALL? 00328000
BCR 1,R2 ALL DONE IF SO. 00329000
BR R6 GO LOOK AT NEXT PARAMETER (IF ANY) 00330000
CKLET LA R4,ERR2D SET BADMODE VECTOR V0006 00331100
CLI 0(R1),C'A' MAKE SURE THAT MODE IS V0006 00331150
BLR R4 GREATER THAN OR EQUAL TO 'A' HRC002DS 00332490
CLI 0(R1),C'I' AND LESS THAN OR EQUAL TO 'I' HRC002DS 00332980
BNH CKNUM AND NOT IN THE RANGE HRC002DS 00333470
CLI 0(R1),C'J' MAKE SURE THAT MODE IS HRC002DS 00333960
BLR R4 GREATER THAN OR EQUAL TO 'J' HRC002DS 00334450
CLI 0(R1),C'R' AND LESS THAN OR EQUAL TO 'R' HRC002DS 00334940
BNH CKNUM AND NOT IN THE RANGE HRC002DS 00335430
CLI 0(R1),C'S' MAKE SURE THAT MODE IS HRC002DS 00335920
BLR R4 GREATER THAN OR EQUAL TO 'S' HRC002DS 00336410
CLI 0(R1),C'Z' AND LESS THAN OR EQUAL TO 'Z' HRC002DS 00336900
BHR R4 AND NOT IN THE RANGE HRC002DS 00337390
CKNUM CLI 1(R1),C' ' IS ONLY A MODE LETTER SPECIFIED? 00339000
BNE MODECK CORRECT. 00340000
TM ERSFLAG,ALLNAMES+ALLTYPES '* *' ALREADY? 00341000
BO ERR6 NOT ALLOWED. 00342000
TM ERSFLAG,QUIET IS THIS A FUNCTION CALL? 00343000
BCR 1,R2 IF SO, WE'RE DONE. 00344000
BR R6 CONTINUE. 00345000
MODECK CLI 1(R1),C'0' MAKE SURE THAT THE MODENUMBER IS 00346000
BCR 4,R4 NOT LESS THAN 0 00347000
CLI 1(R1),C'5' OR 00348000
BCR 2,R4 GREATER THAN 5. 00349000
TM ERSFLAG,QUIET (UNLESS CALLED AS 00350000
BCR 1,R2 A FUNCTION) 00351000
CLI 2(R1),C' ' OR MORE THAN 2 CHARACTERS. 00352000
BCR 7,R4 OTHERWISE, THESE ALSO 00353000
BR R6 WILL BE ERRORS. 00354000
SPACE 00355000
CKSTAR CLI 0(R1),C'*' IS THERE AN ASTERISK? 00356000
BNE 4(,R5) NO. RETURN. 00357000
CLI 1(R1),C' ' MUST BE FOLLOWED BY A BLANK. 00358000
BCR 8,R5 OKAY. 00359000
BR R4 ERROR 00360000
SPACE 00361000
OPTSCAN L R2,FVSERAS1 GET PLIST POINTER. 00362000
LA R2,24(,R2) GET REASONABLE POSITION FOR PARENTHESIS. 00363000
CR R1,R2 HOW ARE WE DOING? 00364000
BL ERR1 BADLY. 00365000
CLI 8(R1),X'FF' IS IT A BARE PARENTHESIS? 00366000
BE CHECKALL YES, THEN WE ARE DONE. 00367000
LA R5,7 GET THE LENGTH OF AN OPTION. 00368000
LA R1,8(,R1) POINT TO THE OPTION SUPPLIED. 00369000
LA R3,OPTIONS-8 FIND THE OPTION TABLE (OFFSET A LITTLE). 00370000
LA R4,NUMOPTS GET THE NUMBER OF OPTIONS. 00371000
LR R2,R1 MAKE A COPY OF THE POINTER. 00372000
CKBLANK LA R2,1(,R2) POINT INTO THE FIELD. 00373000
CLI 0(R2),C' ' HAVE WE FOUND A BLANK? 00374000
BE GOTLN YES. THEN LET'S GO ON. 00375000
BCT R5,CKBLANK KEEP TRYING. 00376000
GOTLN SR R2,R1 GOT THE LENGTH BY NOW. 00377000
BCTR R2,0 BUT IT'S TOO HIGH BY 1. 00378000
CKNXT LA R3,8(,R3) POINT INTO THE OPTION TABLE. 00379000
EX R2,CKMATCH COMPARE SOMETHING AGAINST SOMETHING ELSE. 00380000
BE OPTFND WE GOT A MATCH! 00381000
BCT R4,CKNXT BETTER LUCK NEXT TIME. 00382000
B ERR5 THERE IS NO NEXT TIME. 00383000
SPACE 00384000
CKMATCH CLC 0(*-*,R3),0(R1) 00385000
SPACE 00386000
OPTFND CLI 0(R1),C'T' WAS IT TYPE (ONLY 'T' SO FAR)? 00387000
BNE PARTDONE NO, SO DON'T SET THE FLAG. 00388000
OI ERSFLAG,TYPEM FLAG THAT THE USER WANTS TO WATCH. 00389000
PARTDONE LA R1,8(,R1) CHECK FOR ADDITIONAL PARAMETERS. 00390000
CLI 0(R1),X'FF' ARE THERE ANY? 00391000
BE CHECKALL NO, THEN WE ARE DONE. 00392000
CLI 0(R1),C')' DID HE BALANCE HIS PARENTHESES? 00393000
BNE ERR3 WITH SOMETHING WEIRD, APPERENTLY. 00394000
LA R1,8(,R1) ANYTHING BEYOND THIS SYNTACTIC ELEGANCE? 00395000
CLI 0(R1),X'FF' WELL? 00396000
BNE ERR3 YES, BUT CAN'T IMAGINE WHAT. 00397000
CHECKALL TM ERSFLAG,ALLNAMES+ALLTYPES+ALLMODES '* * *'? 00398000
BO ERR6 NOT ALLOWED. 00399000
CKM L R1,FVSERAS1 GET STARTING ADDRESS OF THE PLIST. 00400000
TM ERSFLAG,ALLMODES WAS MODE AN ASTERISK? 00401000
BO MAINLOOP DON'T WORRY, IF SO. 00402000
CLI 24(R1),C'A' WAS IT A PARENTHESIS? 00403000
BL CKA MOST LIKELY. 00404000
CLI 24(R1),C'Z' OR POSSIBLY A FENCE? 00405000
BNH MAINLOOP PROBABLY NOT. 00406000
CKA TM ERSFLAG,ALLNAMES+ALLTYPES WAS IT ' * * '? 00407000
BO ERR6 NOT ALLOWED. 00408000
OI ERSFLAG,FRSTONLY SET APPROPRIATE BIT P0589 00410000
LA R1,DMODE-24 POINT TO THE DEFAULT MODE-LETTER. V0268 00411100
L R15,=V(DMSLADW) CALL ADTLKP TO FIND 00412000
BALR R14,R15 THE FIRST READ-WRITE DISK. 00413000
BNZ ERR2X V0268 00414100
ST R1,ADTADD STORE ADT ADDRESS IN A HANDY PLACE. 00419000
SPACE 00420000
MAINLOOP SR R0,R0 R0=0 TO SEARCH FROM THE BEGINNING 00421000
ERAS02 L R1,FVSERAS1 SEARCH ACTIVE-TABLE 00422000
L R15,AACTLKP CALL ACTLKP 00423000
BALR R14,R15 ... 00424000
BZ FOUND1 BRANCH IF ACTLKP FOUND IT. 00425000
LM R0,R1,FVSERAS0 IF NOT, RE-LOAD R0 AND R1 AND 00426000
L R15,=V(DMSLFSW) CALL 'FSTLKW' 00427000
BALR R14,R15 ... 00428000
BZ FOUND2 'FOUND' IF CONDITION-CODE = 0 00429000
* 00430000
ERAS02A TM ERSFLAG,UPNEED UPDATE OF UFD NEEDED ? 00431000
BZ ERAS04 TRF IF NOT. 00432000
ERAS03 L R0,FVSERAS0 A (ACTIVE-DISK-TABLE) INTO R0, 00433000
SR R1,R1 ZERO OUT A REGISTER. V0636 00434100
BCTR R1,0 NOW, MAKE IT NEGATIVE. V0636 00434200
L R15,AUPDISK FINISH UPDATING THE DIRECTORY 00435000
BALR R14,R15 ... 00436000
* 00437000
* GIVE BACK FREE STORAGE IF WE USED ANY ... 00438000
ERAS04 L R1,FVSERAS2 GET ADDRESS OF FREE STORAGE. 00439000
LTR R1,R1 DID WE USE ANY FREE STORAGE AT ALL ? 00440000
BZ ERR2 (NOTHING ERASED) 00441000
* CALL FRET TO RELEASE 1000 BYTES 00442000
LA R0,125 SET THE NUMBER OF DWORDS. V0636 00443100
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR V0636 00443200
L R15,ERRCOD1-3 ERROR-CODE (0 IF ALL WENT WELL) INTO R15 00444000
* 00445000
EXIT KXCHK ERBIT CHECK FOR 'KX' WANTED... 00446000
LM R0,R14,REGSAV1 RESTORE R0-R14 00447000
LTR R15,R15 SET CONDITION-CODE FOR CONVENIENCE OF CALLER 00448000
BR R14 RETURN TO SVCINT OR CALLER. 00449000
EJECT 00450000
FOUND1 DS 0H FILE-TO-BE-ERASED 'FOUND' BY ACTLKP ... 00451000
USING AFTSECT,R1 (BRIEFLY) 00452000
L R11,AFTADT GET POINTER TO ACTIVE-DISK-TABLE 00453000
USING ADTSECT,R11 REFERENCE SAME 00454000
TM ADTFLG1,ADTFRW IS THIS A READ-WRITE DISK ? 00455000
LR R0,R1 IF NOT, SET UP R0 AS NEEDED 00456000
BZ ERAS02 AND RESUME SEARCHING. 00457000
TM ERSFLAG,FRSTONLY FIRST R/W DISK ONLY WANTED ? 00458000
BZ FOUND1A BZ IF NOT (DON'T WORRY ABOUT IT). 00459000
C R11,ADTADD IS THE DISK FOUND THE FIRST R/W DISK ? 00460000
BNE ERAS02 IF NOT, FORGET IT & RESUME SEARCHING. 00461000
FOUND1A LR R0,R11 IF READ-WRITE, SET R0 TO ACT. DISK TABLE 00462000
L R15,ATFINIS CLOSE FILE VIA NEW FUNCTION 'EFINIS' 00463000
BALR R14,R15 WITHOUT CALLING UPDISK OR SUCH. 00464000
L R2,AFTPFST-1 REMEMBER ITS ADDRESS (IF ANY) IN FST-TABLES 00465000
LA R2,0(,R2) (STRIP OFF LIKELY FLAG-BYTE) 00466000
LH R6,AFTFCL GET FIRST-CHAIN-LINK DISK-ADDRESS, 00467000
LH R7,AFTDBC AND NO. OF 800-BYTE DATA BLOCKS 00468000
DROP R1 ... 00469000
L R15,AACTFRET NOW GIVE BACK THE ACTIVE-FILE-TABLE 00470000
BALR R14,R15 (PURPOSELY LEFT THERE FOR US BY EFINIS) 00471000
B FOUND3 AND JOIN FORCES BELOW. 00472000
* 00473000
FOUND2 DS 0H FILE-TO-BE-ERASED 'FOUND' BY FSTLKW ... 00474000
LR R11,R0 REFERENCE THE ACTIVE-DISK-TABLE 00475000
TM ERSFLAG,FRSTONLY FIRST R/W DISK ONLY WANTED ? 00476000
BZ FOUND2A BZ IF NOT (DON'T WORRY ABOUT IT). 00477000
C R11,ADTADD IS THE DISK FOUND THE FIRST R/W DISK ? 00478000
BNE ERAS02A TRF IF NOT, STOP SEARCHING, GO FINISH UP. 00479000
FOUND2A OI FVSERAS1,X'80' SET SIGN-BIT 'ON' IN 'R1' FOR NEXT TIME 00480000
LR R2,R1 REMEMBER ITS ADDRESS IN FST-TABLES FOR LATER 00481000
USING FSTSECT,R2 REFERENCE IT BRIEFLY, 00482000
LH R6,FSTFCL GET FIRST-CHAIN-LINK DISK-ADDRESS, 00483000
LH R7,FSTDBC AND NO. OF 800-BYTE DATA BLOCKS 00484000
DROP R2 00485000
FOUND3 EQU * JOIN FORCES WHETHER FOUND BY ACTLKP OR FSTLKW 00486000
L R1,FVSERAS0 "OLD" ACTIVE-DISK-TABLE (IF ANY) INTO R1, 00487000
CR R11,R1 IS "THIS" ADT THE SAME AS THE OLD ONE ? 00488000
BE FOUND4A TRF IF YES - NO TFINIS OR UPDISK NEEDED. 00489000
LTR R0,R1 DOES OLD ACTIVE-DISK-TABLE EXIST AT ALL ? 00490000
BZ FOUND4 IF NOT (1ST TIME THRU), CALL 'TFINIS' ETC 00491000
SR R1,R1 ZERO OUT A REGISTER. V0636 00492100
BCTR R1,0 NOW, MAKE IT NEGATIVE. V0636 00492200
L R15,AUPDISK 'FINISH' UPDATING DIRECTORY FOR OLD DISK 00493000
BALR R14,R15 ... 00494000
TM ERSFLAG,FRSTONLY WAS FIRST R/W DISK ONLY WANTED ? 00495000
BO ERAS04 TRF IF YES -EXIT RIGHT NOW, MAN. 00496000
SR R1,R1 R1 MUST = 0 NOW 00497000
FOUND4 EQU * CLOSE ANY OPEN FILES... 00498000
LR R0,R11 SET R0 FOR NEW ACTIVE DISK TABLE 00500000
ST R11,FVSERAS0 STORE NEW ACTIVE-DISK-TABLE ADDRESS, 00501000
L R15,ATFINIS CALL 'TFINIS' TO 'TCLOSE' ALL OUTPUT 00502000
BALR R14,R15 FILES FOR THIS ACTIVE-DISK-TABLE. 00503000
L R15,AUPDISK CALL 'UPDISK' TO RESERVE 00504000
BALR R14,R15 DISK-SPACE FOR NEW UFD IN ADVANCE. 00505000
FOUND4A LTR R7,R7 CHECK NUMBER OF 800-BYTE DATA-BLOCKS 00506000
BNP ERROR3 FAULTY FILE IF NOT > 0 (BUT CONTINUE) 00507000
LTR R6,R6 CHECK FIRST-CHAIN-LINK DISK-ADDRESS, 00508000
BZ ERROR3 FAULTY FILE IF = 0. 00509000
STH R6,SIGNAL STORE 1ST CHAIN LINK DISK-ADDRESS IN 00510000
LA R6,SIGNAL HANDY HALFWORD, AND REFER TO IT THERE 00511000
L R1,FVSERAS2 ADDRESS OF BUFFER (IF ANY) INTO R1 00512000
LTR R4,R1 WAS THERE ANY ? 00513000
BP LTR22 BP (BNZ) IF YES - USE IT (IN R4) 00514000
* IF NOT, GET 1000 BYTES - ENOUGH FOR WORST CASE 00515000
LA R0,125 SET THE NUMBER OF DWORDS. V0636 00516100
DMSFREE DWORDS=(0),TYPE=NUCLEUS,TYPCALL=BALR V0636 00516200
LTR R15,R15 FAIL IF FREE STORAGE CANNOT @VA02374 00516500
BNZ ERROR25 BE ACQUIRED @VA02374 00516700
ST R1,FVSERAS2 STORE ITS ADDRESS FOR FUTURE REFERENCE. 00517000
LR R4,R1 CORE-ADDRESS OF 1ST CHAIN LINK TO R4, 00518000
LTR22 TM ERSFLAG,TYPEM IS THE (TYP FLAG ON ?? 00519000
BNO SR55 NO, GO TO SR55 00520000
LTR R2,R2 DOES FST-ENTRY EXIST IN THE TABLES ? 00521000
BZ SR55 IF NOT, FORGET FANCY STUFF. 00522000
USING FSTSECT,R2 00523000
LA R5,15(,R1) POINT CONVENIENTLY INTO THE BUFFER V0144 00524100
MVC 1(8,R5),FSTN MOVE IN THE FILENAME V0144 00524150
MVI 9(R5),C' ' DELIMIT WITH A BLANK V0144 00524200
MVC 10(8,R5),FSTT MOVE IN THE FILETYPE V0144 00524250
MVI 18(R5),C' ' YES...ANOTHER BLANK V0144 00524300
MVC 19(1,R5),ADTM NOW, GET THE CORRECT MODE-LETTER V0144 00524350
MVC 20(1,R5),FSTM+1 AND THE CORRECT NODE-NUMBER V0144 00524400
MVI 0(R5),X'14' MOVE IN THE MESSAGE LENGTH V0144 00524450
LINEDIT MF=(E,'SYS'),TEXTA=(5),TYPCALL=BALR,DOT=NO, V0144*00524500
COMP=NO V0144 00524550
DROP R2 00547000
SR55 SR R5,R5 R5 WILL BE BYTE-COUNT OF '0' 00548000
STM R4,R5,DSKLOC STORE CORE-ADDRESS AND BYTE-COUNT, 00549000
BAL R10,READCL READ IN FIRST CHAIN LINK 00550000
* 00551000
* NOW RELEASE THE VARIOUS DATA BLOCKS AND CHAIN LINKS ... 00552000
* 00553000
SR R3,R3 CLEAR R3 (AN AVAILABLE REGISTER) 00554000
LA R8,80(,R4) POINT TO BEGINNING OF DATA BLOCKS, 00555000
LA R9,60 MAXIMUM OF 60 DATA BLOCKS IN 1ST C.L. 00556000
BAL R10,ERSUB1 RELEASE DATA BLOCKS OF FIRST C.L. 00557000
SR R0,R0 PICK UP THE DISK ADDRESS @VA01100 00558100
ICM R0,B'0011',SIGNAL OF THE 1ST CHAIN LINK @VA01100 00558200
LR R1,R11 REFERENCE ACTIVE-DISK-TABLE, 00559000
L R15,AQQTRKX RELEASE FIRST CHAIN LINK ITSELF 00560000
BALR R14,R15 VIA 'QQTRKX'. 00561000
BZ ERAS05 OK IF R15=0 FROM QQTRKX. JS 00562000
CH R15,H3 IF ERROR, MAYBE ERROR 3 (FULL QQMSK) ? JS 00563000
BNE ERROR3 REAL ERROR (ERROR 3 FOR ERASE) IF NOT JS 00564000
ERAS05 LTR R7,R7 ANY DATA BLOCKS LEFT ? JS 00565000
BNP ERAS06 ALL DONE UNLESS COUNT STILL > 0. 00566000
LR R6,R4 BEGINNING OF 1ST C.L. POINTS TO 2ND C.L. 00567000
LA R4,200(,R4) ADVANCE 200 BYTES FOR 800-BYTE BUFFER, 00568000
LA R5,800 800 BYTES WE'LL READ NOW, 00569000
STM R4,R5,DSKLOC STORE CORE-ADDRESS AND BYTE-COUNT, 00570000
LA R5,40 MAXIMUM OF 40 NTH CHAIN LINKS 00571000
* 00572000
NCLOOP DS 0H LOOP TO READ IN AND RELEASE NTH CHAIN LINKS 00573000
CH R3,0(,R6) CHECK DISK-ADDRESS OF NTH CHAIN LINK 00574000
BE LAR626 BE IF 'EMPTY' ... 00575000
BAL R10,READCL READ IN NTH CHAIN LINK, 00576000
LR R8,R4 POINT TO BEGINNING OF SAME IN CORE 00577000
H400 LA R9,400 MAXIMUM OF 400 DATA BLOCKS, 00578000
BAL R10,ERSUB1 RELEASE UP TO 400 DATA BLOCKS 00579000
LH R0,0(,R6) GET DISK-ADDRESS OF CHAIN-LINK ITSELF, 00580000
LA R9,1 JUST 1, 00581000
BAL R10,ERSUB2 RELEASE NTH CHAIN LINK ITSELF. 00582000
LAR626 LA R6,2(,R6) ADVANCE TO NEXT CHAIN LINK (IF ANY) 00583000
LTR R7,R7 CHECK NUMBER OF DATA BLOCKS LEFT (IF ANY) 00584000
BNP ERAS06 ALL DONE IF NONE LEFT. 00585000
BCT R5,NCLOOP KEEP ITERATING UP TO 40 NTH CHAIN LINKS 00586000
* 00587000
ERROR3 EQU * CHAINING SEARCH TERMINATED. V0039 00588100
* 00589000
ERAS06 LTR R2,R2 REFERENCE FILE ADDRESS IN FST TABLES, 00590000
BZ ERAS14 BZ IF NOT THERE AT ALL (FORGET IT). 00591000
XC 0(40,R2),0(R2) CLEAR THE 40 BYTES, 00592000
C R2,STATER1 DOES ERASED FILE MATCH STATEFST INFO ? 00593000
BNE ERAS07 BNE IF NOT (FORGET IT). 00594000
XC STATEFST(STFSTSIZ),STATEFST Yes? clear STATEFST HRC015DS 00595100
ERAS07 LM R4,R5,ADTCHBA POINT TO 'CURRENT ITEM' (IF ANY), 00596000
AR R4,R5 ADDRESS NOW IN R4. 00597000
LM R6,R7,ADTLHBA POINT TO 00598000
LR R8,R6 'LAST ITEM', 00599000
AR R8,R7 ADDRESS NOW IN R8. 00600000
LA R9,40 (NEED SHORTLY) 00601000
CR R2,R8 DID WE ERASE THE VERY LAST ITEM ? 00602000
BE ERAS12 BE IF YES (ENTIRELY POSSIBLE). 00603000
C R3,0(,R8) IS LAST ITEM NULL ? 00604000
BNE ERAS10 BNE IF NOT (GOOD SHOW, NO PROBLEM). 00605000
ERAS08 BAL R10,ERAS22 BACK OFF 40 BYTES & SEE IF OK, 00606000
BNM ERAS09 NO PROBLEM IF R7 NOT MINUS. 00607000
L R6,FSTBKWD(,R6) BACK UP TO PREVIOUS FST HYPERBLOCK, 00608000
LTR R6,R6 (IF ANY) 00609000
BZ ERAS14 GIVE UP IF NOTHING THERE. 00610000
LA R7,760 POINT TO LAST FST-ENTRY IN PREVIOUS BLOCK 00611000
LR R8,R6 AND GET 00612000
AR R8,R7 ADDRESS OF SAME 00613000
STM R6,R7,ADTLHBA STORE NEW VALUES 00614000
OI ERSFLAG,GIVEBACK SET FLAG-BIT TO DETACH EMPTY FROM CHAIN 00615000
ERAS09 C R3,0(,R8) MAKE SURE NOT ANOTHER EMPTY ONE 00616000
BNE ERAS10 OK IF NOT, PROCEED. 00617000
CR R2,R8 IF EMPTY, ARE WE AT THE FILE WE ERASED ? 00618000
BNE ERAS08 BNE IF NOT, KEEP TRYING. 00619000
B ERAS14 GIVE UP IF YES. 00620000
* 00621000
* CHECK ACTIVE FILE TABLE FOR POSSIBILITY THAT AN 00622000
* ACTIVE FILE TABLE ENTRY POINTS TO THE FST-ENTRY (GIVEN BY R8) 00623000
* THAT WE WILL BE MOVING TO THE EMPTY SLOT GIVEN BY R2 ... 00624000
* 00625000
ERAS10 SR R1,R1 R1=0 TO START WITH 1ST ACTIVE FILE TABLE 00626000
CHKACTL L R15,AACTNXT GET 'NEXT' ACTIVE FILE TABLE 00627000
BALR R14,R15 VIA ACTNXT 00628000
LTR R1,R1 IF R1=0, THERE ARE NO AFT'S LEFT 00629000
BZ ERAS11 BZ IF THAT'S THE CASE, WE'RE DONE. 00630000
USING AFTSECT,R1 IF SOMETHING THERE, REFERENCE THE AFT, 00631000
L R15,AFTPFST-1 GET POINTER TO FST-TABLES, 00632000
LA R15,0(,R15) STRIP OFF FLAG-BYTE, 00633000
CR R15,R8 DOES IT MATCH THE 'LAST' FST ENTRY ? 00634000
BNE CHKACTL IF NOT, KEEP CHECKING. 00635000
IC R14,AFTFLG IF IT DOES MATCH, SAVE THE FLAG-BYTE, 00636000
ST R2,AFTPFST-1 CHANGE POINTER TO THE NEW LOCATION WHERE 00637000
STC R14,AFTFLG THE OLD FILE WAS, RESTORE THE FLAG BYTE, 00638000
DROP R1 00639000
* 00640000
ERAS11 MVC 0(40,R2),0(R8) MOVE THAT LAST FILE TO THE EMPTY SLOT, 00641000
XC 0(40,R8),0(R8) CLEAR THE PLACE WHERE IT WAS 00642000
C R8,STATER1 DOES OLD PLACE MATCH STATEFST POINTER ? 00643000
BNE CR24 BNE IF NOT (FORGET IT). 00644000
ST R2,STATER1 STORE NEW ADDRESS THERE IF IT DID. 00645000
CR24 CR R2,R4 DOES POINTER TO 'CURRENT ITEM' MATCH R2 ? 00646000
BNE ERAS12 BNE IF NOT. 00647000
SR R5,R9 BACK OFF 40 BYTES ON CURRENT DISPLACEMENT 00648000
ST R5,ADTCFST & STORE NEW DISPLACEMENT (MINUS 40 IS OK) 00649000
ERAS12 BAL R10,ERAS22 BACK OFF 40 BYTES ON DISP. OF LAST FST, 00650000
* 00651000
ERAS14 OI ERSFLAG,UPNEED INDICATE UPDATE OF UFD WILL BE NEEDED 00652000
* 00653000
LM R4,R5,ADTHBCT GET HYPERBLOCK COUNT & NUMBER OF FILES, 00654000
BCTR R5,0 DECREMENT NUMBER OF FILES, 00655000
ST R5,ADTFSTC STORE UPDATED VALUE OF NUMBER OF FILES JS 00656000
TM ERSFLAG,GIVEBACK SHOULD WE GIVE BACK EMPTY HYPERBLOCK 00657000
BZ ERAS16 BZ IF FLAG-BIT NOT SET. 00658000
NI ERSFLAG,255-GIVEBACK IF YES, TURN OFF THE FLAG-BIT, 00659000
L R1,FSTFWDP(,R6) GET POINTER TO EMPTY BLOCK (R6 INTACT) 00660000
ST R3,FSTFWDP(,R6) CLEAR IT (R3 IS STILL 0), 00661000
* GIVE BACK 808-BYTE BUFFER VIA FRET 00662000
DMSFRET LOC=(1),DWORDS=101,TYPCALL=BALR 00663000
BCTR R4,0 DECREMENT HYPERBLOCK COUNT, 00664000
LH R6,ADTRES ALSO DECREMENT 00665000
BCTR R6,0 THE 00666000
STH R6,ADTRES RESERVE-COUNT. 00667000
ST R4,ADTHBCT STORE UPDATED HYPERBLOCK COUNT JS 00668000
* 00669000
ERAS16 EQU * JS 00670000
* 00671000
TM ERSFLAG,ALLNAMES+ALLTYPES+ALLMODES SHOULD WE CONTINUE ? 00672000
BZ ERAS03 TRF IF NOT - GO FINISH UP. 00673000
SSM ON PERMIT TIMER AND/OR TERMINAL INTERRUPT(S) 00674000
SSM *+1 NOW INHIBIT ALL INTERRUPTS AGAIN 00675000
B MAINLOOP GO CHECK FOR MORE FILE(S) TO BE ERASED. 00676000
SPACE 2 00677000
* SUBROUTINE TO BACK OFF 40 BYTES ON LAST FST (IF POSSIBLE) 00678000
* 00679000
ERAS22 SR R8,R9 BACK OFF R8 BY 40 (NEEDED IN SOME CASES) 00680000
SR R7,R9 BACK OFF 40 BYTES ON DISP. OF LAST FST, 00681000
BCR 4,R10 BUT IF MINUS, EXIT. 00682000
ST R7,ADTLFST IF 0 OR +, STORE UPDATED DISP. OF LAST FST 00683000
BR R10 AND RETURN TO CALLER. 00684000
* 00685000
* NOTE - CALLER CAN CHECK CONDITION-CODE TO SEE WHAT HAPPENED 00686000
EJECT 00687000
* 00688000
* SUBROUTINE TO READ IN A CHAIN LINK ... 00689000
* 00690000
* R6 = CORE-ADDRESS OF DISK-ADDRESS 00691000
* R10 = RETURN-REGISTER 00692000
* R11 = ADDRESS OF ACTIVE-DISK-TABLE 00693000
* 00694000
READCL ST R6,DSKADR STORE CORE-ADDRESS OF DISK-ADDRESS, 00695000
ST R11,ADTADD STORE ADDRESS OF ACTIVE-DISK-TABLE, 00696000
LA R1,DSKLST PARAMETER-LIST FOR RDTK, 00697000
L R15,ARDTK CALL RDTK TO 00698000
BALR R14,R15 READ IN CHAIN LINK 00699000
BCR 8,R10 IF NO ERRORS, EXIT TO CALLER VIA R10. 00700000
* IF ERROR FROM RDTK (BAD NEWS) ... 00701000
CH R15,H5 ERROR 5 WOULD MEAN 'SICK' DISK-ADDRESS 00702000
BE ERROR3 (FAULTY FILE) 00703000
* FOR ANY OTHER RDTK ERROR, ... 00704000
L R14,ADISKDIE TO 'DIE' IS TO HAVE UFD INTACT @VA01539 00705100
BR R14 UNTIL DISK TROUBLE IS CORRECTED. @VA01539 00705200
* 00707000
* 00708000
* SUBROUTINE TO GIVE BACK A DATA-BLOCK OR CHAIN LINK 00709000
* 00710000
* R7 = NUMBER OF DATA-BLOCKS REMAINING TO BE RETURNED 00711000
* R8 = CORE-ADDRESS OF 1ST DISK-RECORD TO BE RETURNED 00712000
* R9 = NUMBER OF RECORDS TO BE RETURNED (E.G. 1, 60, 400) 00713000
* R10 = RETURN-REGISTER 00714000
* ENTER AT ERSUB1 TO GIVE BACK DATA BLOCKS 00715000
* ENTER AT ERSUB2 WITH R9=1 TO GIVE BACK A CHAIN LINK 00716000
* 00717000
ERSUB1 LH R0,0(,R8) PICK UP DISK-RECORD TO BE GIVEN BACK, 00718000
LTR R0,R0 IS IT 0 (A NULL BLOCK) ? 00719000
BZ LAR828 BZ IF YES (SKIP IT) 00720000
BCTR R7,0 DECREMENT NO. OF DATA-BLOCKS LEFT 00721000
ERSUB2 LR R1,R11 SET R1 FOR ACTIVE-DISK-TABLE, 00722000
ICM R0,B'1100',=H'0' ZERO THE 2 HIGH BYTES V0636 00722100
L R15,ATRKLKPX CALL 'TRKLKPX' TO GIVE 00723000
BALR R14,R15 BACK THE DISK-RECORD 00724000
BNZ ERROR3 BEWARE OF TRKLKPX ERROR 00725000
LAR828 LA R8,2(,R8) ADVANCE TO NEXT DISK-RECORD, 00726000
LTR R7,R7 CHECK IT ANY DATA-BLOCKS LEFT AT ALL, 00727000
BCR 13,R10 'BNP' IF NONE LEFT, EXIT FORTHWITH 00728000
BCT R9,ERSUB1 ITERATE IF NEEDED 00729000
BR R10 RETURN TO CALLER WHEN THRU. 00730000
EJECT 00731000
* CONSTANTS, ETC. 00732000
* 00733000
DMODE DC C'A' DEFAULT MODE-LETTER V0268 00734100
ON DC X'81' PERMIT TIMER AND/OR TERMINAL INTERRUPT(S) 00735000
* 00736000
H3 DC H'0003' ERROR 3 (FULL QQMSK) FROM QQTRKX IS OK JS 00737000
H5 DC H'0005' ERROR 5 FROM RDTK MEANS 'SICK' DISK-ADDRESS 00738000
* 00739000
ADISKDIE DC A(DISKDIE) TO 'DIE' IF PERMANENT ERROR READING DISK. 00740000
* 00741000
* 00742000
ERR1 SR R2,R2 00743000
LA R3,BADID 00744000
LA R4,54 00745000
B ERR4B 00746000
* 00747000
* ERASE HAS NOT BEEN ABLE TO FIND THE FILE(S) WHICH ARE TO BE P0589 00748000
* ERASED. THE FOLLOWING LOGIC DETERMINES THE ERROR MESSAGE WHICH P1035 00749000
* IS TO BE TYPED TO THE USER. FIRST, 'STATEW' IS CALLED, TO SEE P1035 00750000
* ANY OF HIS RULES ARE VIOLATED. IF NOT, WE CALL 'ADTLKP' TO SEE P1035 00751000
* WHETHER THE DISK SPECIFIED IS READ/ONLY, THE LATTER DETERMINING P1035 00752000
* WHETHER WE TYPE 'FILE NOT FOUND' OR 'DISK IS READ/ONLY'. P1035 00753000
ERR2 TM ERSFLAG,FRSTONLY DEFAULT OF MODE? V0268 00754100
BO ERR2A JUST 'FILE NOT FOUND', THEN. V0268 00754150
L R1,FVSERAS1 POINT TO ORIGINAL PLIST P1035 00755000
L R15,ASTATEW CALL 'STATEW' FOR ERROR MSGP1035 00756000
BALR R14,R15 P1035 00757000
SPACE 1 P1035 00758000
* IF RETURN CODE FROM 'STATEW' IS NOT 0 OR 28, THEN STATEW HAS P1035 00759000
* ALREADY TYPED AN ERROR MESSAGE. P1035 00760000
LTR R15,R15 RETURN CODE = 0? P1035 00761000
BZ ERR2CK CONTINUE PROCESSING IF SO P1035 00762000
CH R15,=H'36' WAS DISK NOT ACCESSED? @VA12416 00762500
BE ERR2BX GIVE MSG @VA12416 00762600
CH R15,=H'28' WAS ERR 'FILE NOT FOUND'? P1035 00763000
BNE EXIT JUST PASS BACK STATEW'S RC P1035 00764000
SPACE 1 P1035 00765000
ERR2CK EQU * P1035 00766000
TM ERSFLAG,ALLMODES '*' SPECIFIED FOR FILEMODE?P0589 00767000
BO ERR2A THEN 'FILE NOT FOUND' P0589 00768000
SPACE 1 P0589 00769000
* OTHERWISE HE REQUESTED A SPECIFIC DISK (OR DEFAULTED TO THE P0589 00770000
* A-DISK) P0589 00771000
ERR2X LA R6,DMODE V0268 00772100
L R1,FVSERAS1 GET ADDR OF ORIGINAL PLIST P0589 00773000
TM ERSFLAG,FRSTONLY SHOULD WE USE A-DISK? P0589 00774000
BO *+8 SKIP IF SO P0589 00775000
LA R6,24(,R1) POINT TO SPECIFIED MODE LETP0589 00776000
LR R1,R6 LET R1 POINT TO MODE LET, P0589 00777000
SH R1,=H'24' DISPLACED BACK 24 BYTES P0589 00778000
L R15,=V(DMSLAD) AND CALL ADTLKP P0589 00779000
BALR R14,R15 P0589 00780000
USING ADTSECT,R1 P0589 00781000
DROP R11 P0589 00782000
TM ADTFLG1,ADTFRW+ADTFRO DISK ACCESSED AT ALL? V0268 00782100
BZ ERR2B V0268 00782150
TM ADTFLG1,ADTFRW IS IT READ/WRITE? P0589 00783000
BZ ERR2C GO IF IT'S READ/ONLY P0589 00784000
SPACE 1 P0589 00785000
* COME HERE IF THE 'FILE NOT FOUND' MESSAGE IS TO BE TYPED. P0589 00786000
ERR2A EQU * P0589 00787000
CLI REGSAV1+4,X'0E' WAS ERASE INVOKED FROM EXEC @VA01154 00787100
* WITH "&CONTROL OFF" IN EFFECT ? 00787200
BE ERROR28 IF YES, OMIT THE ERROR MESSAGE @VA01154 00787300
* JUST AS IF IT HAD BEEN A FUNCTION CALL. 00787400
* NO - USE THE USUAL ERROR MESSAGE ROUTINE: 00787500
LA R3,NTFND R3 POINTS TO MSG TEXT P0589 00788000
LA R4,2 00789000
BAL R5,LENCK 00790000
LA R2,8(,R2) 00791000
BAL R5,ERRMSG 00792000
ERROR28 LA R15,28 ERROR 28 = FILE NOT FOUND @VA01154 00793100
B EXIT 00794000
* V0268 00795100
ERR2BX LA R6,24(,R1) POINT TO SPECIFIED MODE LETTER @VA12416 00795120
ERR2B LA R3,NOTACC V0268 00795150
LA R2,1 V0268 00795200
LA R4,69 V0268 00795250
B ERR2E V0268 00795300
* COME HERE IF 'DISK IS READ/ONLY' P0589 00796000
ERR2C EQU * P0589 00797000
LA R3,DISKRO R3 -> MESSAGE TEXT P0589 00798000
LA R2,1 SUBSTITUTION LENGTH P0589 00799000
LA R4,37 MESSAGE NUMBER P0589 00800000
* NOTE: R6 ALREADY POINTS TO THE SUBSTITUTION PARM, THE P0589 00801000
* MODE LETTER. P0589 00802000
ERR2E BAL R5,ERRMSG V0268 00803100
LA R15,36 RETURN CODE = 36 P0589 00804000
B EXIT P0589 00805000
* 00806000
ERR2D LA R3,BADMODE V0006 00806100
LR R6,R1 V0006 00806150
LA R2,8 V0006 00806200
LA R4,48 V0006 00806250
* V0268 00806500
B ERR4C V0268 00806550
ERR3 LA R3,BADPARM 00807000
LA R4,70 00808000
ERR4A LA R2,8 00809000
ERR4B LR R6,R1 00810000
ERR4C BAL R5,ERRMSG 00811000
LA R15,24 00812000
B EXIT 00813000
* 00814000
ERR5 LA R3,BADOPT 00815000
LA R4,3 00816000
B ERR4A 00817000
* 00818000
ERR6 LA R3,CANTDO 00819000
LA R4,71 00820000
BAL R5,LENCK 00821000
LA R2,8(,R2) 00822000
B ERR4C 00823000
* 00824000
LENCK L R1,FVSERAS1 00825000
LA R6,8(,R1) 00826000
LA R2,16 00827000
CLI 24(R1),C'*' 00828000
BCR 8,R5 00829000
CLI 24(R1),C'A' 00830000
BL 4(,R5) 00831000
CLI 24(R1),C'Z' 00832000
BH 4(,R5) 00833000
BR R5 00834000
ERROR25 LA R3,NOCORE MESSAGE 'CORE NOT AVAILABLE' @VA02374 00834150
LA R4,109 STANDARD NOCORE MSG NO @VA02374 00834300
BAL R5,ERRMSG WRITE IT IF BY COMMAND @VA02374 00834450
LA R15,25 @VA02374 00834600
B EXIT @VA02374 00834750
* 00835000
ERRMSG TM ERSFLAG,QUIET ARE WE A FUNCTION? 00836000
BCR 1,R5 YES. NO ERROR MESSAGES, THEN. 00837000
DMSERR MF=(E,'SYS'),LET=E,NUM=(4),TEXTA=(3), X00838000
SUB=(CHAR8A,((6),(2))),TYPCALL=BALR 00839000
BR R5 00840000
* 00841000
NTFND DC AL1(L'NTFNDMSG) 00842000
NTFNDMSG DC C'FILE ''..........................'' NOT FOUND' 00843000
* 00844000
BADOPT DC AL1(L'OPTMSG) 00845000
OPTMSG DC C'INVALID OPTION ''........''' 00846000
* 00847000
BADID DC AL1(L'IDMSG) 00848000
IDMSG DC C'INCOMPLETE FILEID SPECIFIED' 00849000
* 00850000
CANTDO DC AL1(L'CANTMSG) 00851000
CANTMSG DC C'ERASE ................... NOT ALLOWED' 00852000
* 00853000
BADPARM DC AL1(L'PARMMSG) 00854000
PARMMSG DC C'INVALID PARAMETER ''........''' 00855000
* P0589 00856000
DISKRO DC AL1(L'ROMSG) LENGTH OF MESSAGE TEXT P0589 00857000
ROMSG DC C'DISK ''..'' IS READ/ONLY' P0589 00858000
* 00859000
BADMODE DC AL1(L'MODEMSG) V0006 00859100
MODEMSG DC C'INVALID MODE ''........''' V0006 00859150
* V0006 00859200
NOTACC DC AL1(L'ACCMSG) V0268 00859300
ACCMSG DC C'DISK ''..'' NOT ACCESSED' V0268 00859350
* @VA02374 00859365
NOCORE DC AL1(L'COREMSG) @VA02374 00859380
COREMSG DC C'VIRTUAL STORAGE CAPACITY EXCEEDED' @VA02374 00859395
* 00859500
DS 0F 00860000
OPTIONS EQU * 00861000
DC CL8'TYPE' 00862000
DC CL8'NOTYPE' 00863000
NUMOPTS EQU (*-OPTIONS)/8 00864000
* 00865000
LTORG 00865100
EJECT 00866000
NUCON 00867000
AFT 00868000
ADT 00870000
FSTB 00872000
FVS 00874000
* 00875000
ALLNAMES EQU X'80' FLAG-BIT FOR ALL-NAMES 00876000
ALLTYPES EQU X'40' FLAG-BIT FOR ALL-TYPES 00877000
ALLMODES EQU X'20' FLAG-BIT FOR ALL-MODES 00878000
GIVEBACK EQU X'10' GIVE BACK LAST FST HYPERBLOCK (EMPTY) 00879000
FRSTONLY EQU X'08' SEARCH ONLY THE FIRST READ-WRITE DISK 00880000
UPNEED EQU X'04' UPDATE OF UFD NEEDED BEFORE WE EXIT 00881000
TYPEM EQU X'02' TYPING WANTED PLEASE 00882000
QUIET EQU X'01' DO NOT TYPE ERROR MESSAGES 00883000
EJECT 00884000
REGEQU 00885000
END 00886000