From 8e636ab764cc6444af7c8e3ed1f00e3542285972 Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 2 Sep 2011 07:14:48 +0000 Subject: [PATCH] 2011-09-02 Bob Duff * einfo.adb: (Has_Xref_Entry): Do not call Implementation_Base_Type. Lib.Xref has been rewritten to avoid the need for it, and it was costly. * s-htable.ads,s-htable.adb: (Present,Set_If_Not_Present): New functions in support of efficient xref. * lib-xref-alfa.adb: Misc changes related to Key component of type Xref_Entry. * lib-xref.adb: (Add_Entry,etc): Speed improvement. (New_Entry): Call Implementation_Base_Type, because Has_Xref_Entry no longer does. This is the one place where it is needed. 2011-09-02 Johannes Kanig * g-comlin.adb (Getopt): New optional argument Concatenate to have similar interface as the other Getopt function. 2011-09-02 Hristian Kirtchev * exp_ch4.adb: (Expand_Allocator_Expression): Do not generate a call to Set_Finalize_Address if there is no allocator available. * exp_util.adb: (Build_Allocate_Deallocate_Proc): Account for a case of allocator expansion where the allocator is not expanded but needs a custom allocate routine. Code reformatting. (Is_Finalizable_Transient): Remove local variables Has_Rens and Ren_Obj. Code reformatting. (Is_Renamed): Renamed to Is_Aliased. Add code to detect aliasing through the use of 'reference. * sem_ch4.adb: (Analyze_Allocator): Detect allocators generated as part of build-in-place expansion. They are intentionally marked as coming from source, but their parents are not. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178436 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 33 ++++ gcc/ada/einfo.adb | 2 +- gcc/ada/exp_ch4.adb | 5 +- gcc/ada/exp_util.adb | 135 ++++++++------ gcc/ada/g-comlin.adb | 9 +- gcc/ada/g-comlin.ads | 10 +- gcc/ada/lib-xref-alfa.adb | 119 ++++++------ gcc/ada/lib-xref.adb | 462 ++++++++++++++++++++++++++++------------------ gcc/ada/s-htable.adb | 37 +++- gcc/ada/s-htable.ads | 10 +- gcc/ada/sem_ch4.adb | 6 + 11 files changed, 530 insertions(+), 298 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ab6922..8f63086 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2011-09-02 Bob Duff + + * einfo.adb: (Has_Xref_Entry): Do not call + Implementation_Base_Type. Lib.Xref has been + rewritten to avoid the need for it, and it was costly. + * s-htable.ads,s-htable.adb: (Present,Set_If_Not_Present): New + functions in support of efficient xref. + * lib-xref-alfa.adb: Misc changes related to Key component of + type Xref_Entry. + * lib-xref.adb: (Add_Entry,etc): Speed improvement. + (New_Entry): Call Implementation_Base_Type, because Has_Xref_Entry + no longer does. This is the one place where it is needed. + +2011-09-02 Johannes Kanig + + * g-comlin.adb (Getopt): New optional argument Concatenate to have + similar interface as the other Getopt function. + +2011-09-02 Hristian Kirtchev + + * exp_ch4.adb: (Expand_Allocator_Expression): Do not generate + a call to Set_Finalize_Address if there is no allocator available. + * exp_util.adb: (Build_Allocate_Deallocate_Proc): Account for + a case of allocator expansion where the allocator is not expanded but + needs a custom allocate routine. Code reformatting. + (Is_Finalizable_Transient): Remove local variables Has_Rens and + Ren_Obj. Code reformatting. + (Is_Renamed): Renamed to Is_Aliased. Add code to detect aliasing + through the use of 'reference. + * sem_ch4.adb: (Analyze_Allocator): Detect allocators generated + as part of build-in-place expansion. They are intentionally marked as + coming from source, but their parents are not. + 2011-09-02 Ed Schonberg * sem_ch10.adb (Analyze_With_Clause): If the library unit diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index dbe5c26..494f31b 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -1599,7 +1599,7 @@ package body Einfo is function Has_Xref_Entry (Id : E) return B is begin - return Flag182 (Implementation_Base_Type (Id)); + return Flag182 (Id); end Has_Xref_Entry; function Hiding_Loop_Variable (Id : E) return E is diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 65735b8..3c6754b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1137,11 +1137,14 @@ package body Exp_Ch4 is -- Since .NET/JVM compilers do not support address arithmetic, -- this call is skipped. The same is done for CodePeer because - -- primitive Finalize_Address is never generated. + -- primitive Finalize_Address is never generated. Do not create + -- this call if there is no allocator available any more. if VM_Target = No_VM and then not CodePeer_Mode and then Present (Finalization_Master (PtrT)) + and then Present (Temp_Decl) + and then Nkind (Expression (Temp_Decl)) = N_Allocator then Insert_Action (N, Make_Set_Finalize_Address_Call diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index bc323a8..65311f8 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -494,13 +494,39 @@ package body Exp_Util is Expr := N; end if; - Ptr_Typ := Base_Type (Etype (Expr)); + -- In certain cases an allocator with a qualified expression may + -- be relocated and used as the initialization expression of a + -- temporary: + + -- before: + -- Obj : Ptr_Typ := new Desig_Typ'(...); + + -- after: + -- Tmp : Ptr_Typ := new Desig_Typ'(...); + -- Obj : Ptr_Typ := Tmp; + + -- Since the allocator is always marked as analyzed to avoid infinite + -- expansion, it will never be processed by this routine given that + -- the designated type needs finalization actions. Detect this case + -- and complete the expansion of the allocator. + + if Nkind (Expr) = N_Identifier + and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration + and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator + then + Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True); + return; + end if; - -- The allocator may have been rewritten into something else + -- The allocator may have been rewritten into something else in which + -- case the expansion performed by this routine does not apply. - if Nkind (Expr) = N_Allocator then - Proc_To_Call := Procedure_To_Call (Expr); + if Nkind (Expr) /= N_Allocator then + return; end if; + + Ptr_Typ := Base_Type (Etype (Expr)); + Proc_To_Call := Procedure_To_Call (Expr); end if; Pool_Id := Associated_Storage_Pool (Ptr_Typ); @@ -3723,11 +3749,9 @@ package body Exp_Util is (Decl : Node_Id; Rel_Node : Node_Id) return Boolean is - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); - Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); - Desig : Entity_Id := Obj_Typ; - Has_Rens : Boolean := True; - Ren_Obj : Entity_Id; + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); + Desig : Entity_Id := Obj_Typ; function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean; -- Determine whether transient object Trans_Id is initialized either @@ -3741,14 +3765,15 @@ package body Exp_Util is -- value 1 and BIPaccess is not null. This case creates an aliasing -- between the returned value and the value denoted by BIPaccess. - function Is_Allocated (Trans_Id : Entity_Id) return Boolean; - -- Determine whether transient object Trans_Id is allocated on the heap - - function Is_Renamed + function Is_Aliased (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean; - -- Determine whether transient object Trans_Id has been renamed in the - -- statement list starting from First_Stmt. + -- Determine whether transient object Trans_Id has been renamed or + -- aliased through 'reference in the statement list starting from + -- First_Stmt. + + function Is_Allocated (Trans_Id : Entity_Id) return Boolean; + -- Determine whether transient object Trans_Id is allocated on the heap --------------------------- -- Initialized_By_Access -- @@ -3849,30 +3874,14 @@ package body Exp_Util is return False; end Initialized_By_Aliased_BIP_Func_Call; - ------------------ - -- Is_Allocated -- - ------------------ - - function Is_Allocated (Trans_Id : Entity_Id) return Boolean is - Expr : constant Node_Id := Expression (Parent (Trans_Id)); - - begin - return - Is_Access_Type (Etype (Trans_Id)) - and then Present (Expr) - and then Nkind (Expr) = N_Allocator; - end Is_Allocated; - ---------------- - -- Is_Renamed -- + -- Is_Aliased -- ---------------- - function Is_Renamed + function Is_Aliased (Trans_Id : Entity_Id; First_Stmt : Node_Id) return Boolean is - Stmt : Node_Id; - function Extract_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id; -- Given an object renaming declaration, retrieve the entity of the @@ -3918,26 +3927,30 @@ package body Exp_Util is return Empty; end Extract_Renamed_Object; - -- Start of processing for Is_Renamed - - begin - -- If a previous invocation of this routine has determined that a - -- list has no renamings, then no point in repeating the same scan. - - if not Has_Rens then - return False; - end if; + -- Local variables - -- Assume that the statement list does not have a renaming. This is a - -- minor optimization. + Expr : Node_Id; + Ren_Obj : Entity_Id; + Stmt : Node_Id; - Has_Rens := False; + -- Start of processing for Is_Aliased + begin Stmt := First_Stmt; while Present (Stmt) loop - if Nkind (Stmt) = N_Object_Renaming_Declaration then - Has_Rens := True; - Ren_Obj := Extract_Renamed_Object (Stmt); + if Nkind (Stmt) = N_Object_Declaration then + Expr := Expression (Stmt); + + if Present (Expr) + and then Nkind (Expr) = N_Reference + and then Nkind (Prefix (Expr)) = N_Identifier + and then Entity (Prefix (Expr)) = Trans_Id + then + return True; + end if; + + elsif Nkind (Stmt) = N_Object_Renaming_Declaration then + Ren_Obj := Extract_Renamed_Object (Stmt); if Present (Ren_Obj) and then Ren_Obj = Trans_Id @@ -3950,7 +3963,21 @@ package body Exp_Util is end loop; return False; - end Is_Renamed; + end Is_Aliased; + + ------------------ + -- Is_Allocated -- + ------------------ + + function Is_Allocated (Trans_Id : Entity_Id) return Boolean is + Expr : constant Node_Id := Expression (Parent (Trans_Id)); + + begin + return + Is_Access_Type (Etype (Trans_Id)) + and then Present (Expr) + and then Nkind (Expr) = N_Allocator; + end Is_Allocated; -- Start of processing for Is_Finalizable_Transient @@ -3967,6 +3994,11 @@ package body Exp_Util is and then Requires_Transient_Scope (Desig) and then Nkind (Rel_Node) /= N_Simple_Return_Statement + -- Do not consider renamed or 'reference-d transient objects because + -- the act of renaming extends the object's lifetime. + + and then not Is_Aliased (Obj_Id, Decl) + -- Do not consider transient objects allocated on the heap since they -- are attached to a finalization master. @@ -3985,11 +4017,6 @@ package body Exp_Util is and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id) - -- Do not consider renamed transient objects because the act of - -- renaming extends the object's lifetime. - - and then not Is_Renamed (Obj_Id, Decl) - -- Do not consider conversions of tags to class-wide types and then not Is_Tag_To_CW_Conversion (Obj_Id); diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index 43a6524..cce88b9 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -3236,9 +3236,10 @@ package body GNAT.Command_Line is ------------ procedure Getopt - (Config : Command_Line_Configuration; - Callback : Switch_Handler := null; - Parser : Opt_Parser := Command_Line_Parser) + (Config : Command_Line_Configuration; + Callback : Switch_Handler := null; + Parser : Opt_Parser := Command_Line_Parser; + Concatenate : Boolean := True) is Getopt_Switches : String_Access; C : Character := ASCII.NUL; @@ -3373,7 +3374,7 @@ package body GNAT.Command_Line is loop C := Getopt (Switches => Getopt_Switches.all, - Concatenate => True, + Concatenate => Concatenate, Parser => Parser); if C = '*' then diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index f1b2163..f19d7ba 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -703,9 +703,10 @@ package GNAT.Command_Line is -- switch. procedure Getopt - (Config : Command_Line_Configuration; - Callback : Switch_Handler := null; - Parser : Opt_Parser := Command_Line_Parser); + (Config : Command_Line_Configuration; + Callback : Switch_Handler := null; + Parser : Opt_Parser := Command_Line_Parser; + Concatenate : Boolean := True); -- Similar to the standard Getopt function. -- For each switch found on the command line, this calls Callback, if the -- switch is not handled automatically. @@ -716,6 +717,9 @@ package GNAT.Command_Line is -- variable). This function will in fact never call [Callback] if all -- switches were handled automatically and there is nothing left to do. -- + -- The option Concatenate is identical to the one of the standard Getopt + -- function. + -- -- This procedure automatically adds -h and --help to the valid switches, -- to display the help message and raises Exit_From_Command_Line. -- If an invalid switch is specified on the command line, this procedure diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 25b7b79..8a29818 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -456,10 +456,11 @@ package body Alfa is -- Second test: within same unit, sort by location of the scope of -- the entity definition. - elsif Get_Scope_Num (T1.Ent_Scope) /= - Get_Scope_Num (T2.Ent_Scope) + elsif Get_Scope_Num (T1.Key.Ent_Scope) /= + Get_Scope_Num (T2.Key.Ent_Scope) then - return Get_Scope_Num (T1.Ent_Scope) < Get_Scope_Num (T2.Ent_Scope); + return Get_Scope_Num (T1.Key.Ent_Scope) < + Get_Scope_Num (T2.Key.Ent_Scope); -- Third test: within same unit and scope, sort by location of -- entity definition. @@ -470,41 +471,47 @@ package body Alfa is -- Fourth test: if reference is in same unit as entity definition, -- sort first. - elsif T1.Lun /= T2.Lun and then T1.Ent_Scope_File = T1.Lun then + elsif + T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun + then return True; - elsif T1.Lun /= T2.Lun and then T2.Ent_Scope_File = T2.Lun then + + elsif + T1.Key.Lun /= T2.Key.Lun and then T2.Ent_Scope_File = T2.Key.Lun + then return False; -- Fifth test: if reference is in same unit and same scope as entity -- definition, sort first. - elsif T1.Ent_Scope_File = T1.Lun - and then T1.Ref_Scope /= T2.Ref_Scope - and then T1.Ent_Scope = T1.Ref_Scope + elsif T1.Ent_Scope_File = T1.Key.Lun + and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope + and then T1.Key.Ent_Scope = T1.Key.Ref_Scope then return True; - elsif T1.Ent_Scope_File = T1.Lun - and then T1.Ref_Scope /= T2.Ref_Scope - and then T2.Ent_Scope = T2.Ref_Scope + elsif T1.Ent_Scope_File = T1.Key.Lun + and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope + and then T2.Key.Ent_Scope = T2.Key.Ref_Scope then return False; -- Sixth test: for same entity, sort by reference location unit - elsif T1.Lun /= T2.Lun then - return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun); + elsif T1.Key.Lun /= T2.Key.Lun then + return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun); -- Seventh test: for same entity, sort by reference location scope - elsif Get_Scope_Num (T1.Ref_Scope) /= - Get_Scope_Num (T2.Ref_Scope) + elsif Get_Scope_Num (T1.Key.Ref_Scope) /= + Get_Scope_Num (T2.Key.Ref_Scope) then - return Get_Scope_Num (T1.Ref_Scope) < Get_Scope_Num (T2.Ref_Scope); + return Get_Scope_Num (T1.Key.Ref_Scope) < + Get_Scope_Num (T2.Key.Ref_Scope); -- Eighth test: order of location within referencing unit - elsif T1.Loc /= T2.Loc then - return T1.Loc < T2.Loc; + elsif T1.Key.Loc /= T2.Key.Loc then + return T1.Key.Loc < T2.Key.Loc; -- Finally, for two locations at the same address prefer the one that -- does NOT have the type 'r', so that a modification or extension @@ -513,7 +520,7 @@ package body Alfa is -- in-out actuals, the read reference follows the modify reference. else - return T2.Typ = 'r'; + return T2.Key.Typ = 'r'; end if; end Lt; @@ -563,7 +570,7 @@ package body Alfa is -- Set entity at this point with newly created "Heap" variable - Xrefs.Table (Xrefs.Last).Ent := Heap; + Xrefs.Table (Xrefs.Last).Key.Ent := Heap; Nrefs := Nrefs + 1; Rnums (Nrefs) := Xrefs.Last; @@ -637,13 +644,13 @@ package body Alfa is Nrefs := 0; for J in 1 .. NR loop - if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Ent)) - and then Alfa_References (Xrefs.Table (Rnums (J)).Typ) - and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Ent_Scope) - and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Ref_Scope) - and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Ent) - and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Ent, - Xrefs.Table (Rnums (J)).Typ) + if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Key.Ent)) + and then Alfa_References (Xrefs.Table (Rnums (J)).Key.Typ) + and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ent_Scope) + and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ref_Scope) + and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Key.Ent) + and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Key.Ent, + Xrefs.Table (Rnums (J)).Key.Typ) then Nrefs := Nrefs + 1; Rnums (Nrefs) := Rnums (J); @@ -695,12 +702,12 @@ package body Alfa is Prevt := 'm'; for J in 1 .. NR loop - if Xrefs.Table (Rnums (J)).Loc /= Crloc + if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc or else (Prevt = 'm' - and then Xrefs.Table (Rnums (J)).Typ = 'r') + and then Xrefs.Table (Rnums (J)).Key.Typ = 'r') then - Crloc := Xrefs.Table (Rnums (J)).Loc; - Prevt := Xrefs.Table (Rnums (J)).Typ; + Crloc := Xrefs.Table (Rnums (J)).Key.Loc; + Prevt := Xrefs.Table (Rnums (J)).Key.Typ; Nrefs := Nrefs + 1; Rnums (Nrefs) := Rnums (J); end if; @@ -814,13 +821,13 @@ package body Alfa is -- construction of the scope table, or an erroneous scope for the -- current cross-reference. - pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope)); + pragma Assert (Is_Future_Scope_Entity (XE.Key.Ent_Scope)); -- Update the range of cross references to which the current scope -- refers to. This may be the empty range only for the first scope -- considered. - if XE.Ent_Scope /= Cur_Scope then + if XE.Key.Ent_Scope /= Cur_Scope then Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx; Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := @@ -828,39 +835,39 @@ package body Alfa is From_Xref_Idx := Alfa_Xref_Table.Last + 1; end if; - while XE.Ent_Scope /= Cur_Scope loop + while XE.Key.Ent_Scope /= Cur_Scope loop Cur_Scope_Idx := Cur_Scope_Idx + 1; pragma Assert (Cur_Scope_Idx <= Alfa_Scope_Table.Last); end loop; - if XE.Ent /= Cur_Entity then + if XE.Key.Ent /= Cur_Entity then Cur_Entity_Name := - new String'(Unique_Name (XE.Ent)); + new String'(Unique_Name (XE.Key.Ent)); end if; - if XE.Ent = Heap then + if XE.Key.Ent = Heap then Alfa_Xref_Table.Append ( (Entity_Name => Cur_Entity_Name, Entity_Line => 0, - Etype => Get_Entity_Type (XE.Ent), + Etype => Get_Entity_Type (XE.Key.Ent), Entity_Col => 0, - File_Num => Dependency_Num (XE.Lun), - Scope_Num => Get_Scope_Num (XE.Ref_Scope), - Line => Int (Get_Logical_Line_Number (XE.Loc)), - Rtype => XE.Typ, - Col => Int (Get_Column_Number (XE.Loc)))); + File_Num => Dependency_Num (XE.Key.Lun), + Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope), + Line => Int (Get_Logical_Line_Number (XE.Key.Loc)), + Rtype => XE.Key.Typ, + Col => Int (Get_Column_Number (XE.Key.Loc)))); else Alfa_Xref_Table.Append ( (Entity_Name => Cur_Entity_Name, Entity_Line => Int (Get_Logical_Line_Number (XE.Def)), - Etype => Get_Entity_Type (XE.Ent), + Etype => Get_Entity_Type (XE.Key.Ent), Entity_Col => Int (Get_Column_Number (XE.Def)), - File_Num => Dependency_Num (XE.Lun), - Scope_Num => Get_Scope_Num (XE.Ref_Scope), - Line => Int (Get_Logical_Line_Number (XE.Loc)), - Rtype => XE.Typ, - Col => Int (Get_Column_Number (XE.Loc)))); + File_Num => Dependency_Num (XE.Key.Lun), + Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope), + Line => Int (Get_Logical_Line_Number (XE.Key.Loc)), + Rtype => XE.Key.Typ, + Col => Int (Get_Column_Number (XE.Key.Loc)))); end if; end Add_One_Xref; end loop; @@ -1071,20 +1078,20 @@ package body Alfa is -- Entity is filled later on with the special "Heap" variable - Drefs.Table (Indx).Ent := Empty; + Drefs.Table (Indx).Key.Ent := Empty; Drefs.Table (Indx).Def := No_Location; - Drefs.Table (Indx).Loc := Ref; - Drefs.Table (Indx).Typ := Typ; + Drefs.Table (Indx).Key.Loc := Ref; + Drefs.Table (Indx).Key.Typ := Typ; -- It is as if the special "Heap" was defined in every scope where it -- is referenced. - Drefs.Table (Indx).Eun := Get_Source_Unit (Ref); - Drefs.Table (Indx).Lun := Get_Source_Unit (Ref); + Drefs.Table (Indx).Key.Eun := Get_Source_Unit (Ref); + Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref); - Drefs.Table (Indx).Ref_Scope := Ref_Scope; - Drefs.Table (Indx).Ent_Scope := Ref_Scope; + Drefs.Table (Indx).Key.Ref_Scope := Ref_Scope; + Drefs.Table (Indx).Key.Ent_Scope := Ref_Scope; Drefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ref_Scope); end if; end Generate_Dereference; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 4bc7ed4..2dbf5ff 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -44,6 +44,7 @@ with Stand; use Stand; with Table; use Table; with GNAT.Heap_Sort_G; +with GNAT.HTable; package body Lib.Xref is @@ -56,16 +57,13 @@ package body Lib.Xref is subtype Xref_Entry_Number is Int; - type Xref_Entry is record + type Xref_Key is record + -- These are the components of Xref_Entry that participate in hash + -- lookups. + Ent : Entity_Id; -- Entity referenced (E parameter to Generate_Reference) - Def : Source_Ptr; - -- Original source location for entity being referenced. Note that these - -- values are used only during the output process, they are not set when - -- the entries are originally built. This is because private entities - -- can be swapped when the initial call is made. - Loc : Source_Ptr; -- Location of reference (Original_Location (Sloc field of N parameter -- to Generate_Reference). Set to No_Location for the case of a @@ -89,9 +87,22 @@ package body Lib.Xref is Ent_Scope : Entity_Id; -- Entity of the closest subprogram or package enclosing the definition, -- which should be located in the same file as the definition itself. + end record; + + type Xref_Entry is record + Key : Xref_Key; Ent_Scope_File : Unit_Number_Type; -- File for entity Ent_Scope + + Def : Source_Ptr; + -- Original source location for entity being referenced. Note that these + -- values are used only during the output process, they are not set when + -- the entries are originally built. This is because private entities + -- can be swapped when the initial call is made. + + HTable_Next : Xref_Entry_Number; + -- For use only by Static_HTable end record; package Xrefs is new Table.Table ( @@ -102,6 +113,44 @@ package body Lib.Xref is Table_Increment => Alloc.Xrefs_Increment, Table_Name => "Xrefs"); + -------------- + -- Xref_Set -- + -------------- + + -- We keep a set of xref entries, in order to avoid inserting duplicate + -- entries into the above Xrefs table. An entry is in Xref_Set if and only + -- if it is in Xrefs. + + Num_Buckets : constant := 2**16; + + subtype Header_Num is Integer range 0 .. Num_Buckets - 1; + type Null_Type is null record; + pragma Unreferenced (Null_Type); + + function Hash (F : Xref_Entry_Number) return Header_Num; + + function Equal (F1, F2 : Xref_Entry_Number) return Boolean; + + procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number); + + function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number; + + function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number; + + pragma Inline (Hash, Equal, HT_Set_Next, HT_Next, Get_Key); + + package Xref_Set is new GNAT.HTable.Static_HTable ( + Header_Num, + Element => Xref_Entry, + Elmt_Ptr => Xref_Entry_Number, + Null_Ptr => 0, + Set_Next => HT_Set_Next, + Next => HT_Next, + Key => Xref_Entry_Number, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + ---------------------- -- Alfa Information -- ---------------------- @@ -121,14 +170,51 @@ package body Lib.Xref is function Lt (T1, T2 : Xref_Entry) return Boolean; -- Order cross-references + procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type); + -- Add an entry to the tables of Xref_Entries, avoiding duplicates + + --------------- + -- Add_Entry -- + --------------- + + procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type) is + begin + Xrefs.Increment_Last; -- tentative + Xrefs.Table (Xrefs.Last).Key := Key; + + -- Set the entry in Xref_Set, and if newly set, keep the above + -- tentative increment. + + if Xref_Set.Set_If_Not_Present (Xrefs.Last) then + Xrefs.Table (Xrefs.Last).Ent_Scope_File := Ent_Scope_File; + -- Leave Def and HTable_Next uninitialized + + Set_Has_Xref_Entry (Key.Ent); + + -- It was already in Xref_Set, so throw away the tentatively-added + -- entry + + else + Xrefs.Decrement_Last; + end if; + end Add_Entry; + + ----------- + -- Equal -- + ----------- + + function Equal (F1, F2 : Xref_Entry_Number) return Boolean is + Result : constant Boolean := + Xrefs.Table (F1).Key = Xrefs.Table (F2).Key; + begin + return Result; + end Equal; + ------------------------- -- Generate_Definition -- ------------------------- procedure Generate_Definition (E : Entity_Id) is - Loc : Source_Ptr; - Indx : Nat; - begin pragma Assert (Nkind (E) in N_Entity); @@ -159,22 +245,15 @@ package body Lib.Xref is and then In_Extended_Main_Source_Unit (E) and then not Is_Internal_Name (Chars (E)) then - Xrefs.Increment_Last; - Indx := Xrefs.Last; - Loc := Original_Location (Sloc (E)); - - Xrefs.Table (Indx).Ent := E; - Xrefs.Table (Indx).Typ := ' '; - Xrefs.Table (Indx).Def := No_Location; - Xrefs.Table (Indx).Loc := No_Location; - - Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc); - - Xrefs.Table (Indx).Ref_Scope := Empty; - Xrefs.Table (Indx).Ent_Scope := Empty; - Xrefs.Table (Indx).Ent_Scope_File := No_Unit; - - Set_Has_Xref_Entry (E); + Add_Entry + ((Ent => E, + Loc => No_Location, + Typ => ' ', + Eun => Get_Source_Unit (Original_Location (Sloc (E))), + Lun => No_Unit, + Ref_Scope => Empty, + Ent_Scope => Empty), + Ent_Scope_File => No_Unit); if In_Inlined_Body then Set_Referenced (E); @@ -294,14 +373,16 @@ package body Lib.Xref is Set_Ref : Boolean := True; Force : Boolean := False) is - Indx : Nat; Nod : Node_Id; Ref : Source_Ptr; Def : Source_Ptr; Ent : Entity_Id; - Ref_Scope : Entity_Id; - Ent_Scope : Entity_Id; + Actual_Typ : Character := Typ; + + Ref_Scope : Entity_Id; + Ent_Scope : Entity_Id; + Ent_Scope_File : Unit_Number_Type; Call : Node_Id; Formal : Entity_Id; @@ -865,34 +946,33 @@ package body Lib.Xref is Ref := Original_Location (Sloc (Nod)); Def := Original_Location (Sloc (Ent)); - Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N); - Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); - - Xrefs.Increment_Last; - Indx := Xrefs.Last; - - Xrefs.Table (Indx).Loc := Ref; - - -- Overriding operations are marked with 'P' - - if Typ = 'p' + if Actual_Typ = 'p' and then Is_Subprogram (N) and then Present (Overridden_Operation (N)) then - Xrefs.Table (Indx).Typ := 'P'; - else - Xrefs.Table (Indx).Typ := Typ; + Actual_Typ := 'P'; end if; - Xrefs.Table (Indx).Eun := Get_Source_Unit (Def); - Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref); - Xrefs.Table (Indx).Ent := Ent; + if Alfa_Mode then + Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N); + Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); + Ent_Scope_File := Get_Source_Unit (Ent_Scope); - Xrefs.Table (Indx).Ref_Scope := Ref_Scope; - Xrefs.Table (Indx).Ent_Scope := Ent_Scope; - Xrefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ent_Scope); + else + Ref_Scope := Empty; + Ent_Scope := Empty; + Ent_Scope_File := No_Unit; + end if; - Set_Has_Xref_Entry (Ent); + Add_Entry + ((Ent => Ent, + Loc => Ref, + Typ => Actual_Typ, + Eun => Get_Source_Unit (Def), + Lun => Get_Source_Unit (Ref), + Ref_Scope => Ref_Scope, + Ent_Scope => Ent_Scope), + Ent_Scope_File => Ent_Scope_File); end if; end Generate_Reference; @@ -957,6 +1037,49 @@ package body Lib.Xref is end loop; end Generate_Reference_To_Generic_Formals; + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number is + begin + return E; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Xref_Entry_Number) return Header_Num is + -- It is unlikely to have two references to the same entity at the same + -- source location, so the hash function depends only on the Ent and Loc + -- fields. + + XE : Xref_Entry renames Xrefs.Table (F); + type M is mod 2**32; + H : constant M := M'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc); + begin + return Header_Num (H mod Num_Buckets); + end Hash; + + ----------------- + -- HT_Set_Next -- + ----------------- + + procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number) is + begin + Xrefs.Table (E).HTable_Next := Next; + end HT_Set_Next; + + ------------- + -- HT_Next -- + ------------- + + function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number is + begin + return Xrefs.Table (E).HTable_Next; + end HT_Next; + ---------------- -- Initialize -- ---------------- @@ -974,8 +1097,8 @@ package body Lib.Xref is begin -- First test: if entity is in different unit, sort by unit - if T1.Eun /= T2.Eun then - return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun); + if T1.Key.Eun /= T2.Key.Eun then + return Dependency_Num (T1.Key.Eun) < Dependency_Num (T2.Key.Eun); -- Second test: within same unit, sort by entity Sloc @@ -984,21 +1107,21 @@ package body Lib.Xref is -- Third test: sort definitions ahead of references - elsif T1.Loc = No_Location then + elsif T1.Key.Loc = No_Location then return True; - elsif T2.Loc = No_Location then + elsif T2.Key.Loc = No_Location then return False; -- Fourth test: for same entity, sort by reference location unit - elsif T1.Lun /= T2.Lun then - return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun); + elsif T1.Key.Lun /= T2.Key.Lun then + return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun); -- Fifth test: order of location within referencing unit - elsif T1.Loc /= T2.Loc then - return T1.Loc < T2.Loc; + elsif T1.Key.Loc /= T2.Key.Loc then + return T1.Key.Loc < T2.Key.Loc; -- Finally, for two locations at the same address, we prefer -- the one that does NOT have the type 'r' so that a modification @@ -1008,7 +1131,7 @@ package body Lib.Xref is -- the modify reference. else - return T2.Typ = 'r'; + return T2.Key.Typ = 'r'; end if; end Lt; @@ -1245,7 +1368,7 @@ package body Lib.Xref is begin for J in 1 .. Xrefs.Last loop - Ent := Xrefs.Table (J).Ent; + Ent := Xrefs.Table (J).Key.Ent; if Is_Type (Ent) and then Is_Tagged_Type (Ent) @@ -1283,9 +1406,7 @@ package body Lib.Xref is Handle_Orphan_Type_References : declare J : Nat; Tref : Entity_Id; - Indx : Nat; Ent : Entity_Id; - Loc : Source_Ptr; L, R : Character; pragma Warnings (Off, L); @@ -1302,18 +1423,20 @@ package body Lib.Xref is procedure New_Entry (E : Entity_Id) is begin - if Present (E) - and then not Has_Xref_Entry (E) + pragma Assert (Present (E)); + + if not Has_Xref_Entry (Implementation_Base_Type (E)) and then Sloc (E) > No_Location then - Xrefs.Increment_Last; - Indx := Xrefs.Last; - Loc := Original_Location (Sloc (E)); - Xrefs.Table (Indx).Ent := E; - Xrefs.Table (Indx).Loc := No_Location; - Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc); - Xrefs.Table (Indx).Lun := No_Unit; - Set_Has_Xref_Entry (E); + Add_Entry + ((Ent => E, + Loc => No_Location, + Typ => Character'First, + Eun => Get_Source_Unit (Original_Location (Sloc (E))), + Lun => No_Unit, + Ref_Scope => Empty, + Ent_Scope => Empty), + Ent_Scope_File => No_Unit); end if; end New_Entry; @@ -1326,7 +1449,7 @@ package body Lib.Xref is J := 1; while J <= Xrefs.Last loop - Ent := Xrefs.Table (J).Ent; + Ent := Xrefs.Table (J).Key.Ent; Get_Type_Reference (Ent, Tref, L, R); if Present (Tref) @@ -1393,15 +1516,15 @@ package body Lib.Xref is Prim := Parent_Op (Node (Op)); if Present (Prim) then - Xrefs.Increment_Last; - Indx := Xrefs.Last; - Loc := Original_Location (Sloc (Prim)); - Xrefs.Table (Indx).Ent := Prim; - Xrefs.Table (Indx).Loc := No_Location; - Xrefs.Table (Indx).Eun := - Get_Source_Unit (Sloc (Prim)); - Xrefs.Table (Indx).Lun := No_Unit; - Set_Has_Xref_Entry (Prim); + Add_Entry + ((Ent => Prim, + Loc => No_Location, + Typ => Character'First, + Eun => Get_Source_Unit (Sloc (Prim)), + Lun => No_Unit, + Ref_Scope => Empty, + Ent_Scope => Empty), + Ent_Scope_File => No_Unit); end if; Next_Elmt (Op); @@ -1418,9 +1541,8 @@ package body Lib.Xref is Output_Refs : declare - Nrefs : Nat := Xrefs.Last; - -- Number of references in table. This value may get reset (reduced) - -- when we eliminate duplicate reference entries. + Nrefs : constant Nat := Xrefs.Last; + -- Number of references in table Rnums : array (0 .. Nrefs) of Nat; -- This array contains numbers of references in the Xrefs table. @@ -1523,37 +1645,13 @@ package body Lib.Xref is for J in 1 .. Nrefs loop Rnums (J) := J; Xrefs.Table (J).Def := - Original_Location (Sloc (Xrefs.Table (J).Ent)); + Original_Location (Sloc (Xrefs.Table (J).Key.Ent)); end loop; -- Sort the references Sorting.Sort (Integer (Nrefs)); - -- Eliminate duplicate entries - - declare - NR : constant Nat := Nrefs; - - begin - -- We need this test for NR because if we force ALI file - -- generation in case of errors detected, it may be the case - -- that Nrefs is 0, so we should not reset it here - - if NR >= 2 then - Nrefs := 1; - - for J in 2 .. NR loop - if Xrefs.Table (Rnums (J)) /= - Xrefs.Table (Rnums (Nrefs)) - then - Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); - end if; - end loop; - end if; - end; - -- Initialize loop through references Curxu := No_Unit; @@ -1773,7 +1871,7 @@ package body Lib.Xref is -- Start of processing for Output_One_Ref begin - Ent := XE.Ent; + Ent := XE.Key.Ent; Ctyp := Xref_Entity_Letters (Ekind (Ent)); -- Skip reference if it is the only reference to an entity, @@ -1782,10 +1880,10 @@ package body Lib.Xref is -- consisting only of packages with END lines, where no -- entity from the package is actually referenced. - if XE.Typ = 'e' + if XE.Key.Typ = 'e' and then Ent /= Curent and then (Refno = Nrefs or else - Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent) + Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent) and then not In_Extended_Main_Source_Unit (Ent) then @@ -1795,7 +1893,7 @@ package body Lib.Xref is -- For private type, get full view type if Ctyp = '+' - and then Present (Full_View (XE.Ent)) + and then Present (Full_View (XE.Key.Ent)) then Ent := Underlying_Type (Ent); @@ -1813,15 +1911,15 @@ package body Lib.Xref is -- For variable reference, get corresponding type if Ctyp = '*' then - Ent := Etype (XE.Ent); + Ent := Etype (XE.Key.Ent); Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent))); -- If variable is private type, get full view type if Ctyp = '+' - and then Present (Full_View (Etype (XE.Ent))) + and then Present (Full_View (Etype (XE.Key.Ent))) then - Ent := Underlying_Type (Etype (XE.Ent)); + Ent := Underlying_Type (Etype (XE.Key.Ent)); if Present (Ent) then Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent))); @@ -1839,13 +1937,13 @@ package body Lib.Xref is -- Special handling for access parameters and objects of -- an anonymous access type. - if Ekind_In (Etype (XE.Ent), + if Ekind_In (Etype (XE.Key.Ent), E_Anonymous_Access_Type, E_Anonymous_Access_Subprogram_Type, E_Anonymous_Access_Protected_Subprogram_Type) then - if Is_Formal (XE.Ent) - or else Ekind_In (XE.Ent, E_Variable, E_Constant) + if Is_Formal (XE.Key.Ent) + or else Ekind_In (XE.Key.Ent, E_Variable, E_Constant) then Ctyp := 'p'; end if; @@ -1859,8 +1957,8 @@ package body Lib.Xref is -- Special handling for abstract types and operations - if Is_Overloadable (XE.Ent) - and then Is_Abstract_Subprogram (XE.Ent) + if Is_Overloadable (XE.Key.Ent) + and then Is_Abstract_Subprogram (XE.Key.Ent) then if Ctyp = 'U' then Ctyp := 'x'; -- Abstract procedure @@ -1869,10 +1967,10 @@ package body Lib.Xref is Ctyp := 'y'; -- Abstract function end if; - elsif Is_Type (XE.Ent) - and then Is_Abstract_Type (XE.Ent) + elsif Is_Type (XE.Key.Ent) + and then Is_Abstract_Type (XE.Key.Ent) then - if Is_Interface (XE.Ent) then + if Is_Interface (XE.Key.Ent) then Ctyp := 'h'; elsif Ctyp = 'R' then @@ -1887,41 +1985,42 @@ package body Lib.Xref is -- Suppress references to object definitions, used for local -- references. - or else XE.Typ = 'D' - or else XE.Typ = 'I' + or else XE.Key.Typ = 'D' + or else XE.Key.Typ = 'I' -- Suppress self references, except for bodies that act as -- specs. - or else (XE.Loc = XE.Def + or else (XE.Key.Loc = XE.Def and then - (XE.Typ /= 'b' - or else not Is_Subprogram (XE.Ent))) + (XE.Key.Typ /= 'b' + or else not Is_Subprogram (XE.Key.Ent))) -- Also suppress definitions of body formals (we only -- treat these as references, and the references were -- separately recorded). - or else (Is_Formal (XE.Ent) - and then Present (Spec_Entity (XE.Ent))) + or else (Is_Formal (XE.Key.Ent) + and then Present (Spec_Entity (XE.Key.Ent))) then null; else -- Start new Xref section if new xref unit - if XE.Eun /= Curxu then + if XE.Key.Eun /= Curxu then if Write_Info_Col > 1 then Write_Info_EOL; end if; - Curxu := XE.Eun; + Curxu := XE.Key.Eun; Write_Info_Initiate ('X'); Write_Info_Char (' '); - Write_Info_Nat (Dependency_Num (XE.Eun)); + Write_Info_Nat (Dependency_Num (XE.Key.Eun)); Write_Info_Char (' '); - Write_Info_Name (Reference_Name (Source_Index (XE.Eun))); + Write_Info_Name + (Reference_Name (Source_Index (XE.Key.Eun))); end if; -- Start new Entity line if new entity. Note that we @@ -1932,14 +2031,14 @@ package body Lib.Xref is if No (Curent) or else - (XE.Ent /= Curent + (XE.Key.Ent /= Curent and then - (Name_Change (XE.Ent) or else XE.Def /= Curdef)) + (Name_Change (XE.Key.Ent) or else XE.Def /= Curdef)) then - Curent := XE.Ent; + Curent := XE.Key.Ent; Curdef := XE.Def; - Get_Unqualified_Name_String (Chars (XE.Ent)); + Get_Unqualified_Name_String (Chars (XE.Key.Ent)); Curlen := Name_Len; Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen); @@ -2051,7 +2150,7 @@ package body Lib.Xref is declare Ent_Name : constant String := - Exact_Source_Name (Sloc (XE.Ent)); + Exact_Source_Name (Sloc (XE.Key.Ent)); begin for C in Ent_Name'Range loop Write_Info_Char (Ent_Name (C)); @@ -2060,22 +2159,22 @@ package body Lib.Xref is -- See if we have a renaming reference - if Is_Object (XE.Ent) - and then Present (Renamed_Object (XE.Ent)) + if Is_Object (XE.Key.Ent) + and then Present (Renamed_Object (XE.Key.Ent)) then - Rref := Renamed_Object (XE.Ent); + Rref := Renamed_Object (XE.Key.Ent); - elsif Is_Overloadable (XE.Ent) - and then Nkind (Parent (Declaration_Node (XE.Ent))) = - N_Subprogram_Renaming_Declaration + elsif Is_Overloadable (XE.Key.Ent) + and then Nkind (Parent (Declaration_Node (XE.Key.Ent))) + = N_Subprogram_Renaming_Declaration then - Rref := Name (Parent (Declaration_Node (XE.Ent))); + Rref := Name (Parent (Declaration_Node (XE.Key.Ent))); - elsif Ekind (XE.Ent) = E_Package - and then Nkind (Declaration_Node (XE.Ent)) = + elsif Ekind (XE.Key.Ent) = E_Package + and then Nkind (Declaration_Node (XE.Key.Ent)) = N_Package_Renaming_Declaration then - Rref := Name (Declaration_Node (XE.Ent)); + Rref := Name (Declaration_Node (XE.Key.Ent)); else Rref := Empty; @@ -2128,12 +2227,13 @@ package body Lib.Xref is -- Write out information about generic parent, if entity -- is an instance. - if Is_Generic_Instance (XE.Ent) then + if Is_Generic_Instance (XE.Key.Ent) then declare Gen_Par : constant Entity_Id := Generic_Parent (Specification - (Unit_Declaration_Node (XE.Ent))); + (Unit_Declaration_Node + (XE.Key.Ent))); Loc : constant Source_Ptr := Sloc (Gen_Par); Gen_U : constant Unit_Number_Type := Get_Source_Unit (Loc); @@ -2154,15 +2254,16 @@ package body Lib.Xref is -- See if we have a type reference and if so output - Check_Type_Reference (XE.Ent, False); + Check_Type_Reference (XE.Key.Ent, False); -- Additional information for types with progenitors - if Is_Record_Type (XE.Ent) - and then Present (Interfaces (XE.Ent)) + if Is_Record_Type (XE.Key.Ent) + and then Present (Interfaces (XE.Key.Ent)) then declare - Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent)); + Elmt : Elmt_Id := + First_Elmt (Interfaces (XE.Key.Ent)); begin while Present (Elmt) loop Check_Type_Reference (Node (Elmt), True); @@ -2173,11 +2274,11 @@ package body Lib.Xref is -- For array types, list index types as well. (This is -- not C, indexes have distinct types). - elsif Is_Array_Type (XE.Ent) then + elsif Is_Array_Type (XE.Key.Ent) then declare Indx : Node_Id; begin - Indx := First_Index (XE.Ent); + Indx := First_Index (XE.Key.Ent); while Present (Indx) loop Check_Type_Reference (First_Subtype (Etype (Indx)), True); @@ -2189,10 +2290,11 @@ package body Lib.Xref is -- If the entity is an overriding operation, write info -- on operation that was overridden. - if Is_Subprogram (XE.Ent) - and then Present (Overridden_Operation (XE.Ent)) + if Is_Subprogram (XE.Key.Ent) + and then Present (Overridden_Operation (XE.Key.Ent)) then - Output_Overridden_Op (Overridden_Operation (XE.Ent)); + Output_Overridden_Op + (Overridden_Operation (XE.Key.Ent)); end if; -- End of processing for entity output @@ -2204,13 +2306,13 @@ package body Lib.Xref is -- as the previous one, or it is a read-reference that -- indicates that the entity is an in-out actual in a call. - if XE.Loc /= No_Location + if XE.Key.Loc /= No_Location and then - (XE.Loc /= Crloc - or else (Prevt = 'm' and then XE.Typ = 'r')) + (XE.Key.Loc /= Crloc + or else (Prevt = 'm' and then XE.Key.Typ = 'r')) then - Crloc := XE.Loc; - Prevt := XE.Typ; + Crloc := XE.Key.Loc; + Prevt := XE.Key.Typ; -- Start continuation if line full, else blank @@ -2223,25 +2325,26 @@ package body Lib.Xref is -- Output file number if changed - if XE.Lun /= Curru then - Curru := XE.Lun; + if XE.Key.Lun /= Curru then + Curru := XE.Key.Lun; Write_Info_Nat (Dependency_Num (Curru)); Write_Info_Char ('|'); end if; - Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc))); - Write_Info_Char (XE.Typ); + Write_Info_Nat + (Int (Get_Logical_Line_Number (XE.Key.Loc))); + Write_Info_Char (XE.Key.Typ); - if Is_Overloadable (XE.Ent) - and then Is_Imported (XE.Ent) - and then XE.Typ = 'b' + if Is_Overloadable (XE.Key.Ent) + and then Is_Imported (XE.Key.Ent) + and then XE.Key.Typ = 'b' then - Output_Import_Export_Info (XE.Ent); + Output_Import_Export_Info (XE.Key.Ent); end if; - Write_Info_Nat (Int (Get_Column_Number (XE.Loc))); + Write_Info_Nat (Int (Get_Column_Number (XE.Key.Loc))); - Output_Instantiation_Refs (Sloc (XE.Ent)); + Output_Instantiation_Refs (Sloc (XE.Key.Ent)); end if; end if; end Output_One_Ref; @@ -2254,4 +2357,9 @@ package body Lib.Xref is end Output_Refs; end Output_References; +begin + -- Reset is necessary because Elmt_Ptr does not default to Null_Ptr, + -- because it's not an access type. + + Xref_Set.Reset; end Lib.Xref; diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb index 898081c..68a4ac3 100644 --- a/gcc/ada/s-htable.adb +++ b/gcc/ada/s-htable.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2011, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -121,6 +121,15 @@ package body System.HTable is return Iterator_Ptr; end Get_Non_Null; + ------------- + -- Present -- + ------------- + + function Present (K : Key) return Boolean is + begin + return Get (K) /= Null_Ptr; + end Present; + ------------ -- Remove -- ------------ @@ -181,6 +190,32 @@ package body System.HTable is Table (Index) := E; end Set; + ------------------------ + -- Set_If_Not_Present -- + ------------------------ + + function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is + K : constant Key := Get_Key (E); + Index : constant Header_Num := Hash (K); + Elmt : Elmt_Ptr := Table (Index); + + begin + loop + if Elmt = Null_Ptr then + Set_Next (E, Table (Index)); + Table (Index) := E; + + return True; + + elsif Equal (Get_Key (Elmt), K) then + return False; + + else + Elmt := Next (Elmt); + end if; + end loop; + end Set_If_Not_Present; + end Static_HTable; ------------------- diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads index 58def27b1..29fb5fb 100644 --- a/gcc/ada/s-htable.ads +++ b/gcc/ada/s-htable.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2011, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -183,6 +183,14 @@ package System.HTable is -- Returns the latest inserted element pointer with the given Key -- or null if none. + function Present (K : Key) return Boolean; + -- True if an element whose Get_Key is K is in the table + + function Set_If_Not_Present (E : Elmt_Ptr) return Boolean; + -- If Present (Get_Key (E)), returns False. Otherwise, does Set (E), and + -- then returns True. Present (Get_Key (E)) is always True afterward, + -- and the result True indicates E is newly Set. + procedure Remove (K : Key); -- Removes the latest inserted element pointer associated with the -- given key if any, does nothing if none. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e5299b2..3f04964 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -490,8 +490,14 @@ package body Sem_Ch4 is Resolve (Expression (E), Type_Id); + -- Allocators generated by the build-in-place expansion mechanism + -- are explicitly marked as coming from source but do not need to be + -- checked for limited initialization. To exclude this case, ensure + -- that the parent of the allocator is a source node. + if Is_Limited_Type (Type_Id) and then Comes_From_Source (N) + and then Comes_From_Source (Parent (N)) and then not In_Instance_Body then if not OK_For_Limited_Init (Type_Id, Expression (E)) then -- 2.7.4