-/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008
+/* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught
Namelist input contributed by Paul Thomas
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 <string.h>
+#include <stdlib.h>
#include <ctype.h>
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;
static char
next_char (st_parameter_dt *dtp)
{
- size_t length;
+ ssize_t length;
gfc_offset record;
char c;
+ int cc;
if (dtp->u.p.last_char != '\0')
{
}
record *= dtp->u.p.current_unit->recl;
- if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
+ 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;
/* Get the next character and handle end-of-record conditions. */
- length = 1;
-
- if (sread (dtp->u.p.current_unit->s, &c, &length) != 0)
- {
- generate_error (&dtp->common, LIBERROR_OS, NULL);
- return '\0';
- }
-
- if (is_stream_io (dtp) && length == 1)
- dtp->u.p.current_unit->strm_pos++;
-
if (is_internal_unit (dtp))
{
+ 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. */
}
else
{
- if (length == 0)
+ cc = fbuf_getc (dtp->u.p.current_unit);
+
+ if (cc == EOF)
{
- if (dtp->u.p.advance_status == ADVANCE_NO)
- {
- 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
+ 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');
eat_line (st_parameter_dt *dtp)
{
char c;
- if (!is_internal_unit (dtp))
- do
- c = next_char (dtp);
- while (c != '\n');
+
+ do
+ c = next_char (dtp);
+ while (c != '\n');
}
switch (c)
{
case ',':
- if (dtp->u.p.decimal_status == DECIMAL_COMMA)
+ if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
{
unget_char (dtp, c);
break;
}
}
}
- while (c == '\n' || c == '\r' || c == ' ');
+ while (c == '\n' || c == '\r' || c == ' ' || c == '\t');
unget_char (dtp, c);
}
break;
default:
if (dtp->u.p.namelist_mode)
{
- if (dtp->u.p.delim_status == DELIM_APOSTROPHE
- || dtp->u.p.delim_status == DELIM_QUOTE
- || c == '&' || c == '$' || c == '/')
- {
- unget_char (dtp, c);
- return;
- }
-
- /* Check to see if we are seeing a namelist object name by using the
- line buffer and looking ahead for an '=' or '('. */
- l_push_char (dtp, c);
-
- int i;
- for(i = 0; i < 63; i++)
- {
- c = next_char (dtp);
- if (is_separator(c))
- {
- unget_char (dtp, c);
- eat_separator (dtp);
- c = next_char (dtp);
- if (c != '=')
- {
- l_push_char (dtp, c);
- dtp->u.p.item_count = 0;
- dtp->u.p.line_buffer_enabled = 1;
- goto get_string;
- }
- }
-
- l_push_char (dtp, c);
-
- if (c == '=' || c == '(')
- {
- dtp->u.p.item_count = 0;
- dtp->u.p.nml_read_error = 1;
- dtp->u.p.line_buffer_enabled = 1;
- return;
- }
- }
-
- /* The string is too long to be a valid object name so assume that it
- is a string to be read in as a value. */
- dtp->u.p.item_count = 0;
- dtp->u.p.line_buffer_enabled = 1;
- goto get_string;
+ unget_char (dtp, c);
+ return;
}
push_char (dtp, c);
invalid. */
done:
c = next_char (dtp);
- if (is_separator (c))
+ if (is_separator (c) || c == '!')
{
unget_char (dtp, c);
eat_separator (dtp);
c = next_char (dtp);
}
- if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
c = '.';
if (!isdigit (c) && c != '.')
for (;;)
{
c = next_char (dtp);
- if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
{
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:
unget_char (dtp, c);
if (next_char (dtp)
- != (dtp->u.p.decimal_status == DECIMAL_POINT ? ',' : ';'))
+ != (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);
/* 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;
seen_dp = 0;
c = next_char (dtp);
- if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
{
for (;;)
{
c = next_char (dtp);
- if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
{
c = next_char (dtp);
}
- if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
c = '.';
if (!isdigit (c) && c != '.')
for (;;)
{
c = next_char (dtp);
- if (c == ',' && dtp->u.p.decimal_status == DECIMAL_COMMA)
+ if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
c = '.';
switch (c)
{
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);
if (setjmp (eof_jump))
{
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))
{
}
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);
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;
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
}
/* 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])))
{
if (is_char)
sprintf (parse_err_msg, "Substring out of range");
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;
}
}
/* Flush the stream to force immediate output. */
- fbuf_flush (dtp->u.p.current_unit, 1);
- 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);
}
int dim;
index_type dlen;
index_type m;
- index_type obj_name_len;
+ size_t obj_name_len;
void * pdata;
/* This object not touched in name parsing. */
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. */
+ /* BT_NULL (equivalent to GFC_DTYPE_UNKNOWN) falls through
+ for nulls and is detected at default: of switch block. */
- dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
+ dtp->u.p.saved_type = BT_NULL;
free_saved (dtp);
switch (nl->type)
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;
return SUCCESS;
}
- if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
+ if (dtp->u.p.saved_type == BT_NULL)
{
dtp->u.p.expanded_read = 0;
goto incr_idx;
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 (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. */
goto nml_err_ret;
}
+ 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;
/* A trailing space is required, we give a little lattitude here, 10.9.1. */
c = next_char (dtp);
- if (!is_separator(c))
+ 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. */
st_printf ("%s\n", nml_err_msg);
if (u != NULL)
{
- flush (u->s);
+ sflush (u->s);
unlock_unit (u);
}
}
OSDN Git Service
