diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 50 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 62 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 18 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 19 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 66 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 230 |
7 files changed, 424 insertions, 22 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e982bc4..23e5c66 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,53 @@ +2005-01-21 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/25124 + PR fortran/25625 + * decl.c (get_proc_name): If there is an existing + symbol in the encompassing namespace, call errors + if it is a procedure of the same name or the kind + field is set, indicating a type declaration. + + PR fortran/20881 + PR fortran/23308 + PR fortran/25538 + PR fortran/25710 + * decl.c (add_global_entry): New function to check + for existing global symbol with this name and to + create new one if none exists. + (gfc_match_entry): Call add_global_entry before + matching argument lists for subroutine and function + entries. + * gfortran.h: Prototype for existing function, + global_used. + * resolve.c (resolve_global_procedure): New function + to check global symbols for procedures. + (resolve_call, resolve_function): Calls to this + new function for non-contained and non-module + procedures. + * match.c (match_common): Add check for existing + global symbol, creat one if none exists and emit + error if there is a clash. + * parse.c (global_used): Remove static and use the + gsymbol name rather than the new_block name, so that + the function can be called from resolve.c. + (parse_block_data, parse_module, add_global_procedure): + Improve checks for existing gsymbols. Emit error if + already defined or if references were to another type. + Set defined flag. + + PR fortran/PR24276 + * trans-expr.c (gfc_conv_aliased_arg): New function called by + gfc_conv_function_call that coverts an expression for an aliased + component reference to a derived type array into a temporary array + of the same type as the component. The temporary is passed as an + actual argument for the procedure call and is copied back to the + derived type after the call. + (is_aliased_array): New function that detects an array reference + that is followed by a component reference. + (gfc_conv_function_call): Detect an aliased actual argument with + is_aliased_array and convert it to a temporary and back again + using gfc_conv_aliased_arg. + 2006-01-19 Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de> * gfortranspec.c: Update copyright years. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index e786b31..282ca73 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -603,17 +603,38 @@ get_proc_name (const char *name, gfc_symbol ** result) int rc; if (gfc_current_ns->parent == NULL) - return gfc_get_symbol (name, NULL, result); + rc = gfc_get_symbol (name, NULL, result); + else + rc = gfc_get_symbol (name, gfc_current_ns->parent, result); - rc = gfc_get_symbol (name, gfc_current_ns->parent, result); - if (*result == NULL) - return rc; + sym = *result; - /* ??? Deal with ENTRY problem */ + if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE) + { + /* Trap another encompassed procedure with the same name. */ + if (sym->attr.flavor != 0 + && sym->attr.proc != 0 + && (sym->attr.subroutine || sym->attr.function)) + gfc_error_now ("Procedure '%s' at %C is already defined at %L", + name, &sym->declared_at); + + /* Trap declarations of attributes in encompassing scope. The + signature for this is that ts.kind is set. Legitimate + references only set ts.type. */ + if (sym->ts.kind != 0 + && sym->attr.proc == 0 + && gfc_current_ns->parent != NULL + && sym->attr.access == 0) + gfc_error_now ("Procedure '%s' at %C has an explicit interface" + " and must not have attributes declared at %L", + name, &sym->declared_at); + } + + if (gfc_current_ns->parent == NULL || *result == NULL) + return rc; st = gfc_new_symtree (&gfc_current_ns->sym_root, name); - sym = *result; st->n.sym = sym; sym->refs++; @@ -2606,6 +2627,29 @@ cleanup: return m; } +/* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the + name of the entry, rather than the gfc_current_block name, and to return false + upon finding an existing global entry. */ + +static bool +add_global_entry (const char * name, int sub) +{ + gfc_gsymbol *s; + + s = gfc_get_gsymbol(name); + + if (s->defined + || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) + global_used(s, NULL); + else + { + s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + s->where = gfc_current_locus; + s->defined = 1; + return true; + } + return false; +} /* Match an ENTRY statement. */ @@ -2697,6 +2741,9 @@ gfc_match_entry (void) if (state == COMP_SUBROUTINE) { /* An entry in a subroutine. */ + if (!add_global_entry (name, 1)) + return MATCH_ERROR; + m = gfc_match_formal_arglist (entry, 0, 1); if (m != MATCH_YES) return MATCH_ERROR; @@ -2716,6 +2763,9 @@ gfc_match_entry (void) ENTRY f() RESULT (r) can't be written as ENTRY f RESULT (r). */ + if (!add_global_entry (name, 0)) + return MATCH_ERROR; + old_loc = gfc_current_locus; if (gfc_match_eos () == MATCH_YES) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b00a9b3..9e5d303 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1962,5 +1962,6 @@ void gfc_show_namespace (gfc_namespace *); /* parse.c */ try gfc_parse_file (void); +void global_used (gfc_gsymbol *, locus *); #endif /* GCC_GFORTRAN_H */ diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 7dd4e1a..40355d2 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2250,6 +2250,7 @@ gfc_match_common (void) gfc_array_spec *as; gfc_equiv * e1, * e2; match m; + gfc_gsymbol *gsym; old_blank_common = gfc_current_ns->blank_common.head; if (old_blank_common) @@ -2266,6 +2267,23 @@ gfc_match_common (void) if (m == MATCH_ERROR) goto cleanup; + gsym = gfc_get_gsymbol (name); + if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON) + { + gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON", + sym->name); + goto cleanup; + } + + if (gsym->type == GSYM_UNKNOWN) + { + gsym->type = GSYM_COMMON; + gsym->where = gfc_current_locus; + gsym->defined = 1; + } + + gsym->used = 1; + if (name[0] == '\0') { t = &gfc_current_ns->blank_common; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 6fd3322..4fb690b 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1,5 +1,5 @@ /* Main parser. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -2396,7 +2396,7 @@ done: /* Come here to complain about a global symbol already in use as something else. */ -static void +void global_used (gfc_gsymbol *sym, locus *where) { const char *name; @@ -2430,7 +2430,7 @@ global_used (gfc_gsymbol *sym, locus *where) } gfc_error("Global name '%s' at %L is already being used as a %s at %L", - gfc_new_block->name, where, name, &sym->where); + sym->name, where, name, &sym->where); } @@ -2461,12 +2461,13 @@ parse_block_data (void) else { s = gfc_get_gsymbol (gfc_new_block->name); - if (s->type != GSYM_UNKNOWN) + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA)) global_used(s, NULL); else { s->type = GSYM_BLOCK_DATA; s->where = gfc_current_locus; + s->defined = 1; } } @@ -2491,12 +2492,13 @@ parse_module (void) gfc_gsymbol *s; s = gfc_get_gsymbol (gfc_new_block->name); - if (s->type != GSYM_UNKNOWN) + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE)) global_used(s, NULL); else { s->type = GSYM_MODULE; s->where = gfc_current_locus; + s->defined = 1; } st = parse_spec (ST_NONE); @@ -2535,12 +2537,14 @@ add_global_procedure (int sub) s = gfc_get_gsymbol(gfc_new_block->name); - if (s->type != GSYM_UNKNOWN) + if (s->defined + || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) global_used(s, NULL); else { s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; s->where = gfc_current_locus; + s->defined = 1; } } @@ -2556,12 +2560,13 @@ add_global_program (void) return; s = gfc_get_gsymbol (gfc_new_block->name); - if (s->type != GSYM_UNKNOWN) + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM)) global_used(s, NULL); else { s->type = GSYM_PROGRAM; s->where = gfc_current_locus; + s->defined = 1; } } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index af95316..1d8a71b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -885,6 +885,36 @@ find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual) ap->expr->inline_noncopying_intrinsic = 1; } +/* This function does the checking of references to global procedures + as defined in sections 18.1 and 14.1, respectively, of the Fortran + 77 and 95 standards. It checks for a gsymbol for the name, making + one if it does not already exist. If it already exists, then the + reference being resolved must correspond to the type of gsymbol. + Otherwise, the new symbol is equipped with the attributes of the + reference. The corresponding code that is called in creating + global entities is parse.c. */ + +static void +resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) +{ + gfc_gsymbol * gsym; + uint type; + + type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; + + gsym = gfc_get_gsymbol (sym->name); + + if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) + global_used (gsym, where); + + if (gsym->type == GSYM_UNKNOWN) + { + gsym->type = type; + gsym->where = *where; + } + + gsym->used = 1; +} /************* Function resolution *************/ @@ -1157,6 +1187,14 @@ resolve_function (gfc_expr * expr) try t; int temp; + /* If the procedure is not internal or module, it must be external and + should be checked for usage. */ + if (expr->symtree && expr->symtree->n.sym + && !expr->symtree->n.sym->attr.dummy + && !expr->symtree->n.sym->attr.contained + && !expr->symtree->n.sym->attr.use_assoc) + resolve_global_procedure (expr->symtree->n.sym, &expr->where, 0); + /* Switch off assumed size checking and do this again for certain kinds of procedure, once the procedure itself is resolved. */ need_full_assumed_size++; @@ -1511,6 +1549,14 @@ resolve_call (gfc_code * c) { try t; + /* If the procedure is not internal or module, it must be external and + should be checked for usage. */ + if (c->symtree && c->symtree->n.sym + && !c->symtree->n.sym->attr.dummy + && !c->symtree->n.sym->attr.contained + && !c->symtree->n.sym->attr.use_assoc) + resolve_global_procedure (c->symtree->n.sym, &c->loc, 1); + /* Switch off assumed size checking and do this again for certain kinds of procedure, once the procedure itself is resolved. */ need_full_assumed_size++; @@ -4805,6 +4851,18 @@ resolve_symbol (gfc_symbol * sym) } break; + case FL_PROCEDURE: + /* An external symbol may not have an intializer because it is taken to be + a procedure. */ + if (sym->attr.external && sym->value) + { + gfc_error ("External object '%s' at %L may not have an initializer", + sym->name, &sym->declared_at); + return; + } + + break; + case FL_DERIVED: /* Add derived type to the derived type list. */ { @@ -4818,14 +4876,6 @@ resolve_symbol (gfc_symbol * sym) default: - /* An external symbol falls through to here if it is not referenced. */ - if (sym->attr.external && sym->value) - { - gfc_error ("External object '%s' at %L may not have an initializer", - sym->name, &sym->declared_at); - return; - } - break; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 880994a..b30a121 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1529,6 +1529,226 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping, gfc_free_expr (expr); } +/* Returns a reference to a temporary array into which a component of + an actual argument derived type array is copied and then returned + after the function call. + TODO Get rid of this kludge, when array descriptors are capable of + handling aliased arrays. */ + +static void +gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77) +{ + gfc_se lse; + gfc_se rse; + gfc_ss *lss; + gfc_ss *rss; + gfc_loopinfo loop; + gfc_loopinfo loop2; + gfc_ss_info *info; + tree offset; + tree tmp_index; + tree tmp; + tree base_type; + stmtblock_t body; + int n; + + gcc_assert (expr->expr_type == EXPR_VARIABLE); + + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + /* Walk the argument expression. */ + rss = gfc_walk_expr (expr); + + gcc_assert (rss != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, rss); + + /* Calculate the bounds of the scalarization. */ + gfc_conv_ss_startstride (&loop); + + /* Build an ss for the temporary. */ + base_type = gfc_typenode_for_spec (&expr->ts); + if (GFC_ARRAY_TYPE_P (base_type) + || GFC_DESCRIPTOR_TYPE_P (base_type)) + base_type = gfc_get_element_type (base_type); + + loop.temp_ss = gfc_get_ss ();; + loop.temp_ss->type = GFC_SS_TEMP; + loop.temp_ss->data.temp.type = base_type; + + if (expr->ts.type == BT_CHARACTER) + loop.temp_ss->string_length = expr->ts.cl->backend_decl; + + loop.temp_ss->data.temp.dimen = loop.dimen; + loop.temp_ss->next = gfc_ss_terminator; + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, loop.temp_ss); + + /* Setup the scalarizing loops. */ + gfc_conv_loop_setup (&loop); + + /* Pass the temporary descriptor back to the caller. */ + info = &loop.temp_ss->data.info; + parmse->expr = info->descriptor; + + /* Setup the gfc_se structures. */ + gfc_copy_loopinfo_to_se (&lse, &loop); + gfc_copy_loopinfo_to_se (&rse, &loop); + + rse.ss = rss; + lse.ss = loop.temp_ss; + gfc_mark_ss_chain_used (rss, 1); + gfc_mark_ss_chain_used (loop.temp_ss, 1); + + /* Start the scalarized loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* Translate the expression. */ + gfc_conv_expr (&rse, expr); + + gfc_conv_tmp_array_ref (&lse); + gfc_advance_se_ss_chain (&lse); + + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + gfc_add_expr_to_block (&body, tmp); + + gcc_assert (rse.ss == gfc_ss_terminator); + + gfc_trans_scalarizing_loops (&loop, &body); + + /* Add the post block after the second loop, so that any + freeing of allocated memory is done at the right time. */ + gfc_add_block_to_block (&parmse->pre, &loop.pre); + + /**********Copy the temporary back again.*********/ + + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + /* Walk the argument expression. */ + lss = gfc_walk_expr (expr); + rse.ss = loop.temp_ss; + lse.ss = lss; + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop2); + gfc_add_ss_to_loop (&loop2, lss); + + /* Calculate the bounds of the scalarization. */ + gfc_conv_ss_startstride (&loop2); + + /* Setup the scalarizing loops. */ + gfc_conv_loop_setup (&loop2); + + gfc_copy_loopinfo_to_se (&lse, &loop2); + gfc_copy_loopinfo_to_se (&rse, &loop2); + + gfc_mark_ss_chain_used (lss, 1); + gfc_mark_ss_chain_used (loop.temp_ss, 1); + + /* Declare the variable to hold the temporary offset and start the + scalarized loop body. */ + offset = gfc_create_var (gfc_array_index_type, NULL); + gfc_start_scalarized_body (&loop2, &body); + + /* Build the offsets for the temporary from the loop variables. The + temporary array has lbounds of zero and strides of one in all + dimensions, so this is very simple. The offset is only computed + outside the innermost loop, so the overall transfer could be + optimised further. */ + info = &rse.ss->data.info; + + tmp_index = gfc_index_zero_node; + for (n = info->dimen - 1; n > 0; n--) + { + tree tmp_str; + tmp = rse.loop->loopvar[n]; + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp, rse.loop->from[n]); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp, tmp_index); + + tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type, + rse.loop->to[n-1], rse.loop->from[n-1]); + tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp_str, gfc_index_one_node); + + tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type, + tmp, tmp_str); + } + + tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp_index, rse.loop->from[0]); + gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index); + + tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type, + rse.loop->loopvar[0], offset); + + /* Now use the offset for the reference. */ + tmp = build_fold_indirect_ref (info->data); + rse.expr = gfc_build_array_ref (tmp, tmp_index); + + if (expr->ts.type == BT_CHARACTER) + rse.string_length = expr->ts.cl->backend_decl; + + gfc_conv_expr (&lse, expr); + + gcc_assert (lse.ss == gfc_ss_terminator); + + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + gfc_add_expr_to_block (&body, tmp); + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop2, &body); + + /* Wrap the whole thing up by adding the second loop to the post-block + and following it by the post-block of the fist loop. In this way, + if the temporary needs freeing, it is done after use! */ + gfc_add_block_to_block (&parmse->post, &loop2.pre); + gfc_add_block_to_block (&parmse->post, &loop2.post); + + gfc_add_block_to_block (&parmse->post, &loop.post); + + gfc_cleanup_loop (&loop); + gfc_cleanup_loop (&loop2); + + /* Pass the string length to the argument expression. */ + if (expr->ts.type == BT_CHARACTER) + parmse->string_length = expr->ts.cl->backend_decl; + + /* We want either the address for the data or the address of the descriptor, + depending on the mode of passing array arguments. */ + if (g77) + parmse->expr = gfc_conv_descriptor_data_get (parmse->expr); + else + parmse->expr = build_fold_addr_expr (parmse->expr); + + return; +} + +/* Is true if the last array reference is followed by a component reference. */ + +static bool +is_aliased_array (gfc_expr * e) +{ + gfc_ref * ref; + bool seen_array; + + seen_array = false; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + seen_array = true; + + if (ref->next == NULL && ref->type == REF_COMPONENT) + return seen_array; + } + return false; +} /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. @@ -1655,7 +1875,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, && !formal->sym->attr.pointer && formal->sym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; - gfc_conv_array_parameter (&parmse, arg->expr, argss, f); + if (arg->expr->expr_type == EXPR_VARIABLE + && is_aliased_array (arg->expr)) + /* The actual argument is a component reference to an + array of derived types. In this case, the argument + is converted to a temporary, which is passed and then + written back after the procedure call. */ + gfc_conv_aliased_arg (&parmse, arg->expr, f); + else + gfc_conv_array_parameter (&parmse, arg->expr, argss, f); } } |