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

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

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

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

From-SVN: r270268

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 832f2c75e3825a8d3519b89bedc884102efaab96..e25bb0fb8dc6c7daf390acdf4b7554f281dbb432 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2019-04-10  Harald Anlauf  <anlauf@gmx.de>
+
+       Backport from trunk
+       PR fortran/89904
+       * check.c (gfc_check_transfer): Reject procedures as actual
+       arguments for SOURCE and MOLD of TRANSFER intrinsic.
+
 2019-03-31  Harald Anlauf  <anlauf@gmx.de>
 
        Backport from trunk

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index f5e0ab5f5b8e3492c21b4bc161fb0358682076f9..f49fb9e9e09f2713eb156e56fce8971d0ac5a0c4 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -5295,6 +5295,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"
@@ -5302,6 +5322,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 d5d5187aeb9db7920dfcccd06e7fae379a5b1a0d..d235ad826e6bdbd3794b116b320e834aa541a288 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2019-04-10  Harald Anlauf  <anlauf@gmx.de>
+
+       Backport from trunk
+       PR fortran/89904
+       * gfortran.dg/pr85797.f90: Adjust testcase.
+
 2019-04-10  Matthew Malcomson  <matthew.malcomson@arm.com>
 
        PR target/90024

diff --git a/gcc/testsuite/gfortran.dg/pr85797.f90 b/gcc/testsuite/gfortran.dg/pr85797.f90
index fe6d96d6e304d1744c27ec426625869ddc7feee7..01d8e640621e9b76741bc498288782dcdd486d11 100644 (file)
--- 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)