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

6 files changed, 130 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 57ed95f71de..23dfbdf4345 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 b5a17c0d5d8..6ff6d10c6af 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 29a4002c2b7..9be16a86dc2 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 00000000000..30cf357174f
--- /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 00000000000..dc68bef2ada
--- /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 00000000000..46a11d3f55a
--- /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