+2018-05-24 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Ignore raising an error in
+ expansion for limited tagged types when the node to be expanded is a
+ raise expression due to it not representing a valid object.
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Add exception to error
+ message regarding assignments to limited types to ignore genereated
+ code.
+
2018-05-24 Hristian Kirtchev <kirtchev@adacore.com>
* exp_util.adb (New_Class_Wide_Subtype): Capture and restore relevant
-- If we cannot convert the expression into a renaming we must
-- consider it an internal error because the backend does not
- -- have support to handle it.
+ -- have support to handle it. Also, when a raise expression is
+ -- encountered we ignore it since it doesn't return a value and
+ -- thus cannot trigger a copy.
- else
+ elsif Nkind (Original_Node (Expr_Q)) /= N_Raise_Expression then
pragma Assert (False);
raise Program_Error;
end if;
-- extension of a limited interface, and the actual is
-- limited. This is an error according to AI05-0087, but
-- is not caught at the point of instantiation in earlier
- -- versions.
+ -- versions. We also must verify that the limited type does
+ -- not come from source as corner cases may exist where
+ -- an assignment was not intended like the pathological case
+ -- of a raise expression within a return statement.
-- This is wrong, error messages cannot be issued during
-- expansion, since they would be missed in -gnatc mode ???
- Error_Msg_N ("assignment not available on limited type", N);
+ if Comes_From_Source (N) then
+ Error_Msg_N
+ ("assignment not available on limited type", N);
+ end if;
+
return;
end if;
+2018-05-24 Justin Squirek <squirek@adacore.com>
+
+ * gnat.dg/raise_expr.adb: New testcase.
+
2018-05-24 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/formal_containers.adb: New testcase.
--- /dev/null
+-- { dg-do compile }
+
+procedure Raise_Expr is
+
+ E : exception;
+
+ type T is tagged limited null record;
+ type TC is new T with null record;
+
+ function F0 return Boolean is
+ begin
+ return raise E;
+ end;
+
+ function F return T'Class is
+ TT : T;
+ begin
+ return raise E; -- Causes compile-time crash
+ end F;
+
+begin
+ declare
+ O : T'class := F;
+ begin
+ null;
+ end;
+end Raise_Expr;