Geek Gadgets 1/ADE-1.bin/ade-dist/gnat-2.06-src.tgz/tar.out/fsf/gnat/ada/nlists.adb

Text File | 1996-09-28 | 25KB | 954 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               N L I S T S                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.13 $                             --
--                                                                          --
--        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
--                                                                          --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software  Foundation; either version 2, or (at your option) any --
-- later version.  The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
-- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
-- Library  General  Public  License for  more  details.  You  should  have --
-- received  a copy of the GNU  Library  General Public License  along with --
-- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
--                                                                          --
------------------------------------------------------------------------------

--  WARNING: There is a C version of this package. Any changes to this source
--  file must be properly reflected in the corresponding C header a-nlists.h

with Alloc;   use Alloc;
with Atree;   use Atree;
with Debug;   use Debug;
with Output;  use Output;
with Table;

package body Nlists is

   use Atree_Private_Part;
   --  Get access to Nodes table

   ----------------------------------
   -- Implementation of Node Lists --
   ----------------------------------

   --  To allow efficient access to the list, both for traversal, and for
   --  insertion of new entries at the end of the list, a list is stored
   --  using a circular format, as indicated by the following diagram:

   --    +--------+    +-------+    +-------+         +-------+
   --    |  List  |    |  1st  |    |  2nd  |         | Last  |
   --    |     ------->|   -------->|   ------>....-->|   -------+
   --    | Header |    | Entry |    | Entry |         | Entry |  |
   --    +-----|--+    +-------+    +-------+         +-------+  |
   --       ^  |                                          ^      |
   --       |  |                                          |      |
   --       |  + -----------------------------------------+      |
   --       +--- ------------------------------------------------+

   --  The list header is an entry in the Lists table. List_Id values
   --  are used to reference list headers.

   --  The First field of the list header contains Empty for a null list,
   --  or a standard Node_Id value pointing to the first item on the list.
   --  The Last field of the list header contains Empty for a null list or a
   --  standard Node_Id value pointing to the last item on the list.

   --  The nodes within the list use the Link field to hold a normal
   --  Node_Id value, which points to the next item in the list except for
   --  the last item in the list, which points to the list head and is thus
   --  a standard List_Id value referencing the containing list. This allows
   --  a quik check for the end of the list in a list traversal (check value
   --  of link for being in List_Id range), and also makes it possible to
   --  find the list containing any given node (find the end of the list by
   --  chasing Link fields, and then the Link field of this node references
   --  the list).

   --  All nodes that are elements of a list have the In_List flag set True.
   --  All nodes that are not list elements have the In_List flag set False.

   --  Note that since the Link field of a node is used both for a Parent
   --  pointer and for a forward link field in a list, that list elements
   --  cannot have direct parent pointers (and hence cannot be referenced
   --  directly from a field in another node). However, the list header
   --  itself does have a parent field.

   ------------------------
   --  List Header Table --
   ------------------------

   type List_Header is record
      First  : Union_Id;
      Last   : Union_Id;
      Parent : Node_Id;
   end record;

   package Lists is new Table (
     Table_Component_Type => List_Header,
     Table_Index_Type     => List_Id,
     Table_Low_Bound      => First_List_Id,
     Table_Initial        => Alloc_Lists_Initial,
     Table_Increment      => Alloc_Lists_Increment,
     Table_Name           => "Lists");

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Set_First (List : List_Id; Node : Node_Id);
   pragma Inline (Set_First);
   --  Used internally in the implementation of the list routines to
   --  set the first element of a list to point to a given node.

   procedure Set_Last (List : List_Id; Node : Node_Id);
   pragma Inline (Set_Last);
   --  Used internally in the implementation of the list routines to set the
   --  last element of a list to point to a given node.

   function Node_Link (Node : Node_Id) return Node_Id;
   pragma Inline (Node_Link);
   --  Used internally in the implementation of the list routines to return
   --  the contents of the Link field of a specified node as a node.

   function List_Link (Node : Node_Id) return List_Id;
   pragma Inline (List_Link);
   --  Used internally in the implementation of the list routines to return
   --  the contents of the Link field of a specified node as a list.

   procedure Set_Node_Link (Node : Node_Id; To : Node_Id);
   pragma Inline (Set_Node_Link);
   --  Used internally in the implementation of the list routines to set
   --  the Link field of a node to point to a given node.

   procedure Set_List_Link (Node : Node_Id; To : List_Id);
   pragma Inline (Set_List_Link);
   --  Used internally in the implementation of the list routines to set
   --  the Link field of a node to point to a given list.

   function Is_At_End_Of_List (Node : Node_Id) return Boolean;
   pragma Inline (Is_At_End_Of_List);
   --  Used internally in the implementation of the list routines to determine
   --  if a given node is the last element of a list. False for nodes that are
   --  not elements of lists.

   ------------
   -- Append --
   ------------

   procedure Append (Node : Node_Id; To : List_Id) is
   begin
      pragma Assert (not Is_List_Member (Node));

      if Node = Error then
         return;
      end if;

      if Debug_Flag_N then
         Write_Str ("Append node ");
         Write_Int (Int (Node));
         Write_Str (" to list ");
         Write_Int (Int (To));
         Write_Eol;
      end if;

      if Last (To) = Empty then
         Set_First (To, Node);
      else
         Set_Node_Link (Last (To), Node);
      end if;

      Set_Last (To, Node);
      Set_List_Link (Node, To);
      Nodes.Table (Node).In_List := True;
   end Append;

   ---------------
   -- Append_To --
   ---------------

   procedure Append_To (To : List_Id; Node : Node_Id) is
   begin
      Append (Node, To);
   end Append_To;

   -----------------
   -- Append_List --
   -----------------

   procedure Append_List (List : List_Id; To : List_Id) is
   begin
      if Debug_Flag_N then
         Write_Str ("Append list ");
         Write_Int (Int (List));
         Write_Str (" to list ");
         Write_Int (Int (To));
         Write_Eol;
      end if;

      if Is_Empty_List (List) then
         return;

      else
         if Is_Empty_List (To) then
            Set_First (To, First (List));
         else
            Set_Node_Link (Last (To), First (List));
         end if;

         Set_Last (To, Last (List));
         Set_List_Link (Last (List), To);

         Set_Last (List, Empty);
         Set_First (List, Empty);
      end if;
   end Append_List;

   --------------------
   -- Append_List_To --
   --------------------

   procedure Append_List_To (To : List_Id; List : List_Id) is
   begin
      Append_List (List, To);
   end Append_List_To;

   -----------
   -- First --
   -----------

   function First (List : List_Id) return Node_Id is
   begin
      pragma Assert (List in First_List_Id .. Lists.Last);
      return Node_Id (Lists.Table (List).First);
   end First;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
      E : constant List_Id := Error_List;

   begin
      Lists.Init;

      --  Allocate Error_List list header

      Lists.Increment_Last;
      Set_Parent (E, Empty);
      Set_First  (E, Empty);
      Set_Last   (E, Empty);
   end Initialize;

   ------------------
   -- Insert_After --
   ------------------

   procedure Insert_After (After : Node_Id; Node : Node_Id) is
   begin
      pragma Assert
        (Is_List_Member (After) and then not Is_List_Member (Node));

      if Node = Error then
         return;
      end if;

      if Debug_Flag_N then
         Write_Str ("Insert node");
         Write_Int (Int (Node));
         Write_Str (" after node ");
         Write_Int (Int (After));
         Write_Eol;
      end if;

      if Is_At_End_Of_List (After) then
         Set_Last (List_Containing (After), Node);
         Set_List_Link (Node, List_Link (After));
      else
         Set_Node_Link (Node, Node_Link (After));
      end if;

      Set_Node_Link (After, Node);
      Nodes.Table (Node).In_List := True;
   end Insert_After;

   -------------------
   -- Insert_Before --
   -------------------

   procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
      L : List_Id;
      N : Node_Id;

   begin
      pragma Assert (Is_List_Member (Before) and not Is_List_Member (Node));

      if Node = Error then
         return;
      end if;

      if Debug_Flag_N then
         Write_Str ("Insert node");
         Write_Int (Int (Node));
         Write_Str (" before node ");
         Write_Int (Int (Before));
         Write_Eol;
      end if;

      L := List_Containing (Before);

      if First (L) = Before then
         Set_First (L, Node);

      else
         N := First (L);

         while Node_Link (N) /= Before loop
            N := Node_Link (N);
         end loop;

         Set_Node_Link (N, Node);
      end if;

      Set_Node_Link (Node, Before);
      Nodes.Table (Node).In_List := True;
   end Insert_Before;

   -----------------------
   -- Insert_List_After --
   -----------------------

   procedure Insert_List_After (After : Node_Id; List : List_Id) is
   begin
      pragma Assert (Is_List_Member (After));

      if Debug_Flag_N then
         Write_Str ("Insert list ");
         Write_Int (Int (List));
         Write_Str (" after node ");
         Write_Int (Int (After));
         Write_Eol;
      end if;

      if Is_Empty_List (List) then
         return;

      else
         if Is_At_End_Of_List (After) then
            Set_Last (List_Containing (After), Last (List));
            Set_List_Link (Last (List), List_Link (After));
         else
            Set_Node_Link (Last (List), Node_Link (After));
         end if;

         Set_Node_Link (After, First (List));

         Set_First (List, Empty);
         Set_Last (List, Empty);
      end if;
   end Insert_List_After;

   ------------------------
   -- Insert_List_Before --
   ------------------------

   procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
      L : List_Id;
      N : Node_Id;

   begin
      pragma Assert (Is_List_Member (Before));

      if Debug_Flag_N then
         Write_Str ("Insert list ");
         Write_Int (Int (List));
         Write_Str (" before node ");
         Write_Int (Int (Before));
         Write_Eol;
      end if;

      if Is_Empty_List (List) then
         return;

      else
         L := List_Containing (Before);

         if First (L) = Before then
            Set_First (L, First (List));

         else
            N := First (L);

            while Node_Link (N) /= Before loop
               N := Node_Link (N);
            end loop;

            Set_Node_Link (N, First (List));
         end if;

         Set_Node_Link (Last (List), Before);

         Set_First (List, Empty);
         Set_Last (List, Empty);
      end if;
   end Insert_List_Before;

   -----------------------
   -- Is_At_End_Of_List --
   -----------------------

   function Is_At_End_Of_List (Node : Node_Id) return Boolean is
   begin
      pragma Assert (Is_List_Member (Node));
      return (Nodes.Table (Node).Link in List_Range);
   end Is_At_End_Of_List;

   -------------------
   -- Is_Empty_List --
   -------------------

   function Is_Empty_List (List : List_Id) return Boolean is
   begin
      return First (List) = Empty;
   end Is_Empty_List;

   --------------------
   -- Is_List_Member --
   --------------------

   function Is_List_Member (Node : Node_Id) return Boolean is
   begin
      return Nodes.Table (Node).In_List;
   end Is_List_Member;

   -----------------------
   -- Is_Non_Empty_List --
   -----------------------

   function Is_Non_Empty_List (List : List_Id) return Boolean is
   begin
      return List /= No_List and then First (List) /= Empty;
   end Is_Non_Empty_List;

   ----------
   -- Last --
   ----------

   function Last (List : List_Id) return Node_Id is
   begin
      pragma Assert (List in First_List_Id .. Lists.Last);
      return Node_Id (Lists.Table (List).Last);
   end Last;

   ------------------
   -- Last_List_Id --
   ------------------

   function Last_List_Id return List_Id is
   begin
      return Lists.Last;
   end Last_List_Id;

   ---------------------
   -- List_Containing --
   ---------------------

   function List_Containing (Node : Node_Id) return List_Id is
      N : Node_Id;

   begin
      pragma Assert (Is_List_Member (Node));
      N := Node;

      while not Is_At_End_Of_List (N) loop
         N := Node_Link (N);
      end loop;

      return List_Link (N);
   end List_Containing;

   -----------------
   -- List_Length --
   -----------------

   function List_Length (List : List_Id) return Nat is
      Result : Nat := 0;
      Node   : Node_Id;

   begin
      Node := First (List);

      while Present (Node) loop
         Result := Result + 1;
         Node := Next (Node);
      end loop;

      return Result;
   end List_Length;

   ---------------
   -- List_Link --
   ---------------

   function List_Link (Node : Node_Id) return List_Id is
   begin
      return List_Id (Nodes.Table (Node).Link);
   end List_Link;

   -------------------
   -- Lists_Address --
   -------------------

   function Lists_Address return System.Address is
   begin
      return Lists.Table (First_List_Id)'Address;
   end Lists_Address;

   --------------
   -- New_List --
   --------------

   function New_List return List_Id is

      procedure New_List_Debugging_Output;
      --  Debugging output for debug flag N

      procedure New_List_Debugging_Output is
      begin
         if Debug_Flag_N then
            Write_Str ("Allocate new list, returned ID = ");
            Write_Int (Int (Lists.Last));
            Write_Eol;
         end if;
      end New_List_Debugging_Output;

      pragma Inline (New_List_Debugging_Output);

   --  Start of processing for New_List

   begin
      Lists.Increment_Last;
      Set_Parent (Lists.Last, Empty);
      Set_First (Lists.Last, Empty);
      Set_Last (Lists.Last, Empty);
      pragma Debug (New_List_Debugging_Output);
      return (Lists.Last);
   end New_List;

   --  Since the one argument case is common, we optimize to build the right
   --  list directly, rather than first building an empty list and then doing
   --  the insertion, which results in some unnecessary work.

   function New_List (Node : Node_Id) return List_Id is
   begin
      if Node = Error then
         return New_List;
      else
         Lists.Increment_Last;
         Set_Parent (Lists.Last, Empty);
         Set_First (Lists.Last, Node);
         Set_Last (Lists.Last, Node);
         Set_List_Link (Node, Lists.Last);
         Nodes.Table (Node).In_List := True;
      end if;

      if Debug_Flag_N then
         Write_Str ("Allocate new list, returned ID = ");
         Write_Int (Int (Lists.Last));
         Write_Eol;
      end if;

      return (Lists.Last);
   end New_List;

   function New_List (Node1, Node2 : Node_Id) return List_Id is
      L : constant List_Id := New_List (Node1);

   begin
      Append (Node2, L);
      return L;
   end New_List;

   function New_List (Node1, Node2, Node3 : Node_Id) return List_Id is
      L : constant List_Id := New_List (Node1);

   begin
      Append (Node2, L);
      Append (Node3, L);
      return L;
   end New_List;

   function New_List (Node1, Node2, Node3, Node4 : Node_Id) return List_Id is
      L : constant List_Id := New_List (Node1);

   begin
      Append (Node2, L);
      Append (Node3, L);
      Append (Node4, L);
      return L;
   end New_List;

   function New_List
     (Node1 : Node_Id;
      Node2 : Node_Id;
      Node3 : Node_Id;
      Node4 : Node_Id;
      Node5 : Node_Id)
      return  List_Id
   is
      L : constant List_Id := New_List (Node1);

   begin
      Append (Node2, L);
      Append (Node3, L);
      Append (Node4, L);
      Append (Node5, L);
      return L;
   end New_List;

   function New_List
     (Node1 : Node_Id;
      Node2 : Node_Id;
      Node3 : Node_Id;
      Node4 : Node_Id;
      Node5 : Node_Id;
      Node6 : Node_Id)
      return  List_Id
   is
      L : constant List_Id := New_List (Node1);

   begin
      Append (Node2, L);
      Append (Node3, L);
      Append (Node4, L);
      Append (Node5, L);
      Append (Node6, L);
      return L;
   end New_List;

   -------------------
   -- New_List_Copy --
   -------------------

   function New_List_Copy (List : List_Id) return List_Id is
      NL : List_Id;
      E  : Node_Id;

   begin
      if List = No_List then
         return No_List;

      else
         NL := New_List;
         E := First (List);

         while Present (E) loop
            Append (New_Copy (E), NL);
            E := Next (E);
         end loop;

         return NL;
      end if;
   end New_List_Copy;

   ------------------------
   -- New_List_Copy_Tree --
   ------------------------

   function New_List_Copy_Tree (List : List_Id) return List_Id is
      NL : List_Id;
      E  : Node_Id;

   begin
      if List = No_List then
         return No_List;

      else
         NL := New_List;
         E := First (List);

         while Present (E) loop
            Append (New_Copy_Tree (E), NL);
            E := Next (E);
         end loop;

         return NL;
      end if;
   end New_List_Copy_Tree;

   ----------
   -- Next --
   ----------

   function Next (Node : Node_Id) return Node_Id is
   begin
      pragma Assert (Is_List_Member (Node));

      if Is_At_End_Of_List (Node) then
         return Empty;
      else
         return Node_Link (Node);
      end if;
   end Next;

   --------
   -- No --
   --------

   function No (List : List_Id) return Boolean is
   begin
      return List = No_List;
   end No;

   ---------------
   -- Node_Link --
   ---------------

   function Node_Link (Node : Node_Id) return Node_Id is
   begin
      return Node_Id (Nodes.Table (Node).Link);
   end Node_Link;

   ---------------
   -- Num_Lists --
   ---------------

   function Num_Lists return Nat is
   begin
      return Int (Lists.Last) - Int (Lists.First) + 1;
   end Num_Lists;

   ------------
   -- Parent --
   ------------

   function Parent (List : List_Id) return Node_Id is
   begin
      pragma Assert (List in First_List_Id .. Lists.Last);
      return Lists.Table (List).Parent;
   end Parent;

   -------------
   -- Prepend --
   -------------

   procedure Prepend (Node : Node_Id; To : List_Id) is
   begin
      if Is_Empty_List (To) then
         Append (Node, To);
      else
         Insert_Before (First (To), Node);
      end if;
   end Prepend;

   ----------------
   -- Prepend_To --
   ----------------

   procedure Prepend_To (To : List_Id; Node : Node_Id) is
   begin
      Prepend (Node, To);
   end Prepend_To;

   -------------
   -- Present --
   -------------

   function Present (List : List_Id) return Boolean is
   begin
      return List /= No_List;
   end Present;

   ----------
   -- Prev --
   ----------

   function Prev (Node : Node_Id) return Node_Id is
      P : Node_Id;

   begin
      P := First (List_Containing (Node));

      if P = Node then
         return Empty;

      else
         while Node_Link (P) /= Node loop
            P := Node_Link (P);
         end loop;

         return P;
      end if;
   end Prev;

   ------------
   -- Remove --
   ------------

   procedure Remove (Node : Node_Id) is
      L : List_Id;
      N : Node_Id;

   begin
      L := List_Containing (Node);

      if Debug_Flag_N then
         Write_Str ("Remove node ");
         Write_Int (Int (Node));
         Write_Eol;
      end if;

      if First (L) = Node then
         if Is_At_End_Of_List (Node) then
            Set_Last (L, Empty);
            Set_First (L, Empty);
         else
            Set_First (L, Node_Link (Node));
         end if;

      else
         N := First (L);

         while Node_Link (N) /= Node loop
            N := Node_Link (N);
         end loop;

         if Is_At_End_Of_List (Node) then
            Set_Last (L, N);
            Set_List_Link (N, List_Link (Node));
         else
            Set_Node_Link (N, Node_Link (Node));
         end if;
      end if;

      Set_Node_Link (Node, Empty);
      Nodes.Table (Node).In_List := False;
   end Remove;

   -----------------
   -- Remove_Head --
   -----------------

   function Remove_Head (List : List_Id) return Node_Id is
      N : Node_Id;

   begin
      if Debug_Flag_N then
         Write_Str ("Remove head of list ");
         Write_Int (Int (List));
         Write_Eol;
      end if;

      N := First (List);

      if N = Empty then
         return Empty;

      else
         if Is_At_End_Of_List (N) then
            Set_Last  (List, Empty);
            Set_First (List, Empty);
         else
            Set_First (List, Node_Link (N));
         end if;

         Set_Node_Link (N, Empty);
         Nodes.Table (N).In_List := False;
         return N;
      end if;
   end Remove_Head;

   -----------------
   -- Remove_Next --
   -----------------

   function Remove_Next (Node : Node_Id) return Node_Id is
      Nxt : constant Node_Id := Next (Node);

   begin
      if Nxt /= Empty then
         Nodes.Table (Node).Link := Nodes.Table (Nxt).Link;
         Set_Node_Link (Nxt, Empty);
         Nodes.Table (Nxt).In_List := False;
      end if;

      return Nxt;
   end Remove_Next;

   ---------------
   -- Set_First --
   ---------------

   procedure Set_First (List : List_Id; Node : Node_Id) is
   begin
      pragma Assert (List in First_List_Id .. Lists.Last);
      Lists.Table (List).First := Union_Id (Node);
   end Set_First;

   --------------
   -- Set_Last --
   --------------

   procedure Set_Last (List : List_Id; Node : Node_Id) is
   begin
      pragma Assert (List in First_List_Id .. Lists.Last);
      Lists.Table (List).Last := Union_Id (Node);
   end Set_Last;

   -------------------
   -- Set_List_Link --
   -------------------

   procedure Set_List_Link (Node : Node_Id; To : List_Id) is
   begin
      Nodes.Table (Node).Link := Union_Id (To);
   end Set_List_Link;

   -------------------
   -- Set_Node_Link --
   -------------------

   procedure Set_Node_Link (Node : Node_Id; To : Node_Id) is
   begin
      Nodes.Table (Node).Link := Union_Id (To);
   end Set_Node_Link;

   ----------------
   -- Set_Parent --
   ----------------

   procedure Set_Parent (List : List_Id; Node : Node_Id) is
   begin
      pragma Assert (List in First_List_Id .. Lists.Last);
      Lists.Table (List).Parent := Node;
   end Set_Parent;

   ---------------
   -- Tree_Read --
   ---------------

   procedure Tree_Read is
   begin
      Lists.Tree_Read;
   end Tree_Read;

   ----------------
   -- Tree_Write --
   ----------------

   procedure Tree_Write is
   begin
      Lists.Tree_Write;
   end Tree_Write;

end Nlists;