-/* 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
Boston, MA 02110-1301, USA. */
-#include "config.h"
+#include "io.h"
#include <string.h>
#include <ctype.h>
-#include "libgfortran.h"
-#include "io.h"
/* List directed input. Several parsing subroutines are practically
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;
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);
+ generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
return '\0';
}
{
if (p == NULL)
{
- generate_error (&dtp->common, ERROR_OS, NULL);
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
return '\0';
}
if (length == 0)
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':
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);
+ generate_error (&dtp->common, LIBERROR_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);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
}
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);
+ generate_error (&dtp->common, LIBERROR_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);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
}
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);
+ sprintf (message, "Bad repeat count in item %d of list input",
+ dtp->u.p.item_count);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
}
eat_line (dtp);
free_saved (dtp);
- st_sprintf (message, "Bad logical value while reading item %d",
+ sprintf (message, "Bad logical value while reading item %d",
dtp->u.p.item_count);
- generate_error (&dtp->common, ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return;
logical_done:
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);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return;
goto get_string;
default:
- if (dtp->u.p.namelist_mode)
+ if (dtp->u.p.namelist_mode
+ && (dtp->u.p.current_unit->flags.delim == DELIM_APOSTROPHE
+ || dtp->u.p.current_unit->flags.delim == DELIM_QUOTE))
{
unget_char (dtp,c);
return;
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);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
}
}
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);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
}
eat_line (dtp);
free_saved (dtp);
- st_sprintf (message, "Bad complex value in item %d of list input",
+ sprintf (message, "Bad complex value in item %d of list input",
dtp->u.p.item_count);
- generate_error (&dtp->common, ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
}
eat_line (dtp);
free_saved (dtp);
- st_sprintf (message, "Bad real number in item %d of list input",
+ sprintf (message, "Bad real number in item %d of list input",
dtp->u.p.item_count);
- generate_error (&dtp->common, ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, LIBERROR_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);
- generate_error (&dtp->common, ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
}
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);
- generate_error (&dtp->common, ERROR_READ_VALUE, message);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
}
dtp->u.p.eof_jump = &eof_jump;
if (setjmp (eof_jump))
{
- generate_error (&dtp->common, ERROR_END, NULL);
+ generate_error (&dtp->common, LIBERROR_END, NULL);
goto cleanup;
}
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);
}
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;
|| (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. */
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;
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: misplaced = 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;
}
if (setjmp (eof_jump))
{
dtp->u.p.eof_jump = NULL;
- generate_error (&dtp->common, ERROR_END, NULL);
+ generate_error (&dtp->common, LIBERROR_END, NULL);
return;
}
case '&':
break;
+ case '!':
+ eat_line (dtp);
+ goto find_nml_name;
+
case '=':
c = next_char (dtp);
if (c == '?')
if (dtp->u.p.nml_read_error)
goto find_nml_name;
+ /* A trailing space is required, we give a little lattitude here, 10.9.1. */
+ c = next_char (dtp);
+ if (!is_separator(c))
+ {
+ unget_char (dtp, c);
+ goto find_nml_name;
+ }
+
/* Ready to read namelist objects. If there is an error in input
from stdin, output the error message and continue. */
dtp->u.p.eof_jump = NULL;
free_saved (dtp);
free_line (dtp);
- generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
return;
}
OSDN Git Service
