From: Ed Schonberg <schonberg@adacore.com>
Date: Mon, 19 Aug 2019 08:37:18 +0000 (+0000)
Subject: [Ada] Crash on object initialization that is call to expression function
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fcef060c9b321edcb24a56616588e712c22029ba;p=gcc.git

[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
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 932ff97f2c1..1f490b3efe1 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 8f2e35894d4..7a52b90c98f 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -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
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 127a223f238..2dd707d36c6 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.
diff --git a/gcc/testsuite/gnat.dg/expr_func9.adb b/gcc/testsuite/gnat.dg/expr_func9.adb
new file mode 100644
index 00000000000..4bfa21dc647
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/expr_func9.adb
@@ -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;