-/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist input contributed by Paul Thomas
}
+/* Free the line buffer if necessary. */
+
+static void
+free_line (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.line_buffer == NULL)
+ return;
+
+ free_mem (dtp->u.p.line_buffer);
+ dtp->u.p.line_buffer = NULL;
+}
+
+
static char
next_char (st_parameter_dt *dtp)
{
goto done;
}
- length = 1;
+ /* Read from line_buffer if enabled. */
- /* Handle the end-of-record condition for internal array unit */
- if (is_array_io(dtp) && dtp->u.p.current_unit->bytes_left == 0)
+ if (dtp->u.p.line_buffer_enabled)
{
- c = '\n';
- record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+ dtp->u.p.at_eol = 0;
- /* Check for "end-of-file" condition */
- if (record == 0)
- longjmp (*dtp->u.p.eof_jump, 1);
+ c = dtp->u.p.line_buffer[dtp->u.p.item_count];
+ if (c != '\0' && dtp->u.p.item_count < 64)
+ {
+ dtp->u.p.line_buffer[dtp->u.p.item_count] = '\0';
+ dtp->u.p.item_count++;
+ goto done;
+ }
- record *= dtp->u.p.current_unit->recl;
-
- if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+ dtp->u.p.item_count = 0;
+ dtp->u.p.line_buffer_enabled = 0;
+ }
+
+ /* Handle the end-of-record and end-of-file conditions for
+ internal array unit. */
+ if (is_array_io (dtp))
+ {
+ if (dtp->u.p.at_eof)
longjmp (*dtp->u.p.eof_jump, 1);
- dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
- goto done;
+ /* Check for "end-of-record" condition. */
+ if (dtp->u.p.current_unit->bytes_left == 0)
+ {
+ c = '\n';
+ record = next_array_record (dtp, dtp->u.p.current_unit->ls);
+
+ /* Check for "end-of-file" condition. */
+ if (record == 0)
+ {
+ dtp->u.p.at_eof = 1;
+ goto done;
+ }
+
+ record *= dtp->u.p.current_unit->recl;
+ if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+ longjmp (*dtp->u.p.eof_jump, 1);
+
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+ goto done;
+ }
}
- /* Get the next character and handle end-of-record conditions */
+ /* Get the next character and handle end-of-record conditions. */
+
+ length = 1;
+
p = salloc_r (dtp->u.p.current_unit->s, &length);
+
+ if (is_stream_io (dtp))
+ dtp->u.p.current_unit->strm_pos++;
- if (is_internal_unit(dtp))
+ if (is_internal_unit (dtp))
{
- if (is_array_io(dtp))
+ if (is_array_io (dtp))
{
/* End of record is handled in the next pass through, above. The
- check for NULL here is cautionary. */
+ check for NULL here is cautionary. */
if (p == NULL)
{
generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
if (n == '\n')
dtp->u.p.at_eol = 1;
else
- {
- unget_char (dtp, n);
- unget_char (dtp, c);
- }
+ unget_char (dtp, n);
break;
case '\n':
case '/':
dtp->u.p.input_complete = 1;
- if (!dtp->u.p.namelist_mode) next_record (dtp, 0);
+ if (!dtp->u.p.namelist_mode)
+ return;
break;
case '\n':
}
}
+
+/* This function reads characters through to the end of the current line and
+ just ignores them. */
+
+static void
+eat_line (st_parameter_dt *dtp)
+{
+ char c;
+ if (!is_internal_unit (dtp))
+ do
+ c = next_char (dtp);
+ while (c != '\n');
+}
+
+
/* This function is needed to catch bad conversions so that namelist can
attempt to see if dtp->u.p.saved_string contains a new object name rather
than a bad value. */
if (dtp->u.p.repeat_count == 0)
{
- st_sprintf (message, "Zero repeat count in item %d of list input",
- dtp->u.p.item_count);
+ sprintf (message, "Zero repeat count in item %d of list input",
+ dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
m = 1;
overflow:
if (length == -1)
- st_sprintf (message, "Repeat count overflow in item %d of list input",
- dtp->u.p.item_count);
+ sprintf (message, "Repeat count overflow in item %d of list input",
+ dtp->u.p.item_count);
else
- st_sprintf (message, "Integer overflow while reading item %d",
- dtp->u.p.item_count);
+ sprintf (message, "Integer overflow while reading item %d",
+ dtp->u.p.item_count);
free_saved (dtp);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
if (repeat > MAX_REPEAT)
{
- st_sprintf (message,
- "Repeat count overflow in item %d of list input",
- dtp->u.p.item_count);
+ sprintf (message,
+ "Repeat count overflow in item %d of list input",
+ dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
case '*':
if (repeat == 0)
{
- st_sprintf (message,
- "Zero repeat count in item %d of list input",
- dtp->u.p.item_count);
+ sprintf (message,
+ "Zero repeat count in item %d of list input",
+ dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
return 0;
bad_repeat:
- st_sprintf (message, "Bad repeat count in item %d of list input",
- dtp->u.p.item_count);
+ eat_line (dtp);
+ free_saved (dtp);
+ sprintf (message, "Bad repeat count in item %d of list input",
+ dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
return 1;
}
+/* To read a logical we have to look ahead in the input stream to make sure
+ there is not an equal sign indicating a variable name. To do this we use
+ line_buffer to point to a temporary buffer, pushing characters there for
+ possible later reading. */
+
+static void
+l_push_char (st_parameter_dt *dtp, char c)
+{
+ if (dtp->u.p.line_buffer == NULL)
+ {
+ dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
+ memset (dtp->u.p.line_buffer, 0, SCRATCH_SIZE);
+ }
+
+ dtp->u.p.line_buffer[dtp->u.p.item_count++] = c;
+}
+
+
/* Read a logical character on the input. */
static void
read_logical (st_parameter_dt *dtp, int length)
{
char c, message[100];
- int v;
+ int i, v;
if (parse_repeat (dtp))
return;
- c = next_char (dtp);
+ c = tolower (next_char (dtp));
+ l_push_char (dtp, c);
switch (c)
{
case 't':
- case 'T':
v = 1;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+
+ if (!is_separator(c))
+ goto possible_name;
+
+ unget_char (dtp, c);
break;
case 'f':
- case 'F':
v = 0;
- break;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (!is_separator(c))
+ goto possible_name;
+
+ unget_char (dtp, c);
+ break;
case '.':
- c = next_char (dtp);
+ c = tolower (next_char (dtp));
switch (c)
{
- case 't':
- case 'T':
- v = 1;
- break;
- case 'f':
- case 'F':
- v = 0;
- break;
- default:
- goto bad_logical;
+ case 't':
+ v = 1;
+ break;
+ case 'f':
+ v = 0;
+ break;
+ default:
+ goto bad_logical;
}
break;
unget_char (dtp, c);
eat_separator (dtp);
- free_saved (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);
return;
+ possible_name:
+
+ for(i = 0; i < 63; i++)
+ {
+ c = next_char (dtp);
+ if (is_separator(c))
+ {
+ /* All done if this is not a namelist read. */
+ if (!dtp->u.p.namelist_mode)
+ goto logical_done;
+
+ unget_char (dtp, c);
+ eat_separator (dtp);
+ c = next_char (dtp);
+ if (c != '=')
+ {
+ unget_char (dtp, c);
+ goto logical_done;
+ }
+ }
+
+ l_push_char (dtp, c);
+ if (c == '=')
+ {
+ dtp->u.p.nml_read_error = 1;
+ dtp->u.p.line_buffer_enabled = 1;
+ dtp->u.p.item_count = 0;
+ return;
+ }
+
+ }
+
bad_logical:
+ free_line (dtp);
+
if (nml_bad_return (dtp, c))
return;
- st_sprintf (message, "Bad logical value while reading item %d",
+ eat_line (dtp);
+ free_saved (dtp);
+ sprintf (message, "Bad logical value while reading item %d",
dtp->u.p.item_count);
-
generate_error (&dtp->common, ERROR_READ_VALUE, message);
+ return;
+
+ 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);
+ free_saved (dtp);
+ free_line (dtp);
}
if (nml_bad_return (dtp, c))
return;
-
+
+ eat_line (dtp);
free_saved (dtp);
-
- st_sprintf (message, "Bad integer for item %d in list input",
+ sprintf (message, "Bad integer for item %d in list input",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
else
{
free_saved (dtp);
- st_sprintf (message, "Invalid string input in item %d",
+ sprintf (message, "Invalid string input in item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
return m;
bad:
+
+ if (nml_bad_return (dtp, c))
+ return 0;
+
+ eat_line (dtp);
free_saved (dtp);
- st_sprintf (message, "Bad floating point number for item %d",
+ sprintf (message, "Bad floating point number for item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, ERROR_READ_VALUE, message);
if (nml_bad_return (dtp, c))
return;
- st_sprintf (message, "Bad complex value in item %d of list input",
+ eat_line (dtp);
+ free_saved (dtp);
+ sprintf (message, "Bad complex value in item %d of list input",
dtp->u.p.item_count);
-
generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
if (nml_bad_return (dtp, c))
return;
- st_sprintf (message, "Bad real number in item %d of list input",
+ eat_line (dtp);
+ free_saved (dtp);
+ sprintf (message, "Bad real number in item %d of list input",
dtp->u.p.item_count);
-
generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
{
- st_sprintf (message, "Read type %s where %s was expected for item %d",
+ sprintf (message, "Read type %s where %s was expected for item %d",
type_name (dtp->u.p.saved_type), type_name (type),
dtp->u.p.item_count);
if (dtp->u.p.saved_length != len)
{
- st_sprintf (message,
+ sprintf (message,
"Read kind %d %s where kind %d is required for item %d",
dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
dtp->u.p.item_count);
c = eat_spaces (dtp);
if (is_separator (c))
- { /* Found a null value. */
+ {
+ /* Found a null value. */
eat_separator (dtp);
dtp->u.p.repeat_count = 0;
- /* eat_separator sets this flag if the separator was a comma */
+ /* eat_separator sets this flag if the separator was a comma. */
if (dtp->u.p.comma_flag)
goto cleanup;
- /* eat_separator sets this flag if the separator was a \n or \r */
+ /* eat_separator sets this flag if the separator was a \n or \r. */
if (dtp->u.p.at_eol)
finish_separator (dtp);
else
else
{
eat_spaces (dtp);
- /* trailing spaces prior to end of line */
+ /* Trailing spaces prior to end of line. */
if (dtp->u.p.at_eol)
finish_separator (dtp);
}
int indx;
int neg;
int null_flag;
+ int is_array_section;
char c;
+ is_array_section = 0;
+ dtp->u.p.expanded_read = 0;
+
/* The next character in the stream should be the '('. */
c = next_char (dtp);
switch (c)
{
case ':':
+ is_array_section = 1;
break;
case ',': case ')':
if ((c==',' && dim == rank -1)
|| (c==')' && dim < rank -1))
{
- st_sprintf (parse_err_msg,
- "Bad number of index fields");
+ sprintf (parse_err_msg,
+ "Bad number of index fields");
goto err_ret;
}
break;
break;
default:
- st_sprintf (parse_err_msg, "Bad character in index");
+ sprintf (parse_err_msg, "Bad character in index");
goto err_ret;
}
if ((c == ',' || c == ')') && indx == 0
&& dtp->u.p.saved_string == 0)
{
- st_sprintf (parse_err_msg, "Null index field");
+ sprintf (parse_err_msg, "Null index field");
goto err_ret;
}
if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
|| (indx == 2 && dtp->u.p.saved_string == 0))
{
- st_sprintf(parse_err_msg, "Bad index triplet");
+ sprintf(parse_err_msg, "Bad index triplet");
goto err_ret;
}
/* Now read the index. */
if (convert_integer (dtp, sizeof(ssize_t), neg))
{
- st_sprintf (parse_err_msg, "Bad integer in index");
+ sprintf (parse_err_msg, "Bad integer in index");
goto err_ret;
}
break;
if (indx == 0)
{
memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
- ls[dim].end = ls[dim].start;
+
+ /* If -std=f95/2003 or an array section is specified,
+ do not allow excess data to be processed. */
+ if (is_array_section == 1
+ || compile_options.allow_std < GFC_STD_GNU)
+ ls[dim].end = ls[dim].start;
+ else
+ dtp->u.p.expanded_read = 1;
}
break;
}
|| (ls[dim].end > (ssize_t)ad[dim].ubound)
|| (ls[dim].end < (ssize_t)ad[dim].lbound))
{
- st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
+ sprintf (parse_err_msg, "Index %d out of range", dim + 1);
goto err_ret;
}
if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0)
|| (ls[dim].step == 0))
{
- st_sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
+ sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
goto err_ret;
}
index_type len = strlen (nl->var_name) + 1;
int dim;
char * ext_name = (char*)get_mem (len + 1);
- strcpy (ext_name, nl->var_name);
- strcat (ext_name, "%");
+ memcpy (ext_name, nl->var_name, len-1);
+ memcpy (ext_name + len - 1, "%", 2);
for (nl = nl->next; nl; nl = nl->next)
{
if (strncmp (nl->var_name, ext_name, len) == 0)
index_type dlen;
index_type m;
index_type obj_name_len;
- void * pdata ;
+ void * pdata;
/* This object not touched in name parsing. */
case GFC_DTYPE_DERIVED:
obj_name_len = strlen (nl->var_name) + 1;
obj_name = get_mem (obj_name_len+1);
- strcpy (obj_name, nl->var_name);
- strcat (obj_name, "%");
+ memcpy (obj_name, nl->var_name, obj_name_len-1);
+ memcpy (obj_name + obj_name_len - 1, "%", 2);
+
+ /* If reading a derived type, disable the expanded read warning
+ since a single object can have multiple reads. */
+ dtp->u.p.expanded_read = 0;
/* Now loop over the components. Update the component pointer
with the return value from nml_write_obj. This loop jumps
goto incr_idx;
default:
- st_sprintf (nml_err_msg, "Bad type for namelist object %s",
+ sprintf (nml_err_msg, "Bad type for namelist object %s",
nl->var_name);
internal_error (&dtp->common, nml_err_msg);
goto nml_err_ret;
*pprev_nl = nl;
if (dtp->u.p.nml_read_error)
- return SUCCESS;
+ {
+ dtp->u.p.expanded_read = 0;
+ return SUCCESS;
+ }
if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
- goto incr_idx;
-
+ {
+ dtp->u.p.expanded_read = 0;
+ goto incr_idx;
+ }
/* Note the switch from GFC_DTYPE_type to BT_type at this point.
This comes about because the read functions return BT_types. */
memcpy (pdata, dtp->u.p.saved_string, m);
if (m < dlen)
memset ((void*)( pdata + m ), ' ', dlen - m);
- break;
+ break;
default:
break;
}
- /* Break out of loop if scalar. */
+ /* Warn if a non-standard expanded read occurs. A single read of a
+ single object is acceptable. If a second read occurs, issue a warning
+ and set the flag to zero to prevent further warnings. */
+ if (dtp->u.p.expanded_read == 2)
+ {
+ notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read.");
+ dtp->u.p.expanded_read = 0;
+ }
+ /* If the expanded read warning flag is set, increment it,
+ indicating that a single read has occurred. */
+ if (dtp->u.p.expanded_read >= 1)
+ dtp->u.p.expanded_read++;
+
+ /* Break out of loop if scalar. */
if (!nl->var_rank)
break;
if (dtp->u.p.repeat_count > 1)
{
- st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
+ sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
nl->var_name );
goto nml_err_ret;
}
c = next_char (dtp);
if (c != '?')
{
- st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
+ sprintf (nml_err_msg, "namelist read: misplaced = sign");
goto nml_err_ret;
}
nml_query (dtp, '=');
nml_match_name (dtp, "end", 3);
if (dtp->u.p.nml_read_error)
{
- st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
+ sprintf (nml_err_msg, "namelist not terminated with / or &end");
goto nml_err_ret;
}
case '/':
if (nl == NULL)
{
if (dtp->u.p.nml_read_error && *pprev_nl)
- st_sprintf (nml_err_msg, "Bad data for namelist object %s",
+ sprintf (nml_err_msg, "Bad data for namelist object %s",
(*pprev_nl)->var_name);
else
- st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
+ sprintf (nml_err_msg, "Cannot match namelist object name %s",
dtp->u.p.saved_string);
goto nml_err_ret;
if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
parse_err_msg) == FAILURE)
{
- st_sprintf (nml_err_msg, "%s for namelist variable %s",
+ sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
if (nl->type != GFC_DTYPE_DERIVED)
{
- st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
+ sprintf (nml_err_msg, "Attempt to get derived component for %s",
nl->var_name);
goto nml_err_ret;
}
if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
{
- st_sprintf (nml_err_msg, "%s for namelist variable %s",
+ sprintf (nml_err_msg, "%s for namelist variable %s",
parse_err_msg, nl->var_name);
goto nml_err_ret;
}
if (ind[0].step != 1)
{
- st_sprintf (nml_err_msg,
+ sprintf (nml_err_msg,
"Bad step in substring for namelist object %s",
nl->var_name);
goto nml_err_ret;
if (c == '(')
{
- st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
+ sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
" namelist object %s", nl->var_name);
goto nml_err_ret;
}
if (c != '=')
{
- st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
+ sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
nl->var_name);
goto nml_err_ret;
}
dtp->u.p.namelist_mode = 1;
dtp->u.p.input_complete = 0;
+ dtp->u.p.expanded_read = 0;
dtp->u.p.eof_jump = &eof_jump;
if (setjmp (eof_jump))
case '&':
break;
+ case '!':
+ eat_line (dtp);
+ goto find_nml_name;
+
case '=':
c = next_char (dtp);
if (c == '?')
dtp->u.p.eof_jump = NULL;
free_saved (dtp);
+ free_line (dtp);
return;
/* All namelist error calls return from here */
dtp->u.p.eof_jump = NULL;
free_saved (dtp);
+ free_line (dtp);
generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
return;
}
OSDN Git Service
