flang/test/Semantics/assign03.f90

   1 ! RUN: %python %S/test_errors.py %s %flang_fc1
   2 ! Pointer assignment constraints 10.2.2.2 (see also assign02.f90)
   3
   4 module m
   5   interface
   6     subroutine s(i)
   7       integer i
   8     end
   9   end interface
  10   type :: t
  11     procedure(s), pointer, nopass :: p
  12     real, pointer :: q
  13   end type
  14 contains
  15   ! C1027
  16   subroutine s1
  17     type(t), allocatable :: a(:)
  18     type(t), allocatable :: b[:]
  19     a(1)%p => s
  20     !ERROR: Procedure pointer may not be a coindexed object
  21     b[1]%p => s
  22   end
  23   ! C1028
  24   subroutine s2
  25     type(t) :: a
  26     a%p => s
  27     !ERROR: In assignment to object pointer 'q', the target 's' is a procedure designator
  28     a%q => s
  29   end
  30   ! C1029
  31   subroutine s3
  32     type(t) :: a
  33     a%p => f()  ! OK: pointer-valued function
  34     !ERROR: Subroutine pointer 'p' may not be associated with function designator 'f'
  35     a%p => f
  36   contains
  37     function f()
  38       procedure(s), pointer :: f
  39       f => s
  40     end
  41   end
  42
  43   ! C1030 and 10.2.2.4 - procedure names as target of procedure pointer
  44   subroutine s4(s_dummy)
  45     procedure(s) :: s_dummy
  46     procedure(s), pointer :: p, q
  47     procedure(), pointer :: r
  48     integer :: i
  49     external :: s_external
  50     p => s_dummy
  51     p => s_internal
  52     p => s_module
  53     q => p
  54     r => s_external
  55   contains
  56     subroutine s_internal(i)
  57       integer i
  58     end
  59   end
  60   subroutine s_module(i)
  61     integer i
  62   end
  63
  64   ! 10.2.2.4(3)
  65   subroutine s5
  66     procedure(f_impure1), pointer :: p_impure
  67     procedure(f_pure1), pointer :: p_pure
  68     !ERROR: Procedure pointer 'p_elemental' may not be ELEMENTAL
  69     procedure(f_elemental1), pointer :: p_elemental
  70     procedure(s_impure1), pointer :: sp_impure
  71     procedure(s_pure1), pointer :: sp_pure
  72     !ERROR: Procedure pointer 'sp_elemental' may not be ELEMENTAL
  73     procedure(s_elemental1), pointer :: sp_elemental
  74
  75     p_impure => f_impure1 ! OK, same characteristics
  76     p_impure => f_pure1 ! OK, target may be pure when pointer is not
  77     p_impure => f_elemental1 ! OK, target may be pure elemental
  78     p_impure => f_ImpureElemental1 ! OK, target may be elemental
  79
  80     sp_impure => s_impure1 ! OK, same characteristics
  81     sp_impure => s_pure1 ! OK, target may be pure when pointer is not
  82     sp_impure => s_elemental1 ! OK, target may be elemental when pointer is not
  83
  84     !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure1'
  85     p_pure => f_impure1
  86     p_pure => f_pure1 ! OK, same characteristics
  87     p_pure => f_elemental1 ! OK, target may be pure
  88     !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impureelemental1'
  89     p_pure => f_impureElemental1
  90
  91     !ERROR: PURE procedure pointer 'sp_pure' may not be associated with non-PURE procedure designator 's_impure1'
  92     sp_pure => s_impure1
  93     sp_pure => s_pure1 ! OK, same characteristics
  94     sp_pure => s_elemental1 ! OK, target may be elemental when pointer is not
  95
  96     !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2'
  97     p_impure => f_impure2
  98     !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2'
  99     p_pure => f_pure2
 100     !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2'
 101     p_impure => f_elemental2
 102
 103     !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2'
 104     sp_impure => s_impure2
 105     !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2'
 106     sp_impure => s_pure2
 107     !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2'
 108     sp_pure => s_elemental2
 109
 110     !ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1'
 111     p_impure => s_impure1
 112
 113     !ERROR: Subroutine pointer 'sp_impure' may not be associated with function designator 'f_impure1'
 114     sp_impure => f_impure1
 115
 116   contains
 117     integer function f_impure1(n)
 118       real, intent(in) :: n
 119       f_impure = n
 120     end
 121     pure integer function f_pure1(n)
 122       real, intent(in) :: n
 123       f_pure = n
 124     end
 125     elemental integer function f_elemental1(n)
 126       real, intent(in) :: n
 127       f_elemental = n
 128     end
 129     impure elemental integer function f_impureElemental1(n)
 130       real, intent(in) :: n
 131       f_impureElemental = n
 132     end
 133
 134     integer function f_impure2(n)
 135       real, intent(inout) :: n
 136       f_impure = n
 137     end
 138     pure real function f_pure2(n)
 139       real, intent(in) :: n
 140       f_pure = n
 141     end
 142     elemental integer function f_elemental2(n)
 143       real, value :: n
 144       f_elemental = n
 145     end
 146
 147     subroutine s_impure1(n)
 148       integer, intent(inout) :: n
 149       n = n + 1
 150     end
 151     pure subroutine s_pure1(n)
 152       integer, intent(inout) :: n
 153       n = n + 1
 154     end
 155     elemental subroutine s_elemental1(n)
 156       integer, intent(inout) :: n
 157       n = n + 1
 158     end
 159
 160     subroutine s_impure2(n) bind(c)
 161       integer, intent(inout) :: n
 162       n = n + 1
 163     end subroutine s_impure2
 164     pure subroutine s_pure2(n)
 165       integer, intent(out) :: n
 166       n = 1
 167     end subroutine s_pure2
 168     elemental subroutine s_elemental2(m,n)
 169       integer, intent(inout) :: m, n
 170       n = m + n
 171     end subroutine s_elemental2
 172   end
 173
 174   ! 10.2.2.4(4)
 175   subroutine s6
 176     procedure(s), pointer :: p, q
 177     procedure(), pointer :: r
 178     external :: s_external
 179     p => s_external ! OK for a pointer with an explicit interface to be associated with a procedure with an implicit interface
 180     r => s_module ! OK for a pointer with implicit interface to be associated with a procedure with an explicit interface.  See 10.2.2.4 (3)
 181   end
 182
 183   ! 10.2.2.4(5)
 184   subroutine s7
 185     procedure(real) :: f_external
 186     external :: s_external
 187     procedure(), pointer :: p_s
 188     procedure(real), pointer :: p_f
 189     p_f => f_external
 190     p_s => s_external
 191     !ERROR: Subroutine pointer 'p_s' may not be associated with function designator 'f_external'
 192     p_s => f_external
 193     !ERROR: Function pointer 'p_f' may not be associated with subroutine designator 's_external'
 194     p_f => s_external
 195   end
 196
 197   ! C1017: bounds-spec
 198   subroutine s8
 199     real, target :: x(10, 10)
 200     real, pointer :: p(:, :)
 201     p(2:,3:) => x
 202     !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
 203     p(2:) => x
 204   end
 205
 206   ! bounds-remapping
 207   subroutine s9
 208     real, target :: x(10, 10), y(100)
 209     real, pointer :: p(:, :)
 210     ! C1018
 211     !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
 212     p(1:100) => x
 213     ! 10.2.2.3(9)
 214     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 215     p(1:5,1:5) => x(1:10,::2)
 216     ! 10.2.2.3(9)
 217     !ERROR: Pointer bounds require 25 elements but target has only 20
 218     p(1:5,1:5) => x(:,1:2)
 219     !OK - rhs has rank 1 and enough elements
 220     p(1:5,1:5) => y(1:100:2)
 221     !OK - same, but from function result
 222     p(1:5,1:5) => f()
 223    contains
 224     function f()
 225       real, pointer :: f(:)
 226       f => y
 227     end function
 228   end
 229
 230   subroutine s10
 231     integer, pointer :: p(:)
 232     type :: t
 233       integer :: a(4, 4)
 234       integer :: b
 235     end type
 236     type(t), target :: x
 237     type(t), target :: y(10,10)
 238     integer :: v(10)
 239     p(1:16) => x%a
 240     p(1:8) => x%a(:,3:4)
 241     p(1:1) => x%b  ! We treat scalars as simply contiguous
 242     p(1:1) => x%a(1,1)
 243     p(1:1) => y(1,1)%a(1,1)
 244     p(1:1) => y(:,1)%a(1,1)  ! Rank 1 RHS
 245     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 246     p(1:4) => x%a(::2,::2)
 247     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 248     p(1:100) => y(:,:)%b
 249     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 250     p(1:100) => y(:,:)%a(1,1)
 251     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 252     !ERROR: An array section with a vector subscript may not be a pointer target
 253     p(1:4) => x%a(:,v)
 254   end
 255
 256   subroutine s11
 257     complex, target :: x(10,10)
 258     complex, pointer :: p(:)
 259     real, pointer :: q(:)
 260     p(1:100) => x(:,:)
 261     q(1:10) => x(1,:)%im
 262     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 263     q(1:100) => x(:,:)%re
 264   end
 265
 266   ! Check is_contiguous, which is usually the same as when pointer bounds
 267   ! remapping is used. If it's not simply contiguous it's not constant so
 268   ! an error is reported.
 269   subroutine s12
 270     integer, pointer :: p(:)
 271     type :: t
 272       integer :: a(4, 4)
 273       integer :: b
 274     end type
 275     type(t), target :: x
 276     type(t), target :: y(10,10)
 277     integer :: v(10)
 278     logical, parameter :: l1 = is_contiguous(x%a(:,:))
 279     logical, parameter :: l2 = is_contiguous(y(1,1)%a(1,1))
 280     !ERROR: Must be a constant value
 281     logical, parameter :: l3 = is_contiguous(y(:,1)%a(1,1))
 282     !ERROR: Must be a constant value
 283     logical, parameter :: l4 = is_contiguous(x%a(:,v))
 284     !ERROR: Must be a constant value
 285     logical, parameter :: l5 = is_contiguous(y(v,1)%a(1,1))
 286     !ERROR: Must be a constant value
 287     logical, parameter :: l6 = is_contiguous(p(:))
 288   end
 289   subroutine test3(b)
 290     integer, intent(inout) :: b(..)
 291     !ERROR: Must be a constant value
 292     integer, parameter :: i = rank(b)
 293   end subroutine
 294
 295
 296 end