gcc/testsuite/gfortran.dg/coarray_8.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fmax-errors=1000 -fcoarray=single" }
   3 !
   4 ! PR fortran/18918
   5 !
   6 ! Coarray expressions.
   7 !
   8 module mod2
   9   implicit none
  10   type t
  11     procedure(sub), pointer :: ppc
  12   contains
  13     procedure :: tbp => sub
  14   end type t
  15   type t2
  16     class(t), allocatable :: poly
  17   end type t2
  18 contains
  19   subroutine sub(this)
  20     class(t), intent(in) :: this
  21   end subroutine sub
  22 end module mod2
  23
  24 subroutine procTest(y,z)
  25   use mod2
  26   implicit none
  27   type(t), save :: x[*]
  28   type(t) :: y[*]
  29   type(t2) :: z[*]
  30
  31   x%ppc => sub
  32   call x%ppc() ! OK
  33   call x%tbp() ! OK
  34   call x[1]%tbp ! OK, not polymorphic
  35   ! Invalid per C726
  36   call x[1]%ppc ! { dg-error "Coindexed procedure-pointer component" }
  37
  38   y%ppc => sub
  39   call y%ppc() ! OK
  40   call y%tbp() ! OK
  41   call y[1]%tbp ! OK, coindexed polymorphic object but not poly. subobj.
  42   call y[1]%ppc ! { dg-error "Coindexed procedure-pointer component" }
  43
  44   ! Invalid per C1229
  45   z%poly%ppc => sub
  46   call z%poly%ppc() ! OK
  47   call z%poly%tbp() ! OK
  48   call z[1]%poly%tbp ! { dg-error "Polymorphic subobject of coindexed" }
  49   call z[1]%poly%ppc ! { dg-error "Coindexed procedure-pointer component" }
  50 end subroutine procTest
  51
  52
  53 module m
  54   type t1
  55     integer, pointer :: p
  56   end type t1
  57   type t2
  58     integer :: i
  59   end type t2
  60   type t
  61     integer, allocatable :: a[:]
  62     type(t1), allocatable :: b[:]
  63     type(t2), allocatable :: c[:]
  64   end type t
  65 contains
  66   pure subroutine p2(x)
  67    integer, intent(inout) :: x
  68   end subroutine p2
  69   pure subroutine p3(x)
  70    integer, pointer :: x
  71   end subroutine p3
  72   pure subroutine p1(x)
  73     type(t), intent(inout) :: x
  74     integer, target :: tgt1
  75     x%a = 5
  76     x%a[6] = 9 ! { dg-error "Assignment to coindexed variable" }
  77     x%b%p => tgt1
  78     x%b[1]%p => tgt1 ! { dg-error "shall not have a coindex" }
  79     x%b%p => x%b[1]%p ! { dg-error "shall not have a coindex" }
  80     x%b = t1(x%b[1]%p) ! { dg-error "Coindexed expression to pointer component" }
  81     x%b = x%b[1] ! { dg-error "derived type variable with a POINTER component in a PURE" }
  82     call p2 (x%c[1]%i) ! { dg-error "Coindexed actual argument" }
  83     call p3 (x%b[1]%p) ! { dg-error "to pointer dummy" }
  84   end subroutine p1
  85   subroutine nonPtr()
  86     type(t1), save :: a[*]
  87     type(t2), save :: b[*]
  88     integer, target :: tgt1
  89     a%p => tgt1
  90     a[1]%p => tgt1 ! { dg-error "shall not have a coindex" }
  91     a%p => a[2]%p ! { dg-error "shall not have a coindex" }
  92     a = t1(a[1]%p) ! { dg-error "Coindexed expression to pointer component" }
  93     call p2 (b[1]%i) ! OK
  94     call p2 (a[1]%p) ! OK - pointer target and not pointer
  95   end subroutine nonPtr
  96 end module m
  97
  98
  99 module mmm3
 100  type t
 101    integer, allocatable :: a(:)
 102  end type t
 103 contains
 104   subroutine assign(x)
 105     type(t) :: x[*]
 106     allocate(x%a(3))
 107     x%a = [ 1, 2, 3]
 108     x[1]%a = [ 1, 2, 3] ! OK - if shapes are the same, otherwise wrong
 109                         ! (no reallocate on assignment)
 110   end subroutine assign
 111   subroutine assign2(x,y)
 112     type(t),allocatable :: x[:]
 113     type(t) :: y
 114     x = y
 115     x[1] = y ! { dg-error "must not be have an allocatable ultimate component" }
 116   end subroutine assign2
 117 end module mmm3
 118
 119
 120 module mmm4
 121   implicit none
 122 contains
 123   subroutine t1(x)
 124     integer :: x(1)
 125   end subroutine t1
 126   subroutine t3(x)
 127     character :: x(*)
 128   end subroutine t3
 129   subroutine t2()
 130     integer, save :: x[*]
 131     integer, save :: y(1)[*]
 132     character(len=20), save :: z[*]
 133
 134     call t1(x) ! { dg-error "Rank mismatch" }
 135     call t1(x[1]) ! { dg-error "Rank mismatch" }
 136
 137     call t1(y(1)) ! OK
 138     call t1(y(1)[1]) ! { dg-error "Rank mismatch" }
 139
 140     call t3(z) !  OK
 141     call t3(z[1]) ! { dg-error "Rank mismatch" }
 142   end subroutine t2
 143 end module mmm4
 144
 145
 146 subroutine tfgh()
 147   integer :: i(2)
 148   DATA i/(i, i=1,2)/ ! { dg-error "Expected PARAMETER symbol" }
 149   do i = 1, 5 ! { dg-error "cannot be a sub-component" }
 150   end do ! { dg-error "Expecting END SUBROUTINE" }
 151 end subroutine tfgh
 152
 153 subroutine tfgh2()
 154   integer, save :: x[*]
 155   integer :: i(2)
 156   DATA i/(x, x=1,2)/ ! { dg-error "Expected PARAMETER symbol" }
 157   do x = 1, 5 ! { dg-error "cannot be a coarray" }
 158   end do ! { dg-error "Expecting END SUBROUTINE" }
 159 end subroutine tfgh2
 160
 161
 162 subroutine f4f4()
 163   type t
 164     procedure(), pointer, nopass :: ppt => null()
 165   end type t
 166   external foo
 167   type(t), save :: x[*]
 168   x%ppt => foo
 169   x[1]%ppt => foo ! { dg-error "shall not have a coindex" }
 170 end subroutine f4f4
 171
 172
 173 subroutine corank()
 174   integer, allocatable :: a[:,:]
 175   call one(a) ! OK
 176   call two(a) !  { dg-error "Corank mismatch in argument" }
 177 contains
 178   subroutine one(x)
 179     integer :: x[*]
 180   end subroutine one
 181   subroutine two(x)
 182     integer, allocatable :: x[:]
 183   end subroutine two
 184 end subroutine corank
 185
 186 subroutine assign42()
 187   integer, allocatable :: z(:)[:]
 188   z(:)[1] = z
 189 end subroutine assign42
 190
 191 ! { dg-final { cleanup-modules "mod2 m mmm3 mmm4" } }