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 --
-----------------------
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 --
-------------------------
OSDN Git Service
