/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
In fortran all the rhs values of an assignment must be evaluated before
any assignments take place. This can require a temporary array to store the
values. We also require a temporary when we are passing array expressions
- or vector subecripts as procedure parameters.
+ or vector subscripts as procedure parameters.
Array sections are passed without copying to a temporary. These use the
scalarizer to determine the shape of the section. The flag
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "tree-gimple.h"
+#include "gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "flags.h"
#include "gfortran.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "dependency.h"
static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
-static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
+static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
/* The contents of this structure aren't actually used, just the address. */
static gfc_ss gfc_ss_terminator_var;
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
return t;
This function gets called through the following macros:
gfc_conv_descriptor_data_set
- gfc_conv_descriptor_data_set_tuples. */
+ gfc_conv_descriptor_data_set. */
void
-gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
- tree desc, tree value,
- bool tuples_p)
+gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
{
tree field, type, t;
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
+ t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
}
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- return build_fold_addr_expr (t);
+ t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ return gfc_build_addr_expr (NULL_TREE, t);
}
-tree
+static tree
gfc_conv_descriptor_offset (tree desc)
{
tree type;
field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+}
+
+tree
+gfc_conv_descriptor_offset_get (tree desc)
+{
+ return gfc_conv_descriptor_offset (desc);
+}
+
+void
+gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
+ tree value)
+{
+ tree t = gfc_conv_descriptor_offset (desc);
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
+
tree
gfc_conv_descriptor_dtype (tree desc)
{
field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
}
static tree
&& TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- tmp = gfc_build_array_ref (tmp, dim);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ tmp = gfc_build_array_ref (tmp, dim, NULL);
return tmp;
}
-tree
+static tree
gfc_conv_descriptor_stride (tree desc, tree dim)
{
tree tmp;
field = gfc_advance_chain (field, STRIDE_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
return tmp;
}
tree
+gfc_conv_descriptor_stride_get (tree desc, tree dim)
+{
+ tree type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ if (integer_zerop (dim)
+ && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+ return gfc_index_one_node;
+
+ return gfc_conv_descriptor_stride (desc, dim);
+}
+
+void
+gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
+ tree dim, tree value)
+{
+ tree t = gfc_conv_descriptor_stride (desc, dim);
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+static tree
gfc_conv_descriptor_lbound (tree desc, tree dim)
{
tree tmp;
field = gfc_advance_chain (field, LBOUND_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
return tmp;
}
tree
+gfc_conv_descriptor_lbound_get (tree desc, tree dim)
+{
+ return gfc_conv_descriptor_lbound (desc, dim);
+}
+
+void
+gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
+ tree dim, tree value)
+{
+ tree t = gfc_conv_descriptor_lbound (desc, dim);
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
+
+static tree
gfc_conv_descriptor_ubound (tree desc, tree dim)
{
tree tmp;
field = gfc_advance_chain (field, UBOUND_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
return tmp;
}
+tree
+gfc_conv_descriptor_ubound_get (tree desc, tree dim)
+{
+ return gfc_conv_descriptor_ubound (desc, dim);
+}
+
+void
+gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
+ tree dim, tree value)
+{
+ tree t = gfc_conv_descriptor_ubound (desc, dim);
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+}
/* Build a null array descriptor constructor. */
/* Set a NULL data pointer. */
tmp = build_constructor_single (type, field, null_pointer_node);
TREE_CONSTANT (tmp) = 1;
- TREE_INVARIANT (tmp) = 1;
/* All other fields are ignored. */
return tmp;
gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
- lower = tmpse.expr;
+ lower = fold_convert (gfc_array_index_type, tmpse.expr);
/* ...and the upper bound. */
gfc_init_se (&tmpse, NULL);
gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
- upper = tmpse.expr;
+ upper = fold_convert (gfc_array_index_type, tmpse.expr);
/* Set the upper bound of the loop to UPPER - LOWER. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
callee will allocate the array. If DEALLOC is true, also generate code to
free the array afterwards.
+ If INITIAL is not NULL, it is packed using internal_pack and the result used
+ as data instead of allocating a fresh, unitialized area of memory.
+
Initialization code is added to PRE and finalization code to POST.
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
static void
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
- gfc_ss_info * info, tree size, tree nelem,
- bool dynamic, bool dealloc)
+ gfc_ss_info * info, tree size, tree nelem,
+ tree initial, bool dynamic, bool dealloc)
{
tree tmp;
tree desc;
else
{
/* Allocate the temporary. */
- onstack = !dynamic && gfc_can_put_var_on_stack (size);
+ onstack = !dynamic && initial == NULL_TREE
+ && gfc_can_put_var_on_stack (size);
if (onstack)
{
tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
tmp);
tmp = gfc_create_var (tmp, "A");
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
else
{
- /* Allocate memory to hold the data. */
- tmp = gfc_call_malloc (pre, NULL, size);
- tmp = gfc_evaluate_now (tmp, pre);
+ /* Allocate memory to hold the data or call internal_pack. */
+ if (initial == NULL_TREE)
+ {
+ tmp = gfc_call_malloc (pre, NULL, size);
+ tmp = gfc_evaluate_now (tmp, pre);
+ }
+ else
+ {
+ tree packed;
+ tree source_data;
+ tree was_packed;
+ stmtblock_t do_copying;
+
+ tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
+ 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,
+ gfor_fndecl_in_pack, 1, initial);
+ tmp = fold_convert (TREE_TYPE (packed), tmp);
+ gfc_add_modify (pre, packed, tmp);
+
+ tmp = build_fold_indirect_ref_loc (input_location,
+ initial);
+ source_data = gfc_conv_descriptor_data_get (tmp);
+
+ /* internal_pack may return source->data without any allocation
+ or copying if it is already packed. If that's the case, we
+ need to allocate and copy manually. */
+
+ gfc_start_block (&do_copying);
+ tmp = gfc_call_malloc (&do_copying, NULL, size);
+ tmp = fold_convert (TREE_TYPE (packed), tmp);
+ gfc_add_modify (&do_copying, packed, tmp);
+ tmp = gfc_build_memcpy_call (packed, source_data, size);
+ gfc_add_expr_to_block (&do_copying, tmp);
+
+ was_packed = fold_build2 (EQ_EXPR, boolean_type_node,
+ packed, source_data);
+ tmp = gfc_finish_block (&do_copying);
+ tmp = build3_v (COND_EXPR, was_packed, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (pre, tmp);
+
+ tmp = fold_convert (pvoid_type_node, packed);
+ }
+
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
}
/* The offset is zero because we create temporaries with a zero
lower bound. */
- tmp = gfc_conv_descriptor_offset (desc);
- gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
+ gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
if (dealloc && !onstack)
{
fields of info if known. Returns the size of the array, or NULL for a
callee allocated array.
- PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
+ PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
+ gfc_trans_allocate_array_storage.
*/
tree
gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
gfc_loopinfo * loop, gfc_ss_info * info,
- tree eltype, bool dynamic, bool dealloc,
- bool callee_alloc)
+ tree eltype, tree initial, bool dynamic,
+ bool dealloc, bool callee_alloc, locus * where)
{
tree type;
tree desc;
int dim;
gcc_assert (info->dimen > 0);
+
+ if (gfc_option.warn_array_temp && where)
+ gfc_warning ("Creating array temporary at %L", where);
+
/* Set the lower bound to zero. */
for (dim = 0; dim < info->dimen; dim++)
{
n = loop->order[dim];
- if (n < loop->temp_dim)
- gcc_assert (integer_zerop (loop->from[n]));
- else
- {
- /* Callee allocated arrays may not have a known bound yet. */
- if (loop->to[n])
- loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- loop->to[n], loop->from[n]);
- loop->from[n] = gfc_index_zero_node;
- }
+ /* Callee allocated arrays may not have a known bound yet. */
+ if (loop->to[n])
+ loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
+ gfc_array_index_type,
+ loop->to[n], loop->from[n]), pre);
+ loop->from[n] = gfc_index_zero_node;
info->delta[dim] = gfc_index_zero_node;
info->start[dim] = gfc_index_zero_node;
/* Initialize the descriptor. */
type =
- gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
+ gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
+ GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
/* Fill in the array dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
/*
Fill in the bounds and stride. This is a packed array, so:
{
stride[n] = size
delta = ubound[n] + 1 - lbound[n];
- size = size * delta;
+ size = size * delta;
}
size = size * sizeof(element);
*/
or_expr = NULL_TREE;
+ /* If there is at least one null loop->to[n], it is a callee allocated
+ array. */
for (n = 0; n < info->dimen; n++)
- {
- if (loop->to[n] == NULL_TREE)
- {
+ if (loop->to[n] == NULL_TREE)
+ {
+ size = NULL_TREE;
+ break;
+ }
+
+ for (n = 0; n < info->dimen; n++)
+ {
+ if (size == NULL_TREE)
+ {
/* For a callee allocated array express the loop bounds in terms
of the descriptor fields. */
- tmp = build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
- gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
- loop->to[n] = tmp;
- size = NULL_TREE;
- continue;
- }
-
+ tmp =
+ fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
+ gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+ loop->to[n] = tmp;
+ continue;
+ }
+
/* Store the stride and bound components in the descriptor. */
- tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (pre, tmp, size);
+ gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
- tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
+ gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
+ gfc_index_zero_node);
- tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (pre, tmp, loop->to[n]);
+ gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
loop->to[n], gfc_index_one_node);
size = NULL_TREE;
}
- gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic,
- dealloc);
+ gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
+ dynamic, dealloc);
if (info->dimen > loop->temp_dim)
loop->temp_dim = info->dimen;
{
tree dest, src, dest_index, src_index;
gfc_loopinfo *loop;
- gfc_ss_info *dest_info, *src_info;
+ gfc_ss_info *dest_info;
gfc_ss *dest_ss, *src_ss;
gfc_se src_se;
int n;
src_ss = gfc_walk_expr (expr);
dest_ss = se->ss;
- src_info = &src_ss->data.info;
dest_info = &dest_ss->data.info;
gcc_assert (dest_info->dimen == 2);
- gcc_assert (src_info->dimen == 2);
/* Get a descriptor for EXPR. */
gfc_init_se (&src_se, NULL);
se->expr = dest;
/* Copy across the dtype field. */
- gfc_add_modify_expr (&se->pre,
+ gfc_add_modify (&se->pre,
gfc_conv_descriptor_dtype (dest),
gfc_conv_descriptor_dtype (src));
dest_index = gfc_rank_cst[n];
src_index = gfc_rank_cst[1 - n];
- gfc_add_modify_expr (&se->pre,
- gfc_conv_descriptor_stride (dest, dest_index),
- gfc_conv_descriptor_stride (src, src_index));
+ gfc_conv_descriptor_stride_set (&se->pre, dest, dest_index,
+ gfc_conv_descriptor_stride_get (src, src_index));
- gfc_add_modify_expr (&se->pre,
- gfc_conv_descriptor_lbound (dest, dest_index),
- gfc_conv_descriptor_lbound (src, src_index));
+ gfc_conv_descriptor_lbound_set (&se->pre, dest, dest_index,
+ gfc_conv_descriptor_lbound_get (src, src_index));
- gfc_add_modify_expr (&se->pre,
- gfc_conv_descriptor_ubound (dest, dest_index),
- gfc_conv_descriptor_ubound (src, src_index));
+ gfc_conv_descriptor_ubound_set (&se->pre, dest, dest_index,
+ gfc_conv_descriptor_ubound_get (src, src_index));
if (!loop->to[n])
{
gcc_assert (integer_zerop (loop->from[n]));
- loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (dest, dest_index),
- gfc_conv_descriptor_lbound (dest, dest_index));
+ loop->to[n] =
+ fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (dest, dest_index),
+ gfc_conv_descriptor_lbound_get (dest, dest_index));
}
}
dest_info->data = gfc_conv_descriptor_data_get (src);
gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
- /* Copy the offset. This is not changed by transposition: the top-left
- element is still at the same offset as before. */
- dest_info->offset = gfc_conv_descriptor_offset (src);
- gfc_add_modify_expr (&se->pre,
- gfc_conv_descriptor_offset (dest),
- dest_info->offset);
+ /* Copy the offset. This is not changed by transposition; the top-left
+ element is still at the same offset as before, except where the loop
+ starts at zero. */
+ if (!integer_zerop (loop->from[0]))
+ dest_info->offset = gfc_conv_descriptor_offset_get (src);
+ else
+ dest_info->offset = gfc_index_zero_node;
+ gfc_conv_descriptor_offset_set (&se->pre, dest,
+ dest_info->offset);
+
if (dest_info->dimen > loop->temp_dim)
loop->temp_dim = dest_info->dimen;
}
if (integer_zerop (extra))
return;
- ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
/* Add EXTRA to the upper bound. */
- tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
- gfc_add_modify_expr (pblock, ubound, tmp);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
+ gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
/* Get the value of the current data pointer. */
arg0 = gfc_conv_descriptor_data_get (desc);
/* Calculate the new array size. */
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
- tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
- arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp,
- fold_convert (gfc_array_index_type, size));
-
- /* Pick the realloc function. */
- if (gfc_index_integer_kind == 4 || gfc_index_integer_kind == 8)
- tmp = gfor_fndecl_internal_realloc;
- else
- gcc_unreachable ();
-
- /* Set the new data pointer. */
- tmp = build_call_expr (tmp, 2, arg0, arg1);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ ubound, gfc_index_one_node);
+ arg1 = fold_build2 (MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, tmp),
+ fold_convert (size_type_node, size));
+
+ /* Call the realloc() function. */
+ tmp = gfc_call_realloc (pblock, arg0, arg1);
gfc_conv_descriptor_data_set (pblock, desc, tmp);
}
of array constructor C. */
static bool
-gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
{
+ gfc_constructor *c;
gfc_iterator *i;
mpz_t val;
mpz_t len;
mpz_init (val);
dynamic = false;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
i = c->iterator;
if (i && gfc_iterator_has_dynamic_bounds (i))
/* We should have already created the offset variable. We cannot
create it here because we may be in an inner scope. */
gcc_assert (*offsetvar != NULL_TREE);
- gfc_add_modify_expr (pblock, *offsetvar, *poffset);
+ gfc_add_modify (pblock, *offsetvar, *poffset);
*poffset = *offsetvar;
TREE_USED (*offsetvar) = 1;
}
-/* Assign an element of an array constructor. */
+/* Variables needed for bounds-checking. */
+static bool first_len;
+static tree first_len_val;
+static bool typespec_chararray_ctor;
static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
gfc_conv_expr (se, expr);
/* Store the value. */
- tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
- tmp = gfc_build_array_ref (tmp, offset);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ gfc_conv_descriptor_data_get (desc));
+ tmp = gfc_build_array_ref (tmp, offset, NULL);
+
if (expr->ts.type == BT_CHARACTER)
{
+ int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+ tree esize;
+
+ esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
+ esize = fold_convert (gfc_charlen_type_node, esize);
+ esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
+ build_int_cst (gfc_charlen_type_node,
+ gfc_character_kinds[i].bit_size / 8));
+
gfc_conv_string_parameter (se);
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
{
/* The temporary is an array of pointers. */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
- gfc_add_modify_expr (&se->pre, tmp, se->expr);
+ gfc_add_modify (&se->pre, tmp, se->expr);
}
else
{
/* The temporary is an array of string values. */
- tmp = gfc_build_addr_expr (pchar_type_node, tmp);
+ tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
/* We know the temporary and the value will be the same length,
so can use memcpy. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
- tmp, se->expr, se->string_length);
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
+ se->string_length, se->expr, expr->ts.kind);
+ }
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
+ {
+ if (first_len)
+ {
+ gfc_add_modify (&se->pre, first_len_val,
+ se->string_length);
+ first_len = false;
+ }
+ else
+ {
+ /* Verify that all constructor elements are of the same
+ length. */
+ tree cond = fold_build2 (NE_EXPR, boolean_type_node,
+ first_len_val, se->string_length);
+ gfc_trans_runtime_check
+ (true, false, cond, &se->pre, &expr->where,
+ "Different CHARACTER lengths (%ld/%ld) in array constructor",
+ fold_convert (long_integer_type_node, first_len_val),
+ fold_convert (long_integer_type_node, se->string_length));
+ }
}
}
else
{
/* TODO: Should the frontend already have done this conversion? */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
- gfc_add_modify_expr (&se->pre, tmp, se->expr);
+ gfc_add_modify (&se->pre, tmp, se->expr);
}
gfc_add_block_to_block (pblock, &se->pre);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
/* Make sure the constructed array has room for the new data. */
if (dynamic)
gcc_assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
- tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
- gfc_add_modify_expr (&body, *poffset, tmp);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ *poffset, gfc_index_one_node);
+ gfc_add_modify (&body, *poffset, tmp);
/* Finish the loop. */
gfc_trans_scalarizing_loops (&loop, &body);
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
- tree desc, gfc_constructor * c,
+ tree desc, gfc_constructor_base base,
tree * poffset, tree * offsetvar,
bool dynamic)
{
stmtblock_t body;
gfc_se se;
mpz_t size;
+ gfc_constructor *c;
+
+ tree shadow_loopvar = NULL_TREE;
+ gfc_saved_var saved_loopvar;
mpz_init (size);
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
/* If this is an iterator or an array, the offset must be a variable. */
if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
gfc_put_offset_into_var (pblock, poffset, offsetvar);
+ /* Shadowing the iterator avoids changing its value and saves us from
+ keeping track of it. Further, it makes sure that there's always a
+ backend-decl for the symbol, even if there wasn't one before,
+ e.g. in the case of an iterator that appears in a specification
+ expression in an interface mapping. */
+ if (c->iterator)
+ {
+ gfc_symbol *sym = c->iterator->var->symtree->n.sym;
+ tree type = gfc_typenode_for_spec (&sym->ts);
+
+ shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
+ gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
+ }
+
gfc_start_block (&body);
if (c->expr->expr_type == EXPR_ARRAY)
n = 0;
while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
{
- p = p->next;
+ p = gfc_constructor_next (p);
n++;
}
if (n < 4)
tree init;
tree bound;
tree tmptype;
+ HOST_WIDE_INT idx = 0;
p = c;
list = NULL_TREE;
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
- if (p->expr->ts.type == BT_CHARACTER
- && POINTER_TYPE_P (type))
- {
- /* For constant character array constructors we build
- an array of pointers. */
- se.expr = gfc_build_addr_expr (pchar_type_node,
- se.expr);
- }
-
- list = tree_cons (NULL_TREE, se.expr, list);
+
+ if (c->expr->ts.type != BT_CHARACTER)
+ se.expr = fold_convert (type, se.expr);
+ /* For constant character array constructors we build
+ an array of pointers. */
+ else if (POINTER_TYPE_P (type))
+ se.expr = gfc_build_addr_expr
+ (gfc_get_pchar_type (p->expr->ts.kind),
+ se.expr);
+
+ list = tree_cons (build_int_cst (gfc_array_index_type,
+ idx++), se.expr, list);
c = p;
- p = p->next;
+ p = gfc_constructor_next (p);
}
bound = build_int_cst (NULL_TREE, n - 1);
init = build_constructor_from_list (tmptype, nreverse (list));
TREE_CONSTANT (init) = 1;
- TREE_INVARIANT (init) = 1;
TREE_STATIC (init) = 1;
/* Create a static variable to hold the data. */
tmp = gfc_create_var (tmptype, "data");
TREE_STATIC (tmp) = 1;
TREE_CONSTANT (tmp) = 1;
- TREE_INVARIANT (tmp) = 1;
TREE_READONLY (tmp) = 1;
DECL_INITIAL (tmp) = init;
init = tmp;
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
- tmp = build_fold_indirect_ref (tmp);
- tmp = gfc_build_array_ref (tmp, *poffset);
- tmp = build_fold_addr_expr (tmp);
- init = build_fold_addr_expr (init);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
+ tmp = gfc_build_array_ref (tmp, *poffset, NULL);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ init = gfc_build_addr_expr (NULL_TREE, init);
size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
bound = build_int_cst (NULL_TREE, n * size);
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY], 3,
tmp, init, bound);
gfc_add_expr_to_block (&body, tmp);
}
if (!INTEGER_CST_P (*poffset))
{
- gfc_add_modify_expr (&body, *offsetvar, *poffset);
+ gfc_add_modify (&body, *offsetvar, *poffset);
*poffset = *offsetvar;
}
}
- /* The frontend should already have done any expansions possible
+ /* The frontend should already have done any expansions
at compile-time. */
if (!c->iterator)
{
else
{
/* Build the implied do-loop. */
+ stmtblock_t implied_do_block;
tree cond;
tree end;
tree step;
- tree loopvar;
tree exit_label;
tree loopbody;
tree tmp2;
- tree tmp_loopvar;
loopbody = gfc_finish_block (&body);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, c->iterator->var);
- gfc_add_block_to_block (pblock, &se.pre);
- loopvar = se.expr;
-
- /* Make a temporary, store the current value in that
- and return it, once the loop is done. */
- tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
- gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
+ /* Create a new block that holds the implied-do loop. A temporary
+ loop-variable is used. */
+ gfc_start_block(&implied_do_block);
/* Initialize the loop. */
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->start);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify_expr (pblock, loopvar, se.expr);
+ gfc_add_block_to_block (&implied_do_block, &se.pre);
+ gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->end);
- gfc_add_block_to_block (pblock, &se.pre);
- end = gfc_evaluate_now (se.expr, pblock);
+ gfc_add_block_to_block (&implied_do_block, &se.pre);
+ end = gfc_evaluate_now (se.expr, &implied_do_block);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->step);
- gfc_add_block_to_block (pblock, &se.pre);
- step = gfc_evaluate_now (se.expr, pblock);
+ gfc_add_block_to_block (&implied_do_block, &se.pre);
+ step = gfc_evaluate_now (se.expr, &implied_do_block);
/* If this array expands dynamically, and the number of iterations
is not constant, we won't have allocated space for the static
if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
{
/* Get the number of iterations. */
- tmp = gfc_get_iteration_count (loopvar, end, step);
+ tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
/* Get the static part of C->EXPR's size. */
gfc_get_array_constructor_element_size (&size, c->expr);
/* Grow the array by TMP * TMP2 elements. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
- gfc_grow_array (pblock, desc, tmp);
+ gfc_grow_array (&implied_do_block, desc, tmp);
}
/* Generate the loop body. */
tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
build_int_cst (TREE_TYPE (step), 0));
cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
- build2 (GT_EXPR, boolean_type_node,
- loopvar, end),
- build2 (LT_EXPR, boolean_type_node,
- loopvar, end));
+ fold_build2 (GT_EXPR, boolean_type_node,
+ shadow_loopvar, end),
+ fold_build2 (LT_EXPR, boolean_type_node,
+ shadow_loopvar, end));
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
/* The main loop body. */
gfc_add_expr_to_block (&body, loopbody);
/* Increase loop variable by step. */
- tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
- gfc_add_modify_expr (&body, loopvar, tmp);
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (shadow_loopvar), shadow_loopvar, step);
+ gfc_add_modify (&body, shadow_loopvar, tmp);
/* Finish the loop. */
tmp = gfc_finish_block (&body);
tmp = build1_v (LOOP_EXPR, tmp);
- gfc_add_expr_to_block (pblock, tmp);
+ gfc_add_expr_to_block (&implied_do_block, tmp);
/* Add the exit label. */
tmp = build1_v (LABEL_EXPR, exit_label);
- gfc_add_expr_to_block (pblock, tmp);
+ gfc_add_expr_to_block (&implied_do_block, tmp);
- /* Restore the original value of the loop counter. */
- gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
+ /* Finishe the implied-do loop. */
+ tmp = gfc_finish_block(&implied_do_block);
+ gfc_add_expr_to_block(pblock, tmp);
+
+ gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
}
}
mpz_clear (size);
case REF_SUBSTRING:
if (ref->u.ss.start->expr_type != EXPR_CONSTANT
- || ref->u.ss.start->expr_type != EXPR_CONSTANT)
+ || ref->u.ss.end->expr_type != EXPR_CONSTANT)
break;
mpz_init_set_ui (char_len, 1);
mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
- *len = gfc_conv_mpz_to_tree (char_len,
- gfc_default_character_kind);
+ *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
*len = convert (gfc_charlen_type_node, *len);
mpz_clear (char_len);
return;
}
}
- *len = ts->cl->backend_decl;
+ *len = ts->u.cl->backend_decl;
}
if (*len && INTEGER_CST_P (*len))
return;
- if (!e->ref && e->ts.cl->length
- && e->ts.cl->length->expr_type == EXPR_CONSTANT)
+ if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
/* This is easy. */
- gfc_conv_const_charlen (e->ts.cl);
- *len = e->ts.cl->backend_decl;
+ gfc_conv_const_charlen (e->ts.u.cl);
+ *len = e->ts.u.cl->backend_decl;
}
else
{
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (block, &se.post);
- e->ts.cl->backend_decl = *len;
+ e->ts.u.cl->backend_decl = *len;
}
}
/* Figure out the string length of a character array constructor.
+ If len is NULL, don't calculate the length; this happens for recursive calls
+ when a sub-array-constructor is an element but not at the first position,
+ so when we're not interested in the length.
Returns TRUE if all elements are character constants. */
bool
-get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
{
+ gfc_constructor *c;
bool is_const;
-
+
is_const = TRUE;
- for (; c; c = c->next)
+
+ if (gfc_constructor_first (base) == NULL)
+ {
+ if (len)
+ *len = build_int_cstu (gfc_charlen_type_node, 0);
+ return is_const;
+ }
+
+ /* Loop over all constructor elements to find out is_const, but in len we
+ want to store the length of the first, not the last, element. We can
+ of course exit the loop as soon as is_const is found to be false. */
+ for (c = gfc_constructor_first (base);
+ c && is_const; c = gfc_constructor_next (c))
{
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
- if (!(*len && INTEGER_CST_P (*len)))
+ if (len && !(*len && INTEGER_CST_P (*len)))
*len = build_int_cstu (gfc_charlen_type_node,
c->expr->value.character.length);
break;
case EXPR_VARIABLE:
is_const = false;
- get_array_ctor_var_strlen (c->expr, len);
+ if (len)
+ get_array_ctor_var_strlen (c->expr, len);
break;
default:
is_const = false;
- get_array_ctor_all_strlen (block, c->expr, len);
+ if (len)
+ get_array_ctor_all_strlen (block, c->expr, len);
break;
}
+
+ /* After the first iteration, we don't want the length modified. */
+ len = NULL;
}
return is_const;
return zero. Note, an empty or NULL array constructor returns zero. */
unsigned HOST_WIDE_INT
-gfc_constant_array_constructor_p (gfc_constructor * c)
+gfc_constant_array_constructor_p (gfc_constructor_base base)
{
unsigned HOST_WIDE_INT nelem = 0;
+ gfc_constructor *c = gfc_constructor_first (base);
while (c)
{
if (c->iterator
|| c->expr->rank > 0
|| c->expr->expr_type != EXPR_CONSTANT)
return 0;
- c = c->next;
+ c = gfc_constructor_next (c);
nelem++;
}
return nelem;
to tree to build an initializer. */
nelem = 0;
list = NULL_TREE;
- c = expr->value.constructor;
+ c = gfc_constructor_first (expr->value.constructor);
while (c)
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, c->expr);
- if (c->expr->ts.type == BT_CHARACTER
- && POINTER_TYPE_P (type))
- se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
- list = tree_cons (NULL_TREE, se.expr, list);
- c = c->next;
+ if (c->expr->ts.type != BT_CHARACTER)
+ se.expr = fold_convert (type, se.expr);
+ else if (POINTER_TYPE_P (type))
+ se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
+ se.expr);
+ list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
+ se.expr, list);
+ c = gfc_constructor_next (c);
nelem++;
}
as.type = AS_EXPLICIT;
if (!expr->shape)
{
- as.lower[0] = gfc_int_expr (0);
- as.upper[0] = gfc_int_expr (nelem - 1);
+ as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, nelem - 1);
}
else
for (i = 0; i < expr->rank; i++)
{
int tmp = (int) mpz_get_si (expr->shape[i]);
- as.lower[i] = gfc_int_expr (0);
- as.upper[i] = gfc_int_expr (tmp - 1);
+ as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, tmp - 1);
}
- tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC);
+ tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
init = build_constructor_from_list (tmptype, nreverse (list));
TREE_CONSTANT (init) = 1;
- TREE_INVARIANT (init) = 1;
TREE_STATIC (init) = 1;
tmp = gfc_create_var (tmptype, "A");
TREE_STATIC (tmp) = 1;
TREE_CONSTANT (tmp) = 1;
- TREE_INVARIANT (tmp) = 1;
TREE_READONLY (tmp) = 1;
DECL_INITIAL (tmp) = init;
info = &ss->data.info;
info->descriptor = tmp;
- info->data = build_fold_addr_expr (tmp);
- info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
- loop->from[0]);
+ info->data = gfc_build_addr_expr (NULL_TREE, tmp);
+ info->offset = gfc_index_zero_node;
for (i = 0; i < info->dimen; i++)
{
/* Helper routine of gfc_trans_array_constructor to determine if the
bounds of the loop specified by LOOP are constant and simple enough
to use with gfc_trans_constant_array_constructor. Returns the
- the iteration count of the loop if suitable, and NULL_TREE otherwise. */
+ iteration count of the loop if suitable, and NULL_TREE otherwise. */
static tree
constant_array_constructor_loop_size (gfc_loopinfo * loop)
simplest method. */
static void
-gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
+gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
{
- gfc_constructor *c;
+ gfc_constructor_base c;
tree offset;
tree offsetvar;
tree desc;
tree type;
bool dynamic;
+ bool old_first_len, old_typespec_chararray_ctor;
+ tree old_first_len_val;
+
+ /* Save the old values for nested checking. */
+ old_first_len = first_len;
+ old_first_len_val = first_len_val;
+ old_typespec_chararray_ctor = typespec_chararray_ctor;
+
+ /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
+ typespec was given for the array constructor. */
+ typespec_chararray_ctor = (ss->expr->ts.u.cl
+ && ss->expr->ts.u.cl->length_from_typespec);
+
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
+ {
+ first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
+ first_len = true;
+ }
ss->data.info.dimen = loop->dimen;
c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
{
- bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
- if (!ss->string_length)
- gfc_todo_error ("complex character array constructors");
-
- /* It is surprising but still possible to wind up with expressions that
- lack a character length.
- TODO Find the offending part of the front end and cure this properly.
- Concatenation involving arrays is the main culprit. */
- if (!ss->expr->ts.cl)
+ bool const_string;
+
+ /* get_array_ctor_strlen walks the elements of the constructor, if a
+ typespec was given, we already know the string length and want the one
+ specified there. */
+ if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
+ && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
{
- ss->expr->ts.cl = gfc_get_charlen ();
- ss->expr->ts.cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = ss->expr->ts.cl->next;
+ gfc_se length_se;
+
+ const_string = false;
+ gfc_init_se (&length_se, NULL);
+ gfc_conv_expr_type (&length_se, ss->expr->ts.u.cl->length,
+ gfc_charlen_type_node);
+ ss->string_length = length_se.expr;
+ gfc_add_block_to_block (&loop->pre, &length_se.pre);
+ gfc_add_block_to_block (&loop->post, &length_se.post);
}
+ else
+ const_string = get_array_ctor_strlen (&loop->pre, c,
+ &ss->string_length);
+
+ /* Complex character array constructors should have been taken care of
+ and not end up here. */
+ gcc_assert (ss->string_length);
- ss->expr->ts.cl->backend_decl = ss->string_length;
+ ss->expr->ts.u.cl->backend_decl = ss->string_length;
type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
if (const_string)
if (size && compare_tree_int (size, nelem) == 0)
{
gfc_trans_constant_array_constructor (loop, ss, type);
- return;
+ goto finish;
}
}
}
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
- type, dynamic, true, false);
+ type, NULL_TREE, dynamic, true, false, where);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
/* If the array grows dynamically, the upper bound of the loop variable
is determined by the array's final upper bound. */
if (dynamic)
- loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
+ loop->to[0] = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
if (TREE_USED (offsetvar))
pushdecl (offsetvar);
gcc_assert (INTEGER_CST_P (offset));
#if 0
/* Disable bound checking for now because it's probably broken. */
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
gcc_unreachable ();
}
#endif
+
+finish:
+ /* Restore old values of globals. */
+ first_len = old_first_len;
+ first_len_val = old_first_len_val;
+ typespec_chararray_ctor = old_typespec_chararray_ctor;
}
desc = info->subscript[dim]->data.info.descriptor;
zero = gfc_rank_cst[0];
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (desc, zero),
- gfc_conv_descriptor_lbound (desc, zero));
+ gfc_conv_descriptor_ubound_get (desc, zero),
+ gfc_conv_descriptor_lbound_get (desc, zero));
tmp = gfc_evaluate_now (tmp, &loop->pre);
loop->to[n] = tmp;
}
but before the actual scalarizing loops. */
static void
-gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
+gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
+ locus * where)
{
gfc_se se;
int n;
- /* TODO: This can generate bad code if there are ordering dependencies.
- eg. a callee allocated function and an unknown size constructor. */
+ /* TODO: This can generate bad code if there are ordering dependencies,
+ e.g., a callee allocated function and an unknown size constructor. */
gcc_assert (ss != NULL);
for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
/* Scalar expression. Evaluate this now. This includes elemental
dimension indices, but not array section bounds. */
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, ss->expr);
- gfc_add_block_to_block (&loop->pre, &se.pre);
+ gfc_conv_expr (&se, ss->expr);
+ gfc_add_block_to_block (&loop->pre, &se.pre);
- if (ss->expr->ts.type != BT_CHARACTER)
- {
- /* Move the evaluation of scalar expressions outside the
- scalarization loop. */
- if (subscript)
- se.expr = convert(gfc_array_index_type, se.expr);
- se.expr = gfc_evaluate_now (se.expr, &loop->pre);
- gfc_add_block_to_block (&loop->pre, &se.post);
- }
- else
- gfc_add_block_to_block (&loop->post, &se.post);
+ if (ss->expr->ts.type != BT_CHARACTER)
+ {
+ /* Move the evaluation of scalar expressions outside the
+ scalarization loop, except for WHERE assignments. */
+ if (subscript)
+ se.expr = convert(gfc_array_index_type, se.expr);
+ if (!ss->where)
+ se.expr = gfc_evaluate_now (se.expr, &loop->pre);
+ gfc_add_block_to_block (&loop->pre, &se.post);
+ }
+ else
+ gfc_add_block_to_block (&loop->post, &se.post);
ss->data.scalar.expr = se.expr;
ss->string_length = se.string_length;
/* Add the expressions for scalar and vector subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
if (ss->data.info.subscript[n])
- gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
+ gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
+ where);
gfc_set_vector_loop_bounds (loop, &ss->data.info);
break;
break;
case GFC_SS_CONSTRUCTOR:
- gfc_trans_array_constructor (loop, ss);
+ if (ss->expr->ts.type == BT_CHARACTER
+ && ss->string_length == NULL
+ && ss->expr->ts.u.cl
+ && ss->expr->ts.u.cl->length)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, ss->expr->ts.u.cl->length,
+ gfc_charlen_type_node);
+ ss->string_length = se.expr;
+ gfc_add_block_to_block (&loop->pre, &se.pre);
+ gfc_add_block_to_block (&loop->post, &se.post);
+ }
+ gfc_trans_array_constructor (loop, ss, where);
break;
case GFC_SS_TEMP:
else
{
/* Descriptorless arrays. */
- return build_fold_addr_expr (descriptor);
+ return gfc_build_addr_expr (NULL_TREE, descriptor);
}
}
else
if (GFC_ARRAY_TYPE_P (type))
return GFC_TYPE_ARRAY_OFFSET (type);
else
- return gfc_conv_descriptor_offset (descriptor);
+ return gfc_conv_descriptor_offset_get (descriptor);
}
if (tmp != NULL_TREE)
return tmp;
- tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
+ tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
return tmp;
}
if (tmp != NULL_TREE)
return tmp;
- tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
+ tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
return tmp;
}
if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
return gfc_index_zero_node;
- tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
+ tmp = gfc_conv_descriptor_ubound_get (descriptor, gfc_rank_cst[dim]);
return tmp;
}
locus * where, bool check_upper)
{
tree fault;
- tree tmp;
+ tree tmp_lo, tmp_up;
char *msg;
const char * name = NULL;
- if (!flag_bounds_check)
+ if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
return index;
index = gfc_evaluate_now (index, &se->pre);
&& se->loop->ss->loop_chain->expr->symtree)
name = se->loop->ss->loop_chain->expr->symtree->name;
- if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
- && se->loop->ss->loop_chain->expr->symtree)
- name = se->loop->ss->loop_chain->expr->symtree->name;
-
if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
{
if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
name = "unnamed constant";
}
- /* Check lower bound. */
- tmp = gfc_conv_array_lbound (descriptor, n);
- fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
- if (name)
- asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
- gfc_msg_fault, name, n+1);
- else
- asprintf (&msg, "%s, lower bound of dimension %d exceeded, %%ld is "
- "smaller than %%ld", gfc_msg_fault, n+1);
- gfc_trans_runtime_check (fault, &se->pre, where, msg,
- fold_convert (long_integer_type_node, index),
- fold_convert (long_integer_type_node, tmp));
- gfc_free (msg);
-
- /* Check upper bound. */
+ if (descriptor->base.code != COMPONENT_REF)
+ name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
+
+ /* If upper bound is present, include both bounds in the error message. */
if (check_upper)
{
- tmp = gfc_conv_array_ubound (descriptor, n);
- fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
+ tmp_lo = gfc_conv_array_lbound (descriptor, n);
+ tmp_up = gfc_conv_array_ubound (descriptor, n);
+
+ if (name)
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "outside of expected range (%%ld:%%ld)", n+1, name);
+ else
+ asprintf (&msg, "Index '%%ld' of dimension %d "
+ "outside of expected range (%%ld:%%ld)", n+1);
+
+ fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
+ gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+ fold_convert (long_integer_type_node, index),
+ fold_convert (long_integer_type_node, tmp_lo),
+ fold_convert (long_integer_type_node, tmp_up));
+ fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp_up);
+ gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
+ fold_convert (long_integer_type_node, index),
+ fold_convert (long_integer_type_node, tmp_lo),
+ fold_convert (long_integer_type_node, tmp_up));
+ gfc_free (msg);
+ }
+ else
+ {
+ tmp_lo = gfc_conv_array_lbound (descriptor, n);
+
if (name)
- asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
- " exceeded", gfc_msg_fault, name, n+1);
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "below lower bound of %%ld", n+1, name);
else
- asprintf (&msg, "%s, upper bound of dimension %d exceeded, %%ld is "
- "larger than %%ld", gfc_msg_fault, n+1);
- gfc_trans_runtime_check (fault, &se->pre, where, msg,
+ asprintf (&msg, "Index '%%ld' of dimension %d "
+ "below lower bound of %%ld", n+1);
+
+ fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp_lo);
+ gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, index),
- fold_convert (long_integer_type_node, tmp));
+ fold_convert (long_integer_type_node, tmp_lo));
gfc_free (msg);
}
switch (ar->dimen_type[dim])
{
case DIMEN_ELEMENT:
- gcc_assert (i == -1);
/* Elemental dimension. */
gcc_assert (info->subscript[dim]
&& info->subscript[dim]->type == GFC_SS_SCALAR);
index = gfc_trans_array_bound_check (se, info->descriptor,
index, dim, &ar->where,
- (ar->as->type != AS_ASSUMED_SIZE
- && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
+ ar->as->type != AS_ASSUMED_SIZE
+ || dim < ar->dimen - 1);
break;
case DIMEN_VECTOR:
index, gfc_conv_array_stride (desc, 0));
/* Read the vector to get an index into info->descriptor. */
- data = build_fold_indirect_ref (gfc_conv_array_data (desc));
- index = gfc_build_array_ref (data, index);
+ data = build_fold_indirect_ref_loc (input_location,
+ gfc_conv_array_data (desc));
+ index = gfc_build_array_ref (data, index, NULL);
index = gfc_evaluate_now (index, &se->pre);
+ index = fold_convert (gfc_array_index_type, index);
/* Do any bounds checking on the final info->descriptor index. */
index = gfc_trans_array_bound_check (se, info->descriptor,
index, dim, &ar->where,
- (ar->as->type != AS_ASSUMED_SIZE
- && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
+ ar->as->type != AS_ASSUMED_SIZE
+ || dim < ar->dimen - 1);
break;
case DIMEN_RANGE:
gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
{
gfc_ss_info *info;
+ tree decl = NULL_TREE;
tree index;
tree tmp;
int n;
if (!integer_zerop (info->offset))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
- tmp = build_fold_indirect_ref (info->data);
- se->expr = gfc_build_array_ref (tmp, index);
+ if (se->ss->expr && is_subref_array (se->ss->expr))
+ decl = se->ss->expr->symtree->n.sym->backend_decl;
+
+ tmp = build_fold_indirect_ref_loc (input_location,
+ info->data);
+ se->expr = gfc_build_array_ref (tmp, index, decl);
}
tree tmp;
tree stride;
gfc_se indexse;
+ gfc_se tmpse;
+
+ if (ar->dimen == 0)
+ return;
/* Handle scalarized references separately. */
if (ar->type != AR_ELEMENT)
gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type);
gfc_add_block_to_block (&se->pre, &indexse.pre);
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
/* Check array bounds. */
tree cond;
/* Lower bound. */
tmp = gfc_conv_array_lbound (se->expr, n);
+ if (sym->attr.temporary)
+ {
+ gfc_init_se (&tmpse, se);
+ gfc_conv_expr_type (&tmpse, ar->as->lower[n],
+ gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ tmp = tmpse.expr;
+ }
+
cond = fold_build2 (LT_EXPR, boolean_type_node,
indexse.expr, tmp);
- asprintf (&msg, "%s for array '%s', "
- "lower bound of dimension %d exceeded, %%ld is smaller "
- "than %%ld", gfc_msg_fault, sym->name, n+1);
- gfc_trans_runtime_check (cond, &se->pre, where, msg,
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "below lower bound of %%ld", n+1, sym->name);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
fold_convert (long_integer_type_node,
indexse.expr),
fold_convert (long_integer_type_node, tmp));
/* Upper bound, but not for the last dimension of assumed-size
arrays. */
- if (n < ar->dimen - 1
- || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
+ if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
{
tmp = gfc_conv_array_ubound (se->expr, n);
+ if (sym->attr.temporary)
+ {
+ gfc_init_se (&tmpse, se);
+ gfc_conv_expr_type (&tmpse, ar->as->upper[n],
+ gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ tmp = tmpse.expr;
+ }
+
cond = fold_build2 (GT_EXPR, boolean_type_node,
indexse.expr, tmp);
- asprintf (&msg, "%s for array '%s', "
- "upper bound of dimension %d exceeded, %%ld is "
- "greater than %%ld", gfc_msg_fault, sym->name, n+1);
- gfc_trans_runtime_check (cond, &se->pre, where, msg,
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "above upper bound of %%ld", n+1, sym->name);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
fold_convert (long_integer_type_node,
indexse.expr),
fold_convert (long_integer_type_node, tmp));
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
-
+
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
tmp = build_fold_indirect_ref (tmp);
- se->expr = gfc_build_array_ref (tmp, index);
+ se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
}
/* Generates the actual loop code for a scalarization loop. */
-static void
+void
gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
stmtblock_t * pbody)
{
tree tmp;
tree loopbody;
tree exit_label;
+ tree stmt;
+ tree init;
+ tree incr;
- loopbody = gfc_finish_block (pbody);
+ if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS))
+ == (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_WS)
+ && n == loop->dimen - 1)
+ {
+ /* We create an OMP_FOR construct for the outermost scalarized loop. */
+ init = make_tree_vec (1);
+ cond = make_tree_vec (1);
+ incr = make_tree_vec (1);
+
+ /* Cycle statement is implemented with a goto. Exit statement must not
+ be present for this loop. */
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
+
+ /* Label for cycle statements (if needed). */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (pbody, tmp);
+
+ stmt = make_node (OMP_FOR);
+
+ TREE_TYPE (stmt) = void_type_node;
+ OMP_FOR_BODY (stmt) = loopbody = gfc_finish_block (pbody);
+
+ OMP_FOR_CLAUSES (stmt) = build_omp_clause (input_location,
+ OMP_CLAUSE_SCHEDULE);
+ OMP_CLAUSE_SCHEDULE_KIND (OMP_FOR_CLAUSES (stmt))
+ = OMP_CLAUSE_SCHEDULE_STATIC;
+ if (ompws_flags & OMPWS_NOWAIT)
+ OMP_CLAUSE_CHAIN (OMP_FOR_CLAUSES (stmt))
+ = build_omp_clause (input_location, OMP_CLAUSE_NOWAIT);
+
+ /* Initialize the loopvar. */
+ TREE_VEC_ELT (init, 0) = build2_v (MODIFY_EXPR, loop->loopvar[n],
+ loop->from[n]);
+ OMP_FOR_INIT (stmt) = init;
+ /* The exit condition. */
+ TREE_VEC_ELT (cond, 0) = build2 (LE_EXPR, boolean_type_node,
+ loop->loopvar[n], loop->to[n]);
+ OMP_FOR_COND (stmt) = cond;
+ /* Increment the loopvar. */
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+ loop->loopvar[n], gfc_index_one_node);
+ TREE_VEC_ELT (incr, 0) = fold_build2 (MODIFY_EXPR,
+ void_type_node, loop->loopvar[n], tmp);
+ OMP_FOR_INCR (stmt) = incr;
+
+ ompws_flags &= ~OMPWS_CURR_SINGLEUNIT;
+ gfc_add_expr_to_block (&loop->code[n], stmt);
+ }
+ else
+ {
+ loopbody = gfc_finish_block (pbody);
- /* Initialize the loopvar. */
- gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
+ /* Initialize the loopvar. */
+ if (loop->loopvar[n] != loop->from[n])
+ gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
- exit_label = gfc_build_label_decl (NULL_TREE);
+ exit_label = gfc_build_label_decl (NULL_TREE);
- /* Generate the loop body. */
- gfc_init_block (&block);
+ /* Generate the loop body. */
+ gfc_init_block (&block);
- /* The exit condition. */
- cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
- tmp = build1_v (GOTO_EXPR, exit_label);
- TREE_USED (exit_label) = 1;
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
+ /* The exit condition. */
+ cond = fold_build2 (GT_EXPR, boolean_type_node,
+ loop->loopvar[n], loop->to[n]);
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ TREE_USED (exit_label) = 1;
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
- /* The main body. */
- gfc_add_expr_to_block (&block, loopbody);
+ /* The main body. */
+ gfc_add_expr_to_block (&block, loopbody);
- /* Increment the loopvar. */
- tmp = build2 (PLUS_EXPR, gfc_array_index_type,
- loop->loopvar[n], gfc_index_one_node);
- gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
+ /* Increment the loopvar. */
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ loop->loopvar[n], gfc_index_one_node);
+ gfc_add_modify (&block, loop->loopvar[n], tmp);
- /* Build the loop. */
- tmp = gfc_finish_block (&block);
- tmp = build1_v (LOOP_EXPR, tmp);
- gfc_add_expr_to_block (&loop->code[n], tmp);
+ /* Build the loop. */
+ tmp = gfc_finish_block (&block);
+ tmp = build1_v (LOOP_EXPR, tmp);
+ gfc_add_expr_to_block (&loop->code[n], tmp);
+
+ /* Add the exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&loop->code[n], tmp);
+ }
- /* Add the exit label. */
- tmp = build1_v (LABEL_EXPR, exit_label);
- gfc_add_expr_to_block (&loop->code[n], tmp);
}
}
}
- if (loop->dimen == 0)
- gfc_todo_error ("Unable to determine rank of expression");
-
+ /* We should have determined the rank of the expression by now. If
+ not, that's bad news. */
+ gcc_assert (loop->dimen != 0);
/* Loop over all the SS in the chain. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
}
/* The rest is just runtime bound checking. */
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
stmtblock_t block;
tree lbound, ubound;
tree end;
tree size[GFC_MAX_DIMENSIONS];
- tree stride_pos, stride_neg, non_zerosized, tmp2;
+ tree stride_pos, stride_neg, non_zerosized, tmp2, tmp3;
gfc_ss_info *info;
char *msg;
int dim;
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
+ stmtblock_t inner;
+
if (ss->type != GFC_SS_SECTION)
continue;
+ gfc_start_block (&inner);
+
/* TODO: range checking for mapped dimensions. */
info = &ss->data.info;
if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
continue;
- if (n == info->ref->u.ar.dimen - 1
- && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
- || info->ref->u.ar.as->cp_was_assumed))
+ if (dim == info->ref->u.ar.dimen - 1
+ && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
check_upper = false;
else
check_upper = true;
asprintf (&msg, "Zero stride is not allowed, for dimension %d "
"of array '%s'", info->dim[n]+1,
ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg);
+ gfc_trans_runtime_check (true, false, tmp, &inner,
+ &ss->expr->where, msg);
gfc_free (msg);
desc = ss->data.info.descriptor;
stride_pos, stride_neg);
/* Check the start of the range against the lower and upper
- bounds of the array, if the range is not empty. */
- tmp = fold_build2 (LT_EXPR, boolean_type_node, info->start[n],
- lbound);
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- non_zerosized, tmp);
- asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
- " exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
- info->dim[n]+1, ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
- fold_convert (long_integer_type_node,
- info->start[n]),
- fold_convert (long_integer_type_node,
- lbound));
- gfc_free (msg);
-
+ bounds of the array, if the range is not empty.
+ If upper bound is present, include both bounds in the
+ error message. */
if (check_upper)
{
- tmp = fold_build2 (GT_EXPR, boolean_type_node,
- info->start[n], ubound);
+ tmp = fold_build2 (LT_EXPR, boolean_type_node,
+ info->start[n], lbound);
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
non_zerosized, tmp);
- asprintf (&msg, "%s, upper bound of dimension %d of array "
- "'%s' exceeded, %%ld is greater than %%ld",
- gfc_msg_fault, info->dim[n]+1,
- ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
- fold_convert (long_integer_type_node, info->start[n]),
- fold_convert (long_integer_type_node, ubound));
+ tmp2 = fold_build2 (GT_EXPR, boolean_type_node,
+ info->start[n], ubound);
+ tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ non_zerosized, tmp2);
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "outside of expected range (%%ld:%%ld)",
+ info->dim[n]+1, ss->expr->symtree->name);
+ gfc_trans_runtime_check (true, false, tmp, &inner,
+ &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, info->start[n]),
+ fold_convert (long_integer_type_node, lbound),
+ fold_convert (long_integer_type_node, ubound));
+ gfc_trans_runtime_check (true, false, tmp2, &inner,
+ &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, info->start[n]),
+ fold_convert (long_integer_type_node, lbound),
+ fold_convert (long_integer_type_node, ubound));
gfc_free (msg);
}
-
+ else
+ {
+ tmp = fold_build2 (LT_EXPR, boolean_type_node,
+ info->start[n], lbound);
+ tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ non_zerosized, tmp);
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "below lower bound of %%ld",
+ info->dim[n]+1, ss->expr->symtree->name);
+ gfc_trans_runtime_check (true, false, tmp, &inner,
+ &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, info->start[n]),
+ fold_convert (long_integer_type_node, lbound));
+ gfc_free (msg);
+ }
+
/* Compute the last element of the range, which is not
necessarily "end" (think 0:5:3, which doesn't contain 5)
and check it against both lower and upper bounds. */
- tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
+
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
info->start[n]);
- tmp2 = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp2,
+ tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp,
info->stride[n]);
- tmp2 = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
- tmp2);
-
- tmp = fold_build2 (LT_EXPR, boolean_type_node, tmp2, lbound);
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- non_zerosized, tmp);
- asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
- " exceeded, %%ld is smaller than %%ld", gfc_msg_fault,
- info->dim[n]+1, ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
- fold_convert (long_integer_type_node,
- tmp2),
- fold_convert (long_integer_type_node,
- lbound));
- gfc_free (msg);
-
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
+ tmp);
+ tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound);
+ tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ non_zerosized, tmp2);
if (check_upper)
{
- tmp = fold_build2 (GT_EXPR, boolean_type_node, tmp2, ubound);
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- non_zerosized, tmp);
- asprintf (&msg, "%s, upper bound of dimension %d of array "
- "'%s' exceeded, %%ld is greater than %%ld",
- gfc_msg_fault, info->dim[n]+1,
- ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
- fold_convert (long_integer_type_node, tmp2),
- fold_convert (long_integer_type_node, ubound));
+ tmp3 = fold_build2 (GT_EXPR, boolean_type_node, tmp, ubound);
+ tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ non_zerosized, tmp3);
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "outside of expected range (%%ld:%%ld)",
+ info->dim[n]+1, ss->expr->symtree->name);
+ gfc_trans_runtime_check (true, false, tmp2, &inner,
+ &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, tmp),
+ fold_convert (long_integer_type_node, ubound),
+ fold_convert (long_integer_type_node, lbound));
+ gfc_trans_runtime_check (true, false, tmp3, &inner,
+ &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, tmp),
+ fold_convert (long_integer_type_node, ubound),
+ fold_convert (long_integer_type_node, lbound));
gfc_free (msg);
}
-
+ else
+ {
+ asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
+ "below lower bound of %%ld",
+ info->dim[n]+1, ss->expr->symtree->name);
+ gfc_trans_runtime_check (true, false, tmp2, &inner,
+ &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, tmp),
+ fold_convert (long_integer_type_node, lbound));
+ gfc_free (msg);
+ }
+
/* Check the section sizes match. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
info->start[n]);
tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
info->stride[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, tmp);
+ tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
+ build_int_cst (gfc_array_index_type, 0));
/* We remember the size of the first section, and check all the
others against this. */
if (size[n])
{
- tree tmp3
- = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
- asprintf (&msg, "%s, size mismatch for dimension %d "
- "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
+ tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
+ asprintf (&msg, "Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
info->dim[n]+1, ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp3, &block, &ss->expr->where, msg,
+
+ gfc_trans_runtime_check (true, false, tmp3, &inner,
+ &ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp),
fold_convert (long_integer_type_node, size[n]));
+
gfc_free (msg);
}
else
- size[n] = gfc_evaluate_now (tmp, &block);
+ size[n] = gfc_evaluate_now (tmp, &inner);
}
+
+ tmp = gfc_finish_block (&inner);
+
+ /* For optional arguments, only check bounds if the argument is
+ present. */
+ if (ss->expr->symtree->n.sym->attr.optional
+ || ss->expr->symtree->n.sym->attr.not_always_present)
+ tmp = build3_v (COND_EXPR,
+ gfc_conv_expr_present (ss->expr->symtree->n.sym),
+ tmp, build_empty_stmt (input_location));
+
+ gfc_add_expr_to_block (&block, tmp);
+
}
tmp = gfc_finish_block (&block);
gfc_ss *ss;
gfc_ref *lref;
gfc_ref *rref;
- gfc_ref *aref;
int nDepend = 0;
- int temp_dim = 0;
loop->temp_ss = NULL;
- aref = dest->data.info.ref;
- temp_dim = 0;
for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
{
if (ss->type != GFC_SS_SECTION)
continue;
- if (gfc_could_be_alias (dest, ss)
- || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
+ if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
{
- nDepend = 1;
- break;
+ if (gfc_could_be_alias (dest, ss)
+ || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
+ {
+ nDepend = 1;
+ break;
+ }
}
-
- if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
+ else
{
lref = dest->expr->ref;
rref = ss->expr->ref;
if (depends[n])
loop->order[dim++] = n;
}
- temp_dim = dim;
for (n = 0; n < loop->dimen; n++)
{
if (! depends[n])
moved outside the loop. */
void
-gfc_conv_loop_setup (gfc_loopinfo * loop)
+gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
{
int n;
- int dim;
gfc_ss_info *info;
gfc_ss_info *specinfo;
gfc_ss *ss;
tree tmp;
- tree len;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
bool dynamic[GFC_MAX_DIMENSIONS];
- gfc_constructor *c;
mpz_t *cshape;
mpz_t i;
if (ss->shape)
{
/* The frontend has worked out the size for us. */
- loopspec[n] = ss;
+ if (!loopspec[n] || !loopspec[n]->shape
+ || !integer_zerop (loopspec[n]->data.info.start[n]))
+ /* Prefer zero-based descriptors if possible. */
+ loopspec[n] = ss;
continue;
}
if (ss->type == GFC_SS_CONSTRUCTOR)
{
+ gfc_constructor_base base;
/* An unknown size constructor will always be rank one.
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
can be determined at compile time. Prefer not to otherwise,
since the general case involves realloc, and it's better to
avoid that overhead if possible. */
- c = ss->expr->value.constructor;
- dynamic[n] = gfc_get_array_constructor_size (&i, c);
+ base = ss->expr->value.constructor;
+ dynamic[n] = gfc_get_array_constructor_size (&i, base);
if (!dynamic[n] || !loopspec[n])
loopspec[n] = ss;
continue;
loopspec[n] = ss; */
}
- if (!loopspec[n])
- gfc_todo_error ("Unable to find scalarization loop specifier");
+ /* We should have found the scalarization loop specifier. If not,
+ that's bad news. */
+ gcc_assert (loopspec[n]);
info = &loopspec[n]->data.info;
break;
case GFC_SS_SECTION:
- loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
- &loop->pre);
+ /* Use the end expression if it exists and is not constant,
+ so that it is only evaluated once. */
+ if (info->end[n] && !INTEGER_CST_P (info->end[n]))
+ loop->to[n] = info->end[n];
+ else
+ loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
+ &loop->pre);
break;
case GFC_SS_FUNCTION:
for (i = 0; i<=last; i++){...}; */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
loop->to[n], loop->from[n]);
- tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
+ tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
tmp, info->stride[n]);
+ tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
+ build_int_cst (gfc_array_index_type, -1));
loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
/* Make the loop variable start at 0. */
loop->from[n] = gfc_index_zero_node;
/* Add all the scalar code that can be taken out of the loops.
This may include calculating the loop bounds, so do it before
allocating the temporary. */
- gfc_add_loop_ss_code (loop, loop->ss, false);
+ gfc_add_loop_ss_code (loop, loop->ss, false, where);
/* If we want a temporary then create it. */
if (loop->temp_ss != NULL)
{
gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
+
+ /* Make absolutely sure that this is a complete type. */
+ if (loop->temp_ss->string_length)
+ loop->temp_ss->data.temp.type
+ = gfc_get_character_type_len_for_eltype
+ (TREE_TYPE (loop->temp_ss->data.temp.type),
+ loop->temp_ss->string_length);
+
tmp = loop->temp_ss->data.temp.type;
- len = loop->temp_ss->string_length;
n = loop->temp_ss->data.temp.dimen;
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
loop->temp_ss->type = GFC_SS_SECTION;
loop->temp_ss->data.info.dimen = n;
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
- &loop->temp_ss->data.info, tmp, false, true,
- false);
+ &loop->temp_ss->data.info, tmp, NULL_TREE,
+ false, true, false, where);
}
for (n = 0; n < loop->temp_dim; n++)
/* Calculate the translation from loop variables to array indices. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
- if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
+ if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
+ && ss->type != GFC_SS_CONSTRUCTOR)
+
continue;
info = &ss->data.info;
for (n = 0; n < info->dimen; n++)
{
- dim = info->dim[n];
-
/* If we are specifying the range the delta is already set. */
if (loopspec[n] != ss)
{
size = 1 - lbound;
a.ubound[n] = specified_upper_bound;
a.stride[n] = stride;
- size = ubound + size; //size = ubound + 1 - lbound
+ size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
stride = stride * size;
}
return (stride);
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
or_expr = NULL_TREE;
ubound = lower[n];
}
}
- tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
- gfc_add_modify_expr (pblock, tmp, se.expr);
+ gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
+ se.expr);
/* Work out the offset for this component. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
/* Start the calculation for the size of this dimension. */
- size = build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, se.expr);
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, se.expr);
/* Set upper bound. */
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
- gfc_add_modify_expr (pblock, tmp, se.expr);
+ gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
/* Store the stride. */
- tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
- gfc_add_modify_expr (pblock, tmp, stride);
+ gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
/* Calculate the size of this dimension. */
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
else
or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
+ size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ gfc_index_zero_node, size);
+
/* Multiply the stride by the number of elements in this dimension. */
stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
stride = gfc_evaluate_now (stride, pblock);
var = gfc_create_var (TREE_TYPE (size), "size");
gfc_start_block (&thenblock);
- gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
+ gfc_add_modify (&thenblock, var, gfc_index_zero_node);
thencase = gfc_finish_block (&thenblock);
gfc_start_block (&elseblock);
- gfc_add_modify_expr (&elseblock, var, size);
+ gfc_add_modify (&elseblock, var, size);
elsecase = gfc_finish_block (&elseblock);
tmp = gfc_evaluate_now (or_expr, pblock);
{
tree tmp;
tree pointer;
- tree allocate;
tree offset;
tree size;
gfc_expr **lower;
/* Find the last reference in the chain. */
while (ref && ref->next != NULL)
{
- gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+ || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
prev_ref = ref;
ref = ref->next;
}
if (ref == NULL || ref->type != REF_ARRAY)
return false;
+ /* Return if this is a scalar coarray. */
+ if (!prev_ref && !expr->symtree->n.sym->attr.dimension)
+ {
+ gcc_assert (expr->symtree->n.sym->attr.codimension);
+ return false;
+ }
+ else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
+ {
+ gcc_assert (prev_ref->u.c.component->attr.codimension);
+ return false;
+ }
+
if (!prev_ref)
allocatable_array = expr->symtree->n.sym->attr.allocatable;
else
- allocatable_array = prev_ref->u.c.component->allocatable;
+ allocatable_array = prev_ref->u.c.component->attr.allocatable;
/* Figure out the size of the array. */
switch (ref->u.ar.type)
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
- if (TYPE_PRECISION (gfc_array_index_type) == 32 ||
- TYPE_PRECISION (gfc_array_index_type) == 64)
- {
- if (allocatable_array)
- allocate = gfor_fndecl_allocate_array;
- else
- allocate = gfor_fndecl_allocate;
- }
- else
- gcc_unreachable ();
-
/* The allocate_array variants take the old pointer as first argument. */
if (allocatable_array)
- tmp = build_call_expr (allocate, 3, pointer, size, pstat);
+ tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
else
- tmp = build_call_expr (allocate, 2, size, pstat);
- tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
+ tmp = gfc_allocate_with_status (&se->pre, size, pstat);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
gfc_add_expr_to_block (&se->pre, tmp);
- tmp = gfc_conv_descriptor_offset (se->expr);
- gfc_add_modify_expr (&se->pre, tmp, offset);
+ gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
if (expr->ts.type == BT_DERIVED
- && expr->ts.derived->attr.alloc_comp)
+ && expr->ts.u.derived->attr.alloc_comp)
{
- tmp = gfc_nullify_alloc_comp (expr->ts.derived, se->expr,
+ tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
ref->u.ar.as->rank);
gfc_add_expr_to_block (&se->pre, tmp);
}
/*GCC ARRAYS*/
tree
-gfc_array_deallocate (tree descriptor, tree pstat)
+gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
{
tree var;
tree tmp;
STRIP_NOPS (var);
/* Parameter is the address of the data component. */
- tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
+ tmp = gfc_deallocate_with_status (var, pstat, false, expr);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
- tmp = build2 (MODIFY_EXPR, void_type_node,
- var, build_int_cst (TREE_TYPE (var), 0));
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ var, build_int_cst (TREE_TYPE (var), 0));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
case EXPR_ARRAY:
/* Create a vector of all the elements. */
- for (c = expr->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
if (c->iterator)
{
/* Problems occur when we get something like
- integer :: a(lots) = (/(i, i=1,lots)/) */
- /* TODO: Unexpanded array initializers. */
- internal_error
- ("Possible frontend bug: array constructor not expanded");
+ integer :: a(lots) = (/(i, i=1, lots)/) */
+ gfc_fatal_error ("The number of elements in the array constructor "
+ "at %L requires an increase of the allowed %d "
+ "upper limit. See -fmax-array-constructor "
+ "option", &expr->where,
+ gfc_option.flag_max_array_constructor);
+ return NULL_TREE;
}
- if (mpz_cmp_si (c->n.offset, 0) != 0)
- index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
+ if (mpz_cmp_si (c->offset, 0) != 0)
+ index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
else
index = NULL_TREE;
mpz_init (maxval);
tree tmp1, tmp2;
mpz_set (maxval, c->repeat);
- mpz_add (maxval, c->n.offset, maxval);
+ mpz_add (maxval, c->offset, maxval);
mpz_sub_ui (maxval, maxval, 1);
tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
- if (mpz_cmp_si (c->n.offset, 0) != 0)
+ if (mpz_cmp_si (c->offset, 0) != 0)
{
- mpz_add_ui (maxval, c->n.offset, 1);
+ mpz_add_ui (maxval, c->offset, 1);
tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
}
else
- tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
+ tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
- range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
+ range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
}
else
range = NULL;
CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
+
default:
- gcc_unreachable ();
+ /* Catch those occasional beasts that do not simplify
+ for one reason or another, assuming that if they are
+ standard defying the frontend will catch them. */
+ gfc_conv_expr (&se, c->expr);
+ if (range == NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ else
+ {
+ if (index != NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+ }
+ break;
}
}
break;
/* Create a constructor from the list of elements. */
tmp = build_constructor (type, v);
TREE_CONSTANT (tmp) = 1;
- TREE_INVARIANT (tmp) = 1;
return tmp;
}
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify_expr (pblock, lbound, se.expr);
+ gfc_add_modify (pblock, lbound, se.expr);
}
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify_expr (pblock, ubound, se.expr);
+ gfc_add_modify (pblock, ubound, se.expr);
}
/* The offset of this dimension. offset = offset - lbound * stride. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
if (stride)
- gfc_add_modify_expr (pblock, stride, tmp);
+ gfc_add_modify (pblock, stride, tmp);
else
stride = gfc_evaluate_now (tmp, pblock);
/* Make sure that negative size arrays are translated
to being zero size. */
- tmp = build2 (GE_EXPR, boolean_type_node,
- stride, gfc_index_zero_node);
- tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
- stride, gfc_index_zero_node);
- gfc_add_modify_expr (pblock, stride, tmp);
+ tmp = fold_build2 (GE_EXPR, boolean_type_node,
+ stride, gfc_index_zero_node);
+ tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
+ stride, gfc_index_zero_node);
+ gfc_add_modify (pblock, stride, tmp);
}
size = stride;
/* Evaluate character string length. */
if (sym->ts.type == BT_CHARACTER
- && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
{
- gfc_trans_init_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
gfc_trans_vla_type_sizes (sym, &block);
/* Emit a DECL_EXPR for this variable, which will cause the
gimplifier to allocate storage, and all that good stuff. */
- tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
+ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&block, tmp);
}
gcc_assert (!sym->module);
if (sym->ts.type == BT_CHARACTER
- && !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_trans_init_string_length (sym->ts.cl, &block);
+ && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
if (sym->attr.cray_pointee)
{
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
gfc_add_expr_to_block (&block, fnbody);
return gfc_finish_block (&block);
}
/* Allocate memory to hold the data. */
tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
- gfc_add_modify_expr (&block, decl, tmp);
+ gfc_add_modify (&block, decl, tmp);
/* Set offset of the array. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
/* Automatic arrays should not have initializers. */
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_trans_init_string_length (sym->ts.cl, &block);
+ && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
/* Evaluate the bounds of the array. */
gfc_trans_array_bounds (type, sym, &offset, &block);
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
/* Set the pointer itself if we aren't using the parameter directly. */
if (TREE_CODE (parm) != PARM_DECL)
{
tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
- gfc_add_modify_expr (&block, parm, tmp);
+ gfc_add_modify (&block, parm, tmp);
}
stmt = gfc_finish_block (&block);
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 ());
+ stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&block, stmt);
type = TREE_TYPE (tmpdesc);
gcc_assert (GFC_ARRAY_TYPE_P (type));
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
- dumdesc = build_fold_indirect_ref (dumdesc);
+ dumdesc = build_fold_indirect_ref_loc (input_location,
+ dumdesc);
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_trans_init_string_length (sym->ts.cl, &block);
+ && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
- checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
+ checkparm = (sym->as->type == AS_EXPLICIT
+ && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
|| GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
anything as we still don't know the array stride. */
partial = gfc_create_var (boolean_type_node, "partial");
TREE_USED (partial) = 1;
- tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
+ tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
- gfc_add_modify_expr (&block, partial, tmp);
+ gfc_add_modify (&block, partial, tmp);
}
else
{
if (no_repack)
{
/* Set the first stride. */
- stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
+ stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
stride = gfc_evaluate_now (stride, &block);
- tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
- tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
- gfc_index_one_node, stride);
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node,
+ stride, gfc_index_zero_node);
+ tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
+ gfc_index_one_node, stride);
stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
/* Allow the user to disable array repacking. */
stmt_unpacked = NULL_TREE;
gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
/* A library call to repack the array if necessary. */
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
- stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
+ stmt_unpacked = build_call_expr_loc (input_location,
+ gfor_fndecl_in_pack, 1, tmp);
stride = gfc_index_one_node;
+
+ if (gfc_option.warn_array_temp)
+ gfc_warning ("Creating array temporary at %L", &loc);
}
/* This is for the case where the array data is used directly without
if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
{
/* Don't repack unknown shape arrays when the first stride is 1. */
- tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
- stmt_packed, stmt_unpacked);
+ tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
+ partial, stmt_packed, stmt_unpacked);
}
else
tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
- gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
+ gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
offset = gfc_index_zero_node;
size = gfc_index_one_node;
if (checkparm || !sym->as->upper[n])
{
/* Get the bounds of the actual parameter. */
- dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
- dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
+ dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
+ dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
}
else
{
gfc_conv_expr_type (&se, sym->as->lower[n],
gfc_array_index_type);
gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify_expr (&block, lbound, se.expr);
+ gfc_add_modify (&block, lbound, se.expr);
}
ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
gfc_conv_expr_type (&se, sym->as->upper[n],
gfc_array_index_type);
gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify_expr (&block, ubound, se.expr);
+ gfc_add_modify (&block, ubound, se.expr);
}
/* Check the sizes match. */
{
/* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
char * msg;
+ tree temp;
+
+ temp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ ubound, lbound);
+ temp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, temp);
+
+ stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ dubound, dlbound);
+ stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, stride2);
+
+ tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
+ asprintf (&msg, "Dimension %d of array '%s' has extent "
+ "%%ld instead of %%ld", n+1, sym->name);
+
+ gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg,
+ fold_convert (long_integer_type_node, temp),
+ fold_convert (long_integer_type_node, stride2));
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- ubound, lbound);
- stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
- dubound, dlbound);
- tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
- asprintf (&msg, "%s for dimension %d of array '%s'",
- gfc_msg_bounds, n+1, sym->name);
- gfc_trans_runtime_check (tmp, &block, &loc, msg);
gfc_free (msg);
}
}
{
/* For assumed shape arrays move the upper bound by the same amount
as the lower bound. */
- tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ dubound, dlbound);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
- gfc_add_modify_expr (&block, ubound, tmp);
+ gfc_add_modify (&block, ubound, tmp);
}
/* The offset of this dimension. offset = offset - lbound * stride. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
if (no_repack || partial != NULL_TREE)
{
stmt_unpacked =
- gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
+ gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
}
/* Figure out the stride if not a known constant. */
/* Assign the stride. */
if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
- tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
- stmt_unpacked, stmt_packed);
+ tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
+ stmt_unpacked, stmt_packed);
else
tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
}
}
else
ubound, tmp);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
}
}
}
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
gfc_trans_vla_type_sizes (sym, &block);
if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
- stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&block, stmt);
if (sym->attr.intent != INTENT_IN)
{
/* Copy the data back. */
- tmp = build_call_expr (gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_in_unpack, 2, dumdesc, tmpdesc);
gfc_add_expr_to_block (&cleanup, tmp);
}
stmt = gfc_finish_block (&cleanup);
/* Only do the cleanup if the array was repacked. */
- tmp = build_fold_indirect_ref (dumdesc);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ dumdesc);
tmp = gfc_conv_descriptor_data_get (tmp);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
- stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
+ stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
- stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ stmt = build3_v (COND_EXPR, tmp, stmt,
+ build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&block, stmt);
}
}
+/* Calculate the overall offset, including subreferences. */
+static void
+gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
+ bool subref, gfc_expr *expr)
+{
+ tree tmp;
+ tree field;
+ tree stride;
+ tree index;
+ gfc_ref *ref;
+ gfc_se start;
+ int n;
+
+ /* If offset is NULL and this is not a subreferenced array, there is
+ nothing to do. */
+ if (offset == NULL_TREE)
+ {
+ if (subref)
+ offset = gfc_index_zero_node;
+ else
+ return;
+ }
+
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
+ tmp = gfc_build_array_ref (tmp, offset, NULL);
+
+ /* Offset the data pointer for pointer assignments from arrays with
+ subreferences; e.g. my_integer => my_type(:)%integer_component. */
+ if (subref)
+ {
+ /* Go past the array reference. */
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY &&
+ ref->u.ar.type != AR_ELEMENT)
+ {
+ ref = ref->next;
+ break;
+ }
+
+ /* Calculate the offset for each subsequent subreference. */
+ for (; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ field = ref->u.c.component->backend_decl;
+ gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
+ break;
+
+ case REF_SUBSTRING:
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
+ gfc_add_block_to_block (block, &start.pre);
+ tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+ break;
+
+ case REF_ARRAY:
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
+ && ref->u.ar.type == AR_ELEMENT);
+
+ /* TODO - Add bounds checking. */
+ stride = gfc_index_one_node;
+ index = gfc_index_zero_node;
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ {
+ tree itmp;
+ tree jtmp;
+
+ /* Update the index. */
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
+ itmp = gfc_evaluate_now (start.expr, block);
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
+ jtmp = gfc_evaluate_now (start.expr, block);
+ itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
+ itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
+ index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
+ index = gfc_evaluate_now (index, block);
+
+ /* Update the stride. */
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
+ itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
+ itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, itmp);
+ stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
+ stride = gfc_evaluate_now (stride, block);
+ }
+
+ /* Apply the index to obtain the array element. */
+ tmp = gfc_build_array_ref (tmp, index, NULL);
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+ }
+ }
+
+ /* Set the target data pointer. */
+ offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+ gfc_conv_descriptor_data_set (block, parm, offset);
+}
+
+
+/* gfc_conv_expr_descriptor needs the string length an expression
+ so that the size of the temporary can be obtained. This is done
+ by adding up the string lengths of all the elements in the
+ expression. Function with non-constant expressions have their
+ string lengths mapped onto the actual arguments using the
+ interface mapping machinery in trans-expr.c. */
+static void
+get_array_charlen (gfc_expr *expr, gfc_se *se)
+{
+ gfc_interface_mapping mapping;
+ gfc_formal_arglist *formal;
+ gfc_actual_arglist *arg;
+ gfc_se tse;
+
+ if (expr->ts.u.cl->length
+ && gfc_is_constant_expr (expr->ts.u.cl->length))
+ {
+ if (!expr->ts.u.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+ return;
+ }
+
+ switch (expr->expr_type)
+ {
+ case EXPR_OP:
+ get_array_charlen (expr->value.op.op1, se);
+
+ /* For parentheses the expression ts.u.cl is identical. */
+ if (expr->value.op.op == INTRINSIC_PARENTHESES)
+ return;
+
+ expr->ts.u.cl->backend_decl =
+ gfc_create_var (gfc_charlen_type_node, "sln");
+
+ if (expr->value.op.op2)
+ {
+ get_array_charlen (expr->value.op.op2, se);
+
+ gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
+
+ /* Add the string lengths and assign them to the expression
+ string length backend declaration. */
+ gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+ fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
+ expr->value.op.op1->ts.u.cl->backend_decl,
+ expr->value.op.op2->ts.u.cl->backend_decl));
+ }
+ else
+ gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+ expr->value.op.op1->ts.u.cl->backend_decl);
+ break;
+
+ case EXPR_FUNCTION:
+ if (expr->value.function.esym == NULL
+ || expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ {
+ gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+ break;
+ }
+
+ /* Map expressions involving the dummy arguments onto the actual
+ argument expressions. */
+ gfc_init_interface_mapping (&mapping);
+ formal = expr->symtree->n.sym->formal;
+ arg = expr->value.function.actual;
+
+ /* Set se = NULL in the calls to the interface mapping, to suppress any
+ backend stuff. */
+ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+ {
+ if (!arg->expr)
+ continue;
+ if (formal->sym)
+ gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+ }
+
+ gfc_init_se (&tse, NULL);
+
+ /* Build the expression for the character length and convert it. */
+ gfc_apply_interface_mapping (&mapping, &tse, expr->ts.u.cl->length);
+
+ gfc_add_block_to_block (&se->pre, &tse.pre);
+ gfc_add_block_to_block (&se->post, &tse.post);
+ tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
+ tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
+ build_int_cst (gfc_charlen_type_node, 0));
+ expr->ts.u.cl->backend_decl = tse.expr;
+ gfc_free_interface_mapping (&mapping);
+ break;
+
+ default:
+ gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+ break;
+ }
+}
+
+
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
tree start;
tree offset;
int full;
+ bool subref_array_target = false;
gcc_assert (ss != gfc_ss_terminator);
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
- need_tmp = gfc_ref_needs_temporary_p (expr->ref);
+ subref_array_target = se->direct_byref && is_subref_array (expr);
+ need_tmp = gfc_ref_needs_temporary_p (expr->ref)
+ && !subref_array_target;
+
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
else if (se->direct_byref)
full = 0;
else
- full = gfc_full_array_ref_p (info->ref);
+ full = gfc_full_array_ref_p (info->ref, NULL);
if (full)
{
if (se->direct_byref)
{
/* Copy the descriptor for pointer assignments. */
- gfc_add_modify_expr (&se->pre, se->expr, desc);
+ gfc_add_modify (&se->pre, se->expr, desc);
+
+ /* Add any offsets from subreferences. */
+ gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
+ subref_array_target, expr);
}
else if (se->want_pointer)
{
/* We pass full arrays directly. This means that pointers and
allocatable arrays should also work. */
- se->expr = build_fold_addr_expr (desc);
+ se->expr = gfc_build_addr_expr (NULL_TREE, desc);
}
else
{
/* For pointer assignments pass the descriptor directly. */
se->ss = secss;
- se->expr = build_fold_addr_expr (se->expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
gfc_conv_expr (se, expr);
return;
}
{
/* Elemental function. */
need_tmp = 1;
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ get_array_charlen (expr, se);
+
info = NULL;
}
else
break;
}
-
gfc_init_loopinfo (&loop);
/* Associate the SS with the loop. */
loop.temp_ss = gfc_get_ss ();
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
+
+ if (expr->ts.type == BT_CHARACTER
+ && !expr->ts.u.cl->backend_decl)
+ get_array_charlen (expr, se);
+
+ loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+
if (expr->ts.type == BT_CHARACTER)
- {
- if (expr->ts.cl == NULL)
- {
- /* This had better be a substring reference! */
- gfc_ref *char_ref = expr->ref;
- for (; char_ref; char_ref = char_ref->next)
- if (char_ref->type == REF_SUBSTRING)
- {
- mpz_t char_len;
- expr->ts.cl = gfc_get_charlen ();
- expr->ts.cl->next = char_ref->u.ss.length->next;
- char_ref->u.ss.length->next = expr->ts.cl;
-
- mpz_init_set_ui (char_len, 1);
- mpz_add (char_len, char_len,
- char_ref->u.ss.end->value.integer);
- mpz_sub (char_len, char_len,
- char_ref->u.ss.start->value.integer);
- expr->ts.cl->backend_decl
- = gfc_conv_mpz_to_tree (char_len,
- gfc_default_character_kind);
- /* Cast is necessary for *-charlen refs. */
- expr->ts.cl->backend_decl
- = convert (gfc_charlen_type_node,
- expr->ts.cl->backend_decl);
- mpz_clear (char_len);
- break;
- }
- gcc_assert (char_ref != NULL);
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
- }
- else if (expr->ts.cl->length
- && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
- {
- gfc_conv_const_charlen (expr->ts.cl);
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length
- = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
- }
- else
- {
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
- }
- se->string_length = loop.temp_ss->string_length;
- }
+ loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
else
- {
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length = NULL;
- }
+ loop.temp_ss->string_length = NULL;
+
+ se->string_length = loop.temp_ss->string_length;
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, & expr->where);
if (need_tmp)
{
{
gfc_conv_expr (&rse, expr);
if (POINTER_TYPE_P (TREE_TYPE (rse.expr)))
- rse.expr = build_fold_indirect_ref (rse.expr);
+ rse.expr = build_fold_indirect_ref_loc (input_location,
+ rse.expr);
}
else
gfc_conv_expr_val (&rse, expr);
gfc_add_block_to_block (&block, &rse.pre);
gfc_add_block_to_block (&block, &lse.pre);
- gfc_add_modify_expr (&block, lse.expr, rse.expr);
+ lse.string_length = rse.string_length;
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
+ expr->expr_type == EXPR_VARIABLE, true);
+ gfc_add_expr_to_block (&block, tmp);
/* Finish the copying loops. */
gfc_trans_scalarizing_loops (&loop, &block);
/* Otherwise make a new one. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
- loop.from, loop.to, 0);
+ loop.from, loop.to, 0,
+ GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
}
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (parm);
- gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
+ gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
- if (se->direct_byref)
+ /* Set offset for assignments to pointer only to zero if it is not
+ the full array. */
+ if (se->direct_byref
+ && info->ref && info->ref->u.ar.type != AR_FULL)
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);
from = loop.from[dim];
to = loop.to[dim];
- /* If we have an array section or are assigning to a pointer,
- make sure that the lower bound is 1. References to the full
+ /* 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->direct_byref)
+ || info->ref->u.ar.type != AR_FULL)
&& !integer_onep (from))
{
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
from = gfc_index_one_node;
}
- tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
- gfc_add_modify_expr (&loop.pre, tmp, from);
+ gfc_conv_descriptor_lbound_set (&loop.pre, parm,
+ gfc_rank_cst[dim], from);
/* Set the new upper bound. */
- tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
- gfc_add_modify_expr (&loop.pre, tmp, to);
+ gfc_conv_descriptor_ubound_set (&loop.pre, parm,
+ gfc_rank_cst[dim], to);
/* Multiply the stride by the section stride to get the
total stride. */
stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
stride, info->stride[dim]);
- if (se->direct_byref)
+ if (se->direct_byref
+ && info->ref
+ && info->ref->u.ar.type != AR_FULL)
{
base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
base, stride);
}
/* Store the new stride. */
- tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
- gfc_add_modify_expr (&loop.pre, tmp, stride);
+ gfc_conv_descriptor_stride_set (&loop.pre, parm,
+ gfc_rank_cst[dim], stride);
dim++;
}
if (se->data_not_needed)
- gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
+ gfc_conv_descriptor_data_set (&loop.pre, parm,
+ gfc_index_zero_node);
else
- {
- /* Point the data pointer at the first element in the section. */
- tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref (tmp);
- tmp = gfc_build_array_ref (tmp, offset);
- offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
- gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
- }
+ /* Point the data pointer at the 1st element in the section. */
+ gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
+ subref_array_target, expr);
if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
- && !se->data_not_needed)
+ && !se->data_not_needed)
{
/* Set the offset. */
- tmp = gfc_conv_descriptor_offset (parm);
- gfc_add_modify_expr (&loop.pre, tmp, base);
+ gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
}
else
{
/* Only the callee knows what the correct offset it, so just set
it to zero here. */
- tmp = gfc_conv_descriptor_offset (parm);
- gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
+ gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
}
desc = parm;
}
{
/* Get a pointer to the new descriptor. */
if (se->want_pointer)
- se->expr = build_fold_addr_expr (desc);
+ se->expr = gfc_build_addr_expr (NULL_TREE, desc);
else
se->expr = desc;
}
gfc_cleanup_loop (&loop);
}
+/* Helper function for gfc_conv_array_parameter if array size needs to be
+ computed. */
+
+static void
+array_parameter_size (tree desc, gfc_expr *expr, tree *size)
+{
+ tree elem;
+ if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+ *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
+ else if (expr->rank > 1)
+ *size = build_call_expr_loc (input_location,
+ gfor_fndecl_size0, 1,
+ gfc_build_addr_expr (NULL, desc));
+ else
+ {
+ tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
+
+ *size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+ *size = fold_build2 (PLUS_EXPR, gfc_array_index_type, *size,
+ gfc_index_one_node);
+ *size = fold_build2 (MAX_EXPR, gfc_array_index_type, *size,
+ gfc_index_zero_node);
+ }
+ elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ *size = fold_build2 (MULT_EXPR, gfc_array_index_type, *size,
+ fold_convert (gfc_array_index_type, elem));
+}
/* Convert an array for passing as an actual parameter. */
/* TODO: Optimize passing g77 arrays. */
void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
+ const gfc_symbol *fsym, const char *proc_name,
+ tree *size)
{
tree ptr;
tree desc;
tree tmp = NULL_TREE;
tree stmt;
tree parent = DECL_CONTEXT (current_function_decl);
- bool full_array_var, this_array_result;
+ bool full_array_var;
+ bool this_array_result;
+ bool contiguous;
+ bool no_pack;
+ bool array_constructor;
+ bool good_allocatable;
+ bool ultimate_ptr_comp;
+ bool ultimate_alloc_comp;
gfc_symbol *sym;
stmtblock_t block;
+ gfc_ref *ref;
+
+ ultimate_ptr_comp = false;
+ ultimate_alloc_comp = false;
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ref->next == NULL)
+ break;
+
+ if (ref->type == REF_COMPONENT)
+ {
+ ultimate_ptr_comp = ref->u.c.component->attr.pointer;
+ ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
+ }
+ }
+
+ full_array_var = false;
+ contiguous = false;
+
+ if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
+ full_array_var = gfc_full_array_ref_p (ref, &contiguous);
- full_array_var = (expr->expr_type == EXPR_VARIABLE
- && expr->ref->u.ar.type == AR_FULL);
sym = full_array_var ? expr->symtree->n.sym : NULL;
+ /* The symbol should have an array specification. */
+ gcc_assert (!sym || sym->as || ref->u.ar.as);
+
if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
{
get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
- expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre);
- se->string_length = expr->ts.cl->backend_decl;
+ expr->ts.u.cl->backend_decl = tmp;
+ se->string_length = tmp;
}
/* Is this the result of the enclosing procedure? */
tmp = gfc_get_symbol_decl (sym);
if (sym->ts.type == BT_CHARACTER)
- se->string_length = sym->ts.cl->backend_decl;
- if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ se->string_length = sym->ts.u.cl->backend_decl;
+
+ if (sym->ts.type == BT_DERIVED)
+ {
+ gfc_conv_expr_descriptor (se, expr, ss);
+ se->expr = gfc_conv_array_data (se->expr);
+ return;
+ }
+
+ if (!sym->attr.pointer
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
se->expr = tmp;
else
- se->expr = build_fold_addr_expr (tmp);
+ se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
+ if (size)
+ array_parameter_size (tmp, expr, size);
return;
}
+
if (sym->attr.allocatable)
{
- if (sym->attr.dummy)
+ if (sym->attr.dummy || sym->attr.result)
{
gfc_conv_expr_descriptor (se, expr, ss);
- se->expr = gfc_conv_array_data (se->expr);
+ tmp = se->expr;
}
- else
- se->expr = gfc_conv_array_data (tmp);
+ if (size)
+ array_parameter_size (tmp, expr, size);
+ se->expr = gfc_conv_array_data (tmp);
return;
}
}
+ /* A convenient reduction in scope. */
+ contiguous = g77 && !this_array_result && contiguous;
+
+ /* There is no need to pack and unpack the array, if it is contiguous
+ and not deferred or assumed shape. */
+ no_pack = ((sym && sym->as
+ && !sym->attr.pointer
+ && sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_SHAPE)
+ ||
+ (ref && ref->u.ar.as
+ && ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
+
+ no_pack = contiguous && no_pack;
+
+ /* Array constructors are always contiguous and do not need packing. */
+ array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
+
+ /* Same is true of contiguous sections from allocatable variables. */
+ good_allocatable = contiguous
+ && expr->symtree
+ && expr->symtree->n.sym->attr.allocatable;
+
+ /* Or ultimate allocatable components. */
+ ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
+
+ if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
+ {
+ gfc_conv_expr_descriptor (se, expr, ss);
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = expr->ts.u.cl->backend_decl;
+ if (size)
+ array_parameter_size (se->expr, expr, size);
+ se->expr = gfc_conv_array_data (se->expr);
+ return;
+ }
+
if (this_array_result)
{
/* Result of the enclosing function. */
gfc_conv_expr_descriptor (se, expr, ss);
- se->expr = build_fold_addr_expr (se->expr);
+ if (size)
+ array_parameter_size (se->expr, expr, size);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
- se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
+ se->expr = gfc_conv_array_data (build_fold_indirect_ref_loc (input_location,
+ se->expr));
return;
}
/* Every other type of array. */
se->want_pointer = 1;
gfc_conv_expr_descriptor (se, expr, ss);
+ if (size)
+ array_parameter_size (build_fold_indirect_ref_loc (input_location,
+ se->expr),
+ expr, size);
}
-
/* Deallocate the allocatable components of structures that are
not variable. */
if (expr->ts.type == BT_DERIVED
- && expr->ts.derived->attr.alloc_comp
+ && expr->ts.u.derived->attr.alloc_comp
&& expr->expr_type != EXPR_VARIABLE)
{
- tmp = build_fold_indirect_ref (se->expr);
- tmp = gfc_deallocate_alloc_comp (expr->ts.derived, tmp, expr->rank);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ se->expr);
+ tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
gfc_add_expr_to_block (&se->post, tmp);
}
{
desc = se->expr;
/* Repack the array. */
- ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
+ if (gfc_option.warn_array_temp)
+ {
+ if (fsym)
+ gfc_warning ("Creating array temporary at %L for argument '%s'",
+ &expr->where, fsym->name);
+ else
+ gfc_warning ("Creating array temporary at %L", &expr->where);
+ }
+
+ ptr = build_call_expr_loc (input_location,
+ gfor_fndecl_in_pack, 1, desc);
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ {
+ tmp = gfc_conv_expr_present (sym);
+ ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
+ fold_convert (TREE_TYPE (se->expr), ptr),
+ fold_convert (TREE_TYPE (se->expr), null_pointer_node));
+ }
+
ptr = gfc_evaluate_now (ptr, &se->pre);
+
se->expr = ptr;
+ if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
+ {
+ char * msg;
+
+ if (fsym && proc_name)
+ asprintf (&msg, "An array temporary was created for argument "
+ "'%s' of procedure '%s'", fsym->name, proc_name);
+ else
+ asprintf (&msg, "An array temporary was created");
+
+ tmp = build_fold_indirect_ref_loc (input_location,
+ desc);
+ tmp = gfc_conv_array_data (tmp);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node,
+ fold_convert (TREE_TYPE (tmp), ptr), tmp);
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ gfc_conv_expr_present (sym), tmp);
+
+ gfc_trans_runtime_check (false, true, tmp, &se->pre,
+ &expr->where, msg);
+ gfc_free (msg);
+ }
+
gfc_start_block (&block);
/* Copy the data back. */
- tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
- gfc_add_expr_to_block (&block, tmp);
+ if (fsym == NULL || fsym->attr.intent != INTENT_IN)
+ {
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_in_unpack, 2, desc, ptr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
/* Free the temporary. */
tmp = gfc_call_free (convert (pvoid_type_node, ptr));
gfc_init_block (&block);
/* Only if it was repacked. This code needs to be executed before the
loop cleanup code. */
- tmp = build_fold_indirect_ref (desc);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ desc);
tmp = gfc_conv_array_data (tmp);
- tmp = build2 (NE_EXPR, boolean_type_node,
- fold_convert (TREE_TYPE (tmp), ptr), tmp);
- tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ tmp = fold_build2 (NE_EXPR, boolean_type_node,
+ fold_convert (TREE_TYPE (tmp), ptr), tmp);
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ gfc_conv_expr_present (sym), tmp);
+
+ tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se->post);
gfc_trans_dealloc_allocated (tree descriptor)
{
tree tmp;
- tree ptr;
tree var;
stmtblock_t block;
var = gfc_conv_descriptor_data_get (descriptor);
STRIP_NOPS (var);
- tmp = gfc_create_var (gfc_array_index_type, NULL);
- ptr = build_fold_addr_expr (tmp);
- /* Call array_deallocate with an int* present in the second argument.
+ /* Call array_deallocate with an int * present in the second argument.
Although it is ignored here, it's presence ensures that arrays that
are already deallocated are ignored. */
- tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
+ tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
- tmp = build2 (MODIFY_EXPR, void_type_node,
- var, build_int_cst (TREE_TYPE (var), 0));
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ var, build_int_cst (TREE_TYPE (var), 0));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
tree nelems;
tree tmp;
idx = gfc_rank_cst[rank - 1];
- nelems = gfc_conv_descriptor_ubound (decl, idx);
- tmp = gfc_conv_descriptor_lbound (decl, idx);
- tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
- tmp = build2 (PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ nelems = gfc_conv_descriptor_ubound_get (decl, idx);
+ tmp = gfc_conv_descriptor_lbound_get (decl, idx);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
tmp = gfc_evaluate_now (tmp, block);
- nelems = gfc_conv_descriptor_stride (decl, idx);
- tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
+ nelems = gfc_conv_descriptor_stride_get (decl, idx);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
return gfc_evaluate_now (tmp, block);
}
-/* Allocate dest to the same size as src, and copy src -> dest. */
+/* Allocate dest to the same size as src, and copy src -> dest.
+ If no_malloc is set, only the copy is done. */
-tree
-gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
+static tree
+duplicate_allocatable(tree dest, tree src, tree type, int rank,
+ bool no_malloc)
{
tree tmp;
tree size;
tree null_data;
stmtblock_t block;
- /* If the source is null, set the destination to null. */
+ /* If the source is null, set the destination to null. Then,
+ allocate memory to the destination. */
gfc_init_block (&block);
- gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- null_data = gfc_finish_block (&block);
- gfc_init_block (&block);
+ if (rank == 0)
+ {
+ tmp = null_pointer_node;
+ tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+ null_data = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ size = TYPE_SIZE_UNIT (type);
+ if (!no_malloc)
+ {
+ tmp = gfc_call_malloc (&block, type, size);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
+ fold_convert (type, tmp));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ tmp = built_in_decls[BUILT_IN_MEMCPY];
+ tmp = build_call_expr_loc (input_location, tmp, 3,
+ dest, src, size);
+ }
+ else
+ {
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ null_data = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ nelems = get_full_array_size (&block, src, rank);
+ tmp = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
+ if (!no_malloc)
+ {
+ tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
+ tmp = gfc_call_malloc (&block, tmp, size);
+ gfc_conv_descriptor_data_set (&block, dest, tmp);
+ }
+
+ /* We know the temporary and the value will be the same length,
+ so can use memcpy. */
+ tmp = built_in_decls[BUILT_IN_MEMCPY];
+ tmp = build_call_expr_loc (input_location,
+ tmp, 3, gfc_conv_descriptor_data_get (dest),
+ gfc_conv_descriptor_data_get (src), size);
+ }
- nelems = get_full_array_size (&block, src, rank);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
- fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type))));
-
- /* Allocate memory to the destination. */
- tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
- size);
- gfc_conv_descriptor_data_set (&block, dest, tmp);
-
- /* We know the temporary and the value will be the same length,
- so can use memcpy. */
- tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = build_call_expr (tmp, 3, gfc_conv_descriptor_data_get (dest),
- gfc_conv_descriptor_data_get (src), size);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
/* Null the destination if the source is null; otherwise do
the allocate and copy. */
- null_cond = gfc_conv_descriptor_data_get (src);
+ if (rank == 0)
+ null_cond = src;
+ else
+ null_cond = gfc_conv_descriptor_data_get (src);
+
null_cond = convert (pvoid_type_node, null_cond);
- null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
- null_pointer_node);
+ null_cond = fold_build2 (NE_EXPR, boolean_type_node,
+ null_cond, null_pointer_node);
return build3_v (COND_EXPR, null_cond, tmp, null_data);
}
+/* Allocate dest to the same size as src, and copy data src -> dest. */
+
+tree
+gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
+{
+ return duplicate_allocatable(dest, src, type, rank, false);
+}
+
+
+/* Copy data src -> dest. */
+
+tree
+gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
+{
+ return duplicate_allocatable(dest, src, type, rank, true);
+}
+
+
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
-enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
+enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
+ COPY_ONLY_ALLOC_COMP};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_init_block (&fnblock);
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref (decl);
+ if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
+ decl = build_fold_indirect_ref_loc (input_location,
+ decl);
/* If this an array of derived types with allocatable components
build a loop and recursively call this function. */
|| GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
{
tmp = gfc_conv_array_data (decl);
- var = build_fold_indirect_ref (tmp);
+ var = build_fold_indirect_ref_loc (input_location,
+ tmp);
/* Get the number of elements - 1 and set the counter. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
is a full array reference, we only need the descriptor
information from dimension = rank. */
tmp = get_full_array_size (&fnblock, decl, rank);
- tmp = build2 (MINUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
null_cond = gfc_conv_descriptor_data_get (decl);
- null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
- build_int_cst (TREE_TYPE (null_cond), 0));
+ null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
+ build_int_cst (TREE_TYPE (null_cond), 0));
}
else
{
/* Build the body of the loop. */
gfc_init_block (&loopbody);
- vref = gfc_build_array_ref (var, index);
+ vref = gfc_build_array_ref (var, index, NULL);
if (purpose == COPY_ALLOC_COMP)
{
- tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
- gfc_add_expr_to_block (&fnblock, tmp);
-
- tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
- dref = gfc_build_array_ref (tmp, index);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+ {
+ tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ 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, purpose);
}
+ else if (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);
+ }
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
tmp = gfc_finish_block (&fnblock);
if (null_cond != NULL_TREE)
- tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, null_cond, tmp,
+ build_empty_stmt (input_location));
return tmp;
}
for (c = der_type->components; c; c = c->next)
{
bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
- && c->ts.derived->attr.alloc_comp;
+ && c->ts.u.derived->attr.alloc_comp;
cdecl = c->backend_decl;
ctype = TREE_TYPE (cdecl);
case DEALLOCATE_ALLOC_COMP:
/* Do not deallocate the components of ultimate pointer
components. */
- if (cmp_has_alloc_comps && !c->pointer)
+ if (cmp_has_alloc_comps && !c->attr.pointer)
{
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
- tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
- if (c->allocatable)
+ if (c->attr.allocatable && c->attr.dimension)
{
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
tmp = gfc_trans_dealloc_allocated (comp);
gfc_add_expr_to_block (&fnblock, tmp);
}
+ else if (c->attr.allocatable)
+ {
+ /* Allocatable scalar components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+
+ tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&fnblock, tmp);
+
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.allocatable)
+ {
+ /* Allocatable scalar CLASS components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+
+ /* Add reference to '$data' component. */
+ tmp = c->ts.u.derived->components->backend_decl;
+ comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ comp, tmp, NULL_TREE);
+
+ tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&fnblock, tmp);
+
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
break;
case NULLIFY_ALLOC_COMP:
- if (c->pointer)
+ if (c->attr.pointer)
continue;
- else if (c->allocatable)
+ else if (c->attr.allocatable && c->attr.dimension)
{
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
}
+ else if (c->attr.allocatable)
+ {
+ /* Allocatable scalar components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.allocatable)
+ {
+ /* Allocatable scalar CLASS components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ /* Add reference to '$data' component. */
+ tmp = c->ts.u.derived->components->backend_decl;
+ comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ comp, tmp, NULL_TREE);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
else if (cmp_has_alloc_comps)
{
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
- tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
case COPY_ALLOC_COMP:
- if (c->pointer)
+ if (c->attr.pointer)
continue;
/* We need source and destination components. */
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
- dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
dcmp = fold_convert (TREE_TYPE (comp), dcmp);
- if (c->allocatable && !cmp_has_alloc_comps)
+ if (c->attr.allocatable && !cmp_has_alloc_comps)
{
- tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
+ rank = c->as ? c->as->rank : 0;
+ tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
{
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
- gfc_add_modify_expr (&fnblock, dcmp, tmp);
- tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
+ gfc_add_modify (&fnblock, dcmp, tmp);
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
/* Recursively traverse an object of derived type, generating code to
- copy its allocatable components. */
+ copy it and its allocatable components. */
tree
gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
}
+/* Recursively traverse an object of derived type, generating code to
+ copy only its allocatable components. */
+
+tree
+gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+{
+ return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
+}
+
+
+/* Check for default initializer; sym->value is not enough as it is also
+ set for EXPR_NULL of allocatables. */
+
+static bool
+has_default_initializer (gfc_symbol *der)
+{
+ gfc_component *c;
+
+ gcc_assert (der->attr.flavor == FL_DERIVED);
+ for (c = der->components; c; c = c->next)
+ if ((c->ts.type != BT_DERIVED && c->initializer)
+ || (c->ts.type == BT_DERIVED
+ && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
+ break;
+
+ return c != NULL;
+}
+
+
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
Do likewise, recursively if necessary, with the allocatable components of
derived types. */
bool sym_has_alloc_comp;
sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
- && sym->ts.derived->attr.alloc_comp;
+ && sym->ts.u.derived->attr.alloc_comp;
/* Make sure the frontend gets these right. */
if (!(sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp))
|| TREE_CODE (sym->backend_decl) == PARM_DECL);
if (sym->ts.type == BT_CHARACTER
- && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ && !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
{
- gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock);
gfc_trans_vla_type_sizes (sym, &fnblock);
}
- /* Dummy and use associated variables don't need anything special. */
- if (sym->attr.dummy || sym->attr.use_assoc)
+ /* Dummy, use associated and result variables don't need anything special. */
+ if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
{
gfc_add_expr_to_block (&fnblock, body);
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
-
+
if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
{
- if (!sym->attr.save)
+ if (!sym->attr.save
+ && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
{
- rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_nullify_alloc_comp (sym->ts.derived, descriptor, rank);
- gfc_add_expr_to_block (&fnblock, tmp);
+ if (sym->value == NULL || !has_default_initializer (sym->ts.u.derived))
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else
+ {
+ tmp = gfc_init_default_dt (sym, NULL, false);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
}
}
else if (!GFC_DESCRIPTOR_TYPE_P (type))
{
/* If the backend_decl is not a descriptor, we must have a pointer
to one. */
- descriptor = build_fold_indirect_ref (sym->backend_decl);
+ descriptor = build_fold_indirect_ref_loc (input_location,
+ sym->backend_decl);
type = TREE_TYPE (descriptor);
}
/* NULLIFY the data pointer. */
- if (GFC_DESCRIPTOR_TYPE_P (type))
+ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
gfc_add_expr_to_block (&fnblock, body);
{
int rank;
rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_deallocate_alloc_comp (sym->ts.derived, descriptor, rank);
+ tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
- if (sym->attr.allocatable)
+ if (sym->attr.allocatable && sym->attr.dimension
+ && !sym->attr.save && !sym->attr.result)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
gfc_add_expr_to_block (&fnblock, tmp);
gfc_ref *ref;
gfc_array_ref *ar;
gfc_ss *newss;
- gfc_ss *head;
int n;
for (ref = expr->ref; ref; ref = ref->next)
continue;
ar = &ref->u.ar;
+
+ if (ar->as->rank == 0)
+ {
+ /* Scalar coarray. */
+ continue;
+ }
+
switch (ar->type)
{
case AR_ELEMENT:
newss->data.info.dimen = 0;
newss->data.info.ref = ref;
- head = newss;
-
/* We add SS chains for all the subscripts in the section. */
for (n = 0; n < ar->dimen; n++)
{
if (head == ss)
{
/* First operand is scalar. We build the chain in reverse order, so
- add the scarar SS after the second operand. */
+ add the scalar SS after the second operand. */
head = head2;
while (head && head->next != ss)
head = head->next;
gfc_ss *newss;
gfc_intrinsic_sym *isym;
gfc_symbol *sym;
+ gfc_component *comp = NULL;
isym = expr->value.function.isym;
sym = expr->symtree->n.sym;
/* A function that returns arrays. */
- if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
+ gfc_is_proc_ptr_comp (expr, &comp);
+ if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
+ || (comp && comp->attr.dimension))
{
newss = gfc_get_ss ();
newss->type = GFC_SS_FUNCTION;