1! RUN: %S/test_errors.sh %s %t %flang_fc1
2! REQUIRES: shell
3! Test 15.5.2.5 constraints and restrictions for POINTER & ALLOCATABLE
4! arguments when both sides of the call have the same attributes.
5
6module m
7
8  type :: t
9  end type
10  type, extends(t) :: t2
11  end type
12  type :: pdt(n)
13    integer, len :: n
14  end type
15
16  type(t), pointer :: mp(:), mpmat(:,:)
17  type(t), allocatable :: ma(:), mamat(:,:)
18  class(t), pointer :: pp(:)
19  class(t), allocatable :: pa(:)
20  class(t2), pointer :: pp2(:)
21  class(t2), allocatable :: pa2(:)
22  class(*), pointer :: up(:)
23  class(*), allocatable :: ua(:)
24  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
25  type(pdt(*)), pointer :: amp(:)
26  !ERROR: An assumed (*) type parameter may be used only for a (non-statement function) dummy argument, associate name, named constant, or external function result
27  type(pdt(*)), allocatable :: ama(:)
28  type(pdt(:)), pointer :: dmp(:)
29  type(pdt(:)), allocatable :: dma(:)
30  type(pdt(1)), pointer :: nmp(:)
31  type(pdt(1)), allocatable :: nma(:)
32
33 contains
34
35  subroutine smp(x)
36    type(t), pointer :: x(:)
37  end subroutine
38  subroutine sma(x)
39    type(t), allocatable :: x(:)
40  end subroutine
41  subroutine spp(x)
42    class(t), pointer :: x(:)
43  end subroutine
44  subroutine spa(x)
45    class(t), allocatable :: x(:)
46  end subroutine
47  subroutine sup(x)
48    class(*), pointer :: x(:)
49  end subroutine
50  subroutine sua(x)
51    class(*), allocatable :: x(:)
52  end subroutine
53  subroutine samp(x)
54    type(pdt(*)), pointer :: x(:)
55  end subroutine
56  subroutine sama(x)
57    type(pdt(*)), allocatable :: x(:)
58  end subroutine
59  subroutine sdmp(x)
60    type(pdt(:)), pointer :: x(:)
61  end subroutine
62  subroutine sdma(x)
63    type(pdt(:)), allocatable :: x(:)
64  end subroutine
65  subroutine snmp(x)
66    type(pdt(1)), pointer :: x(:)
67  end subroutine
68  subroutine snma(x)
69    type(pdt(1)), allocatable :: x(:)
70  end subroutine
71
72  subroutine test
73    call smp(mp) ! ok
74    call sma(ma) ! ok
75    call spp(pp) ! ok
76    call spa(pa) ! ok
77    !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so
78    call smp(pp)
79    !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so
80    call sma(pa)
81    !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so
82    call spp(mp)
83    !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so
84    call spa(ma)
85    !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
86    call sup(pp)
87    !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
88    call sua(pa)
89    !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't'
90    call spp(up)
91    !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't'
92    call spa(ua)
93    !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
94    call spp(pp2)
95    !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
96    call spa(pa2)
97    !ERROR: Rank of dummy argument is 1, but actual argument has rank 2
98    call smp(mpmat)
99    !ERROR: Rank of dummy argument is 1, but actual argument has rank 2
100    call sma(mamat)
101    call sdmp(dmp) ! ok
102    call sdma(dma) ! ok
103    call snmp(nmp) ! ok
104    call snma(nma) ! ok
105    call samp(nmp) ! ok
106    call sama(nma) ! ok
107    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
108    call sdmp(nmp)
109    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
110    call sdma(nma)
111    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
112    call snmp(dmp)
113    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
114    call snma(dma)
115    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
116    call samp(dmp)
117    !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE
118    call sama(dma)
119  end subroutine
120
121end module
122