1! { dg-do compile }
2
3! Type-bound procedures
4! Test for errors in specific bindings, during resolution.
5
6MODULE othermod
7  IMPLICIT NONE
8CONTAINS
9
10  REAL FUNCTION proc_noarg ()
11    IMPLICIT NONE
12  END FUNCTION proc_noarg
13
14END MODULE othermod
15
16MODULE testmod
17  USE othermod
18  IMPLICIT NONE
19
20  INTEGER :: noproc
21
22  PROCEDURE() :: proc_nointf
23
24  INTERFACE
25    SUBROUTINE proc_intf ()
26    END SUBROUTINE proc_intf
27  END INTERFACE
28
29  ABSTRACT INTERFACE
30    SUBROUTINE proc_abstract_intf ()
31    END SUBROUTINE proc_abstract_intf
32  END INTERFACE
33
34  TYPE supert
35  CONTAINS
36    PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg
37    PROCEDURE, NOPASS, NON_OVERRIDABLE :: super_nonoverrid => proc_sub_noarg
38  END TYPE supert
39
40  TYPE, EXTENDS(supert) :: t
41  CONTAINS
42
43    ! Bindings that should succeed
44    PROCEDURE, NOPASS :: p0 => proc_noarg
45    PROCEDURE, PASS :: p1 => proc_arg_first
46    PROCEDURE proc_arg_first
47    PROCEDURE, PASS(me) :: p2 => proc_arg_middle
48    PROCEDURE, PASS(me), NON_OVERRIDABLE :: p3 => proc_arg_last
49    PROCEDURE, NOPASS :: p4 => proc_nome
50    PROCEDURE, NOPASS :: p5 => proc_intf
51    PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg
52
53    ! Bindings that should not succeed
54    PROCEDURE :: e0 => undefined ! { dg-error "has no IMPLICIT|module procedure" }
55    PROCEDURE, PASS :: e1 => proc_noarg ! { dg-error "at least one argument" }
56    PROCEDURE :: e2 => proc_noarg ! { dg-error "at least one argument" }
57    PROCEDURE, PASS(me) :: e3 => proc_nome ! { dg-error "no argument 'me'" }
58    PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" }
59    PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "Non-polymorphic passed-object dummy argument" }
60    PROCEDURE :: e6 => noproc ! { dg-error "module procedure" }
61    PROCEDURE :: e7 => proc_nointf ! { dg-error "explicit interface" }
62    PROCEDURE, NOPASS :: e8 => proc_abstract_intf ! { dg-error "explicit interface" }
63    PROCEDURE :: super_nonoverrid => proc_arg_first ! { dg-error "NON_OVERRIDABLE" }
64
65  END TYPE t
66
67CONTAINS
68
69  SUBROUTINE proc_arg_first (me, x)
70    IMPLICIT NONE
71    CLASS(t) :: me
72    REAL :: x
73  END SUBROUTINE proc_arg_first
74
75  INTEGER FUNCTION proc_arg_middle (x, me, y)
76    IMPLICIT NONE
77    REAL :: x, y
78    CLASS(t) :: me
79  END FUNCTION proc_arg_middle
80
81  SUBROUTINE proc_arg_last (x, me)
82    IMPLICIT NONE
83    CLASS(t) :: me
84    REAL :: x
85  END SUBROUTINE proc_arg_last
86
87  SUBROUTINE proc_nome (arg, x, y)
88    IMPLICIT NONE
89    TYPE(t) :: arg
90    REAL :: x, y
91  END SUBROUTINE proc_nome
92
93  SUBROUTINE proc_mewrong (me, x)
94    IMPLICIT NONE
95    REAL :: x
96    INTEGER :: me
97  END SUBROUTINE proc_mewrong
98
99  SUBROUTINE proc_sub_noarg ()
100  END SUBROUTINE proc_sub_noarg
101
102END MODULE testmod
103
104PROGRAM main
105  IMPLICIT NONE
106
107  TYPE t
108  CONTAINS
109    PROCEDURE, NOPASS :: proc_no_module ! { dg-error "module procedure" }
110  END TYPE t
111
112CONTAINS
113
114  SUBROUTINE proc_no_module ()
115  END SUBROUTINE proc_no_module
116
117END PROGRAM main
118