===================================================================
@@ -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);
===================================================================
@@ -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)
{
===================================================================
@@ -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);
===================================================================
@@ -1,3 +1,20 @@
+2015-10-25 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ 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 <kargl@gcc.gnu.org>
PR fortran/68055
===================================================================
@@ -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
{
===================================================================
@@ -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" } }
===================================================================
@@ -1,3 +1,13 @@
+2015-10-25 Andre Vehreschild <vehre@gmx.de>
+
+ 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 <kargl@gcc.gnu.org>
PR fortran/68055