}
+/* Return for an expression the backend decl of the coarray. */
+
+static tree
+get_tree_for_caf_expr (gfc_expr *expr)
+{
+ tree caf_decl = NULL_TREE;
+ gfc_ref *ref;
+
+ gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
+ if (expr->symtree->n.sym->attr.codimension)
+ caf_decl = expr->symtree->n.sym->backend_decl;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ {
+ gfc_component *comp = ref->u.c.component;
+ if (comp->attr.pointer || comp->attr.allocatable)
+ caf_decl = NULL_TREE;
+ if (comp->attr.codimension)
+ caf_decl = comp->backend_decl;
+ }
+
+ gcc_assert (caf_decl != NULL_TREE);
+ return caf_decl;
+}
+
+
/* For each character array constructor subexpression without a ts.u.cl->length,
replace it by its first element (if there aren't any elements, the length
should already be set to zero). */
gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node,
start.expr));
- gfc_free (msg);
+ free (msg);
/* Check upper bound. */
fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
fold_convert (long_integer_type_node, end.expr),
fold_convert (long_integer_type_node,
se->string_length));
- gfc_free (msg);
+ free (msg);
}
/* If the start and end expressions are equal, the length is one. */
field = c->backend_decl;
gcc_assert (TREE_CODE (field) == FIELD_DECL);
decl = se->expr;
+
+ /* Components can correspond to fields of different containing
+ types, as components are created without context, whereas
+ a concrete use of a component has the type of decl as context.
+ So, if the type doesn't match, we search the corresponding
+ FIELD_DECL in the parent type. To not waste too much time
+ we cache this result in norestrict_decl. */
+
+ if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
+ {
+ tree f2 = c->norestrict_decl;
+ if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
+ for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
+ if (TREE_CODE (f2) == FIELD_DECL
+ && DECL_NAME (f2) == DECL_NAME (field))
+ break;
+ gcc_assert (f2);
+ c->norestrict_decl = f2;
+ field = f2;
+ }
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
decl, field, NULL_TREE);
se->string_length = tmp;
}
- if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
+ if (((c->attr.pointer || c->attr.allocatable)
+ && (!c->attr.dimension && !c->attr.codimension)
&& c->ts.type != BT_CHARACTER)
|| c->attr.proc_pointer)
se->expr = build_fold_indirect_ref_loc (input_location,
static void
gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
+ gfc_ss *ss;
gfc_ref *ref;
gfc_symbol *sym;
tree parent_decl = NULL_TREE;
bool entry_master;
sym = expr->symtree->n.sym;
- if (se->ss != NULL)
+ ss = se->ss;
+ if (ss != NULL)
{
+ gfc_ss_info *ss_info = ss->info;
+
/* Check that something hasn't gone horribly wrong. */
- gcc_assert (se->ss != gfc_ss_terminator);
- gcc_assert (se->ss->expr == expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ gcc_assert (ss_info->expr == expr);
/* A scalarized term. We already know the descriptor. */
- se->expr = se->ss->data.info.descriptor;
- se->string_length = se->ss->string_length;
- for (ref = se->ss->data.info.ref; ref; ref = ref->next)
+ se->expr = ss_info->data.array.descriptor;
+ se->string_length = ss_info->string_length;
+ for (ref = ss_info->data.array.ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
break;
}
}
else if (!sym->attr.value)
{
- /* Dereference non-character scalar dummy arguments. */
- if (sym->attr.dummy && !sym->attr.dimension)
+ /* Dereference non-character scalar dummy arguments. */
+ if (sym->attr.dummy && !sym->attr.dimension
+ && !(sym->attr.codimension && sym->attr.allocatable))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
- || !sym->attr.dimension))
+ || (!sym->attr.dimension
+ && (!sym->attr.codimension || !sym->attr.allocatable))))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
}
switch (kind)
{
case 0:
- fndecl = built_in_decls[BUILT_IN_POWIF];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
break;
case 1:
- fndecl = built_in_decls[BUILT_IN_POWI];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWI);
break;
case 2:
- fndecl = built_in_decls[BUILT_IN_POWIL];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
break;
case 3:
/* Use the __builtin_powil() only if real(kind=16) is
actually the C long double type. */
if (!gfc_real16_is_float128)
- fndecl = built_in_decls[BUILT_IN_POWIL];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
break;
default:
sym->new_sym->n.sym->formal = NULL;
gfc_free_symbol (sym->new_sym->n.sym);
gfc_free_expr (sym->expr);
- gfc_free (sym->new_sym);
- gfc_free (sym);
+ free (sym->new_sym);
+ free (sym);
}
for (cl = mapping->charlens; cl; cl = nextcl)
{
nextcl = cl->next;
gfc_free_expr (cl->length);
- gfc_free (cl);
+ free (cl);
}
}
expr->symtree = sym->new_sym;
else if (sym->expr)
gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
+ /* Replace base type for polymorphic arguments. */
+ if (expr->ref && expr->ref->type == REF_COMPONENT
+ && sym->expr && sym->expr->ts.type == BT_CLASS)
+ expr->ref->u.c.sym = sym->expr->ts.u.derived;
}
/* ...and to subexpressions in expr->value. */
gfc_ss *rss;
gfc_loopinfo loop;
gfc_loopinfo loop2;
- gfc_ss_info *info;
+ gfc_array_info *info;
tree offset;
tree tmp_index;
tree tmp;
|| GFC_DESCRIPTOR_TYPE_P (base_type))
base_type = gfc_get_element_type (base_type);
- loop.temp_ss = gfc_get_ss ();;
- loop.temp_ss->type = GFC_SS_TEMP;
- loop.temp_ss->data.temp.type = base_type;
+ loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
+ ? expr->ts.u.cl->backend_decl
+ : NULL),
+ loop.dimen);
- if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
- else
- loop.temp_ss->string_length = NULL;
-
- parmse->string_length = loop.temp_ss->string_length;
- loop.temp_ss->data.temp.dimen = loop.dimen;
- loop.temp_ss->next = gfc_ss_terminator;
+ parmse->string_length = loop.temp_ss->info->string_length;
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, loop.temp_ss);
gfc_conv_loop_setup (&loop, &expr->where);
/* Pass the temporary descriptor back to the caller. */
- info = &loop.temp_ss->data.info;
+ info = &loop.temp_ss->info->data.array;
parmse->expr = info->descriptor;
/* Setup the gfc_se structures. */
dimensions, so this is very simple. The offset is only computed
outside the innermost loop, so the overall transfer could be
optimized further. */
- info = &rse.ss->data.info;
- dimen = info->dimen;
+ info = &rse.ss->info->data.array;
+ dimen = rse.ss->dimen;
tmp_index = gfc_index_zero_node;
for (n = dimen - 1; n > 0; n--)
return 0;
}
+
/* Generate code for a procedure call. Note can return se->post != NULL.
If se->direct_byref is set then se->expr contains the return parameter.
Return nonzero, if the call has alternate specifiers.
tree fntype;
gfc_se parmse;
gfc_ss *argss;
- gfc_ss_info *info;
+ gfc_array_info *info;
int byref;
int parm_kind;
tree type;
{
if (!sym->attr.elemental)
{
- gcc_assert (se->ss->type == GFC_SS_FUNCTION);
- if (se->ss->useflags)
+ gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
+ if (se->ss->info->useflags)
{
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->attr.dimension)
return 0;
}
}
- info = &se->ss->data.info;
+ info = &se->ss->info->data.array;
}
else
info = NULL;
gfc_init_se (&parmse, se);
gfc_conv_derived_to_class (&parmse, e, fsym->ts);
}
- else if (se->ss && se->ss->useflags)
+ else if (se->ss && se->ss->info->useflags)
{
/* An elemental function inside a scalarized loop. */
gfc_init_se (&parmse, se);
else
goto end_pointer_check;
+ /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
+ allocatable to an optional dummy, cf. 12.5.2.12. */
+ if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ goto end_pointer_check;
+
if (attr.optional)
{
/* If the actual argument is an optional pointer/allocatable and
else
goto end_pointer_check;
+ tmp = parmse.expr;
+
+ /* If the argument is passed by value, we need to strip the
+ INDIRECT_REF. */
+ if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
cond = fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, parmse.expr,
- fold_convert (TREE_TYPE (parmse.expr),
+ boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp),
null_pointer_node));
}
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
msg);
- gfc_free (msg);
+ free (msg);
}
end_pointer_check:
if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
VEC_safe_push (tree, gc, stringargs, parmse.string_length);
+ /* For descriptorless coarrays and assumed-shape coarray dummies, we
+ pass the token and the offset as additional arguments. */
+ if (fsym && fsym->attr.codimension
+ && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && !fsym->attr.allocatable
+ && e == NULL)
+ {
+ /* Token and offset. */
+ VEC_safe_push (tree, gc, stringargs, null_pointer_node);
+ VEC_safe_push (tree, gc, stringargs,
+ build_int_cst (gfc_array_index_type, 0));
+ gcc_assert (fsym->attr.optional);
+ }
+ else if (fsym && fsym->attr.codimension
+ && !fsym->attr.allocatable
+ && gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tree caf_decl, caf_type;
+ tree offset, tmp2;
+
+ caf_decl = get_tree_for_caf_expr (e);
+ caf_type = TREE_TYPE (caf_decl);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ tmp = gfc_conv_descriptor_token (caf_decl);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+ tmp = GFC_DECL_TOKEN (caf_decl);
+ else
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+ tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+ }
+
+ VEC_safe_push (tree, gc, stringargs, tmp);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ offset = build_int_cst (gfc_array_index_type, 0);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+ offset = GFC_DECL_CAF_OFFSET (caf_decl);
+ else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
+ offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
+ else
+ offset = build_int_cst (gfc_array_index_type, 0);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ tmp = gfc_conv_descriptor_data_get (caf_decl);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (caf_type));
+ tmp = caf_decl;
+ }
+
+ if (fsym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
+ (TREE_TYPE (parmse.expr))));
+ tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+ tmp2 = gfc_conv_descriptor_data_get (tmp2);
+ }
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+ tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ tmp2 = parmse.expr;
+ }
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type, tmp2),
+ fold_convert (gfc_array_index_type, tmp));
+ offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+
+ VEC_safe_push (tree, gc, stringargs, offset);
+ }
+
VEC_safe_push (tree, gc, arglist, parmse.expr);
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&comp->ts);
- info->dimen = se->loop->dimen;
+ gcc_assert (se->ss->dimen == se->loop->dimen);
/* Evaluate the bounds of the result, if known. */
gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
returns a pointer, the temporary will be a shallow copy and
mustn't be deallocated. */
callee_alloc = comp->attr.allocatable || comp->attr.pointer;
- gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
- NULL_TREE, false, !comp->attr.pointer,
- callee_alloc, &se->ss->expr->where);
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
+ tmp, NULL_TREE, false,
+ !comp->attr.pointer, callee_alloc,
+ &se->ss->info->expr->where);
/* Pass the temporary as the first argument. */
result = info->descriptor;
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&ts);
- info->dimen = se->loop->dimen;
+ gcc_assert (se->ss->dimen == se->loop->dimen);
/* Evaluate the bounds of the result, if known. */
gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
returns a pointer, the temporary will be a shallow copy and
mustn't be deallocated. */
callee_alloc = sym->attr.allocatable || sym->attr.pointer;
- gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
- NULL_TREE, false, !sym->attr.pointer,
- callee_alloc, &se->ss->expr->where);
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
+ tmp, NULL_TREE, false,
+ !sym->attr.pointer, callee_alloc,
+ &se->ss->info->expr->where);
/* Pass the temporary as the first argument. */
result = info->descriptor;
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
with other functions. For dummy arguments, the typing is done to
- to this result, even if it has to be repeated for each call. */
+ this result, even if it has to be repeated for each call. */
if (has_alternate_specifier
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
{
/* For a simple char type, we can call memset(). */
if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
return build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMSET], 3, start,
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, start,
build_int_cst (gfc_get_int_type (gfc_c_int_kind),
lang_hooks.to_target_charset (' ')),
size);
fold_build2_loc (input_location, MINUS_EXPR, sizetype, i,
TYPE_SIZE_UNIT (type)));
gfc_add_modify (&loop, el,
- fold_build2_loc (input_location, POINTER_PLUS_EXPR,
- TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
+ fold_build_pointer_plus_loc (input_location,
+ el, TYPE_SIZE_UNIT (type)));
/* Making the loop... actually loop! */
tmp = gfc_finish_block (&loop);
cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
dlen);
tmp2 = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMMOVE],
- 3, dest, src, dlen);
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, dest, src, dlen);
/* Else copy and pad with spaces. */
tmp3 = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMMOVE],
- 3, dest, src, slen);
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, dest, src, slen);
- tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
- dest, fold_convert (sizetype, slen));
+ tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
tmp4 = fill_with_spaces (tmp4, chartype,
fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE(dlen), dlen, slen));
n = 0;
for (fargs = sym->formal; fargs; fargs = fargs->next)
n++;
- saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
- temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
+ saved_vars = XCNEWVEC (gfc_saved_var, n);
+ temp_vars = XCNEWVEC (tree, n);
for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
{
/* Restore the original variables. */
for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
gfc_restore_sym (fargs->sym, &saved_vars[n]);
- gfc_free (saved_vars);
+ free (saved_vars);
}
static void
gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
{
- gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
- gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
+ gfc_ss *ss;
+
+ ss = se->ss;
+ gcc_assert (ss != NULL && ss != gfc_ss_terminator);
+ gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
gfc_conv_tmp_array_ref (se);
}
gfc_se lse;
gfc_ss *rss;
gfc_ss *lss;
+ gfc_array_info *lss_array;
stmtblock_t body;
stmtblock_t block;
gfc_loopinfo loop;
/* Walk the rhs. */
rss = gfc_walk_expr (expr);
if (rss == gfc_ss_terminator)
- {
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_ss ();
- rss->next = gfc_ss_terminator;
- rss->type = GFC_SS_SCALAR;
- rss->expr = expr;
- }
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
/* Create a SS for the destination. */
- lss = gfc_get_ss ();
- lss->type = GFC_SS_COMPONENT;
- lss->expr = NULL;
- lss->shape = gfc_get_shape (cm->as->rank);
- lss->next = gfc_ss_terminator;
- lss->data.info.dimen = cm->as->rank;
- lss->data.info.descriptor = dest;
- lss->data.info.data = gfc_conv_array_data (dest);
- lss->data.info.offset = gfc_conv_array_offset (dest);
+ lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
+ GFC_SS_COMPONENT);
+ lss_array = &lss->info->data.array;
+ lss_array->shape = gfc_get_shape (cm->as->rank);
+ lss_array->descriptor = dest;
+ lss_array->data = gfc_conv_array_data (dest);
+ lss_array->offset = gfc_conv_array_offset (dest);
for (n = 0; n < cm->as->rank; n++)
{
- lss->data.info.dim[n] = n;
- lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
- lss->data.info.stride[n] = gfc_index_one_node;
+ lss_array->start[n] = gfc_conv_array_lbound (dest, n);
+ lss_array->stride[n] = gfc_index_one_node;
- mpz_init (lss->shape[n]);
- mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
+ mpz_init (lss_array->shape[n]);
+ mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
cm->as->lower[n]->value.integer);
- mpz_add_ui (lss->shape[n], lss->shape[n], 1);
+ mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
}
/* Associate the SS with the loop. */
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
- for (n = 0; n < cm->as->rank; n++)
- mpz_clear (lss->shape[n]);
- gfc_free (lss->shape);
-
+ gcc_assert (lss_array->shape != NULL);
+ gfc_free_shape (&lss_array->shape, cm->as->rank);
gfc_cleanup_loop (&loop);
return gfc_finish_block (&block);
void
gfc_conv_expr (gfc_se * se, gfc_expr * expr)
{
- if (se->ss && se->ss->expr == expr
- && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
+ gfc_ss *ss;
+
+ ss = se->ss;
+ if (ss && ss->info->expr == expr
+ && (ss->info->type == GFC_SS_SCALAR
+ || ss->info->type == GFC_SS_REFERENCE))
{
+ gfc_ss_info *ss_info;
+
+ ss_info = ss->info;
/* Substitute a scalar expression evaluated outside the scalarization
loop. */
- se->expr = se->ss->data.scalar.expr;
- if (se->ss->type == GFC_SS_REFERENCE)
+ se->expr = ss_info->data.scalar.value;
+ if (ss_info->type == GFC_SS_REFERENCE)
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
- se->string_length = se->ss->string_length;
+ se->string_length = ss_info->string_length;
gfc_advance_se_ss_chain (se);
return;
}
void
gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
{
+ gfc_ss *ss;
tree var;
- if (se->ss && se->ss->expr == expr
- && se->ss->type == GFC_SS_REFERENCE)
+ ss = se->ss;
+ if (ss && ss->info->expr == expr
+ && ss->info->type == GFC_SS_REFERENCE)
{
/* Returns a reference to the scalar evaluated outside the loop
for this case. */
if (gfc_ref_needs_temporary_p (expr1->ref))
return true;
- /* Functions returning pointers need temporaries. */
- if (expr2->symtree->n.sym->attr.pointer
- || expr2->symtree->n.sym->attr.allocatable)
+ /* Functions returning pointers or allocatables need temporaries. */
+ c = expr2->value.function.esym
+ ? (expr2->value.function.esym->attr.pointer
+ || expr2->value.function.esym->attr.allocatable)
+ : (expr2->symtree->n.sym->attr.pointer
+ || expr2->symtree->n.sym->attr.allocatable);
+ if (c)
return true;
/* Character array functions need temporaries unless the
return true;
/* If we have reached here with an intrinsic function, we do not
- need a temporary. */
+ need a temporary except in the particular case that reallocation
+ on assignment is active and the lhs is allocatable and a target. */
if (expr2->value.function.isym)
- return false;
+ return (gfc_option.flag_realloc_lhs
+ && sym->attr.allocatable
+ && sym->attr.target);
/* If the LHS is a dummy, we need a temporary if it is not
INTENT(OUT). */
reallocatable assignments from extrinsic function calls. */
static void
-realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
+realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
+ gfc_loopinfo *loop)
{
- gfc_loopinfo loop;
/* Signal that the function call should not be made by
gfc_conv_loop_setup. */
se->ss->is_alloc_lhs = 1;
- gfc_init_loopinfo (&loop);
- gfc_add_ss_to_loop (&loop, *ss);
- gfc_add_ss_to_loop (&loop, se->ss);
- gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, where);
- gfc_copy_loopinfo_to_se (se, &loop);
- gfc_add_block_to_block (&se->pre, &loop.pre);
- gfc_add_block_to_block (&se->pre, &loop.post);
+ gfc_init_loopinfo (loop);
+ gfc_add_ss_to_loop (loop, *ss);
+ gfc_add_ss_to_loop (loop, se->ss);
+ gfc_conv_ss_startstride (loop);
+ gfc_conv_loop_setup (loop, where);
+ gfc_copy_loopinfo_to_se (se, loop);
+ gfc_add_block_to_block (&se->pre, &loop->pre);
+ gfc_add_block_to_block (&se->pre, &loop->post);
se->ss->is_alloc_lhs = 0;
}
+/* For Assignment to a reallocatable lhs from intrinsic functions,
+ replace the se.expr (ie. the result) with a temporary descriptor.
+ Null the data field so that the library allocates space for the
+ result. Free the data of the original descriptor after the function,
+ in case it appears in an argument expression and transfer the
+ result to the original descriptor. */
+
static void
-realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+fcncall_realloc_result (gfc_se *se, int rank)
{
tree desc;
+ tree res_desc;
tree tmp;
tree offset;
int n;
- /* Use the allocation done by the library. */
+ /* Use the allocation done by the library. Substitute the lhs
+ descriptor with a copy, whose data field is nulled.*/
desc = build_fold_indirect_ref_loc (input_location, se->expr);
- tmp = gfc_conv_descriptor_data_get (desc);
- tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
- gfc_add_expr_to_block (&se->pre, tmp);
- gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
/* Unallocated, the descriptor does not have a dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ res_desc = gfc_evaluate_now (desc, &se->pre);
+ gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
+ se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
+
+ /* Free the lhs after the function call and copy the result to
+ the lhs descriptor. */
+ tmp = gfc_conv_descriptor_data_get (desc);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+ gfc_add_expr_to_block (&se->post, tmp);
+ gfc_add_modify (&se->post, desc, res_desc);
offset = gfc_index_zero_node;
tmp = gfc_index_one_node;
gfc_se se;
gfc_ss *ss;
gfc_component *comp = NULL;
+ gfc_loopinfo loop;
if (arrayfunc_assign_needs_temporary (expr1, expr2))
return NULL;
{
if (!expr2->value.function.isym)
{
- realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
+ realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
ss->is_alloc_lhs = 1;
}
else
- realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
+ fcncall_realloc_result (&se, expr1->rank);
}
gfc_conv_function_expr (&se, expr2);
/* Construct call to __builtin_memset. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMSET],
- 3, dest, integer_zero_node, len);
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, dest, integer_zero_node, len);
return fold_convert (void_type_node, tmp);
}
/* Construct call to __builtin_memcpy. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
+ 3, dst, src, len);
return fold_convert (void_type_node, tmp);
}
}
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MALLOC], 1,
- size_in_bytes);
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1, size_in_bytes);
tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
gfc_add_modify (block, lse.expr, tmp);
if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
build_empty_stmt (input_location));
gfc_add_expr_to_block (block, tmp);
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_REALLOC], 2,
- fold_convert (pvoid_type_node, lse.expr),
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2, fold_convert (pvoid_type_node, lse.expr),
size_in_bytes);
tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
gfc_add_modify (block, lse.expr, tmp);
rss = NULL;
if (lss != gfc_ss_terminator)
{
- /* Allow the scalarizer to workshare array assignments. */
- if (ompws_flags & OMPWS_WORKSHARE_FLAG)
- ompws_flags |= OMPWS_SCALARIZER_WS;
-
/* The assignment needs scalarization. */
lss_section = lss;
/* Find a non-scalar SS from the lhs. */
while (lss_section != gfc_ss_terminator
- && lss_section->type != GFC_SS_SECTION)
+ && lss_section->info->type != GFC_SS_SECTION)
lss_section = lss_section->next;
gcc_assert (lss_section != gfc_ss_terminator);
/* Walk the rhs. */
rss = gfc_walk_expr (expr2);
if (rss == gfc_ss_terminator)
- {
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_ss ();
- rss->next = gfc_ss_terminator;
- rss->type = GFC_SS_SCALAR;
- rss->expr = expr2;
- }
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop);
/* Enable loop reversal. */
- for (n = 0; n < loop.dimen; n++)
- loop.reverse[n] = GFC_REVERSE_NOT_SET;
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
gfc_mark_ss_chain_used (loop.temp_ss, 3);
}
+ /* Allow the scalarizer to workshare array assignments. */
+ if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
+ ompws_flags |= OMPWS_SCALARIZER_WS;
+
/* Start the scalarized loop body. */
gfc_start_scalarized_body (&loop, &body);
}
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
l_is_temp || init_flag,
- expr_is_variable (expr2) || scalar_to_array,
- dealloc);
+ expr_is_variable (expr2) || scalar_to_array
+ || expr2->expr_type == EXPR_ARRAY, dealloc);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
&& !gfc_expr_attr (expr1).codimension
&& !gfc_is_coindexed (expr1))
{
+ ompws_flags &= ~OMPWS_SCALARIZER_WS;
tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
if (tmp != NULL_TREE)
gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
OSDN Git Service
