re PR fortran/70260 (ICE: gimplification failed)

2018-11-18  Thomas Koenig  <tkoenig@gcc.gnu.org>

    PR fortran/70260
    * expr.c (gfc_check_assign): Reject assigning to an external
    symbol.
    (gfc_check_pointer_assign): Add suppress_type_test
    argument. Insert line after if. A non-proc pointer can not point
    to a constant.  Only check types if suppress_type_test is false.
    * gfortran.h (gfc_check_pointer_assign): Add optional
    suppress_type_test argument.
    * resolve.c (gfc_resolve_code):  Move up gfc_check_pointer_assign
    and give it the extra argument.
    (resolve_fl_procedure): Set error on value for a function with
    an inizializer.

2018-11-18  Thomas Koenig  <tkoenig@gcc.gnu.org>

    PR fortran/70260
    * gfortran.dg/proc_ptr_result_5.f90:  Add dg-error directive.
    * gfortran.dg/protected_4.f90: Split line to allow for extra error.
    * gfortran.dg/protected_6.f90: Likewise.
    * gfortran.dg/assign_11.f90: New test.
    * gfortran.dg/pointer_assign_12.f90: New test.

From-SVN: r266248

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2868db9f6a02ade91a7e9c1452a4fb1eb9fd7aae..83920ab8f6d55a957e725dd4453daa7f7f7fba53 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2018-11-18  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/70260
+       * expr.c (gfc_check_assign): Reject assigning to an external
+       symbol.
+       (gfc_check_pointer_assign): Add suppress_type_test
+       argument. Insert line after if. A non-proc pointer can not point
+       to a constant.  Only check types if suppress_type_test is false.
+       * gfortran.h (gfc_check_pointer_assign): Add optional
+       suppress_type_test argument.
+       * resolve.c (gfc_resolve_code):  Move up gfc_check_pointer_assign
+       and give it the extra argument.
+       (resolve_fl_procedure): Set error on value for a function with
+       an inizializer.
+
 2018-11-15  David Malcolm  <dmalcolm@redhat.com>
 
        PR other/19165

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 1d1d48d0b813d096e5f3eb7117460334f83b4142..388fddab4729205ac897aa0da5b863ae24e8f950 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3507,6 +3507,18 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
          return false;
        }
     }
+  else
+    {
+      /* Reject assigning to an external symbol.  For initializers, this
+        was already done before, in resolve_fl_procedure.  */
+      if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external
+         && sym->attr.proc != PROC_MODULE && !rvalue->error)
+       {
+         gfc_error ("Illegal assignment to external procedure at %L",
+                    &lvalue->where);
+         return false;
+       }
+    }
 
   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
     {
@@ -3643,7 +3655,8 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
    NULLIFY statement.  */
 
 bool
-gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
+gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
+                         bool suppress_type_test)
 {
   symbol_attribute attr, lhs_attr;
   gfc_ref *ref;
@@ -3771,6 +3784,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
                     &rvalue->where);
          return false;
        }
+
       if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer)
        {
          /* Check for intrinsics.  */
@@ -3967,6 +3981,16 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 
       return true;
     }
+  else
+    {
+      /* A non-proc pointer cannot point to a constant.  */
+      if (rvalue->expr_type == EXPR_CONSTANT)
+       {
+         gfc_error_now ("Pointer assignment target cannot be a constant at %L",
+                        &rvalue->where);
+         return false;
+       }
+    }
 
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
@@ -3980,7 +4004,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
                   "polymorphic, or of a type with the BIND or SEQUENCE "
                   "attribute, to be compatible with an unlimited "
                   "polymorphic target", &lvalue->where);
-      else
+      else if (!suppress_type_test)
        gfc_error ("Different types in pointer assignment at %L; "
                   "attempted assignment of %s to %s", &lvalue->where,
                   gfc_typename (&rvalue->ts),

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 128f5746aa9cdc6bd51324222cd9c51258961d3f..530e00794fba429616b2c6b8cbf4c6719e37a50d 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3219,7 +3219,8 @@ int gfc_kind_max (gfc_expr *, gfc_expr *);
 
 bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3;
 bool gfc_check_assign (gfc_expr *, gfc_expr *, int, bool c = true);
-bool gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
+bool gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
+  bool suppres_type_test = false);
 bool gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *);
 
 gfc_expr *gfc_build_default_init_expr (gfc_typespec *, locus *);

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ba9623497d2f6f99697fcc3893858acd4731f04b..df7c6cb13ac78a7afedb6399d2bc9ae71d9623d0 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11420,11 +11420,12 @@ start:
              t = gfc_check_vardef_context (e, false, false, false,
                                            _("pointer assignment"));
            gfc_free_expr (e);
+
+           t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t;
+
            if (!t)
              break;
 
-           gfc_check_pointer_assign (code->expr1, code->expr2);
-
            /* Assigning a class object always is a regular assign.  */
            if (code->expr2->ts.type == BT_CLASS
                && code->expr1->ts.type == BT_CLASS
@@ -12540,6 +12541,9 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
     {
       gfc_error ("Function %qs at %L cannot have an initializer",
                 sym->name, &sym->declared_at);
+
+      /* Make sure no second error is issued for this.  */
+      sym->value->error = 1;
       return false;
     }
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 30386c6fa8949c999316213ca22d593e29353ccb..571618623e7fd6ab11d7059e76f09d430c626c8f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2018-11-18  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/70260
+       * gfortran.dg/proc_ptr_result_5.f90:  Add dg-error directive.
+       * gfortran.dg/protected_4.f90: Split line to allow for extra error.
+       * gfortran.dg/protected_6.f90: Likewise.
+       * gfortran.dg/assign_11.f90: New test.
+       * gfortran.dg/pointer_assign_12.f90: New test.
+
 2018-11-17  Jakub Jelinek  <jakub@redhat.com>
 
        PR tree-optimization/87546

diff --git a/gcc/testsuite/gfortran.dg/assign_11.f90 b/gcc/testsuite/gfortran.dg/assign_11.f90
new file mode 100644 (file)
index 0000000..81c0286
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assign_11.f90
@@ -0,0 +1,9 @@
+! { dg-do compile }
+! PR 70260 - this used to ICE
+! Original test case by Gernard Steinmetz
+subroutine s (f)
+   integer, external :: f, g
+   integer :: h
+   g = f(2) ! { dg-error "Illegal assignment to external procedure" }
+   h = g(2)
+end

diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_12.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_12.f90
new file mode 100644 (file)
index 0000000..d2ed3d3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_assign_12.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! PR 70260 - this used to ICE
+! Original test case by Gehard Steinmetz
+module m
+   interface gkind
+      procedure g
+   end interface
+contains
+   integer function g()
+      g => 1 ! { dg-error "Pointer assignment target cannot be a constant" }
+   end
+   subroutine f(x)
+      character(kind=kind(gkind())) :: x
+   end
+end

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90
index 121fd4d87f9d1a67b87a8d83d93ab6941a2cb41c..36afedf58c7c8a40b1d65ce1a6232a4158e32446 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90
@@ -14,6 +14,6 @@ contains
      logical(1) function f()
      end function
    end interface
-   f = .true._1
+   f = .true._1 ! { dg-error "Illegal assignment" }
  end function f
 end program test

diff --git a/gcc/testsuite/gfortran.dg/protected_4.f90 b/gcc/testsuite/gfortran.dg/protected_4.f90
index 44ca6ac13923bff9e818dc8c8f24cf16ce23c8e4..46e508522b7b9618c8299609bd169497bb30ea88 100644 (file)
--- a/gcc/testsuite/gfortran.dg/protected_4.f90
+++ b/gcc/testsuite/gfortran.dg/protected_4.f90
@@ -26,7 +26,8 @@ program main
   a = 43       ! { dg-error "variable definition context" }
   ap => null() ! { dg-error "pointer association context" }
   nullify(ap)  ! { dg-error "pointer association context" }
-  ap => at     ! { dg-error "pointer association context" }
+  ap => &      ! { dg-error "pointer association context" }
+       & at    ! { dg-error "Pointer assignment target has PROTECTED attribute" }
   ap = 3       ! OK
   allocate(ap) ! { dg-error "pointer association context" }
   ap = 73      ! OK

diff --git a/gcc/testsuite/gfortran.dg/protected_6.f90 b/gcc/testsuite/gfortran.dg/protected_6.f90
index 9df9ef47a105633d5389280d4555e591cd056d24..b386dcf5f1bcf39dcab6430cb5644f084f35e818 100644 (file)
--- a/gcc/testsuite/gfortran.dg/protected_6.f90
+++ b/gcc/testsuite/gfortran.dg/protected_6.f90
@@ -22,7 +22,8 @@ program main
   a = 43       ! { dg-error "variable definition context" }
   ap => null() ! { dg-error "pointer association context" }
   nullify(ap)  ! { dg-error "pointer association context" }
-  ap => at     ! { dg-error "pointer association context" }
+  ap => &      ! { dg-error "pointer association context" }
+       & at    ! { dg-error "Pointer assignment target has PROTECTED attribute" }
   ap = 3       ! OK
   allocate(ap) ! { dg-error "pointer association context" }
   ap = 73      ! OK