bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
- tree errlen, gfc_expr *expr3)
+ tree errlen, tree label_finish, gfc_expr *expr3)
{
tree tmp;
tree pointer;
/* The allocatable variant takes the old pointer as first argument. */
if (allocatable)
gfc_allocate_allocatable (&elseblock, pointer, size, token,
- status, errmsg, errlen, expr);
+ status, errmsg, errlen, label_finish, expr);
else
gfc_allocate_using_malloc (&elseblock, pointer, size, status);
/*GCC ARRAYS*/
tree
-gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
+gfc_array_deallocate (tree descriptor, tree pstat, tree errmsg, tree errlen,
+ tree label_finish, gfc_expr* expr)
{
tree var;
tree tmp;
stmtblock_t block;
+ bool coarray = gfc_is_coarray (expr);
gfc_start_block (&block);
+
/* Get a pointer to the data. */
var = gfc_conv_descriptor_data_get (descriptor);
STRIP_NOPS (var);
/* Parameter is the address of the data component. */
- tmp = gfc_deallocate_with_status (var, pstat, false, expr);
+ tmp = gfc_deallocate_with_status (coarray ? descriptor : var, pstat, errmsg,
+ errlen, label_finish, false, expr, coarray);
gfc_add_expr_to_block (&block, tmp);
- /* Zero the data pointer. */
+ /* Zero the data pointer; only for coarrays an error can occur and then
+ the allocation status may not be changed. */
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
var, build_int_cst (TREE_TYPE (var), 0));
+ if (pstat != NULL_TREE && coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tree cond;
+ tree stat = build_fold_indirect_ref_loc (input_location, pstat);
+
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ stat, build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, tmp, build_empty_stmt (input_location));
+ }
+
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
/* Generate code to deallocate an array, if it is allocated. */
tree
-gfc_trans_dealloc_allocated (tree descriptor)
+gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
{
tree tmp;
tree var;
/* Call array_deallocate with an int * present in the second argument.
Although it is ignored here, it's presence ensures that arrays that
are already deallocated are ignored. */
- tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
+ tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
+ NULL_TREE, NULL_TREE, NULL_TREE, true,
+ NULL, coarray);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
- tmp = gfc_trans_dealloc_allocated (comp);
+ tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (c->attr.allocatable)
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp)))
- tmp = gfc_trans_dealloc_allocated (comp);
+ tmp = gfc_trans_dealloc_allocated (comp,
+ CLASS_DATA (c)->attr.codimension);
else
{
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
&& !sym->attr.save && !sym->attr.result)
{
- tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
+ tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
+ sym->attr.codimension);
gfc_add_expr_to_block (&cleanup, tmp);
}
}
-/* Walk the arguments of an elemental function. */
+/* Walk the arguments of an elemental function.
+ PROC_EXPR is used to check whether an argument is permitted to be absent. If
+ it is NULL, we don't do the check and the argument is assumed to be present.
+*/
gfc_ss *
gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
- gfc_ss_type type)
+ gfc_expr *proc_expr, gfc_ss_type type)
{
+ gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
gfc_ss *tail;
head = gfc_ss_terminator;
tail = NULL;
+
+ if (proc_expr)
+ {
+ gfc_ref *ref;
+
+ /* Normal procedure case. */
+ dummy_arg = proc_expr->symtree->n.sym->formal;
+
+ /* Typebound procedure case. */
+ for (ref = proc_expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->ts.interface)
+ dummy_arg = ref->u.c.component->ts.interface->formal;
+ else
+ dummy_arg = NULL;
+ }
+ }
+ else
+ dummy_arg = NULL;
+
scalar = 1;
for (; arg; arg = arg->next)
{
- if (!arg->expr)
+ if (!arg->expr || arg->expr->expr_type == EXPR_NULL)
continue;
newss = gfc_walk_subexpr (head, arg->expr);
gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
newss = gfc_get_scalar_ss (head, arg->expr);
newss->info->type = type;
+
+ if (dummy_arg != NULL
+ && dummy_arg->sym->attr.optional
+ && arg->expr->symtree
+ && arg->expr->symtree->n.sym->attr.optional
+ && arg->expr->ref == NULL)
+ newss->info->data.scalar.can_be_null_ref = true;
}
else
scalar = 0;
while (tail->next != gfc_ss_terminator)
tail = tail->next;
}
+
+ if (dummy_arg != NULL)
+ dummy_arg = dummy_arg->next;
}
if (scalar)
by reference. */
if (sym->attr.elemental || (comp && comp->attr.elemental))
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
- GFC_SS_REFERENCE);
+ expr, GFC_SS_REFERENCE);
/* Scalar functions are OK as these are evaluated outside the scalarization
loop. Pass back and let the caller deal with it. */