From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1534) id 355233852767; Mon, 17 Oct 2022 16:15:39 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 355233852767 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1666023339; bh=gQ6kmxcOXMbmQD/v+wfeFIljTkJTXmtepuVtycSjQMU=; h=From:To:Subject:Date:From; b=udlIy9qc8JBwhopgyo/pD9SF4RtzcXhngHhQWeNAP8Mczr4QTAdqmTRh7UEsvNAlJ /q9IoLyW0pIywDfPCQlGxkPEvMPaAqHAZ0uTwM3jywQ/Syk0+KURWo/kOU5bOfLHqN 9wyBTdsUnL3+AB53EztFEaaA8cd7RP5xJ6Rt0KtI= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Tobias Burnus To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-3338] Fortran: Fixes for kind=4 characters strings [PR107266] X-Act-Checkin: gcc X-Git-Author: Tobias Burnus X-Git-Refname: refs/heads/master X-Git-Oldrev: 3bd5d9a28e1ce4d1615902397b5ad50909839d6d X-Git-Newrev: 8950288333162caa68b85c71ed2d02f40976ddb9 Message-Id: <20221017161539.355233852767@sourceware.org> Date: Mon, 17 Oct 2022 16:15:39 +0000 (GMT) List-Id: https://gcc.gnu.org/g:8950288333162caa68b85c71ed2d02f40976ddb9 commit r13-3338-g8950288333162caa68b85c71ed2d02f40976ddb9 Author: Tobias Burnus Date: Mon Oct 17 18:15:16 2022 +0200 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. Diff: --- gcc/fortran/trans-decl.cc | 10 ++--- gcc/fortran/trans-expr.cc | 12 +++--- gcc/fortran/trans-types.cc | 2 +- gcc/testsuite/gfortran.dg/char4_decl-2.f90 | 63 ++++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/char4_decl.f90 | 56 ++++++++++++++++++++++++++ 5 files changed, 131 insertions(+), 12 deletions(-) diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 5d16d640322..4b570c3551a 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -7378,13 +7378,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 1551a2e4df4..e7b9211f17e 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -10374,15 +10374,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 c062a5b29d7..fdce56defec 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -2314,7 +2314,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/gfortran.dg/char4_decl-2.f90 b/gcc/testsuite/gfortran.dg/char4_decl-2.f90 new file mode 100644 index 00000000000..d6461614a4f --- /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 index 00000000000..bb6b6a8318a --- /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