}
+/* 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. */
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;
+ se->string_length = ss_info->string_length;
for (ref = se->ss->data.info.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);
}
}
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;
-
- if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
- else
- loop.temp_ss->string_length = NULL;
+ loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
+ ? expr->ts.u.cl->backend_decl
+ : NULL),
+ loop.dimen);
- 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);
outside the innermost loop, so the overall transfer could be
optimized further. */
info = &rse.ss->data.info;
- dimen = info->dimen;
+ 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);
+ gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
if (se->ss->useflags)
{
gcc_assert ((!comp && gfc_return_by_reference (sym)
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->loop, 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->loop, 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;
/* 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->data.info;
+ 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. */
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). */
result to the original descriptor. */
static void
-fcncall_realloc_result (gfc_se *se)
+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. Substitute the lhs
descriptor with a copy, whose data field is nulled.*/
desc = build_fold_indirect_ref_loc (input_location, se->expr);
+ /* 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 data to
- it. */
+ /* 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);
- tmp = gfc_conv_descriptor_data_get (res_desc);
- gfc_conv_descriptor_data_set (&se->post, desc, tmp);
+ gfc_add_modify (&se->post, desc, res_desc);
- /* Unallocated, the descriptor does not have a dtype. */
- tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (&se->post, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ offset = gfc_index_zero_node;
+ tmp = gfc_index_one_node;
+ /* Now reset the bounds from zero based to unity based. */
+ for (n = 0 ; n < rank; n++)
+ {
+ /* Accumulate the offset. */
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, tmp);
+ /* Now do the bounds. */
+ gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
+ tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_conv_descriptor_lbound_set (&se->post, desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&se->post, desc,
+ gfc_rank_cst[n], tmp);
+
+ /* The extent for the next contribution to offset. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
+ gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ }
+ gfc_conv_descriptor_offset_set (&se->post, desc, offset);
}
ss->is_alloc_lhs = 1;
}
else
- fcncall_realloc_result (&se);
+ 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
