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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@139997 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 57ed95f..23dfbdf 100644 (file)
--- 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 b5a17c0..6ff6d10 100644 (file)
--- 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 29a4002..9be16a8 100644 (file)
--- 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 (file)
index 0000000..30cf357
--- /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 (file)
index 0000000..dc68bef
--- /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 (file)
index 0000000..46a11d3
--- /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