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
|
! { dg-do run }
!
! Test the fix for PRs93924 & 93925.
!
! Contributed by Martin Stein <mscfd@gmx.net>
!
module cs
implicit none
integer, target :: integer_target
abstract interface
function classStar_map_ifc(x) result(y)
class(*), pointer :: y
class(*), target, intent(in) :: x
end function classStar_map_ifc
end interface
contains
function fun(x) result(y)
class(*), pointer :: y
class(*), target, intent(in) :: x
select type (x)
type is (integer)
integer_target = x ! Deals with dangling target.
y => integer_target
class default
y => null()
end select
end function fun
function apply(f, x) result(y)
procedure(classStar_map_ifc) :: f
integer, intent(in) :: x
integer :: y
class(*), pointer :: p
y = 0 ! Get rid of 'y' undefined warning
p => f (x)
select type (p)
type is (integer)
y = p
end select
end function apply
function selector() result(f)
procedure(classStar_map_ifc), pointer :: f
f => fun
end function selector
end module cs
program classStar_map
use cs
implicit none
integer :: x, y
procedure(classStar_map_ifc), pointer :: f
x = 123654
f => selector () ! Fixed by second chunk in patch
y = apply (f, x) ! Fixed by first chunk in patch
if (x .ne. y) stop 1
x = 2 * x
y = apply (fun, x) ! PR93925; fixed as above
if (x .ne. y) stop 2
end program classStar_map
|
