Dear all,
the attached fixes a missed optimization passing a constant character
string to a scalar dummy with value attribute and shorter than the
actual by truncating the latter at compile time.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
From 378e6ee5fc20a2648940e80e5a7faf150cc4a33c Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Sun, 31 Aug 2025 20:42:23 +0200
Subject: [PATCH] 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.
---
gcc/fortran/trans-expr.cc | 34 ++++++++++++++++++++
gcc/testsuite/gfortran.dg/value_10.f90 | 43 ++++++++++++++++++++++++++
2 files changed, 77 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/value_10.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6a21e8c10e8..97431d9f19e 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 00000000000..b1c8d1d81e9
--- /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" } }
--
2.51.0
