1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
! { dg-do run }
!
! Test the fix for PR99819 - explicit shape class arrays in different
! procedures caused an ICE.
!
! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
!
program p
type t
integer :: i
end type
class(t), allocatable :: dum1(:), dum2(:), dum3(:,:)
allocate (t :: dum1(3), dum2(10), dum3(2,5))
dum2%i = [1,2,3,4,5,6,7,8,9,10]
dum3%i = reshape ([1,2,3,4,5,6,7,8,9,10],[2,5])
! Somewhat elaborated versions of the PR procedures.
if (f (dum1, dum2, dum3) .ne. 10) stop 1
if (g (dum1) .ne. 3) stop 2
! Test the original versions of the procedures.
if (f_original (dum1, dum2) .ne. 3) stop 3
if (g_original (dum2) .ne. 10) stop 4
contains
integer function f(x, y, z)
class(t) :: x(:)
class(t) :: y(size( x))
class(t) :: z(2,*)
if (size (y) .ne. 3) stop 5
if (size (z) .ne. 0) stop 6
select type (y)
type is (t)
f = 1
if (any (y%i .ne. [1,2,3])) stop 7
class default
f = 0
end select
select type (z)
type is (t)
f = f*10
if (any (z(1,1:4)%i .ne. [1,3,5,7])) stop 8
class default
f = 0
end select
end
integer function g(z)
class(t) :: z(:)
type(t) :: u(size(z))
g = size (u)
end
integer function f_original(x, y)
class(t) :: x(:)
class(*) :: y(size (x))
f_original = size (y)
end
integer function g_original(z)
class(*) :: z(:)
type(t) :: u(size(z))
g_original = size (u)
end
end
|
