This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[gfortran] PR 15481: Separate common symbols
- From: Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>
- To: GCC Fortran mailing list <fortran at gcc dot gnu dot org>,patch <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 26 Jun 2004 17:43:47 +0200
- Subject: [gfortran] PR 15481: Separate common symbols
This is the first step towards aresolution of PR 154841.
With this commons are now no longer in the same symtree as the variables
of a namespace, but in a new symtree instead. The patch is large,
because this needs fixups in various parts of the compiler to make this
work. Because this makes the workaround for PR 13249 superfluous, I
added that PR to the ChangeLog.
Compiled and tested on i686-pc-linux. This also fixes two minor issues
when matching, one with empty commons and one with an empty common name
(i.e. common // ...). It also fixes an issue in the generation of
initialization of derived data types in commons.
While I was touching module.c, I added an obvious fix to mio_gmp_real,
where we would misprint negative numbers.
This introduces a regression in that the error
gfc_error ("DATA statement at %C may not initialize variable "
"'%s' from blank COMMON", sym->name);
will not be emitted any longer. I will fix that in a followup, once I
figure out a place to do this now.
Looking over the patch, I see that I didn't install logic to dump common
blocks. I will fix this once this patch is in.
- Tobi
2004-06-26 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
Andrew Vaught <andyv@firstinter.net>
PR fortran/13249
PR fortran/15481
* declc (gfc_match_save): Adapt to new common structures,
don't allow saving USE-associated common.
* dump-parse-tree (gfc_show_attr): (saved_)common are not
symbol attributes any longer.
(gfc_show_symbol): Don't show old-style commons any longer.
(gfc_show_namespace): Adapt call to gfc_traverse_symtree to new
interface.
gfortran.h (symbol_attribute): Remove common and saved_common
attributes.
(gfc_symbol): Remove common_head element.
(gfc_common_head): New struct.
(gfc_get_common_head): New macro.
(gfc_symtree): Add field 'common' to union.
(gfc_namespace): Add field 'common_root'; change type of field
'blank_common' to blank_common.
(gfc_add_data): New prototype.
(gfc_traverse_symtree): Expect a symtree as first argument
instead of namespace.
* match.c (gfc_get_common): New function.
(match_common_name): Change to take char * as argument, adapt,
fix bug with empty name.
(gfc_match_common): Adapt to new data structures. Disallow
redeclaration of USE-associated COMMON-block. Fix bug with
empty common.
(var_element): Adapt to new common structures.
* match.h (gfc_get_common): Declare.
* module.c: Add 2004 to copyright years, add commons to module
file layout.
(ab_attribute, attr_bits, mio_symbol_attributes): Remove code
for removed attributes.
(mio_gmp_real): Fix output of negative numbers.
(mio_symbol): Adapt to new way of storing common relations.
(load_commons): New function.
(read_module): Skip common list on first pass, load_commons at
second.
(write_commons): New function.
(write_module): Call write_commons().
* symbol.c (gfc_add_saved_comon, gfc_add_common): Remove
functions related to removed attributes.
(gfc_add_data): New function.
(gfc_clear_attr): Don't set removed attributes.
(gfc_copy_attr): Don't copy removed attributes.
(gfc_traverse_symtree): Don't travese symbol tree of
the passed namespace, but require a symtree to be passed
instead.
(gfc_traverse_ns): Call gfc_traverse_symtree according to new
interface.
(save_symbol): Remove setting of removed attribute.
* trans-common.c (gfc_sym_mangled_common_id): Change to
take 'char *' argument instead of 'gfc_symbol'.
(build_common_decl, new_segment, translate_common): Adapt to new
data structures, add new
argument name.
(create_common): Adapt to new data structures, add new
argument name. Fix typo in intialization of derived types.
(finish_equivalences): Add second argument in call to
create_common.
(named_common): take 'gfc_symtree' instead of 'gfc_symbol'.
(gfc_trans_common): Adapt to new data structures.
* trans-decl.c (gfc_create_module_variables): Also output
symbols from commons.
Index: decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/decl.c,v
retrieving revision 1.11
diff -u -p -r1.11 decl.c
--- decl.c 26 Jun 2004 12:01:43 -0000 1.11
+++ decl.c 26 Jun 2004 15:00:13 -0000
@@ -1908,6 +1908,7 @@ gfc_match_end (gfc_statement * st)
default:
gfc_error ("Unexpected END statement at %C");
+ eos_ok = 0;
goto cleanup;
}
@@ -2427,6 +2428,8 @@ gfc_match_parameter (void)
match
gfc_match_save (void)
{
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_common_head *c;
gfc_symbol *sym;
match m;
@@ -2469,14 +2472,22 @@ gfc_match_save (void)
return MATCH_ERROR;
}
- m = gfc_match (" / %s /", &sym);
+ m = gfc_match (" / %n /", &n);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
goto syntax;
- if (gfc_add_saved_common (&sym->attr, NULL) == FAILURE)
- return MATCH_ERROR;
+ 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->saved = 1;
+
gfc_current_ns->seen_save = 1;
next_item:
Index: dump-parse-tree.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/dump-parse-tree.c,v
retrieving revision 1.5
diff -u -p -r1.5 dump-parse-tree.c
--- dump-parse-tree.c 22 May 2004 15:52:42 -0000 1.5
+++ dump-parse-tree.c 26 Jun 2004 15:00:14 -0000
@@ -544,8 +544,6 @@ gfc_show_attr (symbol_attribute * attr)
gfc_status (" TARGET");
if (attr->dummy)
gfc_status (" DUMMY");
- if (attr->common)
- gfc_status (" COMMON");
if (attr->result)
gfc_status (" RESULT");
if (attr->entry)
@@ -559,8 +557,6 @@ gfc_show_attr (symbol_attribute * attr)
gfc_status (" IN-NAMELIST");
if (attr->in_common)
gfc_status (" IN-COMMON");
- if (attr->saved_common)
- gfc_status (" SAVED-COMMON");
if (attr->function)
gfc_status (" FUNCTION");
@@ -616,7 +612,6 @@ gfc_show_symbol (gfc_symbol * sym)
{
gfc_formal_arglist *formal;
gfc_interface *intr;
- gfc_symbol *s;
if (sym == NULL)
return;
@@ -649,14 +644,6 @@ gfc_show_symbol (gfc_symbol * sym)
gfc_status (" %s", intr->sym->name);
}
- if (sym->common_head)
- {
- show_indent ();
- gfc_status ("Common members:");
- for (s = sym->common_head; s; s = s->common_next)
- gfc_status (" %s", s->name);
- }
-
if (sym->result)
{
show_indent ();
@@ -1445,7 +1432,7 @@ gfc_show_namespace (gfc_namespace * ns)
}
gfc_current_ns = ns;
- gfc_traverse_symtree (ns, show_symtree);
+ gfc_traverse_symtree (ns->sym_root, show_symtree);
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
{
Index: expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/expr.c,v
retrieving revision 1.7
diff -u -p -r1.7 expr.c
--- expr.c 27 May 2004 12:35:11 -0000 1.7
+++ expr.c 26 Jun 2004 15:00:17 -0000
@@ -1167,6 +1167,18 @@ check_intrinsic_op (gfc_expr * e, try (*
case INTRINSIC_GE:
case INTRINSIC_LT:
case INTRINSIC_LE:
+ if ((*check_function) (e->op2) == FAILURE)
+ return FAILURE;
+
+ if ((et0 (e->op1) != BT_CHARACTER && et0 (e->op2) != BT_CHARACTER)
+ || (!numeric_type (et0 (e->op1)) && !numeric_type (et0 (e->op2))))
+ {
+ gfc_error ("Numeric or character operands are required in "
+ "expression at %L", &e->where);
+ return FAILURE;
+ }
+ break;
+
case INTRINSIC_PLUS:
case INTRINSIC_MINUS:
@@ -1179,10 +1191,8 @@ check_intrinsic_op (gfc_expr * e, try (*
if (!numeric_type (et0 (e->op1)) || !numeric_type (et0 (e->op2)))
goto not_numeric;
- if (e->operator != INTRINSIC_POWER)
- break;
-
- if (check_function == check_init_expr && et0 (e->op2) != BT_INTEGER)
+ if (e->operator == INTRINSIC_POWER
+ && check_function == check_init_expr && et0 (e->op2) != BT_INTEGER)
{
gfc_error ("Exponent at %L must be INTEGER for an initialization "
"expression", &e->op2->where);
Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.13
diff -u -p -r1.13 gfortran.h
--- gfortran.h 14 Jun 2004 15:56:48 -0000 1.13
+++ gfortran.h 26 Jun 2004 15:00:17 -0000
@@ -385,12 +385,12 @@ typedef struct
/* Variable attributes. */
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, save:1, target:1,
- dummy:1, common:1, result:1, entry:1, assign:1;
+ dummy:1, result:1, entry:1, assign:1;
unsigned data:1, /* Symbol is named in a DATA statement. */
use_assoc:1; /* Symbol has been use-associated. */
- unsigned in_namelist:1, in_common:1, saved_common:1;
+ unsigned in_namelist:1, in_common:1;
unsigned function:1, subroutine:1, generic:1;
unsigned implicit_type:1; /* Type defined via implicit rules */
@@ -642,8 +642,7 @@ typedef struct gfc_symbol
struct gfc_symbol *result; /* function result symbol */
gfc_component *components; /* Derived type components */
- /* TODO: These three fields are mutually exclusive. */
- struct gfc_symbol *common_head, *common_next; /* Links for COMMON syms */
+ struct gfc_symbol *common_next; /* Links for COMMON syms */
/* Make sure setup code for dummy arguments is generated in the correct
order. */
int dummy_order;
@@ -671,6 +670,20 @@ typedef struct gfc_symbol
gfc_symbol;
+/* This structure is used to keep track of symbols in common blocks. */
+
+typedef struct
+{
+ locus where;
+ int use_assoc, saved;
+ gfc_symbol *head;
+}
+gfc_common_head;
+
+#define gfc_get_common_head() gfc_getmem(sizeof(gfc_common_head))
+
+
+
/* Within a namespace, symbols are pointed to by symtree nodes that
are linked together in a balanced binary tree. There can be
several symtrees pointing to the same symbol node via USE
@@ -687,6 +700,7 @@ typedef struct gfc_symtree
{
gfc_symbol *sym; /* Symbol associated with this node */
gfc_user_op *uop;
+ gfc_common_head *common;
}
n;
@@ -696,7 +710,8 @@ gfc_symtree;
typedef struct gfc_namespace
{
- gfc_symtree *sym_root, *uop_root; /* Roots of the red/black symbol trees */
+ /* Roots of the red/black symbol trees */
+ gfc_symtree *sym_root, *uop_root, *common_root;
int set_flag[GFC_LETTERS];
gfc_typespec default_type[GFC_LETTERS]; /* IMPLICIT typespecs */
@@ -705,7 +720,7 @@ typedef struct gfc_namespace
gfc_interface *operator[GFC_INTRINSIC_OPS];
struct gfc_namespace *parent, *contained, *sibling;
struct gfc_code *code;
- gfc_symbol *blank_common;
+ gfc_common_head blank_common;
struct gfc_equiv *equiv;
gfc_access default_access, operator_access[GFC_INTRINSIC_OPS];
@@ -720,6 +735,24 @@ gfc_namespace;
extern gfc_namespace *gfc_current_ns;
+/* Global symbols are symbols of global scope. Currently we only use
+ this to detect collisions already when parsing.
+ TODO: Extend to verify procedure calls. */
+
+typedef struct gfc_gsymbol
+{
+ BBT_HEADER(gfc_gsymbol);
+
+ char name[GFC_MAX_SYMBOL_LEN+1];
+ enum { GSYM_UNKNOWN=1, GSYM_PROGRAM, GSYM_FUNCTION, GSYM_SUBROUTINE,
+ GSYM_MODULE, GSYM_COMMON, GSYM_BLOCK_DATA } type;
+
+ int defined, used;
+ locus where;
+}
+gfc_gsymbol;
+
+extern gfc_gsymbol *gfc_gsym_root;
/* Information on interfaces being built. */
typedef struct
@@ -1429,6 +1462,7 @@ try gfc_add_dummy (symbol_attribute *, l
try gfc_add_generic (symbol_attribute *, locus *);
try gfc_add_common (symbol_attribute *, locus *);
try gfc_add_in_common (symbol_attribute *, locus *);
+try gfc_add_data (symbol_attribute *, locus *);
try gfc_add_in_namelist (symbol_attribute *, locus *);
try gfc_add_sequence (symbol_attribute *, locus *);
try gfc_add_elemental (symbol_attribute *, locus *);
@@ -1483,13 +1517,16 @@ void gfc_free_namespace (gfc_namespace *
void gfc_symbol_init_2 (void);
void gfc_symbol_done_2 (void);
-void gfc_traverse_symtree (gfc_namespace *, void (*)(gfc_symtree *));
+void gfc_traverse_symtree (gfc_symtree *, void (*)(gfc_symtree *));
void gfc_traverse_ns (gfc_namespace *, void (*)(gfc_symbol *));
void gfc_traverse_user_op (gfc_namespace *, void (*)(gfc_user_op *));
void gfc_save_all (gfc_namespace *);
void gfc_symbol_state (void);
+gfc_gsymbol *gfc_get_gsymbol (char *);
+gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, char *);
+
/* intrinsic.c */
extern int gfc_init_expr;
Index: io.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/io.c,v
retrieving revision 1.10
diff -u -p -r1.10 io.c
--- io.c 26 Jun 2004 11:48:55 -0000 1.10
+++ io.c 26 Jun 2004 15:00:17 -0000
@@ -1,5 +1,6 @@
/* Deal with I/O statements & related stuff.
- Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
+ Inc.
Contributed by Andy Vaught
This file is part of GCC.
Index: match.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/match.c,v
retrieving revision 1.10
diff -u -p -r1.10 match.c
--- match.c 15 Jun 2004 21:50:48 -0000 1.10
+++ match.c 26 Jun 2004 15:00:20 -0000
@@ -2246,23 +2246,49 @@ error:
}
+/* Given a name, return a pointer to the common head structure,
+ creating it if it does not exist.
+ TODO: Add to global symbol tree. */
+
+gfc_common_head *
+gfc_get_common (char *name)
+{
+ gfc_symtree *st;
+
+ 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;
+ }
+
+ return st->n.common;
+}
+
+
/* Match a common block name. */
static match
-match_common_name (gfc_symbol ** sym)
+match_common_name (char *name)
{
match m;
if (gfc_match_char ('/') == MATCH_NO)
- return MATCH_NO;
+ {
+ name[0] = '\0';
+ return MATCH_YES;
+ }
if (gfc_match_char ('/') == MATCH_YES)
{
- *sym = NULL;
+ name[0] = '\0';
return MATCH_YES;
}
- m = gfc_match_symbol (sym, 0);
+ m = gfc_match_name (name);
if (m == MATCH_ERROR)
return MATCH_ERROR;
@@ -2279,18 +2305,19 @@ match_common_name (gfc_symbol ** sym)
match
gfc_match_common (void)
{
- gfc_symbol *sym, *common_name, **head, *tail, *old_blank_common;
+ gfc_symbol *sym, **head, *tail, *old_blank_common;
+ char name[GFC_MAX_SYMBOL_LEN+1];
+ gfc_common_head *t;
gfc_array_spec *as;
match m;
- old_blank_common = gfc_current_ns->blank_common;
+ old_blank_common = gfc_current_ns->blank_common.head;
if (old_blank_common)
{
while (old_blank_common->common_next)
old_blank_common = old_blank_common->common_next;
}
- common_name = NULL;
as = NULL;
if (gfc_match_eos () == MATCH_YES)
@@ -2298,19 +2325,28 @@ gfc_match_common (void)
for (;;)
{
- m = match_common_name (&common_name);
+ m = match_common_name (name);
if (m == MATCH_ERROR)
goto cleanup;
- if (common_name == NULL)
- head = &gfc_current_ns->blank_common;
+ if (name[0] == '\0')
+ {
+ t = &gfc_current_ns->blank_common;
+ if (t->head == NULL)
+ t->where = gfc_current_locus;
+ head = &t->head;
+ }
else
{
- head = &common_name->common_head;
+ t = gfc_get_common (name);
+ head = &t->head;
- if (!common_name->attr.common
- && gfc_add_common (&common_name->attr, NULL) == FAILURE)
- goto cleanup;
+ if (t->use_assoc)
+ {
+ gfc_error ("COMMON block '%s' at %C has already "
+ "been USE-associated");
+ goto cleanup;
+ }
}
if (*head == NULL)
@@ -2323,6 +2359,9 @@ gfc_match_common (void)
}
/* Grab the list of symbols. */
+ if (gfc_match_eos () == MATCH_YES)
+ goto done;
+
for (;;)
{
m = gfc_match_symbol (&sym, 0);
@@ -2338,16 +2377,18 @@ gfc_match_common (void)
goto cleanup;
}
+ if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
+ goto cleanup;
+
if (sym->value != NULL
- && (common_name == NULL || !sym->attr.data))
+ && (name[0] == '\0' || !sym->attr.data))
{
- if (common_name == NULL)
+ if (name[0] == '\0')
gfc_error ("Previously initialized symbol '%s' in "
"blank COMMON block at %C", sym->name);
else
gfc_error ("Previously initialized symbol '%s' in "
- "COMMON block '%s' at %C", sym->name,
- common_name->name);
+ "COMMON block '%s' at %C", sym->name, name);
goto cleanup;
}
@@ -2422,7 +2463,7 @@ cleanup:
if (old_blank_common)
old_blank_common->common_next = NULL;
else
- gfc_current_ns->blank_common = NULL;
+ gfc_current_ns->blank_common.head = NULL;
gfc_free_array_spec (as);
return MATCH_ERROR;
}
@@ -2827,7 +2868,8 @@ static match
var_element (gfc_data_variable * new)
{
match m;
- gfc_symbol *sym, *t;
+ gfc_symbol *sym;
+ gfc_common_head *t;
memset (new, '\0', sizeof (gfc_data_variable));
@@ -2847,17 +2889,20 @@ var_element (gfc_data_variable * new)
return MATCH_ERROR;
}
+#if 0 // TODO: Find out where to move this message
if (sym->attr.in_common)
/* See if sym is in the blank common block. */
- for (t = sym->ns->blank_common; t; t = t->common_next)
- if (sym == t)
+ for (t = &sym->ns->blank_common; t; t = t->common_next)
+ if (sym == t->head)
{
gfc_error ("DATA statement at %C may not initialize variable "
"'%s' from blank COMMON", sym->name);
return MATCH_ERROR;
}
+#endif
- sym->attr.data = 1;
+ if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
+ return MATCH_ERROR;
return MATCH_YES;
}
Index: match.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/match.h,v
retrieving revision 1.4
diff -u -p -r1.4 match.h
--- match.h 15 May 2004 18:02:15 -0000 1.4
+++ match.h 26 Jun 2004 15:00:20 -0000
@@ -89,6 +89,10 @@ match gfc_match_where (gfc_statement *);
match gfc_match_elsewhere (void);
match gfc_match_forall (gfc_statement *);
+/* Other functions. */
+
+gfc_common_head *gfc_get_common (char *);
+
/* decl.c */
match gfc_match_null (gfc_expr **);
Index: module.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/module.c,v
retrieving revision 1.6
diff -u -p -r1.6 module.c
--- module.c 9 Jun 2004 12:55:48 -0000 1.6
+++ module.c 26 Jun 2004 15:00:20 -0000
@@ -1,6 +1,7 @@
/* Handle modules, which amounts to loading and saving symbols and
their attendant structures.
- Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
+ Inc.
Contributed by Andy Vaught
This file is part of GCC.
@@ -43,6 +44,9 @@ Software Foundation, 59 Temple Place - S
( ( <name of generic interface> <module of generic interface> <i/f1> ... )
...
)
+ ( ( <common name> <symbol> <saved flag>)
+ ...
+ )
( <Symbol Number (in no particular order)>
<True name of symbol>
<Module name of symbol>
@@ -1361,8 +1365,8 @@ mio_internal_string (char *string)
typedef enum
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
- AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_COMMON, AB_RESULT,
- AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_SAVED_COMMON,
+ AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
+ AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT
}
@@ -1379,13 +1383,11 @@ static const mstring attr_bits[] =
minit ("SAVE", AB_SAVE),
minit ("TARGET", AB_TARGET),
minit ("DUMMY", AB_DUMMY),
- minit ("COMMON", AB_COMMON),
minit ("RESULT", AB_RESULT),
minit ("ENTRY", AB_ENTRY),
minit ("DATA", AB_DATA),
minit ("IN_NAMELIST", AB_IN_NAMELIST),
minit ("IN_COMMON", AB_IN_COMMON),
- minit ("SAVED_COMMON", AB_SAVED_COMMON),
minit ("FUNCTION", AB_FUNCTION),
minit ("SUBROUTINE", AB_SUBROUTINE),
minit ("SEQUENCE", AB_SEQUENCE),
@@ -1450,8 +1452,6 @@ mio_symbol_attribute (symbol_attribute *
MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
if (attr->dummy)
MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
- if (attr->common)
- MIO_NAME(ab_attribute) (AB_COMMON, attr_bits);
if (attr->result)
MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
if (attr->entry)
@@ -1463,8 +1463,6 @@ mio_symbol_attribute (symbol_attribute *
MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits);
if (attr->in_common)
MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
- if (attr->saved_common)
- MIO_NAME(ab_attribute) (AB_SAVED_COMMON, attr_bits);
if (attr->function)
MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
@@ -1527,9 +1525,6 @@ mio_symbol_attribute (symbol_attribute *
case AB_DUMMY:
attr->dummy = 1;
break;
- case AB_COMMON:
- attr->common = 1;
- break;
case AB_RESULT:
attr->result = 1;
break;
@@ -1545,9 +1540,6 @@ mio_symbol_attribute (symbol_attribute *
case AB_IN_COMMON:
attr->in_common = 1;
break;
- case AB_SAVED_COMMON:
- attr->saved_common = 1;
- break;
case AB_FUNCTION:
attr->function = 1;
break;
@@ -2274,6 +2266,15 @@ mio_gmp_real (mpf_t * real)
atom_string = gfc_getmem (strlen (p) + 20);
sprintf (atom_string, "0.%s@%ld", p, exponent);
+
+ /* Fix negative numbers. */
+ if (atom_string[2] == '-')
+ {
+ atom_string[0] = '-';
+ atom_string[1] = '0';
+ atom_string[2] = '.';
+ }
+
write_atom (ATOM_STRING, atom_string);
gfc_free (atom_string);
@@ -2670,7 +2671,6 @@ mio_symbol (gfc_symbol * sym)
}
/* Save/restore common block links */
- mio_symbol_ref (&sym->common_head);
mio_symbol_ref (&sym->common_next);
mio_formal_arglist (sym);
@@ -2689,9 +2689,6 @@ mio_symbol (gfc_symbol * sym)
sym->component_access =
MIO_NAME(gfc_access) (sym->component_access, access_types);
- mio_symbol_ref (&sym->common_head);
- mio_symbol_ref (&sym->common_next);
-
mio_rparen ();
}
@@ -2811,6 +2808,34 @@ load_generic_interfaces (void)
}
+/* Load common blocks. */
+
+static void
+load_commons(void)
+{
+ char name[GFC_MAX_SYMBOL_LEN+1];
+ gfc_common_head *p;
+
+ mio_lparen ();
+
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ mio_lparen ();
+ mio_internal_string (name);
+
+ p = gfc_get_common (name);
+
+ mio_symbol_ref (&p->head);
+ mio_integer (&p->saved);
+ p->use_assoc = 1;
+
+ mio_rparen();
+ }
+
+ mio_rparen();
+}
+
+
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
traversal, because the act of loading can alter the tree. */
@@ -2922,6 +2947,7 @@ read_module (void)
get_module_locus (&user_operators);
skip_list ();
skip_list ();
+ skip_list ();
mio_lparen ();
@@ -3058,6 +3084,8 @@ read_module (void)
load_operator_interfaces ();
load_generic_interfaces ();
+ load_commons ();
+
/* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets
marked as NEEDED if its previous state was UNUSED. */
@@ -3128,6 +3156,30 @@ check_access (gfc_access specific_access
}
+/* Write a common block to the module */
+
+static void
+write_common (gfc_symtree *st)
+{
+ gfc_common_head *p;
+
+ if (st == NULL)
+ return;
+
+ write_common(st->left);
+ write_common(st->right);
+
+ mio_lparen();
+ mio_internal_string(st->name);
+
+ p = st->n.common;
+ mio_symbol_ref(&p->head);
+ mio_integer(&p->saved);
+
+ mio_rparen();
+}
+
+
/* Write a symbol to the module. */
static void
@@ -3320,6 +3372,12 @@ write_module (void)
write_char ('\n');
write_char ('\n');
+ mio_lparen ();
+ write_common (gfc_current_ns->common_root);
+ mio_rparen ();
+ write_char ('\n');
+ write_char ('\n');
+
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
Sometimes writing one symbol will cause another to need to be
@@ -3338,7 +3396,7 @@ write_module (void)
write_char ('\n');
mio_lparen ();
- gfc_traverse_symtree (gfc_current_ns, write_symtree);
+ gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
mio_rparen ();
}
Index: parse.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/parse.c,v
retrieving revision 1.8
diff -u -p -r1.8 parse.c
--- parse.c 26 Jun 2004 11:48:55 -0000 1.8
+++ parse.c 26 Jun 2004 15:00:23 -0000
@@ -1,5 +1,6 @@
/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
+ Inc.
Contributed by Andy Vaught
This file is part of GCC.
@@ -2319,12 +2320,79 @@ done:
}
+/* Come here to complain about a global symbol already in use as
+ something else. */
+
+static void
+global_used (gfc_gsymbol *sym, locus *where)
+{
+ const char *name;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ switch(sym->type)
+ {
+ case GSYM_PROGRAM:
+ name = "PROGRAM";
+ break;
+ case GSYM_FUNCTION:
+ name = "FUNCTION";
+ break;
+ case GSYM_SUBROUTINE:
+ name = "SUBROUTINE";
+ break;
+ case GSYM_COMMON:
+ name = "COMMON";
+ break;
+ case GSYM_BLOCK_DATA:
+ name = "BLOCK DATA";
+ break;
+ case GSYM_MODULE:
+ name = "MODULE";
+ break;
+ default:
+ gfc_internal_error ("gfc_gsymbol_type(): Bad type");
+ name = NULL;
+ }
+
+ gfc_error("Global name '%s' at %L is already being used as a %s at %L",
+ gfc_new_block->name, where, name, &sym->where);
+}
+
+
/* Parse a block data program unit. */
static void
parse_block_data (void)
{
gfc_statement st;
+ static locus blank_locus;
+ static int blank_block=0;
+ gfc_gsymbol *s;
+
+ if (gfc_new_block == NULL)
+ {
+ if (blank_block)
+ gfc_error ("Blank BLOCK DATA at %C conflicts with "
+ "prior BLOCK DATA at %L", &blank_locus);
+ else
+ {
+ blank_block = 1;
+ blank_locus = gfc_current_locus;
+ }
+ }
+ else
+ {
+ s = gfc_get_gsymbol (gfc_new_block->name);
+ if (s->type != GSYM_UNKNOWN)
+ global_used(s, NULL);
+ else
+ {
+ s->type = GSYM_BLOCK_DATA;
+ s->where = gfc_current_locus;
+ }
+ }
st = parse_spec (ST_NONE);
@@ -2344,6 +2412,16 @@ static void
parse_module (void)
{
gfc_statement st;
+ gfc_gsymbol *s;
+
+ s = gfc_get_gsymbol (gfc_new_block->name);
+ if (s->type != GSYM_UNKNOWN)
+ global_used(s, NULL);
+ else
+ {
+ s->type = GSYM_MODULE;
+ s->where = gfc_current_locus;
+ }
st = parse_spec (ST_NONE);
@@ -2372,6 +2450,46 @@ loop:
}
+/* Add a procedure name to the global symbol table. */
+
+static void
+add_global_procedure (int sub)
+{
+ gfc_gsymbol *s;
+
+ s = gfc_get_gsymbol(gfc_new_block->name);
+
+ if (s->type != GSYM_UNKNOWN)
+ global_used(s, NULL);
+ else
+ {
+ s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+ s->where = gfc_current_locus;
+ }
+}
+
+
+/* Add a program to the global symbol table. */
+
+static void
+add_global_program (void)
+{
+ gfc_gsymbol *s;
+
+ if (gfc_new_block == NULL)
+ return;
+ s = gfc_get_gsymbol (gfc_new_block->name);
+
+ if (s->type != GSYM_UNKNOWN)
+ global_used(s, NULL);
+ else
+ {
+ s->type = GSYM_PROGRAM;
+ s->where = gfc_current_locus;
+ }
+}
+
+
/* Top level parser. */
try
@@ -2415,16 +2533,19 @@ loop:
push_state (&s, COMP_PROGRAM, gfc_new_block);
accept_statement (st);
+ add_global_program ();
parse_progunit (ST_NONE);
break;
case ST_SUBROUTINE:
+ add_global_procedure (1);
push_state (&s, COMP_SUBROUTINE, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
break;
case ST_FUNCTION:
+ add_global_procedure (0);
push_state (&s, COMP_FUNCTION, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
Index: symbol.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/symbol.c,v
retrieving revision 1.5
diff -u -p -r1.5 symbol.c
--- symbol.c 27 May 2004 12:35:12 -0000 1.5
+++ symbol.c 26 Jun 2004 15:00:23 -0000
@@ -88,6 +88,8 @@ static int next_dummy_order = 1;
gfc_namespace *gfc_current_ns;
+gfc_gsymbol *gfc_gsym_root = NULL;
+
static gfc_symbol *changed_syms = NULL;
@@ -671,24 +673,6 @@ gfc_add_save (symbol_attribute * attr, l
try
-gfc_add_saved_common (symbol_attribute * attr, locus * where)
-{
-
- if (check_used (attr, where))
- return FAILURE;
-
- if (attr->saved_common)
- {
- duplicate_attr ("SAVE", where);
- return FAILURE;
- }
-
- attr->saved_common = 1;
- return check_conflict (attr, where);
-}
-
-
-try
gfc_add_target (symbol_attribute * attr, locus * where)
{
@@ -720,22 +704,6 @@ gfc_add_dummy (symbol_attribute * attr,
try
-gfc_add_common (symbol_attribute * attr, locus * where)
-{
- /* TODO: We currently add common blocks into the same namespace as normal
- variables. This is wrong. Disable the checks below as a temporary
- hack. See PR13249 */
-#if 0
- if (check_used (attr, where) || check_done (attr, where))
- return FAILURE;
-#endif
-
- attr->common = 1;
- return check_conflict (attr, where);
-}
-
-
-try
gfc_add_in_common (symbol_attribute * attr, locus * where)
{
@@ -754,6 +722,18 @@ gfc_add_in_common (symbol_attribute * at
}
+try
+gfc_add_data (symbol_attribute *attr, locus *where)
+{
+
+ if (check_used (attr, where))
+ return FAILURE;
+
+ attr->data = 1;
+ return check_conflict(attr, where);
+}
+
+
try
gfc_add_in_namelist (symbol_attribute * attr, locus * where)
{
@@ -1059,7 +1039,6 @@ gfc_clear_attr (symbol_attribute * attr)
attr->save = 0;
attr->target = 0;
attr->dummy = 0;
- attr->common = 0;
attr->result = 0;
attr->entry = 0;
attr->data = 0;
@@ -1067,7 +1046,6 @@ gfc_clear_attr (symbol_attribute * attr)
attr->in_namelist = 0;
attr->in_common = 0;
- attr->saved_common = 0;
attr->function = 0;
attr->subroutine = 0;
attr->generic = 0;
@@ -1120,8 +1098,6 @@ gfc_copy_attr (symbol_attribute * dest,
goto fail;
if (src->dummy && gfc_add_dummy (dest, where) == FAILURE)
goto fail;
- if (src->common && gfc_add_common (dest, where) == FAILURE)
- goto fail;
if (src->result && gfc_add_result (dest, where) == FAILURE)
goto fail;
if (src->entry)
@@ -1132,8 +1108,6 @@ gfc_copy_attr (symbol_attribute * dest,
if (src->in_common && gfc_add_in_common (dest, where) == FAILURE)
goto fail;
- if (src->saved_common && gfc_add_saved_common (dest, where) == FAILURE)
- goto fail;
if (src->generic && gfc_add_generic (dest, where) == FAILURE)
goto fail;
@@ -2336,10 +2310,10 @@ traverse_symtree (gfc_symtree * st, void
void
-gfc_traverse_symtree (gfc_namespace * ns, void (*func) (gfc_symtree *))
+gfc_traverse_symtree (gfc_symtree * root, void (*func) (gfc_symtree *))
{
- traverse_symtree (ns->sym_root, func);
+ traverse_symtree (root, func);
}
@@ -2368,7 +2342,7 @@ void
gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
{
- gfc_traverse_symtree (ns, clear_sym_mark);
+ gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
traverse_ns (ns->sym_root, func);
}
@@ -2383,12 +2357,6 @@ save_symbol (gfc_symbol * sym)
if (sym->attr.use_assoc)
return;
- if (sym->attr.common)
- {
- gfc_add_saved_common (&sym->attr, &sym->declared_at);
- return;
- }
-
if (sym->attr.in_common
|| sym->attr.dummy
|| sym->attr.flavor != FL_VARIABLE)
@@ -2419,3 +2387,63 @@ gfc_symbol_state(void) {
}
#endif
+
+/************** Global symbol handling ************/
+
+
+/* Search a tree for the global symbol. */
+
+gfc_gsymbol *
+gfc_find_gsymbol (gfc_gsymbol *symbol, char *name)
+{
+ gfc_gsymbol *s;
+
+ if (symbol == NULL)
+ return NULL;
+ if (strcmp (symbol->name, name) == 0)
+ return symbol;
+
+ s = gfc_find_gsymbol (symbol->left, name);
+ if (s != NULL)
+ return s;
+
+ s = gfc_find_gsymbol (symbol->right, name);
+ if (s != NULL)
+ return s;
+
+ return NULL;
+}
+
+
+/* Compare two global symbols. Used for managing the BB tree. */
+
+static int
+gsym_compare (void * _s1, void * _s2)
+{
+ gfc_gsymbol *s1, *s2;
+
+ s1 = (gfc_gsymbol *)_s1;
+ s2 = (gfc_gsymbol *)_s2;
+ return strcmp(s1->name, s2->name);
+}
+
+
+/* Get a global symbol, creating it if it doesn't exist. */
+
+gfc_gsymbol *
+gfc_get_gsymbol (char *name)
+{
+ gfc_gsymbol *s;
+
+ s = gfc_find_gsymbol (gfc_gsym_root, name);
+ if (s != NULL)
+ return s;
+
+ s = gfc_getmem (sizeof (gfc_gsymbol));
+ s->type = GSYM_UNKNOWN;
+ strcpy (s->name, name);
+
+ gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
+
+ return s;
+}
Index: trans-common.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-common.c,v
retrieving revision 1.7
diff -u -p -r1.7 trans-common.c
--- trans-common.c 22 Jun 2004 03:07:01 -0000 1.7
+++ trans-common.c 26 Jun 2004 15:00:23 -0000
@@ -168,24 +168,24 @@ add_segments (segment_info *list, segmen
/* Construct mangled common block name from symbol name. */
static tree
-gfc_sym_mangled_common_id (gfc_symbol *sym)
+gfc_sym_mangled_common_id (const char *name)
{
int has_underscore;
- char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
- if (strcmp (sym->name, BLANK_COMMON_NAME) == 0)
- return get_identifier (sym->name);
+ if (strcmp (name, BLANK_COMMON_NAME) == 0)
+ return get_identifier (name);
if (gfc_option.flag_underscoring)
{
- has_underscore = strchr (sym->name, '_') != 0;
+ has_underscore = strchr (name, '_') != 0;
if (gfc_option.flag_second_underscore && has_underscore)
- snprintf (name, sizeof name, "%s__", sym->name);
+ snprintf (mangled_name, sizeof mangled_name, "%s__", name);
else
- snprintf (name, sizeof name, "%s_", sym->name);
- return get_identifier (name);
+ snprintf (mangled_name, sizeof mangled_name, "%s_", name);
+ return get_identifier (mangled_name);
}
else
- return get_identifier (sym->name);
+ return get_identifier (name);
}
@@ -252,7 +252,8 @@ build_equiv_decl (tree union_type, bool
/* Get storage for common block. */
static tree
-build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
+build_common_decl (gfc_common_head *com, const char *name,
+ tree union_type, bool is_init)
{
gfc_symbol *common_sym;
tree decl;
@@ -261,7 +262,7 @@ build_common_decl (gfc_symbol *sym, tree
if (gfc_common_ns == NULL)
gfc_common_ns = gfc_get_namespace (NULL);
- gfc_get_symbol (sym->name, gfc_common_ns, &common_sym);
+ gfc_get_symbol (name, gfc_common_ns, &common_sym);
decl = common_sym->backend_decl;
/* Update the size of this common block as needed. */
@@ -273,9 +274,9 @@ build_common_decl (gfc_symbol *sym, tree
/* 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 (sym->name, BLANK_COMMON_NAME))
+ if (strcmp (name, BLANK_COMMON_NAME))
gfc_warning ("Named COMMON block '%s' at %L shall be of the "
- "same size", sym->name, &sym->declared_at);
+ "same size", name, &com->where);
DECL_SIZE_UNIT (decl) = size;
}
}
@@ -289,8 +290,8 @@ build_common_decl (gfc_symbol *sym, tree
/* If there is no backend_decl for the common block, build it. */
if (decl == NULL_TREE)
{
- decl = build_decl (VAR_DECL, get_identifier (sym->name), union_type);
- SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (sym));
+ decl = build_decl (VAR_DECL, get_identifier (name), union_type);
+ SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (name));
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
@@ -323,7 +324,7 @@ build_common_decl (gfc_symbol *sym, tree
backend declarations for all of the elements. */
static void
-create_common (gfc_symbol *sym)
+create_common (gfc_common_head *com, const char *name)
{
segment_info *h, *next_s;
tree union_type;
@@ -354,8 +355,8 @@ create_common (gfc_symbol *sym)
}
finish_record_layout (rli, true);
- if (sym)
- decl = build_common_decl (sym, union_type, is_init);
+ if (com)
+ decl = build_common_decl (com, name, union_type, is_init);
else
decl = build_equiv_decl (union_type, is_init);
@@ -395,7 +396,7 @@ create_common (gfc_symbol *sym)
case BT_DERIVED:
gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, sym->value, 1);
+ gfc_conv_structure (&se, h->sym->value, 1);
break;
default:
@@ -725,7 +726,7 @@ add_equivalences (void)
and all of the symbols equivalenced with that symbol. */
static void
-new_segment (gfc_symbol *common_sym, gfc_symbol *sym)
+new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym)
{
HOST_WIDE_INT length;
@@ -742,7 +743,7 @@ new_segment (gfc_symbol *common_sym, gfc
if (current_segment->offset < 0)
gfc_error ("The equivalence set for '%s' cause an invalid extension "
"to COMMON '%s' at %L",
- sym->name, common_sym->name, &common_sym->declared_at);
+ sym->name, name, &common->where);
/* The offset of the next common variable. */
current_offset += length;
@@ -783,7 +784,7 @@ finish_equivalences (gfc_namespace *ns)
v->offset -= min_offset;
current_common = current_segment;
- create_common (NULL);
+ create_common (NULL, NULL);
break;
}
}
@@ -792,7 +793,8 @@ finish_equivalences (gfc_namespace *ns)
/* Translate a single common block. */
static void
-translate_common (gfc_symbol *common_sym, gfc_symbol *var_list)
+translate_common (gfc_common_head *common, const char *name,
+ gfc_symbol *var_list)
{
gfc_symbol *sym;
@@ -803,20 +805,19 @@ translate_common (gfc_symbol *common_sym
for (sym = var_list; sym; sym = sym->common_next)
{
if (! sym->equiv_built)
- new_segment (common_sym, sym);
+ new_segment (common, name, sym);
}
- create_common (common_sym);
+ create_common (common, name);
}
/* Work function for translating a named common block. */
static void
-named_common (gfc_symbol *s)
+named_common (gfc_symtree *st)
{
- if (s->attr.common)
- translate_common (s, s->common_head);
+ translate_common (st->n.common, st->name, st->n.common->head);
}
@@ -827,17 +828,17 @@ named_common (gfc_symbol *s)
void
gfc_trans_common (gfc_namespace *ns)
{
- gfc_symbol *sym;
+ gfc_common_head *c;
/* Translate the blank common block. */
- if (ns->blank_common != NULL)
+ if (ns->blank_common.head != NULL)
{
- gfc_get_symbol (BLANK_COMMON_NAME, ns, &sym);
- translate_common (sym, ns->blank_common);
+ c = gfc_get_common_head ();
+ translate_common (c, BLANK_COMMON_NAME, ns->blank_common.head);
}
/* Translate all named common blocks. */
- gfc_traverse_ns (ns, named_common);
+ gfc_traverse_symtree (ns->common_root, named_common);
/* Commit the newly created symbols for common blocks. */
gfc_commit_symbols ();
Index: trans-decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.14
diff -u -p -r1.14 trans-decl.c
--- trans-decl.c 22 Jun 2004 03:07:01 -0000 1.14
+++ trans-decl.c 26 Jun 2004 15:00:24 -0000
@@ -1787,10 +1787,6 @@ gfc_create_module_variable (gfc_symbol *
internal_error ("module symbol %s in wrong namespace", sym->name);
}
- /* Don't ouptut symbols from common blocks. */
- if (sym->attr.common)
- return;
-
/* Only output variables and array valued parametes. */
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))