BWR TITLE 'DMSBWR (CMS) VM/370 - RELEASE 6' 00001000
SPACE 2 00002000
*. 00003000
* MODULE NAME: 00004000
* 00005000
* DMSBWR (WRBUF) 00006000
* 00007000
* FUNCTION: 00008000
* 00009000
* TO WRITE ONE OR MORE SUCCESSIVE ITEMS INTO A 00010000
* SPECIFIED DISK FILE. 00011000
* 00012000
* ATTRIBUTES: 00013000
* 00014000
* NUCLEUS RESIDENT, REENTRANT, CALLED BY BALR OR SVC 00015000
* 00016000
* ENTRY POINTS: 00017000
* 00018000
* DMSBWR (WRBUF) 00019000
* 00020000
* ENTRY CONDITIONS: 00021000
* 00022000
* R1 MUST POINT TO WRBUF PARAMETER LIST: 00023000
* PLIST DC CL8'WRBUF' (NOTE-IMMATERIAL IF CALLED BY BALR) 00024000
* DC CL8' ' FILENAME 00025000
* DC CL8' ' FILETYPE 00026000
* DC CL2' ' FILEMODE 00027000
* DC H' ' ITEM NUMBER OF RECORD TO BE WRITTEN 00028000
* DC A( ) ADDRESS OF OUTPUT BUFFER 00029000
* DC F' ' NUMBER OF BYTES TO BE WRITTEN 00030000
* DC CL2' ' F/V FLAG (IN LEFTMOST BYTE) 00031000
* DC H' ' NUMBER OF ITEMS TO BE WRITTEN 00032000
* 00033000
* EXIT CONDITIONS: 00034000
* 00035000
* NORMAL - 00036000
* R15 = 0 (AND CONDITION-CODE = 0) 00037000
* 00038000
* ERROR - 00039000
* R15 NONZERO (AND CONDITION-CODE = 2) 00040000
* 00041000
* ERROR RETURNS: 00042000
* 00043000
* ERROR RETURNS TO CALLER (R15 VALUE AT EXIT): 00044000
* 00045000
* 2. USER MEMORY ADDRESS = 0 00046000
* 00047000
* 4. FIRST CHARACTER MODE ILLEGAL 00048000
* 00049000
* 5. SECOND CHARACTER MODE ILLEGAL 00050000
* 00051000
* 6. ITEM NUMBER + NUMBER OF ITEMS TOO LARGE--WILL NOT FIT 00052000
* IN A HALFWORD 00053000
* 00054000
* 7. ATTEMPT TO SKIP OVER UNWRITTEN VARIABLE-LENGTH ITEM 00055000
* 00056000
* 8. NUMBER OF BYTES NOT SPECIFIED 00057000
* 00058000
* 9. FILE ALREADY ACTIVE FOR READING 00059000
* 00060000
* 10. MAXIMUM NUMBER OF CMS FILES (3400) REACHED 00061000
* 00062000
* 11. F-V FLAG NOT F OR V 00063000
* 00064000
* 12. MODE SY (SYSTEM) OR OTHER READ-ONLY DISK 00065000
* 00066000
* 13. DISK IS FULL (NON-FATAL) 00067000
* 00068000
* 14. NUMBER OF BYTES TO BE WRITTEN IS NOT INTEGRALLY 00069000
* DIVISIBLE BY NUMBER OF ITEMS TO BE WRITTEN 00070000
* 00071000
* 15. LENGTH THIS ITEM NOT SAME AS PREVIOUS 00072000
* 00073000
* 16. CHARACTERISTIC (F-V FLAG) NOT SAME AS PREVIOUS 00074000
* 00075000
* 17. VARIABLE-LENGTH ITEM GREATER THAN 65K BYTES 00076000
* 00077000
* 18. NUMBER OF ITEMS GREATER THAN 1 FOR VARIABLE-LENGTH FILE 00078000
* 00079000
* 19. MAXIMUM NUMBER OF DATA BLOCKS PER FILE (16060) REACHED 00080000
* 00081000
* 20. INVALID CHARACTER(S) IN FILENAME (OF NEW FILE) 00082000
* 00083000
* 21. INVALID CHARACTER(S) IN FILETYPE (OF NEW FILE) 00084000
* 00085000
* 22. VIRTUAL STORAGE CAPACITY EXCEEDED 00086000
* 00087000
* 00088000
* 25. INSUFFICIENT FREE STORAGE AVAILABLE FOR FILE 00089000
* MANAGEMENT CONTROL AREAS. 00090000
* 00090100
* 27. ATTEMPT TO UPDATE VARIABLE LENGTH ITEM WITH ONE OF DIFFERENT 00090200
* LENGTH 00090300
* CALLS TO OTHER ROUTINES: 00091000
* 00092000
* ACTFREE, ACTFRET, ACTLKP, ADTLKP, DISKDIE, FREE, FRET, 00093000
* FSTLKW, KILLEXF, QQTRK, QQTRKX, RDTK, TRKLKP, 00094000
* TRKLKPX, WRTK 00095000
* 00096000
* EXTERNAL REFERENCES: 00097000
* 00098000
* ADT, AFT, FSTB, FVS 00099000
* 00100000
* TABLES/WORKAREAS: 00101000
* 00102000
* SEE EXTERNAL REFERENCES 00103000
* 00104000
* REGISTER USAGE: 00105000
* 00106000
* GRPO - BASE REGISTERS 00107000
* 00108000
* NOTES: 00109000
* 00110000
* NONE 00111000
* 00112000
* OPERATION: 00113000
* 00114000
* WRBUF FIRST PERFORMS A SERIES OF TESTS TO ENSURE THAT 00115000
* THE PARAMETER LIST IS LEGAL. IF IT IS NOT, WRBUF 00116000
* SIGNALS THE ERROR AND RETURNS TO THE CALLING PROGRAM. 00117000
* IF THE PARAMETER IS LEGAL, WRBUF CALLS THE ACTLKP 00118000
* ROUTINE TO SEE IF THE FILE EXISTS AND IS ACTIVE; IF 00119000
* YES, PROCESSING PROCEEDS AS DESCRIBED UNDER "FILE 00120000
* ACTIVE". IF NOT, WRBUF CALLS THE FSTLKW FUNCTION 00121000
* PROGRAM TO DETERMINE WHETHER THE SPECIFIED FILE 00122000
* EXISTS. IF YES, PROCESSING PROCEEDS AS DESCRIBED 00123000
* UNDER "FILE EXISTS, NOT ACTIVE". IF NOT, PROCESSING 00124000
* PROCEEDS AS DESCRIBED UNDER "FILE DOES NOT EXIST". 00125000
* 00126000
* FILE DOES NOT EXIST: 00127000
* 00128000
* IF THE FILE DOES NOT EXIST, WRBUF CALLS ADTLKP TO 00129000
* DETERMINE THE ACTIVE DISK TABLE PERTAINING TO THE 00130000
* GIVEN MODE, AND CHECKS TO ENSURE THAT THE DISK IS 00131000
* AVAILABLE AND IN READ-WRITE STATUS (ERROR RETURN IF 00132000
* NOT). THEN ACTFREE IS CALLED TO OBTAIN AN AVAILABLE 00133000
* SLOT IN THE ACTIVE FILE TABLE FOR THE FILE ABOUT TO 00134000
* BE CREATED. THEN WRBUF INITIALIZES THE AFT ENTRY 00135000
* WITH NECESSARY INFORMATION INCLUDING THE NAME, TYPE, 00136000
* AND MODE OF THE FILE. WRBUF THEN CALLS THE QQTRK 00137000
* ROUTINE TO OBTAIN AN AVAILABLE SIXTEENTH OF A TRACK 00138000
* OF DISK SPACE FOR USE AS THE FIRST CHAIN LINK AND 00139000
* STORES THE DISK ADDRESS RETURNED BY QQTRK IN THE FILE 00140000
* STATUS TABLE. NEXT, WRBUF CALCULATES (FROM THE ITEM 00141000
* NUMBER SUPPLIED IN THE PARAMETER LIST) THE DATA BLOCK 00142000
* INTO WHICH THE ITEM(S) IS/ARE TO BE WRITTEN. THIS 00143000
* CALCULATION ALSO YIELDS THE LOCATION WITHIN THE DATA 00144000
* BLOCK AT WHICH THE ITEM(S) WILL RESIDE. (THE 00145000
* CALCULATION IS ((N-1)*L)/800. N IS THE ITEM NUMBER, L 00146000
* IS THE ITEM LENGTH, AND 800 IS THE LENGTH OF A DATA 00147000
* BLOCK. THE QUOTIENT PRODUCED BY THIS CALCULATION IS 00148000
* THE NUMBER OF THE AFFECTED DATA BLOCK AND THE 00149000
* REMAINDER IS THE DISPLACEMENT INTO THE DATA BLOCK AT 00150000
* WHICH THE ITEM(S) WILL RESIDE.) NEXT, WRBUF 00151000
* CALCULATES THE NUMBER OF BYTES TO BE WRITTEN. THIS 00152000
* IS EQUAL TO THE ITEM LENGTH MULTIPLIED BY THE NUMBER 00153000
* OF ITEMS TO BE WRITTEN. BOTH VALUES ARE OBTAINED 00154000
* FROM THE PARAMETER LIST. WRBUF THEN MARKS THE FILE 00155000
* ACTIVE, OBTAINS BUFFER SPACE FOR THE DATA BLOCK, AND 00156000
* DETERMINES IF THE ITEM TO BE WRITTEN IS OF FIXED OR 00157000
* VARIABLE LENGTH. IF OF VARIABLE LENGTH, PROCESSING 00158000
* PROCEEDS AS DESCRIBED UNDER "VARIABLE-LENGTH ITEM". 00159000
* IF OF FIXED LENGTH, PROCESSING PROCEEDS AS DESCRIBED 00160000
* BELOW. 00161000
* 00162000
* FIXED-LENGTH ITEM: WRBUF DETERMINES THE CHAIN LINK 00163000
* THAT SHOULD CONTAIN THE ADDRESS OF THE AFFECTED DATA 00164000
* BLOCK. (ORDINARILY, AT THIS POINT, THIS WILL BE THE 00165000
* FIRST CHAIN LINK AND IT WILL EXIST IN MAIN STORAGE.) 00166000
* IF THIS CHAIN LINK DOES NOT EXIST (THAT IS, ITS 00167000
* CORRESPONDING ENTRY IN THE FIRST CHAIN LINK IS NOT A 00168000
* VALID DISK ADDRESS), WRBUF CALLS THE TRKLKP FUNCTION 00169000
* PROGRAM TO OBTAIN A QUARTER OF A TRACK FOR THE NEW 00170000
* CHAIN LINK, INSERTS THE DISK ADDRESS RETURNED BY 00171000
* TRKLKP INTO THE CHAIN LINK DIRECTORY OF THE ACTIVE 00172000
* FILE TABLE ENTRY, AND OBTAINS STORAGE FOR USE IN 00173000
* CONSTRUCTING THE NEW CHAIN LINK. IF THE CHAIN LINK 00174000
* EXISTS, WRBUF CALLS THE RDTK FUNCTION PROGRAM TO READ 00175000
* IT INTO MAIN STORAGE. WRBUF THEN DETERMINES IF THE 00176000
* AFFECTED DATA BLOCK EXISTS. (IT WILL IF THE 00177000
* CORRESPONDING ENTRY IN THE CHAIN LINK THAT IS IN MAIN 00178000
* STORAGE CONTAINS A VALID DISK ADDRESS.) IF IT DOES 00179000
* NOT EXIST, WRBUF CALLS THE TRKLKP FUNCTION PROGRAM TO 00180000
* OBTAIN A QUARTER OF A TRACK FOR THE NEW DATA BLOCK, 00181000
* INSERTS THE DISK ADDRESS RETURNED BY TRKLKP INTO THE 00182000
* APPROPRIATE ENTRY IN THE CHAIN LINK THAT IS IN MAIN 00183000
* STORAGE, AND CLEARS THE DATA BLOCK BUFFER FOR USE IN 00184000
* CONSTRUCTING THE DATA BLOCK. IF THE DATA BLOCK 00185000
* EXISTS, WRBUF CALLS THE RDTK FUNCTION PROGRAM TO READ 00186000
* IT INTO THE DATA BLOCK BUFFER. WRBUF THEN CALCULATES 00187000
* THE NUMBER OF BYTES IN THE DATA BLOCK BUFFER THAT ARE 00188000
* AVAILABLE FOR USE. (THE NUMBER OF BYTES AVAILABLE IS 00189000
* EQUAL TO 800 MINUS THE PREVIOUSLY CALCULATED 00190000
* DISPLACEMENT.) NEXT, WRBUF DETERMINES WHETHER THE 00191000
* NUMBER OF BYTES TO BE WRITTEN IS GREATER THAN THE 00192000
* NUMBER OF BYTES AVAILABLE IN THE DATA BLOCK BUFFER. 00193000
* IF THE NUMBER OF BYTES TO BE WRITTEN IS NOT GREATER 00194000
* THAN THE NUMBER AVAILABLE, WRBUF MOVES THE BYTES TO 00195000
* BE WRITTEN FROM THE INPUT BUFFER TO THE BLOCK BUFFER 00196000
* AND RETURNS TO THE CALLING PROGRAM. (IN THIS CASE, 00197000
* THE DATA BLOCK IS NOT WRITTEN ONTO DISK BECAUSE IT IS 00198000
* NOT FULL.) IF THE NUMBER OF BYTES TO BE WRITTEN 00199000
* EXCEEDS THE NUMBER OF BYTES AVAILABLE, WRBUF MOVES 00200000
* SUFFICIENT BYTES INTO THE DATA BLOCK BUFFER TO FILL 00201000
* IT, AND WRITES THE COMPLETED DATA BLOCK ONTO DISK. 00202000
* WRBUF THEN DETERMINES IF THE CHAIN LINK THAT SHOULD 00203000
* CONTAIN THE ADDRESS OF THE DATA BLOCK THAT IS TO 00204000
* RECEIVE THE OVERFLOW FROM THE PREVIOUS DATA BLOCK IS 00205000
* IN MAIN STORAGE. IF IT IS NOT, WRBUF WRITES THE 00206000
* CURRENT CHAIN LINK (THAT IS, THE ONE IN MAIN STORAGE) 00207000
* ONTO DISK AND RETRIEVES THE CHAIN LINK CONTAINING THE 00208000
* ADDRESS OF THE DATA BLOCK THAT IS TO RECEIVE THE 00209000
* OVERFLOW. THIS CHAIN LINK MAY OR MAY NOT EXIST. IF 00210000
* THE CHAIN LINK DOES NOT EXIST, WRBUF ALLOCATES DISK 00211000
* SPACE FOR THE NEW CHAIN LINK IN THE PREVIOUSLY 00212000
* DESCRIBED MANNER AND DETERMINES IF THE DATA BLOCK 00213000
* THAT IS TO RECEIVE THE OVERFLOW EXISTS AS PREVIOUSLY 00214000
* DESCRIBED. IF THE CHAIN LINK EXISTS, WRBUF READS IT 00215000
* INTO MAIN STORAGE AND DETERMINES IF THE DATA BLOCK TO 00216000
* RECEIVE THE OVERFLOW EXISTS. WHEN THE DATA BLOCK 00217000
* THAT IS TO RECEIVE THE OVERFLOW IS IN MAIN STORAGE, 00218000
* (THAT IS, IN THE DATA BLOCK BUFFER) WRBUF CALCULATES 00219000
* THE NUMBER OF BYTES REMAINING TO BE WRITTEN. IF THIS 00220000
* IS NOT GREATER THAN THE NUMBER OF BYTES AVAILABLE IN 00221000
* THE DATA BLOCK BUFFER (ON OVERFLOW, ALL 800 BYTES OF 00222000
* THE DATA BLOCK BUFFER ARE AVAILABLE), WRBUF MOVES THE 00223000
* REMAINING BYTES FROM THE INPUT BUFFER TO THE DATA 00224000
* BLOCK BUFFER AND RETURNS TO THE CALLER. IF THE 00225000
* NUMBER OF BYTES REMAINING TO BE WRITTEN IS GREATER 00226000
* THAN THE NUMBER OF BYTES AVAILABLE IN THE DATA BLOCK 00227000
* BUFFER, WRBUF MOVES SUFFICIENT BYTES INTO THE DATA 00228000
* BLOCK BUFFER TO FILL IT, WRITES THE DATA BLOCK ONTO 00229000
* DISK, AND MOVES THE OVERFLOW INTO THE NEXT DATA BLOCK 00230000
* AS DESCRIBED. 00231000
* 00232000
* VARIABLE-LENGTH ITEM: WRBUF READS SUCCESSIVE DATA 00233000
* BLOCKS (STARTING WITH THE FIRST) INTO THE DATA BLOCK 00234000
* BUFFER UNTIL IT LOCATES THE ONE THAT CONTAINS THE 00235000
* ITEM IMMEDIATELY PRECEDING THE ONE THAT CORRESPONDS 00236000
* TO THE ITEM NUMBER SPECIFIED IN THE PARAMETER LIST. 00237000
* IT THEN LOCATES THE END OF THAT ITEM. (THIS MAY 00238000
* ENTAIL READING ADDITIONAL DATA BLOCKS, DEPENDING ON 00239000
* THE LENGTH OF THE ITEM.) WHEN IT LOCATES THE END OF 00240000
* THE ITEM, WRBUF MOVES THE LENGTH OF THE ITEM TO BE 00241000
* WRITTEN FROM THE INPUT BUFFER TO THE LOCATION IN THE 00242000
* DATA BLOCK BUFFER IMMEDIATELY AFTER THE END OF THE 00243000
* PREVIOUS ITEM. IT THEN MOVES THE ITEM TO BE WRITTEN 00244000
* FROM THE INPUT BUFFER TO THE DATA BLOCK BUFFER IN THE 00245000
* SAME MANNER AS FOR FIXED-LENGTH ITEMS. (IF OVERFLOW 00246000
* OCCURS, IT IS HANDLED IN THE SAME MANNER AS FOR 00247000
* FIXED-LENGTH ITEMS.) 00248000
* 00249000
* FILE EXISTS, NOT ACTIVE: 00250000
* 00251000
* IF THE FILE EXISTS BUT IS NOT ACTIVE, WRBUF 00252000
* CALCULATES THE DATA BLOCK INTO WHICH THE ITEM(S) IS 00253000
* TO BE WRITTEN. THIS CALCULATION ALSO YIELDS THE 00254000
* LOCATION WITHIN THE DATA BLOCK AT WHICH THE ITEM(S) 00255000
* WILL RESIDE. ACTFREE IS CALLED TO OBTAIN AN 00256000
* AVAILABLE SLOT IN THE ACTIVE FILE TABLE AND TO STORE 00257000
* THE FST ENTRY THEREIN. NEXT, WRBUF MARKS THE FILE AS 00258000
* ACTIVE, READS THE FIRST CHAIN LINK INTO MAIN STORAGE, 00259000
* AND MOVES THE FIRST 80 BYTES OF THE FIRST CHAIN LINK 00260000
* INTO THE CHAIN LINK DIRECTORY OF THE ACTIVE FILE 00261000
* TABLE ENTRY. WRBUF THEN DETERMINES IF THE ITEM(S) TO 00262000
* BE WRITTEN ARE OF FIXED OR VARIABLE LENGTH. FOR BOTH 00263000
* OF THESE ITEM TYPES, WRBUF PROCEEDS AS DESCRIBED 00264000
* UNDER THE CORRESPONDING HEADING IN "FILE DOES NOT 00265000
* EXIST" IN THIS SECTION. 00266000
* 00267000
* FILE ACTIVE: 00268000
* 00269000
* IF THE FILE IS ACTIVE, WRBUF CALCULATES THE DATA 00270000
* BLOCK INTO WHICH THE ITEM(S) IS/ARE TO BE WRITTEN. 00271000
* THIS CALCULATION ALSO YIELDS THE DISPLACEMENT INTO 00272000
* THE DATA BLOCK AT WHICH THE ITEM(S) WILL RESIDE. 00273000
* NEXT, WRBUF DETERMINES THE NATURE OF THE ITEM(S) TO 00274000
* BE WRITTEN. IF OF VARIABLE LENGTH, WRBUF PROCEEDS AS 00275000
* DESCRIBED UNDER "VARIABLE-LENGTH ITEM". IF OF FIXED 00276000
* LENGTH, IT PROCEEDS AS DESCRIBED BLOW. 00277000
* 00278000
* FIXED-LENGTH ITEM: WRBUF DETERMINES WHETHER THE 00279000
* AFFECTED DATA BLOCK IS IN MAIN STORAGE. IF IT IS, 00280000
* WRBUF PROCEEDS AS DESCRIBED UNDER "FILE DOES NOT 00281000
* EXIST", STARTING AT THE POINT WHERE THE NUMBER OF 00282000
* BYTES AVAILABLE IN THE DATA BLOCK BUFFER IS 00283000
* CALCULATED. IF THE AFFECTED DATA BLOCK IS NOT IN MAIN 00284000
* STORAGE, WRBUF PROCEEDS IN ESSENTIALLY THE SAME 00285000
* MANNER AS DESCRIBED UNDER "FILE DOES NOT EXIST", 00286000
* STARTING AT THE POINT WHERE THE DATA BLOCK IS WRITTEN 00287000
* ONTO DISK. (IN THIS CASE, AN OVERFLOW CONDITION IS 00288000
* NOT BEING PROCESSED; HOWEVER, THE LOGIC USED TO 00289000
* OBTAIN THE AFFECTED CHAIN LINK AND DATA BLOCK IS 00290000
* ESSENTIALLY THE SAME. ALSO, BECAUSE THIS IS NOT AN 00291000
* OVERFLOW CONDITION, WHEN THE AFFECTED DATA BLOCK IS 00292000
* RESIDENT IN THE DATA BLOCK BUFFER, THE NUMBER OF 00293000
* BYTES AVAILABLE IN THAT BUFFER IS EQUAL TO 800 MINUS 00294000
* THE CALCULATED DISPLACEMENT.) 00295000
* 00296000
* VARIABLE-LENGTH ITEM: IF THE VARIABLE-LENGTH ITEM TO 00297000
* BE WRITTEN IMMEDIATELY FOLLOWS THE ONE THAT WAS JUST 00298000
* PROCESSED, WRBUF MOVES THE ITEM LENGTH FROM THE INPUT 00299000
* BUFFER INTO THE DATA BLOCK BUFFER IMMEDIATELY AFTER 00300000
* THE END OF THE PREVIOUS ITEM. IT THEN MOVES THE ITEM 00301000
* TO BE WRITTEN FROM THE INPUT BUFFER INTO THE DATA 00302000
* BLOCK BUFFER IMMEDIATELY AFTER THE LENGTH. THIS IS 00303000
* DONE IN THE USUAL MANNER. (IF OVERFLOW OCCURS, IT IS 00304000
* HANDLED IN THE USUAL MANNER.) IF THE ITEM TO BE 00305000
* WRITTEN DOES NOT IMMEDIATELY FOLLOW THE ONE THAT WAS 00306000
* JUST PROCESSED, WRBUF PROCEEDS IN THE SAME MANNER AS 00307000
* DESCRIBED UNDER THE VARIABLE-LENGTH ITEM PORTION OF 00308000
* "FILE DOES NOT EXIST". 00309000
* 00310000
* NOTES: 00311000
* 00312000
* 1. WRBUF CAN ONLY WRITE A CERTAIN NUMBER OF LOGICAL 00313000
* RECORDS OR ITEMS, REGARDLESS OF HOW MUCH DISK 00314000
* SPACE MAY BE AVAILABLE, BECAUSE THE "NUMBER OF 00315000
* ITEMS" IS KEPT IN A HALFWORD IN THE 40-BYTE FST 00316000
* ENTRY FOR THAT FILE, AND IS LIMITED BY THE SIZE OF 00317000
* A NUMBER WHICH WILL FIT IN A (16-BIT) HALFWORD. 00318000
* TO AVOID RUNNING INTO THIS LIMITATION BEFORE IT IS 00319000
* TOO LATE TO CLOSE THE FILE SUCCESSFULLY, WRBUF 00320000
* CHECKS THAT THE ITEM-NUMBER (WHEN A WRBUF CALL HAS 00321000
* BEEN COMPLETED) WILL NOT EXCEED A GIVEN LIMIT. IF 00322000
* IT DOES, AN ERROR CODE 6 IS RETURNED, AND NO MORE 00323000
* DATA IS WRITTEN. THE FILE MAY, HOWEVER, AT THIS 00324000
* POINT BE SUCCESSFULLY CLOSED (VIA FINIS), AND CAN 00325000
* LATER BE READ BY RDBUF. AT PRESENT THIS LIMITING 00326000
* NUMBER OF RECORDS HAPPENS TO BE 65533. (65533 00327000
* WOULD HAVE BEEN THE ABSOLUTE LIMITING FACTOR.) 00328000
* 00329000
* 2. IN CALLS TO QQTRK FOR OBTAINING THE FIRST CHAIN 00330000
* LINK FOR A NEW FILE, AND TO TRKLKP FOR OBTAINING 00331000
* EITHER A NEW NTH CHAIN LINK OR A DATA BLOCK, ERROR 00332000
* CODES ARE CHECKED FROM THESE FUNCTION PROGRAMS FOR 00333000
* THE FULL DISK CONDITION. IF ANY OF THESE 00334000
* SITUATIONS OCCUR, WRBUF CAREFULLY SETS OR RESETS 00335000
* ANY FLAGS OR CONDITIONS AS NEEDED, AND PRESENTS 00336000
* THE USER WITH THE NON-FATAL ERROR-CODE 13. 00337000
* THE FILE WHICH WAS BEING WRBUF'ED (UNLESS 00338000
* NULL) IS THEN AVAILABLE AND COMPLETE INSOFAR AS 00339000
* THE DATA BEING WRITTEN COULD FIT IN THE SPACE 00340000
* AVAILABLE. THE DIRECTORY IS NOT UPDATED UNLESS A 00341000
* KX IS IN EFFECT, THUS ALLOWING ANY DESIRED ERROR 00342000
* RECOVERY PROCEDURES TO BE INSTITUTED. 00343000
* 00344000
* 3. BECAUSE OF THE DESIGN OF THE FIRST CHAIN LINK IN 00345000
* THE CMS FILE SYSTEM, THERE IS A LIMITATION OF 00346000
* 16060 800-BYTE DATA BLOCKS FOR ANY GIVEN FILE. IF 00347000
* A FILE BEING WRBUF'ED REACHES THIS LIMIT, AN ERROR 00348000
* 19 IS RETURNED, AND NO MORE DATA IS WRITTEN. THE 00349000
* FILE MAY BE CLOSED, AND CAN THEN BE SUCCESSFULLY 00350000
* READ (OR ERASED), BUT IT CANNOT BE MADE ANY 00351000
* LARGER. (A FILE OF THIS SIZE WOULD FILL MORE THAN 00352000
* HALF OF A FULL-SIZE 2314 DISK). 00353000
* 00354000
* 4. THERE IS ALSO A LIMIT OF 3400 FILES THAT CAN BE 00355000
* REPRESENTED FOR ANY GIVEN DISK, AS LIMITED BY THE 00356000
* LAYOUT OF THE MFD BLOCK. IF A DISK ALREADY HAS 00357000
* REACHED THIS MAXIMUM AND AN ATTEMPT TO WRBUF A NEW 00358000
* FILE IS MADE, WRBUF RETURNS AN ERROR CODE 10, AND 00359000
* THE NEW FILE IS NOT OPENED. 00360000
* 00361000
*. 00362000
EJECT 00363000
DMSBWR START 0 (NOTE - CAN BE CALLED BY BALR WITHIN NUCLEUS) 00364000
ENTRY WRBUF 00365000
WRBUF EQU DMSBWR 00366000
* 00367000
ENTRY INVTBL 00368000
* 00369000
* ENTER 'WRBUF', SAVE REGISTERS, SET UP ADDRESSABILITY, ETC. 00370000
USING NUCON,R0 00371000
L R15,AFVS -- A(FVS) INTO R15 00372000
USING FVSECT,R15 00373000
STM R0,R14,REGSAV3 -- SAVE R0 THRU 14 00374000
DROP R15 00375000
LR R13,R15 -- REFERENCE 'FVS' INFO 00376000
USING FVSECT,R13 00377000
BALR R10,0 -- OUR OWN ADDRESSABILITY 00378000
USING *,R10 00379000
OI UFDBUSY,WRBIT SET OUR BIT IN 'UFDBUSY' FLAG 00380000
LA R1,0(,R1) MAKE THE REGISTER PRESENTABLE 00381000
LM R2,R3,PADDR(R1) CHECK ADDRESS (& BYTE-COUNT INTO R3) 00382000
LR R11,R1 AND MAKE A COPY. V0510 00383000
SR R8,R8 EMPTY A REGISTER. V0510 00384000
ICM R8,B'0011',PNOIT(R1) GET THE NUMBER OF ITEMS. V0510 00385000
LA R2,0(,R2) STRIP OFF HIGH ORDER BYTE. 00386000
LTR 2,2 00387000
LA R15,2 ERROR 2 00388000
BZ ERR IF = 0. 00389000
ST 2,PADDRX SAVE PADDR 00390000
LTR R6,R3 REMEMBER BYTE COUNT, & CHECK IT; @VA01100 00391000
LA R15,8 ERROR 8 IF 00392000
BNP ERR NOT > 0. 00393000
LA R15,0(R2,R3) COMPUTE END OF DATA @VM03232 00394000
C R15,VMSIZE COMPARE WITH VMSIZE @VM03232 00395000
BNH BUFOK GO TO IT @VA10561 00396000
CLC VMSIZE+1(3),SVCOPSW+5 DCSS USER..?? @VA10561 00396200
BH ERROR22 NO KILL HIM (RC=2) @VA10561 00396400
BUFOK EQU * @VA10561 00396600
LA R7,1 1 INTO R7 FOR GENERAL USE (FOR A WHILE) 00397000
SR R0,R0 0 INTO R0, 00398000
ST R0,FALIGN CLEAR 'FALIGN', 00399000
CR R0,R8 PNOIT > 0? V0510 00400000
BL TSTFVF BL IF OK, NO. OF ITEMS IS > 0. 00401000
STH R7,PNOIT(,R1) SET NOIT = 1 (IF IT WAS 0) 00402000
LR R8,R7 READJUST THE SAVED COPY. V0510 00403000
SPACE 1 00404000
TSTFVF EQU * 00405000
CLI PFIVA(1),C'F' TEST F-V 00406000
BE FVF 00407000
CLI PFIVA(1),C'V' 00408000
LA R15,11 ERROR 11 00409000
BNE ERR IF NOT = V. 00410000
CR R7,R8 MUST BE 1 FOR VARIABLE FILES. V0510 00411000
LA R15,18 ERROR 18 00412000
BNE ERR IF NOT = 1. 00413000
C R3,=F'65535' CHECK AGAINST MAX(ALLOWABLE) V0510 00414000
LA R15,17 ERROR 17 00415000
BH ERR IF > 65535. 00416000
FVF CLI PMODE(R1),C'A' MODE LETTER MUST BE SPECIFICALLY GIVEN 00417000
BL ERROR4 ERROR 4 IF < A 00418000
CLI PMODE(R1),C'Z' ... 00419000
BH ERROR4 OR ERROR 4 IF > Z 00420000
CLI PFILE(R1),C'*' ASTERISK IN FILENAME ? @VM03232 00421000
BE ERROR20 THAT'S ILLEGAL ... @VM03232 00422000
CLI PTYPE(R1),C'*' OR ASTERISK IN FILETYPE ? @VM03232 00423000
BE ERROR21 THAT'S IMMORAL OR FATTENING. @VM03232 00424000
LR R3,R8 MAKE A USEFUL COPY OF PNOIT. V0510 00425000
SR R4,R4 ZERO-OUT REGISTER 4 V0510 00426000
ICM R4,B'0011',PITEM(R1) GET THE STARTING ITEM-NUMBV0510 00427000
BZ LR15AA (FORGET IT IF = 0) 00428000
AR R3,R4 COMPUTE ITEM-NUMBER WE WILL HAVE 00429000
C R3,=F'65535' CHECK AGAINST MAX(ALLOWABLE). V0510 00430000
BNL ERROR6 ERROR IF > PRACTICAL LIMIT OF 65533 00431000
LR R3,R8 GET PNOIT. V0510 00432000
LR15AA L R15,AACTLKP GET ADDR OF AFT-LOOKUP. V0510 00433000
BALR R14,R15 (R0 = 0 TO SEARCH FROM BEGINNING) 00434000
BZ FOUND1 BZ IF FOUND BY ACTLKP. 00435000
SR99 SR R9,R9 R9=0 MEANS NOT FOUND BY ACTLKP 00436000
L 15,=V(DMSLFSW) CALL 'FSTLKW', THEN 00437000
BALR 14,15 ... 00438000
LR R12,R1 R1 INTO R12 IN CASE IT WAS SUCCESSFUL, 00439000
BZ FOUND2 BRANCH IF C.C. = 0 (WAS FOUND) @VM03232 00440000
CK LA R1,8(,R11) POINT TO FILE NAME HRC012DS 00441490
BAL R15,PTEST CHECK FILENAME FOR INVALID CHARS @VA01100 00442000
BZ CKTYP FILENAME WAS GOOD, SO HOW WAS FILETYPE 00443000
ERROR20 LA R15,20 TELL HIM HIS FILENAME WAS BAD @VM03232 00444000
B ERR ... 00445000
CKTYP LA R1,16(,R11) POINT TO FILE TYPE HRC012DS 00446490
BAL R15,PTEST CHECK THE FILETYPE. 00447000
BZ PLOK PASSED THIS TEST TOO. 00448000
ERROR21 LA R15,21 TELL HIM HIS FILETYPE WAS BAD @VM03232 00449000
B ERR ... 00450000
PLOK L R2,PADDRX RESTORE WHAT WE CLOBBERED 00451000
LR R1,R11 RESTORE R1 TO PARAMETER-LIST, 00452000
L R15,=V(DMSLAD) CALL 'ADTLKP' TO FIND DISK TO WRITE ON, 00453000
BALR R14,R15 ... 00454000
BNZ ERROR4 ERROR 4 IF NO DISK AT ALL MATCHING THIS LETTER 00455000
CLI PMODE+1(R11),C' ' WAS NO MODE NUMBER SPECIFIED??@VA05746 00456000
BNE CHKMD YES THERE WAS - CHECK IF ILLEGAL @VA05746 00457000
MVI PMODE+1(R11),C'1' DEFAULT MODE NUMBER TO 1 @VA05746 00458000
CHKMD DS 0H @VA05746 00459000
CLI PMODE+1(R11),C'0' IS MODE NUMBER LEGAL? 00460000
BL ERROR5 BRANCH IF NOT 00461000
CLI PMODE+1(R11),C'6' ARE WE SURE? 00462000
BNL ERROR5 BRANCH IF > 5 (NO GOOD) @VA01100 00463000
USING ADTSECT,R1 IF FOUND, REFERENCE ACTIVE-DISK-TABLE, 00464000
TM ADTFLG1,ADTFRW IT BETTER BE A READ-WRITE DISK, 00465000
BZ CANTWRIT ERROR IF IT ISN'T. 00466000
L R0,ADTFSTC TOTAL NO. OF FILES ON THIS DISK 00467000
CH R0,MAXFILES MAXIMUM NO? 00468000
BNL FILSBUST BRANCH IF SO 00469000
LR R0,R1 IF OK, PLACE IN R0 FOR ACTFREE SHORTLY, 00470000
SR R1,R1 AND CLEAR R1 FOR ACTFREE. 00471000
DROP R1 00472000
CLI PFIVA(R11),C'F' FIXED FILE? @VA02521 00473000
BE INIT YES - NO PROBLEM @VA02521 00474000
LA R15,1 VARIABLE-STARTING ITEM NUMBER @VA02521 00475000
CLM R15,B'0011',PITEM(R11) MUST NOT EXCEED 1 @VA02521 00476000
BNL INIT OK IF 0 OR 1 @VA02521 00477000
B ERROR7 ERROR7 IF 2 OR MORE @VA02521 00478000
ERROR5 LA R15,5 ERROR 5 IF MODE NO. < 0 OR > 5. @VA01100 00479000
B ERR ... 00480000
* 00481000
FOUND1 LR R9,R1 REFERENCE ACTIVE-FILE-TABLE, 00482000
USING AFTSECT,R9 ... 00483000
LA R12,AFTFST POINT R12 TO COPY OF FST BLOCK IN AFT BLOCK 00484000
TM AFTFLG,AFTWRT ACTIVE-WRITE ? 00485000
BO FOUND2 BO IF YES (GOOD SHOW), CONTINUE BELOW. 00486000
TM AFTFLG,AFTRD ACTIVE-READ ? 00487000
LA R15,9 ERROR 9 00488000
BO ERR IF YES. 00489000
L R1,AFTADT IF NEITHER (MUST BE FROM A 'POINT'), 00490000
USING ADTSECT,R1 REFERENCE ACTIVE-DISK-TABLE 00491000
TM ADTFLG1,ADTFRW IT BETTER BE A READ-WRITE DISK, 00492000
BZ JCANTWRT MAKE SPECIAL CHECK IF IT ISN'T. 00493000
DROP R1,R9 (FOR NOW) 00494000
* 00495000
USING FSTSECT,R12 (BRIEFLY) 00496000
FOUND2 CLC FSTFV(1),PFIVA(R11) IS CHARACTERISTIC CORRECT 00497000
LA R15,16 ERROR 16 00498000
BNE ERR IF NOT CORRECT 00499000
CLI FSTFV,C'V' IS IT VARIABLE LENGTH ITEM 00500000
BE PROCES YES, DON'T WORRY ABOUT LENGTH 00501000
L R2,FSTIL TEST NO. OF BYTES 00502000
L R15,FSTIL GET ITEM LENGTH V0510 00503000
MR R14,R8 GET SIZE OF REQUEST. V0510 00504000
CR R15,R6 EQUAL TO PNOBY? V0510 00505000
BE PROCES SAME AS BEFORE 00506000
* 00507000
LA R15,15 ERROR 15 IF WRONG 00508000
B ERR NUMBER OF BYTES 00509000
DROP R12 00510000
SPACE 3 00511000
PTEST DS 0H CHECK CHARACTER VALIDITY HRC012DS 00512690
LA R5,7(,R1) PNT AT LAST BYTE OF NAME HRC012DS 00513380
LR R0,R1 SAVE POINTER BEFORE TRT HRC012DS 00514070
TRT 0(8,R1),INVTBL CHECK FOR INVALID CHARACTER HRC012DS 00514760
BZR R15 IF ALL OK, EXIT WITH CC = 0. HRC012DS 00515450
CR R0,R1 DID TRT ERROR AT FIRST CHAR HRC012DS 00516140
BE SETCODE ERROR ON FIRST CHARACTER HRC012DS 00516830
SR R5,R1 CHECK IF FIRST CHAR INVALID HRC012DS 00517520
* SIZE IS -1 FOR EXECUTE INST HRC012DS 00518210
BMR R15 TSK! TSK! BAD LIST HRC012DS 00518900
EX R5,CLC CHECK THE REST FOR BLANKS HRC012DS 00519590
BR R15 EXIT WITH CC SET 0 OR ¬0 HRC012DS 00520280
SETCODE DS 0H SET A NON ZERO CONDITION CODE HRC012DS 00520970
CR R15,R1 R15 = RETURN, R1 = PRAM LIST HRC012DS 00521660
BR R15 RETURN TO CALLER WITH CC = 2 HRC012DS 00522350
CLC CLC 0(0,R1),INVTBL CHECK FOR BLANKS IN NAME HRC012DS 00523040
EJECT 00525000
******************************************************* 00526000
* 00527000
* OPEN NEW FILE WITH SPECIFIED FILE NAME, FILE TYPE. 00528000
* ASSIGN ENTRY IN ACTIVE STATUS TABLE AND ASSIGN FIRST 00529000
* CHAIN LINK. 00530000
* 00531000
**************************************************** 00532000
* 00533000
* NOTE : R11 ALREADY POINTS TO ORIGINAL P-LIST 00534000
* (NEEDED BY 'ACTFREE') 00535000
* 00536000
INIT L R15,AACTFREE CALL 'ACTFREE' TO OPEN THE FILE 00537000
BALR R14,R15 ... 00538000
LR R9,R1 REFERENCE ACTIVE-FILE-TABLE 00539000
USING AFTSECT,R9 ... 00540000
MVC AFTN(16),PFILE(R11) MOVE IN FILENAME & FILETYPE 00541000
XC AFTD(24),AFTD CLEAR FROM DATE THRU TO END OF 40-BYTES 00542000
MVC AFTFV(1),PFIVA(R11) CHARACTERISTIC 00543000
MVC AFTM(2),PMODE(R11) MODE, 00544000
STH R7,AFTWP SET WRITE- AND 00545000
STH R7,AFTRP READ-POINTERS TO 1 00546000
LR R15,R6 GET PNOBY. V0510 00547000
SR 14,14 ... 00548000
DR R14,R3 CALCULATE INDIVIDUAL ITEM LENGTH 00549000
LTR R15,R15 IS IT GREATER THAN ZERO? @VA04192 00550000
BNP ERROR14 NO - ERROR @VA04192 00551000
LTR R14,R14 WAS THERE A REMAINDER? @VA04192 00552000
BZ SETITEM NO - ITEM LENGTH IS OK @VA04192 00553000
ERROR14 LA R15,14 BUFFER SIZE NOT INTEGRALLY @VA04192 00554000
B ERR DIVISIBLE BY # RECORDS TO WRITE @VA04192 00555000
SETITEM ST R15,AFTIL SET ITEM LENGTH @VA04192 00556000
STH R4,AFTIC STORE ITEM NO. (IF ANY) - STILL IN R4 00557000
LR R1,R0 R1 MUST POINT TO ACTIVE DISK TABLE, 00558000
LR R12,R1 REMEMBER ADDR ACTIVE DISK TABLE @VA01247 00559000
L R15,AQQTRK AND CALL 'QQTRK' 00560000
BALR R14,R15 TO OBTAIN FIRST CHAIN LINK 00561000
BNZ QQBAD BAD NEWS IF ERROR FROM QQTRK 00562000
STH R1,AFTFCL IF OK, RECORD DISK-ADD. OF 1ST CHAIN-LINK 00563000
MVI AFTFLG2,AFTNEW FLAG AS TOTALLY NEW FILE. V0510 00564000
USING ADTSECT,R12 REFERENCE ACTIVE DISK TABLE @VA01247 00565000
L R15,ADTFSTC TOTAL NO. OF FILES ON THIS DISK @VA01247 00566000
AR R15,R7 BUMP COUNT BY 1 (R7 STILL = 1) @VA01247 00567000
ST R15,ADTFSTC AND STORE NEW VALUE @VA01247 00568000
DROP R12 @VA01247 00569000
LA R12,AFTFST POINT R12 TO COPY OF FST BLOCK IN AFT BLOCK 00570000
* CONTINUE TO 'PROCES' ... 00571000
EJECT 00572000
*************************************************** 00573000
* THE POSITION OF THE ITEM IN THE DATA BLOCK IS CALCULATED 00574000
* IF THE CURRENT CHAIN LINK AND DATA BLOCK ARE CURRENTLY 00575000
* IN CORE, THE ITEM IS INSERTED IN THE DATA BLOCK AND WRBUF 00576000
* RETURNS TO THE CALLING ROUTINE. IF A DIFFERENT DATA BLOCK 00577000
* OR CHAIN LINK ARE REQUIRED, THE SECTIONS OF CODE 00578000
* FOLLOWING THIS SECTION ARE REQUIRED. 00579000
* 00580000
**************************************************** 00581000
* 00582000
USING FSTSECT,R12 (FOR A WHILE) 00583000
PROCES LTR R4,R4 IS ITEM-NUMBER SUPPLIED IN P-LIST ? 00584000
BP LR34 BP IF YES, USE IT. 00585000
SR R4,R4 EMPTY OUT A REGISTER. V0510 00586000
ICM R4,B'0011',FSTWP GET THE WRITE-POINTER. V0510 00587000
AR R3,R4 TEST FOR TOO MANY ITEMS 00588000
C R3,=F'65535' CHECK AGAINST THE MAXIMUM V0510 00589000
BL LR34 TRF IF OK - NO MORE THAN 65533. 00590000
ERROR6 LA R15,6 ERROR 6 IF MORE ITEMS TO BE IN A FILE 00591000
B ERR THAN CAN FIT INTO A HALFWORD COUNTER ! 00592000
* 00593000
LR34 LR R3,R4 CALCULATE BLOCK 00594000
BCTR 3,0 NO. AND BYTE NO. 00595000
M R2,FSTIL WITHIN BLOCK 00596000
D R2,EIGHTHD BLOCKNO IN 3; BYTENO IN 2. V0510 00597000
L R15,FSTIL GET NO. BYTES TO BE WRITTEN. V0510 00598000
MR R14,R8 MULTIPLY BY THE NUMBER OF ITEMS. V0510 00599000
LR R5,R15 PUT PRODUCT INTO R5. V0510 00600000
DROP R12 00601000
LTR R9,R9 DO WE NEED TO GET AN ACTIVE TABLE ENTRY ? 00602000
BP SETWR BP IF WE'VE ALREADY GOT ONE. 00603000
L R15,AACTFREE IF NOT, CALL ACTFREE 00604000
BALR R14,R15 (R0 & R1 ARE STILL SET FROM FSTLKW) 00605000
LR R9,R1 REFERENCE ACTIVE FILE TABLE VIA R9, 00606000
* 00607000
SETWR L R12,AFTADT REFERENCE ACTIVE DISK TABLE 00608000
ST R12,PLIST+12 STORE IN RDTK/WRTK P-LIST 00609000
STH R4,AFTWP STORE WRITE-POINTER 00610000
NI AFTFLG2,255-SAMELEN INITIALIZE SAME LENGTH @VA09491 00610500
TM AFTFLG,AFTWRT IS IT ALREADY AN ACTIVE-WRITE ? 00611000
BO INSERT BO IF YES, GET ON WITH IT. 00612000
OI AFTFLG,AFTWRT IT'S AN ACTIVE WRITE NOW, CONTINUE... 00613000
LA R0,125 GET 1000 BYTES OF FREE STORAGE. V0510 00614000
DMSFREE DWORDS=(0),TYPE=NUCLEUS,TYPCALL=BALR, @VA03665X00615000
ERR=ERROR25P @VA03665 00616000
USING ADTSECT,R12 @VA03665 00617000
LH R15,ADTNACW INCREMENT NUMBER OF ACTIVE @VA03665 00618000
AR R15,R7 WRITE FILES BY 1 @VA03665 00619000
STH R15,ADTNACW AND STORE NEW VALUE @VA03665 00620000
SR R14,R14 ZERO FOR DIVIDE @VA04916 00621000
D R14,=F'20' (20 FST'S PER HYPERBLOCK) @VA04916 00622000
LTR R14,R14 ANY REMAINDER? @VA04916 00623000
BP RESOK YES; SKIP @VA04916 00624000
LH R14,ADTRES NO; INCREMENT RESERVE COUNT @VA04916 00625000
LA R14,2(,R14) BY 2 (DISK MAY BE UPDATED TWICE) @VA04916 00626000
STH R14,ADTRES AND RESTORE IT @VA04916 00627000
DROP R12 @VA04916 00628000
RESOK ST R1,AFTFCLA SAVE ADDRESS OF THE FCL BUFFER @VA04916 00629000
LR R6,R1 WE'LL NEED THIS LATER. V0510 00630000
XC 0(200,R1),0(R1) ZERO-OUT THE FCL IN STORAGE. V0510 00631000
LA R1,200(,R1) DATA BUFFER IS 200 BYTES BEYOND. V0510 00632000
ST R1,AFTDBA SAVE ADDR OF DATA-BLOCK BUFFER. V0510 00633000
TM AFTFLG2,AFTNEW IS THIS A NEW FILE? V0510 00634000
BO RESET ALREADY DONE, IF SO. V0510 00635000
SR R7,R7 SIGNAL READING AN FCL. V0510 00636000
LA R8,AFTFCL POINT TO THE DISK ADDR REQUIRED. V0510 00637000
BAL R14,FSRD1 READ IT IN. V0510 00638000
BNZ ERROR3 BETTER TO QUIT IF ERROR. V0510 00639000
RESET MVC AFTCLB(80),0(6) MOVE CL DISK ADDRS TO AFT V0510 00640000
MVC AFTCLN(2),ONEH SIGNAL THIS IS THE FCL. V0510 00641000
MVC AFTCLD(2),AFTFCL SET DISK ADDR OF FCL. V0510 00642000
CLI AFTFV,C'V' IS IT A VARIABLE LENGTH ITEM? V0510 00643000
BE VARINT YES. INITIALIZE THE FILE. V0510 00644000
FINDBLOK BAL R14,DISKRD FIND THE RIGHT DATA BLOCK, @VM03232 00645000
B INSRT AND GO INSERT THE RECORD(S). @VM03232 00646000
INSERT DS 0H NOTE -- R9 NOW ALREADY POINTS TO RIGHT ACTIVE-TABLE 00647000
CLI AFTFV,C'V' IS IT VARIABLE LENGTH ITEM 00648000
BE VARINS YES - INSERT ITEM @VM03232 00649000
TM AFTFLG,AFTDBF IS THERE A DATA BLOCK IN STORAGE?@VM03232 00650000
BZ FINDBLOK IF NOT, GO FIND THE RIGHT BLOCK. @VM03232 00651000
LH R6,AFTDBN YES - GET "DATA BLOCK NUMBER", @VM03232 00652000
CR R6,R3 DOES IT CONTAIN THIS RECORD ? @VM03232 00653000
BE INSRT YES - GO INSERT THE RECORD(S). @VM03232 00654000
WRITEBLK BAL R14,DISKRW NO - WRITE CURRENT BLOCK FIRST @VM03232 00655000
* INSERT GIVEN RECORD(S) IN DATA BLOCK (AND WRITE IT OUT IF FULL): 00656000
* NOTE: R2 = DISPLACEMENT OF RECORD; R5 = NO. OF BYTES TO BE WRITTEN 00657000
INSRT L R8,PADDRX GET ADDR. OF DATA TO BE WRITTEN @VM03232 00658000
LTR R2,R2 START ON A BLOCK BOUNDARY ? @VM03232 00659000
BNZ RESL NOPE - MUST MOVE THE DATA ETC. @VM03232 00660000
C R5,EIGHTHD IF YES, BLOCK COUNT 800 OR MORE? @VM03232 00661000
BNL LARGEBLK YES - WRITE FORTHWITH. @VM03232 00662000
* HANDLE GENERAL CASE OF SMALL AND/OR UNALIGNED LOGICAL RECORD: 00663000
RESL OI AFTFLG,AFTDBF SIGNAL DATA BLOCK IS IN STORAGE @VM03232 00664000
L R0,AFTDBA GET ADDRESS OF DATA BLOCK @VM03232 00665000
AR R0,R2 ADDRESS OF WHERE TO MOVE TO @VM03232 00666000
LR R14,R8 WHERE TO MOVE FROM @VM03232 00667000
LA R6,Q800 CALCULATE SPACE REMAINING @VM03232 00668000
SR R6,R2 IN THE BLOCK @VM03232 00669000
CR R6,R5 WILL THE RECORD FIT IN THE @VM03232 00670000
* BLOCK ? 00671000
BNL PUTEX YES - PUT IT IN THE BLOCK AND @VM03232 00672000
* EXIT. 00673000
* RECORD WILL NOT FIT IN DATA BLOCK: 00674000
LR R1,R6 SET BYTE COUNT TO WHAT WILL FIT @VM03232 00675000
LR R15,R6 ... @VM03232 00676000
MVCL R0,R14 MOVE WHAT WE CAN @VM03232 00677000
AR R8,R6 BUMP ADDRESS BY NO. BYTES WRITTEN@VM03232 00678000
ST R8,PADDRX REMEMBER FOR LATER, @VM03232 00679000
SR R5,R6 SIMILARLY DECREMENT COUNT @VM03232 00680000
SR R2,R2 R2=0 MEANS START AT BEGIN OF BLK @VM03232 00681000
A R3,ONE BUMP DISK "BLOCK" NUMBER @VM03232 00682000
B WRITEBLK GO WRITE OUT FILLED-UP BLOCK. @VM03232 00683000
SPACE 00684000
LARGEBLK EQU * LARGE BLOCK (800 BYTES OR MORE) @VM03232 00685000
* R2 = DISPLACEMENT = 0 00686000
* R3 = "BLOCK NUMBER" (0 UP) 00687000
* R5 = BYTE COUNT = 800 OR MORE 00688000
* R8 = ADDRESS OF DATA TO BE WRITTEN 00689000
NI AFTFLG,FF-AFTDBF SIGNAL "NO DATA BLOCK EXISTS" @VM03232 00690000
ST R2,AFTDBD ALSO CLEAR AFTDBD (AND AFTDBN) @VM03232 00691000
ST R8,PLIST STORE STARTING DATA-ADDRESS @VM03232 00692000
LR R7,R3 GET "BLOCK NUMBER" (0 UP) @VM03232 00693000
SH R7,SIXTY LESS SIXTY @VM03232 00694000
BM LARGEB1 BRANCH IF BLK NO. WAS 0-59 @VM03232 00695000
SR R6,R6 IF 60 OR MORE, DIVIDE @VM03232 00696000
D R6,FOURHD BY 400 TO GET C.L. OFFSET @VM03232 00697000
LA R7,Q798 SET LIMIT FOR END OF CHAIN LINK @VM03232 00698000
L R2,AFTCLA GET ADDRESS OF NTH CHAIN LINK, @VM03232 00699000
B LARGEB2 BRANCH TO COMMON CODE BELOW. @VM03232 00700000
LARGEB1 LR R6,R3 GET BLOCK NUMBER AGAIN (0-59) @VM03232 00701000
LA R7,Q118 SET LIMIT FOR END OF CHAIN LINK @VM03232 00702000
L R2,AFTFCLA GET ADDRESS OF FIRST CHAIN LINK @VM03232 00703000
LA R2,Q80(,R2) PLUS OFFSET TO POINT TO DATA BLKS@VM03232 00704000
LARGEB2 AR R6,R6 DOUBLE THE CHAIN LINK OFFSET @VM03232 00705000
AR R7,R2 COMPUTE ADDRESS OF CHAIN LINK END@VM03232 00706000
AR R2,R6 COMPUTE WHERE WE WILL START @VM03232 00707000
ST R2,PLIST+8 STORE IN WRTK P-LIST @VM03232 00708000
LA R6,2 R6=2 FOR BXLE USE @VM03232 00709000
* "GETBLOCK" LOOP TO OBTAIN DISK BLOCKS ON WHICH TO WRITE THE DATA: 00710000
LARGEB3 A R3,ONE INCREMENT "BLOCK NUMBER" @VM03232 00711000
SR R15,R15 CLEAR R15 PLEASE, @VM03232 00712000
CH R15,0(,R2) CHECK FOR PRE-EXISTING BLOCK @VM03232 00713000
BNE LARGEB4 IF SOMETHING THERE, USE IT @VM03232 00714000
BAL R14,GETBLOCK IF NOT, GET A NEW BLOCK @VM03232 00715000
BNZ LARGEB5 BEWARE OF FULL DISK @VM03232 00716000
STH R1,0(,R2) OK - STORE NEW BLOCK DISK ADDR @VM03232 00717000
LH R14,AFTDBC INCREMENT DATA-BLOCK-COUNT @VM03232 00718000
LA R14,1(,R14) ... @VM03232 00719000
STH R14,AFTDBC ... @VM03232 00720000
LARGEB4 LA R14,Q800 NEED PHYSICAL BLOCK LENGTH, @VM03232 00721000
AR R8,R14 BUMP DATA-BLOCK ADDRESS @VM03232 00722000
SR R5,R14 DECREMENT BYTE COUNT @VM03232 00723000
CR R5,R14 AT LEAST 800 BYTES LEFT ? @VM03232 00724000
BL LARGEB6 IF NOT, GO WRITE. @VM03232 00725000
BXLE R2,R6,LARGEB3 ITERATE "GETBLOCK" LOOP ... @VM03232 00726000
B LARGEB6 NO ROOM LEFT IN CHAIN LINK. @VM03232 00727000
SPACE 00728000
* ERROR FROM DMKTRK (TRKLKP) TRYING TO GET A BLOCK ON DISK: 00729000
LARGEB5 BAL R14,GIVEBACK GIVE BACK BLOCK WE WON'T USE @VM03232 00730000
LA R15,4 REMEMBER ERROR 4 FROM TRKLKP @VM03232 00731000
BCTR R3,0 ALSO DECREMENT R3 BLOCK NUMBER @VM03232 00732000
SPACE 00733000
* NO MORE ROOM IN CHAIN LINK OR WE HAVE ALL THE BLOCKS WE NEED: 00734000
LARGEB6 STH R3,AFTDBN KEEP "AFTDBN" CURRENT @VM03232 00735000
LR R2,R15 REMEMBER TRKLKP RETURN CODE @VM03232 00736000
LR R1,R8 ACCUMULATED ADDRESS INTO R1, @VM03232 00737000
S R1,PLIST COMPUTE ACCUMULATED BYTE-COUNT, @VM03232 00738000
BNP LARGEB7 BEWARE NO BLOCKS WRITTEN AT ALL, @VM03232 00739000
ST R1,PLIST+4 OK - STORE IN WRTK PLIST @VM03232 00740000
LA R1,PLIST POINT TO WRTK P-LIST, @VM03232 00741000
L R15,AWRTK GET ADDRESS OF WRTK @VM03232 00742000
BALR R14,R15 WRITE OUT THE BLOCK(S) @VM03232 00743000
BNZ ERROR3 VERY DISAPPOINTING IF WRTK ERROR @VM03232 00744000
* NOW CHECK TO SEE IF WE HAVE ANY MORE TO DO ... 00745000
LARGEB7 LTR R2,R2 CHECK TRKLKP RETURN CODE @VM03232 00746000
BNZ WRCHECK IF NOT 0, USE DISK-IS-FULL LOGIC @VM03232 00747000
* CONTINUE IF R2 (BYTE DISPLACEMENT) = 0: 00748000
LTR R0,R5 CHECK REMAINING BYTE COUNT R5/R0 @VM03232 00749000
BZ UPDPT IF NOTHING LEFT, GO FINISH UP. @VM03232 00750000
ST R8,PADDRX PRESERVE R8 (DATA ADDRESS) @VM03232 00751000
B FINDBLOK GO CALL DISKRD & GO TO INSRT. @VM03232 00752000
SPACE 00753000
* RECORD WILL FIT IN DATA BLOCK: 00754000
PUTEX LR R1,R5 BYTE COUNT @VM03232 00755000
LR R15,R5 ... @VM03232 00756000
MVCL R0,R14 MOVE RECORD TO FREE STORAGE BLK @VM03232 00757000
* NOTE: R0 POINTS TO END OF RECORD 00758000
S R0,AFTDBA MAKE RELATIVE TO DATA BLOCK @VM03232 00759000
UPDPT EQU * FINISH UP AND GET OUT OF HERE: @VM03232 00760000
STH R0,AFTID AND STORE ITEM DISPLACEMENT @VM03232 00761000
SR R6,R6 TIP OVER A REGISTER. V0510 00762000
ICM R6,B'0011',AFTWP GET THE WRITE-POINTER. V0510 00763000
AH 6,PNOIT(0,11) UPDATE WRITE POINTER 00764000
STH R6,AFTWP 00765000
STH 6,AFTIN STORE ITEM NUMBER 00766000
BCTR 6,0 NO. OF ITEMS = WRITE POINTER - 1 00767000
CLM R6,M3,AFTIC IS WRITE-PTR > NO. OF ITEMS? @VA07151 00768000
BNH CLIV BNH IF NOT. 00769000
STH R6,AFTIC YES, SET NEW NO. ITEMS COUNT 00770000
CLIV CLI AFTFV,C'V' IS IT VARIABLE LENGTH ? 00771000
BNE LMREG NO, NO NEED TO UPDATE LENGTH 00772000
L R15,PNOBY(,R11) GET LENGTH OF THIS RECORD @VM03232 00773000
CL R15,AFTIL IS THIS RECORD THE LONGEST YET ? @VM03232 00774000
BNH LMREG NO - GO RESTORE REGISTERS @VM03232 00775000
ST R15,AFTIL STORE NEW LONGEST ITEM LENGTH @VM03232 00776000
LMREG SR R15,R15 CLEAR REGISTER 15 FOR SUCCESSFUL RETURN 00777000
* 00778000
ERR KXCHK WRBIT CHECK FOR 'KX' WANTED... 00779000
LTR R13,R13 HAS CHAIN LINK BEEN WRITTEN ? 00780000
BM WRBEX3 TRF IF YES - HANDLE SPECIALLY. 00781000
WRBEX1 LTR R15,R15 SET CONDITION-CODE FOR CONVENIENCE OF CALLER 00782000
WRBEX2 LM R0,R14,REGSAV3 RESTORE REGISTERS R0-R14 00783000
BR R14 AND RETURN TO CALLER. 00784000
SPACE 1 00785000
WRBEX3 LR R3,R15 REMEMBER THE RETURN-CODE IN R3; @VA01100 00786000
L R2,AFTADT NEED ADDR OF ADT FOR THIS DISK @VA01100 00787000
MOVEREGS MVC REGSAV4(60),REGSAV3 AVOID REGSAVING PROBLEMS. V0510 00788000
LR R0,R2 POINT TO THE ADT. V0510 00789000
SR R1,R1 SIGNAL JUST TFINIS. V0510 00790000
L R15,ATFINIS GET THE ADDR OF TFINIS. V0510 00791000
BALR R14,R15 GO THERE. V0510 00792000
SR R1,R1 SIGNAL WE WANT TO RESERVE BLOCKS. V0510 00793000
L R15,AUPDISK GET THE ADDR OF UPDISK. V0510 00794000
BALR R14,R15 GO THERE. V0510 00795000
MVC REGSAV3(60),REGSAV4 REAVOID REGSAVING PROBLEMS V0510 00796000
LR R1,R2 R1 MUST POINT TO THE ADT @VA01100 00797000
SR R0,R0 GET REASSIGNED NTH CHAIN LINK @VA01100 00798000
ICM R0,B'0011',AFTCLDX ... (IS THERE ONE?) @VA01100 00799000
BZ NOCLDX APPARENTLY NOT. V0510 00800000
* (R1 STILL POINTS TO THE ADT) 00801000
L R15,ATRKLKPX GET THE ADDR OF TRKLKPX. V0510 00802000
BALR R14,R15 GIVE BACK THE OLD N'TH CL. V0510 00803000
ICM R0,B'0011',AFTOCLDX GET "OLD" AFTCLDX @VA01100 00804000
BZ NOCLDX (IF ANY) @VA01100 00805000
* (R1 STILL POINTS TO THE ADT) 00806000
L R15,ATRKLKPX GET ADDR OF TRKLKPX AGAIN @VA01100 00807000
BALR R14,R15 AND "DO IT AGAIN, SAM". @VA01100 00808000
NOCLDX ICM R0,B'0011',AFTFCLX GET OLD FCL DISK ADDR IF ANY @VA01100 00809000
BZ NOFCLX IF NOT, DON'T TRY TO GIVE BACK @VA01100 00810000
* (R1 STILL POINTS TO THE ADT) 00811000
L R15,AQQTRKX GET THE ADDR OF QQTRKX. V0510 00812000
BALR R14,R15 GIVE BACK THE OLD FCL. V0510 00813000
NOFCLX SR R15,R15 FINALLY, CLEAR ... @VA01100 00814000
ST R15,AFTFCLX AFTFCLX AND AFTCLDX @VA01100 00815000
STH R15,AFTOCLDX AND "OLD AFTCLDX" @VA01100 00816000
NI AFTFLG2,255-(AFTCLX+AFTOLDCL) CLEAR FLAG BITS @VA01100 00817000
LR R0,R2 POINT TO THE ADT AGAIN. V0510 00818000
LNR R1,R0 MAKE THE REGISTER NEGATIVE. V0510 00819000
L R15,AUPDISK GET THE ADDR OF UPDISK AGAIN. V0510 00820000
BALR R14,R15 REALLY UPDATE THE DISK NOW. V0510 00821000
CLC AFTCLN(2),ONEH IS THIS A FIRST CHAIN LINK? V0510 00822000
BE ALLDONE NO TROUBLE IF SO. V0510 00823000
OI AFTFLG2,AFTOLDCL SET "AFTOLDCL" FLAGBIT AGAIN @VA01100 00824000
ALLDONE LTR R15,R3 RESTORE RETURN-CODE AND SET C.C. @VA01100 00825000
B WRBEX2 GO TO THE COMMON EXIT. V0510 00826000
EJECT 00827000
********************************************************************** 00828000
* 00829000
* VARIABLE LENGTH ITEM ROUTINE 00830000
* FILE JUST OPENED. 00831000
* 00832000
********************************************************************** 00833000
* 00834000
VARINT SR R4,R4 ZERO OUT A REGISTER. V0510 00835000
ICM R4,B'0011',AFTIC GET THE NUMBER OF ITEMS. V0510 00836000
CLM R4,B'0011',AFTWP REPLACING LAST RECORD ? @VA09491 00836040
BE LASTREC YES, OK @VA09491 00836080
BL MAYADD CHECK FOR ADDING NEXT RECORD @VA09491 00836120
TM AFTFLG2,AFTNEW CHECK NEW FILE @VA09491 00836160
BO LASTREC YES, ALLOW DIFFERENT LENGTH @VA09491 00836200
TM DOSFLAGS,DOSMODE IN DOS MOD ? @VA09491 00836240
BO LASTREC YES, SKIP LENGTH CHECK @VA09491 00836280
OI AFTFLG2,SAMELEN CHECK SAME LENGTH @VA09491 00836320
LH R6,FCBNUM COUNT OF FCB ENTRIES @VA09491 00836360
LTR R6,R6 ARE THERE ANY ? @VA09491 00836400
BZ LASTREC NO , SKIP THE CHECK @VA09491 00836440
LA R3,0(,R11) POINT TO WRBUF PLIST @VA09491 00836480
S R3,SIXTEEN BACK UP 4 WORDS @VA09491 00836520
L R7,FCBFIRST FCB ANCHOR @VA09491 00836560
USING FCBSECT,R7 FCB ADDRESSABILITY @VA09491 00836600
LOOPFCB EQU * @VA09491 00836640
CLC FCBDD,EIGHT(R3) FCB DDNAME IN PLIST @VA09491 00836680
BE FOUNDFCB YES, CHECK IT @VA09491 00836720
L R7,0(,R7) BUMP TO NEXT FCB @VA09491 00836760
BCT R6,LOOPFCB LOOP THRU ENTRIES @VA09491 00836800
B LASTREC NOT FOUND @VA09491 00836840
FOUNDFCB EQU * CHECK RECORD FORMAT @VA09491 00836880
NI AFTFLG2,255-SAMELEN NO LENGTH CHECK @VA09491 00836920
LA R7,0(,R7) CLEAR HIGH BYTE @VA09491 00836960
CR R7,R3 THE SAME FCB ? @VA09491 00837000
BNE LASTREC NO, FORGET IT @VA09491 00837040
ICM R3,M7,DEBDCBAD+1 DCB POINTER IN FCB @VA09491 00837080
BZ LASTREC NO , SKIP DCB CHECK @VA09491 00837120
C R3,VMSIZE BEYOND ADDRESSABILITY @VA09491 00837160
BNL LASTREC YES , SKIP IT @VA09491 00837200
USING IHADCB,R3 DCB ADDRESSABILITY @VA09491 00837240
TM DCBRECFM,UND RECFM = UNDEFINED @VA09491 00837280
BO LASTREC YES , SKIP LENGTH CHECK @VA09491 00837320
OI AFTFLG2,SAMELEN ALL REPLACES MUST BE @VA09491 00837360
* THE SAME LENGTH AS BEFORE @VA09491 00837400
B LASTREC BYPASS NEXT CHECK @VA09491 00837440
DROP R3 DROP DCB ADDRESSABILITY @VA09491 00837480
DROP R7 DROP FCB ADDRESSABILITY @VA09491 00837520
MAYADD DS 0H @VA09491 00837560
LA R4,1(,R4) CHECK FOR ADDING ONE RECORD @VA09491 00837600
SR R15,R15 EMPTY ANOTHER REGISTER. V0510 00838000
ICM R15,B'0011',AFTWP AND GET THE WRITE-POINTER. V0510 00839000
CR R4,R15 WRITE PTR. MUST NOT EXCEED NO. OF ITEMS 00840000
BL ERROR7 ERROR 7 IF TROUBLE 00841000
LASTREC DS 0H @VA09491 00841500
SR 3,3 SET TO READ BLOCK NO. 0 00842000
MVC AFTIN(2),ONEH SET THE ITEM NO. TO 1. V0510 00843000
STH R3,AFTID SET DISPLACEMENT = 0 00844000
BAL R14,DISKRD READ APPROPRIATE DATA BLOCK @VM03232 00845000
VARLP1 CLC AFTIN(2),AFTWP ARE WE AT WRITE PLACE 00846000
BE ALLSET YUP, ALMOST FINISHED 00847000
LH 2,AFTID GET DISPLACEMENT WITHIN DATA BLOCK 00848000
C 2,F798 IS ITEM LENGTH IN BLOCK 00849000
BH OVERLP NO, IT PROTRUDES 00850000
BE OVERL3 ONLY LENGTH IN BLOCK 00851000
LR 5,2 GET LOC. OF ITEM LENGTH 00852000
A 5,AFTDBA ... 00853000
SR R15,R15 CLEAR REG, @VM03232 00854000
ICM R15,B'0011',0(R5) MOVE TO NEXT ITEM @VM03232 00855000
LA 2,2(2,15) (ADJUST FOR 2-BYTE ITEM LENGTH) 00856000
VARLP2 EQU * ... 00857000
C R2,EIGHTHD IS ITEM IN THIS BLOCK? V0510 00858000
BL INBLCK YES, SET ITEM NO. AND DISPLACEMENT 00859000
S R2,EIGHTHD SAVE THE COUNT. V0510 00860000
ST 2,SAVECT ... 00861000
LA 3,1(,3) GET NEXT BLOCK 00862000
BAL R14,DISKRD ... @VM03232 00863000
L 2,SAVECT RESTORE COUNT 00864000
B VARLP2 TEST FOR ITEM 00865000
INBLCK STH 2,AFTID STORE DISPLACEMENT 00866000
SR R2,R2 EMPTY A REGISTER V0510 00867000
ICM R2,B'0011',AFTIN GET ITEM-NUMBER FOR INCREMENTINV0510 00868000
LA 2,1(,2) ... 00869000
STH 2,AFTIN ... 00870000
B VARLP1 TEST ITEM NUMBER 00871000
SPACE 1 00872000
OVERLP C R2,EIGHTHD IS IT IN THE NEXT BLOCK? V0510 00873000
BE OVERL2 YES, READ IT IN 00874000
LR 5,2 GET LOC. OF FIRST BYTE 00875000
A 5,AFTDBA ... 00876000
MVC ALIGN(1),0(5) MOVE FIRST BYTE 00877000
LA 3,1(,3) READ NEXT BLOCK 00878000
BAL R14,DISKRD ... @VM03232 00879000
L 5,AFTDBA GET LOC. OF SECOND BYTE 00880000
MVC ALIGN+1(1),0(5) ... 00881000
L R2,FALIGN GET ITEM LENGTH 00882000
LA 2,1(,2) (ADJUST FOR 1-BYTE LENGTH) 00883000
B VARLP2 CONTINUE ON 00884000
OVERL2 LA 3,1(,3) READ NEXT BLOCK 00885000
BAL R14,DISKRD ... @VM03232 00886000
L 5,AFTDBA GET ITEM LENGTH 00887000
SR R2,R2 MAKE A WORK REGISTER. V0510 00888000
ICM R2,B'0011',0(R5) V0510 00889000
LA 2,2(,2) (ADJUST FOR 2-BYTE LENGTH) 00890000
B VARLP2 CONTINUE ON 00891000
OVERL3 LR 5,2 GET LOC. OF ITEM LENGTH 00892000
A 5,AFTDBA ... 00893000
MVC ALIGN(2),0(5) SAVE ITEM LENGTH 00894000
LA 3,1(0,3) GET NEXT BLOCK 00895000
BAL R14,DISKRD ... @VM03232 00896000
L R2,FALIGN SET ITEM LENGTH 00897000
B VARLP2 CONTINUE 00898000
SPACE 3 00899000
********************************************************************** 00900000
* 00901000
* VARIABLE LENGTH ITEM ROUTINE 00902000
* FILE WAS ALREADY OPEN. 00903000
* 00904000
********************************************************************** 00905000
VARINS LH R3,AFTDBN BE SURE TO SET BLOCK NO. CORRECTLY P3060 00906000
CLC AFTIN(2),AFTWP ARE WE AT THE WRITE PLACE? P3060 00907000
BE ALLSET YES, THAT WAS EASY 00908000
L R6,AFTDBA POINT TO THE DATA BLOCK BUFFER. V0510 00909000
LA R8,AFTDBD POINT TO THE DISK ADDR OF THE DATA V0510 00910000
BAL R14,CONFSWR WRITE OUT THE DATA BLK (IF ANY) @VM03232 00911000
BZ VARINT IF R15 = 0, SEARCH FOR CORRECT PLACE 00912000
ERROR3 L R14,ADISKDIE STOP NOW TO PRESERVE @VA00895 00913000
BR R14 OLD DIRECTORY @VA00895 00914000
EJECT 00915000
********************************************************************** 00916000
* 00917000
* VARIABLE LENGTH ITEM ROUTINE 00918000
* SET VARIABLE LENGTH ITEM LENGTH, AND INSERT DATA 00919000
* 00920000
********************************************************************** 00921000
ALLSET LH 2,AFTID GET DISPLACEMENT 00922000
C 2,F798 IS EVERYTHING IN THIS BLOCK 00923000
BH ALS2 NO, ADJUST THINGS 00924000
BE ALS5 ONLY LENGTH IN THIS BLOCK 00925000
ALS4 LTR R5,R2 GET DISPLACEMENT FOR ITEM LENGTH @VM03232 00926000
BNZ ALS4A BEWARE OF 0 (OK IF NOT). @VM03232 00927000
CH R5,AFTDBD IS DATA BLOCK NONEXISTENT ? @VM03232 00928000
BNE ALS4A NOPE (WHEW) - WE'RE OK. @VM03232 00929000
BAL R14,DISKRD YES - INITIALIZE DATA BLOCK @VM03232 00930000
ALS4A A R5,AFTDBA FORM ADDRESS FOR ITEM LENGTH @VM03232 00931000
TM AFTFLG2,SAMELEN MUST CHECK LENGTH ? @VA09491 00931100
BZ LAB1 NO,CONTINUE @VA09491 00931200
CLC 0(2,R5),PNOBY+2(R11) IS LENGTH OK @VA09491 00931300
BNE ERROR27 NO , WRONG LENGTH @VA09491 00931400
LAB1 DS 0H @VA09491 00931500
MVC 0(2,5),PNOBY+2(11) INSERT ITEM LENGTH 00932000
LA 2,2(,2) ADJUST DISPLACEMENT 00933000
L 5,PNOBY(,11) SET NUMBER OF BYTES TO WRITE 00934000
B INSRT INSERT DATA INTO BLOCK 00935000
ALS2 C R2,EIGHTHD IS IT IN THIS BLOCK? V0510 00936000
BE ALS3 NO, GET NEXT ONE 00937000
LR 5,2 GET LOC. TO PUT FIRST BYTE 00938000
A 5,AFTDBA ... 00939000
TM AFTFLG2,SAMELEN MUST CHECK LENGTH ? @VA09491 00939100
BZ LAB2 NO, CONTINUE @VA09491 00939200
CLC 0(1,R5),PNOBY+2(R11) IS FIRST HALF OK ? @VA09491 00939300
BNE ERROR27 NOPE @VA09491 00939400
LAB2 DS 0H @VA09491 00939500
MVC 0(1,5),PNOBY+2(11) INSERT FIRST BYTE TO ITEM LENGTH 00940000
LA 3,1(,3) GET NEXT BLOCK 00941000
BAL R14,DISKRW ... @VM03232 00942000
L 5,AFTDBA GET LOC. TO PUT SECOND BYTE 00943000
TM AFTFLG2,SAMELEN MUST CHECK LENGTH @VA09491 00943100
BZ LAB3 NO, CONTINUE @VA09491 00943200
CLC 0(1,R5),PNOBY+3(R11) IS SECOND HALF OK ? @VA09491 00943300
BNE ERROR27 NO, DIFFERENT LENGTH @VA09491 00943400
LAB3 DS 0H @VA09491 00943500
MVC 0(1,5),PNOBY+3(11) INSERT SECOND BYTE 00944000
LA 2,1 SET DISPLACEMENT=1 00945000
L 5,PNOBY(,11) SET NUMBER OF BYTES TO WRITE 00946000
B INSRT INSERT DATA INTO BLOCK 00947000
ALS3 LA 3,1(,3) GET NEXT BLOXK 00948000
BAL R14,DISKRW ... @VM03232 00949000
SR 2,2 SET DISPLACEMENT=0 00950000
B ALS4 SET ITEM LENGTH 00951000
ALS5 LR 5,2 GET LOC. TO PUT ITEM LENGTH 00952000
A 5,AFTDBA ... 00953000
TM AFTFLG2,SAMELEN MUST CHECK LENGTH @VA09491 00953100
BZ LAB4 NO, CONTINUE @VA09491 00953200
CLC 0(2,R5),PNOBY+2(R11) IS LENGTH OK @VA09491 00953300
BNE ERROR27 NO, DIFFERENT LENGTH @VA09491 00953400
LAB4 DS 0H @VA09491 00953500
MVC 0(2,5),PNOBY+2(11) INSERT ITEM LENGTH 00954000
LA 3,1(0,3) GET NEXT BLOCK 00955000
BAL R14,DISKRW ... @VM03232 00956000
SR 2,2 SET DISPLACEMENT 00957000
L 5,PNOBY(0,11) AND NO. OF BYTES 00958000
B INSRT INSERT DATA 00959000
ERROR27 EQU * @VA09491 00959200
LA R15,27 ERROR CODE 26 @VA09491 00959400
B ERR RETURN WITH AN ERROR @VA09491 00959600
EJECT 00960000
********************************************************************** 00961000
* 00962000
* DISK INTERFACE ROUTINE FOR FIXED OR VARIABLE LENGTH ITEM(S) 00963000
* 00964000
* PARAMETERS- 00965000
* 00966000
* REG. 3 - DESIRED DATA BLOCK NO. 00967000
* REG. 14 - RETURN ADDRESS 00968000
* 00969000
********************************************************************** 00970000
* 00971000
* DISKRD - READ DESIRED BLOCK 00972000
DISKRD ST R14,DSKRET SAVE RETURN ADDRESS @VM03232 00973000
B SWICH2 GO TO IT @VM03232 00974000
* 00975000
* DISKRW - WRITE CURRENT BLOCK BEFORE READ 00976000
DISKRW ST R14,DSKRET SAVE RETURN ADDRESS @VM03232 00977000
* 00978000
* CONTINUE 'IN LINE' TO 'SWICH' ... 00979000
SPACE 00980000
******************************************************** 00981000
* 00982000
* THE CURRENT DATA BLOCK IS WRITTEN ON THE DISK. IF A 00983000
* DIFFERENT CHAIN LINK IS REQUIRED TO DEFINE THE NEW DATA 00984000
* BLOCK, THE OLD CHAIN LINK IS WRITTEN ONTO THE DISK AND 00985000
* THE NEXT CHAIN LINK IS OBTAINED FROM THE DISK IF IT HAD 00986000
* BEEN PREVIOUSLY DEFINED. IF A NEW CHAIN 00987000
* LINK MUST BE DEFINED, ITS ADDRESS IS PLACED IN THE FIRST 00988000
* CHAIN LINK. THE NEXT DATA BLOCK THEN IS READ FROM 00989000
* THE DISK IF IT PREVIOUSLY EXISTED, OR IF IT DID NOT EXIST, 00990000
* IT IS NOW DEFINED BY PLACING ITS NEW DISK ADDRESS IN THE 00991000
* CHAIN LINK. THE PROGRAM RETURNS TO THE PRIVIOUS SECTION 00992000
* OF CODE FOR INSERTION OF THE DATA ITEM INTO THE DATA BLOCK 00993000
* WHICH WAS JUST SET UP IN CORE. 00994000
* 00995000
********************************************** 00996000
SWICH L R6,AFTDBA POINT TO THE DATA BLOCK BUFFER. V0510 00997000
LA R8,AFTDBD INDICATE THE DISK ADDR. V0510 00998000
BAL R14,CONFSWR WRITE OUT THE DATA BLK (IF ANY) @VM03232 00999000
BNZ ERROR3 BNZ IF PERMANENT I/O ERROR ON DISK. 01000000
SWICH2 LH 8,AFTCLN IS THIS THE RIGHT 01001000
C 8,ONE CHAIN LINK 01002000
BE RCL YES - BRANCH. @VM03232 01003000
SH R8,TWOH NO - CALCULATE @VM03232 01004000
L 7,FOURHD (X-2)*400+60 01005000
MR 6,8 01006000
AH 7,SIXTY LOWER LIMIT TEST 01007000
CR 7,3 01008000
BH LINKSW WRONG CHAIN LINK 01009000
A 7,THRNN 01010000
CR 7,3 UPPER LIMIT TEST 01011000
BNL NLKPTR RIGHT BLOCK NO. 01012000
LINKSW L R6,AFTCLA POINT TO THE CHAIN LINK BUFFER V0510 01013000
LA R8,AFTCLD POINT TO THE ADDR ON DISK V0510 01014000
BAL R14,FSWR WRITE OUT THE CHAIN LINK. V0510 01015000
BNZ ERROR3 QUIT IF UNEXPECTED ERROR. V0510 01016000
TM AFTFLG2,AFTCLX HAS ANY MODIFICATION TAKEN PLACE? V0510 01017000
BNO RELINK PROCEED WITH ABANDON,IF NOT. V0510 01018000
O R13,SIGNBIT R13 'MINUS' MEANS C.L. HAS BEEN WRITTEN 01019000
RELINK CH 3,FIFNI IS BLOCK NO. BETWEEN 01020000
BH MORTST ZERO AND 59 01021000
MVC AFTCLN(2),ONEH SET CHAIN-LINK-NUMBER TO 1 01022000
MVC AFTCLD(2),AFTFCL DISK ADDR OF FCL. V0510 01023000
CLNUP NI AFTFLG2,255-AFTOLDCL ALL ELSE CORRECT. V0510 01024000
LR R4,R3 MAKE A COPY OF THE BLOCK NUMBER. V0510 01025000
AR R4,R4 DOUBLE IT, FOR INDEXING. V0510 01026000
LA R4,80(,R4) SHOW OFFSET INTO FCL FOR DATA BLOCK V0510 01027000
L R8,AFTFCLA POINT TO FCL BUFFER. V0510 01028000
B FCLNUP PRETEND THAT WE JUST READ IT IN. V0510 01029000
* 01030000
RCL CH R3,FIFNI IS BLOCK NO. BETWEEN 0 AND 59 ? @VM03232 01031000
BNH CLNUP BRANCH IF YES @VM03232 01032000
TM AFTFLG2,AFTCLX HAS ANY MODIFICATION TAKEN PLACE?@VM03232 01033000
BNO MORTST NO WORRY, IF NOT. @VM03232 01034000
O R13,SIGNBIT PRETEND A CHAIN LINK WAS WRITTEN @VM03232 01035000
* AND CONTINUE TO "MORTST" ... 01036000
MORTST SR 6,6 CALCULATE (N-60)/400+2 01037000
LR 7,3 =X=NO. C.L. TO BE 01038000
SH 7,SIXTY PLACED IN CORE 01039000
D 6,FOURHD 01040000
LA 7,2(0,7) 01041000
CH R7,MAXCHAIN ARE BEYOND CHAIN-LINK 41 ? 01042000
BH ERROR19 ERROR 19 IF YES - DON'T LET HIM DO IT. 01043000
STH 7,AFTCLN 01044000
TM AFTFLG,AFTFBA IS BUFFER FOR N'TH 01045000
BO CLODT CHAIN LINK ASSIGNED, YES 01046000
LA R0,100 GET N'TH CHAIN-LINK BUFFER. V0510 01047000
DMSFREE DWORDS=(0),TYPE=NUCLEUS,TYPCALL=BALR V0510 01048000
LTR R15,R15 MUST ACQUIRE FREE STORAGE @VA02374 01049000
BNZ ERROR25 OR FAIL @VA02374 01050000
ST 1,AFTCLA 01051000
OI AFTFLG,AFTFBA SET N'TH BUF. ASSIGN. BIT 01052000
CLODT LH 8,AFTCLN DOES CHAIN LINK 01053000
AR R8,R8 SOUGHT EXIST ON 01054000
SH 8,FOUR DISK-CALCULATE X*2-4 01055000
LH R6,AFTCLB(R8) 01056000
LTR 6,6 01057000
BZ ASQRK NO 01058000
STH 6,AFTCLD STORE DISK ADDR. OF CHAIN LINK 01059000
L R6,AFTCLA POINT TO THE CHAIN LINK BUFFER. V0510 01060000
LA R8,AFTCLB(R8) POINT TO OFFSET OF CHAIN LINK ADDR V0510 01061000
BAL R14,FSRD READ IN THE CHAIN LINK. V0510 01062000
BNZ ERROR3 QUIT ON ERROR CONDITION. V0510 01063000
OI AFTFLG2,AFTOLDCL SIGNAL NCL EXISTED PREVIOUSLY. V0510 01064000
B NLKPTR NOW LOCATE THE DATA BLOCK. V0510 01065000
ASQRK BAL R14,GETBLOCK GET A CHAIN LINK ALLOCATED. V0510 01066000
BNZ BADNEWS IF ERROR FROM TRKLKP GETTING A CHAIN-LINK 01067000
STH 1,AFTCLD DISK ADDR. OF CHAIN LINK IN CORE 01068000
STH R1,AFTCLB(R8) INSERT C.L. ADDR. IN F.C.L. 01069000
L 14,AFTCLA CLEAR N'TH CHAIN 01070000
L R15,EIGHTHD SIZE INTO R15 @VA01100 01071000
SR R1,R1 CLEAR R1 (R0 IS IMMATERIAL) @VA01100 01072000
MVCL R14,R0 CLEAR THE N'TH CHAIN LINK @VA01100 01073000
NLKPTR LR 7,3 FIND POINTER TO ADDRESS 01074000
SH 7,SIXTY OF DATA BLOCK IN 01075000
SR R6,R6 CHAIN LINK 01076000
D 6,FOURHD EQUAL REMAINDER OF (X-60)/400=R 01077000
AR 6,6 R*2=POINTER 01078000
LR 4,6 01079000
L R8,AFTCLA POINT TO THE CHAIN LINK BUFFER. V0510 01080000
FCLNUP SR R6,R6 CREATE POINTER COMPARATOR. V0510 01081000
AR R4,R8 RESOLVE OFFSET OF DATA ADDR. V0510 01082000
CH R6,0(,R4) IS ANYTHING THERE? V0510 01083000
BE QTRK GET ONE, IF NOT. V0510 01084000
L R6,AFTDBA POINT TO THE DATA BUFFER. V0510 01085000
LR R8,R4 POINT TO THE DISK ADDR. V0510 01086000
BAL R14,FSRD READ IN THE BLOCK. V0510 01087000
BNZ ERROR3 BNZ IF PERMANENT I/O ERROR ON DISK. 01088000
MVC AFTDBD(2),0(4) INSERT DISK ADDR. OF DATA 01089000
STH 3,AFTDBN PUT CURRENT BLOCK NO. IN TABLE 01090000
B DISKRRT RETURN TO INSERT NEW ITEM 01091000
* BLOCK CURRENTLY IN CORE 01092000
QTRK CLC AFTDBC(2),MAXBLKS MAX. NO. OF DATA BLOCKS BEEN REACHED 01093000
BNL ERROR19 ERROR 19 IF YES - QUIT NOW. 01094000
BAL R14,GETBLOCK ASSIGN A BLOCK. V0510 01095000
BNZ NEWCHECK BNZ IF ERROR-CODE FROM TRKLKP NOT = 0. 01096000
LH R14,AFTDBC INCREMENT NO. OF QUARTER DATA TRACKS 01097000
LA 14,1(,14) 01098000
STH R14,AFTDBC REPLACE IN F.S.T. TABLE 01099000
STH 1,AFTDBD D.A. OF DATA BLOCK IN CORE 01100000
STH 1,0(0,4) DISK ADDR. TO CHAIN LINK 01101000
STH R3,AFTDBN PUT CURRENT BLOCK NO. IN TABLE 01102000
L 14,AFTDBA CLEAR DATA BLOCK 01103000
L R15,EIGHTHD SIZE INTO R15 @VA01100 01104000
SR R1,R1 CLEAR R1 (R0 IS IMMATERIAL) @VA01100 01105000
MVCL R14,R0 CLEAR THE DATA BLOCK @VA01100 01106000
TM AFTFLG2,AFTNEW IS THIS A NEW FILE? V0510 01107000
BO NOSWAP NO WORRIES, IF SO. V0510 01108000
TM AFTFLG2,AFTOLDCL MODIFYING SOMETHING PERCHANCE? V0510 01109000
BNO FLAGMOD IF NOT, SIGNAL IT MILDLY ANYWAY. V0510 01110000
BAL R14,GETBLOCK GET AN ALTERNATE NTH CHAIN LINK @VA01100 01111000
BNZ PORCPINE IF N.G., HANDLE "VERY CAREFULLY" @VA01100 01112000
LH R8,AFTCLN GET THE CHAIN LINK NUMBER. V0510 01113000
AR R8,R8 DOUBLED, FOR HALF-WORD LOGIC. V0510 01114000
SH R8,FOUR AND OFFSET A LITTLE. V0510 01115000
MVC AFTOCLDX(2),AFTCLDX SAVE "OLD AFTCLDX" (IF ANY) @VA01100 01116000
LH R15,AFTCLB(R8) NOW , GET THE OLD DISK ADDR. V0510 01117000
STH R15,AFTCLDX SAVE IT FOR LATER. V0510 01118000
STH R1,AFTCLB(R8) INSTALL THE ALTERNATE ADDR. V0510 01119000
STH R1,AFTCLD ALL OVER THE PLACE. V0510 01120000
FLAGMOD OI AFTFLG2,AFTCLX SAY SOMETHING HAS BEEN CHANGED. V0510 01121000
* ASSIGN AN ALTERNATE FIRST CHAIN LINK (UNLESS WE ALREADY HAVE ONE): 01122000
L R15,AFTADT @VM03203 01123000
USING ADTSECT,R15 @VM03203 01124000
TM ADTFLG3,ADTFXCHN ANY OLD CHAIN LINKS? @VM03203 01125000
BNO FLGMODA NO, THEN CONTINUE @VM03203 01126000
O R13,SIGNBIT YES,THEN CALL TFINIS LATER @VM03203 01127000
DROP R15 @VM03203 01128000
FLGMODA SR R0,R0 GET 'OLD' FIRST CHAIN LINK @VM03203 01129000
ICM R0,B'0011',AFTFCLX DOES IT EXIST ? @VA01100 01130000
BNZ NOSWAP IF YES, WE ALREADY HAVE NEW ONE @VA01100 01131000
L R1,AFTADT NO, POINT TO THE ADT; @VA01100 01132000
L R15,AQQTRK AND GET A "NEW" FIRST CHAIN LINK @VA01100 01133000
BALR R14,R15 ..... @VA01100 01134000
BNZ NOSWAP UH-OH IF NO ROOM LEFT AT THE INN @VA01100 01135000
MVC AFTFCLX(2),AFTFCL SAVE OLD FCL DISK-ADDRESS @VA01100 01136000
STH R1,AFTFCL START USING THE NEW FCL @VA01100 01137000
CLC AFTCLN(2),ONEH IS THIS THE FCL ? @VA01100 01138000
BNE NOSWAP NO - NOT AT THE MOMENT @VA01100 01139000
STH R1,AFTCLD YES - STORE HERE ALSO @VA01100 01140000
NOSWAP NI AFTFLG2,255-AFTOLDCL CLEAR "AFTOLDCL" FLAG @VA01100 01141000
DISKRRT L R14,DSKRET GET RETURN-ADDRESS @VM03232 01142000
BR R14 HOME AGAIN. @VM03232 01143000
SPACE 01144000
* HANDLE "VERY CAREFULLY" IF ALTERNATE NTH CHAIN LINK IS UNAVAILABLE... 01145000
PORCPINE LR R0,R1 SET UP R0, @VA01100 01146000
L R1,AFTADT ALSO SET UP R1, AND @VA01100 01147000
L R15,ATRKLKPX GIVE BACK THE BLOCK @VA01100 01148000
BALR R14,R15 (SINCE WE WON'T BE USING IT) @VA01100 01149000
O R13,SIGNBIT FORCE CALL TO TFINIS ETC WHEN WE @VA01100 01150000
B FLAGMOD ARE DONE; GO SET FLAG & CONTINUE @VA01100 01151000
SPACE 3 01152000
FSRD LA R7,800 ASSUME AN 800-BYTE BLOCK. V0510 01153000
FSRD1 L R15,ARDTK GET THE ADDR OF RDTK. V0510 01154000
B RDWR GET COMMON. V0510 01155000
* "CONDITIONAL" ENTRY EQUIVALENT TO "FSWR" WHERE AFTDBD IS USED: 01156000
CONFSWR SR R15,R15 WRITE DATA BLOCK IF IT EXISTS: @VM03232 01157000
CH R15,AFTDBD AS GIVEN BY "AFTDBD" @VM03232 01158000
BER R14 IF NONEXISTENT, RETURN FORTHWITH @VM03232 01159000
FSWR L R15,AWRTK GET THE ADDR OF WRTK. V0510 01160000
LA R7,800 ASSUME 800-BYTE WRITE. V0510 01161000
RDWR LA R1,PLIST POINT TO THE PLIST. V0510 01162000
STM R6,R8,PLIST SET UP PASSED PARAMS. V0510 01163000
BR R15 READ/WRITE WITH RETURN TO CALLER. V0510 01164000
SPACE 1 01165000
GETBLOCK L R1,AFTADT POINT TO THE ADT. V0510 01166000
L R15,ATRKLKP GET THE ADDR OF TRKLKP. V0510 01167000
BR R15 GET A BLOCK AND RETURN. V0510 01168000
EJECT 01169000
********************************************************************** 01170000
* 01171000
* CONSTANTS AND DEFINITIONS 01172000
* 01173000
********************************************************************** 01174000
* 01175000
* PARAMETER LIST DISPLACEMENTS (GENERALLY R11) 01176000
* 01177000
PFILE EQU 8 01178000
PTYPE EQU 16 01179000
PMODE EQU 24 01180000
PITEM EQU 26 01181000
PADDR EQU 28 01182000
PNOBY EQU 32 01183000
PFIVA EQU 36 01184000
PNOIT EQU 38 01185000
* 01186000
* NUMERICAL CONSTANTS 01187000
* 01188000
* HALFWORD CONSTANTS ... 01189000
* 01190000
TWOH DC H'2' 01191000
FOUR DC H'4' 01192000
FIFNI DC H'59' 01193000
SIXTY DC H'60' 01194000
* 01195000
MAXFILES DC H'3400' MAX. NO. OF FILES CMS CAN HANDLE @VA03764 01196000
MAXBLKS DC H'16060' MAXIMUM NO. OF DATA BLOCKS FOR ONE FILE 01197000
MAXCHAIN DC H'41' HIGHEST CHAIN-LINK WE CAN NOW HANDLE 01198000
SIXTEEN DC F'16' FULLWORD SIXTEEN @VA09491 01198500
* 01199000
* FULLWORD CONSTANTS 01200000
* 01201000
ONE DC F'1' 01202000
ONEH EQU ONE+2 'ONE' AS A HALFWORD. 01203000
FOURHD DC F'400' 01204000
THRNN DC F'399' 01205000
ONEGRP DC F'256' 01206000
F798 DC F'798' 01207000
EIGHTHD DC F'800' V0510 01208000
* 01209000
* ADDRESS CONSTANTS 01210000
* 01211000
SIGNBIT DC X'80000000' TO SIGNAL THAT CHAIN-LINK HAS BEEN WRITTEN 01212000
* 01213000
* EQUATES 01214000
* 01215000
M3 EQU 3 @VA07151 01216000
M7 EQU 7 MASK SEVEN @VA09491 01216200
EIGHT EQU 8 MISCELLANEOUS 8 @VA09491 01216400
EJECT 01217000
* 01218000
* SPECIAL ERROR-HANDLING PURPOSELY AT THE END ... 01219000
* (R10 ADDRESSABILITY STILL IN EFFECT) 01220000
* 01221000
ADISKDIE DC V(DISKDIE) 'DIE' FOR DISK-ERROR. 01222000
* 01223000
QQBAD L R2,AFTADT R2 POINTS TO ADT FOR MESSAGE HANDLING 01224000
B RELQQ ERROR 01225000
* 01226000
* WATCH OUT FOR NEW DATA-BLOCK IN NEW CHAIN-LINK ... 01227000
* 01228000
NEWCHECK LA R2,4 SET INCREMENTER AND @VA01100 01229000
LA R3,796(,R8) SET LIMIT FOR BXLE (R6 STILL=0) @VA01100 01230000
CR604 C R6,0(,R8) IS CHAIN-LINK ALL ZEROES ? @VA01100 01231000
BNE JCHECK TRF IF NOT COMPLETELY EMPTY @VA01100 01232000
BXLE R8,R2,CR604 ITERATE FOR ENTIRE 800-BYTE C. L.@VA01100 01233000
LR R2,R1 SAVE R1 FOR LATER, 01234000
LR R3,R15 DITTO R15 01235000
L R15,ATRKLKPX CALL TRKLKPX 01236000
SR R0,R0 EMPTY A REGISTER V0510 01237000
ICM R0,B'0011',AFTCLD GET THE DASD ADDR OF THE CHAIN-V0510 01238000
L R1,AFTADT EMPTY CHAIN-LINK 01239000
BALR R14,R15 ... 01240000
LH R8,AFTCLN GET CHAIN-LINK-NUMBER 01241000
AR R8,R8 TIMES TWO (E.G. 4,6,8, ETC.) 01242000
STH R6,AFTCLB-4(R8) CLEAR EMPTY C.L. IN ACTTAB LINKAGE 01243000
STH R6,AFTCLD ***** AND HERE IF NECESSARY ************* 01244000
LR R1,R2 RESTORE R1 AND 01245000
LR R15,R3 R15 FROM BEFORE 01246000
* 01247000
BADNEWS OI AFTFLG,AFTFULD WARN FINIS NOT TO WRITE NULL CHAIN-LINK 01248000
* 01249000
JCHECK CH R15,FOUR SEE IF = ERROR 4 ('VERY FEW' LEFT) ? 01250000
BNE WRCHECK BNE IF NOT, MAKE ONE FURTHER CHECK 01251000
BAL R14,GIVEBACK GIVE BACK BLOCK WE WON'T USE @VM03232 01252000
WRCHECK L R2,AFTADT R2 POINTS TO ADT FOR MESSAGE HANDLING 01253000
SR R8,R8 CLEAR A HANDY REGISTER, 01254000
CH R8,AFTDBC DO WE HAVE ANY DATA-BLOCKS AT ALL YET ? 01255000
BL ERROR13 BL IF YES (> 0), FINIS WILL FINISH IT UP. 01256000
L R1,AFTADT IF FILE 'NULL', SET UP R1 01257000
SR R0,R0 ZERO REGISTER 0 V0510 01258000
ICM R0,B'0011',AFTFCL GET THE FIRST CHAIN LINK ADDR @VA01109 01259000
L R15,AQQTRKX CALL QQTRKX TO GIVE BACK THE 1ST CHAIN 01260000
BALR R14,R15 LINK (SINCE WE WON'T BE USING IT) 01261000
USING ADTSECT,R1 01262000
L R15,ADTFSTC TOTAL NUMBER OF FILES. V0510 01263000
BCTR R15,0 DECREMENT 01264000
ST R15,ADTFSTC STORE AS THE NEW VALUE. V0510 01265000
LH R15,ADTNACW NO. OF FILES OPEN FOR WRITING 01266000
BCTR R15,0 DECREMENT BY 1 01267000
STH R15,ADTNACW STORE NEW VALUE 01268000
DROP R1 01269000
LA R0,125 RETURN THE 1000-BYTE AREA 01270000
L R1,AFTFCLA WHICH IS STILL LYING AROUND @VA01109 01271000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR @VM03083 01272000
RELQQ LR R1,R9 POINT TO ACTIVE-FILE-TABLE, 01273000
L R15,AACTFRET GIVE IT BACK VIA ACTFRET, 01274000
BALR R14,R15 ... 01275000
B ERROR13J JOIN CODE BELOW (WITH R13 PLUS) @VA01100 01276000
* 01277000
GIVEBACK L R15,ATRKLKPX IF ERROR (4) FROM TRKLKP, @VM03232 01278000
LR R0,R1 SET UP R0 FOR TRKLKPX, @VM03232 01279000
L R1,AFTADT ALSO SET UP R1, GIVE IT BACK, @VM03232 01280000
BR R15 AND RETURN DIRECTLY TO CALLER. @VM03232 01281000
* 01282000
ERROR13 DS 0H COMES HERE IF NO (OR VERY FEW) TRACKS LEFT 01283000
O R13,SIGNBIT R13 MINUS TO CALL TFINIS LATER @VA01100 01284000
ERROR13J EQU * JOIN HERE IF FILE = NULL. @VA01100 01285000
LR R8,R2 SET R8 FOR ADDRESSABILITY IN WARMSG 01286000
LA R2,LFULLMSG POINT TO ERROR MESSAGE P0751 01287000
LA R3,107 AND SETUP THE ERROR NUMBER P0751 01288000
BAL R6,WARMSG CALL MESSAGE SUBROUTINE P0751 01289000
CLI AFTFV,C'V' VARIABLE LENGTH? @VA04222 01290000
BE VARGO YES, THEN NO CALC @VA04222 01291000
LH R15,AFTDBC GET NO. DATA BLOCKS @VA04222 01292000
SR R14,R14 ZERO OUT OTH REG @VA04222 01293000
M R14,EIGHTHD GET ANSWER NO. OF BYTES @VA04222 01294000
L R6,AFTIL GET LENGTH OF RECORD @VA04222 01295000
SR R14,R14 CLEAN R14 AGAIN @VA04222 01296000
DR R14,R6 DIVIDE BY LENGTH @VA04222 01297000
CLM R15,3,AFTIC IS ITEM COUNT LARGER NOW? @VA04222 01298000
BNH VARGO NO, THEN DON'T STORE NEW ITEM @VA04222 01299000
* COUNT 01300000
STH R15,AFTIC SET NEW ITEM COUNT @VA04222 01301000
VARGO LA R15,13 SET ERROR CODE 13 @VA04222 01302000
B ERR @VA04222 01303000
* 01304000
ERROR7 LA R15,7 01305000
B ERR 01306000
* 01307000
ERROR4 LA R15,4 ERROR 4 01308000
B ERR 01309000
* 01310000
ERROR19 LA R15,19 ERROR 19 (BEYOND FILE SYSTEM LIMITS) 01311000
B ERR 01312000
SPACE 1 01313000
USING ADTSECT,R12 @VA03665 01314000
ERROR25P L R15,ADTFSTC TOTAL NUMBER OF FILES @VA03665 01315000
TM AFTFLG2,AFTNEW TEST FOR NEW FILE @VA08045 01316000
BNO ERROR25R IF NOT THEN SKIP DECRMNT @VA08045 01317000
BCTR R15,0 DECREMENT @VA03665 01318000
ST R15,ADTFSTC STORE AS THE NEW VALUE @VA03665 01319000
DROP R12 @VA03665 01320000
L R1,AFTADT GET ADDRESS OF ADT @VA03665 01321000
SR R0,R0 @VA03665 01322000
ICM R0,B'0011',AFTFCL GET ADDR OF FIRST CHAIN LINK @VA03665 01323000
L R15,AQQTRKX GIVE BACK FIRST CHAIN LINK @VA03665 01324000
BALR R14,R15 @VA03665 01325000
LR R1,R9 ADDR OF ACTIVE FILE TABLE @VA03665 01326000
ERROR25R EQU * @VA08045 01327000
L R15,AACTFRET GIVE IT BACK @VA03665 01328000
BALR R14,R15 @VA03665 01329000
ERROR25 LA R15,25 CORE NOT AVAILABLE FOR @VA03665 01330000
B ERR UFD BUFFERS @VA03665 01331000
* 01332000
FILSBUST DS 0H TOO MANY FILES ON ONE DISK 01333000
LR R8,R1 SET R8 FOR ADDRESSABILITY IN WARMSG 01334000
LA R2,LBUSTMSG POINT TO THE MESSAGE P0751 01335000
LA R3,170 SET UP THE ERROR NUMBER P0751 01336000
BAL R6,WARMSG CALL MESSAGE SUBROUTINE P0751 01337000
LA R15,10 SET ERROR CODE 10 01338000
B ERR 01339000
* 01340000
JCANTWRT DS 0H DISK CANNOT BE WRITTEN ON 01341000
USING ADTSECT,R1 01342000
CLI ADTMX,C' ' IF ACTIVE FROM POINT, IS IT A ... 01343000
BE CANTWRIT READ-ONLY EXTENSION (ERROR IF NOT). 01344000
CLC 24(1,R11),ADTMX IF YES, DOES IT MATCH CALLER'S MODE ? 01345000
BNE CANTWRIT TRF IF NOT (DEFINITELY IN ERROR). 01346000
DROP R1 01347000
L R15,AACTFRET IF R/O EXT. OF OUR DISK, 01348000
LR R1,R9 RESTORE R1 TO POINT TO AFT ENTRY, 01349000
BALR R14,R15 GET IT OUT OF THE ACTIVE FILE TABLE, 01350000
LR R1,R11 RESTORE R1 TO CALLER'S P-LIST, 01351000
B SR99 AND RE-ENTER LOGIC FOR 'OUR' DISK 01352000
* 01353000
CANTWRIT EQU * 01354000
LA R15,12 SET ERROR CODE 12 01355000
B ERR 01356000
* 01357000
ERROR22 DMSERR TEXT='Virtual Storage capacity exceeded', @VA02525X01358490
NUM=109,LET=S,TYPCALL=BALR @VA02525 01359000
LA R15,22 ERROR CODE 22 @VA02525 01360000
B ERR @VA02525 01361000
* 01362000
USING ADTSECT,R8 P0751 01363000
WARMSG L R7,ADTDTA POINT TO THE DEVICE TABLE ENTRY P0751 01364000
DMSERR MF=(E,'SYS'),NUM=(3),LET=S,TEXTA=(2), P0751*01365000
TYPCALL=BALR,SUB=(CHARA,(ADTM,1),HEX4A,((7),2)) P0751 01366000
BR R6 P0751 01367000
DROP R8 P0751 01368000
* 01369000
LBUSTMSG DC AL1(L'BUSTMSG) P0751 01370000
BUSTMSG DC C'Disk ''..(....)'' has maximum number of files' *01371290
HRC012DS 01371580
* 01372000
LFULLMSG DC AL1(L'FULLMSG) P0751 01373000
FULLMSG DC C'Disk ''..(....)'' is full' HRC012DS 01374490
SPACE 2 01375000
DS 0D ALIGN INVTBL ... @VM03232 01376000
INVTBL DC 256X'40' X'40' MEANS "INVALID" HRC012DS 01377190
ORG INVTBL+78 HRC012DS 01377380
DC X'00' '+' IS VALID PLUS HRC012DS 01377570
ORG INVTBL+91 HRC012DS 01377760
DC X'00' '$' IS VALID DOLLAR HRC012DS 01377950
ORG INVTBL+96 HRC012DS 01378140
DC X'00' '-' IS VALID DASH/HYPHEN HRC012DS 01378330
ORG INVTBL+109 HRC012DS 01378520
DC X'00' '_' IS VALID UNDERSCORE HRC012DS 01378710
ORG INVTBL+122 HRC012DS 01378900
DC X'00' ':' IS VALID COLON HRC012DS 01379090
ORG INVTBL+123 01380000
DC 2X'00' '#' AND '@' ARE VALID @VA01100 01381000
ORG INVTBL+129 01382000
DC 9X'00' LOWER CASE 'A' THRU 'I' ARE VALID @VA01100 01383000
ORG INVTBL+145 01384000
DC 9X'00' LOWER CASE 'J' THRU 'R' ARE VALID @VA01100 01385000
ORG INVTBL+162 01386000
DC 8X'00' LOWER CASE 'S' THRU 'Z' ARE VALID @VA01100 01387000
ORG INVTBL+193 01388000
DC 9X'00' UPPER CASE 'A' THRU 'I' ARE VALID @VA01100 01389000
ORG INVTBL+209 01390000
DC 9X'00' UPPER CASE 'J' THRU 'R' ARE VALID @VA01100 01391000
ORG INVTBL+226 01392000
DC 8X'00' UPPER CASE 'S' THRU 'Z' ARE VALID @VA01100 01393000
ORG INVTBL+240 01394000
DC 10X'00' NUMBERS '0' THRU '9' ARE VALID @VA01100 01395000
ORG , HRC012DS 01396490
SPACE 01397000
LTORG NEEDED CONSTANTS ... @VM03232 01398000
SPACE 01399000
* EQUATES: 01400000
Q80 EQU 80 LENGTH OF NTH CHAIN LINK AREA @VM03232 01401000
* IN FIRST CHAIN LINK. 01402000
Q118 EQU 118 DISPLACEMENT OF LAST DATA BLOCK @VM03232 01403000
* IN FIRST CHAIN LINK AREA. 01404000
Q798 EQU 798 DISPLACEMENT OF LAST DATA BLOCK @VM03232 01405000
* IN NTH (NOT 1ST) CHAIN LINK AREA. 01406000
Q800 EQU 800 LENGTH OF CMS PHYSICAL BLOCKS @VM03232 01407000
FF EQU X'FF' @VM03232 01408000
SPACE 01409000
DS 0D - "WRBUF" ENDS HERE - 01410000
EJECT 01411000
FVS 01412000
* 01413000
PLIST EQU RWFSTRG FOUR WORDS 01414000
PADDRX EQU RWFSTRG+16 ONE WORD 01415000
DSKRET EQU RWFSTRG+20 ONE WORD 01416000
SAVECT EQU RWFSTRG+24 ONE WORD 01417000
FALIGN EQU RWFSTRG+28 (CLEARED BY INITIALIZATION) 01418000
ALIGN EQU FALIGN+2 RIGHT-HALF OF 'FALIGN' 01419000
WRBFLAG1 EQU ALIGN+2 FIRST FLAG-BYTE 01420000
WRBFLAG2 EQU WRBFLAG1+1 SECOND FLAG-BYTE 01421000
* 01422000
END$TEMP EQU WRBFLAG2+1 END OF TEMPORARY STORAGE. 01423000
* 01424000
REGSAV4 EQU RWFSTRG+12 SAFE SAVE-AREA NOT USED BY TFINIS OR UPDISK 01425000
EJECT 01426000
NUCON 01427000
DCBD DSORG=(PS) 01427200
CMSCB 01427400
AFT 01428000
FSTB 01429000
ADT 01430000
REGEQU 01431000
END 01432000