re PR libfortran/12839 (incorrect IO of Inf)

2004-06-12  Bud Davis  <bdavis9659@comcast.net>

        PR gfortran/12839
        * gfortran.fortran-torture/execute/nan_inf_fmt.f90: New test.
        * io/write.c(write_float): format inf and nan IAW F2003.

From-SVN: r83024

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2004-06-12  Bud Davis  <bdavis9659@comcast.net>
+
+	PR gfortran/12839
+	* gfortran.fortran-torture/execute/nan_inf_fmt.f90: New test.
+
 2004-06-11  Mark Mitchell  <mark@codesourcery.com>
 
 	PR c++/15862

gcc/testsuite/gfortran.fortran-torture/execute/nan_inf_fmt.f90

@@ -0,0 +1,79 @@
+!pr 12839- F2003 formatting of Inf /Nan 
+       implicit none
+       character*40 l
+       character*12 fmt
+       real zero, pos_inf, neg_inf, nan
+       zero = 0.0
+
+! need a better way of generating these floating point
+! exceptional constants.
+
+       pos_inf =  1.0/zero
+       neg_inf = -1.0/zero
+       nan = zero/zero
+
+
+! check a field width < 3
+       fmt = '(F2.0)'
+       write(l,fmt=fmt)pos_inf
+       if (l.ne.'**') call abort
+       write(l,fmt=fmt)neg_inf
+       if (l.ne.'**') call abort
+       write(l,fmt=fmt)nan
+       if (l.ne.'**') call abort
+
+! check a field width = 3
+       fmt = '(F3.0)'
+       write(l,fmt=fmt)pos_inf
+       if (l.ne.'Inf') call abort
+       write(l,fmt=fmt)neg_inf
+       if (l.ne.'Inf') call abort
+       write(l,fmt=fmt)nan
+       if (l.ne.'NaN') call abort
+
+! check a field width > 3
+       fmt = '(F4.0)'
+       write(l,fmt=fmt)pos_inf
+       if (l.ne.'+Inf') call abort
+       write(l,fmt=fmt)neg_inf
+       if (l.ne.'-Inf') call abort
+       write(l,fmt=fmt)nan
+       if (l.ne.' NaN') call abort
+
+! check a field width = 7
+       fmt = '(F7.0)'
+       write(l,fmt=fmt)pos_inf
+       if (l.ne.'   +Inf') call abort
+       write(l,fmt=fmt)neg_inf
+       if (l.ne.'   -Inf') call abort
+       write(l,fmt=fmt)nan
+       if (l.ne.'    NaN') call abort
+
+! check a field width = 8
+       fmt = '(F8.0)'
+       write(l,fmt=fmt)pos_inf
+       if (l.ne.'Infinity') call abort
+       write(l,fmt=fmt)neg_inf
+       if (l.ne.'Infinity') call abort
+       write(l,fmt=fmt)nan
+       if (l.ne.'     NaN') call abort
+
+! check a field width = 9
+       fmt = '(F9.0)'
+       write(l,fmt=fmt)pos_inf
+       if (l.ne.'+Infinity') call abort
+       write(l,fmt=fmt)neg_inf
+       if (l.ne.'-Infinity') call abort
+       write(l,fmt=fmt)nan
+       if (l.ne.'      NaN') call abort
+
+! check a field width = 14
+       fmt = '(F14.0)'
+       write(l,fmt=fmt)pos_inf
+       if (l.ne.'     +Infinity') call abort
+       write(l,fmt=fmt)neg_inf
+       if (l.ne.'     -Infinity') call abort
+       write(l,fmt=fmt)nan
+       if (l.ne.'           NaN') call abort
+       end
+

libgfortran/ChangeLog

@@ -1,3 +1,8 @@
+2004-06-12  Bud Davis  <bdavis9659@comcast.net>
+
+	PR gfortran/12839
+	* io/write.c(write_float): format inf and nan IAW F2003.
+
 2004-06-09  Bud Davis  <bdavis9659@comcaste.net>
 
 	PR gfortran/14897

libgfortran/io/write.c

@@ -515,11 +515,14 @@ write_float (fnode *f, const char *source, int len)
      if (res == 0)
        {
          nb =  f->u.real.w;
-         if (nb <= 4)
-            nb = 4;
          p = write_block (nb);
-         memset (p, ' ' , 1);
+         if (nb < 3)
-         
+         {
+             memset (p, '*',nb);
+             return;
+         }
+
+         memset(p, ' ', nb);
          res = isinf (n);
          if (res != 0)
          {
@@ -527,11 +530,18 @@ write_float (fnode *f, const char *source, int len)
                fin = '+';
             else
                fin = '-';
-         
+
-             memset (p + 1, fin, nb - 1);
+            if (nb > 7)
+               memcpy(p + nb - 8, "Infinity", 8); 
+            else
+               memcpy(p + nb - 3, "Inf", 3);
+            if (nb < 8)
+               memset(p + nb - 4, fin, 1);
+            else if (nb > 8)
+               memset(p + nb - 9, fin, 1); 
           }
          else
-             sprintf(p + 1, "NaN");
+             memcpy(p + nb - 3, "NaN", 3);
          return;
        }
    }