PR fortran/15326: returning strings with non-constant lengths
Richard Sandiford
richard@codesourcery.com
Fri Sep 2 08:58:00 GMT 2005
PR 15326 is about an ICE on calls to functions like:
function f1 (string)
character (len = *) :: string
character (len = len (string)) :: f1
end function f1
The error comes from gfc_conv_function_call, which is only prepared to
handle constant string lengths:
/* 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);
According to Paul B., the prevailing wisdom was that it was too
complicated for the caller to evaluate arbitrary lengths, and that
these sorts of return values should be allocated by the callee instead.
This would lead to a calling convention with three cases:
- Functions whose result has a constant length parameter.
The allocation would be done by the caller.
- Functions whose result has an assumed length. The allocation
would also be done by the caller. For example:
program main
call sub (f2)
contains
function f2
character (len = *) :: f2
f2 = '123456789abcdef'
end function f2
subroutine sub (f)
character (len = 8) :: f
print *, f ()
end subroutine sub
end program main
- Functions whose result has a non-constant, non-assumed length.
The callee would allocate the array and tell the caller how
long it is. In Fortran terms, the pointer and length arguments
would be intent(out) rather than intent(in).
I think this makes the interface too complicated though. It also
pessimises cases in which the length could in principle be calculated
at compile time. For example, if we have:
program main
character (len = 20) :: x
x = f3 ()
contains
function f3
character (len = 20) :: f3
f3 = ''
end function f3
end program main
then we'll store the result of f3() in a stack temporary, and could
in principle assign directly to x instead, once such an optimisation
is implemented. It would be nice to do the same for:
program main
character (len = 20) :: x
x = f1 (x)
contains
function f1 (string)
character (len = *) :: string
character (len = len (string)) :: f1
f1 = string
end function f1
end program main
I've therefore tried to get the caller to calculate the length itself.
The restrictions on specification expressions should ensure that
this is safe.
As expected, it's not a simple patch, but it's not as bad as I first
feared. I doubt a patch to change the calling conventions would
be much simpler. I just hope I've not forgotten anything major.
The main part of the patch introduces a new set of functions by which
a caller can evaluate expressions from a callee's interface. The idea
is to:
1. Create a fake symbol to represent the value of an actual argument.
The symbol's backend_decl holds the cached value of the argument,
which needs to be adjusted for calling conventions and must have
the shape imposed by the dummy argument.
Note that these fake symbols are treated as ordinary variables,
not dummy arguments.
2. Create a copy of the interface expression that we want to evaluate.
3. Replace each reference to a dummy argument symbol with a
reference to the associated actual argument symbol.
For an example of (1), suppose we have:
program main
integer, dimension (1:50) :: b
integer :: i
b = (/ (i + 100, i = 1, 50) /)
print *, f4 (b)
contains
function f4 (a)
integer, dimension (10:) :: a
character (len = a (11)) :: f4
f4 = ''
end function f4
end program main
When converting "f4 (b)", "a" will be mapped to a fake symbol with an
array as its backend_decl. This array will have the same data as "b",
but its bounds will be "(10 : 9 + size (b, 1))". "a (11)" will therefore
evaluate to "b (2)" (== 102) as expected.
The only case I've found where these fake "variable" symbols caused
problems was in the passing of functions as values. There's no such
thing as a "function variable", so gfc_conv_function_val expects either
a dummy procedure symbol (which would have a pointer type) or a direct
procedure symbol (whose value would be a FUNCTION_DECL). We need a
small change to gfc_conv_function_val so that it allows non-dummy
symbols to be pointers too.
Most of the rest of the patch is about getting gfc_conv_function_call to
use these new evaluation functions. The main problem with the current
code is that g_c_f_c determines the location of the return value _before_
evaluating the arguments. That's no longer possible after the patch.
We need to evaluate the arguments first in order to calculate the
length of the return value.
A further problem is that g_c_f_c assumes that every call to the
function will have the same return length. That's no longer true
after this patch, and wouldn't be true however the PR is fixed.
So, a large part of the g_c_f_c change is just swapping the two blocks
of code around, but with tweaks to account for non-constant return
lengths. The specific changes are:
- Arguments related to the return value are added to a new list called
"retargs". retargs and arglist are concatenated at the end.
- The evaluated length is no longer stored in sym->cl->backend_decl,
since (a) its value might change every time the function is called
and (b) the value we compute may refer to the caller's local
variables. Instead, a temporary typespec and charlen are used.
- The code that handles null pointer arguments used to add the string
length to stringargs itself. It now stores the string length in
parmse.string_length, just like the other cases do.
(This is needed because of the new call to gfc_add_interface_mapping,
which uses parmse.string_length for "len = *" arguments.)
- At the moment, when g_c_f_c is called from within a scalarisation loop,
the length of an array return value is set from "len":
/* 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;
Now that the length can be nonconstant, we shouldn't evaluate
it during every iteration of the loop. I've therefore changed
the GFC_SS_FUNCTION case in gfc_add_loop_ss_code so that it
stores the length in ss->string_length, just like the GFC_SS_SCALAR
and GFC_SS_REFERENCE cases do. gfc_conv_tmp_array_ref will then pick
up this value and the "Bundle..." code above can be deleted.
- As a minor clean-up, "len" is converted to gfc_charlen_type_node
up-front, rather than at each point of use.
I've written the patch so that constant lengths don't go through the
new interface functions. This is partly for efficiency and partly for
safety. The idea is that the new functions will only be used for code
that triggered the ICE, which should make the patch a bit safer for 4.1.
I've included various testcases to try to make sure that
gfc_add_interface_mapping handles each type of argument correctly.
The tests try variations on other things too.
There are some things I know don't work for unrelated reasons.
For example, suppose we have:
program main
call test (f ())
contains
function f
integer, dimension (2) :: f
f = (/ 1, 1 /)
end function f
subroutine test (a)
integer, dimension (2) :: a
print *, a
end subroutine test
end program main
Neither the caller nor callee take responsibility for allocating the
array, and we get a segfault at runtime. This same bug causes a
segfault for characters too, both with variable and constant lengths:
program main
call test (f ())
contains
function f
character (len = 2), dimension (2) :: f
f = (/ '', '' /)
end function f
subroutine test (a)
character (len = *), dimension (2) :: a
print *, a
end subroutine test
end program main
program main
integer :: a
a = 2
call test (f ())
contains
function f
character (len = a), dimension (2) :: f
f = (/ '', '' /)
end function f
subroutine test (a)
character (len = *), dimension (2) :: a
print *, a
end subroutine test
end program main
Also, ubound() doesn't work correctly for:
program main
integer, dimension (40) :: a
call test (a)
contains
subroutine test (a)
integer, dimension (100:) :: a
print *, ubound (a, 1)
end subroutine test
end program main
which prints "40" instead of "140". This same bug prevents ubound()s
in interfaces from working correctly.
Individually bootstrapped & regression tested on i686-pc-linux-gnu.
Also tested with SPECFP2000 on powerpc64-linux-gnu, in combination
with the fortran patches that I posted last week. OK to install?
Richard
gcc/fortran/
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.
gcc/testsuite/
PR fortran/15326
* gfortran.fortran-torture/execute/pr15326-1.f90,
* gfortran.fortran-torture/execute/pr15326-2.f90,
* gfortran.fortran-torture/execute/pr15326-3.f90,
* gfortran.fortran-torture/execute/pr15326-4.f90,
* gfortran.fortran-torture/execute/pr15326-5.f90,
* gfortran.fortran-torture/execute/pr15326-6.f90,
* gfortran.fortran-torture/execute/pr15326-7.f90
* gfortran.fortran-torture/execute/pr15326-8.f90: New tests.
Index: gcc/fortran/trans-array.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.54
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -d -r1.54 trans-array.c
*** gcc/fortran/trans-array.c 6 Aug 2005 12:56:18 -0000 1.54
--- gcc/fortran/trans-array.c 2 Sep 2005 08:41:46 -0000
*************** gfc_add_loop_ss_code (gfc_loopinfo * loo
*** 1233,1238 ****
--- 1233,1239 ----
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:
Index: gcc/fortran/trans-expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.57
diff -c -p -F^\([(a-zA-Z0-9_]\|#define\) -d -r1.57 trans-expr.c
*** gcc/fortran/trans-expr.c 16 Aug 2005 12:58:46 -0000 1.57
--- gcc/fortran/trans-expr.c 2 Sep 2005 08:41:46 -0000
*************** gfc_conv_function_val (gfc_se * se, gfc_
*** 1058,1065 ****
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
{
--- 1058,1063 ----
*************** gfc_conv_function_val (gfc_se * se, gfc_
*** 1067,1075 ****
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);
}
}
--- 1065,1517 ----
sym->backend_decl = gfc_get_extern_function_decl (sym);
tmp = sym->backend_decl;
! 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);
}
*************** int
*** 1081,1087 ****
--- 1523,1531 ----
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;
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1094,1114 ****
tree stringargs;
gfc_formal_arglist *formal;
int has_alternate_specifier = 0;
arglist = 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)
--- 1538,1553 ----
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;
if (se->ss != NULL)
{
if (!sym->attr.elemental)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1123,1131 ****
/* 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;
}
}
--- 1562,1567 ----
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1134,1224 ****
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);
! }
! }
!
formal = sym->formal;
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
--- 1570,1578 ----
else
info = NULL;
! 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)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1243,1254 ****
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));
! }
}
}
else if (se->ss && se->ss->useflags)
--- 1597,1604 ----
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
if (arg->missing_arg_type == BT_CHARACTER)
! parmse.string_length = convert (gfc_charlen_type_node,
! integer_zero_node);
}
}
else if (se->ss && se->ss->useflags)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1293,1298 ****
--- 1643,1651 ----
}
}
+ 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);
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 1303,1308 ****
--- 1656,1753 ----
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);
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr15326-1.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr15326-1.f90 2005-09-01 22:12:03.000000000 +0100
***************
*** 0 ****
--- 1,110 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr15326-2.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr15326-2.f90 2005-09-01 22:12:03.000000000 +0100
***************
*** 0 ****
--- 1,103 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr15326-3.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr15326-3.f90 2005-09-02 08:41:00.000000000 +0100
***************
*** 0 ****
--- 1,75 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr15326-4.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr15326-4.f90 2005-09-02 09:41:21.000000000 +0100
***************
*** 0 ****
--- 1,60 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr15326-5.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr15326-5.f90 2005-09-01 22:12:03.000000000 +0100
***************
*** 0 ****
--- 1,134 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr15326-6.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr15326-6.f90 2005-09-01 22:32:59.000000000 +0100
***************
*** 0 ****
--- 1,105 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr15326-7.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr15326-7.f90 2005-09-01 22:12:03.000000000 +0100
***************
*** 0 ****
--- 1,52 ----
+ 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
diff -c /dev/null gcc/testsuite/gfortran.fortran-torture/execute/pr15326-8.f90
*** /dev/null 2005-06-16 22:49:09.000000000 +0100
--- gcc/testsuite/gfortran.fortran-torture/execute/pr15326-8.f90 2005-09-01 22:12:03.000000000 +0100
***************
*** 0 ****
--- 1,48 ----
+ 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
More information about the Fortran
mailing list