Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (Revision 229293) +++ gcc/fortran/trans.h (Arbeitskopie) @@ -378,7 +378,7 @@ void gfc_reset_vptr (stmtblock_t *, gfc_expr *); void gfc_reset_len (stmtblock_t *, gfc_expr *); tree gfc_get_vptr_from_expr (tree); -tree gfc_get_class_array_ref (tree, tree); +tree gfc_get_class_array_ref (tree, tree, tree); tree gfc_copy_class_to_class (tree, tree, tree, bool); bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *); bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool); Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (Revision 229293) +++ gcc/fortran/trans-array.c (Arbeitskopie) @@ -3250,7 +3250,7 @@ { type = gfc_get_element_type (type); tmp = TREE_OPERAND (cdecl, 0); - tmp = gfc_get_class_array_ref (offset, tmp); + tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE); tmp = fold_convert (build_pointer_type (type), tmp); tmp = build_fold_indirect_ref_loc (input_location, tmp); return tmp; @@ -7107,9 +7107,20 @@ } else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset) { + bool toonebased; tmp = gfc_conv_array_lbound (desc, n); + toonebased = integer_onep (tmp); + // lb(arr) - from (- start + 1) tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (base), tmp, from); + if (onebased && toonebased) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (base), tmp, start); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (base), tmp, + gfc_index_one_node); + } tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (base), tmp, gfc_conv_array_stride (desc, n)); @@ -7183,12 +7194,13 @@ /* For class arrays add the class tree into the saved descriptor to enable getting of _vptr and the like. */ if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc) - && IS_CLASS_ARRAY (expr->symtree->n.sym) - && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl)) + && IS_CLASS_ARRAY (expr->symtree->n.sym)) { gfc_allocate_lang_decl (desc); GFC_DECL_SAVED_DESCRIPTOR (desc) = - GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl); + DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ? + GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl) + : expr->symtree->n.sym->backend_decl; } if (!se->direct_byref || se->byref_noassign) { Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 229293) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -1039,9 +1039,10 @@ of the referenced element. */ tree -gfc_get_class_array_ref (tree index, tree class_decl) +gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp) { - tree data = gfc_class_data_get (class_decl); + tree data = data_comp != NULL_TREE ? data_comp : + gfc_class_data_get (class_decl); tree size = gfc_class_vtab_size_get (class_decl); tree offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, @@ -1075,6 +1076,7 @@ tree stdcopy; tree extcopy; tree index; + bool is_from_desc = false, is_to_class = false; args = NULL; /* To prevent warnings on uninitialized variables. */ @@ -1088,7 +1090,19 @@ fcn_type = TREE_TYPE (TREE_TYPE (fcn)); if (from != NULL_TREE) - from_data = gfc_class_data_get (from); + { + is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from)); + if (is_from_desc) + { + from_data = from; + from = GFC_DECL_SAVED_DESCRIPTOR (from); + } + else + { + from_data = gfc_class_data_get (from); + is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)); + } + } else from_data = gfc_class_vtab_def_init_get (to); @@ -1100,9 +1114,16 @@ from_len = integer_zero_node; } - to_data = gfc_class_data_get (to); - if (unlimited) - to_len = gfc_class_len_get (to); + if (GFC_CLASS_TYPE_P (TREE_TYPE (to))) + { + is_to_class = true; + to_data = gfc_class_data_get (to); + if (unlimited) + to_len = gfc_class_len_get (to); + } + else + /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */ + to_data = to; if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data))) { @@ -1118,15 +1139,23 @@ nelems = gfc_evaluate_now (tmp, &body); index = gfc_create_var (gfc_array_index_type, "S"); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data))) + if (is_from_desc) { - from_ref = gfc_get_class_array_ref (index, from); + from_ref = gfc_get_class_array_ref (index, from, from_data); vec_safe_push (args, from_ref); } else vec_safe_push (args, from_data); - to_ref = gfc_get_class_array_ref (index, to); + if (is_to_class) + to_ref = gfc_get_class_array_ref (index, to, to_data); + else + { + tmp = gfc_conv_array_data (to); + tmp = build_fold_indirect_ref_loc (input_location, tmp); + to_ref = gfc_build_addr_expr (NULL_TREE, + gfc_build_array_ref (tmp, index, to)); + } vec_safe_push (args, to_ref); tmp = build_call_vec (fcn_type, fcn, args); @@ -1183,7 +1212,7 @@ } else { - gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data))); + gcc_assert (!is_from_desc); vec_safe_push (args, from_data); vec_safe_push (args, to_data); stdcopy = build_call_vec (fcn_type, fcn, args); Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 229293) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -1,3 +1,20 @@ +2015-10-25 Andre Vehreschild + + PR fortran/66927 + PR fortran/67044 + * trans-array.c (build_array_ref): Modified call to + gfc_get_class_array_ref to adhere to new interface. + (gfc_conv_expr_descriptor): For one-based arrays that + are filled by a loop starting at one the start index of the + source array has to be mangled into the offset. + * trans-expr.c (gfc_get_class_array_ref): When the tree to get + the _data component is present already, add a way to supply it. + (gfc_copy_class_to_class): Allow to copy to a derived type also. + * trans-stmt.c (gfc_trans_allocate): Do not conv_expr_descriptor + for functions returning a class or derived object. Get the + reference instead. + * trans.h: Interface change of gfc_get_class_array_ref. + 2015-10-24 Steven G. Kargl PR fortran/68055 Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (Revision 229293) +++ gcc/fortran/trans-stmt.c (Arbeitskopie) @@ -5186,9 +5186,16 @@ /* In all other cases evaluate the expr3. */ symbol_attribute attr; /* Get the descriptor for all arrays, that are not allocatable or - pointer, because the latter are descriptors already. */ + pointer, because the latter are descriptors already. + The exception are function calls returning a class object: + The descriptor is stored in their results _data component, which + is easier to access, when first a temporary variable for the + result is created and the descriptor retrieved from there. */ attr = gfc_expr_attr (code->expr3); - if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer) + if (code->expr3->rank != 0 + && ((!attr.allocatable && !attr.pointer) + || (code->expr3->expr_type == EXPR_FUNCTION + && code->expr3->ts.type != BT_CLASS))) gfc_conv_expr_descriptor (&se, code->expr3); else gfc_conv_expr_reference (&se, code->expr3); @@ -5205,17 +5212,40 @@ variable declaration. */ if (se.expr != NULL_TREE && temp_var_needed) { - tree var; + tree var, desc; tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ? se.expr : build_fold_indirect_ref_loc (input_location, se.expr); + + /* Get the array descriptor and prepare it to be assigned to the + temporary variable var. For classes the array descriptor is + in the _data component and the object goes into the + GFC_DECL_SAVED_DESCRIPTOR. */ + if (code->expr3->ts.type == BT_CLASS + && code->expr3->rank != 0) + { + /* When an array_ref was in expr3, then the descriptor is the + first operand. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + { + desc = TREE_OPERAND (tmp, 0); + } + else + { + desc = tmp; + tmp = gfc_class_data_get (tmp); + } + e3_is = E3_DESC; + } + else + desc = se.expr; /* We need a regular (non-UID) symbol here, therefore give a prefix. */ var = gfc_create_var (TREE_TYPE (tmp), "source"); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) { gfc_allocate_lang_decl (var); - GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr; + GFC_DECL_SAVED_DESCRIPTOR (var) = desc; } gfc_add_modify_loc (input_location, &block, var, tmp); @@ -5241,11 +5271,12 @@ expr3_len = se.string_length; } /* Store what the expr3 is to be used for. */ - e3_is = expr3 != NULL_TREE ? - (code->ext.alloc.arr_spec_from_expr3 ? - E3_DESC - : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) - : E3_UNSET; + if (e3_is == E3_UNSET) + e3_is = expr3 != NULL_TREE ? + (code->ext.alloc.arr_spec_from_expr3 ? + E3_DESC + : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) + : E3_UNSET; /* Figure how to get the _vtab entry. This also obtains the tree expression for accessing the _len component, because only @@ -5254,11 +5285,17 @@ if (code->expr3->ts.type == BT_CLASS) { gfc_expr *rhs; + tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ? + build_fold_indirect_ref (expr3): expr3; /* Polymorphic SOURCE: VPTR must be determined at run time. expr3 may be a temporary array declaration, therefore check for GFC_CLASS_TYPE_P before trying to get the _vptr component. */ - if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3)) - && (VAR_P (expr3) || !code->expr3->ref)) + if (tmp != NULL_TREE + && TREE_CODE (tmp) != POINTER_PLUS_EXPR + && (e3_is == E3_DESC + || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) + && (VAR_P (tmp) || !code->expr3->ref)) + || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp)))) tmp = gfc_class_vptr_get (expr3); else { @@ -5709,10 +5746,7 @@ /* Initialization via SOURCE block (or static default initializer). Classes need some special handling, so catch them first. */ if (expr3 != NULL_TREE - && ((POINTER_TYPE_P (TREE_TYPE (expr3)) - && TREE_CODE (expr3) != POINTER_PLUS_EXPR) - || (VAR_P (expr3) && GFC_CLASS_TYPE_P ( - TREE_TYPE (expr3)))) + && TREE_CODE (expr3) != POINTER_PLUS_EXPR && code->expr3->ts.type == BT_CLASS && (expr->ts.type == BT_CLASS || expr->ts.type == BT_DERIVED)) @@ -5731,7 +5765,7 @@ gfc_expr *ppc; gfc_code *ppc_code; gfc_ref *ref, *dataref; - gfc_expr *rhs = gfc_copy_expr (code->expr3); + gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); @@ -5827,7 +5861,8 @@ void_type_node, tmp, extcopy, stdcopy); } gfc_free_statements (ppc_code); - gfc_free_expr (rhs); + if (rhs != e3rhs) + gfc_free_expr (rhs); } else { Index: gcc/testsuite/gfortran.dg/class_array_15.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_array_15.f03 (Revision 229293) +++ gcc/testsuite/gfortran.dg/class_array_15.f03 (Arbeitskopie) @@ -115,4 +115,4 @@ bh => bhGet(b,instance=2) if (loc (b) .ne. loc(bh%hostNode)) call abort end -! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } } +! { dg-final { scan-tree-dump-times "builtin_free" 11 "original" } } Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 229293) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -1,3 +1,13 @@ +2015-10-25 Andre Vehreschild + + PR fortran/66927 + PR fortran/67044 + * gfortran.dg/allocate_with_source_10.f08: New test. + * gfortran.dg/allocate_with_source_11.f08: New test. + * gfortran.dg/class_array_15.f03: Changed count of expected + _builtin_frees to 11. One step of temporaries is spared, therefore + the allocatable component of that temporary is not to be freeed. + 2015-10-24 Steven G. Kargl PR fortran/68055