FRE      TITLE 'DMSFRE     (CMS)       VM/370 - RELEASE 6'              00001000
         SPACE 2                                                        00002000
*.                                                                      00003000
*   MODULE NAME:                                                        00010000
*                                                                       00011000
*         DMSFRE (FREE AND FRET)                                        00012000
*                                                                       00013000
*   FUNCTION:                                                           00014000
*                                                                       00015000
*         MANAGEMENT OF FREE STORAGE.                                   00016000
*                                                                       00017000
*   ATTRIBUTES:                                                         00018000
*                                                                       00019000
*         NUCLEUS RESIDENT, RE-ENTRANT                                  00020000
*                                                                       00021000
*   ENTRY POINTS:                                                       00022000
*                                                                       00023000
*         DMSFREB -- CALLED AS A RESULT OF THE 'DMSFREE' AND 'DMSFRET'  00024000
*               MACRO CALLS                                             00025000
*                                                                       00026000
*         DMSFREES -- CALLED AS A RESULT OF THE 'SVCFREE' MACRO CALL.   00027000
*                                                                       00028000
*         DMSFRETS -- CALLED AS A RESULT OF THE 'SVCFRET' MACRO CALL.   00029000
*                                                                       00030000
*         DMSFREEX -- CALLED AS THE RESULT OF A BALR TO THE ADDRESS IN  00031000
*               THE 'NUCON' LOCATION 'AFREE'                            00032000
*                                                                       00033000
*         DMSFRETX -- CALLED AS THE RESULT OF A BALR TO THE ADDRESS IN  00034000
*               THE 'NUCON' LOCATION 'AFRET'                            00035000
*                                                                       00036000
*         DMSFRES -- CALLED AS THE RESULT OF EXECUTION OF THE 'DMSFRES' 00037000
*               MACRO                                                   00038000
*                                                                       00039000
*    ENTRY CONDITIONS:                                                  00040000
*                                                                       00041000
*         DMSFREB -- CODE203 IN NUCON CONTAINS THE HALFWORD CODE        00042000
*               COMPUTED BY THE DMSFREE OR DMSFRET MACROS, DEPENDING    00043000
*               UPON THE OPTIONS SPECIFIED IN THOSE MACROS.             00044000
*                                                                       00045000
*         DMSFREES -- R1 POINTS TO A PLIST:                             00046000
*               DC    CL8'SVCFREE'                                      00047000
*               DC    A(LENGTH)         LENGTH OF REQUESTED BLOCK IN    00048000
*                                       DOUBLEWORDS                     00049000
*               DC    A(0)              ADDRESS OF BLOCK, FILLED IN BY  00050000
*                                       THIS ROUTINE                    00051000
*                                                                       00052000
*         DMSFRETS -- R1 POINTS TO A PLIST:                             00053000
*               DC    CL8'SVCFRET'                                      00054000
*               DC    A(LENGTH)         LENGTH OF BLOCK BEING RELEASED, 00055000
*                                       IN DOUBLEWORDS                  00056000
*               DC    A(ADDRESS)        ADDRESS OF BLOCK BEING RELEASED 00057000
*                                                                       00058000
*         DMSFREEX -- R0 CONTAINS REQUESTED LENGTH                      00059000
*                                                                       00060000
*         DMSFRETX -- R1 CONTAINS THE ADDRESS OF THE BLOCK BEING        00061000
*               RELEASED, AND R0 ITS SIZE IN DOUBLEWORDS.               00062000
*                                                                       00063000
*         DMSFRES -- CODE203 IN NUCON CONTAINS THE HALFWORD CODE        00064000
*               COMPUTED BY THE DMSFREE OR DMSFRET MACROS, DEPENDING    00065000
*               UPON THE PARTICULAR SERVICE ROUTINE BEING REQUESTED.    00066000
*                                                                       00067000
*   EXIT CONDITIONS:                                                    00068000
*                                                                       00069000
*         NORMAL:                                                       00070000
*                                                                       00071000
*         FOR ALLOCATION, REGISTER 1 IS SET TO THE ADDRESS OF THE       00072000
*               ALLOCATED BLOCK.                                        00073000
*         REGISTER 15 IS SET TO THE RETURN CODE, ZERO.                  00074000
*                                                                       00075000
*         ERROR:                                                        00076000
*         RC = 1: NO FREE STORAGE AVAILABLE.                            00077000
*         RC = 2: USER STORAGE POINTERS CLOBBERED.                      00078000
*         RC = 3: NUCLEUS STORAGE POINTERS CLOBBERED.                   00079000
*         RC = 4: (FREE) REQUESTED SIZE NOT POSITIVE, OR MIN GREATER    00080000
*               THAN MAX FOR VARIABLE REQUEST.                          00081000
*         RC = 5: (FRET) RETURNED SIZE NOT POSITIVE                     00082000
*         RC = 6: (FRET) BLOCK WAS IMPROPERLY RETURNED (OVERLAPS TWO    00083000
*               AREAS, OR ANOTHER BLOCK, OR OUT OF RANGE)               00084000
*         RC = 7: (FRET) RETURNED BLOCK IS NOT DOUBLE-WORD ALIGNED.     00085000
*         RC = 8: (DMSFRES) ILLEGAL CODE OR ARGUMENT                    00086000
*                                                                       00087000
*   EXTERNAL REFERENCES:                                                00088000
*                                                                       00089000
*         DMSNUCU -- USER NUCON PAGE                                    00090000
*         DMSNUCE -- END OF NUCON                                       00091000
*         TRANSAR -- ADDRESS OF TRANSIENT AREA                          00092000
*         TRANSEND -- END OF TRANSIENT AREA                             00093000
*         DMSFRT -- DMSFRE WORK AREA, DESCRIBED BY DMSFRT MACRO         00094000
*                                                                       00095000
*   CALLS TO OTHER ROUTINES:                                            00096000
*                                                                       00097000
*         DMSERR -- TO TYPE OUT ERROR MESSAGES                          00098000
*                                                                       00099000
*   TABLES/WORKAREAS:                                                   00100000
*                                                                       00101000
*         DMSFRT -- DMSFRE WORK AREA                                    00102000
*                                                                       00103000
*   REGISTER USAGE:                                                     00104000
*                                                                       00105000
*         R2 = SCRATCH REGISTER                                         00106000
*         R3 = CHAIN HEADER POINTER                                     00107000
*         R4 = CURRENT CHAIN ELEMENT POINTER                            00108000
*         R5 = PREVIOUS CHAIN ELEMENT POINTER                           00109000
*         R6 = ADDRESS OF BLOCK BEING EXAMINED                          00110000
*         R7 = SIZE OF BLOCK BEING EXAMINED OR SEARCHED FOR             00111000
*         R8 = COUNTING REGISTER                                        00112000
*         R9 = SCRATCH REGISTER                                         00113000
*         R10 = INTERNAL SUBROUTINE RETURN REGISTER                     00114000
*         R11 = BASE REGISTER                                           00115000
*         R12 = SECOND BASE REGISTER                                    00116000
*         R13 = POINTER TO WORK AREA, DMSFRT                            00117000
*                                                                       00118000
*   OPERATION:                                                          00119000
*                                                                       00120000
*         DMSFREB -- ALLOCATES OR RELEASES A BLOCK OF STORAGE DEPENDING 00121000
*               UPON THE CODE IN NUCON LOCATION 'CODE203'.  THE EXACT   00122000
*               METHOD OF OPERATION IS DESCRIBED IN THE PLM, IN THE     00123000
*               SECTION ON FREE STORAGE MANAGEMENT.                     00124000
*                                                                       00125000
*         DMSFREES -- THE SIZE IS LOADED FROM THE PLIST, AND A DMSFREE  00126000
*               MACRO IS EXECUTED.  UPON RETURN, THE ADDRESS OF THE     00127000
*               ALLOCATED BLOCK IS STORED INTO THE PLIST.               00128000
*                                                                       00129000
*         DMSFRETS -- THE SIZE AND ADDRESS OF THE BLOCK TO BE RELEASED  00130000
*               ARE LOADED FROM THE PLIST, AND A DMSFRET MACRO IS       00131000
*               EXECUTED.                                               00132000
*                                                                       00133000
*         DMSFREEX -- A DMSFREE MACRO IS EXECUTED.                      00134000
*                                                                       00135000
*         DMSFRETX -- A DMSFRET MACRO IS EXECUTED.                      00136000
*                                                                       00137000
*         DMSFRES -- THE FOLLOWING SERVICE ROUTINES ARE EXECUTED:       00138000
*                                                                       00139000
*         CKON: TURN ON FLAG WHICH CAUSES 'CHECK' TO BE EXECUTED WITH   00140000
*               EACH CALL TO DMSFRE.                                    00141000
*                                                                       00142000
*         CKOFF: TURN OFF THIS FLAG.                                    00143000
*                                                                       00144000
*         INIT1: FIRST DMSFRE INITIALIZATION ROUTINE.  THIS ROUTINE     00145000
*               INITIALIZES FREE STORAGE IN A TEMPORARY WAY, SO THAT    00146000
*               THE SYSTEM DISK CAN BE LOGGED IN.                       00147000
*                                                                       00148000
*         INIT2: SECOND DMSFRE INITIALIZATION ROUTINE.  THIS ROUTINE    00149000
*               IS CALLED AFTER THE SIZE OF VIRTUAL MEMORY IS KNOWN,    00150000
*               TO PREPARE STORAGE FOR THE USUAL ACTIVITY IN FREE       00151000
*               STORAGE ALLOCATION. ANY HIGH-CORE POINTERS ARE CLEARED, 00152000
*               THE 'FREETAB' FREE STORAGE TABLE IS ALLOCATED (THIS     00153000
*               TABLE CONTAINS ONE BYTE FOR EACH PAGE OF VIRTUAL        00154000
*               MEMORY, WHICH INDICATES THE USE OF THAT PAGE), ALL      00155000
*               STORAGE KEYS ARE INITIALIZED, AND THE CHAINS ARE        00156000
*               CLEANED UP.                                             00157000
*                                                                       00158000
*         CHECKS: CAUSE ALL CHAINS TO BE CHECKED FOR VALIDITY.          00159000
*                                                                       00160000
*         UREC: RECOVERY ROUTINE CALLED BY DMSABN.  ALL USER FREE       00161000
*               STORAGE BLOCKS ARE RELEASED.                            00162000
*                                                                       00163000
*         CALOC: COMPUTATION ROUTINE CALLED BY DMSABN.  THIS ROUTINE    00164000
*               COMPUTES THE SIZE OF ALLOCATED STORAGE.                 00165000
*.                                                                      00166000
         MACRO                                                          00173000
&NM      CLEANUP &COND,&CHAIN                                           00174000
&NM      REVB  &COND,*+12                                               00175000
         OI    FREEFLG2,FRF2CL                                          00176000
         AIF   ('&CHAIN' NE '').NOC                                     00177000
         OI    FLAGS(CHR),FLCLN+FLPA                                    00178000
         MEXIT                                                          00179000
.NOC     OI    FREE&CHAIN+FLAGS,FLCLN+FLPA                              00180000
         MEND                                                           00181000
         SPACE 5                                                        00182000
         MACRO                                                          00183000
&NM      REVB  &C,&J                                                    00184000
         LCLC  &CT                                                      00185000
         AIF   ('&C' EQ '').MEND                                        00186000
         AIF   ('&C'(1,1) EQ 'N').N                                     00187000
&NM      BN&C  &J                                                       00188000
         MEXIT                                                          00189000
.N       ANOP                                                           00190000
&CT      SETC  '&C'(2,8)                                                00191000
&NM      B&CT  &J                                                       00192000
.MEND    MEND                                                           00193000
         EJECT                                                          00194000
         MACRO                                                          00195000
&NM      DGEN  &LIST                                                    00196000
         LCLA  &I                      LOOP VARIABLE                    00197000
&NM      DC    0H'0',AL2(&LIST-&NM)                                     00198000
.LOOP    ANOP                                                           00199000
         DC    AL2(&SYSLIST(&I+2)-&NM)                                  00200000
&I       SETA  &I+1                                                     00201000
         AIF   (&I+2 LE N'&SYSLIST).LOOP                                00202000
         MEND                                                           00203000
         SPACE 5                                                        00204000
         MACRO                                                          00205000
         ROUND &TYPE,&R                                                 00206000
.* ROUND SIZE VALUE UP OR DOWN TO 4K MULTIPLE                           00207000
         AIF   ('&TYPE' NE 'UP').D                                      00208000
         LA    &R,4096-1(,&R)          ADD (PAGE-1) VALUE               00209000
.D       N     &R,=X'00FFF000'         TRUNCATE TO PAGE BOUNDARY        00210000
         MEND                                                           00211000
         SPACE 3                                                        00212000
         MACRO                                                          00213000
         CVDB  &R,&ERR=                CONVERT DOUBLEWORDS TO BYTES     00214000
         AR    &R,&R                   MULTIPLY BY 8                    00215000
         AR    &R,&R                                                    00216000
         AR    &R,&R                                                    00217000
         SPACE                                                          00218000
* ERROR RETURN IF RESULT IS NEGATIVE                                    00219000
         RTN   NP,&ERR,FINIS                                            00220000
         C     &R,=X'00FF0000'         COMPARE RESULT WITH MAXIMUM      00221000
         BNH   *+8                     SKIP IF SMALLER                  00222000
         L     &R,=X'00FF0000'         LOAD MAXIMUM VALUE               00223000
         MEND                                                           00224000
         EJECT                                                          00225000
         MACRO                                                          00226000
         RTN   &COND,&CODE,&FINIS                                       00227000
         LCLA  &J                                                       00228000
         LCLB  &CB,&FB                                                  00229000
&CB      SETB  ('&CODE' NE '0')                                         00230000
&FB      SETB  ('&FINIS' NE '')                                         00231000
&J       SETA  (1-&CB)*(2*&FB+8)+12*&CB COMPUTE JUMP LENGTH             00232000
         REVB  &COND,*+&J                                               00233000
         AIF   (&CB).NCB1                                               00234000
         SR    R15,R15                 ZERO RETURN CODE                 00235000
         AGO   .RET                                                     00236000
.NCB1    ANOP                                                           00237000
         LA    R15,CODE&CODE           SET RETURN CODE                  00238000
         AIF   (&CODE LT 20).LC                                         00239000
CODE&CODE EQU  &CODE (DOCUMENTATION)                                    00240000
.LC      ANOP                                                           00241000
         AIF   (&FB).RET                                                00242000
         LTR   R15,R15                 SET CONDITION CODE               00243000
.RET     ANOP                                                           00244000
         AIF   (&FB).B                                                  00245000
         BR    RR                      RETURN TO CALLER                 00246000
         MEXIT                                                          00247000
.B       B     RTN&FINIS                                                00248000
         MEND                                                           00249000
* REGISTER DEFINITIONS                                                  00251000
DMSFRE   START 0                                                        00252000
R0       EQU   0                                                        00253000
R1       EQU   1                                                        00254000
R2       EQU   2                                                        00255000
R3       EQU   3                                                        00256000
R4       EQU   4                                                        00257000
R5       EQU   5                                                        00258000
R6       EQU   6                                                        00259000
R7       EQU   7                                                        00260000
R8       EQU   8                                                        00261000
R9       EQU   9                                                        00262000
R10      EQU   10                                                       00263000
R11      EQU   11                                                       00264000
R12      EQU   12                                                       00265000
R13      EQU   13                                                       00266000
R14      EQU   14                                                       00267000
R15      EQU   15                                                       00268000
         SPACE 5                                                        00269000
XR2      EQU   R2                      SCRATCH -- MUST BE PRESERVED BY *00270000
                                       LOW-LEVEL SUBROUTINES            00271000
CHR      EQU   R3                      CHAIN HEADER POINTER             00272000
PTR      EQU   R4                      CURRENT CHAIN ELEMENT POINTER    00273000
PPTR     EQU   R5                      PREVIOUS CHAIN ELEMENT POINTER   00274000
BLR      EQU   R6                      ADDRESS OF BLOCK BEING EXAMINED  00275000
SR       EQU   R7                      SIZE OF BLOCK BE SEARCHED FOR    00276000
CR       EQU   R8                      COUNTING REGISTER                00277000
XR       EQU   R9                      SCRATCH REGISTER -- MUST BE ODD  00278000
RR       EQU   R10                     INTERNAL SUBROUTINE RETURN REG   00279000
BR       EQU   R11                     BASE REGISTER                    00280000
BR2      EQU   R12                                                      00281000
TR       EQU   R13                     POINTER TO WORK AREA             00282000
         SPACE 3                                                        00283000
* NOTE: CR = (XR-1): HIGH BYTE WILL BE CLOBBERED BY MVCL AND CLCL.      00284000
         EJECT                                                          00285000
* THE FOLLOWING NAME CHANGES WERE MADE IN GOING FROM CMS/67 TO CMS/370  00286000
         SPACE                                                          00287000
*        OLD NAME                      NEW NAME                         00288000
*        -----------                   -----------                      00289000
*        SVCFREE                       DMSFREES                         00290000
*        SVCFRET                       DMSFRETS                         00291000
*        FREE                          DMSFREEX                         00292000
*        FRET                          DMSFRETX                         00293000
         SPACE 3                                                        00294000
         USING DMSFRE,BR,BR2                                            00295000
         USING NUCON,R0                                                 00296000
         USING FRDSECT,TR                                               00297000
         SPACE 3                                                        00298000
         ENTRY DMSFREB,DMSFREES,DMSFRETS,DMSFREEX,DMSFRETX              00299000
         ENTRY DMSFRES                 DMSFRE SERVICE ROUTINES          00300000
         ENTRY FREE,FRET,SVCFREE,SVCFRET ***** REMOVE *****             00301000
         EJECT                                                          00302000
* LIST OF INTERNAL RETURN CODES                                         00303000
CODE1    EQU   1                       NO STORAGE AVAILABLE -- FREE    *00304000
                                       REQUEST CANNOT BE SATISFIED      00305000
CODE2    EQU   2                       USER STORAGE POINTERS CLOBBERED  00306000
CODE3    EQU   3                       NUC STORAGE POINTERS CLOBBERED   00307000
CODE4    EQU   4                       FREE: REQUESTED SIZE <= 0 OR    *00308000
                                       MIN > MAX FOR VARIABLE REQUEST   00309000
CODE5    EQU   5                       FRET: RETURNED SIZE <= 0         00310000
CODE6    EQU   6                       FRET: BLOCK WAS IMPROPERLY      *00311000
                                       RETURNED (OVERLAPS TWO AREAS OR *00312000
                                       ANOTHER BLOCK, OR OUT OF RANGE)  00313000
CODE7    EQU   7                       FRET: RETURNED BLOCK IS NOT     *00314000
                                       DOUBLE-WORD ALIGNED              00315000
CODE8    EQU   8                       DMSFRES: ILLEGAL CODE OR ARG     00316000
CODE9    EQU   9                       ANY: UNEXPECTED INTERNAL ERROR   00317000
         SPACE                                                          00318000
* 20 OR HIGHER: UNEXPECTED INTERNAL ERRORS                              00319000
INIT1    EQU   *                                                        00321000
* FIRST INITIALIZATION ROUTINE                                          00322000
* PUT ALL STORAGE ON NUCLEUS CHAIN AND ROUTINE.                         00323000
* TURN ON AN 'UN-INITIALIZED' FLAG TO INDICATE THAT SECOND INIT         00324000
* ROUTINE HAS NOT YET BEEN CALLED.                                      00325000
* UNTIL SECOND ROUTINE IS CALLED, NO USER STORAGE MAY BE ALLOCATED.     00326000
* IN THE BEGINNING, THERE IS ONLY ONE LOW-CORE BLOCK ON THE FREE        00327000
* CHAIN.                                                                00328000
         L     XR,=V(DMSNUCE)          ADDR OF BEGINNING OF BLOCK       00329000
         ST    XR,FREELN+POINTER       STORE POINTER IN CHAIN HEADER    00330000
         XC    POINTER(4,XR),POINTER(XR) ZERO 'NEXT BLOCK' POINTER      00331000
         L     XR2,=V(TRANSAR)         END OF BLOCK                     00332000
         SR    XR2,XR                  SIZE OF BLOCK                    00333000
         ST    XR2,FREELN+MAX          SET MAX FOR CHAIN                00334000
         ST    XR2,SIZE(,XR)           STORE SIZE OF BLOCK              00335000
         MVI   FREELN+(NUM+3),1        ONE BLOCK IN CHAIN               00336000
         MVI   FREEFLG2,FRF2NOI        INITIALIZE FLAG BYTE             00337000
         RTN   ,0,FINIS                RETURN                           00338000
* SECOND INITIALIZATION ROUTINE                                         00340000
* ALLOCATE BYTE TABLE, DEPENDING ON STORAGE SIZE.                       00341000
* SET UP BYTES TO INIDICATE ALLOCATED STORAGE.                          00342000
* SET CLEANUP FLAG FOR NUCLEUS LOW-CORE CHAIN                           00343000
* TURN OFF 'UN-INITIALIZED' FLAG SET BY FIRST INITIALIZATION ROUTINE.   00344000
* BRANCH TO RETURN, TO ALLOW CLEANUP.                                   00345000
INIT2    EQU   *                                                        00346000
         MVC   FREELOW1,FREELOWE       SAVE CURRENT VALUE OF FREELOWE   00347000
         L     XR2,FREELOWE            SAVE CURRENT VALUE OF FREELOWE   00348000
         SPACE                                                          00349000
* WIPE OUT ALL HIGH-CORE NUCLEUS STORAGE.                               00350000
         XC    FREEHN(12),FREEHN       CLEAR HIGH CORE POINTERS         00351000
         L     SR,VMSIZE               GET CORE SIZE                    00352000
         SRA   SR,12                   NUMBER BYTES NEEDED IN FREETAB   00353000
         LA    SR,7(,SR)               ROUND SR UP TO DOUBLE WORD       00354000
         N     SR,=X'00FFFFF8'                                          00355000
         LA    CHR,FREELN              POINT TO LOW-CORE NUCLEUS CHAIN  00356000
         BAL   RR,SCHFIX               ALLOCATE TABLE                   00357000
         BZ    INIT2A                  GO IT SUCCESSFUL                 00358000
         SPACE                                                          00359000
* OTHERWISE, ALLOCATE FROM TOP OF CORE STORAGE.                         00360000
         LR    R1,SR                   SAVE FREETAB SIZE                00361000
         ROUND UP,SR                   ROUND UP TO NUMBER OF PAGES      00362000
         BAL   RR,GEXT                 GET EXTEND STORAGE               00363000
         LA    CHR,FREEHN              POINT TO HIGH-CORE NUCLEUS CHAIN 00364000
         BAL   RR,SFRT                 PUT ON HIGH NUCLEUS CHAIN        00365000
         LR    SR,R1                   GET SIZE NEEDED                  00366000
         BAL   RR,SCHFIX               GO ALLOCATE IT                   00367000
         RTN   NZ,23,FINIS             ALLOCATION ERROR IS IMPOSSIBLE   00368000
         SPACE                                                          00369000
* WHEN CONTROL REACHES THIS POINT, THE FREETAB TABLE HAS BEEN           00370000
* ALLOCATED, AND ITS ADDRESS IS IN REGISTER BLR.                        00371000
INIT2A   EQU   *                                                        00372000
         ST    BLR,AFREETAB            SAVE ADDRESS IN NUCON            00373000
         NI    FREEFLG2,X'FF'-FRF2NOI  TURN OFF 'NOT INITIALIZED' FLAG  00374000
         SPACE                                                          00375000
* WE MUST NOW INITIALIZE THE ASSIGNED CODES AND STORAGE KEYS FOR ALL    00376000
* OF CORE STORAGE.                                                      00377000
         SPACE                                                          00378000
* FIRST, WE INITIALIZE EVERYTHING TO NUCLEUS KEY AND SYSTEM CODE.       00379000
         SR    BLR,BLR                 BLOCK STARTS AT LOCATION ZERO    00380000
         L     SR,VMSIZE               GET SIZE OF VIRTUAL MEMORY       00381000
         LA    XR,NUCKEY               NUCLEUS KEY                      00382000
         BAL   RR,SETKEYI              SET STORAGE KEY                  00383000
         LA    XR,SYSCODE              SET SYSTEM CODE                  00384000
         BAL   RR,SETCODEI                                              00385000
         SPACE                                                          00386000
* CHANGE KEY IN USER HALF-PAGE IN NUCON                                 00387000
         L     BLR,=V(DMSNUCU)         POINT TO USER HALF-PAGE          00388000
         LA    XR,USERKEY              USER STORAGE KEY                 00389000
         SSK   XR,BLR                  SET STORAGE KEY                  00390000
         SPACE                                                          00391000
* THE LOW-CORE FREE STORAGE AREA SHOULD HAVE NUCLEUS FREE STORAGE CODE. 00392000
         L     BLR,=V(DMSNUCE)         BEGINNING OF BLOCK               00393000
         ROUND DOWN,BLR                ROUND DOWN TO PAGE BOUNDARY      00394000
         L     SR,=V(TRANSAR)          END OF BLOCK                     00395000
         SLR   SR,BLR                  SIZE OF BLOCK IN BYTES           00396000
         LA    XR,NUCCODE              SET NUCLEUS CODE                 00397000
         BAL   RR,SETCODEI                                              00398000
         SPACE                                                          00399000
* THE TRANSIENT AREA IS SET TO TRANSIENT CODE, AND USER STORAGE KEY.    00400000
         L     BLR,=V(TRANSAR)         BEGINNING OF TRANSIENT AREA      00401000
         L     SR,=V(TRANSEND)         END OF TRANSIENT AREA            00402000
         SLR   SR,BLR                  SIZE OF TRANSIENT AREA           00403000
         LA    XR,TRNCODE              TRANSIENT AREA CODE              00404000
         BAL   RR,SETCODEI             SET CODE IN FREETAB TABLE        00405000
         LA    XR,USERKEY              USER STORAGE KEY                 00406000
         BAL   RR,SETKEYI              SET STORAGE KEY                  00407000
         SPACE                                                          00408000
* THE USER AREA IS SET TO USER AREA CODE, AND USER STORAGE KEY.         00409000
         L     BLR,AUSRAREA            BEGINNING OF USER AREA           00410000
         L     SR,FREELOWE             END OF USER AREA                 00411000
         SLR   SR,BLR                  SIZE OF USER AREA                00412000
         LA    XR,USARCODE             USER AREA CODE                   00413000
         BAL   RR,SETCODEI             PUT INTO FREETAB                 00414000
         LA    XR,USERKEY              USER STORAGE KEY                 00415000
         BAL   RR,SETKEYI              SET STORAGE KEY                  00416000
         SPACE                                                          00417000
* FINALLY, ANY HIGH CORE FREE AREA SHOULD HAVE NUCLEUS FREE STORAGE     00418000
* CODE.  ANY SUCH AREA MAY HAVE BEEN ALLOCATE ONLY FOR FREETAB.         00419000
         L     BLR,FREELOWE            BEGINNING OF HIGH CORE FREE AREA 00420000
         L     SR,FREELOW1             END OF AREA                      00421000
         SLR   SR,BLR                  SIZE OF AREA                     00422000
         BZ    INIT2B                  NOTHING TO DO IF ZERO            00423000
         LA    XR,NUCCODE              SET NUCLEUS CODE                 00424000
         BAL   RR,SETCODEI             PUT INTO FREETAB                 00425000
         SPACE                                                          00426000
INIT2B   EQU   *                                                        00427000
         CLEANUP ,LN                   CLEAN UP LOW CORE NUCLEUS CHAIN  00428000
         CLEANUP ,HN                   CLEAN UP HIGH CORE NUC CHAIN     00429000
         RTN   ,0,FINIS                GO CLEAN UP AND RETURN (RC=0)    00430000
* SVCFREE ENTRY                                                         00432000
         USING *,R15                                                    00433000
DMSFREES EQU   *                                                        00434000
SVCFREE  EQU   *                       ***** REMOVE *****               00435000
         LR    R2,R1                   SAVE PARAMETER LIST POINTER      00436000
         L     R0,8(,R1)               LOAD BLOCK SIZE INTO R0          00437000
         DMSFREE DWORDS=(0),ERR=*,TYPE=USER ALLOCATE BLOCK              00438000
         ST    R1,12(,R2)              STORE ADDRESS IN PARAM LIST      00439000
         BR    R14                     RETURN TO CALLER                 00440000
         SPACE 5                                                        00441000
* SVCFRET ENTRY                                                         00442000
         USING *,R15                                                    00443000
DMSFRETS EQU   *                                                        00444000
SVCFRET  EQU   *                       ***** REMOVE *****               00445000
         LR    R2,R1                   SAVE PARAMETER LIST POINTER      00446000
         LM    R0,R1,8(R1)             LOAD LENGTH/ADDR INTO R0/R1      00447000
         DMSFRET DWORDS=(0),LOC=(1),ERR=* RETURN BLOCK                  00448000
         BR    R14                                                      00449000
* DMSFREEX IS POINTED TO BY NUCON FIELD AFREE.                          00451000
DMSFREEX EQU   *                                                        00452000
FREE     EQU   *                       ******* REMOVE *******           00453000
         DMSFREE DWORDS=(0),TYPCALL=SVC,TYPE=USER                       00454000
         BR    R14                                                      00455000
         SPACE 2                                                        00456000
* DMSFRETX IS POINTED TO BY AFRET                                       00457000
DMSFRETX EQU   *                                                        00458000
FRET     EQU   *                       ******* REMOVE *******           00459000
         DMSFRET DWORDS=(0),LOC=(1),TYPCALL=SVC                         00460000
         BR    R14                                                      00461000
* ENTRY POINT FOR SVC 203 CALLS                                         00463000
         USING *,R15                                                    00464000
DMSFREB  EQU   *                                                        00465000
         STM   R0,R15,FREESAVE         SAVE REGISTERS IN NUCON          00466000
         LM    BR,BR2,=A(DMSFRE,DMSFRE+4096) SET BASE REGISTERS         00467000
         DROP  R15                                                      00468000
         L     TR,=V(DMSFRT)           POINT TO WORK AREA               00469000
         SPACE                                                          00470000
* NUCON LOCATION CODE203 CONTAINS THE HALFWORD CODE USED IN             00471000
* CONJUNCTION WITH SVC 203.  IF THIS VALUE IS NEGATIVE, THEN            00472000
* THIS IS A CONDITIONAL REQUEST.  THIS MEANS THAT WE WILL NOT ABEND IF  00473000
* THE REQUEST CANNOT BE SATISFIED.                                      00474000
* THE ACTUAL ROUTINE CODE IS IN THE SECOND BYTE OF THE ABSOLUTE VALUE   00475000
* OF THE CODE.  THIS LEAVES SEVEN FLAGS BITS IN THE FIRST BYTE OF THE   00476000
* CODE, AND THESE BECOME THE FREEFLG1 FLAG BITS.                        00477000
         LH    R14,CODE203             GET SVC 203 CODE VALUE           00478000
         LPR   R15,R14                 GET ABSOLUTE VALUE               00479000
         SRL   R15,8                   GET FLAG BYTE                    00480000
         STC   R15,FREEFLG1            AND STORE IN FLAG BYTE           00481000
         LTR   R14,R14                 WAS ORIGINAL CODE NEGATIVE?      00482000
         BP    *+8                     SKIP IF NOT                      00483000
         OI    FREEFLG1,FRF1C          SET 'CONDITIONAL' FLAG           00484000
         TM    FREEFLG2,FRF2CKE        TEXT 'CHECK EACH TIME' FLAG      00485000
         BZ    *+8                     SKIP IF OFF                      00486000
         OI    FREEFLG2,FRF2CKT        SET 'CHECK THIS TIME' FLAG       00487000
         TM    FREEFLG1,FRF1E          WAS THIS A 'FREE' CALL?          00488000
         BZ    FRETUN                  GO IF A FRET CALL                00489000
         SPACE                                                          00490000
* OTHERWISE, IT'S A 'FREE' CALL                                         00491000
         TM    FREEFLG1,FRF1N          'NUCLEUS' STORAGE?               00492000
         BO    NFREE                   GO IF SO                         00493000
         B     UFREE                   USER STORAGE IF NOT              00494000
         EJECT                                                          00495000
* ENTRY POINT FOR DMSFRES MACRO CALLS -- DMSFRE FREE STORAGE SERVICE    00496000
* ROUTINES.                                                             00497000
         USING *,R15                                                    00498000
DMSFRES  EQU   *                                                        00499000
         STM   R0,R15,FREESAVE         SAVE REGISTERS                   00500000
         LM    BR,BR2,=A(DMSFRE,DMSFRE+4096)                            00501000
         DROP  R15                                                      00502000
         L     TR,=V(DMSFRT)           POINT TO WORK AREA               00503000
         MVI   FREEFLG1,FRF1C+FRF1M    SET FREEFLG1 FOR EXIT LOGIC      00504000
         LH    R14,CODE203             GET HALFWORD CODE WITH SVC 203   00505000
         LPR   R14,R14                 TAKE ABSOLUTE VALUE              00506000
         SRL   R14,8                   GET LEFTMOST BYTE                00507000
         AR    R14,R14                 MULTIPLY BY 4                    00508000
         AR    R14,R14                                                  00509000
         RTN   Z,8,FINIS               ILLEGAL ARGUMENT IF ZERO         00510000
         C     R14,FRESTAB             COMPARE WITH MAX VALUE           00511000
         RTN   H,8,FINIS               ILLEGAL ARG IF GREATER           00512000
         L     R14,FRESTAB(R14)        GET BRANCH ADDRESS               00513000
         BR    R14                     GO TO IT                         00514000
         SPACE 5                                                        00515000
* FRESTAB TABLE CONTAINS THE ADDRESSES OF THE VARIOUS DMSFRE            00516000
* FREE STORAGE SERVICE ROUTINES.                                        00517000
FRESTAB  DC    A(FRESTABE-FRESTAB)     SIZE OF TABLE                    00518000
         DC    A(CKON)                 1                                00519000
         DC    A(CKOFF)                2                                00520000
         DC    A(INIT1)                3                                00521000
         DC    A(INIT2)                4                                00522000
         DC    A(CHECKS)               5                                00523000
         DC    A(UREC)                 6                                00524000
         DC    A(CALOC)                7                                00525000
FRESTABE EQU   *                                                        00526000
         SPACE 3                                                        00527000
         LTORG                                                          00528000
* FRET, USER OR NUCLEUS                                                 00530000
FRETUN   EQU   *                                                        00531000
         SPACE                                                          00532000
* R0 CONTAINS THE NUMBER OF DOUBLE WORDS BEING RETURNED, AND R1         00533000
* CONTAINS THE ADDRESS OF THE BLOCK BEING RETURNED.                     00534000
         SPACE                                                          00535000
* FIRST, WE CONVERT THE SIZE FROM DOUBLEWORDS TO BYTES.                 00536000
         CVDB  R0,ERR=5                CONVERT DOUBLEWORDS TO BYTES     00537000
         LR    SR,R0                   SR CONTAINS SIZE IN BYTES        00538000
         LA    R1,0(,R1)               CLEAR HIGH-ORDER BYTE      P3015 00539000
         LR    BLR,R1                  BLR CONTAINS ADDRESS OF BLOCK    00540000
         SPACE                                                          00541000
* CALL FINDCHN SUBROUTINE TO DETERMINE WHICH OF THE FOUR CHAINS THE     00542000
* BLOCK BELONGS ON.  FINDCHN ALSO DOES SOME ERROR CHECKING TO SEE IF    00543000
* THE BLOCK IS DOUBLE-WORD ALIGNED AND IT'S ENTIRELY WITHIN ONE AREA    00544000
* (NUCLEUS OR USER, LOW- OR HIGH-CORE).                                 00545000
         BAL   RR,FINDCHN              FIND CHAIN FOR THE BLOCK         00546000
         SPACE                                                          00547000
* CONTROL RETURNS TO THIS POINT WHEN A NUCLEUS FRET RESULTS IN A WHOLE  00548000
* PAGE BEING FREED.  THIS POINT IS BRANCHED TO TO PUT THE PAGE(S) ON    00549000
* THE USER CHAIN.                                                       00550000
FRETR    EQU   *                                                        00551000
         BAL   RR,SFRT                 PUT BLOCK ONTO CHAIN             00552000
         SPACE                                                          00553000
* SFRT RETURNS (IN BLR AND SR) THE ADDRESS AND SIZE OF THE ENTIRE BLOCK 00554000
* WHICH IS ON THE CHAIN WHICH CONTAINS THE FRETTED BLOCK.  (I.E., IF    00555000
* THE FRETTED BLOCK WAS COMBINED WITH ANOTHER BLOCK ALREADY ON THE FREE 00556000
* CHAIN, THEN SFRT RETURNS THE ADDR AND SIZE OF THE ENTIRE BLOCK OF     00557000
* COMBINED STORAGE.)                                                    00558000
* WE CHECK TO SEE WHETHER THIS BLOCK CONTAINS AN EMBEDDED PAGE.         00559000
         CL    SR,PAGESIZE             BLOCKSIZE >= A PAGE?             00560000
         BL    RETURN                  NOTHING TO DO IF NOT             00561000
         TM    FREEFLG2,FRF2NOI        SECOND INIT ROUTINE TAKEN PLACE? 00562000
         BO    RETURN                  RETURN IF IT HAS NOT             00563000
         CL    BLR,FREELOWE            ADDRESS = ADDR OF LOW EXTEND?    00564000
         BNE   FRET1                   TO FRET1 IF NOT                  00565000
         SPACE                                                          00566000
* OTHERWISE, WE ARE FRETTING A BLOCK AT LOW EXTEND, SO THAT WE MAY      00567000
* MOVE THE LOW EXTEND POINTER UP.                                       00568000
         ROUND DOWN,SR                 ROUND DOWN BLOCKSIZE TO PAGE    *00569000
                                       SIZE                             00570000
         BAL   RR,SETKEYN              SET KEY TO 'UNASSIGNED'          00571000
         BAL   RR,SETCODEN             SET TABLE CODE TO 'UNASSIGNED'   00572000
         BAL   RR,ALOC                 REMOVE BLOCK FROM CHAIN          00573000
         AR    BLR,SR                  POINT TO END OF BLOCK            00574000
         ST    BLR,FREELOWE            THIS IS NEW LOW EXTEND VALUE     00575000
         TM    FLAGS(CHR),FLHC         THIS HAD BETTER BE HIGH-CORE CHN 00576000
         RTN   NO,40,CLOB              STORAGE CLOBBERED IF NOT         00577000
         SPACE                                                          00578000
* IF THIS IS THE NUCLEUS CHAIN, THEN THE HIGH-CORE USER CHAIN MAY       00579000
* CONTAIN PAGES WHICH CAN FURTHER AFFECT FREELOWE (LOW EXTEND).  FOR    00580000
* THIS REASON, WE MUST SET CLEANUP FLAG FOR FREEHU IN THIS CASE.        00581000
         TM    FLAGS(CHR),FLNU         HIGH-CORE NUC CHAIN?             00582000
         CLEANUP O,HU                  CLEANUP HIGH-CORE USER CHN IF SO 00583000
         RTN   ,0,FINIS                NORMAL RETURN                    00584000
         SPACE 2                                                        00585000
* CONTROL COMES HERE IF THE BLOCK IS A PAGE WHOSE ADDRESS IS NOT AT     00586000
* LOW-EXTEND.  IF THIS IS A NUCLEUS CHAIN, THEN WE MUST TRANSFER THE    00587000
* PAGE(S) TO THE CORRESPONDING USER CHAIN.                              00588000
FRET1    EQU   *                                                        00589000
         TM    FLAGS(CHR),FLNU         NUCLEUS CHAIN?                   00590000
         BZ    FRETUP                  GO IF NOT                        00591000
         TM    FREEFLG2,FRF2NOI        SECOND INIT TAKEN PLACE?         00592000
         BO    FRETUP                  GO IF NOT                        00593000
         LR    XR,SR                   SIZE OF BLOCK                    00594000
         AR    XR,BLR                  XR -> END OF BLOCK               00595000
         ROUND UP,BLR                  BLR -> ADDRESS OF EMBEDDED PAGE  00596000
         ROUND DOWN,XR                 XR -> END OF EMBEDDED PAGE BLOCK 00597000
         CLR   BLR,XR                  ARE THE TWO EQUAL?               00598000
         RTN   NL,0,FINIS              IF SO, THEN IT WASN'T REALLY    *00599000
                                       A PAGE                           00600000
         LR    SR,XR                   SR CONTAINS END PAGE ADDRESS     00601000
         SR    SR,BLR                  SR = NO BYTES IN PAGE BLOCK      00602000
         BAL   RR,ALOC                 REMOVE PAGE BLOCK FROM CHAIN     00603000
         LA    CHR,BLOCKLEN(,CHR)      POINT TO CORRESPONDING USER CHN  00604000
         BAL   RR,SETKEY               SET KEY TO USER KEY              00605000
         BAL   RR,SETCODE              SET TABLE CODE TO USER CODE      00606000
         B     FRETR                   RETURN TO CODE ABOVE TO PUT     *00607000
                                       BLOCK ONTO USER CHAIN            00608000
         SPACE 2                                                        00609000
* COME HERE IF PAGE FOUND ON USER CHAIN (OR ON NUCLEUS CHAIN IF         00610000
* SECOND INITIALIZATION HAS NOT YET TAKEN PLACE)                        00611000
FRETUP   EQU   *                                                        00612000
         OI    FLAGS(CHR),FLPA         SET 'PAGE AVAILABLE' FLAG        00613000
         RTN   ,0,FINIS                AND GIVE NORMAL RETURN           00614000
* UFREE -- USER FREE STORAGE REQUEST.                                   00616000
* R0 CONTAINS THE SIZE OF THE REQUEST IN DOUBLE WORDS.  IF THE          00617000
* REQUEST IS VARIABLE, THEN R1 CONTAINS THE MINIMUM SIZE OF THE         00618000
* REQUEST.                                                              00619000
UFREE    EQU   *                                                        00620000
         SPACE                                                          00621000
* IF THE SECOND INITIALIZATION ROUTINE HAS NOT YET BEEN INVOKED, THEN   00622000
* ALL USER STORAGE REQUESTS BECOME NUCLEUS STORAGE REQUESTS.            00623000
         TM    FREEFLG2,FRF2NOI        NO SECOND INITIALIZATION?        00624000
         BNO   *+12                    SKIP 2 INSTR'S IF THERE WAS ONE  00625000
         OI    FREEFLG1,FRF1N          SET 'NUCLEUS' REQUEST BIT        00626000
         B     NFREE                   AND GO TO NUCLEUS FREE ROUTINE   00627000
         SPACE                                                          00628000
* WE FIRST CONVERT THE NUMBER IN R0 TO BYTES.                           00629000
         CVDB  R0,ERR=4                CONVERT DOUBLEWORDS TO BYTES     00630000
         LR    SR,R0                   SR CONTAINS SIZE OF REQUEST      00631000
         LA    CHR,FREELU              POINT TO USER LOW-CORE CHAIN     00632000
         SPACE                                                          00633000
* IF THE USER SPECIFIED 'AREA=HIGH', THEN LOW-CORE STORAGE MAY NOT      00634000
* BE USED.                                                              00635000
         TM    FREEFLG1,FRF1L          LOW-CORE STORAGE PERMITTED?      00636000
         BZ    UFREEH                  GO IF NOT                        00637000
         BAL   RR,SCHFIX               ALLOCATE FROM USER LOW-CORE CHN  00638000
         BZ    RETURN                  RETURN IF ALLOCATION SUCCESSFUL  00639000
         SPACE                                                          00640000
* CONTROL COMES HERE IF NO ALLOCATION CAN BE MADE FROM THE LOW-CORE     00641000
* CHAIN.                                                                00642000
UFREEH   EQU   *                                                        00643000
         LA    CHR,FREEHU              POINT TO HIGHCORE USER CHAIN     00644000
         TM    FREEFLG1,FRF1H          IS AREA=HIGH PERMITTED?          00645000
         BZ    UFREEV                  GO IF NOT                        00646000
         BAL   RR,SCHFIX               TRY TO ALLOCATE FROM HIGHCORE    00647000
         BZ    RETURN                  RETURN (RC=0) IF SUCCESSFUL      00648000
         SPACE                                                          00649000
* THERE IS NO SPACE AVAILABLE ON EITHER HIGH CORE OR LOW CORE CHAIN.    00650000
* WE ATTEMPT TO EXTEND DOWN INTO USER CORE BY ADDING ONE OR MORE        00651000
* PAGES FROM BELOW THE 'LOW EXTEND' AREA TO THE USER HIGH CORE CHAIN.   00652000
         ROUND UP,SR                   ROUND UP SIZE TO PAGE MULTIPLE   00653000
         CL    SR,PAGESIZE             BLOCKSIZE > 1 PAGE?              00654000
         CLEANUP H                     CLEAN UP LATER IF SO             00655000
         BAL   RR,GEXT                 GET EXTEND STORAGE               00656000
         BNZ   UFREEV                  GO IF NONE AVAILABLE             00657000
         BAL   RR,SETKEY               SET USER STORAGE KEY             00658000
         BAL   RR,SETCODE              SET USER-ASSIGNED TABLE CODE     00659000
         BAL   RR,SFRT                 PUT NEW STORAGE ONTO CHAIN       00660000
         LR    SR,R0                   RESTORE R0 = REQUEST SIZE--BYTES 00661000
         B     UFREEH                  GO ALLOCATE AGAIN FROM HIGH CHN  00662000
         SPACE 2                                                        00663000
* COME HERE IF THERE IS NO HOPE OF ALLOCATING THE REQUEST BLOCKSIZE.    00664000
* AT THIS POINT WE MUST TRY TO SATISFY A VARIABLE REQUEST, IF HE ALLOWS 00665000
* ONE.  IF HE DOES, THEN REGISTER 1 CONTAINS THE MINIMUM SIZE WHICH     00666000
* HE WILL ACCEPT.                                                       00667000
UFREEV   EQU   *                                                        00668000
         TM    FREEFLG1,FRF1V          VARIABLE REQUEST?                00669000
         RTN   Z,1,FINIS               IF NOT, RETURN RC=1 (NO CORE)    00670000
         SPACE                                                          00671000
* CONVERT DOUBLE WORD SIZE IN R1 TO BYTES.                              00672000
         CVDB  R1,ERR=4                CONVERT DOUBLEWORDS TO BYTES     00673000
         CLR   R1,R0                   COMPARE WITH MAXIMUM             00674000
         RTN   H,4,FINIS               ILLEGAL ARG IF GREATER           00675000
         TM    FREEFLG1,FRF1H          AREA=HIGH ALLOWED?               00676000
         BZ    UFREEV1                 NO -- NO NEED TO GET EXTEND      00677000
         BAL   RR,AEXT                 GET ALL AVAILABLE EXTEND STOR    00678000
         BNZ   UFREEV1                 GO IF NONE AVAILABLE             00679000
         LA    CHR,FREEHU              POINT TO HIGH CORE USER CHN      00680000
         BAL   RR,SETKEY               SET USER CORE KEY                00681000
         BAL   RR,SETCODE              SET USER-ASSIGNED TABLE CODE     00682000
         BAL   RR,SFRT                 PUT EXTEND STORAGE ON CHAIN      00683000
         CLEANUP ,                     SET CLEANUP FLAG FOR HU CHAIN    00684000
         LR    SR,R0               RESTORE REAL MAX REQUEST    @VM01316 00684100
         BAL   RR,SCHFIX           AND CHECK IT AGAIN...       @VM01316 00684200
         BZ    RETURN              RETURN IF SATISFIED         @VM01316 00684300
         SPACE 2                                                        00685000
* WE NOW SEARCH BOTH USER CHAINS FOR THE LARGEST AVAILABLE BLOCK        00686000
* WHICH IS GREATER THAN THE MINIMUM.                                    00687000
UFREEV1  EQU   *                                                        00688000
         LR    SR,R1                   GET MINIMUM SIZE                 00689000
         SR    BLR,BLR                 NO BLOCK ALLOCATED YET           00690000
         LA    CHR,FREELU              POINT TO LOW CORE USER CHAIN     00691000
         TM    FREEFLG1,FRF1L          AREA=LOW ALLOWED?                00692000
         BZ    *+8                     SKIP CALL IF NOT                 00693000
         BAL   RR,SCHVAR               SEARCH FOR LARGEST BLOCK         00694000
         LR    XR2,BLR                 SAVE RESULT FROM LOWCORE SEARCH  00695000
         LA    CHR,FREEHU              POINT TO HIGHCORE CHAIN          00696000
         TM    FREEFLG1,FRF1H          AREA=HIGH ALLOWED?               00697000
         BZ    *+8                     SKIP IF NOT                      00698000
         BAL   RR,SCHVAR               SEARCH FOR LARGEST BLOCK         00699000
         LTR   BLR,BLR                 WAS ANY BLOCK FOUND EITHER TIME? 00700000
         RTN   Z,1,FINIS               RETURN RC=1 IF NOT (NO CORE)     00701000
         CR    SR,R1                   BLOCKSIZE >= MIN SIZE?           00702000
         RTN   L,35,FINIS              IMPOSSIBLE IF NOT                00703000
         CR    SR,R0                   BLOCKSIZE < MAX SIZE?            00704000
         RTN   NL,36,FINIS             IMPOSSIBLE IF NOT                00705000
         CLR   BLR,XR2                 WAS BLOCK ALLOCATED IN LOWCORE?  00706000
         BNE   *+8                     SKIP IF NOT                      00707000
         LA    CHR,FREELU              POINT TO LOW CORE CHAIN IF SO    00708000
         BAL   RR,ALOC                 REMOVE THE BLOCK FROM THE CHAIN  00709000
         RTN   ,0,FINIS                RETURN RC=0 -- WE'RE THROUGH     00710000
* NFREE -- NUCLEUS FREE STORAGE REQUEST                                 00712000
NFREE    EQU   *                                                        00713000
         CVDB  R0,ERR=4                CONVERT DOUBLEWORDS TO BYTES     00714000
         LR    SR,R0                   SR = SIZE REQUESTED (IN BYTES)   00715000
         LA    CHR,FREELN              POINT TO LOWCORE NUCLEUS CHAIN   00716000
         SPACE                                                          00717000
* THE USER MAY HAVE SPECIFIED AREA=HIGH, IN WHICH CASE AREA=LOW IS NOT  00718000
* PERMITTED.                                                            00719000
         TM    FREEFLG1,FRF1L          AREA=LOW PERMITTED?              00720000
         BZ    NFREEN                  GO IF NOT                        00721000
         SPACE                                                          00722000
* IF THE ATTEMPT TO ALLOCATE THE BLOCK FROM FREELN FAILS, THEN CONTROL  00723000
* WILL LATER RETURN TO THIS POINT WITH CHR POINTING TO THE NUCLEUS      00724000
* HIGH CORE CHAIN.                                                      00725000
* ALSO, CONTROL WILL RETURN HERE TO RE-ATTEMPT AN ALLOCATION FROM       00726000
* THE SAME CHAIN.                                                       00727000
NFREER   EQU   *                                                        00728000
         LR    SR,R0                   GET REQUESTED SIZE               00729000
         BAL   RR,SCHFIX               ATTEMPT TO ALLOCATE FROM CHAIN   00730000
         BZ    RETURN                  RETURN RC=0 IF ALLOCATION       *00731000
                                       IS SUCCESSFUL                    00732000
         LR    XR2,CHR                 SAVE CHAIN PTR TEMPORARILY       00733000
         LA    CHR,BLOCKLEN(,CHR)      POINT TO CORRESPONDING USER CHN  00734000
         L     SR,PAGESIZE             SIZE OF A PAGE                   00735000
         BAL   RR,SCHPAGE              ALLOCATE A PAGE FROM USER CHAIN  00736000
         LR    CHR,XR2                 RESTORE CHR                      00737000
         BNZ   NFREEN                  GO IF NOT SUCCESSFUL             00738000
         SPACE                                                          00739000
* CONTROL COMES HERE TO PUT A PAGE BLOCK ON THE CHAIN POINTED TO BY     00740000
* CHR.                                                                  00741000
NFREEB   EQU   *                                                        00742000
         BAL   RR,SETKEY               SET NUC STORAGE KEY FOR BLKP3026 00743000
         CL    R0,PAGESIZE             IS REQUESTED SIZE > 1 PAGE?      00744000
         CLEANUP H                     SET CLEANUP FLAG IF SO           00745000
         BAL   RR,SETCODE              SET NUCLEUS-ASSIGNED CODE        00746000
         BAL   RR,SFRT                 PUT BLOCK ONTO NUCLEUS CHAIN     00747000
         B     NFREER                  GO RE-ATTEMPT ALLOCATION         00748000
         SPACE                                                          00749000
* IF THE ALLOCATION FOR THE GIVEN CHAIN FAILS, THEN CONTROL COMES       00750000
* HERE.  THE FIRST TIME CONTROL COMES HERE, WE POINT TO THE HIGHCORE    00751000
* CHAIN AND RETURN TO NFREER TO ATTEMPT ALLOCATION FROM THAT CHAIN.     00752000
* THE NEXT TIME, WE MUST TRY EXTEND STORAGE.                            00753000
NFREEN   EQU   *                                                        00754000
         TM    FREEFLG1,FRF1H          AREA=HIGH ALLOWED?               00755000
         BZ    NFREEV                  GO TRY VARIABLE IF NOT           00756000
         SPACE                                                          00757000
* CHECK TO SEE IF WE HAVE ALREADY LOOKED AT THE HIGHCORE NUC CHAIN.     00758000
         TM    FLAGS(CHR),FLHC         HIGHCORE CHAIN?                  00759000
         LA    CHR,FREEHN              POINT TO HIGHCORE CHAIN          00760000
         BNO   NFREER                  GO TRY HIGHCORE CHAIN            00761000
         L     SR,PAGESIZE             PUT PAGESIZE INTO SR             00762000
         BAL   RR,GEXT                 GET EXTEND STORAGE               00763000
         BZ    NFREEB                  PUT STORAGE ONTO NUC CHAIN,     *00764000
                                       IF AVAILABLE                     00765000
         SPACE 2                                                        00766000
* CONTROL COMES HERE IF THE FIXED REQUEST CANNOT BE SATISFIED.          00767000
* AT THIS POINT, ALL AVAILABLE PAGES ARE ON THE NUCLEUS CHAIN.          00768000
* WE TRY FOR A VARIABLE REQUEST.                                        00769000
NFREEV   EQU   *                                                        00770000
         TM    FREEFLG1,FRF1V          VARIABLE REQUEST MADE?           00771000
         RTN   Z,1,FINIS               RETURN RC=1 (NO CORE) IF NOT     00772000
         SPACE                                                          00773000
* MIN SIZE ALLOWED IS IN R1 IN DOUBLEWORDS.  CONVERT TO BYTES.          00774000
         CVDB  R1,ERR=4                CONVERT R1 FROM DWORDS TO BYTES  00775000
         CR    R1,R0                   COMPARE WITH MAX REQUEST         00776000
         RTN   H,4,FINIS               ILLEGAL ARG IF LARGER            00777000
         LR    SR,R1                   GET MIN SIZE ALLOWED             00778000
         BCTR  SR,0                    DECREMENT FOR SCHVAR ROUTINE     00779000
         SR    BLR,BLR                 NO BLOCK FOUND YET               00780000
         LA    CHR,FREELN              POINT TO LOW-CORE NUC CHAIN      00781000
         TM    FREEFLG1,FRF1L          AREA=LOW ALLOWED?                00782000
         BZ    *+8                     SKIP CALL IF NOT                 00783000
         SPACE                                                          00784000
* SCHVAR WILL FIND THE LARGEST BLOCK ON THE CHAIN WHOSE SIZE IS         00785000
* LARGER THAN THE VALUE IN REGISTER SR.                                 00786000
         BAL   RR,SCHVAR               FIND LARGEST BLOCK.              00787000
         LR    XR2,BLR                 SAVE RETURNED VALUE TEMPORARILY  00788000
         LA    CHR,FREEHN              POINT TO HIGHCORE BLOCK          00789000
         TM    FREEFLG1,FRF1H          AREA=HIGH ALLOWED?               00790000
         BZ    *+8                     SKIP CALL TO SCHVAR IF NOT       00791000
         BAL   RR,SCHVAR               FIND ANY LARGER BLOCK            00792000
         LTR   BLR,BLR                 ANY BLOCK FOUND WHATSOEVER?      00793000
         RTN   Z,1,FINIS               RETURN RC=1 (NO CORE) IF NONE    00794000
         CR    SR,R1                   BLOCK LARGER THAN MIN SIZE?      00795000
         RTN   L,33,FINIS              IMPOSSIBLE IF NOT                00796000
         CR    SR,R0                   BLOCK SMALLER THAN MAX SIZE?     00797000
         RTN   NL,34,FINIS                                              00798000
         CLR   BLR,XR2                 WAS BLOCK ALLOCATED FROM        *00799000
                                       LOW CORE CHAIN?                  00800000
         BNE   *+8                     SKIP IF NOT                      00801000
         LA    CHR,FREELN              POINT TO LOWCORE CHAIN           00802000
         BAL   RR,ALOC                 ALLOCATE BLOCK FROM CHAIN        00803000
         B     RETURN                  RETURN TO CALLER                 00804000
AEXT     EQU   *                                                        00806000
         SPACE                                                          00807000
* ALLOCATE ALL AVAILABLE EXTEND STORAGE.                                00808000
         SPACE                                                          00809000
* NORMAL RETURN:                                                        00810000
*        BLR -> BLOCK OF ALL REMAINING EXTEND STORAGE                   00811000
*        SR CONTAINS THE SIZE OF THIS BLOCK.                            00812000
         SPACE                                                          00813000
* ERROR RETURN:                                                         00814000
*        RC = 1 (NO STORAGE AVAILABLE)                                  00815000
         SPACE 2                                                        00816000
* THE LOWEST POSSIBLE EXTEND AREA ADDRESS IS EQUAL TO THE MAXIMUM       00817000
* OF MAINHIGH, LOCCNT, AND AUSRAREA.                                    00818000
         L     BLR,MAINHIGH            GET MAINHIGH                     00819000
         CL    BLR,LOCCNT              COMPARE WITH LOCCNT              00820000
         BH    *+8                     SKIP IF HIGHER                   00821000
         L     BLR,LOCCNT              USE LOCCNT IF HIGHER             00822000
         CL    BLR,AUSRAREA            COMPARE WITH USERAREA ADDR       00823000
         BH    *+8                     SKIP IF HIGHER                   00824000
         L     BLR,AUSRAREA            USE IT IF HIGHER                 00825000
         ROUND UP,BLR                  ROUND UP TO PAGE BOUNDARY        00826000
         CL    BLR,FREELOWE            LOWER THAN EXISTING LOW EXTEND?  00827000
         RTN   NL,1                    RETURN RC=1 IF NOT (NO CORE)     00828000
         L     SR,FREELOWE             GET OLD LOW EXTEND LOCATION      00829000
         SR    SR,BLR                  OBTAIN SIZE OF NEW BLOCK         00830000
         ST    BLR,FREELOWE            STORE NEW LOW EXTEND VALUE       00831000
         RTN   ,0                      RETURN RC=0 TO CALLER            00832000
ALOC     EQU   *                                                        00834000
         SPACE                                                          00835000
* THIS SUBROUTINE ALLOCATES A SPECIFIC BLOCK OF A SPECIFIC SIZE FROM    00836000
* A SPECIFIC CHAIN.                                                     00837000
         SPACE                                                          00838000
* AT ENTRY:                                                             00839000
*        BLR -> DESIRED BLOCK                                           00840000
*        SR CONTAINS SIZE OF BLOCK                                      00841000
*        CHR -> DESIRED CHAIN HEADER                                    00842000
         SPACE                                                          00843000
* NORMAL RETURN:                                                        00844000
*        BLR AND SR ARE UNCHANGED                                       00845000
*        THE BLOCK IS REMOVED FROM THE SPECIFIED CHAIN                  00846000
         SPACE                                                          00847000
* ERROR RETURN:                                                         00848000
*        IF THE BLOCK CANNOT BE ALLOCATED, THEN IT IS ASSUMED THAT      00849000
*        THERE IS AN ERROR IN INTERNAL DMSFRE LOGIC, AND THE ROUTINE    00850000
*        IS TERMINATED IMMEDIATELY.                                     00851000
         SPACE 3                                                        00852000
* ALOCC ENTRY IS USED TO SAVE TIME IF CURRENT CHAIN ELEMENTS ARE        00853000
*        ALREADY KNOWN.                                                 00854000
         SPACE                                                          00855000
* ADDITIONAL ENTRY REQUIREMENTS:                                        00856000
*        BLR, SR AND CHR AS ABOVE                                       00857000
*        PTR -> CHAIN ELEMENT CONTAINS DESIRED BLOCK                    00858000
*        PPTR -> PREVIOUS CHAIN ELEMENT (OR CHAIN HEADER)               00859000
         SPACE 3                                                        00860000
* ALOC ENTRY                                                            00861000
         L     CR,NUM(,CHR)            GET NUMBER OF CHAIN ELEMENTS     00862000
         LTR   CR,CR                   ANY CHAIN ELEMENTS?              00863000
         RTN   Z,20,FINIS              IMPOSSIBLE IF NONE               00864000
         SPACE                                                          00865000
* SET UP TWO REGISTERS TO SAVE TIME IN LOOP                             00866000
         LA    R14,ALOCL               FOR LOOP                         00867000
         LA    R15,ALOCF               FOR LOOP                         00868000
         LR    PTR,CHR                 INITIALIZE CHAIN ELEMENT POINTER 00869000
         SPACE                                                          00870000
* THE FOLLOWING LOOP SEARCHES FOR THE CHAIN ELEMENT CONTAINING THE      00871000
* DESIRED BLOCK.                                                        00872000
         CNOP  0,8                     FOR SPEED                        00873000
ALOCL    EQU   *                                                        00874000
         LR    PPTR,PTR                MOVE UP ONE CHAIN ELEMENT        00875000
         L     PTR,POINTER(,PTR)       POINT TO NEXT CHAIN ELEMENT      00876000
         CLR   PTR,BLR                 HAVE WE FOUND BLOCK YET?         00877000
         BCR   13,R15 (BNH ALOCF)      GO IF FOUND                      00878000
         BCTR  CR,R14 (BCT CR,ALOCL)   COUNT CHAIN BLOCKS               00879000
         RTN   ,21,FINIS               WE'RE OUT OF THEM -- IMPOSSIBLE  00880000
         SPACE                                                          00881000
* COME HERE WHEN THE BLOCK HAS BEEN FOUND.  AT THIS POINT, THE          00882000
* REGISTERS ARE SET UP AS FOLLOWS:                                      00883000
*        BLR -> DESIRED BLOCK                                           00884000
*        SR CONTAINS SIZE OF DESIRED BLOCK (IN BYTES)                   00885000
*        PTR -> CHAINED FREE BLOCK CONTAINING DESIRED BLOCK             00886000
*        PPTR -> PREVIOUS BLOCK IN CHAIN                                00887000
ALOCF    EQU   *                                                        00888000
         SPACE                                                          00889000
* ALOCC ENTRY.                                                          00890000
* THIS ENTRY POINT IS USED AS AN ALTERNATE ENTRY POINT TO ALOC WHEN     00891000
* THE ABOVE REGISTERS ARE ALREADY SET.                                  00892000
ALOCC    EQU   *                                                        00893000
         L     CR,NUM(,CHR)            GET NUMBER OF ELEMENTS IN CHN    00894000
         CLR   PTR,BLR                 IS DESIRED BLOCK AT BEGINNING   *00895000
                                       OF THIS FREE CHAIN ENTRY?        00896000
         BE    ALOCT                   GO IF IT IS                      00897000
         SPACE                                                          00898000
* OTHERWISE, WE MUST LOP OFF PART OF THE BOTTOM OF THE CHAIN ELEMENT,   00899000
* UP TO THE DESIRED BLOCK.                                              00900000
* WE DO THAT BY SIMPLY MAKING IT A SEPARATE BLOCK ON THE FREE CHAIN.    00901000
         LR    R14,BLR                 R14 -> DESIRED BLOCK             00902000
         SR    R14,PTR                 R14 CONTAINS SIZE OF FREE BLOCK *00903000
                                       BELOW DESIRED BLOCK              00904000
         L     XR,SIZE(,PTR)           XR CONTAINS SIZE OF ENTIRE FREE *00905000
                                       ELEMENT CONTAINING DESIRED BLK   00906000
         ST    R14,SIZE(,PTR)          SET SIZE OF NEW LOPPED OFF BLOCK 00907000
         SR    XR,R14                  SIZE REMAINING IN UPPER BLOCK    00908000
         ST    BLR,POINTER(,PPTR)      PUT UPPER BLOCK INTO CHAIN       00909000
         ST    PTR,POINTER(,BLR)                                        00910000
         ST    XR,SIZE(,BLR)           STORE SIZE OF UPPER BLOCK        00911000
         LA    CR,1(,CR)               INCREMENT FREE CHAIN ELEMENT    *00912000
                                       COUNT                            00913000
         LR    PTR,BLR                 MAKE UPPER PART THE NEW CURRENT *00914000
                                       BLOCK                            00915000
         SPACE 2                                                        00916000
* WHEN CONTROL REACHES THIS POINT, THE CURRENT CHAIN ELEMENT (POINTED   00917000
* TO BY PTR) BEGINS AT THE ADDRESS OF THE DESIRED BLOCK.  (I.E.,        00918000
* PTR = BLR.)                                                           00919000
ALOCT    EQU   *                                                        00920000
         C     SR,SIZE(,PTR)           COMPARE DESIRED SIZE WITH SIZE  *00921000
                                       OF FREE ELEMENT                  00922000
         BE    ALOCE                   GO IF THEY'RE EQUAL              00923000
         SPACE                                                          00924000
* CHECK TO SEE IF THE CHAIN ELEMENT IS LARGE ENOUGH.                    00925000
         RTN   H,22,FINIS              NOT LARGE ENOUGH -- IMPOSSIBLE   00926000
         SPACE                                                          00927000
* OTHERWISE, THE CHAIN ELEMENT IS LARGER THAN THE DESIRED BLOCK, AND    00928000
* SO A BLOCK MUST BE LOPPED OFF THE TOP OF THE CHAIN ELEMENT.  WE       00929000
* SIMPLY MAKE THE TOP PART OF THE BLOCK A SEPARATE CHAIN ELEMENT.       00930000
         LR    R14,SR                  R14 CONTAINS SIZE OF DESIRED BLK 00931000
         AR    R14,PTR                 R14 -> UPPER BLOCK               00932000
         L     XR,SIZE(,PTR)           XR = SIZE OF ENTIRE FREE ELEMENT 00933000
         SR    XR,SR                   SR = SIZE OF UPPER BLOCK         00934000
         SPACE                                                          00935000
* WE PLACE THE UPPER BLOCK IN THE CHAIN, REMOVING THE REQUESTED BLOCK.  00936000
         ST    R14,POINTER(,PPTR)      PUT UPPER BLOCK INTO CHAIN       00937000
         ST    XR,SIZE(,R14)           STORE SIZE OF NEW UPPER BLOCK    00938000
         MVC   POINTER(4,R14),POINTER(PTR) PUT UPPER BLOCK INTO CHAIN   00939000
         B     ALOCX                                                    00940000
         SPACE 2                                                        00941000
* CONTROL COMES HERE IF THE CHAIN ELEMENT IS EXACTLY EQUAL TO THE       00942000
* DESIRED BLOCK.  WE SIMPLY REMOVE THIS BLOCK FROM THE CHAIN.           00943000
ALOCE    EQU   *                                                        00944000
         MVC   POINTER(4,PPTR),POINTER(PTR) REMOVE FROM CHAIN           00945000
         BCTR  CR,0                    DECREMENT ELEMENT COUNT          00946000
         SPACE                                                          00947000
* CONTROL COMES HERE WHEN THE DESIRED BLOCK HAS BEEN REMOVED FROM       00948000
* THE CHAIN, WITH CR CONTAINING THE NEW CHAIN ELEMENT COUNT.            00949000
ALOCX    EQU   *                                                        00950000
         ST    CR,NUM(,CHR)            STORE ELEMENT COUNT              00951000
         RTN   ,0                      RETURN RC=0 TO CALLER            00952000
FINDCHN  EQU   *                                                        00954000
         SPACE                                                          00955000
* THIS SUBROUTINE IS CALLED BY 'FRET' TO DETERMINE ON WHICH OF THE FOUR 00956000
* CHAINS THE FRETTED BLOCK BELONGS (LOW VS HIGH CORE, USER VS NUCLEUS)  00957000
         SPACE                                                          00958000
* INPUT:                                                                00959000
*        BLR -> BLOCK                                                   00960000
*        SR = SIZE OF BLOCK                                             00961000
         SPACE                                                          00962000
* RESULTS:                                                              00963000
*        CHR -> CORRECT CHAIN                                           00964000
*        FREEFLG1 FLAGS ARE SET AS FOLLOWS:                             00965000
*              FRF1N IF NUCLEUS BLOCK                                   00966000
*              FRF1L IF LOW-CORE BLOCK                                  00967000
*              FRF1H IF HIGH-CORE BLOCK                                 00968000
         SPACE                                                          00969000
* ERROR CHECKING:                                                       00970000
*        IF BLOCK DOES NOT BELONG ENTIRELY TO ONE CHAIN, A DIRECT       00971000
*        RETURN IS MADE WITH RC=6.                                      00972000
*        IF NOT DOUBLE-WORD ALIGNED, THEN RC=7                          00973000
*        IF SIZE <= 0 THEN RC=5                                         00974000
         SPACE 2                                                        00975000
         LA    XR,7                    CHECK DOUBLE-WORD ALIGNMENT      00976000
         NR    XR,BLR                  'AND' OUT HIGHORDER BITS         00977000
         RTN   NZ,7,FINIS              RETURN RC=7 IF NOT DOUBLEWORD    00978000
         LTR   SR,SR                   CHECK SIZE                       00979000
         RTN   NP,5,FINIS              ERROR IF NOT > 0                 00980000
         C     BLR,VMSIZE              BLOCK ADDRESS IN MEMORY?   P3015 00981000
         RTN   NL,6,FINIS              RETURN CODE 6 IF NOT       P3015 00982000
         LR    R14,BLR                 R14 -> BLOCK                     00983000
         ROUND DOWN,R14                ROUND DOWN TO PAGE BOUNDARY      00984000
         LR    R15,SR                  R15 = SIZE OF BLOCK              00985000
         AR    R15,BLR                 R15 -> END OF BLOCK              00986000
         C     R15,VMSIZE              END OF BLOCK WITHIN MEMORY?P3015 00987000
         RTN   H,6,FINIS               RETURN CODE 6 IF NOT       P3015 00988000
         ROUND UP,R15                  ROUND UP R15 TO PAGE BOUNDARY    00989000
         SR    R15,R14                 LENGTH OF PAGE GROUP CONTAINING *00990000
                                       BLOCK                            00991000
         SRL   R14,12                  DIVIDE BY 4096: R14 = PAGE NUM   00992000
         SRL   R15,12                  DIVIDE BY 4096: R15 = NUM PAGES  00993000
         SPACE                                                          00994000
* FREETAB CONTAINS ONE BYTE FOR EACH PAGE OF VIRTUAL MEMORY.  THAT      00995000
* BYTE INDICATES WHETHER THAT PAGE IS ASSIGNED TO USER FREE/FRET        00996000
* STORAGE, NUCLEUS FREE/FRET STORAGE, OR UNASSIGNED TO FREE/FRET        00997000
* STORAGE.                                                              00998000
* WE CHECK TO SEE IF ALL THE TYPES CORRESPONDING TO THE BLOCK           00999000
* BEING RETURNED ARE THE SAME, EITHER NUCLEUS OR USER.                  01000000
         AL    R14,AFREETAB            POINT TO FIRST BYTE IN FREETAB   01001000
         SPACE                                                          01002000
* HOWEVER, IF THE SECOND INITIALIZATION HAS NOT YET BEEN INVOKED, THEN  01003000
* FREETAB HAS NOT YET BEEN ALLOCATED.  IN THIS CASE, WE SIMPLY POINT    01004000
* R14 TO A DUMMY BYTE CONTAINING THE NUCLEUS CODE.                      01005000
         TM    FREEFLG2,FRF2NOI        NO SECOND INITIALIZATION?        01006000
         BNO   *+8                     SKIP IF THERE WAS ONE            01007000
         LA    R14,=AL1(NUCCODE)       POINT TO DUMMY NUCCODE BYTE      01008000
         SPACE                                                          01009000
         LA    CHR,FREELN              ASSUME NUCLEUS LOW-CORE CHAIN    01010000
         CL    BLR,AUSRAREA            IS IT HIGH CORE?                 01011000
         BL    *+8                     SKIP IF NOT                      01012000
         LA    CHR,FREEHN              ASSUME NUCLEUS HIGH-CORE CHAIN   01013000
         SPACE                                                          01014000
* WE NOW EXAMINE THE BYTE IN FREETAB.                                   01015000
         CLI   0(R14),MAXCODE          GREATER THAN MAXIMUM CODE VALUE? 01016000
         RTN   H,30,FINIS              IMPOSSIBLE IF HIGHER             01017000
         CLI   0(R14),0                TEST IF ZERO                     01018000
         RTN   E,31,FINIS              IMPOSSIBLE IF SO                 01019000
         CLI   0(R14),NUCCODE          IS IT NUCLEUS CODE?              01020000
         BE    FINDCHN1                GO IF NUCLEUS PAGE               01021000
         CLI   0(R14),USERCODE         IS IT USER CODE                  01022000
         RTN   NE,6,FINIS              ILLEGAL ARGS IF NOT              01023000
         LA    CHR,BLOCKLEN(,CHR)      POINT TO CORRESPONDING USER     *01024000
                                       CHAIN IF SO                      01025000
         SPACE                                                          01026000
* WHEN CONTROL REACHES THIS POINT, CHR POINTS TO THE CORRECT CHAIN,     01027000
* R14 POINTS TO THE FIRST FREETAB BYTE FOR THE GROUP OF PAGES,          01028000
* AND R15 CONTAINS THE NUMBER OF PAGES.                                 01029000
* WE FIRST SET THE FREEFLG1 FLAG BITS.                                  01030000
FINDCHN1 EQU   *                                                        01031000
         TM    FLAGS(CHR),FLNU         NUCLEUS CHAIN?                   01032000
         BZ    *+8                     SKIP IF NOT                      01033000
         OI    FREEFLG1,FRF1N          SET NUCLEUS BIT                  01034000
         OI    FREEFLG1,FRF1L          DEFAULT LOW-CORE BIT             01035000
         TM    FLAGS(CHR),FLHC         HIGH-CORE CHAIN?                 01036000
         BZ    *+8                     SKIP IF NOT                      01037000
         XI    FREEFLG1,FRF1L+FRF1H    SWITCH TO HIGHCORE BIT           01038000
         SPACE                                                          01039000
* WE NOW CHECK TO SEE IF ALL THE BYTES IN THE FREETAB TABLE FOR THIS    01040000
* PAGE GROUP ARE EQUAL.                                                 01041000
         SPACE                                                          01042000
* HOWEVER, IF THE SECOND INITIALIZATION ROUTINE HAS NOT YET BEEN        01043000
* INVOKED, THEN THERE IS NOTHING MORE TO DO.                            01044000
         TM    FREEFLG2,FRF2NOI        NO SECOND INITIALIZATION?        01045000
         RTN   O,0                     NORMAL RETURN IF NONE            01046000
         SPACE                                                          01047000
         IC    XR,0(R14)               GET FIRST BYTE FROM TABLE        01048000
         SLL   XR,24                   PUT INTO HIGH BYTE OF REG        01049000
         SPACE                                                          01050000
* NOTE: XR IS AN ODD-NUMBERED REGISTER WHICH CONTAINS A ZERO ADDRESS    01051000
* AND A PAD CHARARACTER EQUAL TO THE CHARACTER IN THE TABLE.  THE       01052000
* CONTENTS OF REGISTER (XR-1) ARE IRRELEVANT.                           01053000
         CLCL  R14,XR-1                CHECK TO SEE IF BYTES ARE ALL   *01054000
                                       THE SAME                         01055000
         USING FRDSECT,TR                                               01056000
         RTN   E,0                     RETURN RC=0 IF THEY ARE          01057000
         RTN   ,6,FINIS                OTHERWISE, ILLEGAL ARG           01058000
GEXT     EQU   *                                                        01060000
         SPACE                                                          01061000
* ALLOCATE 'EXTEND' PAGE OF PAGES.                                      01062000
         SPACE                                                          01063000
* AT ENTRY:                                                             01064000
*        SR = NUMBER OF BYTES REQUIRED (MUST BE PAGE MULTIPLE)          01065000
         SPACE                                                          01066000
* NORMAL RETURN:                                                        01067000
*        BLR -> ALLOCATED BLOCK OR EXTEND STORAGE                       01068000
*        SR IS UNCHANGED (= SIZE OF BLOCK)                              01069000
         SPACE                                                          01070000
* ERROR RETURN:                                                         01071000
*        RC=1 IF REQUEST STORAGE IS NOT AVAILABLE                       01072000
         SPACE 2                                                        01073000
         L     BLR,FREELOWE            LOAD LOW EXTEND POINTER          01074000
         SR    BLR,SR                  TENTATIVE NEW LOW EXTEND VALUE   01075000
         SPACE                                                          01076000
* THE NEW LOW EXTEND MUST EXCEED MAINHIGH, LOCCNT, AND AUSRAREA.        01077000
         C     BLR,MAINHIGH            COMPARE WITH END OF GETMAIN AREA 01078000
         RTN   L,1                     ERROR RETURN IF LOWER            01079000
         TM    BATFLAGS,BATLOAD  IS BATCH BEING LOADED ?       @VA05381 01079330
         BO    CKUAREA      YES, DON'T CHECK AGAINST LOCCNT    @VA05381 01079660
         CL    BLR,LOCCNT              COMPARE WITH LOADER LOCATION    *01080000
                                       COUNTER                          01081000
         RTN   L,1                     ERROR RETURN IF LOWER            01082000
CKUAREA  EQU   *                                               @VA05381 01082500
         CL    BLR,AUSRAREA            COMPARE WITH USER PROGRAM ADDR   01083000
         RTN   L,1                     ERROR RETURN IF LOWER            01084000
         ST    BLR,FREELOWE            STORE NEW LOW EXTEND VALUE       01085000
         RTN   ,0                      RETURN RC=0                      01086000
SCHFIX   EQU   *                                                        01088000
         SPACE                                                          01089000
* SEARCH THE SPECIFIED FREE CHAIN FOR A BLOCK OF THE DESIRED SIZE, AND  01090000
* ALLOCATE IT AND RETURN ITS ADDRESS.                                   01091000
         SPACE                                                          01092000
* AT ENTRY:                                                             01093000
*        SR = SIZE OF DESIRED BLOCK                                     01094000
*        CHR -> CHAIN HEADER BLOCK OF CHAIN TO BE SEARCHED              01095000
         SPACE                                                          01096000
* NORMAL RETURN:                                                        01097000
*        SEARCHED CHAIN IS ADJUSTED                                     01098000
*        BLR -> ALLOCATED BLOCK                                         01099000
         SPACE                                                          01100000
* ERROR RETURN:                                                         01101000
*        RC = 1 (NO STORAGE AVAILABLE)                                  01102000
*        CHAIN IS LEFT UNCHANGED                                        01103000
         SPACE 2                                                        01104000
         L     CR,NUM(,CHR)            GET NUM OF ELEMENTS ON CHAIN     01105000
         LTR   CR,CR                   ANY ELEMENTS?                    01106000
         RTN   Z,1                     RETURN RC=1 IF NOTHING TO DO     01107000
         CL    SR,MAX(,CHR)            SR EXCEED MAX BLOCK ON CHAIN?    01108000
         RTN   H,1                     IF YES, NO POINT IN EVEN        *01109000
                                       CHECKING -- RETURN RC=1          01110000
         LR    PTR,CHR                 INITIALIZER CHAIN ELEMENT PTR    01111000
         LA    R14,SCHFIXL             FOR SPEED IN LOOP                01112000
         LA    R15,SCHFIXF             FOR SPEED IN LOOP                01113000
         SPACE                                                          01114000
* THE FOLLOWING LOOP SEARCHES FOR THE FIRST FREE ELEMENT IN THE         01115000
* CHAIN WHICH IS LARGE ENOUGH TO ACCOMODATE THE REQUEST.                01116000
         CNOP  0,8                     FOR SPEED                        01117000
SCHFIXL  EQU   *                                                        01118000
         LR    PPTR,PTR                ADVANCE ONE CHAIN ELEMENT        01119000
         L     PTR,POINTER(,PTR)                                        01120000
         CL    SR,SIZE(,PTR)           CHAIN ELEMENT BIG ENOUGH?        01121000
         BCR   13,R15 (BNH SCHFIXF)    GO IF YES                        01122000
         BCTR  CR,R14 (BCT CR,SCHFIXL) COUNT BLOCKS AND LOOP BACK       01123000
         SPACE                                                          01124000
* COME HERE IF WE'VE RUN OUT OF BLOCKS                                  01125000
* FIRST, RESET MAX TO ONE LESS THAN CURRENT SEARCH VALUE.               01126000
         LR    XR,SR                   XR = BLOCK BEING SEARCHED FOR    01127000
         BCTR  XR,0                    DECREMENT BY ONE                 01128000
         ST    XR,MAX(,CHR)            STORE AS NEW MAX                 01129000
         L     PTR,POINTER(,PTR)       LOAD NEXT POINTER                01130000
         LTR   PTR,PTR                 IT HAD BETTER BE ZERO            01131000
         RTN   Z,1                     IF SO, RETURN RC=1 (NO CORE)     01132000
         RTN   ,55,CLOB                CHAIN CLOBBERED IF NOT           01133000
         SPACE 2                                                        01134000
* COME HERE IF A CHAIN ELEMENT IS BIG ENOUGH.  AT THIS POINT, THE       01135000
* FOLLOWING REGISTERS ARE SET:                                          01136000
*        PTR -> CURRENT FREE CHAIN ELEMENT                              01137000
*        PPTR -> PREVIOUS FREE CHAIN ELEMENT (OR CHAIN HEADER)          01138000
*        CHR -> CHAIN HEADER                                            01139000
         SPACE                                                          01140000
* THE CONDITION IS STILL SET FROM THE LASE 'CL SR,SIZE(,PTR)'           01141000
* INSTRUCTION.                                                          01142000
SCHFIXF  EQU   *                                                        01143000
         BE    SCHFIXE                 GO IF CHAIN ELT IS EXACTLY RIGHT 01144000
         SPACE                                                          01145000
* OTHERWISE, WE MUST LOP OFF THE BOTTOM PART OF THE BLOCK AND ALLOCATE  01146000
* THE TOP PART OF THE REQUIRED SIZE.                                    01147000
         L     XR,SIZE(,PTR)           GET SIZE OF CHAIN ELEMENT        01148000
         SR    XR,SR                   COMPUTE SIZE REMAINING IN       *01149000
                                       BOTTOM PART                      01150000
         ST    XR,SIZE(,PTR)           STORE NEW BLOCK SIZE             01151000
         LA    BLR,0(XR,PTR)           ADDRESS OF ALLOCATED BLOCK       01152000
         RTN   ,0                      RETURN RC=0                      01153000
         SPACE 2                                                        01154000
* COME HERE IF THE CHAIN ELEMENT IS EXACTLY THE SIZE REQUESTED.         01155000
SCHFIXE  EQU   *                                                        01156000
         MVC   0(4,PPTR),0(PTR)        REMOVE CHAIN ELEMENT FROM CHAIN  01157000
         L     CR,NUM(,CHR)            DECREMENT ELEMENT COUNT          01158000
         BCTR  CR,0                                                     01159000
         ST    CR,NUM(,CHR)                                             01160000
         LR    BLR,PTR                 POINT TO ALLOCATED BLOCK         01161000
         RTN   ,0                      AND RETURN                       01162000
SCHPAGE  EQU   *                                                        01164000
         SPACE                                                          01165000
* SEARCH SPECIFIED CHAIN FOR FULL PAGE(S).  WILL RETURN BLOCK ONLY      01166000
* PAGE-ALIGNED AND ONLY A MULTIPLE OF A PAGE.                           01167000
         SPACE                                                          01168000
* INPUT:                                                                01169000
*        CHR -> CHAIN                                                   01170000
*        SR = SIZE OF BLOCK (PAGE MULTIPLE)                             01171000
         SPACE                                                          01172000
* NORMAL RETURN                                                         01173000
*        BLR -> BLOCK, REMOVED FROM CHAIN                               01174000
         SPACE                                                          01175000
* ERROR RETURN                                                          01176000
*        BLR = GARBAGE                                                  01177000
*        RC = 1 (NO CORE AVAILABLE)                                     01178000
         SPACE                                                          01179000
         NI    FREEFLG2,X'FF'-FRF2SVP  TURN OFF SCHVPGE FLAG            01180000
         B     SCHPC                                                    01181000
         EJECT                                                          01182000
SCHVPGE  EQU   *                                                        01183000
         SPACE                                                          01184000
* SCHVPGE IS LIKE SCHPAGE, EXCEPT THAT IT IS USED FOR VARIABLE          01185000
* REQUESTS, AND RETURNS AN ENTIRE BLOCK OF PAGES WHICH IS GREATER THAN  01186000
* OR EQUAL TO THE DESIRED MINIMUM SIZE.                                 01187000
         SPACE                                                          01188000
* AT ENTRY:                                                             01189000
*        SR = MINIMUM SIZE IN BYTES (MULTIPLE OF PAGE SIZE)             01190000
         SPACE                                                          01191000
* NORMAL RETURN:                                                        01192000
*        SR = ACTUAL SIZE ALLOCATED                                     01193000
*        BLR -> ALLOCATED BLOCK                                         01194000
         SPACE                                                          01195000
* ERROR RETURN                                                          01196000
*        RC = 1 (NO STORAGE AVAILABLE)                                  01197000
         SPACE 2                                                        01198000
         OI    FREEFLG2,FRF2SVP        SET SCHVPGE FLAG                 01199000
         EJECT                                                          01200000
* COMMON BRANCH POINT FOR SCHPAGE AND SCHVPGE.  THE FLAG FRF2SVP        01201000
* IN FREEFLG2 IS SET IF AND ONLY IF SCHVPGE WAS THE ENTRY POINT.        01202000
SCHPC    EQU   *                                                        01203000
         TM    FLAGS(CHR),FLPA         PAGE AVAILABLE ON CHAIN?         01204000
         RTN   Z,1                     JUST RETURN (RC=1) IF NOT        01205000
         L     CR,NUM(,CHR)            GET NUMBER OF BLOCKS             01206000
         LTR   CR,CR                   ANY IN THE CHAIN?                01207000
         RTN   Z,1                     THEN THERE'S NO USE LOOKING      01208000
         CL    SR,MAX(,CHR)            DOES ANY BLOCK OF MIN SIZE      *01209000
                                       EXIST IN THE CHAIN?              01210000
         RTN   H,1                     RETURN RC=1 IF NOT               01211000
         LA    R14,SCHPAGL             TO SPEED UP LOOP                 01212000
         LA    R15,SCHPAGF             TO SPEED UP LOOP                 01213000
         LR    PTR,CHR                 INITIALIZE CHAIN ELEMENT PTR     01214000
         SPACE                                                          01215000
* WE USE THE HIGH BYTE OF REG RR AS A FLAG BYTE TO INDICATE THAT NO     01216000
* BLOCK OF THE REQUIRED MINIMUM SIZE WAS FOUND.  (OF COURSE, JUST       01217000
* FINDING A LARGE ENOUGH BLOCK IS NOT ENOUGH.  IT MAY BECOME TOO        01218000
* SMALL WHEN WE ALIGN IT TO PAGE BOUNDARIES.)                           01219000
         O     RR,=AL1(X'FF',0,0,0)    NO BLOCK FOUND YET               01220000
         SPACE                                                          01221000
* THE FOLLOWING LOOP SEARCHES FOR A BLOCK OF THE REQUIRED MIN SIZE.     01222000
         CNOP  0,8                     FOR SPEED                        01223000
SCHPAGL  EQU   *                                                        01224000
         LR    PPTR,PTR                MOVE UP ONE CHAIN ELEMENT        01225000
         L     PTR,POINTER(,PTR)                                        01226000
         CL    SR,SIZE(,PTR)           CHAIN ELEMENT LARGE ENOUGH?      01227000
         BCR   13,R15 (BNH SCHPAGF)    GO IF BIG ENOUGH                 01228000
         SPACE                                                          01229000
* A RETURN IS MADE TO SCHPAGLR IF THE BLOCK WHICH IS BIG ENOUGH NOW     01230000
* TURNS OUT TO BE TOO SMALL WHEN IT IS ROUNDED TO PAGE BOUNDARIES.      01231000
SCHPAGLR EQU   *                                                        01232000
         BCTR  CR,R14 (BCT CR,SCHPAGL) COUNT FREE ELEMENTS              01233000
         SPACE                                                          01234000
* COME HERE WHEN WE'VE RUN OUT OF BLOCKS.                               01235000
         LR    XR,SR                   COPY REQUESTED SIZE              01236000
         BCTR  XR,0                    DECREMENT                        01237000
         LTR   RR,RR                   WAS ANY BLOCK FOUND?             01238000
         BNM   SCHPAGL1                SKIP RESETTING CODE IF SO        01239000
         ST    XR,MAX(,CHR)            STORE NEW MAX FIELD              01240000
         CL    SR,PAGESIZE             SIZE REQUESTED > 1 PAGE?         01241000
         BH    *+8                     SKIP IF YES                      01242000
         NI    FLAGS(CHR),X'FF'-FLPA   TURN OFF 'PAGE AVAILABLE' FLAG   01243000
         SPACE                                                          01244000
SCHPAGL1 EQU   *                                                        01245000
         L     PTR,POINTER(,PTR)       LOAD NEXT POINTER                01246000
         LTR   PTR,PTR                 ANYTHING THERE?                  01247000
         RTN   Z,1                     RETURN RC=1 IF NOT               01248000
         RTN   ,56,CLOB                IMPOSSIBLE CONDITION IF SO       01249000
         SPACE                                                          01250000
* CONTROL COMES HERE WHEN A BIG ENOUGH BLOCK IS FOUND.  WE MUST PAGE    01251000
* ALIGN THE BLOCK AND SEE IF IT'S STILL BIG ENOUGH.                     01252000
SCHPAGF  EQU   *                                                        01253000
         LA    RR,0(,RR)               INDICATE THAT SOME BLOCK WAS FND 01254000
         LR    BLR,PTR                 POINTER TO FREE ELEMENT          01255000
         ROUND UP,BLR                  ROUND UP TO PAGE BOUNDARY        01256000
         LR    XR,PTR                  POINTER TO FREE ELEMENT          01257000
         A     XR,SIZE(,PTR)           POINTER TO END OF FREE ELEMENT   01258000
         SR    XR,BLR                  NUMBER OF BYTES BEYOND PAGE     *01259000
                                       BOUNDARY                         01260000
         CLR   SR,XR                   STILL BIG ENOUGH?                01261000
         BH    SCHPAGLR                RE-ENTER SEARCH LOOP IF NOT      01262000
         SPACE                                                          01263000
* CONTROL COMES HERE IF THE BLOCK AT PTR IS INDEED BIG ENOUGH.          01264000
* WE NOW MAKE AN ADJUSTMENT, FOR SCHPGE ONLY, IN CASE THERE ARE         01265000
* MORE PAGES AVAILABLE THAN WE NEED.  IN THIS CASE, WE GRAB ONLY THE    01266000
* HIGHEST PAGES.                                                        01267000
         SPACE                                                          01268000
* AT THIS POINT, REGISTERS ARE AS FOLLOWS:                              01269000
*        PTR -> FREE BLOCK                                              01270000
*        BLR = PTR ROUNDED UP TO PAGE BOUNDARY                          01271000
*        XR = SIZE OF FREE ELEMENT FROM BLR ON UP                       01272000
         SPACE                                                          01273000
* IN ADDITION, THE CONDITION CODE IS STILL SET FROM 'CLR SR,XR'.        01274000
         BE    SCHPAGC                 GO IF REST OF BLOCK = SIZE      *01275000
                                       DESIRED -- JUST TAKE IT.         01276000
         SPACE                                                          01277000
* OTHERWISE, IT'S TOO BIG.                                              01278000
         LR    R14,XR                  SIZE OF FREE ELT FROM BLR UP     01279000
         ROUND DOWN,R14                ROUND DOWN TO PAGE BOUNDARY      01280000
         TM    FREEFLG2,FRF2SVP        SCHVPGE ENTRY?                   01281000
         BZ    *+10                    SKIP TWO IF SCHPAGE              01282000
         LR    SR,R14                  SR = ENTIRE PAGE BLOCK SIZE      01283000
         B     SCHPAGC                 GO ALLOCATE IT                   01284000
         SPACE                                                          01285000
* MAYBE JUST THE PAGE BLOCK IS THE RIGHT SIZE.                          01286000
         CLR   R14,SR                                                   01287000
         BE    SCHPAGC                 GO IF IT'S JUST THE RIGHT SIZE   01288000
         SPACE                                                          01289000
* WE MUST MOVE THE POINTERS UP SO THAT WE ALLOCATE THE HIGHEST PAGES.   01290000
         SR    R14,SR                  R14=NUMBER OF PAGES TO ADVANCE   01291000
         SR    XR,R14                  UPDATE XR                        01292000
         AR    BLR,R14                 UPDATE BLR                       01293000
         SPACE                                                          01294000
* AT THIS POINT, WE HAVE:                                               01295000
*        BLR -> BLOCK DESIRED                                           01296000
*        SR = SIZE DESIRED                                              01297000
*        PTR -> FREE CHAIN ELEMENT WHICH MUST BE SUB-DIVIDED            01298000
*        PPTR -> PREVIOUS FREE CHAIN ELEMENT                            01299000
         SPACE                                                          01300000
* WE NOW ENTER THE ALOC SUBROUTINE TO ALLOCATE THE THE SUB-BLOCK.       01301000
SCHPAGC  EQU   *                                                        01302000
         B     ALOCC                                                    01303000
SCHVAR   EQU   *                                                        01305000
         SPACE                                                          01306000
* FOR VARIABLE SEARCHES, SEARCH SPECIFIED CHAIN FOR LARGEST BLOCK       01307000
* EXCEEDING A GIVEN MINIMUM SIZE.  THIS ROUTINE DOES NOT REMOVE THE     01308000
* BLOCK FROM THE CHAIN.                                                 01309000
         SPACE                                                          01310000
* AT ENTRY:                                                             01311000
*        SR = MINIMUM SIZE WHICH MUST BE EXCEEDED                       01312000
*        CHR -> CHAIN HEADER FOR DESIRED CHAIN                          01313000
         SPACE                                                          01314000
* NORMAL RETURN:                                                        01315000
*        RC = 0                                                         01316000
*        SR = SIZE OF BLOCK FOUND                                       01317000
*        BLR = ADDRESS OF BLOCK FOUND                                   01318000
         SPACE                                                          01319000
* ERROR RETURN (NO BLOCK OF REQUIRED MINIMUM SIZE)                      01320000
*        RC = 1 (NO STORAGE AVAILABLE)                                  01321000
*        SR, BLR ARE UNCHANGED                                          01322000
         SPACE 2                                                        01323000
         L     CR,NUM(,CHR)            GET FREE ELEMENT COUNT           01324000
         LTR   CR,CR                   ANY ELEMENTS?                    01325000
         RTN   Z,1                     RETURN RC=1 TO CALLER IF NOT     01326000
         CL    SR,MAX(,CHR)            DESIRED SIZE >= CHAIN MAX?       01327000
         RTN   NL,1                    RETURN RC=1 TO CALLER IF NOT     01328000
         LR    PTR,CHR                 INITIALIZE PTR                   01329000
         SR    XR,XR                   INDICATE NO BLOCK WAS FOUND      01330000
         LA    R15,SCHVARF             FOR SPEED IN LOOP                01331000
         LA    R14,SCHVARL             FOR SPEED IN LOOP                01332000
         SPACE                                                          01333000
* THIS LOOP SEARCHES THE CHAIN FOR A LARGE ENOUGH BLOCK.                01334000
SCHVARL  EQU   *                                                        01335000
         LR    PPTR,PTR                MOVE POINTERS UP ONE ELEMENT     01336000
         L     PTR,POINTER(,PTR)                                        01337000
         CL    SR,SIZE(,PTR)           BLOCK LARGER THAN MIN SIZE?      01338000
         BCR   11,R15 (BNL SCHVARF)    SKIP IF TOO SMALL                01339000
         BCTR  XR,0                    INDICATE THAT A BLOCK WAS FOUND  01340000
         LR    BLR,PTR                 POINT TO THE BLOCK               01341000
         L     SR,SIZE(,BLR)           SET NEW MINIMUM SIZE             01342000
         SPACE                                                          01343000
SCHVARF  EQU   *                                                        01344000
         BCTR  CR,R14 (BCT CR,SCHVARL) COUNT BLOCKS                     01345000
         SPACE                                                          01346000
* COME HERE WHEN THE ENTIRE CHAIN HAS BEEN SEARCHED.                    01347000
         ST    SR,MAX(,CHR)            SET CORRECT MAXIMUM              01348000
         L     PTR,POINTER(,PTR)       LOOK AT NEXT POINTER             01349000
         LTR   PTR,PTR                 ANYTHING THERE?                  01350000
         RTN   NZ,57,CLOB              CHAIN CLOBBERED IF SO            01351000
         LTR   XR,XR                   ANY BLOCK FOUND?                 01352000
         RTN   M,0                     YES, IF XR < 0                   01353000
         RTN   ,1                      IF NOT, RETURN RC=1 (NO CORE)    01354000
SETCODE  EQU   *                                                        01356000
         SPACE                                                          01357000
* SET CODES IN FREETAB TO INDICATED VALUE.                              01358000
         SPACE                                                          01359000
* AT ENTRY:                                                             01360000
*        BLR -> PAGE BLOCK WHOSE FREETAB BYTES ARE TO BE CHANGED        01361000
*        SR = SIZE OF PAGE BLOCK (PAGE MULTIPLE)                        01362000
*        CHR -> CHAIN HEADER, WHOSE 'TCODE' FIELD INDICATES VALUE TO    01363000
*               WHICH THE FREETAB BYTES FOR THIS BLOCK ARE TO BE SET.   01364000
         SPACE                                                          01365000
* NOTE: NORMAL RETURN IS ALWAYS MADE                                    01366000
         SPACE 2                                                        01367000
         IC    XR,TCODE(,CHR)          GET NEW CODE VALUE               01368000
         B     SETCODC                 GO TO COMMON CODE                01369000
         SPACE 5                                                        01370000
SETCODEN EQU   *                                                        01371000
         SPACE                                                          01372000
* SAME AS SETCODE, BUT CODE IS SET TO 'UNASSIGNED'.                     01373000
         LA    XR,USARCODE             USE USER AREA CODE               01374000
         B     SETCODC                 BRANCH TO COMMON CODE            01375000
         SPACE 3                                                        01376000
* THE FOLLOWING IS USED BY THE INITIALIZATION ROUTINES -- THE PROPER    01377000
* CODE IS ALREADY IN XR.                                                01378000
SETCODEI EQU   *                                                        01379000
         SPACE 5                                                        01380000
* COMMON BRANCH POINT FOR SETCODE AND SETCODEN.                         01381000
SETCODC  EQU   *                                                        01382000
         SPACE                                                          01383000
* IF THE SECOND INITIALIZATION ROUTINE HAS NOT YET BEEN INVOKED, THEN   01384000
* THERE IS NOTHING TO DO.                                               01385000
         TM    FREEFLG2,FRF2NOI        NO SECOND INITIALIZATION?        01386000
         RTN   O,0                     NORMAL RETURN IF NONE            01387000
         SPACE                                                          01388000
         LR    R14,BLR                 R14 = PAGE BLOCK ADDRESS         01389000
         SRL   R14,12                  DIVIDE BY 4096 TO GET PAGE NUMB  01390000
         AL    R14,AFREETAB            POINT TO FIRST BYTE IN FREETAB  *01391000
                                       TO BE MODIFIED                   01392000
         LR    R15,SR                  SIZE OF PAGE BLOCK IN BYTES      01393000
         SRL   R15,12                  DIVIDE BY 4096 TO NUMBER PAGES   01394000
         SLL   XR,24                   PUT VALUE INTO HIGH ORDER BYTE   01395000
         SPACE                                                          01396000
* NOTE: XR IS AN ODD-NUMBERED REGISTER WHICH CONTAINS A ZERO ADDRESS    01397000
* FIELD AND A PAD CHARACTER (IN THE HIGH ORDER BYTE) EQUAL TO THE       01398000
* CHARACTER TO BE PLACED IN THE TABLE.                                  01399000
* THE CONTENTS OF REGISTER (XR-1) ARE IRRELEVANT.                       01400000
         MVCL  R14,XR-1                FILL IN CHARACTER                01401000
         USING FRDSECT,TR                                               01402000
         RTN   ,0                      NORMAL RETURN                    01403000
SETKEY   EQU   *                                                        01405000
         SPACE                                                          01406000
* SET STORAGE KEYS                                                      01407000
         SPACE                                                          01408000
* AT ENTRY:                                                             01409000
*        BLR -> BLOCK OF STORAGE FOR WHICH STORAGE KEYS ARE TO BE       01410000
*               CHANGED (PAGE-ALIGNED)                                  01411000
*        SR = SIZE OF BLOCK (MULTIPLE OF PAGE SIZE)                     01412000
*        CHR -> CHAIN HEADER, WHOSE 'SKEY' FIELD CONTAINS THE NEW       01413000
*               STORAGE KEY VALUE FOR THESE PAGES                       01414000
         SPACE                                                          01415000
* NOTE: NORMAL RETURN IS ALWAYS MADE                                    01416000
         SPACE 2                                                        01417000
         IC    XR,SKEY(,CHR)           GET STORAGE KEY                  01418000
         B     SETKEYG                 GO TO COMMON CODE                01419000
         SPACE 5                                                        01420000
SETKEYN  EQU   *                                                        01421000
         SPACE                                                          01422000
* SAME AS SETKEY, EXCEPT THAT 'UNASSIGNED' STORAGE KEY IS SET.          01423000
         LA    XR,USERKEY              SET USER KEY                     01424000
         B     SETKEYG                 GO TO COMMON CODE                01425000
         SPACE 3                                                        01426000
SETKEYI  EQU   *                                                        01427000
         SPACE 5                                                        01428000
* COMMON BRANCH POINT FOR SETKEY AND SETKEYN                            01429000
SETKEYG  EQU   *                                                        01430000
         LR    R14,BLR                 POINTER TO PAGE BLOCK            01431000
         LR    R15,SR                  SIZE OF PAGE BLOCK               01432000
         SPACE                                                          01433000
* SSK LOOP                                                              01434000
SETKEYL  EQU   *                                                        01435000
         SSK   XR,R14                  SET STORAGE KEY OF 1ST HALF OF  *01436000
                                       PAGE                             01437000
         LA    R14,2048(,R14)          ADVANCE POINTER TO SECOND HALF   01438000
         SSK   XR,R14                  SET STORAGE KEY OF SECOND HALF   01439000
         LA    R14,2048(,R14)          ADVANCE TO NEXT PAGE             01440000
         S     R15,PAGESIZE            SUBTRACT PAGESIZE FROM TOTAL    *01441000
                                       SIZE                             01442000
         BP    SETKEYL                 LOOP IF THERE IS MORE TO DO      01443000
         BM    *+8                                             @VA00980 01444100
SETKEYR  SR    R15,R15                                         @VA00980 01444200
         BR    RR                                              @VA00980 01444300
         RTN   ,24,FINIS               IMPOSSIBLE CONDITION IF NEGATIVE 01445000
SFRT     EQU   *                                                        01447000
         SPACE                                                          01448000
* FRET SUBROUTINE -- ADD A BLOCK TO A SPECIFIED CHAIN.                  01449000
         SPACE                                                          01450000
* AT ENTRY:                                                             01451000
*        CHR -> CHAIN HEADER FOR CHAIN TO BE MODIFIED                   01452000
*        BLR -> BLOCK TO BE ADDED TO CHAIN                              01453000
*        SR = SIZE OF BLOCK TO BE ADDED TO CHAIN                        01454000
         SPACE                                                          01455000
* AT RETURN:                                                            01456000
*        BLR AND SR ARE SET UP TO INDICATE THE BLOCK ON THE CHAIN       01457000
*        WHICH CONTAINS THE BLOCK WHICH WAS RETURNED.  THAT IS,         01458000
*        IF THE RETURNED BLOCK DID NOT COMBINE WITH ANY OTHER BLOCK,    01459000
*        THEN BLR AND SR INDICATE THE RETURNED BLOCK.  IF THE RETURNED  01460000
*        BLOCK DID COMBINE, THEN BLR AND SR INDICATE THE TOTAL BLOCK    01461000
*        ON THE FREE CHAIN.                                             01462000
*        BLR -> BLOCK ON FREE CHAIN CONTAINING RETURNED BLOCK           01463000
*        SR = SIZE OF THIS BLOCK                                        01464000
         SPACE                                                          01465000
         ST    SR,SIZE(,BLR)           SET SIZE FIELD OF RETURNED BLOCK 01466000
         LR    XR,SR                   XR = SIZE OF RETURNED BLOCK      01467000
         AR    XR,BLR                  XR -> END OF RETURNED BLOCK      01468000
         LR    PTR,CHR                 INITIALIZE CHAIN POINTER         01469000
         LA    R15,SFRTL               FOR SPEED IN LOOP                01470000
         SPACE                                                          01471000
* SEARCH LOOP -- FINDS THE PLACE WHERE THE NEW BLOCK BELONGS.           01472000
         CNOP  0,8                     FOR SPEED                        01473000
SFRTL    EQU   *                                                        01474000
         LR    PPTR,PTR                MOVE POINTERS AHEAD ONE BLOCK    01475000
         L     PTR,POINTER(,PTR)                                        01476000
         CLR   XR,PTR                  END OF NEW BLOCK ABOVE OLD BLK?  01477000
         BCR   4,R15 (BL SFRTL)        YES -- LOOP BACK AND CONTINUE    01478000
         SPACE                                                          01479000
* WE DROP THROUGH THE LOOP WHEN WE HAVE FOUND THE POSITION IN           01480000
* THE CHAIN WHERE THE BLOCK BELONGS.                                    01481000
* WHEN CONTROL COMES TO THIS POINT, THEN REGISTERS ARE AS FOLLOWS:      01482000
         SPACE                                                          01483000
*        BLR -> NEW BLOCK                                               01484000
*        XR -> END OF NEW BLOCK                                         01485000
*        SR = SIZE OF NEW BLOCK (= XR - BLR)                            01486000
         SPACE                                                          01487000
*        PTR AND PPTR -> CHAIN ELEMENTS SUCH THAT ONE OF THE FOLLOWING  01488000
*        IS TRUE:                                                       01489000
         SPACE                                                          01490000
*        CASE 1.                                                        01491000
*              XR = PTR                                                 01492000
*              BLR > POINTER(,PTR) + SIZE OF BLOCK BELOW NEW BLOCK      01493000
*              IN THIS CASE, THE NEW BLOCK COMBINES WITH THE PTR BLOCK  01494000
*              ABOVE IT, BUT LIES ABOVE THE POINTER(,PTR) BLOCK AND     01495000
*              DOES NOT COMBINE WITH IT.                                01496000
         SPACE                                                          01497000
*        CASE 2.                                                        01498000
*              XR = PTR                                                 01499000
*              BLR = POINTER(,PTR) + SIZE OF BLOCK BELOW NEW BLOCK      01500000
*              IN THIS CASE, THE NEW BLOCK COMBINES WITH THE PTR BLOCK  01501000
*              ABOVE IT AND WITH THE POINTER(,PTR) BLOCK BELOW.         01502000
         SPACE                                                          01503000
*        CASE 3.                                                        01504000
*              XR > PTR                                                 01505000
*              BLR = PTR + SIZE(,PTR)                                   01506000
*              IN THIS CASE, THE NEW BLOCK CAN BE COMBINED WITH THE     01507000
*              PTR BLOCK BELOW IT.                                      01508000
         SPACE                                                          01509000
*        CASE 4.                                                        01510000
*              XR > PTR                                                 01511000
*              BLR > PTR + SIZE(,PTR)                                   01512000
*              IN THIS CASE, THE NEW BLOCK LIES STRICTLY BETWEEN THE    01513000
*              PTR BLOCK AND THE PPTR BLOCK, AND DOES NOT COMBINE WITH  01514000
*              ANYTHING.  (THIS CASE ALSO ARISES IF PTR = 0 -- THE NEW  01515000
*              BLOCK GOES ON THE END OF THE CHAIN.)                     01516000
         SPACE                                                          01517000
*        IN ADDITION, THE CONDITION CODE IS STILL SET FROM THE          01518000
*        INSTRUCTION 'CLR XR, PTR'                                      01519000
SFRTLO   EQU   *                                                        01520000
         L     CR,NUM(,CHR)            GET NUMBER OF ELEMENTS ON CHAIN  01521000
         BE    SFRTC123                GO IF CASES 1 OR 2               01522000
         SPACE                                                          01523000
* CASES 3 OR 4; ALSO CASES 1 AND 2 AFTER LOADING NEXT LOWER PTR         01524000
SFRTC34  EQU   *                                                        01525000
         LTR   R14,PTR                 ANY PTR POINTER?                 01526000
         BZ    SFRTC4                  CASE 4 IF NOT                    01527000
         AL    R14,SIZE(,PTR)          R14 -> END OF PTR BLOCK          01528000
         CLR   R14,BLR                 COMBINE BLR AND PTR BLOCKS?      01529000
         RTN   H,6,FINIS               NEW BLOCK OVERLAPS PTR BLOCK     01530000
         BL    SFRTC4    FINISHED IF BLOCKS ARE NON-CONTIGUOUS @VA08663 01531000
         SPACE                                                          01532000
* COME HERE ON CASES 1, 2 OR 3 -- THE BLR BLOCK IS TO BE COMBINED WITH  01533000
* THE PTR BLOCK EITHER FROM ABOVE OR FROM BELOW.                        01534000
SFRTC123 EQU   *                                                        01535000
         AL    SR,SIZE(,PTR)           SIZE OF COMBINED BLOCKS          01536000
         CLR   BLR,PTR                 WHICH BLOCK IS LOWER IN CORE?    01537000
         BL    *+6                     SKIP IF CASES 1 OR 2             01538000
         LR    BLR,PTR                 CASE 3                           01539000
         SPACE                                                          01540000
* AT THIS POINT, BLR POINTS TO COMBINED BLOCK.                          01541000
         ST    SR,SIZE(,BLR)           STORE SIZE OF COMBINED BLOCK.    01542000
         L     PTR,POINTER(,PTR)       POINT TO BLOCK FOLLOWING OLD PTR 01543000
         BCTR  CR,0                    DECREMENT COUNT, BECAUSE OF     *01544000
                                       COMBINING JUST PERFORMED         01545000
         ST    PTR,POINTER(,PPTR)                                       01546000
         SPACE                                                          01547000
* NOW EVERYTHING IS SET UP FOR CASE 1 OR 2 AS IF FOR CASE 3 OR 4, WITH  01548000
* BLR NOW POINTING TO THE COMBINED BLOCK, AND PTR POINTING TO WHAT USED 01549000
* TO BE POINTER(,PTR).  ALSO, CONDITION CODE FROM LAST CLR INSTRUCTION  01550000
* IS STILL SET.                                                         01551000
         BL    SFRTC34             GO HANDLE FINISH-UP         @VA08663 01552000
SFRTC4   EQU   *                                                        01554000
         ST    BLR,POINTER(,PPTR)      PUT NEW BLOCK ONTO CHAIN         01555000
         ST    PTR,POINTER(,BLR)                                        01556000
         LA    CR,1(,CR)               INCREMENT COUNT, SINCE WE HAVE  *01557000
                                       ADDED A BLOCK                    01558000
         SPACE                                                          01559000
* AT THIS POINT, ALL THE BLOCKS ARE PROPERLY CHAINED, AND REGISTERS     01560000
* BLR AND SR ARE PROPERLY SET UP FOR EXIT.  NOW WE NEED ONLY STORE THE  01561000
* NEW CHAIN HEADER VALUES, AND EXIT.                                    01562000
         ST    CR,NUM(,CHR)            STORE NUMBER OF BLOCKS           01563000
         CL    SR,MAX(,CHR)            SHOULD MAX BE UPDATED?           01564000
         BL    *+8                     SKIP IF NOT                      01565000
         ST    SR,MAX(,CHR)            STORE IF SO                      01566000
         RTN   ,0                      NORMAL RETURN (RC=0)             01567000
RTNFINIS EQU   *                                                        01569000
RTNCLOB  EQU   *                                                        01570000
RETURN   EQU   *                                                        01571000
         ST    R15,FREESAVE+R15*4      STORE RETURN CODE IN SAVE AREA   01572000
         LTR   R15,R15                 ANY RETURN CODE?                 01573000
         BNZ   ERRORET                 GO HANDLE IT                     01574000
         SPACE                                                          01575000
RETURN1  EQU   *                                                        01576000
         TM    FREEFLG1,FRF1E          WAS THIS FREE CALL (NOT FRET)    01577000
         BZ    RETURN2                 GO IF IT WAS FRET                01578000
         ST    BLR,FREESAVE+R1*4       STORE ALLOCATED BLOCK LOCATION   01579000
         TM    FREEFLG1,FRF1V+FRF1E    WAS IT VARIABLE REQUEST?         01580000
         BNO   RETURN2                 SKIP IF NOT                      01581000
         SRA   SR,3                    CONVERT SIZE TO DOUBLEWORDS      01582000
         ST    SR,FREESAVE+R0*4        AND STORE IN SAVE AREA           01583000
         SPACE                                                          01584000
RETURN2  EQU   *                                                        01585000
         TM    FREEFLG2,FRF2CL         CLEAN-UP FLAG SET?               01586000
         BO    CLEANUP                 YES -- GO CLEAN UP               01587000
         SPACE                                                          01588000
RETURN3  EQU   *                                                        01589000
         TM    FREEFLG2,FRF2CKT        CHECK FLAG SET?                  01590000
         BO    CHECK                   YES -- GO CHECK                  01591000
         SPACE                                                          01592000
RETURN4  EQU   *                                                        01593000
         SPACE                                                          01594000
RETURNE  EQU   *                                                        01595000
         LM    R0,R15,FREESAVE         RESTORE GENERAL REGISTERS        01596000
         BR    R14                     AND RETURN TO CALLER             01597000
* PUT CONSTANTS AND LITERALS HERE TO KEEP HEAVILY USED PARTS            01599000
* OF ROUTINE IN ONE PAGE.                                               01600000
PAGESIZE DC    A(4096)                 SIZE OF A PAGE IN BYTES          01601000
         SPACE 2                                                        01602000
         LTORG                                                          01603000
         DS    0H                                                       01604000
         SPACE                                                          01605000
* THIS ENDS THE HEAVILY USED PORTION OF DMSFRE.                         01606000
         SPACE                                                          01607000
CLEANUP  EQU   *                                                        01609000
         SPACE                                                          01610000
* THE CLEANUP ROUTINE IS ENTERED WHEN THE FRF2CL FLAG IS SET IN         01611000
* FREEFLG2.                                                             01612000
* CLEANUP WILL TAKE PLACE FOR ALL CHAINS WHOSE HEADERS HAVE FLCLN FLAG  01613000
* ON IN THE 'FLAGS' BYTE.                                               01614000
         SPACE                                                          01615000
* THERE ARE TWO TYPES OF CLEANUP:                                       01616000
*        1. FOR NUCLEUS CHAINS, ANY FULL PAGES MUST BE REMOVED AND      01617000
*           PLACED ON THE CORRESPONDING USER CHAINS.                    01618000
*        2. FOR THE HIGH-CORE USER CHAIN, IT MAY BE POSSIBLE TO         01619000
*           REMOVE STORAGE FROM CHAIN AND MOVE UP 'LOW EXTEND' POINTER. 01620000
         SPACE 2                                                        01621000
         LA    XR,4                    NUMBER OF CHAINS                 01622000
         LA    CHR,FREELN              POINT TO FIRST HEADER BLOCK      01623000
         SH    CHR,=AL2(BLOCKLEN)      AND BACK UP BY LENGTH OF ONE     01624000
         BALR  R14,0 (LA R14,CLEANUPL) SET R14 FOR SPEED IN LOOP        01625000
         SPACE                                                          01626000
CLEANUPL EQU   *                                                        01627000
         LA    CHR,BLOCKLEN(,CHR)      POINT TO NEXT CHAIN HEADER BLK   01628000
         TM    FLAGS(CHR),FLCLN        'CLEANUP' FLAG SET?              01629000
         BO    CL                      GO CLEAN UP IF SO                01630000
         BCTR  XR,R14 (BCT XR,CLEANUPL) COUNT CHAINS                    01631000
         NI    FREEFLG2,X'FF'-FRF2CL   TURN OFF MAJOR CLEANUP FLAG      01632000
         B     RETURN3                 AND RE-ENTER RETURN CODE         01633000
         SPACE 2                                                        01634000
* COME HERE IF A CHAIN HEADER BLOCK WITH THE CLEANUP FLAG ON IS         01635000
* FOUND.                                                                01636000
CL       EQU   *                                                        01637000
         TM    FLAGS(CHR),FLNU         NUCLEUS CHAIN?                   01638000
         BO    CLN                     GO HANDLE IT                     01639000
         SPACE                                                          01640000
CL1      EQU   *                                                        01641000
         TM    FLAGS(CHR),FLHC         HIGH-CORE CHAIN?                 01642000
         BO    CLH                     GO HANDLE IT                     01643000
         SPACE                                                          01644000
CL2      EQU   *                                                        01645000
         NI    FLAGS(CHR),X'FF'-FLCLN  TURN OFF CLEANUP FLAG            01646000
         B     CLEANUP                 AND SEARCH FOR MORE DIRTY CHAINS 01647000
         SPACE                                                          01648000
* COME HERE TO CLEAN UP A NUCLEUS CHAIN.  IT IS NECESSARY TO REMOVE     01649000
* COMPLETE PAGES FROM THE CHAIN.                                        01650000
CLN      EQU   *                                                        01651000
         TM    FREEFLG2,FRF2NOI        2ND INITIALIZATION TAKEN PLACE?  01652000
         BO    CL1                     NO -- NOTHING TO DO              01653000
         L     SR,PAGESIZE             GET PAGE SIZE                    01654000
         BAL   RR,SCHVPGE              FIND ANY PAGES ON CHAIN          01655000
         BNZ   CL1                     FINISHED IF NO FULL PAGES        01656000
         TM    FLAGS(CHR),FLHC         IS THIS A HIGH-CORE CHAIN?       01657000
         BZ    CLN1                    GO IF NOT HIGH CORE              01658000
         CL    BLR,FREELOWE            IS THE BLOCK AT LOW EXTEND?      01659000
         BNE   CLN1                    GO IF NOT                        01660000
         SPACE                                                          01661000
* OTHERWISE, WE CAN INCREASE THE LOW EXTEND POINTER.                    01662000
         BAL   RR,SETCODEN             SET CODE TO UNASSIGNED           01663000
         BAL   RR,SETKEYN              SET KEY TO UNASSIGNED            01664000
         AR    BLR,SR                  FIND END OF BLOCK                01665000
         ST    BLR,FREELOWE            STORE NEW LOW EXTEND PTR         01666000
         SPACE                                                          01667000
* IT IS NOW POSSIBLE THAT THE HIGH-CORE USER CHAIN MAY NEED CLEANING    01668000
* UP, SINCE LOW EXTEND HAS BEEN CHANGED.                                01669000
         CLEANUP ,HU                                                    01670000
         B     CL2                     ALL FINISHED WITH THIS CHAIN     01671000
         SPACE                                                          01672000
* COME HERE IF THERE IS A PAGE BLOCK TO BE MOVED TO THE                 01673000
* CORRESPONDING USER CHAIN.                                             01674000
CLN1     EQU   *                                                        01675000
         LA    CHR,BLOCKLEN(,CHR)      POINT TO CORRESPONDING USER CHN  01676000
         BAL   RR,SETCODE              SET USER CODE IN FREETAB         01677000
         BAL   RR,SETKEY               SET USER STORAGE KEY             01678000
         BAL   RR,SFRT                 PUT PAGE BLOCK ON THAT CHAIN     01679000
         OI    FLAGS(CHR),FLPA         SET PAGE AVAILABLE FLAG          01680000
         SH    CHR,=AL2(BLOCKLEN)      POINT BACK TO NUC CHAIN          01681000
         B     CLN                     AND LOOK FOR MORE PAGES          01682000
         SPACE                                                          01683000
* FOR HIGH-CORE USER CHAIN, WE NEED ONLY SEE IF IT CAN BE               01684000
* DIS-EXTENDED.                                                         01685000
CLH      EQU   *                                                        01686000
         TM    FLAGS(CHR),FLPA         PAGE AVAILABLE ON CHAIN?         01687000
         BZ    CL2                     NOTHING TO DO IF NOT             01688000
         L     CR,NUM(,CHR)            GET NUMBER OF BLOCKS ON CHAIN    01689000
         LTR   CR,CR                   ANY BLOCKS?                      01690000
         BZ    CL2                     GO IF NOT                        01691000
         L     SR,PAGESIZE             SIZE OF A PAGE                   01692000
         CL    SR,MAX(,CHR)            COMPARE WITH MAX SIZE ON CHAIN   01693000
         BH    CL2                     WE'RE ALL THROUGH IF MAX TOO    *01694000
                                       SMALL                            01695000
         LA    R14,CLHL                FOR SPEED IN LOOP                01696000
         LR    PTR,CHR                 INITIALIZE PTR                   01697000
         SPACE                                                          01698000
* THE FOLLOWING LOOP SIMPLY SEARCHES FOR THE LAST BLOCK IN THE          01699000
* CHAIN.                                                                01700000
         CNOP  0,8                     FOR SPEED IN LOOP                01701000
CLHL     EQU   *                                                        01702000
         LR    PPTR,PTR                MOVE POINTERS AHEAD ONE BLOCK    01703000
         L     PTR,POINTER(,PTR)                                        01704000
         BCTR  CR,R14 (BCT CR,CLHL)    COUNT BLOCKS                     01705000
         CLC   =F'0',POINTER(PTR)      CHECK FOR CLOBBERED CHAIN        01706000
         RTN   NE,61,CLOB              CLOBBERED IF NONZERO             01707000
         L     SR,SIZE(,PTR)           GET SIZE OF LAST BLOCK           01708000
         ROUND DOWN,SR                 ROUND DOWN TO PAGE BOUNDARY      01709000
         LTR   SR,SR                   ANYTHING LEFT?                   01710000
         BZ    CL2                     WE'RE THROUGH IF NOT             01711000
         LR    BLR,PTR                 POINT TO BLOCK                   01712000
         CL    BLR,FREELOWE            IS IT A LOW-EXTEND?              01713000
         BNE   CL2                     WE'RE THROUGH IF NOT             01714000
         BAL   RR,ALOCC                ALLOCATE BLOCK                   01715000
         BAL   RR,SETCODEN             SET UNASSIGNED CODE              01716000
         BAL   RR,SETKEYN              SET UNASSIGNED STORAGE KEY       01717000
         ALR   BLR,SR                  POINT TO END OF BLOCK            01718000
         ST    BLR,FREELOWE            THAT'S THE NEW LOW-EXTEND VALUE  01719000
         B     CL2                     AND WE'RE THROUGH                01720000
CHECK    EQU   *                                                        01722000
         SPACE                                                          01723000
* CHECK TO SEE IF ALL CHAINS ARE CONSISTENT.                            01724000
         SPACE                                                          01725000
* THIS ROUTINE DOES NOT MAKE ANY CHANGES TO THE CHAINS (NOT EVEN MAX).  01726000
* IT JUST CHECKS TO SEE IF EVERYTHING'S LEGAL.                          01727000
         SPACE                                                          01728000
* IT WILL BE ENTERED IF THE 'FRF2CKT' FLAG IN FREEFLG2 IS SET.          01729000
         SPACE 2                                                        01730000
* THE FOLLOWING FLAG INDICATES THAT THE CHECK ROUTINE IS BEING          01731000
* EXECUTED.                                                             01732000
         OI    FREEFLG2,FRF2CKX        SET 'IN CHECK' FLAG              01733000
         L     XR,FREELOWE             GET CURRENT LOW EXTEND VALUE     01734000
         C     XR,VMSIZE               GREATER THAN SIZE OF STORAGE?    01735000
         RTN   H,84,CHKP               CLOBBERED IF IT IS               01736000
         C     XR,AUSRAREA             BELOW USER PROGRAM AREA?         01737000
         RTN   L,85,CHKP               CLOBBERED IF IT IS               01738000
         L     SR,VMSIZE               GET SIZE OF STORAGE              01739000
         SRA   SR,12                   SR = SIZE OF FREETAB IN BYTES    01740000
         L     BLR,AFREETAB            BLR -> FREETABL                  01741000
         LA    R14,256                                                  01742000
         SPACE                                                          01743000
* THE FOLLOWING LOOP CHECKS ALL THE BYTES IN FREETAB TO SEE IF THEY     01744000
* ARE WITHIN LEGAL RANGE.  NOTE, FOR THE PURPOSES OF THE TRT USED       01745000
* IN THE LOOP, THAT XR2 = R2, SO THAT NOTHING IMPORTANT IS BEING        01746000
* CLOBBERED IN REGISTER 2.                                              01747000
CHECKF   EQU   *                                                        01748000
         LTR   R15,SR                  ANY BYTES LEFT TO CHECK?         01749000
         BZ    CHECKF1                 ALL THROUGH CHECKING IF NOT      01750000
         CLR   R15,R14                 MORE THAN 256 BYTES LEFT?        01751000
         BL    *+6                     SKIP IF NOT                      01752000
         LR    R15,R14                 USE 256 PER TRT, IF SO           01753000
         SR    SR,R15                  SUBTRACT THIS NUMBER FROM TOTAL  01754000
         BCTR  R15,0                   DECREMENT COUNT FOR EX           01755000
         EX    R15,CHECKFI             DO THE TRT ON FREETAB            01756000
         RTN   NZ,86,CHKP              ERROR IF NOT ALL ZERO            01757000
*                                      FUNCTION VALUES                  01758000
         LA    BLR,256(,BLR)           INCREMENT POINTER INTO FREETAB   01759000
         B     CHECKF                  LOOP BACK FOR NEXT 256 BYTES     01760000
         SPACE                                                          01761000
CHECKFI  TRT   0(0,BLR),CHECKFT        LENGTH FIELD FILLED IN BY EX     01762000
         SPACE                                                          01763000
* THE FOLLOWING TRANSLATE TABLE SHOULD REALLY BE 256 BYTES LONG.        01764000
* HOWEVER, SINCE THE TABLE IS FOLLOWED BY EXECUTABLE CODE, THERE WILL   01765000
* NOT BE VERY MANY NON-ZERO BYTES IN THE STORAGE FOLLOWING IT.  AS A    01766000
* RESULT, IT WILL BE SUFFICIENT FOR OUR PURPOSES.                       01767000
CHECKFT  DC    AL1(1),(5)AL1(0)                                         01768000
         DS    0H                                                       01769000
         EJECT                                                          01770000
* WE NOW BEGIN THE MAIN WORK OF CHECKING ALL CHAINS FOR                 01771000
* CONSISTENCY.                                                          01772000
CHECKF1  EQU   *                                                        01773000
         LA    CHR,FREELN              POINT TO LOW NUCLEUS CHAIN       01774000
         B     CHECKB                  GO ENTER OUTER LOOP AND CHECK IT 01775000
         SPACE                                                          01776000
* COME HERE EACH TIME A NEW CHAIN IS TO BE STARTED.                     01777000
CHECKA   EQU   *                                                        01778000
         LR    XR,CHR                  SAVE OLD CHAIN POINTER           01779000
         LA    CHR,BLOCKLEN(,CHR)      ADVANCE TO NEXT CHAIN POINTER    01780000
         TM    FLAGS(XR),FLHC          HAVE WE EXAMINED HIGH-CORE YET?  01781000
         BZ    CHECKB                  GO HANDLE NEXT CHAIN IF NOT      01782000
         TM    FLAGS(XR),FLNU          WAS IT HIGH-CORE USER CHAIN?     01783000
         BO    CHECKB                  GO HANDLE HIGH USER CHAIN IF NOT 01784000
         SPACE                                                          01785000
* WE HAVE CHECKED ALL FOUR CHAINS                                       01786000
         SPACE                                                          01787000
* THE FOLLOWING TURNS OFF THE 'CHECK IN USE' AND THE 'ENTER CHECK       01788000
* THIS TIME' FLAGS                                                      01789000
         NI    FREEFLG2,X'FF'-FRF2CKT-FRF2CKX TURN OFF FLAGS            01790000
         SPACE                                                          01791000
* IF THERE HAS BEEN AN ERROR, WE GO TO THE ERROR HANDLING CODE.         01792000
* OTHERWISE, WE JUST RETURN.                                            01793000
         CLC   =F'0',FREESAVE+4*R15    HAS THERE BEEN AN ERROR          01794000
         BE    RETURN4                 JUST RETURN IF NOT               01795000
         B     ERCHK                   GO FINISH UP IF THERE HAS        01796000
         SPACE 2                                                        01797000
* COME HERE TO BEGIN PROCESSING A NEW CHAIN                             01798000
* FIRST, CHECK TO SEE IF ANY HIGH BYTES HAVE BEEN CLOBBERED.            01799000
CHECKB   EQU   *                                                        01800000
         CLI   POINTER(CHR),0          HIGH BYTE OF POINTER CLOBBERED?  01801000
         RTN   NE,82,CHK               CLOBBERED IF NONZERO             01802000
         CLI   MAX(CHR),0              HIGH BYTE OF MAX CLOBBERED?      01803000
         RTN   NE,83,CHK               CLOBBERED IF NONZERO             01804000
         L     CR,NUM(,CHR)            NUMBER OF ELEMENTS IN CHAIN      01805000
         LA    CR,1(,CR)               INCREMENT BY 1 FOR LOOP LOGIC    01806000
         LR    PTR,CHR                 INITIALIZE PTR                   01807000
         B     CHECKLE                 ENTER LOOP AT THE END            01808000
         SPACE                                                          01809000
* THIS IS THE RETURN BRANCH POINT IN THE LOOP                           01810000
CHECKL   EQU   *                                                        01811000
         LR    PPTR,PTR                MOVE UP POINTERS ONE BLOCK       01812000
         L     PTR,POINTER(,PTR)                                        01813000
         LTR   PTR,PTR                 DOES POINTER = 0?                01814000
         RTN   Z,70,CHK                CHAIN CLOBBERED IF SO            01815000
         LR    BLR,PTR                 BLR -> CURRENT BLOCK             01816000
         SPACE                                                          01817000
* CHECK FOR DOUBLE WORD ALIGNED BLOCK.                                  01818000
         L     XR,=AL1(255,0,0,7)                                       01819000
         NR    XR,PTR                  ZERO OUT HIGHORDER BITS          01820000
         RTN   NZ,71,CHK               IF NONZERO, THEN NOT ALIGNED     01821000
         SPACE                                                          01822000
* CHECK FOR DOUBLEWORD ALIGNED SIZE                                     01823000
         L     SR,SIZE(,PTR)           GET SIZE OF BLOCK                01824000
         L     XR,=AL1(255,0,0,7)                                       01825000
         NR    XR,SR                   ZERO OUT HIGHORDER BITS          01826000
         RTN   NZ,72,CHK               IF NONZERO, THEN NOT ALIGNED     01827000
         SPACE                                                          01828000
         CLR   PPTR,CHR                IS THIS THE FIRST BLOCK ON THE  *01829000
                                       CHAIN?                           01830000
         BE    CHECKLA                 YES -- SKIP NEXT TEST            01831000
         LA    XR,0(SR,BLR)            XR -> END OF BLOCK               01832000
         CLR   XR,PPTR                 SEE IF BLOCKS ARE IN CORRECT    *01833000
                                       ORDER                            01834000
         RTN   NL,73,CHK               BLOCKS OVERLAP OR NOT CHAINED   *01835000
                                       IN ORDER                         01836000
         SPACE                                                          01837000
CHECKLA  EQU   *                                                        01838000
         SPACE                                                          01839000
* CHECK TO SEE IF BLOCKSIZE IS GREATER THAN MAX FOR THIS CHAIN.         01840000
         CL    SR,MAX(,CHR)            COMPARE WITH MAX                 01841000
         RTN   H,74,CHK                CLOBBERED IF SIZE > MAX          01842000
         SPACE                                                          01843000
* WE CALL FINDCHN TO PERFORM THE CHECK TO SEE IF THE FREETAB TABLE IS   01844000
* CORRECT.  THIS ROUTINE WILL ALSO CHECK TO MAKE SURE THAT THE BLOCK    01845000
* DOES NOT OVERLAP STORAGE ASSIGNED TO ANOTHER CHAIN.                   01846000
         LR    XR2,CHR                 SAVE CHAIN POINTER               01847000
         BAL   RR,FINDCHN              FIND CORRECT CHAIN POINTER       01848000
         RTN   NZ,75,CHK               ERROR RETURN -> CLOBBERED        01849000
         CLR   XR2,CHR                 DID WE END UP WITH SAME CHAIN?   01850000
         RTN   NE,76,CHK               BLOCK ON WRONG CHAIN             01851000
         SPACE                                                          01852000
* IF THE BLOCK CONTAINS A FULL PAGE, WE CHECK TO SEE IF:                01853000
*        1. THE 'PAGE AVAILABLE' (FLPA) FLAG IS ON IN THE FLAGS BYTE.   01854000
*        2. IF FREELOWE CAN BE DIS-EXTENDED.                            01855000
*        3. IF THE CHAIN IS A NUCLEUS CHAIN (IN WHICH CASE, A FULL PAGE 01856000
*           IS ILLEGAL)                                                 01857000
         CL    SR,PAGESIZE             COMPARE BLOCK SIZE WITH PAGESIZE 01858000
         BL    CHECKLB                 NOTHING TO DO IF SMALLER         01859000
         LA    XR,0(SR,BLR)            XR -> END OF BLOCK               01860000
         ROUND UP,BLR                  BLR -> BEGINNING OF EMBEDDED PGE 01861000
         ROUND DOWN,XR                 XR -> END OF EMBEDDED PAGE BLOCK 01862000
         CLR   BLR,XR                  ARE THE TWO EQUAL?               01863000
         BNL   CHECKLB                 THEN THERE IS NO EMBEDDED PAGE   01864000
         TM    FLAGS(CHR),FLPA         PAGE AVAILABLE FLAG ON?          01865000
         RTN   Z,77,CHK                CHAIN CLOBBERED IF NOT           01866000
         CL    BLR,FREELOWE            BLOCK AT LOW-EXTEND?             01867000
         RTN   E,78,CHK                THAT SHOULDN'T HAVE HAPPENED     01868000
         SPACE                                                          01869000
* A FULL PAGE CANNOT APPEAR ON A NUCLEUS CHAIN, UNLESS THE SECOND       01870000
* INITIALIZATION HAS NOT YET TAKEN PLACE.                               01871000
         TM    FLAGS(CHR),FLNU         NUCLEUS CHAIN?                   01872000
         BZ    CHECKLB                 OK IF NOT                        01873000
         TM    FREEFLG2,FRF2NOI        SECOND INIT TAKEN PLACE?         01874000
         RTN   NO,79,CHK               CHAIN CLOBBERED IF IT HAS        01875000
         SPACE                                                          01876000
* WE CHECK THE VALIDITY OF THE FREELOWE POINTER.  IF THIS IS A HIGH     01877000
* CORE CHAIN, THEN THIS BLOCK SHOULD LIE ABOVE FREELOWE, THE LOW        01878000
* EXTEND POINTER.                                                       01879000
CHECKLB  EQU   *                                                        01880000
         LR    BLR,PTR                 RESTORE BLR                      01881000
         CL    BLR,FREELOWE            COMPARE WITH LOW EXTEND          01882000
         BNL   CHECKLC                 IF HIGH OR EQUAL, THEN IT'S OK   01883000
         TM    FLAGS(CHR),FLHC         IS THIS A HIGH-CORE CHAIN?       01884000
         RTN   O,80,CHK                FREELOWE CLOBBERED IF SO         01885000
         SPACE                                                          01886000
CHECKLC  EQU   *                                                        01887000
         SPACE                                                          01888000
* COME HERE AT END OF CHECKING EACH CHAIN.                              01889000
CHECKLE  EQU   *                                                        01890000
         BCT   CR,CHECKL               COUNT BLOCKS ON CHAIN            01891000
         CLC   =F'0',POINTER(PTR)      LAST POINTER = 0?                01892000
         RTN   NE,81,CHK               COUNT IS WRONG IF NOT            01893000
         B     CHECKA                                                   01894000
* THE CKON SERVICE ROUTINE TURNS ON A FLAG, SO THAT FROM THIS POINT     01896000
* ON A 'CHECK' WILL TAKE PLACE WITH EACH CALL TO DMSFRE.                01897000
CKON     EQU   *                                                        01898000
         OI    FREEFLG2,FRF2CKE+FRF2CKT TURN ON FLAGS                   01899000
         RTN   ,0,FINIS                RETURN TO CALLER                 01900000
         SPACE 3                                                        01901000
* THE CKOFF SERVICE ROUTINE TURNS OFF THIS FLAG.                        01902000
CKOFF    EQU   *                                                        01903000
         NI    FREEFLG2,X'FF'-FRF2CKE                                   01904000
         RTN   ,0,FINIS                RETURN TO CALLER                 01905000
         SPACE 3                                                        01906000
* THE CHECK SERVICE ROUTINE CAUSES A 'CHECK' TO BE PERFORMED.  THIS     01907000
* WILL INVOLVE A COMPLETE CHECK OF ALL FREE CHAINS FOR IRREGULARITIES.  01908000
CHECKS   EQU   *                                                        01909000
         OI    FREEFLG2,FRF2CKT        SIGNAL A CHECK                   01910000
         RTN   ,0,FINIS                RETURN TO CALLER                 01911000
* USER FREE STORAGE RECOVERY SERVICE ROUTINE.                           01913000
* THIS ROUTINE IS CALLED BY THE DMSABN ABEND RECOVERY ROUTINE.  IT      01914000
* RELEASES ALL STORAGE ALLOCATED AS 'USER' STORAGE.                     01915000
UREC     EQU   *                                                        01916000
         XC    FREELU(12),FREELU       ZERO OUT LOWCORE POINTERS        01917000
         XC    FREEHU(12),FREEHU       ZERO OUT HIGHCORE POINTERS       01918000
         L     R1,AFREETAB             POINT TO FREE STORAGE BYTE TABLE 01919000
         SR    XR2,XR2                 POINT TO CURRENT PAGE (PAGE 0)   01920000
         L     R0,AUSRAREA             BEGINNING OF HIGH CORE           01921000
         SRA   R0,12                   NUMBER OF PAGES IN LOW CORE      01922000
         LA    CHR,FREELU              POINT TO LOW-CORE USER CHAIN     01923000
         SPACE                                                          01924000
* THE FOLLOWING LOOP SEARCHES THROUGH THE FREETAB TABLE, LOOKING FOR    01925000
* BYTES CORRESPONDING TO USER PAGES.  THESE PAGES ARE PUT BACK ONTO     01926000
* THE USER FREE STORAGE CHAIN.                                          01927000
URECL    EQU   *                                                        01928000
         CLI   0(R1),USERCODE          IS THIS A USER PAGE?             01929000
         BNE   URECLE                  SKIP IT IF NOT                   01930000
         LR    BLR,XR2                 BLR -> CURRENT PAGE              01931000
         L     SR,PAGESIZE             LOAD BLOCKSIZE REG WITH PAGESIZE 01932000
         SPACE                                                          01933000
* WE LOOP THRU FREETAB TO FIND THE FIRST NON-USER BYTE.                 01934000
URECG    EQU   *                                                        01935000
         CLI   1(R1),USERCODE          IS THE NEXT ONE FOR USER?        01936000
         BNE   URECF                   GO IF NOT                        01937000
         LA    R1,1(,R1)               OTHERWISE, INCREMENT REGS        01938000
         A     XR2,PAGESIZE                                             01939000
         A     SR,PAGESIZE                                              01940000
         BCT   R0,URECG                AND GO TRY AGAIN                 01941000
         SPACE                                                          01942000
* AT THIS POINT, WE CALL SFRT TO PUT THE BLOCK ONTO THE FREE CHAIN.     01943000
URECF    EQU   *                                                        01944000
         BAL   RR,SFRT                                                  01945000
         OI    FLAGS(CHR),FLPA         SET 'PAGE AVAILABLE' FLAG        01946000
         SPACE                                                          01947000
URECLE   EQU   *                                                        01948000
         LA    R1,1(,R1)               INCREMENT FREETAB POINTER        01949000
         A     XR2,PAGESIZE            INCREMENT PAGE POINTER           01950000
         BCT   R0,URECL                COUNT PAGES                      01951000
         SPACE                                                          01952000
* WHEN WE REACH THIS POINT FOR THE FIRST TIME, WE WILL HAVE CHECKED     01953000
* ONLY THE LOW-CORE PAGES.  SO WE NOW SET THINGS UP TO CHECK THE        01954000
* HIGH CORE PAGES.                                                      01955000
         C     XR2,AUSRAREA            ARE WE AT BEGINNING OF USER AREA 01956000
         BNE   URECB                   WE'RE ALL THROUGH IF NOT         01957000
         SPACE                                                          01958000
* OTHERWISE, WE COMPUTE THE NUMBER OF PAGES IN HIGH CORE.               01959000
         L     R0,VMSIZE               SIZE OF VIRTUAL MEMORY           01960000
         S     R0,AUSRAREA             SIZE OF HIGH CORE                01961000
         SRA   R0,12                   AND CONVERT TO NUMBER OF PAGES   01962000
         LA    CHR,FREEHU              POINT TO HIGH-CORE USER CHAIN    01963000
         B     URECL                   GO BACK AND RE-ENTER LOOP        01964000
         SPACE                                                          01965000
* COME HERE WHEN WE'RE ALL THROUGH                                      01966000
URECB    EQU   *                                                        01967000
         C     XR2,VMSIZE              XR2 -> END OF CORE?              01968000
         RTN   NE,41,FINIS             IMPOSSIBLE IF NOT                01969000
         CLEANUP ,HU                   CLEAN UP HIGH-CORE USER CHAIN    01970000
         OI    FREEFLG2,FRF2CKT        FORCE A CHECK OF ALL CHAINS      01971000
         RTN   ,0,FINIS                RETURN TO CALLER                 01972000
* CALOC SERVICE ROUTINE.                                                01974000
* THIS ROUTINE IS CALLED BY DMSABN, THE ABEND RECOVERY ROUTINE.         01975000
* THIS ROUTINE COMPUTES THE TOTAL AMOUNT OF FREE STORAGE WHICH IS       01976000
* NOT ON THE FREE CHAIN.  THE FIGURE DOES NOT INCLUDE SPACE OCCUPIED    01977000
* BY THE SYSTEM DISK FILE DIRECTORY (SSTAT), NOR DOES IT INCLUDE        01978000
* THE FREETAB TABLE.                                                    01979000
CALOC    EQU   *                                                        01980000
         SPACE                                                          01981000
* FIRST, WE COMPUTE THE SIZE OF ALL PAGES ALLOCATED TO FREE STORAGE.    01982000
         SPACE                                                          01983000
* LOW CORE RUNS FROM NUCEND TO SSTAT.                                   01984000
* NOTE THAT SSTAT IS LOCATED IN THE HIGHEST PART OF WHAT WAS            01985000
* ORIGINALLY THE LOW-CORE FREE STORAGE REGION (FROM NUCEND TO TRANSAR)  01986000
         L     SR,ASSTAT               POINT TO SSTAT                   01987000
         S     SR,=V(DMSNUCE)          GET SIZE OF LOWCORE REGION       01988000
         SPACE                                                          01989000
* HIGH CORE RUNS FROM FREELOWE TO FREELOW1 (THE LATTER WAS SET BY       01990000
* INIT2 AS THE ORIGINAL VALUE OF FREELOWE)                              01991000
         A     SR,FREELOW1             ADD FREELOW1                     01992000
         S     SR,FREELOWE             NET SIZE OF HIGH CORE REGION     01993000
         SPACE                                                          01994000
* WE NOW LOOP THROUGH ALL FOUR CHAINS, AND SUBTRACT THE SIZE OF EACH    01995000
* BLOCK ON THE FREE CHAIN FROM SR.                                      01996000
         LA    XR,4                    NUMBER OF CHAINS                 01997000
         LA    CHR,FREELN              POINT TO LOW-CORE NUCLEUS CHAIN  01998000
         SH    CHR,=AL2(BLOCKLEN)      BACK UP BY ONE BLOCK LENGTH      01999000
         SPACE                                                          02000000
* COME HERE TO EXAMINE THE NEXT CHAIN                                   02001000
CALOCC   EQU   *                                                        02002000
         LA    CHR,BLOCKLEN(,CHR)      POINT TO NEXT CHAIN HEADER       02003000
         L     CR,NUM(,CHR)            GET NUMBER OF BLOCKS ON CHAIN    02004000
         LTR   CR,CR                   ARE THERE ANY?                   02005000
         BZ    CALOCE                  NOTHING TO DO IF NOT             02006000
         LR    PTR,CHR                 POINT TO CHAIN HEADER            02007000
         SPACE                                                          02008000
* POINT TO EACH BLOCK, AND SUBTRACT ITS SIZE FROM SR.                   02009000
CALOCB   EQU   *                                                        02010000
         L     PTR,POINTER(,PTR)       POINT TO NEXT CHAIN ELEMENT      02011000
         S     SR,SIZE(,PTR)           SUBTRACT ITS SIZE FROM SR        02012000
         BCT   CR,CALOCB               COUNT BLOCKS                     02013000
         SPACE                                                          02014000
* COME HERE AT THE END OF EACH CHAIN                                    02015000
CALOCE   EQU   *                                                        02016000
         BCT   XR,CALOCC               COUNT CHAINS                     02017000
         SPACE                                                          02018000
* WE NOW SUBTRACT FROM SR THE SIZE OF FREETAB.                          02019000
         L     XR,VMSIZE               SIZE OF MEMORY                   02020000
         SRA   XR,12                   NUMBER OF PAGES = SIZE OF       *02021000
                                       FREETAB                          02022000
         SR    SR,XR                   SUBTRACT RESULT FROM SR          02023000
         SRA   SR,3                    CONVERT TO DOUBLE WORDS          02024000
         ST    SR,FREESAVE+R0*4        STORE IN RETURNED REG 0          02025000
         RTN   ,0,FINIS                RETURN TO CALLER                 02026000
* COME HERE UPON ANY ERROR RETURN FROM OTHER THAN THE 'CHECK'           02028000
* ROUTINE.                                                              02029000
ERRORET  EQU   *                                                        02030000
         TM    FREEFLG2,FRF2CKX        ARE WE IN 'CHECK' ROUTINE? P3015 02031000
         BO    RTNCHK                  CLOBBERED CHAIN IF SO      P3015 02032000
         SPACE                                                          02033000
* FIRST, WE COMPUTE THE ADDRESS OF THE CALLER.                          02034000
         L     R14,FREESAVE+4*R14      GET VALUE OF R14 AT ENTRY        02035000
         TM    FREEFLG1,FRF1B          WAS THIS A 'TYPCALL=BALR' CALL?  02036000
         BO    ERRET1                  WE HAVE OUR ANSWER IF SO         02037000
         L     XR,CURRSAVE             GET ADDRESS OF CURRENT SAVE AREA 02038000
         USING SSAVE,XR                                                 02039000
         L     R14,CALLER              GET ADDRESS OF SVC CALLER        02040000
         DROP  XR                                                       02041000
         SPACE                                                          02042000
ERRET1   EQU   *                                                        02043000
         ST    R14,ACALL                SAVE ADDRESS OF ACALL           02044000
         CH    R15,=H'20'              IS ERROR CODE > 20?              02045000
         BNL   ERRX                    GO DIRECTLY TO 'ERRX' IF SO      02046000
         SR    XR,XR                                                    02047000
         IC    XR,ERRTAB(R15)          GET JUMP CODE FOR THIS ERROR     02048000
         B     *+4(XR)                 JUMP BASED ON ERROR CODE         02049000
         B     ERRX                  0 9 < RC < 20 -- CAN'T HAPPEN      02050000
         B     ERRCORE               4 RC = 1 -- NO CORE AVAILABLE      02051000
         B     ERREERR               8 RC = 4 -- DMSFREE ARGUMENT ERROR 02052000
         B     ERRTERR              12 RC = 5, 6 OR 7 -- DMSFRET ARG ER 02053000
         SPACE                                                          02054000
ERRTAB   DC    AL1(0,4,0,0,8,12,12,12),13AL1(0)                         02055000
         DS    0H                                                       02056000
         EJECT                                                          02057000
ERRX     EQU   *                                                        02058000
         LR    XR,R15                  XR <- IMPOSSIBLE ERROR CODE      02059000
         DMSERR NUM=167,LET=T,TYPCALL=BALR,DISP=SIO,                   *02060000
               TEXT='FREE STORAGE MANAGEMENT ERROR, INTERNAL ERROR CODE*02061000
                .....',                                                *02062000
               SUB=(DEC,(XR))                                           02063000
         B     CHECK                                                    02064000
         SPACE 2                                                        02065000
ERRCORE  EQU   *                                                        02066000
         TM    FREEFLG1,FRF1M          MESSAGES SUPPRESSED              02067000
         BZ    CHKCLN             SKIP MSG, CHECK CLEANUP      @VA02373 02068300
         DMSERR NUM=159,LET=T,TYPCALL=BALR,DISP=SIO,                   *02069000
               SUB=(HEXA,ACALL),                                       *02070000
               TEXT='INSUFFICIENT STORAGE AVAILABLE TO SATISFY DMSFREE *02071000
               REQUEST FROM ......'                                     02072000
CHKCLN   TM    FREEFLG2,FRF2CL    CLEANUP REQUIRED?            @VA02373 02073200
         BZ    CHECK              SEE IF ANYTHING IS MESSED UP @VA02373 02073400
         OI    FREEFLG2,FRF2CKT   CHECK AFTERWARD              @VA02373 02073600
         B     CLEANUP            PUT PAGES ON RIGHT QUEUES    @VA02373 02073800
         SPACE 2                                                        02074000
ERREERR  EQU   *                                                        02075000
         TM    FREEFLG1,FRF1M          MESSAGES SUPPRESSED?             02076000
         BZ    CHECK                   DON'T TYPE MESSAGE IF SO         02077000
         DMSERR NUM=160,LET=T,TYPCALL=BALR,DISP=SIO,                   *02078000
               SUB=(HEXA,ACALL),                                       *02079000
               TEXT='INVALID DMSFREE CALL FROM ......'         @V305066 02080000
         B     CHECK                                                    02081000
         SPACE 2                                                        02082000
ERRTERR  EQU   *                                                        02083000
         TM    FREEFLG1,FRF1M          MESSAGES SUPPRESSED?             02084000
         BZ    CHECK                   DON'T TYPE MESSAGE IF SO         02085000
         LR    XR,R15                  GET ACTUAL RETURN CODE           02086000
         DMSERR NUM=161,LET=T,TYPCALL=BALR,MF=(E,'SYS'),DISP=SIO,      *02087000
               SUB=(HEXA,ACALL,DEC,(XR)),                              *02088000
               TEXT='INVALID DMSFRET CALL FROM ......, ERROR NUMBER ...*02089000
               ..'                                             @V305066 02090000
         B     CHECK                                                    02091000
         EJECT                                                          02092000
* CONTROL COMES HERE WHEN A CRITICAL POINTER IS FOUND BY THE 'CHECK'    02093000
* ROUTINE TO BE MEANINGLESS OR DESTROYED.                               02094000
RTNCHKP  EQU   *                                                        02095000
         LR    XR,R15                  GET INTERNAL RETURN CODE         02096000
         DMSERR NUM=162,LET=T,TYPCALL=BALR,DISP=SIO,HALT=YES,          *02097000
               TEXT='VITAL FREE STORAGE POINTERS DESTROYED (INTERNAL ER*02098000
               ROR CODE ....), RE-IPL CMS',                            *02099000
               SUB=(DEC,(XR))                                           02100000
         SPACE                                                          02101000
* WE CONTINUE OPERATION IN CASE HE TURNS OFF THE WAIT STATE BIT AFTER   02102000
* REPAIRING THE POINTERS.                                               02103000
         B     CHECK                                                    02104000
         EJECT                                                          02105000
* CONTROL COMES HERE WHEN THE 'CHECK' ROUTINE FINDS THAT ONE OF THE     02106000
* CHAINS IS CLOBBERED.                                                  02107000
RTNCHK   EQU   *                                                        02108000
         LR    XR,R15                  GET INTERNAL ERROR CODE          02109000
         LA    R0,=CL4'LOW'            POINT TO WORD 'LOW'              02110000
         TM    FLAGS(CHR),FLHC         IS THIS THE HIGHCORE CHAIN?      02111000
         BZ    *+8                     SKIP IF NOT                      02112000
         LA    R0,=CL4'HIGH'           IF SO, THEN POINT TO WORD 'HIGH' 02113000
         TM    FLAGS(CHR),FLNU         IS THIS A NUCLEUS CHAIN?         02114000
         BO    RTNCHKN                 GO IF IT IS                      02115000
         SPACE 2                                                        02116000
* MESSAGE: DMSFRE163T LOW/HIGH CORE USER CHAIN HAS BEEN DESTROYED.      02117000
         DMSERR NUM=163,LET=T,MF=(E,'SYS'),TYPCALL=BALR,DISP=SIO,      *02118000
               TEXTA=RTNCHKT1,                                         *02119000
               SUB=(CHARA,(R0),CHARA,=CL7'USER',DEC,(XR),CHARA,   P3071*02120000
               =CL10' ')                                                02121000
         SPACE                                                          02122000
* HEADER INFORMATION MESSAGE                                            02123000
         DMSERR NUM=165,LET=T,MF=(E,'SYS'),TYPCALL=BALR,DISP=SIO,      *02124000
               TEXTA=RTNCHKT2,SUB=(HEX,(CHR),HEX4A,(CHR))               02125000
         XC    0(12,CHR),0(CHR)        ZERO OUT HEADER BLOCK            02126000
         RTN   ,2,CHKC                 USER STORAGE POINTERS CLOBBERED  02127000
         SPACE 5                                                        02128000
* NUCLEUS STORAGE POINTERS HAVE BEEN CLOBBERED.                         02129000
RTNCHKN  EQU   *                                                        02130000
         DMSERR NUM=164,LET=T,MF=(E,'SYS'),TYPCALL=BALR,DISP=SIO,      *02131000
               TEXTA=RTNCHKT1,                                         *02132000
               SUB=(CHARA,(R0),CHARA,=CL7'NUCLEUS',DEC,(XR),      P3071*02133000
               CHARA,=C'RE-IPL CMS')                                    02134000
         DMSERR NUM=165,LET=T,MF=(E,'SYS'),TYPCALL=BALR,               *02135000
               DISP=SIO,TEXTA=RTNCHKT2,                                *02136000
               SUB=(HEX,(CHR),HEX4A,(CHR))                              02137000
         XC    0(12,CHR),0(CHR)        ZERO OUT HEADER POINTER          02138000
         LPSW  =A(X'20000',RTNCHKN1)   LOAD DISABLED WAIT STATE TO DIE  02139000
         SPACE 3                                                        02140000
* WE CONTINUE OPERATION, IN CASE HE TURNS OFF THE WAIT STATE BIT.       02141000
RTNCHKN1 EQU   *                                                        02142000
         RTN   ,3,CHKC                 NUCLEUS STORAGE POINTERS CLOBBED 02143000
         SPACE 2                                                        02144000
* TEXT FOR THE TWO ERROR MESSAGES.                                      02145000
RTNCHKT1 DC    AL1(RTNCHKL1)                                            02146000
         DC    C'....-CORE ....... STORAGE POINTERS DESTROYED (INTERNAL*02147000
                ERROR CODE ....) ..........'                            02148000
RTNCHKL1 EQU   *-RTNCHKT1-1                                             02149000
         SPACE                                                          02150000
RTNCHKT2 DC    AL1(RTNCHKL2)                                            02151000
         DC    C'CHAIN HEADER AT ......: ..............................*02152000
               .....'                                                   02153000
RTNCHKL2 EQU   *-RTNCHKT2-1                                             02154000
         DS    0H                                                       02155000
         SPACE 5                                                        02156000
* COME HERE AFTER THE MESSAGE IS TYPED OUT.  WE ZERO OUT THE CHAIN      02157000
* HEADER BLOCK FOR THE CLOBBERED CHAIN.                                 02158000
RTNCHKC  EQU   *                                                        02159000
         ST    R15,FREESAVE+4*R15      SAVE 2/3 RETURN CODE             02160000
         B     CHECK                   GO TO CHECK AGAIN                02161000
         EJECT                                                          02162000
* COME HERE AFTER THE CHECK ROUTINE HAS COMPLETED, IF ANY ERROR HAS     02163000
* BEEN DETECTED SINCE DMSFRE WAS ENTERED.                               02164000
ERCHK    EQU   *                                                        02165000
         CLC   =F'20',FREESAVE+4*R15   ERROR CODE STILL > 20?           02166000
         BNL   ERCHK1                  GO IF NOT                        02167000
         SPACE                                                          02168000
* THAT MEANS THAT WE GOT AN UNEXPECTED ERROR, BUT ALL THE CHAINS        02169000
* ARE OK.  WE TYPE OUT A SPECIAL ERROR MESSAGE FOR THIS.                02170000
         DMSERR NUM=166,LET=T,DISP=SIO,TYPCALL=BALR,HALT=YES,          *02171000
               SUB=(DECA,FREESAVE+4*R15),                              *02172000
               TEXT='UNEXPECTED ERROR IN FREE STORAGE MANAGEMENT ROUTIN*02173000
               E (INTERNAL ERROR CODE ....). RE-IPL CMS'                02174000
         SPACE                                                          02175000
* CONTINUE PROCESSING IN CASE THE USER TURNS OFF THE WAIT STATE BIT.    02176000
         MVC   FREESAVE+4*R15(4),=A(CODE9) SET RETURN CODE TO 9         02177000
         SPACE 2                                                        02178000
ERCHK1   EQU   *                                                        02179000
         TM    FREEFLG1,FRF1C          WAS THIS A CONDITIONAL CALL?     02180000
         BO    RETURNE                 JUST RETURN TO CALLER IF SO      02181000
         TM    FREEFLG1,FRF1B          WAS 'TYPCALL=BALR' CODED?        02182000
         BO    ERCHK1B                 GO HANDLE THAT IF SO             02183000
         SPACE                                                          02184000
* FOR TYPCALL=SVC CALLS, WE SIMPLY SET THE ABEND CODE IN SVCSECT SO     02185000
* THAT DMSITS WILL ABEND BEFORE RETURNING TO THE CALLER.                02186000
         L     XR,ASVCSECT             POINT TO SVCSECT                 02187000
         USING SVCSECT,XR                                               02188000
         MVC   SVCAB,=X'00F7'          SET ABEND CODE TO 0F7            02189000
         B     RETURN                  AND JUST RETURN                  02190000
         SPACE                                                          02191000
* FOR TYPCALL=BALR CALLS TO DMSFRE, WE ABEND BY PASSING CONTROL TO      02192000
* DMSABNGO.                                                             02193000
ERCHK1B  EQU   *                                                        02194000
         L     XR,=V(DMSABW)           POINT TO DMSABN WORKSPACE        02195000
         USING ABWSECT,XR                                               02196000
         MVC   ABNPSW(4),=A(X'0F8')    SET ABEND CODE TO 0F8            02197000
         MVC   ABNPSW+4(4),FREESAVE+4*R14 PUT RETURN ADDR INTO PSW      02198000
         MVC   ABNREGS(4*16),FREESAVE  COPY ABEND REGISTERS             02199000
         LA    R0,X'0F8'               PUT ABEND CODE INTO REG 0        02200000
         L     R15,=V(DMSABNGO)        POINT TO ABEND ROUTINE           02201000
         BALR  R14,R15                 AND BRANCH TO IT                 02202000
         DC    4H'0'                   DMSABNGO SHOULDN'T RETURN        02203000
         LTORG                                                          02205000
         DMSFRT                                                         02207000
         NUCON                                                          02209000
         DMSABW                                                         02210000
         SVCSAVE                                                        02211000
         SVCSECT                                                        02212000
         END                                                            02213000