From patchwork Sat Oct 23 00:30:00 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Sandra Loosemore X-Patchwork-Id: 46562 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 383483857827 for ; Sat, 23 Oct 2021 00:30:27 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id E729C3858012; Sat, 23 Oct 2021 00:30:08 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org E729C3858012 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: xy3KxDOBZ043KStT1Tj1mq/8bf7sca0nr5oBxDJTKXwmwOCxjEOAgfjivzqnNBdpup15464+iY SByn3NQGfixgJsUAlpxFCuazil/ja8vvUmdwWfenu/mPZgpnZSM8ACGEFLyupRG321OfkeASWD oD9b1RdTErgatbpfDTzt4TDu/bUrXaqmzITb67AwQrr0ohmTXNgJHrRtwq9ptHzBft+CW+u9/H ITXzHnTdD2CrUy77IZYJPMYz5V61SUBtSJ2VZwPLUdyHTj3tZ29WLQ2DZenpJt5O11XrlxF5TJ jK5c73kC5F/f+AHPPJbWOEJa X-IronPort-AV: E=Sophos;i="5.87,173,1631606400"; d="scan'208";a="70008294" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa1.mentor.iphmx.com with ESMTP; 22 Oct 2021 16:30:07 -0800 IronPort-SDR: wfN9MLmJflKEDYTOyU2y3OOzGz8dH2S6LRBrSiAxOF/VzFxa6aLp3Hg/UyxYLd37hQzOUJUaiJ G3FdUI9v5bgIzFNtetSu/2KvPzURWQxWp2NqZoR16+ND0SWttiGylhAwSZ2FDsQ7GWNAWaQNyD Sln0aetCqCmch4QDqoLg4K4gjlNxeoFSLi63UXNBgDqh6x5jgwZ4d9lxLjWZLY2Dxz0v7GQWk0 yvW8Mn7wlZL7WJUdai8LW3cVWUtYGFIzbnuQ9SW9s7r5yYU3nTB7l2TJne1nVAQVNaGr580z9X WhU= To: "fortran@gcc.gnu.org" , "gcc-patches@gcc.gnu.org" From: Sandra Loosemore Subject: [Fortran, committed] Add testcase for PR95196 Message-ID: Date: Fri, 22 Oct 2021 18:30:00 -0600 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.13.0 MIME-Version: 1.0 Content-Language: en-US X-ClientProxiedBy: SVR-ORW-MBX-06.mgc.mentorg.com (147.34.90.206) To svr-orw-mbx-03.mgc.mentorg.com (147.34.90.203) X-Spam-Status: No, score=-9.6 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_NUMSUBJECT, SPF_HELO_PASS, 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: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" I've committed another testcase from a bugzilla issue that now appears to be fixed. -Sandra commit 9a0e34eb45e36d4f90cedb61191fd31da0bab256 Author: Sandra Loosemore Date: Fri Oct 22 17:22:00 2021 -0700 Add testcase for PR fortran/95196 2021-10-22 José Rui Faustino de Sousa Sandra Loosemore gcc/testsuite/ PR fortran/95196 * gfortran.dg/PR95196.f90: New. diff --git a/gcc/testsuite/gfortran.dg/PR95196.f90 b/gcc/testsuite/gfortran.dg/PR95196.f90 new file mode 100644 index 0000000..14333e4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR95196.f90 @@ -0,0 +1,83 @@ +! { dg-do run } + +program rnk_p + + implicit none + + integer, parameter :: n = 10 + integer, parameter :: m = 5 + integer, parameter :: s = 4 + integer, parameter :: l = 4 + integer, parameter :: u = s+l-1 + + integer :: a(n) + integer :: b(n,n) + integer :: c(n,n,n) + integer :: r(s*s*s) + integer :: i + + a = reshape([(i, i=1,n)], [n]) + b = reshape([(i, i=1,n*n)], [n,n]) + c = reshape([(i, i=1,n*n*n)], [n,n,n]) + r(1:s) = a(l:u) + call rnk_s(a(l:u), r(1:s)) + r(1:s*s) = reshape(b(l:u,l:u), [s*s]) + call rnk_s(b(l:u,l:u), r(1:s*s)) + r = reshape(c(l:u,l:u,l:u), [s*s*s]) + call rnk_s(c(l:u,l:7,l:u), r) + stop + +contains + + subroutine rnk_s(a, b) + integer, intent(in) :: a(..) + integer, intent(in) :: b(:) + + !integer :: l(rank(a)), u(rank(a)) does not work due to Bug 94048 + integer, allocatable :: lb(:), ub(:) + integer :: i, j, k, l + + lb = lbound(a) + ub = ubound(a) + select rank(a) + rank(1) + if(any(lb/=lbound(a))) stop 11 + if(any(ub/=ubound(a))) stop 12 + if(size(a)/=size(b)) stop 13 + do i = 1, size(a) + if(a(i)/=b(i)) stop 14 + end do + rank(2) + if(any(lb/=lbound(a))) stop 21 + if(any(ub/=ubound(a))) stop 22 + if(size(a)/=size(b)) stop 23 + k = 0 + do j = 1, size(a, dim=2) + do i = 1, size(a, dim=1) + k = k + 1 + if(a(i,j)/=b(k)) stop 24 + end do + end do + rank(3) + if(any(lb/=lbound(a))) stop 31 + if(any(ub/=ubound(a))) stop 32 + if(size(a)/=size(b)) stop 33 + l = 0 + do k = 1, size(a, dim=3) + do j = 1, size(a, dim=2) + do i = 1, size(a, dim=1) + l = l + 1 + ! print *, a(i,j,k), b(l) + if(a(i,j,k)/=b(l)) stop 34 + end do + end do + end do + rank default + stop 171 + end select + deallocate(lb, ub) + return + end subroutine rnk_s + +end program rnk_p +