2007-12-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31213
PR fortran/33888
PR fortran/33998
* trans-array.c (gfc_trans_array_constructor_value): If the
iterator variable does not have a backend_decl, use a local
temporary.
(get_elemental_fcn_charlen): New function to map the character
length of an elemental function onto its actual arglist.
(gfc_conv_expr_descriptor): Call the above so that the size of
the temporary can be evaluated.
* trans-expr.c : Include arith.h and change prototype of
gfc_apply_interface_mapping_to_expr to return void. Change all
references to gfc_apply_interface_mapping_to_expr accordingly.
(gfc_free_interface_mapping): Free the 'expr' field.
(gfc_add_interface_mapping): Add an argument for the actual
argument expression. This is copied to the 'expr' field of the
mapping. Only stabilize the backend_decl if the se is present.
Copy the character length expression and only add it's backend
declaration if se is present. Return without working on the
backend declaration for the new symbol if se is not present.
(gfc_map_intrinsic_function) : To simplify intrinsics 'len',
'size', 'ubound' and 'lbound' and then to map the result.
(gfc_map_fcn_formal_to_actual): Performs the formal to actual
mapping for the case of a function found in a specification
expression in the interface being mapped.
(gfc_apply_interface_mapping_to_ref): Remove seen_result and
all its references. Remove the inline simplification of LEN
and call gfc_map_intrinsic_function instead. Change the
order of mapping of the actual arguments and simplifying
intrinsic functions. Finally, if a function maps to an
actual argument, call gfc_map_fcn_formal_to_actual.
(gfc_conv_function_call): Add 'e' to the call to
gfc_add_interface_mapping.
* dump-parse-tree.c (gfc_show_symbol_n): New function for
diagnostic purposes.
* gfortran.h : Add prototype for gfc_show_symbol_n.
* trans.h : Add 'expr' field to gfc_add_interface_mapping.
Add 'expr' to prototype for gfc_show_symbol_n.
* resolve.c (resolve_generic_f0): Set specific function as
referenced.
2007-12-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31213
PR fortran/33888
PR fortran/33998
* gfortran.dg/mapping_1.f90: New test.
* gfortran.dg/mapping_2.f90: New test.
* gfortran.dg/mapping_3.f90: New test.
From-SVN: r130988
+2007-12-16 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/31213
+ PR fortran/33888
+ PR fortran/33998
+ * trans-array.c (gfc_trans_array_constructor_value): If the
+ iterator variable does not have a backend_decl, use a local
+ temporary.
+ (get_elemental_fcn_charlen): New function to map the character
+ length of an elemental function onto its actual arglist.
+ (gfc_conv_expr_descriptor): Call the above so that the size of
+ the temporary can be evaluated.
+ * trans-expr.c : Include arith.h and change prototype of
+ gfc_apply_interface_mapping_to_expr to return void. Change all
+ references to gfc_apply_interface_mapping_to_expr accordingly.
+ (gfc_free_interface_mapping): Free the 'expr' field.
+ (gfc_add_interface_mapping): Add an argument for the actual
+ argument expression. This is copied to the 'expr' field of the
+ mapping. Only stabilize the backend_decl if the se is present.
+ Copy the character length expression and only add it's backend
+ declaration if se is present. Return without working on the
+ backend declaration for the new symbol if se is not present.
+ (gfc_map_intrinsic_function) : To simplify intrinsics 'len',
+ 'size', 'ubound' and 'lbound' and then to map the result.
+ (gfc_map_fcn_formal_to_actual): Performs the formal to actual
+ mapping for the case of a function found in a specification
+ expression in the interface being mapped.
+ (gfc_apply_interface_mapping_to_ref): Remove seen_result and
+ all its references. Remove the inline simplification of LEN
+ and call gfc_map_intrinsic_function instead. Change the
+ order of mapping of the actual arguments and simplifying
+ intrinsic functions. Finally, if a function maps to an
+ actual argument, call gfc_map_fcn_formal_to_actual.
+ (gfc_conv_function_call): Add 'e' to the call to
+ gfc_add_interface_mapping.
+ * dump-parse-tree.c (gfc_show_symbol_n): New function for
+ diagnostic purposes.
+ * gfortran.h : Add prototype for gfc_show_symbol_n.
+ * trans.h : Add 'expr' field to gfc_add_interface_mapping.
+ Add 'expr' to prototype for gfc_show_symbol_n.
+ * resolve.c (resolve_generic_f0): Set specific function as
+ referenced.
+
2007-12-14 Tobias Burnus <burnus@net-b.de>
PR fortran/34438
}
+/* Show a symbol for diagnostic purposes. */
+void
+gfc_show_symbol_n (const char * msg, gfc_symbol *sym)
+{
+ if (msg)
+ gfc_status (msg);
+ gfc_show_symbol (sym);
+ gfc_status_char ('\n');
+}
+
+
/* Show a user-defined operator. Just prints an operator
and the name of the associated subroutine, really. */
void gfc_show_namespace (gfc_namespace *);
void gfc_show_ref (gfc_ref *);
void gfc_show_symbol (gfc_symbol *);
+void gfc_show_symbol_n (const char *, gfc_symbol *);
void gfc_show_typespec (gfc_typespec *);
/* parse.c */
else if (s->result != NULL && s->result->as != NULL)
expr->rank = s->result->as->rank;
+ gfc_set_sym_referenced (expr->value.function.esym);
+
return MATCH_YES;
}
loopbody = gfc_finish_block (&body);
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, c->iterator->var);
- gfc_add_block_to_block (pblock, &se.pre);
- loopvar = se.expr;
+ if (c->iterator->var->symtree->n.sym->backend_decl)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, c->iterator->var);
+ gfc_add_block_to_block (pblock, &se.pre);
+ loopvar = se.expr;
+ }
+ else
+ {
+ /* If the iterator appears in a specification expression in
+ an interface mapping, we need to make a temp for the loop
+ variable because it is not declared locally. */
+ loopvar = gfc_typenode_for_spec (&c->iterator->var->ts);
+ loopvar = gfc_create_var (loopvar, "loopvar");
+ }
/* Make a temporary, store the current value in that
and return it, once the loop is done. */
}
+/* gfc_conv_expr_descriptor needs the character length of elemental
+ functions before the function is called so that the size of the
+ temporary can be obtained. The only way to do this is to convert
+ the expression, mapping onto the actual arguments. */
+static void
+get_elemental_fcn_charlen (gfc_expr *expr, gfc_se *se)
+{
+ gfc_interface_mapping mapping;
+ gfc_formal_arglist *formal;
+ gfc_actual_arglist *arg;
+ gfc_se tse;
+
+ formal = expr->symtree->n.sym->formal;
+ arg = expr->value.function.actual;
+ gfc_init_interface_mapping (&mapping);
+
+ /* Set se = NULL in the calls to the interface mapping, to supress any
+ backend stuff. */
+ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+ {
+ if (!arg->expr)
+ continue;
+ if (formal->sym)
+ gfc_add_interface_mapping (&mapping, formal->sym, NULL, arg->expr);
+ }
+
+ gfc_init_se (&tse, NULL);
+
+ /* Build the expression for the character length and convert it. */
+ gfc_apply_interface_mapping (&mapping, &tse, expr->ts.cl->length);
+
+ gfc_add_block_to_block (&se->pre, &tse.pre);
+ gfc_add_block_to_block (&se->post, &tse.post);
+ tse.expr = fold_convert (gfc_charlen_type_node, tse.expr);
+ tse.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tse.expr,
+ build_int_cst (gfc_charlen_type_node, 0));
+ expr->ts.cl->backend_decl = tse.expr;
+ gfc_free_interface_mapping (&mapping);
+}
+
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
{
/* Elemental function. */
need_tmp = 1;
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.cl->length->expr_type != EXPR_CONSTANT)
+ get_elemental_fcn_charlen (expr, se);
+
info = NULL;
}
else
#include "langhooks.h"
#include "flags.h"
#include "gfortran.h"
+#include "arith.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
#include "dependency.h"
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
-static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
+static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
gfc_expr *);
/* Copy the scalarization loop variables. */
{
nextsym = sym->next;
gfc_free_symbol (sym->new->n.sym);
+ gfc_free_expr (sym->expr);
gfc_free (sym->new);
gfc_free (sym);
}
void
gfc_add_interface_mapping (gfc_interface_mapping * mapping,
- gfc_symbol * sym, gfc_se * se)
+ gfc_symbol * sym, gfc_se * se,
+ gfc_expr *expr)
{
gfc_interface_sym_mapping *sm;
tree desc;
new_sym->attr.pointer = sym->attr.pointer;
new_sym->attr.allocatable = sym->attr.allocatable;
new_sym->attr.flavor = sym->attr.flavor;
+ new_sym->attr.function = sym->attr.function;
/* Create a fake symtree for it. */
root = NULL;
sm->next = mapping->syms;
sm->old = sym;
sm->new = new_symtree;
+ sm->expr = gfc_copy_expr (expr);
mapping->syms = sm;
/* Stabilize the argument's value. */
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
+ if (!sym->attr.function && se)
+ 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);
+ sm->expr->ts.cl = new_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)
+ if (!new_sym->ts.cl->length && se)
{
se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
new_sym->ts.cl->backend_decl = se->string_length;
}
}
+ if (!se)
+ return;
+
/* Use the passed value as-is if the argument is a function. */
if (sym->attr.flavor == FL_PROCEDURE)
value = se->expr;
}
+/* Convert intrinsic function calls into result expressions. */
+static bool
+gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping)
+{
+ gfc_symbol *sym;
+ gfc_expr *new_expr;
+ gfc_expr *arg1;
+ gfc_expr *arg2;
+ int d, dup;
+
+ arg1 = expr->value.function.actual->expr;
+ if (expr->value.function.actual->next)
+ arg2 = expr->value.function.actual->next->expr;
+ else
+ arg2 = NULL;
+
+ sym = arg1->symtree->n.sym;
+
+ if (sym->attr.dummy)
+ return false;
+
+ new_expr = NULL;
+
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_LEN:
+ /* TODO figure out why this condition is necessary. */
+ if (sym->attr.function
+ && arg1->ts.cl->length->expr_type != EXPR_CONSTANT
+ && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)
+ return false;
+
+ new_expr = gfc_copy_expr (arg1->ts.cl->length);
+ break;
+
+ case GFC_ISYM_SIZE:
+ if (!sym->as)
+ return false;
+
+ if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+ {
+ dup = mpz_get_si (arg2->value.integer);
+ d = dup - 1;
+ }
+ else
+ {
+ dup = sym->as->rank;
+ d = 0;
+ }
+
+ for (; d < dup; d++)
+ {
+ gfc_expr *tmp;
+ tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
+ tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
+ if (new_expr)
+ new_expr = gfc_multiply (new_expr, tmp);
+ else
+ new_expr = tmp;
+ }
+ break;
+
+ case GFC_ISYM_LBOUND:
+ case GFC_ISYM_UBOUND:
+ /* TODO These implementations of lbound and ubound do not limit if
+ the size < 0, according to F95's 13.14.53 and 13.14.113. */
+
+ if (!sym->as)
+ return false;
+
+ if (arg2 && arg2->expr_type == EXPR_CONSTANT)
+ d = mpz_get_si (arg2->value.integer) - 1;
+ else
+ /* TODO: If the need arises, this could produce an array of
+ ubound/lbounds. */
+ gcc_unreachable ();
+
+ if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
+ new_expr = gfc_copy_expr (sym->as->lower[d]);
+ else
+ new_expr = gfc_copy_expr (sym->as->upper[d]);
+ break;
+
+ default:
+ break;
+ }
+
+ gfc_apply_interface_mapping_to_expr (mapping, new_expr);
+ if (!new_expr)
+ return false;
+
+ gfc_replace_expr (expr, new_expr);
+ return true;
+}
+
+
+static void
+gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
+ gfc_interface_mapping * mapping)
+{
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *actual;
+
+ actual = expr->value.function.actual;
+ f = map_expr->symtree->n.sym->formal;
+
+ for (; f && actual; f = f->next, actual = actual->next)
+ {
+ if (!actual->expr)
+ continue;
+
+ gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
+ }
+
+ if (map_expr->symtree->n.sym->attr.dimension)
+ {
+ int d;
+ gfc_array_spec *as;
+
+ as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
+
+ for (d = 0; d < as->rank; d++)
+ {
+ gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
+ gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
+ }
+
+ expr->value.function.esym->as = as;
+ }
+
+ if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
+ {
+ expr->value.function.esym->ts.cl->length
+ = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
+
+ gfc_apply_interface_mapping_to_expr (mapping,
+ expr->value.function.esym->ts.cl->length);
+ }
+}
+
+
/* 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 int
+static void
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
gfc_expr * expr)
{
gfc_interface_sym_mapping *sym;
gfc_actual_arglist *actual;
- int seen_result = 0;
if (!expr)
- return 0;
+ return;
/* Copying an expression does not copy its length, so do that here. */
if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
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;
+ /* TODO Find out why the condition on expr->symtree had to be moved into
+ the loop rather than being ouside it, as originally. */
+ for (sym = mapping->syms; sym; sym = sym->next)
+ if (expr->symtree && sym->old == expr->symtree->n.sym)
+ {
+ if (sym->new->n.sym->backend_decl)
+ expr->symtree = sym->new;
+ else if (sym->expr)
+ gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
+ }
- /* ...and to subexpressions in expr->value. */
+ /* ...and to subexpressions in expr->value. */
switch (expr->expr_type)
{
case EXPR_VARIABLE:
- if (expr->symtree->n.sym->attr.result)
- seen_result = 1;
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_SUBSTRING:
break;
case EXPR_FUNCTION:
+ for (actual = expr->value.function.actual; actual; actual = actual->next)
+ gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+
if (expr->value.function.esym == NULL
&& expr->value.function.isym != NULL
- && expr->value.function.isym->id == GFC_ISYM_LEN
- && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
- && gfc_apply_interface_mapping_to_expr (mapping,
- expr->value.function.actual->expr))
- {
- gfc_expr *new_expr;
- new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
- *expr = *new_expr;
- gfc_free (new_expr);
- gfc_apply_interface_mapping_to_expr (mapping, expr);
- break;
- }
+ && expr->value.function.actual->expr->symtree
+ && gfc_map_intrinsic_function (expr, mapping))
+ break;
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);
+ {
+ expr->value.function.esym = sym->new->n.sym;
+ gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
+ expr->value.function.esym->result = sym->new->n.sym;
+ }
break;
case EXPR_ARRAY:
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
break;
}
- return seen_result;
+
+ return;
}
}
if (fsym && need_interface_mapping)
- gfc_add_interface_mapping (&mapping, fsym, &parmse);
+ gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&post, &parmse.post);
struct gfc_interface_sym_mapping *next;
gfc_symbol *old;
gfc_symtree *new;
+ gfc_expr *expr;
}
gfc_interface_sym_mapping;
void gfc_init_interface_mapping (gfc_interface_mapping *);
void gfc_free_interface_mapping (gfc_interface_mapping *);
void gfc_add_interface_mapping (gfc_interface_mapping *,
- gfc_symbol *, gfc_se *);
+ gfc_symbol *, gfc_se *, gfc_expr *);
void gfc_finish_interface_mapping (gfc_interface_mapping *,
stmtblock_t *, stmtblock_t *);
void gfc_apply_interface_mapping (gfc_interface_mapping *,
+2007-12-16 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/31213
+ PR fortran/33888
+ PR fortran/33998
+ * gfortran.dg/mapping_1.f90: New test.
+ * gfortran.dg/mapping_2.f90: New test.
+ * gfortran.dg/mapping_3.f90: New test.
+
2007-12-16 Richard Sandiford <rsandifo@nildram.co.uk>
PR rtl-optimization/34415
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR31213, which exposed rather a lot of
+! bugs - see the PR and the ChangeLog.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+module mykinds
+ implicit none
+ integer, parameter :: ik1 = selected_int_kind (2)
+ integer, parameter :: ik2 = selected_int_kind (4)
+ integer, parameter :: dp = selected_real_kind (15,300)
+end module mykinds
+
+module spec_xpr
+ use mykinds
+ implicit none
+ integer(ik2) c_size
+contains
+ pure function tricky (str,ugly)
+ character(*), intent(in) :: str
+ integer(ik1) :: ia_ik1(len(str))
+ interface yoagly
+ pure function ugly(n)
+ use mykinds
+ implicit none
+ integer, intent(in) :: n
+ complex(dp) :: ugly(3*n+2)
+ end function ugly
+ end interface yoagly
+ logical :: la(size (yoagly (size (ia_ik1))))
+ integer :: i
+ character(tricky_helper ((/(.TRUE., i=1, size (la))/)) + c_size) :: tricky
+
+ tricky = transfer (yoagly (1), tricky)
+ end function tricky
+
+ pure function tricky_helper (lb)
+ logical, intent(in) :: lb(:)
+ integer :: tricky_helper
+ tricky_helper = 2 * size (lb) + 3
+ end function tricky_helper
+end module spec_xpr
+
+module xtra_fun
+ implicit none
+contains
+ pure function butt_ugly(n)
+ use mykinds
+ implicit none
+ integer, intent(in) :: n
+ complex(dp) :: butt_ugly(3*n+2)
+ real(dp) pi, sq2
+
+ pi = 4 * atan (1.0_dp)
+ sq2 = sqrt (2.0_dp)
+ butt_ugly = cmplx (pi, sq2, dp)
+ end function butt_ugly
+end module xtra_fun
+
+program spec_test
+ use mykinds
+ use spec_xpr
+ use xtra_fun
+ implicit none
+ character(54) :: chr
+
+ c_size = 5
+ if (tricky ('Help me', butt_ugly) .ne. transfer (butt_ugly (1), chr)) call abort ()
+end program spec_test
+! { dg-final { cleanup-modules "mykinds spec_xpr xtra_fun" } }
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR33998, in which the chain of expressions
+! determining the character length of my_string were not being
+! resolved by the formal to actual mapping.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module test
+ implicit none
+ contains
+ function my_string(x)
+ integer i
+ real, intent(in) :: x(:)
+ character(0) h4(1:minval([(1,i=1,0)],1))
+ character(0) sv1(size(x,1):size(h4))
+ character(0) sv2(2*lbound(sv1,1):size(h4))
+ character(lbound(sv2,1)-3) my_string
+
+ do i = 1, len(my_string)
+ my_string(i:i) = achar(modulo(i-1,10)+iachar('0'))
+ end do
+ end function my_string
+end module test
+
+program len_test
+ use test
+ implicit none
+ real x(7)
+
+ if (my_string(x) .ne. "01234567890") call abort ()
+end program len_test
+! { dg-final { cleanup-modules "test" } }
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR33888, in which the character length of
+! the elemental function myfunc was not being calculated before
+! the temporary for the array result was allocated.
+!
+! Contributed by Walter Spector <w6ws@earthlink.net>
+!
+program ftn95bug
+ implicit none
+
+ character(8) :: indata(4) = &
+ (/ '12344321', '98766789', 'abcdefgh', 'ABCDEFGH' /)
+
+ call process (myfunc (indata)) ! <- This caused a gfortran ICE !
+
+contains
+
+ elemental function myfunc (s)
+ character(*), intent(in) :: s
+ character(len (s)) :: myfunc
+
+ myfunc = s
+
+ end function
+
+ subroutine process (strings)
+ character(*), intent(in) :: strings(:)
+
+ if (any (strings .ne. indata)) call abort ()
+
+ end subroutine
+
+end program
projects / platform / upstream / gcc.git / commitdiff