1532 lines
26 KiB
C
1532 lines
26 KiB
C
|
/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
|
||
|
Contributed by Andy Vaught
|
||
|
|
||
|
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)
|
||
|
any later version.
|
||
|
|
||
|
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, 59 Temple Place - Suite 330,
|
||
|
Boston, MA 02111-1307, USA. */
|
||
|
|
||
|
|
||
|
#include "config.h"
|
||
|
#include <string.h>
|
||
|
#include <ctype.h>
|
||
|
#include "libgfortran.h"
|
||
|
#include "io.h"
|
||
|
|
||
|
|
||
|
/* List directed input. Several parsing subroutines are practically
|
||
|
* reimplemented from formatted input, the reason being that there are
|
||
|
* all kinds of small differences between formatted and list directed
|
||
|
* parsing. */
|
||
|
|
||
|
|
||
|
/* Subroutines for reading characters from the input. Because a
|
||
|
* repeat count is ambiguous with an integer, we have to read the
|
||
|
* whole digit string before seeing if there is a '*' which signals
|
||
|
* the repeat count. Since we can have a lot of potential leading
|
||
|
* zeros, we have to be able to back up by arbitrary amount. Because
|
||
|
* the input might not be seekable, we have to buffer the data
|
||
|
* ourselves. Data is buffered in scratch[] until it becomes too
|
||
|
* large, after which we start allocating memory on the heap. */
|
||
|
|
||
|
static int repeat_count, saved_length, saved_used, input_complete, at_eol;
|
||
|
static int comma_flag, namelist_mode;
|
||
|
|
||
|
static char last_char, *saved_string;
|
||
|
static bt saved_type;
|
||
|
|
||
|
|
||
|
|
||
|
/* Storage area for values except for strings. Must be large enough
|
||
|
* to hold a complex value (two reals) of the largest kind */
|
||
|
|
||
|
static char value[20];
|
||
|
|
||
|
#define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \
|
||
|
case '5': case '6': case '7': case '8': case '9'
|
||
|
|
||
|
#define CASE_SEPARATORS case ' ': case ',': case '/': case '\n': case '\t'
|
||
|
|
||
|
/* This macro assumes that we're operating on a variable */
|
||
|
|
||
|
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
|
||
|
|| c == '\t')
|
||
|
|
||
|
/* Maximum repeat count. Less than ten times the maximum signed int32. */
|
||
|
|
||
|
#define MAX_REPEAT 200000000
|
||
|
|
||
|
|
||
|
/* push_char()-- Save a character to a string buffer, enlarging it as
|
||
|
* necessary. */
|
||
|
|
||
|
static void
|
||
|
push_char (char c)
|
||
|
{
|
||
|
char *new;
|
||
|
|
||
|
if (saved_string == NULL)
|
||
|
{
|
||
|
saved_string = scratch;
|
||
|
memset (saved_string,0,SCRATCH_SIZE);
|
||
|
saved_length = SCRATCH_SIZE;
|
||
|
saved_used = 0;
|
||
|
}
|
||
|
|
||
|
if (saved_used >= saved_length)
|
||
|
{
|
||
|
saved_length = 2 * saved_length;
|
||
|
new = get_mem (2 * saved_length);
|
||
|
|
||
|
memset (new,0,2 * saved_length);
|
||
|
|
||
|
memcpy (new, saved_string, saved_used);
|
||
|
if (saved_string != scratch)
|
||
|
free_mem (saved_string);
|
||
|
|
||
|
saved_string = new;
|
||
|
}
|
||
|
|
||
|
saved_string[saved_used++] = c;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* free_saved()-- Free the input buffer if necessary. */
|
||
|
|
||
|
static void
|
||
|
free_saved (void)
|
||
|
{
|
||
|
|
||
|
if (saved_string == NULL)
|
||
|
return;
|
||
|
|
||
|
if (saved_string != scratch)
|
||
|
free_mem (saved_string);
|
||
|
|
||
|
saved_string = NULL;
|
||
|
}
|
||
|
|
||
|
|
||
|
static char
|
||
|
next_char (void)
|
||
|
{
|
||
|
int length;
|
||
|
char c, *p;
|
||
|
|
||
|
if (last_char != '\0')
|
||
|
{
|
||
|
at_eol = 0;
|
||
|
c = last_char;
|
||
|
last_char = '\0';
|
||
|
goto done;
|
||
|
}
|
||
|
|
||
|
length = 1;
|
||
|
|
||
|
p = salloc_r (current_unit->s, &length);
|
||
|
if (p == NULL)
|
||
|
{
|
||
|
generate_error (ERROR_OS, NULL);
|
||
|
return '\0';
|
||
|
}
|
||
|
|
||
|
if (length == 0)
|
||
|
longjmp (g.eof_jump, 1);
|
||
|
c = *p;
|
||
|
|
||
|
done:
|
||
|
at_eol = (c == '\n');
|
||
|
return c;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* unget_char()-- Push a character back onto the input */
|
||
|
|
||
|
static void
|
||
|
unget_char (char c)
|
||
|
{
|
||
|
|
||
|
last_char = c;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* eat_spaces()-- Skip over spaces in the input. Returns the nonspace
|
||
|
* character that terminated the eating and also places it back on the
|
||
|
* input. */
|
||
|
|
||
|
static char
|
||
|
eat_spaces (void)
|
||
|
{
|
||
|
char c;
|
||
|
|
||
|
do
|
||
|
{
|
||
|
c = next_char ();
|
||
|
}
|
||
|
while (c == ' ' || c == '\t');
|
||
|
|
||
|
unget_char (c);
|
||
|
return c;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* eat_separator()-- 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 systems usually deliver console input on a line
|
||
|
* basis.
|
||
|
*
|
||
|
* The upshot is that if we see a newline as part of reading a
|
||
|
* 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. */
|
||
|
|
||
|
static void
|
||
|
eat_separator (void)
|
||
|
{
|
||
|
char c;
|
||
|
|
||
|
eat_spaces ();
|
||
|
comma_flag = 0;
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case ',':
|
||
|
comma_flag = 1;
|
||
|
eat_spaces ();
|
||
|
break;
|
||
|
|
||
|
case '/':
|
||
|
input_complete = 1;
|
||
|
next_record (0);
|
||
|
break;
|
||
|
|
||
|
case '\n':
|
||
|
break;
|
||
|
|
||
|
case '!':
|
||
|
if (namelist_mode)
|
||
|
{ /* Eat a namelist comment */
|
||
|
do
|
||
|
c = next_char ();
|
||
|
while (c != '\n');
|
||
|
|
||
|
break;
|
||
|
}
|
||
|
|
||
|
/* Fall Through */
|
||
|
|
||
|
default:
|
||
|
unget_char (c);
|
||
|
break;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
|
||
|
/* finish_separator()-- 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. */
|
||
|
|
||
|
static void
|
||
|
finish_separator (void)
|
||
|
{
|
||
|
char c;
|
||
|
|
||
|
restart:
|
||
|
eat_spaces ();
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case ',':
|
||
|
if (comma_flag)
|
||
|
unget_char (c);
|
||
|
else
|
||
|
{
|
||
|
c = eat_spaces ();
|
||
|
if (c == '\n')
|
||
|
goto restart;
|
||
|
}
|
||
|
|
||
|
break;
|
||
|
|
||
|
case '/':
|
||
|
input_complete = 1;
|
||
|
next_record (0);
|
||
|
break;
|
||
|
|
||
|
case '\n':
|
||
|
goto restart;
|
||
|
|
||
|
case '!':
|
||
|
if (namelist_mode)
|
||
|
{
|
||
|
do
|
||
|
c = next_char ();
|
||
|
while (c != '\n');
|
||
|
|
||
|
goto restart;
|
||
|
}
|
||
|
|
||
|
default:
|
||
|
unget_char (c);
|
||
|
break;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
|
||
|
/* convert_integer()-- Convert an unsigned string to an integer. The
|
||
|
* length value is -1 if we are working on a repeat count. Returns
|
||
|
* nonzero if we have a range problem. As a side effect, frees the
|
||
|
* saved_string. */
|
||
|
|
||
|
static int
|
||
|
convert_integer (int length, int negative)
|
||
|
{
|
||
|
char c, *buffer, message[100];
|
||
|
int m;
|
||
|
int64_t v, max, max10;
|
||
|
|
||
|
buffer = saved_string;
|
||
|
v = 0;
|
||
|
|
||
|
max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
|
||
|
max10 = max / 10;
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = *buffer++;
|
||
|
if (c == '\0')
|
||
|
break;
|
||
|
c -= '0';
|
||
|
|
||
|
if (v > max10)
|
||
|
goto overflow;
|
||
|
v = 10 * v;
|
||
|
|
||
|
if (v > max - c)
|
||
|
goto overflow;
|
||
|
v += c;
|
||
|
}
|
||
|
|
||
|
m = 0;
|
||
|
|
||
|
if (length != -1)
|
||
|
{
|
||
|
if (negative)
|
||
|
v = -v;
|
||
|
set_integer (value, v, length);
|
||
|
}
|
||
|
else
|
||
|
{
|
||
|
repeat_count = v;
|
||
|
|
||
|
if (repeat_count == 0)
|
||
|
{
|
||
|
st_sprintf (message, "Zero repeat count in item %d of list input",
|
||
|
g.item_count);
|
||
|
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
m = 1;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
free_saved ();
|
||
|
return m;
|
||
|
|
||
|
overflow:
|
||
|
if (length == -1)
|
||
|
st_sprintf (message, "Repeat count overflow in item %d of list input",
|
||
|
g.item_count);
|
||
|
else
|
||
|
st_sprintf (message, "Integer overflow while reading item %d",
|
||
|
g.item_count);
|
||
|
|
||
|
free_saved ();
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* parse_repeat()-- Parse a repeat count for logical and complex
|
||
|
* values which cannot begin with a digit. Returns nonzero if we are
|
||
|
* done, zero if we should continue on. */
|
||
|
|
||
|
static int
|
||
|
parse_repeat (void)
|
||
|
{
|
||
|
char c, message[100];
|
||
|
int repeat;
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
repeat = c - '0';
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
return 1;
|
||
|
|
||
|
default:
|
||
|
unget_char (c);
|
||
|
return 0;
|
||
|
}
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
repeat = 10 * repeat + c - '0';
|
||
|
|
||
|
if (repeat > MAX_REPEAT)
|
||
|
{
|
||
|
st_sprintf (message,
|
||
|
"Repeat count overflow in item %d of list input",
|
||
|
g.item_count);
|
||
|
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
break;
|
||
|
|
||
|
case '*':
|
||
|
if (repeat == 0)
|
||
|
{
|
||
|
st_sprintf (message,
|
||
|
"Zero repeat count in item %d of list input",
|
||
|
g.item_count);
|
||
|
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
goto done;
|
||
|
|
||
|
default:
|
||
|
goto bad_repeat;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
done:
|
||
|
repeat_count = repeat;
|
||
|
return 0;
|
||
|
|
||
|
bad_repeat:
|
||
|
st_sprintf (message, "Bad repeat count in item %d of list input",
|
||
|
g.item_count);
|
||
|
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* read_logical()-- Read a logical character on the input */
|
||
|
|
||
|
static void
|
||
|
read_logical (int length)
|
||
|
{
|
||
|
char c, message[100];
|
||
|
int v;
|
||
|
|
||
|
if (parse_repeat ())
|
||
|
return;
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case 't':
|
||
|
case 'T':
|
||
|
v = 1;
|
||
|
break;
|
||
|
case 'f':
|
||
|
case 'F':
|
||
|
v = 0;
|
||
|
break;
|
||
|
|
||
|
case '.':
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case 't':
|
||
|
case 'T':
|
||
|
v = 1;
|
||
|
break;
|
||
|
case 'f':
|
||
|
case 'F':
|
||
|
v = 0;
|
||
|
break;
|
||
|
default:
|
||
|
goto bad_logical;
|
||
|
}
|
||
|
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
return; /* Null value */
|
||
|
|
||
|
default:
|
||
|
goto bad_logical;
|
||
|
}
|
||
|
|
||
|
saved_type = BT_LOGICAL;
|
||
|
saved_length = length;
|
||
|
|
||
|
/* Eat trailing garbage */
|
||
|
|
||
|
do
|
||
|
{
|
||
|
c = next_char ();
|
||
|
}
|
||
|
while (!is_separator (c));
|
||
|
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
free_saved ();
|
||
|
set_integer ((int *) value, v, length);
|
||
|
|
||
|
return;
|
||
|
|
||
|
bad_logical:
|
||
|
st_sprintf (message, "Bad logical value while reading item %d",
|
||
|
g.item_count);
|
||
|
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
}
|
||
|
|
||
|
|
||
|
/* read_integer()-- Reading integers is tricky because we can actually
|
||
|
* be reading a repeat count. We have to store the characters in a
|
||
|
* buffer because we could be reading an integer that is larger than the
|
||
|
* default int used for repeat counts. */
|
||
|
|
||
|
static void
|
||
|
read_integer (int length)
|
||
|
{
|
||
|
char c, message[100];
|
||
|
int negative;
|
||
|
|
||
|
negative = 0;
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case '-':
|
||
|
negative = 1;
|
||
|
/* Fall through */
|
||
|
|
||
|
case '+':
|
||
|
c = next_char ();
|
||
|
goto get_integer;
|
||
|
|
||
|
CASE_SEPARATORS: /* Single null */
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
return;
|
||
|
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
default:
|
||
|
goto bad_integer;
|
||
|
}
|
||
|
|
||
|
/* Take care of what may be a repeat count */
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
case '*':
|
||
|
push_char ('\0');
|
||
|
goto repeat;
|
||
|
|
||
|
CASE_SEPARATORS: /* Not a repeat count */
|
||
|
goto done;
|
||
|
|
||
|
default:
|
||
|
goto bad_integer;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
repeat:
|
||
|
if (convert_integer (-1, 0))
|
||
|
return;
|
||
|
|
||
|
/* Get the real integer */
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
return;
|
||
|
|
||
|
case '-':
|
||
|
negative = 1;
|
||
|
/* Fall through */
|
||
|
|
||
|
case '+':
|
||
|
c = next_char ();
|
||
|
break;
|
||
|
}
|
||
|
|
||
|
get_integer:
|
||
|
if (!isdigit (c))
|
||
|
goto bad_integer;
|
||
|
push_char (c);
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
goto done;
|
||
|
|
||
|
default:
|
||
|
goto bad_integer;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
bad_integer:
|
||
|
free_saved ();
|
||
|
|
||
|
st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
|
||
|
return;
|
||
|
|
||
|
done:
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
|
||
|
push_char ('\0');
|
||
|
if (convert_integer (length, negative))
|
||
|
{
|
||
|
free_saved ();
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
free_saved ();
|
||
|
saved_type = BT_INTEGER;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* read_character()-- Read a character variable */
|
||
|
|
||
|
static void
|
||
|
read_character (int length)
|
||
|
{
|
||
|
char c, quote, message[100];
|
||
|
|
||
|
quote = ' '; /* Space means no quote character */
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c); /* NULL value */
|
||
|
eat_separator ();
|
||
|
return;
|
||
|
|
||
|
case '"':
|
||
|
case '\'':
|
||
|
quote = c;
|
||
|
goto get_string;
|
||
|
|
||
|
default:
|
||
|
push_char (c);
|
||
|
goto get_string;
|
||
|
}
|
||
|
|
||
|
/* Deal with a possible repeat count */
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c);
|
||
|
goto done; /* String was only digits! */
|
||
|
|
||
|
case '*':
|
||
|
push_char ('\0');
|
||
|
goto got_repeat;
|
||
|
|
||
|
default:
|
||
|
push_char (c);
|
||
|
goto get_string; /* Not a repeat count after all */
|
||
|
}
|
||
|
}
|
||
|
|
||
|
got_repeat:
|
||
|
if (convert_integer (-1, 0))
|
||
|
return;
|
||
|
|
||
|
/* Now get the real string */
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c); /* repeated NULL values */
|
||
|
eat_separator ();
|
||
|
return;
|
||
|
|
||
|
case '"':
|
||
|
case '\'':
|
||
|
quote = c;
|
||
|
break;
|
||
|
|
||
|
default:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
}
|
||
|
|
||
|
get_string:
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case '"':
|
||
|
case '\'':
|
||
|
if (c != quote)
|
||
|
{
|
||
|
push_char (c);
|
||
|
break;
|
||
|
}
|
||
|
|
||
|
/* See if we have a doubled quote character or the end of the string */
|
||
|
|
||
|
c = next_char ();
|
||
|
if (c == quote)
|
||
|
{
|
||
|
push_char (quote);
|
||
|
break;
|
||
|
}
|
||
|
|
||
|
unget_char (c);
|
||
|
goto done;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
if (quote == ' ')
|
||
|
{
|
||
|
unget_char (c);
|
||
|
goto done;
|
||
|
}
|
||
|
|
||
|
if (c != '\n')
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
default:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
/* At this point, we have to have a separator, or else the string is invalid */
|
||
|
|
||
|
done:
|
||
|
c = next_char ();
|
||
|
if (is_separator (c))
|
||
|
{
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
saved_type = BT_CHARACTER;
|
||
|
}
|
||
|
else
|
||
|
{
|
||
|
free_saved ();
|
||
|
st_sprintf (message, "Invalid string input in item %d", g.item_count);
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
|
||
|
/* parse_real()-- Parse a component of a complex constant or a real
|
||
|
* number that we are sure is already there. This is a straight real
|
||
|
* number parser. */
|
||
|
|
||
|
static int
|
||
|
parse_real (void *buffer, int length)
|
||
|
{
|
||
|
char c, message[100];
|
||
|
int m, seen_dp;
|
||
|
|
||
|
c = next_char ();
|
||
|
if (c == '-' || c == '+')
|
||
|
{
|
||
|
push_char (c);
|
||
|
c = next_char ();
|
||
|
}
|
||
|
|
||
|
if (!isdigit (c) && c != '.')
|
||
|
goto bad;
|
||
|
|
||
|
push_char (c);
|
||
|
|
||
|
seen_dp = (c == '.') ? 1 : 0;
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
case '.':
|
||
|
if (seen_dp)
|
||
|
goto bad;
|
||
|
|
||
|
seen_dp = 1;
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
case 'e':
|
||
|
case 'E':
|
||
|
case 'd':
|
||
|
case 'D':
|
||
|
push_char ('e');
|
||
|
goto exp1;
|
||
|
|
||
|
case '-':
|
||
|
case '+':
|
||
|
push_char ('e');
|
||
|
push_char (c);
|
||
|
c = next_char ();
|
||
|
goto exp2;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c);
|
||
|
goto done;
|
||
|
|
||
|
default:
|
||
|
goto done;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
exp1:
|
||
|
c = next_char ();
|
||
|
if (c != '-' && c != '+')
|
||
|
push_char ('+');
|
||
|
else
|
||
|
{
|
||
|
push_char (c);
|
||
|
c = next_char ();
|
||
|
}
|
||
|
|
||
|
exp2:
|
||
|
if (!isdigit (c))
|
||
|
goto bad;
|
||
|
push_char (c);
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c);
|
||
|
goto done;
|
||
|
|
||
|
default:
|
||
|
goto done;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
done:
|
||
|
unget_char (c);
|
||
|
push_char ('\0');
|
||
|
|
||
|
m = convert_real (buffer, saved_string, length);
|
||
|
free_saved ();
|
||
|
|
||
|
return m;
|
||
|
|
||
|
bad:
|
||
|
free_saved ();
|
||
|
st_sprintf (message, "Bad floating point number for item %d", g.item_count);
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* read_complex()-- Reading a complex number is straightforward
|
||
|
* because we can tell what it is right away. */
|
||
|
|
||
|
static void
|
||
|
read_complex (int length)
|
||
|
{
|
||
|
char message[100];
|
||
|
char c;
|
||
|
|
||
|
if (parse_repeat ())
|
||
|
return;
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case '(':
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
return;
|
||
|
|
||
|
default:
|
||
|
goto bad_complex;
|
||
|
}
|
||
|
|
||
|
eat_spaces ();
|
||
|
if (parse_real (value, length))
|
||
|
return;
|
||
|
|
||
|
eat_spaces ();
|
||
|
if (next_char () != ',')
|
||
|
goto bad_complex;
|
||
|
|
||
|
eat_spaces ();
|
||
|
if (parse_real (value + length, length))
|
||
|
return;
|
||
|
|
||
|
eat_spaces ();
|
||
|
if (next_char () != ')')
|
||
|
goto bad_complex;
|
||
|
|
||
|
c = next_char ();
|
||
|
if (!is_separator (c))
|
||
|
goto bad_complex;
|
||
|
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
|
||
|
free_saved ();
|
||
|
saved_type = BT_COMPLEX;
|
||
|
return;
|
||
|
|
||
|
bad_complex:
|
||
|
st_sprintf (message, "Bad complex value in item %d of list input",
|
||
|
g.item_count);
|
||
|
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
}
|
||
|
|
||
|
|
||
|
/* read_real()-- Parse a real number with a possible repeat count. */
|
||
|
|
||
|
static void
|
||
|
read_real (int length)
|
||
|
{
|
||
|
char c, message[100];
|
||
|
int seen_dp;
|
||
|
|
||
|
seen_dp = 0;
|
||
|
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
case '.':
|
||
|
push_char (c);
|
||
|
seen_dp = 1;
|
||
|
break;
|
||
|
|
||
|
case '+':
|
||
|
case '-':
|
||
|
goto got_sign;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c); /* Single null */
|
||
|
eat_separator ();
|
||
|
return;
|
||
|
|
||
|
default:
|
||
|
goto bad_real;
|
||
|
}
|
||
|
|
||
|
/* Get the digit string that might be a repeat count */
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
case '.':
|
||
|
if (seen_dp)
|
||
|
goto bad_real;
|
||
|
|
||
|
seen_dp = 1;
|
||
|
push_char (c);
|
||
|
goto real_loop;
|
||
|
|
||
|
case 'E':
|
||
|
case 'e':
|
||
|
case 'D':
|
||
|
case 'd':
|
||
|
goto exp1;
|
||
|
|
||
|
case '+':
|
||
|
case '-':
|
||
|
push_char ('e');
|
||
|
push_char (c);
|
||
|
c = next_char ();
|
||
|
goto exp2;
|
||
|
|
||
|
case '*':
|
||
|
push_char ('\0');
|
||
|
goto got_repeat;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
if (c != '\n')
|
||
|
unget_char (c); /* Real number that is just a digit-string */
|
||
|
goto done;
|
||
|
|
||
|
default:
|
||
|
goto bad_real;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
got_repeat:
|
||
|
if (convert_integer (-1, 0))
|
||
|
return;
|
||
|
|
||
|
/* Now get the number itself */
|
||
|
|
||
|
c = next_char ();
|
||
|
if (is_separator (c))
|
||
|
{ /* Repeated null value */
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
if (c != '-' && c != '+')
|
||
|
push_char ('+');
|
||
|
else
|
||
|
{
|
||
|
got_sign:
|
||
|
push_char (c);
|
||
|
c = next_char ();
|
||
|
}
|
||
|
|
||
|
if (!isdigit (c) && c != '.')
|
||
|
goto bad_real;
|
||
|
|
||
|
if (c == '.')
|
||
|
{
|
||
|
if (seen_dp)
|
||
|
goto bad_real;
|
||
|
else
|
||
|
seen_dp = 1;
|
||
|
}
|
||
|
|
||
|
push_char (c);
|
||
|
|
||
|
real_loop:
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
goto done;
|
||
|
|
||
|
case '.':
|
||
|
if (seen_dp)
|
||
|
goto bad_real;
|
||
|
|
||
|
seen_dp = 1;
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
case 'E':
|
||
|
case 'e':
|
||
|
case 'D':
|
||
|
case 'd':
|
||
|
goto exp1;
|
||
|
|
||
|
case '+':
|
||
|
case '-':
|
||
|
push_char ('e');
|
||
|
push_char (c);
|
||
|
c = next_char ();
|
||
|
goto exp2;
|
||
|
|
||
|
default:
|
||
|
goto bad_real;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
exp1:
|
||
|
push_char ('e');
|
||
|
|
||
|
c = next_char ();
|
||
|
if (c != '+' && c != '-')
|
||
|
push_char ('+');
|
||
|
else
|
||
|
{
|
||
|
push_char (c);
|
||
|
c = next_char ();
|
||
|
}
|
||
|
|
||
|
exp2:
|
||
|
if (!isdigit (c))
|
||
|
goto bad_real;
|
||
|
push_char (c);
|
||
|
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
|
||
|
switch (c)
|
||
|
{
|
||
|
CASE_DIGITS:
|
||
|
push_char (c);
|
||
|
break;
|
||
|
|
||
|
CASE_SEPARATORS:
|
||
|
unget_char (c);
|
||
|
eat_separator ();
|
||
|
goto done;
|
||
|
|
||
|
default:
|
||
|
goto bad_real;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
done:
|
||
|
push_char ('\0');
|
||
|
if (convert_real (value, saved_string, length))
|
||
|
return;
|
||
|
|
||
|
free_saved ();
|
||
|
saved_type = BT_REAL;
|
||
|
return;
|
||
|
|
||
|
bad_real:
|
||
|
st_sprintf (message, "Bad real number in item %d of list input",
|
||
|
g.item_count);
|
||
|
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
}
|
||
|
|
||
|
|
||
|
/* check_type()-- Check the current type against the saved type to
|
||
|
* make sure they are compatible. Returns nonzero if incompatible. */
|
||
|
|
||
|
static int
|
||
|
check_type (bt type, int len)
|
||
|
{
|
||
|
char message[100];
|
||
|
|
||
|
if (saved_type != BT_NULL && saved_type != type)
|
||
|
{
|
||
|
st_sprintf (message, "Read type %s where %s was expected for item %d",
|
||
|
type_name (saved_type), type_name (type), g.item_count);
|
||
|
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
|
||
|
return 0;
|
||
|
|
||
|
if (saved_length != len)
|
||
|
{
|
||
|
st_sprintf (message,
|
||
|
"Read kind %d %s where kind %d is required for item %d",
|
||
|
saved_length, type_name (saved_type), len, g.item_count);
|
||
|
generate_error (ERROR_READ_VALUE, message);
|
||
|
return 1;
|
||
|
}
|
||
|
|
||
|
return 0;
|
||
|
}
|
||
|
|
||
|
|
||
|
/* list_formatted_read()-- Top level data transfer subroutine for list
|
||
|
* reads. Because we have to deal with repeat counts, the data item
|
||
|
* is always saved after reading, usually in the value[] array. If a
|
||
|
* repeat count is greater than one, we copy the data item multiple
|
||
|
* times. */
|
||
|
|
||
|
void
|
||
|
list_formatted_read (bt type, void *p, int len)
|
||
|
{
|
||
|
char c;
|
||
|
int m;
|
||
|
|
||
|
namelist_mode = 0;
|
||
|
|
||
|
if (setjmp (g.eof_jump))
|
||
|
{
|
||
|
generate_error (ERROR_END, NULL);
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
if (g.first_item)
|
||
|
{
|
||
|
g.first_item = 0;
|
||
|
input_complete = 0;
|
||
|
repeat_count = 1;
|
||
|
at_eol = 0;
|
||
|
|
||
|
c = eat_spaces ();
|
||
|
if (is_separator (c))
|
||
|
{ /* Found a null value */
|
||
|
eat_separator ();
|
||
|
repeat_count = 0;
|
||
|
if (at_eol)
|
||
|
finish_separator ();
|
||
|
else
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
}
|
||
|
else
|
||
|
{
|
||
|
if (input_complete)
|
||
|
return;
|
||
|
|
||
|
if (repeat_count > 0)
|
||
|
{
|
||
|
if (check_type (type, len))
|
||
|
return;
|
||
|
goto set_value;
|
||
|
}
|
||
|
|
||
|
if (at_eol)
|
||
|
finish_separator ();
|
||
|
else
|
||
|
eat_spaces ();
|
||
|
|
||
|
saved_type = BT_NULL;
|
||
|
repeat_count = 1;
|
||
|
}
|
||
|
|
||
|
|
||
|
switch (type)
|
||
|
{
|
||
|
case BT_INTEGER:
|
||
|
read_integer (len);
|
||
|
break;
|
||
|
case BT_LOGICAL:
|
||
|
read_logical (len);
|
||
|
break;
|
||
|
case BT_CHARACTER:
|
||
|
read_character (len);
|
||
|
break;
|
||
|
case BT_REAL:
|
||
|
read_real (len);
|
||
|
break;
|
||
|
case BT_COMPLEX:
|
||
|
read_complex (len);
|
||
|
break;
|
||
|
default:
|
||
|
internal_error ("Bad type for list read");
|
||
|
}
|
||
|
|
||
|
if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
|
||
|
saved_length = len;
|
||
|
|
||
|
if (ioparm.library_return != LIBRARY_OK)
|
||
|
return;
|
||
|
|
||
|
set_value:
|
||
|
switch (saved_type)
|
||
|
{
|
||
|
case BT_COMPLEX:
|
||
|
len = 2 * len;
|
||
|
/* Fall through */
|
||
|
|
||
|
case BT_INTEGER:
|
||
|
case BT_REAL:
|
||
|
case BT_LOGICAL:
|
||
|
memcpy (p, value, len);
|
||
|
break;
|
||
|
|
||
|
case BT_CHARACTER:
|
||
|
m = (len < saved_used) ? len : saved_used;
|
||
|
memcpy (p, saved_string, m);
|
||
|
|
||
|
if (m < len)
|
||
|
memset (((char *) p) + m, ' ', len - m);
|
||
|
break;
|
||
|
|
||
|
case BT_NULL:
|
||
|
break;
|
||
|
}
|
||
|
|
||
|
if (--repeat_count <= 0)
|
||
|
free_saved ();
|
||
|
}
|
||
|
|
||
|
void
|
||
|
init_at_eol()
|
||
|
{
|
||
|
at_eol = 0;
|
||
|
}
|
||
|
|
||
|
/* finish_list_read()-- Finish a list read */
|
||
|
|
||
|
void
|
||
|
finish_list_read (void)
|
||
|
{
|
||
|
char c;
|
||
|
|
||
|
free_saved ();
|
||
|
|
||
|
if (at_eol)
|
||
|
{
|
||
|
at_eol = 0;
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
|
||
|
do
|
||
|
{
|
||
|
c = next_char ();
|
||
|
}
|
||
|
while (c != '\n');
|
||
|
}
|
||
|
|
||
|
static namelist_info *
|
||
|
find_nml_node (char * var_name)
|
||
|
{
|
||
|
namelist_info * t = ionml;
|
||
|
while (t != NULL)
|
||
|
{
|
||
|
if (strcmp (var_name,t->var_name) == 0)
|
||
|
{
|
||
|
t->value_acquired = 1;
|
||
|
return t;
|
||
|
}
|
||
|
t = t->next;
|
||
|
}
|
||
|
return NULL;
|
||
|
}
|
||
|
|
||
|
static void
|
||
|
match_namelist_name (char *name, int len)
|
||
|
{
|
||
|
int name_len;
|
||
|
char c;
|
||
|
char * namelist_name = name;
|
||
|
|
||
|
name_len = 0;
|
||
|
/* Match the name of the namelist */
|
||
|
|
||
|
if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
|
||
|
{
|
||
|
wrong_name:
|
||
|
generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
while (name_len < len)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
if (tolower (c) != tolower (namelist_name[name_len++]))
|
||
|
goto wrong_name;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
|
||
|
/********************************************************************
|
||
|
Namelist reads
|
||
|
********************************************************************/
|
||
|
|
||
|
/* namelist_read()-- Process a namelist read. This subroutine
|
||
|
* initializes things, positions to the first element and */
|
||
|
|
||
|
void
|
||
|
namelist_read (void)
|
||
|
{
|
||
|
char c;
|
||
|
int name_matched, next_name ;
|
||
|
namelist_info * nl;
|
||
|
int len, m;
|
||
|
void * p;
|
||
|
|
||
|
namelist_mode = 1;
|
||
|
|
||
|
if (setjmp (g.eof_jump))
|
||
|
{
|
||
|
generate_error (ERROR_END, NULL);
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
restart:
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case ' ':
|
||
|
goto restart;
|
||
|
case '!':
|
||
|
do
|
||
|
c = next_char ();
|
||
|
while (c != '\n');
|
||
|
|
||
|
goto restart;
|
||
|
|
||
|
case '&':
|
||
|
break;
|
||
|
|
||
|
default:
|
||
|
generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
/* Match the name of the namelist */
|
||
|
match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
|
||
|
|
||
|
/* Ready to read namelist elements */
|
||
|
for (;;)
|
||
|
{
|
||
|
c = next_char ();
|
||
|
switch (c)
|
||
|
{
|
||
|
case '&':
|
||
|
match_namelist_name("end",3);
|
||
|
return;
|
||
|
case '\\':
|
||
|
return;
|
||
|
case ' ':
|
||
|
case '\n':
|
||
|
case '\t':
|
||
|
break;
|
||
|
case ',':
|
||
|
next_name = 1;
|
||
|
break;
|
||
|
|
||
|
case '=':
|
||
|
name_matched = 1;
|
||
|
nl = find_nml_node (saved_string);
|
||
|
if (nl == NULL)
|
||
|
internal_error ("Can not found a valid namelist var!");
|
||
|
free_saved();
|
||
|
|
||
|
len = nl->len;
|
||
|
p = nl->mem_pos;
|
||
|
switch (nl->type)
|
||
|
{
|
||
|
case BT_INTEGER:
|
||
|
read_integer (len);
|
||
|
break;
|
||
|
case BT_LOGICAL:
|
||
|
read_logical (len);
|
||
|
break;
|
||
|
case BT_CHARACTER:
|
||
|
read_character (len);
|
||
|
break;
|
||
|
case BT_REAL:
|
||
|
read_real (len);
|
||
|
break;
|
||
|
case BT_COMPLEX:
|
||
|
read_complex (len);
|
||
|
break;
|
||
|
default:
|
||
|
internal_error ("Bad type for namelist read");
|
||
|
}
|
||
|
|
||
|
switch (saved_type)
|
||
|
{
|
||
|
case BT_COMPLEX:
|
||
|
len = 2 * len;
|
||
|
/* Fall through */
|
||
|
|
||
|
case BT_INTEGER:
|
||
|
case BT_REAL:
|
||
|
case BT_LOGICAL:
|
||
|
memcpy (p, value, len);
|
||
|
break;
|
||
|
|
||
|
case BT_CHARACTER:
|
||
|
m = (len < saved_used) ? len : saved_used;
|
||
|
memcpy (p, saved_string, m);
|
||
|
|
||
|
if (m < len)
|
||
|
memset (((char *) p) + m, ' ', len - m);
|
||
|
break;
|
||
|
|
||
|
case BT_NULL:
|
||
|
break;
|
||
|
}
|
||
|
|
||
|
break;
|
||
|
|
||
|
default :
|
||
|
push_char(c);
|
||
|
break;
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|