diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 32 | ||||
| -rw-r--r-- | gcc/ada/atree.adb | 102 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 91 | ||||
| -rw-r--r-- | gcc/ada/lib-load.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/nlists.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/nlists.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/par-ch6.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/prj.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 978 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 51 |
10 files changed, 1168 insertions, 135 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index eaa602b..1533016 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 027df3c..3745b38 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -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 -- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index df25f6e..8807638 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -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 diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 1ceb389..857b609 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -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; diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 7a2b4b4..09bd85a 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -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 -- -------------- diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 5a6b94f..3753936 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -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 diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 263efe1..d91b2d9 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -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; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 73e1f40..d8f368d 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d036c85..337d1ac 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ce6d4bd..4046b78 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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; |