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'' (NUMBER OF 4K PAGES TO ALLOCATE, MUS DMS00340 * MUST BE 1 TO 256) DMS00350 * DC CL8'(' (OPTION SEPARATOR) DMS00360 * DC CL8'KEY ' (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' (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' (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'' (FNAME OF TEXT BECOMES AREA ID) DMS00590 * DC CL8'(' (OPTION SEPARATOR) DMS00600 * DC CL8'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 <( NAME . KEY . PERM < ) >> DMS00700 * DELETE DMS00710 * LIST <( STACK TYPE NOTYPE < ) >> DMS00720 * RESLIB LOAD <( 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 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 DMS13390 SKPNAME EQU X'04' FUNCTION 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