1! { dg-do run }
2
3! Type-bound procedures
4! Check basic calls to NOPASS type-bound procedures.
5
6MODULE m
7  IMPLICIT NONE
8
9  TYPE add
10  CONTAINS
11    PROCEDURE, NOPASS :: func => func_add
12    PROCEDURE, NOPASS :: sub => sub_add
13    PROCEDURE, NOPASS :: echo => echo_add
14  END TYPE add
15
16  TYPE mul
17  CONTAINS
18    PROCEDURE, NOPASS :: func => func_mul
19    PROCEDURE, NOPASS :: sub => sub_mul
20    PROCEDURE, NOPASS :: echo => echo_mul
21  END TYPE mul
22
23CONTAINS
24
25  INTEGER FUNCTION func_add (a, b)
26    IMPLICIT NONE
27    INTEGER :: a, b
28    func_add = a + b
29  END FUNCTION func_add
30
31  INTEGER FUNCTION func_mul (a, b)
32    IMPLICIT NONE
33    INTEGER :: a, b
34    func_mul = a * b
35  END FUNCTION func_mul
36
37  SUBROUTINE sub_add (a, b, c)
38    IMPLICIT NONE
39    INTEGER, INTENT(IN) :: a, b
40    INTEGER, INTENT(OUT) :: c
41    c = a + b
42  END SUBROUTINE sub_add
43
44  SUBROUTINE sub_mul (a, b, c)
45    IMPLICIT NONE
46    INTEGER, INTENT(IN) :: a, b
47    INTEGER, INTENT(OUT) :: c
48    c = a * b
49  END SUBROUTINE sub_mul
50
51  SUBROUTINE echo_add ()
52    IMPLICIT NONE
53    WRITE (*,*) "Hi from adder!"
54  END SUBROUTINE echo_add
55
56  INTEGER FUNCTION echo_mul ()
57    IMPLICIT NONE
58    echo_mul = 5
59    WRITE (*,*) "Hi from muler!"
60  END FUNCTION echo_mul
61
62  ! Do the testing here, in the same module as the type is.
63  SUBROUTINE test ()
64    IMPLICIT NONE
65
66    TYPE(add) :: adder
67    TYPE(mul) :: muler
68
69    INTEGER :: x
70
71    IF (adder%func (2, 3) /= 5 .OR. muler%func (2, 3) /= 6) THEN
72      STOP 1
73    END IF
74
75    CALL adder%sub (2, 3, x)
76    IF (x /= 5) THEN
77      STOP 2
78    END IF
79
80    CALL muler%sub (2, 3, x)
81    IF (x /= 6) THEN
82      STOP 3
83    END IF
84
85    ! Check procedures without arguments.
86    CALL adder%echo ()
87    x = muler%echo ()
88    CALL adder%echo
89  END SUBROUTINE test
90
91END MODULE m
92
93PROGRAM main
94  USE m, ONLY: test
95  CALL test ()
96END PROGRAM main
97