re PR libfortran/34427 (Revision 130708 breaks namelist input)

2007-12-13  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34427
        * io/list_read.c (read_real): Fix unwinding for namelists.

2007-12-13  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34427
        * gfortran.dg/namelist_42.f90: New.

From-SVN: r130889

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 78f1b06a40a7ca3151882408698ec9714842f68d..d665f7dbcf7647be35daecb3534d1a077f7a7757 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-12-13  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/34427
+       * gfortran.dg/namelist_42.f90: New.
+
 2007-12-12  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/34254

diff --git a/gcc/testsuite/gfortran.dg/namelist_42.f90 b/gcc/testsuite/gfortran.dg/namelist_42.f90
new file mode 100644 (file)
index 0000000..b0095fe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/namelist_42.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-options "-mieee" { target sh*-*-* } }
+!
+! PR fortran/34427
+!
+! Check that namelists and the real values Inf, NaN, Infinity
+! properly coexist.
+!
+ PROGRAM TEST
+  IMPLICIT NONE
+  real , DIMENSION(11) ::foo 
+  integer :: infinity
+  NAMELIST /nl/ foo
+  NAMELIST /nl/ infinity
+  foo = -1.0
+  infinity = -1
+
+  open (10, status="scratch")
+! Works:
+  write (10,*) " &nl foo = 5, 5, 5, nan, infinity, infinity "
+  write (10,*)
+  write (10,*) "      = 1, /"
+! Does not work
+  !write (10,*) " &nl foo = 5, 5, 5, nan, infinity, infinity"
+  !write (10,*) "      = 1, /"
+  rewind (10)
+  READ (10, NML = nl)
+  CLOSE (10)
+
+  if(infinity /= 1) call abort()
+  if(any(foo(1:3) /= [5.0, 5.0, 5.0]) .or. .not.isnan(foo(4)) &
+     .or. foo(5) <= huge(foo) .or. any(foo(6:11) /= -1.0)) &
+    call abort()
+ END PROGRAM TEST

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index e23d362a89c246fa78b82221a4a35c7212a3104d..12969af81d8c80f26cd1e9b1b79b03980a233535 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,8 @@
+2007-12-13  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/34427
+       * io/list_read.c (read_real): Fix unwinding for namelists.
+
 2007-12-10  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR libfortran/34411

diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 9ac5609e9ce23991a4b3effdc0aa343a92d3b2b5..e63fca57a2f22b98ce7847443073f358753a7983 100644 (file)
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -1315,6 +1315,7 @@ read_real (st_parameter_dt *dtp, int length)
 {
   char c, message[100];
   int seen_dp;
+  int is_inf, i;
 
   seen_dp = 0;
 
@@ -1522,34 +1523,102 @@ read_real (st_parameter_dt *dtp, int length)
   return;
 
  inf_nan:
+  l_push_char (dtp, c);
+  is_inf = 0;
+
   /* Match INF and Infinity.  */
-  if ((c == 'i' || c == 'I')
-      && ((c = next_char (dtp)) == 'n' || c == 'N')
-      && ((c = next_char (dtp)) == 'f' || c == 'F'))
+  if (c == 'i' || c == 'I')
     {
-       c = next_char (dtp);
-       if (is_separator (c)
-           || ((c == 'i' || c == 'I')
-               && ((c = next_char (dtp)) == 'n' || c == 'N')
-               && ((c = next_char (dtp)) == 'i' || c == 'I')
-               && ((c = next_char (dtp)) == 't' || c == 'T')
-               && ((c = next_char (dtp)) == 'y' || c == 'Y')
-               && (c = next_char (dtp)) && is_separator (c)))
-         {
-            push_char (dtp, 'i');
-            push_char (dtp, 'n');
-            push_char (dtp, 'f');
-            goto done;
-         }
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c != 'n' && c != 'N')
+       goto unwind;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c != 'f' && c != 'F')
+       goto unwind;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (!is_separator (c))
+       {
+         if (c != 'i' && c != 'I')
+           goto unwind;
+         c = next_char (dtp);
+         l_push_char (dtp, c);
+         if (c != 'n' && c != 'N')
+           goto unwind;
+         c = next_char (dtp);
+         l_push_char (dtp, c);
+         if (c != 'i' && c != 'I')
+           goto unwind;
+         c = next_char (dtp);
+         l_push_char (dtp, c);
+         if (c != 't' && c != 'T')
+           goto unwind;
+         c = next_char (dtp);
+         l_push_char (dtp, c);
+         if (c != 'y' && c != 'Y')
+           goto unwind;
+         c = next_char (dtp);
+         l_push_char (dtp, c);
+       }
+       is_inf = 1;
     } /* Match NaN.  */
-  else if (((c = next_char (dtp)) == 'a' || c == 'A')
-          && ((c = next_char (dtp)) == 'n' || c == 'N')
-          && (c = next_char (dtp)) && is_separator (c))
+  else
+    {
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c != 'a' && c != 'A')
+       goto unwind;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c != 'n' && c != 'N')
+       goto unwind;
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+    }
+
+  if (!is_separator (c) || c == '=')
+    goto unwind;
+
+  if (dtp->u.p.namelist_mode && c != ',' && c != '/')
+    for (i = 0; i < 63; i++)
+    { 
+      eat_spaces (dtp);
+      c = next_char (dtp);
+      l_push_char (dtp, c);
+      if (c == '=')
+       goto unwind;
+
+      if (c == ',' || c == '/' || !is_separator(c))
+       break;
+    }
+
+  if (is_inf)
+    {
+      push_char (dtp, 'i');
+      push_char (dtp, 'n');
+      push_char (dtp, 'f');
+    }
+  else
     {
       push_char (dtp, 'n');
       push_char (dtp, 'a');
       push_char (dtp, 'n');
-      goto done;
+    }
+
+  dtp->u.p.item_count = 0;
+  dtp->u.p.line_buffer_enabled = 0;
+  free_line (dtp);
+  goto done;
+
+ unwind:
+  if (dtp->u.p.namelist_mode)
+    {
+      dtp->u.p.nml_read_error = 1;
+      dtp->u.p.line_buffer_enabled = 1;
+      dtp->u.p.item_count = 0;
+      return;
     }
 
  bad_real: