From 8736d6b14a4dfdfb58c80ccd398981b0fb5d00aa Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Wed, 28 Jun 2023 22:16:18 +0200
Subject: [PATCH] Fortran: ABI for scalar CHARACTER(LEN=1),VALUE dummy argument
 [PR110360]

gcc/fortran/ChangeLog:

	PR fortran/110360
	* trans-expr.cc (gfc_conv_procedure_call): For non-constant string
	argument passed to CHARACTER(LEN=1),VALUE dummy, ensure proper
	dereferencing and truncation of string to length 1.

gcc/testsuite/ChangeLog:

	PR fortran/110360
	* gfortran.dg/value_9.f90: Add tests for intermediate regression.
---
 gcc/fortran/trans-expr.cc             | 15 ++++++++++-----
 gcc/testsuite/gfortran.dg/value_9.f90 | 23 +++++++++++++++++++++++
 2 files changed, 33 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ad0cdf902ba..30946ba3f63 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6395,7 +6395,7 @@ 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.
-		       Constant strings are truncated to length 1.
+		       Strings are truncated to length 1.
 		       The BIND(C) case is handled elsewhere.  */
 		    if (fsym->ts.type == BT_CHARACTER
 			&& !fsym->ts.is_c_interop
@@ -6405,10 +6405,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			    (fsym->ts.u.cl->length->value.integer, 1) == 0))
 		      {
 			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);
+			  {
+			    tree slen1 = build_int_cst (gfc_charlen_type_node, 1);
+			    gfc_conv_string_parameter (&parmse);
+			    parmse.expr = gfc_string_to_single_character (slen1,
+									  parmse.expr,
+									  e->ts.kind);
+			    /* Truncate resulting string to length 1.  */
+			    parmse.string_length = slen1;
+			  }
 			else if (e->value.character.length > 1)
 			  {
 			    e->value.character.length = 1;
diff --git a/gcc/testsuite/gfortran.dg/value_9.f90 b/gcc/testsuite/gfortran.dg/value_9.f90
index f6490645e27..1a2fa80ed0d 100644
--- a/gcc/testsuite/gfortran.dg/value_9.f90
+++ b/gcc/testsuite/gfortran.dg/value_9.f90
@@ -9,7 +9,12 @@ program p
   character      (kind=4), allocatable :: ca4
   character      (kind=4), pointer     :: cp4
   character(len=:,kind=4), allocatable :: cd4
+  character                            :: c  =   "1"
+  character      (kind=4)              :: c4 = 4_"4"
+  character(len=3)                     :: d  =   "210"
+  character(len=3,kind=4)              :: d4 = 4_"321"
   integer :: a = 65
+  integer :: l = 2
   allocate (ca, cp, ca4, cp4)

   ! Check len=1 actual argument cases first
@@ -20,15 +25,21 @@ program p
   call val  ("A",char(a))
   call val  ("A",mychar(65))
   call val  ("A",mychar(a))
+  call val  ("1",c)
+  call val  ("1",(c))
   call val4 (4_"C",4_"C")
   call val4 (4_"A",char(65,kind=4))
   call val4 (4_"A",char(a, kind=4))
+  call val4 (4_"4",c4)
+  call val4 (4_"4",(c4))
   call val  (ca,ca)
   call val  (cp,cp)
   call val  (cd,cd)
+  call val  (ca,(ca))
   call val4 (ca4,ca4)
   call val4 (cp4,cp4)
   call val4 (cd4,cd4)
+  call val4 (cd4,(cd4))
   call sub  ("S")
   call sub4 (4_"T")

@@ -37,6 +48,18 @@ program p
   call val4 (4_"V**",4_"V//")
   call sub  (  "WTY")
   call sub4 (4_"ZXV")
+  call val  (  "234",  d    )
+  call val4 (4_"345",  d4   )
+  call val  (  "234", (d)   )
+  call val4 (4_"345", (d4)  )
+  call val  (  "234",  d (1:2))
+  call val4 (4_"345",  d4(1:2))
+  call val  (  "234",  d (1:l))
+  call val4 (4_"345",  d4(1:l))
+  call val  ("1",c // d)
+  call val  ("1",trim (c // d))
+  call val4 (4_"4",c4 // d4)
+  call val4 (4_"4",trim (c4 // d4))
   cd = "gkl"; cd4 = 4_"hmn"
   call val  (cd,cd)
   call val4 (cd4,cd4)
--
2.35.3