Dear all, the attached patch tries to improve diagnostics at compile time for character arguments in various ways:
- we did unconditionally give a warning for too short character actual arguments passed to a scalar dummy; we now give an error when -std=f* is specified. The warning is retained for -std=legacy/gnu as several testcases depend on it. - if the actual argument has length zero, no warning was given. This had been remedied. - if a character actual argument is longer than the dummy, we now give a truncation warning if -Wcharacter-truncation is given. - If a character formal argument has the pointer or allocatable attribute, or is an array that is not assumed or explicit size, we now generate an error by default unless -std=legacy is specified, which falls back to just giving a warning as before. (One testcase depends on it.) The errors emitted as described above have been checked to be consistent with NAG. :-) There is one thing where we (still?) deviate from F2018:15.5.2.4. The standard text explicitly mentions default character kind and C character kind in several contexts, which could be interpreted as excluding kind=4 character. However, I do not see why this should be the case - there is no actual technical reason, and also NAG handles kind=4 character the same as kind=1 character in the tests. If someone feels strongly about it, we could make an interp request to resolve this. I would consider this a gfortran extension for the time being. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald
From 3b432dab9437a77167c80de665c4f742635c339d Mon Sep 17 00:00:00 2001 From: Harald Anlauf <[email protected]> Date: Thu, 28 Aug 2025 22:07:10 +0200 Subject: [PATCH] Fortran: improve compile-time checking of character dummy arguments [PR93330] PR fortran/93330 gcc/fortran/ChangeLog: * interface.cc (get_sym_storage_size): Add argument size_known to indicate that the storage size could be successfully determined. (get_expr_storage_size): Likewise. (gfc_compare_actual_formal): Use them to handle zero-sized dummy and actual arguments. If a character formal argument has the pointer or allocatable attribute, or is an array that is not assumed or explicit size, we generate an error by default unless -std=legacy is specified, which falls back to just giving a warning. If -Wcharacter-truncation is given, warn on a character actual argument longer than the dummy. Generate an error for too short scalar character arguments if -std=f* is given instead of just a warning. gcc/testsuite/ChangeLog: * gfortran.dg/argument_checking_15.f90: Adjust dg-pattern. * gfortran.dg/bounds_check_strlen_7.f90: Add dg-pattern. * gfortran.dg/char_length_3.f90: Adjust options. * gfortran.dg/whole_file_24.f90: Add dg-pattern. * gfortran.dg/whole_file_29.f90: Likewise. * gfortran.dg/argument_checking_27.f90: New test. --- gcc/fortran/interface.cc | 156 +++++++++--- .../gfortran.dg/argument_checking_15.f90 | 4 +- .../gfortran.dg/argument_checking_27.f90 | 240 ++++++++++++++++++ .../gfortran.dg/bounds_check_strlen_7.f90 | 3 +- gcc/testsuite/gfortran.dg/char_length_3.f90 | 1 + gcc/testsuite/gfortran.dg/whole_file_24.f90 | 2 +- gcc/testsuite/gfortran.dg/whole_file_29.f90 | 2 +- 7 files changed, 370 insertions(+), 38 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/argument_checking_27.f90 diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index d08f683498d..ef5a17d0af4 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -3007,15 +3007,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } -/* Returns the storage size of a symbol (formal argument) or - zero if it cannot be determined. */ +/* Returns the storage size of a symbol (formal argument) or sets argument + size_known to false if it cannot be determined. */ static unsigned long -get_sym_storage_size (gfc_symbol *sym) +get_sym_storage_size (gfc_symbol *sym, bool *size_known) { int i; unsigned long strlen, elements; + *size_known = false; + if (sym->ts.type == BT_CHARACTER) { if (sym->ts.u.cl && sym->ts.u.cl->length @@ -3029,7 +3031,10 @@ get_sym_storage_size (gfc_symbol *sym) strlen = 1; if (symbol_rank (sym) == 0) - return strlen; + { + *size_known = true; + return strlen; + } elements = 1; if (sym->as->type != AS_EXPLICIT) @@ -3046,17 +3051,19 @@ get_sym_storage_size (gfc_symbol *sym) - mpz_get_si (sym->as->lower[i]->value.integer) + 1L; } + *size_known = true; + return strlen*elements; } -/* Returns the storage size of an expression (actual argument) or - zero if it cannot be determined. For an array element, it returns - the remaining size as the element sequence consists of all storage +/* Returns the storage size of an expression (actual argument) or sets argument + size_known to false if it cannot be determined. For an array element, it + returns the remaining size as the element sequence consists of all storage units of the actual argument up to the end of the array. */ static unsigned long -get_expr_storage_size (gfc_expr *e) +get_expr_storage_size (gfc_expr *e, bool *size_known) { int i; long int strlen, elements; @@ -3064,6 +3071,8 @@ get_expr_storage_size (gfc_expr *e) bool is_str_storage = false; gfc_ref *ref; + *size_known = false; + if (e == NULL) return 0; @@ -3083,7 +3092,10 @@ get_expr_storage_size (gfc_expr *e) strlen = 1; /* Length per element. */ if (e->rank == 0 && !e->ref) - return strlen; + { + *size_known = true; + return strlen; + } elements = 1; if (!e->ref) @@ -3092,7 +3104,10 @@ get_expr_storage_size (gfc_expr *e) return 0; for (i = 0; i < e->rank; i++) elements *= mpz_get_si (e->shape[i]); - return elements*strlen; + { + *size_known = true; + return elements*strlen; + } } for (ref = e->ref; ref; ref = ref->next) @@ -3231,6 +3246,8 @@ get_expr_storage_size (gfc_expr *e) } } + *size_known = true; + if (substrlen) return (is_str_storage) ? substrlen + (elements-1)*strlen : elements*strlen; @@ -3331,7 +3348,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_array_spec *fas, *aas; bool pointer_dummy, pointer_arg, allocatable_arg; bool procptr_dummy, optional_dummy, allocatable_dummy; - + bool actual_size_known = false; + bool formal_size_known = false; bool ok = true; actual = *ap; @@ -3584,20 +3602,39 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, f->sym->ts.u.cl->length->value.integer) != 0)) { + long actual_len, formal_len; + actual_len = mpz_get_si (a->expr->ts.u.cl->length->value.integer); + formal_len = mpz_get_si (f->sym->ts.u.cl->length->value.integer); + if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) - gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " - "argument and pointer or allocatable dummy argument " - "%qs at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); + { + /* Emit a warning for -std=legacy and an error otherwise. */ + if (gfc_option.warn_std == 0) + gfc_warning (0, "Character length mismatch (%ld/%ld) between " + "actual argument and pointer or allocatable " + "dummy argument %qs at %L", actual_len, formal_len, + f->sym->name, &a->expr->where); + else + gfc_error ("Character length mismatch (%ld/%ld) between " + "actual argument and pointer or allocatable " + "dummy argument %qs at %L", actual_len, formal_len, + f->sym->name, &a->expr->where); + } else if (where) - gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " - "argument and assumed-shape dummy argument %qs " - "at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); + { + /* Emit a warning for -std=legacy and an error otherwise. */ + if (gfc_option.warn_std == 0) + gfc_warning (0, "Character length mismatch (%ld/%ld) between " + "actual argument and assumed-shape dummy argument " + "%qs at %L", actual_len, formal_len, + f->sym->name, &a->expr->where); + else + gfc_error ("Character length mismatch (%ld/%ld) between " + "actual argument and assumed-shape dummy argument " + "%qs at %L", actual_len, formal_len, + f->sym->name, &a->expr->where); + + } ok = false; goto match; } @@ -3622,21 +3659,74 @@ 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); - formal_size = get_sym_storage_size (f->sym); - if (actual_size != 0 && actual_size < formal_size - && a->expr->ts.type != BT_PROCEDURE + actual_size = get_expr_storage_size (a->expr, &actual_size_known); + formal_size = get_sym_storage_size (f->sym, &formal_size_known); + + if (actual_size_known && formal_size_known + && actual_size != formal_size + && a->expr->ts.type == BT_CHARACTER && f->sym->attr.flavor != FL_PROCEDURE) { - if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) + /* F2018:15.5.2.4: + (3) "The length type parameter values of a present actual argument + shall agree with the corresponding ones of the dummy argument that + are not assumed, except for the case of the character length + parameter of an actual argument of type character with default + kind or C character kind associated with a dummy argument that is + not assumed-shape or assumed-rank." + + (4) "If a present scalar dummy argument is of type character with + default kind or C character kind, the length len of the dummy + argument shall be less than or equal to the length of the actual + argument. The dummy argument becomes associated with the leftmost + len characters of the actual argument. If a present array dummy + argument is of type character with default kind or C character + kind and is not assumed-shape or assumed-rank, it becomes + associated with the leftmost characters of the actual argument + element sequence." + + As an extension we treat kind=4 character similarly to kind=1. */ + + if (actual_size > formal_size) { - gfc_warning (0, "Character length of actual argument shorter " - "than of dummy argument %qs (%lu/%lu) at %L", - f->sym->name, actual_size, formal_size, - &a->expr->where); + if (a->expr->ts.type == BT_CHARACTER && where + && (!f->sym->as || f->sym->as->type == AS_EXPLICIT)) + gfc_warning (OPT_Wcharacter_truncation, + "Character length of actual argument longer " + "than of dummy argument %qs (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); goto skip_size_check; } - else if (where) + + if (a->expr->ts.type == BT_CHARACTER && where && !f->sym->as) + { + /* Emit warning for -std=legacy/gnu and an error otherwise. */ + if (gfc_notification_std (GFC_STD_LEGACY) == ERROR) + { + gfc_error ("Character length of actual argument shorter " + "than of dummy argument %qs (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); + ok = false; + goto match; + } + else + gfc_warning (0, "Character length of actual argument shorter " + "than of dummy argument %qs (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); + goto skip_size_check; + } + } + + if (actual_size_known && formal_size_known + && actual_size < formal_size + && f->sym->as + && a->expr->ts.type != BT_PROCEDURE + && f->sym->attr.flavor != FL_PROCEDURE) + { + if (where) { /* Emit a warning for -std=legacy and an error otherwise. */ if (gfc_option.warn_std == 0) diff --git a/gcc/testsuite/gfortran.dg/argument_checking_15.f90 b/gcc/testsuite/gfortran.dg/argument_checking_15.f90 index e79541fcded..63931a287f2 100644 --- a/gcc/testsuite/gfortran.dg/argument_checking_15.f90 +++ b/gcc/testsuite/gfortran.dg/argument_checking_15.f90 @@ -45,8 +45,8 @@ subroutine test() implicit none character(len=5), pointer :: c character(len=5) :: str(5) -call foo(c) ! { dg-warning "Character length mismatch" } -call bar(str) ! { dg-warning "Character length mismatch" } +call foo(c) ! { dg-error "Character length mismatch" } +call bar(str) ! { dg-error "Character length mismatch" } contains subroutine foo(a) character(len=3), pointer :: a diff --git a/gcc/testsuite/gfortran.dg/argument_checking_27.f90 b/gcc/testsuite/gfortran.dg/argument_checking_27.f90 new file mode 100644 index 00000000000..06dd187dcf9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/argument_checking_27.f90 @@ -0,0 +1,240 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2018 -Wcharacter-truncation" } +! PR fortran/93330 +! +! Exercise compile-time checking of character length of dummy vs. +! actual arguments. Based on original testcase by Tobias Burnus + +module m + use iso_c_binding, only: c_char + implicit none +contains + ! scalar dummy + ! character(kind=1): + subroutine zero(x, y) + character(kind=1,len=0), value :: x + character(kind=1,len=1), value :: y + print '(5a)', 'zero >', x, '< >', y, '<' + end + subroutine one(x, y) + character(kind=1,len=1), value :: x + character(kind=1,len=1), value :: y + print '(5a)','one >', x, '< >', y, '<' + end + subroutine two(x, y) + character(kind=1,len=2), value :: x + character(kind=1,len=1), value :: y + print '(5a)','two >', x, '< >', y, '<' + end + subroutine cbind(x, y) bind(C) + character(kind=c_char,len=1), value :: x + character(kind=c_char,len=1), value :: y + print '(5a)','cbind >', x, '< >', y, '<' + end + + ! character(kind=4): + subroutine zero4(x, y) + character(kind=4,len=0), value :: x + character(kind=1,len=1), value :: y + print '(5a)', 'zero4 >', x, '< >', y, '<' + end + subroutine one4(x, y) + character(kind=4,len=1), value :: x + character(kind=1,len=1), value :: y + print '(5a)','one4 >', x, '< >', y, '<' + end + subroutine two4(x, y) + character(kind=4,len=2), value :: x + character(kind=1,len=1), value :: y + print '(5a)','two4 >', x, '< >', y, '<' + end + + ! character(kind=1): + ! array dummy, assumed size + subroutine zero_0(x, y) + character(kind=1,len=0) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)', 'zero_0 >', x(1), '< >', y, '<' + end + subroutine one_0(x, y) + character(kind=1,len=1) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)','one_0 >', x(1), '< >', y, '<' + end + subroutine two_0(x, y) + character(kind=1,len=2) :: x(*) + character(kind=1,len=1), value :: y + print '(5a)','two_0 >', x(1), '< >', y, '<' + end + + ! array dummy, explicit size + subroutine zero_1(x, y) + character(kind=1,len=0) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)', 'zero_1 >', x(1), '< >', y, '<' + end + subroutine one_1(x, y) + character(kind=1,len=1) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)','one_1 >', x(1), '< >', y, '<' + end + subroutine two_1(x, y) + character(kind=1,len=2) :: x(1) + character(kind=1,len=1), value :: y + print '(5a)','two_1 >', x(1), '< >', y, '<' + end + + ! array dummy, assumed shape + subroutine zero_a(x, y) + character(kind=1,len=0) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)', 'zero_a >', x(1), '< >', y, '<' + end + subroutine one_a(x, y) + character(kind=1,len=1) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','one_a >', x(1), '< >', y, '<' + end + subroutine two_a(x, y) + character(kind=1,len=2) :: x(:) + character(kind=1,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','two_a >', x(1), '< >', y, '<' + end + + ! character(kind=4): + ! array dummy, assumed size + subroutine zero4_0(x, y) + character(kind=4,len=0) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)', 'zero4_0 >', x(1), '< >', y, '<' + end + subroutine one4_0(x, y) + character(kind=4,len=1) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)','one4_0 >', x(1), '< >', y, '<' + end + subroutine two4_0(x, y) + character(kind=4,len=2) :: x(*) + character(kind=4,len=1), value :: y + print '(5a)','two4_0 >', x(1), '< >', y, '<' + end + + ! array dummy, explicit size + subroutine zero4_1(x, y) + character(kind=4,len=0) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)', 'zero4_1 >', x(1), '< >', y, '<' + end + subroutine one4_1(x, y) + character(kind=4,len=1) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)','one4_1 >', x(1), '< >', y, '<' + end + subroutine two4_1(x, y) + character(kind=4,len=2) :: x(1) + character(kind=4,len=1), value :: y + print '(5a)','two4_1 >', x(1), '< >', y, '<' + end + + ! array dummy, assumed shape + subroutine zero4_a(x, y) + character(kind=4,len=0) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)', 'zero4_a >', x(1), '< >', y, '<' + end + subroutine one4_a(x, y) + character(kind=4,len=1) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','one4_a >', x(1), '< >', y, '<' + end + subroutine two4_a(x, y) + character(kind=4,len=2) :: x(:) + character(kind=4,len=1), value :: y + if (size (x) < 1) stop 99 + print '(5a)','two4_a >', x(1), '< >', y, '<' + end +end + +program p + use m + implicit none + call zero('', '1') + call one ('', '2') ! { dg-error "length of actual argument shorter" } + call one ('b'(3:2),'3') ! { dg-error "length of actual argument shorter" } + call two ('', '4') ! { dg-error "length of actual argument shorter" } + call two ('f','5') ! { dg-error "length of actual argument shorter" } + + call cbind('', '6') ! { dg-error "length of actual argument shorter" } + call cbind('ABC','7') ! { dg-warning "length of actual argument longer" } + + ! character(kind=4): + call zero4(4_'', '8') + call zero4(4_'3','9') ! { dg-warning "length of actual argument longer" } + call one4 (4_'', 'A') ! { dg-error "length of actual argument shorter" } + call one4 (4_'b'(3:2),'B') ! { dg-error "length of actual argument shorter" } + call one4 (4_'bbcd'(3:3),'C') + call one4 (4_'cd','D') ! { dg-warning "length of actual argument longer" } + call two4 (4_'', 'E') ! { dg-error "length of actual argument shorter" } + call two4 (4_'f', 'F') ! { dg-error "length of actual argument shorter" } + call two4 (4_'fgh','G') ! { dg-warning "length of actual argument longer" } + + ! array dummy, assumed size + call zero_0([''],'a') + call zero_0(['a'],'b') + call one_0 ([''],'c') + call one_0 (['b'],'d') + call one_0 (['cd'],'e') + call two_0 ([''],'f') + call two_0 (['fg'],'g') + + ! array dummy, explicit size + call zero_1([''],'a') + call zero_1(['a'],'b') ! { dg-warning "actual argument longer" } + call one_1 ([''],'c') ! { dg-error "too few elements for dummy" } + call one_1 (['b'],'d') + call one_1 (['cd'],'e') ! { dg-warning "actual argument longer" } + call two_1 ([''],'f') ! { dg-error "too few elements for dummy" } + call two_1 (['fg'],'h') + + ! array dummy, assumed shape + call zero_a([''],'a') + call zero_a(['a'],'b') ! { dg-error "Character length mismatch" } + call one_a ([''],'c') ! { dg-error "Character length mismatch" } + call one_a (['b'],'d') + call one_a (['cd'],'e') ! { dg-error "Character length mismatch" } + call two_a ([''],'f') ! { dg-error "Character length mismatch" } + call two_a (['fg'],'h') + + ! character(kind=4): + ! array dummy, assumed size + call zero4_0([4_''],4_'a') + call zero4_0([4_'a'],4_'b') + call one4_0 ([4_''],4_'c') + call one4_0 ([4_'b'],4_'d') + call one4_0 ([4_'cd'],4_'e') + call two4_0 ([4_''],4_'f') + call two4_0 ([4_'fg'],4_'g') + + ! array dummy, explicit size + call zero4_1([4_''],4_'a') + call zero4_1([4_'a'],4_'b') ! { dg-warning "actual argument longer" } + call one4_1 ([4_''],4_'c') ! { dg-error "too few elements for dummy" } + call one4_1 ([4_'b'],4_'d') + call one4_1 ([4_'cd'],4_'e') ! { dg-warning "actual argument longer" } + call two4_1 ([4_''],4_'f') ! { dg-error "too few elements for dummy" } + call two4_1 ([4_'fg'],4_'h') + + ! array dummy, assumed shape + call zero4_a([4_''],4_'a') + call zero4_a([4_'a'],4_'b') ! { dg-error "Character length mismatch" } + call one4_a ([4_''],4_'c') ! { dg-error "Character length mismatch" } + call one4_a ([4_'b'],4_'d') + call one4_a ([4_'cd'],4_'e') ! { dg-error "Character length mismatch" } + call two4_a ([4_''],4_'f') ! { dg-error "Character length mismatch" } + call two4_a ([4_'fg'],4_'h') +end diff --git a/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 b/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 index 99a0d8697ff..d8bb8cf6d7c 100644 --- a/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 +++ b/gcc/testsuite/gfortran.dg/bounds_check_strlen_7.f90 @@ -18,7 +18,8 @@ END MODULE m PROGRAM main USE m IMPLICIT NONE - CALL test ('') ! 0 length, but not absent argument. + ! 0 length, but not absent argument. + CALL test ('') ! { dg-warning "Character length of actual argument" } END PROGRAM main ! { dg-output "shorter than the declared one for dummy argument 'opt' \\(0/5\\)" } diff --git a/gcc/testsuite/gfortran.dg/char_length_3.f90 b/gcc/testsuite/gfortran.dg/char_length_3.f90 index 6529a77ff04..75cb4382750 100644 --- a/gcc/testsuite/gfortran.dg/char_length_3.f90 +++ b/gcc/testsuite/gfortran.dg/char_length_3.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! { dg-options "-std=legacy" } ! PR fortran/25071 ! Check if actual argument is too short ! diff --git a/gcc/testsuite/gfortran.dg/whole_file_24.f90 b/gcc/testsuite/gfortran.dg/whole_file_24.f90 index 3ff6ca85700..7b322f1a215 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_24.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_24.f90 @@ -27,7 +27,7 @@ module syntax_rules contains subroutine syntax_init_from_ifile () type(string_t) :: string - string = line_get_string_advance ("") + string = line_get_string_advance ("") ! { dg-warning "Character length of actual argument shorter" } end subroutine syntax_init_from_ifile end module syntax_rules end diff --git a/gcc/testsuite/gfortran.dg/whole_file_29.f90 b/gcc/testsuite/gfortran.dg/whole_file_29.f90 index 86d84cf8d27..87ac4f3041b 100644 --- a/gcc/testsuite/gfortran.dg/whole_file_29.f90 +++ b/gcc/testsuite/gfortran.dg/whole_file_29.f90 @@ -19,7 +19,7 @@ module syntax_rules contains subroutine syntax_init_from_ifile () type(string_t) :: string - string = line_get_string_advance ("") + string = line_get_string_advance ("") ! { dg-warning "Character length of actual argument shorter" } end subroutine syntax_init_from_ifile end module syntax_rules end -- 2.43.0
