re PR fortran/41733 (Proc-pointer conformance checks: Elemental-proc-ptr => non-elemental-proc)

2011-09-22  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41733
	* expr.c (gfc_check_pointer_assign): Check for nonintrinsic elemental
	procedures.
	* interface.c (gfc_compare_interfaces): Rename 'intent_flag'. Check
	for PURE and ELEMENTAL attributes.
	(compare_actual_formal): Remove pureness check here.


2011-09-22  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41733
	* gfortran.dg/impure_actual_1.f90: Modified error message.
	* gfortran.dg/proc_ptr_32.f90: New.
	* gfortran.dg/proc_ptr_33.f90: New.

From-SVN: r179080

gcc/fortran/ChangeLog

+2011-09-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41733
+	* expr.c (gfc_check_pointer_assign): Check for nonintrinsic elemental
+	procedures.
+	* interface.c (gfc_compare_interfaces): Rename 'intent_flag'. Check
+	for PURE and ELEMENTAL attributes.
+	(compare_actual_formal): Remove pureness check here.
+
 2011-09-20  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	* check.c (gfc_check_c_sizeof): Remove redundant word.

gcc/fortran/expr.c

@@ -3432,7 +3432,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 		     rvalue->symtree->name, &rvalue->where);
 	  return FAILURE;
 	}
-      /* Check for C727.  */
+      /* Check for F08:C729.  */
       if (attr.flavor == FL_PROCEDURE)
 	{
 	  if (attr.proc == PROC_ST_FUNCTION)
@@ -3448,6 +3448,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 			      rvalue->symtree->name, &rvalue->where) == FAILURE)
 	    return FAILURE;
 	}
+      /* Check for F08:C730.  */
+      if (attr.elemental && !attr.intrinsic)
+	{
+	  gfc_error ("Nonintrinsic elemental procedure '%s' is invalid "
+		     "in procedure pointer assigment at %L",
+		     rvalue->symtree->name, &rvalue->where);
+	  return FAILURE;
+	}
 
       /* Ensure that the calling convention is the same. As other attributes
 	 such as DLLEXPORT may differ, one explicitly only tests for the

gcc/fortran/interface.c

@@ -1087,12 +1087,12 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
 /* 'Compare' two formal interfaces associated with a pair of symbols.
    We return nonzero if there exists an actual argument list that
    would be ambiguous between the two interfaces, zero otherwise.
-   'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
+   'strict_flag' specifies whether all the characteristics are
    required to match, which is not the case for ambiguity checks.*/
 
 int
 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
-			int generic_flag, int intent_flag,
+			int generic_flag, int strict_flag,
 			char *errmsg, int err_len)
 {
   gfc_formal_arglist *f1, *f2;
@@ -1115,17 +1115,32 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
       return 0;
     }
 
-  /* If the arguments are functions, check type and kind
-     (only for dummy procedures and procedure pointer assignments).  */
-  if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
+  /* Do strict checks on all characteristics
+     (for dummy procedures and procedure pointer assignments).  */
+  if (!generic_flag && strict_flag)
     {
-      if (s1->ts.type == BT_UNKNOWN)
-	return 1;
-      if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
+      if (s1->attr.function && s2->attr.function)
 	{
-	  if (errmsg != NULL)
-	    snprintf (errmsg, err_len, "Type/kind mismatch in return value "
-		      "of '%s'", name2);
+	  /* If both are functions, check type and kind.  */
+	  if (s1->ts.type == BT_UNKNOWN)
+	    return 1;
+	  if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
+	    {
+	      if (errmsg != NULL)
+		snprintf (errmsg, err_len, "Type/kind mismatch in return value "
+			  "of '%s'", name2);
+	      return 0;
+	    }
+	}
+
+      if (s1->attr.pure && !s2->attr.pure)
+	{
+	  snprintf (errmsg, err_len, "Mismatch in PURE attribute");
+	  return 0;
+	}
+      if (s1->attr.elemental && !s2->attr.elemental)
+	{
+	  snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
 	  return 0;
 	}
     }
@@ -1166,7 +1181,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 	    return 0;
 	  }
 
-	if (intent_flag)
+	if (strict_flag)
 	  {
 	    /* Check all characteristics.  */
 	    if (check_dummy_characteristics (f1->sym, f2->sym,
@@ -2276,16 +2291,6 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return 0;
 	}
 
-      if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
-	  && a->expr->ts.type == BT_PROCEDURE
-	  && !a->expr->symtree->n.sym->attr.pure)
-	{
-	  if (where)
-	    gfc_error ("Expected a PURE procedure for argument '%s' at %L",
-		       f->sym->name, &a->expr->where);
-	  return 0;
-	}
-
       if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && a->expr->symtree->n.sym->as

gcc/testsuite/ChangeLog

+2011-09-22  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/41733
+	* gfortran.dg/impure_actual_1.f90: Modified error message.
+	* gfortran.dg/proc_ptr_32.f90: New.
+	* gfortran.dg/proc_ptr_33.f90: New.
+
 2011-09-22  Ira Rosen  <ira.rosen@linaro.org>
 
 	PR tree-optimization/50451

gcc/testsuite/gfortran.dg/impure_actual_1.f90

@@ -18,7 +18,7 @@ CONTAINS
  END FUNCTION J
 END MODULE M1
 USE M1
- write(6,*) J(L) ! { dg-error "Expected a PURE procedure for argument" }
+ write(6,*) J(L) ! { dg-error "Mismatch in PURE attribute" }
 END
 
 ! { dg-final { cleanup-modules "m1" } }

gcc/testsuite/gfortran.dg/proc_ptr_32.f90

+! { dg-do compile }
+!
+! PR 41733: Proc-pointer conformance checks: Elemental-proc-ptr => non-elemental-procedure
+!
+! Contributed by James Van Buskirk
+
+  implicit none
+  procedure(my_dcos), pointer :: f
+  f => my_dcos           ! { dg-error "invalid in procedure pointer assigment" }
+contains
+  real elemental function my_dcos(x)
+    real, intent(in) :: x
+    my_dcos = cos(x)
+  end function
+end

gcc/testsuite/gfortran.dg/proc_ptr_33.f90

+! { dg-do compile }
+!
+! PR 41733: Proc-pointer conformance checks: Elemental-proc-ptr => non-elemental-procedure
+!
+! Contributed by James Van Buskirk
+
+module funcs
+   implicit none
+   abstract interface
+      real elemental function fun(x)
+         real, intent(in) :: x
+      end function
+   end interface
+contains
+  function my_dcos(x)
+    real, intent(in) :: x
+    real :: my_dcos
+    my_dcos = cos(x)
+  end function
+end module
+
+program start
+   use funcs
+   implicit none
+   procedure(fun), pointer :: f
+   real x(3)
+   x = [1,2,3]
+   f => my_dcos     ! { dg-error "Mismatch in PURE attribute" }
+   write(*,*) f(x)
+end program start 
+
+! { dg-final { cleanup-modules "funcs" } }
\ No newline at end of file