/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
In fortran all the rhs values of an assignment must be evaluated before
any assignments take place. This can require a temporary array to store the
values. We also require a temporary when we are passing array expressions
- or vector subecripts as procedure parameters.
+ or vector subscripts as procedure parameters.
Array sections are passed without copying to a temporary. These use the
scalarizer to determine the shape of the section. The flag
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "tree-gimple.h"
+#include "gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
This function gets called through the following macros:
gfc_conv_descriptor_data_set
- gfc_conv_descriptor_data_set_tuples. */
+ gfc_conv_descriptor_data_set. */
void
-gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
- tree desc, tree value,
- bool tuples_p)
+gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
{
tree field, type, t;
gcc_assert (DATA_FIELD == 0);
t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
}
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
gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
- lower = tmpse.expr;
+ lower = fold_convert (gfc_array_index_type, tmpse.expr);
/* ...and the upper bound. */
gfc_init_se (&tmpse, NULL);
gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
- upper = tmpse.expr;
+ upper = fold_convert (gfc_array_index_type, tmpse.expr);
/* Set the upper bound of the loop to UPPER - LOWER. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
callee will allocate the array. If DEALLOC is true, also generate code to
free the array afterwards.
+ If INITIAL is not NULL, it is packed using internal_pack and the result used
+ as data instead of allocating a fresh, unitialized area of memory.
+
Initialization code is added to PRE and finalization code to POST.
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
static void
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
- gfc_ss_info * info, tree size, tree nelem,
- bool dynamic, bool dealloc)
+ gfc_ss_info * info, tree size, tree nelem,
+ tree initial, bool dynamic, bool dealloc)
{
tree tmp;
tree desc;
else
{
/* Allocate the temporary. */
- onstack = !dynamic && gfc_can_put_var_on_stack (size);
+ onstack = !dynamic && initial == NULL_TREE
+ && gfc_can_put_var_on_stack (size);
if (onstack)
{
tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
tmp);
tmp = gfc_create_var (tmp, "A");
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
else
{
- /* Allocate memory to hold the data. */
- tmp = gfc_call_malloc (pre, NULL, size);
- tmp = gfc_evaluate_now (tmp, pre);
+ /* Allocate memory to hold the data or call internal_pack. */
+ if (initial == NULL_TREE)
+ {
+ tmp = gfc_call_malloc (pre, NULL, size);
+ tmp = gfc_evaluate_now (tmp, pre);
+ }
+ else
+ {
+ tree packed;
+ tree source_data;
+ tree was_packed;
+ stmtblock_t do_copying;
+
+ tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
+ gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
+ tmp = TREE_TYPE (tmp); /* The descriptor itself. */
+ tmp = gfc_get_element_type (tmp);
+ gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
+ packed = gfc_create_var (build_pointer_type (tmp), "data");
+
+ tmp = build_call_expr (gfor_fndecl_in_pack, 1, initial);
+ tmp = fold_convert (TREE_TYPE (packed), tmp);
+ gfc_add_modify (pre, packed, tmp);
+
+ tmp = build_fold_indirect_ref (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 ());
+ gfc_add_expr_to_block (pre, tmp);
+
+ tmp = fold_convert (pvoid_type_node, packed);
+ }
+
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
}
/* The offset is zero because we create temporaries with a zero
lower bound. */
tmp = gfc_conv_descriptor_offset (desc);
- gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
+ gfc_add_modify (pre, tmp, gfc_index_zero_node);
if (dealloc && !onstack)
{
fields of info if known. Returns the size of the array, or NULL for a
callee allocated array.
- PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
+ PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
+ gfc_trans_allocate_array_storage.
*/
tree
gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
gfc_loopinfo * loop, gfc_ss_info * info,
- tree eltype, bool dynamic, bool dealloc,
- bool callee_alloc)
+ tree eltype, tree initial, bool dynamic,
+ bool dealloc, bool callee_alloc, locus * where)
{
tree type;
tree desc;
int dim;
gcc_assert (info->dimen > 0);
+
+ if (gfc_option.warn_array_temp && where)
+ gfc_warning ("Creating array temporary at %L", where);
+
/* Set the lower bound to zero. */
for (dim = 0; dim < info->dimen; dim++)
{
n = loop->order[dim];
- /* 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;
/* Fill in the array dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
/*
Fill in the bounds and stride. This is a packed array, so:
{
stride[n] = size
delta = ubound[n] + 1 - lbound[n];
- size = size * delta;
+ size = size * delta;
}
size = size * sizeof(element);
*/
or_expr = NULL_TREE;
+ /* If there is at least one null loop->to[n], it is a callee allocated
+ array. */
for (n = 0; n < info->dimen; n++)
- {
- if (loop->to[n] == NULL_TREE)
- {
+ if (loop->to[n] == NULL_TREE)
+ {
+ size = NULL_TREE;
+ break;
+ }
+
+ for (n = 0; n < info->dimen; n++)
+ {
+ if (size == NULL_TREE)
+ {
/* For a callee allocated array express the loop bounds in terms
of the descriptor fields. */
- tmp =
+ 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;
- }
-
+ loop->to[n] = tmp;
+ continue;
+ }
+
/* Store the stride and bound components in the descriptor. */
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (pre, tmp, size);
+ gfc_add_modify (pre, tmp, size);
tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
+ gfc_add_modify (pre, tmp, gfc_index_zero_node);
tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (pre, tmp, loop->to[n]);
+ gfc_add_modify (pre, tmp, 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;
se->expr = dest;
/* Copy across the dtype field. */
- gfc_add_modify_expr (&se->pre,
+ gfc_add_modify (&se->pre,
gfc_conv_descriptor_dtype (dest),
gfc_conv_descriptor_dtype (src));
dest_index = gfc_rank_cst[n];
src_index = gfc_rank_cst[1 - n];
- gfc_add_modify_expr (&se->pre,
+ gfc_add_modify (&se->pre,
gfc_conv_descriptor_stride (dest, dest_index),
gfc_conv_descriptor_stride (src, src_index));
- gfc_add_modify_expr (&se->pre,
+ gfc_add_modify (&se->pre,
gfc_conv_descriptor_lbound (dest, dest_index),
gfc_conv_descriptor_lbound (src, src_index));
- gfc_add_modify_expr (&se->pre,
+ gfc_add_modify (&se->pre,
gfc_conv_descriptor_ubound (dest, dest_index),
gfc_conv_descriptor_ubound (src, src_index));
else
dest_info->offset = gfc_index_zero_node;
- gfc_add_modify_expr (&se->pre,
+ gfc_add_modify (&se->pre,
gfc_conv_descriptor_offset (dest),
dest_info->offset);
/* Add EXTRA to the upper bound. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
- gfc_add_modify_expr (pblock, ubound, tmp);
+ gfc_add_modify (pblock, ubound, tmp);
/* Get the value of the current data pointer. */
arg0 = gfc_conv_descriptor_data_get (desc);
/* We should have already created the offset variable. We cannot
create it here because we may be in an inner scope. */
gcc_assert (*offsetvar != NULL_TREE);
- gfc_add_modify_expr (pblock, *offsetvar, *poffset);
+ gfc_add_modify (pblock, *offsetvar, *poffset);
*poffset = *offsetvar;
TREE_USED (*offsetvar) = 1;
}
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
- tree esize;
gfc_conv_expr (se, expr);
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
tmp = gfc_build_array_ref (tmp, offset, NULL);
- esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
- esize = fold_convert (gfc_charlen_type_node, esize);
-
if (expr->ts.type == BT_CHARACTER)
{
+ int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+ tree esize;
+
+ esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
+ esize = fold_convert (gfc_charlen_type_node, esize);
+ esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
+ build_int_cst (gfc_charlen_type_node,
+ gfc_character_kinds[i].bit_size / 8));
+
gfc_conv_string_parameter (se);
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
{
/* The temporary is an array of pointers. */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
- gfc_add_modify_expr (&se->pre, tmp, se->expr);
+ gfc_add_modify (&se->pre, tmp, se->expr);
}
else
{
/* The temporary is an array of string values. */
- tmp = gfc_build_addr_expr (pchar_type_node, tmp);
+ tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
/* We know the temporary and the value will be the same length,
so can use memcpy. */
- gfc_trans_string_copy (&se->pre, esize, tmp,
- se->string_length,
- se->expr);
+ 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)
{
- gfc_add_modify_expr (&se->pre, first_len_val,
+ gfc_add_modify (&se->pre, first_len_val,
se->string_length);
first_len = false;
}
tree cond = fold_build2 (NE_EXPR, boolean_type_node,
first_len_val, se->string_length);
gfc_trans_runtime_check
- (cond, &se->pre, &expr->where,
+ (true, false, cond, &se->pre, &expr->where,
"Different CHARACTER lengths (%ld/%ld) in array constructor",
fold_convert (long_integer_type_node, first_len_val),
fold_convert (long_integer_type_node, se->string_length));
{
/* TODO: Should the frontend already have done this conversion? */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
- gfc_add_modify_expr (&se->pre, tmp, se->expr);
+ gfc_add_modify (&se->pre, tmp, se->expr);
}
gfc_add_block_to_block (pblock, &se->pre);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
/* Make sure the constructed array has room for the new data. */
if (dynamic)
/* Increment the offset. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
*poffset, gfc_index_one_node);
- gfc_add_modify_expr (&body, *poffset, tmp);
+ gfc_add_modify (&body, *poffset, tmp);
/* Finish the loop. */
gfc_trans_scalarizing_loops (&loop, &body);
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);
+
+ /* For constant character array constructors we build
+ an array of pointers. */
if (p->expr->ts.type == BT_CHARACTER
&& POINTER_TYPE_P (type))
- {
- /* For constant character array constructors we build
- an array of pointers. */
- se.expr = gfc_build_addr_expr (pchar_type_node,
- se.expr);
- }
-
- list = tree_cons (NULL_TREE, se.expr, list);
+ se.expr = gfc_build_addr_expr
+ (gfc_get_pchar_type (p->expr->ts.kind),
+ se.expr);
+
+ list = tree_cons (build_int_cst (gfc_array_index_type,
+ idx++), se.expr, list);
c = p;
p = p->next;
}
tmp = gfc_conv_descriptor_data_get (desc);
tmp = build_fold_indirect_ref (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);
}
if (!INTEGER_CST_P (*poffset))
{
- gfc_add_modify_expr (&body, *offsetvar, *poffset);
+ gfc_add_modify (&body, *offsetvar, *poffset);
*poffset = *offsetvar;
}
}
- /* The frontend should already have done any expansions possible
+ /* The frontend should already have done any expansions
at compile-time. */
if (!c->iterator)
{
/* Make a temporary, store the current value in that
and return it, once the loop is done. */
tmp_loopvar = gfc_create_var (TREE_TYPE (loopvar), "loopvar");
- gfc_add_modify_expr (pblock, tmp_loopvar, loopvar);
+ gfc_add_modify (pblock, tmp_loopvar, loopvar);
/* Initialize the loop. */
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->start);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify_expr (pblock, loopvar, se.expr);
+ gfc_add_modify (pblock, loopvar, se.expr);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->end);
/* Increase loop variable by step. */
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
- gfc_add_modify_expr (&body, loopvar, tmp);
+ gfc_add_modify (&body, loopvar, tmp);
/* Finish the loop. */
tmp = gfc_finish_block (&body);
gfc_add_expr_to_block (pblock, tmp);
/* Restore the original value of the loop counter. */
- gfc_add_modify_expr (pblock, loopvar, tmp_loopvar);
+ gfc_add_modify (pblock, loopvar, tmp_loopvar);
}
}
mpz_clear (size);
mpz_init_set_ui (char_len, 1);
mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
- *len = gfc_conv_mpz_to_tree (char_len,
- gfc_default_character_kind);
+ *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
*len = convert (gfc_charlen_type_node, *len);
mpz_clear (char_len);
return;
/* Figure out the string length of a character array constructor.
+ If len is NULL, don't calculate the length; this happens for recursive calls
+ when a sub-array-constructor is an element but not at the first position,
+ so when we're not interested in the length.
Returns TRUE if all elements are character constants. */
bool
if (c == NULL)
{
- *len = build_int_cstu (gfc_charlen_type_node, 0);
+ if (len)
+ *len = build_int_cstu (gfc_charlen_type_node, 0);
return is_const;
}
- for (; c; c = c->next)
+ /* 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)
{
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
- if (!(*len && INTEGER_CST_P (*len)))
+ if (len && !(*len && INTEGER_CST_P (*len)))
*len = build_int_cstu (gfc_charlen_type_node,
c->expr->value.character.length);
break;
case EXPR_VARIABLE:
is_const = false;
- get_array_ctor_var_strlen (c->expr, len);
+ if (len)
+ get_array_ctor_var_strlen (c->expr, len);
break;
default:
is_const = false;
- get_array_ctor_all_strlen (block, c->expr, len);
+ if (len)
+ get_array_ctor_all_strlen (block, c->expr, len);
break;
}
+
+ /* After the first iteration, we don't want the length modified. */
+ len = NULL;
}
return is_const;
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, c->expr);
- if (c->expr->ts.type == BT_CHARACTER
- && POINTER_TYPE_P (type))
- se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
- list = tree_cons (NULL_TREE, se.expr, list);
+ if (c->expr->ts.type == BT_CHARACTER && POINTER_TYPE_P (type))
+ se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
+ se.expr);
+ list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
+ se.expr, list);
c = c->next;
nelem++;
}
info = &ss->data.info;
info->descriptor = tmp;
- info->data = build_fold_addr_expr (tmp);
- info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
- loop->from[0]);
+ info->data = gfc_build_addr_expr (NULL_TREE, tmp);
+ info->offset = gfc_index_zero_node;
for (i = 0; i < info->dimen; i++)
{
/* Helper routine of gfc_trans_array_constructor to determine if the
bounds of the loop specified by LOOP are constant and simple enough
to use with gfc_trans_constant_array_constructor. Returns the
- the iteration count of the loop if suitable, and NULL_TREE otherwise. */
+ iteration count of the loop if suitable, and NULL_TREE otherwise. */
static tree
constant_array_constructor_loop_size (gfc_loopinfo * loop)
simplest method. */
static void
-gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
+gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
{
gfc_constructor *c;
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);
- 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;
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);
-
- 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;
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;
}
but before the actual scalarizing loops. */
static void
-gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
+gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
+ locus * where)
{
gfc_se se;
int n;
- /* TODO: This can generate bad code if there are ordering dependencies.
- eg. a callee allocated function and an unknown size constructor. */
+ /* TODO: This can generate bad code if there are ordering dependencies,
+ e.g., a callee allocated function and an unknown size constructor. */
gcc_assert (ss != NULL);
for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
/* Scalar expression. Evaluate this now. This includes elemental
dimension indices, but not array section bounds. */
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, ss->expr);
- gfc_add_block_to_block (&loop->pre, &se.pre);
+ gfc_conv_expr (&se, ss->expr);
+ gfc_add_block_to_block (&loop->pre, &se.pre);
- if (ss->expr->ts.type != BT_CHARACTER)
- {
- /* Move the evaluation of scalar expressions outside the
- scalarization loop. */
- if (subscript)
- se.expr = convert(gfc_array_index_type, se.expr);
- se.expr = gfc_evaluate_now (se.expr, &loop->pre);
- gfc_add_block_to_block (&loop->pre, &se.post);
- }
- else
- gfc_add_block_to_block (&loop->post, &se.post);
+ if (ss->expr->ts.type != BT_CHARACTER)
+ {
+ /* Move the evaluation of scalar expressions outside the
+ scalarization loop, except for WHERE assignments. */
+ if (subscript)
+ se.expr = convert(gfc_array_index_type, se.expr);
+ if (!ss->where)
+ se.expr = gfc_evaluate_now (se.expr, &loop->pre);
+ gfc_add_block_to_block (&loop->pre, &se.post);
+ }
+ else
+ gfc_add_block_to_block (&loop->post, &se.post);
ss->data.scalar.expr = se.expr;
ss->string_length = se.string_length;
/* Add the expressions for scalar and vector subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
if (ss->data.info.subscript[n])
- gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
+ gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true,
+ where);
gfc_set_vector_loop_bounds (loop, &ss->data.info);
break;
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_add_block_to_block (&loop->post, &se.post);
}
- gfc_trans_array_constructor (loop, ss);
+ gfc_trans_array_constructor (loop, ss, where);
break;
case GFC_SS_TEMP:
else
{
/* Descriptorless arrays. */
- return build_fold_addr_expr (descriptor);
+ return gfc_build_addr_expr (NULL_TREE, descriptor);
}
}
else
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);
else
asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
gfc_msg_fault, n+1);
- gfc_trans_runtime_check (fault, &se->pre, where, msg,
+ 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);
else
asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
gfc_msg_fault, n+1);
- gfc_trans_runtime_check (fault, &se->pre, where, msg,
+ 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);
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;
asprintf (&msg, "%s for array '%s', "
"lower bound of dimension %d exceeded (%%ld < %%ld)",
gfc_msg_fault, sym->name, n+1);
- gfc_trans_runtime_check (cond, &se->pre, where, msg,
+ gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
fold_convert (long_integer_type_node,
indexse.expr),
fold_convert (long_integer_type_node, tmp));
asprintf (&msg, "%s for array '%s', "
"upper bound of dimension %d exceeded (%%ld > %%ld)",
gfc_msg_fault, sym->name, n+1);
- gfc_trans_runtime_check (cond, &se->pre, where, msg,
+ gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
fold_convert (long_integer_type_node,
indexse.expr),
fold_convert (long_integer_type_node, tmp));
loopbody = gfc_finish_block (pbody);
/* Initialize the loopvar. */
- gfc_add_modify_expr (&loop->code[n], 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);
/* Increment the loopvar. */
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
loop->loopvar[n], gfc_index_one_node);
- gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
+ gfc_add_modify (&block, loop->loopvar[n], tmp);
/* Build the loop. */
tmp = gfc_finish_block (&block);
}
/* The rest is just runtime bound checking. */
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
stmtblock_t block;
tree lbound, ubound;
asprintf (&msg, "Zero stride is not allowed, for dimension %d "
"of array '%s'", info->dim[n]+1,
ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg);
+ gfc_trans_runtime_check (true, false, tmp, &inner,
+ &ss->expr->where, msg);
gfc_free (msg);
desc = ss->data.info.descriptor;
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 (tmp, &inner, &ss->expr->where, msg,
+ 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,
asprintf (&msg, "%s, upper 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 (tmp, &inner, &ss->expr->where, msg,
+ 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_free (msg);
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 (tmp, &inner, &ss->expr->where, msg,
+ 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,
asprintf (&msg, "%s, upper 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 (tmp, &inner, &ss->expr->where, msg,
+ 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_free (msg);
asprintf (&msg, "%s, size mismatch for dimension %d "
"of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
info->dim[n]+1, ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp3, &inner, &ss->expr->where, msg,
+ gfc_trans_runtime_check (true, false, tmp3, &inner,
+ &ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp),
fold_convert (long_integer_type_node, size[n]));
gfc_free (msg);
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;
moved outside the loop. */
void
-gfc_conv_loop_setup (gfc_loopinfo * loop)
+gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
{
int n;
int dim;
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;
}
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:
/* Add all the scalar code that can be taken out of the loops.
This may include calculating the loop bounds, so do it before
allocating the temporary. */
- gfc_add_loop_ss_code (loop, loop->ss, false);
+ gfc_add_loop_ss_code (loop, loop->ss, false, where);
/* If we want a temporary then create it. */
if (loop->temp_ss != NULL)
/* Make absolutely sure that this is a complete type. */
if (loop->temp_ss->string_length)
loop->temp_ss->data.temp.type
- = gfc_get_character_type_len (gfc_default_character_kind,
- loop->temp_ss->string_length);
+ = gfc_get_character_type_len_for_eltype
+ (TREE_TYPE (loop->temp_ss->data.temp.type),
+ loop->temp_ss->string_length);
tmp = loop->temp_ss->data.temp.type;
len = loop->temp_ss->string_length;
loop->temp_ss->type = GFC_SS_SECTION;
loop->temp_ss->data.info.dimen = n;
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop,
- &loop->temp_ss->data.info, tmp, false, true,
- false);
+ &loop->temp_ss->data.info, tmp, NULL_TREE,
+ false, true, false, where);
}
for (n = 0; n < loop->temp_dim; n++)
/* Calculate the translation from loop variables to array indices. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
- if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
+ if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT
+ && ss->type != GFC_SS_CONSTRUCTOR)
+
continue;
info = &ss->data.info;
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
or_expr = NULL_TREE;
}
}
tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
- gfc_add_modify_expr (pblock, tmp, se.expr);
+ gfc_add_modify (pblock, tmp, se.expr);
/* Work out the offset for this component. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
gfc_add_block_to_block (pblock, &se.pre);
tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
- gfc_add_modify_expr (pblock, tmp, se.expr);
+ gfc_add_modify (pblock, tmp, se.expr);
/* Store the stride. */
tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
- gfc_add_modify_expr (pblock, tmp, stride);
+ gfc_add_modify (pblock, tmp, stride);
/* Calculate the size of this dimension. */
size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
var = gfc_create_var (TREE_TYPE (size), "size");
gfc_start_block (&thenblock);
- gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
+ gfc_add_modify (&thenblock, var, gfc_index_zero_node);
thencase = gfc_finish_block (&thenblock);
gfc_start_block (&elseblock);
- gfc_add_modify_expr (&elseblock, var, size);
+ gfc_add_modify (&elseblock, var, size);
elsecase = gfc_finish_block (&elseblock);
tmp = gfc_evaluate_now (or_expr, pblock);
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_expr (&se->pre, tmp, offset);
+ gfc_add_modify (&se->pre, tmp, offset);
if (expr->ts.type == BT_DERIVED
&& expr->ts.derived->attr.alloc_comp)
/*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. */
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_error_now ("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);
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;
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify_expr (pblock, lbound, se.expr);
+ gfc_add_modify (pblock, lbound, se.expr);
}
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify_expr (pblock, ubound, se.expr);
+ gfc_add_modify (pblock, ubound, se.expr);
}
/* The offset of this dimension. offset = offset - lbound * stride. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
if (stride)
- gfc_add_modify_expr (pblock, stride, tmp);
+ gfc_add_modify (pblock, stride, tmp);
else
stride = gfc_evaluate_now (tmp, pblock);
stride, gfc_index_zero_node);
tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
stride, gfc_index_zero_node);
- gfc_add_modify_expr (pblock, stride, tmp);
+ gfc_add_modify (pblock, stride, tmp);
}
size = stride;
if (sym->ts.type == BT_CHARACTER
&& onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
- gfc_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.cl, NULL, &block);
gfc_trans_vla_type_sizes (sym, &block);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.cl, NULL, &block);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
if (sym->attr.cray_pointee)
{
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
gfc_add_expr_to_block (&block, fnbody);
return gfc_finish_block (&block);
}
/* Allocate memory to hold the data. */
tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
- gfc_add_modify_expr (&block, decl, tmp);
+ gfc_add_modify (&block, decl, tmp);
/* Set offset of the array. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
/* Automatic arrays should not have initializers. */
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.cl, NULL, &block);
/* Evaluate the bounds of the array. */
gfc_trans_array_bounds (type, sym, &offset, &block);
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
/* Set the pointer itself if we aren't using the parameter directly. */
if (TREE_CODE (parm) != PARM_DECL)
{
tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
- gfc_add_modify_expr (&block, parm, tmp);
+ gfc_add_modify (&block, parm, tmp);
}
stmt = gfc_finish_block (&block);
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_conv_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.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));
TREE_USED (partial) = 1;
tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node);
- gfc_add_modify_expr (&block, partial, tmp);
+ gfc_add_modify (&block, partial, tmp);
}
else
{
tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
gfc_index_one_node, stride);
stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
/* Allow the user to disable array repacking. */
stmt_unpacked = NULL_TREE;
stmt_unpacked = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
stride = gfc_index_one_node;
+
+ if (gfc_option.warn_array_temp)
+ gfc_warning ("Creating array temporary at %L", &loc);
}
/* This is for the case where the array data is used directly without
}
else
tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
- gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
+ gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
offset = gfc_index_zero_node;
size = gfc_index_one_node;
gfc_conv_expr_type (&se, sym->as->lower[n],
gfc_array_index_type);
gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify_expr (&block, lbound, se.expr);
+ gfc_add_modify (&block, lbound, se.expr);
}
ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
gfc_conv_expr_type (&se, sym->as->upper[n],
gfc_array_index_type);
gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify_expr (&block, ubound, se.expr);
+ gfc_add_modify (&block, ubound, se.expr);
}
/* Check the sizes match. */
tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
asprintf (&msg, "%s for dimension %d of array '%s'",
gfc_msg_bounds, n+1, sym->name);
- gfc_trans_runtime_check (tmp, &block, &loc, msg);
+ gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
gfc_free (msg);
}
}
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
dubound, dlbound);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
- gfc_add_modify_expr (&block, ubound, tmp);
+ gfc_add_modify (&block, ubound, tmp);
}
/* The offset of this dimension. offset = offset - lbound * stride. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
stmt_unpacked, stmt_packed);
else
tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
}
}
else
ubound, tmp);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
}
}
}
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
gfc_trans_vla_type_sizes (sym, &block);
tmp = gfc_build_array_ref (tmp, offset, NULL);
/* Offset the data pointer for pointer assignments from arrays with
- subreferences; eg. my_integer => my_type(:)%integer_component. */
+ subreferences; e.g. my_integer => my_type(:)%integer_component. */
if (subref)
{
/* Go past the array reference. */
arg = expr->value.function.actual;
gfc_init_interface_mapping (&mapping);
- /* Set se = NULL in the calls to the interface mapping, to supress any
+ /* 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 (se->direct_byref)
{
/* Copy the descriptor for pointer assignments. */
- gfc_add_modify_expr (&se->pre, se->expr, desc);
+ gfc_add_modify (&se->pre, se->expr, desc);
/* Add any offsets from subreferences. */
gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
{
/* 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;
}
break;
}
-
gfc_init_loopinfo (&loop);
/* Associate the SS with the loop. */
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);
+ gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, & expr->where);
if (need_tmp)
{
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (parm);
- gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
+ gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
/* Set offset for assignments to pointer only to zero if it is not
the full array. */
from = gfc_index_one_node;
}
tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
- gfc_add_modify_expr (&loop.pre, tmp, from);
+ gfc_add_modify (&loop.pre, tmp, from);
/* Set the new upper bound. */
tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
- gfc_add_modify_expr (&loop.pre, tmp, to);
+ gfc_add_modify (&loop.pre, tmp, to);
/* Multiply the stride by the section stride to get the
total stride. */
/* Store the new stride. */
tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
- gfc_add_modify_expr (&loop.pre, tmp, stride);
+ gfc_add_modify (&loop.pre, tmp, stride);
dim++;
}
{
/* Set the offset. */
tmp = gfc_conv_descriptor_offset (parm);
- gfc_add_modify_expr (&loop.pre, tmp, base);
+ gfc_add_modify (&loop.pre, tmp, base);
}
else
{
/* Only the callee knows what the correct offset it, so just set
it to zero here. */
tmp = gfc_conv_descriptor_offset (parm);
- gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
+ gfc_add_modify (&loop.pre, tmp, 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;
}
/* TODO: Optimize passing g77 arrays. */
void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
+ const gfc_symbol *fsym, const char *proc_name)
{
tree ptr;
tree desc;
stmtblock_t block;
full_array_var = (expr->expr_type == EXPR_VARIABLE
- && expr->ref->u.ar.type == AR_FULL);
+ && expr->ref->type == REF_ARRAY
+ && 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);
+
if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
{
get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
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);
return;
}
if (sym->attr.allocatable)
{
/* Result of the enclosing function. */
gfc_conv_expr_descriptor (se, expr, ss);
- se->expr = build_fold_addr_expr (se->expr);
+ 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))))
gfc_conv_expr_descriptor (se, expr, ss);
}
-
/* Deallocate the allocatable components of structures that are
not variable. */
if (expr->ts.type == BT_DERIVED
{
desc = se->expr;
/* Repack the array. */
+
+ if (gfc_option.warn_array_temp)
+ {
+ if (fsym)
+ gfc_warning ("Creating array temporary at %L for argument '%s'",
+ &expr->where, fsym->name);
+ else
+ gfc_warning ("Creating array temporary at %L", &expr->where);
+ }
+
ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ {
+ tmp = gfc_conv_expr_present (sym);
+ ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp,
+ fold_convert (TREE_TYPE (se->expr), ptr),
+ fold_convert (TREE_TYPE (se->expr), null_pointer_node));
+ }
+
ptr = gfc_evaluate_now (ptr, &se->pre);
+
se->expr = ptr;
+ if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
+ {
+ char * msg;
+
+ if (fsym && proc_name)
+ asprintf (&msg, "An array temporary was created for argument "
+ "'%s' of procedure '%s'", fsym->name, proc_name);
+ else
+ asprintf (&msg, "An array temporary was created");
+
+ tmp = build_fold_indirect_ref (desc);
+ tmp = gfc_conv_array_data (tmp);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node,
+ fold_convert (TREE_TYPE (tmp), ptr), tmp);
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ gfc_conv_expr_present (sym), tmp);
+
+ gfc_trans_runtime_check (false, true, tmp, &se->pre,
+ &expr->where, msg);
+ gfc_free (msg);
+ }
+
gfc_start_block (&block);
/* Copy the data back. */
- tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
- gfc_add_expr_to_block (&block, tmp);
+ if (fsym == NULL || fsym->attr.intent != INTENT_IN)
+ {
+ tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
/* Free the temporary. */
tmp = gfc_call_free (convert (pvoid_type_node, ptr));
tmp = gfc_conv_array_data (tmp);
tmp = fold_build2 (NE_EXPR, boolean_type_node,
fold_convert (TREE_TYPE (tmp), ptr), tmp);
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ gfc_conv_expr_present (sym), tmp);
+
tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
/* 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. */
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 (gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
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);
gfc_add_expr_to_block (&fnblock, tmp);
}
- if (c->allocatable)
+ if (c->attr.allocatable)
{
comp = fold_build3 (COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
break;
case NULLIFY_ALLOC_COMP:
- if (c->pointer)
+ if (c->attr.pointer)
continue;
- else if (c->allocatable)
+ else if (c->attr.allocatable)
{
comp = fold_build3 (COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
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);
gfc_add_expr_to_block (&fnblock, tmp);
{
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
- gfc_add_modify_expr (&fnblock, dcmp, tmp);
+ gfc_add_modify (&fnblock, dcmp, tmp);
tmp = structure_alloc_comps (c->ts.derived, comp, dcmp,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
- gfc_conv_string_length (sym->ts.cl, &fnblock);
+ gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
gfc_trans_vla_type_sizes (sym, &fnblock);
}
gfc_add_expr_to_block (&fnblock, tmp);
}
- if (sym->attr.allocatable && !sym->attr.save)
+ if (sym->attr.allocatable && !sym->attr.save && !sym->attr.result)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
gfc_add_expr_to_block (&fnblock, tmp);
if (head == ss)
{
/* First operand is scalar. We build the chain in reverse order, so
- add the scarar SS after the second operand. */
+ add the scalar SS after the second operand. */
head = head2;
while (head && head->next != ss)
head = head->next;
OSDN Git Service
