[PATCH] Fortran: ABI for scalar CHARACTER(LEN=1),VALUE dummy argument [PR110360]

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 850 bytes --]

Dear all,

gfortran's ABI specifies that actual arguments to CHARACTER(LEN=1),VALUE
dummy arguments are passed by value in the scalar case.  That did work
for constant strings being passed, but not in several other cases, where
pointers were passed, resulting in subsequent random junk...

The attached patch fixes this for the case of a non-constant string
argument.

It does not touch the character,value bind(c) case - this is a different
thing and may need separate work, as Mikael pointed out - and there is
a missed optimization for the case of actual constant string arguments
of length larger than 1: it appears that the full string is pushed to
the stack.  I did not address that, as the primary aim here is to get
correctly working code.  (I added a TODO in a comment.)

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr110360.diff --]
[-- Type: text/x-patch, Size: 4277 bytes --]

From bea1e14490e4abc4b67bae8fdca5196bb93acd2d Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 22 Jun 2023 22:07:41 +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): Pass actual argument
	to scalar CHARACTER(1),VALUE dummy argument by value.

gcc/testsuite/ChangeLog:

	PR fortran/110360
	* gfortran.dg/value_9.f90: New test.
---
 gcc/fortran/trans-expr.cc             | 19 +++++++
 gcc/testsuite/gfortran.dg/value_9.f90 | 78 +++++++++++++++++++++++++++
 2 files changed, 97 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/value_9.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 3c209bcde97..c92fccd0be2 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6392,6 +6392,25 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  else
 		    {
 		    gfc_conv_expr (&parmse, e);
+
+		    /* 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.  */
+		    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)
+		      {
+			parmse.expr = gfc_string_to_single_character
+			  (build_int_cst (gfc_charlen_type_node, 1),
+			   parmse.expr,
+			   e->ts.kind);
+		      }
+
 		    if (fsym->attr.optional
 			&& fsym->ts.type != BT_CLASS
 			&& fsym->ts.type != BT_DERIVED)
diff --git a/gcc/testsuite/gfortran.dg/value_9.f90 b/gcc/testsuite/gfortran.dg/value_9.f90
new file mode 100644
index 00000000000..f6490645e27
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/value_9.f90
@@ -0,0 +1,78 @@
+! { dg-do run }
+! PR fortran/110360 - ABI for scalar character(len=1),value dummy argument
+
+program p
+  implicit none
+  character,               allocatable :: ca
+  character,               pointer     :: cp
+  character(len=:),        allocatable :: cd
+  character      (kind=4), allocatable :: ca4
+  character      (kind=4), pointer     :: cp4
+  character(len=:,kind=4), allocatable :: cd4
+  integer :: a = 65
+  allocate (ca, cp, ca4, cp4)
+
+  ! Check len=1 actual argument cases first
+  ca  =   "a"; cp  =   "b"; cd  =   "c"
+  ca4 = 4_"d"; cp4 = 4_"e"; cd4 = 4_"f"
+  call val  ("B","B")
+  call val  ("A",char(65))
+  call val  ("A",char(a))
+  call val  ("A",mychar(65))
+  call val  ("A",mychar(a))
+  call val4 (4_"C",4_"C")
+  call val4 (4_"A",char(65,kind=4))
+  call val4 (4_"A",char(a, kind=4))
+  call val  (ca,ca)
+  call val  (cp,cp)
+  call val  (cd,cd)
+  call val4 (ca4,ca4)
+  call val4 (cp4,cp4)
+  call val4 (cd4,cd4)
+  call sub  ("S")
+  call sub4 (4_"T")
+
+  ! Check that always the first character of the string is finally used
+  call val  (  "U++",  "U--")
+  call val4 (4_"V**",4_"V//")
+  call sub  (  "WTY")
+  call sub4 (4_"ZXV")
+  cd = "gkl"; cd4 = 4_"hmn"
+  call val  (cd,cd)
+  call val4 (cd4,cd4)
+  call sub  (cd)
+  call sub4 (cd4)
+  deallocate (ca, cp, ca4, cp4, cd, cd4)
+contains
+  subroutine val (x, c)
+    character(kind=1), intent(in) :: x  ! control: pass by reference
+    character(kind=1), value      :: c
+    print *, "by value(kind=1): ", c
+    if (c /= x)   stop 1
+    c = "*"
+    if (c /= "*") stop 2
+  end
+
+  subroutine val4 (x, c)
+    character(kind=4), intent(in) :: x  ! control: pass by reference
+    character(kind=4), value      :: c
+    print *, "by value(kind=4): ", c
+    if (c /= x)     stop 3
+    c = 4_"#"
+    if (c /= 4_"#") stop 4
+  end
+
+  subroutine sub (s)
+    character(*), intent(in) :: s
+    call val (s, s)
+  end
+  subroutine sub4 (s)
+    character(kind=4,len=*), intent(in) :: s
+    call val4 (s, s)
+  end
+
+  character function mychar (i)
+    integer, intent(in) :: i
+    mychar = char (i)
+  end
+end
--
2.35.3