[PATCH] Emit correct types for CHARACTER(C_CHAR), VALUE

[PATCH] Emit correct types for CHARACTER(C_CHAR), VALUE

[FX]

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

Hi,

I’ve spent many hours going down a rabbit hole, namely that we emit incorrect types for C interoperable procedure parameters of type CHARACTER(C_CHAR), VALUE. The full details can be found here: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=103828 I will try here to be as brief as I can.

This bug manifests on the new target aarche64-apple-darwin, and there only if a CHARACTER(C_CHAR), VALUE argument is the 11th (or greater) argument to the function. Then, we would pass it as a 32-bit value, instead of an 8-bit value (as should a char). The front-end emits the wrong type information about the argument, but it turns out for all other targets this simply does not matter, due to their ABI.

Interoperable CHARACTER(C_CHAR), VALUE arguments are weird, because deep down they’re not actually character types (in the Fortran sense of the word), i.e. arrays, but scalar C char (i.e., integers!). So they’ve always been kind-of second class citizens in the front-end. A function was introduced in 2007 that basically patches their type on the fly: gfc_conv_scalar_char_value(). The problem is that function is simply wrong. It says (from comments):

      /* Modify the tree type for scalar character dummy arguments of bind(c)
        procedures if they are passed by value.  The tree type for them will
        be promoted to INTEGER_TYPE for the middle end, which appears to be
        what C would do with characters passed by-value.  The value attribute
         implies the dummy is a scalar.  */

The error is a misunderstanding of the C standard. char (and integer types smaller than int) are promoted to int for argument passing in unprototyped (old-school K&R) functions. In prototyped functions, they are most definitely not promoted. Therefore, the function is wrong.

More importantly, we can actually emit the right type much earlier in the front-end, and we already have a place to do so, in gfc_sym_type(). We already handle the result variables, but by-value arguments should have the same type, so the fix is easy.

In fact, once we emit the right type in gfc_sym_type(), we actually never need to fix it up in gfc_conv_scalar_char_value(). Removing the hack, I decided to leave it as a series of assertions, because we have seen in the past that this case is difficult to catch, and can easily regress due to changes elsewhere in the front-end.

Then, once the hack is removed, it becomes clear that the two callers of gfc_conv_scalar_char_value() expected different things from it: it’s called from generate_local_decl() to hack the sym->backend_decl; and it’s called from gfc_conv_procedure_call() for its true purpose, as a real conv_* function. For the first case, we can inline the checks (which have replaced the hack) into the caller in generate_local_decl(). Once only the second use case remains, we can make the function local to that file (make static, remove gfc_ prefix).


The patch comes with a couple of extra testcases, exercising the passing of char by value, and as integer, and their interoperability.
It was regtested on x86_64-pc-gnu-linux, on aarch64-apple-darwin (because its ABI is picky).

OK to commit?

FX


[-- Attachment #2: 0001-Fortran-Emit-correct-types-for-CHARACTER-C_CHAR-VALU.patch --]
[-- Type: application/octet-stream, Size: 16949 bytes --]

From f97bcd4044e032954f3a80479d1f1e5204d2d649 Mon Sep 17 00:00:00 2001
From: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Date: Sun, 26 Dec 2021 20:18:01 +0100
Subject: [PATCH] Fortran: Emit correct types for CHARACTER(C_CHAR), VALUE
 arguments

Make the front-end emit the right type for CHARACTER(C_CHAR), VALUE
arguments to BIND(C) procedures. They are scalar integers of C type
char, and should be emitted as such. They are not strings or arrays,
and are not promoted to C int, either.

gcc/fortran/ChangeLog:

	PR fortran/103828
	* trans-decl.c (generate_local_decl): Do not call
	gfc_conv_scalar_char_value(), but check the type tree.
	* trans-expr.c (gfc_conv_scalar_char_value): Rename to
	conv_scalar_char_value, do not alter type tree.
	(gfc_conv_procedure_call): Adjust call to renamed
	conv_scalar_char_value() function.
	* trans-types.c (gfc_sym_type): Take care of
	CHARACTER(C_CHAR), VALUE arguments.
	* trans.h (gfc_conv_scalar_char_value): Remove prototype.

gcc/testsuite/ChangeLog:

	PR fortran/103828
	* gfortran.dg/c_char_tests_3.f90: New file.
	* gfortran.dg/c_char_tests_3_c.c: New file.
	* gfortran.dg/c_char_tests_4.f90: New file.
	* gfortran.dg/c_char_tests_5.f90: New file.
---
 gcc/fortran/trans-decl.c                     | 17 ++--
 gcc/fortran/trans-expr.c                     | 86 ++++++++-----------
 gcc/fortran/trans-types.c                    |  2 +-
 gcc/fortran/trans.h                          |  1 -
 gcc/testsuite/gfortran.dg/c_char_tests_3.f90 | 51 +++++++++++
 gcc/testsuite/gfortran.dg/c_char_tests_3_c.c | 16 ++++
 gcc/testsuite/gfortran.dg/c_char_tests_4.f90 | 90 ++++++++++++++++++++
 gcc/testsuite/gfortran.dg/c_char_tests_5.f90 | 49 +++++++++++
 8 files changed, 255 insertions(+), 57 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/c_char_tests_3.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_char_tests_3_c.c
 create mode 100644 gcc/testsuite/gfortran.dg/c_char_tests_4.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_char_tests_5.f90

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index cb7f684d52c..d288af5aa10 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -6001,15 +6001,20 @@ generate_local_decl (gfc_symbol * sym)
 
   if (sym->attr.dummy == 1)
     {
-      /* Modify the tree type for scalar character dummy arguments of bind(c)
-	 procedures if they are passed by value.  The tree type for them will
-	 be promoted to INTEGER_TYPE for the middle end, which appears to be
-	 what C would do with characters passed by-value.  The value attribute
-         implies the dummy is a scalar.  */
+      /* The tree type for scalar character dummy arguments of BIND(C)
+	 procedures, if they are passed by value, should be unsigned char.
+	 The value attribute implies the dummy is a scalar.  */
       if (sym->attr.value == 1 && sym->backend_decl != NULL
 	  && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
 	  && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
-	gfc_conv_scalar_char_value (sym, NULL, NULL);
+	{
+	  /* We used to modify the tree here. Now it is done earlier in
+	     the front-end, so we only check it here to avoid regressions.  */
+	  gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
+	  gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
+	  gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
+	  gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
+	}
 
       /* Unused procedure passed as dummy argument.  */
       if (sym->attr.flavor == FL_PROCEDURE)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e413b2d7a1f..80c669f50fb 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -41,6 +41,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "trans-stmt.h"
 #include "dependency.h"
 #include "gimplify.h"
+#include "tm.h"		/* For CHAR_TYPE_SIZE.  */
 
 
 /* Calculate the number of characters in a string.  */
@@ -3972,63 +3973,50 @@ gfc_string_to_single_character (tree len, tree str, int kind)
 }
 
 
-void
-gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
+static void
+conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
 {
+  gcc_assert (expr);
 
+  /* We used to modify the tree here. Now it is done earlier in
+     the front-end, so we only check it here to avoid regressions.  */
   if (sym->backend_decl)
     {
-      /* This becomes the nominal_type in
-	 function.c:assign_parm_find_data_types.  */
-      TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
-      /* This becomes the passed_type in
-	 function.c:assign_parm_find_data_types.  C promotes char to
-	 integer for argument passing.  */
-      DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
-
-      DECL_BY_REFERENCE (sym->backend_decl) = 0;
+      gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE);
+      gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1);
+      gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE);
+      gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0);
     }
 
-  if (expr != NULL)
+  /* If we have a constant character expression, make it into an
+      integer of type C char.  */
+  if ((*expr)->expr_type == EXPR_CONSTANT)
     {
-      /* If we have a constant character expression, make it into an
-	 integer.  */
-      if ((*expr)->expr_type == EXPR_CONSTANT)
-        {
-	  gfc_typespec ts;
-          gfc_clear_ts (&ts);
+      gfc_typespec ts;
+      gfc_clear_ts (&ts);
 
-	  *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
-				    (int)(*expr)->value.character.string[0]);
-	  if ((*expr)->ts.kind != gfc_c_int_kind)
-	    {
-  	      /* The expr needs to be compatible with a C int.  If the
-		 conversion fails, then the 2 causes an ICE.  */
-	      ts.type = BT_INTEGER;
-	      ts.kind = gfc_c_int_kind;
-	      gfc_convert_type (*expr, &ts, 2);
-	    }
+      *expr = gfc_get_int_expr (gfc_default_character_kind, NULL,
+				(*expr)->value.character.string[0]);
+    }
+  else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
+    {
+      if ((*expr)->ref == NULL)
+	{
+	  se->expr = gfc_string_to_single_character
+	    (build_int_cst (integer_type_node, 1),
+	      gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
+				  gfc_get_symbol_decl
+				  ((*expr)->symtree->n.sym)),
+	      (*expr)->ts.kind);
 	}
-      else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
-        {
-	  if ((*expr)->ref == NULL)
-	    {
-	      se->expr = gfc_string_to_single_character
-		(build_int_cst (integer_type_node, 1),
-		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
-				      gfc_get_symbol_decl
-				      ((*expr)->symtree->n.sym)),
-		 (*expr)->ts.kind);
-	    }
-	  else
-	    {
-	      gfc_conv_variable (se, *expr);
-	      se->expr = gfc_string_to_single_character
-		(build_int_cst (integer_type_node, 1),
-		 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
-				      se->expr),
-		 (*expr)->ts.kind);
-	    }
+      else
+	{
+	  gfc_conv_variable (se, *expr);
+	  se->expr = gfc_string_to_single_character
+	    (build_int_cst (integer_type_node, 1),
+	      gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
+				  se->expr),
+	      (*expr)->ts.kind);
 	}
     }
 }
@@ -6341,7 +6329,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      && fsym->ns->proc_name->attr.is_bind_c)
 		    {
 		      parmse.expr = NULL;
-		      gfc_conv_scalar_char_value (fsym, &parmse, &e);
+		      conv_scalar_char_value (fsym, &parmse, &e);
 		      if (parmse.expr == NULL)
 			gfc_conv_expr (&parmse, e);
 		    }
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index eec4aa6f5fc..6262d52657f 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2262,7 +2262,7 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
 
   if (sym->ts.type == BT_CHARACTER
       && ((sym->attr.function && sym->attr.is_bind_c)
-	  || (sym->attr.result
+	  || ((sym->attr.result || sym->attr.value)
 	      && sym->ns->proc_name
 	      && sym->ns->proc_name->attr.is_bind_c)
 	  || (sym->ts.deferred && (!sym->ts.u.cl
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 15012a336ff..f78d5025047 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -508,7 +508,6 @@ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
 tree gfc_get_character_len_in_bytes (tree);
 tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
 tree gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *, gfc_expr *);
-void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);
 tree gfc_string_to_single_character (tree len, tree str, int kind);
 tree gfc_get_tree_for_caf_expr (gfc_expr *);
 void gfc_get_caf_token_offset (gfc_se*, tree *, tree *, tree, tree, gfc_expr *);
diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_3.f90
new file mode 100644
index 00000000000..9fc07144ed0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_char_tests_3.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+! { dg-additional-sources c_char_tests_3_c.c }
+!
+! PR fortran/103828
+! Check that we can pass many function args as C char, which are interoperable
+! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR).
+
+subroutine test_int (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c)
+  use, intrinsic :: iso_c_binding
+  implicit none
+  integer(c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o
+
+  if (a /= iachar('a')) stop 1
+  if (b /= iachar('b')) stop 2
+  if (c /= iachar('c')) stop 3
+  if (d /= iachar('d')) stop 4
+  if (e /= iachar('e')) stop 5
+  if (f /= iachar('f')) stop 6
+  if (g /= iachar('g')) stop 7
+  if (h /= iachar('h')) stop 8
+  if (i /= iachar('i')) stop 9
+  if (j /= iachar('j')) stop 10
+  if (k /= iachar('k')) stop 11
+  if (l /= iachar('l')) stop 12
+  if (m /= iachar('m')) stop 13
+  if (n /= iachar('n')) stop 14
+  if (o /= iachar('o')) stop 15
+end subroutine
+
+subroutine test_char (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c)
+  use, intrinsic :: iso_c_binding
+  implicit none
+  character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o
+
+  if (a /= 'a') stop 101
+  if (b /= 'b') stop 102
+  if (c /= 'c') stop 103
+  if (d /= 'd') stop 104
+  if (e /= 'e') stop 105
+  if (f /= 'f') stop 106
+  if (g /= 'g') stop 107
+  if (h /= 'h') stop 108
+  if (i /= 'i') stop 109
+  if (j /= 'j') stop 110
+  if (k /= 'k') stop 111
+  if (l /= 'l') stop 112
+  if (m /= 'm') stop 113
+  if (n /= 'n') stop 114
+  if (o /= 'o') stop 115
+end subroutine
+
diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_3_c.c b/gcc/testsuite/gfortran.dg/c_char_tests_3_c.c
new file mode 100644
index 00000000000..1c86a549165
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_char_tests_3_c.c
@@ -0,0 +1,16 @@
+void test_char (char, char, char, char, char,
+		char, char, char, char, char,
+		char, char, char, char, char);
+
+void test_int (char, char, char, char, char,
+	       char, char, char, char, char,
+	       char, char, char, char, char);
+
+int main (void) {
+  test_char ('a', 'b', 'c', 'd', 'e',
+	     'f', 'g', 'h', 'i', 'j',
+	     'k', 'l', 'm', 'n', 'o');
+  test_int ('a', 'b', 'c', 'd', 'e',
+	    'f', 'g', 'h', 'i', 'j',
+	    'k', 'l', 'm', 'n', 'o');
+}
diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_4.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_4.f90
new file mode 100644
index 00000000000..512948a2a3f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_char_tests_4.f90
@@ -0,0 +1,90 @@
+! { dg-do run }
+!
+! PR fortran/103828
+! Check that we can pass many function args as C char, which are interoperable
+! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR).
+
+program test
+  use, intrinsic :: iso_c_binding, only : c_signed_char, c_char
+  implicit none
+
+  interface
+    ! In order to perform this test, we cheat and pretend to give each function
+    ! the other one's prototype. It should still work, because all arguments
+    ! are interoperable with C char.
+
+    subroutine test1 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c, name='test_int')
+      import c_char
+      character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o
+    end subroutine test1
+
+    subroutine test2 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c, name='test_char')
+      import c_signed_char
+      integer(kind=c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o
+    end subroutine test2
+
+  end interface
+
+  call test1('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o')
+  call test2(ichar('a', kind=c_signed_char), &
+             ichar('b', kind=c_signed_char), &
+             ichar('c', kind=c_signed_char), &
+             ichar('d', kind=c_signed_char), &
+             ichar('e', kind=c_signed_char), &
+             ichar('f', kind=c_signed_char), &
+             ichar('g', kind=c_signed_char), &
+             ichar('h', kind=c_signed_char), &
+             ichar('i', kind=c_signed_char), &
+             ichar('j', kind=c_signed_char), &
+             ichar('k', kind=c_signed_char), &
+             ichar('l', kind=c_signed_char), &
+             ichar('m', kind=c_signed_char), &
+             ichar('n', kind=c_signed_char), &
+             ichar('o', kind=c_signed_char))
+
+end program test
+
+subroutine test_int (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c)
+  use, intrinsic :: iso_c_binding, only : c_signed_char
+  implicit none
+  integer(c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o
+
+  if (a /= iachar('a')) stop 1
+  if (b /= iachar('b')) stop 2
+  if (c /= iachar('c')) stop 3
+  if (d /= iachar('d')) stop 4
+  if (e /= iachar('e')) stop 5
+  if (f /= iachar('f')) stop 6
+  if (g /= iachar('g')) stop 7
+  if (h /= iachar('h')) stop 8
+  if (i /= iachar('i')) stop 9
+  if (j /= iachar('j')) stop 10
+  if (k /= iachar('k')) stop 11
+  if (l /= iachar('l')) stop 12
+  if (m /= iachar('m')) stop 13
+  if (n /= iachar('n')) stop 14
+  if (o /= iachar('o')) stop 15
+end subroutine
+
+subroutine test_char (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c)
+  use, intrinsic :: iso_c_binding, only : c_char
+  implicit none
+  character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o
+
+  if (a /= 'a') stop 101
+  if (b /= 'b') stop 102
+  if (c /= 'c') stop 103
+  if (d /= 'd') stop 104
+  if (e /= 'e') stop 105
+  if (f /= 'f') stop 106
+  if (g /= 'g') stop 107
+  if (h /= 'h') stop 108
+  if (i /= 'i') stop 109
+  if (j /= 'j') stop 110
+  if (k /= 'k') stop 111
+  if (l /= 'l') stop 112
+  if (m /= 'm') stop 113
+  if (n /= 'n') stop 114
+  if (o /= 'o') stop 115
+end subroutine
+
diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_5.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_5.f90
new file mode 100644
index 00000000000..c7a1c6e8c2b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_char_tests_5.f90
@@ -0,0 +1,49 @@
+! { dg-do run }
+! { dg-options "-fbackslash" }
+!
+! PR fortran/103828
+! Check that we can C char with non-ASCII values, which are interoperable
+! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR).
+
+program test
+  use, intrinsic :: iso_c_binding, only : c_signed_char, c_char
+  implicit none
+
+  interface
+    ! In order to perform this test, we cheat and pretend to give each function
+    ! the other one's prototype. It should still work, because all arguments
+    ! are interoperable with C char.
+
+    subroutine test1 (a) bind(c, name='test_int')
+      import c_char
+      character(kind=c_char, len=1), value :: a
+    end subroutine test1
+
+    subroutine test2 (a) bind(c, name='test_char')
+      import c_signed_char
+      integer(kind=c_signed_char), value :: a
+    end subroutine test2
+
+  end interface
+
+  call test1('\xA3')
+  call test2(-93_c_signed_char)
+
+end program test
+
+subroutine test_int (a) bind(c)
+  use, intrinsic :: iso_c_binding, only : c_signed_char
+  implicit none
+  integer(c_signed_char), value :: a
+
+  if (a /= iachar('\xA3', kind=c_signed_char)) stop 1
+end subroutine
+
+subroutine test_char (a) bind(c)
+  use, intrinsic :: iso_c_binding, only : c_char
+  implicit none
+  character(kind=c_char, len=1), value :: a
+
+  if (a /= '\xA3') stop 101
+end subroutine
+
-- 
2.32.0 (Apple Git-132)

Re: [PATCH] Emit correct types for CHARACTER(C_CHAR), VALUE

[Mikael Morin]

Le 26/12/2021 à 21:09, FX via Fortran a écrit :
> 
> OK to commit?
> 
This looks good, yes.  Thanks.