void
write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
{
char *p;
int wlen;
GFC_INTEGER_LARGEST n;
wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
p = write_block (dtp, wlen);
if (p == NULL)
return;
n = extract_int (source, len);
if (unlikely (is_char4_unit (dtp)))
{
gfc_char4_t *p4 = (gfc_char4_t *) p;
memset4 (p4, ' ', wlen -1);
p4[wlen - 1] = (n) ? 'T' : 'F';
return;
}
memset (p, ' ', wlen -1);
p[wlen - 1] = (n) ? 'T' : 'F';
}
static void
read_default_char4 (st_parameter_dt *dtp, char *p, int len, int width)
{
int m, n;
gfc_char4_t *dest;
if (is_char4_unit(dtp))
{
gfc_char4_t *s4;
s4 = (gfc_char4_t *) read_block_form4 (dtp, &width);
if (s4 == NULL)
return;
if (width > len)
s4 += (width - len);
m = ((int) width > len) ? len : (int) width;
dest = (gfc_char4_t *) p;
for (n = 0; n < m; n++)
*dest++ = *s4++;
for (n = 0; n < len - (int) width; n++)
*dest++ = (gfc_char4_t) ' ';
}
else
{
char *s;
s = read_block_form (dtp, &width);
if (s == NULL)
return;
if (width > len)
s += (width - len);
m = ((int) width > len) ? len : (int) width;
dest = (gfc_char4_t *) p;
for (n = 0; n < m; n++, dest++, s++)
*dest = (unsigned char ) *s;
for (n = 0; n < len - (int) width; n++, dest++)
*dest = (unsigned char) ' ';
}
}
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))
{
GFC_INTEGER_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_int (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;
}
sign = calculate_sign (dtp, n < 0);
if (n < 0)
n = -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++;
digits = strlen (q);
/* Select a width if none was specified. The idea here is to always
print something. */
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;
}
memset4 (p4, ' ', nblank);
p4 += nblank;
switch (sign)
{
case S_PLUS:
*p4++ = '+';
break;
case S_MINUS:
*p4++ = '-';
break;
case S_NONE:
break;
}
memset4 (p4, '0', nzero);
p4 += nzero;
memcpy4 (p4, q, digits);
return;
}
if (nblank < 0)
{
star_fill (p, w);
goto done;
}
memset (p, ' ', nblank);
p += nblank;
switch (sign)
{
case S_PLUS:
*p++ = '+';
break;
case S_MINUS:
*p++ = '-';
break;
case S_NONE:
break;
}
memset (p, '0', nzero);
p += nzero;
memcpy (p, q, digits);
done:
return;
}
static void
write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
int src_len, int w_len)
{
char *p;
int j, k = 0;
gfc_char4_t c;
uchar d;
/* Take care of preceding blanks. */
if (w_len > src_len)
{
k = w_len - src_len;
p = write_block (dtp, k);
if (p == NULL)
return;
if (is_char4_unit (dtp))
{
gfc_char4_t *p4 = (gfc_char4_t *) p;
memset4 (p4, ' ', k);
}
else
memset (p, ' ', k);
}
/* Get ready to handle delimiters if needed. */
switch (dtp->u.p.current_unit->delim_status)
{
case DELIM_APOSTROPHE:
d = '\'';
break;
case DELIM_QUOTE:
d = '"';
break;
default:
d = ' ';
break;
}
/* Now process the remaining characters, one at a time. */
for (j = 0; j < src_len; j++)
{
c = source[j];
if (is_char4_unit (dtp))
{
gfc_char4_t *q;
/* Handle delimiters if any. */
if (c == d && d != ' ')
{
p = write_block (dtp, 2);
if (p == NULL)
return;
q = (gfc_char4_t *) p;
*q++ = c;
}
else
{
p = write_block (dtp, 1);
if (p == NULL)
return;
q = (gfc_char4_t *) p;
}
*q = c;
}
else
{
/* Handle delimiters if any. */
if (c == d && d != ' ')
{
p = write_block (dtp, 2);
if (p == NULL)
return;
*p++ = (uchar) c;
}
else
{
p = write_block (dtp, 1);
if (p == NULL)
return;
}
*p = c > 255 ? '?' : (uchar) c;
}
}
}
static void
write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
{
int w, m, digits, nzero, nblank;
char *p;
w = f->u.integer.w;
m = f->u.integer.m;
/* 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;
}
digits = strlen (q);
/* Select a width if none was specified. The idea here is to always
print something. */
if (w == 0)
w = ((digits < m) ? m : digits);
p = write_block (dtp, w);
if (p == NULL)
return;
nzero = 0;
if (digits < m)
nzero = m - digits;
/* See if things will work. */
nblank = w - (nzero + digits);
if (unlikely (is_char4_unit (dtp)))
{
gfc_char4_t *p4 = (gfc_char4_t *) p;
if (nblank < 0)
{
memset4 (p4, '*', w);
return;
}
if (!dtp->u.p.no_leading_blank)
{
memset4 (p4, ' ', nblank);
q += nblank;
memset4 (p4, '0', nzero);
q += nzero;
memcpy4 (p4, q, digits);
}
else
{
memset4 (p4, '0', nzero);
q += nzero;
memcpy4 (p4, q, digits);
q += digits;
memset4 (p4, ' ', nblank);
dtp->u.p.no_leading_blank = 0;
}
return;
}
if (nblank < 0)
{
star_fill (p, w);
goto done;
}
if (!dtp->u.p.no_leading_blank)
{
memset (p, ' ', nblank);
p += nblank;
memset (p, '0', nzero);
p += nzero;
memcpy (p, q, digits);
}
else
{
memset (p, '0', nzero);
p += nzero;
memcpy (p, q, digits);
p += digits;
memset (p, ' ', nblank);
dtp->u.p.no_leading_blank = 0;
}
done:
return;
}
void
write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
{
int wlen;
char *p;
wlen = f->u.string.length < 0
|| (f->format == FMT_G && f->u.string.length == 0)
? len : f->u.string.length;
#ifdef HAVE_CRLF
/* If this is formatted STREAM IO convert any embedded line feed characters
to CR_LF on systems that use that sequence for newlines. See F2003
Standard sections 10.6.3 and 9.9 for further information. */
if (is_stream_io (dtp))
{
const char crlf[] = "\r\n";
int i, q, bytes;
q = bytes = 0;
/* Write out any padding if needed. */
if (len < wlen)
{
p = write_block (dtp, wlen - len);
if (p == NULL)
return;
memset (p, ' ', wlen - len);
}
/* Scan the source string looking for '\n' and convert it if found. */
for (i = 0; i < wlen; i++)
{
if (source[i] == '\n')
{
/* Write out the previously scanned characters in the string. */
if (bytes > 0)
{
p = write_block (dtp, bytes);
if (p == NULL)
return;
memcpy (p, &source[q], bytes);
q += bytes;
bytes = 0;
}
/* Write out the CR_LF sequence. */
q++;
p = write_block (dtp, 2);
if (p == NULL)
return;
memcpy (p, crlf, 2);
}
else
bytes++;
}
/* Write out any remaining bytes if no LF was found. */
if (bytes > 0)
{
p = write_block (dtp, bytes);
if (p == NULL)
return;
memcpy (p, &source[q], bytes);
}
}
else
{
#endif
p = write_block (dtp, wlen);
if (p == NULL)
return;
if (unlikely (is_char4_unit (dtp)))
{
gfc_char4_t *p4 = (gfc_char4_t *) p;
if (wlen < len)
memcpy4 (p4, source, wlen);
else
{
memset4 (p4, ' ', wlen - len);
memcpy4 (p4 + wlen - len, source, len);
}
return;
}
if (wlen < len)
memcpy (p, source, wlen);
else
{
memset (p, ' ', wlen - len);
memcpy (p + wlen - len, source, len);
}
#ifdef HAVE_CRLF
}
#endif
}
