This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, gfortran] PR22304, 17917, 16511, 18870 and 23270 - modules,equivalences and commons
:ADDPATCH <fortran>:
This patch supercedes:
http://gcc.gnu.org/ml/gcc-patches/2005-08/msg01070.html
http://gcc.gnu.org/ml/gcc-patches/2005-08/msg01071.html
http://gcc.gnu.org/ml/gcc-patches/2005-08/msg01072.html
http://gcc.gnu.org/ml/gcc-patches/2005-08/msg01073.html
http://gcc.gnu.org/ml/gcc-patches/2005-08/msg01144.html
The comments on these versions have been responded to and the
appropriate improvements made. I think that it would be helpful to
retain these patches in the queue, if for no other reason than that they
serve as references. I would like, if possible, to clear them all at once.
In addition, the attached patch deals with two further problems:
PR18870 - prevents indirect equivalencing of different common blocks.
PR23270 - adds module blank common.
I have run out of time before going away for nearly a couple of weeks
and so was not able to separate out the different components of the
work. I had a notion that I might annotate the accumulated patch, but
the changelog entries serve quite well enough for this.
I am aware that this has become a bit of a monster but it should be
quite comprehensible with the changelog remarks and the comments.
The improvement in functionality with modules/commons/equivalences
should be apparent from the testcases.
Bootstrapped and regtested on Athlon1700/FC3.
OK for mainline and 4.0?
Paul T
The patches and testcases are in inverse chronological order.
=================fortran.diff===============
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/23270
* gfortran.h: Move definition of BLANK_COMMON_NAME from trans-
common.c so that it is accessible to module.c.
* module.c (write_blank_common): New.
* module.c (write_module): Call write_blank_common.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/18870
* gfortran.h: Add common_head field to gfc_symbol structure.
* 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.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
* module.c (write_common): Demangle common block names
and restore them to their fortran form.
* match.c (gfc_get_common): Mangle use associated common
blocks with an incrementing serial number for each block
and in each namespace. The common block symtree name is
left unmangled so that the external reference is OK.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
* 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, use-associated common
blocks produce the correct references.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/16511
* gfortran.h: new attr field, in_equivalence.
* match.c (gfc_match_common, gfc_match_equivalence): Ensure that
symbols that are equivalence associated with a common block are
marked as being in_common.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/17917
* module.c (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.
* trans_decl.c (gfc_create_module_variable): Return for
equivalenced symbols with existing backend declaration.
* 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.
* gfortran.h (gfc_equiv): Add field for the equivalence
name.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
Mike Albert <albertm@uphs.upenn.edu>
PR fortran/22304
* trans-common.c (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.
=================test cases===============
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/23270
* gfortran.dg/module_blank_common.f90: New.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/18870
* gfortran.dg/common_equivalence_2.f: New.
* gfortran.dg/common_equivalence_3.f: New.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/host_common.f90: New.
* gfortran.dg/modules_commons_1.f90: New.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/nested_modules_1.f90: New.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/16511
* gfortran.dg/g77/19990905-0.f: Remove XFAIL and add comment to
connect the test with the PR.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/17917
* gfortran.dg/module_equivalence_1.f90: New.
2005-08-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/22304
* gfortran.dg/common_equivalence_1.f: New.
Index: gcc/gcc/fortran/gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.81
diff -c -p -r1.81 gfortran.h
*** gcc/gcc/fortran/gfortran.h 19 Aug 2005 09:05:03 -0000 1.81
--- gcc/gcc/fortran/gfortran.h 21 Aug 2005 17:13:07 -0000
*************** char *alloca ();
*** 77,82 ****
--- 77,84 ----
#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 }
*************** typedef struct
*** 419,425 ****
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 function:1, subroutine:1, generic:1;
unsigned implicit_type:1; /* Type defined via implicit rules. */
unsigned untyped:1; /* No implicit type could be found. */
--- 421,427 ----
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, 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. */
*************** typedef struct gfc_symbol
*** 702,707 ****
--- 704,714 ----
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. */
+ void *common_head;
+
/* Make sure setup code for dummy arguments is generated in the correct
order. */
int dummy_order;
*************** typedef struct gfc_equiv
*** 1190,1195 ****
--- 1197,1203 ----
{
struct gfc_equiv *next, *eq;
gfc_expr *expr;
+ const char *module;
int used;
}
gfc_equiv;
Index: gcc/gcc/fortran/match.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/match.c,v
retrieving revision 1.43
diff -c -p -r1.43 match.c
*** gcc/gcc/fortran/match.c 7 Aug 2005 22:56:17 -0000 1.43
--- gcc/gcc/fortran/match.c 21 Aug 2005 17:13:10 -0000
*************** gfc_common_head *
*** 2161,2184 ****
gfc_get_common (const char *name, int from_module)
{
gfc_symtree *st;
! static int serial = 0;
char mangled_name[GFC_MAX_SYMBOL_LEN+1];
if (from_module)
{
! /* A use associated common block is only needed to correctly layout
! the variables it contains. */
! snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
! st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
}
else
! {
! 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 ();
--- 2161,2194 ----
gfc_get_common (const char *name, int from_module)
{
gfc_symtree *st;
! int serial;
char mangled_name[GFC_MAX_SYMBOL_LEN+1];
+ /* A use associated common block is only needed to correctly layout
+ the variables it contains. Thus we give it a mangled name with
+ a series number, to ensure that each common declaration is
+ independent from the previous ones. Making sure that this mangled
+ name does not feed through to the mod files is done by write_module. */
if (from_module)
{
! for (serial = 0;; serial++)
! {
! snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial, name);
! st = gfc_find_symtree (gfc_current_ns->common_root, mangled_name);
! if (!st)
! break;
! }
}
else
! snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, name);
! st = gfc_find_symtree (gfc_current_ns->common_root, mangled_name);
!
! if (st == NULL)
! st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
+ /* The unmangled name is used here so that use associated common block
+ variables always reference the right external structure. */
if (st->n.common == NULL)
{
st->n.common = gfc_get_common_head ();
*************** gfc_get_common (const char *name, int fr
*** 2189,2195 ****
return st->n.common;
}
-
/* Match a common block name. */
static match
--- 2199,2204 ----
*************** match_common_name (char *name)
*** 2226,2235 ****
match
gfc_match_common (void)
{
! 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.head;
--- 2235,2246 ----
match
gfc_match_common (void)
{
! 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;
+ bool equiv_flag;
match m;
old_blank_common = gfc_current_ns->blank_common.head;
*************** gfc_match_common (void)
*** 2354,2361 ****
--- 2365,2408 ----
sym->as = as;
as = NULL;
+
}
+ sym->common_head = (void*)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)
+ {
+ equiv_flag = false;
+ for (e2 = e1; e2; e2 = e2->eq)
+ if (e2->expr->symtree->n.sym == sym)
+ {
+ equiv_flag = true;
+ break;
+ }
+ if (equiv_flag == false)
+ continue;
+ 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' at %C is being indirectly "
+ "equivalenced to another COMMON block"
+ , sym->name);
+ goto cleanup;
+ }
+ other->attr.in_common = 1;
+ other->common_head = (void*)t;
+ }
+ }
+ }
+
+
gfc_gobble_whitespace ();
if (gfc_match_eos () == MATCH_YES)
goto done;
*************** gfc_match_equivalence (void)
*** 2559,2565 ****
--- 2606,2615 ----
{
gfc_equiv *eq, *set, *tail;
gfc_ref *ref;
+ gfc_symbol *sym;
match m;
+ void *common_head = NULL;
+ bool common_flag;
tail = NULL;
*************** gfc_match_equivalence (void)
*** 2576,2581 ****
--- 2626,2632 ----
goto syntax;
set = eq;
+ common_flag = FALSE;
for (;;)
{
*************** gfc_match_equivalence (void)
*** 2594,2599 ****
--- 2645,2658 ----
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)
*************** gfc_match_equivalence (void)
*** 2603,2608 ****
--- 2662,2685 ----
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 different COMMON "
+ "blocks by EQUIVALENCE at %C");
+ 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)
Index: gcc/gcc/fortran/module.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/module.c,v
retrieving revision 1.35
diff -c -p -r1.35 module.c
*** gcc/gcc/fortran/module.c 19 Aug 2005 09:05:03 -0000 1.35
--- gcc/gcc/fortran/module.c 21 Aug 2005 17:13:15 -0000
*************** Software Foundation, 51 Franklin Street,
*** 47,52 ****
--- 47,55 ----
( ( <common name> <symbol> <saved flag>)
...
)
+
+ ( equivalence list )
+
( <Symbol Number (in no particular order)>
<True name of symbol>
<Module name of symbol>
*************** load_commons(void)
*** 2920,2925 ****
--- 2923,2970 ----
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
*************** read_module (void)
*** 3032,3037 ****
--- 3077,3085 ----
get_module_locus (&user_operators);
skip_list ();
skip_list ();
+
+ /* Skip commons and equivalences for now. */
+ skip_list ();
skip_list ();
mio_lparen ();
*************** read_module (void)
*** 3170,3175 ****
--- 3218,3224 ----
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
*************** static void
*** 3241,3246 ****
--- 3290,3296 ----
write_common (gfc_symtree *st)
{
gfc_common_head *p;
+ const char * name;
if (st == NULL)
return;
*************** write_common (gfc_symtree *st)
*** 3249,3255 ****
write_common(st->right);
mio_lparen();
! mio_pool_string(&st->name);
p = st->n.common;
mio_symbol_ref(&p->head);
--- 3299,3311 ----
write_common(st->right);
mio_lparen();
!
! /* Demangle the common block name in nested modules. */
! name = st->name;
! if (name[0] == '_')
! name = &name[3];
!
! mio_pool_string(&name);
p = st->n.common;
mio_symbol_ref(&p->head);
*************** write_common (gfc_symtree *st)
*** 3258,3263 ****
--- 3314,3364 ----
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_module (void)
*** 3444,3454 ****
--- 3545,3561 ----
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
Index: gcc/gcc/fortran/trans-common.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-common.c,v
retrieving revision 1.30
diff -c -p -r1.30 trans-common.c
*** gcc/gcc/fortran/trans-common.c 6 Aug 2005 12:56:18 -0000 1.30
--- gcc/gcc/fortran/trans-common.c 21 Aug 2005 17:13:20 -0000
*************** typedef struct segment_info
*** 119,126 ****
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 *
--- 119,124 ----
*************** add_condition (segment_info *f, gfc_equi
*** 665,710 ****
/* 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. */
!
static bool
find_equivalence (segment_info *n)
{
! gfc_equiv *e1, *e2, *eq, *other;
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;
! if (e1->expr->symtree->n.sym == n->sym)
! {
! eq = e1;
! other = e2;
! }
! else if (e2->expr->symtree->n.sym == n->sym)
{
eq = e2;
! other = e1;
}
! else
! eq = NULL;
!
! if (eq)
{
! add_condition (n, eq, other);
! eq->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;
}
}
}
--- 663,707 ----
/* Given a segment element, search through the equivalence lists for unused
! conditions that involve the symbol. Add these rules to the segment. */
!
static bool
find_equivalence (segment_info *n)
{
! gfc_equiv *e1, *e2, *eq;
bool found;
!
found = FALSE;
+
for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
{
! eq = NULL;
! /* 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;
! break;
}
! }
!
! /* 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, e2);
! e2->used = 1;
found = TRUE;
}
}
}
*************** translate_common (gfc_common_head *commo
*** 813,824 ****
/* 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);
/* Ensure the current location is properly aligned. */
align = TYPE_ALIGN_UNIT (s->field);
current_offset = (current_offset + align - 1) &~ (align - 1);
--- 810,823 ----
/* Add symbols to the segment. */
for (sym = var_list; sym; sym = sym->common_next)
{
! 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);
*************** finish_equivalences (gfc_namespace *ns)
*** 893,898 ****
--- 892,898 ----
{
gfc_equiv *z, *y;
gfc_symbol *sym;
+ gfc_common_head * c;
HOST_WIDE_INT offset;
unsigned HOST_WIDE_INT align;
bool dummy;
*************** finish_equivalences (gfc_namespace *ns)
*** 916,923 ****
apply_segment_offset (current_segment, offset);
! /* Create the decl. */
! create_common (NULL, current_segment, true);
break;
}
}
--- 916,938 ----
apply_segment_offset (current_segment, offset);
! /* 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;
}
}
Index: gcc/gcc/fortran/trans-decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.66
diff -c -p -r1.66 trans-decl.c
*** gcc/gcc/fortran/trans-decl.c 11 Aug 2005 13:50:09 -0000 1.66
--- gcc/gcc/fortran/trans-decl.c 21 Aug 2005 17:13:21 -0000
*************** gfc_create_module_variable (gfc_symbol *
*** 2156,2161 ****
--- 2156,2165 ----
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_generate_function_code (gfc_namespac
*** 2332,2339 ****
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
--- 2336,2341 ----
*************** gfc_generate_function_code (gfc_namespac
*** 2350,2355 ****
--- 2352,2359 ----
/* Translate COMMON blocks. */
gfc_trans_common (ns);
+ gfc_generate_contained_functions (ns);
+
generate_local_vars (ns);
current_function_return_label = 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
! { dg-do compile }
! PR fortran/18870
!
program main
common /foo/ a
common /bar/ b
equivalence (a,c)
equivalence (b,c) ! { dg-error "COMMON blocks by EQUIVALENCE" }
c=3.
print *,a
print *,b
end
! { 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
! { dg-do run }
! This program tests that host+use associated common blocks work.
!
! provided by Paul Thomas - pault@gcc.gnu.org
!
module global
common /z/ a
contains
end module global
program test
use global
a = 42.0
call foo ()
contains
subroutine foo
common /z/ b
if (b.ne.a) call abort
if (b.ne.42.0) call abort
end subroutine foo
end program test
! { 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
! { 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
! { 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
! { 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
Index: gcc/gcc/testsuite/gfortran.dg/g77/19990905-0.f
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/gfortran.dg/g77/19990905-0.f,v
retrieving revision 1.1
diff -c -p -r1.1 19990905-0.f
*** gcc/gcc/testsuite/gfortran.dg/g77/19990905-0.f 13 Jul 2004 07:08:22 -0000 1.1
--- gcc/gcc/testsuite/gfortran.dg/g77/19990905-0.f 22 Aug 2005 04:48:44 -0000
***************
*** 1,8 ****
c { dg-do compile }
* =foo0.f in Burley's g77 test suite.
subroutine sub(a)
common /info/ iarray(1000)
! equivalence (m,iarray(100)), (n,iarray(200))
! real a(m,n) ! { dg-bogus "Variable 'm' cannot appear" "Variable 'm' cannot appear" { xfail *-*-* } } PR 16511
a(1,1) = a(2,2)
end
--- 1,12 ----
c { dg-do compile }
* =foo0.f in Burley's g77 test suite.
+ ! Used to give "Variable 'm' cannot appear" "Variable 'm' cannot appear"
+ ! after REAL a(m,n), as described in PR 16511.
+ !
subroutine sub(a)
+ equivalence (m,iarray(100))
common /info/ iarray(1000)
! equivalence (n,iarray(200))
! real a(m,n)
a(1,1) = a(2,2)
end
- Follow-Ups:
- Re: [Patch, gfortran] PR22304, 17917, 16511, 18870 and 23270 - modules, equivalences and commons
- Re: [Patch, gfortran] PR22304, 17917, 16511, 18870 and 23270 - modules, equivalences and commons
- Re: [Patch, gfortran] PR22304, 17917, 16511, 18870 and 23270 - modules,equivalences and commons