[Ada] Missing finalization of defaulted aggregate in extended return
Arnaud Charlet
charlet@adacore.com
Wed Jul 6 12:38:00 GMT 2016
This patch introduces several significant changes in the area of transient
object processing and finalization.
1) The patch introduces a new mechanism for handling of transient objects in
the context of aggregate initialization. An array element or record component
initialized by a controlled function call is now treated as a special context.
The circuitry associated with the transient function result is now produced in
place, during aggregate expansion, as opposed to a post pass as part of
transient scope processing. This ensures that the transient function result is
finalized immediately after the related element or component is initialized,
tag adjusted, and deep_adjusted.
Prior to this change, the transient function result was finalized too early,
leading to a malformed element or component.
2) All three transient object finalization mechanisms (transient scopes, if
expressions, case expressions, expression_with_actions, transient aggregate
components) now share the same code generation circuitry.
3) Any trainsient object processed by one of the three mechanisms is ignored
by the general finalization mechanism to prevent double finalization.
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package Types is
type Ctrl is new Controlled with record
Id : Natural := 0;
end record;
procedure Adjust (Obj : in out Ctrl);
procedure Finalize (Obj : in out Ctrl);
procedure Initialize (Obj : in out Ctrl);
function Make_Ctrl return Ctrl;
type Parent is tagged record
Comp_1 : Integer := 1;
end record;
type Child is new Parent with record
Comp_2 : Ctrl := Make_Ctrl;
Comp_3 : Unbounded_String := To_Unbounded_String ("Comp_3");
end record;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 100;
procedure Adjust (Obj : in out Ctrl) is
Old_Id : constant Natural := Obj.Id;
New_Id : constant Natural := Old_Id + 1;
begin
if Old_Id = 0 then
Put_Line ("ERROR: adjusting finalized object");
end if;
Put_Line (" adj:" & Old_Id'Img & " ->" & New_Id'Img);
Obj.Id := New_Id;
end Adjust;
procedure Finalize (Obj : in out Ctrl) is
Obj_Id : constant Natural := Obj.Id;
begin
if Obj_Id = 0 then
Put_Line ("ERROR: finalizing finalized object");
end if;
Put_Line (" fin:" & Obj_Id'Img);
Obj.Id := 0;
end Finalize;
procedure Initialize (Obj : in out Ctrl) is
begin
Obj.Id := Id_Gen;
Id_Gen := Id_Gen + 100;
Put_Line (" ini:" & Obj.Id'Img);
end Initialize;
function Make_Ctrl return Ctrl is
Result : Ctrl;
begin
return Result;
end Make_Ctrl;
end Types;
-- aggregates.ads
with Types; use Types;
package Aggregates is
function Box_Aggregate return Child;
function Box_Aggregate_In_ER return Child;
function Normal_Aggregate return Child;
function Normal_Aggregate_In_ER return Child;
end Aggregates;
-- aggregates.adb
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
package body Aggregates is
function Box_Aggregate return Child is
Result : constant Child := (Parent with others => <>);
begin
return Result;
end Box_Aggregate;
function Box_Aggregate_In_ER return Child is
begin
return Result : Child := (Parent with others => <>)
do null; end return;
end Box_Aggregate_In_ER;
function Normal_Aggregate return Child is
Result : constant Child :=
(Parent with Comp_2 => Make_Ctrl,
Comp_3 => To_Unbounded_String ("Comp_3"));
begin
return Result;
end Normal_Aggregate;
function Normal_Aggregate_In_ER return Child is
begin
return Result : Child :=
(Parent with Comp_2 => Make_Ctrl,
Comp_3 => To_Unbounded_String ("Comp_3"))
do null; end return;
end Normal_Aggregate_In_ER;
end Aggregates;
-- leaks.adb
with Ada.Text_IO; use Ada.Text_IO;
with Aggregates; use Aggregates;
with Types; use Types;
procedure Leaks is
begin
Put_Line ("Box aggregate");
declare
Aggr_1 : constant Child := Box_Aggregate;
begin null; end;
Put_Line ("Box aggregate in extended return");
declare
Aggr_2 : constant Child := Box_Aggregate_In_ER;
begin null; end;
Put_Line ("Notmal aggregate");
declare
Aggr_3 : constant Child := Normal_Aggregate;
begin null; end;
Put_Line ("Notmal aggregate in extended return");
declare
Aggr_4 : constant Child := Normal_Aggregate;
begin null; end;
end Leaks;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q leaks.adb -largs -lgmem
$ ./leaks
$ gnatmem ./leaks > leaks.txt
$ grep "Number of non freed allocations" leaks.txt
Box aggregate
ini: 100
adj: 100 -> 101
fin: 100
adj: 101 -> 102
fin: 101
adj: 102 -> 103
fin: 102
adj: 103 -> 104
fin: 103
fin: 104
Box aggregate in extended return
ini: 200
adj: 200 -> 201
fin: 200
adj: 201 -> 202
fin: 201
adj: 202 -> 203
fin: 202
adj: 203 -> 204
fin: 203
fin: 204
Notmal aggregate
ini: 300
adj: 300 -> 301
fin: 300
adj: 301 -> 302
fin: 301
adj: 302 -> 303
fin: 302
adj: 303 -> 304
fin: 303
fin: 304
Notmal aggregate in extended return
ini: 400
adj: 400 -> 401
fin: 400
adj: 401 -> 402
fin: 401
adj: 402 -> 403
fin: 402
adj: 403 -> 404
fin: 403
fin: 404
Total number of allocations : 4
Total number of deallocations : 4
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295
is now used as Is_Ignored_Transient.
(Is_Finalized_Transient): New routine.
(Is_Ignored_Transient): New routine.
(Is_Processed_Transient): Removed.
(Set_Is_Finalized_Transient): New routine.
(Set_Is_Ignored_Transient): New routine.
(Set_Is_Processed_Transient): Removed.
(Write_Entity_Flags): Output Flag252 and Flag295.
* einfo.ads: New attributes Is_Finalized_Transient
and Is_Ignored_Transient along with occurrences in
entities. Remove attribute Is_Processed_Transient.
(Is_Finalized_Transient): New routine along with pragma Inline.
(Is_Ignored_Transient): New routine along with pragma Inline.
(Is_Processed_Transient): Removed along with pragma Inline.
(Set_Is_Finalized_Transient): New routine along with pragma Inline.
(Set_Is_Ignored_Transient): New routine along with pragma Inline.
(Set_Is_Processed_Transient): Removed along with pragma Inline.
* exp_aggr.adb Add with and use clauses for Exp_Ch11 and Inline.
(Build_Record_Aggr_Code): Change the handling
of controlled record components.
(Ctrl_Init_Expression): Removed.
(Gen_Assign): Add new formal parameter In_Loop
along with comment on usage. Remove local variables Stmt and
Stmt_Expr. Change the handling of controlled array components.
(Gen_Loop): Update the call to Gen_Assign.
(Gen_While): Update the call to Gen_Assign.
(Initialize_Array_Component): New routine.
(Initialize_Ctrl_Array_Component): New routine.
(Initialize_Ctrl_Record_Component): New routine.
(Initialize_Record_Component): New routine.
(Process_Transient_Component): New routine.
(Process_Transient_Component_Completion): New routine.
* exp_ch4.adb (Process_Transient_In_Expression): New routine.
(Process_Transient_Object): Removed. Replace all existing calls
to this routine with calls to Process_Transient_In_Expression.
* exp_ch6.adb (Expand_Ctrl_Function_Call): Remove local constant
Is_Elem_Ref. Update the comment on ignoring transients.
* exp_ch7.adb (Process_Declarations): Do not process ignored
or finalized transient objects.
(Process_Transient_In_Scope): New routine.
(Process_Transients_In_Scope): New routine.
(Process_Transient_Objects): Removed. Replace all existing calls
to this routine with calls to Process_Transients_In_Scope.
* exp_util.adb (Build_Transient_Object_Statements): New routine.
(Is_Finalizable_Transient): Do not consider a transient object
which has been finalized.
(Requires_Cleanup_Actions): Do not consider ignored or finalized
transient objects.
* exp_util.ads (Build_Transient_Object_Statements): New routine.
* sem_aggr.adb: Major code clean up.
* sem_res.adb: Update documentation.
-------------- next part --------------
Index: sem_aggr.adb
===================================================================
--- sem_aggr.adb (revision 238040)
+++ sem_aggr.adb (working copy)
@@ -2930,7 +2930,7 @@
end if;
else
- Error_Msg_N ("no unique type for this aggregate", A);
+ Error_Msg_N ("no unique type for this aggregate", A);
end if;
Check_Function_Writable_Actuals (N);
@@ -2941,25 +2941,9 @@
------------------------------
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Assoc : Node_Id;
- -- N_Component_Association node belonging to the input aggregate N
-
- Expr : Node_Id;
- Positional_Expr : Node_Id;
- Component : Entity_Id;
- Component_Elmt : Elmt_Id;
-
- Components : constant Elist_Id := New_Elmt_List;
- -- Components is the list of the record components whose value must be
- -- provided in the aggregate. This list does include discriminants.
-
New_Assoc_List : constant List_Id := New_List;
- New_Assoc : Node_Id;
-- New_Assoc_List is the newly built list of N_Component_Association
- -- nodes. New_Assoc is one such N_Component_Association node in it.
- -- Note that while Assoc and New_Assoc contain the same kind of nodes,
- -- they are used to iterate over two different N_Component_Association
- -- lists.
+ -- nodes.
Others_Etype : Entity_Id := Empty;
-- This variable is used to save the Etype of the last record component
@@ -2975,7 +2959,6 @@
Box_Node : Node_Id;
Is_Box_Present : Boolean := False;
Others_Box : Integer := 0;
-
-- Ada 2005 (AI-287): Variables used in case of default initialization
-- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization;
@@ -2983,9 +2966,9 @@
-- (which may be a sub-aggregate of a larger one) that are default-
-- initialized. A value of One indicates that an others_box is present.
-- Any larger value indicates that the others_box is not redundant.
- -- These variables, similar to Others_Etype, are also updated as a
- -- side effect of function Get_Value.
- -- Box_Node is used to place a warning on a redundant others_box.
+ -- These variables, similar to Others_Etype, are also updated as a side
+ -- effect of function Get_Value. Box_Node is used to place a warning on
+ -- a redundant others_box.
procedure Add_Association
(Component : Entity_Id;
@@ -2997,14 +2980,23 @@
-- either New_Assoc_List, or the association being built for an inner
-- aggregate.
- function Discr_Present (Discr : Entity_Id) return Boolean;
+ procedure Add_Discriminant_Values
+ (New_Aggr : Node_Id;
+ Assoc_List : List_Id);
+ -- The constraint to a component may be given by a discriminant of the
+ -- enclosing type, in which case we have to retrieve its value, which is
+ -- part of the enclosing aggregate. Assoc_List provides the discriminant
+ -- associations of the current type or of some enclosing record.
+
+ function Discriminant_Present (Input_Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True.
- -- Otherwise, if N is an extension aggregate, Discr is a discriminant
- -- whose value may already have been specified by N's ancestor part.
- -- This routine checks whether this is indeed the case and if so returns
- -- False, signaling that no value for Discr should appear in N's
- -- aggregate part. Also, in this case, the routine appends to
- -- New_Assoc_List the discriminant value specified in the ancestor part.
+ -- Otherwise, if N is an extension aggregate, then Input_Discr denotes
+ -- a discriminant whose value may already have been specified by N's
+ -- ancestor part. This routine checks whether this is indeed the case
+ -- and if so returns False, signaling that no value for Input_Discr
+ -- should appear in N's aggregate part. Also, in this case, the routine
+ -- appends to New_Assoc_List the discriminant value specified in the
+ -- ancestor part.
--
-- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed. The inherited discriminant values must not be reinserted
@@ -3012,11 +3004,16 @@
-- present on first analysis to build the proper subtype indications.
-- The flag Inherited_Discriminant is used to prevent the re-insertion.
+ function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id;
+ -- AI05-0115: Find earlier ancestor in the derivation chain that is
+ -- derived from private view Typ. Whether the aggregate is legal depends
+ -- on the current visibility of the type as well as that of the parent
+ -- of the ancestor.
+
function Get_Value
(Compon : Node_Id;
From : List_Id;
- Consider_Others_Choice : Boolean := False)
- return Node_Id;
+ Consider_Others_Choice : Boolean := False) return Node_Id;
-- Given a record component stored in parameter Compon, this function
-- returns its value as it appears in the list From, which is a list
-- of N_Component_Association nodes.
@@ -3041,7 +3038,14 @@
-- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
-- also copies the dimensions of Source to the returned node.
- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
+ procedure Propagate_Discriminants
+ (Aggr : Node_Id;
+ Assoc_List : List_Id);
+ -- Nested components may themselves be discriminated types constrained
+ -- by outer discriminants, whose values must be captured before the
+ -- aggregate is expanded into assignments.
+
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id);
-- Analyzes and resolves expression Expr against the Etype of the
-- Component. This routine also applies all appropriate checks to Expr.
-- It finally saves a Expr in the newly created association list that
@@ -3059,13 +3063,12 @@
Assoc_List : List_Id;
Is_Box_Present : Boolean := False)
is
- Loc : Source_Ptr;
Choice_List : constant List_Id := New_List;
- New_Assoc : Node_Id;
+ Loc : Source_Ptr;
begin
- -- If this is a box association the expression is missing, so
- -- use the Sloc of the aggregate itself for the new association.
+ -- If this is a box association the expression is missing, so use the
+ -- Sloc of the aggregate itself for the new association.
if Present (Expr) then
Loc := Sloc (Expr);
@@ -3073,35 +3076,98 @@
Loc := Sloc (N);
end if;
- Append (New_Occurrence_Of (Component, Loc), Choice_List);
- New_Assoc :=
+ Append_To (Choice_List, New_Occurrence_Of (Component, Loc));
+
+ Append_To (Assoc_List,
Make_Component_Association (Loc,
Choices => Choice_List,
Expression => Expr,
- Box_Present => Is_Box_Present);
- Append (New_Assoc, Assoc_List);
+ Box_Present => Is_Box_Present));
end Add_Association;
- -------------------
- -- Discr_Present --
- -------------------
+ -----------------------------
+ -- Add_Discriminant_Values --
+ -----------------------------
- function Discr_Present (Discr : Entity_Id) return Boolean is
+ procedure Add_Discriminant_Values
+ (New_Aggr : Node_Id;
+ Assoc_List : List_Id)
+ is
+ Assoc : Node_Id;
+ Discr : Entity_Id;
+ Discr_Elmt : Elmt_Id;
+ Discr_Val : Node_Id;
+ Val : Entity_Id;
+
+ begin
+ Discr := First_Discriminant (Etype (New_Aggr));
+ Discr_Elmt := First_Elmt (Discriminant_Constraint (Etype (New_Aggr)));
+ while Present (Discr_Elmt) loop
+ Discr_Val := Node (Discr_Elmt);
+
+ -- If the constraint is given by a discriminant then it is a
+ -- discriminant of an enclosing record, and its value has already
+ -- been placed in the association list.
+
+ if Is_Entity_Name (Discr_Val)
+ and then Ekind (Entity (Discr_Val)) = E_Discriminant
+ then
+ Val := Entity (Discr_Val);
+
+ Assoc := First (Assoc_List);
+ while Present (Assoc) loop
+ if Present (Entity (First (Choices (Assoc))))
+ and then Entity (First (Choices (Assoc))) = Val
+ then
+ Discr_Val := Expression (Assoc);
+ exit;
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ Add_Association
+ (Discr, New_Copy_Tree (Discr_Val),
+ Component_Associations (New_Aggr));
+
+ -- If the discriminant constraint is a current instance, mark the
+ -- current aggregate so that the self-reference can be expanded
+ -- later. The constraint may refer to the subtype of aggregate, so
+ -- use base type for comparison.
+
+ if Nkind (Discr_Val) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Discr_Val))
+ and then Is_Type (Entity (Prefix (Discr_Val)))
+ and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val))
+ then
+ Set_Has_Self_Reference (N);
+ end if;
+
+ Next_Elmt (Discr_Elmt);
+ Next_Discriminant (Discr);
+ end loop;
+ end Add_Discriminant_Values;
+
+ --------------------------
+ -- Discriminant_Present --
+ --------------------------
+
+ function Discriminant_Present (Input_Discr : Entity_Id) return Boolean is
Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
+ Ancestor_Is_Subtyp : Boolean;
+
Loc : Source_Ptr;
Ancestor : Node_Id;
+ Ancestor_Typ : Entity_Id;
Comp_Assoc : Node_Id;
+ Discr : Entity_Id;
Discr_Expr : Node_Id;
-
- Ancestor_Typ : Entity_Id;
+ Discr_Val : Elmt_Id := No_Elmt;
Orig_Discr : Entity_Id;
- D : Entity_Id;
- D_Val : Elmt_Id := No_Elmt; -- stop junk warning
- Ancestor_Is_Subtyp : Boolean;
-
begin
if Regular_Aggr then
return True;
@@ -3157,42 +3223,67 @@
-- Now look to see if Discr was specified in the ancestor part
if Ancestor_Is_Subtyp then
- D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
+ Discr_Val :=
+ First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
end if;
- Orig_Discr := Original_Record_Component (Discr);
+ Orig_Discr := Original_Record_Component (Input_Discr);
- D := First_Discriminant (Ancestor_Typ);
- while Present (D) loop
+ Discr := First_Discriminant (Ancestor_Typ);
+ while Present (Discr) loop
-- If Ancestor has already specified Disc value then insert its
-- value in the final aggregate.
- if Original_Record_Component (D) = Orig_Discr then
+ if Original_Record_Component (Discr) = Orig_Discr then
if Ancestor_Is_Subtyp then
- Discr_Expr := New_Copy_Tree (Node (D_Val));
+ Discr_Expr := New_Copy_Tree (Node (Discr_Val));
else
Discr_Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ancestor),
- Selector_Name => New_Occurrence_Of (Discr, Loc));
+ Selector_Name => New_Occurrence_Of (Input_Discr, Loc));
end if;
- Resolve_Aggr_Expr (Discr_Expr, Discr);
+ Resolve_Aggr_Expr (Discr_Expr, Input_Discr);
Set_Inherited_Discriminant (Last (New_Assoc_List));
return False;
end if;
- Next_Discriminant (D);
+ Next_Discriminant (Discr);
if Ancestor_Is_Subtyp then
- Next_Elmt (D_Val);
+ Next_Elmt (Discr_Val);
end if;
end loop;
return True;
- end Discr_Present;
+ end Discriminant_Present;
+ ---------------------------
+ -- Find_Private_Ancestor --
+ ---------------------------
+
+ function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id is
+ Par : Entity_Id;
+
+ begin
+ Par := Typ;
+ loop
+ if Has_Private_Ancestor (Par)
+ and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
+ then
+ return Par;
+
+ elsif not Is_Derived_Type (Par) then
+ return Empty;
+
+ else
+ Par := Etype (Base_Type (Par));
+ end if;
+ end loop;
+ end Find_Private_Ancestor;
+
---------------
-- Get_Value --
---------------
@@ -3200,8 +3291,7 @@
function Get_Value
(Compon : Node_Id;
From : List_Id;
- Consider_Others_Choice : Boolean := False)
- return Node_Id
+ Consider_Others_Choice : Boolean := False) return Node_Id
is
Typ : constant Entity_Id := Etype (Compon);
Assoc : Node_Id;
@@ -3266,14 +3356,14 @@
null;
else
Error_Msg_N
- ("components in OTHERS choice must "
- & "have same type", Selector_Name);
+ ("components in OTHERS choice must have same "
+ & "type", Selector_Name);
end if;
end if;
Others_Etype := Typ;
- -- Copy expression so that it is resolved
+ -- Copy the expression so that it is resolved
-- independently for each component, This is needed
-- for accessibility checks on compoents of anonymous
-- access types, even in compile_only mode.
@@ -3414,11 +3504,110 @@
return New_Copy;
end New_Copy_Tree_And_Copy_Dimensions;
+ -----------------------------
+ -- Propagate_Discriminants --
+ -----------------------------
+
+ procedure Propagate_Discriminants
+ (Aggr : Node_Id;
+ Assoc_List : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Needs_Box : Boolean := False;
+
+ procedure Process_Component (Comp : Entity_Id);
+ -- Add one component with a box association to the inner aggregate,
+ -- and recurse if component is itself composite.
+
+ -----------------------
+ -- Process_Component --
+ -----------------------
+
+ procedure Process_Component (Comp : Entity_Id) is
+ T : constant Entity_Id := Etype (Comp);
+ New_Aggr : Node_Id;
+
+ begin
+ if Is_Record_Type (T) and then Has_Discriminants (T) then
+ New_Aggr := Make_Aggregate (Loc, New_List, New_List);
+ Set_Etype (New_Aggr, T);
+
+ Add_Association
+ (Comp, New_Aggr, Component_Associations (Aggr));
+
+ -- Collect discriminant values and recurse
+
+ Add_Discriminant_Values (New_Aggr, Assoc_List);
+ Propagate_Discriminants (New_Aggr, Assoc_List);
+
+ else
+ Needs_Box := True;
+ end if;
+ end Process_Component;
+
+ -- Local variables
+
+ Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr));
+ Components : constant Elist_Id := New_Elmt_List;
+ Def_Node : constant Node_Id :=
+ Type_Definition (Declaration_Node (Aggr_Type));
+
+ Comp : Node_Id;
+ Comp_Elmt : Elmt_Id;
+ Errors : Boolean;
+
+ -- Start of processing for Propagate_Discriminants
+
+ begin
+ -- The component type may be a variant type. Collect the components
+ -- that are ruled by the known values of the discriminants. Their
+ -- values have already been inserted into the component list of the
+ -- current aggregate.
+
+ if Nkind (Def_Node) = N_Record_Definition
+ and then Present (Component_List (Def_Node))
+ and then Present (Variant_Part (Component_List (Def_Node)))
+ then
+ Gather_Components (Aggr_Type,
+ Component_List (Def_Node),
+ Governed_By => Component_Associations (Aggr),
+ Into => Components,
+ Report_Errors => Errors);
+
+ Comp_Elmt := First_Elmt (Components);
+ while Present (Comp_Elmt) loop
+ if Ekind (Node (Comp_Elmt)) /= E_Discriminant then
+ Process_Component (Node (Comp_Elmt));
+ end if;
+
+ Next_Elmt (Comp_Elmt);
+ end loop;
+
+ -- No variant part, iterate over all components
+
+ else
+ Comp := First_Component (Etype (Aggr));
+ while Present (Comp) loop
+ Process_Component (Comp);
+ Next_Component (Comp);
+ end loop;
+ end if;
+
+ if Needs_Box then
+ Append_To (Component_Associations (Aggr),
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True));
+ end if;
+ end Propagate_Discriminants;
+
-----------------------
-- Resolve_Aggr_Expr --
-----------------------
- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id) is
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
-- If the expression is an aggregate (possibly qualified) then its
-- expansion is delayed until the enclosing aggregate is expanded
@@ -3433,14 +3622,15 @@
---------------------------
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
- Kind : constant Node_Kind := Nkind (Expr);
begin
- return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)
- and then Present (Etype (Expr))
- and then Is_Record_Type (Etype (Expr))
- and then Expansion_Delayed (Expr))
- or else (Kind = N_Qualified_Expression
- and then Has_Expansion_Delayed (Expression (Expr)));
+ return
+ (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ and then Present (Etype (Expr))
+ and then Is_Record_Type (Etype (Expr))
+ and then Expansion_Delayed (Expr))
+ or else
+ (Nkind (Expr) = N_Qualified_Expression
+ and then Has_Expansion_Delayed (Expression (Expr)));
end Has_Expansion_Delayed;
-- Local variables
@@ -3580,6 +3770,8 @@
Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
end if;
+ -- Add association Component => Expr if the caller requests it
+
if Relocate then
New_Expr := Relocate_Node (Expr);
@@ -3595,6 +3787,17 @@
Add_Association (New_C, New_Expr, New_Assoc_List);
end Resolve_Aggr_Expr;
+ -- Local variables
+
+ Components : constant Elist_Id := New_Elmt_List;
+ -- Components is the list of the record components whose value must be
+ -- provided in the aggregate. This list does include discriminants.
+
+ Expr : Node_Id;
+ Component : Entity_Id;
+ Component_Elmt : Elmt_Id;
+ Positional_Expr : Node_Id;
+
-- Start of processing for Resolve_Record_Aggregate
begin
@@ -3607,7 +3810,6 @@
if Present (Component_Associations (N))
and then Present (First (Component_Associations (N)))
then
-
if Present (Expressions (N)) then
Check_SPARK_05_Restriction
("named association cannot follow positional one",
@@ -3678,8 +3880,9 @@
-- STEP 2: Verify aggregate structure
Step_2 : declare
- Selector_Name : Node_Id;
+ Assoc : Node_Id;
Bad_Aggregate : Boolean := False;
+ Selector_Name : Node_Id;
begin
if Present (Component_Associations (N)) then
@@ -3774,7 +3977,7 @@
-- First find the discriminant values in the positional components
while Present (Discrim) and then Present (Positional_Expr) loop
- if Discr_Present (Discrim) then
+ if Discriminant_Present (Discrim) then
Resolve_Aggr_Expr (Positional_Expr, Discrim);
-- Ada 2005 (AI-231)
@@ -3802,7 +4005,7 @@
while Present (Discrim) loop
Expr := Get_Value (Discrim, Component_Associations (N), True);
- if not Discr_Present (Discrim) then
+ if not Discriminant_Present (Discrim) then
if Present (Expr) then
Error_Msg_NE
("more than one value supplied for discriminant &",
@@ -3850,17 +4053,17 @@
and then Present (Underlying_Record_View (Typ)))
then
Build_Constrained_Itype : declare
+ Constrs : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : Entity_Id;
Indic : Node_Id;
+ New_Assoc : Node_Id;
Subtyp_Decl : Node_Id;
- Def_Id : Entity_Id;
- C : constant List_Id := New_List;
-
begin
New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop
- Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C);
+ Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
Next (New_Assoc);
end loop;
@@ -3872,14 +4075,16 @@
Subtype_Mark =>
New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc, C));
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
else
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc, C));
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
end if;
Def_Id := Create_Itype (Ekind (Typ), N);
@@ -3906,46 +4111,14 @@
-- STEP 5: Get remaining components according to discriminant values
Step_5 : declare
+ Dnode : Node_Id;
+ Errors_Found : Boolean := False;
Record_Def : Node_Id;
Parent_Typ : Entity_Id;
- Root_Typ : Entity_Id;
Parent_Typ_List : Elist_Id;
Parent_Elmt : Elmt_Id;
- Errors_Found : Boolean := False;
- Dnode : Node_Id;
+ Root_Typ : Entity_Id;
- function Find_Private_Ancestor return Entity_Id;
- -- AI05-0115: Find earlier ancestor in the derivation chain that is
- -- derived from a private view. Whether the aggregate is legal
- -- depends on the current visibility of the type as well as that
- -- of the parent of the ancestor.
-
- ---------------------------
- -- Find_Private_Ancestor --
- ---------------------------
-
- function Find_Private_Ancestor return Entity_Id is
- Par : Entity_Id;
-
- begin
- Par := Typ;
- loop
- if Has_Private_Ancestor (Par)
- and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
- then
- return Par;
-
- elsif not Is_Derived_Type (Par) then
- return Empty;
-
- else
- Par := Etype (Base_Type (Par));
- end if;
- end loop;
- end Find_Private_Ancestor;
-
- -- Start of processing for Step_5
-
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
Parent_Typ_List := New_Elmt_List;
@@ -3959,19 +4132,20 @@
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
- -- AI05-0115: check legality of aggregate for type with
- -- aa private ancestor.
+ -- AI05-0115: check legality of aggregate for type with a
+ -- private ancestor.
Root_Typ := Root_Type (Typ);
if Has_Private_Ancestor (Typ) then
declare
Ancestor : constant Entity_Id :=
- Find_Private_Ancestor;
+ Find_Private_Ancestor (Typ);
Ancestor_Unit : constant Entity_Id :=
- Cunit_Entity (Get_Source_Unit (Ancestor));
+ Cunit_Entity
+ (Get_Source_Unit (Ancestor));
Parent_Unit : constant Entity_Id :=
- Cunit_Entity
- (Get_Source_Unit (Base_Type (Etype (Ancestor))));
+ Cunit_Entity (Get_Source_Unit
+ (Base_Type (Etype (Ancestor))));
begin
-- Check whether we are in a scope that has full view
-- over the private ancestor and its parent. This can
@@ -4189,8 +4363,7 @@
-- object of the aggregate.
if Present (Parent (Component))
- and then
- Nkind (Parent (Component)) = N_Component_Declaration
+ and then Nkind (Parent (Component)) = N_Component_Declaration
and then Present (Expression (Parent (Component)))
then
Expr :=
@@ -4213,26 +4386,18 @@
elsif Present (Underlying_Type (Ctyp))
and then Is_Access_Type (Underlying_Type (Ctyp))
then
- if not Is_Private_Type (Ctyp) then
- Expr := Make_Null (Sloc (N));
- Set_Etype (Expr, Ctyp);
- Add_Association
- (Component => Component,
- Expr => Expr,
- Assoc_List => New_Assoc_List);
-
-- If the component's type is private with an access type as
-- its underlying type then we have to create an unchecked
-- conversion to satisfy type checking.
- else
+ if Is_Private_Type (Ctyp) then
declare
Qual_Null : constant Node_Id :=
Make_Qualified_Expression (Sloc (N),
Subtype_Mark =>
New_Occurrence_Of
(Underlying_Type (Ctyp), Sloc (N)),
- Expression => Make_Null (Sloc (N)));
+ Expression => Make_Null (Sloc (N)));
Convert_Null : constant Node_Id :=
Unchecked_Convert_To
@@ -4245,6 +4410,17 @@
Expr => Convert_Null,
Assoc_List => New_Assoc_List);
end;
+
+ -- Otherwise the component type is non-private
+
+ else
+ Expr := Make_Null (Sloc (N));
+ Set_Etype (Expr, Ctyp);
+
+ Add_Association
+ (Component => Component,
+ Expr => Expr,
+ Assoc_List => New_Assoc_List);
end if;
-- Ada 2012: If component is scalar with default value, use it
@@ -4254,8 +4430,9 @@
then
Add_Association
(Component => Component,
- Expr => Default_Aspect_Value
- (First_Subtype (Underlying_Type (Ctyp))),
+ Expr =>
+ Default_Aspect_Value
+ (First_Subtype (Underlying_Type (Ctyp))),
Assoc_List => New_Assoc_List);
elsif Has_Non_Null_Base_Init_Proc (Ctyp)
@@ -4270,8 +4447,8 @@
-- for the rest, if other components are present.
-- The type of the aggregate is the known subtype of
- -- the component. The capture of discriminants must
- -- be recursive because subcomponents may be constrained
+ -- the component. The capture of discriminants must be
+ -- recursive because subcomponents may be constrained
-- (transitively) by discriminants of enclosing types.
-- For a private type with discriminants, a call to the
-- initialization procedure will be generated, and no
@@ -4281,206 +4458,6 @@
Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id;
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id);
- -- The constraint to a component may be given by a
- -- discriminant of the enclosing type, in which case
- -- we have to retrieve its value, which is part of the
- -- enclosing aggregate. Assoc_List provides the
- -- discriminant associations of the current type or
- -- of some enclosing record.
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id);
- -- Nested components may themselves be discriminated
- -- types constrained by outer discriminants, whose
- -- values must be captured before the aggregate is
- -- expanded into assignments.
-
- -----------------------------
- -- Add_Discriminant_Values --
- -----------------------------
-
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Assoc : Node_Id;
- Discr : Entity_Id;
- Discr_Elmt : Elmt_Id;
- Discr_Val : Node_Id;
- Val : Entity_Id;
-
- begin
- Discr := First_Discriminant (Etype (New_Aggr));
- Discr_Elmt :=
- First_Elmt
- (Discriminant_Constraint (Etype (New_Aggr)));
- while Present (Discr_Elmt) loop
- Discr_Val := Node (Discr_Elmt);
-
- -- If the constraint is given by a discriminant
- -- it is a discriminant of an enclosing record,
- -- and its value has already been placed in the
- -- association list.
-
- if Is_Entity_Name (Discr_Val)
- and then
- Ekind (Entity (Discr_Val)) = E_Discriminant
- then
- Val := Entity (Discr_Val);
-
- Assoc := First (Assoc_List);
- while Present (Assoc) loop
- if Present
- (Entity (First (Choices (Assoc))))
- and then
- Entity (First (Choices (Assoc))) = Val
- then
- Discr_Val := Expression (Assoc);
- exit;
- end if;
-
- Next (Assoc);
- end loop;
- end if;
-
- Add_Association
- (Discr, New_Copy_Tree (Discr_Val),
- Component_Associations (New_Aggr));
-
- -- If the discriminant constraint is a current
- -- instance, mark the current aggregate so that
- -- the self-reference can be expanded later.
- -- The constraint may refer to the subtype of
- -- aggregate, so use base type for comparison.
-
- if Nkind (Discr_Val) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Discr_Val))
- and then Is_Type (Entity (Prefix (Discr_Val)))
- and then Base_Type (Etype (N)) =
- Entity (Prefix (Discr_Val))
- then
- Set_Has_Self_Reference (N);
- end if;
-
- Next_Elmt (Discr_Elmt);
- Next_Discriminant (Discr);
- end loop;
- end Add_Discriminant_Values;
-
- -----------------------------
- -- Propagate_Discriminants --
- -----------------------------
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Aggr_Type : constant Entity_Id :=
- Base_Type (Etype (Aggr));
- Def_Node : constant Node_Id :=
- Type_Definition
- (Declaration_Node (Aggr_Type));
-
- Comp : Node_Id;
- Comp_Elmt : Elmt_Id;
- Components : constant Elist_Id := New_Elmt_List;
- Needs_Box : Boolean := False;
- Errors : Boolean;
-
- procedure Process_Component (Comp : Entity_Id);
- -- Add one component with a box association to the
- -- inner aggregate, and recurse if component is
- -- itself composite.
-
- -----------------------
- -- Process_Component --
- -----------------------
-
- procedure Process_Component (Comp : Entity_Id) is
- T : constant Entity_Id := Etype (Comp);
- New_Aggr : Node_Id;
-
- begin
- if Is_Record_Type (T)
- and then Has_Discriminants (T)
- then
- New_Aggr :=
- Make_Aggregate (Loc, New_List, New_List);
- Set_Etype (New_Aggr, T);
- Add_Association
- (Comp, New_Aggr,
- Component_Associations (Aggr));
-
- -- Collect discriminant values and recurse
-
- Add_Discriminant_Values
- (New_Aggr, Assoc_List);
- Propagate_Discriminants
- (New_Aggr, Assoc_List);
-
- else
- Needs_Box := True;
- end if;
- end Process_Component;
-
- -- Start of processing for Propagate_Discriminants
-
- begin
- -- The component type may be a variant type, so
- -- collect the components that are ruled by the
- -- known values of the discriminants. Their values
- -- have already been inserted into the component
- -- list of the current aggregate.
-
- if Nkind (Def_Node) = N_Record_Definition
- and then Present (Component_List (Def_Node))
- and then
- Present
- (Variant_Part (Component_List (Def_Node)))
- then
- Gather_Components (Aggr_Type,
- Component_List (Def_Node),
- Governed_By => Component_Associations (Aggr),
- Into => Components,
- Report_Errors => Errors);
-
- Comp_Elmt := First_Elmt (Components);
- while Present (Comp_Elmt) loop
- if Ekind (Node (Comp_Elmt)) /=
- E_Discriminant
- then
- Process_Component (Node (Comp_Elmt));
- end if;
-
- Next_Elmt (Comp_Elmt);
- end loop;
-
- -- No variant part, iterate over all components
-
- else
- Comp := First_Component (Etype (Aggr));
- while Present (Comp) loop
- Process_Component (Comp);
- Next_Component (Comp);
- end loop;
- end if;
-
- if Needs_Box then
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices =>
- New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True));
- end if;
- end Propagate_Discriminants;
-
- -- Start of processing for Capture_Discriminants
-
begin
Expr := Make_Aggregate (Loc, New_List, New_List);
Set_Etype (Expr, Ctyp);
@@ -4498,9 +4475,9 @@
elsif Has_Discriminants (Ctyp) then
Add_Discriminant_Values
- (Expr, Component_Associations (Expr));
+ (Expr, Component_Associations (Expr));
Propagate_Discriminants
- (Expr, Component_Associations (Expr));
+ (Expr, Component_Associations (Expr));
else
declare
@@ -4523,6 +4500,7 @@
Expression => Empty,
Box_Present => True));
end if;
+
exit;
end if;
@@ -4537,6 +4515,9 @@
Assoc_List => New_Assoc_List);
end Capture_Discriminants;
+ -- Otherwise the component type is not a record, or it has
+ -- not discriminants, or it is private.
+
else
Add_Association
(Component => Component,
@@ -4576,6 +4557,9 @@
-- STEP 7: check for invalid components + check type in choice list
Step_7 : declare
+ Assoc : Node_Id;
+ New_Assoc : Node_Id;
+
Selectr : Node_Id;
-- Selector name
@@ -4651,7 +4635,7 @@
if Nkind (N) /= N_Extension_Aggregate
or else
Scope (Original_Record_Component (C)) /=
- Etype (Ancestor_Part (N))
+ Etype (Ancestor_Part (N))
then
exit;
end if;
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 238040)
+++ exp_ch7.adb (working copy)
@@ -2080,11 +2080,19 @@
if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null;
- -- Transient variables are treated separately in order to
- -- minimize the size of the generated code. For details, see
- -- Process_Transient_Objects.
+ -- Finalization of transient objects are treated separately in
+ -- order to handle sensitive cases. These include:
- elsif Is_Processed_Transient (Obj_Id) then
+ -- * Aggregate expansion
+ -- * If, case, and expression with actions expansion
+ -- * Transient scopes
+
+ -- If one of those contexts has marked the transient object as
+ -- ignored, do not generate finalization actions for it.
+
+ elsif Is_Finalized_Transient (Obj_Id)
+ or else Is_Ignored_Transient (Obj_Id)
+ then
null;
-- Ignored Ghost objects do not need any cleanup actions
@@ -2139,8 +2147,8 @@
then
Processing_Actions (Has_No_Init => True);
- -- Processing for "hook" objects generated for controlled
- -- transients declared inside an Expression_With_Actions.
+ -- Processing for "hook" objects generated for transient
+ -- objects declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
@@ -2353,7 +2361,7 @@
end if;
end if;
- -- Handle a rare case caused by a controlled transient variable
+ -- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.
@@ -3124,7 +3132,7 @@
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
-- Temporaries created for the purpose of "exporting" a
- -- controlled transient out of an Expression_With_Actions (EWA)
+ -- transient object out of an Expression_With_Actions (EWA)
-- need guards. The following illustrates the usage of such
-- temporaries.
@@ -6392,30 +6400,31 @@
Act_Cleanup : constant List_Id :=
Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
-- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
- -- Last), but this was incorrect as Process_Transient_Object may
+ -- Last), but this was incorrect as Process_Transients_In_Scope may
-- introduce new scopes and cause a reallocation of Scope_Stack.Table.
- procedure Process_Transient_Objects
+ procedure Process_Transients_In_Scope
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id);
- -- First_Object and Last_Object define a list which contains potential
- -- controlled transient objects. Finalization flags are inserted before
- -- First_Object and finalization calls are inserted after Last_Object.
- -- Related_Node is the node for which transient objects have been
- -- created.
+ -- Find all transient objects in the list First_Object .. Last_Object
+ -- and generate finalization actions for them. Related_Node denotes the
+ -- node which created all transient objects.
- -------------------------------
- -- Process_Transient_Objects --
- -------------------------------
+ ---------------------------------
+ -- Process_Transients_In_Scope --
+ ---------------------------------
- procedure Process_Transient_Objects
+ procedure Process_Transients_In_Scope
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id)
is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
Must_Hook : Boolean := False;
- -- Flag denoting whether the context requires transient variable
+ -- Flag denoting whether the context requires transient object
-- export to the outer finalizer.
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
@@ -6424,6 +6433,15 @@
procedure Detect_Subprogram_Call is
new Traverse_Proc (Is_Subprogram_Call);
+ procedure Process_Transient_In_Scope
+ (Obj_Decl : Node_Id;
+ Blk_Data : Finalization_Exception_Data;
+ Blk_Stmts : List_Id);
+ -- Generate finalization actions for a single transient object
+ -- denoted by object declaration Obj_Decl. Blk_Data is the
+ -- exception data of the enclosing block. Blk_Stmts denotes the
+ -- statements of the enclosing block.
+
------------------------
-- Is_Subprogram_Call --
------------------------
@@ -6466,32 +6484,149 @@
end if;
end Is_Subprogram_Call;
- -- Local variables
+ --------------------------------
+ -- Process_Transient_In_Scope --
+ --------------------------------
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
+ procedure Process_Transient_In_Scope
+ (Obj_Decl : Node_Id;
+ Blk_Data : Finalization_Exception_Data;
+ Blk_Stmts : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+ Fin_Call : Node_Id;
+ Fin_Stmts : List_Id;
+ Hook_Assign : Node_Id;
+ Hook_Clear : Node_Id;
+ Hook_Decl : Node_Id;
+ Hook_Insert : Node_Id;
+ Ptr_Decl : Node_Id;
+ begin
+ -- Mark the transient object as successfully processed to avoid
+ -- double finalization.
+
+ Set_Is_Finalized_Transient (Obj_Id);
+
+ -- Construct all the pieces necessary to hook and finalize the
+ -- transient object.
+
+ Build_Transient_Object_Statements
+ (Obj_Decl => Obj_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl);
+
+ -- The context contains at least one subprogram call which may
+ -- raise an exception. This scenario employs "hooking" to pass
+ -- transient objects to the enclosing finalizer in case of an
+ -- exception.
+
+ if Must_Hook then
+
+ -- Add the access type which provides a reference to the
+ -- transient object. Generate:
+
+ -- type Ptr_Typ is access all Desig_Typ;
+
+ Insert_Action (Obj_Decl, Ptr_Decl);
+
+ -- Add the temporary which acts as a hook to the transient
+ -- object. Generate:
+
+ -- Hook : Ptr_Typ := null;
+
+ Insert_Action (Obj_Decl, Hook_Decl);
+
+ -- When the transient object is initialized by an aggregate,
+ -- the hook must capture the object after the last aggregate
+ -- assignment takes place. Only then is the object considered
+ -- fully initialized. Generate:
+
+ -- Hook := Ptr_Typ (Obj_Id);
+ -- <or>
+ -- Hook := Obj_Id'Unrestricted_Access;
+
+ if Ekind_In (Obj_Id, E_Constant, E_Variable)
+ and then Present (Last_Aggregate_Assignment (Obj_Id))
+ then
+ Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
+
+ -- Otherwise the hook seizes the related object immediately
+
+ else
+ Hook_Insert := Obj_Decl;
+ end if;
+
+ Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
+ end if;
+
+ -- When exception propagation is enabled wrap the hook clear
+ -- statement and the finalization call into a block to catch
+ -- potential exceptions raised during finalization. Generate:
+
+ -- begin
+ -- [Hook := null;]
+ -- [Deep_]Finalize (Obj_Ref);
+
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence
+ -- (Enn, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
+
+ if Exceptions_OK then
+ Fin_Stmts := New_List;
+
+ if Must_Hook then
+ Append_To (Fin_Stmts, Hook_Clear);
+ end if;
+
+ Append_To (Fin_Stmts, Fin_Call);
+
+ Prepend_To (Blk_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Fin_Stmts,
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Blk_Data)))));
+
+ -- Otherwise generate:
+
+ -- [Hook := null;]
+ -- [Deep_]Finalize (Obj_Ref);
+
+ -- Note that the statements are inserted in reverse order to
+ -- achieve the desired final order outlined above.
+
+ else
+ Prepend_To (Blk_Stmts, Fin_Call);
+
+ if Must_Hook then
+ Prepend_To (Blk_Stmts, Hook_Clear);
+ end if;
+ end if;
+ end Process_Transient_In_Scope;
+
+ -- Local variables
+
Built : Boolean := False;
+ Blk_Data : Finalization_Exception_Data;
Blk_Decl : Node_Id := Empty;
Blk_Decls : List_Id := No_List;
Blk_Ins : Node_Id;
Blk_Stmts : List_Id;
- Desig_Typ : Entity_Id;
- Fin_Call : Node_Id;
- Fin_Data : Finalization_Exception_Data;
- Fin_Stmts : List_Id;
- Hook_Clr : Node_Id := Empty;
- Hook_Id : Entity_Id;
- Hook_Ins : Node_Id;
- Init_Expr : Node_Id;
Loc : Source_Ptr;
Obj_Decl : Node_Id;
- Obj_Id : Entity_Id;
- Obj_Ref : Node_Id;
- Obj_Typ : Entity_Id;
- Ptr_Typ : Entity_Id;
- -- Start of processing for Process_Transient_Objects
+ -- Start of processing for Process_Transients_In_Scope
begin
-- The expansion performed by this routine is as follows:
@@ -6536,11 +6671,11 @@
-- Save_Occurrence (Ex, Get_Current_Excep.all.all);
-- end;
+ -- Abort_Undefer;
+
-- if Raised and not Abrt then
-- Raise_From_Controlled_Operation (Ex);
-- end if;
-
- -- Abort_Undefer_Direct;
-- end;
-- Recognize a scenario where the transient context is an object
@@ -6554,8 +6689,8 @@
-- Obj : ...;
-- Res : ... := BIP_Func_Call (..., Obj, ...);
- -- The finalization of any controlled transient must happen after
- -- the build-in-place function call is executed.
+ -- The finalization of any transient object must happen after the
+ -- build-in-place function call is executed.
if Nkind (N) = N_Object_Declaration
and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
@@ -6589,115 +6724,8 @@
and then Obj_Decl /= Related_Node
then
- Loc := Sloc (Obj_Decl);
- Obj_Id := Defining_Identifier (Obj_Decl);
- Obj_Typ := Base_Type (Etype (Obj_Id));
- Desig_Typ := Obj_Typ;
+ Loc := Sloc (Obj_Decl);
- Set_Is_Processed_Transient (Obj_Id);
-
- -- Handle access types
-
- if Is_Access_Type (Desig_Typ) then
- Desig_Typ := Available_View (Designated_Type (Desig_Typ));
- end if;
-
- -- Transient objects associated with subprogram calls need
- -- extra processing. These objects are usually created right
- -- before the call and finalized immediately after the call.
- -- If an exception occurs during the call, the clean up code
- -- is skipped due to the sudden change in control and the
- -- transient is never finalized.
-
- -- To handle this case, such variables are "exported" to the
- -- enclosing sequence of statements where their corresponding
- -- "hooks" are picked up by the finalization machinery.
-
- if Must_Hook then
-
- -- Create an access type which provides a reference to the
- -- transient object. Generate:
- -- type Ptr_Typ is access [all] Desig_Typ;
-
- Ptr_Typ := Make_Temporary (Loc, 'A');
-
- Insert_Action (Obj_Decl,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present =>
- Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication =>
- New_Occurrence_Of (Desig_Typ, Loc))));
-
- -- Create a temporary which acts as a hook to the transient
- -- object. Generate:
- -- Hook : Ptr_Typ := null;
-
- Hook_Id := Make_Temporary (Loc, 'T');
-
- Insert_Action (Obj_Decl,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Hook_Id,
- Object_Definition =>
- New_Occurrence_Of (Ptr_Typ, Loc)));
-
- -- Mark the temporary as a hook. This signals the machinery
- -- in Build_Finalizer to recognize this special case.
-
- Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
-
- -- Hook the transient object to the temporary. Generate:
- -- Hook := Ptr_Typ (Obj_Id);
- -- <or>
- -- Hook := Obj_Id'Unrestricted_Access;
-
- if Is_Access_Type (Obj_Typ) then
- Init_Expr :=
- Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
-
- else
- Init_Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
-
- -- When the transient object is initialized by an aggregate,
- -- the hook must capture the object after the last component
- -- assignment takes place. Only then is the object fully
- -- initialized.
-
- if Ekind (Obj_Id) = E_Variable
- and then Present (Last_Aggregate_Assignment (Obj_Id))
- then
- Hook_Ins := Last_Aggregate_Assignment (Obj_Id);
-
- -- Otherwise the hook seizes the related object immediately
-
- else
- Hook_Ins := Obj_Decl;
- end if;
-
- Insert_After_And_Analyze (Hook_Ins,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Init_Expr));
-
- -- The transient object is about to be finalized by the
- -- clean up code following the subprogram call. In order
- -- to avoid double finalization, clear the hook.
-
- -- Generate:
- -- Hook := null;
-
- Hook_Clr :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Make_Null (Loc));
- end if;
-
-- Before generating the clean up code for the first transient
-- object, create a wrapper block which houses all hook clear
-- statements and finalization calls. This wrapper is needed by
@@ -6707,25 +6735,14 @@
Built := True;
Blk_Stmts := New_List;
- -- Create the declarations of all entities that participate
- -- in exception detection and propagation.
+ -- Generate:
+ -- Abrt : constant Boolean := ...;
+ -- Ex : Exception_Occurrence;
+ -- Raised : Boolean := False;
if Exceptions_OK then
Blk_Decls := New_List;
-
- -- Generate:
- -- Abrt : constant Boolean := ...;
- -- Ex : Exception_Occurrence;
- -- Raised : Boolean := False;
-
- Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
-
- -- Generate:
- -- if Raised and then not Abrt then
- -- Raise_From_Controlled_Operation (Ex);
- -- end if;
-
- Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
+ Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
end if;
Blk_Decl :=
@@ -6736,64 +6753,13 @@
Statements => Blk_Stmts));
end if;
- -- Generate:
- -- [Deep_]Finalize (Obj_Ref);
+ -- Construct all necessary circuitry to hook and finalize a
+ -- single transient object.
- Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
-
- if Is_Access_Type (Obj_Typ) then
- Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
- Set_Etype (Obj_Ref, Desig_Typ);
- end if;
-
- Fin_Call :=
- Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
-
- -- When exception propagation is enabled wrap the hook clear
- -- statement and the finalization call into a block to catch
- -- potential exceptions raised during finalization. Generate:
-
- -- begin
- -- [Temp := null;]
- -- [Deep_]Finalize (Obj_Ref);
-
- -- exception
- -- when others =>
- -- if not Raised then
- -- Raised := True;
- -- Save_Occurrence
- -- (Enn, Get_Current_Excep.all.all);
- -- end if;
- -- end;
-
- if Exceptions_OK then
- Fin_Stmts := New_List;
-
- if Present (Hook_Clr) then
- Append_To (Fin_Stmts, Hook_Clr);
- end if;
-
- Append_To (Fin_Stmts, Fin_Call);
-
- Prepend_To (Blk_Stmts,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Fin_Stmts,
- Exception_Handlers => New_List (
- Build_Exception_Handler (Fin_Data)))));
-
- -- Otherwise generate:
- -- [Temp := null;]
- -- [Deep_]Finalize (Obj_Ref);
-
- else
- Prepend_To (Blk_Stmts, Fin_Call);
-
- if Present (Hook_Clr) then
- Prepend_To (Blk_Stmts, Hook_Clr);
- end if;
- end if;
+ Process_Transient_In_Scope
+ (Obj_Decl => Obj_Decl,
+ Blk_Data => Blk_Data,
+ Blk_Stmts => Blk_Stmts);
end if;
-- Terminate the scan after the last object has been processed to
@@ -6806,12 +6772,15 @@
Next (Obj_Decl);
end loop;
+ -- Complete the decoration of the enclosing finalization block and
+ -- insert it into the tree.
+
if Present (Blk_Decl) then
- -- Note that the abort defer / undefer pair does not require an
- -- extra block because each finalization exception is caught in
- -- its corresponding finalization block. As a result, the call to
- -- Abort_Defer always takes place.
+ -- Note that this Abort_Undefer does not require a extra block or
+ -- an AT_END handler because each finalization exception is caught
+ -- in its own corresponding finalization block. As a result, the
+ -- call to Abort_Defer always takes place.
if Abort_Allowed then
Prepend_To (Blk_Stmts,
@@ -6821,9 +6790,18 @@
Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
+ -- Generate:
+ -- if Raised and then not Abrt then
+ -- Raise_From_Controlled_Operation (Ex);
+ -- end if;
+
+ if Exceptions_OK then
+ Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
+ end if;
+
Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
end if;
- end Process_Transient_Objects;
+ end Process_Transients_In_Scope;
-- Local variables
@@ -6901,10 +6879,10 @@
(Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
end if;
- -- Check for transient controlled objects associated with Target and
- -- generate the appropriate finalization actions for them.
+ -- Check for transient objects associated with Target and generate the
+ -- appropriate finalization actions for them.
- Process_Transient_Objects
+ Process_Transients_In_Scope
(First_Object => First_Obj,
Last_Object => Last_Obj,
Related_Node => Target);
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 238040)
+++ exp_util.adb (working copy)
@@ -1653,6 +1653,133 @@
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image;
+ ---------------------------------------
+ -- Build_Transient_Object_Statements --
+ ---------------------------------------
+
+ procedure Build_Transient_Object_Statements
+ (Obj_Decl : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Assign : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Hook_Decl : out Node_Id;
+ Ptr_Decl : out Node_Id;
+ Finalize_Obj : Boolean := True)
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+ Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
+
+ Desig_Typ : Entity_Id;
+ Hook_Expr : Node_Id;
+ Hook_Id : Entity_Id;
+ Obj_Ref : Node_Id;
+ Ptr_Typ : Entity_Id;
+
+ begin
+ -- Recover the type of the object
+
+ Desig_Typ := Obj_Typ;
+
+ if Is_Access_Type (Desig_Typ) then
+ Desig_Typ := Available_View (Designated_Type (Desig_Typ));
+ end if;
+
+ -- Create an access type which provides a reference to the transient
+ -- object. Generate:
+
+ -- type Ptr_Typ is access all Desig_Typ;
+
+ Ptr_Typ := Make_Temporary (Loc, 'A');
+ Set_Ekind (Ptr_Typ, E_General_Access_Type);
+ Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
+
+ Ptr_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
+
+ -- Create a temporary check which acts as a hook to the transient
+ -- object. Generate:
+
+ -- Hook : Ptr_Typ := null;
+
+ Hook_Id := Make_Temporary (Loc, 'T');
+ Set_Ekind (Hook_Id, E_Variable);
+ Set_Etype (Hook_Id, Ptr_Typ);
+
+ Hook_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Hook_Id,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression => Make_Null (Loc));
+
+ -- Mark the temporary as a hook. This signals the machinery in
+ -- Build_Finalizer to recognize this special case.
+
+ Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
+
+ -- Hook the transient object to the temporary. Generate:
+
+ -- Hook := Ptr_Typ (Obj_Id);
+ -- <or>
+ -- Hool := Obj_Id'Unrestricted_Access;
+
+ if Is_Access_Type (Obj_Typ) then
+ Hook_Expr :=
+ Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
+ else
+ Hook_Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+ end if;
+
+ Hook_Assign :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Hook_Id, Loc),
+ Expression => Hook_Expr);
+
+ -- Crear the hook prior to finalizing the object. Generate:
+
+ -- Hook := null;
+
+ Hook_Clear :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Hook_Id, Loc),
+ Expression => Make_Null (Loc));
+
+ -- Finalize the object. Generate:
+
+ -- [Deep_]Finalize (Obj_Ref[.all]);
+
+ if Finalize_Obj then
+ Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
+
+ if Is_Access_Type (Obj_Typ) then
+ Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
+ Set_Etype (Obj_Ref, Desig_Typ);
+ end if;
+
+ Fin_Call := Make_Final_Call (Obj_Ref, Desig_Typ);
+
+ -- Otherwise finalize the hook. Generate:
+
+ -- [Deep_]Finalize (Hook.all);
+
+ else
+ Fin_Call :=
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Hook_Id, Loc)),
+ Typ => Desig_Typ);
+ end if;
+ end Build_Transient_Object_Statements;
+
-----------------------------
-- Check_Float_Op_Overflow --
-----------------------------
@@ -5067,7 +5194,7 @@
-- explicit aliases of it:
-- do
- -- Trans_Id : Ctrl_Typ ...; -- controlled transient object
+ -- Trans_Id : Ctrl_Typ ...; -- transient object
-- Alias : ... := Trans_Id; -- object is aliased
-- Val : constant Boolean :=
-- ... Alias ...; -- aliasing ends
@@ -5236,6 +5363,10 @@
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+ -- Do not consider a transient object that was already processed
+
+ and then not Is_Finalized_Transient (Obj_Id)
+
-- Do not consider renamed or 'reference-d transient objects because
-- the act of renaming extends the object's lifetime.
@@ -8255,11 +8386,19 @@
if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null;
- -- Transient variables are treated separately in order to minimize
- -- the size of the generated code. See Exp_Ch7.Process_Transient_
- -- Objects.
+ -- Finalization of transient objects are treated separately in
+ -- order to handle sensitive cases. These include:
- elsif Is_Processed_Transient (Obj_Id) then
+ -- * Aggregate expansion
+ -- * If, case, and expression with actions expansion
+ -- * Transient scopes
+
+ -- If one of those contexts has marked the transient object as
+ -- ignored, do not generate finalization actions for it.
+
+ elsif Is_Finalized_Transient (Obj_Id)
+ or else Is_Ignored_Transient (Obj_Id)
+ then
null;
-- Ignored Ghost objects do not need any cleanup actions because
@@ -8315,8 +8454,8 @@
then
return True;
- -- Processing for "hook" objects generated for controlled
- -- transients declared inside an Expression_With_Actions.
+ -- Processing for "hook" objects generated for transient objects
+ -- declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
@@ -8464,7 +8603,7 @@
elsif Nkind (Decl) = N_Block_Statement
and then
- -- Handle a rare case caused by a controlled transient variable
+ -- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 238040)
+++ exp_util.ads (working copy)
@@ -280,6 +280,35 @@
-- is false, the call is for a stand-alone object, and the generated
-- function itself must do its own cleanups.
+ procedure Build_Transient_Object_Statements
+ (Obj_Decl : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Assign : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Hook_Decl : out Node_Id;
+ Ptr_Decl : out Node_Id;
+ Finalize_Obj : Boolean := True);
+ -- Subsidiary to the processing of transient objects in transient scopes,
+ -- if expressions, case expressions, expression_with_action nodes, array
+ -- aggregates, and record aggregates. Obj_Decl denotes the declaration of
+ -- the transient object. Generate the following nodes:
+ --
+ -- * Fin_Call - the call to [Deep_]Finalize which cleans up the transient
+ -- object if flag Finalize_Obj is set to True, or finalizes the hook when
+ -- the flag is False.
+ --
+ -- * Hook_Assign - the assignment statement which captures a reference to
+ -- the transient object in the hook.
+ --
+ -- * Hook_Clear - the assignment statement which resets the hook to null
+ --
+ -- * Hook_Decl - the declaration of the hook object
+ --
+ -- * Ptr_Decl - the full type declaration of the hook type
+ --
+ -- These nodes are inserted in specific places depending on the context by
+ -- the various Process_Transient_xxx routines.
+
procedure Check_Float_Op_Overflow (N : Node_Id);
-- Called where we could have a floating-point binary operator where we
-- must check for infinities if we are operating in Check_Float_Overflow
Index: einfo.adb
===================================================================
--- einfo.adb (revision 238040)
+++ einfo.adb (working copy)
@@ -561,7 +561,7 @@
-- Has_Predicates Flag250
-- Has_Implicit_Dereference Flag251
- -- Is_Processed_Transient Flag252
+ -- Is_Finalized_Transient Flag252
-- Disable_Controlled Flag253
-- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255
@@ -609,8 +609,8 @@
-- Is_Partial_Invariant_Procedure Flag292
-- Is_Actual_Subtype Flag293
-- Has_Pragma_Unused Flag294
+ -- Is_Ignored_Transient Flag295
- -- (unused) Flag295
-- (unused) Flag296
-- (unused) Flag297
-- (unused) Flag298
@@ -2185,6 +2185,12 @@
return Flag99 (Id);
end Is_Exported;
+ function Is_Finalized_Transient (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ return Flag252 (Id);
+ end Is_Finalized_Transient;
+
function Is_First_Subtype (Id : E) return B is
begin
return Flag70 (Id);
@@ -2250,6 +2256,12 @@
return Flag278 (Id);
end Is_Ignored_Ghost_Entity;
+ function Is_Ignored_Transient (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ return Flag295 (Id);
+ end Is_Ignored_Transient;
+
function Is_Immediately_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -2466,12 +2478,6 @@
return Flag245 (Id);
end Is_Private_Primitive;
- function Is_Processed_Transient (Id : E) return B is
- begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
- return Flag252 (Id);
- end Is_Processed_Transient;
-
function Is_Public (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -5248,6 +5254,12 @@
Set_Flag99 (Id, V);
end Set_Is_Exported;
+ procedure Set_Is_Finalized_Transient (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ Set_Flag252 (Id, V);
+ end Set_Is_Finalized_Transient;
+
procedure Set_Is_First_Subtype (Id : E; V : B := True) is
begin
Set_Flag70 (Id, V);
@@ -5329,6 +5341,12 @@
Set_Flag278 (Id, V);
end Set_Is_Ignored_Ghost_Entity;
+ procedure Set_Is_Ignored_Transient (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ Set_Flag295 (Id, V);
+ end Set_Is_Ignored_Transient;
+
procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -5543,12 +5561,6 @@
Set_Flag245 (Id, V);
end Set_Is_Private_Primitive;
- procedure Set_Is_Processed_Transient (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
- Set_Flag252 (Id, V);
- end Set_Is_Processed_Transient;
-
procedure Set_Is_Public (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -9241,6 +9253,7 @@
W ("Is_Entry_Formal", Flag52 (Id));
W ("Is_Exception_Handler", Flag286 (Id));
W ("Is_Exported", Flag99 (Id));
+ W ("Is_Finalized_Transient", Flag252 (Id));
W ("Is_First_Subtype", Flag70 (Id));
W ("Is_For_Access_Subtype", Flag118 (Id));
W ("Is_Formal_Subprogram", Flag111 (Id));
@@ -9253,6 +9266,7 @@
W ("Is_Hidden_Non_Overridden_Subpgm", Flag2 (Id));
W ("Is_Hidden_Open_Scope", Flag171 (Id));
W ("Is_Ignored_Ghost_Entity", Flag278 (Id));
+ W ("Is_Ignored_Transient", Flag295 (Id));
W ("Is_Immediately_Visible", Flag7 (Id));
W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id));
@@ -9292,7 +9306,6 @@
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Private_Primitive", Flag245 (Id));
- W ("Is_Processed_Transient", Flag252 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Pure_Unit_Access_Type", Flag189 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 238040)
+++ einfo.ads (working copy)
@@ -535,7 +535,7 @@
-- a build-in-place function call. Contains the relocated build-in-place
-- call after the expansion has decoupled the call from the object. This
-- attribute is used by the finalization machinery to insert cleanup code
--- for all additional transient variables found in the transient block.
+-- for all additional transient objects found in the transient block.
-- C_Pass_By_Copy (Flag125) [implementation base type only]
-- Defined in record types. Set if a pragma Convention for the record
@@ -2484,6 +2484,12 @@
-- Applies to all entities, true for abstract states that are subject to
-- option External.
+-- Is_Finalized_Transient (Flag252)
+-- Defined in constants, loop parameters of generalized iterators, and
+-- variables. Set when a transient object has been finalized by one of
+-- the transient finalization mechanisms. The flag prevents the double
+-- finalization of the object.
+
-- Is_Finalizer (synthesized)
-- Applies to all entities, true for procedures containing finalization
-- code to process local or library level objects.
@@ -2595,6 +2601,13 @@
-- pragma Ghost or inherit "ghostness" from an enclosing construct, and
-- subject to Assertion_Policy Ghost => Ignore.
+-- Is_Ignored_Transient (Flag295)
+-- Defined in constants, loop parameters of generalized iterators, and
+-- variables. Set when a transient object must be processed by one of
+-- the transient finalization mechanisms. Once marked, a transient is
+-- intentionally ignored by the general finalization mechanism because
+-- its clean up actions are context specific.
+
-- Is_Immediately_Visible (Flag7)
-- Defined in all entities. Set if entity is immediately visible, i.e.
-- is defined in some currently open scope (RM 8.3(4)).
@@ -2997,13 +3010,6 @@
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes.
--- Is_Processed_Transient (Flag252)
--- Defined in variables, loop parameters, and constants, including the
--- loop parameters of generalized iterators. Set when a transient object
--- needs to be finalized and has already been processed by the transient
--- scope machinery. This flag signals the general finalization mechanism
--- to ignore the transient object.
-
-- Is_Protected_Component (synthesized)
-- Applicable to all entities, true if the entity denotes a private
-- component of a protected type.
@@ -5786,8 +5792,9 @@
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
+ -- Is_Finalized_Transient (Flag252)
+ -- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268)
- -- Is_Processed_Transient (Flag252) (constants only)
-- Is_Return_Object (Flag209)
-- Is_True_Constant (Flag163)
-- Is_Uplevel_Referenced_Entity (Flag283)
@@ -6552,8 +6559,9 @@
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
+ -- Is_Finalized_Transient (Flag252)
+ -- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268)
- -- Is_Processed_Transient (Flag252)
-- Is_Return_Object (Flag209)
-- Is_Safe_To_Reevaluate (Flag249)
-- Is_Shared_Passive (Flag60)
@@ -7062,6 +7070,7 @@
function Is_Entry_Formal (Id : E) return B;
function Is_Exception_Handler (Id : E) return B;
function Is_Exported (Id : E) return B;
+ function Is_Finalized_Transient (Id : E) return B;
function Is_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B;
function Is_Frozen (Id : E) return B;
@@ -7070,6 +7079,7 @@
function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B;
function Is_Hidden_Open_Scope (Id : E) return B;
function Is_Ignored_Ghost_Entity (Id : E) return B;
+ function Is_Ignored_Transient (Id : E) return B;
function Is_Immediately_Visible (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
@@ -7108,7 +7118,6 @@
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Private_Primitive (Id : E) return B;
- function Is_Processed_Transient (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
function Is_Pure_Unit_Access_Type (Id : E) return B;
@@ -7736,6 +7745,7 @@
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
procedure Set_Is_Exception_Handler (Id : E; V : B := True);
procedure Set_Is_Exported (Id : E; V : B := True);
+ procedure Set_Is_Finalized_Transient (Id : E; V : B := True);
procedure Set_Is_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True);
procedure Set_Is_Formal_Subprogram (Id : E; V : B := True);
@@ -7748,6 +7758,7 @@
procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True);
procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True);
procedure Set_Is_Ignored_Ghost_Entity (Id : E; V : B := True);
+ procedure Set_Is_Ignored_Transient (Id : E; V : B := True);
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
@@ -7787,7 +7798,6 @@
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Private_Primitive (Id : E; V : B := True);
- procedure Set_Is_Processed_Transient (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
@@ -8544,6 +8554,7 @@
pragma Inline (Is_Enumeration_Type);
pragma Inline (Is_Exception_Handler);
pragma Inline (Is_Exported);
+ pragma Inline (Is_Finalized_Transient);
pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type);
pragma Inline (Is_Floating_Point_Type);
@@ -8563,6 +8574,7 @@
pragma Inline (Is_Hidden_Non_Overridden_Subpgm);
pragma Inline (Is_Hidden_Open_Scope);
pragma Inline (Is_Ignored_Ghost_Entity);
+ pragma Inline (Is_Ignored_Transient);
pragma Inline (Is_Immediately_Visible);
pragma Inline (Is_Implementation_Defined);
pragma Inline (Is_Imported);
@@ -8612,7 +8624,6 @@
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Primitive);
pragma Inline (Is_Private_Type);
- pragma Inline (Is_Processed_Transient);
pragma Inline (Is_Protected_Type);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
@@ -9039,6 +9050,7 @@
pragma Inline (Set_Is_Entry_Formal);
pragma Inline (Set_Is_Exception_Handler);
pragma Inline (Set_Is_Exported);
+ pragma Inline (Set_Is_Finalized_Transient);
pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype);
pragma Inline (Set_Is_Formal_Subprogram);
@@ -9051,6 +9063,7 @@
pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm);
pragma Inline (Set_Is_Hidden_Open_Scope);
pragma Inline (Set_Is_Ignored_Ghost_Entity);
+ pragma Inline (Set_Is_Ignored_Transient);
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
@@ -9090,7 +9103,6 @@
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Private_Primitive);
- pragma Inline (Set_Is_Processed_Transient);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Pure_Unit_Access_Type);
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 238040)
+++ sem_res.adb (working copy)
@@ -9951,10 +9951,10 @@
begin
-- Ensure all actions associated with the left operand (e.g.
- -- finalization of transient controlled objects) are fully evaluated
- -- locally within an expression with actions. This is particularly
- -- helpful for coverage analysis. However this should not happen in
- -- generics or if Minimize_Expression_With_Actions is set.
+ -- finalization of transient objects) are fully evaluated locally within
+ -- an expression with actions. This is particularly helpful for coverage
+ -- analysis. However this should not happen in generics or if option
+ -- Minimize_Expression_With_Actions is set.
if Expander_Active and not Minimize_Expression_With_Actions then
declare
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 238040)
+++ exp_ch4.adb (working copy)
@@ -226,22 +226,21 @@
procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
-- Inspect and process statement list Stmt of if or case expression N for
- -- transient controlled objects. If such objects are found, the routine
- -- generates code to clean them up when the context of the expression is
- -- evaluated or elaborated.
+ -- transient objects. If such objects are found, the routine generates code
+ -- to clean them up when the context of the expression is evaluated.
- procedure Process_Transient_Object
- (Decl : Node_Id;
- N : Node_Id;
- Stmts : List_Id);
+ procedure Process_Transient_In_Expression
+ (Obj_Decl : Node_Id;
+ Expr : Node_Id;
+ Stmts : List_Id);
-- Subsidiary routine to the expansion of expression_with_actions, if and
-- case expressions. Generate all necessary code to finalize a transient
- -- controlled object when the enclosing context is elaborated or evaluated.
- -- Decl denotes the declaration of the transient controlled object which is
- -- usually the result of a controlled function call. N denotes the related
- -- expression_with_actions, if expression, or case expression node. Stmts
- -- denotes the statement list which contains Decl, either at the top level
- -- or within a nested construct.
+ -- object when the enclosing context is elaborated or evaluated. Obj_Decl
+ -- denotes the declaration of the transient object, which is usually the
+ -- result of a controlled function call. Expr denotes the expression with
+ -- actions, if expression, or case expression node. Stmts denotes the
+ -- statement list which contains Decl, either at the top level or within a
+ -- nested construct.
procedure Rewrite_Comparison (N : Node_Id);
-- If N is the node for a comparison whose outcome can be determined at
@@ -4866,11 +4865,10 @@
Prepend_List (Actions (Alt), Stmts);
end if;
- -- Finalize any transient controlled objects on exit from the
- -- alternative. This is done only in the return optimization case
- -- because otherwise the case expression is converted into an
- -- expression with actions which already contains this form of
- -- processing.
+ -- Finalize any transient objects on exit from the alternative.
+ -- This is done only in the return optimization case because
+ -- otherwise the case expression is converted into an expression
+ -- with actions which already contains this form of processing.
if Optimize_Return_Stmt then
Process_If_Case_Statements (N, Stmts);
@@ -4952,9 +4950,9 @@
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
- -- generates code to clean them up when the context of the expression is
- -- evaluated or elaborated.
+ -- transient objects. If such objects are found, the routine generates
+ -- code to clean them up when the context of the expression is evaluated
+ -- or elaborated.
------------------------------
-- Force_Boolean_Evaluation --
@@ -4997,7 +4995,7 @@
if Nkind (Act) = N_Object_Declaration
and then Is_Finalizable_Transient (Act, N)
then
- Process_Transient_Object (Act, N, Acts);
+ Process_Transient_In_Expression (Act, N, Acts);
return Abandon;
-- Avoid processing temporary function results multiple times when
@@ -5038,8 +5036,8 @@
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:
+ -- temporary. This ensures that aliases of transient objects do not leak
+ -- to the expression of the expression_with_actions node:
-- do
-- Trans_Id : Ctrl_Typ := ...;
@@ -5059,12 +5057,12 @@
-- in Val end;
-- Once this transformation is performed, it is safe to finalize the
- -- transient controlled object at the end of the actions list.
+ -- transient object at the end of the actions list.
-- Note that Force_Evaluation does not remove side effects in operators
-- because it assumes that all operands are evaluated and side effect
-- free. This is not the case when an operand depends implicitly on the
- -- transient controlled object through the use of access types.
+ -- transient object through the use of access types.
elsif Is_Boolean_Type (Etype (Expression (N))) then
Force_Boolean_Evaluation (Expression (N));
@@ -5077,8 +5075,8 @@
Force_Evaluation (Expression (N));
end if;
- -- Process all transient controlled objects found within the actions of
- -- the EWA node.
+ -- Process all transient objects found within the actions of the EWA
+ -- node.
Act := First (Acts);
while Present (Act) loop
@@ -12956,44 +12954,44 @@
if Nkind (Decl) = N_Object_Declaration
and then Is_Finalizable_Transient (Decl, N)
then
- Process_Transient_Object (Decl, N, Stmts);
+ Process_Transient_In_Expression (Decl, N, Stmts);
end if;
Next (Decl);
end loop;
end Process_If_Case_Statements;
- ------------------------------
- -- Process_Transient_Object --
- ------------------------------
+ -------------------------------------
+ -- Process_Transient_In_Expression --
+ -------------------------------------
- procedure Process_Transient_Object
- (Decl : Node_Id;
- N : Node_Id;
- Stmts : List_Id)
+ procedure Process_Transient_In_Expression
+ (Obj_Decl : Node_Id;
+ Expr : Node_Id;
+ Stmts : List_Id)
is
- Loc : constant Source_Ptr := Sloc (Decl);
- Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
- Obj_Typ : constant Node_Id := Etype (Obj_Id);
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
- 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 (N);
+ Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
-- The node on which to insert the hook as an action. This is usually
-- the innermost enclosing non-transient construct.
+ Fin_Call : Node_Id;
+ Hook_Assign : Node_Id;
+ Hook_Clear : Node_Id;
+ Hook_Decl : Node_Id;
+ Hook_Insert : Node_Id;
+ Ptr_Decl : Node_Id;
+
Fin_Context : Node_Id;
-- The node after which to insert the finalization actions of the
- -- transient controlled object.
+ -- transient object.
begin
- pragma Assert (Nkind_In (N, N_Case_Expression,
- N_Expression_With_Actions,
- N_If_Expression));
+ pragma Assert (Nkind_In (Expr, N_Case_Expression,
+ N_Expression_With_Actions,
+ N_If_Expression));
-- When the context is a Boolean evaluation, all three nodes capture the
-- result of their computation in a local temporary:
@@ -13004,102 +13002,63 @@
-- <finalize Trans_Id>
-- in Result end;
- -- As a result, the finalization of any transient controlled objects can
- -- safely take place after the result capture.
+ -- As a result, the finalization of any transient objects can safely
+ -- take place after the result capture.
-- ??? could this be extended to elementary types?
- if Is_Boolean_Type (Etype (N)) then
+ if Is_Boolean_Type (Etype (Expr)) then
Fin_Context := Last (Stmts);
- -- Otherwise the immediate context may not be safe enough to carry out
- -- transient controlled object finalization due to aliasing and nesting
- -- of constructs. Insert calls to [Deep_]Finalize after the innermost
+ -- Otherwise the immediate context may not be safe enough to carry
+ -- out transient object finalization due to aliasing and nesting of
+ -- constructs. Insert calls to [Deep_]Finalize after the innermost
-- enclosing non-transient construct.
else
Fin_Context := Hook_Context;
end if;
- -- Step 1: Create the access type which provides a reference to the
- -- transient controlled object.
+ -- Mark the transient object as successfully processed to avoid double
+ -- finalization.
- if Is_Access_Type (Obj_Typ) then
- Desig_Typ := Directly_Designated_Type (Obj_Typ);
- else
- Desig_Typ := Obj_Typ;
- end if;
+ Set_Is_Finalized_Transient (Obj_Id);
- Desig_Typ := Base_Type (Desig_Typ);
+ -- Construct all the pieces necessary to hook and finalize a transient
+ -- object.
- -- Generate:
- -- Ann : access [all] <Desig_Typ>;
+ Build_Transient_Object_Statements
+ (Obj_Decl => Obj_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl,
+ Finalize_Obj => False);
- Ptr_Id := Make_Temporary (Loc, 'A');
+ -- Add the access type which provides a reference to the transient
+ -- object. Generate:
- Insert_Action (Hook_Context,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Id,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))));
+ -- type Ptr_Typ is access all Desig_Typ;
- -- Step 2: Create a temporary which acts as a hook to the transient
- -- controlled object. Generate:
+ Insert_Action (Hook_Context, Ptr_Decl);
+ -- Add the temporary which acts as a hook to the transient object.
+ -- Generate:
+
-- Hook : Ptr_Id := null;
- Hook_Id := Make_Temporary (Loc, 'T');
+ Insert_Action (Hook_Context, Hook_Decl);
- Insert_Action (Hook_Context,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Hook_Id,
- Object_Definition => New_Occurrence_Of (Ptr_Id, Loc)));
+ -- When the transient object is initialized by an aggregate, the hook
+ -- must capture the object after the last aggregate assignment takes
+ -- place. Only then is the object considered initialized. Generate:
- -- 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 (Hook_Id, Decl);
-
- -- 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
- -- created (whereas the declaration of the hook pointer, and the
- -- finalization call, may be inserted at an outer level, and may
- -- remain unused for some executions, if the actual creation of
- -- the object is conditional).
-
- -- The use of unchecked conversion / unrestricted access is needed to
- -- avoid an accessibility violation. Note that the finalization code is
- -- structured in such a way that the "hook" is processed only when it
- -- points to an existing object.
-
- if Is_Access_Type (Obj_Typ) then
- Expr :=
- Unchecked_Convert_To
- (Typ => Ptr_Id,
- Expr => New_Occurrence_Of (Obj_Id, Loc));
- else
- Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
-
- -- Generate:
- -- Hook := Ptr_Id (Obj_Id);
+ -- Hook := Ptr_Typ (Obj_Id);
-- <or>
-- 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
- -- place. Only then is the object fully initialized.
-
- if Ekind (Obj_Id) = E_Variable
+ if Ekind_In (Obj_Id, E_Constant, E_Variable)
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
@@ -13107,54 +13066,42 @@
-- Otherwise the hook seizes the related object immediately
else
- Hook_Insert := Decl;
+ Hook_Insert := Obj_Decl;
end if;
- Insert_After_And_Analyze (Hook_Insert,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Expr));
+ Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
- -- Step 4: Finalize the hook after the context has been evaluated or
- -- elaborated. Generate:
-
- -- 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 a finalization call, as the general finalization mechanism
- -- (see Build_Finalizer) would take care of the transient controlled
- -- object on subprogram exit. Note that it would also be impossible to
- -- insert the finalization code after the return statement as this will
- -- render it unreachable.
+ -- (see Build_Finalizer) would take care of the transient object on
+ -- subprogram exit. Note that it would also be impossible to insert the
+ -- finalization code after the return statement as this will render it
+ -- unreachable.
if Nkind (Fin_Context) = N_Simple_Return_Statement then
null;
- -- Otherwise finalize the hook
+ -- Finalize the hook after the context has been evaluated. Generate:
+ -- if Hook /= null then
+ -- [Deep_]Finalize (Hook.all);
+ -- Hook := null;
+ -- end if;
+
else
Insert_Action_After (Fin_Context,
- Make_Implicit_If_Statement (Decl,
+ Make_Implicit_If_Statement (Obj_Decl,
Condition =>
Make_Op_Ne (Loc,
- Left_Opnd => New_Occurrence_Of (Hook_Id, Loc),
+ Left_Opnd =>
+ New_Occurrence_Of (Defining_Entity (Hook_Decl), 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),
-
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Make_Null (Loc)))));
+ Fin_Call,
+ Hook_Clear)));
end if;
- end Process_Transient_Object;
+ end Process_Transient_In_Expression;
------------------------
-- Rewrite_Comparison --
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 238040)
+++ exp_ch6.adb (working copy)
@@ -4115,10 +4115,6 @@
and then Present (Generalized_Indexing (Ref));
end Is_Element_Reference;
- -- Local variables
-
- Is_Elem_Ref : constant Boolean := Is_Element_Reference (N);
-
-- Start of processing for Expand_Ctrl_Function_Call
begin
@@ -4142,20 +4138,24 @@
Remove_Side_Effects (N);
- -- When the temporary function result appears inside a case expression
- -- or an if expression, its lifetime must be extended to match that of
- -- the context. If not, the function result will be finalized too early
- -- and the evaluation of the expression could yield incorrect result. An
- -- exception to this rule are references to Ada 2012 container elements.
+ -- The side effect removal of the function call produced a temporary.
+ -- When the context is a case expression, if expression, or expression
+ -- with actions, the lifetime of the temporary must be extended to match
+ -- that of the context. Otherwise the function result will be finalized
+ -- too early and affect the result of the expression. To prevent this
+ -- unwanted effect, the temporary should not be considered for clean up
+ -- actions by the general finalization machinery.
+
+ -- Exception to this rule are references to Ada 2012 container elements.
-- Such references must be finalized at the end of each iteration of the
-- related quantified expression, otherwise the container will remain
-- busy.
- if not Is_Elem_Ref
+ if Nkind (N) = N_Explicit_Dereference
and then Within_Case_Or_If_Expression (N)
- and then Nkind (N) = N_Explicit_Dereference
+ and then not Is_Element_Reference (N)
then
- Set_Is_Processed_Transient (Entity (Prefix (N)));
+ Set_Is_Ignored_Transient (Entity (Prefix (N)));
end if;
end Expand_Ctrl_Function_Call;
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 238040)
+++ exp_aggr.adb (working copy)
@@ -35,10 +35,12 @@
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
+with Exp_Ch11; use Exp_Ch11;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Fname; use Fname;
with Freeze; use Freeze;
+with Inline; use Inline;
with Itypes; use Itypes;
with Lib; use Lib;
with Namet; use Namet;
@@ -95,6 +97,25 @@
-- Returns true if N is an aggregate used to initialize the components
-- of a statically allocated dispatch table.
+ function Late_Expansion
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Target : Node_Id) return List_Id;
+ -- This routine implements top-down expansion of nested aggregates. In
+ -- doing so, it avoids the generation of temporaries at each level. N is
+ -- a nested record or array aggregate with the Expansion_Delayed flag.
+ -- Typ is the expected type of the aggregate. Target is a (duplicatable)
+ -- expression that will hold the result of the aggregate expansion.
+
+ function Make_OK_Assignment_Statement
+ (Sloc : Source_Ptr;
+ Name : Node_Id;
+ Expression : Node_Id) return Node_Id;
+ -- This is like Make_Assignment_Statement, except that Assignment_OK
+ -- is set in the left operand. All assignments built by this unit use
+ -- this routine. This is needed to deal with assignments to initialized
+ -- constants that are done in place.
+
function Must_Slide
(Obj_Type : Entity_Id;
Typ : Entity_Id) return Boolean;
@@ -109,6 +130,41 @@
-- when a component may be given with bounds that differ from those of the
-- component type.
+ function Number_Of_Choices (N : Node_Id) return Nat;
+ -- Returns the number of discrete choices (not including the others choice
+ -- if present) contained in (sub-)aggregate N.
+
+ procedure Process_Transient_Component
+ (Loc : Source_Ptr;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Aggr : Node_Id := Empty;
+ Stmts : List_Id := No_List);
+ -- Subsidiary to the expansion of array and record aggregates. Generate
+ -- part of the necessary code to finalize a transient component. Comp_Typ
+ -- is the component type. Init_Expr is the initialization expression of the
+ -- component which is always a function call. Fin_Call is the finalization
+ -- call used to clean up the transient function result. Hook_Clear is the
+ -- hook reset statement. Aggr and Stmts both control the placement of the
+ -- generated code. Aggr is the related aggregate. If present, all code is
+ -- inserted prior to Aggr using Insert_Action. Stmts is the initialization
+ -- statements of the component. If present, all code is added to Stmts.
+
+ procedure Process_Transient_Component_Completion
+ (Loc : Source_Ptr;
+ Aggr : Node_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+ Stmts : List_Id);
+ -- Subsidiary to the expansion of array and record aggregates. Generate
+ -- part of the necessary code to finalize a transient component. Aggr is
+ -- the related aggregate. Fin_Clear is the finalization call used to clean
+ -- up the transient component. Hook_Clear is the hook reset statment. Stmts
+ -- is the initialization statement list for the component. All generated
+ -- code is added to Stmts.
+
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
-- Sort the Case Table using the Lower Bound of each Choice as the key.
-- A simple insertion sort is used since the number of choices in a case
@@ -260,29 +316,6 @@
-- an array that is suitable for this optimization: it returns True if Typ
-- is a two dimensional bit packed array with component size 1, 2, or 4.
- function Late_Expansion
- (N : Node_Id;
- Typ : Entity_Id;
- Target : Node_Id) return List_Id;
- -- This routine implements top-down expansion of nested aggregates. In
- -- doing so, it avoids the generation of temporaries at each level. N is
- -- a nested record or array aggregate with the Expansion_Delayed flag.
- -- Typ is the expected type of the aggregate. Target is a (duplicatable)
- -- expression that will hold the result of the aggregate expansion.
-
- function Make_OK_Assignment_Statement
- (Sloc : Source_Ptr;
- Name : Node_Id;
- Expression : Node_Id) return Node_Id;
- -- This is like Make_Assignment_Statement, except that Assignment_OK
- -- is set in the left operand. All assignments built by this unit use
- -- this routine. This is needed to deal with assignments to initialized
- -- constants that are done in place.
-
- function Number_Of_Choices (N : Node_Id) return Nat;
- -- Returns the number of discrete choices (not including the others choice
- -- if present) contained in (sub-)aggregate N.
-
function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
-- Given an array aggregate, this function handles the case of a packed
-- array aggregate with all constant values, where the aggregate can be
@@ -794,14 +827,18 @@
function Index_Base_Name return Node_Id;
-- Returns a new reference to the index type name
- function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
+ function Gen_Assign
+ (Ind : Node_Id;
+ Expr : Node_Id;
+ In_Loop : Boolean := False) return List_Id;
-- Ind must be a side-effect-free expression. If the input aggregate N
-- to Build_Loop contains no subaggregates, then this function returns
-- the assignment statement:
--
-- Into (Indexes, Ind) := Expr;
--
- -- Otherwise we call Build_Code recursively
+ -- Otherwise we call Build_Code recursively. Flag In_Loop should be set
+ -- when the assignment appears within a generated loop.
--
-- Ada 2005 (AI-287): In case of default initialized component, Expr
-- is empty and we generate a call to the corresponding IP subprogram.
@@ -815,9 +852,9 @@
-- Into (Indexes, J) := Expr;
-- end loop;
--
- -- Otherwise we call Build_Code recursively.
- -- As an optimization if the loop covers 3 or fewer scalar elements we
- -- generate a sequence of assignments.
+ -- Otherwise we call Build_Code recursively. As an optimization if the
+ -- loop covers 3 or fewer scalar elements we generate a sequence of
+ -- assignments.
function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
-- Nodes L and H must be side-effect-free expressions. If the input
@@ -1016,21 +1053,37 @@
-- Gen_Assign --
----------------
- function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
+ function Gen_Assign
+ (Ind : Node_Id;
+ Expr : Node_Id;
+ In_Loop : Boolean := False) return List_Id
+ is
function Add_Loop_Actions (Lis : List_Id) return List_Id;
- -- Collect insert_actions generated in the construction of a
- -- loop, and prepend them to the sequence of assignments to
- -- complete the eventual body of the loop.
+ -- Collect insert_actions generated in the construction of a loop,
+ -- and prepend them to the sequence of assignments to complete the
+ -- eventual body of the loop.
- function Ctrl_Init_Expression
- (Comp_Typ : Entity_Id;
- Stmts : List_Id) return Node_Id;
- -- Perform in-place side effect removal if expression Expr denotes a
- -- controlled function call. Return a reference to the entity which
- -- captures the result of the call. Comp_Typ is the expected type of
- -- the component. Stmts is the list of initialization statmenets. Any
- -- generated code is added to Stmts.
+ procedure Initialize_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Node_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of array component Arr_Comp with
+ -- expected type Comp_Typ. Init_Expr denotes the initialization
+ -- expression of the array component. All generated code is added
+ -- to list Stmts.
+ procedure Initialize_Ctrl_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of array component Arr_Comp when its
+ -- expected type Comp_Typ needs finalization actions. Init_Expr is
+ -- the initialization expression of the array component. All hook-
+ -- related declarations are inserted prior to aggregate N. Remaining
+ -- code is added to list Stmts.
+
----------------------
-- Add_Loop_Actions --
----------------------
@@ -1058,79 +1111,208 @@
end if;
end Add_Loop_Actions;
- --------------------------
- -- Ctrl_Init_Expression --
- --------------------------
+ --------------------------------
+ -- Initialize_Array_Component --
+ --------------------------------
- function Ctrl_Init_Expression
- (Comp_Typ : Entity_Id;
- Stmts : List_Id) return Node_Id
+ procedure Initialize_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Node_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
is
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Init_Stmt : Node_Id;
+
+ begin
+ -- Initialize the array element. Generate:
+
+ -- Arr_Comp := Init_Expr;
+
+ -- Note that the initialization expression is replicated because
+ -- it has to be reevaluated within a generated loop.
+
+ Init_Stmt :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Arr_Comp),
+ Expression => New_Copy_Tree (Init_Expr));
+ Set_No_Ctrl_Actions (Init_Stmt);
+
+ -- If this is an aggregate for an array of arrays, each
+ -- subaggregate will be expanded as well, and even with
+ -- No_Ctrl_Actions the assignments of inner components will
+ -- require attachment in their assignments to temporaries. These
+ -- temporaries must be finalized for each subaggregate. Generate:
+
+ -- begin
+ -- Arr_Comp := Init_Expr;
+ -- end;
+
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then Is_Array_Type (Comp_Typ)
+ then
+ Init_Stmt :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Init_Stmt)));
+ end if;
+
+ Append_To (Stmts, Init_Stmt);
+
+ -- Adjust the tag due to a possible view conversion. Generate:
+
+ -- Arr_Comp._tag := Full_TypP;
+
+ if Tagged_Type_Expansion
+ and then Present (Comp_Typ)
+ and then Is_Tagged_Type (Comp_Typ)
+ then
+ Append_To (Stmts,
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Arr_Comp),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Full_Typ), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
+ Loc))));
+ end if;
+
+ -- Adjust the array component. Controlled subaggregates are not
+ -- considered because each of their individual elements will
+ -- receive an adjustment of its own. Generate:
+
+ -- [Deep_]Adjust (Arr_Comp);
+
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then not Is_Limited_Type (Comp_Typ)
+ and then not
+ (Is_Array_Type (Comp_Typ)
+ and then Is_Controlled (Component_Type (Comp_Typ))
+ and then Nkind (Expr) = N_Aggregate)
+ then
+ Append_To (Stmts,
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Arr_Comp),
+ Typ => Comp_Typ));
+ end if;
+ end Initialize_Array_Component;
+
+ -------------------------------------
+ -- Initialize_Ctrl_Array_Component --
+ -------------------------------------
+
+ procedure Initialize_Ctrl_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
Init_Expr : Node_Id;
- Obj_Id : Entity_Id;
- Ptr_Typ : Entity_Id;
+ Stmts : List_Id)
+ is
+ Act_Aggr : Node_Id;
+ Act_Stmts : List_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+ In_Place_Expansion : Boolean;
+ -- Flag set when a nonlimited controlled function call requires
+ -- in-place expansion.
+
begin
- Init_Expr := New_Copy_Tree (Expr);
+ -- Perform a preliminary analysis and resolution to determine what
+ -- the initialization expression denotes. An unanalyzed function
+ -- call may appear as an identifier or an indexed component.
- -- Perform a preliminary analysis and resolution to determine
- -- what the expression denotes. Note that a function call may
- -- appear as an identifier or an indexed component.
+ if Nkind_In (Init_Expr, N_Function_Call,
+ N_Identifier,
+ N_Indexed_Component)
+ and then not Analyzed (Init_Expr)
+ then
+ Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
+ end if;
- Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
+ In_Place_Expansion :=
+ Nkind (Init_Expr) = N_Function_Call
+ and then not Is_Limited_Type (Comp_Typ);
-- The initialization expression is a controlled function call.
-- Perform in-place removal of side effects to avoid creating a
- -- transient scope. In the end the temporary function result is
- -- finalized by the general finalization machinery.
+ -- transient scope, which leads to premature finalization.
- if Nkind (Init_Expr) = N_Function_Call then
+ -- This in-place expansion is not performed for limited transient
+ -- objects because the initialization is already done in-place.
- -- Suppress the removal of side effects by generatal analysis
- -- because this behavior is emulated here.
+ if In_Place_Expansion then
+ -- Suppress the removal of side effects by general analysis
+ -- because this behavior is emulated here. This avoids the
+ -- generation of a transient scope, which leads to out-of-order
+ -- adjustment and finalization.
+
Set_No_Side_Effect_Removal (Init_Expr);
- -- Generate:
- -- type Ptr_Typ is access all Comp_Typ;
+ -- When the transient component initialization is related to a
+ -- range or an "others", keep all generated statements within
+ -- the enclosing loop. This way the controlled function call
+ -- will be evaluated at each iteration, and its result will be
+ -- finalized at the end of each iteration.
- Ptr_Typ := Make_Temporary (Loc, 'A');
+ if In_Loop then
+ Act_Aggr := Empty;
+ Act_Stmts := Stmts;
- Append_To (Stmts,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Comp_Typ, Loc))));
+ -- Otherwise this is a single component initialization. Hook-
+ -- related statements are inserted prior to the aggregate.
- -- Generate:
- -- Obj : constant Ptr_Typ := Init_Expr'Reference;
+ else
+ Act_Aggr := N;
+ Act_Stmts := No_List;
+ end if;
- Obj_Id := Make_Temporary (Loc, 'R');
+ -- Install all hook-related declarations and prepare the clean
+ -- up statements.
- Append_To (Stmts,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Obj_Id,
- Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
- Expression => Make_Reference (Loc, Init_Expr)));
+ Process_Transient_Component
+ (Loc => Loc,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Aggr => Act_Aggr,
+ Stmts => Act_Stmts);
+ end if;
- -- Generate:
- -- Obj.all;
+ -- Use the noncontrolled component initialization circuitry to
+ -- assign the result of the function call to the array element.
+ -- This also performs subaggregate wrapping, tag adjustment, and
+ -- [deep] adjustment of the array element.
- return
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc));
+ Initialize_Array_Component
+ (Arr_Comp => Arr_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Stmts => Stmts);
- -- Otherwise the initialization expression denotes a controlled
- -- object. There is nothing special to be done here as there is
- -- no possible transient scope involvement.
+ -- At this point the array element is fully initialized. Complete
+ -- the processing of the controlled array component by finalizing
+ -- the transient function result.
- else
- return Init_Expr;
+ if In_Place_Expansion then
+ Process_Transient_Component_Completion
+ (Loc => Loc,
+ Aggr => N,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
end if;
- end Ctrl_Init_Expression;
+ end Initialize_Ctrl_Array_Component;
-- Local variables
@@ -1140,8 +1322,6 @@
Expr_Q : Node_Id;
Indexed_Comp : Node_Id;
New_Indexes : List_Id;
- Stmt : Node_Id;
- Stmt_Expr : Node_Id;
-- Start of processing for Gen_Assign
@@ -1253,7 +1433,7 @@
-- component associations that provide different bounds from
-- those of the component type, and sliding must occur. Instead
-- of decomposing the current aggregate assignment, force the
- -- re-analysis of the assignment, so that a temporary will be
+ -- reanalysis of the assignment, so that a temporary will be
-- generated in the usual fashion, and sliding will take place.
if Nkind (Parent (N)) = N_Assignment_Statement
@@ -1272,6 +1452,59 @@
end if;
end if;
+ if Present (Expr) then
+
+ -- Handle an initialization expression of a controlled type in
+ -- case it denotes a function call. In general such a scenario
+ -- will produce a transient scope, but this will lead to wrong
+ -- order of initialization, adjustment, and finalization in the
+ -- context of aggregates.
+
+ -- Target (1) := Ctrl_Func_Call;
+
+ -- begin -- scope
+ -- Trans_Obj : ... := Ctrl_Func_Call; -- object
+ -- Target (1) := Trans_Obj;
+ -- Finalize (Trans_Obj);
+ -- end;
+ -- Target (1)._tag := ...;
+ -- Adjust (Target (1));
+
+ -- In the example above, the call to Finalize occurs too early
+ -- and as a result it may leave the array component in a bad
+ -- state. Finalization of the transient object should really
+ -- happen after adjustment.
+
+ -- To avoid this scenario, perform in-place side-effect removal
+ -- of the function call. This eliminates the transient property
+ -- of the function result and ensures correct order of actions.
+
+ -- Res : ... := Ctrl_Func_Call;
+ -- Target (1) := Res;
+ -- Target (1)._tag := ...;
+ -- Adjust (Target (1));
+ -- Finalize (Res);
+
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then Nkind (Expr) /= N_Aggregate
+ then
+ Initialize_Ctrl_Array_Component
+ (Arr_Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+
+ -- Otherwise perform simple component initialization
+
+ else
+ Initialize_Array_Component
+ (Arr_Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+ end if;
+
-- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
-- If the component type is an access type, add an explicit null
@@ -1283,7 +1516,7 @@
-- its Initialize procedure explicitly, because there is no explicit
-- object creation that will invoke it otherwise.
- if No (Expr) then
+ else
if Present (Base_Init_Proc (Base_Type (Ctype)))
or else Has_Task (Base_Type (Ctype))
then
@@ -1316,154 +1549,6 @@
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
Typ => Ctype));
end if;
-
- else
- -- Handle an initialization expression of a controlled type in
- -- case it denotes a function call. In general such a scenario
- -- will produce a transient scope, but this will lead to wrong
- -- order of initialization, adjustment, and finalization in the
- -- context of aggregates.
-
- -- Arr_Comp (1) := Ctrl_Func_Call;
-
- -- begin -- transient scope
- -- Trans_Obj : ... := Ctrl_Func_Call; -- transient object
- -- Arr_Comp (1) := Trans_Obj;
- -- Finalize (Trans_Obj);
- -- end;
- -- Arr_Comp (1)._tag := ...;
- -- Adjust (Arr_Comp (1));
-
- -- In the example above, the call to Finalize occurs too early
- -- and as a result it may leave the array component in a bad
- -- state. Finalization of the transient object should really
- -- happen after adjustment.
-
- -- To avoid this scenario, perform in-place side effect removal
- -- of the function call. This eliminates the transient property
- -- of the function result and ensures correct order of actions.
- -- Note that the function result behaves as a source controlled
- -- object and is finalized by the general finalization mechanism.
-
- -- begin
- -- Res : ... := Ctrl_Func_Call;
- -- Arr_Comp (1) := Res;
- -- Arr_Comp (1)._tag := ...;
- -- Adjust (Arr_Comp (1));
- -- at end
- -- Finalize (Res);
- -- end;
-
- -- There is no need to perform this kind of light expansion when
- -- the component type is limited controlled because everything is
- -- already done in place.
-
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
- and then not Is_Limited_Type (Comp_Typ)
- and then Nkind (Expr) /= N_Aggregate
- then
- Stmt_Expr := Ctrl_Init_Expression (Comp_Typ, Stmts);
-
- -- Otherwise use the initialization expression directly
-
- else
- Stmt_Expr := New_Copy_Tree (Expr);
- end if;
-
- Stmt :=
- Make_OK_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Indexed_Comp),
- Expression => Stmt_Expr);
-
- -- The target of the assignment may not have been initialized,
- -- so it is not possible to call Finalize as expected in normal
- -- controlled assignments. We must also avoid using the primitive
- -- _assign (which depends on a valid target, and may for example
- -- perform discriminant checks on it).
-
- -- Both Finalize and usage of _assign are disabled by setting
- -- No_Ctrl_Actions on the assignment. The rest of the controlled
- -- actions are done manually with the proper finalization list
- -- coming from the context.
-
- Set_No_Ctrl_Actions (Stmt);
-
- -- If this is an aggregate for an array of arrays, each
- -- subaggregate will be expanded as well, and even with
- -- No_Ctrl_Actions the assignments of inner components will
- -- require attachment in their assignments to temporaries. These
- -- temporaries must be finalized for each subaggregate, to prevent
- -- multiple attachments of the same temporary location to same
- -- finalization chain (and consequently circular lists). To ensure
- -- that finalization takes place for each subaggregate we wrap the
- -- assignment in a block.
-
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
- and then Is_Array_Type (Comp_Typ)
- and then Present (Expr)
- then
- Stmt :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Stmt)));
- end if;
-
- Append_To (Stmts, Stmt);
-
- -- Adjust the tag due to a possible view conversion
-
- if Present (Comp_Typ)
- and then Is_Tagged_Type (Comp_Typ)
- and then Tagged_Type_Expansion
- then
- declare
- Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
-
- begin
- Append_To (Stmts,
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Indexed_Comp),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Full_Typ), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
- Loc))));
- end;
- end if;
-
- -- Adjust and attach the component to the proper final list, which
- -- can be the controller of the outer record object or the final
- -- list associated with the scope.
-
- -- If the component is itself an array of controlled types, whose
- -- value is given by a subaggregate, then the attach calls have
- -- been generated when individual subcomponent are assigned, and
- -- must not be done again to prevent malformed finalization chains
- -- (see comments above, concerning the creation of a block to hold
- -- inner finalization actions).
-
- if Present (Comp_Typ)
- and then Needs_Finalization (Comp_Typ)
- and then not Is_Limited_Type (Comp_Typ)
- and then not
- (Is_Array_Type (Comp_Typ)
- and then Is_Controlled (Component_Type (Comp_Typ))
- and then Nkind (Expr) = N_Aggregate)
- then
- Append_To (Stmts,
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Comp_Typ));
- end if;
end if;
return Add_Loop_Actions (Stmts);
@@ -1545,7 +1630,6 @@
and then Local_Compile_Time_Known_Value (H)
and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
then
-
Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
@@ -1600,7 +1684,8 @@
-- Construct the statements to execute in the loop body
- L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr);
+ L_Body :=
+ Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True);
-- Construct the final loop
@@ -1707,8 +1792,9 @@
Expression => W_Index_Succ);
Append_To (W_Body, W_Increment);
+
Append_List_To (W_Body,
- Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr));
+ Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True));
-- Construct the final loop
@@ -1784,15 +1870,10 @@
end if;
end Local_Expr_Value;
- -- Build_Array_Aggr_Code Variables
+ -- Local variables
- Assoc : Node_Id;
- Choice : Node_Id;
- Expr : Node_Id;
- Typ : Entity_Id;
+ New_Code : constant List_Id := New_List;
- Others_Assoc : Node_Id := Empty;
-
Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
-- The aggregate bounds of this specific subaggregate. Note that if the
@@ -1803,8 +1884,12 @@
Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
-- After Duplicate_Subexpr these are side-effect free
- Low : Node_Id;
- High : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Expr : Node_Id;
+ High : Node_Id;
+ Low : Node_Id;
+ Typ : Entity_Id;
Nb_Choices : Nat := 0;
Table : Case_Table_Type (1 .. Number_Of_Choices (N));
@@ -1813,7 +1898,7 @@
Nb_Elements : Int;
-- Number of elements in the positional aggregate
- New_Code : constant List_Id := New_List;
+ Others_Assoc : Node_Id := Empty;
-- Start of processing for Build_Array_Aggr_Code
@@ -2076,10 +2161,39 @@
-- The type of the aggregate is a subtype created ealier using the
-- given values of the discriminant components of the aggregate.
+ procedure Initialize_Ctrl_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of controlled record component Rec_Comp.
+ -- Comp_Typ is the component type. Init_Expr is the initialization
+ -- expression for the record component. Hook-related declarations are
+ -- inserted prior to aggregate N using Insert_Action. All remaining
+ -- generated code is added to list Stmts.
+
+ procedure Initialize_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of record component Rec_Comp. Comp_Typ
+ -- is the component type. Init_Expr is the initialization expression
+ -- of the record component. All generated code is added to list Stmts.
+
function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
-- Check whether Bounds is a range node and its lower and higher bounds
-- are integers literals.
+ function Replace_Type (Expr : Node_Id) return Traverse_Result;
+ -- If the aggregate contains a self-reference, traverse each expression
+ -- to replace a possible self-reference with a reference to the proper
+ -- component of the target of the assignment.
+
+ function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
+ -- If default expression of a component mentions a discriminant of the
+ -- type, it must be rewritten as the discriminant of the target object.
+
---------------------------------
-- Ancestor_Discriminant_Value --
---------------------------------
@@ -2259,6 +2373,39 @@
return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi;
end Compatible_Int_Bounds;
+ -----------------------------------
+ -- Generate_Finalization_Actions --
+ -----------------------------------
+
+ procedure Generate_Finalization_Actions is
+ begin
+ -- Do the work only the first time this is called
+
+ if Finalization_Done then
+ return;
+ end if;
+
+ Finalization_Done := True;
+
+ -- Determine the external finalization list. It is either the
+ -- finalization list of the outer scope or the one coming from an
+ -- outer aggregate. When the target is not a temporary, the proper
+ -- scope is the scope of the target rather than the potentially
+ -- transient current scope.
+
+ if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then
+ Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
+ Set_Assignment_OK (Ref);
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
+ Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+ end if;
+ end Generate_Finalization_Actions;
+
--------------------------------
-- Get_Constraint_Association --
--------------------------------
@@ -2528,81 +2675,168 @@
end loop;
end Init_Stored_Discriminants;
- -------------------------
- -- Is_Int_Range_Bounds --
- -------------------------
+ --------------------------------------
+ -- Initialize_Ctrl_Record_Component --
+ --------------------------------------
- function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
- begin
- return Nkind (Bounds) = N_Range
- and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
- and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
- end Is_Int_Range_Bounds;
+ procedure Initialize_Ctrl_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
- -----------------------------------
- -- Generate_Finalization_Actions --
- -----------------------------------
+ In_Place_Expansion : Boolean;
+ -- Flag set when a nonlimited controlled function call requires
+ -- in-place expansion.
- procedure Generate_Finalization_Actions is
begin
- -- Do the work only the first time this is called
+ -- Perform a preliminary analysis and resolution to determine what
+ -- the initialization expression denotes. Unanalyzed function calls
+ -- may appear as identifiers or indexed components.
- if Finalization_Done then
- return;
+ if Nkind_In (Init_Expr, N_Function_Call,
+ N_Identifier,
+ N_Indexed_Component)
+ and then not Analyzed (Init_Expr)
+ then
+ Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
end if;
- Finalization_Done := True;
+ In_Place_Expansion :=
+ Nkind (Init_Expr) = N_Function_Call
+ and then not Is_Limited_Type (Comp_Typ);
- -- Determine the external finalization list. It is either the
- -- finalization list of the outer-scope or the one coming from an
- -- outer aggregate. When the target is not a temporary, the proper
- -- scope is the scope of the target rather than the potentially
- -- transient current scope.
+ -- The initialization expression is a controlled function call.
+ -- Perform in-place removal of side effects to avoid creating a
+ -- transient scope.
- if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then
- Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
- Set_Assignment_OK (Ref);
+ -- This in-place expansion is not performed for limited transient
+ -- objects because the initialization is already done in place.
- Append_To (L,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
- Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+ if In_Place_Expansion then
+
+ -- Suppress the removal of side effects by general analysis
+ -- because this behavior is emulated here. This avoids the
+ -- generation of a transient scope, which leads to out-of-order
+ -- adjustment and finalization.
+
+ Set_No_Side_Effect_Removal (Init_Expr);
+
+ -- Install all hook-related declarations and prepare the clean up
+ -- statements.
+
+ Process_Transient_Component
+ (Loc => Loc,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Aggr => N);
end if;
- end Generate_Finalization_Actions;
- function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
- -- If default expression of a component mentions a discriminant of the
- -- type, it must be rewritten as the discriminant of the target object.
+ -- Use the noncontrolled component initialization circuitry to
+ -- assign the result of the function call to the record component.
+ -- This also performs tag adjustment and [deep] adjustment of the
+ -- record component.
- function Replace_Type (Expr : Node_Id) return Traverse_Result;
- -- If the aggregate contains a self-reference, traverse each expression
- -- to replace a possible self-reference with a reference to the proper
- -- component of the target of the assignment.
+ Initialize_Record_Component
+ (Rec_Comp => Rec_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Stmts => Stmts);
- --------------------------
- -- Rewrite_Discriminant --
- --------------------------
+ -- At this point the record component is fully initialized. Complete
+ -- the processing of the controlled record component by finalizing
+ -- the transient function result.
- function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
+ if In_Place_Expansion then
+ Process_Transient_Component_Completion
+ (Loc => Loc,
+ Aggr => N,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
+ end if;
+ end Initialize_Ctrl_Record_Component;
+
+ ---------------------------------
+ -- Initialize_Record_Component --
+ ---------------------------------
+
+ procedure Initialize_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Init_Stmt : Node_Id;
+
begin
- if Is_Entity_Name (Expr)
- and then Present (Entity (Expr))
- and then Ekind (Entity (Expr)) = E_In_Parameter
- and then Present (Discriminal_Link (Entity (Expr)))
- and then Scope (Discriminal_Link (Entity (Expr))) =
- Base_Type (Etype (N))
+ -- Initialize the record component. Generate:
+
+ -- Rec_Comp := Init_Expr;
+
+ -- Note that the initialization expression is NOT replicated because
+ -- only a single component may be initialized by it.
+
+ Init_Stmt :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Rec_Comp),
+ Expression => Init_Expr);
+ Set_No_Ctrl_Actions (Init_Stmt);
+
+ Append_To (Stmts, Init_Stmt);
+
+ -- Adjust the tag due to a possible view conversion. Generate:
+
+ -- Rec_Comp._tag := Full_TypeP;
+
+ if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
+ Append_To (Stmts,
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Rec_Comp),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Full_Typ), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
+ Loc))));
+ end if;
+
+ -- Adjust the component. Generate:
+
+ -- [Deep_]Adjust (Rec_Comp);
+
+ if Needs_Finalization (Comp_Typ)
+ and then not Is_Limited_Type (Comp_Typ)
then
- Rewrite (Expr,
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Lhs),
- Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+ Append_To (Stmts,
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Rec_Comp),
+ Typ => Comp_Typ));
end if;
+ end Initialize_Record_Component;
- return OK;
- end Rewrite_Discriminant;
+ -------------------------
+ -- Is_Int_Range_Bounds --
+ -------------------------
+ function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
+ begin
+ return Nkind (Bounds) = N_Range
+ and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
+ and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
+ end Is_Int_Range_Bounds;
+
------------------
-- Replace_Type --
------------------
@@ -2646,12 +2880,34 @@
return OK;
end Replace_Type;
- procedure Replace_Self_Reference is
- new Traverse_Proc (Replace_Type);
+ --------------------------
+ -- Rewrite_Discriminant --
+ --------------------------
+ function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (Expr)
+ and then Present (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_In_Parameter
+ and then Present (Discriminal_Link (Entity (Expr)))
+ and then Scope (Discriminal_Link (Entity (Expr))) =
+ Base_Type (Etype (N))
+ then
+ Rewrite (Expr,
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Lhs),
+ Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+ end if;
+
+ return OK;
+ end Rewrite_Discriminant;
+
procedure Replace_Discriminants is
new Traverse_Proc (Rewrite_Discriminant);
+ procedure Replace_Self_Reference is
+ new Traverse_Proc (Replace_Type);
+
-- Start of processing for Build_Record_Aggr_Code
begin
@@ -3238,57 +3494,61 @@
Ctype => Component_Type (Expr_Q_Type),
Index => First_Index (Expr_Q_Type),
Into => Comp_Expr,
- Scalar_Comp => Is_Scalar_Type
- (Component_Type (Expr_Q_Type))));
+ Scalar_Comp =>
+ Is_Scalar_Type (Component_Type (Expr_Q_Type))));
end;
else
- Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name => Comp_Expr,
- Expression => Expr_Q);
+ -- Handle an initialization expression of a controlled type
+ -- in case it denotes a function call. In general such a
+ -- scenario will produce a transient scope, but this will
+ -- lead to wrong order of initialization, adjustment, and
+ -- finalization in the context of aggregates.
- Set_No_Ctrl_Actions (Instr);
- Append_To (L, Instr);
- end if;
+ -- Target.Comp := Ctrl_Func_Call;
- -- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for a VM where tags are
- -- implicit.
+ -- begin -- scope
+ -- Trans_Obj : ... := Ctrl_Func_Call; -- object
+ -- Target.Comp := Trans_Obj;
+ -- Finalize (Trans_Obj);
+ -- end
+ -- Target.Comp._tag := ...;
+ -- Adjust (Target.Comp);
- -- tmp.comp._tag := comp_typ'tag;
+ -- In the example above, the call to Finalize occurs too
+ -- early and as a result it may leave the record component
+ -- in a bad state. Finalization of the transient object
+ -- should really happen after adjustment.
- if Is_Tagged_Type (Comp_Type)
- and then Tagged_Type_Expansion
- then
- Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Comp_Expr),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Comp_Type), Loc)),
+ -- To avoid this scenario, perform in-place side-effect
+ -- removal of the function call. This eliminates the
+ -- transient property of the function result and ensures
+ -- correct order of actions.
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
- Loc)));
+ -- Res : ... := Ctrl_Func_Call;
+ -- Target.Comp := Res;
+ -- Target.Comp._tag := ...;
+ -- Adjust (Target.Comp);
+ -- Finalize (Res);
- Append_To (L, Instr);
- end if;
+ if Needs_Finalization (Comp_Type)
+ and then Nkind (Expr_Q) /= N_Aggregate
+ then
+ Initialize_Ctrl_Record_Component
+ (Rec_Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
- -- Generate:
- -- Adjust (tmp.comp);
+ -- Otherwise perform single component initialization
- if Needs_Finalization (Comp_Type)
- and then not Is_Limited_Type (Comp_Type)
- then
- Append_To (L,
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Comp_Expr),
- Typ => Comp_Type));
+ else
+ Initialize_Record_Component
+ (Rec_Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
+ end if;
end if;
end if;
@@ -3692,19 +3952,17 @@
-- case the current delayed expansion mechanism doesn't work when
-- the declared object size depend on the initializing expr.
- begin
- Parent_Node := Parent (Parent_Node);
- Parent_Kind := Nkind (Parent_Node);
+ Parent_Node := Parent (Parent_Node);
+ Parent_Kind := Nkind (Parent_Node);
- if Parent_Kind = N_Object_Declaration then
- Unc_Decl :=
- not Is_Entity_Name (Object_Definition (Parent_Node))
- or else Has_Discriminants
- (Entity (Object_Definition (Parent_Node)))
- or else Is_Class_Wide_Type
- (Entity (Object_Definition (Parent_Node)));
- end if;
- end;
+ if Parent_Kind = N_Object_Declaration then
+ Unc_Decl :=
+ not Is_Entity_Name (Object_Definition (Parent_Node))
+ or else Has_Discriminants
+ (Entity (Object_Definition (Parent_Node)))
+ or else Is_Class_Wide_Type
+ (Entity (Object_Definition (Parent_Node)));
+ end if;
end if;
-- Just set the Delay flag in the cases where the transformation will be
@@ -3758,13 +4016,14 @@
-- the target of the assignment must not be declared within a local
-- block, and because cleanup will take place on return from the
-- initialization procedure.
+
-- Should the condition be more restrictive ???
if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
Establish_Transient_Scope (N, Sec_Stack => Needs_Finalization (Typ));
end if;
- -- If the aggregate is non-limited, create a temporary. If it is limited
+ -- If the aggregate is nonlimited, create a temporary. If it is limited
-- and context is an assignment, this is a subaggregate for an enclosing
-- aggregate being expanded. It must be built in place, so use target of
-- the current assignment.
@@ -7295,177 +7554,306 @@
end if;
end Must_Slide;
- ----------------------------------
- -- Two_Dim_Packed_Array_Handled --
- ----------------------------------
+ ---------------------------------
+ -- Process_Transient_Component --
+ ---------------------------------
- function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Ctyp : constant Entity_Id := Component_Type (Typ);
- Comp_Size : constant Int := UI_To_Int (Component_Size (Typ));
- Packed_Array : constant Entity_Id :=
- Packed_Array_Impl_Type (Base_Type (Typ));
+ procedure Process_Transient_Component
+ (Loc : Source_Ptr;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Aggr : Node_Id := Empty;
+ Stmts : List_Id := No_List)
+ is
+ procedure Add_Item (Item : Node_Id);
+ -- Insert arbitrary node Item into the tree depending on the values of
+ -- Aggr and Stmts.
- One_Comp : Node_Id;
- -- Expression in original aggregate
+ --------------
+ -- Add_Item --
+ --------------
- One_Dim : Node_Id;
- -- One-dimensional subaggregate
+ procedure Add_Item (Item : Node_Id) is
+ begin
+ if Present (Aggr) then
+ Insert_Action (Aggr, Item);
+ else
+ pragma Assert (Present (Stmts));
+ Append_To (Stmts, Item);
+ end if;
+ end Add_Item;
+ -- Local variables
+
+ Hook_Assign : Node_Id;
+ Hook_Decl : Node_Id;
+ Ptr_Decl : Node_Id;
+ Res_Decl : Node_Id;
+ Res_Id : Entity_Id;
+ Res_Typ : Entity_Id;
+
+ -- Start of processing for Process_Transient_Component
+
begin
+ -- Add the access type, which provides a reference to the function
+ -- result. Generate:
- -- For now, only deal with cases where an integral number of elements
- -- fit in a single byte. This includes the most common boolean case.
+ -- type Res_Typ is access all Comp_Typ;
- if not (Comp_Size = 1 or else
- Comp_Size = 2 or else
- Comp_Size = 4)
- then
- return False;
- end if;
+ Res_Typ := Make_Temporary (Loc, 'A');
+ Set_Ekind (Res_Typ, E_General_Access_Type);
+ Set_Directly_Designated_Type (Res_Typ, Comp_Typ);
- Convert_To_Positional
- (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+ Add_Item
+ (Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Res_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc))));
- -- Verify that all components are static
+ -- Add the temporary which captures the result of the function call.
+ -- Generate:
- if Nkind (N) = N_Aggregate
- and then Compile_Time_Known_Aggregate (N)
- then
- null;
+ -- Res : constant Res_Typ := Init_Expr'Reference;
- -- The aggregate may have been re-analyzed and converted already
+ -- Note that this temporary is effectively a transient object because
+ -- its lifetime is bounded by the current array or record component.
- elsif Nkind (N) /= N_Aggregate then
- return True;
+ Res_Id := Make_Temporary (Loc, 'R');
+ Set_Ekind (Res_Id, E_Constant);
+ Set_Etype (Res_Id, Res_Typ);
- -- If component associations remain, the aggregate is not static
+ -- Mark the transient object as successfully processed to avoid double
+ -- finalization.
- elsif Present (Component_Associations (N)) then
- return False;
+ Set_Is_Finalized_Transient (Res_Id);
- else
- One_Dim := First (Expressions (N));
- while Present (One_Dim) loop
- if Present (Component_Associations (One_Dim)) then
- return False;
- end if;
+ -- Signal the general finalization machinery that this transient object
+ -- should not be considered for finalization actions because its cleanup
+ -- will be performed by Process_Transient_Component_Completion.
- One_Comp := First (Expressions (One_Dim));
- while Present (One_Comp) loop
- if not Is_OK_Static_Expression (One_Comp) then
- return False;
- end if;
+ Set_Is_Ignored_Transient (Res_Id);
- Next (One_Comp);
- end loop;
+ Res_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Res_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Res_Typ, Loc),
+ Expression =>
+ Make_Reference (Loc, New_Copy_Tree (Init_Expr)));
- Next (One_Dim);
- end loop;
- end if;
+ Add_Item (Res_Decl);
- -- Two-dimensional aggregate is now fully positional so pack one
- -- dimension to create a static one-dimensional array, and rewrite
- -- as an unchecked conversion to the original type.
+ -- Construct all pieces necessary to hook and finalize the transient
+ -- result.
- declare
- Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array));
- -- The packed array type is a byte array
+ Build_Transient_Object_Statements
+ (Obj_Decl => Res_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl);
- Packed_Num : Nat;
- -- Number of components accumulated in current byte
+ -- Add the access type which provides a reference to the transient
+ -- result. Generate:
- Comps : List_Id;
- -- Assembled list of packed values for equivalent aggregate
+ -- type Ptr_Typ is access all Comp_Typ;
- Comp_Val : Uint;
- -- integer value of component
+ Add_Item (Ptr_Decl);
- Incr : Int;
- -- Step size for packing
+ -- Add the temporary which acts as a hook to the transient result.
+ -- Generate:
- Init_Shift : Int;
- -- Endian-dependent start position for packing
+ -- Hook : Ptr_Typ := null;
- Shift : Int;
- -- Current insertion position
+ Add_Item (Hook_Decl);
- Val : Int;
- -- Component of packed array being assembled.
+ -- Attach the transient result to the hook. Generate:
- begin
- Comps := New_List;
- Val := 0;
- Packed_Num := 0;
+ -- Hook := Ptr_Typ (Res);
- -- Account for endianness. See corresponding comment in
- -- Packed_Array_Aggregate_Handled concerning the following.
+ Add_Item (Hook_Assign);
- if Bytes_Big_Endian
- xor Debug_Flag_8
- xor Reverse_Storage_Order (Base_Type (Typ))
- then
- Init_Shift := Byte_Size - Comp_Size;
- Incr := -Comp_Size;
- else
- Init_Shift := 0;
- Incr := +Comp_Size;
- end if;
+ -- The original initialization expression now references the value of
+ -- the temporary function result. Generate:
- -- Iterate over each subaggregate
+ -- Res.all
- Shift := Init_Shift;
- One_Dim := First (Expressions (N));
- while Present (One_Dim) loop
- One_Comp := First (Expressions (One_Dim));
- while Present (One_Comp) loop
- if Packed_Num = Byte_Size / Comp_Size then
+ Rewrite (Init_Expr,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Res_Id, Loc)));
+ end Process_Transient_Component;
- -- Byte is complete, add to list of expressions
+ --------------------------------------------
+ -- Process_Transient_Component_Completion --
+ --------------------------------------------
- Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
- Val := 0;
- Shift := Init_Shift;
- Packed_Num := 0;
+ procedure Process_Transient_Component_Completion
+ (Loc : Source_Ptr;
+ Aggr : Node_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+ Stmts : List_Id)
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
- else
- Comp_Val := Expr_Rep_Value (One_Comp);
+ begin
+ pragma Assert (Present (Fin_Call));
+ pragma Assert (Present (Hook_Clear));
- -- Adjust for bias, and strip proper number of bits
+ -- Generate the following code if exception propagation is allowed:
- if Has_Biased_Representation (Ctyp) then
- Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp));
- end if;
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
- Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
- Shift := Shift + Incr;
- One_Comp := Next (One_Comp);
- Packed_Num := Packed_Num + 1;
- end if;
- end loop;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- One_Dim := Next (One_Dim);
- end loop;
+ -- begin
+ -- [Abort_Defer;]
- if Packed_Num > 0 then
+ -- begin
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
- -- Add final incomplete byte if present
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E,
+ -- Get_Curent_Excep.all.all);
+ -- end if;
+ -- end;
- Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
- end if;
+ -- [Abort_Undefer;]
- Rewrite (N,
- Unchecked_Convert_To (Typ,
- Make_Qualified_Expression (Loc,
- Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc),
- Expression => Make_Aggregate (Loc, Expressions => Comps))));
- Analyze_And_Resolve (N);
- return True;
- end;
- end Two_Dim_Packed_Array_Handled;
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
+ if Exceptions_OK then
+ Abort_And_Exception : declare
+ Blk_Decls : constant List_Id := New_List;
+ Blk_Stmts : constant List_Id := New_List;
+
+ Fin_Data : Finalization_Exception_Data;
+
+ begin
+ -- Create the declarations of the two flags and the exception
+ -- occurrence.
+
+ Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
+
+ -- Generate:
+ -- Abort_Defer;
+
+ if Abort_Allowed then
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Defer));
+ end if;
+
+ -- Wrap the hook clear and the finalization call in order to trap
+ -- a potential exception.
+
+ Append_To (Blk_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Hook_Clear,
+ Fin_Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Fin_Data)))));
+
+ -- Generate:
+ -- Abort_Undefer;
+
+ if Abort_Allowed then
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+
+ -- Reraise the potential exception with a proper "upgrade" to
+ -- Program_Error if needed.
+
+ Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
+
+ -- Wrap everything in a block
+
+ Append_To (Stmts,
+ Make_Block_Statement (Loc,
+ Declarations => Blk_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Blk_Stmts)));
+ end Abort_And_Exception;
+
+ -- Generate the following code if exception propagation is not allowed
+ -- and aborts are allowed:
+
+ -- begin
+ -- Abort_Defer;
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
+ -- at end
+ -- Abort_Undefer;
+ -- end;
+
+ elsif Abort_Allowed then
+ Abort_Only : declare
+ Blk_Stmts : constant List_Id := New_List;
+
+ AUD : Entity_Id;
+ Blk : Node_Id;
+ Blk_HSS : Node_Id;
+ Blk_Id : Entity_Id;
+
+ begin
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+ Append_To (Blk_Stmts, Hook_Clear);
+ Append_To (Blk_Stmts, Fin_Call);
+
+ AUD := RTE (RE_Abort_Undefer_Direct);
+
+ Blk_HSS :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Blk_Stmts,
+ At_End_Proc => New_Occurrence_Of (AUD, Loc));
+
+ Blk :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence => Blk_HSS);
+
+ Add_Block_Identifier (Blk, Blk_Id);
+ Expand_At_End_Handler (Blk_HSS, Blk_Id);
+
+ -- Present the Abort_Undefer_Direct function to the back end so
+ -- that it can inline the call to the function.
+
+ Add_Inlined_Body (AUD, Aggr);
+
+ Append_To (Stmts, Blk);
+ end Abort_Only;
+
+ -- Otherwise generate:
+
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
+
+ else
+ Append_To (Stmts, Hook_Clear);
+ Append_To (Stmts, Fin_Call);
+ end if;
+ end Process_Transient_Component_Completion;
+
---------------------
-- Sort_Case_Table --
---------------------
@@ -7612,4 +8000,175 @@
end if;
end Static_Array_Aggregate;
+ ----------------------------------
+ -- Two_Dim_Packed_Array_Handled --
+ ----------------------------------
+
+ function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Ctyp : constant Entity_Id := Component_Type (Typ);
+ Comp_Size : constant Int := UI_To_Int (Component_Size (Typ));
+ Packed_Array : constant Entity_Id :=
+ Packed_Array_Impl_Type (Base_Type (Typ));
+
+ One_Comp : Node_Id;
+ -- Expression in original aggregate
+
+ One_Dim : Node_Id;
+ -- One-dimensional subaggregate
+
+ begin
+
+ -- For now, only deal with cases where an integral number of elements
+ -- fit in a single byte. This includes the most common boolean case.
+
+ if not (Comp_Size = 1 or else
+ Comp_Size = 2 or else
+ Comp_Size = 4)
+ then
+ return False;
+ end if;
+
+ Convert_To_Positional
+ (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+
+ -- Verify that all components are static
+
+ if Nkind (N) = N_Aggregate
+ and then Compile_Time_Known_Aggregate (N)
+ then
+ null;
+
+ -- The aggregate may have been reanalyzed and converted already
+
+ elsif Nkind (N) /= N_Aggregate then
+ return True;
+
+ -- If component associations remain, the aggregate is not static
+
+ elsif Present (Component_Associations (N)) then
+ return False;
+
+ else
+ One_Dim := First (Expressions (N));
+ while Present (One_Dim) loop
+ if Present (Component_Associations (One_Dim)) then
+ return False;
+ end if;
+
+ One_Comp := First (Expressions (One_Dim));
+ while Present (One_Comp) loop
+ if not Is_OK_Static_Expression (One_Comp) then
+ return False;
+ end if;
+
+ Next (One_Comp);
+ end loop;
+
+ Next (One_Dim);
+ end loop;
+ end if;
+
+ -- Two-dimensional aggregate is now fully positional so pack one
+ -- dimension to create a static one-dimensional array, and rewrite
+ -- as an unchecked conversion to the original type.
+
+ declare
+ Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array));
+ -- The packed array type is a byte array
+
+ Packed_Num : Nat;
+ -- Number of components accumulated in current byte
+
+ Comps : List_Id;
+ -- Assembled list of packed values for equivalent aggregate
+
+ Comp_Val : Uint;
+ -- Integer value of component
+
+ Incr : Int;
+ -- Step size for packing
+
+ Init_Shift : Int;
+ -- Endian-dependent start position for packing
+
+ Shift : Int;
+ -- Current insertion position
+
+ Val : Int;
+ -- Component of packed array being assembled
+
+ begin
+ Comps := New_List;
+ Val := 0;
+ Packed_Num := 0;
+
+ -- Account for endianness. See corresponding comment in
+ -- Packed_Array_Aggregate_Handled concerning the following.
+
+ if Bytes_Big_Endian
+ xor Debug_Flag_8
+ xor Reverse_Storage_Order (Base_Type (Typ))
+ then
+ Init_Shift := Byte_Size - Comp_Size;
+ Incr := -Comp_Size;
+ else
+ Init_Shift := 0;
+ Incr := +Comp_Size;
+ end if;
+
+ -- Iterate over each subaggregate
+
+ Shift := Init_Shift;
+ One_Dim := First (Expressions (N));
+ while Present (One_Dim) loop
+ One_Comp := First (Expressions (One_Dim));
+ while Present (One_Comp) loop
+ if Packed_Num = Byte_Size / Comp_Size then
+
+ -- Byte is complete, add to list of expressions
+
+ Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
+ Val := 0;
+ Shift := Init_Shift;
+ Packed_Num := 0;
+
+ else
+ Comp_Val := Expr_Rep_Value (One_Comp);
+
+ -- Adjust for bias, and strip proper number of bits
+
+ if Has_Biased_Representation (Ctyp) then
+ Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp));
+ end if;
+
+ Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
+ Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
+ Shift := Shift + Incr;
+ One_Comp := Next (One_Comp);
+ Packed_Num := Packed_Num + 1;
+ end if;
+ end loop;
+
+ One_Dim := Next (One_Dim);
+ end loop;
+
+ if Packed_Num > 0 then
+
+ -- Add final incomplete byte if present
+
+ Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
+ end if;
+
+ Rewrite (N,
+ Unchecked_Convert_To (Typ,
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc),
+ Expression => Make_Aggregate (Loc, Expressions => Comps))));
+ Analyze_And_Resolve (N);
+ return True;
+ end;
+ end Two_Dim_Packed_Array_Handled;
+
end Exp_Aggr;
More information about the Gcc-patches
mailing list