&& TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == ARRAY_TYPE);
- return build (COMPONENT_REF, TREE_TYPE (field), desc, field);
+ return build (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
}
tree
field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- return build (COMPONENT_REF, TREE_TYPE (field), desc, field);
+ return build (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
}
tree
field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- return build (COMPONENT_REF, TREE_TYPE (field), desc, field);
+ return build (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 = build (COMPONENT_REF, TREE_TYPE (field), desc, field);
+ tmp = build (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
tmp = gfc_build_array_ref (tmp, dim);
return tmp;
}
field = gfc_advance_chain (field, STRIDE_SUBFIELD);
assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field);
+ tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
return tmp;
}
field = gfc_advance_chain (field, LBOUND_SUBFIELD);
assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field);
+ tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
return tmp;
}
field = gfc_advance_chain (field, UBOUND_SUBFIELD);
assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
- tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field);
+ tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
return tmp;
}
-/* Generate an initializer for a static pointer or allocatable array. */
+/* Build an null array descriptor constructor. */
-void
-gfc_trans_static_array_pointer (gfc_symbol * sym)
+tree
+gfc_build_null_descriptor (tree type)
{
- tree tmp;
tree field;
- tree type;
+ tree tmp;
- assert (TREE_STATIC (sym->backend_decl));
- /* Just zero the data member. */
- type = TREE_TYPE (sym->backend_decl);
assert (GFC_DESCRIPTOR_TYPE_P (type));
assert (DATA_FIELD == 0);
field = TYPE_FIELDS (type);
+ /* Set a NULL data pointer. */
tmp = tree_cons (field, null_pointer_node, NULL_TREE);
tmp = build1 (CONSTRUCTOR, type, tmp);
TREE_CONSTANT (tmp) = 1;
TREE_INVARIANT (tmp) = 1;
- DECL_INITIAL (sym->backend_decl) = tmp;
+ /* All other fields are ignored. */
+
+ return tmp;
}
}
+/* Generate an initializer for a static pointer or allocatable array. */
+
+void
+gfc_trans_static_array_pointer (gfc_symbol * sym)
+{
+ tree type;
+
+ assert (TREE_STATIC (sym->backend_decl));
+ /* Just zero the data member. */
+ type = TREE_TYPE (sym->backend_decl);
+ DECL_INITIAL (sym->backend_decl) =gfc_build_null_descriptor (type);
+}
+
+
/* Generate code to allocate an array temporary, or create a variable to
- hold the data. */
+ hold the data. If size is NULL zero the descriptor so that so that the
+ callee will allocate the array. Also generates code to free the array
+ afterwards. */
static void
gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
desc = info->descriptor;
data = gfc_conv_descriptor_data (desc);
- onstack = gfc_can_put_var_on_stack (size);
- if (onstack)
+ if (size == NULL_TREE)
{
- /* Make a temporary variable to hold the data. */
- tmp = fold (build (MINUS_EXPR, TREE_TYPE (nelem), nelem,
- integer_one_node));
- tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp);
- tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), tmp);
- tmp = gfc_create_var (tmp, "A");
- tmp = gfc_build_addr_expr (TREE_TYPE (data), tmp);
- gfc_add_modify_expr (&loop->pre, data, tmp);
+ /* A callee allocated array. */
+ gfc_add_modify_expr (&loop->pre, data, convert (TREE_TYPE (data),
+ gfc_index_zero_node));
info->data = data;
info->offset = gfc_index_zero_node;
-
+ onstack = FALSE;
}
else
{
- /* Allocate memory to hold the data. */
- args = gfc_chainon_list (NULL_TREE, size);
+ /* Allocate the temporary. */
+ onstack = gfc_can_put_var_on_stack (size);
- if (gfc_index_integer_kind == 4)
- tmp = gfor_fndecl_internal_malloc;
- else if (gfc_index_integer_kind == 8)
- tmp = gfor_fndecl_internal_malloc64;
+ if (onstack)
+ {
+ /* Make a temporary variable to hold the data. */
+ tmp = fold (build (MINUS_EXPR, TREE_TYPE (nelem), nelem,
+ integer_one_node));
+ tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ tmp);
+ tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
+ tmp);
+ tmp = gfc_create_var (tmp, "A");
+ tmp = gfc_build_addr_expr (TREE_TYPE (data), tmp);
+ gfc_add_modify_expr (&loop->pre, data, tmp);
+ info->data = data;
+ info->offset = gfc_index_zero_node;
+
+ }
else
- abort ();
- tmp = gfc_build_function_call (tmp, args);
- tmp = convert (TREE_TYPE (data), tmp);
- gfc_add_modify_expr (&loop->pre, data, tmp);
+ {
+ /* Allocate memory to hold the data. */
+ args = gfc_chainon_list (NULL_TREE, size);
- info->data = data;
- info->offset = gfc_index_zero_node;
+ if (gfc_index_integer_kind == 4)
+ tmp = gfor_fndecl_internal_malloc;
+ else if (gfc_index_integer_kind == 8)
+ tmp = gfor_fndecl_internal_malloc64;
+ else
+ abort ();
+ tmp = gfc_build_function_call (tmp, args);
+ tmp = convert (TREE_TYPE (data), tmp);
+ gfc_add_modify_expr (&loop->pre, data, tmp);
+
+ info->data = data;
+ info->offset = gfc_index_zero_node;
+ }
}
/* The offset is zero because we create temporaries with a zero
/* Generate code to allocate and initialize the descriptor for a temporary
- array. Fills in the descriptor, data and offset fields of info. Also
- adjusts the loop variables to be zero-based. Returns the size of the
- array. */
+ array. This is used for both temporaries needed by the scaparizer, and
+ functions returning arrays. Adjusts the loop variables to be zero-based,
+ and calculates the loop bounds for callee allocated arrays.
+ Also fills in the descriptor, data and offset fields of info if known.
+ Returns the size of the array, or NULL for a callee allocated array. */
tree
gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
assert (integer_zerop (loop->from[n]));
else
{
- loop->to[n] = fold (build (MINUS_EXPR, gfc_array_index_type,
+ /* Callee allocated arrays may not have a known bound yet. */
+ if (loop->to[n])
+ loop->to[n] = fold (build (MINUS_EXPR, gfc_array_index_type,
loop->to[n], loop->from[n]));
- loop->from[n] = integer_zero_node;
+ loop->from[n] = gfc_index_zero_node;
}
- info->delta[dim] = integer_zero_node;
- info->start[dim] = integer_zero_node;
- info->stride[dim] = integer_one_node;
+ info->delta[dim] = gfc_index_zero_node;
+ info->start[dim] = gfc_index_zero_node;
+ info->stride[dim] = gfc_index_one_node;
info->dim[dim] = dim;
}
GFC_DECL_PACKED_ARRAY (desc) = 1;
info->descriptor = desc;
- size = integer_one_node;
+ size = gfc_index_one_node;
/* Fill in the array dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify_expr (&loop->pre, tmp,
GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (desc)));
- /* Fill in the bounds and stride. This is a packed array, so:
+ /*
+ Fill in the bounds and stride. This is a packed array, so:
+
size = 1;
for (n = 0; n < rank; n++)
- {
- stride[n] = size
- delta = ubound[n] + 1 - lbound[n];
- size = size * delta;
- }
- size = size * sizeof(element); */
+ {
+ stride[n] = size
+ delta = ubound[n] + 1 - lbound[n];
+ size = size * delta;
+ }
+ size = size * sizeof(element);
+ */
+
for (n = 0; n < info->dimen; n++)
{
+ if (loop->to[n] == NULL_TREE)
+ {
+ /* For a callee allocated array express the loop bounds in terms
+ of the descriptor fields. */
+ tmp = build (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;
+ }
+
/* Store the stride and bound components in the descriptor. */
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
gfc_add_modify_expr (&loop->pre, tmp, size);
tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
- gfc_add_modify_expr (&loop->pre, tmp, integer_zero_node);
+ gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
- loop->to[n], integer_one_node));
+ loop->to[n], gfc_index_one_node));
size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp));
size = gfc_evaluate_now (size, &loop->pre);
/* Get the size of the array. */
nelem = size;
- size = fold (build (MULT_EXPR, gfc_array_index_type, size,
+ if (size)
+ size = fold (build (MULT_EXPR, gfc_array_index_type, size,
TYPE_SIZE_UNIT (gfc_get_element_type (type))));
gfc_trans_allocate_array_storage (loop, info, size, nelem);
gfc_add_modify_expr (&body, tmp, se.expr);
/* Increment the offset. */
- tmp = build (PLUS_EXPR, gfc_array_index_type, *poffset, integer_one_node);
+ tmp = build (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
gfc_add_modify_expr (&body, *poffset, tmp);
/* Finish the loop. */
ref = gfc_build_indirect_ref (pointer);
ref = gfc_build_array_ref (ref, *poffset);
- gfc_add_modify_expr (&body, ref, se.expr);
+ gfc_add_modify_expr (&body, ref,
+ fold_convert (TREE_TYPE (ref), se.expr));
gfc_add_block_to_block (&body, &se.post);
*poffset = fold (build (PLUS_EXPR, gfc_array_index_type,
- *poffset, integer_one_node));
+ *poffset, gfc_index_one_node));
}
else
{
p = p->next;
}
- bound = build_int_2 (n - 1, 0);
+ bound = build_int_cst (NULL_TREE, n - 1, 0);
/* Create an array type to hold them. */
tmptype = build_range_type (gfc_array_index_type,
- integer_zero_node, bound);
+ gfc_index_zero_node, bound);
tmptype = build_array_type (type, tmptype);
init = build1 (CONSTRUCTOR, tmptype, nreverse (list));
init = gfc_build_addr_expr (NULL, init);
size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
- bound = build_int_2 (n * size, 0);
+ bound = build_int_cst (NULL_TREE, n * size, 0);
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_chainon_list (tmp, init);
tmp = gfc_chainon_list (tmp, bound);
gfc_trans_allocate_temp_array (loop, &ss->data.info, type, NULL_TREE);
desc = ss->data.info.descriptor;
- offset = integer_zero_node;
+ offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
TREE_USED (offsetvar) = 0;
gfc_trans_array_constructor_value (&loop->pre, type,
else
assert (INTEGER_CST_P (offset));
#if 0
- /* Disable bound checking for now cause it's probably broken. */
+ /* Disable bound checking for now because it's probably broken. */
if (flag_bounds_check)
{
abort ();
/* Add the pre and post chains for all the scalar expressions in a SS chain
to loop. This is called after the loop parameters have been calculated,
but before the actual scalarizing loops. */
-/*GCC ARRAYS*/
static void
gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
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. */
assert (ss != NULL);
for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
gfc_trans_array_constructor (loop, ss);
break;
+ case GFC_SS_TEMP:
+ case GFC_SS_COMPONENT:
+ /* Do nothing. These are handled elsewhere. */
+ break;
+
default:
abort ();
}
/* This should only ever happen when passing an assumed shape array
as an actual parameter. The value will never be used. */
if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
- return integer_zero_node;
+ return gfc_index_zero_node;
tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
return tmp;
}
else
{
- /* Temporary array. */
+ /* Temporary array or derived type component. */
assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]];
+ if (!integer_zerop (info->delta[i]))
+ index = fold (build (PLUS_EXPR, gfc_array_index_type, index,
+ info->delta[i]));
}
/* Multiply by the stride. */
return;
}
- index = integer_zero_node;
+ index = gfc_index_zero_node;
- fault = integer_zero_node;
+ fault = gfc_index_zero_node;
/* Calculate the offsets from all the dimensions. */
for (n = 0; n < ar->dimen; n++)
continue;
if (ss->type != GFC_SS_SECTION
- && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR)
+ && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
+ && ss->type != GFC_SS_COMPONENT)
continue;
info = &ss->data.info;
/* Increment the loopvar. */
tmp = build (PLUS_EXPR, gfc_array_index_type,
- loop->loopvar[n], integer_one_node);
+ loop->loopvar[n], gfc_index_one_node);
gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
/* Build the loop. */
continue;
if (ss->type != GFC_SS_SECTION
- && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR)
+ && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
+ && ss->type != GFC_SS_COMPONENT)
continue;
ss->data.info.offset = ss->data.info.saved_offset;
/* Calculate the stride. */
if (stride == NULL)
- info->stride[n] = integer_one_node;
+ info->stride[n] = gfc_index_one_node;
else
{
gfc_init_se (&se, NULL);
case GFC_SS_SECTION:
case GFC_SS_CONSTRUCTOR:
case GFC_SS_FUNCTION:
+ case GFC_SS_COMPONENT:
loop->dimen = ss->data.info.dimen;
break;
/* Loop over all the SS in the chain. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
+ if (ss->expr && ss->expr->shape && !ss->shape)
+ ss->shape = ss->expr->shape;
+
switch (ss->type)
{
case GFC_SS_SECTION:
case GFC_SS_FUNCTION:
for (n = 0; n < ss->data.info.dimen; n++)
{
- ss->data.info.start[n] = integer_zero_node;
- ss->data.info.stride[n] = integer_one_node;
+ ss->data.info.start[n] = gfc_index_zero_node;
+ ss->data.info.stride[n] = gfc_index_one_node;
}
break;
loop for this dimension. We try to pick the simplest term. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
- if (ss->expr && ss->expr->shape)
+ if (ss->shape)
{
/* The frontend has worked out the size for us. */
loopspec[n] = ss;
if (ss->type == GFC_SS_CONSTRUCTOR)
{
+ /* An unknown size constructor will always be rank one.
+ Higher rank constructors will wither have known shape,
+ or still be wrapped in a call to reshape. */
+ assert (loop->dimen == 1);
/* Try to figure out the size of the constructor. */
/* TODO: avoid this by making the frontend set the shape. */
gfc_get_array_cons_size (&i, ss->expr->value.constructor);
continue;
}
- /* We don't know how to handle functions yet.
- This may not be possible in all cases. */
+ /* 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;
+ }
+
if (ss->type != GFC_SS_SECTION)
continue;
- info = &ss->data.info;
-
if (loopspec[n])
specinfo = &loopspec[n]->data.info;
else
*/
if (!specinfo)
loopspec[n] = ss;
+ /* TODO: Is != contructor correct? */
else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
{
if (integer_onep (info->stride[n])
info = &loopspec[n]->data.info;
/* Set the extents of this range. */
- cshape = loopspec[n]->expr->shape;
+ cshape = loopspec[n]->shape;
if (cshape && INTEGER_CST_P (info->start[n])
&& INTEGER_CST_P (info->stride[n]))
{
{
case GFC_SS_CONSTRUCTOR:
assert (info->dimen == 1);
- assert (loop->to[n]);
+ assert (loop->to[n]);
break;
case GFC_SS_SECTION:
&loop->pre);
break;
+ case GFC_SS_FUNCTION:
+ /* The loop bound will be set when we generate the call. */
+ assert (loop->to[n] == NULL_TREE);
+ break;
+
default:
abort ();
}
/* Transform everything so we have a simple incrementing variable. */
if (integer_onep (info->stride[n]))
- info->delta[n] = integer_zero_node;
+ info->delta[n] = gfc_index_zero_node;
else
{
/* Set the delta for this section. */
info->stride[n]));
loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
/* Make the loop variable start at 0. */
- loop->from[n] = integer_zero_node;
+ 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);
+
/* If we want a temporary then create it. */
if (loop->temp_ss != NULL)
{
tmp, len);
}
- /* Add all the scalar code that can be taken out of the loops. */
- gfc_add_loop_ss_code (loop, loop->ss, false);
-
for (n = 0; n < loop->temp_dim; n++)
loopspec[loop->order[n]] = NULL;
/* 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)
+ if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
continue;
info = &ss->data.info;
{
dim = info->dim[n];
- /* If we are specifying the range the delta may already be set. */
+ /* If we are specifying the range the delta is already set. */
if (loopspec[n] != ss)
{
/* Calculate the offset relative to the loop variable.
type = TREE_TYPE (descriptor);
- stride = integer_one_node;
- offset = integer_zero_node;
+ stride = gfc_index_one_node;
+ offset = gfc_index_zero_node;
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
/* Set lower bound. */
gfc_init_se (&se, NULL);
if (lower == NULL)
- se.expr = integer_one_node;
+ se.expr = gfc_index_one_node;
else
{
assert (lower[n]);
}
else
{
- se.expr = integer_one_node;
+ se.expr = gfc_index_one_node;
ubound = lower[n];
}
}
/* Start the calculation for the size of this dimension. */
size = build (MINUS_EXPR, gfc_array_index_type,
- integer_one_node, se.expr);
+ gfc_index_one_node, se.expr);
/* Set upper bound. */
gfc_init_se (&se, NULL);
/* A single scalar or derived type value. Create an array with all
elements equal to that value. */
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, expr);
+
+ if (expr->expr_type == EXPR_CONSTANT)
+ gfc_conv_constant (&se, expr);
+ else
+ gfc_conv_structure (&se, expr, 1);
tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
assert (tmp && INTEGER_CST_P (tmp));
as = sym->as;
- size = integer_one_node;
- offset = integer_zero_node;
+ size = gfc_index_one_node;
+ offset = gfc_index_zero_node;
for (dim = 0; dim < as->rank; dim++)
{
/* Evaluate non-constant array bound expressions. */
{
/* Calculate stride = size * (ubound + 1 - lbound). */
tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
- integer_one_node, lbound));
+ gfc_index_one_node, lbound));
tmp = fold (build (PLUS_EXPR, gfc_array_index_type, ubound, tmp));
tmp = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp));
if (stride)
tree fndecl;
tree size;
tree offset;
- tree args;
bool onstack;
assert (!(sym->attr.pointer || sym->attr.allocatable));
assert (GFC_ARRAY_TYPE_P (type));
onstack = TREE_CODE (type) != POINTER_TYPE;
- /* We never generate initialization code of module variables. */
- if (fnbody == NULL_TREE)
- {
- assert (onstack);
-
- /* Generate static initializer. */
- if (sym->value)
- {
- DECL_INITIAL (decl) =
- gfc_conv_array_initializer (TREE_TYPE (decl), sym->value);
- }
- return fnbody;
- }
-
gfc_start_block (&block);
/* Evaluate character string length. */
{
gfc_trans_init_string_length (sym->ts.cl, &block);
- DECL_DEFER_OUTPUT (decl) = 1;
-
- /* Generate code to allocate the automatic variable. It will be
- freed automatically. */
- tmp = gfc_build_addr_expr (NULL, decl);
- args = gfc_chainon_list (NULL_TREE, tmp);
- args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
- tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC],
- args);
+ /* Emit a DECL_EXPR for this variable, which will cause the
+ gimplifier to allocate stoage, and all that good stuff. */
+ tmp = build (DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&block, tmp);
}
if (onstack)
{
- if (sym->value)
- {
- DECL_INITIAL (decl) =
- gfc_conv_array_initializer (TREE_TYPE (decl), sym->value);
- }
-
gfc_add_expr_to_block (&block, fnbody);
return gfc_finish_block (&block);
}
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
- && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
gfc_trans_init_string_length (sym->ts.cl, &block);
/* Evaluate the bounds of the array. */
int n;
int checkparm;
int no_repack;
+ bool optional_arg;
+
+ /* Do nothing for pointer and allocatable arrays. */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ return body;
if (sym->attr.dummy && gfc_is_nodesc_array (sym))
return gfc_trans_g77_array (sym, body);
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
- && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
gfc_trans_init_string_length (sym->ts.cl, &block);
checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
tmp = build (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
tmp = build (COND_EXPR, gfc_array_index_type, tmp,
- integer_one_node, stride);
+ gfc_index_one_node, stride);
stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
gfc_add_modify_expr (&block, stride, tmp);
tmp = gfc_chainon_list (NULL_TREE, tmp);
stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
- stride = integer_one_node;
+ stride = gfc_index_one_node;
}
/* This is for the case where the array data is used directly without
}
else
tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
- gfc_add_modify_expr (&block, tmpdesc, tmp);
+ gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
- offset = integer_zero_node;
- size = integer_one_node;
+ offset = gfc_index_zero_node;
+ size = gfc_index_one_node;
/* Evaluate the bounds of the array. */
for (n = 0; n < sym->as->rank; n++)
{
/* Calculate stride = size * (ubound + 1 - lbound). */
tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
- integer_one_node, lbound));
+ gfc_index_one_node, lbound));
tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
ubound, tmp));
size = fold (build (MULT_EXPR, gfc_array_index_type,
/* Only do the entry/initialization code if the arg is present. */
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
- if (sym->attr.optional)
+ optional_arg = sym->attr.optional || sym->ns->proc_name->attr.entry_master;
+ if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
tmp = build (NE_EXPR, boolean_type_node, tmp, tmpdesc);
stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
- if (sym->attr.optional)
+ if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
}
-/* Convert an array for passing as an actual parameter. Expressions
- and vector subscripts are evaluated and stored in a teporary, which is then
+/* Convert an array for passing as an actual parameter. 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
a modified copy of the descriptor is passed, but using the original data.
Also used for array pointer assignments by setting se->direct_byref. */
tree start;
tree offset;
int full;
+ gfc_ss *vss;
assert (ss != gfc_ss_terminator);
/* TODO: Pass constant array constructors without a temporary. */
- /* If we have a linear array section, we can pass it directly. Otherwise
- we need to copy it into a temporary. */
- if (expr->expr_type == EXPR_VARIABLE)
+ /* Special case things we know we can pass easily. */
+ switch (expr->expr_type)
{
- gfc_ss *vss;
+ case EXPR_VARIABLE:
+ /* If we have a linear array section, we can pass it directly.
+ Otherwise we need to copy it into a temporary. */
/* Find the SS for the array section. */
secss = ss;
else if (se->want_pointer)
{
/* We pass full arrays directly. This means that pointers and
- allocatable arrays should also work. */
- se->expr = gfc_build_addr_expr (NULL, desc);
+ allocatable arrays should also work. */
+ se->expr = gfc_build_addr_expr (NULL_TREE, desc);
}
else
{
se->expr = desc;
}
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
return;
}
- }
- else
- {
+ break;
+
+ 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
+ arbitary expressions, ie. copy to a temporary. */
+ secss = ss;
+ /* Look for the SS for this function. */
+ while (secss != gfc_ss_terminator
+ && (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
+ secss = secss->next;
+
+ if (se->direct_byref)
+ {
+ assert (secss != gfc_ss_terminator);
+
+ /* For pointer assignments pass the descriptor directly. */
+ se->ss = secss;
+ se->expr = gfc_build_addr_expr (NULL, se->expr);
+ gfc_conv_expr (se, expr);
+ return;
+ }
+
+ if (secss == gfc_ss_terminator)
+ {
+ /* Elemental function. */
+ need_tmp = 1;
+ info = NULL;
+ }
+ else
+ {
+ /* Transformational function. */
+ info = &secss->data.info;
+ need_tmp = 0;
+ }
+ break;
+
+ default:
+ /* Something complicated. Copy it into a temporary. */
need_tmp = 1;
secss = NULL;
info = NULL;
+ break;
}
+
gfc_init_loopinfo (&loop);
/* Associate the SS with the loop. */
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
- loop.temp_ss->data.temp.string_length = NULL;
+ /* Which can hold our string, if present. */
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = loop.temp_ss->data.temp.string_length
+ = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
+ else
+ loop.temp_ss->data.temp.string_length = NULL;
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
/* Set the first stride component to zero to indicate a temporary. */
desc = loop.temp_ss->data.info.descriptor;
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
- gfc_add_modify_expr (&loop.pre, tmp, integer_zero_node);
+ gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
assert (is_gimple_lvalue (desc));
se->expr = gfc_build_addr_expr (NULL, desc);
}
+ else if (expr->expr_type == EXPR_FUNCTION)
+ {
+ desc = info->descriptor;
+
+ if (se->want_pointer)
+ se->expr = gfc_build_addr_expr (NULL_TREE, desc);
+ else
+ se->expr = desc;
+
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
+ }
else
{
- /* We pass sections without copying to a temporary. A function may
- decide to repack the array to speed up access, but we're not
- bothered about that here. */
+ /* We pass sections without copying to a temporary. Make a new
+ descriptor and point it at the section we want. The loop variable
+ limits will be the limits of the section.
+ A function may decide to repack the array to speed up access, but
+ we're not bothered about that here. */
int dim;
tree parm;
tree parmtype;
tree to;
tree base;
- /* Otherwise make a new descriptor and point it at the section we
- want. The loop variable limits will be the limits of the section.
- */
+ /* Set the string_length for a character array. */
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = expr->symtree->n.sym->ts.cl->backend_decl;
+
desc = info->descriptor;
assert (secss && secss != gfc_ss_terminator);
if (se->direct_byref)
parm = gfc_create_var (parmtype, "parm");
}
- offset = integer_zero_node;
+ offset = gfc_index_zero_node;
dim = 0;
/* The following can be somewhat confusing. We have two
gfc_add_modify_expr (&loop.pre, tmp, GFC_TYPE_ARRAY_DTYPE (parmtype));
if (se->direct_byref)
- base = integer_zero_node;
+ base = gfc_index_zero_node;
else
base = NULL_TREE;
if (!integer_onep (from))
{
/* Make sure the new section starts at 1. */
- tmp = fold (build (MINUS_EXPR, TREE_TYPE (from),
- integer_one_node, from));
- to = fold (build (PLUS_EXPR, TREE_TYPE (to), to, tmp));
- from = integer_one_node;
+ tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, from));
+ to = fold (build (PLUS_EXPR, gfc_array_index_type, to, tmp));
+ from = gfc_index_one_node;
}
tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]);
gfc_add_modify_expr (&loop.pre, tmp, from);
offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
tmp = gfc_conv_descriptor_data (parm);
- gfc_add_modify_expr (&loop.pre, tmp, offset);
+ gfc_add_modify_expr (&loop.pre, tmp,
+ fold_convert (TREE_TYPE (tmp), offset));
if (se->direct_byref)
{
{
sym = expr->symtree->n.sym;
tmp = gfc_get_symbol_decl (sym);
+ if (sym->ts.type == BT_CHARACTER)
+ se->string_length = sym->ts.cl->backend_decl;
if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
&& !sym->attr.allocatable)
{
/* NULLIFY the data pointer. */
tmp = gfc_conv_descriptor_data (descriptor);
- gfc_add_modify_expr (&fnblock, tmp, integer_zero_node);
+ gfc_add_modify_expr (&fnblock, tmp,
+ convert (TREE_TYPE (tmp), integer_zero_node));
gfc_add_expr_to_block (&fnblock, body);
projects / gcc.git / blobdiff