1! RUN: %python %S/test_errors.py %s %flang_fc1
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    y%i = 1 !VDC
34  type is (t2)
35    call sub_with_in_and_inout_param(y,y) !VDC
36end select
37
38select type ( y => (fun(1)) )
39  type is (t1)
40    !ERROR: Left-hand side of assignment is not modifiable
41    y%i = 1 !VDC
42  type is (t2)
43    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
44    call sub_with_in_and_inout_param(y,y) !VDC
45end select
46
47! B) associated with a variable:
48p_or_c => x1
49select type ( a => p_or_c )
50  type is (t1)
51    a%i = 10
52end select
53
54select type ( a => p_or_c )
55  type is (t1)
56end select
57
58!C)Associate with  with vector subscript
59select type (b => array1(V,2))
60  type is (t1)
61    !ERROR: Left-hand side of assignment is not modifiable
62    b%i  = 1 !VDC
63  type is (t2)
64    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
65    call sub_with_in_and_inout_param_vector(b,b) !VDC
66end select
67select type(b =>  foo(1) )
68  type is (t1)
69    !ERROR: Left-hand side of assignment is not modifiable
70    b%i = 1 !VDC
71  type is (t2)
72    !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'z=' must be definable
73    call sub_with_in_and_inout_param_vector(b,b) !VDC
74end select
75
76!D) Have no association and should be ok.
77!1. points to function
78ptr => fun(1)
79select type ( ptr )
80type is (t1)
81  ptr%i = 1
82end select
83
84!2. points to variable
85ptr=>x1
86select type (ptr)
87  type is (t1)
88    ptr%i = 10
89end select
90
91contains
92
93  function fun(i)
94    class(t1),pointer :: fun
95    integer :: i
96    if (i>0) then
97      fun => x1
98    else if (i<0) then
99      fun => x2
100    else
101      fun => NULL()
102    end if
103  end function
104
105  function foo(i)
106    integer :: i
107    class(t1),DIMENSION(:),allocatable :: foo
108    integer, dimension(2) :: U
109    U = (/ 1,2 /)
110    if (i>0) then
111      foo = array1(2,U)
112    else if (i<0) then
113      foo = array2(2,U) ! ok: t2 extends t1
114    end if
115  end function
116
117  function foo2()
118    class(t2),DIMENSION(:),allocatable :: foo2
119    !ERROR: No intrinsic or user-defined ASSIGNMENT(=) matches operand types CLASS(t2) and CLASS(t1)
120    foo2 = array1(2,:)
121  end function
122
123  subroutine sub_with_in_and_inout_param(y, z)
124    type(t2), INTENT(IN) :: y
125    class(t2), INTENT(INOUT) :: z
126    z%i = 10
127  end subroutine
128
129  subroutine sub_with_in_and_inout_param_vector(y, z)
130    type(t2),DIMENSION(:), INTENT(IN) :: y
131    class(t2),DIMENSION(:), INTENT(INOUT) :: z
132    z%i = 10
133  end subroutine
134
135end
136