/* 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, 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);
+ /* 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 (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;
- 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);
+ {
+ /* 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] = gfc_index_zero_node;
}
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);
/* 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);
/* 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_trans_array_constructor (loop, ss);
break;
+ case GFC_SS_TEMP:
+ /* Do nothing. This will be handled later. */
+ break;
+
default:
abort ();
}
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
+ functions and something else. */
+ if (ss->type == GFC_SS_FUNCTION)
+ {
+ loopspec[n] = ss;
+ continue;
+ }
+
if (ss->type != GFC_SS_SECTION)
continue;
&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 ();
}
}
}
+ /* 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;
int checkparm;
int no_repack;
+ /* 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);
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->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. */
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;
- /* set the string_length for a character array. */
+ /* 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;
- /* Otherwise make a new descriptor and point it at the section we
- want. The loop variable limits will be the limits of the section.
- */
desc = info->descriptor;
assert (secss && secss != gfc_ss_terminator);
if (se->direct_byref)
TREE_SIDE_EFFECTS (se->expr) = 1;
#endif
- if (byref && !se->direct_byref)
+ if (byref)
{
+ /* Add the function call to the pre chain. There is no expression. */
gfc_add_expr_to_block (&se->pre, se->expr);
+ se->expr = NULL_TREE;
- if (sym->result->attr.dimension)
+ if (!se->direct_byref)
{
- if (flag_bounds_check)
+ if (sym->result->attr.dimension)
{
- /* Check the data pointer hasn't been modified. This would happen
- in a function returning a pointer. */
- tmp = gfc_conv_descriptor_data (info->descriptor);
- tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
- gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+ if (flag_bounds_check)
+ {
+ /* Check the data pointer hasn't been modified. This would
+ happen in a function returning a pointer. */
+ tmp = gfc_conv_descriptor_data (info->descriptor);
+ tmp = build (NE_EXPR, boolean_type_node, tmp, info->data);
+ gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
+ }
+ se->expr = info->descriptor;
}
- se->expr = info->descriptor;
- }
- else if (sym->ts.type == BT_CHARACTER)
- {
- se->expr = var;
- se->string_length = len;
+ else if (sym->ts.type == BT_CHARACTER)
+ {
+ se->expr = var;
+ se->string_length = len;
+ }
+ else
+ abort ();
}
- else
- abort ();
}
}
}
+/* Generate code for a pointer assignment. */
+
tree
gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
rss = gfc_walk_expr (expr2);
if (lss == gfc_ss_terminator)
{
+ /* Scalar pointers. */
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
assert (rss == gfc_ss_terminator);
}
else
{
+ /* Array pointer. */
gfc_conv_expr_descriptor (&lse, expr1, lss);
/* Implement Nullify. */
if (expr2->expr_type == EXPR_NULL)
se.ss = gfc_walk_expr (expr2);
assert (se.ss != gfc_ss_terminator);
gfc_conv_function_expr (&se, expr2);
- gfc_add_expr_to_block (&se.pre, se.expr);
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
--- /dev/null
+! { dg-do run }
+! Test functions returning arrays of indeterminate size.
+program ret_array_1
+ integer, dimension(:, :), allocatable :: a
+ integer, dimension(2) :: b
+
+ allocate (a(2, 3))
+ a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/))
+
+ ! Using the return value as an actual argument
+ b = 0;
+ b = sum (transpose (a), 1);
+ if (any (b .ne. (/9, 12/))) call abort ()
+
+ ! Using the return value in an expression
+ b = 0;
+ b = sum (transpose (a) + 1, 1);
+ if (any (b .ne. (/12, 15/))) call abort ()
+
+ ! Same again testing a user function
+! TODO: enable these once this is implemented
+! b = 0;
+! b = sum (my_transpose (a), 1);
+! if (any (b .ne. (/9, 12/))) call abort ()
+!
+! ! Using the return value in an expression
+! b = 0;
+! b = sum (my_transpose (a) + 1, 1);
+! if (any (b .ne. (/12, 15/))) call abort ()
+contains
+subroutine test(x, n)
+ integer, dimension (:, :) :: x
+ integer n
+
+ if (any (shape (x) .ne. (/3, 2/))) call abort
+ if (any (x .ne. (n + reshape((/1, 4, 2, 5, 3, 6/), (/3, 2/))))) call abort
+end subroutine
+
+function my_transpose (x) result (r)
+ interface
+ pure function obfuscate (i)
+ integer obfuscate
+ integer, intent(in) :: i
+ end function
+ end interface
+ integer, dimension (:, :) :: x
+ integer, dimension (obfuscate(ubound(x, 2)), &
+ obfuscate(ubound(x, 1))) :: r
+ integer i
+
+ do i = 1, ubound(x, 1)
+ r(:, i) = x(i, :)
+ end do
+end function
+end program
+
+pure function obfuscate (i)
+ integer obfuscate
+ integer, intent(in) :: i
+
+ obfuscate = i
+end function
+
projects / gcc.git / commitdiff