-/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ 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).
#include <ctype.h>
#include <stdlib.h>
#include <stdbool.h>
+#include <errno.h>
#define star_fill(p, n) memset(p, '*', n)
#include "write_float.def"
+typedef unsigned char uchar;
+
+/* Write out default char4. */
+
+static void
+write_default_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;
+ 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;
+ memset (p, ' ', k);
+ }
+
+ /* Get ready to handle delimiters if needed. */
+ d = ' ';
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ switch (dtp->u.p.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];
+
+ /* 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 };
+ size_t 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. */
+ d = ' ';
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ switch (dtp->u.p.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++;
+ }
+ }
+}
+
+
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 ? len : f->u.string.length;
+ 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
#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, int len)
+{
+ int 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;
+
+ 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 char crlf[] = "\r\n";
+ int i, 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 (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)
{
write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
{
char *p;
+ int wlen;
GFC_INTEGER_LARGEST n;
- p = write_block (dtp, f->u.w);
+ wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
+
+ p = write_block (dtp, wlen);
if (p == NULL)
return;
- memset (p, ' ', f->u.w - 1);
+ memset (p, ' ', wlen - 1);
n = extract_int (source, len);
- p[f->u.w - 1] = (n) ? 'T' : 'F';
+ p[wlen - 1] = (n) ? 'T' : 'F';
}
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)
if (n < 0)
n = -n;
- nsign = sign == SIGN_NONE ? 0 : 1;
+ nsign = sign == S_NONE ? 0 : 1;
q = conv (n, itoa_buf, sizeof (itoa_buf));
digits = strlen (q);
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;
}
the strings if the file has been opened in that mode. */
static void
-write_character (st_parameter_dt *dtp, const char *source, int length)
+write_character (st_parameter_dt *dtp, const char *source, int kind, int length)
{
int i, extra;
char *p, d;
- switch (dtp->u.p.current_unit->flags.delim)
+ d = ' ';
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ switch (dtp->u.p.delim_status)
{
case DELIM_APOSTROPHE:
d = '\'';
break;
}
- if (d == ' ')
- extra = 0;
- else
+ if (kind == 1)
{
- extra = 2;
+ if (d == ' ')
+ extra = 0;
+ else
+ {
+ extra = 2;
- for (i = 0; i < length; i++)
- if (source[i] == d)
- extra++;
- }
+ for (i = 0; i < length; i++)
+ if (source[i] == d)
+ extra++;
+ }
- p = write_block (dtp, length + extra);
- if (p == NULL)
- return;
+ p = write_block (dtp, length + extra);
+ if (p == NULL)
+ return;
+
+ if (d == ' ')
+ memcpy (p, source, length);
+ else
+ {
+ *p++ = d;
+
+ for (i = 0; i < length; i++)
+ {
+ *p++ = source[i];
+ if (source[i] == d)
+ *p++ = d;
+ }
- if (d == ' ')
- memcpy (p, source, length);
+ *p = d;
+ }
+ }
else
{
- *p++ = d;
-
- for (i = 0; i < length; i++)
+ if (d == ' ')
{
- *p++ = source[i];
- if (source[i] == d)
- *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);
}
+ else
+ {
+ p = write_block (dtp, 1);
+ *p = d;
- *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;
+ }
}
}
-/* 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). */
+/* Set an fnode to default format. */
static void
-write_real (st_parameter_dt *dtp, const char *source, int length)
+set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
{
- fnode f ;
- int org_scale = dtp->u.p.scale_factor;
- f.format = FMT_G;
- dtp->u.p.scale_factor = 1;
+ f->format = FMT_G;
switch (length)
{
case 4:
- f.u.real.w = 14;
- f.u.real.d = 7;
- f.u.real.e = 2;
+ f->u.real.w = 15;
+ f->u.real.d = 8;
+ f->u.real.e = 2;
break;
case 8:
- f.u.real.w = 23;
- f.u.real.d = 15;
- f.u.real.e = 3;
+ f->u.real.w = 25;
+ f->u.real.d = 17;
+ f->u.real.e = 3;
break;
case 10:
- f.u.real.w = 28;
- f.u.real.d = 19;
- f.u.real.e = 4;
+ f->u.real.w = 29;
+ f->u.real.d = 20;
+ f->u.real.e = 4;
break;
case 16:
- f.u.real.w = 43;
- f.u.real.d = 34;
- f.u.real.e = 4;
+ f->u.real.w = 44;
+ f->u.real.d = 35;
+ f->u.real.e = 4;
break;
default:
internal_error (&dtp->common, "bad real kind");
break;
}
+}
+/* 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). */
+
+void
+write_real (st_parameter_dt *dtp, const char *source, int length)
+{
+ fnode f ;
+ int org_scale = dtp->u.p.scale_factor;
+ dtp->u.p.scale_factor = 1;
+ set_fnode_default (dtp, &f, length);
+ write_float (dtp, &f, source , length);
+ dtp->u.p.scale_factor = org_scale;
+}
+
+
+void
+write_real_g0 (st_parameter_dt *dtp, const char *source, int length, int d)
+{
+ fnode f ;
+ int org_scale = dtp->u.p.scale_factor;
+ dtp->u.p.scale_factor = 1;
+ set_fnode_default (dtp, &f, length);
+ f.format = FMT_ES;
+ f.u.real.d = d;
write_float (dtp, &f, source , length);
dtp->u.p.scale_factor = org_scale;
}
static void
write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
{
+ char semi_comma = ',';
+
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ semi_comma = dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';';
+
if (write_char (dtp, '('))
return;
write_real (dtp, source, kind);
- if (write_char (dtp, ','))
+ if (write_char (dtp, semi_comma))
return;
write_real (dtp, source + size / 2, kind);
}
else
{
- if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
- dtp->u.p.current_unit->flags.delim != DELIM_NONE)
- write_separator (dtp);
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ {
+ if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
+ dtp->u.p.delim_status != DELIM_NONE)
+ write_separator (dtp);
+ }
+ else
+ {
+ if (type != BT_CHARACTER || !dtp->u.p.char_flag)
+ 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);
break;
case BT_REAL:
write_real (dtp, p, kind);
{
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);
+#else
+ write_character (dtp, "\n", 1, 1);
+#endif
+ }
+ else
+ write_character (dtp, " ", 1, 1);
+}
+
+
static namelist_info *
nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
namelist_info * base, char * base_name)
size_t base_var_name_len;
size_t tot_len;
unit_delim tmp_delim;
+
+ /* Set the character to be used to separate values
+ to a comma or semi-colon. */
+
+ char semi_comma = ',';
+
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ semi_comma = dtp->u.p.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)
{
-#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);
+
len = 0;
if (base)
{
for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
{
cup = toupper (base_name[dim_i]);
- write_character (dtp, &cup, 1);
+ write_character (dtp, &cup, 1, 1);
}
}
for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
{
cup = toupper (obj->var_name[dim_i]);
- write_character (dtp, &cup, 1);
+ write_character (dtp, &cup, 1, 1);
}
- write_character (dtp, "=", 1);
+ write_character (dtp, "=", 1, 1);
}
/* Counts the number of data output on a line, including names. */
if (rep_ctr > 1)
{
sprintf(rep_buff, " %d*", rep_ctr);
- write_character (dtp, rep_buff, strlen (rep_buff));
+ write_character (dtp, rep_buff, 1, strlen (rep_buff));
dtp->u.p.no_leading_blank = 1;
}
num++;
break;
case GFC_DTYPE_CHARACTER:
- tmp_delim = dtp->u.p.current_unit->flags.delim;
- if (dtp->u.p.nml_delim == '"')
- dtp->u.p.current_unit->flags.delim = DELIM_QUOTE;
- if (dtp->u.p.nml_delim == '\'')
- dtp->u.p.current_unit->flags.delim = DELIM_APOSTROPHE;
- write_character (dtp, p, obj->string_length);
- dtp->u.p.current_unit->flags.delim = tmp_delim;
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ {
+ tmp_delim = dtp->u.p.delim_status;
+ if (dtp->u.p.nml_delim == '"')
+ dtp->u.p.delim_status = DELIM_QUOTE;
+ if (dtp->u.p.nml_delim == '\'')
+ dtp->u.p.delim_status = DELIM_APOSTROPHE;
+ write_character (dtp, p, 1, obj->string_length);
+ dtp->u.p.delim_status = tmp_delim;
+ }
+ else
+ write_character (dtp, p, 1, obj->string_length);
break;
case GFC_DTYPE_REAL:
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);
+ write_character (dtp, &semi_comma, 1, 1);
if (num > 5)
{
num = 0;
-#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);
}
rep_ctr = 1;
}
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
index_type dummy_offset = 0;
char c;
char * dummy_name = NULL;
- unit_delim tmp_delim;
+ unit_delim tmp_delim = DELIM_UNSPECIFIED;
/* Set the delimiter for namelist output. */
-
- tmp_delim = dtp->u.p.current_unit->flags.delim;
+if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ {
+ tmp_delim = dtp->u.p.delim_status;
switch (tmp_delim)
{
case (DELIM_QUOTE):
}
/* Temporarily disable namelist delimters. */
- dtp->u.p.current_unit->flags.delim = DELIM_NONE;
-
- write_character (dtp, "&", 1);
+ dtp->u.p.delim_status = DELIM_NONE;
+ }
+ write_character (dtp, "&", 1, 1);
/* Write namelist name in upper case - f95 std. */
for (i = 0 ;i < dtp->namelist_name_len ;i++ )
{
c = toupper (dtp->namelist_name[i]);
- write_character (dtp, &c ,1);
+ write_character (dtp, &c, 1 ,1);
}
if (dtp->u.p.ionml != NULL)
}
}
-#ifdef HAVE_CRLF
- write_character (dtp, " /\r\n", 5);
-#else
- write_character (dtp, " /\n", 4);
-#endif
-
+ write_character (dtp, " /", 1, 3);
+ namelist_write_newline (dtp);
/* Restore the original delimiter. */
- dtp->u.p.current_unit->flags.delim = tmp_delim;
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ dtp->u.p.delim_status = tmp_delim;
}
#undef NML_DIGITS
OSDN Git Service
