{
/* Create a temporary and convert it to the correct type. */
tmp = gfc_get_int_type (kind);
- tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr));
+ tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
+ se->expr));
/* Test for a NULL value. */
tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
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);
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. */
if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
tmp = se->expr;
else
- tmp = build_fold_indirect_ref (se->expr);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ se->expr);
tmp = gfc_build_array_ref (tmp, start.expr, NULL);
se->expr = gfc_build_addr_expr (type, tmp);
}
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 (se->expr);
+ 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);
}
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result))
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
}
else if (!sym->attr.value)
{
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension)
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* Dereference scalar hidden result. */
if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
&& (sym->attr.function || sym->attr.result)
&& !sym->attr.dimension && !sym->attr.pointer
&& !sym->attr.always_explicit)
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
|| sym->attr.function
|| sym->attr.result
|| !sym->attr.dimension))
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
}
ref = expr->ref;
{
/* 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);
break;
}
- se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
+ se->expr = build_call_expr_loc (input_location,
+ fndecl, 2, lse.expr, rse.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)
{
else
gcc_unreachable ();
- tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr,
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 6, len, var, lse.string_length, lse.expr,
rse.string_length, rse.expr);
gfc_add_expr_to_block (&se->pre, tmp);
&& TREE_INT_CST_HIGH (len) == 0)
{
str = fold_convert (gfc_get_pchar_type (kind), str);
- return build_fold_indirect_ref (str);
+ return build_fold_indirect_ref_loc (input_location,
+ str);
}
return NULL_TREE;
else
gcc_unreachable ();
- tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 4, len1, str1, len2, str2);
}
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 vindex;
+ stmtblock_t body;
+ gfc_class_esym_list *next_elist, *tmp_elist;
+ gfc_se tmpse;
+
+ /* Convert the vindex expression. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr (&tmpse, elist->vindex);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ vindex = 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;
+
+ /* 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 (vindex),
+ elist->derived->vindex);
+ /* Build a label for the vindex 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->vindex)
+ gfc_free_expr (elist->vindex);
+ 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 vindex in dynamic dispatch");
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Write the switch expression. */
+ tmp = gfc_finish_block (&body);
+ tmp = build3_v (SWITCH_EXPR, vindex, 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);
if (sym->attr.proc_pointer)
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
}
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;
}
}
tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
tmp = build_pointer_type (tmp);
if (sym->attr.pointer)
- value = build_fold_indirect_ref (se->expr);
+ value = build_fold_indirect_ref_loc (input_location,
+ se->expr);
else
value = se->expr;
value = fold_convert (tmp, value);
/* If the argument is a scalar, a pointer to an array or an allocatable,
dereference it. */
else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
- value = build_fold_indirect_ref (se->expr);
+ value = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* For character(*), use the actual argument's descriptor. */
- else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
- value = build_fold_indirect_ref (se->expr);
+ else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
+ value = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* If the argument is an array descriptor, use it to determine
information about the actual argument's shape. */
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
{
/* Get the actual argument's descriptor. */
- desc = build_fold_indirect_ref (se->expr);
+ desc = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* Create the replacement variable. */
tmp = gfc_conv_descriptor_data_get (desc);
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. */
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;
rse.loop->loopvar[0], offset);
/* Now use the offset for the reference. */
- tmp = build_fold_indirect_ref (info->data);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ info->data);
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;
/* We want either the address for the data or the address of the descriptor,
depending on the mode of passing array arguments. */
}
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;
+ 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 0;
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));
- formal = sym->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 = 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)
{
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
}
+ else if (fsym && fsym->ts.type == BT_CLASS
+ && e->ts.type == BT_DERIVED)
+ {
+ tree data;
+ tree vindex;
+ tree size;
+
+ /* The derived type needs to be converted to a temporary
+ CLASS object. */
+ gfc_init_se (&parmse, se);
+ type = gfc_typenode_for_spec (&fsym->ts);
+ var = gfc_create_var (type, "class");
+
+ /* Get the components. */
+ tmp = fsym->ts.u.derived->components->backend_decl;
+ data = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ var, tmp, NULL_TREE);
+ tmp = fsym->ts.u.derived->components->next->backend_decl;
+ vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ var, tmp, NULL_TREE);
+ tmp = fsym->ts.u.derived->components->next->next->backend_decl;
+ size = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ var, tmp, NULL_TREE);
+
+ /* Set the vindex. */
+ tmp = build_int_cst (TREE_TYPE (vindex), e->ts.u.derived->vindex);
+ gfc_add_modify (&parmse.pre, vindex, tmp);
+
+ /* Set the size. */
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&e->ts));
+ gfc_add_modify (&parmse.pre, size,
+ fold_convert (TREE_TYPE (size), tmp));
+
+ /* Now set the data field. */
+ argss = gfc_walk_expr (e);
+ if (argss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (&parmse, e);
+ tmp = fold_convert (TREE_TYPE (data),
+ parmse.expr);
+ gfc_add_modify (&parmse.pre, data, tmp);
+ }
+ else
+ {
+ gfc_conv_expr (&parmse, e);
+ gfc_add_modify (&parmse.pre, data, parmse.expr);
+ }
+
+ /* Pass the address of the class object. */
+ parmse.expr = gfc_build_addr_expr (NULL_TREE, var);
+ }
else if (se->ss && se->ss->useflags)
{
/* An elemental function inside a scalarized loop. */
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
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 (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))
{
int parm_rank;
- tmp = build_fold_indirect_ref (parmse.expr);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
parm_rank = e->rank;
switch (parm_kind)
{
break;
case (SCALAR_POINTER):
- tmp = build_fold_indirect_ref (tmp);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
break;
}
{
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)
{
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
&& GFC_DESCRIPTOR_TYPE_P
(TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
retargs = gfc_chainon_list (retargs, se->expr);
}
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
retargs = gfc_chainon_list (retargs, tmp);
}
- else if (sym->result->attr.dimension)
+ else if (!comp && sym->result->attr.dimension)
{
gcc_assert (se->loop && info);
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");
where f is pointer valued, we have to dereference the result. */
if (!se->want_pointer && !byref && sym->attr.pointer
&& !gfc_is_proc_ptr_comp (expr, NULL))
- se->expr = build_fold_indirect_ref (se->expr);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
/* f2c calling conventions require a scalar default real function to
return a double precision result. Convert this back to default
/* 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 (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 (var);
+ gcc_assert (ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+ se->expr = build_fold_indirect_ref_loc (input_location, var);
}
}
}
/* For a simple char type, we can call memset(). */
if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
- return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
+ return build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMSET], 3, start,
build_int_cst (gfc_get_int_type (gfc_c_int_kind),
lang_hooks.to_target_charset (' ')),
size);
/* Truncate string if source is too long. */
cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
- tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
+ tmp2 = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMMOVE],
3, dest, src, dlen);
/* Else copy and pad with spaces. */
- tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
+ tmp3 = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMMOVE],
3, dest, src, slen);
tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
/* 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 (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);
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)
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);
- tmp = fold_convert (TREE_TYPE (dest), se.expr);
- gfc_add_modify (&block, dest, tmp);
-
- if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
- tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
+ 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,
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 (!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)
+ {
+ val = gfc_conv_initializer (c->expr, &cm->ts,
+ TREE_TYPE (cm->ts.u.derived->components->backend_decl),
+ cm->ts.u.derived->components->attr.dimension,
+ cm->ts.u.derived->components->attr.pointer);
+
+ /* Append it to the constructor list. */
+ CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->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);
if (expr1->symtree->n.sym->attr.proc_pointer
&& expr1->symtree->n.sym->attr.dummy)
- lse.expr = build_fold_indirect_ref (lse.expr);
+ lse.expr = build_fold_indirect_ref_loc (input_location,
+ lse.expr);
if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
&& expr2->symtree->n.sym->attr.dummy)
- rse.expr = build_fold_indirect_ref (rse.expr);
+ rse.expr = build_fold_indirect_ref_loc (input_location,
+ rse.expr);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
/* 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;
}
len = fold_convert (size_type_node, len);
/* Construct call to __builtin_memset. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMSET],
3, dest, integer_zero_node, len);
return fold_convert (void_type_node, tmp);
}
len = fold_convert (size_type_node, len);
/* Construct call to __builtin_memcpy. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
return fold_convert (void_type_node, tmp);
}
/* 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_start_block (&block);
+
+ if (code->expr2->ts.type != BT_CLASS)
+ {
+ /* Insert an additional assignment which sets the '$vindex' field. */
+ gfc_expr *lhs,*rhs;
+ lhs = gfc_copy_expr (code->expr1);
+ gfc_add_component_ref (lhs, "$vindex");
+ if (code->expr2->ts.type == BT_DERIVED)
+ /* vindex is constant, determined at compile time. */
+ rhs = gfc_int_expr (code->expr2->ts.u.derived->vindex);
+ else if (code->expr2->expr_type == EXPR_NULL)
+ rhs = gfc_int_expr (0);
+ else
+ gcc_unreachable ();
+ tmp = gfc_trans_assignment (lhs, rhs, false);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Insert another assignment which sets the '$size' field. */
+ lhs = gfc_copy_expr (code->expr1);
+ gfc_add_component_ref (lhs, "$size");
+ if (code->expr2->ts.type == BT_DERIVED)
+ {
+ /* Size is fixed at compile time. */
+ gfc_se lse;
+ gfc_init_se (&lse, NULL);
+ gfc_conv_expr (&lse, lhs);
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr2->ts));
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), tmp));
+ }
+ else if (code->expr2->expr_type == EXPR_NULL)
+ {
+ rhs = gfc_int_expr (0);
+ tmp = gfc_trans_assignment (lhs, rhs, false);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gcc_unreachable ();
+
+ 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
