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;
type List_Header is record
First : Node_Id;
Last : Node_Id;
Parent : Node_Id;
end record;
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");
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");
procedure Set_First (List : List_Id; To : Node_Id);
pragma Inline (Set_First);
procedure Set_Last (List : List_Id; To : Node_Id);
pragma Inline (Set_Last);
procedure Set_List_Link (Node : Node_Id; To : List_Id);
pragma Inline (Set_List_Link);
procedure Set_Next (Node : Node_Id; To : Node_Id);
pragma Inline (Set_Next);
procedure Set_Prev (Node : Node_Id; To : Node_Id);
pragma Inline (Set_Prev);
procedure Allocate_List_Tables (N : Node_Id) is
begin
Next_Node.Set_Last (N);
Prev_Node.Set_Last (N);
end Allocate_List_Tables;
procedure Append (Node : Node_Id; To : List_Id) is
L : constant Node_Id := Last (To);
procedure Append_Debug;
pragma Inline (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;
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;
procedure Append_List (List : List_Id; To : List_Id) is
procedure Append_List_Debug;
pragma Inline (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;
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;
procedure Append_List_To (To : List_Id; List : List_Id) is
begin
Append_List (List, To);
end Append_List_To;
procedure Append_To (To : List_Id; Node : Node_Id) is
begin
Append (Node, To);
end Append_To;
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;
end Delete_List;
function First (List : List_Id) return Node_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;
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;
procedure Initialize is
E : constant List_Id := Error_List;
begin
Lists.Init;
Next_Node.Init;
Prev_Node.Init;
Lists.Increment_Last;
Set_Parent (E, Empty);
Set_First (E, Empty);
Set_Last (E, Empty);
end Initialize;
procedure Insert_After (After : Node_Id; Node : Node_Id) is
procedure Insert_After_Debug;
pragma Inline (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;
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;
procedure Insert_Before (Before : Node_Id; Node : Node_Id) is
procedure Insert_Before_Debug;
pragma Inline (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;
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;
procedure Insert_List_After (After : Node_Id; List : List_Id) is
procedure Insert_List_After_Debug;
pragma Inline (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;
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;
procedure Insert_List_Before (Before : Node_Id; List : List_Id) is
procedure Insert_List_Before_Debug;
pragma Inline (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;
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;
function Is_Empty_List (List : List_Id) return Boolean is
begin
return First (List) = Empty;
end Is_Empty_List;
function Is_List_Member (Node : Node_Id) return Boolean is
begin
return Nodes.Table (Node).In_List;
end Is_List_Member;
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;
function Last (List : List_Id) return Node_Id is
begin
pragma Assert (List <= Lists.Last);
return Lists.Table (List).Last;
end Last;
function Last_List_Id return List_Id is
begin
return Lists.Last;
end Last_List_Id;
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;
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;
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;
function Lists_Address return System.Address is
begin
return Lists.Table (First_List_Id)'Address;
end Lists_Address;
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;
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;
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;
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;
function New_List return List_Id is
procedure New_List_Debug;
pragma Inline (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;
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;
function New_List (Node : Node_Id) return List_Id is
procedure New_List_Debug;
pragma Inline (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;
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;
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;
function Next_Node_Address return System.Address is
begin
return Next_Node.Table (First_Node_Id)'Address;
end Next_Node_Address;
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;
function No (List : List_Id) return Boolean is
begin
return List = No_List;
end No;
function Num_Lists return Nat is
begin
return Int (Lists.Last) - Int (Lists.First) + 1;
end Num_Lists;
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;
function Parent (List : List_Id) return Node_Id is
begin
pragma Assert (List <= Lists.Last);
return Lists.Table (List).Parent;
end Parent;
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;
procedure Prepend (Node : Node_Id; To : List_Id) is
F : constant Node_Id := First (To);
procedure Prepend_Debug;
pragma Inline (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;
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;
procedure Prepend_To (To : List_Id; Node : Node_Id) is
begin
Prepend (Node, To);
end Prepend_To;
function Present (List : List_Id) return Boolean is
begin
return List /= No_List;
end Present;
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;
function Prev_Node_Address return System.Address is
begin
return Prev_Node.Table (First_Node_Id)'Address;
end Prev_Node_Address;
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;
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);
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;
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;
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);
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;
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;
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);
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;
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;
procedure Set_First (List : List_Id; To : Node_Id) is
begin
Lists.Table (List).First := To;
end Set_First;
procedure Set_Last (List : List_Id; To : Node_Id) is
begin
Lists.Table (List).Last := To;
end Set_Last;
procedure Set_List_Link (Node : Node_Id; To : List_Id) is
begin
Nodes.Table (Node).Link := Union_Id (To);
end Set_List_Link;
procedure Set_Next (Node : Node_Id; To : Node_Id) is
begin
Next_Node.Table (Node) := To;
end Set_Next;
procedure Set_Parent (List : List_Id; Node : Node_Id) is
begin
pragma Assert (List <= Lists.Last);
Lists.Table (List).Parent := Node;
end Set_Parent;
procedure Set_Prev (Node : Node_Id; To : Node_Id) is
begin
Prev_Node.Table (Node) := To;
end Set_Prev;
procedure Tree_Read is
begin
Lists.Tree_Read;
Next_Node.Tree_Read;
Prev_Node.Tree_Read;
end Tree_Read;
procedure Tree_Write is
begin
Lists.Tree_Write;
Next_Node.Tree_Write;
Prev_Node.Tree_Write;
end Tree_Write;
end Nlists;