1! RUN: %S/test_errors.sh %s %t %f18
2! Test various conditions in C1158.
3implicit none
4
5type :: t1
6  integer :: i
7end type
8
9type, extends(t1) :: t2
10end type
11
12type(t1),target :: x1
13type(t2),target :: x2
14
15class(*), pointer :: ptr
16class(t1), pointer :: p_or_c
17!vector subscript related
18class(t1),DIMENSION(:,:),allocatable::array1
19class(t2),DIMENSION(:,:),allocatable::array2
20integer, dimension(2) :: V
21V = (/ 1,2 /)
22allocate(array1(3,3))
23allocate(array2(3,3))
24
25! A) associate with function, i.e (other than variables)
26select type ( y => fun(1) )
27  type is (t1)
28    print *, rank(y%i)
29end select
30
31select type ( y => fun(1) )
32  type is (t1)
33    !ERROR: Left-hand side of assignment is not modifiable
34    y%i = 1 !VDC
35  type is (t2)
36    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
37    call sub_with_in_and_inout_param(y,y) !VDC
38end select
39
40! B) associated with a variable:
41p_or_c => x1
42select type ( a => p_or_c )
43  type is (t1)
44    a%i = 10
45end select
46
47select type ( a => p_or_c )
48  type is (t1)
49end select
50
51!C)Associate with  with vector subscript
52select type (b => array1(V,2))
53  type is (t1)
54    !ERROR: Left-hand side of assignment is not modifiable
55    b%i  = 1 !VDC
56  type is (t2)
57    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
58    call sub_with_in_and_inout_param_vector(b,b) !VDC
59end select
60select type(b =>  foo(1) )
61  type is (t1)
62    !ERROR: Left-hand side of assignment is not modifiable
63    b%i = 1 !VDC
64  type is (t2)
65    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
66    call sub_with_in_and_inout_param_vector(b,b) !VDC
67end select
68
69!D) Have no association and should be ok.
70!1. points to function
71ptr => fun(1)
72select type ( ptr )
73type is (t1)
74  ptr%i = 1
75end select
76
77!2. points to variable
78ptr=>x1
79select type (ptr)
80  type is (t1)
81    ptr%i = 10
82end select
83
84contains
85
86  function fun(i)
87    class(t1),pointer :: fun
88    integer :: i
89    if (i>0) then
90      fun => x1
91    else if (i<0) then
92      fun => x2
93    else
94      fun => NULL()
95    end if
96  end function
97
98  function foo(i)
99    integer :: i
100    class(t1),DIMENSION(:),allocatable :: foo
101    integer, dimension(2) :: U
102    U = (/ 1,2 /)
103    if (i>0) then
104      foo = array1(2,U)
105    else if (i<0) then
106      !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types TYPE(t1) and TYPE(t2)
107      foo = array2(2,U)
108    end if
109  end function
110
111  subroutine sub_with_in_and_inout_param(y, z)
112    type(t2), INTENT(IN) :: y
113    class(t2), INTENT(INOUT) :: z
114    z%i = 10
115  end subroutine
116
117  subroutine sub_with_in_and_inout_param_vector(y, z)
118    type(t2),DIMENSION(:), INTENT(IN) :: y
119    class(t2),DIMENSION(:), INTENT(INOUT) :: z
120    z%i = 10
121  end subroutine
122
123end
124