re PR fortran/60322 ([OOP] Incorrect bounds on polymorphic dummy array)

2015-04-27  Andre Vehreschild  <vehre@gmx.de>

        PR fortran/60322
        Add tests forgotten to svn-add.
        * gfortran.dg/class_allocate_19.f03: New test.
        * gfortran.dg/class_array_20.f03: New test.
        * gfortran.dg/class_array_21.f03: New test.
        * gfortran.dg/finalize_29.f08: New test.

From-SVN: r222478

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fb5618116d0ae1eb32b2832f5a09eb19ae745df7..67bdd69ddf0eb06abe3b1596ffb9a18c974e29e6 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,12 @@
+2015-04-27  Andre Vehreschild  <vehre@gmx.de>
+
+       PR fortran/60322
+       Add tests forgotten to svn-add.
+       * gfortran.dg/class_allocate_19.f03: New test.
+       * gfortran.dg/class_array_20.f03: New test.
+       * gfortran.dg/class_array_21.f03: New test.
+       * gfortran.dg/finalize_29.f08: New test.
+
 2015-04-27  Andre Vehreschild  <vehre@gmx.de>
 
        PR fortran/59678

diff --git a/gcc/testsuite/gfortran.dg/class_allocate_19.f03 b/gcc/testsuite/gfortran.dg/class_allocate_19.f03
new file mode 100644 (file)
index 0000000..719be3e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_allocate_19.f03
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! Contributed by: Vladimir Fuka  <vladimir.fuka@gmail.com>
+
+use iso_c_binding
+implicit none
+real, target :: e
+class(*), allocatable, target :: a(:)
+e = 1.0
+call add_element_poly(a,e)
+if (size(a) /= 1) call abort()
+call add_element_poly(a,e)
+if (size(a) /= 2) call abort()
+select type (a)
+  type is (real)
+    if (any (a /= [ 1, 1])) call abort()
+end select
+contains
+    subroutine add_element_poly(a,e)
+      use iso_c_binding
+      class(*),allocatable,intent(inout),target :: a(:)
+      class(*),intent(in),target :: e
+      class(*),allocatable,target :: tmp(:)
+      type(c_ptr) :: dummy
+
+      interface
+        function memcpy(dest,src,n) bind(C,name="memcpy") result(res)
+          import
+          type(c_ptr) :: res
+          integer(c_intptr_t),value :: dest
+          integer(c_intptr_t),value :: src
+          integer(c_size_t),value :: n
+        end function
+      end interface
+
+      if (.not.allocated(a)) then
+        allocate(a(1), source=e)
+      else
+        allocate(tmp(size(a)),source=a)
+        deallocate(a)
+        allocate(a(size(tmp)+1),mold=e)
+        dummy = memcpy(loc(a(1)),loc(tmp),sizeof(tmp))
+        dummy = memcpy(loc(a(size(tmp)+1)),loc(e),sizeof(e))
+      end if
+    end subroutine
+end
+

diff --git a/gcc/testsuite/gfortran.dg/class_array_20.f03 b/gcc/testsuite/gfortran.dg/class_array_20.f03
new file mode 100644 (file)
index 0000000..c49f7d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_20.f03
@@ -0,0 +1,100 @@
+! {dg-do run}
+!
+! Test contributed by Thomas L. Clune via pr60322
+!                  and Antony Lewis via pr64692
+
+program class_array_20
+  implicit none
+
+  type Foo
+  end type
+
+  type(foo), dimension(2:3) :: arg
+  integer :: oneDarr(2)
+  integer :: twoDarr(2,3)
+  integer :: x, y
+  double precision :: P(2, 2)
+
+  ! Checking for PR/60322
+  call copyFromClassArray([Foo(), Foo()])
+  call copyFromClassArray(arg)
+  call copyFromClassArray(arg(:))
+
+  x= 3
+  y= 4
+  oneDarr = [x, y]
+  call W([x, y])
+  call W(oneDarr)
+  call W([3, 4])
+
+  twoDarr = reshape([3, 4, 5, 5, 6, 7], [2, 3])
+  call WtwoD(twoDarr)
+  call WtwoD(reshape([3, 4, 5, 5, 6, 7], [2, 3]))
+
+  ! Checking for PR/64692
+  P(1:2, 1) = [1.d0, 2.d0]
+  P(1:2, 2) = [3.d0, 4.d0]
+  call AddArray(P(1:2, 2))
+
+contains
+
+  subroutine copyFromClassArray(classarray)
+    class (Foo), intent(in) :: classarray(:)
+
+    if (lbound(classarray, 1) .ne. 1) call abort()
+    if (ubound(classarray, 1) .ne. 2) call abort()
+    if (size(classarray) .ne. 2) call abort()
+  end subroutine
+
+  subroutine AddArray(P)
+    class(*), target, intent(in) :: P(:)
+    class(*), pointer :: Pt(:)
+
+    allocate(Pt(1:size(P)), source= P)
+
+    select type (P)
+      type is (double precision)
+        if (abs(P(1)-3.d0) .gt. 1.d-8) call abort()
+        if (abs(P(2)-4.d0) .gt. 1.d-8) call abort()
+      class default
+        call abort()
+    end select
+
+    select type (Pt)
+      type is (double precision)
+        if (abs(Pt(1)-3.d0) .gt. 1.d-8) call abort()
+        if (abs(Pt(2)-4.d0) .gt. 1.d-8) call abort()
+      class default
+        call abort()
+    end select
+  end subroutine
+
+  subroutine W(ar)
+    class(*), intent(in) :: ar(:)
+
+    if (lbound(ar, 1) /= 1) call abort()
+    select type (ar)
+      type is (integer)
+        ! The indeces 1:2 are essential here, or else one would not
+        ! note, that the array internally starts at 0, although the
+        ! check for the lbound above went fine.
+        if (any (ar(1:2) .ne. [3, 4])) call abort()
+      class default
+        call abort()
+    end select
+  end subroutine
+
+  subroutine WtwoD(ar)
+    class(*), intent(in) :: ar(:,:)
+
+    if (any (lbound(ar) /= [1, 1])) call abort()
+    select type (ar)
+      type is (integer)
+        if (any (reshape(ar(1:2,1:3), [6]) .ne. [3, 4, 5, 5, 6, 7])) &
+        call abort()
+      class default
+        call abort()
+    end select
+  end subroutine
+end program class_array_20
+

diff --git a/gcc/testsuite/gfortran.dg/class_array_21.f03 b/gcc/testsuite/gfortran.dg/class_array_21.f03
new file mode 100644 (file)
index 0000000..1e89d38
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_21.f03
@@ -0,0 +1,97 @@
+! {dg-do run}
+!
+! Contributed by Andre Vehreschild
+! Check more elaborate class array addressing.
+
+module m1
+
+  type InnerBaseT
+    integer, allocatable :: a(:)
+  end type InnerBaseT
+
+  type, extends(InnerBaseT) :: InnerT
+    integer :: i
+  end type InnerT
+
+  type BaseT
+    class(InnerT), allocatable :: arr(:,:)
+  contains
+    procedure P
+  end type BaseT
+
+contains
+
+  subroutine indir(this, mat)
+    class(BaseT) :: this
+    class(InnerT), intent(inout) :: mat(:,:)
+
+    call this%P(mat)
+  end subroutine indir
+
+  subroutine P(this, mat)
+    class(BaseT) :: this
+    class(InnerT), intent(inout) :: mat(:,:)
+    integer :: i,j
+
+    mat%i = 42
+    do i= 1, ubound(mat, 1)
+      do j= 1, ubound(mat, 2)
+        if (.not. allocated(mat(i,j)%a)) then
+          allocate(mat(i,j)%a(10), source = 72)
+        end if
+      end do
+    end do
+    mat(1,1)%i = 9
+    mat(1,1)%a(5) = 1
+  end subroutine
+
+end module m1
+
+program test
+  use m1
+
+  class(BaseT), allocatable, target :: o
+  class(InnerT), pointer :: i_p(:,:)
+  class(InnerBaseT), allocatable :: i_a(:,:)
+  integer i,j,l
+
+  allocate(o)
+  allocate(o%arr(2,2))
+  allocate(InnerT::i_a(2,2))
+  o%arr%i = 1
+
+  i_p => o%arr
+  call o%P(i_p)
+  if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort()
+  do l= 1, 10
+    do i= 1, 2
+      do j= 1,2
+        if ((i == 1 .and. j == 1 .and. l == 5 .and. &
+             o%arr(i,j)%a(5) /= 1) &
+            .or. (.not. (i == 1 .and. j == 1 .and. l == 5) &
+              .and. o%arr(i,j)%a(l) /= 72)) call abort()
+      end do
+    end do
+  end do
+
+  select type (i_a)
+    type is (InnerT)
+      call o%P(i_a)
+      do l= 1, 10
+        do i= 1, 2
+          do j= 1,2
+            if ((i == 1 .and. j == 1 .and. l == 5 .and. &
+                 i_a(i,j)%a(5) /= 1) &
+                .or. (.not. (i == 1 .and. j == 1 .and. l == 5) &
+                  .and. i_a(i,j)%a(l) /= 72)) call abort()
+          end do
+        end do
+      end do
+  end select
+
+  i_p%i = 4
+  call indir(o, i_p)
+  if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) call abort()
+end program test
+
+! vim:ts=2:sts=2:cindent:sw=2:tw=80:

diff --git a/gcc/testsuite/gfortran.dg/finalize_29.f08 b/gcc/testsuite/gfortran.dg/finalize_29.f08
new file mode 100644 (file)
index 0000000..1f5f742
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_29.f08
@@ -0,0 +1,289 @@
+! {dg-do run}
+!
+! Testcase contributed by Andre Vehreschild  <vehre@gcc.gnu.org>
+
+module module_finalize_29
+  implicit none
+
+  ! The type name is encoding the state of its finalizer being
+  ! elemental (second letter 'e'), or non-element (second letter 'n')
+  ! or array shaped (second letter 'a'), or shape-specific routine
+  ! (generic; second letter 'g'),
+  ! and whether the init-routine is elemental or not (third letter
+  ! either 'e' or 'n').
+  type ten
+    integer :: i = 40
+  contains
+    final :: ten_fin
+  end type ten
+
+  type tee
+    integer :: i = 41
+  contains
+    final :: tee_fin
+  end type tee
+
+  type tne
+    integer :: i = 42
+  contains
+    final :: tne_fin
+  end type tne
+
+  type tnn
+    integer :: i = 43
+  contains
+    final :: tnn_fin
+  end type tnn
+
+  type tae
+    integer :: i = 44
+  contains
+    final :: tae_fin
+  end type tae
+
+  type tan
+    integer :: i = 45
+  contains
+    final :: tan_fin
+  end type tan
+
+  type tge
+    integer :: i = 46
+  contains
+    final :: tge_scalar_fin, tge_array_fin
+  end type tge
+
+  type tgn
+    integer :: i = 47
+  contains
+    final :: tgn_scalar_fin, tgn_array_fin
+  end type tgn
+
+  integer :: ten_fin_counts, tee_fin_counts, tne_fin_counts, tnn_fin_counts
+  integer :: tae_fin_counts, tan_fin_counts
+  integer :: tge_scalar_fin_counts, tge_array_fin_counts
+  integer :: tgn_scalar_fin_counts, tgn_array_fin_counts
+contains
+  impure elemental subroutine ten_fin(x)
+    type(ten), intent(inout) :: x
+    x%i = -10 * x%i
+    ten_fin_counts = ten_fin_counts + 1
+  end subroutine ten_fin
+
+  impure elemental subroutine tee_fin(x)
+    type(tee), intent(inout) :: x
+    x%i = -11 * x%i
+    tee_fin_counts = tee_fin_counts + 1
+  end subroutine tee_fin
+
+  subroutine tne_fin(x)
+    type(tne), intent(inout) :: x
+    x%i = -12 * x%i
+    tne_fin_counts = tne_fin_counts + 1
+  end subroutine tne_fin
+
+  subroutine tnn_fin(x)
+    type(tnn), intent(inout) :: x
+    x%i = -13 * x%i
+    tnn_fin_counts = tnn_fin_counts + 1
+  end subroutine tnn_fin
+
+  subroutine tae_fin(x)
+    type(tae), intent(inout) :: x(:,:)
+    x%i = -14 * x%i
+    tae_fin_counts = tae_fin_counts + 1
+  end subroutine tae_fin
+
+  subroutine tan_fin(x)
+    type(tan), intent(inout) :: x(:,:)
+    x%i = -15 * x%i
+    tan_fin_counts = tan_fin_counts + 1
+  end subroutine tan_fin
+
+  subroutine tge_scalar_fin(x)
+    type(tge), intent(inout) :: x
+    x%i = -16 * x%i
+    tge_scalar_fin_counts = tge_scalar_fin_counts + 1
+  end subroutine tge_scalar_fin
+
+  subroutine tge_array_fin(x)
+    type(tge), intent(inout) :: x(:,:)
+    x%i = -17 * x%i
+    tge_array_fin_counts = tge_array_fin_counts + 1
+  end subroutine tge_array_fin
+
+  subroutine tgn_scalar_fin(x)
+    type(tgn), intent(inout) :: x
+    x%i = -18 * x%i
+    tgn_scalar_fin_counts = tgn_scalar_fin_counts + 1
+  end subroutine tgn_scalar_fin
+
+  subroutine tgn_array_fin(x)
+    type(tgn), intent(inout) :: x(:,:)
+    x%i = -19 * x%i
+    tgn_array_fin_counts = tgn_array_fin_counts + 1
+  end subroutine tgn_array_fin
+
+  ! The finalizer/initializer call producer
+  subroutine ten_init(x)
+    class(ten), intent(out) :: x(:,:)
+  end subroutine ten_init
+
+  impure elemental subroutine tee_init(x)
+    class(tee), intent(out) :: x
+  end subroutine tee_init
+
+  impure elemental subroutine tne_init(x)
+    class(tne), intent(out) :: x
+  end subroutine tne_init
+
+  subroutine tnn_init(x)
+    class(tnn), intent(out) :: x(:,:)
+  end subroutine tnn_init
+
+  impure elemental subroutine tae_init(x)
+    class(tae), intent(out) :: x
+  end subroutine tae_init
+
+  subroutine tan_init(x)
+    class(tan), intent(out) :: x(:,:)
+  end subroutine tan_init
+
+  impure elemental subroutine tge_init(x)
+    class(tge), intent(out) :: x
+  end subroutine tge_init
+
+  subroutine tgn_init(x)
+    class(tgn), intent(out) :: x(:,:)
+  end subroutine tgn_init
+end module module_finalize_29
+
+program finalize_29
+  use module_finalize_29
+  implicit none
+
+  type(ten), allocatable :: x_ten(:,:)
+  type(tee), allocatable :: x_tee(:,:)
+  type(tne), allocatable :: x_tne(:,:)
+  type(tnn), allocatable :: x_tnn(:,:)
+  type(tae), allocatable :: x_tae(:,:)
+  type(tan), allocatable :: x_tan(:,:)
+  type(tge), allocatable :: x_tge(:,:)
+  type(tgn), allocatable :: x_tgn(:,:)
+
+  ! Set the global counts to zero.
+  ten_fin_counts = 0
+  tee_fin_counts = 0
+  tne_fin_counts = 0
+  tnn_fin_counts = 0
+  tae_fin_counts = 0
+  tan_fin_counts = 0
+  tge_scalar_fin_counts = 0
+  tge_array_fin_counts = 0
+  tgn_scalar_fin_counts = 0
+  tgn_array_fin_counts = 0
+
+  allocate(ten :: x_ten(5,5))
+  allocate(tee :: x_tee(5,5))
+  allocate(tne :: x_tne(5,5))
+  allocate(tnn :: x_tnn(5,5))
+  allocate(tae :: x_tae(5,5))
+  allocate(tan :: x_tan(5,5))
+  allocate(tge :: x_tge(5,5))
+  allocate(tgn :: x_tgn(5,5))
+
+  x_ten%i = 1
+  x_tee%i = 2
+  x_tne%i = 3
+  x_tnn%i = 4
+  x_tae%i = 5
+  x_tan%i = 6
+  x_tge%i = 7
+  x_tgn%i = 8
+
+  call ten_init(x_ten(::2, ::3))
+
+  if (ten_fin_counts /= 6) call abort()
+  if (tee_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + &
+        tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+        tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+  ten_fin_counts = 0
+
+  call tee_init(x_tee(::2, ::3))
+
+  if (tee_fin_counts /= 6) call abort()
+  if (ten_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + &
+        tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+        tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+  tee_fin_counts = 0
+
+  call tne_init(x_tne(::2, ::3))
+
+  if (tne_fin_counts /= 6) call abort()
+  if (ten_fin_counts + tee_fin_counts + tnn_fin_counts + tae_fin_counts + &
+        tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+        tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+  tne_fin_counts = 0
+
+  call tnn_init(x_tnn(::2, ::3))
+
+  if (tnn_fin_counts /= 0) call abort()
+  if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tae_fin_counts + &
+        tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+        tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+
+  call tae_init(x_tae(::2, ::3))
+
+  if (tae_fin_counts /= 0) call abort()
+  if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + &
+        tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+        tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+
+  call tan_init(x_tan(::2, ::3))
+
+  if (tan_fin_counts /= 1) call abort()
+  if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + &
+        tae_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+        tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+  tan_fin_counts = 0
+
+  call tge_init(x_tge(::2, ::3))
+
+  if (tge_scalar_fin_counts /= 6) call abort()
+  if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + &
+        tae_fin_counts + tan_fin_counts + tgn_array_fin_counts + &
+        tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+  tge_scalar_fin_counts = 0
+
+  call tgn_init(x_tgn(::2, ::3))
+
+  if (tgn_array_fin_counts /= 1) call abort()
+  if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + &
+        tae_fin_counts + tan_fin_counts + tge_scalar_fin_counts + &
+        tge_array_fin_counts + tgn_scalar_fin_counts /= 0) call abort()
+  tgn_array_fin_counts = 0
+
+  if (any (reshape (x_ten%i, [25]) /= [[40, 1, 40, 1, 40], [1, 1, 1, 1, 1],&
+        [1, 1, 1, 1, 1], [40, 1, 40, 1, 40], [1, 1, 1, 1, 1]])) call abort()
+
+  if (any (reshape (x_tee%i, [25]) /= [[41, 2, 41, 2, 41], [2, 2, 2, 2, 2],&
+        [2, 2, 2, 2, 2], [41, 2, 41, 2, 41], [2, 2, 2, 2, 2]])) call abort()
+
+  if (any (reshape (x_tne%i, [25]) /= [[42, 3, 42, 3, 42], [3, 3, 3, 3, 3],&
+        [3, 3, 3, 3, 3], [42, 3, 42, 3, 42], [3, 3, 3, 3, 3]])) call abort()
+
+  if (any (reshape (x_tnn%i, [25]) /= [[43, 4, 43, 4, 43], [4, 4, 4, 4, 4],&
+        [4, 4, 4, 4, 4], [43, 4, 43, 4, 43], [4, 4, 4, 4, 4]])) call abort()
+
+  if (any (reshape (x_tae%i, [25]) /= [[44, 5, 44, 5, 44], [5, 5, 5, 5, 5],&
+        [5, 5, 5, 5, 5], [44, 5, 44, 5, 44], [5, 5, 5, 5, 5]])) call abort()
+
+  if (any (reshape (x_tan%i, [25]) /= [[45, 6, 45, 6, 45], [6, 6, 6, 6, 6],&
+        [6, 6, 6, 6, 6], [45, 6, 45, 6, 45], [6, 6, 6, 6, 6]])) call abort()
+
+  if (any (reshape (x_tge%i, [25]) /= [[46, 7, 46, 7, 46], [7, 7, 7, 7, 7],&
+        [7, 7, 7, 7, 7], [46, 7, 46, 7, 46], [7, 7, 7, 7, 7]])) call abort()
+
+  if (any (reshape (x_tgn%i, [25]) /= [[47, 8, 47, 8, 47], [8, 8, 8, 8, 8],&
+        [8, 8, 8, 8, 8], [47, 8, 47, 8, 47], [8, 8, 8, 8, 8]])) call abort()
+end program finalize_29