ibm:vm370-lib:cms:dmsres.assemble_src
Table of Contents
DMSRES Source
References
- Fixes Applied : 0
- This Source Date : Wednesday, January 11, 2006
- Last Fix ID : [Unmodified]
Source Listing
- DMSRES.ASSEMBLE.txt
- RES TITLE 'DMSRES - CMS RESIDENT CORE LIBRARY PROCESSOR' DMS00010
- *MODULE NAME - DMS00020
- * DMS00030
- * DMSRES DMS00040
- * DMS00050
- *FUNCTION - DMS00060
- * DMS00070
- * TO ASSIST A USER IN MAINTAINING A RESIDENT CORE LIBRARY. DMS00080
- * DMS00090
- *ENTRY POINTS - DMS00100
- * DMS00110
- * DMSRES DMS00120
- * DMS00130
- *ENTRY CONDITIONS - DMS00140
- * DMS00150
- * R1 - A(CMS PLIST) DMS00160
- * R13 - A(SAVE AREA) DMS00170
- * R14 - RETURN ADDRESS DMS00180
- * R15 - ENTRY POINT ADDRESS DMS00190
- * DMS00200
- *EXIT CONDITIONS - DMS00210
- * DMS00220
- * R15 - RETURN CODE: DMS00230
- * = 0 -> FUNCTION COMPLETED. DMS00240
- * > 0 -> FUNCTION NOT COMPLETED. DMS00250
- * DMS00260
- *MODULE ATTRIBUTES - DMS00270
- * DMS00280
- * TRASIENT AREA, SYSTEM KEY, SERIALLY REUSEABLE, CALLED VIA SVC DMS00290
- * 202 AS FOLLOWS: DMS00300
- * DMS00310
- * R1 -> DC CL8'RESLIB' DMS00320
- * DC CL8'ALLOCATE' (ALLOCATE PROTECTED STORAGE) DMS00330
- * DC CL8'<PAGES>' (NUMBER OF 4K PAGES TO ALLOCATE, MUS DMS00340
- * MUST BE 1 TO 256) DMS00350
- * DC CL8'(' (OPTION SEPARATOR) DMS00360
- * DC CL8'KEY <NN>' (STORAGE PKEY TO ASSIGN TO AREA) DMS00370
- * DC CL8'PERM' (PROTECT AGAINST DEL *) DMS00380
- * DC XL8'FF' DMS00390
- * DMS00400
- * R1 -> DC CL8'RESLIB' DMS00410
- * DC CL8'DELETE' (DELETE PREVIOUS ALLOC OR LOAD) DMS00420
- * DC CL8'<ID | *> (ALLOCATE OR LOAD ID. IF *, THEN DMS00430
- * DELETE ALL BUT PERM SPACE) DMS00440
- * DC XL8'FF' DMS00450
- EJECT DMS00460
- * R1 -> DC CL8'RESLIB' DMS00470
- * DC CL8'LIST' (DISPLAY ONE OR MORE ENTRIES) DMS00480
- * DC CL8'<ID | *> (ALLOCATE OR LOAD ID. IF *, THEN DMS00490
- * DISPLAY ALL ENTRIES) DMS00500
- * DC CL8'(' (OPTION SEPARATOR) DMS00510
- * DC CL8'STACK' (STACK OUTPUT FIFO, NOTYPE DFLT) DMS00520
- * DC CL8'TYPE' (TYPE THE DISPLAY, NORMAL DFLT) DMS00530
- * DC CL8'NOTYPE' (SUPPRESS TYPE OUT) DMS00540
- * DC XL8'FF' DMS00550
- * DMS00560
- * R1 -> DC CL8'RESLIB' DMS00570
- * DC CL8'LOAD' (LOAD A PROGRAM INTO PROT STORE) DMS00580
- * DC CL8'<ID>' (FNAME OF TEXT BECOMES AREA ID) DMS00590
- * DC CL8'(' (OPTION SEPARATOR) DMS00600
- * DC CL8'NAME <NAME>' (TRUE NAME OF ENTRY) DMS00610
- * DC CL8'PERM' (PROTECT FROM DEL *) DMS00620
- * DC CL8'SYSTEM' (LEAVE AREA IN KEY F. WHEN CALLED, DMS00630
- * PSW KEY=0, MASK=DISABLED. ELSE STORE DMS00640
- * KEY=E, PSW KEY=E, MASK=ENABLED) DMS00650
- * DC XL8'FF' DMS00660
- * DMS00670
- *GENERAL COMMAND SYNTAX: DMS00680
- * DMS00690
- * ALLOCATE <ID> <( NAME . KEY . PERM < ) >> DMS00700
- * DELETE <ID | * > DMS00710
- * LIST <ID | * > <( STACK TYPE NOTYPE < ) >> DMS00720
- * RESLIB LOAD <ID> <( PERM SYSTEM NAME ...< ) >> DMS00730
- * DMS00740
- *MINIMUM ABBREVIATIONS - DMS00750
- * DMS00760
- * ALLOCATE -> A DELETE -> D LIST -> L DMS00770
- * LOAD -> LO DMS00780
- * DMS00790
- * KEY -> KEY NAME -> NAME NOTYPE -> NOT DMS00800
- * PERM -> PERM STACK -> STACK SYSTEM -> SYS DMS00810
- * TYPE -> T DMS00820
- EJECT DMS00830
- *NOTES - DMS00840
- * DMS00850
- * 1. THIS ROUTINE MUST BE LOADED IN THE TRANSIENT AREA AND DMS00860
- * GENERATED WITH A NAME OF RESLIB WITH THE SYSTEM OPTION. DMS00870
- * DMS00880
- * 2. THE ALLOCATE, LOAD, AND LIST FUNCTION RETURN THE ADDRESS DMS00890
- * OF THE RELEVANT AREA IN R1. DMS00900
- * DMS00910
- * 3. DUPLICATE OPTIONS ARE ACCEPTED. THE RIGHTMOST IS USED. DMS00920
- * DMS00930
- *LOCALLY ISSUED MESSAGES: DMS00940
- * DMS00950
- * DMSRES003E INVALID OPTION '........' RC=24 DMS00960
- * DMSRES005E NO 'KEY | NAME' SPECIFIED RC=24 DMS00970
- * DMSRES014E INVALID FUNCTION '........' RC=24 DMS00980
- * DMSRES026W '........' NOT IN LIBRARY RC=4 DMS00990
- * DMSRES026E INVALID ........ '........' FOR '........' FUNCTION RC=24 DMS01000
- * DMSRES027W NO PRIVATE CORE IMAGE LIBRARY RC=4 DMS01010
- * DMSRES029E INVALID PARAMETER '....' IN THE '....' OPTION FIELD RC=24 DMS01020
- * DMSRES047E NO FUNCTION SPECIFIED RC=24 DMS01030
- * DMSRES050E PARAMETER MISSING AFTER ........ RC=24 DMS01040
- * DMSRES070E INVALID PARAMETER '........' RC=24 DMS01050
- * DMSRES109S VIRTUAL STORAGE CAPACITY EXCEEDED RC=104 DMS01060
- * DMSRES224E '........ ALREADY IN USE' RC=24 DMS01070
- * DMS01080
- *LOGIC - DMS01090
- * DMS01100
- * DOCUMENTED AT EACH MAJOR PORTION OF THE PROGRAM. DMS01110
- SPACE 3 DMS01120
- *********************************************************************** DMS01130
- * * DMS01140
- * S E T C D E P E N D I N G O N C M S L E V E L * DMS01150
- * * DMS01160
- *********************************************************************** DMS01170
- SPACE DMS01180
- GBLC &STATE DMS01190
- &STATE SETC 'ASTATE' FOR REL < 6.0 OR ANY W/O BSEP | SEP DMS01200
- *STATE SETC 'AESTATE' FOR REL >=6.0 WITH BSEP OR SEP DMS01210
- EJECT DMS01220
- *STEP 1: PERFORM ENTRY INITIALIZATION DMS01230
- * DMS01240
- DMSRES CSECT DMS01250
- PRINT NOGEN DMS01260
- USING NUCON,R0 DMS01270
- USING FUNCBLOK,R3 DMS01280
- USING LIBNTRY,R7 DMS01290
- USING *,R12 DMS01300
- SPACE DMS01310
- LR R12,R15 SET BASE REGISTER DMS01320
- LR R11,R14 SAVE RETURN ADDRESS DMS01330
- LA R8,8(,R1) SET PLIST POINTER DMS01340
- MVI FBITS,0 CLEAR THE FBITS DMS01350
- MVI OBITS,0 CLEAR THE OBITS DMS01360
- MVI LKEY,X'0E' SET USER KEY DMS01370
- SPACE DMS01380
- *STEP 2: SETUP TO SCAN FOR FUNCTION NAME DMS01390
- * DMS01400
- BAL R10,GETLEN GET LEN-1 DMS01410
- LM R3,R5,=A(FUNCTAB,FUNCTABL,FUNCTABE) GET FUNCTION PNTRS DMS01420
- SPACE DMS01430
- *STEP 3: SCAN FOR A VALID FUNCTION DMS01440
- * DMS01450
- CHKFUNC1 EX R1,CLCFUNC IF FUNCTION NAMES THE SAME DMS01460
- BE GOTFUNC THEN PROCESS IT DMS01470
- BXLE R3,R4,CHKFUNC1 ELSE KEEP LOOKING DMS01480
- SPACE DMS01490
- *STEP 4: NO VALID FUNCTION NAME FOUND. CHECK TYPE OF ERR MSG TO GIVE DMS01500
- * DMS01510
- CLC 0(2,R8),=C'(' IF OPTION LIST FOUND DMS01520
- BE NOFUNC THEN NO FUNCTION SPECIFIED DMS01530
- CLI 0(R8),X'FF' ELSE END OF PLIST DMS01540
- BE NOFUNC THEN NO FUNCTION FOUND DMS01550
- B BADFUNC ELSE IT IS AN INVALID ONE DMS01560
- EJECT DMS01570
- *STEP 5: CHECK IF REMAINDER OF PLIST IS TO BE PROCESSED DMS01580
- * DMS01590
- GOTFUNC LA R8,8(,R8) POINT TO START OF PARMS DMS01600
- TM FUNCFLAG,NOFPROC IF NO PLIST PROCESSING DMS01610
- BO FUNCXEQ THEN EXECUTE THE FUNCTION DMS01620
- SPACE DMS01630
- *STEP 6: CHECK IF ENTRY ID SPECIFIED AND IF SO, GET IT DMS01640
- * DMS01650
- BAL R10,SCANP SCAN PLIST FOR END DMS01660
- BZ CHKNAME IF END, THEN CHECK IF FNAME NEEDED DMS01670
- MVC LOADTXTN(8),0(R8) ELSE GET FNAME DMS01680
- LA R8,8(,R8) POINT TO NEXT TOKEN DMS01690
- B CHKXEQ AND CHECK FOR FURTHER PROCESSING DMS01700
- SPACE DMS01710
- *STEP 7: NO <ID> SPECIFIED, CHECK IF THIS IS ACCEPTABLE DMS01720
- * DMS01730
- CHKNAME TM FUNCFLAG,SKPNAME IF NAME NOT OPTIONAL DMS01740
- BNO NOPARM THEN ERROR DMS01750
- MVC LOADTXTN(2),=C'* ' ELSE INDICATE STAR DMS01760
- SPACE DMS01770
- *STEP 8: CHECK IF IMMEDIATE XEQ REQUIRED OR OPTION CHECKING DMS01780
- * DMS01790
- CHKXEQ TM FUNCFLAG,IXEQ IF NOT IMMED XEQ DMS01800
- BNO GETOP THEN PROCESS THE OPTIONS DMS01810
- B FUNCXEQ ELSE EXECUTE THE FUNCTION DMS01820
- EJECT DMS01830
- *********************************************************************** DMS01840
- * * DMS01850
- * O P T I O N L I S T P R O C E S S I N G * DMS01860
- * * DMS01870
- *********************************************************************** DMS01880
- SPACE DMS01890
- *STEP 1: CHECK IF WE ACTUALLY HAVE A VALID OPTION LIST DMS01900
- * DMS01910
- GETOP CLI 0(R8),X'FF' IF END OF PLIST DMS01920
- BE FUNCXEQ THEN START XEQ DMS01930
- CLC 0(2,R8),=C'( ' IF TOKEN ¬= '(' DMS01940
- BNE CONFLCTP THEN INVALID PARAMETER DMS01950
- SPACE DMS01960
- *STEP 2: BUMP TO NEXT TOKEN AND CHECK IF OPTION LIST HAS ENDED DMS01970
- * DMS01980
- GETOP1 LA R8,8(,R8) BUMP TO NEXT TOKEN DMS01990
- CLI 0(R8),X'FF' IF END OF PLIST DMS02000
- BE FUNCXEQ THEN EXCUTE FUNCTION DMS02010
- CLC 0(2,R8),=C') ' IF CLOSE PAREN DMS02020
- BE FUNCXEQ THEN EXECUTE FUNCTION DMS02030
- SPACE DMS02040
- *STEP 3: PREPARE TO SCAN THE OPTION TABLE DMS02050
- * DMS02060
- LA R2,7(,R8) POINT TO LAST BYTE OF OPTION DMS02070
- BAL R10,GETLEN GET LEN-1 DMS02080
- LM R5,R7,=A(OPTABLE,OPTABLN,OPTABND) GET TBL PNTRS DMS02090
- USING OPTBLOK,R5 DMS02100
- SPACE DMS02110
- *STEP 4: SCAN FOR VALID OPTION DMS02120
- * DMS02130
- GETOP2 CLM R1,B'0001',OPTLEN IF OUR STRING IS TO SHORT DMS02140
- BL GETOP2A THEN SKIP IT DMS02150
- EX R1,CLCOPT ELSE IF OPTION NAMES COMPARE DMS02160
- BE GETOP3 THEN FOUND OPTION DMS02170
- GETOP2A BXLE R5,R6,GETOP2 ELSE LOOK AT NEXT ONE DMS02180
- B BADOPT INVALID OPTION DMS02190
- SPACE DMS02200
- *STEP 5: CHECK IF OPTION VALID FOR FUNCTION AND SET INDICATOR IF SO DMS02210
- * DMS02220
- GETOP3 MVC 0(1,R13),FUNCOPT GET VALID OPTION BITS DMS02230
- NC 0(1,R13),OPTVALID IF OPTION NOT ONE OF THEM DMS02240
- BZ CONFLCTO THEN OPTION/FUNCTION CONFLICT DMS02250
- NC OBITS(1),OPTMASK REMOVE TOGGLE OPTIONS DMS02260
- OC OBITS(1),OPTBITS SET OPTION INDICATOR DMS02270
- EJECT DMS02280
- *STEP 6: CHECK FOR 'NAME' OPTION AND PROCESS DMS02290
- * DMS02300
- CLC CHKNAMO(8),0(R5) IF NOT THE NAME OPTION DMS02310
- BNE GETOP4 THEN CHECK FOR KEY OPTION DMS02320
- LA R8,8(,R8) ELSE POINT TO NEXT OPTION DMS02330
- BAL R10,SCANP CHECK IF END OF PLIST HERE DMS02340
- BZ NOPTV IF SO, THEN NAME NOT SPECIFIED DMS02350
- MVC NEWNAME(8),0(R8) ELSE SET NEW NAME DMS02360
- B GETOP1 GET NEXT OPTION DMS02370
- SPACE DMS02380
- *STEP 7: CHECK IF 'KEY' SPECIFIED AND PROCESS DMS02390
- * DMS02400
- GETOP4 CLC CHKKEY(8),0(R8) IF KEY NOT SPECIFIED DMS02410
- BNE GETOP1 THEN GET NEXT OPTION DMS02420
- LA R8,8(,R8) ELSE POINT TO NEXT TOKEN DMS02430
- BAL R10,SCANP CHECK IF AT END OF PLIST DMS02440
- BZ NOPTV IF AT END, THEN ERROR DMS02450
- BAL R10,GETLEN ELSE GET LEN-1 OF TOKEN DMS02460
- BAL R10,GETNUM CONVERT IT DMS02470
- BNZ BADVAL IF INVALID, THEN ERROR DMS02480
- CH R15,=H'15' IF KEY > X'0F' DMS02490
- BH BADVAL THEN INVALID DMS02500
- STC R15,LKEY ELSE SET KEY VALUE DMS02510
- B GETOP1 AND GET NEXT OPTION DMS02520
- DROP R5 DMS02530
- EJECT DMS02540
- *********************************************************************** DMS02550
- * * DMS02560
- * A L L O C A T E F U N C T I O N P R O C E S S I N G * DMS02570
- * * DMS02580
- *********************************************************************** DMS02590
- SPACE DMS02600
- *STEP 1: GET THE NUMBER OF PAGES TO BE ALLOCATED DMS02610
- * DMS02620
- ALO LA R8,LOADTXTN POINT TO NUMBER OF PAGES DMS02630
- BAL R10,GETLEN GET LEN-1 DMS02640
- BAL R10,GETNUM CONVERT IT TO BINARY DMS02650
- BNZ CONFLCTP IF INVALID, THEN EXIT DMS02660
- STH R15,SAVENUM SAVE THE NUMBER DMS02670
- SPACE DMS02680
- *STEP 2: CHECK IF USER TRYING TO ALLOCATE DUPLICATE ID DMS02690
- * DMS02700
- TM OBITS,OPTNAM IF NAME NOT SPECIFIED DMS02710
- BNO ALO01 THEN SKIP DUP ID CHECK DMS02720
- MVC LOADTXTN(8),NEWNAME ELSE SUPPLY NAME DMS02730
- BAL R10,SCANTAB FIND ID IN LIB TABLE DMS02740
- BZ DUPID IF FOUND, THEN ERROR DMS02750
- SPACE DMS02760
- *STEP 3: ALLOCATE A NEW LIB TABLE ENTRY AND CHECK IF UNIQUE ID NEEDED DMS02770
- * DMS02780
- ALO01 SR R0,R0 GET FREE LIB ENTRY DMS02790
- BAL R10,SCANTABA VIA SPECIAL SEARCH DMS02800
- BNZ NOSTOR IF NONE, THEN TABLE IS FULL DMS02810
- TM OBITS,OPTNAM IF NAME SPECIFIED DMS02820
- BO ALO03 THEN SKIP THE ID GENERATION DMS02830
- LR R5,R15 SAVE THE ENTRY NUMBER DMS02840
- STM R0,R7,STSAVE SAVE SOME REGS DMS02850
- NI FBITS,255-SEEKADR RESET SEEK BIT DMS02860
- SPACE DMS02870
- *STEP 4: CONSTRUCT A UNIQUE ID FOR THE USER DMS02880
- * DMS02890
- ALO02 STCK DTEMP SAVE CURRENT TOD DMS02900
- STC R5,DTEMP+7 INSERT ENTRY ID DMS02910
- UNPK 0(9,R13),DTEMP+4(5) BREAK OUT ALL DIGITS DMS02920
- MVC LOADTXTN(8),0(R13) MOVE OVER RELEVANT PORTION DMS02930
- NC LOADTXTN(8),=8X'0F' ISOLATE THE DIGITS DMS02940
- TR LOADTXTN(8),=C'ABCDEFGHJKMNPQRS' CREATE NAME DMS02950
- BAL R10,SCANTAB FIND THE ENTRY DMS02960
- BZ ALO02 IF FOUND, GENERATE A NEW ONE DMS02970
- MVC NEWNAME(8),LOADTXTN ELSE MAKE THIS THE NAME DMS02980
- LM R0,R7,STSAVE RESTORE THE REGS DMS02990
- EJECT DMS03000
- *STEP 5: ALLOCATE STORAGE BASED ON NUMBER OF PAGES WANTED DMS03010
- * DMS03020
- ALO03 LH R2,SAVENUM GET NUMBER OF PAGES DMS03030
- SLL R2,12 MULTIPLY BY 4096 DMS03040
- BAL R10,GETCORE GET THE STORAGE DMS03050
- BNZ NOSTOR IF NOT ENOUGH FREE AREA, ERROR DMS03060
- SPACE DMS03070
- *STEP 6: ENTER THE AREA IN THE LIB TABLE AND RETURN EPA TO USER DMS03080
- * DMS03090
- LR R1,R3 R1 <- EPA (SAME AS START LOC) DMS03100
- BAL R10,ADDNTRY ADD THE ENTRY DMS03110
- BAL R10,RETNTRY RETURN IT TO USER VIA R1 DMS03120
- B EXIT00 ALL DONE DMS03130
- EJECT DMS03140
- *********************************************************************** DMS03150
- * * DMS03160
- * D E L E T E F U N C T I O N P R O C E S S I N G * DMS03170
- * * DMS03180
- *********************************************************************** DMS03190
- SPACE DMS03200
- *STEP 1: CHECK IF '*' SPECIFIED INDICATING ALL NON-PERM DELETES DMS03210
- * DMS03220
- DELT CLC LOADTXTN(2),=C'* ' IF STAR NOT GIVEN DMS03230
- BNE DELT03 THEN DELETE ONLY ONE ENTRY DMS03240
- BAL R14,GETLIB ELSE GET A(LIB TABLE) DMS03250
- BNZ EXIT00 IF NONE, THEN ALL DONE DMS03260
- LA R5,LIBMAXN ELSE DELETE ALL POSSIBLE ENTRIES DMS03270
- SPACE DMS03280
- *STEP 2: DELETE ALL APPLICABLE ENTRIES DMS03290
- * DMS03300
- DELT01 CLI LIBID,0 IF NULL ENTRY HIT DMS03310
- BE EXIT00 THEN ALL DONE DMS03320
- TM LIBFLAGS,LIBPERM IF THIS IS NOT A PERM ENTRY DMS03330
- BNO DELT02 THEN DELETE DMS03340
- LA R7,LIBSIZE(,R7) ELSE POINT TO NEXT ENTRY DMS03350
- BCT R5,DELT01 AND CHECK IT OUT DMS03360
- B EXIT00 ALL DONE DMS03370
- SPACE DMS03380
- *STEP 3: FREE THE ENTRY STORAGE AND DELETE FROM LIB TABLE DMS03390
- * DMS03400
- DELT02 LM R2,R3,LIBLEN GET LEN & ADDRESS DMS03410
- BAL R10,RELCORE RELEASE THE STORAGE DMS03420
- BAL R10,RELNTRY RELEASE THE LIB TABLE ENTRY DMS03430
- BNZ DELT01 IF MORE LEFT, CHECK THEM OUT DMS03440
- B EXIT00 ELSE ALL DONE DMS03450
- SPACE DMS03460
- *STEP 4: FIND MATCHING ENTRY ID ENTRY IN LIB TABLE DMS03470
- * DMS03480
- DELT03 BAL R10,SCANTAB SCAN LIB TABLE DMS03490
- BNZ NOTXT IF NOT FOUND, THEN ERROR DMS03500
- SPACE DMS03510
- *STEP 5: ENTRY FOUND, RELEASE ITS STORAGE AND DELETE THE TABLE ENTRY DMS03520
- * DMS03530
- BAL R10,RELCORE RELEASE ENTRY STORAGE DMS03540
- BAL R10,RELNTRY RELEASE THE ENTRY DMS03550
- B EXIT00 AND EXIT WITH RC=0 DMS03560
- EJECT DMS03570
- *********************************************************************** DMS03580
- * * DMS03590
- * L O A D F U N C T I O N P R O C E S S I N G * DMS03600
- * * DMS03610
- *********************************************************************** DMS03620
- SPACE DMS03630
- *STEP 1: CHECK IF NAME TO BE ENTERED IS A DUPLICATE DMS03640
- * DMS03650
- LOADF MVC STSAVE(8),LOADTXTN SAVE CURRENT NAME DMS03660
- TM OBITS,OPTNAM IF 'NAME' NOT SPECIFIED DMS03670
- BNO *+10 THEN ALL IS WELL DMS03680
- MVC LOADTXTN(8),NEWNAME ELSE SET NEW NAME DMS03690
- BAL R10,SCANTAB TRY TO FIND THE ENTRY DMS03700
- BZ DUPID IF FOUND, THEN ERROR DMS03710
- MVC NEWNAME(8),LOADTXTN ELSE SET THE ENTRY NAME DMS03720
- MVC LOADTXTN(8),STSAVE RESTORE LOAD NAME DMS03730
- SPACE DMS03740
- *STEP 2: GET A LIB TABLE ENTRY & LOAD ROUTINE INTO LOW STORAGE FIRST DMS03750
- * SO THAT WE CAN COMPUTE THE AMOUNT OF STORAGE NEEDED FOR IT. DMS03760
- * DMS03770
- SR R0,R0 LOOK FOR EMPTY SLOT DMS03780
- BAL R10,SCANTABA VIA SCANTAB ONCE MORE DMS03790
- BNZ NOSTOR IF NONE, TABLE IS FULL DMS03800
- L R3,MAINHIGH ELSE GET A CLEAR STORAGE AREA DMS03810
- BAL R10,LOADTXT DO INITIAL LOAD DMS03820
- BNZ EXITRC IF ERROR, EXIT W/ LOADER RC DMS03830
- SPACE DMS03840
- *STEP 3: COMPUTE THE AMOUNT OF STORAGE NEEDED BASED OF STARTING DMS03850
- * LOCATION AND ENDING LOCATION AS COMPUTE BY THE LOADER. DMS03860
- * DMS03870
- LR R2,R0 R2 <- ENDING ADDRESS DMS03880
- SR R2,R3 SIZE = LOCCNT - START ADDRESS DMS03890
- TM OBITS,OPTSYS IF SYSTEM OPTION NOT SPECIFIED DMS03900
- BNO *+8 THEN KEY VALUE IS CORRECT DMS03910
- MVI LKEY,X'0F' ELSE SET STORAGE TO KEY X'F' DMS03920
- BAL R10,GETCORE ALLOCATE STORAGE DMS03930
- BNZ NOSTOR IF NONE, THEN ERROR DMS03940
- SPACE DMS03950
- *STEP 4: LOAD THE FILE IN HIGH STORAGE ONCE AGAIN. IF ERROR, RELEASE DMS03960
- * THE STORAGE WE GOT BEFORE WE EXIT. DMS03970
- * DMS03980
- BAL R10,LOADTXT LOAD THE FILE DMS03990
- BZ LOADF01 IF IT WAS LOADED, WE ARE ALL SET DMS04000
- LR R9,R15 ELSE GET RC DMS04010
- BAL R10,RELCORE RELEASE THE STORAGE DMS04020
- LR R15,R9 RESTORE THE LOADER RC DMS04030
- B EXITRC AND EXIT DMS04040
- SPACE DMS04050
- *STEP 5: ADD NEW ENTRY INTO THE LIB TABLE AND RETURN ADDR TO USER DMS04060
- * DMS04070
- LOADF01 L R1,STRTADDR GET ENTRY POINT ADDRESS DMS04080
- BAL R10,ADDNTRY ADD IT TO THE LIB TABLE DMS04090
- BAL R10,RETNTRY SUPPLY EPA VIA R1 DMS04100
- OI LIBFLAGS,LIBCMD FLAG AS A RESIDENT COMMAND DMS04110
- B EXIT00 AND EXIT DMS04120
- EJECT DMS04130
- *********************************************************************** DMS04140
- * * DMS04150
- * L I S T F U N C T I O N P R O C E S S I N G * DMS04160
- * * DMS04170
- *********************************************************************** DMS04180
- SPACE DMS04190
- *STEP 1: SET CORRECT OPTIONS BASED ON SPECIFIED OPTIONS DMS04200
- * DMS04210
- LST TM OBITS,OPTYPE+OPNTYPE IF TYPE | NOTYPE SPECIFIED DMS04220
- BNZ LST00 THEN OPTIONS ARE SET DMS04230
- OI OBITS,OPTYPE ELSE FORCE TYPING DMS04240
- TM OBITS,OPTSTK IF STACK NOT SPECIFIED DMS04250
- BNO LST00 THEN OPTIONS ARE SET DMS04260
- NI OBITS,255-OPTYPE ELSE RESET TYPING DMS04270
- OI OBITS,OPNTYPE AND INDICATE NOTYPING DMS04280
- SPACE DMS04290
- *STEP 2: CHECK IF '*' SPECIFIED FOR FNAME (IF IT WAS, USER WANTS A DMS04300
- * COMPLETE LIST OF THE LIB TABLE). ELSE TYPE SINGLE ENTRY. DMS04310
- * DMS04320
- LST00 CLC LOADTXTN(2),=C'* ' IF STAR SPECIFIED DMS04330
- BE LST01 THEN GIVE COMPLETE LIST DMS04340
- BAL R10,SCANTAB ELSE FIND THE MATCHING ENTRY DMS04350
- BNZ NOTXTL IF NONE, THEN ERROR DMS04360
- BAL R10,RETNTRY ELSE RETURN EPA FOR USER DMS04370
- BAL R10,TYPENTRY TYPE THE INFO DMS04380
- B EXIT00 AND EXIT WITH RC = 0 DMS04390
- SPACE DMS04400
- *STEP 3: SCAN COMPLETE LIB TABLE TYPING ALL VALID ENTRIES DMS04410
- * DMS04420
- LST01 LA R5,LIBMAXN DO ALL OF THE ENTRIES DMS04430
- BAL R14,GETLIB GET A(LIB TABLE) DMS04440
- BNZ NOTXTA IF NONE, GIVE WARNING MESSAGE DMS04450
- SPACE DMS04460
- LST01A CLI LIBID,0 IF ENTRY IS NULL DMS04470
- BE LST01B THE SKIP IT DMS04480
- BAL R10,TYPENTRY ELSE TYPE IT DMS04490
- SPACE DMS04500
- LST01B LA R7,LIBSIZE(,R7) ELSE POINT TO NEXT ENTRY DMS04510
- BCT R5,LST01A AND TYPE IT IF NOT NULL DMS04520
- SPACE DMS04530
- *STEP 4: CHECK IF ANYTHING ACTUALLY TYPED AND EXIT CORRECTLY DMS04540
- * DMS04550
- TM FBITS,HDR IF SOMETHING WAS TYPED DMS04560
- BO EXIT00 THEN EXIT NORMALLY DMS04570
- TM OBITS,OPTYPE IF NOTYPE IN EFFECT DMS04580
- BNO EXIT04 THEN JUST EXIT DMS04590
- B NOTXTA ELSE ISSUE ERROR MESSAGE DMS04600
- EJECT DMS04610
- *********************************************************************** DMS04620
- * * DMS04630
- * E R R O R M E S S A G E S * DMS04640
- * * DMS04650
- *********************************************************************** DMS04660
- SPACE DMS04670
- * DMSRES003E DMS04680
- * DMS04690
- BADOPT DMSERR TEXT='INVALID OPTION ''........''',NUM=3,LET=E, XDMS04700
- SUB=(CHARA,(R8)) DMS04710
- B EXIT24 DMS04720
- SPACE DMS04730
- * DMSRES005E DMS04740
- * DMS04750
- NOPTV DMSERR TEXT='NO ''....'' SPECIFIED',NUM=5,LET=E, XDMS04760
- SUB=(CHARA,(R5)) DMS04770
- B EXIT24 DMS04780
- SPACE DMS04790
- * DMSRES014E DMS04800
- * DMS04810
- BADFUNC DMSERR TEXT='INVALID FUNCTION ''........''',NUM=14,LET=E, XDMS04820
- SUB=(CHARA,(R8)) DMS04830
- B EXIT24 DMS04840
- SPACE DMS04850
- * DMSRES026W DMS04860
- * DMS04870
- NOTXTL TM OBITS,OPTYPE IF TYPE IS SUPPRESSED DMS04880
- BNO EXIT04 THEN SKIP THE MESSAGE DMS04890
- NOTXT DMSERR TEXT='''........'' NOT IN LIBRARY',NUM=26,LET=W, XDMS04900
- SUB=(CHARA,LOADTXTN) DMS04910
- B EXIT04 DMS04920
- SPACE DMS04930
- * DMSRES026E DMS04940
- * DMS04950
- CONFLCTO LA R2,=CL9'OPTION' OPTION/FUNCTION CONFLICT DMS04960
- B CONFLCT DMS04970
- CONFLCTP LA R2,=CL9'PARAMETER' PARAMETER/FUNCTION CONFLICT DMS04980
- SPACE DMS04990
- CONFLCT DMSERR TEXT='INVALID ......... ''........'' FOR ''........'' XDMS05000
- FUNCTION',NUM=26,LET=E,SUB=(CHARA,(R2),CHARA,(R8), XDMS05010
- CHARA,FUNCNAME),RENT=NO DMS05020
- B EXIT24 DMS05030
- SPACE DMS05040
- * DMSRES027W DMS05050
- * DMS05060
- NOTXTA TM OBITS,OPTYPE IF NOTYPING WANTED DMS05070
- BNO EXIT04 THEN JUST EXIT DMS05080
- DMSERR TEXT='NO PRIVATE CORE IMAGE LIBRARY',NUM=27,LET=W DMS05090
- B EXIT04 DMS05100
- EJECT DMS05110
- * DMSRES029E DMS05120
- * DMS05130
- BADVAL DMSERR TEXT='INVALID PARAMETER ''........'' IN THE OPTION ''.XDMS05140
- .......'' FIELD',NUM=29,LET=E,RENT=NO, XDMS05150
- SUB=(CHARA,(R8),CHARA,(R5)) DMS05160
- B EXIT24 DMS05170
- SPACE DMS05180
- * DMSRES047E DMS05190
- * DMS05200
- NOFUNC DMSERR TEXT='NO FUNCTION SPECIFIED',NUM=47,LET=E DMS05210
- B EXIT24 DMS05220
- SPACE DMS05230
- * DMSRES050E DMS05240
- * DMS05250
- NOPARM DMSERR TEXT='PARAMETER MISSING AFTER ........',NUM=50,LET=E, XDMS05260
- SUB=(CHARA,FUNCNAME) DMS05270
- B EXIT24 DMS05280
- SPACE DMS05290
- * DMSRES109S DMS05300
- * DMS05310
- NOSTOR DMSERR TEXT='VIRTUAL STORAGE CAPACITY EXCEEDED',NUM=109,LET=S DMS05320
- B EXIT104 DMS05330
- SPACE DMS05340
- * DMSRES224E DMS05350
- * DMS05360
- DUPID DMSERR TEXT='........ ALREADY IN USE',NUM=224,LET=E, XDMS05370
- SUB=(CHARA,LOADTXTN) DMS05380
- B EXIT24 DMS05390
- SPACE DMS05400
- * EXIT HERE FOR RC = 0 DMS05410
- * DMS05420
- EXIT00 SR R15,R15 RC = 0 DMS05430
- EXITRC BR R11 RETURN TO CMS DMS05440
- SPACE DMS05450
- * EXIT HERE FOR RC = 4 DMS05460
- * DMS05470
- EXIT04 LA R15,4 RC = 4 DMS05480
- BR R11 RETURN DMS05490
- SPACE DMS05500
- * EXIT HERE FOR RC = 24 DMS05510
- * DMS05520
- EXIT24 LA R15,24 RC = 24 DMS05530
- BR R11 EXIT DMS05540
- SPACE DMS05550
- * EXIT HERE FOR RC = 104 DMS05560
- * DMS05570
- EXIT104 LA R15,104 RC = 104 DMS05580
- BR R11 EXIT DMS05590
- EJECT DMS05600
- *SUBROUTINE - DMS05610
- * SCANTAB DMS05620
- * SCANTABA DMS05630
- * DMS05640
- *FUNCTION - DMS05650
- * SCAN THE LIB TABLE FOR A NAME (SCANTAB) OR ADDRESS (SCANTABA) DMS05660
- * DMS05670
- *ENTRY CONDITIONS - DMS05680
- * R10 - RETURN ADDRESS DMS05690
- * ADDITIONALLY: DMS05700
- * IF FBITS = SEEKADR THEN R0 CONTAINS ADDRESS TO SEEK FOR. DMS05710
- * THIS ADDRESS CORRESPONDS TO THE LIBADR FIELD. DMS05720
- * IF FBITS ¬ SEEKADR THEN AREA LOADTXTN CONTAINS AN 8 CHAR DMS05730
- * NAME TO BE FOUND IN THE LIB TABLE. DMS05740
- * DMS05750
- *EXIT CONDITIONS - DMS05760
- * CC = 0 -> ENTRY FOUND, REGISTERS CONTAIN: DMS05770
- * R1 - A(MODULE ENTRY POINT) DMS05780
- * R2 - LENGTH OF STORAGE AREA ALLOCATED DMS05790
- * R3 - A(STORAGE AREA ALLOCATED) DMS05800
- * R7 - A(LIB TABLE ENTRY) DMS05810
- * R15- UNIQUE ENTRY NUMBER DMS05820
- * DMS05830
- * CC ¬ 0 -> MATCHING ENTRY NOT FOUND. DMS05840
- * DMS05850
- *NOTES - DMS05860
- * 1. IF THERE IS NO LIB TABLE ALLOCATED, THIS ROUTINE WILL GET DMS05870
- * ONE. THE LIB TABLE IS 4K LONG AND HOLDS ALL THE NAME TO DMS05880
- * ADDRESS MAPPINGS. DONE ONLY IF R0 = 0 AND SEEKADR SET ON. DMS05890
- * DMS05900
- * 2. IN ALL CASES, R0 - R3, R7, R14, R15 ARE MODIFIED. DMS05910
- * DMS05920
- * 3. EXIT MAY BE MADE DIRECTLY TO VARIOUS ERROR MESSAGES. DMS05930
- * DMS05940
- * 4. ENTRY SCANTABA MAY BE USED TO SET THE SEEKADR BIT ON. DMS05950
- SPACE DMS05960
- *STEP 1: GET A(LIB TABLE) AND CHECK IF ALLOCATED YET DMS05970
- * DMS05980
- SCANTABA OI FBITS,SEEKADR SET ADDRESS SEARCH ON DMS05990
- SPACE DMS06000
- SCANTAB BAL R14,GETLIB GET A(LIB TABLE) DMS06010
- BZ SCANTAB1 IF PRESENT, START SCAN DMS06020
- SPACE DMS06030
- *STEP 2: ALLOCATE A LIB TABLE ONLY IF SEARCHING FOR A FREE ENTRY DMS06040
- * DMS06050
- LTR R0,R0 IF NOT SEARCHING FOR 0 ENTRY DMS06060
- BNZR R10 THEN RETURN, NOTHING FOUND DMS06070
- TM FBITS,SEEKADR IF SEEKING BY ADDRESS DMS06080
- BO SCANTAB0 THEN GO ALLOCATE LIB TABLE DMS06090
- LTR R12,R12 ELSE SET CC¬0 DMS06100
- BR R10 AND RETURN DMS06110
- EJECT DMS06120
- *STEP 3: LIB TABLE IS NOT YET ALLOCATED, ALLOCATE IT DMS06130
- * DMS06140
- SCANTAB0 L R2,=F'4096' GET 4K FOR LIB TABLE DMS06150
- IC R7,LKEY GET WANTED KEY DMS06160
- MVI LKEY,0 PLACE LIB TABLE IN KEY 0 DMS06170
- ST R10,0(,R13) SAVE THE RPA REG DMS06180
- BAL R10,GETCORE ALLOCATE THE STORAGE DMS06190
- L R10,0(,R13) RESTORE RPA REG DMS06200
- STC R7,LKEY RESTORE WANTED KEY DMS06210
- BNZ NOSTOR IF NOT ALLOCATED, THEN ERROR DMS06220
- SPACE DMS06230
- *STEP 4: LOAD SPECIAL COMMAND PROCESSING ROUTINE AT START OF LIB TABLE DMS06240
- * DMS06250
- MVC ASTATE2(4),&STATE SET STATE ADDRESS IN CODE DMS06260
- ST R3,&STATE SET ANCHOR IN NUCON DMS06270
- LR R0,R3 R0 <- A(LIB TABLE) DMS06280
- LA R1,DMSRESRL R1 <- LENGTH(CODE) DMS06290
- LA R14,DMSRESRC R14 <- A(LOCAL CODE) DMS06300
- LR R15,R1 R15 <- LENGTH(CODE) DMS06310
- MVCL R0,R14 MOVE CODE OVER DMS06320
- LR R7,R0 SET STARTING ADDR OF LIBTABLE DMS06330
- SR R0,R0 CLEAR R0 ONCE AGAIN DMS06340
- SPACE DMS06350
- *STEP 5: SCAN THE LIB TABLE FOR THE MATCHING ENTRY DMS06360
- * DMS06370
- SCANTAB1 LA R15,LIBMAXN SCAN MAX ENTRIES DMS06380
- SPACE DMS06390
- SCANTAB2 LM R1,R3,LIBEPA ASSUME ENTRY WILL MATCH DMS06400
- TM FBITS,SEEKADR IF SEEKING BY ADDRESS DMS06410
- BO SCANTAB3 THEN PERFORM ADDRESS MATCH DMS06420
- CLC LIBID(8),LOADTXTN ELSE IF NAMES MATCH DMS06430
- BER R10 THEN RETURN W/ INFO DMS06440
- CLI LIBID,X'01' IF LIBENTRY IS NULL DMS06450
- BLR R10 THEN RETURN, END OF TABLE DMS06460
- B SCANTAB4 ELSE GO TO NEXT ENTRY DMS06470
- SPACE DMS06480
- SCANTAB3 CL R0,LIBADR IF ADDRESSES MATCH DMS06490
- BER R10 THEN RETURN WITH INFO DMS06500
- CLI LIBID,X'01' IF LIBENTRY IS NULL DMS06510
- BLR R10 THEN RETURN, END OF TABLE DMS06520
- SPACE DMS06530
- *STEP 6: BUMP TO NEXT LIB TABLE ENTRY AND PROCESS DMS06540
- * DMS06550
- SCANTAB4 LA R7,LIBSIZE(,R7) BUMP TO NEXT ENTRY DMS06560
- BCT R15,SCANTAB2 SCAN THE TABLE DMS06570
- BR R10 RETURN, NOT FOUND, CC¬=0 DMS06580
- EJECT DMS06590
- *SUBROUTINE - DMS06600
- * ADDNTRY DMS06610
- * DMS06620
- *FUNCTION - DMS06630
- * TO COMPLETE A LIB TABLE ENTRY DMS06640
- * DMS06650
- *ENTRY CONDITIONS - DMS06660
- * R1 - A(MODULE E.P.A) DMS06670
- * R2 - LENGTH OF STORAGE AREA DMS06680
- * R3 - A(STORAGE AREA) DMS06690
- * R7 - A(LIB TABLE ENTRY TO BE USED) DMS06700
- * ADDITIONALLY: AREA AT NEWNAME CONTAINS THE FNAME; DMS06710
- * LKEY CONTAINS THE STORAGE PROTECT KEY. DMS06720
- * DMS06730
- *EXIT CONDITIONS - DMS06740
- * NONE. DMS06750
- * DMS06760
- *NOTES - DMS06770
- * 1. LIBFLAGS ARE SET ACCORDING TO INDICATORS IN OBITS. DMS06780
- SPACE DMS06790
- *STEP 1: COMPLETE THE LIB TABLE ENTRY DMS06800
- * DMS06810
- ADDNTRY MVC LIBID(8),NEWNAME SUPPLY REAL NAME DMS06820
- STM R1,R3,LIBEPA SET EPA, LEN, ADDR DMS06830
- MVC LIBKEY(1),LKEY SET THE PKEY DMS06840
- MVI LIBFLAGS,0 CLEAR FLAGS DMS06850
- SPACE DMS06860
- *STEP 2: SET ENTRY FLAGS DMS06870
- * DMS06880
- TM OBITS,OPTPERM IF NOT PERM ENTRY DMS06890
- BNO *+8 THEN SKIP THE SET DMS06900
- OI LIBFLAGS,LIBPERM ELSE INDICATE PERM DMS06910
- TM OBITS,OPTSYS IF NOT SYSTEM SPACE DMS06920
- BNOR R10 THEN RETURN, ALL DONE DMS06930
- OI LIBFLAGS,LIBSYS ELSE INDICATE SYSTEM SPACE DMS06940
- BR R10 AND RETURN DMS06950
- EJECT DMS06960
- *SUBROUTINE - DMS06970
- * GETCORE DMS06980
- * DMS06990
- *FUNCTION - DMS07000
- * TO ALLOCATE ONE OR MORE PAGES OF NUCLEUS HIGH STORAGE DMS07010
- * PROTECTED PRIVATE (HIDDEN FROM CMS) STORAGE. DMS07020
- * DMS07030
- *ENTRY CONDITIONS - DMS07040
- * R2 - LENGTH, IN BYTES, TO BE ALLOCATED. DMS07050
- * R10 - RETURN ADDRESS DMS07060
- * DMS07070
- *EXIT CONDITIONS - DMS07080
- * CC = 0 -> STORAGE ALLOCATED, REGISTERS CONTAIN: DMS07090
- * R2 - LENGTH, IN BYTES, ACTUALLY ALLOCATED. DMS07100
- * R3 - A(STORAGE AREA) ALLOCATED. DMS07110
- * CC ¬ 0 -> INSUFFICIENT STORAGE. DMS07120
- * DMS07130
- *NOTES - DMS07140
- * 1. R0 - R3, R14, R15 MODIFIED. DMS07150
- SPACE DMS07160
- *STEP 1: ROUND REQUESTORS LENGTH TO NEAREST 4K SIZE. WE CAN ONLY DMS07170
- * ALLOCATE STORAGE IN UNITS OF PAGES. DMS07180
- * DMS07190
- GETCORE LA R2,4095(,R2) ADD A TAD LESS THAN 4K DMS07200
- SRL R2,12 SHIFT DOWN DMS07210
- SLL R2,12 AND UP, WE NOW HAVE A GOOD NUMBER DMS07220
- SPACE DMS07230
- *STEP 2: ADD 4K MORE TO IT SO THAT WE CAN BE ASSURED THAT WHEN WE DMS07240
- * TRIM THE EXCESS THE RESULTING AREA WILL WIND UP ON A PAGE DMS07250
- * BOUNDARY. ONCE DONE, ALLOCATE HIGH NUCLEUS STORAGE. DMS07260
- * DMS07270
- AL R2,=F'4096' ADD 4K TO REQUESTED SIZE DMS07280
- LR R0,R2 COPY IT DMS07290
- SRL R0,3 CONVERT TO DWORDS FOR DMSFREE DMS07300
- DMSFREE DWORDS=(0),TYPE=NUCLEUS,AREA=HIGH,ERR=GETCORE6 DMS07310
- SPACE DMS07320
- *STEP 3: CHECK IF CMS ALLOCATED ON A PAGE BOUNDARY. IF IT DID THEN DMS07330
- * WE JUST NEED TO TRIM THE TOP 4K OFF. ELSE, WE MUST TRIM DMS07340
- * STORAGE ON BOTH SIDE OF THE AREA. DMS07350
- * DMS07360
- LA R1,0(,R1) CLEAR TOP BYTE DMS07370
- LA R3,4095(,R1) ADD A TAD LESS THAN 4K TO ADDRESS DMS07380
- N R3,=X'00FFF000' STRIP LOW 12 BITS DMS07390
- CLR R1,R3 IF RESULT IS NOT THE SAME AS ORGINAL DMS07400
- BNE GETCORE2 THEN AREA WAS NOT ON PAGE BOUNDARY DMS07410
- EJECT DMS07420
- *STEP 4: RELEASE THE 1ST 4K OF THE STORAGE AREA AND ADJUST THE DMS07430
- * STRTING ADDRESS AND LENGTH BY THE SAME AMOUNT. DMS07440
- * DMS07450
- L R0,=F'4096' GET 4K DMS07460
- ALR R3,R0 ADJUST STARTING ADDRESS DMS07470
- SLR R2,R0 DECREASE THE LENGTH BY 4K DMS07480
- SRL R0,3 COMPUTE DWORDS TO RELEASE DMS07490
- DMSFRET DWORDS=(0),LOC=(1) FREE 1ST 4K DMS07500
- B GETCORE3 GO FINISH UP DMS07510
- SPACE DMS07520
- *STEP 5: RELEASE AS MUCH STORAGE AS NECESSARY (LESS THAN 4K GAURENTEED) DMS07530
- * SO THAT THE ALLOCATED STORAGE AREA START ON A PAGE BNDRY. DMS07540
- * NOTE THAT WE HAVE IN R3 THE ADDRESS WE WOULD LIKE THE AREA DMS07550
- * TO START AT AND R1 CONTAINS THE ORGINAL ADDRESS. THUS THE DMS07560
- * DIFFERENCE WILL BE THE AMOUNT WE HAVE TO RELEASE. DMS07570
- * DMS07580
- GETCORE2 LR R0,R3 R0 <- WANTED STARTING ADDRESS DMS07590
- SR R0,R1 LESS ACTUAL ADDRESS YIELDS EXCESS DMS07600
- SR R2,R0 SUBTRACT EXCESS FROM AREA LENGTH DMS07610
- SRL R0,3 COMPUTE DWORDS DMS07620
- DMSFRET DWORDS=(0),LOC=(1) FREE THE STORAGE AREA DMS07630
- SPACE DMS07640
- *STEP 6: WE MUST NOW FREE THE EXCESS AT THE END OF OUR STORAGE AREA. DMS07650
- * THIS IS EASILY COMPUTED SINCE WE KNOW THAT THE LENGTH OF THE DMS07660
- * STORAGE AREA MUST BE EXACTLY A MULTIPLE OF 4K, WE NEED ONLY DMS07670
- * TO RELEASE THE AMOUNT INDICATED IN THE LOW ORDER 12 BITS OF DMS07680
- * THE ACTUAL LENGTH QUANTITY AND ADJUST THE LENGTH BY THAT DMS07690
- * AMOUNT. THIS THE STORAGE AREA WILL BE IN PAGE CIRCUMSCRIBED DMS07700
- * BOUNDARIES. DMS07710
- * DMS07720
- LR R0,R2 R0 <- CURRENT LENGTH OF AREA DMS07730
- N R0,=F'4095' ISOLATE LOW ORDER 12 BITS DMS07740
- SR R2,R0 SUBTRACT EXCESS OF ORIGINAL LENGTH DMS07750
- LR R1,R3 R1 <- A(STORAGE AREA) DMS07760
- ALR R1,R2 POINT TO STARTING AREA TO FREE DMS07770
- SRL R0,3 GET DWORDS DMS07780
- DMSFRET DWORDS=(0),LOC=(1) FREE THE STORAGE AREA DMS07790
- SPACE DMS07800
- *STEP 7: WE MUST NOW ADJUST THE AMOUNT CMS KEEPS TRACK OF AS SYSTEM DMS07810
- * ALLOCATED BY THE AMOUNT WE HAVE ALLOCATED FOR OURSELVES. DMS07820
- * THIS WILL PREVENT CMS FROM EVER MISSING THE STORAGE AREA. DMS07830
- * DMS07840
- GETCORE3 L R15,ADMSFRT GET A(FRETAB) DMS07850
- USING FRDSECT,R15 DMS07860
- L R1,FREELOW1 GET ORIGINAL HIGH WATER MARK DMS07870
- SLR R1,R2 ADJUST BY THE AMOUNT WE ALLOCATED DMS07880
- ST R1,FREELOW1 AND UPDATE IT DMS07890
- DROP R15 DMS07900
- EJECT DMS07910
- *STEP 8: CLEAR THE STORAGE AREA TO ZEROES DMS07920
- * DMS07930
- LR R0,R3 R0 <- A(AREA) DMS07940
- LR R1,R2 R1 <- L(AREA) DMS07950
- SR R15,R15 ZERO FOR PAD MVCL DMS07960
- MVCL R0,R14 CLEAR THE AREA DMS07970
- SPACE DMS07980
- *STEP 9: SET PROTECT KEYS AND RETURN DMS07990
- * DMS08000
- BAL R14,SETKEY SET PKEYS DMS08010
- SR R15,R15 SET CC=0 DMS08020
- BR R10 AND RETURN DMS08030
- SPACE DMS08040
- *STEP 10: ON ERROR, RETURN WITH CC ¬= 0 DMS08050
- * DMS08060
- GETCORE6 LTR R12,R12 SET CC ¬ 0 DMS08070
- BR R10 AND RETURN DMS08080
- EJECT DMS08090
- *SUBROUTINE - DMS08100
- * SETKEY DMS08110
- * DMS08120
- *FUNCTION - DMS08130
- * TO SET STORAGE PROTECT KEYS DMS08140
- * DMS08150
- *ENTRY CONDITIONS - DMS08160
- * R2 - LENGTH(AREA) IN BYTES DMS08170
- * R3 - A(AREA) DMS08180
- * R14 - RETURN ADDRESS DMS08190
- * *** - LKEY CONTAINS THE PROTECT KEY RIGHT JUSTIFIED. DMS08200
- * DMS08210
- *EXIT CONDITIONS - DMS08220
- * NONE. DMS08230
- SPACE DMS08240
- *STEP 1: SET UP FOR SSK INSTRUCTION DMS08250
- * DMS08260
- SETKEY LR R0,R2 R0 <- L(AREA) DMS08270
- SRL R0,11 CONVERT TO NUMBER OF PAGES * 2 DMS08280
- LR R1,R3 R1 <- A(AREA) DMS08290
- IC R15,LKEY GET PROTECT KEY DMS08300
- SLL R15,4 SHIFT INTO CORRECT POSITION DMS08310
- SPACE DMS08320
- *STEP 2: SET STORAGE TO CORRECT PROTECT KEY DMS08330
- * DMS08340
- SETKEY01 SSK R15,R1 SET PROTECT KEY DMS08350
- LA R1,2048(,R1) NEXT 2K BOUNDARY DMS08360
- BCT R0,SETKEY01 DO ALL PAGES DMS08370
- BR R14 AND RETURN DMS08380
- EJECT DMS08390
- *SUBROUTINE - DMS08400
- * RELNTRY DMS08410
- * DMS08420
- *FUNCTION - DMS08430
- * TO RELEASE A LIBRARY ENTRY AND IF LAST ONE RELEASED, TO DMS08440
- * TO RELEASE THE LIBRARY DIRECTORY PAGE. DMS08450
- * DMS08460
- *ENTRY CONDITIONS - DMS08470
- * R7 - A(LIB ENTRY) TO FREE DMS08480
- * R10 - RETURN ADDRESS DMS08490
- * DMS08500
- *EXIT CONDITIONS - DMS08510
- * CC = 0 -> LIBRARY DIRECTORY PAGE RELEASED, R7 IS ZERO. DMS08520
- * CC ¬ 0 -> LIBRARY ENTRY RELEASED, DIRECTORY NOT EMPTY. DMS08530
- * R7 HOLDS NEXT ENTRY ADDRESS. DMS08540
- * DMS08550
- *NOTES - DMS08560
- * 1. R0 - R3, R14, R15 MODIFIED. DMS08570
- SPACE DMS08580
- *STEP 1: COMPUTE NUMBER OF BYTES LEFT AFTER CURRENT ENTRY DMS08590
- * DMS08600
- RELNTRY LA R1,LIBTLEN R1 <- LEN(LIB TAB) DMS08610
- AL R1,&STATE R1 <- A(LAST LIB TABLE BYTE)-PREFIX DMS08620
- LA R1,DMSRESRL(,R1) R1 <- A(LAST LIB TABLE BYTE) + 1 DMS08630
- SLR R1,R7 R1 <- ENDLOC - CURLOC (NUM BYTES) DMS08640
- LR R0,R7 R0 <- A(CURRENT ENTRY) DMS08650
- SPACE DMS08660
- *STEP 2: COMPUTE NUMBER OF BYTES TO BE MOVED AT ENTRY+1 DMS08670
- * DMS08680
- LA R14,LIBSIZE R1 <- SIZE(EACH ENTRY) DMS08690
- LR R15,R1 R15<- TOTAL LENGTH INC CUR_ENTRY DMS08700
- SLR R15,R14 R15<- TOTAL LENGTH AFTER CURRENT ENT DMS08710
- ALR R14,R0 R14<- A(NEXT ENTRY) DMS08720
- SPACE DMS08730
- *STEP 3: COMPRESS OUT THE DELETED ENTRY AND CHECK IF LIB TABLE EMPTY DMS08740
- * DMS08750
- MVCL R0,R14 COMPRESS LIB TABLE DMS08760
- L R3,&STATE R3 <- A(LIB TABLE) DMS08770
- CLI DMSRESRL(R3),0 IF FIRST ENTRY IS NOT NULL DMS08780
- BNER R10 THEN RETURN, ALL DONE DMS08790
- SPACE DMS08800
- *STEP 4: LIB TABLE IS EMPTY, RELEASE ITS STORAGE DMS08810
- * DMS08820
- MVC &STATE.(4),ASTATE2-DMSRESRC(R3) RESET STATE ADDRESS DMS08830
- L R2,=F'4096' GET SIZE(LIB TABLE) DMS08840
- ST R10,0(,R13) SAVE RPA DMS08850
- BAL R10,RELCORE RELEASE THE STORAGE DMS08860
- L R10,0(,R13) RESTORE RPA DMS08870
- SR R7,R7 NULL OUT ENTRY POINTER DMS08880
- BR R10 RETURN WITH CC = 0 DMS08890
- EJECT DMS08900
- *SUBROUTINE - DMS08910
- * RETNTRY DMS08920
- * DMS08930
- *FUNCTION - DMS08940
- * TO PLACE A VALUE IN THE CALLER'S REG 1. DMS08950
- * DMS08960
- *ENTRY CONDITIONS - DMS08970
- * R1 - VALUE TO BE RETURNED DMS08980
- * R10 - RETURN ADDRESS DMS08990
- * DMS09000
- *EXIT CONDITIONS - DMS09010
- * NONE. DMS09020
- * DMS09030
- *NOTES - DMS09040
- * 1. R15 MODIFIED. DMS09050
- SPACE DMS09060
- *STEP 1: RETURN VALUE TO CALLER DMS09070
- * DMS09080
- RETNTRY L R15,ASVCSECT GET A(SVCSECT) DMS09090
- L R15,CURRALOC-SVCSECT(,R15) GET A(SSAVE) DMS09100
- ST R1,EGPR1-SSAVE(,R15) SET NEW VALUE DMS09110
- BR R10 AND RETURN DMS09120
- EJECT DMS09130
- *SUBROUTINE - DMS09140
- * SCANP DMS09150
- * DMS09160
- *FUNCTION - DMS09170
- * TO CHECK IF WE ARE POINTING TO THE END OF THE PARAMS. DMS09180
- * DMS09190
- *ENTRY CONDITIONS - DMS09200
- * R8 - A(CURRENT TOKEN) DMS09210
- * R10 - RETURN ADDRESS DMS09220
- * DMS09230
- *EXIT CONDITIONS - DMS09240
- * CC = 0 -> END OF PARAM DATA FOUND. DMS09250
- * CC ¬ 0 -> MORE PARAM DATA EXISTS DMS09260
- SPACE DMS09270
- *STEP 1: SET CC BASED ON CONTENTS OF TOKEN DMS09280
- * DMS09290
- SCANP CLI 0(R8),X'FF' IF PLIST END DMS09300
- BER R10 THEN RETURN W/ CC=0 DMS09310
- CLC 0(2,R8),=C'( ' IF OPTION LIST STARTING DMS09320
- BR R10 THEN RETURN, AS CC IS SET DMS09330
- EJECT DMS09340
- *SUBROUTINE - DMS09350
- * GETLIB DMS09360
- * DMS09370
- *FUNCTION - DMS09380
- * TO GET A(LIB TABLE) DMS09390
- * DMS09400
- *ENTRY CONDITIONS - DMS09410
- * R14 - RETURN ADDRESS DMS09420
- * DMS09430
- *EXIT CONDITIONS - DMS09440
- * CC = 0 -> LIB TABLE ALLOCATED; R7 HOLDS THE ADDRESS. DMS09450
- * CC ¬ 0 -> LIB TABLE NOT ALLOCATED; R7 MEANINGLESS. DMS09460
- SPACE DMS09470
- *STEP 1: GET THE A(LIB TABLE PREFIX) AND COMPUTE THE TRUE ADDRESS DMS09480
- * DMS09490
- GETLIB L R7,&STATE GET A(CODE AREA) DMS09500
- LA R7,DMSRESRL(,R7) POINT TO START OF TABLE DMS09510
- SPACE DMS09520
- *STEP 2: CHECK IF LIB TABLE TRULY ALLOCATED DMS09530
- * DMS09540
- CL R7,AUSRAREA IF A(LIB TABLE) < USER AREA DMS09550
- BLR R14 THEN RETURN DMS09560
- CL R7,VMSIZE IF A(LIB TABLE) > LAST LOC DMS09570
- BHR R14 THEN RETURN DMS09580
- CLR R14,R14 ELSE SET CC = 0 DMS09590
- BR R14 AND RETURN DMS09600
- EJECT DMS09610
- *SUBROUTINE - DMS09620
- * GETLEN DMS09630
- * DMS09640
- *FUNCTION - DMS09650
- * TO COMPUTE THE LEN-1 OF A TOKEN. DMS09660
- * DMS09670
- *ENTRY CONDITIONS - DMS09680
- * R8 - A(TOKEN TO SCAN) DMS09690
- * R10 - RETURN ADDRESS DMS09700
- * DMS09710
- *EXIT CONDITIONS - DMS09720
- * R1 - LENGTH-1(TOKEN) DMS09730
- * R2 - A(LAST NON-BLANK CHAR) IN TOKEN DMS09740
- SPACE DMS09750
- *STEP 1: SCAN BACKWARDS FOR FIRTS NON-BLANK DMS09760
- * DMS09770
- GETLEN LA R1,7 SET UP FOR LEN COMP DMS09780
- LA R2,7(,R8) POINT TO LAST CHAR IN TOKEN DMS09790
- SPACE DMS09800
- GETLENA CLI 0(R2),C' ' IF CHAR ¬= ' ' DMS09810
- BNER R10 THEN DONE, FOUND THE LEN-1 DMS09820
- BCTR R2,0 ELSE BACK UP 1 CHAR DMS09830
- BCT R1,GETLENA AND CHECK CHAR OUT (DEC COUNT) DMS09840
- BR R10 ALL DONE, RETURN DMS09850
- EJECT DMS09860
- *SUBROUTINE - DMS09870
- * GETNUM DMS09880
- * DMS09890
- *FUNCTION - DMS09900
- * TO COMPUTE THE BINARY VALUE OF AN EBCDIC STRING. DMS09910
- * DMS09920
- *ENTRY CONDITIONS - DMS09930
- * R1 - LEN-1(TOKEN) DMS09940
- * R8 - A(TOKEN) TO CONVERT DMS09950
- * R10 - RETURN ADDRESS DMS09960
- * DMS09970
- *EXIT CONDITIONS - DMS09980
- * CC = 0 -> NUMBER CONVERTED, R15 HOLDS VALUE. DMS09990
- * CC ¬ 0 -> NUMBER INVALID OR GREATER THAN 256. DMS10000
- * DMS10010
- *NOTES - DMS10020
- * 1. R0 IS MODIFIED. DMS10030
- SPACE DMS10040
- *STEP 1: PREPARE TO SCAN FOR INVALID DIGITS DMS10050
- * DMS10060
- GETNUM LA R0,1(,R1) GET FULL LENGTH DMS10070
- LR R15,R8 R15 <- A(TOKEN) DMS10080
- SPACE DMS10090
- *STEP 2: MAKE SURE ALL DIGITS ARE VALID DMS10100
- * DMS10110
- GETNUM1 CLI 0(R15),C'0' IF CHAR < '0' DMS10120
- BLR R10 THEN INVALID DMS10130
- CLI 0(R15),C'9' IF CHAR > '9' DMS10140
- BHR R10 THEN INVALID DMS10150
- LA R15,1(,R15) ELSE BUMP TO NEXT ONE DMS10160
- BCT R0,GETNUM1 AND CHECK NEXT ONE OUT DMS10170
- SPACE DMS10180
- *STEP 3: CONVERT THE ACTUAL STRING TO BINARY DMS10190
- * DMS10200
- EX R1,PACK PACK THE VALUE DMS10210
- CP 0(8,R13),=PL2'256' IF VALUE > 256 DMS10220
- BHR R10 THEN INVALID DMS10230
- CVB R15,0(,R13) ELSE CONVERT TO BINARY DMS10240
- LA R0,1 GET A COMPARE CONSTANT DMS10250
- CR R15,R0 IF VALUE < 1 DMS10260
- BLR R10 THEN ZERO AND IS INVALID DMS10270
- SR R0,R0 ELSE SET CC = 0 DMS10280
- BR R10 AND RETURN DMS10290
- EJECT DMS10300
- *SUBROUTINE - DMS10310
- * RELCORE DMS10320
- * DMS10330
- *FUNCTION - DMS10340
- * TO RELEASE PRIVATE STORAGE GOTTEN BY GETCORE. DMS10350
- * DMS10360
- *ENTRY CONDITIONS - DMS10370
- * R2 - AMOUNT OF BYTES, TRUE, TO BE FREED. DMS10380
- * R3 - A(STORAGE AREA) TO BE FREED. DMS10390
- * R10 - RETURN ADDRESS. DMS10400
- * DMS10410
- *EXIT CONDITIONS - DMS10420
- * NONE. DMS10430
- SPACE DMS10440
- *STEP 1: RESET THE PROTECT KEYS AND FREE THE STORAGE AREA DMS10450
- * DMS10460
- RELCORE MVI LKEY,X'0F' SET KEY X'F0' DMS10470
- BAL R14,SETKEY SET THE PKEYS DMS10480
- LR R0,R2 COPY BYTES DMS10490
- SRL R0,3 GET DWORDS DMS10500
- LR R1,R3 GET ADDRESS DMS10510
- DMSFRET DWORDS=(0),LOC=(1) DMS10520
- SPACE DMS10530
- *STEP 2: ADJUST THE CMS FREETAB SO THAT CMS WILL GET ITS STORAGE DMS10540
- * BACK. IF WE DID NOT, CMS WOULD DIE. DMS10550
- * DMS10560
- L R15,ADMSFRT GET A(FREETAB) DMS10570
- USING FRDSECT,R15 DMS10580
- L R1,FREELOW1 GET LOW WATER MARK DMS10590
- ALR R1,R2 ADJUST IT UPWARDS DMS10600
- ST R1,FREELOW1 UPDATE IT DMS10610
- BR R10 AND RETURN DMS10620
- DROP R15 DMS10630
- EJECT DMS10640
- *SUBROUTINE - DMS10650
- * LOADTXT DMS10660
- * DMS10670
- *FUNCTION - DMS10680
- * TO LOAD A TEXT DECK INTO PRIVATE STORAGE. DMS10690
- * DMS10700
- *ENTRY CONDITIONS - DMS10710
- * R3 - ADDRESS AT WHICH THE ROUTINE IS TO BE LOADED. DMS10720
- * R10 - RETURN ADDRESS DMS10730
- * DMS10740
- *EXIT CONDITIONS - DMS10750
- * CC = 0 -> ROUTINE LOADED. REGISTERS CONTAIN: DMS10760
- * R0 - A(NEXT LOAD POINT) DMS10770
- * R1 - ENTRY POINT ADDRESS FROM THE LOADER. DMS10780
- * CC ¬ 0 -> ERROR DURING LOAD. DMS10790
- * DMS10800
- *NOTES - DMS10810
- * 1. IN ALL CASES, R0, R1, R14, R15 ARE MODIFIED. DMS10820
- SPACE DMS10830
- *STEP 1: PLUG IN THE ORIGIN ADDRESS INTO THE COMMAND LINE DMS10840
- * DMS10850
- LOADTXT LINEDIT TEXT='........',BUFFA=LOADTXTA,DOT=NO,DISP=NONE, XDMS10860
- SUB=(HEX,(R3)) DMS10870
- MVI LOADTXTA,C' ' REMOVE THE LENGTH FIELD DMS10880
- SPACE DMS10890
- *STEP 2: INDICATE THAT IT IS OK TO LOAD ANYWHERE AND ISSUE THE LOAD DMS10900
- * COMMAND VIA SVC 202. NOTE THAT THE CALLER MUST HAVE FILLED DMS10910
- * IN THE NAME OF THE TEXT DECK TO BE LOADED AT LOADTXTN. DMS10920
- * DMS10930
- OI MODFLGS,SYSLOAD TELL LOADER TO SKIP CHECKS DMS10940
- LA R1,LOADTXTC POINT TO COMMAND LINE DMS10950
- SVC 202 ISSUE COMMAND SVC DMS10960
- DC AL4(*+4) DMS10970
- SPACE DMS10980
- *STEP 3: PICK UP THE EPA THAT THE LOADER LEFT IN NUCON AND ZERO OUT DMS10990
- * THE LOCATION COUNTER SO THAT THE NEXT LOAD DOES NOT FAIL DMS11000
- * BECAUSE THE LOADER WILL TRY TO LOAD AFTER THAT LOC. THEN DMS11010
- * EXIT BASED ON THE RC FROM THE LOADER. DMS11020
- * DMS11030
- L R0,LOCCNT GET NEXT LOAD POINT DMS11040
- L R1,STRTADDR GET EPA DMS11050
- XC LOCCNT(4),LOCCNT ZERO OUT LOC COUNTER DMS11060
- LTR R15,R15 SET CC BASED ON RC DMS11070
- BR R10 AND RETURN DMS11080
- EJECT DMS11090
- *SUBROUTINE - DMS11100
- * TYPENTRY DMS11110
- * DMS11120
- *FUNCTION - DMS11130
- * TO TYPE OR STACK A LIB TABLE ENTRY DMS11140
- * DMS11150
- *ENTRY CONDITIONS - DMS11160
- * R7 - A(LIB TABLE ENTRY) DMS11170
- * R10 - RETURN ADDRESS DMS11180
- * DMS11190
- *EXIT CONDITIONS - DMS11200
- * IF SOMETHING WAS STACKED OR TYPED, HDR FLAG IS SET. DMS11210
- * DMS11220
- *NOTES - DMS11230
- * 1. THE CALLER MUST INDICATE IF TYPING OR STACKING IS DMS11240
- * WANTED BY THE OPTSTK & OPTYPE FLAG IN OBITS. DMS11250
- * DMS11260
- * 2. R0 - R4, R14, R15 MODIFIED. DMS11270
- SPACE DMS11280
- *STEP 1: CHECK IF A HEADER LINE IS TO BE TYPED. DMS11290
- * DMS11300
- TYPENTRY TM FBITS,HDR IF WE TYPED A HDR DMS11310
- BO TYPENTRX THEN SKIP TYPING IT AGAIN DMS11320
- OI FBITS,HDR ELSE INDICATE WE HAVE TYPED DMS11330
- TM OBITS,OPNTYPE IF NOTYPE IS REQUESTED DMS11340
- BO TYPENTRX THEN SKIP THE HEADER LINE DMS11350
- WRTERM 'ENTRY ID E.P.A. PAGE AMT KEY ATTRIBUTES' DMS11360
- SPACE DMS11370
- *STEP 2: GATHER ALL INFORMATION TO BE TYPED OR STACKED DMS11380
- * DMS11390
- TYPENTRX TM OBITS,OPTYPE+OPTSTK IF NOTYPE & NOSTACK DMS11400
- BZR R10 THEN ALL DONE DMS11410
- MVC STSAVE(8),=8C' ' ELSE CLEAR AREA DMS11420
- TM LIBFLAGS,LIBPERM IF FLAG NOT SET DMS11430
- BNO *+10 THEN NOT PERM DMS11440
- MVC STSAVE(4),=C'PERM' ELSE INDICATE PERM DMS11450
- TM LIBFLAGS,LIBSYS IF INDICATOR NOT SET DMS11460
- BNO *+10 THEN NOT SYSTEM ROUTINE DMS11470
- MVC STSAVE+5(3),=C'SYS' ELSE INDICATE SYSTEM DMS11480
- LM R2,R3,LIBLEN GET LENGTH AND LOC DMS11490
- SRL R2,12 COMPUTE NUMBER OF PAGES DMS11500
- SRL R3,12 COMPUTE PAGE NUMBER DMS11510
- SR R4,R4 PREPARE FOR IC DMS11520
- IC R4,LIBKEY GET STORAGE KEY DMS11530
- EJECT DMS11540
- *STEP 3: FORMAT THE DATA TO BE TYPED DMS11550
- * DMS11560
- LINEDIT TEXT='........ ...... ... ... .. ........', XDMS11570
- DOT=NO,COMP=NO,RENT=NO,DISP=NONE,BUFFA=BUFFER, XDMS11580
- SUB=(CHARA,LIBID,HEXA,LIBEPA,HEX,(R3),DEC,(R2), XDMS11590
- DEC,(R4),CHARA,STSAVE) DMS11600
- SPACE DMS11610
- *STEP 4: CHECK IS WE MUST TYPE THE RESULTING DATA DMS11620
- * DMS11630
- TM OBITS,OPTYPE IF NOTYPING DMS11640
- BNO TYPENTRW THEN SKIP THE WRTERM DMS11650
- SR R2,R2 ELSE PREPARE FOR IC DMS11660
- IC R2,BUFFER GET THE ACTUAL LENGTH DMS11670
- WRTERM BUFFER+1,(2) WRITE THE LINE DMS11680
- SPACE DMS11690
- *STEP 4: CHECK IF WE MUST STACK THE LINE DMS11700
- * DMS11710
- TYPENTRW TM OBITS,OPTSTK IF STACK NOT WANTED DMS11720
- BNOR R10 THEN RETURN DMS11730
- MVC TYPENTRL(1),BUFFER ELSE SET THE LENGTH DMS11740
- LA R1,TYPENTRP POINT TO STACK PLIST DMS11750
- SVC 202 STACK THE LINE DMS11760
- BR R10 AND RETURN DMS11770
- SPACE 2 DMS11780
- * STACK PLIST DMS11790
- * DMS11800
- TYPENTRP DC CL8'ATTN',C'FIFO' DMS11810
- TYPENTRL DC AL4(BUFFER+1) DMS11820
- EJECT DMS11830
- *********************************************************************** DMS11840
- * * DMS11850
- * S T O R A G E A R E A S & C O N S T A N T S * DMS11860
- * * DMS11870
- *********************************************************************** DMS11880
- SPACE DMS11890
- * EXECUTED COMMANDS DMS11900
- * DMS11910
- PACK PACK 0(8,R13),0(0,R8) PACK A VALUE DMS11920
- CLCOPT CLC OPTNAME-OPTBLOK(*-*,R5),0(R8) CHECK OPTIONA NAME DMS11930
- CLCSYN CLC LOADTXTN(*-*),8(R3) LOOK FOR SYNONYM DMS11940
- CLCFUNC CLC FUNCNAME(*-*),0(R8) CHECK FUNCTION NAME DMS11950
- SPACE DMS11960
- * LOAD COMMAND LINE DMS11970
- * DMS11980
- LOADTXTC DC CL8'LOAD' DMS11990
- LOADTXTN DC 8C' ',CL8'(',CL8'NOMAP',CL7'ORIGIN' DMS12000
- LOADTXTA DC 9C' ',8X'FF' DMS12010
- SPACE DMS12020
- * VALID FUNCTION TABLE DMS12030
- * DMS12040
- FUNCTAB DC CL8'ALLOCATE',AL1(NAMOK+PERMOK+KEYOK,0) DMS12050
- B ALO -> FUNCTION DMS12060
- DC CL8'DELETE',AL1(0,0) DMS12070
- B DELT -> FUNCTION DMS12080
- DC CL8'LIST',AL1(TYPOK+STKOK,SKPNAME) DMS12090
- B LST DMS12100
- FUNCTABE DC CL8'LOAD',AL1(PERMOK+SYSOK+NAMOK,0) DMS12110
- B LOADF DMS12120
- SPACE DMS12130
- * VALID OPTION TABLE DMS12140
- * DMS12150
- OPTABLE DC CL8'KEY',AL1(KEYOK,OPTKEY,255,2) DMS12160
- CHKKEY EQU OPTABLE DMS12170
- CHKNAMO DC CL8'NAME',AL1(NAMOK,OPTNAM,255,3) DMS12180
- DC CL8'NOTYPE',AL1(TYPOK,OPNTYPE,255-OPTYPE,2) DMS12190
- DC CL8'PERM',AL1(PERMOK,OPTPERM,255,3) DMS12200
- DC CL8'STACK',AL1(STKOK,OPTSTK,255,4) DMS12210
- DC CL8'SYSTEM',AL1(SYSOK,OPTSYS,255,2) DMS12220
- OPTABND DC CL8'TYPE',AL1(TYPOK,OPTYPE,255-OPNTYPE,0) DMS12230
- EJECT DMS12240
- * MISC. DMS12250
- * DMS12260
- SAVENUM DC H'0' SAVE AREA FOR NUMBER DMS12270
- NEWNAME DC 8C' ' NEW NAME FOR NAME OPTION DMS12280
- LKEY DC X'00' REQUESTED PROTECT KEY DMS12290
- SPACE DMS12300
- OBITS DC X'00' OPTION FLAG BYTE DMS12310
- OPTPERM EQU X'01' PERM OPTION IN EFFECT DMS12320
- OPTSTK EQU X'02' STACK OPTION IN EFFECT DMS12330
- OPTYPE EQU X'04' TYPE OPTION IN EFFECT DMS12340
- OPNTYPE EQU X'08' NOTYPE OPTION SPECIFIED DMS12350
- OPTSYS EQU X'10' SYSTEM OPTION IN EFFECT DMS12360
- OPTNAM EQU X'20' NAME OPTION IN EFFECT DMS12370
- OPTKEY EQU X'40' KEY OPTION IN EFFECT DMS12380
- SPACE DMS12390
- FBITS DC X'00' MORE FLAGS DMS12400
- HDR EQU X'10' HEADER HAS BEEN TYPED DMS12410
- SEEKADR EQU X'20' SCANTAB TO SEARCH VIA ADDRESS DMS12420
- SPACE DMS12430
- BUFFER DC 50C' ' DMS12440
- DTEMP DS 1D DOUBLEWORD WORK AREA DMS12450
- SPACE DMS12460
- LTORG DMS12470
- EJECT DMS12480
- *********************************************************************** DMS12490
- * * DMS12500
- * R E S I D E N T C O M M A N D P R O C E S S I N G * DMS12510
- * * DMS12520
- *********************************************************************** DMS12530
- SPACE DMS12540
- *STEP 1: MAKE SURE THAT ENTRY IS FROM DMSMOD VIA DMSITS DMS12550
- * DMS12560
- DS 0D ALIGN ON CORRECT BOUNDARY DMS12570
- USING *,R15 DMS12580
- DMSRESRC STM R0,R7,STSAVE SAVE SOME REGS DMS12590
- LA R0,0(,R11) CLEAR TOP BYTE OF RETADDR DMS12600
- CL R0,ACMSRET IF RETADDR >= DMSITS RPA DMS12610
- BNL FINDRES4 THEN NOT PROPER CALL DMS12620
- CLR R0,R5 IF RETADDR < DMSITS BASE ADDRESS DMS12630
- BNH FINDRES4 THEN NOT PROPER CALL DMS12640
- SPACE DMS12650
- *STEP 2: MAKE SURE THAT THIS IS A PROPER DMSMOD CALLING SEQUENCE DMS12660
- * DMS12670
- CL R10,AFVS IF R10 ¬- A(FVSECT) DMS12680
- BNE FINDRES4 THEN INVALID CALL DMS12690
- LA R0,0(,R7) GET PARM ADDRESS DMS12700
- L R3,ASVCSECT GET A(SVCSECT) DMS12710
- LA R2,MODLIST-SVCSECT(,R3) POINT TO DMSITS PLIST DMS12720
- CLR R2,R0 IF NOT CORRECT PLIST DMS12730
- BNE FINDRES4 THEN BAG IT DMS12740
- SPACE DMS12750
- *STEP 3: INITIALIZE FOR DMSRESRC PROCESSING DMS12760
- * DMS12770
- LA R7,DMSRESRL(,R15) POINT TO START OF TABLE DMS12780
- LA R0,LIBMAXN GET MAX NUMBER OF ENTRIES DMS12790
- SPACE DMS12800
- *STEP 4: ATTEMPT TO FIND RESIDENT COMMAND IN LIB TABLE DMS12810
- * DMS12820
- FINDRES1 CLC LIBID(8),8(R1) IF COMMAND NAMES THE SAME DMS12830
- BE FINDRES2 THEN POSSIBLE MATCH DMS12840
- CLI LIBID,X'01' IF END OF LIST FOUND DMS12850
- BL FINDRES4 THEN COMMAND NOT FOUND DMS12860
- LA R7,LIBSIZE(,R7) ELSE BUMP TO NEXT ENTRY DMS12870
- BCT R0,FINDRES1 AND LOOK AT IT DMS12880
- B FINDRES4 COMMAND NOT FOUND DMS12890
- EJECT DMS12900
- *STEP 5: CHECK IF ENTRY TRULY A COMMAND AND IF SO, PROCESS IT DMS12910
- * DMS12920
- FINDRES2 TM LIBFLAGS,LIBCMD IF NOT A COMMAND DMS12930
- BNO FINDRES4 THEN IGNORE IT DMS12940
- MVC STRTADDR(4),LIBEPA ELSE SET ENTRY POINT DMS12950
- NI PROTFLAG,255-PRFUSYS ASSUME USER COMMAND DMS12960
- TM LIBFLAGS,LIBSYS IF NOT SYSTEM DMS12970
- BNO FINDRES3 THEN ASSUMPTION CORRECT DMS12980
- OI SFLAG-SVCSECT(R3),SFSYS+SFNUC SET APPROPRIATE FLAGS DMS12990
- SPACE DMS13000
- *STEP 5: RETURN TO DMSITS SO THAT COMMAND EXECUTION MAY START DMS13010
- * DMS13020
- FINDRES3 SR R15,R15 SET RC = 0 DMS13030
- BR R11 AND RETURN DMS13040
- SPACE DMS13050
- *STEP 7: INVALID ENTRY OR COMMAND NOT FOUND, CONTINUE W/ NORMAL XEQ DMS13060
- * DMS13070
- FINDRES4 LM R0,R7,STSAVE RESTORE THE REGS DMS13080
- L R15,ASTATE2 GET A(TRUE STATE ROUTINE) DMS13090
- BR R15 AND CONTINUE NORMALLY DMS13100
- SPACE DMS13110
- * STORAGE FOR LOCAL ROUTINE DMS13120
- * DMS13130
- ASTATE2 DC A(0) A(TRUE STATE ROUTINE) DMS13140
- STSAVE DS 9F SAVE AREA DMS13150
- SPACE DMS13160
- DMSRESRL EQU (*-DMSRESRC+7)/8*8 LENGTH OF SPECIAL CODE DMS13170
- DROP R15 DMS13180
- EJECT DMS13190
- *********************************************************************** DMS13200
- * * DMS13210
- * L O C A L D S E C T S * DMS13220
- * * DMS13230
- *********************************************************************** DMS13240
- SPACE DMS13250
- * MAPPING OF FUNCTAB DMS13260
- * DMS13270
- FUNCBLOK DSECT DMS13280
- FUNCNAME DC 8C' ' NAME OF FUNCTION DMS13290
- FUNCOPT DC X'00' VALID OPTIONS FOR FUNCTION DMS13300
- TYPOK EQU X'01' TYPE/NOTYPE OPTION VALID DMS13310
- STKOK EQU X'02' STACK OPTION VALID DMS13320
- SYSOK EQU X'04' SYSTEM OPTION VALID DMS13330
- PERMOK EQU X'08' PERM OPTION VALID DMS13340
- NAMOK EQU X'10' NAME OPTION VALID DMS13350
- KEYOK EQU X'20' KEY OPTION VALID DMS13360
- FUNCFLAG DC X'00' PROCESSING OPTIONS DMS13370
- IXEQ EQU X'01' EXECUTE IMMEDIATELY DMS13380
- NOFPROC EQU X'02' DO NOT SCAN FOR FUNCTION <ID> DMS13390
- SKPNAME EQU X'04' FUNCTION <ID> IS OPTIONAL DMS13400
- FUNCXEQ NOP 0 EXECUTION BRANCH DMS13410
- FUNCTABL EQU *-FUNCBLOK LENGTH OF EACH ENTRY DMS13420
- SPACE DMS13430
- * MAPPING OF OPTION TABLE DMS13440
- * DMS13450
- OPTBLOK CSECT DMS13460
- OPTNAME DC 8C' ' NAME OF OPTION DMS13470
- OPTVALID DC X'00' OPTION/FUNCTION MAPPING FLAGS DMS13480
- OPTBITS DC X'00' OPTION INDICATORS DMS13490
- OPTMASK DC X'00' MASK FOR RESETTING OPTION INDICATORS DMS13500
- OPTLEN DC X'00' MINIMUM ABBREVIATION AS LEN-1 DMS13510
- OPTABLN EQU *-OPTBLOK LEN(EACH ENTRY) DMS13520
- SPACE DMS13530
- * MAPPING OF A LIB TABLE ENTRY DMS13540
- * DMS13550
- LIBNTRY DSECT DMS13560
- LIBID DC 8C' ' FNAME IN AREA DMS13570
- LIBEPA DC A(0) ENTRY POINT ADDRESS DMS13580
- LIBFLAGS EQU LIBEPA FLAGS AS FOLLOWS: DMS13590
- LIBPERM EQU X'80' PERM SPACE DMS13600
- LIBSYS EQU X'40' SYSTEM SPACE DMS13610
- LIBCMD EQU X'20' COMMAND ROUTINE LOADED DMS13620
- LIBLEN DC A(0) LENGTH OF STORAGE AREA DMS13630
- LIBADR DC A(0) ADDRESS OF STORAGE AREA DMS13640
- LIBKEY EQU LIBADR ASSIGNED STORAGE PROTECT KEY DMS13650
- LIBSIZE EQU *-LIBNTRY SIZE OF EACH ENTRY DMS13660
- LIBTLEN EQU 4096-DMSRESRL LENGTH(LIB TABLE) DMS13670
- LIBMAXN EQU LIBTLEN/LIBSIZE MAX NUMBER OF ENTRIES DMS13680
- EJECT DMS13690
- NUCON DMS13700
- DMSFRT DMS13710
- CMSAVE DMS13720
- SVCSECT DMS13730
- REGEQU DMS13740
- END DMSRES DMS13750
ibm/vm370-lib/cms/dmsres.assemble_src.txt · Last modified: 2023/08/06 13:35 by Site Administrator