1! RUN: %S/test_errors.sh %s %t %flang_fc1
2! REQUIRES: shell
3! Tests for C760:
4! The passed-object dummy argument shall be a scalar, nonpointer, nonallocatable
5! dummy data object with the same declared type as the type being defined;
6! all of its length type parameters shall be assumed; it shall be polymorphic
7! (7.3.2.3) if and only if the type being defined is extensible (7.5.7).
8! It shall not have the VALUE attribute.
9!
10! C757 If the procedure pointer component has an implicit interface or has no
11! arguments, NOPASS shall be specified.
12!
13! C758 If PASS (arg-name) appears, the interface of the procedure pointer
14! component shall have a dummy argument named arg-name.
15
16
17module m1
18  type :: t
19    procedure(real), pointer, nopass :: a
20    !ERROR: Procedure component 'b' must have NOPASS attribute or explicit interface
21    procedure(real), pointer :: b
22  end type
23end
24
25module m2
26  type :: t
27    !ERROR: Procedure component 'a' with no dummy arguments must have NOPASS attribute
28    procedure(s1), pointer :: a
29    !ERROR: Procedure component 'b' with no dummy arguments must have NOPASS attribute
30    procedure(s1), pointer, pass :: b
31  contains
32    !ERROR: Procedure binding 'p1' with no dummy arguments must have NOPASS attribute
33    procedure :: p1 => s1
34    !ERROR: Procedure binding 'p2' with no dummy arguments must have NOPASS attribute
35    procedure, pass :: p2 => s1
36  end type
37contains
38  subroutine s1()
39  end
40end
41
42module m3
43  type :: t
44    !ERROR: 'y' is not a dummy argument of procedure interface 's'
45    procedure(s), pointer, pass(y) :: a
46  contains
47    !ERROR: 'z' is not a dummy argument of procedure interface 's'
48    procedure, pass(z) :: p => s
49  end type
50contains
51  subroutine s(x)
52    class(t) :: x
53  end
54end
55
56module m4
57  type :: t
58    !ERROR: Passed-object dummy argument 'x' of procedure 'a' may not have the POINTER attribute
59    procedure(s1), pointer :: a
60    !ERROR: Passed-object dummy argument 'x' of procedure 'b' may not have the ALLOCATABLE attribute
61    procedure(s2), pointer, pass(x) :: b
62    !ERROR: Passed-object dummy argument 'f' of procedure 'c' must be a data object
63    procedure(s3), pointer, pass :: c
64    !ERROR: Passed-object dummy argument 'x' of procedure 'd' must be scalar
65    procedure(s4), pointer, pass :: d
66  end type
67contains
68  subroutine s1(x)
69    class(t), pointer :: x
70  end
71  subroutine s2(w, x)
72    real :: x
73    !ERROR: The type of 'x' has already been declared
74    class(t), allocatable :: x
75  end
76  subroutine s3(f)
77    interface
78      real function f()
79      end function
80    end interface
81  end
82  subroutine s4(x)
83    class(t) :: x(10)
84  end
85end
86
87module m5
88  type :: t1
89    sequence
90    !ERROR: Passed-object dummy argument 'x' of procedure 'a' must be of type 't1' but is 'REAL(4)'
91    procedure(s), pointer :: a
92  end type
93  type :: t2
94  contains
95    !ERROR: Passed-object dummy argument 'y' of procedure 's' must be of type 't2' but is 'TYPE(t1)'
96    procedure, pass(y) :: s
97  end type
98contains
99  subroutine s(x, y)
100    real :: x
101    type(t1) :: y
102  end
103end
104
105module m6
106  type :: t(k, l)
107    integer, kind :: k
108    integer, len :: l
109    !ERROR: Passed-object dummy argument 'x' of procedure 'a' has non-assumed length parameter 'l'
110    procedure(s1), pointer :: a
111  end type
112contains
113  subroutine s1(x)
114    class(t(1, 2)) :: x
115  end
116end
117
118module m7
119  type :: t
120    sequence  ! t is not extensible
121    !ERROR: Passed-object dummy argument 'x' of procedure 'a' may not be polymorphic because 't' is not extensible
122    procedure(s), pointer :: a
123  end type
124contains
125  subroutine s(x)
126    !ERROR: Non-extensible derived type 't' may not be used with CLASS keyword
127    class(t) :: x
128  end
129end
130
131module m8
132  type :: t
133  contains
134    !ERROR: Passed-object dummy argument 'x' of procedure 's' must be polymorphic because 't' is extensible
135    procedure :: s
136  end type
137contains
138  subroutine s(x)
139    type(t) :: x  ! x is not polymorphic
140  end
141end
142