-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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, --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package Lists is new Table.Table (
Table_Component_Type => List_Header,
- Table_Index_Type => List_Id,
+ Table_Index_Type => List_Id'Base,
Table_Low_Bound => First_List_Id,
Table_Initial => Alloc.Lists_Initial,
Table_Increment => Alloc.Lists_Increment,
package Next_Node is new Table.Table (
Table_Component_Type => Node_Id,
- Table_Index_Type => Node_Id,
+ Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
package Prev_Node is new Table.Table (
Table_Component_Type => Node_Id,
- Table_Index_Type => Node_Id,
+ Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
-- Local Subprograms --
-----------------------
- procedure Prepend_Debug (Node : Node_Id; To : List_Id);
- pragma Inline (Prepend_Debug);
- -- Output debug information if Debug_Flag_N set
-
- procedure Remove_Next_Debug (Node : Node_Id);
- pragma Inline (Remove_Next_Debug);
- -- Output debug information if Debug_Flag_N set
-
procedure Set_First (List : List_Id; To : Node_Id);
pragma Inline (Set_First);
-- Sets First field of list header List to reference To
--------------------------
procedure Allocate_List_Tables (N : Node_Id) is
+ Old_Last : constant Node_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;
------------
pragma Inline (Append_Debug);
-- Output debug information if Debug_Flag_N set
+ ------------------
+ -- Append_Debug --
+ ------------------
+
procedure Append_Debug is
begin
if Debug_Flag_N then
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
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 --
-----------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
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);
+ 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
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
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
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
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
end if;
end Insert_List_Before_Debug;
- -- Start of prodcessing for Insert_List_Before
+ -- Start of processing for Insert_List_Before
begin
pragma Assert (Is_List_Member (Before));
function Is_Non_Empty_List (List : List_Id) return Boolean is
begin
- return List /= No_List and then First (List) /= Empty;
+ return First (List) /= Empty;
end Is_Non_Empty_List;
----------
-- Last --
----------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
function Last (List : List_Id) return Node_Id is
begin
- pragma Assert (List in First_List_Id .. Lists.Last);
+ pragma Assert (List <= Lists.Last);
return Lists.Table (List).Last;
end Last;
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;
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
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
function New_List (Node1, Node2 : Node_Id) return List_Id is
L : constant List_Id := New_List (Node1);
-
begin
Append (Node2, L);
return L;
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);
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);
Node2 : Node_Id;
Node3 : Node_Id;
Node4 : Node_Id;
- Node5 : Node_Id)
- return List_Id
+ Node5 : Node_Id) return List_Id
is
L : constant List_Id := New_List (Node1);
-
begin
Append (Node2, L);
Append (Node3, L);
Node3 : Node_Id;
Node4 : Node_Id;
Node5 : Node_Id;
- Node6 : Node_Id)
- return List_Id
+ Node6 : Node_Id) return List_Id
is
L : constant List_Id := New_List (Node1);
-
begin
Append (Node2, L);
Append (Node3, L);
-- Next --
----------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
function Next (Node : Node_Id) return Node_Id is
begin
pragma Assert (Is_List_Member (Node));
loop
N := Next (N);
exit when Nkind (N) /= N_Pragma
- and then
+ and then
Nkind (N) /= N_Null_Statement;
end loop;
-- No --
--------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
function No (List : List_Id) return Boolean is
begin
return List = No_List;
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;
function Parent (List : List_Id) return Node_Id is
begin
- pragma Assert (List in First_List_Id .. Lists.Last);
+ pragma Assert (List <= Lists.Last);
return Lists.Table (List).Parent;
end Parent;
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));
return;
end if;
- pragma Debug (Prepend_Debug (Node, To));
+ pragma Debug (Prepend_Debug);
if No (F) then
Set_Last (To, Node);
Set_List_Link (Node, To);
end Prepend;
- -------------------
- -- Prepend_Debug --
- -------------------
-
- procedure Prepend_Debug (Node : Node_Id; To : List_Id) 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;
-
----------------
-- Prepend_To --
----------------
-- Prev --
----------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
function Prev (Node : Node_Id) return Node_Id is
begin
pragma Assert (Is_List_Member (Node));
pragma Inline (Remove_Debug);
-- Output debug information if Debug_Flag_N set
+ ------------------
+ -- Remove_Debug --
+ ------------------
+
procedure Remove_Debug is
begin
if Debug_Flag_N then
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
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
LC : constant List_Id := List_Containing (Node);
begin
- pragma Debug (Remove_Next_Debug (Node));
+ pragma Debug (Remove_Next_Debug);
Set_Next (Node, Nxt2);
if No (Nxt2) then
return Nxt;
end Remove_Next;
- -----------------------
- -- Remove_Next_Debug --
- -----------------------
-
- procedure Remove_Next_Debug (Node : Node_Id) 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;
-
---------------
-- Set_First --
---------------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
procedure Set_First (List : List_Id; To : Node_Id) is
begin
Lists.Table (List).First := To;
-- Set_Last --
--------------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
procedure Set_Last (List : List_Id; To : Node_Id) is
begin
Lists.Table (List).Last := To;
-- Set_List_Link --
-------------------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
procedure Set_List_Link (Node : Node_Id; To : List_Id) is
begin
Nodes.Table (Node).Link := Union_Id (To);
-- Set_Next --
--------------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
procedure Set_Next (Node : Node_Id; To : Node_Id) is
begin
Next_Node.Table (Node) := To;
procedure Set_Parent (List : List_Id; Node : Node_Id) is
begin
- pragma Assert (List in First_List_Id .. Lists.Last);
+ pragma Assert (List <= Lists.Last);
Lists.Table (List).Parent := Node;
end Set_Parent;
-- Set_Prev --
--------------
- -- This subprogram is deliberately placed early on, out of alphabetical
- -- order, so that it can be properly inlined from within this unit.
-
procedure Set_Prev (Node : Node_Id; To : Node_Id) is
begin
Prev_Node.Table (Node) := To;
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;
OSDN Git Service
