2004-12-06 Richard Henderson <rth@redhat.com>
+ * 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.
+
+2004-12-06 Richard Henderson <rth@redhat.com>
+
* Makefile.am: Generate all m4 output under $(srcdir).
* Makefile.in: Regenerate.
{
__eoshift0 (ret, array, *pshift, pbound, pdim ? *pdim : 1);
}
-
{
__eoshift2 (ret, array, *pshift, bound, pdim ? *pdim : 1);
}
-
void
prefix(exit_i4) (GFC_INTEGER_4 * status)
{
-
if (status == NULL)
exit(0);
exit(*status);
void
prefix(exit_i8) (GFC_INTEGER_8 * status)
{
-
if (status == NULL)
exit(0);
exit((int) *status);
void
prefix(flush_i4) (GFC_INTEGER_4 * unit)
{
-
gfc_unit *us;
/* flush all streams */
bits = i & ~mask;
return (i & mask) | (bits >> (size - shift)) | ((i << shift) & ~mask);
}
-
# undef TYPE
# undef UTYPE
#endif
-
if (vector != NULL)
{
-
/* The return array will have as many
elements as there are in VECTOR. */
total = vector->dim[0].ubound + 1 - vector->dim[0].lbound;
void
prefix(arandom_r4) (gfc_array_r4 *x)
{
-
index_type count[GFC_MAX_DIMENSIONS - 1];
index_type extent[GFC_MAX_DIMENSIONS - 1];
index_type stride[GFC_MAX_DIMENSIONS - 1];
void
prefix(arandom_r8) (gfc_array_r8 *x)
{
-
index_type count[GFC_MAX_DIMENSIONS - 1];
index_type extent[GFC_MAX_DIMENSIONS - 1];
index_type stride[GFC_MAX_DIMENSIONS - 1];
must be called with no argument or exactly one argument. */
void
-random_seed (GFC_INTEGER_4 *size, gfc_array_i4 * put,
- gfc_array_i4 * get)
+random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
{
-
int i;
if (size == NULL && put == NULL && get == NULL)
get->data[i * get->dim[0].stride] = (GFC_INTEGER_4) kiss_seed[i];
}
}
-
-
size = 0;
return size;
}
-
prefix(stat_i4_sub) (char * name, gfc_array_i4 * sarray,
GFC_INTEGER_4 * status, gfc_charlen_type name_len)
{
-
int val;
char *str;
struct stat sb;
prefix(stat_i8_sub) (char * name, gfc_array_i8 * sarray,
GFC_INTEGER_8 * status, gfc_charlen_type name_len)
{
-
int val;
char *str;
struct stat sb;
prefix(stat_i8) (char * name, gfc_array_i8 * sarray,
gfc_charlen_type name_len)
{
-
GFC_INTEGER_8 val;
prefix(stat_i8_sub) (name, sarray, &val, name_len);
return val;
prefix(fstat_i4_sub) (GFC_INTEGER_4 * unit, gfc_array_i4 * sarray,
GFC_INTEGER_4 * status)
{
-
int val;
struct stat sb;
prefix(fstat_i8_sub) (GFC_INTEGER_8 * unit, gfc_array_i8 * sarray,
GFC_INTEGER_8 * status)
{
-
int val;
struct stat sb;
GFC_INTEGER_4
prefix(fstat_i4) (GFC_INTEGER_4 * unit, gfc_array_i4 * sarray)
{
-
GFC_INTEGER_4 val;
prefix(fstat_i4_sub) (unit, sarray, &val);
return val;
GFC_INTEGER_8
prefix(fstat_i8) (GFC_INTEGER_8 * unit, gfc_array_i8 * sarray)
{
-
GFC_INTEGER_8 val;
prefix(fstat_i8_sub) (unit, sarray, &val);
return val;
/* Return string with all trailing blanks removed. */
void
-string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen, const char * src)
+string_trim (GFC_INTEGER_4 * len, void ** dest, GFC_INTEGER_4 slen,
+ const char * src)
{
int i;
memmove (dest + (i * slen), src, slen);
}
}
-
if (count_max != NULL)
*count_max = mx;
}
-
rptr += rxstride - (rystride * xcount);
}
}
-
prefix(unlink_i8_sub) (char * name, GFC_INTEGER_8 * status,
gfc_charlen_type name_len)
{
-
GFC_INTEGER_4 status4;
-
prefix (unlink_i4_sub) (name, &status4, name_len);
if (status)
*status = status4;
prefix(unlink_i4_sub) (name, &status, name_len);
return status;
}
-
mptr = mask->data;
vptr = vector->data;
-
/* Use the same loop for both logical types. */
if (GFC_DESCRIPTOR_SIZE (mask) != 4)
{
tmp.data = field;
__unpack1 (ret, vector, mask, &tmp);
}
-
}
while (base != 0);
-/* base is the new pointer. Seek to it exactly */
-
-done:
+ /* base is the new pointer. Seek to it exactly */
+ done:
if (sseek (current_unit->s, base) == FAILURE)
goto io_error;
current_unit->last_record--;
return;
-io_error:
+ io_error:
generate_error (ERROR_OS, NULL);
}
current_unit->last_record--;
return;
-io_error:
+ io_error:
generate_error (ERROR_OS, NULL);
}
unformatted_backspace ();
}
-done:
+ done:
library_end ();
}
void
free_fnodes (void)
{
-
if (avail - array >= FARRAY_SIZE)
free_fnode (&array[0]);
head = tail = NULL;
-/* Get the next format item */
-
-format_item:
+ /* Get the next format item */
+ format_item:
t = format_lex ();
switch (t)
{
goto finished;
}
-/* In this state, t must currently be a data descriptor. Deal with
- * things that can/must follow the descriptor */
-
-data_desc:
+ /* In this state, t must currently be a data descriptor. Deal with
+ things that can/must follow the descriptor */
+ data_desc:
switch (t)
{
case FMT_P:
tail->u.real.e = -1;
-/* Look for optional exponent */
-
+ /* Look for optional exponent */
t = format_lex ();
if (t != FMT_E)
saved_token = t;
goto finished;
}
-/* Between a descriptor and what comes next */
-between_desc:
+ /* Between a descriptor and what comes next */
+ between_desc:
t = format_lex ();
switch (t)
{
goto finished;
}
-/* Optional comma is a weird between state where we've just finished
- * reading a colon, slash or P descriptor. */
-
-optional_comma:
+ /* Optional comma is a weird between state where we've just finished
+ reading a colon, slash or P descriptor. */
+ optional_comma:
t = format_lex ();
switch (t)
{
goto format_item;
-finished:
+ finished:
return head;
}
void
parse_format (void)
{
-
format_string = ioparm.format;
format_string_len = ioparm.format_len;
saved_token = FMT_NONE;
error = NULL;
-/* Initialize variables used during traversal of the tree */
+ /* Initialize variables used during traversal of the tree */
reversion_ok = 0;
g.reversion_flag = 0;
saved_format = NULL;
-/* Allocate the first format node as the root of the tree */
+ /* Allocate the first format node as the root of the tree */
avail = array;
}
/* If this is a data edit descriptor, then reversion has become OK. */
-
-done:
+ done:
t = f->format;
if (!reversion_ok &&
void
unget_format (fnode * f)
{
-
saved_format = f;
}
static void
dump_format1 (fnode * f)
{
-
for (; f; f = f->next)
dump_format1 (f);
}
void
dump_format (void)
{
-
st_printf ("format = ");
dump_format0 (&array[0]);
st_printf ("\n");
static void
free_saved (void)
{
-
if (saved_string == NULL)
return;
static void
unget_char (char c)
{
-
last_char = c;
}
{
char c;
-restart:
+ restart:
eat_spaces ();
c = next_char ();
free_saved ();
return m;
-overflow:
+ overflow:
if (length == -1)
st_sprintf (message, "Repeat count overflow in item %d of list input",
g.item_count);
}
}
-done:
+ done:
repeat_count = repeat;
return 0;
-bad_repeat:
+ bad_repeat:
st_sprintf (message, "Bad repeat count in item %d of list input",
g.item_count);
return;
-bad_logical:
+ bad_logical:
st_sprintf (message, "Bad logical value while reading item %d",
g.item_count);
}
}
-repeat:
+ repeat:
if (convert_integer (-1, 0))
return;
break;
}
-get_integer:
+ get_integer:
if (!isdigit (c))
goto bad_integer;
push_char (c);
}
}
-bad_integer:
+ bad_integer:
free_saved ();
st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
return;
-done:
+ done:
unget_char (c);
eat_separator ();
}
}
-got_repeat:
+ got_repeat:
if (convert_integer (-1, 0))
return;
break;
}
-get_string:
+ get_string:
for (;;)
{
c = next_char ();
}
}
-/* At this point, we have to have a separator, or else the string is
- invalid. */
-
-done:
+ /* At this point, we have to have a separator, or else the string is
+ invalid. */
+ done:
c = next_char ();
if (is_separator (c))
{
}
}
-exp1:
+ exp1:
c = next_char ();
if (c != '-' && c != '+')
push_char ('+');
c = next_char ();
}
-exp2:
+ exp2:
if (!isdigit (c))
goto bad;
push_char (c);
}
}
-done:
+ done:
unget_char (c);
push_char ('\0');
return m;
-bad:
+ bad:
free_saved ();
st_sprintf (message, "Bad floating point number for item %d", g.item_count);
generate_error (ERROR_READ_VALUE, message);
saved_type = BT_COMPLEX;
return;
-bad_complex:
+ bad_complex:
st_sprintf (message, "Bad complex value in item %d of list input",
g.item_count);
}
}
-got_repeat:
+ got_repeat:
if (convert_integer (-1, 0))
return;
push_char (c);
-real_loop:
+ real_loop:
for (;;)
{
c = next_char ();
}
}
-exp1:
+ exp1:
push_char ('e');
c = next_char ();
c = next_char ();
}
-exp2:
+ exp2:
if (!isdigit (c))
goto bad_real;
push_char (c);
}
}
-done:
+ done:
push_char ('\0');
if (convert_real (value, saved_string, length))
return;
saved_type = BT_REAL;
return;
-bad_real:
+ bad_real:
st_sprintf (message, "Bad real number in item %d of list input",
g.item_count);
repeat_count = 1;
}
-
switch (type)
{
case BT_INTEGER:
if (ioparm.library_return != LIBRARY_OK)
return;
-set_value:
+ set_value:
switch (saved_type)
{
case BT_COMPLEX:
}
void
-init_at_eol()
+init_at_eol(void)
{
at_eol = 0;
}
return;
}
-
do
{
c = next_char ();
return;
}
-restart:
+ restart:
c = next_char ();
switch (c)
{
void
library_start (void)
{
-
if (g.in_library)
internal_error ("Recursive library calls not allowed");
memset (&ioparm, '\0', sizeof (ioparm));
ioparm.library_return = t;
}
-
{"sequential", ACCESS_SEQUENTIAL},
{"direct", ACCESS_DIRECT},
{NULL}
-}, action_opt[] =
+};
+
+static st_option action_opt[] =
{
- {
- "read", ACTION_READ}
- ,
- {
- "write", ACTION_WRITE}
- ,
- {
- "readwrite", ACTION_READWRITE}
- ,
- {
- NULL}
-}
+ { "read", ACTION_READ},
+ { "write", ACTION_WRITE},
+ { "readwrite", ACTION_READWRITE},
+ { NULL}
+};
-, blank_opt[] =
+static st_option blank_opt[] =
{
- {
- "null", BLANK_NULL}
- ,
- {
- "zero", BLANK_ZERO}
- ,
- {
- NULL}
-}
+ { "null", BLANK_NULL},
+ { "zero", BLANK_ZERO},
+ { NULL}
+};
-, delim_opt[] =
+static st_option delim_opt[] =
{
- {
- "none", DELIM_NONE}
- ,
- {
- "apostrophe", DELIM_APOSTROPHE}
- ,
- {
- "quote", DELIM_QUOTE}
- ,
- {
- NULL}
-}
+ { "none", DELIM_NONE},
+ { "apostrophe", DELIM_APOSTROPHE},
+ { "quote", DELIM_QUOTE},
+ { NULL}
+};
-, form_opt[] =
+static st_option form_opt[] =
{
- {
- "formatted", FORM_FORMATTED}
- ,
- {
- "unformatted", FORM_UNFORMATTED}
- ,
- {
- NULL}
-}
+ { "formatted", FORM_FORMATTED},
+ { "unformatted", FORM_UNFORMATTED},
+ { NULL}
+};
-, position_opt[] =
+static st_option position_opt[] =
{
- {
- "asis", POSITION_ASIS}
- ,
- {
- "rewind", POSITION_REWIND}
- ,
- {
- "append", POSITION_APPEND}
- ,
- {
- NULL}
-}
+ { "asis", POSITION_ASIS},
+ { "rewind", POSITION_REWIND},
+ { "append", POSITION_APPEND},
+ { NULL}
+};
-, status_opt[] =
+static st_option status_opt[] =
{
- {
- "unknown", STATUS_UNKNOWN}
- ,
- {
- "old", STATUS_OLD}
- ,
- {
- "new", STATUS_NEW}
- ,
- {
- "replace", STATUS_REPLACE}
- ,
- {
- "scratch", STATUS_SCRATCH}
- ,
- {
- NULL}
-}
+ { "unknown", STATUS_UNKNOWN},
+ { "old", STATUS_OLD},
+ { "new", STATUS_NEW},
+ { "replace", STATUS_REPLACE},
+ { "scratch", STATUS_SCRATCH},
+ { NULL}
+};
-, pad_opt[] =
+static st_option pad_opt[] =
{
- {
- "yes", PAD_YES}
- ,
- {
- "no", PAD_NO}
- ,
- {
- NULL}
+ { "yes", PAD_YES},
+ { "no", PAD_NO},
+ { NULL}
};
void
test_endfile (gfc_unit * u)
{
-
if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
u->endfile = AT_ENDFILE;
}
static void
edit_modes (gfc_unit * u, unit_flags * flags)
{
-
/* Complain about attempts to change the unchangeable. */
if (flags->status != STATUS_UNSPECIFIED &&
test_endfile (u);
-cleanup:
+ cleanup:
/* Free memory associated with a temporary filename. */
static void
already_open (gfc_unit * u, unit_flags * flags)
{
-
if (ioparm.file == NULL)
{
edit_modes (u, flags);
void
set_integer (void *dest, int64_t value, int length)
{
-
switch (length)
{
case 8:
int
convert_real (void *dest, const char *buffer, int length)
{
-
errno = 0;
switch (length)
static char *
eat_leading_spaces (int *width, char *p)
{
-
for (;;)
{
if (*width == 0 || *p != ' ')
set_integer (dest, v, length);
return;
-bad:
+ bad:
generate_error (ERROR_READ_VALUE, "Bad value during integer read");
return;
-overflow:
+ overflow:
generate_error (ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
set_integer (dest, v, length);
return;
-bad:
+ bad:
generate_error (ERROR_READ_VALUE, "Bad value during integer read");
return;
-overflow:
+ overflow:
generate_error (ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
}
-/* No exponent has been seen, so we use the current scale factor */
-
+ /* No exponent has been seen, so we use the current scale factor */
exponent = -g.scale_factor;
goto done;
-bad_float:
+ bad_float:
generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
if (buffer != scratch)
free_mem (buffer);
return;
-/* At this point the start of an exponent has been found */
-
-exp1:
+ /* At this point the start of an exponent has been found */
+ exp1:
while (w > 0 && *p == ' ')
{
w--;
if (w == 0)
goto bad_float;
-/* At this point a digit string is required. We calculate the value
- of the exponent in order to take account of the scale factor and
- the d parameter before explict conversion takes place. */
-
-exp2:
+ /* At this point a digit string is required. We calculate the value
+ of the exponent in order to take account of the scale factor and
+ the d parameter before explict conversion takes place. */
+ exp2:
if (!isdigit (*p))
goto bad_float;
exponent = exponent * exponent_sign;
-done:
+ done:
/* Use the precision specified in the format if no decimal point has been
seen. */
if (!seen_dp)
return;
-/* Come here when we need a data descriptor but don't have one. We
- push the current format node back onto the input, then return and
- let the user program call us back with the data. */
-
-need_data:
+ /* Come here when we need a data descriptor but don't have one. We
+ push the current format node back onto the input, then return and
+ let the user program call us back with the data. */
+ need_data:
unget_format (f);
}
-
/* Data transfer entry points. The type of the data entity is
implicit in the subroutine call. This prevents us from having to
share a common enum with the compiler. */
void
transfer_integer (void *p, int kind)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
void
transfer_real (void *p, int kind)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
void
transfer_logical (void *p, int kind)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
void
transfer_character (void *p, int len)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
void
transfer_complex (void *p, int kind)
{
-
g.item_count++;
if (ioparm.library_return != LIBRARY_OK)
return;
static void
pre_position (void)
{
-
if (current_unit->current_record)
return; /* Already positioned. */
/* Start the data transfer if we are doing a formatted transfer. */
if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
&& ioparm.namelist_name == NULL && ionml == NULL)
-
- formatted_transfer (0, NULL, 0);
-
+ formatted_transfer (0, NULL, 0);
}
current_unit->bytes_left -= length;
}
}
-
break;
case FORMATTED_SEQUENTIAL:
static void
finalize_transfer (void)
{
-
if ((ionml != NULL) && (ioparm.namelist_name != NULL))
{
if (ioparm.namelist_read_mode)
static void
iolength_transfer_init (void)
{
-
if (ioparm.iolength != NULL)
*ioparm.iolength = 0;
/* Set up the subroutine that will handle the transfers. */
transfer = iolength_transfer;
-
}
st_iolength (void)
{
library_start ();
-
iolength_transfer_init ();
}
void
st_read (void)
{
-
library_start ();
data_transfer_init (1);
st_read_done (void)
{
finalize_transfer ();
-
library_end ();
}
void
st_write (void)
{
-
library_start ();
data_transfer_init (0);
}
void
st_write_done (void)
{
-
finalize_transfer ();
/* Deal with endfile conditions associated with sequential files. */
st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
int kind)
{
-
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER, 0);
}
st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
int kind)
{
-
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL, 0);
}
st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
int kind, gfc_charlen_type string_length)
{
-
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER,
string_length);
}
st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
int kind)
{
-
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX, 0);
}
st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
int kind)
{
-
st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL, 0);
}
-
input = output = error = 0;
-/* Unix allocates the lowest descriptors first, so a loop is not
- * required, but this order is. */
+ /* Unix allocates the lowest descriptors first, so a loop is not
+ required, but this order is. */
if (fd == STDIN_FILENO)
{
const char *
get_oserror (void)
{
-
return strerror (errno);
}
void
sys_exit (int code)
{
-
exit (code);
}
static try
fd_flush (unix_stream * s)
{
-
if (s->ndirty == 0)
return SUCCESS;;
static try
fd_sfree (unix_stream * s)
{
-
if (s->ndirty != 0 &&
(s->buffer != s->small_buffer || options.all_unbuffered ||
s->unbuffered))
static int
fd_seek (unix_stream * s, gfc_offset offset)
{
-
s->physical_offset = s->logical_offset = offset;
return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS;
static try
fd_truncate (unix_stream * s)
{
-
if (lseek (s->fd, s->logical_offset, SEEK_SET) == -1)
return FAILURE;
the fd is a regular file at this point */
if (ftruncate (s->fd, s->logical_offset))
- {
return FAILURE;
- }
s->physical_offset = s->file_length = s->logical_offset;
static try
fd_close (unix_stream * s)
{
-
if (fd_flush (s) == FAILURE)
return FAILURE;
static void
fd_open (unix_stream * s)
{
-
if (isatty (s->fd))
s->unbuffered = 1;
static try
mmap_flush (unix_stream * s)
{
-
if (!s->mmaped)
return fd_flush (s);
static int
mmap_seek (unix_stream * s, gfc_offset offset)
{
-
s->logical_offset = offset;
return SUCCESS;
}
static try
mmap_sfree (unix_stream * s)
{
-
return SUCCESS;
}
static int
mem_seek (unix_stream * s, gfc_offset offset)
{
-
if (offset > s->file_length)
{
errno = ESPIPE;
static int
mem_truncate (unix_stream * s)
{
-
return SUCCESS;
}
static try
mem_sfree (unix_stream * s)
{
-
return SUCCESS;
}
void
empty_internal_buffer(stream *strm)
{
- unix_stream * s = (unix_stream *) strm;
- memset(s->buffer, ' ', s->file_length);
+ unix_stream * s = (unix_stream *) strm;
+ memset(s->buffer, ' ', s->file_length);
}
/* open_internal()-- Returns a stream structure from an internal file */
int
unit_to_fd(int unit)
{
-
gfc_unit *us;
us = find_unit(unit);
static int
unpack_filename (char *cstring, const char *fstring, int len)
{
-
len = fstrlen (fstring, len);
if (len >= PATH_MAX)
return 1;
internal_error ("regular_file(): Bad status");
}
- // mode |= O_LARGEFILE;
+ /* mode |= O_LARGEFILE; */
return open (path, mode,
S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH);
stream *
input_stream (void)
{
-
return fd_to_stream (STDIN_FILENO, PROT_READ);
}
stream *
output_stream (void)
{
-
return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
}
const char *
inquire_unformatted (const char *string, int len)
{
-
return inquire_formatted (string, len);
}
const char *
inquire_read (const char *string, int len)
{
-
return inquire_access (string, len, R_OK);
}
const char *
inquire_write (const char *string, int len)
{
-
return inquire_access (string, len, W_OK);
}
const char *
inquire_readwrite (const char *string, int len)
{
-
return inquire_access (string, len, R_OK | W_OK);
}
gfc_offset
file_length (stream * s)
{
-
return ((unix_stream *) s)->file_length;
}
gfc_offset
file_position (stream * s)
{
-
return ((unix_stream *) s)->logical_offset;
}
memcpy (p, q, digits);
-done:
+ done:
return;
}
memcpy (p, q, digits);
-done:
+ done:
return;
}
void
write_i (fnode * f, const char *p, int len)
{
-
write_decimal (f, p, len, (void *) itoa);
}
void
write_b (fnode * f, const char *p, int len)
{
-
write_int (f, p, len, btoa);
}
void
write_o (fnode * f, const char *p, int len)
{
-
write_int (f, p, len, otoa);
}
void
write_z (fnode * f, const char *p, int len)
{
-
write_int (f, p, len, xtoa);
}
void
write_d (fnode *f, const char *p, int len)
{
-
write_float (f, p, len);
}
void
write_e (fnode *f, const char *p, int len)
{
-
write_float (f, p, len);
}
void
write_f (fnode *f, const char *p, int len)
{
-
write_float (f, p, len);
}
void
write_en (fnode *f, const char *p, int len)
{
-
write_float (f, p, len);
}
void
write_es (fnode *f, const char *p, int len)
{
-
write_float (f, p, len);
}
static void
write_complex (const char *source, int len)
{
-
if (write_char ('('))
return;
write_real (source, len);
static const char *
var_source (variable * v)
{
-
if (getenv (v->name) == NULL)
return "Default";
*v->var = atoi (p);
return;
-set_default:
+ set_default:
*v->var = v->value;
return;
}
static void
show_integer (variable * v)
{
-
st_printf ("%s %d\n", var_source (v), *v->var);
}
static void
show_boolean (variable * v)
{
-
st_printf ("%s %s\n", var_source (v), *v->var ? "Yes" : "No");
}
static void
show_sep (variable * v)
{
-
st_printf ("%s \"%s\"\n", var_source (v), options.separator);
}
{"DOWN", FP_ROUND_DOWN},
{"ZERO", FP_ROUND_ZERO},
{NULL}
-}, precision[] =
+};
+
+static choice precision[] =
{
- {
- "24", 1}
- ,
- {
- "53", 2}
- ,
- {
- "64", 0}
- ,
- {
- NULL}
-}
+ { "24", 1},
+ { "53", 2},
+ { "64", 0},
+ { NULL}
+};
-, signal_choices[] =
+static choice signal_choices[] =
{
- {
- "IGNORE", 1}
- ,
- {
- "ABORT", 0}
- ,
- {
- NULL}
+ { "IGNORE", 1},
+ { "ABORT", 0},
+ { NULL}
};
*v->var = c->value;
return;
-set_default:
+ set_default:
*v->var = v->value;
}
static void
show_choice (variable * v, choice * c)
{
-
st_printf ("%s ", var_source (v));
for (; c->name; c++)
st_printf ("%s\n", c->name);
else
st_printf ("(Unknown)\n");
-
}
{
init_choice (v, rounding);
}
+
static void
show_round (variable * v)
{
{
init_choice (v, precision);
}
+
static void
show_precision (variable * v)
{
{
init_choice (v, signal_choices);
}
+
static void
show_signal (variable * v)
{
char *p, **e;
variable *v;
int n;
-/* TODO: print version number. */
+
+ /* TODO: print version number. */
st_printf ("GNU Fortran 95 runtime library version "
"UNKNOWN" "\n\n");
void
show_locus (void)
{
-
if (!options.locus || filename == NULL)
return;
{
static int magic = 0;
+ /* Don't even try to print something at this point */
if (magic == MAGIC)
- sys_exit (4); /* Don't even try to print something at this point */
+ sys_exit (4);
magic = MAGIC;
}
void
os_error (const char *message)
{
-
recursion_check ();
-
show_locus ();
st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
-
sys_exit (1);
}
void
runtime_error (const char *message)
{
-
recursion_check ();
-
show_locus ();
st_printf ("Fortran runtime error: %s\n", message);
-
sys_exit (2);
}
void
internal_error (const char *message)
{
-
recursion_check ();
-
show_locus ();
st_printf ("Internal Error: %s\n", message);
sys_exit (3);
void
get_args (int *argc, char ***argv)
{
-
*argc = argc_save;
*argv = argv_save;
}
{
close_units ();
}
-
void
memory_init (void)
{
-
/* The root should never be used directly, so don't set the magic. */
mem_root.magic = 0;
mem_root.next = &mem_root;
void
free_mem (void *p)
{
-
free (p);
}
void
allocate (void **mem, GFC_INTEGER_4 size, GFC_INTEGER_4 * stat)
{
-
if (size < 0)
{
runtime_error ("Attempt to allocate negative amount of memory. "
void
allocate64 (void **mem, GFC_INTEGER_8 size, GFC_INTEGER_4 * stat)
{
-
if (size < 0)
{
runtime_error
void
deallocate (void **mem, GFC_INTEGER_4 * stat)
{
-
if (!mem)
runtime_error ("Internal: NULL mem pointer in ALLOCATE.");
if (stat)
*stat = 0;
}
-
int
fstrlen (const char *string, int len)
{
-
for (len--; len >= 0; len--)
if (string[len] != ' ')
break;
}
-
void
fstrcpy (char *dest, int destlen, const char *src, int srclen)
{
-
if (srclen >= destlen)
{
/* This will truncate if too long. */
find_option (const char *s1, int s1_len, st_option * opts,
const char *error_message)
{
-
for (; opts->name; opts++)
if (compare0 (s1, s1_len, opts->name))
return opts->value;
return -1;
}
-
OSDN Git Service
