URL https://opencores.org/ocsvn/scarts/scarts/trunk
Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [nlists.adb] - Blame information for rev 16

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               N L I S T S                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
--  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;
with Atree;  use Atree;
with Debug;  use Debug;
with Output; use Output;
with Sinfo;  use Sinfo;
with Table;
 
package body Nlists is
 
   use Atree_Private_Part;
   --  Get access to Nodes table
 
   ----------------------------------
   -- Implementation of Node Lists --
   ----------------------------------
 
   --  A node list is represented by a list header which contains
   --  three fields:
 
   type List_Header is record
      First : Node_Id;
      --  Pointer to first node in list. Empty if list is empty
 
      Last  : Node_Id;
      --  Pointer to last node in list. Empty if list is empty
 
      Parent : Node_Id;
      --  Pointer to parent of list. Empty if list has no parent
   end record;
 
   --  The node lists are stored in a table indexed by List_Id values
 
   package Lists is new Table.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");
 
   --  The nodes in the list all have the In_List flag set, and their Link
   --  fields (which otherwise point to the parent) contain the List_Id of
   --  the list header giving immediate access to the list containing the
   --  node, and its parent and first and last elements.
 
   --  Two auxiliary tables, indexed by Node_Id values and built in parallel
   --  with the main nodes table and always having the same size contain the
   --  list link values that allow locating the previous and next node in a
   --  list. The entries in these tables are valid only if the In_List flag
   --  is set in the corresponding node. Next_Node is Empty at the end of a
   --  list and Prev_Node is Empty at the start of a list.
 
   package Next_Node is new Table.Table (
      Table_Component_Type => Node_Id,
      Table_Index_Type     => Node_Id,
      Table_Low_Bound      => First_Node_Id,
      Table_Initial        => Alloc.Orig_Nodes_Initial,
      Table_Increment      => Alloc.Orig_Nodes_Increment,
      Table_Name           => "Next_Node");
 
   package Prev_Node is new Table.Table (
      Table_Component_Type => Node_Id,
      Table_Index_Type     => Node_Id,
      Table_Low_Bound      => First_Node_Id,
      Table_Initial        => Alloc.Orig_Nodes_Initial,
      Table_Increment      => Alloc.Orig_Nodes_Increment,
      Table_Name           => "Prev_Node");
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   procedure Set_First (List : List_Id; To : Node_Id);
   pragma Inline (Set_First);
   --  Sets First field of list header List to reference To
 
   procedure Set_Last (List : List_Id; To : Node_Id);
   pragma Inline (Set_Last);
   --  Sets Last field of list header List to reference To
 
   procedure Set_List_Link (Node : Node_Id; To : List_Id);
   pragma Inline (Set_List_Link);
   --  Sets list link of Node to list header To
 
   procedure Set_Next (Node : Node_Id; To : Node_Id);
   pragma Inline (Set_Next);
   --  Sets the Next_Node pointer for Node to reference To
 
   procedure Set_Prev (Node : Node_Id; To : Node_Id);
   pragma Inline (Set_Prev);
   --  Sets the Prev_Node pointer for Node to reference To
 
   --------------------------
   -- Allocate_List_Tables --
   --------------------------
 
   procedure Allocate_List_Tables (N : Node_Id) is
   begin
      Next_Node.Set_Last (N);
      Prev_Node.Set_Last (N);
   end Allocate_List_Tables;
 
   ------------
   -- Append --
   ------------
 
   procedure Append (Node : Node_Id; To : List_Id) is
      L : constant Node_Id := Last (To);
 
      procedure Append_Debug;
      pragma Inline (Append_Debug);
      --  Output debug information if Debug_Flag_N set
 
      ------------------
      -- Append_Debug --
      ------------------
 
      procedure Append_Debug is
      begin
         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;
      end Append_Debug;
 
   --  Start of processing for Append
 
   begin
      pragma Assert (not Is_List_Member (Node));
 
      if Node = Error then
         return;
      end if;
 
      pragma Debug (Append_Debug);
 
      if No (L) then
         Set_First (To, Node);
      else
         Set_Next (L, Node);
      end if;
 
      Set_Last (To, Node);
 
      Nodes.Table (Node).In_List := True;
 
      Set_Next      (Node, Empty);
      Set_Prev      (Node, L);
      Set_List_Link (Node, To);
   end Append;
 
   -----------------
   -- Append_List --
   -----------------
 
   procedure Append_List (List : List_Id; To : List_Id) is
 
      procedure Append_List_Debug;
      pragma Inline (Append_List_Debug);
      --  Output debug information if Debug_Flag_N set
 
      -----------------------
      -- Append_List_Debug --
      -----------------------
 
      procedure Append_List_Debug 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;
      end Append_List_Debug;
 
   --  Start of processing for Append_List
 
   begin
      if Is_Empty_List (List) then
         return;
 
      else
         declare
            L : constant Node_Id := Last (To);
            F : constant Node_Id := First (List);
            N : Node_Id;
 
         begin
            pragma Debug (Append_List_Debug);
 
            N := F;
            loop
               Set_List_Link (N, To);
               N := Next (N);
               exit when No (N);
            end loop;
 
            if No (L) then
               Set_First (To, F);
            else
               Set_Next (L, F);
            end if;
 
            Set_Prev (F, L);
            Set_Last (To, Last (List));
 
            Set_First (List, Empty);
            Set_Last  (List, Empty);
         end;
      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;
 
   ---------------
   -- Append_To --
   ---------------
 
   procedure Append_To (To : List_Id; Node : Node_Id) is
   begin
      Append (Node, To);
   end Append_To;
 
   -----------------
   -- Delete_List --
   -----------------
 
   procedure Delete_List (L : List_Id) is
      N : Node_Id;
 
   begin
      while Is_Non_Empty_List (L) loop
         N := Remove_Head (L);
         Delete_Tree (N);
      end loop;
 
      --  Should recycle list header???
   end Delete_List;
 
   -----------
   -- First --
   -----------
 
   function First (List : List_Id) return Node_Id is
   begin
      if List = No_List then
         return Empty;
      else
         pragma Assert (List in First_List_Id .. Lists.Last);
         return Lists.Table (List).First;
      end if;
   end First;
 
   ----------------------
   -- First_Non_Pragma --
   ----------------------
 
   function First_Non_Pragma (List : List_Id) return Node_Id is
      N : constant Node_Id := First (List);
 
   begin
      if Nkind (N) /= N_Pragma
           and then
         Nkind (N) /= N_Null_Statement
      then
         return N;
      else
         return Next_Non_Pragma (N);
      end if;
   end First_Non_Pragma;
 
   ----------------
   -- Initialize --
   ----------------
 
   procedure Initialize is
      E : constant List_Id := Error_List;
 
   begin
      Lists.Init;
      Next_Node.Init;
      Prev_Node.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
 
      procedure Insert_After_Debug;
      pragma Inline (Insert_After_Debug);
      --  Output debug information if Debug_Flag_N set
 
      ------------------------
      -- Insert_After_Debug --
      ------------------------
 
      procedure Insert_After_Debug is
      begin
         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;
      end Insert_After_Debug;
 
   --  Start of processing for Insert_After
 
   begin
      pragma Assert
        (Is_List_Member (After) and then not Is_List_Member (Node));
 
      if Node = Error then
         return;
      end if;
 
      pragma Debug (Insert_After_Debug);
 
      declare
         Before : constant Node_Id := Next (After);
         LC     : constant List_Id := List_Containing (After);
 
      begin
         if Present (Before) then
            Set_Prev (Before, Node);
         else
            Set_Last (LC, Node);
         end if;
 
         Set_Next (After, Node);
 
         Nodes.Table (Node).In_List := True;
 
         Set_Prev      (Node, After);
         Set_Next      (Node, Before);
         Set_List_Link (Node, LC);
      end;
   end Insert_After;
 
   -------------------
   -- Insert_Before --
   -------------------
 
   procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
 
      procedure Insert_Before_Debug;
      pragma Inline (Insert_Before_Debug);
      --  Output debug information if Debug_Flag_N set
 
      -------------------------
      -- Insert_Before_Debug --
      -------------------------
 
      procedure Insert_Before_Debug is
      begin
         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;
      end Insert_Before_Debug;
 
   --  Start of processing for Insert_Before
 
   begin
      pragma Assert
        (Is_List_Member (Before) and then not Is_List_Member (Node));
 
      if Node = Error then
         return;
      end if;
 
      pragma Debug (Insert_Before_Debug);
 
      declare
         After : constant Node_Id := Prev (Before);
         LC    : constant List_Id := List_Containing (Before);
 
      begin
         if Present (After) then
            Set_Next (After, Node);
         else
            Set_First (LC, Node);
         end if;
 
         Set_Prev (Before, Node);
 
         Nodes.Table (Node).In_List := True;
 
         Set_Prev      (Node, After);
         Set_Next      (Node, Before);
         Set_List_Link (Node, LC);
      end;
   end Insert_Before;
 
   -----------------------
   -- Insert_List_After --
   -----------------------
 
   procedure Insert_List_After (After : Node_Id; List : List_Id) is
 
      procedure Insert_List_After_Debug;
      pragma Inline (Insert_List_After_Debug);
      --  Output debug information if Debug_Flag_N set
 
      -----------------------------
      -- Insert_List_After_Debug --
      -----------------------------
 
      procedure Insert_List_After_Debug is
      begin
         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;
      end Insert_List_After_Debug;
 
   --  Start of processing for Insert_List_After
 
   begin
      pragma Assert (Is_List_Member (After));
 
      if Is_Empty_List (List) then
         return;
 
      else
         declare
            Before : constant Node_Id := Next (After);
            LC     : constant List_Id := List_Containing (After);
            F      : constant Node_Id := First (List);
            L      : constant Node_Id := Last (List);
            N      : Node_Id;
 
         begin
            pragma Debug (Insert_List_After_Debug);
 
            N := F;
            loop
               Set_List_Link (N, LC);
               exit when N = L;
               N := Next (N);
            end loop;
 
            if Present (Before) then
               Set_Prev (Before, L);
            else
               Set_Last (LC, L);
            end if;
 
            Set_Next (After, F);
            Set_Prev (F, After);
            Set_Next (L, Before);
 
            Set_First (List, Empty);
            Set_Last  (List, Empty);
         end;
      end if;
   end Insert_List_After;
 
   ------------------------
   -- Insert_List_Before --
   ------------------------
 
   procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
 
      procedure Insert_List_Before_Debug;
      pragma Inline (Insert_List_Before_Debug);
      --  Output debug information if Debug_Flag_N set
 
      ------------------------------
      -- Insert_List_Before_Debug --
      ------------------------------
 
      procedure Insert_List_Before_Debug is
      begin
         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;
      end Insert_List_Before_Debug;
 
   --  Start of prodcessing for Insert_List_Before
 
   begin
      pragma Assert (Is_List_Member (Before));
 
      if Is_Empty_List (List) then
         return;
 
      else
         declare
            After : constant Node_Id := Prev (Before);
            LC    : constant List_Id := List_Containing (Before);
            F     : constant Node_Id := First (List);
            L     : constant Node_Id := Last (List);
            N     : Node_Id;
 
         begin
            pragma Debug (Insert_List_Before_Debug);
 
            N := F;
            loop
               Set_List_Link (N, LC);
               exit when N = L;
               N := Next (N);
            end loop;
 
            if Present (After) then
               Set_Next (After, F);
            else
               Set_First (LC, F);
            end if;
 
            Set_Prev (Before, L);
            Set_Prev (F, After);
            Set_Next (L, Before);
 
            Set_First (List, Empty);
            Set_Last  (List, Empty);
         end;
      end if;
   end Insert_List_Before;
 
   -------------------
   -- 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 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;
 
   ---------------------
   -- Last_Non_Pragma --
   ---------------------
 
   function Last_Non_Pragma (List : List_Id) return Node_Id is
      N : constant Node_Id := Last (List);
 
   begin
      if Nkind (N) /= N_Pragma then
         return N;
      else
         return Prev_Non_Pragma (N);
      end if;
   end Last_Non_Pragma;
 
   ---------------------
   -- List_Containing --
   ---------------------
 
   function List_Containing (Node : Node_Id) return List_Id is
   begin
      pragma Assert (Is_List_Member (Node));
      return List_Id (Nodes.Table (Node).Link);
   end List_Containing;
 
   -----------------
   -- List_Length --
   -----------------
 
   function List_Length (List : List_Id) return Nat is
      Result : Nat;
      Node   : Node_Id;
 
   begin
      Result := 0;
      Node := First (List);
      while Present (Node) loop
         Result := Result + 1;
         Node := Next (Node);
      end loop;
 
      return Result;
   end List_Length;
 
   -------------------
   -- Lists_Address --
   -------------------
 
   function Lists_Address return System.Address is
   begin
      return Lists.Table (First_List_Id)'Address;
   end Lists_Address;
 
   ----------
   -- Lock --
   ----------
 
   procedure Lock is
   begin
      Lists.Locked := True;
      Lists.Release;
 
      Prev_Node.Locked := True;
      Next_Node.Locked := True;
 
      Prev_Node.Release;
      Next_Node.Release;
   end Lock;
 
   -------------------
   -- New_Copy_List --
   -------------------
 
   function New_Copy_List (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_Copy_List;
 
   ----------------------------
   -- New_Copy_List_Original --
   ----------------------------
 
   function New_Copy_List_Original (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
            if Comes_From_Source (E) then
               Append (New_Copy (E), NL);
            end if;
 
            E := Next (E);
         end loop;
 
         return NL;
      end if;
   end New_Copy_List_Original;
 
   ------------------------
   -- New_Copy_List_Tree --
   ------------------------
 
   function New_Copy_List_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_Copy_List_Tree;
 
   --------------
   -- New_List --
   --------------
 
   function New_List return List_Id is
 
      procedure New_List_Debug;
      pragma Inline (New_List_Debug);
      --  Output debugging information if Debug_Flag_N is set
 
      --------------------
      -- New_List_Debug --
      --------------------
 
      procedure New_List_Debug 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_Debug;
 
   --  Start of processing for New_List
 
   begin
      Lists.Increment_Last;
 
      declare
         List : constant List_Id := Lists.Last;
 
      begin
         Set_Parent (List, Empty);
         Set_First  (List, Empty);
         Set_Last   (List, Empty);
 
         pragma Debug (New_List_Debug);
         return (List);
      end;
   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
 
      procedure New_List_Debug;
      pragma Inline (New_List_Debug);
      --  Output debugging information if Debug_Flag_N is set
 
      --------------------
      -- New_List_Debug --
      --------------------
 
      procedure New_List_Debug 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_Debug;
 
   --  Start of processing for New_List
 
   begin
      if Node = Error then
         return New_List;
 
      else
         pragma Assert (not Is_List_Member (Node));
 
         Lists.Increment_Last;
 
         declare
            List : constant List_Id := Lists.Last;
 
         begin
            Set_Parent (List, Empty);
            Set_First  (List, Node);
            Set_Last   (List, Node);
 
            Nodes.Table (Node).In_List := True;
            Set_List_Link (Node, List);
            Set_Prev (Node, Empty);
            Set_Next (Node, Empty);
            pragma Debug (New_List_Debug);
            return List;
         end;
      end if;
   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;
 
   ----------
   -- Next --
   ----------
 
   function Next (Node : Node_Id) return Node_Id is
   begin
      pragma Assert (Is_List_Member (Node));
      return Next_Node.Table (Node);
   end Next;
 
   procedure Next (Node : in out Node_Id) is
   begin
      Node := Next (Node);
   end Next;
 
   -----------------------
   -- Next_Node_Address --
   -----------------------
 
   function Next_Node_Address return System.Address is
   begin
      return Next_Node.Table (First_Node_Id)'Address;
   end Next_Node_Address;
 
   ---------------------
   -- Next_Non_Pragma --
   ---------------------
 
   function Next_Non_Pragma (Node : Node_Id) return Node_Id is
      N : Node_Id;
 
   begin
      N := Node;
      loop
         N := Next (N);
         exit when Nkind (N) /= N_Pragma
                     and then
                   Nkind (N) /= N_Null_Statement;
      end loop;
 
      return N;
   end Next_Non_Pragma;
 
   procedure Next_Non_Pragma (Node : in out Node_Id) is
   begin
      Node := Next_Non_Pragma (Node);
   end Next_Non_Pragma;
 
   --------
   -- No --
   --------
 
   function No (List : List_Id) return Boolean is
   begin
      return List = No_List;
   end No;
 
   ---------------
   -- Num_Lists --
   ---------------
 
   function Num_Lists return Nat is
   begin
      return Int (Lists.Last) - Int (Lists.First) + 1;
   end Num_Lists;
 
   -------
   -- p --
   -------
 
   function p (U : Union_Id) return Node_Id is
   begin
      if U in Node_Range then
         return Parent (Node_Id (U));
      elsif U in List_Range then
         return Parent (List_Id (U));
      else
         return 99_999_999;
      end if;
   end p;
 
   ------------
   -- 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;
 
   ----------
   -- Pick --
   ----------
 
   function Pick (List : List_Id; Index : Pos) return Node_Id is
      Elmt : Node_Id;
 
   begin
      Elmt := First (List);
      for J in 1 .. Index - 1 loop
         Elmt := Next (Elmt);
      end loop;
 
      return Elmt;
   end Pick;
 
   -------------
   -- Prepend --
   -------------
 
   procedure Prepend (Node : Node_Id; To : List_Id) is
      F : constant Node_Id := First (To);
 
      procedure Prepend_Debug;
      pragma Inline (Prepend_Debug);
      --  Output debug information if Debug_Flag_N set
 
      -------------------
      -- Prepend_Debug --
      -------------------
 
      procedure Prepend_Debug is
      begin
         if Debug_Flag_N then
            Write_Str ("Prepend node ");
            Write_Int (Int (Node));
            Write_Str (" to list ");
            Write_Int (Int (To));
            Write_Eol;
         end if;
      end Prepend_Debug;
 
   --  Start of processing for Prepend_Debug
 
   begin
      pragma Assert (not Is_List_Member (Node));
 
      if Node = Error then
         return;
      end if;
 
      pragma Debug (Prepend_Debug);
 
      if No (F) then
         Set_Last (To, Node);
      else
         Set_Prev (F, Node);
      end if;
 
      Set_First (To, Node);
 
      Nodes.Table (Node).In_List := True;
 
      Set_Next      (Node, F);
      Set_Prev      (Node, Empty);
      Set_List_Link (Node, To);
   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
   begin
      pragma Assert (Is_List_Member (Node));
      return Prev_Node.Table (Node);
   end Prev;
 
   procedure Prev (Node : in out Node_Id) is
   begin
      Node := Prev (Node);
   end Prev;
 
   -----------------------
   -- Prev_Node_Address --
   -----------------------
 
   function Prev_Node_Address return System.Address is
   begin
      return Prev_Node.Table (First_Node_Id)'Address;
   end Prev_Node_Address;
 
   ---------------------
   -- Prev_Non_Pragma --
   ---------------------
 
   function Prev_Non_Pragma (Node : Node_Id) return Node_Id is
      N : Node_Id;
 
   begin
      N := Node;
      loop
         N := Prev (N);
         exit when Nkind (N) /= N_Pragma;
      end loop;
 
      return N;
   end Prev_Non_Pragma;
 
   procedure Prev_Non_Pragma (Node : in out Node_Id) is
   begin
      Node := Prev_Non_Pragma (Node);
   end Prev_Non_Pragma;
 
   ------------
   -- Remove --
   ------------
 
   procedure Remove (Node : Node_Id) is
      Lst : constant List_Id := List_Containing (Node);
      Prv : constant Node_Id := Prev (Node);
      Nxt : constant Node_Id := Next (Node);
 
      procedure Remove_Debug;
      pragma Inline (Remove_Debug);
      --  Output debug information if Debug_Flag_N set
 
      ------------------
      -- Remove_Debug --
      ------------------
 
      procedure Remove_Debug is
      begin
         if Debug_Flag_N then
            Write_Str ("Remove node ");
            Write_Int (Int (Node));
            Write_Eol;
         end if;
      end Remove_Debug;
 
   --  Start of processing for Remove
 
   begin
      pragma Debug (Remove_Debug);
 
      if No (Prv) then
         Set_First (Lst, Nxt);
      else
         Set_Next (Prv, Nxt);
      end if;
 
      if No (Nxt) then
         Set_Last (Lst, Prv);
      else
         Set_Prev (Nxt, Prv);
      end if;
 
      Nodes.Table (Node).In_List := False;
      Set_Parent (Node, Empty);
   end Remove;
 
   -----------------
   -- Remove_Head --
   -----------------
 
   function Remove_Head (List : List_Id) return Node_Id is
      Frst : constant Node_Id := First (List);
 
      procedure Remove_Head_Debug;
      pragma Inline (Remove_Head_Debug);
      --  Output debug information if Debug_Flag_N set
 
      -----------------------
      -- Remove_Head_Debug --
      -----------------------
 
      procedure Remove_Head_Debug is
      begin
         if Debug_Flag_N then
            Write_Str ("Remove head of list ");
            Write_Int (Int (List));
            Write_Eol;
         end if;
      end Remove_Head_Debug;
 
   --  Start of processing for Remove_Head
 
   begin
      pragma Debug (Remove_Head_Debug);
 
      if Frst = Empty then
         return Empty;
 
      else
         declare
            Nxt : constant Node_Id := Next (Frst);
 
         begin
            Set_First (List, Nxt);
 
            if No (Nxt) then
               Set_Last (List, Empty);
            else
               Set_Prev (Nxt, Empty);
            end if;
 
            Nodes.Table (Frst).In_List := False;
            Set_Parent (Frst, Empty);
            return Frst;
         end;
      end if;
   end Remove_Head;
 
   -----------------
   -- Remove_Next --
   -----------------
 
   function Remove_Next (Node : Node_Id) return Node_Id is
      Nxt : constant Node_Id := Next (Node);
 
      procedure Remove_Next_Debug;
      pragma Inline (Remove_Next_Debug);
      --  Output debug information if Debug_Flag_N set
 
      -----------------------
      -- Remove_Next_Debug --
      -----------------------
 
      procedure Remove_Next_Debug is
      begin
         if Debug_Flag_N then
            Write_Str ("Remove next node after ");
            Write_Int (Int (Node));
            Write_Eol;
         end if;
      end Remove_Next_Debug;
 
   --  Start of processing for Remove_Next
 
   begin
      if Present (Nxt) then
         declare
            Nxt2 : constant Node_Id := Next (Nxt);
            LC   : constant List_Id := List_Containing (Node);
 
         begin
            pragma Debug (Remove_Next_Debug);
            Set_Next (Node, Nxt2);
 
            if No (Nxt2) then
               Set_Last (LC, Node);
            else
               Set_Prev (Nxt2, Node);
            end if;
 
            Nodes.Table (Nxt).In_List := False;
            Set_Parent (Nxt, Empty);
         end;
      end if;
 
      return Nxt;
   end Remove_Next;
 
   ---------------
   -- Set_First --
   ---------------
 
   procedure Set_First (List : List_Id; To : Node_Id) is
   begin
      Lists.Table (List).First := To;
   end Set_First;
 
   --------------
   -- Set_Last --
   --------------
 
   procedure Set_Last (List : List_Id; To : Node_Id) is
   begin
      Lists.Table (List).Last := To;
   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_Next --
   --------------
 
   procedure Set_Next (Node : Node_Id; To : Node_Id) is
   begin
      Next_Node.Table (Node) := To;
   end Set_Next;
 
   ----------------
   -- 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;
 
   --------------
   -- Set_Prev --
   --------------
 
   procedure Set_Prev (Node : Node_Id; To : Node_Id) is
   begin
      Prev_Node.Table (Node) := To;
   end Set_Prev;
 
   ---------------
   -- Tree_Read --
   ---------------
 
   procedure Tree_Read is
   begin
      Lists.Tree_Read;
      Next_Node.Tree_Read;
      Prev_Node.Tree_Read;
   end Tree_Read;
 
   ----------------
   -- Tree_Write --
   ----------------
 
   procedure Tree_Write is
   begin
      Lists.Tree_Write;
      Next_Node.Tree_Write;
      Prev_Node.Tree_Write;
   end Tree_Write;
 
end Nlists;
Browse

Tools

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [nlists.adb] - Blame information for rev 16

Line No.	Rev	Author	Line
1	12	jlechner	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- N L I S T S --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2005, 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 2, 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. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING. If not, write --`
19			`-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --`
20			`-- Boston, MA 02110-1301, USA. --`
21			`-- --`
22			`-- As a special exception, if other files instantiate generics from this --`
23			`-- unit, or you link this unit with other files to produce an executable, --`
24			`-- this unit does not by itself cause the resulting executable to be --`
25			`-- covered by the GNU General Public License. This exception does not --`
26			`-- however invalidate any other reasons why the executable file might be --`
27			`-- covered by the GNU Public License. --`
28			`-- --`
29			`-- GNAT was originally developed by the GNAT team at New York University. --`
30			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
31			`-- --`
32			`------------------------------------------------------------------------------`
33
34			`-- WARNING: There is a C version of this package. Any changes to this source`
35			`-- file must be properly reflected in the corresponding C header a-nlists.h`
36
37			`with Alloc;`
38			`with Atree; use Atree;`
39			`with Debug; use Debug;`
40			`with Output; use Output;`