OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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:
Richard Sandiford 2005-09-08 18:46:06 +00:00 committed by Richard Sandiford
parent 5c9186cec3
commit 0348d6fd85
12 changed files with 1296 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/fortran/ChangeLog
View File

@ -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

1
gcc/fortran/trans-array.c
View File

@ -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:

659
gcc/fortran/trans-expr.c
View File

@ -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);

12
gcc/testsuite/ChangeLog
View File

@ -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

113
gcc/testsuite/gfortran.dg/char_result_1.f90 Normal file
View File

@ -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

105
gcc/testsuite/gfortran.dg/char_result_2.f90 Normal file
View File

@ -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

78
gcc/testsuite/gfortran.dg/char_result_3.f90 Normal file
View File

@ -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

62
gcc/testsuite/gfortran.dg/char_result_4.f90 Normal file
View File

@ -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

137
gcc/testsuite/gfortran.dg/char_result_5.f90 Normal file
View File

@ -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

107
gcc/testsuite/gfortran.dg/char_result_6.f90 Normal file
View File

@ -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

55
gcc/testsuite/gfortran.dg/char_result_7.f90 Normal file
View File

@ -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

51
gcc/testsuite/gfortran.dg/char_result_8.f90 Normal file
View File

@ -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