[Patch, fortran] PR78619 - [6/7/8 Regression] ICE in copy_reference_ops_from_ref, at tree-ssa-sccvn.c:889

[Paul Richard Thomas]

This regression arose from the patch for PR66465, in which the type
check for the associated intrinsic was failing when testing the
association of a procedure pointer component with a procedure pointer.
See the comment in the patch for an explanation as to why this is an
issue. The fix is to isolate the fix for PR66465 to calls from
gfc_check_associated.

Bootstrapped and regtested on FC23/x86_64. OK for all three branches?

Cheers

Paul

2017-11-08  Paul Thomas  <pa...@gcc.gnu.org>

    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-08  Paul Thomas  <pa...@gcc.gnu.org>

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

Index: gcc/fortran/check.c
===================================================================
*** gcc/fortran/check.c (revision 254440)
--- gcc/fortran/check.c (working copy)
*************** less_than_bitsize2 (const char *arg1, gf
*** 427,441 ****
  /* Make sure two expressions have the same type.  */
  
  static bool
! same_type_check (gfc_expr *e, int n, gfc_expr *f, int m)
  {
    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 (gfc_compare_types (ets, fts))
      return true;
--- 427,448 ----
  /* Make sure two expressions have the same type.  */
  
  static bool
! 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 (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;
*************** gfc_check_associated (gfc_expr *pointer,
*** 1002,1008 ****
      }
  
    t = true;
!   if (!same_type_check (pointer, 0, target, 1))
      t = false;
    if (!rank_check (target, 0, pointer->rank))
      t = false;
--- 1009,1015 ----
      }
  
    t = true;
!   if (!same_type_check (pointer, 0, target, 1, true))
      t = false;
    if (!rank_check (target, 0, pointer->rank))
      t = false;
Index: gcc/testsuite/gfortran.dg/pr78619.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pr78619.f90       (nonexistent)
--- gcc/testsuite/gfortran.dg/pr78619.f90       (working copy)
***************
*** 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.fort...@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 }