[gcc r14-2064] Fortran: ABI for scalar CHARACTER(LEN=1), VALUE dummy argument [PR110360]

[gcc r14-2064] Fortran: ABI for scalar CHARACTER(LEN=1), VALUE dummy argument [PR110360]

[Harald Anlauf]

https://gcc.gnu.org/g:3f97d10aa1ff5984d6fd657f246d3f251b254ff1

commit r14-2064-g3f97d10aa1ff5984d6fd657f246d3f251b254ff1
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Sat Jun 24 20:36:53 2023 +0200

    Fortran: ABI for scalar CHARACTER(LEN=1),VALUE dummy argument [PR110360]
    
    gcc/fortran/ChangeLog:
    
            PR fortran/110360
            * trans-expr.cc (gfc_conv_procedure_call): Truncate constant string
            argument of length > 1 passed to scalar CHARACTER(1),VALUE dummy.

Diff:
---
 gcc/fortran/trans-expr.cc | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c92fccd0be2..63e3cf9681e 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6395,20 +6395,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 		    /* ABI: actual arguments to CHARACTER(len=1),VALUE
 		       dummy arguments are actually passed by value.
-		       The BIND(C) case is handled elsewhere.
-		       TODO: truncate constant strings to length 1.  */
+		       Constant strings are truncated to length 1.
+		       The BIND(C) case is handled elsewhere.  */
 		    if (fsym->ts.type == BT_CHARACTER
 			&& !fsym->ts.is_c_interop
 			&& fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT
 			&& fsym->ts.u.cl->length->ts.type == BT_INTEGER
 			&& (mpz_cmp_ui
-			    (fsym->ts.u.cl->length->value.integer, 1) == 0)
-			&& e->expr_type != EXPR_CONSTANT)
+			    (fsym->ts.u.cl->length->value.integer, 1) == 0))
 		      {
-			parmse.expr = gfc_string_to_single_character
-			  (build_int_cst (gfc_charlen_type_node, 1),
-			   parmse.expr,
-			   e->ts.kind);
+			if (e->expr_type != EXPR_CONSTANT)
+			  parmse.expr = gfc_string_to_single_character
+			    (build_int_cst (gfc_charlen_type_node, 1),
+			     parmse.expr,
+			     e->ts.kind);
+			else if (e->value.character.length > 1)
+			  {
+			    e->value.character.length = 1;
+			    gfc_conv_expr (&parmse, e);
+			  }
 		      }
 
 		    if (fsym->attr.optional