#include "system.h"
#include "coretypes.h"
#include "tree.h"
+#include "gimple.h"
+#include "ggc.h"
#include "toplev.h"
+#include "real.h"
#include "flags.h"
#include "gfortran.h"
-#include "constructor.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "dependency.h"
static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
-static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
+static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
/* The contents of this structure aren't actually used, just the address. */
static gfc_ss gfc_ss_terminator_var;
/* Initialize the descriptor. */
type =
- gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
+ gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
of array constructor C. */
static bool
-gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
{
- gfc_constructor *c;
gfc_iterator *i;
mpz_t val;
mpz_t len;
mpz_init (val);
dynamic = false;
- for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+ for (; c; c = c->next)
{
i = c->iterator;
if (i && gfc_iterator_has_dynamic_bounds (i))
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
- tree desc, gfc_constructor_base base,
+ tree desc, gfc_constructor * c,
tree * poffset, tree * offsetvar,
bool dynamic)
{
stmtblock_t body;
gfc_se se;
mpz_t size;
- gfc_constructor *c;
tree shadow_loopvar = NULL_TREE;
gfc_saved_var saved_loopvar;
mpz_init (size);
- for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+ for (; c; c = c->next)
{
/* If this is an iterator or an array, the offset must be a variable. */
if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
n = 0;
while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
{
- p = gfc_constructor_next (p);
+ p = p->next;
n++;
}
if (n < 4)
else
{
/* Collect multiple scalar constants into a constructor. */
- VEC(constructor_elt,gc) *v = NULL;
+ tree list;
tree init;
tree bound;
tree tmptype;
HOST_WIDE_INT idx = 0;
p = c;
+ list = NULL_TREE;
/* Count the number of consecutive scalar constants. */
while (p && !(p->iterator
|| p->expr->expr_type != EXPR_CONSTANT))
(gfc_get_pchar_type (p->expr->ts.kind),
se.expr);
- CONSTRUCTOR_APPEND_ELT (v,
- build_int_cst (gfc_array_index_type,
- idx++),
- se.expr);
+ list = tree_cons (build_int_cst (gfc_array_index_type,
+ idx++), se.expr, list);
c = p;
- p = gfc_constructor_next (p);
+ p = p->next;
}
bound = build_int_cst (NULL_TREE, n - 1);
gfc_index_zero_node, bound);
tmptype = build_array_type (type, tmptype);
- init = build_constructor (tmptype, v);
+ init = build_constructor_from_list (tmptype, nreverse (list));
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
/* Create a static variable to hold the data. */
Returns TRUE if all elements are character constants. */
bool
-get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
{
- gfc_constructor *c;
bool is_const;
-
+
is_const = TRUE;
- if (gfc_constructor_first (base) == NULL)
+ if (c == NULL)
{
if (len)
*len = build_int_cstu (gfc_charlen_type_node, 0);
/* Loop over all constructor elements to find out is_const, but in len we
want to store the length of the first, not the last, element. We can
of course exit the loop as soon as is_const is found to be false. */
- for (c = gfc_constructor_first (base);
- c && is_const; c = gfc_constructor_next (c))
+ for (; c && is_const; c = c->next)
{
switch (c->expr->expr_type)
{
return zero. Note, an empty or NULL array constructor returns zero. */
unsigned HOST_WIDE_INT
-gfc_constant_array_constructor_p (gfc_constructor_base base)
+gfc_constant_array_constructor_p (gfc_constructor * c)
{
unsigned HOST_WIDE_INT nelem = 0;
- gfc_constructor *c = gfc_constructor_first (base);
while (c)
{
if (c->iterator
|| c->expr->rank > 0
|| c->expr->expr_type != EXPR_CONSTANT)
return 0;
- c = gfc_constructor_next (c);
+ c = c->next;
nelem++;
}
return nelem;
tree
gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
{
- tree tmptype, init, tmp;
+ tree tmptype, list, init, tmp;
HOST_WIDE_INT nelem;
gfc_constructor *c;
gfc_array_spec as;
gfc_se se;
int i;
- VEC(constructor_elt,gc) *v = NULL;
/* First traverse the constructor list, converting the constants
to tree to build an initializer. */
nelem = 0;
- c = gfc_constructor_first (expr->value.constructor);
+ list = NULL_TREE;
+ c = expr->value.constructor;
while (c)
{
gfc_init_se (&se, NULL);
else if (POINTER_TYPE_P (type))
se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
se.expr);
- CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
- se.expr);
- c = gfc_constructor_next (c);
+ list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
+ se.expr, list);
+ c = c->next;
nelem++;
}
as.type = AS_EXPLICIT;
if (!expr->shape)
{
- as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
- as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, nelem - 1);
+ as.lower[0] = gfc_int_expr (0);
+ as.upper[0] = gfc_int_expr (nelem - 1);
}
else
for (i = 0; i < expr->rank; i++)
{
int tmp = (int) mpz_get_si (expr->shape[i]);
- as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
- as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, tmp - 1);
+ as.lower[i] = gfc_int_expr (0);
+ as.upper[i] = gfc_int_expr (tmp - 1);
}
tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
- init = build_constructor (tmptype, v);
+ init = build_constructor_from_list (tmptype, nreverse (list));
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
{
- gfc_constructor_base c;
+ gfc_constructor *c;
tree offset;
tree offsetvar;
tree desc;
break;
case GFC_SS_REFERENCE:
- /* Scalar argument to elemental procedure. Evaluate this
- now. */
+ /* Scalar reference. Evaluate this now. */
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, ss->expr);
+ gfc_conv_expr_reference (&se, ss->expr);
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_add_block_to_block (&loop->post, &se.post);
&& se->loop->ss->loop_chain->expr->symtree)
name = se->loop->ss->loop_chain->expr->symtree->name;
+ if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
+ && se->loop->ss->loop_chain->expr->symtree)
+ name = se->loop->ss->loop_chain->expr->symtree->name;
+
if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
{
if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
name = "unnamed constant";
}
- if (TREE_CODE (descriptor) == VAR_DECL)
- name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
-
/* If upper bound is present, include both bounds in the error message. */
if (check_upper)
{
gfc_conv_array_data (desc));
index = gfc_build_array_ref (data, index, NULL);
index = gfc_evaluate_now (index, &se->pre);
- index = fold_convert (gfc_array_index_type, index);
/* Do any bounds checking on the final info->descriptor index. */
index = gfc_trans_array_bound_check (se, info->descriptor,
gfc_se indexse;
gfc_se tmpse;
- if (ar->dimen == 0)
- return;
-
/* Handle scalarized references separately. */
if (ar->type != AR_ELEMENT)
{
if (size[n])
{
tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
- asprintf (&msg, "Array bound mismatch for dimension %d "
- "of array '%s' (%%ld/%%ld)",
+ asprintf (&msg, "%s, size mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
info->dim[n]+1, ss->expr->symtree->name);
-
gfc_trans_runtime_check (true, false, tmp3, &inner,
&ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp),
fold_convert (long_integer_type_node, size[n]));
-
gfc_free (msg);
}
else
tree tmp;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
bool dynamic[GFC_MAX_DIMENSIONS];
+ gfc_constructor *c;
mpz_t *cshape;
mpz_t i;
if (ss->type == GFC_SS_CONSTRUCTOR)
{
- gfc_constructor_base base;
/* An unknown size constructor will always be rank one.
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
can be determined at compile time. Prefer not to otherwise,
since the general case involves realloc, and it's better to
avoid that overhead if possible. */
- base = ss->expr->value.constructor;
- dynamic[n] = gfc_get_array_constructor_size (&i, base);
+ c = ss->expr->value.constructor;
+ dynamic[n] = gfc_get_array_constructor_size (&i, c);
if (!dynamic[n] || !loopspec[n])
loopspec[n] = ss;
continue;
/*GCC ARRAYS*/
static tree
-gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
+gfc_array_init_size (tree descriptor, int rank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper,
stmtblock_t * pblock)
{
stride = gfc_evaluate_now (stride, pblock);
}
- for (n = rank; n < rank + corank; n++)
- {
- ubound = upper[n];
-
- /* Set lower bound. */
- gfc_init_se (&se, NULL);
- if (lower == NULL || lower[n] == NULL)
- {
- gcc_assert (n == rank + corank - 1);
- se.expr = gfc_index_one_node;
- }
- else
- {
- if (ubound || n == rank + corank - 1)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
- else
- {
- se.expr = gfc_index_one_node;
- ubound = lower[n];
- }
- }
- gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
- se.expr);
-
- if (n < rank + corank - 1)
- {
- gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_conv_descriptor_ubound_set (pblock, descriptor, gfc_rank_cst[n], se.expr);
- }
- }
-
/* The stride is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable_array, coarray;
+ bool allocatable_array;
ref = expr->ref;
/* Find the last reference in the chain. */
while (ref && ref->next != NULL)
{
- gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
prev_ref = ref;
ref = ref->next;
}
return false;
if (!prev_ref)
- {
- allocatable_array = expr->symtree->n.sym->attr.allocatable;
- coarray = expr->symtree->n.sym->attr.codimension;
- }
+ allocatable_array = expr->symtree->n.sym->attr.allocatable;
else
- {
- allocatable_array = prev_ref->u.c.component->attr.allocatable;
- coarray = prev_ref->u.c.component->attr.codimension;
- }
-
- /* Return if this is a scalar coarray. */
- if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
- || (prev_ref && !prev_ref->u.c.component->attr.dimension))
- {
- gcc_assert (coarray);
- return false;
- }
+ allocatable_array = prev_ref->u.c.component->attr.allocatable;
/* Figure out the size of the array. */
switch (ref->u.ar.type)
{
case AR_ELEMENT:
- if (!coarray)
- {
- lower = NULL;
- upper = ref->u.ar.start;
- break;
- }
- /* Fall through. */
-
- case AR_SECTION:
- lower = ref->u.ar.start;
- upper = ref->u.ar.end;
+ lower = NULL;
+ upper = ref->u.ar.start;
break;
case AR_FULL:
upper = ref->u.ar.as->upper;
break;
+ case AR_SECTION:
+ lower = ref->u.ar.start;
+ upper = ref->u.ar.end;
+ break;
+
default:
gcc_unreachable ();
break;
}
- size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
- ref->u.ar.as->corank, &offset, lower, upper,
- &se->pre);
+ size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
+ lower, upper, &se->pre);
/* Allocate memory to store the data. */
pointer = gfc_conv_descriptor_data_get (se->expr);
{
gfc_constructor *c;
tree tmp;
+ mpz_t maxval;
gfc_se se;
HOST_WIDE_INT hi;
unsigned HOST_WIDE_INT lo;
- tree index;
+ tree index, range;
VEC(constructor_elt,gc) *v = NULL;
switch (expr->expr_type)
case EXPR_ARRAY:
/* Create a vector of all the elements. */
- for (c = gfc_constructor_first (expr->value.constructor);
- c; c = gfc_constructor_next (c))
+ for (c = expr->value.constructor; c; c = c->next)
{
if (c->iterator)
{
gfc_option.flag_max_array_constructor);
return NULL_TREE;
}
- if (mpz_cmp_si (c->offset, 0) != 0)
- index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
+ if (mpz_cmp_si (c->n.offset, 0) != 0)
+ index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
else
index = NULL_TREE;
+ mpz_init (maxval);
+ if (mpz_cmp_si (c->repeat, 0) != 0)
+ {
+ tree tmp1, tmp2;
+
+ mpz_set (maxval, c->repeat);
+ mpz_add (maxval, c->n.offset, maxval);
+ mpz_sub_ui (maxval, maxval, 1);
+ tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+ if (mpz_cmp_si (c->n.offset, 0) != 0)
+ {
+ mpz_add_ui (maxval, c->n.offset, 1);
+ tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+ }
+ else
+ tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
+
+ range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
+ }
+ else
+ range = NULL;
+ mpz_clear (maxval);
gfc_init_se (&se, NULL);
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
gfc_conv_constant (&se, c->expr);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ if (range == NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ else
+ {
+ if (index != NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+ }
break;
case EXPR_STRUCTURE:
for one reason or another, assuming that if they are
standard defying the frontend will catch them. */
gfc_conv_expr (&se, c->expr);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ if (range == NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ else
+ {
+ if (index != NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+ }
break;
}
}
{
/* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
char * msg;
- tree temp;
-
- temp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- ubound, lbound);
- temp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, temp);
- stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ ubound, lbound);
+ stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
dubound, dlbound);
- stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, stride2);
-
- tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
- asprintf (&msg, "Dimension %d of array '%s' has extent "
- "%%ld instead of %%ld", n+1, sym->name);
-
- gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg,
- fold_convert (long_integer_type_node, temp),
- fold_convert (long_integer_type_node, stride2));
-
+ tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
+ asprintf (&msg, "%s for dimension %d of array '%s'",
+ gfc_msg_bounds, n+1, sym->name);
+ gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
gfc_free (msg);
}
}
gfc_trans_scalarizing_loops (&loop, &block);
desc = loop.temp_ss->data.info.descriptor;
+
+ gcc_assert (is_gimple_lvalue (desc));
}
else if (expr->expr_type == EXPR_FUNCTION)
{
{
/* Otherwise make a new one. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
- parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
+ parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
}
+/* Check for default initializer; sym->value is not enough as it is also
+ set for EXPR_NULL of allocatables. */
+
+static bool
+has_default_initializer (gfc_symbol *der)
+{
+ gfc_component *c;
+
+ gcc_assert (der->attr.flavor == FL_DERIVED);
+ for (c = der->components; c; c = c->next)
+ if ((c->ts.type != BT_DERIVED && c->initializer)
+ || (c->ts.type == BT_DERIVED
+ && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
+ break;
+
+ return c != NULL;
+}
+
+
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
Do likewise, recursively if necessary, with the allocatable components of
derived types. */
if (!sym->attr.save
&& !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
{
- if (sym->value == NULL
- || !gfc_has_default_initializer (sym->ts.u.derived))
+ if (sym->value == NULL || !has_default_initializer (sym->ts.u.derived))
{
rank = sym->as ? sym->as->rank : 0;
tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
continue;
ar = &ref->u.ar;
-
- if (ar->as->rank == 0)
- {
- /* Scalar coarray. */
- continue;
- }
-
switch (ar->type)
{
case AR_ELEMENT:
if (intent != INTENT_OUT)
{
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false, true);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);
gcc_assert (lse.ss == gfc_ss_terminator);
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
gfc_add_expr_to_block (&body, tmp);
/* Generate the copying loops. */
gfc_conv_expr (&rse, expr);
- tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true);
gfc_add_expr_to_block (&body, tmp);
gcc_assert (rse.ss == gfc_ss_terminator);
if (cm->ts.type == BT_CHARACTER)
lse.string_length = cm->ts.u.cl->backend_decl;
lse.expr = dest;
- tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
+ tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
/* Generate code for assignment of scalar variables. Includes character
- strings and derived types with allocatable components. */
+ strings and derived types with allocatable components.
+ If you know that the LHS has no allocations, set dealloc to false. */
tree
gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
- bool l_is_temp, bool r_is_var)
+ bool l_is_temp, bool r_is_var, bool dealloc)
{
stmtblock_t block;
tree tmp;
the same as the rhs. This must be done following the assignment
to prevent deallocating data that could be used in the rhs
expression. */
- if (!l_is_temp)
+ if (!l_is_temp && dealloc)
{
tmp = gfc_evaluate_now (lse->expr, &lse->pre);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
/* Subroutine of gfc_trans_assignment that actually scalarizes the
- assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS. */
+ assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
+ init_flag indicates initialization expressions and dealloc that no
+ deallocate prior assignment is needed (if in doubt, set true). */
static tree
-gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+ bool dealloc)
{
gfc_se lse;
gfc_se rse;
&& expr2->expr_type != EXPR_VARIABLE
&& !gfc_is_constant_expr (expr2)
&& expr1->rank && !expr2->rank);
- if (scalar_to_array)
+ if (scalar_to_array && dealloc)
{
tmp = gfc_deallocate_alloc_comp (expr2->ts.u.derived, rse.expr, 0);
gfc_add_expr_to_block (&loop.post, tmp);
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
l_is_temp || init_flag,
(expr2->expr_type == EXPR_VARIABLE)
- || scalar_to_array);
+ || scalar_to_array, dealloc);
gfc_add_expr_to_block (&body, tmp);
if (lss == gfc_ss_terminator)
rse.string_length = string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- false, false);
+ false, false, dealloc);
gfc_add_expr_to_block (&body, tmp);
}
/* Translate an assignment. */
tree
-gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
+gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
+ bool dealloc)
{
tree tmp;
}
/* Fallback to the scalarizer to generate explicit loops. */
- return gfc_trans_assignment_1 (expr1, expr2, init_flag);
+ return gfc_trans_assignment_1 (expr1, expr2, init_flag, dealloc);
}
tree
gfc_trans_init_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr1, code->expr2, true);
+ return gfc_trans_assignment (code->expr1, code->expr2, true, false);
}
tree
gfc_trans_assign (gfc_code * code)
{
- return gfc_trans_assignment (code->expr1, code->expr2, false);
+ return gfc_trans_assignment (code->expr1, code->expr2, false, true);
}