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 --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 8ab2fade283ef7b2fb2c39732b8811cc45bf8f81..e809a14c808a60158ce46a95988aa8f4fc43af8d 100644 (file)
--- 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 (file)
index 0000000..fb9ec4d
--- /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