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