From patchwork Sat Apr 13 17:41:09 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Harald Anlauf X-Patchwork-Id: 1923383 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=gmx.de header.i=anlauf@gmx.de header.a=rsa-sha256 header.s=s31663417 header.b=I7t9KNTY; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4VH12b1H04z1yYp for ; Sun, 14 Apr 2024 03:41:41 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 879A73849AF9 for ; Sat, 13 Apr 2024 17:41:37 +0000 (GMT) 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.15.19]) by sourceware.org (Postfix) with ESMTPS id D224F3858C50; Sat, 13 Apr 2024 17:41:10 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D224F3858C50 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org D224F3858C50 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.15.19 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1713030073; cv=none; b=AOh4fN559WlxqfeKlTTR+bc1bQbAuV9Nxu87KHIZ/Al5qCDzE7jAPU/ZWINW7ZXGbhbIEiWJ4YpAjvGtAjfhUM/EEJrikJhHt8/egMEfO2nR30AgZ4pUUpInSkcZk8a3XnpUEYQ5wBMbzhRADVLgDvZaRIKdlVG8eJ2Jn8Uy+Nw= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1713030073; c=relaxed/simple; bh=cPqOYlIv9f6OhP5tcAoSBs8QzGGaRjq2yERGjvhYQqw=; h=DKIM-Signature:MIME-Version:Message-ID:From:To:Subject:Date; b=ewKRCX1YzUnAYrsdy+9zmR/jApJ/NzeHPxAKHS7D+BC/tMfnh+m3CIjCn1IcFs1X/7o+Y5RD1PjpAu5BJJfouDf7EWmCjEGkeSa0Jhvpe/rIgHjQXe7h04XPIEyyhDkZaQaGvPYXuZNm8LWpJc1BB6alWqRt09SEZxdmKricttM= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmx.de; s=s31663417; t=1713030069; x=1713634869; i=anlauf@gmx.de; bh=A6bV2vjQH8q+OVaMCa1tlHG8Rc60KpDzAasVZtb+D9s=; h=X-UI-Sender-Class:From:To:Subject:Date; b=I7t9KNTYN9Nvc2SK1tb7nCrvKtUIuKpT0X7EoxYqfIeGRbs+8zAEIUIb+LwMLyUm o9h9X+3uFuI1HGZ2R1RJFiyxUmxLYxJscUbSaLCkrcICDjqmaxWh2WPSvOrAufDwK RYbxYzini7iesPcLRAY/yGWS1JdamIJaSLVkZEbpLi35YYnXQ0D3oRmP+4UEHYw4b DKoIURxVIfGURpVwtBBLhQXatqPeOKT0WSR4jKmGWI94rKa3zPkGL9Lls59jvT3Ka qlNXMqFAfv2FcxqSi9pZ9//yiJqduIoIr2fZ8/kTdCPBRDNM8t5dA2IDZ7Y35NybS +9KZipmf2ML4p5sF/g== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from [79.232.156.17] ([79.232.156.17]) by web-mail.gmx.net (3c-app-gmx-bs31.server.lan [172.19.170.83]) (via HTTP); Sat, 13 Apr 2024 19:41:09 +0200 MIME-Version: 1.0 Message-ID: From: Harald Anlauf To: fortran , gcc-patches Subject: [PATCH] Fortran: ALLOCATE of fixed-length CHARACTER with SOURCE/MOLD [PR113793] Date: Sat, 13 Apr 2024 19:41:09 +0200 Importance: normal Sensitivity: Normal X-Priority: 3 X-Provags-ID: V03:K1:mIkbsELlZEmeH0qq4hZ7Tax56rHn7oT64HvJvJQsI5Vm0gSTbI6xavdQg+z3vY/30azWL mq5VkS1BdizkKUell+BDPvMXPX6eIHHIpDYZ9hkroqJbLMXVIqlSpf9mHlZLxSGtgRfg868PJIyA TZZdePuWra0qj2380wSg2wqGQP2vYNNeJ7yN0zC2X7NySgMD1zXR/oJrQ+QTRV5Yxsur66c2gOai 7nNuoO9cS+nLvyWBs7nLU2inNDuIer+M3JqrTz/IXuzZ0o3u0MHgWZaor4KnJxtc0gF9ZWLbO5jZ fY= UI-OutboundReport: notjunk:1;M01:P0:w0J0X5y9MNw=;1Ujjf6wr3etxp9C+tCNCW3WtLof 7XpBn1HK2Ayuj6E/etCRK6pvbRHWlq+uvP+2HsdTYgaPeL+tpNJ2QHtEhwvzZMzO3ijR9STt1 1H7kWqxLaQOnWSuf6323ZsXEDxF4xhP9+dQGZsifnxtRlgZ2mt8wuuHi3ppZA1f/0fTHSm6/Q VpYXAv7vpYHBGcv8EaW76oVujMWtF0Iy5gaxEQpUgkGK112pjPZvxqkX+wTO67FlVcTWGhG02 i9JiOZuHCXPiAOaNvhXyUDpMXsS3ZWYz3o2N2nXEWXvUNg6S42ak1BCTzFgaiTBiFtBuyCgm9 LalkdH7gPen/NEofvMnzDunpK4+mC7N0bVgdwjpa+Cc1PVHZ4EcuB1ixiVXd0S+Xh27w+3Po8 3Io4iSoTQFI7CPD3fERM016N77rNovnxv3zUrI1tuqEFsG3QAU/hv3NZe576rJUMH1oI28SCf EwTQCq5vkY8hQP+nYHUojMI/dnHcA046iDQoowl4Kfvu/Fi/QdwUHJNlRqD3awY58nLUZ5eoC y51ZEAJPsH1+ivxV/Fx4Md/ODWU/9I2QUGvoPD6fUc9fWaJ19ev+PmRrnSvKfkBES3AKrKjqV f/P4W0heuFw//Z6Km4DIL3OH5vfBBNIKAS17DCf+qfQjgQmjhu0bK34J2I889lQ8f045Kv2lg hvDV/a3tv0mYcg2Quv0THu0kGOJKH6K9h7wPQ+qOLuEFA0qO1JRxNL52i3R1PGk= X-Spam-Status: No, score=-12.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H2, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Dear all, the attached patch adds the following: - diagnostics of different string length of allocate-object and of the source-expr (SOURCE/MOLD) as hard error when it can be determined at compile-time - a runtime-diagnostics und -fcheck=bounds (reuse of existing checks) - a fallback solution (GNU extension) to use the length of allocate-object if the length mismatch is not diagnosed at compile-time or runtime. This avoids heap corruption and leads to string truncation or padding during assignment. F2008 demands same values of the kind type parameters, and this is diagnosed by NAG. It also always gives a hard error, even at runtime. Some brands (NVidia, AMD flang) tolerate a length mismatch silently and perform string truncation or padding, without crashing. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald From b9ece695a178319e35cd9f36cc731855302dd57f Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Sat, 13 Apr 2024 19:09:24 +0200 Subject: [PATCH] Fortran: ALLOCATE of fixed-length CHARACTER with SOURCE/MOLD [PR113793] F2008 requires for ALLOCATE with SOURCE= or MOLD= specifier that the kind type parameters of allocate-object and source-expr have the same values. Add compile-time diagnostics for different character length and a runtime check (under -fcheck=bounds). Use length from allocate-object to prevent heap corruption and to allow string padding or truncation on assignment. gcc/fortran/ChangeLog: PR fortran/113793 * resolve.cc (resolve_allocate_expr): Reject ALLOCATE with SOURCE= or MOLD= specifier for unequal length. * trans-stmt.cc (gfc_trans_allocate): If an allocatable character variable has fixed length, use it and do not use the source length. With bounds-checking enabled, add a runtime check for same length. gcc/testsuite/ChangeLog: PR fortran/113793 * gfortran.dg/allocate_with_source_29.f90: New test. * gfortran.dg/allocate_with_source_30.f90: New test. * gfortran.dg/allocate_with_source_31.f90: New test. --- gcc/fortran/resolve.cc | 10 ++++ gcc/fortran/trans-stmt.cc | 36 +++++++++++-- .../gfortran.dg/allocate_with_source_29.f90 | 48 +++++++++++++++++ .../gfortran.dg/allocate_with_source_30.f90 | 51 +++++++++++++++++++ .../gfortran.dg/allocate_with_source_31.f90 | 38 ++++++++++++++ 5 files changed, 179 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_29.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_30.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_31.f90 diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 4cbf7186119..6b3e5ba4fcb 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -8278,6 +8278,16 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) goto failure; } + /* Check F2008:C639: "Corresponding kind type parameters of + allocate-object and source-expr shall have the same values." */ + if (e->ts.type == BT_CHARACTER + && !e->ts.deferred + && e->ts.u.cl->length + && code->expr3->ts.type == BT_CHARACTER + && !gfc_check_same_strlen (e, code->expr3, "ALLOCATE with " + "SOURCE= or MOLD= specifier")) + goto failure; + /* Check TS18508, C702/C703. */ if (code->expr3->ts.type == BT_DERIVED && ((codimension && gfc_expr_attr (code->expr3).event_comp) diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 7997c167bae..c34e0b4c0cd 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -6829,10 +6829,26 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) in the array is needed, which is the product of the len and esize for char arrays. For unlimited polymorphics len can be zero, therefore take the maximum of len and one. */ + tree lhs_len; + + /* If an allocatable character variable has fixed length, use it. + Otherwise use source length. As different lengths are not + allowed by the standard, generate a runtime check. */ + if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred) + { + gfc_trans_same_strlen_check ("ALLOCATE with SOURCE= or MOLD=", + &code->expr3->where, + se.string_length, expr3_len, + &block); + lhs_len = fold_convert (TREE_TYPE (expr3_len), se.string_length); + } + else + lhs_len = expr3_len; + tmp = fold_build2_loc (input_location, MAX_EXPR, TREE_TYPE (expr3_len), - expr3_len, fold_convert (TREE_TYPE (expr3_len), - integer_one_node)); + lhs_len, fold_convert (TREE_TYPE (expr3_len), + integer_one_node)); tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (expr3_esize), expr3_esize, fold_convert (TREE_TYPE (expr3_esize), tmp)); @@ -6877,10 +6893,22 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) allocate. expr3_len is set when expr3 is an unlimited polymorphic - object or a deferred length string. */ + object or a deferred length string. + + If an allocatable character variable has fixed length, use it. + Otherwise use source length. As different lengths are not + allowed by the standard, a runtime check was inserted + above. */ if (expr3_len != NULL_TREE) { - tmp = fold_convert (TREE_TYPE (expr3_esize), expr3_len); + tree lhs_len; + if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred) + lhs_len = fold_convert (TREE_TYPE (expr3_len), + se.string_length); + else + lhs_len = expr3_len; + + tmp = fold_convert (TREE_TYPE (expr3_esize), lhs_len); tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (expr3_esize), expr3_esize, tmp); diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_29.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_29.f90 new file mode 100644 index 00000000000..b3d4c8ae520 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_29.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! PR fortran/113793 +! +! Static checks of string length for ALLOCATE with SOURCE= or MOLD= + +program p + implicit none + character(kind=1,len=8), allocatable :: a(:), d, b(:,:) + character(kind=4,len=6), allocatable :: c(:), e, f(:,:) + character(kind=1,len=2) :: c1 = "xx" + character(kind=1,len=8) :: c2 = "yy" + character(kind=4,len=6) :: c3 = 4_"ww" + character(kind=4,len=3) :: c4 = 4_"zz" + + ALLOCATE (a(1),source= "a") ! { dg-error "Unequal character lengths .8/1. " } + ALLOCATE (a(2),mold = "bb") ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (c(3),source=4_"yyy") ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (c(4),mold =4_"zzzz") ! { dg-error "Unequal character lengths .6/4. " } + ALLOCATE (d, source= "12345") ! { dg-error "Unequal character lengths .8/5. " } + ALLOCATE (d, source= "12345678") + ALLOCATE (d, mold = "123456") ! { dg-error "Unequal character lengths .8/6. " } + ALLOCATE (e, source=4_"654321") + ALLOCATE (e, mold =4_"7654321") ! { dg-error "Unequal character lengths .6/7. " } + ALLOCATE (a(5),source=c1) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (a(6),mold =c1) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (c(7),source=c4) ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (c(8),mold =c4) ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (a,source=[c1,c1,c1]) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (a,source=[c2,c2,c2]) + ALLOCATE (c,source=[c3,c3]) + ALLOCATE (c,source=[c4,c4]) ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (d,source=c1) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (e,source=c4) ! { dg-error "Unequal character lengths .6/3. " } + ALLOCATE (b,source=reshape([c1],[1,1])) ! { dg-error "Unequal character lengths .8/2. " } + ALLOCATE (b,source=reshape([c2],[1,1])) + ALLOCATE (f,source=reshape([c3],[1,1])) + ALLOCATE (f,source=reshape([c4],[1,1])) ! { dg-error "Unequal character lengths .6/3. " } +contains + subroutine foo (s) + character(*), intent(in) :: s + character(len=8), allocatable :: f(:), g + ALLOCATE (f(3), source=s) + ALLOCATE (d, source=s) + ALLOCATE (f(3), mold=s) + ALLOCATE (d, mold=s) + end +end diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_30.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_30.f90 new file mode 100644 index 00000000000..f8a71d11708 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_30.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-additional-options "-std=f2008 -fcheck=bounds -g -fdump-tree-original" } +! { dg-output "At line 43 .*" } +! { dg-shouldfail "Unequal character lengths .3/2. in ALLOCATE with SOURCE= or MOLD=" } +! +! PR fortran/113793 +! +! Test runtime checks of string length for ALLOCATE with SOURCE= or MOLD= + +program p + implicit none + character(kind=1,len=2) :: c1 = "xx" + character(kind=1,len=8) :: c2 = "yy" + character(kind=4,len=6) :: c3 = 4_"ww" + call sub1 (len (c2), c2) + call sub4 (len (c3), c3) + call test (len (c1) + 1, c1) +contains + subroutine sub1 (n, s) + integer, intent(in) :: n + character(*), intent(in) :: s + character(len=8), allocatable :: f(:), g + character(len=n), allocatable :: h(:), j + ALLOCATE (f(7), source=s) + ALLOCATE (g, source=s) + ALLOCATE (h(5), mold=s) + ALLOCATE (j, mold=s) + end + subroutine sub4 (n, s) + integer, intent(in) :: n + character(kind=4,len=*), intent(in) :: s + character(kind=4,len=6), allocatable :: f(:), g + character(kind=4,len=n), allocatable :: h(:), j + ALLOCATE (f(3), source=s) + ALLOCATE (g, source=s) + ALLOCATE (h(5), mold=s) + ALLOCATE (j, mold=s) + end + subroutine test (n, s) + integer, intent(in) :: n + character(*), intent(in) :: s + character(len=n), allocatable :: str + ALLOCATE (str, source=s) + end +end + +! { dg-final { scan-tree-dump-times "__builtin_malloc .72.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc .24.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc .56.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc .8.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ALLOCATE with SOURCE= or MOLD=" 9 "original" } } diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_31.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_31.f90 new file mode 100644 index 00000000000..50c6098126e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_31.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-additional-options "-std=gnu -fcheck=no-bounds" } +! +! PR fortran/113793 +! +! Test extension for ALLOCATE with SOURCE= or MOLD= that strings +! are truncated or padded and no memory corruption occurs + +program p + implicit none + call test_pad (8, "12345") + call test_trunc (6, "123456789") +contains + subroutine test_pad (n, s) + integer, intent(in) :: n + character(*), intent(in) :: s + character(len=n), allocatable :: a(:), b(:,:) + if (len (s) >= n) stop 111 + ALLOCATE (a(100),source=s) + ALLOCATE (b(5,6),source=s) +! print *, ">", a(42), "<" +! print *, ">", b(3,4), "<" + if (a(42) /= s) stop 1 + if (b(3,4) /= s) stop 2 + end + subroutine test_trunc (n, s) + integer, intent(in) :: n + character(*), intent(in) :: s + character(len=n), allocatable :: a(:), b(:,:) + if (len (s) <= n) stop 222 + ALLOCATE (a(100),source=s) + ALLOCATE (b(5,6),source=s) +! print *, ">", a(42), "<" +! print *, ">", b(3,4), "<" + if (a(42) /= s(1:n)) stop 3 + if (b(3,4) /= s(1:n)) stop 4 + end +end -- 2.35.3