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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [move_alloc_6.f90] - Blame information for rev 694

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { dg-do run }
2
!
3
! Test move_alloc for polymorphic scalars
4
!
5
!
6
module myalloc
7
  implicit none
8
 
9
  type :: base_type
10
     integer :: i  =2
11
  end type base_type
12
 
13
  type, extends(base_type) :: extended_type
14
     integer :: j = 77
15
  end type extended_type
16
contains
17
  subroutine myallocate (a)
18
    class(base_type), allocatable, intent(inout) :: a
19
    class(base_type), allocatable :: tmp
20
 
21
    allocate (extended_type :: tmp)
22
 
23
    select type(tmp)
24
      type is(base_type)
25
        call abort ()
26
      type is(extended_type)
27
        if (tmp%i /= 2 .or. tmp%j /= 77) call abort()
28
        tmp%i = 5
29
        tmp%j = 88
30
    end select
31
 
32
    select type(a)
33
      type is(base_type)
34
        if (a%i /= -44) call abort()
35
        a%i = -99
36
      class default
37
        call abort ()
38
    end select
39
 
40
    call move_alloc (from=tmp, to=a)
41
 
42
    select type(a)
43
      type is(extended_type)
44
        if (a%i /= 5) call abort()
45
        if (a%j /= 88) call abort()
46
        a%i = 123
47
        a%j = 9498
48
      class default
49
        call abort ()
50
    end select
51
 
52
    if (allocated (tmp)) call abort()
53
  end subroutine myallocate
54
end module myalloc
55
 
56
program main
57
  use myalloc
58
  implicit none
59
  class(base_type), allocatable :: a
60
 
61
  allocate (a)
62
 
63
  select type(a)
64
    type is(base_type)
65
      if (a%i /= 2) call abort()
66
      a%i = -44
67
    class default
68
      call abort ()
69
  end select
70
 
71
  call myallocate (a)
72
 
73
  select type(a)
74
    type is(extended_type)
75
      if (a%i /= 123) call abort()
76
      if (a%j /= 9498) call abort()
77
    class default
78
      call abort ()
79
  end select
80
end program main

powered by: WebSVN 2.1.0

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