Fortran: add bounds-checking for ALLOCATE of CHARACTER with type-spec [PR53357]

Fix a rejects-(potentially)-valid code for ALLOCATE of CHARACTER with
type-spec, and implement a string-length check for -fcheck=bounds.
Implement more detailed errors or warnings when character function
declarations and references do not match.

	PR fortran/53357

gcc/fortran/ChangeLog:

	* dependency.cc (gfc_dep_compare_expr): Return correct result if
	relationship of expressions could not be determined.
	* interface.cc (gfc_check_result_characteristics): Implement error
	messages if character function declations and references do not
	agree, else emit warning in cases where a mismatch is suspected.
	* trans-stmt.cc (gfc_trans_allocate): Implement a string length
	check for -fcheck=bounds.

gcc/testsuite/ChangeLog:

	* gfortran.dg/auto_char_len_4.f90: Adjust patterns.
	* gfortran.dg/typebound_override_1.f90: Likewise.
	* gfortran.dg/bounds_check_strlen_10.f90: New test.

diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index 2d3db9541bba8fff65d64fdbe7ffbedbd7e54d21..1fd65bbadca6105ea1af869f0f447b2035f4ce65 100644 (file)
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -474,7 +474,7 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
   }
 
   if (e1->expr_type != e2->expr_type)
-    return -3;
+    return -2;
 
   switch (e1->expr_type)
     {

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 61c506bfdb5dbdc4dcf7f5aa8bf5872fe9d25749..176c7d4a8ed413ba90147fef81f330ffc98ece28 100644 (file)
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -1692,9 +1692,30 @@ gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
              return false;
 
            case -2:
-             /* FIXME: Implement a warning for this case.
-             snprintf (errmsg, err_len, "Possible character length mismatch "
-                       "in function result");*/
+             if (r1->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+               {
+                 snprintf (errmsg, err_len,
+                           "Function declared with a non-constant character "
+                           "length referenced with a constant length");
+                 return false;
+               }
+             else if (r2->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+               {
+                 snprintf (errmsg, err_len,
+                           "Function declared with a constant character "
+                           "length referenced with a non-constant length");
+                 return false;
+               }
+             /* Warn if length expression types are different, except for
+                 possibly false positives where complex expressions might have
+                 been used.  */
+             else if ((r1->ts.u.cl->length->expr_type
+                       != r2->ts.u.cl->length->expr_type)
+                      && (r1->ts.u.cl->length->expr_type != EXPR_OP
+                          || r2->ts.u.cl->length->expr_type != EXPR_OP))
+               gfc_warning (0, "Possible character length mismatch in "
+                            "function result between %L and %L",
+                            &r1->declared_at, &r2->declared_at);
              break;
 
            case 0:

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 520ab505659f65dd0aecd4de30e66957578b7270..a409c25b8991bd5b3d483cb4d79d2995e1f39e6a 100644 (file)
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6393,6 +6393,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
   gfc_symtree *newsym = NULL;
   symbol_attribute caf_attr;
   gfc_actual_arglist *param_list;
+  tree ts_string_length = NULL_TREE;
 
   if (!code->ext.alloc.list)
     return NULL_TREE;
@@ -6741,6 +6742,7 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
          gfc_init_se (&se_sz, NULL);
          gfc_conv_expr (&se_sz, sz);
          gfc_free_expr (sz);
+         ts_string_length = fold_convert (gfc_charlen_type_node, se_sz.expr);
          tmp = gfc_get_char_type (code->ext.alloc.ts.kind);
          tmp = TYPE_SIZE_UNIT (tmp);
          tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
@@ -6951,6 +6953,15 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
       else
        tmp = expr3_esize;
 
+      /* Create runtime check for ALLOCATE of character with type-spec.  */
+      if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred
+         && ts_string_length
+         && se.string_length)
+       gfc_trans_same_strlen_check ("ALLOCATE with type-spec",
+                                    &al->expr->where,
+                                    ts_string_length, se.string_length,
+                                    &block);
+
       gfc_omp_namelist *omp_alloc_item = NULL;
       if (omp_allocate)
        {

diff --git a/gcc/testsuite/gfortran.dg/auto_char_len_4.f90 b/gcc/testsuite/gfortran.dg/auto_char_len_4.f90
index 16789fafcc70ca914534e458e5612ac9537a31a0..74a50c38844008869381ee7f18a73af2a7d1c2ac 100644 (file)
--- a/gcc/testsuite/gfortran.dg/auto_char_len_4.f90
+++ b/gcc/testsuite/gfortran.dg/auto_char_len_4.f90
@@ -13,26 +13,37 @@ FUNCTION a()
 END FUNCTION a
 
 SUBROUTINE s(n)
-  CHARACTER(LEN=n), EXTERNAL :: a  ! { dg-error "Character length mismatch" }
-  CHARACTER(LEN=n), EXTERNAL :: d  ! { dg-error "Character length mismatch" }
+  CHARACTER(LEN=n), EXTERNAL :: a  ! { dg-error "declared with a constant character length" }
+  CHARACTER(LEN=n), EXTERNAL :: d  ! { dg-error "declared with a constant character length" }
   interface
     function b (m)                ! This is OK
-      CHARACTER(LEN=m) :: b
       integer :: m
+      CHARACTER(LEN=m) :: b
     end function b
+    function e (m)              ! { dg-warning "Possible character length mismatch" }
+      integer :: m
+      CHARACTER(LEN=m) :: e
+    end function e
   end interface
   write(6,*) a()
   write(6,*) b(n)
   write(6,*) c()
   write(6,*) d()
+  write(6,*) e(n)
 contains
-    function c ()                ! This is OK
-      CHARACTER(LEN=n):: c
-      c = ""
-    end function c
+  function c ()                ! This is OK
+    CHARACTER(LEN=n):: c
+    c = ""
+  end function c
 END SUBROUTINE s
 
 FUNCTION d()
   CHARACTER(len=99) :: d
   d = ''
 END FUNCTION d
+
+function e(k)                   ! { dg-warning "Possible character length mismatch" }
+  integer :: k
+  character(len=k+1-1) :: e
+  e = ''
+end function e

diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_10.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_10.f90
new file mode 100644 (file)
index 0000000..accc3fa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_strlen_10.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-additional-options "-fcheck=bounds -fdump-tree-optimized" }
+!
+! PR fortran/53357 - bounds-check for character type-spec in ALLOCATE
+
+program pr53357
+  implicit none
+  integer :: i, j
+  i = 3
+  j = 5
+  block
+    character(len=i), allocatable :: str1
+    character(len=j), allocatable :: str2
+    allocate (character(len=3) :: &
+         str1, & ! runtime check optimized away
+         str2  ) ! runtime check kept
+  end block
+end
+
+! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "At line 16 of file" 1 "optimized" } }

diff --git a/gcc/testsuite/gfortran.dg/typebound_override_1.f90 b/gcc/testsuite/gfortran.dg/typebound_override_1.f90
index 7eb685615f46ba631b7d2820541383422e29446d..393f634f157f352f18db720cef7b579e97ccbd72 100644 (file)
--- a/gcc/testsuite/gfortran.dg/typebound_override_1.f90
+++ b/gcc/testsuite/gfortran.dg/typebound_override_1.f90
@@ -21,9 +21,9 @@ module m
    contains
      procedure, nopass :: a => a2  ! { dg-error "Character length mismatch in function result" }
      procedure, nopass :: b => b2  ! { dg-error "Rank mismatch in function result" }
-     procedure, nopass :: c => c2  ! FIXME: dg-warning "Possible character length mismatch" 
+     procedure, nopass :: c => c2  ! FIXME: dg-warning "Possible character length mismatch"
      procedure, nopass :: d => d2  ! valid, check for commutativity (+,*)
-     procedure, nopass :: e => e2  ! { dg-error "Character length mismatch in function result" }
+     procedure, nopass :: e => e2  ! { dg-error "declared with a constant character length" }
   end type
 
 contains