[Ada] Crash on expression function as completion, with implicit dereference

An implicit dereference freezes the corresponding designated type. Most
implicit dereferences are made explicit during expansion, but this is not the
case for a dispatching call where the the controlling parameter and the
corresponding controlling argument are access to a tagged type. In that case,
to enforce the rule that an expression function that is a completion freezes
type references within, we must locate controlling arguments of an access type
and freeze explicitly the corresponding designated type.

2018-01-11  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_ch6.adb (Freeze_Expr_Types): If an access value is the
	controlling argument of a dispatching call. freeze the corresponding
	designated type.

gcc/testsuite/

	* gnat.dg/expr_func3.adb, gnat.dg/expr_func3.ads: New testcase.

From-SVN: r256507

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9681fbd9713287c30e7ca24a1af186e91f57a396..fc30104ded284d665493d1f7e8702e00108def6a 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2018-01-11  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_ch6.adb (Freeze_Expr_Types): If an access value is the
+       controlling argument of a dispatching call. freeze the corresponding
+       designated type.
+
 2018-01-11  Ben Brosgol  <brosgol@adacore.com>
 
        * doc/Makefile: Add Sphinx option -W to treat warnings as errors.

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index cb5b3e7bd9aea09fbb7a674417d2dfaf6cfb61ce..1c0495f651200c616f0099035bda906e53e217da 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -423,6 +423,20 @@ package body Sem_Ch6 is
                Check_And_Freeze_Type (Designated_Type (Etype (Node)));
             end if;
 
+            --  An implicit dereference freezes the designated type. In the
+            --  case of a dispatching call whose controlling argument is an
+            --  access type, the dereference is not made explicit, so we must
+            --  check for such a call and freeze the designated type.
+
+            if Nkind (Node) in N_Has_Etype
+              and then Present (Etype (Node))
+              and then Is_Access_Type (Etype (Node))
+              and then Nkind (Parent (Node)) = N_Function_Call
+              and then Node = Controlling_Argument (Parent (Node))
+            then
+               Check_And_Freeze_Type (Designated_Type (Etype (Node)));
+            end if;
+
             --  No point in posting several errors on the same expression
 
             if Serious_Errors_Detected > 0 then

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 66e77cc4e2b899bb294726694d408a54160272b1..0ea0a93e0d7d1640d556d99e1da3a5ff1ad3212b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-01-11  Ed Schonberg  <schonberg@adacore.com>
+
+       * gnat.dg/expr_func3.adb, gnat.dg/expr_func3.ads: New testcase.
+
 2018-01-11  Ed Schonberg  <schonberg@adacore.com>
 
        * gnat.dg/fixedpnt2.adb, gnat.dg/fixedpnt2.ads: New testcase.

diff --git a/gcc/testsuite/gnat.dg/expr_func3.adb b/gcc/testsuite/gnat.dg/expr_func3.adb
new file mode 100644 (file)
index 0000000..3e4d583
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/expr_func3.adb
@@ -0,0 +1,7 @@
+--  { dg-do compile }
+
+package body Expr_Func3 is
+
+   procedure Dummy is null;
+
+end Expr_Func3;

diff --git a/gcc/testsuite/gnat.dg/expr_func3.ads b/gcc/testsuite/gnat.dg/expr_func3.ads
new file mode 100644 (file)
index 0000000..45593da
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/expr_func3.ads
@@ -0,0 +1,18 @@
+package Expr_Func3 is
+
+   type Obj_T is abstract tagged null record;
+
+   type T is access all Obj_T'Class;
+
+   function Slave (Obj : access Obj_T) return T is (T(Obj));
+
+   function Optional_Slave (Obj : T) return T;
+
+   procedure Dummy;
+
+private
+
+   function Optional_Slave (Obj : T) return T is
+    (if Obj = null then null else Slave (Obj));
+
+end Expr_Func3;