OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2009-04-17  Ed Schonberg  <schonberg@adacore.com>

	* atree.ads, atree.adb: Move New_Copy_Tree.to sem_util.

	* nlists.ads, nlists.adb: Move New_Copy_List to sem_util.
	
	* lib-load.adb: Use Copy_Separate_Tree rather than New_Copy_Tree

	* sem_util.ads, sem_util.adb: New_Copy_Tree and New_Copy_List belong in
	semantic units, because the handling of itypes in the copied tree
	requires semantic information that does not belong in atree.

2009-04-17  Robert Dewar  <dewar@adacore.com>

	* par-ch6.adb: Minor reformatting

	* prj.adb: Minor reformatting

From-SVN: r146230
This commit is contained in:
Arnaud Charlet 2009-04-17 11:38:12 +02:00
parent cec2913559
commit f3b01cd988
10 changed files with 1168 additions and 135 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
gcc/ada/ChangeLog
View File

@ -1,3 +1,35 @@
2009-04-17 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Access_Subprogram_Definition): Additional checks on
illegal uses of incomplete types in formal parts and return types.
* sem_ch6.adb (Process_Formals): Taft-amendment types are legal in
access to subprograms.
* sem_ch7.adb (Uninstall_Declarations): diagnose attempts to use
Taft-amendment types as the return type of an access_to_function type.
* freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete
type for access_to_subprograms. The check is performed on package exit.
2009-04-17 Ed Schonberg <schonberg@adacore.com>
* atree.ads, atree.adb: Move New_Copy_Tree.to sem_util.
* nlists.ads, nlists.adb: Move New_Copy_List to sem_util.
* lib-load.adb: Use Copy_Separate_Tree rather than New_Copy_Tree
* sem_util.ads, sem_util.adb: New_Copy_Tree and New_Copy_List belong in
semantic units, because the handling of itypes in the copied tree
requires semantic information that does not belong in atree.
2009-04-17 Robert Dewar <dewar@adacore.com>
* par-ch6.adb: Minor reformatting
* prj.adb: Minor reformatting
2009-04-17 Gary Dismukes <dismukes@adacore.com>
* par-ch6.adb (P_Subprogram): Overriding indicators should be allowed

102
gcc/ada/atree.adb
View File

@ -105,8 +105,6 @@ package body Atree is
use Atree_Private_Part;
-- We are also allowed to see our private data structures!
function E_To_N is new Unchecked_Conversion (Entity_Kind, Node_Kind);
function N_To_E is new Unchecked_Conversion (Node_Kind, Entity_Kind);
-- Functions used to store Entity_Kind value in Nkind field
-- The following declarations are used to store flags 65-72 in the
@ -395,91 +393,6 @@ package body Atree is
function To_Flag_Word5_Ptr is new
Unchecked_Conversion (Union_Id_Ptr, Flag_Word5_Ptr);
-- Default value used to initialize default nodes. Note that some of the
-- fields get overwritten, and in particular, Nkind always gets reset.
Default_Node : Node_Record := (
Is_Extension => False,
Pflag1 => False,
Pflag2 => False,
In_List => False,
Unused_1 => False,
Rewrite_Ins => False,
Analyzed => False,
Comes_From_Source => False, -- modified by Set_Comes_From_Source_Default
Error_Posted => False,
Flag4 => False,
Flag5 => False,
Flag6 => False,
Flag7 => False,
Flag8 => False,
Flag9 => False,
Flag10 => False,
Flag11 => False,
Flag12 => False,
Flag13 => False,
Flag14 => False,
Flag15 => False,
Flag16 => False,
Flag17 => False,
Flag18 => False,
Nkind => N_Unused_At_Start,
Sloc => No_Location,
Link => Empty_List_Or_Node,
Field1 => Empty_List_Or_Node,
Field2 => Empty_List_Or_Node,
Field3 => Empty_List_Or_Node,
Field4 => Empty_List_Or_Node,
Field5 => Empty_List_Or_Node);
-- Default value used to initialize node extensions (i.e. the second
-- and third and fourth components of an extended node). Note we are
-- cheating a bit here when it comes to Node12, which really holds
-- flags an (for the third component), the convention. But it works
-- because Empty, False, Convention_Ada, all happen to be all zero bits.
Default_Node_Extension : constant Node_Record := (
Is_Extension => True,
Pflag1 => False,
Pflag2 => False,
In_List => False,
Unused_1 => False,
Rewrite_Ins => False,
Analyzed => False,
Comes_From_Source => False,
Error_Posted => False,
Flag4 => False,
Flag5 => False,
Flag6 => False,
Flag7 => False,
Flag8 => False,
Flag9 => False,
Flag10 => False,
Flag11 => False,
Flag12 => False,
Flag13 => False,
Flag14 => False,
Flag15 => False,
Flag16 => False,
Flag17 => False,
Flag18 => False,
Nkind => E_To_N (E_Void),
Field6 => Empty_List_Or_Node,
Field7 => Empty_List_Or_Node,
Field8 => Empty_List_Or_Node,
Field9 => Empty_List_Or_Node,
Field10 => Empty_List_Or_Node,
Field11 => Empty_List_Or_Node,
Field12 => Empty_List_Or_Node);
--------------------------------------------------
-- Implementation of Tree Substitution Routines --
--------------------------------------------------
@ -1218,7 +1131,7 @@ package body Atree is
-- Start of processing for New_Copy_Tree function
function New_Copy_Tree
function New_Copy_Tree1
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
@ -1835,12 +1748,9 @@ package body Atree is
-- The new Itype has all the attributes of the old one, and
-- we just copy the contents of the entity. However, the back-end
-- needs different names for debugging purposes, so we create a
-- new internal name by appending the letter 'c' (copy) to the
-- name of the original.
-- new internal name for it in all cases.
Get_Name_String (Chars (Old_Itype));
Add_Char_To_Name_Buffer ('c');
Set_Chars (New_Itype, Name_Enter);
-- Set_Chars (New_Itype, New_Internal_Name ('T'));
-- If our associated node is an entity that has already been copied,
-- then set the associated node of the copy to point to the right
@ -1952,6 +1862,10 @@ package body Atree is
Old_Itype);
end if;
end if;
Get_Name_String (Chars (Old_Itype));
Add_Char_To_Name_Buffer ('c');
Add_Nat_To_Name_Buffer (Int (Associated_Node_For_Itype (New_Itype)));
Set_Chars (New_Itype, Name_Enter);
end Visit_Itype;
----------------
@ -2085,7 +1999,7 @@ package body Atree is
-- Now we can copy the actual tree
return Copy_Node_With_Replacement (Source);
end New_Copy_Tree;
end New_Copy_Tree1;
----------------
-- New_Entity --

91
gcc/ada/atree.ads
View File

@ -430,7 +430,7 @@ package Atree is
-- Source to be Empty, in which case Relocate_Node simply returns
-- Empty as the result.
function New_Copy_Tree
function New_Copy_Tree1
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
@ -3114,6 +3114,95 @@ package Atree is
for Node_Record'Size use 8*32;
for Node_Record'Alignment use 4;
function E_To_N is new Unchecked_Conversion (Entity_Kind, Node_Kind);
function N_To_E is new Unchecked_Conversion (Node_Kind, Entity_Kind);
-- Default value used to initialize default nodes. Note that some of the
-- fields get overwritten, and in particular, Nkind always gets reset.
Default_Node : Node_Record := (
Is_Extension => False,
Pflag1 => False,
Pflag2 => False,
In_List => False,
Unused_1 => False,
Rewrite_Ins => False,
Analyzed => False,
Comes_From_Source => False,
-- modified by Set_Comes_From_Source_Default
Error_Posted => False,
Flag4 => False,
Flag5 => False,
Flag6 => False,
Flag7 => False,
Flag8 => False,
Flag9 => False,
Flag10 => False,
Flag11 => False,
Flag12 => False,
Flag13 => False,
Flag14 => False,
Flag15 => False,
Flag16 => False,
Flag17 => False,
Flag18 => False,
Nkind => N_Unused_At_Start,
Sloc => No_Location,
Link => Empty_List_Or_Node,
Field1 => Empty_List_Or_Node,
Field2 => Empty_List_Or_Node,
Field3 => Empty_List_Or_Node,
Field4 => Empty_List_Or_Node,
Field5 => Empty_List_Or_Node);
-- Default value used to initialize node extensions (i.e. the second
-- and third and fourth components of an extended node). Note we are
-- cheating a bit here when it comes to Node12, which really holds
-- flags an (for the third component), the convention. But it works
-- because Empty, False, Convention_Ada, all happen to be all zero bits.
Default_Node_Extension : constant Node_Record := (
Is_Extension => True,
Pflag1 => False,
Pflag2 => False,
In_List => False,
Unused_1 => False,
Rewrite_Ins => False,
Analyzed => False,
Comes_From_Source => False,
Error_Posted => False,
Flag4 => False,
Flag5 => False,
Flag6 => False,
Flag7 => False,
Flag8 => False,
Flag9 => False,
Flag10 => False,
Flag11 => False,
Flag12 => False,
Flag13 => False,
Flag14 => False,
Flag15 => False,
Flag16 => False,
Flag17 => False,
Flag18 => False,
Nkind => E_To_N (E_Void),
Field6 => Empty_List_Or_Node,
Field7 => Empty_List_Or_Node,
Field8 => Empty_List_Or_Node,
Field9 => Empty_List_Or_Node,
Field10 => Empty_List_Or_Node,
Field11 => Empty_List_Or_Node,
Field12 => Empty_List_Or_Node);
-- The following defines the extendable array used for the nodes table
-- Nodes with extensions use five consecutive entries in the array

4
gcc/ada/lib-load.adb
View File

@ -169,14 +169,14 @@ package body Lib.Load is
Chars => Chars (Selector_Name (Name (With_Node))));
Du_Name :=
Make_Defining_Program_Unit_Name (No_Location,
Name => New_Copy_Tree (Prefix (Name (With_Node))),
Name => Copy_Separate_Tree (Prefix (Name (With_Node))),
Defining_Identifier => Cunit_Entity);
Set_Is_Child_Unit (Cunit_Entity);
End_Lab :=
Make_Designator (No_Location,
Name => New_Copy_Tree (Prefix (Name (With_Node))),
Name => Copy_Separate_Tree (Prefix (Name (With_Node))),
Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
end if;

25
gcc/ada/nlists.adb
View File

@ -745,31 +745,6 @@ package body Nlists is
end if;
end New_Copy_List_Original;
------------------------
-- New_Copy_List_Tree --
------------------------
function New_Copy_List_Tree (List : List_Id) return List_Id is
NL : List_Id;
E : Node_Id;
begin
if List = No_List then
return No_List;
else
NL := New_List;
E := First (List);
while Present (E) loop
Append (New_Copy_Tree (E), NL);
E := Next (E);
end loop;
return NL;
end if;
end New_Copy_List_Tree;
--------------
-- New_List --
--------------

7
gcc/ada/nlists.ads
View File

@ -108,13 +108,6 @@ package Nlists is
function New_Copy_List_Original (List : List_Id) return List_Id;
-- Same as New_Copy_List but copies only nodes coming from source
function New_Copy_List_Tree (List : List_Id) return List_Id;
-- Similar to New_Copy_List, except that the copies are done using the
-- Atree.New_Copy_Tree function, which means that a full recursive copy
-- of the subtrees in the list is performed, setting proper parents. As
-- for New_Copy_Tree, it is illegal to attempt to copy extended nodes
-- (entities) either directly or indirectly using this function.
function First (List : List_Id) return Node_Id;
pragma Inline (First);
-- Obtains the first element of the given node list or, if the node list

7
gcc/ada/par-ch6.adb
View File

@ -221,13 +221,12 @@ package body Ch6 is
-- and bodies can occur.
if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub
and then Pf_Flags /= Pf_Decl_Pbod
and then
Pf_Flags /= Pf_Decl_Pbod
then
Error_Msg_SC ("overriding indicator not allowed here!");
elsif Token /= Tok_Function
and then Token /= Tok_Procedure
then
elsif Token /= Tok_Function and then Token /= Tok_Procedure then
Error_Msg_SC ("FUNCTION or PROCEDURE expected!");
end if;
end if;

6
gcc/ada/prj.adb
View File

@ -715,8 +715,8 @@ package body Prj is
is
begin
if Object_File_Suffix = No_Name then
return Extend_Name (Source_File_Name, Object_Suffix);
return Extend_Name
(Source_File_Name, Object_Suffix);
else
return Extend_Name
(Source_File_Name, Get_Name_String (Object_File_Suffix));
@ -880,6 +880,7 @@ package body Prj is
loop
Free (Tree.Projects.Table (P));
end loop;
Project_Table.Free (Tree.Projects);
-- Private part
@ -929,6 +930,7 @@ package body Prj is
Free (Tree.Projects.Table (P));
end loop;
end if;
Project_Table.Init (Tree.Projects);
-- Private part table

978
gcc/ada/sem_util.adb
View File

@ -59,8 +59,38 @@ with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
with GNAT.HTable; use GNAT.HTable;
package body Sem_Util is
----------------------------------------
-- Global_Variables for New_Copy_Tree --
----------------------------------------
-- These global variables are used by New_Copy_Tree. See description
-- of the body of this subprogram for details. Global variables can be
-- safely used by New_Copy_Tree, since there is no case of a recursive
-- call from the processing inside New_Copy_Tree.
NCT_Hash_Threshhold : constant := 20;
-- If there are more than this number of pairs of entries in the
-- map, then Hash_Tables_Used will be set, and the hash tables will
-- be initialized and used for the searches.
NCT_Hash_Tables_Used : Boolean := False;
-- Set to True if hash tables are in use
NCT_Table_Entries : Nat;
-- Count entries in table to see if threshhold is reached
NCT_Hash_Table_Setup : Boolean := False;
-- Set to True if hash table contains data. We set this True if we
-- setup the hash table with data, and leave it set permanently
-- from then on, this is a signal that second and subsequent users
-- of the hash table must clear the old entries before reuse.
subtype NCT_Header_Num is Int range 0 .. 511;
-- Defines range of headers in hash tables (512 headers)
-----------------------
-- Local Subprograms --
-----------------------
@ -7431,6 +7461,954 @@ package body Sem_Util is
end if;
end Needs_One_Actual;
------------------------
-- New_Copy_List_Tree --
------------------------
function New_Copy_List_Tree (List : List_Id) return List_Id is
NL : List_Id;
E : Node_Id;
begin
if List = No_List then
return No_List;
else
NL := New_List;
E := First (List);
while Present (E) loop
Append (New_Copy_Tree (E), NL);
E := Next (E);
end loop;
return NL;
end if;
end New_Copy_List_Tree;
-------------------
-- New_Copy_Tree --
-------------------
use Atree.Unchecked_Access;
use Atree_Private_Part;
-- Our approach here requires a two pass traversal of the tree. The
-- first pass visits all nodes that eventually will be copied looking
-- for defining Itypes. If any defining Itypes are found, then they are
-- copied, and an entry is added to the replacement map. In the second
-- phase, the tree is copied, using the replacement map to replace any
-- Itype references within the copied tree.
-- The following hash tables are used if the Map supplied has more
-- than hash threshhold entries to speed up access to the map. If
-- there are fewer entries, then the map is searched sequentially
-- (because setting up a hash table for only a few entries takes
-- more time than it saves.
function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
-- Hash function used for hash operations
-------------------
-- New_Copy_Hash --
-------------------
function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
begin
return Nat (E) mod (NCT_Header_Num'Last + 1);
end New_Copy_Hash;
---------------
-- NCT_Assoc --
---------------
-- The hash table NCT_Assoc associates old entities in the table
-- with their corresponding new entities (i.e. the pairs of entries
-- presented in the original Map argument are Key-Element pairs).
package NCT_Assoc is new Simple_HTable (
Header_Num => NCT_Header_Num,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => New_Copy_Hash,
Equal => Types."=");
---------------------
-- NCT_Itype_Assoc --
---------------------
-- The hash table NCT_Itype_Assoc contains entries only for those
-- old nodes which have a non-empty Associated_Node_For_Itype set.
-- The key is the associated node, and the element is the new node
-- itself (NOT the associated node for the new node).
package NCT_Itype_Assoc is new Simple_HTable (
Header_Num => NCT_Header_Num,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => New_Copy_Hash,
Equal => Types."=");
-- Start of processing for New_Copy_Tree function
function New_Copy_Tree
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id
is
Actual_Map : Elist_Id := Map;
-- This is the actual map for the copy. It is initialized with the
-- given elements, and then enlarged as required for Itypes that are
-- copied during the first phase of the copy operation. The visit
-- procedures add elements to this map as Itypes are encountered.
-- The reason we cannot use Map directly, is that it may well be
-- (and normally is) initialized to No_Elist, and if we have mapped
-- entities, we have to reset it to point to a real Elist.
function Assoc (N : Node_Or_Entity_Id) return Node_Id;
-- Called during second phase to map entities into their corresponding
-- copies using Actual_Map. If the argument is not an entity, or is not
-- in Actual_Map, then it is returned unchanged.
procedure Build_NCT_Hash_Tables;
-- Builds hash tables (number of elements >= threshold value)
function Copy_Elist_With_Replacement
(Old_Elist : Elist_Id) return Elist_Id;
-- Called during second phase to copy element list doing replacements
procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
-- Called during the second phase to process a copied Itype. The actual
-- copy happened during the first phase (so that we could make the entry
-- in the mapping), but we still have to deal with the descendents of
-- the copied Itype and copy them where necessary.
function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
-- Called during second phase to copy list doing replacements
function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
-- Called during second phase to copy node doing replacements
procedure Visit_Elist (E : Elist_Id);
-- Called during first phase to visit all elements of an Elist
procedure Visit_Field (F : Union_Id; N : Node_Id);
-- Visit a single field, recursing to call Visit_Node or Visit_List
-- if the field is a syntactic descendent of the current node (i.e.
-- its parent is Node N).
procedure Visit_Itype (Old_Itype : Entity_Id);
-- Called during first phase to visit subsidiary fields of a defining
-- Itype, and also create a copy and make an entry in the replacement
-- map for the new copy.
procedure Visit_List (L : List_Id);
-- Called during first phase to visit all elements of a List
procedure Visit_Node (N : Node_Or_Entity_Id);
-- Called during first phase to visit a node and all its subtrees
-----------
-- Assoc --
-----------
function Assoc (N : Node_Or_Entity_Id) return Node_Id is
E : Elmt_Id;
Ent : Entity_Id;
begin
if not Has_Extension (N) or else No (Actual_Map) then
return N;
elsif NCT_Hash_Tables_Used then
Ent := NCT_Assoc.Get (Entity_Id (N));
if Present (Ent) then
return Ent;
else
return N;
end if;
-- No hash table used, do serial search
else
E := First_Elmt (Actual_Map);
while Present (E) loop
if Node (E) = N then
return Node (Next_Elmt (E));
else
E := Next_Elmt (Next_Elmt (E));
end if;
end loop;
end if;
return N;
end Assoc;
---------------------------
-- Build_NCT_Hash_Tables --
---------------------------
procedure Build_NCT_Hash_Tables is
Elmt : Elmt_Id;
Ent : Entity_Id;
begin
if NCT_Hash_Table_Setup then
NCT_Assoc.Reset;
NCT_Itype_Assoc.Reset;
end if;
Elmt := First_Elmt (Actual_Map);
while Present (Elmt) loop
Ent := Node (Elmt);
-- Get new entity, and associate old and new
Next_Elmt (Elmt);
NCT_Assoc.Set (Ent, Node (Elmt));
if Is_Type (Ent) then
declare
Anode : constant Entity_Id :=
Associated_Node_For_Itype (Ent);
begin
if Present (Anode) then
-- Enter a link between the associated node of the
-- old Itype and the new Itype, for updating later
-- when node is copied.
NCT_Itype_Assoc.Set (Anode, Node (Elmt));
end if;
end;
end if;
Next_Elmt (Elmt);
end loop;
NCT_Hash_Tables_Used := True;
NCT_Hash_Table_Setup := True;
end Build_NCT_Hash_Tables;
---------------------------------
-- Copy_Elist_With_Replacement --
---------------------------------
function Copy_Elist_With_Replacement
(Old_Elist : Elist_Id) return Elist_Id
is
M : Elmt_Id;
New_Elist : Elist_Id;
begin
if No (Old_Elist) then
return No_Elist;
else
New_Elist := New_Elmt_List;
M := First_Elmt (Old_Elist);
while Present (M) loop
Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
Next_Elmt (M);
end loop;
end if;
return New_Elist;
end Copy_Elist_With_Replacement;
---------------------------------
-- Copy_Itype_With_Replacement --
---------------------------------
-- This routine exactly parallels its phase one analog Visit_Itype,
procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
begin
-- Translate Next_Entity, Scope and Etype fields, in case they
-- reference entities that have been mapped into copies.
Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
Set_Etype (New_Itype, Assoc (Etype (New_Itype)));
if Present (New_Scope) then
Set_Scope (New_Itype, New_Scope);
else
Set_Scope (New_Itype, Assoc (Scope (New_Itype)));
end if;
-- Copy referenced fields
if Is_Discrete_Type (New_Itype) then
Set_Scalar_Range (New_Itype,
Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
elsif Has_Discriminants (Base_Type (New_Itype)) then
Set_Discriminant_Constraint (New_Itype,
Copy_Elist_With_Replacement
(Discriminant_Constraint (New_Itype)));
elsif Is_Array_Type (New_Itype) then
if Present (First_Index (New_Itype)) then
Set_First_Index (New_Itype,
First (Copy_List_With_Replacement
(List_Containing (First_Index (New_Itype)))));
end if;
if Is_Packed (New_Itype) then
Set_Packed_Array_Type (New_Itype,
Copy_Node_With_Replacement
(Packed_Array_Type (New_Itype)));
end if;
end if;
end Copy_Itype_With_Replacement;
--------------------------------
-- Copy_List_With_Replacement --
--------------------------------
function Copy_List_With_Replacement
(Old_List : List_Id) return List_Id
is
New_List : List_Id;
E : Node_Id;
begin
if Old_List = No_List then
return No_List;
else
New_List := Empty_List;
E := First (Old_List);
while Present (E) loop
Append (Copy_Node_With_Replacement (E), New_List);
Next (E);
end loop;
return New_List;
end if;
end Copy_List_With_Replacement;
--------------------------------
-- Copy_Node_With_Replacement --
--------------------------------
function Copy_Node_With_Replacement
(Old_Node : Node_Id) return Node_Id
is
New_Node : Node_Id;
procedure Adjust_Named_Associations
(Old_Node : Node_Id;
New_Node : Node_Id);
-- If a call node has named associations, these are chained through
-- the First_Named_Actual, Next_Named_Actual links. These must be
-- propagated separately to the new parameter list, because these
-- are not syntactic fields.
function Copy_Field_With_Replacement
(Field : Union_Id) return Union_Id;
-- Given Field, which is a field of Old_Node, return a copy of it
-- if it is a syntactic field (i.e. its parent is Node), setting
-- the parent of the copy to poit to New_Node. Otherwise returns
-- the field (possibly mapped if it is an entity).
-------------------------------
-- Adjust_Named_Associations --
-------------------------------
procedure Adjust_Named_Associations
(Old_Node : Node_Id;
New_Node : Node_Id)
is
Old_E : Node_Id;
New_E : Node_Id;
Old_Next : Node_Id;
New_Next : Node_Id;
begin
Old_E := First (Parameter_Associations (Old_Node));
New_E := First (Parameter_Associations (New_Node));
while Present (Old_E) loop
if Nkind (Old_E) = N_Parameter_Association
and then Present (Next_Named_Actual (Old_E))
then
if First_Named_Actual (Old_Node)
= Explicit_Actual_Parameter (Old_E)
then
Set_First_Named_Actual
(New_Node, Explicit_Actual_Parameter (New_E));
end if;
-- Now scan parameter list from the beginning,to locate
-- next named actual, which can be out of order.
Old_Next := First (Parameter_Associations (Old_Node));
New_Next := First (Parameter_Associations (New_Node));
while Nkind (Old_Next) /= N_Parameter_Association
or else Explicit_Actual_Parameter (Old_Next)
/= Next_Named_Actual (Old_E)
loop
Next (Old_Next);
Next (New_Next);
end loop;
Set_Next_Named_Actual
(New_E, Explicit_Actual_Parameter (New_Next));
end if;
Next (Old_E);
Next (New_E);
end loop;
end Adjust_Named_Associations;
---------------------------------
-- Copy_Field_With_Replacement --
---------------------------------
function Copy_Field_With_Replacement
(Field : Union_Id) return Union_Id
is
begin
if Field = Union_Id (Empty) then
return Field;
elsif Field in Node_Range then
declare
Old_N : constant Node_Id := Node_Id (Field);
New_N : Node_Id;
begin
-- If syntactic field, as indicated by the parent pointer
-- being set, then copy the referenced node recursively.
if Parent (Old_N) = Old_Node then
New_N := Copy_Node_With_Replacement (Old_N);
if New_N /= Old_N then
Set_Parent (New_N, New_Node);
end if;
-- For semantic fields, update possible entity reference
-- from the replacement map.
else
New_N := Assoc (Old_N);
end if;
return Union_Id (New_N);
end;
elsif Field in List_Range then
declare
Old_L : constant List_Id := List_Id (Field);
New_L : List_Id;
begin
-- If syntactic field, as indicated by the parent pointer,
-- then recursively copy the entire referenced list.
if Parent (Old_L) = Old_Node then
New_L := Copy_List_With_Replacement (Old_L);
Set_Parent (New_L, New_Node);
-- For semantic list, just returned unchanged
else
New_L := Old_L;
end if;
return Union_Id (New_L);
end;
-- Anything other than a list or a node is returned unchanged
else
return Field;
end if;
end Copy_Field_With_Replacement;
-- Start of processing for Copy_Node_With_Replacement
begin
if Old_Node <= Empty_Or_Error then
return Old_Node;
elsif Has_Extension (Old_Node) then
return Assoc (Old_Node);
else
New_Node := New_Copy (Old_Node);
-- If the node we are copying is the associated node of a
-- previously copied Itype, then adjust the associated node
-- of the copy of that Itype accordingly.
if Present (Actual_Map) then
declare
E : Elmt_Id;
Ent : Entity_Id;
begin
-- Case of hash table used
if NCT_Hash_Tables_Used then
Ent := NCT_Itype_Assoc.Get (Old_Node);
if Present (Ent) then
Set_Associated_Node_For_Itype (Ent, New_Node);
end if;
-- Case of no hash table used
else
E := First_Elmt (Actual_Map);
while Present (E) loop
if Is_Itype (Node (E))
and then
Old_Node = Associated_Node_For_Itype (Node (E))
then
Set_Associated_Node_For_Itype
(Node (Next_Elmt (E)), New_Node);
end if;
E := Next_Elmt (Next_Elmt (E));
end loop;
end if;
end;
end if;
-- Recursively copy descendents
Set_Field1
(New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
Set_Field2
(New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
Set_Field3
(New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
Set_Field4
(New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
Set_Field5
(New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
-- Adjust Sloc of new node if necessary
if New_Sloc /= No_Location then
Set_Sloc (New_Node, New_Sloc);
-- If we adjust the Sloc, then we are essentially making
-- a completely new node, so the Comes_From_Source flag
-- should be reset to the proper default value.
Nodes.Table (New_Node).Comes_From_Source :=
Default_Node.Comes_From_Source;
end if;
-- If the node is call and has named associations,
-- set the corresponding links in the copy.
if (Nkind (Old_Node) = N_Function_Call
or else Nkind (Old_Node) = N_Entry_Call_Statement
or else
Nkind (Old_Node) = N_Procedure_Call_Statement)
and then Present (First_Named_Actual (Old_Node))
then
Adjust_Named_Associations (Old_Node, New_Node);
end if;
-- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
-- The replacement mechanism applies to entities, and is not used
-- here. Eventually we may need a more general graph-copying
-- routine. For now, do a sequential search to find desired node.
if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
and then Present (First_Real_Statement (Old_Node))
then
declare
Old_F : constant Node_Id := First_Real_Statement (Old_Node);
N1, N2 : Node_Id;
begin
N1 := First (Statements (Old_Node));
N2 := First (Statements (New_Node));
while N1 /= Old_F loop
Next (N1);
Next (N2);
end loop;
Set_First_Real_Statement (New_Node, N2);
end;
end if;
end if;
-- All done, return copied node
return New_Node;
end Copy_Node_With_Replacement;
-----------------
-- Visit_Elist --
-----------------
procedure Visit_Elist (E : Elist_Id) is
Elmt : Elmt_Id;
begin
if Present (E) then
Elmt := First_Elmt (E);
while Elmt /= No_Elmt loop
Visit_Node (Node (Elmt));
Next_Elmt (Elmt);
end loop;
end if;
end Visit_Elist;
-----------------
-- Visit_Field --
-----------------
procedure Visit_Field (F : Union_Id; N : Node_Id) is
begin
if F = Union_Id (Empty) then
return;
elsif F in Node_Range then
-- Copy node if it is syntactic, i.e. its parent pointer is
-- set to point to the field that referenced it (certain
-- Itypes will also meet this criterion, which is fine, since
-- these are clearly Itypes that do need to be copied, since
-- we are copying their parent.)
if Parent (Node_Id (F)) = N then
Visit_Node (Node_Id (F));
return;
-- Another case, if we are pointing to an Itype, then we want
-- to copy it if its associated node is somewhere in the tree
-- being copied.
-- Note: the exclusion of self-referential copies is just an
-- optimization, since the search of the already copied list
-- would catch it, but it is a common case (Etype pointing
-- to itself for an Itype that is a base type).
elsif Has_Extension (Node_Id (F))
and then Is_Itype (Entity_Id (F))
and then Node_Id (F) /= N
then
declare
P : Node_Id;
begin
P := Associated_Node_For_Itype (Node_Id (F));
while Present (P) loop
if P = Source then
Visit_Node (Node_Id (F));
return;
else
P := Parent (P);
end if;
end loop;
-- An Itype whose parent is not being copied definitely
-- should NOT be copied, since it does not belong in any
-- sense to the copied subtree.
return;
end;
end if;
elsif F in List_Range
and then Parent (List_Id (F)) = N
then
Visit_List (List_Id (F));
return;
end if;
end Visit_Field;
-----------------
-- Visit_Itype --
-----------------
procedure Visit_Itype (Old_Itype : Entity_Id) is
New_Itype : Entity_Id;
E : Elmt_Id;
Ent : Entity_Id;
begin
-- Itypes that describe the designated type of access to subprograms
-- have the structure of subprogram declarations, with signatures,
-- etc. Either we duplicate the signatures completely, or choose to
-- share such itypes, which is fine because their elaboration will
-- have no side effects.
if Ekind (Old_Itype) = E_Subprogram_Type then
return;
end if;
New_Itype := New_Copy (Old_Itype);
-- The new Itype has all the attributes of the old one, and
-- we just copy the contents of the entity. However, the back-end
-- needs different names for debugging purposes, so we create a
-- new internal name for it in all cases.
Set_Chars (New_Itype, New_Internal_Name ('T'));
-- If our associated node is an entity that has already been copied,
-- then set the associated node of the copy to point to the right
-- copy. If we have copied an Itype that is itself the associated
-- node of some previously copied Itype, then we set the right
-- pointer in the other direction.
if Present (Actual_Map) then
-- Case of hash tables used
if NCT_Hash_Tables_Used then
Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
if Present (Ent) then
Set_Associated_Node_For_Itype (New_Itype, Ent);
end if;
Ent := NCT_Itype_Assoc.Get (Old_Itype);
if Present (Ent) then
Set_Associated_Node_For_Itype (Ent, New_Itype);
-- If the hash table has no association for this Itype and
-- its associated node, enter one now.
else
NCT_Itype_Assoc.Set
(Associated_Node_For_Itype (Old_Itype), New_Itype);
end if;
-- Case of hash tables not used
else
E := First_Elmt (Actual_Map);
while Present (E) loop
if Associated_Node_For_Itype (Old_Itype) = Node (E) then
Set_Associated_Node_For_Itype
(New_Itype, Node (Next_Elmt (E)));
end if;
if Is_Type (Node (E))
and then
Old_Itype = Associated_Node_For_Itype (Node (E))
then
Set_Associated_Node_For_Itype
(Node (Next_Elmt (E)), New_Itype);
end if;
E := Next_Elmt (Next_Elmt (E));
end loop;
end if;
end if;
if Present (Freeze_Node (New_Itype)) then
Set_Is_Frozen (New_Itype, False);
Set_Freeze_Node (New_Itype, Empty);
end if;
-- Add new association to map
if No (Actual_Map) then
Actual_Map := New_Elmt_List;
end if;
Append_Elmt (Old_Itype, Actual_Map);
Append_Elmt (New_Itype, Actual_Map);
if NCT_Hash_Tables_Used then
NCT_Assoc.Set (Old_Itype, New_Itype);
else
NCT_Table_Entries := NCT_Table_Entries + 1;
if NCT_Table_Entries > NCT_Hash_Threshhold then
Build_NCT_Hash_Tables;
end if;
end if;
-- If a record subtype is simply copied, the entity list will be
-- shared. Thus cloned_Subtype must be set to indicate the sharing.
if Ekind (Old_Itype) = E_Record_Subtype
or else Ekind (Old_Itype) = E_Class_Wide_Subtype
then
Set_Cloned_Subtype (New_Itype, Old_Itype);
end if;
-- Visit descendents that eventually get copied
Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
if Is_Discrete_Type (Old_Itype) then
Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
elsif Has_Discriminants (Base_Type (Old_Itype)) then
-- ??? This should involve call to Visit_Field
Visit_Elist (Discriminant_Constraint (Old_Itype));
elsif Is_Array_Type (Old_Itype) then
if Present (First_Index (Old_Itype)) then
Visit_Field (Union_Id (List_Containing
(First_Index (Old_Itype))),
Old_Itype);
end if;
if Is_Packed (Old_Itype) then
Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
Old_Itype);
end if;
end if;
end Visit_Itype;
----------------
-- Visit_List --
----------------
procedure Visit_List (L : List_Id) is
N : Node_Id;
begin
if L /= No_List then
N := First (L);
while Present (N) loop
Visit_Node (N);
Next (N);
end loop;
end if;
end Visit_List;
----------------
-- Visit_Node --
----------------
procedure Visit_Node (N : Node_Or_Entity_Id) is
-- Start of processing for Visit_Node
begin
-- Handle case of an Itype, which must be copied
if Has_Extension (N)
and then Is_Itype (N)
then
-- Nothing to do if already in the list. This can happen with an
-- Itype entity that appears more than once in the tree.
-- Note that we do not want to visit descendents in this case.
-- Test for already in list when hash table is used
if NCT_Hash_Tables_Used then
if Present (NCT_Assoc.Get (Entity_Id (N))) then
return;
end if;
-- Test for already in list when hash table not used
else
declare
E : Elmt_Id;
begin
if Present (Actual_Map) then
E := First_Elmt (Actual_Map);
while Present (E) loop
if Node (E) = N then
return;
else
E := Next_Elmt (Next_Elmt (E));
end if;
end loop;
end if;
end;
end if;
Visit_Itype (N);
end if;
-- Visit descendents
Visit_Field (Field1 (N), N);
Visit_Field (Field2 (N), N);
Visit_Field (Field3 (N), N);
Visit_Field (Field4 (N), N);
Visit_Field (Field5 (N), N);
end Visit_Node;
-- Start of processing for New_Copy_Tree
begin
Actual_Map := Map;
-- See if we should use hash table
if No (Actual_Map) then
NCT_Hash_Tables_Used := False;
else
declare
Elmt : Elmt_Id;
begin
NCT_Table_Entries := 0;
Elmt := First_Elmt (Actual_Map);
while Present (Elmt) loop
NCT_Table_Entries := NCT_Table_Entries + 1;
Next_Elmt (Elmt);
Next_Elmt (Elmt);
end loop;
if NCT_Table_Entries > NCT_Hash_Threshhold then
Build_NCT_Hash_Tables;
else
NCT_Hash_Tables_Used := False;
end if;
end;
end if;
-- Hash table set up if required, now start phase one by visiting
-- top node (we will recursively visit the descendents).
Visit_Node (Source);
-- Now the second phase of the copy can start. First we process
-- all the mapped entities, copying their descendents.
if Present (Actual_Map) then
declare
Elmt : Elmt_Id;
New_Itype : Entity_Id;
begin
Elmt := First_Elmt (Actual_Map);
while Present (Elmt) loop
Next_Elmt (Elmt);
New_Itype := Node (Elmt);
Copy_Itype_With_Replacement (New_Itype);
Next_Elmt (Elmt);
end loop;
end;
end if;
-- Now we can copy the actual tree
return Copy_Node_With_Replacement (Source);
end New_Copy_Tree;
-------------------------
-- New_External_Entity --
-------------------------

51
gcc/ada/sem_util.ads
View File

@ -876,6 +876,57 @@ package Sem_Util is
-- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that
-- results from an indexing of a function call written in prefix form.
function New_Copy_List_Tree (List : List_Id) return List_Id;
-- Copy recursively an analyzed list of nodes. Uses New_Copy_Tree defined
-- below. As for New_Copy_Tree, it is illegal to attempt to copy extended
-- nodes (entities) either directly or indirectly using this function.
function New_Copy_Tree
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id;
-- Given a node that is the root of a subtree, Copy_Tree copies the entire
-- syntactic subtree, including recursively any descendents whose parent
-- field references a copied node (descendents not linked to a copied node
-- by the parent field are not copied, instead the copied tree references
-- the same descendent as the original in this case, which is appropriate
-- for non-syntactic fields such as Etype). The parent pointers in the
-- copy are properly set. Copy_Tree (Empty/Error) returns Empty/Error.
-- The one exception to the rule of not copying semantic fields is that
-- any implicit types attached to the subtree are duplicated, so that
-- the copy contains a distinct set of implicit type entities. Thus this
-- function is used when it is necessary to duplicate an analyzed tree,
-- declared in the same or some other compilation unit. This function is
-- declared here rather than in atree because it uses semantic information
-- in particular concerning the structure of itypes and the generation of
-- public symbols.
-- The Map argument, if set to a non-empty Elist, specifies a set of
-- mappings to be applied to entities in the tree. The map has the form:
--
-- old entity 1
-- new entity to replace references to entity 1
-- old entity 2
-- new entity to replace references to entity 2
-- ...
--
-- The call destroys the contents of Map in this case
--
-- The parameter New_Sloc, if set to a value other than No_Location, is
-- used as the Sloc value for all nodes in the new copy. If New_Sloc is
-- set to its default value No_Location, then the Sloc values of the
-- nodes in the copy are simply copied from the corresponding original.
--
-- The Comes_From_Source indication is unchanged if New_Sloc is set to
-- the default No_Location value, but is reset if New_Sloc is given, since
-- in this case the result clearly is neither a source node or an exact
-- copy of a source node.
--
-- The parameter New_Scope, if set to a value other than Empty, is the
-- value to use as the Scope for any Itypes that are copied. The most
-- typical value for this parameter, if given, is Current_Scope.
function New_External_Entity
(Kind : Entity_Kind;
Scope_Id : Entity_Id;