/* 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>
{
tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr),
present, se->expr,
- fold_convert (TREE_TYPE (se->expr), integer_zero_node));
+ build_zero_cst (TREE_TYPE (se->expr)));
tmp = gfc_evaluate_now (tmp, &se->pre);
se->expr = tmp;
}
}
+/* Return for an expression the backend decl of the coarray. */
+
+static tree
+get_tree_for_caf_expr (gfc_expr *expr)
+{
+ tree caf_decl = NULL_TREE;
+ gfc_ref *ref;
+
+ gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
+ if (expr->symtree->n.sym->attr.codimension)
+ caf_decl = expr->symtree->n.sym->backend_decl;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ {
+ gfc_component *comp = ref->u.c.component;
+ if (comp->attr.pointer || comp->attr.allocatable)
+ caf_decl = NULL_TREE;
+ if (comp->attr.codimension)
+ caf_decl = comp->backend_decl;
+ }
+
+ gcc_assert (caf_decl != NULL_TREE);
+ return caf_decl;
+}
+
+
/* 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). */
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);
gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node,
start.expr));
- gfc_free (msg);
+ free (msg);
/* Check upper bound. */
fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
fold_convert (long_integer_type_node, end.expr),
fold_convert (long_integer_type_node,
se->string_length));
- gfc_free (msg);
+ free (msg);
}
/* If the start and end expressions are equal, the length is one. */
field = c->backend_decl;
gcc_assert (TREE_CODE (field) == FIELD_DECL);
decl = se->expr;
+
+ /* Components can correspond to fields of different containing
+ types, as components are created without context, whereas
+ a concrete use of a component has the type of decl as context.
+ So, if the type doesn't match, we search the corresponding
+ FIELD_DECL in the parent type. To not waste too much time
+ we cache this result in norestrict_decl. */
+
+ if (DECL_FIELD_CONTEXT (field) != TREE_TYPE (decl))
+ {
+ tree f2 = c->norestrict_decl;
+ if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
+ for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
+ if (TREE_CODE (f2) == FIELD_DECL
+ && DECL_NAME (f2) == DECL_NAME (field))
+ break;
+ gcc_assert (f2);
+ c->norestrict_decl = f2;
+ field = f2;
+ }
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
decl, field, NULL_TREE);
se->string_length = tmp;
}
- if (((c->attr.pointer || c->attr.allocatable) && c->attr.dimension == 0
+ if (((c->attr.pointer || c->attr.allocatable)
+ && (!c->attr.dimension && !c->attr.codimension)
&& c->ts.type != BT_CHARACTER)
|| c->attr.proc_pointer)
se->expr = build_fold_indirect_ref_loc (input_location,
dt = ref->u.c.sym;
c = ref->u.c.component;
+ /* Return if the component is not in the parent type. */
+ for (cmp = dt->components; cmp; cmp = cmp->next)
+ if (strcmp (c->name, cmp->name) == 0)
+ return;
+
/* Build a gfc_ref to recursively call gfc_conv_component_ref. */
parent.type = REF_COMPONENT;
parent.next = NULL;
if (dt->backend_decl == NULL)
gfc_get_derived_type (dt);
- 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; 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.u.derived;
- parent.u.c.component = c;
- conv_parent_component_references (se, &parent);
- }
+ /* Build the reference and call self. */
+ gfc_conv_component_ref (se, &parent);
+ parent.u.c.sym = dt->components->ts.u.derived;
+ parent.u.c.component = c;
+ conv_parent_component_references (se, &parent);
}
/* Return the contents of a variable. Also handles reference/pointer
static void
gfc_conv_variable (gfc_se * se, gfc_expr * expr)
{
+ gfc_ss *ss;
gfc_ref *ref;
gfc_symbol *sym;
tree parent_decl = NULL_TREE;
bool entry_master;
sym = expr->symtree->n.sym;
- if (se->ss != NULL)
+ ss = se->ss;
+ if (ss != NULL)
{
+ gfc_ss_info *ss_info = ss->info;
+
/* Check that something hasn't gone horribly wrong. */
- gcc_assert (se->ss != gfc_ss_terminator);
- gcc_assert (se->ss->expr == expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ gcc_assert (ss_info->expr == expr);
/* A scalarized term. We already know the descriptor. */
- se->expr = se->ss->data.info.descriptor;
- se->string_length = se->ss->string_length;
- for (ref = se->ss->data.info.ref; ref; ref = ref->next)
+ se->expr = ss_info->data.array.descriptor;
+ se->string_length = ss_info->string_length;
+ for (ref = ss_info->data.array.ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
break;
}
}
else if (!sym->attr.value)
{
- /* Dereference non-character scalar dummy arguments. */
- if (sym->attr.dummy && !sym->attr.dimension)
+ /* Dereference non-character scalar dummy arguments. */
+ if (sym->attr.dummy && !sym->attr.dimension
+ && !(sym->attr.codimension && sym->attr.allocatable))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
- || !sym->attr.dimension))
+ || (!sym->attr.dimension
+ && (!sym->attr.codimension || !sym->attr.allocatable))))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
}
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. */
switch (kind)
{
case 0:
- fndecl = built_in_decls[BUILT_IN_POWIF];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
break;
case 1:
- fndecl = built_in_decls[BUILT_IN_POWI];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWI);
break;
case 2:
- fndecl = built_in_decls[BUILT_IN_POWIL];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
break;
case 3:
/* Use the __builtin_powil() only if real(kind=16) is
actually the C long double type. */
if (!gfc_real16_is_float128)
- fndecl = built_in_decls[BUILT_IN_POWIL];
+ fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
break;
default:
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);
}
sym->new_sym->n.sym->formal = NULL;
gfc_free_symbol (sym->new_sym->n.sym);
gfc_free_expr (sym->expr);
- gfc_free (sym->new_sym);
- gfc_free (sym);
+ free (sym->new_sym);
+ free (sym);
}
for (cl = mapping->charlens; cl; cl = nextcl)
{
nextcl = cl->next;
gfc_free_expr (cl->length);
- gfc_free (cl);
+ free (cl);
}
}
expr->symtree = sym->new_sym;
else if (sym->expr)
gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
+ /* Replace base type for polymorphic arguments. */
+ if (expr->ref && expr->ref->type == REF_COMPONENT
+ && sym->expr && sym->expr->ts.type == BT_CLASS)
+ expr->ref->u.c.sym = sym->expr->ts.u.derived;
}
/* ...and to subexpressions in expr->value. */
gfc_ss *rss;
gfc_loopinfo loop;
gfc_loopinfo loop2;
- gfc_ss_info *info;
+ gfc_array_info *info;
tree offset;
tree tmp_index;
tree tmp;
|| GFC_DESCRIPTOR_TYPE_P (base_type))
base_type = gfc_get_element_type (base_type);
- loop.temp_ss = gfc_get_ss ();;
- loop.temp_ss->type = GFC_SS_TEMP;
- loop.temp_ss->data.temp.type = base_type;
+ loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER)
+ ? expr->ts.u.cl->backend_decl
+ : NULL),
+ loop.dimen);
- if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
- else
- loop.temp_ss->string_length = NULL;
-
- parmse->string_length = loop.temp_ss->string_length;
- loop.temp_ss->data.temp.dimen = loop.dimen;
- loop.temp_ss->next = gfc_ss_terminator;
+ parmse->string_length = loop.temp_ss->info->string_length;
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, loop.temp_ss);
gfc_conv_loop_setup (&loop, &expr->where);
/* Pass the temporary descriptor back to the caller. */
- info = &loop.temp_ss->data.info;
+ info = &loop.temp_ss->info->data.array;
parmse->expr = info->descriptor;
/* Setup the gfc_se structures. */
gfc_conv_expr (&rse, expr);
gfc_conv_tmp_array_ref (&lse);
- gfc_advance_se_ss_chain (&lse);
if (intent != INTENT_OUT)
{
dimensions, so this is very simple. The offset is only computed
outside the innermost loop, so the overall transfer could be
optimized further. */
- info = &rse.ss->data.info;
- dimen = info->dimen;
+ info = &rse.ss->info->data.array;
+ dimen = rse.ss->dimen;
tmp_index = gfc_index_zero_node;
for (n = dimen - 1; n > 0; n--)
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);
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.
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;
tree fntype;
gfc_se parmse;
gfc_ss *argss;
- gfc_ss_info *info;
+ gfc_array_info *info;
int byref;
int parm_kind;
tree type;
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);
{
if (!sym->attr.elemental)
{
- gcc_assert (se->ss->type == GFC_SS_FUNCTION);
- if (se->ss->useflags)
+ gcc_assert (se->ss->info->type == GFC_SS_FUNCTION);
+ if (se->ss->info->useflags)
{
gcc_assert ((!comp && gfc_return_by_reference (sym)
&& sym->result->attr.dimension)
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
return 0;
}
}
- info = &se->ss->data.info;
+ info = &se->ss->info->data.array;
}
else
info = NULL;
}
/* 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;
gfc_init_se (&parmse, se);
gfc_conv_derived_to_class (&parmse, e, fsym->ts);
}
- else if (se->ss && se->ss->useflags)
+ else if (se->ss && se->ss->info->useflags)
{
/* An elemental function inside a scalarized loop. */
gfc_init_se (&parmse, se);
&& fsym->attr.flavor != FL_PROCEDURE)
|| (fsym->attr.proc_pointer
&& !(e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.dummy))
- || (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy))
+ || (fsym->attr.proc_pointer
+ && e->expr_type == EXPR_VARIABLE
&& gfc_is_proc_ptr_comp (e, NULL))
|| fsym->attr.allocatable))
{
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)
+ /* In Fortran 2008 it's allowed to pass a NULL pointer/nonallocated
+ allocatable to an optional dummy, cf. 12.5.2.12. */
+ if (fsym != NULL && fsym->attr.optional && !attr.proc_pointer
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ goto end_pointer_check;
+
+ 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);
else
goto end_pointer_check;
+ tmp = parmse.expr;
+
+ /* If the argument is passed by value, we need to strip the
+ INDIRECT_REF. */
+ if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
cond = fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, parmse.expr,
- fold_convert (TREE_TYPE (parmse.expr),
+ boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp),
null_pointer_node));
}
gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
msg);
- gfc_free (msg);
+ free (msg);
}
end_pointer_check:
+ /* Deferred length dummies pass the character length by reference
+ so that the value can be returned. */
+ if (parmse.string_length && fsym && fsym->ts.deferred)
+ {
+ tmp = parmse.string_length;
+ if (TREE_CODE (tmp) != VAR_DECL)
+ tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
+ parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
/* Character strings are passed as two parameters, a length and a
pointer - except for Bind(c) which only passes the pointer. */
if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
VEC_safe_push (tree, gc, stringargs, parmse.string_length);
+ /* For descriptorless coarrays and assumed-shape coarray dummies, we
+ pass the token and the offset as additional arguments. */
+ if (fsym && fsym->attr.codimension
+ && gfc_option.coarray == GFC_FCOARRAY_LIB
+ && !fsym->attr.allocatable
+ && e == NULL)
+ {
+ /* Token and offset. */
+ VEC_safe_push (tree, gc, stringargs, null_pointer_node);
+ VEC_safe_push (tree, gc, stringargs,
+ build_int_cst (gfc_array_index_type, 0));
+ gcc_assert (fsym->attr.optional);
+ }
+ else if (fsym && fsym->attr.codimension
+ && !fsym->attr.allocatable
+ && gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ tree caf_decl, caf_type;
+ tree offset, tmp2;
+
+ caf_decl = get_tree_for_caf_expr (e);
+ caf_type = TREE_TYPE (caf_decl);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ tmp = gfc_conv_descriptor_token (caf_decl);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+ tmp = GFC_DECL_TOKEN (caf_decl);
+ else
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+ tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
+ }
+
+ VEC_safe_push (tree, gc, stringargs, tmp);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+ && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
+ offset = build_int_cst (gfc_array_index_type, 0);
+ else if (DECL_LANG_SPECIFIC (caf_decl)
+ && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+ offset = GFC_DECL_CAF_OFFSET (caf_decl);
+ else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
+ offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
+ else
+ offset = build_int_cst (gfc_array_index_type, 0);
+
+ if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+ tmp = gfc_conv_descriptor_data_get (caf_decl);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (caf_type));
+ tmp = caf_decl;
+ }
+
+ if (fsym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
+ (TREE_TYPE (parmse.expr))));
+ tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+ tmp2 = gfc_conv_descriptor_data_get (tmp2);
+ }
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+ tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+ tmp2 = parmse.expr;
+ }
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type, tmp2),
+ fold_convert (gfc_array_index_type, tmp));
+ offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+
+ VEC_safe_push (tree, gc, stringargs, offset);
+ }
+
VEC_safe_push (tree, gc, arglist, parmse.expr);
}
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
we take the character length of the first argument for the result.
For dummies, we have to look through the formal argument list for
this function and use the character length found there.*/
- if (!sym->attr.dummy)
+ if (ts.deferred && (sym->attr.allocatable || sym->attr.pointer))
+ cl.backend_decl = gfc_create_var (gfc_charlen_type_node, "slen");
+ else if (!sym->attr.dummy)
cl.backend_decl = VEC_index (tree, stringargs, 0);
else
{
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)
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&comp->ts);
- info->dimen = se->loop->dimen;
+ gcc_assert (se->ss->dimen == se->loop->dimen);
/* 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. */
callee_alloc = comp->attr.allocatable || comp->attr.pointer;
- gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
- NULL_TREE, false, !comp->attr.pointer,
- callee_alloc, &se->ss->expr->where);
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
+ tmp, NULL_TREE, false,
+ !comp->attr.pointer, callee_alloc,
+ &se->ss->info->expr->where);
/* Pass the temporary as the first argument. */
result = info->descriptor;
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&ts);
- info->dimen = se->loop->dimen;
+ gcc_assert (se->ss->dimen == se->loop->dimen);
/* 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. */
callee_alloc = sym->attr.allocatable || sym->attr.pointer;
- gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
- NULL_TREE, false, !sym->attr.pointer,
- callee_alloc, &se->ss->expr->where);
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, se->ss,
+ tmp, NULL_TREE, false,
+ !sym->attr.pointer, callee_alloc,
+ &se->ss->info->expr->where);
/* Pass the temporary as the first argument. */
result = info->descriptor;
VEC_safe_push (tree, gc, retargs, var);
}
+ if (ts.type == BT_CHARACTER && ts.deferred
+ && (sym->attr.allocatable || sym->attr.pointer))
+ {
+ tmp = len;
+ if (TREE_CODE (tmp) != VAR_DECL)
+ tmp = gfc_evaluate_now (len, &se->pre);
+ len = gfc_build_addr_expr (NULL_TREE, tmp);
+ }
+
/* Add the string length to the argument list. */
if (ts.type == BT_CHARACTER)
VEC_safe_push (tree, gc, retargs, len);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
with other functions. For dummy arguments, the typing is done to
- to this result, even if it has to be repeated for each call. */
+ this result, even if it has to be repeated for each call. */
if (has_alternate_specifier
&& TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
{
x = f()
where f is pointer valued, we have to dereference the result. */
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);
+ && ((!comp && (sym->attr.pointer || sym->attr.allocatable))
+ || (comp && (comp->attr.pointer || comp->attr.allocatable))))
+ 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
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)
{
else
se->expr = var;
- se->string_length = len;
+ if (!ts.deferred)
+ se->string_length = len;
+ else if (sym->attr.allocatable || sym->attr.pointer)
+ se->string_length = cl.backend_decl;
}
else
{
/* For a simple char type, we can call memset(). */
if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
return build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMSET], 3, start,
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, start,
build_int_cst (gfc_get_int_type (gfc_c_int_kind),
lang_hooks.to_target_charset (' ')),
size);
/* 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_build2_loc (input_location, MINUS_EXPR, sizetype, i,
TYPE_SIZE_UNIT (type)));
gfc_add_modify (&loop, el,
- fold_build2_loc (input_location, POINTER_PLUS_EXPR,
- TREE_TYPE (el), el, TYPE_SIZE_UNIT (type)));
+ fold_build_pointer_plus_loc (input_location,
+ el, TYPE_SIZE_UNIT (type)));
/* Making the loop... actually loop! */
tmp = gfc_finish_block (&loop);
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);
cond2 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, slen,
dlen);
tmp2 = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMMOVE],
- 3, dest, src, dlen);
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, dest, src, dlen);
/* Else copy and pad with spaces. */
tmp3 = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMMOVE],
- 3, dest, src, slen);
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, dest, src, slen);
- tmp4 = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (dest),
- dest, fold_convert (sizetype, slen));
+ tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen);
tmp4 = fill_with_spaces (tmp4, chartype,
fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE(dlen), dlen, slen));
n = 0;
for (fargs = sym->formal; fargs; fargs = fargs->next)
n++;
- saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
- temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
+ saved_vars = XCNEWVEC (gfc_saved_var, n);
+ temp_vars = XCNEWVEC (tree, n);
for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
{
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);
+
+ arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
- gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
+ 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);
/* Restore the original variables. */
for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
gfc_restore_sym (fargs->sym, &saved_vars[n]);
- gfc_free (saved_vars);
+ free (saved_vars);
}
static void
gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
{
- gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
- gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
+ gfc_ss *ss;
+
+ ss = se->ss;
+ gcc_assert (ss != NULL && ss != gfc_ss_terminator);
+ gcc_assert (ss->info->expr == expr && ss->info->type == GFC_SS_CONSTRUCTOR);
gfc_conv_tmp_array_ref (se);
- gfc_advance_se_ss_chain (se);
}
gfc_se lse;
gfc_ss *rss;
gfc_ss *lss;
+ gfc_array_info *lss_array;
stmtblock_t body;
stmtblock_t block;
gfc_loopinfo loop;
/* Walk the rhs. */
rss = gfc_walk_expr (expr);
if (rss == gfc_ss_terminator)
- {
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_ss ();
- rss->next = gfc_ss_terminator;
- rss->type = GFC_SS_SCALAR;
- rss->expr = expr;
- }
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr);
/* Create a SS for the destination. */
- lss = gfc_get_ss ();
- lss->type = GFC_SS_COMPONENT;
- lss->expr = NULL;
- lss->shape = gfc_get_shape (cm->as->rank);
- lss->next = gfc_ss_terminator;
- lss->data.info.dimen = cm->as->rank;
- lss->data.info.descriptor = dest;
- lss->data.info.data = gfc_conv_array_data (dest);
- lss->data.info.offset = gfc_conv_array_offset (dest);
+ lss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
+ GFC_SS_COMPONENT);
+ lss_array = &lss->info->data.array;
+ lss_array->shape = gfc_get_shape (cm->as->rank);
+ lss_array->descriptor = dest;
+ lss_array->data = gfc_conv_array_data (dest);
+ lss_array->offset = gfc_conv_array_offset (dest);
for (n = 0; n < cm->as->rank; n++)
{
- lss->data.info.dim[n] = n;
- lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
- lss->data.info.stride[n] = gfc_index_one_node;
+ lss_array->start[n] = gfc_conv_array_lbound (dest, n);
+ lss_array->stride[n] = gfc_index_one_node;
- mpz_init (lss->shape[n]);
- mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
+ mpz_init (lss_array->shape[n]);
+ mpz_sub (lss_array->shape[n], cm->as->upper[n]->value.integer,
cm->as->lower[n]->value.integer);
- mpz_add_ui (lss->shape[n], lss->shape[n], 1);
+ mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
}
/* Associate the SS with the loop. */
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
- for (n = 0; n < cm->as->rank; n++)
- mpz_clear (lss->shape[n]);
- gfc_free (lss->shape);
-
+ gcc_assert (lss_array->shape != NULL);
+ gfc_free_shape (&lss_array->shape, cm->as->rank);
gfc_cleanup_loop (&loop);
return gfc_finish_block (&block);
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);
components. Although the latter have a default initializer
of EXPR_NULL,... by default, the static nullify is not needed
since this is done every time we come into scope. */
- if (!c->expr || cm->attr.allocatable)
+ if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
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;
void
gfc_conv_expr (gfc_se * se, gfc_expr * expr)
{
- if (se->ss && se->ss->expr == expr
- && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
+ gfc_ss *ss;
+
+ ss = se->ss;
+ if (ss && ss->info->expr == expr
+ && (ss->info->type == GFC_SS_SCALAR
+ || ss->info->type == GFC_SS_REFERENCE))
{
+ gfc_ss_info *ss_info;
+
+ ss_info = ss->info;
/* Substitute a scalar expression evaluated outside the scalarization
loop. */
- se->expr = se->ss->data.scalar.expr;
- if (se->ss->type == GFC_SS_REFERENCE)
+ se->expr = ss_info->data.scalar.value;
+ if (ss_info->type == GFC_SS_REFERENCE)
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
- se->string_length = se->ss->string_length;
+ se->string_length = ss_info->string_length;
gfc_advance_se_ss_chain (se);
return;
}
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. */
void
gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
{
+ gfc_ss *ss;
tree var;
- if (se->ss && se->ss->expr == expr
- && se->ss->type == GFC_SS_REFERENCE)
+ ss = se->ss;
+ if (ss && ss->info->expr == expr
+ && ss->info->type == GFC_SS_REFERENCE)
{
/* Returns a reference to the scalar evaluated outside the loop
for this case. */
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. */
+ really added if -fbounds-check is enabled. Exclude deferred
+ character length lefthand sides. */
if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL
+ && !(expr1->ts.deferred
+ && (TREE_CODE (lse.string_length) == VAR_DECL))
&& !expr1->symtree->n.sym->attr.proc_pointer
&& !gfc_is_proc_ptr_comp (expr1, NULL))
{
&block);
}
+ /* The assignment to an deferred character length sets the string
+ length to that of the rhs. */
+ if (expr1->ts.deferred && (TREE_CODE (lse.string_length) == VAR_DECL))
+ {
+ if (expr2->expr_type != EXPR_NULL)
+ gfc_add_modify (&block, lse.string_length, rse.string_length);
+ else
+ gfc_add_modify (&block, lse.string_length,
+ build_int_cst (gfc_charlen_type_node, 0));
+ }
+
gfc_add_modify (&block, lse.expr,
fold_convert (TREE_TYPE (lse.expr), rse.expr));
}
gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
- gcc_assert (se->string_length
- && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
}
if (gfc_ref_needs_temporary_p (expr1->ref))
return true;
- /* Functions returning pointers need temporaries. */
- if (expr2->symtree->n.sym->attr.pointer
- || expr2->symtree->n.sym->attr.allocatable)
+ /* Functions returning pointers or allocatables need temporaries. */
+ c = expr2->value.function.esym
+ ? (expr2->value.function.esym->attr.pointer
+ || expr2->value.function.esym->attr.allocatable)
+ : (expr2->symtree->n.sym->attr.pointer
+ || expr2->symtree->n.sym->attr.allocatable);
+ if (c)
return true;
/* Character array functions need temporaries unless the
return true;
/* If we have reached here with an intrinsic function, we do not
- need a temporary. */
+ need a temporary except in the particular case that reallocation
+ on assignment is active and the lhs is allocatable and a target. */
if (expr2->value.function.isym)
- return false;
+ return (gfc_option.flag_realloc_lhs
+ && sym->attr.allocatable
+ && sym->attr.target);
/* If the LHS is a dummy, we need a temporary if it is not
INTENT(OUT). */
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;
+}
+
+
+/* For Assignment to a reallocatable lhs from intrinsic functions,
+ replace the se.expr (ie. the result) with a temporary descriptor.
+ Null the data field so that the library allocates space for the
+ result. Free the data of the original descriptor after the function,
+ in case it appears in an argument expression and transfer the
+ result to the original descriptor. */
+
+static void
+fcncall_realloc_result (gfc_se *se, int rank)
+{
+ tree desc;
+ tree res_desc;
+ tree tmp;
+ tree offset;
+ int n;
+
+ /* Use the allocation done by the library. Substitute the lhs
+ descriptor with a copy, whose data field is nulled.*/
+ desc = build_fold_indirect_ref_loc (input_location, se->expr);
+ /* 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)));
+ res_desc = gfc_evaluate_now (desc, &se->pre);
+ gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
+ se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
+
+ /* Free the lhs after the function call and copy the result to
+ the lhs descriptor. */
+ tmp = gfc_conv_descriptor_data_get (desc);
+ tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+ gfc_add_expr_to_block (&se->post, tmp);
+ gfc_add_modify (&se->post, desc, res_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. */
gfc_se se;
gfc_ss *ss;
gfc_component *comp = NULL;
+ gfc_loopinfo loop;
if (arrayfunc_assign_needs_temporary (expr1, expr2))
return NULL;
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, &loop);
+ ss->is_alloc_lhs = 1;
+ }
+ else
+ fcncall_realloc_result (&se, expr1->rank);
+ }
+
gfc_conv_function_expr (&se, expr2);
gfc_add_block_to_block (&se.pre, &se.post);
/* Construct call to __builtin_memset. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMSET],
- 3, dest, integer_zero_node, len);
+ builtin_decl_explicit (BUILT_IN_MEMSET),
+ 3, dest, integer_zero_node, len);
return fold_convert (void_type_node, tmp);
}
/* Construct call to __builtin_memcpy. */
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
+ 3, dst, src, len);
return fold_convert (void_type_node, tmp);
}
}
+/* 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;
+}
+
+
+/* Is the lhs OK for automatic reallocation? */
+
+static bool
+is_scalar_reallocatable_lhs (gfc_expr *expr)
+{
+ gfc_ref * ref;
+
+ /* An allocatable variable with no reference. */
+ if (expr->symtree->n.sym->attr.allocatable
+ && !expr->ref)
+ return true;
+
+ /* All that can be left are allocatable components. */
+ if ((expr->symtree->n.sym->ts.type != BT_DERIVED
+ && expr->symtree->n.sym->ts.type != BT_CLASS)
+ || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+ return false;
+
+ /* Find an allocatable component ref last. */
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ && !ref->next
+ && ref->u.c.component->attr.allocatable)
+ return true;
+
+ return false;
+}
+
+
+/* Allocate or reallocate scalar lhs, as necessary. */
+
+static void
+alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
+ tree string_length,
+ gfc_expr *expr1,
+ gfc_expr *expr2)
+
+{
+ tree cond;
+ tree tmp;
+ tree size;
+ tree size_in_bytes;
+ tree jump_label1;
+ tree jump_label2;
+ gfc_se lse;
+
+ if (!expr1 || expr1->rank)
+ return;
+
+ if (!expr2 || expr2->rank)
+ return;
+
+ /* Since this is a scalar lhs, we can afford to do this. That is,
+ there is no risk of side effects being repeated. */
+ gfc_init_se (&lse, NULL);
+ lse.want_pointer = 1;
+ gfc_conv_expr (&lse, expr1);
+
+ jump_label1 = gfc_build_label_decl (NULL_TREE);
+ jump_label2 = gfc_build_label_decl (NULL_TREE);
+
+ /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */
+ tmp = build_int_cst (TREE_TYPE (lse.expr), 0);
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ lse.expr, tmp);
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (block, tmp);
+
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ /* Use the rhs string length and the lhs element size. */
+ size = string_length;
+ tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
+ tmp = TYPE_SIZE_UNIT (tmp);
+ size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp), tmp,
+ fold_convert (TREE_TYPE (tmp), size));
+ }
+ else
+ {
+ /* Otherwise use the length in bytes of the rhs. */
+ size = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
+ size_in_bytes = size;
+ }
+
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1, size_in_bytes);
+ tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+ gfc_add_modify (block, lse.expr, tmp);
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ /* Deferred characters need checking for lhs and rhs string
+ length. Other deferred parameter variables will have to
+ come here too. */
+ tmp = build1_v (GOTO_EXPR, jump_label2);
+ gfc_add_expr_to_block (block, tmp);
+ }
+ tmp = build1_v (LABEL_EXPR, jump_label1);
+ gfc_add_expr_to_block (block, tmp);
+
+ /* For a deferred length character, reallocate if lengths of lhs and
+ rhs are different. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ expr1->ts.u.cl->backend_decl, size);
+ /* Jump past the realloc if the lengths are the same. */
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (block, tmp);
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2, fold_convert (pvoid_type_node, lse.expr),
+ size_in_bytes);
+ tmp = fold_convert (TREE_TYPE (lse.expr), tmp);
+ gfc_add_modify (block, lse.expr, tmp);
+ tmp = build1_v (LABEL_EXPR, jump_label2);
+ gfc_add_expr_to_block (block, tmp);
+
+ /* Update the lhs character length. */
+ size = string_length;
+ gfc_add_modify (block, expr1->ts.u.cl->backend_decl, size);
+ }
+}
+
+
/* 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
stmtblock_t body;
bool l_is_temp;
bool scalar_to_array;
+ bool def_clen_func;
tree string_length;
int n;
/* 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)
{
- /* Allow the scalarizer to workshare array assignments. */
- if (ompws_flags & OMPWS_WORKSHARE_FLAG)
- ompws_flags |= OMPWS_SCALARIZER_WS;
-
/* The assignment needs scalarization. */
lss_section = lss;
/* Find a non-scalar SS from the lhs. */
while (lss_section != gfc_ss_terminator
- && lss_section->type != GFC_SS_SECTION)
+ && lss_section->info->type != GFC_SS_SECTION)
lss_section = lss_section->next;
gcc_assert (lss_section != gfc_ss_terminator);
/* Walk the rhs. */
rss = gfc_walk_expr (expr2);
if (rss == gfc_ss_terminator)
- {
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_ss ();
- rss->next = gfc_ss_terminator;
- rss->type = GFC_SS_SCALAR;
- rss->expr = expr2;
- }
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+
/* Associate the SS with the loop. */
gfc_add_ss_to_loop (&loop, lss);
gfc_add_ss_to_loop (&loop, rss);
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop);
/* Enable loop reversal. */
- for (n = 0; n < loop.dimen; n++)
- loop.reverse[n] = GFC_REVERSE_NOT_SET;
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
gfc_mark_ss_chain_used (loop.temp_ss, 3);
}
+ /* Allow the scalarizer to workshare array assignments. */
+ if ((ompws_flags & OMPWS_WORKSHARE_FLAG) && loop.temp_ss == NULL)
+ ompws_flags |= OMPWS_SCALARIZER_WS;
+
/* Start the scalarized loop body. */
gfc_start_scalarized_body (&loop, &body);
}
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)
gfc_add_expr_to_block (&loop.post, tmp);
}
+ /* For a deferred character length function, the function call must
+ happen before the (re)allocation of the lhs, otherwise the character
+ length of the result is not known. */
+ def_clen_func = (((expr2->expr_type == EXPR_FUNCTION)
+ || (expr2->expr_type == EXPR_COMPCALL)
+ || (expr2->expr_type == EXPR_PPC))
+ && expr2->ts.deferred);
+ if (gfc_option.flag_realloc_lhs
+ && expr2->ts.type == BT_CHARACTER
+ && (def_clen_func || expr2->expr_type == EXPR_OP)
+ && expr1->ts.deferred)
+ gfc_add_block_to_block (&block, &rse.pre);
+
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
+ || expr2->expr_type == EXPR_ARRAY, dealloc);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
{
+ /* F2003: Add the code for reallocation on assignment. */
+ if (gfc_option.flag_realloc_lhs
+ && is_scalar_reallocatable_lhs (expr1))
+ alloc_scalar_allocatable_for_assignment (&block, rse.string_length,
+ expr1, expr2);
+
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &body);
}
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);
}
+ /* F2003: 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))
+ {
+ ompws_flags &= ~OMPWS_SCALARIZER_WS;
+ 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);
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);
+
+ /* Make sure that the component backend_decls have been built, which
+ will not have happened if the derived types concerned have not
+ been referenced. */
+ gfc_get_derived_type (rhs->ts.u.derived);
+ 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
