diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2ca0e243122..0572b05868b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2009-11-26 Janus Weil + + PR fortran/42048 + PR fortran/42167 + * gfortran.h (gfc_is_function_return_value): New prototype. + * match.c (gfc_match_call): Use new function + 'gfc_is_function_return_value'. + * primary.c (gfc_is_function_return_value): New function to check if a + symbol is the return value of an encompassing function. + (match_actual_arg,gfc_match_rvalue,match_variable): Use new function + 'gfc_is_function_return_value'. + * resolve.c (resolve_common_blocks,resolve_actual_arglist): Ditto. + 2009-11-25 Jakub Jelinek PR fortran/42162 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 74a31d2661c..cc3ccf5527c 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2751,6 +2751,7 @@ symbol_attribute gfc_expr_attr (gfc_expr *); match gfc_match_rvalue (gfc_expr **); match gfc_match_varspec (gfc_expr*, int, bool, bool); int gfc_check_digit (char, int); +bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *); /* trans.c */ void gfc_generate_code (gfc_namespace *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 13f68ab8c65..f6650e78b52 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2975,7 +2975,8 @@ gfc_match_call (void) /* If this is a variable of derived-type, it probably starts a type-bound procedure call. */ - if ((sym->attr.flavor != FL_PROCEDURE || sym == gfc_current_ns->proc_name) + if ((sym->attr.flavor != FL_PROCEDURE + || gfc_is_function_return_value (sym, gfc_current_ns)) && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) return match_typebound_call (st); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index c0777c48b85..113729fb059 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1347,6 +1347,25 @@ gfc_match_literal_constant (gfc_expr **result, int signflag) } +/* This checks if a symbol is the return value of an encompassing function. + Function nesting can be maximally two levels deep, but we may have + additional local namespaces like BLOCK etc. */ + +bool +gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns) +{ + if (!sym->attr.function || (sym->result != sym)) + return false; + while (ns) + { + if (ns->proc_name == sym) + return true; + ns = ns->parent; + } + return false; +} + + /* Match a single actual argument value. An actual argument is usually an expression, but can also be a procedure name. If the argument is a single name, it is not always possible to tell @@ -1415,9 +1434,7 @@ match_actual_arg (gfc_expr **result) is being defined, then we have a variable. */ if (sym->attr.function && sym->result == sym) { - if (gfc_current_ns->proc_name == sym - || (gfc_current_ns->parent != NULL - && gfc_current_ns->parent->proc_name == sym)) + if (gfc_is_function_return_value (sym, gfc_current_ns)) break; if (sym->attr.entry @@ -2521,9 +2538,7 @@ gfc_match_rvalue (gfc_expr **result) return MATCH_ERROR; } - if (gfc_current_ns->proc_name == sym - || (gfc_current_ns->parent != NULL - && gfc_current_ns->parent->proc_name == sym)) + if (gfc_is_function_return_value (sym, gfc_current_ns)) goto variable; if (sym->attr.entry @@ -2998,10 +3013,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) if (sym->attr.function && !sym->attr.external && sym->result == sym - && ((sym == gfc_current_ns->proc_name - && sym == gfc_current_ns->proc_name->result) - || (gfc_current_ns->parent - && sym == gfc_current_ns->parent->proc_name->result) + && (gfc_is_function_return_value (sym, gfc_current_ns) || (sym->attr.entry && sym->ns == gfc_current_ns) || (sym->attr.entry diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 740679edd2d..5048f251528 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -776,7 +776,7 @@ resolve_common_blocks (gfc_symtree *common_root) gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure", sym->name, &common_root->n.common->where); else if (sym->attr.result - ||(sym->attr.function && gfc_current_ns->proc_name == sym)) + || gfc_is_function_return_value (sym, gfc_current_ns)) gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L " "that is also a function result", sym->name, &common_root->n.common->where); @@ -1400,10 +1400,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, /* If the symbol is the function that names the current (or parent) scope, then we really have a variable reference. */ - if (sym->attr.function && sym->result == sym - && (sym->ns->proc_name == sym - || (sym->ns->parent != NULL - && sym->ns->parent->proc_name == sym))) + if (gfc_is_function_return_value (sym, sym->ns)) goto got_variable; /* If all else fails, see if we have a specific intrinsic. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 73f39a7c29d..b9893dad10f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2009-11-26 Janus Weil + + PR fortran/42048 + PR fortran/42167 + * gfortran.dg/select_type_10.f03: New test case. + * gfortran.dg/typebound_call_11.f03: Extended test case. + 2009-11-26 Michael Matz PR tree-optimization/41905 diff --git a/gcc/testsuite/gfortran.dg/select_type_10.f03 b/gcc/testsuite/gfortran.dg/select_type_10.f03 new file mode 100644 index 00000000000..217d72a8371 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_10.f03 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR 42167: [OOP] SELECT TYPE with function return value +! +! Contributed by Damian Rouson + +module bar_module + + implicit none + type :: bar + real ,dimension(:) ,allocatable :: f + contains + procedure :: total + end type + +contains + + function total(lhs,rhs) + class(bar) ,intent(in) :: lhs + class(bar) ,intent(in) :: rhs + class(bar) ,pointer :: total + select type(rhs) + type is (bar) + allocate(bar :: total) + select type(total) + type is (bar) + total%f = lhs%f + rhs%f + end select + end select + end function + +end module + +! { dg-final { cleanup-modules "bar_module" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_call_11.f03 b/gcc/testsuite/gfortran.dg/typebound_call_11.f03 index 14f3232b440..8d7b8f06178 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_11.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_11.f03 @@ -35,6 +35,14 @@ contains call new%mesh%new_grid() end function + type(field) function new_field3() + call g() + contains + subroutine g() + call new_field3%mesh%new_grid() + end subroutine g + end function new_field3 + end module ! { dg-final { cleanup-modules "grid_module field_module" } }