From 30aabb86ef4252ad2df0d3a56c364b824a2e5245 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 9 Sep 2005 00:23:09 +0000 Subject: [PATCH] re PR fortran/18878 ([4.0 only] erronous error message on vaild USE statement) 2005-09-09 Paul Thomas PR fortran/18878 * module.c (find_use_name_n): Based on original find_use_name. Either counts number of use names for a given real name or returns use name n. (find_use_name, number_use_names): Interfaces to the function find_use_name_n. (read_module): Add the logic and calls to these functions, so that mutiple reuses of the same real name are loaded. 2005-09-09 Paul Thomas PR fortran/22304 PR fortran/23270 PR fortran/18870 PR fortran/16511 PR fortran/17917 * gfortran.h: Move definition of BLANK_COMMON_NAME from trans- common.c so that it is accessible to module.c. Add common_head field to gfc_symbol structure. Add field for the equivalence name AND new attr field, in_equivalence. * match.c (gfc_match_common, gfc_match_equivalence): In loops that flag common block equivalences, emit an error if the common blocks are different, using sym->common_head as the common block identifier. Ensure that symbols that are equivalence associated with a common block are marked as being in_common. * module.c (write_blank_common): New. (write_common): Use unmangled common block name. (load_equiv): New function ported from g95. (read_module): Call load_equiv. (write_equiv): New function ported from g95. Correct string referencing for gfc functions. Give module equivalences a unique name. (write_module): Call write_equiv and write_blank_common. * primary.c (match_variable) Old gfc_match_variable, made static and third argument provided to indicate if parent namespace to be visited or not. (gfc_match_variable) New. Interface to match_variable. (gfc_match_equiv_variable) New. Interface to match_variable. * trans-common.c (finish_equivalences): Provide the call to create_common with a gfc_common_header so that module equivalences are made external, rather than local. (find_equivalences): Ensure that all members in common block equivalences are marked as used. This prevents the subsequent call to this function from making local unions. * trans-decl.c (gfc_generate_function_code): Move the call to gfc_generate_contained_functions to after the call to gfc_trans_common so the use-associated, contained common blocks produce the correct references. (gfc_create_module_variable): Return for equivalenced symbols with existing backend declaration. 2005-09-09 Paul Thomas PR fortran/18878 * gfortran.dg/module_double_reuse.f90: New. 2005-09-09 Paul Thomas PR fortran/23270 PR fortran/22304 PR fortran/18870 PR fortran/17917 PR fortran/16511 * gfortran.dg/common_equivalence_1.f: New. * gfortran.dg/common_equivalence_2.f: New. * gfortran.dg/common_equivalence_3.f: New. * gfortran.dg/contained_equivalence_1.f90: New. * gfortran.dg/module_blank_common.f90: New. * gfortran.dg/module_commons_1.f90: New. * gfortran.dg/module_equivalence_1.f90: New. * gfortran.dg/nested_modules_1.f90: New. * gfortran.dg/g77/19990905-0.f: Remove XFAIL, rearrange equivalences and add comment to connect the test with the PR. From-SVN: r104060 --- gcc/fortran/ChangeLog | 53 ++++ gcc/fortran/gfortran.h | 14 +- gcc/fortran/match.c | 75 +++++- gcc/fortran/module.c | 235 ++++++++++++++---- gcc/fortran/primary.c | 26 +- gcc/fortran/trans-common.c | 87 ++++--- gcc/fortran/trans-decl.c | 8 +- gcc/testsuite/ChangeLog | 24 ++ .../gfortran.dg/common_equivalence_1.f | 21 ++ .../gfortran.dg/common_equivalence_2.f | 13 + .../gfortran.dg/common_equivalence_3.f | 14 ++ .../gfortran.dg/contained_equivalence_1.f90 | 18 ++ .../gfortran.dg/module_blank_common.f90 | 19 ++ .../gfortran.dg/module_commons_1.f90 | 24 ++ .../gfortran.dg/module_double_reuse.f90 | 19 ++ .../gfortran.dg/module_equivalence_1.f90 | 26 ++ .../gfortran.dg/nested_modules_1.f90 | 43 ++++ 17 files changed, 630 insertions(+), 89 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/common_equivalence_1.f create mode 100644 gcc/testsuite/gfortran.dg/common_equivalence_2.f create mode 100644 gcc/testsuite/gfortran.dg/common_equivalence_3.f create mode 100644 gcc/testsuite/gfortran.dg/contained_equivalence_1.f90 create mode 100755 gcc/testsuite/gfortran.dg/module_blank_common.f90 create mode 100644 gcc/testsuite/gfortran.dg/module_commons_1.f90 create mode 100755 gcc/testsuite/gfortran.dg/module_double_reuse.f90 create mode 100644 gcc/testsuite/gfortran.dg/module_equivalence_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/nested_modules_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f1974a39c06..6cc04bd6a91 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,56 @@ +2005-09-09 Paul Thomas + + PR fortran/18878 + * module.c (find_use_name_n): Based on original + find_use_name. Either counts number of use names for a + given real name or returns use name n. + (find_use_name, number_use_names): Interfaces to the + function find_use_name_n. + (read_module): Add the logic and calls to these functions, + so that mutiple reuses of the same real name are loaded. + +2005-09-09 Paul Thomas + + PR fortran/22304 + PR fortran/23270 + PR fortran/18870 + PR fortran/16511 + PR fortran/17917 + * gfortran.h: Move definition of BLANK_COMMON_NAME from trans- + common.c so that it is accessible to module.c. Add common_head + field to gfc_symbol structure. Add field for the equivalence + name AND new attr field, in_equivalence. + * match.c (gfc_match_common, gfc_match_equivalence): In loops + that flag common block equivalences, emit an error if the + common blocks are different, using sym->common_head as the + common block identifier. Ensure that symbols that are equivalence + associated with a common block are marked as being in_common. + * module.c (write_blank_common): New. + (write_common): Use unmangled common block name. + (load_equiv): New function ported from g95. + (read_module): Call load_equiv. + (write_equiv): New function ported from g95. Correct + string referencing for gfc functions. Give module + equivalences a unique name. + (write_module): Call write_equiv and write_blank_common. + * primary.c (match_variable) Old gfc_match_variable, made + static and third argument provided to indicate if parent + namespace to be visited or not. + (gfc_match_variable) New. Interface to match_variable. + (gfc_match_equiv_variable) New. Interface to match_variable. + * trans-common.c (finish_equivalences): Provide the call + to create_common with a gfc_common_header so that + module equivalences are made external, rather than local. + (find_equivalences): Ensure that all members in common block + equivalences are marked as used. This prevents the subsequent + call to this function from making local unions. + * trans-decl.c (gfc_generate_function_code): Move the call to + gfc_generate_contained_functions to after the call to + gfc_trans_common so the use-associated, contained common + blocks produce the correct references. + (gfc_create_module_variable): Return for equivalenced symbols + with existing backend declaration. + 2005-09-08 Tobias Schl"uter PR fortran/23765 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ed9fcba819f..59e1bead111 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -77,6 +77,8 @@ char *alloca (); #define PREFIX(x) "_gfortran_" x #define PREFIX_LEN 10 +#define BLANK_COMMON_NAME "__BLNK__" + /* Macro to initialize an mstring structure. */ #define minit(s, t) { s, NULL, t } @@ -419,7 +421,7 @@ typedef struct 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; + unsigned in_namelist:1, in_common:1, in_equivalence:1; unsigned function:1, subroutine:1, generic:1; unsigned implicit_type:1; /* Type defined via implicit rules. */ unsigned untyped:1; /* No implicit type could be found. */ @@ -706,6 +708,11 @@ typedef struct gfc_symbol gfc_component *components; /* Derived type components */ struct gfc_symbol *common_next; /* Links for COMMON syms */ + + /* This is in fact a gfc_common_head but it is only used for pointer + comparisons to check if symbols are in the same common block. */ + struct gfc_common_head* common_head; + /* Make sure setup code for dummy arguments is generated in the correct order. */ int dummy_order; @@ -734,12 +741,12 @@ gfc_symbol; /* This structure is used to keep track of symbols in common blocks. */ -typedef struct +typedef struct gfc_common_head { locus where; int use_assoc, saved; char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symbol *head; + struct gfc_symbol *head; } gfc_common_head; @@ -1194,6 +1201,7 @@ typedef struct gfc_equiv { struct gfc_equiv *next, *eq; gfc_expr *expr; + const char *module; int used; } gfc_equiv; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 67c7c96f1dd..5a626334272 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2226,10 +2226,11 @@ match_common_name (char *name) match gfc_match_common (void) { - gfc_symbol *sym, **head, *tail, *old_blank_common; + gfc_symbol *sym, **head, *tail, *other, *old_blank_common; char name[GFC_MAX_SYMBOL_LEN+1]; gfc_common_head *t; gfc_array_spec *as; + gfc_equiv * e1, * e2; match m; old_blank_common = gfc_current_ns->blank_common.head; @@ -2348,8 +2349,46 @@ gfc_match_common (void) sym->as = as; as = NULL; + } + sym->common_head = t; + + /* Check to see if the symbol is already in an equivalence group. + If it is, set the other members as being in common. */ + if (sym->attr.in_equivalence) + { + for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) + { + for (e2 = e1; e2; e2 = e2->eq) + if (e2->expr->symtree->n.sym == sym) + goto equiv_found; + + continue; + + equiv_found: + + for (e2 = e1; e2; e2 = e2->eq) + { + other = e2->expr->symtree->n.sym; + if (other->common_head + && other->common_head != sym->common_head) + { + gfc_error ("Symbol '%s', in COMMON block '%s' at " + "%C is being indirectly equivalenced to " + "another COMMON block '%s'", + sym->name, + sym->common_head->name, + other->common_head->name); + goto cleanup; + } + other->attr.in_common = 1; + other->common_head = t; + } + } + } + + gfc_gobble_whitespace (); if (gfc_match_eos () == MATCH_YES) goto done; @@ -2553,7 +2592,10 @@ gfc_match_equivalence (void) { gfc_equiv *eq, *set, *tail; gfc_ref *ref; + gfc_symbol *sym; match m; + gfc_common_head *common_head = NULL; + bool common_flag; tail = NULL; @@ -2570,10 +2612,11 @@ gfc_match_equivalence (void) goto syntax; set = eq; + common_flag = FALSE; for (;;) { - m = gfc_match_variable (&set->expr, 1); + m = gfc_match_equiv_variable (&set->expr); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) @@ -2588,6 +2631,14 @@ gfc_match_equivalence (void) goto cleanup; } + if (set->expr->symtree->n.sym->attr.in_common) + { + common_flag = TRUE; + common_head = set->expr->symtree->n.sym->common_head; + } + + set->expr->symtree->n.sym->attr.in_equivalence = 1; + if (gfc_match_char (')') == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) @@ -2597,6 +2648,26 @@ gfc_match_equivalence (void) set = set->eq; } + /* If one of the members of an equivalence is in common, then + mark them all as being in common. Before doing this, check + that members of the equivalence group are not in different + common blocks. */ + if (common_flag) + for (set = eq; set; set = set->eq) + { + sym = set->expr->symtree->n.sym; + if (sym->common_head && sym->common_head != common_head) + { + gfc_error ("Attempt to indirectly overlap COMMON " + "blocks %s and %s by EQUIVALENCE at %C", + sym->common_head->name, + common_head->name); + goto cleanup; + } + sym->attr.in_common = 1; + sym->common_head = common_head; + } + if (gfc_match_eos () == MATCH_YES) break; if (gfc_match_char (',') != MATCH_YES) diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index db510fdbc36..b11a16baff1 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -47,6 +47,9 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ( ( ) ... ) + + ( equivalence list ) + ( @@ -582,20 +585,34 @@ syntax: cleanup: free_rename (); return MATCH_ERROR; -} + } -/* Given a name, return the name under which to load this symbol. - Returns NULL if this symbol shouldn't be loaded. */ +/* Given a name and a number, inst, return the inst name + under which to load this symbol. Returns NULL if this + symbol shouldn't be loaded. If inst is zero, returns + the number of instances of this name. */ static const char * -find_use_name (const char *name) +find_use_name_n (const char *name, int *inst) { gfc_use_rename *u; + int i; + i = 0; for (u = gfc_rename_list; u; u = u->next) - if (strcmp (u->use_name, name) == 0) - break; + { + if (strcmp (u->use_name, name) != 0) + continue; + if (++i == *inst) + break; + } + + if (!*inst) + { + *inst = i; + return NULL; + } if (u == NULL) return only_flag ? NULL : name; @@ -605,6 +622,28 @@ find_use_name (const char *name) return (u->local_name[0] != '\0') ? u->local_name : name; } +/* Given a name, return the name under which to load this symbol. + Returns NULL if this symbol shouldn't be loaded. */ + +static const char * +find_use_name (const char *name) +{ + int i = 1; + return find_use_name_n (name, &i); +} + +/* Given a real name, return the number of use names associated + with it. */ + +static int +number_use_names (const char *name) +{ + int i = 0; + const char *c; + c = find_use_name_n (name, &i); + return i; +} + /* Try to find the operator in the current list. */ @@ -2920,6 +2959,48 @@ load_commons(void) mio_rparen(); } +/* load_equiv()-- Load equivalences. */ + +static void +load_equiv(void) +{ + gfc_equiv *head, *tail, *end; + + mio_lparen(); + + end = gfc_current_ns->equiv; + while(end != NULL && end->next != NULL) + end = end->next; + + while(peek_atom() != ATOM_RPAREN) { + mio_lparen(); + head = tail = NULL; + + while(peek_atom() != ATOM_RPAREN) + { + if (head == NULL) + head = tail = gfc_get_equiv(); + else + { + tail->eq = gfc_get_equiv(); + tail = tail->eq; + } + + mio_pool_string(&tail->module); + mio_expr(&tail->expr); + } + + if (end == NULL) + gfc_current_ns->equiv = head; + else + end->next = head; + + end = head; + 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 @@ -3020,7 +3101,7 @@ read_module (void) const char *p; char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_intrinsic_op i; - int ambiguous, symbol; + int ambiguous, symbol, j, nuse; pointer_info *info; gfc_use_rename *u; gfc_symtree *st; @@ -3032,6 +3113,9 @@ read_module (void) get_module_locus (&user_operators); skip_list (); skip_list (); + + /* Skip commons and equivalences for now. */ + skip_list (); skip_list (); mio_lparen (); @@ -3084,50 +3168,60 @@ read_module (void) info = get_integer (symbol); - /* Get the local name for this symbol. */ - p = find_use_name (name); + /* See how many use names there are. If none, go through the start + of the loop at least once. */ + nuse = number_use_names (name); + if (nuse == 0) + nuse = 1; - /* Skip symtree nodes not in an ONLY caluse. */ - if (p == NULL) - continue; - - /* Check for ambiguous symbols. */ - st = gfc_find_symtree (gfc_current_ns->sym_root, p); - - if (st != NULL) + for (j = 1; j <= nuse; j++) { - if (st->n.sym != info->u.rsym.sym) - st->ambiguous = 1; - info->u.rsym.symtree = st; - } - else - { - /* Create a symtree node in the current namespace for this symbol. */ - st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) : - gfc_new_symtree (&gfc_current_ns->sym_root, p); + /* Get the jth local name for this symbol. */ + p = find_use_name_n (name, &j); - st->ambiguous = ambiguous; + /* Skip symtree nodes not in an ONLY clause. */ + if (p == NULL) + continue; - sym = info->u.rsym.sym; + /* Check for ambiguous symbols. */ + st = gfc_find_symtree (gfc_current_ns->sym_root, p); - /* Create a symbol node if it doesn't already exist. */ - if (sym == NULL) + if (st != NULL) { - sym = info->u.rsym.sym = - gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns); - - sym->module = gfc_get_string (info->u.rsym.module); + if (st->n.sym != info->u.rsym.sym) + st->ambiguous = 1; + info->u.rsym.symtree = st; } + else + { + /* Create a symtree node in the current namespace for this symbol. */ + st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) : + gfc_new_symtree (&gfc_current_ns->sym_root, p); - st->n.sym = sym; - st->n.sym->refs++; + st->ambiguous = ambiguous; - /* Store the symtree pointing to this symbol. */ - info->u.rsym.symtree = st; + sym = info->u.rsym.sym; - if (info->u.rsym.state == UNUSED) - info->u.rsym.state = NEEDED; - info->u.rsym.referenced = 1; + /* Create a symbol node if it doesn't already exist. */ + if (sym == NULL) + { + sym = info->u.rsym.sym = + gfc_new_symbol (info->u.rsym.true_name + , gfc_current_ns); + + sym->module = gfc_get_string (info->u.rsym.module); + } + + st->n.sym = sym; + st->n.sym->refs++; + + /* Store the symtree pointing to this symbol. */ + info->u.rsym.symtree = st; + + if (info->u.rsym.state == UNUSED) + info->u.rsym.state = NEEDED; + info->u.rsym.referenced = 1; + } } } @@ -3170,6 +3264,7 @@ read_module (void) load_generic_interfaces (); load_commons (); + load_equiv(); /* At this point, we read those symbols that are needed but haven't been loaded yet. If one symbol requires another, the other gets @@ -3241,6 +3336,7 @@ static void write_common (gfc_symtree *st) { gfc_common_head *p; + const char * name; if (st == NULL) return; @@ -3249,7 +3345,11 @@ write_common (gfc_symtree *st) write_common(st->right); mio_lparen(); - mio_pool_string(&st->name); + + /* Write the unmangled name. */ + name = st->n.common->name; + + mio_pool_string(&name); p = st->n.common; mio_symbol_ref(&p->head); @@ -3258,6 +3358,51 @@ write_common (gfc_symtree *st) mio_rparen(); } +/* Write the blank common block to the module */ + +static void +write_blank_common (void) +{ + const char * name = BLANK_COMMON_NAME; + + if (gfc_current_ns->blank_common.head == NULL) + return; + + mio_lparen(); + + mio_pool_string(&name); + + mio_symbol_ref(&gfc_current_ns->blank_common.head); + mio_integer(&gfc_current_ns->blank_common.saved); + + mio_rparen(); +} + +/* Write equivalences to the module. */ + +static void +write_equiv(void) +{ + gfc_equiv *eq, *e; + int num; + + num = 0; + for(eq=gfc_current_ns->equiv; eq; eq=eq->next) + { + mio_lparen(); + + for(e=eq; e; e=e->eq) + { + if (e->module == NULL) + e->module = gfc_get_string("%s.eq.%d", module_name, num); + mio_allocated_string(e->module); + mio_expr(&e->expr); + } + + num++; + mio_rparen(); + } +} /* Write a symbol to the module. */ @@ -3444,11 +3589,17 @@ write_module (void) write_char ('\n'); mio_lparen (); + write_blank_common (); write_common (gfc_current_ns->common_root); mio_rparen (); write_char ('\n'); write_char ('\n'); + mio_lparen(); + write_equiv(); + 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 diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 560b5facfff..48a5f347d9c 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -2173,10 +2173,15 @@ gfc_match_rvalue (gfc_expr ** result) starts as a symbol, can be a structure component or an array reference. It can be a function if the function doesn't have a separate RESULT variable. If the symbol has not been previously - seen, we assume it is a variable. */ + seen, we assume it is a variable. -match -gfc_match_variable (gfc_expr ** result, int equiv_flag) + This function is called by two interface functions: + gfc_match_variable, which has host_flag = 1, and + gfc_match_equiv_variable, with host_flag = 0, to restrict the + match of the symbol to the local scope. */ + +static match +match_variable (gfc_expr ** result, int equiv_flag, int host_flag) { gfc_symbol *sym; gfc_symtree *st; @@ -2184,7 +2189,7 @@ gfc_match_variable (gfc_expr ** result, int equiv_flag) locus where; match m; - m = gfc_match_sym_tree (&st, 1); + m = gfc_match_sym_tree (&st, host_flag); if (m != MATCH_YES) return m; where = gfc_current_locus; @@ -2258,3 +2263,16 @@ gfc_match_variable (gfc_expr ** result, int equiv_flag) *result = expr; return MATCH_YES; } + +match +gfc_match_variable (gfc_expr ** result, int equiv_flag) +{ + return match_variable (result, equiv_flag, 1); +} + +match +gfc_match_equiv_variable (gfc_expr ** result) +{ + return match_variable (result, 1, 0); +} + diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index ecdfd2c53ed..039d86da662 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -119,8 +119,6 @@ typedef struct segment_info static segment_info * current_segment; static gfc_namespace *gfc_common_ns = NULL; -#define BLANK_COMMON_NAME "__BLNK__" - /* Make a segment_info based on a symbol. */ static segment_info * @@ -665,46 +663,45 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) /* Given a segment element, search through the equivalence lists for unused - conditions that involve the symbol. Add these rules to the segment. Only - checks for rules involving the first symbol in the equivalence set. */ - + conditions that involve the symbol. Add these rules to the segment. */ + static bool find_equivalence (segment_info *n) { - gfc_equiv *e1, *e2, *eq, *other; + gfc_equiv *e1, *e2, *eq; bool found; - + found = FALSE; + for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) { - other = NULL; - for (e2 = e1->eq; e2; e2 = e2->eq) - { - if (e2->used) - continue; + eq = NULL; - if (e1->expr->symtree->n.sym == n->sym) - { - eq = e1; - other = e2; - } - else if (e2->expr->symtree->n.sym == n->sym) + /* Search the equivalence list, including the root (first) element + for the symbol that owns the segment. */ + for (e2 = e1; e2; e2 = e2->eq) + { + if (!e2->used && e2->expr->symtree->n.sym == n->sym) { eq = e2; - other = e1; + break; } - else - eq = NULL; - - if (eq) + } + + /* Go to the next root element. */ + if (eq == NULL) + continue; + + eq->used = 1; + + /* Now traverse the equivalence list matching the offsets. */ + for (e2 = e1; e2; e2 = e2->eq) + { + if (!e2->used && e2 != eq) { - add_condition (n, eq, other); - eq->used = 1; + add_condition (n, eq, e2); + e2->used = 1; found = TRUE; - /* If this symbol is the first in the chain we may find other - matches. Otherwise we can skip to the next equivalence. */ - if (eq == e2) - break; } } } @@ -813,12 +810,14 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list) /* Add symbols to the segment. */ for (sym = var_list; sym; sym = sym->common_next) { - if (sym->equiv_built) - { - /* Symbol has already been added via an equivalence. */ - current_segment = common_segment; - s = find_segment_info (sym); + current_segment = common_segment; + s = find_segment_info (sym); + /* Symbol has already been added via an equivalence. Multiple + use associations of the same common block result in equiv_built + being set but no information about the symbol in the segment. */ + if (s && sym->equiv_built) + { /* Ensure the current location is properly aligned. */ align = TYPE_ALIGN_UNIT (s->field); current_offset = (current_offset + align - 1) &~ (align - 1); @@ -893,6 +892,7 @@ finish_equivalences (gfc_namespace *ns) { gfc_equiv *z, *y; gfc_symbol *sym; + gfc_common_head * c; HOST_WIDE_INT offset; unsigned HOST_WIDE_INT align; bool dummy; @@ -916,8 +916,23 @@ finish_equivalences (gfc_namespace *ns) apply_segment_offset (current_segment, offset); - /* Create the decl. */ - create_common (NULL, current_segment, true); + /* Create the decl. If this is a module equivalence, it has a unique + name, pointed to by z->module. This is written to a gfc_common_header + to push create_common into using build_common_decl, so that the + equivalence appears as an external symbol. Otherwise, a local + declaration is built using build_equiv_decl.*/ + if (z->module) + { + c = gfc_get_common_head (); + /* We've lost the real location, so use the location of the + enclosing procedure. */ + c->where = ns->proc_name->declared_at; + strcpy (c->name, z->module); + } + else + c = NULL; + + create_common (c, current_segment, true); break; } } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index aaa4006da63..1b568407bd3 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2160,6 +2160,10 @@ gfc_create_module_variable (gfc_symbol * sym) if (sym->attr.use_assoc || sym->attr.in_common) return; + /* Equivalenced variables arrive here after creation. */ + if (sym->backend_decl && sym->equiv_built) + return; + if (sym->backend_decl) internal_error ("backend decl for module variable %s already exists", sym->name); @@ -2336,8 +2340,6 @@ gfc_generate_function_code (gfc_namespace * ns) gfc_start_block (&block); - gfc_generate_contained_functions (ns); - if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER) { /* Copy length backend_decls to all entry point result @@ -2354,6 +2356,8 @@ gfc_generate_function_code (gfc_namespace * ns) /* Translate COMMON blocks. */ gfc_trans_common (ns); + gfc_generate_contained_functions (ns); + generate_local_vars (ns); current_function_return_label = NULL; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f6ab8fba3cb..a9753daa32f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,27 @@ +2005-09-09 Paul Thomas + + PR fortran/18878 + * gfortran.dg/module_double_reuse.f90: New. + +2005-09-09 Paul Thomas + + PR fortran/23270 + PR fortran/22304 + PR fortran/18870 + PR fortran/17917 + PR fortran/16511 + * gfortran.dg/common_equivalence_1.f: New. + * gfortran.dg/common_equivalence_2.f: New. + * gfortran.dg/common_equivalence_3.f: New. + * gfortran.dg/contained_equivalence_1.f90: New. + * gfortran.dg/module_blank_common.f90: New. + * gfortran.dg/module_commons_1.f90: New. + * gfortran.dg/module_equivalence_1.f90: New. + * gfortran.dg/nested_modules_1.f90: New. + * gfortran.dg/g77/19990905-0.f: Remove XFAIL, rearrange + equivalences and add comment to connect the test with + the PR. + 2005-09-08 Tobias Schl"uter PR fortran/23765 diff --git a/gcc/testsuite/gfortran.dg/common_equivalence_1.f b/gcc/testsuite/gfortran.dg/common_equivalence_1.f new file mode 100644 index 00000000000..2f15b93a4ae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/common_equivalence_1.f @@ -0,0 +1,21 @@ +c { dg-do run } +c This program tests the fix for PR22304. +c +c provided by Paul Thomas - pault@gcc.gnu.org +c + integer a(2), b, c + COMMON /foo/ a + EQUIVALENCE (a(1),b), (c, a(2)) + a(1) = 101 + a(2) = 102 + call bar () + END + + subroutine bar () + integer a(2), b, c, d + COMMON /foo/ a + EQUIVALENCE (a(1),b), (c, a(2)) + if (b.ne.101) call abort () + if (c.ne.102) call abort () + END + diff --git a/gcc/testsuite/gfortran.dg/common_equivalence_2.f b/gcc/testsuite/gfortran.dg/common_equivalence_2.f new file mode 100644 index 00000000000..be25fcd3d42 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/common_equivalence_2.f @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/18870 +! + program main + common /foo/ a + common /bar/ b + equivalence (a,c) + equivalence (b,c) ! { dg-error "indirectly overlap COMMON" } + c=3. + print *,a + print *,b + end + diff --git a/gcc/testsuite/gfortran.dg/common_equivalence_3.f b/gcc/testsuite/gfortran.dg/common_equivalence_3.f new file mode 100644 index 00000000000..6acd46aa352 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/common_equivalence_3.f @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/18870 +! + program main + equivalence (a,c) + equivalence (b,c) + common /foo/ a + common /bar/ b ! { dg-error "equivalenced to another COMMON" } + c=3. + print *,a + print *,b + end + + diff --git a/gcc/testsuite/gfortran.dg/contained_equivalence_1.f90 b/gcc/testsuite/gfortran.dg/contained_equivalence_1.f90 new file mode 100644 index 00000000000..7c6b0126cdb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/contained_equivalence_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! This program tests that equivalence only associates variables in +! the same scope. +! +! provided by Paul Thomas - pault@gcc.gnu.org +! +program contained_equiv + real a + a = 1.0 + call foo () + if (a.ne.1.0) call abort () +contains + subroutine foo () + real b + equivalence (a, b) + b = 2.0 + end subroutine foo +end program contained_equiv diff --git a/gcc/testsuite/gfortran.dg/module_blank_common.f90 b/gcc/testsuite/gfortran.dg/module_blank_common.f90 new file mode 100755 index 00000000000..23bb48ab009 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_blank_common.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! +! This tests that blank common works in modules. PR23270 +! Contributed by Paul Thomas +! +module global + common a, b + real a, b +end module global +program blank_common + use global + common z + complex z + a = 999.0_4 + b = -999.0_4 + if (z.ne.cmplx (a,b)) call abort () +end program blank_common + + diff --git a/gcc/testsuite/gfortran.dg/module_commons_1.f90 b/gcc/testsuite/gfortran.dg/module_commons_1.f90 new file mode 100644 index 00000000000..996074c0778 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_commons_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! This program tests that use associated common blocks work. +! +! provided by Paul Thomas - pault@gcc.gnu.org +! +module m1 + common /x/ a +end module m1 +module m2 + common /x/ a +end module m2 + +subroutine foo () + use m2 + if (a.ne.99.0) call abort () +end subroutine foo + +program collision + use m1 + use m2, only: b=>a + b = 99.0 + call foo () +end program collision + diff --git a/gcc/testsuite/gfortran.dg/module_double_reuse.f90 b/gcc/testsuite/gfortran.dg/module_double_reuse.f90 new file mode 100755 index 00000000000..8c1b6ec6367 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_double_reuse.f90 @@ -0,0 +1,19 @@ +! Test of fix for PR18878 +! +! Based on example in PR by Steve Kargl +! +module a + integer, parameter :: b = kind(1.d0) + real(b) :: z +end module a +program d + use a, only : e => b, f => b, u => z, v => z + real(e) x + real(f) y + x = 1.e0_e + y = 1.e0_f + u = 99.0 + if (kind(x).ne.kind(y)) call abort () + if (v.ne.u) call abort () +end program d + diff --git a/gcc/testsuite/gfortran.dg/module_equivalence_1.f90 b/gcc/testsuite/gfortran.dg/module_equivalence_1.f90 new file mode 100644 index 00000000000..d8268ca722f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_equivalence_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! This tests the fix for PR17917, where equivalences were not being +! written to and read back from modules. +! +! Contributed by Paul Thomas pault@gcc.gnu.org +! +module test_equiv !Bug 17917 + common /my_common/ d + real a(2),b(4),c(4), d(8) + equivalence (a(1),b(2)), (c(1),d(5)) +end module test_equiv + +subroutine foo () + use test_equiv, z=>b + if (any (d(5:8)/=z)) call abort () +end subroutine foo + +program module_equiv + use test_equiv + b = 99.0_4 + a = 999.0_4 + c = (/99.0_4, 999.0_4, 999.0_4, 99.0_4/) + call foo () +end program module_equiv + + diff --git a/gcc/testsuite/gfortran.dg/nested_modules_1.f90 b/gcc/testsuite/gfortran.dg/nested_modules_1.f90 new file mode 100644 index 00000000000..d7ed4f346b4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/nested_modules_1.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! This tests that common blocks function with multiply nested modules. +! Contributed by Paul Thomas +! + module mod0 + double complex FOO, KANGA + common /bar/ FOO, KANGA + contains + subroutine eyeore () + FOO = FOO + (1.0d0, 0.0d0) + KANGA = KANGA - (1.0d0, 0.0d0) + end subroutine eyeore + end module mod0 + module mod1 + use mod0 + complex ROBIN + common/owl/ROBIN + end module mod1 + module mod2 + use mod0 + use mod1 + real*8 re1, im1, re2, im2, re, im + common /bar/ re1, im1, re2, im2 + equivalence (re1, re), (im1, im) + contains + subroutine tigger (w) + double complex w + if (FOO.ne.(1.0d0, 1.0d0)) call abort () + if (KANGA.ne.(-1.0d0, -1.0d0)) call abort () + if (ROBIN.ne.(99.0d0, 99.0d0)) CALL abort () + if (w.ne.cmplx(re,im)) call abort () + end subroutine tigger + end module mod2 + + use mod2 + use mod0, only: w=>foo + FOO = (0.0d0, 1.0d0) + KANGA = (0.0d0, -1.0d0) + ROBIN = (99.0d0, 99.0d0) + call eyeore () + call tigger (w) + end