re PR fortran/31822 (Missing run-time bound checks for character pointer => target)

2008-12-18  Daniel Kraft  <d@domob.eu>

	PR fortran/31822
	* gfortran.h (gfc_check_same_strlen): Made public.
	* trans.h (gfc_trans_same_strlen_check): Made public.
	* check.c (gfc_check_same_strlen): Made public and adapted error
	message output to be useful not only for intrinsics.
	(gfc_check_merge): Adapt to gfc_check_same_strlen change.
	* expr.c (gfc_check_pointer_assign): Use gfc_check_same_strlen for
	string length compile-time check.
	* trans-expr.c (gfc_trans_pointer_assignment): Add runtime-check for
	equal string lengths using gfc_trans_same_strlen_check.
	* trans-intrinsic.c (gfc_trans_same_strlen_check): Renamed and made
	public from conv_same_strlen_check.
	(gfc_conv_intrinsic_merge): Adapted accordingly.

2008-12-18  Daniel Kraft  <d@domob.eu>

	PR fortran/31822
	* gfortran.dg/char_pointer_assign_2.f90: Updated expected error message
	to be more detailed.
	* gfortran.dg/char_pointer_assign_4.f90: New test.
	* gfortran.dg/char_pointer_assign_5.f90: New test.

From-SVN: r142808

gcc/fortran/ChangeLog

@@ -1,3 +1,19 @@
+2008-12-18  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/31822
+	* gfortran.h (gfc_check_same_strlen): Made public.
+	* trans.h (gfc_trans_same_strlen_check): Made public.
+	* check.c (gfc_check_same_strlen): Made public and adapted error
+	message output to be useful not only for intrinsics.
+	(gfc_check_merge): Adapt to gfc_check_same_strlen change.
+	* expr.c (gfc_check_pointer_assign): Use gfc_check_same_strlen for
+	string length compile-time check.
+	* trans-expr.c (gfc_trans_pointer_assignment): Add runtime-check for
+	equal string lengths using gfc_trans_same_strlen_check.
+	* trans-intrinsic.c (gfc_trans_same_strlen_check): Renamed and made
+	public from conv_same_strlen_check.
+	(gfc_conv_intrinsic_merge): Adapted accordingly.
+
 2008-12-17  Daniel Kraft  <d@domob.eu>
 
 	PR fortran/38137

gcc/fortran/check.c

@@ -396,8 +396,8 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 /* Check whether two character expressions have the same length;
    returns SUCCESS if they have or if the length cannot be determined.  */
 
-static gfc_try
+gfc_try
-check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
+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;
@@ -423,8 +423,8 @@ check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name)
    if (len_a == len_b)
      return SUCCESS;
 
-   gfc_error ("Unequal character lengths (%ld and %ld) in %s intrinsic "
+   gfc_error ("Unequal character lengths (%ld/%ld) in %s at %L",
-	      "at %L", len_a, len_b, name, &a->where);
+	      len_a, len_b, name, &a->where);
    return FAILURE;
 }
 
@@ -2011,7 +2011,7 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
     return FAILURE;
 
   if (tsource->ts.type == BT_CHARACTER)
-    return check_same_strlen (tsource, fsource, "MERGE");
+    return gfc_check_same_strlen (tsource, fsource, "MERGE intrinsic");
 
   return SUCCESS;
 }

gcc/fortran/expr.c

@@ -3179,15 +3179,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   if (rvalue->expr_type == EXPR_NULL)
     return SUCCESS;
 
-  if (lvalue->ts.type == BT_CHARACTER
+  if (lvalue->ts.type == BT_CHARACTER)
-      && lvalue->ts.cl && rvalue->ts.cl
-      && lvalue->ts.cl->length && rvalue->ts.cl->length
-      && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
-				    rvalue->ts.cl->length)) == 1)
     {
-      gfc_error ("Different character lengths in pointer "
+      gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
-		 "assignment at %L", &lvalue->where);
+      if (t == FAILURE)
-      return FAILURE;
+	return FAILURE;
     }
 
   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))

gcc/fortran/gfortran.h

@@ -2580,4 +2580,7 @@ void gfc_global_used (gfc_gsymbol *, locus *);
 /* dependency.c */
 int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
 
+/* check.c */
+gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
+
 #endif /* GCC_GFORTRAN_H  */

gcc/fortran/trans-expr.c

@@ -4016,7 +4016,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
   tree tmp;
   tree decl;
 
-
   gfc_start_block (&block);
 
   gfc_init_se (&lse, NULL);
@@ -4039,15 +4038,32 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
+
+      /* Check character lengths if character expression.  The test is only
+	 really added if -fbounds-check is enabled.  */
+      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+	{
+	  gcc_assert (expr2->ts.type == BT_CHARACTER);
+	  gcc_assert (lse.string_length && rse.string_length);
+	  gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+				       lse.string_length, rse.string_length,
+				       &block);
+	}
+
       gfc_add_modify (&block, lse.expr,
 			   fold_convert (TREE_TYPE (lse.expr), rse.expr));
+
       gfc_add_block_to_block (&block, &rse.post);
       gfc_add_block_to_block (&block, &lse.post);
     }
   else
     {
+      tree strlen_lhs;
+      tree strlen_rhs = NULL_TREE;
+
       /* Array pointer.  */
       gfc_conv_expr_descriptor (&lse, expr1, lss);
+      strlen_lhs = lse.string_length;
       switch (expr2->expr_type)
 	{
 	case EXPR_NULL:
@@ -4057,8 +4073,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 
 	case EXPR_VARIABLE:
 	  /* Assign directly to the pointer's descriptor.  */
-          lse.direct_byref = 1;
+	  lse.direct_byref = 1;
 	  gfc_conv_expr_descriptor (&lse, expr2, rss);
+	  strlen_rhs = lse.string_length;
 
 	  /* If this is a subreference array pointer assignment, use the rhs
 	     descriptor element size for the lhs span.  */
@@ -4071,7 +4088,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	      tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
 	      tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
 	      if (!INTEGER_CST_P (tmp))
-	        gfc_add_block_to_block (&lse.post, &rse.pre);
+		gfc_add_block_to_block (&lse.post, &rse.pre);
 	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
 	    }
 
@@ -4086,10 +4103,23 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  lse.expr = tmp;
 	  lse.direct_byref = 1;
 	  gfc_conv_expr_descriptor (&lse, expr2, rss);
+	  strlen_rhs = lse.string_length;
 	  gfc_add_modify (&lse.pre, desc, tmp);
 	  break;
-        }
+	}
+
       gfc_add_block_to_block (&block, &lse.pre);
+
+      /* Check string lengths if applicable.  The check is only really added
+	 to the output code if -fbounds-check is enabled.  */
+      if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+	{
+	  gcc_assert (expr2->ts.type == BT_CHARACTER);
+	  gcc_assert (strlen_lhs && strlen_rhs);
+	  gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+				       strlen_lhs, strlen_rhs, &block);
+	}
+
       gfc_add_block_to_block (&block, &lse.post);
     }
   return gfc_finish_block (&block);

gcc/fortran/trans-intrinsic.c

@@ -751,9 +751,9 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
    string lengths for both expressions are the same (needed for e.g. MERGE).
    If bounds-checking is not enabled, does nothing.  */
 
-static void
+void
-conv_same_strlen_check (const char* intr_name, locus* where, tree a, tree b,
+gfc_trans_same_strlen_check (const char* intr_name, locus* where,
-			stmtblock_t* target)
+			     tree a, tree b, stmtblock_t* target)
 {
   tree cond;
   tree name;
@@ -769,8 +769,7 @@ conv_same_strlen_check (const char* intr_name, locus* where, tree a, tree b,
   name = gfc_build_cstring_const (intr_name);
   name = gfc_build_addr_expr (pchar_type_node, name);
   gfc_trans_runtime_check (true, false, cond, target, where,
-			   "Unequal character lengths (%ld/%ld) for arguments"
+			   "Unequal character lengths (%ld/%ld) in %s",
-			   " to %s",
 			   fold_convert (long_integer_type_node, a),
 			   fold_convert (long_integer_type_node, b), name);
 }
@@ -3081,8 +3080,8 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
       fsource = args[3];
       mask = args[4];
 
-      conv_same_strlen_check ("MERGE", &expr->where, len, len2, &se->post);
+      gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
-
+				   &se->pre);
       se->string_length = len;
     }
   type = TREE_TYPE (tsource);

gcc/fortran/trans.h

@@ -458,6 +458,10 @@ tree gfc_trans_runtime_error_vararg (bool, locus*, const char*, va_list);
 void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *,
 			      const char *, ...);
 
+/* Generate a runtime check for same string length.  */
+void gfc_trans_same_strlen_check (const char*, locus*, tree, tree,
+				  stmtblock_t*);
+
 /* Generate a call to free() after checking that its arg is non-NULL.  */
 tree gfc_call_free (tree);
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,11 @@
+2008-12-18  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/31822
+	* gfortran.dg/char_pointer_assign_2.f90: Updated expected error message
+	to be more detailed.
+	* gfortran.dg/char_pointer_assign_4.f90: New test.
+	* gfortran.dg/char_pointer_assign_5.f90: New test.
+
 2008-12-18  Jakub Jelinek  <jakub@redhat.com>
 
 	PR middle-end/38533

gcc/testsuite/gfortran.dg/char_pointer_assign_2.f90

@@ -6,6 +6,6 @@
   character(5), pointer :: ch3(:)
 
   ch2 => ch1  ! Check correct is OK
-  ch3 => ch1  ! { dg-error "Different character lengths" }
+  ch3 => ch1  ! { dg-error "Unequal character lengths \\(5/4\\)" }
 
-end
+end

gcc/testsuite/gfortran.dg/char_pointer_assign_4.f90

@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Unequal character length" }
+
+! PR fortran/31822
+! Verify that runtime checks for matching character length
+! in pointer assignment work.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program ptr
+  implicit none
+  character(len=10), target :: s1
+  character(len=5), pointer :: p1
+  integer, volatile :: i
+  i = 8
+  p1 => s1(1:i) 
+end program ptr
+
+! { dg-output "Unequal character lengths \\(5/8\\)" }

gcc/testsuite/gfortran.dg/char_pointer_assign_5.f90

@@ -0,0 +1,23 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Unequal character length" }
+
+! PR fortran/31822
+! Verify that runtime checks for matching character length
+! in pointer assignment work.
+
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program ptr
+  implicit none
+  character(len=10), target :: s1
+  call bar((/ s1, s1 /))
+contains
+  subroutine bar(s)
+    character(len=*),target  :: s(2)
+    character(len=17),pointer :: p(:)
+    p => s
+  end subroutine bar
+end program ptr
+
+! { dg-output "Unequal character lengths \\(17/10\\)" }