flang/test/Semantics/assign03.f90

   1 ! RUN: %S/test_errors.sh %s %t %flang_fc1
   2 ! REQUIRES: shell
   3 ! Pointer assignment constraints 10.2.2.2 (see also assign02.f90)
   4
   5 module m
   6   interface
   7     subroutine s(i)
   8       integer i
   9     end
  10   end interface
  11   type :: t
  12     procedure(s), pointer, nopass :: p
  13     real, pointer :: q
  14   end type
  15 contains
  16   ! C1027
  17   subroutine s1
  18     type(t), allocatable :: a(:)
  19     type(t), allocatable :: b[:]
  20     a(1)%p => s
  21     !ERROR: Procedure pointer 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_pure), pointer :: p_pure
  68     procedure(f_impure), pointer :: p_impure
  69     !ERROR: Procedure pointer 'p_elemental' may not be ELEMENTAL
  70     procedure(f_elemental), pointer :: p_elemental
  71     p_pure => f_pure
  72     p_impure => f_impure
  73     p_impure => f_pure
  74     !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure'
  75     p_pure => f_impure
  76   contains
  77     pure integer function f_pure()
  78       f_pure = 1
  79     end
  80     integer function f_impure()
  81       f_impure = 1
  82     end
  83     elemental integer function f_elemental()
  84       f_elemental = 1
  85     end
  86   end
  87
  88   ! 10.2.2.4(4)
  89   subroutine s6
  90     procedure(s), pointer :: p, q
  91     procedure(), pointer :: r
  92     external :: s_external
  93     !ERROR: Procedure pointer 'p' with explicit interface may not be associated with procedure designator 's_external' with implicit interface
  94     p => s_external
  95     !ERROR: Procedure pointer 'r' with implicit interface may not be associated with procedure designator 's_module' with explicit interface
  96     r => s_module
  97   end
  98
  99   ! 10.2.2.4(5)
 100   subroutine s7
 101     procedure(real) :: f_external
 102     external :: s_external
 103     procedure(), pointer :: p_s
 104     procedure(real), pointer :: p_f
 105     p_f => f_external
 106     p_s => s_external
 107     !ERROR: Subroutine pointer 'p_s' may not be associated with function designator 'f_external'
 108     p_s => f_external
 109     !ERROR: Function pointer 'p_f' may not be associated with subroutine designator 's_external'
 110     p_f => s_external
 111   end
 112
 113   ! C1017: bounds-spec
 114   subroutine s8
 115     real, target :: x(10, 10)
 116     real, pointer :: p(:, :)
 117     p(2:,3:) => x
 118     !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
 119     p(2:) => x
 120   end
 121
 122   ! bounds-remapping
 123   subroutine s9
 124     real, target :: x(10, 10), y(100)
 125     real, pointer :: p(:, :)
 126     ! C1018
 127     !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
 128     p(1:100) => x
 129     ! 10.2.2.3(9)
 130     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 131     p(1:5,1:5) => x(1:10,::2)
 132     ! 10.2.2.3(9)
 133     !ERROR: Pointer bounds require 25 elements but target has only 20
 134     p(1:5,1:5) => x(:,1:2)
 135     !OK - rhs has rank 1 and enough elements
 136     p(1:5,1:5) => y(1:100:2)
 137   end
 138
 139   subroutine s10
 140     integer, pointer :: p(:)
 141     type :: t
 142       integer :: a(4, 4)
 143       integer :: b
 144     end type
 145     type(t), target :: x
 146     type(t), target :: y(10,10)
 147     integer :: v(10)
 148     p(1:16) => x%a
 149     p(1:8) => x%a(:,3:4)
 150     p(1:1) => x%b  ! We treat scalars as simply contiguous
 151     p(1:1) => x%a(1,1)
 152     p(1:1) => y(1,1)%a(1,1)
 153     p(1:1) => y(:,1)%a(1,1)  ! Rank 1 RHS
 154     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 155     p(1:4) => x%a(::2,::2)
 156     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 157     p(1:100) => y(:,:)%b
 158     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 159     p(1:100) => y(:,:)%a(1,1)
 160     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 161     !ERROR: An array section with a vector subscript may not be a pointer target
 162     p(1:4) => x%a(:,v)
 163   end
 164
 165   subroutine s11
 166     complex, target :: x(10,10)
 167     complex, pointer :: p(:)
 168     real, pointer :: q(:)
 169     p(1:100) => x(:,:)
 170     q(1:10) => x(1,:)%im
 171     !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
 172     q(1:100) => x(:,:)%re
 173   end
 174
 175   ! Check is_contiguous, which is usually the same as when pointer bounds
 176   ! remapping is used. If it's not simply contiguous it's not constant so
 177   ! an error is reported.
 178   subroutine s12
 179     integer, pointer :: p(:)
 180     type :: t
 181       integer :: a(4, 4)
 182       integer :: b
 183     end type
 184     type(t), target :: x
 185     type(t), target :: y(10,10)
 186     integer :: v(10)
 187     logical, parameter :: l1 = is_contiguous(x%a(:,:))
 188     logical, parameter :: l2 = is_contiguous(y(1,1)%a(1,1))
 189     !ERROR: Must be a constant value
 190     logical, parameter :: l3 = is_contiguous(y(:,1)%a(1,1))
 191     !ERROR: Must be a constant value
 192     logical, parameter :: l4 = is_contiguous(x%a(:,v))
 193     !ERROR: Must be a constant value
 194     logical, parameter :: l5 = is_contiguous(y(v,1)%a(1,1))
 195   end
 196   subroutine test3(b)
 197     integer, intent(inout) :: b(..)
 198     !ERROR: Must be a constant value
 199     integer, parameter :: i = rank(b)
 200   end subroutine
 201
 202
 203 end