Fortran: Fixes for kind=4 characters strings [PR107266]

	PR fortran/107266

gcc/fortran/
	* trans-expr.cc (gfc_conv_string_parameter): Use passed
	type to honor character kind.
	* trans-types.cc (gfc_sym_type): Honor character kind.
	* trans-decl.cc (gfc_conv_cfi_to_gfc): Fix handling kind=4
	character strings.

gcc/testsuite/
	* gfortran.dg/char4_decl.f90: New test.
	* gfortran.dg/char4_decl-2.f90: New test.

(cherry picked from commit c610cf20ebb3444ef4224d789aca670a12f5da40)

diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp
index c0da9049a32a9a9d9becd8f7b983ef8b77408032..685fe68667a4cfc8ce5d74722558d1f3df829f63 100644 (file)
--- a/gcc/fortran/ChangeLog.omp
+++ b/gcc/fortran/ChangeLog.omp
@@ -1,3 +1,15 @@
+2022-10-17  Tobias Burnus  <tobias@codesourcery.com>
+
+       Backport from mainline:
+       2022-10-17  Tobias Burnus  <tobias@codesourcery.com>
+
+       PR fortran/107266
+       * trans-expr.cc (gfc_conv_string_parameter): Use passed
+       type to honor character kind.
+       * trans-types.cc (gfc_sym_type): Honor character kind.
+       * trans-decl.cc (gfc_conv_cfi_to_gfc): Fix handling kind=4
+       character strings.
+
 2022-10-05  Tobias Burnus  <tobias@codesourcery.com>
 
        Backport from mainline:

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 344df1a7d234e76a5838b6e5f19015dec7f3c448..99e6b60a3cdfabdb2cc2931a05244ffc05563dee 100644 (file)
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -7401,13 +7401,13 @@ done:
   /* Set string length for len=:, only.  */
   if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
     {
-      tmp = sym->ts.u.cl->backend_decl;
+      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+      tmp = fold_convert (TREE_TYPE (tmp2), sym->ts.u.cl->backend_decl);
       if (sym->ts.kind != 1)
        tmp = fold_build2_loc (input_location, MULT_EXPR,
-                              gfc_array_index_type,
-                              sym->ts.u.cl->backend_decl, tmp);
-      tmp2 = gfc_get_cfi_desc_elem_len (cfi);
-      gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+                              TREE_TYPE (tmp2), tmp,
+                              build_int_cst (TREE_TYPE (tmp2), sym->ts.kind));
+      gfc_add_modify (&block, tmp2, tmp);
     }
 
   if (!sym->attr.dimension)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index eb113d0ceec8e048ef8c6ecdc7f8d6809e641434..05d57fbe9f5ee4de532899b09ace49a01985c32d 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -10358,15 +10358,15 @@ gfc_conv_string_parameter (gfc_se * se)
        || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
       && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
     {
+      type = TREE_TYPE (se->expr);
       if (TREE_CODE (se->expr) != INDIRECT_REF)
-       {
-         type = TREE_TYPE (se->expr);
-          se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
-       }
+       se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
       else
        {
-         type = gfc_get_character_type_len (gfc_default_character_kind,
-                                            se->string_length);
+         if (TREE_CODE (type) == ARRAY_TYPE)
+           type = TREE_TYPE (type);
+         type = gfc_get_character_type_len_for_eltype (type,
+                                                       se->string_length);
          type = build_pointer_type (type);
          se->expr = gfc_build_addr_expr (type, se->expr);
        }

diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index c109c14ca4be4fe788de1cc84036a38ff6ed0b2f..2dc25347b691174ac15d8b23d9d8ffa6cd31d01a 100644 (file)
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -2310,7 +2310,7 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
              && sym->ns->proc_name->attr.is_bind_c)
          || (sym->ts.deferred && (!sym->ts.u.cl
                                   || !sym->ts.u.cl->backend_decl))))
-    type = gfc_character1_type_node;
+    type = gfc_get_char_type (sym->ts.kind);
   else
     type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
 

diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index 4f1976b82092a3c8f7b6c043382ca0cbf2af1544..b2b4381e3cebe8489de1595b7c4e3676b86fa4aa 100644 (file)
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,13 @@
+2022-10-17  Tobias Burnus  <tobias@codesourcery.com>
+
+       Backport from mainline:
+       2022-10-17  Tobias Burnus  <tobias@codesourcery.com>
+
+       PR fortran/107266
+       PR fortran/107266
+       * gfortran.dg/char4_decl.f90: New test.
+       * gfortran.dg/char4_decl-2.f90: New test.
+
 2022-10-12  Andrew Stubbs  <ams@codesourcery.com>
 
        Backport from mainline:

diff --git a/gcc/testsuite/gfortran.dg/char4_decl-2.f90 b/gcc/testsuite/gfortran.dg/char4_decl-2.f90
new file mode 100644 (file)
index 0000000..d646161
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char4_decl-2.f90
@@ -0,0 +1,63 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+
+! In this program shall be no kind=1,
+! except for the 'argv' of the 'main' program.
+
+! PR fortran/107266
+
+! { dg-final { scan-tree-dump-times "kind=1" 1 "original" } }
+! { dg-final { scan-tree-dump-times "character\\(kind=1\\) \\* \\* argv\\)" 1 "original" } }
+
+
+! { dg-final { scan-tree-dump-times "character\\(kind=4\\) f \\(character\\(kind=4\\) x\\)" 1 "original" } }
+
+character(kind=4) function f(x) bind(C)
+  character(kind=4), value :: x
+end
+
+program testit
+  implicit none (type, external)
+  character (kind=4, len=:), allocatable :: aa
+  character (kind=4, len=:), pointer :: pp
+
+  pp => NULL ()
+
+  call frobf (aa, pp)
+  if (.not. allocated (aa)) stop 101
+  if (storage_size(aa) /= storage_size(4_'foo')) stop 1
+  if (aa .ne. 4_'foo') stop 102
+  if (.not. associated (pp)) stop 103
+  if (storage_size(pp) /= storage_size(4_'bar')) stop 2
+  if (pp .ne. 4_'bar') stop 104
+
+  pp => NULL ()
+
+  call frobc (aa, pp)
+  if (.not. allocated (aa)) stop 105
+  if (storage_size(aa) /= storage_size(4_'frog')) stop 3
+  if (aa .ne. 4_'frog') stop 106
+  if (.not. associated (pp)) stop 107
+  if (storage_size(pp) /= storage_size(4_'toad')) stop 4
+  if (pp .ne. 4_'toad') stop 108
+
+
+  contains
+
+    subroutine frobf (a, p) Bind(C)
+      character (kind=4, len=:), allocatable :: a
+      character (kind=4, len=:), pointer :: p
+      allocate (character(kind=4, len=3) :: p)
+      a = 4_'foo'
+      p = 4_'bar'
+    end subroutine
+
+    subroutine frobc (a, p) Bind(C)
+      character (kind=4, len=:), allocatable :: a
+      character (kind=4, len=:), pointer :: p
+      allocate (character(kind=4, len=4) :: p)
+      a = 4_'frog'
+      p = 4_'toad'
+    end subroutine
+
+end program

diff --git a/gcc/testsuite/gfortran.dg/char4_decl.f90 b/gcc/testsuite/gfortran.dg/char4_decl.f90
new file mode 100644 (file)
index 0000000..bb6b6a8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char4_decl.f90
@@ -0,0 +1,56 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+
+! In this program shall be no kind=1,
+! except for the 'argv' of the 'main' program.
+
+! Related PR fortran/107266
+
+! { dg-final { scan-tree-dump-times "kind=1" 1 "original" } }
+! { dg-final { scan-tree-dump-times "character\\(kind=1\\) \\* \\* argv\\)" 1 "original" } }
+
+program testit
+  implicit none (type, external)
+  character (kind=4, len=:), allocatable :: aa
+  character (kind=4, len=:), pointer :: pp
+
+  pp => NULL ()
+
+  call frobf (aa, pp)
+  if (.not. allocated (aa)) stop 101
+  if (storage_size(aa) /= storage_size(4_'foo')) stop 1
+  if (aa .ne. 4_'foo') stop 102
+  if (.not. associated (pp)) stop 103
+  if (storage_size(pp) /= storage_size(4_'bar')) stop 2
+  if (pp .ne. 4_'bar') stop 104
+
+  pp => NULL ()
+
+  call frobc (aa, pp)
+  if (.not. allocated (aa)) stop 105
+  if (storage_size(aa) /= storage_size(4_'frog')) stop 3
+  if (aa .ne. 4_'frog') stop 106
+  if (.not. associated (pp)) stop 107
+  if (storage_size(pp) /= storage_size(4_'toad')) stop 4
+  if (pp .ne. 4_'toad') stop 108
+
+
+  contains
+
+    subroutine frobf (a, p)
+      character (kind=4, len=:), allocatable :: a
+      character (kind=4, len=:), pointer :: p
+      allocate (character(kind=4, len=3) :: p)
+      a = 4_'foo'
+      p = 4_'bar'
+    end subroutine
+
+    subroutine frobc (a, p)
+      character (kind=4, len=:), allocatable :: a
+      character (kind=4, len=:), pointer :: p
+      allocate (character(kind=4, len=4) :: p)
+      a = 4_'frog'
+      p = 4_'toad'
+    end subroutine
+
+end program