OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/16336 (ICE with common block in module)

Browse Source 
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.

From-SVN: r84476
This commit is contained in:
Tobias Schlüter 2004-07-11 00:37:16 +02:00 committed by Tobias Schlüter
parent 77dc410393
commit 53814b8fe8
8 changed files with 83 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/fortran/ChangeLog
View File

@ -1,3 +1,23 @@
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

9
gcc/fortran/decl.c
View File

@ -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;

3
gcc/fortran/gfortran.h
View File

@ -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 */

35
gcc/fortran/match.c
View File

@ -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)

2
gcc/fortran/match.h
View File

@ -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 */

2
gcc/fortran/module.c
View File

@ -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);

17
gcc/fortran/symbol.c
View File

@ -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)
{

38
gcc/fortran/trans-common.c
View File

@ -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. */