https://gcc.gnu.org/g:386f6d98ba0d438d65da1ad5b203f7b2743fc6da
commit r15-5414-g386f6d98ba0d438d65da1ad5b203f7b2743fc6da
Author: Harald Anlauf <anl...@gmx.de>
Date: Sun Nov 17 23:04:58 2024 +0100
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:
---
gcc/fortran/dependency.cc | 2 +-
gcc/fortran/interface.cc | 27 +++++++++++++++++++---
gcc/fortran/trans-stmt.cc | 11 +++++++++
gcc/testsuite/gfortran.dg/auto_char_len_4.f90 | 25 ++++++++++++++------
.../gfortran.dg/bounds_check_strlen_10.f90 | 21 +++++++++++++++++
gcc/testsuite/gfortran.dg/typebound_override_1.f90 | 4 ++--
6 files changed, 77 insertions(+), 13 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index 2d3db9541bba..1fd65bbadca6 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 61c506bfdb5d..176c7d4a8ed4 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 520ab505659f..a409c25b8991 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 16789fafcc70..74a50c388440 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 000000000000..accc3faebe82
--- /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 7eb685615f46..393f634f157f 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
