gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow,
- gfc_expr *expr3)
+ tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
{
tree type;
tree tmp;
/* The stride is the number of elements in the array, so multiply by the
size of an element to get the total size. Obviously, if there ia a
SOURCE expression (expr3) we must use its element size. */
- if (expr3 != NULL)
+ if (expr3_elem_size != NULL_TREE)
+ tmp = expr3_elem_size;
+ else if (expr3 != NULL)
{
if (expr3->ts.type == BT_CLASS)
{
if (rank == 0)
return element_size;
+ *nelems = gfc_evaluate_now (stride, pblock);
stride = fold_convert (size_type_node, stride);
/* First check for overflow. Since an array of type character can
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
- tree errlen, tree label_finish, gfc_expr *expr3)
+ tree errlen, tree label_finish, tree expr3_elem_size,
+ tree *nelems, gfc_expr *expr3)
{
tree tmp;
tree pointer;
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3);
+ expr3_elem_size, nelems, expr3);
if (dimension)
{
gfc_start_block (&elseblock);
/* Allocate memory to store the data. */
+ if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
gfc_add_expr_to_block (&se->pre, tmp);
- if (expr->ts.type == BT_CLASS && expr3)
+ if (expr->ts.type == BT_CLASS)
{
tmp = build_int_cst (unsigned_char_type_node, 0);
/* With class objects, it is best to play safe and null the
cdecl, NULL_TREE);
dcmp = fold_convert (TREE_TYPE (comp), dcmp);
+ if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+ {
+ tree ftn_tree;
+ tree size;
+ tree dst_data;
+ tree src_data;
+ tree null_data;
+
+ dst_data = gfc_class_data_get (dcmp);
+ src_data = gfc_class_data_get (comp);
+ size = fold_convert (size_type_node, gfc_vtable_size_get (comp));
+
+ if (CLASS_DATA (c)->attr.dimension)
+ {
+ nelems = gfc_conv_descriptor_size (src_data,
+ CLASS_DATA (c)->as->rank);
+ src_data = gfc_conv_descriptor_data_get (src_data);
+ dst_data = gfc_conv_descriptor_data_get (dst_data);
+ }
+ else
+ nelems = build_int_cst (size_type_node, 1);
+
+ gfc_init_block (&tmpblock);
+
+ /* We need to use CALLOC as _copy might try to free allocatable
+ components of the destination. */
+ ftn_tree = builtin_decl_explicit (BUILT_IN_CALLOC);
+ tmp = build_call_expr_loc (input_location, ftn_tree, 2, nelems,
+ size);
+ gfc_add_modify (&tmpblock, dst_data,
+ fold_convert (TREE_TYPE (dst_data), tmp));
+
+ tmp = gfc_copy_class_to_class (comp, dcmp, nelems);
+ gfc_add_expr_to_block (&tmpblock, tmp);
+ tmp = gfc_finish_block (&tmpblock);
+
+ gfc_init_block (&tmpblock);
+ gfc_add_modify (&tmpblock, dst_data,
+ fold_convert (TREE_TYPE (dst_data),
+ null_pointer_node));
+ null_data = gfc_finish_block (&tmpblock);
+
+ null_cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, src_data,
+ null_pointer_node);
+
+ gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
+ tmp, null_data));
+ continue;
+ }
+
if (c->attr.allocatable && !cmp_has_alloc_comps)
{
rank = c->as ? c->as->rank : 0;
}
+/* Given an expression refering to a procedure, return the symbol of its
+ interface. We can't get the procedure symbol directly as we have to handle
+ the case of (deferred) type-bound procedures. */
+
+gfc_symbol *
+gfc_get_proc_ifc_for_expr (gfc_expr *procedure_ref)
+{
+ gfc_symbol *sym;
+ gfc_ref *ref;
+
+ if (procedure_ref == NULL)
+ return NULL;
+
+ /* Normal procedure case. */
+ sym = procedure_ref->symtree->n.sym;
+
+ /* Typebound procedure case. */
+ for (ref = procedure_ref->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.proc_pointer)
+ sym = ref->u.c.component->ts.interface;
+ else
+ sym = NULL;
+ }
+
+ return sym;
+}
+
+
/* 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_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg,
gfc_expr *proc_expr, gfc_ss_type type)
{
+ gfc_symbol *proc_ifc;
gfc_formal_arglist *dummy_arg;
int scalar;
gfc_ss *head;
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;
- }
- }
+ proc_ifc = gfc_get_proc_ifc_for_expr (proc_expr);
+ if (proc_ifc)
+ dummy_arg = proc_ifc->formal;
else
dummy_arg = NULL;
if (dummy_arg != NULL
&& dummy_arg->sym->attr.optional
- && arg->expr->symtree
- && arg->expr->symtree->n.sym->attr.optional
- && arg->expr->ref == NULL)
+ && arg->expr->expr_type == EXPR_VARIABLE
+ && (gfc_expr_attr (arg->expr).optional
+ || gfc_expr_attr (arg->expr).allocatable
+ || gfc_expr_attr (arg->expr).pointer))
newss->info->data.scalar.can_be_null_ref = true;
}
else
OSDN Git Service
