diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 24 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 96 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 31 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 69 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 17 |
7 files changed, 221 insertions, 40 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c0f12e6..d24afdf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2009-04-09 Janus Weil <janus@gcc.gnu.org> + + PR fortran/36704 + * decl.c (add_hidden_procptr_result): New function for handling + procedure pointer return values by adding a hidden result variable. + (variable_decl,match_procedure_decl,gfc_match_function_decl, + gfc_match_subroutine,gfc_match_end,attr_decl1): Handle procedure pointer + return values. + * parse.c (parse_interface): Add EXTERNAL attribute only after + FUNCTION/SUBROUTINE declaration is complete. + * primary.c (replace_hidden_procptr_result): New function for replacing + function symbol by hidden result variable. + (gfc_match_rvalue,match_variable): Replace symbol by hidden result + variable. + * resolve.c (resolve_contained_fntype,resolve_function,resolve_variable, + resolve_symbol): Allow for procedure pointer function results. + (resolve_fl_procedure): Conflict detection moved here from + 'check_conflict'. + * symbol.c (gfc_check_function_type): Allow for procedure pointer + function results. + (check_conflict): Move some conflict detection to resolution stage. + * trans-types.c (gfc_sym_type,gfc_get_function_type): Handle hidden + result variables. + 2009-04-08 Jakub Jelinek <jakub@redhat.com> * trans-types.c (gfc_init_types): Ensure gfc_integer_types doesn't diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 2e54147..27fe8ff 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1667,6 +1667,17 @@ variable_decl (int elem) } } + /* Procedure pointer as function result. */ + if (gfc_current_state () == COMP_FUNCTION + && strcmp ("ppr@", gfc_current_block ()->name) == 0 + && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0) + strcpy (name, "ppr@"); + + if (gfc_current_state () == COMP_FUNCTION + && strcmp (name, gfc_current_block ()->name) == 0 + && gfc_current_block ()->result + && strcmp ("ppr@", gfc_current_block ()->result->name) == 0) + strcpy (name, "ppr@"); /* OK, we've successfully matched the declaration. Now put the symbol in the current namespace, because it might be used in the @@ -4069,6 +4080,66 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) } +/* Procedure pointer return value without RESULT statement: + Add "hidden" result variable named "ppr@". */ + +static gfc_try +add_hidden_procptr_result (gfc_symbol *sym) +{ + bool case1,case2; + + if (gfc_notification_std (GFC_STD_F2003) == ERROR) + return FAILURE; + + /* First usage case: PROCEDURE and EXTERNAL statements. */ + case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block () + && strcmp (gfc_current_block ()->name, sym->name) == 0 + && sym->attr.external; + /* Second usage case: INTERFACE statements. */ + case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_FUNCTION + && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0; + + if (case1 || case2) + { + gfc_symtree *stree; + if (case1) + gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree); + else if (case2) + gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree); + sym->result = stree->n.sym; + + sym->result->attr.proc_pointer = sym->attr.proc_pointer; + sym->result->attr.pointer = sym->attr.pointer; + sym->result->attr.external = sym->attr.external; + sym->result->attr.referenced = sym->attr.referenced; + sym->attr.proc_pointer = 0; + sym->attr.pointer = 0; + sym->attr.external = 0; + if (sym->result->attr.external && sym->result->attr.pointer) + { + sym->result->attr.pointer = 0; + sym->result->attr.proc_pointer = 1; + } + + return gfc_add_result (&sym->result->attr, sym->result->name, NULL); + } + /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */ + else if (sym->attr.function && !sym->attr.external && sym->attr.pointer + && sym->result && sym->result != sym && sym->result->attr.external + && sym == gfc_current_ns->proc_name + && sym == sym->result->ns->proc_name + && strcmp ("ppr@", sym->result->name) == 0) + { + sym->result->attr.proc_pointer = 1; + sym->attr.pointer = 0; + return SUCCESS; + } + else + return FAILURE; +} + + /* Match a PROCEDURE declaration (R1211). */ static match @@ -4201,6 +4272,10 @@ got_ts: if (gfc_add_external (&sym->attr, NULL) == FAILURE) return MATCH_ERROR; + + if (add_hidden_procptr_result (sym) == SUCCESS) + sym = sym->result; + if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE) return MATCH_ERROR; @@ -4415,6 +4490,10 @@ gfc_match_function_decl (void) } if (get_proc_name (name, &sym, false)) return MATCH_ERROR; + + if (add_hidden_procptr_result (sym) == SUCCESS) + sym = sym->result; + gfc_new_block = sym; m = gfc_match_formal_arglist (sym, 0, 0); @@ -4812,6 +4891,10 @@ gfc_match_subroutine (void) if (get_proc_name (name, &sym, false)) return MATCH_ERROR; + + if (add_hidden_procptr_result (sym) == SUCCESS) + sym = sym->result; + gfc_new_block = sym; /* Check what next non-whitespace character is so we can tell if there @@ -5259,12 +5342,21 @@ gfc_match_end (gfc_statement *st) if (block_name == NULL) goto syntax; - if (strcmp (name, block_name) != 0) + if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) { gfc_error ("Expected label '%s' for %s statement at %C", block_name, gfc_ascii_statement (*st)); goto cleanup; } + /* Procedure pointer as function result. */ + else if (strcmp (block_name, "ppr@") == 0 + && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0) + { + gfc_error ("Expected label '%s' for %s statement at %C", + gfc_current_block ()->ns->proc_name->name, + gfc_ascii_statement (*st)); + goto cleanup; + } if (gfc_match_eos () == MATCH_YES) return MATCH_YES; @@ -5375,6 +5467,8 @@ attr_decl1 (void) goto cleanup; } + add_hidden_procptr_result (sym); + return MATCH_YES; cleanup: diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 1925198..81e4591 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -2113,14 +2113,6 @@ loop: gfc_free_namespace (gfc_current_ns); goto loop; } - if (current_interface.type != INTERFACE_ABSTRACT && - !gfc_new_block->attr.dummy && - gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) - { - reject_statement (); - gfc_free_namespace (gfc_current_ns); - goto loop; - } break; case ST_PROCEDURE: @@ -2213,6 +2205,10 @@ decl: goto decl; } + /* Add EXTERNAL attribute to function or subroutine. */ + if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy) + gfc_add_external (&prog_unit->attr, &gfc_current_locus); + current_interface = save; gfc_add_interface (prog_unit); pop_state (); 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 */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1b866d9..438b0d6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -344,7 +344,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) if (sym->result == sym) gfc_error ("Contained function '%s' at %L has no IMPLICIT type", sym->name, &sym->declared_at); - else + else if (!sym->result->attr.proc_pointer) gfc_error ("Result '%s' of contained function '%s' at %L has " "no IMPLICIT type", sym->result->name, sym->name, &sym->result->declared_at); @@ -2530,7 +2530,8 @@ resolve_function (gfc_expr *expr) if (expr->ts.type == BT_UNKNOWN) { if (expr->symtree->n.sym->result - && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN) + && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN + && !expr->symtree->n.sym->result->attr.proc_pointer) expr->ts = expr->symtree->n.sym->result->ts; } @@ -4196,7 +4197,11 @@ resolve_variable (gfc_expr *e) return FAILURE; sym = e->symtree->n.sym; - if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) + if (sym->attr.flavor == FL_PROCEDURE + && (!sym->attr.function + || (sym->attr.function && sym->result + && sym->result->attr.proc_pointer + && !sym->result->attr.function))) { e->ts.type = BT_PROCEDURE; goto resolve_procedure; @@ -8034,18 +8039,41 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } } - if (sym->attr.save == SAVE_EXPLICIT && !sym->attr.proc_pointer) - { - gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " - "in '%s' at %L", sym->name, &sym->declared_at); - return FAILURE; - } - - if (sym->attr.intent && !sym->attr.proc_pointer) + if (!sym->attr.proc_pointer) { - gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " - "in '%s' at %L", sym->name, &sym->declared_at); - return FAILURE; + if (sym->attr.save == SAVE_EXPLICIT) + { + gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " + "in '%s' at %L", sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->attr.intent) + { + gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " + "in '%s' at %L", sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->attr.subroutine && sym->attr.result) + { + gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " + "in '%s' at %L", sym->name, &sym->declared_at); + return FAILURE; + } + if (sym->attr.external && sym->attr.function + && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) + || sym->attr.contained)) + { + gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute " + "in '%s' at %L", sym->name, &sym->declared_at); + return FAILURE; + } + if (strcmp ("ppr@", sym->name) == 0) + { + gfc_error ("Procedure pointer result '%s' at %L " + "is missing the pointer attribute", + sym->ns->proc_name->name, &sym->declared_at); + return FAILURE; + } } return SUCCESS; @@ -9310,11 +9338,14 @@ resolve_symbol (gfc_symbol *sym) /* Result may be in another namespace. */ resolve_symbol (sym->result); - sym->ts = sym->result->ts; - sym->as = gfc_copy_array_spec (sym->result->as); - sym->attr.dimension = sym->result->attr.dimension; - sym->attr.pointer = sym->result->attr.pointer; - sym->attr.allocatable = sym->result->attr.allocatable; + if (!sym->result->attr.proc_pointer) + { + sym->ts = sym->result->ts; + sym->as = gfc_copy_array_spec (sym->result->as); + sym->attr.dimension = sym->result->attr.dimension; + sym->attr.pointer = sym->result->attr.pointer; + sym->attr.allocatable = sym->result->attr.allocatable; + } } } } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6ffd869..a4f43a5 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -320,7 +320,7 @@ gfc_check_function_type (gfc_namespace *ns) proc->attr.allocatable = proc->result->attr.allocatable; } } - else + else if (!proc->result->attr.proc_pointer) { gfc_error ("Function result '%s' at %L has no IMPLICIT type", proc->result->name, &proc->result->declared_at); @@ -453,10 +453,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (entry, intrinsic); if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) - { - conf (external, subroutine); - conf (external, function); - } + conf (external, subroutine); conf (allocatable, pointer); conf_std (allocatable, dummy, GFC_STD_F2003); @@ -626,14 +623,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) break; case FL_PROCEDURE: - /* Conflicts with INTENT will be checked at resolution stage, - see "resolve_fl_procedure". */ + /* Conflicts with INTENT, SAVE and RESULT will be checked + at resolution stage, see "resolve_fl_procedure". */ if (attr->subroutine) { conf2 (target); conf2 (allocatable); - conf2 (result); conf2 (in_namelist); conf2 (dimension); conf2 (function); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 7cb3363..e83215c 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1616,8 +1616,8 @@ gfc_sym_type (gfc_symbol * sym) tree type; int byref; - /* Procedure Pointers inside COMMON blocks or as function result. */ - if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result)) + /* Procedure Pointers inside COMMON blocks. */ + if (sym->attr.proc_pointer && sym->attr.in_common) { /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */ sym->attr.proc_pointer = 0; @@ -2156,7 +2156,18 @@ gfc_get_function_type (gfc_symbol * sym) } else if (sym->result && sym->result->attr.proc_pointer) /* Procedure pointer return values. */ - type = gfc_sym_type (sym->result); + { + if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0) + { + /* Unset proc_pointer as gfc_get_function_type + is called recursively. */ + sym->result->attr.proc_pointer = 0; + type = build_pointer_type (gfc_get_function_type (sym->result)); + sym->result->attr.proc_pointer = 1; + } + else + type = gfc_sym_type (sym->result); + } else type = gfc_sym_type (sym); |