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 --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c92fccd0be2e0849e64075d1e6060b241c6f247e..63e3cf9681e2343b8c51aa0f25e5cbc690324737 100644 (file)
--- 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