*DECK     DB$FKLA 
USETEXT CDCSCTX 
      PROC DB$FKLA; 
      BEGIN 
 #
* *   DB$FKLA -- ALLOCATE A BLOCK IN FKL         PAGE  1
* *   R L MCALLESTER                             DATE  07/22/86 
* 
* DC  PURPOSE 
* 
*     ALLOCATE AN FPT OR A KEY AREA IN THE FILE KEY LIST. 
* 
* DC  ENTRY CONDITIONS
* 
*     P<RSARBLK> IS SET.
*     RSARRQ1 IS TRUE IF AN FPT IS TO BE ALLOCATED. 
*     RSARRQ2 IS TRUE IF PRIMARY KEY SPACE IS TO BE ALLOCATED.
*     RSARRQ3 IS TRUE IF ALTERNATE KEY SPACE IS TO BE ALLOCATED.
* 
* DC  EXIT CONDITION
* 
*     A NEW BLOCK IS ALLOCATED IN THE FKL.
*     THE CORRESPONDING POINTERS ARE SET IN THE AREA CONTROL BLOCK. 
*     THE REQUEST FLAGS RSARRQ1, RSARRQ2 AND RSARRQ3 ARE FALSE. 
* 
* DC  CALLING ROUTINES
* 
*     DB$OPN$                OPEN AREA
* 
* DC  CALLED ROUTINES 
# 
      XREF PROC DB$FLOP;           # GENERATE FLOW POINT               #
      XREF PROC DB$MFA;            # ALLOCATE A FIXED MEMORY BLOCK     #
      XREF PROC DB$MFF;            # FREE A FIXED MEMORY BLOCK         #
      XREF PROC DB$PUNT;           # CDCS INTERNAL ERROR               #
      XREF FUNC DB$SWI I;          # SWAP IN TABLE                     #
      XREF FUNC DB$SWO I;          # SWAP OUT TABLE                    #
# 
* DC  DESCRIPTION 
* 
*     THE STRUCTURE - 
* 
*     MEMORY ALLOCATION WITHIN THE FILE KEY LIST (FKL) IS MAINTAINED
*     BY DB$FKLA AND DB$FKLR. 
*     POINTERS TO THE ALLOCATED BLOCKS ARE KEPT IN THE AREA CONTROL 
*     BLOCKS IN THE RSB.
* 
*     THE FIRST WORD OF THE FKL CONTAINS THE LIST DEFINITION. 
*     FKLEMPTY IS A POINTER TO THE FIRST EMPTY BLOCK. 
*     FKLLENGTH CONTAINS THE LENGTH OF THE FKL. 
* 
*     THE EMPTY BLOCKS ARE CONNECTED BY THE EMPTY BLOCK CHAIN WHICH IS
*     CONTAINED IN THE FIRST WORD OF EACH EMPTY BLOCK.
*     FKLEMPTY IS A POINTER TO THE NEXT EMPTY BLOCK.
*     FKLLENGTH CONTAINS THE LENGTH OF THE EMPTY BLOCK. 
* 
* 
*     THE PROCESS - 
* 
*     EACH OF THE THREE FLAGS IS EXAMINED TO SEE IF MEMORY ALLOCATION 
*     IS REQUESTED.  IF IT IS, THE "ALLOCATE" PROCEDURE IS CALLED.
*     THE REQUEST FLAGS ARE CLEARED.
* 
*     "ALLOCATE" SCANS THE EMPTY CHAIN LOOKING FOR A BLOCK THAT IS
*     ADEQUATE FOR THE REQUESTED BLOCK. 
*     IF NONE IS FOUND, "EXPAND" IS CALLED TO ENLARGE THE FKL.
*     THE EMPTY CHAIN IS MODIFIED TO EXCLUDE THE ALLOCATED BLOCK. 
*     THE OFFSET TO THE ALLOCATED BLOCK IS RETURNED IN "BLOCKOFFS". 
* 
*     "EXPAND" ENLARGES THE FKL BY SWAPPING IT OUT, LOCATING ITS ENTRY
*     IN THE SWAP TABLE, INCREASING THE REQUIRED WORD LENGTH AND THEN 
*     SWAPPING IT IN AGAIN. 
 #
# 
*     NON-LOCAL VARIABLES 
# 
      XREF ITEM RJRSW B;           # RESTRICT JOURNAL RECORDS - SWITCH #
      XREF ITEM SWPTC;             # COUNT OF ENTRIES IN SWAP TABLE    #
  
      XREF ARRAY SWPSEGT;          # SWAP SEGMENT TABLE                #
        BEGIN 
*CALL SWPTDCLS
        END 
# 
*     LOCAL VARIABLES 
# 
      ITEM BLKSIZE;          # BLOCK SIZE                              #
      ITEM BLNSIZE;          # BLOCK SIZE (NEW)                        #
      ITEM BLOCKOFFS;        # OFFSET TO BLOCK IN THE FILEKEY LIST     #
      ITEM BLOCKSIZE;        # SIZE OF BLOCK TO BE ALLOCATED           #
      ITEM PRIORBLOCK;       # BLOCK POINTING TO THE CURRENT ONE       #
      ITEM PRU;              # PRU LOCATION OF SWAPPED TABLE           #
      ITEM RSAROFFSET;       # AREA CONTROL BLOCK OFFSET IN RSB        #
      ITEM XA;               # SCRATCH VARIABLE                        #
      ITEM XB;               # SCRATCH VARIABLE                        #
      ITEM XC;               # SCRATCH VARIABLE                        #
  
      BASED ARRAY OLDBLK; 
        BEGIN 
        ITEM OLDWORD  (00,00,60); 
        END 
      BASED ARRAY NEWBLK; 
        BEGIN 
        ITEM NEWWORD  (00,00,60); 
        END 
  
  
  
  
#     B E G I N   D B $ F K L A   E X E C U T A B L E   C O D E .      #
  
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("FKLA   "); 
      CONTROL ENDIF;
  
      P<FKL> = RSFFKLLOC[0];
  
      IF RSARRQ1
      THEN
        BEGIN                      # ALLOCATE AN FPT                   #
        IF RJRSW THEN 
          BEGIN 
          BLOCKSIZE = DFFPTSZ1; 
          END 
        ELSE
          BEGIN 
          BLOCKSIZE = DFFPTSZ2; 
          END 
        ALLOCATE; 
        RSARFPT[0] = BLOCKOFFS; 
        P<FPT> = LOC(FKL) + RSARFPT[0]; 
        END 
  
      IF RSARRQ2
      THEN
        BEGIN                      # ALLOCATE A PRIMARY KEY AREA       #
        BLOCKSIZE = RSARPKL[0]; 
        ALLOCATE; 
        RSARPKO[0] = BLOCKOFFS; 
        END 
  
      IF RSARRQ3
      THEN
        BEGIN                      # ALLOCATE AN ALTERNATE KEY AREA    #
        BLOCKSIZE = RSARAKL[0]; 
        ALLOCATE; 
        RSARAKO[0] = BLOCKOFFS; 
        END 
      RSARREQ[0] = 0;              # CLEAR THE REQUEST FLAGS           #
      RETURN; 
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   A L L O C A T E        #
#                                                                      #
#**********************************************************************#
  
  
      PROC ALLOCATE;         # ALLOCATE A BLOCK IN THE FKL             #
        BEGIN 
                             # THE SIZE OF THE REQUESTED BLOCK IS IN   #
                             # THE VARIABLE "BLOCKSIZE".               #
        PRIORBLOCK = 0; 
        BLOCKOFFS = FKLEMPTY[0];
  
                             # IF THERE IS NO EMPTY BLOCK, CREATE ONE. #
  
        IF FKLEMPTY[0] EQ FKLLENGTH[0]
        THEN
          BEGIN 
          EXPAND; 
          END 
  
                             # SEARCH FOR AN ADEQUATE EMPTY BLOCK.     #
  
        FOR XA = XA  WHILE FKLLENGTH[BLOCKOFFS] LS BLOCKSIZE
        DO
          BEGIN 
          IF FKLEMPTY[BLOCKOFFS] EQ FKLLENGTH[0]
          THEN
                             # THIS IS THE LAST EMPTY BLOCK.           #
            BEGIN 
            IF BLOCKOFFS + FKLLENGTH[BLOCKOFFS] LS FKLLENGTH[0] 
            THEN
                             # THE LAST WORD OF THE FKL IS NOT EMPTY.  #
              BEGIN 
              PRIORBLOCK = BLOCKOFFS; 
              BLOCKOFFS = FKLLENGTH[0]; 
              END 
  
            EXPAND;          # ENLARGE THE FKL FOR THE REQUESTED BLOCK.#
            END 
          ELSE
            BEGIN 
            IF BLOCKOFFS + FKLLENGTH[BLOCKOFFS] GR FKLLENGTH[0] 
                OR FKLEMPTY[BLOCKOFFS] LQ 0 
            THEN
              BEGIN 
              DB$PUNT("DB$FKLA 1");    # A PROGRAM ERROR               #
              END 
            PRIORBLOCK = BLOCKOFFS;    # ADVANCE TO THE NEXT EMPTY BLK #
            BLOCKOFFS = FKLEMPTY[BLOCKOFFS];
            END 
          END 
        IF FKLLENGTH[BLOCKOFFS] EQ BLOCKSIZE
        THEN
          BEGIN 
                                   # THE EMPTY BLOCK IS AN EXACT FIT.  #
                                   # REMOVE IT FROM THE EMPTY CHAIN.   #
          XA = FKLEMPTY[BLOCKOFFS]; 
          END 
        ELSE
          BEGIN 
                                   # ASSIGN THE BLOCK IN THE FIRST     #
                                   # PART OF THE EMPTY BLOCK AND       #
                                   # REDEFINE THE REDUCED EMPTY BLOCK. #
          XA = BLOCKOFFS + BLOCKSIZE; 
          FKLWORD[XA] = 0;
          FKLLENGTH[XA] = FKLLENGTH[BLOCKOFFS] - BLOCKSIZE; 
          FKLEMPTY[XA] = FKLEMPTY[BLOCKOFFS]; 
          END 
        FKLEMPTY[PRIORBLOCK] = XA;
                                   # CLEAR THE ASSIGNED BLOCK          #
        XB = BLOCKOFFS + BLOCKSIZE - 1; 
        FOR XA = BLOCKOFFS STEP 1 UNTIL XB
        DO
          BEGIN 
          FKLWORD[XA] = 0;
          END 
        END 
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   E X P A N D            #
#                                                                      #
#**********************************************************************#
  
  
      PROC EXPAND;
        BEGIN 
        IF LOC(FKL) NQ LOC(RSB) + RSFRLEN[0]
        THEN
          BEGIN 
                             # THE FKL IS NOT ATTACHED TO THE RSB.     #
                             # SWAP OUT JUST THE FKL, INCREASE ITS     #
                             # MEMORY REQUIREMENT AND SWAP IT BACK IN. #
          P<OLDBLK> = LOC(FKL); 
          BLKSIZE = FKLLENGTH[0]; 
          PRU = -DB$SWO(P<OLDBLK>,BLKSIZE); 
  
          SWAPIN;            # THE NEW MEMORY ADDRESS OF THE FKL       #
                             # IS RETURNED IN XB                       #
          RSFFKLLOC[0] = XB;
          END 
        ELSE
          BEGIN 
                             # THE FKL IS ATTACHED TO THE RSB.         #
                             # SWAP OUT THE RSB/FKL, INCREASE ITS      #
                             # MEMORY REQUIREMENT AND SWAP IT BACK IN. #
          RSAROFFSET = LOC(RSARBLK) - LOC(RSB); 
          P<OLDBLK> = LOC(RSB); 
          BLKSIZE = RSFRLEN[0] + FKLLENGTH[0];
          PRU = -DB$SWO(P<OLDBLK>,BLKSIZE); 
  
          SWAPIN;            # THE NEW MEMORY ADDRESS OF THE RSB       #
                             # IS RETURNED IN XB                       #
          P<RSB> = XB;
          TQRSB[0] = XB;
          P<RSARBLK> = XB + RSAROFFSET; 
          RSFFKLLOC[0] = XB + RSFRLEN[0]; 
          END 
        P<FKL> = RSFFKLLOC[0];
        P<FPT> = LOC(FKL) + RSARFPT[0]; 
  
                             # IF THE LAST WORD OF THE FKL IS NOT EMPTY#
                             # CREATE A NEW EMPTY BLOCK POINTER.       #
        IF BLOCKOFFS EQ FKLLENGTH[0]
        THEN
          BEGIN 
          FKLWORD[BLOCKOFFS] = 0; 
          FKLEMPTY[BLOCKOFFS] = BLOCKOFFS;
          END 
  
        FKLLENGTH[0] = FKLLENGTH[0] + DFFKLINL; 
        FKLLENGTH[BLOCKOFFS] = FKLLENGTH[BLOCKOFFS] + DFFKLINL; 
        FKLEMPTY [BLOCKOFFS] = FKLEMPTY [BLOCKOFFS] + DFFKLINL; 
        END 
  
  
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   S W A P I N            #
#                                                                      #
#**********************************************************************#
  
  
      PROC SWAPIN;
        BEGIN 
        IF PRU LS 0 
        THEN                       # THE FKL WAS NOT SWAPPED OUT       #
          BEGIN 
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("FKLA-NS"); 
          CONTROL ENDIF;
          BLNSIZE = BLKSIZE + DFFKLINL; 
          DB$MFA(BLNSIZE, P<NEWBLK>); 
          FOR XC = BLNSIZE -1 STEP -1 UNTIL BLKSIZE 
          DO
            BEGIN 
            NEWWORD[XC] = 0;
            END 
          FOR XC = BLKSIZE -1 STEP -1 UNTIL 0 
          DO
            BEGIN 
            NEWWORD[XC] = OLDWORD[XC];
            END 
          DB$MFF(P<OLDBLK>);
          XB = LOC(NEWBLK); 
          RETURN; 
  
          END 
        XC = 0; 
        FOR XB = 1 STEP 1 UNTIL SWPTC 
        DO
          BEGIN 
          IF PRU EQ SWPN[XB]
          THEN                     # THE ENTRY IS FOUND                #
            BEGIN 
            XC = XB;
            END 
          END 
        IF XC EQ 0
        THEN
          BEGIN 
          DB$PUNT("DB$FKLA 2");    # THE ENTRY WAS NOT FOUND.  ABORT.  #
          END 
        SWL[XC] = SWL[XC] + DFFKLINL; 
        XB = DB$SWI(PRU); 
        END 
  
      END 
      TERM
