diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index c960dfeabd9..e418f1f3301 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -816,9 +816,7 @@ bool gfc_is_ptr_fcn (gfc_expr *e) { return e != NULL && e->expr_type == EXPR_FUNCTION - && (gfc_expr_attr (e).pointer - || (e->ts.type == BT_CLASS - && CLASS_DATA (e)->attr.class_pointer)); + && gfc_expr_attr (e).pointer; } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 82e6ac53aa1..8e018b6e7e8 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -1350,6 +1350,9 @@ resolve_structure_cons (gfc_expr *expr, int init) && CLASS_DATA (comp)->as) rank = CLASS_DATA (comp)->as->rank; + if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS) + gfc_find_vtab (&cons->expr->ts); + if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank && (comp->attr.allocatable || cons->expr->rank)) { @@ -1381,7 +1384,7 @@ resolve_structure_cons (gfc_expr *expr, int init) gfc_basic_typename (comp->ts.type)); t = false; } - else + else if (!UNLIMITED_POLY (comp)) { bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); if (t) diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 18589e17843..b0fd25e92a3 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1915,7 +1915,6 @@ gfc_get_symbol_decl (gfc_symbol * sym) gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL); } - gfc_finish_var_decl (decl, sym); if (sym->ts.type == BT_CHARACTER) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 3c209bcde97..b292b5f8995 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -8781,6 +8781,7 @@ alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp, tree size; tree size_in_bytes; tree lhs_cl_size = NULL_TREE; + gfc_se se; if (!comp) return; @@ -8815,16 +8816,30 @@ alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp, } else if (cm->ts.type == BT_CLASS) { - gcc_assert (expr2->ts.type == BT_CLASS || expr2->ts.type == BT_DERIVED); - if (expr2->ts.type == BT_DERIVED) + if (expr2->ts.type != BT_CLASS) { - tmp = gfc_get_symbol_decl (expr2->ts.u.derived); - size = TYPE_SIZE_UNIT (tmp); + if (expr2->ts.type == BT_CHARACTER) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr2); + size = build_int_cst (gfc_array_index_type, expr2->ts.kind); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + se.string_length, size); + size = fold_convert (size_type_node, size); + } + else + { + if (expr2->ts.type == BT_DERIVED) + tmp = gfc_get_symbol_decl (expr2->ts.u.derived); + else + tmp = gfc_typenode_for_spec (&expr2->ts); + size = TYPE_SIZE_UNIT (tmp); + } } else { gfc_expr *e2vtab; - gfc_se se; e2vtab = gfc_find_and_cut_at_last_class_ref (expr2); gfc_add_vptr_component (e2vtab); gfc_add_size_component (e2vtab); @@ -8975,6 +8990,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, { gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); + tree size; /* Take care about non-array allocatable components here. The alloc_* routine below is motivated by the alloc_scalar_allocatable_for_ @@ -8990,7 +9006,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, && expr->symtree->n.sym->attr.dummy) se.expr = build_fold_indirect_ref_loc (input_location, se.expr); - if (cm->ts.type == BT_CLASS && expr->ts.type == BT_DERIVED) + if (cm->ts.type == BT_CLASS) { tmp = gfc_class_data_get (dest); tmp = build_fold_indirect_ref_loc (input_location, tmp); @@ -9005,7 +9021,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, /* For deferred strings insert a memcpy. */ if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) { - tree size; gcc_assert (se.string_length || expr->ts.u.cl->backend_decl); size = size_of_string_in_bytes (cm->ts.kind, se.string_length ? se.string_length @@ -9013,6 +9028,36 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, tmp = gfc_build_memcpy_call (tmp, se.expr, size); gfc_add_expr_to_block (&block, tmp); } + else if (cm->ts.type == BT_CLASS) + { + /* Fix the expression for memcpy. */ + if (expr->expr_type != EXPR_VARIABLE) + se.expr = gfc_evaluate_now (se.expr, &block); + + if (expr->ts.type == BT_CHARACTER) + { + size = build_int_cst (gfc_array_index_type, expr->ts.kind); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + se.string_length, size); + size = fold_convert (size_type_node, size); + } + else + size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr->ts)); + + /* Now copy the expression to the constructor component _data. */ + gfc_add_expr_to_block (&block, + gfc_build_memcpy_call (tmp, se.expr, size)); + + /* Fill the unlimited polymorphic _len field. */ + if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER) + { + tmp = gfc_class_len_get (gfc_get_class_from_expr (tmp)); + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), + se.string_length)); + } + } else gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), se.expr));