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:
Richard Sandiford
Richard Sandiford
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>
|
||||
|
||||
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
|
||||
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
|
||||
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
|
||||
using realloc. This prevents us from putting the array on the stack. */
|
||||
|
||||
static void
|
||||
gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
||||
tree size, tree nelem, bool dynamic)
|
||||
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
|
||||
gfc_ss_info * info, tree size, tree nelem,
|
||||
bool dynamic)
|
||||
{
|
||||
tree tmp;
|
||||
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))
|
||||
{
|
||||
/* 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;
|
||||
}
|
||||
else
|
||||
|
|
@ -474,7 +521,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
|||
tmp);
|
||||
tmp = gfc_create_var (tmp, "A");
|
||||
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
|
||||
{
|
||||
|
|
@ -488,8 +535,8 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
|||
else
|
||||
gcc_unreachable ();
|
||||
tmp = gfc_build_function_call (tmp, args);
|
||||
tmp = gfc_evaluate_now (tmp, &loop->pre);
|
||||
gfc_conv_descriptor_data_set (&loop->pre, desc, tmp);
|
||||
tmp = gfc_evaluate_now (tmp, pre);
|
||||
gfc_conv_descriptor_data_set (pre, desc, tmp);
|
||||
}
|
||||
}
|
||||
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
|
||||
lower bound. */
|
||||
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)
|
||||
{
|
||||
|
|
@ -506,7 +553,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
|
|||
tmp = fold_convert (pvoid_type_node, tmp);
|
||||
tmp = gfc_chainon_list (NULL_TREE, 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.
|
||||
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
|
||||
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 type;
|
||||
|
|
@ -565,7 +613,7 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
|
|||
|
||||
/* Fill in the array dtype. */
|
||||
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:
|
||||
|
|
@ -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. */
|
||||
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]);
|
||||
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]);
|
||||
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,
|
||||
loop->to[n], gfc_index_one_node);
|
||||
|
||||
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. */
|
||||
|
|
@ -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,
|
||||
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)
|
||||
loop->temp_dim = info->dimen;
|
||||
|
|
@ -1278,7 +1326,8 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
|
|||
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;
|
||||
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));
|
||||
loop->temp_ss->type = GFC_SS_SECTION;
|
||||
loop->temp_ss->data.info.dimen = n;
|
||||
gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info,
|
||||
tmp, false);
|
||||
gfc_trans_allocate_temp_array (&loop->pre, &loop->post, loop,
|
||||
&loop->temp_ss->data.info, tmp, false);
|
||||
}
|
||||
|
||||
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. */
|
||||
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. */
|
||||
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
|
||||
variables. */
|
||||
|
|
|
|||
|
|
@ -41,6 +41,8 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
|
|||
#include "trans-stmt.h"
|
||||
|
||||
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. */
|
||||
|
||||
|
|
@ -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. */
|
||||
|
||||
static void
|
||||
void
|
||||
gfc_init_interface_mapping (gfc_interface_mapping * mapping)
|
||||
{
|
||||
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). */
|
||||
|
||||
static void
|
||||
void
|
||||
gfc_free_interface_mapping (gfc_interface_mapping * mapping)
|
||||
{
|
||||
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
|
||||
calling this function. */
|
||||
|
||||
static void
|
||||
void
|
||||
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
|
||||
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
|
||||
any finalization code to POST. */
|
||||
|
||||
static void
|
||||
void
|
||||
gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
|
||||
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
|
||||
in SE. */
|
||||
|
||||
static void
|
||||
void
|
||||
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
|
||||
gfc_se * se, gfc_expr * expr)
|
||||
{
|
||||
|
|
@ -1571,8 +1509,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
info = NULL;
|
||||
|
||||
gfc_init_interface_mapping (&mapping);
|
||||
need_interface_mapping = (sym->ts.type == BT_CHARACTER
|
||||
&& sym->ts.cl->length->expr_type != EXPR_CONSTANT);
|
||||
need_interface_mapping = ((sym->ts.type == BT_CHARACTER
|
||||
&& sym->ts.cl->length->expr_type != EXPR_CONSTANT)
|
||||
|| sym->attr.dimension);
|
||||
formal = sym->formal;
|
||||
/* Evaluate the arguments. */
|
||||
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;
|
||||
}
|
||||
gfc_free_interface_mapping (&mapping);
|
||||
|
||||
byref = gfc_return_by_reference (sym);
|
||||
if (byref)
|
||||
|
|
@ -1693,8 +1631,12 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
tmp = gfc_typenode_for_spec (&ts);
|
||||
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. */
|
||||
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. */
|
||||
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)
|
||||
retargs = gfc_chainon_list (retargs, len);
|
||||
}
|
||||
gfc_free_interface_mapping (&mapping);
|
||||
|
||||
/* Add the return arguments. */
|
||||
arglist = chainon (retargs, arglist);
|
||||
|
|
|
|||
|
|
@ -572,4 +572,74 @@ struct lang_decl GTY(())
|
|||
arg1, arg2)
|
||||
#define build3_v(code, arg1, arg2, arg3) build3(code, void_type_node, \
|
||||
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 */
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
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