re PR fortran/17472 ([4.0 only] namelist does not handle arrays)

-------------------------------------------------------------------

From-SVN: r98287

gcc/fortran/ChangeLog

+2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+	PR fortran/17472
+	PR fortran/18209
+	PR fortran/18396
+	PR fortran/19467
+	PR fortran/19657
+	* fortran/trans-io.c (gfc_build_io_library_fndecls): Create declaration for
+	st_set_nml_var and st_set_nml_var_dim. Remove declarations of old
+	namelist functions.
+	(build_dt): Simplified call to transfer_namelist_element.
+	(nml_get_addr_expr): Generates address expression for start of object data. New function.
+	(nml_full_name): Qualified name for derived type components. New function.
+	(transfer_namelist_element): Modified for calls to new functions and improved derived
+	type handling.
+
 2005-04-17  Richard Guenther  <rguenth@gcc.gnu.org>
 
 	* scanner.c (gfc_next_char_literal): Reset truncation flag

gcc/testsuite/ChangeLog

+2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+	PR libfortran/12884 gfortran.dg/pr12884.f: New test
+	PR libfortran/17285 gfortran.dg/pr17285.f90: New test
+	PR libfortran/17472, 18396, 18209 gfortran.dg/pr17472.f: New test
+	PR libfortran/18122, 18591 gfortran.dg/pr18122.f90: New test
+	PR libfortran/18210 gfortran.dg/pr18210.f90: New test
+	PR libfortran/18392 gfortran.dg/pr18392.f90: New test
+	PR libfortran/19467 gfortran.dg/pr19467.f90: New test
+	PR libfortran/19657 gfortran.dg/pr19657.f90: New test
+	* gfortran.dg/namelist_1.f90: Correct comment (PUBLIC and PRIVATE wrong way round).
+	* gfortran.dg/namelist_2.f90: Variables with INTENT(IN) cannot be in namelists. New test
+	* gfortran.dg/namelist_3.f90: Pointers cannot be in namelists. New test
+	* gfortran.dg/namelist_11.f: Tests reals and qualifiers in namelist. New test
+	* gfortran.dg/namelist_12.f: Tests integers and qualifiers in namelist. New test
+	* gfortran.dg/namelist_13.f90: Tests derived types in namelist. New test
+	* gfortran.dg/namelist_14.f90: Tests trans-io.c namelist support. New test
+	* gfortran.dg/namelist_15.f90: Tests arrays of derived types in namelist. New test
+	* gfortran.dg/namelist_16.f90: Tests complex in namelist. New test
+	* gfortran.dg/namelist_17.f90: Tests logical in namelist. New test
+	* gfortran.dg/namelist_18.f90: Tests charcter delimiters in namelist. New test
+	* gfortran.dg/namelist_19.f90: Tests namelist errors. New test
+	* gfortran.dg/namelist_20.f90: Tests negative bounds for explicit arrays. New test
+
 2005-04-17  Richard Guenther  <rguenth@gcc.gnu.org>
 
 	* gfortran.dg/wtruncate.f: New testcase.

gcc/testsuite/gfortran.dg/namelist_1.f90

 ! { dg-do compile }
-! Check that public entities in private namelists are rejected
+! Check that private entities in public namelists are rejected
 module namelist_1
   public
   integer,private :: x
   namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" "" }
 end module
-

gcc/testsuite/gfortran.dg/namelist_11.f

+c { dg-do run }
+c This program tests: namelist comment, a blank line before the nameilist name, the namelist name,
+c a scalar qualifier, various combinations of space, comma and lf delimiters, f-formats, e-formats
+c a blank line within the data read, nulls, a range qualifier, a new object name before end of data
+c and an integer read.  It also tests that namelist output can be re-read by namelist input.
+c provided by Paul Thomas - pault@gcc.gnu.org
+
+      program namelist_1
+
+      REAL*4 x(10)
+      REAL*8 xx
+      integer ier
+      namelist /mynml/ x, xx
+
+      do i = 1 , 10
+        x(i) = -1
+      end do
+      x(6) = 6.0
+      x(10) = 10.0
+      xx = 0d0
+
+      open (10,status="scratch")
+      write (10, *) "!mynml"
+      write (10, *) ""
+      write (10, *) "&gf /"
+      write (10, *) "&mynml  x(7) =+99.0e0 x=1.0, 2.0 ,"
+      write (10, *) " 2*3.0, ,, 7.0e0,+0.08e+02 !comment"
+      write (10, *) ""
+      write (10, *) " 9000e-3 x(4:5)=4 ,5 "
+      write (10, *) " x=,,3.0, xx=10d0 /"
+      rewind (10)
+
+      read (10, nml=mynml, IOSTAT=ier)
+      if (ier.ne.0) call abort
+      rewind (10)
+
+      do i = 1 , 10
+        if ( abs( x(i) - real(i) ) .gt. 1e-8 ) call abort
+      end do
+      if ( abs( xx - 10d0 ) .gt. 1e-8 ) call abort
+
+      write (10, nml=mynml, iostat=ier)
+      if (ier.ne.0) call abort
+      rewind (10)
+
+      read (10, NML=mynml, IOSTAT=ier)
+      if (ier.ne.0) call abort
+      close (10)
+
+      do i = 1 , 10
+        if ( abs( x(i) - real(i) ) .gt. 1e-8 ) call abort
+      end do
+      if ( abs( xx - 10d0 ) .gt. 1e-8 ) call abort
+
+      end program

gcc/testsuite/gfortran.dg/namelist_12.f

+c{ dg-do run }
+c This program repeats many of the same tests as test_nml_1 but for integer instead of real.
+c  It also tests repeat nulls, comma delimited character read, a triplet qualifier, a range with
+c and assumed start, a quote delimited string, a qualifier with an assumed end and a fully
+c explicit range.  It also tests that integers and characters are successfully read back by
+c namelist.
+c Provided by Paul Thomas - pault@gcc.gnu.org
+
+      program namelist_12
+
+      integer*4 x(10)
+      integer*8 xx
+      integer ier
+      character*10 ch , check
+      namelist /mynml/ x, xx, ch
+ 
+c set debug = 0 or 1 in the namelist! (line 33)
+
+      do i = 1 , 10
+        x(i) = -1
+      end do
+      x(6) = 6
+      x(10) = 10
+      xx = 0
+      ch ="zzzzzzzzzz"
+      check="abcdefghij"
+
+      open (10,status="scratch")
+      write (10, *) "!mynml"
+      write (10, *) " "
+      write (10, *) "&mynml  x(7) =+99 x=1, 2 ,"
+      write (10, *) " 2*3, ,, 2* !comment"
+      write (10, *) " 9 ch=qqqdefghqq , x(8:7:-1) = 8 , 7"
+      write (10, *) " ch(:3) =""abc"","
+      write (10, *) " ch(9:)='ij' x(4:5)=4 ,5 xx = 42/"
+      rewind (10)
+
+      read (10, nml=mynml, IOSTAT=ier)
+      if (ier.ne.0) call abort
+      rewind (10)
+
+      write (10, nml=mynml, iostat=ier)
+      if (ier.ne.0) call abort
+      rewind (10)
+
+      read (10, NML=mynml, IOSTAT=ier)
+      if (ier.ne.0) call abort
+      close (10)
+
+      do i = 1 , 10
+        if ( abs( x(i) - i ) .ne. 0 ) call abort ()
+        if ( ch(i:i).ne.check(I:I) ) call abort
+      end do
+      if (xx.ne.42) call abort ()
+
+      end program

gcc/testsuite/gfortran.dg/namelist_13.f90

+!{ dg-do run }
+! Tests simple derived types.
+! Provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_13
+
+  type                        ::      yourtype
+    integer, dimension(2)     ::      yi = (/8,9/)
+    real, dimension(2)        ::      yx = (/80.,90./)
+    character(len=2)          ::      ych = "xx"
+  end type yourtype
+
+  type                        ::      mytype
+    integer, dimension(2)     ::      myi = (/800,900/)
+    real, dimension(2)        ::      myx = (/8000.,9000./)
+    character(len=2)          ::      mych = "zz"
+    type(yourtype)            ::      my_yourtype
+  end type mytype
+
+  type(mytype)                ::      z
+  integer                     ::      ier
+  integer                     ::      zeros(10)
+  namelist /mynml/ zeros, z
+
+  zeros = 0
+  zeros(5) = 1
+
+  open(10,status="scratch")
+  write (10, nml=mynml, iostat=ier)
+  if (ier.ne.0) call abort
+
+  rewind (10)
+  read (10, NML=mynml, IOSTAT=ier)
+  if (ier.ne.0) call abort
+  close (10)
+
+end program namelist_13
+

gcc/testsuite/gfortran.dg/namelist_14.f90

+!{ dg-do run }
+! Tests various combinations of intrinsic types, derived types, arrays,
+! dummy arguments and common to check nml_get_addr_expr in trans-io.c.
+! See comments below for selection.
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+module global
+  type             ::  mt
+    integer        ::  ii(4)
+  end type mt
+end module global
+
+program namelist_14
+  use global
+  common /myc/ cdt
+  integer          ::  i(2) = (/101,201/)
+  type(mt)         ::  dt(2)
+  type(mt)         ::  cdt
+  real*8           ::  pi = 3.14159_8
+  character*10     ::  chs="singleton"
+  character*10     ::  cha(2)=(/"first     ","second    "/)
+
+  dt = mt ((/99,999,9999,99999/))
+  cdt = mt ((/-99,-999,-9999,-99999/))
+  call foo (i,dt,pi,chs,cha)
+
+contains
+
+  logical function dttest (dt1, dt2)
+    use global
+    type(mt)       :: dt1
+    type(mt)       :: dt2
+    dttest = any(dt1%ii == dt2%ii)
+  end function dttest
+
+
+  subroutine foo (i, dt, pi, chs, cha)
+    use global
+    common /myc/ cdt
+    real *8        :: pi                   !local real scalar
+    integer        :: i(2)                 !dummy arg. array
+    integer        :: j(2) = (/21, 21/)    !equivalenced array
+    integer        :: jj                   !    -||-     scalar
+    integer        :: ier
+    type(mt)       :: dt(2)                !dummy arg., derived array
+    type(mt)       :: dtl(2)               !in-scope derived type array
+    type(mt)       :: dts                  !in-scope derived type
+    type(mt)       :: cdt                  !derived type in common block
+    character*10   :: chs                  !dummy arg. character var.
+    character*10   :: cha(:)               !dummy arg. character array
+    character*10   :: chl="abcdefg"        !in-scope character var.
+    equivalence (j,jj)
+    namelist /z/     dt, dtl, dts, cdt, j, jj, i, pi, chs, chl, cha
+
+    dts = mt ((/1, 2, 3, 4/))
+    dtl = mt ((/41, 42, 43, 44/))
+
+    open (10, status = "scratch")
+    write (10, nml = z, iostat = ier)
+    if (ier /= 0 ) call abort()
+    rewind (10)
+
+    i = 0
+    j = 0
+    jj = 0
+    pi = 0
+    dt  = mt ((/0, 0, 0, 0/))
+    dtl = mt ((/0, 0, 0, 0/))
+    dts = mt ((/0, 0, 0, 0/))
+    cdt = mt ((/0, 0, 0, 0/))
+    chs = ""
+    cha = ""
+    chl = ""
+
+    read (10, nml = z, iostat = ier)
+    if (ier /= 0 ) call abort()
+    close (10)
+
+    if (.not.(dttest (dt(1),  mt ((/99,999,9999,99999/))) .and.  &
+	      dttest (dt(2),  mt ((/99,999,9999,99999/))) .and.  &
+	      dttest (dtl(1), mt ((/41, 42, 43, 44/))) .and.     &
+	      dttest (dtl(2), mt ((/41, 42, 43, 44/))) .and.     &
+	      dttest (dts, mt ((/1, 2, 3, 4/))) .and.            &
+	      dttest (cdt, mt ((/-99,-999,-9999,-99999/))) .and. &
+	      all (j ==(/21, 21/)) .and.                         &
+	      all (i ==(/101, 201/)) .and.                       &
+	      (pi == 3.14159_8) .and.                            &
+	      (chs == "singleton") .and.                         &
+	      (chl == "abcdefg") .and.                           &
+	      (cha(1)(1:10) == "first    ") .and.                &
+	      (cha(2)(1:10) == "second    "))) call abort ()
+
+    end subroutine foo
+end program namelist_14 

gcc/testsuite/gfortran.dg/namelist_15.f90

+!{ dg-do run }
+! Tests arrays of derived types containing derived type arrays whose
+! components are character arrays - exercises object name parser in
+! list_read.c. Checks that namelist output can be reread. 
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+module global
+  type             ::  mt
+    character(len=2) ::  ch(2) = (/"aa","bb"/)
+  end type mt
+  type             ::  bt
+    integer        ::  i(2) = (/1,2/)
+    type(mt)       ::  m(2)
+  end type bt
+end module global
+
+program namelist_15
+  use global
+  type(bt)         ::  x(2)
+
+  namelist /mynml/ x
+
+  open (10, status = "scratch")
+  write (10, '(A)') "&MYNML"
+  write (10, '(A)') " x = 3, 4, 'dd', 'ee', 'ff', 'gg',"
+  write (10, '(A)') "     4, 5, 'hh', 'ii', 'jj', 'kk',"
+  write (10, '(A)') " x%i = , ,-3, -4"
+  write (10, '(A)') " x(2)%m(1)%ch(2) =q,"
+  write (10, '(A)') " x(2)%m(2)%ch(1)(1) =w,"
+  write (10, '(A)') " x%m%ch(:)(2) =z z z z z z z z,"
+  write (10, '(A)') "&end"
+   
+  rewind (10)
+  read (10, nml = mynml, iostat = ier)
+  if (ier .ne. 0) call abort () 
+  close (10)
+
+  open (10, status = "scratch")
+  write (10, nml = mynml)
+  rewind (10)
+  read (10, nml = mynml, iostat = ier)
+  if (ier .ne. 0) call abort () 
+  close(10)
+
+  if (.not. ((x(1)%i(1) == 3)          .and. &
+             (x(1)%i(2) == 4)          .and. &
+             (x(1)%m(1)%ch(1) == "dz") .and. &
+	     (x(1)%m(1)%ch(2) == "ez") .and. &
+             (x(1)%m(2)%ch(1) == "fz") .and. &
+	     (x(1)%m(2)%ch(2) == "gz") .and. &
+             (x(2)%i(1) == -3)         .and. &
+             (x(2)%i(2) == -4)         .and. &
+             (x(2)%m(1)%ch(1) == "hz") .and. &
+	     (x(2)%m(1)%ch(2) == "qz") .and. &
+             (x(2)%m(2)%ch(1) == "wz") .and. &
+	     (x(2)%m(2)%ch(2) == "kz"))) call abort ()
+
+end program namelist_15 

gcc/testsuite/gfortran.dg/namelist_16.f90

+!{ dg-do run }
+! Tests namelist on complex variables
+! provided by Paul Thomas - pault@gcc.gnu.org
+program namelist_16
+  complex(kind=8), dimension(2)  ::   z
+  namelist /mynml/ z
+  z = (/(1.0,2.0), (3.0,4.0)/)
+
+  open (10, status = "scratch")
+  write (10, '(A)') "&mynml z(1)=(5.,6.) z(2)=(7.,8.) /"
+  rewind (10)
+
+  read (10, mynml, iostat = ier)
+  if (ier .ne. 0) call abort ()
+  close (10)
+
+  open (10, status = "scratch")
+  write (10, mynml, iostat = ier)
+  if (ier .ne. 0) call abort ()
+  rewind (10)
+
+  z = (/(1.0,2.0), (3.0,4.0)/)
+  read (10, mynml, iostat = ier)
+  if (ier .ne. 0) call abort ()
+  close (10)
+
+  if ((z(1) .ne. (5.0,6.0)) .or. (z(2) .ne. (7.0,8.0))) call abort ()
+
+end program namelist_16 

gcc/testsuite/gfortran.dg/namelist_17.f90

+!{ dg-do run }
+! Tests namelist on logical variables
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_17
+  logical, dimension(2)        ::   l
+  namelist /mynml/ l
+  l = (/.true., .false./)
+
+  open (10, status = "scratch")
+  write (10, '(A)') "&mynml l = F T /"
+  rewind (10)
+  
+  read (10, mynml, iostat = ier)
+  if (ier .ne. 0) call abort ()
+  close (10)
+
+  open (10, status = "scratch")
+  write (10, mynml, iostat = ier)
+  if (ier .ne. 0) call abort ()
+  rewind (10)
+
+  l = (/.true., .false./)
+  read (10, mynml, iostat = ier)
+  if (ier .ne. 0) call abort ()
+  close (10)
+
+  if (l(1) .or. (.not.l(2))) call abort ()
+
+end program namelist_17 

gcc/testsuite/gfortran.dg/namelist_18.f90

+!{ dg-do run }
+! Tests character delimiters for namelist write 
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_18
+  character*3        ::   ch = "foo"
+  character*80       ::   buffer
+  namelist /mynml/ ch
+
+  open (10, status = "scratch")
+  write (10, mynml)
+  rewind (10)
+  read (10, '(a)', iostat = ier) buffer
+  read (10, '(a)', iostat = ier) buffer
+  if (ier .ne. 0) call abort ()
+  close (10)
+  If ((buffer(5:5) /= "f") .or. (buffer(9:9) /= " ")) call abort () 
+
+  open (10, status = "scratch", delim ="quote")
+  write (10, mynml)
+  rewind (10)
+  read (10, '(a)', iostat = ier) buffer
+  read (10, '(a)', iostat = ier) buffer
+  if (ier .ne. 0) call abort ()
+  close (10)
+  If ((buffer(5:5) /= """") .or. (buffer(9:9) /= """")) call abort ()
+
+  open (10, status = "scratch", delim ="apostrophe")
+  write (10, mynml)
+  rewind (10)
+  read (10, '(a)', iostat = ier) buffer
+  read (10, '(a)', iostat = ier) buffer
+  if (ier .ne. 0) call abort ()
+  close (10)
+  If ((buffer(5:5) /= "'") .or. (buffer(9:9) /= "'")) call abort ()
+
+end program namelist_18

gcc/testsuite/gfortran.dg/namelist_19.f90

+!{ dg-do run }
+! Test namelist error trapping.
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_19
+  character*80 wrong, right
+  
+! "=" before any object name
+  wrong = "&z = i = 1,2 /"
+  right = "&z i = 1,2 /"
+  call test_err(wrong, right)
+  
+! &* instead of &end for termination 
+  wrong = "&z i = 1,2 &xxx"
+  right = "&z i = 1,2 &end"
+  call test_err(wrong, right)
+  
+! bad data 
+  wrong = "&z i = 1,q /"
+  right = "&z i = 1,2 /"
+  call test_err(wrong, right)
+  
+! object name not matched 
+  wrong = "&z j = 1,2 /"
+  right = "&z i = 1,2 /"
+  call test_err(wrong, right)
+
+! derived type component for intrinsic type
+  wrong = "&z i%j = 1,2 /"
+  right = "&z i = 1,2 /"
+  call test_err(wrong, right)
+
+! step other than 1 for substring qualifier
+  wrong = "&z ch(1:2:2) = 'a'/"
+  right = "&z ch(1:2) = 'ab' /"
+  call test_err(wrong, right)
+
+! qualifier for scalar 
+  wrong = "&z k(2) = 1 /"
+  right = "&z k    = 1 /"
+  call test_err(wrong, right)
+
+! no '=' after object name 
+  wrong = "&z i   1,2 /"
+  right = "&z i = 1,2 /"
+  call test_err(wrong, right)
+
+! repeat count too large 
+  wrong = "&z i = 3*2 /"
+  right = "&z i = 2*2 /"
+  call test_err(wrong, right)
+
+! too much data 
+  wrong = "&z i = 1 2 3 /"
+  right = "&z i = 1 2 /"
+  call test_err(wrong, right)
+
+! no '=' after object name 
+  wrong = "&z i   1,2 /"
+  right = "&z i = 1,2 /"
+  call test_err(wrong, right)
+
+! bad number of index fields
+  wrong = "&z i(1,2) = 1 /"
+  right = "&z i(1)   = 1 /"
+  call test_err(wrong, right)
+
+! bad character in index field 
+  wrong = "&z i(x) = 1 /"
+  right = "&z i(1) = 1 /"
+  call test_err(wrong, right)
+
+! null index field 
+  wrong = "&z i( ) = 1 /"
+  right = "&z i(1) = 1 /"
+  call test_err(wrong, right)
+
+! null index field 
+  wrong = "&z i(1::)   = 1 2/"
+  right = "&z i(1:2:1) = 1 2 /"
+  call test_err(wrong, right)
+
+! null index field 
+  wrong = "&z i(1:2:)  = 1 2/"
+  right = "&z i(1:2:1) = 1 2 /"
+  call test_err(wrong, right)
+
+! index out of range 
+  wrong = "&z i(10) = 1 /"
+  right = "&z i(1)  = 1 /"
+  call test_err(wrong, right)
+
+! index out of range 
+  wrong = "&z i(0:1) = 1 /"
+  right = "&z i(1:1) = 1 /"
+  call test_err(wrong, right)
+
+! bad range
+  wrong = "&z i(1:2:-1) = 1 2 /"
+  right = "&z i(1:2: 1) = 1 2 /"
+  call test_err(wrong, right)
+
+! bad range
+  wrong = "&z i(2:1: 1) = 1 2 /"
+  right = "&z i(2:1:-1) = 1 2 /"
+  call test_err(wrong, right)
+
+contains
+  subroutine test_err(wrong, right)
+    character*80 wrong, right
+    integer            :: i(2) = (/0, 0/)
+    integer            :: k =0
+    character*2        :: ch = "  "
+    namelist /z/ i, k, ch
+
+! Check that wrong namelist input gives an error
+
+    open (10, status = "scratch")
+    write (10, '(A)') wrong
+    rewind (10)
+    read (10, z, iostat = ier)
+    close(10)
+    if (ier == 0) call abort ()
+
+! Check that right namelist input gives no error
+
+    open (10, status = "scratch")
+    write (10, '(A)') right
+    rewind (10)
+    read (10, z, iostat = ier)
+    close(10)
+    if (ier /= 0) call abort ()
+  end subroutine test_err
+  
+end program namelist_19

gcc/testsuite/gfortran.dg/namelist_2.f90

+! { dg-do compile }
+! Check that variable with intent(in) cannot be a member of a namelist
+subroutine namelist_2(x)
+  integer,intent(in) :: x
+  namelist /n/ x
+  read(*,n) ! { dg-error "is INTENT" "" }
+end subroutine namelist_2

gcc/testsuite/gfortran.dg/namelist_20.f90

+!{ dg-do run }
+! Tests namelist io for an explicit shape array with negative bounds
+! provided by Paul Thomas - pault@gcc.gnu.org
+
+program namelist_20
+  integer, dimension (-4:-2) :: x
+  integer                    :: i, ier
+  namelist /a/ x
+
+  open (10, status = "scratch")
+  write (10, '(A)') "&a x(-5)=0 /"            !-ve index below lbound
+  write (10, '(A)') "&a x(-1)=0 /"            !-ve index above ubound
+  write (10, '(A)') "&a x(1:2)=0 /"           !+ve indices
+  write (10, '(A)') "&a x(-4:-2)= -4,-3,-2 /" !correct
+  write (10, '(A)') " "
+  rewind (10)
+
+  ier=0
+  read(10, a, iostat=ier)
+  if (ier == 0) call abort ()
+  ier=0
+  read(10, a, iostat=ier)
+  if (ier == 0) call abort ()
+  ier=0
+  read(10, a, iostat=ier)
+  if (ier == 0) call abort ()
+
+  ier=0
+  read(10, a, iostat=ier)
+  if (ier /= 0) call abort ()
+  do i = -4,-2
+    if (x(i) /= i) call abort ()
+  end do
+
+end program namelist_20 

gcc/testsuite/gfortran.dg/namelist_3.f90

+! { dg-do compile }
+! Check that a pointer cannot be a member of a namelist
+program namelist_3
+  integer,pointer :: x
+  allocate (x)
+  namelist /n/ x ! { dg-error "NAMELIST attribute conflicts with POINTER attribute" "" }
+end program namelist_3

gcc/testsuite/gfortran.dg/pr12884.f

+c { dg-do run }
+c pr 12884
+c test namelist with input file containg / before namelist. Also checks
+c non-standard use of $ instead of &
+c Based on example provided by jean-pierre.flament@univ-lille1.fr
+
+      program pr12884
+      integer ispher,nosym,runflg,noprop
+      namelist /cntrl/ ispher,nosym,runflg,noprop
+      ispher = 0
+      nosym = 0
+      runflg = 0
+      noprop = 0 
+      open (10, status = "scratch")
+      write (10, '(A)') " $FILE"
+      write (10, '(A)') "   pseu  dir/file"
+      write (10, '(A)') " $END"
+      write (10, '(A)') " $cntrl ispher=1,nosym=2,"
+      write (10, '(A)') " runflg=3,noprop=4,$END"
+      write (10, '(A)')"/"
+      rewind (10)
+      read (10, cntrl)
+      if ((ispher.ne.1).or.(nosym.ne.2).or.(runflg.ne.3).or.
+     &  (noprop.ne.4)) call abort ()
+      end

gcc/testsuite/gfortran.dg/pr17285.f90

+! { dg-do run }
+! pr 17285
+! Test that namelist can read its own output.
+! At the same time, check arrays and different terminations
+! Based on example provided by paulthomas2@wanadoo.fr
+
+program pr17285
+  implicit none
+  integer, dimension(10) :: number = 42
+  integer                :: ctr, ierr
+  namelist /mynml/ number
+  open (10, status = "scratch")
+  write (10,'(A)') &
+    "&mynml number(:)=42,42,42,42,42,42,42,42,42,42,/ "
+  write (10,mynml)
+  write (10,'(A)') "&mynml number(1:10)=10*42 &end"
+  rewind (10)
+  do ctr = 1,3
+    number = 0
+    read (10, nml = mynml, iostat = ierr)
+    if ((ierr /= 0) .or. (any (number /= 42))) &
+      call abort ()
+  end do
+  close(10)
+end program pr17285

gcc/testsuite/gfortran.dg/pr17472.f

+c { dg-do run }
+c pr 17472
+c test namelist handles arrays
+c Based on example provided by thomas.koenig@online.de
+
+       integer a(10), ctr
+       data a / 1,2,3,4,5,6,7,8,9,10 /
+       namelist /ints/ a
+       do ctr = 1,10
+         if (a(ctr).ne.ctr) call abort ()
+       end do
+       end

gcc/testsuite/gfortran.dg/pr18122.f90

+! { dg-do run }
+! test namelist with scalars and arrays.
+! Based on example provided by thomas.koenig@online.de
+
+program sechs_w
+  implicit none
+
+  integer, parameter :: dr=selected_real_kind(15)
+
+  integer, parameter :: nkmax=6
+  real (kind=dr) :: rb(nkmax)
+  integer :: z
+
+  real (kind=dr) :: dg
+  real (kind=dr) :: a
+  real (kind=dr) :: da
+  real (kind=dr) :: delta
+  real (kind=dr) :: s,t
+  integer :: nk
+  real (kind=dr) alpha0
+
+  real (kind=dr) :: phi, phi0, rad, rex, zk, z0, drdphi, dzdphi
+
+  namelist /schnecke/ z, dg, a, t, delta, s, nk, rb, alpha0
+
+  open (10,status="scratch")
+  write (10, *)  "&SCHNECKE"
+  write (10, *)    " z=1,"
+  write (10, *)    " dg=58.4,"
+  write (10, *)    " a=48.,"
+  write (10, *)    " delta=0.4,"
+  write (10, *)    " s=0.4,"
+  write (10, *)    " nk=6,"
+  write (10, *)    " rb=60, 0, 40,"
+  write (10, *)    " alpha0=20.,"
+  write (10, *)    "/"
+
+  rewind (10)
+  read (10,schnecke)
+  close (10)
+  if ((z /= 1)       .or. (dg /= 58.4_dr)  .or. (a /= 48.0_dr)   .or. &
+    (delta /= 0.4_dr).or. (s /= 0.4_dr)    .or. (nk /= 6)        .or. &
+    (rb(1) /= 60._dr).or. (rb(2) /= 0.0_dr).or. (rb(3) /=40.0_dr).or. &
+    (alpha0 /= 20.0_dr)) call abort ()
+end program sechs_w

gcc/testsuite/gfortran.dg/pr18210.f90

+! { dg-do run }
+! Names in upper case and object names starting column 2
+! Based on example provided by thomas.koenig@online.de
+
+program pr18210
+
+  real :: a
+  character*80 :: buffer
+  namelist /foo/ a
+
+  a = 1.4
+  open (10, status = "scratch")
+  write (10,foo)
+  rewind (10)
+  read (10, '(a)') buffer
+  if (buffer(2:4) /= "FOO") call abort ()
+  read (10, '(a)') buffer
+  if (buffer(1:2) /= " A") call abort ()
+  close (10)
+
+end program pr18210

gcc/testsuite/gfortran.dg/pr18392.f90

+! { dg-do run }
+! pr 18392
+! test namelist with derived types
+! Based on example provided by thomas.koenig@online.de
+
+program pr18392
+  implicit none
+  type foo
+     integer a
+     real b
+  end type foo
+  type(foo) :: a
+  namelist /nl/ a
+  open (10, status="scratch")
+  write (10,*) " &NL"
+  write (10,*) " A%A = 10,"
+  write (10,*) "/"
+  rewind (10)
+  read (10,nl)
+  close (10)
+  IF (a%a /= 10.0) call abort ()
+end program pr18392

gcc/testsuite/gfortran.dg/pr19467.f90

+! { dg-do run }
+! pr 19467
+! test namelist with character arrays
+! Based on example provided by paulthomas2@wanadoo.fr
+
+program pr19467
+  implicit none
+  integer             :: ier
+  character(len=2)    :: ch(2)
+  character(len=2)    :: dh(2)=(/"aa","bb"/)
+  namelist /a/ ch
+  open (10, status = "scratch")
+  write (10, *) "&A ch = 'aa' , 'bb' /"
+  rewind (10)
+  READ (10,nml=a, iostat = ier)
+  close (10)
+  if ((ier /= 0) .or. (any (ch /= dh))) call abort ()
+end program pr19467

gcc/testsuite/gfortran.dg/pr19657.f

+c { dg-do run }
+c pr 19657
+c test namelist not skipped if ending with logical.
+c Based on example provided by fuyuki@ccsr.u-tokyo.ac.jp
+
+      program pr19657
+      implicit none
+      logical   l
+      integer   i, ctr
+      namelist /nm/ i, l
+      open (10, status = "scratch")
+      write (10,*) "&nm i=1,l=t &end"
+      write (10,*) "&nm i=2 &end"
+      write (10,*) "&nm i=3 &end"
+      rewind (10)
+      do ctr = 1,3
+        read (10,nm,end=190)
+        if (i.ne.ctr) call abort ()
+      enddo
+ 190  continue 
+      end

libgfortran/ChangeLog

+2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+* io/list_read.c (eat_separator): at_eol = 1 replaced(zapped at some time?).
+
+2005-04-17 Paul Thomas <pault@gcc.gnu.org>
+
+
+	PR libgfortran/12884
+	PR libgfortran/17285
+	PR libgfortran/18122
+	PR libgfortran/18210
+	PR libgfortran/18392
+	PR libgfortran/18591
+	PR libgfortran/18879
+	* io/io.h (nml_ls): Declare.
+	(namelist_info): Modify for arrays.
+	* io/list_read.c (namelist_read): Reduced to call to new functions.
+	(match_namelist_name): Simplified.
+	(nml_query): Handles stdin queries ? and =?. New function.
+	(nml_get_obj_data): Parses object name. New function.
+	(touch_nml_nodes): Marks objects for read. New function.
+	(untouch_nml_nodes): Resets objects. New function.
+	(parse_qualifier): Parses and checks qualifiers. New function
+	(nml_read_object): Reads and stores object data. New function.
+	(eat_separator): No new_record on '/' in namelist.
+	(finish_separator): No new_record on '/' in namelist.
+	(read_logical): Error return for namelist.
+	(read_integer): Error return for namelist.
+	(read_complex): Error return for namelist.
+	(read_real): Error return for namelist.
+	* io/lock.c (library_end): Free extended namelist_info types.
+	* io/transfer.c (st_set_nml_var): Modified for arrays.
+	(st_set_nml_var_dim): Dimension descriptors. New function.
+	* io/write.c (namelist_write): Reduced to call to new functions.
+	(nml_write_obj): Writes output for object. New function.
+	(write_integer): Suppress leading blanks for repeat counts.
+	(write_int): Suppress leading blanks for repeat counts.
+	(write_float): Suppress leading blanks for repeat counts.
+	(output_float): Suppress leading blanks for repeat counts.
+
 2005-04-15  Thomas Koenig  <Thomas.Koenig@online.de>
 
 	PR libfortran/18495

libgfortran/io/io.h

@@ -74,32 +74,75 @@ stream;
 #define sseek(s, pos) ((s)->seek)(s, pos)
 #define struncate(s) ((s)->truncate)(s)
 
-/* Namelist represent object */
-/*
+/* Representation of a namelist object in libgfortran
+
    Namelist Records
-       &groupname  object=value [,object=value].../
+      &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]].../
      or
-       &groupname  object=value [,object=value]...&groupname
+      &GROUPNAME  OBJECT=value[s] [,OBJECT=value[s]]...&END
+
+   The object can be a fully qualified, compound name for an instrinsic
+   type, derived types or derived type components.  So, a substring
+   a(:)%b(4)%ch(2:4)(1:7) has to be treated correctly in namelist
+   read. Hence full information about the structure of the object has
+   to be available to list_read.c and write.
+
+   These requirements are met by the following data structures.
+
+   nml_loop_spec contains the variables for the loops over index ranges
+   that are encountered.  Since the variables can be negative, ssize_t
+   is used.  */
+
+typedef struct nml_loop_spec
+{
 
-  Even more complex, during the execution of a program containing a
-  namelist READ statement, you can specify a question mark character(?)
-  or a question mark character preceded by an equal sign(=?) to get
-  the information of the namelist group. By '?', the name of variables
-  in the namelist will be displayed, by '=?', the name and value of
-  variables will be displayed.
+  /* Index counter for this dimension.  */
+  ssize_t idx;
 
-  All these requirements need a new data structure to record all info
-  about the namelist.
-*/
+  /* Start for the index counter.  */
+  ssize_t start;
+
+  /* End for the index counter.  */
+  ssize_t end;
+
+  /* Step for the index counter.  */
+  ssize_t step;
+}
+nml_loop_spec;
+
+/* namelist_info type contains all the scalar information about the
+   object and arrays of descriptor_dimension and nml_loop_spec types for
+   arrays.  */
 
 typedef struct namelist_type
 {
+
+  /* Object type, stored as GFC_DTYPE_xxxx.  */
+  bt type;
+
+  /* Object name.  */
   char * var_name;
+
+  /* Address for the start of the object's data.  */
   void * mem_pos;
-  int  value_acquired;
+
+  /* Flag to show that a read is to be attempted for this node.  */
+  int touched;
+
+  /* Length of intrinsic type in bytes.  */
   int len;
-  int string_length;
-  bt type;
+
+  /* Rank of the object.  */
+  int var_rank;
+
+  /* Overall size of the object in bytes.  */
+  index_type size;
+
+  /* Length of character string.  */
+  index_type string_length;
+
+  descriptor_dimension * dim;
+  nml_loop_spec * ls;
   struct namelist_type * next;
 }
 namelist_info;

libgfortran/io/lock.c

 /* Thread/recursion locking
-   Copyright 2002 Free Software Foundation, Inc.
+   Copyright 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -73,20 +73,28 @@ library_end (void)
   g.in_library = 0;
   filename = NULL;
   line = 0;
-
   t = ioparm.library_return;
+
+  /* Delete the namelist, if it exists.  */
+
   if (ionml != NULL)
     {
       t1 = ionml;
       while (t1 != NULL)
-       {
-         t2 = t1;
-         t1 = t1->next;
-         free_mem (t2);
-       }
+	{
+	  t2 = t1;
+	  t1 = t1->next;
+	  free_mem (t2->var_name);
+	  if (t2->var_rank)
+	    {
+	     free_mem (t2->dim);
+	     free_mem (t2->ls);
+	    }
+	  free_mem (t2);
+	}
     }
-  
   ionml = NULL;
+
   memset (&ioparm, '\0', sizeof (ioparm));
   ioparm.library_return = t;
 }

libgfortran/io/transfer.c

 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
    Contributed by Andy Vaught
+   Namelist transfer functions contributed by Paul Thomas
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
 
@@ -1623,94 +1624,78 @@ st_write_done (void)
   library_end ();
 }
 
+/* Receives the scalar information for namelist objects and stores it
+   in a linked list of namelist_info types.  */
 
-static void
-st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
-                int kind, bt type, int string_length)
+void
+st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
+		gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
 {
-  namelist_info *t1 = NULL, *t2 = NULL;
-  namelist_info *nml = (namelist_info *) get_mem (sizeof (namelist_info));
+  namelist_info *t1 = NULL;
+  namelist_info *nml;
+
+  nml = (namelist_info*) get_mem (sizeof (namelist_info));
+
   nml->mem_pos = var_addr;
-  if (var_name)
+
+  nml->var_name = (char*) get_mem (strlen (var_name) + 1);
+  strcpy (nml->var_name, var_name);
+
+  nml->len = (int) len;
+  nml->string_length = (index_type) string_length;
+
+  nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
+  nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
+  nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
+
+  if (nml->var_rank > 0)
     {
-      assert (var_name_len > 0);
-      nml->var_name = (char*) get_mem (var_name_len+1);
-      strncpy (nml->var_name, var_name, var_name_len);
-      nml->var_name[var_name_len] = 0;
+      nml->dim = (descriptor_dimension*)
+		   get_mem (nml->var_rank * sizeof (descriptor_dimension));
+      nml->ls = (nml_loop_spec*)
+		  get_mem (nml->var_rank * sizeof (nml_loop_spec));
     }
   else
     {
-      assert (var_name_len == 0);
-      nml->var_name = NULL;
+      nml->dim = NULL;
+      nml->ls = NULL;
     }
 
-  nml->len = kind;
-  nml->type = type;
-  nml->string_length = string_length;
-
   nml->next = NULL;
 
   if (ionml == NULL)
-     ionml = nml;
+    ionml = nml;
   else
     {
-      t1 = ionml;
-      while (t1 != NULL)
-       {
-         t2 = t1;
-         t1 = t1->next;
-       }
-       t2->next = nml;
+      for (t1 = ionml; t1->next; t1 = t1->next);
+      t1->next = nml;
     }
+  return;
 }
 
-extern void st_set_nml_var_int (void *, char *, int, int);
-export_proto(st_set_nml_var_int);
-
-extern void st_set_nml_var_float (void *, char *, int, int);
-export_proto(st_set_nml_var_float);
-
-extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type);
-export_proto(st_set_nml_var_char);
-
-extern void st_set_nml_var_complex (void *, char *, int, int);
-export_proto(st_set_nml_var_complex);
-
-extern void st_set_nml_var_log (void *, char *, int, int);
-export_proto(st_set_nml_var_log);
+/* Store the dimensional information for the namelist object.  */
 
 void
-st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
-		    int kind)
+st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
+		    GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
 {
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
-}
+  namelist_info * nml;
+  int n;
 
-void
-st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
-		      int kind)
-{
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL, 0);
-}
+  n = (int)n_dim;
 
-void
-st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
-		     int kind, gfc_charlen_type string_length)
-{
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
-		  string_length);
-}
+  for (nml = ionml; nml->next; nml = nml->next);
 
-void
-st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
-			int kind)
-{
-  st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX, 0);
+  nml->dim[n].stride = (ssize_t)stride;
+  nml->dim[n].lbound = (ssize_t)lbound;
+  nml->dim[n].ubound = (ssize_t)ubound;
 }
 
-void
-st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
-		    int kind)
-{
-   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL, 0);
-}
+extern void st_set_nml_var (void * ,char * ,
+			    GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
+export_proto(st_set_nml_var);
+
+extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
+				GFC_INTEGER_4 ,GFC_INTEGER_4);
+export_proto(st_set_nml_var_dim);
+