Hi all,
here is a follow-up to my recent patch for PR59493, doing some cleanup
related to the generation of vtab symbols:
1) Since the function gfc_find_intrinsic_vtab, contrary to its name,
handles not only intrinsic but also derived types, I removed the
latter functionality, and instead introduced a new function
gfc_find_vtab, which handles arbitrary types and simply decides
whether to call the corresponding function for intrinsic or derived
vtabs.
2) Basically all calls to gfc_find_intrinsic_vtab are replaced by
gfc_find_vtab. This often simplifies the logic and saves additional IF
clauses to distinguish between intrinsic and derived types.
3) As a consequence, gfc_find_intrinsic_vtab is made static and loses
the gfc_ prefix.
All of this results in the code being shorter, clearer and more
error-prone. The patch is regtested on x86_64-unknown-linux-gnu. Ok
for trunk?
Cheers,
Janus
2013-12-18 Janus Weil <ja...@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.
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c (revision 206083)
+++ gcc/fortran/check.c (working copy)
@@ -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;
}
Index: gcc/fortran/class.c
===================================================================
--- gcc/fortran/class.c (revision 206083)
+++ gcc/fortran/class.c (working copy)
@@ -423,18 +423,11 @@ gfc_class_initializer (gfc_typespec *ts, gfc_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. */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 206083)
+++ gcc/fortran/expr.c (working copy)
@@ -3618,11 +3618,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_ex
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)
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 206083)
+++ gcc/fortran/gfortran.h (working copy)
@@ -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*,
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 206083)
+++ gcc/fortran/interface.c (working copy)
@@ -2606,7 +2606,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gf
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
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 206083)
+++ gcc/fortran/resolve.c (working copy)
@@ -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
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);
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 206083)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -558,7 +558,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_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
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 ();
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 206083)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -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,
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 206083)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -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);
