FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/18878 ([4.0 only] erronous error message on vaild USE statement)

Browse source 
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
This commit is contained in:
Paul Thomas 2005-09-09 00:23:09 +00:00
parent 7afd4c375d
commit 30aabb86ef
17 changed files with 630 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

53
gcc/fortran/ChangeLog
View file

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

14
gcc/fortran/gfortran.h
View file

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

75
gcc/fortran/match.c
View file

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

235
gcc/fortran/module.c
View file

@ -47,6 +47,9 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
( ( <common name> <symbol> <saved flag>)
...
)
( equivalence list )
( <Symbol Number (in no particular order)>
<True name of symbol>
<Module name of symbol>
@ -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

26
gcc/fortran/primary.c
View file

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

87
gcc/fortran/trans-common.c
View file

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

8
gcc/fortran/trans-decl.c
View file

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

24
gcc/testsuite/ChangeLog
View file

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

21
gcc/testsuite/gfortran.dg/common_equivalence_1.f Normal file
View file

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

13
gcc/testsuite/gfortran.dg/common_equivalence_2.f Normal file
View file

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

14
gcc/testsuite/gfortran.dg/common_equivalence_3.f Normal file
View file

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

18
gcc/testsuite/gfortran.dg/contained_equivalence_1.f90 Normal file
View file

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

19
gcc/testsuite/gfortran.dg/module_blank_common.f90 Executable file
View file

@ -0,0 +1,19 @@
! { 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

24
gcc/testsuite/gfortran.dg/module_commons_1.f90 Normal file
View file

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

19
gcc/testsuite/gfortran.dg/module_double_reuse.f90 Executable file
View file

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

26
gcc/testsuite/gfortran.dg/module_equivalence_1.f90 Normal file
View file

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

43
gcc/testsuite/gfortran.dg/nested_modules_1.f90 Normal file
View file

@ -0,0 +1,43 @@
! { 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