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