From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/nlists.adb | 1459 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1459 insertions(+) create mode 100644 gcc/ada/nlists.adb (limited to 'gcc/ada/nlists.adb') diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb new file mode 100644 index 000000000..453e665ec --- /dev/null +++ b/gcc/ada/nlists.adb @@ -0,0 +1,1459 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- N L I S T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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_Or_Entity_Id; + -- Pointer to first node in list. Empty if list is empty + + Last : Node_Or_Entity_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'Base, + 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_Or_Entity_Id, + Table_Index_Type => Node_Or_Entity_Id'Base, + 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_Or_Entity_Id, + Table_Index_Type => Node_Or_Entity_Id'Base, + 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_Or_Entity_Id); + pragma Inline (Set_First); + -- Sets First field of list header List to reference To + + procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id); + pragma Inline (Set_Last); + -- Sets Last field of list header List to reference To + + procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id); + pragma Inline (Set_List_Link); + -- Sets list link of Node to list header To + + procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id); + pragma Inline (Set_Next); + -- Sets the Next_Node pointer for Node to reference To + + procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id); + pragma Inline (Set_Prev); + -- Sets the Prev_Node pointer for Node to reference To + + -------------------------- + -- Allocate_List_Tables -- + -------------------------- + + procedure Allocate_List_Tables (N : Node_Or_Entity_Id) is + Old_Last : constant Node_Or_Entity_Id'Base := Next_Node.Last; + + begin + pragma Assert (N >= Old_Last); + Next_Node.Set_Last (N); + Prev_Node.Set_Last (N); + + -- Make sure we have no uninitialized junk in any new entires added. + -- This ensures that Tree_Gen will not write out any uninitialized junk. + + for J in Old_Last + 1 .. N loop + Next_Node.Table (J) := Empty; + Prev_Node.Table (J) := Empty; + end loop; + end Allocate_List_Tables; + + ------------ + -- Append -- + ------------ + + procedure Append (Node : Node_Or_Entity_Id; To : List_Id) is + L : constant Node_Or_Entity_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_Or_Entity_Id := Last (To); + F : constant Node_Or_Entity_Id := First (List); + N : Node_Or_Entity_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_Or_Entity_Id) is + begin + Append (Node, To); + end Append_To; + + ----------- + -- First -- + ----------- + + function First (List : List_Id) return Node_Or_Entity_Id is + begin + if List = No_List then + return Empty; + else + pragma Assert (List <= Lists.Last); + return Lists.Table (List).First; + end if; + end First; + + ---------------------- + -- First_Non_Pragma -- + ---------------------- + + function First_Non_Pragma (List : List_Id) return Node_Or_Entity_Id is + N : constant Node_Or_Entity_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; + + ------------------ + -- In_Same_List -- + ------------------ + + function In_Same_List (N1, N2 : Node_Or_Entity_Id) return Boolean is + begin + return List_Containing (N1) = List_Containing (N2); + end In_Same_List; + + ------------------ + -- Insert_After -- + ------------------ + + procedure Insert_After + (After : Node_Or_Entity_Id; + Node : Node_Or_Entity_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_Or_Entity_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_Or_Entity_Id; + Node : Node_Or_Entity_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_Or_Entity_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_Or_Entity_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_Or_Entity_Id := Next (After); + LC : constant List_Id := List_Containing (After); + F : constant Node_Or_Entity_Id := First (List); + L : constant Node_Or_Entity_Id := Last (List); + N : Node_Or_Entity_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_Or_Entity_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 processing for Insert_List_Before + + begin + pragma Assert (Is_List_Member (Before)); + + if Is_Empty_List (List) then + return; + + else + declare + After : constant Node_Or_Entity_Id := Prev (Before); + LC : constant List_Id := List_Containing (Before); + F : constant Node_Or_Entity_Id := First (List); + L : constant Node_Or_Entity_Id := Last (List); + N : Node_Or_Entity_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_Or_Entity_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 First (List) /= Empty; + end Is_Non_Empty_List; + + ---------- + -- Last -- + ---------- + + function Last (List : List_Id) return Node_Or_Entity_Id is + begin + pragma Assert (List <= 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_Or_Entity_Id is + N : constant Node_Or_Entity_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_Or_Entity_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_Or_Entity_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_Or_Entity_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_Or_Entity_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_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_Or_Entity_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 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_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 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_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 : Node_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_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_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_Id; + Node5 : Node_Or_Entity_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_Or_Entity_Id; + Node2 : Node_Or_Entity_Id; + Node3 : Node_Or_Entity_Id; + Node4 : Node_Or_Entity_Id; + Node5 : Node_Or_Entity_Id; + Node6 : Node_Or_Entity_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_Or_Entity_Id) return Node_Or_Entity_Id is + begin + pragma Assert (Is_List_Member (Node)); + return Next_Node.Table (Node); + end Next; + + procedure Next (Node : in out Node_Or_Entity_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_Or_Entity_Id) return Node_Or_Entity_Id + is + N : Node_Or_Entity_Id; + + begin + N := Node; + loop + N := Next (N); + exit when not Nkind_In (N, N_Pragma, N_Null_Statement); + end loop; + + return N; + end Next_Non_Pragma; + + procedure Next_Non_Pragma (Node : in out Node_Or_Entity_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_Or_Entity_Id is + begin + if U in Node_Range then + return Parent (Node_Or_Entity_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_Or_Entity_Id is + begin + pragma Assert (List <= Lists.Last); + return Lists.Table (List).Parent; + end Parent; + + ---------- + -- Pick -- + ---------- + + function Pick (List : List_Id; Index : Pos) return Node_Or_Entity_Id is + Elmt : Node_Or_Entity_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_Or_Entity_Id; To : List_Id) is + F : constant Node_Or_Entity_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_List -- + ------------------ + + procedure Prepend_List (List : List_Id; To : List_Id) is + + procedure Prepend_List_Debug; + pragma Inline (Prepend_List_Debug); + -- Output debug information if Debug_Flag_N set + + ------------------------ + -- Prepend_List_Debug -- + ------------------------ + + procedure Prepend_List_Debug is + begin + if Debug_Flag_N then + Write_Str ("Prepend list "); + Write_Int (Int (List)); + Write_Str (" to list "); + Write_Int (Int (To)); + Write_Eol; + end if; + end Prepend_List_Debug; + + -- Start of processing for Prepend_List + + begin + if Is_Empty_List (List) then + return; + + else + declare + F : constant Node_Or_Entity_Id := First (To); + L : constant Node_Or_Entity_Id := Last (List); + N : Node_Or_Entity_Id; + + begin + pragma Debug (Prepend_List_Debug); + + N := L; + loop + Set_List_Link (N, To); + N := Prev (N); + exit when No (N); + end loop; + + if No (F) then + Set_Last (To, L); + else + Set_Next (L, F); + end if; + + Set_Prev (F, L); + Set_First (To, First (List)); + + Set_First (List, Empty); + Set_Last (List, Empty); + end; + end if; + end Prepend_List; + + --------------------- + -- Prepend_List_To -- + --------------------- + + procedure Prepend_List_To (To : List_Id; List : List_Id) is + begin + Prepend_List (List, To); + end Prepend_List_To; + + ---------------- + -- Prepend_To -- + ---------------- + + procedure Prepend_To (To : List_Id; Node : Node_Or_Entity_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_Or_Entity_Id) return Node_Or_Entity_Id is + begin + pragma Assert (Is_List_Member (Node)); + return Prev_Node.Table (Node); + end Prev; + + procedure Prev (Node : in out Node_Or_Entity_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_Or_Entity_Id) return Node_Or_Entity_Id + is + N : Node_Or_Entity_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_Or_Entity_Id) is + begin + Node := Prev_Non_Pragma (Node); + end Prev_Non_Pragma; + + ------------ + -- Remove -- + ------------ + + procedure Remove (Node : Node_Or_Entity_Id) is + Lst : constant List_Id := List_Containing (Node); + Prv : constant Node_Or_Entity_Id := Prev (Node); + Nxt : constant Node_Or_Entity_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_Or_Entity_Id is + Frst : constant Node_Or_Entity_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_Or_Entity_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_Or_Entity_Id) return Node_Or_Entity_Id + is + Nxt : constant Node_Or_Entity_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_Or_Entity_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_Or_Entity_Id) is + begin + Lists.Table (List).First := To; + end Set_First; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is + begin + Lists.Table (List).Last := To; + end Set_Last; + + ------------------- + -- Set_List_Link -- + ------------------- + + procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is + begin + Nodes.Table (Node).Link := Union_Id (To); + end Set_List_Link; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is + begin + Next_Node.Table (Node) := To; + end Set_Next; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is + begin + pragma Assert (List <= Lists.Last); + Lists.Table (List).Parent := Node; + end Set_Parent; + + -------------- + -- Set_Prev -- + -------------- + + procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_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; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + Lists.Locked := False; + Prev_Node.Locked := False; + Next_Node.Locked := False; + end Unlock; + +end Nlists; -- cgit v1.2.3