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

gcc/fortran/ChangeLog

+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

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),

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 *);

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;
     }
 

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/assign_11.f90

+! { 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

gcc/testsuite/gfortran.dg/pointer_assign_12.f90

+! { 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

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

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

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