2005-09-09 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
PR fortran/18878
* gfortran.dg/module_double_reuse.f90: New.
2005-09-09 Paul Thomas <pault@gcc.gnu.org>
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
+2005-09-09 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <pault@gcc.gnu.org>
+
+ 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 <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/23765
#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 }
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. */
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;
/* 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;
{
struct gfc_equiv *next, *eq;
gfc_expr *expr;
+ const char *module;
int used;
}
gfc_equiv;
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;
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;
{
gfc_equiv *eq, *set, *tail;
gfc_ref *ref;
+ gfc_symbol *sym;
match m;
+ gfc_common_head *common_head = NULL;
+ bool common_flag;
tail = NULL;
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)
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)
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)
( ( <common name> <symbol> <saved flag>)
...
)
+
+ ( equivalence list )
+
( <Symbol Number (in no particular order)>
<True name of symbol>
<Module name of symbol>
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;
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. */
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
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;
get_module_locus (&user_operators);
skip_list ();
skip_list ();
+
+ /* Skip commons and equivalences for now. */
+ skip_list ();
skip_list ();
mio_lparen ();
info = get_integer (symbol);
- /* Get the local name for this symbol. */
- p = find_use_name (name);
-
- /* Skip symtree nodes not in an ONLY caluse. */
- if (p == NULL)
- continue;
+ /* 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;
- /* Check for ambiguous symbols. */
- st = gfc_find_symtree (gfc_current_ns->sym_root, p);
-
- if (st != NULL)
- {
- if (st->n.sym != info->u.rsym.sym)
- st->ambiguous = 1;
- info->u.rsym.symtree = st;
- }
- else
+ for (j = 1; j <= nuse; j++)
{
- /* 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->ambiguous = ambiguous;
+
+ sym = info->u.rsym.sym;
+
+ /* 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);
- st->n.sym = sym;
- st->n.sym->refs++;
+ 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;
+ /* 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;
+ if (info->u.rsym.state == UNUSED)
+ info->u.rsym.state = NEEDED;
+ info->u.rsym.referenced = 1;
+ }
}
}
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
write_common (gfc_symtree *st)
{
gfc_common_head *p;
+ const char * name;
if (st == NULL)
return;
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);
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. */
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
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;
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;
*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);
+}
+
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 *
/* 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;
}
}
}
/* 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);
{
gfc_equiv *z, *y;
gfc_symbol *sym;
+ gfc_common_head * c;
HOST_WIDE_INT offset;
unsigned HOST_WIDE_INT align;
bool dummy;
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;
}
}
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);
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
/* Translate COMMON blocks. */
gfc_trans_common (ns);
+ gfc_generate_contained_functions (ns);
+
generate_local_vars (ns);
current_function_return_label = NULL;
+2005-09-09 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/18878
+ * gfortran.dg/module_double_reuse.f90: New.
+
+2005-09-09 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/23765
--- /dev/null
+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
+
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
+
--- /dev/null
+! { 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
--- /dev/null
+! { dg-do run }
+!
+! This tests that blank common works in modules. PR23270
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+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
+
+
--- /dev/null
+! { 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
+
--- /dev/null
+! 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
+
--- /dev/null
+! { 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
+
+
--- /dev/null
+! { dg-do run }
+!
+! This tests that common blocks function with multiply nested modules.
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ 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
git://gcc.gnu.org / gcc.git / commitdiff