gcc/testsuite/gfortran.dg/namelist_14.f90

   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
   9 module global
  10   type             ::  mt
  11     sequence
  12     integer        ::  ii(4)
  13   end type mt
  14 end module global
  15
  16 program 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
  30 contains
  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 ) STOP 1
  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 ) STOP 2
  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    "))) STOP 3
  95
  96     end subroutine foo
  97 end program namelist_14