/* Array translation routines
- Copyright (C) 2002-2019 Free Software Foundation, Inc.
+ Copyright (C) 2002-2021 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#define LBOUND_SUBFIELD 1
#define UBOUND_SUBFIELD 2
+static tree
+gfc_get_descriptor_field (tree desc, unsigned field_idx)
+{
+ tree type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
+ gcc_assert (field != NULL_TREE);
+
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+}
+
/* This provides READ-ONLY access to the data field. The field itself
doesn't have the proper type. */
tree
gfc_conv_descriptor_data_get (tree desc)
{
- tree field, type, t;
-
- type = TREE_TYPE (desc);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
- field = TYPE_FIELDS (type);
- gcc_assert (DATA_FIELD == 0);
-
- t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
- field, NULL_TREE);
- t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
+ tree type = TREE_TYPE (desc);
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ gcc_unreachable ();
- return t;
+ tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
+ return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
}
/* This provides WRITE access to the data field.
void
gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
{
- tree field, type, t;
-
- type = TREE_TYPE (desc);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
- field = TYPE_FIELDS (type);
- gcc_assert (DATA_FIELD == 0);
-
- t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
- field, NULL_TREE);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
+ tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
+ gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
}
tree
gfc_conv_descriptor_data_addr (tree desc)
{
- tree field, type, t;
-
- type = TREE_TYPE (desc);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
- field = TYPE_FIELDS (type);
- gcc_assert (DATA_FIELD == 0);
-
- t = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), desc,
- field, NULL_TREE);
- return gfc_build_addr_expr (NULL_TREE, t);
+ tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
+ return gfc_build_addr_expr (NULL_TREE, field);
}
static tree
gfc_conv_descriptor_offset (tree desc)
{
- tree type;
- tree field;
-
- type = TREE_TYPE (desc);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
- field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
- gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
- return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
+ tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
+ gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+ return field;
}
tree
tree
gfc_conv_descriptor_dtype (tree desc)
{
- tree field;
- tree type;
-
- type = TREE_TYPE (desc);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
- field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
- gcc_assert (field != NULL_TREE
- && TREE_TYPE (field) == get_dtype_type_node ());
-
- return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
+ tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
+ gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
+ return field;
}
static tree
gfc_conv_descriptor_span (tree desc)
{
- tree type;
- tree field;
-
- type = TREE_TYPE (desc);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
- field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
- gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
- return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
+ tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
+ gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+ return field;
}
tree
dtype, tmp, NULL_TREE);
}
-
tree
gfc_get_descriptor_dimension (tree desc)
{
- tree type, field;
-
- type = TREE_TYPE (desc);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
-
- field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
- gcc_assert (field != NULL_TREE
- && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
- && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
-
- return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
+ tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
+ gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
+ return field;
}
tree
gfc_conv_descriptor_token (tree desc)
{
- tree type;
- tree field;
-
- type = TREE_TYPE (desc);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
- field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
-
+ tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
/* Should be a restricted pointer - except in the finalization wrapper. */
- gcc_assert (field != NULL_TREE
- && (TREE_TYPE (field) == prvoid_type_node
- || TREE_TYPE (field) == pvoid_type_node));
+ gcc_assert (TREE_TYPE (field) == prvoid_type_node
+ || TREE_TYPE (field) == pvoid_type_node);
+ return field;
+}
+
+static tree
+gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
+{
+ tree tmp = gfc_conv_descriptor_dimension (desc, dim);
+ tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
+ gcc_assert (field != NULL_TREE);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
+ tmp, field, NULL_TREE);
}
-
static tree
gfc_conv_descriptor_stride (tree desc, tree dim)
{
- tree tmp;
- tree field;
-
- tmp = gfc_conv_descriptor_dimension (desc, dim);
- field = TYPE_FIELDS (TREE_TYPE (tmp));
- field = gfc_advance_chain (field, STRIDE_SUBFIELD);
- gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- tmp, field, NULL_TREE);
- return tmp;
+ tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
+ gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+ return field;
}
tree
static tree
gfc_conv_descriptor_lbound (tree desc, tree dim)
{
- tree tmp;
- tree field;
-
- tmp = gfc_conv_descriptor_dimension (desc, dim);
- field = TYPE_FIELDS (TREE_TYPE (tmp));
- field = gfc_advance_chain (field, LBOUND_SUBFIELD);
- gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- tmp, field, NULL_TREE);
- return tmp;
+ tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
+ gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+ return field;
}
tree
static tree
gfc_conv_descriptor_ubound (tree desc, tree dim)
{
- tree tmp;
- tree field;
-
- tmp = gfc_conv_descriptor_dimension (desc, dim);
- field = TYPE_FIELDS (TREE_TYPE (tmp));
- field = gfc_advance_chain (field, UBOUND_SUBFIELD);
- gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
-
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- tmp, field, NULL_TREE);
- return tmp;
+ tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
+ gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
+ return field;
}
tree
void
gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
- tree *dtype_off, tree *dim_off,
- tree *dim_size, tree *stride_suboff,
- tree *lower_suboff, tree *upper_suboff)
+ tree *dtype_off, tree *span_off,
+ tree *dim_off, tree *dim_size,
+ tree *stride_suboff, tree *lower_suboff,
+ tree *upper_suboff)
{
tree field;
tree type;
*data_off = byte_position (field);
field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
*dtype_off = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
+ *span_off = byte_position (field);
field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
*dim_off = byte_position (field);
type = TREE_TYPE (TREE_TYPE (field));
else
tmp = sym->backend_decl;
- if (tmp && DECL_LANG_SPECIFIC (tmp))
+ if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
*desc = tmp;
gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
tmp = TREE_TYPE (tmp); /* The descriptor itself. */
tmp = gfc_get_element_type (tmp);
- gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
packed = gfc_create_var (build_pointer_type (tmp), "data");
tmp = build_call_expr_loc (input_location,
}
+/* Use the information in the ss to obtain the required information about
+ the type and size of an array temporary, when the lhs in an assignment
+ is a class expression. */
+
+static tree
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+{
+ gfc_ss *lhs_ss;
+ gfc_ss *rhs_ss;
+ tree tmp;
+ tree tmp2;
+ tree vptr;
+ tree rhs_class_expr = NULL_TREE;
+ tree lhs_class_expr = NULL_TREE;
+ bool unlimited_rhs = false;
+ bool unlimited_lhs = false;
+ bool rhs_function = false;
+ gfc_symbol *vtab;
+
+ /* The second element in the loop chain contains the source for the
+ temporary; ie. the rhs of the assignment. */
+ rhs_ss = ss->loop->ss->loop_chain;
+
+ if (rhs_ss != gfc_ss_terminator
+ && rhs_ss->info
+ && rhs_ss->info->expr
+ && rhs_ss->info->expr->ts.type == BT_CLASS
+ && rhs_ss->info->data.array.descriptor)
+ {
+ rhs_class_expr
+ = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
+ unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
+ if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
+ rhs_function = true;
+ }
+
+ /* For an assignment the lhs is the next element in the loop chain.
+ If we have a class rhs, this had better be a class variable
+ expression! */
+ lhs_ss = rhs_ss->loop_chain;
+ if (lhs_ss != gfc_ss_terminator
+ && lhs_ss->info
+ && lhs_ss->info->expr
+ && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
+ && lhs_ss->info->expr->ts.type == BT_CLASS)
+ {
+ tmp = lhs_ss->info->data.array.descriptor;
+ unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
+ }
+ else
+ tmp = NULL_TREE;
+
+ /* Get the lhs class expression. */
+ if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
+ lhs_class_expr = gfc_get_class_from_expr (tmp);
+ else
+ return rhs_class_expr;
+
+ gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
+
+ /* Set the lhs vptr and, if necessary, the _len field. */
+ if (rhs_class_expr)
+ {
+ /* Both lhs and rhs are class expressions. */
+ tmp = gfc_class_vptr_get (lhs_class_expr);
+ gfc_add_modify (pre, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ gfc_class_vptr_get (rhs_class_expr)));
+ if (unlimited_lhs)
+ {
+ tmp = gfc_class_len_get (lhs_class_expr);
+ if (unlimited_rhs)
+ tmp2 = gfc_class_len_get (rhs_class_expr);
+ else
+ tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ gfc_add_modify (pre, tmp, tmp2);
+ }
+
+ if (rhs_function)
+ {
+ tmp = gfc_class_data_get (rhs_class_expr);
+ gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
+ }
+ }
+ else
+ {
+ /* lhs is class and rhs is intrinsic or derived type. */
+ *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
+ *eltype = gfc_get_element_type (*eltype);
+ vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
+ vptr = vtab->backend_decl;
+ if (vptr == NULL_TREE)
+ vptr = gfc_get_symbol_decl (vtab);
+ vptr = gfc_build_addr_expr (NULL_TREE, vptr);
+ tmp = gfc_class_vptr_get (lhs_class_expr);
+ gfc_add_modify (pre, tmp,
+ fold_convert (TREE_TYPE (tmp), vptr));
+
+ if (unlimited_lhs)
+ {
+ tmp = gfc_class_len_get (lhs_class_expr);
+ if (rhs_ss->info
+ && rhs_ss->info->expr
+ && rhs_ss->info->expr->ts.type == BT_CHARACTER)
+ tmp2 = build_int_cst (TREE_TYPE (tmp),
+ rhs_ss->info->expr->ts.kind);
+ else
+ tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ gfc_add_modify (pre, tmp, tmp2);
+ }
+ }
+
+ return rhs_class_expr;
+}
+
+
+
/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
functions returning arrays. Adjusts the loop variables to be
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
class_expr = build_fold_indirect_ref_loc (input_location, initial);
- eltype = TREE_TYPE (class_expr);
- eltype = gfc_get_element_type (eltype);
/* Obtain the structure (class) expression. */
- class_expr = TREE_OPERAND (class_expr, 0);
+ class_expr = gfc_get_class_from_expr (class_expr);
gcc_assert (class_expr);
}
+ /* Otherwise, some expressions, such as class functions, arising from
+ dependency checking in assignments come here with class element type.
+ The descriptor can be obtained from the ss->info and then converted
+ to the class object. */
+ if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
+ class_expr = get_class_info_from_ss (pre, ss, &eltype);
+
+ /* If the dynamic type is not available, use the declared type. */
+ if (eltype && GFC_CLASS_TYPE_P (eltype))
+ eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
+
+ if (class_expr == NULL_TREE)
+ elemsize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (eltype));
+ else
+ {
+ /* Unlimited polymorphic entities are initialised with NULL vptr. They
+ can be tested for by checking if the len field is present. If so
+ test the vptr before using the vtable size. */
+ tmp = gfc_class_vptr_get (class_expr);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+ elemsize = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type,
+ tmp,
+ gfc_class_vtab_size_get (class_expr),
+ gfc_index_zero_node);
+ elemsize = gfc_evaluate_now (elemsize, pre);
+ elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
+ /* Casting the data as a character of the dynamic length ensures that
+ assignment of elements works when needed. */
+ eltype = gfc_get_character_type_len (1, elemsize);
+ }
+
memset (from, 0, sizeof (from));
memset (to, 0, sizeof (to));
}
}
- if (class_expr == NULL_TREE)
- elemsize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- else
- elemsize = gfc_class_vtab_size_get (class_expr);
-
/* Get the size of the array. */
if (size && !callee_alloc)
{
gfc_ref *ref;
gfc_typespec *ts;
mpz_t char_len;
+ gfc_se se;
/* Don't bother if we already know the length is a constant. */
if (*len && INTEGER_CST_P (*len))
}
}
+ /* A last ditch attempt that is sometimes needed for deferred characters. */
+ if (!ts->u.cl->backend_decl)
+ {
+ gfc_init_se (&se, NULL);
+ if (expr->rank)
+ gfc_conv_expr_descriptor (&se, expr);
+ else
+ gfc_conv_expr (&se, expr);
+ gcc_assert (se.string_length != NULL_TREE);
+ gfc_add_block_to_block (block, &se.pre);
+ ts->u.cl->backend_decl = se.string_length;
+ }
+
*len = ts->u.cl->backend_decl;
}
}
/* Also the data pointer. */
tmp = gfc_conv_array_data (se.expr);
- /* If this is a variable or address of a variable we use it directly.
+ /* If this is a variable or address or a class array, use it directly.
Otherwise we must evaluate it now to avoid breaking dependency
analysis by pulling the expressions for elemental array indices
inside the loop. */
if (!(DECL_P (tmp)
|| (TREE_CODE (tmp) == ADDR_EXPR
- && DECL_P (TREE_OPERAND (tmp, 0)))))
+ && DECL_P (TREE_OPERAND (tmp, 0)))
+ || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+ && TREE_CODE (se.expr) == COMPONENT_REF
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
tmp = gfc_evaluate_now (tmp, block);
info->data = tmp;
size = gfc_class_vtab_size_get (decl);
/* For unlimited polymorphic entities then _len component needs to be
- multiplied with the size. If no _len component is present, then
- gfc_class_len_or_zero_get () return a zero_node. */
- tmp = gfc_class_len_or_zero_get (decl);
- if (!integer_zerop (tmp))
- size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
- fold_convert (TREE_TYPE (index), size),
- fold_build2 (MAX_EXPR, TREE_TYPE (index),
- fold_convert (TREE_TYPE (index), tmp),
- fold_convert (TREE_TYPE (index),
- integer_one_node)));
- else
- size = fold_convert (TREE_TYPE (index), size);
+ multiplied with the size. */
+ size = gfc_resize_class_size_with_len (&se->pre, decl, size);
+
+ size = fold_convert (TREE_TYPE (index), size);
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
if (ar->dimen == 0)
{
- gcc_assert (ar->codimen || sym->attr.select_rank_temporary);
+ gcc_assert (ar->codimen || sym->attr.select_rank_temporary
+ || (ar->as && ar->as->corank));
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
}
}
+ decl = se->expr;
+ if (IS_CLASS_ARRAY (sym) && sym->attr.dummy && ar->as->type != AS_DEFERRED)
+ decl = sym->backend_decl;
+
cst_offset = offset = gfc_index_zero_node;
- add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
+ add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
/* Calculate the offsets from all the dimensions. Make sure to associate
the final offset so that we form a chain of loop invariant summands. */
indexse.expr = save_expr (indexse.expr);
/* Lower bound. */
- tmp = gfc_conv_array_lbound (se->expr, n);
+ tmp = gfc_conv_array_lbound (decl, n);
if (sym->attr.temporary)
{
gfc_init_se (&tmpse, se);
arrays. */
if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
{
- tmp = gfc_conv_array_ubound (se->expr, n);
+ tmp = gfc_conv_array_ubound (decl, n);
if (sym->attr.temporary)
{
gfc_init_se (&tmpse, se);
}
/* Multiply the index by the stride. */
- stride = gfc_conv_array_stride (se->expr, n);
+ stride = gfc_conv_array_stride (decl, n);
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
indexse.expr, stride);
/* A pointer array component can be detected from its field decl. Fix
the descriptor, mark the resulting variable decl and pass it to
build_array_ref. */
+ decl = NULL_TREE;
if (get_CFI_desc (sym, expr, &decl, ar))
decl = build_fold_indirect_ref_loc (input_location, decl);
if (!expr->ts.deferred && !sym->attr.codimension
decl = sym->backend_decl;
}
else if (sym->ts.type == BT_CLASS)
- decl = NULL_TREE;
+ {
+ if (UNLIMITED_POLY (sym))
+ {
+ gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr (&tmpse, class_expr);
+ if (!se->class_vptr)
+ se->class_vptr = gfc_class_vptr_get (tmpse.expr);
+ gfc_free_expr (class_expr);
+ decl = tmpse.expr;
+ }
+ else
+ decl = NULL_TREE;
+ }
se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
}
if (flag_stack_arrays)
{
gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
- space = build_decl (sym->declared_at.lb->location,
+ space = build_decl (gfc_get_location (&sym->declared_at),
VAR_DECL, create_tmp_var_name ("A"),
TREE_TYPE (TREE_TYPE (decl)));
gfc_trans_vla_type_sizes (sym, &init);
tmp = fold_build1_loc (input_location, DECL_EXPR,
TREE_TYPE (space), space);
gfc_add_expr_to_block (&init, tmp);
- addr = fold_build1_loc (sym->declared_at.lb->location,
+ addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
ADDR_EXPR, TREE_TYPE (decl), space);
gfc_add_modify (&init, decl, addr);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
if (sym->attr.optional || sym->attr.not_always_present)
{
- tmp = gfc_conv_expr_present (sym);
- stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
+ tree nullify;
+ if (TREE_CODE (parm) != PARM_DECL)
+ nullify = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ parm, null_pointer_node);
+ else
+ nullify = build_empty_stmt (input_location);
+ tmp = gfc_conv_expr_present (sym, true);
+ stmt = build3_v (COND_EXPR, tmp, stmt, nullify);
}
gfc_add_init_cleanup (block, stmt, NULL_TREE);
&& sym->attr.dummy));
if (optional_arg)
{
- tmp = gfc_conv_expr_present (sym);
- stmtInit = build3_v (COND_EXPR, tmp, stmtInit,
- build_empty_stmt (input_location));
+ tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node);
+ zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ tmpdesc, zero_init);
+ tmp = gfc_conv_expr_present (sym, true);
+ stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init);
}
/* Cleanup code. */
tmp = gfc_build_array_ref (tmp, index, NULL);
break;
+ case REF_INQUIRY:
+ switch (ref->u.i)
+ {
+ case INQUIRY_RE:
+ tmp = fold_build1_loc (input_location, REALPART_EXPR,
+ TREE_TYPE (TREE_TYPE (tmp)), tmp);
+ break;
+
+ case INQUIRY_IM:
+ tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
+ TREE_TYPE (TREE_TYPE (tmp)), tmp);
+ break;
+
+ default:
+ break;
+ }
+ break;
+
default:
gcc_unreachable ();
break;
e = gfc_constructor_first (expr->value.constructor)->expr;
gfc_init_se (&tse, NULL);
+
+ /* Avoid evaluating trailing array references since all we need is
+ the string length. */
if (e->rank)
+ tse.descriptor_only = 1;
+ if (e->rank && e->expr_type != EXPR_VARIABLE)
gfc_conv_expr_descriptor (&tse, e);
else
gfc_conv_expr (&tse, e);
gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
tse.string_length);
+ /* Make sure that deferred length components point to the hidden
+ string_length component. */
+ if (TREE_CODE (tse.expr) == COMPONENT_REF
+ && TREE_CODE (tse.string_length) == COMPONENT_REF
+ && TREE_OPERAND (tse.expr, 0) == TREE_OPERAND (tse.string_length, 0))
+ e->ts.u.cl->backend_decl = expr->ts.u.cl->backend_decl;
+
return;
case EXPR_OP:
get_array_charlen (expr->value.op.op1, se);
- /* For parentheses the expression ts.u.cl is identical. */
+ /* For parentheses the expression ts.u.cl should be identical. */
if (expr->value.op.op == INTRINSIC_PARENTHESES)
- return;
+ {
+ if (expr->value.op.op1->ts.u.cl != expr->ts.u.cl)
+ expr->ts.u.cl->backend_decl
+ = expr->value.op.op1->ts.u.cl->backend_decl;
+ return;
+ }
expr->ts.u.cl->backend_decl =
gfc_create_var (gfc_charlen_type_node, "sln");
tree desc;
stmtblock_t block;
tree start;
- tree offset;
int full;
bool subref_array_target = false;
bool deferred_array_component = false;
full = 1;
else if (se->direct_byref)
full = 0;
+ else if (info->ref->u.ar.dimen == 0 && !info->ref->next)
+ full = 1;
+ else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer)
+ full = 0;
else
full = gfc_full_array_ref_p (info->ref, NULL);
tree from;
tree to;
tree base;
- bool onebased = false, rank_remap;
+ tree offset;
ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
- rank_remap = ss->dimen < ndim;
if (se->want_coarray)
{
gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
}
- /* If we have an array section or are assigning make sure that
- the lower bound is 1. References to the full
- array should otherwise keep the original bounds. */
- if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer)
+ /* If we have an array section, are assigning or passing an array
+ section argument make sure that the lower bound is 1. References
+ to the full array should otherwise keep the original bounds. */
+ if (!info->ref || info->ref->u.ar.type != AR_FULL)
for (dim = 0; dim < loop.dimen; dim++)
if (!integer_onep (loop.from[dim]))
{
if (tmp != NULL_TREE)
gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
- offset = gfc_index_zero_node;
-
/* The following can be somewhat confusing. We have two
descriptors, a new one and the original array.
{parm, parmtype, dim} refer to the new one.
tmp = gfc_conv_descriptor_dtype (parm);
gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
- /* Set offset for assignments to pointer only to zero if it is not
- the full array. */
- if ((se->direct_byref || se->use_offset)
- && ((info->ref && info->ref->u.ar.type != AR_FULL)
- || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
- base = gfc_index_zero_node;
- else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
- base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
- else
- base = NULL_TREE;
+ /* The 1st element in the section. */
+ base = gfc_index_zero_node;
+
+ /* The offset from the 1st element in the section. */
+ offset = gfc_index_zero_node;
for (n = 0; n < ndim; n++)
{
stride = gfc_conv_array_stride (desc, n);
- /* Work out the offset. */
+ /* Work out the 1st element in the section. */
if (info->ref
&& info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
{
start, tmp);
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
tmp, stride);
- offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
- offset, tmp);
+ base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
+ base, tmp);
if (info->ref
&& info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
{
- /* For elemental dimensions, we only need the offset. */
+ /* For elemental dimensions, we only need the 1st
+ element in the section. */
continue;
}
from = loop.from[dim];
to = loop.to[dim];
- onebased = integer_onep (from);
gfc_conv_descriptor_lbound_set (&loop.pre, parm,
gfc_rank_cst[dim], from);
gfc_array_index_type,
stride, info->stride[n]);
- if ((se->direct_byref || se->use_offset)
- && ((info->ref && info->ref->u.ar.type != AR_FULL)
- || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
- {
- base = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE (base), base, stride);
- }
- 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));
- base = fold_build2_loc (input_location, PLUS_EXPR,
- TREE_TYPE (base), tmp, base);
- }
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (offset), stride, from);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (offset), offset, tmp);
/* Store the new stride. */
gfc_conv_descriptor_stride_set (&loop.pre, parm,
gfc_index_zero_node);
else
/* Point the data pointer at the 1st element in the section. */
- gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
+ gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
subref_array_target, expr);
- /* Force the offset to be -1, when the lower bound of the highest
- dimension is one and the symbol is present and is not a
- pointer/allocatable or associated. */
- if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
- && !se->data_not_needed)
- || (se->use_offset && base != NULL_TREE))
- {
- /* Set the offset depending on base. */
- tmp = rank_remap && !se->direct_byref ?
- fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, base,
- offset)
- : base;
- gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
- }
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
- && !se->data_not_needed
- && (!rank_remap || se->use_offset))
- {
- gfc_conv_descriptor_offset_set (&loop.pre, parm,
- gfc_conv_descriptor_offset_get (desc));
- }
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
- && !se->data_not_needed
- && gfc_expr_attr (expr).select_rank_temporary)
- {
- gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
- }
- else if (onebased && (!rank_remap || se->use_offset)
- && expr->symtree
- && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS
- && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
- && !expr->symtree->n.sym->attr.allocatable
- && !expr->symtree->n.sym->attr.pointer
- && !expr->symtree->n.sym->attr.host_assoc
- && !expr->symtree->n.sym->attr.use_assoc)
- {
- /* Set the offset to -1. */
- mpz_t minus_one;
- mpz_init_set_si (minus_one, -1);
- tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
- gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
- }
- else
- {
- /* Only the callee knows what the correct offset it, so just set
- it to zero here. */
- gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
- }
+ gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
+
desc = parm;
}
/* The components shall be deallocated before their containing entity. */
gfc_prepend_expr_to_block (&se->post, tmp);
}
- if (expr->ts.type == BT_CHARACTER)
+ if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
se->string_length = expr->ts.u.cl->backend_decl;
if (size)
array_parameter_size (se->expr, expr, size);
making the packing and unpacking operation visible to the
optimizers. */
- if (g77 && optimize && !optimize_size && expr->expr_type == EXPR_VARIABLE
+ if (g77 && flag_inline_arg_packing && expr->expr_type == EXPR_VARIABLE
&& !is_pointer (expr) && ! gfc_has_dimen_vector_ref (expr)
+ && !(expr->symtree->n.sym->as
+ && expr->symtree->n.sym->as->type == AS_ASSUMED_RANK)
&& (fsym == NULL || fsym->ts.type != BT_ASSUMED))
{
gfc_conv_subref_array_arg (se, expr, g77,
vref = gfc_build_array_ref (var, index, NULL);
- if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
- && !caf_enabled (caf_mode))
+ if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
{
tmp = build_fold_indirect_ref_loc (input_location,
gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank,
- COPY_ALLOC_COMP, 0, args);
+ COPY_ALLOC_COMP, caf_mode, args);
}
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
cdesc = gfc_create_var (cdesc, "cdesc");
DECL_ARTIFICIAL (cdesc) = 1;
-
+
gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
gfc_get_dtype_rank_type (1, tmp));
gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
gfc_index_one_node);
gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
gfc_index_zero_node, ubound);
-
+
if (attr->dimension)
comp = gfc_conv_descriptor_data_get (comp);
else
&& (CLASS_DATA (c)->attr.allocatable
|| CLASS_DATA (c)->attr.class_pointer))
{
+ tree vptr_decl;
+
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
+ vptr_decl = gfc_class_vptr_get (comp);
+
comp = gfc_class_data_get (comp);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
gfc_conv_descriptor_data_set (&fnblock, comp,
build_int_cst (TREE_TYPE (comp), 0));
gfc_add_expr_to_block (&fnblock, tmp);
}
+
+ /* The dynamic type of a disassociated pointer or unallocated
+ allocatable variable is its declared type. An unlimited
+ polymorphic entity has no declared type. */
+ if (!UNLIMITED_POLY (c))
+ {
+ vtab = gfc_find_derived_vtab (c->ts.u.derived);
+ if (!vtab->backend_decl)
+ gfc_get_symbol_decl (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl);
+ }
+ else
+ tmp = build_int_cst (TREE_TYPE (vptr_decl), 0);
+
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, vptr_decl, tmp);
+ gfc_add_expr_to_block (&fnblock, tmp);
+
cmp_has_alloc_comps = false;
}
/* Coarrays need the component to be nulled before the api-call
for the malloc call. */
if (UNLIMITED_POLY (c))
{
- tree ctmp;
gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
gfc_class_len_get (comp));
-
- size = gfc_evaluate_now (size, &tmpblock);
- tmp = gfc_class_len_get (comp);
- ctmp = fold_build2_loc (input_location, MULT_EXPR,
- size_type_node, size,
- fold_convert (size_type_node, tmp));
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, tmp,
- build_zero_cst (TREE_TYPE (tmp)));
- size = fold_build3_loc (input_location, COND_EXPR,
- size_type_node, tmp, ctmp, size);
- size = gfc_evaluate_now (size, &tmpblock);
+ size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
}
/* Coarray component have to have the same allocation status and
else if (flag_coarray == GFC_FCOARRAY_LIB
&& caf_in_coarray (caf_mode))
{
- tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp)
- : fold_build3_loc (input_location,
- COMPONENT_REF,
- pvoid_type_node, dest,
- c->caf_token,
- NULL_TREE);
+ tree dst_tok;
+ if (c->as)
+ dst_tok = gfc_conv_descriptor_token (dcmp);
+ else
+ {
+ /* For a scalar allocatable component the caf_token is
+ the next component. */
+ if (!c->caf_token)
+ c->caf_token = c->next->backend_decl;
+ dst_tok = fold_build3_loc (input_location,
+ COMPONENT_REF,
+ pvoid_type_node, dest,
+ c->caf_token,
+ NULL_TREE);
+ }
tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp,
ctype, rank);
}
args.image_index = image_index;
args.stat = stat;
args.errmsg = errmsg;
- args.errmsg = errmsg_len;
+ args.errmsg_len = errmsg_len;
if (rank == 0)
{
}
-/* Recursively traverse an object of paramterized derived type, generating
+/* Recursively traverse an object of parameterized derived type, generating
code to allocate parameterized components. */
tree
return res;
}
-/* Recursively traverse an object of paramterized derived type, generating
+/* Recursively traverse an object of parameterized derived type, generating
code to deallocate parameterized components. */
tree
}
-/* Recursively traverse a dummy of paramterized derived type to check the
+/* Recursively traverse a dummy of parameterized derived type to check the
values of LEN parameters. */
tree
tree alloc_expr;
tree size1;
tree size2;
+ tree elemsize1;
+ tree elemsize2;
tree array1;
tree cond_null;
tree cond;
tree jump_label2;
tree neq_size;
tree lbd;
+ tree class_expr2 = NULL_TREE;
int n;
int dim;
gfc_array_spec * as;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
array1 = gfc_conv_descriptor_data_get (desc);
+ if (expr2)
+ desc2 = rss->info->data.array.descriptor;
+ else
+ desc2 = NULL_TREE;
+
+ /* Get the old lhs element size for deferred character and class expr1. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ if (expr1->ts.u.cl->backend_decl
+ && VAR_P (expr1->ts.u.cl->backend_decl))
+ elemsize1 = expr1->ts.u.cl->backend_decl;
+ else
+ elemsize1 = lss->info->string_length;
+ }
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
+ if (tmp == NULL_TREE)
+ tmp = gfc_get_class_from_gfc_expr (expr1);
+
+ if (tmp != NULL_TREE)
+ {
+ tmp2 = gfc_class_vptr_get (tmp);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, tmp2,
+ build_int_cst (TREE_TYPE (tmp2), 0));
+ elemsize1 = gfc_class_vtab_size_get (tmp);
+ elemsize1 = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ elemsize1, gfc_index_zero_node);
+ }
+ else
+ elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
+ }
+ else
+ elemsize1 = NULL_TREE;
+ if (elemsize1 != NULL_TREE)
+ elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
+
+ /* Get the new lhs size in bytes. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ if (expr2->ts.deferred)
+ {
+ if (expr2->ts.u.cl->backend_decl
+ && VAR_P (expr2->ts.u.cl->backend_decl))
+ tmp = expr2->ts.u.cl->backend_decl;
+ else
+ tmp = rss->info->string_length;
+ }
+ else
+ {
+ tmp = expr2->ts.u.cl->backend_decl;
+ if (!tmp && expr2->expr_type == EXPR_OP
+ && expr2->value.op.op == INTRINSIC_CONCAT)
+ {
+ tmp = concat_str_length (expr2);
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
+ else if (!tmp && expr2->ts.u.cl->length)
+ {
+ gfc_se tmpse;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
+ gfc_charlen_type_node);
+ tmp = tmpse.expr;
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
+ tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+ }
+
+ if (expr1->ts.u.cl->backend_decl
+ && VAR_P (expr1->ts.u.cl->backend_decl))
+ gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+ else
+ gfc_add_modify (&fblock, lss->info->string_length, tmp);
+
+ if (expr1->ts.kind > 1)
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp),
+ tmp, build_int_cst (TREE_TYPE (tmp),
+ expr1->ts.kind));
+ }
+ else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
+ {
+ tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp,
+ expr1->ts.u.cl->backend_decl);
+ }
+ else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+ else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
+ {
+ tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
+ if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
+ tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
+
+ if (tmp != NULL_TREE)
+ tmp = gfc_class_vtab_size_get (tmp);
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+ elemsize2 = fold_convert (gfc_array_index_type, tmp);
+ elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
+
/* 7.4.1.3 "If variable is an allocated allocatable variable, it is
deallocated if expr is an array of different shape or any of the
corresponding length type parameter values of variable and expr
rss->info->string_length);
cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, tmp, cond_null);
+ cond_null= gfc_evaluate_now (cond_null, &fblock);
}
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
gfc_add_expr_to_block (&fblock, tmp);
}
+ /* ...else if the element lengths are not the same also go to
+ setting the bounds and doing the reallocation.... */
+ if (elemsize1 != NULL_TREE)
+ {
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ elemsize1, elemsize2);
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&fblock, tmp);
+ }
+
/* ....else jump past the (re)alloc code. */
tmp = build1_v (GOTO_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
gfc_add_expr_to_block (&fblock, tmp);
/* Get the rhs size and fix it. */
- if (expr2)
- desc2 = rss->info->data.array.descriptor;
- else
- desc2 = NULL_TREE;
-
size2 = gfc_index_one_node;
for (n = 0; n < expr2->rank; n++)
{
gfc_add_modify (&fblock, linfo->delta[dim], tmp);
}
- /* Get the new lhs size in bytes. */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- if (expr2->ts.deferred)
- {
- if (expr2->ts.u.cl->backend_decl
- && VAR_P (expr2->ts.u.cl->backend_decl))
- tmp = expr2->ts.u.cl->backend_decl;
- else
- tmp = rss->info->string_length;
- }
- else
- {
- tmp = expr2->ts.u.cl->backend_decl;
- if (!tmp && expr2->expr_type == EXPR_OP
- && expr2->value.op.op == INTRINSIC_CONCAT)
- {
- tmp = concat_str_length (expr2);
- expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
- }
- else if (!tmp && expr2->ts.u.cl->length)
- {
- gfc_se tmpse;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
- gfc_charlen_type_node);
- tmp = tmpse.expr;
- expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
- }
- tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
- }
-
- if (expr1->ts.u.cl->backend_decl
- && VAR_P (expr1->ts.u.cl->backend_decl))
- gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
- else
- gfc_add_modify (&fblock, lss->info->string_length, tmp);
-
- if (expr1->ts.kind > 1)
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp),
- tmp, build_int_cst (TREE_TYPE (tmp),
- expr1->ts.kind));
- }
- else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
- {
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp,
- expr1->ts.u.cl->backend_decl);
- }
- else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
- else
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
- tmp = fold_convert (gfc_array_index_type, tmp);
-
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+ gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
- tmp, size2);
+ elemsize2, size2);
size2 = fold_convert (size_type_node, size2);
size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
size2, size_one_node);
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr1->rank,type));
}
- else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+ else if (expr1->ts.type == BT_CLASS)
{
tree type;
tmp = gfc_conv_descriptor_dtype (desc);
- type = gfc_typenode_for_spec (&expr2->ts);
+
+ if (expr2->ts.type != BT_CLASS)
+ type = gfc_typenode_for_spec (&expr2->ts);
+ else
+ type = gfc_get_character_type_len (1, elemsize2);
+
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr2->rank,type));
/* Set the _len field as well... */
- tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
- if (expr2->ts.type == BT_CHARACTER)
- gfc_add_modify (&fblock, tmp,
- fold_convert (TREE_TYPE (tmp),
- TYPE_SIZE_UNIT (type)));
- else
- gfc_add_modify (&fblock, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
+ if (UNLIMITED_POLY (expr1))
+ {
+ tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
+ if (expr2->ts.type == BT_CHARACTER)
+ gfc_add_modify (&fblock, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ TYPE_SIZE_UNIT (type)));
+ else
+ gfc_add_modify (&fblock, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ }
/* ...and the vptr. */
tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
- tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
- tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
- gfc_add_modify (&fblock, tmp, tmp2);
+ if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
+ && TREE_CODE (desc2) == COMPONENT_REF)
+ {
+ tmp2 = gfc_get_class_from_expr (desc2);
+ tmp2 = gfc_class_vptr_get (tmp2);
+ }
+ else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
+ tmp2 = gfc_class_vptr_get (class_expr2);
+ else
+ {
+ tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+ tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+ }
+
+ gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
}
else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
gfc_add_block_to_block (&realloc_block, &caf_se.post);
realloc_expr = gfc_finish_block (&realloc_block);
- /* Only reallocate if sizes are different. */
+ /* Reallocate if sizes or dynamic types are different. */
+ if (elemsize1)
+ {
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ elemsize1, elemsize2);
+ tmp = gfc_evaluate_now (tmp, &fblock);
+ neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, neq_size, tmp);
+ }
tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
build_empty_stmt (input_location));
- realloc_expr = tmp;
+ realloc_expr = tmp;
/* Malloc expression. */
gfc_init_block (&alloc_block);
alloc_expr = gfc_finish_block (&alloc_block);
/* Malloc if not allocated; realloc otherwise. */
- tmp = build_int_cst (TREE_TYPE (array1), 0);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node,
- array1, tmp);
- tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+ tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
gfc_add_expr_to_block (&fblock, tmp);
/* Make sure that the scalarizer data pointer is updated. */
gfc_add_modify (&fblock, linfo->data, tmp);
}
- /* Add the exit label. */
+ /* Add the label for same shape lhs and rhs. */
tmp = build1_v (LABEL_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
Do likewise, recursively if necessary, with the allocatable components of
- derived types. */
+ derived types. This function is also called for assumed-rank arrays, which
+ are always dummy arguments. */
void
gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Make sure the frontend gets these right. */
gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp
- || has_finalizer);
+ || has_finalizer
+ || (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (ref->type == REF_SUBSTRING)
{
ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
- ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
+ if (ref->u.ss.end)
+ ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
}
/* We're only interested in array sections from now on. */