/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
- 2011, 2012
- Free Software Foundation, Inc.
+ Copyright (C) 2002-2013 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
descriptors and data pointers are also translated.
If the expression is an assignment, we must then resolve any dependencies.
- In fortran all the rhs values of an assignment must be evaluated before
+ 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 subscripts as procedure parameters.
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "gimple.h"
+#include "gimple.h" /* For create_tmp_var_name. */
#include "diagnostic-core.h" /* For internal_error/fatal_error. */
#include "flags.h"
#include "gfortran.h"
/* This provides WRITE access to the data field.
TUPLES_P is true if we are generating tuples.
-
+
This function gets called through the following macros:
gfc_conv_descriptor_data_set
gfc_conv_descriptor_data_set. */
desc, field, NULL_TREE);
}
-static tree
-gfc_conv_descriptor_dimension (tree desc, tree dim)
+
+tree
+gfc_conv_descriptor_rank (tree desc)
{
- tree field;
- tree type;
tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
+ tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
+ dtype, tmp);
+ return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+}
+
+
+tree
+gfc_get_descriptor_dimension (tree desc)
+{
+ tree type, field;
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
&& TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
- desc, field, NULL_TREE);
- tmp = gfc_build_array_ref (tmp, dim, NULL);
- return tmp;
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+}
+
+
+static tree
+gfc_conv_descriptor_dimension (tree desc, tree dim)
+{
+ tree tmp;
+
+ tmp = gfc_get_descriptor_dimension (desc);
+
+ return gfc_build_array_ref (tmp, dim, NULL);
}
if (integer_zerop (dim)
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
static void
free_ss_info (gfc_ss_info *ss_info)
{
+ int n;
+
ss_info->refcount--;
if (ss_info->refcount > 0)
return;
gcc_assert (ss_info->refcount == 0);
- free (ss_info);
-}
-
-
-/* Free a SS. */
-
-void
-gfc_free_ss (gfc_ss * ss)
-{
- gfc_ss_info *ss_info;
- int n;
-
- ss_info = ss->info;
switch (ss_info->type)
{
case GFC_SS_SECTION:
- for (n = 0; n < ss->dimen; n++)
- {
- if (ss_info->data.array.subscript[ss->dim[n]])
- gfc_free_ss_chain (ss_info->data.array.subscript[ss->dim[n]]);
- }
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ if (ss_info->data.array.subscript[n])
+ gfc_free_ss_chain (ss_info->data.array.subscript[n]);
break;
default:
break;
}
- free_ss_info (ss_info);
+ free (ss_info);
+}
+
+
+/* Free a SS. */
+
+void
+gfc_free_ss (gfc_ss * ss)
+{
+ free_ss_info (ss->info);
free (ss);
}
return ss;
}
-
+
/* Creates and initializes a scalar type gfc_ss struct. */
'eltype' == NULL signals that the temporary should be a class object.
The 'initial' expression is used to obtain the size of the dynamic
- type; otehrwise the allocation and initialisation proceeds as for any
+ type; otherwise the allocation and initialisation proceeds as for any
other expression
PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
dynamic type. Generate an eltype and then the class expression. */
if (eltype == NULL_TREE && initial)
{
- if (POINTER_TYPE_P (TREE_TYPE (initial)))
- class_expr = build_fold_indirect_ref_loc (input_location, initial);
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
+ class_expr = build_fold_indirect_ref_loc (input_location, initial);
eltype = TREE_TYPE (class_expr);
eltype = gfc_get_element_type (eltype);
/* Obtain the structure (class) expression. */
/* Variables needed for bounds-checking. */
static bool first_len;
-static tree first_len_val;
+static tree first_len_val;
static bool typespec_chararray_ctor;
static void
bool dynamic)
{
tree tmp;
+ tree start = NULL_TREE;
+ tree end = NULL_TREE;
+ tree step = NULL_TREE;
stmtblock_t body;
gfc_se se;
mpz_t size;
expression in an interface mapping. */
if (c->iterator)
{
- gfc_symbol *sym = c->iterator->var->symtree->n.sym;
- tree type = gfc_typenode_for_spec (&sym->ts);
+ gfc_symbol *sym;
+ tree type;
+
+ /* Evaluate loop bounds before substituting the loop variable
+ in case they depend on it. Such a case is invalid, but it is
+ not more expensive to do the right thing here.
+ See PR 44354. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_val (&se, c->iterator->start);
+ gfc_add_block_to_block (pblock, &se.pre);
+ start = gfc_evaluate_now (se.expr, pblock);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_val (&se, c->iterator->end);
+ gfc_add_block_to_block (pblock, &se.pre);
+ end = gfc_evaluate_now (se.expr, pblock);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_val (&se, c->iterator->step);
+ gfc_add_block_to_block (pblock, &se.pre);
+ step = gfc_evaluate_now (se.expr, pblock);
+
+ sym = c->iterator->var->symtree->n.sym;
+ type = gfc_typenode_for_spec (&sym->ts);
shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
else
{
/* Collect multiple scalar constants into a constructor. */
- VEC(constructor_elt,gc) *v = NULL;
+ vec<constructor_elt, va_gc> *v = NULL;
tree init;
tree bound;
tree tmptype;
/* Build the implied do-loop. */
stmtblock_t implied_do_block;
tree cond;
- tree end;
- tree step;
tree exit_label;
tree loopbody;
tree tmp2;
gfc_start_block(&implied_do_block);
/* Initialize the loop. */
- gfc_init_se (&se, NULL);
- gfc_conv_expr_val (&se, c->iterator->start);
- gfc_add_block_to_block (&implied_do_block, &se.pre);
- gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr);
-
- gfc_init_se (&se, NULL);
- gfc_conv_expr_val (&se, c->iterator->end);
- gfc_add_block_to_block (&implied_do_block, &se.pre);
- end = gfc_evaluate_now (se.expr, &implied_do_block);
-
- gfc_init_se (&se, NULL);
- gfc_conv_expr_val (&se, c->iterator->step);
- gfc_add_block_to_block (&implied_do_block, &se.pre);
- step = gfc_evaluate_now (se.expr, &implied_do_block);
+ gfc_add_modify (&implied_do_block, shadow_loopvar, start);
/* If this array expands dynamically, and the number of iterations
is not constant, we won't have allocated space for the static
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (&implied_do_block, tmp);
- /* Finishe the implied-do loop. */
+ /* Finish the implied-do loop. */
tmp = gfc_finish_block(&implied_do_block);
gfc_add_expr_to_block(pblock, tmp);
}
-/* A catch-all to obtain the string length for anything that is not a
+/* A catch-all to obtain the string length for anything that is not
a substring of non-constant length, 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))
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)
+ if (e->rank == 0)
gfc_conv_expr (&se, e);
else
- gfc_conv_expr_descriptor (&se, e, ss);
+ gfc_conv_expr_descriptor (&se, e);
/* Fix the value. */
*len = gfc_evaluate_now (se.string_length, &se.pre);
gfc_array_spec as;
gfc_se se;
int i;
- VEC(constructor_elt,gc) *v = NULL;
+ vec<constructor_elt, va_gc> *v = NULL;
/* First traverse the constructor list, converting the constants
to tree to build an initializer. */
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
- {
+ {
first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
first_len = true;
}
if (expr->ts.type == BT_CHARACTER)
{
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 (TREE_CODE (*loop_ubound0) == VAR_DECL)
- dynamic = true;
-
gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
NULL_TREE, dynamic, true, false, where);
case GFC_SS_REFERENCE:
/* Scalar argument to elemental procedure. */
gfc_init_se (&se, NULL);
- if (ss_info->data.scalar.can_be_null_ref)
+ if (ss_info->can_be_null_ref)
{
/* If the actual argument can be absent (in other words, it can
be a NULL reference), don't try to evaluate it; pass instead
case GFC_SS_VECTOR:
/* Get the vector's descriptor and store it in SS. */
gfc_init_se (&se, NULL);
- gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr));
+ gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
info->descriptor = se.expr;
gcc_assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]];
- /* Pointer functions can have stride[0] different from unity.
+ /* Pointer functions can have stride[0] different from unity.
Use the stride returned by the function call and stored in
- the descriptor for the temporary. */
+ the descriptor for the temporary. */
if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
&& se->ss->info->expr
&& se->ss->info->expr->symtree
ts = &ref->u.c.component->ts;
class_ref = ref;
break;
- }
+ }
}
if (ts == NULL)
}
}
+
+static tree
+build_array_ref (tree desc, tree offset, tree decl)
+{
+ tree tmp;
+ tree type;
+
+ /* Class container types do not always have the GFC_CLASS_TYPE_P
+ but the canonical type does. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+ && TREE_CODE (desc) == COMPONENT_REF)
+ {
+ type = TREE_TYPE (TREE_OPERAND (desc, 0));
+ if (TYPE_CANONICAL (type)
+ && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
+ type = TYPE_CANONICAL (type);
+ }
+ else
+ type = NULL;
+
+ /* Class array references need special treatment because the assigned
+ type size needs to be used to point to the element. */
+ if (type && GFC_CLASS_TYPE_P (type))
+ {
+ type = gfc_get_element_type (TREE_TYPE (desc));
+ tmp = TREE_OPERAND (desc, 0);
+ tmp = gfc_get_class_array_ref (offset, tmp);
+ tmp = fold_convert (build_pointer_type (type), tmp);
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ return tmp;
+ }
+
+ tmp = gfc_conv_array_data (desc);
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = gfc_build_array_ref (tmp, offset, decl);
+ return tmp;
+}
+
+
/* Build an array reference. se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component
reference. For arrays which do not have a descriptor, se->expr will be
tmp = tmpse.expr;
}
- cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
indexse.expr, tmp);
asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
"below lower bound of %%ld", n+1, sym->name);
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
- /* Access the calculated element. */
- tmp = gfc_conv_array_data (se->expr);
- tmp = build_fold_indirect_ref (tmp);
- se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
+ se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
}
/* Fall through to supply start and stride. */
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
+ {
+ gfc_expr *arg;
+
+ /* This is the variant without DIM=... */
+ gcc_assert (expr->value.function.actual->next->expr == NULL);
+
+ arg = expr->value.function.actual->expr;
+ if (arg->rank == -1)
+ {
+ gfc_se se;
+ tree rank, tmp;
+
+ /* The rank (hence the return value's shape) is unknown,
+ we have to retrieve it. */
+ gfc_init_se (&se, NULL);
+ se.descriptor_only = 1;
+ gfc_conv_expr (&se, arg);
+ /* This is a bare variable, so there is no preliminary
+ or cleanup code. */
+ gcc_assert (se.pre.head == NULL_TREE
+ && se.post.head == NULL_TREE);
+ rank = gfc_conv_descriptor_rank (se.expr);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type,
+ rank),
+ gfc_index_one_node);
+ info->end[0] = gfc_evaluate_now (tmp, &loop->pre);
+ info->start[0] = gfc_index_zero_node;
+ info->stride[0] = gfc_index_one_node;
+ continue;
+ }
+ /* Otherwise fall through GFC_SS_FUNCTION. */
+ }
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_THIS_IMAGE:
stride_pos, stride_neg);
/* Check the start of the range against the lower and upper
- bounds of the array, if the range is not empty.
- If upper bound is present, include both bounds in the
+ bounds of the array, if the range is not empty.
+ If upper bound is present, include both bounds in the
error message. */
if (check_upper)
{
fold_convert (long_integer_type_node, lbound));
free (msg);
}
-
+
/* Compute the last element of the range, which is not
necessarily "end" (think 0:5:3, which doesn't contain 5)
and check it against both lower and upper bounds. */
gfc_trans_runtime_check (true, false, tmp2, &inner,
expr_loc, msg,
fold_convert (long_integer_type_node, tmp),
- fold_convert (long_integer_type_node, ubound),
+ fold_convert (long_integer_type_node, ubound),
fold_convert (long_integer_type_node, lbound));
gfc_trans_runtime_check (true, false, tmp3, &inner,
expr_loc, msg,
fold_convert (long_integer_type_node, tmp),
- fold_convert (long_integer_type_node, ubound),
+ fold_convert (long_integer_type_node, ubound),
fold_convert (long_integer_type_node, lbound));
free (msg);
}
/* Browse through each array's information from the scalarizer and set the loop
bounds according to the "best" one (per dimension), i.e. the one which
- provides the most information (constant bounds, shape, etc). */
+ provides the most information (constant bounds, shape, etc.). */
static void
set_loop_bounds (gfc_loopinfo *loop)
bool dynamic[GFC_MAX_DIMENSIONS];
mpz_t *cshape;
mpz_t i;
+ bool nonoptional_arr;
loopspec = loop->specloop;
{
loopspec[n] = NULL;
dynamic[n] = false;
+
+ /* If there are both optional and nonoptional array arguments, scalarize
+ over the nonoptional; otherwise, it does not matter as then all
+ (optional) arrays have to be present per F2008, 125.2.12p3(6). */
+
+ nonoptional_arr = false;
+
+ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
+ if (ss->info->type != GFC_SS_SCALAR && ss->info->type != GFC_SS_TEMP
+ && ss->info->type != GFC_SS_REFERENCE && !ss->info->can_be_null_ref)
+ nonoptional_arr = true;
+
/* We use one SS term, and use that to determine the bounds of the
loop for this dimension. We try to pick the simplest term. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
ss_type = ss->info->type;
if (ss_type == GFC_SS_SCALAR
|| ss_type == GFC_SS_TEMP
- || ss_type == GFC_SS_REFERENCE)
+ || ss_type == GFC_SS_REFERENCE
+ || (ss->info->can_be_null_ref && nonoptional_arr))
continue;
info = &ss->info->data.array;
}
else
{
- /* Silence unitialized warnings. */
+ /* Silence uninitialized warnings. */
specinfo = NULL;
spec_dim = 0;
}
continue;
}
- /* TODO: Pick the best bound if we have a choice between a
- function and something else. */
- if (ss_type == GFC_SS_FUNCTION)
- {
- loopspec[n] = ss;
- continue;
- }
-
/* Avoid using an allocatable lhs in an assignment, since
there might be a reallocation coming. */
if (loopspec[n] && ss->is_alloc_lhs)
continue;
- if (ss_type != GFC_SS_SECTION)
- continue;
-
if (!loopspec[n])
loopspec[n] = ss;
/* Criteria for choosing a loop specifier (most important first):
known lower bound
known upper bound
*/
- else if ((loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
- || n >= loop->dimen)
+ else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n])
loopspec[n] = ss;
else if (integer_onep (info->stride[dim])
&& !integer_onep (specinfo->stride[spec_dim]))
&& !INTEGER_CST_P (specinfo->stride[spec_dim]))
loopspec[n] = ss;
else if (INTEGER_CST_P (info->start[dim])
- && !INTEGER_CST_P (specinfo->start[spec_dim]))
+ && !INTEGER_CST_P (specinfo->start[spec_dim])
+ && integer_onep (info->stride[dim])
+ == integer_onep (specinfo->stride[spec_dim])
+ && INTEGER_CST_P (info->stride[dim])
+ == INTEGER_CST_P (specinfo->stride[spec_dim]))
loopspec[n] = ss;
/* We don't work out the upper bound.
else if (INTEGER_CST_P (info->finish[n])
gcc_assert (loop->to[n] == NULL_TREE);
break;
+ case GFC_SS_INTRINSIC:
+ {
+ gfc_expr *expr = loopspec[n]->info->expr;
+
+ /* The {l,u}bound of an assumed rank. */
+ gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
+ || expr->value.function.isym->id == GFC_ISYM_UBOUND)
+ && expr->value.function.actual->next->expr == NULL
+ && expr->value.function.actual->expr->rank == -1);
+
+ loop->to[n] = info->end[dim];
+ break;
+ }
+
default:
gcc_unreachable ();
}
ubound = lower[n];
}
}
- gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
conv_lbound = se.expr;
/* Check whether multiplying the stride by the number of
elements in this dimension would overflow. We must also check
whether the current dimension has zero size in order to avoid
- division by zero.
+ division by zero.
*/
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_array_index_type,
- fold_convert (gfc_array_index_type,
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type,
TYPE_MAX_VALUE (gfc_array_index_type)),
size);
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
*overflow, tmp);
*overflow = gfc_evaluate_now (tmp, pblock);
-
+
/* Multiply the stride by the number of elements in this dimension. */
stride = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, stride, size);
ubound = lower[n];
}
}
- gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
if (n < rank + corank - 1)
}
/* The stride is the number of elements in the array, so multiply by the
- size of an element to get the total size. Obviously, if there ia a
+ size of an element to get the total size. Obviously, if there is a
SOURCE expression (expr3) we must use its element size. */
if (expr3_elem_size != NULL_TREE)
tmp = expr3_elem_size;
/* First check for overflow. Since an array of type character can
have zero element_size, we must check for that before
dividing. */
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
size_type_node,
TYPE_MAX_VALUE (size_type_node), element_size);
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
{
cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, var_overflow, integer_zero_node));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
error, gfc_finish_block (&elseblock));
}
else
if (expr->ts.type == BT_CLASS)
{
tmp = build_int_cst (unsigned_char_type_node, 0);
- /* With class objects, it is best to play safe and null the
+ /* With class objects, it is best to play safe and null the
memory because we cannot know if dynamic types have allocatable
components or not. */
tmp = build_call_expr_loc (input_location,
/* Update the array descriptors. */
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
-
+
set_descriptor = gfc_finish_block (&set_descriptor_block);
if (status != NULL_TREE)
{
gfc_add_expr_to_block (&se->pre,
fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_likely (cond), set_descriptor,
- build_empty_stmt (input_location)));
+ build_empty_stmt (input_location)));
}
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
HOST_WIDE_INT hi;
unsigned HOST_WIDE_INT lo;
tree index, range;
- VEC(constructor_elt,gc) *v = NULL;
+ vec<constructor_elt, va_gc> *v = NULL;
if (expr->expr_type == EXPR_VARIABLE
&& expr->symtree->n.sym->attr.flavor == FL_PARAMETER
/* A single scalar or derived type value. Create an array with all
elements equal to that value. */
gfc_init_se (&se, NULL);
-
+
if (expr->expr_type == EXPR_CONSTANT)
gfc_conv_constant (&se, expr);
else
tmp = gfc_conv_expr_present (sym);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
}
-
+
gfc_add_init_cleanup (block, stmt, NULL_TREE);
}
asprintf (&msg, "Dimension %d of array '%s' has extent "
"%%ld instead of %%ld", n+1, sym->name);
- gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
+ gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
fold_convert (long_integer_type_node, temp),
fold_convert (long_integer_type_node, stride2));
gfc_add_expr_to_block (&cleanup, tmp);
stmtCleanup = gfc_finish_block (&cleanup);
-
+
/* Only do the cleanup if the array was repacked. */
tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
tmp = gfc_conv_descriptor_data_get (tmp);
return;
}
- tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref_loc (input_location,
- tmp);
- tmp = gfc_build_array_ref (tmp, offset, NULL);
+ tmp = build_array_ref (desc, offset, NULL);
/* Offset the data pointer for pointer assignments from arrays with
subreferences; e.g. my_integer => my_type(:)%integer_component. */
/* Map expressions involving the dummy arguments onto the actual
argument expressions. */
gfc_init_interface_mapping (&mapping);
- formal = expr->symtree->n.sym->formal;
+ formal = gfc_sym_get_dummy_args (expr->symtree->n.sym);
arg = expr->value.function.actual;
/* Set se = NULL in the calls to the interface mapping, to suppress any
return false;
}
+
+/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
+ AR_FULL, suitable for the scalarizer. */
+
+static gfc_ss *
+walk_coarray (gfc_expr *e)
+{
+ gfc_ss *ss;
+
+ gcc_assert (gfc_get_corank (e) > 0);
+
+ ss = gfc_walk_expr (e);
+
+ /* Fix scalar coarray. */
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_ref *ref;
+
+ ref = e->ref;
+ while (ref)
+ {
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.codimen > 0)
+ break;
+
+ ref = ref->next;
+ }
+
+ gcc_assert (ref != NULL);
+ if (ref->u.ar.type == AR_ELEMENT)
+ ref->u.ar.type = AR_SECTION;
+ ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
+ }
+
+ return ss;
+}
+
+
/* 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
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
- EXPR to se->expr.
+ EXPR to se->expr.
The se->force_tmp flag disables the non-copying descriptor optimization
function call. */
void
-gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
+gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
{
+ gfc_ss *ss;
gfc_ss_type ss_type;
gfc_ss_info *ss_info;
gfc_loopinfo loop;
bool subref_array_target = false;
gfc_expr *arg, *ss_expr;
+ if (se->want_coarray)
+ ss = walk_coarray (expr);
+ else
+ ss = gfc_walk_expr (expr);
+
gcc_assert (ss != NULL);
gcc_assert (ss != gfc_ss_terminator);
ss_type = ss_info->type;
ss_expr = ss_info->expr;
+ /* Special case: TRANSPOSE which needs no temporary. */
+ while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym
+ && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr)))
+ {
+ /* This is a call to transpose which has already been handled by the
+ scalarizer, so that we just need to get its argument's descriptor. */
+ gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+ expr = expr->value.function.actual->expr;
+ }
+
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
/* Create a new descriptor if the array doesn't have one. */
full = 0;
}
- else if (info->ref->u.ar.type == AR_FULL)
+ else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
full = 1;
else if (se->direct_byref)
full = 0;
if (expr->ts.type == BT_CHARACTER)
se->string_length = gfc_get_expr_charlen (expr);
+ gfc_free_ss_chain (ss);
return;
}
break;
-
- case EXPR_FUNCTION:
-
- /* We don't need to copy data in some cases. */
- arg = gfc_get_noncopying_intrinsic_argument (expr);
- if (arg)
- {
- /* This is a call to transpose... */
- gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
- /* ... which has already been handled by the scalarizer, so
- that we just need to get its argument's descriptor. */
- gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss);
- return;
- }
+ case EXPR_FUNCTION:
/* A transformational function return value will be a temporary
array descriptor. We still need to go through the scalarizer
- to create the descriptor. Elemental functions ar handled as
+ to create the descriptor. Elemental functions are handled as
arbitrary expressions, i.e. copy to a temporary. */
if (se->direct_byref)
gcc_assert (se->ss == ss);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
gfc_conv_expr (se, expr);
+ gfc_free_ss_chain (ss);
return;
}
/* Vector subscripts need copying and are handled elsewhere. */
if (info->ref)
gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
-
+
/* look for the corresponding scalarizer dimension: dim. */
for (dim = 0; dim < ndim; dim++)
if (ss->dim[dim] == n)
/* TODO: Optimize passing g77 arrays. */
void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
const gfc_symbol *fsym, const char *proc_name,
tree *size)
{
se->string_length = sym->ts.u.cl->backend_decl;
if (!sym->attr.pointer
- && sym->as
- && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_RANK
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
{
if (sym->attr.dummy || sym->attr.result)
{
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
tmp = se->expr;
}
if (size)
no_pack = ((sym && sym->as
&& !sym->attr.pointer
&& sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_RANK
&& sym->as->type != AS_ASSUMED_SHAPE)
||
(ref && ref->u.ar.as
&& ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_RANK
&& ref->u.ar.as->type != AS_ASSUMED_SHAPE)
||
gfc_is_simply_contiguous (expr, false));
&& expr->symtree->n.sym->attr.allocatable;
/* Or ultimate allocatable components. */
- ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
+ ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
{
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
if (expr->ts.type == BT_CHARACTER)
se->string_length = expr->ts.u.cl->backend_decl;
if (size)
if (this_array_result)
{
/* Result of the enclosing function. */
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
if (size)
array_parameter_size (se->expr, expr, size);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
{
/* Every other type of array. */
se->want_pointer = 1;
- gfc_conv_expr_descriptor (se, expr, ss);
+ gfc_conv_expr_descriptor (se, expr);
if (size)
array_parameter_size (build_fold_indirect_ref_loc (input_location,
se->expr),
tree
gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
-{
+{
tree tmp;
tree var;
stmtblock_t block;
}
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
- tmp = build_call_expr_loc (input_location, tmp, 3,
- dest, src, size);
+ tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+ fold_convert (size_type_node, size));
}
else
{
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location,
tmp, 3, gfc_conv_descriptor_data_get (dest),
- gfc_conv_descriptor_data_get (src), size);
+ gfc_conv_descriptor_data_get (src),
+ fold_convert (size_type_node, size));
}
gfc_add_expr_to_block (&block, tmp);
if ((POINTER_TYPE_P (decl_type) && rank != 0)
|| (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
-
- decl = build_fold_indirect_ref_loc (input_location,
- decl);
+ decl = build_fold_indirect_ref_loc (input_location, decl);
/* Just in case in gets dereferenced. */
decl_type = TREE_TYPE (decl);
/* If this an array of derived types with allocatable components
build a loop and recursively call this function. */
if (TREE_CODE (decl_type) == ARRAY_TYPE
- || GFC_DESCRIPTOR_TYPE_P (decl_type))
+ || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
{
tmp = gfc_conv_array_data (decl);
var = build_fold_indirect_ref_loc (input_location,
tmp);
-
+
/* Get the number of elements - 1 and set the counter. */
if (GFC_DESCRIPTOR_TYPE_P (decl_type))
{
case DEALLOCATE_ALLOC_COMP:
/* gfc_deallocate_scalar_with_status calls gfc_deallocate_alloc_comp
- (ie. this function) so generate all the calls and suppress the
+ (i.e. this function) so generate all the calls and suppress the
recursion from here, if necessary. */
called_dealloc_with_status = false;
gfc_init_block (&tmpblock);
/* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
-
+
/* Add reference to '_data' component. */
tmp = CLASS_DATA (c)->backend_decl;
comp = fold_build3_loc (input_location, COMPONENT_REF,
CLASS_DATA (c)->attr.codimension);
else
{
- tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
+ tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
CLASS_DATA (c)->ts);
gfc_add_expr_to_block (&tmpblock, tmp);
called_dealloc_with_status = true;
null_cond = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, src_data,
- null_pointer_node);
+ null_pointer_node);
gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
tmp, null_data));
tree lbound;
tree ubound;
tree desc;
+ tree old_desc;
tree desc2;
tree offset;
tree jump_label1;
as = NULL;
/* If the lhs shape is not the same as the rhs jump to setting the
- bounds and doing the reallocation....... */
+ bounds and doing the reallocation....... */
for (n = 0; n < expr1->rank; n++)
{
/* Check the shape. */
tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
- gfc_add_expr_to_block (&fblock, tmp);
+ gfc_add_expr_to_block (&fblock, tmp);
}
/* ....else jump past the (re)alloc code. */
tmp = build1_v (GOTO_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
-
+
/* Add the label to start automatic (re)allocation. */
tmp = build1_v (LABEL_EXPR, jump_label1);
gfc_add_expr_to_block (&fblock, tmp);
size1, size2);
neq_size = gfc_evaluate_now (cond, &fblock);
+ /* Deallocation of allocatable components will have to occur on
+ reallocation. Fix the old descriptor now. */
+ if ((expr1->ts.type == BT_DERIVED)
+ && expr1->ts.u.derived->attr.alloc_comp)
+ old_desc = gfc_evaluate_now (desc, &fblock);
+ else
+ old_desc = NULL_TREE;
/* Now modify the lhs descriptor and the associated scalarizer
variables. F2003 7.4.1.3: "If variable is or becomes an
unallocated allocatable variable, then it is allocated with each
deferred type parameter equal to the corresponding type parameters
of expr , with the shape of expr , and with each lower bound equal
- to the corresponding element of LBOUND(expr)."
+ to the corresponding element of LBOUND(expr)."
Reuse size1 to keep a dimension-by-dimension track of the
stride of the new array. */
size1 = gfc_index_one_node;
/* Realloc expression. Note that the scalarizer uses desc.data
in the array reference - (*desc.data)[<element>]. */
gfc_init_block (&realloc_block);
+
+ if ((expr1->ts.type == BT_DERIVED)
+ && expr1->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, old_desc,
+ expr1->rank);
+ gfc_add_expr_to_block (&realloc_block, tmp);
+ }
+
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_REALLOC), 2,
fold_convert (pvoid_type_node, array1),
size2);
gfc_conv_descriptor_data_set (&realloc_block,
desc, tmp);
+
+ if ((expr1->ts.type == BT_DERIVED)
+ && expr1->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+ expr1->rank);
+ gfc_add_expr_to_block (&realloc_block, tmp);
+ }
+
realloc_expr = gfc_finish_block (&realloc_block);
/* Only reallocate if sizes are different. */
desc, tmp);
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ if ((expr1->ts.type == BT_DERIVED)
+ && expr1->ts.u.derived->attr.alloc_comp)
+ {
+ tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+ expr1->rank);
+ gfc_add_expr_to_block (&alloc_block, tmp);
+ }
alloc_expr = gfc_finish_block (&alloc_block);
/* Malloc if not allocated; realloc otherwise. */
sym->backend_decl);
type = TREE_TYPE (descriptor);
}
-
+
/* NULLIFY the data pointer. */
if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
}
-/* Given an expression refering to a procedure, return the symbol of its
+/* Given an expression referring to a procedure, return the symbol of its
interface. We can't get the procedure symbol directly as we have to handle
the case of (deferred) type-bound procedures. */
tail = NULL;
if (proc_ifc)
- dummy_arg = proc_ifc->formal;
+ dummy_arg = gfc_sym_get_dummy_args (proc_ifc);
else
dummy_arg = NULL;
newss = gfc_get_scalar_ss (head, arg->expr);
newss->info->type = type;
- if (dummy_arg != NULL
- && dummy_arg->sym->attr.optional
- && arg->expr->expr_type == EXPR_VARIABLE
- && (gfc_expr_attr (arg->expr).optional
- || gfc_expr_attr (arg->expr).allocatable
- || gfc_expr_attr (arg->expr).pointer))
- newss->info->data.scalar.can_be_null_ref = true;
}
else
scalar = 0;
+ if (dummy_arg != NULL
+ && dummy_arg->sym->attr.optional
+ && arg->expr->expr_type == EXPR_VARIABLE
+ && (gfc_expr_attr (arg->expr).optional
+ || gfc_expr_attr (arg->expr).allocatable
+ || gfc_expr_attr (arg->expr).pointer))
+ newss->info->can_be_null_ref = true;
+
head = newss;
if (!tail)
{
sym = expr->symtree->n.sym;
/* A function that returns arrays. */
- gfc_is_proc_ptr_comp (expr, &comp);
+ comp = gfc_get_proc_ptr_comp (expr);
if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
|| (comp && comp->attr.dimension))
return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
projects / platform / upstream / gcc48.git / blobdiff