[fortran] patch for PR 12839 - incorrect IO of inf

[Bud Davis <bdavis9659 at comcast dot net>]

Below is a patch for your consideration that implements the output of
+inf/-inf/nan as per the draft Fortran 2003 standard.  At least it is my
attempt to implement it properly :)

Tested on i686/linux with no additional test suite failures.

Here is a test case, that demonstrates it:


! pr12839 - output infinity using F2003 standard
   implicit none
   real zero,nan,pos_inf,neg_inf
   character*30 B,info
   logical debug
   integer test_count,fail_count
   common test_count,fail_count,debug
!
   debug = .FALSE.
   test_count = 0
   fail_count = 0
   zero = 0.0
   pos_inf =  1.0/zero
   neg_inf = -1.0/zero
   nan = zero/zero
!
!  check field < 3
   call check('pos inf field oflow','(F2.0)',pos_inf,'**',2)
   call check('neg inf field oflow','(F2.0)',neg_inf,'**',2)
   call check('nan     field oflow','(F2.0)',nan    ,'**',2)
!
!  check field = 3
   call check('pos inf no +/-','(F3.0)',pos_inf,'Inf',3)
   call check('neg inf no +/-','(F3.0)',neg_inf,'Inf',3)
   call check('nan           ','(F3.0)',nan    ,'NaN',3)
!
!  check field > 3
   call check('pos inf ','(F4.0)',pos_inf,'+Inf',4)
   call check('neg inf ','(F4.0)',neg_inf,'-Inf',4)
   call check('nan     ','(F4.0)',nan    ,' NaN',4)
 
!  check field = 7
   call check('pos inf ','(F7.1)',pos_inf,'   +Inf',7)
   call check('neg inf ','(F7.1)',neg_inf,'   -Inf',7)
   call check('nan     ','(F7.1)',nan    ,'    NaN',7)
 
!  check field = 8
   call check('pos inf ','(F8.0)',pos_inf,'Infinity',8)
   call check('neg inf ','(F8.0)',neg_inf,'Infinity',8)
   call check('nan     ','(F8.0)',nan    ,'     NaN',8)
 
!  check field = 9
   call check('pos inf ','(F9.2)',pos_inf,'+Infinity',9)
   call check('neg inf ','(F9.2)',neg_inf,'-Infinity',9)
   call check('nan     ','(F9.2)',nan    ,'      NaN',9)
 
!  check field = 14
   call check('pos inf ','(F14.0)',pos_inf,'     +Infinity',14)
   call check('neg inf ','(F14.0)',neg_inf,'     -Infinity',14)
   call check('nan     ','(F14.0)',nan    ,'           NaN',14)
 
   if (debug)print*,'Ran ',test_count,' with ',fail_count,' failures.'
   end
   subroutine check(info,fmt,value,exp,len)
   implicit none
   logical debug
   character(len=*) fmt,exp,info
   character*30 B
   real value
   integer len,test_count,fail_count,i
   common test_count,fail_count,debug
   test_count = test_count + 1
   B = ''
   write(B,fmt)value
   if (debug) print*,'---------------'
   if (debug) print*,'TEST: ',info
   if (debug) print*,'INTERNAL WRITE: ',B(1:len),' FORMAT: ',fmt
 
   if (B(1:len).NE.exp(1:len)) then
      print*,' is ',B(1:len),' should be ',exp,' fmt is ',fmt
      fail_count = fail_count + 1
      do i = 1,len
         print*,'i = ',i,' ',B(i:i)
      enddo
      if (.not.debug) call abort
   endif
   return
   end



2004-02-28  Bud Davis  <bdavis9659@comcast.net>
                                                                                                                                      
        * io/write.c (write_float): PR12839 Change +-inf and NaN to
F2003 standard.
  



      
Index: gcc/libgfortran/io/write.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/Attic/write.c,v
retrieving revision 1.1.2.7
diff -c -3 -p -r1.1.2.7 write.c
*** gcc/libgfortran/io/write.c  1 Jan 2004 13:57:04 -0000       1.1.2.7
--- gcc/libgfortran/io/write.c  29 Feb 2004 16:09:40 -0000
*************** write_float (fnode *f, const char *sourc
*** 507,516 ****
       if (res == 0)
         {
           nb =  f->u.real.w;
-          if (nb <= 4)
-             nb = 4;
           p = write_block (nb);
!          memset (p, ' ' , 1);
            
           res = isinf (n);
           if (res != 0)
--- 507,520 ----
       if (res == 0)
         {
           nb =  f->u.real.w;
           p = write_block (nb);
!          if (nb < 3)
!          {
!              memset (p, '*',nb);
!              return;
!          }
!
!          memset(p, ' ', nb);
            
           res = isinf (n);
           if (res != 0)
*************** write_float (fnode *f, const char *sourc
*** 519,529 ****
                 fin = '+';
              else
                 fin = '-';
!
!              memset (p + 1, fin, nb - 1);
            }
           else
!              sprintf(p + 1, "NaN");
           return;
         }
     }
--- 523,541 ----
                 fin = '+';
              else
                 fin = '-';
!
!             if (nb > 7)
!                sprintf(p + nb - 8, "Infinity");
!             else
!                sprintf(p + nb - 3, "Inf");
!
!             if (nb < 8)
!                memset(p + nb - 4, fin, 1);
!             else if (nb > 8)
!                memset(p + nb - 9, fin, 1);
            }
           else
!              sprintf(p + nb -3 , "NaN");
           return;
         }
     }