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 <ja...@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 <ja...@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" } }
