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