re PR fortran/31821 (character pointer => target(range) should detect if lengths don't match)

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.

From-SVN: r168224

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

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;
+   len_a = gfc_var_strlen(a);
+   len_b = gfc_var_strlen(b);
+
+   if (len_a == -1 || len_b == -1 || len_a == len_b)
+     return SUCCESS;
    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;
-
-   if (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;
+     {
+       gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
+		  len_a, len_b, name, &a->where);
+       return FAILURE;
+     }
 }
 
 

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

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