Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / fortran / trans-array.cc
blob: 05134952db43d586b83f0cb307309f90b7ce0111 [file] [log] [blame]
/* Array translation routines
Copyright (C) 2002-2022 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* trans-array.cc-- Various array related code, including scalarization,
allocation, initialization and other support routines. */
/* How the scalarizer works.
In gfortran, array expressions use the same core routines as scalar
expressions.
First, a Scalarization State (SS) chain is built. This is done by walking
the expression tree, and building a linear list of the terms in the
expression. As the tree is walked, scalar subexpressions are translated.
The scalarization parameters are stored in a gfc_loopinfo structure.
First the start and stride of each term is calculated by
gfc_conv_ss_startstride. During this process the expressions for the array
descriptors and data pointers are also translated.
If the expression is an assignment, we must then resolve any dependencies.
In Fortran all the rhs values of an assignment must be evaluated before
any assignments take place. This can require a temporary array to store the
values. We also require a temporary when we are passing array expressions
or vector subscripts as procedure parameters.
Array sections are passed without copying to a temporary. These use the
scalarizer to determine the shape of the section. The flag
loop->array_parameter tells the scalarizer that the actual values and loop
variables will not be required.
The function gfc_conv_loop_setup generates the scalarization setup code.
It determines the range of the scalarizing loop variables. If a temporary
is required, this is created and initialized. Code for scalar expressions
taken outside the loop is also generated at this time. Next the offset and
scaling required to translate from loop variables to array indices for each
term is calculated.
A call to gfc_start_scalarized_body marks the start of the scalarized
expression. This creates a scope and declares the loop variables. Before
calling this gfc_make_ss_chain_used must be used to indicate which terms
will be used inside this loop.
The scalar gfc_conv_* functions are then used to build the main body of the
scalarization loop. Scalarization loop variables and precalculated scalar
values are automatically substituted. Note that gfc_advance_se_ss_chain
must be used, rather than changing the se->ss directly.
For assignment expressions requiring a temporary two sub loops are
generated. The first stores the result of the expression in the temporary,
the second copies it to the result. A call to
gfc_trans_scalarized_loop_boundary marks the end of the main loop code and
the start of the copying loop. The temporary may be less than full rank.
Finally gfc_trans_scalarizing_loops is called to generate the implicit do
loops. The loops are added to the pre chain of the loopinfo. The post
chain may still contain cleanup code.
After the loop code has been added into its parent scope gfc_cleanup_loop
is called to free all the SS allocated by the scalarizer. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "options.h"
#include "tree.h"
#include "gfortran.h"
#include "gimple-expr.h"
#include "trans.h"
#include "fold-const.h"
#include "constructor.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "dependency.h"
static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
/* The contents of this structure aren't actually used, just the address. */
static gfc_ss gfc_ss_terminator_var;
gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
static tree
gfc_array_dataptr_type (tree desc)
{
return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
}
/* Build expressions to access members of the CFI descriptor. */
#define CFI_FIELD_BASE_ADDR 0
#define CFI_FIELD_ELEM_LEN 1
#define CFI_FIELD_VERSION 2
#define CFI_FIELD_RANK 3
#define CFI_FIELD_ATTRIBUTE 4
#define CFI_FIELD_TYPE 5
#define CFI_FIELD_DIM 6
#define CFI_DIM_FIELD_LOWER_BOUND 0
#define CFI_DIM_FIELD_EXTENT 1
#define CFI_DIM_FIELD_SM 2
static tree
gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
{
tree type = TREE_TYPE (desc);
gcc_assert (TREE_CODE (type) == RECORD_TYPE
&& TYPE_FIELDS (type)
&& (strcmp ("base_addr",
IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
== 0));
tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
gcc_assert (field != NULL_TREE);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
}
tree
gfc_get_cfi_desc_base_addr (tree desc)
{
return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
}
tree
gfc_get_cfi_desc_elem_len (tree desc)
{
return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
}
tree
gfc_get_cfi_desc_version (tree desc)
{
return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
}
tree
gfc_get_cfi_desc_rank (tree desc)
{
return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
}
tree
gfc_get_cfi_desc_type (tree desc)
{
return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
}
tree
gfc_get_cfi_desc_attribute (tree desc)
{
return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
}
static tree
gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
{
tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true);
tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
gcc_assert (field != NULL_TREE);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
tmp, field, NULL_TREE);
}
tree
gfc_get_cfi_dim_lbound (tree desc, tree idx)
{
return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
}
tree
gfc_get_cfi_dim_extent (tree desc, tree idx)
{
return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
}
tree
gfc_get_cfi_dim_sm (tree desc, tree idx)
{
return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
}
#undef CFI_FIELD_BASE_ADDR
#undef CFI_FIELD_ELEM_LEN
#undef CFI_FIELD_VERSION
#undef CFI_FIELD_RANK
#undef CFI_FIELD_ATTRIBUTE
#undef CFI_FIELD_TYPE
#undef CFI_FIELD_DIM
#undef CFI_DIM_FIELD_LOWER_BOUND
#undef CFI_DIM_FIELD_EXTENT
#undef CFI_DIM_FIELD_SM
/* Build expressions to access the members of an array descriptor.
It's surprisingly easy to mess up here, so never access
an array descriptor by "brute force", always use these
functions. This also avoids problems if we change the format
of an array descriptor.
To understand these magic numbers, look at the comments
before gfc_build_array_type() in trans-types.cc.
The code within these defines should be the only code which knows the format
of an array descriptor.
Any code just needing to read obtain the bounds of an array should use
gfc_conv_array_* rather than the following functions as these will return
know constant values, and work with arrays which do not have descriptors.
Don't forget to #undef these! */
#define DATA_FIELD 0
#define OFFSET_FIELD 1
#define DTYPE_FIELD 2
#define SPAN_FIELD 3
#define DIMENSION_FIELD 4
#define CAF_TOKEN_FIELD 5
#define STRIDE_SUBFIELD 0
#define LBOUND_SUBFIELD 1
#define UBOUND_SUBFIELD 2
static tree
gfc_get_descriptor_field (tree desc, unsigned field_idx)
{
tree type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
gcc_assert (field != NULL_TREE);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
}
/* This provides READ-ONLY access to the data field. The field itself
doesn't have the proper type. */
tree
gfc_conv_descriptor_data_get (tree desc)
{
tree type = TREE_TYPE (desc);
if (TREE_CODE (type) == REFERENCE_TYPE)
gcc_unreachable ();
tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field);
}
/* This provides WRITE access to the data field.
TUPLES_P is true if we are generating tuples.
This function gets called through the following macros:
gfc_conv_descriptor_data_set
gfc_conv_descriptor_data_set. */
void
gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
{
tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
}
/* This provides address access to the data field. This should only be
used by array allocation, passing this on to the runtime. */
tree
gfc_conv_descriptor_data_addr (tree desc)
{
tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
return gfc_build_addr_expr (NULL_TREE, field);
}
static tree
gfc_conv_descriptor_offset (tree desc)
{
tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
tree
gfc_conv_descriptor_offset_get (tree desc)
{
return gfc_conv_descriptor_offset (desc);
}
void
gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
tree value)
{
tree t = gfc_conv_descriptor_offset (desc);
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
tree
gfc_conv_descriptor_dtype (tree desc)
{
tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
return field;
}
static tree
gfc_conv_descriptor_span (tree desc)
{
tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
tree
gfc_conv_descriptor_span_get (tree desc)
{
return gfc_conv_descriptor_span (desc);
}
void
gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
tree value)
{
tree t = gfc_conv_descriptor_span (desc);
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
tree
gfc_conv_descriptor_rank (tree desc)
{
tree tmp;
tree dtype;
dtype = gfc_conv_descriptor_dtype (desc);
tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
gcc_assert (tmp != NULL_TREE
&& TREE_TYPE (tmp) == signed_char_type_node);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
dtype, tmp, NULL_TREE);
}
/* Return the element length from the descriptor dtype field. */
tree
gfc_conv_descriptor_elem_len (tree desc)
{
tree tmp;
tree dtype;
dtype = gfc_conv_descriptor_dtype (desc);
tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
GFC_DTYPE_ELEM_LEN);
gcc_assert (tmp != NULL_TREE
&& TREE_TYPE (tmp) == size_type_node);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
dtype, tmp, NULL_TREE);
}
tree
gfc_conv_descriptor_attribute (tree desc)
{
tree tmp;
tree dtype;
dtype = gfc_conv_descriptor_dtype (desc);
tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
GFC_DTYPE_ATTRIBUTE);
gcc_assert (tmp!= NULL_TREE
&& TREE_TYPE (tmp) == short_integer_type_node);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
dtype, tmp, NULL_TREE);
}
tree
gfc_conv_descriptor_type (tree desc)
{
tree tmp;
tree dtype;
dtype = gfc_conv_descriptor_dtype (desc);
tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
gcc_assert (tmp!= NULL_TREE
&& TREE_TYPE (tmp) == signed_char_type_node);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
dtype, tmp, NULL_TREE);
}
tree
gfc_get_descriptor_dimension (tree desc)
{
tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
return field;
}
static tree
gfc_conv_descriptor_dimension (tree desc, tree dim)
{
tree tmp;
tmp = gfc_get_descriptor_dimension (desc);
return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
}
tree
gfc_conv_descriptor_token (tree desc)
{
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
/* Should be a restricted pointer - except in the finalization wrapper. */
gcc_assert (TREE_TYPE (field) == prvoid_type_node
|| TREE_TYPE (field) == pvoid_type_node);
return field;
}
static tree
gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
{
tree tmp = gfc_conv_descriptor_dimension (desc, dim);
tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
gcc_assert (field != NULL_TREE);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
tmp, field, NULL_TREE);
}
static tree
gfc_conv_descriptor_stride (tree desc, tree dim)
{
tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
tree
gfc_conv_descriptor_stride_get (tree desc, tree dim)
{
tree type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
if (integer_zerop (dim)
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
return gfc_conv_descriptor_stride (desc, dim);
}
void
gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
tree dim, tree value)
{
tree t = gfc_conv_descriptor_stride (desc, dim);
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
static tree
gfc_conv_descriptor_lbound (tree desc, tree dim)
{
tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
tree
gfc_conv_descriptor_lbound_get (tree desc, tree dim)
{
return gfc_conv_descriptor_lbound (desc, dim);
}
void
gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
tree dim, tree value)
{
tree t = gfc_conv_descriptor_lbound (desc, dim);
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
static tree
gfc_conv_descriptor_ubound (tree desc, tree dim)
{
tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
tree
gfc_conv_descriptor_ubound_get (tree desc, tree dim)
{
return gfc_conv_descriptor_ubound (desc, dim);
}
void
gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
tree dim, tree value)
{
tree t = gfc_conv_descriptor_ubound (desc, dim);
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
/* Build a null array descriptor constructor. */
tree
gfc_build_null_descriptor (tree type)
{
tree field;
tree tmp;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
gcc_assert (DATA_FIELD == 0);
field = TYPE_FIELDS (type);
/* Set a NULL data pointer. */
tmp = build_constructor_single (type, field, null_pointer_node);
TREE_CONSTANT (tmp) = 1;
/* All other fields are ignored. */
return tmp;
}
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
void
gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
int dim, tree new_lbound)
{
tree offs, ubound, lbound, stride;
tree diff, offs_diff;
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
offs = gfc_conv_descriptor_offset_get (desc);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
/* Get difference (new - old) by which to shift stuff. */
diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
new_lbound, lbound);
/* Shift ubound and offset accordingly. This has to be done before
updating the lbound, as they depend on the lbound expression! */
ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
ubound, diff);
gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
diff, stride);
offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
offs, offs_diff);
gfc_conv_descriptor_offset_set (block, desc, offs);
/* Finally set lbound to value we want. */
gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
}
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
tree *dtype_off, tree *span_off,
tree *dim_off, tree *dim_size,
tree *stride_suboff, tree *lower_suboff,
tree *upper_suboff)
{
tree field;
tree type;
type = TYPE_MAIN_VARIANT (desc_type);
field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
*data_off = byte_position (field);
field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
*dtype_off = byte_position (field);
field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
*span_off = byte_position (field);
field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
*dim_off = byte_position (field);
type = TREE_TYPE (TREE_TYPE (field));
*dim_size = TYPE_SIZE_UNIT (type);
field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
*stride_suboff = byte_position (field);
field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
*lower_suboff = byte_position (field);
field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
*upper_suboff = byte_position (field);
}
/* Cleanup those #defines. */
#undef DATA_FIELD
#undef OFFSET_FIELD
#undef DTYPE_FIELD
#undef SPAN_FIELD
#undef DIMENSION_FIELD
#undef CAF_TOKEN_FIELD
#undef STRIDE_SUBFIELD
#undef LBOUND_SUBFIELD
#undef UBOUND_SUBFIELD
/* Mark a SS chain as used. Flags specifies in which loops the SS is used.
flags & 1 = Main loop body.
flags & 2 = temp copy loop. */
void
gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags)
{
for (; ss != gfc_ss_terminator; ss = ss->next)
ss->info->useflags = flags;
}
/* Free a gfc_ss chain. */
void
gfc_free_ss_chain (gfc_ss * ss)
{
gfc_ss *next;
while (ss != gfc_ss_terminator)
{
gcc_assert (ss != NULL);
next = ss->next;
gfc_free_ss (ss);
ss = next;
}
}
static void
free_ss_info (gfc_ss_info *ss_info)
{
int n;
ss_info->refcount--;
if (ss_info->refcount > 0)
return;
gcc_assert (ss_info->refcount == 0);
switch (ss_info->type)
{
case GFC_SS_SECTION:
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
if (ss_info->data.array.subscript[n])
gfc_free_ss_chain (ss_info->data.array.subscript[n]);
break;
default:
break;
}
free (ss_info);
}
/* Free a SS. */
void
gfc_free_ss (gfc_ss * ss)
{
free_ss_info (ss->info);
free (ss);
}
/* Creates and initializes an array type gfc_ss struct. */
gfc_ss *
gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
{
gfc_ss *ss;
gfc_ss_info *ss_info;
int i;
ss_info = gfc_get_ss_info ();
ss_info->refcount++;
ss_info->type = type;
ss_info->expr = expr;
ss = gfc_get_ss ();
ss->info = ss_info;
ss->next = next;
ss->dimen = dimen;
for (i = 0; i < ss->dimen; i++)
ss->dim[i] = i;
return ss;
}
/* Creates and initializes a temporary type gfc_ss struct. */
gfc_ss *
gfc_get_temp_ss (tree type, tree string_length, int dimen)
{
gfc_ss *ss;
gfc_ss_info *ss_info;
int i;
ss_info = gfc_get_ss_info ();
ss_info->refcount++;
ss_info->type = GFC_SS_TEMP;
ss_info->string_length = string_length;
ss_info->data.temp.type = type;
ss = gfc_get_ss ();
ss->info = ss_info;
ss->next = gfc_ss_terminator;
ss->dimen = dimen;
for (i = 0; i < ss->dimen; i++)
ss->dim[i] = i;
return ss;
}
/* Creates and initializes a scalar type gfc_ss struct. */
gfc_ss *
gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
{
gfc_ss *ss;
gfc_ss_info *ss_info;
ss_info = gfc_get_ss_info ();
ss_info->refcount++;
ss_info->type = GFC_SS_SCALAR;
ss_info->expr = expr;
ss = gfc_get_ss ();
ss->info = ss_info;
ss->next = next;
return ss;
}
/* Free all the SS associated with a loop. */
void
gfc_cleanup_loop (gfc_loopinfo * loop)
{
gfc_loopinfo *loop_next, **ploop;
gfc_ss *ss;
gfc_ss *next;
ss = loop->ss;
while (ss != gfc_ss_terminator)
{
gcc_assert (ss != NULL);
next = ss->loop_chain;
gfc_free_ss (ss);
ss = next;
}
/* Remove reference to self in the parent loop. */
if (loop->parent)
for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next)
if (*ploop == loop)
{
*ploop = loop->next;
break;
}
/* Free non-freed nested loops. */
for (loop = loop->nested; loop; loop = loop_next)
{
loop_next = loop->next;
gfc_cleanup_loop (loop);
free (loop);
}
}
static void
set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop)
{
int n;
for (; ss != gfc_ss_terminator; ss = ss->next)
{
ss->loop = loop;
if (ss->info->type == GFC_SS_SCALAR
|| ss->info->type == GFC_SS_REFERENCE
|| ss->info->type == GFC_SS_TEMP)
continue;
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
if (ss->info->data.array.subscript[n] != NULL)
set_ss_loop (ss->info->data.array.subscript[n], loop);
}
}
/* Associate a SS chain with a loop. */
void
gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head)
{
gfc_ss *ss;
gfc_loopinfo *nested_loop;
if (head == gfc_ss_terminator)
return;
set_ss_loop (head, loop);
ss = head;
for (; ss && ss != gfc_ss_terminator; ss = ss->next)
{
if (ss->nested_ss)
{
nested_loop = ss->nested_ss->loop;
/* More than one ss can belong to the same loop. Hence, we add the
loop to the chain only if it is different from the previously
added one, to avoid duplicate nested loops. */
if (nested_loop != loop->nested)
{
gcc_assert (nested_loop->parent == NULL);
nested_loop->parent = loop;
gcc_assert (nested_loop->next == NULL);
nested_loop->next = loop->nested;
loop->nested = nested_loop;
}
else
gcc_assert (nested_loop->parent == loop);
}
if (ss->next == gfc_ss_terminator)
ss->loop_chain = loop->ss;
else
ss->loop_chain = ss->next;
}
gcc_assert (ss == gfc_ss_terminator);
loop->ss = head;
}
/* Returns true if the expression is an array pointer. */
static bool
is_pointer_array (tree expr)
{
if (expr == NULL_TREE
|| !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr))
|| GFC_CLASS_TYPE_P (TREE_TYPE (expr)))
return false;
if (TREE_CODE (expr) == VAR_DECL
&& GFC_DECL_PTR_ARRAY_P (expr))
return true;
if (TREE_CODE (expr) == PARM_DECL
&& GFC_DECL_PTR_ARRAY_P (expr))
return true;
if (TREE_CODE (expr) == INDIRECT_REF
&& GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0)))
return true;
/* The field declaration is marked as an pointer array. */
if (TREE_CODE (expr) == COMPONENT_REF
&& GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1))
&& !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1))))
return true;
return false;
}
/* If the symbol or expression reference a CFI descriptor, return the
pointer to the converted gfc descriptor. If an array reference is
present as the last argument, check that it is the one applied to
the CFI descriptor in the expression. Note that the CFI object is
always the symbol in the expression! */
static bool
get_CFI_desc (gfc_symbol *sym, gfc_expr *expr,
tree *desc, gfc_array_ref *ar)
{
tree tmp;
if (!is_CFI_desc (sym, expr))
return false;
if (expr && ar)
{
if (!(expr->ref && expr->ref->type == REF_ARRAY)
|| (&expr->ref->u.ar != ar))
return false;
}
if (sym == NULL)
tmp = expr->symtree->n.sym->backend_decl;
else
tmp = sym->backend_decl;
if (tmp && DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
*desc = tmp;
return true;
}
/* Return the span of an array. */
tree
gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
if (is_pointer_array (desc)
|| (get_CFI_desc (NULL, expr, &desc, NULL)
&& (POINTER_TYPE_P (TREE_TYPE (desc))
? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
: GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
{
if (POINTER_TYPE_P (TREE_TYPE (desc)))
desc = build_fold_indirect_ref_loc (input_location, desc);
/* This will have the span field set. */
tmp = gfc_conv_descriptor_span_get (desc);
}
else if (expr->ts.type == BT_ASSUMED)
{
if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
if (POINTER_TYPE_P (TREE_TYPE (desc)))
desc = build_fold_indirect_ref_loc (input_location, desc);
tmp = gfc_conv_descriptor_span_get (desc);
}
else if (TREE_CODE (desc) == COMPONENT_REF
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
{
/* The descriptor is a class _data field and so use the vtable
size for the receiving span field. */
tmp = gfc_get_vptr_from_expr (desc);
tmp = gfc_vptr_size_get (tmp);
}
else if (expr && expr->expr_type == EXPR_VARIABLE
&& expr->symtree->n.sym->ts.type == BT_CLASS
&& expr->ref->type == REF_COMPONENT
&& expr->ref->next->type == REF_ARRAY
&& expr->ref->next->next == NULL
&& CLASS_DATA (expr->symtree->n.sym)->attr.dimension)
{
/* Dummys come in sometimes with the descriptor detached from
the class field or declaration. */
tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl);
tmp = gfc_vptr_size_get (tmp);
}
else
{
/* If none of the fancy stuff works, the span is the element
size of the array. Attempt to deal with unbounded character
types if possible. Otherwise, return NULL_TREE. */
tmp = gfc_get_element_type (TREE_TYPE (desc));
if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
{
gcc_assert (expr->ts.type == BT_CHARACTER);
tmp = gfc_get_character_len_in_bytes (tmp);
if (tmp == NULL_TREE || integer_zerop (tmp))
{
tree bs;
tmp = gfc_get_expr_charlen (expr);
tmp = fold_convert (gfc_array_index_type, tmp);
bs = build_int_cst (gfc_array_index_type, expr->ts.kind);
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, tmp, bs);
}
tmp = (tmp && !integer_zerop (tmp))
? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
}
else
tmp = fold_convert (gfc_array_index_type,
size_in_bytes (tmp));
}
return tmp;
}
/* Generate an initializer for a static pointer or allocatable array. */
void
gfc_trans_static_array_pointer (gfc_symbol * sym)
{
tree type;
gcc_assert (TREE_STATIC (sym->backend_decl));
/* Just zero the data member. */
type = TREE_TYPE (sym->backend_decl);
DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
}
/* If the bounds of SE's loop have not yet been set, see if they can be
determined from array spec AS, which is the array spec of a called
function. MAPPING maps the callee's dummy arguments to the values
that the caller is passing. Add any initialization and finalization
code to SE. */
void
gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
gfc_se * se, gfc_array_spec * as)
{
int n, dim, total_dim;
gfc_se tmpse;
gfc_ss *ss;
tree lower;
tree upper;
tree tmp;
total_dim = 0;
if (!as || as->type != AS_EXPLICIT)
return;
for (ss = se->ss; ss; ss = ss->parent)
{
total_dim += ss->loop->dimen;
for (n = 0; n < ss->loop->dimen; n++)
{
/* The bound is known, nothing to do. */
if (ss->loop->to[n] != NULL_TREE)
continue;
dim = ss->dim[n];
gcc_assert (dim < as->rank);
gcc_assert (ss->loop->dimen <= as->rank);
/* Evaluate the lower bound. */
gfc_init_se (&tmpse, NULL);
gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
lower = fold_convert (gfc_array_index_type, tmpse.expr);
/* ...and the upper bound. */
gfc_init_se (&tmpse, NULL);
gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
gfc_add_block_to_block (&se->pre, &tmpse.pre);
gfc_add_block_to_block (&se->post, &tmpse.post);
upper = fold_convert (gfc_array_index_type, tmpse.expr);
/* Set the upper bound of the loop to UPPER - LOWER. */
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, upper, lower);
tmp = gfc_evaluate_now (tmp, &se->pre);
ss->loop->to[n] = tmp;
}
}
gcc_assert (total_dim == as->rank);
}
/* Generate code to allocate an array temporary, or create a variable to
hold the data. If size is NULL, zero the descriptor so that the
callee will allocate the array. If DEALLOC is true, also generate code to
free the array afterwards.
If INITIAL is not NULL, it is packed using internal_pack and the result used
as data instead of allocating a fresh, unitialized area of memory.
Initialization code is added to PRE and finalization code to POST.
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
static void
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
gfc_array_info * info, tree size, tree nelem,
tree initial, bool dynamic, bool dealloc)
{
tree tmp;
tree desc;
bool onstack;
desc = info->descriptor;
info->offset = gfc_index_zero_node;
if (size == NULL_TREE || integer_zerop (size))
{
/* A callee allocated array. */
gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
onstack = FALSE;
}
else
{
/* Allocate the temporary. */
onstack = !dynamic && initial == NULL_TREE
&& (flag_stack_arrays
|| gfc_can_put_var_on_stack (size));
if (onstack)
{
/* Make a temporary variable to hold the data. */
tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (nelem),
nelem, gfc_index_one_node);
tmp = gfc_evaluate_now (tmp, pre);
tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
tmp);
tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)),
tmp);
tmp = gfc_create_var (tmp, "A");
/* If we're here only because of -fstack-arrays we have to
emit a DECL_EXPR to make the gimplifier emit alloca calls. */
if (!gfc_can_put_var_on_stack (size))
gfc_add_expr_to_block (pre,
fold_build1_loc (input_location,
DECL_EXPR, TREE_TYPE (tmp),
tmp));
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
else
{
/* Allocate memory to hold the data or call internal_pack. */
if (initial == NULL_TREE)
{
tmp = gfc_call_malloc (pre, NULL, size);
tmp = gfc_evaluate_now (tmp, pre);
}
else
{
tree packed;
tree source_data;
tree was_packed;
stmtblock_t do_copying;
tmp = TREE_TYPE (initial); /* Pointer to descriptor. */
gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
tmp = TREE_TYPE (tmp); /* The descriptor itself. */
tmp = gfc_get_element_type (tmp);
packed = gfc_create_var (build_pointer_type (tmp), "data");
tmp = build_call_expr_loc (input_location,
gfor_fndecl_in_pack, 1, initial);
tmp = fold_convert (TREE_TYPE (packed), tmp);
gfc_add_modify (pre, packed, tmp);
tmp = build_fold_indirect_ref_loc (input_location,
initial);
source_data = gfc_conv_descriptor_data_get (tmp);
/* internal_pack may return source->data without any allocation
or copying if it is already packed. If that's the case, we
need to allocate and copy manually. */
gfc_start_block (&do_copying);
tmp = gfc_call_malloc (&do_copying, NULL, size);
tmp = fold_convert (TREE_TYPE (packed), tmp);
gfc_add_modify (&do_copying, packed, tmp);
tmp = gfc_build_memcpy_call (packed, source_data, size);
gfc_add_expr_to_block (&do_copying, tmp);
was_packed = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, packed,
source_data);
tmp = gfc_finish_block (&do_copying);
tmp = build3_v (COND_EXPR, was_packed, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (pre, tmp);
tmp = fold_convert (pvoid_type_node, packed);
}
gfc_conv_descriptor_data_set (pre, desc, tmp);
}
}
info->data = gfc_conv_descriptor_data_get (desc);
/* The offset is zero because we create temporaries with a zero
lower bound. */
gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
if (dealloc && !onstack)
{
/* Free the temporary. */
tmp = gfc_conv_descriptor_data_get (desc);
tmp = gfc_call_free (tmp);
gfc_add_expr_to_block (post, tmp);
}
}
/* Get the scalarizer array dimension corresponding to actual array dimension
given by ARRAY_DIM.
For example, if SS represents the array ref a(1,:,:,1), it is a
bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1,
and 1 for ARRAY_DIM=2.
If SS represents transpose(a(:,1,1,:)), it is again a bidimensional
scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for
ARRAY_DIM=3.
If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer
array. If called on the inner ss, the result would be respectively 0,1,2 for
ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1
for ARRAY_DIM=1,2. */
static int
get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim)
{
int array_ref_dim;
int n;
array_ref_dim = 0;
for (; ss; ss = ss->parent)
for (n = 0; n < ss->dimen; n++)
if (ss->dim[n] < array_dim)
array_ref_dim++;
return array_ref_dim;
}
static gfc_ss *
innermost_ss (gfc_ss *ss)
{
while (ss->nested_ss != NULL)
ss = ss->nested_ss;
return ss;
}
/* Get the array reference dimension corresponding to the given loop dimension.
It is different from the true array dimension given by the dim array in
the case of a partial array reference (i.e. a(:,:,1,:) for example)
It is different from the loop dimension in the case of a transposed array.
*/
static int
get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
{
return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
ss->dim[loop_dim]);
}
/* Use the information in the ss to obtain the required information about
the type and size of an array temporary, when the lhs in an assignment
is a class expression. */
static tree
get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
{
gfc_ss *lhs_ss;
gfc_ss *rhs_ss;
tree tmp;
tree tmp2;
tree vptr;
tree rhs_class_expr = NULL_TREE;
tree lhs_class_expr = NULL_TREE;
bool unlimited_rhs = false;
bool unlimited_lhs = false;
bool rhs_function = false;
gfc_symbol *vtab;
/* The second element in the loop chain contains the source for the
temporary; ie. the rhs of the assignment. */
rhs_ss = ss->loop->ss->loop_chain;
if (rhs_ss != gfc_ss_terminator
&& rhs_ss->info
&& rhs_ss->info->expr
&& rhs_ss->info->expr->ts.type == BT_CLASS
&& rhs_ss->info->data.array.descriptor)
{
if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
rhs_class_expr
= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
else
rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
rhs_function = true;
}
/* For an assignment the lhs is the next element in the loop chain.
If we have a class rhs, this had better be a class variable
expression! */
lhs_ss = rhs_ss->loop_chain;
if (lhs_ss != gfc_ss_terminator
&& lhs_ss->info
&& lhs_ss->info->expr
&& lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
&& lhs_ss->info->expr->ts.type == BT_CLASS)
{
tmp = lhs_ss->info->data.array.descriptor;
unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
}
else
tmp = NULL_TREE;
/* Get the lhs class expression. */
if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
lhs_class_expr = gfc_get_class_from_expr (tmp);
else
return rhs_class_expr;
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
/* Set the lhs vptr and, if necessary, the _len field. */
if (rhs_class_expr)
{
/* Both lhs and rhs are class expressions. */
tmp = gfc_class_vptr_get (lhs_class_expr);
gfc_add_modify (pre, tmp,
fold_convert (TREE_TYPE (tmp),
gfc_class_vptr_get (rhs_class_expr)));
if (unlimited_lhs)
{
tmp = gfc_class_len_get (lhs_class_expr);
if (unlimited_rhs)
tmp2 = gfc_class_len_get (rhs_class_expr);
else
tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
gfc_add_modify (pre, tmp, tmp2);
}
if (rhs_function)
{
tmp = gfc_class_data_get (rhs_class_expr);
gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
}
}
else
{
/* lhs is class and rhs is intrinsic or derived type. */
*eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
*eltype = gfc_get_element_type (*eltype);
vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
vptr = vtab->backend_decl;
if (vptr == NULL_TREE)
vptr = gfc_get_symbol_decl (vtab);
vptr = gfc_build_addr_expr (NULL_TREE, vptr);
tmp = gfc_class_vptr_get (lhs_class_expr);
gfc_add_modify (pre, tmp,
fold_convert (TREE_TYPE (tmp), vptr));
if (unlimited_lhs)
{
tmp = gfc_class_len_get (lhs_class_expr);
if (rhs_ss->info
&& rhs_ss->info->expr
&& rhs_ss->info->expr->ts.type == BT_CHARACTER)
tmp2 = build_int_cst (TREE_TYPE (tmp),
rhs_ss->info->expr->ts.kind);
else
tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
gfc_add_modify (pre, tmp, tmp2);
}
}
return rhs_class_expr;
}
/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
functions returning arrays. Adjusts the loop variables to be
zero-based, and calculates the loop bounds for callee allocated arrays.
Allocate the array unless it's callee allocated (we have a callee
allocated array if 'callee_alloc' is true, or if loop->to[n] is
NULL_TREE for any n). Also fills in the descriptor, data and offset
fields of info if known. Returns the size of the array, or NULL for a
callee allocated array.
'eltype' == NULL signals that the temporary should be a class object.
The 'initial' expression is used to obtain the size of the dynamic
type; otherwise the allocation and initialization proceeds as for any
other expression
PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for
gfc_trans_allocate_array_storage. */
tree
gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
tree eltype, tree initial, bool dynamic,
bool dealloc, bool callee_alloc, locus * where)
{
gfc_loopinfo *loop;
gfc_ss *s;
gfc_array_info *info;
tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
tree type;
tree desc;
tree tmp;
tree size;
tree nelem;
tree cond;
tree or_expr;
tree elemsize;
tree class_expr = NULL_TREE;
int n, dim, tmp_dim;
int total_dim = 0;
/* This signals a class array for which we need the size of the
dynamic type. Generate an eltype and then the class expression. */
if (eltype == NULL_TREE && initial)
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
class_expr = build_fold_indirect_ref_loc (input_location, initial);
/* Obtain the structure (class) expression. */
class_expr = gfc_get_class_from_expr (class_expr);
gcc_assert (class_expr);
}
/* Otherwise, some expressions, such as class functions, arising from
dependency checking in assignments come here with class element type.
The descriptor can be obtained from the ss->info and then converted
to the class object. */
if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
class_expr = get_class_info_from_ss (pre, ss, &eltype);
/* If the dynamic type is not available, use the declared type. */
if (eltype && GFC_CLASS_TYPE_P (eltype))
eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
if (class_expr == NULL_TREE)
elemsize = fold_convert (gfc_array_index_type,
TYPE_SIZE_UNIT (eltype));
else
{
/* Unlimited polymorphic entities are initialised with NULL vptr. They
can be tested for by checking if the len field is present. If so
test the vptr before using the vtable size. */
tmp = gfc_class_vptr_get (class_expr);
tmp = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
tmp, build_int_cst (TREE_TYPE (tmp), 0));
elemsize = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type,
tmp,
gfc_class_vtab_size_get (class_expr),
gfc_index_zero_node);
elemsize = gfc_evaluate_now (elemsize, pre);
elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
/* Casting the data as a character of the dynamic length ensures that
assignment of elements works when needed. */
eltype = gfc_get_character_type_len (1, elemsize);
}
memset (from, 0, sizeof (from));
memset (to, 0, sizeof (to));
info = &ss->info->data.array;
gcc_assert (ss->dimen > 0);
gcc_assert (ss->loop->dimen == ss->dimen);
if (warn_array_temporaries && where)
gfc_warning (OPT_Warray_temporaries,
"Creating array temporary at %L", where);
/* Set the lower bound to zero. */
for (s = ss; s; s = s->parent)
{
loop = s->loop;
total_dim += loop->dimen;
for (n = 0; n < loop->dimen; n++)
{
dim = s->dim[n];
/* Callee allocated arrays may not have a known bound yet. */
if (loop->to[n])
loop->to[n] = gfc_evaluate_now (
fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
loop->to[n], loop->from[n]),
pre);
loop->from[n] = gfc_index_zero_node;
/* We have just changed the loop bounds, we must clear the
corresponding specloop, so that delta calculation is not skipped
later in gfc_set_delta. */
loop->specloop[n] = NULL;
/* We are constructing the temporary's descriptor based on the loop
dimensions. As the dimensions may be accessed in arbitrary order
(think of transpose) the size taken from the n'th loop may not map
to the n'th dimension of the array. We need to reconstruct loop
infos in the right order before using it to set the descriptor
bounds. */
tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim);
from[tmp_dim] = loop->from[n];
to[tmp_dim] = loop->to[n];
info->delta[dim] = gfc_index_zero_node;
info->start[dim] = gfc_index_zero_node;
info->end[dim] = gfc_index_zero_node;
info->stride[dim] = gfc_index_one_node;
}
}
/* Initialize the descriptor. */
type =
gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
/* Emit a DECL_EXPR for the variable sized array type in
GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
sizes works correctly. */
tree arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (type));
if (! TYPE_NAME (arraytype))
TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
NULL_TREE, arraytype);
gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
arraytype, TYPE_NAME (arraytype)));
if (class_expr != NULL_TREE)
{
tree class_data;
tree dtype;
/* Create a class temporary. */
tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
gfc_add_modify (pre, tmp, class_expr);
/* Assign the new descriptor to the _data field. This allows the
vptr _copy to be used for scalarized assignment since the class
temporary can be found from the descriptor. */
class_data = gfc_class_data_get (tmp);
tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (desc), desc);
gfc_add_modify (pre, class_data, tmp);
/* Take the dtype from the class expression. */
dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
tmp = gfc_conv_descriptor_dtype (class_data);
gfc_add_modify (pre, tmp, dtype);
/* Point desc to the class _data field. */
desc = class_data;
}
else
{
/* Fill in the array dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
}
info->descriptor = desc;
size = gfc_index_one_node;
/*
Fill in the bounds and stride. This is a packed array, so:
size = 1;
for (n = 0; n < rank; n++)
{
stride[n] = size
delta = ubound[n] + 1 - lbound[n];
size = size * delta;
}
size = size * sizeof(element);
*/
or_expr = NULL_TREE;
/* If there is at least one null loop->to[n], it is a callee allocated
array. */
for (n = 0; n < total_dim; n++)
if (to[n] == NULL_TREE)
{
size = NULL_TREE;
break;
}
if (size == NULL_TREE)
for (s = ss; s; s = s->parent)
for (n = 0; n < s->loop->dimen; n++)
{
dim = get_scalarizer_dim_for_array_dim (ss, s->dim[n]);
/* For a callee allocated array express the loop bounds in terms
of the descriptor fields. */
tmp = fold_build2_loc (input_location,
MINUS_EXPR, gfc_array_index_type,
gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]),
gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]));
s->loop->to[n] = tmp;
}
else
{
for (n = 0; n < total_dim; n++)
{
/* Store the stride and bound components in the descriptor. */
gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
gfc_index_zero_node);
gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type,
to[n], gfc_index_one_node);
/* Check whether the size for this dimension is negative. */
cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
tmp, gfc_index_zero_node);
cond = gfc_evaluate_now (cond, pre);
if (n == 0)
or_expr = cond;
else
or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, or_expr, cond);
size = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size, tmp);
size = gfc_evaluate_now (size, pre);
}
}
/* Get the size of the array. */
if (size && !callee_alloc)
{
/* If or_expr is true, then the extent in at least one
dimension is zero and the size is set to zero. */
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
or_expr, gfc_index_zero_node, size);
nelem = size;
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, elemsize);
}
else
{
nelem = size;
size = NULL_TREE;
}
/* Set the span. */
tmp = fold_convert (gfc_array_index_type, elemsize);
gfc_conv_descriptor_span_set (pre, desc, tmp);
gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
dynamic, dealloc);
while (ss->parent)
ss = ss->parent;
if (ss->dimen > ss->loop->temp_dim)
ss->loop->temp_dim = ss->dimen;
return size;
}
/* Return the number of iterations in a loop that starts at START,
ends at END, and has step STEP. */
static tree
gfc_get_iteration_count (tree start, tree end, tree step)
{
tree tmp;
tree type;
type = TREE_TYPE (step);
tmp = fold_build2_loc (input_location, MINUS_EXPR, type, end, start);
tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, type, tmp, step);
tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp,
build_int_cst (type, 1));
tmp = fold_build2_loc (input_location, MAX_EXPR, type, tmp,
build_int_cst (type, 0));
return fold_convert (gfc_array_index_type, tmp);
}
/* Extend the data in array DESC by EXTRA elements. */
static void
gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
{
tree arg0, arg1;
tree tmp;
tree size;
tree ubound;
if (integer_zerop (extra))
return;
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
/* Add EXTRA to the upper bound. */
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
ubound, extra);
gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
/* Get the value of the current data pointer. */
arg0 = gfc_conv_descriptor_data_get (desc);
/* Calculate the new array size. */
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
ubound, gfc_index_one_node);
arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
fold_convert (size_type_node, tmp),
fold_convert (size_type_node, size));
/* Call the realloc() function. */
tmp = gfc_call_realloc (pblock, arg0, arg1);
gfc_conv_descriptor_data_set (pblock, desc, tmp);
}
/* Return true if the bounds of iterator I can only be determined
at run time. */
static inline bool
gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
{
return (i->start->expr_type != EXPR_CONSTANT
|| i->end->expr_type != EXPR_CONSTANT
|| i->step->expr_type != EXPR_CONSTANT);
}
/* Split the size of constructor element EXPR into the sum of two terms,
one of which can be determined at compile time and one of which must
be calculated at run time. Set *SIZE to the former and return true
if the latter might be nonzero. */
static bool
gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
{
if (expr->expr_type == EXPR_ARRAY)
return gfc_get_array_constructor_size (size, expr->value.constructor);
else if (expr->rank > 0)
{
/* Calculate everything at run time. */
mpz_set_ui (*size, 0);
return true;
}
else
{
/* A single element. */
mpz_set_ui (*size, 1);
return false;
}
}
/* Like gfc_get_array_constructor_element_size, but applied to the whole
of array constructor C. */
static bool
gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
{
gfc_constructor *c;
gfc_iterator *i;
mpz_t val;
mpz_t len;
bool dynamic;
mpz_set_ui (*size, 0);
mpz_init (len);
mpz_init (val);
dynamic = false;
for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
i = c->iterator;
if (i && gfc_iterator_has_dynamic_bounds (i))
dynamic = true;
else
{
dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
if (i)
{
/* Multiply the static part of the element size by the
number of iterations. */
mpz_sub (val, i->end->value.integer, i->start->value.integer);
mpz_fdiv_q (val, val, i->step->value.integer);
mpz_add_ui (val, val, 1);
if (mpz_sgn (val) > 0)
mpz_mul (len, len, val);
else
mpz_set_ui (len, 0);
}
mpz_add (*size, *size, len);
}
}
mpz_clear (len);
mpz_clear (val);
return dynamic;
}
/* Make sure offset is a variable. */
static void
gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
tree * offsetvar)
{
/* We should have already created the offset variable. We cannot
create it here because we may be in an inner scope. */
gcc_assert (*offsetvar != NULL_TREE);
gfc_add_modify (pblock, *offsetvar, *poffset);
*poffset = *offsetvar;
TREE_USED (*offsetvar) = 1;
}
/* Variables needed for bounds-checking. */
static bool first_len;
static tree first_len_val;
static bool typespec_chararray_ctor;
static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
gfc_conv_expr (se, expr);
/* Store the value. */
tmp = build_fold_indirect_ref_loc (input_location,
gfc_conv_descriptor_data_get (desc));
tmp = gfc_build_array_ref (tmp, offset, NULL);
if (expr->ts.type == BT_CHARACTER)
{
int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
tree esize;
esize = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
esize = fold_convert (gfc_charlen_type_node, esize);
esize = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
TREE_TYPE (esize), esize,
build_int_cst (TREE_TYPE (esize),
gfc_character_kinds[i].bit_size / 8));
gfc_conv_string_parameter (se);
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
{
/* The temporary is an array of pointers. */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
gfc_add_modify (&se->pre, tmp, se->expr);
}
else
{
/* The temporary is an array of string values. */
tmp = gfc_build_addr_expr (gfc_get_pchar_type (expr->ts.kind), tmp);
/* We know the temporary and the value will be the same length,
so can use memcpy. */
gfc_trans_string_copy (&se->pre, esize, tmp, expr->ts.kind,
se->string_length, se->expr, expr->ts.kind);
}
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !typespec_chararray_ctor)
{
if (first_len)
{
gfc_add_modify (&se->pre, first_len_val,
fold_convert (TREE_TYPE (first_len_val),
se->string_length));
first_len = false;
}
else
{
/* Verify that all constructor elements are of the same
length. */
tree rhs = fold_convert (TREE_TYPE (first_len_val),
se->string_length);
tree cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node, first_len_val,
rhs);
gfc_trans_runtime_check
(true, false, cond, &se->pre, &expr->where,
"Different CHARACTER lengths (%ld/%ld) in array constructor",
fold_convert (long_integer_type_node, first_len_val),
fold_convert (long_integer_type_node, se->string_length));
}
}
}
else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc))))
{
/* Assignment of a CLASS array constructor to a derived type array. */
if (expr->expr_type == EXPR_FUNCTION)
se->expr = gfc_evaluate_now (se->expr, pblock);
se->expr = gfc_class_data_get (se->expr);
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
gfc_add_modify (&se->pre, tmp, se->expr);
}
else
{
/* TODO: Should the frontend already have done this conversion? */
se->expr = fold_convert (TREE_TYPE (tmp), se->expr);
gfc_add_modify (&se->pre, tmp, se->expr);
}
gfc_add_block_to_block (pblock, &se->pre);
gfc_add_block_to_block (pblock, &se->post);
}
/* Add the contents of an array to the constructor. DYNAMIC is as for
gfc_trans_array_constructor_value. */
static void
gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
tree type ATTRIBUTE_UNUSED,
tree desc, gfc_expr * expr,
tree * poffset, tree * offsetvar,
bool dynamic)
{
gfc_se se;
gfc_ss *ss;
gfc_loopinfo loop;
stmtblock_t body;
tree tmp;
tree size;
int n;
/* We need this to be a variable so we can increment it. */
gfc_put_offset_into_var (pblock, poffset, offsetvar);
gfc_init_se (&se, NULL);
/* Walk the array expression. */
ss = gfc_walk_expr (expr);
gcc_assert (ss != gfc_ss_terminator);
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &expr->where);
/* Make sure the constructed array has room for the new data. */
if (dynamic)
{
/* Set SIZE to the total number of elements in the subarray. */
size = gfc_index_one_node;
for (n = 0; n < loop.dimen; n++)
{
tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
gfc_index_one_node);
size = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size, tmp);
}
/* Grow the constructed array by SIZE elements. */
gfc_grow_array (&loop.pre, desc, size);
}
/* Make the loop body. */
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &body);
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
gcc_assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
*poffset, gfc_index_one_node);
gfc_add_modify (&body, *poffset, tmp);
/* Finish the loop. */
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&loop.pre, &loop.post);
tmp = gfc_finish_block (&loop.pre);
gfc_add_expr_to_block (pblock, tmp);
gfc_cleanup_loop (&loop);
}
/* Assign the values to the elements of an array constructor. DYNAMIC
is true if descriptor DESC only contains enough data for the static
size calculated by gfc_get_array_constructor_size. When true, memory
for the dynamic parts must be allocated using realloc. */
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
tree desc, gfc_constructor_base base,
tree * poffset, tree * offsetvar,
bool dynamic)
{
tree tmp;
tree start = NULL_TREE;
tree end = NULL_TREE;
tree step = NULL_TREE;
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))
{
/* 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))
gfc_put_offset_into_var (pblock, poffset, offsetvar);
/* Shadowing the iterator avoids changing its value and saves us from
keeping track of it. Further, it makes sure that there's always a
backend-decl for the symbol, even if there wasn't one before,
e.g. in the case of an iterator that appears in a specification
expression in an interface mapping. */
if (c->iterator)
{
gfc_symbol *sym;
tree type;
/* Evaluate loop bounds before substituting the loop variable
in case they depend on it. Such a case is invalid, but it is
not more expensive to do the right thing here.
See PR 44354. */
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->start);
gfc_add_block_to_block (pblock, &se.pre);
start = gfc_evaluate_now (se.expr, pblock);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->end);
gfc_add_block_to_block (pblock, &se.pre);
end = gfc_evaluate_now (se.expr, pblock);
gfc_init_se (&se, NULL);
gfc_conv_expr_val (&se, c->iterator->step);
gfc_add_block_to_block (pblock, &se.pre);
step = gfc_evaluate_now (se.expr, pblock);
sym = c->iterator->var->symtree->n.sym;
type = gfc_typenode_for_spec (&sym->ts);
shadow_loopvar = gfc_create_var (type, "shadow_loopvar");
gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar);
}
gfc_start_block (&body);
if (c->expr->expr_type == EXPR_ARRAY)
{
/* Array constructors can be nested. */
gfc_trans_array_constructor_value (&body, type, desc,
c->expr->value.constructor,
poffset, offsetvar, dynamic);
}
else if (c->expr->rank > 0)
{
gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
poffset, offsetvar, dynamic);
}
else
{
/* This code really upsets the gimplifier so don't bother for now. */
gfc_constructor *p;
HOST_WIDE_INT n;
HOST_WIDE_INT size;
p = c;
n = 0;
while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
{
p = gfc_constructor_next (p);
n++;
}
if (n < 4)
{
/* Scalar values. */
gfc_init_se (&se, NULL);
gfc_trans_array_ctor_element (&body, desc, *poffset,
&se, c->expr);
*poffset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type,
*poffset, gfc_index_one_node);
}
else
{
/* Collect multiple scalar constants into a constructor. */
vec<constructor_elt, va_gc> *v = NULL;
tree init;
tree bound;
tree tmptype;
HOST_WIDE_INT idx = 0;
p = c;
/* Count the number of consecutive scalar constants. */
while (p && !(p->iterator
|| p->expr->expr_type != EXPR_CONSTANT))
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
if (c->expr->ts.type != BT_CHARACTER)
se.expr = fold_convert (type, se.expr);
/* For constant character array constructors we build
an array of pointers. */
else if (POINTER_TYPE_P (type))
se.expr = gfc_build_addr_expr
(gfc_get_pchar_type (p->expr->ts.kind),
se.expr);
CONSTRUCTOR_APPEND_ELT (v,
build_int_cst (gfc_array_index_type,
idx++),
se.expr);
c = p;
p = gfc_constructor_next (p);
}
bound = size_int (n - 1);
/* Create an array type to hold them. */
tmptype = build_range_type (gfc_array_index_type,
gfc_index_zero_node, bound);
tmptype = build_array_type (type, tmptype);
init = build_constructor (tmptype, v);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
/* Create a static variable to hold the data. */
tmp = gfc_create_var (tmptype, "data");
TREE_STATIC (tmp) = 1;
TREE_CONSTANT (tmp) = 1;
TREE_READONLY (tmp) = 1;
DECL_INITIAL (tmp) = init;
init = tmp;
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_conv_descriptor_data_get (desc);
tmp = build_fold_indirect_ref_loc (input_location,
tmp);
tmp = gfc_build_array_ref (tmp, *poffset, NULL);
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
init = gfc_build_addr_expr (NULL_TREE, init);
size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
bound = build_int_cst (size_type_node, n * size);
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMCPY),
3, tmp, init, bound);
gfc_add_expr_to_block (&body, tmp);
*poffset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, *poffset,
build_int_cst (gfc_array_index_type, n));
}
if (!INTEGER_CST_P (*poffset))
{
gfc_add_modify (&body, *offsetvar, *poffset);
*poffset = *offsetvar;
}
}
/* The frontend should already have done any expansions
at compile-time. */
if (!c->iterator)
{
/* Pass the code as is. */
tmp = gfc_finish_block (&body);
gfc_add_expr_to_block (pblock, tmp);
}
else
{
/* Build the implied do-loop. */
stmtblock_t implied_do_block;
tree cond;
tree exit_label;
tree loopbody;
tree tmp2;
loopbody = gfc_finish_block (&body);
/* Create a new block that holds the implied-do loop. A temporary
loop-variable is used. */
gfc_start_block(&implied_do_block);
/* Initialize the loop. */
gfc_add_modify (&implied_do_block, shadow_loopvar, start);
/* If this array expands dynamically, and the number of iterations
is not constant, we won't have allocated space for the static
part of C->EXPR's size. Do that now. */
if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
{
/* Get the number of iterations. */
tmp = gfc_get_iteration_count (shadow_loopvar, end, step);
/* Get the static part of C->EXPR's size. */
gfc_get_array_constructor_element_size (&size, c->expr);
tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
/* Grow the array by TMP * TMP2 elements. */
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, tmp, tmp2);
gfc_grow_array (&implied_do_block, desc, tmp);
}
/* Generate the loop body. */
exit_label = gfc_build_label_decl (NULL_TREE);
gfc_start_block (&body);
/* Generate the exit condition. Depending on the sign of
the step variable we have to generate the correct
comparison. */
tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
step, build_int_cst (TREE_TYPE (step), 0));
cond = fold_build3_loc (input_location, COND_EXPR,
logical_type_node, tmp,
fold_build2_loc (input_location, GT_EXPR,
logical_type_node, shadow_loopvar, end),
fold_build2_loc (input_location, LT_EXPR,
logical_type_node, shadow_loopvar, end));
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = build3_v (COND_EXPR, cond, tmp,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
/* The main loop body. */
gfc_add_expr_to_block (&body, loopbody);
/* Increase loop variable by step. */
tmp = fold_build2_loc (input_location, PLUS_EXPR,
TREE_TYPE (shadow_loopvar), shadow_loopvar,
step);
gfc_add_modify (&body, shadow_loopvar, tmp);
/* Finish the loop. */
tmp = gfc_finish_block (&body);
tmp = build1_v (LOOP_EXPR, tmp);
gfc_add_expr_to_block (&implied_do_block, tmp);
/* Add the exit label. */
tmp = build1_v (LABEL_EXPR, exit_label);
gfc_add_expr_to_block (&implied_do_block, tmp);
/* Finish the implied-do loop. */
tmp = gfc_finish_block(&implied_do_block);
gfc_add_expr_to_block(pblock, tmp);
gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar);
}
}
mpz_clear (size);
}
/* The array constructor code can create a string length with an operand
in the form of a temporary variable. This variable will retain its
context (current_function_decl). If we store this length tree in a
gfc_charlen structure which is shared by a variable in another
context, the resulting gfc_charlen structure with a variable in a
different context, we could trip the assertion in expand_expr_real_1
when it sees that a variable has been created in one context and
referenced in another.
If this might be the case, we create a new gfc_charlen structure and
link it into the current namespace. */
static void
store_backend_decl (gfc_charlen **clp, tree len, bool force_new_cl)
{
if (force_new_cl)
{
gfc_charlen *new_cl = gfc_new_charlen (gfc_current_ns, *clp);
*clp = new_cl;
}
(*clp)->backend_decl = len;
}
/* A catch-all to obtain the string length for anything that is not
a substring of non-constant length, a constant, array or variable. */
static void
get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
{
gfc_se se;
/* Don't bother if we already know the length is a constant. */
if (*len && INTEGER_CST_P (*len))
return;
if (!e->ref && e->ts.u.cl && e->ts.u.cl->length
&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
/* This is easy. */
gfc_conv_const_charlen (e->ts.u.cl);
*len = e->ts.u.cl->backend_decl;
}
else
{
/* Otherwise, be brutal even if inefficient. */
gfc_init_se (&se, NULL);
/* No function call, in case of side effects. */
se.no_function_call = 1;
if (e->rank == 0)
gfc_conv_expr (&se, e);
else
gfc_conv_expr_descriptor (&se, e);
/* Fix the value. */
*len = gfc_evaluate_now (se.string_length, &se.pre);
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (block, &se.post);
store_backend_decl (&e->ts.u.cl, *len, true);
}
}
/* Figure out the string length of a variable reference expression.
Used by get_array_ctor_strlen. */
static void
get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
{
gfc_ref *ref;
gfc_typespec *ts;
mpz_t char_len;
gfc_se se;
/* Don't bother if we already know the length is a constant. */
if (*len && INTEGER_CST_P (*len))
return;
ts = &expr->symtree->n.sym->ts;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
/* Array references don't change the string length. */
if (ts->deferred)
get_array_ctor_all_strlen (block, expr, len);
break;
case REF_COMPONENT:
/* Use the length of the component. */
ts = &ref->u.c.component->ts;
break;
case REF_SUBSTRING:
if (ref->u.ss.end == NULL
|| ref->u.ss.start->expr_type != EXPR_CONSTANT
|| ref->u.ss.end->expr_type != EXPR_CONSTANT)
{
/* Note that this might evaluate expr. */
get_array_ctor_all_strlen (block, expr, len);
return;
}
mpz_init_set_ui (char_len, 1);
mpz_add (char_len, char_len, ref->u.ss.end->value.integer);
mpz_sub (char_len, char_len, ref->u.ss.start->value.integer);
*len = gfc_conv_mpz_to_tree_type (char_len, gfc_charlen_type_node);
mpz_clear (char_len);
return;
case REF_INQUIRY:
break;
default:
gcc_unreachable ();
}
}
/* A last ditch attempt that is sometimes needed for deferred characters. */
if (!ts->u.cl->backend_decl)
{
gfc_init_se (&se, NULL);
if (expr->rank)
gfc_conv_expr_descriptor (&se, expr);
else
gfc_conv_expr (&se, expr);
gcc_assert (se.string_length != NULL_TREE);
gfc_add_block_to_block (block, &se.pre);
ts->u.cl->backend_decl = se.string_length;
}
*len = ts->u.cl->backend_decl;
}
/* Figure out the string length of a character array constructor.
If len is NULL, don't calculate the length; this happens for recursive calls
when a sub-array-constructor is an element but not at the first position,
so when we're not interested in the length.
Returns TRUE if all elements are character constants. */
bool
get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
{
gfc_constructor *c;
bool is_const;
is_const = TRUE;
if (gfc_constructor_first (base) == NULL)
{
if (len)
*len = build_int_cstu (gfc_charlen_type_node, 0);
return is_const;
}
/* 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))
{
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
if (len && !(*len && INTEGER_CST_P (*len)))
*len = build_int_cstu (gfc_charlen_type_node,
c->expr->value.character.length);
break;
case EXPR_ARRAY:
if (!get_array_ctor_strlen (block, c->expr->value.constructor, len))
is_const = false;
break;
case EXPR_VARIABLE:
is_const = false;
if (len)
get_array_ctor_var_strlen (block, c->expr, len);
break;
default:
is_const = false;
if (len)
get_array_ctor_all_strlen (block, c->expr, len);
break;
}
/* After the first iteration, we don't want the length modified. */
len = NULL;
}
return is_const;
}
/* Check whether the array constructor C consists entirely of constant
elements, and if so returns the number of those elements, otherwise
return zero. Note, an empty or NULL array constructor returns zero. */
unsigned HOST_WIDE_INT
gfc_constant_array_constructor_p (gfc_constructor_base base)
{
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);
nelem++;
}
return nelem;
}
/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
and the tree type of it's elements, TYPE, return a static constant
variable that is compile-time initialized. */
tree
gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
{
tree tmptype, init, tmp;
HOST_WIDE_INT nelem;
gfc_constructor *c;
gfc_array_spec as;
gfc_se se;
int i;
vec<constructor_elt, va_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);
while (c)
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, c->expr);
if (c->expr->ts.type != BT_CHARACTER)
se.expr = fold_convert (type, se.expr);
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);
nelem++;
}
/* Next determine the tree type for the array. We use the gfortran
front-end's gfc_get_nodesc_array_type in order to create a suitable
GFC_ARRAY_TYPE_P that may be used by the scalarizer. */
memset (&as, 0, sizeof (gfc_array_spec));
as.rank = expr->rank;
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);
}
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);
}
tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
/* as is not needed anymore. */
for (i = 0; i < as.rank + as.corank; i++)
{
gfc_free_expr (as.lower[i]);
gfc_free_expr (as.upper[i]);
}
init = build_constructor (tmptype, v);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
tmp = build_decl (input_location, VAR_DECL, create_tmp_var_name ("A"),
tmptype);
DECL_ARTIFICIAL (tmp) = 1;
DECL_IGNORED_P (tmp) = 1;
TREE_STATIC (tmp) = 1;
TREE_CONSTANT (tmp) = 1;
TREE_READONLY (tmp) = 1;
DECL_INITIAL (tmp) = init;
pushdecl (tmp);
return tmp;
}
/* Translate a constant EXPR_ARRAY array constructor for the scalarizer.
This mostly initializes the scalarizer state info structure with the
appropriate values to directly use the array created by the function
gfc_build_constant_array_constructor. */
static void
trans_constant_array_constructor (gfc_ss * ss, tree type)
{
gfc_array_info *info;
tree tmp;
int i;
tmp = gfc_build_constant_array_constructor (ss->info->expr, type);
info = &ss->info->data.array;
info->descriptor = tmp;
info->data = gfc_build_addr_expr (NULL_TREE, tmp);
info->offset = gfc_index_zero_node;
for (i = 0; i < ss->dimen; i++)
{
info->delta[i] = gfc_index_zero_node;
info->start[i] = gfc_index_zero_node;
info->end[i] = gfc_index_zero_node;
info->stride[i] = gfc_index_one_node;
}
}
static int
get_rank (gfc_loopinfo *loop)
{
int rank;
rank = 0;
for (; loop; loop = loop->parent)
rank += loop->dimen;
return rank;
}
/* Helper routine of gfc_trans_array_constructor to determine if the
bounds of the loop specified by LOOP are constant and simple enough
to use with trans_constant_array_constructor. Returns the
iteration count of the loop if suitable, and NULL_TREE otherwise. */
static tree
constant_array_constructor_loop_size (gfc_loopinfo * l)
{
gfc_loopinfo *loop;
tree size = gfc_index_one_node;
tree tmp;
int i, total_dim;
total_dim = get_rank (l);
for (loop = l; loop; loop = loop->parent)
{
for (i = 0; i < loop->dimen; i++)
{
/* If the bounds aren't constant, return NULL_TREE. */
if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i]))
return NULL_TREE;
if (!integer_zerop (loop->from[i]))
{
/* Only allow nonzero "from" in one-dimensional arrays. */
if (total_dim != 1)
return NULL_TREE;
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
loop->to[i], loop->from[i]);
}
else
tmp = loop->to[i];
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, tmp, gfc_index_one_node);
size = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size, tmp);
}
}
return size;
}
static tree *
get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
{
gfc_ss *ss;
int n;
gcc_assert (array->nested_ss == NULL);
for (ss = array; ss; ss = ss->parent)
for (n = 0; n < ss->loop->dimen; n++)
if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
return &(ss->loop->to[n]);
gcc_unreachable ();
}
static gfc_loopinfo *
outermost_loop (gfc_loopinfo * loop)
{
while (loop->parent != NULL)
loop = loop->parent;
return loop;
}
/* Array constructors are handled by constructing a temporary, then using that
within the scalarization loop. This is not optimal, but seems by far the
simplest method. */
static void
trans_array_constructor (gfc_ss * ss, locus * where)
{
gfc_constructor_base c;
tree offset;
tree offsetvar;
tree desc;
tree type;
tree tmp;
tree *loop_ubound0;
bool dynamic;
bool old_first_len, old_typespec_chararray_ctor;
tree old_first_len_val;
gfc_loopinfo *loop, *outer_loop;
gfc_ss_info *ss_info;
gfc_expr *expr;
gfc_ss *s;
tree neg_len;
char *msg;
/* Save the old values for nested checking. */
old_first_len = first_len;
old_first_len_val = first_len_val;
old_typespec_chararray_ctor = typespec_chararray_ctor;
loop = ss->loop;
outer_loop = outermost_loop (loop);
ss_info = ss->info;
expr = ss_info->expr;
/* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
typespec was given for the array constructor. */
typespec_chararray_ctor = (expr->ts.type == BT_CHARACTER
&& expr->ts.u.cl
&& expr->ts.u.cl->length_from_typespec);
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
{
first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
first_len = true;
}
gcc_assert (ss->dimen == ss->loop->dimen);
c = expr->value.constructor;
if (expr->ts.type == BT_CHARACTER)
{
bool const_string;
bool force_new_cl = false;
/* get_array_ctor_strlen walks the elements of the constructor, if a
typespec was given, we already know the string length and want the one
specified there. */
if (typespec_chararray_ctor && expr->ts.u.cl->length
&& expr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
{
gfc_se length_se;
const_string = false;
gfc_init_se (&length_se, NULL);
gfc_conv_expr_type (&length_se, expr->ts.u.cl->length,
gfc_charlen_type_node);
ss_info->string_length = length_se.expr;
/* Check if the character length is negative. If it is, then
set LEN = 0. */
neg_len = fold_build2_loc (input_location, LT_EXPR,
logical_type_node, ss_info->string_length,
build_zero_cst (TREE_TYPE
(ss_info->string_length)));
/* Print a warning if bounds checking is enabled. */
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
msg = xasprintf ("Negative character length treated as LEN = 0");
gfc_trans_runtime_check (false, true, neg_len, &length_se.pre,
where, msg);
free (msg);
}
ss_info->string_length
= fold_build3_loc (input_location, COND_EXPR,
gfc_charlen_type_node, neg_len,
build_zero_cst
(TREE_TYPE (ss_info->string_length)),
ss_info->string_length);
ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
&length_se.pre);
gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
gfc_add_block_to_block (&outer_loop->post, &length_se.post);
}
else
{
const_string = get_array_ctor_strlen (&outer_loop->pre, c,
&ss_info->string_length);
force_new_cl = true;
}
/* Complex character array constructors should have been taken care of
and not end up here. */
gcc_assert (ss_info->string_length);
store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
if (const_string)
type = build_pointer_type (type);
}
else
type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
? &CLASS_DATA (expr)->ts : &expr->ts);
/* See if the constructor determines the loop bounds. */
dynamic = false;
loop_ubound0 = get_loop_upper_bound_for_array (ss, 0);
if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE)
{
/* We have a multidimensional parameter. */
for (s = ss; s; s = s->parent)
{
int n;
for (n = 0; n < s->loop->dimen; n++)
{
s->loop->from[n] = gfc_index_zero_node;
s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]],
gfc_index_integer_kind);
s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
s->loop->to[n],
gfc_index_one_node);
}
}
}
if (*loop_ubound0 == NULL_TREE)
{
mpz_t size;
/* We should have a 1-dimensional, zero-based loop. */
gcc_assert (loop->parent == NULL && loop->nested == NULL);
gcc_assert (loop->dimen == 1);
gcc_assert (integer_zerop (loop->from[0]));
/* Split the constructor size into a static part and a dynamic part.
Allocate the static size up-front and record whether the dynamic
size might be nonzero. */
mpz_init (size);
dynamic = gfc_get_array_constructor_size (&size, c);
mpz_sub_ui (size, size, 1);
loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
mpz_clear (size);
}
/* Special case constant array constructors. */
if (!dynamic)
{
unsigned HOST_WIDE_INT nelem = gfc_constant_array_constructor_p (c);
if (nelem > 0)
{
tree size = constant_array_constructor_loop_size (loop);
if (size && compare_tree_int (size, nelem) == 0)
{
trans_constant_array_constructor (ss, type);
goto finish;
}
}
}
gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
NULL_TREE, dynamic, true, false, where);
desc = ss_info->data.array.descriptor;
offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
suppress_warning (offsetvar);
TREE_USED (offsetvar) = 0;
gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c,
&offset, &offsetvar, dynamic);
/* If the array grows dynamically, the upper bound of the loop variable
is determined by the array's final upper bound. */
if (dynamic)
{
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
offsetvar, gfc_index_one_node);
tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
if (*loop_ubound0 && VAR_P (*loop_ubound0))
gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
else
*loop_ubound0 = tmp;
}
if (TREE_USED (offsetvar))
pushdecl (offsetvar);
else
gcc_assert (INTEGER_CST_P (offset));
#if 0
/* Disable bound checking for now because it's probably broken. */
if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
{
gcc_unreachable ();
}
#endif
finish:
/* Restore old values of globals. */
first_len = old_first_len;
first_len_val = old_first_len_val;
typespec_chararray_ctor = old_typespec_chararray_ctor;
}
/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is
called after evaluating all of INFO's vector dimensions. Go through
each such vector dimension and see if we can now fill in any missing
loop bounds. */
static void
set_vector_loop_bounds (gfc_ss * ss)
{
gfc_loopinfo *loop, *outer_loop;
gfc_array_info *info;
gfc_se se;
tree tmp;
tree desc;
tree zero;
int n;
int dim;
outer_loop = outermost_loop (ss->loop);
info = &ss->info->data.array;
for (; ss; ss = ss->parent)
{
loop = ss->loop;
for (n = 0; n < loop->dimen; n++)
{
dim = ss->dim[n];
if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR
|| loop->to[n] != NULL)
continue;
/* Loop variable N indexes vector dimension DIM, and we don't
yet know the upper bound of loop variable N. Set it to the
difference between the vector's upper and lower bounds. */
gcc_assert (loop->from[n] == gfc_index_zero_node);
gcc_assert (info->subscript[dim]
&& info->subscript[dim]->info->type == GFC_SS_VECTOR);
gfc_init_se (&se, NULL);
desc = info->subscript[dim]->info->data.array.descriptor;
zero = gfc_rank_cst[0];
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
gfc_conv_descriptor_ubound_get (desc, zero),
gfc_conv_descriptor_lbound_get (desc, zero));
tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
loop->to[n] = tmp;
}
}
}
/* Tells whether a scalar argument to an elemental procedure is saved out
of a scalarization loop as a value or as a reference. */
bool
gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info * ss_info)
{
if (ss_info->type != GFC_SS_REFERENCE)
return false;
if (ss_info->data.scalar.needs_temporary)
return false;
/* If the actual argument can be absent (in other words, it can
be a NULL reference), don't try to evaluate it; pass instead
the reference directly. */
if (ss_info->can_be_null_ref)
return true;
/* If the expression is of polymorphic type, it's actual size is not known,
so we avoid copying it anywhere. */
if (ss_info->data.scalar.dummy_arg
&& gfc_dummy_arg_get_typespec (*ss_info->data.scalar.dummy_arg).type
== BT_CLASS
&& ss_info->expr->ts.type == BT_CLASS)
return true;
/* If the expression is a data reference of aggregate type,
and the data reference is not used on the left hand side,
avoid a copy by saving a reference to the content. */
if (!ss_info->data.scalar.needs_temporary
&& (ss_info->expr->ts.type == BT_DERIVED
|| ss_info->expr->ts.type == BT_CLASS)
&& gfc_expr_is_variable (ss_info->expr))
return true;
/* Otherwise the expression is evaluated to a temporary variable before the
scalarization loop. */
return false;
}
/* Add the pre and post chains for all the scalar expressions in a SS chain
to loop. This is called after the loop parameters have been calculated,
but before the actual scalarizing loops. */
static void
gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
locus * where)
{
gfc_loopinfo *nested_loop, *outer_loop;
gfc_se se;
gfc_ss_info *ss_info;
gfc_array_info *info;
gfc_expr *expr;
int n;
/* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise,
arguments could get evaluated multiple times. */
if (ss->is_alloc_lhs)
return;
outer_loop = outermost_loop (loop);
/* TODO: This can generate bad code if there are ordering dependencies,
e.g., a callee allocated function and an unknown size constructor. */
gcc_assert (ss != NULL);
for (; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
gcc_assert (ss);
/* Cross loop arrays are handled from within the most nested loop. */
if (ss->nested_ss != NULL)
continue;
ss_info = ss->info;
expr = ss_info->expr;
info = &ss_info->data.array;
switch (ss_info->type)
{
case GFC_SS_SCALAR:
/* Scalar expression. Evaluate this now. This includes elemental
dimension indices, but not array section bounds. */
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
if (expr->ts.type != BT_CHARACTER
&& !gfc_is_alloc_class_scalar_function (expr))
{
/* Move the evaluation of scalar expressions outside the
scalarization loop, except for WHERE assignments. */
if (subscript)
se.expr = convert(gfc_array_index_type, se.expr);
if (!ss_info->where)
se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre);
gfc_add_block_to_block (&outer_loop->pre, &se.post);
}
else
gfc_add_block_to_block (&outer_loop->post, &se.post);
ss_info->data.scalar.value = se.expr;
ss_info->string_length = se.string_length;
break;
case GFC_SS_REFERENCE:
/* Scalar argument to elemental procedure. */
gfc_init_se (&se, NULL);
if (gfc_scalar_elemental_arg_saved_as_reference (ss_info))
gfc_conv_expr_reference (&se, expr);
else
{
/* Evaluate the argument outside the loop and pass
a reference to the value. */
gfc_conv_expr (&se, expr);
}
/* Ensure that a pointer to the string is stored. */
if (expr->ts.type == BT_CHARACTER)
gfc_conv_string_parameter (&se);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
if (gfc_is_class_scalar_expr (expr))
/* This is necessary because the dynamic type will always be
large than the declared type. In consequence, assigning
the value to a temporary could segfault.
OOP-TODO: see if this is generally correct or is the value
has to be written to an allocated temporary, whose address
is passed via ss_info. */
ss_info->data.scalar.value = se.expr;
else
ss_info->data.scalar.value = gfc_evaluate_now (se.expr,
&outer_loop->pre);
ss_info->string_length = se.string_length;
break;
case GFC_SS_SECTION:
/* Add the expressions for scalar and vector subscripts. */
for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
if (info->subscript[n])
gfc_add_loop_ss_code (loop, info->subscript[n], true, where);
set_vector_loop_bounds (ss);
break;
case GFC_SS_VECTOR:
/* Get the vector's descriptor and store it in SS. */
gfc_init_se (&se, NULL);
gfc_conv_expr_descriptor (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
info->descriptor = se.expr;
break;
case GFC_SS_INTRINSIC:
gfc_add_intrinsic_ss_code (loop, ss);
break;
case GFC_SS_FUNCTION:
/* Array function return value. We call the function and save its
result in a temporary for use inside the loop. */
gfc_init_se (&se, NULL);
se.loop = loop;
se.ss = ss;
if (gfc_is_class_array_function (expr))
expr->must_finalize = 1;
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
ss_info->string_length = se.string_length;
break;
case GFC_SS_CONSTRUCTOR:
if (expr->ts.type == BT_CHARACTER
&& ss_info->string_length == NULL
&& expr->ts.u.cl
&& expr->ts.u.cl->length
&& expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, expr->ts.u.cl->length,
gfc_charlen_type_node);
ss_info->string_length = se.expr;
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
}
trans_array_constructor (ss, where);
break;
case GFC_SS_TEMP:
case GFC_SS_COMPONENT:
/* Do nothing. These are handled elsewhere. */
break;
default:
gcc_unreachable ();
}
}
if (!subscript)
for (nested_loop = loop->nested; nested_loop;
nested_loop = nested_loop->next)
gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
}
/* Translate expressions for the descriptor and data pointer of a SS. */
/*GCC ARRAYS*/
static void
gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
{
gfc_se se;