Add decimal formatted I/O for unsigneds.

5 files changed, 178 insertions, 26 deletions

diff --git a/gcc/testsuite/gfortran.dg/unsigned_4.f90 b/gcc/testsuite/gfortran.dg/unsigned_4.f90
new file mode 100644
index 0000000..495523d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_4.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test some basic formatted I/O.
+
+program main
+  unsigned :: u
+  open (10,status="scratch")
+  write (10,'(I4)') 1u
+  write (10,'(I4)') -1
+  rewind 10
+  read (10,'(I4)') u
+  if (u /= 1u) stop 1
+  read (10,'(I4)') u
+  if (u /= 4294967295u) stop 2
+end program main
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 32e2b82..2677551 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -897,6 +897,10 @@ internal_proto(read_radix);
 extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_decimal);
 
+extern void read_decimal_unsigned (st_parameter_dt *, const fnode *, char *,
+				   int);
+internal_proto(read_decimal_unsigned);
+
 extern void read_user_defined (st_parameter_dt *, void *);
 internal_proto(read_user_defined);
 
@@ -947,6 +951,9 @@ internal_proto(write_f);
 extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_i);
 
+extern void write_iu (st_parameter_dt *, const fnode *, const char *, int);
+internal_proto(write_iu);
+
 extern void write_l (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(write_l);
 
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
index 2fb3939..60b497a 100644
--- a/libgfortran/io/read.c
+++ b/libgfortran/io/read.c
@@ -470,7 +470,7 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
     if ((c & ~masks[nb-1]) == patns[nb-1])
       goto found;
   goto invalid;
-	
+
  found:
   c = (c & masks[nb-1]);
   nread = nb - 1;
@@ -501,7 +501,7 @@ read_utf8 (st_parameter_dt *dtp, size_t *nbytes)
     goto invalid;
 
   return c;
-      
+
  invalid:
   generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding");
   return (gfc_char4_t) '?';
@@ -544,7 +544,7 @@ read_default_char1 (st_parameter_dt *dtp, char *p, size_t len, size_t width)
   size_t m;
 
   s = read_block_form (dtp, &width);
-  
+
   if (s == NULL)
     return;
   if (width > len)
@@ -688,7 +688,7 @@ read_a_char4 (st_parameter_dt *dtp, const fnode *f, char *p, size_t length)
     read_utf8_char4 (dtp, p, length, w);
   else
     read_default_char4 (dtp, p, length, w);
-  
+
   dtp->u.p.sf_read_comma =
     dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
 }
@@ -729,7 +729,7 @@ next_char (st_parameter_dt *dtp, char **p, size_t *w)
   if (c != ' ')
     return c;
   if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
-    return ' ';  /* return a blank to signal a null */ 
+    return ' ';  /* return a blank to signal a null */
 
   /* At this point, the rest of the field has to be trailing blanks */
 
@@ -808,19 +808,19 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
       c = next_char (dtp, &p, &w);
       if (c == '\0')
 	break;
-	
+
       if (c == ' ')
         {
 	  if (dtp->u.p.blank_status == BLANK_NULL)
 	    {
 	      /* Skip spaces.  */
 	      for ( ; w > 0; p++, w--)
-		if (*p != ' ') break; 
+		if (*p != ' ') break;
 	      continue;
 	    }
 	  if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
         }
-        
+
       if (c < '0' || c > '9')
 	goto bad;
 
@@ -856,6 +856,98 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 
 }
 
+/* read_decimal_unsigned () - almost the same as above, but we do not check for
+   overflow, but just calculate everything mod 2^n. */
+
+void
+read_decimal_unsigned (st_parameter_dt *dtp, const fnode *f, char *dest,
+		       int length)
+{
+  GFC_UINTEGER_LARGEST value, v;
+  size_t w;
+  int negative;
+  char c, *p;
+
+  w = f->u.w;
+
+  /* This is a legacy extension, and the frontend will only allow such cases
+   * through when -fdec-format-defaults is passed.
+   */
+  if (w == (size_t) DEFAULT_WIDTH)
+    w = default_width_for_integer (length);
+
+  p = read_block_form (dtp, &w);
+
+  if (p == NULL)
+    return;
+
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    {
+      set_unsigned (dest, (GFC_UINTEGER_LARGEST) 0, length);
+      return;
+    }
+
+  negative = 0;
+
+  switch (*p)
+    {
+    case '-':
+      negative = 1;
+      /* Fall through */
+
+    case '+':
+      p++;
+      if (--w == 0)
+	goto bad;
+      /* Fall through */
+
+    default:
+      break;
+    }
+
+  /* At this point we have a digit-string */
+  value = 0;
+
+  for (;;)
+    {
+      c = next_char (dtp, &p, &w);
+      if (c == '\0')
+	break;
+
+      if (c == ' ')
+	{
+	  if (dtp->u.p.blank_status == BLANK_NULL)
+	    {
+	      /* Skip spaces.  */
+	      for ( ; w > 0; p++, w--)
+		if (*p != ' ') break;
+	      continue;
+	    }
+	  if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
+	}
+
+      if (c < '0' || c > '9')
+	goto bad;
+
+      c -= '0';
+      value = 10 * value;
+      value += c;
+    }
+
+  if (negative)
+    value = -value;
+
+  set_unsigned (dest, value, length);
+  return;
+
+ bad:
+  generate_error (&dtp->common, LIBERROR_READ_VALUE,
+		  "Bad value during integer read");
+  next_record (dtp, 1);
+  return;
+}
+
 
 /* read_radix()-- This function reads values for non-decimal radixes.
    The difference here is that we treat the values here as unsigned
@@ -1070,7 +1162,7 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
   if (w == 0)
     goto zero;
 
-  /* Check for Infinity or NaN.  */    
+  /* Check for Infinity or NaN.  */
   if (unlikely ((w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))))
     {
       int seen_paren = 0;
@@ -1112,9 +1204,9 @@ read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
 	  ++p;
 	  ++out;
 	}
-	 
+
       *out = '\0';
-      
+
       if (seen_paren != 0 && seen_paren != 2)
 	goto bad_float;
 
@@ -1211,7 +1303,7 @@ found_digit:
       ++p;
       --w;
     }
-  
+
   /* No exponent has been seen, so we use the current scale factor.  */
   exponent = - dtp->u.p.scale_factor;
   goto done;
@@ -1249,7 +1341,7 @@ exponent:
 	  ++p;
 	  --w;
 	}
-	
+
       /* Only allow trailing blanks.  */
       while (w > 0)
 	{
@@ -1258,7 +1350,7 @@ exponent:
 	  ++p;
 	  --w;
 	}
-    }    
+    }
   else  /* BZ or BN status is enabled.  */
     {
       while (w > 0)
@@ -1298,7 +1390,7 @@ done:
      significand.  */
   else if (!seen_int_digit && !seen_dec_digit)
     {
-      notify_std (&dtp->common, GFC_STD_LEGACY, 
+      notify_std (&dtp->common, GFC_STD_LEGACY,
 		  "REAL input of style 'E+NN'");
       *(out++) = '0';
     }
@@ -1391,20 +1483,20 @@ read_x (st_parameter_dt *dtp, size_t n)
   if ((dtp->u.p.current_unit->pad_status == PAD_NO || is_internal_unit (dtp))
       && dtp->u.p.current_unit->bytes_left < (gfc_offset) n)
     n = dtp->u.p.current_unit->bytes_left;
-    
+
   if (n == 0)
     return;
-    
+
   if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
     {
       gfc_char4_t c;
       size_t nbytes, j;
-    
+
       /* Proceed with decoding one character at a time.  */
       for (j = 0; j < n; j++)
 	{
 	  c = read_utf8 (dtp, &nbytes);
-    
+
 	  /* Check for a short read and if so, break out.  */
 	  if (nbytes == 0 || c == (gfc_char4_t)0)
 	    break;
@@ -1441,7 +1533,7 @@ read_x (st_parameter_dt *dtp, size_t n)
 	     the rest of the I/O statement.  Set the corresponding flag.  */
 	  if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
 	    dtp->u.p.eor_condition = 1;
-	    
+
 	  /* If we encounter a CR, it might be a CRLF.  */
 	  if (q == '\r') /* Probably a CRLF */
 	    {
@@ -1455,7 +1547,7 @@ read_x (st_parameter_dt *dtp, size_t n)
 	  goto done;
 	}
       n++;
-    } 
+    }
 
  done:
   if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
@@ -1464,4 +1556,3 @@ read_x (st_parameter_dt *dtp, size_t n)
   dtp->u.p.current_unit->bytes_left -= n;
   dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
 }
-
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 741dbd9..64f394d 100644
--- a/libgfortran/io/transfer.c
+++ b/libgfortran/io/transfer.c
@@ -1418,6 +1418,9 @@ type_name (bt type)
     case BT_INTEGER:
       p = "INTEGER";
       break;
+    case BT_UNSIGNED:
+      p = "UNSIGNED";
+      break;
     case BT_LOGICAL:
       p = "LOGICAL";
       break;
@@ -1493,6 +1496,31 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
   return 1;
 }
 
+/* Check that the actual matches one of two expected types; issue an error
+   if that is not the case.  */
+
+
+static int
+require_one_of_two_types (st_parameter_dt *dtp, bt expected1, bt expected2,
+			  bt actual, const fnode *f)
+{
+  char buffer[BUFLEN];
+
+  if (actual == expected1)
+    return 0;
+
+  if (actual == expected2)
+    return 0;
+
+  snprintf (buffer, BUFLEN,
+	    "Expected %s or %s for item %d in formatted transfer, got %s",
+	    type_name (expected1), type_name (expected2),
+	    dtp->u.p.item_count - 1, type_name (actual));
+
+  format_error (dtp, f, buffer);
+  return 1;
+
+}
 
 /* Check that the dtio procedure required for formatted IO is present.  */
 
@@ -1635,9 +1663,12 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
 	case FMT_I:
 	  if (n == 0)
 	    goto need_read_data;
-	  if (require_type (dtp, BT_INTEGER, type, f))
+	  if (require_one_of_two_types (dtp, BT_INTEGER, BT_UNSIGNED, type, f))
 	    return;
-	  read_decimal (dtp, f, p, kind);
+	  if (type == BT_INTEGER)
+	    read_decimal (dtp, f, p, kind);
+	  else
+	    read_decimal_unsigned (dtp, f, p, kind);
 	  break;
 
 	case FMT_B:
@@ -2131,9 +2162,12 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
 	case FMT_I:
 	  if (n == 0)
 	    goto need_data;
-	  if (require_type (dtp, BT_INTEGER, type, f))
+	  if (require_one_of_two_types (dtp, BT_INTEGER, BT_UNSIGNED, type, f))
 	    return;
-	  write_i (dtp, f, p, kind);
+	  if (type == BT_INTEGER)
+	    write_i (dtp, f, p, kind);
+	  else
+	    write_iu (dtp, f, p, kind);
 	  break;
 
 	case FMT_B:
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index 0f9600f..2f414c6 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -1367,6 +1367,11 @@ write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
   write_decimal (dtp, f, p, len);
 }
 
+void
+write_iu (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+  write_decimal_unsigned (dtp, f, p, len);
+}
 
 void
 write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)