https://gcc.gnu.org/g:47bb24546297ef6812d69bc800ec005fc7e567e9
commit r17-988-g47bb24546297ef6812d69bc800ec005fc7e567e9 Author: Harald Anlauf <[email protected]> Date: Thu May 28 22:49:26 2026 +0200 Fortran: checking of passed character length [PR125393] Commit r16-3462 enhanced checking of character length passed to a character dummy. However, when the actual argument was an array element, its storage size was estimated from all elements up to the end of the array. This could give a bogus warning when the dummy argument was of a scalar character type. Fix check for this case to actually compare the character lengths of actual and dummy. PR fortran/125393 gcc/fortran/ChangeLog: * interface.cc (get_expr_storage_size): Additionally return character length. (gfc_compare_actual_formal): When the formal is a scalar character variable, use character lengths, not array storage size for check. gcc/testsuite/ChangeLog: * gfortran.dg/argument_checking_28.f90: New test. Diff: --- gcc/fortran/interface.cc | 15 +++++++- gcc/testsuite/gfortran.dg/argument_checking_28.f90 | 45 ++++++++++++++++++++++ 2 files changed, 58 insertions(+), 2 deletions(-) diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 8ab2fade283e..e809a14c808a 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -3085,7 +3085,7 @@ get_sym_storage_size (gfc_symbol *sym, bool *size_known) units of the actual argument up to the end of the array. */ static unsigned long -get_expr_storage_size (gfc_expr *e, bool *size_known) +get_expr_storage_size (gfc_expr *e, bool *size_known, long int *charlen) { int i; long int strlen, elements; @@ -3094,6 +3094,7 @@ get_expr_storage_size (gfc_expr *e, bool *size_known) gfc_ref *ref; *size_known = false; + *charlen = -1; if (e == NULL) return 0; @@ -3109,6 +3110,7 @@ get_expr_storage_size (gfc_expr *e, bool *size_known) strlen = e->value.character.length; else return 0; + *charlen = strlen; } else strlen = 1; /* Length per element. */ @@ -3365,6 +3367,7 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_formal_arglist *f; int i, n, na; unsigned long actual_size, formal_size; + long int charlen; bool full_array = false; gfc_array_ref *actual_arr_ref; gfc_array_spec *fas, *aas; @@ -3681,9 +3684,17 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN) goto skip_size_check; - actual_size = get_expr_storage_size (a->expr, &actual_size_known); + actual_size = get_expr_storage_size (a->expr, &actual_size_known, &charlen); formal_size = get_sym_storage_size (f->sym, &formal_size_known); + /* If the formal is a scalar character variable, use the charlen of the + actual. */ + if (actual_size_known && formal_size_known && charlen >= 0 + && a->expr->ts.type == BT_CHARACTER + && f->sym->attr.flavor != FL_PROCEDURE + && !f->sym->attr.dimension) + actual_size = charlen; + if (actual_size_known && formal_size_known && actual_size != formal_size && a->expr->ts.type == BT_CHARACTER diff --git a/gcc/testsuite/gfortran.dg/argument_checking_28.f90 b/gcc/testsuite/gfortran.dg/argument_checking_28.f90 new file mode 100644 index 000000000000..fb9ec4d70eae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_28.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2018 -Wcharacter-truncation" } +! +! PR fortran/125393 - checking of passed character length + +module test + implicit none +contains + + subroutine a(string) + character(len=2) string + end subroutine a + + subroutine b + character(len=2) :: s1 + character(len=2), dimension(2) :: s2 + character(len=1) :: s3(2) + character(len=4) :: s4 + call a(s1) + call a(s1(1:2)) + call a(s2(1)) ! This gave a bogus warning + call a(s2(1)(1:2)) + call a(s3(1)) ! { dg-error "Character length of actual argument shorter" } + call a(s4(1:2)) + call a(c1()) ! { dg-error "Character length of actual argument shorter" } + call a(c2()) + call a(c3()) ! { dg-warning "Character length of actual argument longer" } + end subroutine b + + function c1 () + character(len=1) :: c1 + c1 = "a" + end function c1 + + function c2 () + character(len=2) :: c2 + c2 = "ab" + end function c2 + + function c3 () + character(len=3) :: c3 + c3 = "abc" + end function c3 + +end module test
