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: The left-hand side of a pointer assignment is not definable
  21     !BECAUSE: Procedure pointer 'p' may not be a coindexed object
  22     b[1]%p => s
  23   end
  24   ! C1028
  25   subroutine s2
  26     type(t) :: a
  27     a%p => s
  28     !ERROR: In assignment to object pointer 'q', the target 's' is a procedure designator
  29     a%q => s
  30   end
  31   ! C1029
  32   subroutine s3
  33     type(t) :: a
  34     a%p => f()  ! OK: pointer-valued function
  35     !ERROR: Subroutine pointer 'p' may not be associated with function designator 'f'
  36     a%p => f
  37   contains
  38     function f()
  39       procedure(s), pointer :: f
  40       f => s
  41     end
  42   end
  43
  44   ! C1030 and 10.2.2.4 - procedure names as target of procedure pointer
  45   subroutine s4(s_dummy)
  46     procedure(s) :: s_dummy
  47     procedure(s), pointer :: p, q
  48     procedure(), pointer :: r
  49     integer :: i
  50     external :: s_external
  51     p => s_dummy
  52     p => s_internal
  53     p => s_module
  54     q => p
  55     r => s_external
  56   contains
  57     subroutine s_internal(i)
  58       integer i
  59     end
  60   end
  61   subroutine s_module(i)
  62     integer i
  63   end
  64
  65   ! 10.2.2.4(3)
  66   subroutine s5
  67     procedure(f_impure1), pointer :: p_impure
  68     procedure(f_pure1), pointer :: p_pure
  69     !ERROR: Procedure pointer 'p_elemental' may not be ELEMENTAL
  70     procedure(f_elemental1), pointer :: p_elemental
  71     procedure(s_impure1), pointer :: sp_impure
  72     procedure(s_pure1), pointer :: sp_pure
  73     !ERROR: Procedure pointer 'sp_elemental' may not be ELEMENTAL
  74     procedure(s_elemental1), pointer :: sp_elemental
  75
  76     p_impure => f_impure1 ! OK, same characteristics
  77     p_impure => f_pure1 ! OK, target may be pure when pointer is not
  78     !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental1': incompatible procedure attributes: Elemental
  79     p_impure => f_elemental1
  80     !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impureelemental1': incompatible procedure attributes: Elemental
  81     p_impure => f_ImpureElemental1 ! OK, target may be elemental
  82
  83     sp_impure => s_impure1 ! OK, same characteristics
  84     sp_impure => s_pure1 ! OK, target may be pure when pointer is not
  85     !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_elemental1': incompatible procedure attributes: Elemental
  86     sp_impure => s_elemental1
  87
  88     !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure1'
  89     p_pure => f_impure1
  90     p_pure => f_pure1 ! OK, same characteristics
  91     !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_elemental1': incompatible procedure attributes: Elemental
  92     p_pure => f_elemental1
  93     !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impureelemental1'
  94     p_pure => f_impureElemental1
  95
  96     !ERROR: PURE procedure pointer 'sp_pure' may not be associated with non-PURE procedure designator 's_impure1'
  97     sp_pure => s_impure1
  98     sp_pure => s_pure1 ! OK, same characteristics
  99     !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental1': incompatible procedure attributes: Elemental
 100     sp_pure => s_elemental1 ! OK, target may be elemental when pointer is not
 101
 102     !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2': incompatible dummy argument #1: incompatible dummy data object intents
 103     p_impure => f_impure2
 104     !ERROR: Function pointer 'p_pure' associated with incompatible function designator 'f_pure2': function results have distinct types: INTEGER(4) vs REAL(4)
 105     p_pure => f_pure2
 106     !ERROR: Function pointer 'p_pure' associated with incompatible function designator 'ccos': function results have distinct types: INTEGER(4) vs COMPLEX(4)
 107     p_pure => ccos
 108     !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2': incompatible procedure attributes: Elemental
 109     p_impure => f_elemental2
 110
 111     !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2': incompatible procedure attributes: BindC
 112     sp_impure => s_impure2
 113     !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2': incompatible dummy argument #1: incompatible dummy data object intents
 114     sp_impure => s_pure2
 115     !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2': incompatible procedure attributes: Elemental
 116     sp_pure => s_elemental2
 117
 118     !ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1'
 119     p_impure => s_impure1
 120
 121     !ERROR: Subroutine pointer 'sp_impure' may not be associated with function designator 'f_impure1'
 122     sp_impure => f_impure1
 123
 124   contains
 125     integer function f_impure1(n)
 126       real, intent(in) :: n
 127       f_impure = n
 128     end
 129     pure integer function f_pure1(n)
 130       real, intent(in) :: n
 131       f_pure = n
 132     end
 133     elemental integer function f_elemental1(n)
 134       real, intent(in) :: n
 135       f_elemental = n
 136     end
 137     impure elemental integer function f_impureElemental1(n)
 138       real, intent(in) :: n
 139       f_impureElemental = n
 140     end
 141
 142     integer function f_impure2(n)
 143       real, intent(inout) :: n
 144       f_impure = n
 145     end
 146     pure real function f_pure2(n)
 147       real, intent(in) :: n
 148       f_pure = n
 149     end
 150     elemental integer function f_elemental2(n)
 151       real, value :: n
 152       f_elemental = n
 153     end
 154
 155     subroutine s_impure1(n)
 156       integer, intent(inout) :: n
 157       n = n + 1
 158     end
 159     pure subroutine s_pure1(n)
 160       integer, intent(inout) :: n
 161       n = n + 1
 162     end
 163     elemental subroutine s_elemental1(n)
 164       integer, intent(inout) :: n
 165       n = n + 1
 166     end
 167
 168     subroutine s_impure2(n) bind(c)
 169       integer, intent(inout) :: n
 170       n = n + 1
 171     end subroutine s_impure2
 172     pure subroutine s_pure2(n)
 173       integer, intent(out) :: n
 174       n = 1
 175     end subroutine s_pure2
 176     elemental subroutine s_elemental2(m,n)
 177       integer, intent(inout) :: m, n
 178       n = m + n
 179     end subroutine s_elemental2
 180   end
 181
 182   ! 10.2.2.4(4)
 183   subroutine s6
 184     procedure(s), pointer :: p, q
 185     procedure(), pointer :: r
 186     external :: s_external
 187     p => s_external ! OK for a pointer with an explicit interface to be associated with a procedure with an implicit interface
 188     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)
 189   end
 190
 191   ! 10.2.2.4(5)
 192   subroutine s7
 193     procedure(real) :: f_external
 194     external :: s_external
 195     procedure(), pointer :: p_s
 196     procedure(real), pointer :: p_f
 197     p_f => f_external
 198     p_s => s_external
 199     !Ok: p_s has no interface
 200     p_s => f_external
 201     !Ok: s_external has no interface
 202     p_f => s_external
 203   end
 204
 205   ! C1017: bounds-spec
 206   subroutine s8
 207     real, target :: x(10, 10)
 208     real, pointer :: p(:, :)
 209     p(2:,3:) => x
 210     !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
 211     p(2:) => x
 212   end
 213
 214   ! bounds-remapping
 215   subroutine s9
 216     real, target :: x(10, 10), y(100)
 217     real, pointer :: p(:, :)
 218     ! C1018
 219     !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
 220     p(1:100) => x
 221     ! 10.2.2.3(9)
 222     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 223     p(1:5,1:5) => x(1:10,::2)
 224     ! 10.2.2.3(9)
 225     !ERROR: Pointer bounds require 25 elements but target has only 20
 226     p(1:5,1:5) => x(:,1:2)
 227     !OK - rhs has rank 1 and enough elements
 228     p(1:5,1:5) => y(1:100:2)
 229     !OK - same, but from function result
 230     p(1:5,1:5) => f()
 231    contains
 232     function f()
 233       real, pointer :: f(:)
 234       f => y
 235     end function
 236   end
 237
 238   subroutine s10
 239     integer, pointer :: p(:)
 240     type :: t
 241       integer :: a(4, 4)
 242       integer :: b
 243     end type
 244     type(t), target :: x
 245     type(t), target :: y(10,10)
 246     integer :: v(10)
 247     p(1:16) => x%a
 248     p(1:8) => x%a(:,3:4)
 249     p(1:1) => x%b  ! We treat scalars as simply contiguous
 250     p(1:1) => x%a(1,1)
 251     p(1:1) => y(1,1)%a(1,1)
 252     p(1:1) => y(:,1)%a(1,1)  ! Rank 1 RHS
 253     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 254     p(1:4) => x%a(::2,::2)
 255     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 256     p(1:100) => y(:,:)%b
 257     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 258     p(1:100) => y(:,:)%a(1,1)
 259     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 260     !ERROR: An array section with a vector subscript may not be a pointer target
 261     p(1:4) => x%a(:,v)
 262   end
 263
 264   subroutine s11
 265     complex, target :: x(10,10)
 266     complex, pointer :: p(:)
 267     real, pointer :: q(:)
 268     p(1:100) => x(:,:)
 269     q(1:10) => x(1,:)%im
 270     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 271     q(1:100) => x(:,:)%re
 272   end
 273
 274   ! Check is_contiguous, which is usually the same as when pointer bounds
 275   ! remapping is used.
 276   subroutine s12
 277     integer, pointer :: p(:)
 278     integer, pointer, contiguous :: pc(:)
 279     type :: t
 280       integer :: a(4, 4)
 281       integer :: b
 282     end type
 283     type(t), target :: x
 284     type(t), target :: y(10,10)
 285     integer :: v(10)
 286     logical(kind=merge(1,-1,is_contiguous(x%a(:,:)))) :: l1 ! known true
 287     logical(kind=merge(1,-1,is_contiguous(y(1,1)%a(1,1)))) :: l2 ! known true
 288     !ERROR: Must be a constant value
 289     logical(kind=merge(-1,-2,is_contiguous(y(:,1)%a(1,1)))) :: l3 ! unknown
 290     !ERROR: Must be a constant value
 291     logical(kind=merge(-1,-2,is_contiguous(y(:,1)%a(1,1)))) :: l4 ! unknown
 292     logical(kind=merge(-1,1,is_contiguous(x%a(:,v)))) :: l5 ! known false
 293     !ERROR: Must be a constant value
 294     logical(kind=merge(-1,-2,is_contiguous(y(v,1)%a(1,1)))) :: l6 ! unknown
 295     !ERROR: Must be a constant value
 296     logical(kind=merge(-1,-2,is_contiguous(p(:)))) :: l7 ! unknown
 297     logical(kind=merge(1,-1,is_contiguous(pc(:)))) :: l8 ! known true
 298     logical(kind=merge(-1,1,is_contiguous(pc(1:10:2)))) :: l9 ! known false
 299     logical(kind=merge(-1,1,is_contiguous(pc(10:1:-1)))) :: l10 ! known false
 300     logical(kind=merge(1,-1,is_contiguous(pc(1:10:1)))) :: l11 ! known true
 301     logical(kind=merge(-1,1,is_contiguous(pc(10:1:-1)))) :: l12 ! known false
 302     !ERROR: Must be a constant value
 303     logical(kind=merge(-1,1,is_contiguous(pc(::-1)))) :: l13 ! unknown (could be empty)
 304     logical(kind=merge(1,-1,is_contiguous(y(1,1)%a(::-1,1)))) :: l14 ! known true (empty)
 305     logical(kind=merge(1,-1,is_contiguous(y(1,1)%a(1,::-1)))) :: l15 ! known true (empty)
 306   end
 307   subroutine test3(b)
 308     integer, intent(inout) :: b(..)
 309     !ERROR: Must be a constant value
 310     integer, parameter :: i = rank(b)
 311   end subroutine
 312
 313   subroutine s13
 314     external :: s_external
 315     procedure(), pointer :: ptr
 316     !Ok - don't emit an error about incompatible Subroutine attribute
 317     ptr => s_external
 318     call ptr
 319   end subroutine
 320
 321   subroutine s14
 322     procedure(real), pointer :: ptr
 323     sf(x) = x + 1.
 324     !ERROR: Statement function 'sf' may not be the target of a pointer assignment
 325     ptr => sf
 326   end subroutine
 327 end