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. */
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
{
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);
+ /* 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_expr (&se->pre,
gfc_conv_descriptor_offset (dest),
dest_info->offset);
-
+
if (dest_info->dimen > loop->temp_dim)
loop->temp_dim = dest_info->dimen;
}
/* 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 ();
+ arg1 = build2 (MULT_EXPR, size_type_node, fold_convert (size_type_node, tmp),
+ fold_convert (size_type_node, size));
- /* Set the new data pointer. */
- tmp = build_call_expr (tmp, 2, arg0, arg1);
+ /* Call the realloc() function. */
+ tmp = gfc_call_realloc (pblock, arg0, arg1);
gfc_conv_descriptor_data_set (pblock, desc, tmp);
}
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))
{
}
+/* 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->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.
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;
+
+ if (c == NULL)
+ {
+ *len = build_int_cstu (gfc_charlen_type_node, 0);
+ return is_const;
+ }
+
for (; c; c = c->next)
{
switch (c->expr->expr_type)
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;
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. */
+ get_array_ctor_all_strlen (block, c->expr, len);
break;
}
}
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,
c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
{
- bool const_string = get_array_ctor_strlen (c, &ss->string_length);
+ bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
if (!ss->string_length)
gfc_todo_error ("complex character array constructors");
+ /* It is surprising but still possible to wind up with expressions that
+ lack a character length.
+ TODO Find the offending part of the front end and cure this properly.
+ Concatenation involving arrays is the main culprit. */
+ if (!ss->expr->ts.cl)
+ {
+ ss->expr->ts.cl = gfc_get_charlen ();
+ ss->expr->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = ss->expr->ts.cl->next;
+ }
+
+ 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)
type = build_pointer_type (type);
/* 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;
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);
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;
asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
gfc_msg_fault, name, n+1);
else
- asprintf (&msg, "%s, lower bound of dimension %d exceeded",
- gfc_msg_fault, n+1);
- gfc_trans_runtime_check (fault, msg, &se->pre, where);
+ asprintf (&msg, "%s, lower bound of dimension %d exceeded, %%ld is "
+ "smaller than %%ld", gfc_msg_fault, n+1);
+ gfc_trans_runtime_check (fault, &se->pre, where, msg,
+ fold_convert (long_integer_type_node, index),
+ fold_convert (long_integer_type_node, tmp));
gfc_free (msg);
/* Check upper bound. */
- 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", gfc_msg_fault, name, n+1);
+ else
+ asprintf (&msg, "%s, upper bound of dimension %d exceeded, %%ld is "
+ "larger than %%ld", gfc_msg_fault, n+1);
+ gfc_trans_runtime_check (fault, &se->pre, where, msg,
+ fold_convert (long_integer_type_node, index),
+ fold_convert (long_integer_type_node, tmp));
+ gfc_free (msg);
+ }
return index;
}
/* 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:
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_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 (flag_bounds_check)
{
/* 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 is smaller "
+ "than %%ld", gfc_msg_fault, sym->name, n+1);
+ gfc_trans_runtime_check (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 is "
+ "greater than %%ld", gfc_msg_fault, sym->name, n+1);
+ gfc_trans_runtime_check (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. */
/* 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:
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:
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
&& (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 (tmp, &block, &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 is smaller than %%ld", gfc_msg_fault,
+ info->dim[n]+1, ss->expr->symtree->name);
+ gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
+ fold_convert (long_integer_type_node,
+ info->start[n]),
+ fold_convert (long_integer_type_node,
+ lbound));
gfc_free (msg);
- 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 is greater than %%ld",
+ gfc_msg_fault, info->dim[n]+1,
+ ss->expr->symtree->name);
+ gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, info->start[n]),
+ fold_convert (long_integer_type_node, ubound));
+ 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 is smaller than %%ld", gfc_msg_fault,
+ info->dim[n]+1, ss->expr->symtree->name);
+ gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
+ fold_convert (long_integer_type_node,
+ tmp2),
+ fold_convert (long_integer_type_node,
+ lbound));
gfc_free (msg);
- tmp = fold_build2 (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 is greater than %%ld",
+ gfc_msg_fault, info->dim[n]+1,
+ ss->expr->symtree->name);
+ gfc_trans_runtime_check (tmp, &block, &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, tmp2),
+ fold_convert (long_integer_type_node, ubound));
+ gfc_free (msg);
+ }
/* Check the section sizes match. */
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end,
others against this. */
if (size[n])
{
- tmp =
- fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
+ tree tmp3
+ = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
asprintf (&msg, "%s, size mismatch for dimension %d "
- "of array '%s'", 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 (tmp3, &block, &ss->expr->where, msg,
+ fold_convert (long_integer_type_node, tmp),
+ fold_convert (long_integer_type_node, size[n]));
gfc_free (msg);
}
else
/* 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)
{
{
tree tmp;
tree pointer;
- tree allocate;
tree offset;
tree size;
gfc_expr **lower;
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);
else
- tmp = build_call_expr (allocate, 2, size, pstat);
+ tmp = gfc_allocate_with_status (&se->pre, size, pstat);
tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
gfc_add_expr_to_block (&se->pre, 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);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
/* 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. */
tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
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 (tmp, &block, &loc, msg);
gfc_free (msg);
}
}
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
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);
+ gfc_conv_const_charlen (expr->ts.cl);
loop.temp_ss->data.temp.type
= gfc_typenode_for_spec (&expr->ts);
loop.temp_ss->string_length
tmp = gfc_conv_descriptor_dtype (parm);
gfc_add_modify_expr (&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,
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_conv_descriptor_data_set (&loop.pre, parm, offset);
}
- 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);
{
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;
&& expr->ref->u.ar.type == AR_FULL);
sym = full_array_var ? expr->symtree->n.sym : NULL;
+ if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
+ {
+ get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
+ expr->ts.cl->backend_decl = gfc_evaluate_now (tmp, &se->pre);
+ se->string_length = expr->ts.cl->backend_decl;
+ }
+
/* Is this the result of the enclosing procedure? */
this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE);
if (this_array_result
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 = build2 (NE_EXPR, boolean_type_node,
+ fold_convert (TREE_TYPE (tmp), ptr), 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);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
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. */
tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
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)
OSDN Git Service
