}
+/* 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_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_OS, NULL);
+ generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
return '\0';
}
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;
}
+/* 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;
+ 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;
- goto cleanup;
+
+ /* 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. */
+ if (dtp->u.p.at_eol)
+ finish_separator (dtp);
+ else
+ goto cleanup;
}
}
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 == '?')
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
