From 7289d1c97783c40ead8e74d6137e2dddc0d59e30 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Wed, 18 Dec 2013 23:00:53 +0100 Subject: [PATCH] re PR fortran/59493 ([OOP] ICE: Segfault on Class(*) pointer association) 2013-12-18 Janus Weil 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 --- gcc/fortran/ChangeLog | 18 ++++++++++ gcc/fortran/check.c | 7 +--- gcc/fortran/class.c | 63 +++++++++++++++++++---------------- gcc/fortran/expr.c | 8 ++--- gcc/fortran/gfortran.h | 2 +- gcc/fortran/interface.c | 2 +- gcc/fortran/resolve.c | 7 ++-- gcc/fortran/trans-expr.c | 10 +++--- gcc/fortran/trans-intrinsic.c | 10 ++---- gcc/fortran/trans-stmt.c | 11 ++---- 10 files changed, 69 insertions(+), 69 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1a81bfcc0cc..2a1e1972e70 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2013-12-18 Janus Weil + + 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 PR fortran/54949 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 1508c744724..0064761e170 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; } diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index b65cd892b1d..5c3a4ec37fb 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -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. */ diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index df96e5b4d35..00a4beff62b 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ff3ffb5a1c3..03d9136d01b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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*, diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 1cd1c2b0e3a..243b0f12150 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index db2f5eb705a..57e6cbb979e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 62ba93203cd..d6498ae607a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 (); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4acdc8dc756..1f5d6154bef 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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, diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 4f211975581..51d037e90f9 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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);