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

Subversion Repositories openrisc

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [gfortran.dg/] [dynamic_dispatch_3.f03] - Blame information for rev 384

Details | Compare with Previous | View Log


! { dg-do run }
! Tests dynamic dispatch of class functions, spread over
! different modules. Apart from the location of the derived
! type declarations, this test is the same as
! dynamic_dispatch_1.f03
!
! Contributed by Paul Thomas 
!
module m1
  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
contains
  real function make_real (arg)
    class(t1), intent(in) :: arg
    make_real = real (arg%i)
  end function make_real
 
  integer function make_integer (arg, arg2)
    class(t1), intent(in) :: arg
    integer :: arg2
    make_integer = arg%i * arg2
  end function make_integer
 
  integer function i_m_j (arg)
    class(t1), intent(in) :: arg
        i_m_j = arg%i
  end function i_m_j
end module m1
 
module m2
  use m1
  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
  real function make_real2 (arg)
    class(t2), intent(in) :: arg
    make_real2 = real (arg%j)
  end function make_real2
 
  integer function make_integer_2 (arg, arg2)
    class(t2), intent(in) :: arg
    integer :: arg2
    make_integer_2 = arg%j * arg2
  end function make_integer_2
 
  integer function i_m_j_2 (arg)
    class(t2), intent(in) :: arg
        i_m_j_2 = arg%j
  end function i_m_j_2
end module m2
 
  use m1
  use m2
  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
  a => b                                   ! declared type in module m1
  if (a%real() .ne. real (42)) call abort
  if (a%prod() .ne. 42) call abort
  if (a%extract (2) .ne. 84) call abort
  if (a%base_extract (2) .ne. 84) call abort
  a => c                                   ! extension in module m2
  if (a%real() .ne. real (99)) call abort
  if (a%prod() .ne. 99) call abort
  if (a%extract (3) .ne. 297) call abort
  if (a%base_extract (3) .ne. 126) call abort
  a => d                                   ! extension in main
  if (a%real() .ne. real (42)) call abort
  if (a%prod() .ne. 42) call abort
  if (a%extract (4) .ne. 168) call abort
  if (a%base_extract (4) .ne. 168) call abort
end
! { dg-final { cleanup-modules "m1, m2" } }

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

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [gfortran.dg/] [dynamic_dispatch_3.f03] - Blame information for rev 384