re PR fortran/89904 (ICE in gfortran starting with r270045)

2019-04-04  Harald Anlauf  <anlauf@gmx.de>

	PR fortran/89004
	* check.c (gfc_check_transfer): Reject procedures as actual
	arguments for SOURCE and MOLD of TRANSFER intrinsic.

	PR fortran/89004
	* gfortran.dg/pr85797.f90: Adjust testcase.

From-SVN: r270150

4 files changed, 40 insertions, 9 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 835ef4e..7b849b0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2019-04-04  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/89004
+	* check.c (gfc_check_transfer): Reject procedures as actual
+	arguments for SOURCE and MOLD of TRANSFER intrinsic.
+
 2019-04-03  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/68567
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index ee50634..a04f0d6 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -5544,6 +5544,26 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
   size_t source_size;
   size_t result_size;
 
+  /* SOURCE shall be a scalar or array of any type.  */
+  if (source->ts.type == BT_PROCEDURE
+      && source->symtree->n.sym->attr.subroutine == 1)
+    {
+      gfc_error ("%<SOURCE%> argument of %<TRANSFER%> intrinsic at %L "
+                 "must not be a %s", &source->where,
+		 gfc_basic_typename (source->ts.type));
+      return false;
+    }
+
+  /* MOLD shall be a scalar or array of any type.  */
+  if (mold->ts.type == BT_PROCEDURE
+      && mold->symtree->n.sym->attr.subroutine == 1)
+    {
+      gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L "
+                 "must not be a %s", &mold->where,
+		 gfc_basic_typename (mold->ts.type));
+      return false;
+    }
+
   if (mold->ts.type == BT_HOLLERITH)
     {
       gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L must not be"
@@ -5551,6 +5571,8 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
       return false;
     }
 
+  /* SIZE (optional) shall be an integer scalar.  The corresponding actual
+     argument shall not be an optional dummy argument.  */
   if (size != NULL)
     {
       if (!type_check (size, 2, BT_INTEGER))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7afa590..31c7082 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2019-04-04  Harald Anlauf  <anlauf@gmx.de>
+
+	PR fortran/89004
+	* gfortran.dg/pr85797.f90: Adjust testcase.
+
 2019-04-04  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/65619
diff --git a/gcc/testsuite/gfortran.dg/pr85797.f90 b/gcc/testsuite/gfortran.dg/pr85797.f90
index fe6d96d..01d8e64 100644
--- a/gcc/testsuite/gfortran.dg/pr85797.f90
+++ b/gcc/testsuite/gfortran.dg/pr85797.f90
@@ -1,29 +1,27 @@
 ! { dg-do compile }
-! { dg-options "-Wall" }
 ! PR fortran/83515 - ICE: Invalid expression in gfc_element_size 
 ! PR fortran/85797 - ICE in gfc_element_size, at fortran/target-memory.c:126
+! PR fortran/89904 - ICE in gfortran starting with r270045
 
-subroutine a
-  c = transfer (a, b)           ! { dg-warning "Non-RECURSIVE procedure" }
+recursive subroutine a
+  c = transfer (a, b)           ! { dg-error "'SOURCE' argument of 'TRANSFER'" }
 end
 
 recursive subroutine d
-  c = transfer (d, b)
-end
-
-recursive subroutine e
-  k = transfer (transfer (e, e), 1)
+  c = transfer (b, d)           ! { dg-error "'MOLD' argument of 'TRANSFER'" }
 end
 
 subroutine f
   use, intrinsic :: iso_c_binding
   integer(c_intptr_t) :: b, c
+  procedure(), pointer :: a
+  c = transfer (a, b)
   c = transfer (transfer (b, a), b)
 end
 
 module m
 contains
-  function f () result (z)      ! { dg-warning "Return value" }
+  function f () result (z)
     class(*), pointer :: z
   end function f
   recursive subroutine s (q)