/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ 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>
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-array.c-- Various array related code, including scalarization,
allocation, initialization and other support routines. */
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"
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
t = fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), t);
return t;
This function gets called through the following macros:
gfc_conv_descriptor_data_set
- gfc_conv_descriptor_data_set_tuples. */
+ gfc_conv_descriptor_data_set. */
void
-gfc_conv_descriptor_data_set_internal (stmtblock_t *block,
- tree desc, tree value,
- bool tuples_p)
+gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
{
tree field, type, t;
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value), tuples_p);
+ t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ gfc_add_modify (block, t, fold_convert (TREE_TYPE (field), value));
}
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
- t = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- return build_fold_addr_expr (t);
+ t = fold_build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ return gfc_build_addr_expr (NULL_TREE, t);
}
tree
field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
}
tree
field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
+ return fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
}
static tree
&& TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
- tmp = gfc_build_array_ref (tmp, dim);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+ tmp = gfc_build_array_ref (tmp, dim, NULL);
return tmp;
}
field = gfc_advance_chain (field, STRIDE_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
return tmp;
}
field = gfc_advance_chain (field, LBOUND_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
return tmp;
}
field = gfc_advance_chain (field, UBOUND_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
return tmp;
}
/* Set a NULL data pointer. */
tmp = build_constructor_single (type, field, null_pointer_node);
TREE_CONSTANT (tmp) = 1;
- TREE_INVARIANT (tmp) = 1;
/* All other fields are ignored. */
return tmp;
gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
- lower = tmpse.expr;
+ lower = fold_convert (gfc_array_index_type, tmpse.expr);
/* ...and the upper bound. */
gfc_init_se (&tmpse, NULL);
gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
- upper = tmpse.expr;
+ upper = fold_convert (gfc_array_index_type, tmpse.expr);
/* Set the upper bound of the loop to UPPER - LOWER. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
callee will allocate the array. If DEALLOC is true, also generate code to
free the array afterwards.
+ If INITIAL is not NULL, it is packed using internal_pack and the result used
+ as data instead of allocating a fresh, unitialized area of memory.
+
Initialization code is added to PRE and finalization code to POST.
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
static void
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
- gfc_ss_info * info, tree size, tree nelem,
- bool dynamic, bool dealloc)
+ gfc_ss_info * info, tree size, tree nelem,
+ tree initial, bool dynamic, bool dealloc)
{
tree tmp;
tree desc;
else
{
/* Allocate the temporary. */
- onstack = !dynamic && gfc_can_put_var_on_stack (size);
+ onstack = !dynamic && initial == NULL_TREE
+ && gfc_can_put_var_on_stack (size);
if (onstack)
{
tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
tmp);
tmp = gfc_create_var (tmp, "A");
- tmp = build_fold_addr_expr (tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
else
{
- /* Allocate memory to hold the data. */
- if (gfc_index_integer_kind == 4)
- tmp = gfor_fndecl_internal_malloc;
- else if (gfc_index_integer_kind == 8)
- tmp = gfor_fndecl_internal_malloc64;
+ /* 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
- gcc_unreachable ();
- tmp = build_call_expr (tmp, 1, size);
- tmp = gfc_evaluate_now (tmp, pre);
+ {
+ 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)
{
/* Free the temporary. */
tmp = gfc_conv_descriptor_data_get (desc);
- tmp = fold_convert (pvoid_type_node, tmp);
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
gfc_add_expr_to_block (post, tmp);
}
}
fields of info if known. Returns the size of the array, or NULL for a
callee allocated array.
- PRE, POST, DYNAMIC and DEALLOC are as for gfc_trans_allocate_array_storage.
+ PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
+ gfc_trans_allocate_array_storage.
*/
tree
gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
gfc_loopinfo * loop, gfc_ss_info * info,
- tree eltype, bool dynamic, bool dealloc,
- bool callee_alloc)
+ tree eltype, tree initial, bool dynamic,
+ bool dealloc, bool callee_alloc, locus * where)
{
tree type;
tree desc;
int dim;
gcc_assert (info->dimen > 0);
+
+ if (gfc_option.warn_array_temp && where)
+ gfc_warning ("Creating array temporary at %L", where);
+
/* Set the lower bound to zero. */
for (dim = 0; dim < info->dimen; dim++)
{
n = loop->order[dim];
- if (n < loop->temp_dim)
- gcc_assert (integer_zerop (loop->from[n]));
- else
- {
- /* Callee allocated arrays may not have a known bound yet. */
- if (loop->to[n])
- loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- loop->to[n], loop->from[n]);
- loop->from[n] = gfc_index_zero_node;
- }
+ /* Callee allocated arrays may not have a known bound yet. */
+ if (loop->to[n])
+ loop->to[n] = gfc_evaluate_now (fold_build2 (MINUS_EXPR,
+ gfc_array_index_type,
+ loop->to[n], loop->from[n]), pre);
+ loop->from[n] = gfc_index_zero_node;
info->delta[dim] = gfc_index_zero_node;
info->start[dim] = gfc_index_zero_node;
/* Initialize the descriptor. */
type =
- gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
+ gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
+ GFC_ARRAY_UNKNOWN);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
/* Fill in the array dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
/*
Fill in the bounds and stride. This is a packed array, so:
{
stride[n] = size
delta = ubound[n] + 1 - lbound[n];
- size = size * delta;
+ size = size * delta;
}
size = size * sizeof(element);
*/
or_expr = NULL_TREE;
+ /* If there is at least one null loop->to[n], it is a callee allocated
+ array. */
for (n = 0; n < info->dimen; n++)
- {
- if (loop->to[n] == NULL_TREE)
- {
+ if (loop->to[n] == NULL_TREE)
+ {
+ size = NULL_TREE;
+ break;
+ }
+
+ for (n = 0; n < info->dimen; n++)
+ {
+ if (size == NULL_TREE)
+ {
/* For a callee allocated array express the loop bounds in terms
of the descriptor fields. */
- tmp = build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
- gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
- loop->to[n] = tmp;
- size = NULL_TREE;
- continue;
- }
-
+ tmp =
+ fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
+ gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
+ loop->to[n] = tmp;
+ continue;
+ }
+
/* Store the stride and bound components in the descriptor. */
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (pre, tmp, size);
+ gfc_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);
nelem = size;
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type))));
}
else
{
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));
if (!loop->to[n])
{
gcc_assert (integer_zerop (loop->from[n]));
- loop->to[n] = build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound (dest, dest_index),
- gfc_conv_descriptor_lbound (dest, dest_index));
+ loop->to[n] =
+ fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound (dest, dest_index),
+ gfc_conv_descriptor_lbound (dest, dest_index));
}
}
dest_info->data = gfc_conv_descriptor_data_get (src);
gfc_conv_descriptor_data_set (&se->pre, dest, dest_info->data);
- /* Copy the offset. This is not changed by transposition: the top-left
- element is still at the same offset as before. */
- dest_info->offset = gfc_conv_descriptor_offset (src);
- gfc_add_modify_expr (&se->pre,
+ /* Copy the offset. This is not changed by transposition; the top-left
+ element is still at the same offset as before, except where the loop
+ starts at zero. */
+ if (!integer_zerop (loop->from[0]))
+ dest_info->offset = gfc_conv_descriptor_offset (src);
+ else
+ dest_info->offset = gfc_index_zero_node;
+
+ gfc_add_modify (&se->pre,
gfc_conv_descriptor_offset (dest),
dest_info->offset);
-
+
if (dest_info->dimen > loop->temp_dim)
loop->temp_dim = dest_info->dimen;
}
ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
/* Add EXTRA to the upper bound. */
- tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
- gfc_add_modify_expr (pblock, ubound, tmp);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
+ gfc_add_modify (pblock, ubound, tmp);
/* Get the value of the current data pointer. */
arg0 = gfc_conv_descriptor_data_get (desc);
/* Calculate the new array size. */
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
- tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
- arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
-
- /* Pick the appropriate realloc function. */
- if (gfc_index_integer_kind == 4)
- tmp = gfor_fndecl_internal_realloc;
- else if (gfc_index_integer_kind == 8)
- tmp = gfor_fndecl_internal_realloc64;
- else
- gcc_unreachable ();
-
- /* Set the new data pointer. */
- tmp = build_call_expr (tmp, 2, arg0, arg1);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ ubound, gfc_index_one_node);
+ arg1 = fold_build2 (MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, tmp),
+ fold_convert (size_type_node, size));
+
+ /* Call the realloc() function. */
+ tmp = gfc_call_realloc (pblock, arg0, arg1);
gfc_conv_descriptor_data_set (pblock, desc, tmp);
}
/* We should have already created the offset variable. We cannot
create it here because we may be in an inner scope. */
gcc_assert (*offsetvar != NULL_TREE);
- gfc_add_modify_expr (pblock, *offsetvar, *poffset);
+ gfc_add_modify (pblock, *offsetvar, *poffset);
*poffset = *offsetvar;
TREE_USED (*offsetvar) = 1;
}
-/* Assign an element of an array constructor. */
+/* Variables needed for bounds-checking. */
+static bool first_len;
+static tree first_len_val;
+static bool typespec_chararray_ctor;
static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
/* Store the value. */
tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (desc));
- tmp = gfc_build_array_ref (tmp, offset);
+ tmp = gfc_build_array_ref (tmp, offset, NULL);
+
if (expr->ts.type == BT_CHARACTER)
{
+ int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+ tree esize;
+
+ esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
+ esize = fold_convert (gfc_charlen_type_node, esize);
+ esize = fold_build2 (TRUNC_DIV_EXPR, gfc_charlen_type_node, esize,
+ build_int_cst (gfc_charlen_type_node,
+ gfc_character_kinds[i].bit_size / 8));
+
gfc_conv_string_parameter (se);
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
{
/* The temporary is an array of pointers. */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
- gfc_add_modify_expr (&se->pre, tmp, se->expr);
+ gfc_add_modify (&se->pre, tmp, se->expr);
}
else
{
/* The temporary is an array of string values. */
- tmp = gfc_build_addr_expr (pchar_type_node, tmp);
+ tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
/* We know the temporary and the value will be the same length,
so can use memcpy. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
- tmp, se->expr, se->string_length);
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
+ se->string_length, se->expr, expr->ts.kind);
+ }
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
+ {
+ if (first_len)
+ {
+ gfc_add_modify (&se->pre, first_len_val,
+ se->string_length);
+ first_len = false;
+ }
+ else
+ {
+ /* Verify that all constructor elements are of the same
+ length. */
+ tree cond = fold_build2 (NE_EXPR, boolean_type_node,
+ first_len_val, se->string_length);
+ gfc_trans_runtime_check
+ (true, false, cond, &se->pre, &expr->where,
+ "Different CHARACTER lengths (%ld/%ld) in array constructor",
+ fold_convert (long_integer_type_node, first_len_val),
+ fold_convert (long_integer_type_node, se->string_length));
+ }
}
}
else
{
/* TODO: Should the frontend already have done this conversion? */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
- gfc_add_modify_expr (&se->pre, tmp, se->expr);
+ gfc_add_modify (&se->pre, tmp, se->expr);
}
gfc_add_block_to_block (pblock, &se->pre);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
/* Make sure the constructed array has room for the new data. */
if (dynamic)
gcc_assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
- tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
- gfc_add_modify_expr (&body, *poffset, tmp);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ *poffset, gfc_index_one_node);
+ gfc_add_modify (&body, *poffset, tmp);
/* Finish the loop. */
gfc_trans_scalarizing_loops (&loop, &body);
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;
}
init = build_constructor_from_list (tmptype, nreverse (list));
TREE_CONSTANT (init) = 1;
- TREE_INVARIANT (init) = 1;
TREE_STATIC (init) = 1;
/* Create a static variable to hold the data. */
tmp = gfc_create_var (tmptype, "data");
TREE_STATIC (tmp) = 1;
TREE_CONSTANT (tmp) = 1;
- TREE_INVARIANT (tmp) = 1;
TREE_READONLY (tmp) = 1;
DECL_INITIAL (tmp) = init;
init = tmp;
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
tmp = build_fold_indirect_ref (tmp);
- tmp = gfc_build_array_ref (tmp, *poffset);
- tmp = build_fold_addr_expr (tmp);
- init = build_fold_addr_expr (init);
+ tmp = gfc_build_array_ref (tmp, *poffset, NULL);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ init = gfc_build_addr_expr (NULL_TREE, init);
size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
bound = build_int_cst (NULL_TREE, n * size);
gfc_add_expr_to_block (&body, tmp);
*poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- *poffset, build_int_cst (NULL_TREE, n));
+ *poffset,
+ build_int_cst (gfc_array_index_type, n));
}
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)
{
loopbody = gfc_finish_block (&body);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, c->iterator->var);
- gfc_add_block_to_block (pblock, &se.pre);
- loopvar = se.expr;
+ 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_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);
tmp = fold_build2 (GT_EXPR, boolean_type_node, step,
build_int_cst (TREE_TYPE (step), 0));
cond = fold_build3 (COND_EXPR, boolean_type_node, tmp,
- build2 (GT_EXPR, boolean_type_node,
- loopvar, end),
- build2 (LT_EXPR, boolean_type_node,
- loopvar, end));
+ fold_build2 (GT_EXPR, boolean_type_node,
+ loopvar, end),
+ fold_build2 (LT_EXPR, boolean_type_node,
+ loopvar, end));
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 (&body, loopbody);
/* Increase loop variable by step. */
- tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
- gfc_add_modify_expr (&body, loopvar, tmp);
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
+ 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);
case REF_SUBSTRING:
if (ref->u.ss.start->expr_type != EXPR_CONSTANT
- || ref->u.ss.start->expr_type != EXPR_CONSTANT)
+ || ref->u.ss.end->expr_type != EXPR_CONSTANT)
break;
mpz_init_set_ui (char_len, 1);
mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
- *len = gfc_conv_mpz_to_tree (char_len,
- gfc_default_character_kind);
+ *len = gfc_conv_mpz_to_tree (char_len, gfc_default_integer_kind);
*len = convert (gfc_charlen_type_node, *len);
mpz_clear (char_len);
return;
}
+/* A catch-all to obtain the string length for anything that is not a
+ constant, array or variable. */
+static void
+get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
+{
+ gfc_se se;
+ gfc_ss *ss;
+
+ /* Don't bother if we already know the length is a constant. */
+ 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)
+ {
+ /* This is easy. */
+ gfc_conv_const_charlen (e->ts.cl);
+ *len = e->ts.cl->backend_decl;
+ }
+ else
+ {
+ /* Otherwise, be brutal even if inefficient. */
+ ss = gfc_walk_expr (e);
+ gfc_init_se (&se, NULL);
+
+ /* No function call, in case of side effects. */
+ se.no_function_call = 1;
+ if (ss == gfc_ss_terminator)
+ gfc_conv_expr (&se, e);
+ else
+ gfc_conv_expr_descriptor (&se, e, ss);
+
+ /* Fix the value. */
+ *len = gfc_evaluate_now (se.string_length, &se.pre);
+
+ gfc_add_block_to_block (block, &se.pre);
+ gfc_add_block_to_block (block, &se.post);
+
+ e->ts.cl->backend_decl = *len;
+ }
+}
+
+
/* Figure out the string length of a character array constructor.
+ If len is NULL, don't calculate the length; this happens for recursive calls
+ when a sub-array-constructor is an element but not at the first position,
+ so when we're not interested in the length.
Returns TRUE if all elements are character constants. */
bool
-get_array_ctor_strlen (gfc_constructor * c, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
{
bool is_const;
is_const = TRUE;
- for (; c; c = c->next)
+
+ if (c == NULL)
+ {
+ if (len)
+ *len = build_int_cstu (gfc_charlen_type_node, 0);
+ return is_const;
+ }
+
+ /* Loop over all constructor elements to find out is_const, but in len we
+ want to store the length of the first, not the last, element. We can
+ of course exit the loop as soon as is_const is found to be false. */
+ for (; c && 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_ARRAY:
- if (!get_array_ctor_strlen (c->expr->value.constructor, len))
+ if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
is_const = false;
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;
-
- /* Hope that whatever we have possesses a constant character
- length! */
- if (!(*len && INTEGER_CST_P (*len)) && c->expr->ts.cl)
- {
- gfc_conv_const_charlen (c->expr->ts.cl);
- *len = c->expr->ts.cl->backend_decl;
- }
- /* TODO: For now we just ignore anything we don't know how to
- handle, and hope we can figure it out a different way. */
+ 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++;
}
init = build_constructor_from_list (tmptype, nreverse (list));
TREE_CONSTANT (init) = 1;
- TREE_INVARIANT (init) = 1;
TREE_STATIC (init) = 1;
tmp = gfc_create_var (tmptype, "A");
TREE_STATIC (tmp) = 1;
TREE_CONSTANT (tmp) = 1;
- TREE_INVARIANT (tmp) = 1;
TREE_READONLY (tmp) = 1;
DECL_INITIAL (tmp) = init;
info = &ss->data.info;
info->descriptor = tmp;
- info->data = build_fold_addr_expr (tmp);
- info->offset = fold_build1 (NEGATE_EXPR, gfc_array_index_type,
- loop->from[0]);
+ info->data = gfc_build_addr_expr (NULL_TREE, tmp);
+ info->offset = gfc_index_zero_node;
for (i = 0; i < info->dimen; i++)
{
/* Helper routine of gfc_trans_array_constructor to determine if the
bounds of the loop specified by LOOP are constant and simple enough
to use with gfc_trans_constant_array_constructor. Returns the
- the iteration count of the loop if suitable, and NULL_TREE otherwise. */
+ iteration count of the loop if suitable, and NULL_TREE otherwise. */
static tree
constant_array_constructor_loop_size (gfc_loopinfo * loop)
return NULL_TREE;
if (!integer_zerop (loop->from[i]))
{
- /* Only allow non-zero "from" in one-dimensional arrays. */
+ /* Only allow nonzero "from" in one-dimensional arrays. */
if (loop->dimen != 1)
return NULL_TREE;
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
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 desc;
tree type;
bool dynamic;
+ bool old_first_len, old_typespec_chararray_ctor;
+ tree old_first_len_val;
+
+ /* Save the old values for nested checking. */
+ old_first_len = first_len;
+ old_first_len_val = first_len_val;
+ old_typespec_chararray_ctor = typespec_chararray_ctor;
+
+ /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
+ typespec was given for the array constructor. */
+ typespec_chararray_ctor = (ss->expr->ts.cl
+ && ss->expr->ts.cl->length_from_typespec);
+
+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ && ss->expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
+ {
+ first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
+ first_len = true;
+ }
ss->data.info.dimen = loop->dimen;
c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
{
- bool const_string = get_array_ctor_strlen (c, &ss->string_length);
- if (!ss->string_length)
- gfc_todo_error ("complex character array constructors");
+ bool const_string;
+
+ /* get_array_ctor_strlen walks the elements of the constructor, if a
+ typespec was given, we already know the string length and want the one
+ specified there. */
+ if (typespec_chararray_ctor && ss->expr->ts.cl->length
+ && ss->expr->ts.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_charlen_type_node);
+ ss->string_length = length_se.expr;
+ gfc_add_block_to_block (&loop->pre, &length_se.pre);
+ gfc_add_block_to_block (&loop->post, &length_se.post);
+ }
+ else
+ const_string = get_array_ctor_strlen (&loop->pre, c,
+ &ss->string_length);
+
+ /* Complex character array constructors should have been taken care of
+ and not end up here. */
+ gcc_assert (ss->string_length);
+
+ ss->expr->ts.cl->backend_decl = ss->string_length;
type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
if (const_string)
/* See if the constructor determines the loop bounds. */
dynamic = false;
+
+ if (ss->expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE)
+ {
+ /* We have a multidimensional parameter. */
+ int n;
+ for (n = 0; n < ss->expr->rank; n++)
+ {
+ loop->from[n] = gfc_index_zero_node;
+ loop->to[n] = gfc_conv_mpz_to_tree (ss->expr->shape [n],
+ gfc_index_integer_kind);
+ loop->to[n] = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ loop->to[n], gfc_index_one_node);
+ }
+ }
+
if (loop->to[0] == NULL_TREE)
{
mpz_t size;
if (size && compare_tree_int (size, nelem) == 0)
{
gfc_trans_constant_array_constructor (loop, ss, type);
- return;
+ goto finish;
}
}
}
gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, &ss->data.info,
- type, dynamic, true, false);
+ type, NULL_TREE, dynamic, true, false, where);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
+ TREE_NO_WARNING (offsetvar) = 1;
TREE_USED (offsetvar) = 0;
gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
&offset, &offsetvar, dynamic);
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;
break;
case GFC_SS_CONSTRUCTOR:
- gfc_trans_array_constructor (loop, ss);
+ if (ss->expr->ts.type == BT_CHARACTER
+ && ss->string_length == NULL
+ && ss->expr->ts.cl
+ && ss->expr->ts.cl->length)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, ss->expr->ts.cl->length,
+ gfc_charlen_type_node);
+ ss->string_length = se.expr;
+ gfc_add_block_to_block (&loop->pre, &se.pre);
+ gfc_add_block_to_block (&loop->post, &se.post);
+ }
+ gfc_trans_array_constructor (loop, ss, where);
break;
case GFC_SS_TEMP:
else
{
/* Descriptorless arrays. */
- return build_fold_addr_expr (descriptor);
+ return gfc_build_addr_expr (NULL_TREE, descriptor);
}
}
else
static tree
gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
- locus * where)
+ locus * where, bool check_upper)
{
tree fault;
tree tmp;
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);
tmp = gfc_conv_array_lbound (descriptor, n);
fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
if (name)
- asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
- gfc_msg_fault, name, n+1);
+ 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",
+ asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
gfc_msg_fault, n+1);
- gfc_trans_runtime_check (fault, msg, &se->pre, where);
+ 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. */
- tmp = gfc_conv_array_ubound (descriptor, n);
- fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
- if (name)
- asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded",
- gfc_msg_fault, name, n+1);
- else
- asprintf (&msg, "%s, upper bound of dimension %d exceeded",
- gfc_msg_fault, n+1);
- gfc_trans_runtime_check (fault, msg, &se->pre, where);
- gfc_free (msg);
+ if (check_upper)
+ {
+ tmp = gfc_conv_array_ubound (descriptor, n);
+ fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
+ if (name)
+ asprintf (&msg, "%s for array '%s', upper bound of dimension %d "
+ " exceeded (%%ld > %%ld)", gfc_msg_fault, name, n+1);
+ else
+ asprintf (&msg, "%s, upper 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);
+ }
return index;
}
switch (ar->dimen_type[dim])
{
case DIMEN_ELEMENT:
- gcc_assert (i == -1);
/* Elemental dimension. */
gcc_assert (info->subscript[dim]
&& info->subscript[dim]->type == GFC_SS_SCALAR);
/* We've already translated this value outside the loop. */
index = info->subscript[dim]->data.scalar.expr;
- if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
- || dim < ar->dimen - 1)
- index = gfc_trans_array_bound_check (se, info->descriptor,
- index, dim, &ar->where);
+ 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);
break;
case DIMEN_VECTOR:
/* Read the vector to get an index into info->descriptor. */
data = build_fold_indirect_ref (gfc_conv_array_data (desc));
- index = gfc_build_array_ref (data, index);
+ index = gfc_build_array_ref (data, index, NULL);
index = gfc_evaluate_now (index, &se->pre);
/* Do any bounds checking on the final info->descriptor index. */
- if ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
- || dim < ar->dimen - 1)
- index = gfc_trans_array_bound_check (se, info->descriptor,
- index, dim, &ar->where);
+ 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);
break;
case DIMEN_RANGE:
gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
{
gfc_ss_info *info;
+ tree decl = NULL_TREE;
tree index;
tree tmp;
int n;
if (!integer_zerop (info->offset))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset);
+ 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);
- se->expr = gfc_build_array_ref (tmp, index);
+ se->expr = gfc_build_array_ref (tmp, index, decl);
}
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 &&
- ((ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed)
- || n < ar->dimen - 1))
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
/* Check array bounds. */
tree cond;
char *msg;
+ /* Evaluate the indexse.expr only once. */
+ indexse.expr = save_expr (indexse.expr);
+
+ /* Lower bound. */
tmp = gfc_conv_array_lbound (se->expr, n);
cond = fold_build2 (LT_EXPR, boolean_type_node,
indexse.expr, tmp);
asprintf (&msg, "%s for array '%s', "
- "lower bound of dimension %d exceeded", gfc_msg_fault,
- sym->name, n+1);
- gfc_trans_runtime_check (cond, msg, &se->pre, where);
+ "lower bound of dimension %d exceeded (%%ld < %%ld)",
+ gfc_msg_fault, sym->name, n+1);
+ 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));
gfc_free (msg);
- tmp = gfc_conv_array_ubound (se->expr, n);
- cond = fold_build2 (GT_EXPR, boolean_type_node,
- indexse.expr, tmp);
- asprintf (&msg, "%s for array '%s', "
- "upper bound of dimension %d exceeded", gfc_msg_fault,
- sym->name, n+1);
- gfc_trans_runtime_check (cond, msg, &se->pre, where);
- gfc_free (msg);
+ /* 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))
+ {
+ tmp = gfc_conv_array_ubound (se->expr, n);
+ 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);
+ 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));
+ gfc_free (msg);
+ }
}
/* Multiply the index by the stride. */
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp);
-
+
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
tmp = build_fold_indirect_ref (tmp);
- se->expr = gfc_build_array_ref (tmp, index);
+ se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
}
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);
gfc_init_block (&block);
/* The exit condition. */
- cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
+ 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, loopbody);
/* Increment the loopvar. */
- tmp = build2 (PLUS_EXPR, gfc_array_index_type,
- loop->loopvar[n], gfc_index_one_node);
- gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
+ 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);
/* As usual, lbound and ubound are exceptions!. */
case GFC_SS_INTRINSIC:
- switch (ss->expr->value.function.isym->generic_id)
+ switch (ss->expr->value.function.isym->id)
{
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
}
}
- if (loop->dimen == 0)
- gfc_todo_error ("Unable to determine rank of expression");
-
+ /* We should have determined the rank of the expression by now. If
+ not, that's bad news. */
+ gcc_assert (loop->dimen != 0);
/* Loop over all the SS in the chain. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
break;
case GFC_SS_INTRINSIC:
- switch (ss->expr->value.function.isym->generic_id)
+ switch (ss->expr->value.function.isym->id)
{
/* Fall through to supply start and stride. */
case GFC_ISYM_LBOUND:
}
/* The rest is just runtime bound checking. */
- if (flag_bounds_check)
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
stmtblock_t block;
tree lbound, ubound;
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
+ stmtblock_t inner;
+
if (ss->type != GFC_SS_SECTION)
continue;
+ gfc_start_block (&inner);
+
/* TODO: range checking for mapped dimensions. */
info = &ss->data.info;
dimensions are checked later. */
for (n = 0; n < loop->dimen; n++)
{
+ bool check_upper;
+
dim = info->dim[n];
if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
continue;
- if (n == info->ref->u.ar.dimen - 1
+
+ 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))
- continue;
-
- desc = ss->data.info.descriptor;
-
- /* This is the run-time equivalent of resolve.c's
- check_dimension(). The logical is more readable there
- than it is here, with all the trees. */
- lbound = gfc_conv_array_lbound (desc, dim);
- ubound = gfc_conv_array_ubound (desc, dim);
- end = info->end[n];
+ check_upper = false;
+ else
+ check_upper = true;
/* Zero stride is not allowed. */
tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n],
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, msg, &block, &ss->expr->where);
+ gfc_trans_runtime_check (true, false, tmp, &inner,
+ &ss->expr->where, msg);
gfc_free (msg);
+ desc = ss->data.info.descriptor;
+
+ /* This is the run-time equivalent of resolve.c's
+ check_dimension(). The logical is more readable there
+ than it is here, with all the trees. */
+ lbound = gfc_conv_array_lbound (desc, dim);
+ end = info->end[n];
+ if (check_upper)
+ ubound = gfc_conv_array_ubound (desc, dim);
+ else
+ ubound = NULL;
+
/* non_zerosized is true when the selected range is not
empty. */
stride_pos = fold_build2 (GT_EXPR, boolean_type_node,
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
non_zerosized, tmp);
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
- " exceeded", gfc_msg_fault, info->dim[n]+1,
- ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
+ " 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);
- tmp = fold_build2 (GT_EXPR, boolean_type_node, info->start[n],
- 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", gfc_msg_fault, info->dim[n]+1,
- ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
- gfc_free (msg);
+ if (check_upper)
+ {
+ tmp = fold_build2 (GT_EXPR, boolean_type_node,
+ info->start[n], 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,
+ 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_free (msg);
+ }
/* Compute the last element of the range, which is not
necessarily "end" (think 0:5:3, which doesn't contain 5)
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
non_zerosized, tmp);
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
- " exceeded", gfc_msg_fault, info->dim[n]+1,
- ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
+ " 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 (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", gfc_msg_fault, info->dim[n]+1,
- ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
- gfc_free (msg);
+ 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,
+ 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_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 (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])
{
- tmp =
- fold_build2 (NE_EXPR, boolean_type_node, tmp, 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'", gfc_msg_bounds, info->dim[n]+1,
- ss->expr->symtree->name);
- gfc_trans_runtime_check (tmp, msg, &block, &ss->expr->where);
+ "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
+ 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
- size[n] = gfc_evaluate_now (tmp, &block);
+ size[n] = gfc_evaluate_now (tmp, &inner);
}
+
+ tmp = gfc_finish_block (&inner);
+
+ /* For optional arguments, only check bounds if the argument is
+ present. */
+ if (ss->expr->symtree->n.sym->attr.optional
+ || ss->expr->symtree->n.sym->attr.not_always_present)
+ tmp = build3_v (COND_EXPR,
+ gfc_conv_expr_present (ss->expr->symtree->n.sym),
+ tmp, build_empty_stmt ());
+
+ gfc_add_expr_to_block (&block, tmp);
+
}
tmp = gfc_finish_block (&block);
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;
nDepend = gfc_dep_resolver (lref, rref);
+ if (nDepend == 1)
+ break;
#if 0
/* TODO : loop shifting. */
if (nDepend == 1)
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;
}
loopspec[n] = ss; */
}
- if (!loopspec[n])
- gfc_todo_error ("Unable to find scalarization loop specifier");
+ /* We should have found the scalarization loop specifier. If not,
+ that's bad news. */
+ gcc_assert (loopspec[n]);
info = &loopspec[n]->data.info;
break;
case GFC_SS_SECTION:
- loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
- &loop->pre);
+ /* Use the end expression if it exists and is not constant,
+ so that it is only evaluated once. */
+ if (info->end[n] && !INTEGER_CST_P (info->end[n]))
+ loop->to[n] = info->end[n];
+ else
+ loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
+ &loop->pre);
break;
case GFC_SS_FUNCTION:
for (i = 0; i<=last; i++){...}; */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
loop->to[n], loop->from[n]);
- tmp = fold_build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
+ tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type,
tmp, info->stride[n]);
+ tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp,
+ build_int_cst (gfc_array_index_type, -1));
loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
/* Make the loop variable start at 0. */
loop->from[n] = gfc_index_zero_node;
/* Add all the scalar code that can be taken out of the loops.
This may include calculating the loop bounds, so do it before
allocating the temporary. */
- gfc_add_loop_ss_code (loop, loop->ss, false);
+ gfc_add_loop_ss_code (loop, loop->ss, false, where);
/* If we want a temporary then create it. */
if (loop->temp_ss != NULL)
{
gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
+
+ /* Make absolutely sure that this is a complete type. */
+ if (loop->temp_ss->string_length)
+ loop->temp_ss->data.temp.type
+ = gfc_get_character_type_len_for_eltype
+ (TREE_TYPE (loop->temp_ss->data.temp.type),
+ loop->temp_ss->string_length);
+
tmp = loop->temp_ss->data.temp.type;
len = loop->temp_ss->string_length;
n = loop->temp_ss->data.temp.dimen;
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;
size = 1 - lbound;
a.ubound[n] = specified_upper_bound;
a.stride[n] = stride;
- size = ubound + size; //size = ubound + 1 - lbound
+ size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
stride = stride * size;
}
return (stride);
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
or_expr = NULL_TREE;
}
}
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);
offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
/* Start the calculation for the size of this dimension. */
- size = build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, se.expr);
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, se.expr);
/* Set upper bound. */
gfc_init_se (&se, NULL);
gfc_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);
else
or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
+ size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ gfc_index_zero_node, size);
+
/* Multiply the stride by the number of elements in this dimension. */
stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
stride = gfc_evaluate_now (stride, pblock);
/* The stride is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, tmp);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, stride,
+ fold_convert (gfc_array_index_type, tmp));
if (poffset != NULL)
{
var = gfc_create_var (TREE_TYPE (size), "size");
gfc_start_block (&thenblock);
- gfc_add_modify_expr (&thenblock, var, gfc_index_zero_node);
+ gfc_add_modify (&thenblock, var, gfc_index_zero_node);
thencase = gfc_finish_block (&thenblock);
gfc_start_block (&elseblock);
- gfc_add_modify_expr (&elseblock, var, size);
+ gfc_add_modify (&elseblock, var, size);
elsecase = gfc_finish_block (&elseblock);
tmp = gfc_evaluate_now (or_expr, pblock);
{
tree tmp;
tree pointer;
- tree allocate;
tree offset;
tree size;
gfc_expr **lower;
if (!prev_ref)
allocatable_array = expr->symtree->n.sym->attr.allocatable;
else
- allocatable_array = prev_ref->u.c.component->allocatable;
+ allocatable_array = prev_ref->u.c.component->attr.allocatable;
/* Figure out the size of the array. */
switch (ref->u.ar.type)
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
- if (TYPE_PRECISION (gfc_array_index_type) == 32)
- {
- if (allocatable_array)
- allocate = gfor_fndecl_allocate_array;
- else
- allocate = gfor_fndecl_allocate;
- }
- else if (TYPE_PRECISION (gfc_array_index_type) == 64)
- {
- if (allocatable_array)
- allocate = gfor_fndecl_allocate64_array;
- else
- allocate = gfor_fndecl_allocate64;
- }
- else
- gcc_unreachable ();
-
/* The allocate_array variants take the old pointer as first argument. */
if (allocatable_array)
- tmp = build_call_expr (allocate, 3, pointer, size, pstat);
+ tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
else
- tmp = build_call_expr (allocate, 2, size, pstat);
- tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
+ tmp = gfc_allocate_with_status (&se->pre, size, pstat);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
gfc_add_expr_to_block (&se->pre, tmp);
tmp = gfc_conv_descriptor_offset (se->expr);
- gfc_add_modify_expr (&se->pre, tmp, offset);
+ gfc_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 = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat);
+ tmp = gfc_deallocate_with_status (var, pstat, false, expr);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
- tmp = build2 (MODIFY_EXPR, void_type_node,
- var, build_int_cst (TREE_TYPE (var), 0));
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ var, build_int_cst (TREE_TYPE (var), 0));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
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);
else
tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
- range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
+ range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
}
else
range = NULL;
CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
+
default:
- gcc_unreachable ();
+ /* Catch those occasional beasts that do not simplify
+ for one reason or another, assuming that if they are
+ standard defying the frontend will catch them. */
+ gfc_conv_expr (&se, c->expr);
+ if (range == NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ else
+ {
+ if (index != NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+ }
+ break;
}
}
break;
/* Create a constructor from the list of elements. */
tmp = build_constructor (type, v);
TREE_CONSTANT (tmp) = 1;
- TREE_INVARIANT (tmp) = 1;
return tmp;
}
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify_expr (pblock, lbound, se.expr);
+ gfc_add_modify (pblock, lbound, se.expr);
}
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify_expr (pblock, ubound, se.expr);
+ gfc_add_modify (pblock, ubound, se.expr);
}
/* The offset of this dimension. offset = offset - lbound * stride. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, size);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
if (stride)
- gfc_add_modify_expr (pblock, stride, tmp);
+ gfc_add_modify (pblock, stride, tmp);
else
stride = gfc_evaluate_now (tmp, pblock);
/* Make sure that negative size arrays are translated
to being zero size. */
- tmp = build2 (GE_EXPR, boolean_type_node,
- stride, gfc_index_zero_node);
- tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
- stride, gfc_index_zero_node);
- gfc_add_modify_expr (pblock, stride, tmp);
+ tmp = fold_build2 (GE_EXPR, boolean_type_node,
+ stride, gfc_index_zero_node);
+ tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
+ stride, gfc_index_zero_node);
+ gfc_add_modify (pblock, stride, tmp);
}
size = stride;
stmtblock_t block;
tree type;
tree tmp;
- tree fndecl;
tree size;
tree offset;
bool onstack;
if (sym->ts.type == BT_CHARACTER
&& onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
- gfc_trans_init_string_length (sym->ts.cl, &block);
+ gfc_conv_string_length (sym->ts.cl, NULL, &block);
gfc_trans_vla_type_sizes (sym, &block);
/* Emit a DECL_EXPR for this variable, which will cause the
gimplifier to allocate storage, and all that good stuff. */
- tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
+ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&block, tmp);
}
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
- gfc_trans_init_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);
}
/* The size is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ fold_convert (gfc_array_index_type, tmp));
/* Allocate memory to hold the data. */
- if (gfc_index_integer_kind == 4)
- fndecl = gfor_fndecl_internal_malloc;
- else if (gfc_index_integer_kind == 8)
- fndecl = gfor_fndecl_internal_malloc64;
- else
- gcc_unreachable ();
- tmp = build_call_expr (fndecl, 1, size);
- tmp = fold_convert (TREE_TYPE (decl), tmp);
- gfc_add_modify_expr (&block, decl, tmp);
+ tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
+ gfc_add_modify (&block, decl, tmp);
/* Set offset of the array. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
/* Automatic arrays should not have initializers. */
gfc_add_expr_to_block (&block, fnbody);
/* Free the temporary. */
- tmp = convert (pvoid_type_node, decl);
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
+ tmp = gfc_call_free (convert (pvoid_type_node, decl));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
- gfc_trans_init_string_length (sym->ts.cl, &block);
+ 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_trans_init_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
{
stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
stride = gfc_evaluate_now (stride, &block);
- tmp = build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node);
- tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
- gfc_index_one_node, stride);
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node,
+ stride, gfc_index_zero_node);
+ tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp,
+ gfc_index_one_node, stride);
stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
/* Allow the user to disable array repacking. */
stmt_unpacked = NULL_TREE;
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
if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
{
/* Don't repack unknown shape arrays when the first stride is 1. */
- tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
- stmt_packed, stmt_unpacked);
+ tmp = fold_build3 (COND_EXPR, TREE_TYPE (stmt_packed),
+ partial, stmt_packed, stmt_unpacked);
}
else
tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
- gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
+ gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp));
offset = gfc_index_zero_node;
size = gfc_index_one_node;
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 (MINUS_EXPR, gfc_array_index_type,
ubound, lbound);
- stride2 = build2 (MINUS_EXPR, gfc_array_index_type,
- dubound, dlbound);
+ 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 (tmp, msg, &block, &loc);
+ gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
gfc_free (msg);
}
}
{
/* For assumed shape arrays move the upper bound by the same amount
as the lower bound. */
- tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ dubound, dlbound);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound);
- gfc_add_modify_expr (&block, ubound, tmp);
+ gfc_add_modify (&block, ubound, tmp);
}
/* The offset of this dimension. offset = offset - lbound * stride. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride);
/* Assign the stride. */
if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
- tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
- stmt_unpacked, stmt_packed);
+ tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial,
+ stmt_unpacked, stmt_packed);
else
tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
}
}
else
ubound, tmp);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
- gfc_add_modify_expr (&block, stride, tmp);
+ gfc_add_modify (&block, stride, tmp);
}
}
}
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
gfc_trans_vla_type_sizes (sym, &block);
}
/* Free the temporary. */
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmpdesc);
+ tmp = gfc_call_free (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 = gfc_conv_descriptor_data_get (tmp);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
+ tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
if (optional_arg)
}
+/* Calculate the overall offset, including subreferences. */
+static void
+gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
+ bool subref, gfc_expr *expr)
+{
+ tree tmp;
+ tree field;
+ tree stride;
+ tree index;
+ gfc_ref *ref;
+ gfc_se start;
+ int n;
+
+ /* If offset is NULL and this is not a subreferenced array, there is
+ nothing to do. */
+ if (offset == NULL_TREE)
+ {
+ if (subref)
+ offset = gfc_index_zero_node;
+ else
+ return;
+ }
+
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref (tmp);
+ tmp = gfc_build_array_ref (tmp, offset, NULL);
+
+ /* Offset the data pointer for pointer assignments from arrays with
+ subreferences; e.g. my_integer => my_type(:)%integer_component. */
+ if (subref)
+ {
+ /* Go past the array reference. */
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY &&
+ ref->u.ar.type != AR_ELEMENT)
+ {
+ ref = ref->next;
+ break;
+ }
+
+ /* Calculate the offset for each subsequent subreference. */
+ for (; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ field = ref->u.c.component->backend_decl;
+ gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
+ break;
+
+ case REF_SUBSTRING:
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
+ gfc_add_block_to_block (block, &start.pre);
+ tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+ break;
+
+ case REF_ARRAY:
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE
+ && ref->u.ar.type == AR_ELEMENT);
+
+ /* TODO - Add bounds checking. */
+ stride = gfc_index_one_node;
+ index = gfc_index_zero_node;
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ {
+ tree itmp;
+ tree jtmp;
+
+ /* Update the index. */
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.start[n], gfc_array_index_type);
+ itmp = gfc_evaluate_now (start.expr, block);
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.as->lower[n], gfc_array_index_type);
+ jtmp = gfc_evaluate_now (start.expr, block);
+ itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, itmp, jtmp);
+ itmp = fold_build2 (MULT_EXPR, gfc_array_index_type, itmp, stride);
+ index = fold_build2 (PLUS_EXPR, gfc_array_index_type, itmp, index);
+ index = gfc_evaluate_now (index, block);
+
+ /* Update the stride. */
+ gfc_init_se (&start, NULL);
+ gfc_conv_expr_type (&start, ref->u.ar.as->upper[n], gfc_array_index_type);
+ itmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, start.expr, jtmp);
+ itmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, itmp);
+ stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, itmp);
+ stride = gfc_evaluate_now (stride, block);
+ }
+
+ /* Apply the index to obtain the array element. */
+ tmp = gfc_build_array_ref (tmp, index, NULL);
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+ }
+ }
+
+ /* Set the target data pointer. */
+ offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
+ gfc_conv_descriptor_data_set (block, parm, offset);
+}
+
+
+/* gfc_conv_expr_descriptor needs the 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. */
+static void
+get_elemental_fcn_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 (!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.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.cl->backend_decl = tse.expr;
+ gfc_free_interface_mapping (&mapping);
+}
+
+
/* 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
This function is also used for array pointer assignments, and there
are three cases:
- - want_pointer && !se->direct_byref
+ - se->want_pointer && !se->direct_byref
EXPR is an actual argument. On exit, se->expr contains a
pointer to the array descriptor.
- - !want_pointer && !se->direct_byref
+ - !se->want_pointer && !se->direct_byref
EXPR is an actual argument to an intrinsic function or the
left-hand side of a pointer assignment. On exit, se->expr
contains the descriptor for EXPR.
- - !want_pointer && se->direct_byref
+ - !se->want_pointer && se->direct_byref
EXPR is the right-hand side of a pointer assignment and
se->expr is the descriptor for the previously-evaluated
left-hand side. The function creates an assignment from
tree start;
tree offset;
int full;
+ bool subref_array_target = false;
gcc_assert (ss != gfc_ss_terminator);
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
- need_tmp = gfc_ref_needs_temporary_p (expr->ref);
+ subref_array_target = se->direct_byref && is_subref_array (expr);
+ need_tmp = gfc_ref_needs_temporary_p (expr->ref)
+ && !subref_array_target;
+
if (need_tmp)
full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
if (se->direct_byref)
{
/* Copy the descriptor for pointer assignments. */
- gfc_add_modify_expr (&se->pre, se->expr, desc);
+ gfc_add_modify (&se->pre, se->expr, desc);
+
+ /* Add any offsets from subreferences. */
+ gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
+ subref_array_target, expr);
}
else if (se->want_pointer)
{
/* We pass full arrays directly. This means that pointers and
allocatable arrays should also work. */
- se->expr = build_fold_addr_expr (desc);
+ se->expr = gfc_build_addr_expr (NULL_TREE, desc);
}
else
{
/* For pointer assignments pass the descriptor directly. */
se->ss = secss;
- se->expr = build_fold_addr_expr (se->expr);
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
gfc_conv_expr (se, expr);
return;
}
{
/* Elemental function. */
need_tmp = 1;
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
+ get_elemental_fcn_charlen (expr, se);
+
info = NULL;
}
else
break;
}
-
gfc_init_loopinfo (&loop);
/* Associate the SS with the loop. */
loop.temp_ss = gfc_get_ss ();
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
+
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.cl, expr, &se->pre);
+
+ loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+
if (expr->ts.type == BT_CHARACTER)
- {
- if (expr->ts.cl == NULL)
- {
- /* This had better be a substring reference! */
- gfc_ref *char_ref = expr->ref;
- for (; char_ref; char_ref = char_ref->next)
- if (char_ref->type == REF_SUBSTRING)
- {
- mpz_t char_len;
- expr->ts.cl = gfc_get_charlen ();
- expr->ts.cl->next = char_ref->u.ss.length->next;
- char_ref->u.ss.length->next = expr->ts.cl;
-
- mpz_init_set_ui (char_len, 1);
- mpz_add (char_len, char_len,
- char_ref->u.ss.end->value.integer);
- mpz_sub (char_len, char_len,
- char_ref->u.ss.start->value.integer);
- expr->ts.cl->backend_decl
- = gfc_conv_mpz_to_tree (char_len,
- gfc_default_character_kind);
- /* Cast is necessary for *-charlen refs. */
- expr->ts.cl->backend_decl
- = convert (gfc_charlen_type_node,
- expr->ts.cl->backend_decl);
- mpz_clear (char_len);
- break;
- }
- gcc_assert (char_ref != NULL);
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
- }
- else if (expr->ts.cl->length
- && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
- {
- expr->ts.cl->backend_decl
- = gfc_conv_mpz_to_tree (expr->ts.cl->length->value.integer,
- expr->ts.cl->length->ts.kind);
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length
- = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
- }
- else
- {
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
- }
- se->string_length = loop.temp_ss->string_length;
- }
+ loop.temp_ss->string_length = expr->ts.cl->backend_decl;
else
- {
- loop.temp_ss->data.temp.type
- = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->string_length = NULL;
- }
+ loop.temp_ss->string_length = NULL;
+
+ se->string_length = loop.temp_ss->string_length;
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, & expr->where);
if (need_tmp)
{
gfc_add_block_to_block (&block, &rse.pre);
gfc_add_block_to_block (&block, &lse.pre);
- gfc_add_modify_expr (&block, lse.expr, rse.expr);
+ lse.string_length = rse.string_length;
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
+ expr->expr_type == EXPR_VARIABLE);
+ gfc_add_expr_to_block (&block, tmp);
/* Finish the copying loops. */
gfc_trans_scalarizing_loops (&loop, &block);
/* Otherwise make a new one. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
- loop.from, loop.to, 0);
+ loop.from, loop.to, 0,
+ GFC_ARRAY_UNKNOWN);
parm = gfc_create_var (parmtype, "parm");
}
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (parm);
- gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
+ gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
- if (se->direct_byref)
+ /* Set offset for assignments to pointer only to zero if it is not
+ the full array. */
+ if (se->direct_byref
+ && info->ref && info->ref->u.ar.type != AR_FULL)
base = gfc_index_zero_node;
+ else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+ base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
else
base = NULL_TREE;
from = loop.from[dim];
to = loop.to[dim];
- /* If we have an array section or are assigning to a pointer,
- make sure that the lower bound is 1. References to the full
+ /* If we have an array section or are assigning make sure that
+ the lower bound is 1. References to the full
array should otherwise keep the original bounds. */
if ((!info->ref
- || info->ref->u.ar.type != AR_FULL
- || se->direct_byref)
+ || info->ref->u.ar.type != AR_FULL)
&& !integer_onep (from))
{
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
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. */
stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
stride, info->stride[dim]);
- if (se->direct_byref)
- base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
- base, stride);
+ if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
+ {
+ base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
+ base, stride);
+ }
+ else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+ {
+ tmp = gfc_conv_array_lbound (desc, n);
+ tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
+ tmp, loop.from[dim]);
+ tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base),
+ tmp, gfc_conv_array_stride (desc, n));
+ base = fold_build2 (PLUS_EXPR, TREE_TYPE (base),
+ tmp, base);
+ }
/* 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++;
}
if (se->data_not_needed)
gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node);
else
- {
- /* Point the data pointer at the first element in the section. */
- tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref (tmp);
- tmp = gfc_build_array_ref (tmp, offset);
- offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
- gfc_conv_descriptor_data_set (&loop.pre, parm, offset);
- }
+ /* Point the data pointer at the first element in the section. */
+ gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
+ subref_array_target, expr);
- if (se->direct_byref && !se->data_not_needed)
+ if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+ && !se->data_not_needed)
{
/* 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;
- tree tmp;
+ tree tmp = NULL_TREE;
tree stmt;
+ tree parent = DECL_CONTEXT (current_function_decl);
+ bool full_array_var, this_array_result;
gfc_symbol *sym;
stmtblock_t block;
+ full_array_var = (expr->expr_type == EXPR_VARIABLE
+ && 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);
+ expr->ts.cl->backend_decl = tmp;
+ se->string_length = tmp;
+ }
+
+ /* Is this the result of the enclosing procedure? */
+ this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
+ if (this_array_result
+ && (sym->backend_decl != current_function_decl)
+ && (sym->backend_decl != parent))
+ this_array_result = false;
+
/* Passing address of the array if it is not pointer or assumed-shape. */
- if (expr->expr_type == EXPR_VARIABLE
- && expr->ref->u.ar.type == AR_FULL && g77)
+ if (full_array_var && g77 && !this_array_result)
{
- sym = expr->symtree->n.sym;
tmp = gfc_get_symbol_decl (sym);
if (sym->ts.type == BT_CHARACTER)
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)
{
- if (sym->attr.dummy)
+ if (sym->attr.dummy || sym->attr.result)
{
gfc_conv_expr_descriptor (se, expr, ss);
se->expr = gfc_conv_array_data (se->expr);
}
}
- se->want_pointer = 1;
- gfc_conv_expr_descriptor (se, expr, ss);
+ if (this_array_result)
+ {
+ /* Result of the enclosing function. */
+ gfc_conv_expr_descriptor (se, expr, ss);
+ 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));
+
+ return;
+ }
+ else
+ {
+ /* Every other type of array. */
+ se->want_pointer = 1;
+ gfc_conv_expr_descriptor (se, expr, ss);
+ }
/* Deallocate the allocatable components of structures that are
not variable. */
{
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 = convert (pvoid_type_node, ptr);
- tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
+ tmp = gfc_call_free (convert (pvoid_type_node, ptr));
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
loop cleanup code. */
tmp = build_fold_indirect_ref (desc);
tmp = gfc_conv_array_data (tmp);
- tmp = build2 (NE_EXPR, boolean_type_node, ptr, 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);
gfc_trans_dealloc_allocated (tree descriptor)
{
tree tmp;
- tree ptr;
tree var;
stmtblock_t block;
var = gfc_conv_descriptor_data_get (descriptor);
STRIP_NOPS (var);
- tmp = gfc_create_var (gfc_array_index_type, NULL);
- ptr = build_fold_addr_expr (tmp);
- /* Call array_deallocate with an int* present in the second argument.
+ /* Call array_deallocate with an int * present in the second argument.
Although it is ignored here, it's presence ensures that arrays that
are already deallocated are ignored. */
- tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr);
+ tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
- tmp = build2 (MODIFY_EXPR, void_type_node,
- var, build_int_cst (TREE_TYPE (var), 0));
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ var, build_int_cst (TREE_TYPE (var), 0));
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
idx = gfc_rank_cst[rank - 1];
nelems = gfc_conv_descriptor_ubound (decl, idx);
tmp = gfc_conv_descriptor_lbound (decl, idx);
- tmp = build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
- tmp = build2 (PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, nelems, tmp);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
tmp = gfc_evaluate_now (tmp, block);
nelems = gfc_conv_descriptor_stride (decl, idx);
- tmp = build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
return gfc_evaluate_now (tmp, block);
}
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. */
gfc_init_block (&block);
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
null_data = gfc_finish_block (&block);
nelems = get_full_array_size (&block, src, rank);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type))));
/* Allocate memory to the destination. */
- if (gfc_index_integer_kind == 4)
- tmp = build_call_expr (gfor_fndecl_internal_malloc, 1, size);
- else if (gfc_index_integer_kind == 8)
- tmp = build_call_expr (gfor_fndecl_internal_malloc64, 1, size);
- else
- gcc_unreachable ();
- tmp = fold_convert (TREE_TYPE (gfc_conv_descriptor_data_get (src)), tmp);
+ 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,
the allocate and copy. */
null_cond = gfc_conv_descriptor_data_get (src);
null_cond = convert (pvoid_type_node, null_cond);
- null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
- null_pointer_node);
+ null_cond = fold_build2 (NE_EXPR, boolean_type_node,
+ null_cond, null_pointer_node);
return build3_v (COND_EXPR, null_cond, tmp, null_data);
}
is a full array reference, we only need the descriptor
information from dimension = rank. */
tmp = get_full_array_size (&fnblock, decl, rank);
- tmp = build2 (MINUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
null_cond = gfc_conv_descriptor_data_get (decl);
- null_cond = build2 (NE_EXPR, boolean_type_node, null_cond,
- build_int_cst (TREE_TYPE (null_cond), 0));
+ null_cond = fold_build2 (NE_EXPR, boolean_type_node, null_cond,
+ build_int_cst (TREE_TYPE (null_cond), 0));
}
else
{
/* Build the body of the loop. */
gfc_init_block (&loopbody);
- vref = gfc_build_array_ref (var, index);
+ vref = gfc_build_array_ref (var, index, NULL);
if (purpose == COPY_ALLOC_COMP)
{
- tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
- gfc_add_expr_to_block (&fnblock, tmp);
-
- tmp = build_fold_indirect_ref (gfc_conv_descriptor_data_get (dest));
- dref = gfc_build_array_ref (tmp, index);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
+ {
+ tmp = gfc_duplicate_allocatable (dest, decl, TREE_TYPE(decl), rank);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ tmp = build_fold_indirect_ref (gfc_conv_array_data (dest));
+ dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
else
gfc_add_expr_to_block (&loopbody, tmp);
- /* Build the loop and return. */
+ /* Build the loop and return. */
gfc_init_loopinfo (&loop);
loop.dimen = 1;
loop.from[0] = gfc_index_zero_node;
}
/* Otherwise, act on the components or recursively call self to
- act on a chain of components. */
+ act on a chain of components. */
for (c = der_type->components; c; c = c->next)
{
bool cmp_has_alloc_comps = (c->ts.type == BT_DERIVED)
case DEALLOCATE_ALLOC_COMP:
/* Do not deallocate the components of ultimate pointer
components. */
- if (cmp_has_alloc_comps && !c->pointer)
+ if (cmp_has_alloc_comps && !c->attr.pointer)
{
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
- if (c->allocatable)
+ if (c->attr.allocatable)
{
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
tmp = gfc_trans_dealloc_allocated (comp);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
case NULLIFY_ALLOC_COMP:
- if (c->pointer)
+ if (c->attr.pointer)
continue;
- else if (c->allocatable)
+ else if (c->attr.allocatable)
{
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
}
else if (cmp_has_alloc_comps)
{
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.derived, comp, NULL_TREE,
rank, purpose);
break;
case COPY_ALLOC_COMP:
- if (c->pointer)
+ if (c->attr.pointer)
continue;
/* We need source and destination components. */
- comp = build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
- dcmp = build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ dcmp = fold_build3 (COMPONENT_REF, ctype, dest, cdecl, NULL_TREE);
dcmp = fold_convert (TREE_TYPE (comp), dcmp);
- if (c->allocatable && !cmp_has_alloc_comps)
+ if (c->attr.allocatable && !cmp_has_alloc_comps)
{
tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
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_trans_init_string_length (sym->ts.cl, &fnblock);
+ gfc_conv_string_length (sym->ts.cl, NULL, &fnblock);
gfc_trans_vla_type_sizes (sym, &fnblock);
}
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)
+ {
+ tmp = gfc_init_default_dt (sym, NULL);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
}
}
else if (!GFC_DESCRIPTOR_TYPE_P (type))
}
/* NULLIFY the data pointer. */
- if (GFC_DESCRIPTOR_TYPE_P (type))
+ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node);
gfc_add_expr_to_block (&fnblock, body);
gfc_add_expr_to_block (&fnblock, tmp);
}
- if (sym->attr.allocatable)
+ 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
