gcc/testsuite/gfortran.dg/bounds_temporaries_1.f90

   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
  11 subroutine 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)
  20 end subroutine gfcbug34
  21
  22 ! This is PR25669
  23 subroutine foo (a)
  24   real a(*)
  25   call bar (a, LBOUND(a),2) ! { dg-error "Rank mismatch in argument" }
  26 end subroutine foo
  27 subroutine bar (b, i, j)
  28   real b(i:j)
  29   print *, i, j
  30   print *, b(i:j)
  31 end subroutine bar
  32
  33 ! This is PR18003
  34 subroutine io_bug()
  35   integer :: a(10)
  36   print *, ubound(a)
  37 end subroutine io_bug
  38
  39 ! This checks that lbound and ubound are OK in  temporary
  40 ! expressions.
  41 subroutine io_bug_plus()
  42   integer :: a(10, 10), b(2)
  43   print *, ubound(a)*(/1,2/)
  44   print *, (/1,2/)*ubound(a)
  45 end 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
  62 end
  63
  64