From d960687543a235ad99ae343a5f391a847a1c693e Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 18 Mar 2010 21:23:35 +0000 Subject: [PATCH] 2010-03-18 Paul Thomas PR fortran/43039 * trans-expr.c (conv_parent_component_references): Ensure that 'dt' has a backend_decl. PR fortran/43043 * trans-expr.c (gfc_conv_structure): Ensure that the derived type has a backend_decl. PR fortran/43044 * resolve.c (resolve_global_procedure): Check that the 'cl' structure is not NULL. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@157552 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 14 ++ gcc/fortran/resolve.c | 5 +- gcc/fortran/trans-expr.c | 360 +++++++++++++++++++++++++---------------------- 3 files changed, 212 insertions(+), 167 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 231deaa7582..dc155fa1574 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2010-03-18 Paul Thomas + + PR fortran/43039 + * trans-expr.c (conv_parent_component_references): Ensure that + 'dt' has a backend_decl. + + PR fortran/43043 + * trans-expr.c (gfc_conv_structure): Ensure that the derived + type has a backend_decl. + + PR fortran/43044 + * resolve.c (resolve_global_procedure): Check that the 'cl' + structure is not NULL. + 2010-03-18 Shujing Zhao * lang.opt (-ffixed-line-length-, ffree-line-length-): Remove diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index de316da840d..24ec7a8a1de 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1851,12 +1851,13 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, /* Non-assumed length character functions. */ if (sym->attr.function && sym->ts.type == BT_CHARACTER - && gsym->ns->proc_name->ts.u.cl->length != NULL) + && gsym->ns->proc_name->ts.u.cl != NULL + && gsym->ns->proc_name->ts.u.cl->length != NULL) { gfc_charlen *cl = sym->ts.u.cl; if (!sym->attr.entry_master && sym->attr.if_source == IFSRC_UNKNOWN - && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) + && cl && cl->length && cl->length->expr_type != EXPR_CONSTANT) { gfc_error ("Nonconstant character-length function '%s' at %L " "must have an explicit interface", sym->name, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b76a3245d89..b9ea5579ac8 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -26,12 +26,15 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" +#include "convert.h" +#include "ggc.h" #include "toplev.h" +#include "real.h" +#include "gimple.h" #include "langhooks.h" #include "flags.h" #include "gfortran.h" #include "arith.h" -#include "constructor.h" #include "trans.h" #include "trans-const.h" #include "trans-types.h" @@ -275,14 +278,11 @@ flatten_array_ctors_without_strlen (gfc_expr* e) /* We've found what we're looking for. */ if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) { - gfc_constructor *c; gfc_expr* new_expr; - gcc_assert (e->value.constructor); - c = gfc_constructor_first (e->value.constructor); - new_expr = c->expr; - c->expr = NULL; + new_expr = e->value.constructor->expr; + e->value.constructor->expr = NULL; flatten_array_ctors_without_strlen (new_expr); gfc_replace_expr (e, new_expr); @@ -291,8 +291,7 @@ flatten_array_ctors_without_strlen (gfc_expr* e) /* Otherwise, fall through to handle constructor elements. */ case EXPR_STRUCTURE: - for (c = gfc_constructor_first (e->value.constructor); - c; c = gfc_constructor_next (c)) + for (c = e->value.constructor; c; c = c->next) flatten_array_ctors_without_strlen (c->expr); break; @@ -1111,6 +1110,8 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len) tree var; tree tmp; + gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node)); + if (gfc_can_put_var_on_stack (len)) { /* Create a temporary variable to hold the result. */ @@ -1431,8 +1432,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) gfc_typespec ts; gfc_clear_ts (&ts); - *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, - (int)(*expr)->value.character.string[0]); + *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]); if ((*expr)->ts.kind != gfc_c_int_kind) { /* The expr needs to be compatible with a C int. If the @@ -1526,11 +1526,141 @@ get_proc_ptr_comp (gfc_expr *e) } +/* Select a class typebound procedure at runtime. */ +static void +select_class_proc (gfc_se *se, gfc_class_esym_list *elist, + tree declared, gfc_expr *expr) +{ + tree end_label; + tree label; + tree tmp; + tree hash; + stmtblock_t body; + gfc_class_esym_list *next_elist, *tmp_elist; + gfc_se tmpse; + + /* Convert the hash expression. */ + gfc_init_se (&tmpse, NULL); + gfc_conv_expr (&tmpse, elist->hash_value); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + hash = gfc_evaluate_now (tmpse.expr, &se->pre); + gfc_add_block_to_block (&se->post, &tmpse.post); + + /* Fix the function type to be that of the declared type method. */ + declared = gfc_create_var (TREE_TYPE (declared), "method"); + + end_label = gfc_build_label_decl (NULL_TREE); + + gfc_init_block (&body); + + /* Go through the list of extensions. */ + for (; elist; elist = next_elist) + { + /* This case has already been added. */ + if (elist->derived == NULL) + goto free_elist; + + /* Skip abstract base types. */ + if (elist->derived->attr.abstract) + goto free_elist; + + /* Run through the chain picking up all the cases that call the + same procedure. */ + tmp_elist = elist; + for (; elist; elist = elist->next) + { + tree cval; + + if (elist->esym != tmp_elist->esym) + continue; + + cval = build_int_cst (TREE_TYPE (hash), + elist->derived->hash_value); + /* Build a label for the hash value. */ + label = gfc_build_label_decl (NULL_TREE); + tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, + cval, NULL_TREE, label); + gfc_add_expr_to_block (&body, tmp); + + /* Null the reference the derived type so that this case is + not used again. */ + elist->derived = NULL; + } + + elist = tmp_elist; + + /* Get a pointer to the procedure, */ + tmp = gfc_get_symbol_decl (elist->esym); + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + { + gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + } + + /* Assign the pointer to the appropriate procedure. */ + gfc_add_modify (&body, declared, + fold_convert (TREE_TYPE (declared), tmp)); + + /* Break to the end of the construct. */ + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + + /* Free the elists as we go; freeing them in gfc_free_expr causes + segfaults because it occurs too early and too often. */ + free_elist: + next_elist = elist->next; + if (elist->hash_value) + gfc_free_expr (elist->hash_value); + gfc_free (elist); + elist = NULL; + } + + /* Default is an error. */ + label = gfc_build_label_decl (NULL_TREE); + tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node, + NULL_TREE, NULL_TREE, label); + gfc_add_expr_to_block (&body, tmp); + tmp = gfc_trans_runtime_error (true, &expr->where, + "internal error: bad hash value in dynamic dispatch"); + gfc_add_expr_to_block (&body, tmp); + + /* Write the switch expression. */ + tmp = gfc_finish_block (&body); + tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE); + gfc_add_expr_to_block (&se->pre, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = declared; + return; +} + + static void conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; + if (expr && expr->symtree + && expr->value.function.class_esym) + { + if (!sym->backend_decl) + sym->backend_decl = gfc_get_extern_function_decl (sym); + + tmp = sym->backend_decl; + + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) + { + gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + } + + select_class_proc (se, expr->value.function.class_esym, + tmp, expr); + return; + } + if (gfc_is_proc_ptr_comp (expr, NULL)) tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) @@ -1718,7 +1848,6 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; - new_sym->attr.codimension = sym->attr.codimension; new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; new_sym->attr.flavor = sym->attr.flavor; @@ -1861,10 +1990,9 @@ gfc_finish_interface_mapping (gfc_interface_mapping * mapping, static void gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping, - gfc_constructor_base base) + gfc_constructor * c) { - gfc_constructor *c; - for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + for (; c; c = c->next) { gfc_apply_interface_mapping_to_expr (mapping, c->expr); if (c->iterator) @@ -1948,7 +2076,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) break; case GFC_ISYM_SIZE: - if (!sym->as || sym->as->rank == 0) + if (!sym->as) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -1972,9 +2100,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) return false; } - tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), - gfc_get_int_expr (gfc_default_integer_kind, - NULL, 1)); + tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1)); tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d])); if (new_expr) new_expr = gfc_multiply (new_expr, tmp); @@ -1988,7 +2114,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) /* TODO These implementations of lbound and ubound do not limit if the size < 0, according to F95's 13.14.53 and 13.14.113. */ - if (!sym->as || sym->as->rank == 0) + if (!sym->as) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -2260,7 +2386,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, if (intent != INTENT_OUT) { - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); gfc_trans_scalarizing_loops (&loop, &body); @@ -2358,7 +2484,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77, gcc_assert (lse.ss == gfc_ss_terminator); - tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false); gfc_add_expr_to_block (&body, tmp); /* Generate the copying loops. */ @@ -2478,9 +2604,8 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, /* Remember the vtab corresponds to the derived type not to the class declared type. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived, true); + 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)); gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); @@ -3071,7 +3196,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, it is invalid to pass a non-present argument on, even though there is no technical reason for this in gfortran. See Fortran 2003, Section 12.4.1.6 item (7)+(8). */ - tree present, null_ptr, type; + tree present, nullptr, type; if (attr->allocatable && (fsym == NULL || !fsym->attr.allocatable)) @@ -3095,10 +3220,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, present = fold_build2 (EQ_EXPR, boolean_type_node, present, fold_convert (type, null_pointer_node)); type = TREE_TYPE (parmse.expr); - null_ptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, - fold_convert (type, null_pointer_node)); + nullptr = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, + fold_convert (type, null_pointer_node)); cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, - present, null_ptr); + present, nullptr); } else { @@ -3858,10 +3983,12 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, { gfc_symbol *derived = expr->ts.u.derived; + expr = gfc_int_expr (0); + /* The derived symbol has already been converted to a (void *). Use its kind. */ - expr = gfc_get_int_expr (derived->ts.kind, NULL, 0); expr->ts.f90_type = derived->ts.f90_type; + expr->ts.kind = derived->ts.kind; gfc_init_se (&se, NULL); gfc_conv_constant (&se, expr); @@ -3888,10 +4015,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, case BT_DERIVED: case BT_CLASS: gfc_init_se (&se, NULL); - if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) - gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1); - else - gfc_conv_structure (&se, expr, 1); + gfc_conv_structure (&se, expr, 1); return se.expr; case BT_CHARACTER: @@ -3987,7 +4111,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_expr (&rse, expr); - tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true); + tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); @@ -4199,7 +4323,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { /* NULL initialization for CLASS components. */ tmp = gfc_trans_structure_assign (dest, - gfc_class_null_initializer (&cm->ts)); + gfc_default_initializer (&cm->ts)); gfc_add_expr_to_block (&block, tmp); } else if (cm->attr.dimension) @@ -4245,7 +4369,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) if (cm->ts.type == BT_CHARACTER) lse.string_length = cm->ts.u.cl->backend_decl; lse.expr = dest; - tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true); + tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); @@ -4264,8 +4388,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr) gfc_start_block (&block); cm = expr->ts.u.derived->components; - for (c = gfc_constructor_first (expr->value.constructor); - c; c = gfc_constructor_next (c), cm = cm->next) + for (c = expr->value.constructor; c; c = c->next, cm = cm->next) { /* Skip absent members in default initializers. */ if (!c->expr) @@ -4321,8 +4444,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) cm = expr->ts.u.derived->components; - for (c = gfc_constructor_first (expr->value.constructor); - c; c = gfc_constructor_next (c), cm = cm->next) + for (c = expr->value.constructor; c; c = c->next, cm = cm->next) { /* Skip absent members in default initializers and allocatable components. Although the latter have a default initializer @@ -4331,7 +4453,20 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) if (!c->expr || cm->attr.allocatable) continue; - if (strcmp (cm->name, "$size") == 0) + if (cm->ts.type == BT_CLASS) + { + gfc_component *data; + data = gfc_find_component (cm->ts.u.derived, "$data", true, true); + if (!data->backend_decl) + gfc_get_derived_type (cm->ts.u.derived); + val = gfc_conv_initializer (c->expr, &cm->ts, + TREE_TYPE (data->backend_decl), + data->attr.dimension, + data->attr.pointer); + + CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val); + } + else if (strcmp (cm->name, "$size") == 0) { val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived)); CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); @@ -4339,11 +4474,10 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL && strcmp (cm->name, "$extends") == 0) { - tree vtab; gfc_symbol *vtabs; vtabs = cm->initializer->symtree->n.sym; - vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab); + val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs)); + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); } else { @@ -4397,8 +4531,6 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) /* Substitute a scalar expression evaluated outside the scalarization loop. */ se->expr = se->ss->data.scalar.expr; - if (se->ss->type == GFC_SS_REFERENCE) - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); se->string_length = se->ss->string_length; gfc_advance_se_ss_chain (se); return; @@ -4519,9 +4651,9 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) if (se->ss && se->ss->expr == expr && se->ss->type == GFC_SS_REFERENCE) { - /* Returns a reference to the scalar evaluated outside the loop - for this case. */ - gfc_conv_expr (se, expr); + se->expr = se->ss->data.scalar.expr; + se->string_length = se->ss->string_length; + gfc_advance_se_ss_chain (se); return; } @@ -4765,12 +4897,11 @@ gfc_conv_string_parameter (gfc_se * se) /* Generate code for assignment of scalar variables. Includes character - strings and derived types with allocatable components. - If you know that the LHS has no allocations, set dealloc to false. */ + strings and derived types with allocatable components. */ tree gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, - bool l_is_temp, bool r_is_var, bool dealloc) + bool l_is_temp, bool r_is_var) { stmtblock_t block; tree tmp; @@ -4818,7 +4949,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, the same as the rhs. This must be done following the assignment to prevent deallocating data that could be used in the rhs expression. */ - if (!l_is_temp && dealloc) + if (!l_is_temp) { tmp = gfc_evaluate_now (lse->expr, &lse->pre); tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); @@ -5148,13 +5279,10 @@ gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2) /* Subroutine of gfc_trans_assignment that actually scalarizes the - assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. - init_flag indicates initialization expressions and dealloc that no - deallocate prior assignment is needed (if in doubt, set true). */ + assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */ static tree -gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, - bool dealloc) +gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) { gfc_se lse; gfc_se rse; @@ -5271,7 +5399,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, && expr2->expr_type != EXPR_VARIABLE && !gfc_is_constant_expr (expr2) && expr1->rank && !expr2->rank); - if (scalar_to_array && dealloc) + if (scalar_to_array) { tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0); gfc_add_expr_to_block (&loop.post, tmp); @@ -5280,7 +5408,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp || init_flag, (expr2->expr_type == EXPR_VARIABLE) - || scalar_to_array, dealloc); + || scalar_to_array); gfc_add_expr_to_block (&body, tmp); if (lss == gfc_ss_terminator) @@ -5317,7 +5445,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, rse.string_length = string_length; tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - false, false, dealloc); + false, false); gfc_add_expr_to_block (&body, tmp); } @@ -5375,8 +5503,7 @@ copyable_array_p (gfc_expr * expr) /* Translate an assignment. */ tree -gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, - bool dealloc) +gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag) { tree tmp; @@ -5419,116 +5546,19 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* Fallback to the scalarizer to generate explicit loops. */ - return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc); + return gfc_trans_assignment_1 (expr1, expr2, init_flag); } tree gfc_trans_init_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr1, code->expr2, true, false); + return gfc_trans_assignment (code->expr1, code->expr2, true); } tree gfc_trans_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr1, code->expr2, false, true); -} - - -/* Generate code to assign typebound procedures to a derived vtab. */ -void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt, - gfc_symbol *vtab) -{ - gfc_component *cmp; - tree vtb; - tree ctree; - tree proc; - tree cond = NULL_TREE; - stmtblock_t body; - bool seen_extends; - - /* Point to the first procedure pointer. */ - cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true); - - seen_extends = (cmp != NULL); - - vtb = gfc_get_symbol_decl (vtab); - - if (seen_extends) - { - cmp = cmp->next; - if (!cmp) - return; - ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), - vtb, cmp->backend_decl, NULL_TREE); - cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree, - build_int_cst (TREE_TYPE (ctree), 0)); - } - else - { - cmp = vtab->ts.u.derived->components; - } - - gfc_init_block (&body); - for (; cmp; cmp = cmp->next) - { - gfc_symbol *target = NULL; - - /* Generic procedure - build its vtab. */ - if (cmp->ts.type == BT_DERIVED && !cmp->tb) - { - gfc_symbol *vt = cmp->ts.interface; - - if (vt == NULL) - { - /* Use association loses the interface. Obtain the vtab - by name instead. */ - char name[2 * GFC_MAX_SYMBOL_LEN + 8]; - sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name, - cmp->name); - gfc_find_symbol (name, vtab->ns, 0, &vt); - if (vt == NULL) - continue; - } - - gfc_trans_assign_vtab_procs (&body, dt, vt); - ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), - vtb, cmp->backend_decl, NULL_TREE); - proc = gfc_get_symbol_decl (vt); - proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc); - gfc_add_modify (&body, ctree, proc); - continue; - } - - /* This is required when typebound generic procedures are called - with derived type targets. The specific procedures do not get - added to the vtype, which remains "empty". */ - if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym) - target = cmp->tb->u.specific->n.sym; - else - { - gfc_symtree *st; - st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL); - if (st->n.tb && st->n.tb->u.specific) - target = st->n.tb->u.specific->n.sym; - } - - if (!target) - continue; - - ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl), - vtb, cmp->backend_decl, NULL_TREE); - proc = gfc_get_symbol_decl (target); - proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc); - gfc_add_modify (&body, ctree, proc); - } - - proc = gfc_finish_block (&body); - - if (seen_extends) - proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location)); - - gfc_add_expr_to_block (block, proc); + return gfc_trans_assignment (code->expr1, code->expr2, false); } @@ -5573,9 +5603,9 @@ 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 (); rhs->expr_type = EXPR_VARIABLE; gfc_find_sym_tree (vtab->name, NULL, 1, &st); @@ -5583,7 +5613,7 @@ gfc_trans_class_assign (gfc_code *code) rhs->ts = vtab->ts; } else if (code->expr2->expr_type == EXPR_NULL) - rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); + rhs = gfc_int_expr (0); else gcc_unreachable (); -- 2.11.0