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.

6 files changed, 77 insertions, 13 deletions

diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index 2d3db95..1fd65bb 100644
--- 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 61c506bf..176c7d4 100644
--- 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 520ab50..a409c25 100644
--- 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 16789fa..74a50c3 100644
--- 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
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 7eb6856..393f634 100644
--- 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