1! { dg-do run }
2
3! Type-bound procedures
4! Check they can actually be called and run correctly.
5! This also checks for correct module save/restore.
6
7! FIXME: Check that calls to inherited bindings work once CLASS allows that.
8
9MODULE m
10  IMPLICIT NONE
11
12  TYPE mynum
13    REAL :: num_real
14    INTEGER :: num_int
15  CONTAINS
16    PROCEDURE, PASS, PRIVATE :: add_mynum ! Check that this may be PRIVATE.
17    PROCEDURE, PASS :: add_int
18    PROCEDURE, PASS :: add_real
19    PROCEDURE, PASS :: assign_int
20    PROCEDURE, PASS :: assign_real
21    PROCEDURE, PASS(from) :: assign_to_int
22    PROCEDURE, PASS(from) :: assign_to_real
23    PROCEDURE, PASS :: get_all
24
25    GENERIC :: OPERATOR(+) => add_mynum, add_int, add_real
26    GENERIC :: OPERATOR(.GET.) => get_all
27    GENERIC :: ASSIGNMENT(=) => assign_int, assign_real, &
28                                assign_to_int, assign_to_real
29  END TYPE mynum
30
31CONTAINS
32
33  TYPE(mynum) FUNCTION add_mynum (a, b)
34    CLASS(mynum), INTENT(IN) :: a, b
35    add_mynum = mynum (a%num_real + b%num_real, a%num_int + b%num_int)
36  END FUNCTION add_mynum
37
38  TYPE(mynum) FUNCTION add_int (a, b)
39    CLASS(mynum), INTENT(IN) :: a
40    INTEGER, INTENT(IN) :: b
41    add_int = mynum (a%num_real, a%num_int + b)
42  END FUNCTION add_int
43
44  TYPE(mynum) FUNCTION add_real (a, b)
45    CLASS(mynum), INTENT(IN) :: a
46    REAL, INTENT(IN) :: b
47    add_real = mynum (a%num_real + b, a%num_int)
48  END FUNCTION add_real
49
50  REAL FUNCTION get_all (me)
51    CLASS(mynum), INTENT(IN) :: me
52    get_all = me%num_real + me%num_int
53  END FUNCTION get_all
54
55  SUBROUTINE assign_real (dest, from)
56    CLASS(mynum), INTENT(INOUT) :: dest
57    REAL, INTENT(IN) :: from
58    dest%num_real = from
59  END SUBROUTINE assign_real
60
61  SUBROUTINE assign_int (dest, from)
62    CLASS(mynum), INTENT(INOUT) :: dest
63    INTEGER, INTENT(IN) :: from
64    dest%num_int = from
65  END SUBROUTINE assign_int
66
67  SUBROUTINE assign_to_real (dest, from)
68    REAL, INTENT(OUT) :: dest
69    CLASS(mynum), INTENT(IN) :: from
70    dest = from%num_real
71  END SUBROUTINE assign_to_real
72
73  SUBROUTINE assign_to_int (dest, from)
74    INTEGER, INTENT(OUT) :: dest
75    CLASS(mynum), INTENT(IN) :: from
76    dest = from%num_int
77  END SUBROUTINE assign_to_int
78
79  ! Test it works basically within the module.
80  SUBROUTINE check_in_module ()
81    IMPLICIT NONE
82    TYPE(mynum) :: num
83
84    num = mynum (1.0, 2)
85    num = num + 7
86    IF (num%num_real /= 1.0 .OR. num%num_int /= 9) CALL abort ()
87  END SUBROUTINE check_in_module
88
89END MODULE m
90
91! Here we see it also works for use-associated operators loaded from a module.
92PROGRAM main
93  USE m, ONLY: mynum, check_in_module
94  IMPLICIT NONE
95
96  TYPE(mynum) :: num1, num2, num3
97  REAL :: real_var
98  INTEGER :: int_var
99
100  CALL check_in_module ()
101
102  num1 = mynum (1.0, 2)
103  num2 = mynum (2.0, 3)
104
105  num3 = num1 + num2
106  IF (num3%num_real /= 3.0 .OR. num3%num_int /= 5) CALL abort ()
107
108  num3 = num1 + 5
109  IF (num3%num_real /= 1.0 .OR. num3%num_int /= 7) CALL abort ()
110
111  num3 = num1 + (-100.5)
112  IF (num3%num_real /= -99.5 .OR. num3%num_int /= 2) CALL abort ()
113
114  num3 = 42
115  num3 = -1.2
116  IF (num3%num_real /= -1.2 .OR. num3%num_int /= 42) CALL abort ()
117
118  real_var = num3
119  int_var = num3
120  IF (real_var /= -1.2 .OR. int_var /= 42) CALL abort ()
121
122  IF (.GET. num1 /= 3.0) CALL abort ()
123END PROGRAM main
124