re PR fortran/21104 (Segmentation fault on correct code)
PR fortran/21104 * trans.h (gfc_interface_sym_mapping, gfc_interface_mapping): Moved from trans-expr.c. (gfc_init_interface_mapping, gfc_free_interface_mapping) (gfc_add_interface_mapping, gfc_finish_interface_mapping) (gfc_apply_interface_mapping): Declare. * trans-array.h (gfc_set_loop_bounds_from_array_spec): Declare. (gfc_trans_allocate_temp_array): Add pre and post block arguments. * trans-array.c (gfc_set_loop_bounds_from_array_spec): New function. (gfc_trans_allocate_array_storage): Replace loop argument with separate pre and post blocks. (gfc_trans_allocate_temp_array): Add pre and post block arguments. Update call to gfc_trans_allocate_array_storage. (gfc_trans_array_constructor, gfc_conv_loop_setup): Adjust for new interface to gfc_trans_allocate_temp_array. * trans-expr.c (gfc_interface_sym_mapping, gfc_interface_mapping): Moved to trans.h. (gfc_init_interface_mapping, gfc_free_interface_mapping) (gfc_add_interface_mapping, gfc_finish_interface_mapping) (gfc_apply_interface_mapping): Make extern. (gfc_conv_function_call): Build an interface mapping for array return values too. Call gfc_set_loop_bounds_from_array_spec. Adjust call to gfc_trans_allocate_temp_array so that code is added to SE rather than LOOP. From-SVN: r104075
This commit is contained in:
parent
ec25720ba3
commit
62ab4a5499
|
@ -1,3 +1,30 @@
|
||||||
|
2005-09-09 Richard Sandiford <richard@codesourcery.com>
|
||||||
|
|
||||||
|
PR fortran/21104
|
||||||
|
* trans.h (gfc_interface_sym_mapping, gfc_interface_mapping): Moved
|
||||||
|
from trans-expr.c.
|
||||||
|
(gfc_init_interface_mapping, gfc_free_interface_mapping)
|
||||||
|
(gfc_add_interface_mapping, gfc_finish_interface_mapping)
|
||||||
|
(gfc_apply_interface_mapping): Declare.
|
||||||
|
* trans-array.h (gfc_set_loop_bounds_from_array_spec): Declare.
|
||||||
|
(gfc_trans_allocate_temp_array): Add pre and post block arguments.
|
||||||
|
* trans-array.c (gfc_set_loop_bounds_from_array_spec): New function.
|
||||||
|
(gfc_trans_allocate_array_storage): Replace loop argument with
|
||||||
|
separate pre and post blocks.
|
||||||
|
(gfc_trans_allocate_temp_array): Add pre and post block arguments.
|
||||||
|
Update call to gfc_trans_allocate_array_storage.
|
||||||
|
(gfc_trans_array_constructor, gfc_conv_loop_setup): Adjust for new
|
||||||
|
interface to gfc_trans_allocate_temp_array.
|
||||||
|
* trans-expr.c (gfc_interface_sym_mapping, gfc_interface_mapping):
|
||||||
|
Moved to trans.h.
|
||||||
|
(gfc_init_interface_mapping, gfc_free_interface_mapping)
|
||||||
|
(gfc_add_interface_mapping, gfc_finish_interface_mapping)
|
||||||
|
(gfc_apply_interface_mapping): Make extern.
|
||||||
|
(gfc_conv_function_call): Build an interface mapping for array
|
||||||
|
return values too. Call gfc_set_loop_bounds_from_array_spec.
|
||||||
|
Adjust call to gfc_trans_allocate_temp_array so that code is
|
||||||
|
added to SE rather than LOOP.
|
||||||
|
|
||||||
2005-09-09 Richard Sandiford <richard@codesourcery.com>
|
2005-09-09 Richard Sandiford <richard@codesourcery.com>
|
||||||
|
|
||||||
PR fortran/12840
|
PR fortran/12840
|
||||||
|
|
|
@ -433,17 +433,64 @@ gfc_trans_static_array_pointer (gfc_symbol * sym)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* 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;
|
||||||
|
gfc_se tmpse;
|
||||||
|
tree lower;
|
||||||
|
tree upper;
|
||||||
|
tree tmp;
|
||||||
|
|
||||||
|
if (as && as->type == AS_EXPLICIT)
|
||||||
|
for (dim = 0; dim < se->loop->dimen; dim++)
|
||||||
|
{
|
||||||
|
n = se->loop->order[dim];
|
||||||
|
if (se->loop->to[n] == NULL_TREE)
|
||||||
|
{
|
||||||
|
/* 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 = 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 = tmpse.expr;
|
||||||
|
|
||||||
|
/* Set the upper bound of the loop to UPPER - LOWER. */
|
||||||
|
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
|
||||||
|
tmp = gfc_evaluate_now (tmp, &se->pre);
|
||||||
|
se->loop->to[n] = tmp;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
/* Generate code to allocate an array temporary, or create a variable to
|
/* Generate code to allocate an array temporary, or create a variable to
|
||||||
hold the data. If size is NULL zero the descriptor so that so that the
|
hold the data. If size is NULL zero the descriptor so that so that the
|
||||||
callee will allocate the array. Also generates code to free the array
|
callee will allocate the array. Also generates code to free the array
|
||||||
afterwards.
|
afterwards.
|
||||||
|
|
||||||
|
Initialization code is added to PRE and finalization code to POST.
|
||||||
DYNAMIC is true if the caller may want to extend the array later
|
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. */
|
using realloc. This prevents us from putting the array on the stack. */
|
||||||
|
|
||||||
static void
|
static void
|
||||||
gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
|
||||||
tree size, tree nelem, bool dynamic)
|
gfc_ss_info * info, tree size, tree nelem,
|
||||||
|
bool dynamic)
|
||||||
{
|
{
|
||||||
tree tmp;
|
tree tmp;
|
||||||
tree args;
|
tree args;
|
||||||
|
@ -455,7 +502,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
if (size == NULL_TREE || integer_zerop (size))
|
if (size == NULL_TREE || integer_zerop (size))
|
||||||
{
|
{
|
||||||
/* A callee allocated array. */
|
/* A callee allocated array. */
|
||||||
gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
|
gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
|
||||||
onstack = FALSE;
|
onstack = FALSE;
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
|
@ -474,7 +521,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
tmp);
|
tmp);
|
||||||
tmp = gfc_create_var (tmp, "A");
|
tmp = gfc_create_var (tmp, "A");
|
||||||
tmp = gfc_build_addr_expr (NULL, tmp);
|
tmp = gfc_build_addr_expr (NULL, tmp);
|
||||||
gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
|
gfc_conv_descriptor_data_set (pre, desc, tmp);
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
|
@ -488,8 +535,8 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
else
|
else
|
||||||
gcc_unreachable ();
|
gcc_unreachable ();
|
||||||
tmp = gfc_build_function_call (tmp, args);
|
tmp = gfc_build_function_call (tmp, args);
|
||||||
tmp = gfc_evaluate_now (tmp, &loop->pre);
|
tmp = gfc_evaluate_now (tmp, pre);
|
||||||
gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
|
gfc_conv_descriptor_data_set (pre, desc, tmp);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
info->data = gfc_conv_descriptor_data_get (desc);
|
info->data = gfc_conv_descriptor_data_get (desc);
|
||||||
|
@ -497,7 +544,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
/* The offset is zero because we create temporaries with a zero
|
/* The offset is zero because we create temporaries with a zero
|
||||||
lower bound. */
|
lower bound. */
|
||||||
tmp = gfc_conv_descriptor_offset (desc);
|
tmp = gfc_conv_descriptor_offset (desc);
|
||||||
gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
|
gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
|
||||||
|
|
||||||
if (!onstack)
|
if (!onstack)
|
||||||
{
|
{
|
||||||
|
@ -506,7 +553,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
tmp = fold_convert (pvoid_type_node, tmp);
|
tmp = fold_convert (pvoid_type_node, tmp);
|
||||||
tmp = gfc_chainon_list (NULL_TREE, tmp);
|
tmp = gfc_chainon_list (NULL_TREE, tmp);
|
||||||
tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
|
tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
|
||||||
gfc_add_expr_to_block (&loop->post, tmp);
|
gfc_add_expr_to_block (post, tmp);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -518,10 +565,11 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
Also fills in the descriptor, data and offset fields of info if known.
|
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.
|
Returns the size of the array, or NULL for a callee allocated array.
|
||||||
|
|
||||||
DYNAMIC is as for gfc_trans_allocate_array_storage. */
|
PRE, POST and DYNAMIC are as for gfc_trans_allocate_array_storage. */
|
||||||
|
|
||||||
tree
|
tree
|
||||||
gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
|
gfc_trans_allocate_temp_array (stmtblock_t * pre, stmtblock_t * post,
|
||||||
|
gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
tree eltype, bool dynamic)
|
tree eltype, bool dynamic)
|
||||||
{
|
{
|
||||||
tree type;
|
tree type;
|
||||||
|
@ -565,7 +613,7 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
|
|
||||||
/* Fill in the array dtype. */
|
/* Fill in the array dtype. */
|
||||||
tmp = gfc_conv_descriptor_dtype (desc);
|
tmp = gfc_conv_descriptor_dtype (desc);
|
||||||
gfc_add_modify_expr (&loop->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
|
gfc_add_modify_expr (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
|
||||||
|
|
||||||
/*
|
/*
|
||||||
Fill in the bounds and stride. This is a packed array, so:
|
Fill in the bounds and stride. This is a packed array, so:
|
||||||
|
@ -596,19 +644,19 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
|
|
||||||
/* Store the stride and bound components in the descriptor. */
|
/* Store the stride and bound components in the descriptor. */
|
||||||
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
|
tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
|
||||||
gfc_add_modify_expr (&loop->pre, tmp, size);
|
gfc_add_modify_expr (pre, tmp, size);
|
||||||
|
|
||||||
tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
|
tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]);
|
||||||
gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node);
|
gfc_add_modify_expr (pre, tmp, gfc_index_zero_node);
|
||||||
|
|
||||||
tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
|
tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]);
|
||||||
gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]);
|
gfc_add_modify_expr (pre, tmp, loop->to[n]);
|
||||||
|
|
||||||
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
|
||||||
loop->to[n], gfc_index_one_node);
|
loop->to[n], gfc_index_one_node);
|
||||||
|
|
||||||
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
|
||||||
size = gfc_evaluate_now (size, &loop->pre);
|
size = gfc_evaluate_now (size, pre);
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Get the size of the array. */
|
/* Get the size of the array. */
|
||||||
|
@ -617,7 +665,7 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||||
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
||||||
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
|
||||||
|
|
||||||
gfc_trans_allocate_array_storage (loop, info, size, nelem, dynamic);
|
gfc_trans_allocate_array_storage (pre, post, info, size, nelem, dynamic);
|
||||||
|
|
||||||
if (info->dimen > loop->temp_dim)
|
if (info->dimen > loop->temp_dim)
|
||||||
loop->temp_dim = info->dimen;
|
loop->temp_dim = info->dimen;
|
||||||
|
@ -1278,7 +1326,8 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
|
||||||
mpz_clear (size);
|
mpz_clear (size);
|
||||||
}
|
}
|
||||||
|
|
||||||
gfc_trans_allocate_temp_array (loop, &ss->data.info, type, dynamic);
|
gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
|
||||||
|
&ss->data.info, type, dynamic);
|
||||||
|
|
||||||
desc = ss->data.info.descriptor;
|
desc = ss->data.info.descriptor;
|
||||||
offset = gfc_index_zero_node;
|
offset = gfc_index_zero_node;
|
||||||
|
@ -2727,8 +2776,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
|
||||||
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
|
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
|
||||||
loop->temp_ss->type = GFC_SS_SECTION;
|
loop->temp_ss->type = GFC_SS_SECTION;
|
||||||
loop->temp_ss->data.info.dimen = n;
|
loop->temp_ss->data.info.dimen = n;
|
||||||
gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info,
|
gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
|
||||||
tmp, false);
|
&loop->temp_ss->data.info, tmp, false);
|
||||||
}
|
}
|
||||||
|
|
||||||
for (n = 0; n < loop->temp_dim; n++)
|
for (n = 0; n < loop->temp_dim; n++)
|
||||||
|
|
|
@ -26,8 +26,13 @@ tree gfc_array_deallocate (tree, tree);
|
||||||
se, which should contain an expression for the array descriptor. */
|
se, which should contain an expression for the array descriptor. */
|
||||||
void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
|
void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
|
||||||
|
|
||||||
|
/* Allow the bounds of a loop to be set from a callee's array spec. */
|
||||||
|
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
|
||||||
|
gfc_se *, gfc_array_spec *);
|
||||||
|
|
||||||
/* Generate code to allocate a temporary array. */
|
/* Generate code to allocate a temporary array. */
|
||||||
tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree, bool);
|
tree gfc_trans_allocate_temp_array (stmtblock_t *, stmtblock_t *,
|
||||||
|
gfc_loopinfo *, gfc_ss_info *, tree, bool);
|
||||||
|
|
||||||
/* Generate function entry code for allocation of compiler allocated array
|
/* Generate function entry code for allocation of compiler allocated array
|
||||||
variables. */
|
variables. */
|
||||||
|
|
|
@ -41,6 +41,8 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
|
||||||
#include "trans-stmt.h"
|
#include "trans-stmt.h"
|
||||||
|
|
||||||
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
|
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
|
||||||
|
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
|
||||||
|
gfc_expr *);
|
||||||
|
|
||||||
/* Copy the scalarization loop variables. */
|
/* Copy the scalarization loop variables. */
|
||||||
|
|
||||||
|
@ -1075,73 +1077,9 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
/* This group of functions allows a caller to evaluate an expression from
|
|
||||||
the callee's interface. It establishes a mapping between the interface's
|
|
||||||
dummy arguments and the caller's actual arguments, then applies that
|
|
||||||
mapping to a given gfc_expr.
|
|
||||||
|
|
||||||
You can initialize a mapping structure like so:
|
|
||||||
|
|
||||||
gfc_interface_mapping mapping;
|
|
||||||
...
|
|
||||||
gfc_init_interface_mapping (&mapping);
|
|
||||||
|
|
||||||
You should then evaluate each actual argument into a temporary
|
|
||||||
gfc_se structure, here called "se", and map the result to the
|
|
||||||
dummy argument's symbol, here called "sym":
|
|
||||||
|
|
||||||
gfc_add_interface_mapping (&mapping, sym, &se);
|
|
||||||
|
|
||||||
After adding all mappings, you should call:
|
|
||||||
|
|
||||||
gfc_finish_interface_mapping (&mapping, pre, post);
|
|
||||||
|
|
||||||
where "pre" and "post" are statement blocks for initialization
|
|
||||||
and finalization code respectively. You can then evaluate an
|
|
||||||
interface expression "expr" as follows:
|
|
||||||
|
|
||||||
gfc_apply_interface_mapping (&mapping, se, expr);
|
|
||||||
|
|
||||||
Once you've evaluated all expressions, you should free
|
|
||||||
the mapping structure with:
|
|
||||||
|
|
||||||
gfc_free_interface_mapping (&mapping); */
|
|
||||||
|
|
||||||
|
|
||||||
/* This structure represents a mapping from OLD to NEW, where OLD is a
|
|
||||||
dummy argument symbol and NEW is a symbol that represents the value
|
|
||||||
of an actual argument. Mappings are linked together using NEXT
|
|
||||||
(in no particular order). */
|
|
||||||
typedef struct gfc_interface_sym_mapping
|
|
||||||
{
|
|
||||||
struct gfc_interface_sym_mapping *next;
|
|
||||||
gfc_symbol *old;
|
|
||||||
gfc_symtree *new;
|
|
||||||
}
|
|
||||||
gfc_interface_sym_mapping;
|
|
||||||
|
|
||||||
|
|
||||||
/* This structure is used by callers to evaluate an expression from
|
|
||||||
a callee's interface. */
|
|
||||||
typedef struct gfc_interface_mapping
|
|
||||||
{
|
|
||||||
/* Maps the interface's dummy arguments to the values that the caller
|
|
||||||
is passing. The whole list is owned by this gfc_interface_mapping. */
|
|
||||||
gfc_interface_sym_mapping *syms;
|
|
||||||
|
|
||||||
/* A list of gfc_charlens that were needed when creating copies of
|
|
||||||
expressions. The whole list is owned by this gfc_interface_mapping. */
|
|
||||||
gfc_charlen *charlens;
|
|
||||||
}
|
|
||||||
gfc_interface_mapping;
|
|
||||||
|
|
||||||
|
|
||||||
static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
|
|
||||||
gfc_expr *);
|
|
||||||
|
|
||||||
/* Initialize MAPPING. */
|
/* Initialize MAPPING. */
|
||||||
|
|
||||||
static void
|
void
|
||||||
gfc_init_interface_mapping (gfc_interface_mapping * mapping)
|
gfc_init_interface_mapping (gfc_interface_mapping * mapping)
|
||||||
{
|
{
|
||||||
mapping->syms = NULL;
|
mapping->syms = NULL;
|
||||||
|
@ -1151,7 +1089,7 @@ gfc_init_interface_mapping (gfc_interface_mapping * mapping)
|
||||||
|
|
||||||
/* Free all memory held by MAPPING (but not MAPPING itself). */
|
/* Free all memory held by MAPPING (but not MAPPING itself). */
|
||||||
|
|
||||||
static void
|
void
|
||||||
gfc_free_interface_mapping (gfc_interface_mapping * mapping)
|
gfc_free_interface_mapping (gfc_interface_mapping * mapping)
|
||||||
{
|
{
|
||||||
gfc_interface_sym_mapping *sym;
|
gfc_interface_sym_mapping *sym;
|
||||||
|
@ -1258,7 +1196,7 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
|
||||||
in SE. The caller may still use se->expr and se->string_length after
|
in SE. The caller may still use se->expr and se->string_length after
|
||||||
calling this function. */
|
calling this function. */
|
||||||
|
|
||||||
static void
|
void
|
||||||
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
|
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
|
||||||
gfc_symbol * sym, gfc_se * se)
|
gfc_symbol * sym, gfc_se * se)
|
||||||
{
|
{
|
||||||
|
@ -1359,7 +1297,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
|
||||||
the length of each argument, adding any initialization code to PRE and
|
the length of each argument, adding any initialization code to PRE and
|
||||||
any finalization code to POST. */
|
any finalization code to POST. */
|
||||||
|
|
||||||
static void
|
void
|
||||||
gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
|
gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
|
||||||
stmtblock_t * pre, stmtblock_t * post)
|
stmtblock_t * pre, stmtblock_t * post)
|
||||||
{
|
{
|
||||||
|
@ -1503,7 +1441,7 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
|
||||||
/* Evaluate interface expression EXPR using MAPPING. Store the result
|
/* Evaluate interface expression EXPR using MAPPING. Store the result
|
||||||
in SE. */
|
in SE. */
|
||||||
|
|
||||||
static void
|
void
|
||||||
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
|
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
|
||||||
gfc_se * se, gfc_expr * expr)
|
gfc_se * se, gfc_expr * expr)
|
||||||
{
|
{
|
||||||
|
@ -1571,8 +1509,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
info = NULL;
|
info = NULL;
|
||||||
|
|
||||||
gfc_init_interface_mapping (&mapping);
|
gfc_init_interface_mapping (&mapping);
|
||||||
need_interface_mapping = (sym->ts.type == BT_CHARACTER
|
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
|
||||||
&& sym->ts.cl->length->expr_type != EXPR_CONSTANT);
|
&& sym->ts.cl->length->expr_type != EXPR_CONSTANT)
|
||||||
|
|| sym->attr.dimension);
|
||||||
formal = sym->formal;
|
formal = sym->formal;
|
||||||
/* Evaluate the arguments. */
|
/* Evaluate the arguments. */
|
||||||
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
|
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
|
||||||
|
@ -1678,7 +1617,6 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
|
|
||||||
len = cl.backend_decl;
|
len = cl.backend_decl;
|
||||||
}
|
}
|
||||||
gfc_free_interface_mapping (&mapping);
|
|
||||||
|
|
||||||
byref = gfc_return_by_reference (sym);
|
byref = gfc_return_by_reference (sym);
|
||||||
if (byref)
|
if (byref)
|
||||||
|
@ -1693,8 +1631,12 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
tmp = gfc_typenode_for_spec (&ts);
|
tmp = gfc_typenode_for_spec (&ts);
|
||||||
info->dimen = se->loop->dimen;
|
info->dimen = se->loop->dimen;
|
||||||
|
|
||||||
|
/* Evaluate the bounds of the result, if known. */
|
||||||
|
gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
|
||||||
|
|
||||||
/* Allocate a temporary to store the result. */
|
/* Allocate a temporary to store the result. */
|
||||||
gfc_trans_allocate_temp_array (se->loop, info, tmp, false);
|
gfc_trans_allocate_temp_array (&se->pre, &se->post,
|
||||||
|
se->loop, info, tmp, false);
|
||||||
|
|
||||||
/* Zero the first stride to indicate a temporary. */
|
/* Zero the first stride to indicate a temporary. */
|
||||||
tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
|
tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
|
||||||
|
@ -1745,6 +1687,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
if (ts.type == BT_CHARACTER)
|
if (ts.type == BT_CHARACTER)
|
||||||
retargs = gfc_chainon_list (retargs, len);
|
retargs = gfc_chainon_list (retargs, len);
|
||||||
}
|
}
|
||||||
|
gfc_free_interface_mapping (&mapping);
|
||||||
|
|
||||||
/* Add the return arguments. */
|
/* Add the return arguments. */
|
||||||
arglist = chainon (retargs, arglist);
|
arglist = chainon (retargs, arglist);
|
||||||
|
|
|
@ -572,4 +572,74 @@ struct lang_decl GTY(())
|
||||||
arg1, arg2)
|
arg1, arg2)
|
||||||
#define build3_v(code, arg1, arg2, arg3) build3(code, void_type_node, \
|
#define build3_v(code, arg1, arg2, arg3) build3(code, void_type_node, \
|
||||||
arg1, arg2, arg3)
|
arg1, arg2, arg3)
|
||||||
|
|
||||||
|
/* This group of functions allows a caller to evaluate an expression from
|
||||||
|
the callee's interface. It establishes a mapping between the interface's
|
||||||
|
dummy arguments and the caller's actual arguments, then applies that
|
||||||
|
mapping to a given gfc_expr.
|
||||||
|
|
||||||
|
You can initialize a mapping structure like so:
|
||||||
|
|
||||||
|
gfc_interface_mapping mapping;
|
||||||
|
...
|
||||||
|
gfc_init_interface_mapping (&mapping);
|
||||||
|
|
||||||
|
You should then evaluate each actual argument into a temporary
|
||||||
|
gfc_se structure, here called "se", and map the result to the
|
||||||
|
dummy argument's symbol, here called "sym":
|
||||||
|
|
||||||
|
gfc_add_interface_mapping (&mapping, sym, &se);
|
||||||
|
|
||||||
|
After adding all mappings, you should call:
|
||||||
|
|
||||||
|
gfc_finish_interface_mapping (&mapping, pre, post);
|
||||||
|
|
||||||
|
where "pre" and "post" are statement blocks for initialization
|
||||||
|
and finalization code respectively. You can then evaluate an
|
||||||
|
interface expression "expr" as follows:
|
||||||
|
|
||||||
|
gfc_apply_interface_mapping (&mapping, se, expr);
|
||||||
|
|
||||||
|
Once you've evaluated all expressions, you should free
|
||||||
|
the mapping structure with:
|
||||||
|
|
||||||
|
gfc_free_interface_mapping (&mapping); */
|
||||||
|
|
||||||
|
|
||||||
|
/* This structure represents a mapping from OLD to NEW, where OLD is a
|
||||||
|
dummy argument symbol and NEW is a symbol that represents the value
|
||||||
|
of an actual argument. Mappings are linked together using NEXT
|
||||||
|
(in no particular order). */
|
||||||
|
typedef struct gfc_interface_sym_mapping
|
||||||
|
{
|
||||||
|
struct gfc_interface_sym_mapping *next;
|
||||||
|
gfc_symbol *old;
|
||||||
|
gfc_symtree *new;
|
||||||
|
}
|
||||||
|
gfc_interface_sym_mapping;
|
||||||
|
|
||||||
|
|
||||||
|
/* This structure is used by callers to evaluate an expression from
|
||||||
|
a callee's interface. */
|
||||||
|
typedef struct gfc_interface_mapping
|
||||||
|
{
|
||||||
|
/* Maps the interface's dummy arguments to the values that the caller
|
||||||
|
is passing. The whole list is owned by this gfc_interface_mapping. */
|
||||||
|
gfc_interface_sym_mapping *syms;
|
||||||
|
|
||||||
|
/* A list of gfc_charlens that were needed when creating copies of
|
||||||
|
expressions. The whole list is owned by this gfc_interface_mapping. */
|
||||||
|
gfc_charlen *charlens;
|
||||||
|
}
|
||||||
|
gfc_interface_mapping;
|
||||||
|
|
||||||
|
void gfc_init_interface_mapping (gfc_interface_mapping *);
|
||||||
|
void gfc_free_interface_mapping (gfc_interface_mapping *);
|
||||||
|
void gfc_add_interface_mapping (gfc_interface_mapping *,
|
||||||
|
gfc_symbol *, gfc_se *);
|
||||||
|
void gfc_finish_interface_mapping (gfc_interface_mapping *,
|
||||||
|
stmtblock_t *, stmtblock_t *);
|
||||||
|
void gfc_apply_interface_mapping (gfc_interface_mapping *,
|
||||||
|
gfc_se *, gfc_expr *);
|
||||||
|
|
||||||
#endif /* GFC_TRANS_H */
|
#endif /* GFC_TRANS_H */
|
||||||
|
|
|
@ -1,3 +1,10 @@
|
||||||
|
2005-09-09 Richard Sandiford <richard@codesourcery.com>
|
||||||
|
|
||||||
|
PR fortran/21104
|
||||||
|
* gfortran.dg/array_alloc_1.f90,
|
||||||
|
* gfortran.dg/array_alloc_2.f90,
|
||||||
|
* gfortran.dg/array_alloc_3.f90: New tests.
|
||||||
|
|
||||||
2005-09-09 Richard Sandiford <richard@codesourcery.com>
|
2005-09-09 Richard Sandiford <richard@codesourcery.com>
|
||||||
|
|
||||||
PR fortran/12840
|
PR fortran/12840
|
||||||
|
|
|
@ -0,0 +1,21 @@
|
||||||
|
! PR 21104. Make sure that either f() or its caller will allocate
|
||||||
|
! the array data. We've decided to make the caller allocate it.
|
||||||
|
! { dg-do run }
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
call test (f ())
|
||||||
|
contains
|
||||||
|
subroutine test (x)
|
||||||
|
integer, dimension (10) :: x
|
||||||
|
integer :: i
|
||||||
|
do i = 1, 10
|
||||||
|
if (x (i) .ne. i * 100) call abort
|
||||||
|
end do
|
||||||
|
end subroutine test
|
||||||
|
|
||||||
|
function f
|
||||||
|
integer, dimension (10) :: f
|
||||||
|
integer :: i
|
||||||
|
forall (i = 1:10) f (i) = i * 100
|
||||||
|
end function f
|
||||||
|
end program main
|
|
@ -0,0 +1,38 @@
|
||||||
|
! Like array_alloc_1.f90, but check cases in which the array length is
|
||||||
|
! not a literal constant.
|
||||||
|
! { dg-do run }
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
integer, parameter :: n = 100
|
||||||
|
call test (n, f1 ())
|
||||||
|
call test (47, f2 (50))
|
||||||
|
call test (n, f3 (f1 ()))
|
||||||
|
contains
|
||||||
|
subroutine test (expected, x)
|
||||||
|
integer, dimension (:) :: x
|
||||||
|
integer :: i, expected
|
||||||
|
if (size (x, 1) .ne. expected) call abort
|
||||||
|
do i = 1, expected
|
||||||
|
if (x (i) .ne. i * 100) call abort
|
||||||
|
end do
|
||||||
|
end subroutine test
|
||||||
|
|
||||||
|
function f1
|
||||||
|
integer, dimension (n) :: f1
|
||||||
|
integer :: i
|
||||||
|
forall (i = 1:n) f1 (i) = i * 100
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (howmuch)
|
||||||
|
integer :: i, howmuch
|
||||||
|
integer, dimension (4:howmuch) :: f2
|
||||||
|
forall (i = 4:howmuch) f2 (i) = i * 100 - 300
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
function f3 (x)
|
||||||
|
integer, dimension (:) :: x
|
||||||
|
integer, dimension (size (x, 1)) :: f3
|
||||||
|
integer :: i
|
||||||
|
forall (i = 1:size(x)) f3 (i) = i * 100
|
||||||
|
end function f3
|
||||||
|
end program main
|
|
@ -0,0 +1,35 @@
|
||||||
|
! Like array_alloc_1.f90, but check multi-dimensional arrays.
|
||||||
|
! { dg-do run }
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
call test ((/ 3, 4, 5 /), f ((/ 3, 4, 5 /)))
|
||||||
|
contains
|
||||||
|
subroutine test (expected, x)
|
||||||
|
integer, dimension (:,:,:) :: x
|
||||||
|
integer, dimension (3) :: expected
|
||||||
|
integer :: i, i1, i2, i3
|
||||||
|
do i = 1, 3
|
||||||
|
if (size (x, i) .ne. expected (i)) call abort
|
||||||
|
end do
|
||||||
|
do i1 = 1, expected (1)
|
||||||
|
do i2 = 1, expected (2)
|
||||||
|
do i3 = 1, expected (3)
|
||||||
|
if (x (i1, i2, i3) .ne. i1 + i2 * 10 + i3 * 100) call abort
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end subroutine test
|
||||||
|
|
||||||
|
function f (x)
|
||||||
|
integer, dimension (3) :: x
|
||||||
|
integer, dimension (x(1), x(2), x(3)) :: f
|
||||||
|
integer :: i1, i2, i3
|
||||||
|
do i1 = 1, x(1)
|
||||||
|
do i2 = 1, x(2)
|
||||||
|
do i3 = 1, x(3)
|
||||||
|
f (i1, i2, i3) = i1 + i2 * 10 + i3 * 100
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end do
|
||||||
|
end function f
|
||||||
|
end program main
|
Loading…
Reference in New Issue