diff options
Diffstat (limited to 'gcc/fortran/primary.c')
| -rw-r--r-- | gcc/fortran/primary.c | 31 |
1 files changed, 30 insertions, 1 deletions
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index cb6f988..cab8f82 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2358,6 +2358,30 @@ check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym) } +/* Procedure pointer as function result: Replace the function symbol by the + auto-generated hidden result variable named "ppr@". */ + +static gfc_try +replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st) +{ + /* Check for procedure pointer result variable. */ + if ((*sym)->attr.function && !(*sym)->attr.external + && (*sym)->result && (*sym)->result != *sym + && (*sym)->result->attr.proc_pointer + && (*sym) == gfc_current_ns->proc_name + && (*sym) == (*sym)->result->ns->proc_name + && strcmp ("ppr@", (*sym)->result->name) == 0) + { + /* Automatic replacement with "hidden" result variable. */ + (*sym)->result->attr.referenced = (*sym)->attr.referenced; + *sym = (*sym)->result; + *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name); + return SUCCESS; + } + return FAILURE; +} + + /* Matches a variable name followed by anything that might follow it-- array reference, argument list of a function, etc. */ @@ -2394,6 +2418,8 @@ gfc_match_rvalue (gfc_expr **result) e = NULL; where = gfc_current_locus; + replace_hidden_procptr_result (&sym, &symtree); + /* If this is an implicit do loop index and implicitly typed, it should not be host associated. */ m = check_for_implicit_index (&symtree, &sym); @@ -2583,6 +2609,8 @@ gfc_match_rvalue (gfc_expr **result) gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */ sym = symtree->n.sym; + replace_hidden_procptr_result (&sym, &symtree); + e = gfc_get_expr (); e->symtree = symtree; e->expr_type = EXPR_FUNCTION; @@ -2912,7 +2940,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) break; } - if (sym->attr.proc_pointer) + if (sym->attr.proc_pointer + || replace_hidden_procptr_result (&sym, &st) == SUCCESS) break; /* Fall through to error */ |