From 4b17187f237160e6b3d536f7843d4f3a7d258a23 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 12 May 2015 17:11:29 +0200 Subject: [PATCH] [multiple changes] 2015-05-12 Ed Schonberg * a-coormu.ads, a-coormu.adb: Add Indexing aspect, Reference_Type, and Reference_Control_Type to support element iterators over ordered multisets. * a-ciormu.ads, a-ciormu.adb: Ditto for indefinite_ordered_multisets. 2015-05-12 Hristian Kirtchev * exp_ch4.adb (Expand_N_Expression_With_Actions): Force the evaluation of the EWA expression. Code cleanup. (Process_Transient_Object): Code cleanup. * exp_util.adb (Is_Aliased): Controlled transient objects found within EWA nodes are not aliased. (Is_Finalizable_Transient): Iterators are not finalizable transients. From-SVN: r223076 --- gcc/ada/ChangeLog | 17 ++++ gcc/ada/a-ciormu.adb | 56 ++++++++++- gcc/ada/a-ciormu.ads | 41 +++++++- gcc/ada/a-coormu.adb | 56 ++++++++++- gcc/ada/a-coormu.ads | 41 +++++++- gcc/ada/exp_ch4.adb | 217 ++++++++++++++++++++++--------------------- gcc/ada/exp_util.adb | 81 +++++++++++----- 7 files changed, 372 insertions(+), 137 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8d396da5774..e12294194c1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2015-05-12 Ed Schonberg + + * a-coormu.ads, a-coormu.adb: Add Indexing aspect, Reference_Type, + and Reference_Control_Type to support element iterators over + ordered multisets. + * a-ciormu.ads, a-ciormu.adb: Ditto for + indefinite_ordered_multisets. + +2015-05-12 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Expression_With_Actions): Force + the evaluation of the EWA expression. Code cleanup. + (Process_Transient_Object): Code cleanup. + * exp_util.adb (Is_Aliased): Controlled transient objects found + within EWA nodes are not aliased. + (Is_Finalizable_Transient): Iterators are not finalizable transients. + 2015-05-12 Robert Dewar * sem_prag.adb (Process_Atomic_Independent_Shared_Volatile): diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb index 1b562d7febf..38dd5ae6a40 100644 --- a/gcc/ada/a-ciormu.adb +++ b/gcc/ada/a-ciormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, 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- -- @@ -353,6 +353,45 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is return Node.Color; end Color; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Constant_Reference"); + + -- Note: in predefined container units, the creation of a reference + -- increments the busy bit of the container, and its finalization + -- decrements it. In the absence of control machinery, this tampering + -- protection is missing. + + declare + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + pragma Unreferenced (T); + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element, + Control => (Container => Container'Unrestricted_Access)) + do + null; + end return; + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1730,6 +1769,14 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is raise Program_Error with "attempt to stream set cursor"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + --------------------- -- Replace_Element -- --------------------- @@ -2055,4 +2102,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is raise Program_Error with "attempt to stream set cursor"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads index 575d5d8321e..68d1835bed9 100644 --- a/gcc/ada/a-ciormu.ads +++ b/gcc/ada/a-ciormu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, 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- -- @@ -52,8 +52,9 @@ package Ada.Containers.Indefinite_Ordered_Multisets is -- otherwise, it returns True. type Set is tagged private - with Default_Iterator => Iterate, - Iterator_Element => Element_Type; + with Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; pragma Preelaborable_Initialization (Set); @@ -128,6 +129,15 @@ package Ada.Containers.Indefinite_Ordered_Multisets is -- change the value of the element while Process is executing (to "tamper -- with elements") will raise Program_Error. + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + procedure Assign (Target : in out Set; Source : Set); function Copy (Source : Set) return Set; @@ -469,6 +479,19 @@ private type Set_Access is access all Set; for Set_Access'Storage_Size use 0; + -- In all predefined libraries the following type is controlled, for proper + -- management of tampering checks. For performance reason we omit this + -- machinery for multisets, which are used in a number of our tools. + + type Reference_Control_Type is record + Container : Set_Access; + end record; + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is record + Control : Reference_Control_Type; + end record; + type Cursor is record Container : Set_Access; Node : Node_Access; @@ -500,6 +523,18 @@ private for Set'Read use Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + Empty_Set : constant Set := (Controlled with Tree => (First => null, Last => null, diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb index 06dfe94918c..c3e4fce66e4 100644 --- a/gcc/ada/a-coormu.adb +++ b/gcc/ada/a-coormu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, 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- -- @@ -321,6 +321,45 @@ package body Ada.Containers.Ordered_Multisets is return Node.Color; end Color; + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Constant_Reference"); + + -- Note: in predefined container units, the creation of a reference + -- increments the busy bit of the container, and its finalization + -- decrements it. In the absence of control machinery, this tampering + -- protection is missing. + + declare + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + pragma Unreferenced (T); + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Unrestricted_Access, + Control => (Container => Container'Unrestricted_Access)) + do + null; + end return; + end; + end Constant_Reference; + -------------- -- Contains -- -------------- @@ -1638,6 +1677,14 @@ package body Ada.Containers.Ordered_Multisets is raise Program_Error with "attempt to stream set cursor"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + --------------------- -- Replace_Element -- --------------------- @@ -1937,4 +1984,11 @@ package body Ada.Containers.Ordered_Multisets is raise Program_Error with "attempt to stream set cursor"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads index 8d684741e94..d7e7b94152b 100644 --- a/gcc/ada/a-coormu.ads +++ b/gcc/ada/a-coormu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2015, 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- -- @@ -51,8 +51,9 @@ package Ada.Containers.Ordered_Multisets is -- otherwise, it returns True. type Set is tagged private - with Default_Iterator => Iterate, - Iterator_Element => Element_Type; + with Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; pragma Preelaborable_Initialization (Set); @@ -127,6 +128,15 @@ package Ada.Containers.Ordered_Multisets is -- change the value of the element while Process is executing (to "tamper -- with elements") will raise Program_Error. + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + procedure Assign (Target : in out Set; Source : Set); function Copy (Source : Set) return Set; @@ -473,6 +483,19 @@ private type Set_Access is access all Set; for Set_Access'Storage_Size use 0; + -- In all predefined libraries the following type is controlled, for proper + -- management of tampering checks. For performance reason we omit this + -- machinery for multisets, which are used in a number of our tools. + + type Reference_Control_Type is record + Container : Set_Access; + end record; + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is record + Control : Reference_Control_Type; + end record; + type Cursor is record Container : Set_Access; Node : Node_Access; @@ -504,6 +527,18 @@ private for Set'Read use Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + Empty_Set : constant Set := (Controlled with Tree => (First => null, Last => null, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 3fcd8247fd8..8b3e0ea511b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -5090,7 +5090,6 @@ package body Exp_Ch4 is -------------------------------------- procedure Expand_N_Expression_With_Actions (N : Node_Id) is - function Process_Action (Act : Node_Id) return Traverse_Result; -- Inspect and process a single action of an expression_with_actions for -- transient controlled objects. If such objects are found, the routine @@ -5129,14 +5128,57 @@ package body Exp_Ch4 is -- Local variables - Act : Node_Id; + Acts : constant List_Id := Actions (N); + Expr : constant Node_Id := Expression (N); + Act : Node_Id; -- Start of processing for Expand_N_Expression_With_Actions begin - -- Process the actions as described above + -- Do not evaluate the expression when it denotes an entity because the + -- expression_with_actions node will be replaced by the reference. + + if Is_Entity_Name (Expr) then + null; + + -- Do not evaluate the expression when there are no actions because the + -- expression_with_actions node will be replaced by the expression. + + elsif No (Acts) or else Is_Empty_List (Acts) then + null; + + -- Force the evaluation of the expression by capturing its value in a + -- temporary. This ensures that aliases of transient controlled objects + -- do not leak to the expression of the expression_with_actions node: + + -- do + -- Trans_Id : Ctrl_Typ : ...; + -- Alias : ... := Trans_Id; + -- in ... Alias ... end; + + -- In the example above, Trans_Id cannot be finalized at the end of the + -- actions list because this may affect the alias and the final value of + -- the expression_with_actions. Forcing the evaluation encapsulates the + -- reference to the Alias within the actions list: + + -- do + -- Trans_Id : Ctrl_Typ : ...; + -- Alias : ... := Trans_Id; + -- Val : constant Boolean := ... Alias ...; + -- + -- in Val end; - Act := First (Actions (N)); + -- It is now safe to finalize the transient controlled object at the end + -- of the actions list. + + else + Force_Evaluation (Expr); + end if; + + -- Process all transient controlled objects found within the actions of + -- the EWA node. + + Act := First (Acts); while Present (Act) loop Process_Single_Action (Act); Next (Act); @@ -5151,7 +5193,7 @@ package body Exp_Ch4 is -- tree in cases like this. This raises a whole lot of issues of whether -- we have problems elsewhere, which will be addressed in the future??? - if Is_Empty_List (Actions (N)) then + if Is_Empty_List (Acts) then Rewrite (N, Relocate_Node (Expression (N))); end if; end Expand_N_Expression_With_Actions; @@ -11406,9 +11448,10 @@ package body Exp_Ch4 is -- problems for coverage analysis. Rewrite (Right, - Make_Expression_With_Actions (LocR, - Expression => Relocate_Node (Right), - Actions => Actlist)); + Make_Expression_With_Actions (LocR, + Expression => Relocate_Node (Right), + Actions => Actlist)); + Set_Actions (N, No_List); Analyze_And_Resolve (Right, Standard_Boolean); @@ -12620,72 +12663,28 @@ package body Exp_Ch4 is (Decl : Node_Id; Rel_Node : Node_Id) is - Loc : constant Source_Ptr := Sloc (Decl); - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); - Obj_Typ : constant Node_Id := Etype (Obj_Id); - Desig_Typ : Entity_Id; - Expr : Node_Id; - Fin_Stmts : List_Id; - Ptr_Id : Entity_Id; - Temp_Id : Entity_Id; - Temp_Ins : Node_Id; + Loc : constant Source_Ptr := Sloc (Decl); + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); + Obj_Typ : constant Node_Id := Etype (Obj_Id); + Desig_Typ : Entity_Id; + Expr : Node_Id; + Hook_Id : Entity_Id; + Hook_Insert : Node_Id; + Ptr_Id : Entity_Id; Hook_Context : constant Node_Id := Find_Hook_Context (Rel_Node); - -- Node on which to insert the hook pointer (as an action): the - -- innermost enclosing non-transient scope. - - Finalization_Context : Node_Id; - -- Node after which to insert finalization actions + -- The node on which to insert the hook as an action. This is usually + -- the innermost enclosing non-transient construct. - Finalize_Always : Boolean; - -- If False, call to finalizer includes a test of whether the hook - -- pointer is null. + Fin_Context : Node_Id; + -- The node after which to insert the finalization actions of the + -- transient controlled object. begin - -- Step 0: determine where to attach finalization actions in the tree - - -- Special case for Boolean EWAs: capture expression in a temporary, - -- whose declaration will serve as the context around which to insert - -- finalization code. The finalization thus remains local to the - -- specific condition being evaluated. - if Is_Boolean_Type (Etype (Rel_Node)) then - - -- In this case, the finalization context is chosen so that we know - -- at finalization point that the hook pointer is never null, so no - -- need for a test, we can call the finalizer unconditionally, except - -- in the case where the object is created in a specific branch of a - -- conditional expression. - - Finalize_Always := - not Within_Case_Or_If_Expression (Rel_Node) - and then not Nkind_In - (Original_Node (Rel_Node), N_Case_Expression, - N_If_Expression); - - declare - Loc : constant Source_Ptr := Sloc (Rel_Node); - Temp : constant Entity_Id := Make_Temporary (Loc, 'E', Rel_Node); - - begin - Append_To (Actions (Rel_Node), - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Etype (Rel_Node), Loc), - Expression => Expression (Rel_Node))); - Finalization_Context := Last (Actions (Rel_Node)); - - Analyze (Last (Actions (Rel_Node))); - - Set_Expression (Rel_Node, New_Occurrence_Of (Temp, Loc)); - Analyze (Expression (Rel_Node)); - end; - + Fin_Context := Last (Actions (Rel_Node)); else - Finalize_Always := False; - Finalization_Context := Hook_Context; + Fin_Context := Hook_Context; end if; -- Step 1: Create the access type which provides a reference to the @@ -12715,23 +12714,23 @@ package body Exp_Ch4 is -- Step 2: Create a temporary which acts as a hook to the transient -- controlled object. Generate: - -- Temp : Ptr_Id := null; + -- Hook : Ptr_Id := null; - Temp_Id := Make_Temporary (Loc, 'T'); + Hook_Id := Make_Temporary (Loc, 'T'); Insert_Action (Hook_Context, Make_Object_Declaration (Loc, - Defining_Identifier => Temp_Id, + Defining_Identifier => Hook_Id, Object_Definition => New_Occurrence_Of (Ptr_Id, Loc))); - -- Mark the temporary as created for the purposes of exporting the - -- transient controlled object out of the expression_with_action or if - -- expression. This signals the machinery in Build_Finalizer to treat - -- this case specially. + -- Mark the hook as created for the purposes of exporting the transient + -- controlled object out of the expression_with_action or if expression. + -- This signals the machinery in Build_Finalizer to treat this case in + -- a special manner. - Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl); + Set_Status_Flag_Or_Transient_Decl (Hook_Id, Decl); - -- Step 3: Hook the transient object to the temporary + -- Step 3: Associate the transient object to the hook -- This must be inserted right after the object declaration, so that -- the assignment is executed if, and only if, the object is actually @@ -12747,7 +12746,9 @@ package body Exp_Ch4 is if Is_Access_Type (Obj_Typ) then Expr := - Unchecked_Convert_To (Ptr_Id, New_Occurrence_Of (Obj_Id, Loc)); + Unchecked_Convert_To + (Typ => Ptr_Id, + Expr => New_Occurrence_Of (Obj_Id, Loc)); else Expr := Make_Attribute_Reference (Loc, @@ -12756,9 +12757,9 @@ package body Exp_Ch4 is end if; -- Generate: - -- Temp := Ptr_Id (Obj_Id); + -- Hook := Ptr_Id (Obj_Id); -- - -- Temp := Obj_Id'Unrestricted_Access; + -- Hook := Obj_Id'Unrestricted_Access; -- When the transient object is initialized by an aggregate, the hook -- must capture the object after the last component assignment takes @@ -12767,25 +12768,25 @@ package body Exp_Ch4 is if Ekind (Obj_Id) = E_Variable and then Present (Last_Aggregate_Assignment (Obj_Id)) then - Temp_Ins := Last_Aggregate_Assignment (Obj_Id); + Hook_Insert := Last_Aggregate_Assignment (Obj_Id); -- Otherwise the hook seizes the related object immediately else - Temp_Ins := Decl; + Hook_Insert := Decl; end if; - Insert_After_And_Analyze (Temp_Ins, + Insert_After_And_Analyze (Hook_Insert, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), + Name => New_Occurrence_Of (Hook_Id, Loc), Expression => Expr)); - -- Step 4: Finalize the transient controlled object after the context - -- has been evaluated/elaborated. Generate: + -- Step 4: Finalize the hook after the context has been evaluated or + -- elaborated. Generate: - -- if Temp /= null then - -- [Deep_]Finalize (Temp.all); - -- Temp := null; + -- if Hook /= null then + -- [Deep_]Finalize (Hook.all); + -- Hook := null; -- end if; -- When the node is part of a return statement, there is no need to @@ -12795,29 +12796,29 @@ package body Exp_Ch4 is -- insert the finalization code after the return statement as this will -- render it unreachable. - if Nkind (Finalization_Context) /= N_Simple_Return_Statement then - Fin_Stmts := New_List ( - Make_Final_Call - (Obj_Ref => - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Temp_Id, Loc)), - Typ => Desig_Typ), + if Nkind (Fin_Context) = N_Simple_Return_Statement then + null; - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Temp_Id, Loc), - Expression => Make_Null (Loc))); + -- Otherwise finalize the hook - if not Finalize_Always then - Fin_Stmts := New_List ( - Make_Implicit_If_Statement (Decl, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Temp_Id, Loc), - Right_Opnd => Make_Null (Loc)), - Then_Statements => Fin_Stmts)); - end if; + else + Insert_Action_After (Fin_Context, + Make_Implicit_If_Statement (Decl, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Hook_Id, Loc), + Right_Opnd => Make_Null (Loc)), + + Then_Statements => New_List ( + Make_Final_Call + (Obj_Ref => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Hook_Id, Loc)), + Typ => Desig_Typ), - Insert_Actions_After (Finalization_Context, Fin_Stmts); + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Hook_Id, Loc), + Expression => Make_Null (Loc))))); end if; end Process_Transient_Object; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 986b3045460..5b86d419a99 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4713,7 +4713,6 @@ package body Exp_Util is is 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 @@ -4916,31 +4915,61 @@ package body Exp_Util is -- Start of processing for Is_Aliased begin - Stmt := First_Stmt; - while Present (Stmt) loop - 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; + -- A controlled transient object is not considered aliased when it + -- appears inside an expression_with_actions node even when there are + -- explicit aliases of it: + + -- do + -- Trans_Id : Ctrl_Typ ...; -- controlled transient object + -- Alias : ... := Trans_Id; -- object is aliased + -- Val : constant Boolean := + -- ... Alias ...; -- aliasing ends + -- -- object safe to finalize + -- in Val end; + + -- Expansion ensures that all aliases are encapsulated in the actions + -- list and do not leak to the expression by forcing the evaluation + -- of the expression. + + if Nkind (Rel_Node) = N_Expression_With_Actions then + return False; - elsif Nkind (Stmt) = N_Object_Renaming_Declaration then - Ren_Obj := Find_Renamed_Object (Stmt); + -- Otherwise examine the statements after the controlled transient + -- object and look for various forms of aliasing. - if Present (Ren_Obj) and then Ren_Obj = Trans_Id then - return True; + else + Stmt := First_Stmt; + while Present (Stmt) loop + if Nkind (Stmt) = N_Object_Declaration then + Expr := Expression (Stmt); + + -- Aliasing of the form: + -- Obj : ... := Trans_Id'reference; + + 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 := Find_Renamed_Object (Stmt); + + -- Aliasing of the form: + -- Obj : ... renames ... Trans_Id ...; + + if Present (Ren_Obj) and then Ren_Obj = Trans_Id then + return True; + end if; end if; - end if; - Next (Stmt); - end loop; + Next (Stmt); + end loop; - return False; + return False; + end if; end Is_Aliased; ------------------ @@ -5041,6 +5070,10 @@ package body Exp_Util is return False; end Is_Iterated_Container; + -- Local variables + + Desig : Entity_Id := Obj_Typ; + -- Start of processing for Is_Finalizable_Transient begin @@ -5083,6 +5116,12 @@ package body Exp_Util is and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) + -- Do not consider iterators because those are treated as normal + -- controlled objects and are processed by the usual finalization + -- machinery. This avoids the double finalization of an iterator. + + and then not Is_Iterator (Desig) + -- Do not consider containers in the context of iterator loops. Such -- transient objects must exist for as long as the loop is around, -- otherwise any operation carried out by the iterator will fail. -- 2.30.2