-/* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist input contributed by Paul Thomas
+ F2003 I/O support contributed by Jerry DeLisle
This file is part of the GNU Fortran 95 runtime library (libgfortran).
case '5': case '6': case '7': case '8': case '9'
#define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
- case '\r'
+ case '\r': case ';'
/* This macro assumes that we're operating on a variable. */
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
- || c == '\t' || c == '\r')
+ || c == '\t' || c == '\r' || c == ';')
/* Maximum repeat count. Less than ten times the maximum signed int32. */
#define MAX_REPEAT 200000000
+#ifndef HAVE_SNPRINTF
+# undef snprintf
+# define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
+#endif
/* Save a character to a string buffer, enlarging it as necessary. */
static void
free_line (st_parameter_dt *dtp)
{
+ dtp->u.p.item_count = 0;
+ dtp->u.p.line_buffer_enabled = 0;
+
if (dtp->u.p.line_buffer == NULL)
return;
static char
next_char (st_parameter_dt *dtp)
{
- int length;
+ size_t length;
gfc_offset record;
- char c, *p;
+ char c;
if (dtp->u.p.last_char != '\0')
{
goto done;
}
- dtp->u.p.item_count = 0;
- dtp->u.p.line_buffer_enabled = 0;
+ dtp->u.p.item_count = 0;
+ dtp->u.p.line_buffer_enabled = 0;
}
/* Handle the end-of-record and end-of-file conditions for
length = 1;
- p = salloc_r (dtp->u.p.current_unit->s, &length);
+ if (sread (dtp->u.p.current_unit->s, &c, &length) != 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return '\0';
+ }
- if (is_stream_io (dtp))
+ if (is_stream_io (dtp) && length == 1)
dtp->u.p.current_unit->strm_pos++;
if (is_internal_unit (dtp))
{
if (is_array_io (dtp))
{
- /* End of record is handled in the next pass through, above. The
- check for NULL here is cautionary. */
- if (p == NULL)
+ /* Check whether we hit EOF. */
+ if (length == 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return '\0';
- }
-
+ }
dtp->u.p.current_unit->bytes_left--;
- c = *p;
}
else
{
- if (p == NULL)
+ if (dtp->u.p.at_eof)
longjmp (*dtp->u.p.eof_jump, 1);
if (length == 0)
- c = '\n';
- else
- c = *p;
+ {
+ c = '\n';
+ dtp->u.p.at_eof = 1;
+ }
}
}
else
{
- if (p == NULL)
- {
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- return '\0';
- }
if (length == 0)
{
if (dtp->u.p.advance_status == ADVANCE_NO)
else
longjmp (*dtp->u.p.eof_jump, 1);
}
- else
- c = *p;
}
done:
dtp->u.p.at_eol = (c == '\n' || c == '\r');
switch (c)
{
case ',':
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ {
+ unget_char (dtp, c);
+ break;
+ }
+ /* Fall through. */
+ case ';':
dtp->u.p.comma_flag = 1;
eat_spaces (dtp);
break;
case '\r':
dtp->u.p.at_eol = 1;
n = next_char(dtp);
- if (n == '\n')
+ if (n != '\n')
{
- if (dtp->u.p.namelist_mode)
- {
- do
- c = next_char (dtp);
- while (c == '\n' || c == '\r' || c == ' ');
- unget_char (dtp, c);
- }
+ unget_char (dtp, n);
+ break;
}
- else
- unget_char (dtp, n);
- break;
-
+ /* Fall through. */
case '\n':
dtp->u.p.at_eol = 1;
if (dtp->u.p.namelist_mode)
}
}
}
- while (c == '\n' || c == '\r' || c == ' ');
+ while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
unget_char (dtp, c);
}
break;
unget_char (dtp, c);
break;
+
case '.':
c = tolower (next_char (dtp));
switch (c)
return; /* Null value. */
default:
+ /* Save the character in case it is the beginning
+ of the next object name. */
+ unget_char (dtp, c);
goto bad_logical;
}
unget_char (dtp, c);
eat_separator (dtp);
- dtp->u.p.item_count = 0;
- dtp->u.p.line_buffer_enabled = 0;
set_integer ((int *) dtp->u.p.value, v, length);
free_line (dtp);
logical_done:
- dtp->u.p.item_count = 0;
- dtp->u.p.line_buffer_enabled = 0;
dtp->u.p.saved_type = BT_LOGICAL;
dtp->u.p.saved_length = length;
set_integer ((int *) dtp->u.p.value, v, length);
default:
if (dtp->u.p.namelist_mode)
{
- if (dtp->u.p.current_unit->flags.delim == DELIM_APOSTROPHE
- || dtp->u.p.current_unit->flags.delim == DELIM_QUOTE
+ if (dtp->u.p.delim_status == DELIM_APOSTROPHE
+ || dtp->u.p.delim_status == DELIM_QUOTE
|| c == '&' || c == '$' || c == '/')
{
unget_char (dtp, c);
invalid. */
done:
c = next_char (dtp);
- if (is_separator (c))
+ if (is_separator (c) || c == '!')
{
unget_char (dtp, c);
eat_separator (dtp);
c = next_char (dtp);
}
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
+
if (!isdigit (c) && c != '.')
{
if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
for (;;)
{
c = next_char (dtp);
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
else
unget_char (dtp, c);
- if (next_char (dtp) != ',')
- goto bad_complex;
+ if (dtp->common.flags & IOPARM_DT_HAS_F2003)
+ {
+ if (next_char (dtp)
+ != (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
+ goto bad_complex;
+ }
+ else
+ {
+ if (next_char (dtp) != ',')
+ goto bad_complex;
+ }
eol_2:
eat_spaces (dtp);
seen_dp = 0;
c = next_char (dtp);
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
for (;;)
{
c = next_char (dtp);
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
break;
case '.':
- if (seen_dp)
- goto bad_real;
+ if (seen_dp)
+ goto bad_real;
seen_dp = 1;
push_char (dtp, c);
goto got_repeat;
CASE_SEPARATORS:
- if (c != '\n' && c != ',' && c != '\r')
+ if (c != '\n' && c != ',' && c != '\r' && c != ';')
unget_char (dtp, c);
goto done;
c = next_char (dtp);
}
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
+
if (!isdigit (c) && c != '.')
{
if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
for (;;)
{
c = next_char (dtp);
+ if ((dtp->common.flags & IOPARM_DT_HAS_F2003)
+ && c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
push_char (dtp, 'n');
}
- dtp->u.p.item_count = 0;
- dtp->u.p.line_buffer_enabled = 0;
free_line (dtp);
goto done;
greater than one, we copy the data item multiple times. */
static void
-list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
- size_t size)
+list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
+ int kind, size_t size)
{
char c;
- int m;
+ gfc_char4_t *q;
+ int i, m;
jmp_buf eof_jump;
dtp->u.p.namelist_mode = 0;
case BT_CHARACTER:
if (dtp->u.p.saved_string)
- {
+ {
m = ((int) size < dtp->u.p.saved_used)
? (int) size : dtp->u.p.saved_used;
- memcpy (p, dtp->u.p.saved_string, m);
- }
+ if (kind == 1)
+ memcpy (p, dtp->u.p.saved_string, m);
+ else
+ {
+ q = (gfc_char4_t *) p;
+ for (i = 0; i < m; i++)
+ q[i] = (unsigned char) dtp->u.p.saved_string[i];
+ }
+ }
else
/* Just delimiters encountered, nothing to copy but SPACE. */
m = 0;
if (m < (int) size)
- memset (((char *) p) + m, ' ', size - m);
+ {
+ if (kind == 1)
+ memset (((char *) p) + m, ' ', size - m);
+ else
+ {
+ q = (gfc_char4_t *) p;
+ for (i = m; i < (int) size; i++)
+ q[i] = (unsigned char) ' ';
+ }
+ }
break;
case BT_NULL:
{
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_read_scalar (dtp, type, tmp + size*elem, kind, size);
+ list_formatted_read_scalar (dtp, type, tmp + stride*elem, kind, size);
}
}
static void nml_match_name (char *name, int len)
static int nml_query (st_parameter_dt *dtp)
static int nml_get_obj_data (st_parameter_dt *dtp,
- namelist_info **prev_nl, char *)
+ namelist_info **prev_nl, char *, size_t)
calls:
static void nml_untouch_nodes (st_parameter_dt *dtp)
static namelist_info * find_nml_node (st_parameter_dt *dtp,
array_loop_spec * ls, int rank, char *)
static void nml_touch_nodes (namelist_info * nl)
static int nml_read_obj (namelist_info *nl, index_type offset,
- namelist_info **prev_nl, char *,
+ namelist_info **prev_nl, char *, size_t,
index_type clow, index_type chigh)
calls:
-itself- */
namelist_info * nl;
index_type len;
char * p;
+#ifdef HAVE_CRLF
+ static const index_type endlen = 3;
+ static const char endl[] = "\r\n";
+ static const char nmlend[] = "&end\r\n";
+#else
+ static const index_type endlen = 2;
+ static const char endl[] = "\n";
+ static const char nmlend[] = "&end\n";
+#endif
if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
return;
/* "&namelist_name\n" */
len = dtp->namelist_name_len;
-#ifdef HAVE_CRLF
- p = write_block (dtp, len + 3);
-#else
- p = write_block (dtp, len + 2);
-#endif
- if (!p)
- goto query_return;
+ p = write_block (dtp, len + endlen);
+ if (!p)
+ goto query_return;
memcpy (p, "&", 1);
memcpy ((char*)(p + 1), dtp->namelist_name, len);
-#ifdef HAVE_CRLF
- memcpy ((char*)(p + len + 1), "\r\n", 2);
-#else
- memcpy ((char*)(p + len + 1), "\n", 1);
-#endif
+ memcpy ((char*)(p + len + 1), &endl, endlen - 1);
for (nl = dtp->u.p.ionml; nl; nl = nl->next)
{
/* " var_name\n" */
len = strlen (nl->var_name);
-#ifdef HAVE_CRLF
- p = write_block (dtp, len + 3);
-#else
- p = write_block (dtp, len + 2);
-#endif
+ p = write_block (dtp, len + endlen);
if (!p)
goto query_return;
memcpy (p, " ", 1);
memcpy ((char*)(p + 1), nl->var_name, len);
-#ifdef HAVE_CRLF
- memcpy ((char*)(p + len + 1), "\r\n", 2);
-#else
- memcpy ((char*)(p + len + 1), "\n", 1);
-#endif
+ memcpy ((char*)(p + len + 1), &endl, endlen - 1);
}
/* "&end\n" */
-#ifdef HAVE_CRLF
- p = write_block (dtp, 6);
-#else
- p = write_block (dtp, 5);
-#endif
- if (!p)
+ p = write_block (dtp, endlen + 3);
goto query_return;
-#ifdef HAVE_CRLF
- memcpy (p, "&end\r\n", 6);
-#else
- memcpy (p, "&end\n", 5);
-#endif
+ memcpy (p, &nmlend, endlen + 3);
}
/* Flush the stream to force immediate output. */
+ fbuf_flush (dtp->u.p.current_unit, 1);
flush (dtp->u.p.current_unit->s);
unlock_unit (dtp->u.p.current_unit);
}
static try
nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
namelist_info **pprev_nl, char *nml_err_msg,
- index_type clow, index_type chigh)
+ size_t nml_err_msg_size, index_type clow, index_type chigh)
{
namelist_info * cmp;
char * obj_name;
{
if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
- pprev_nl, nml_err_msg, clow, chigh)
- == FAILURE)
+ pprev_nl, nml_err_msg, nml_err_msg_size,
+ clow, chigh) == FAILURE)
{
free_mem (obj_name);
return FAILURE;
goto incr_idx;
default:
- sprintf (nml_err_msg, "Bad type for namelist object %s",
- nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Bad type for namelist object %s", nl->var_name);
internal_error (&dtp->common, nml_err_msg);
goto nml_err_ret;
}
if (dtp->u.p.repeat_count > 1)
{
- sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
- nl->var_name );
- goto nml_err_ret;
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Repeat count too large for namelist object %s", nl->var_name);
+ goto nml_err_ret;
}
return SUCCESS;
static try
nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
- char *nml_err_msg)
+ char *nml_err_msg, size_t nml_err_msg_size)
{
char c;
namelist_info * nl;
namelist_info * root_nl = NULL;
int dim, parsed_rank;
int component_flag;
- char parse_err_msg[30];
index_type clow, chigh;
int non_zero_rank_count;
if (nl == NULL)
{
if (dtp->u.p.nml_read_error && *pprev_nl)
- sprintf (nml_err_msg, "Bad data for namelist object %s",
- (*pprev_nl)->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Bad data for namelist object %s", (*pprev_nl)->var_name);
else
- sprintf (nml_err_msg, "Cannot match namelist object name %s",
- dtp->u.p.saved_string);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Cannot match namelist object name %s",
+ dtp->u.p.saved_string);
goto nml_err_ret;
}
{
parsed_rank = 0;
if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
- parse_err_msg, &parsed_rank) == FAILURE)
+ nml_err_msg, &parsed_rank) == FAILURE)
{
- sprintf (nml_err_msg, "%s for namelist variable %s",
- parse_err_msg, nl->var_name);
+ char *nml_err_msg_end = strchr (nml_err_msg, '\0');
+ snprintf (nml_err_msg_end,
+ nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
+ " for namelist variable %s", nl->var_name);
goto nml_err_ret;
}
{
if (nl->type != GFC_DTYPE_DERIVED)
{
- sprintf (nml_err_msg, "Attempt to get derived component for %s",
- nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Attempt to get derived component for %s", nl->var_name);
goto nml_err_ret;
}
descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
- if (nml_parse_qualifier (dtp, chd, ind, -1, parse_err_msg, &parsed_rank)
+ if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
== FAILURE)
{
- sprintf (nml_err_msg, "%s for namelist variable %s",
- parse_err_msg, nl->var_name);
+ char *nml_err_msg_end = strchr (nml_err_msg, '\0');
+ snprintf (nml_err_msg_end,
+ nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
+ " for namelist variable %s", nl->var_name);
goto nml_err_ret;
}
if (ind[0].step != 1)
{
- sprintf (nml_err_msg,
- "Step not allowed in substring qualifier"
- " for namelist object %s", nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Step not allowed in substring qualifier"
+ " for namelist object %s", nl->var_name);
goto nml_err_ret;
}
if (nl->type == GFC_DTYPE_DERIVED)
nml_touch_nodes (nl);
- if (component_flag)
+ if (component_flag && nl->var_rank > 0)
nl = first_nl;
/* Make sure no extraneous qualifiers are there. */
if (c == '(')
{
- sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
- " namelist object %s", nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Qualifier for a scalar or non-character namelist object %s",
+ nl->var_name);
goto nml_err_ret;
}
/* Make sure there is no more than one non-zero rank object. */
if (non_zero_rank_count > 1)
{
- sprintf (nml_err_msg, "Multiple sub-objects with non-zero rank in"
- " namelist object %s", nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Multiple sub-objects with non-zero rank in namelist object %s",
+ nl->var_name);
non_zero_rank_count = 0;
goto nml_err_ret;
}
if (c != '=')
{
- sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
- nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Equal sign must follow namelist object name %s",
+ nl->var_name);
goto nml_err_ret;
}
- if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
+ if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
+ clow, chigh) == FAILURE)
goto nml_err_ret;
return SUCCESS;
{
char c;
jmp_buf eof_jump;
- char nml_err_msg[100];
+ char nml_err_msg[200];
/* Pointer to the previously read object, in case attempt is made to read
new object name. Should this fail, error message can give previous
name. */
/* A trailing space is required, we give a little lattitude here, 10.9.1. */
c = next_char (dtp);
- if (!is_separator(c))
+ if (!is_separator(c) && c != '!')
{
unget_char (dtp, c);
goto find_nml_name;
}
+ unget_char (dtp, c);
+ eat_separator (dtp);
+
/* Ready to read namelist objects. If there is an error in input
from stdin, output the error message and continue. */
while (!dtp->u.p.input_complete)
{
- if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
+ if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
+ == FAILURE)
{
gfc_unit *u;
OSDN Git Service
