This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, Fortran] PR41629: [OOP] gimplification error on valid code
Paul,
> I'll look at this patch tomorrow. ?I just got back from a trip.
thanks, that would be great. But if you do so, please don't look at
the patch I sent before, but at the update I'm attaching here.
In the previous version, I moved the call to
'encapsulate_class_symbol' to resolution stage only for plain CLASS
variables, but not for CLASS-valued components. I think it's better
(necessary?) to also do this for components. Note: For components the
attributes are known when parsing the component declaration (which is
just one line), but the type of the component does not have to be
previously defined. Also it's just cleaner to do the encapsulation at
the same point (namely: resolution stage) for *all* CLASS entities
(including components). So I moved 'encapsulate_class_symbol' to
resolve.c and made it static again.
As an aside, I also had to fix an error in gfc_match_allocate: There,
gfc_resolve_expr was called for the SOURCE tag, but of course
resolving should only happen at resolution stage, and not yet when
parsing. Consequently, some error checks (including the function
'conformable_arrays') had to be moved to resolve_allocate_expr, since
they rely on the SOURCE expression being resolved.
I think the patch is regression-free (will re-check). Of course I will
also update the ChangeLog.
Ok for trunk?
Cheers,
Janus
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (Revision 152606)
+++ gcc/fortran/symbol.c (Arbeitskopie)
@@ -4588,13 +4588,15 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typesp
if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
&& (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
{
- if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
- return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
- ts2->u.derived);
- else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
- return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
- ts2->u.derived->components->ts.u.derived);
- else if (ts2->type != BT_CLASS)
+ if (ts1->type == BT_CLASS)
+ {
+ if (ts1->u.derived->attr.is_class)
+ ts1 = &ts1->u.derived->components->ts;
+ if (ts2->u.derived->attr.is_class)
+ ts2 = &ts2->u.derived->components->ts;
+ return gfc_type_is_extension_of (ts1->u.derived, ts2->u.derived);
+ }
+ else if (ts1->type == BT_DERIVED && ts2->type == BT_DERIVED)
return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
else
return 0;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (Revision 152608)
+++ gcc/fortran/decl.c (Arbeitskopie)
@@ -1025,80 +1025,6 @@ verify_c_interop_param (gfc_symbol *sym)
}
-/* Build a polymorphic CLASS entity, using the symbol that comes from build_sym.
- A CLASS entity is represented by an encapsulating type, which contains the
- declared type as '$data' component, plus an integer component '$vindex'
- which determines the dynamic type. */
-
-static gfc_try
-encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
- gfc_array_spec **as)
-{
- char name[GFC_MAX_SYMBOL_LEN + 5];
- gfc_symbol *fclass;
- gfc_component *c;
-
- /* Determine the name of the encapsulating type. */
- if ((*as) && (*as)->rank && attr->allocatable)
- sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
- else if ((*as) && (*as)->rank)
- sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
- else if (attr->allocatable)
- sprintf (name, ".class.%s.a", ts->u.derived->name);
- else
- sprintf (name, ".class.%s", ts->u.derived->name);
-
- gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
- if (fclass == NULL)
- {
- gfc_symtree *st;
- /* If not there, create a new symbol. */
- fclass = gfc_new_symbol (name, ts->u.derived->ns);
- st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
- st->n.sym = fclass;
- gfc_set_sym_referenced (fclass);
- fclass->refs++;
- fclass->ts.type = BT_UNKNOWN;
- fclass->vindex = ts->u.derived->vindex;
- fclass->attr.abstract = ts->u.derived->attr.abstract;
- if (ts->u.derived->f2k_derived)
- fclass->f2k_derived = gfc_get_namespace (NULL, 0);
- if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
- NULL, &gfc_current_locus) == FAILURE)
- return FAILURE;
-
- /* Add component '$data'. */
- if (gfc_add_component (fclass, "$data", &c) == FAILURE)
- return FAILURE;
- c->ts = *ts;
- c->ts.type = BT_DERIVED;
- c->attr.access = ACCESS_PRIVATE;
- c->ts.u.derived = ts->u.derived;
- c->attr.pointer = attr->pointer || attr->dummy;
- c->attr.allocatable = attr->allocatable;
- c->attr.dimension = attr->dimension;
- c->attr.abstract = ts->u.derived->attr.abstract;
- c->as = (*as);
- c->initializer = gfc_get_expr ();
- c->initializer->expr_type = EXPR_NULL;
-
- /* Add component '$vindex'. */
- if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
- return FAILURE;
- c->ts.type = BT_INTEGER;
- c->ts.kind = 4;
- c->attr.access = ACCESS_PRIVATE;
- c->initializer = gfc_int_expr (0);
- }
-
- fclass->attr.extension = 1;
- fclass->attr.is_class = 1;
- ts->u.derived = fclass;
- attr->allocatable = attr->pointer = attr->dimension = 0;
- (*as) = NULL; /* XXX */
- return SUCCESS;
-}
-
/* Function called by variable_decl() that adds a name to the symbol table. */
static gfc_try
@@ -1171,9 +1097,6 @@ build_sym (const char *name, gfc_charlen *cl,
sym->attr.implied_index = 0;
- if (sym->ts.type == BT_CLASS)
- encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
-
return SUCCESS;
}
@@ -1545,9 +1468,6 @@ build_struct (const char *name, gfc_charlen *cl, g
}
}
- if (c->ts.type == BT_CLASS)
- encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
-
/* Check array components. */
if (!c->attr.dimension)
return SUCCESS;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 152606)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -5833,6 +5833,58 @@ gfc_expr_to_initialize (gfc_expr *e)
}
+/* Used in resolve_allocate_expr to check that a allocation-object and
+ a source-expr are conformable. This does not catch all possible
+ cases; in particular a runtime checking is needed. */
+
+static gfc_try
+conformable_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+ /* First compare rank. */
+ if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
+ {
+ gfc_error ("Source-expr at %L must be scalar or have the "
+ "same rank as the allocate-object at %L",
+ &e1->where, &e2->where);
+ return FAILURE;
+ }
+
+ if (e1->shape)
+ {
+ int i;
+ mpz_t s;
+
+ mpz_init (s);
+
+ for (i = 0; i < e1->rank; i++)
+ {
+ if (e2->ref->u.ar.end[i])
+ {
+ mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
+ mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
+ mpz_add_ui (s, s, 1);
+ }
+ else
+ {
+ mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
+ }
+
+ if (mpz_cmp (e1->shape[i], s) != 0)
+ {
+ gfc_error ("Source-expr at %L and allocate-object at %L must "
+ "have the same shape", &e1->where, &e2->where);
+ mpz_clear (s);
+ return FAILURE;
+ }
+ }
+
+ mpz_clear (s);
+ }
+
+ return SUCCESS;
+}
+
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
@@ -5933,8 +5985,33 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code
return FAILURE;
}
- if (is_abstract && !code->expr3 && code->ext.alloc.ts.type == BT_UNKNOWN)
+ /* Some checks for the SOURCE tag. */
+ if (code->expr3)
{
+ /* Check F03:C631. */
+ if (!gfc_type_compatible (&e->ts, &code->expr3->ts))
+ {
+ gfc_error ("Type of entity at %L is type incompatible with "
+ "source-expr at %L", &e->where, &code->expr3->where);
+ return FAILURE;
+ }
+
+ /* Check F03:C632 and restriction following Note 6.18. */
+ if (code->expr3->rank > 0
+ && conformable_arrays (code->expr3, e) == FAILURE)
+ return FAILURE;
+
+ /* Check F03:C633. */
+ if (code->expr3->ts.kind != e->ts.kind)
+ {
+ gfc_error ("The allocate-object at %L and the source-expr at %L "
+ "shall have the same kind type parameter",
+ &e->where, &code->expr3->where);
+ return FAILURE;
+ }
+ }
+ else if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN)
+ {
gcc_assert (e->ts.type == BT_CLASS);
gfc_error ("Allocating %s of ABSTRACT base type at %L requires a "
"type-spec or SOURCE=", sym->name, &e->where);
@@ -7572,11 +7649,10 @@ resolve_ordinary_assign (gfc_code *code, gfc_names
static void
resolve_class_assign (gfc_code *code)
{
- gfc_code *assign_code = gfc_get_code ();
-
if (code->expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the vindex. */
+ gfc_code *assign_code = gfc_get_code ();
assign_code->next = code->next;
code->next = assign_code;
assign_code->op = EXEC_ASSIGN;
@@ -7675,6 +7751,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (gfc_resolve_expr (code->expr2) == FAILURE)
t = FAILURE;
+ if (code->op == EXEC_ALLOCATE
+ && gfc_resolve_expr (code->expr3) == FAILURE)
+ t = FAILURE;
+
switch (code->op)
{
case EXEC_NOP:
@@ -8565,7 +8645,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
associated by the presence of another class I symbol in the same
namespace. 14.6.1.3 of the standard and the discussion on
comp.lang.fortran. */
- if (sym->ns != sym->ts.u.derived->ns
+ if (sym->ns != sym->ts.u.derived->ns && sym->ns->proc_name
&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
{
gfc_symbol *s;
@@ -8601,27 +8681,6 @@ resolve_fl_variable_derived (gfc_symbol *sym, int
return FAILURE;
}
- if (sym->ts.type == BT_CLASS)
- {
- /* C502. */
- if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
- {
- gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
- sym->ts.u.derived->name, sym->name, &sym->declared_at);
- return FAILURE;
- }
-
- /* C509. */
- if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
- || sym->ts.u.derived->components->attr.allocatable
- || sym->ts.u.derived->components->attr.pointer))
- {
- gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
- "or pointer", sym->name, &sym->declared_at);
- return FAILURE;
- }
- }
-
/* Assign default initializer. */
if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
&& (!no_init_flag || sym->attr.intent == INTENT_OUT))
@@ -9692,6 +9751,9 @@ error:
}
+static void resolve_symbol (gfc_symbol *sym);
+
+
/* Resolve the type-bound procedures for a derived type. */
static void
@@ -9797,6 +9859,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
/* Now check that the argument-type matches. */
gcc_assert (me_arg);
+ resolve_symbol (me_arg);
if (me_arg->ts.type != BT_CLASS)
{
gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
@@ -9971,9 +10034,89 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol*
}
-static void resolve_symbol (gfc_symbol *sym);
+/* Build a polymorphic CLASS entity.
+ A CLASS entity is represented by an encapsulating type, which contains the
+ declared type as '$data' component, plus an integer component '$vindex'
+ which determines the dynamic type. */
+static gfc_try
+encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+ gfc_array_spec **as, locus *where)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 5];
+ gfc_symbol *fclass;
+ gfc_component *c;
+ /* F03:C502. */
+ if (!gfc_type_is_extensible (ts->u.derived))
+ {
+ gfc_error ("Type '%s' of CLASS variable at %L is not extensible",
+ ts->u.derived->name, where);
+ return FAILURE;
+ }
+
+ /* Determine the name of the encapsulating type. */
+ if ((*as) && (*as)->rank && attr->allocatable)
+ sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
+ else if ((*as) && (*as)->rank)
+ sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
+ else if (attr->allocatable)
+ sprintf (name, ".class.%s.a", ts->u.derived->name);
+ else
+ sprintf (name, ".class.%s", ts->u.derived->name);
+
+ gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
+ if (fclass == NULL)
+ {
+ gfc_symtree *st;
+ /* If not there, create a new symbol. */
+ fclass = gfc_new_symbol (name, ts->u.derived->ns);
+ st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
+ st->n.sym = fclass;
+ gfc_set_sym_referenced (fclass);
+ fclass->refs++;
+ fclass->ts.type = BT_UNKNOWN;
+ fclass->vindex = ts->u.derived->vindex;
+ fclass->attr.abstract = ts->u.derived->attr.abstract;
+ if (ts->u.derived->f2k_derived)
+ fclass->f2k_derived = gfc_get_namespace (NULL, 0);
+ if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
+ return FAILURE;
+
+ /* Add component '$data'. */
+ if (gfc_add_component (fclass, "$data", &c) == FAILURE)
+ return FAILURE;
+ c->ts = *ts;
+ c->ts.type = BT_DERIVED;
+ c->attr.access = ACCESS_PRIVATE;
+ c->ts.u.derived = ts->u.derived;
+ c->attr.pointer = attr->pointer || attr->dummy;
+ c->attr.allocatable = attr->allocatable;
+ c->attr.dimension = attr->dimension;
+ c->attr.abstract = ts->u.derived->attr.abstract;
+ c->as = (*as);
+ c->initializer = gfc_get_expr ();
+ c->initializer->expr_type = EXPR_NULL;
+
+ /* Add component '$vindex'. */
+ if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
+ return FAILURE;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ c->initializer = gfc_int_expr (0);
+ }
+
+ fclass->attr.extension = 1;
+ fclass->attr.is_class = 1;
+ ts->u.derived = fclass;
+ attr->allocatable = attr->pointer = attr->dimension = 0;
+ (*as) = NULL; /* XXX */
+ return SUCCESS;
+}
+
+
/* Resolve the components of a derived type. */
static gfc_try
@@ -10126,6 +10269,7 @@ resolve_fl_derived (gfc_symbol *sym)
/* Now check that the argument-type matches. */
gcc_assert (me_arg);
+ resolve_symbol (me_arg);
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
|| (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
|| (me_arg->ts.type == BT_CLASS
@@ -10226,7 +10370,8 @@ resolve_fl_derived (gfc_symbol *sym)
}
}
- if (c->ts.type == BT_DERIVED && c->attr.pointer
+ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ && c->attr.pointer
&& c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp)
{
@@ -10236,14 +10381,19 @@ resolve_fl_derived (gfc_symbol *sym)
return FAILURE;
}
- /* C437. */
- if (c->ts.type == BT_CLASS
- && !(c->ts.u.derived->components->attr.pointer
- || c->ts.u.derived->components->attr.allocatable))
+ if (c->ts.type == BT_CLASS && !c->ts.u.derived->attr.is_class)
{
- gfc_error ("Component '%s' with CLASS at %L must be allocatable "
- "or pointer", c->name, &c->loc);
- return FAILURE;
+ /* F03:C437. */
+ if (!(c->attr.pointer || c->attr.allocatable))
+ {
+ gfc_error ("Component '%s' with CLASS at %L must be allocatable "
+ "or pointer", c->name, &c->loc);
+ return FAILURE;
+ }
+
+ if (encapsulate_class_symbol (&c->ts, &c->attr, &c->as, &c->loc)
+ == FAILURE)
+ return FAILURE;
}
/* Ensure that all the derived type components are put on the
@@ -10848,6 +10998,21 @@ resolve_symbol (gfc_symbol *sym)
break;
}
+ if (sym->ts.type == BT_CLASS && !sym->ts.u.derived->attr.is_class)
+ {
+ /* F03:C509. */
+ if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
+ {
+ gfc_error ("CLASS variable at %L must be dummy, allocatable or "
+ "pointer", &sym->declared_at);
+ return;
+ }
+
+ if (encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as,
+ &sym->declared_at) == FAILURE)
+ return;
+ }
+
/* Resolve array specifier. Check as well some constraints
on COMMON blocks. */
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (Revision 152606)
+++ gcc/fortran/match.c (Arbeitskopie)
@@ -2388,58 +2388,6 @@ char_selector:
}
-/* Used in gfc_match_allocate to check that a allocation-object and
- a source-expr are conformable. This does not catch all possible
- cases; in particular a runtime checking is needed. */
-
-static gfc_try
-conformable_arrays (gfc_expr *e1, gfc_expr *e2)
-{
- /* First compare rank. */
- if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
- {
- gfc_error ("Source-expr at %L must be scalar or have the "
- "same rank as the allocate-object at %L",
- &e1->where, &e2->where);
- return FAILURE;
- }
-
- if (e1->shape)
- {
- int i;
- mpz_t s;
-
- mpz_init (s);
-
- for (i = 0; i < e1->rank; i++)
- {
- if (e2->ref->u.ar.end[i])
- {
- mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
- mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
- mpz_add_ui (s, s, 1);
- }
- else
- {
- mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
- }
-
- if (mpz_cmp (e1->shape[i], s) != 0)
- {
- gfc_error ("Source-expr at %L and allocate-object at %L must "
- "have the same shape", &e1->where, &e2->where);
- mpz_clear (s);
- return FAILURE;
- }
- }
-
- mpz_clear (s);
- }
-
- return SUCCESS;
-}
-
-
/* Match an ALLOCATE statement. */
match
@@ -2537,12 +2485,8 @@ gfc_match_allocate (void)
b1 = !(tail->expr->ref
&& (tail->expr->ref->type == REF_COMPONENT
|| tail->expr->ref->type == REF_ARRAY));
- if (sym && sym->ts.type == BT_CLASS)
- b2 = !(sym->ts.u.derived->components->attr.allocatable
- || sym->ts.u.derived->components->attr.pointer);
- else
- b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
- || sym->attr.proc_pointer);
+ b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+ || sym->attr.proc_pointer);
b3 = sym && sym->ns && sym->ns->proc_name
&& (sym->ns->proc_name->attr.allocatable
|| sym->ns->proc_name->attr.pointer
@@ -2620,7 +2564,7 @@ alloc_opt_list:
goto cleanup;
}
- /* The next 3 conditionals check C631. */
+ /* The next 2 conditionals check F03:C631. */
if (ts.type != BT_UNKNOWN)
{
gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
@@ -2635,28 +2579,6 @@ alloc_opt_list:
goto cleanup;
}
- gfc_resolve_expr (tmp);
-
- if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
- {
- gfc_error ("Type of entity at %L is type incompatible with "
- "source-expr at %L", &head->expr->where, &tmp->where);
- goto cleanup;
- }
-
- /* Check C633. */
- if (tmp->ts.kind != head->expr->ts.kind)
- {
- gfc_error ("The allocate-object at %L and the source-expr at %L "
- "shall have the same kind type parameter",
- &head->expr->where, &tmp->where);
- goto cleanup;
- }
-
- /* Check C632 and restriction following Note 6.18. */
- if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
- goto cleanup;
-
source = tmp;
saw_source = true;
@@ -2818,12 +2740,8 @@ gfc_match_deallocate (void)
b1 = !(tail->expr->ref
&& (tail->expr->ref->type == REF_COMPONENT
|| tail->expr->ref->type == REF_ARRAY));
- if (sym && sym->ts.type == BT_CLASS)
- b2 = !(sym->ts.u.derived->components->attr.allocatable
- || sym->ts.u.derived->components->attr.pointer);
- else
- b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
- || sym->attr.proc_pointer);
+ b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+ || sym->attr.proc_pointer);
if (b1 && b2)
{
gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
@@ -4079,6 +3997,7 @@ gfc_match_select_type (void)
if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
return MATCH_ERROR;
expr1->symtree->n.sym->ts = expr2->ts;
+ expr1->symtree->n.sym->attr.pointer = 1;
expr1->symtree->n.sym->attr.referenced = 1;
}
else
@@ -4097,7 +4016,7 @@ gfc_match_select_type (void)
{
gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
"use associate-name=>");
- return MATCH_ERROR;
+ goto error;
}
/* Check for F03:C813. */
@@ -4105,7 +4024,7 @@ gfc_match_select_type (void)
{
gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
"at %C");
- return MATCH_ERROR;
+ goto error;
}
new_st.op = EXEC_SELECT_TYPE;
@@ -4116,6 +4035,10 @@ gfc_match_select_type (void)
select_type_push (expr1->symtree->n.sym);
return MATCH_YES;
+
+error:
+ gfc_current_ns = gfc_current_ns->parent;
+ return MATCH_ERROR;
}
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (Revision 152606)
+++ gcc/fortran/primary.c (Arbeitskopie)
@@ -1733,9 +1733,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
|| (sym->attr.dimension && !sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (primary, NULL)
&& !(gfc_matching_procptr_assignment
- && sym->attr.flavor == FL_PROCEDURE))
- || (sym->ts.type == BT_CLASS
- && sym->ts.u.derived->components->attr.dimension))
+ && sym->attr.flavor == FL_PROCEDURE)))
{
/* In EQUIVALENCE, we don't know yet whether we are seeing
an array, character variable or array of character
@@ -1868,20 +1866,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl
if (m != MATCH_YES)
return m;
}
- else if (component->ts.type == BT_CLASS
- && component->ts.u.derived->components->as != NULL
- && !component->attr.proc_pointer)
- {
- tail = extend_ref (primary, tail);
- tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar,
- component->ts.u.derived->components->as,
- equiv_flag);
- if (m != MATCH_YES)
- return m;
- }
-
if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
|| gfc_match_char ('%') != MATCH_YES)
break;
@@ -1961,6 +1946,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
gfc_ref *ref;
gfc_symbol *sym;
gfc_component *comp;
+ gfc_typespec tmp_ts;
if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
@@ -1986,9 +1972,11 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
if (pointer || attr.proc_pointer)
target = 1;
- if (ts != NULL && expr->ts.type == BT_UNKNOWN)
+ if (ts != NULL && (expr->ts.type == BT_UNKNOWN || expr->ts.type == BT_CLASS))
*ts = sym->ts;
+ tmp_ts = sym->ts;
+
for (; ref; ref = ref->next)
switch (ref->type)
{
@@ -2018,6 +2006,11 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *t
case REF_COMPONENT:
comp = ref->u.c.component;
attr = comp->attr;
+ /* CLASS variables changes their type at resolution stage.
+ Update the reference. */
+ if (tmp_ts.type == BT_CLASS)
+ ref->u.c.sym = tmp_ts.u.derived;
+ tmp_ts = comp->ts;
if (ts != NULL)
{
*ts = comp->ts;