Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ! { dg-do run }
2 !
3 ! PR 41829: [OOP] Runtime error with dynamic dispatching. Tests
4 ! dynamic dispatch in a case where the caller knows nothing about
5 ! the dynamic type at compile time.
6 !
7 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
8 !
9 module foo_mod
10 type foo
11 integer :: i
12 contains
13 procedure, pass(a) :: doit
14 procedure, pass(a) :: getit
15 end type foo
16
17 private doit,getit
18 contains
19 subroutine doit(a)
20 class(foo) :: a
21
22 a%i = 1
23 ! write(*,*) 'FOO%DOIT base version'
24 end subroutine doit
25 function getit(a) result(res)
26 class(foo) :: a
27 integer :: res
28
29 res = a%i
30 end function getit
31
32 end module foo_mod
33 module foo2_mod
34 use foo_mod
35
36 type, extends(foo) :: foo2
37 integer :: j
38 contains
39 procedure, pass(a) :: doit => doit2
40 procedure, pass(a) :: getit => getit2
41 end type foo2
42
43 private doit2, getit2
44
45 contains
46
47 subroutine doit2(a)
48 class(foo2) :: a
49
50 a%i = 2
51 a%j = 3
52 ! write(*,*) 'FOO2%DOIT derived version'
53 end subroutine doit2
54 function getit2(a) result(res)
55 class(foo2) :: a
56 integer :: res
57
58 res = a%j
59 end function getit2
60
61 end module foo2_mod
62
63 module bar_mod
64 use foo_mod
65 type bar
66 class(foo), allocatable :: a
67 contains
68 procedure, pass(a) :: doit
69 procedure, pass(a) :: getit
70 end type bar
71 private doit,getit
72
73 contains
74 subroutine doit(a)
75 class(bar) :: a
76
77 call a%a%doit()
78 end subroutine doit
79 function getit(a) result(res)
80 class(bar) :: a
81 integer :: res
82
83 res = a%a%getit()
84 end function getit
85 end module bar_mod
86
87
88 program testd10
89 use foo_mod
90 use foo2_mod
91 use bar_mod
92
93 type(bar) :: a
94
95 allocate(foo :: a%a)
96 call a%doit()
97 ! write(*,*) 'Getit value : ', a%getit()
98 if (a%getit() .ne. 1) call abort
99 deallocate(a%a)
100 allocate(foo2 :: a%a)
101 call a%doit()
102 ! write(*,*) 'Getit value : ', a%getit()
103 if (a%getit() .ne. 3) call abort
104
105 end program testd10