{
tree dest, src, dest_index, src_index;
gfc_loopinfo *loop;
- gfc_ss_info *dest_info, *src_info;
+ gfc_ss_info *dest_info;
gfc_ss *dest_ss, *src_ss;
gfc_se src_se;
int n;
src_ss = gfc_walk_expr (expr);
dest_ss = se->ss;
- src_info = &src_ss->data.info;
dest_info = &dest_ss->data.info;
gcc_assert (dest_info->dimen == 2);
- gcc_assert (src_info->dimen == 2);
/* Get a descriptor for EXPR. */
gfc_init_se (&src_se, NULL);
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 (depends[n])
loop->order[dim++] = n;
}
- temp_dim = dim;
for (n = 0; n < loop->dimen; n++)
{
if (! depends[n])
gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
{
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];
bool dynamic[GFC_MAX_DIMENSIONS];
gfc_constructor *c;
loop->temp_ss->string_length);
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;
for (n = 0; n < info->dimen; n++)
{
- dim = info->dim[n];
-
/* If we are specifying the range the delta is already set. */
if (loopspec[n] != ss)
{
{
/* Problems occur when we get something like
integer :: a(lots) = (/(i, i=1, lots)/) */
- gfc_error_now ("The number of elements in the array constructor "
- "at %L requires an increase of the allowed %d "
- "upper limit. See -fmax-array-constructor "
- "option", &expr->where,
- gfc_option.flag_max_array_constructor);
+ gfc_fatal_error ("The number of elements in the array constructor "
+ "at %L requires an increase of the allowed %d "
+ "upper limit. See -fmax-array-constructor "
+ "option", &expr->where,
+ gfc_option.flag_max_array_constructor);
return NULL_TREE;
}
if (mpz_cmp_si (c->n.offset, 0) != 0)
/* TODO: Optimize passing g77 arrays. */
void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
const gfc_symbol *fsym, const char *proc_name,
tree *size)
{
tree tmp = NULL_TREE;
tree stmt;
tree parent = DECL_CONTEXT (current_function_decl);
- bool full_array_var, this_array_result;
+ bool full_array_var;
+ bool this_array_result;
+ bool contiguous;
+ bool no_pack;
gfc_symbol *sym;
stmtblock_t block;
+ gfc_ref *ref;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->next == NULL)
+ break;
+
+ full_array_var = false;
+ contiguous = false;
+
+ if (expr->expr_type == EXPR_VARIABLE && ref)
+ full_array_var = gfc_full_array_ref_p (ref, &contiguous);
- full_array_var = (expr->expr_type == EXPR_VARIABLE
- && expr->ref->type == REF_ARRAY
- && expr->ref->u.ar.type == AR_FULL);
sym = full_array_var ? expr->symtree->n.sym : NULL;
/* The symbol should have an array specification. */
- gcc_assert (!sym || sym->as);
+ gcc_assert (!sym || sym->as || ref->u.ar.as);
if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
{
if (sym->ts.type == BT_CHARACTER)
se->string_length = sym->ts.u.cl->backend_decl;
- if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+
+ if (sym->ts.type == BT_DERIVED && !sym->as)
+ {
+ gfc_conv_expr_descriptor (se, expr, ss);
+ se->expr = gfc_conv_array_data (se->expr);
+ return;
+ }
+
+ if (!sym->attr.pointer
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
array_parameter_size (tmp, expr, size);
return;
}
+
if (sym->attr.allocatable)
{
if (sym->attr.dummy || sym->attr.result)
}
}
+ /* There is no need to pack and unpack the array, if it is an array
+ constructor or contiguous and not deferred or assumed shape. */
+ no_pack = ((sym && sym->as
+ && !sym->attr.pointer
+ && sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_SHAPE)
+ ||
+ (ref && ref->u.ar.as
+ && ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
+
+ no_pack = g77 && !this_array_result
+ && (expr->expr_type == EXPR_ARRAY || (contiguous && no_pack));
+
+ if (no_pack)
+ {
+ gfc_conv_expr_descriptor (se, expr, ss);
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = expr->ts.u.cl->backend_decl;
+ if (size)
+ array_parameter_size (se->expr, expr, size);
+ se->expr = gfc_conv_array_data (se->expr);
+ return;
+ }
+
+ if (expr->expr_type == EXPR_ARRAY && g77)
+ {
+ gfc_conv_expr_descriptor (se, expr, ss);
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = expr->ts.u.cl->backend_decl;
+ if (size)
+ array_parameter_size (se->expr, expr, size);
+ se->expr = gfc_conv_array_data (se->expr);
+ return;
+ }
+
if (this_array_result)
{
/* Result of the enclosing function. */
{
desc = se->expr;
/* Repack the array. */
-
if (gfc_option.warn_array_temp)
{
if (fsym)
}
-/* Allocate dest to the same size as src, and copy src -> dest. */
+/* Allocate dest to the same size as src, and copy src -> dest.
+ If no_malloc is set, only the copy is done. */
-tree
-gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
+static tree
+duplicate_allocatable(tree dest, tree src, tree type, int rank,
+ bool no_malloc)
{
tree tmp;
tree size;
tree null_data;
stmtblock_t block;
- /* If the source is null, set the destination to null. */
+ /* If the source is null, set the destination to null. Then,
+ allocate memory to the destination. */
gfc_init_block (&block);
- gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- null_data = gfc_finish_block (&block);
- gfc_init_block (&block);
+ if (rank == 0)
+ {
+ tmp = null_pointer_node;
+ tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+ null_data = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ size = TYPE_SIZE_UNIT (type);
+ if (!no_malloc)
+ {
+ tmp = gfc_call_malloc (&block, type, size);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
+ fold_convert (type, tmp));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ tmp = built_in_decls[BUILT_IN_MEMCPY];
+ tmp = build_call_expr_loc (input_location, tmp, 3,
+ dest, src, size);
+ }
+ else
+ {
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ null_data = gfc_finish_block (&block);
+
+ gfc_init_block (&block);
+ nelems = get_full_array_size (&block, src, rank);
+ tmp = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
+ if (!no_malloc)
+ {
+ tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
+ tmp = gfc_call_malloc (&block, tmp, size);
+ gfc_conv_descriptor_data_set (&block, dest, tmp);
+ }
+
+ /* We know the temporary and the value will be the same length,
+ so can use memcpy. */
+ tmp = built_in_decls[BUILT_IN_MEMCPY];
+ tmp = build_call_expr_loc (input_location,
+ tmp, 3, gfc_conv_descriptor_data_get (dest),
+ gfc_conv_descriptor_data_get (src), size);
+ }
- nelems = get_full_array_size (&block, src, rank);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
- fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type))));
-
- /* Allocate memory to the destination. */
- tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
- size);
- gfc_conv_descriptor_data_set (&block, dest, tmp);
-
- /* We know the temporary and the value will be the same length,
- so can use memcpy. */
- tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = build_call_expr_loc (input_location,
- tmp, 3, gfc_conv_descriptor_data_get (dest),
- gfc_conv_descriptor_data_get (src), size);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
/* Null the destination if the source is null; otherwise do
the allocate and copy. */
- null_cond = gfc_conv_descriptor_data_get (src);
+ if (rank == 0)
+ null_cond = src;
+ else
+ null_cond = gfc_conv_descriptor_data_get (src);
+
null_cond = convert (pvoid_type_node, null_cond);
null_cond = fold_build2 (NE_EXPR, boolean_type_node,
null_cond, null_pointer_node);
}
+/* Allocate dest to the same size as src, and copy data src -> dest. */
+
+tree
+gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
+{
+ return duplicate_allocatable(dest, src, type, rank, false);
+}
+
+
+/* Copy data src -> dest. */
+
+tree
+gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
+{
+ return duplicate_allocatable(dest, src, type, rank, true);
+}
+
+
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
-enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
+enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
+ COPY_ONLY_ALLOC_COMP};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_init_block (&fnblock);
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
decl = build_fold_indirect_ref_loc (input_location,
decl);
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
+ else if (purpose == COPY_ONLY_ALLOC_COMP)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location,
+ gfc_conv_array_data (dest));
+ dref = gfc_build_array_ref (tmp, index, NULL);
+ tmp = structure_alloc_comps (der_type, vref, dref, rank,
+ COPY_ALLOC_COMP);
+ }
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
tmp = gfc_trans_dealloc_allocated (comp);
gfc_add_expr_to_block (&fnblock, tmp);
}
+ else if (c->attr.allocatable)
+ {
+ /* Allocatable scalar components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+
+ tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&fnblock, tmp);
+
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.allocatable)
+ {
+ /* Allocatable scalar CLASS components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+
+ /* Add reference to '$data' component. */
+ tmp = c->ts.u.derived->components->backend_decl;
+ comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ comp, tmp, NULL_TREE);
+
+ tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&fnblock, tmp);
+
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
break;
case NULLIFY_ALLOC_COMP:
decl, cdecl, NULL_TREE);
gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node);
}
+ else if (c->attr.allocatable)
+ {
+ /* Allocatable scalar components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else if (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.allocatable)
+ {
+ /* Allocatable scalar CLASS components. */
+ comp = fold_build3 (COMPONENT_REF, ctype, decl, cdecl, NULL_TREE);
+ /* Add reference to '$data' component. */
+ tmp = c->ts.u.derived->components->backend_decl;
+ comp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ comp, tmp, NULL_TREE);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node, comp,
+ build_int_cst (TREE_TYPE (comp), 0));
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
else if (cmp_has_alloc_comps)
{
comp = fold_build3 (COMPONENT_REF, ctype,
if (c->attr.allocatable && !cmp_has_alloc_comps)
{
- tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
+ rank = c->as ? c->as->rank : 0;
+ tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
/* Recursively traverse an object of derived type, generating code to
- copy its allocatable components. */
+ copy it and its allocatable components. */
tree
gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
}
+/* Recursively traverse an object of derived type, generating code to
+ copy only its allocatable components. */
+
+tree
+gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+{
+ return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
+}
+
+
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
Do likewise, recursively if necessary, with the allocatable components of
derived types. */
gfc_ref *ref;
gfc_array_ref *ar;
gfc_ss *newss;
- gfc_ss *head;
int n;
for (ref = expr->ref; ref; ref = ref->next)
newss->data.info.dimen = 0;
newss->data.info.ref = ref;
- head = newss;
-
/* We add SS chains for all the subscripts in the section. */
for (n = 0; n < ar->dimen; n++)
{
OSDN Git Service
