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