2004-08-23 16:28:31 +02:00
|
|
|
/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
|
2004-05-13 08:41:07 +02:00
|
|
|
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
|
2004-08-23 16:28:31 +02:00
|
|
|
reimplemented from formatted input, the reason being that there are
|
|
|
|
all kinds of small differences between formatted and list directed
|
|
|
|
parsing. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
|
|
|
|
/* Subroutines for reading characters from the input. Because a
|
2004-08-23 16:28:31 +02:00
|
|
|
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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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
|
2004-08-23 16:28:31 +02:00
|
|
|
to hold a complex value (two reals) of the largest kind. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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'
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* This macro assumes that we're operating on a variable. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \
|
|
|
|
|| c == '\t')
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Maximum repeat count. Less than ten times the maximum signed int32. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
#define MAX_REPEAT 200000000
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Save a character to a string buffer, enlarging it as necessary. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Free the input buffer if necessary. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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)
|
2004-08-31 22:37:43 +02:00
|
|
|
{
|
|
|
|
/* 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 ())
|
|
|
|
c = '\n';
|
|
|
|
else
|
|
|
|
longjmp (g.eof_jump, 1);
|
|
|
|
}
|
|
|
|
else
|
|
|
|
c = *p;
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
done:
|
|
|
|
at_eol = (c == '\n');
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Push a character back onto the input. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
static void
|
|
|
|
unget_char (char c)
|
|
|
|
{
|
|
|
|
last_char = c;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Skip over spaces in the input. Returns the nonspace character that
|
|
|
|
terminated the eating and also places it back on the input. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
static char
|
|
|
|
eat_spaces (void)
|
|
|
|
{
|
|
|
|
char c;
|
|
|
|
|
|
|
|
do
|
|
|
|
{
|
|
|
|
c = next_char ();
|
|
|
|
}
|
|
|
|
while (c == ' ' || c == '\t');
|
|
|
|
|
|
|
|
unget_char (c);
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* 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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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);
|
2004-08-31 16:56:09 +02:00
|
|
|
at_eol = 1;
|
2004-05-13 08:41:07 +02:00
|
|
|
break;
|
|
|
|
|
|
|
|
case '\n':
|
|
|
|
break;
|
|
|
|
|
|
|
|
case '!':
|
|
|
|
if (namelist_mode)
|
2004-08-23 16:28:31 +02:00
|
|
|
{ /* Eat a namelist comment. */
|
2004-05-13 08:41:07 +02:00
|
|
|
do
|
|
|
|
c = next_char ();
|
|
|
|
while (c != '\n');
|
|
|
|
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Fall Through... */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
default:
|
|
|
|
unget_char (c);
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* 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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
static void
|
|
|
|
finish_separator (void)
|
|
|
|
{
|
|
|
|
char c;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
restart:
|
2004-05-13 08:41:07 +02:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* 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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
overflow:
|
2004-05-13 08:41:07 +02:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* 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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
done:
|
2004-05-13 08:41:07 +02:00
|
|
|
repeat_count = repeat;
|
|
|
|
return 0;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
bad_repeat:
|
2004-05-13 08:41:07 +02:00
|
|
|
st_sprintf (message, "Bad repeat count in item %d of list input",
|
|
|
|
g.item_count);
|
|
|
|
|
|
|
|
generate_error (ERROR_READ_VALUE, message);
|
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Read a logical character on the input. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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 ();
|
2004-08-23 16:28:31 +02:00
|
|
|
return; /* Null value. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
default:
|
|
|
|
goto bad_logical;
|
|
|
|
}
|
|
|
|
|
|
|
|
saved_type = BT_LOGICAL;
|
|
|
|
saved_length = length;
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Eat trailing garbage. */
|
2004-05-13 08:41:07 +02:00
|
|
|
do
|
|
|
|
{
|
|
|
|
c = next_char ();
|
|
|
|
}
|
|
|
|
while (!is_separator (c));
|
|
|
|
|
|
|
|
unget_char (c);
|
|
|
|
eat_separator ();
|
|
|
|
free_saved ();
|
|
|
|
set_integer ((int *) value, v, length);
|
|
|
|
|
|
|
|
return;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
bad_logical:
|
2004-05-13 08:41:07 +02:00
|
|
|
st_sprintf (message, "Bad logical value while reading item %d",
|
|
|
|
g.item_count);
|
|
|
|
|
|
|
|
generate_error (ERROR_READ_VALUE, message);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* 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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
static void
|
|
|
|
read_integer (int length)
|
|
|
|
{
|
|
|
|
char c, message[100];
|
|
|
|
int negative;
|
|
|
|
|
|
|
|
negative = 0;
|
|
|
|
|
|
|
|
c = next_char ();
|
|
|
|
switch (c)
|
|
|
|
{
|
|
|
|
case '-':
|
|
|
|
negative = 1;
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Fall through... */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
case '+':
|
|
|
|
c = next_char ();
|
|
|
|
goto get_integer;
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
CASE_SEPARATORS: /* Single null. */
|
2004-05-13 08:41:07 +02:00
|
|
|
unget_char (c);
|
|
|
|
eat_separator ();
|
|
|
|
return;
|
|
|
|
|
|
|
|
CASE_DIGITS:
|
|
|
|
push_char (c);
|
|
|
|
break;
|
|
|
|
|
|
|
|
default:
|
|
|
|
goto bad_integer;
|
|
|
|
}
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Take care of what may be a repeat count. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
for (;;)
|
|
|
|
{
|
|
|
|
c = next_char ();
|
|
|
|
switch (c)
|
|
|
|
{
|
|
|
|
CASE_DIGITS:
|
|
|
|
push_char (c);
|
|
|
|
break;
|
|
|
|
|
|
|
|
case '*':
|
|
|
|
push_char ('\0');
|
|
|
|
goto repeat;
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
CASE_SEPARATORS: /* Not a repeat count. */
|
2004-05-13 08:41:07 +02:00
|
|
|
goto done;
|
|
|
|
|
|
|
|
default:
|
|
|
|
goto bad_integer;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
repeat:
|
2004-05-13 08:41:07 +02:00
|
|
|
if (convert_integer (-1, 0))
|
|
|
|
return;
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Get the real integer. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
c = next_char ();
|
|
|
|
switch (c)
|
|
|
|
{
|
|
|
|
CASE_DIGITS:
|
|
|
|
break;
|
|
|
|
|
|
|
|
CASE_SEPARATORS:
|
|
|
|
unget_char (c);
|
|
|
|
eat_separator ();
|
|
|
|
return;
|
|
|
|
|
|
|
|
case '-':
|
|
|
|
negative = 1;
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Fall through... */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
case '+':
|
|
|
|
c = next_char ();
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
get_integer:
|
2004-05-13 08:41:07 +02:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
bad_integer:
|
2004-05-13 08:41:07 +02:00
|
|
|
free_saved ();
|
|
|
|
|
|
|
|
st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
|
|
|
|
generate_error (ERROR_READ_VALUE, message);
|
|
|
|
|
|
|
|
return;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
done:
|
2004-05-13 08:41:07 +02:00
|
|
|
unget_char (c);
|
|
|
|
eat_separator ();
|
|
|
|
|
|
|
|
push_char ('\0');
|
|
|
|
if (convert_integer (length, negative))
|
|
|
|
{
|
|
|
|
free_saved ();
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
|
|
|
|
free_saved ();
|
|
|
|
saved_type = BT_INTEGER;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Read a character variable. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
static void
|
|
|
|
read_character (int length)
|
|
|
|
{
|
|
|
|
char c, quote, message[100];
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
quote = ' '; /* Space means no quote character. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
c = next_char ();
|
|
|
|
switch (c)
|
|
|
|
{
|
|
|
|
CASE_DIGITS:
|
|
|
|
push_char (c);
|
|
|
|
break;
|
|
|
|
|
|
|
|
CASE_SEPARATORS:
|
2004-08-23 16:28:31 +02:00
|
|
|
unget_char (c); /* NULL value. */
|
2004-05-13 08:41:07 +02:00
|
|
|
eat_separator ();
|
|
|
|
return;
|
|
|
|
|
|
|
|
case '"':
|
|
|
|
case '\'':
|
|
|
|
quote = c;
|
|
|
|
goto get_string;
|
|
|
|
|
|
|
|
default:
|
|
|
|
push_char (c);
|
|
|
|
goto get_string;
|
|
|
|
}
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Deal with a possible repeat count. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
for (;;)
|
|
|
|
{
|
|
|
|
c = next_char ();
|
|
|
|
switch (c)
|
|
|
|
{
|
|
|
|
CASE_DIGITS:
|
|
|
|
push_char (c);
|
|
|
|
break;
|
|
|
|
|
|
|
|
CASE_SEPARATORS:
|
|
|
|
unget_char (c);
|
2004-08-23 16:28:31 +02:00
|
|
|
goto done; /* String was only digits! */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
case '*':
|
|
|
|
push_char ('\0');
|
|
|
|
goto got_repeat;
|
|
|
|
|
|
|
|
default:
|
|
|
|
push_char (c);
|
2004-08-23 16:28:31 +02:00
|
|
|
goto get_string; /* Not a repeat count after all. */
|
2004-05-13 08:41:07 +02:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
got_repeat:
|
2004-05-13 08:41:07 +02:00
|
|
|
if (convert_integer (-1, 0))
|
|
|
|
return;
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Now get the real string. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
c = next_char ();
|
|
|
|
switch (c)
|
|
|
|
{
|
|
|
|
CASE_SEPARATORS:
|
2004-08-23 16:28:31 +02:00
|
|
|
unget_char (c); /* Repeated NULL values. */
|
2004-05-13 08:41:07 +02:00
|
|
|
eat_separator ();
|
|
|
|
return;
|
|
|
|
|
|
|
|
case '"':
|
|
|
|
case '\'':
|
|
|
|
quote = c;
|
|
|
|
break;
|
|
|
|
|
|
|
|
default:
|
|
|
|
push_char (c);
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
get_string:
|
2004-05-13 08:41:07 +02:00
|
|
|
for (;;)
|
|
|
|
{
|
|
|
|
c = next_char ();
|
|
|
|
switch (c)
|
|
|
|
{
|
|
|
|
case '"':
|
|
|
|
case '\'':
|
|
|
|
if (c != quote)
|
|
|
|
{
|
|
|
|
push_char (c);
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* See if we have a doubled quote character or the end of
|
|
|
|
the string. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
/* At this point, we have to have a separator, or else the string is
|
|
|
|
invalid. */
|
|
|
|
done:
|
2004-05-13 08:41:07 +02:00
|
|
|
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);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* 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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
exp1:
|
2004-05-13 08:41:07 +02:00
|
|
|
c = next_char ();
|
|
|
|
if (c != '-' && c != '+')
|
|
|
|
push_char ('+');
|
|
|
|
else
|
|
|
|
{
|
|
|
|
push_char (c);
|
|
|
|
c = next_char ();
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
exp2:
|
2004-05-13 08:41:07 +02:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
done:
|
2004-05-13 08:41:07 +02:00
|
|
|
unget_char (c);
|
|
|
|
push_char ('\0');
|
|
|
|
|
|
|
|
m = convert_real (buffer, saved_string, length);
|
|
|
|
free_saved ();
|
|
|
|
|
|
|
|
return m;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
bad:
|
2004-05-13 08:41:07 +02:00
|
|
|
free_saved ();
|
|
|
|
st_sprintf (message, "Bad floating point number for item %d", g.item_count);
|
|
|
|
generate_error (ERROR_READ_VALUE, message);
|
|
|
|
|
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Reading a complex number is straightforward because we can tell
|
|
|
|
what it is right away. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
bad_complex:
|
2004-05-13 08:41:07 +02:00
|
|
|
st_sprintf (message, "Bad complex value in item %d of list input",
|
|
|
|
g.item_count);
|
|
|
|
|
|
|
|
generate_error (ERROR_READ_VALUE, message);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Parse a real number with a possible repeat count. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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:
|
2004-08-23 16:28:31 +02:00
|
|
|
unget_char (c); /* Single null. */
|
2004-05-13 08:41:07 +02:00
|
|
|
eat_separator ();
|
|
|
|
return;
|
|
|
|
|
|
|
|
default:
|
|
|
|
goto bad_real;
|
|
|
|
}
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Get the digit string that might be a repeat count. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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:
|
2004-12-15 13:42:39 +01:00
|
|
|
if (c != '\n' && c != ',')
|
2004-08-23 16:28:31 +02:00
|
|
|
unget_char (c); /* Real number that is just a digit-string. */
|
2004-05-13 08:41:07 +02:00
|
|
|
goto done;
|
|
|
|
|
|
|
|
default:
|
|
|
|
goto bad_real;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
got_repeat:
|
2004-05-13 08:41:07 +02:00
|
|
|
if (convert_integer (-1, 0))
|
|
|
|
return;
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Now get the number itself. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
c = next_char ();
|
|
|
|
if (is_separator (c))
|
2004-08-23 16:28:31 +02:00
|
|
|
{ /* Repeated null value. */
|
2004-05-13 08:41:07 +02:00
|
|
|
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);
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
real_loop:
|
2004-05-13 08:41:07 +02:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
exp1:
|
2004-05-13 08:41:07 +02:00
|
|
|
push_char ('e');
|
|
|
|
|
|
|
|
c = next_char ();
|
|
|
|
if (c != '+' && c != '-')
|
|
|
|
push_char ('+');
|
|
|
|
else
|
|
|
|
{
|
|
|
|
push_char (c);
|
|
|
|
c = next_char ();
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
exp2:
|
2004-05-13 08:41:07 +02:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
done:
|
2004-05-13 08:41:07 +02:00
|
|
|
push_char ('\0');
|
|
|
|
if (convert_real (value, saved_string, length))
|
|
|
|
return;
|
|
|
|
|
|
|
|
free_saved ();
|
|
|
|
saved_type = BT_REAL;
|
|
|
|
return;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
bad_real:
|
2004-05-13 08:41:07 +02:00
|
|
|
st_sprintf (message, "Bad real number in item %d of list input",
|
|
|
|
g.item_count);
|
|
|
|
|
|
|
|
generate_error (ERROR_READ_VALUE, message);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Check the current type against the saved type to make sure they are
|
|
|
|
compatible. Returns nonzero if incompatible. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* 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. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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))
|
2004-08-23 16:28:31 +02:00
|
|
|
{ /* Found a null value. */
|
2004-05-13 08:41:07 +02:00
|
|
|
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
|
2004-09-14 02:56:46 +02:00
|
|
|
{
|
|
|
|
eat_spaces ();
|
|
|
|
/* trailing spaces prior to end of line */
|
|
|
|
if (at_eol)
|
|
|
|
finish_separator ();
|
|
|
|
}
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
set_value:
|
2004-05-13 08:41:07 +02:00
|
|
|
switch (saved_type)
|
|
|
|
{
|
|
|
|
case BT_COMPLEX:
|
|
|
|
len = 2 * len;
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Fall through. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
case BT_INTEGER:
|
|
|
|
case BT_REAL:
|
|
|
|
case BT_LOGICAL:
|
|
|
|
memcpy (p, value, len);
|
|
|
|
break;
|
|
|
|
|
|
|
|
case BT_CHARACTER:
|
2004-06-19 18:42:05 +02:00
|
|
|
if (saved_string)
|
|
|
|
{
|
|
|
|
m = (len < saved_used) ? len : saved_used;
|
|
|
|
memcpy (p, saved_string, m);
|
|
|
|
}
|
2004-08-23 16:28:31 +02:00
|
|
|
else
|
|
|
|
/* Just delimiters encountered, nothing to copy but SPACE. */
|
2004-06-19 18:42:05 +02:00
|
|
|
m = 0;
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
if (m < len)
|
|
|
|
memset (((char *) p) + m, ' ', len - m);
|
|
|
|
break;
|
|
|
|
|
|
|
|
case BT_NULL:
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (--repeat_count <= 0)
|
|
|
|
free_saved ();
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
init_at_eol(void)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
at_eol = 0;
|
|
|
|
}
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Finish a list read. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Match the name of the namelist. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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
|
|
|
|
********************************************************************/
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Process a namelist read. This subroutine initializes things,
|
|
|
|
positions to the first element and
|
|
|
|
FIXME: was this comment ever complete? */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
c99_functions.c, [...]: Whitespace fixes.
* intrinsics/c99_functions.c, intrinsics/eoshift0.c,
intrinsics/eoshift2.c, intrinsics/exit.c, intrinsics/flush.c,
intrinsics/ishftc.c, intrinsics/mvbits.c, intrinsics/pack_generic.c,
intrinsics/random.c, intrinsics/reshape_generic.c, intrinsics/size.c,
intrinsics/spread_generic.c, intrinsics/stat.c,
intrinsics/string_intrinsics.c, intrinsics/system_clock.c,
intrinsics/transpose_generic.c, intrinsics/unlink.c,
intrinsics/unpack_generic.c, io/backspace.c, io/format.c,
io/list_read.c, io/lock.c, io/open.c, io/transfer.c, io/unix.c,
io/write.c, runtime/environ.c, runtime/error.c,
runtime/in_pack_generic.c, runtime/in_unpack_generic.c, runtime/main.c,
runtime/memory.c, runtime/pause.c, runtime/stop.c,
runtime/string.c: Whitespace fixes.
From-SVN: r91794
2004-12-07 01:01:01 +01:00
|
|
|
restart:
|
2004-05-13 08:41:07 +02:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Match the name of the namelist. */
|
2004-05-13 08:41:07 +02:00
|
|
|
match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
|
|
|
|
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Ready to read namelist elements. */
|
2004-08-10 15:34:04 +02:00
|
|
|
while (!input_complete)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
c = next_char ();
|
|
|
|
switch (c)
|
|
|
|
{
|
2004-08-10 15:34:04 +02:00
|
|
|
case '/':
|
|
|
|
input_complete = 1;
|
|
|
|
next_record (0);
|
|
|
|
break;
|
2004-05-13 08:41:07 +02:00
|
|
|
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)
|
2004-08-10 15:34:04 +02:00
|
|
|
internal_error ("Can not match a namelist variable");
|
2004-05-13 08:41:07 +02:00
|
|
|
free_saved();
|
|
|
|
|
|
|
|
len = nl->len;
|
|
|
|
p = nl->mem_pos;
|
2004-09-21 13:22:47 +02:00
|
|
|
|
|
|
|
/* skip any blanks or tabs after the = */
|
|
|
|
eat_spaces ();
|
|
|
|
|
2004-05-13 08:41:07 +02:00
|
|
|
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;
|
2004-08-23 16:28:31 +02:00
|
|
|
/* Fall through... */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
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 :
|
2004-08-10 15:34:04 +02:00
|
|
|
push_char(tolower(c));
|
2004-05-13 08:41:07 +02:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|