#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "real.h"
#include "flags.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "dependency.h"
static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
static gfc_ss gfc_ss_terminator_var;
gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
static tree
gfc_array_dataptr_type (tree desc)
{
return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
}
#define DATA_FIELD 0
#define OFFSET_FIELD 1
#define DTYPE_FIELD 2
#define DIMENSION_FIELD 3
#define STRIDE_SUBFIELD 0
#define LBOUND_SUBFIELD 1
#define UBOUND_SUBFIELD 2
tree
gfc_conv_descriptor_data (tree desc)
{
tree field;
tree type;
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
field = TYPE_FIELDS (type);
gcc_assert (DATA_FIELD == 0);
gcc_assert (field != NULL_TREE
&& TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == ARRAY_TYPE);
return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
}
tree
gfc_conv_descriptor_offset (tree desc)
{
tree type;
tree field;
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
}
tree
gfc_conv_descriptor_dtype (tree desc)
{
tree field;
tree type;
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
return build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
}
static tree
gfc_conv_descriptor_dimension (tree desc, tree dim)
{
tree field;
tree type;
tree tmp;
type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
gcc_assert (field != NULL_TREE
&& TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), desc, field, NULL_TREE);
tmp = gfc_build_array_ref (tmp, dim);
return tmp;
}
tree
gfc_conv_descriptor_stride (tree desc, tree dim)
{
tree tmp;
tree field;
tmp = gfc_conv_descriptor_dimension (desc, dim);
field = TYPE_FIELDS (TREE_TYPE (tmp));
field = gfc_advance_chain (field, STRIDE_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
return tmp;
}
tree
gfc_conv_descriptor_lbound (tree desc, tree dim)
{
tree tmp;
tree field;
tmp = gfc_conv_descriptor_dimension (desc, dim);
field = TYPE_FIELDS (TREE_TYPE (tmp));
field = gfc_advance_chain (field, LBOUND_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
return tmp;
}
tree
gfc_conv_descriptor_ubound (tree desc, tree dim)
{
tree tmp;
tree field;
tmp = gfc_conv_descriptor_dimension (desc, dim);
field = TYPE_FIELDS (TREE_TYPE (tmp));
field = gfc_advance_chain (field, UBOUND_SUBFIELD);
gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), tmp, field, NULL_TREE);
return tmp;
}
tree
gfc_build_null_descriptor (tree type)
{
tree field;
tree tmp;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
gcc_assert (DATA_FIELD == 0);
field = TYPE_FIELDS (type);
tmp = tree_cons (field, null_pointer_node, NULL_TREE);
tmp = build1 (CONSTRUCTOR, type, tmp);
TREE_CONSTANT (tmp) = 1;
TREE_INVARIANT (tmp) = 1;
return tmp;
}
#undef DATA_FIELD
#undef OFFSET_FIELD
#undef DTYPE_FIELD
#undef DIMENSION_FIELD
#undef STRIDE_SUBFIELD
#undef LBOUND_SUBFIELD
#undef UBOUND_SUBFIELD
void
gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
{
for (; ss != gfc_ss_terminator; ss = ss->next)
ss->useflags = flags;
}
static void gfc_free_ss (gfc_ss *);
static void
gfc_free_ss_chain (gfc_ss * ss)
{
gfc_ss *next;
while (ss != gfc_ss_terminator)
{
gcc_assert (ss != NULL);
next = ss->next;
gfc_free_ss (ss);
ss = next;
}
}
static void
gfc_free_ss (gfc_ss * ss)
{
int n;
switch (ss->type)
{
case GFC_SS_SECTION:
case GFC_SS_VECTOR:
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
{
if (ss->data.info.subscript[n])
gfc_free_ss_chain (ss->data.info.subscript[n]);
}
break;
default:
break;
}
gfc_free (ss);
}
void
gfc_cleanup_loop (gfc_loopinfo * loop)
{
gfc_ss *ss;
gfc_ss *next;
ss = loop->ss;
while (ss != gfc_ss_terminator)
{
gcc_assert (ss != NULL);
next = ss->loop_chain;
gfc_free_ss (ss);
ss = next;
}
}
void
gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
{
gfc_ss *ss;
if (head == gfc_ss_terminator)
return;
ss = head;
for (; ss && ss != gfc_ss_terminator; ss = ss->next)
{
if (ss->next == gfc_ss_terminator)
ss->loop_chain = loop->ss;
else
ss->loop_chain = ss->next;
}
gcc_assert (ss == gfc_ss_terminator);
loop->ss = head;
}
void
gfc_trans_static_array_pointer (gfc_symbol * sym)
{
tree type;
gcc_assert (TREE_STATIC (sym->backend_decl));
type = TREE_TYPE (sym->backend_decl);
DECL_INITIAL (sym->backend_decl) =gfc_build_null_descriptor (type);
}
static void
gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
tree size, tree nelem)
{
tree tmp;
tree args;
tree desc;
tree data;
bool onstack;
desc = info->descriptor;
data = gfc_conv_descriptor_data (desc);
if (size == NULL_TREE)
{
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
{
onstack = gfc_can_put_var_on_stack (size);
if (onstack)
{
tmp = fold (build2 (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
{
args = gfc_chainon_list (NULL_TREE, size);
if (gfc_index_integer_kind == 4)
tmp = gfor_fndecl_internal_malloc;
else if (gfc_index_integer_kind == 8)
tmp = gfor_fndecl_internal_malloc64;
else
gcc_unreachable ();
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;
}
}
tmp = gfc_conv_descriptor_offset (desc);
gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
if (!onstack)
{
tmp = convert (pvoid_type_node, info->data);
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&loop->post, tmp);
}
}
tree
gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
tree eltype)
{
tree type;
tree desc;
tree tmp;
tree size;
tree nelem;
int n;
int dim;
gcc_assert (info->dimen > 0);
for (dim = 0; dim < info->dimen; dim++)
{
n = loop->order[dim];
if (n < loop->temp_dim)
gcc_assert (integer_zerop (loop->from[n]));
else
{
if (loop->to[n])
loop->to[n] = fold (build2 (MINUS_EXPR, gfc_array_index_type,
loop->to[n], loop->from[n]));
loop->from[n] = gfc_index_zero_node;
}
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;
}
type =
gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
info->descriptor = desc;
size = gfc_index_one_node;
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify_expr (&loop->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
for (n = 0; n < info->dimen; n++)
{
if (loop->to[n] == NULL_TREE)
{
tmp = build2 (MINUS_EXPR, gfc_array_index_type,
gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
loop->to[n] = tmp;
size = NULL_TREE;
continue;
}
tmp = 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, 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 (build2 (PLUS_EXPR, gfc_array_index_type,
loop->to[n], gfc_index_one_node));
size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
size = gfc_evaluate_now (size, &loop->pre);
}
nelem = size;
if (size)
size = fold (build2 (MULT_EXPR, gfc_array_index_type, size,
TYPE_SIZE_UNIT (gfc_get_element_type (type))));
gfc_trans_allocate_array_storage (loop, info, size, nelem);
if (info->dimen > loop->temp_dim)
loop->temp_dim = info->dimen;
return size;
}
static void
gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
tree * offsetvar)
{
gcc_assert (*offsetvar != NULL_TREE);
gfc_add_modify_expr (pblock, *offsetvar, *poffset);
*poffset = *offsetvar;
TREE_USED (*offsetvar) = 1;
}
static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
tree args;
gfc_conv_expr (se, expr);
tmp = gfc_build_indirect_ref (pointer);
tmp = gfc_build_array_ref (tmp, offset);
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_string_parameter (se);
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
{
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
gfc_add_modify_expr (&se->pre, tmp, se->expr);
}
else
{
tmp = gfc_build_addr_expr (pchar_type_node, tmp);
args = gfc_chainon_list (NULL_TREE, tmp);
args = gfc_chainon_list (args, se->expr);
args = gfc_chainon_list (args, se->string_length);
tmp = built_in_decls[BUILT_IN_MEMCPY];
tmp = gfc_build_function_call (tmp, args);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
else
{
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
gfc_add_modify_expr (&se->pre, tmp, se->expr);
}
gfc_add_block_to_block (pblock, &se->pre);
gfc_add_block_to_block (pblock, &se->post);
}
static void
gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
tree type ATTRIBUTE_UNUSED,
tree pointer, gfc_expr * expr,
tree * poffset, tree * offsetvar)
{
gfc_se se;
gfc_ss *ss;
gfc_loopinfo loop;
stmtblock_t body;
tree tmp;
gfc_put_offset_into_var (pblock, poffset, offsetvar);
gfc_init_se (&se, NULL);
ss = gfc_walk_expr (expr);
gcc_assert (ss != gfc_ss_terminator);
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
if (expr->ts.type == BT_CHARACTER)
gfc_todo_error ("character arrays in constructors");
gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
gcc_assert (se.ss == gfc_ss_terminator);
tmp = build2 (PLUS_EXPR, gfc_array_index_type, *poffset, gfc_index_one_node);
gfc_add_modify_expr (&body, *poffset, tmp);
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&loop.pre, &loop.post);
tmp = gfc_finish_block (&loop.pre);
gfc_add_expr_to_block (pblock, tmp);
gfc_cleanup_loop (&loop);
}
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
tree pointer, gfc_constructor * c,
tree * poffset, tree * offsetvar)
{
tree tmp;
stmtblock_t body;
tree loopbody;
gfc_se se;
for (; c; c = c->next)
{
if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
gfc_put_offset_into_var (pblock, poffset, offsetvar);
gfc_start_block (&body);
if (c->expr->expr_type == EXPR_ARRAY)
{
gfc_trans_array_constructor_value (&body, type, pointer,
c->expr->value.constructor,
poffset, offsetvar);
}
else if (c->expr->rank > 0)
{
gfc_trans_array_constructor_subarray (&body, type, pointer,
c->expr, poffset, offsetvar);
}
else
{
gfc_constructor *p;
HOST_WIDE_INT n;
HOST_WIDE_INT size;
p = c;
n = 0;
while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
{
p = p->next;
n++;
}
if (n < 4)
{
gfc_init_se (&se, NULL);
gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
c->expr);
*poffset = fold (build2 (PLUS_EXPR, gfc_array_index_type,
*poffset, gfc_index_one_node));
}
else
{
tree list;
tree init;
tree bound;
tree tmptype;
p = c;
list = NULL_TREE;
while (p && !(p->iterator
|| p->expr->expr_type != EXPR_CONSTANT))
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
if (p->expr->ts.type == BT_CHARACTER
&& POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
(TREE_TYPE (pointer)))))
{
se.expr = gfc_build_addr_expr (pchar_type_node,
se.expr);
}
list = tree_cons (NULL_TREE, se.expr, list);
c = p;
p = p->next;
}
bound = build_int_cst (NULL_TREE, n - 1);
tmptype = build_range_type (gfc_array_index_type,
gfc_index_zero_node, bound);
tmptype = build_array_type (type, tmptype);
init = build1 (CONSTRUCTOR, tmptype, nreverse (list));
TREE_CONSTANT (init) = 1;
TREE_INVARIANT (init) = 1;
TREE_STATIC (init) = 1;
tmp = gfc_create_var (tmptype, "data");
TREE_STATIC (tmp) = 1;
TREE_CONSTANT (tmp) = 1;
TREE_INVARIANT (tmp) = 1;
DECL_INITIAL (tmp) = init;
init = tmp;
tmp = gfc_build_indirect_ref (pointer);
tmp = gfc_build_array_ref (tmp, *poffset);
tmp = gfc_build_addr_expr (NULL, tmp);
init = gfc_build_addr_expr (NULL, init);
size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
bound = build_int_cst (NULL_TREE, n * size);
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_chainon_list (tmp, init);
tmp = gfc_chainon_list (tmp, bound);
tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY],
tmp);
gfc_add_expr_to_block (&body, tmp);
*poffset = fold (build2 (PLUS_EXPR, gfc_array_index_type,
*poffset, bound));
}
if (!INTEGER_CST_P (*poffset))
{
gfc_add_modify_expr (&body, *offsetvar, *poffset);
*poffset = *offsetvar;
}
}
if (c->iterator)
{
tree end;
tree step;
tree loopvar;
tree exit_label;
loopbody = gfc_finish_block (&body);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, c->iterator->var);
gfc_add_block_to_block (pblock, &se.pre);
loopvar = se.expr;
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->start);
gfc_add_block_to_block (pblock, &se.pre);
gfc_add_modify_expr (pblock, loopvar, se.expr);
gfc_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);
exit_label = gfc_build_label_decl (NULL_TREE);
gfc_start_block (&body);
end = build2 (GT_EXPR, boolean_type_node, loopvar, end);
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = build3_v (COND_EXPR, end, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
gfc_add_expr_to_block (&body, loopbody);
tmp = build2 (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step);
gfc_add_modify_expr (&body, loopvar, tmp);
tmp = gfc_finish_block (&body);
tmp = build1_v (LOOP_EXPR, tmp);
gfc_add_expr_to_block (pblock, tmp);
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (pblock, tmp);
}
else
{
tmp = gfc_finish_block (&body);
gfc_add_expr_to_block (pblock, tmp);
}
}
}
static void
gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c)
{
gfc_iterator *i;
mpz_t val;
mpz_t len;
mpz_set_ui (*size, 0);
mpz_init (len);
mpz_init (val);
for (; c; c = c->next)
{
if (c->expr->expr_type == EXPR_ARRAY)
{
gfc_get_array_cons_size (&len, c->expr->value.constructor);
if (mpz_sgn (len) < 0)
{
mpz_set (*size, len);
mpz_clear (len);
mpz_clear (val);
return;
}
}
else
{
if (c->expr->rank > 0)
{
mpz_set_si (*size, -1);
mpz_clear (len);
mpz_clear (val);
return;
}
mpz_set_ui (len, 1);
}
if (c->iterator)
{
i = c->iterator;
if (i->start->expr_type != EXPR_CONSTANT
|| i->end->expr_type != EXPR_CONSTANT
|| i->step->expr_type != EXPR_CONSTANT)
{
mpz_set_si (*size, -1);
mpz_clear (len);
mpz_clear (val);
return;
}
mpz_add (val, i->end->value.integer, i->start->value.integer);
mpz_tdiv_q (val, val, i->step->value.integer);
mpz_add_ui (val, val, 1);
mpz_mul (len, len, val);
}
mpz_add (*size, *size, len);
}
mpz_clear (len);
mpz_clear (val);
}
static void
get_array_ctor_var_strlen (gfc_expr * expr, tree * len)
{
gfc_ref *ref;
gfc_typespec *ts;
if (*len && INTEGER_CST_P (*len))
return;
ts = &expr->symtree->n.sym->ts;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
break;
case COMPONENT_REF:
ts = &ref->u.c.component->ts;
break;
default:
return;
}
}
*len = ts->cl->backend_decl;
}
static bool
get_array_ctor_strlen (gfc_constructor * c, tree * len)
{
bool is_const;
is_const = TRUE;
for (; c; c = c->next)
{
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
if (!(*len && INTEGER_CST_P (*len)))
*len = build_int_cstu (gfc_charlen_type_node,
c->expr->value.character.length);
break;
case EXPR_ARRAY:
if (!get_array_ctor_strlen (c->expr->value.constructor, len))
is_const = FALSE;
break;
case EXPR_VARIABLE:
is_const = false;
get_array_ctor_var_strlen (c->expr, len);
break;
default:
is_const = FALSE;
break;
}
}
return is_const;
}
static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
{
tree offset;
tree offsetvar;
tree desc;
tree size;
tree type;
bool const_string;
ss->data.info.dimen = loop->dimen;
if (ss->expr->ts.type == BT_CHARACTER)
{
const_string = get_array_ctor_strlen (ss->expr->value.constructor,
&ss->string_length);
if (!ss->string_length)
gfc_todo_error ("complex character array constructors");
type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
if (const_string)
type = build_pointer_type (type);
}
else
{
const_string = TRUE;
type = gfc_typenode_for_spec (&ss->expr->ts);
}
size = gfc_trans_allocate_temp_array (loop, &ss->data.info, type);
desc = ss->data.info.descriptor;
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,
ss->data.info.data,
ss->expr->value.constructor, &offset,
&offsetvar);
if (TREE_USED (offsetvar))
pushdecl (offsetvar);
else
gcc_assert (INTEGER_CST_P (offset));
#if 0
if (flag_bounds_check)
{
gcc_unreachable ();
}
#endif
}
static void
gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
{
gfc_se se;
int n;
gcc_assert (ss != NULL);
for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
gcc_assert (ss);
switch (ss->type)
{
case GFC_SS_SCALAR:
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, ss->expr);
gfc_add_block_to_block (&loop->pre, &se.pre);
if (ss->expr->ts.type != BT_CHARACTER)
{
if (subscript)
se.expr = convert(gfc_array_index_type, se.expr);
se.expr = gfc_evaluate_now (se.expr, &loop->pre);
gfc_add_block_to_block (&loop->pre, &se.post);
}
else
gfc_add_block_to_block (&loop->post, &se.post);
ss->data.scalar.expr = se.expr;
ss->string_length = se.string_length;
break;
case GFC_SS_REFERENCE:
gfc_init_se (&se, NULL);
gfc_conv_expr_reference (&se, ss->expr);
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_add_block_to_block (&loop->post, &se.post);
ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre);
ss->string_length = se.string_length;
break;
case GFC_SS_SECTION:
case GFC_SS_VECTOR:
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
{
if (ss->data.info.subscript[n])
gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true);
}
break;
case GFC_SS_INTRINSIC:
gfc_add_intrinsic_ss_code (loop, ss);
break;
case GFC_SS_FUNCTION:
gfc_init_se (&se, NULL);
se.loop = loop;
se.ss = ss;
gfc_conv_expr (&se, ss->expr);
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_add_block_to_block (&loop->post, &se.post);
break;
case GFC_SS_CONSTRUCTOR:
gfc_trans_array_constructor (loop, ss);
break;
case GFC_SS_TEMP:
case GFC_SS_COMPONENT:
break;
default:
gcc_unreachable ();
}
}
}
static void
gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
{
gfc_se se;
tree tmp;
gcc_assert (ss->expr->expr_type == EXPR_VARIABLE);
gfc_init_se (&se, NULL);
se.descriptor_only = 1;
gfc_conv_expr_lhs (&se, ss->expr);
gfc_add_block_to_block (block, &se.pre);
ss->data.info.descriptor = se.expr;
ss->string_length = se.string_length;
if (base)
{
tmp = gfc_conv_array_data (se.expr);
if (!(DECL_P (tmp)
|| (TREE_CODE (tmp) == ADDR_EXPR
&& DECL_P (TREE_OPERAND (tmp, 0)))))
tmp = gfc_evaluate_now (tmp, block);
ss->data.info.data = tmp;
tmp = gfc_conv_array_offset (se.expr);
ss->data.info.offset = gfc_evaluate_now (tmp, block);
}
}
void
gfc_init_loopinfo (gfc_loopinfo * loop)
{
int n;
memset (loop, 0, sizeof (gfc_loopinfo));
gfc_init_block (&loop->pre);
gfc_init_block (&loop->post);
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
loop->order[n] = n;
loop->ss = gfc_ss_terminator;
}
void
gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop)
{
se->loop = loop;
}
tree
gfc_conv_array_data (tree descriptor)
{
tree type;
type = TREE_TYPE (descriptor);
if (GFC_ARRAY_TYPE_P (type))
{
if (TREE_CODE (type) == POINTER_TYPE)
return descriptor;
else
{
return gfc_build_addr_expr (NULL, descriptor);
}
}
else
return gfc_conv_descriptor_data (descriptor);
}
tree
gfc_conv_array_offset (tree descriptor)
{
tree type;
type = TREE_TYPE (descriptor);
if (GFC_ARRAY_TYPE_P (type))
return GFC_TYPE_ARRAY_OFFSET (type);
else
return gfc_conv_descriptor_offset (descriptor);
}
tree
gfc_conv_array_stride (tree descriptor, int dim)
{
tree tmp;
tree type;
type = TREE_TYPE (descriptor);
tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
if (tmp != NULL_TREE)
return tmp;
tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]);
return tmp;
}
tree
gfc_conv_array_lbound (tree descriptor, int dim)
{
tree tmp;
tree type;
type = TREE_TYPE (descriptor);
tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
if (tmp != NULL_TREE)
return tmp;
tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]);
return tmp;
}
tree
gfc_conv_array_ubound (tree descriptor, int dim)
{
tree tmp;
tree type;
type = TREE_TYPE (descriptor);
tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (tmp != NULL_TREE)
return tmp;
if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor)))
return gfc_index_zero_node;
tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]);
return tmp;
}
static void
gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices,
tree offset, int dimen)
{
tree array;
tree tmp;
tree index;
int n;
array = gfc_build_indirect_ref (pointer);
index = offset;
for (n = 0; n < dimen; n++)
{
tmp = gfc_conv_array_stride (se->expr, n);
tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp));
index = fold (build2 (PLUS_EXPR, gfc_array_index_type, index, tmp));
}
tmp = gfc_build_array_ref (array, index);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE);
se->expr = tmp;
}
static tree
gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n)
{
tree cond;
tree fault;
tree tmp;
if (!flag_bounds_check)
return index;
index = gfc_evaluate_now (index, &se->pre);
tmp = gfc_conv_array_lbound (descriptor, n);
fault = fold (build2 (LT_EXPR, boolean_type_node, index, tmp));
tmp = gfc_conv_array_ubound (descriptor, n);
cond = fold (build2 (GT_EXPR, boolean_type_node, index, tmp));
fault = fold (build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond));
gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
return index;
}
static tree
gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss)
{
tree descsave;
tree indices[GFC_MAX_DIMENSIONS];
gfc_array_ref *ar;
gfc_ss_info *info;
int n;
gcc_assert (ss && ss->type == GFC_SS_VECTOR);
descsave = se->expr;
info = &ss->data.info;
se->expr = info->descriptor;
ar = &info->ref->u.ar;
for (n = 0; n < ar->dimen; n++)
{
switch (ar->dimen_type[n])
{
case DIMEN_ELEMENT:
gcc_assert (info->subscript[n] != gfc_ss_terminator
&& info->subscript[n]->type == GFC_SS_SCALAR);
indices[n] = info->subscript[n]->data.scalar.expr;
break;
case DIMEN_RANGE:
indices[n] = index;
break;
case DIMEN_VECTOR:
index = gfc_conv_vector_array_index (se, index, info->subscript[n]);
indices[n] =
gfc_trans_array_bound_check (se, info->descriptor, index, n);
break;
default:
gcc_unreachable ();
}
}
gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen);
index = se->expr;
se->expr = descsave;
return index;
}
static tree
gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i,
gfc_array_ref * ar, tree stride)
{
tree index;
if (ar)
{
gcc_assert (ar->type != AR_ELEMENT);
if (ar->dimen_type[dim] == DIMEN_ELEMENT)
{
gcc_assert (i == -1);
gcc_assert (info->subscript[dim]
&& info->subscript[dim]->type == GFC_SS_SCALAR);
index = info->subscript[dim]->data.scalar.expr;
index =
gfc_trans_array_bound_check (se, info->descriptor, index, dim);
}
else
{
gcc_assert (info && se->loop);
index = se->loop->loopvar[i];
index = fold (build2 (MULT_EXPR, gfc_array_index_type, index,
info->stride[i]));
index = fold (build2 (PLUS_EXPR, gfc_array_index_type, index,
info->delta[i]));
if (ar->dimen_type[dim] == DIMEN_VECTOR)
{
index = gfc_conv_vector_array_index (se, index,
info->subscript[dim]);
index =
gfc_trans_array_bound_check (se, info->descriptor, index,
dim);
}
else
gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE);
}
}
else
{
gcc_assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]];
if (!integer_zerop (info->delta[i]))
index = fold (build2 (PLUS_EXPR, gfc_array_index_type,
index, info->delta[i]));
}
index = fold (build2 (MULT_EXPR, gfc_array_index_type, index, stride));
return index;
}
static void
gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
{
gfc_ss_info *info;
tree index;
tree tmp;
int n;
info = &se->ss->data.info;
if (ar)
n = se->loop->order[0];
else
n = 0;
index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar,
info->stride0);
index = fold (build2 (PLUS_EXPR, gfc_array_index_type, index, info->offset));
tmp = gfc_build_indirect_ref (info->data);
se->expr = gfc_build_array_ref (tmp, index);
}
void
gfc_conv_tmp_array_ref (gfc_se * se)
{
se->string_length = se->ss->string_length;
gfc_conv_scalarized_array_ref (se, NULL);
}
void
gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar)
{
int n;
tree index;
tree tmp;
tree stride;
tree fault;
gfc_se indexse;
if (ar->type != AR_ELEMENT)
{
gfc_conv_scalarized_array_ref (se, ar);
return;
}
index = gfc_index_zero_node;
fault = gfc_index_zero_node;
for (n = 0; n < ar->dimen; n++)
{
gfc_init_se (&indexse, NULL);
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)
{
tree cond;
indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre);
tmp = gfc_conv_array_lbound (se->expr, n);
cond = fold (build2 (LT_EXPR, boolean_type_node,
indexse.expr, tmp));
fault =
fold (build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond));
tmp = gfc_conv_array_ubound (se->expr, n);
cond = fold (build2 (GT_EXPR, boolean_type_node,
indexse.expr, tmp));
fault =
fold (build2 (TRUTH_OR_EXPR, boolean_type_node, fault, cond));
}
stride = gfc_conv_array_stride (se->expr, n);
tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, indexse.expr,
stride));
index = fold (build2 (PLUS_EXPR, gfc_array_index_type, index, tmp));
}
if (flag_bounds_check)
gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre);
tmp = gfc_conv_array_offset (se->expr);
if (!integer_zerop (tmp))
index = fold (build2 (PLUS_EXPR, gfc_array_index_type, index, tmp));
tmp = gfc_conv_array_data (se->expr);
tmp = gfc_build_indirect_ref (tmp);
se->expr = gfc_build_array_ref (tmp, index);
}
static void
gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
stmtblock_t * pblock)
{
tree index;
tree stride;
gfc_ss_info *info;
gfc_ss *ss;
gfc_se se;
int i;
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
if ((ss->useflags & flag) == 0)
continue;
if (ss->type != GFC_SS_SECTION
&& ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR
&& ss->type != GFC_SS_COMPONENT)
continue;
info = &ss->data.info;
if (dim >= info->dimen)
continue;
if (dim == info->dimen - 1)
{
if (info->ref)
{
for (i = 0; i < info->ref->u.ar.dimen; i++)
{
if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
continue;
gfc_init_se (&se, NULL);
se.loop = loop;
se.expr = info->descriptor;
stride = gfc_conv_array_stride (info->descriptor, i);
index = gfc_conv_array_index_offset (&se, info, i, -1,
&info->ref->u.ar,
stride);
gfc_add_block_to_block (pblock, &se.pre);
info->offset = fold (build2 (PLUS_EXPR, gfc_array_index_type,
info->offset, index));
info->offset = gfc_evaluate_now (info->offset, pblock);
}
i = loop->order[0];
stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
}
else
stride = gfc_conv_array_stride (info->descriptor, 0);
info->stride0 = gfc_evaluate_now (stride, pblock);
}
else
{
gfc_array_ref *ar;
if (info->ref)
{
ar = &info->ref->u.ar;
i = loop->order[dim + 1];
}
else
{
ar = NULL;
i = dim + 1;
}
gfc_init_se (&se, NULL);
se.loop = loop;
se.expr = info->descriptor;
stride = gfc_conv_array_stride (info->descriptor, info->dim[i]);
index = gfc_conv_array_index_offset (&se, info, info->dim[i], i,
ar, stride);
gfc_add_block_to_block (pblock, &se.pre);
info->offset = fold (build2 (PLUS_EXPR, gfc_array_index_type,
info->offset, index));
info->offset = gfc_evaluate_now (info->offset, pblock);
}
if (dim == loop->temp_dim - 1)
info->saved_offset = info->offset;
}
}
void
gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody)
{
int dim;
int n;
int flags;
gcc_assert (!loop->array_parameter);
for (dim = loop->dimen - 1; dim >= 0; dim--)
{
n = loop->order[dim];
gfc_start_block (&loop->code[n]);
loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S");
if (dim < loop->temp_dim)
flags = 3;
else
flags = 1;
gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]);
}
gfc_start_block (pbody);
}
static void
gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
stmtblock_t * pbody)
{
stmtblock_t block;
tree cond;
tree tmp;
tree loopbody;
tree exit_label;
loopbody = gfc_finish_block (pbody);
gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]);
exit_label = gfc_build_label_decl (NULL_TREE);
gfc_init_block (&block);
cond = build2 (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]);
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
gfc_add_expr_to_block (&block, loopbody);
tmp = build2 (PLUS_EXPR, gfc_array_index_type,
loop->loopvar[n], gfc_index_one_node);
gfc_add_modify_expr (&block, loop->loopvar[n], tmp);
tmp = gfc_finish_block (&block);
tmp = build1_v (LOOP_EXPR, tmp);
gfc_add_expr_to_block (&loop->code[n], tmp);
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (&loop->code[n], tmp);
}
void
gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body)
{
int dim;
int n;
gfc_ss *ss;
stmtblock_t *pblock;
tree tmp;
pblock = body;
for (dim = 0; dim < loop->dimen; dim++)
{
n = loop->order[dim];
gfc_trans_scalarized_loop_end (loop, n, pblock);
loop->loopvar[n] = NULL_TREE;
pblock = &loop->code[n];
}
tmp = gfc_finish_block (pblock);
gfc_add_expr_to_block (&loop->pre, tmp);
for (ss = loop->ss; ss; ss = ss->loop_chain)
ss->useflags = 0;
}
void
gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
{
int dim;
int n;
stmtblock_t *pblock;
gfc_ss *ss;
pblock = body;
for (dim = 0; dim < loop->temp_dim - 1; dim++)
{
n = loop->order[dim];
gfc_trans_scalarized_loop_end (loop, n, pblock);
loop->loopvar[n] = NULL_TREE;
pblock = &loop->code[n];
}
n = loop->order[loop->temp_dim - 1];
gfc_trans_scalarized_loop_end (loop, n, pblock);
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
if ((ss->useflags & 2) == 0)
continue;
if (ss->type != GFC_SS_SECTION
&& 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;
}
for (dim = loop->temp_dim - 2; dim >= 0; dim--)
{
n = loop->order[dim];
gfc_start_block (&loop->code[n]);
loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q");
gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]);
}
gfc_start_block (body);
}
static tree
gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock)
{
int dim;
gfc_ss *vecss;
gfc_expr *end;
tree desc;
tree bound;
gfc_se se;
gcc_assert (ss->type == GFC_SS_SECTION);
dim = ss->data.info.dim[n];
vecss = ss;
while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
{
vecss = vecss->data.info.subscript[dim];
gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
dim = vecss->data.info.dim[0];
}
gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
end = vecss->data.info.ref->u.ar.end[dim];
desc = vecss->data.info.descriptor;
if (end)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, end, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
bound = se.expr;
}
else
{
bound = gfc_conv_array_ubound (desc, dim);
}
return bound;
}
static void
gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n)
{
gfc_expr *start;
gfc_expr *stride;
gfc_ss *vecss;
tree desc;
gfc_se se;
gfc_ss_info *info;
int dim;
info = &ss->data.info;
dim = info->dim[n];
vecss = ss;
while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
{
vecss = vecss->data.info.subscript[dim];
gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
if (!vecss->data.info.descriptor)
gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter);
dim = vecss->data.info.dim[0];
}
gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
start = vecss->data.info.ref->u.ar.start[dim];
stride = vecss->data.info.ref->u.ar.stride[dim];
desc = vecss->data.info.descriptor;
if (start)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, start, gfc_array_index_type);
gfc_add_block_to_block (&loop->pre, &se.pre);
info->start[n] = se.expr;
}
else
{
info->start[n] = gfc_conv_array_lbound (desc, dim);
}
info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre);
if (stride == NULL)
info->stride[n] = gfc_index_one_node;
else
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, stride, gfc_array_index_type);
gfc_add_block_to_block (&loop->pre, &se.pre);
info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre);
}
}
void
gfc_conv_ss_startstride (gfc_loopinfo * loop)
{
int n;
tree tmp;
gfc_ss *ss;
gfc_ss *vecss;
tree desc;
loop->dimen = 0;
for (ss = loop->ss;
ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
{
switch (ss->type)
{
case GFC_SS_SECTION:
case GFC_SS_CONSTRUCTOR:
case GFC_SS_FUNCTION:
case GFC_SS_COMPONENT:
loop->dimen = ss->data.info.dimen;
break;
default:
break;
}
}
if (loop->dimen == 0)
gfc_todo_error ("Unable to determine rank of expression");
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:
gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
for (n = 0; n < ss->data.info.dimen; n++)
gfc_conv_section_startstride (loop, ss, n);
break;
case GFC_SS_CONSTRUCTOR:
case GFC_SS_FUNCTION:
for (n = 0; n < ss->data.info.dimen; n++)
{
ss->data.info.start[n] = gfc_index_zero_node;
ss->data.info.stride[n] = gfc_index_one_node;
}
break;
default:
break;
}
}
if (flag_bounds_check)
{
stmtblock_t block;
tree fault;
tree bound;
tree end;
tree size[GFC_MAX_DIMENSIONS];
gfc_ss_info *info;
int dim;
gfc_start_block (&block);
fault = integer_zero_node;
for (n = 0; n < loop->dimen; n++)
size[n] = NULL_TREE;
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
if (ss->type != GFC_SS_SECTION)
continue;
info = &ss->data.info;
for (n = 0; n < loop->dimen; n++)
{
dim = info->dim[n];
vecss = ss;
while (vecss->data.info.ref->u.ar.dimen_type[dim]
== DIMEN_VECTOR)
{
vecss = vecss->data.info.subscript[dim];
gcc_assert (vecss && vecss->type == GFC_SS_VECTOR);
dim = vecss->data.info.dim[0];
}
gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim]
== DIMEN_RANGE);
desc = vecss->data.info.descriptor;
bound = gfc_conv_array_lbound (desc, dim);
tmp = info->start[n];
tmp = fold (build2 (LT_EXPR, boolean_type_node, tmp, bound));
fault = fold (build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
tmp));
bound = gfc_conv_array_ubound (desc, dim);
end = gfc_conv_section_upper_bound (ss, n, &block);
tmp = fold (build2 (GT_EXPR, boolean_type_node, end, bound));
fault = fold (build2 (TRUTH_OR_EXPR, boolean_type_node, fault,
tmp));
tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, end,
info->start[n]));
tmp = fold (build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp,
info->stride[n]));
if (size[n])
{
tmp =
fold (build2 (NE_EXPR, boolean_type_node, tmp, size[n]));
fault =
build2 (TRUTH_OR_EXPR, boolean_type_node, fault, tmp);
}
else
size[n] = gfc_evaluate_now (tmp, &block);
}
}
gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block);
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&loop->pre, tmp);
}
}
static int
gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
{
gfc_ref *lref;
gfc_ref *rref;
gfc_symbol *lsym;
gfc_symbol *rsym;
lsym = lss->expr->symtree->n.sym;
rsym = rss->expr->symtree->n.sym;
if (gfc_symbols_could_alias (lsym, rsym))
return 1;
if (rsym->ts.type != BT_DERIVED
&& lsym->ts.type != BT_DERIVED)
return 0;
for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next)
{
if (lref->type != REF_COMPONENT)
continue;
if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
return 1;
for (rref = rss->expr->ref; rref != rss->data.info.ref;
rref = rref->next)
{
if (rref->type != REF_COMPONENT)
continue;
if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
return 1;
}
}
for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
{
if (rref->type != REF_COMPONENT)
break;
if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
return 1;
}
return 0;
}
void
gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
gfc_ss * rss)
{
gfc_ss *ss;
gfc_ref *lref;
gfc_ref *rref;
gfc_ref *aref;
int nDepend = 0;
int temp_dim = 0;
loop->temp_ss = NULL;
aref = dest->data.info.ref;
temp_dim = 0;
for (ss = rss; ss != gfc_ss_terminator; ss = ss->next)
{
if (ss->type != GFC_SS_SECTION)
continue;
if (gfc_could_be_alias (dest, ss))
{
nDepend = 1;
break;
}
if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
{
lref = dest->expr->ref;
rref = ss->expr->ref;
nDepend = gfc_dep_resolver (lref, rref);
#if 0
if (nDepend == 1)
{
for (n = 0; n < loop->dimen; n++)
{
int dim = dest->data.info.dim[n];
if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
depends[n] = 2;
else if (! gfc_is_same_range (&lref->u.ar,
&rref->u.ar, dim, 0))
depends[n] = 1;
}
dim = 0;
for (n = 0; n < loop->dimen; n++)
{
gcc_assert (loop->order[n] == n);
if (depends[n])
loop->order[dim++] = n;
}
temp_dim = dim;
for (n = 0; n < loop->dimen; n++)
{
if (! depends[n])
loop->order[dim++] = n;
}
gcc_assert (dim == loop->dimen);
break;
}
#endif
}
}
if (nDepend == 1)
{
loop->temp_ss = gfc_get_ss ();
loop->temp_ss->type = GFC_SS_TEMP;
loop->temp_ss->data.temp.type =
gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
loop->temp_ss->string_length = NULL_TREE;
loop->temp_ss->data.temp.dimen = loop->dimen;
loop->temp_ss->next = gfc_ss_terminator;
gfc_add_ss_to_loop (loop, loop->temp_ss);
}
else
loop->temp_ss = NULL;
}
void
gfc_conv_loop_setup (gfc_loopinfo * loop)
{
int n;
int dim;
gfc_ss_info *info;
gfc_ss_info *specinfo;
gfc_ss *ss;
tree tmp;
tree len;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
mpz_t *cshape;
mpz_t i;
mpz_init (i);
for (n = 0; n < loop->dimen; n++)
{
loopspec[n] = NULL;
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
if (ss->shape)
{
loopspec[n] = ss;
continue;
}
if (ss->type == GFC_SS_CONSTRUCTOR)
{
gcc_assert (loop->dimen == 1);
gfc_get_array_cons_size (&i, ss->expr->value.constructor);
if (mpz_sgn (i) > 0)
{
mpz_sub_ui (i, i, 1);
loop->to[n] =
gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
loopspec[n] = ss;
}
continue;
}
if (ss->type == GFC_SS_FUNCTION)
{
loopspec[n] = ss;
continue;
}
if (ss->type != GFC_SS_SECTION)
continue;
if (loopspec[n])
specinfo = &loopspec[n]->data.info;
else
specinfo = NULL;
info = &ss->data.info;
if (!specinfo)
loopspec[n] = ss;
else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
{
if (integer_onep (info->stride[n])
&& !integer_onep (specinfo->stride[n]))
loopspec[n] = ss;
else if (INTEGER_CST_P (info->stride[n])
&& !INTEGER_CST_P (specinfo->stride[n]))
loopspec[n] = ss;
else if (INTEGER_CST_P (info->start[n])
&& !INTEGER_CST_P (specinfo->start[n]))
loopspec[n] = ss;
}
}
if (!loopspec[n])
gfc_todo_error ("Unable to find scalarization loop specifier");
info = &loopspec[n]->data.info;
cshape = loopspec[n]->shape;
if (cshape && INTEGER_CST_P (info->start[n])
&& INTEGER_CST_P (info->stride[n]))
{
loop->from[n] = info->start[n];
mpz_set (i, cshape[n]);
mpz_sub_ui (i, i, 1);
tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
if (!integer_onep (info->stride[n]))
tmp = fold (build2 (MULT_EXPR, gfc_array_index_type,
tmp, info->stride[n]));
loop->to[n] = fold (build2 (PLUS_EXPR, gfc_array_index_type,
loop->from[n], tmp));
}
else
{
loop->from[n] = info->start[n];
switch (loopspec[n]->type)
{
case GFC_SS_CONSTRUCTOR:
gcc_assert (info->dimen == 1);
gcc_assert (loop->to[n]);
break;
case GFC_SS_SECTION:
loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n,
&loop->pre);
break;
case GFC_SS_FUNCTION:
gcc_assert (loop->to[n] == NULL_TREE);
break;
default:
gcc_unreachable ();
}
}
if (integer_onep (info->stride[n]))
info->delta[n] = gfc_index_zero_node;
else
{
info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre);
tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
loop->to[n], loop->from[n]));
tmp = fold (build2 (TRUNC_DIV_EXPR, gfc_array_index_type,
tmp, info->stride[n]));
loop->to[n] = gfc_evaluate_now (tmp, &loop->pre);
loop->from[n] = gfc_index_zero_node;
}
}
gfc_add_loop_ss_code (loop, loop->ss, false);
if (loop->temp_ss != NULL)
{
gcc_assert (loop->temp_ss->type == GFC_SS_TEMP);
tmp = loop->temp_ss->data.temp.type;
len = loop->temp_ss->string_length;
n = loop->temp_ss->data.temp.dimen;
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
loop->temp_ss->type = GFC_SS_SECTION;
loop->temp_ss->data.info.dimen = n;
gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, tmp);
}
for (n = 0; n < loop->temp_dim; n++)
loopspec[loop->order[n]] = NULL;
mpz_clear (i);
if (loop->array_parameter)
return;
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
if (ss->type != GFC_SS_SECTION && ss->type != GFC_SS_COMPONENT)
continue;
info = &ss->data.info;
for (n = 0; n < info->dimen; n++)
{
dim = info->dim[n];
if (loopspec[n] != ss)
{
tmp = fold (build2 (MULT_EXPR, gfc_array_index_type,
loop->from[n], info->stride[n]));
tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
info->start[n], tmp));
info->delta[n] = gfc_evaluate_now (tmp, &loop->pre);
}
}
}
}
static tree
gfc_array_init_size (tree descriptor, int rank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper,
stmtblock_t * pblock)
{
tree type;
tree tmp;
tree size;
tree offset;
tree stride;
gfc_expr *ubound;
gfc_se se;
int n;
type = TREE_TYPE (descriptor);
stride = gfc_index_one_node;
offset = gfc_index_zero_node;
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify_expr (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
for (n = 0; n < rank; n++)
{
ubound = upper[n];
gfc_init_se (&se, NULL);
if (lower == NULL)
se.expr = gfc_index_one_node;
else
{
gcc_assert (lower[n]);
if (ubound)
{
gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
}
else
{
se.expr = gfc_index_one_node;
ubound = lower[n];
}
}
tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]);
gfc_add_modify_expr (pblock, tmp, se.expr);
tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride));
offset = fold (build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp));
size = build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, se.expr);
gfc_init_se (&se, NULL);
gcc_assert (ubound);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]);
gfc_add_modify_expr (pblock, tmp, se.expr);
tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]);
gfc_add_modify_expr (pblock, tmp, stride);
size = fold (build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size));
stride = fold (build2 (MULT_EXPR, gfc_array_index_type, stride, size));
stride = gfc_evaluate_now (stride, pblock);
}
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
size = fold (build2 (MULT_EXPR, gfc_array_index_type, stride, tmp));
if (poffset != NULL)
{
offset = gfc_evaluate_now (offset, pblock);
*poffset = offset;
}
size = gfc_evaluate_now (size, pblock);
return size;
}
void
gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat)
{
tree tmp;
tree pointer;
tree allocate;
tree offset;
tree size;
gfc_expr **lower;
gfc_expr **upper;
switch (ref->u.ar.type)
{
case AR_ELEMENT:
lower = NULL;
upper = ref->u.ar.start;
break;
case AR_FULL:
gcc_assert (ref->u.ar.as->type == AS_EXPLICIT);
lower = ref->u.ar.as->lower;
upper = ref->u.ar.as->upper;
break;
case AR_SECTION:
lower = ref->u.ar.start;
upper = ref->u.ar.end;
break;
default:
gcc_unreachable ();
break;
}
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
lower, upper, &se->pre);
tmp = gfc_conv_descriptor_data (se->expr);
pointer = gfc_build_addr_expr (NULL, tmp);
pointer = gfc_evaluate_now (pointer, &se->pre);
if (TYPE_PRECISION (gfc_array_index_type) == 32)
allocate = gfor_fndecl_allocate;
else if (TYPE_PRECISION (gfc_array_index_type) == 64)
allocate = gfor_fndecl_allocate64;
else
gcc_unreachable ();
tmp = gfc_chainon_list (NULL_TREE, pointer);
tmp = gfc_chainon_list (tmp, size);
tmp = gfc_chainon_list (tmp, pstat);
tmp = gfc_build_function_call (allocate, tmp);
gfc_add_expr_to_block (&se->pre, tmp);
pointer = gfc_conv_descriptor_data (se->expr);
tmp = gfc_conv_descriptor_offset (se->expr);
gfc_add_modify_expr (&se->pre, tmp, offset);
}
tree
gfc_array_deallocate (tree descriptor)
{
tree var;
tree tmp;
stmtblock_t block;
gfc_start_block (&block);
tmp = gfc_conv_descriptor_data (descriptor);
tmp = gfc_build_addr_expr (NULL, tmp);
var = gfc_create_var (TREE_TYPE (tmp), "ptr");
gfc_add_modify_expr (&block, var, tmp);
tmp = gfc_chainon_list (NULL_TREE, var);
tmp = gfc_chainon_list (tmp, integer_zero_node);
tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
tree
gfc_conv_array_initializer (tree type, gfc_expr * expr)
{
gfc_constructor *c;
tree list;
tree tmp;
mpz_t maxval;
gfc_se se;
HOST_WIDE_INT hi;
unsigned HOST_WIDE_INT lo;
tree index, range;
list = NULL_TREE;
switch (expr->expr_type)
{
case EXPR_CONSTANT:
case EXPR_STRUCTURE:
gfc_init_se (&se, NULL);
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));
gcc_assert (tmp && INTEGER_CST_P (tmp));
hi = TREE_INT_CST_HIGH (tmp);
lo = TREE_INT_CST_LOW (tmp);
lo++;
if (lo == 0)
hi++;
while (hi != 0 || lo != 0)
{
list = tree_cons (NULL_TREE, se.expr, list);
if (lo == 0)
hi--;
lo--;
}
break;
case EXPR_ARRAY:
for (c = expr->value.constructor; c; c = c->next)
{
if (c->iterator)
{
internal_error
("Possible frontend bug: array constructor not expanded");
}
if (mpz_cmp_si (c->n.offset, 0) != 0)
index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
else
index = NULL_TREE;
mpz_init (maxval);
if (mpz_cmp_si (c->repeat, 0) != 0)
{
tree tmp1, tmp2;
mpz_set (maxval, c->repeat);
mpz_add (maxval, c->n.offset, maxval);
mpz_sub_ui (maxval, maxval, 1);
tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
if (mpz_cmp_si (c->n.offset, 0) != 0)
{
mpz_add_ui (maxval, c->n.offset, 1);
tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
}
else
tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
range = build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
}
else
range = NULL;
mpz_clear (maxval);
gfc_init_se (&se, NULL);
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
gfc_conv_constant (&se, c->expr);
if (range == NULL_TREE)
list = tree_cons (index, se.expr, list);
else
{
if (index != NULL_TREE)
list = tree_cons (index, se.expr, list);
list = tree_cons (range, se.expr, list);
}
break;
case EXPR_STRUCTURE:
gfc_conv_structure (&se, c->expr, 1);
list = tree_cons (index, se.expr, list);
break;
default:
gcc_unreachable ();
}
}
list = nreverse (list);
break;
default:
gcc_unreachable ();
}
tmp = build1 (CONSTRUCTOR, type, list);
TREE_CONSTANT (tmp) = 1;
TREE_INVARIANT (tmp) = 1;
return tmp;
}
static tree
gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
stmtblock_t * pblock)
{
gfc_array_spec *as;
tree size;
tree stride;
tree offset;
tree ubound;
tree lbound;
tree tmp;
gfc_se se;
int dim;
as = sym->as;
size = gfc_index_one_node;
offset = gfc_index_zero_node;
for (dim = 0; dim < as->rank; dim++)
{
lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
if (as->lower[dim] && !INTEGER_CST_P (lbound))
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
gfc_add_modify_expr (pblock, lbound, se.expr);
}
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
gfc_add_modify_expr (pblock, ubound, se.expr);
}
tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, lbound, size));
offset = fold (build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp));
if (dim + 1 < as->rank)
stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
else
stride = NULL_TREE;
if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
{
tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, lbound));
tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp));
tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
if (stride)
gfc_add_modify_expr (pblock, stride, tmp);
else
stride = gfc_evaluate_now (tmp, pblock);
}
size = stride;
}
*poffset = offset;
return size;
}
tree
gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
{
stmtblock_t block;
tree type;
tree tmp;
tree fndecl;
tree size;
tree offset;
bool onstack;
gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
if (sym->attr.use_assoc)
return fnbody;
type = TREE_TYPE (decl);
gcc_assert (GFC_ARRAY_TYPE_P (type));
onstack = TREE_CODE (type) != POINTER_TYPE;
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
&& onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
{
gfc_trans_init_string_length (sym->ts.cl, &block);
tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&block, tmp);
}
if (onstack)
{
gfc_add_expr_to_block (&block, fnbody);
return gfc_finish_block (&block);
}
type = TREE_TYPE (type);
gcc_assert (!sym->attr.use_assoc);
gcc_assert (!TREE_STATIC (decl));
gcc_assert (!sym->module);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
gfc_trans_init_string_length (sym->ts.cl, &block);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
tmp = gfc_chainon_list (NULL_TREE, size);
if (gfc_index_integer_kind == 4)
fndecl = gfor_fndecl_internal_malloc;
else if (gfc_index_integer_kind == 8)
fndecl = gfor_fndecl_internal_malloc64;
else
gcc_unreachable ();
tmp = gfc_build_function_call (fndecl, tmp);
tmp = fold (convert (TREE_TYPE (decl), tmp));
gfc_add_modify_expr (&block, decl, tmp);
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
gcc_assert (!sym->value);
gfc_add_expr_to_block (&block, fnbody);
tmp = convert (pvoid_type_node, decl);
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
tree
gfc_trans_g77_array (gfc_symbol * sym, tree body)
{
tree parm;
tree type;
locus loc;
tree offset;
tree tmp;
stmtblock_t block;
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
parm = sym->backend_decl;
type = TREE_TYPE (parm);
gcc_assert (GFC_ARRAY_TYPE_P (type));
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
gfc_trans_init_string_length (sym->ts.cl, &block);
gfc_trans_array_bounds (type, sym, &offset, &block);
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
if (TREE_CODE (parm) != PARM_DECL)
{
tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
gfc_add_modify_expr (&block, parm, tmp);
}
tmp = gfc_finish_block (&block);
gfc_set_backend_locus (&loc);
gfc_start_block (&block);
gfc_add_expr_to_block (&block, tmp);
gfc_add_expr_to_block (&block, body);
return gfc_finish_block (&block);
}
tree
gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
{
tree size;
tree type;
tree offset;
locus loc;
stmtblock_t block;
stmtblock_t cleanup;
tree lbound;
tree ubound;
tree dubound;
tree dlbound;
tree dumdesc;
tree tmp;
tree stmt;
tree stride;
tree stmt_packed;
tree stmt_unpacked;
tree partial;
gfc_se se;
int n;
int checkparm;
int no_repack;
bool optional_arg;
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_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
type = TREE_TYPE (tmpdesc);
gcc_assert (GFC_ARRAY_TYPE_P (type));
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
dumdesc = gfc_build_indirect_ref (dumdesc);
gfc_start_block (&block);
if (sym->ts.type == BT_CHARACTER
&& TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
gfc_trans_init_string_length (sym->ts.cl, &block);
checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
|| GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc));
if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc))
{
partial = gfc_create_var (boolean_type_node, "partial");
TREE_USED (partial) = 1;
tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
tmp = fold (build2 (EQ_EXPR, boolean_type_node, tmp, integer_one_node));
gfc_add_modify_expr (&block, partial, tmp);
}
else
{
partial = NULL_TREE;
}
if (no_repack)
{
stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]);
stride = gfc_evaluate_now (stride, &block);
tmp = build2 (EQ_EXPR, boolean_type_node, stride, integer_zero_node);
tmp = build3 (COND_EXPR, gfc_array_index_type, tmp,
gfc_index_one_node, stride);
stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
gfc_add_modify_expr (&block, stride, tmp);
stmt_unpacked = NULL_TREE;
}
else
{
gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
tmp = gfc_chainon_list (NULL_TREE, tmp);
stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
stride = gfc_index_one_node;
}
if (no_repack || partial != NULL_TREE)
stmt_packed = gfc_conv_descriptor_data (dumdesc);
else
stmt_packed = NULL_TREE;
if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
{
tmp = build3 (COND_EXPR, TREE_TYPE (stmt_packed), partial,
stmt_packed, stmt_unpacked);
}
else
tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked;
gfc_add_modify_expr (&block, tmpdesc, fold_convert (type, tmp));
offset = gfc_index_zero_node;
size = gfc_index_one_node;
for (n = 0; n < sym->as->rank; n++)
{
if (checkparm || !sym->as->upper[n])
{
dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]);
dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]);
}
else
{
dubound = NULL_TREE;
dlbound = NULL_TREE;
}
lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
if (!INTEGER_CST_P (lbound))
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, sym->as->upper[n],
gfc_array_index_type);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify_expr (&block, lbound, se.expr);
}
ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
if (sym->as->upper[n])
{
if (!INTEGER_CST_P (ubound))
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, sym->as->upper[n],
gfc_array_index_type);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify_expr (&block, ubound, se.expr);
}
if (checkparm)
{
tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
ubound, lbound));
stride = build2 (MINUS_EXPR, gfc_array_index_type,
dubound, dlbound);
tmp = fold (build2 (NE_EXPR, gfc_array_index_type, tmp, stride));
gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block);
}
}
else
{
tmp = build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound);
tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound));
gfc_add_modify_expr (&block, ubound, tmp);
}
tmp = fold (build2 (MULT_EXPR, gfc_array_index_type, lbound, stride));
offset = fold (build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp));
if (n + 1 < sym->as->rank)
{
stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
if (no_repack || partial != NULL_TREE)
{
stmt_unpacked =
gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]);
}
if (!INTEGER_CST_P (stride))
{
if (no_repack)
stmt_packed = NULL_TREE;
else
{
tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, lbound));
tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
ubound, tmp));
size = fold (build2 (MULT_EXPR, gfc_array_index_type,
size, tmp));
stmt_packed = size;
}
if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
tmp = build3 (COND_EXPR, gfc_array_index_type, partial,
stmt_unpacked, stmt_packed);
else
tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
gfc_add_modify_expr (&block, stride, tmp);
}
}
}
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
stmt = gfc_finish_block (&block);
gfc_start_block (&block);
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
optional_arg = sym->attr.optional || sym->ns->proc_name->attr.entry_master;
if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
}
gfc_add_expr_to_block (&block, stmt);
gfc_add_expr_to_block (&block, body);
if (!no_repack)
{
gfc_start_block (&cleanup);
if (sym->attr.intent != INTENT_IN)
{
tmp = gfc_chainon_list (NULL_TREE, dumdesc);
tmp = gfc_chainon_list (tmp, tmpdesc);
tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
gfc_add_expr_to_block (&cleanup, tmp);
}
tmp = gfc_chainon_list (NULL_TREE, tmpdesc);
tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&cleanup, tmp);
stmt = gfc_finish_block (&cleanup);
tmp = gfc_build_indirect_ref (dumdesc);
tmp = gfc_conv_descriptor_data (tmp);
tmp = build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
if (optional_arg)
{
tmp = gfc_conv_expr_present (sym);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
}
gfc_add_expr_to_block (&block, stmt);
}
return gfc_finish_block (&block);
}
void
gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
{
gfc_loopinfo loop;
gfc_ss *secss;
gfc_ss_info *info;
int need_tmp;
int n;
tree tmp;
tree desc;
stmtblock_t block;
tree start;
tree offset;
int full;
gfc_ss *vss;
gfc_ref *ref;
gcc_assert (ss != gfc_ss_terminator);
switch (expr->expr_type)
{
case EXPR_VARIABLE:
secss = ss;
while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION)
secss = secss->next;
gcc_assert (secss != gfc_ss_terminator);
need_tmp = 0;
for (n = 0; n < secss->data.info.dimen; n++)
{
vss = secss->data.info.subscript[secss->data.info.dim[n]];
if (vss && vss->type == GFC_SS_VECTOR)
need_tmp = 1;
}
info = &secss->data.info;
gfc_conv_ss_descriptor (&se->pre, secss, 0);
desc = info->descriptor;
if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
full = 0;
}
else if (info->ref->u.ar.type == AR_FULL)
full = 1;
else if (se->direct_byref)
full = 0;
else
{
ref = info->ref;
gcc_assert (ref->u.ar.type == AR_SECTION);
full = 1;
for (n = 0; n < ref->u.ar.dimen; n++)
{
if (ref->u.ar.start[n]
|| ref->u.ar.end[n]
|| (ref->u.ar.stride[n]
&& !gfc_expr_is_one (ref->u.ar.stride[n], 0)))
{
full = 0;
break;
}
}
}
ref = expr->ref;
if (!need_tmp && ref && expr->ts.type == BT_CHARACTER)
{
while (ref->next)
ref = ref->next;
if (ref->type == REF_SUBSTRING)
{
full = 0;
need_tmp = 1;
}
}
if (full)
{
if (se->direct_byref)
{
gfc_add_modify_expr (&se->pre, se->expr, desc);
}
else 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 = gfc_get_expr_charlen (expr);
return;
}
break;
case EXPR_FUNCTION:
secss = ss;
while (secss != gfc_ss_terminator
&& (secss->type != GFC_SS_FUNCTION || secss->expr != expr))
secss = secss->next;
if (se->direct_byref)
{
gcc_assert (secss != gfc_ss_terminator);
se->ss = secss;
se->expr = gfc_build_addr_expr (NULL, se->expr);
gfc_conv_expr (se, expr);
return;
}
if (secss == gfc_ss_terminator)
{
need_tmp = 1;
info = NULL;
}
else
{
info = &secss->data.info;
need_tmp = 0;
}
break;
default:
need_tmp = 1;
secss = NULL;
info = NULL;
break;
}
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
if (!need_tmp)
loop.array_parameter = 1;
else
gcc_assert (se->want_pointer && !se->direct_byref);
gfc_conv_ss_startstride (&loop);
if (need_tmp)
{
loop.temp_ss = gfc_get_ss ();
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);
if (expr->ts.type == BT_CHARACTER)
se->string_length = loop.temp_ss->string_length
= TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
else
loop.temp_ss->string_length = NULL;
loop.temp_ss->data.temp.dimen = loop.dimen;
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
gfc_conv_loop_setup (&loop);
if (need_tmp)
{
gfc_se lse;
gfc_se rse;
gfc_mark_ss_chain_used (loop.temp_ss, 1);
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &block);
gfc_init_se (&lse, NULL);
gfc_copy_loopinfo_to_se (&lse, &loop);
gfc_init_se (&rse, NULL);
gfc_copy_loopinfo_to_se (&rse, &loop);
lse.ss = loop.temp_ss;
rse.ss = ss;
gfc_conv_scalarized_array_ref (&lse, NULL);
gfc_conv_expr_val (&rse, expr);
gfc_add_block_to_block (&block, &rse.pre);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_modify_expr (&block, lse.expr, rse.expr);
gfc_trans_scalarizing_loops (&loop, &block);
desc = loop.temp_ss->data.info.descriptor;
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]);
gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
gcc_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
{
int dim;
tree parm;
tree parmtype;
tree stride;
tree from;
tree to;
tree base;
if (expr->ts.type == BT_CHARACTER)
se->string_length = gfc_get_expr_charlen (expr);
desc = info->descriptor;
gcc_assert (secss && secss != gfc_ss_terminator);
if (se->direct_byref)
{
parm = se->expr;
parmtype = TREE_TYPE (parm);
}
else
{
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
loop.from, loop.to, 0);
parm = gfc_create_var (parmtype, "parm");
}
offset = gfc_index_zero_node;
dim = 0;
tmp = gfc_conv_descriptor_dtype (parm);
gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
if (se->direct_byref)
base = gfc_index_zero_node;
else
base = NULL_TREE;
for (n = 0; n < info->ref->u.ar.dimen; n++)
{
stride = gfc_conv_array_stride (desc, n);
if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
{
gcc_assert (info->subscript[n]
&& info->subscript[n]->type == GFC_SS_SCALAR);
start = info->subscript[n]->data.scalar.expr;
}
else
{
gcc_assert (info->dim[dim] == n);
start = info->start[dim];
stride = gfc_evaluate_now (stride, &loop.pre);
}
tmp = gfc_conv_array_lbound (desc, n);
tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (tmp), start, tmp));
tmp = fold (build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, stride));
offset = fold (build2 (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp));
if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
{
continue;
}
gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
from = loop.from[dim];
to = loop.to[dim];
if (!integer_onep (from))
{
tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
gfc_index_one_node, from));
to = fold (build2 (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);
tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]);
gfc_add_modify_expr (&loop.pre, tmp, to);
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));
tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]);
gfc_add_modify_expr (&loop.pre, tmp, stride);
dim++;
}
tmp = gfc_conv_array_data (desc);
tmp = gfc_build_indirect_ref (tmp);
tmp = gfc_build_array_ref (tmp, offset);
offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp);
tmp = gfc_conv_descriptor_data (parm);
gfc_add_modify_expr (&loop.pre, tmp,
fold_convert (TREE_TYPE (tmp), offset));
if (se->direct_byref)
{
tmp = gfc_conv_descriptor_offset (parm);
gfc_add_modify_expr (&loop.pre, tmp, base);
}
else
{
tmp = gfc_conv_descriptor_offset (parm);
gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node);
}
if (!se->direct_byref)
{
if (se->want_pointer)
se->expr = gfc_build_addr_expr (NULL, parm);
else
se->expr = parm;
}
}
gfc_add_block_to_block (&se->pre, &loop.pre);
gfc_add_block_to_block (&se->post, &loop.post);
gfc_cleanup_loop (&loop);
}
void
gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
{
tree ptr;
tree desc;
tree tmp;
tree stmt;
gfc_symbol *sym;
stmtblock_t block;
if (expr->expr_type == EXPR_VARIABLE
&& expr->ref->u.ar.type == AR_FULL && g77)
{
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)
{
if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
se->expr = tmp;
else
se->expr = gfc_build_addr_expr (NULL, tmp);
return;
}
if (sym->attr.allocatable)
{
se->expr = gfc_conv_array_data (tmp);
return;
}
}
se->want_pointer = 1;
gfc_conv_expr_descriptor (se, expr, ss);
if (g77)
{
desc = se->expr;
tmp = gfc_chainon_list (NULL_TREE, desc);
ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp);
ptr = gfc_evaluate_now (ptr, &se->pre);
se->expr = ptr;
gfc_start_block (&block);
tmp = gfc_chainon_list (NULL_TREE, desc);
tmp = gfc_chainon_list (tmp, ptr);
tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp);
gfc_add_expr_to_block (&block, tmp);
tmp = convert (pvoid_type_node, ptr);
tmp = gfc_chainon_list (NULL_TREE, tmp);
tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
gfc_init_block (&block);
tmp = gfc_build_indirect_ref (desc);
tmp = gfc_conv_array_data (tmp);
tmp = build2 (NE_EXPR, boolean_type_node, ptr, tmp);
tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se->post);
gfc_init_block (&se->post);
gfc_add_block_to_block (&se->post, &block);
}
}
tree
gfc_trans_deferred_array (gfc_symbol * sym, tree body)
{
tree type;
tree tmp;
tree descriptor;
tree deallocate;
stmtblock_t block;
stmtblock_t fnblock;
locus loc;
if (!(sym->attr.pointer || sym->attr.allocatable))
fatal_error
("Possible frontend bug: Deferred array size without pointer or allocatable attribute.");
gfc_init_block (&fnblock);
gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
if (sym->ts.type == BT_CHARACTER
&& !INTEGER_CST_P (sym->ts.cl->backend_decl))
gfc_trans_init_string_length (sym->ts.cl, &fnblock);
if (sym->attr.dummy || sym->attr.use_assoc)
{
gfc_add_expr_to_block (&fnblock, body);
return gfc_finish_block (&fnblock);
}
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
descriptor = sym->backend_decl;
if (TREE_STATIC (descriptor))
{
gfc_trans_static_array_pointer (sym);
return body;
}
type = TREE_TYPE (sym->backend_decl);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
tmp = gfc_conv_descriptor_data (descriptor);
gfc_add_modify_expr (&fnblock, tmp,
convert (TREE_TYPE (tmp), integer_zero_node));
gfc_add_expr_to_block (&fnblock, body);
gfc_set_backend_locus (&loc);
if (sym->attr.allocatable)
{
gfc_start_block (&block);
deallocate = gfc_array_deallocate (descriptor);
tmp = gfc_conv_descriptor_data (descriptor);
tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_zero_node);
tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&fnblock, tmp);
}
return gfc_finish_block (&fnblock);
}
static gfc_ss *
gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr)
{
gfc_ref *ref;
gfc_array_ref *ar;
gfc_ss *newss;
gfc_ss *head;
int n;
for (ref = expr->ref; ref; ref = ref->next)
{
if (ref->type != REF_ARRAY)
continue;
ar = &ref->u.ar;
switch (ar->type)
{
case AR_ELEMENT:
break;
case AR_FULL:
newss = gfc_get_ss ();
newss->type = GFC_SS_SECTION;
newss->expr = expr;
newss->next = ss;
newss->data.info.dimen = ar->as->rank;
newss->data.info.ref = ref;
ar->dimen = ar->as->rank;
for (n = 0; n < ar->dimen; n++)
{
newss->data.info.dim[n] = n;
ar->dimen_type[n] = DIMEN_RANGE;
gcc_assert (ar->start[n] == NULL);
gcc_assert (ar->end[n] == NULL);
gcc_assert (ar->stride[n] == NULL);
}
return newss;
case AR_SECTION:
newss = gfc_get_ss ();
newss->type = GFC_SS_SECTION;
newss->expr = expr;
newss->next = ss;
newss->data.info.dimen = 0;
newss->data.info.ref = ref;
head = newss;
for (n = 0; n < ar->dimen; n++)
{
gfc_ss *indexss;
switch (ar->dimen_type[n])
{
case DIMEN_ELEMENT:
gcc_assert (ar->start[n]);
indexss = gfc_get_ss ();
indexss->type = GFC_SS_SCALAR;
indexss->expr = ar->start[n];
indexss->next = gfc_ss_terminator;
indexss->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss;
break;
case DIMEN_RANGE:
newss->data.info.dim[newss->data.info.dimen] = n;
newss->data.info.dimen++;
break;
case DIMEN_VECTOR:
indexss = gfc_walk_expr (ar->start[n]);
if (indexss == gfc_ss_terminator)
internal_error ("scalar vector subscript???");
if (indexss->next != gfc_ss_terminator)
gfc_todo_error ("vector subscript expressions");
indexss->loop_chain = gfc_ss_terminator;
indexss->type = GFC_SS_VECTOR;
newss->data.info.subscript[n] = indexss;
newss->data.info.dim[newss->data.info.dimen] = n;
newss->data.info.dimen++;
break;
default:
gcc_unreachable ();
}
}
gcc_assert (newss->data.info.dimen > 0);
return head;
break;
default:
gcc_unreachable ();
}
}
return ss;
}
static gfc_ss *
gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr)
{
gfc_ss *head;
gfc_ss *head2;
gfc_ss *newss;
head = gfc_walk_subexpr (ss, expr->value.op.op1);
if (expr->value.op.op2 == NULL)
head2 = head;
else
head2 = gfc_walk_subexpr (head, expr->value.op.op2);
if (head2 == ss)
return head2;
if (head != ss && (expr->value.op.op2 == NULL || head2 != head))
return head2;
newss = gfc_get_ss ();
newss->type = GFC_SS_SCALAR;
if (head == ss)
{
head = head2;
while (head && head->next != ss)
head = head->next;
gcc_assert (head);
newss->next = ss;
head->next = newss;
newss->expr = expr->value.op.op1;
}
else
{
gcc_assert (head2 == head);
newss->next = head2;
head2 = newss;
newss->expr = expr->value.op.op2;
}
return head2;
}
static gfc_ss *
gfc_reverse_ss (gfc_ss * ss)
{
gfc_ss *next;
gfc_ss *head;
gcc_assert (ss != NULL);
head = gfc_ss_terminator;
while (ss != gfc_ss_terminator)
{
next = ss->next;
gcc_assert (next != NULL);
ss->next = head;
head = ss;
ss = next;
}
return (head);
}
gfc_ss *
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr,
gfc_ss_type type)
{
gfc_actual_arglist *arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
gfc_ss *newss;
head = gfc_ss_terminator;
tail = NULL;
scalar = 1;
for (arg = expr->value.function.actual; arg; arg = arg->next)
{
if (!arg->expr)
continue;
newss = gfc_walk_subexpr (head, arg->expr);
if (newss == head)
{
newss = gfc_get_ss ();
newss->type = type;
newss->expr = arg->expr;
newss->next = head;
}
else
scalar = 0;
head = newss;
if (!tail)
{
tail = head;
while (tail->next != gfc_ss_terminator)
tail = tail->next;
}
}
if (scalar)
{
gfc_free_ss_chain (head);
return ss;
}
tail->next = ss;
return head;
}
static gfc_ss *
gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
{
gfc_ss *newss;
gfc_intrinsic_sym *isym;
gfc_symbol *sym;
isym = expr->value.function.isym;
if (isym)
return gfc_walk_intrinsic_function (ss, expr, isym);
sym = expr->value.function.esym;
if (!sym)
sym = expr->symtree->n.sym;
if (gfc_return_by_reference (sym) && sym->result->attr.dimension)
{
newss = gfc_get_ss ();
newss->type = GFC_SS_FUNCTION;
newss->expr = expr;
newss->next = ss;
newss->data.info.dimen = expr->rank;
return newss;
}
if (sym->attr.elemental)
return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE);
return ss;
}
static gfc_ss *
gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
{
gfc_ss *newss;
int n;
newss = gfc_get_ss ();
newss->type = GFC_SS_CONSTRUCTOR;
newss->expr = expr;
newss->next = ss;
newss->data.info.dimen = expr->rank;
for (n = 0; n < expr->rank; n++)
newss->data.info.dim[n] = n;
return newss;
}
static gfc_ss *
gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr)
{
gfc_ss *head;
switch (expr->expr_type)
{
case EXPR_VARIABLE:
head = gfc_walk_variable_expr (ss, expr);
return head;
case EXPR_OP:
head = gfc_walk_op_expr (ss, expr);
return head;
case EXPR_FUNCTION:
head = gfc_walk_function_expr (ss, expr);
return head;
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_STRUCTURE:
break;
case EXPR_ARRAY:
head = gfc_walk_array_constructor (ss, expr);
return head;
case EXPR_SUBSTRING:
break;
default:
internal_error ("bad expression type during walk (%d)",
expr->expr_type);
}
return ss;
}
gfc_ss *
gfc_walk_expr (gfc_expr * expr)
{
gfc_ss *res;
res = gfc_walk_subexpr (gfc_ss_terminator, expr);
return gfc_reverse_ss (res);
}