2010-12-24 Thomas Koenig <tkoenig@gcc.gnu.org>

	PR fortran/31821
	* check.c (gfc_var_strlen):  New function, also including
	substring references.
	(gfc_check_same_strlen):  Use gfc_var_strlen.

2010-12-24  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/31821
	* gfortran.dg/char_pointer_assign_6.f90:  New test.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4ffb3e3..980d1b1 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2010-12-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/31821
+       * check.c (gfc_var_strlen):  New function, also including
+       substring references.
+       (gfc_check_same_strlen):  Use gfc_var_strlen.
+
 2010-12-23  Mikael Morin  <mikael.morin@gcc.gnu.org>
 
        PR fortran/46978

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index ceea6f3..20163f9 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -635,40 +635,69 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
   return ret;
 }
 
+/*  Calculate the length of a character variable, including substrings.
+    Strip away parentheses if necessary.  Return -1 if no length could
+    be determined.  */
+
+static long
+gfc_var_strlen (const gfc_expr *a)
+{
+  gfc_ref *ra;
+
+  while (a->expr_type == EXPR_OP && a->value.op.op == INTRINSIC_PARENTHESES)
+    a = a->value.op.op1;
+
+  for (ra = a->ref; ra != NULL && ra->type != REF_SUBSTRING; ra = ra->next)
+    ;
+
+  if (ra)
+    {
+      long start_a, end_a;
+
+      if (ra->u.ss.start->expr_type == EXPR_CONSTANT
+         && ra->u.ss.end->expr_type == EXPR_CONSTANT)
+       {
+         start_a = mpz_get_si (ra->u.ss.start->value.integer);
+         end_a = mpz_get_si (ra->u.ss.end->value.integer);
+         return end_a - start_a + 1;
+       }
+      else if (gfc_dep_compare_expr (ra->u.ss.start, ra->u.ss.end) == 0)
+       return 1;
+      else
+       return -1;
+    }
+
+  if (a->ts.u.cl && a->ts.u.cl->length
+      && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+    return mpz_get_si (a->ts.u.cl->length->value.integer);
+  else if (a->expr_type == EXPR_CONSTANT
+          && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
+    return a->value.character.length;
+  else
+    return -1;
+
+}
 
 /* Check whether two character expressions have the same length;
-   returns SUCCESS if they have or if the length cannot be determined.  */
+   returns SUCCESS if they have or if the length cannot be determined,
+   otherwise return FAILURE and raise a gfc_error.  */
 
 gfc_try
 gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
 {
    long len_a, len_b;
-   len_a = len_b = -1;
-
-   if (a->ts.u.cl && a->ts.u.cl->length
-       && a->ts.u.cl->length->expr_type == EXPR_CONSTANT)
-     len_a = mpz_get_si (a->ts.u.cl->length->value.integer);
-   else if (a->expr_type == EXPR_CONSTANT
-           && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL))
-     len_a = a->value.character.length;
-   else
-     return SUCCESS;
 
-   if (b->ts.u.cl && b->ts.u.cl->length
-       && b->ts.u.cl->length->expr_type == EXPR_CONSTANT)
-     len_b = mpz_get_si (b->ts.u.cl->length->value.integer);
-   else if (b->expr_type == EXPR_CONSTANT
-           && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL))
-     len_b = b->value.character.length;
-   else
-     return SUCCESS;
+   len_a = gfc_var_strlen(a);
+   len_b = gfc_var_strlen(b);
 
-   if (len_a == len_b)
+   if (len_a == -1 || len_b == -1 || len_a == len_b)
      return SUCCESS;
-
-   gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
-             len_a, len_b, name, &a->where);
-   return FAILURE;
+   else
+     {
+       gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+                 len_a, len_b, name, &a->where);
+       return FAILURE;
+     }
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f695502..bd527d7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-12-24  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/31821
+       * gfortran.dg/char_pointer_assign_6.f90:  New test.
+
 2010-12-22  Sebastian Pop  <sebastian.pop@amd.com>
 
        PR tree-optimization/46758

diff --git a/gcc/testsuite/gfortran.dg/char_pointer_assign_6.f90 b/gcc/testsuite/gfortran.dg/char_pointer_assign_6.f90
new file mode 100644 (file)
index 0000000..cd90bfc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_pointer_assign_6.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! PR 31821
+program main
+  character (len=4), pointer:: s1
+  character (len=20), pointer :: p1
+  character (len=4) :: c
+  s1 = 'abcd'
+  p1 => s1(2:3) ! { dg-error "Unequal character lengths \\(20/2\\)" }
+  p1 => c(1:) ! { dg-error "Unequal character lengths \\(20/4\\)" }
+  p1 => c(:4) ! { dg-error "Unequal character lengths \\(20/4\\)" }
+end