https://gcc.gnu.org/g:4ee8acd349ebc55526421b7fa73b0b7a30ee4ebe
commit 4ee8acd349ebc55526421b7fa73b0b7a30ee4ebe
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Fri Aug 2 18:33:40 2024 +0200
Add decimal formatted I/O for unsigneds.
Diff:
---
gcc/testsuite/gfortran.dg/unsigned_4.f90 | 15 ++++
libgfortran/io/io.h | 7 ++
libgfortran/io/read.c | 135 ++++++++++++++++++++++++++-----
libgfortran/io/transfer.c | 42 +++++++++-
libgfortran/io/write.c | 5 ++
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 000000000000..495523d919d3
--- /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 32e2b825ed5b..2677551b277d 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 2fb39392fc99..60b497a810d9 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 741dbd9cc981..64f394dddc75 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 0f9600f5f1fe..2f414c6b57d2 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)
