/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ 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>
#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;
gcc_assert (DATA_FIELD == 0);
t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- return build_fold_addr_expr (t);
+ return gfc_build_addr_expr (NULL_TREE, t);
}
-tree
+static tree
gfc_conv_descriptor_offset (tree desc)
{
tree type;
}
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)
{
tree field;
return tmp;
}
-tree
+static tree
gfc_conv_descriptor_stride (tree desc, tree dim)
{
tree 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;
}
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;
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. */
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 (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, locus * where)
+ tree eltype, tree initial, bool dynamic,
+ bool dealloc, bool callee_alloc, locus * where)
{
tree type;
tree desc;
for (dim = 0; dim < info->dimen; dim++)
{
n = loop->order[dim];
- /* TODO: Investigate why "if (n < loop->temp_dim)
- gcc_assert (integer_zerop (loop->from[n]));" fails here. */
- if (n >= loop->temp_dim)
- {
- /* 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_ARRAY_UNKNOWN);
+ GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
{
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 =
+ tmp =
fold_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;
- }
-
+ 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 (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 (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 (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);
dest_index = gfc_rank_cst[n];
src_index = gfc_rank_cst[1 - n];
- gfc_add_modify (&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 (&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 (&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] =
fold_build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (dest, dest_index),
- gfc_conv_descriptor_lbound (dest, dest_index));
+ gfc_conv_descriptor_ubound_get (dest, dest_index),
+ gfc_conv_descriptor_lbound_get (dest, dest_index));
}
}
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 (src);
+ dest_info->offset = gfc_conv_descriptor_offset_get (src);
else
dest_info->offset = gfc_index_zero_node;
- gfc_add_modify (&se->pre,
- gfc_conv_descriptor_offset (dest),
- dest_info->offset);
+ 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 = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
- gfc_add_modify (pblock, ubound, tmp);
+ 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);
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))
gfc_conv_expr (se, expr);
/* Store the value. */
- tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
+ 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)
gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
se->string_length, se->expr, expr->ts.kind);
}
- if (flag_bounds_check && !typespec_chararray_ctor)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
{
if (first_len)
{
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 (c->expr->ts.type != BT_CHARACTER)
+ se.expr = fold_convert (type, se.expr);
/* For constant character array constructors we build
an array of pointers. */
- if (p->expr->ts.type == BT_CHARACTER
- && POINTER_TYPE_P (type))
+ 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 (NULL_TREE, se.expr, list);
+ 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);
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
tmp = gfc_build_array_ref (tmp, *poffset, NULL);
- tmp = build_fold_addr_expr (tmp);
- init = build_fold_addr_expr (init);
+ 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);
}
}
- /* 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);
- if (c->iterator->var->symtree->n.sym->backend_decl)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, c->iterator->var);
- gfc_add_block_to_block (pblock, &se.pre);
- loopvar = se.expr;
- }
- else
- {
- /* If the iterator appears in a specification expression in
- an interface mapping, we need to make a temp for the loop
- variable because it is not declared locally. */
- loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
- loopvar = gfc_create_var (loopvar, "loopvar");
- }
-
- /* 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 (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 (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. */
build_int_cst (TREE_TYPE (step), 0));
cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
fold_build2 (GT_EXPR, boolean_type_node,
- loopvar, end),
+ shadow_loopvar, end),
fold_build2 (LT_EXPR, boolean_type_node,
- loopvar, end));
+ 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 = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
- gfc_add_modify (&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);
+
+ /* Finishe the implied-do loop. */
+ tmp = gfc_finish_block(&implied_do_block);
+ gfc_add_expr_to_block(pblock, tmp);
- /* Restore the original value of the loop counter. */
- gfc_add_modify (pblock, loopvar, tmp_loopvar);
+ gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
}
}
mpz_clear (size);
}
}
- *len = ts->cl->backend_decl;
+ *len = ts->u.cl->backend_decl;
}
if (*len && INTEGER_CST_P (*len))
return;
- if (!e->ref && e->ts.cl && 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;
}
}
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;
- if (c == NULL)
+ if (gfc_constructor_first (base) == NULL)
{
if (len)
*len = build_int_cstu (gfc_charlen_type_node, 0);
/* 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 && is_const; c = c->next)
+ for (c = gfc_constructor_first (base);
+ c && is_const; c = gfc_constructor_next (c))
{
switch (c->expr->expr_type)
{
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))
+ 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 (NULL_TREE, se.expr, list);
- c = c->next;
+ 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));
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++)
{
static void
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;
- tree loopfrom;
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.cl
- && ss->expr->ts.cl->length_from_typespec);
+ typespec_chararray_ctor = (ss->expr->ts.u.cl
+ && ss->expr->ts.u.cl->length_from_typespec);
- if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
- && !typespec_chararray_ctor)
+ 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;
/* 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.cl->length
- && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (typespec_chararray_ctor && ss->expr->ts.u.cl->length
+ && ss->expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
{
gfc_se length_se;
const_string = false;
gfc_init_se (&length_se, NULL);
- gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
+ 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);
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;
}
}
}
- /* Temporarily reset the loop variables, so that the returned temporary
- has the right size and bounds. This seems only to be necessary for
- 1D arrays. */
- if (!integer_zerop (loop->from[0]) && loop->dimen == 1)
- {
- loopfrom = loop->from[0];
- loop->from[0] = gfc_index_zero_node;
- loop->to[0] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- loop->to[0], loopfrom);
- }
- else
- loopfrom = NULL_TREE;
-
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
- type, dynamic, true, false, where);
-
- if (loopfrom != NULL_TREE)
- {
- loop->from[0] = loopfrom;
- loop->to[0] = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- loop->to[0], loopfrom);
- /* In the case of a non-zero from, the temporary needs an offset
- so that subsequent indexing is correct. */
- ss->data.info.offset = fold_build1 (NEGATE_EXPR,
- gfc_array_index_type,
- loop->from[0]);
- }
+ 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;
}
case GFC_SS_CONSTRUCTOR:
if (ss->expr->ts.type == BT_CHARACTER
&& ss->string_length == NULL
- && ss->expr->ts.cl
- && ss->expr->ts.cl->length)
+ && ss->expr->ts.u.cl
+ && ss->expr->ts.u.cl->length)
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
+ 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);
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"
- "(%%ld < %%ld)", gfc_msg_fault, name, n+1);
- else
- asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
- gfc_msg_fault, n+1);
- 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));
- 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 (%%ld > %%ld)", 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 > %%ld)",
- gfc_msg_fault, n+1);
+ 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);
}
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));
+ 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:
if (se->ss->expr && is_subref_array (se->ss->expr))
decl = se->ss->expr->symtree->n.sym->backend_decl;
- tmp = build_fold_indirect_ref (info->data);
+ 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 < %%ld)",
- gfc_msg_fault, sym->name, n+1);
+ 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),
/* 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 > %%ld)",
- gfc_msg_fault, sym->name, n+1);
+ 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),
/* 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 (&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 = 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 ());
- 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 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- loop->loopvar[n], gfc_index_one_node);
- gfc_add_modify (&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);
}
}
/* 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;
continue;
if (dim == info->ref->u.ar.dimen - 1
- && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
- || info->ref->u.ar.as->cp_was_assumed))
+ && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
check_upper = false;
else
check_upper = true;
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 < %%ld)", gfc_msg_fault,
- 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);
-
+ 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 > %%ld)", gfc_msg_fault,
+ 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, ubound));
+ 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 < %%ld)", gfc_msg_fault,
- 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,
- 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 > %%ld)", gfc_msg_fault,
+ 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, tmp, &inner,
- &ss->expr->where, msg,
- fold_convert (long_integer_type_node, tmp2),
- 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, 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;
-
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,
+ 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 (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
|| 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 ());
+ tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&block, tmp);
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])
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;
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:
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, where);
+ &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)
{
ubound = lower[n];
}
}
- tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
- gfc_add_modify (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);
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 (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 (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);
/* 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)
/* The allocate_array variants take the old pointer as first argument. */
if (allocatable_array)
- tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
+ tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
else
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 (&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 = gfc_deallocate_with_status (var, pstat, false);
+ tmp = gfc_deallocate_with_status (var, pstat, false, expr);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
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 = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
}
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;
/* 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_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.u.cl, NULL, &block);
gfc_trans_vla_type_sizes (sym, &block);
gcc_assert (!sym->module);
if (sym->ts.type == BT_CHARACTER
- && !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_conv_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);
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_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);
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_conv_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 (&block, partial, tmp);
}
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 = fold_build2 (EQ_EXPR, boolean_type_node,
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 (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
{
{
/* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
char * msg;
+ tree temp;
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- ubound, lbound);
- stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ 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);
- 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 (true, false, tmp, &block, &loc, msg);
+ 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));
+
gfc_free (msg);
}
}
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. */
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 = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
- stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ 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);
}
}
tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref (tmp);
+ 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
}
-/* gfc_conv_expr_descriptor needs the character length of elemental
- functions before the function is called so that the size of the
- temporary can be obtained. The only way to do this is to convert
- the expression, mapping onto the actual arguments. */
+/* 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_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
+get_array_charlen (gfc_expr *expr, gfc_se *se)
{
gfc_interface_mapping mapping;
gfc_formal_arglist *formal;
gfc_actual_arglist *arg;
gfc_se tse;
- formal = expr->symtree->n.sym->formal;
- arg = expr->value.function.actual;
- gfc_init_interface_mapping (&mapping);
-
- /* 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 (expr->ts.u.cl->length
+ && gfc_is_constant_expr (expr->ts.u.cl->length))
{
- if (!arg->expr)
- continue;
- if (formal->sym)
- gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+ if (!expr->ts.u.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.u.cl, expr, &se->pre);
+ return;
}
- gfc_init_se (&tse, NULL);
+ 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);
- /* Build the expression for the character length and convert it. */
- gfc_apply_interface_mapping (&mapping, &tse, expr->ts.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;
- 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.cl->backend_decl = tse.expr;
- gfc_free_interface_mapping (&mapping);
+ 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
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)
{
{
/* 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.cl->length->expr_type != EXPR_CONSTANT)
- get_elemental_fcn_charlen (expr, se);
+ && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ get_array_charlen (expr, se);
info = NULL;
}
break;
}
-
gfc_init_loopinfo (&loop);
/* Associate the SS with the loop. */
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
- if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, &se->pre);
+ 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)
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
else
loop.temp_ss->string_length = NULL;
{
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);
lse.string_length = rse.string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
- expr->expr_type == EXPR_VARIABLE);
+ expr->expr_type == EXPR_VARIABLE, true);
gfc_add_expr_to_block (&block, tmp);
/* Finish the copying loops. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
loop.from, loop.to, 0,
- GFC_ARRAY_UNKNOWN);
+ GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
}
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 (&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 (&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 && info->ref && info->ref->u.ar.type != AR_FULL)
+ 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 (&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. */
+ /* Point the data pointer at the 1st element in the section. */
gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
subref_array_target, expr);
&& !se->data_not_needed)
{
/* Set the offset. */
- tmp = gfc_conv_descriptor_offset (parm);
- gfc_add_modify (&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 (&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,
- const gfc_symbol *fsym, const char *proc_name)
+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 = tmp;
+ expr->ts.u.cl->backend_decl = tmp;
se->string_length = tmp;
}
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 || 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. */
-
if (gfc_option.warn_array_temp)
{
if (fsym)
gfc_warning ("Creating array temporary at %L", &expr->where);
}
- ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
+ 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, ptr,
- null_pointer_node);
+ 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.flag_check_array_temporaries)
+ if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
{
char * msg;
else
asprintf (&msg, "An array temporary was created");
- tmp = build_fold_indirect_ref (desc);
+ 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);
/* Copy the data back. */
if (fsym == NULL || fsym->attr.intent != INTENT_IN)
{
- tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_in_unpack, 2, desc, ptr);
gfc_add_expr_to_block (&block, tmp);
}
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 = fold_build2 (NE_EXPR, boolean_type_node,
fold_convert (TREE_TYPE (tmp), ptr), tmp);
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 ());
+ 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);
/* 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 = gfc_deallocate_with_status (var, NULL_TREE, true);
+ tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
tree nelems;
tree tmp;
idx = gfc_rank_cst[rank - 1];
- nelems = gfc_conv_descriptor_ubound (decl, idx);
- tmp = gfc_conv_descriptor_lbound (decl, idx);
+ 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);
+ 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 = fold_build2 (NE_EXPR, boolean_type_node,
null_cond, null_pointer_node);
}
+/* 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)))
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));
+ 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 = 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 = 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 = 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 = 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. */
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 (&fnblock, dcmp, tmp);
- tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
+ 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_conv_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)
+ 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);
+ tmp = gfc_init_default_dt (sym, NULL, false);
gfc_add_expr_to_block (&fnblock, tmp);
}
}
{
/* 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);
}
{
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 && !sym->attr.save)
+ 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++)
{
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;
OSDN Git Service
