OpenCores
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/] [same_type_as_2.f03] - Blame information for rev 377

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

Line No. Rev Author Line
1 302 jeremybenn 
! { dg-do run }
2 
!
3 
! Verifying the runtime behavior of the intrinsic function SAME_TYPE_AS.
4 
!
5 
! Contributed by Janus Weil
6 
 
7 
 type :: t1
8 
  integer :: i
9 
 end type
10 
 
11 
 type, extends(t1) :: t2
12 
  integer :: j
13 
 end type
14 
 
15 
 CLASS(t1), pointer :: c1,c2
16 
 TYPE(t1), target :: x1
17 
 TYPE(t2) ,target :: x2
18 
 
19 
 intrinsic :: SAME_TYPE_AS
20 
 logical :: l
21 
 
22 
 c1 => NULL()
23 
 
24 
 l = SAME_TYPE_AS (x1,x1)
25 
 print *,l
26 
 if (.not.l) call abort()
27 
 l = SAME_TYPE_AS (x1,x2)
28 
 print *,l
29 
 if (l) call abort()
30 
 
31 
 c1 => x1
32 
 l = SAME_TYPE_AS (c1,x1)
33 
 print *,l
34 
 if (.not.l) call abort()
35 
 l = SAME_TYPE_AS (c1,x2)
36 
 print *,l
37 
 if (l) call abort()
38 
 
39 
 c1 => x2
40 
 c2 => x2
41 
 l = SAME_TYPE_AS (c1,c2)
42 
 print *,l
43 
 if (.not.l) call abort()
44 
 
45 
 c1 => x1
46 
 c2 => x2
47 
 l = SAME_TYPE_AS (c1,c2)
48 
 print *,l
49 
 if (l) call abort()
50 
 
51 
end

powered by: WebSVN 2.1.0

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