/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+ 2011
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
se->expr));
/* Test for a NULL value. */
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
- fold_convert (TREE_TYPE (tmp), integer_one_node));
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
{
- tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
- fold_convert (TREE_TYPE (se->expr), integer_zero_node));
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
+ present, se->expr,
+ build_zero_cst (TREE_TYPE (se->expr)));
tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = tmp;
}
gfc_init_se (&se, NULL);
+ if (!cl->length
+ && cl->backend_decl
+ && TREE_CODE (cl->backend_decl) == VAR_DECL)
+ return;
+
/* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
"flatten" array constructors by taking their first element; all elements
should be the same length or a cl->length should be present. */
{
gfc_expr* expr_flat;
gcc_assert (expr);
-
expr_flat = gfc_copy_expr (expr);
flatten_array_ctors_without_strlen (expr_flat);
gfc_resolve_expr (expr_flat);
tree gfc_int4_type_node;
int kind;
int ikind;
+ int res_ikind_1, res_ikind_2;
gfc_se lse;
gfc_se rse;
tree fndecl = NULL;
gfc_int4_type_node = gfc_get_int_type (4);
+ /* In case of integer operands with kinds 1 or 2, we call the integer kind 4
+ library routine. But in the end, we have to convert the result back
+ if this case applies -- with res_ikind_K, we keep track whether operand K
+ falls into this case. */
+ res_ikind_1 = -1;
+ res_ikind_2 = -1;
+
kind = expr->value.op.op1->ts.kind;
switch (expr->value.op.op2->ts.type)
{
case 1:
case 2:
rse.expr = convert (gfc_int4_type_node, rse.expr);
+ res_ikind_2 = ikind;
/* Fall through. */
case 4:
case 1:
case 2:
if (expr->value.op.op1->ts.type == BT_INTEGER)
- lse.expr = convert (gfc_int4_type_node, lse.expr);
+ {
+ lse.expr = convert (gfc_int4_type_node, lse.expr);
+ res_ikind_1 = kind;
+ }
else
gcc_unreachable ();
/* Fall through. */
se->expr = build_call_expr_loc (input_location,
fndecl, 2, lse.expr, rse.expr);
+
+ /* Convert the result back if it is of wrong integer kind. */
+ if (res_ikind_1 != -1 && res_ikind_2 != -1)
+ {
+ /* We want the maximum of both operand kinds as result. */
+ if (res_ikind_1 < res_ikind_2)
+ res_ikind_1 = res_ikind_2;
+ se->expr = convert (gfc_get_int_type (res_ikind_1), se->expr);
+ }
}
tree
gfc_string_to_single_character (tree len, tree str, int kind)
{
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
- if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
+ if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
+ || !POINTER_TYPE_P (TREE_TYPE (str)))
return NULL_TREE;
if (TREE_INT_CST_LOW (len) == 1)
{
gfc_se comp_se;
gfc_expr *e2;
+ expr_t old_type;
+
gfc_init_se (&comp_se, NULL);
e2 = gfc_copy_expr (e);
+ /* We have to restore the expr type later so that gfc_free_expr frees
+ the exact same thing that was allocated.
+ TODO: This is ugly. */
+ old_type = e2->expr_type;
e2->expr_type = EXPR_VARIABLE;
gfc_conv_expr (&comp_se, e2);
+ e2->expr_type = old_type;
gfc_free_expr (e2);
return build_fold_addr_expr_loc (input_location, comp_se.expr);
}
gfc_conv_expr (&rse, expr);
gfc_conv_tmp_array_ref (&lse);
- gfc_advance_se_ss_chain (&lse);
if (intent != INTENT_OUT)
{
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
- cmp = gfc_find_component (declared, "$vptr", true, true);
+ cmp = gfc_find_component (declared, "_vptr", true, true);
ctree = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (cmp->backend_decl),
var, cmp->backend_decl, NULL_TREE);
fold_convert (TREE_TYPE (ctree), tmp));
/* Now set the data field. */
- cmp = gfc_find_component (declared, "$data", true, true);
+ cmp = gfc_find_component (declared, "_data", true, true);
ctree = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (cmp->backend_decl),
var, cmp->backend_decl, NULL_TREE);
int
gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
- gfc_actual_arglist * arg, gfc_expr * expr,
+ gfc_actual_arglist * args, gfc_expr * expr,
VEC(tree,gc) *append_args)
{
gfc_interface_mapping mapping;
VEC(tree,gc) *stringargs;
tree result = NULL;
gfc_formal_arglist *formal;
+ gfc_actual_arglist *arg;
int has_alternate_specifier = 0;
bool need_interface_mapping;
bool callee_alloc;
gfc_clear_ts (&ts);
if (sym->from_intmod == INTMOD_ISO_C_BINDING
- && conv_isocbinding_procedure (se, sym, arg))
+ && conv_isocbinding_procedure (se, sym, args))
return 0;
gfc_is_proc_ptr_comp (expr, &comp);
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
return 0;
}
}
}
/* Evaluate the arguments. */
- for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+ for (arg = args; arg != NULL;
+ arg = arg->next, formal = formal ? formal->next : NULL)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
else
f = f || !sym->attr.always_explicit;
+ /* If the argument is a function call that may not create
+ a temporary for the result, we have to check that we
+ can do it, i.e. that there is no alias between this
+ argument and another one. */
+ if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
+ {
+ gfc_expr *iarg;
+ sym_intent intent;
+
+ if (fsym != NULL)
+ intent = fsym->attr.intent;
+ else
+ intent = INTENT_UNKNOWN;
+
+ if (gfc_check_fncall_dependency (e, intent, sym, args,
+ NOT_ELEMENTAL))
+ parmse.force_tmp = 1;
+
+ iarg = e->value.function.actual->expr;
+
+ /* Temporary needed if aliasing due to host association. */
+ if (sym->attr.contained
+ && !sym->attr.pure
+ && !sym->attr.implicit_pure
+ && !sym->attr.use_assoc
+ && iarg->expr_type == EXPR_VARIABLE
+ && sym->ns == iarg->symtree->n.sym->ns)
+ parmse.force_tmp = 1;
+
+ /* Ditto within module. */
+ if (sym->attr.use_assoc
+ && !sym->attr.pure
+ && !sym->attr.implicit_pure
+ && iarg->expr_type == EXPR_VARIABLE
+ && sym->module == iarg->symtree->n.sym->module)
+ parmse.force_tmp = 1;
+ }
+
if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e))
/* The actual argument is a component reference to an
&& ((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))))
+ && (fsym == NULL
+ || (fsym-> as
+ && (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);
}
if (gfc_option.rtcheck & GFC_RTCHECK_POINTER && e != NULL)
{
- symbol_attribute *attr;
+ symbol_attribute attr;
char *msg;
tree cond;
- if (e->expr_type == EXPR_VARIABLE)
- attr = &e->symtree->n.sym->attr;
- else if (e->expr_type == EXPR_FUNCTION)
- {
- /* For intrinsic functions, the gfc_attr are not available. */
- if (e->symtree->n.sym->attr.generic && e->value.function.isym)
- goto end_pointer_check;
-
- if (e->symtree->n.sym->attr.generic)
- attr = &e->value.function.esym->attr;
- else
- attr = &e->symtree->n.sym->result->attr;
- }
+ if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
+ attr = gfc_expr_attr (e);
else
goto end_pointer_check;
- if (attr->optional)
+ if (attr.optional)
{
/* If the actual argument is an optional pointer/allocatable and
the formal argument takes an nonpointer optional value,
See Fortran 2003, Section 12.4.1.6 item (7)+(8). */
tree present, null_ptr, type;
- if (attr->allocatable
+ if (attr.allocatable
&& (fsym == NULL || !fsym->attr.allocatable))
asprintf (&msg, "Allocatable actual argument '%s' is not "
"allocated or not present", e->symtree->n.sym->name);
- else if (attr->pointer
+ else if (attr.pointer
&& (fsym == NULL || !fsym->attr.pointer))
asprintf (&msg, "Pointer actual argument '%s' is not "
"associated or not present",
e->symtree->n.sym->name);
- else if (attr->proc_pointer
+ else if (attr.proc_pointer
&& (fsym == NULL || !fsym->attr.proc_pointer))
asprintf (&msg, "Proc-pointer actual argument '%s' is not "
"associated or not present",
}
else
{
- if (attr->allocatable
+ if (attr.allocatable
&& (fsym == NULL || !fsym->attr.allocatable))
asprintf (&msg, "Allocatable actual argument '%s' is not "
"allocated", e->symtree->n.sym->name);
- else if (attr->pointer
+ else if (attr.pointer
&& (fsym == NULL || !fsym->attr.pointer))
asprintf (&msg, "Pointer actual argument '%s' is not "
"associated", e->symtree->n.sym->name);
- else if (attr->proc_pointer
+ else if (attr.proc_pointer
&& (fsym == NULL || !fsym->attr.proc_pointer))
asprintf (&msg, "Proc-pointer actual argument '%s' is not "
"associated", e->symtree->n.sym->name);
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- result = build_fold_indirect_ref_loc (input_location,
- se->expr);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must do the automatic reallocation.
+ TODO - deal with intrinsics, without using a temporary. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->loop_chain
+ && se->ss->loop_chain->is_alloc_lhs
+ && !expr->value.function.isym
+ && sym->result->as != NULL)
+ {
+ /* Evaluate the bounds of the result, if known. */
+ gfc_set_loop_bounds_from_array_spec (&mapping, se,
+ sym->result->as);
+
+ /* Perform the automatic reallocation. */
+ tmp = gfc_alloc_allocatable_for_assignment (se->loop,
+ expr, NULL);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Pass the temporary as the first argument. */
+ result = info->descriptor;
+ }
+ else
+ result = build_fold_indirect_ref_loc (input_location,
+ se->expr);
VEC_safe_push (tree, gc, retargs, se->expr);
}
else if (comp && comp->attr.dimension)
/* Evaluate the bounds of the result, if known. */
gfc_set_loop_bounds_from_array_spec (&mapping, se, comp->as);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must not generate the function call
+ here but should just send back the results of the mapping.
+ This is signalled by the function ss being flagged. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->is_alloc_lhs)
+ {
+ gfc_free_interface_mapping (&mapping);
+ return has_alternate_specifier;
+ }
+
/* Create a temporary to store the result. In case the function
returns a pointer, the temporary will be a shallow copy and
mustn't be deallocated. */
/* Evaluate the bounds of the result, if known. */
gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
+ /* If the lhs of an assignment x = f(..) is allocatable and
+ f2003 is allowed, we must not generate the function call
+ here but should just send back the results of the mapping.
+ This is signalled by the function ss being flagged. */
+ if (gfc_option.flag_realloc_lhs
+ && se->ss && se->ss->is_alloc_lhs)
+ {
+ gfc_free_interface_mapping (&mapping);
+ return has_alternate_specifier;
+ }
+
/* Create a temporary to store the result. In case the function
returns a pointer, the temporary will be a shallow copy and
mustn't be deallocated. */
if (!se->direct_byref)
{
- if (sym->attr.dimension || (comp && comp->attr.dimension))
+ if ((sym->attr.dimension && !comp) || (comp && comp->attr.dimension))
{
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
/* Exit condition. */
cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i,
- fold_convert (sizetype, integer_zero_node));
+ build_zero_cst (sizetype));
tmp = build1_v (GOTO_EXPR, exit_label);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
build_empty_stmt (input_location));
fold_convert (size_type_node,
TYPE_SIZE_UNIT (chartype)));
- if (dlength)
+ if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
dest = fold_convert (pvoid_type_node, dest);
else
dest = gfc_build_addr_expr (pvoid_type_node, dest);
- if (slength)
+ if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
src = fold_convert (pvoid_type_node, src);
else
src = gfc_build_addr_expr (pvoid_type_node, src);
gcc_assert (fargs->sym->attr.dimension == 0);
fsym = fargs->sym;
- /* Create a temporary to hold the value. */
- type = gfc_typenode_for_spec (&fsym->ts);
- temp_vars[n] = gfc_create_var (type, fsym->name);
-
if (fsym->ts.type == BT_CHARACTER)
{
/* Copy string arguments. */
- tree arglen;
+ tree arglen;
- gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+ 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),
- temp_vars[n]);
+ /* Create a temporary to hold the value. */
+ if (fsym->ts.u.cl->backend_decl == NULL_TREE)
+ fsym->ts.u.cl->backend_decl
+ = gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
- gfc_conv_expr (&rse, args->expr);
- gfc_conv_string_parameter (&rse);
- gfc_add_block_to_block (&se->pre, &lse.pre);
- gfc_add_block_to_block (&se->pre, &rse.pre);
+ type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
+ temp_vars[n] = gfc_create_var (type, fsym->name);
- gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
+ arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+
+ gfc_conv_expr (&rse, args->expr);
+ gfc_conv_string_parameter (&rse);
+ gfc_add_block_to_block (&se->pre, &lse.pre);
+ gfc_add_block_to_block (&se->pre, &rse.pre);
+
+ gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
rse.string_length, rse.expr, fsym->ts.kind);
- gfc_add_block_to_block (&se->pre, &lse.post);
- gfc_add_block_to_block (&se->pre, &rse.post);
+ gfc_add_block_to_block (&se->pre, &lse.post);
+ gfc_add_block_to_block (&se->pre, &rse.post);
}
else
{
/* For everything else, just evaluate the expression. */
+
+ /* Create a temporary to hold the value. */
+ type = gfc_typenode_for_spec (&fsym->ts);
+ temp_vars[n] = gfc_create_var (type, fsym->name);
+
gfc_conv_expr (&lse, args->expr);
gfc_add_block_to_block (&se->pre, &lse.pre);
gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
}
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));
+ tmp = build2_loc (input_location, 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);
}
gfc_class_null_initializer (&cm->ts));
gfc_add_expr_to_block (&block, tmp);
}
- else if (cm->attr.dimension)
+ else if (cm->attr.dimension && !cm->attr.proc_pointer)
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
gfc_start_block (&block);
cm = expr->ts.u.derived->components;
+
+ if (expr->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
+ && (expr->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
+ || expr->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
+ {
+ gfc_se se, lse;
+
+ gcc_assert (cm->backend_decl == NULL);
+ gfc_init_se (&se, NULL);
+ gfc_init_se (&lse, NULL);
+ gfc_conv_expr (&se, gfc_constructor_first (expr->value.constructor)->expr);
+ lse.expr = dest;
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), se.expr));
+
+ return gfc_finish_block (&block);
+ }
+
for (c = gfc_constructor_first (expr->value.constructor);
c; c = gfc_constructor_next (c), cm = cm->next)
{
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_loc (input_location, COMPONENT_REF,
- TREE_TYPE (field),
- dest, field, NULL_TREE);
- tmp = fold_build2_loc (input_location, 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_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
dest, field, NULL_TREE);
if (!c->expr || cm->attr.allocatable)
continue;
- if (strcmp (cm->name, "$size") == 0)
+ 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)
+ && strcmp (cm->name, "_extends") == 0)
{
tree vtab;
gfc_symbol *vtabs;
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)
+ if (expr->expr_type == EXPR_VARIABLE
+ && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
+ || expr->symtree->n.sym->intmod_sym_id
+ == ISOCBINDING_NULL_FUNPTR))
{
/* Set expr_type to EXPR_NULL, which will result in
null_pointer_node being used below. */
if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
return true;
+ /* If the lhs has been host_associated, is in common, a pointer or is
+ a target and the function is not using a RESULT variable, aliasing
+ can occur and a temporary is needed. */
+ if ((sym->attr.host_assoc
+ || sym->attr.in_common
+ || sym->attr.pointer
+ || sym->attr.cray_pointee
+ || sym->attr.target)
+ && expr2->symtree != NULL
+ && expr2->symtree->n.sym == expr2->symtree->n.sym->result)
+ return true;
+
/* A PURE function can unconditionally be called without a temporary. */
if (expr2->value.function.esym != NULL
&& expr2->value.function.esym->attr.pure)
return false;
- /* TODO a function that could correctly be declared PURE but is not
- could do with returning false as well. */
+ /* Implicit_pure functions are those which could legally be declared
+ to be PURE. */
+ if (expr2->value.function.esym != NULL
+ && expr2->value.function.esym->attr.implicit_pure)
+ return false;
if (!sym->attr.use_assoc
&& !sym->attr.in_common
&& !sym->attr.pointer
&& !sym->attr.target
+ && !sym->attr.cray_pointee
&& expr2->value.function.esym)
{
/* A temporary is not needed if the function is not contained and
}
+/* Provide the loop info so that the lhs descriptor can be built for
+ reallocatable assignments from extrinsic function calls. */
+
+static void
+realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss)
+{
+ gfc_loopinfo loop;
+ /* Signal that the function call should not be made by
+ gfc_conv_loop_setup. */
+ se->ss->is_alloc_lhs = 1;
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, *ss);
+ gfc_add_ss_to_loop (&loop, se->ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, where);
+ gfc_copy_loopinfo_to_se (se, &loop);
+ gfc_add_block_to_block (&se->pre, &loop.pre);
+ gfc_add_block_to_block (&se->pre, &loop.post);
+ se->ss->is_alloc_lhs = 0;
+}
+
+
+static void
+realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
+{
+ tree desc;
+ tree tmp;
+ tree offset;
+ int n;
+
+ /* Use the allocation done by the library. */
+ desc = build_fold_indirect_ref_loc (input_location, se->expr);
+ tmp = gfc_conv_descriptor_data_get (desc);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
+ /* Unallocated, the descriptor does not have a dtype. */
+ tmp = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+
+ offset = gfc_index_zero_node;
+ tmp = gfc_index_one_node;
+ /* Now reset the bounds from zero based to unity based. */
+ for (n = 0 ; n < rank; n++)
+ {
+ /* Accumulate the offset. */
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, tmp);
+ /* Now do the bounds. */
+ gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
+ tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_conv_descriptor_lbound_set (&se->post, desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&se->post, desc,
+ gfc_rank_cst[n], tmp);
+
+ /* The extent for the next contribution to offset. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
+ gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ }
+ gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+}
+
+
+
/* Try to translate array(:) = func (...), where func is a transformational
array function, without using a temporary. Returns NULL if this isn't the
case. */
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
gcc_assert (se.ss != gfc_ss_terminator);
+
+ /* Reallocate on assignment needs the loopinfo for extrinsic functions.
+ This is signalled to gfc_conv_procedure_call by setting is_alloc_lhs.
+ Clearly, this cannot be done for an allocatable function result, since
+ the shape of the result is unknown and, in any case, the function must
+ correctly take care of the reallocation internally. For intrinsic
+ calls, the array data is freed and the library takes care of allocation.
+ TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
+ to the library. */
+ if (gfc_option.flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && !gfc_expr_attr (expr1).codimension
+ && !gfc_is_coindexed (expr1)
+ && !(expr2->value.function.esym
+ && expr2->value.function.esym->result->attr.allocatable))
+ {
+ if (!expr2->value.function.isym)
+ {
+ realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss);
+ ss->is_alloc_lhs = 1;
+ }
+ else
+ realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
+ }
+
gfc_conv_function_expr (&se, expr2);
gfc_add_block_to_block (&se.pre, &se.post);
/* If we are zeroing a local array avoid taking its address by emitting
a = {} instead. */
if (!POINTER_TYPE_P (TREE_TYPE (dest)))
- return build2 (MODIFY_EXPR, void_type_node,
- dest, build_constructor (TREE_TYPE (dest), NULL));
+ return build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ dest, build_constructor (TREE_TYPE (dest), NULL));
/* Convert arguments to the correct types. */
dest = fold_convert (pvoid_type_node, dest);
}
+/* Tells whether the expression is to be treated as a variable reference. */
+
+static bool
+expr_is_variable (gfc_expr *expr)
+{
+ gfc_expr *arg;
+
+ if (expr->expr_type == EXPR_VARIABLE)
+ return true;
+
+ arg = gfc_get_noncopying_intrinsic_argument (expr);
+ if (arg)
+ {
+ gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE);
+ return expr_is_variable (arg);
+ }
+
+ return false;
+}
+
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
/* Walk the lhs. */
lss = gfc_walk_expr (expr1);
+ if (gfc_is_reallocatable_lhs (expr1)
+ && !(expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym != NULL))
+ lss->is_alloc_lhs = 1;
rss = NULL;
if (lss != gfc_ss_terminator)
{
if (l_is_temp)
{
gfc_conv_tmp_array_ref (&lse);
- gfc_advance_se_ss_chain (&lse);
if (expr2->ts.type == BT_CHARACTER)
lse.string_length = string_length;
}
must have its components deallocated afterwards. */
scalar_to_array = (expr2->ts.type == BT_DERIVED
&& expr2->ts.u.derived->attr.alloc_comp
- && expr2->expr_type != EXPR_VARIABLE
+ && !expr_is_variable (expr2)
&& !gfc_is_constant_expr (expr2)
&& expr1->rank && !expr2->rank);
if (scalar_to_array && dealloc)
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
l_is_temp || init_flag,
- (expr2->expr_type == EXPR_VARIABLE)
- || scalar_to_array, dealloc);
+ expr_is_variable (expr2) || scalar_to_array,
+ dealloc);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
lse.ss = lss;
gfc_conv_tmp_array_ref (&rse);
- gfc_advance_se_ss_chain (&rse);
gfc_conv_expr (&lse, expr1);
gcc_assert (lse.ss == gfc_ss_terminator
gfc_add_expr_to_block (&body, tmp);
}
+ /* Allocate or reallocate lhs of allocatable array. */
+ if (gfc_option.flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && !gfc_expr_attr (expr1).codimension
+ && !gfc_is_coindexed (expr1))
+ {
+ tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
+ }
+
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body);
{
tree tmp;
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ gfc_error ("Assignment to deferred-length character variable at %L "
+ "not implemented", &expr1->where);
+ return NULL_TREE;
+ }
+
/* Special case a single function returning an array. */
if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
{
gfc_start_block (&block);
lhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (lhs, "$data");
+ gfc_add_data_component (lhs);
rhs = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (rhs, "$vptr");
- gfc_add_component_ref (rhs, "$def_init");
+ gfc_add_vptr_component (rhs);
+ gfc_add_def_init_component (rhs);
sz = gfc_copy_expr (code->expr1);
- gfc_add_component_ref (sz, "$vptr");
- gfc_add_component_ref (sz, "$size");
+ gfc_add_vptr_component (sz);
+ gfc_add_size_component (sz);
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
if (expr2->ts.type != BT_CLASS)
{
- /* Insert an additional assignment which sets the '$vptr' field. */
+ /* Insert an additional assignment which sets the '_vptr' field. */
+ gfc_symbol *vtab = NULL;
+ gfc_symtree *st;
+
lhs = gfc_copy_expr (expr1);
- gfc_add_component_ref (lhs, "$vptr");
+ gfc_add_vptr_component (lhs);
+
if (expr2->ts.type == BT_DERIVED)
- {
- gfc_symbol *vtab;
- gfc_symtree *st;
- vtab = gfc_find_derived_vtab (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;
- }
+ vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL)
- rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
- else
- gcc_unreachable ();
+ vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+ gcc_assert (vtab);
+
+ rhs = gfc_get_expr ();
+ rhs->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
+ rhs->symtree = st;
+ rhs->ts = vtab->ts;
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
if (expr2->ts.type == BT_CLASS)
op = EXEC_ASSIGN;
else
- gfc_add_component_ref (expr1, "$data");
+ gfc_add_data_component (expr1);
if (op == EXEC_ASSIGN)
tmp = gfc_trans_assignment (expr1, expr2, false, true);
OSDN Git Service
