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.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 99a09ba..ef53e23 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/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
 2009-04-11  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/39692

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7570f8d..48853e4 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/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;
   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;
 }
 
   int resolved;
 }

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 6ced5bc..5fe658e 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/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)
 {
 static tree
 gfc_create_string_length (gfc_symbol * sym)
 {

-  tree length;
-

   gcc_assert (sym->ts.cl);
   gfc_conv_const_charlen (sym->ts.cl);
   gcc_assert (sym->ts.cl);
   gfc_conv_const_charlen (sym->ts.cl);

-  
+

   if (sym->ts.cl->backend_decl == NULL_TREE)
     {
   if (sym->ts.cl->backend_decl == NULL_TREE)
     {

+      tree length;

       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 
       /* Also prefix the mangled name.  */
       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);
       TREE_USED (length) = 1;
       if (sym->ns->proc_name->tlink != NULL)
        gfc_defer_symbol_init (sym);

+

       sym->ts.cl->backend_decl = length;
     }
 
       sym->ts.cl->backend_decl = length;
     }
 

+  gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);

   return sym->ts.cl->backend_decl;
 }
 
   return sym->ts.cl->backend_decl;
 }
 


@@ -1646,7 +1647,8 @@ create_function_arglist (gfc_symbol * sym)
          TREE_READONLY (length) = 1;
          gfc_finish_decl (length);
 
          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)
 
          /* 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
 /* Generate code for a function.  */
 
 void


@@ -3920,6 +4002,12 @@ gfc_generate_function_code (gfc_namespace * ns)
       gfc_add_expr_to_block (&body, tmp);
     }
 
       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);
 
   tmp = gfc_trans_code (ns->code);
   gfc_add_expr_to_block (&body, tmp);
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4acc4b9..28fa637 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/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
 2009-04-11  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/39692

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_1.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_1.f90
new file mode 100644 (file)
index 0000000..4467302
--- /dev/null
+++ b/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\\)" }

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_2.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_2.f90
new file mode 100644 (file)
index 0000000..7ecce2a
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_3.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_3.f90
new file mode 100644 (file)
index 0000000..69be088
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_4.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_4.f90
new file mode 100644 (file)
index 0000000..db8ce3c
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_5.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_5.f90
new file mode 100644 (file)
index 0000000..36fda72
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_6.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_6.f90
new file mode 100644 (file)
index 0000000..550cca8
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90
new file mode 100644 (file)
index 0000000..9f08ba1
--- /dev/null
+++ b/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" } }

diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90
index 9b18177..76f0aae 100644 (file)
--- a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90
+++ b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_index.f90
@@ -8,7 +8,7 @@ program test
 end
 
 function w(str)
 end
 
 function w(str)

-  character(len=8) str
+  character(len=7) str

   integer w
   w = index(str, "R")
 end
   integer w
   w = index(str, "R")
 end

diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90
index 90e4131..d57610c 100644 (file)
--- a/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_trim.f90
+++ b/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    '
   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)
   if (llt(b,"1234")) call abort()
   a='     '
   b=trim(a)