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