1! { dg-do run }
2! { dg-options "-std=legacy" }
3!
4! This tests the fix for PR24276, which originated from the Loren P. Meissner example,
5! Array_List.  The PR concerns dummy argument aliassing of components of arrays of derived
6! types as arrays of the type of the component.  gfortran would compile and run this
7! example but the stride used did not match the actual argument.  This test case exercises
8! a procedure call (to foo2, below) that is identical to Array_List's.
9!
10! Contributed by Paul Thomas  <pault@gcc.gnu.org>
11
12program test_lex
13  type :: dtype
14    integer :: n
15    character*5 :: word
16  end type dtype
17
18  type :: list
19    type(dtype), dimension(4) :: list
20    integer :: l = 4
21  end type list
22
23  type(list) :: table
24  type(dtype) :: elist(2,2)
25
26  table%list = (/dtype (1 , "one  "), dtype (2 , "two  "), dtype (3 , "three"), dtype (4 , "four ")/)
27
28! Test 1D with assumed shape (original bug) and assumed size.
29  call bar (table, 2, 4)
30  if (any (table%list%word.ne.(/"one  ","i=  2","three","i=  4"/))) call abort ()
31
32  elist = reshape (table%list, (/2,2/))
33
34! Check 2D is OK with assumed shape and assumed size.
35  call foo3 (elist%word, 1)
36  call foo1 (elist%word, 3)
37  if (any (elist%word.ne.reshape ((/"i=  1","i=  2","i=  3","i=  4"/), (/2,2/)))) call abort ()
38
39contains
40
41  subroutine bar (table, n, m)
42    type(list) :: table
43    integer n, m
44    call foo1 (table%list(:table%l)%word, n)
45    call foo2 (table%list(:table%l)%word, m)
46  end subroutine bar
47
48  subroutine foo1 (slist, i)
49    character(*), dimension(*) :: slist
50    integer i
51    write (slist(i), '(2hi=,i3)') i
52  end subroutine foo1
53
54  subroutine foo2 (slist, i)
55    character(5), dimension(:) :: slist
56    integer i
57    write (slist(i), '(2hi=,i3)') i
58  end subroutine foo2
59
60  subroutine foo3 (slist, i)
61    character(5), dimension(:,:) :: slist
62    integer i
63    write (slist(1,1), '(2hi=,i3)') i
64  end subroutine foo3
65
66end program test_lex
67
68