From d5551618259aa0add9a31cf9dcbb4810748ad7a5 Mon Sep 17 00:00:00 2001
From: Daniel Kraft <d@domob.eu>
Date: Thu, 4 Sep 2008 21:16:13 +0200
Subject: [PATCH] re PR fortran/37099 (Wrong results when comparing a character
array to a character expression)
2008-09-04 Daniel Kraft <d@domob.eu>
* PR fortran/37099
* expr.c (simplify_const_ref): Update expression's character length
when pulling out a substring reference.
2008-09-04 Daniel Kraft <d@domob.eu>
PR fortran/37099
* gfortran.dg/string_compare_1.f90: New text.
* gfortran.dg/string_compare_2.f90: New text.
* gfortran.dg/string_compare_3.f90: New text.
From-SVN: r139997
---
gcc/fortran/ChangeLog | 6 +++
gcc/fortran/expr.c | 35 +++++++++++++++++-
gcc/testsuite/ChangeLog | 7 ++++
.../gfortran.dg/string_compare_1.f90 | 25 +++++++++++++
.../gfortran.dg/string_compare_2.f90 | 37 +++++++++++++++++++
.../gfortran.dg/string_compare_3.f90 | 21 +++++++++++
6 files changed, 130 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/string_compare_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/string_compare_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/string_compare_3.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 57ed95f71de3..23dfbdf4345a 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2008-09-04 Daniel Kraft <d@domob.eu>
+
+ * PR fortran/37099
+ * expr.c (simplify_const_ref): Update expression's character length
+ when pulling out a substring reference.
+
2008-09-04 Ian Lance Taylor <iant@google.com>
* symbol.c (generate_isocbinding_symbol): Compare
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b5a17c0d5d80..6ff6d10c6af9 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1454,7 +1454,40 @@ simplify_const_ref (gfc_expr *p)
for (; cons; cons = cons->next)
{
cons->expr->ref = gfc_copy_ref (p->ref->next);
- simplify_const_ref (cons->expr);
+ if (simplify_const_ref (cons->expr) == FAILURE)
+ return FAILURE;
+ }
+
+ /* If this is a CHARACTER array and we possibly took a
+ substring out of it, update the type-spec's character
+ length according to the first element (as all should have
+ the same length). */
+ if (p->ts.type == BT_CHARACTER)
+ {
+ int string_len;
+
+ gcc_assert (p->ref->next);
+ gcc_assert (!p->ref->next->next);
+ gcc_assert (p->ref->next->type == REF_SUBSTRING);
+
+ if (p->value.constructor)
+ {
+ const gfc_expr* first = p->value.constructor->expr;
+ gcc_assert (first->expr_type == EXPR_CONSTANT);
+ gcc_assert (first->ts.type == BT_CHARACTER);
+ string_len = first->value.character.length;
+ }
+ else
+ string_len = 0;
+
+ if (!p->ts.cl)
+ {
+ p->ts.cl = gfc_get_charlen ();
+ p->ts.cl->next = NULL;
+ p->ts.cl->length = NULL;
+ }
+ gfc_free_expr (p->ts.cl->length);
+ p->ts.cl->length = gfc_int_expr (string_len);
}
}
gfc_free_ref_list (p->ref);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 29a4002c2b75..9be16a86dc21 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2008-09-04 Daniel Kraft <d@domob.eu>
+
+ PR fortran/37099
+ * gfortran.dg/string_compare_1.f90: New text.
+ * gfortran.dg/string_compare_2.f90: New text.
+ * gfortran.dg/string_compare_3.f90: New text.
+
2008-09-04 H.J. Lu <hongjiu.lu@intel.com>
PR rtl-optimization/37243
diff --git a/gcc/testsuite/gfortran.dg/string_compare_1.f90 b/gcc/testsuite/gfortran.dg/string_compare_1.f90
new file mode 100644
index 000000000000..30cf357174f4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/string_compare_1.f90
@@ -0,0 +1,25 @@
+! { dg-do run }
+
+! PR fortran/37099
+! Check for correct results when comparing array-section-substrings.
+
+PROGRAM main
+ IMPLICIT NONE
+
+ CHARACTER(*), PARAMETER :: exprs(1) = (/ 'aa' /)
+
+ CHARACTER(*), PARAMETER :: al1 = 'a';
+ CHARACTER(len=LEN (al1)) :: al2 = al1;
+
+ LOGICAL :: tmp(1), tmp2(1)
+
+ tmp = (exprs(1:1)(1:1) == al1)
+ tmp2 = (exprs(1:1)(1:1) == al2)
+
+ PRINT '(L1)', tmp
+ PRINT '(L1)', tmp2
+
+ IF (.NOT. tmp(1) .OR. .NOT. tmp2(1)) THEN
+ CALL abort ()
+ END IF
+END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/string_compare_2.f90 b/gcc/testsuite/gfortran.dg/string_compare_2.f90
new file mode 100644
index 000000000000..dc68bef2ada6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/string_compare_2.f90
@@ -0,0 +1,37 @@
+! { dg-do run }
+
+! PR fortran/37099
+! Check for correct results when comparing array-section-substrings.
+
+! This is the original test from the PR.
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+
+module xparams
+ integer,parameter :: exprbeg=100,exprend=154
+ character(*),dimension(exprbeg:exprend),parameter :: &
+ exprs=(/'nint() ','log10() ','sqrt() ','acos() ','asin() ', &
+ 'atan() ','cosh() ','sinh() ','tanh() ','int() ', &
+ 'cos() ','sin() ','tan() ','exp() ','log() ','abs() ',&
+ 'delta() ','step() ','rect() ','max(,) ','min(,) ','bj0() ',&
+ 'bj1() ','bjn(,) ','by0() ','by1() ','byn(,) ','logb(,) ',&
+ 'erf() ','erfc() ','lgamma()','gamma() ','csch() ','sech() ',&
+ 'coth() ','lif(,,) ','gaus() ','sinc() ','atan2(,)','mod(,) ',&
+ 'nthrt(,)','ramp() ','fbi() ','fbiq() ','uran(,) ','aif(,,,)',&
+ 'sgn() ','cbrt() ','fact() ','somb() ','bk0() ','bk1() ',&
+ 'bkn(,) ','bbi(,,) ','bbiq(,,)'/)
+ logical :: tmp(55,26)
+ character(26) :: al = 'abcdefghijklmnopqrstuvwxyz'
+end
+
+program pack_bug
+ use xparams
+ do i = 1, 1
+ tmp(:,i) = (exprs(:)(1:1)==al(i:i))
+ print '(55L1)', exprs(:)(1:1)=='a'
+ print '(55L1)', tmp(:,i)
+
+ if (any ((exprs(:)(1:1)=='a') .neqv. tmp(:,i))) then
+ call abort ()
+ end if
+ end do
+end
diff --git a/gcc/testsuite/gfortran.dg/string_compare_3.f90 b/gcc/testsuite/gfortran.dg/string_compare_3.f90
new file mode 100644
index 000000000000..46a11d3f55a7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/string_compare_3.f90
@@ -0,0 +1,21 @@
+! { dg-do run }
+
+! PR fortran/37099
+! Check for correct results when comparing array-section-substrings.
+
+! This is the test from comment #1 of the PR.
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+
+integer, parameter :: n = 10
+integer, parameter :: ilst(n) = (/(i,i=1,n)/)
+character(*), parameter :: c0lst(n) = (/(char(96+i),i=1,n)/)
+character(*), parameter :: c1lst(n) = (/(char(96+i)//'b',i=1,n)/)
+logical :: tmp(n)
+i = 5
+print *, ilst(:) == i
+print *, c0lst(:)(1:1) == char(96+i)
+tmp = c1lst(:)(1:1) == char(96+i)
+print *, tmp
+print *, c1lst(:)(1:1) == 'e'
+if (any(tmp .neqv. (c0lst(:)(1:1) == char(96+i)))) call abort()
+end
--
GitLab