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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f138fda32c3b010d5d620cf4f16023d4fc2e917f..02ee59319c3192d9b54a766b0c6d019f9bcaa15a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+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.

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 3c09a2a99c4b11a7b459170e25860977900be76f..813a99d037b836b9176496f78e8b9eba14dafb74 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/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

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 7962403a5051aab203070329be377db8d63ad141..7cbe16319b4d63e33cbc0db6f341cf9ef1261818 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/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

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0c9ffed25857db8204931c83bbafe97b633b9d0e..10aff8268a2f0010e11267761091624902429572 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/impure_actual_1.f90 b/gcc/testsuite/gfortran.dg/impure_actual_1.f90
index 1f22c11806940eb287c3bb559f3a17afbee2b1d1..12f3375bf0a505646b58316a3241a3f7f065e73e 100644 (file)
--- a/gcc/testsuite/gfortran.dg/impure_actual_1.f90
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_32.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_32.f90
new file mode 100644 (file)
index 0000000..5664dde
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_32.f90
@@ -0,0 +1,15 @@
+! { 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

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_33.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_33.f90
new file mode 100644 (file)
index 0000000..803d90e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_33.f90
@@ -0,0 +1,32 @@
+! { 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