From 58c1ae3667e753a492bfa224ff9194b9e2ae01ff Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Thu, 22 Sep 2011 11:32:11 +0200 Subject: re PR fortran/41733 (Proc-pointer conformance checks: Elemental-proc-ptr => non-elemental-proc) 2011-09-22 Janus Weil 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 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/interface.c | 49 +++++++++++++++++++++++++++---------------------- 1 file changed, 27 insertions(+), 22 deletions(-) (limited to 'gcc/fortran/interface.c') diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 7962403..7cbe163 100644 --- 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 -- cgit v1.1