Hello world,
the following patch extends the trim optimization to variables like
trim(a%x).
Going for trim(a(1)) led to a very strange regression, so I took that
out (for now).
Regression-tested. OK for trunk?
Thomas
2011-03-26 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/47065
* frontend-passes (optimize_trim): Also follow references, except
when they are substring references or array references.
2011-03-26 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/47065
* gfortran.dg/trim_optimize_5.f90: New test.
* gfortran.dg/trim_optimize_6.f90: New test.
! { dg-do run }
! { dg-options "-O -fdump-tree-original" }
! PR 47065 - replace trim with substring expressions even with references.
program main
use foo
implicit none
type t
character(len=2) :: x
end type t
type(t) :: a
character(len=3) :: b
character(len=10) :: line
a%x = 'a'
write(unit=line,fmt='(A,A)') trim(a%x),"X"
if (line /= 'aX ') call abort
b = 'ab'
write (unit=line,fmt='(A,A)') trim(b),"Y"
if (line /= 'abY ') call abort
end program main
! { dg-final { scan-tree-dump-times "string_len_trim" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-do run }
! PR 47065 - make sure that impure functions are not evaluated twice when
! replacing calls to trim with expression(1:len_trim)
module foo
implicit none
contains
function f()
integer :: f
integer :: s=0
s = s + 1
f = s
end function f
end module foo
program main
use foo
implicit none
character(len=10) :: line
character(len=4) :: b(2)
b(1) = 'a'
b(2) = 'bc'
write(unit=line,fmt='(A,A)') trim(b(f())), "X"
if (line /= "aX ") call abort
if (f() .ne. 2) call abort
end program main
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (Revision 171207)
+++ frontend-passes.c (Arbeitskopie)
@@ -664,6 +664,7 @@
gfc_ref *ref;
gfc_expr *fcn;
gfc_actual_arglist *actual_arglist, *next;
+ gfc_ref **rr = NULL;
/* Don't do this optimization within an argument list, because
otherwise aliasing issues may occur. */
@@ -681,46 +682,54 @@
if (a->expr_type != EXPR_VARIABLE)
return false;
+ /* Follow all references to find the correct place to put the newly
+ created reference. FIXME: Also handle substring references and
+ array references. Array references cause strange regressions at
+ the moment. */
+
if (a->ref)
{
- /* FIXME - also handle substring references, by modifying the
- reference itself. Make sure not to evaluate functions in
- the references twice. */
- return false;
+ for (rr = &(a->ref); *rr; rr = &((*rr)->next))
+ {
+ if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
+ return false;
+ }
}
- else
- {
- strip_function_call (e);
- /* Create the reference. */
+ strip_function_call (e);
- ref = gfc_get_ref ();
- ref->type = REF_SUBSTRING;
+ if (e->ref == NULL)
+ rr = &(e->ref);
- /* Set the start of the reference. */
+ /* Create the reference. */
- ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ ref = gfc_get_ref ();
+ ref->type = REF_SUBSTRING;
- /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */
+ /* Set the start of the reference. */
- fcn = gfc_get_expr ();
- fcn->expr_type = EXPR_FUNCTION;
- fcn->value.function.isym =
- gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
- actual_arglist = gfc_get_actual_arglist ();
- actual_arglist->expr = gfc_copy_expr (e);
- next = gfc_get_actual_arglist ();
- next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
- gfc_default_integer_kind);
- actual_arglist->next = next;
- fcn->value.function.actual = actual_arglist;
+ ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
- /* Set the end of the reference to the call to len_trim. */
+ /* Build the function call to len_trim(x, gfc_defaul_integer_kind). */
- ref->u.ss.end = fcn;
- e->ref = ref;
- return true;
- }
+ fcn = gfc_get_expr ();
+ fcn->expr_type = EXPR_FUNCTION;
+ fcn->value.function.isym =
+ gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
+ actual_arglist = gfc_get_actual_arglist ();
+ actual_arglist->expr = gfc_copy_expr (e);
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ gfc_default_integer_kind);
+ actual_arglist->next = next;
+ fcn->value.function.actual = actual_arglist;
+
+ /* Set the end of the reference to the call to len_trim. */
+
+ ref->u.ss.end = fcn;
+ gcc_assert (*rr == NULL);
+ *rr = ref;
+ return true;
}
#define WALK_SUBEXPR(NODE) \
