URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.dg/] [dynamic_dispatch_2.f03] - Blame information for rev 302

Details | Compare with Previous | View Log


! { dg-do run }
! Tests dynamic dispatch of class subroutines.
!
! Contributed by Paul Thomas 
!
module m
  type :: t1
    integer :: i = 42
    procedure(make_real), pointer :: ptr
  contains
    procedure, pass :: real => make_real
    procedure, pass :: make_integer
    procedure, pass :: prod => i_m_j
    generic, public :: extract => real, make_integer
    generic, public :: base_extract => real, make_integer
  end type t1
 
  type, extends(t1) :: t2
    integer :: j = 99
  contains
    procedure, pass :: real => make_real2
    procedure, pass :: make_integer_2
    procedure, pass :: prod => i_m_j_2
    generic, public :: extract => real, make_integer_2
  end type t2
contains
  subroutine make_real (arg, arg2)
    class(t1), intent(in) :: arg
    real :: arg2
    arg2 = real (arg%i)
  end subroutine make_real
 
  subroutine make_real2 (arg, arg2)
    class(t2), intent(in) :: arg
    real :: arg2
    arg2 = real (arg%j)
  end subroutine make_real2
 
  subroutine make_integer (arg, arg2, arg3)
    class(t1), intent(in) :: arg
    integer :: arg2, arg3
    arg3 = arg%i * arg2
  end subroutine make_integer
 
  subroutine make_integer_2 (arg, arg2, arg3)
    class(t2), intent(in) :: arg
    integer :: arg2, arg3
    arg3 = arg%j * arg2
  end subroutine make_integer_2
 
  subroutine i_m_j (arg, arg2)
    class(t1), intent(in) :: arg
    integer :: arg2
        arg2 = arg%i
  end subroutine i_m_j
 
  subroutine i_m_j_2 (arg, arg2)
    class(t2), intent(in) :: arg
    integer :: arg2
        arg2 = arg%j
  end subroutine i_m_j_2
end module m
 
  use m
  type, extends(t1) :: l1
    character(16) :: chr
  end type l1
  class(t1), pointer :: a !=> NULL()
  type(t1), target :: b
  type(t2), target :: c
  type(l1), target :: d
  real :: r
  integer :: i
 
  a => b                                   ! declared type
  call a%real(r)
  if (r .ne. real (42)) call abort
  call a%prod(i)
  if (i .ne. 42) call abort
  call a%extract (2, i)
  if (i .ne. 84) call abort
  call a%base_extract (2, i)
  if (i .ne. 84) call abort
 
  a => c                                   ! extension in module
  call a%real(r)
  if (r .ne. real (99)) call abort
  call a%prod(i)
  if (i .ne. 99) call abort
  call a%extract (3, i)
  if (i .ne. 297) call abort
  call a%base_extract (3, i)
  if (i .ne. 126) call abort
 
  a => d                                   ! extension in main
  call a%real(r)
  if (r .ne. real (42)) call abort
  call a%prod(i)
  if (i .ne. 42) call abort
  call a%extract (4, i)
  if (i .ne. 168) call abort
  call a%extract (4, i)
  if (i .ne. 168) call abort
end
! { dg-final { cleanup-modules "m" } }

Line No.	Rev	Author	Line
1	302	jeremybenn	`! { dg-do run }`
2			`! Tests dynamic dispatch of class subroutines.`
3			`!`
4			`! Contributed by Paul Thomas`
5			`!`
6			`module m`
7			`type :: t1`
8			`integer :: i = 42`
9			`procedure(make_real), pointer :: ptr`
10			`contains`
11			`procedure, pass :: real => make_real`
12			`procedure, pass :: make_integer`
13			`procedure, pass :: prod => i_m_j`
14			`generic, public :: extract => real, make_integer`
15			`generic, public :: base_extract => real, make_integer`
16			`end type t1`
17
18			`type, extends(t1) :: t2`
19			`integer :: j = 99`
20			`contains`
21			`procedure, pass :: real => make_real2`
22			`procedure, pass :: make_integer_2`
23			`procedure, pass :: prod => i_m_j_2`
24			`generic, public :: extract => real, make_integer_2`
25			`end type t2`
26			`contains`
27			`subroutine make_real (arg, arg2)`
28			`class(t1), intent(in) :: arg`
29			`real :: arg2`
30			`arg2 = real (arg%i)`
31			`end subroutine make_real`
32
33			`subroutine make_real2 (arg, arg2)`
34			`class(t2), intent(in) :: arg`
35			`real :: arg2`
36			`arg2 = real (arg%j)`
37			`end subroutine make_real2`
38
39			`subroutine make_integer (arg, arg2, arg3)`
40			`class(t1), intent(in) :: arg`
41			`integer :: arg2, arg3`
42			`arg3 = arg%i * arg2`
43			`end subroutine make_integer`
44
45			`subroutine make_integer_2 (arg, arg2, arg3)`
46			`class(t2), intent(in) :: arg`
47			`integer :: arg2, arg3`
48			`arg3 = arg%j * arg2`
49			`end subroutine make_integer_2`
50
51			`subroutine i_m_j (arg, arg2)`
52			`class(t1), intent(in) :: arg`
53			`integer :: arg2`
54			`arg2 = arg%i`
55			`end subroutine i_m_j`
56
57			`subroutine i_m_j_2 (arg, arg2)`
58			`class(t2), intent(in) :: arg`
59			`integer :: arg2`
60			`arg2 = arg%j`
61			`end subroutine i_m_j_2`
62			`end module m`
63
64			`use m`
65			`type, extends(t1) :: l1`
66			`character(16) :: chr`
67			`end type l1`
68			`class(t1), pointer :: a !=> NULL()`
69			`type(t1), target :: b`
70			`type(t2), target :: c`
71			`type(l1), target :: d`
72			`real :: r`
73			`integer :: i`
74
75			`a => b ! declared type`
76			`call a%real(r)`
77			`if (r .ne. real (42)) call abort`
78			`call a%prod(i)`
79			`if (i .ne. 42) call abort`
80			`call a%extract (2, i)`
81			`if (i .ne. 84) call abort`
82			`call a%base_extract (2, i)`
83			`if (i .ne. 84) call abort`
84
85			`a => c ! extension in module`
86			`call a%real(r)`
87			`if (r .ne. real (99)) call abort`
88			`call a%prod(i)`
89			`if (i .ne. 99) call abort`
90			`call a%extract (3, i)`
91			`if (i .ne. 297) call abort`
92			`call a%base_extract (3, i)`
93			`if (i .ne. 126) call abort`
94
95			`a => d ! extension in main`
96			`call a%real(r)`
97			`if (r .ne. real (42)) call abort`
98			`call a%prod(i)`
99			`if (i .ne. 42) call abort`
100			`call a%extract (4, i)`
101			`if (i .ne. 168) call abort`
102			`call a%extract (4, i)`
103			`if (i .ne. 168) call abort`
104			`end`
105			`! { dg-final { cleanup-modules "m" } }`

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.dg/] [dynamic_dispatch_2.f03] - Blame information for rev 302