1! { dg-do run }
2
3! Type-bound procedures
4! Check calls with passed-objects.
5
6MODULE m
7  IMPLICIT NONE
8
9  TYPE add
10    INTEGER :: wrong
11    INTEGER :: val
12  CONTAINS
13    PROCEDURE, PASS :: func => func_add
14    PROCEDURE, PASS(me) :: sub => sub_add
15  END TYPE add
16
17  TYPE trueOrFalse
18    LOGICAL :: val
19  CONTAINS
20    PROCEDURE, PASS :: swap
21  END TYPE trueOrFalse
22
23CONTAINS
24
25  INTEGER FUNCTION func_add (me, x)
26    IMPLICIT NONE
27    CLASS(add) :: me
28    INTEGER :: x
29    func_add = me%val + x
30  END FUNCTION func_add
31
32  SUBROUTINE sub_add (res, me, x)
33    IMPLICIT NONE
34    INTEGER, INTENT(OUT) :: res
35    CLASS(add), INTENT(IN) :: me
36    INTEGER, INTENT(IN) :: x
37    res = me%val + x
38  END SUBROUTINE sub_add
39
40  SUBROUTINE swap (me1, me2)
41    IMPLICIT NONE
42    CLASS(trueOrFalse), INTENT(INOUT) :: me1, me2
43
44    IF (.NOT. me1%val .OR. me2%val) THEN
45      CALL abort ()
46    END IF
47    
48    me1%val = .FALSE.
49    me2%val = .TRUE.
50  END SUBROUTINE swap
51
52  ! Do the testing here, in the same module as the type is.
53  SUBROUTINE test ()
54    IMPLICIT NONE
55
56    TYPE(add) :: adder
57    TYPE(trueOrFalse) :: t, f
58
59    INTEGER :: x
60
61    adder%wrong = 0
62    adder%val = 42
63    IF (adder%func (8) /= 50) THEN
64      CALL abort ()
65    END IF
66
67    CALL adder%sub (x, 8)
68    IF (x /=  50) THEN
69      CALL abort ()
70    END IF
71
72    t%val = .TRUE.
73    f%val = .FALSE.
74
75    CALL t%swap (f)
76    CALL f%swap (t)
77
78    IF (.NOT. t%val .OR. f%val) THEN
79      CALL abort ()
80    END IF
81  END SUBROUTINE test
82
83END MODULE m
84
85PROGRAM main
86  USE m, ONLY: test
87  CALL test ()
88END PROGRAM main
89