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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { dg-do run }
2
! { dg-options "-fdump-tree-original" }
3
! Test constructors of derived type with allocatable components (PR 20541).
4
!
5
! Contributed by Erik Edelmann  
6
!            and Paul Thomas  
7
!
8
 
9
Program test_constructor
10
 
11
    implicit none
12
 
13
    type :: thytype
14
        integer(4) :: a(2,2)
15
    end type thytype
16
 
17
    type :: mytype
18
        integer(4), allocatable :: a(:, :)
19
        type(thytype), allocatable :: q(:)
20
    end type mytype
21
 
22
    type (mytype) :: x
23
    type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2]))
24
    integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2])
25
    integer, allocatable :: yy(:,:)
26
    type (thytype), allocatable :: bar(:)
27
    integer :: i
28
 
29
    ! Check that null() works
30
    x = mytype(null(), null())
31
    if (allocated(x%a) .or. allocated(x%q)) call abort()
32
 
33
    ! Check that unallocated allocatables work
34
    x = mytype(yy, bar)
35
    if (allocated(x%a) .or. allocated(x%q)) call abort()
36
 
37
    ! Check that non-allocatables work
38
    x = mytype(y, [foo, foo])
39
    if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
40
    if (any(lbound(x%a) /= lbound(y))) call abort()
41
    if (any(ubound(x%a) /= ubound(y))) call abort()
42
    if (any(x%a /= y)) call abort()
43
    if (size(x%q) /= 2) call abort()
44
    do i = 1, 2
45
        if (any(x%q(i)%a /= foo%a)) call abort()
46
    end do
47
 
48
    ! Check that allocated allocatables work
49
    allocate(yy(size(y,1), size(y,2)))
50
    yy = y
51
    allocate(bar(2))
52
    bar = [foo, foo]
53
    x = mytype(yy, bar)
54
    if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
55
    if (any(x%a /= y)) call abort()
56
    if (size(x%q) /= 2) call abort()
57
    do i = 1, 2
58
        if (any(x%q(i)%a /= foo%a)) call abort()
59
    end do
60
 
61
    ! Functions returning arrays
62
    x = mytype(bluhu(), null())
63
    if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
64
    if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) call abort()
65
 
66
    ! Functions returning allocatable arrays
67
    x = mytype(blaha(), null())
68
    if (.not.allocated(x%a) .or. allocated(x%q)) call abort()
69
    if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) call abort()
70
 
71
    ! Check that passing the constructor to a procedure works
72
    call check_mytype (mytype(y, [foo, foo]))
73
 
74
contains
75
 
76
    subroutine check_mytype(x)
77
        type(mytype), intent(in) :: x
78
        integer :: i
79
 
80
        if (.not.allocated(x%a) .or. .not.allocated(x%q)) call abort()
81
        if (any(lbound(x%a) /= lbound(y))) call abort()
82
        if (any(ubound(x%a) /= ubound(y))) call abort()
83
        if (any(x%a /= y)) call abort()
84
        if (size(x%q) /= 2) call abort()
85
        do i = 1, 2
86
            if (any(x%q(i)%a /= foo%a)) call abort()
87
        end do
88
 
89
    end subroutine check_mytype
90
 
91
 
92
    function bluhu()
93
        integer :: bluhu(2,2)
94
 
95
        bluhu = reshape ([41, 98, 54, 76], [2,2])
96
    end function bluhu
97
 
98
 
99
    function blaha()
100
        integer, allocatable :: blaha(:,:)
101
 
102
        allocate(blaha(2,2))
103
        blaha = reshape ([40, 97, 53, 75], [2,2])
104
    end function blaha
105
 
106
end program test_constructor
107
! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } }
108
! { dg-final { cleanup-tree-dump "original" } }

powered by: WebSVN 2.1.0

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