Fortran: truncate constant string passed to character,value dummy [PR121727]

	PR fortran/121727

gcc/fortran/ChangeLog:

	* trans-expr.cc (gfc_const_length_character_type_p): New helper
	function.
	(conv_dummy_value): Use it to determine if a character actual
	argument has a constant length.  If a character actual argument is
	constant and longer than the dummy, truncate it at compile time.

gcc/testsuite/ChangeLog:

	* gfortran.dg/value_10.f90: New test.

2 files changed, 77 insertions, 0 deletions

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6a21e8c..97431d9 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6510,6 +6510,20 @@ conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond)
 }
 
 
+/* Returns true if the type specified in TS is a character type whose length
+   is constant.  Otherwise returns false.  */
+
+static bool
+gfc_const_length_character_type_p (gfc_typespec *ts)
+{
+  return (ts->type == BT_CHARACTER
+	  && ts->u.cl
+	  && ts->u.cl->length
+	  && ts->u.cl->length->expr_type == EXPR_CONSTANT
+	  && ts->u.cl->length->ts.type == BT_INTEGER);
+}
+
+
 /* Helper function for the handling of (currently) scalar dummy variables
    with the VALUE attribute.  Argument parmse should already be set up.  */
 static void
@@ -6565,6 +6579,26 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym,
       return;
     }
 
+  /* Truncate a too long constant character actual argument.  */
+  if (gfc_const_length_character_type_p (&fsym->ts)
+      && e->expr_type == EXPR_CONSTANT
+      && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer,
+		     e->value.character.length) < 0)
+    {
+      gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer);
+
+      /* Truncate actual string argument.  */
+      gfc_conv_expr (parmse, e);
+      parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen,
+						  e->value.character.string);
+      parmse->string_length = build_int_cst (gfc_charlen_type_node, flen);
+
+      /* Indicate value,optional scalar dummy argument as present.  */
+      if (fsym->attr.optional)
+	vec_safe_push (optionalargs, boolean_true_node);
+      return;
+    }
+
   /* gfortran argument passing conventions:
      actual arguments to CHARACTER(len=1),VALUE
      dummy arguments are actually passed by value.
diff --git a/gcc/testsuite/gfortran.dg/value_10.f90 b/gcc/testsuite/gfortran.dg/value_10.f90
new file mode 100644
index 0000000..b1c8d1d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/value_10.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! { dg-additional-options "-Wcharacter-truncation -fdump-tree-original" }
+! PR fortran/121727
+
+program p
+  use iso_c_binding, only: c_char
+  implicit none
+  call cbind('abcd')   ! { dg-warning "length of actual argument longer" }
+  call one  ('efgh')   ! { dg-warning "length of actual argument longer" }
+  call one4 (4_'IJKL') ! { dg-warning "length of actual argument longer" }
+
+  call two4 (4_'MNOP') ! { dg-warning "length of actual argument longer" }
+  call three('efgh')   ! { dg-warning "length of actual argument longer" }
+  call four ('ijklmn') ! { dg-warning "length of actual argument longer" }
+contains
+  subroutine cbind(c) bind(C)
+    character(kind=c_char,len=1), value :: c
+  end
+
+  subroutine one(x)
+    character(kind=1,len=1), value :: x
+  end
+
+  subroutine one4(w)
+    character(kind=4,len=1), value :: w
+  end
+
+  subroutine two4(y)
+    character(kind=4,len=2), value :: y
+  end
+
+  subroutine three(z)
+    character(kind=1,len=3), value :: z
+  end
+
+  subroutine four(v)
+    character(kind=1,len=4), optional, value :: v
+  end
+end
+
+! { dg-final { scan-tree-dump-times "two4 \\(.*, 2\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "three \\(.*, 3\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "four \\(.*, 1, 4\\);" 1 "original" } }