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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@130708 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 87b83e1..255956a 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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.

diff --git a/gcc/testsuite/gfortran.dg/nan_3.f90 b/gcc/testsuite/gfortran.dg/nan_3.f90
new file mode 100644 (file)
index 0000000..957b94d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/nan_3.f90
@@ -0,0 +1,45 @@
+! { 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

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index e77ef14..8886338 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,8 @@
+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>
 

diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 586e356..c212489 100644 (file)
--- a/libgfortran/io/list_read.c
+++ b/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))