ibm:vm370-lib:cms:dmsers.assemble_src
Table of Contents
DMSERS Source
References
- Fixes Applied : 3
- This Source Date : Tuesday, December 12, 1978
- Last Fix ID : [HRC015DS]
Source Listing
- DMSERS.ASSEMBLE.txt
- 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
ibm/vm370-lib/cms/dmsers.assemble_src.txt · Last modified: 2023/08/06 13:35 by Site Administrator