re PR fortran/34319 (I/O: Support "NaN", "Infinity" and "INF" as input)

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

        PR fortran/34319
        * io/list_read.c (parse_real, read_real): Support NaN/Infinity.

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

        PR fortran/34319
        * gfortran.dg/nan_3.f90: New.

From-SVN: r130708

gcc/testsuite/ChangeLog

+2007-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34319
+	* gfortran.dg/nan_3.f90: New.
+
 2007-12-07  Jakub Jelinek  <jakub@redhat.com>
 
 	* g++.old-deja/g++.mike/empty.C: Remove 2 xfails.

gcc/testsuite/gfortran.dg/nan_3.f90

+! { dg-do run }
+! { dg-options "-fno-range-check" }
+! { dg-options "-fno-range-check -mieee" { target sh*-*-* } }
+!
+! PR fortran/34319
+!
+! Check support of INF/NaN for I/O.
+!
+program main
+  implicit none
+  real :: r
+  complex :: z
+  character(len=30) :: str
+
+  str = "nan"
+  read(str,*) r
+  if (.not.isnan(r)) call abort()
+  str = "(nan,4.0)"
+  read(str,*) z
+  if (.not.isnan(real(z)) .or. aimag(z) /= 4.0) call abort()
+  str = "(7.0,nan)"
+  read(str,*) z
+  if (.not.isnan(aimag(z)) .or. real(z) /= 7.0) call abort()
+
+  str = "inFinity"
+  read(str,*) r
+  if (r <= huge(r)) call abort()
+  str = "(+inFinity,4.0)"
+  read(str,*) z
+  if ((real(z) <= huge(r)) .or. aimag(z) /= 4.0) call abort()
+  str = "(7.0,-inFinity)"
+  read(str,*) z
+  if ((aimag(z) >= -huge(r)) .or. real(z) /= 7.0) call abort()
+
+  str = "inf"
+  read(str,*) r
+  if (r <= huge(r)) call abort()
+  str = "(+inf,4.0)"
+  read(str,*) z
+  if ((real(z) <= huge(r)) .or. aimag(z) /= 4.0) call abort()
+  str = "(7.0,-inf)"
+  read(str,*) z
+  if ((aimag(z) >= -huge(r)) .or. real(z) /= 7.0) call abort()
+
+end program main

libgfortran/ChangeLog

+2007-12-08  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34319
+	* io/list_read.c (parse_real, read_real): Support NaN/Infinity.
+
 2007-12-02  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 	    Thomas Koenig  <tkoenig@gcc.gnu.org>
 

libgfortran/io/list_read.c

@@ -1078,7 +1078,12 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
     }
 
   if (!isdigit (c) && c != '.')
-    goto bad;
+    {
+      if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
+	goto inf_nan;
+      else
+	goto bad;
+    }
 
   push_char (dtp, c);
 
@@ -1136,6 +1141,13 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
 
  exp2:
   if (!isdigit (c))
+    {
+      if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
+	goto inf_nan;
+      else
+	goto bad;
+    }
+
     goto bad;
   push_char (dtp, c);
 
@@ -1166,6 +1178,41 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length)
 
   return m;
 
+ inf_nan:
+  /* Match INF and Infinity.  */
+  if ((c == 'i' || c == 'I')
+      && ((c = next_char (dtp)) == 'n' || c == 'N')
+      && ((c = next_char (dtp)) == 'f' || c == 'F'))
+    {
+	c = next_char (dtp);
+	if ((c != 'i' && c != 'I')
+	    || ((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))))
+	  {
+	     if (is_separator (c))
+	       unget_char (dtp, c);
+	     push_char (dtp, 'i');
+	     push_char (dtp, 'n');
+	     push_char (dtp, 'f');
+	     goto done;
+	  }
+    } /* Match NaN.  */
+  else if (((c = next_char (dtp)) == 'a' || c == 'A')
+	   && ((c = next_char (dtp)) == 'n' || c == 'N')
+	   && (c = next_char (dtp)))
+    {
+      if (is_separator (c))
+	unget_char (dtp, c);
+      push_char (dtp, 'n');
+      push_char (dtp, 'a');
+      push_char (dtp, 'n');
+      goto done;
+    }
+
  bad:
 
   if (nml_bad_return (dtp, c))
@@ -1293,6 +1340,12 @@ read_real (st_parameter_dt *dtp, int length)
       eat_separator (dtp);
       return;
 
+    case 'i':
+    case 'I':
+    case 'n':
+    case 'N':
+      goto inf_nan;
+
     default:
       goto bad_real;
     }
@@ -1367,7 +1420,12 @@ read_real (st_parameter_dt *dtp, int length)
     }
 
   if (!isdigit (c) && c != '.')
-    goto bad_real;
+    {
+      if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
+	goto inf_nan;
+      else
+	goto bad_real;
+    }
 
   if (c == '.')
     {
@@ -1464,6 +1522,37 @@ read_real (st_parameter_dt *dtp, int length)
   dtp->u.p.saved_type = BT_REAL;
   return;
 
+ inf_nan:
+  /* Match INF and Infinity.  */
+  if ((c == 'i' || c == 'I')
+      && ((c = next_char (dtp)) == 'n' || c == 'N')
+      && ((c = next_char (dtp)) == 'f' || c == 'F'))
+    {
+	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;
+	  }
+    } /* 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))
+    {
+      push_char (dtp, 'n');
+      push_char (dtp, 'a');
+      push_char (dtp, 'n');
+      goto done;
+    }
+
  bad_real:
 
   if (nml_bad_return (dtp, c))