+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):
-- --
-- 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- --
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 --
--------------
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 --
---------------------
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;
-- --
-- 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- --
-- 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);
-- 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;
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;
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,
-- --
-- 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- --
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 --
--------------
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 --
---------------------
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;
-- --
-- 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- --
-- 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);
-- 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;
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;
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,
--------------------------------------
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
-- 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 ...;
+ -- <finalize Trans_Id>
+ -- 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);
-- 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;
-- 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);
(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
-- 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
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,
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
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
-- 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;
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
-- 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
+ -- <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;
- 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;
------------------
return False;
end Is_Iterated_Container;
+ -- Local variables
+
+ Desig : Entity_Id := Obj_Typ;
+
-- Start of processing for Is_Finalizable_Transient
begin
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.
projects / gcc.git / commitdiff