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