diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 20 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 9 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 3 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 35 | ||||
| -rw-r--r-- | gcc/fortran/match.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/module.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 17 | ||||
| -rw-r--r-- | gcc/fortran/trans-common.c | 38 |
8 files changed, 83 insertions, 43 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4335a586789..1b39762b967 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,4 +1,24 @@ 2004-07-10 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/16336 + * decl.c (gfc_match_save): Use-associated common block + doesn't collide. + * gfortran.h (gfc_common_head): Add new field 'name'. + Fix typo in comment after #endif. + * match.c (gfc_get_common): Add new argument from_common, + mangle name if flag is set, fill in new field in structure + gfc_common_head. + (match_common): Set new arg in call to gfc_get_common, + use-associated common block doesn't collide. + * match.h (gfc_get_common): Adapt prototype. + * module.c (load_commons): Set new arg in call to + gfc_get_common. + * symbol.c (free_common_tree): New function. + (gfc_free_namespace): Call new function. + * trans-common.c (several functions): Remove argument + 'name', use name from gfc_common_head instead. + +2004-07-10 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de> * expr.c (gfc_check_pointer_assign): Verify that rank of the LHS and RHS match. Return early if the RHS is NULL(). diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 94573ac9df5..3a78efc6560 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2699,14 +2699,7 @@ gfc_match_save (void) if (m == MATCH_NO) goto syntax; - c = gfc_get_common (n); - - if (c->use_assoc) - { - gfc_error("COMMON block '%s' at %C is already USE associated", n); - return MATCH_ERROR; - } - + c = gfc_get_common (n, 0); c->saved = 1; gfc_current_ns->seen_save = 1; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d82d30621d7..3ea8bb6431b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -678,6 +678,7 @@ typedef struct { locus where; int use_assoc, saved; + char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *head; } gfc_common_head; @@ -1697,4 +1698,4 @@ void gfc_show_namespace (gfc_namespace *); /* parse.c */ try gfc_parse_file (void); -#endif /* GFC_GFC_H */ +#endif /* GCC_GFORTRAN_H */ diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 2d85a56cc7d..040142f766c 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2049,22 +2049,38 @@ cleanup: /* Given a name, return a pointer to the common head structure, - creating it if it does not exist. + creating it if it does not exist. If FROM_MODULE is non-zero, we + mangle the name so that it doesn't interfere with commons defined + in the using namespace. TODO: Add to global symbol tree. */ gfc_common_head * -gfc_get_common (char *name) +gfc_get_common (const char *name, int from_module) { gfc_symtree *st; + static int serial = 0; + char mangled_name[GFC_MAX_SYMBOL_LEN+1]; - st = gfc_find_symtree (gfc_current_ns->common_root, name); - if (st == NULL) - st = gfc_new_symtree (&gfc_current_ns->common_root, name); + if (from_module) + { + /* A use associated common block is only needed to correctly layout + the variables it contains. */ + snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); + st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); + } + else + { + st = gfc_find_symtree (gfc_current_ns->common_root, name); + + if (st == NULL) + st = gfc_new_symtree (&gfc_current_ns->common_root, name); + } if (st->n.common == NULL) { st->n.common = gfc_get_common_head (); st->n.common->where = gfc_current_locus; + strcpy (st->n.common->name, name); } return st->n.common; @@ -2140,15 +2156,8 @@ gfc_match_common (void) } else { - t = gfc_get_common (name); + t = gfc_get_common (name, 0); head = &t->head; - - if (t->use_assoc) - { - gfc_error ("COMMON block '%s' at %C has already " - "been USE-associated", name); - goto cleanup; - } } if (*head == NULL) diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 4b8f87232ec..032a6a310b9 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -89,7 +89,7 @@ match gfc_match_forall (gfc_statement *); /* Other functions. */ -gfc_common_head *gfc_get_common (char *); +gfc_common_head *gfc_get_common (const char *, int); /* decl.c */ diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 8fce458a655..33f050b91dc 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2825,7 +2825,7 @@ load_commons(void) mio_lparen (); mio_internal_string (name); - p = gfc_get_common (name); + p = gfc_get_common (name, 1); mio_symbol_ref (&p->head); mio_integer (&p->saved); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 9208d2205d9..3159436eeb9 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2139,6 +2139,22 @@ gfc_commit_symbols (void) } +/* Recursive function that deletes an entire tree and all the common + head structures it points to. */ + +static void +free_common_tree (gfc_symtree * common_tree) +{ + if (common_tree == NULL) + return; + + free_common_tree (common_tree->left); + free_common_tree (common_tree->right); + + gfc_free (common_tree); +} + + /* Recursive function that deletes an entire tree and all the user operator nodes that it contains. */ @@ -2216,6 +2232,7 @@ gfc_free_namespace (gfc_namespace * ns) free_sym_tree (ns->sym_root); free_uop_tree (ns->uop_root); + free_common_tree (ns->common_root); for (cl = ns->cl_list; cl; cl = cl2) { diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index d20a60be906..7907020371e 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -277,8 +277,7 @@ build_equiv_decl (tree union_type, bool is_init) /* Get storage for common block. */ static tree -build_common_decl (gfc_common_head *com, const char *name, - tree union_type, bool is_init) +build_common_decl (gfc_common_head *com, tree union_type, bool is_init) { gfc_symbol *common_sym; tree decl; @@ -287,7 +286,7 @@ build_common_decl (gfc_common_head *com, const char *name, if (gfc_common_ns == NULL) gfc_common_ns = gfc_get_namespace (NULL); - gfc_get_symbol (name, gfc_common_ns, &common_sym); + gfc_get_symbol (com->name, gfc_common_ns, &common_sym); decl = common_sym->backend_decl; /* Update the size of this common block as needed. */ @@ -299,9 +298,9 @@ build_common_decl (gfc_common_head *com, const char *name, /* Named common blocks of the same name shall be of the same size in all scoping units of a program in which they appear, but blank common blocks may be of different sizes. */ - if (strcmp (name, BLANK_COMMON_NAME)) + if (strcmp (com->name, BLANK_COMMON_NAME)) gfc_warning ("Named COMMON block '%s' at %L shall be of the " - "same size", name, &com->where); + "same size", com->name, &com->where); DECL_SIZE_UNIT (decl) = size; } } @@ -315,8 +314,8 @@ build_common_decl (gfc_common_head *com, const char *name, /* If there is no backend_decl for the common block, build it. */ if (decl == NULL_TREE) { - decl = build_decl (VAR_DECL, get_identifier (name), union_type); - SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (name)); + decl = build_decl (VAR_DECL, get_identifier (com->name), union_type); + SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name)); TREE_PUBLIC (decl) = 1; TREE_STATIC (decl) = 1; DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; @@ -348,7 +347,7 @@ build_common_decl (gfc_common_head *com, const char *name, backend declarations for all of the elements. */ static void -create_common (gfc_common_head *com, const char *name) +create_common (gfc_common_head *com) { segment_info *s, *next_s; tree union_type; @@ -377,7 +376,7 @@ create_common (gfc_common_head *com, const char *name) finish_record_layout (rli, true); if (com) - decl = build_common_decl (com, name, union_type, is_init); + decl = build_common_decl (com, union_type, is_init); else decl = build_equiv_decl (union_type, is_init); @@ -720,7 +719,7 @@ add_equivalences (void) and all of the symbols equivalenced with that symbol. */ static void -new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym) +new_segment (gfc_common_head *common, gfc_symbol *sym) { current_segment = get_segment_info (sym, current_offset); @@ -733,8 +732,9 @@ new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym) add_equivalences (); if (current_segment->offset < 0) - gfc_error ("The equivalence set for '%s' cause an invalid extension " - "to COMMON '%s' at %L", sym->name, name, &common->where); + gfc_error ("The equivalence set for '%s' cause an invalid " + "extension to COMMON '%s' at %L", sym->name, + common->name, &common->where); /* Add these to the common block. */ current_common = add_segments (current_common, current_segment); @@ -770,7 +770,7 @@ finish_equivalences (gfc_namespace *ns) v->offset -= min_offset; current_common = current_segment; - create_common (NULL, NULL); + create_common (NULL); break; } } @@ -779,8 +779,7 @@ finish_equivalences (gfc_namespace *ns) /* Translate a single common block. */ static void -translate_common (gfc_common_head *common, const char *name, - gfc_symbol *var_list) +translate_common (gfc_common_head *common, gfc_symbol *var_list) { gfc_symbol *sym; @@ -791,10 +790,10 @@ translate_common (gfc_common_head *common, const char *name, for (sym = var_list; sym; sym = sym->common_next) { if (! sym->equiv_built) - new_segment (common, name, sym); + new_segment (common, sym); } - create_common (common, name); + create_common (common); } @@ -804,7 +803,7 @@ static void named_common (gfc_symtree *st) { - translate_common (st->n.common, st->name, st->n.common->head); + translate_common (st->n.common, st->n.common->head); } @@ -821,7 +820,8 @@ gfc_trans_common (gfc_namespace *ns) if (ns->blank_common.head != NULL) { c = gfc_get_common_head (); - translate_common (c, BLANK_COMMON_NAME, ns->blank_common.head); + strcpy (c->name, BLANK_COMMON_NAME); + translate_common (c, ns->blank_common.head); } /* Translate all named common blocks. */ |