path: root/flang/test/Semantics/assign03.f90

! RUN: %python %S/test_errors.py %s %flang_fc1
! Pointer assignment constraints 10.2.2.2 (see also assign02.f90)

module m
  interface
    subroutine s(i)
      integer i
    end
  end interface
  type :: t
    procedure(s), pointer, nopass :: p
    real, pointer :: q
  end type
contains
  ! C1027
  subroutine s1
    type(t), allocatable :: a(:)
    type(t), allocatable :: b[:]
    a(1)%p => s
    !ERROR: Procedure pointer may not be a coindexed object
    b[1]%p => s
  end
  ! C1028
  subroutine s2
    type(t) :: a
    a%p => s
    !ERROR: In assignment to object pointer 'q', the target 's' is a procedure designator
    a%q => s
  end
  ! C1029
  subroutine s3
    type(t) :: a
    a%p => f()  ! OK: pointer-valued function
    !ERROR: Subroutine pointer 'p' may not be associated with function designator 'f'
    a%p => f
  contains
    function f()
      procedure(s), pointer :: f
      f => s
    end
  end

  ! C1030 and 10.2.2.4 - procedure names as target of procedure pointer
  subroutine s4(s_dummy)
    procedure(s) :: s_dummy
    procedure(s), pointer :: p, q
    procedure(), pointer :: r
    integer :: i
    external :: s_external
    p => s_dummy
    p => s_internal
    p => s_module
    q => p
    r => s_external
  contains
    subroutine s_internal(i)
      integer i
    end
  end
  subroutine s_module(i)
    integer i
  end

  ! 10.2.2.4(3)
  subroutine s5
    procedure(f_impure1), pointer :: p_impure
    procedure(f_pure1), pointer :: p_pure
    !ERROR: Procedure pointer 'p_elemental' may not be ELEMENTAL
    procedure(f_elemental1), pointer :: p_elemental
    procedure(s_impure1), pointer :: sp_impure
    procedure(s_pure1), pointer :: sp_pure
    !ERROR: Procedure pointer 'sp_elemental' may not be ELEMENTAL
    procedure(s_elemental1), pointer :: sp_elemental

    p_impure => f_impure1 ! OK, same characteristics
    p_impure => f_pure1 ! OK, target may be pure when pointer is not
    p_impure => f_elemental1 ! OK, target may be pure elemental
    p_impure => f_ImpureElemental1 ! OK, target may be elemental

    sp_impure => s_impure1 ! OK, same characteristics
    sp_impure => s_pure1 ! OK, target may be pure when pointer is not
    sp_impure => s_elemental1 ! OK, target may be elemental when pointer is not

    !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impure1'
    p_pure => f_impure1
    p_pure => f_pure1 ! OK, same characteristics
    p_pure => f_elemental1 ! OK, target may be pure
    !ERROR: PURE procedure pointer 'p_pure' may not be associated with non-PURE procedure designator 'f_impureelemental1'
    p_pure => f_impureElemental1

    !ERROR: PURE procedure pointer 'sp_pure' may not be associated with non-PURE procedure designator 's_impure1'
    sp_pure => s_impure1
    sp_pure => s_pure1 ! OK, same characteristics
    sp_pure => s_elemental1 ! OK, target may be elemental when pointer is not

    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_impure2'
    p_impure => f_impure2
    !ERROR: Procedure pointer 'p_pure' associated with incompatible procedure designator 'f_pure2'
    p_pure => f_pure2
    !ERROR: Procedure pointer 'p_impure' associated with incompatible procedure designator 'f_elemental2'
    p_impure => f_elemental2

    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_impure2'
    sp_impure => s_impure2
    !ERROR: Procedure pointer 'sp_impure' associated with incompatible procedure designator 's_pure2'
    sp_impure => s_pure2
    !ERROR: Procedure pointer 'sp_pure' associated with incompatible procedure designator 's_elemental2'
    sp_pure => s_elemental2

    !ERROR: Function pointer 'p_impure' may not be associated with subroutine designator 's_impure1'
    p_impure => s_impure1

    !ERROR: Subroutine pointer 'sp_impure' may not be associated with function designator 'f_impure1'
    sp_impure => f_impure1

  contains
    integer function f_impure1(n)
      real, intent(in) :: n
      f_impure = n
    end
    pure integer function f_pure1(n)
      real, intent(in) :: n
      f_pure = n
    end
    elemental integer function f_elemental1(n)
      real, intent(in) :: n
      f_elemental = n
    end
    impure elemental integer function f_impureElemental1(n)
      real, intent(in) :: n
      f_impureElemental = n
    end

    integer function f_impure2(n)
      real, intent(inout) :: n
      f_impure = n
    end
    pure real function f_pure2(n)
      real, intent(in) :: n
      f_pure = n
    end
    elemental integer function f_elemental2(n)
      real, value :: n
      f_elemental = n
    end

    subroutine s_impure1(n)
      integer, intent(inout) :: n
      n = n + 1
    end
    pure subroutine s_pure1(n)
      integer, intent(inout) :: n
      n = n + 1
    end
    elemental subroutine s_elemental1(n)
      integer, intent(inout) :: n
      n = n + 1
    end

    subroutine s_impure2(n) bind(c)
      integer, intent(inout) :: n
      n = n + 1
    end subroutine s_impure2
    pure subroutine s_pure2(n)
      integer, intent(out) :: n
      n = 1
    end subroutine s_pure2
    elemental subroutine s_elemental2(m,n)
      integer, intent(inout) :: m, n
      n = m + n
    end subroutine s_elemental2
  end

  ! 10.2.2.4(4)
  subroutine s6
    procedure(s), pointer :: p, q
    procedure(), pointer :: r
    external :: s_external
    !ERROR: Procedure pointer 'p' with explicit interface may not be associated with procedure designator 's_external' with implicit interface
    p => s_external
    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)
  end

  ! 10.2.2.4(5)
  subroutine s7
    procedure(real) :: f_external
    external :: s_external
    procedure(), pointer :: p_s
    procedure(real), pointer :: p_f
    p_f => f_external
    p_s => s_external
    !ERROR: Subroutine pointer 'p_s' may not be associated with function designator 'f_external'
    p_s => f_external
    !ERROR: Function pointer 'p_f' may not be associated with subroutine designator 's_external'
    p_f => s_external
  end

  ! C1017: bounds-spec
  subroutine s8
    real, target :: x(10, 10)
    real, pointer :: p(:, :)
    p(2:,3:) => x
    !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
    p(2:) => x
  end

  ! bounds-remapping
  subroutine s9
    real, target :: x(10, 10), y(100)
    real, pointer :: p(:, :)
    ! C1018
    !ERROR: Pointer 'p' has rank 2 but the number of bounds specified is 1
    p(1:100) => x
    ! 10.2.2.3(9)
    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
    p(1:5,1:5) => x(1:10,::2)
    ! 10.2.2.3(9)
    !ERROR: Pointer bounds require 25 elements but target has only 20
    p(1:5,1:5) => x(:,1:2)
    !OK - rhs has rank 1 and enough elements
    p(1:5,1:5) => y(1:100:2)
  end

  subroutine s10
    integer, pointer :: p(:)
    type :: t
      integer :: a(4, 4)
      integer :: b
    end type
    type(t), target :: x
    type(t), target :: y(10,10)
    integer :: v(10)
    p(1:16) => x%a
    p(1:8) => x%a(:,3:4)
    p(1:1) => x%b  ! We treat scalars as simply contiguous
    p(1:1) => x%a(1,1)
    p(1:1) => y(1,1)%a(1,1)
    p(1:1) => y(:,1)%a(1,1)  ! Rank 1 RHS
    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
    p(1:4) => x%a(::2,::2)
    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
    p(1:100) => y(:,:)%b
    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
    p(1:100) => y(:,:)%a(1,1)
    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
    !ERROR: An array section with a vector subscript may not be a pointer target
    p(1:4) => x%a(:,v)
  end

  subroutine s11
    complex, target :: x(10,10)
    complex, pointer :: p(:)
    real, pointer :: q(:)
    p(1:100) => x(:,:)
    q(1:10) => x(1,:)%im
    !ERROR: Pointer bounds remapping target must have rank 1 or be simply contiguous
    q(1:100) => x(:,:)%re
  end

  ! Check is_contiguous, which is usually the same as when pointer bounds
  ! remapping is used. If it's not simply contiguous it's not constant so
  ! an error is reported.
  subroutine s12
    integer, pointer :: p(:)
    type :: t
      integer :: a(4, 4)
      integer :: b
    end type
    type(t), target :: x
    type(t), target :: y(10,10)
    integer :: v(10)
    logical, parameter :: l1 = is_contiguous(x%a(:,:))
    logical, parameter :: l2 = is_contiguous(y(1,1)%a(1,1))
    !ERROR: Must be a constant value
    logical, parameter :: l3 = is_contiguous(y(:,1)%a(1,1))
    !ERROR: Must be a constant value
    logical, parameter :: l4 = is_contiguous(x%a(:,v))
    !ERROR: Must be a constant value
    logical, parameter :: l5 = is_contiguous(y(v,1)%a(1,1))
    !ERROR: Must be a constant value
    logical, parameter :: l6 = is_contiguous(p(:))
  end
  subroutine test3(b)
    integer, intent(inout) :: b(..)
    !ERROR: Must be a constant value
    integer, parameter :: i = rank(b)
  end subroutine


end