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.

7 files changed, 370 insertions, 38 deletions

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index d08f683..ef5a17d 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 e79541f..63931a2 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 0000000..06dd187
--- /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 99a0d86..d8bb8cf 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 6529a77..75cb438 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 3ff6ca8..7b322f1 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 86d84cf..87ac4f3 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