-/* Copyright (C) 2002-2017 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2023 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist output contributed by Paul Thomas
F2003 I/O support contributed by Jerry DeLisle
#include "unix.h"
#include <assert.h>
#include <string.h>
-#include <ctype.h>
#define star_fill(p, n) memset(p, '*', n)
is set to the appropriate size to allocate. */
static void
-write_check_cc (st_parameter_dt *dtp, const char **source, int *alloc_len)
+write_check_cc (st_parameter_dt *dtp, const char **source, size_t *alloc_len)
{
/* Only valid for CARRIAGECONTROL=FORTRAN. */
if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN
after the start-of-record string was inserted. */
static char *
-write_cc (st_parameter_dt *dtp, char *p, int *source_len)
+write_cc (st_parameter_dt *dtp, char *p, size_t *source_len)
{
/* Only valid for CARRIAGECONTROL=FORTRAN. */
if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN || source_len == NULL)
}
void
-write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+
+write_a (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
{
- int wlen;
+ size_t wlen;
char *p;
wlen = f->u.string.length < 0
|| (f->format == FMT_G && f->u.string.length == 0)
- ? len : f->u.string.length;
+ ? len : (size_t) f->u.string.length;
#ifdef HAVE_CRLF
/* If this is formatted STREAM IO convert any embedded line feed characters
if (is_stream_io (dtp))
{
const char crlf[] = "\r\n";
- int i, q, bytes;
+ size_t q, bytes;
q = bytes = 0;
/* Write out any padding if needed. */
}
/* Scan the source string looking for '\n' and convert it if found. */
- for (i = 0; i < wlen; i++)
+ for (size_t i = 0; i < wlen; i++)
{
if (source[i] == '\n')
{
to the UTF-8 encoded string before writing out. */
void
-write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
{
- int wlen;
+ size_t wlen;
gfc_char4_t *q;
wlen = f->u.string.length < 0
|| (f->format == FMT_G && f->u.string.length == 0)
- ? len : f->u.string.length;
+ ? len : (size_t) f->u.string.length;
q = (gfc_char4_t *) source;
#ifdef HAVE_CRLF
if (is_stream_io (dtp))
{
const gfc_char4_t crlf[] = {0x000d,0x000a};
- int i, bytes;
+ size_t bytes;
gfc_char4_t *qq;
bytes = 0;
/* Scan the source string looking for '\n' and convert it if found. */
qq = (gfc_char4_t *) source;
- for (i = 0; i < wlen; i++)
+ for (size_t i = 0; i < wlen; i++)
{
if (qq[i] == '\n')
{
i = (GFC_UINTEGER_16) tmp;
}
break;
+# ifdef HAVE_GFC_REAL_17
+ case 17:
+ {
+ GFC_INTEGER_16 tmp = 0;
+ memcpy ((void *) &tmp, p, 16);
+ i = (GFC_UINTEGER_16) tmp;
+ }
+ break;
+# endif
#endif
default:
internal_error (NULL, "bad integer kind");
p[wlen - 1] = (n) ? 'T' : 'F';
}
-
static void
-write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
+write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n, int len)
{
int w, m, digits, nzero, nblank;
char *p;
/* 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);
static void
write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
- int len,
- const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
+ int len)
{
GFC_INTEGER_LARGEST n = 0;
+ GFC_UINTEGER_LARGEST absn;
int w, m, digits, nsign, nzero, nblank;
char *p;
const char *q;
sign = calculate_sign (dtp, n < 0);
if (n < 0)
- n = -n;
+ /* Use unsigned to protect from overflow. */
+ absn = -(GFC_UINTEGER_LARGEST) n;
+ else
+ absn = n;
nsign = sign == S_NONE ? 0 : 1;
- /* conv calls itoa which sets the negative sign needed
- by write_integer. The sign '+' or '-' is set below based on sign
- calculated above, so we just point past the sign in the string
- before proceeding to avoid double signs in corner cases.
- (see PR38504) */
- q = conv (n, itoa_buf, sizeof (itoa_buf));
- if (*q == '-')
- q++;
-
+ /* gfc_itoa() converts the nonnegative value to decimal representation. */
+ q = gfc_itoa (absn, 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;
goto done;
}
- memset4 (p4, ' ', nblank);
- p4 += nblank;
+ if (!dtp->u.p.namelist_mode)
+ {
+ memset4 (p4, ' ', nblank);
+ p4 += nblank;
+ }
switch (sign)
{
memcpy4 (p4, q, digits);
return;
+
+ if (dtp->u.p.namelist_mode)
+ {
+ p4 += digits;
+ memset4 (p4, ' ', nblank);
+ }
}
if (nblank < 0)
goto done;
}
- memset (p, ' ', nblank);
- p += nblank;
+ if (!dtp->u.p.namelist_mode)
+ {
+ memset (p, ' ', nblank);
+ p += nblank;
+ }
switch (sign)
{
memcpy (p, q, digits);
+ if (dtp->u.p.namelist_mode)
+ {
+ p += digits;
+ memset (p, ' ', nblank);
+ }
+
done:
return;
}
-/* Convert unsigned octal to ascii. */
+/* Convert hexadecimal to ASCII. */
+
+static const char *
+xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
+{
+ int digit;
+ char *p;
+
+ assert (len >= GFC_XTOA_BUF_SIZE);
+
+ if (n == 0)
+ return "0";
+
+ p = buffer + GFC_XTOA_BUF_SIZE - 1;
+ *p = '\0';
+
+ while (n != 0)
+ {
+ digit = n & 0xF;
+ if (digit > 9)
+ digit += 'A' - '0' - 10;
+
+ *--p = '0' + digit;
+ n >>= 4;
+ }
+
+ return p;
+}
+
+
+/* Convert unsigned octal to ASCII. */
static const char *
otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
}
-/* Convert unsigned binary to ascii. */
+/* Convert unsigned binary to ASCII. */
static const char *
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
+/* The following three functions, btoa_big, otoa_big, and xtoa_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. */
}
}
- *q = '\0';
-
if (*n == 0)
return "0";
return q;
}
-/* Conversion to hexidecimal. */
+/* Conversion to hexadecimal. */
static const char *
-ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+xtoa_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'};
}
}
+ /* write_z, which calls xtoa_big, is called from transfer.c,
+ formatted_transfer_scalar_write. There it is passed the kind as
+ argument, which means a maximum of 16. The buffer is large
+ enough, but the compiler does not know that, so shut up the
+ warning here. */
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wstringop-overflow"
*q = '\0';
+#pragma GCC diagnostic pop
if (*n == 0)
return "0";
void
write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_decimal (dtp, f, p, len, (void *) gfc_itoa);
+ write_decimal (dtp, f, p, len);
}
char itoa_buf[GFC_BTOA_BUF_SIZE];
GFC_UINTEGER_LARGEST n = 0;
+ /* Ensure we end up with a null terminated string. */
+ memset(itoa_buf, '\0', GFC_BTOA_BUF_SIZE);
+
if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{
p = btoa_big (source, itoa_buf, len, &n);
- write_boz (dtp, f, p, n);
+ write_boz (dtp, f, p, n, len);
}
else
{
n = extract_uint (source, len);
p = btoa (n, itoa_buf, sizeof (itoa_buf));
- write_boz (dtp, f, p, n);
+ write_boz (dtp, f, p, n, len);
}
}
if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{
p = otoa_big (source, itoa_buf, len, &n);
- write_boz (dtp, f, p, n);
+ write_boz (dtp, f, p, n, len);
}
else
{
n = extract_uint (source, len);
p = otoa (n, itoa_buf, sizeof (itoa_buf));
- write_boz (dtp, f, p, n);
+ write_boz (dtp, f, p, n, len);
}
}
if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{
- p = ztoa_big (source, itoa_buf, len, &n);
- write_boz (dtp, f, p, n);
+ p = xtoa_big (source, itoa_buf, len, &n);
+ write_boz (dtp, f, p, n, len);
}
else
{
n = extract_uint (source, len);
- p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
- write_boz (dtp, f, p, n);
+ p = xtoa (n, itoa_buf, sizeof (itoa_buf));
+ write_boz (dtp, f, p, n, len);
}
}
/* Write a list-directed integer value. */
static void
-write_integer (st_parameter_dt *dtp, const char *source, int length)
+write_integer (st_parameter_dt *dtp, const char *source, int kind)
{
- char *p;
- const char *q;
- int digits;
int width;
- char itoa_buf[GFC_ITOA_BUF_SIZE];
-
- q = gfc_itoa (extract_int (source, length), itoa_buf, sizeof (itoa_buf));
+ fnode f;
- switch (length)
+ switch (kind)
{
case 1:
width = 4;
width = 20;
break;
+ case 16:
+ width = 40;
+ break;
+
default:
width = 0;
break;
}
-
- digits = strlen (q);
-
- if (width < digits)
- width = digits;
- p = write_block (dtp, width);
- if (p == NULL)
- return;
-
- if (unlikely (is_char4_unit (dtp)))
- {
- gfc_char4_t *p4 = (gfc_char4_t *) p;
- if (dtp->u.p.no_leading_blank)
- {
- memcpy4 (p4, q, digits);
- memset4 (p4 + digits, ' ', width - digits);
- }
- else
- {
- memset4 (p4, ' ', width - digits);
- memcpy4 (p4 + width - digits, q, digits);
- }
- return;
- }
-
- if (dtp->u.p.no_leading_blank)
- {
- memcpy (p, q, digits);
- memset (p + digits, ' ', width - digits);
- }
- else
- {
- memset (p, ' ', width - digits);
- memcpy (p + width - digits, q, digits);
- }
+ f.u.integer.w = width;
+ f.u.integer.m = -1;
+ f.format = FMT_NONE;
+ write_decimal (dtp, &f, source, kind);
}
#define NODELIM 0
static void
-write_character (st_parameter_dt *dtp, const char *source, int kind, int length, int mode)
+write_character (st_parameter_dt *dtp, const char *source, int kind, size_t length, int mode)
{
- int i, extra;
+ size_t extra;
char *p, d;
if (mode == DELIM)
{
extra = 2;
- for (i = 0; i < length; i++)
+ for (size_t i = 0; i < length; i++)
if (source[i] == d)
extra++;
}
{
*p4++ = d4;
- for (i = 0; i < length; i++)
+ for (size_t i = 0; i < length; i++)
{
*p4++ = (gfc_char4_t) source[i];
if (source[i] == d)
{
*p++ = d;
- for (i = 0; i < length; i++)
+ for (size_t i = 0; i < length; i++)
{
*p++ = source[i];
if (source[i] == d)
/* Floating point helper functions. */
-#define BUF_STACK_SZ 256
+#define BUF_STACK_SZ 384
static int
get_precision (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
{
int size;
- if (f->format == FMT_F && f->u.real.w == 0)
+ if ((f->format == FMT_F && f->u.real.w == 0) || f->u.real.w == DEFAULT_WIDTH)
{
switch (kind)
{
size = 4932 + 3;
break;
case 16:
+#ifdef HAVE_GFC_REAL_17
+ case 17:
+#endif
size = 4932 + 3;
break;
default:
{
char *result;
- /* The buffer needs at least one more byte to allow room for normalizing. */
- *size = size_from_kind (dtp, f, kind) + precision + 1;
+ /* The buffer needs at least one more byte to allow room for
+ normalizing and 1 to hold null terminator. */
+ *size = size_from_kind (dtp, f, kind) + precision + 1 + 1;
if (*size > BUF_STACK_SZ)
result = xmalloc (*size);
char buf_stack[BUF_STACK_SZ];
char str_buf[BUF_STACK_SZ];
char *buffer, *result;
- size_t buf_size, res_len;
+ size_t buf_size, res_len, flt_str_len;
/* Precision for snprintf call. */
int precision = get_precision (dtp, f, source, kind);
/* String buffer to hold final result. */
result = select_string (dtp, f, str_buf, &res_len, kind);
-
+
buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind);
-
+
get_float_string (dtp, f, source , kind, 0, buffer,
- precision, buf_size, result, &res_len);
- write_float_string (dtp, result, res_len);
+ precision, buf_size, result, &flt_str_len);
+ write_float_string (dtp, result, flt_str_len);
if (buf_size > BUF_STACK_SZ)
free (buffer);
f->u.real.e = 4;
#endif
break;
+#ifdef HAVE_GFC_REAL_17
+ case 17:
+ f->u.real.w = 45;
+ f->u.real.d = 36;
+ f->u.real.e = 4;
+ break;
+#endif
default:
internal_error (&dtp->common, "bad real kind");
break;
char buf_stack[BUF_STACK_SZ];
char str_buf[BUF_STACK_SZ];
char *buffer, *result;
- size_t buf_size, res_len;
+ size_t buf_size, res_len, flt_str_len;
int orig_scale = dtp->u.p.scale_factor;
dtp->u.p.scale_factor = 1;
set_fnode_default (dtp, &f, kind);
buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
get_float_string (dtp, &f, source , kind, 1, buffer,
- precision, buf_size, result, &res_len);
- write_float_string (dtp, result, res_len);
+ precision, buf_size, result, &flt_str_len);
+ write_float_string (dtp, result, flt_str_len);
dtp->u.p.scale_factor = orig_scale;
if (buf_size > BUF_STACK_SZ)
compensate for the extra digit. */
void
-write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
+write_real_w0 (st_parameter_dt *dtp, const char *source, int kind,
+ const fnode* f)
{
- fnode f;
+ fnode ff;
char buf_stack[BUF_STACK_SZ];
char str_buf[BUF_STACK_SZ];
char *buffer, *result;
- size_t buf_size, res_len;
- int comp_d;
- set_fnode_default (dtp, &f, kind);
+ size_t buf_size, res_len, flt_str_len;
+ int comp_d = 0;
- if (d > 0)
- f.u.real.d = d;
+ set_fnode_default (dtp, &ff, kind);
+
+ if (f->u.real.d > 0)
+ ff.u.real.d = f->u.real.d;
+ ff.format = f->format;
+
+ /* For FMT_G, Compensate for extra digits when using scale factor, d
+ is not specified, and the magnitude is such that E editing
+ is used. */
+ if (f->format == FMT_G)
+ {
+ if (dtp->u.p.scale_factor > 0 && f->u.real.d == 0)
+ comp_d = 1;
+ else
+ comp_d = 0;
+ }
+
+ if (f->u.real.e >= 0)
+ ff.u.real.e = f->u.real.e;
- /* Compensate for extra digits when using scale factor, d is not
- specified, and the magnitude is such that E editing is used. */
- if (dtp->u.p.scale_factor > 0 && d == 0)
- comp_d = 1;
- else
- comp_d = 0;
dtp->u.p.g0_no_blanks = 1;
/* Precision for snprintf call. */
- int precision = get_precision (dtp, &f, source, kind);
+ int precision = get_precision (dtp, &ff, source, kind);
/* String buffer to hold final result. */
- result = select_string (dtp, &f, str_buf, &res_len, kind);
+ result = select_string (dtp, &ff, str_buf, &res_len, kind);
- buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
+ buffer = select_buffer (dtp, &ff, precision, buf_stack, &buf_size, kind);
- get_float_string (dtp, &f, source , kind, comp_d, buffer,
- precision, buf_size, result, &res_len);
- write_float_string (dtp, result, res_len);
+ get_float_string (dtp, &ff, source , kind, comp_d, buffer,
+ precision, buf_size, result, &flt_str_len);
+ write_float_string (dtp, result, flt_str_len);
dtp->u.p.g0_no_blanks = 0;
if (buf_size > BUF_STACK_SZ)
char str1_buf[BUF_STACK_SZ];
char str2_buf[BUF_STACK_SZ];
char *buffer, *result1, *result2;
- size_t buf_size, res_len1, res_len2;
+ size_t buf_size, res_len1, res_len2, flt_str_len1, flt_str_len2;
int width, lblanks, orig_scale = dtp->u.p.scale_factor;
dtp->u.p.scale_factor = 1;
buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
get_float_string (dtp, &f, source , kind, 0, buffer,
- precision, buf_size, result1, &res_len1);
+ precision, buf_size, result1, &flt_str_len1);
get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
- precision, buf_size, result2, &res_len2);
- lblanks = width - res_len1 - res_len2 - 3;
-
- write_x (dtp, lblanks, lblanks);
+ precision, buf_size, result2, &flt_str_len2);
+ if (!dtp->u.p.namelist_mode)
+ {
+ lblanks = width - flt_str_len1 - flt_str_len2 - 3;
+ write_x (dtp, lblanks, lblanks);
+ }
write_char (dtp, '(');
- write_float_string (dtp, result1, res_len1);
+ write_float_string (dtp, result1, flt_str_len1);
write_char (dtp, semi_comma);
- write_float_string (dtp, result2, res_len2);
+ write_float_string (dtp, result2, flt_str_len2);
write_char (dtp, ')');
dtp->u.p.scale_factor = orig_scale;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
- gfc_array_i4 vlist;
+ gfc_full_array_i4 vlist;
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
base_name_len = strlen (base_name);
for (dim_i = 0; dim_i < base_name_len; dim_i++)
{
- cup = toupper ((int) base_name[dim_i]);
+ cup = safe_toupper (base_name[dim_i]);
write_character (dtp, &cup, 1, 1, NODELIM);
}
}
clen = strlen (obj->var_name);
for (dim_i = len; dim_i < clen; dim_i++)
{
- cup = toupper ((int) obj->var_name[dim_i]);
+ cup = safe_toupper (obj->var_name[dim_i]);
if (cup == '+')
cup = '%';
write_character (dtp, &cup, 1, 1, NODELIM);
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
- gfc_array_i4 vlist;
+ gfc_full_array_i4 vlist;
formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
dtp->u.p.current_unit->child_dtio++;
if (obj->type == BT_DERIVED)
{
- // build a class container
+ /* Build a class container. */
gfc_class list_obj;
list_obj.data = p;
list_obj.vptr = obj->vtable;
namelist_write (st_parameter_dt *dtp)
{
namelist_info *t1, *t2, *dummy = NULL;
- index_type i;
index_type dummy_offset = 0;
char c;
char *dummy_name = NULL;
write_character (dtp, "&", 1, 1, NODELIM);
/* Write namelist name in upper case - f95 std. */
- for (i = 0 ;i < dtp->namelist_name_len ;i++ )
+ for (gfc_charlen_type i = 0; i < dtp->namelist_name_len; i++ )
{
- c = toupper ((int) dtp->namelist_name[i]);
+ c = safe_toupper (dtp->namelist_name[i]);
write_character (dtp, &c, 1 ,1, NODELIM);
}
projects / thirdparty / gcc.git / blobdiff