diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 23dce579c12..223f88c6266 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2009-08-27 Janus Weil + + PR fortran/40869 + * expr.c (gfc_check_pointer_assign): Enable interface check for + pointer assignments involving procedure pointer components. + * gfortran.h (gfc_compare_interfaces): Modified prototype. + * interface.c (gfc_compare_interfaces): Add argument 'name2', to be + used instead of s2->name. Don't rely on the proc_pointer attribute, + but instead on the flags handed to this function. + (check_interface1,compare_parameter): Add argument for + gfc_compare_interfaces. + * resolve.c (check_generic_tbp_ambiguity): Ditto. + 2009-08-27 Daniel Kraft PR fortran/37425 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 57582a9fc47..970c25939cf 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3149,6 +3149,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (proc_pointer) { char err[200]; + gfc_symbol *s1,*s2; + gfc_component *comp; + const char *name; + attr = gfc_expr_attr (rvalue); if (!((rvalue->expr_type == EXPR_NULL) || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer) @@ -3208,22 +3212,35 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } } - /* TODO: Enable interface check for PPCs. */ - if (gfc_is_proc_ptr_comp (rvalue, NULL)) - return SUCCESS; - if ((rvalue->expr_type == EXPR_VARIABLE - && !gfc_compare_interfaces (lvalue->symtree->n.sym, - rvalue->symtree->n.sym, 0, 1, err, - sizeof(err))) - || (rvalue->expr_type == EXPR_FUNCTION - && !gfc_compare_interfaces (lvalue->symtree->n.sym, - rvalue->symtree->n.sym->result, 0, 1, - err, sizeof(err)))) + if (gfc_is_proc_ptr_comp (lvalue, &comp)) + s1 = comp->ts.interface; + else + s1 = lvalue->symtree->n.sym; + + if (gfc_is_proc_ptr_comp (rvalue, &comp)) + { + s2 = comp->ts.interface; + name = comp->name; + } + else if (rvalue->expr_type == EXPR_FUNCTION) + { + s2 = rvalue->symtree->n.sym->result; + name = rvalue->symtree->n.sym->result->name; + } + else + { + s2 = rvalue->symtree->n.sym; + name = rvalue->symtree->n.sym->name; + } + + if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1, + err, sizeof(err))) { gfc_error ("Interface mismatch in procedure pointer assignment " "at %L: %s", &rvalue->where, err); return FAILURE; } + return SUCCESS; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 16c596bd753..514cc808417 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2650,7 +2650,8 @@ gfc_try gfc_ref_dimen_size (gfc_array_ref *, int dimen, mpz_t *); void gfc_free_interface (gfc_interface *); int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); int gfc_compare_types (gfc_typespec *, gfc_typespec *); -int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int, int, char *, int); +int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int, + char *, int); void gfc_check_interfaces (gfc_namespace *); void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 6d16fe10f42..132f10a47c7 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -943,31 +943,31 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) required to match, which is not the case for ambiguity checks.*/ int -gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag, - int intent_flag, char *errmsg, int err_len) +gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, + int generic_flag, int intent_flag, + char *errmsg, int err_len) { gfc_formal_arglist *f1, *f2; if (s1->attr.function && (s2->attr.subroutine || (!s2->attr.function && s2->ts.type == BT_UNKNOWN - && gfc_get_default_type (s2->name, s2->ns)->type == BT_UNKNOWN))) + && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN))) { if (errmsg != NULL) - snprintf (errmsg, err_len, "'%s' is not a function", s2->name); + snprintf (errmsg, err_len, "'%s' is not a function", name2); return 0; } if (s1->attr.subroutine && s2->attr.function) { if (errmsg != NULL) - snprintf (errmsg, err_len, "'%s' is not a subroutine", s2->name); + snprintf (errmsg, err_len, "'%s' is not a subroutine", name2); return 0; } /* If the arguments are functions, check type and kind (only for dummy procedures and procedure pointer assignments). */ - if ((s1->attr.dummy || s1->attr.proc_pointer) - && s1->attr.function && s2->attr.function) + if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function) { if (s1->ts.type == BT_UNKNOWN) return 1; @@ -975,7 +975,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag, { if (errmsg != NULL) snprintf (errmsg, err_len, "Type/kind mismatch in return value " - "of '%s'", s2->name); + "of '%s'", name2); return 0; } } @@ -1012,7 +1012,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag, { if (errmsg != NULL) snprintf (errmsg, err_len, "'%s' has the wrong number of " - "arguments", s2->name); + "arguments", name2); return 0; } @@ -1120,7 +1120,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, if (p->sym->name == q->sym->name && p->sym->module == q->sym->module) continue; - if (gfc_compare_interfaces (p->sym, q->sym, generic_flag, 0, NULL, 0)) + if (gfc_compare_interfaces (p->sym, q->sym, NULL, generic_flag, 0, + NULL, 0)) { if (referenced) { @@ -1403,7 +1404,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } - if (!gfc_compare_interfaces (formal, act_sym, 0, 1, err, + if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err, sizeof(err))) { if (where) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e1c931ba0ff..f10a4123a6b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8851,7 +8851,7 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, } /* Compare the interfaces. */ - if (gfc_compare_interfaces (sym1, sym2, 1, 0, NULL, 0)) + if (gfc_compare_interfaces (sym1, sym2, NULL, 1, 0, NULL, 0)) { gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous", sym1->name, sym2->name, generic_name, &where); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c9979cae52f..3b29417a5f4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-08-27 Janus Weil + + PR fortran/40869 + * gfortran.dg/proc_ptr_comp_20.f90: New. + 2009-08-27 Janne Blomqvist PR libfortran/39667 diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 new file mode 100644 index 00000000000..d4773686090 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR 40869: [F03] PPC assignment checking +! +! Contributed by Janus Weil + +implicit none + +interface func + procedure f1,f2 ! { dg-error "Ambiguous interfaces" } +end interface + +interface operator(.op.) + procedure f1,f2 ! { dg-error "Ambiguous interfaces" } +end interface + +type :: t1 + procedure(integer), pointer, nopass :: ppc +end type + +type :: t2 + procedure(real), pointer, nopass :: ppc +end type + +type(t1) :: o1 +type(t2) :: o2 +procedure(logical),pointer :: pp1 +procedure(complex),pointer :: pp2 + +pp1 => pp2 ! { dg-error "Type/kind mismatch" } +pp2 => o2%ppc ! { dg-error "Type/kind mismatch" } + +o1%ppc => pp1 ! { dg-error "Type/kind mismatch" } +o1%ppc => o2%ppc ! { dg-error "Type/kind mismatch" } + +contains + + real function f1(a,b) + real,intent(in) :: a,b + f1 = a + b + end function + + integer function f2(a,b) + real,intent(in) :: a,b + f2 = a - b + end function + +end +