gcc/testsuite/gfortran.dg/pointer_array_11.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR91077 - both the original test and that in comment #4 of the PR.
   4 !
   5 ! Contribute by Ygal Klein  <ygalklein@gmail.com>
   6 !
   7 program test
   8   implicit none
   9   call original
  10   call comment_4
  11 contains
  12   subroutine original
  13     integer, parameter :: length = 9
  14     real(8), dimension(2) :: a, b
  15     integer :: i
  16     type point
  17        real(8) :: x
  18     end type point
  19
  20     type stored
  21        type(point), dimension(:), allocatable :: np
  22     end type stored
  23     type(stored), dimension(:), pointer :: std =>null()
  24     allocate(std(1))
  25     allocate(std(1)%np(length))
  26     std(1)%np(1)%x = 0.3d0
  27     std(1)%np(2)%x = 0.3555d0
  28     std(1)%np(3)%x = 0.26782d0
  29     std(1)%np(4)%x = 0d0
  30     std(1)%np(5)%x = 1.555d0
  31     std(1)%np(6)%x = 7.3d0
  32     std(1)%np(7)%x = 7.8d0
  33     std(1)%np(8)%x = 6.3d0
  34     std(1)%np(9)%x = 5.5d0
  35 !    do i = 1, 2
  36 !       write(*, "('std(1)%np(',i1,')%x = ',1e22.14)") i, std(1)%np(i)%x
  37 !    end do
  38 !    do i = 1, 2
  39 !       write(*, "('std(1)%np(1:',i1,') = ',9e22.14)") i, std(1)%np(1:i)%x
  40 !    end do
  41     a = std(1)%np(1:2)%x
  42     b = [std(1)%np(1)%x, std(1)%np(2)%x]
  43 !    print *,a
  44 !    print *,b
  45     if (allocated (std(1)%np)) deallocate (std(1)%np)
  46     if (associated (std)) deallocate (std)
  47     if (norm2(a - b) .gt. 1d-3) stop 1
  48   end subroutine
  49
  50   subroutine comment_4
  51     integer, parameter :: length = 2
  52     real(8), dimension(length) :: a, b
  53     integer :: i
  54
  55     type point
  56        real(8) :: x
  57     end type point
  58
  59     type points
  60        type(point), dimension(:), pointer :: np=>null()
  61     end type points
  62
  63     type stored
  64        integer :: l
  65        type(points), pointer :: nfpoint=>null()
  66     end type stored
  67
  68     type(stored), dimension(:), pointer :: std=>null()
  69
  70
  71     allocate(std(1))
  72     allocate(std(1)%nfpoint)
  73     allocate(std(1)%nfpoint%np(length))
  74     std(1)%nfpoint%np(1)%x = 0.3d0
  75     std(1)%nfpoint%np(2)%x = 0.3555d0
  76
  77 !    do i = 1, length
  78 !       write(*, "('std(1)%nfpoint%np(',i1,')%x = ',1e22.14)") i, std(1)%nfpoint%np(i)%x
  79 !    end do
  80 !    do i = 1, length
  81 !       write(*, "('std(1)%nfpoint%np(1:',i1,')%x = ',2e22.14)") i, std(1)%nfpoint%np(1:i)%x
  82 !    end do
  83     a = std(1)%nfpoint%np(1:2)%x
  84     b = [std(1)%nfpoint%np(1)%x, std(1)%nfpoint%np(2)%x]
  85     if (associated (std(1)%nfpoint%np)) deallocate (std(1)%nfpoint%np)
  86     if (associated (std(1)%nfpoint)) deallocate (std(1)%nfpoint)
  87     if (associated (std)) deallocate (std)
  88     if (norm2(a - b) .gt. 1d-3) stop 2
  89     end subroutine
  90 end program test