SVT TITLE 'DMSSVT (CMS) VM/370 - RELEASE 6' 00001000
SPACE 2 00002000
* 00003000
********************************************************************* 00004000
*. 00005000
* 00006000
* MODULE NAME: 00007000
* 00008000
* DMSSVT 00009000
* 00010000
* FUNCTION: 00011000
* 00012000
* DMSSVT PROCESSES OS MACROES. 00013000
* 00014000
* ATTRIBUTES: 00015000
* 00016000
* SERIALLY REUSABLE, TRANSIENT 00017000
* 00018000
* ENTRY POINT: 00019000
* 00020000
* DMSSVT 00021000
* 00022000
* ENTRY CONDITIONS: 00023000
* 00024000
* R12 = A(DMSSVT) 00025000
* R14 = RETURN ADDRESS 00026000
* 00027000
* CALLS TO OTHER ROUTINES: 00028000
* 00029000
* DMSERR,DMSSTT,DMSDBD,DMSBWR,DMSBRD,DMSFNS,DMSERS,DMSFRE, 00030000
* DMSADL,DMSUFD,DMSSBDFR,DMSCRD,DMSCWR,GETMAIN,FREEMAIN, 00031000
* NOTE, TIME, DMSKEY, DMSROS 00032000
* 00033000
* EXTERNAL REFERENCES: 00034000
* 00035000
* OPSECT, IHADCB, FCBSECT, NUCON, PGMSECT 00036000
* 00037000
* 00038000
* SVC SUPPORT ROUTINES AND THEIR OPERATION: 00039000
* 00040000
* 00041000
* XDAP-SVC 0: USED TO WRITE AND READ THE SOURCE CODE SPILL 00042000
* FILE, 00043000
* SYSUT1, DURING LANGUAGE COMPILATION FOR PL/I OPTIMIZER AND 00044000
* ANSI COBOL COMPILERS. THIS ROUTINE CHECKS TO SEE IF THE I/O 00045000
* CODE IS X'0E' (READ) OR X'0D' (WRITE). IF IT IS NEITHER OF 00046000
* THESE, IT PRINTS OUT ERROR MSG 119S. OTHERWISE IT BUILDS A 00047000
* PLIST FROM INFORMATION IN THE CONTROL BLOCKS AND CALLS 00048000
* DMSBRD OR DMSBWR TO READ OR WRITE A BLOCK. IT THEN SETS A 00049000
* RETURN CODE IN THE ECB AND RETURNS CONTROL TO THE USER. 00050000
* 00051000
* TIME-SVC 11: THIS ROUTINE (TIME) LOCATED IN DMSSVT RECEIVES 00052000
* CONTROL 00053000
* WHEN A TIME MACRO INSTRUCTION IS ISSUED. A CALL IS MADE TO 00054000
* THE RPQ SOFTWARE CHRONOLOGICAL TIMER DEVICE, X'OFF'. THE 00055000
* REAL TIME OF DAY AND DATE ARE RETURNED TO THE CALLING 00056000
* PROGRAM IN A SPECIFIED FORM: DECIMAL (DEC) BINARY (BIN), OR 00057000
* TIMER UNITS (TU). 00058000
* 00059000
* SPIE-SVC 14: THIS ROUTINE (SPIE) RECEIVES CONTROL WHEN A 00060000
* SPIE MACRO INSTRUCTION IS ISSUED. WHEN IT GETS CONTROL, 00061000
* SPIE INSERTS THE NEW PROGRAM INTERRUPTION CONTROL AREA 00062000
* (PICA) ADDRESS INTO THE PROGRAM INTERRUPTION ELEMENT (PIE). 00063000
* THE PROGRAM INTERRUPTION ELEMENT RESIDES 00064000
* IN THE PROGRAM INTERRUPTION HANDLER (DMSITP). IT THEN 00065000
* RETURNS THE 00066000
* ADDRESS OF THE OLD PICA TO THE CALLING PROGRAM, SETS THE 00067000
* PROGRAM MASK IN THE CALLING PROGRAM'S PSW, AND RETURNS TO 00068000
* THE CALLING PROGRAM. 00069000
* 00070000
* RESTORE-SVC 17: RESTORE IS A NOP LOCATED IN DMSSVT. 00071000
* 00072000
* BLDL/FIND-SVC 18: SEE BLDL AND FIND UNDER DESCRIPTION OF 00073000
* BPAM ROUTINES. 00074000
* 00075000
* STOW-SVC 21: SEE STOW UNDER DESCRIPTION OF BPAM ROUTINES. 00076000
* 00077000
* DEVTYPE-SVC 24: THIS ROUTINE (DEVTYPE), LOCATED IN DMSSVT, 00078000
* RECEIVES CONTROL 00079000
* WHEN A DEVTYPE MACRO IS ISSUED. UPON ENTRY, DEVTYPE MOVES 00080000
* DEVICE CHARACTERISTIC INFORMATION FOR THE REQUESTED DATA SET 00081000
* INTO A USER SPECIFIED AREA, AND THEN RETURNS CONTROL TO THE 00082000
* USER. 00083000
* 00084000
* 00085000
* TRKBAL-SVC 25: TRKBAL IS A NOP LOCATED IN DMSSVT. 00086000
* 00087000
* WTO, WTOR--SVC 35: THIS ROUTINE (WTO), LOCATED IN DMSSVT, 00088000
* RECEIVES CONTROL 00089000
* WHEN EITHER A WTO OR A WTOR MACRO INSTRUCTION IS ISSUED. 00090000
* FOR A WTO, IT 00091000
* CONSTRUCTS A CALLING SEQUENCE TO THE DMSCWR FUNCTION PROGRAM 00092000
* TO TYPE THE 00093000
* MESSAGE AT THE TERMINAL. (THE ADDRESS OF THE MESSAGE AND 00094000
* ITS LENGTH ARE PROVIDED IN THE PARAMETER LIST THAT RESULTS 00095000
* FROM THE EXPANSION OF THE WTO 00096000
* MACRO INSTRUCTION.) IT THEN CALLS THE DMSCWT FUNCTION 00097000
* PROGRAM TO WAIT UNTIL 00098000
* ALL TERMINAL I/O ACTIVITY HAS CEASED. NEXT, IT CALLS THE 00099000
* DMSCWR 00100000
* FUNCTION PROGRAM TO TYPE THE MESSAGE AT THE TERMINAL AND 00101000
* RETURNS TO THE CALLING PROGRAM. 00102000
* 00103000
* FOR A WTOR MACRO INSTRUCTION, THIS ROUTINE PROCEEDS AS 00104000
* DESCRIBED FOR WTO; HOWEVER, AFTER IT HAS TYPED THE MESSAGE 00105000
* AT THE TERMINAL IT CALLS THE 00106000
* DMSCRD 00107000
* FUNCTION PROGRAM TO READ THE USER'S REPLY FROM THE TERMINAL. 00108000
* WHEN THE USER REPLIES WITH A MESSAGE, IT MOVES THE MESSAGE 00109000
* TO THE BUFFER SPECIFIED IN THE WTOR PARAMETER LIST, SETS THE 00110000
* COMPLETION BIT IN THE ECB, AND RETURNS TO THE CALLING 00111000
* PROGRAM. 00112000
* 00113000
* EXTRACT-SVC 40: THIS ROUTINE (EXTRACT), LOCATED IN DMSSVT 00114000
* RECEIVES CONTROL 00115000
* WHEN AN EXTRACT MACRO IS ISSUED. UPON ENTRY, EXTRACT CLEARS 00116000
* THE USER PROVIDED ANSWER AREA AND RETURNS CONTROL TO THE 00117000
* USER WITH A RETURN CODE OF 4 IN REGISTER 15. 00118000
* 00119000
* IDENTIFY - SVC 41 ADD ENTRY NAME AND ADDRESS TO 00120000
* LOADER TABLE 00121000
* 00122000
* CHAP-SVC 44: CHAP IS A NOP LOCATED IN DMSSVT. 00123000
* 00124000
* TTIMER-SVC46: CHECKS TO INSURE THAT THE VALUE IN THE TIMER 00125000
* (HEX LOCATION 50) WAS SET BY AN STIMER MACRO. IF IT WAS, 00126000
* THE VALUE IS CONVERTED TO AN UNSIGNED 32 BIT BINARY NUMBER 00127000
* SPECIFYING 26 MICRO-SECOND UNITS AND IS RETURNED IN REGISTER 00128000
* 0. IF THE TIMER WAS NOT SET BY AN STIMER MACRO A ZERO IS 00129000
* RETURNED IN REGISTER 0. AFTER SETTING REGISTER 0, THE CANCEL 00130000
* OPTION IS CHECKED. IF IT IS NOT SPECIFIED, CONTROL IS 00131000
* RETURNED TO THE USER. IF IT IS SPECIFIED, THE TIMER VALUE 00132000
* AND EXIT ROUTINE SET BY THE STIMER MACRO ARE CANCELLED AND 00133000
* CONTROL IS RETURNED TO THE USER. 00134000
* 00135000
* STIMER-SVC47: CHECKS TO SEE IF THE WAIT OPTION IS 00136000
* SPECIFIED. IF SO, CONTROL IS RETURNED TO THE USER. IF NOT, 00137000
* THE SPECIFIED TIMER INTERVAL IS CONVERTED TO 13 MICRO-SECOND 00138000
* UNITS AND STORED IN THE TIMER (HEX LOCATION 50). IF A TIMER 00139000
* COMPLETION EXIT ROUTINE IS SPECIFIED, IT IS SCHEDULED TO BE 00140000
* GIVEN CONTROL AFTER COMPLETION OF THE SPECIFIED TIME 00141000
* INTERVAL. IF NOT, NO INDICATION OF THE COMPLETION OF THE 00142000
* TIME INTERVAL IS SCHEDULED. AFTER CHECKING AND HANDLING ANY 00143000
* SPECIFIED EXIT ROUTINE ADDRESS, CONTROL IS RETURNED TO THE 00144000
* USER. THE MAXIMUM TIME INTERVAL ALLOWED IS RESTRICTED TO @VA15155 00145000
* X'7FFFFF00' TIMER UNITS (X'00555554' IN BINARY, OR @VA15155 00145200
* 15 HOURS, 32 MINUTES, AND 4 SECONDS IF IN DECIMAL). IF @VA15155 00145400
* THE TIME INTERVAL IS GREATER THAN THE MAXIMUM, IT WILL BE @VA15155 00145600
* SET TO THE MAXIMUM. @VA15155 00145800
* 00146000
* DEQ-SVC 48: DEQ IS A NOP LOCATED IN DMSSVT. 00147000
* 00148000
* SNAP-SVC 51: CONTROL IS PASSED TO SNAP IN DMSSVT WHEN A 00149000
* SNAP MACRO IS ISSUED. FIRST A CHECK IS MADE TO SEE IF THE @VA04475 00150000
* DCB SPECIFIED IN THE PLIST IS OPEN. IF NOT, CONTROL IS @VA04475 00151000
* RETURNED TO THE CALLER WITH A RETURN CODE OF 4. IF THE DCB @VA04475 00152000
* IS OPENED, THE FCB IS CHECKED FOR A DEVICE TYPE OF DUMMY. @VA04475 00153000
* IF DUMMY, THE EXECUTION OF THE DUMP FUNCTION IS IGNORED. @VA04475 00154000
* OTHERWISE, SNAP FILLS IN A PLIST WITH THE STARTING AND ENDING@VA04475 00155000
* ADDRESS AND CALLS DMSDBD. DMSDBD DUMPS THE SPECIFIED CORE 00156000
* ALONG WITH THE REGISTERS AND LOW CORE TO THE PRINTER. 00157000
* CONTROL IS THEN RETURNED TO SNAP AND SNAP CHECKS TO SEE IF 00158000
* ANY MORE ADDRESSES ARE SPECIFIED. IT CONTINUES CALLING 00159000
* DMSDBD UNTIL ALL THE SPECIFIED ADDRESSES HAVE BEEN DUMPED 00160000
* TO THE PRINTER. CONTROL IS THEN RETURNED TO THE USER. 00161000
* SINCE THE DUMP ALWAYS GOES TO THE PRINTER, THE DCB 00162000
* SPECIFICATION CAN BE ANY DUMMY ADDRESS. 00163000
* 00164000
* ENQ-SVC 56: ENQ IS A NOP LOCATED IN DMSSVT. 00165000
* 00166000
* FREEDBUF-SVC 57: THIS ROUTINE (FREEDBUF) LOCATED IN DMSSVT 00167000
* RECEIVES 00168000
* CONTROL WHEN A FREEDBUF MACRO IS ISSUED. UPON ENTRY, 00169000
* FREEDBUF SETS UP 00170000
* THE CORRECT DSECT REGISTERS AND CALLS THE FREEDBUF ROUTINE 00171000
* IN DMSSBD. 00172000
* THIS ROUTINE RETURNS THE DYNAMICALLY OBTAINED BUFFER (BDAM) 00173000
* SPECIFIED IN THE DECB TO THE DCB BUFFER CONTROL BLOCK CHAIN. 00174000
* CONTROL IS THEN 00175000
* RETURNED TO THE DMSSVT ROUTINE WHICH RETURNS CONTROL TO THE 00176000
* USER. 00177000
* 00178000
* STAE-SVC 60: THIS ROUTINE (STAE) LOCATED IN DMSSVT RECEIVES 00179000
* CONTROL WHEN 00180000
* A STAE MACRO IS ISSUED. UPON ENTRY, STAE CREATES, OVERLAYS 00181000
* OR CANCELS A STAE CONTROL BLOCK (SCB) AS REQUESTED. CONTROL 00182000
* IS THEN RETURNED TO THE USER WITH ONE OF THE FOLLOWING 00183000
* RETURN CODES IN REGISTER 15. 00184000
* 00185000
* CODE MEANING 00186000
* 00187000
* 00 AN SCB IS SUCCESSFULLY CREATED, 00188000
* OVERLAID OR CANCELLED. 00189000
* 00190000
* 08 THE USER IS ATTEMPTING TO CANCEL OR 00191000
* OVERLAY A NON-EXISTENT SCB. 00192000
* 00193000
* 00194000
* 00195000
* FORMAT OF SCB 00196000
* 00197000
* 0 __________________________ 00198000
* |0 OR POINTER TO NEXT SCB| 00199000
* 4 |________________________| 00200000
* |EXIT ADDRESS | 00201000
* 8 |________________________| 00202000
* |PARAMETER LIST ADDRESS | 00203000
* 12 |________________________| 00204000
* _ 00205000
* 00206000
* DETACH-SVC 62: DETACH IS A NOP LOCATED IN DMSSVT. 00207000
* 00208000
* CHKPT-SVC 63: CHKPT IS A NOP LOCATED IN DMSSVT. 00209000
* 00210000
* RDJFCB-SVC 64: THIS ROUTINE (RDJFCB) RECEIVES CONTROL WHEN 00211000
* A RDJFCB MACRO INSTRUCTION IS ISSUED. WHEN IT GETS CONTROL, 00212000
* RDJFCB OBTAINS THE ADDRESS OF THE JFCB FROM THE DCBEXLST 00213000
* FIELD IN THE DCB AND SETS THE JFCB TO ZERO. IT THEN READS 00214000
* THE SIMULATED JFCB LOCATED IN CMSCB THAT WAS PRODUCED BY 00215000
* ISSUING A FILEDEF INTO THE CLOSED AREA. RDJFCB CALLS THE 00216000
* STATE FUNCTION PROGRAM TO DETERMINE IF THE ASSOCIATED FILE 00217000
* EXISTS. IF IT DOES, RDJFCB RETURNS TO THE CALLING PROGRAM. 00218000
* IF THE FILE DOES NOT EXIST, RDJFCB SETS A SWITCH IN THE DCB 00219000
* TO INDICATE THIS AND THEN RETURNS TO THE CALLING PROGRAM. 00220000
* FOR UNOPENED DCB'S, RDJFCB SEARCHES THE DOSCB'S THAT OS USERS 00221000
* PRODUCED BY DLBL COMMANDS FOR VSAM DATA SETS. IF A MATCHING 00222000
* DDNAME IS FOUND, ONLY THE JFCDSORG 'VSAM' BIT (BIT 4 OF BYTE 00223000
* 2) IS TURNED 'ON' AND NO STATE IS ISSUED BEFORE RETURN. THIS BIT 00224000
* IS CHECKED BY THE PL/1 OPEN ROUTINE TO DETECT VSAM DATA SETS. 00225000
* RDJFCB IS LOCATED 00226000
* IN DMSSVT. 00227000
* 00228000
* NOTE: THE SWITCH SET BY THE RDJFCB IS TESTED BY THE FORTRAN 00229000
* OBJECT-TIME DIRECT-ACCESS HANDLER (DIOCS) TO DETERMINE 00230000
* WHETHER OR NOT A REFERENCED DISK FILE EXISTS. IF IT DOES 00231000
* NOT, DIOCS WILL INITIALIZE THE DIRECT ACCESS FILE. 00232000
* 00233000
* SYNAD-SVC 68: LOCATED IN DMSSVT, SYNAD ATTEMPTS TO SIMULATE 00234000
* THE FUNCTIONS 00235000
* SYNADAF AND SYNADRLS. SYNADAF EXPANSION INCLUDES AN SVC 68 00236000
* AND A HIGH-ORDER BYTE IN REGISTER 15 DENOTING AN ACCESS 00237000
* METHOD. SYNAD WILL PREPARE AN ERROR MESSAGE LINE AND SWAP 00238000
* SAVE AREAS AND REGISTER 13 POINTERS. THE MESSAGE BUFFER IS 00239000
* 120 BYTES: BYTES 1-43,84-119 BLANK; BYTES 44-83 'DMSSVT120S 00240000
* INPUT/OUTPUT ERROR NN ON DSNAME', WHERE NN IS THE CMS 00241000
* I/O ERROR CODE. 00242000
* 00243000
* SYNADRLS EXPANSION INCLUDES SVC 68 AND A HIGH ORDER BYTE OF 00244000
* X'FF' IN REGISTER 15. THE SAVE AREA WILL BE RESET, AND 00245000
* THE MESSAGE BUFFER WILL BE RETURNED TO FREE STORAGE. 00246000
* 00247000
* BACKSPACE-SVC 69: 00248000
* CONTROL IS PASSED TO BACKSPACE IN DMSSVT WHEN A BACKSPACE 00249000
* MACRO IS ISSUED. UPON ENTRY, BACKSPACE CHECKS FOR THE FCB OS 00250000
* BIT. IF IT IS ON, DMSROS IS CALLED TO BACKSPACE THE TTR AND 00251000
* CONTROL IS RETURNED TO THE CALLER. OTHERWISE 00252000
* BACKSPACE DECREMENTS THE READ WRITE POINTER BY ONE AND 00253000
* RETURNS CONTROL TO THE USER. NO PHYSICAL TAPE OR DISK 00254000
* ADJUSTMENTS ARE MADE UNTIL THE NEXT READ OR WRITE MACRO IS 00255000
* ISSUED. 00256000
* 00257000
* STAX-SVC 96: LOCATED IN DMSSVT, STAX WILL GET AND CHAIN A 00258000
* TAXE CONTROL BLOCK FOR EACH STAX SVC ISSUED WITH AN EXIT 00259000
* ROUTINE ADDRESS SPECIFIED. THE CHAIN WILL BE ANCHORED BY 00260000
* TAXEADDR IN DMSNUC. IF NO EXIT ADDRESS IS SPECIFIED THE MOST 00261000
* RECENTLY ADDED TAXE IS CLEARED FROM THE CHAIN. IF AN ERROR 00262000
* OCCURS DURING STAX SVC PROCESSING, A RETURN CODE OF EIGHT IS 00263000
* PLACED IN REGISTER 15. THE ONLY OPTION OF STAX WHICH MAY BE 00264000
* SPECIFIED IS 'EXIT ADDRESS'. ANY OTHER OPTIONS WILL CAUSE 00265000
* RETURN CODE EIGHT. 00266000
* 00267000
* 00268000
* 00269000
******************************************************************** 00270000
* *KEYSAV (BDAM OR BSAM) 00271000
* 00272000
* FUNCTION: 00273000
* 00274000
* TO BUILD A KEYS FILE WHEN A DATA FILE USING KEYS IS 00275000
* OPENED AND TO SAVE THE KEYS AT THE END OF THE DATA 00276000
* FILE WHEN IT IS CLOSED. 00277000
* 00278000
* ENTRY CONDITION: 00279000
* 00280000
* SVC 203 FOLLOWED BY HALFWORD OF -3 AND R0=0. 00281000
* 00282000
* EXIT CONDITIONS: 00283000
* 00284000
* CONTROL IS RETURNED TO CALLER WITH A ZERO IN REGISTER 00285000
* 15 IF EXECUTION WAS SUCCESSFUL AND A NONZERO, IF NOT. 00286000
* 00287000
* CALLS TO OTHER ROUTINES: 00288000
* 00289000
* DMSFNS,DMSFRE,DMSBWR,DMSBRD, DMSERS, DMSSTT,DMSUFD,DMSADL 00290000
* 00291000
* 00292000
* TABLES/WORKAREAS: 00293000
* 00294000
* KEYTABL DSECT USED TO READ, WRITE AND SEARCH FOR 00295000
* KEYS. 00296000
* 00297000
* REGISTER USAGE: 00298000
* 00299000
* R0, R1, R3, R4, R6, R7, R9, R11, R14, R15 - WORK 00300000
* R2 - DCB 00301000
* R5 - KEYTABL DSECT 00302000
* R8 - FCB 00303000
* R10 - OPSECT DSECT 00304000
* R12 - BASE 00305000
* 00306000
* OPERATION: 00307000
* 00308000
* KEYSAV GETS CONTROL FROM EITHER DMSSBD OR THE CLOSE 00309000
* ROUTINE, DMSSOP. 00310000
* 00311000
* . IF KEYSAV GETS CONTROL FROM DMSSBD, A KEY TABLE 00312000
* AND A PLIST FOR 00313000
* ACCESSING THE KEY TABLE IS BUILT IN CORE. NEXT, 00314000
* THE XTENT PARAMETER IS READ FROM THE LAST ITEM IN 00315000
* THE DATA FILE AND IF THE FILE FORMAT IS FIXED OR IF 00316000
* THE FILE IS NOT BEING UPDATED, CONTROL IS RETURNED 00317000
* TO DMSSBD. OTHERWISE 00318000
* TWO NEW FILES WITH THE SAME FILETYPE AS THE DATA 00319000
* FILE, BUT WITH FILENAMES OF $KEYTEMP AND $KEYSAVE 00320000
* ARE CREATED, USING THE KEYS AT THE END OF THE DATA 00321000
* FILE. THE $KEYTEMP FILE WILL BE USED FOR UPDATES 00322000
* TO THE KEYS, AND THE $KEYSAVE FILE WILL BE USED IN 00323000
* CASE OF A SYSTEM CRASH OR RE-IPL. IF A $KEYSAVE 00324000
* FILE ALREADY EXISTS FOR A DATA FILE WHEN IT IS 00325000
* OPENED, THEN THE KEYS FROM THAT FILE RATHER THAN 00326000
* THE KEYS FROM THE END OF THE DATA FILE, WILL BE 00327000
* USED TO CREATE $KEYTEMP. AFTER THE TWO FILES ARE 00328000
* CREATED, CONTROL 00329000
* IS RETURNED TO DMSSBD. 00330000
* 00331000
* . IF KEYSAV GETS CONTROL FROM DMSSOP, THEN KEYS FROM 00332000
* THE LAST KEY TABLE REFERRENCED ARE SAVED. IF THE FILE 00333000
* FORMAT IS FIXED OR IF THE FILE WAS NOT UPDATED, 00334000
* THE CORE FOR THE KEY TABLE AND KEY PLIST IS FREED 00335000
* AND CONTROL IS RETURNED TO DMSSBD. OTHERWISE, THE 00336000
* $KEYTEMP FILE ARE READ IN AND WRITTEN AT THE END 00337000
* OF THE DATA FILE. WHEN THIS IS COMPLETE, THE 00338000
* $KEYTEMP AND $KEYSAVE FILES ARE ERASED, THE CORE 00339000
* FOR THE KEY TABLE AND ITS PLIST IS FREED UP, AND 00340000
* CONTROL 00341000
* IS RETURNED TO DMSSOP. 00342000
* 00343000
* 00344000
********************************************************************* 00345000
* *BPAM ROUTINES: 00346000
* 00347000
* THE CMS BPAM MACRO ROUTINES ARE USED TO ACCESS AND 00348000
* BUILD PARTITIONED DATA SETS. THESE DATA SETS ARE 00349000
* DIVIDED INTO SEQUENTIALLY ORGANIZED MEMBERS, EACH OF 00350000
* WHICH HAS A UNIQUE NAME STORED IN A DIRECTORY. THE 00351000
* CMS BPAM MACRO ROUTINES SUPPORT ALL THE OS BPAM MACRO 00352000
* FUNCTIONS EXCEPT THE OS FACILITY OF ADDING USER DATA 00353000
* TO THE DIRECTORY ENTRIES. ANY CMS MACLIB CAN BE ACCESSED 00354000
* BY OS BPAM MACROES BUT ONLY MACLIBS CREATED ON CMS 1.0 00355000
* OR CONVERTED TO CMS 1.0 BY A MACLIB COMMAND WITH THE 00356000
* COMPACT OPTION CAN BE UPDATED BY OS BPAM MACROES. 00357000
* 00358000
* THE FUNCTIONS AND OPERATIONS OF THE CMS BPAM MACRO 00359000
* PROGRAMS ARE GIVEN BELOW. 00360000
* 00361000
******************************************************************** 00362000
* *FIND (BPAM) 00363000
* 00364000
* FUNCTION: 00365000
* 00366000
* WHEN CALLED BY THE USER: 00367000
* TO CAUSE THE CONTROL PROGRAM TO USE THE ADDRESS OF 00368000
* THE FIRST BLOCK OF A SPECIFIED PARTITIONED DATA 00369000
* SET MEMBER AS THE STARTING POINT FOR THE NEXT READ 00370000
* MACRO INSTRUCTION FOR THE SAME DATA SET. 00371000
* 00372000
* WHEN CALLED BY STOW OR BLDL: 00373000
* TO FIND THE DIRECTORY ENTRY FOR A MEMBER AND PASS 00374000
* BACK THE IN-CORE ADDRESS OF THE ENTRY. 00375000
* 00376000
* WHEN CALLED BY DICTSAVE: 00377000
* TO READ IN THE DIRECTORY 00378000
* 00379000
* ENTRY CONDTIONS: 00380000
* 00381000
* FIND ROUTINE IN DMSSVT CAN BE CALLED BY OS FIND MACRO OR BY 00382000
* DMSSVT ROUTINES BLDL, PDSSAVE AND STOW. 00383000
* 00384000
* EXIT CONDITIONS: 00385000
* 00386000
* WHEN CONTROL IS RETURNED TO THE PROBLEM PROGRAM OR 00387000
* CALLING ROUTINE, THE RETURN CODE IN REGISTER 15 IS AS 00388000
* FOLLOWS: 00389000
* 00390000
* NAME PROVIDED RELATIVE ADDRESS PROVIDED 00391000
* ------------- ------------------------- 00392000
* 00393000
* 00-SUCCESSFUL EXECUTION 00-AT ALL TIMES. 00394000
* 04-NAME NOT FOUND IF THE RELATIVE ADDRESS IS 00395000
* 08-PERMANENT I/O BAD IT IS REFLECTED IN 00396000
* ERROR READING THE NEXT READ. 00397000
* IN DIRECTORY 00398000
* 00399000
* THE FOLLOWING ERROR MESSAGE IS PRINTED OUT IF THE DATA 00400000
* SET SPECIFIED IS NOT A VALID MACLIB OR IF THE USER 00401000
* IS TRYING TO UPDATE A MACLIB THAT WAS NOT CREATED ON 00402000
* OR COVERTED TO 1.0. 00403000
* DMSSVT033E FILE 'FILEID' IS NOT A LIBRARY 00404000
* 00405000
* 00406000
* CALLS TO OTHER ROUTINES: 00407000
* 00408000
* DMSBRD, DMSFRE, DMSFNS, DMSROS 00409000
* 00410000
* 00411000
* TABLES/WORKAREAS: 00412000
* 00413000
* TABLES OF PDS ENTRIES ARE KEPT IN CORE. THE SIZE OF 00414000
* THE TABLE IN BYTES IS 24+(12XNO. OF MEMBER AND ALIAS 00415000
* NAMES IN PDS). 00416000
* 00417000
* REGISTER USAGE: 00418000
* 00419000
* R2 - DCB 00420000
* R8 - FCB 00421000
* R9 - MEMBER NAME 00422000
* R11 - PDSSECT DSECT 00423000
* R12 - BASE 00424000
* R13 - SAVE 00425000
* R0,R1,R3 - R7,R10,R14,R15 - WORK 00426000
* 00427000
* 00428000
* OPERATION: 00429000
* 00430000
* UPON ENTRY TO FIND, A CHECK IS MADE OF THE FCB OS BIT. 00431000
* IF IT IS ON, THE OS FST ADDRESS IS LIFTED FROM THE CMSCB 00432000
* OR, IF THE CONCAT BIT IS ON, FROM THE GLOBAL MACLIB 00433000
* LIST. DMSROS IS THEN CALLED TO FIND THE MEMBER NAME AND 00434000
* TTR. IF THE FCB OS BIT IS NOT ON, FCBDSNAM AND THE ADDRESS 00435000
* OF THE 1ST MACRO LIBRARY IS LIFTED FROM THE CMSCB 00436000
* OR, IF THE CONCAT BIT IS ON, FROM THE GLOBAL MACLIB LIST. 00437000
* NEXT A CHECK IS MADE OF THE 00438000
* IN CORE DIRECTORY ADDRESS. IF IT IS ZERO, THE 00439000
* DIRECTORY HEADER RECORD 00440000
* IS READ INTO A SAVE AREA, DMSFRE IS CALLED TO GET 00441000
* CORE FOR THE DIRECTORY AND ITS CONTROL WORDS, 00442000
* THE DIRECTORY IS READ IN, AND THE POINTER TO THE 00443000
* IN-CORE DIRECTORY IS STORED IN FCBPDS. IF, WHEN THE 00444000
* DICTIONARY HEADER RECORD IS READ IN, THE EIGHTH 00445000
* CHARACTER IN IT IS A '$', A ONE IS PUT IN THE CHANGE 00446000
* BYTE AND THE PDS DIRECTORY IS READ FROM A FILE WITH 00447000
* THE SAME FILETYPE AND A FILENAME OF $PDSTEMP. ONCE 00448000
* IN, THE DIRECTORY IS KEPT IN CORE UNTIL A BLDL OR A 00449000
* CLOSE IS ISSUED FOR THE DATA SET. IF THE 2ND 00450000
* THREE BYTES OF THE HEADER ARE NOT 'LIB' OR IF FIND 00451000
* WAS CALLED BY PDSSAVE AND THE 1ST THREE BYTES ARE 00452000
* NOT 'DMS', ERROR MESSAGE DMSSVT033E IS PRINTED OUT AND 00453000
* CONTROL IS PASSED BACK TO THE USER WITH AN I/O ERROR 00454000
* CODE. AFTER FIND HAS 00455000
* THE POINTER TO THE IN-CORE DIRECTORY, IT BEGINS 00456000
* SEARCHING FOR A MATCHING MEMBER NAME OR, IF THE 00457000
* FCBMVPDS OPTION IS SPECIFIED, A HIGHER MEMBER NAME. 00458000
* IF THE CORRECT MEMBER 00459000
* NAME IS NOT FOUND, A CHECK IS MADE TO SEE IF ANY 00460000
* ADDITIONAL DIRECTORY BLOCKS HAVE BEEN ADDED BY STOW. 00461000
* IF SO, THEY TOO ARE SEARCHED. 00462000
* 00463000
* AFTER THE CMS DIRECTORY OR DMSROS SEARCH IS THROUGH AND THE 00464000
* MEMBER IS EITHER FOUND OR NOT FOUND, A CHECK IS MADE TO SEE 00465000
* WHAT PROGRAM REQUESTED THE SEARCH. IF IT WAS 00466000
* PDSSAVE, BLDL OR STOW, CONTROL IS RETURNED TO THOSE 00467000
* ROUTINES. IF IT WAS A SUCCESSFUL USER REQUEST, THE 00468000
* ITEM NUMBER OF THE MEMBER IS MOVED FROM THE DIRECTORY 00469000
* INTO FCBITEM AND DCBRELAD, AND CONTROL IS RETURNED TO 00470000
* THE USER WITH A ZERO IN REGISTER 15. IF IT WAS AN 00471000
* UNSUCCESSFUL USER REQUEST AND THE CONCATIONATION 00472000
* BIT IS NOT ON, CONTROL IS RETURNED TO THE USER 00473000
* WITH A FOUR IN REGISTER 15. IF THE CONCATIONATION 00474000
* BIT IS ON, THE NEXT MACLIB NAME IN THE MACLIB 00475000
* LIST IS USED TO GET THE OS FST OR CMS PDS ADDRESS AND THE 00476000
* SEARCH FOR THE 00477000
* MEMBER STARTS AGAIN. IF THE NEXT FCB POINTER IN THE 00478000
* MACLIB FCB LIST IS ZERO, CONTROL IS RETURNED TO THE 00479000
* USER WITH A FOUR IN REGISTER 15. 00480000
* 00481000
* 00482000
* 00483000
* 00484000
* * . THERE ARE TWO FIND ROUTINES. ONE IS PART OF DMSSCT 00485000
* AND IS USED ONLY WHEN A RELATIVE ADDRESS LIST 00486000
* IS PROVIDED. THE OTHER IS PART OF DMSSVT. 00487000
* 00488000
* . THE DCBDSORG OPTION IN THE DCB MUST ALWAYS BE PO WHEN 00489000
* REFERENCING A BPAM DATA SET. 00490000
* 00491000
********************************************************************* 00492000
* *BLDL (BPAM) 00493000
* 00494000
* FUNCTION: 00495000
* 00496000
* TO FILL IN A USERS LIST IN MAIN STORAGE WITH THE 00497000
* RELATIVE TRACK ADDRESSES (ITEM NUMBERS) FOR REQUESTED 00498000
* MEMBERS. 00499000
* 00500000
* ENTRY CONDITIONS: 00501000
* 00502000
* BLDL ROUTINE IN DMSSVT 00503000
* MUST BE CALLED BY 00504000
* OS BLDL MACRO. 00505000
* 00506000
* EXIT CONDITIONS: 00507000
* 00508000
* WHEN CONTROL IS RETURNED TO THE PROBLEM PROGRAM, THE 00509000
* RETURN CODE IN REGISTER 15 IS AS FOLLOWS: 00510000
* 00511000
* CODE (HEXIDECIMAL) 00512000
* 00 SUCCESSFUL COMPLETION 00513000
* 00514000
* 04 LIST COULD NOT BE FILLED. 00515000
* TTR FIELD OF MEMBER 00516000
* NOT FOUND IS FILLED IN 00517000
* AS ZERO. 00518000
* 00519000
* 08 PERMANENT INPUT OR OUTPUT 00520000
* ERROR WHILE READING IN DIRECTORY. 00521000
* 00522000
* CALLS TO OTHER ROUTINES: 00523000
* 00524000
* FIND, PDSSAVE (BOTH ROUTINES IN DMSSVT) 00525000
* 00526000
* TABLES / WORKAREAS: 00527000
* 00528000
* NONE 00529000
* 00530000
* REGISTER USAGE: 00531000
* 00532000
* R2 - DCB 00533000
* R8 - FCB 00534000
* R9 - MEMBER NAME 00535000
* R11 - PDSSECT DSECT 00536000
* R12 - BASE 00537000
* R13 - SAVE 00538000
* R0,R1,R3-R7,R10,R14,R15 - WORK 00539000
* 00540000
* 00541000
* OPERATION: 00542000
* 00543000
* UPON ENTRY TO BLDL, A CHECK IS MADE TO DETERMINE 00544000
* IF THE JOBLIB OR LINKLIB OPTION IS SPECIFIED. IF 00545000
* SO, CONTROL IS RETURNED TO THE USER WITH A ZERO IN 00546000
* REGISTER 15. IF NOT, FIND IS CALLED TO SEARCH THE 00547000
* DIRECTORY 00548000
* FOR A MATCH OF THE FIRST MEMBER NAME IN THE USER'S 00549000
* LIST. IF A MATCH IS NOT FOUND, THE TTR FIELD IS 00550000
* FILLED IN WITH ZEROES, FIND IS CALLED TO SEARCH FOR 00551000
* THE NEXT MEMBER AND A FOUR IS PUT IN REGISTER 15. IF 00552000
* IT IS FOUND, BLDL FILLS IN THE USERS LIST WITH THE 00553000
* MEMBER'S ITEM NUMBER AND CONTINUES CALLING FIND UNTIL 00554000
* THE WHOLE BLDL LIST HAS BEEN FILLED IN. AFTER THE 00555000
* LIST IS FULL, THE CHANGE BYTE IS CHECKED. IF IT IS 00556000
* NOT SET, CONTROL IS RETURNED TO THE USER. OTHERWISE PDSSAVE IS 00557000
* CALLED TO FREE THE IN-CORE DIRECTORY AND CONTROL IS 00558000
* RETURNED TO THE USER. THE FORMAT OF THE USER'S LIST 00559000
* AFTER CALLING BLDL FOLLOWS: 00560000
* 00561000
* 00562000
* FF LL NAME TTR KZC DATA 00563000
* 00564000
* 00565000
* TTR THE ITEM NUMBER WILL ALWAYS BE RIGHT JUSTIFIED IN 00566000
* THESE THREE BYTES. 00567000
* KZ THESE TWO BYTES WILL ALWAYS BE ZERO. 00568000
* C THE HIGH ORDER BIT IN THIS BYTE WILL BE ON 00569000
* IF THE NAME IS AN ALIAS AND THE MACLIB IS A 00570000
* 1.0 MACLIB. THE DATA FIELD WILL ALWAYS BE ZERO 00571000
* IF THE DCB REFERS TO A CMS DISK. IF THE DCB 00572000
* REFERS TO AN OS DISK, THE C BYTE AND THE DATA 00573000
* FIELD WILL BE FILLED IN FROM THE OS DATA SET. 00574000
* 00575000
* 00576000
********************************************************************* 00577000
* *STOW (BPAM) 00578000
* 00579000
* FUNCTION: 00580000
* 00581000
* TO ADD, CHANGE, REPLACE OR DELETE AN ENTRY IN A 00582000
* PARTITIONED DATA SET (PDS) DIRECTORY. 00583000
* 00584000
* ENTRY CONDITIONS: 00585000
* 00586000
* OS STOW MACRO 00587000
* 00588000
* EXIT CONDITIONS: 00589000
* 00590000
* WHEN CONTROL IS RETURNED TO THE PROBLEM PROGRAM,THE 00591000
* RETURN CODE IN REGISTER 15 IS AS FOLLOWS: 00592000
* 00593000
* CODE (HEXADECIMAL) 00594000
* 00 UPDATE SUCCESSFUL 00595000
* 04 NAME ALREADY IN DIRECTORY 00596000
* 08 NAME COULD NOT BE FOUND 00597000
* 0C DIRECTORY OR FILE FULL 00598000
* 10 A PERMANENT INPUT OR OUTPUT 00599000
* ERROR WAS DETECTED ATTEMPTING 00600000
* TO UPDATE THE DIRECTORY. 00601000
* 00602000
* CALLS TO OTHER ROUTINES: 00603000
* 00604000
* FINDD IN DMSSVT,NOTE IN DMSSCT, DMSFRE,DMSBWR 00605000
* 00606000
* TABLES/WORKAREAS: 00607000
* 00608000
* THE IN-CORE PDS DIRECTORY IS UPDATED BY STOW. 00609000
* 00610000
* REGISTER USAGE: 00611000
* 00612000
* R0,R1,R3,R4,R6,R7,R11,R14,R15 - WORK 00613000
* R2 - DCB 00614000
* R5-PDSSECT DSECT 00615000
* R8-FCB 00616000
* R9-MEMBER NAME 00617000
* R10-OPSECT BASE 00618000
* R12-BASE 00619000
* R13-SAVE AREA 00620000
* 00621000
* . TWO FILES 00622000
* WITH THE SAME FILETYPE CANNOT BE UPDATED AT THE SAME 00623000
* TIME. 00624000
* 00625000
* OPERATION: 00626000
* 00627000
* . IF THE DELETE OPTION IS SPECIFIED, FIND IS 00628000
* CALLED TO SEARCH THE DIRECTORY FOR A MATCH TO THE 00629000
* MEMBER IN THE USERS LIST. IF THE SEARCH IS 00630000
* SUCCESSFUL, THE DIRECTORY ENTRY IS ZEROED OUT, A ONE 00631000
* IS PUT IN THE CHANGE BYTE AND CONTROL IS RETURNED TO 00632000
* THE USER WITH A ZERO IN REGISTER 15. IF THE SEARCH 00633000
* IS NOT SUCCESSFUL, CONTROL IS RETURNED TO THE USER 00634000
* WITH AN EIGHT IN REGISTER 15. 00635000
* 00636000
* .IF THE CHANGE OPTION IS SPECIFIED, FIND IS CALLED 00637000
* TO SEARCH THE DIRECTORY FOR A MATCH TO THE MEMBER IN 00638000
* THE USERS LIST. IF THE SEARCH IS NOT SUCCESSFUL, 00639000
* CONTROL IS RETURNED TO THE USER WITH AN EIGHT IN 00640000
* REGISTER 15. IF THE SEARCH IS SUCCESSFUL, FIND IS 00641000
* CALLED AGAIN TO SEARCH FOR THE NEW MEMBER NAME IN THE 00642000
* DIRECTORY. IF THIS SECOND SEARCH IS SUCCESSFUL 00643000
* CONTROL IS RETURNED TO THE USER WITH A FOUR IN 00644000
* REGISTER 15. IF THIS SECOND SEARCH IS NOT SUCCESSFUL 00645000
* THE DIRECTORY IS CHANGED, A ONE IS PUT IN THE CHANGE 00646000
* BYTE AND CONTROL IS RETURNED TO THE USER WITH A ZERO 00647000
* IN REGISTER 15. 00648000
* 00649000
* . IF THE REPLACE OR ADD OPTION IS SPECIFIED, FIND IS 00650000
* CALLED TO SEARCH THE DIRECTORY FOR A MATCH TO THE 00651000
* MEMBER IN THE USERLIST. IF A MATCH IS FOUND AND ADD 00652000
* IS SPECIFIED, CONTROL IS RETURNED TO THE USER WITH A 00653000
* 4 IN REGISTER 15. 00654000
* 00655000
* IF A MATCH IS NOT FOUND, FIND IS CALLED TO SEARCH THE 00656000
* DIRECTORY FOR A MEMBER NAME OF ALL ZEROES. AFTER THE 00657000
* SEARCH IS COMPLETE, NOTE 00658000
* IS CALLED, AND A CHECK IS MADE TO MAKE SURE THERE IS 00659000
* ROOM FOR THE NEW MEMBER, AND, IF NECESSARY, A NEW PDS 00660000
* BLOCK ON THE DISK. IF THERE IS NOT ENOUGH ROOM, 00661000
* CONTROL IS RETURNED TO THE USER WITH A TWELVE IN 00662000
* REGISTER 15. IF THERE IS ENOUGH ROOM AND AN 00663000
* UNSUCCESSFUL SEARCH FOR A NAME OF ZEROES WAS MADE, 00664000
* DMSFRE IS CALLED TO GET ENOUGH 00665000
* CORE FOR A PDS BLOCK AND 4 EXTRA BYTES. THEN ONE 00666000
* IS ADDED TO THE NEWBLKS COUNT AND THE NEW PDS BLOCK IS 00667000
* ZEROED OUT AND CHAINED TO THE PREVIOUS PDS BLOCK. IF 00668000
* THE ALIAS BIT IS ON IN THE STOW LIST, THE PDS IS UPDATED 00669000
* WITH THE TTR AND ALIAS BIT FROM THE STOW LIST AND CONTROL 00670000
* IS RETURNED TO THE USER. IF THE ALIAS BIT IS NOT ON, 00671000
* AN END OF DATA SET MARK (HEX '61FFFF61') IS WRITTEN AT 00672000
* THE END OF THE MEMBER AND THE ITEM 00673000
* NUMBER OF THE ITEM AFTER THE END OF DATA SET MARK IS 00674000
* STORED IN DICTPTR. THE DIRECTORY ENTRY OR NEW PDS BLOCK IS 00675000
* THEN UPDATED WITH THE MEMBER NAME AND ITEM NUMBER, 00676000
* A TWO IS STORED IN 00677000
* THE CHANGE BYTE, AND CONTROL IS RETURNED TO THE USER 00678000
* WITH A ZERO IN REGISTER 15. 00679000
* 00680000
* . THE UPDATED DIRECTORY IS NOT WRITTEN OUT TO DISK 00681000
* UNTIL THE DATA SET IS CLOSED. IF AN UPDATE PROGRAM 00682000
* DOES NOT CLOSE A PDS DATA SET FOR SOME REASON, E.G, A 00683000
* SYSTEM CRASH OR A RE-IPL, THE PDS DIRECTORY FOR THAT 00684000
* FILE WILL BE SAVED IN A TEMPORARY FILE WITH THE SAME 00685000
* FILETYPE AND A FILENAME OF $PDSTEMP. TO RESTORE THE 00686000
* DIRECTORY TO THE ORIGINAL FILE THE UPDATE PROGRAM 00687000
* MUST BE RUN AGAIN. 00688000
* 00689000
* 00690000
* 00691000
********************************************************************* 00692000
* *PDSSAVE (BPAM) 00693000
* 00694000
* FUNCTION: 00695000
* 00696000
* TO ENSURE THAT A BPAM PDS DIRECTORY IS NOT DESTROYED 00697000
* DURING AN UPDATE AND IS SAVED AFTER IT. 00698000
* 00699000
* ENTRY CONDITIONS: 00700000
* 00701000
* SVC 203 FOLLOWED BY A HALFWORD OF -3 AND R0 LESS THAN 0. 00702000
* 00703000
* EXIT CONDITIONS: 00704000
* 00705000
* CONTROL IS RETURNED TO THE CALLING ROUTINE WITH THE 00706000
* FOLLOWING CODE: 00707000
* 00708000
* SUCCESSFUL CALLING ROUTINE FCBPDS ENTRY 00709000
* ---------- --------------- ------------ 00710000
* YES DMSSBS ADDRESS OF DIRECTORY 00711000
* NO DMSSBS ZERO 00712000
* YES DMSSOP ZERO 00713000
* NO DMSSOP ADDRESS OF DIRECTORY 00714000
* 00715000
* CALLS TO OTHER ROUTINES: 00716000
* 00717000
* FIND IN DMSSVT,DMSFRE,DMSBWR,DMSERS,DMSFNS,DMSUFD, DMSADL 00718000
* 00719000
* TABLES/WORKAREAS: 00720000
* 00721000
* THE IN-CORE PDS DIRECTORY IS SAVED BY PDSSAVE. 00722000
* 00723000
* REGISTER USAGE: 00724000
* 00725000
* R0, R1, R3, R4,, R6, R7, R9, R11, R14, R15 - WORK 00726000
* R2 - DCB 00727000
* R5 - PDSSECT DSECT 00728000
* R8 - FCB 00729000
* R10 - OPSECT DSECT 00730000
* R12 - BASE 00731000
* R13 - SAVE AREA 00732000
* 00733000
* 00734000
* OPERATION: 00735000
* 00736000
* PDSSAVE GETS CONTROL FROM DMSSBS ON THE FIRST WRITE 00737000
* TO A BPAM FILE AFTER OPEN AND FROM DMSSOP WHEN AN 00738000
* UPDATED BPAM FILE IS CLOSED. WHEN CALLED BY DMSSBS, 00739000
* PDSSAVE CALLS FIND TO 00740000
* READ IN THE DIRECTORY. THE CHANGE BYTE IS CHECKED 00741000
* AND, IF IT IS ON, CONTROL IS RETURNED 00742000
* TO DMSSBS. IF THE CHANGE BYTE IS NOT ON, A $ IS 00743000
* WRITTEN IN THE TEMPORARY INDICATOR OF THE DIRECTORY 00744000
* HEADER RECORD OF THE ORIGINAL FILE, FIND IS CALLED TO 00745000
* READ IN THE DIRECTORY, AND A NEW FILE IS CREATED WITH 00746000
* THE SAME FILETYPE AND FILENAME OF $PDSTEMP. A 00747000
* DIRECTORY HEADER RECORD AND A COPY OF THE IN-CORE 00748000
* DIRECTORY IS WRITTEN INTO THIS FILE AND CONTROL IS 00749000
* RETURNED TO DMSSBS. 00750000
* 00751000
* WHEN CALLED BY DMSSOP OR BLDL, PDSSAVE CHECKS THE 00752000
* CHANGE BYTE AND, IF IT IS ZERO, FREES THE DIRECTORY 00753000
* CORE, 00754000
* SETS FCBPDS TO ZERO AND RETURNS TO THE CALLER. IF 00755000
* THE CHANGE BYTE IS NOT ZERO, PDSSAVE WRITES THE 00756000
* DIRECTORY 00757000
* TO DISK. IF THERE ARE NO ERRORS, THE DIRECTORY 00758000
* HEADER RECORD IS WRITTEN, DMSFRE IS CALLED 00759000
* TO FREE THE DIRECTORY CORE, FCBPDS IS SET TO ZERO, 00760000
* THE $PDSTEMP FILE IS ERASED AND CONTROL IS RETURNED 00761000
* TO THE CALLER. IF THERE ARE ERRORS WRITING THE 00762000
* DIRECTORY TO DISK, THE DIRECTORY HEADER RECORD IS NOT 00763000
* WRITTEN AND THE $PDSTEMP FILE IS NOT ERASED. 00764000
* 00765000
* TABLE/RECORD FORMAT: THE FORMAT OF THE DIRECTORY 00766000
* HEADER RECORD, THE DIRECTORY ON DISK AND THE IN-CORE 00767000
* DIRECTORY WITH ITS CONTROL WORDS IS DESCRIBED BELOW. 00768000
* 00769000
* DIRECTORY BYTES HEADER RECORD CONTENTS 00770000
* --------------- ---------------------- 00771000
* 1 - 6 MACLIB INDICATOR 'DMSLIB' 00772000
* 7 - 8 ITEM POINTER TO START OF DIRECTORY 00773000
* 11 - 12 BYTE SIZE OF DIRECTORY 00774000
* 13 - 80 REST OF RECORD NOT USED 00775000
* 00776000
* 00777000
* 00778000
* 00779000
* DIRECTORY ON DISK 00780000
* 00781000
* 8 BYTES 2 BYTES 2 BYTES 00782000
* ----------------------------------------------- 00783000
* |NAME OF FIRST MEMBER |ITEM PTR| ZERO | 00784000
* |NAME OF SECOND MEMBER|ITEM PTR| OR | 00785000
* | | | ALIAS BIT | 00786000
* |NAME OF NTH MEMBER |ITEM PTR| (X'0080') | 00787000
* ----------------------------------------------- 00788000
* 00789000
* IN-CORE DIRECTORY AND CONTROL WORDS 00790000
* 00791000
* DIRNAME DS 3H USED FOR MACLIB INDICATOR 00792000
* DIRPTR DS 1H ITEM POINTER TO START OF DIRECTORY 00793000
* TEMPBYTE DS 1X TEMP INDICATOR 00794000
* NEWBLKS DS 1X NO. OF NEW BLOCKS ADDED BY STOW 00795000
* CORESIZE DS 1H BYTE SIZE OF ORIGINAL IN CORE DIRECTORY 00796000
* PDSBLKSI DS 1H BYTE SIZE OF EACH PDS BLOCK 00797000
* CHNGBYTE DC X'00' BYTE USED TO INDICATE DIRECTORY CHANGE 00798000
* R15CODE DC X'00' USED TO SAVE REGISTER FIFTEEN. 00799000
* PDSDIR DS 0F IN CORE DIRECTORY. 00800000
* AT THE END OF THE IN-CORE DIRECTORY IS A 00801000
* FULL WORD THAT IS EITHER ZERO OR A POINTER 00802000
* TO THE NEXT PDS BLOCK. 00803000
* 00804000
* 00805000
* 00806000
* 00807000
* PDS BLOCK 00808000
* 00809000
* (ADDED TO IN-CORE DIRECTORY BY STOW) 00810000
* 00811000
* BYTES CONTENTS 00812000
* -------------------------------------------------- 00813000
* | 1 TO N | BLOCK OF PDS ENTRIES | 00814000
* | N+1 TO N+4 | ZERO OR POINTER TO NEXT PDS BLOCK | 00815000
* -------------------------------------------------- 00816000
* 00817000
* N = NUMBER OF ENTRIES IN A BLOCK 00818000
* 00819000
* 00820000
* 00821000
* 00822000
*. 00823000
EJECT 00824000
*********************************************************************** 00825000
SPACE 5 00826000
MACRO 00827000
JTBL &SVC,&ADD 00828000
DC AL1(&SVC),AL3(&ADD) 00829000
MEND 00830000
SPACE 2 00831000
MACRO 00832000
JOST &NUM,&LOC 00833000
DC AL1(&NUM),VL3(&LOC) 00834000
MEND 00835000
EJECT 00836000
DMSSVT START X'0' V0313 00837000
SOSVCTR EQU * V0313 00838000
USING SOSVCTR,R12 BASE ADDRESSS IN R12 00839000
USING TEMPSPC,R1 @V305665 00840000
USING FCBSECT,R8 00841000
USING OPSECT,R10 00842000
USING NUCON,R0 00843000
USING SSAVE,R13 00844000
L R13,CURRSAVE 00845000
LR R3,R14 SAVE R14 IN "WORK REGISTER", @VM03083 00846000
LA R0,TEMPLNT NUMBER OF DBL WORDS NEEDED, @VM03083 00847000
DMSFREE DWORDS=(0),TYPCALL=BALR GET TEMPORARY SPACE @VM03083 00848000
ST R3,SAVR14 SAVE RETURN REGISTER @VM03083 00849000
ST R1,OSTEMP SAVE SPACE ADDRESS @V305665 00850000
LM R0,R11,EGPR0 RESTORE REGS 00851000
LM R14,R15,EGPR14 TO VALUE AT TIME OF SVC 00852000
L R10,AOPSECT 00853000
L R9,=A(SOSVCT2) GET ADDR OF SECOND BASE REG 00854000
SR R3,R3 CLEAR WORK REGISTER @V305665 00855000
IC R3,OLDPSW+3 GET SVC NUMBER @V305665 00856000
LM R5,R7,SEARCH GET SEARCH ARGS 00857000
CARE1 EQU * SEARCH FOR SVC ADDRESS 00858000
CLM R3,1,0(R5) IS THIS THE SVC? @V305665 00859000
BNE CARE2 NO 00860000
L R4,0(,R5) FOUND SVC ADDRESS 00861000
CLI 0(R5),203 IS SVC NO. 203 00862000
BCR 8,R4 YES, THEN GO TO 203 ROUTINE 00863000
OI OSSFLAGS,OSRESET SET TO RESET OS CHAINS AT EOJ 00864000
BR R4 00865000
CARE2 BXLE R5,R6,CARE1 LOOP THRU 00866000
LM R5,R7,SEARCH1 GET SEARCH ARGUMENTS @V305665 00867000
CARE3 EQU * @V305665 00868000
CLM R3,1,0(R5) IS THIS THE SVC? @V305665 00869000
BNE CARE4 BRANCH IF NOT @V305665 00870000
OI OSSFLAGS,OSRESET SET TO RESET OS CHAINS AT EOJ@V305665 00871000
L R1,OSTEMP GET SPACE ADDRESS @V305665 00872000
L R3,SAVR14 PRESERVE RETURN REGISTER, @VM03083 00873000
LA R0,TEMPLNT NUMBER OF DBL WORDS USED, @VM03083 00874000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR RETURN SPACE @VM03083 00875000
LR R14,R3 RECOVER THE RETURN REGISTER @VM03083 00876000
DROP R1 @V305665 00877000
LM R0,R1,EGPR0 RESTORE REGISTERS @V305665 00878000
L R12,0(,R5) FOUND SVC ADDRESS @V305665 00879000
BR R12 @V305665 00880000
CARE4 EQU * @V305665 00881000
BXLE R5,R6,CARE3 LOOP THRU @V305665 00882000
* 00883000
* NOT FOUND 00884000
* 00885000
L R6,OSTEMP GET SPACE ADDRESS @V305665 00886000
USING TEMPSPC,R6 @V305665 00887000
L R5,TEXT3 GET MESSAGE ADDRESS @V305665 00888000
DMSERR MF=(E,ERRMESS),TEXTA=(R5),NUM=121,LET=S, @V305665X00889000
SUB=(DEC,(R3),HEX,(R3),HEXA,CALLER) @V305665 00890000
DROP 6 @V305665 00891000
LA R15,4 SET ERRROR CODE 00892000
STC R4,48 00893000
B CMSRET 00894000
EJECT 00895000
********************************************************************** 00896000
DEVTYPE EQU * 24-DETERMINE DEVICE CHARACTERISTECS 00897000
* C(R0)=A(DEVAREA), C(R1)=A(DCBDDNAM) 00898000
* IF C(R0)<0, DEVTAB WAS SPECIFIED 00899000
* IF C(R1)<0, RPS WAS SPECIFIED (WILL BE IGNORED) 00900000
* 00901000
LTR R9,R0 TEST REG 0 00902000
BM DEVTAB DEVTAB SPECIFIED 00903000
* 00904000
DV1 LA R6,DEVTABB GET ADDR OF DEVICE TBL ADDRESSES 00905000
LA R4,20 SETUP DEFAULT FCBDEV @VA07200 00906000
LA R15,4 SET CRT ERROR CODE 00907000
L R8,FCBTAB GET ADDR OF 1ST FCB 00908000
LTR R1,R1 WAS RPS SPECIFIED? @VA05153 00909000
BNM CKLAST BRANCH IF NOT @VA05153 00910000
LCR R1,R1 RECOMPLEMENT R1 @VA05153 00911000
B CKLAST CHECK FOR LAST FCB IN CHAIN 00912000
GETFCB CLC 0(8,R1),FCBDD IS THIS RIGHT FCB 00913000
BE GETDEV YES, GO GET FCBDEV 00914000
L R8,0(,R8) NO, GET NEXT FCB ADDR 00915000
CKLAST LA R8,0(,R8) CLEAR HI ORDER BYTE @VA03767 00916000
LTR R8,R8 IS THIS LAST FCB IN CHAIN? @VA03767 00917000
BNZ GETFCB NO, GO CHECK FOR MATCH 00918000
B DEVADDRS YES, GET TABLE ADDR 00919000
GETDEV IC R4,FCBDEV GET DEVICE CODE 00920000
DEVADDRS L R3,0(R6,R4) GET ADDR OF OS DEV CODE 00921000
IC R4,0(R6,R4) GET DEV CODE LENGTH 00922000
CH R4,EIGHT TWO WORD MOVE? 00923000
BE DOIT1 YES, DISREGUARD 'DEVTAB' 00924000
BL CMSRET MUST BE CRT, RETURN ERR CODE 00925000
LTR R0,R0 WAS DEVTAB SPECIFIED? 00926000
BM DOIT1 YES, FIVE WORD DEVICE TABLE 00927000
LA R4,8 FORCE TWO WORD DEVICE TABLE 00928000
DOIT1 BCTR R4,0 GET MVC COUNTER 00929000
EX R4,MVC MOBE IT, BUSTER 00930000
B CMSCLEAR RETURN 00931000
* 00932000
DEVTAB EQU * DEVTAB SPECIFIED. FIVE WORDS OF INFO 00933000
LCR R9,R9 RECOMPLEMENT R9 00934000
XC 0(20,R9),0(R9) CLEAR FIVE WORDS 00935000
B DV1 00936000
* TABLE OF DEVICE CHARACTERISTIC CONSTANTS 00937000
CN1052 DC X'10000820',AL4(130) 00938000
PR1403 DC X'10800808',AL4(120) 00939000
PU2540 DC X'10000802',AL4(80) 00940000
RD2540 DC X'10000801',AL4(80) 00941000
TP24009 DC X'30008001',AL4(32767) 00942000
DK2314 DC X'30C02008',AL4(7294) 00943000
DC X'00CB00141C7E922D2D010216' 00944000
MVC MVC 0(0,R9),0(R3) MOVE DEVICE CHARAC INTO DEVAREA 00945000
DEVTABB EQU * 00946000
DC X'14',AL3(DK2314) DUMMY 00947000
DC X'08',AL3(PR1403) PTR 00948000
DC X'08',AL3(RD2540) RDR 00949000
DC X'08',AL3(CN1052) CON 00950000
DC X'08',AL3(TP24009) TAPE 00951000
DC X'14',AL3(DK2314) DSK 00952000
DC X'08',AL3(PU2540) PUN 00953000
DC F'0' CRT 00954000
EJECT @VA04475 00955000
********************************************************************** 00956000
RDJFCB EQU * 64-READ JOB FILE CONTROL BLOCK 00957000
* C(R1) = V(DCB) 00958000
L 2,0(,1) PICK UP LSTDCB ADDRESS 00959000
ST R1,EGPR1 SAVE R1 @VA03361 00960000
USING IHADCB,2 00961000
L R3,DCBEXLST GET A(EXITLIST) 00962000
LA R3,0(,R3) 00963000
LTR R3,R3 WAS AN EXITLIST PROVIDED? 00964000
BZ CMSCLEAR NOPE. RETURN NONVIOLENTLY @VA03361 00965000
RDJF1 TM 0(3),X'07' IS THIS THE JFCB POINTER 00966000
BO RDJF2 YES. 00967000
TM 0(3),X'80' IS THIS THE END OF EXIT LIST? 00968000
BO RDJF3 YES. 00969000
LA 3,4(,3) INCREMENT EXIT LIST POINTER 00970000
B RDJF1 ZIP THRU ENTIRE EXIT LIST 00971000
RDJF2 L 3,0(,3) OBTAIN STORAGE ADDR OF JFCB 00972000
LA R3,0(,R3) CLEAR HIGH ORDER BYTE 00973000
LTR R3,R3 A(JFCB WORK AREA SUPPLIED)? 00974000
BZ RDJF3 NOPE, ABEND 00975000
MVI 0(3),X'00' 00976000
MVC 1(175,3),0(3) ZERO JFCB 00977000
TM DCBOFLGS,X'10' HAS DCB BEEN OPENED 00978000
BO RDJF2B YES @V1D1709 00979000
MVI 88(R3),X'01' SET BUFFERING TO ONE 00980000
B RDJF2A GO FIND OUT IF DATA SET EXISTS 00981000
RDJF2B EQU * @V1D1709 00982000
L R8,DCBDEBAD GET SIMULATED DEB ADDR @V1D1709 00983000
SH R8,=AL2(IHADEB-FCBINIT) GET FCB ADDR. @V1D1709 00984000
LA R9,CKFILE LOAD BRANCH ADDR. @V1D1709 00985000
RDJF2C MVC 0(52,R3),IHAJFCB MOVE JFCB INTO DCBAREA @VA03858 00986000
MVI 18(R3),X'40' BLANK OUT UNUSED PART @V1D1709 00987000
MVC 19(25,R3),18(R3) OF DSNAME FIELD @VA03858 00988000
MVC 72(JFCLRECL+2-JFCBMASK,R3),JFCBMASK 00989000
BR R9 @V1D1709 00990000
RDJF2A MVI 87(R3),X'C0' INDICATE NEW FILE 00991000
BAL R9,CKDLBL PERFORM SEARCH FOR VSAM DATA SET @V305174 00992000
LA R1,CMSOP GET PLIST ADDR 00993000
L R8,FCBFIRST GET PTR TO 1ST FCB 00994000
B CKLSTFCB IS THIS LAST FCB 00995000
GETMATCH LA R9,CKFILE LOAD BRANCH ADDRESS @V1D1709 00996000
CLC DCBDDNAM(8),FCBDD DO DDNAMES MATCH? @V1D1709 00997000
BE RDJF2C YES, GO MOVE IN JFCB INFO. @V1D1709 00998000
L R8,0(,R8) GET ADDR OF NEXT FCB 00999000
CKLSTFCB LTR R8,R8 IS THIS LAST FCB 01000000
BNZ GETMATCH NO, CHECK FOR MATCH 01001000
MVC FILENAME(8),CMSNAME SET DEFAULT NAME 01002000
MVC FILEMODE(2),=CL2'A1' SET DEFAULT MODE 01003000
MVC FILETYPE(8),DCBDDNAM SET DEFAULT TYPE 01004000
MVC CMSOP(8),WSTATE SET OP CODE 01005000
B DOSTATE GO DO STATE 01006000
CKFILE LA R1,FCBOP GET ADDR OF FCB PLIST 01007000
MVC FCBOP(8),WSTATE SET OP CODE 01008000
CLI FCBDEV,FCBDSK IS DEVICE DISK? @V1D1709 01009000
BNE CMSCLEAR NO, THEN INDICATE NEW FILE @VA03361 01010000
DOSTATE SVC X'CA' DO STATE @V1D1709 01011000
DC AL4(CMSCLEAR) NO THERE, RETURN @VA03361 01012000
MVI 87(R3),X'40' INDICATE OLD FILE 01013000
LTR R2,R2 LAST LISTDCB ADDRESS? @VA03361 01014000
BM CMSCLEAR YES, GET OUT @VA03361 01015000
L R1,EGPR1 GET PREVIOUS POINTER @VA03361 01016000
LA R1,4(,R1) GET NEXT POINTER @VA03361 01017000
B RDJFCB START OVER AGAIN @VA03361 01018000
RDJF3 EQU * NO JFCB STORAGE POINTER FOUND. ERROR 01019000
ABEND X'240' ABEND WITH SYSTEM CODE OF HEX 240 01020000
* 01021000
* SEARCH DLBL CHAIN OF DOSCB'S - MATCH MEANS VSAM DATA SET 01022000
* 01023000
CKDLBL L R7,DOSFIRST GET POINTER TO FIRST DOSCB @V305174 01024000
LTR R7,R7 DO ANY EXIST ? @V305174 01025000
BCR 8,R9 NO, PROCESS FCB CHAIN @V305174 01026000
USING DOSSECT,R7 @V305174 01027000
DOSDDCK CLC DCBDDNAM(7),DOSDD DDNAMES MATCH ? @V305174 01028000
BE INDICVSM YES, GO TURN ON VSAM DSORG @V305174 01029000
L R7,DOSNEXT GET ADDRESS NEXT DOSCB @V305174 01030000
LA R7,0(,R7) CLEAR HIGH ORDER BYTE @V305174 01031000
LTR R7,R7 FINISHED ? @V305174 01032000
BCR 8,R9 YES, PROCESS FCB CHAIN @V305174 01033000
B DOSDDCK ELSE, LOOP @V305174 01034000
INDICVSM MVI 99(R3),VSAMIND SET JFCDSORG TO 'VSAM' @V305066 01035000
B CMSCLEAR RETURN TO CALLER @V305174 01036000
DROP R2,R7 @V305174 01037000
EJECT @VA04475 01038000
********************************************************************** 01039000
* SVC 18 01040000
* 01041000
* CALLED BY FIND, BLDL, CLOSE OR THE FIRST WRITE 01042000
* TO A BPAM DATA SET. CONTENTS OF REG 0 AND REG 1 01043000
* DETERMINE THE ACTION TO BE TAKEN 01044000
* 01045000
*********************************************************************** 01046000
SPACE 01047000
SVC18 EQU * ENTRY FOR FIND AND BLDL 01048000
USING IHADCB,R2 01049000
USING PDSSECT,R11 01050000
MACLIBR EQU 32 01051000
LPR R2,R1 GET DCB ADDRESS 01052000
BZ CMSCLEAR IGNORE JOB LIB PROCESSING 01053000
L R8,DCBDEBAD GET ADDR OF DEB 01054000
SH R8,=AL2(IHADEB-FCBINIT) GET ADDR OF FCB 01055000
LR R9,R0 01056000
LTR R1,R1 IS THIS BLDL SVC? 01057000
BNL BLDL YES 01058000
SR R14,R14 RETURN TO USER AFTER FIND 01059000
* 01060000
* FINDD 01061000
* USED BY FIND, BLDL, STOW AND PDSSAVE ROUTINES TO READ 01062000
* IN AND SEARCH PDS DIRECTORIES FOR MEMBER NAMES. 01063000
* 01064000
FINDD SR R6,R6 SET FOR 1ST MACLIB NAME @V201122 01065000
MVI DCBRELAD+3,0 ZERO CONCATONATION NO. V0313 01066000
TM FCBINIT,FCBCATML IS CONCATONATION SPECIFIED 01067000
BO NEXTMAC YES, GET MACLIB NAME @V201122 01068000
TM FCBINIT,FCBOS IS THIS AN OS FCB @V201122 01069000
BO OSFNDDSK YES, THEN DO AN OS FIND @V201122 01070000
GETPDS L R11,FCBPDS GET ADDRESS OF PDS @V201122 01071000
LTR R11,R11 PDS DIRECTORY SPECIFIED @V201122 01072000
BNP GETDIR NO, GO GET IT 01073000
SRCHTBL LA R5,PDSDIR GET ADDRESS OF ENTRIES 01074000
LA R6,12 GET LENGTH OF ENTRIES 01075000
LH R7,CORESIZE GET CORESIZE OF ENTRIES 01076000
LTR R7,R7 ARE THERE ANY ENTRIES? @VA01953 01077000
BZ CHKSTOW SEE IF STOW ADDED ANY @VA01953 01078000
SETEND AR R7,R5 GET END OF DIRECTORY 01079000
BCTR R7,R0 SUBTRACT ONE 01080000
COMPLOOP TM FCBIOSW2,FCBMVPDS IS MOVE PDS SWITCH ON @V201122 01081000
BNO COMPARE NO, DO NORMAL COMPARE @V201122 01082000
CLC 0(8,R9),ZEROBIN IS SPECIFIED NAME = ZERO@V201122 01083000
BE SETMEMBR YES, GET NAME > ZERO @V201122 01084000
CLC 0(8,R5),0(R9) NAMES EQUAL @V201122 01085000
BNE BXLELOOP NO, CHECK NEXT NAME @V201122 01086000
TM FCBIOSW2,FCBMMV TST FOR MOVE MEMBER @VA03059 01087000
BNO BIXEL NO, THEN NOT FROM MOVE @VA03059 01088000
CLC 8(2,R5),8(R9) DUPLICATE MEMBER? @VA03059 01089000
BNE BXLELOOP YES, GET NEXT MEMBER @VA03059 01090000
BIXEL BXLE R5,R6,SETMEMBR GET NAME @VA03059 01091000
B NOTFOUND END OF LIST, SO NOT FOUN@V201122 01092000
SETMEMBR EQU * @VA05057 01093000
TM FCBIOSW2,FCBMMV IS THIS MOVE MEMBER? @VA05057 01094000
BZ MOVEMBR BRANCH IF NOT @VA05057 01095000
CLC 8(2,R5),8(R9) DUPLICATE ENTRY POINT? @VA05057 01096000
BE BIXEL BRANCH IF SO @VA05057 01097000
MOVEMBR EQU * @VA05057 01098000
MVC 0(8,R9),0(R5) NAME = NEW NAME @VA05057 01099000
CLC 0(8,R5),ZEROBIN NAME> ZEROES @V201122 01100000
BNH BXLELOOP NO, GET NEXT NAME @V201122 01101000
B FOUND INDICATE NEW NAME FOUND @V201122 01102000
COMPARE CLC 0(8,R5),0(R9) DO NAMES MATCH 01103000
BE FOUND YES 01104000
BXLELOOP BXLE R5,R6,COMPLOOP SETUP FOR NEXT COMPARE @V201122 01105000
CHKSTOW DS 0H @VA01953 01106000
CLC 0(4,R5),ZEROBIN DID STOW ADD ON ENTRIES 01107000
BE NOTFOUND NO 01108000
L R5,0(R5) YES, GET ADDRESS OF ENTRIES 01109000
LH R7,PDSBLKSI GET SIZE OF ENTRIES 01110000
B SETEND CONTINUE SEARCH 01111000
SPACE 2 01112000
* 01113000
* READ IN PDS DIRECTORY 01114000
* 01115000
GETDIR MVC FILENAME(32),FCBDSNAM FILL IN PLIST 01116000
ST R14,FCBOP SAVE RETURN ADDRESS 01117000
LH R5,DCBLRECL GET LRECL 01118000
CLC FCBCOUT(2),ONEBIN BLOCKING FACTOR= 1 V0277 01119000
BNE *+8 NO, USE LRECL V0277 01120000
LH R5,DCBBLKSI YES, USE BLKSIZE 01121000
LR R3,R5 SAVE LRECL 01122000
SR R4,R4 ZERO R4 01123000
D R4,TWELVE GET ENTRIES PER BLK 01124000
SR R3,R4 GET PDSBLKSI 01125000
LR R4,R3 SAVE IN REG 4 01126000
L R3,USAVEPTR GET FREE AREA 01127000
ST R3,FILEBUFF FILL IN ADDRESS 01128000
MVC FILEBYTE(4),TWELVE FILL IN LENGTH 01129000
MVC FILECOUT(2),ONEBIN FILL IN NO. OF ITEMS 01130000
LA R5,CKNAME SET ERROR RETURN 01131000
MVC FILEITEM(2),ONEBIN READ DICTIONARY 01132000
LA R1,PLIST HEADER 01133000
RDHEAD L R15,ARDBUF RECORD 01134000
BALR R14,R15 01135000
CH R15,NINE IS A FINIS NECESSARY? 01136000
BNE CKFOR1 CHECK FOR ERRORS 01137000
MVC CMSOP(8),WFINIS SET TO CALL FINIS 01138000
SVC X'CA' FINIS FILE 01139000
B RDHEAD GO READ HEADER 01140000
CKNAME LA R14,SETCODE SET RETURN ADDR 01141000
CLC 0(6,R3),MACLIB IS THIS A 1.0 MACLIB 01142000
BE CKTEMPSW YES, CONTINUE 01143000
LTR R11,R11 DID PDSSAVE CALL FINDD 01144000
BM BADPDS YES, THEN BAD MACLIB 01145000
CLC 3(3,R3),MACLIB+3 IS THIS A 3.1 MACLIB 01146000
BNE BADPDS NO, THEN PRINT ERR MSG 01147000
CKTEMPSW CLI 8(R3),C'$' IS THIS A GOOD DICTIONARY 01148000
BNE GETSIZE YES 01149000
MVC FILENAME(8),TEMP NO, GET TEMP FILE 01150000
B RDHEAD READ TEMP FILE 01151000
GETSIZE LH R7,10(R3) GET DICTIONARY SIZE 01152000
LA R0,27(R7) ADD CONTROL SPACE 01153000
SRL R0,3 GET NO. OF DOUBLE WORDS 01154000
DMSFREE DWORDS=(0),TYPCALL=BALR CALL FREE ROUTINE @VM03083 01155000
LR R11,R1 GET ADDRESS OF SPACE 01156000
TM FCBINIT,FCBCATML IS CONCATONATION SPECIFIED 01157000
BNO STFCBPDS NO 01158000
TM FCBINIT,FCBDOSL DOSLIB FCB ? @V305001 01159000
BNO MAC1 NO, BRANCH @V305001 01160000
ST R11,DOSDIRC(R6) SAVE PDS ADDRESS @V305001 01161000
B STFCBPDS BRANCH AROUND @V305001 01162000
MAC1 ST R11,MACDIRC(R6) SAVE PDS ADDRESS @V305001 01163000
STFCBPDS ST R1,FCBPDS SAVE DICTIONARY ADDRESS 01164000
LA R1,PLIST FILL IN PLIST 01165000
MVC DIRNAME(12),0(R3) SAVE HEADER INFO 01166000
MVI NEWBLKS,X'00' SET NO. OF NEW BLKS TO ZERO 01167000
SR R3,R3 ZERO REG 3 01168000
LR R6,R4 SET PDSBLKSI 01169000
MVC FILEITEM(2),DIRPTR GET START OF DICTIONARY 01170000
LA R4,PDSDIR GET START OF BUFFER 01171000
ST R6,FILEBYTE FILL IN PDSBLKSI 01172000
STH R6,PDSBLKSI SAVE PDSBLKSI 01173000
AR R7,R4 GET END OF ENTRIES 01174000
XC 0(4,R7),0(R7) ZERO DICTIONARY EXTENSION 01175000
LA R5,STBUFFAD SET UP ERROR RETURN 01176000
MVI CHNGBYTE,X'00' SET CHANGE BYTE 01177000
CLC FILENAME(8),TEMP IS THIS A TEMP FILE 01178000
BNE STBUFFAD NO 01179000
MVI CHNGBYTE,X'03' SET CHANGE BYTE 01180000
LA R15,2 PUT 2 IN REG 15 01181000
STH R15,FILEITEM POINT TO START OF TEMP PDS 01182000
BR R5 START READS 01183000
READBLK L R15,ARDBUF READ IN DICTIONARY 01184000
BALR R14,R15 BLOCKS 01185000
STH R3,FILEITEM ZERO ITEM NO. 01186000
BNZ CKFOR8 CHECK FOR ERRORS 01187000
STBUFFAD ST R4,FILEBUFF FILL IN BUFFER ADDRESS 01188000
BXLE R4,R6,READBLK CONTINUE READING 01189000
L R14,FCBOP RESTORE RETURN ADDRESS 01190000
C R7,FILEBYTE WAS LAST ITEM READ 01191000
BE SRCHTBL YES 01192000
SR R4,R6 NO 01193000
SR R7,R4 IS THERE ANYMORE 01194000
BZ SRCHTBL NO 01195000
ST R7,FILEBYTE YES 01196000
B READBLK DO ONE MORE READ 01197000
SPACE 2 01198000
* 01199000
* FOUND MEMBER NAME IN DIRECTORY 01200000
* 01201000
FOUND SR R15,R15 INDICATE NAME FOUND 01202000
LTR R14,R14 RETURN TO USER? 01203000
BCR 7,R14 NO, GO TO CALLING RTN 01204000
MVI DCBFDAD,X'00' TURN OFF POINT INDICATOR 01205000
MVC FCBITEM(2),8(R5) SET ITEM NO. 01206000
MVI DCBRELAD,0 SET 1ST BYTE OF DCBRELAD TO ZERO 01207000
MVC DCBRELAD+1(2),8(R5) SAVE ITEM NO. 01208000
B CMSCLEAR RETURN TO THE USER 01209000
SPACE 2 01210000
* 01211000
* MEMBER NAME NOT FOUND IN DIRECTORY 01212000
* 01213000
NOTFOUND LA R15,4 NAME NOT FOUND CODE 01214000
TM FCBINIT,FCBCATML IS CONCATONATION SPECIFIED 01215000
BO GETMAC YES 01216000
CKCALLER LTR R14,R14 RETURN TO USER? 01217000
BCR 7,R14 NO, GO TO CALLING RTN 01218000
ST R14,DCBRELAD ZERO DCBRELAD 01219000
B CMSRET RETURN TO THE USER 01220000
SPACE 2 01221000
* 01222000
* SET FCB TO SEARCH NEXT MACLIB PDS FOR MEMBER NAME 01223000
* 01224000
GETMAC SR R6,R6 CLEAR REG 6 @V201122 01225000
IC R6,DCBRELAD+3 GET CURRENT MACLIB PTR @V201122 01226000
LA R6,4(R6) GET NEXT MACLIB PTR @V201122 01227000
ST R6,DCBRELAD SAVE NEW MACLIB INCREMEN@V201122 01228000
NEXTMAC LA R5,0(R6,R6) GET MACLIB NAME INCREMEN@V201122 01229000
TM FCBINIT,FCBDOSL DOSLIB FCB ? @V305001 01230000
BNZ DOSLIB YES, BRANCH @V305001 01231000
LA R5,MACLIBL(R5) GET MACLIB NAME POINTER @V201122 01232000
L R11,MACDIRC(R6) GET PDS OR OS FST ADDR @V305001 01233000
B CHKEND BRANCH AROUND DOSLIB @V305001 01234000
DOSLIB LA R5,DOSLIBL(R5) GET DOSLIB NAME PTR @V305001 01235000
L R11,DOSDIRC(R6) GET PDS OR OS FST ADDR @V305001 01236000
CHKEND CLI 0(R5),FF END OF LIBRARY LIST ? @V305066 01237000
BE CKCALLER YES RETURN TO CALLER @V201122 01238000
LTR R11,R11 IS THIS AN OS DISK @V201122 01239000
BM OSCONCAT YES, DO AN OS FIND @V201122 01240000
NI FCBINIT,255-FCBOS TURN OFF FCB OS SWITCH @V201122 01241000
ST R11,FCBPDS FILL IN FCB PDS ADDRESS @V201122 01242000
MVC FCBDSNAM(8),0(R5) GET NEW MACLIB NAME @V201122 01243000
B GETPDS RETURN TO DO CMS FIND @V201122 01244000
* DO FIND ON OS DISK 01245000
OSCONCAT OI FCBINIT,FCBOS TURN ON FCB OS SWITCH @V201122 01246000
ST R11,FCBOSFST FILL IN OS FST ADDR @V201122 01247000
OSFNDDSK LR R11,R8 SET FCB ADDRESS IN R11 @V201122 01248000
LR R6,R14 SAVE RETURN REG @V201122 01249000
L R15,ADMSROS GET ADDRESS OF DMSROS @V201122 01250000
BAL R14,12(R15) GO TO OS FIND ROUTINE @V201122 01251000
LR R14,R6 RESTORE RETURN ADDRESS @V201122 01252000
CH R15,FOURBIN IS THIS A NOT FOUND ERRO@V201122 01253000
BE NOTFOUND YES, CHECK CONCAT BIT @V201122 01254000
B CKCALLER RETURN TO CALLER @V201122 01255000
SPACE 2 01256000
* 01257000
* CHECK ERRORS AND TAKE APPROPRIATE ACTION 01258000
* 01259000
CKFOR8 CH R15,EIGHT INCORRECT LENGTH? 01260000
BCR 8,R5 YES, CONTINUE 01261000
SETCODE LA R15,8 NO, THEN INDICATE I/O ERROR 01262000
PASSCODE L R14,FCBOP RESTORE RETURN ADDR P3056 01263000
B CKCALLER RETURN TO CALLER P3056 01264000
CKFOR1 CH R15,ONEBIN IS THIS A NEW DATA SET P3056 01265000
BNE CKFOR8 NO 01266000
LR R11,R3 YES 01267000
LA R7,16(R4) SETUP TO GET A PDSBLK 01268000
LR R5,R3 GET ADDR OF WORK AREA P3056 01269000
BAL R10,ADPDSBLK+4 GO GET A PDSBLK 01270000
L R10,AOPSECT RESTORE OPSECT REG V0277 01271000
LR R11,R5 GET ADDR OF PDS SECT 01272000
STH R4,CORESIZE FILL IN CORESIZE 01273000
STH R4,PDSBLKSI FILL IN PDSBLKSI 01274000
MVI DIRPTR+1,X'02' FILL IN DIRPTR 01275000
MVC DIRNAME(6),MACLIB FILL IN PDS INDICATOR 01276000
ST R5,FCBPDS FILL IN PDS ADDRESS @V201122 01277000
L R14,FCBOP GET RETURN ADDR P3056 01278000
TM FCBINIT,FCBCATML IS CONCATONATION SPECIFIED P3056 01279000
BNO ERR1RTRN NO, CHECK FOR PDSSAVE CALL P3056 01280000
TM FCBINIT,FCBDOSL DOSLIB FCB ? @V305001 01281000
BNO MAC3 NO, BRANCH @V305001 01282000
ST R5,DOSDIRC(R6) SAVE PDS ADDRESS @V305001 01283000
B NOTFOUND INDICATE MEM NOT FND @V305001 01284000
MAC3 ST R5,MACDIRC(R6) SAVE PDS ADDRESS @V305001 01285000
B NOTFOUND INDICATE MEMBER NOT FOUND P3056 01286000
ERR1RTRN LR R11,R5 SET PDS BASE REG @V201122 01287000
CLC FCBOP+1(3),=AL3(PDSSAVRT) CALL FROM PDSSAVE? @V201122 01288000
BNE NOTFOUND NO, GIVE NOT FOUND CODE @V201122 01289000
MVI CHNGBYTE,X'04' SET CHNGBYTE 01290000
LH R9,DCBLRECL GET RECORD LENGTH 01291000
CLC FCBCOUT(2),ONEBIN BLOCKING FACTOR= 1 V0277 01292000
BNE *+8 NO, USE LRECL V0277 01293000
LH R9,DCBBLKSI YES, USE BLKSIZE 01294000
ST R9,FILEBYTE SET BUFFER SIZE 01295000
ST R11,FILEBUFF SET BUFFER ADDR 01296000
LA R1,PLIST GET ADDR OF PLIST 01297000
L R15,AWRBUF GET ADDR OF WRBUF 01298000
BALR R14,R15 WRITE HEADER 01299000
BNZ SETCODE IF ERROR, THEN SET ERROR CODE 01300000
B PASSCODE RETURN TO CALLER P3056 01301000
SPACE 2 01302000
BADPDS EQU * @V305665 01303000
DMSERR NUM=033,LET=E,TEXTA=ERRMSG4, @V305665X01304000
SUB=(CHAR8A,(FCBDSNAM,18)) @V305665 01305000
BR R14 RETURN VIA CALLERS EXIT ADDR 01306000
EJECT @VA04475 01307000
*********************************************************************** 01308000
* 01309000
* BLDL 01310000
* USED TO TO HANDLE BLDL MACROES 01311000
* 01312000
*********************************************************************** 01313000
SPACE 01314000
BLDL EQU * P3056 01315000
LA R9,4(R9) MEMBER NAME 01316000
BAL R14,FINDD FIND MEMBER 01317000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01318000
USING TEMPSPC,R14 @V305665 01319000
MVI R15CODE,X'00' 01320000
LR R4,R9 GET START OF MEMBER NAME 01321000
SH R4,FOURBIN GET START OF BLDL LIST 01322000
LH R3,2(R4) GET ENTRY LENGTH 01323000
LH R4,0(R4) GET NO. OF ENTRIES 01324000
SH R3,NINE GET NUMBER FOR CLEARTTR 01325000
B ZERODATA GO CLEAR ENTRY 01326000
GOTOFIND L R14,USAVEPTR GET USER SAVE AREA PTR @V201122 01327000
STM R3,R4,R3*4(R14) SAVE REG3 AND 4 @V201122 01328000
BAL R14,FINDD FIND NEXT MEMBER @V201122 01329000
L R14,USAVEPTR GET USER SAVE AREA PTR @V201122 01330000
LM R3,R4,R3*4(R14) RESTORE REG3 AND 4 @V201122 01331000
ZERODATA EX R3,CLEARTTR CLEAR BLDL ENTRY 01332000
CH R15,FOURBIN WAS MEMBER FOUND 01333000
BL FILLTTR YES 01334000
BH CMSRET 01335000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01336000
STC R15,R15CODE NO, SAVE CODE 01337000
B CKFOREND GO CHECK FOR END 01338000
FILLTTR MVC 9(2,R9),8(R5) FILL IN TTR 01339000
MVC 11(1,R9),DCBRELAD+3 SET CONCATONATION NO. V0313 01340000
TM FCBINIT,FCBOS OS FCB? @V201122 01341000
BNO CKRELEAS NO, CHECK FOR RELEASE @V201122 01342000
LR R15,R3 GET ENTRY LENGTH - 9 @V201122 01343000
MVC 8(3,R9),8(R5) FILL IN OS TTR @V201122 01344000
SH R15,=H'5' SETUP FOR MOVE @V201122 01345000
BM CKFOREND MINIMUM LENGTH REQUESTED @VA10101 01345500
EX R15,MOVEINFO MOVE ENTRY TO BLDL LIST @V201122 01346000
B CKFOREND GET NEXT ENTRY @V201122 01347000
MOVEINFO MVC 13(0,R9),11(R5) MOVE ENTRY TO BLDL LIST @V201122 01348000
CKRELEAS EQU * CHECK RELEASE OF MACLIB @V201122 01349000
CLC DIRNAME(3),MACLIB IS THIS A 1.0 MACLIB 01350000
BNE CKFOREND NO, THEN DON'T MOVE ALIAS BIT 01351000
MVC 13(1,R9),11(R5) SET CONCATONATION NO. V0313 01352000
CKFOREND LA R9,9(R3,R9) GET NEXT MEMBER 01353000
BCT R4,GOTOFIND CONTINUE FILLING LIST 01354000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01355000
SR R15,R15 CLEAR RETURN CODE REG @VA12189 01355500
IC R15,R15CODE 01356000
B CMSRET YES RETURN TO USER 01357000
DROP R14 @V305665 01358000
EJECT 1 01359000
*********************************************************************** 01360000
* 01361000
* PDSSAVE 01362000
* USED TO SAVE A PDS DIRECTORY IN A TEMP FILE IN CASE 01363000
* OF A SYSTEM CRASH DURING AN UPDATE 01364000
* 01365000
********************************************************************** 01366000
SPACE 01367000
SVC203 EQU * ENTRY FOR PDSSAVE AND KEYSAVE 01368000
OI OSSFLAGS,OSRESET SET TO RESET OS CHAINS AT EOJ 01369000
PDSSAVE L R8,DCBDEBAD GET ADDR OF DEB 01370000
SH R8,=AL2(IHADEB-FCBINIT) GET ADDR OF FCB 01371000
AH R0,ONEBIN IS THIS A PDS CLOSE 01372000
BZ PDSCLOSE YES, GO TO PDSCLOSE 01373000
BP KEYSAV NO, GO SAVE KEYS 01374000
LA R15,4 SET ERROR CODE 01375000
TM FCBINIT,FCBCATML IS CONCATONATION SPECIFIED 01376000
BO CMSRET YES, RETURN TO THE USER V0277 01377000
LA R9,ZEROBIN CALL FIND TO 01378000
BAL R14,FINDD READ IN THE DIRECTORY 01379000
PDSSAVRT EQU * RETURN POINT FOR FIND CA@V201122 01380000
CH R15,EIGHT WAS THERE AN I/O ERROR 01381000
BE CMSRET YES, RETURN TO THE USER 01382000
MVC FCBITEM(2),DIRPTR SET ITEM NO. 01383000
MVI DCBRELAD,0 SET 1ST BYTE OF DCBRELAD TO ZERO 01384000
MVC DCBRELAD+1(2),DIRPTR FILL IN DCBRELAD 01385000
CLI CHNGBYTE,X'00' IS CHANGE BYTE ZERO? 01386000
BNE CMSCLEAR NO, RETURN TO THE USER 01387000
B GETPLIST YES 01388000
EJECT @VA04475 01389000
********************************************************************** 01390000
* 01391000
* PDSCLOSE 01392000
* USED BY CLOSE TO SAVE A KEY OR PDS DIRECTORY AND FREE THE 01393000
* DIRECTORY CORE 01394000
* 01395000
*********************************************************************** 01396000
SPACE 1 01397000
USING TEMPSPC,R14 @V305665 01398000
PDSCLOSE EQU * @V305665 01399000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01400000
MVI R15CODE,RC0 ZERO RETURN CODE @V305066 01401000
PDSCLOS2 L R11,FCBPDS GET PDS ADDRESS V0313 01402000
CKSYSLIB TM FCBINIT,FCBCATML IS CONCATIONATION SPECIFIED? 01403000
BO FREESYS YES, GO FREE CORE 01404000
CLI CHNGBYTE,X'00' IS CHANGE BYTE SET 01405000
BNE GETPLIST YES, SAVE PDS @V201122 01406000
CLI TEMPBYTE,C'$' WAS PDS SAVED @V201122 01407000
BNE FREEPDS NO, FREE PDS @V201122 01408000
MVI CHNGBYTE,5 SET CHANGE INDICATOR @V201122 01409000
GETPLIST EQU * @V305665 01410000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01411000
MVI R15CODE,RC0 ZERO RETURN CODE @V305066 01412000
DROP R14 @V305665 01413000
MVI TEMPBYTE,0 SET NON TEMP INDICATOR 01414000
MVC FILENAME(32),FCBDSNAM FILL IN PLIST 01415000
LH R6,DCBLRECL GET DCBBLKSI 01416000
CLC FCBCOUT(2),ONEBIN BLOCKING FACTOR= 1 V0277 01417000
BNE *+8 NO, USE LRECL V0277 01418000
LH R6,DCBBLKSI YES, THEN USE BLKSIZE 01419000
ST R6,FILEBYTE FILL IN LENGTH 01420000
MVC FILECOUT(2),ONEBIN FILL IN NO. OF ITEMS 01421000
LH R3,DIRPTR GET START OF DIRECTORY 01422000
LA R1,PLIST GET PLIST ADDRESS 01423000
CLI CHNGBYTE,X'00' CALLED BY CLOSE OR BSAM? 01424000
BE NEWPDS BSAM, GO SETUP TEMP PLIST 01425000
WRDIR LA R4,PDSDIR GET DIRECTORY ADDRESS 01426000
STH R3,FILEITEM FILL IN ITEM NO. 01427000
SR R3,R3 ZERO REG 3 01428000
LH R6,PDSBLKSI GET PERBLKSI 01429000
LR R7,R4 01430000
AH R7,CORESIZE GET END OF DIRECTORY ADDRESS 01431000
CKBLKEND CR R4,R7 IS THIS END OF PDS BLK 01432000
BE CKSTOW YES, SEE IF STOW ADDED A BLK 01433000
WRBLK ST R4,FILEBUFF FILL IN BUFFER ADDR 01434000
L R15,AWRBUF WRITE DIRECTORY 01435000
BALR R14,R15 TO DISK 01436000
LA R14,*+8 GET RETURN ADDR 01437000
BNZ WRERR GO HANDLE ERR CODE IF SET 01438000
STH R3,FILEITEM ZERO ITEM NO. 01439000
BXLE R4,R6,CKBLKEND CONTINUE WRITING 01440000
B CKTEMP CHECK TEMP SWITCH 01441000
CKSTOW CLC 0(4,R7),ZEROBIN DID STOW ADD ENTRIES 01442000
BE EXTRBLK NO 01443000
L R4,0(R7) YES, GET ENTRY ADDR 01444000
LA R7,0(R6,R4) GET END ADDR 01445000
B WRBLK GO WRITE BLK 01446000
EXTRBLK CH R6,HEX48 IS BLKSIZE 72 01447000
BNE CKTEMP NO, CHECK TEMP SWITCH 01448000
CLC FILENAME(8),TEMP IS THIS TEMP FILE 01449000
BE CKTEMP GO UPDATE DIRECTORY 01450000
SR R4,R6 YES, THEN SET UP 01451000
AR R6,R6 TO WRITE EXTRA BLK 01452000
XC 0(76,R4),0(R4) SO THE MACLIB COMMAND 01453000
B WRBLK WILL WORK ON THIS PDS 01454000
CKTEMP CLC FILENAME(8),TEMP IS TEMP SWITCH ON 01455000
BNE WRHEADER NO, GO WRITE HEADER 01456000
BAL R4,UPDTDSK UPDATE DISK DIRECTORY 01457000
LA R1,PLIST RESTORE ADDR OF PLIST 01458000
MVC FILENAME(8),FCBDSNAM YES, WRITE HEADER 01459000
MVI TEMPBYTE,C'$' SET TEMP INDICATOR 01460000
B WRHEADER GO WRITE 01461000
NEWPDS LA R3,2 CHANGE DIRPTR 01462000
MVC FILENAME(8),TEMP FILL TEMP MODE 01463000
WRHEADER MVC FILEITEM(2),ONEBIN FILL ITEM NO. 01464000
LH R4,CORESIZE GET PDS SIZE 01465000
N R4,HALFWORD ZERO FIRST HALF 01466000
SR R15,R15 GET NO. OF NEW BLKS 01467000
IC R15,NEWBLKS 01468000
MH R15,PDSBLKSI GET SIZE OF PDS IN BYTES 01469000
AR R15,R4 ADD SIZE OF NEW BLKS 01470000
STH R15,CORESIZE SET CORE SIZE FOR HEADER 01471000
LA R15,DIRNAME GET BUFFER ADDRESS 01472000
ST R15,FILEBUFF FILL BUFFER ADDRESS 01473000
WRHEAD L R15,AWRBUF GET ADDR OF WRITE RTN 01474000
BALR R14,R15 WRITE BUFFER 01475000
LA R14,WRHEAD GET ADDR OF WRITE RTN 01476000
BNZ WRERR GO HANDLE ERR CODE IF SET 01477000
STH R4,CORESIZE SET CORESIZE OF MAIN PDS 01478000
CLC FILENAME(8),TEMP TEMP? FILE 01479000
BE WRDIR YES, CONTINUE WRITES 01480000
BAL R14,FINISFIL GO FINIS FILE 01481000
CLI CHNGBYTE,X'00' CALLED BY BSAM? 01482000
BE CMSCLEAR YES, RETURN 01483000
MVC FILENAME(8),TEMP ERASE TEMP FILE 01484000
L R15,AERASE 01485000
BALR R14,R15 01486000
SPACE 1 01487000
* FREE DIRECTORY CORE 01488000
SPACE 1 01489000
FREEPDS LA R5,CMSRET SET RETURN ADDRESS 01490000
XC FCBPDS(4),FCBPDS ZERO FCBPDS 01491000
FREECORE LTR R1,R11 GET DIRECTORY ADDRESS 01492000
BCR 13,R5 BNP GET NEXT ADDRESS @V201122 01493000
LH R6,PDSBLKSI GET PDSBLKSI 01494000
LH R7,CORESIZE GET CORESIZE 01495000
LA R7,16(R7) ADD CONTROL WORDS 01496000
FREEBLK LA R0,11(R7) GET SIZE FOR CALL TO FRET 01497000
L R7,0(R1,R7) GET EXTENSION ADDRESS 01498000
SRL R0,3 GET NO. OF DOUBLE WORDS 01499000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR FRET ROUTINE @VM03083 01500000
SR R15,R15 SET RETURN CODE 01501000
USING TEMPSPC,R14 @V305665 01502000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01503000
IC R15,R15CODE 01504000
C R7,ZEROBIN IS THERE A STOW EXTENSION 01505000
BCR 8,R5 NO 01506000
LR R1,R7 YES, GET ENTRY ADDRESS 01507000
LR R7,R6 GET BLKSI 01508000
B FREEBLK FREE BLOCKS 01509000
SPACE 1 01510000
* FREE MACLIB DIRECTORY CORE 01511000
SPACE 1 01512000
FREESYS LA R3,MACDIRC GET ADDR OF MAC PDS'S @V201122 01513000
LA R4,MACLIBL GET ADDR OF MAC NAME LIS@V201122 01514000
TM FCBINIT,FCBDOSL DOSLIB FCB ? @V305001 01515000
BNO MAC4 NO, BRANCH @V305001 01516000
LA R3,DOSDIRC GET ADDR DOS PDS'S @V305001 01517000
LA R4,DOSLIBL GET ADDR DOS NAME LIST @V305001 01518000
MAC4 BALR R5,R0 GET RETURN ADDRESS @V305066 01519000
L R11,0(R3) GET NEW DIRECTORY ADDRESS 01520000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01521000
SR R15,R15 CLEAR RETURN REG V0313 01522000
IC R15,R15CODE SET ERROR CODE V0313 01523000
CLI 0(R4),X'FF' END OF MAC LIST? @V201122 01524000
BE CMSRET RETURN TO CALLER V0313 01525000
XC 0(4,R3),0(R3) ZERO PDS ADDR 01526000
LA R4,8(R4) INCREMENT BY 8 01527000
LA R3,4(R3) INCREMENT BY 4 01528000
B FREECORE GO FREE CORE 01529000
DROP R14 @V305665 01530000
SPACE 2 01531000
WRERR CH R15,NINE IS FILE OPEN FOR READS 01532000
BNE CMSRET NO, RETURN TO THE USER 01533000
FINISFIL MVC CMSOP(8),WFINIS CALL FINIS 01534000
SVC X'CA' 01535000
DC AL4(CMSRET) 01536000
BR R14 RETURN TO CALLER 01537000
SPACE 1 01538000
* UPDATE DISK DIRECTORY 01539000
SPACE 1 01540000
UPDTDSK L R15,VCADTLKP GET ADTLKP ADDRESS @VM03093 01541000
BALR R14,R15 GO GET ADT ADDR 01542000
LR R0,R1 GET ADT ADDR 01543000
LTR R15,R15 TEST REG 15 @VA09243 01544000
BCR 7,R4 NON ZERO,THEN RETURN 01545000
TM ADTFLG1-ADTSECT(R1),ADTFRW R/W DISK @VA09243 01545100
BO UPDISK YES , UPDATE THE DISK @VA09243 01545200
LA R15,ERR36 ERROR FOR WRITE ON R/O DISK @VA09243 01545300
BR R4 RETURN @VA09243 01545400
UPDISK DS 0H @VA09243 01545500
SR R1,R1 ZERO REG 1 @VA09243 01545600
L R15,ATFINIS GET ADDR OF TFINIS 01546000
BALR R14,R15 TFINIS FILE 01547000
LTR R15,R15 TEST FOR ERRORS 01548000
BCR 7,R4 NON ZERO, THEN RETURN 01549000
LR R1,R0 SET REG 1 POSITIVE 01550000
L R15,AUPDISK GO UPDATE DIRECTORY 01551000
BALR R14,R15 BRACH TO UPDISK 01552000
BR R4 RETURN 01553000
EJECT @VA04475 01554000
********************************************************************* 01555000
* 01556000
* KEYSAV 01557000
* WHEN CALLED BY SOBDAM ... CREATE KEY FILES AND KEY TABLE 01558000
* WHEN CALLED BY SOOPCL ... RESTORE KEYS TO DATA FILE AND FREE 01559000
* THE KEY TABLE CORE 01560000
********************************************************************* 01561000
SPACE 1 01562000
USING KEYSECT,R5 01563000
KEYSAV L R5,FCBKEYS GET ADDR OF KEY TABLE 01564000
SR R7,R7 CLEAR REG 7 OFR KEYLE V0016 01565000
LH R3,DCBBLKSI GET BLOCKSIZE V0016 01566000
IC R7,DCBKEYLE GET KEY LENGTH V0016 01567000
LR R6,R7 SAVE KEY LENGTH V0300 01568000
LA R9,1 SET KEYCOUT TO 1 V0300 01569000
SLL R7,8 MULTIPLY BY 256 V0016 01570000
CLI EGPR0+3,4 IS THIS CALL FROM DMSSBD V0016 01571000
BNE GETBLKSI NO, SAVE AND OR FREE TBLS V0016 01572000
LTR R5,R5 IS IT ZERO 01573000
BNZ CKDATA NO, THEN BYPASS GETMAIN V0016 01574000
SPACE 1 01575000
* SETUP KEY TABLE CONTROL BLOCK 01576000
SPACE 1 01577000
TM DCBRECFM,VAR IS RECFM FXD V0016 01578000
BO GETTBL NO, GO GET CORE V0016 01579000
SR R6,R6 PREPARE FOR DIVIDE V0016 01580000
DR R6,R3 GET NO. BLOCKS IN TABLE V0016 01581000
LTR R6,R6 IS THERE A REMAINDER V0016 01582000
BZ GETFXDSI NO, USE RESULT V0016 01583000
LA R7,1(R7) ADD ONE TO RESULT V0016 01584000
GETFXDSI LR R9,R7 SAVE RESULT AS KEYCOUT V0016 01585000
MR R6,R3 GET SIZE OF TABLE V0016 01586000
GETTBL LA R0,59(R7,R6) GET SIZE OF KEY TABLE V0300 01587000
SRL R0,3 GET NO. OF DOUBLE WORDS 01588000
DMSFREE DWORDS=(0),TYPCALL=BALR CALL FREE ROUTINE @VM03083 01589000
LR R5,R1 GET TABLE ADDR 01590000
ST R5,FCBKEYS FILL IN FCBKEYS 01591000
XC 0(56,R5),0(R5) CLEAR PLIST 01592000
MVC KEYTYPE(10),FCBDSTYP FILL IN FILE TYPE 01593000
ST R7,TBLLNGTH FILL IN TABLE LENGTH 01594000
MVI KEYCOUT+1,X'01' FILL IN BLOCKING FACTOR 01595000
LA R14,KEYTABLE GET ADDR OF KEY TABLE V0016 01596000
ST R14,KEYTBLAD SET TABLE ADDR IN PLIST V0016 01597000
MVC KEYLNGTH+3(1),DCBKEYLE SET KEY LENGTH V0016 01598000
STH R9,KEYCOUT SET BLOCKING FACTOR OF KEYSV0300 01599000
TM DCBRECFM,VAR IS RECFM FIXED V0016 01600000
BO CKDATA NO, THEN CONTINUE V0016 01601000
MVC DATAEND+2(2),FCBXTENT SET END OF DATA SET PTR V0016 01602000
CKDATA MVI KEYFORM,C'F' SET FOR FIXED KEY TABLES V0016 01603000
LA R1,FCBOP GET PLIST ADDR V0016 01604000
MVC KEYNAME(8),KEYTEMP SET TEMPORARY NAME V0300 01605000
L R4,ASTATE GET ADDR OF STATE 01606000
LR R15,R4 GET STATE ADDR 01607000
BALR R14,R15 CALL STATE TO GET FST ADDR 01608000
BNZ ZEROTBL NO DATA FILE, THEN RETURN 01609000
GETBLKSI LH R6,DCBBLKSI GET BLKSI 01610000
LR R3,R6 SAVE BLKSI 01611000
CR R6,R7 IS BLKSI LARGER THAN KEY TABLE 01612000
BNH CKREG0 NO THEN CONTINUE 01613000
LR R6,R7 REPLACE BLKSI WITH TABLE SIZE 01614000
CKREG0 CLI EGPR0+3,4 IS THIS A CALL FROM DMSSBD V0016 01615000
BE SETUP YES, THEN SETUP KEY FILE V0016 01616000
SPACE 1 01617000
* SETUP TO MOVE KEYS TO DATA FILE 01618000
SPACE 1 01619000
XC FCBKEYS(4),FCBKEYS CLEAR ADDR OF KEY TBL 01620000
LR R0,R3 GET FCB I/O SIZE 01621000
L R3,DATAEND GET END OF DATA PTR 01622000
AH R3,FCBCOUT ADD BLOCKING FACTOR 01623000
STH R3,FCBITEM POINT TO END DATA 01624000
LA R3,1(R3) GET PTR TO START OF KEYS 01625000
L R9,AWRBUF GET WRBUF ADDR 01626000
L R10,ARDBUF GET RDBUF ADDR 01627000
LA R1,KEYOP GET ADDR OF KEY PLIST 01628000
CLI KEYCHNG,X'00' WAS THE KEY TABLE CHANGED 01629000
BE RESET NO, CONTINUE 01630000
TM DCBRECFM,VAR RECFM VAR OR UND V0300 01631000
BO LASTTBL YES, NOT BLOCKED V0300 01632000
LH R14,KEYTBLNO GET TBL NO V0016 01633000
BCTR R14,R0 MINUS ONE FOR MULTIPLY V0016 01634000
MH R14,KEYCOUT GET RELATIVE ITEM NO. V0016 01635000
A R14,DATAEND GET ACTUAL ITEM NO. V0016 01636000
STH R14,KEYTBLNO SET ITEM NO. V0016 01637000
LASTTBL LR R15,R9 WRITE LAST KEY TABLE V0016 01638000
BALR R14,R15 SAVE THIS KEY TABLE 01639000
BNZ CKERRS CHECK ERRORS 01640000
RESET MVC KEYTBLNO(2),DATAEND+2 SET STARTING ITEM NO. V0300 01641000
CLC KEYNAME(8),KEYTEMP SHOULD FILE BE WRITTEN V0016 01642000
BNE FREETBL NO, GO FREE TABLES V0016 01643000
ST R3,DATAEND SET KEY POINTER NO. V0016 01644000
BAL R2,WREOF GO WRITE EOF INDICATOR 01645000
L R2,EGPR2 GET DCB BASE V0016 01646000
TM DCBRECFM,VAR IS RECFM FIXED V0016 01647000
BNO GETKEYS YES, THEN CONTINUE V0300 01648000
L R0,TBLLNGTH BLKSI= TABLE LENGTH V0016 01649000
LR R6,R0 BLKSI= TABLE LENGTH V0016 01650000
MVC KEYTBLNO(2),ONEBIN SET ITEM NO. TO ONE V0300 01651000
GETKEYS SR R3,R3 IGNORE $KEYSAVE PLIST V0300 01652000
BAL R2,RDWRKEY2 MOVE KEYS TO DATA FILE 01653000
MVC 0(8,R1),WFINIS FINIS DATA FILE 01654000
SVC X'CA' SVC TO FINIS 01655000
DC AL4(*+4) 01656000
L R15,AERASE GET ADDR OF ERASE 01657000
LA R1,KEYOP GET ADDR OF KEY PLIST 01658000
BALR R14,R15 ERASE $KEYTEMP FILE 01659000
MVC KEYNAME(8),SAVEFILE GET $KEYSAVE NAME 01660000
L R15,AERASE GET ADDR OF ERASE 01661000
BALR R14,R15 ERASE $KEYSAVE 01662000
FREETBL EQU * FREE KEY TABLE V0016 01663000
L R1,TBLLNGTH GET TABLE LENGTH 01664000
L R2,EGPR2 GET DCB ADDR V0300 01665000
SR R15,R15 DO NOT ADD IN KEYLENGTH V0300 01666000
TM DCBRECFM,VAR RECFM = VAR OR UND V0300 01667000
BNO SETSIZE NO, DON'T ADD KEYLENGTH V0300 01668000
L R15,KEYLNGTH ADD KEYLENGTH TO SIZE V0300 01669000
SETSIZE LA R0,59(R1,R15) GET SIZE OF KEY TABLES V0300 01670000
LR R1,R5 GET DSECT ADDR 01671000
SRL R0,3 GET NO. OF DOUBLE WORDS 01672000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR FRET KEY TBL @VM03083 01673000
B CMSCLEAR RETURN 01674000
SPACE 1 01675000
* MOVE KEYS TO OR FROM DATA FILE 01676000
SPACE 1 01677000
RDWRKEY1 LTR R1,R3 IS $KEYSAVE PART OF MOVE 01678000
BZ RDWRKEY2 NO, CONTINUE 01679000
LR R15,R10 GET ADDR OF I/O RTN 01680000
BALR R14,R15 GO DO I/O 01681000
BNZ CKERRS CHECK ERRS 01682000
SR R15,R15 ZERO REG 15 P3056 01683000
STH R15,X'1A'(R1) ZERO ITEM NO. P3056 01684000
RDWRKEY2 LA R1,KEYOP GET ADDR OF KEY PLIST 01685000
LR R15,R10 GET I/O ADDR 01686000
BALR R14,R15 DO I/O 01687000
BNZ CKERRS CHECK ERRORS 01688000
SR R15,R15 ZERO REG 15 01689000
STH R15,KEYTBLNO ZERO KEYTBLNO. 01690000
MOVEKEYS LA R1,FCBOP GET ADDR OF FCB PLIST 01691000
L R4,KEYTBLAD GET KEY TABLE ADDR 01692000
LR R7,R4 SET KEY TABLE ADDR 01693000
A R7,TBLLNGTH GET ADDR OF END KEY TABLE 01694000
ST R0,FCBBYTE FILL IN BYTE SIZE 01695000
SETAD ST R4,FCBBUFF FILL IN BUFFER ADDR 01696000
BXH R4,R6,GETREST IS BUFFER FULL 01697000
RDWRDATA LR R15,R9 GET I/O ADDR 01698000
BALR R14,R15 DO I/O 01699000
BNZ CKERRS CHECK ERRORS 01700000
SR R15,R15 ZERO REG 15 01701000
STH R15,FCBITEM ZERO ITEM NO. 01702000
CLC KEYTABLE(4),EOF IS THIS AN EOF INDICATOR? 01703000
BCR 8,R2 YES, THEN RETURN TO CALLER 01704000
L R14,KEYLNGTH GET THE KEYLENGTH @VA01363 01705000
SLL R14,8 KEYLENGTH X 256 @VA01363 01706000
CR R6,R14 BLKSI = > TBLLENGTH @VA01363 01707000
BNL RDWRKEY1 YES, GET NEXT TBL @VA01363 01708000
B SETAD MOVE NEXT RECORD 01709000
GETREST SR R4,R6 GET AMOUNT LEFT IN BUFFER 01710000
SR R7,R4 01711000
BNP RDWRKEY1 IF FULL, MOVE ON 01712000
LTR R3,R3 SHOULD FCBBYTE BE CHANGED 01713000
BZ RDWRDATA NO 01714000
ST R7,FCBBYTE FILL IN RESIDUAL COUNT 01715000
B RDWRDATA GO WRITE KEYS 01716000
CKERRS CH R15,EIGHT IS ERROR BAD LENGTH 01717000
BE 4(R14) YES, CONTINUE 01718000
CH R15,TWELVE+2 IS THIS END OF FILE 01719000
BE ENDMOVE YES, THEN SET FOR RETURN 01720000
CH R15,NINE IS A FINIS NEEDED 01721000
BNE CMSRET NO, RETURN WITH ERROR CODE 01722000
MVC 0(8,R1),WFINIS GET FINIS SVC 01723000
SVC X'CA' SVC TO FINIS 01724000
DC AL4(*+4) 01725000
SH R14,FOURBIN DO I/O AGAIN 01726000
BCR 15,R14 DO I/O AGAIN 01727000
ENDMOVE C R9,ARDBUF IS THIS DURING CLOSE 01728000
BCR 8,R2 NO, RETURN 01729000
CLC KEYTABLE(4),EOF EOF ALREADY @VA09243 01729300
BE CMSRET YES, GIVE UP @VA09243 01729600
WREOF L R15,EGPR2 GET DCB BASE V0016 01730000
USING IHADCB,R15 V0016 01731000
LH R0,DCBBLKSI GET BLOCKSIZE V0016 01732000
DROP R15 V0016 01733000
USING IHADCB,R2 V0016 01734000
MVC KEYTABLE(4),EOF SET EOF INDICATOR V0016 01735000
MVC KEYTABLE+4(2),FCBXTENT SET FCBXTENT V0016 01736000
MVC KEYTABLE+6(2),=CL2'KY' SET INDICATOR FOR PTR V0016 01737000
MVC KEYTABLE+8(2),DATAEND+2 SET POINTER TO KEYS V0016 01738000
B MOVEKEYS WRITE EOF RECORD V0016 01739000
SPACE 1 01740000
* SETUP TO CREATE KEYS FILES 01741000
SPACE 1 01742000
SETUP LR R0,R6 SET BUFFER LENGTH P3056 01743000
L R3,FCBBUFF GET FST PTR 01744000
MVC FCBITEM(2),26(R3) POINT TO LAST DATA ITEM 01745000
MVC DATAEND+2(2),26(R3) POINT TO LAST DATA ITEM 01746000
LA R3,PLIST GET ADDR OF PLIST 01747000
MVI KEYTBLNO+1,X'01' SET KEY FILE PTRS AT 1 01748000
MVC FILENAME(8),SAVEFILE FILL IN $KEYSAVE NAME 01749000
MVC FILETYPE(24),KEYTYPE GET REST OF PLIST 01750000
LR R1,R3 GET PLIST ADDR 01751000
LR R15,R4 GET STATE ADDR 01752000
BALR R14,R15 SEE IF FILE EXISTS 01753000
MVC FILEBUFF(4),KEYTBLAD RESTOR KEY TABLE ADDR 01754000
L R9,ARDBUF GET READ PTRS 01755000
L R10,AWRBUF GET WRITE PTRS 01756000
BNZ RDKEYPTR FILE NOT THERE 01757000
LR R8,R3 SET FCB DSECT REG TO CMSOP ADDR 01758000
SH R8,=H'16' ALIGN CMSOP SAME AS FCBOP 01759000
LR R6,R7 GET TABLE LENGTH 01760000
SR R3,R3 ZERO REG 3 01761000
B GOMOVE GO CREATE $KEYSAVE FILE 01762000
RDKEYPTR BAL R2,MOVEKEYS READ IN PTR TO KEYS 01763000
L R2,EGPR2 GET DCB BASE V0016 01764000
CLC KEYTABLE+4(4),SAVEFILE IS THIS A KEY PTR 01765000
BNE CKFORKY NO,CHECK FOR NEW INDICATOR V0016 01766000
L R15,KEYTABLE+8 GET POINTER TO KEYS V0016 01767000
B SETFORRD GO GET KEYS V0016 01768000
CKFORKY LA R15,8 SET ERROR CODE V0016 01769000
CLC KEYTABLE+6(2),=CL2'KY' IS THIS A VALID KEY PTR V0016 01770000
BNE CMSRET NO, RETURN WITH ERROR CODE V0016 01771000
LH R15,KEYTABLE+8 GET POINTER TO KEYS V0016 01772000
LH R0,KEYTABLE+4 GET FCBXTENT V0016 01773000
STH R0,FCBXTENT SET FCBXTENT V0016 01774000
AH R0,FCBCOUT POINT TO EOF RECORD V0016 01775000
AH R0,ONEBIN POINT TO KEYS V0016 01776000
STH R0,DATAEND+2 SET END OF DATA NO. V0016 01777000
LR R6,R7 USE TABLE LENGTH FOR BLKSI V0016 01778000
TM DCBRECFM,VAR IS RECFM FIXED V0016 01779000
BNO NOTEMP YES, DON'T USE TEMP FILE V0016 01780000
STH R15,DATAEND+2 SET PTR TO KEYS V0016 01781000
TM IOBIOFLG,IOBIN IS THIS A READ V0016 01782000
BNO SETFORRD NO, SAVE KEY TBLS V0016 01783000
MVC KEYFORM(1),FCBFORM SET FORMAT OF KEY TBLS V0016 01784000
STH R15,DATAEND+2 SET PTR TO KEYS V0016 01785000
NOTEMP MVC KEYNAME(8),FCBDSNAM READ KEYS IN DATA FILE V0016 01786000
B ZEROTBL RETURN TO DMSSBD V0016 01787000
SETFORRD N R15,HALFWORD CLEAR 1ST HALF EOF POINT V0016 01788000
STH R15,FCBITEM POINT TO KEYS 01789000
BCTR R15,R0 01790000
SH R15,FCBCOUT SET PTR TO LAST DATA ITEM 01791000
TM DCBRECFM,VAR IS RECFM FIXED V0016 01792000
BNO SETTBLNO YES, CONTINUE V0300 01793000
ST R15,DATAEND SAVE END OF DATA PTR 01794000
B GOMOVE MOVE KEYS V0300 01795000
SETTBLNO MVC KEYTBLNO(2),DATAEND+2 SET START OF KEY TABLE V0300 01796000
GOMOVE LR R0,R6 SET BUFFER LENGTH P3056 01797000
BAL R2,MOVEKEYS GO MOVE KEYS P3056 01798000
LTR R1,R3 WAS REG 3 ZERO 01799000
BZ ZEROTBL YES, THEN WE'RE THROUGH 01800000
BAL R4,UPDTDSK GO UPDATE DIRECTORY 01801000
ZEROTBL XC KEYTBLNO(2),KEYTBLNO CLEAR KEY TABLE NO. V0016 01802000
B CMSCLEAR RETURN 01803000
DROP R5 01804000
EJECT @VA04475 01805000
*********************************************************************** 01806000
* 01807000
* STOW 01808000
* USED TO UPDATE A PDS DIRECTORY 01809000
* CONTENTS OF R0 AND R1 DETERMINE ACTION TO BE TAKEN 01810000
* 01811000
*********************************************************************** 01812000
SPACE 01813000
SVC21 EQU * 01814000
LTR R1,R1 IS A DELETE OR ADD SPECIFIED 01815000
BL CKREPLAC NO, NEITHER IS SPECIFIED 01816000
LTR R0,R0 IS A DELETE SPECIFIED 01817000
BL DELETE YES 01818000
LA R14,ADD SET UP FOR ADD 01819000
FINDMEM LPR R9,R0 GET ADDRESS OF MEMBER 01820000
LPR R2,R1 GET DCB ADDRESS 01821000
L R8,DCBDEBAD GET ADDR OF DEB 01822000
SH R8,=AL2(IHADEB-FCBINIT) GET ADDR OF FCB 01823000
B FINDD FIND MEMBER 01824000
SPACE 2 01825000
CKREPLAC LTR R0,R0 IS CHANGE SPECIFIED 01826000
BL CHANGE YES 01827000
REPLAC BAL R14,FINDMEM FIND MEMBER 01828000
USING TEMPSPC,R14 @V305665 01829000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01830000
MVI R15CODE,X'00' 01831000
CH R15,FOURBIN CHECK FOR ERRORS 01832000
BH STOWERR I/O ERROR 01833000
BL NOTEITEM NO ERRORS 01834000
MVI R15CODE,X'08' SET ERROR CODE 01835000
ADDREPL LR R3,R9 SAVE MEMBER PTR 01836000
LA R9,ZEROBIN FIND ENTRY SPACE 01837000
BAL R14,FINDD CALL FINDD 01838000
LR R9,R3 RESTORE MEMBER PTR 01839000
NOTEITEM LH R4,FCBITEM GET FCBITEM 01840000
N R4,HALFWORD 01841000
AH R4,FCBCOUT 01842000
LA R1,4(R4) SET FOR MAX CK 01843000
LH R7,CORESIZE GET CORESIZE 01844000
LR R3,R7 GET CORESIZE 01845000
TM 11(R9),X'80' IS THIS AN ALIAS STOW @V201122 01846000
BO CKSPACE GO GET ENTRY SPACE @V201122 01847000
SR R6,R6 01848000
D R6,PDSBLKSI GET SIZE OF PDS IN BLKS 01849000
AR R1,R7 ADD TO CURRENT ITEM PTR 01850000
SR R7,R7 GET NO. OF NEW BLKS ADDED 01851000
IC R7,NEWBLKS 01852000
AR R1,R7 ADD NO. OF NEW BLKS 01853000
C R1,MAXSIZE IS FILE FULL 01854000
BNL TOBIGERR YES 01855000
CH R4,DIRPTR SHOULD DIRECTORY MOVE UP? 01856000
BNH CKSPACE NO, CONTINUE 01857000
STH R4,DIRPTR SAVE NEW DIRECTORY PTR 01858000
CKSPACE LTR R15,R15 WAS ENTRY SPACE FOUND? 01859000
BZ ADDENTRY YES 01860000
BAL R10,ADPDSBLK NO 01861000
ADDENTRY MVC 0(8,R5),0(R9) ADD MEMBER NAME 01862000
LA R14,STOWERR SET RETURN FOR BADPDS 01863000
CLC DIRNAME(6),MACLIB IS THIS A 1.0 MACLIB 01864000
BNE BADPDS NO, THEN PRINT ERR MSG 01865000
TM 11(R9),X'80' IS ALIAS BIT SET 01866000
BNO SETNAME NO, WRITE EOF INDICATOR 01867000
MVI 10(R5),0 ZERO THIS BYTE 01868000
MVI 11(R5),X'80' SET ALIAS BYTE 01869000
MVC 8(2,R5),9(R9) SET MEMBER ITEM NO. 01870000
B STOWRET RETURN TO CALLER 01871000
SETNAME MVC 8(2,R5),DCBRELAD+1 FILL IN ITEM NO. 01872000
MVC 8(3,R9),DCBRELAD SET TTR IN USER STOW LIST 01873000
MVI CHNGBYTE,X'03' SET CHANGE BYTE 01874000
LA R1,FCBOP GET ADDR OF PLIST 01875000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01876000
MVC FEOF,EOF MOVE EOF IND. TO BUFFER @V305665 01877000
LA R14,FEOF GET ADDRESS OF FEOF @V305665 01878000
ST R14,FCBBUFF SAVE FOR WRBUF @V305665 01879000
L R15,AWRBUF WRITE /* TO 01880000
BALR R14,R15 INDICATE END OF FILE 01881000
BNZ STOWERR CHECK FOR ERRORS 01882000
OI DCBCIND2,X'80' TURN ON STOW BIT @VA04367 01883000
STH R4,FCBITEM UPDATE ITEM NO. 01884000
MVC DCBRELAD+1(2),FCBITEM SET POINTER FOR NEXT MEMBER 01885000
SH R4,FCBCOUT COMPUTE MEMBER SIZE 01886000
SH R4,8(R5) 01887000
STH R15,10(R5) ZERO ALIAS BYTE 01888000
STOWRET EQU * @V305665 01889000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01890000
IC R15,R15CODE GET RETURN CODE @V305665 01891000
B CMSRET RETURN TO USER 01892000
SPACE 2 01893000
ADPDSBLK LH R7,PDSBLKSI GET PDSBLKSI 01894000
LA R0,11(R7) ADD CONTROL WORD 01895000
SRL R0,3 GET NO. OF DOUBLE WORDS 01896000
DMSFREE DWORDS=(0),TYPCALL=BALR CALL FREE ROUTINE @VM03083 01897000
SR R3,R3 GET NO. OF NEW BLKS 01898000
IC R3,NEWBLKS 01899000
LA R3,1(R3) ADD ONE TO NO. OF BLKS 01900000
STC R3,NEWBLKS SAVE NO. OF NEW BLKS 01901000
ST R1,0(R5) ADD BLOCK TO DIRECTORY 01902000
LR R5,R1 SET UP TO 01903000
LA R7,4(R1,R7) ZERO OUT THE 01904000
CLEAR LA R6,256 GET NO. 256 01905000
SR R1,R6 SUBTRACT 256 01906000
SR R7,R6 SUBTRACT 256 01907000
B BXLE NEW BLOCK 01908000
EXECUTE XC 0(256,R1),0(R1) CLEAR 256 BYTES 01909000
BXLE BXLE R1,R6,EXECUTE 01910000
AR R7,R6 GET END OF TABLE 01911000
SR R7,R1 01912000
BCR 13,R10 BNP NO, RETURN 01913000
BCTR R7,R0 SUBTRACT ONE 01914000
EX R7,CLEARBLK CLEAR EXTRA BYTES 01915000
BCR 15,R10 RETURN 01916000
SPACE 2 01917000
DELETE BAL R14,FINDMEM FIND MEMBER 01918000
AR R15,R15 ANY ERRORS? 01919000
BNZ CMSRET YES, RETURN 01920000
XC 0(12,R5),0(R5) CLEAR ENTRY 01921000
B CMSCLEAR RETURN TO THE USER 01922000
SPACE 2 01923000
CHANGE BAL R14,FINDMEM FIND MEMBER 01924000
AR R15,R15 ANY ERRORS? 01925000
BNZ CMSRET YES RETURN 01926000
LR R3,R5 01927000
LA R9,8(R9) SEE IF NEW MEMBER 01928000
BAL R14,FINDD IS ALREADY IN DIRECTORY 01929000
LTR R15,R15 ANY ERRORS? 01930000
BZ ADDERR YES, RETURN 01931000
MVC 0(8,R3),0(R9) CHANGE ENTRY 01932000
B CMSCLEAR RETURN TO THE USER 01933000
SPACE 2 01934000
ADD EQU * @V305665 01935000
L R14,OSTEMP GET SPACE ADDRESS @V305665 01936000
MVI R15CODE,RC0 WAS MEMBER IN DIRECTORY? @V305066 01937000
CH R15,FOURBIN IF NOT, 01938000
BE ADDREPL CONTINUE 01939000
BH STOWERR OTHERWISE RETURN ERROR 01940000
ADDERR LA R15,4 RETURN ADD ERROR CODE 01941000
B CMSRET 01942000
SPACE 2 01943000
TOBIGERR LA R15,12 DIRECTORY FULL ERROR CODE 01944000
B CMSRET 01945000
STOWERR LA R15,16 I/O ERROR CODE 01946000
B CMSRET 01947000
DROP R14 @V305665 01948000
EJECT 01949000
* CONSTANTS 01950000
SPACE 1 01951000
DS 0F 01952000
ZEROBIN DC XL8'00' 01953000
ONEBIN DC XL2'0001' 01954000
FOURBIN DC XL2'0004' 01955000
EIGHT DC XL2'0008' 01956000
NINE DC XL2'0009' 01957000
TWELVE DC F'12' 01958000
WSTATE DC CL8'STATE' @V305665 01959000
TEMP DC CL8'$PDSTEMP' 01960000
KEYTEMP DC CL8'$KEYTEMP' 01961000
SAVEFILE DC CL8'$KEYSAVE' 01962000
MACLIB DC CL6'DMSLIB' 1.0 LIBRARY INDICATOR 01963000
SPACE 1 01964000
HEX48 DC XL2'0048' @VM03083 01965000
MAXSIZE DC F'65535' 01966000
HALFWORD EQU MAXSIZE 01967000
FF EQU X'FF' @V305066 01968000
TWO EQU 2 @V305066 01969000
HEX00 EQU X'00' @V305066 01970000
ERR8 EQU 8 @V305066 01971000
ERR36 EQU 36 WRITE TO R/O DISK ERROR @VA09243 01971500
RC0 EQU 0 @V305066 01972000
CON1 EQU 1 @V305066 01973000
P EQU C'P' @V305066 01974000
RC4 EQU 4 @V305066 01975000
VSAMIND EQU X'08' @V305066 01976000
HEXF0 EQU X'F0' @V305066 01977000
CLEARBLK XC 0(0,R1),0(R1) 01978000
CLEARTTR XC 8(R0,R9),8(R9) 01979000
EOF DC XL4'61FFFF61' EOF MARKER 01980000
WFINIS DC CL8'FINIS' 01981000
SEARCH DS 0F SVC SEARCH ARGUMENTS 01982000
DC A(SVCTABBG) 01983000
DC F'4' 01984000
DC A(SVCTABED) 01985000
SEARCH1 DS 0F VCON SEARCH ARGUMENTS @V305665 01986000
DC A(SVCVCNBG) @V305665 01987000
DC F'4' @V305665 01988000
DC A(SVCVCNED) @V305665 01989000
TEXT3 DC AL4(ERRMSG3) @V305665 01990000
EJECT @VA04475 01991000
********************************************************************* 01992000
* 01993000
* RETURN TO CMS 01994000
* 01995000
* 01996000
CMSCLEAR SR R15,R15 ERROR CODE = 0 01997000
CMSRET ST R15,EGPR15 SET ERROR CODE IN SAVE AREA 01998000
RETRN EQU * @V305665 01999000
L R1,OSTEMP GET SPACE ADDRESS @V305665 02000000
USING TEMPSPC,R1 @V305665 02001000
L R14,SAVR14 GET RETURN REGISTER @V305665 02002000
ST R14,OSTEMP PRESERVE RETURN REGISTER, @VM03083 02003000
LA R0,TEMPLNT NUMBER OF DBL WORDS USED, @VM03083 02004000
DROP R1 NOW RETURN THE TEMPORARY SPACE @VM03083 02005000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR ... @VM03083 02006000
L R14,OSTEMP RECOVER THE RETURN REGISTER @VM03083 02007000
BR R14 02008000
SPACE 02009000
LTORG 02010000
EJECT 02011000
********************************************************************* 02012000
* 02013000
ORG SOSVCTR+4096 SETUP SECOND BASE REG 02014000
SOSVCT2 EQU * 02015000
USING SOSVCT2,R9 SECOND BASE REG 02016000
SPACE 02017000
********************************************************************** 02018000
SNAP EQU * 51-SNAP DUMP SPECIFIED CORE @VM03083 02019000
L R2,EGPR1 LOAD PLIST ADDR. @VA04475 02020000
L R2,4(R2) LOAD DCB ADDR. FROM PLIST @VA04475 02021000
CL R2,=4X'FF' IS IT AN ABEND FROM DMSSAB? @VA05383 02022000
* VA05383 02023000
BE ABDMP YES @VA05383 02024000
USING IHADCB,R2 @VA04475 02025000
TM DCBOFLGS,X'10' FILE OPEN ? @VA04475 02026000
BO CKFCB YES, CHECK FCB FOR DUMMY @VA04475 02027000
LA R15,4 SET RETURN CODE @VA04475 02028000
B CMSRET RETURN, RC=4, DCB NOT OPEN @VA04475 02029000
CKFCB L R8,DCBDEBAD LOAD DEB ADDR. @VA04475 02030000
SH R8,=AL2(IHADEB-FCBINIT) BACK UP TO FCB START @VA04475 02031000
USING FCBSECT,R8 @VA04475 02032000
CLI FCBDEV,FCBDUM THIS DEVICE DUMMY ? @VA04475 02033000
BE CMSCLEAR YES, DON'T DO THE DUMP @VA04475 02034000
ABDMP EQU * @VA05383 02035000
LA R10,DUMPLIST GET ADDR OF DUMP PLIST @VM03083 02036000
LM R2,R7,0(R10) GET PLIST REGS @VM03083 02037000
MVC 0(64,R2),EGPR0 MOVE REGS TO DUMP AREA @VM03083 02038000
MVC LOWSAVE,0 MOVE LOW CORE TO DUMP AREA @VM03083 02039000
MVC 0(32,R6),EFPRS MOVE FLOATING REGS TO DUMP AREA @VM03083 02040000
MVI 0(R7),X'40' SET BLANK TO CLEAR TITLE @VA09674 02040600
MVC 1(131,R7),0(R7) CLEAR TITLE AREA @VA09674 02041200
MVC 10(4,R7),=CL4'ID= ' SETUP TITLE @VM03083 02042000
SR R5,R5 ZERO REG 5 @VM03083 02043000
IC R5,0(R1) GET ID NO. @VM03083 02044000
CVD R5,8(R10) CONVERT TO DECIMAL @VM03083 02045000
UNPK 14(2,R7),14(2,R10) PUT ID IN MSG @VM03083 02046000
OI 15(R7),X'F0' REPLACE SIGN BITS @VM03083 02047000
L R2,12(,R1) GET DUMP ADDRESSES @VM03083 02048000
LA R4,25 LIMIT 25 DUMPS PER SNAP @VM03083 02049000
LTR R2,R2 DUMP ADDRESSES SPECIFIED? @VM03083 02050000
BNZ SNAPDUMP YES, CONTINUE @VM03083 02051000
LA R4,1 ONLY DUMP ONCE @VM03083 02052000
SR R6,R6 START ADDR IS ZERO @VM03083 02053000
LA R7,164 ENDING ADDR IS 164 @VM03083 02054000
TM 3(R1),2 DUMP CORE SPECIFIED? @VM03083 02055000
BNO SETDMPAD NO, DUMP LOW CORE @VM03083 02056000
L R7,VMSIZE DUMP ALL CORE @VM03083 02057000
B SETDMPAD SET DUMP ADDRESSES @VM03083 02058000
SNAPDUMP LM R6,R7,0(R2) GET START AND END ADDR @VM03083 02059000
SETDMPAD EQU * @VM03083 02060000
SRL R6,2 ROUND DOWN TO FULLWORD @VM03083 02061000
SLL R6,2 @VM03083 02062000
LA R6,0(,R6) STRIP OFF HIGH ORDER BYTE @VM03083 02063000
LA R7,3(,R7) ROUND UP TO A FULLWORD @VM03083 02064000
SRL R7,2 @VM03083 02065000
SLL R7,2 @VM03083 02066000
STM R6,R7,8(R10) FILL START AND END ADDR @VM03083 02067000
LA R0,32 SET ADDR OF PSW TO BE PRINTED@VM03083 02068000
LR R1,R10 GET ADDR OF PLIST @VM03083 02069000
L R15,ADMPEXEC GET ADDR OF DUMP PROGRAM @VM03083 02070000
BALR R14,R15 BRANCH TO DUMP PROGRAM @VM03083 02071000
TM 4(R2),X'80' LAST SET OF ADDRESSES @VM03083 02072000
BO CMSCLEAR YES, RETURN @VM03083 02073000
LA R2,8(,R2) GET NEXT SET OF ADDRESSES @VM03083 02074000
BCT R4,SNAPDUMP CONTINUE DUMPING @VM03083 02075000
B CMSCLEAR OVER 25 DUMPS, RETURN @VM03083 02076000
EJECT @VA04475 02077000
SPIE EQU * SPEC PRG INTERPT EXECUTION @V305066 02078000
L R2,APIE GET ADDRESSS OF PICA @V305066 02079000
L R10,0(R2) GET ADDR OF PICA @V305066 02080000
ST R1,0(R2) INSET NEW PICA ADDR IN PIE @V305066 02081000
MVI 0(R2),HEX00 CLEAR PICA RESERVE BYTE @V305066 02082000
ST R10,EGPR1 RETURN OLD PICA ADDR @V305066 02083000
NI OLDPSW+4,HEXF0 CLEAR THE PROGRAM MASK @V305066 02084000
OC OLDPSW+4(1),0(R1) SET PROGRAM MASK IN USERS PSW @V305066 02085000
B RETRN RETURN @V305066 02086000
EJECT @VA04475 02087000
********************************************************************* 02088000
EXTRACT EQU * 40 - ZERO ANSWER AREA 02089000
* 02090000
* C(R1)=A(ANSWER AREA) 02091000
* 02092000
* C(R1+8)=FIELD BYTES 02093000
* 02094000
* THE NUMBER OF BITS SET IN THE FIELD BYTES DETERMAINS THE NUMBER 02095000
* OF FULLWORDS TO BE CLEARED IN THE ANSWER AREA. 02096000
* 02097000
SPACE 02098000
SR R5,R5 02099000
SR R4,R4 02100000
L R5,8(,R1) GET FIELD BYTES 02101000
SRL R5,21 INITIAL SHIFT FOR BITS NOT USED 02102000
EXTLOOP EQU * 02103000
LTR R5,R5 ANY BITS? 02104000
BZ DONE NO, NOTHING TO CLEAR 02105000
LA R14,CON1 INDICATE LOW ORDER BIT @V305066 02106000
NR R14,R5 IS BIT SET? @V305665 02107000
BZ BUMP BRANCH IF NOT @V305665 02108000
LA R4,1(,R4) YES, INCREMENT R4 02109000
BUMP EQU * 02110000
SRL R5,1 SHIFT 02111000
B EXTLOOP LOOP THROUGH FIRST BYTE 02112000
SPACE 02113000
DONE EQU * 02114000
SLL R4,2 MULTIPLY BY 4 02115000
LTR R4,R4 ANY BITS AT ALL? 02116000
BZ NOBITS NO, LETS EXIT 02117000
BCTR R4,0 DECREMENT BY 1 02118000
L R5,0(,R1) GET ANSWER AREA ADDRESS 02119000
EX R4,EXTCLEAR ZERO OUT ANSWER AREA 02120000
NOBITS EQU * 02121000
LA R15,4 SET RETURN CODE OF 4 02122000
B CMSRET RETURN 02123000
SPACE 02124000
EXTCLEAR XC 0(0,R5),0(R5) ZERO OUT ANSWER AREA 02125000
SPACE 02126000
EJECT 02127000
********************************************************************** 02128000
* 02129000
* FREEDBUF 02130000
* USED TO HANDLE FREEDBUF MACROES 02131000
* REG0=V(DECB) REG1=V(DCB) 02132000
*********************************************************************** 02133000
SPACE 02134000
SVC57 LR R3,R0 SET UP DSECT REGS @VM03203 02135000
LR R2,R1 @VM03203 02136000
L R15,=V(DMSSBDFR) GO TO FREDBUF @VM03203 02137000
BALR R4,R15 TO RETURN BUFFER @VM03203 02138000
B RETRN RETURN @VM03203 02139000
EJECT @VA04475 02140000
*********************************************************************** 02141000
* 02142000
* STAE 02143000
* USED TO HANDLE STAE MACROES 02144000
* REG0=ACTION CODE REG1=V(PARM LIST) 02145000
********************************************************************** 02146000
SPACE 02147000
USING PGMSECT,R3 @VM03203 02148000
SVC60 L R3,APGMSECT GET ADDR OF PGMSECT @VM03203 02149000
LA R3,SCBPTR GET ADDR OF SCB POINTER @VM03203 02150000
DROP R3 @VM03203 02151000
LR R4,R1 SAVE R1 @VM03203 02152000
L R1,0(R3) @VM03203 02153000
CH R0,FOURBIN CHECK OPTION CODE @VM03203 02154000
BH OVERLAY OVERLAY SCB @VM03203 02155000
LA R0,TWO GET SCB LEN IN DWORDS @VM03203 02156000
BE CANCEL CANCEL SCB @VM03203 02157000
DMSFREE DWORDS=(0),TYPE=NUCLEUS,TYPCALL=BALR @VM03203 02158000
MVC 0(4,R1),0(R3) CHAIN SCB'S @VM03203 02159000
ST R1,0(R3) FILL IN SCB PTR @VM03203 02160000
OVERLAY MVC 4(8,R1),0(R4) FILL IN STAE PARAMETERS @VM03203 02161000
MVI 12(R1),HEX00 CLEAR FLAG BYTE @VM03203 02162000
B CMSCLEAR RETURN @VM03203 02163000
CANCEL LA R15,ERR8 SET ERROR CODE @VM03203 02164000
LTR R1,R1 IS THERE AN SCB @VM03203 02165000
BZ CMSRET NO, THAN RETURN @VM03203 02166000
MVC 0(4,R3),0(R1) DELETE SCB @VM03203 02167000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR @VM03203 02168000
B CMSCLEAR RETURN @VM03203 02169000
EJECT 02170000
***************************************************************@VA04475 02171000
RESTORE EQU * 17-RESTORE IOB @VA04475 02172000
* @VA04475 02173000
TRKBAL EQU * 25-TRKBAL @VA04475 02174000
* @VA04475 02175000
CHAP EQU * 44-CHANGE PRIORITY @VA04475 02176000
* C(R1)=A(TCB LOCATION), C(R0)=PRIORITY VALUE @VA04475 02177000
* @VA04475 02178000
CHKPT EQU * CHECKPOINT RESTART @VA04475 02179000
* @VA04475 02180000
DEQ EQU * 48-DEQUEUE A TASK @VA04475 02181000
* @VA04475 02182000
DETACH EQU * 62-DETACH A MODULE FROM TASK QUEUE @VA04475 02183000
* C(R1)=A(TCB LOCATION) @VA04475 02184000
* @VA04475 02185000
ENQ EQU * 56-ENQUEUE ADDITIONAL TASK @VA04475 02186000
* @VA04475 02187000
B CMSCLEAR ALL OF ABOVE ARE EFFECTIVE NO-OP @VA04475 02188000
* @VA04475 02189000
FEOV EQU * FORCED END OF VOLUME @VA04475 02190000
LA R15,4 SET ERROR CODE @VA04475 02191000
B CMSRET RETURN WITH ERROR CODE @VA04475 02192000
* @VA04475 02193000
EJECT @VA04475 02194000
******************************************************************* 02195000
IDENTIFY DS 0H 41-ASSIGN ADDITIONAL ENTRY POINTS 02196000
* C(R0)=A(CL8'LOAD MODULE'), C(R1)=A(ENTRY POINT) 02197000
OI OSSFLAGS,OSRESET INDICATE OS SIM. ENTERED @V1D1705 02198000
LR R4,R0 SAVE INPUT REGS @V1D1705 02199000
LR R5,R1 @V1D1705 02200000
DMSFREE DWORDS=15,TYPCALL=BALR @VM03083 02201000
L R0,LINKSTRT CHAIN IDENTIFY RB ON LOAD RB CHAI@V1D1705 02202000
ST R1,LINKSTRT @V1D1705 02203000
XC 0(120,R1),0(R1) CLEAR REQ. BLK. @VM03203 02204000
ST R0,0(R1) CHAIN BLOCKS @VA02596 02205000
MVC 12(8,R1),0(R4) MOVE IDENTIFIED NAME TO RB @V1D1705 02206000
ST R5,28(R1) SET IDENTIFIED ADDR. AS ENTRY POI@V1D1705 02207000
B CMSCLEAR RETURN @V1D1705 02208000
EJECT @VA04475 02209000
*********************************************************************** 02210000
*STAX (SVC 96) 02211000
SPACE 02212000
STAX L R2,0(0,R1) GET EXIT ADDRESS 02213000
LTR R2,R2 WAS AN EXIT ADDRESS SPECIFIED 02214000
BZ STXCLR NO, CLEAR HIGHEST EXIT 02215000
OI OSSFLAGS,OSRESET INDICATE CLEANUP NEEDED 02216000
LA R0,28 YES, GET AN EXIT ELEMENT @V1D1709 02217000
LR R4,R1 PROTECT PARAMETER REG. 02218000
DMSFREE DWORDS=(0),TYPCALL=BALR @VM03083 02219000
USING CMSTAXE,R1 @V1D1709 02220000
L R3,TAXEADDR CHAIN NEW ELEMENT 02221000
ST R1,TAXEADDR AT BEGGINNING OF 02222000
ST R3,TAXELNK QUEUE @V1D1709 02223000
ST R2,TAXEEXIT SET EXIT ADDR. IN ELEMENT @V1D1709 02224000
MVC 0(4,R1),STAXPSW MOVE IN LEFT HALF OF PSW FIELD 02225000
MVC TAXEDEF(4),16(R4) MOVE IN USADDR + DEFER IND. @V1D1709 02226000
B CMSCLEAR RETURN 02227000
DROP R1 @V1D1709 02228000
USING CMSTAXE,R2 @V1D1709 02229000
STXCLR L R2,TAXEADDR GET HIGHEST ELEMENT 02230000
LTR R1,R2 IS THERE ONE 02231000
BZ STXERR NO 02232000
L R3,TAXELNK GET POINTER TO NEXT TAXE @V1D1709 02233000
ST R3,TAXEADDR MAKE NXT=1ST 02234000
LA R0,28 FREE THIS EXIT ELEMENT @V1D1709 02235000
DMSFRET DWORDS=(0),LOC=(1),TYPCALL=BALR @VM03083 02236000
B CMSCLEAR RETURN 02237000
STXERR LA R15,8 RETURN CODE 02238000
B CMSRET 02239000
STAXPSW DC X'FF040000' LEFT 1/2 OF EXIT PSW 02240000
DROP R2 @V1D1709 02241000
EJECT @VA04475 02242000
******************************************************************* 02243000
SYNAD DS 0H 68-SYNAD ERROR MESSAGES 02244000
* R1=A(DCB) R0=A(DECB) R15=X'ACCESS METHOD CODE',AL3(0) 02245000
USING IHADCB,R2 02246000
USING IHADECB,R3 02247000
LR R2,R1 SETUP DCB REG 02248000
LR R3,R0 SETUP DECB REG 02249000
CLI EGPR15,X'FF' SYNADRLS? 02250000
BE SYNADRLS YES. 02251000
SYNADAF EQU * PREPARE ERROR MESSAGE 02252000
LA R0,200 GET SAVE AREA PLUS MESSAGE BUFFER 02253000
SR R1,R1 02254000
GETMAIN R,LV=(R0) 02255000
L R5,EGPR13 GET A(USER SAVE AREA) 02256000
ST R5,4(,R1) SET A (PREVIOUS SAVE AREA) 02257000
ST R1,8(,R5) SAVE A(NEXT SAVE AREA) 02258000
ST R1,EGPR13 PASS BACK NEWEST SAVEAREA 02259000
LA R1,72(,R1) POINT TO A(MESSAGE BUFFER) 02260000
XC 0(8,R1),0(R1) CLEAR BDW AND RDW 02261000
MVI 8(R1),X'40' BLANK OUT BUFFER 02262000
MVC 9(119,R1),8(R1) 02263000
LA R4,124 GET RDW 02264000
STH R4,4(,R1) STORE RDW IN BUFFER 02265000
MVC 44(31,R1),ERRMSG1 MOVE IN STANDARD MSG 02266000
USING IHADCB,R2 02267000
MVC 55(6,R1),=C'OUTPUT' 02268000
TM EGPR1,X'40' OUTPUT ERROR? 02269000
BO DCBNAME YES, GO SET DDNAME 02270000
MVC 55(6,R1),=C'INPUT ' 02271000
DCBNAME L R8,DCBDEBAD GET ADDR OF DEB 02272000
SH R8,=AL2(IHADEB-FCBINIT) GET ADDR OF FCB 02273000
IC R4,DECSDECB+3 GET ERROR CODE V0300 02274000
USING TEMPSPC,R14 @V305665 02275000
L R14,OSTEMP GET SPACE ADDRESS @V305665 02276000
CVD R4,DHOUR CONVERT TO DECIMAL 02277000
UNPK 68(3,R1),DHOUR+5(3) 02278000
DROP R14 @V305665 02279000
OI 70(R1),C'0' RESET SIGN BITS 02280000
MVC 75(8,R1),FCBDD GET NAME OF DCB 02281000
MVI 83(R1),C',' SET DDNAME DELIMITER 02282000
TM EGPR1,X'C0' WAS THIS I/O ERROR 02283000
BNZ SYRETRN YES, THEN RETURN 02284000
MVC 55(6,R1),8(R1) RESET I/O INDIC BACK TO BLNK 02285000
MVC 68(3,R1),8(R1) SAME WITH ERROR CODE 02286000
SYRETRN ST R1,EGPR1 SEND BACK R1=A(MESSAGE BUFFER) 02287000
B SVC68RET RETURN TO CALLER 02288000
* 02289000
SYNADRLS DS 0H 68-RELEASE SYNAD MESSAGE BUFFER 02290000
L R1,EGPR13 GET A(SYNAD SAVEAREA) 02291000
LA R0,200 BYTE COUNT 02292000
L R4,4(,R1) GET A(PREVIOUS SAVEAREA) 02293000
ST R4,EGPR13 RESET PREV ST AREA 02294000
FREEMAIN R,LV=(R0),A=(R1) 02295000
XC 8(4,R4),8(R4) ZERO SAVE AREA PTR 02296000
SVC68RET SR R15,R15 ZERO REG 15 02297000
ST R15,EGPR0 ZERO REG 0 IN SAVE AREA 02298000
B RETRN RETURN TO CALLER 02299000
* 02300000
EJECT @VA04475 02301000
********************************************************************** 02302000
SPACE 02303000
STIMER EQU * 02304000
DIN EQU X'30' DECIMAL TIME INTERVAL 02305000
BIN EQU X'10' BINARY TIME INTERVAL 02306000
TUI EQU X'F0' TIMER UNIT TIME INTERVAL 02307000
TOD EQU X'70' TIME OF DAY TIME INTERVAL 02308000
REAL EQU X'03' REAL OPTION 02309000
WAIT EQU X'01' WAIT OPTION 02310000
* R1 =V(TIME INTERVAL) 02311000
* R0 =V(EXIT ADDRESS) 02312000
* 02313000
USING EXTSECT,R4 02314000
TM EGPR0,REAL REAL OPTION SPECIFIED 02315000
BO CKTIMUNT YES, CONTINUE 02316000
TM EGPR0,WAIT IS WAIT OPTION SPECIFIED 02317000
BO CMSCLEAR YES, TREAT AS NOP 02318000
CKTIMUNT L R5,EGPR0 GET ADDR OF EXIT ROUTINE 02319000
L R1,0(R1) GET TIME SPECIFICATION 02320000
TM EGPR0,TUI TIME IN TIMER UNITS 02321000
BZ TINT YES, BRANCH @VA15155 02322000
DECIM TM EGPR0,TOD-BIN NON BINARY OPTIONS ON 02325000
BZ BINT NO, MUST BE BINARY 02326000
L R1,EGPR1 GET ADDR OF TIME 02327000
CONVERT EQU * CONVERT TO BINARY V0277 02328000
USING TEMPSPC,R8 @V305665 02329000
L R8,OSTEMP GET SPACE ADDRESS @V305665 02330000
PACK WORK(8),4(4,R1) PACK HUNDREDTHS OF SECONDS 02331000
CVB R4,WORK CONVERT TO BINARY 02332000
PACK WORK(8),2(2,R1) PACK MINUTES 02333000
CVB R7,WORK CONVERT TO BINARY 02334000
MH R7,=H'6000' CONVERT TO HUNDREDTHS 02335000
AR R4,R7 ADD TO TOTAL 02336000
PACK WORK(8),0(2,R1) PACK HOURS 02337000
CVB R7,WORK CONVERT TO BINARY 02338000
DROP R8 @V305665 02339000
M R6,=F'360000' CONVERT TO HUNDREDTHS 02340000
AR R4,R7 ADD TO TOTAL 02341000
C R1,EGPR1 CALL FROM TIME? V0277 02342000
BCR 7,R14 YES, RETURN TO TIME V0277 02343000
TM EGPR0,TOD-DIN IS TIME OF DAY BIT ON 02344000
BNO DINT NO, THEN OPTION= DECIMAL 02345000
TIME BIN 02346000
SR R4,R0 GET TIME TILL INTERRUPT 02347000
BP DINT IF INTERVAL NOT EXPIRED, CONTINUE 02348000
L R4,TIMEUNIT IF EXPIRED, SET TO 1/100 SEC 02349000
DINT LR R1,R4 SETUP TO SET TIMER 02350000
BINT MH R1,TIMEUNIT+2 CONVERT TO TIMER UNITS 02351000
TINT EQU * @VA15155 02351100
CL R1,MAXTIME IS TIME <= MAX VALUE @VA15155 02351200
BNH TIMEOK YES, TIME OK @VA15155 02351300
L R1,MAXTIME NO, SET TO MAX VALUE @VA15155 02351400
TIMEOK EQU * @VA15155 02351500
SLL R1,1 MULTIPLY BY 2 V0416 02352000
STIMRETN ST R1,TIMER SET TIMER 02353000
L R4,AEXTSECT GET DSECT ADDR 02354000
ST R5,STIMEXIT SET EXIT ROUTINE ADDR 02355000
MVI STIMEXIT,1 INDICATE STIMER HAS BEEN ISSUED V0206 02356000
B CMSCLEAR RETURN TO CALLER 02357000
TIMEUNIT DC A(10000/26) 100 TH SEC IN TIMER UNITS V0416 02358000
MAXTIME DC X'7FFFFF00' MAX VALUE IN TIMER UNITS @VA15155 02358500
EJECT @VA04475 02359000
****************************************************************** 02360000
SPACE 02361000
TTIMER EQU * 02362000
* R1 = CANCEL FLAG 02363000
* R0 = RETURN REG FOR REMAINING TIME 02364000
L R4,AEXTSECT GET DSECT ADDR 02365000
SR R0,R0 ZERO REG 0 02366000
C R0,STIMEXIT WAS STIMER SPECIFIED 02367000
BE SETR0 NO, RETURN ZERO TIME 02368000
L R0,TIMER GET REMAINING TIME 02369000
SRL R0,1 CONVERT TO OS TIMER UNITS V0206 02370000
SETR0 ST R0,EGPR0 SET R0 IN SAVE AREA 02371000
LTR R1,R1 WAS CANCEL SPECIFIED 02372000
BZ CMSCLEAR NO, RETURN 02373000
SR R1,R1 YES, CLEAR TIMER EXIT ADDR 02374000
ST R1,STIMEXIT TIMER EXIT ADDR=0 02375000
CLI TIMCHAR,0 IS BLIP OFF @VA04419 02376000
BE NOBLIP YES, THEN SET TIMER TO HIGH VALUE@VA04419 02377000
MVC TIMER(4),=X'000258F6' SET TIMER FOR 2 SECONDS @VA04419 02378000
B CMSCLEAR RETURN @VA04419 02379000
NOBLIP MVC TIMER(4),=X'7FFFFF00' SET TIMER TO HIGH VALUE @VA04419 02380000
B CMSCLEAR RETURN TO CALLER 02381000
DROP R4 02382000
EJECT 1 02383000
USING TEMPSPC,R8 @V305665 02384000
********************************************************************* 02385000
TIME EQU * 11-PROCURE REAL TIME & DATE 02386000
* MODE FLAG: BITS X'03'; B'10'=DEC B'01'=BIN B'00'=TU 02387000
DEC EQU X'02' "HHMMSS00" 02388000
* GET REAL TIME-OF-DAY & DATE 02389000
L R8,OSTEMP GET SPACE ADDRESS @V305665 02390000
STC 1,FLAG SAVE TIME-FORMAT CODE 02391000
LA R1,DIAGTIME GET ADDR OF TIME BUFFER V0277 02392000
DC X'8310000C' DIAGNOSE FOR TIME V0277 02393000
MVC TIMBUF(24),CURRDATE MOVE INTO WORKING BUFFER 02394000
XC TIMEWK1(TIMEWK2-TIMEWK1),TIMEWK1 CLEAR WORK REGION 02395000
* PACK CHRONOLOGICALLY ACQUIRED DATA 02396000
SR R0,R0 02397000
MVI TIMDAY+2,X'C0' 02398000
PACK ZEIT(2),TIMDAY(3) HOURS: "HH" 02399000
MVI TIMDAY+5,X'C0' 02400000
PACK ZEIT+1(2),TIMDAY+3(3) MINUTES: "MM" 02401000
MVI TIMDAY+8,X'C0' 02402000
PACK ZEIT+2(2),TIMDAY+6(3) SECONDS: "SS" 02403000
* 02404000
MVI TDATE+2,X'C0' 02405000
PACK TAG+1(2),TDATE(3) MONTH: "MM" 02406000
MVI TDATE+5,X'C0' 02407000
PACK TAG+2(2),TDATE+3(3) DAY: "DD" 02408000
MVI TDATE+8,X'C0' 02409000
PACK TAG+3(2),TDATE+6(3) YEAR: "YY" 02410000
* SET DATE INTO REG 1: "00 YY DD D+" 02411000
IC R0,TAG+3 02412000
SLL R0,16 02413000
AH R0,SIGN 02414000
ST R0,DATE 02415000
H12 SRL R0,12 02416000
AH R0,SIGN 02417000
ST R0,YEAR 02418000
DP YEAR(4),FOUR(2) 02419000
SR R1,R1 02420000
IC R1,TAG+1 02421000
IC R1,TRTABL(R1) 02422000
LH R0,NTABL(R1) GET MONTH INCREMENT 02423000
STH R0,DAY AND SAVE 02424000
CLI YEAR+3,X'0C' IS IT A LEAP YEAR? 02425000
BH NOLEAP NO, BRANCH 02426000
CH R1,FOURBIN IF MONTH > FEB. ADD 1 TO DATE V0277 02427000
BL JANFEB NO 02428000
AP DAY(2),ONE(2) YES, ADD ONE DAY TO DATE PAST FEB 02429000
JANFEB EQU * 02430000
NOLEAP AP DATE(4),DAY(2) 02431000
MVI TAG+3,X'C0' 02432000
LH R0,TAG+2 02433000
SRL R0,4 RIGHT SHIFT FOR ADD DECIMAL 02434000
STH R0,DAY 02435000
AP DATE(4),DAY(2) 02436000
OI DATE+3,X'0F' SET PRINTABLE SIGN CHARACTER 02437000
MVC EGPR1,DATE MOVE DATE TO R1 SAVEAREA 02438000
CLI FLAG,2 DECIMAL TIME SPECIFIED V0277 02439000
BNE TIMBIN GET BINARY TIME V0277 02440000
* DEC: "HHMMSS00" 02441000
NI ZEIT+3,X'00' CLEAR BYTE 02442000
MVC EGPR0,ZEIT MOVE TIME TO SAVEAREA 02443000
B CMSCLEAR 02444000
TIMBIN MVC TIMDAY(8),CURRDATE+8 RESET TIME OF DAY V0277 02445000
MVC TIMDAY+2(2),TIMDAY+3 SETUP FOR CONVERT V0277 02446000
MVC TIMDAY+4(2),TIMDAY+6 SETUP FOR CONVERT V0277 02447000
MVC TIMDAY+6(2),=XL2'F0F0' SET HUNDRETHS OF SECONDS V0277 02448000
LA R1,TIMDAY USE STIMER FOR CONVERT V0277 02449000
BAL R14,CONVERT CONVERT TO BINARY V0277 02450000
LR R5,R4 SAVE BINARY TIME V0277 02451000
CLI FLAG,1 BINARY FLAG ON V0277 02452000
BE TIMRET YES RETURN TO CALLER V0277 02453000
MH R4,TIMEUNIT+2 CONVERT TO TIMER UNITS V0277 02454000
CLI FLAG,3 MIC OPTION SPECIFIED V0277 02455000
BNE TIMRET NO, RETURN TO CALLER V0277 02456000
M R4,=F'409600' GET MICROSECOND IN 51ST BIT V0277 02457000
L R1,EGPR0 GET RETURN ADDR FOR TIME V0277 02458000
STM R4,R5,0(R1) SET TIME IN RETURN ADDR V0277 02459000
B CMSCLEAR RETURN TO CALLER V0277 02460000
TIMRET ST R4,EGPR0 SET TIME IN REG 0 V0277 02461000
B CMSCLEAR RETURN TO CALLER V0277 02462000
* 02463000
* NEEDED CONSTANTS, WORK AREAE, & TIMER VARIABLES 02464000
* 02465000
* DISPLACEMENT PER MONTH INTO "DAY OF YEAR" TABLE. 02466000
TRTABL DC X'0C000204' V0277 02467000
DC X'06080A0C' 02468000
DC X'0E10' 02469000
ONE DC PL2'1' 02470000
FOUR DC PL2'4' 02471000
SIGN DC X'000F' PRINTABLE SIGN 02472000
DC X'121416' 02473000
* CUMULATIVE "DAY-OF-YEAR" PER MONTH TABLE 02474000
NTABL DS 0H 02475000
DC X'000C031C' 02476000
DC X'059C090C' 02477000
DC X'120C151C' 02478000
DC X'181C212C' 02479000
DC X'243C273C' 02480000
DC X'304C334C' 02481000
DROP R8 @V305665 02482000
EJECT 1 02483000
USING FCBSECT,R8 @V305665 02484000
********************************************************************** 02485000
WTO EQU * 35-WRITE-TO-OPERATOR-/-WITH REPLY 02486000
* WTO: AL2(L'MSG); 2X'FLAGS'; MESSAGE; SVC 35. 02487000
* WTOR: AL1(L'REPLY); AL3(REPLY BUFFER); A(ECB); AL2(L'MSG); 02488000
* 2X'FLAGS'; MESSAGE; SVC 35. 02489000
* 02490000
MVI OSIOTYPE,C'N' INDICATE "WTO" 02491000
LR 2,1 SAVE R1 FOR REPLY. 02492000
CLI 0(R1),0 DETERMINE: WTO, OR WTOR? 02493000
BE SUIT05 YES 02494000
MVI OSIOTYPE,C'M' INDICATE "WTOR" 02495000
LA 1,8(,1) 02496000
SUIT05 LH 3,0(,1) 02497000
SH R3,HAL4+2 TR 02498000
STH R3,CONWRCNT STORE WRITE COUNT 02499000
HAL4 LA R1,4(R1,R0) C(R1)=LINE OF PRINT ADRESS TR 02500000
ST R1,CONWRBUF SET A(OUTPUT BUFFER) 02501000
* 02502000
LA R1,WAITLIST WAIT FOR CLEAR TYPEOUT 02503000
SVC X'CA' (JAS -- 23 AUGUST 1967) 02504000
* 02505000
LA R1,CONWRITE 02506000
SVC X'CA' 02507000
DC AL4(*+4) 02508000
CLI 0(R2),0 IS IT A WTO? @VA01757 02509000
BE WTORET YES, RETURN @VA01757 02510000
LA R1,CONREAD READ THE REPLY 02511000
SVC X'CA' 02512000
DC AL4(*+4) 02513000
L R5,0(,R2) GET A(REPLY BUFFER) 02514000
SR 4,4 02515000
IC R4,0(,R2) GET L'REPLY DESIRED. 02516000
LTR R15,R4 IS READ COUNT ZERO? V0023 02517000
BZ WTORRET YES, RETURN V0023 02518000
LH R4,CONRDCNT GET NO. BYTES READ P3056 02519000
LTR R4,R4 BYTES READ= ZERO? V0023 02520000
BZ WTORRET YES, RETURN V0023 02521000
CR R4,R15 BYTES READ> BYTES REQUESTED V0023 02522000
BNH *+6 NO, CONTINUE V0023 02523000
LR R4,R15 YES, USE BYTES REQUESTED V0023 02524000
BCTR R4,R0 SET FOR MOVE P3056 02525000
EX 4,MOVE MOVE INTO USER'S BUFFER 02526000
WTORRET EQU * RETURN TO CALLER V0023 02527000
L 2,4(,2) R2 POINTS TO THE ECB. 02528000
XC 0(4,2),0(2) SET COMPLETION CODE 02529000
OI 0(2),X'7F' IN THE ECB. 02530000
WTORET B CMSCLEAR TR 02531000
* 02532000
* DATA AREA. 02533000
* 02534000
MOVE MVC 0(1,R5),CMNDLINE MOVE CONSOLE INPUT 02535000
EJECT @VA04475 02536000
******************************************************************** 02537000
* 02538000
* SVC 0 - EXCP, XDAP * 02539000
* * 02540000
*********************************************************************** 02541000
SPACE 02542000
* 02543000
* DURING PL/I COMPLIATION, THE "XDAP" ACCESS METHOD IS USED TO READ * 02544000
* OR TO WRITE-IN-PLACE TEXT & DICTIONARY BLOCKS. * 02545000
* FOR ANY OTHER PURPOSE, SVC 0 IS UNSUPPORTED. RETURN TO ABEND * 02546000
* 02547000
* 02548000
USING IHADCB,2 SET BASE FOR DCB REFERENCES 02549000
* ON ENTRY: 02550000
* GPR 1 = ADDR OF XDAP CONTROL BLOCK 02551000
* 02552000
XDAP EQU * 02553000
L 2,20(,1) GET DCB ADDRESS 02554000
L R8,DCBDEBAD GET ADDR OF DEB 02555000
SH R8,=AL2(IHADEB-FCBINIT) GET ADDR OF FCB 02556000
LH R7,FCBITEM SAVE ITEM NO. 02557000
LH R5,38(R1) GET TTR 02558000
N R5,HALFWORD 02559000
STH R5,FCBITEM FILL IN ITEM NO. 02560000
MVC FCBBUFF(8),56(R1) GET ADDRESS AND LENGTH 02561000
MVI FCBBUFF,X'00' 02562000
XC FCBBYTE(2),FCBBYTE 02563000
CLI 56(1),X'0E' DETERMINE I/O OPERATION 02564000
BNE XDAP2 NOT A READ. 02565000
L R15,ARDBUF READ. 02566000
NI DCBOFLGS,X'7F' INDICATE LAST I/O IS READ 02567000
B XDAP3 02568000
XDAP2 CLI 56(1),X'0D' IS IT WRITE? 02569000
BNE CNTRL NO. ILLEGAL OPERATION 02570000
L R15,AWRBUF WRITE 02571000
OI DCBOFLGS,X'80' INDICATE LAST I/O IS WRITE 02572000
XDAP3 LR 3,1 SET A(IOB) INTO R3 02573000
SH 3,FOURBIN - ?'4' = A(ECB) 02574000
XC 0(4,R3),0(R3) CLEAR ECB FLAG 02575000
LR R6,R15 SAVE REG 15 02576000
XDAPRW LA R1,FCBOP EXECUTE READ / WRITE 02577000
BALR R14,R15 02578000
BNZ XDAP5 02579000
* 02580000
XDAPOK EQU * @VA01052 02581000
MVI 0(3),X'7F' INDICATE I/O COMPLETE, NO ERRORS. 02582000
SETITEM STH R7,FCBITEM RESTORE ITEM NO. 02583000
B CMSCLEAR RETURN TO THE USER 02584000
* 02585000
XDAP5 EQU * ERROR FROM RDBUF / WRVUF 02586000
CH R15,NINE IS THIS AN ERROR NINE 02587000
BNE XDAP6 NO, CONTINUE 02588000
MVC FCBOP(8),WFINIS YES, THEN FINIS FILE 02589000
SVC X'CA' 02590000
DC AL4(*+4) 02591000
LR R15,R6 RESTORE REG 15 02592000
B XDAPRW RETRY I/O 02593000
XDAP6 TM DCBOFLGS,X'80' OUTPUT? @VA01052 02594000
BO XDAPERR YES, THEN ERROR @VA01052 02595000
CH R15,EIGHT LENGTH ERROR? @VA01052 02596000
BE XDAPOK YES, THEN IGNORE @VA01052 02597000
XDAPERR EQU * @VA01052 02598000
STH 15,2(,3) STORE ERR CODE INTO ECB 02599000
MVI 0(3),X'42' SET BYTE CODE IN ECB 02600000
B SETITEM RETURN TO USER 02601000
CNTRL DMSERR MF=I,TEXTA=ERRMSG2,NUM=119,LET=S 02602000
ABEND X'400' SYSTEM ABEND WITH ERROR CODE 02603000
EJECT 1 02604000
************************************************************** 02605000
BSP EQU * 69-BACKSPACE A DATA SET @V305665 02606000
* 02607000
* A BACKSPACE IS EXECUTED BY SETTING A POINT 02608000
* INDICATOR TO THE CURRENT ITEM NO. MINUS ONE. 02609000
* THE DISK OR TAPE IS NOT PHYSICALLY MOVED UNTIL 02610000
* THE NEXT BSAM READ OR WRITE TAKES PLACE. 02611000
USING IHADCB,R2 @V305665 02612000
LR R2,R1 GET V(DCB) IN REG 2 @V305665 02613000
L R8,DCBDEBAD GET ADDR OF DEB @V305665 02614000
SH R8,=AL2(IHADEB-FCBINIT) GET ADDR OF FCB @V305665 02615000
TM FCBINIT,FCBOS IS THIS OS FCB? @V305665 02616000
BNO BACKDA BRANCH IF NOT @V305665 02617000
LR R11,R8 SET FCB REG FOR OS @V305665 02618000
LCR R0,R8 INDICATE BSP CALL @V305665 02619000
L R15,ADMSROS GET DMSROS ADDRESS @V305665 02620000
BAL R14,16(R15) BAL TO DMSROS @V305665 02621000
LTR R15,R15 ANY ERRORS? @V305665 02622000
BNZ BACKERR BRANCH IF YES @V305665 02623000
B BSPRET RETURN TO CALLER @V305665 02624000
BACKDA EQU * @V305665 02625000
LH R5,FCBITEM GET ITEM NO. @V305066 02626000
N R5,HALFWORD ZERO FIRST HALF @V305665 02627000
CLI DCBFDAD,P WAS A POINT JUST ISSUED? @V305066 02628000
BNE BACKUP NO, USE FCBITEM @V305665 02629000
CLC DCBFDAD+6(2),=XL2'FFF8' BSP OVER EOF? @V305665 02630000
BE BACKUP BRANCH IF YES @V305665 02631000
MVC FCBOP(2),DCBFDAD+6 GET NEW ITEM NUMBER @V305665 02632000
LH R5,FCBOP GET THE NUMBER @V305665 02633000
LA R5,1(,R5) ADD ONE BACK @V305665 02634000
BACKUP EQU * @V305665 02635000
SH R5,FCBCOUT BACKSPACE ONE BLOCK @V305665 02636000
LTR R5,R5 IS NO. POSITIVE? @V305665 02637000
BNP BACKERR BRANCH IF NOT @V305665 02638000
BCTR R5,R0 SUBTRACT ONE FOR A POINT @V305665 02639000
STH R5,FCBOP SAVE NUMBER IN FCB @V305665 02640000
MVC DCBFDAD+6(2),FCBOP AND DCB @V305665 02641000
MVI DCBFDAD,P INDICATE POINT @V305066 02642000
CLI FCBDEV,FCBTAP IS THIS TAPE? @VA04853 02643000
BNE BSPRET BRANCH IF NOT @VA04853 02644000
TM DCBRECFM,VAR IS RECFM FIXED? @VA04853 02645000
BO BSPSET BRANCH IF NOT @VA04853 02646000
LH R5,DCBBLKSI GET BLOCKSIZE @VA04853 02647000
LH R6,DCBLRECL AND THE LRECL @VA04853 02648000
CR R5,R6 IS FILE BLOCKED? @VA04853 02649000
BE BSPSET BRANCH IF NOT @VA04853 02650000
N R5,HALFWORD ZERO FIRST HALF OF BLOCKSIZE @VA04853 02651000
N R6,HALFWORD AND LRECL @VA04853 02652000
SR R4,R4 ZERO REGISTER 4 @VA04853 02653000
DR R4,R6 GET BLOCKING FACTOR @VA04853 02654000
STH R5,FCBCOUT AND SAVE IT (NEEDED FOR @VA04853 02655000
BSPSET EQU * SHORT LAST BLOCK) @VA04853 02656000
LH R4,FCBTBSP GET NUMBER OF RECORDS BSP @VA04853 02657000
LA R4,1(,R4) ADD ONE @VA04853 02658000
STH R4,FCBTBSP AND SAVE IT @VA04853 02659000
BSPRET EQU * RETURN FROM BACKSPACE @V201122 02660000
NI DCBOFLGS,255-PREVIOUS TURN OFF WRITE INDICATOR 02661000
B CMSCLEAR 02662000
* 02663000
BACKERR DS 0H THERE WAS AN ERROR, GOSH 02664000
LA R15,4 SET OS ERROR CODE 02665000
B CMSRET 02666000
EJECT 1 02667000
************************************************************** HRC380DS 02667025
SVC120 EQU * 120-GETMAIN for memory above HRC380DS 02667050
* the 16 megabyte line. HRC380DS 02667075
* HRC380DS 02667100
* This is (hopefully) temporary code. As neither CMS HRC380DS 02667125
* nor CP is ready for 31-bit addressing, this entry HRC380DS 02667150
* point merely allows programs such as GCC to run as HRC380DS 02667175
* they do on MVS/XA or z/VM. No memory management is HRC380DS 02667200
* done here. We simply return a fixed address which HRC380DS 02667225
* represents where the memory has been "allocated". HRC380DS 02667250
* On entry, R0 has the requested amount. We leave R0 HRC380DS 02667275
* alone, as that is where the amount allocated is HRC380DS 02667300
* returned. We return the address of the allocated HRC380DS 02667325
* memory in R1. HRC380DS 02667350
L R1,=XL4'04100000' this is where Paul wants it HRC380DS 02667375
ST R1,EGPR1 save it for our caller HRC380DS 02667400
SR R15,R15 works every time HRC380DS 02667425
B CMSRET HRC380DS 02667450
EJECT 1 HRC380DS 02667475
*********************************************************************** 02668000
SVCTABBG DS 0F SVC TABLE 02669000
SPACE 02670000
JTBL 0,XDAP 02671000
JTBL 11,TIME 02672000
JTBL 14,SPIE 02673000
JTBL 17,RESTORE 02674000
JTBL 18,SVC18 02675000
JTBL 21,SVC21 02676000
JTBL 24,DEVTYPE 02677000
JTBL 25,TRKBAL V0317 02678000
JTBL 31,FEOV @VA01363 02679000
JTBL 35,WTO 02680000
JTBL 40,EXTRACT 02681000
JTBL 41,IDENTIFY 02682000
JTBL 44,CHAP 02683000
JTBL 46,TTIMER 02684000
JTBL 47,STIMER 02685000
JTBL 48,DEQ 02686000
JTBL 51,SNAP 02687000
JTBL 56,ENQ 02688000
JTBL 57,SVC57 02689000
JTBL 60,SVC60 02690000
JTBL 62,DETACH 02691000
JTBL 63,CHKPT 02692000
JTBL 64,RDJFCB 02693000
JTBL 68,SYNAD 02694000
JTBL 69,BSP 02695000
JTBL 96,STAX 02696000
JTBL 120,SVC120 HRC380DS 02696100
JTBL 203,SVC203 02697000
SPACE 02698000
SVCTABED EQU *-4 02699000
SVCVCNBG EQU * @V305665 02700000
JOST 01,DMSSVN1 WAIT @V305665 02701000
JOST 02,DMSSVN2 POST @V305665 02702000
JOST 03,DMSSLN3 EXIT/RETURN @V305665 02703000
JOST 04,DMSSMN4 GETMAIN @V305665 02704000
JOST 05,DMSSMN5 FREEMAIN @V305665 02705000
JOST 06,DMSSLN6 LINK @V305665 02706000
JOST 07,DMSSLN7 XCTL @V305665 02707000
JOST 08,DMSSLN8 LOAD @V305665 02708000
JOST 09,DMSSLN9 DELETE @V305665 02709000
JOST 10,DMSSMN10 GETMAIN/FREEMAIN @V305665 02710000
JOST 13,DMSSAB ABEND (CHECK THIS!!) @V305665 02711000
JOST 19,DMSSOP19 OPEN @V305665 02712000
JOST 20,DMSSOP20 CLOSE @V305665 02713000
JOST 22,DMSSOP22 OPENJ @V305665 02714000
JOST 23,DMSSOP23 TCLOSE @V305665 02715000
JOST 42,DMSSLN42 ATTACH @V305665 02716000
JOST 93,DMSSVN93 TSO TGET-TPUT @V305665 02717000
JOST 94,DMSSVN94 TSO TCLEARQ @V305665 02718000
SVCVCNED EQU *-4 @V305665 02719000
SPACE 2 02720000
* VCONS FOR OS ROUTINES 02721000
DC V(DMSSVN) @V305665 02722000
DC V(DMSSMN) @V305665 02723000
DC V(DMSLGT) @V305665 02724000
DC V(DMSSLN) @V305665 02725000
DC V(DMSSAB) @V305665 02726000
DC V(DMSSOP) @V305665 02727000
DC V(DMSSQS) @V305665 02728000
DC V(DMSSBS) @V305665 02729000
DC V(DMSSCT) @V305665 02730000
DC V(DMSLSB) @V305665 02731000
SPACE 3 02732000
ERRMSG1 DC C'DMSSVT120S ****** ERROR *** ON ' 02733000
ERRMSG2 DC AL1(32) 02734000
DC C'UNSUPPORTED FORM OF ''XDAP'' MACRO' 02735000
ERRMSG3 DC AL1(ENDMSG3-ERRMSG3-1) 02736000
DC C'UNSUPPORTED SVC ... (HEX ..) CALLED FROM ......' 02737000
ENDMSG3 DS 0X 02738000
ERRMSG4 DC AL1(ENDMSG4-ERRMSG4-1) MSG LENGTH 02739000
DC C'FILE ''....................'' IS NOT A' @VA06023 02740000
DC C' LIBRARY' @VA06023 02741000
ENDMSG4 DS 0X END OF MSG 4 02742000
SPACE 02743000
LTORG (FOR 2ND PAGE OF CODE) @VM03083 02744000
EJECT 02745000
DCBD DSORG=(PS) 02746000
EJECT 02747000
PGMSECT 02748000
TSOBLKS @V1D1709 02749000
CMSCB 02750000
DOSCB @V305174 02751000
IO 02752000
FSTB 02753000
NUCON 02754000
EXTSECT 02755000
CMSAVE 02756000
REGEQU 02757000
PDSSECT 02758000
KEYSECT 02759000
ADT 02759500
EJECT 1 02760000
TEMPSPC DSECT @V305665 02761000
SAVR14 DS F REGISTER 14 SAVE AREA @V305665 02762000
FEOF DS F @V305665 02763000
ZEIT DS PL4 TIME WORK AREA @V305665 02764000
TAG DS PL4 DATE WORK AREA @V305665 02765000
TIMEWK1 DS 0X CLEAR OUT REGION @V305665 02766000
DAY DS H @V305665 02767000
HOUR DS 3H @V305665 02768000
MIN DS 3H @V305665 02769000
DHOUR DS D @V305665 02770000
DATE EQU DHOUR @V305665 02771000
YEAR EQU DHOUR+4 @V305665 02772000
TIMEWK2 DS 0X END OF CLEAR AREA @V305665 02773000
* 02774000
TIMBUF DS CL24 WORKING BUFFER @V305665 02775000
TDATE EQU TIMBUF @V305665 02776000
TIMDAY EQU TIMBUF+8 @V305665 02777000
FLAG DS X @V305665 02778000
R15CODE DS X @V305665 02779000
WORK DS 1D WORK AREA @V305665 02780000
ERRMESS DMSERR MF=L,MAXSUBS=3 @V305665 02781000
TEMPSEND EQU * @V305665 02782000
TEMPLNT EQU (TEMPSEND-TEMPSPC)/8 @V305665 02783000
END 02784000