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

[Pierre-Marie de Rodat <derodat at adacore dot com>]

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.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

--- gcc/ada/sem_ch6.adb
+++ 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--- /dev/null
new file mode 100644
+++ 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;--- /dev/null
new file mode 100644
+++ 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;