1!{ dg-do run }
2!{ dg-options "-std=legacy" }
3!
4! Tests various combinations of intrinsic types, derived types, arrays,
5! dummy arguments and common to check nml_get_addr_expr in trans-io.c.
6! See comments below for selection.
7! provided by Paul Thomas - pault@gcc.gnu.org
8
9module global
10  type             ::  mt
11    sequence
12    integer        ::  ii(4)
13  end type mt
14end module global
15
16program namelist_14
17  use global
18  common /myc/ cdt
19  integer          ::  i(2) = (/101,201/)
20  type(mt)         ::  dt(2)
21  type(mt)         ::  cdt
22  real(kind=8)           ::  pi = 3.14159_8
23  character*10     ::  chs="singleton"
24  character*10     ::  cha(2)=(/"first     ","second    "/)
25
26  dt = mt ((/99,999,9999,99999/))
27  cdt = mt ((/-99,-999,-9999,-99999/))
28  call foo (i,dt,pi,chs,cha)
29
30contains
31
32  logical function dttest (dt1, dt2)
33    use global
34    type(mt)       :: dt1
35    type(mt)       :: dt2
36    dttest = any(dt1%ii == dt2%ii)
37  end function dttest
38
39
40  subroutine foo (i, dt, pi, chs, cha)
41    use global
42    common /myc/ cdt
43    real(kind=8)        :: pi                   !local real scalar
44    integer        :: i(2)                 !dummy arg. array
45    integer        :: j(2) = (/21, 21/)    !equivalenced array
46    integer        :: jj                   !    -||-     scalar
47    integer        :: ier
48    type(mt)       :: dt(2)                !dummy arg., derived array
49    type(mt)       :: dtl(2)               !in-scope derived type array
50    type(mt)       :: dts                  !in-scope derived type
51    type(mt)       :: cdt                  !derived type in common block
52    character*10   :: chs                  !dummy arg. character var.
53    character*10   :: cha(:)               !dummy arg. character array
54    character*10   :: chl="abcdefg"        !in-scope character var.
55    equivalence (j,jj)
56    namelist /z/     dt, dtl, dts, cdt, j, jj, i, pi, chs, chl, cha
57
58    dts = mt ((/1, 2, 3, 4/))
59    dtl = mt ((/41, 42, 43, 44/))
60
61    open (10, status = "scratch", delim='apostrophe')
62    write (10, nml = z, iostat = ier)
63    if (ier /= 0 ) call abort()
64    rewind (10)
65
66    i = 0
67    j = 0
68    jj = 0
69    pi = 0
70    dt  = mt ((/0, 0, 0, 0/))
71    dtl = mt ((/0, 0, 0, 0/))
72    dts = mt ((/0, 0, 0, 0/))
73    cdt = mt ((/0, 0, 0, 0/))
74    chs = ""
75    cha = ""
76    chl = ""
77
78    read (10, nml = z, iostat = ier)
79    if (ier /= 0 ) call abort()
80    close (10)
81
82    if (.not.(dttest (dt(1),  mt ((/99,999,9999,99999/))) .and.  &
83          dttest (dt(2),  mt ((/99,999,9999,99999/))) .and.  &
84          dttest (dtl(1), mt ((/41, 42, 43, 44/))) .and.     &
85          dttest (dtl(2), mt ((/41, 42, 43, 44/))) .and.     &
86          dttest (dts, mt ((/1, 2, 3, 4/))) .and.            &
87          dttest (cdt, mt ((/-99,-999,-9999,-99999/))) .and. &
88          all (j ==(/21, 21/)) .and.                         &
89          all (i ==(/101, 201/)) .and.                       &
90          (pi == 3.14159_8) .and.                            &
91          (chs == "singleton") .and.                         &
92          (chl == "abcdefg") .and.                           &
93          (cha(1)(1:10) == "first    ") .and.                &
94          (cha(2)(1:10) == "second    "))) call abort ()
95
96    end subroutine foo
97end program namelist_14
98