1 /* Copyright (C) 2002,2003,2005 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA. */
36 #include "libgfortran.h"
40 /* Environment scanner. Examine the environment for controlling minor
41 * aspects of the program's execution. Our philosophy here that the
42 * environment should not prevent the program from running, so an
43 * environment variable with a messed-up value will be interpreted in
46 * Most of the environment is checked early in the startup sequence,
47 * but other variables are checked during execution of the user's
53 typedef struct variable
57 void (*init
) (struct variable
*);
58 void (*show
) (struct variable
*);
65 /* print_spaces()-- Print a particular number of spaces */
76 for (i
= 0; i
< n
; i
++)
85 /* var_source()-- Return a string that describes where the value of a
86 * variable comes from */
89 var_source (variable
* v
)
91 if (getenv (v
->name
) == NULL
)
101 /* init_integer()-- Initialize an integer environment variable. */
104 init_integer (variable
* v
)
108 p
= getenv (v
->name
);
113 if (!isdigit (*q
) && (p
!= q
|| *q
!= '-'))
128 /* init_unsigned_integer()-- Initialize an integer environment variable
129 which has to be positive. */
132 init_unsigned_integer (variable
* v
)
136 p
= getenv (v
->name
);
156 /* show_integer()-- Show an integer environment variable */
159 show_integer (variable
* v
)
161 st_printf ("%s %d\n", var_source (v
), *v
->var
);
165 /* init_boolean()-- Initialize a boolean environment variable. We
166 * only look at the first letter of the variable. */
169 init_boolean (variable
* v
)
173 p
= getenv (v
->name
);
177 if (*p
== '1' || *p
== 'Y' || *p
== 'y')
183 if (*p
== '0' || *p
== 'N' || *p
== 'n')
197 /* show_boolean()-- Show a boolean environment variable */
200 show_boolean (variable
* v
)
202 st_printf ("%s %s\n", var_source (v
), *v
->var
? "Yes" : "No");
206 /* init_mem()-- Initialize environment variables that have to do with
207 * how memory from an ALLOCATE statement is filled. A single flag
208 * enables filling and a second variable gives the value that is used
209 * to initialize the memory. */
212 init_mem (variable
* v
)
217 p
= getenv (v
->name
);
219 options
.allocate_init_flag
= 0; /* The default */
224 if (strcasecmp (p
, "NONE") == 0)
227 /* IEEE-754 Quiet Not-a-Number that will work for single and double
228 * precision. Look for the 'f95' mantissa in debug dumps. */
230 if (strcasecmp (p
, "NaN") == 0)
232 options
.allocate_init_flag
= 1;
233 options
.allocate_init_value
= 0xfff80f95;
237 /* Interpret the string as a hexadecimal constant */
254 n
= (n
<< 4) | (*p
++ - offset
);
257 options
.allocate_init_flag
= 1;
258 options
.allocate_init_value
= n
;
263 show_mem (variable
* v
)
267 p
= getenv (v
->name
);
269 st_printf ("%s ", var_source (v
));
271 if (options
.allocate_init_flag
)
272 st_printf ("0x%x", options
.allocate_init_value
);
279 init_sep (variable
* v
)
284 p
= getenv (v
->name
);
289 options
.separator
= p
;
290 options
.separator_len
= strlen (p
);
292 /* Make sure the separator is valid */
294 if (options
.separator_len
== 0)
317 options
.separator
= " ";
318 options
.separator_len
= 1;
323 show_sep (variable
* v
)
325 st_printf ("%s \"%s\"\n", var_source (v
), options
.separator
);
330 init_string (variable
* v
__attribute__ ((unused
)))
335 show_string (variable
* v
)
339 p
= getenv (v
->name
);
343 st_printf ("%s \"%s\"\n", var_source (v
), p
);
347 /* Structure for associating names and values. */
358 { FP_ROUND_NEAREST
, FP_ROUND_UP
, FP_ROUND_DOWN
, FP_ROUND_ZERO
};
360 static const choice rounding
[] = {
361 {"NEAREST", FP_ROUND_NEAREST
},
363 {"DOWN", FP_ROUND_DOWN
},
364 {"ZERO", FP_ROUND_ZERO
},
368 static const choice precision
[] =
376 static const choice signal_choices
[] =
385 init_choice (variable
* v
, const choice
* c
)
389 p
= getenv (v
->name
);
394 if (strcasecmp (c
->name
, p
) == 0)
412 show_choice (variable
* v
, const choice
* c
)
414 st_printf ("%s ", var_source (v
));
417 if (c
->value
== *v
->var
)
421 st_printf ("%s\n", c
->name
);
423 st_printf ("(Unknown)\n");
428 init_round (variable
* v
)
430 init_choice (v
, rounding
);
434 show_round (variable
* v
)
436 show_choice (v
, rounding
);
440 init_precision (variable
* v
)
442 init_choice (v
, precision
);
446 show_precision (variable
* v
)
448 show_choice (v
, precision
);
452 init_signal (variable
* v
)
454 init_choice (v
, signal_choices
);
458 show_signal (variable
* v
)
460 show_choice (v
, signal_choices
);
464 static variable variable_table
[] = {
465 {"GFORTRAN_STDIN_UNIT", 5, &options
.stdin_unit
, init_integer
, show_integer
,
466 "Unit number that will be preconnected to standard input\n"
467 "(No preconnection if negative)", 0},
469 {"GFORTRAN_STDOUT_UNIT", 6, &options
.stdout_unit
, init_integer
,
471 "Unit number that will be preconnected to standard output\n"
472 "(No preconnection if negative)", 0},
474 {"GFORTRAN_STDERR_UNIT", 0, &options
.stderr_unit
, init_integer
,
476 "Unit number that will be preconnected to standard error\n"
477 "(No preconnection if negative)", 0},
479 {"GFORTRAN_USE_STDERR", 1, &options
.use_stderr
, init_boolean
,
481 "Sends library output to standard error instead of standard output.", 0},
483 {"GFORTRAN_TMPDIR", 0, NULL
, init_string
, show_string
,
484 "Directory for scratch files. Overrides the TMP environment variable\n"
485 "If TMP is not set " DEFAULT_TEMPDIR
" is used.", 0},
487 {"GFORTRAN_UNBUFFERED_ALL", 0, &options
.all_unbuffered
, init_boolean
,
489 "If TRUE, all output is unbuffered. This will slow down large writes "
490 "but can be\nuseful for forcing data to be displayed immediately.", 0},
492 {"GFORTRAN_SHOW_LOCUS", 1, &options
.locus
, init_boolean
, show_boolean
,
493 "If TRUE, print filename and line number where runtime errors happen.", 0},
495 {"GFORTRAN_OPTIONAL_PLUS", 0, &options
.optional_plus
, init_boolean
, show_boolean
,
496 "Print optional plus signs in numbers where permitted. Default FALSE.", 0},
498 {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL
, &options
.default_recl
,
499 init_unsigned_integer
, show_integer
,
500 "Default maximum record length for sequential files. Most useful for\n"
501 "adjusting line length of preconnected units. Default "
502 stringize (DEFAULT_RECL
), 0},
504 {"GFORTRAN_LIST_SEPARATOR", 0, NULL
, init_sep
, show_sep
,
505 "Separatator to use when writing list output. May contain any number of "
506 "spaces\nand at most one comma. Default is a single space.", 0},
508 /* Memory related controls */
510 {"GFORTRAN_MEM_INIT", 0, NULL
, init_mem
, show_mem
,
511 "How to initialize allocated memory. Default value is NONE for no "
512 "initialization\n(faster), NAN for a Not-a-Number with the mantissa "
513 "0x40f95 or a custom\nhexadecimal value", 0},
515 {"GFORTRAN_MEM_CHECK", 0, &options
.mem_check
, init_boolean
, show_boolean
,
516 "Whether memory still allocated will be reported when the program ends.",
519 /* Signal handling (Unix). */
521 {"GFORTRAN_SIGHUP", 0, &options
.sighup
, init_signal
, show_signal
,
522 "Whether the program will IGNORE or ABORT on SIGHUP.", 0},
524 {"GFORTRAN_SIGINT", 0, &options
.sigint
, init_signal
, show_signal
,
525 "Whether the program will IGNORE or ABORT on SIGINT.", 0},
527 /* Floating point control */
529 {"GFORTRAN_FPU_ROUND", 0, &options
.fpu_round
, init_round
, show_round
,
530 "Set floating point rounding. Values are NEAREST, UP, DOWN, ZERO.", 0},
532 {"GFORTRAN_FPU_PRECISION", 0, &options
.fpu_precision
, init_precision
,
534 "Precision of intermediate results. Values are 24, 53 and 64.", 0},
536 {NULL
, 0, NULL
, NULL
, NULL
, NULL
, 0}
540 /* init_variables()-- Initialize most runtime variables from
541 * environment variables. */
544 init_variables (void)
548 for (v
= variable_table
; v
->name
; v
++)
553 /* check_buffered()-- Given an unit number n, determine if an override
554 * for the stream exists. Returns zero for unbuffered, one for
555 * buffered or two for not set. */
558 check_buffered (int n
)
560 char name
[22 + sizeof (n
) * 3];
564 if (options
.all_unbuffered
)
567 sprintf (name
, "GFORTRAN_UNBUFFERED_%d", n
);
580 show_variables (void)
585 /* TODO: print version number. */
586 st_printf ("GNU Fortran 95 runtime library version "
589 st_printf ("Environment variables:\n");
590 st_printf ("----------------------\n");
592 for (v
= variable_table
; v
->name
; v
++)
594 n
= st_printf ("%s", v
->name
);
595 print_spaces (25 - n
);
597 if (v
->show
== show_integer
)
598 st_printf ("Integer ");
599 else if (v
->show
== show_boolean
)
600 st_printf ("Boolean ");
602 st_printf ("String ");
605 st_printf ("%s\n\n", v
->desc
);
608 /* System error codes */
610 st_printf ("\nRuntime error codes:");
611 st_printf ("\n--------------------\n");
613 for (n
= ERROR_FIRST
+ 1; n
< ERROR_LAST
; n
++)
615 st_printf ("%d %s\n", n
, translate_error (n
));
617 st_printf (" %d %s\n", n
, translate_error (n
));
619 st_printf ("\nCommand line arguments:\n");
620 st_printf (" --help Print this list\n");
622 /* st_printf(" --resume <dropfile> Resume program execution from dropfile\n"); */