gcc/ada/a-cuprqu.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                 ADA.CONTAINERS.UNBOUNDED_PRIORITY_QUEUES                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2011-2015, Free Software Foundation, Inc.       --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 package body Ada.Containers.Unbounded_Priority_Queues is
  33
  34    package body Implementation is
  35
  36       -----------------------
  37       -- Local Subprograms --
  38       -----------------------
  39
  40       function Before_Or_Equal (X, Y : Queue_Priority) return Boolean;
  41       --  True if X is before or equal to Y. Equal means both Before(X,Y) and
  42       --  Before(Y,X) are False.
  43
  44       procedure Free is
  45         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
  46
  47       ---------------------
  48       -- Before_Or_Equal --
  49       ---------------------
  50
  51       function Before_Or_Equal (X, Y : Queue_Priority) return Boolean is
  52       begin
  53          return (if Before (X, Y) then True else not Before (Y, X));
  54       end Before_Or_Equal;
  55
  56       -------------
  57       -- Dequeue --
  58       -------------
  59
  60       procedure Dequeue
  61         (List    : in out List_Type;
  62          Element : out Queue_Interfaces.Element_Type)
  63       is
  64          H : constant Node_Access := List.Header'Unchecked_Access;
  65          pragma Assert (List.Length /= 0);
  66          pragma Assert (List.Header.Next /= H);
  67          --  List can't be empty; see the barrier
  68
  69          pragma Assert
  70            (List.Header.Next.Next = H or else
  71             Before_Or_Equal (Get_Priority (List.Header.Next.Element),
  72                              Get_Priority (List.Header.Next.Next.Element)));
  73          --  The first item is before-or-equal to the second
  74
  75          pragma Assert
  76            (List.Header.Next.Next_Unequal = H or else
  77             Before (Get_Priority (List.Header.Next.Element),
  78                     Get_Priority (List.Header.Next.Next_Unequal.Element)));
  79          --  The first item is before its Next_Unequal item
  80
  81          --  The highest-priority item is always first; just remove it and
  82          --  return that element.
  83
  84          X : Node_Access := List.Header.Next;
  85
  86       --  Start of processing for Dequeue
  87
  88       begin
  89          Element := X.Element;
  90          X.Next.Prev := H;
  91          List.Header.Next := X.Next;
  92          List.Header.Next_Unequal := X.Next;
  93          List.Length := List.Length - 1;
  94          Free (X);
  95       end Dequeue;
  96
  97       procedure Dequeue
  98         (List     : in out List_Type;
  99          At_Least : Queue_Priority;
 100          Element  : in out Queue_Interfaces.Element_Type;
 101          Success  : out Boolean)
 102       is
 103       begin
 104          --  This operation dequeues a high priority item if it exists in the
 105          --  queue. By "high priority" we mean an item whose priority is equal
 106          --  or greater than the value At_Least. The generic formal operation
 107          --  Before has the meaning "has higher priority than". To dequeue an
 108          --  item (meaning that we return True as our Success value), we need
 109          --  as our predicate the equivalent of "has equal or higher priority
 110          --  than", but we cannot say that directly, so we require some logical
 111          --  gymnastics to make it so.
 112
 113          --  If E is the element at the head of the queue, and symbol ">"
 114          --  refers to the "is higher priority than" function Before, then we
 115          --  derive our predicate as follows:
 116          --    original: P(E) >= At_Least
 117          --    same as:  not (P(E) < At_Least)
 118          --    same as:  not (At_Least > P(E))
 119          --    same as:  not Before (At_Least, P(E))
 120
 121          --  But that predicate needs to be true in order to successfully
 122          --  dequeue an item. If it's false, it means no item is dequeued, and
 123          --  we return False as the Success value.
 124
 125          Success := List.Length > 0
 126            and then
 127              not Before (At_Least, Get_Priority (List.Header.Next.Element));
 128
 129          if Success then
 130             List.Dequeue (Element);
 131          end if;
 132       end Dequeue;
 133
 134       -------------
 135       -- Enqueue --
 136       -------------
 137
 138       procedure Enqueue
 139         (List     : in out List_Type;
 140          New_Item : Queue_Interfaces.Element_Type)
 141       is
 142          P : constant Queue_Priority := Get_Priority (New_Item);
 143          H : constant Node_Access := List.Header'Unchecked_Access;
 144
 145          function Next return Node_Access;
 146          --  The node before which we wish to insert the new node
 147
 148          ----------
 149          -- Next --
 150          ----------
 151
 152          function Next return Node_Access is
 153          begin
 154             return Result : Node_Access := H.Next_Unequal do
 155                while Result /= H
 156                  and then not Before (P, Get_Priority (Result.Element))
 157                loop
 158                   Result := Result.Next_Unequal;
 159                end loop;
 160             end return;
 161          end Next;
 162
 163          --  Local varaibles
 164
 165          Prev : constant Node_Access := Next.Prev;
 166          --  The node after which we wish to insert the new node. So Prev must
 167          --  be the header, or be higher or equal priority to the new item.
 168          --  Prev.Next must be the header, or be lower priority than the
 169          --  new item.
 170
 171          pragma Assert
 172            (Prev = H or else Before_Or_Equal (Get_Priority (Prev.Element), P));
 173          pragma Assert
 174            (Prev.Next = H
 175               or else Before (P, Get_Priority (Prev.Next.Element)));
 176          pragma Assert (Prev.Next = Prev.Next_Unequal);
 177
 178          Node : constant Node_Access :=
 179                   new Node_Type'(New_Item,
 180                                  Prev         => Prev,
 181                                  Next         => Prev.Next,
 182                                  Next_Unequal => Prev.Next);
 183
 184       --  Start of processing for Enqueue
 185
 186       begin
 187          Prev.Next.Prev := Node;
 188          Prev.Next := Node;
 189
 190          if Prev = H then
 191
 192             --  Make sure Next_Unequal of the Header always points to the first
 193             --  "real" node. Here, we've inserted a new first "real" node, so
 194             --  must update.
 195
 196             List.Header.Next_Unequal := Node;
 197
 198          elsif Before (Get_Priority (Prev.Element), P) then
 199
 200             --  If the new item inserted has a unique priority in queue (not
 201             --  same priority as precedent), set Next_Unequal of precedent
 202             --  element to the new element instead of old next element, since
 203             --  Before (P, Get_Priority (Next.Element) or Next = H).
 204
 205             Prev.Next_Unequal := Node;
 206          end if;
 207
 208          pragma Assert (List.Header.Next_Unequal = List.Header.Next);
 209
 210          List.Length := List.Length + 1;
 211
 212          if List.Length > List.Max_Length then
 213             List.Max_Length := List.Length;
 214          end if;
 215       end Enqueue;
 216
 217       --------------
 218       -- Finalize --
 219       --------------
 220
 221       procedure Finalize (List : in out List_Type) is
 222          Ignore : Queue_Interfaces.Element_Type;
 223       begin
 224          while List.Length > 0 loop
 225             List.Dequeue (Ignore);
 226          end loop;
 227       end Finalize;
 228
 229       ------------
 230       -- Length --
 231       ------------
 232
 233       function Length (List : List_Type) return Count_Type is
 234       begin
 235          return List.Length;
 236       end Length;
 237
 238       ----------------
 239       -- Max_Length --
 240       ----------------
 241
 242       function Max_Length (List : List_Type) return Count_Type is
 243       begin
 244          return List.Max_Length;
 245       end Max_Length;
 246
 247    end Implementation;
 248
 249    protected body Queue is
 250
 251       -----------------
 252       -- Current_Use --
 253       -----------------
 254
 255       function Current_Use return Count_Type is
 256       begin
 257          return List.Length;
 258       end Current_Use;
 259
 260       -------------
 261       -- Dequeue --
 262       -------------
 263
 264       entry Dequeue (Element : out Queue_Interfaces.Element_Type)
 265         when List.Length > 0
 266       is
 267       begin
 268          List.Dequeue (Element);
 269       end Dequeue;
 270
 271       --------------------------------
 272       -- Dequeue_Only_High_Priority --
 273       --------------------------------
 274
 275       procedure Dequeue_Only_High_Priority
 276         (At_Least : Queue_Priority;
 277          Element  : in out Queue_Interfaces.Element_Type;
 278          Success  : out Boolean)
 279       is
 280       begin
 281          List.Dequeue (At_Least, Element, Success);
 282       end Dequeue_Only_High_Priority;
 283
 284       -------------
 285       -- Enqueue --
 286       -------------
 287
 288       entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is
 289       begin
 290          List.Enqueue (New_Item);
 291       end Enqueue;
 292
 293       --------------
 294       -- Peak_Use --
 295       --------------
 296
 297       function Peak_Use return Count_Type is
 298       begin
 299          return List.Max_Length;
 300       end Peak_Use;
 301
 302    end Queue;
 303
 304 end Ada.Containers.Unbounded_Priority_Queues;