-/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
+ 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).
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 "config.h"
+#include "io.h"
#include <string.h>
+#include <stdlib.h>
#include <ctype.h>
-#include "libgfortran.h"
-#include "io.h"
/* List directed input. Several parsing subroutines are practically
case '5': case '6': case '7': case '8': case '9'
#define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t': \
- case '\r'
+ case '\r': case ';'
/* This macro assumes that we're operating on a variable. */
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
- || c == '\t' || c == '\r')
+ || c == '\t' || c == '\r' || c == ';')
/* Maximum repeat count. Less than ten times the maximum signed int32. */
#define MAX_REPEAT 200000000
+#ifndef HAVE_SNPRINTF
+# undef snprintf
+# define snprintf(str, size, ...) sprintf (str, __VA_ARGS__)
+#endif
/* Save a character to a string buffer, enlarging it as necessary. */
if (dtp->u.p.saved_string == NULL)
{
- if (dtp->u.p.scratch == NULL)
- dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
- dtp->u.p.saved_string = dtp->u.p.scratch;
+ dtp->u.p.saved_string = get_mem (SCRATCH_SIZE);
+ // memset below should be commented out.
memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0;
if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
{
dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
- new = get_mem (2 * dtp->u.p.saved_length);
-
- memset (new, 0, 2 * dtp->u.p.saved_length);
-
- memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
- if (dtp->u.p.saved_string != dtp->u.p.scratch)
- free_mem (dtp->u.p.saved_string);
-
+ new = realloc (dtp->u.p.saved_string, dtp->u.p.saved_length);
+ if (new == NULL)
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
dtp->u.p.saved_string = new;
+
+ // Also this should not be necessary.
+ memset (new + dtp->u.p.saved_used, 0,
+ dtp->u.p.saved_length - dtp->u.p.saved_used);
+
}
dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
if (dtp->u.p.saved_string == NULL)
return;
- if (dtp->u.p.saved_string != dtp->u.p.scratch)
- free_mem (dtp->u.p.saved_string);
+ free_mem (dtp->u.p.saved_string);
dtp->u.p.saved_string = NULL;
dtp->u.p.saved_used = 0;
}
+/* Free the line buffer if necessary. */
+
+static void
+free_line (st_parameter_dt *dtp)
+{
+ dtp->u.p.item_count = 0;
+ dtp->u.p.line_buffer_enabled = 0;
+
+ 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)
{
- int length;
- char c, *p;
+ ssize_t length;
+ gfc_offset record;
+ char c;
+ int cc;
if (dtp->u.p.last_char != '\0')
{
goto done;
}
- length = 1;
+ /* Read from line_buffer if enabled. */
- p = salloc_r (dtp->u.p.current_unit->s, &length);
- if (p == NULL)
+ if (dtp->u.p.line_buffer_enabled)
{
- generate_error (&dtp->common, ERROR_OS, NULL);
- return '\0';
+ dtp->u.p.at_eol = 0;
+
+ 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;
+ }
+
+ 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);
+
+ /* Check for "end-of-record" condition. */
+ if (dtp->u.p.current_unit->bytes_left == 0)
+ {
+ int finished;
+
+ c = '\n';
+ record = next_array_record (dtp, dtp->u.p.current_unit->ls,
+ &finished);
+
+ /* Check for "end-of-file" condition. */
+ if (finished)
+ {
+ dtp->u.p.at_eof = 1;
+ goto done;
+ }
+
+ 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);
+
+ dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
+ goto done;
+ }
}
- if (length == 0)
+ /* Get the next character and handle end-of-record conditions. */
+
+ if (is_internal_unit (dtp))
{
- /* For internal files return a newline instead of signalling EOF. */
- /* ??? This isn't quite right, but we don't handle internal files
- with multiple records. */
- if (is_internal_unit (dtp))
- c = '\n';
+ length = sread (dtp->u.p.current_unit->s, &c, 1);
+ if (length < 0)
+ {
+ generate_error (&dtp->common, LIBERROR_OS, NULL);
+ return '\0';
+ }
+
+ if (is_array_io (dtp))
+ {
+ /* Check whether we hit EOF. */
+ if (length == 0)
+ {
+ generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
+ return '\0';
+ }
+ dtp->u.p.current_unit->bytes_left--;
+ }
else
- longjmp (*dtp->u.p.eof_jump, 1);
+ {
+ if (dtp->u.p.at_eof)
+ longjmp (*dtp->u.p.eof_jump, 1);
+ if (length == 0)
+ {
+ c = '\n';
+ dtp->u.p.at_eof = 1;
+ }
+ }
}
else
- c = *p;
+ {
+ 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)
+ dtp->u.p.current_unit->strm_pos++;
+ }
done:
dtp->u.p.at_eol = (c == '\n' || c == '\r');
return c;
}
+/* 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');
+}
+
+
/* Skip over a separator. Technically, we don't always eat the whole
separator. This is because if we've processed the last input item,
then a separator is unnecessary. Plus the fact that operating
static void
eat_separator (st_parameter_dt *dtp)
{
- char c;
+ char c, n;
eat_spaces (dtp);
dtp->u.p.comma_flag = 0;
switch (c)
{
case ',':
+ if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ {
+ unget_char (dtp, c);
+ break;
+ }
+ /* Fall through. */
+ case ';':
dtp->u.p.comma_flag = 1;
eat_spaces (dtp);
break;
dtp->u.p.input_complete = 1;
break;
- case '\n':
case '\r':
dtp->u.p.at_eol = 1;
+ n = next_char(dtp);
+ if (n != '\n')
+ {
+ unget_char (dtp, n);
+ break;
+ }
+ /* Fall through. */
+ case '\n':
+ dtp->u.p.at_eol = 1;
+ if (dtp->u.p.namelist_mode)
+ {
+ do
+ {
+ c = next_char (dtp);
+ if (c == '!')
+ {
+ eat_line (dtp);
+ c = next_char (dtp);
+ if (c == '!')
+ {
+ eat_line (dtp);
+ c = next_char (dtp);
+ }
+ }
+ }
+ while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
+ unget_char (dtp, c);
+ }
break;
case '!':
else
{
c = eat_spaces (dtp);
- if (c == '\n')
+ if (c == '\n' || c == '\r')
goto restart;
}
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 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);
+ 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;
}
return 0;
bad_repeat:
- 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);
+ 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, LIBERROR_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;
+ 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;
return; /* Null value. */
default:
+ /* Save the character in case it is the beginning
+ of the next object name. */
+ unget_char (dtp, c);
goto bad_logical;
}
unget_char (dtp, c);
eat_separator (dtp);
- free_saved (dtp);
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, LIBERROR_READ_VALUE, message);
+ return;
- generate_error (&dtp->common, ERROR_READ_VALUE, message);
+ logical_done:
+
+ 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);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return;
default:
if (dtp->u.p.namelist_mode)
{
- unget_char (dtp,c);
+ unget_char (dtp, c);
return;
}
+
push_char (dtp, c);
goto get_string;
}
goto done;
}
- if (c != '\n')
+ if (c != '\n' && c != '\r')
push_char (dtp, c);
break;
invalid. */
done:
c = next_char (dtp);
- if (is_separator (c))
+ if (is_separator (c) || c == '!')
{
unget_char (dtp, c);
eat_separator (dtp);
dtp->u.p.saved_type = BT_CHARACTER;
+ free_line (dtp);
}
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);
}
}
c = next_char (dtp);
}
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ c = '.';
+
if (!isdigit (c) && c != '.')
- goto bad;
+ {
+ if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
+ goto inf_nan;
+ else
+ goto bad;
+ }
push_char (dtp, c);
for (;;)
{
c = next_char (dtp);
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
exp2:
if (!isdigit (c))
goto bad;
+
push_char (dtp, c);
for (;;)
return m;
+ inf_nan:
+ /* Match INF and Infinity. */
+ if ((c == 'i' || c == 'I')
+ && ((c = next_char (dtp)) == 'n' || c == 'N')
+ && ((c = next_char (dtp)) == 'f' || c == 'F'))
+ {
+ c = next_char (dtp);
+ if ((c != 'i' && c != 'I')
+ || ((c == 'i' || c == 'I')
+ && ((c = next_char (dtp)) == 'n' || c == 'N')
+ && ((c = next_char (dtp)) == 'i' || c == 'I')
+ && ((c = next_char (dtp)) == 't' || c == 'T')
+ && ((c = next_char (dtp)) == 'y' || c == 'Y')
+ && (c = next_char (dtp))))
+ {
+ if (is_separator (c))
+ unget_char (dtp, c);
+ push_char (dtp, 'i');
+ push_char (dtp, 'n');
+ push_char (dtp, 'f');
+ goto done;
+ }
+ } /* Match NaN. */
+ else if (((c = next_char (dtp)) == 'a' || c == 'A')
+ && ((c = next_char (dtp)) == 'n' || c == 'N')
+ && (c = next_char (dtp)))
+ {
+ if (is_separator (c))
+ unget_char (dtp, c);
+ push_char (dtp, 'n');
+ push_char (dtp, 'a');
+ push_char (dtp, 'n');
+ goto done;
+ }
+
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);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, message);
return 1;
}
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;
}
eat_spaces (dtp);
- if (parse_real (dtp, dtp->u.p.value, kind))
+ if (parse_real (dtp, dest, kind))
return;
eol_1:
else
unget_char (dtp, c);
- if (next_char (dtp) != ',')
+ if (next_char (dtp)
+ != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';'))
goto bad_complex;
eol_2:
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;
eat_spaces (dtp);
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);
+ 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];
int seen_dp;
+ int is_inf;
seen_dp = 0;
c = next_char (dtp);
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
eat_separator (dtp);
return;
+ case 'i':
+ case 'I':
+ case 'n':
+ case 'N':
+ goto inf_nan;
+
default:
goto bad_real;
}
for (;;)
{
c = next_char (dtp);
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
break;
case '.':
- if (seen_dp)
- goto bad_real;
+ if (seen_dp)
+ goto bad_real;
seen_dp = 1;
push_char (dtp, c);
goto got_repeat;
CASE_SEPARATORS:
- if (c != '\n' && c != ',' && c != '\r')
+ if (c != '\n' && c != ',' && c != '\r' && c != ';')
unget_char (dtp, c);
goto done;
c = next_char (dtp);
}
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ c = '.';
+
if (!isdigit (c) && c != '.')
- goto bad_real;
+ {
+ if (c == 'i' || c == 'I' || c == 'n' || c == 'N')
+ goto inf_nan;
+ else
+ goto bad_real;
+ }
if (c == '.')
{
for (;;)
{
c = next_char (dtp);
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
+ c = '.';
switch (c)
{
CASE_DIGITS:
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);
dtp->u.p.saved_type = BT_REAL;
return;
+ inf_nan:
+ l_push_char (dtp, c);
+ is_inf = 0;
+
+ /* Match INF and Infinity. */
+ if (c == 'i' || c == 'I')
+ {
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (c != 'n' && c != 'N')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (c != 'f' && c != 'F')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (!is_separator (c))
+ {
+ if (c != 'i' && c != 'I')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (c != 'n' && c != 'N')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (c != 'i' && c != 'I')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (c != 't' && c != 'T')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (c != 'y' && c != 'Y')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ }
+ is_inf = 1;
+ } /* Match NaN. */
+ else
+ {
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (c != 'a' && c != 'A')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ if (c != 'n' && c != 'N')
+ goto unwind;
+ c = next_char (dtp);
+ l_push_char (dtp, c);
+ }
+
+ if (!is_separator (c))
+ goto unwind;
+
+ if (dtp->u.p.namelist_mode)
+ {
+ if (c == ' ' || c =='\n' || c == '\r')
+ {
+ do
+ c = next_char (dtp);
+ while (c == ' ' || c =='\n' || c == '\r');
+
+ l_push_char (dtp, c);
+
+ if (c == '=')
+ goto unwind;
+ }
+ }
+
+ if (is_inf)
+ {
+ push_char (dtp, 'i');
+ push_char (dtp, 'n');
+ push_char (dtp, 'f');
+ }
+ else
+ {
+ push_char (dtp, 'n');
+ push_char (dtp, 'a');
+ push_char (dtp, 'n');
+ }
+
+ free_line (dtp);
+ goto done;
+
+ unwind:
+ if (dtp->u.p.namelist_mode)
+ {
+ dtp->u.p.nml_read_error = 1;
+ dtp->u.p.line_buffer_enabled = 1;
+ dtp->u.p.item_count = 0;
+ return;
+ }
+
bad_real:
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);
+ 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;
}
greater than one, we copy the data item multiple times. */
static void
-list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
- size_t size)
+list_formatted_read_scalar (st_parameter_dt *dtp, volatile bt type, void *p,
+ int kind, size_t size)
{
char c;
- int m;
+ gfc_char4_t *q;
+ int i, m;
jmp_buf eof_jump;
dtp->u.p.namelist_mode = 0;
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);
+ if (!is_internal_unit (dtp))
+ {
+ dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
+ dtp->u.p.current_unit->current_record = 0;
+ }
goto cleanup;
}
dtp->u.p.input_complete = 0;
dtp->u.p.repeat_count = 1;
dtp->u.p.at_eol = 0;
-
+
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. */
+ 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
+ else
goto cleanup;
}
}
else
{
- if (dtp->u.p.input_complete)
- goto cleanup;
-
if (dtp->u.p.repeat_count > 0)
{
if (check_type (dtp, type, kind))
return;
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
{
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);
}
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");
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;
case BT_CHARACTER:
if (dtp->u.p.saved_string)
- {
+ {
m = ((int) size < dtp->u.p.saved_used)
? (int) size : dtp->u.p.saved_used;
- memcpy (p, dtp->u.p.saved_string, m);
- }
+ if (kind == 1)
+ memcpy (p, dtp->u.p.saved_string, m);
+ else
+ {
+ q = (gfc_char4_t *) p;
+ for (i = 0; i < m; i++)
+ q[i] = (unsigned char) dtp->u.p.saved_string[i];
+ }
+ }
else
/* Just delimiters encountered, nothing to copy but SPACE. */
m = 0;
if (m < (int) size)
- memset (((char *) p) + m, ' ', size - m);
+ {
+ if (kind == 1)
+ memset (((char *) p) + m, ' ', size - m);
+ else
+ {
+ q = (gfc_char4_t *) p;
+ for (i = m; i < (int) size; i++)
+ q[i] = (unsigned char) ' ';
+ }
+ }
break;
case BT_NULL:
{
size_t elem;
char *tmp;
+ size_t stride = type == BT_CHARACTER ?
+ size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
tmp = (char *) p;
for (elem = 0; elem < nelems; elem++)
{
dtp->u.p.item_count++;
- list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
+ list_formatted_read_scalar (dtp, type, tmp + stride*elem, kind, size);
}
}
free_saved (dtp);
+ fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
+
if (dtp->u.p.at_eol)
{
dtp->u.p.at_eol = 0;
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;
+ }
}
/* NAMELIST INPUT
static void nml_match_name (char *name, int len)
static int nml_query (st_parameter_dt *dtp)
static int nml_get_obj_data (st_parameter_dt *dtp,
- namelist_info **prev_nl, char *)
+ namelist_info **prev_nl, char *, size_t)
calls:
static void nml_untouch_nodes (st_parameter_dt *dtp)
static namelist_info * find_nml_node (st_parameter_dt *dtp,
array_loop_spec * ls, int rank, char *)
static void nml_touch_nodes (namelist_info * nl)
static int nml_read_obj (namelist_info *nl, index_type offset,
- namelist_info **prev_nl, char *,
+ namelist_info **prev_nl, char *, size_t,
index_type clow, index_type chigh)
calls:
-itself- */
static try
nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
- array_loop_spec *ls, int rank, char *parse_err_msg)
+ array_loop_spec *ls, int rank, char *parse_err_msg,
+ int *parsed_rank)
{
int dim;
int indx;
int neg;
int null_flag;
+ int is_array_section, is_char;
char c;
+ is_char = 0;
+ is_array_section = 0;
+ dtp->u.p.expanded_read = 0;
+
+ /* See if this is a character substring qualifier we are looking for. */
+ if (rank == -1)
+ {
+ rank = 1;
+ is_char = 1;
+ }
+
/* 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");
+ if (is_char)
+ sprintf (parse_err_msg, "Bad substring qualifier");
+ else
+ sprintf (parse_err_msg, "Bad number of index fields");
goto err_ret;
}
break;
break;
default:
- st_sprintf (parse_err_msg, "Bad character in index");
+ if (is_char)
+ sprintf (parse_err_msg,
+ "Bad character in substring qualifier");
+ else
+ 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");
+ if (is_char)
+ sprintf (parse_err_msg, "Null substring qualifier");
+ else
+ 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");
+ if (is_char)
+ sprintf (parse_err_msg, "Bad substring qualifier");
+ else
+ sprintf (parse_err_msg, "Bad index triplet");
+ goto err_ret;
+ }
+
+ if (is_char && !is_array_section)
+ {
+ sprintf (parse_err_msg,
+ "Missing colon in substring qualifier");
goto err_ret;
}
/* Now read the index. */
if (convert_integer (dtp, sizeof(ssize_t), neg))
{
- st_sprintf (parse_err_msg, "Bad integer in index");
+ if (is_char)
+ sprintf (parse_err_msg, "Bad integer substring qualifier");
+ else
+ 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;
}
+
+ /* Check for non-zero rank. */
+ if (is_array_section == 1 && ls[dim].start != ls[dim].end)
+ *parsed_rank = 1;
+
break;
}
}
/* 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 > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
+ || (ls[dim].start < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim]))
+ || (ls[dim].end > (ssize_t) GFC_DIMENSION_UBOUND(ad[dim]))
+ || (ls[dim].end < (ssize_t) GFC_DIMENSION_LBOUND(ad[dim])))
{
- st_sprintf (parse_err_msg, "Index %d out of range", dim + 1);
+ if (is_char)
+ sprintf (parse_err_msg, "Substring out of range");
+ else
+ 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)
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;
}
}
namelist_info * nl;
index_type len;
char * p;
+#ifdef HAVE_CRLF
+ static const index_type endlen = 3;
+ static const char endl[] = "\r\n";
+ static const char nmlend[] = "&end\r\n";
+#else
+ static const index_type endlen = 2;
+ static const char endl[] = "\n";
+ static const char nmlend[] = "&end\n";
+#endif
if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
return;
else
{
-
/* "&namelist_name\n" */
len = dtp->namelist_name_len;
- p = write_block (dtp, len + 2);
- if (!p)
- goto query_return;
+ p = write_block (dtp, len + endlen);
+ if (!p)
+ goto query_return;
memcpy (p, "&", 1);
memcpy ((char*)(p + 1), dtp->namelist_name, len);
- memcpy ((char*)(p + len + 1), "\n", 1);
+ memcpy ((char*)(p + len + 1), &endl, endlen - 1);
for (nl = dtp->u.p.ionml; nl; nl = nl->next)
{
-
/* " var_name\n" */
len = strlen (nl->var_name);
- p = write_block (dtp, len + 2);
+ p = write_block (dtp, len + endlen);
if (!p)
goto query_return;
memcpy (p, " ", 1);
memcpy ((char*)(p + 1), nl->var_name, len);
- memcpy ((char*)(p + len + 1), "\n", 1);
+ memcpy ((char*)(p + len + 1), &endl, endlen - 1);
}
/* "&end\n" */
- p = write_block (dtp, 5);
- if (!p)
+ p = write_block (dtp, endlen + 3);
goto query_return;
- memcpy (p, "&end\n", 5);
+ memcpy (p, &nmlend, endlen + 3);
}
/* Flush the stream to force immediate output. */
- flush (dtp->u.p.current_unit->s);
+ fbuf_flush (dtp->u.p.current_unit, WRITING);
+ sflush (dtp->u.p.current_unit->s);
unlock_unit (dtp->u.p.current_unit);
}
static try
nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
namelist_info **pprev_nl, char *nml_err_msg,
- index_type clow, index_type chigh)
+ size_t nml_err_msg_size, index_type clow, index_type chigh)
{
-
namelist_info * cmp;
char * obj_name;
int nml_carry;
int dim;
index_type dlen;
index_type m;
- index_type obj_name_len;
- void * pdata ;
+ size_t obj_name_len;
+ void * pdata;
/* This object not touched in name parsing. */
len = nl->len;
switch (nl->type)
{
-
case GFC_DTYPE_INTEGER:
case GFC_DTYPE_LOGICAL:
dlen = len;
do
{
-
/* Update the pointer to the data, using the current index vector */
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 */
break;
case GFC_DTYPE_REAL:
- read_real (dtp, len);
- break;
+ /* 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;
+ /* 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:
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
{
if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
- pprev_nl, nml_err_msg, clow, chigh)
- == FAILURE)
+ pprev_nl, nml_err_msg, nml_err_msg_size,
+ clow, chigh) == FAILURE)
{
free_mem (obj_name);
return FAILURE;
goto incr_idx;
default:
- st_sprintf (nml_err_msg, "Bad type for namelist object %s",
- nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "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" ,
- nl->var_name );
- goto nml_err_ret;
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Repeat count too large for namelist object %s", nl->var_name);
+ goto nml_err_ret;
}
return SUCCESS;
static try
nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
- char *nml_err_msg)
+ char *nml_err_msg, size_t nml_err_msg_size)
{
char c;
namelist_info * nl;
namelist_info * first_nl = NULL;
namelist_info * root_nl = NULL;
- int dim;
+ int dim, parsed_rank;
int component_flag;
- char parse_err_msg[30];
index_type clow, chigh;
+ int non_zero_rank_count;
/* Look for end of input or object name. If '?' or '=?' are encountered
in stdin, print the node names or the namelist to stdout. */
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 '/':
nml_untouch_nodes (dtp);
component_flag = 0;
+ non_zero_rank_count = 0;
/* Get the object name - should '!' and '\n' be permitted separators? */
do
{
- push_char (dtp, tolower(c));
+ if (!is_separator (c))
+ push_char (dtp, tolower(c));
c = next_char (dtp);
} while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
if (nl == NULL)
{
if (dtp->u.p.nml_read_error && *pprev_nl)
- st_sprintf (nml_err_msg, "Bad data for namelist object %s",
- (*pprev_nl)->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Bad data for namelist object %s", (*pprev_nl)->var_name);
else
- st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
- dtp->u.p.saved_string);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Cannot match namelist object name %s",
+ dtp->u.p.saved_string);
goto nml_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;
}
if (c == '(' && nl->var_rank)
{
+ parsed_rank = 0;
if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
- parse_err_msg) == FAILURE)
+ nml_err_msg, &parsed_rank) == FAILURE)
{
- st_sprintf (nml_err_msg, "%s for namelist variable %s",
- parse_err_msg, nl->var_name);
+ char *nml_err_msg_end = strchr (nml_err_msg, '\0');
+ snprintf (nml_err_msg_end,
+ nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
+ " for namelist variable %s", nl->var_name);
goto nml_err_ret;
}
+
+ if (parsed_rank > 0)
+ non_zero_rank_count++;
+
c = next_char (dtp);
unget_char (dtp, c);
}
+ else if (nl->var_rank > 0)
+ non_zero_rank_count++;
/* Now parse a derived type component. The root namelist_info address
is backed up, as is the previous component level. The component flag
if (c == '%')
{
-
if (nl->type != GFC_DTYPE_DERIVED)
{
- st_sprintf (nml_err_msg, "Attempt to get derived component for %s",
- nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Attempt to get derived component for %s", nl->var_name);
goto nml_err_ret;
}
component_flag = 1;
c = next_char (dtp);
goto get_name;
-
}
/* Parse a character qualifier, if present. chigh = 0 is a default
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, parse_err_msg) == FAILURE)
+ if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank)
+ == FAILURE)
{
- st_sprintf (nml_err_msg, "%s for namelist variable %s",
- parse_err_msg, nl->var_name);
+ char *nml_err_msg_end = strchr (nml_err_msg, '\0');
+ snprintf (nml_err_msg_end,
+ nml_err_msg_size - (nml_err_msg_end - nml_err_msg),
+ " for namelist variable %s", nl->var_name);
goto nml_err_ret;
}
if (ind[0].step != 1)
{
- st_sprintf (nml_err_msg,
- "Bad step in substring for namelist object %s",
- nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Step not allowed in substring qualifier"
+ " for namelist object %s", nl->var_name);
goto nml_err_ret;
}
if (nl->type == GFC_DTYPE_DERIVED)
nml_touch_nodes (nl);
- if (component_flag)
+ if (component_flag && nl->var_rank > 0 && nl->next)
nl = first_nl;
- /*make sure no extraneous qualifiers are there.*/
+ /* Make sure no extraneous qualifiers are there. */
if (c == '(')
{
- st_sprintf (nml_err_msg, "Qualifier for a scalar or non-character"
- " namelist object %s", nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Qualifier for a scalar or non-character namelist object %s",
+ nl->var_name);
+ goto nml_err_ret;
+ }
+
+ /* Make sure there is no more than one non-zero rank object. */
+ if (non_zero_rank_count > 1)
+ {
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Multiple sub-objects with non-zero rank in namelist object %s",
+ nl->var_name);
+ non_zero_rank_count = 0;
goto nml_err_ret;
}
if (c != '=')
{
- st_sprintf (nml_err_msg, "Equal sign must follow namelist object name %s",
- nl->var_name);
+ snprintf (nml_err_msg, nml_err_msg_size,
+ "Equal sign must follow namelist object name %s",
+ nl->var_name);
goto nml_err_ret;
}
- if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
+ 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;
return SUCCESS;
{
char c;
jmp_buf eof_jump;
- char nml_err_msg[100];
+ char nml_err_msg[200];
/* 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.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))
{
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) && c != '!')
+ {
+ unget_char (dtp, c);
+ goto find_nml_name;
+ }
+
+ unget_char (dtp, c);
+ eat_separator (dtp);
+
/* Ready to read namelist objects. If there is an error in input
from stdin, output the error message and continue. */
while (!dtp->u.p.input_complete)
{
- if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
+ if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)
+ == FAILURE)
{
gfc_unit *u;
st_printf ("%s\n", nml_err_msg);
if (u != NULL)
{
- flush (u->s);
+ sflush (u->s);
unlock_unit (u);
}
}
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);
- generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
+ free_line (dtp);
+ generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg);
return;
}
OSDN Git Service
