1! { dg-do compile } 2! This tests the fix for PRs 26834, 25669 and 18803, in which 3! shape information for the lbound and ubound intrinsics was not 4! transferred to the scalarizer. For this reason, an ICE would 5! ensue, whenever these functions were used in temporaries. 6! 7! The tests are lifted from the PRs and some further checks are 8! done to make sure that nothing is broken. 9! 10! This is PR26834 11subroutine gfcbug34 () 12 implicit none 13 type t 14 integer, pointer :: i (:) => NULL () 15 end type t 16 type(t), save :: gf 17 allocate (gf%i(20)) 18 write(*,*) 'ubound:', ubound (gf% i) 19 write(*,*) 'lbound:', lbound (gf% i) 20end subroutine gfcbug34 21 22! This is PR25669 23subroutine foo (a) 24 real a(*) 25 call bar (a, LBOUND(a),2) ! { dg-error "Rank mismatch in argument" } 26end subroutine foo 27subroutine bar (b, i, j) 28 real b(i:j) 29 print *, i, j 30 print *, b(i:j) 31end subroutine bar 32 33! This is PR18003 34subroutine io_bug() 35 integer :: a(10) 36 print *, ubound(a) 37end subroutine io_bug 38 39! This checks that lbound and ubound are OK in temporary 40! expressions. 41subroutine io_bug_plus() 42 integer :: a(10, 10), b(2) 43 print *, ubound(a)*(/1,2/) 44 print *, (/1,2/)*ubound(a) 45end subroutine io_bug_plus 46 47 character(4) :: ch(2), ech(2) = (/'ABCD', 'EFGH'/) 48 real(4) :: a(2) 49 equivalence (ech,a) ! { dg-warning "default CHARACTER EQUIVALENCE statement" } 50 integer(1) :: i(8) = (/(j, j = 1,8)/) 51 52! Check that the bugs have gone 53 call io_bug () 54 call io_bug_plus () 55 call foo ((/1.0,2.0,3.0/)) 56 call gfcbug34 () 57 58! Check that we have not broken other intrinsics. 59 print *, cos ((/1.0,2.0/)) 60 print *, transfer (a, ch) 61 print *, i(1:4) * transfer (a, i, 4) * 2 62end 63 64 65