From: Ed Schonberg <schonberg@adacore.com>
Date: Tue, 21 Aug 2018 14:44:46 +0000 (+0000)
Subject: [Ada] Compiler abort on call to expr. function for default discriminant
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8a2f6bbe45fe2dff64d613365fe2ddb2b1922e2f;p=gcc.git

[Ada] Compiler abort on call to expr. function for default discriminant

If a discriminant specification has a default that is a call to an
expression function, that function has to be frozen at the point of a
call to the initialization procedure for an object of the record type,
even though the call does not appear to come from source.

2018-08-21  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_res.adb (Resolve_Call): Force the freezing of an
	expression function that is called to provide a default value
	for a defaulted discriminant in an object initialization.

gcc/testsuite/

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

From-SVN: r263710
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 31420a3d663..7bae0cfc813 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2018-08-21  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_res.adb (Resolve_Call): Force the freezing of an
+	expression function that is called to provide a default value
+	for a defaulted discriminant in an object initialization.
+
 2018-08-21  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* libgnat/g-dynhta.adb, libgnat/g-dynhta.ads: New package
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index ddfa5430a7b..13612aa3bf5 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6067,7 +6067,10 @@ package body Sem_Res is
       --  (including the body of another expression function) which would
       --  place the freeze node in the wrong scope. An expression function
       --  is frozen in the usual fashion, by the appearance of a real body,
-      --  or at the end of a declarative part.
+      --  or at the end of a declarative part. However an implcit call to
+      --  an expression function may appear when it is part of a default
+      --  expression in a call to an initialiation procedure, and must be
+      --  frozen now, even if the body is inserted at a later point.
 
       if Is_Entity_Name (Subp)
         and then not In_Spec_Expression
@@ -6076,6 +6079,14 @@ package body Sem_Res is
           (not Is_Expression_Function_Or_Completion (Entity (Subp))
             or else Scope (Entity (Subp)) = Current_Scope)
       then
+         if Is_Expression_Function (Entity (Subp)) then
+
+            --  Force freeze of expression function in call.
+
+            Set_Comes_From_Source (Subp, True);
+            Set_Must_Not_Freeze (Subp, False);
+         end if;
+
          Freeze_Expression (Subp);
       end if;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2c02ca1549a..a3d8dda36c2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-08-21  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/expr_func5.adb: New testcase.
+
 2018-08-21  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/dynhash.adb: New testcase.
diff --git a/gcc/testsuite/gnat.dg/expr_func5.adb b/gcc/testsuite/gnat.dg/expr_func5.adb
new file mode 100644
index 00000000000..34c4eb3b78d
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/expr_func5.adb
@@ -0,0 +1,10 @@
+--  { dg-do compile }
+
+procedure Expr_Func5 is
+   type T is (B);
+   function F return T is (B);
+   type R (W : T := F) is null record;
+   V : R;
+begin
+   null;
+end Expr_Func5;