===================================================================
@@ -3317,7 +3317,21 @@
Kill_Current_Values;
- if Present (Actions (P)) then
+ -- If P has already been expanded, we can't park new actions
+ -- on it, so we need to expand them immediately, introducing
+ -- an Expression_With_Actions. N can't be an expression
+ -- with actions, or else then the actions would have been
+ -- inserted at an inner level.
+
+ if Analyzed (P) then
+ pragma Assert (Nkind (N) /= N_Expression_With_Actions);
+ Rewrite (N,
+ Make_Expression_With_Actions (Sloc (N),
+ Actions => Ins_Actions,
+ Expression => Relocate_Node (N)));
+ Analyze_And_Resolve (N);
+
+ elsif Present (Actions (P)) then
Insert_List_After_And_Analyze
(Last (Actions (P)), Ins_Actions);
else
@@ -3407,8 +3421,12 @@
-- the new actions come from the expression of the expression with
-- actions, they must be added to the existing actions. The other
-- alternative is when the new actions are related to one of the
- -- existing actions of the expression with actions. In that case
- -- they must be inserted further up the tree.
+ -- existing actions of the expression with actions, and should
+ -- never reach here: if actions are inserted on a statement within
+ -- the Actions of an expression with actions, or on some
+ -- sub-expression of such a statement, then the outermost proper
+ -- insertion point is right before the statement, and we should
+ -- never climb up as far as the N_Expression_With_Actions itself.
when N_Expression_With_Actions =>
if N = Expression (P) then
@@ -3420,6 +3438,9 @@
(Last (Actions (P)), Ins_Actions);
end if;
return;
+
+ else
+ raise Program_Error;
end if;
-- Case of appearing in the condition of a while expression or
===================================================================
@@ -47,8 +47,6 @@
with Sem_Cat; use Sem_Cat;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@@ -2891,6 +2889,9 @@
Nod : Node_Id;
Loc : constant Source_Ptr := Sloc (N);
+ Chk : Node_Id;
+ -- The check (N_Raise_Program_Error) node to be inserted
+
begin
-- If expansion is disabled, do not generate any checks. Also
-- skip checks if any subunits are missing because in either
@@ -2914,106 +2915,35 @@
Nod := N;
end if;
+ -- Build check node, possibly with condition
+
+ Chk := Make_Raise_Program_Error (Loc,
+ Reason => PE_Access_Before_Elaboration);
+ if Present (C) then
+ Set_Condition (Chk,
+ Make_Op_Not (Loc, Right_Opnd => C));
+ end if;
+
-- If we are inserting at the top level, insert in Aux_Decls
if Nkind (Parent (Nod)) = N_Compilation_Unit then
declare
ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
- R : Node_Id;
begin
- if No (C) then
- R :=
- Make_Raise_Program_Error (Loc,
- Reason => PE_Access_Before_Elaboration);
- else
- R :=
- Make_Raise_Program_Error (Loc,
- Condition => Make_Op_Not (Loc, C),
- Reason => PE_Access_Before_Elaboration);
- end if;
-
if No (Declarations (ADN)) then
- Set_Declarations (ADN, New_List (R));
+ Set_Declarations (ADN, New_List (Chk));
else
- Append_To (Declarations (ADN), R);
+ Append_To (Declarations (ADN), Chk);
end if;
- Analyze (R);
+ Analyze (Chk);
end;
- -- Otherwise just insert before the node in question. However, if
- -- the context of the call has already been analyzed, an insertion
- -- will not work if it depends on subsequent expansion (e.g. a call in
- -- a branch of a short-circuit). In that case we replace the call with
- -- an if expression, or with a Raise if it is unconditional.
+ -- Otherwise just insert as an action on the node in question
- -- Unfortunately this does not work if the call has a dynamic size,
- -- because gigi regards it as a dynamic-sized temporary. If such a call
- -- appears in a short-circuit expression, the elaboration check will be
- -- missed (rare enough ???). Otherwise, the code below inserts the check
- -- at the appropriate place before the call. Same applies in the even
- -- rarer case the return type has a known size but is unconstrained.
-
else
- if Nkind (N) = N_Function_Call
- and then Analyzed (Parent (N))
- and then Size_Known_At_Compile_Time (Etype (N))
- and then
- (not Has_Discriminants (Etype (N))
- or else Is_Constrained (Etype (N)))
-
- then
- declare
- Typ : constant Entity_Id := Etype (N);
- Chk : constant Boolean := Do_Range_Check (N);
-
- R : constant Node_Id :=
- Make_Raise_Program_Error (Loc,
- Reason => PE_Access_Before_Elaboration);
-
- Reloc_N : Node_Id;
-
- begin
- Set_Etype (R, Typ);
-
- if No (C) then
- Rewrite (N, R);
-
- else
- Reloc_N := Relocate_Node (N);
- Save_Interps (N, Reloc_N);
- Rewrite (N,
- Make_If_Expression (Loc,
- Expressions => New_List (C, Reloc_N, R)));
- end if;
-
- Analyze_And_Resolve (N, Typ);
-
- -- If the original call requires a range check, so does the
- -- if expression.
-
- if Chk then
- Enable_Range_Check (N);
- else
- Set_Do_Range_Check (N, False);
- end if;
- end;
-
- else
- if No (C) then
- Insert_Action (Nod,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Access_Before_Elaboration));
- else
- Insert_Action (Nod,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Not (Loc,
- Right_Opnd => C),
- Reason => PE_Access_Before_Elaboration));
- end if;
- end if;
+ Insert_Action (Nod, Chk);
end if;
end Insert_Elab_Check;
This change removes specialized code for insertion of dynamic elaboration checks (-gnatE) that caused a temporary of a controlled type to be finalized too early when passed as actual parameter to a subprogram through a named parameter association. The following compilation must be accepted and produce the indicated result: $ gnatmake -q -gnatE elab_check_ctr $ ./elab_check_ctr Inner: X.Ptr.all = 1 with Ada.Finalization; package Ctrl_Typ is type Int_Access is access all Integer; type Ctr is new Ada.Finalization.Controlled with record Ptr : Int_Access; end record; procedure Adjust (X : in out Ctr); procedure Finalize (X : in out Ctr); function Make return Ctr; end Ctrl_Typ; with Ada.Unchecked_Deallocation; package body Ctrl_Typ is procedure Free is new Ada.Unchecked_Deallocation (Integer, Int_Access); procedure Adjust (X : in out Ctr) is begin if X.Ptr /= null then X.Ptr.all := X.Ptr.all + 1; end if; end Adjust; procedure Finalize (X : in out Ctr) is begin if X.Ptr /= null then if X.Ptr.all < 1 then raise Program_Error; end if; X.Ptr.all := X.Ptr.all - 1; if X.Ptr.all = 0 then Free (X.Ptr); end if; end if; end Finalize; function Make return Ctr is begin return Ctr'(Ada.Finalization.Controlled with Ptr => new Integer'(1)); end Make; end Ctrl_Typ; with Ctrl_Typ; use Ctrl_Typ; with Ada.Text_IO; use Ada.Text_IO; procedure Elab_Check_Ctr is procedure Inner (X : Ctr) is begin if X.Ptr = null then Put_Line ("Inner : X.Ptr = null"); else Put_Line ("Inner: X.Ptr.all =" & X.Ptr.all'Img); end if; end Inner; begin Inner (X => Make); end Elab_Check_Ctr; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-01-22 Thomas Quinot <quinot@adacore.com> * exp_util.adb (Insert_Actions): When inserting actions on a short circuit operator that has already been analyzed, do not park actions in node; instead introduce an N_Expression_With_Actions and insert actions immediately. Add guard for unexpected case of climbing up through statement in Actions list of an N_Expression_With_Actions. * sem_elab.adb (Insert_Elab_Check): Remove complex specialized circuitry for the case where the context is already analyzed, as it is not needed and introduces irregularities in finalization. Instead rely on the above change to Insert_Actions to ensure that late insertion on short circuit operators works as expected.