diff options
| author | Janus Weil <janus@gcc.gnu.org> | 2009-11-26 20:01:02 +0100 |
|---|---|---|
| committer | Janus Weil <janus@gcc.gnu.org> | 2009-11-26 20:01:02 +0100 |
| commit | 2d71b918d494015f467023d3ee4596b3c887d4b8 (patch) | |
| tree | 514b39dc8ae626e9d48ee49c59406a249bd6050c /gcc/fortran/primary.c | |
| parent | 90dcfecb47a75e10277dcdd44aeb39267d251f36 (diff) | |
| download | gcc-2d71b918d494015f467023d3ee4596b3c887d4b8.zip gcc-2d71b918d494015f467023d3ee4596b3c887d4b8.tar.gz gcc-2d71b918d494015f467023d3ee4596b3c887d4b8.tar.bz2 | |
re PR fortran/42048 ([F03] Erroneous syntax error message on TBP call)
2009-11-26 Janus Weil <janus@gcc.gnu.org>
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-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/42048
PR fortran/42167
* gfortran.dg/select_type_10.f03: New test case.
* gfortran.dg/typebound_call_11.f03: Extended test case.
From-SVN: r154679
Diffstat (limited to 'gcc/fortran/primary.c')
| -rw-r--r-- | gcc/fortran/primary.c | 32 |
1 files changed, 22 insertions, 10 deletions
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index c0777c4..113729f 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 |