Commit 9b6da3c7 by Janus Weil

re PR fortran/60234 ([OOP] ICE in generate_finalization_wrapper at fortran/class.c:1883)

2014-02-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/60234
	* gfortran.h (gfc_build_class_symbol): Removed argument.
	* class.c (gfc_add_component_ref): Fix up missing vtype if necessary.
	(gfc_build_class_symbol): Remove argument 'delayed_vtab'. vtab is always
	delayed now, except for unlimited polymorphics.
	(comp_is_finalizable): Procedure pointer components are not finalizable.
	* decl. (build_sym, build_struct, attr_decl1): Removed argument of
	'gfc_build_class_symbol'.
	* match.c (copy_ts_from_selector_to_associate, select_type_set_tmp):
	Ditto.
	* symbol.c (gfc_set_default_type): Ditto.


2014-02-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/60234
	* gfortran.dg/finalize_23.f90: New.

From-SVN: r207986
parent 4b156fd0
2014-02-21 Janus Weil <janus@gcc.gnu.org>
PR fortran/60234
* gfortran.h (gfc_build_class_symbol): Removed argument.
* class.c (gfc_add_component_ref): Fix up missing vtype if necessary.
(gfc_build_class_symbol): Remove argument 'delayed_vtab'. vtab is always
delayed now, except for unlimited polymorphics.
(comp_is_finalizable): Procedure pointer components are not finalizable.
* decl. (build_sym, build_struct, attr_decl1): Removed argument of
'gfc_build_class_symbol'.
* match.c (copy_ts_from_selector_to_associate, select_type_set_tmp):
Ditto.
* symbol.c (gfc_set_default_type): Ditto.
2014-02-19 Janus Weil <janus@gcc.gnu.org>
PR fortran/60232
......
......@@ -218,6 +218,14 @@ gfc_add_component_ref (gfc_expr *e, const char *name)
break;
tail = &((*tail)->next);
}
if (derived->components->next->ts.type == BT_DERIVED &&
derived->components->next->ts.u.derived == NULL)
{
/* Fix up missing vtype. */
gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived);
gcc_assert (vtab);
derived->components->next->ts.u.derived = vtab->ts.u.derived;
}
if (*tail != NULL && strcmp (name, "_data") == 0)
next = *tail;
(*tail) = gfc_get_ref();
......@@ -543,7 +551,7 @@ gfc_intrinsic_hash_value (gfc_typespec *ts)
bool
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as, bool delayed_vtab)
gfc_array_spec **as)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
gfc_symbol *fclass;
......@@ -637,16 +645,17 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
if (!gfc_add_component (fclass, "_vptr", &c))
return false;
c->ts.type = BT_DERIVED;
if (delayed_vtab
|| (ts->u.derived->f2k_derived
&& ts->u.derived->f2k_derived->finalizers))
c->ts.u.derived = NULL;
else
if (ts->u.derived->attr.unlimited_polymorphic)
{
vtab = gfc_find_derived_vtab (ts->u.derived);
gcc_assert (vtab);
c->ts.u.derived = vtab->ts.u.derived;
}
else
/* Build vtab later. */
c->ts.u.derived = NULL;
c->attr.access = ACCESS_PRIVATE;
c->attr.pointer = 1;
}
......@@ -790,7 +799,9 @@ has_finalizer_component (gfc_symbol *derived)
static bool
comp_is_finalizable (gfc_component *comp)
{
if (comp->attr.allocatable && comp->ts.type != BT_CLASS)
if (comp->attr.proc_pointer)
return false;
else if (comp->attr.allocatable && comp->ts.type != BT_CLASS)
return true;
else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer
&& (comp->ts.u.derived->attr.alloc_comp
......
......@@ -1199,7 +1199,7 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
sym->attr.implied_index = 0;
if (sym->ts.type == BT_CLASS)
return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
return true;
}
......@@ -1656,10 +1656,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
scalar:
if (c->ts.type == BT_CLASS)
{
bool delayed = (gfc_state_stack->sym == c->ts.u.derived)
|| (!c->ts.u.derived->components
&& !c->ts.u.derived->attr.zero_comp);
bool t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed);
bool t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
if (t)
t = t2;
......@@ -6340,7 +6337,7 @@ attr_decl1 (void)
}
if (sym->ts.type == BT_CLASS
&& !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false))
&& !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
{
m = MATCH_ERROR;
goto cleanup;
......
......@@ -2988,7 +2988,7 @@ bool gfc_is_class_container_ref (gfc_expr *e);
gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
unsigned int gfc_hash_value (gfc_symbol *);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);
gfc_array_spec **);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
gfc_symbol *gfc_find_vtab (gfc_typespec *);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
......
......@@ -5148,8 +5148,7 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
assoc_sym->ts.type = BT_CLASS;
assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
assoc_sym->attr.pointer = 1;
gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
&assoc_sym->as, false);
gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as);
}
}
......@@ -5273,7 +5272,7 @@ select_type_set_tmp (gfc_typespec *ts)
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as, false);
&tmp->n.sym->as);
}
/* Add an association for it, so the rest of the parser knows it is
......
......@@ -262,7 +262,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
if (ts->type == BT_CHARACTER && ts->u.cl)
sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
else if (ts->type == BT_CLASS
&& !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false))
&& !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
return false;
if (sym->attr.is_bind_c == 1 && gfc_option.warn_c_binding_type)
......
2014-02-21 Janus Weil <janus@gcc.gnu.org>
PR fortran/60234
* gfortran.dg/finalize_23.f90: New.
2014-02-21 Adam Butcher <adam@jessamine.co.uk>
PR c++/60052
......
! { dg-do compile }
!
! PR 60234: [4.9 Regression] [OOP] ICE in generate_finalization_wrapper at fortran/class.c:1883
!
! Contribued by Antony Lewis <antony@cosmologist.info>
module ObjectLists
implicit none
Type TObjectList
contains
FINAL :: finalize
end Type
Type, extends(TObjectList):: TRealCompareList
end Type
contains
subroutine finalize(L)
Type(TObjectList) :: L
end subroutine
integer function CompareReal(this)
Class(TRealCompareList) :: this
end function
end module
! { dg-final { cleanup-modules "ObjectLists" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment