*DECK DB$JLCT 
USETEXT CDCSCTX 
      PROC DB$JLCT ((REC1),(LENGTH1),(REC2),(LENGTH2),(WTR)); 
      BEGIN 
 #
* *   DB$JLCT  - JOURNAL LOGGING CONTROLLER      PAGE  1
* *   R L MCALLESTER                             DATE  09/22/80 
* 
* DC  PURPOSE 
* 
*     TO CONTROL THE WRITING OF RECORDS TO THE JOURNAL LOG FILE SO THAT 
*     IT IS DONE IN AN EFFICIENT AND ORDERLY FASHION. 
*     THE INTENTION IS TO MINIMIZE THE DISK ACCESSES AND TO PROVIDE 
*     MAXIMUM PROCESS OVERLAP.
* 
* DC  ENTRY CONDITIONS
* 
* D   PARAMETERS
# 
      ITEM REC1 I;           # LOCATION OF THE FIRST PART OF LOG RECORD#
      ITEM LENGTH1 I;        # LENGTH OF THE FIRST PART                #
  
#     THE SECOND PART PARAMETERS ARE PROVIDED FOR PASSING A DISJOINT   #
#     RECORD FROM AN INPUT BUFFER.                                     #
  
      ITEM REC2 I;           # LOCATION OF THE SECOND PART             #
      ITEM LENGTH2 I;        # LENGTH OF SECOND PART (MAY BE ZERO)     #
  
      ITEM WTR B;            # TRUE TO FORCE WRITE THE RECORD          #
# 
* D   ASSUMPTIONS 
* 
*     P<RCB>                 POINTER TO CURRENT RUN-UNIT CONTROL BLOCK
*     SALX                   SUBSCRIPT TO SCHEMA ACCESS LIST
* 
*     SPACE ON THE JOURNAL LOG FILE HAS BEEN RESERVED THROUGH A PRIOR 
*     CALL TO DB$JLRS.
* 
* DC  EXIT CONDITIONS 
* 
*     IF WTR IS FALSE, RETURN WHEN THE RECORD IS IN THE OUTPUT BUFFER.
*     IF WTR IS TRUE, DO NOT RETURN UNTIL THE RECORD IS ON THE DISK.
* 
*     WHEN WTR IS TRUE, ALL RESERVATIONS FOR THIS RCB ARE CANCELLED.
* 
* DC  CALLING ROUTINES
* 
*     DB$JLO                 JOURNAL LOG OUTPUT ROUTINE 
*     DB$TRJL                COPY THE TRANSACTION TO THE JOURNAL LOG
* 
* DC  CALLED ROUTINES 
# 
      XREF PROC DB$FLOP;     # ENTER A FLOW POINT                      #
      XREF PROC DB$GOTO;     # GO TO AN ERROR PROCESSOR ROUTINE.       #
      XREF PROC DB$IOER;     # I-O ERROR ON A LOG FILE                 #
      XREF PROC DB$POP;      # RETURN A WORD FROM THE PUSH DOWN STACK  #
      XREF PROC DB$POP2;     # RETURN TWO WORDS FROM PUSH DOWN STACK   #
      XREF PROC DB$POP3;     # RETURN THREE WORDS FROM PUSH DOWN STACK #
      XREF PROC DB$PSH2;     # SAVE TWO WORDS IN THE PUSH DOWN STACK   #
      XREF PROC DB$PSH3;     # SAVE THREE WORDS IN THE PUSH DOWN STACK #
      XREF PROC DB$PUNT;     # INTERNAL ERROR ROUTINE                  #
      XREF PROC DB$PUSH;     # SAVE A WORD IN THE PUSH DOWN STACK      #
      XREF PROC DB$RWTR;     # REWRITE RECORD TO FORCE OUTPUT          #
      XREF PROC DB$RWTW;     # REWRITE WORDS FROM WORKING STORAGE      #
      XREF PROC DB$SCHD;     # CDCS TASK SCHEDULER                     #
# 
* DC  EMBEDDED PROCEDURES 
# 
      XDEF PROC DB$JLCR;     # CANCEL RESERVATION ON JOURNAL LOG SPACE #
# 
* DC  NON-LOCAL VARIABLES MODIFIED
# 
*CALL JFQUEDCLS 
  
      BASED ARRAY FET;
*CALL FETDCLS 
# 
* DC  DESCRIPTION 
* 
*     THIS IS THE MAIN CONTROLLING ROUTINE FOR ACCESS TO THE
*     JOURNAL LOG FILE. 
*     IT MANIPULATES A CONTROL QUEUE NAMED JLQUEUE. 
* 
*     THE QUEUE CONTAINS SIX TYPES OF ENTRIES THAT ARE DESCRIBED IN THE 
*     SECTION ON 'ENTRY TYPES'. 
* 
*     THE SECTION ON 'JOURNAL LOG OUTPUT STATES' DESCRIBES SEVERAL
*     SPECIAL STATES THAT MAY EXIST DURING PROCESSING.
* 
* 
* D   ENTRY TYPES 
* 
* 
*     -- *EMPTY* --          AN EMPTY ENTRY 
* 
*     ALL ENTRIES BEYOND THE LAST ACTIVE ENTRY ARE *EMPTY*. 
*     NO *EMPTY* ENTRIES ARE PERMITTED BEFORE AN ACTIVE ENTRY.
* 
* 
*     -- *REC* --            RECORD DESCRIPTOR
* 
*     DEFINES A RECORD OR A PORTION OF A RECORD THAT IS TO BE MOVED TO
*     THE JOURNAL LOG OUTPUT BUFFER.
*     TWO OF THESE MAY BE ENTERED INTO THE QUEUE WITH EACH CALL TO
*     DB$JLCT.  IF THE SECOND LENGTH IS ZERO, THEN ONLY ONE RECORD
*     DESCRIPTOR IS ENTERED IN THE QUEUE. 
* 
*     IF A JOURNAL LOG RECORD IS WRAPPED AROUND THE END OF A CIRCULAR 
*     BUFFER, IT MAY BE PASSED AS TWO RECORD PORTIONS.
*     THESE TWO PORTIONS WILL BE RECORDED CONTIGUOUSLY ON THE LOG FILE. 
* 
*     THE *REC* ENTRY CONSISTS OF THE ENTRY TYPE CODE, THE LENGTH AND 
*     LOCATION OF THE RECORD, AND THE LOCATION OF THE USERS RCB.
* 
*     CONTROL WILL BE RETURNED TO THE CALLER WHEN THE RECORD IS IN THE
*     LOG FILE BUFFER.
* 
* 
*     -- *RECF* --           RECORD DESCRIPTOR - FORCE TO DISK
* 
*     IDENTICAL TO THE *REC* ENTRY EXCEPT THAT CONTROL IS NOT RETURNED
*     TO THE CALLER UNTIL THE RECORD IS ON THE DISK.
* 
* 
*     -- *RES* --            RESERVATION
* 
*     THE *RES* ENTRY IS PLACED IN THE QUEUE BY A CALL TO DB$JLRS.
*     IT RESERVES SPACE ON THE PREALLOCATED LOG FILE FOR THE FOLLOWING
*     RECORD OR GROUP OF RECORDS. 
*     THE SPACE MUST BE RESERVED BEFORE ANY CALLS TO DB$JLCT. 
* 
*     THE *RES* ENTRY CONSISTS OF THE ENTRY TYPE CODE, THE TOTAL LENGTH 
*     THAT IS RESERVED AND THE LOCATION OF THE USERS RCB. 
* 
*     THE RESERVED LENGTH IS REDUCED BY THE LENGTH OF EACH RECORD AS
*     THE RECORD DESCRIPTORS ARE PLACED IN THE QUEUE. 
*     A RESERVATION OVERRUN IS A CDCS INTERNAL ERROR. 
* 
*     THE *RES* ENTRY IS REMOVED FROM THE QUEUE WHEN ITS LENGTH IS
*     REDUCED TO ZERO OR WHEN A *RECF* ENTERS THE QUEUE.
* 
*     IF THERE IS A CHANCE THAT NEITHER OF THESE EVENTS WILL OCCUR, 
*     IT IS POSSIBLE TO CANCEL A RESERVATION BY CALLING DB$JLCR.
* 
* 
*     -- *FORCE* --          FORCE RECORD TO DISK 
* 
*     WHEN THE RECORD THAT IS DEFINED BY A *RECF* ENTRY HAS BEEN MOVED
*     TO THE OUTPUT BUFFER, THE ENTRY IS CONVERTED TO A *FORCE* ENTRY.
* 
*     IF OUTPUT IS ALREADY IN PROGRESS, THE RECORD IS NOT ACTUALLY
*     FORCED TO DISK. 
*     INSTEAD, A SURVEILLANCE SCHEME IS SET UP TO TELL IF IT IS WRITTEN 
*     TO DISK DUE TO THE NORMAL OUTPUT OF OTHER RECORDS BEHIND IT.
*     THE CURRENT WORD ADDRESS, -JFQCWA-, OF THE FILE IS RECORDED IN
*     THE FIELD -JFQWA- OF THE *FORCE* ENTRY. 
*     WHEN -JFQCWA-, REDUCED BY THE LENGTH OF DATA IN THE BUFFER, 
*     BECOMES GREATER THAN -JFQWA- THE DATA IS ON DISK. 
*     AT THAT TIME THE *FORCE* IS DELETED FROM THE QUEUE. 
* 
*     IF OUTPUT IS NOT ALREADY IN PROGRESS, THE OUTPUT IS FORCED BY 
*     CALLING DB$RWTR.
* 
* 
*     -- *NULL* --
* 
*     AN EMPTY ENTRY THAT HAS NOT BEEN COMPACTED OUT FROM AMONG THE 
*     ACTIVE ENTRIES. 
* 
* 
* D   JOURNAL LOG OUTPUT STATES 
* 
*       ..  JOURNAL LOG FILE RESERVED TO CAPACITY 
*             (JFILEOK IS FALSE)
* 
*     NO MORE RESERVATIONS ARE ACCEPTED BY DB$JLRS. 
*     DB$JLCT PROCESSES RECORDS NORMALLY ON PREVIOUSLY RESERVED SPACE.
*     WHEN ALL PRIOR RESERVATIONS HAVE BEEN SATISFIED, LOG FILE 
*     SWITCHING IS INITIATED. 
* 
*       ..  JFQUEUE FULL
* 
*     IF THERE IS NOT ROOM IN THE JFQUEUE FOR BOTH OF THE *REC* ENTRIES 
*     THAT MAY BE REQUESTED ON A DB$JLCT CALL, DB$JLCT USES THE DB$PUSH 
*     PROCEDURE TO SAVE THE INPUT PARAMETERS UNTIL THERE IS SPACE 
*     IN THE QUEUE. 
*     ENTRIES ALREADY IN THE QUEUE ARE PROCESSED NORMALLY.
* 
*       ..  JOURNAL LOG FILE FET BUSY 
* 
*     WHEN DB$RWTW FILLS THE OUTPUT BUFFER, IT WILL AUTOMATICALLY 
*     INITIATE A CIO CALL FOR A REWRITE FUNCTION.  IT RETURNS TO THE
*     CALLING ROUTINE WITH THE LENGTH PARAMETER EQUAL TO THE PORTION
*     OF THE DATA THAT HAS NOT BEEN TRANSFERRED INTO THE BUFFER.
* 
*     WHEN A NON-ZERO LENGTH IS RETURNED TO DB$JLCT, THAT INDICATES 
*     THAT THE FET IS BUSY.  DB$JLCT WILL NOT MAKE ANY MORE DB$RWTW 
*     CALLS DURING THAT SCAN. 
* 
*     THE CALL TO DB$SCHD THAT IS MADE WHILE WAITING FOR THE FILE BUSY
*     STATE SPECIFIES THE STATCOMP BIT.  THIS CAUSES THE RCB TO BE
*     RESCHEDULED ON EACH PASS BY DB$SCHD.  THE RESULT IS THAT DB$RWTW
*     IS CALLED AGAIN AT APPROPRIATE INTERVALS TO TEST IF THERE IS
*     SPACE AVAILABLE IN THE BUFFER.
* 
*     NEW REQUESTS THAT ARE RECEIVED DURING THE FET BUSY STATUS ARE 
*     INSERTED IN THE QUEUE AS LONG AS THERE IS QUEUE SPACE.
* 
* 
*       ..  REWRITE RECORD IN PROGRESS
*             (FETWTRI IS FALSE)
* 
*     A CALL TO DB$RWTR INITIATES A REWRITER (REWRITE RECORD) CIO 
*     FUNCTION.  WHILE THE REWRITER IS IN PROGRESS, DB$JLCT CANNOT CALL 
*     DB$RWTW TO ENTER ANY MORE DATA INTO THE OUTPUT BUFFER.
* 
*     THE FLAG -FETWTRI- IS TRUE WHEN DB$RWTR IS IDLE.
*     DB$JLCT WILL NOT ENTER SCAN-2 WHILE -FETWTRI- IS FALSE (BUSY).
*     DURING THIS TIME, RESERVATION AND RECORD REQUESTS ARE ACCEPTED
*     AND PLACED IN THE QUEUE AS LONG AS QUEUE SPACE IS AVAILABLE.
* 
*     TO AVOID THE DB$RWTR BUSY STATUS, DB$JLCT DOES NOT CALL DB$RWTR 
*     WHILE THERE ARE ANY ACTIVE REQUESTS OR RESERVATIONS IN THE QUEUE. 
*     AFTER ALL THE REQUESTS HAVE BEEN PROCESSED, DB$RWTR IS CALLED IF
*     IT IS NECESSARY TO FORCE A RECORD TO THE DISK.
* 
* 
* D   PROCESSING
* 
*     DB$JLCT MAKES THREE SCANS TO PROCESS THE QUEUE. 
* 
* 
*     -- SCAN-1 --
* 
*     THE *RES* ENTRY FOR THE CURRENT RCB IS LOCATED AND ITS
*     RESERVATION IS REDUCED BY THE LENGTH OF THE RECORDS BEING 
*     PASSED TO DB$JLCT.
*     THE *RES* IS CHANGED TO *NULL* IF ITS LENGTH GOES TO ZERO 
*     OR IF -WTR- IS -TRUE-.
* 
*     THE *REC* OR *RECF* REPLACES THE FIRST *EMPTY* ENTRY. 
* 
* 
*     -- SCAN-2 --
* 
*     *FORCE* ENTRIES ARE TESTED TO SEE IF THEIR DATA HAS BEEN
*     TRANSFERRED TO THE DISK.  IF SO, THEY ARE DELETED.
* 
*     DB$RWTW IS CALLED FOR *REC* OR *RECF* ENTRIES.
*     IF DB$RWTW IS NOT ABLE TO TRANSFER THE RECORD TO THE BUFFER,
*     THIS INDICATES THAT THE FILE IS BUSY.  IN THIS CASE -RWTWIDLE-
*     IS SET -FALSE- TO AVOID ANY MORE CALLS TO DB$RWTW DURING THIS 
*     SCAN. 
* 
*     IF A *REC* RECORD IS TRANSFERRED TO THE BUFFER, THE *REC* ENTRY 
*     IS DELETED. 
*     IF A *RECF* RECORD IS TRANSFERRED TO THE BUFFER, THE *RECF* ENTRY 
*     IS CONVERTED TO A *FORCE* ENTRY.
* 
*     ALL REMAINING *RES*, *FORCE*, *REC* AND *RECF* ENTRIES ARE
*     COMPACTED AT THE BEGINNING OF THE QUEUE.
*     ALL REMAINING ENTRIES ARE CONVERTED TO *EMPTY* ENTRIES. 
* 
* 
*     -- SCAN-3 --
* 
*     SCAN 3 IS NOT PERFORMED UNLESS THERE IS A REMAINING *FORCE* 
*     ENTRY AND NO *REC*, *RECF* OR *RES* ENTRIES REMAINING IN THE
*     QUEUE AFTER SCAN-2. 
*     THE *FORCE* ENTRIES ARE PURGED FROM THE QUEUE AND DB$RWTR IS
*     CALLED TO FORCE WRITE THE REMAINING RECORDS TO THE DISK.
* 
* 
*     -- END PROCESSING --
* 
*     IF THE SCANS HAVE LEFT NO *REC*, *RECF* OR *FORCE* ENTRIES IN 
*     THE QUEUE FOR THIS USER, THEN DB$JLCT IS FINISHED FOR THIS USER 
*     AND RETURNS.
*     IF NOT FINISHED, IT DELAYS BY CALLING DB$SCHD AND THEN REPEATS
*     SCAN-2 AND SCAN-3.
 #
# 
*     LOCAL VARIABLES 
# 
      ITEM CONTA I;          # CONTINUATION ADDRESS IF DROPPED         #
      ITEM FINISHED B;       # FLAG SET IF THE RUN UNIT LOGGING IS DONE#
      ITEM LENGTH I;         # RECORD LENGTH PARAMETER FOR DB$RWTW     #
      ITEM NORES B;          # SET IF NO RESERVATION IS IN EFFECT      #
      ITEM RECORD I;         # RECORD LOCATION PARAMETER FOR DB$RWTW   #
      ITEM RWTWIDLE B;       # FLAG SET AS LONG AS DB$RWTW IS IDLE     #
      ITEM TEMP I;           # SCRATCH WORD                            #
      ITEM TEMP2 I;          # SCRATCH WORD                            #
      ITEM XA I;             # INDUCTION VARIABLE                      #
      ITEM XB I;             # INDUCTION VARIABLE                      #
  
  
  
  
#     B E G I N   D B $ J L C T   E X E C U T A B L E   C O D E .      #
  
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("JLCT");
      CONTROL ENDIF;
  
      DB$PUSH(DB$JLCT); 
  
#     CHECK TO SEE IF THERE IS ROOM IN THE QUEUE                       #
  
      P<JFQUEUE> = SAJLFPTR[SALX];
      IF JFQWORD[DFJFNLAST] NQ DFJFQEMPTY 
      THEN
        BEGIN                # WAIT UNTIL AN ENTRY IS AVAILABLE        #
        DB$PSH2(REC1,LENGTH1);
        DB$PSH3(REC2,LENGTH2,WTR);
  
        TEMP2 = LOC(JFQWORD[DFJFNLAST]);
        P<JFQUEUE> = DFNPTR;
        DB$SCHD(TEMP2,DFWAITLOG); 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP ("JLCT-S1");
        CONTROL ENDIF;
  
        P<JFQUEUE> = SAJLFPTR[SALX];
        DB$POP3(WTR,LENGTH2,REC2);
        DB$POP2(LENGTH1,REC1);
        END 
  
#     -- INSERT THE NEW RECORD DESCRIPTORS IN THE JFQUEUE --           #
  
      NORES = TRUE; 
  
                             #  -- SCAN-1 --                           #
  
  
      FOR XA = 0 STEP 1 WHILE JFQWORD[XA] NQ DFJFQEMPTY 
      DO
        BEGIN 
        XB = XA+1;           # AFTER EXIT FROM LOOP, XB POINTS TO EMPTY#
  
                             #  -- *RES* --    CHECK RESERVATION       #
        IF JFQRCB [XA] EQ LOC(RCB)
          AND JFQCODE [XA] EQ DFJFQRES
        THEN
          BEGIN 
          NORES = FALSE;
          JFQLEN [XA] = JFQLEN [XA] - LENGTH1 - LENGTH2;
          IF JFQLEN [XA] EQ 0 
          THEN
            BEGIN 
            JFQWORD [XA] = DFJFQNULL;  # THE RESERVATION IS EXACT      #
            RCJLRS[0] = FALSE;  # CLEAR RCB END-CASE FLAG              #
            TEST XA;
  
            END 
          IF JFQLEN [XA] LS 0 
          THEN
            BEGIN 
            DB$PUNT ("DB$JLCT 3");  # INSUFFICIENT SPACE RESERVED      #
  
            END 
          IF WTR             # IF WRITE RECORD IS SPECIFIED            #
          THEN
            BEGIN 
            JFQWORD [XA] = DFJFQNULL;  # THE RESERVATION IS SATISFIED  #
            RCJLRS[0] = FALSE;  # CLEAR RCB END-CASE FLAG              #
            END 
          END 
        END 
  
                             #  -- *EMPTY* --  INSERT *REC* OR *RECF*  #
      IF NORES
      THEN
        BEGIN 
        DB$PUNT ("DB$JLCT 2");  # NO RESERVATION                       #
  
        END 
      JFQREC [XB] = REC1; 
      JFQLEN [XB] = LENGTH1;
      JFQCODE [XB] = DFJFQREC;
      JFQRCB [XB] = P<RCB>; 
      IF LENGTH2 NQ 0 
      THEN
        BEGIN 
        XB = XB+1;
        JFQREC [XB] = REC2; 
        JFQLEN [XB] = LENGTH2;
        JFQCODE [XB] = DFJFQREC;
        JFQRCB [XB] = P<RCB>; 
        END 
      IF WTR
      THEN
        BEGIN 
        JFQCODE [XB] = DFJFQRECF; 
        END 
      RCIRDTMD[0] = TRUE;    # SET A FLAG TO DEFER TERMINATION         #
  
  
  
#                         B I G   L O O P                              #
  
  
BIGLOOP:                     # LOOP HERE UNTIL THE USERS ENTRY IS GONE #
  
#     IF DB$RWTR IS ACTIVE FOR THIS LOGFILE, WAIT FOR IT TO IDLE.      #
  
      P<FET> = LOC(JFQFET); 
      IF NOT FETWTRI[0] 
      THEN
        BEGIN 
        TEMP2 = LOC(FETWTRI[0]);
        P<JFQUEUE> = DFNPTR;
        P<FET> = DFNPTR;
        DB$SCHD(TEMP2,DFWAITLOG); 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP ("JLCT-S2");
        CONTROL ENDIF;
  
        P<JFQUEUE> = SAJLFPTR[SALX];
        P<FET> = LOC(JFQFET); 
        END 
  
#     -- SCAN THE QUEUE, ADVANCING ENTRY STATUS --                     #
  
      FINISHED = TRUE;
      NORES = TRUE; 
      RWTWIDLE = TRUE;
      XA = 0; 
  
                             #  -- SCAN-2 --                           #
  
#     THIS SCAN WILL SQUEEZE OUT COMPLETED ENTRIES AND NULL ENTRIES    #
#     THAT HAVE BEEN LEFT IN THE QUEUE.                                #
#     ITEM XA CONTROLS THE STORAGE OF ENTRIES NOT BEING SQUEEZED OUT.  #
#     AN EXIT FROM THE FOR LOOP VIA A TEST XB CAUSES AN ENTRY TO BE    #
#     SQUEEZED OUT.                                                    #
  
      FOR XB = 0 STEP 1 UNTIL DFJFLAST
      DO
        BEGIN 
  
                             #  -- *FORCE* --                          #
        IF JFQCODE [XB] EQ DFJFQFORCE 
        THEN
          BEGIN              # TEST IF DATA IS NOW ON THE DISK         #
  
#         -JFQCWA- IS A COUNT OF HOW MANY WORDS HAVE BEEN SENT TO THE  #
#         FILE.  IT IS INCREASED BY DB$RWTW EVERY TIME A RECORD IS     #
#         TRANSFERED INTO THE BUFFER.                                  #
#         WHEN A *FORCE* ENTRY IS CREATED, THE VALUE OF -JFQCWA- IS    #
#         SAVED IN -JFQWA-.                                            #
#         THE CURRENT WORD ADDRESS OF DATA THAT HAS BEEN TRANSFERRED   #
#         TO THE DISK IS CALCULATED BY SUBTRACTING THE LENGTH OF DATA  #
#         IN THE BUFFER FROM -JFQCWA-.                                 #
#         WHEN THE CALCULATED VALUE IS GREATED THAN -JFQWA-, THE RECORD#
#         IS ON THE DISK.                                              #
  
          TEMP = FETIN[0] - FETOUT[0];  # SIZE OF DATA IN THE BUFFER   #
          IF TEMP LS 0
          THEN                # ADD BUFFER SIZE TO INVERT THE BUFFER   #
            BEGIN 
            TEMP = TEMP + FETLIMIT[0] - FETFIRST[0];
            END 
                             # CURRENT WORD ADDRESS REDUCED BY THE     #
                             # LENGTH OF THE DATA IN THE BUFFER        #
          TEMP = FETCWA[0] - TEMP;
          IF TEMP GQ JFQWA[XB]
          THEN               # THE DATA HAS BEEN WRITTEN TO THE DISK   #
            BEGIN 
            TEST XB;         # DELETE THE ENTRY BY SKIPPING PAST IT    #
  
            END 
          END 
  
                             #  -- *NULL* --   DELETE IT               #
        IF JFQCODE[XB] GQ DFJFQNULL 
        THEN
          BEGIN 
          IF JFQCODE[XB] EQ DFJFQNULL 
          THEN
            BEGIN 
            TEST XB;         # COMPRESS OUT THE NULL ENTRY             #
  
            END 
          DB$PUNT ("DB$JLCT 4");  # INVALID ENTRY                      #
  
          END 
                             #  -- *REC*  OR  *RECF* --                #
        IF (JFQCODE [XB] EQ DFJFQREC
          OR JFQCODE [XB] EQ DFJFQRECF) 
          AND RWTWIDLE
        THEN
          BEGIN 
          IF FETNOSAT[0] NQ 0 
          THEN               # I-O ERROR FROM PRIOR FILE ACCESS        #
            BEGIN 
            DB$IOER(P<FET>);
            END 
          RECORD =  JFQREC [XB];
          LENGTH =  JFQLEN [XB];
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("JLCT-C1"); 
          CONTROL ENDIF;
  
          DB$RWTW (P<FET>, RECORD, LENGTH); 
  
#         WHEN LENGTH GOES TO ZERO, THE TRANSFER TO THE BUFFER IS DONE #
  
          IF LENGTH EQ 0
          THEN
            BEGIN 
            IF JFQCODE [XB] EQ DFJFQREC 
            THEN
              BEGIN 
              TEST XB;       # REQUEST COMPLETED, DELETE IT            #
  
              END 
            ELSE
              BEGIN 
  
#             IT IS A DFJFQRECF.                                       #
#             IT MUST BE ON DISK BEFORE THE REQUEST IS COMPLETE.       #
#             CONVERT IT TO DFJFQFORCE.                                #
  
              JFQWA[XB] = FETCWA[0];
              JFQCODE [XB] = DFJFQFORCE;
              END 
            END 
          ELSE
            BEGIN 
  
#           THE LENGTH HAS NOT GONE TO ZERO.                           #
#           THAT MEANS DB$RWTW IS BUSY AND CANT ACCEPT THE REST.       #
#           DONT SEND IT ANY MORE RECORDS                              #
  
            RWTWIDLE = FALSE; 
            JFQREC[XB] = RECORD;
            JFQLEN[XB] = LENGTH;
            END 
          END 
  
#     IF THIS USER HAS ANY ACTIVE ENTRIES, OTHER THAN *RES*, LEFT THEN #
#     THIS REQUEST SHOULD CONTINUE TO LOOP. (CALLING DB$SCHD)          #
  
        IF JFQRCB [XB] EQ LOC(RCB)
          AND JFQCODE [XB] NQ DFJFQRES
        THEN
          BEGIN 
          FINISHED = FALSE; 
          END 
  
                             # -- *RES* --                             #
        IF JFQCODE[XB] EQ DFJFQRES
        THEN
          BEGIN 
          NORES = FALSE;
          END 
  
#     COMPACT THE ENTRIES THAT ARE STILL ACTIVE.                       #
  
        JFQWORD [XA] = JFQWORD [XB];
        XA = XA + 1;
  
        IF JFQWORD[XA] EQ DFJFQEMPTY
        THEN
          BEGIN 
          GOTO RESTEMPTY;    # ALL THE REST OF THE ENTRIES ARE EMPTY   #
  
          END 
        END 
  
      FOR XA = XA STEP 1 UNTIL DFJFLAST 
      DO
        BEGIN 
        JFQWORD [XA] = DFJFQEMPTY;
        END 
  
  
RESTEMPTY:  
  
  
                             #  -- SCAN-3 --                           #
  
#     IF THERE ARE *FORCE* ENTRIES BUT NO *REC*, *RECF* OR *RES*       #
#     ENTRIES, THEN ALL THE ACTIVE ENTRIES ARE *FORCE* ENTRIES.        #
#     DELETE THEM AND THEN CALL DB$RWTR.                               #
  
      IF JFQCODE[0] EQ DFJFQFORCE 
        AND RWTWIDLE
        AND NORES 
      THEN
        BEGIN 
        FOR XA = 0 STEP 1 
          WHILE JFQWORD[XA] NQ DFJFQEMPTY 
        DO
          BEGIN 
          JFQWORD[XA] = DFJFQEMPTY; 
          END 
        IF FETNOSAT[0] NQ 0 
        THEN                 # I-O ERROR FROM PRIOR FILE ACCESS        #
          BEGIN 
          DB$IOER(P<FET>);
          END 
        DB$RWTR(P<FET>);
        FINISHED = TRUE;
        END 
  
                             #  -- END PROCESSING --                   #
      P<FET> = DFNPTR;
      IF NOT FINISHED 
      THEN
        BEGIN 
        P<JFQUEUE> = DFNPTR;
        DB$SCHD(LOC(STATCOMP), DFWAITLOG);
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("JLCT-S3"); 
        CONTROL ENDIF;
  
        P<JFQUEUE> = SAJLFPTR[SALX];
        GOTO BIGLOOP; 
  
  
        END 
  
      P<JFQUEUE> = DFNPTR;
      DB$POP(DB$JLCT);
      RCIRDTMD[0] = FALSE;
      IF RCIRDTAD[0] NQ 0 
      THEN                   # A JOB TERMINATION HAS OCCURRED.         #
        BEGIN 
        RCSTACKX[0] = LOC(RCB) + DFRCIR0;  # RESET THE STACK TO EMPTY  #
        CONTA = RCIRDTAD[0];
        RCIRDTAD[0] = 0;
        DB$GOTO(CONTA);      # GO TO THE ERROR PROCESSOR.              #
        END 
  
      RETURN; 
  
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   D B $ J L C R .        #
#                                                                      #
#**********************************************************************#
  
      PROC DB$JLCR; 
      BEGIN 
 #
* *   DB$JLCT                                    PAGE  1
* *   DB$JLCR - CANCEL RESERVATIONS 
* *   R L MCALLESTER                             DATE  10/21/80 
* 
* DC  PURPOSE 
* 
*     CANCEL SPACE RESERVATIONS ON THE JOURNAL LOG FILE.
* 
* DC  ENTRY CONDITIONS
* 
* D   PARAMETERS
* 
*     NONE
* 
* D   ASSUMPTIONS 
* 
*     P<RCB>                 POINTER TO CURRENT RUN-UNIT CONTROL BLOCK
*     SALX                   SUBSCRIPT TO SCHEMA ACCESS LIST
* 
* DC  EXIT CONDITIONS 
* 
*     THE *RES*, *REC* AND *RECF* ENTRIES FOR THIS RCB HAVE BEEN
*     PURGED FROM THE JFQUEUE.
* 
* DC  CALLING ROUTINES
* 
*     DB$RCBF                CALLED IF THE RUN UNIT IS DROPPED. 
* 
* DC  CALLED ROUTINES 
* 
*     DB$JLCT                ENTERED AT LABEL -BIGLOOP- 
*     DB$PUSH                SAVE WORD IN RCB STACK 
* 
* DC  NON-LOCAL VARIABLES MODIFIED
* 
*     JFQUEUE                QUEUE CONTAINING RECORD AND RESERVATION
*                            DESCRIPTORS. 
* 
* DC  DESCRIPTION 
* 
*     SCAN THE JFQUEUE FOR *RES*, *REC* OR *RECF* ENTRIES.
*     AS EACH IS LOCATED IT IS CONVERTED TO A *NULL*, UNLESS IT IS THE
*     FIRST *REC* OR *RECF* IN THE QUEUE. 
*     THE FIRST *REC* OR *RECF* MAY HAVE BEEN PARTIALLY TRANSFERRED TO
*     THE OUTPUT BUFFER.
*     PARTIAL RECORDS ARE NOT PERMITTED ON THE FILE, SO CONTROL IS
*     TRANSFERRED BACK TO DB$JLCT TO WAIT FOR THE REMAINDER OF THE
*     RECORD TO BE TRANSFERRED. 
 #
# 
*     LOCAL VARIABLES 
# 
      ITEM FIRSTREC B;       # FIRST *REC*                             #
  
  
#     B E G I N   D B $ J L C R   E X E C U T A B L E   C O D E        #
  
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("JLCR");
      CONTROL ENDIF;
  
      P<JFQUEUE> = SAJLFPTR[SALX];
      FIRSTREC = TRUE;
  
      FOR XA = 0 STEP 1 
        WHILE JFQCODE NQ DFJFQEMPTY 
        AND XA LQ DFJFLAST
      DO
        BEGIN 
        IF JFQRCB[XA] EQ LOC(RCB) 
        THEN
          BEGIN 
                             # THE ENTRY IS FOR THE TERMINATED USER    #
          IF JFQCODE[XA] EQ DFJFQRES
          THEN
            BEGIN 
            JFQWORD[XA] = DFJFQNULL;
            TEST XA;
  
            END 
          IF JFQCODE[XA] EQ DFJFQREC
            OR JFQCODE[XA] EQ DFJFQRECF 
          THEN
            BEGIN 
            IF FIRSTREC 
            THEN
              BEGIN 
              DB$PUSH(DB$JLCR);  # DB$JLCT WILL POP TO ITS ENTRY       #
              GOTO BIGLOOP;  # GO WAIT TIL THE RECORD IS WRITTEN       #
  
              END 
            ELSE
              BEGIN 
              JFQWORD[XA] = DFJFQNULL;
              END 
            END 
          END 
        ELSE
          BEGIN 
                             # THE ENTRY IS FOR ANOTHER USER           #
          IF JFQCODE[XA] EQ DFJFQREC
            OR JFQCODE[XA] EQ DFJFQRECF 
          THEN
            BEGIN 
                             # THE TERMINATED USERS ENTRY IS NOT FIRST #
            FIRSTREC = FALSE; 
            END 
          END 
        END 
      P<JFQUEUE> = DFNPTR;
      RETURN; 
  
      END   # DB$JLCR # 
  
      END   # DB$JLCT # 
      TERM
