From aab081301183b100541e48100c11281435b9e286 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 22 Feb 2012 15:06:51 +0100 Subject: [PATCH] [multiple changes] 2012-02-22 Hristian Kirtchev * exp_ch7.adb (Process_Declarations): Minor reformatting. Simplify the entry point for renamings. Detect a case where a source object has been transformed into a class-wide renaming of a call to Ada.Tags.Displace. * exp_util.adb (Is_Displacement_Of_Ctrl_Function_Result): New routine. (Is_Finalizable_Transient): Minor reformatting. (Is_Tag_To_Class_Wide_Conversion): Minor reformatting. (Requires_Cleanup_Actions): Minor reformatting. Simplify the entry point for renamings. Detect a case where a source object has been transformed into a class-wide renaming of a call to Ada.Tags.Displace. * exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): New routine. (Is_Tag_To_Class_Wide_Conversion): Minor reformatting. 2012-02-22 Ed Schonberg * lib-load.adb (Load_Unit): If the prefix of the name in a with-clause is a renaming, add a with-clause on the original unit. * sem_ch10.adb (Build_Unit_Name): Remove code made obsolete by new handling of renamings in with-clauses. From-SVN: r184478 --- gcc/ada/exp_ch7.adb | 20 ++++++-- gcc/ada/exp_util.adb | 120 +++++++++++++++++++++++++++++++++++++++---- gcc/ada/exp_util.ads | 11 +++- gcc/ada/lib-load.adb | 20 +++++++- gcc/ada/sem_ch10.adb | 23 +-------- 5 files changed, 152 insertions(+), 42 deletions(-) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 7f5fcaaf90d..0347dcc5bd7 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1816,7 +1816,7 @@ package body Exp_Ch7 is and then Needs_Finalization (Obj_Typ) and then not (Ekind (Obj_Id) = E_Constant and then not Has_Completion (Obj_Id)) - and then not Is_Tag_To_CW_Conversion (Obj_Id) + and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) then Processing_Actions; @@ -1894,10 +1894,7 @@ package body Exp_Ch7 is -- Specific cases of object renamings - elsif Nkind (Decl) = N_Object_Renaming_Declaration - and then Nkind (Name (Decl)) = N_Explicit_Dereference - and then Nkind (Prefix (Name (Decl))) = N_Identifier - then + elsif Nkind (Decl) = N_Object_Renaming_Declaration then Obj_Id := Defining_Identifier (Decl); Obj_Typ := Base_Type (Etype (Obj_Id)); @@ -1919,6 +1916,19 @@ package body Exp_Ch7 is and then Present (Return_Flag_Or_Transient_Decl (Obj_Id)) then Processing_Actions (Has_No_Init => True); + + -- Detect a case where a source object has been initialized by + -- a controlled function call which was later rewritten as a + -- class-wide conversion of Ada.Tags.Displace. + + -- Obj : Class_Wide_Type := Function_Call (...); + + -- Temp : ... := Function_Call (...)'reference; + -- Obj : Class_Wide_Type renames + -- (... Ada.Tags.Displace (Temp)); + + elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then + Processing_Actions (Has_No_Init => True); end if; -- Inspect the freeze node of an access-to-controlled type and diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 98bd2f3b491..34bf030e205 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3940,6 +3940,92 @@ package body Exp_Util is return True; end Is_All_Null_Statements; + --------------------------------------------- + -- Is_Displacement_Of_Ctrl_Function_Result -- + --------------------------------------------- + + function Is_Displacement_Of_Ctrl_Function_Result + (Obj_Id : Entity_Id) return Boolean + is + function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean; + -- Determine whether object declaration N is initialized by a controlled + -- function call. + + function Is_Displace_Call (N : Node_Id) return Boolean; + -- Determine whether a particular node is a call to Ada.Tags.Displace. + -- The call might be nested within other actions such as conversions. + + ---------------------------------- + -- Initialized_By_Ctrl_Function -- + ---------------------------------- + + function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is + Expr : constant Node_Id := Original_Node (Expression (N)); + + begin + return + Nkind (Expr) = N_Function_Call + and then Needs_Finalization (Etype (Expr)); + end Initialized_By_Ctrl_Function; + + ---------------------- + -- Is_Displace_Call -- + ---------------------- + + function Is_Displace_Call (N : Node_Id) return Boolean is + Call : Node_Id := N; + + begin + -- Strip various actions which may precede a call to Displace + + loop + if Nkind (Call) = N_Explicit_Dereference then + Call := Prefix (Call); + + elsif Nkind_In (Call, N_Type_Conversion, + N_Unchecked_Type_Conversion) + then + Call := Expression (Call); + else + exit; + end if; + end loop; + + return + Nkind (Call) = N_Function_Call + and then Is_RTE (Entity (Name (Call)), RE_Displace); + end Is_Displace_Call; + + -- Local variables + + Decl : constant Node_Id := Parent (Obj_Id); + Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); + Orig_Decl : constant Node_Id := Original_Node (Decl); + + -- Start of processing for Is_Displacement_Of_Ctrl_Function_Result + + begin + -- Detect the following case: + + -- Obj : Class_Wide_Type := Function_Call (...); + + -- which is rewritten into: + + -- Temp : ... := Function_Call (...)'reference; + -- Obj : Class_Wide_Type renames (... Ada.Tags.Displace (Temp)); + + -- when the return type of the function and the class-wide type require + -- dispatch table pointer displacement. + + return + Nkind (Decl) = N_Object_Renaming_Declaration + and then Nkind (Orig_Decl) = N_Object_Declaration + and then Comes_From_Source (Orig_Decl) + and then Initialized_By_Ctrl_Function (Orig_Decl) + and then Is_Class_Wide_Type (Obj_Typ) + and then Is_Displace_Call (Renamed_Object (Obj_Id)); + end Is_Displacement_Of_Ctrl_Function_Result; + ------------------------------ -- Is_Finalizable_Transient -- ------------------------------ @@ -4321,7 +4407,7 @@ package body Exp_Util is -- Do not consider conversions of tags to class-wide types - and then not Is_Tag_To_CW_Conversion (Obj_Id) + and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) -- Do not consider containers in the context of iterator loops. Such -- transient objects must exist for as long as the loop is around, @@ -4851,11 +4937,13 @@ package body Exp_Util is end if; end Is_Renamed_Object; - ----------------------------- - -- Is_Tag_To_CW_Conversion -- - ----------------------------- + ------------------------------------- + -- Is_Tag_To_Class_Wide_Conversion -- + ------------------------------------- - function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is + function Is_Tag_To_Class_Wide_Conversion + (Obj_Id : Entity_Id) return Boolean + is Expr : constant Node_Id := Expression (Parent (Obj_Id)); begin @@ -4864,7 +4952,7 @@ package body Exp_Util is and then Present (Expr) and then Nkind (Expr) = N_Unchecked_Type_Conversion and then Etype (Expression (Expr)) = RTE (RE_Tag); - end Is_Tag_To_CW_Conversion; + end Is_Tag_To_Class_Wide_Conversion; ---------------------------- -- Is_Untagged_Derivation -- @@ -7015,7 +7103,7 @@ package body Exp_Util is and then Needs_Finalization (Obj_Typ) and then not (Ekind (Obj_Id) = E_Constant and then not Has_Completion (Obj_Id)) - and then not Is_Tag_To_CW_Conversion (Obj_Id) + and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) then return True; @@ -7064,10 +7152,7 @@ package body Exp_Util is -- Specific cases of object renamings - elsif Nkind (Decl) = N_Object_Renaming_Declaration - and then Nkind (Name (Decl)) = N_Explicit_Dereference - and then Nkind (Prefix (Name (Decl))) = N_Identifier - then + elsif Nkind (Decl) = N_Object_Renaming_Declaration then Obj_Id := Defining_Identifier (Decl); Obj_Typ := Base_Type (Etype (Obj_Id)); @@ -7089,6 +7174,19 @@ package body Exp_Util is and then Present (Return_Flag_Or_Transient_Decl (Obj_Id)) then return True; + + -- Detect a case where a source object has been initialized by a + -- controlled function call which was later rewritten as a class- + -- wide conversion of Ada.Tags.Displace. + + -- Obj : Class_Wide_Type := Function_Call (...); + + -- Temp : ... := Function_Call (...)'reference; + -- Obj : Class_Wide_Type renames + -- (... Ada.Tags.Displace (Temp)); + + elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then + return True; end if; -- Inspect the freeze node of an access-to-controlled type and look diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index c0e0082185d..97e9b5c9a56 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -521,6 +521,12 @@ package Exp_Util is -- False otherwise. True for an empty list. It is an error to call this -- routine with No_List as the argument. + function Is_Displacement_Of_Ctrl_Function_Result + (Obj_Id : Entity_Id) return Boolean; + -- Determine whether Obj_Id is a source object that has been initialized by + -- a controlled function call later rewritten as a class-wide conversion of + -- Ada.Tags.Displace. + function Is_Finalizable_Transient (Decl : Node_Id; Rel_Node : Node_Id) return Boolean; @@ -587,7 +593,8 @@ package Exp_Util is -- We consider that a (1 .. 2) is a renamed object since it is the prefix -- of the name in the renaming declaration. - function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean; + function Is_Tag_To_Class_Wide_Conversion + (Obj_Id : Entity_Id) return Boolean; -- Determine whether object Obj_Id is the result of a tag-to-class-wide -- type conversion. diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index 0ac729ece6c..be4c5376c36 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -406,9 +406,25 @@ package body Lib.Load is New_Child (Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump))))); + -- If the load is for a with_clause, for visibility purposes both + -- the renamed entity and renaming one must be available in the + -- current unit: the renamed one in order to retrieve the child + -- unit, and the original one because it may be used as a prefix + -- in the body of the current unit. We add an explicit with_clause + -- for the original parent so that the renaming declaration is + -- properly loaded and analyzed. + + if Present (With_Node) then + Insert_After (With_Node, + Make_With_Clause (Sloc (With_Node), + Name => Copy_Separate_Tree (Prefix (Name (With_Node))))); + end if; + -- Save the renaming entity, to establish its visibility when -- installing the context. The implicit with is on this entity, - -- not on the package it renames. + -- not on the package it renames. This is somewhat redundant given + -- the with_clause just created, but it simplifies subsequent + -- expansion of the current with_clause. Optimizable ??? if Nkind (Error_Node) = N_With_Clause and then Nkind (Name (Error_Node)) = N_Selected_Component diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index e2d1c2b5cd6..1aa25c2a542 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2936,32 +2936,11 @@ package body Sem_Ch10 is function Build_Unit_Name (Nam : Node_Id) return Node_Id is Ent : Entity_Id; - Renaming : Entity_Id; Result : Node_Id; begin if Nkind (Nam) = N_Identifier then - - -- If the parent unit P in the name of the with_clause for P.Q is - -- a renaming of package R, then the entity of the parent is set - -- to R, but the identifier retains Chars (P) to be consistent - -- with the source (see details in lib-load). However the implicit - -- with_clause for the parent must make the entity for P visible, - -- because P.Q may be used as a prefix within the current unit. - -- The entity for P is the current_entity with that name, because - -- the package renaming declaration for it has just been analyzed. - -- Note that this case can only happen if P.Q has already appeared - -- in a previous with_clause in a related unit, such as the - -- library body of the current unit. - - if Chars (Nam) /= Chars (Entity (Nam)) then - Renaming := Current_Entity (Nam); - pragma Assert (Renamed_Entity (Renaming) = Entity (Nam)); - return New_Occurrence_Of (Renaming, Loc); - - else - return New_Occurrence_Of (Entity (Nam), Loc); - end if; + return New_Occurrence_Of (Entity (Nam), Loc); else Ent := Entity (Nam);