From patchwork Tue Jan 11 21:17:12 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 49891 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 00553393A417 for ; Tue, 11 Jan 2022 21:18:00 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 00553393A417 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1641935881; bh=g5sUhsggTFx9wJmwxMbLXcrZYZmpVahyj3Rm5RAppsA=; h=To:Subject:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=bxSSTK6zxEYmD+Aw/5igNLo/VDm0VAQVOZOHxalLO9blCG0yS1tsqdf5y8OhPX/G3 PizI4CCme7mmeWZeKo+0kaxEl9x2xG4gBKCWjFiYLaoCoaVK3VDg7cWi5HDoyWi0Td DZ156uS2scYlkxj4TiOu/HghWFy1h40bD7tFQZlc= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.17.22]) by sourceware.org (Postfix) with ESMTPS id 00A0B3858029; Tue, 11 Jan 2022 21:17:13 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 00A0B3858029 X-UI-Sender-Class: 01bb95c1-4bf8-414a-932a-4f6e2808ef9c Received: from [79.251.13.44] ([79.251.13.44]) by web-mail.gmx.net (3c-app-gmx-bs15.server.lan [172.19.170.67]) (via HTTP); Tue, 11 Jan 2022 22:17:12 +0100 MIME-Version: 1.0 Message-ID: To: fortran , gcc-patches Subject: [PATCH] PR fortran/83079 - ICE and wrong code with TRANSFER and character(kind=4) Date: Tue, 11 Jan 2022 22:17:12 +0100 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:dkv7pJmSfCvF239z5uHkoRw+5XCZSYR7qUiXAfyRpICJCxOyAoxBtRDFp4djw+eyhe3JT CGIh7IArrM5HDrNJ8eBpjCW7Ckhj3tfegHpApR4vSq0M0e+mI7pYrMSm6oAeb3GHG2WFyjyheg35 dmRTGwHFGOuQIh+82xU3KvC0QK9EBCCJNM62+jMqHfKNwxLtmwNNcVKS1tFh3tJs0OXx7gaQz6M8 owWyyOLEZlDPrPfxa7rN4n5nXWMre6zBHYMEA7YboIR8FhfobNBdL7o6Uwn9SLAWzu4IIq5bCW1B hY= X-UI-Out-Filterresults: notjunk:1;V03:K0:aqjc0oigEx8=:m6igRjueHI//O/UaYGUgmp 8ku2d3HTFaVJzteMEK/54kkThOaNf6sZRX73cfUby4PdgCjJiUygf/ahskSd+Fw/NKKJGQhkr WdJyDOBSV2tlbXWvYyG3LEL+zB9wyT1T3auNhkPiAnrp9wAQSh1Zoh36Vabycl/LF5r2BOHYl oqUwdZkBJ+YIB7pj+teVLzE/0p09WBCzX9lUrMMMyUZZgxWxb1jbLFEcDMD0NFtkVR5zLdzyP V6afaYm3XdClvhwkrx7GS1Soy21nDVYxxjpwgxJMprDwN0HLsOxl1MlHRtIXRXBeugLFCUtco PBQv6wkucD5q6KVzSk68kMJYP7A5VlRu1f6kc0pWtY5e8/0m0L9rVYL/wDzRsytIeVkJi1dDJ qQaueaCrn8pjL0lFfEMcRWR4TtjT2zplDZqjZ4wiVHZUNbFwdCYtkCsNBwxbhOFOnxCLT0sVR g6lS5kqKPx/SZsh5PoqFHP6fY746kXr/SN/LC8D54G1xLXim0CcXmAyv8L0/RBYFFOfxNnG0o GXJz6sWtI38MtFfAYnyzoOetPiQqL9PNsB5rD4Oejiy5ztmslBQFDoG340ndLo1176oUv+7ve ZbzbpmTWyaRzIlsbKTWnFbAQupOsyb52TnyA1/GDRO+gYWxaZRZeFq0c56LKgzZCwrk4dLhmh j/qs5rGvp/zZAeT+m58S+2oundgfg9kt4F9tVut3eNFszF9fkB+Gu7K3+l9CisARP6fxylDJQ 4nIcnCv6gYvgjKGNHYcpkBz17wNp8vCLn3LT+VlqsWGx2TomdRT8+PdfObJd22Jglz6uKujvv fXsHSvT X-Spam-Status: No, score=-11.6 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H5, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Harald Anlauf via Gcc-patches From: Harald Anlauf Reply-To: Harald Anlauf Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Dear Fortranners, when digging into the issue pointed out in the PR by Gerhard it turned out that there were several issues with the TRANSFER intrinsics in the case MOLD was CHARACTER(kind=4). Default CHARACTER was fine, though. - the size of the result was wrongly calculated - the string length used in temporaries was wrong - the result characteristics was wrong Fortunately, the few fixes were very local and needed only fix-ups of the respective computations. Since the details of which issue would show up seemed to depend on the properties of a the arguments to TRANSFER, I wrote an extended testcase which is a "hull" of what I used in debugging. (The testcase was and can be cross-checked with the NAG compiler.) Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald From cb14e9a1975bc9d9d2f544c314a0820f68b8bdc7 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Tue, 11 Jan 2022 22:06:10 +0100 Subject: [PATCH] Fortran: fix ICE and wrong code with TRANSFER and CHARACTER(kind=4) gcc/fortran/ChangeLog: PR fortran/83079 * target-memory.c (gfc_interpret_character): Result length is in bytes and thus depends on the character kind. * trans-intrinsic.c (gfc_conv_intrinsic_transfer): Compute correct string length for the result of the TRANSFER intrinsic and for temporaries for the different character kinds. gcc/testsuite/ChangeLog: PR fortran/83079 * gfortran.dg/transfer_char_kind4.f90: New test. --- gcc/fortran/target-memory.c | 2 +- gcc/fortran/trans-intrinsic.c | 17 ++- .../gfortran.dg/transfer_char_kind4.f90 | 115 ++++++++++++++++++ 3 files changed, 130 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/transfer_char_kind4.f90 diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index af1c21047f6..9b5af8d1482 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -485,7 +485,7 @@ gfc_interpret_character (unsigned char *buffer, size_t buffer_size, result->value.character.string[result->value.character.length] = '\0'; - return result->value.character.length; + return size_character (result->value.character.length, result->ts.kind); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index aae34b06948..5821b2264ce 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8531,7 +8531,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) { case BT_CHARACTER: tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); - mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp); + mold_type = gfc_get_character_type_len (arg->expr->ts.kind, + argse.string_length); break; case BT_CLASS: tmp = gfc_class_vtab_size_get (argse.expr); @@ -8633,7 +8634,13 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) se->expr = info->descriptor; if (expr->ts.type == BT_CHARACTER) - se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len); + { + tmp = fold_convert (gfc_charlen_type_node, + TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind))); + se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_charlen_type_node, + dest_word_len, tmp); + } return; @@ -8687,7 +8694,11 @@ scalar_transfer: gfc_add_expr_to_block (&se->post, tmp); se->expr = tmpdecl; - se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len); + tmp = fold_convert (gfc_charlen_type_node, + TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind))); + se->string_length = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_charlen_type_node, + dest_word_len, tmp); } else { diff --git a/gcc/testsuite/gfortran.dg/transfer_char_kind4.f90 b/gcc/testsuite/gfortran.dg/transfer_char_kind4.f90 new file mode 100644 index 00000000000..5f1fe691318 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/transfer_char_kind4.f90 @@ -0,0 +1,115 @@ +! { dg-do run } +! PR fortran/83079 - ICE and wrong code with TRANSFER and character(kind=4) +! Exercise TRANSFER intrinsic to check character result length and shape + +program p + implicit none + character(len=*,kind=4), parameter :: a = 4_'ABCDEF' + character(len=6,kind=4) :: b = 4_'abcdef' + character(len=*,kind=4), parameter :: c = 4_'XY' + character(len=2,kind=4) :: d = 4_'xy' + integer :: k, l + k = len (a) + l = len (c) + +! print *, transfer(4_'xy', [4_'a']) + + ! TRANSFER with rank-0 result + call chk0 (transfer (4_'ABCD', 4_'XY'), 2, 1) + call chk0 (transfer (4_'ABCD', c ), l, 2) + call chk0 (transfer (4_'ABCD', d ), l, 3) + call chk0 (transfer (a , 4_'XY'), 2, 4) + call chk0 (transfer (a , c ), l, 5) + call chk0 (transfer (a , d ), l, 6) + call chk0 (transfer (b , 4_'XY'), 2, 7) + call chk0 (transfer (b , c ), l, 8) + call chk0 (transfer (b , d ), l, 9) + + call chk0 (transfer ([4_'ABCD'], 4_'XY'), 2, 11) + call chk0 (transfer ([4_'ABCD'], c ), l, 12) + call chk0 (transfer ([4_'ABCD'], d ), l, 13) + call chk0 (transfer ([a ], 4_'XY'), 2, 14) + call chk0 (transfer ([a ], c ), l, 15) + call chk0 (transfer ([a ], d ), l, 16) + call chk0 (transfer ([b ], 4_'XY'), 2, 17) + call chk0 (transfer ([b ], c ), l, 18) + call chk0 (transfer ([b ], d ), l, 19) + + ! TRANSFER with rank-1 result + call chk1 (transfer (4_'ABCD', [4_'XY']), 2, 2, 21) + call chk1 (transfer (4_'ABCD', [c] ), 2, 2, 22) + call chk1 (transfer (4_'ABCD', [d] ), 2, 2, 23) + call chk1 (transfer (a , [4_'XY']), 2, k/2, 24) + call chk1 (transfer (a , [c] ), l, k/l, 25) + call chk1 (transfer (a , [d] ), l, k/l, 26) + call chk1 (transfer (b , [4_'XY']), 2, k/2, 27) + call chk1 (transfer (b , [c] ), l, k/l, 28) + call chk1 (transfer (b , [d] ), l, k/l, 29) + + call chk1 (transfer (4_'ABCD', 4_'XY',size=2), 2, 2, 31) + call chk1 (transfer (4_'ABCD', c ,size=2), 2, 2, 32) + call chk1 (transfer (4_'ABCD', d ,size=2), 2, 2, 33) + call chk1 (transfer (a , 4_'XY',size=3), 2, 3, 34) + call chk1 (transfer (a , c ,size=3), l, 3, 35) + call chk1 (transfer (a , d ,size=3), l, 3, 36) + call chk1 (transfer (b , 4_'XY',size=3), 2, 3, 37) + call chk1 (transfer (b , c ,size=3), l, 3, 38) + call chk1 (transfer (b , d ,size=3), l, 3, 39) + + call chk1 (transfer (4_'ABCD', [4_'XY'],size=2), 2, 2, 41) + call chk1 (transfer (4_'ABCD', [c] ,size=2), 2, 2, 42) + call chk1 (transfer (4_'ABCD', [d] ,size=2), 2, 2, 43) + call chk1 (transfer (a , [4_'XY'],size=3), 2, 3, 44) + call chk1 (transfer (a , [c] ,size=3), l, 3, 45) + call chk1 (transfer (a , [d] ,size=3), l, 3, 46) + call chk1 (transfer (b , [4_'XY'],size=3), 2, 3, 47) + call chk1 (transfer (b , [c] ,size=3), l, 3, 48) + call chk1 (transfer (b , [d] ,size=3), l, 3, 49) + + call chk1 (transfer ([4_'ABCD'], [4_'XY']), 2, 2, 51) + call chk1 (transfer ([4_'ABCD'], [c] ), 2, 2, 52) + call chk1 (transfer ([4_'ABCD'], [d] ), 2, 2, 53) + call chk1 (transfer ([a ], [4_'XY']), 2, k/2, 54) + call chk1 (transfer ([a ], [c] ), l, k/l, 55) + call chk1 (transfer ([a ], [d] ), l, k/l, 56) + call chk1 (transfer ([b ], [4_'XY']), 2, k/2, 57) + call chk1 (transfer ([b ], [c] ), l, k/l, 58) + call chk1 (transfer ([b ], [d] ), l, k/l, 59) + + call chk1 (transfer (4_'ABCD', c ,size=4/l), l, 4/l, 62) + call chk1 (transfer (4_'ABCD', d ,size=4/l), l, 4/l, 63) + call chk1 (transfer (a , 4_'XY',size=k/2), 2, k/2, 64) + call chk1 (transfer (a , c ,size=k/l), l, k/l, 65) + call chk1 (transfer (a , d ,size=k/l), l, k/l, 66) + call chk1 (transfer (b , 4_'XY',size=k/2), 2, k/2, 67) + call chk1 (transfer (b , c ,size=k/l), l, k/l, 68) + call chk1 (transfer (b , d ,size=k/l), l, k/l, 69) + +contains + ! Validate rank-0 result + subroutine chk0 (str, l, stopcode) + character(kind=4,len=*), intent(in) :: str + integer, intent(in) :: l, stopcode + integer :: i, p + i = len (str) + p = verify (str, a // b) ! Check for junk characters + if (i /= l .or. p > 0) then + print *, stopcode, "len=", i, i == l, ">", str, "<" + stop stopcode + end if + end subroutine chk0 + + ! Validate rank-1 result + subroutine chk1 (str, l, m, stopcode) + character(kind=4,len=*), intent(in) :: str(:) + integer, intent(in) :: l, m, stopcode + integer :: i, j, p + i = len (str) + j = size (str) + p = maxval (verify (str, a // b)) ! Check for junk characters + if (i /= l .or. j /= m .or. p > 0) then + print *, stopcode, "len=", i, i == l, "size=", j, j == m, ">", str, "<" + stop stopcode + end if + end subroutine chk1 +end -- 2.31.1