[Patch, Fortran] PR 41733: Proc-pointer conformance checks: Elemental-proc-ptr => non-elemental-proc

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

here is a patch which adds checks for the ELEMENTAL attribute in
procedure pointer assignments and dummy procedures. For details see
the PR and the c.l.f. thread mentioned therein. For the PURE
attribute, we already had a check, which I moved and reformulated (so
that it is applicable also to proc-ptr assignments).

The patch was regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus



2011-09-21  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-21  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.

Index: gcc/testsuite/gfortran.dg/impure_actual_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/impure_actual_1.f90	(revision 179017)
+++ gcc/testsuite/gfortran.dg/impure_actual_1.f90	(working copy)
@@ -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" } }
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 179017)
+++ gcc/fortran/interface.c	(working copy)
@@ -1087,12 +1087,12 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_s
 /* '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,19 +1115,34 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol
       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;
+	}
     }
 
   if (s1->attr.if_source == IFSRC_UNKNOWN
@@ -1166,7 +1181,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol
 	    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, gf
 	  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
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 179017)
+++ gcc/fortran/expr.c	(working copy)
@@ -3432,7 +3432,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
 		     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_ex
 			      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

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

! { 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" } }