/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
length = NULL; /* To silence compiler warning. */
- if (is_subref_array (e) && e->ts.cl->length)
+ if (is_subref_array (e) && e->ts.u.cl->length)
{
gfc_se tmpse;
gfc_init_se (&tmpse, NULL);
- gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
- e->ts.cl->backend_decl = tmpse.expr;
+ gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node);
+ e->ts.u.cl->backend_decl = tmpse.expr;
return tmpse.expr;
}
expression's length could be the length of the character
variable. */
if (e->symtree->n.sym->ts.type == BT_CHARACTER)
- length = e->symtree->n.sym->ts.cl->backend_decl;
+ length = e->symtree->n.sym->ts.u.cl->backend_decl;
/* Look through the reference chain for component references. */
for (r = e->ref; r; r = r->next)
{
case REF_COMPONENT:
if (r->u.c.component->ts.type == BT_CHARACTER)
- length = r->u.c.component->ts.cl->backend_decl;
+ length = r->u.c.component->ts.u.cl->backend_decl;
break;
case REF_ARRAY:
}
-/* For each character array constructor subexpression without a ts.cl->length,
+/* 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). */
case EXPR_ARRAY:
/* We've found what we're looking for. */
- if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
+ if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
{
gfc_expr* new_expr;
gcc_assert (e->value.constructor);
{
tree tmp;
tree type;
- tree var;
tree fault;
gfc_se start;
gfc_se end;
type = gfc_get_character_type (kind, ref->u.ss.length);
type = build_pointer_type (type);
- var = NULL_TREE;
gfc_init_se (&start, se);
gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &start.pre);
gfc_conv_string_parameter (se);
else
{
+ tmp = start.expr;
+ STRIP_NOPS (tmp);
/* Avoid multiple evaluation of substring start. */
- if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
+ if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
start.expr = gfc_evaluate_now (start.expr, &se->pre);
/* Change the start of the string. */
gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
gfc_add_block_to_block (&se->pre, &end.pre);
}
- if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
+ tmp = end.expr;
+ STRIP_NOPS (tmp);
+ if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp))
end.expr = gfc_evaluate_now (end.expr, &se->pre);
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
}
tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
- build_int_cst (gfc_charlen_type_node, 1),
- start.expr);
- tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
+ end.expr, start.expr);
+ tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node,
+ build_int_cst (gfc_charlen_type_node, 1), tmp);
tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
build_int_cst (gfc_charlen_type_node, 0));
se->string_length = tmp;
se->expr = tmp;
- if (c->ts.type == BT_CHARACTER)
+ if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer)
{
- tmp = c->ts.cl->backend_decl;
+ tmp = c->ts.u.cl->backend_decl;
/* Components must always be constant length. */
gcc_assert (tmp && INTEGER_CST_P (tmp));
se->string_length = tmp;
}
- if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+ if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
+ && c->ts.type != BT_CHARACTER)
|| c->attr.proc_pointer)
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
if (dt->attr.extension && dt->components)
{
+ if (dt->attr.is_class)
+ cmp = dt->components;
+ else
+ cmp = dt->components->next;
/* Return if the component is not in the parent type. */
- for (cmp = dt->components->next; cmp; cmp = cmp->next)
+ for (; cmp; cmp = cmp->next)
if (strcmp (c->name, cmp->name) == 0)
return;
/* Otherwise build the reference and call self. */
gfc_conv_component_ref (se, &parent);
- parent.u.c.sym = dt->components->ts.derived;
+ parent.u.c.sym = dt->components->ts.u.derived;
parent.u.c.component = c;
conv_parent_component_references (se, &parent);
}
{
/* If the character length of an entry isn't set, get the length from
the master function instead. */
- if (sym->attr.entry && !sym->ts.cl->backend_decl)
- se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
+ if (sym->attr.entry && !sym->ts.u.cl->backend_decl)
+ se->string_length = sym->ns->proc_name->ts.u.cl->backend_decl;
else
- se->string_length = sym->ts.cl->backend_decl;
+ se->string_length = sym->ts.u.cl->backend_decl;
gcc_assert (se->string_length);
}
separately. */
if (se->want_pointer)
{
- if (expr->ts.type == BT_CHARACTER)
+ if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL))
gfc_conv_string_parameter (se);
else
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
tree var;
tree tmp;
- gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
+ gcc_assert (types_compatible_p (TREE_TYPE (len), gfc_charlen_type_node));
if (gfc_can_put_var_on_stack (len))
{
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
- type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
+ type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
if (len == NULL_TREE)
{
return tmp;
}
+
+/* Return the backend_decl for a procedure pointer component. */
+
+static tree
+get_proc_ptr_comp (gfc_expr *e)
+{
+ gfc_se comp_se;
+ gfc_expr *e2;
+ gfc_init_se (&comp_se, NULL);
+ e2 = gfc_copy_expr (e);
+ e2->expr_type = EXPR_VARIABLE;
+ gfc_conv_expr (&comp_se, e2);
+ gfc_free_expr (e2);
+ return build_fold_addr_expr_loc (input_location, comp_se.expr);
+}
+
+
+/* Select a class typebound procedure at runtime. */
+static void
+select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
+ tree declared, gfc_expr *expr)
+{
+ tree end_label;
+ tree label;
+ tree tmp;
+ tree hash;
+ stmtblock_t body;
+ gfc_class_esym_list *next_elist, *tmp_elist;
+ gfc_se tmpse;
+
+ /* Convert the hash expression. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr (&tmpse, elist->hash_value);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ hash = gfc_evaluate_now (tmpse.expr, &se->pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+
+ /* Fix the function type to be that of the declared type method. */
+ declared = gfc_create_var (TREE_TYPE (declared), "method");
+
+ end_label = gfc_build_label_decl (NULL_TREE);
+
+ gfc_init_block (&body);
+
+ /* Go through the list of extensions. */
+ for (; elist; elist = next_elist)
+ {
+ /* This case has already been added. */
+ if (elist->derived == NULL)
+ goto free_elist;
+
+ /* Skip abstract base types. */
+ if (elist->derived->attr.abstract)
+ goto free_elist;
+
+ /* Run through the chain picking up all the cases that call the
+ same procedure. */
+ tmp_elist = elist;
+ for (; elist; elist = elist->next)
+ {
+ tree cval;
+
+ if (elist->esym != tmp_elist->esym)
+ continue;
+
+ cval = build_int_cst (TREE_TYPE (hash),
+ elist->derived->hash_value);
+ /* Build a label for the hash value. */
+ label = gfc_build_label_decl (NULL_TREE);
+ tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+ cval, NULL_TREE, label);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Null the reference the derived type so that this case is
+ not used again. */
+ elist->derived = NULL;
+ }
+
+ elist = tmp_elist;
+
+ /* Get a pointer to the procedure, */
+ tmp = gfc_get_symbol_decl (elist->esym);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+
+ /* Assign the pointer to the appropriate procedure. */
+ gfc_add_modify (&body, declared,
+ fold_convert (TREE_TYPE (declared), tmp));
+
+ /* Break to the end of the construct. */
+ tmp = build1_v (GOTO_EXPR, end_label);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Free the elists as we go; freeing them in gfc_free_expr causes
+ segfaults because it occurs too early and too often. */
+ free_elist:
+ next_elist = elist->next;
+ if (elist->hash_value)
+ gfc_free_expr (elist->hash_value);
+ gfc_free (elist);
+ elist = NULL;
+ }
+
+ /* Default is an error. */
+ label = gfc_build_label_decl (NULL_TREE);
+ tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+ NULL_TREE, NULL_TREE, label);
+ gfc_add_expr_to_block (&body, tmp);
+ tmp = gfc_trans_runtime_error (true, &expr->where,
+ "internal error: bad hash value in dynamic dispatch");
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Write the switch expression. */
+ tmp = gfc_finish_block (&body);
+ tmp = build3_v (SWITCH_EXPR, hash, tmp, NULL_TREE);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ tmp = build1_v (LABEL_EXPR, end_label);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = declared;
+ return;
+}
+
+
static void
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
tree tmp;
+ if (expr && expr->symtree
+ && expr->value.function.class_esym)
+ {
+ if (!sym->backend_decl)
+ sym->backend_decl = gfc_get_extern_function_decl (sym);
+
+ tmp = sym->backend_decl;
+
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+
+ select_class_proc (se, expr->value.function.class_esym,
+ tmp, expr);
+ return;
+ }
+
if (gfc_is_proc_ptr_comp (expr, NULL))
- tmp = gfc_get_proc_ptr_comp (se, expr);
+ tmp = get_proc_ptr_comp (expr);
else if (sym->attr.dummy)
{
tmp = gfc_get_symbol_decl (sym);
tree var;
type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed);
+ type = gfc_get_nodesc_array_type (type, sym->as, packed,
+ !sym->attr.target && !sym->attr.pointer
+ && !sym->attr.proc_pointer);
var = gfc_create_var (type, "ifm");
gfc_add_modify (block, var, fold_convert (type, data));
if (sym->ts.type == BT_CHARACTER)
{
/* Create a copy of the dummy argument's length. */
- new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
- sm->expr->ts.cl = new_sym->ts.cl;
+ new_sym->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.u.cl);
+ sm->expr->ts.u.cl = new_sym->ts.u.cl;
/* If the length is specified as "*", record the length that
the caller is passing. We should use the callee's length
in all other cases. */
- if (!new_sym->ts.cl->length && se)
+ if (!new_sym->ts.u.cl->length && se)
{
se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
- new_sym->ts.cl->backend_decl = se->string_length;
+ new_sym->ts.u.cl->backend_decl = se->string_length;
}
}
se->expr);
/* For character(*), use the actual argument's descriptor. */
- else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
+ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
value = build_fold_indirect_ref_loc (input_location,
se->expr);
for (sym = mapping->syms; sym; sym = sym->next)
if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
- && !sym->new_sym->n.sym->ts.cl->backend_decl)
+ && !sym->new_sym->n.sym->ts.u.cl->backend_decl)
{
- expr = sym->new_sym->n.sym->ts.cl->length;
+ expr = sym->new_sym->n.sym->ts.u.cl->length;
gfc_apply_interface_mapping_to_expr (mapping, expr);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (pre, &se.pre);
gfc_add_block_to_block (post, &se.post);
- sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
+ sym->new_sym->n.sym->ts.u.cl->backend_decl = se.expr;
}
}
case GFC_ISYM_LEN:
/* TODO figure out why this condition is necessary. */
if (sym->attr.function
- && (arg1->ts.cl->length == NULL
- || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT
- && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)))
+ && (arg1->ts.u.cl->length == NULL
+ || (arg1->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ && arg1->ts.u.cl->length->expr_type != EXPR_VARIABLE)))
return false;
- new_expr = gfc_copy_expr (arg1->ts.cl->length);
+ new_expr = gfc_copy_expr (arg1->ts.u.cl->length);
break;
case GFC_ISYM_SIZE:
if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
{
- expr->value.function.esym->ts.cl->length
- = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
+ expr->value.function.esym->ts.u.cl->length
+ = gfc_copy_expr (map_expr->symtree->n.sym->ts.u.cl->length);
gfc_apply_interface_mapping_to_expr (mapping,
- expr->value.function.esym->ts.cl->length);
+ expr->value.function.esym->ts.u.cl->length);
}
}
return;
/* Copying an expression does not copy its length, so do that here. */
- if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
+ if (expr->ts.type == BT_CHARACTER && expr->ts.u.cl)
{
- expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
- gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
+ expr->ts.u.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.u.cl);
+ gfc_apply_interface_mapping_to_expr (mapping, expr->ts.u.cl->length);
}
/* Apply the mapping to any references. */
an actual argument derived type array is copied and then returned
after the function call. */
void
-gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
- int g77, sym_intent intent)
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
+ sym_intent intent, bool formal_ptr)
{
gfc_se lse;
gfc_se rse;
tree tmp_index;
tree tmp;
tree base_type;
+ tree size;
stmtblock_t body;
int n;
+ int dimen;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
gfc_conv_ss_startstride (&loop);
/* Build an ss for the temporary. */
- if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
- gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+ gfc_conv_string_length (expr->ts.u.cl, expr, &parmse->pre);
base_type = gfc_typenode_for_spec (&expr->ts);
if (GFC_ARRAY_TYPE_P (base_type)
loop.temp_ss->data.temp.type = base_type;
if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+ loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
else
loop.temp_ss->string_length = NULL;
outside the innermost loop, so the overall transfer could be
optimized further. */
info = &rse.ss->data.info;
+ dimen = info->dimen;
tmp_index = gfc_index_zero_node;
- for (n = info->dimen - 1; n > 0; n--)
+ for (n = dimen - 1; n > 0; n--)
{
tree tmp_str;
tmp = rse.loop->loopvar[n];
rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
if (expr->ts.type == BT_CHARACTER)
- rse.string_length = expr->ts.cl->backend_decl;
+ rse.string_length = expr->ts.u.cl->backend_decl;
gfc_conv_expr (&lse, expr);
/* Pass the string length to the argument expression. */
if (expr->ts.type == BT_CHARACTER)
- parmse->string_length = expr->ts.cl->backend_decl;
+ parmse->string_length = expr->ts.u.cl->backend_decl;
+
+ /* Determine the offset for pointer formal arguments and set the
+ lbounds to one. */
+ if (formal_ptr)
+ {
+ size = gfc_index_one_node;
+ offset = gfc_index_zero_node;
+ for (n = 0; n < dimen; n++)
+ {
+ tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
+ gfc_rank_cst[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&parmse->pre,
+ parmse->expr,
+ gfc_rank_cst[n],
+ tmp);
+ gfc_conv_descriptor_lbound_set (&parmse->pre,
+ parmse->expr,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ size = gfc_evaluate_now (size, &parmse->pre);
+ offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ offset, size);
+ offset = gfc_evaluate_now (offset, &parmse->pre);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ rse.loop->to[n], rse.loop->from[n]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ size, tmp);
+ }
+
+ gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
+ offset);
+ }
/* We want either the address for the data or the address of the descriptor,
depending on the mode of passing array arguments. */
}
+/* Takes a derived type expression and returns the address of a temporary
+ class object of the 'declared' type. */
+static void
+gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
+ gfc_typespec class_ts)
+{
+ gfc_component *cmp;
+ gfc_symbol *vtab;
+ gfc_symbol *declared = class_ts.u.derived;
+ gfc_ss *ss;
+ tree ctree;
+ tree var;
+ tree tmp;
+
+ /* The derived type needs to be converted to a temporary
+ CLASS object. */
+ tmp = gfc_typenode_for_spec (&class_ts);
+ var = gfc_create_var (tmp, "class");
+
+ /* Set the vptr. */
+ cmp = gfc_find_component (declared, "$vptr", true, true);
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ var, cmp->backend_decl, NULL_TREE);
+
+ /* Remember the vtab corresponds to the derived type
+ not to the class declared type. */
+ vtab = gfc_find_derived_vtab (e->ts.u.derived);
+ gcc_assert (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+ gfc_add_modify (&parmse->pre, ctree,
+ fold_convert (TREE_TYPE (ctree), tmp));
+
+ /* Now set the data field. */
+ cmp = gfc_find_component (declared, "$data", true, true);
+ ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+ var, cmp->backend_decl, NULL_TREE);
+ ss = gfc_walk_expr (e);
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (parmse, e);
+ tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+ gfc_add_modify (&parmse->pre, ctree, tmp);
+ }
+ else
+ {
+ gfc_conv_expr (parmse, e);
+ gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+ }
+
+ /* Pass the address of the class object. */
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
+/* The following routine generates code for the intrinsic
+ procedures from the ISO_C_BINDING module:
+ * C_LOC (function)
+ * C_FUNLOC (function)
+ * C_F_POINTER (subroutine)
+ * C_F_PROCPOINTER (subroutine)
+ * C_ASSOCIATED (function)
+ One exception which is not handled here is C_F_POINTER with non-scalar
+ arguments. Returns 1 if the call was replaced by inline code (else: 0). */
+
+static int
+conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
+ gfc_actual_arglist * arg)
+{
+ gfc_symbol *fsym;
+ gfc_ss *argss;
+
+ if (sym->intmod_sym_id == ISOCBINDING_LOC)
+ {
+ if (arg->expr->rank == 0)
+ gfc_conv_expr_reference (se, arg->expr);
+ else
+ {
+ int f;
+ /* This is really the actual arg because no formal arglist is
+ created for C_LOC. */
+ fsym = arg->expr->symtree->n.sym;
+
+ /* We should want it to do g77 calling convention. */
+ f = (fsym != NULL)
+ && !(fsym->attr.pointer || fsym->attr.allocatable)
+ && fsym->as->type != AS_ASSUMED_SHAPE;
+ f = f || !sym->attr.always_explicit;
+
+ argss = gfc_walk_expr (arg->expr);
+ gfc_conv_array_parameter (se, arg->expr, argss, f,
+ NULL, NULL, NULL);
+ }
+
+ /* TODO -- the following two lines shouldn't be necessary, but if
+ they're removed, a bug is exposed later in the code path.
+ This workaround was thus introduced, but will have to be
+ removed; please see PR 35150 for details about the issue. */
+ se->expr = convert (pvoid_type_node, se->expr);
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+ return 1;
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+ {
+ arg->expr->ts.type = sym->ts.u.derived->ts.type;
+ arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
+ arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
+ gfc_conv_expr_reference (se, arg->expr);
+
+ return 1;
+ }
+ else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
+ && arg->next->expr->rank == 0)
+ || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
+ {
+ /* Convert c_f_pointer if fptr is a scalar
+ and convert c_f_procpointer. */
+ gfc_se cptrse;
+ gfc_se fptrse;
+
+ gfc_init_se (&cptrse, NULL);
+ gfc_conv_expr (&cptrse, arg->expr);
+ gfc_add_block_to_block (&se->pre, &cptrse.pre);
+ gfc_add_block_to_block (&se->post, &cptrse.post);
+
+ gfc_init_se (&fptrse, NULL);
+ if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
+ || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
+ fptrse.want_pointer = 1;
+
+ gfc_conv_expr (&fptrse, arg->next->expr);
+ gfc_add_block_to_block (&se->pre, &fptrse.pre);
+ gfc_add_block_to_block (&se->post, &fptrse.post);
+
+ if (arg->next->expr->symtree->n.sym->attr.proc_pointer
+ && arg->next->expr->symtree->n.sym->attr.dummy)
+ fptrse.expr = build_fold_indirect_ref_loc (input_location,
+ fptrse.expr);
+
+ se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
+ fptrse.expr,
+ fold_convert (TREE_TYPE (fptrse.expr),
+ cptrse.expr));
+
+ return 1;
+ }
+ else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+ {
+ gfc_se arg1se;
+ gfc_se arg2se;
+
+ /* Build the addr_expr for the first argument. The argument is
+ already an *address* so we don't need to set want_pointer in
+ the gfc_se. */
+ gfc_init_se (&arg1se, NULL);
+ gfc_conv_expr (&arg1se, arg->expr);
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
+
+ /* See if we were given two arguments. */
+ if (arg->next == NULL)
+ /* Only given one arg so generate a null and do a
+ not-equal comparison against the first arg. */
+ se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
+ fold_convert (TREE_TYPE (arg1se.expr),
+ null_pointer_node));
+ else
+ {
+ tree eq_expr;
+ tree not_null_expr;
+
+ /* Given two arguments so build the arg2se from second arg. */
+ gfc_init_se (&arg2se, NULL);
+ gfc_conv_expr (&arg2se, arg->next->expr);
+ gfc_add_block_to_block (&se->pre, &arg2se.pre);
+ gfc_add_block_to_block (&se->post, &arg2se.post);
+
+ /* Generate test to compare that the two args are equal. */
+ eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
+ arg1se.expr, arg2se.expr);
+ /* Generate test to ensure that the first arg is not null. */
+ not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
+ arg1se.expr, null_pointer_node);
+
+ /* Finally, the generated test must check that both arg1 is not
+ NULL and that it is equal to the second arg. */
+ se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+ not_null_expr, eq_expr);
+ }
+
+ return 1;
+ }
+
+ /* Nothing was done. */
+ 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 var;
tree len;
tree stringargs;
+ tree result = NULL;
gfc_formal_arglist *formal;
int has_alternate_specifier = 0;
bool need_interface_mapping;
len = NULL_TREE;
gfc_clear_ts (&ts);
- if (sym->from_intmod == INTMOD_ISO_C_BINDING)
- {
- if (sym->intmod_sym_id == ISOCBINDING_LOC)
- {
- if (arg->expr->rank == 0)
- gfc_conv_expr_reference (se, arg->expr);
- else
- {
- int f;
- /* This is really the actual arg because no formal arglist is
- created for C_LOC. */
- fsym = arg->expr->symtree->n.sym;
-
- /* We should want it to do g77 calling convention. */
- f = (fsym != NULL)
- && !(fsym->attr.pointer || fsym->attr.allocatable)
- && fsym->as->type != AS_ASSUMED_SHAPE;
- f = f || !sym->attr.always_explicit;
-
- argss = gfc_walk_expr (arg->expr);
- gfc_conv_array_parameter (se, arg->expr, argss, f,
- NULL, NULL, NULL);
- }
-
- /* TODO -- the following two lines shouldn't be necessary, but
- they're removed a bug is exposed later in the codepath.
- This is workaround was thus introduced, but will have to be
- removed; please see PR 35150 for details about the issue. */
- se->expr = convert (pvoid_type_node, se->expr);
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
-
- return 0;
- }
- else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
- {
- arg->expr->ts.type = sym->ts.derived->ts.type;
- arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
- arg->expr->ts.kind = sym->ts.derived->ts.kind;
- gfc_conv_expr_reference (se, arg->expr);
-
- return 0;
- }
- else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
- && arg->next->expr->rank == 0)
- || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
- {
- /* Convert c_f_pointer if fptr is a scalar
- and convert c_f_procpointer. */
- gfc_se cptrse;
- gfc_se fptrse;
-
- gfc_init_se (&cptrse, NULL);
- gfc_conv_expr (&cptrse, arg->expr);
- gfc_add_block_to_block (&se->pre, &cptrse.pre);
- gfc_add_block_to_block (&se->post, &cptrse.post);
-
- gfc_init_se (&fptrse, NULL);
- if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
- || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
- fptrse.want_pointer = 1;
-
- gfc_conv_expr (&fptrse, arg->next->expr);
- gfc_add_block_to_block (&se->pre, &fptrse.pre);
- gfc_add_block_to_block (&se->post, &fptrse.post);
-
- if (gfc_is_proc_ptr_comp (arg->next->expr, NULL))
- tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
- else
- tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
- se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
- fold_convert (tmp, cptrse.expr));
-
- return 0;
- }
- else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
- {
- gfc_se arg1se;
- gfc_se arg2se;
-
- /* Build the addr_expr for the first argument. The argument is
- already an *address* so we don't need to set want_pointer in
- the gfc_se. */
- gfc_init_se (&arg1se, NULL);
- gfc_conv_expr (&arg1se, arg->expr);
- gfc_add_block_to_block (&se->pre, &arg1se.pre);
- gfc_add_block_to_block (&se->post, &arg1se.post);
-
- /* See if we were given two arguments. */
- if (arg->next == NULL)
- /* Only given one arg so generate a null and do a
- not-equal comparison against the first arg. */
- se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
- fold_convert (TREE_TYPE (arg1se.expr),
- null_pointer_node));
- else
- {
- tree eq_expr;
- tree not_null_expr;
-
- /* Given two arguments so build the arg2se from second arg. */
- gfc_init_se (&arg2se, NULL);
- gfc_conv_expr (&arg2se, arg->next->expr);
- gfc_add_block_to_block (&se->pre, &arg2se.pre);
- gfc_add_block_to_block (&se->post, &arg2se.post);
-
- /* Generate test to compare that the two args are equal. */
- eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
- arg1se.expr, arg2se.expr);
- /* Generate test to ensure that the first arg is not null. */
- not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
- arg1se.expr, null_pointer_node);
-
- /* Finally, the generated test must check that both arg1 is not
- NULL and that it is equal to the second arg. */
- se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- not_null_expr, eq_expr);
- }
-
- return 0;
- }
- }
+ if (sym->from_intmod == INTMOD_ISO_C_BINDING
+ && conv_isocbinding_procedure (se, sym, arg))
+ return 0;
gfc_is_proc_ptr_comp (expr, &comp);
if (!sym->attr.elemental)
{
gcc_assert (se->ss->type == GFC_SS_FUNCTION);
- if (se->ss->useflags)
- {
+ if (se->ss->useflags)
+ {
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->attr.dimension)
|| (comp && comp->attr.dimension));
- gcc_assert (se->loop != NULL);
+ gcc_assert (se->loop != NULL);
- /* Access the previously obtained result. */
- gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
- return 0;
- }
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
+ gfc_advance_se_ss_chain (se);
+ return 0;
+ }
}
info = &se->ss->data.info;
}
gfc_init_block (&post);
gfc_init_interface_mapping (&mapping);
- need_interface_mapping = ((sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length
- && sym->ts.cl->length->expr_type
- != EXPR_CONSTANT)
- || (comp && comp->attr.dimension)
- || (!comp && sym->attr.dimension));
- if (comp)
- formal = comp->formal;
+ if (!comp)
+ {
+ formal = sym->formal;
+ need_interface_mapping = sym->attr.dimension ||
+ (sym->ts.type == BT_CHARACTER
+ && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type
+ != EXPR_CONSTANT);
+ }
else
- formal = sym->formal;
+ {
+ formal = comp->formal;
+ need_interface_mapping = comp->attr.dimension ||
+ (comp->ts.type == BT_CHARACTER
+ && comp->ts.u.cl->length
+ && comp->ts.u.cl->length->expr_type
+ != EXPR_CONSTANT);
+ }
+
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
+
if (e == NULL)
{
-
if (se->ignore_optional)
{
/* Some intrinsics have already been resolved to the correct
}
else if (arg->label)
{
- has_alternate_specifier = 1;
- continue;
+ has_alternate_specifier = 1;
+ continue;
}
else
{
/* Pass a NULL pointer for an absent arg. */
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
- if (arg->missing_arg_type == BT_CHARACTER)
+ if (arg->missing_arg_type == BT_CHARACTER)
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
}
+ else if (fsym && fsym->ts.type == BT_CLASS
+ && e->ts.type == BT_DERIVED)
+ {
+ /* The derived type needs to be converted to a temporary
+ CLASS object. */
+ gfc_init_se (&parmse, se);
+ gfc_conv_derived_to_class (&parmse, e, fsym->ts);
+ }
else if (se->ss && se->ss->useflags)
{
/* An elemental function inside a scalarized loop. */
- gfc_init_se (&parmse, se);
- gfc_conv_expr_reference (&parmse, e);
+ gfc_init_se (&parmse, se);
+ gfc_conv_expr_reference (&parmse, e);
parm_kind = ELEMENTAL;
}
else
argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
- {
+ {
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.cray_pointee
&& fsym && fsym->attr.flavor == FL_PROCEDURE)
through arg->name. */
conv_arglist_function (&parmse, arg->expr, arg->name);
else if ((e->expr_type == EXPR_FUNCTION)
- && e->symtree->n.sym->attr.pointer
- && fsym && fsym->attr.target)
+ && ((e->value.function.esym
+ && e->value.function.esym->result->attr.pointer)
+ || (!e->value.function.esym
+ && e->symtree->n.sym->attr.pointer))
+ && fsym && fsym->attr.target)
{
gfc_conv_expr (&parmse, e);
parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
}
else if (e->expr_type == EXPR_FUNCTION
&& e->symtree->n.sym->result
+ && e->symtree->n.sym->result != e->symtree->n.sym
&& e->symtree->n.sym->result->attr.proc_pointer)
{
/* Functions returning procedure pointers. */
else
{
gfc_conv_expr_reference (&parmse, e);
+
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ stmtblock_t block;
+
+ gfc_init_block (&block);
+ tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE,
+ true, NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ parmse.expr, null_pointer_node);
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ {
+ tmp = fold_build3 (COND_EXPR, void_type_node,
+ gfc_conv_expr_present (e->symtree->n.sym),
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ }
+ else
+ tmp = gfc_finish_block (&block);
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+
if (fsym && e->expr_type != EXPR_NULL
&& ((fsym->attr.pointer
&& fsym->attr.flavor != FL_PROCEDURE)
|| (fsym->attr.proc_pointer
&& !(e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.dummy))))
+ && e->symtree->n.sym->attr.dummy))
+ || (e->expr_type == EXPR_VARIABLE
+ && gfc_is_proc_ptr_comp (e, NULL))
+ || fsym->attr.allocatable))
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
ALLOCATABLE or assumed shape, we do not use g77's calling
convention, and pass the address of the array descriptor
instead. Otherwise we use g77's calling convention. */
- int f;
+ bool f;
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
&& fsym->as->type != AS_ASSUMED_SHAPE;
- f = f || !sym->attr.always_explicit;
+ if (comp)
+ f = f || !comp->attr.always_explicit;
+ else
+ f = f || !sym->attr.always_explicit;
if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e))
is converted to a temporary, which is passed and then
written back after the procedure call. */
gfc_conv_subref_array_arg (&parmse, e, f,
- fsym ? fsym->attr.intent : INTENT_INOUT);
+ fsym ? fsym->attr.intent : INTENT_INOUT,
+ fsym && fsym->attr.pointer);
else
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name, NULL);
- /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
- allocated on entry, it must be deallocated. */
- if (fsym && fsym->attr.allocatable
- && fsym->attr.intent == INTENT_OUT)
- {
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
- tmp = gfc_trans_dealloc_allocated (tmp);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
+ /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
+ allocated on entry, it must be deallocated. */
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
+ tmp = gfc_trans_dealloc_allocated (tmp);
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ tmp = fold_build3 (COND_EXPR, void_type_node,
+ gfc_conv_expr_present (e->symtree->n.sym),
+ tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
}
}
if (e && (fsym == NULL || fsym->attr.optional))
{
/* If an optional argument is itself an optional dummy argument,
- check its presence and substitute a null if absent. */
+ check its presence and substitute a null if absent. This is
+ only needed when passing an array to an elemental procedure
+ as then array elements are accessed - or no NULL pointer is
+ allowed and a "1" or "0" should be passed if not present.
+ When passing a non-array-descriptor full array to a
+ non-array-descriptor dummy, no check is needed. For
+ array-descriptor actual to array-descriptor dummy, see
+ PR 41911 for why a check has to be inserted.
+ fsym == NULL is checked as intrinsics required the descriptor
+ but do not always set fsym. */
if (e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
+ && e->symtree->n.sym->attr.optional
+ && ((e->rank > 0 && sym->attr.elemental)
+ || e->representation.length || e->ts.type == BT_CHARACTER
+ || (e->rank > 0
+ && (fsym == NULL || fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_DEFERRED))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
}
&& parmse.string_length == NULL_TREE
&& e->ts.type == BT_PROCEDURE
&& e->symtree->n.sym->ts.type == BT_CHARACTER
- && e->symtree->n.sym->ts.cl->length != NULL
- && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && e->symtree->n.sym->ts.u.cl->length != NULL
+ && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
- gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
- parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
+ gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl);
+ parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl;
}
}
deallocated for non-variable scalars. Non-variable arrays are
dealt with in trans-array.c(gfc_conv_array_parameter). */
if (e && e->ts.type == BT_DERIVED
- && e->ts.derived->attr.alloc_comp
+ && e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
&& (e->expr_type != EXPR_VARIABLE && !e->rank))
{
{
tree local_tmp;
local_tmp = gfc_evaluate_now (tmp, &se->pre);
- local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
+ local_tmp = gfc_copy_alloc_comp (e->ts.u.derived, local_tmp, tmp, parm_rank);
gfc_add_expr_to_block (&se->post, local_tmp);
}
- tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
+ tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
gfc_add_expr_to_block (&se->post, tmp);
}
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
- ts = sym->ts;
+ if (comp)
+ ts = comp->ts;
+ else
+ ts = sym->ts;
+
if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
se->string_length = build_int_cst (gfc_charlen_type_node, 1);
else if (ts.type == BT_CHARACTER)
{
- if (sym->ts.cl->length == NULL)
+ if (ts.u.cl->length == NULL)
{
/* Assumed character length results are not allowed by 5.1.1.5 of the
standard and are trapped in resolve.c; except in the case of SPREAD
formal = sym->ns->proc_name->formal;
for (; formal; formal = formal->next)
if (strcmp (formal->sym->name, sym->name) == 0)
- cl.backend_decl = formal->sym->ts.cl->backend_decl;
+ cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
}
}
- else
+ else
{
tree tmp;
/* Calculate the length of the returned string. */
gfc_init_se (&parmse, NULL);
if (need_interface_mapping)
- gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
+ gfc_apply_interface_mapping (&mapping, &parmse, ts.u.cl->length);
else
- gfc_conv_expr (&parmse, sym->ts.cl->length);
+ gfc_conv_expr (&parmse, ts.u.cl->length);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
/* Set up a charlen structure for it. */
cl.next = NULL;
cl.length = NULL;
- ts.cl = &cl;
+ ts.u.cl = &cl;
len = cl.backend_decl;
}
- byref = (comp && comp->attr.dimension)
+ byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
|| (!comp && gfc_return_by_reference (sym));
if (byref)
{
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
+ result = build_fold_indirect_ref_loc (input_location,
+ se->expr);
retargs = gfc_chainon_list (retargs, se->expr);
}
else if (comp && comp->attr.dimension)
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
- tmp = info->descriptor;
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ result = info->descriptor;
+ tmp = gfc_build_addr_expr (NULL_TREE, result);
retargs = gfc_chainon_list (retargs, tmp);
}
- else if (sym->result->attr.dimension)
+ else if (!comp && sym->result->attr.dimension)
{
gcc_assert (se->loop && info);
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
- tmp = info->descriptor;
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ result = info->descriptor;
+ tmp = gfc_build_addr_expr (NULL_TREE, result);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
{
/* Pass the string length. */
- type = gfc_get_character_type (ts.kind, ts.cl);
+ type = gfc_get_character_type (ts.kind, ts.u.cl);
type = build_pointer_type (type);
/* Return an address to a char[0:len-1]* temporary for
character pointers. */
- if (sym->attr.pointer || sym->attr.allocatable)
+ if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+ || (comp && (comp->attr.pointer || comp->attr.allocatable)))
{
var = gfc_create_var (type, "pstr");
+ if ((!comp && sym->attr.allocatable)
+ || (comp && comp->attr.allocatable))
+ gfc_add_modify (&se->pre, var,
+ fold_convert (TREE_TYPE (var),
+ null_pointer_node));
+
/* Provide an address expression for the function arguments. */
var = gfc_build_addr_expr (NULL_TREE, var);
}
something like
x = f()
where f is pointer valued, we have to dereference the result. */
- if (!se->want_pointer && !byref && sym->attr.pointer
+ if (!se->want_pointer && !byref
+ && (sym->attr.pointer || sym->attr.allocatable)
&& !gfc_is_proc_ptr_comp (expr, NULL))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
/* Bundle in the string length. */
se->string_length = len;
}
- else if (sym->ts.type == BT_CHARACTER)
+ else if (ts.type == BT_CHARACTER)
{
/* Dereference for character pointer results. */
- if (sym->attr.pointer || sym->attr.allocatable)
- se->expr = build_fold_indirect_ref_loc (input_location,
- var);
+ if ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+ || (comp && (comp->attr.pointer || comp->attr.allocatable)))
+ se->expr = build_fold_indirect_ref_loc (input_location, var);
else
se->expr = var;
}
else
{
- gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
- se->expr = build_fold_indirect_ref_loc (input_location,
- var);
+ gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+ se->expr = build_fold_indirect_ref_loc (input_location, var);
}
}
}
/* Follow the function call with the argument post block. */
if (byref)
- gfc_add_block_to_block (&se->pre, &post);
+ {
+ gfc_add_block_to_block (&se->pre, &post);
+
+ /* Transformational functions of derived types with allocatable
+ components must have the result allocatable components copied. */
+ arg = expr->value.function.actual;
+ if (result && arg && expr->rank
+ && expr->value.function.isym
+ && expr->value.function.isym->transformational
+ && arg->expr->ts.type == BT_DERIVED
+ && arg->expr->ts.u.derived->attr.alloc_comp)
+ {
+ tree tmp2;
+ /* Copy the allocatable components. We have to use a
+ temporary here to prevent source allocatable components
+ from being corrupted. */
+ tmp2 = gfc_evaluate_now (result, &se->pre);
+ tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
+ result, tmp2, expr->rank);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
+ expr->rank);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Finally free the temporary's data field. */
+ tmp = gfc_conv_descriptor_data_get (tmp2);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ }
else
gfc_add_block_to_block (&se->post, &post);
/* Copy string arguments. */
tree arglen;
- gcc_assert (fsym->ts.cl && fsym->ts.cl->length
- && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
+ gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+ && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
tmp = gfc_build_addr_expr (build_pointer_type (type),
if (sym->ts.type == BT_CHARACTER)
{
- gfc_conv_const_charlen (sym->ts.cl);
+ gfc_conv_const_charlen (sym->ts.u.cl);
/* Force the expression to the correct length. */
if (!INTEGER_CST_P (se->string_length)
|| tree_int_cst_lt (se->string_length,
- sym->ts.cl->backend_decl))
+ sym->ts.u.cl->backend_decl))
{
- type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
+ type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
tmp = gfc_create_var (type, sym->name);
tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
- gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
+ gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
sym->ts.kind, se->string_length, se->expr,
sym->ts.kind);
se->expr = tmp;
}
- se->string_length = sym->ts.cl->backend_decl;
+ se->string_length = sym->ts.u.cl->backend_decl;
}
/* Restore the original variables. */
}
-/* Return the backend_decl for a procedure pointer component. */
-
-tree
-gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
-{
- gfc_se comp_se;
- gfc_expr *e2;
- gfc_init_se (&comp_se, NULL);
- e2 = gfc_copy_expr (e);
- e2->expr_type = EXPR_VARIABLE;
- gfc_conv_expr (&comp_se, e2);
- comp_se.expr = build_fold_addr_expr_loc (input_location, comp_se.expr);
- return gfc_evaluate_now (comp_se.expr, &se->pre);
-}
-
-
/* Translate a function expression. */
static void
used as initialization expressions). If so, we need to modify
the 'expr' to be that for a (void *). */
if (expr != NULL && expr->ts.type == BT_DERIVED
- && expr->ts.is_iso_c && expr->ts.derived)
+ && expr->ts.is_iso_c && expr->ts.u.derived)
{
- gfc_symbol *derived = expr->ts.derived;
+ gfc_symbol *derived = expr->ts.u.derived;
expr = gfc_int_expr (0);
switch (ts->type)
{
case BT_DERIVED:
+ case BT_CLASS:
gfc_init_se (&se, NULL);
gfc_conv_structure (&se, expr, 1);
return se.expr;
case BT_CHARACTER:
- return gfc_conv_string_init (ts->cl->backend_decl,expr);
+ return gfc_conv_string_init (ts->u.cl->backend_decl,expr);
default:
gfc_init_se (&se, NULL);
gfc_conv_tmp_array_ref (&lse);
if (cm->ts.type == BT_CHARACTER)
- lse.string_length = cm->ts.cl->backend_decl;
+ lse.string_length = cm->ts.u.cl->backend_decl;
gfc_conv_expr (&rse, expr);
}
+static tree
+gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
+ gfc_expr * expr)
+{
+ gfc_se se;
+ gfc_ss *rss;
+ stmtblock_t block;
+ tree offset;
+ int n;
+ tree tmp;
+ tree tmp2;
+ gfc_array_spec *as;
+ gfc_expr *arg = NULL;
+
+ gfc_start_block (&block);
+ gfc_init_se (&se, NULL);
+
+ /* Get the descriptor for the expressions. */
+ rss = gfc_walk_expr (expr);
+ se.want_pointer = 0;
+ gfc_conv_expr_descriptor (&se, expr, rss);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_modify (&block, dest, se.expr);
+
+ /* Deal with arrays of derived types with allocatable components. */
+ if (cm->ts.type == BT_DERIVED
+ && cm->ts.u.derived->attr.alloc_comp)
+ tmp = gfc_copy_alloc_comp (cm->ts.u.derived,
+ se.expr, dest,
+ cm->as->rank);
+ else
+ tmp = gfc_duplicate_allocatable (dest, se.expr,
+ TREE_TYPE(cm->backend_decl),
+ cm->as->rank);
+
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &se.post);
+
+ if (expr->expr_type != EXPR_VARIABLE)
+ gfc_conv_descriptor_data_set (&block, se.expr,
+ null_pointer_node);
+
+ /* We need to know if the argument of a conversion function is a
+ variable, so that the correct lower bound can be used. */
+ if (expr->expr_type == EXPR_FUNCTION
+ && expr->value.function.isym
+ && expr->value.function.isym->conversion
+ && expr->value.function.actual->expr
+ && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
+ arg = expr->value.function.actual->expr;
+
+ /* Obtain the array spec of full array references. */
+ if (arg)
+ as = gfc_get_full_arrayspec_from_expr (arg);
+ else
+ as = gfc_get_full_arrayspec_from_expr (expr);
+
+ /* Shift the lbound and ubound of temporaries to being unity,
+ rather than zero, based. Always calculate the offset. */
+ offset = gfc_conv_descriptor_offset_get (dest);
+ gfc_add_modify (&block, offset, gfc_index_zero_node);
+ tmp2 =gfc_create_var (gfc_array_index_type, NULL);
+
+ for (n = 0; n < expr->rank; n++)
+ {
+ tree span;
+ tree lbound;
+
+ /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+ TODO It looks as if gfc_conv_expr_descriptor should return
+ the correct bounds and that the following should not be
+ necessary. This would simplify gfc_conv_intrinsic_bound
+ as well. */
+ if (as && as->lower[n])
+ {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[n]);
+ gfc_add_block_to_block (&block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, &block);
+ }
+ else if (as && arg)
+ {
+ tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp,
+ gfc_rank_cst[n]);
+ }
+ else if (as)
+ lbound = gfc_conv_descriptor_lbound_get (dest,
+ gfc_rank_cst[n]);
+ else
+ lbound = gfc_index_one_node;
+
+ lbound = fold_convert (gfc_array_index_type, lbound);
+
+ /* Shift the bounds and set the offset accordingly. */
+ tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
+ span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
+ gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound);
+ gfc_conv_descriptor_ubound_set (&block, dest,
+ gfc_rank_cst[n], tmp);
+ gfc_conv_descriptor_lbound_set (&block, dest,
+ gfc_rank_cst[n], lbound);
+
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_lbound_get (dest,
+ gfc_rank_cst[n]),
+ gfc_conv_descriptor_stride_get (dest,
+ gfc_rank_cst[n]));
+ gfc_add_modify (&block, tmp2, tmp);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
+ gfc_conv_descriptor_offset_set (&block, dest, tmp);
+ }
+
+ if (arg)
+ {
+ /* If a conversion expression has a null data pointer
+ argument, nullify the allocatable component. */
+ tree non_null_expr;
+ tree null_expr;
+
+ if (arg->symtree->n.sym->attr.allocatable
+ || arg->symtree->n.sym->attr.pointer)
+ {
+ non_null_expr = gfc_finish_block (&block);
+ gfc_start_block (&block);
+ gfc_conv_descriptor_data_set (&block, dest,
+ null_pointer_node);
+ null_expr = gfc_finish_block (&block);
+ tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
+ tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ return build3_v (COND_EXPR, tmp,
+ null_expr, non_null_expr);
+ }
+ }
+
+ return gfc_finish_block (&block);
+}
+
+
/* Assign a single component of a derived type constructor. */
static tree
gfc_ss *rss;
stmtblock_t block;
tree tmp;
- tree offset;
- int n;
gfc_start_block (&block);
gfc_add_block_to_block (&block, &se.post);
}
}
+ else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL)
+ {
+ /* NULL initialization for CLASS components. */
+ tmp = gfc_trans_structure_assign (dest,
+ gfc_default_initializer (&cm->ts));
+ gfc_add_expr_to_block (&block, tmp);
+ }
else if (cm->attr.dimension)
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
else if (cm->attr.allocatable)
{
- tree tmp2;
-
- gfc_init_se (&se, NULL);
-
- rss = gfc_walk_expr (expr);
- se.want_pointer = 0;
- gfc_conv_expr_descriptor (&se, expr, rss);
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_modify (&block, dest, se.expr);
-
- if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
- tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
- cm->as->rank);
- else
- tmp = gfc_duplicate_allocatable (dest, se.expr,
- TREE_TYPE(cm->backend_decl),
- cm->as->rank);
-
+ tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
- gfc_add_block_to_block (&block, &se.post);
-
- if (expr->expr_type != EXPR_VARIABLE)
- gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
-
- /* Shift the lbound and ubound of temporaries to being unity, rather
- than zero, based. Calculate the offset for all cases. */
- offset = gfc_conv_descriptor_offset_get (dest);
- gfc_add_modify (&block, offset, gfc_index_zero_node);
- tmp2 =gfc_create_var (gfc_array_index_type, NULL);
- for (n = 0; n < expr->rank; n++)
- {
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_CONSTANT)
- {
- tree span;
- tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
- span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
- gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
- tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- span, gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n],
- tmp);
- gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n],
- gfc_index_one_node);
- }
- tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound_get (dest,
- gfc_rank_cst[n]),
- gfc_conv_descriptor_stride_get (dest,
- gfc_rank_cst[n]));
- gfc_add_modify (&block, tmp2, tmp);
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
- gfc_conv_descriptor_offset_set (&block, dest, tmp);
- }
-
- if (expr->expr_type == EXPR_FUNCTION
- && expr->value.function.isym
- && expr->value.function.isym->conversion
- && expr->value.function.actual->expr
- && expr->value.function.actual->expr->expr_type
- == EXPR_VARIABLE)
- {
- /* If a conversion expression has a null data pointer
- argument, nullify the allocatable component. */
- gfc_symbol *s;
- tree non_null_expr;
- tree null_expr;
- s = expr->value.function.actual->expr->symtree->n.sym;
- if (s->attr.allocatable || s->attr.pointer)
- {
- non_null_expr = gfc_finish_block (&block);
- gfc_start_block (&block);
- gfc_conv_descriptor_data_set (&block, dest,
- null_pointer_node);
- null_expr = gfc_finish_block (&block);
- tmp = gfc_conv_descriptor_data_get (s->backend_decl);
- tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- return build3_v (COND_EXPR, tmp, null_expr,
- non_null_expr);
- }
- }
}
else
{
gfc_conv_expr (&se, expr);
if (cm->ts.type == BT_CHARACTER)
- lse.string_length = cm->ts.cl->backend_decl;
+ lse.string_length = cm->ts.u.cl->backend_decl;
lse.expr = dest;
tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
gfc_add_expr_to_block (&block, tmp);
tree tmp;
gfc_start_block (&block);
- cm = expr->ts.derived->components;
+ cm = expr->ts.u.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
/* Skip absent members in default initializers. */
if (!c->expr)
continue;
+ /* Handle c_null_(fun)ptr. */
+ if (c && c->expr && c->expr->ts.is_iso_c)
+ {
+ field = cm->backend_decl;
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ dest, field, NULL_TREE);
+ tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ gfc_add_expr_to_block (&block, tmp);
+ continue;
+ }
+
field = cm->backend_decl;
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
if (!init)
{
/* Create a temporary variable and fill it in. */
- se->expr = gfc_create_var (type, expr->ts.derived->name);
+ se->expr = gfc_create_var (type, expr->ts.u.derived->name);
tmp = gfc_trans_structure_assign (se->expr, expr);
gfc_add_expr_to_block (&se->pre, tmp);
return;
}
- cm = expr->ts.derived->components;
+ cm = expr->ts.u.derived->components;
for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
{
if (!c->expr || cm->attr.allocatable)
continue;
- val = gfc_conv_initializer (c->expr, &cm->ts,
- TREE_TYPE (cm->backend_decl), cm->attr.dimension,
- cm->attr.pointer || cm->attr.proc_pointer);
+ if (cm->ts.type == BT_CLASS)
+ {
+ gfc_component *data;
+ data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
+ val = gfc_conv_initializer (c->expr, &cm->ts,
+ TREE_TYPE (data->backend_decl),
+ data->attr.dimension,
+ data->attr.pointer);
+
+ CONSTRUCTOR_APPEND_ELT (v, data->backend_decl, val);
+ }
+ else if (strcmp (cm->name, "$size") == 0)
+ {
+ val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ }
+ else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+ && strcmp (cm->name, "$extends") == 0)
+ {
+ gfc_symbol *vtabs;
+ vtabs = cm->initializer->symtree->n.sym;
+ val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ }
+ else
+ {
+ val = gfc_conv_initializer (c->expr, &cm->ts,
+ TREE_TYPE (cm->backend_decl), cm->attr.dimension,
+ cm->attr.pointer || cm->attr.proc_pointer);
- /* Append it to the constructor list. */
- CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ /* Append it to the constructor list. */
+ CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+ }
}
se->expr = build_constructor (type, v);
if (init)
null_pointer_node. C_PTR and C_FUNPTR are converted to match the
typespec for the C_PTR and C_FUNPTR symbols, which has already been
updated to be an integer with a kind equal to the size of a (void *). */
- if (expr->ts.type == BT_DERIVED && expr->ts.derived
- && expr->ts.derived->attr.is_iso_c)
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
+ && expr->ts.u.derived->attr.is_iso_c)
{
if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
|| expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
{
/* Update the type/kind of the expression to be what the new
type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
- expr->ts.type = expr->ts.derived->ts.type;
- expr->ts.f90_type = expr->ts.derived->ts.f90_type;
- expr->ts.kind = expr->ts.derived->ts.kind;
+ expr->ts.type = expr->ts.u.derived->ts.type;
+ expr->ts.f90_type = expr->ts.u.derived->ts.f90_type;
+ expr->ts.kind = expr->ts.u.derived->ts.kind;
}
}
}
if (expr->expr_type == EXPR_FUNCTION
- && expr->symtree->n.sym->attr.pointer
- && !expr->symtree->n.sym->attr.dimension)
+ && ((expr->value.function.esym
+ && expr->value.function.esym->result->attr.pointer
+ && !expr->value.function.esym->result->attr.dimension)
+ || (!expr->value.function.esym
+ && expr->symtree->n.sym->attr.pointer
+ && !expr->symtree->n.sym->attr.dimension)))
{
se->want_pointer = 1;
gfc_conv_expr (se, expr);
/* Check character lengths if character expression. The test is only
really added if -fbounds-check is enabled. */
- if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+ && !expr1->symtree->n.sym->attr.proc_pointer
+ && !gfc_is_proc_ptr_comp (expr1, NULL))
{
gcc_assert (expr2->ts.type == BT_CHARACTER);
gcc_assert (lse.string_length && rse.string_length);
gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
rse->expr, ts.kind);
}
- else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
+ else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
cond = NULL_TREE;
if (!l_is_temp)
{
tmp = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
+ tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
if (r_is_var)
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
same as the lhs. */
if (r_is_var)
{
- tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
+ tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0);
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
gfc_add_expr_to_block (&block, tmp);
}
}
+ else if (ts.type == BT_DERIVED || ts.type == BT_CLASS)
+ {
+ gfc_add_block_to_block (&block, &lse->pre);
+ gfc_add_block_to_block (&block, &rse->pre);
+ tmp = fold_build1 (VIEW_CONVERT_EXPR, TREE_TYPE (lse->expr), rse->expr);
+ gfc_add_modify (&block, lse->expr, tmp);
+ }
else
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
gfc_add_modify (&block, lse->expr,
- fold_convert (TREE_TYPE (lse->expr), rse->expr));
+ fold_convert (TREE_TYPE (lse->expr), rse->expr));
}
gfc_add_block_to_block (&block, &lse->post);
character lengths are the same. */
if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
{
- if (expr1->ts.cl->length == NULL
- || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (expr1->ts.u.cl->length == NULL
+ || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return NULL;
- if (expr2->ts.cl->length == NULL
- || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
+ if (expr2->ts.u.cl->length == NULL
+ || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpz_cmp (expr1->ts.cl->length->value.integer,
- expr2->ts.cl->length->value.integer) != 0)
+ if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
+ expr2->ts.u.cl->length->value.integer) != 0)
return NULL;
}
gfc_start_block (&se.pre);
se.want_pointer = 1;
- gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
+ gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL);
+
+ if (expr1->ts.type == BT_DERIVED
+ && expr1->ts.u.derived->attr.alloc_comp)
+ {
+ tree tmp;
+ tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
+ expr1->rank);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
/* Subroutine of gfc_trans_assignment that actually scalarizes the
- assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
+ assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
static tree
gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
to arrays must be done with a deep copy and the rhs temporary
must have its components deallocated afterwards. */
scalar_to_array = (expr2->ts.type == BT_DERIVED
- && expr2->ts.derived->attr.alloc_comp
+ && expr2->ts.u.derived->attr.alloc_comp
&& expr2->expr_type != EXPR_VARIABLE
&& !gfc_is_constant_expr (expr2)
&& expr1->rank && !expr2->rank);
if (scalar_to_array)
{
- tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0);
+ tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
gfc_add_expr_to_block (&loop.post, tmp);
}
return false;
case BT_DERIVED:
- return !expr->ts.derived->attr.alloc_comp;
+ return !expr->ts.u.derived->attr.alloc_comp;
default:
break;
{
return gfc_trans_assignment (code->expr1, code->expr2, false);
}
+
+
+/* Translate an assignment to a CLASS object
+ (pointer or ordinary assignment). */
+
+tree
+gfc_trans_class_assign (gfc_code *code)
+{
+ stmtblock_t block;
+ tree tmp;
+ gfc_expr *lhs;
+ gfc_expr *rhs;
+
+ gfc_start_block (&block);
+
+ if (code->op == EXEC_INIT_ASSIGN)
+ {
+ /* Special case for initializing a CLASS variable on allocation.
+ A MEMCPY is needed to copy the full data of the dynamic type,
+ which may be different from the declared type. */
+ gfc_se dst,src;
+ tree memsz;
+ gfc_init_se (&dst, NULL);
+ gfc_init_se (&src, NULL);
+ gfc_add_component_ref (code->expr1, "$data");
+ gfc_conv_expr (&dst, code->expr1);
+ gfc_conv_expr (&src, code->expr2);
+ gfc_add_block_to_block (&block, &src.pre);
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
+ gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+ }
+
+ if (code->expr2->ts.type != BT_CLASS)
+ {
+ /* Insert an additional assignment which sets the '$vptr' field. */
+ lhs = gfc_copy_expr (code->expr1);
+ gfc_add_component_ref (lhs, "$vptr");
+ if (code->expr2->ts.type == BT_DERIVED)
+ {
+ gfc_symbol *vtab;
+ gfc_symtree *st;
+ vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+ gcc_assert (vtab);
+
+ rhs = gfc_get_expr ();
+ rhs->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (vtab->name, NULL, 1, &st);
+ rhs->symtree = st;
+ rhs->ts = vtab->ts;
+ }
+ else if (code->expr2->expr_type == EXPR_NULL)
+ rhs = gfc_int_expr (0);
+ else
+ gcc_unreachable ();
+
+ tmp = gfc_trans_pointer_assignment (lhs, rhs);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_free_expr (lhs);
+ gfc_free_expr (rhs);
+ }
+
+ /* Do the actual CLASS assignment. */
+ if (code->expr2->ts.type == BT_CLASS)
+ code->op = EXEC_ASSIGN;
+ else
+ gfc_add_component_ref (code->expr1, "$data");
+
+ if (code->op == EXEC_ASSIGN)
+ tmp = gfc_trans_assign (code);
+ else if (code->op == EXEC_POINTER_ASSIGN)
+ tmp = gfc_trans_pointer_assign (code);
+ else
+ gcc_unreachable();
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
+}
OSDN Git Service
