diff gcc/testsuite/gfortran.dg/dtio_30.f03 @ 111:04ced10e8804

gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/gfortran.dg/dtio_30.f03	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,60 @@
+! { dg-do run }
+! PR80333  Namelist dtio write of array of class does not traverse the array
+! This test checks both NAMELIST WRITE and READ of an array of class
+module m
+  implicit none
+  type :: t
+    character :: c
+    character :: d
+  contains
+    procedure :: read_formatted
+    generic :: read(formatted) => read_formatted
+    procedure :: write_formatted
+    generic :: write(formatted) => write_formatted
+  end type t
+contains
+  subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    class(t), intent(inout) :: dtv
+    integer, intent(in) :: unit
+    character(*), intent(in) :: iotype
+    integer, intent(in) :: v_list(:)
+    integer, intent(out) :: iostat
+    character(*), intent(inout) :: iomsg
+    integer :: i
+    read(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d
+  end subroutine read_formatted
+
+  subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    class(t), intent(in) :: dtv
+    integer, intent(in) :: unit
+    character(*), intent(in) :: iotype
+    integer, intent(in) :: v_list(:)
+    integer, intent(out) :: iostat
+    character(*), intent(inout) :: iomsg
+    write(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d
+  end subroutine write_formatted
+end module m
+
+program p
+  use m
+  implicit none
+  class(t), dimension(:,:), allocatable :: w
+  namelist /nml/  w
+  integer :: unit, iostatus
+  character(256) :: str = ""
+
+  open(10, status='scratch')
+  allocate(w(10,3))
+  w = t('j','r')
+  w(5:7,2)%c='k'
+  write(10, nml)
+  rewind(10)
+  w = t('p','z')
+  read(10, nml)
+  write(str,*) w
+  if (str.ne." jr jr jr jr jr jr jr jr jr jr jr jr jr jr kr kr kr jr jr jr jr jr jr jr jr jr jr jr jr jr") &
+      & call abort
+  str = ""
+  write(str,"(*(DT))") w
+  if (str.ne."jrjrjrjrjrjrjrjrjrjrjrjrjrjrkrkrkrjrjrjrjrjrjrjrjrjrjrjrjrjr") call abort
+end program p