[multiple changes]
2015-05-12 Ed Schonberg <schonberg@adacore.com> * 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 <kirtchev@adacore.com> * 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
This commit is contained in:
Arnaud Charlet
parent
7858300e04
commit
4b17187f23
@ -1,3 +1,20 @@
|
||||
2015-05-12 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* 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 <kirtchev@adacore.com>
|
||||
|
||||
* 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 <dewar@adacore.com>
|
||||
|
||||
* sem_prag.adb (Process_Atomic_Independent_Shared_Volatile):
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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.
|
||||
|
||||
Act := First (Actions (N));
|
||||
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 ...;
|
||||
-- <finalize Trans_Id>
|
||||
-- in Val end;
|
||||
|
||||
-- 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.
|
||||
-- The node on which to insert the hook as an action. This is usually
|
||||
-- the innermost enclosing non-transient construct.
|
||||
|
||||
Finalization_Context : Node_Id;
|
||||
-- Node after which to insert finalization actions
|
||||
|
||||
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);
|
||||
-- <or>
|
||||
-- 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)),
|
||||
|
||||
Insert_Actions_After (Finalization_Context, Fin_Stmts);
|
||||
Then_Statements => New_List (
|
||||
Make_Final_Call
|
||||
(Obj_Ref =>
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Prefix => New_Occurrence_Of (Hook_Id, Loc)),
|
||||
Typ => Desig_Typ),
|
||||
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name => New_Occurrence_Of (Hook_Id, Loc),
|
||||
Expression => Make_Null (Loc)))));
|
||||
end if;
|
||||
end Process_Transient_Object;
|
||||
|
||||
|
||||
@ -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);
|
||||
-- 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:
|
||||
|
||||
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;
|
||||
-- do
|
||||
-- Trans_Id : Ctrl_Typ ...; -- controlled transient object
|
||||
-- Alias : ... := Trans_Id; -- object is aliased
|
||||
-- Val : constant Boolean :=
|
||||
-- ... Alias ...; -- aliasing ends
|
||||
-- <finalize Trans_Id> -- 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;
|
||||
|
||||
-- Otherwise examine the statements after the controlled transient
|
||||
-- object and look for various forms of aliasing.
|
||||
|
||||
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;
|
||||
|
||||
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
|
||||
Ren_Obj := Find_Renamed_Object (Stmt);
|
||||
Next (Stmt);
|
||||
end loop;
|
||||
|
||||
if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
|
||||
return True;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user