GFC_ISYM_STOPPED_IMAGES,
GFC_ISYM_STORAGE_SIZE,
GFC_ISYM_STRIDE,
- GFC_ISYM_SU_KIND,
GFC_ISYM_SUM,
GFC_ISYM_SYMLINK,
GFC_ISYM_SYMLNK,
GFC_ISYM_Y0,
GFC_ISYM_Y1,
GFC_ISYM_YN,
- GFC_ISYM_YN2
+ GFC_ISYM_YN2,
+
+ /* Add this at the end, so maybe the module format
+ remains compatible. */
+ GFC_ISYM_SU_KIND
+
};
enum init_local_logical
gfc_expr *gfc_simplify_ieee_functions (gfc_expr *);
bool gfc_is_constant_array_expr (gfc_expr *);
bool gfc_is_size_zero_array (gfc_expr *);
-void gfc_convert_mpz_to_unsigned (mpz_t, int);
+void gfc_convert_mpz_to_unsigned (mpz_t, int, bool check = true);
/* trans-array.cc */
mpz_set_str (e->value.integer, t, radix);
k = gfc_validate_kind (BT_UNSIGNED, kind, false);
- gfc_convert_mpz_to_unsigned (e->value.integer, gfc_unsigned_kinds[k].bit_size);
+ gfc_convert_mpz_to_unsigned (e->value.integer, gfc_unsigned_kinds[k].bit_size,
+ false);
return e;
}
be accomplished by masking out the high bits. */
void
-gfc_convert_mpz_to_unsigned (mpz_t x, int bitsize)
+gfc_convert_mpz_to_unsigned (mpz_t x, int bitsize, bool check)
{
mpz_t mask;
{
/* Confirm that no bits above the signed range are set if we
are doing range checking. */
- if (flag_range_check != 0)
+ if (check && flag_range_check != 0)
gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
}
}
IOCALL_WRITE_DONE,
IOCALL_X_INTEGER,
IOCALL_X_INTEGER_WRITE,
+ IOCALL_X_UNSIGNED,
+ IOCALL_X_UNSIGNED_WRITE,
IOCALL_X_LOGICAL,
IOCALL_X_LOGICAL_WRITE,
IOCALL_X_CHARACTER,
get_identifier (PREFIX("transfer_integer_write")), ". w R . ",
void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+ iocall[IOCALL_X_UNSIGNED] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_unsigned")), ". w W . ",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_UNSIGNED_WRITE] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_unsigned_write")), ". w R . ",
+ void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
+
iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("transfer_logical")), ". w W . ",
void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
break;
+ case BT_UNSIGNED:
+ arg2 = build_int_cst (unsigned_type_node, kind);
+ if (last_dt == READ)
+ function = iocall[IOCALL_X_UNSIGNED];
+ else
+ function = iocall[IOCALL_X_UNSIGNED_WRITE];
+
+ break;
+
case BT_REAL:
arg2 = build_int_cst (integer_type_node, kind);
if (last_dt == READ)
! { dg-do run }
! { dg-options "-funsigned" }
-! Test basic assignment, arithmetic and a condition.
+! Test some arithmetic ans selected_unsigned_kind.
program memain
unsigned :: u, v
+ integer, parameter :: u1 = selected_unsigned_kind(2), &
+ u2 = selected_unsigned_kind(4), &
+ u4 = selected_unsigned_kind(6), &
+ u8 = selected_unsigned_kind(10)
u = 1u
v = 42u
if (u + v /= 43u) then
stop 1
end if
+ if (u1 /= 1 .or. u2 /= 2 .or. u4 /= 4 .or. u8 /= 8) stop 2
end program memain
--- /dev/null
+! { dg-do run }
+! { dg-additional-options -funsigned }
+! Test some list-directed I/O
+program main
+ implicit none
+ unsigned :: uw, ur, vr
+ unsigned(kind=8) :: u8
+ uw = 10u
+ open (10, status="scratch")
+ write (10,*) uw,-1
+ rewind 10
+ read (10,*) ur,vr
+ if (ur /= 10u .or. vr /= 4294967295u) stop 1
+ rewind 10
+ write (10,*) 17179869184u_8
+ rewind 10
+ read (10,*) u8
+ if (u8 /= 17179869184u_8) stop 2
+end program main
+
global:
_gfortran_internal_pack_class;
_gfortran_internal_unpack_class;
+ _gfortran_transfer_unsigned;
+ _gfortran_transfer_unsigned_write;
} GFORTRAN_14;
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
internal_proto(set_integer);
+extern void set_unsigned (void *, GFC_UINTEGER_LARGEST, int);
+internal_proto(set_unsigned);
+
extern GFC_UINTEGER_LARGEST si_max (int);
internal_proto(si_max);
+extern GFC_UINTEGER_LARGEST us_max (int);
+internal_proto(us_max);
+
extern int convert_real (st_parameter_dt *, void *, const char *, int);
internal_proto(convert_real);
return 1;
}
+/* Same as above, but for unsigneds, where we do not need overflow checks,
+ except on the repeat count. */
+
+static int
+convert_unsigned (st_parameter_dt *dtp, int length, int negative)
+{
+ char c, *buffer, message[IOMSG_LEN];
+ GFC_UINTEGER_LARGEST v, value;
+ GFC_UINTEGER_8 max;
+ int m;
+
+ buffer = dtp->u.p.saved_string;
+ max = length == -1 ? 0 : MAX_REPEAT;
+
+ for (;;)
+ {
+ c = *buffer++;
+ if (c == '\0')
+ break;
+ c -= '0';
+ v += c;
+ if (length == -1 && v > max)
+ goto overflow;
+ }
+
+ m = 0;
+
+ if (length == -1)
+ {
+ if (negative)
+ value = -v;
+ else
+ value = v;
+
+ value = value & us_max (length);
+ set_unsigned (dtp->u.p.value, value, length);
+ }
+ else
+ {
+ dtp->u.p.repeat_count = v;
+
+ if (dtp->u.p.repeat_count == 0)
+ {
+ snprintf (message, IOMSG_LEN, "Zero repeat count in item %d of list input",
+ dtp->u.p.item_count);
+
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
+ m = 1;
+ }
+ }
+ free_saved (dtp);
+ return m;
+
+ overflow:
+ snprintf (message, IOMSG_LEN, "Repeat count overflow in item %d of list input",
+ dtp->u.p.item_count);
+
+ return 1;
+}
/* Parse a repeat count for logical and complex values which cannot
begin with a digit. Returns nonzero if we are done, zero if we
used for repeat counts. */
static void
-read_integer (st_parameter_dt *dtp, int length)
+read_integer (st_parameter_dt *dtp, int length, bt type)
{
char message[IOMSG_LEN];
int c, negative;
}
repeat:
- if (convert_integer (dtp, -1, 0))
- return;
+ if (type == BT_INTEGER)
+ {
+ if (convert_integer (dtp, -1, 0))
+ return;
+ }
+ else
+ {
+ if (convert_unsigned (dtp, -1, 0))
+ return;
+ }
/* Get the real integer. */
else if (c != '\n')
eat_line (dtp);
- snprintf (message, IOMSG_LEN, "Bad integer for item %d in list input",
+ if (type == BT_INTEGER)
+ snprintf (message, IOMSG_LEN, "Bad integer for item %d in list input",
dtp->u.p.item_count);
+ else
+ snprintf (message, IOMSG_LEN, "Bad unsigned for item %d in list input",
+ dtp->u.p.item_count);
+
free_line (dtp);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
eat_separator (dtp);
push_char (dtp, '\0');
- if (convert_integer (dtp, length, negative))
+ if (convert_integer (dtp, length, negative)) /* XXX */
{
free_saved (dtp);
return;
}
free_saved (dtp);
- dtp->u.p.saved_type = BT_INTEGER;
+ dtp->u.p.saved_type = type;
}
-
/* Read a character variable. */
static void
switch (type)
{
case BT_INTEGER:
- read_integer (dtp, kind);
+ case BT_UNSIGNED:
+ read_integer (dtp, kind, type);
break;
case BT_LOGICAL:
read_logical (dtp, kind);
break;
case BT_INTEGER:
+ case BT_UNSIGNED:
case BT_LOGICAL:
memcpy (p, dtp->u.p.value, size);
break;
switch (nl->type)
{
case BT_INTEGER:
- read_integer (dtp, len);
+ case BT_UNSIGNED:
+ read_integer (dtp, len, nl->type);
break;
case BT_LOGICAL:
}
}
+/* set_integer()-- All of the integer assignments come here to
+ actually place the value into memory. */
+
+void
+set_unsigned (void *dest, GFC_UINTEGER_LARGEST value, int length)
+{
+ NOTE ("set_integer: %lld %p", (long long int) value, dest);
+ switch (length)
+ {
+#ifdef HAVE_GFC_UINTEGER_16
+#ifdef HAVE_GFC_REAL_17
+ case 17:
+ {
+ GFC_UINTEGER_16 tmp = value;
+ memcpy (dest, (void *) &tmp, 16);
+ }
+ break;
+#endif
+/* length=10 comes about for kind=10 real/complex BOZ, cf. PR41711. */
+ case 10:
+ case 16:
+ {
+ GFC_UINTEGER_16 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+#endif
+ case 8:
+ {
+ GFC_UINTEGER_8 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+ case 4:
+ {
+ GFC_UINTEGER_4 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+ case 2:
+ {
+ GFC_UINTEGER_2 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+ case 1:
+ {
+ GFC_UINTEGER_1 tmp = value;
+ memcpy (dest, (void *) &tmp, length);
+ }
+ break;
+ default:
+ internal_error (NULL, "Bad integer kind");
+ }
+}
+
/* Max signed value of size give by length argument. */
}
}
+GFC_UINTEGER_LARGEST
+us_max (int length)
+{
+ switch (length)
+ {
+#ifdef HAVE_GFC_UINTEGER_16
+ case 17:
+ case 16:
+ return GFC_UINTEGER_16_HUGE;
+#endif
+ case 8:
+ return GFC_UINTEGER_8_HUGE;
+ case 4:
+ return GFC_UINTEGER_4_HUGE;
+ case 2:
+ return GFC_UINTEGER_2_HUGE;
+ case 1:
+ return GFC_UINTEGER_1_HUGE;
+ default:
+ internal_error (NULL, "Bad unsigned kind");
+ }
+}
/* convert_real()-- Convert a character representation of a floating
point number to the machine number. Returns nonzero if there is an
transfer_complex
transfer_real128
transfer_complex128
+ transfer_unsigned
and for WRITE
transfer_complex_write
transfer_real128_write
transfer_complex128_write
+ transfer_unsigned_write
These subroutines do not return status. The *128 functions
are in the file transfer128.c.
extern void transfer_integer_write (st_parameter_dt *, void *, int);
export_proto(transfer_integer_write);
+extern void transfer_unsigned (st_parameter_dt *, void *, int);
+export_proto(transfer_unsigned);
+
+extern void transfer_unsigned_write (st_parameter_dt *, void *, int);
+export_proto(transfer_unsigned_write);
+
extern void transfer_real (st_parameter_dt *, void *, int);
export_proto(transfer_real);
transfer_integer (dtp, p, kind);
}
+void
+transfer_unsigned (st_parameter_dt *dtp, void *p, int kind)
+{
+ wrap_scalar_transfer (dtp, BT_UNSIGNED, p, kind, kind, 1);
+}
+
+void
+transfer_unsigned_write (st_parameter_dt *dtp, void *p, int kind)
+{
+ transfer_unsigned (dtp, p, kind);
+}
+
void
transfer_real (st_parameter_dt *dtp, void *p, int kind)
{
return;
}
+/* Same as above, but somewhat simpler because we only treat unsigned
+ numbers. */
+static void
+write_decimal_unsigned (st_parameter_dt *dtp, const fnode *f,
+ const char *source, int len)
+{
+ GFC_UINTEGER_LARGEST n = 0;
+ int w, m, digits, nsign, nzero, nblank;
+ char *p;
+ const char *q;
+ sign_t sign;
+ char itoa_buf[GFC_BTOA_BUF_SIZE];
+
+ w = f->u.integer.w;
+ m = f->format == FMT_G ? -1 : f->u.integer.m;
+
+ n = extract_uint (source, len);
+
+ /* Special case: */
+ if (m == 0 && n == 0)
+ {
+ if (w == 0)
+ w = 1;
+
+ p = write_block (dtp, w);
+ if (p == NULL)
+ return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', w);
+ }
+ else
+ memset (p, ' ', w);
+ goto done;
+ }
+
+ /* Just in case somebody wants a + sign. */
+ sign = calculate_sign (dtp, false);
+ nsign = sign == S_NONE ? 0 : 1;
+
+ q = gfc_itoa (n, itoa_buf, sizeof (itoa_buf));
+ digits = strlen (q);
+
+ /* Select a width if none was specified. The idea here is to always
+ print something. */
+ if (w == DEFAULT_WIDTH)
+ w = default_width_for_integer (len);
+
+ if (w == 0)
+ w = ((digits < m) ? m : digits) + nsign;
+
+ p = write_block (dtp, w);
+ if (p == NULL)
+ return;
+
+ nzero = 0;
+ if (digits < m)
+ nzero = m - digits;
+
+ /* See if things will work. */
+
+ nblank = w - (nsign + nzero + digits);
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *)p;
+ if (nblank < 0)
+ {
+ memset4 (p4, '*', w);
+ goto done;
+ }
+
+ if (!dtp->u.p.namelist_mode)
+ {
+ memset4 (p4, ' ', nblank);
+ p4 += nblank;
+ }
+
+ if (sign == S_PLUS)
+ *p4++ = '+';
+
+ memset4 (p4, '0', nzero);
+ p4 += nzero;
+
+ memcpy4 (p4, q, digits);
+
+ if (dtp->u.p.namelist_mode)
+ {
+ p4 += digits;
+ memset4 (p4, ' ', nblank);
+ }
+
+ return;
+ }
+
+ if (nblank < 0)
+ {
+ star_fill (p, w);
+ goto done;
+ }
+
+ if (!dtp->u.p.namelist_mode)
+ {
+ memset (p, ' ', nblank);
+ p += nblank;
+ }
+
+ if (sign == S_PLUS)
+ *p++ = '+';
+
+ memset (p, '0', nzero);
+ p += nzero;
+
+ memcpy (p, q, digits);
+
+ if (dtp->u.p.namelist_mode)
+ {
+ p += digits;
+ memset (p, ' ', nblank);
+ }
+
+ done:
+ return;
+
+}
/* Convert hexadecimal to ASCII. */
static const char *
write_decimal (dtp, &f, source, kind);
}
+/* Write a list-directed unsigned value. We use the same formatting
+ as for integer. */
+
+static void
+write_unsigned (st_parameter_dt *dtp, const char *source, int kind)
+{
+ int width;
+ fnode f;
+
+ switch (kind)
+ {
+ case 1:
+ width = 4;
+ break;
+
+ case 2:
+ width = 6;
+ break;
+
+ case 4:
+ width = 11;
+ break;
+
+ case 8:
+ width = 20;
+ break;
+
+ case 16:
+ width = 40;
+ break;
+
+ default:
+ width = 0;
+ break;
+ }
+ f.u.integer.w = width;
+ f.u.integer.m = -1;
+ f.format = FMT_NONE;
+ write_decimal_unsigned (dtp, &f, source, kind);
+}
+
/* Write a list-directed string. We have to worry about delimiting
the strings if the file has been opened in that mode. */
case BT_INTEGER:
write_integer (dtp, p, kind);
break;
+ case BT_UNSIGNED:
+ write_unsigned (dtp, p, kind);
+ break;
case BT_LOGICAL:
write_logical (dtp, p, kind);
break;
(GFC_INTEGER_16)((((GFC_UINTEGER_16)1) << 127) - 1)
#endif
+#define GFC_UINTEGER_1_HUGE ((GFC_UINTEGER_1) -1)
+#define GFC_UINTEGER_2_HUGE ((GFC_UINTEGER_2) -1)
+#define GFC_UINTEGER_4_HUGE ((GFC_UINTEGER_4) -1)
+#define GFC_UINTEGER_8_HUGE ((GFC_UINTEGER_8) -1)
+#ifdef HAVE_GFC_UINTEGER_16
+#define GFC_UINTEGER_16_HUGE ((GFC_UINTEGER_16) -1)
+#endif
+
+
/* M{IN,AX}{LOC,VAL} need also infinities and NaNs if supported. */
#if __FLT_HAS_INFINITY__
#endif
-/* We always have these. */
-
-#define HAVE_GFC_UINTEGER_1 1
-#define HAVE_GFC_UINTEGER_4 1
-
#endif /* LIBGFOR_H */
echo "typedef GFC_INTEGER_${k} GFC_LOGICAL_${k};"
echo "#define HAVE_GFC_LOGICAL_${k}"
echo "#define HAVE_GFC_INTEGER_${k}"
+ echo "#define HAVE_GFC_UINTEGER_${k}"
echo ""
fi
rm -f tmp$$.*
projects / thirdparty / gcc.git / commitdiff
