1486 lines
37 KiB
Ada
1486 lines
37 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- N L I S T S --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2020, 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. 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 COPYING3. If not, go to --
|
|
-- http://www.gnu.org/licenses for a complete copy of the 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
|
|
Locked : Boolean := False;
|
|
-- Compiling with assertions enabled, list contents modifications are
|
|
-- permitted only when this switch is set to False; compiling without
|
|
-- assertions this lock has no effect.
|
|
|
|
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.Nodes_Initial,
|
|
Table_Increment => Alloc.Nodes_Increment,
|
|
Release_Threshold => Alloc.Nodes_Release_Threshold,
|
|
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.Nodes_Initial,
|
|
Table_Increment => Alloc.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 entries added.
|
|
|
|
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);
|
|
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_New --
|
|
----------------
|
|
|
|
procedure Append_New (Node : Node_Or_Entity_Id; To : in out List_Id) is
|
|
begin
|
|
if No (To) then
|
|
To := New_List;
|
|
end if;
|
|
|
|
Append (Node, To);
|
|
end Append_New;
|
|
|
|
-------------------
|
|
-- Append_New_To --
|
|
-------------------
|
|
|
|
procedure Append_New_To (To : in out List_Id; Node : Node_Or_Entity_Id) is
|
|
begin
|
|
Append_New (Node, To);
|
|
end Append_New_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
|
|
begin
|
|
Lists.Init;
|
|
Next_Node.Init;
|
|
Prev_Node.Init;
|
|
|
|
-- Allocate Error_List list header
|
|
|
|
Lists.Increment_Last;
|
|
Set_Parent (Error_List, Empty);
|
|
Set_First (Error_List, Empty);
|
|
Set_Last (Error_List, 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;
|
|
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;
|
|
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;
|
|
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.Release;
|
|
Lists.Locked := True;
|
|
Prev_Node.Release;
|
|
Prev_Node.Locked := True;
|
|
Next_Node.Release;
|
|
Next_Node.Locked := True;
|
|
end Lock;
|
|
|
|
----------------
|
|
-- Lock_Lists --
|
|
----------------
|
|
|
|
procedure Lock_Lists is
|
|
begin
|
|
pragma Assert (not Locked);
|
|
Locked := True;
|
|
end Lock_Lists;
|
|
|
|
-------------------
|
|
-- 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);
|
|
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;
|
|
|
|
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
|
|
Next (N);
|
|
exit when Nkind (N) not in 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;
|
|
|
|
------------
|
|
-- 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
|
|
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_New --
|
|
-----------------
|
|
|
|
procedure Prepend_New (Node : Node_Or_Entity_Id; To : in out List_Id) is
|
|
begin
|
|
if No (To) then
|
|
To := New_List;
|
|
end if;
|
|
|
|
Prepend (Node, To);
|
|
end Prepend_New;
|
|
|
|
--------------------
|
|
-- Prepend_New_To --
|
|
--------------------
|
|
|
|
procedure Prepend_New_To (To : in out List_Id; Node : Node_Or_Entity_Id) is
|
|
begin
|
|
Prepend_New (Node, To);
|
|
end Prepend_New_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
|
|
pragma Assert (not Locked);
|
|
Lists.Table (List).First := To;
|
|
end Set_First;
|
|
|
|
--------------
|
|
-- Set_Last --
|
|
--------------
|
|
|
|
procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is
|
|
begin
|
|
pragma Assert (not Locked);
|
|
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
|
|
pragma Assert (not Locked);
|
|
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
|
|
pragma Assert (not Locked);
|
|
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 (not Locked);
|
|
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
|
|
pragma Assert (not Locked);
|
|
Prev_Node.Table (Node) := To;
|
|
end Set_Prev;
|
|
|
|
------------
|
|
-- Unlock --
|
|
------------
|
|
|
|
procedure Unlock is
|
|
begin
|
|
Lists.Locked := False;
|
|
Prev_Node.Locked := False;
|
|
Next_Node.Locked := False;
|
|
end Unlock;
|
|
|
|
------------------
|
|
-- Unlock_Lists --
|
|
------------------
|
|
|
|
procedure Unlock_Lists is
|
|
begin
|
|
pragma Assert (Locked);
|
|
Locked := False;
|
|
end Unlock_Lists;
|
|
|
|
end Nlists;
|