From 5834bdc3d483d566dcfa41fae7923f9d587f0193 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 9 Jun 2019 09:43:37 +0000 Subject: [PATCH] re PR fortran/89365 (Inquiry functions for assumed rank objects fail) 2019-06-09 Paul Thomas PR fortran/89365 * gfortran.dg/assumed_rank_bounds_3.f90 : New test. From-SVN: r272090 --- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/assumed_rank_bounds_3.f90 | 219 ++++++++++++++++++ 2 files changed, 224 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/assumed_rank_bounds_3.f90 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index df3d0061b50..a1b884164de 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +019-06-09 Paul Thomas + + PR fortran/89365 + * gfortran.dg/assumed_rank_bounds_3.f90 : New test. + 2019-06-08 Paul Thomas PR fortran/90786 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_bounds_3.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_bounds_3.f90 new file mode 100644 index 00000000000..0a428f2ed6f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_bounds_3.f90 @@ -0,0 +1,219 @@ +! { dg-do run } +! +! This test case is inserted as a check. PR89365 inially asserted that +! gfortran was getting the bounds wrong for allocatable and pointer +! actual arguments. However, the reporter accepted that it is OK and +! this is the corrected version of his testcase, which fills a gap in +! the testsuite. +! +! Contributed by Reinhold Bader +! +module mod_ass_rank_inquiry + use, intrinsic :: iso_c_binding + implicit none + logical, parameter :: debug = .true. + integer :: error_count = 0 +! +! using inquiry functions for assumed rank objects +! + contains + subroutine foo_1(this) + real(c_float) :: this(..) + select case(rank(this)) + case(0) + if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & + size(ubound(this)) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape / lbound / ubound' + end if + if (size(this) /= 1) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + case(1) + if (sum(abs(shape(this) - [4])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size', size(this) + end if + if (lbound(this,1) /= 1) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound',lbound(this,1) + end if + if (ubound(this,1) /= 4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound',ubound(this,1) + end if + case(3) + if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 2*3*4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + if (sum(abs(lbound(this) - [ 1, 1, 1 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound' + end if + if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound' + end if + case default + error_count = error_count + 1 + end select + end subroutine foo_1 + subroutine foo_2(this) + real(c_float), allocatable :: this(..) + if (.not. allocated(this)) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL allocated' + end if + select case(rank(this)) + case(0) + if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & + size(ubound(this)) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape / lbound / ubound' + end if + if (size(this) /= 1) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + case(1) + if (sum(abs(shape(this) - [4])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size', size(this) + end if + if (lbound(this,1) /= 2) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound',lbound(this,1) + end if + if (ubound(this,1) /= 5) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound',ubound(this,1) + end if + case(3) + if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 2*3*4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound', lbound(this) + end if + if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound', ubound(this) + end if + case default + error_count = error_count + 1 + end select + end subroutine foo_2 + subroutine foo_3(this) + real(c_float), pointer :: this(..) + if (.not. associated(this)) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL associated' + end if + select case(rank(this)) + case(0) + if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & + size(ubound(this)) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape / lbound / ubound' + end if + if (size(this) /= 1) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + case(1) + if (sum(abs(shape(this) - [4])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size', size(this) + end if + if (lbound(this,1) /= 2) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound',lbound(this,1) + end if + if (ubound(this,1) /= 5) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound',ubound(this,1) + end if + case(3) + if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 2*3*4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound', lbound(this) + end if + if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound', ubound(this) + end if + case default + error_count = error_count + 1 + end select + end subroutine foo_3 +end module mod_ass_rank_inquiry +program ass_rank_inquiry + use mod_ass_rank_inquiry + implicit none + real, allocatable :: x, y(:), z(:,:,:) + real, pointer :: xp, yp(:), zp(:,:,:) + + allocate(x, y(2:5), z(0:1,-1:1,1:4)) + allocate(xp, yp(2:5), zp(0:1,-1:1,1:4)) + + + call foo_1(x) + if (error_count > 0) write(*,*) 'FAIL: after scalar ',error_count + call foo_1(y) + if (error_count > 0) write(*,*) 'FAIL: after rank-1 ',error_count + call foo_1(z) + if (error_count > 0) write(*,*) 'FAIL: after rank-3 ',error_count + call foo_2(x) + if (error_count > 0) write(*,*) 'FAIL: after allocscalar ',error_count + call foo_2(y) + if (error_count > 0) write(*,*) 'FAIL: after allocrank-1 ',error_count + call foo_2(z) + if (error_count > 0) write(*,*) 'FAIL: after allocrank-3 ',error_count + call foo_3(xp) + if (error_count > 0) write(*,*) 'FAIL: after ptrscalar ',error_count + call foo_3(yp) + if (error_count > 0) write(*,*) 'FAIL: after ptrrank-1 ',error_count + call foo_3(zp) + if (error_count > 0) write(*,*) 'FAIL: after ptrrank-3 ',error_count + + if (error_count == 0) then + write(*,*) 'OK' + else + stop 1 + end if + + deallocate(x, y, z) + deallocate(xp, yp, zp) +end program ass_rank_inquiry -- 2.30.2