re PR fortran/44434 ([OOP] ICE in in gfc_add_component_ref)
2010-07-13 Janus Weil <janus@gcc.gnu.org> PR fortran/44434 PR fortran/44565 PR fortran/43945 PR fortran/44869 * gfortran.h (gfc_find_derived_vtab): Modified prototype. * class.c (gfc_build_class_symbol): Modified call to 'gfc_find_derived_vtab'. (add_proc_component): Removed, moved code into 'add_proc_comp'. (add_proc_comps): Renamed to 'add_proc_comp', removed treatment of generics. (add_procs_to_declared_vtab1): Removed unnecessary argument 'resolved'. Removed treatment of generics. (copy_vtab_proc_comps): Removed unnecessary argument 'resolved'. Call 'add_proc_comp' instead of duplicating code. (add_procs_to_declared_vtab): Removed unnecessary arguments 'resolved' and 'declared'. (add_generic_specifics,add_generics_to_declared_vtab): Removed. (gfc_find_derived_vtab): Removed unnecessary argument 'resolved'. Removed treatment of generics. * iresolve.c (gfc_resolve_extends_type_of): Modified call to 'gfc_find_derived_vtab'. * resolve.c (resolve_typebound_function,resolve_typebound_subroutine): Removed treatment of generics. (resolve_select_type,resolve_fl_derived): Modified call to 'gfc_find_derived_vtab'. * trans-decl.c (gfc_get_symbol_decl): Ditto. * trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign): Ditto. * trans-stmt.c (gfc_trans_allocate): Ditto. 2010-07-13 Janus Weil <janus@gcc.gnu.org> PR fortran/44434 PR fortran/44565 PR fortran/43945 PR fortran/44869 * gfortran.dg/dynamic_dispatch_1.f03: Fixed invalid test case. * gfortran.dg/dynamic_dispatch_2.f03: Ditto. * gfortran.dg/dynamic_dispatch_3.f03: Ditto. * gfortran.dh/typebound_call_16.f03: New. * gfortran.dg/typebound_generic_6.f03: New. * gfortran.dg/typebound_generic_7.f03: New. * gfortran.dg/typebound_generic_8.f03: New. From-SVN: r162125
This commit is contained in:
parent
b1743e3754
commit
88ce80316f
|
@ -1,3 +1,35 @@
|
|||
2010-07-13 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/44434
|
||||
PR fortran/44565
|
||||
PR fortran/43945
|
||||
PR fortran/44869
|
||||
* gfortran.h (gfc_find_derived_vtab): Modified prototype.
|
||||
* class.c (gfc_build_class_symbol): Modified call to
|
||||
'gfc_find_derived_vtab'.
|
||||
(add_proc_component): Removed, moved code into 'add_proc_comp'.
|
||||
(add_proc_comps): Renamed to 'add_proc_comp', removed treatment of
|
||||
generics.
|
||||
(add_procs_to_declared_vtab1): Removed unnecessary argument 'resolved'.
|
||||
Removed treatment of generics.
|
||||
(copy_vtab_proc_comps): Removed unnecessary argument 'resolved'.
|
||||
Call 'add_proc_comp' instead of duplicating code.
|
||||
(add_procs_to_declared_vtab): Removed unnecessary arguments 'resolved'
|
||||
and 'declared'.
|
||||
(add_generic_specifics,add_generics_to_declared_vtab): Removed.
|
||||
(gfc_find_derived_vtab): Removed unnecessary argument 'resolved'.
|
||||
Removed treatment of generics.
|
||||
* iresolve.c (gfc_resolve_extends_type_of): Modified call to
|
||||
'gfc_find_derived_vtab'.
|
||||
* resolve.c (resolve_typebound_function,resolve_typebound_subroutine):
|
||||
Removed treatment of generics.
|
||||
(resolve_select_type,resolve_fl_derived): Modified call to
|
||||
'gfc_find_derived_vtab'.
|
||||
* trans-decl.c (gfc_get_symbol_decl): Ditto.
|
||||
* trans-expr.c (gfc_conv_derived_to_class,gfc_trans_class_assign):
|
||||
Ditto.
|
||||
* trans-stmt.c (gfc_trans_allocate): Ditto.
|
||||
|
||||
2010-07-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR fortran/37077
|
||||
|
|
|
@ -174,7 +174,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
|
|||
c->ts.u.derived = NULL;
|
||||
else
|
||||
{
|
||||
vtab = gfc_find_derived_vtab (ts->u.derived, false);
|
||||
vtab = gfc_find_derived_vtab (ts->u.derived);
|
||||
gcc_assert (vtab);
|
||||
c->ts.u.derived = vtab->ts.u.derived;
|
||||
}
|
||||
|
@ -199,344 +199,126 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
|
|||
}
|
||||
|
||||
|
||||
static void
|
||||
add_proc_component (gfc_component *c, gfc_symbol *vtype,
|
||||
gfc_symtree *st, gfc_symbol *specific,
|
||||
bool is_generic, bool is_generic_specific)
|
||||
{
|
||||
/* Add procedure component. */
|
||||
if (is_generic)
|
||||
{
|
||||
if (gfc_add_component (vtype, specific->name, &c) == FAILURE)
|
||||
return;
|
||||
c->ts.interface = specific;
|
||||
}
|
||||
else if (c && is_generic_specific)
|
||||
{
|
||||
c->ts.interface = st->n.tb->u.specific->n.sym;
|
||||
}
|
||||
else
|
||||
{
|
||||
c = gfc_find_component (vtype, st->name, true, true);
|
||||
if (!c && gfc_add_component (vtype, st->name, &c) == FAILURE)
|
||||
return;
|
||||
c->ts.interface = st->n.tb->u.specific->n.sym;
|
||||
}
|
||||
|
||||
if (!c->tb)
|
||||
c->tb = XCNEW (gfc_typebound_proc);
|
||||
*c->tb = *st->n.tb;
|
||||
c->tb->ppc = 1;
|
||||
c->attr.procedure = 1;
|
||||
c->attr.proc_pointer = 1;
|
||||
c->attr.flavor = FL_PROCEDURE;
|
||||
c->attr.access = ACCESS_PRIVATE;
|
||||
c->attr.external = 1;
|
||||
c->attr.untyped = 1;
|
||||
c->attr.if_source = IFSRC_IFBODY;
|
||||
|
||||
/* A static initializer cannot be used here because the specific
|
||||
function is not a constant; internal compiler error: in
|
||||
output_constant, at varasm.c:4623 */
|
||||
c->initializer = NULL;
|
||||
}
|
||||
|
||||
/* Add a procedure pointer component to the vtype
|
||||
to represent a specific type-bound procedure. */
|
||||
|
||||
static void
|
||||
add_proc_comps (gfc_component *c, gfc_symbol *vtype,
|
||||
gfc_symtree *st, bool is_generic)
|
||||
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
|
||||
{
|
||||
if (c == NULL && !is_generic)
|
||||
gfc_component *c;
|
||||
c = gfc_find_component (vtype, name, true, true);
|
||||
|
||||
if (c == NULL)
|
||||
{
|
||||
add_proc_component (c, vtype, st, NULL, false, false);
|
||||
}
|
||||
else if (is_generic && st->n.tb && vtype->components == NULL)
|
||||
{
|
||||
gfc_tbp_generic* g;
|
||||
gfc_symbol * specific;
|
||||
for (g = st->n.tb->u.generic; g; g = g->next)
|
||||
{
|
||||
if (!g->specific)
|
||||
continue;
|
||||
specific = g->specific->u.specific->n.sym;
|
||||
add_proc_component (NULL, vtype, st, specific, true, false);
|
||||
}
|
||||
/* Add procedure component. */
|
||||
if (gfc_add_component (vtype, name, &c) == FAILURE)
|
||||
return;
|
||||
if (tb->u.specific)
|
||||
c->ts.interface = tb->u.specific->n.sym;
|
||||
|
||||
if (!c->tb)
|
||||
c->tb = XCNEW (gfc_typebound_proc);
|
||||
*c->tb = *tb;
|
||||
c->tb->ppc = 1;
|
||||
c->attr.procedure = 1;
|
||||
c->attr.proc_pointer = 1;
|
||||
c->attr.flavor = FL_PROCEDURE;
|
||||
c->attr.access = ACCESS_PRIVATE;
|
||||
c->attr.external = 1;
|
||||
c->attr.untyped = 1;
|
||||
c->attr.if_source = IFSRC_IFBODY;
|
||||
|
||||
/* A static initializer cannot be used here because the specific
|
||||
function is not a constant; internal compiler error: in
|
||||
output_constant, at varasm.c:4623 */
|
||||
c->initializer = NULL;
|
||||
}
|
||||
else if (c->attr.proc_pointer && c->tb)
|
||||
{
|
||||
*c->tb = *st->n.tb;
|
||||
*c->tb = *tb;
|
||||
c->tb->ppc = 1;
|
||||
c->ts.interface = st->n.tb->u.specific->n.sym;
|
||||
c->ts.interface = tb->u.specific->n.sym;
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype,
|
||||
bool resolved)
|
||||
{
|
||||
gfc_component *c;
|
||||
gfc_symbol *generic;
|
||||
char name[3 * GFC_MAX_SYMBOL_LEN + 10];
|
||||
|
||||
/* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
|
||||
|
||||
static void
|
||||
add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
|
||||
{
|
||||
if (!st)
|
||||
return;
|
||||
|
||||
if (st->left)
|
||||
add_procs_to_declared_vtab1 (st->left, vtype, resolved);
|
||||
add_procs_to_declared_vtab1 (st->left, vtype);
|
||||
|
||||
if (st->right)
|
||||
add_procs_to_declared_vtab1 (st->right, vtype, resolved);
|
||||
add_procs_to_declared_vtab1 (st->right, vtype);
|
||||
|
||||
if (!st->n.tb)
|
||||
return;
|
||||
|
||||
if (!st->n.tb->is_generic && st->n.tb->u.specific)
|
||||
{
|
||||
c = gfc_find_component (vtype, st->name, true, true);
|
||||
add_proc_comps (c, vtype, st, false);
|
||||
}
|
||||
else if (st->n.tb->is_generic)
|
||||
{
|
||||
c = gfc_find_component (vtype, st->name, true, true);
|
||||
|
||||
if (c == NULL)
|
||||
{
|
||||
/* Add derived type component with generic name. */
|
||||
if (gfc_add_component (vtype, st->name, &c) == FAILURE)
|
||||
return;
|
||||
c->ts.type = BT_DERIVED;
|
||||
c->attr.flavor = FL_VARIABLE;
|
||||
c->attr.pointer = 1;
|
||||
|
||||
/* Add a special empty derived type as a placeholder. */
|
||||
sprintf (name, "$empty");
|
||||
gfc_find_symbol (name, vtype->ns, 0, &generic);
|
||||
if (generic == NULL)
|
||||
{
|
||||
gfc_get_symbol (name, vtype->ns, &generic);
|
||||
generic->attr.flavor = FL_DERIVED;
|
||||
generic->refs++;
|
||||
gfc_set_sym_referenced (generic);
|
||||
generic->ts.type = BT_UNKNOWN;
|
||||
generic->attr.zero_comp = 1;
|
||||
}
|
||||
|
||||
c->ts.u.derived = generic;
|
||||
}
|
||||
}
|
||||
add_proc_comp (vtype, st->name, st->n.tb);
|
||||
}
|
||||
|
||||
|
||||
/* Copy procedure pointers components from the parent type. */
|
||||
|
||||
static void
|
||||
copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype,
|
||||
bool resolved)
|
||||
copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
|
||||
{
|
||||
gfc_component *c, *cmp;
|
||||
gfc_component *cmp;
|
||||
gfc_symbol *vtab;
|
||||
|
||||
vtab = gfc_find_derived_vtab (declared, resolved);
|
||||
vtab = gfc_find_derived_vtab (declared);
|
||||
|
||||
for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
|
||||
{
|
||||
if (gfc_find_component (vtype, cmp->name, true, true))
|
||||
continue;
|
||||
|
||||
if (gfc_add_component (vtype, cmp->name, &c) == FAILURE)
|
||||
return;
|
||||
|
||||
if (cmp->ts.type == BT_DERIVED)
|
||||
{
|
||||
c->ts = cmp->ts;
|
||||
c->ts.u.derived = cmp->ts.u.derived;
|
||||
c->attr.flavor = FL_VARIABLE;
|
||||
c->attr.pointer = 1;
|
||||
c->initializer = NULL;
|
||||
continue;
|
||||
}
|
||||
|
||||
c->tb = XCNEW (gfc_typebound_proc);
|
||||
*c->tb = *cmp->tb;
|
||||
c->attr.procedure = 1;
|
||||
c->attr.proc_pointer = 1;
|
||||
c->attr.flavor = FL_PROCEDURE;
|
||||
c->attr.access = ACCESS_PRIVATE;
|
||||
c->attr.external = 1;
|
||||
c->ts.interface = cmp->ts.interface;
|
||||
c->attr.untyped = 1;
|
||||
c->attr.if_source = IFSRC_IFBODY;
|
||||
c->initializer = NULL;
|
||||
add_proc_comp (vtype, cmp->name, cmp->tb);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* Add procedure pointers for all type-bound procedures to a vtab. */
|
||||
|
||||
static void
|
||||
add_procs_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
|
||||
gfc_symbol *derived, bool resolved)
|
||||
add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
|
||||
{
|
||||
gfc_symbol* super_type;
|
||||
|
||||
super_type = gfc_get_derived_super_type (declared);
|
||||
super_type = gfc_get_derived_super_type (derived);
|
||||
|
||||
if (super_type && (super_type != declared))
|
||||
add_procs_to_declared_vtab (super_type, vtype, derived, resolved);
|
||||
|
||||
if (declared != derived)
|
||||
copy_vtab_proc_comps (declared, vtype, resolved);
|
||||
|
||||
if (declared->f2k_derived && declared->f2k_derived->tb_sym_root)
|
||||
add_procs_to_declared_vtab1 (declared->f2k_derived->tb_sym_root,
|
||||
vtype, resolved);
|
||||
|
||||
if (declared->f2k_derived && declared->f2k_derived->tb_uop_root)
|
||||
add_procs_to_declared_vtab1 (declared->f2k_derived->tb_uop_root,
|
||||
vtype, resolved);
|
||||
}
|
||||
|
||||
|
||||
static
|
||||
void add_generic_specifics (gfc_symbol *declared, gfc_symbol *vtab,
|
||||
const char *name)
|
||||
{
|
||||
gfc_tbp_generic* g;
|
||||
gfc_symbol * specific1;
|
||||
gfc_symbol * specific2;
|
||||
gfc_symtree *st = NULL;
|
||||
gfc_component *c;
|
||||
|
||||
/* Find the generic procedure using the component name. */
|
||||
st = gfc_find_typebound_proc (declared, NULL, name, true, NULL);
|
||||
if (st == NULL)
|
||||
st = gfc_find_typebound_user_op (declared, NULL, name, true, NULL);
|
||||
|
||||
if (st == NULL)
|
||||
return;
|
||||
|
||||
/* Add procedure pointer components for the specific procedures. */
|
||||
for (g = st->n.tb->u.generic; g; g = g->next)
|
||||
if (super_type && (super_type != derived))
|
||||
{
|
||||
if (!g->specific)
|
||||
continue;
|
||||
specific1 = g->specific_st->n.tb->u.specific->n.sym;
|
||||
|
||||
c = vtab->ts.u.derived->components;
|
||||
specific2 = NULL;
|
||||
|
||||
/* Override identical specific interface. */
|
||||
if (vtab->ts.u.derived->components)
|
||||
{
|
||||
for (; c; c= c->next)
|
||||
{
|
||||
specific2 = c->ts.interface;
|
||||
if (gfc_compare_interfaces (specific2, specific1,
|
||||
specific1->name, 0, 0, NULL, 0))
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
add_proc_component (c, vtab->ts.u.derived, g->specific_st,
|
||||
NULL, false, true);
|
||||
vtab->ts.u.derived->attr.zero_comp = 0;
|
||||
/* Make sure that the PPCs appear in the same order as in the parent. */
|
||||
copy_vtab_proc_comps (super_type, vtype);
|
||||
/* Only needed to get the PPC interfaces right. */
|
||||
add_procs_to_declared_vtab (super_type, vtype);
|
||||
}
|
||||
|
||||
if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
|
||||
add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
|
||||
|
||||
if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
|
||||
add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
add_generics_to_declared_vtab (gfc_symbol *declared, gfc_symbol *vtype,
|
||||
gfc_symbol *derived, bool resolved)
|
||||
{
|
||||
gfc_component *cmp;
|
||||
gfc_symtree *st = NULL;
|
||||
gfc_symbol * vtab;
|
||||
char name[2 * GFC_MAX_SYMBOL_LEN + 8];
|
||||
gfc_symbol* super_type;
|
||||
|
||||
gcc_assert (resolved);
|
||||
|
||||
for (cmp = vtype->components; cmp; cmp = cmp->next)
|
||||
{
|
||||
if (cmp->ts.type != BT_DERIVED)
|
||||
continue;
|
||||
|
||||
/* The only derived type that does not represent a generic
|
||||
procedure is the pointer to the parent vtab. */
|
||||
if (cmp->ts.u.derived
|
||||
&& strcmp (cmp->ts.u.derived->name, "$extends") == 0)
|
||||
continue;
|
||||
|
||||
/* Find the generic procedure using the component name. */
|
||||
st = gfc_find_typebound_proc (declared, NULL, cmp->name,
|
||||
true, NULL);
|
||||
if (st == NULL)
|
||||
st = gfc_find_typebound_user_op (declared, NULL, cmp->name,
|
||||
true, NULL);
|
||||
|
||||
/* Should be an error but we pass on it for now. */
|
||||
if (st == NULL || !st->n.tb->is_generic)
|
||||
continue;
|
||||
|
||||
vtab = NULL;
|
||||
|
||||
/* Build a vtab and a special vtype, with only the procedure
|
||||
pointer fields, to carry the pointers to the specific
|
||||
procedures. Should this name ever be changed, the same
|
||||
should be done in trans-expr.c(gfc_trans_assign_vtab_procs). */
|
||||
sprintf (name, "vtab$%s$%s", vtype->name, cmp->name);
|
||||
gfc_find_symbol (name, derived->ns, 0, &vtab);
|
||||
if (vtab == NULL)
|
||||
{
|
||||
gfc_get_symbol (name, derived->ns, &vtab);
|
||||
vtab->ts.type = BT_DERIVED;
|
||||
vtab->attr.flavor = FL_VARIABLE;
|
||||
vtab->attr.target = 1;
|
||||
vtab->attr.save = SAVE_EXPLICIT;
|
||||
vtab->attr.vtab = 1;
|
||||
vtab->refs++;
|
||||
gfc_set_sym_referenced (vtab);
|
||||
sprintf (name, "%s$%s", vtype->name, cmp->name);
|
||||
|
||||
gfc_find_symbol (name, derived->ns, 0, &cmp->ts.u.derived);
|
||||
if (cmp->ts.u.derived == NULL
|
||||
|| (strcmp (cmp->ts.u.derived->name, "$empty") == 0))
|
||||
{
|
||||
gfc_get_symbol (name, derived->ns, &cmp->ts.u.derived);
|
||||
if (gfc_add_flavor (&cmp->ts.u.derived->attr, FL_DERIVED,
|
||||
NULL, &gfc_current_locus) == FAILURE)
|
||||
return;
|
||||
cmp->ts.u.derived->refs++;
|
||||
gfc_set_sym_referenced (cmp->ts.u.derived);
|
||||
cmp->ts.u.derived->attr.vtype = 1;
|
||||
cmp->ts.u.derived->attr.zero_comp = 1;
|
||||
}
|
||||
vtab->ts.u.derived = cmp->ts.u.derived;
|
||||
}
|
||||
|
||||
/* Store this for later use in setting the pointer. */
|
||||
cmp->ts.interface = vtab;
|
||||
|
||||
if (vtab->ts.u.derived->components)
|
||||
continue;
|
||||
|
||||
super_type = gfc_get_derived_super_type (declared);
|
||||
|
||||
if (super_type && (super_type != declared))
|
||||
add_generic_specifics (super_type, vtab, cmp->name);
|
||||
|
||||
add_generic_specifics (declared, vtab, cmp->name);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* Find the symbol for a derived type's vtab. A vtab has the following
|
||||
fields:
|
||||
$hash a hash value used to identify the derived type
|
||||
$size the size in bytes of the derived type
|
||||
$extends a pointer to the vtable of the parent derived type
|
||||
then:
|
||||
procedure pointer components for the specific typebound procedures
|
||||
structure pointers to reduced vtabs that contain procedure
|
||||
pointers to the specific procedures. */
|
||||
/* Find the symbol for a derived type's vtab.
|
||||
A vtab has the following fields:
|
||||
* $hash a hash value used to identify the derived type
|
||||
* $size the size in bytes of the derived type
|
||||
* $extends a pointer to the vtable of the parent derived type
|
||||
After these follow procedure pointer components for the
|
||||
specific type-bound procedures. */
|
||||
|
||||
gfc_symbol *
|
||||
gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
|
||||
gfc_find_derived_vtab (gfc_symbol *derived)
|
||||
{
|
||||
gfc_namespace *ns;
|
||||
gfc_symbol *vtab = NULL, *vtype = NULL;
|
||||
|
@ -608,7 +390,7 @@ gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
|
|||
parent = gfc_get_derived_super_type (derived);
|
||||
if (parent)
|
||||
{
|
||||
parent_vtab = gfc_find_derived_vtab (parent, resolved);
|
||||
parent_vtab = gfc_find_derived_vtab (parent);
|
||||
c->ts.type = BT_DERIVED;
|
||||
c->ts.u.derived = parent_vtab->ts.u.derived;
|
||||
c->initializer = gfc_get_expr ();
|
||||
|
@ -623,7 +405,7 @@ gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
|
|||
c->initializer = gfc_get_null_expr (NULL);
|
||||
}
|
||||
|
||||
add_procs_to_declared_vtab (derived, vtype, derived, resolved);
|
||||
add_procs_to_declared_vtab (derived, vtype);
|
||||
vtype->attr.vtype = 1;
|
||||
}
|
||||
|
||||
|
@ -632,15 +414,6 @@ gfc_find_derived_vtab (gfc_symbol *derived, bool resolved)
|
|||
}
|
||||
}
|
||||
|
||||
/* Catch the call just before the backend declarations are built, so that
|
||||
the generic procedures have been resolved and the specific procedures
|
||||
have formal interfaces that can be compared. */
|
||||
if (resolved
|
||||
&& vtab->ts.u.derived
|
||||
&& vtab->ts.u.derived->backend_decl == NULL)
|
||||
add_generics_to_declared_vtab (derived, vtab->ts.u.derived,
|
||||
derived, resolved);
|
||||
|
||||
return vtab;
|
||||
}
|
||||
|
||||
|
|
|
@ -2820,7 +2820,7 @@ void gfc_add_component_ref (gfc_expr *, const char *);
|
|||
gfc_expr *gfc_class_null_initializer (gfc_typespec *);
|
||||
gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
|
||||
gfc_array_spec **, bool);
|
||||
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
|
||||
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
|
||||
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
|
||||
const char*, bool, locus*);
|
||||
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
|
||||
|
|
|
@ -854,7 +854,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
|
|||
gfc_add_component_ref (a, "$vptr");
|
||||
else if (a->ts.type == BT_DERIVED)
|
||||
{
|
||||
vtab = gfc_find_derived_vtab (a->ts.u.derived, false);
|
||||
vtab = gfc_find_derived_vtab (a->ts.u.derived);
|
||||
/* Clear the old expr. */
|
||||
gfc_free_ref_list (a->ref);
|
||||
memset (a, '\0', sizeof (gfc_expr));
|
||||
|
@ -870,7 +870,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
|
|||
gfc_add_component_ref (mo, "$vptr");
|
||||
else if (mo->ts.type == BT_DERIVED)
|
||||
{
|
||||
vtab = gfc_find_derived_vtab (mo->ts.u.derived, false);
|
||||
vtab = gfc_find_derived_vtab (mo->ts.u.derived);
|
||||
/* Clear the old expr. */
|
||||
gfc_free_ref_list (mo->ref);
|
||||
memset (mo, '\0', sizeof (gfc_expr));
|
||||
|
|
|
@ -5477,7 +5477,6 @@ resolve_typebound_function (gfc_expr* e)
|
|||
gfc_ref *class_ref;
|
||||
gfc_symtree *st;
|
||||
const char *name;
|
||||
const char *genname;
|
||||
gfc_typespec ts;
|
||||
|
||||
st = e->symtree;
|
||||
|
@ -5501,11 +5500,6 @@ resolve_typebound_function (gfc_expr* e)
|
|||
c = gfc_find_component (declared, "$data", true, true);
|
||||
declared = c->ts.u.derived;
|
||||
|
||||
/* Keep the generic name so that the vtab reference can be made. */
|
||||
genname = NULL;
|
||||
if (e->value.compcall.tbp->is_generic)
|
||||
genname = e->value.compcall.name;
|
||||
|
||||
/* Treat the call as if it is a typebound procedure, in order to roll
|
||||
out the correct name for the specific function. */
|
||||
if (resolve_compcall (e, &name) == FAILURE)
|
||||
|
@ -5521,15 +5515,6 @@ resolve_typebound_function (gfc_expr* e)
|
|||
|
||||
/* '$vptr' points to the vtab, which contains the procedure pointers. */
|
||||
gfc_add_component_ref (e, "$vptr");
|
||||
if (genname)
|
||||
{
|
||||
/* A generic procedure needs the subsidiary vtabs and vtypes for
|
||||
the specific procedures to have been build. */
|
||||
gfc_symbol *vtab;
|
||||
vtab = gfc_find_derived_vtab (declared, true);
|
||||
gcc_assert (vtab);
|
||||
gfc_add_component_ref (e, genname);
|
||||
}
|
||||
gfc_add_component_ref (e, name);
|
||||
|
||||
/* Recover the typespec for the expression. This is really only
|
||||
|
@ -5552,7 +5537,6 @@ resolve_typebound_subroutine (gfc_code *code)
|
|||
gfc_ref *new_ref;
|
||||
gfc_ref *class_ref;
|
||||
gfc_symtree *st;
|
||||
const char *genname;
|
||||
const char *name;
|
||||
gfc_typespec ts;
|
||||
|
||||
|
@ -5577,11 +5561,6 @@ resolve_typebound_subroutine (gfc_code *code)
|
|||
c = gfc_find_component (declared, "$data", true, true);
|
||||
declared = c->ts.u.derived;
|
||||
|
||||
/* Keep the generic name so that the vtab reference can be made. */
|
||||
genname = NULL;
|
||||
if (code->expr1->value.compcall.tbp->is_generic)
|
||||
genname = code->expr1->value.compcall.name;
|
||||
|
||||
if (resolve_typebound_call (code, &name) == FAILURE)
|
||||
return FAILURE;
|
||||
ts = code->expr1->ts;
|
||||
|
@ -5595,15 +5574,6 @@ resolve_typebound_subroutine (gfc_code *code)
|
|||
|
||||
/* '$vptr' points to the vtab, which contains the procedure pointers. */
|
||||
gfc_add_component_ref (code->expr1, "$vptr");
|
||||
if (genname)
|
||||
{
|
||||
/* A generic procedure needs the subsidiary vtabs and vtypes for
|
||||
the specific procedures to have been build. */
|
||||
gfc_symbol *vtab;
|
||||
vtab = gfc_find_derived_vtab (declared, true);
|
||||
gcc_assert (vtab);
|
||||
gfc_add_component_ref (code->expr1, genname);
|
||||
}
|
||||
gfc_add_component_ref (code->expr1, name);
|
||||
|
||||
/* Recover the typespec for the expression. This is really only
|
||||
|
@ -7505,7 +7475,7 @@ resolve_select_type (gfc_code *code)
|
|||
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
|
||||
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
|
||||
gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
|
||||
vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived, true);
|
||||
vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
|
||||
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
|
||||
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
|
||||
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
|
||||
|
@ -10777,7 +10747,7 @@ resolve_fl_derived (gfc_symbol *sym)
|
|||
gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
|
||||
if (vptr->ts.u.derived == NULL)
|
||||
{
|
||||
gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
|
||||
gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
|
||||
gcc_assert (vtab);
|
||||
vptr->ts.u.derived = vtab->ts.u.derived;
|
||||
}
|
||||
|
|
|
@ -1077,7 +1077,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|
|||
{
|
||||
gfc_component *c = CLASS_DATA (sym);
|
||||
if (!c->ts.u.derived->backend_decl)
|
||||
gfc_find_derived_vtab (c->ts.u.derived, true);
|
||||
gfc_find_derived_vtab (c->ts.u.derived);
|
||||
}
|
||||
|
||||
if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
|
||||
|
|
|
@ -2478,8 +2478,8 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
|
|||
var, cmp->backend_decl, NULL_TREE);
|
||||
|
||||
/* Remember the vtab corresponds to the derived type
|
||||
not to the class declared type. */
|
||||
vtab = gfc_find_derived_vtab (e->ts.u.derived, true);
|
||||
not to the class declared type. */
|
||||
vtab = gfc_find_derived_vtab (e->ts.u.derived);
|
||||
gcc_assert (vtab);
|
||||
gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab);
|
||||
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
|
||||
|
@ -5641,7 +5641,7 @@ gfc_trans_class_assign (gfc_code *code)
|
|||
{
|
||||
gfc_symbol *vtab;
|
||||
gfc_symtree *st;
|
||||
vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true);
|
||||
vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
|
||||
gcc_assert (vtab);
|
||||
gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab);
|
||||
rhs = gfc_get_expr ();
|
||||
|
|
|
@ -4295,7 +4295,7 @@ gfc_trans_allocate (gfc_code * code)
|
|||
|
||||
if (ts->type == BT_DERIVED)
|
||||
{
|
||||
vtab = gfc_find_derived_vtab (ts->u.derived, true);
|
||||
vtab = gfc_find_derived_vtab (ts->u.derived);
|
||||
gcc_assert (vtab);
|
||||
gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
|
||||
gfc_init_se (&lse, NULL);
|
||||
|
|
|
@ -1,3 +1,17 @@
|
|||
2010-07-13 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/44434
|
||||
PR fortran/44565
|
||||
PR fortran/43945
|
||||
PR fortran/44869
|
||||
* gfortran.dg/dynamic_dispatch_1.f03: Fixed invalid test case.
|
||||
* gfortran.dg/dynamic_dispatch_2.f03: Ditto.
|
||||
* gfortran.dg/dynamic_dispatch_3.f03: Ditto.
|
||||
* gfortran.dh/typebound_call_16.f03: New.
|
||||
* gfortran.dg/typebound_generic_6.f03: New.
|
||||
* gfortran.dg/typebound_generic_7.f03: New.
|
||||
* gfortran.dg/typebound_generic_8.f03: New.
|
||||
|
||||
2010-07-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR libfortran/37077
|
||||
|
|
|
@ -12,16 +12,14 @@ module m
|
|||
procedure, pass :: make_integer
|
||||
procedure, pass :: prod => i_m_j
|
||||
generic, public :: extract => real, make_integer
|
||||
generic, public :: base_extract => real, make_integer
|
||||
end type t1
|
||||
|
||||
type, extends(t1) :: t2
|
||||
integer :: j = 99
|
||||
contains
|
||||
procedure, pass :: real => make_real2
|
||||
procedure, pass :: make_integer_2
|
||||
procedure, pass :: make_integer => make_integer_2
|
||||
procedure, pass :: prod => i_m_j_2
|
||||
generic, public :: extract => real, make_integer_2
|
||||
end type t2
|
||||
contains
|
||||
real function make_real (arg)
|
||||
|
@ -69,16 +67,13 @@ end module m
|
|||
if (a%real() .ne. real (42)) call abort
|
||||
if (a%prod() .ne. 42) call abort
|
||||
if (a%extract (2) .ne. 84) call abort
|
||||
if (a%base_extract (2) .ne. 84) call abort
|
||||
a => c ! extension in module
|
||||
if (a%real() .ne. real (99)) call abort
|
||||
if (a%prod() .ne. 99) call abort
|
||||
if (a%extract (3) .ne. 297) call abort
|
||||
if (a%base_extract (3) .ne. 126) call abort
|
||||
a => d ! extension in main
|
||||
if (a%real() .ne. real (42)) call abort
|
||||
if (a%prod() .ne. 42) call abort
|
||||
if (a%extract (4) .ne. 168) call abort
|
||||
if (a%base_extract (4) .ne. 168) call abort
|
||||
end
|
||||
! { dg-final { cleanup-modules "m" } }
|
||||
|
|
|
@ -12,16 +12,14 @@ module m
|
|||
procedure, pass :: make_integer
|
||||
procedure, pass :: prod => i_m_j
|
||||
generic, public :: extract => real, make_integer
|
||||
generic, public :: base_extract => real, make_integer
|
||||
end type t1
|
||||
|
||||
type, extends(t1) :: t2
|
||||
integer :: j = 99
|
||||
contains
|
||||
procedure, pass :: real => make_real2
|
||||
procedure, pass :: make_integer_2
|
||||
procedure, pass :: make_integer => make_integer_2
|
||||
procedure, pass :: prod => i_m_j_2
|
||||
generic, public :: extract => real, make_integer_2
|
||||
end type t2
|
||||
contains
|
||||
subroutine make_real (arg, arg2)
|
||||
|
@ -79,8 +77,6 @@ end module m
|
|||
if (i .ne. 42) call abort
|
||||
call a%extract (2, i)
|
||||
if (i .ne. 84) call abort
|
||||
call a%base_extract (2, i)
|
||||
if (i .ne. 84) call abort
|
||||
|
||||
a => c ! extension in module
|
||||
call a%real(r)
|
||||
|
@ -89,8 +85,6 @@ end module m
|
|||
if (i .ne. 99) call abort
|
||||
call a%extract (3, i)
|
||||
if (i .ne. 297) call abort
|
||||
call a%base_extract (3, i)
|
||||
if (i .ne. 126) call abort
|
||||
|
||||
a => d ! extension in main
|
||||
call a%real(r)
|
||||
|
@ -99,7 +93,5 @@ end module m
|
|||
if (i .ne. 42) call abort
|
||||
call a%extract (4, i)
|
||||
if (i .ne. 168) call abort
|
||||
call a%extract (4, i)
|
||||
if (i .ne. 168) call abort
|
||||
end
|
||||
! { dg-final { cleanup-modules "m" } }
|
||||
|
|
|
@ -15,7 +15,6 @@ module m1
|
|||
procedure, pass :: make_integer
|
||||
procedure, pass :: prod => i_m_j
|
||||
generic, public :: extract => real, make_integer
|
||||
generic, public :: base_extract => real, make_integer
|
||||
end type t1
|
||||
contains
|
||||
real function make_real (arg)
|
||||
|
@ -41,9 +40,8 @@ module m2
|
|||
integer :: j = 99
|
||||
contains
|
||||
procedure, pass :: real => make_real2
|
||||
procedure, pass :: make_integer_2
|
||||
procedure, pass :: make_integer => make_integer_2
|
||||
procedure, pass :: prod => i_m_j_2
|
||||
generic, public :: extract => real, make_integer_2
|
||||
end type t2
|
||||
contains
|
||||
real function make_real2 (arg)
|
||||
|
@ -76,16 +74,13 @@ end module m2
|
|||
if (a%real() .ne. real (42)) call abort
|
||||
if (a%prod() .ne. 42) call abort
|
||||
if (a%extract (2) .ne. 84) call abort
|
||||
if (a%base_extract (2) .ne. 84) call abort
|
||||
a => c ! extension in module m2
|
||||
if (a%real() .ne. real (99)) call abort
|
||||
if (a%prod() .ne. 99) call abort
|
||||
if (a%extract (3) .ne. 297) call abort
|
||||
if (a%base_extract (3) .ne. 126) call abort
|
||||
a => d ! extension in main
|
||||
if (a%real() .ne. real (42)) call abort
|
||||
if (a%prod() .ne. 42) call abort
|
||||
if (a%extract (4) .ne. 168) call abort
|
||||
if (a%base_extract (4) .ne. 168) call abort
|
||||
end
|
||||
! { dg-final { cleanup-modules "m1, m2" } }
|
||||
|
|
|
@ -0,0 +1,35 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! PR 41685: [OOP] internal compiler error: verify_flow_info failed
|
||||
!
|
||||
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
|
||||
|
||||
module base_mat_mod
|
||||
|
||||
type :: base_sparse_mat
|
||||
contains
|
||||
procedure, pass(a) :: get_nrows
|
||||
end type base_sparse_mat
|
||||
|
||||
contains
|
||||
|
||||
integer function get_nrows(a)
|
||||
implicit none
|
||||
class(base_sparse_mat), intent(in) :: a
|
||||
end function get_nrows
|
||||
|
||||
end module base_mat_mod
|
||||
|
||||
|
||||
use base_mat_mod
|
||||
|
||||
type, extends(base_sparse_mat) :: s_coo_sparse_mat
|
||||
end type s_coo_sparse_mat
|
||||
|
||||
class(s_coo_sparse_mat), pointer :: a
|
||||
Integer :: m
|
||||
m = a%get_nrows()
|
||||
|
||||
end
|
||||
|
||||
! { dg-final { cleanup-modules "base_mat_mod" } }
|
|
@ -0,0 +1,69 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! PR 43945: [OOP] Derived type with GENERIC: resolved to the wrong specific TBP
|
||||
!
|
||||
! Contributed by by Salvatore Filippone <sfilippone@uniroma2.it>
|
||||
|
||||
module foo_mod
|
||||
type foo
|
||||
integer :: i
|
||||
contains
|
||||
procedure, pass(a) :: doit
|
||||
procedure, pass(a) :: getit
|
||||
generic, public :: do => doit
|
||||
generic, public :: get => getit
|
||||
end type foo
|
||||
private doit,getit
|
||||
contains
|
||||
subroutine doit(a)
|
||||
class(foo) :: a
|
||||
a%i = 1
|
||||
write(*,*) 'FOO%DOIT base version'
|
||||
end subroutine doit
|
||||
function getit(a) result(res)
|
||||
class(foo) :: a
|
||||
integer :: res
|
||||
res = a%i
|
||||
end function getit
|
||||
end module foo_mod
|
||||
|
||||
module foo2_mod
|
||||
use foo_mod
|
||||
type, extends(foo) :: foo2
|
||||
integer :: j
|
||||
contains
|
||||
procedure, pass(a) :: doit => doit2
|
||||
procedure, pass(a) :: getit => getit2
|
||||
end type foo2
|
||||
private doit2, getit2
|
||||
|
||||
contains
|
||||
|
||||
subroutine doit2(a)
|
||||
class(foo2) :: a
|
||||
a%i = 2
|
||||
a%j = 3
|
||||
end subroutine doit2
|
||||
function getit2(a) result(res)
|
||||
class(foo2) :: a
|
||||
integer :: res
|
||||
res = a%j
|
||||
end function getit2
|
||||
end module foo2_mod
|
||||
|
||||
program testd15
|
||||
use foo2_mod
|
||||
type(foo2) :: af2
|
||||
class(foo), allocatable :: afab
|
||||
|
||||
allocate(foo2 :: afab)
|
||||
call af2%do()
|
||||
if (af2%i .ne. 2) call abort
|
||||
if (af2%get() .ne. 3) call abort
|
||||
call afab%do()
|
||||
if (afab%i .ne. 2) call abort
|
||||
if (afab%get() .ne. 3) call abort
|
||||
|
||||
end program testd15
|
||||
|
||||
! { dg-final { cleanup-modules "foo_mod foo2_mod" } }
|
|
@ -0,0 +1,28 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! PR 44434: [OOP] ICE in in gfc_add_component_ref
|
||||
!
|
||||
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
|
||||
|
||||
module foo_mod
|
||||
type foo
|
||||
contains
|
||||
procedure :: doit
|
||||
generic :: do => doit
|
||||
end type
|
||||
contains
|
||||
subroutine doit(a)
|
||||
class(foo) :: a
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
program testd15
|
||||
contains
|
||||
subroutine dodo(x)
|
||||
use foo_mod
|
||||
class(foo) :: x
|
||||
call x%do()
|
||||
end subroutine
|
||||
end
|
||||
|
||||
! { dg-final { cleanup-modules "foo_mod" } }
|
|
@ -0,0 +1,29 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! PR 44565: [4.6 Regression] [OOP] ICE in gimplify_expr with array-valued generic TBP
|
||||
!
|
||||
! Contributed by Hans-Werner Boschmann <boschmann@tp1.physik.uni-siegen.de>
|
||||
|
||||
module ice6
|
||||
|
||||
type :: t
|
||||
contains
|
||||
procedure :: get_array
|
||||
generic :: get_something => get_array
|
||||
end type
|
||||
|
||||
contains
|
||||
|
||||
function get_array(this)
|
||||
class(t) :: this
|
||||
real,dimension(2) :: get_array
|
||||
end function get_array
|
||||
|
||||
subroutine do_something(this)
|
||||
class(t) :: this
|
||||
print *,this%get_something()
|
||||
end subroutine do_something
|
||||
|
||||
end module ice6
|
||||
|
||||
! { dg-final { cleanup-modules "ice6" } }
|
Loading…
Reference in New Issue