-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 2002-2018 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist output contributed by Paul Thomas
+ F2003 I/O support contributed by Jerry DeLisle
-This file is part of the GNU Fortran 95 runtime library (libgfortran).
+This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
any later version.
-In addition to the permissions in the GNU General Public License, the
-Free Software Foundation gives you unlimited permission to link the
-compiled version of this file into combinations with other programs,
-and to distribute those combinations without any restriction coming
-from the use of this file. (The General Public License restrictions
-do apply in other respects; for example, they cover modification of
-the file, and distribution when not linked into a combine
-executable.)
-
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
-You should have received a copy of the GNU General Public License
-along with Libgfortran; see the file COPYING. If not, write to
-the Free Software Foundation, 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA. */
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
-#include "config.h"
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
#include <assert.h>
#include <string.h>
#include <ctype.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include "libgfortran.h"
-#include "io.h"
#define star_fill(p, n) memset(p, '*', n)
+typedef unsigned char uchar;
+
+/* Helper functions for character(kind=4) internal units. These are needed
+ by write_float.def. */
+
+static void
+memcpy4 (gfc_char4_t *dest, const char *source, int k)
+{
+ int j;
+
+ const char *p = source;
+ for (j = 0; j < k; j++)
+ *dest++ = (gfc_char4_t) *p++;
+}
+
+/* This include contains the heart and soul of formatted floating point. */
+#include "write_float.def"
+
+/* Write out default char4. */
+
+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;
+ }
+ }
+}
+
+
+/* Write out UTF-8 converted from char4. */
+
+static void
+write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
+ int src_len, int w_len)
+{
+ char *p;
+ int j, k = 0;
+ gfc_char4_t c;
+ static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
+ static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
+ int nbytes;
+ uchar buf[6], d, *q;
+
+ /* Take care of preceding blanks. */
+ if (w_len > src_len)
+ {
+ k = w_len - src_len;
+ p = write_block (dtp, k);
+ if (p == NULL)
+ return;
+ 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 = k; j < src_len; j++)
+ {
+ c = source[j];
+ if (c < 0x80)
+ {
+ /* Handle the 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 = (uchar) c;
+ }
+ else
+ {
+ /* Convert to UTF-8 sequence. */
+ nbytes = 1;
+ q = &buf[6];
+
+ do
+ {
+ *--q = ((c & 0x3F) | 0x80);
+ c >>= 6;
+ nbytes++;
+ }
+ while (c >= 0x3F || (c & limits[nbytes-1]));
+
+ *--q = (c | masks[nbytes-1]);
+
+ p = write_block (dtp, nbytes);
+ if (p == NULL)
+ return;
+
+ while (q < &buf[6])
+ *p++ = *q++;
+ }
+ }
+}
+
+
+/* Check the first character in source if we are using CC_FORTRAN
+ and set the cc.type appropriately. The cc.type is used later by write_cc
+ to determine the output start-of-record, and next_record_cc to determine the
+ output end-of-record.
+ This function is called before the output buffer is allocated, so alloc_len
+ is set to the appropriate size to allocate. */
+
+static void
+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
+ || alloc_len == NULL || source == NULL)
+ return;
+
+ /* Peek at the first character. */
+ int c = (*alloc_len > 0) ? (*source)[0] : EOF;
+ if (c != EOF)
+ {
+ /* The start-of-record character which will be printed. */
+ dtp->u.p.cc.u.start = '\n';
+ /* The number of characters to print at the start-of-record.
+ len > 1 means copy the SOR character multiple times.
+ len == 0 means no SOR will be output. */
+ dtp->u.p.cc.len = 1;
+
+ switch (c)
+ {
+ case '+':
+ dtp->u.p.cc.type = CCF_OVERPRINT;
+ dtp->u.p.cc.len = 0;
+ break;
+ case '-':
+ dtp->u.p.cc.type = CCF_ONE_LF;
+ dtp->u.p.cc.len = 1;
+ break;
+ case '0':
+ dtp->u.p.cc.type = CCF_TWO_LF;
+ dtp->u.p.cc.len = 2;
+ break;
+ case '1':
+ dtp->u.p.cc.type = CCF_PAGE_FEED;
+ dtp->u.p.cc.len = 1;
+ dtp->u.p.cc.u.start = '\f';
+ break;
+ case '$':
+ dtp->u.p.cc.type = CCF_PROMPT;
+ dtp->u.p.cc.len = 1;
+ break;
+ case '\0':
+ dtp->u.p.cc.type = CCF_OVERPRINT_NOA;
+ dtp->u.p.cc.len = 0;
+ break;
+ default:
+ /* In the default case we copy ONE_LF. */
+ dtp->u.p.cc.type = CCF_DEFAULT;
+ dtp->u.p.cc.len = 1;
+ break;
+ }
+
+ /* We add n-1 to alloc_len so our write buffer is the right size.
+ We are replacing the first character, and possibly prepending some
+ additional characters. Note for n==0, we actually subtract one from
+ alloc_len, which is correct, since that character is skipped. */
+ if (*alloc_len > 0)
+ {
+ *source += 1;
+ *alloc_len += dtp->u.p.cc.len - 1;
+ }
+ /* If we have no input, there is no first character to replace. Make
+ sure we still allocate enough space for the start-of-record string. */
+ else
+ *alloc_len = dtp->u.p.cc.len;
+ }
+}
+
+
+/* Write the start-of-record character(s) for CC_FORTRAN.
+ Also adjusts the 'cc' struct to contain the end-of-record character
+ for next_record_cc.
+ The source_len is set to the remaining length to copy from the source,
+ after the start-of-record string was inserted. */
+
+static char *
+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)
+ return p;
+
+ /* Write the start-of-record string to the output buffer. Note that len is
+ never more than 2. */
+ if (dtp->u.p.cc.len > 0)
+ {
+ *(p++) = dtp->u.p.cc.u.start;
+ if (dtp->u.p.cc.len > 1)
+ *(p++) = dtp->u.p.cc.u.start;
+
+ /* source_len comes from write_check_cc where it is set to the full
+ allocated length of the output buffer. Therefore we subtract off the
+ length of the SOR string to obtain the remaining source length. */
+ *source_len -= dtp->u.p.cc.len;
+ }
-typedef enum
-{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
-sign_t;
+ /* Common case. */
+ dtp->u.p.cc.len = 1;
+ dtp->u.p.cc.u.end = '\r';
+
+ /* Update end-of-record character for next_record_w. */
+ switch (dtp->u.p.cc.type)
+ {
+ case CCF_PROMPT:
+ case CCF_OVERPRINT_NOA:
+ /* No end-of-record. */
+ dtp->u.p.cc.len = 0;
+ dtp->u.p.cc.u.end = '\0';
+ break;
+ case CCF_OVERPRINT:
+ case CCF_ONE_LF:
+ case CCF_TWO_LF:
+ case CCF_PAGE_FEED:
+ case CCF_DEFAULT:
+ default:
+ /* Carriage return. */
+ dtp->u.p.cc.len = 1;
+ dtp->u.p.cc.u.end = '\r';
+ break;
+ }
+ return p;
+}
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 ? len : f->u.string.length;
+ wlen = f->u.string.length < 0
+ || (f->format == FMT_G && f->u.string.length == 0)
+ ? 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')
{
bytes = 0;
}
- /* Write out the CR_LF sequence. */
+ /* Write out the CR_LF sequence. */
q++;
p = write_block (dtp, 2);
if (p == NULL)
else
{
#endif
+ if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
+ write_check_cc (dtp, &source, &wlen);
+
p = write_block (dtp, wlen);
if (p == NULL)
return;
+ if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
+ p = write_cc (dtp, p, &wlen);
+
+ 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
#endif
}
+
+/* The primary difference between write_a_char4 and write_a is that we have to
+ deal with writing from the first byte of the 4-byte character and pay
+ attention to the most significant bytes. For ENCODING="default" write the
+ lowest significant byte. If the 3 most significant bytes contain
+ non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
+ to the UTF-8 encoded string before writing out. */
+
+void
+write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
+{
+ size_t wlen;
+ gfc_char4_t *q;
+
+ wlen = f->u.string.length < 0
+ || (f->format == FMT_G && f->u.string.length == 0)
+ ? len : (size_t) f->u.string.length;
+
+ q = (gfc_char4_t *) source;
+#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 gfc_char4_t crlf[] = {0x000d,0x000a};
+ size_t bytes;
+ gfc_char4_t *qq;
+ bytes = 0;
+
+ /* Write out any padding if needed. */
+ if (len < wlen)
+ {
+ char *p;
+ 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. */
+ qq = (gfc_char4_t *) source;
+ for (size_t i = 0; i < wlen; i++)
+ {
+ if (qq[i] == '\n')
+ {
+ /* Write out the previously scanned characters in the string. */
+ if (bytes > 0)
+ {
+ if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+ write_utf8_char4 (dtp, q, bytes, 0);
+ else
+ write_default_char4 (dtp, q, bytes, 0);
+ bytes = 0;
+ }
+
+ /* Write out the CR_LF sequence. */
+ write_default_char4 (dtp, crlf, 2, 0);
+ }
+ else
+ bytes++;
+ }
+
+ /* Write out any remaining bytes if no LF was found. */
+ if (bytes > 0)
+ {
+ if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+ write_utf8_char4 (dtp, q, bytes, 0);
+ else
+ write_default_char4 (dtp, q, bytes, 0);
+ }
+ }
+ else
+ {
+#endif
+ if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+ write_utf8_char4 (dtp, q, len, wlen);
+ else
+ write_default_char4 (dtp, q, len, wlen);
+#ifdef HAVE_CRLF
+ }
+#endif
+}
+
+
static GFC_INTEGER_LARGEST
extract_int (const void *p, int len)
{
}
break;
#ifdef HAVE_GFC_INTEGER_16
+ case 10:
case 16:
{
- GFC_INTEGER_16 tmp;
+ GFC_INTEGER_16 tmp = 0;
memcpy ((void *) &tmp, p, len);
i = (GFC_UINTEGER_16) tmp;
}
return i;
}
-static GFC_REAL_LARGEST
-extract_real (const void *p, int len)
+
+void
+write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
{
- GFC_REAL_LARGEST i = 0;
- switch (len)
- {
- case 4:
- {
- GFC_REAL_4 tmp;
- memcpy ((void *) &tmp, p, len);
- i = tmp;
- }
- break;
- case 8:
- {
- GFC_REAL_8 tmp;
- memcpy ((void *) &tmp, p, len);
- i = tmp;
- }
- break;
-#ifdef HAVE_GFC_REAL_10
- case 10:
- {
- GFC_REAL_10 tmp;
- memcpy ((void *) &tmp, p, len);
- i = tmp;
- }
- break;
-#endif
-#ifdef HAVE_GFC_REAL_16
- case 16:
- {
- GFC_REAL_16 tmp;
- memcpy ((void *) &tmp, p, len);
- i = tmp;
- }
- break;
-#endif
- default:
- internal_error (NULL, "bad real kind");
- }
- return i;
-}
+ char *p;
+ int wlen;
+ GFC_INTEGER_LARGEST n;
+ wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
-/* Given a flag that indicate if a value is negative or not, return a
- sign_t that gives the sign that we need to produce. */
+ p = write_block (dtp, wlen);
+ if (p == NULL)
+ return;
-static sign_t
-calculate_sign (st_parameter_dt *dtp, int negative_flag)
-{
- sign_t s = SIGN_NONE;
+ n = extract_int (source, len);
- if (negative_flag)
- s = SIGN_MINUS;
- else
- switch (dtp->u.p.sign_status)
- {
- case SIGN_SP:
- s = SIGN_PLUS;
- break;
- case SIGN_SS:
- s = SIGN_NONE;
- break;
- case SIGN_S:
- s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
- break;
- }
+ 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;
+ }
- return s;
+ memset (p, ' ', wlen -1);
+ p[wlen - 1] = (n) ? 'T' : 'F';
}
-/* Returns the value of 10**d. */
-
-static GFC_REAL_LARGEST
-calculate_exp (int d)
+static void
+write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
{
- int i;
- GFC_REAL_LARGEST r = 1.0;
+ int w, m, digits, nzero, nblank;
+ char *p;
- for (i = 0; i< (d >= 0 ? d : -d); i++)
- r *= 10;
-
- r = (d >= 0) ? r : 1.0 / r;
-
- return r;
-}
-
-
-/* Generate corresponding I/O format for FMT_G output.
- The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
- LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
-
- Data Magnitude Equivalent Conversion
- 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
- m = 0 F(w-n).(d-1), n' '
- 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
- 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
- 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
- ................ ..........
- 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
- m >= 10**d-0.5 Ew.d[Ee]
-
- notes: for Gw.d , n' ' means 4 blanks
- for Gw.dEe, n' ' means e+2 blanks */
-
-static fnode *
-calculate_G_format (st_parameter_dt *dtp, const fnode *f,
- GFC_REAL_LARGEST value, int *num_blank)
-{
- int e = f->u.real.e;
- int d = f->u.real.d;
- int w = f->u.real.w;
- fnode *newf;
- GFC_REAL_LARGEST m, exp_d;
- int low, high, mid;
- int ubound, lbound;
-
- newf = get_mem (sizeof (fnode));
-
- /* Absolute value. */
- m = (value > 0.0) ? value : -value;
-
- /* In case of the two data magnitude ranges,
- generate E editing, Ew.d[Ee]. */
- exp_d = calculate_exp (d);
- if ((m > 0.0 && m < 0.1 - 0.05 / exp_d) || (m >= exp_d - 0.5 ) ||
- ((m == 0.0) && !(compile_options.allow_std & GFC_STD_F2003)))
- {
- newf->format = FMT_E;
- newf->u.real.w = w;
- newf->u.real.d = d;
- newf->u.real.e = e;
- *num_blank = 0;
- return newf;
- }
-
- /* Use binary search to find the data magnitude range. */
- mid = 0;
- low = 0;
- high = d + 1;
- lbound = 0;
- ubound = d + 1;
-
- while (low <= high)
- {
- GFC_REAL_LARGEST temp;
- mid = (low + high) / 2;
-
- /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
- temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
-
- if (m < temp)
- {
- ubound = mid;
- if (ubound == lbound + 1)
- break;
- high = mid - 1;
- }
- else if (m > temp)
- {
- lbound = mid;
- if (ubound == lbound + 1)
- {
- mid ++;
- break;
- }
- low = mid + 1;
- }
- else
- break;
- }
-
- /* Pad with blanks where the exponent would be. */
- if (e < 0)
- *num_blank = 4;
- else
- *num_blank = e + 2;
-
- /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
- newf->format = FMT_F;
- newf->u.real.w = f->u.real.w - *num_blank;
-
- /* Special case. */
- if (m == 0.0)
- newf->u.real.d = d - 1;
- else
- newf->u.real.d = - (mid - d - 1);
-
- /* For F editing, the scale factor is ignored. */
- dtp->u.p.scale_factor = 0;
- return newf;
-}
-
-
-/* Output a real number according to its format which is FMT_G free. */
-
-static void
-output_float (st_parameter_dt *dtp, const fnode *f, GFC_REAL_LARGEST value)
-{
-#if defined(HAVE_GFC_REAL_16) && __LDBL_DIG__ > 18
-# define MIN_FIELD_WIDTH 46
-#else
-# define MIN_FIELD_WIDTH 31
-#endif
-#define STR(x) STR1(x)
-#define STR1(x) #x
- /* This must be large enough to accurately hold any value. */
- char buffer[MIN_FIELD_WIDTH+1];
- char *out;
- char *digits;
- int e;
- char expchar;
- format_token ft;
- int w;
- int d;
- int edigits;
- int ndigits;
- /* Number of digits before the decimal point. */
- int nbefore;
- /* Number of zeros after the decimal point. */
- int nzero;
- /* Number of digits after the decimal point. */
- int nafter;
- /* Number of zeros after the decimal point, whatever the precision. */
- int nzero_real;
- int leadzero;
- int nblanks;
- int i;
- sign_t sign;
-
- ft = f->format;
- w = f->u.real.w;
- d = f->u.real.d;
-
- nzero_real = -1;
-
-
- /* We should always know the field width and precision. */
- if (d < 0)
- internal_error (&dtp->common, "Unspecified precision");
-
- /* Use sprintf to print the number in the format +D.DDDDe+ddd
- For an N digit exponent, this gives us (MIN_FIELD_WIDTH-5)-N digits
- after the decimal point, plus another one before the decimal point. */
- sign = calculate_sign (dtp, value < 0.0);
- if (value < 0)
- value = -value;
-
- /* Special case when format specifies no digits after the decimal point. */
- if (d == 0 && ft == FMT_F)
- {
- if (value < 0.5)
- value = 0.0;
- else if (value < 1.0)
- value = value + 0.5;
- }
-
- /* printf pads blanks for us on the exponent so we just need it big enough
- to handle the largest number of exponent digits expected. */
- edigits=4;
-
- if (ft == FMT_F || ft == FMT_EN
- || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0))
- {
- /* Always convert at full precision to avoid double rounding. */
- ndigits = MIN_FIELD_WIDTH - 4 - edigits;
- }
- else
- {
- /* We know the number of digits, so can let printf do the rounding
- for us. */
- if (ft == FMT_ES)
- ndigits = d + 1;
- else
- ndigits = d;
- if (ndigits > MIN_FIELD_WIDTH - 4 - edigits)
- ndigits = MIN_FIELD_WIDTH - 4 - edigits;
- }
-
- /* # The result will always contain a decimal point, even if no
- * digits follow it
- *
- * - The converted value is to be left adjusted on the field boundary
- *
- * + A sign (+ or -) always be placed before a number
- *
- * MIN_FIELD_WIDTH minimum field width
- *
- * * (ndigits-1) is used as the precision
- *
- * e format: [-]d.ddde±dd where there is one digit before the
- * decimal-point character and the number of digits after it is
- * equal to the precision. The exponent always contains at least two
- * digits; if the value is zero, the exponent is 00.
- */
-#ifdef HAVE_SNPRINTF
- snprintf (buffer, sizeof (buffer), "%+-#" STR(MIN_FIELD_WIDTH) ".*"
- GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value);
-#else
- sprintf (buffer, "%+-#" STR(MIN_FIELD_WIDTH) ".*"
- GFC_REAL_LARGEST_FORMAT "e", ndigits - 1, value);
-#endif
-
- /* Check the resulting string has punctuation in the correct places. */
- if (d != 0 && (buffer[2] != '.' || buffer[ndigits + 2] != 'e'))
- internal_error (&dtp->common, "printf is broken");
-
- /* Read the exponent back in. */
- e = atoi (&buffer[ndigits + 3]) + 1;
-
- /* Make sure zero comes out as 0.0e0. */
- if (value == 0.0)
- e = 0;
-
- /* Normalize the fractional component. */
- buffer[2] = buffer[1];
- digits = &buffer[2];
-
- /* Figure out where to place the decimal point. */
- switch (ft)
- {
- case FMT_F:
- nbefore = e + dtp->u.p.scale_factor;
- if (nbefore < 0)
- {
- nzero = -nbefore;
- nzero_real = nzero;
- if (nzero > d)
- nzero = d;
- nafter = d - nzero;
- nbefore = 0;
- }
- else
- {
- nzero = 0;
- nafter = d;
- }
- expchar = 0;
- break;
-
- case FMT_E:
- case FMT_D:
- i = dtp->u.p.scale_factor;
- if (value != 0.0)
- e -= i;
- if (i < 0)
- {
- nbefore = 0;
- nzero = -i;
- nafter = d + i;
- }
- else if (i > 0)
- {
- nbefore = i;
- nzero = 0;
- nafter = (d - i) + 1;
- }
- else /* i == 0 */
- {
- nbefore = 0;
- nzero = 0;
- nafter = d;
- }
-
- if (ft == FMT_E)
- expchar = 'E';
- else
- expchar = 'D';
- break;
-
- case FMT_EN:
- /* The exponent must be a multiple of three, with 1-3 digits before
- the decimal point. */
- if (value != 0.0)
- e--;
- if (e >= 0)
- nbefore = e % 3;
- else
- {
- nbefore = (-e) % 3;
- if (nbefore != 0)
- nbefore = 3 - nbefore;
- }
- e -= nbefore;
- nbefore++;
- nzero = 0;
- nafter = d;
- expchar = 'E';
- break;
-
- case FMT_ES:
- if (value != 0.0)
- e--;
- nbefore = 1;
- nzero = 0;
- nafter = d;
- expchar = 'E';
- break;
-
- default:
- /* Should never happen. */
- internal_error (&dtp->common, "Unexpected format token");
- }
-
- /* Round the value. */
- if (nbefore + nafter == 0)
- {
- ndigits = 0;
- if (nzero_real == d && digits[0] >= '5')
- {
- /* We rounded to zero but shouldn't have */
- nzero--;
- nafter = 1;
- digits[0] = '1';
- ndigits = 1;
- }
- }
- else if (nbefore + nafter < ndigits)
- {
- ndigits = nbefore + nafter;
- i = ndigits;
- if (digits[i] >= '5')
- {
- /* Propagate the carry. */
- for (i--; i >= 0; i--)
- {
- if (digits[i] != '9')
- {
- digits[i]++;
- break;
- }
- digits[i] = '0';
- }
-
- if (i < 0)
- {
- /* The carry overflowed. Fortunately we have some spare space
- at the start of the buffer. We may discard some digits, but
- this is ok because we already know they are zero. */
- digits--;
- digits[0] = '1';
- if (ft == FMT_F)
- {
- if (nzero > 0)
- {
- nzero--;
- nafter++;
- }
- else
- nbefore++;
- }
- else if (ft == FMT_EN)
- {
- nbefore++;
- if (nbefore == 4)
- {
- nbefore = 1;
- e += 3;
- }
- }
- else
- e++;
- }
- }
- }
-
- /* Calculate the format of the exponent field. */
- if (expchar)
- {
- edigits = 1;
- for (i = abs (e); i >= 10; i /= 10)
- edigits++;
-
- if (f->u.real.e < 0)
- {
- /* Width not specified. Must be no more than 3 digits. */
- if (e > 999 || e < -999)
- edigits = -1;
- else
- {
- edigits = 4;
- if (e > 99 || e < -99)
- expchar = ' ';
- }
- }
- else
- {
- /* Exponent width specified, check it is wide enough. */
- if (edigits > f->u.real.e)
- edigits = -1;
- else
- edigits = f->u.real.e + 2;
- }
- }
- else
- edigits = 0;
-
- /* Pick a field size if none was specified. */
- if (w <= 0)
- w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
-
- /* Create the ouput buffer. */
- out = write_block (dtp, w);
- if (out == NULL)
- return;
-
- /* Zero values always output as positive, even if the value was negative
- before rounding. */
- for (i = 0; i < ndigits; i++)
- {
- if (digits[i] != '0')
- break;
- }
- if (i == ndigits)
- sign = calculate_sign (dtp, 0);
-
- /* Work out how much padding is needed. */
- nblanks = w - (nbefore + nzero + nafter + edigits + 1);
- if (sign != SIGN_NONE)
- nblanks--;
-
- /* Check the value fits in the specified field width. */
- if (nblanks < 0 || edigits == -1)
- {
- star_fill (out, w);
- return;
- }
-
- /* See if we have space for a zero before the decimal point. */
- if (nbefore == 0 && nblanks > 0)
- {
- leadzero = 1;
- nblanks--;
- }
- else
- leadzero = 0;
-
- /* Pad to full field width. */
-
-
- if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
- {
- memset (out, ' ', nblanks);
- out += nblanks;
- }
-
- /* Output the initial sign (if any). */
- if (sign == SIGN_PLUS)
- *(out++) = '+';
- else if (sign == SIGN_MINUS)
- *(out++) = '-';
-
- /* Output an optional leading zero. */
- if (leadzero)
- *(out++) = '0';
-
- /* Output the part before the decimal point, padding with zeros. */
- if (nbefore > 0)
- {
- if (nbefore > ndigits)
- {
- i = ndigits;
- memcpy (out, digits, i);
- ndigits = 0;
- while (i < nbefore)
- out[i++] = '0';
- }
- else
- {
- i = nbefore;
- memcpy (out, digits, i);
- ndigits -= i;
- }
-
- digits += i;
- out += nbefore;
- }
- /* Output the decimal point. */
- *(out++) = '.';
-
- /* Output leading zeros after the decimal point. */
- if (nzero > 0)
- {
- for (i = 0; i < nzero; i++)
- *(out++) = '0';
- }
-
- /* Output digits after the decimal point, padding with zeros. */
- if (nafter > 0)
- {
- if (nafter > ndigits)
- i = ndigits;
- else
- i = nafter;
-
- memcpy (out, digits, i);
- while (i < nafter)
- out[i++] = '0';
-
- digits += i;
- ndigits -= i;
- out += nafter;
- }
-
- /* Output the exponent. */
- if (expchar)
- {
- if (expchar != ' ')
- {
- *(out++) = expchar;
- edigits--;
- }
-#if HAVE_SNPRINTF
- snprintf (buffer, sizeof (buffer), "%+0*d", edigits, e);
-#else
- sprintf (buffer, "%+0*d", edigits, e);
-#endif
- memcpy (out, buffer, edigits);
- }
-
- if (dtp->u.p.no_leading_blank)
- {
- out += edigits;
- memset( out , ' ' , nblanks );
- dtp->u.p.no_leading_blank = 0;
- }
-#undef STR
-#undef STR1
-#undef MIN_FIELD_WIDTH
-}
-
-
-void
-write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
-{
- char *p;
- GFC_INTEGER_LARGEST n;
-
- p = write_block (dtp, f->u.w);
- if (p == NULL)
- return;
-
- memset (p, ' ', f->u.w - 1);
- n = extract_int (source, len);
- p[f->u.w - 1] = (n) ? 'T' : 'F';
-}
-
-/* Output a real number according to its format. */
-
-static void
-write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
-{
- GFC_REAL_LARGEST n;
- int nb =0, res, save_scale_factor;
- char * p, fin;
- fnode *f2 = NULL;
-
- n = extract_real (source, len);
-
- if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
- {
- res = isfinite (n);
- if (res == 0)
- {
- nb = f->u.real.w;
-
- /* If the field width is zero, the processor must select a width
- not zero. 4 is chosen to allow output of '-Inf' or '+Inf' */
-
- if (nb == 0) nb = 4;
- p = write_block (dtp, nb);
- if (p == NULL)
- return;
- if (nb < 3)
- {
- memset (p, '*',nb);
- return;
- }
-
- memset(p, ' ', nb);
- res = !isnan (n);
- if (res != 0)
- {
- if (signbit(n))
- {
-
- /* If the sign is negative and the width is 3, there is
- insufficient room to output '-Inf', so output asterisks */
-
- if (nb == 3)
- {
- memset (p, '*',nb);
- return;
- }
-
- /* The negative sign is mandatory */
-
- fin = '-';
- }
- else
-
- /* The positive sign is optional, but we output it for
- consistency */
-
- fin = '+';
-
- if (nb > 8)
-
- /* We have room, so output 'Infinity' */
-
- memcpy(p + nb - 8, "Infinity", 8);
- else
-
- /* For the case of width equals 8, there is not enough room
- for the sign and 'Infinity' so we go with 'Inf' */
-
- memcpy(p + nb - 3, "Inf", 3);
- if (nb < 9 && nb > 3)
- p[nb - 4] = fin; /* Put the sign in front of Inf */
- else if (nb > 8)
- p[nb - 9] = fin; /* Put the sign in front of Infinity */
- }
- else
- memcpy(p + nb - 3, "NaN", 3);
- return;
- }
- }
-
- if (f->format != FMT_G)
- output_float (dtp, f, n);
- else
- {
- save_scale_factor = dtp->u.p.scale_factor;
- f2 = calculate_G_format (dtp, f, n, &nb);
- output_float (dtp, f2, n);
- dtp->u.p.scale_factor = save_scale_factor;
- if (f2 != NULL)
- free_mem(f2);
-
- if (nb > 0)
- {
- p = write_block (dtp, nb);
- if (p == NULL)
- return;
- memset (p, ' ', nb);
- }
- }
-}
-
-
-static void
-write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
- const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
-{
- GFC_UINTEGER_LARGEST n = 0;
- int w, m, digits, nzero, nblank;
- char *p;
- const char *q;
- char itoa_buf[GFC_BTOA_BUF_SIZE];
-
- w = f->u.integer.w;
- m = f->u.integer.m;
-
- n = extract_uint (source, len);
+ w = f->u.integer.w;
+ m = f->u.integer.m;
/* Special case: */
p = write_block (dtp, w);
if (p == NULL)
return;
-
- memset (p, ' ', w);
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', w);
+ }
+ else
+ memset (p, ' ', w);
goto done;
}
- q = conv (n, itoa_buf, sizeof (itoa_buf));
digits = strlen (q);
/* Select a width if none was specified. The idea here is to always
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);
char itoa_buf[GFC_BTOA_BUF_SIZE];
w = f->u.integer.w;
- m = f->u.integer.m;
+ 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)
p = write_block (dtp, w);
if (p == NULL)
return;
-
- memset (p, ' ', w);
+ 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;
- nsign = sign == SIGN_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);
nblank = w - (nsign + nzero + digits);
- if (nblank < 0)
+ if (unlikely (is_char4_unit (dtp)))
{
- star_fill (p, w);
- goto done;
- }
+ gfc_char4_t *p4 = (gfc_char4_t *)p;
+ if (nblank < 0)
+ {
+ memset4 (p4, '*', w);
+ goto done;
+ }
- memset (p, ' ', nblank);
- p += nblank;
+ if (!dtp->u.p.namelist_mode)
+ {
+ 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 (dtp->u.p.namelist_mode)
+ {
+ p4 += digits;
+ memset4 (p4, ' ', nblank);
+ }
+ }
+
+ if (nblank < 0)
+ {
+ star_fill (p, w);
+ goto done;
+ }
+
+ if (!dtp->u.p.namelist_mode)
+ {
+ memset (p, ' ', nblank);
+ p += nblank;
+ }
switch (sign)
{
- case SIGN_PLUS:
+ case S_PLUS:
*p++ = '+';
break;
- case SIGN_MINUS:
+ case S_MINUS:
*p++ = '-';
break;
- case SIGN_NONE:
+ case S_NONE:
break;
}
memcpy (p, q, digits);
+ if (dtp->u.p.namelist_mode)
+ {
+ p += digits;
+ memset (p, ' ', nblank);
+ }
+
done:
return;
}
return p;
}
+/* The following three functions, btoa_big, otoa_big, and ztoa_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. */
+
+/* Conversion to binary. */
+
+static const char *
+btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+ char *q;
+ int i, j;
+
+ q = buffer;
+ if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
+ {
+ const char *p = s;
+ for (i = 0; i < len; i++)
+ {
+ char c = *p;
+
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ for (j = 0; j < 8; j++)
+ {
+ *q++ = (c & 128) ? '1' : '0';
+ c <<= 1;
+ }
+ p++;
+ }
+ }
+ else
+ {
+ const char *p = s + len - 1;
+ for (i = 0; i < len; i++)
+ {
+ char c = *p;
+
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ for (j = 0; j < 8; j++)
+ {
+ *q++ = (c & 128) ? '1' : '0';
+ c <<= 1;
+ }
+ p--;
+ }
+ }
+
+ *q = '\0';
+
+ if (*n == 0)
+ return "0";
+
+ /* Move past any leading zeros. */
+ while (*buffer == '0')
+ buffer++;
+
+ return buffer;
+
+}
+
+/* Conversion to octal. */
+
+static const char *
+otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
+{
+ char *q;
+ int i, j, k;
+ uint8_t octet;
+
+ q = buffer + GFC_OTOA_BUF_SIZE - 1;
+ *q = '\0';
+ i = k = octet = 0;
+
+ if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
+ {
+ const char *p = s + len - 1;
+ char c = *p;
+ while (i < len)
+ {
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ for (j = 0; j < 3 && i < len; j++)
+ {
+ octet |= (c & 1) << j;
+ c >>= 1;
+ if (++k > 7)
+ {
+ i++;
+ k = 0;
+ c = *--p;
+ }
+ }
+ *--q = '0' + octet;
+ octet = 0;
+ }
+ }
+ else
+ {
+ const char *p = s;
+ char c = *p;
+ while (i < len)
+ {
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ for (j = 0; j < 3 && i < len; j++)
+ {
+ octet |= (c & 1) << j;
+ c >>= 1;
+ if (++k > 7)
+ {
+ i++;
+ k = 0;
+ c = *++p;
+ }
+ }
+ *--q = '0' + octet;
+ octet = 0;
+ }
+ }
+
+ if (*n == 0)
+ return "0";
+
+ /* Move past any leading zeros. */
+ while (*q == '0')
+ q++;
+
+ return q;
+}
+
+/* Conversion to hexidecimal. */
+
+static const char *
+ztoa_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'};
+
+ char *q;
+ uint8_t h, l;
+ int i;
+
+ q = buffer;
+
+ if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
+ {
+ const char *p = s;
+ for (i = 0; i < len; i++)
+ {
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ h = (*p >> 4) & 0x0F;
+ l = *p++ & 0x0F;
+ *q++ = a[h];
+ *q++ = a[l];
+ }
+ }
+ else
+ {
+ const char *p = s + len - 1;
+ for (i = 0; i < len; i++)
+ {
+ /* Test for zero. Needed by write_boz later. */
+ if (*p != 0)
+ *n = 1;
+
+ h = (*p >> 4) & 0x0F;
+ l = *p-- & 0x0F;
+ *q++ = a[h];
+ *q++ = a[l];
+ }
+ }
+
+ *q = '\0';
+
+ if (*n == 0)
+ return "0";
+
+ /* Move past any leading zeros. */
+ while (*buffer == '0')
+ buffer++;
+
+ return buffer;
+}
+
void
write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
}
-void
-write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+void
+write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+ const char *p;
+ char itoa_buf[GFC_BTOA_BUF_SIZE];
+ GFC_UINTEGER_LARGEST n = 0;
+
+ if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+ {
+ p = btoa_big (source, itoa_buf, len, &n);
+ write_boz (dtp, f, p, n);
+ }
+ else
+ {
+ n = extract_uint (source, len);
+ p = btoa (n, itoa_buf, sizeof (itoa_buf));
+ write_boz (dtp, f, p, n);
+ }
+}
+
+
+void
+write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+ const char *p;
+ char itoa_buf[GFC_OTOA_BUF_SIZE];
+ GFC_UINTEGER_LARGEST n = 0;
+
+ if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+ {
+ p = otoa_big (source, itoa_buf, len, &n);
+ write_boz (dtp, f, p, n);
+ }
+ else
+ {
+ n = extract_uint (source, len);
+ p = otoa (n, itoa_buf, sizeof (itoa_buf));
+ write_boz (dtp, f, p, n);
+ }
+}
+
+void
+write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
+{
+ const char *p;
+ char itoa_buf[GFC_XTOA_BUF_SIZE];
+ GFC_UINTEGER_LARGEST n = 0;
+
+ if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
+ {
+ p = ztoa_big (source, itoa_buf, len, &n);
+ write_boz (dtp, f, p, n);
+ }
+ else
+ {
+ n = extract_uint (source, len);
+ p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
+ write_boz (dtp, f, p, n);
+ }
+}
+
+/* Take care of the X/TR descriptor. */
+
+void
+write_x (st_parameter_dt *dtp, int len, int nspaces)
+{
+ char *p;
+
+ p = write_block (dtp, len);
+ if (p == NULL)
+ return;
+ if (nspaces > 0 && len - nspaces >= 0)
+ {
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (&p4[len - nspaces], ' ', nspaces);
+ }
+ else
+ memset (&p[len - nspaces], ' ', nspaces);
+ }
+}
+
+
+/* List-directed writing. */
+
+
+/* Write a single character to the output. Returns nonzero if
+ something goes wrong. */
+
+static int
+write_char (st_parameter_dt *dtp, int c)
+{
+ char *p;
+
+ p = write_block (dtp, 1);
+ if (p == NULL)
+ return 1;
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ *p4 = c;
+ return 0;
+ }
+
+ *p = (uchar) c;
+
+ return 0;
+}
+
+
+/* Write a list-directed logical value. */
+
+static void
+write_logical (st_parameter_dt *dtp, const char *source, int length)
+{
+ write_char (dtp, extract_int (source, length) ? 'T' : 'F');
+}
+
+
+/* Write a list-directed integer value. */
+
+static void
+write_integer (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;
+
+ default:
+ width = 0;
+ break;
+ }
+ f.u.integer.w = width;
+ f.u.integer.m = -1;
+ write_decimal (dtp, &f, source, kind, (void *) gfc_itoa);
+}
+
+
+/* Write a list-directed string. We have to worry about delimiting
+ the strings if the file has been opened in that mode. */
+
+#define DELIM 1
+#define NODELIM 0
+
+static void
+write_character (st_parameter_dt *dtp, const char *source, int kind, size_t length, int mode)
+{
+ size_t extra;
+ char *p, d;
+
+ if (mode == DELIM)
+ {
+ switch (dtp->u.p.current_unit->delim_status)
+ {
+ case DELIM_APOSTROPHE:
+ d = '\'';
+ break;
+ case DELIM_QUOTE:
+ d = '"';
+ break;
+ default:
+ d = ' ';
+ break;
+ }
+ }
+ else
+ d = ' ';
+
+ if (kind == 1)
+ {
+ if (d == ' ')
+ extra = 0;
+ else
+ {
+ extra = 2;
+
+ for (size_t i = 0; i < length; i++)
+ if (source[i] == d)
+ extra++;
+ }
+
+ p = write_block (dtp, length + extra);
+ if (p == NULL)
+ return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t d4 = (gfc_char4_t) d;
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+
+ if (d4 == ' ')
+ memcpy4 (p4, source, length);
+ else
+ {
+ *p4++ = d4;
+
+ for (size_t i = 0; i < length; i++)
+ {
+ *p4++ = (gfc_char4_t) source[i];
+ if (source[i] == d)
+ *p4++ = d4;
+ }
+
+ *p4 = d4;
+ }
+ return;
+ }
+
+ if (d == ' ')
+ memcpy (p, source, length);
+ else
+ {
+ *p++ = d;
+
+ for (size_t i = 0; i < length; i++)
+ {
+ *p++ = source[i];
+ if (source[i] == d)
+ *p++ = d;
+ }
+
+ *p = d;
+ }
+ }
+ else
+ {
+ if (d == ' ')
+ {
+ if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+ write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
+ else
+ write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
+ }
+ else
+ {
+ p = write_block (dtp, 1);
+ *p = d;
+
+ if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+ write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
+ else
+ write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
+
+ p = write_block (dtp, 1);
+ *p = d;
+ }
+ }
+}
+
+/* Floating point helper functions. */
+
+#define BUF_STACK_SZ 256
+
+static int
+get_precision (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
+{
+ if (f->format != FMT_EN)
+ return determine_precision (dtp, f, kind);
+ else
+ return determine_en_precision (dtp, f, source, kind);
+}
+
+/* 4932 is the maximum exponent of long double and quad precision, 3
+ extra characters for the sign, the decimal point, and the
+ trailing null. Extra digits are added by the calling functions for
+ requested precision. Likewise for float and double. F0 editing produces
+ full precision output. */
+static int
+size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind)
+{
+ int size;
+
+ if (f->format == FMT_F && f->u.real.w == 0)
+ {
+ switch (kind)
+ {
+ case 4:
+ size = 38 + 3; /* These constants shown for clarity. */
+ break;
+ case 8:
+ size = 308 + 3;
+ break;
+ case 10:
+ size = 4932 + 3;
+ break;
+ case 16:
+ size = 4932 + 3;
+ break;
+ default:
+ internal_error (&dtp->common, "bad real kind");
+ break;
+ }
+ }
+ else
+ size = f->u.real.w + 1; /* One byte for a NULL character. */
+
+ return size;
+}
+
+static char *
+select_buffer (st_parameter_dt *dtp, const fnode *f, int precision,
+ char *buf, size_t *size, int kind)
{
- write_int (dtp, f, p, len, btoa);
-}
+ char *result;
+
+ /* The buffer needs at least one more byte to allow room for normalizing. */
+ *size = size_from_kind (dtp, f, kind) + precision + 1;
+ if (*size > BUF_STACK_SZ)
+ result = xmalloc (*size);
+ else
+ result = buf;
+ return result;
+}
-void
-write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+static char *
+select_string (st_parameter_dt *dtp, const fnode *f, char *buf, size_t *size,
+ int kind)
{
- write_int (dtp, f, p, len, otoa);
+ char *result;
+ *size = size_from_kind (dtp, f, kind) + f->u.real.d + 1;
+ if (*size > BUF_STACK_SZ)
+ result = xmalloc (*size);
+ else
+ result = buf;
+ return result;
}
-void
-write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+static void
+write_float_string (st_parameter_dt *dtp, char *fstr, size_t len)
{
- write_int (dtp, f, p, len, xtoa);
+ char *p = write_block (dtp, len);
+ if (p == NULL)
+ return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memcpy4 (p4, fstr, len);
+ return;
+ }
+ memcpy (p, fstr, len);
}
+static void
+write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
+{
+ char buf_stack[BUF_STACK_SZ];
+ char str_buf[BUF_STACK_SZ];
+ char *buffer, *result;
+ size_t buf_size, res_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);
+
+ if (buf_size > BUF_STACK_SZ)
+ free (buffer);
+ if (res_len > BUF_STACK_SZ)
+ free (result);
+}
+
void
write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float_0 (dtp, f, p, len);
}
void
write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float_0 (dtp, f, p, len);
}
void
write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float_0 (dtp, f, p, len);
}
void
write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
+ write_float_0 (dtp, f, p, len);
}
void
write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
{
- write_float (dtp, f, p, len);
-}
-
-
-/* Take care of the X/TR descriptor. */
-
-void
-write_x (st_parameter_dt *dtp, int len, int nspaces)
-{
- char *p;
-
- p = write_block (dtp, len);
- if (p == NULL)
- return;
-
- if (nspaces > 0)
- memset (&p[len - nspaces], ' ', nspaces);
-}
-
-
-/* List-directed writing. */
-
-
-/* Write a single character to the output. Returns nonzero if
- something goes wrong. */
-
-static int
-write_char (st_parameter_dt *dtp, char c)
-{
- char *p;
-
- p = write_block (dtp, 1);
- if (p == NULL)
- return 1;
-
- *p = c;
-
- return 0;
-}
-
-
-/* Write a list-directed logical value. */
-
-static void
-write_logical (st_parameter_dt *dtp, const char *source, int length)
-{
- write_char (dtp, extract_int (source, length) ? 'T' : 'F');
+ write_float_0 (dtp, f, p, len);
}
-/* Write a list-directed integer value. */
+/* Set an fnode to default format. */
static void
-write_integer (st_parameter_dt *dtp, const char *source, int length)
+set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
{
- 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));
-
+ f->format = FMT_G;
switch (length)
{
- case 1:
- width = 4;
- break;
-
- case 2:
- width = 6;
- break;
-
case 4:
- width = 11;
+ f->u.real.w = 16;
+ f->u.real.d = 9;
+ f->u.real.e = 2;
break;
-
case 8:
- width = 20;
+ f->u.real.w = 25;
+ f->u.real.d = 17;
+ f->u.real.e = 3;
+ break;
+ case 10:
+ f->u.real.w = 30;
+ f->u.real.d = 21;
+ f->u.real.e = 4;
+ break;
+ case 16:
+ /* Adjust decimal precision depending on binary precision, 106 or 113. */
+#if GFC_REAL_16_DIGITS == 113
+ f->u.real.w = 45;
+ f->u.real.d = 36;
+ f->u.real.e = 4;
+#else
+ f->u.real.w = 41;
+ f->u.real.d = 32;
+ f->u.real.e = 4;
+#endif
break;
-
default:
- width = 0;
+ internal_error (&dtp->common, "bad real kind");
break;
}
-
- digits = strlen (q);
-
- if (width < digits)
- width = digits;
- p = write_block (dtp, width);
- if (p == NULL)
- 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);
- }
}
+/* Output a real number with default format.
+ To guarantee that a binary -> decimal -> binary roundtrip conversion
+ recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
+ significant digits for REAL kinds 4, 8, 10, and 16, respectively.
+ Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
+ for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
+ Fortran standard requires outputting an extra digit when the scale
+ factor is 1 and when the magnitude of the value is such that E
+ editing is used. However, gfortran compensates for this, and thus
+ for list formatted the same number of significant digits is
+ generated both when using F and E editing. */
-/* Write a list-directed string. We have to worry about delimiting
- the strings if the file has been opened in that mode. */
-
-static void
-write_character (st_parameter_dt *dtp, const char *source, int length)
+void
+write_real (st_parameter_dt *dtp, const char *source, int kind)
{
- int i, extra;
- char *p, d;
+ fnode f ;
+ char buf_stack[BUF_STACK_SZ];
+ char str_buf[BUF_STACK_SZ];
+ char *buffer, *result;
+ size_t buf_size, res_len;
+ int orig_scale = dtp->u.p.scale_factor;
+ dtp->u.p.scale_factor = 1;
+ set_fnode_default (dtp, &f, kind);
+
+ /* 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);
+
+ /* Scratch buffer to hold final result. */
+ 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);
+
+ dtp->u.p.scale_factor = orig_scale;
+ if (buf_size > BUF_STACK_SZ)
+ free (buffer);
+ if (res_len > BUF_STACK_SZ)
+ free (result);
+}
- switch (dtp->u.p.current_unit->flags.delim)
- {
- case DELIM_APOSTROPHE:
- d = '\'';
- break;
- case DELIM_QUOTE:
- d = '"';
- break;
- default:
- d = ' ';
- break;
- }
+/* Similar to list formatted REAL output, for kPG0 where k > 0 we
+ compensate for the extra digit. */
- if (d == ' ')
- extra = 0;
+void
+write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
+{
+ fnode f;
+ 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);
+
+ if (d > 0)
+ f.u.real.d = d;
+
+ /* 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
- {
- extra = 2;
+ comp_d = 0;
+ dtp->u.p.g0_no_blanks = 1;
- for (i = 0; i < length; i++)
- if (source[i] == d)
- extra++;
- }
+ /* Precision for snprintf call. */
+ int precision = get_precision (dtp, &f, source, kind);
- p = write_block (dtp, length + extra);
- if (p == NULL)
- return;
+ /* String buffer to hold final result. */
+ result = select_string (dtp, &f, str_buf, &res_len, kind);
- if (d == ' ')
- memcpy (p, source, length);
- else
- {
- *p++ = d;
+ buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
- for (i = 0; i < length; i++)
- {
- *p++ = source[i];
- if (source[i] == d)
- *p++ = d;
- }
+ get_float_string (dtp, &f, source , kind, comp_d, buffer,
+ precision, buf_size, result, &res_len);
+ write_float_string (dtp, result, res_len);
- *p = d;
- }
+ dtp->u.p.g0_no_blanks = 0;
+ if (buf_size > BUF_STACK_SZ)
+ free (buffer);
+ if (res_len > BUF_STACK_SZ)
+ free (result);
}
-/* Output a real number with default format.
- This is 1PG14.7E2 for REAL(4), 1PG23.15E3 for REAL(8),
- 1PG28.19E4 for REAL(10) and 1PG43.34E4 for REAL(16). */
-
static void
-write_real (st_parameter_dt *dtp, const char *source, int length)
+write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{
+ char semi_comma =
+ dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
+
+ /* Set for no blanks so we get a string result with no leading
+ blanks. We will pad left later. */
+ dtp->u.p.g0_no_blanks = 1;
+
fnode f ;
- int org_scale = dtp->u.p.scale_factor;
- f.format = FMT_G;
+ char buf_stack[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;
+ int width, lblanks, orig_scale = dtp->u.p.scale_factor;
+
dtp->u.p.scale_factor = 1;
- switch (length)
- {
- case 4:
- f.u.real.w = 14;
- f.u.real.d = 7;
- f.u.real.e = 2;
- break;
- case 8:
- f.u.real.w = 23;
- f.u.real.d = 15;
- f.u.real.e = 3;
- break;
- case 10:
- f.u.real.w = 28;
- f.u.real.d = 19;
- f.u.real.e = 4;
- break;
- case 16:
- f.u.real.w = 43;
- f.u.real.d = 34;
- f.u.real.e = 4;
- break;
- default:
- internal_error (&dtp->common, "bad real kind");
- break;
- }
- write_float (dtp, &f, source , length);
- dtp->u.p.scale_factor = org_scale;
-}
+ set_fnode_default (dtp, &f, kind);
+ /* Set width for two values, parenthesis, and comma. */
+ width = 2 * f.u.real.w + 3;
-static void
-write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
-{
- if (write_char (dtp, '('))
- return;
- write_real (dtp, source, kind);
+ /* Set for no blanks so we get a string result with no leading
+ blanks. We will pad left later. */
+ dtp->u.p.g0_no_blanks = 1;
- if (write_char (dtp, ','))
- return;
- write_real (dtp, source + size / 2, kind);
+ /* Precision for snprintf call. */
+ int precision = get_precision (dtp, &f, source, kind);
+
+ /* String buffers to hold final result. */
+ result1 = select_string (dtp, &f, str1_buf, &res_len1, kind);
+ result2 = select_string (dtp, &f, str2_buf, &res_len2, kind);
+ 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);
+ get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
+ precision, buf_size, result2, &res_len2);
+ if (!dtp->u.p.namelist_mode)
+ {
+ lblanks = width - res_len1 - res_len2 - 3;
+ write_x (dtp, lblanks, lblanks);
+ }
+ write_char (dtp, '(');
+ write_float_string (dtp, result1, res_len1);
+ write_char (dtp, semi_comma);
+ write_float_string (dtp, result2, res_len2);
write_char (dtp, ')');
+
+ dtp->u.p.scale_factor = orig_scale;
+ dtp->u.p.g0_no_blanks = 0;
+ if (buf_size > BUF_STACK_SZ)
+ free (buffer);
+ if (res_len1 > BUF_STACK_SZ)
+ free (result1);
+ if (res_len2 > BUF_STACK_SZ)
+ free (result2);
}
p = write_block (dtp, options.separator_len);
if (p == NULL)
return;
-
- memcpy (p, options.separator, options.separator_len);
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memcpy4 (p4, options.separator, options.separator_len);
+ }
+ else
+ memcpy (p, options.separator, options.separator_len);
}
if (dtp->u.p.first_item)
{
dtp->u.p.first_item = 0;
- write_char (dtp, ' ');
+ if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
+ write_char (dtp, ' ');
}
else
{
if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
- dtp->u.p.current_unit->flags.delim != DELIM_NONE)
- write_separator (dtp);
+ (dtp->u.p.current_unit->delim_status != DELIM_NONE
+ && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
+ write_separator (dtp);
}
switch (type)
write_logical (dtp, p, kind);
break;
case BT_CHARACTER:
- write_character (dtp, p, kind);
+ write_character (dtp, p, kind, size, DELIM);
break;
case BT_REAL:
write_real (dtp, p, kind);
case BT_COMPLEX:
write_complex (dtp, p, kind, size);
break;
+ case BT_CLASS:
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "LISTDIRECTED";
+ gfc_charlen_type iotype_len = 12;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+
+ GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsge, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ }
+ break;
default:
internal_error (&dtp->common, "list_formatted_write(): Bad type");
}
+ fbuf_flush_list (dtp->u.p.current_unit, LIST_WRITING);
dtp->u.p.char_flag = (type == BT_CHARACTER);
}
{
size_t elem;
char *tmp;
+ size_t stride = type == BT_CHARACTER ?
+ size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
tmp = (char *) p;
for (elem = 0; elem < nelems; elem++)
{
dtp->u.p.item_count++;
- list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
+ list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
}
}
#define NML_DIGITS 20
+static void
+namelist_write_newline (st_parameter_dt *dtp)
+{
+ if (!is_internal_unit (dtp))
+ {
+#ifdef HAVE_CRLF
+ write_character (dtp, "\r\n", 1, 2, NODELIM);
+#else
+ write_character (dtp, "\n", 1, 1, NODELIM);
+#endif
+ return;
+ }
+
+ if (is_array_io (dtp))
+ {
+ gfc_offset record;
+ int finished;
+ char *p;
+ int length = dtp->u.p.current_unit->bytes_left;
+
+ p = write_block (dtp, length);
+ if (p == NULL)
+ return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memset4 (p4, ' ', length);
+ }
+ else
+ memset (p, ' ', length);
+
+ /* Now that the current record has been padded out,
+ determine where the next record in the array is. */
+ record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+ &finished);
+ if (finished)
+ dtp->u.p.current_unit->endfile = AT_ENDFILE;
+ else
+ {
+ /* Now seek to this record */
+ record = record * dtp->u.p.current_unit->recl;
+
+ if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
+ {
+ generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+ return;
+ }
+
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+ }
+ }
+ else
+ write_character (dtp, " ", 1, 1, NODELIM);
+}
+
+
static namelist_info *
-nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
- namelist_info * base, char * base_name)
+nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
+ namelist_info *base, char *base_name)
{
int rep_ctr;
int num;
int nml_carry;
- index_type len;
+ int len;
index_type obj_size;
index_type nelem;
- index_type dim_i;
- index_type clen;
+ size_t dim_i;
+ size_t clen;
index_type elem_ctr;
- index_type obj_name_len;
- void * p ;
+ size_t obj_name_len;
+ void *p;
char cup;
- char * obj_name;
- char * ext_name;
+ char *obj_name;
+ char *ext_name;
+ char *q;
+ size_t ext_name_len;
char rep_buff[NML_DIGITS];
- namelist_info * cmp;
- namelist_info * retval = obj->next;
+ namelist_info *cmp;
+ namelist_info *retval = obj->next;
size_t base_name_len;
size_t base_var_name_len;
size_t tot_len;
+ /* Set the character to be used to separate values
+ to a comma or semi-colon. */
+
+ char semi_comma =
+ dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
+
/* Write namelist variable names in upper case. If a derived type,
nothing is output. If a component, base and base_name are set. */
- if (obj->type != GFC_DTYPE_DERIVED)
+ if (obj->type != BT_DERIVED || obj->dtio_sub != NULL)
{
-#ifdef HAVE_CRLF
- write_character (dtp, "\r\n ", 3);
-#else
- write_character (dtp, "\n ", 2);
-#endif
+ namelist_write_newline (dtp);
+ write_character (dtp, " ", 1, 1, NODELIM);
+
len = 0;
if (base)
{
- len =strlen (base->var_name);
- for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
+ len = strlen (base->var_name);
+ base_name_len = strlen (base_name);
+ for (dim_i = 0; dim_i < base_name_len; dim_i++)
{
- cup = toupper (base_name[dim_i]);
- write_character (dtp, &cup, 1);
+ cup = toupper ((int) base_name[dim_i]);
+ write_character (dtp, &cup, 1, 1, NODELIM);
}
}
- for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
+ clen = strlen (obj->var_name);
+ for (dim_i = len; dim_i < clen; dim_i++)
{
- cup = toupper (obj->var_name[dim_i]);
- write_character (dtp, &cup, 1);
+ cup = toupper ((int) obj->var_name[dim_i]);
+ if (cup == '+')
+ cup = '%';
+ write_character (dtp, &cup, 1, 1, NODELIM);
}
- write_character (dtp, "=", 1);
+ write_character (dtp, "=", 1, 1, NODELIM);
}
/* Counts the number of data output on a line, including names. */
switch (obj->type)
{
- case GFC_DTYPE_REAL:
+ case BT_REAL:
obj_size = size_from_real_kind (len);
break;
- case GFC_DTYPE_COMPLEX:
+ case BT_COMPLEX:
obj_size = size_from_complex_kind (len);
break;
- case GFC_DTYPE_CHARACTER:
+ case BT_CHARACTER:
obj_size = obj->string_length;
break;
default:
- obj_size = len;
+ obj_size = len;
}
if (obj->var_rank)
/* Set the index vector and count the number of elements. */
nelem = 1;
- for (dim_i=0; dim_i < obj->var_rank; dim_i++)
+ for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
{
- obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
- nelem = nelem * (obj->dim[dim_i].ubound + 1 - obj->dim[dim_i].lbound);
+ obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
+ nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
}
/* Main loop to output the data held in the object. */
/* Check for repeat counts of intrinsic types. */
if ((elem_ctr < (nelem - 1)) &&
- (obj->type != GFC_DTYPE_DERIVED) &&
- !memcmp (p, (void*)(p + obj_size ), obj_size ))
+ (obj->type != BT_DERIVED) &&
+ !memcmp (p, (void *)(p + obj_size ), obj_size ))
{
rep_ctr++;
}
{
if (rep_ctr > 1)
{
- st_sprintf(rep_buff, " %d*", rep_ctr);
- write_character (dtp, rep_buff, strlen (rep_buff));
+ snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
+ write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
dtp->u.p.no_leading_blank = 1;
}
num++;
switch (obj->type)
{
- case GFC_DTYPE_INTEGER:
+ case BT_INTEGER:
write_integer (dtp, p, len);
break;
- case GFC_DTYPE_LOGICAL:
+ case BT_LOGICAL:
write_logical (dtp, p, len);
break;
- case GFC_DTYPE_CHARACTER:
- if (dtp->u.p.nml_delim)
- write_character (dtp, &dtp->u.p.nml_delim, 1);
- write_character (dtp, p, obj->string_length);
- if (dtp->u.p.nml_delim)
- write_character (dtp, &dtp->u.p.nml_delim, 1);
+ case BT_CHARACTER:
+ if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
+ write_character (dtp, p, 4, obj->string_length, DELIM);
+ else
+ write_character (dtp, p, 1, obj->string_length, DELIM);
break;
- case GFC_DTYPE_REAL:
+ case BT_REAL:
write_real (dtp, p, len);
break;
- case GFC_DTYPE_COMPLEX:
+ case BT_COMPLEX:
dtp->u.p.no_leading_blank = 0;
num++;
write_complex (dtp, p, len, obj_size);
break;
- case GFC_DTYPE_DERIVED:
-
+ case BT_DERIVED:
+ case BT_CLASS:
/* To treat a derived type, we need to build two strings:
ext_name = the name, including qualifiers that prepends
component names in the output - passed to
components. */
/* First ext_name => get length of all possible components */
+ if (obj->dtio_sub != NULL)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "NAMELIST";
+ gfc_charlen_type iotype_len = 8;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+ formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
+
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ if (obj->type == BT_DERIVED)
+ {
+ /* Build a class container. */
+ gfc_class list_obj;
+ list_obj.data = p;
+ list_obj.vptr = obj->vtable;
+ list_obj.len = 0;
+ dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ }
+ else
+ {
+ dtio_ptr (p, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ }
+ dtp->u.p.current_unit->child_dtio--;
+
+ goto obj_loop;
+ }
base_name_len = base_name ? strlen (base_name) : 0;
base_var_name_len = base ? strlen (base->var_name) : 0;
- ext_name = (char*)get_mem ( base_name_len
- + base_var_name_len
- + strlen (obj->var_name)
- + obj->var_rank * NML_DIGITS
- + 1);
+ ext_name_len = base_name_len + base_var_name_len
+ + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
+ ext_name = xmalloc (ext_name_len);
- memcpy (ext_name, base_name, base_name_len);
+ if (base_name)
+ memcpy (ext_name, base_name, base_name_len);
clen = strlen (obj->var_name + base_var_name_len);
- memcpy (ext_name + base_name_len,
+ memcpy (ext_name + base_name_len,
obj->var_name + base_var_name_len, clen);
-
+
/* Append the qualifier. */
tot_len = base_name_len + clen;
- for (dim_i = 0; dim_i < obj->var_rank; dim_i++)
+ for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
{
if (!dim_i)
{
ext_name[tot_len] = '(';
tot_len++;
}
- st_sprintf (ext_name + tot_len, "%d", (int) obj->ls[dim_i].idx);
+ snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
+ (int) obj->ls[dim_i].idx);
tot_len += strlen (ext_name + tot_len);
- ext_name[tot_len] = (dim_i == obj->var_rank - 1) ? ')' : ',';
+ ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
tot_len++;
}
ext_name[tot_len] = '\0';
+ for (q = ext_name; *q; q++)
+ if (*q == '+')
+ *q = '%';
/* Now obj_name. */
obj_name_len = strlen (obj->var_name) + 1;
- obj_name = get_mem (obj_name_len+1);
+ obj_name = xmalloc (obj_name_len + 1);
memcpy (obj_name, obj->var_name, obj_name_len-1);
memcpy (obj_name + obj_name_len-1, "%", 2);
obj, ext_name);
}
- free_mem (obj_name);
- free_mem (ext_name);
+ free (obj_name);
+ free (ext_name);
goto obj_loop;
default:
internal_error (&dtp->common, "Bad type for namelist write");
}
- /* Reset the leading blank suppression, write a comma and, if 5
- values have been output, write a newline and advance to column
- 2. Reset the repeat counter. */
+ /* Reset the leading blank suppression, write a comma (or semi-colon)
+ and, if 5 values have been output, write a newline and advance
+ to column 2. Reset the repeat counter. */
dtp->u.p.no_leading_blank = 0;
- write_character (dtp, ",", 1);
+ if (obj->type == BT_CHARACTER)
+ {
+ if (dtp->u.p.nml_delim != '\0')
+ write_character (dtp, &semi_comma, 1, 1, NODELIM);
+ }
+ else
+ write_character (dtp, &semi_comma, 1, 1, NODELIM);
if (num > 5)
{
num = 0;
-#ifdef HAVE_CRLF
- write_character (dtp, "\r\n ", 3);
-#else
- write_character (dtp, "\n ", 2);
-#endif
+ if (dtp->u.p.nml_delim == '\0')
+ write_character (dtp, &semi_comma, 1, 1, NODELIM);
+ namelist_write_newline (dtp);
+ write_character (dtp, " ", 1, 1, NODELIM);
}
rep_ctr = 1;
}
obj_loop:
- nml_carry = 1;
- for (dim_i = 0; nml_carry && (dim_i < obj->var_rank); dim_i++)
- {
- obj->ls[dim_i].idx += nml_carry ;
- nml_carry = 0;
- if (obj->ls[dim_i].idx > (ssize_t)obj->dim[dim_i].ubound)
- {
- obj->ls[dim_i].idx = obj->dim[dim_i].lbound;
- nml_carry = 1;
- }
- }
+ nml_carry = 1;
+ for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
+ {
+ obj->ls[dim_i].idx += nml_carry ;
+ nml_carry = 0;
+ if (obj->ls[dim_i].idx > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
+ {
+ obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
+ nml_carry = 1;
+ }
+ }
}
/* Return a pointer beyond the furthest object accessed. */
return retval;
}
+
/* This is the entry function for namelist writes. It outputs the name
of the namelist and iterates through the namelist by calls to
nml_write_obj. The call below has dummys in the arguments used in
void
namelist_write (st_parameter_dt *dtp)
{
- namelist_info * t1, *t2, *dummy = NULL;
- index_type i;
+ namelist_info *t1, *t2, *dummy = NULL;
index_type dummy_offset = 0;
char c;
- char * dummy_name = NULL;
- unit_delim tmp_delim;
+ char *dummy_name = NULL;
/* Set the delimiter for namelist output. */
-
- tmp_delim = dtp->u.p.current_unit->flags.delim;
- dtp->u.p.current_unit->flags.delim = DELIM_NONE;
- switch (tmp_delim)
+ switch (dtp->u.p.current_unit->delim_status)
{
- case (DELIM_QUOTE):
- dtp->u.p.nml_delim = '"';
- break;
-
- case (DELIM_APOSTROPHE):
- dtp->u.p.nml_delim = '\'';
- break;
-
- default:
- dtp->u.p.nml_delim = '\0';
- break;
+ case DELIM_APOSTROPHE:
+ dtp->u.p.nml_delim = '\'';
+ break;
+ case DELIM_QUOTE:
+ case DELIM_UNSPECIFIED:
+ dtp->u.p.nml_delim = '"';
+ break;
+ default:
+ dtp->u.p.nml_delim = '\0';
}
- write_character (dtp, "&", 1);
+ 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 (dtp->namelist_name[i]);
- write_character (dtp, &c ,1);
+ c = toupper ((int) dtp->namelist_name[i]);
+ write_character (dtp, &c, 1 ,1, NODELIM);
}
if (dtp->u.p.ionml != NULL)
t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
}
}
-#ifdef HAVE_CRLF
- write_character (dtp, " /\r\n", 5);
-#else
- write_character (dtp, " /\n", 4);
-#endif
-
- /* Recover the original delimiter. */
- dtp->u.p.current_unit->flags.delim = tmp_delim;
+ namelist_write_newline (dtp);
+ write_character (dtp, " /", 1, 2, NODELIM);
}
#undef NML_DIGITS