gcc/testsuite/gfortran.dg/namelist_14.f90

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