From:	SCOVCB::GALVIN_FX    31-JAN-1989 09:01
To:	ARISIA::EVERHART
Subj:	

package body QUEUES is

   DONE : boolean := false;
   TOP_QUEUE, LAST_QUEUE : QUEUE;
   TRC_OPTION : UTILITY.OPTION := UTILITY.OFF;
   REPORT_OPT : UTILITY.OPTION := UTILITY.ON;

   procedure FREE_QUEUE is new UNCHECKED_DEALLOCATION (QUEUE_REC, QUEUE);

   task QUEUE_TASK is
      entry CREATE (Q : in out QUEUE; T : in STRING);
      entry INSERT (Q : in out QUEUE; E : in ELEMENT_TYPE);
      entry REMOVE_FIRST (Q : in out QUEUE; E : out ELEMENT_TYPE);
      entry REMOVE_CURRENT (Q : in out QUEUE);
      entry FIRST (Q : in out QUEUE; OUT_PUT_DATA : out ELEMENT_TYPE);
      entry LAST (Q : in out QUEUE; OUT_PUT_DATA : out ELEMENT_TYPE);
      entry NEXT (Q : in out QUEUE; OUT_PUT_DATA : out ELEMENT_TYPE);
      entry PREVIOUS (Q : in out QUEUE; OUT_PUT_DATA : out ELEMENT_TYPE);
   end QUEUE_TASK;

   task body QUEUE_TASK is
   begin
      loop
         select    
         accept CREATE (Q : in out QUEUE; T : in STRING) do
--      LINK QUEUES TOGETHER
            Q := new QUEUE_REC;
            if TOP_QUEUE = null then
               TOP_QUEUE := Q;
            else
               LAST_QUEUE.NEXT := Q;
            end if;
            LAST_QUEUE := Q;
            Q.LENGTH := 0;
            Q.NAME := UTILITY.STRING_MATCH (T, 8);
         end CREATE;
         or
         accept INSERT (Q : in out QUEUE; E : in ELEMENT_TYPE) do
            declare 
               NEW_NODE, TEMP_NODE_PTR : ELEMENT_PTR;
            begin
-- Chain the new node into the  structure.
               NEW_NODE := new ELEMENT_REC;
               NEW_NODE.DATA := E;
               Q.NO_OF_ENTRIES := Q.NO_OF_ENTRIES + 1;
               if QUEUE_IS_EMPTY (Q) then
                  Q.TOP := NEW_NODE;
                  Q.BOTTOM := NEW_NODE;
                  Q.CURRENT := NEW_NODE;
               else 
                  TEMP_NODE_PTR := Q.TOP;
                  DONE := false;
                  while not DONE loop
                     if RELATES_TO (E, TEMP_NODE_PTR.DATA) then
                        if TEMP_NODE_PTR = Q.TOP then
-- insert NEW_NODE right before TEMP_NODE_PTR at TOP 
                           Q.TOP := NEW_NODE;
                           TEMP_NODE_PTR.PREV := NEW_NODE;
                        else
-- insert NEW_NODE right before TEMP_NODE_PTR 
                           TEMP_NODE_PTR.PREV.NEXT := NEW_NODE;
                           NEW_NODE.PREV := TEMP_NODE_PTR.PREV;
                           TEMP_NODE_PTR.PREV := NEW_NODE;
                        end if;
                        NEW_NODE.NEXT := TEMP_NODE_PTR;
                        DONE := true;
                     else
                        exit when TEMP_NODE_PTR = Q.BOTTOM;
                        TEMP_NODE_PTR := TEMP_NODE_PTR.NEXT;
                     end if;                   
                  end loop;
                  if not DONE then
-- insert NEW_NODE right after TEMP_NODE_PTR at BOTTOM
                     TEMP_NODE_PTR.NEXT := NEW_NODE;
                     NEW_NODE.PREV := TEMP_NODE_PTR;
                     Q.BOTTOM := NEW_NODE;
                  end if;
                  Q.CURRENT := NEW_NODE;
               end if;
               Q.LENGTH := Q.LENGTH + 1;
               if Q.LENGTH > Q.MAX_LENGTH then
                  Q.MAX_LENGTH := Q.LENGTH;
               end if;
            end; --declare block
         end INSERT;
         or
         accept REMOVE_FIRST (Q : in out QUEUE; E : out ELEMENT_TYPE) do
            if QUEUE_IS_EMPTY (Q) then 
               raise QUEUE_EMPTY_ERROR;
            else
-- Remove the node on the top of the list and change the TOP pointer,
-- and alter the CURRENT pointer appropriately.         
               Q.LENGTH := Q.LENGTH - 1;             
               E := Q.TOP.DATA;
               if Q.LENGTH > 0 then
                  Q.CURRENT := Q.BOTTOM;
                  Q.TOP := Q.TOP.NEXT;
                  Q.TOP.PREV := null;
               end if;
            end if;
         end REMOVE_FIRST;
         or 
         accept REMOVE_CURRENT (Q : in out QUEUE) do
            if QUEUE_IS_EMPTY (Q) then
               raise QUEUE_EMPTY_ERROR;
            else
-- Remove the node being pointed to by CURRENT  pointer.              
-- Now,set the CURRENT pointer to its predecessor:
               Q.LENGTH := Q.LENGTH - 1;
               if Q.LENGTH > 0 then
                  if Q.CURRENT = Q.TOP then
                     Q.TOP := Q.TOP.NEXT;
                     Q.TOP.PREV := null;
                     Q.CURRENT := Q.BOTTOM;
                  elsif Q.CURRENT = Q.BOTTOM then
                     Q.BOTTOM := Q.BOTTOM.PREV;
                     Q.BOTTOM.NEXT := null;
                     Q.CURRENT := Q.BOTTOM;
                  else
                     Q.CURRENT.PREV.NEXT := Q.CURRENT.NEXT;
                     Q.CURRENT.NEXT.PREV := Q.CURRENT.PREV;
                     Q.CURRENT := Q.CURRENT.PREV;
                  end if;
               end if;
            end if;
         end REMOVE_CURRENT;
         or
         accept FIRST (Q : in out QUEUE; OUT_PUT_DATA : out ELEMENT_TYPE) do
            if QUEUE_IS_EMPTY (Q) then
               raise QUEUE_EMPTY_ERROR;
            else
               Q.CURRENT := Q.TOP;
               OUT_PUT_DATA := Q.CURRENT.DATA;
            end if;
         end FIRST;
         or
         accept LAST (Q : in out QUEUE; OUT_PUT_DATA : out ELEMENT_TYPE) do
            if QUEUE_IS_EMPTY (Q) then
               raise QUEUE_EMPTY_ERROR;
            else
               Q.CURRENT:= Q.BOTTOM;
               OUT_PUT_DATA := Q.CURRENT.DATA;
            end if;
         end LAST;
         or
         accept NEXT (Q: in out QUEUE; OUT_PUT_DATA : out ELEMENT_TYPE) do
            if QUEUE_IS_EMPTY (Q) then
               raise QUEUE_EMPTY_ERROR;
            elsif Q.CURRENT = Q.BOTTOM then
               Q.CURRENT := Q.TOP;
            else
               Q.CURRENT := Q.CURRENT.NEXT;
            end if;
            OUT_PUT_DATA := Q.CURRENT.DATA;
         end NEXT;
         or
         accept PREVIOUS (Q : in out QUEUE; OUT_PUT_DATA : out ELEMENT_TYPE) do
            if QUEUE_IS_EMPTY (Q) then
               raise QUEUE_EMPTY_ERROR;
            elsif Q.CURRENT = Q.TOP then
               Q.CURRENT := Q.BOTTOM;
            else
               Q.CURRENT := Q.CURRENT.PREV;
            end if;
            OUT_PUT_DATA := Q.CURRENT.DATA;
         end PREVIOUS;
         or
            terminate;
         end select;
      end loop;
   exception
      when others =>
         put_line ("FATAL ERROR -- Queue Exception");
         SET_QUEUE_REPORT_OPTION (UTILITY.ON);
         OUTPUT_QUEUE_REPORT;
   end QUEUE_TASK;


   procedure CREATE_QUEUE (QUEUE_REF : in out QUEUE; QUEUE_NAME : in string) is
   begin
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("CREATE_QUEUE " & QUEUE_NAME, UTILITY.LF);
      end if;
      QUEUE_TASK.CREATE (QUEUE_REF, QUEUE_NAME);
   end CREATE_QUEUE;

   procedure INSERT_QUEUE (QUEUE_REF : in out QUEUE ; 
                           ELEMENT_REF : in ELEMENT_TYPE) is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("INSERT_QUEUE " & QUEUE_REF.NAME, UTILITY.LF);
      end if;
      QUEUE_TASK.INSERT (QUEUE_REF, ELEMENT_REF);
   end INSERT_QUEUE;


   procedure REMOVE_QUEUE_FIRST (QUEUE_REF : in out QUEUE; 
                                 ELEMENT_REF : out ELEMENT_TYPE) is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("REMOVE_QUEUE_FIRST " & QUEUE_REF.NAME, 
                               UTILITY.LF);
      end if;
      QUEUE_TASK.REMOVE_FIRST (QUEUE_REF, ELEMENT_REF);
   end REMOVE_QUEUE_FIRST;


   procedure REMOVE_QUEUE_CURRENT (QUEUE_REF : in out QUEUE) is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("REMOVE_QUEUE_CURRENT " & QUEUE_REF.NAME, 
                               UTILITY.LF);
      end if;
      QUEUE_TASK.REMOVE_CURRENT (QUEUE_REF);
   end REMOVE_QUEUE_CURRENT;


   procedure DESTROY_QUEUE (QUEUE_REF : in out QUEUE) is
      Q_CURRENT, Q_PREVIOUS : QUEUE;
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("DESTROY_QUEUE " & QUEUE_REF.NAME, UTILITY.LF);
      end if;
-- decouple this queue 
      Q_CURRENT := TOP_QUEUE;
      if Q_CURRENT = QUEUE_REF then       -- top_queue special case
         TOP_QUEUE := Q_CURRENT.NEXT;
         if LAST_QUEUE = QUEUE_REF then
            LAST_QUEUE := TOP_QUEUE;       -- should be null
         end if;
      else                                -- not top_queue
         loop
            Q_PREVIOUS := Q_CURRENT;
            Q_CURRENT := Q_PREVIOUS.NEXT;
            if Q_CURRENT = QUEUE_REF then
               Q_PREVIOUS.NEXT := Q_CURRENT.NEXT;
               if LAST_QUEUE = QUEUE_REF then
                  LAST_QUEUE := Q_PREVIOUS;
               end if;
               exit;
            end if;
            exit when Q_CURRENT = LAST_QUEUE;  -- this should never happen
         end loop;
      end if;
      FREE_QUEUE (QUEUE_REF);
   end DESTROY_QUEUE;


   procedure FIRST_IN_QUEUE (QUEUE_REF : in out QUEUE; 
                             ELEMENT_REF : out ELEMENT_TYPE) is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("FIRST_IN_QUEUE " & QUEUE_REF.NAME, UTILITY.LF);
      end if;
      QUEUE_TASK.FIRST (QUEUE_REF, ELEMENT_REF);
   end FIRST_IN_QUEUE;

  	
   procedure LAST_IN_QUEUE (QUEUE_REF : in out QUEUE;  
                            ELEMENT_REF : out ELEMENT_TYPE) is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("LAST_IN_QUEUE " & QUEUE_REF.NAME, UTILITY.LF);
      end if;
      QUEUE_TASK.LAST (QUEUE_REF, ELEMENT_REF);
   end LAST_IN_QUEUE;


   procedure NEXT_IN_QUEUE (QUEUE_REF : in out QUEUE; 
                            ELEMENT_REF : out  ELEMENT_TYPE) is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("NEXT_IN_QUEUE " & QUEUE_REF.NAME, UTILITY.LF);
      end if;
      QUEUE_TASK.NEXT (QUEUE_REF, ELEMENT_REF);
   end NEXT_IN_QUEUE;


   procedure PREVIOUS_IN_QUEUE (QUEUE_REF : in out QUEUE; 
                                ELEMENT_REF : out ELEMENT_TYPE) is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("PREVIOUS_IN_QUEUE " & QUEUE_REF.NAME, 
                               UTILITY.LF);
      end if;
      QUEUE_TASK.PREVIOUS (QUEUE_REF, ELEMENT_REF);
   end PREVIOUS_IN_QUEUE;


   function QUEUE_IS_EMPTY (QUEUE_REF : in QUEUE) return boolean is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      if QUEUE_REF.LENGTH = 0 then 
         return true;
      else
         return false;
      end if;
   end QUEUE_IS_EMPTY;


   function QUEUE_IS_AT_BEGIN (QUEUE_REF  : in QUEUE) return boolean is
   begin
      if QUEUE_IS_EMPTY (QUEUE_REF) then
         raise QUEUE_EMPTY_ERROR;
      elsif QUEUE_REF.CURRENT = QUEUE_REF.TOP then
         return true;
      else
         return false;
      end if;
   end QUEUE_IS_AT_BEGIN;


   function QUEUE_IS_AT_END (QUEUE_REF  : in QUEUE) return boolean is
   begin
      if QUEUE_IS_EMPTY (QUEUE_REF) then
         raise QUEUE_EMPTY_ERROR;
      elsif QUEUE_REF.CURRENT = QUEUE_REF.BOTTOM then
         return true;
      else
         return false;
      end if;
   end QUEUE_IS_AT_END;


   function LENGTH_OF_QUEUE (QUEUE_REF : in QUEUE) return integer is
   begin
      if QUEUE_REF = null then
         raise QUEUE_DOES_NOT_EXIST;
      end if;
      return QUEUE_REF.LENGTH;
   end LENGTH_OF_QUEUE;


   procedure OUTPUT_QUEUE_REPORT is
      use UTILITY.INT_IO;
      QU : QUEUE := TOP_QUEUE;
      QSNAME : UTILITY.CHAR_STRING;
   begin
      QSNAME := UTILITY.STRING_MATCH (QUEUES_NAME, 8);
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("OUTPUT_QUEUE_REPORT for QUEUES package "
            & QSNAME, UTILITY.LF);
      end if;
      if REPORT_OPT = UTILITY.ON then
         UTILITY.CONTROL_OUTPUT;
         new_line;
         new_line;
         put ("  REPORT FOR QUEUES PACKAGE: "); put (QSNAME); new_line;
         new_line;
         if QU = null then
            put_line ("No queues were created or all have been destroyed");
         else
            put_line ("                          MAXIMUM  NUMBER OF");
            put_line ("  NAME          LENGTH     LENGTH    ENTRIES");
            loop
               put (QU.NAME & "   ");
               put (QU.LENGTH); 
               put (QU.MAX_LENGTH); 
               put (QU.NO_OF_ENTRIES); 
               new_line;
               exit when QU.NEXT = null;
               QU := QU.NEXT;
            end loop;
         end if;
         new_line;
         UTILITY.RELEASE_OUTPUT_CONTROL;
      end if;
   end OUTPUT_QUEUE_REPORT;


   procedure SET_QUEUE_REPORT_OPTION (REPORT_OPTION : in UTILITY.OPTION) is
      QSNAME : UTILITY.CHAR_STRING;
   begin
      QSNAME := UTILITY.STRING_MATCH (QUEUES_NAME, 8);
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("SET QUEUE REPORT OPTION ", UTILITY.NO_LF);
         if REPORT_OPTION = UTILITY.ON then
            put ("ON");
         else 
            put ("OFF");
         end if;
         put (" for QUEUES package "); put (QSNAME); new_line;
      end if;
      REPORT_OPT := REPORT_OPTION;
   end SET_QUEUE_REPORT_OPTION;


   procedure SET_QUEUE_TRACE_OPTION (TRACE_OPTION : in UTILITY.OPTION) is
      QSNAME : UTILITY.CHAR_STRING;
   begin
      QSNAME := UTILITY.STRING_MATCH (QUEUES_NAME, 8);
      TRC_OPTION := TRACE_OPTION;
      if TRC_OPTION = UTILITY.ON then
         UTILITY.OUTPUT_TRACE ("SET QUEUE TRACE OPTION ON", UTILITY.NO_LF);
         put (" for QUEUES package "); put (QSNAME); new_line;
      end if;
   end SET_QUEUE_TRACE_OPTION;

end QUEUES;
