-/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
+/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010, 2011
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).
+This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
+the Free Software Foundation; either version 3, or (at your option)
any later version.
-In addition to the permissions in the GNU General Public License, the
-Free Software Foundation gives you unlimited permission to link the
-compiled version of this file into combinations with other programs,
-and to distribute those combinations without any restriction coming
-from the use of this file. (The General Public License restrictions
-do apply in other respects; for example, they cover modification of
-the file, and distribution when not linked into a combine
-executable.)
-
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
-You should have received a copy of the GNU General Public License
-along with Libgfortran; see the file COPYING. If not, write to
-the Free Software Foundation, 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA. */
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+<http://www.gnu.org/licenses/>. */
#include "io.h"
+#include "fbuf.h"
+#include "unix.h"
#include <string.h>
#include <stdlib.h>
#include <ctype.h>
#define MAX_REPEAT 200000000
-#ifndef HAVE_SNPRINTF
-# undef snprintf
-# define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
-#endif
+
+#define MSGLEN 100
/* Save a character to a string buffer, enlarging it as necessary. */
if (dtp->u.p.saved_string == NULL)
return;
- free_mem (dtp->u.p.saved_string);
+ free (dtp->u.p.saved_string);
dtp->u.p.saved_string = NULL;
dtp->u.p.saved_used = 0;
if (dtp->u.p.line_buffer == NULL)
return;
- free_mem (dtp->u.p.line_buffer);
+ free (dtp->u.p.line_buffer);
dtp->u.p.line_buffer = NULL;
}
-static char
+static int
next_char (st_parameter_dt *dtp)
{
ssize_t length;
gfc_offset record;
- char c;
- int cc;
+ int c;
- if (dtp->u.p.last_char != '\0')
+ if (dtp->u.p.last_char != EOF - 1)
{
dtp->u.p.at_eol = 0;
c = dtp->u.p.last_char;
- dtp->u.p.last_char = '\0';
+ dtp->u.p.last_char = EOF - 1;
goto done;
}
if (is_array_io (dtp))
{
if (dtp->u.p.at_eof)
- longjmp (*dtp->u.p.eof_jump, 1);
+ return EOF;
/* Check for "end-of-record" condition. */
if (dtp->u.p.current_unit->bytes_left == 0)
record *= dtp->u.p.current_unit->recl;
if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
- longjmp (*dtp->u.p.eof_jump, 1);
+ return EOF;
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
goto done;
if (is_internal_unit (dtp))
{
- length = sread (dtp->u.p.current_unit->s, &c, 1);
+ char cc;
+ length = sread (dtp->u.p.current_unit->s, &cc, 1);
+ c = cc;
if (length < 0)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
else
{
if (dtp->u.p.at_eof)
- longjmp (*dtp->u.p.eof_jump, 1);
+ return EOF;
if (length == 0)
{
c = '\n';
}
else
{
- cc = fbuf_getc (dtp->u.p.current_unit);
-
- if (cc == EOF)
- {
- if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
- longjmp (*dtp->u.p.eof_jump, 1);
- dtp->u.p.current_unit->endfile = AT_ENDFILE;
- c = '\n';
- }
- else
- c = (char) cc;
- if (is_stream_io (dtp) && cc != EOF)
+ c = fbuf_getc (dtp->u.p.current_unit);
+ if (c != EOF && is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
-
}
done:
- dtp->u.p.at_eol = (c == '\n' || c == '\r');
+ dtp->u.p.at_eol = (c == '\n' || c == '\r' || c == EOF);
return c;
}
/* Push a character back onto the input. */
static void
-unget_char (st_parameter_dt *dtp, char c)
+unget_char (st_parameter_dt *dtp, int c)
{
dtp->u.p.last_char = c;
}
/* Skip over spaces in the input. Returns the nonspace character that
terminated the eating and also places it back on the input. */
-static char
+static int
eat_spaces (st_parameter_dt *dtp)
{
- char c;
+ int c;
do
- {
- c = next_char (dtp);
- }
- while (c == ' ' || c == '\t');
+ c = next_char (dtp);
+ while (c != EOF && (c == ' ' || c == '\t'));
unget_char (dtp, c);
return c;
}
-/* This function reads characters through to the end of the current line and
- just ignores them. */
+/* This function reads characters through to the end of the current
+ line and just ignores them. Returns 0 for success and LIBERROR_END
+ if it hit EOF. */
-static void
+static int
eat_line (st_parameter_dt *dtp)
{
- char c;
- if (!is_internal_unit (dtp))
- do
- c = next_char (dtp);
- while (c != '\n');
+ int c;
+
+ do
+ c = next_char (dtp);
+ while (c != EOF && c != '\n');
+ if (c == EOF)
+ return LIBERROR_END;
+ return 0;
}
separator, we stop reading. If there are more input items, we
continue reading the separator with finish_separator() which takes
care of the fact that we may or may not have seen a comma as part
- of the separator. */
+ of the separator.
-static void
+ Returns 0 for success, and non-zero error code otherwise. */
+
+static int
eat_separator (st_parameter_dt *dtp)
{
- char c, n;
+ int c, n;
+ int err = 0;
eat_spaces (dtp);
dtp->u.p.comma_flag = 0;
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return LIBERROR_END;
switch (c)
{
case ',':
case '\r':
dtp->u.p.at_eol = 1;
- n = next_char(dtp);
+ if ((n = next_char(dtp)) == EOF)
+ return LIBERROR_END;
if (n != '\n')
{
unget_char (dtp, n);
{
do
{
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return LIBERROR_END;
if (c == '!')
{
- eat_line (dtp);
- c = next_char (dtp);
- if (c == '!')
- {
- eat_line (dtp);
- c = next_char (dtp);
- }
+ err = eat_line (dtp);
+ if (err)
+ return err;
+ c = '\n';
}
}
while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
case '!':
if (dtp->u.p.namelist_mode)
{ /* Eat a namelist comment. */
- do
- c = next_char (dtp);
- while (c != '\n');
+ err = eat_line (dtp);
+ if (err)
+ return err;
break;
}
unget_char (dtp, c);
break;
}
+ return err;
}
/* Finish processing a separator that was interrupted by a newline.
If we're here, then another data item is present, so we finish what
- we started on the previous line. */
+ we started on the previous line. Return 0 on success, error code
+ on failure. */
-static void
+static int
finish_separator (st_parameter_dt *dtp)
{
- char c;
+ int c;
+ int err;
restart:
eat_spaces (dtp);
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return LIBERROR_END;
switch (c)
{
case ',':
unget_char (dtp, c);
else
{
- c = eat_spaces (dtp);
+ if ((c = eat_spaces (dtp)) == EOF)
+ return LIBERROR_END;
if (c == '\n' || c == '\r')
goto restart;
}
case '/':
dtp->u.p.input_complete = 1;
if (!dtp->u.p.namelist_mode)
- return;
+ return err;
break;
case '\n':
case '!':
if (dtp->u.p.namelist_mode)
{
- do
- c = next_char (dtp);
- while (c != '\n');
-
+ err = eat_line (dtp);
+ if (err)
+ return err;
goto restart;
}
unget_char (dtp, c);
break;
}
+ return err;
}
static int
convert_integer (st_parameter_dt *dtp, int length, int negative)
{
- char c, *buffer, message[100];
+ char c, *buffer, message[MSGLEN];
int m;
GFC_INTEGER_LARGEST v, max, max10;
if (dtp->u.p.repeat_count == 0)
{
- sprintf (message, "Zero repeat count in item %d of list input",
+ snprintf (message, MSGLEN, "Zero repeat count in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
overflow:
if (length == -1)
- sprintf (message, "Repeat count overflow in item %d of list input",
+ snprintf (message, MSGLEN, "Repeat count overflow in item %d of list input",
dtp->u.p.item_count);
else
- sprintf (message, "Integer overflow while reading item %d",
+ snprintf (message, MSGLEN, "Integer overflow while reading item %d",
dtp->u.p.item_count);
free_saved (dtp);
static int
parse_repeat (st_parameter_dt *dtp)
{
- char c, message[100];
- int repeat;
+ char message[MSGLEN];
+ int c, repeat;
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad_repeat;
switch (c)
{
CASE_DIGITS:
if (repeat > MAX_REPEAT)
{
- sprintf (message,
+ snprintf (message, MSGLEN,
"Repeat count overflow in item %d of list input",
dtp->u.p.item_count);
case '*':
if (repeat == 0)
{
- sprintf (message,
+ snprintf (message, MSGLEN,
"Zero repeat count in item %d of list input",
dtp->u.p.item_count);
bad_repeat:
- eat_line (dtp);
free_saved (dtp);
- sprintf (message, "Bad repeat count in item %d of list input",
+ if (c == EOF)
+ {
+ hit_eof (dtp);
+ return 1;
+ }
+ else
+ eat_line (dtp);
+ snprintf (message, MSGLEN, "Bad repeat count in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
static void
read_logical (st_parameter_dt *dtp, int length)
{
- char c, message[100];
- int i, v;
+ char message[MSGLEN];
+ int c, i, v;
if (parse_repeat (dtp))
return;
c = next_char (dtp);
l_push_char (dtp, c);
- if (!is_separator(c))
+ if (!is_separator(c) && c != EOF)
goto possible_name;
unget_char (dtp, c);
c = next_char (dtp);
l_push_char (dtp, c);
- if (!is_separator(c))
+ if (!is_separator(c) && c != EOF)
goto possible_name;
unget_char (dtp, c);
/* Eat trailing garbage. */
do
- {
- c = next_char (dtp);
- }
- while (!is_separator (c));
+ c = next_char (dtp);
+ while (c != EOF && !is_separator (c));
unget_char (dtp, c);
eat_separator (dtp);
if (nml_bad_return (dtp, c))
return;
- eat_line (dtp);
free_saved (dtp);
- sprintf (message, "Bad logical value while reading item %d",
+ if (c == EOF)
+ {
+ hit_eof (dtp);
+ return;
+ }
+ else if (c != '\n')
+ eat_line (dtp);
+ snprintf (message, MSGLEN, "Bad logical value while reading item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return;
static void
read_integer (st_parameter_dt *dtp, int length)
{
- char c, message[100];
- int negative;
+ char message[MSGLEN];
+ int c, negative;
negative = 0;
/* Fall through... */
case '+':
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad_integer;
goto get_integer;
CASE_SEPARATORS: /* Single null. */
goto repeat;
CASE_SEPARATORS: /* Not a repeat count. */
+ case EOF:
goto done;
default:
/* Get the real integer. */
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad_integer;
switch (c)
{
CASE_DIGITS:
break;
CASE_SEPARATORS:
+ case EOF:
goto done;
default:
if (nml_bad_return (dtp, c))
return;
-
- eat_line (dtp);
- free_saved (dtp);
- sprintf (message, "Bad integer for item %d in list input",
+
+ free_saved (dtp);
+ if (c == EOF)
+ {
+ hit_eof (dtp);
+ return;
+ }
+ else if (c != '\n')
+ eat_line (dtp);
+ snprintf (message, MSGLEN, "Bad integer for item %d in list input",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
static void
read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
{
- char c, quote, message[100];
+ char quote, message[MSGLEN];
+ int c;
quote = ' '; /* Space means no quote character. */
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto eof;
switch (c)
{
CASE_DIGITS:
for (;;)
{
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto eof;
switch (c)
{
CASE_DIGITS:
/* Now get the real string. */
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto eof;
switch (c)
{
CASE_SEPARATORS:
get_string:
for (;;)
{
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto done_eof;
switch (c)
{
case '"':
/* See if we have a doubled quote character or the end of
the string. */
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto eof;
if (c == quote)
{
push_char (dtp, quote);
invalid. */
done:
c = next_char (dtp);
- if (is_separator (c) || c == '!')
+ done_eof:
+ if (is_separator (c) || c == '!' || c == EOF)
{
unget_char (dtp, c);
eat_separator (dtp);
dtp->u.p.saved_type = BT_CHARACTER;
free_line (dtp);
}
- else
+ else
{
free_saved (dtp);
- sprintf (message, "Invalid string input in item %d",
+ snprintf (message, MSGLEN, "Invalid string input in item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
}
+ return;
+
+ eof:
+ free_saved (dtp);
+ hit_eof (dtp);
}
static int
parse_real (st_parameter_dt *dtp, void *buffer, int length)
{
- char c, message[100];
- int m, seen_dp;
+ char message[MSGLEN];
+ int c, m, seen_dp;
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad;
+
if (c == '-' || c == '+')
{
push_char (dtp, c);
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad;
}
if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
for (;;)
{
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad;
if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
case '+':
push_char (dtp, 'e');
push_char (dtp, c);
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad;
goto exp2;
CASE_SEPARATORS:
- unget_char (dtp, c);
goto done;
default:
}
exp1:
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad;
if (c != '-' && c != '+')
push_char (dtp, '+');
else
for (;;)
{
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad;
switch (c)
{
CASE_DIGITS:
return m;
+ done_infnan:
+ unget_char (dtp, c);
+ push_char (dtp, '\0');
+
+ m = convert_infnan (dtp, buffer, dtp->u.p.saved_string, length);
+ free_saved (dtp);
+
+ return m;
+
inf_nan:
/* Match INF and Infinity. */
if ((c == 'i' || c == 'I')
push_char (dtp, 'i');
push_char (dtp, 'n');
push_char (dtp, 'f');
- goto done;
+ goto done_infnan;
}
} /* Match NaN. */
else if (((c = next_char (dtp)) == 'a' || c == 'A')
push_char (dtp, 'n');
push_char (dtp, 'a');
push_char (dtp, 'n');
- goto done;
+
+ /* Match "NAN(alphanum)". */
+ if (c == '(')
+ {
+ for ( ; c != ')'; c = next_char (dtp))
+ if (is_separator (c))
+ goto bad;
+
+ c = next_char (dtp);
+ if (is_separator (c))
+ unget_char (dtp, c);
+ }
+ goto done_infnan;
}
bad:
if (nml_bad_return (dtp, c))
return 0;
- eat_line (dtp);
free_saved (dtp);
- sprintf (message, "Bad floating point number for item %d",
+ if (c == EOF)
+ {
+ hit_eof (dtp);
+ return 1;
+ }
+ else if (c != '\n')
+ eat_line (dtp);
+ snprintf (message, MSGLEN, "Bad floating point number for item %d",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
what it is right away. */
static void
-read_complex (st_parameter_dt *dtp, int kind, size_t size)
+read_complex (st_parameter_dt *dtp, void * dest, int kind, size_t size)
{
- char message[100];
- char c;
+ char message[MSGLEN];
+ int c;
if (parse_repeat (dtp))
return;
goto bad_complex;
}
+eol_1:
eat_spaces (dtp);
- if (parse_real (dtp, dtp->u.p.value, kind))
+ c = next_char (dtp);
+ if (c == '\n' || c== '\r')
+ goto eol_1;
+ else
+ unget_char (dtp, c);
+
+ if (parse_real (dtp, dest, kind))
return;
-eol_1:
+eol_2:
eat_spaces (dtp);
c = next_char (dtp);
if (c == '\n' || c== '\r')
- goto eol_1;
+ goto eol_2;
else
unget_char (dtp, c);
!= (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
goto bad_complex;
-eol_2:
+eol_3:
eat_spaces (dtp);
c = next_char (dtp);
if (c == '\n' || c== '\r')
- goto eol_2;
+ goto eol_3;
else
unget_char (dtp, c);
- if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
+ if (parse_real (dtp, dest + size / 2, kind))
return;
-
+
+eol_4:
eat_spaces (dtp);
+ c = next_char (dtp);
+ if (c == '\n' || c== '\r')
+ goto eol_4;
+ else
+ unget_char (dtp, c);
+
if (next_char (dtp) != ')')
goto bad_complex;
if (nml_bad_return (dtp, c))
return;
- eat_line (dtp);
free_saved (dtp);
- sprintf (message, "Bad complex value in item %d of list input",
+ if (c == EOF)
+ {
+ hit_eof (dtp);
+ return;
+ }
+ else if (c != '\n')
+ eat_line (dtp);
+ snprintf (message, MSGLEN, "Bad complex value in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
}
/* Parse a real number with a possible repeat count. */
static void
-read_real (st_parameter_dt *dtp, int length)
+read_real (st_parameter_dt *dtp, void * dest, int length)
{
- char c, message[100];
+ char message[MSGLEN];
+ int c;
int seen_dp;
int is_inf;
/* Now get the number itself. */
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad_real;
if (is_separator (c))
{ /* Repeated null value. */
unget_char (dtp, c);
{
got_sign:
push_char (dtp, c);
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad_real;
}
if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
break;
CASE_SEPARATORS:
+ case EOF:
goto done;
case '.':
exp1:
push_char (dtp, 'e');
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ goto bad_real;
if (c != '+' && c != '-')
push_char (dtp, '+');
else
unget_char (dtp, c);
eat_separator (dtp);
push_char (dtp, '\0');
- if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
+ if (convert_real (dtp, dest, dtp->u.p.saved_string, length))
return;
free_saved (dtp);
goto unwind;
c = next_char (dtp);
l_push_char (dtp, c);
+
+ /* Match NAN(alphanum). */
+ if (c == '(')
+ {
+ for (c = next_char (dtp); c != ')'; c = next_char (dtp))
+ if (is_separator (c))
+ goto unwind;
+ else
+ l_push_char (dtp, c);
+
+ l_push_char (dtp, ')');
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ }
}
if (!is_separator (c))
if (c == ' ' || c =='\n' || c == '\r')
{
do
- c = next_char (dtp);
+ {
+ if ((c = next_char (dtp)) == EOF)
+ goto bad_real;
+ }
while (c == ' ' || c =='\n' || c == '\r');
l_push_char (dtp, c);
}
free_line (dtp);
- goto done;
+ unget_char (dtp, c);
+ eat_separator (dtp);
+ push_char (dtp, '\0');
+ if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length))
+ return;
+
+ free_saved (dtp);
+ dtp->u.p.saved_type = BT_REAL;
+ return;
unwind:
if (dtp->u.p.namelist_mode)
if (nml_bad_return (dtp, c))
return;
- eat_line (dtp);
free_saved (dtp);
- sprintf (message, "Bad real number in item %d of list input",
+ if (c == EOF)
+ {
+ hit_eof (dtp);
+ return;
+ }
+ else if (c != '\n')
+ eat_line (dtp);
+
+ snprintf (message, MSGLEN, "Bad real number in item %d of list input",
dtp->u.p.item_count);
generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
}
static int
check_type (st_parameter_dt *dtp, bt type, int len)
{
- char message[100];
+ char message[MSGLEN];
- if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
+ if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type)
{
- sprintf (message, "Read type %s where %s was expected for item %d",
+ snprintf (message, MSGLEN, "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);
return 1;
}
- if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
+ if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER)
return 0;
if (dtp->u.p.saved_length != len)
{
- sprintf (message,
+ snprintf (message, MSGLEN,
"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);
reading, usually in the dtp->u.p.value[] array. If a repeat count is
greater than one, we copy the data item multiple times. */
-static void
-list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
+static int
+list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
int kind, size_t size)
{
- char c;
gfc_char4_t *q;
- int i, m;
- jmp_buf eof_jump;
+ int c, i, m;
+ int err = 0;
dtp->u.p.namelist_mode = 0;
- dtp->u.p.eof_jump = &eof_jump;
- if (setjmp (eof_jump))
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- goto cleanup;
- }
-
if (dtp->u.p.first_item)
{
dtp->u.p.first_item = 0;
dtp->u.p.repeat_count = 1;
dtp->u.p.at_eol = 0;
- c = eat_spaces (dtp);
+ if ((c = eat_spaces (dtp)) == EOF)
+ {
+ err = LIBERROR_END;
+ goto cleanup;
+ }
if (is_separator (c))
{
/* Found a null value. */
if (dtp->u.p.repeat_count > 0)
{
if (check_type (dtp, type, kind))
- return;
+ return err;
goto set_value;
}
if (dtp->u.p.input_complete)
goto cleanup;
- if (dtp->u.p.input_complete)
- goto cleanup;
-
if (dtp->u.p.at_eol)
finish_separator (dtp);
else
finish_separator (dtp);
}
- dtp->u.p.saved_type = BT_NULL;
+ dtp->u.p.saved_type = BT_UNKNOWN;
dtp->u.p.repeat_count = 1;
}
read_character (dtp, kind);
break;
case BT_REAL:
- read_real (dtp, kind);
+ read_real (dtp, p, kind);
+ /* Copy value back to temporary if needed. */
+ if (dtp->u.p.repeat_count > 0)
+ memcpy (dtp->u.p.value, p, kind);
break;
case BT_COMPLEX:
- read_complex (dtp, kind, size);
+ read_complex (dtp, p, kind, size);
+ /* Copy value back to temporary if needed. */
+ if (dtp->u.p.repeat_count > 0)
+ memcpy (dtp->u.p.value, p, size);
break;
default:
internal_error (&dtp->common, "Bad type for list read");
}
- if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
+ if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN)
dtp->u.p.saved_length = size;
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
switch (dtp->u.p.saved_type)
{
case BT_COMPLEX:
- case BT_INTEGER:
case BT_REAL:
+ if (dtp->u.p.repeat_count > 0)
+ memcpy (p, dtp->u.p.value, size);
+ break;
+
+ case BT_INTEGER:
case BT_LOGICAL:
memcpy (p, dtp->u.p.value, size);
break;
}
break;
- case BT_NULL:
+ case BT_UNKNOWN:
break;
+
+ default:
+ internal_error (&dtp->common, "Bad type for list read");
}
if (--dtp->u.p.repeat_count <= 0)
free_saved (dtp);
cleanup:
- dtp->u.p.eof_jump = NULL;
+ if (err == LIBERROR_END)
+ hit_eof (dtp);
+ return err;
}
char *tmp;
size_t stride = type == BT_CHARACTER ?
size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
+ int err;
tmp = (char *) p;
for (elem = 0; elem < nelems; elem++)
{
dtp->u.p.item_count++;
- list_formatted_read_scalar (dtp, type, tmp + stride*elem, kind, size);
+ err = list_formatted_read_scalar (dtp, type, tmp + stride*elem,
+ kind, size);
+ if (err)
+ break;
}
}
void
finish_list_read (st_parameter_dt *dtp)
{
- char c;
+ int err;
free_saved (dtp);
return;
}
- do
- {
- c = next_char (dtp);
- }
- while (c != '\n');
-
- if (dtp->u.p.current_unit->endfile != NO_ENDFILE)
- {
- generate_error (&dtp->common, LIBERROR_END, NULL);
- dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
- dtp->u.p.current_unit->current_record = 0;
- }
+ err = eat_line (dtp);
+ if (err == LIBERROR_END)
+ hit_eof (dtp);
}
/* NAMELIST INPUT
static try
nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
array_loop_spec *ls, int rank, char *parse_err_msg,
+ size_t parse_err_msg_size,
int *parsed_rank)
{
int dim;
int neg;
int null_flag;
int is_array_section, is_char;
- char c;
+ int c;
is_char = 0;
is_array_section = 0;
/* The next character in the stream should be the '('. */
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
/* Process the qualifier, by dimension and triplet. */
neg = 0;
/* Process a potential sign. */
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
switch (c)
{
case '-':
/* Process characters up to the next ':' , ',' or ')'. */
for (;;)
{
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
switch (c)
{
|| (c==')' && dim < rank -1))
{
if (is_char)
- sprintf (parse_err_msg, "Bad substring qualifier");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Bad substring qualifier");
else
- sprintf (parse_err_msg, "Bad number of index fields");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Bad number of index fields");
goto err_ret;
}
break;
case ' ': case '\t':
eat_spaces (dtp);
- c = next_char (dtp);
+ if ((c = next_char (dtp) == EOF))
+ return FAILURE;
break;
default:
if (is_char)
- sprintf (parse_err_msg,
+ snprintf (parse_err_msg, parse_err_msg_size,
"Bad character in substring qualifier");
else
- sprintf (parse_err_msg, "Bad character in index");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Bad character in index");
goto err_ret;
}
&& dtp->u.p.saved_string == 0)
{
if (is_char)
- sprintf (parse_err_msg, "Null substring qualifier");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Null substring qualifier");
else
- sprintf (parse_err_msg, "Null index field");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Null index field");
goto err_ret;
}
|| (indx == 2 && dtp->u.p.saved_string == 0))
{
if (is_char)
- sprintf (parse_err_msg, "Bad substring qualifier");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Bad substring qualifier");
else
- sprintf (parse_err_msg, "Bad index triplet");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Bad index triplet");
goto err_ret;
}
if (is_char && !is_array_section)
{
- sprintf (parse_err_msg,
+ snprintf (parse_err_msg, parse_err_msg_size,
"Missing colon in substring qualifier");
goto err_ret;
}
}
/* Now read the index. */
- if (convert_integer (dtp, sizeof(ssize_t), neg))
+ if (convert_integer (dtp, sizeof(index_type), neg))
{
if (is_char)
- sprintf (parse_err_msg, "Bad integer substring qualifier");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Bad integer substring qualifier");
else
- sprintf (parse_err_msg, "Bad integer in index");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Bad integer in index");
goto err_ret;
}
break;
if (!null_flag)
{
if (indx == 0)
- memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
+ memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
if (indx == 1)
- memcpy (&ls[dim].end, dtp->u.p.value, sizeof(ssize_t));
+ memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type));
if (indx == 2)
- memcpy (&ls[dim].step, dtp->u.p.value, sizeof(ssize_t));
+ memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type));
}
/* Singlet or doublet indices. */
{
if (indx == 0)
{
- memcpy (&ls[dim].start, dtp->u.p.value, sizeof(ssize_t));
+ memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type));
/* 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)
+ if (is_array_section == 1
+ || !(compile_options.allow_std & GFC_STD_GNU)
+ || dtp->u.p.ionml->type == BT_DERIVED)
ls[dim].end = ls[dim].start;
else
dtp->u.p.expanded_read = 1;
}
}
+ if (is_array_section == 1 && dtp->u.p.expanded_read == 1)
+ {
+ int i;
+ dtp->u.p.expanded_read = 0;
+ for (i = 0; i < dim; i++)
+ ls[i].end = ls[i].start;
+ }
+
/* Check the values of the triplet indices. */
- if ((ls[dim].start > (ssize_t)ad[dim].ubound)
- || (ls[dim].start < (ssize_t)ad[dim].lbound)
- || (ls[dim].end > (ssize_t)ad[dim].ubound)
- || (ls[dim].end < (ssize_t)ad[dim].lbound))
+ if ((ls[dim].start > GFC_DIMENSION_UBOUND(ad[dim]))
+ || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim]))
+ || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim]))
+ || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim])))
{
if (is_char)
- sprintf (parse_err_msg, "Substring out of range");
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Substring out of range");
else
- sprintf (parse_err_msg, "Index %d out of range", dim + 1);
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "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))
{
- sprintf (parse_err_msg, "Bad range in index %d", dim + 1);
+ snprintf (parse_err_msg, parse_err_msg_size,
+ "Bad range in index %d", dim + 1);
goto err_ret;
}
for (dim=0; dim < nl->var_rank; dim++)
{
nl->ls[dim].step = 1;
- nl->ls[dim].end = nl->dim[dim].ubound;
- nl->ls[dim].start = nl->dim[dim].lbound;
+ nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
+ nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
nl->ls[dim].idx = nl->ls[dim].start;
}
}
else
break;
}
- free_mem (ext_name);
+ free (ext_name);
return;
}
nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
{
index_type i;
- char c;
+ int c;
+
dtp->u.p.nml_read_error = 0;
for (i = 0; i < len; i++)
{
c = next_char (dtp);
- if (tolower (c) != tolower (name[i]))
+ if (c == EOF || (tolower (c) != tolower (name[i])))
{
dtp->u.p.nml_read_error = 1;
break;
len = nl->len;
switch (nl->type)
{
- case GFC_DTYPE_INTEGER:
- case GFC_DTYPE_LOGICAL:
+ case BT_INTEGER:
+ case BT_LOGICAL:
dlen = len;
break;
- case GFC_DTYPE_REAL:
+ case BT_REAL:
dlen = size_from_real_kind (len);
break;
- case GFC_DTYPE_COMPLEX:
+ case BT_COMPLEX:
dlen = size_from_complex_kind (len);
break;
- case GFC_DTYPE_CHARACTER:
+ case BT_CHARACTER:
dlen = chigh ? (chigh - clow + 1) : nl->string_length;
break;
pdata = (void*)(nl->mem_pos + offset);
for (dim = 0; dim < nl->var_rank; dim++)
- pdata = (void*)(pdata + (nl->ls[dim].idx - nl->dim[dim].lbound) *
- nl->dim[dim].stride * nl->size);
+ pdata = (void*)(pdata + (nl->ls[dim].idx
+ - GFC_DESCRIPTOR_LBOUND(nl,dim))
+ * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
/* Reset the error flag and try to read next value, if
dtp->u.p.repeat_count=0 */
if (dtp->u.p.input_complete)
return SUCCESS;
- /* GFC_TYPE_UNKNOWN through for nulls and is detected
- after the switch block. */
-
- dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
+ dtp->u.p.saved_type = BT_UNKNOWN;
free_saved (dtp);
switch (nl->type)
{
- case GFC_DTYPE_INTEGER:
+ case BT_INTEGER:
read_integer (dtp, len);
break;
- case GFC_DTYPE_LOGICAL:
+ case BT_LOGICAL:
read_logical (dtp, len);
break;
- case GFC_DTYPE_CHARACTER:
+ case BT_CHARACTER:
read_character (dtp, len);
break;
- case GFC_DTYPE_REAL:
- read_real (dtp, len);
- break;
+ case BT_REAL:
+ /* Need to copy data back from the real location to the temp in order
+ to handle nml reads into arrays. */
+ read_real (dtp, pdata, len);
+ memcpy (dtp->u.p.value, pdata, dlen);
+ break;
- case GFC_DTYPE_COMPLEX:
- read_complex (dtp, len, dlen);
- break;
+ case BT_COMPLEX:
+ /* Same as for REAL, copy back to temp. */
+ read_complex (dtp, pdata, len, dlen);
+ memcpy (dtp->u.p.value, pdata, dlen);
+ break;
- case GFC_DTYPE_DERIVED:
+ case BT_DERIVED:
obj_name_len = strlen (nl->var_name) + 1;
obj_name = get_mem (obj_name_len+1);
memcpy (obj_name, nl->var_name, obj_name_len-1);
pprev_nl, nml_err_msg, nml_err_msg_size,
clow, chigh) == FAILURE)
{
- free_mem (obj_name);
+ free (obj_name);
return FAILURE;
}
if (dtp->u.p.input_complete)
{
- free_mem (obj_name);
+ free (obj_name);
return SUCCESS;
}
}
- free_mem (obj_name);
+ free (obj_name);
goto incr_idx;
default:
return SUCCESS;
}
- if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
+ if (dtp->u.p.saved_type == BT_UNKNOWN)
{
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. */
-
switch (dtp->u.p.saved_type)
{
break;
case BT_CHARACTER:
- m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
+ if (dlen < dtp->u.p.saved_used)
+ {
+ if (compile_options.bounds_check)
+ {
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Namelist object '%s' truncated on read.",
+ nl->var_name);
+ generate_warning (&dtp->common, nml_err_msg);
+ }
+ m = dlen;
+ }
+ else
+ m = dtp->u.p.saved_used;
pdata = (void*)( pdata + clow - 1 );
memcpy (pdata, dtp->u.p.saved_string, m);
if (m < dlen)
nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
char *nml_err_msg, size_t nml_err_msg_size)
{
- char c;
+ int c;
namelist_info * nl;
namelist_info * first_nl = NULL;
namelist_info * root_nl = NULL;
int dim, parsed_rank;
- int component_flag;
+ int component_flag, qualifier_flag;
index_type clow, chigh;
int non_zero_rank_count;
if (dtp->u.p.input_complete)
return SUCCESS;
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
switch (c)
{
case '=':
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
if (c != '?')
{
- sprintf (nml_err_msg, "namelist read: misplaced = sign");
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "namelist read: misplaced = sign");
goto nml_err_ret;
}
nml_query (dtp, '=');
nml_match_name (dtp, "end", 3);
if (dtp->u.p.nml_read_error)
{
- sprintf (nml_err_msg, "namelist not terminated with / or &end");
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "namelist not terminated with / or &end");
goto nml_err_ret;
}
case '/':
break;
}
- /* Untouch all nodes of the namelist and reset the flag that is set for
+ /* Untouch all nodes of the namelist and reset the flags that are set for
derived type components. */
nml_untouch_nodes (dtp);
component_flag = 0;
+ qualifier_flag = 0;
non_zero_rank_count = 0;
/* Get the object name - should '!' and '\n' be permitted separators? */
{
if (!is_separator (c))
push_char (dtp, tolower(c));
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
unget_char (dtp, c);
for (dim=0; dim < nl->var_rank; dim++)
{
nl->ls[dim].step = 1;
- nl->ls[dim].end = nl->dim[dim].ubound;
- nl->ls[dim].start = nl->dim[dim].lbound;
+ nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim);
+ nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim);
nl->ls[dim].idx = nl->ls[dim].start;
}
{
parsed_rank = 0;
if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
- nml_err_msg, &parsed_rank) == FAILURE)
+ nml_err_msg, nml_err_msg_size,
+ &parsed_rank) == FAILURE)
{
char *nml_err_msg_end = strchr (nml_err_msg, '\0');
snprintf (nml_err_msg_end,
" for namelist variable %s", nl->var_name);
goto nml_err_ret;
}
-
if (parsed_rank > 0)
non_zero_rank_count++;
- c = next_char (dtp);
+ qualifier_flag = 1;
+
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
unget_char (dtp, c);
}
else if (nl->var_rank > 0)
if (c == '%')
{
- if (nl->type != GFC_DTYPE_DERIVED)
+ if (nl->type != BT_DERIVED)
{
snprintf (nml_err_msg, nml_err_msg_size,
"Attempt to get derived component for %s", nl->var_name);
goto nml_err_ret;
}
- if (!component_flag)
+ if (*pprev_nl == NULL || !component_flag)
first_nl = nl;
root_nl = nl;
+
component_flag = 1;
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
goto get_name;
}
clow = 1;
chigh = 0;
- if (c == '(' && nl->type == GFC_DTYPE_CHARACTER)
+ if (c == '(' && nl->type == BT_CHARACTER)
{
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, nml_err_msg, &parsed_rank)
+ if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg,
+ nml_err_msg_size, &parsed_rank)
== FAILURE)
{
char *nml_err_msg_end = strchr (nml_err_msg, '\0');
goto nml_err_ret;
}
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
unget_char (dtp, c);
}
- /* If a derived type touch its components and restore the root
- namelist_info if we have parsed a qualified derived type
- component. */
-
- if (nl->type == GFC_DTYPE_DERIVED)
- nml_touch_nodes (nl);
- if (component_flag && nl->var_rank > 0)
- nl = first_nl;
-
/* Make sure no extraneous qualifiers are there. */
if (c == '(')
if (dtp->u.p.input_complete)
return SUCCESS;
- c = next_char (dtp);
+ if ((c = next_char (dtp)) == EOF)
+ return FAILURE;
if (c != '=')
{
nl->var_name);
goto nml_err_ret;
}
+ /* If a derived type, touch its components and restore the root
+ namelist_info if we have parsed a qualified derived type
+ component. */
+
+ if (nl->type == BT_DERIVED)
+ nml_touch_nodes (nl);
+
+ if (first_nl)
+ {
+ if (first_nl->var_rank == 0)
+ {
+ if (component_flag && qualifier_flag)
+ nl = first_nl;
+ }
+ else
+ nl = first_nl;
+ }
- if (first_nl != NULL && first_nl->var_rank > 0)
- nl = first_nl;
-
if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size,
clow, chigh) == FAILURE)
goto nml_err_ret;
void
namelist_read (st_parameter_dt *dtp)
{
- char c;
- jmp_buf eof_jump;
+ int c;
char nml_err_msg[200];
+
+ /* Initialize the error string buffer just in case we get an unexpected fail
+ somewhere and end up at nml_err_ret. */
+ strcpy (nml_err_msg, "Internal namelist read error");
+
/* 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. */
dtp->u.p.input_complete = 0;
dtp->u.p.expanded_read = 0;
- dtp->u.p.eof_jump = &eof_jump;
- if (setjmp (eof_jump))
- {
- dtp->u.p.eof_jump = NULL;
- generate_error (&dtp->common, LIBERROR_END, NULL);
- return;
- }
-
/* Look for &namelist_name . Skip all characters, testing for $nmlname.
Exit on success or EOF. If '?' or '=?' encountered in stdin, print
node names or namelist on stdout. */
find_nml_name:
- switch (c = next_char (dtp))
+ c = next_char (dtp);
+ switch (c)
{
case '$':
case '&':
case '?':
nml_query (dtp, '?');
+ case EOF:
+ return;
+
default:
goto find_nml_name;
}
if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
== FAILURE)
{
- gfc_unit *u;
-
if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
goto nml_err_ret;
-
- u = find_unit (options.stderr_unit);
- st_printf ("%s\n", nml_err_msg);
- if (u != NULL)
- {
- sflush (u->s);
- unlock_unit (u);
- }
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
}
- }
+ /* Reset the previous namelist pointer if we know we are not going
+ to be doing multiple reads within a single namelist object. */
+ if (prev_nl && prev_nl->var_rank == 0)
+ prev_nl = NULL;
+ }
- dtp->u.p.eof_jump = NULL;
free_saved (dtp);
free_line (dtp);
return;
- /* All namelist error calls return from here */
nml_err_ret:
- dtp->u.p.eof_jump = NULL;
+ /* All namelist error calls return from here */
free_saved (dtp);
free_line (dtp);
generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
OSDN Git Service
