1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
module class_17_mod
implicit none
type :: type_pass
integer :: value
contains
procedure :: set_value_pass
generic :: set_value => set_value_pass
end type
type :: type_no_pass
integer :: value
contains
procedure, nopass :: set_value_no_pass, set_value_no_pass_no_obj
generic :: set_value => set_value_no_pass, set_value_no_pass_no_obj
end type
contains
subroutine set_value_pass(this, value)
class(type_pass), intent(inout) :: this
integer, intent(in) :: value
this%value = 2 * value
end subroutine
subroutine set_value_no_pass(obj, value)
class(type_no_pass), intent(inout) :: obj
integer, intent(in) :: value
obj%value = value
end subroutine
subroutine set_value_no_pass_no_obj(value)
integer, intent(inout) :: value
value = 25
end subroutine
end module
program class_17
use class_17_mod
implicit none
integer :: value
type(type_pass) :: obj_pass
type(type_no_pass) :: obj_no_pass
obj_pass%value = 42
! below tests show different calls to the same
! GenericProcedure (actually the same StructMethodDeclaration)
! case 1. passed as argument
call obj_pass%set_value(45)
print *, "obj_pass%value: ", obj_pass%value
if (obj_pass%value /= 90) error stop
! case 2. passed as kwarg
call obj_pass%set_value(value=50)
print *, "obj_pass%value: ", obj_pass%value
if (obj_pass%value /= 100) error stop
obj_no_pass%value = 42
! below tests show different calls to the same
! GenericProcedure (actually the same StructMethodDeclaration)
! case 1. both are arguments
call obj_no_pass%set_value(obj_no_pass, 5)
print *, "obj_no_pass%value: ", obj_no_pass%value
if (obj_no_pass%value /= 5) error stop
! case 2. first is argument, second is kwarg
call obj_no_pass%set_value(obj_no_pass, value=10)
print *, "obj_no_pass%value: ", obj_no_pass%value
if (obj_no_pass%value /= 10) error stop
! case 3. both are kwargs
call obj_no_pass%set_value(obj=obj_no_pass, value=11)
print *, "obj_no_pass%value: ", obj_no_pass%value
if (obj_no_pass%value /= 11) error stop
! case 4. both are kwargs, but position interchanged
call obj_no_pass%set_value(value=64, obj=obj_no_pass)
print *, "obj_no_pass%value: ", obj_no_pass%value
if (obj_no_pass%value /= 64) error stop
value = 10
! below tests show different calls to the same
! GenericProcedure (actually the same StructMethodDeclaration),
! which accepts only one argument
! case 1. passed as argument
call obj_no_pass%set_value(value)
print *, "value: ", value
if (value /= 25) error stop
value = 30
! case 2. passed as kwarg
call obj_no_pass%set_value(value=value)
print *, "value: ", value
if (value /= 25) error stop
end program class_17
|
