Patchwork [fortran] PR 31821 - substring checking on pointer assignment

login
register
mail settings
Submitter Thomas Koenig
Date Dec. 23, 2010, 8:33 a.m.
Message ID <1293093225.6414.3.camel@linux-fd1f.site>
Download mbox | patch
Permalink /patch/76481/
State New
Headers show

Comments

Thomas Koenig - Dec. 23, 2010, 8:33 a.m.
Hello world,

the following patch checks substring lengths for pointer assignments
during compile time.  Regression-tested.

OK for trunk?

Merry christmas and a happy new year, everybody!

	Thomas

2010-12-23  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  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/31821
	* gfortran.dg/char_pointer_assign_6.f90:  New test.
Mikael Morin - Dec. 23, 2010, 4:29 p.m.
On Thursday 23 December 2010 09:33:45 Thomas Koenig wrote:
> Hello world,
> 
> the following patch checks substring lengths for pointer assignments
> during compile time.  Regression-tested.
> 
> OK for trunk?
OK, thanks.

> 
> Merry christmas and a happy new year, everybody!
Same to you (and everybody else).

Mikael
Thomas Koenig - Dec. 24, 2010, 8:42 a.m.
Hi Mikael,

> On Thursday 23 December 2010 09:33:45 Thomas Koenig wrote:
> > Hello world,
> > 
> > the following patch checks substring lengths for pointer assignments
> > during compile time.  Regression-tested.
> > 
> > OK for trunk?
> OK, thanks.

Sending        fortran/ChangeLog
Sending        fortran/check.c
Sending        testsuite/ChangeLog
Adding         testsuite/gfortran.dg/char_pointer_assign_6.f90
Transmitting file data ....
Committed revision 168224.

Thanks for the review!

	Thomas

Patch

Index: check.c
===================================================================
--- check.c	(Revision 167770)
+++ check.c	(Arbeitskopie)
@@ -635,40 +635,69 @@ 
   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
+   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;
-
-   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;
+     }
 }