-/* Copyright (C) 2002,2003,2005 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
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. */
+the Free Software Foundation, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
-#include "config.h"
#include <string.h>
#include <stdlib.h>
#include <ctype.h>
-#include "libgfortran.h"
-#include "../io/io.h"
-
/* Environment scanner. Examine the environment for controlling minor
* aspects of the program's execution. Our philosophy here that the
* but other variables are checked during execution of the user's
* program. */
-options_t options = { };
+options_t options;
typedef struct variable
}
variable;
+static void init_unformatted (variable *);
-/* print_spaces()-- Print a particular number of spaces */
+/* print_spaces()-- Print a particular number of spaces. */
static void
print_spaces (int n)
}
-/* init_mem()-- Initialize environment variables that have to do with
- * how memory from an ALLOCATE statement is filled. A single flag
- * enables filling and a second variable gives the value that is used
- * to initialize the memory. */
-
-static void
-init_mem (variable * v)
-{
- int offset, n;
- char *p;
-
- p = getenv (v->name);
-
- options.allocate_init_flag = 0; /* The default */
-
- if (p == NULL)
- return;
-
- if (strcasecmp (p, "NONE") == 0)
- return;
-
- /* IEEE-754 Quiet Not-a-Number that will work for single and double
- * precision. Look for the 'f95' mantissa in debug dumps. */
-
- if (strcasecmp (p, "NaN") == 0)
- {
- options.allocate_init_flag = 1;
- options.allocate_init_value = 0xfff80f95;
- return;
- }
-
- /* Interpret the string as a hexadecimal constant */
-
- n = 0;
- while (*p)
- {
- if (!isxdigit (*p))
- {
- v->bad = 1;
- return;
- }
-
- offset = '0';
- if (islower (*p))
- offset = 'a';
- if (isupper (*p))
- offset = 'A';
-
- n = (n << 4) | (*p++ - offset);
- }
-
- options.allocate_init_flag = 1;
- options.allocate_init_value = n;
-}
-
-
-static void
-show_mem (variable * v)
-{
- char *p;
-
- p = getenv (v->name);
-
- st_printf ("%s ", var_source (v));
-
- if (options.allocate_init_flag)
- st_printf ("0x%x", options.allocate_init_value);
-
- st_printf ("\n");
-}
-
-
static void
init_sep (variable * v)
{
static void
-init_string (variable * v)
+init_string (variable * v __attribute__ ((unused)))
{
}
}
-/* Structure for associating names and values. */
-
-typedef struct
-{
- const char *name;
- int value;
-}
-choice;
-
-
-enum
-{ FP_ROUND_NEAREST, FP_ROUND_UP, FP_ROUND_DOWN, FP_ROUND_ZERO };
-
-static choice rounding[] = {
- {"NEAREST", FP_ROUND_NEAREST},
- {"UP", FP_ROUND_UP},
- {"DOWN", FP_ROUND_DOWN},
- {"ZERO", FP_ROUND_ZERO},
- {NULL}
-};
-
-static choice precision[] =
-{
- { "24", 1},
- { "53", 2},
- { "64", 0},
- { NULL}
-};
-
-static choice signal_choices[] =
-{
- { "IGNORE", 1},
- { "ABORT", 0},
- { NULL}
-};
-
-
-static void
-init_choice (variable * v, choice * c)
-{
- char *p;
-
- p = getenv (v->name);
- if (p == NULL)
- goto set_default;
-
- for (; c->name; c++)
- if (strcasecmp (c->name, p) == 0)
- break;
-
- if (c->name == NULL)
- {
- v->bad = 1;
- goto set_default;
- }
-
- *v->var = c->value;
- return;
-
- set_default:
- *v->var = v->value;
-}
-
-
-static void
-show_choice (variable * v, choice * c)
-{
- st_printf ("%s ", var_source (v));
-
- for (; c->name; c++)
- if (c->value == *v->var)
- break;
-
- if (c->name)
- st_printf ("%s\n", c->name);
- else
- st_printf ("(Unknown)\n");
-}
-
-
-static void
-init_round (variable * v)
-{
- init_choice (v, rounding);
-}
-
-static void
-show_round (variable * v)
-{
- show_choice (v, rounding);
-}
-
-static void
-init_precision (variable * v)
-{
- init_choice (v, precision);
-}
-
-static void
-show_precision (variable * v)
-{
- show_choice (v, precision);
-}
-
-static void
-init_signal (variable * v)
-{
- init_choice (v, signal_choices);
-}
-
-static void
-show_signal (variable * v)
-{
- show_choice (v, signal_choices);
-}
-
-
static variable variable_table[] = {
- {"GFORTRAN_STDIN_UNIT", 5, &options.stdin_unit, init_integer, show_integer,
+ {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
+ init_integer, show_integer,
"Unit number that will be preconnected to standard input\n"
- "(No preconnection if negative)"},
+ "(No preconnection if negative)", 0},
- {"GFORTRAN_STDOUT_UNIT", 6, &options.stdout_unit, init_integer,
- show_integer,
+ {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
+ init_integer, show_integer,
"Unit number that will be preconnected to standard output\n"
- "(No preconnection if negative)"},
+ "(No preconnection if negative)", 0},
- {"GFORTRAN_STDERR_UNIT", 0, &options.stderr_unit, init_integer,
- show_integer,
+ {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
+ init_integer, show_integer,
"Unit number that will be preconnected to standard error\n"
- "(No preconnection if negative)"},
+ "(No preconnection if negative)", 0},
{"GFORTRAN_USE_STDERR", 1, &options.use_stderr, init_boolean,
show_boolean,
- "Sends library output to standard error instead of standard output."},
+ "Sends library output to standard error instead of standard output.", 0},
{"GFORTRAN_TMPDIR", 0, NULL, init_string, show_string,
"Directory for scratch files. Overrides the TMP environment variable\n"
- "If TMP is not set " DEFAULT_TEMPDIR " is used."},
+ "If TMP is not set " DEFAULT_TEMPDIR " is used.", 0},
{"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean,
show_boolean,
"If TRUE, all output is unbuffered. This will slow down large writes "
- "but can be\nuseful for forcing data to be displayed immediately."},
+ "but can be\nuseful for forcing data to be displayed immediately.", 0},
+
+ {"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
+ init_boolean, show_boolean,
+ "If TRUE, output to preconnected units is unbuffered.", 0},
{"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
- "If TRUE, print filename and line number where runtime errors happen."},
+ "If TRUE, print filename and line number where runtime errors happen.", 0},
{"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
- "Print optional plus signs in numbers where permitted. Default FALSE."},
+ "Print optional plus signs in numbers where permitted. Default FALSE.", 0},
{"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
init_unsigned_integer, show_integer,
"Default maximum record length for sequential files. Most useful for\n"
"adjusting line length of preconnected units. Default "
- stringize (DEFAULT_RECL)},
+ stringize (DEFAULT_RECL), 0},
{"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
- "Separatator to use when writing list output. May contain any number of "
- "spaces\nand at most one comma. Default is a single space."},
-
- /* Memory related controls */
-
- {"GFORTRAN_MEM_INIT", 0, NULL, init_mem, show_mem,
- "How to initialize allocated memory. Default value is NONE for no "
- "initialization\n(faster), NAN for a Not-a-Number with the mantissa "
- "0x40f95 or a custom\nhexadecimal value"},
-
- {"GFORTRAN_MEM_CHECK", 0, &options.mem_check, init_boolean, show_boolean,
- "Whether memory still allocated will be reported when the program ends."},
+ "Separator to use when writing list output. May contain any number of "
+ "spaces\nand at most one comma. Default is a single space.", 0},
- /* Signal handling (Unix). */
+ /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
+ unformatted I/O. */
+ {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string,
+ "Set format for unformatted files", 0},
- {"GFORTRAN_SIGHUP", 0, &options.sighup, init_signal, show_signal,
- "Whether the program will IGNORE or ABORT on SIGHUP."},
+ /* Behaviour when encoutering a runtime error. */
+ {"GFORTRAN_ERROR_DUMPCORE", -1, &options.dump_core,
+ init_boolean, show_boolean,
+ "Dump a core file (if possible) on runtime error", -1},
- {"GFORTRAN_SIGINT", 0, &options.sigint, init_signal, show_signal,
- "Whether the program will IGNORE or ABORT on SIGINT."},
+ {"GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace,
+ init_boolean, show_boolean,
+ "Print out a backtrace (if possible) on runtime error", -1},
- /* Floating point control */
-
- {"GFORTRAN_FPU_ROUND", 0, &options.fpu_round, init_round, show_round,
- "Set floating point rounding. Values are NEAREST, UP, DOWN, ZERO."},
-
- {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision, init_precision,
- show_precision,
- "Precision of intermediate results. Values are 24, 53 and 64."},
-
- {"GFORTRAN_FPU_INVALID", 1, &options.fpu_invalid, init_boolean,
- show_boolean,
- "Raise a floating point exception on invalid FP operation."},
-
- {"GFORTRAN_FPU_DENORMAL", 1, &options.fpu_denormal, init_boolean,
- show_boolean,
- "Raise a floating point exception when denormal numbers are encountered."},
-
- {"GFORTRAN_FPU_ZERO", 0, &options.fpu_zerodiv, init_boolean, show_boolean,
- "Raise a floating point exception when dividing by zero."},
-
- {"GFORTRAN_FPU_OVERFLOW", 0, &options.fpu_overflow, init_boolean,
- show_boolean,
- "Raise a floating point exception on overflow."},
-
- {"GFORTRAN_FPU_UNDERFLOW", 0, &options.fpu_underflow, init_boolean,
- show_boolean,
- "Raise a floating point exception on underflow."},
-
- {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision_loss, init_boolean,
- show_boolean,
- "Raise a floating point exception on precision loss."},
-
- {NULL}
+ {NULL, 0, NULL, NULL, NULL, NULL, 0}
};
}
-/* check_buffered()-- Given an unit number n, determine if an override
- * for the stream exists. Returns zero for unbuffered, one for
- * buffered or two for not set. */
-
-int
-check_buffered (int n)
-{
- char name[40];
- variable v;
- int rv;
-
- if (options.all_unbuffered)
- return 0;
-
- strcpy (name, "GFORTRAN_UNBUFFERED_");
- strcat (name, gfc_itoa (n));
-
- v.name = name;
- v.value = 2;
- v.var = &rv;
-
- init_boolean (&v);
-
- return rv;
-}
-
-
void
show_variables (void)
{
st_printf ("\nRuntime error codes:");
st_printf ("\n--------------------\n");
- for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++)
+ for (n = LIBERROR_FIRST + 1; n < LIBERROR_LAST; n++)
if (n < 0 || n > 9)
st_printf ("%d %s\n", n, translate_error (n));
else
sys_exit (0);
}
+
+/* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
+ It is called from environ.c to parse this variable, and from
+ open.c to determine if the user specified a default for an
+ unformatted file.
+ The syntax of the environment variable is, in bison grammar:
+
+ GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
+ mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
+ exception: mode ':' unit_list | unit_list ;
+ unit_list: unit_spec | unit_list unit_spec ;
+ unit_spec: INTEGER | INTEGER '-' INTEGER ;
+*/
+
+/* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
+
+
+#define NATIVE 257
+#define SWAP 258
+#define BIG 259
+#define LITTLE 260
+/* Some space for additional tokens later. */
+#define INTEGER 273
+#define END (-1)
+#define ILLEGAL (-2)
+
+typedef struct
+{
+ int unit;
+ unit_convert conv;
+} exception_t;
+
+
+static char *p; /* Main character pointer for parsing. */
+static char *lastpos; /* Auxiliary pointer, for backing up. */
+static int unit_num; /* The last unit number read. */
+static int unit_count; /* The number of units found. */
+static int do_count; /* Parsing is done twice - first to count the number
+ of units, then to fill in the table. This
+ variable controls what to do. */
+static exception_t *elist; /* The list of exceptions to the default. This is
+ sorted according to unit number. */
+static int n_elist; /* Number of exceptions to the default. */
+
+static unit_convert endian; /* Current endianness. */
+
+static unit_convert def; /* Default as specified (if any). */
+
+/* Search for a unit number, using a binary search. The
+ first argument is the unit number to search for. The second argument
+ is a pointer to an index.
+ If the unit number is found, the function returns 1, and the index
+ is that of the element.
+ If the unit number is not found, the function returns 0, and the
+ index is the one where the element would be inserted. */
+
+static int
+search_unit (int unit, int *ip)
+{
+ int low, high, mid;
+
+ low = -1;
+ high = n_elist;
+ while (high - low > 1)
+ {
+ mid = (low + high) / 2;
+ if (unit <= elist[mid].unit)
+ high = mid;
+ else
+ low = mid;
+ }
+ *ip = high;
+ if (elist[high].unit == unit)
+ return 1;
+ else
+ return 0;
+}
+
+/* This matches a keyword. If it is found, return the token supplied,
+ otherwise return ILLEGAL. */
+
+static int
+match_word (const char *word, int tok)
+{
+ int res;
+
+ if (strncasecmp (p, word, strlen (word)) == 0)
+ {
+ p += strlen (word);
+ res = tok;
+ }
+ else
+ res = ILLEGAL;
+ return res;
+
+}
+
+/* Match an integer and store its value in unit_num. This only works
+ if p actually points to the start of an integer. The caller has
+ to ensure this. */
+
+static int
+match_integer (void)
+{
+ unit_num = 0;
+ while (isdigit (*p))
+ unit_num = unit_num * 10 + (*p++ - '0');
+ return INTEGER;
+
+}
+
+/* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
+ Returned values are the different tokens. */
+
+static int
+next_token (void)
+{
+ int result;
+
+ lastpos = p;
+ switch (*p)
+ {
+ case '\0':
+ result = END;
+ break;
+
+ case ':':
+ case ',':
+ case '-':
+ case ';':
+ result = *p;
+ p++;
+ break;
+
+ case 'b':
+ case 'B':
+ result = match_word ("big_endian", BIG);
+ break;
+
+ case 'l':
+ case 'L':
+ result = match_word ("little_endian", LITTLE);
+ break;
+
+ case 'n':
+ case 'N':
+ result = match_word ("native", NATIVE);
+ break;
+
+ case 's':
+ case 'S':
+ result = match_word ("swap", SWAP);
+ break;
+
+ case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ result = match_integer ();
+ break;
+
+ default:
+ result = ILLEGAL;
+ break;
+ }
+ return result;
+}
+
+/* Back up the last token by setting back the character pointer. */
+
+static void
+push_token (void)
+{
+ p = lastpos;
+}
+
+/* This is called when a unit is identified. If do_count is nonzero,
+ increment the number of units by one. If do_count is zero,
+ put the unit into the table. */
+
+static void
+mark_single (int unit)
+{
+ int i,j;
+
+ if (do_count)
+ {
+ unit_count++;
+ return;
+ }
+ if (search_unit (unit, &i))
+ {
+ elist[unit].conv = endian;
+ }
+ else
+ {
+ for (j=n_elist; j>=i; j--)
+ elist[j+1] = elist[j];
+
+ n_elist += 1;
+ elist[i].unit = unit;
+ elist[i].conv = endian;
+ }
+}
+
+/* This is called when a unit range is identified. If do_count is
+ nonzero, increase the number of units. If do_count is zero,
+ put the unit into the table. */
+
+static void
+mark_range (int unit1, int unit2)
+{
+ int i;
+ if (do_count)
+ unit_count += abs (unit2 - unit1) + 1;
+ else
+ {
+ if (unit2 < unit1)
+ for (i=unit2; i<=unit1; i++)
+ mark_single (i);
+ else
+ for (i=unit1; i<=unit2; i++)
+ mark_single (i);
+ }
+}
+
+/* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
+ twice, once to count the units and once to actually mark them in
+ the table. When counting, we don't check for double occurrences
+ of units. */
+
+static int
+do_parse (void)
+{
+ int tok;
+ int unit1;
+ int continue_ulist;
+ char *start;
+
+ unit_count = 0;
+
+ start = p;
+
+ /* Parse the string. First, let's look for a default. */
+ tok = next_token ();
+ switch (tok)
+ {
+ case NATIVE:
+ endian = GFC_CONVERT_NATIVE;
+ break;
+
+ case SWAP:
+ endian = GFC_CONVERT_SWAP;
+ break;
+
+ case BIG:
+ endian = GFC_CONVERT_BIG;
+ break;
+
+ case LITTLE:
+ endian = GFC_CONVERT_LITTLE;
+ break;
+
+ case INTEGER:
+ /* A leading digit means that we are looking at an exception.
+ Reset the position to the beginning, and continue processing
+ at the exception list. */
+ p = start;
+ goto exceptions;
+ break;
+
+ case END:
+ goto end;
+ break;
+
+ default:
+ goto error;
+ break;
+ }
+
+ tok = next_token ();
+ switch (tok)
+ {
+ case ';':
+ def = endian;
+ break;
+
+ case ':':
+ /* This isn't a default after all. Reset the position to the
+ beginning, and continue processing at the exception list. */
+ p = start;
+ goto exceptions;
+ break;
+
+ case END:
+ def = endian;
+ goto end;
+ break;
+
+ default:
+ goto error;
+ break;
+ }
+
+ exceptions:
+
+ /* Loop over all exceptions. */
+ while(1)
+ {
+ tok = next_token ();
+ switch (tok)
+ {
+ case NATIVE:
+ if (next_token () != ':')
+ goto error;
+ endian = GFC_CONVERT_NATIVE;
+ break;
+
+ case SWAP:
+ if (next_token () != ':')
+ goto error;
+ endian = GFC_CONVERT_SWAP;
+ break;
+
+ case LITTLE:
+ if (next_token () != ':')
+ goto error;
+ endian = GFC_CONVERT_LITTLE;
+ break;
+
+ case BIG:
+ if (next_token () != ':')
+ goto error;
+ endian = GFC_CONVERT_BIG;
+ break;
+
+ case INTEGER:
+ push_token ();
+ break;
+
+ case END:
+ goto end;
+ break;
+
+ default:
+ goto error;
+ break;
+ }
+ /* We arrive here when we want to parse a list of
+ numbers. */
+ continue_ulist = 1;
+ do
+ {
+ tok = next_token ();
+ if (tok != INTEGER)
+ goto error;
+
+ unit1 = unit_num;
+ tok = next_token ();
+ /* The number can be followed by a - and another number,
+ which means that this is a unit range, a comma
+ or a semicolon. */
+ if (tok == '-')
+ {
+ if (next_token () != INTEGER)
+ goto error;
+
+ mark_range (unit1, unit_num);
+ tok = next_token ();
+ if (tok == END)
+ goto end;
+ else if (tok == ';')
+ continue_ulist = 0;
+ else if (tok != ',')
+ goto error;
+ }
+ else
+ {
+ mark_single (unit1);
+ switch (tok)
+ {
+ case ';':
+ continue_ulist = 0;
+ break;
+
+ case ',':
+ break;
+
+ case END:
+ goto end;
+ break;
+
+ default:
+ goto error;
+ }
+ }
+ } while (continue_ulist);
+ }
+ end:
+ return 0;
+ error:
+ def = GFC_CONVERT_NONE;
+ return -1;
+}
+
+void init_unformatted (variable * v)
+{
+ char *val;
+ val = getenv (v->name);
+ def = GFC_CONVERT_NONE;
+ n_elist = 0;
+
+ if (val == NULL)
+ return;
+ do_count = 1;
+ p = val;
+ do_parse ();
+ if (do_count <= 0)
+ {
+ n_elist = 0;
+ elist = NULL;
+ }
+ else
+ {
+ elist = get_mem (unit_count * sizeof (exception_t));
+ do_count = 0;
+ p = val;
+ do_parse ();
+ }
+}
+
+/* Get the default conversion for for an unformatted unit. */
+
+unit_convert
+get_unformatted_convert (int unit)
+{
+ int i;
+
+ if (elist == NULL)
+ return def;
+ else if (search_unit (unit, &i))
+ return elist[i].conv;
+ else
+ return def;
+}
OSDN Git Service
