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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [gfortran.dg/] [func_derived_3.f90] - Blame information for rev 844

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

Line No. Rev Author Line
1 149 jeremybenn 
! { dg-do run }
2 
! This tests the "virtual fix" for PR19561, where pointers to derived
3 
! types were not generating correct code.  This testcase is based on
4 
! the original PR example.  This example not only tests the
5 
! original problem but throughly tests derived types in modules,
6 
! module interfaces and compound derived types.
7 
!
8 
! Original by Martin Reinecke  martin@mpa-garching.mpg.de
9 
! Submitted by Paul Thomas  pault@gcc.gnu.org
10 
! Slightly modified by Tobias Schlüter
11 
module func_derived_3
12 
  implicit none
13 
  type objA
14 
    private
15 
    integer :: i
16 
  end type objA
17 
 
18 
  interface new
19 
    module procedure oaInit
20 
  end interface
21 
 
22 
  interface print
23 
    module procedure oaPrint
24 
  end interface
25 
 
26 
  private
27 
  public objA,new,print
28 
 
29 
contains
30 
 
31 
  subroutine oaInit(oa,i)
32 
    integer :: i
33 
    type(objA) :: oa
34 
    oa%i=i
35 
  end subroutine oaInit
36 
 
37 
  subroutine oaPrint (oa)
38 
    type (objA) :: oa
39 
    write (10, '("simple  = ",i5)') oa%i
40 
    end subroutine oaPrint
41 
 
42 
end module func_derived_3
43 
 
44 
module func_derived_3a
45 
  use func_derived_3
46 
  implicit none
47 
 
48 
  type objB
49 
    private
50 
    integer :: i
51 
    type(objA), pointer :: oa
52 
  end type objB
53 
 
54 
  interface new
55 
    module procedure obInit
56 
  end interface
57 
 
58 
  interface print
59 
    module procedure obPrint
60 
  end interface
61 
 
62 
  private
63 
  public objB, new, print, getOa, getOa2
64 
 
65 
contains
66 
 
67 
  subroutine obInit (ob,oa,i)
68 
    integer :: i
69 
    type(objA), target :: oa
70 
    type(objB) :: ob
71 
 
72 
    ob%i=i
73 
    ob%oa=>oa
74 
  end subroutine obInit
75 
 
76 
  subroutine obPrint (ob)
77 
    type (objB) :: ob
78 
    write (10, '("derived = ",i5)') ob%i
79 
    call print (ob%oa)
80 
  end subroutine obPrint
81 
 
82 
  function getOa (ob) result (oa)
83 
    type (objB),target :: ob
84 
    type (objA), pointer :: oa
85 
 
86 
    oa=>ob%oa
87 
  end function getOa
88 
 
89 
! without a result clause
90 
  function getOa2 (ob)
91 
    type (objB),target :: ob
92 
    type (objA), pointer :: getOa2
93 
 
94 
    getOa2=>ob%oa
95 
  end function getOa2
96 
 
97 
end module func_derived_3a
98 
 
99 
  use func_derived_3
100 
  use func_derived_3a
101 
  implicit none
102 
  type (objA),target :: oa
103 
  type (objB),target :: ob
104 
  character (len=80) :: line
105 
 
106 
  open (10, status='scratch')
107 
 
108 
  call new (oa,1)
109 
  call new (ob, oa, 2)
110 
 
111 
  call print (ob)
112 
  call print (getOa (ob))
113 
  call print (getOa2 (ob))
114 
 
115 
  rewind (10)
116 
  read (10, '(80a)') line
117 
  if (trim (line).ne."derived =     2") call abort ()
118 
  read (10,  '(80a)') line
119 
  if (trim (line).ne."simple  =     1") call abort ()
120 
  read (10,  '(80a)') line
121 
  if (trim (line).ne."simple  =     1") call abort ()
122 
  read (10,  '(80a)') line
123 
  if (trim (line).ne."simple  =     1") call abort ()
124 
  close (10)
125 
end program
126 
 
127 
! { dg-final { cleanup-modules "func_derived_3 func_derived_3a" } }

powered by: WebSVN 2.1.0

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