OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

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

Go to most recent revision | Details | Compare with Previous | View Log

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" } }

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.