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>
|
||||
|
||||
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_add_block_to_block (&loop->pre, &se.pre);
|
||||
gfc_add_block_to_block (&loop->post, &se.post);
|
||||
ss->string_length = se.string_length;
|
||||
break;
|
||||
|
||||
case GFC_SS_CONSTRUCTOR:
|
||||
|
|
|
@ -1058,8 +1058,6 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
|
|||
tmp = gfc_get_symbol_decl (sym);
|
||||
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
|
||||
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
|
||||
|
||||
se->expr = tmp;
|
||||
}
|
||||
else
|
||||
{
|
||||
|
@ -1067,9 +1065,453 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
|
|||
sym->backend_decl = gfc_get_extern_function_decl (sym);
|
||||
|
||||
tmp = sym->backend_decl;
|
||||
gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
|
||||
se->expr = gfc_build_addr_expr (NULL, tmp);
|
||||
if (!POINTER_TYPE_P (TREE_TYPE (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_actual_arglist * arg)
|
||||
{
|
||||
gfc_interface_mapping mapping;
|
||||
tree arglist;
|
||||
tree retargs;
|
||||
tree tmp;
|
||||
tree fntype;
|
||||
gfc_se parmse;
|
||||
|
@ -1094,21 +1538,16 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
tree stringargs;
|
||||
gfc_formal_arglist *formal;
|
||||
int has_alternate_specifier = 0;
|
||||
bool need_interface_mapping;
|
||||
gfc_typespec ts;
|
||||
gfc_charlen cl;
|
||||
|
||||
arglist = NULL_TREE;
|
||||
retargs = NULL_TREE;
|
||||
stringargs = NULL_TREE;
|
||||
var = 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 (!sym->attr.elemental)
|
||||
|
@ -1123,9 +1562,6 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
/* Access the previously obtained result. */
|
||||
gfc_conv_tmp_array_ref (se);
|
||||
gfc_advance_se_ss_chain (se);
|
||||
|
||||
/* Bundle in the string length. */
|
||||
se->string_length = len;
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
@ -1134,91 +1570,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
else
|
||||
info = NULL;
|
||||
|
||||
byref = gfc_return_by_reference (sym);
|
||||
if (byref)
|
||||
{
|
||||
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);
|
||||
}
|
||||
}
|
||||
|
||||
gfc_init_interface_mapping (&mapping);
|
||||
need_interface_mapping = (sym->ts.type == BT_CHARACTER
|
||||
&& sym->ts.cl->length->expr_type != EXPR_CONSTANT);
|
||||
formal = sym->formal;
|
||||
/* Evaluate the arguments. */
|
||||
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);
|
||||
parmse.expr = null_pointer_node;
|
||||
if (arg->missing_arg_type == BT_CHARACTER)
|
||||
{
|
||||
stringargs =
|
||||
gfc_chainon_list (stringargs,
|
||||
convert (gfc_charlen_type_node,
|
||||
integer_zero_node));
|
||||
}
|
||||
parmse.string_length = convert (gfc_charlen_type_node,
|
||||
integer_zero_node);
|
||||
}
|
||||
}
|
||||
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->post, &parmse.post);
|
||||
|
||||
|
@ -1303,6 +1656,98 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
|
||||
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. */
|
||||
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>
|
||||
|
||||
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