From 24d2fbbeacb37a9a07ae7b038ce331630141aa10 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Wed, 27 Apr 2016 12:20:54 +0000 Subject: [PATCH] exp_ch3.adb (Expand_N_Object_Declaration): Rewrite an object declaration of the form "X ... 2016-04-27 Bob Duff * exp_ch3.adb (Expand_N_Object_Declaration): Rewrite an object declaration of the form "X : T := Func (...);", where T is controlled, as a renaming. * a-strunb-shared.adb (Finalize): Set the Unbounded_String Object to be an empty string, instead of null-ing out the Reference. * exp_util.adb (Needs_Finalization): Remove redundant code. From-SVN: r235488 --- gcc/ada/ChangeLog | 9 +++ gcc/ada/a-strunb-shared.adb | 7 ++- gcc/ada/exp_ch3.adb | 139 ++++++++++++++++++++++++++------------------ gcc/ada/exp_util.adb | 8 +-- 4 files changed, 100 insertions(+), 63 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cbbc3b2..75f6904 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2016-04-27 Bob Duff + + * exp_ch3.adb (Expand_N_Object_Declaration): Rewrite an object + declaration of the form "X : T := Func (...);", where T is + controlled, as a renaming. + * a-strunb-shared.adb (Finalize): Set the Unbounded_String Object + to be an empty string, instead of null-ing out the Reference. + * exp_util.adb (Needs_Finalization): Remove redundant code. + 2016-04-27 Hristian Kirtchev * aspects.ads Aspects Export and Import do not require delay. They diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb index 5cbe360..72028e0 100644 --- a/gcc/ada/a-strunb-shared.adb +++ b/gcc/ada/a-strunb-shared.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -795,7 +795,10 @@ package body Ada.Strings.Unbounded is -- so we need to add a guard for the case of finalizing the same -- object twice. - Object.Reference := null; + -- We set the Object to the empty string so there will be no ill + -- effects if a program references an already-finalized object. + + Object.Reference := Null_Unbounded_String.Reference; Unreference (SR); end if; end Finalize; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 7df4830..0925329 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -6336,11 +6336,46 @@ package body Exp_Ch3 is function Rewrite_As_Renaming return Boolean is begin - return not Aliased_Present (N) - and then Is_Entity_Name (Expr_Q) - and then Ekind (Entity (Expr_Q)) = E_Variable - and then OK_To_Rename (Entity (Expr_Q)) - and then Is_Entity_Name (Obj_Def); + -- If the object declaration appears in the form + + -- Obj : Ctrl_Typ := Func (...); + + -- where Ctrl_Typ is controlled but not immutably limited type, then + -- the expansion of the function call should use a dereference of the + -- result to reference the value on the secondary stack. + + -- Obj : Ctrl_Typ renames Func (...).all; + + -- As a result, the call avoids an extra copy. This an optimization, + -- but it is required for passing ACATS tests in some cases where it + -- would otherwise make two copies. The RM allows removing redunant + -- Adjust/Finalize calls, but does not allow insertion of extra ones. + + return (Nkind (Expr_Q) = N_Explicit_Dereference + and then not Comes_From_Source (Expr_Q) + and then Nkind (Original_Node (Expr_Q)) = N_Function_Call + and then Nkind (Object_Definition (N)) in N_Has_Entity + and then (Needs_Finalization (Entity (Object_Definition (N))))) + + -- If the initializing expression is for a variable with attribute + -- OK_To_Rename set, then transform: + + -- Obj : Typ := Expr; + + -- into + + -- Obj : Typ renames Expr; + + -- provided that Obj is not aliased. The aliased case has to be + -- excluded in general because Expr will not be aliased in + -- general. + + or else + (not Aliased_Present (N) + and then Is_Entity_Name (Expr_Q) + and then Ekind (Entity (Expr_Q)) = E_Variable + and then OK_To_Rename (Entity (Expr_Q)) + and then Is_Entity_Name (Obj_Def)); end Rewrite_As_Renaming; -- Local variables @@ -6993,58 +7028,9 @@ package body Exp_Ch3 is Insert_After_And_Analyze (Init_After, Stat); end; end if; - - -- Final transformation, if the initializing expression is an entity - -- for a variable with OK_To_Rename set, then we transform: - - -- X : typ := expr; - - -- into - - -- X : typ renames expr - - -- provided that X is not aliased. The aliased case has to be - -- excluded in general because Expr will not be aliased in general. - - if Rewrite_As_Renaming then - Rewrite (N, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Defining_Identifier (N), - Subtype_Mark => Obj_Def, - Name => Expr_Q)); - - -- We do not analyze this renaming declaration, because all its - -- components have already been analyzed, and if we were to go - -- ahead and analyze it, we would in effect be trying to generate - -- another declaration of X, which won't do. - - Set_Renamed_Object (Defining_Identifier (N), Expr_Q); - Set_Analyzed (N); - - -- We do need to deal with debug issues for this renaming - - -- First, if entity comes from source, then mark it as needing - -- debug information, even though it is defined by a generated - -- renaming that does not come from source. - - if Comes_From_Source (Defining_Identifier (N)) then - Set_Debug_Info_Needed (Defining_Identifier (N)); - end if; - - -- Now call the routine to generate debug info for the renaming - - declare - Decl : constant Node_Id := Debug_Renaming_Declaration (N); - begin - if Present (Decl) then - Insert_Action (N, Decl); - end if; - end; - end if; end if; - if Nkind (N) = N_Object_Declaration - and then Nkind (Obj_Def) = N_Access_Definition + if Nkind (Obj_Def) = N_Access_Definition and then not Is_Local_Anonymous_Access (Etype (Def_Id)) then -- An Ada 2012 stand-alone object of an anonymous access type @@ -7122,6 +7108,47 @@ package body Exp_Ch3 is end; end if; + -- Final transformation - turn the object declaration into a renaming if + -- appropriate. + + if Present (Expr) then + if Rewrite_As_Renaming then + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Defining_Identifier (N), + Subtype_Mark => Obj_Def, + Name => Expr_Q)); + + -- We do not analyze this renaming declaration, because all its + -- components have already been analyzed, and if we were to go + -- ahead and analyze it, we would in effect be trying to generate + -- another declaration of X, which won't do. + + Set_Renamed_Object (Defining_Identifier (N), Expr_Q); + Set_Analyzed (N); + + -- We do need to deal with debug issues for this renaming + + -- First, if entity comes from source, then mark it as needing + -- debug information, even though it is defined by a generated + -- renaming that does not come from source. + + if Comes_From_Source (Defining_Identifier (N)) then + Set_Debug_Info_Needed (Defining_Identifier (N)); + end if; + + -- Now call the routine to generate debug info for the renaming + + declare + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + begin + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end; + end if; + end if; + -- Exception on library entity not available exception diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 6090ab9..2e8e1d6 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6995,11 +6995,10 @@ package body Exp_Util is return False; - elsif Is_Array_Type (Rec) then - return Needs_Finalization (Component_Type (Rec)); - else - return Has_Controlled_Component (Rec); + return + Is_Array_Type (Rec) + and then Needs_Finalization (Component_Type (Rec)); end if; else return False; @@ -7032,7 +7031,6 @@ package body Exp_Util is return Is_Class_Wide_Type (T) or else Is_Controlled (T) - or else Has_Controlled_Component (T) or else Has_Some_Controlled_Component (T) or else (Is_Concurrent_Type (T) -- 2.7.4