dtp->u.p.line_buffer_enabled = 0;
}
- /* Handle the end-of-record condition for internal array unit */
- if (is_array_io(dtp) && dtp->u.p.current_unit->bytes_left == 0)
+ /* Handle the end-of-record and end-of-file conditions for
+ internal array unit. */
+ if (is_array_io(dtp))
{
- c = '\n';
- record = next_array_record (dtp, dtp->u.p.current_unit->ls);
-
- /* Check for "end-of-file" condition */
- if (record == 0)
+ if (dtp->u.p.at_eof)
longjmp (*dtp->u.p.eof_jump, 1);
- record *= dtp->u.p.current_unit->recl;
-
- if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
- longjmp (*dtp->u.p.eof_jump, 1);
+ /* 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);
- dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
- goto done;
+ /* 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_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. */
return 0;
bad_repeat:
+
+ eat_line (dtp);
+ free_saved (dtp);
st_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;
}
static void
l_push_char (st_parameter_dt *dtp, char c)
{
- char *new;
-
if (dtp->u.p.line_buffer == NULL)
{
dtp->u.p.line_buffer = get_mem (SCRATCH_SIZE);
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;
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);
- 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);
- return;
+ goto logical_done;
}
}
dtp->u.p.item_count = 0;
return;
}
- }
+
+ }
bad_logical:
+ free_line (dtp);
+
if (nml_bad_return (dtp, c))
return;
+ eat_line (dtp);
+ free_saved (dtp);
st_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",
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",
dtp->u.p.item_count);
if (nml_bad_return (dtp, c))
return;
+ eat_line (dtp);
+ free_saved (dtp);
st_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;
+ eat_line (dtp);
+ free_saved (dtp);
st_sprintf (message, "Bad real number in item %d of list input",
dtp->u.p.item_count);
-
generate_error (&dtp->common, ERROR_READ_VALUE, message);
}
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 (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;
}
index_type dlen;
index_type m;
index_type obj_name_len;
- void * pdata ;
+ void * pdata;
/* This object not touched in name parsing. */
strcpy (obj_name, nl->var_name);
strcat (obj_name, "%");
+ /* 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
past nested derived types by testing if the potential
*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;
c = next_char (dtp);
if (c != '?')
{
- st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
+ st_sprintf (nml_err_msg, "namelist read: misplaced = sign");
goto nml_err_ret;
}
nml_query (dtp, '=');
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 == '?')
OSDN Git Service
