This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[gfortran]: Resolve EQUIVALENCE
- From: canqun at nudt dot edu dot cn
- To: gcc-patches at gcc dot gnu dot org, fortran at gcc dot gnu dot org
- Date: Wed, 12 Nov 2003 11:45:41 +0800 (HKT)
- Subject: [gfortran]: Resolve EQUIVALENCE
- Reply-to: canqun at nudt dot edu dot cn
This patch resolve EQUIVALENCE object.
Canqun Yang
*** ChangeLog.save 2003-11-12 11:22:05.000000000 +0800
--- ChangeLog 2003-11-12 10:38:12.000000000 +0800
***************
*** 1,3 ****
--- 1,9 ----
+ 2003-11-12 Canqun Yang <canqun@nudt.edu.cn>
+
+ * resolve.c (gfc_resolve): Modified.
+ (resolve_equivalence): Resolve EQUIVALENCE object.
+ (resolve_equivalence_derived): New function.
+
2003-11-11 Canqun Yang <canqun@nudt.edu.cn>
* options.c (gfc_init_options): Set flag_max_stack_var_size as 32768.
*** resolve.c.save 2003-11-12 11:24:26.000000000 +0800
--- resolve.c 2003-11-12 11:24:30.000000000 +0800
***************
*** 4199,4204 ****
--- 4199,4340 ----
return 0;
}
+
+ /* Resolve derived type EQUIVALENCE object. */
+
+ static try
+ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e)
+ {
+ gfc_symbol *d;
+ gfc_component *c = derived->components;
+
+ if (!derived)
+ return SUCCESS;
+
+ /* Shall not be an object of nonsequence derived type. */
+ if (!derived->attr.sequence)
+ {
+ gfc_error ("Derived type variable '%s' at %L must have SEQUENCE "
+ "attribute to be an EQUIVALENCE object", sym->name, &e->where);
+ return FAILURE;
+ }
+
+ for (; c ; c = c->next)
+ {
+ d = c->ts.derived;
+ if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE))
+ return FAILURE;
+
+ /* Shall not be an object of sequence derived type containing a pointer
+ in the structure. */
+ if (c->pointer)
+ {
+ gfc_error ("Derived type variable '%s' at %L has pointer componet(s) "
+ "cannot be an EQUIVALENCE object", sym->name, &e->where);
+ return FAILURE;
+ }
+ }
+ return SUCCESS;
+ }
+
+
+ /* Resolve equivalence object.
+ An EQUIVALENCE object shall not be a dummy argument, a pointer, an
+ allocatable array, an object of nonsequence derived type, an object of
+ sequence derived type containing a pointer at any level of component
+ selection, an automatic object, a function name, an entry name, a result
+ name, a named constant, a structure component, or a subobject of any of
+ the preceding objects. */
+
+ static void
+ resolve_equivalence (gfc_equiv *eq)
+ {
+ gfc_symbol *sym;
+ gfc_symbol *derived;
+ gfc_expr *e;
+ gfc_ref *r;
+
+ for (; eq; eq = eq->eq)
+ {
+ e = eq->expr;
+ if (gfc_resolve_expr (e) == FAILURE)
+ continue;
+
+ sym = e->symtree->n.sym;
+
+ /* Shall not be a dummy argument. */
+ if (sym->attr.dummy)
+ {
+ gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE "
+ "object", sym->name, &e->where);
+ continue;
+ }
+
+ /* Shall not be an allocatable array. */
+ if (sym->attr.allocatable)
+ {
+ gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE "
+ "object", sym->name, &e->where);
+ continue;
+ }
+
+ /* Shall not be a pointer. */
+ if (sym->attr.pointer)
+ {
+ gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object",
+ sym->name, &e->where);
+ continue;
+ }
+
+ /* Shall not be a function name, ... */
+ if (sym->attr.function || sym->attr.result || sym->attr.entry
+ || sym->attr.subroutine)
+ {
+ gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object",
+ sym->name, &e->where);
+ continue;
+ }
+
+ /* Shall not be a named constant. */
+ if (e->expr_type == EXPR_CONSTANT)
+ {
+ gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE "
+ "object", sym->name, &e->where);
+ continue;
+ }
+
+ derived = e->ts.derived;
+ if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE)
+ continue;
+
+ if (!e->ref)
+ continue;
+
+ /* Shall not be an automatic array. */
+ if (e->ref->type == REF_ARRAY
+ && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE)
+ {
+ gfc_error ("Array '%s' at %L with non-constant bounds cannot be "
+ "an EQUIVALENCE object", sym->name, &e->where);
+ continue;
+ }
+
+ /* Shall not be a structure component. */
+ r = e->ref;
+ while (r)
+ {
+ if (r->type == REF_COMPONENT)
+ {
+ gfc_error ("Structure component '%s' at %L cannot be an "
+ "EQUIVALENCE object",
+ r->u.c.component->name, &e->where);
+ break;
+ }
+ r = r->next;
+ }
+ }
+ }
+
/* This function is called after a complete program unit has been compiled.
Its purpose is to examine all of the expressions associated with a program
***************
*** 4212,4217 ****
--- 4348,4354 ----
gfc_namespace *old_ns, *n;
gfc_charlen *cl;
gfc_data *d;
+ gfc_equiv *eq;
old_ns = gfc_current_ns;
gfc_current_ns = ns;
***************
*** 4256,4261 ****
--- 4393,4401 ----
iter_stack = NULL;
gfc_traverse_ns (ns, gfc_formalize_init_value);
+ for (eq = ns->equiv; eq; eq = eq->next)
+ resolve_equivalence (eq);
+
cs_base = NULL;
resolve_code (ns->code, ns);
! Program to test the EQUIVALENCE resolvement.
subroutine sub (a)
type dt1
sequence
integer, pointer:: c1
end type
type dt2
sequence
integer:: c1
real,pointer:: c2
type (dt1) :: c3
end type
type dt3
integer:: c1
end type
type (dt1) :: dvar1
type (dt2) :: dvar2
type (dt3) :: dvar3
integer a
real :: auto(a)
parameter (p = 100)
real, allocatable :: x(:,:)
pointer:: y
equivalence (dvar1%c1, dvar2%c3%c1, dvar3, x, auto(1), y, arr(2))
dimension arr(100)
end