backport: re PR fortran/78619 (ICE in copy_reference_ops_from_ref, at tree-ssa-sccvn...

2017-11-13  Paul Thomas  <pault@gcc.gnu.org>

	Backport from trunk
	PR fortran/78619
	* check.c (same_type_check): Introduce a new argument 'assoc'
	with default value false. If this is true, use the symbol type
	spec of BT_PROCEDURE expressions.
	(gfc_check_associated): Set 'assoc' true in the call to
	'same_type_check'.

2017-11-13  Paul Thomas  <pault@gcc.gnu.org>

	Backport from trunk
	PR fortran/78619
	* gfortran.dg/pr78619.f90: New test.

From-SVN: r254719

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d7f4609dc717c024a200e7aa1c9d9e0373ad2c00..603ed33fc3a4819163a6fd47c697bf54062d1cac 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2017-11-13  Paul Thomas  <pault@gcc.gnu.org>
+
+       Backport from trunk
+       PR fortran/78619
+       * check.c (same_type_check): Introduce a new argument 'assoc'
+       with default value false. If this is true, use the symbol type
+       spec of BT_PROCEDURE expressions.
+       (gfc_check_associated): Set 'assoc' true in the call to
+       'same_type_check'.
+
 2017-11-06  Paul Thomas  <pault@gcc.gnu.org>
 
        Backported from trunk

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 80c884738a4d0127b7c503baa289ad76f613acee..ee421d99cd9d2b440496eca2cba9448c1b0d97cf 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -404,15 +404,22 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
 /* Make sure two expressions have the same type.  */
 
 static bool
-same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
+same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false)
 {
   gfc_typespec *ets = &e->ts;
   gfc_typespec *fts = &f->ts;
 
-  if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
-    ets = &e->symtree->n.sym->ts;
-  if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
-    fts = &f->symtree->n.sym->ts;
+  if (assoc)
+    {
+      /* Procedure pointer component expressions have the type of the interface
+        procedure. If they are being tested for association with a procedure
+        pointer (ie. not a component), the type of the procedure must be
+        determined.  */
+      if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym)
+       ets = &e->symtree->n.sym->ts;
+      if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym)
+       fts = &f->symtree->n.sym->ts;
+    }
 
   if (gfc_compare_types (ets, fts))
     return true;
@@ -968,7 +975,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
     }
 
   t = true;
-  if (!same_type_check (pointer, 0, target, 1))
+  if (!same_type_check (pointer, 0, target, 1, true))
     t = false;
   if (!rank_check (target, 0, pointer->rank))
     t = false;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fc1441b0c21b68e31b564066404f34a99bc152ec..fd9561b184c89a3e0cb707a934e7d5707393034c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2017-11-13  Paul Thomas  <pault@gcc.gnu.org>
+
+       Backport from trunk
+       PR fortran/78619
+       * gfortran.dg/pr78619.f90: New test.
+
 2017-11-11  John David Anglin  <danglin@gcc.gnu.org>
 
        Backport from mainline

diff --git a/gcc/testsuite/gfortran.dg/pr78619.f90 b/gcc/testsuite/gfortran.dg/pr78619.f90
new file mode 100644 (file)
index 0000000..5fbe185
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr78619.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-options "-Werror -O3" }
+!
+! Tests the fix for PR78619, in which the recursive use of 'f' at line 13
+! caused an ICE.
+!
+! Contributed by Gerhard Steinmetz  <gerhard.steinmetz.fortran@t-online.de>
+!
+  print *, g(1.0) ! 'g' is OK
+contains
+  function f(x) result(z)
+    real :: x, z
+    z = sign(1.0, f) ! { dg-error "calling itself recursively|must be the same type" }
+  end
+  real function g(x)
+    real :: x
+    g = -1
+    g = -sign(1.0, g) ! This is OK.
+  end
+end
+! { dg-message "all warnings being treated as errors" "" { target *-*-* } 0 }