[gcc] GCC 4.5.0=>4.5.1

gcc/libgfortran/io/write.c

Index: gcc/libgfortran/io/write.c
diff --git a/gcc/libgfortran/io/write.c b/gcc/libgfortran/io/write.c
index b6d6e687736dab543896ac1375dfac38a2986a39..fa31b98665bcf5cc68da31522901717f611ab57f 100644
--- a/gcc/libgfortran/io/write.c
+++ b/gcc/libgfortran/io/write.c
@@ -26,6 +26,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 <http://www.gnu.org/licenses/>.  */
 
 #include "io.h"
+#include "format.h"
+#include "unix.h"
 #include <assert.h>
 #include <string.h>
 #include <ctype.h>
@@ -293,7 +295,7 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
      Standard sections 10.6.3 and 9.9 for further information.  */
   if (is_stream_io (dtp))
     {
-      const char crlf[] = "\r\n";
+      const gfc_char4_t crlf[] = {0x000d,0x000a};
       int i, bytes;
       gfc_char4_t *qq;
       bytes = 0;
@@ -446,9 +448,10 @@ extract_uint (const void *p, int len)
       }
       break;
 #ifdef HAVE_GFC_INTEGER_16
+    case 10:
     case 16:
       {
-	GFC_INTEGER_16 tmp;
+	GFC_INTEGER_16 tmp = 0;
 	memcpy ((void *) &tmp, p, len);
 	i = (GFC_UINTEGER_16) tmp;
       }
@@ -482,20 +485,14 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
 
 
 static void
-write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
-           const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
+write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
 {
-  GFC_UINTEGER_LARGEST n = 0;
   int w, m, digits, nzero, nblank;
   char *p;
-  const char *q;
-  char itoa_buf[GFC_BTOA_BUF_SIZE];
 
   w = f->u.integer.w;
   m = f->u.integer.m;
 
-  n = extract_uint (source, len);
-
   /* Special case:  */
 
   if (m == 0 && n == 0)
@@ -511,7 +508,6 @@ write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
       goto done;
     }
 
-  q = conv (n, itoa_buf, sizeof (itoa_buf));
   digits = strlen (q);
 
   /* Select a width if none was specified.  The idea here is to always
@@ -538,7 +534,6 @@ write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
       goto done;
     }
 
-
   if (!dtp->u.p.no_leading_blank)
     {
       memset (p, ' ', nblank);
@@ -706,6 +701,202 @@ btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
   return p;
 }
 
+/* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
+   to convert large reals with kind sizes that exceed the largest integer type
+   available on certain platforms.  In these cases, byte by byte conversion is
+   performed. Endianess is taken into account.  */
+
+/* Conversion to binary.  */
+
+static const char *
+btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  char *q;
+  int i, j;
+  
+  q = buffer;
+  if (big_endian)
+    {
+      const char *p = s;
+      for (i = 0; i < len; i++)
+	{
+	  char c = *p;
+
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 8; j++)
+	    {
+	      *q++ = (c & 128) ? '1' : '0';
+	      c <<= 1;
+	    }
+	  p++;
+	}
+    }
+  else
+    {
+      const char *p = s + len - 1;
+      for (i = 0; i < len; i++)
+	{
+	  char c = *p;
+
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 8; j++)
+	    {
+	      *q++ = (c & 128) ? '1' : '0';
+	      c <<= 1;
+	    }
+	  p--;
+	}
+    }
+
+  *q = '\0';
+
+  if (*n == 0)
+    return "0";
+
+  /* Move past any leading zeros.  */  
+  while (*buffer == '0')
+    buffer++;
+
+  return buffer;
+
+}
+
+/* Conversion to octal.  */
+
+static const char *
+otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  char *q;
+  int i, j, k;
+  uint8_t octet;
+
+  q = buffer + GFC_OTOA_BUF_SIZE - 1;
+  *q = '\0';
+  i = k = octet = 0;
+
+  if (big_endian)
+    {
+      const char *p = s + len - 1;
+      char c = *p;
+      while (i < len)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 3 && i < len; j++)
+	    {
+	      octet |= (c & 1) << j;
+	      c >>= 1;
+	      if (++k > 7)
+	        {
+		  i++;
+		  k = 0;
+		  c = *--p;
+		}
+	    }
+	  *--q = '0' + octet;
+	  octet = 0;
+	}
+    }
+  else
+    {
+      const char *p = s;
+      char c = *p;
+      while (i < len)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  for (j = 0; j < 3 && i < len; j++)
+	    {
+	      octet |= (c & 1) << j;
+	      c >>= 1;
+	      if (++k > 7)
+	        {
+		  i++;
+		  k = 0;
+		  c = *++p;
+		}
+	    }
+	  *--q = '0' + octet;
+	  octet = 0;
+	}
+    }
+
+  if (*n == 0)
+    return "0";
+
+  /* Move past any leading zeros.  */  
+  while (*q == '0')
+    q++;
+
+  return q;
+}
+
+/* Conversion to hexidecimal.  */
+
+static const char *
+ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+  static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
+    '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
+
+  char *q;
+  uint8_t h, l;
+  int i;
+  
+  q = buffer;
+  
+  if (big_endian)
+    {
+      const char *p = s;
+      for (i = 0; i < len; i++)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  h = (*p >> 4) & 0x0F;
+	  l = *p++ & 0x0F;
+	  *q++ = a[h];
+	  *q++ = a[l];
+	}
+    }
+  else
+    {
+      const char *p = s + len - 1;
+      for (i = 0; i < len; i++)
+	{
+	  /* Test for zero. Needed by write_boz later.  */
+	  if (*p != 0)
+	    *n = 1;
+
+	  h = (*p >> 4) & 0x0F;
+	  l = *p-- & 0x0F;
+	  *q++ = a[h];
+	  *q++ = a[l];
+	}
+    }
+
+  *q = '\0';
+  
+  if (*n == 0)
+    return "0";
+    
+  /* Move past any leading zeros.  */  
+  while (*buffer == '0')
+    buffer++;
+
+  return buffer;
+}
 
 /* gfc_itoa()-- Integer to decimal conversion.
    The itoa function is a widespread non-standard extension to standard
@@ -757,22 +948,64 @@ write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 
 
 void
-write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
-  write_int (dtp, f, p, len, btoa);
+  const char *p;
+  char itoa_buf[GFC_BTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = btoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = btoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
 }
 
 
 void
-write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
-  write_int (dtp, f, p, len, otoa);
+  const char *p;
+  char itoa_buf[GFC_OTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+  
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = otoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = otoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
 }
 
 void
-write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
-  write_int (dtp, f, p, len, gfc_xtoa);
+  const char *p;
+  char itoa_buf[GFC_XTOA_BUF_SIZE];
+  GFC_UINTEGER_LARGEST n = 0;
+
+  if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+    {
+      p = ztoa_big (source, itoa_buf, len, &n);
+      write_boz (dtp, f, p, n);
+    }
+  else
+    {
+      n = extract_uint (source, len);
+      p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
+      write_boz (dtp, f, p, n);
+    }
 }
 
 
@@ -1194,10 +1427,8 @@ namelist_write_newline (st_parameter_dt *dtp)
   if (is_array_io (dtp))
     {
       gfc_offset record;
-      int finished, length;
+      int finished;
 
-      length = (int) dtp->u.p.current_unit->bytes_left;
-	      
       /* Now that the current record has been padded out,
 	 determine where the next record in the array is. */
       record = next_array_record (dtp, dtp->u.p.current_unit->ls,
@@ -1316,8 +1547,8 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
   nelem = 1;
   for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
     {
-      obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
-      nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
+      obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
+      nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
     }
 
   /* Main loop to output the data held in the object.  */
@@ -1484,9 +1715,9 @@ obj_loop:
       {
 	obj->ls[dim_i].idx += nml_carry ;
 	nml_carry = 0;
-	if (obj->ls[dim_i].idx  > (index_type) obj->dim[dim_i].ubound)
+ 	if (obj->ls[dim_i].idx  > (ssize_t) GFC_DESCRIPTOR_UBOUND(obj,dim_i))
 	  {
-	    obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
+ 	    obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
 	    nml_carry = 1;
 	  }
        }