===================================================================
@@ -10577,16 +10577,17 @@
end if;
-- Check for case of converting to a type that has an invariant
- -- associated with it. This required an invariant check. We convert
+ -- associated with it. This requires an invariant check. We insert
+ -- a call:
- -- typ (expr)
+ -- invariant_check (typ (expr))
- -- into
+ -- in the code, after removing side effects from the expression.
+ -- This is clearer than replacing the conversion into an expression
+ -- with actions, because the context may impose additional actions
+ -- (tag checks, membership tests, etc.) that conflict with this
+ -- rewriting (used previously).
- -- do invariant_check (typ (expr)) in typ (expr);
-
- -- using Duplicate_Subexpr to avoid multiple side effects
-
-- Note: the Comes_From_Source check, and then the resetting of this
-- flag prevents what would otherwise be an infinite recursion.
@@ -10595,12 +10596,8 @@
and then Comes_From_Source (N)
then
Set_Comes_From_Source (N, False);
- Rewrite (N,
- Make_Expression_With_Actions (Loc,
- Actions => New_List (
- Make_Invariant_Call (Duplicate_Subexpr (N))),
- Expression => Duplicate_Subexpr_No_Checks (N)));
- Analyze_And_Resolve (N, Target_Type);
+ Remove_Side_Effects (N);
+ Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
goto Done;
end if;
This patch fixes a spurious error on a renaming of a conversion of the designated object of a pointer to class-wide type when the target type has an invariant aspect. The following must execute quietly: gnatmake -gnata -q main main --- with System.Assertions; use System.Assertions; with Gd; use Gd; procedure main is begin Foo; raise Program_Error; exception when Assert_Failure => null; end; -- package CN is type CN_Type is private; private type CN_Type is record V : Integer := 27; -- wrong initialization end record with Type_Invariant => V mod 7 = 0; end; --- package HD is type HD_Type is tagged null record; type HD_Class_Pointer is access HD_Type'Class; end; --- with CN; with HD; package GD is type XT is new HD.HD_Type with record X : aliased CN.CN_Type; end record; procedure Foo; end; -- package body GD is procedure Foo is DHP : constant HD.HD_Class_Pointer := new XT; DH : XT renames XT (DHP.all); begin null; end; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-10-12 Ed Schonberg <schonberg@adacore.com> * exp_ch4.adb (Expand_N_Type_Conversion): If the target type has an invariant aspect, insert invariant call at the proper place in the code rather than rewriting the expression as an expression with actions, to prevent spurious semantic errors on the rewritten conversion when it is the object in a renaming.