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