FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/59493 ([OOP] ICE: Segfault on Class(*) pointer association)

Browse source 
2013-12-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/59493
	* gfortran.h (gfc_find_intrinsic_vtab): Removed prototype.
	(gfc_find_vtab): New prototype.
	* class.c (gfc_find_intrinsic_vtab): Rename to 'find_intrinsic_vtab' and
	make static. Minor modifications.
	(gfc_find_vtab): New function.
	(gfc_class_initializer): Use new function 'gfc_find_vtab'.
	* check.c (gfc_check_move_alloc): Ditto.
	* expr.c (gfc_check_pointer_assign): Ditto.
	* interface.c (compare_actual_formal): Ditto.
	* resolve.c (resolve_allocate_expr, resolve_select_type): Ditto.
	* trans-expr.c (gfc_conv_intrinsic_to_class, gfc_trans_class_assign):
	Ditto.
	* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
	* trans-stmt.c (gfc_trans_allocate): Ditto.

From-SVN: r206101
This commit is contained in:
Janus Weil 2013-12-18 23:00:53 +01:00
parent f00f3b679e
commit 7289d1c977
10 changed files with 69 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View file

@ -1,3 +1,21 @@
2013-12-18 Janus Weil <janus@gcc.gnu.org>
PR fortran/59493
* gfortran.h (gfc_find_intrinsic_vtab): Removed prototype.
(gfc_find_vtab): New prototype.
* class.c (gfc_find_intrinsic_vtab): Rename to 'find_intrinsic_vtab' and
make static. Minor modifications.
(gfc_find_vtab): New function.
(gfc_class_initializer): Use new function 'gfc_find_vtab'.
* check.c (gfc_check_move_alloc): Ditto.
* expr.c (gfc_check_pointer_assign): Ditto.
* interface.c (compare_actual_formal): Ditto.
* resolve.c (resolve_allocate_expr, resolve_select_type): Ditto.
* trans-expr.c (gfc_conv_intrinsic_to_class, gfc_trans_class_assign):
Ditto.
* trans-intrinsic.c (conv_intrinsic_move_alloc): Ditto.
* trans-stmt.c (gfc_trans_allocate): Ditto.
2013-12-16 Janus Weil <janus@gcc.gnu.org>
PR fortran/54949

7
gcc/fortran/check.c
View file

@ -2858,12 +2858,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
/* CLASS arguments: Make sure the vtab of from is present. */
if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
{
if (from->ts.type == BT_CLASS || from->ts.type == BT_DERIVED)
gfc_find_derived_vtab (from->ts.u.derived);
else
gfc_find_intrinsic_vtab (&from->ts);
}
gfc_find_vtab (&from->ts);
return true;
}

63
gcc/fortran/class.c
View file

@ -423,18 +423,11 @@ gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr)
gfc_expr *init;
gfc_component *comp;
gfc_symbol *vtab = NULL;
bool is_unlimited_polymorphic;
is_unlimited_polymorphic = ts->u.derived
&& ts->u.derived->components->ts.u.derived
&& ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic;
if (is_unlimited_polymorphic && init_expr)
vtab = gfc_find_intrinsic_vtab (&ts->u.derived->components->ts);
else if (init_expr && init_expr->expr_type != EXPR_NULL)
vtab = gfc_find_derived_vtab (init_expr->ts.u.derived);
if (init_expr && init_expr->expr_type != EXPR_NULL)
vtab = gfc_find_vtab (&init_expr->ts);
else
vtab = gfc_find_derived_vtab (ts->u.derived);
vtab = gfc_find_vtab (ts);
init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
&ts->u.derived->declared_at);
@ -2403,39 +2396,34 @@ yes:
/* Find (or generate) the symbol for an intrinsic type's vtab. This is
need to support unlimited polymorphism. */
needed to support unlimited polymorphism. */
gfc_symbol *
gfc_find_intrinsic_vtab (gfc_typespec *ts)
static gfc_symbol *
find_intrinsic_vtab (gfc_typespec *ts)
{
gfc_namespace *ns;
gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL;
gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
int charlen = 0;
if (ts->type == BT_CHARACTER && ts->deferred)
if (ts->type == BT_CHARACTER)
{
gfc_error ("TODO: Deferred character length variable at %C cannot "
"yet be associated with unlimited polymorphic entities");
return NULL;
if (ts->deferred)
{
gfc_error ("TODO: Deferred character length variable at %C cannot "
"yet be associated with unlimited polymorphic entities");
return NULL;
}
else if (ts->u.cl && ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
charlen = mpz_get_si (ts->u.cl->length->value.integer);
}
if (ts->type == BT_UNKNOWN)
return NULL;
/* Sometimes the typespec is passed from a single call. */
if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
return gfc_find_derived_vtab (ts->u.derived);
/* Find the top-level namespace. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (!ns->parent)
break;
if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
charlen = mpz_get_si (ts->u.cl->length->value.integer);
if (ns)
{
char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
@ -2636,6 +2624,25 @@ cleanup:
}
/* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */
gfc_symbol *
gfc_find_vtab (gfc_typespec *ts)
{
switch (ts->type)
{
case BT_UNKNOWN:
return NULL;
case BT_DERIVED:
return gfc_find_derived_vtab (ts->u.derived);
case BT_CLASS:
return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived);
default:
return find_intrinsic_vtab (ts);
}
}
/* General worker function to find either a type-bound procedure or a
type-bound user operator. */

8
gcc/fortran/expr.c
View file

@ -3618,11 +3618,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return false;
}
/* Make sure the vtab is present. */
if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
gfc_find_derived_vtab (rvalue->ts.u.derived);
else if (UNLIMITED_POLY (lvalue) && !UNLIMITED_POLY (rvalue))
gfc_find_intrinsic_vtab (&rvalue->ts);
/* Make sure the vtab is present. */
if (lvalue->ts.type == BT_CLASS && !UNLIMITED_POLY (rvalue))
gfc_find_vtab (&rvalue->ts);
/* Check rank remapping. */
if (rank_remap)

2
gcc/fortran/gfortran.h
View file

@ -2990,7 +2990,7 @@ unsigned int gfc_hash_value (gfc_symbol *);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **, bool);
gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
gfc_symbol *gfc_find_intrinsic_vtab (gfc_typespec *);
gfc_symbol *gfc_find_vtab (gfc_typespec *);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*,
const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, bool*,

2
gcc/fortran/interface.c
View file

@ -2606,7 +2606,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (UNLIMITED_POLY (f->sym)
&& a->expr->ts.type != BT_DERIVED
&& a->expr->ts.type != BT_CLASS)
gfc_find_intrinsic_vtab (&a->expr->ts);
gfc_find_vtab (&a->expr->ts);
if (a->expr->expr_type == EXPR_NULL
&& ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer

7
gcc/fortran/resolve.c
View file

@ -6930,10 +6930,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
gcc_assert (ts);
if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
gfc_find_derived_vtab (ts->u.derived);
else
gfc_find_intrinsic_vtab (ts);
gfc_find_vtab (ts);
if (dimension)
e = gfc_expr_to_initialize (e);
@ -8054,7 +8051,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
gfc_symbol *ivtab;
gfc_expr *e;
ivtab = gfc_find_intrinsic_vtab (&c->ts);
ivtab = gfc_find_vtab (&c->ts);
gcc_assert (ivtab && CLASS_DATA (ivtab)->initializer);
e = CLASS_DATA (ivtab)->initializer;
c->low = c->high = gfc_copy_expr (e);

10
gcc/fortran/trans-expr.c
View file

@ -558,7 +558,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
/* Set the vptr. */
ctree = gfc_class_vptr_get (var);
vtab = gfc_find_intrinsic_vtab (&e->ts);
vtab = gfc_find_vtab (&e->ts);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify (&parmse->pre, ctree,
@ -1015,12 +1015,10 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
goto assign_vptr;
}
if (expr2->ts.type == BT_DERIVED)
vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL)
vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
if (expr2->expr_type == EXPR_NULL)
vtab = gfc_find_vtab (&expr1->ts);
else
vtab = gfc_find_intrinsic_vtab (&expr2->ts);
vtab = gfc_find_vtab (&expr2->ts);
gcc_assert (vtab);
rhs = gfc_get_expr ();

10
gcc/fortran/trans-intrinsic.c
View file

@ -7657,10 +7657,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
}
else
{
if (from_expr->ts.type != BT_DERIVED)
vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
else
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
vtab = gfc_find_vtab (&from_expr->ts);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify_loc (input_location, &block, to_se.expr,
@ -7714,10 +7711,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
}
else
{
if (from_expr->ts.type != BT_DERIVED)
vtab = gfc_find_intrinsic_vtab (&from_expr->ts);
else
vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
vtab = gfc_find_vtab (&from_expr->ts);
gcc_assert (vtab);
tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
gfc_add_modify_loc (input_location, &block, to_se.expr,

11
gcc/fortran/trans-stmt.c
View file

@ -5144,10 +5144,7 @@ gfc_trans_allocate (gfc_code * code)
if (ts->type == BT_DERIVED || UNLIMITED_POLY (e))
{
if (ts->type == BT_DERIVED)
vtab = gfc_find_derived_vtab (ts->u.derived);
else
vtab = gfc_find_intrinsic_vtab (ts);
vtab = gfc_find_vtab (ts);
gcc_assert (vtab);
gfc_init_se (&lse, NULL);
lse.want_pointer = 1;
@ -5232,12 +5229,8 @@ gfc_trans_allocate (gfc_code * code)
ppc = gfc_copy_expr (rhs);
gfc_add_vptr_component (ppc);
}
else if (rhs->ts.type == BT_DERIVED)
ppc = gfc_lval_expr_from_sym
(gfc_find_derived_vtab (rhs->ts.u.derived));
else
ppc = gfc_lval_expr_from_sym
(gfc_find_intrinsic_vtab (&rhs->ts));
ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts));
gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code (EXEC_CALL);