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

4 files changed, 134 insertions, 21 deletions

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 78f1b06..d665f7d 100644
--- 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
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 e23d362..12969af 100644
--- 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 9ac5609..e63fca5 100644
--- 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: