[Ada] Crash on object initialization that is call to expression function

This patch fixes a compiler abort on an object declaration for a
class-wide type whose expression is a call to an expression function
that returns type extension.

2019-08-19  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_res.adb (Resolve_Call): A call to an expression function
	freezes when expander is active, unless the call appears within
	the body of another expression function,

gcc/testsuite/

	* gnat.dg/expr_func9.adb: New testcase.

From-SVN: r274662
This commit is contained in:
Ed Schonberg 2019-08-19 08:37:18 +00:00 committed by Pierre-Marie de Rodat
parent c702203823
commit fcef060c9b
4 changed files with 37 additions and 1 deletions

View File

@ -1,3 +1,9 @@
2019-08-19 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Call): A call to an expression function
freezes when expander is active, unless the call appears within
the body of another expression function,
2019-08-19 Dmitriy Anisimkov <anisimko@adacore.com>
* libgnat/s-os_lib.ads, libgnat/s-os_lib.adb (To_Ada, To_C): New

View File

@ -6314,13 +6314,15 @@ package body Sem_Res is
-- an expression function may appear when it is part of a default
-- expression in a call to an initialization procedure, and must be
-- frozen now, even if the body is inserted at a later point.
-- Otherwise, the call freezes the expression if expander is active,
-- for example as part of an object declaration.
if Is_Entity_Name (Subp)
and then not In_Spec_Expression
and then not Is_Expression_Function_Or_Completion (Current_Scope)
and then
(not Is_Expression_Function_Or_Completion (Entity (Subp))
or else Scope (Entity (Subp)) = Current_Scope)
or else Expander_Active)
then
if Is_Expression_Function (Entity (Subp)) then

View File

@ -1,3 +1,7 @@
2019-08-19 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/expr_func9.adb: New testcase.
2019-08-19 Bob Duff <duff@adacore.com>
* gnat.dg/valid_scalars2.adb: New testcase.

View File

@ -0,0 +1,24 @@
-- { dg-do compile }
-- { dg-options "-gnatws" }
procedure Expr_Func9 is
type Root is interface;
type Child1 is new Root with null record;
type Child2 is new Root with record
I2 : Integer;
end record;
function Create (I : Integer) return Child2 is (I2 => I);
I : Root'Class :=
(if False
then Child1'(null record)
else
Create (1));
begin
null;
end Expr_Func9;