From 9056bd70254731635be255e7aed12fae1aa3705f Mon Sep 17 00:00:00 2001 From: =?utf8?q?Tobias=20Schl=C3=BCter?= Date: Tue, 29 Jun 2004 20:57:25 +0200 Subject: [PATCH] Andrew Vaught 2004-06-29 Tobias Schlueter Andrew Vaught 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 description. (ab_attribute, attr_bits, mio_symbol_attributes): Remove code for removed attributes. (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. (traverse_symtree): Remove. (gfc_traverse_symtree): Don't traverse symbol tree of the passed namespace, but require a symtree to be passed instead. Unify with traverse_symtree. (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. Co-Authored-By: Andrew Vaught From-SVN: r83871 --- gcc/fortran/ChangeLog | 67 ++++++++++++++++++++++++++ gcc/fortran/decl.c | 16 ++++-- gcc/fortran/dump-parse-tree.c | 15 +----- gcc/fortran/gfortran.h | 30 +++++++++--- gcc/fortran/match.c | 91 ++++++++++++++++++++++++++--------- gcc/fortran/match.h | 4 ++ gcc/fortran/module.c | 89 ++++++++++++++++++++++++++-------- gcc/fortran/parse.c | 3 +- gcc/fortran/symbol.c | 77 +++++++---------------------- gcc/fortran/trans-common.c | 67 +++++++++++++------------- gcc/fortran/trans-decl.c | 4 -- 11 files changed, 298 insertions(+), 165 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 54f5c80560c..1623cb75d58 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,70 @@ +2004-06-29 Tobias Schlueter + Andrew Vaught + + 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 description. + (ab_attribute, attr_bits, mio_symbol_attributes): Remove code + for removed attributes. + (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. + (traverse_symtree): Remove. + (gfc_traverse_symtree): Don't traverse symbol + tree of the passed namespace, but require a symtree to be passed + instead. Unify with traverse_symtree. + (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. + 2004-06-29 Tobias Schlueter * io.c: Add 2004 to copyright years. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 4ccb0d4a6f8..fab762fc63e 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2427,6 +2427,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 +2471,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: diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 64e4a81ee7d..3b7fc6911c4 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -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++) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index bfd52e4b656..d35506ae6e6 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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]; @@ -1447,6 +1462,7 @@ try gfc_add_dummy (symbol_attribute *, locus *); 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 *); @@ -1501,7 +1517,7 @@ 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 *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index bc2379db49c..d605361ec03 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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; } diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 6cff5cc0aa0..85729ec0ae8 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -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 **); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index cf8f453400a..7f720ba9770 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -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 - Suite 330, Boston, MA ( ( ... ) ... ) + ( ( ) + ... + ) ( @@ -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 * attr) 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 * attr) 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 * attr) 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 * attr) 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; @@ -2679,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); @@ -2698,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 (); } @@ -2820,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. */ @@ -2931,6 +2947,7 @@ read_module (void) get_module_locus (&user_operators); skip_list (); skip_list (); + skip_list (); mio_lparen (); @@ -3067,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. */ @@ -3137,6 +3156,30 @@ check_access (gfc_access specific_access, gfc_access default_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 @@ -3329,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 @@ -3347,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 (); } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 812df4d8401..3f9ca813c65 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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. diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 4b5f34e6d2d..c1d0212a13e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -672,24 +672,6 @@ gfc_add_save (symbol_attribute * attr, locus * where) } -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) { @@ -721,22 +703,6 @@ gfc_add_dummy (symbol_attribute * attr, locus * where) } -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) { @@ -756,6 +722,18 @@ gfc_add_in_common (symbol_attribute * attr, locus * where) } +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) { @@ -1061,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; @@ -1069,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; @@ -1122,8 +1098,6 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) 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) @@ -1134,8 +1108,6 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) 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; @@ -2323,28 +2295,19 @@ clear_sym_mark (gfc_symtree * st) /* Recursively traverse the symtree nodes. */ -static void -traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *)) +void +gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *)) { - if (st != NULL) { (*func) (st); - traverse_symtree (st->left, func); - traverse_symtree (st->right, func); + gfc_traverse_symtree (st->left, func); + gfc_traverse_symtree (st->right, func); } } -void -gfc_traverse_symtree (gfc_namespace * ns, void (*func) (gfc_symtree *)) -{ - - traverse_symtree (ns->sym_root, func); -} - - /* Recursive namespace traversal function. */ static void @@ -2370,7 +2333,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); } @@ -2385,12 +2348,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) diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index f0c385adfbb..769469d9cca 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -168,24 +168,24 @@ add_segments (segment_info *list, segment_info *v) /* 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 is_init) /* 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 union_type, bool is_init) 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 union_type, bool is_init) /* 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 union_type, bool is_init) /* 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 union_type, bool is_init) 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_symbol *sym) 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, gfc_symbol *var_list) 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 (); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 8cf6cbb185d..e6424671680 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1787,10 +1787,6 @@ gfc_create_module_variable (gfc_symbol * sym) 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)) -- 2.30.2