re PR fortran/37746 (bounds check of string dummy arguments)

2009-04-11  Daniel Kraft  <d@domob.eu>

	PR fortran/37746
	* gfortran.h (struct gfc_charlen): New field `passed_length' to store
	the actual passed string length for dummy arguments.
	* trans-decl.c (gfc_create_string_length): Formatting fixes and added
	assertion, moved a local variable into the innermost block it is needed.
	(create_function_arglist): Removed TODO about the check being
	implemented and initialize cl->passed_length here.
	(add_argument_checking): New method.
	(gfc_generate_function_code): Call the argument checking method.

2009-04-11  Daniel Kraft  <d@domob.eu>

	PR fortran/37746
	* gfortran.dg/bounds_check_strlen_1.f90: New test.
	* gfortran.dg/bounds_check_strlen_2.f90: New test.
	* gfortran.dg/bounds_check_strlen_3.f90: New test.
	* gfortran.dg/bounds_check_strlen_4.f90: New test.
	* gfortran.dg/bounds_check_strlen_5.f90: New test.
	* gfortran.dg/bounds_check_strlen_6.f90: New test.
	* gfortran.dg/bounds_check_strlen_7.f90: New test.
	* gfortran.fortran-torture/execute/intrinsic_index.f90: Fix wrong
	expected string length that failed with -fbounds-check now.
	* gfortran.fortran-torture/execute/intrinsic_trim.f90: Ditto.

From-SVN: r145958

gcc/fortran/ChangeLog

@@ -1,3 +1,15 @@
+2009-04-11  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37746
+	* gfortran.h (struct gfc_charlen): New field `passed_length' to store
+	the actual passed string length for dummy arguments.
+	* trans-decl.c (gfc_create_string_length): Formatting fixes and added
+	assertion, moved a local variable into the innermost block it is needed.
+	(create_function_arglist): Removed TODO about the check being
+	implemented and initialize cl->passed_length here.
+	(add_argument_checking): New method.
+	(gfc_generate_function_code): Call the argument checking method.
+
 2009-04-11  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/39692

gcc/fortran/gfortran.h

@@ -794,6 +794,7 @@ typedef struct gfc_charlen
   struct gfc_charlen *next;
   bool length_from_typespec; /* Length from explicit array ctor typespec?  */
   tree backend_decl;
+  tree passed_length; /* Length argument explicitelly passed.  */
 
   int resolved;
 }

gcc/fortran/trans-decl.c

@@ -877,13 +877,12 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 static tree
 gfc_create_string_length (gfc_symbol * sym)
 {
-  tree length;
-
   gcc_assert (sym->ts.cl);
   gfc_conv_const_charlen (sym->ts.cl);
-  
+
   if (sym->ts.cl->backend_decl == NULL_TREE)
     {
+      tree length;
       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 
       /* Also prefix the mangled name.  */
@@ -895,9 +894,11 @@ gfc_create_string_length (gfc_symbol * sym)
       TREE_USED (length) = 1;
       if (sym->ns->proc_name->tlink != NULL)
 	gfc_defer_symbol_init (sym);
+
       sym->ts.cl->backend_decl = length;
     }
 
+  gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
   return sym->ts.cl->backend_decl;
 }
 
@@ -1646,7 +1647,8 @@ create_function_arglist (gfc_symbol * sym)
 	  TREE_READONLY (length) = 1;
 	  gfc_finish_decl (length);
 
-	  /* TODO: Check string lengths when -fbounds-check.  */
+	  /* Remember the passed value.  */
+	  f->sym->ts.cl->passed_length = length;
 
 	  /* Use the passed value for assumed length variables.  */
 	  if (!f->sym->ts.cl->length)
@@ -3704,6 +3706,86 @@ gfc_trans_entry_master_switch (gfc_entry_list * el)
 }
 
 
+/* Add code to string lengths of actual arguments passed to a function against
+   the expected lengths of the dummy arguments.  */
+
+static void
+add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
+{
+  gfc_formal_arglist *formal;
+
+  for (formal = sym->formal; formal; formal = formal->next)
+    if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
+      {
+	enum tree_code comparison;
+	tree cond;
+	tree argname;
+	gfc_symbol *fsym;
+	gfc_charlen *cl;
+	const char *message;
+
+	fsym = formal->sym;
+	cl = fsym->ts.cl;
+
+	gcc_assert (cl);
+	gcc_assert (cl->passed_length != NULL_TREE);
+	gcc_assert (cl->backend_decl != NULL_TREE);
+
+	/* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
+	   string lengths must match exactly.  Otherwise, it is only required
+	   that the actual string length is *at least* the expected one.  */
+	if (fsym->attr.pointer || fsym->attr.allocatable
+	    || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+	  {
+	    comparison = NE_EXPR;
+	    message = _("Actual string length does not match the declared one"
+			" for dummy argument '%s' (%ld/%ld)");
+	  }
+	else
+	  {
+	    comparison = LT_EXPR;
+	    message = _("Actual string length is shorter than the declared one"
+			" for dummy argument '%s' (%ld/%ld)");
+	  }
+
+	/* Build the condition.  For optional arguments, an actual length
+	   of 0 is also acceptable if the associated string is NULL, which
+	   means the argument was not passed.  */
+	cond = fold_build2 (comparison, boolean_type_node,
+			    cl->passed_length, cl->backend_decl);
+	if (fsym->attr.optional)
+	  {
+	    tree not_absent;
+	    tree not_0length;
+	    tree absent_failed;
+
+	    not_0length = fold_build2 (NE_EXPR, boolean_type_node,
+				       cl->passed_length,
+				       fold_convert (gfc_charlen_type_node,
+						     integer_zero_node));
+	    not_absent = fold_build2 (NE_EXPR, boolean_type_node,
+				      fsym->backend_decl, null_pointer_node);
+
+	    absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
+					 not_0length, not_absent);
+
+	    cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+				cond, absent_failed);
+	  }
+
+	/* Build the runtime check.  */
+	argname = gfc_build_cstring_const (fsym->name);
+	argname = gfc_build_addr_expr (pchar_type_node, argname);
+	gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
+				 message, argname,
+				 fold_convert (long_integer_type_node,
+					       cl->passed_length),
+				 fold_convert (long_integer_type_node,
+					       cl->backend_decl));
+      }
+}
+
+
 /* Generate code for a function.  */
 
 void
@@ -3920,6 +4002,12 @@ gfc_generate_function_code (gfc_namespace * ns)
       gfc_add_expr_to_block (&body, tmp);
     }
 
+  /* If bounds-checking is enabled, generate code to check passed in actual
+     arguments against the expected dummy argument attributes (e.g. string
+     lengths).  */
+  if (flag_bounds_check)
+    add_argument_checking (&body, sym);
+
   tmp = gfc_trans_code (ns->code);
   gfc_add_expr_to_block (&body, tmp);
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,17 @@
+2009-04-11  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/37746
+	* gfortran.dg/bounds_check_strlen_1.f90: New test.
+	* gfortran.dg/bounds_check_strlen_2.f90: New test.
+	* gfortran.dg/bounds_check_strlen_3.f90: New test.
+	* gfortran.dg/bounds_check_strlen_4.f90: New test.
+	* gfortran.dg/bounds_check_strlen_5.f90: New test.
+	* gfortran.dg/bounds_check_strlen_6.f90: New test.
+	* gfortran.dg/bounds_check_strlen_7.f90: New test.
+	* gfortran.fortran-torture/execute/intrinsic_index.f90: Fix wrong
+	expected string length that failed with -fbounds-check now.
+	* gfortran.fortran-torture/execute/intrinsic_trim.f90: Ditto.
+
 2009-04-11  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/39692

gcc/testsuite/gfortran.dg/bounds_check_strlen_1.f90

@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Character length mismatch" }
+
+! PR fortran/37746
+! Test bounds-checking for string length of dummy arguments.
+
+SUBROUTINE test (str)
+  IMPLICIT NONE
+  CHARACTER(len=5) :: str
+END SUBROUTINE test
+
+PROGRAM main
+  IMPLICIT NONE
+  CALL test ('abc') ! String is too short.
+END PROGRAM main
+
+! { dg-output "shorter than the declared one for dummy argument 'str' \\(3/5\\)" }

gcc/testsuite/gfortran.dg/bounds_check_strlen_2.f90

@@ -0,0 +1,33 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Character length mismatch" }
+
+! PR fortran/37746
+! Test bounds-checking for string length of dummy arguments.
+
+MODULE m
+
+CONTAINS
+
+  SUBROUTINE test (str, n)
+    IMPLICIT NONE
+    CHARACTER(len=n) :: str
+    INTEGER :: n
+  END SUBROUTINE test
+
+  SUBROUTINE test2 (str)
+    IMPLICIT NONE
+    CHARACTER(len=*) :: str
+    CALL test (str, 5) ! Expected length of str is 5.
+  END SUBROUTINE test2
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+  CALL test2 ('abc') ! String is too short.
+END PROGRAM main
+
+! { dg-output "shorter than the declared one for dummy argument 'str' \\(3/5\\)" }
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/bounds_check_strlen_3.f90

@@ -0,0 +1,33 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Character length mismatch" }
+
+! PR fortran/37746
+! Test bounds-checking for string length of dummy arguments.
+
+MODULE m
+
+CONTAINS
+
+  SUBROUTINE test (str)
+    IMPLICIT NONE
+    CHARACTER(len=5), POINTER :: str
+  END SUBROUTINE test
+
+  SUBROUTINE test2 (n)
+    IMPLICIT NONE
+    INTEGER :: n
+    CHARACTER(len=n), POINTER :: str
+    CALL test (str)
+  END SUBROUTINE test2
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+  CALL test2 (7) ! Too long.
+END PROGRAM main
+
+! { dg-output "does not match the declared one for dummy argument 'str' \\(7/5\\)" }
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/bounds_check_strlen_4.f90

@@ -0,0 +1,33 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Character length mismatch" }
+
+! PR fortran/37746
+! Test bounds-checking for string length of dummy arguments.
+
+MODULE m
+
+CONTAINS
+
+  SUBROUTINE test (str)
+    IMPLICIT NONE
+    CHARACTER(len=5), ALLOCATABLE :: str(:)
+  END SUBROUTINE test
+
+  SUBROUTINE test2 (n)
+    IMPLICIT NONE
+    INTEGER :: n
+    CHARACTER(len=n), ALLOCATABLE :: str(:)
+    CALL test (str)
+  END SUBROUTINE test2
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+  CALL test2 (7) ! Too long.
+END PROGRAM main
+
+! { dg-output "does not match the declared one for dummy argument 'str' \\(7/5\\)" }
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/bounds_check_strlen_5.f90

@@ -0,0 +1,33 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Character length mismatch" }
+
+! PR fortran/37746
+! Test bounds-checking for string length of dummy arguments.
+
+MODULE m
+
+CONTAINS
+
+  SUBROUTINE test (str)
+    IMPLICIT NONE
+    CHARACTER(len=5) :: str(:) ! Assumed shape.
+  END SUBROUTINE test
+
+  SUBROUTINE test2 (n)
+    IMPLICIT NONE
+    INTEGER :: n
+    CHARACTER(len=n) :: str(2)
+    CALL test (str)
+  END SUBROUTINE test2
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+  CALL test2 (7) ! Too long.
+END PROGRAM main
+
+! { dg-output "does not match the declared one for dummy argument 'str' \\(7/5\\)" }
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/bounds_check_strlen_6.f90

@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+
+! PR fortran/37746
+! Ensure that too long or matching string lengths don't trigger the runtime
+! error for matching string lengths, if the dummy argument is neither
+! POINTER nor ALLOCATABLE or assumed-shape.
+! Also check that absent OPTIONAL arguments don't trigger the check.
+
+MODULE m
+CONTAINS
+
+  SUBROUTINE test (str, opt)
+    IMPLICIT NONE
+    CHARACTER(len=5) :: str
+    CHARACTER(len=5), OPTIONAL :: opt
+  END SUBROUTINE test
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+  CALL test ('abcde')  ! String length matches.
+  CALL test ('abcdef') ! String too long, is ok.
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90

@@ -0,0 +1,25 @@
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+! { dg-shouldfail "Character length mismatch" }
+
+! PR fortran/37746
+! Test bounds-checking for string length of dummy arguments.
+
+MODULE m
+CONTAINS
+
+  SUBROUTINE test (opt)
+    IMPLICIT NONE
+    CHARACTER(len=5), OPTIONAL :: opt
+  END SUBROUTINE test
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+  CALL test ('') ! 0 length, but not absent argument.
+END PROGRAM main
+
+! { dg-output "shorter than the declared one for dummy argument 'opt' \\(0/5\\)" }
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90

@@ -8,7 +8,7 @@ program test
 end
 
 function w(str)
-  character(len=8) str
+  character(len=7) str
   integer w
   w = index(str, "R")
 end

gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90

@@ -3,7 +3,7 @@ program intrinsic_trim
   character(len=8) a
   character(len=4) b,work
   a='1234    '
-  b=work(9,a)
+  b=work(8,a)
   if (llt(b,"1234")) call abort()
   a='     '
   b=trim(a)