re PR fortran/15326 ([4.0 only] ICE with assumed length character strings)
PR fortran/15326 * trans-array.c (gfc_add_loop_ss_code): Set ss->string_length in the GFC_SS_FUNCTION case too. * trans-expr.c (gfc_conv_function_val): Allow symbols to be bound to function pointers as well as function decls. (gfc_interface_sym_mapping, gfc_interface_mapping): New structures. (gfc_init_interface_mapping, gfc_free_interface_mapping) (gfc_get_interface_mapping_charlen, gfc_get_interface_mapping_array) (gfc_set_interface_mapping_bounds, gfc_add_interface_mapping) (gfc_finish_interface_mapping, gfc_apply_interface_mapping_to_cons) (gfc_apply_interface_mapping_to_ref) (gfc_apply_interface_mapping_to_expr) (gfc_apply_interface_mapping): New functions. (gfc_conv_function_call): Evaluate the arguments before working out where the result should go. Make the null pointer case provide the string length in parmse.string_length. Cope with non-constant string lengths, using the above functions to evaluate such lengths. Use a temporary typespec; don't assign to sym->cl->backend_decl. Don't assign to se->string_length when returning a cached array descriptor. From-SVN: r104040
This commit is contained in:
parent
5c9186cec3
commit
0348d6fd85
|
@ -1,3 +1,26 @@
|
||||||
|
2005-09-08 Richard Sandiford <richard@codesourcery.com>
|
||||||
|
|
||||||
|
PR fortran/15326
|
||||||
|
* trans-array.c (gfc_add_loop_ss_code): Set ss->string_length in
|
||||||
|
the GFC_SS_FUNCTION case too.
|
||||||
|
* trans-expr.c (gfc_conv_function_val): Allow symbols to be bound
|
||||||
|
to function pointers as well as function decls.
|
||||||
|
(gfc_interface_sym_mapping, gfc_interface_mapping): New structures.
|
||||||
|
(gfc_init_interface_mapping, gfc_free_interface_mapping)
|
||||||
|
(gfc_get_interface_mapping_charlen, gfc_get_interface_mapping_array)
|
||||||
|
(gfc_set_interface_mapping_bounds, gfc_add_interface_mapping)
|
||||||
|
(gfc_finish_interface_mapping, gfc_apply_interface_mapping_to_cons)
|
||||||
|
(gfc_apply_interface_mapping_to_ref)
|
||||||
|
(gfc_apply_interface_mapping_to_expr)
|
||||||
|
(gfc_apply_interface_mapping): New functions.
|
||||||
|
(gfc_conv_function_call): Evaluate the arguments before working
|
||||||
|
out where the result should go. Make the null pointer case provide
|
||||||
|
the string length in parmse.string_length. Cope with non-constant
|
||||||
|
string lengths, using the above functions to evaluate such lengths.
|
||||||
|
Use a temporary typespec; don't assign to sym->cl->backend_decl.
|
||||||
|
Don't assign to se->string_length when returning a cached array
|
||||||
|
descriptor.
|
||||||
|
|
||||||
2005-09-08 Richard Sandiford <richard@codesourcery.com>
|
2005-09-08 Richard Sandiford <richard@codesourcery.com>
|
||||||
|
|
||||||
PR fortran/19928
|
PR fortran/19928
|
||||||
|
|
|
@ -1233,6 +1233,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript)
|
||||||
gfc_conv_expr (&se, ss->expr);
|
gfc_conv_expr (&se, ss->expr);
|
||||||
gfc_add_block_to_block (&loop->pre, &se.pre);
|
gfc_add_block_to_block (&loop->pre, &se.pre);
|
||||||
gfc_add_block_to_block (&loop->post, &se.post);
|
gfc_add_block_to_block (&loop->post, &se.post);
|
||||||
|
ss->string_length = se.string_length;
|
||||||
break;
|
break;
|
||||||
|
|
||||||
case GFC_SS_CONSTRUCTOR:
|
case GFC_SS_CONSTRUCTOR:
|
||||||
|
|
|
@ -1058,8 +1058,6 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
|
||||||
tmp = gfc_get_symbol_decl (sym);
|
tmp = gfc_get_symbol_decl (sym);
|
||||||
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
|
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
|
||||||
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
|
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
|
||||||
|
|
||||||
se->expr = tmp;
|
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
|
@ -1067,9 +1065,453 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
|
||||||
sym->backend_decl = gfc_get_extern_function_decl (sym);
|
sym->backend_decl = gfc_get_extern_function_decl (sym);
|
||||||
|
|
||||||
tmp = sym->backend_decl;
|
tmp = sym->backend_decl;
|
||||||
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
|
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
|
||||||
se->expr = gfc_build_addr_expr (NULL, tmp);
|
{
|
||||||
|
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
|
||||||
|
tmp = gfc_build_addr_expr (NULL, tmp);
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
se->expr = tmp;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* 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
|
||||||
|
gfc_init_interface_mapping (gfc_interface_mapping * mapping)
|
||||||
|
{
|
||||||
|
mapping->syms = NULL;
|
||||||
|
mapping->charlens = NULL;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Free all memory held by MAPPING (but not MAPPING itself). */
|
||||||
|
|
||||||
|
static void
|
||||||
|
gfc_free_interface_mapping (gfc_interface_mapping * mapping)
|
||||||
|
{
|
||||||
|
gfc_interface_sym_mapping *sym;
|
||||||
|
gfc_interface_sym_mapping *nextsym;
|
||||||
|
gfc_charlen *cl;
|
||||||
|
gfc_charlen *nextcl;
|
||||||
|
|
||||||
|
for (sym = mapping->syms; sym; sym = nextsym)
|
||||||
|
{
|
||||||
|
nextsym = sym->next;
|
||||||
|
gfc_free_symbol (sym->new->n.sym);
|
||||||
|
gfc_free (sym->new);
|
||||||
|
gfc_free (sym);
|
||||||
|
}
|
||||||
|
for (cl = mapping->charlens; cl; cl = nextcl)
|
||||||
|
{
|
||||||
|
nextcl = cl->next;
|
||||||
|
gfc_free_expr (cl->length);
|
||||||
|
gfc_free (cl);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Return a copy of gfc_charlen CL. Add the returned structure to
|
||||||
|
MAPPING so that it will be freed by gfc_free_interface_mapping. */
|
||||||
|
|
||||||
|
static gfc_charlen *
|
||||||
|
gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
|
||||||
|
gfc_charlen * cl)
|
||||||
|
{
|
||||||
|
gfc_charlen *new;
|
||||||
|
|
||||||
|
new = gfc_get_charlen ();
|
||||||
|
new->next = mapping->charlens;
|
||||||
|
new->length = gfc_copy_expr (cl->length);
|
||||||
|
|
||||||
|
mapping->charlens = new;
|
||||||
|
return new;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* A subroutine of gfc_add_interface_mapping. Return a descriptorless
|
||||||
|
array variable that can be used as the actual argument for dummy
|
||||||
|
argument SYM. Add any initialization code to BLOCK. PACKED is as
|
||||||
|
for gfc_get_nodesc_array_type and DATA points to the first element
|
||||||
|
in the passed array. */
|
||||||
|
|
||||||
|
static tree
|
||||||
|
gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
|
||||||
|
int packed, tree data)
|
||||||
|
{
|
||||||
|
tree type;
|
||||||
|
tree var;
|
||||||
|
|
||||||
|
type = gfc_typenode_for_spec (&sym->ts);
|
||||||
|
type = gfc_get_nodesc_array_type (type, sym->as, packed);
|
||||||
|
|
||||||
|
var = gfc_create_var (type, "parm");
|
||||||
|
gfc_add_modify_expr (block, var, fold_convert (type, data));
|
||||||
|
|
||||||
|
return var;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
|
||||||
|
and offset of descriptorless array type TYPE given that it has the same
|
||||||
|
size as DESC. Add any set-up code to BLOCK. */
|
||||||
|
|
||||||
|
static void
|
||||||
|
gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
|
||||||
|
{
|
||||||
|
int n;
|
||||||
|
tree dim;
|
||||||
|
tree offset;
|
||||||
|
tree tmp;
|
||||||
|
|
||||||
|
offset = gfc_index_zero_node;
|
||||||
|
for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
|
||||||
|
{
|
||||||
|
GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
|
||||||
|
if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
|
||||||
|
{
|
||||||
|
dim = gfc_rank_cst[n];
|
||||||
|
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
|
||||||
|
gfc_conv_descriptor_ubound (desc, dim),
|
||||||
|
gfc_conv_descriptor_lbound (desc, dim));
|
||||||
|
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
|
||||||
|
GFC_TYPE_ARRAY_LBOUND (type, n),
|
||||||
|
tmp);
|
||||||
|
tmp = gfc_evaluate_now (tmp, block);
|
||||||
|
GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
|
||||||
|
}
|
||||||
|
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
|
||||||
|
GFC_TYPE_ARRAY_LBOUND (type, n),
|
||||||
|
GFC_TYPE_ARRAY_STRIDE (type, n));
|
||||||
|
offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
|
||||||
|
}
|
||||||
|
offset = gfc_evaluate_now (offset, block);
|
||||||
|
GFC_TYPE_ARRAY_OFFSET (type) = offset;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Extend MAPPING so that it maps dummy argument SYM to the value stored
|
||||||
|
in SE. The caller may still use se->expr and se->string_length after
|
||||||
|
calling this function. */
|
||||||
|
|
||||||
|
static void
|
||||||
|
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
|
||||||
|
gfc_symbol * sym, gfc_se * se)
|
||||||
|
{
|
||||||
|
gfc_interface_sym_mapping *sm;
|
||||||
|
tree desc;
|
||||||
|
tree tmp;
|
||||||
|
tree value;
|
||||||
|
gfc_symbol *new_sym;
|
||||||
|
gfc_symtree *root;
|
||||||
|
gfc_symtree *new_symtree;
|
||||||
|
|
||||||
|
/* Create a new symbol to represent the actual argument. */
|
||||||
|
new_sym = gfc_new_symbol (sym->name, NULL);
|
||||||
|
new_sym->ts = sym->ts;
|
||||||
|
new_sym->attr.referenced = 1;
|
||||||
|
new_sym->attr.dimension = sym->attr.dimension;
|
||||||
|
new_sym->attr.pointer = sym->attr.pointer;
|
||||||
|
new_sym->attr.flavor = sym->attr.flavor;
|
||||||
|
|
||||||
|
/* Create a fake symtree for it. */
|
||||||
|
root = NULL;
|
||||||
|
new_symtree = gfc_new_symtree (&root, sym->name);
|
||||||
|
new_symtree->n.sym = new_sym;
|
||||||
|
gcc_assert (new_symtree == root);
|
||||||
|
|
||||||
|
/* Create a dummy->actual mapping. */
|
||||||
|
sm = gfc_getmem (sizeof (*sm));
|
||||||
|
sm->next = mapping->syms;
|
||||||
|
sm->old = sym;
|
||||||
|
sm->new = new_symtree;
|
||||||
|
mapping->syms = sm;
|
||||||
|
|
||||||
|
/* Stabilize the argument's value. */
|
||||||
|
se->expr = gfc_evaluate_now (se->expr, &se->pre);
|
||||||
|
|
||||||
|
if (sym->ts.type == BT_CHARACTER)
|
||||||
|
{
|
||||||
|
/* Create a copy of the dummy argument's length. */
|
||||||
|
new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
|
||||||
|
|
||||||
|
/* If the length is specified as "*", record the length that
|
||||||
|
the caller is passing. We should use the callee's length
|
||||||
|
in all other cases. */
|
||||||
|
if (!new_sym->ts.cl->length)
|
||||||
|
{
|
||||||
|
se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
|
||||||
|
new_sym->ts.cl->backend_decl = se->string_length;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Use the passed value as-is if the argument is a function. */
|
||||||
|
if (sym->attr.flavor == FL_PROCEDURE)
|
||||||
|
value = se->expr;
|
||||||
|
|
||||||
|
/* If the argument is either a string or a pointer to a string,
|
||||||
|
convert it to a boundless character type. */
|
||||||
|
else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
|
||||||
|
{
|
||||||
|
tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
|
||||||
|
tmp = build_pointer_type (tmp);
|
||||||
|
if (sym->attr.pointer)
|
||||||
|
tmp = build_pointer_type (tmp);
|
||||||
|
|
||||||
|
value = fold_convert (tmp, se->expr);
|
||||||
|
if (sym->attr.pointer)
|
||||||
|
value = gfc_build_indirect_ref (value);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* If the argument is a scalar or a pointer to an array, dereference it. */
|
||||||
|
else if (!sym->attr.dimension || sym->attr.pointer)
|
||||||
|
value = gfc_build_indirect_ref (se->expr);
|
||||||
|
|
||||||
|
/* If the argument is an array descriptor, use it to determine
|
||||||
|
information about the actual argument's shape. */
|
||||||
|
else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
|
||||||
|
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
|
||||||
|
{
|
||||||
|
/* Get the actual argument's descriptor. */
|
||||||
|
desc = gfc_build_indirect_ref (se->expr);
|
||||||
|
|
||||||
|
/* Create the replacement variable. */
|
||||||
|
tmp = gfc_conv_descriptor_data_get (desc);
|
||||||
|
value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
|
||||||
|
|
||||||
|
/* Use DESC to work out the upper bounds, strides and offset. */
|
||||||
|
gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
/* Otherwise we have a packed array. */
|
||||||
|
value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
|
||||||
|
|
||||||
|
new_sym->backend_decl = value;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Called once all dummy argument mappings have been added to MAPPING,
|
||||||
|
but before the mapping is used to evaluate expressions. Pre-evaluate
|
||||||
|
the length of each argument, adding any initialization code to PRE and
|
||||||
|
any finalization code to POST. */
|
||||||
|
|
||||||
|
static void
|
||||||
|
gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
|
||||||
|
stmtblock_t * pre, stmtblock_t * post)
|
||||||
|
{
|
||||||
|
gfc_interface_sym_mapping *sym;
|
||||||
|
gfc_expr *expr;
|
||||||
|
gfc_se se;
|
||||||
|
|
||||||
|
for (sym = mapping->syms; sym; sym = sym->next)
|
||||||
|
if (sym->new->n.sym->ts.type == BT_CHARACTER
|
||||||
|
&& !sym->new->n.sym->ts.cl->backend_decl)
|
||||||
|
{
|
||||||
|
expr = sym->new->n.sym->ts.cl->length;
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, expr);
|
||||||
|
gfc_init_se (&se, NULL);
|
||||||
|
gfc_conv_expr (&se, expr);
|
||||||
|
|
||||||
|
se.expr = gfc_evaluate_now (se.expr, &se.pre);
|
||||||
|
gfc_add_block_to_block (pre, &se.pre);
|
||||||
|
gfc_add_block_to_block (post, &se.post);
|
||||||
|
|
||||||
|
sym->new->n.sym->ts.cl->backend_decl = se.expr;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Like gfc_apply_interface_mapping_to_expr, but applied to
|
||||||
|
constructor C. */
|
||||||
|
|
||||||
|
static void
|
||||||
|
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
|
||||||
|
gfc_constructor * c)
|
||||||
|
{
|
||||||
|
for (; c; c = c->next)
|
||||||
|
{
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, c->expr);
|
||||||
|
if (c->iterator)
|
||||||
|
{
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Like gfc_apply_interface_mapping_to_expr, but applied to
|
||||||
|
reference REF. */
|
||||||
|
|
||||||
|
static void
|
||||||
|
gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
|
||||||
|
gfc_ref * ref)
|
||||||
|
{
|
||||||
|
int n;
|
||||||
|
|
||||||
|
for (; ref; ref = ref->next)
|
||||||
|
switch (ref->type)
|
||||||
|
{
|
||||||
|
case REF_ARRAY:
|
||||||
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
||||||
|
{
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
|
||||||
|
}
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
|
||||||
|
break;
|
||||||
|
|
||||||
|
case REF_COMPONENT:
|
||||||
|
break;
|
||||||
|
|
||||||
|
case REF_SUBSTRING:
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* EXPR is a copy of an expression that appeared in the interface
|
||||||
|
associated with MAPPING. Walk it recursively looking for references to
|
||||||
|
dummy arguments that MAPPING maps to actual arguments. Replace each such
|
||||||
|
reference with a reference to the associated actual argument. */
|
||||||
|
|
||||||
|
static void
|
||||||
|
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
|
||||||
|
gfc_expr * expr)
|
||||||
|
{
|
||||||
|
gfc_interface_sym_mapping *sym;
|
||||||
|
gfc_actual_arglist *actual;
|
||||||
|
|
||||||
|
if (!expr)
|
||||||
|
return;
|
||||||
|
|
||||||
|
/* Copying an expression does not copy its length, so do that here. */
|
||||||
|
if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
|
||||||
|
{
|
||||||
|
expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Apply the mapping to any references. */
|
||||||
|
gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
|
||||||
|
|
||||||
|
/* ...and to the expression's symbol, if it has one. */
|
||||||
|
if (expr->symtree)
|
||||||
|
for (sym = mapping->syms; sym; sym = sym->next)
|
||||||
|
if (sym->old == expr->symtree->n.sym)
|
||||||
|
expr->symtree = sym->new;
|
||||||
|
|
||||||
|
/* ...and to subexpressions in expr->value. */
|
||||||
|
switch (expr->expr_type)
|
||||||
|
{
|
||||||
|
case EXPR_VARIABLE:
|
||||||
|
case EXPR_CONSTANT:
|
||||||
|
case EXPR_NULL:
|
||||||
|
case EXPR_SUBSTRING:
|
||||||
|
break;
|
||||||
|
|
||||||
|
case EXPR_OP:
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
|
||||||
|
break;
|
||||||
|
|
||||||
|
case EXPR_FUNCTION:
|
||||||
|
for (sym = mapping->syms; sym; sym = sym->next)
|
||||||
|
if (sym->old == expr->value.function.esym)
|
||||||
|
expr->value.function.esym = sym->new->n.sym;
|
||||||
|
|
||||||
|
for (actual = expr->value.function.actual; actual; actual = actual->next)
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
|
||||||
|
break;
|
||||||
|
|
||||||
|
case EXPR_ARRAY:
|
||||||
|
case EXPR_STRUCTURE:
|
||||||
|
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Evaluate interface expression EXPR using MAPPING. Store the result
|
||||||
|
in SE. */
|
||||||
|
|
||||||
|
static void
|
||||||
|
gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
|
||||||
|
gfc_se * se, gfc_expr * expr)
|
||||||
|
{
|
||||||
|
expr = gfc_copy_expr (expr);
|
||||||
|
gfc_apply_interface_mapping_to_expr (mapping, expr);
|
||||||
|
gfc_conv_expr (se, expr);
|
||||||
|
se->expr = gfc_evaluate_now (se->expr, &se->pre);
|
||||||
|
gfc_free_expr (expr);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@ -1081,7 +1523,9 @@ int
|
||||||
gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
gfc_actual_arglist * arg)
|
gfc_actual_arglist * arg)
|
||||||
{
|
{
|
||||||
|
gfc_interface_mapping mapping;
|
||||||
tree arglist;
|
tree arglist;
|
||||||
|
tree retargs;
|
||||||
tree tmp;
|
tree tmp;
|
||||||
tree fntype;
|
tree fntype;
|
||||||
gfc_se parmse;
|
gfc_se parmse;
|
||||||
|
@ -1094,21 +1538,16 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
tree stringargs;
|
tree stringargs;
|
||||||
gfc_formal_arglist *formal;
|
gfc_formal_arglist *formal;
|
||||||
int has_alternate_specifier = 0;
|
int has_alternate_specifier = 0;
|
||||||
|
bool need_interface_mapping;
|
||||||
|
gfc_typespec ts;
|
||||||
|
gfc_charlen cl;
|
||||||
|
|
||||||
arglist = NULL_TREE;
|
arglist = NULL_TREE;
|
||||||
|
retargs = NULL_TREE;
|
||||||
stringargs = NULL_TREE;
|
stringargs = NULL_TREE;
|
||||||
var = NULL_TREE;
|
var = NULL_TREE;
|
||||||
len = NULL_TREE;
|
len = NULL_TREE;
|
||||||
|
|
||||||
/* Obtain the string length now because it is needed often below. */
|
|
||||||
if (sym->ts.type == BT_CHARACTER)
|
|
||||||
{
|
|
||||||
gcc_assert (sym->ts.cl && sym->ts.cl->length
|
|
||||||
&& sym->ts.cl->length->expr_type == EXPR_CONSTANT);
|
|
||||||
len = gfc_conv_mpz_to_tree
|
|
||||||
(sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
|
|
||||||
}
|
|
||||||
|
|
||||||
if (se->ss != NULL)
|
if (se->ss != NULL)
|
||||||
{
|
{
|
||||||
if (!sym->attr.elemental)
|
if (!sym->attr.elemental)
|
||||||
|
@ -1123,9 +1562,6 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
/* Access the previously obtained result. */
|
/* Access the previously obtained result. */
|
||||||
gfc_conv_tmp_array_ref (se);
|
gfc_conv_tmp_array_ref (se);
|
||||||
gfc_advance_se_ss_chain (se);
|
gfc_advance_se_ss_chain (se);
|
||||||
|
|
||||||
/* Bundle in the string length. */
|
|
||||||
se->string_length = len;
|
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
@ -1134,91 +1570,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
else
|
else
|
||||||
info = NULL;
|
info = NULL;
|
||||||
|
|
||||||
byref = gfc_return_by_reference (sym);
|
gfc_init_interface_mapping (&mapping);
|
||||||
if (byref)
|
need_interface_mapping = (sym->ts.type == BT_CHARACTER
|
||||||
{
|
&& sym->ts.cl->length->expr_type != EXPR_CONSTANT);
|
||||||
if (se->direct_byref)
|
|
||||||
{
|
|
||||||
arglist = gfc_chainon_list (arglist, se->expr);
|
|
||||||
|
|
||||||
/* Add string length to argument list. */
|
|
||||||
if (sym->ts.type == BT_CHARACTER)
|
|
||||||
{
|
|
||||||
sym->ts.cl->backend_decl = len;
|
|
||||||
arglist = gfc_chainon_list (arglist,
|
|
||||||
convert (gfc_charlen_type_node, len));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
else if (sym->result->attr.dimension)
|
|
||||||
{
|
|
||||||
gcc_assert (se->loop && se->ss);
|
|
||||||
|
|
||||||
/* Set the type of the array. */
|
|
||||||
tmp = gfc_typenode_for_spec (&sym->ts);
|
|
||||||
info->dimen = se->loop->dimen;
|
|
||||||
|
|
||||||
/* Allocate a temporary to store the result. */
|
|
||||||
gfc_trans_allocate_temp_array (se->loop, info, tmp);
|
|
||||||
|
|
||||||
/* Zero the first stride to indicate a temporary. */
|
|
||||||
tmp =
|
|
||||||
gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
|
|
||||||
gfc_add_modify_expr (&se->pre, tmp,
|
|
||||||
convert (TREE_TYPE (tmp), integer_zero_node));
|
|
||||||
|
|
||||||
/* Pass the temporary as the first argument. */
|
|
||||||
tmp = info->descriptor;
|
|
||||||
tmp = gfc_build_addr_expr (NULL, tmp);
|
|
||||||
arglist = gfc_chainon_list (arglist, tmp);
|
|
||||||
|
|
||||||
/* Add string length to argument list. */
|
|
||||||
if (sym->ts.type == BT_CHARACTER)
|
|
||||||
{
|
|
||||||
sym->ts.cl->backend_decl = len;
|
|
||||||
arglist = gfc_chainon_list (arglist,
|
|
||||||
convert (gfc_charlen_type_node, len));
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
else if (sym->ts.type == BT_CHARACTER)
|
|
||||||
{
|
|
||||||
|
|
||||||
/* Pass the string length. */
|
|
||||||
sym->ts.cl->backend_decl = len;
|
|
||||||
type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
|
|
||||||
type = build_pointer_type (type);
|
|
||||||
|
|
||||||
/* Return an address to a char[0:len-1]* temporary for character pointers. */
|
|
||||||
if (sym->attr.pointer || sym->attr.allocatable)
|
|
||||||
{
|
|
||||||
/* Build char[0:len-1] * pstr. */
|
|
||||||
tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
|
|
||||||
build_int_cst (gfc_charlen_type_node, 1));
|
|
||||||
tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
|
|
||||||
tmp = build_array_type (gfc_character1_type_node, tmp);
|
|
||||||
var = gfc_create_var (build_pointer_type (tmp), "pstr");
|
|
||||||
|
|
||||||
/* Provide an address expression for the function arguments. */
|
|
||||||
var = gfc_build_addr_expr (NULL, var);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
var = gfc_conv_string_tmp (se, type, len);
|
|
||||||
}
|
|
||||||
arglist = gfc_chainon_list (arglist, var);
|
|
||||||
arglist = gfc_chainon_list (arglist,
|
|
||||||
convert (gfc_charlen_type_node, len));
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
|
|
||||||
|
|
||||||
type = gfc_get_complex_type (sym->ts.kind);
|
|
||||||
var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
|
|
||||||
arglist = gfc_chainon_list (arglist, var);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
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)
|
||||||
|
@ -1243,12 +1597,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
gfc_init_se (&parmse, NULL);
|
gfc_init_se (&parmse, NULL);
|
||||||
parmse.expr = null_pointer_node;
|
parmse.expr = null_pointer_node;
|
||||||
if (arg->missing_arg_type == BT_CHARACTER)
|
if (arg->missing_arg_type == BT_CHARACTER)
|
||||||
{
|
parmse.string_length = convert (gfc_charlen_type_node,
|
||||||
stringargs =
|
integer_zero_node);
|
||||||
gfc_chainon_list (stringargs,
|
|
||||||
convert (gfc_charlen_type_node,
|
|
||||||
integer_zero_node));
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
else if (se->ss && se->ss->useflags)
|
else if (se->ss && se->ss->useflags)
|
||||||
|
@ -1293,6 +1643,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
if (formal && need_interface_mapping)
|
||||||
|
gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
|
||||||
|
|
||||||
gfc_add_block_to_block (&se->pre, &parmse.pre);
|
gfc_add_block_to_block (&se->pre, &parmse.pre);
|
||||||
gfc_add_block_to_block (&se->post, &parmse.post);
|
gfc_add_block_to_block (&se->post, &parmse.post);
|
||||||
|
|
||||||
|
@ -1303,6 +1656,98 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
||||||
|
|
||||||
arglist = gfc_chainon_list (arglist, parmse.expr);
|
arglist = gfc_chainon_list (arglist, parmse.expr);
|
||||||
}
|
}
|
||||||
|
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
|
||||||
|
|
||||||
|
ts = sym->ts;
|
||||||
|
if (ts.type == BT_CHARACTER)
|
||||||
|
{
|
||||||
|
/* Calculate the length of the returned string. */
|
||||||
|
gfc_init_se (&parmse, NULL);
|
||||||
|
if (need_interface_mapping)
|
||||||
|
gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
|
||||||
|
else
|
||||||
|
gfc_conv_expr (&parmse, sym->ts.cl->length);
|
||||||
|
gfc_add_block_to_block (&se->pre, &parmse.pre);
|
||||||
|
gfc_add_block_to_block (&se->post, &parmse.post);
|
||||||
|
|
||||||
|
/* Set up a charlen structure for it. */
|
||||||
|
cl.next = NULL;
|
||||||
|
cl.length = NULL;
|
||||||
|
cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
|
||||||
|
ts.cl = &cl;
|
||||||
|
|
||||||
|
len = cl.backend_decl;
|
||||||
|
}
|
||||||
|
gfc_free_interface_mapping (&mapping);
|
||||||
|
|
||||||
|
byref = gfc_return_by_reference (sym);
|
||||||
|
if (byref)
|
||||||
|
{
|
||||||
|
if (se->direct_byref)
|
||||||
|
retargs = gfc_chainon_list (retargs, se->expr);
|
||||||
|
else if (sym->result->attr.dimension)
|
||||||
|
{
|
||||||
|
gcc_assert (se->loop && info);
|
||||||
|
|
||||||
|
/* Set the type of the array. */
|
||||||
|
tmp = gfc_typenode_for_spec (&ts);
|
||||||
|
info->dimen = se->loop->dimen;
|
||||||
|
|
||||||
|
/* Allocate a temporary to store the result. */
|
||||||
|
gfc_trans_allocate_temp_array (se->loop, info, tmp);
|
||||||
|
|
||||||
|
/* Zero the first stride to indicate a temporary. */
|
||||||
|
tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
|
||||||
|
gfc_add_modify_expr (&se->pre, tmp,
|
||||||
|
convert (TREE_TYPE (tmp), integer_zero_node));
|
||||||
|
|
||||||
|
/* Pass the temporary as the first argument. */
|
||||||
|
tmp = info->descriptor;
|
||||||
|
tmp = gfc_build_addr_expr (NULL, tmp);
|
||||||
|
retargs = gfc_chainon_list (retargs, tmp);
|
||||||
|
}
|
||||||
|
else if (ts.type == BT_CHARACTER)
|
||||||
|
{
|
||||||
|
/* Pass the string length. */
|
||||||
|
type = gfc_get_character_type (ts.kind, ts.cl);
|
||||||
|
type = build_pointer_type (type);
|
||||||
|
|
||||||
|
/* Return an address to a char[0:len-1]* temporary for
|
||||||
|
character pointers. */
|
||||||
|
if (sym->attr.pointer || sym->attr.allocatable)
|
||||||
|
{
|
||||||
|
/* Build char[0:len-1] * pstr. */
|
||||||
|
tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
|
||||||
|
build_int_cst (gfc_charlen_type_node, 1));
|
||||||
|
tmp = build_range_type (gfc_array_index_type,
|
||||||
|
gfc_index_zero_node, tmp);
|
||||||
|
tmp = build_array_type (gfc_character1_type_node, tmp);
|
||||||
|
var = gfc_create_var (build_pointer_type (tmp), "pstr");
|
||||||
|
|
||||||
|
/* Provide an address expression for the function arguments. */
|
||||||
|
var = gfc_build_addr_expr (NULL, var);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
var = gfc_conv_string_tmp (se, type, len);
|
||||||
|
|
||||||
|
retargs = gfc_chainon_list (retargs, var);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
|
||||||
|
|
||||||
|
type = gfc_get_complex_type (ts.kind);
|
||||||
|
var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
|
||||||
|
retargs = gfc_chainon_list (retargs, var);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Add the string length to the argument list. */
|
||||||
|
if (ts.type == BT_CHARACTER)
|
||||||
|
retargs = gfc_chainon_list (retargs, len);
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Add the return arguments. */
|
||||||
|
arglist = chainon (retargs, arglist);
|
||||||
|
|
||||||
/* Add the hidden string length parameters to the arguments. */
|
/* Add the hidden string length parameters to the arguments. */
|
||||||
arglist = chainon (arglist, stringargs);
|
arglist = chainon (arglist, stringargs);
|
||||||
|
|
|
@ -1,3 +1,15 @@
|
||||||
|
2005-09-08 Richard Sandiford <richard@codesourcery.com>
|
||||||
|
|
||||||
|
PR fortran/15326
|
||||||
|
* gfortran.dg/char_result_1.f90,
|
||||||
|
* gfortran.dg/char_result_2.f90,
|
||||||
|
* gfortran.dg/char_result_3.f90,
|
||||||
|
* gfortran.dg/char_result_4.f90,
|
||||||
|
* gfortran.dg/char_result_5.f90,
|
||||||
|
* gfortran.dg/char_result_6.f90,
|
||||||
|
* gfortran.dg/char_result_7.f90,
|
||||||
|
* gfortran.dg/char_result_8.f90: New tests.
|
||||||
|
|
||||||
2005-09-08 Richard Sandiford <richard@codesourcery.com>
|
2005-09-08 Richard Sandiford <richard@codesourcery.com>
|
||||||
|
|
||||||
PR fortran/19928
|
PR fortran/19928
|
||||||
|
|
|
@ -0,0 +1,113 @@
|
||||||
|
! Related to PR 15326. Try calling string functions whose lengths depend
|
||||||
|
! on the lengths of other strings.
|
||||||
|
! { dg-do run }
|
||||||
|
pure function double (string)
|
||||||
|
character (len = *), intent (in) :: string
|
||||||
|
character (len = len (string) * 2) :: double
|
||||||
|
double = string // string
|
||||||
|
end function double
|
||||||
|
|
||||||
|
function f1 (string)
|
||||||
|
character (len = *) :: string
|
||||||
|
character (len = len (string)) :: f1
|
||||||
|
f1 = ''
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (string1, string2)
|
||||||
|
character (len = *) :: string1
|
||||||
|
character (len = len (string1) - 20) :: string2
|
||||||
|
character (len = len (string1) + len (string2) / 2) :: f2
|
||||||
|
f2 = ''
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
interface
|
||||||
|
pure function double (string)
|
||||||
|
character (len = *), intent (in) :: string
|
||||||
|
character (len = len (string) * 2) :: double
|
||||||
|
end function double
|
||||||
|
function f1 (string)
|
||||||
|
character (len = *) :: string
|
||||||
|
character (len = len (string)) :: f1
|
||||||
|
end function f1
|
||||||
|
function f2 (string1, string2)
|
||||||
|
character (len = *) :: string1
|
||||||
|
character (len = len (string1) - 20) :: string2
|
||||||
|
character (len = len (string1) + len (string2) / 2) :: f2
|
||||||
|
end function f2
|
||||||
|
end interface
|
||||||
|
|
||||||
|
integer :: a
|
||||||
|
character (len = 80), target :: text
|
||||||
|
character (len = 70), pointer :: textp
|
||||||
|
|
||||||
|
a = 42
|
||||||
|
textp => text
|
||||||
|
|
||||||
|
call test (f1 (text), 80)
|
||||||
|
call test (f2 (text, text), 110)
|
||||||
|
call test (f3 (text), 115)
|
||||||
|
call test (f4 (text), 192)
|
||||||
|
call test (f5 (text), 160)
|
||||||
|
call test (f6 (text), 39)
|
||||||
|
|
||||||
|
call test (f1 (textp), 70)
|
||||||
|
call test (f2 (textp, text), 95)
|
||||||
|
call test (f3 (textp), 105)
|
||||||
|
call test (f4 (textp), 192)
|
||||||
|
call test (f5 (textp), 140)
|
||||||
|
call test (f6 (textp), 29)
|
||||||
|
|
||||||
|
call indirect (textp)
|
||||||
|
contains
|
||||||
|
function f3 (string)
|
||||||
|
integer, parameter :: l1 = 30
|
||||||
|
character (len = *) :: string
|
||||||
|
character (len = len (string) + l1 + 5) :: f3
|
||||||
|
f3 = ''
|
||||||
|
end function f3
|
||||||
|
|
||||||
|
function f4 (string)
|
||||||
|
character (len = len (text) - 10) :: string
|
||||||
|
character (len = len (string) + len (text) + a) :: f4
|
||||||
|
f4 = ''
|
||||||
|
end function f4
|
||||||
|
|
||||||
|
function f5 (string)
|
||||||
|
character (len = *) :: string
|
||||||
|
character (len = len (double (string))) :: f5
|
||||||
|
f5 = ''
|
||||||
|
end function f5
|
||||||
|
|
||||||
|
function f6 (string)
|
||||||
|
character (len = *) :: string
|
||||||
|
character (len = len (string (a:))) :: f6
|
||||||
|
f6 = ''
|
||||||
|
end function f6
|
||||||
|
|
||||||
|
subroutine indirect (text2)
|
||||||
|
character (len = *) :: text2
|
||||||
|
|
||||||
|
call test (f1 (text), 80)
|
||||||
|
call test (f2 (text, text), 110)
|
||||||
|
call test (f3 (text), 115)
|
||||||
|
call test (f4 (text), 192)
|
||||||
|
call test (f5 (text), 160)
|
||||||
|
call test (f6 (text), 39)
|
||||||
|
|
||||||
|
call test (f1 (text2), 70)
|
||||||
|
call test (f2 (text2, text2), 95)
|
||||||
|
call test (f3 (text2), 105)
|
||||||
|
call test (f4 (text2), 192)
|
||||||
|
call test (f5 (text2), 140)
|
||||||
|
call test (f6 (text2), 29)
|
||||||
|
end subroutine indirect
|
||||||
|
|
||||||
|
subroutine test (string, length)
|
||||||
|
character (len = *) :: string
|
||||||
|
integer, intent (in) :: length
|
||||||
|
if (len (string) .ne. length) call abort
|
||||||
|
end subroutine test
|
||||||
|
end program main
|
|
@ -0,0 +1,105 @@
|
||||||
|
! Like char_result_1.f90, but the string arguments are pointers.
|
||||||
|
! { dg-do run }
|
||||||
|
pure function double (string)
|
||||||
|
character (len = *), intent (in) :: string
|
||||||
|
character (len = len (string) * 2) :: double
|
||||||
|
double = string // string
|
||||||
|
end function double
|
||||||
|
|
||||||
|
function f1 (string)
|
||||||
|
character (len = *), pointer :: string
|
||||||
|
character (len = len (string)) :: f1
|
||||||
|
f1 = ''
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (string1, string2)
|
||||||
|
character (len = *), pointer :: string1
|
||||||
|
character (len = len (string1) - 20), pointer :: string2
|
||||||
|
character (len = len (string1) + len (string2) / 2) :: f2
|
||||||
|
f2 = ''
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
interface
|
||||||
|
pure function double (string)
|
||||||
|
character (len = *), intent (in) :: string
|
||||||
|
character (len = len (string) * 2) :: double
|
||||||
|
end function double
|
||||||
|
function f1 (string)
|
||||||
|
character (len = *), pointer :: string
|
||||||
|
character (len = len (string)) :: f1
|
||||||
|
end function f1
|
||||||
|
function f2 (string1, string2)
|
||||||
|
character (len = *), pointer :: string1
|
||||||
|
character (len = len (string1) - 20), pointer :: string2
|
||||||
|
character (len = len (string1) + len (string2) / 2) :: f2
|
||||||
|
end function f2
|
||||||
|
end interface
|
||||||
|
|
||||||
|
integer :: a
|
||||||
|
character (len = 80), target :: text
|
||||||
|
character (len = 70), pointer :: textp
|
||||||
|
|
||||||
|
a = 42
|
||||||
|
textp => text
|
||||||
|
|
||||||
|
call test (f1 (textp), 70)
|
||||||
|
call test (f2 (textp, textp), 95)
|
||||||
|
call test (f3 (textp), 105)
|
||||||
|
call test (f4 (textp), 192)
|
||||||
|
call test (f5 (textp), 140)
|
||||||
|
call test (f6 (textp), 29)
|
||||||
|
|
||||||
|
call indirect (textp)
|
||||||
|
contains
|
||||||
|
function f3 (string)
|
||||||
|
integer, parameter :: l1 = 30
|
||||||
|
character (len = *), pointer :: string
|
||||||
|
character (len = len (string) + l1 + 5) :: f3
|
||||||
|
f3 = ''
|
||||||
|
end function f3
|
||||||
|
|
||||||
|
function f4 (string)
|
||||||
|
character (len = len (text) - 10), pointer :: string
|
||||||
|
character (len = len (string) + len (text) + a) :: f4
|
||||||
|
f4 = ''
|
||||||
|
end function f4
|
||||||
|
|
||||||
|
function f5 (string)
|
||||||
|
character (len = *), pointer :: string
|
||||||
|
character (len = len (double (string))) :: f5
|
||||||
|
f5 = ''
|
||||||
|
end function f5
|
||||||
|
|
||||||
|
function f6 (string)
|
||||||
|
character (len = *), pointer :: string
|
||||||
|
character (len = len (string (a:))) :: f6
|
||||||
|
f6 = ''
|
||||||
|
end function f6
|
||||||
|
|
||||||
|
subroutine indirect (textp2)
|
||||||
|
character (len = 50), pointer :: textp2
|
||||||
|
|
||||||
|
call test (f1 (textp), 70)
|
||||||
|
call test (f2 (textp, textp), 95)
|
||||||
|
call test (f3 (textp), 105)
|
||||||
|
call test (f4 (textp), 192)
|
||||||
|
call test (f5 (textp), 140)
|
||||||
|
call test (f6 (textp), 29)
|
||||||
|
|
||||||
|
call test (f1 (textp2), 50)
|
||||||
|
call test (f2 (textp2, textp), 65)
|
||||||
|
call test (f3 (textp2), 85)
|
||||||
|
call test (f4 (textp2), 192)
|
||||||
|
call test (f5 (textp2), 100)
|
||||||
|
call test (f6 (textp2), 9)
|
||||||
|
end subroutine indirect
|
||||||
|
|
||||||
|
subroutine test (string, length)
|
||||||
|
character (len = *) :: string
|
||||||
|
integer, intent (in) :: length
|
||||||
|
if (len (string) .ne. length) call abort
|
||||||
|
end subroutine test
|
||||||
|
end program main
|
|
@ -0,0 +1,78 @@
|
||||||
|
! Related to PR 15326. Try calling string functions whose lengths involve
|
||||||
|
! some sort of array calculation.
|
||||||
|
! { dg-do run }
|
||||||
|
pure elemental function double (x)
|
||||||
|
integer, intent (in) :: x
|
||||||
|
integer :: double
|
||||||
|
double = x * 2
|
||||||
|
end function double
|
||||||
|
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
interface
|
||||||
|
pure elemental function double (x)
|
||||||
|
integer, intent (in) :: x
|
||||||
|
integer :: double
|
||||||
|
end function double
|
||||||
|
end interface
|
||||||
|
|
||||||
|
integer, dimension (100:104), target :: a
|
||||||
|
integer, dimension (:), pointer :: ap
|
||||||
|
integer :: i, lower
|
||||||
|
|
||||||
|
a = (/ (i + 5, i = 0, 4) /)
|
||||||
|
ap => a
|
||||||
|
lower = 11
|
||||||
|
|
||||||
|
call test (f1 (a), 35)
|
||||||
|
call test (f1 (ap), 35)
|
||||||
|
call test (f1 ((/ 5, 10, 50 /)), 65)
|
||||||
|
call test (f1 (a (101:103)), 21)
|
||||||
|
|
||||||
|
call test (f2 (a), 115)
|
||||||
|
call test (f2 (ap), 115)
|
||||||
|
call test (f2 ((/ 5, 10, 50 /)), 119)
|
||||||
|
call test (f2 (a (101:103)), 116)
|
||||||
|
|
||||||
|
call test (f3 (a), 60)
|
||||||
|
call test (f3 (ap), 60)
|
||||||
|
call test (f3 ((/ 5, 10, 50 /)), 120)
|
||||||
|
call test (f3 (a (101:103)), 30)
|
||||||
|
|
||||||
|
call test (f4 (a, 13, 1), 21)
|
||||||
|
call test (f4 (ap, 13, 2), 14)
|
||||||
|
call test (f4 ((/ 5, 10, 50 /), 12, 1), 60)
|
||||||
|
call test (f4 (a (101:103), 12, 1), 15)
|
||||||
|
contains
|
||||||
|
function f1 (array)
|
||||||
|
integer, dimension (10:) :: array
|
||||||
|
character (len = sum (array)) :: f1
|
||||||
|
f1 = ''
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (array)
|
||||||
|
integer, dimension (10:) :: array
|
||||||
|
character (len = array (11) + a (104) + 100) :: f2
|
||||||
|
f2 = ''
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
function f3 (array)
|
||||||
|
integer, dimension (:) :: array
|
||||||
|
character (len = sum (double (array (2:)))) :: f3
|
||||||
|
f3 = ''
|
||||||
|
end function f3
|
||||||
|
|
||||||
|
function f4 (array, upper, stride)
|
||||||
|
integer, dimension (10:) :: array
|
||||||
|
integer :: upper, stride
|
||||||
|
character (len = sum (array (lower:upper:stride))) :: f4
|
||||||
|
f4 = ''
|
||||||
|
end function f4
|
||||||
|
|
||||||
|
subroutine test (string, length)
|
||||||
|
character (len = *) :: string
|
||||||
|
integer, intent (in) :: length
|
||||||
|
if (len (string) .ne. length) call abort
|
||||||
|
end subroutine test
|
||||||
|
end program main
|
|
@ -0,0 +1,62 @@
|
||||||
|
! Like char_result_3.f90, but the array arguments are pointers.
|
||||||
|
! { dg-do run }
|
||||||
|
pure elemental function double (x)
|
||||||
|
integer, intent (in) :: x
|
||||||
|
integer :: double
|
||||||
|
double = x * 2
|
||||||
|
end function double
|
||||||
|
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
interface
|
||||||
|
pure elemental function double (x)
|
||||||
|
integer, intent (in) :: x
|
||||||
|
integer :: double
|
||||||
|
end function double
|
||||||
|
end interface
|
||||||
|
|
||||||
|
integer, dimension (100:104), target :: a
|
||||||
|
integer, dimension (:), pointer :: ap
|
||||||
|
integer :: i, lower
|
||||||
|
|
||||||
|
a = (/ (i + 5, i = 0, 4) /)
|
||||||
|
ap => a
|
||||||
|
lower = 1
|
||||||
|
|
||||||
|
call test (f1 (ap), 35)
|
||||||
|
call test (f2 (ap), 115)
|
||||||
|
call test (f3 (ap), 60)
|
||||||
|
call test (f4 (ap, 5, 2), 21)
|
||||||
|
contains
|
||||||
|
function f1 (array)
|
||||||
|
integer, dimension (:), pointer :: array
|
||||||
|
character (len = sum (array)) :: f1
|
||||||
|
f1 = ''
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (array)
|
||||||
|
integer, dimension (:), pointer :: array
|
||||||
|
character (len = array (2) + a (104) + 100) :: f2
|
||||||
|
f2 = ''
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
function f3 (array)
|
||||||
|
integer, dimension (:), pointer :: array
|
||||||
|
character (len = sum (double (array (2:)))) :: f3
|
||||||
|
f3 = ''
|
||||||
|
end function f3
|
||||||
|
|
||||||
|
function f4 (array, upper, stride)
|
||||||
|
integer, dimension (:), pointer :: array
|
||||||
|
integer :: upper, stride
|
||||||
|
character (len = sum (array (lower:upper:stride))) :: f4
|
||||||
|
f4 = ''
|
||||||
|
end function f4
|
||||||
|
|
||||||
|
subroutine test (string, length)
|
||||||
|
character (len = *) :: string
|
||||||
|
integer, intent (in) :: length
|
||||||
|
if (len (string) .ne. length) call abort
|
||||||
|
end subroutine test
|
||||||
|
end program main
|
|
@ -0,0 +1,137 @@
|
||||||
|
! Related to PR 15326. Test calls to string functions whose lengths
|
||||||
|
! depend on various types of scalar value.
|
||||||
|
! { dg-do run }
|
||||||
|
pure function select (selector, iftrue, iffalse)
|
||||||
|
logical, intent (in) :: selector
|
||||||
|
integer, intent (in) :: iftrue, iffalse
|
||||||
|
integer :: select
|
||||||
|
|
||||||
|
if (selector) then
|
||||||
|
select = iftrue
|
||||||
|
else
|
||||||
|
select = iffalse
|
||||||
|
end if
|
||||||
|
end function select
|
||||||
|
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
interface
|
||||||
|
pure function select (selector, iftrue, iffalse)
|
||||||
|
logical, intent (in) :: selector
|
||||||
|
integer, intent (in) :: iftrue, iffalse
|
||||||
|
integer :: select
|
||||||
|
end function select
|
||||||
|
end interface
|
||||||
|
|
||||||
|
type pair
|
||||||
|
integer :: left, right
|
||||||
|
end type pair
|
||||||
|
|
||||||
|
integer, target :: i
|
||||||
|
integer, pointer :: ip
|
||||||
|
real, target :: r
|
||||||
|
real, pointer :: rp
|
||||||
|
logical, target :: l
|
||||||
|
logical, pointer :: lp
|
||||||
|
complex, target :: c
|
||||||
|
complex, pointer :: cp
|
||||||
|
character, target :: ch
|
||||||
|
character, pointer :: chp
|
||||||
|
type (pair), target :: p
|
||||||
|
type (pair), pointer :: pp
|
||||||
|
|
||||||
|
character (len = 10) :: dig
|
||||||
|
|
||||||
|
i = 100
|
||||||
|
r = 50.5
|
||||||
|
l = .true.
|
||||||
|
c = (10.9, 11.2)
|
||||||
|
ch = '1'
|
||||||
|
p%left = 40
|
||||||
|
p%right = 50
|
||||||
|
|
||||||
|
ip => i
|
||||||
|
rp => r
|
||||||
|
lp => l
|
||||||
|
cp => c
|
||||||
|
chp => ch
|
||||||
|
pp => p
|
||||||
|
|
||||||
|
dig = '1234567890'
|
||||||
|
|
||||||
|
call test (f1 (i), 200)
|
||||||
|
call test (f1 (ip), 200)
|
||||||
|
call test (f1 (-30), 60)
|
||||||
|
call test (f1 (i / (-4)), 50)
|
||||||
|
|
||||||
|
call test (f2 (r), 100)
|
||||||
|
call test (f2 (rp), 100)
|
||||||
|
call test (f2 (70.1), 140)
|
||||||
|
call test (f2 (r / 4), 24)
|
||||||
|
call test (f2 (real (i)), 200)
|
||||||
|
|
||||||
|
call test (f3 (l), 50)
|
||||||
|
call test (f3 (lp), 50)
|
||||||
|
call test (f3 (.false.), 55)
|
||||||
|
call test (f3 (i < 30), 55)
|
||||||
|
|
||||||
|
call test (f4 (c), 10)
|
||||||
|
call test (f4 (cp), 10)
|
||||||
|
call test (f4 (cmplx (60.0, r)), 60)
|
||||||
|
call test (f4 (cmplx (r, 1.0)), 50)
|
||||||
|
|
||||||
|
call test (f5 (ch), 11)
|
||||||
|
call test (f5 (chp), 11)
|
||||||
|
call test (f5 ('23'), 12)
|
||||||
|
call test (f5 (dig (3:)), 13)
|
||||||
|
call test (f5 (dig (10:)), 10)
|
||||||
|
|
||||||
|
call test (f6 (p), 145)
|
||||||
|
call test (f6 (pp), 145)
|
||||||
|
call test (f6 (pair (20, 10)), 85)
|
||||||
|
call test (f6 (pair (i / 2, 1)), 106)
|
||||||
|
contains
|
||||||
|
function f1 (i)
|
||||||
|
integer :: i
|
||||||
|
character (len = abs (i) * 2) :: f1
|
||||||
|
f1 = ''
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (r)
|
||||||
|
real :: r
|
||||||
|
character (len = floor (r) * 2) :: f2
|
||||||
|
f2 = ''
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
function f3 (l)
|
||||||
|
logical :: l
|
||||||
|
character (len = select (l, 50, 55)) :: f3
|
||||||
|
f3 = ''
|
||||||
|
end function f3
|
||||||
|
|
||||||
|
function f4 (c)
|
||||||
|
complex :: c
|
||||||
|
character (len = int (c)) :: f4
|
||||||
|
f4 = ''
|
||||||
|
end function f4
|
||||||
|
|
||||||
|
function f5 (c)
|
||||||
|
character :: c
|
||||||
|
character (len = scan ('123456789', c) + 10) :: f5
|
||||||
|
f5 = ''
|
||||||
|
end function f5
|
||||||
|
|
||||||
|
function f6 (p)
|
||||||
|
type (pair) :: p
|
||||||
|
integer :: i
|
||||||
|
character (len = sum ((/ p%left, p%right, (i, i = 1, 10) /))) :: f6
|
||||||
|
f6 = ''
|
||||||
|
end function f6
|
||||||
|
|
||||||
|
subroutine test (string, length)
|
||||||
|
character (len = *) :: string
|
||||||
|
integer, intent (in) :: length
|
||||||
|
if (len (string) .ne. length) call abort
|
||||||
|
end subroutine test
|
||||||
|
end program main
|
|
@ -0,0 +1,107 @@
|
||||||
|
! Like char_result_5.f90, but the function arguments are pointers to scalars.
|
||||||
|
! { dg-do run }
|
||||||
|
pure function select (selector, iftrue, iffalse)
|
||||||
|
logical, intent (in) :: selector
|
||||||
|
integer, intent (in) :: iftrue, iffalse
|
||||||
|
integer :: select
|
||||||
|
|
||||||
|
if (selector) then
|
||||||
|
select = iftrue
|
||||||
|
else
|
||||||
|
select = iffalse
|
||||||
|
end if
|
||||||
|
end function select
|
||||||
|
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
interface
|
||||||
|
pure function select (selector, iftrue, iffalse)
|
||||||
|
logical, intent (in) :: selector
|
||||||
|
integer, intent (in) :: iftrue, iffalse
|
||||||
|
integer :: select
|
||||||
|
end function select
|
||||||
|
end interface
|
||||||
|
|
||||||
|
type pair
|
||||||
|
integer :: left, right
|
||||||
|
end type pair
|
||||||
|
|
||||||
|
integer, target :: i
|
||||||
|
integer, pointer :: ip
|
||||||
|
real, target :: r
|
||||||
|
real, pointer :: rp
|
||||||
|
logical, target :: l
|
||||||
|
logical, pointer :: lp
|
||||||
|
complex, target :: c
|
||||||
|
complex, pointer :: cp
|
||||||
|
character, target :: ch
|
||||||
|
character, pointer :: chp
|
||||||
|
type (pair), target :: p
|
||||||
|
type (pair), pointer :: pp
|
||||||
|
|
||||||
|
i = 100
|
||||||
|
r = 50.5
|
||||||
|
l = .true.
|
||||||
|
c = (10.9, 11.2)
|
||||||
|
ch = '1'
|
||||||
|
p%left = 40
|
||||||
|
p%right = 50
|
||||||
|
|
||||||
|
ip => i
|
||||||
|
rp => r
|
||||||
|
lp => l
|
||||||
|
cp => c
|
||||||
|
chp => ch
|
||||||
|
pp => p
|
||||||
|
|
||||||
|
call test (f1 (ip), 200)
|
||||||
|
call test (f2 (rp), 100)
|
||||||
|
call test (f3 (lp), 50)
|
||||||
|
call test (f4 (cp), 10)
|
||||||
|
call test (f5 (chp), 11)
|
||||||
|
call test (f6 (pp), 145)
|
||||||
|
contains
|
||||||
|
function f1 (i)
|
||||||
|
integer, pointer :: i
|
||||||
|
character (len = abs (i) * 2) :: f1
|
||||||
|
f1 = ''
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (r)
|
||||||
|
real, pointer :: r
|
||||||
|
character (len = floor (r) * 2) :: f2
|
||||||
|
f2 = ''
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
function f3 (l)
|
||||||
|
logical, pointer :: l
|
||||||
|
character (len = select (l, 50, 55)) :: f3
|
||||||
|
f3 = ''
|
||||||
|
end function f3
|
||||||
|
|
||||||
|
function f4 (c)
|
||||||
|
complex, pointer :: c
|
||||||
|
character (len = int (c)) :: f4
|
||||||
|
f4 = ''
|
||||||
|
end function f4
|
||||||
|
|
||||||
|
function f5 (c)
|
||||||
|
character, pointer :: c
|
||||||
|
character (len = scan ('123456789', c) + 10) :: f5
|
||||||
|
f5 = ''
|
||||||
|
end function f5
|
||||||
|
|
||||||
|
function f6 (p)
|
||||||
|
type (pair), pointer :: p
|
||||||
|
integer :: i
|
||||||
|
character (len = sum ((/ p%left, p%right, (i, i = 1, 10) /))) :: f6
|
||||||
|
f6 = ''
|
||||||
|
end function f6
|
||||||
|
|
||||||
|
subroutine test (string, length)
|
||||||
|
character (len = *) :: string
|
||||||
|
integer, intent (in) :: length
|
||||||
|
if (len (string) .ne. length) call abort
|
||||||
|
end subroutine test
|
||||||
|
end program main
|
|
@ -0,0 +1,55 @@
|
||||||
|
! Related to PR 15326. Try calling string functions whose lengths depend
|
||||||
|
! on a dummy procedure.
|
||||||
|
! { dg-do run }
|
||||||
|
integer pure function double (x)
|
||||||
|
integer, intent (in) :: x
|
||||||
|
double = x * 2
|
||||||
|
end function double
|
||||||
|
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
interface
|
||||||
|
integer pure function double (x)
|
||||||
|
integer, intent (in) :: x
|
||||||
|
end function double
|
||||||
|
end interface
|
||||||
|
|
||||||
|
call test (f1 (double, 100), 200)
|
||||||
|
call test (f2 (double, 70), 140)
|
||||||
|
|
||||||
|
call indirect (double)
|
||||||
|
contains
|
||||||
|
function f1 (fn, i)
|
||||||
|
integer :: i
|
||||||
|
interface
|
||||||
|
integer pure function fn (x)
|
||||||
|
integer, intent (in) :: x
|
||||||
|
end function fn
|
||||||
|
end interface
|
||||||
|
character (len = fn (i)) :: f1
|
||||||
|
f1 = ''
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (fn, i)
|
||||||
|
integer :: i, fn
|
||||||
|
character (len = fn (i)) :: f2
|
||||||
|
f2 = ''
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
subroutine indirect (fn)
|
||||||
|
interface
|
||||||
|
integer pure function fn (x)
|
||||||
|
integer, intent (in) :: x
|
||||||
|
end function fn
|
||||||
|
end interface
|
||||||
|
call test (f1 (fn, 100), 200)
|
||||||
|
call test (f2 (fn, 70), 140)
|
||||||
|
end subroutine indirect
|
||||||
|
|
||||||
|
subroutine test (string, length)
|
||||||
|
character (len = *) :: string
|
||||||
|
integer, intent (in) :: length
|
||||||
|
if (len (string) .ne. length) call abort
|
||||||
|
end subroutine test
|
||||||
|
end program main
|
|
@ -0,0 +1,51 @@
|
||||||
|
! Related to PR 15326. Compare functions that return string pointers with
|
||||||
|
! functions that return strings.
|
||||||
|
! { dg-do run }
|
||||||
|
program main
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
character (len = 100), target :: string
|
||||||
|
|
||||||
|
call test (f1 (), 30)
|
||||||
|
call test (f2 (50), 50)
|
||||||
|
call test (f3 (), 30)
|
||||||
|
call test (f4 (70), 70)
|
||||||
|
|
||||||
|
call indirect (100)
|
||||||
|
contains
|
||||||
|
function f1
|
||||||
|
character (len = 30) :: f1
|
||||||
|
f1 = ''
|
||||||
|
end function f1
|
||||||
|
|
||||||
|
function f2 (i)
|
||||||
|
integer :: i
|
||||||
|
character (len = i) :: f2
|
||||||
|
f2 = ''
|
||||||
|
end function f2
|
||||||
|
|
||||||
|
function f3
|
||||||
|
character (len = 30), pointer :: f3
|
||||||
|
f3 => string
|
||||||
|
end function f3
|
||||||
|
|
||||||
|
function f4 (i)
|
||||||
|
integer :: i
|
||||||
|
character (len = i), pointer :: f4
|
||||||
|
f4 => string
|
||||||
|
end function f4
|
||||||
|
|
||||||
|
subroutine indirect (i)
|
||||||
|
integer :: i
|
||||||
|
call test (f1 (), 30)
|
||||||
|
call test (f2 (i), i)
|
||||||
|
call test (f3 (), 30)
|
||||||
|
call test (f4 (i), i)
|
||||||
|
end subroutine indirect
|
||||||
|
|
||||||
|
subroutine test (string, length)
|
||||||
|
character (len = *) :: string
|
||||||
|
integer, intent (in) :: length
|
||||||
|
if (len (string) .ne. length) call abort
|
||||||
|
end subroutine test
|
||||||
|
end program main
|
Loading…
Reference in New Issue