Fortran: fix namelist read for input with comments [PR125095]

Namelist input may contain comments (initiated with a "!") after a
separator or in the first nonblank position of a namelist input record.
Skip comments until end of line, and eat leading whitespace in a subsequent
input record.

	PR libfortran/125095

libgfortran/ChangeLog:

	* io/list_read.c (read_logical): Eat comments in namelist read mode.
	(read_integer): Likewise.
	(read_character): Likewise.
	(read_complex): Likewise.
	(read_real): Likewise.

gcc/testsuite/ChangeLog:

	* gfortran.dg/namelist_102.f90: New test.

diff --git a/gcc/testsuite/gfortran.dg/namelist_102.f90 b/gcc/testsuite/gfortran.dg/namelist_102.f90
new file mode 100644 (file)
index 0000000..66c3809
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/namelist_102.f90
@@ -0,0 +1,248 @@
+! { dg-do run }
+! { dg-additional-options "-O2" }
+!
+! PR fortran/125095 - test namelist read with comments
+!
+! Based on testcases by Andy Nelson and Steven G. Kargl
+
+program nmlbug
+  implicit none
+  call test_int
+  call test_real
+  call test_complex
+  call test_logical
+  call test_char
+
+contains
+
+  subroutine test_int
+
+    integer :: array(4), barray(4), carray(4), darray(4)
+
+    namelist/nml1/  array
+    namelist/nml2/ barray
+    namelist/nml3/ carray
+    namelist/nml4/ darray
+
+    open(10,status='scratch')
+    write(10,'(A)') '&nml1'
+    write(10,'(A)') '  array = 1, 2, 3, 4,'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml2'
+    write(10,'(A)') '  barray = 5,    ! comment'
+    write(10,'(A)') '           6,'
+    write(10,'(A)') '           7     ! another comment'
+    write(10,'(A)') '           8,'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml3'
+    write(10,'(A)') '  carray =  9     ! New comment'
+    write(10,'(A)') '           10'
+    write(10,'(A)') '           11     ! another new comment'
+    write(10,'(A)') '           12'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml4'
+    write(10,'(A)') '  darray = 13, 14, 15, 16,'
+    write(10,'(A)') '/'
+    flush(10)
+    rewind(10)
+
+    read(10,nml1)
+    if (any( array /= [ 1,  2,  3,  4])) stop 1
+    read(10,nml2)
+    if (any(barray /= [ 5,  6,  7,  8])) stop 2
+    read(10,nml3)
+    if (any(carray /= [ 9, 10, 11, 12])) stop 3
+    read(10,nml4)
+    if (any(darray /= [13, 14, 15, 16])) stop 4
+    close(10)
+
+  end subroutine test_int
+
+  subroutine test_real
+
+    real :: array(4), barray(4), carray(4), darray(4)
+
+    namelist/nml1/  array
+    namelist/nml2/ barray
+    namelist/nml3/ carray
+    namelist/nml4/ darray
+
+    open(10,status='scratch')
+    write(10,'(A)') '&nml1'
+    write(10,'(A)') '  array = 1, 2, 3, 4,'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml2'
+    write(10,'(A)') '  barray = 5,    ! comment'
+    write(10,'(A)') '           6,'
+    write(10,'(A)') '           7     ! another comment'
+    write(10,'(A)') '           8,'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml3'
+    write(10,'(A)') '  carray =  9     ! New comment'
+    write(10,'(A)') '           10'
+    write(10,'(A)') '           11     ! another new comment'
+    write(10,'(A)') '           12'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml4'
+    write(10,'(A)') '  darray = 13, 14, 15, 16,'
+    write(10,'(A)') '/'
+    flush(10)
+    rewind(10)
+
+    read(10,nml1)
+    if (any( array /= [ 1,  2,  3,  4])) stop 1
+    read(10,nml2)
+    if (any(barray /= [ 5,  6,  7,  8])) stop 2
+    read(10,nml3)
+    if (any(carray /= [ 9, 10, 11, 12])) stop 3
+    read(10,nml4)
+    if (any(darray /= [13, 14, 15, 16])) stop 4
+    close(10)
+
+  end subroutine test_real
+
+  subroutine test_complex
+
+    complex :: array(4), barray(4), carray(4), darray(4)
+
+    namelist/nml1/  array
+    namelist/nml2/ barray
+    namelist/nml3/ carray
+    namelist/nml4/ darray
+
+    open(10,status='scratch')
+    write(10,'(A)') '&nml1'
+    write(10,'(A)') '  array = (1,0), (2,0), (3,0), (4,0),'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml2'
+    write(10,'(A)') '  barray = (5,0),    ! comment'
+    write(10,'(A)') '           (6,0),'
+    write(10,'(A)') '           (7,0)     ! another comment'
+    write(10,'(A)') '           (8,0),'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml3'
+    write(10,'(A)') '  carray =  (9,0)     ! New comment'
+    write(10,'(A)') '           (10,0)'
+    write(10,'(A)') '           (11,0)     ! another new comment'
+    write(10,'(A)') '           (12,0)'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml4'
+    write(10,'(A)') '  darray = (13,0), (14,0), (15,0), (16,0),'
+    write(10,'(A)') '/'
+    flush(10)
+    rewind(10)
+
+    read(10,nml1)
+    if (any( array /= [ 1,  2,  3,  4])) stop 1
+    read(10,nml2)
+    if (any(barray /= [ 5,  6,  7,  8])) stop 2
+    read(10,nml3)
+    if (any(carray /= [ 9, 10, 11, 12])) stop 3
+    read(10,nml4)
+    if (any(darray /= [13, 14, 15, 16])) stop 4
+    close(10)
+
+  end subroutine test_complex
+
+  subroutine test_logical
+
+    logical :: array(4), barray(4), carray(4), darray(4)
+
+    namelist/nml1/  array
+    namelist/nml2/ barray
+    namelist/nml3/ carray
+    namelist/nml4/ darray
+
+    open(10,status='scratch')
+    write(10,'(A)') '&nml1'
+    write(10,'(A)') '  array = T,F,F,T'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml2'
+    write(10,'(A)') '  barray = T,    ! comment'
+    write(10,'(A)') '           F,'
+    write(10,'(A)') '           F     ! another comment'
+    write(10,'(A)') '           T,'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml3'
+    write(10,'(A)') '  carray =  T     ! New comment'
+    write(10,'(A)') '            F'
+    write(10,'(A)') '            F     ! another new comment'
+    write(10,'(A)') '            T'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml4'
+    write(10,'(A)') '  darray =  T,F,F,T'
+    write(10,'(A)') '/'
+    flush(10)
+    rewind(10)
+
+    read(10,nml1)
+    if (any( array .neqv. [ .true.,.false.,.false.,.true. ])) stop 1
+    read(10,nml2)
+    if (any(barray .neqv. [ .true.,.false.,.false.,.true. ])) stop 2
+    read(10,nml3)
+    if (any(carray .neqv. [ .true.,.false.,.false.,.true. ])) stop 3
+    read(10,nml4)
+    if (any(darray .neqv. [ .true.,.false.,.false.,.true. ])) stop 4
+    close(10)
+
+  end subroutine test_logical
+
+  subroutine test_char
+
+    character(8) :: array(4), barray(4), carray(4), darray(4)
+
+    namelist/nml1/  array
+    namelist/nml2/ barray
+    namelist/nml3/ carray
+    namelist/nml4/ darray
+
+    open(10,status='scratch')
+    write(10,'(A)') '&nml1'
+    write(10,'(A)') '  array = "a", "b", "c", "d",'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml2'
+    write(10,'(A)') '  barray = "a",    ! comment'
+    write(10,'(A)') '           "b",'
+    write(10,'(A)') '           "c"     ! another comment'
+    write(10,'(A)') '           "d",'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml3'
+    write(10,'(A)') '  carray = "a"     ! New comment'
+    write(10,'(A)') '           "b"'
+    write(10,'(A)') '           "c"     ! another new comment'
+    write(10,'(A)') '           "d"'
+    write(10,'(A)') '/'
+    write(10,*)
+    write(10,'(A)') '&nml4'
+    write(10,'(A)') '  darray = "a", "b", "c", "d",'
+    write(10,'(A)') '/'
+    flush(10)
+    rewind(10)
+
+    read(10,nml1)
+    if (any( array /= [ "a", "b", "c", "d" ])) stop 1
+    read(10,nml2)
+    if (any(barray /= [ "a", "b", "c", "d" ])) stop 2
+    read(10,nml3)
+    if (any(carray /= [ "a", "b", "c", "d" ])) stop 3
+    read(10,nml4)
+    if (any(darray /= [ "a", "b", "c", "d" ])) stop 4
+    close(10)
+
+  end subroutine test_char
+
+end program nmlbug

diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 0d16640a900087b4b2dfe47589feb22597da5356..7b71cf38719deb6e3dbe0a22c0cca546b8fb43c1 100644 (file)
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -917,6 +917,7 @@ read_logical (st_parameter_dt *dtp, int length)
   if (parse_repeat (dtp))
     return;
 
+next:
   c = safe_tolower (next_char (dtp));
   l_push_char (dtp, c);
   switch (c)
@@ -961,6 +962,9 @@ read_logical (st_parameter_dt *dtp, int length)
     case '!':
       if (!dtp->u.p.namelist_mode)
         goto bad_logical;
+      eat_line (dtp);
+      eat_spaces (dtp);
+      goto next;
 
     CASE_SEPARATORS:
     case EOF:
@@ -1076,6 +1080,7 @@ read_integer (st_parameter_dt *dtp, int length, bt type)
   int c, negative;
   negative = 0;
 
+next:
   c = next_char (dtp);
   switch (c)
     {
@@ -1091,6 +1096,9 @@ read_integer (st_parameter_dt *dtp, int length, bt type)
     case '!':
       if (!dtp->u.p.namelist_mode)
         goto bad_integer;
+      eat_line (dtp);
+      eat_spaces (dtp);
+      goto next;
 
     CASE_SEPARATORS:           /* Single null.  */
       unget_char (dtp, c);
@@ -1260,6 +1268,7 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
 
   quote = ' ';                 /* Space means no quote character.  */
 
+next:
   if ((c = next_char (dtp)) == EOF)
     goto eof;
   if (c == ';')
@@ -1284,6 +1293,15 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
       quote = c;
       goto get_string;
 
+    case '!':
+      if (dtp->u.p.namelist_mode)
+       {
+         eat_line (dtp);
+         eat_spaces (dtp);
+         goto next;
+       }
+      /* Fall through...  */
+
     default:
       if (dtp->u.p.namelist_mode)
        {
@@ -1703,6 +1721,7 @@ read_complex (st_parameter_dt *dtp, void *dest, int kind, size_t size)
   if (parse_repeat (dtp))
     return;
 
+next:
   c = next_char (dtp);
   switch (c)
     {
@@ -1712,6 +1731,9 @@ read_complex (st_parameter_dt *dtp, void *dest, int kind, size_t size)
     case '!':
       if (!dtp->u.p.namelist_mode)
        goto bad_complex;
+      eat_line (dtp);
+      eat_spaces (dtp);
+      goto next;
 
     CASE_SEPARATORS:
     case EOF:
@@ -1813,6 +1835,7 @@ read_real (st_parameter_dt *dtp, void *dest, int length)
 
   seen_dp = 0;
 
+next:
   c = next_char (dtp);
   if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
     {
@@ -1844,6 +1867,9 @@ read_real (st_parameter_dt *dtp, void *dest, int length)
     case '!':
       if (!dtp->u.p.namelist_mode)
        goto bad_real;
+      eat_line (dtp);
+      eat_spaces (dtp);
+      goto next;
 
     CASE_SEPARATORS:
       unget_char (dtp, c);             /* Single null.  */