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.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ad0cdf902ba9ac994172bcc235830934fef43dde..30946ba3f630ddb9156cdd804c5437147eb9fe8e 100644 (file)
--- 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 f6490645e27fa47d4b0e02399b3f150265a008c1..1a2fa80ed0dca59bafc92c77e263c8cf536faa13 100644 (file)
--- 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)