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
*);
64 static void init_unformatted (variable
*);
66 /* print_spaces()-- Print a particular number of spaces. */
77 for (i
= 0; i
< n
; i
++)
86 /* var_source()-- Return a string that describes where the value of a
87 * variable comes from */
90 var_source (variable
* v
)
92 if (getenv (v
->name
) == NULL
)
102 /* init_integer()-- Initialize an integer environment variable. */
105 init_integer (variable
* v
)
109 p
= getenv (v
->name
);
114 if (!isdigit (*q
) && (p
!= q
|| *q
!= '-'))
129 /* init_unsigned_integer()-- Initialize an integer environment variable
130 which has to be positive. */
133 init_unsigned_integer (variable
* v
)
137 p
= getenv (v
->name
);
157 /* show_integer()-- Show an integer environment variable */
160 show_integer (variable
* v
)
162 st_printf ("%s %d\n", var_source (v
), *v
->var
);
166 /* init_boolean()-- Initialize a boolean environment variable. We
167 * only look at the first letter of the variable. */
170 init_boolean (variable
* v
)
174 p
= getenv (v
->name
);
178 if (*p
== '1' || *p
== 'Y' || *p
== 'y')
184 if (*p
== '0' || *p
== 'N' || *p
== 'n')
198 /* show_boolean()-- Show a boolean environment variable */
201 show_boolean (variable
* v
)
203 st_printf ("%s %s\n", var_source (v
), *v
->var
? "Yes" : "No");
207 /* init_mem()-- Initialize environment variables that have to do with
208 * how memory from an ALLOCATE statement is filled. A single flag
209 * enables filling and a second variable gives the value that is used
210 * to initialize the memory. */
213 init_mem (variable
* v
)
218 p
= getenv (v
->name
);
220 options
.allocate_init_flag
= 0; /* The default */
225 if (strcasecmp (p
, "NONE") == 0)
228 /* IEEE-754 Quiet Not-a-Number that will work for single and double
229 * precision. Look for the 'f95' mantissa in debug dumps. */
231 if (strcasecmp (p
, "NaN") == 0)
233 options
.allocate_init_flag
= 1;
234 options
.allocate_init_value
= 0xfff80f95;
238 /* Interpret the string as a hexadecimal constant */
255 n
= (n
<< 4) | (*p
++ - offset
);
258 options
.allocate_init_flag
= 1;
259 options
.allocate_init_value
= n
;
264 show_mem (variable
* v
)
268 p
= getenv (v
->name
);
270 st_printf ("%s ", var_source (v
));
272 if (options
.allocate_init_flag
)
273 st_printf ("0x%x", options
.allocate_init_value
);
280 init_sep (variable
* v
)
285 p
= getenv (v
->name
);
290 options
.separator
= p
;
291 options
.separator_len
= strlen (p
);
293 /* Make sure the separator is valid */
295 if (options
.separator_len
== 0)
318 options
.separator
= " ";
319 options
.separator_len
= 1;
324 show_sep (variable
* v
)
326 st_printf ("%s \"%s\"\n", var_source (v
), options
.separator
);
331 init_string (variable
* v
__attribute__ ((unused
)))
336 show_string (variable
* v
)
340 p
= getenv (v
->name
);
344 st_printf ("%s \"%s\"\n", var_source (v
), p
);
348 /* Structure for associating names and values. */
359 { FP_ROUND_NEAREST
, FP_ROUND_UP
, FP_ROUND_DOWN
, FP_ROUND_ZERO
};
361 static const choice rounding
[] = {
362 {"NEAREST", FP_ROUND_NEAREST
},
364 {"DOWN", FP_ROUND_DOWN
},
365 {"ZERO", FP_ROUND_ZERO
},
369 static const choice precision
[] =
377 static const choice signal_choices
[] =
386 init_choice (variable
* v
, const choice
* c
)
390 p
= getenv (v
->name
);
395 if (strcasecmp (c
->name
, p
) == 0)
413 show_choice (variable
* v
, const choice
* c
)
415 st_printf ("%s ", var_source (v
));
418 if (c
->value
== *v
->var
)
422 st_printf ("%s\n", c
->name
);
424 st_printf ("(Unknown)\n");
429 init_round (variable
* v
)
431 init_choice (v
, rounding
);
435 show_round (variable
* v
)
437 show_choice (v
, rounding
);
441 init_precision (variable
* v
)
443 init_choice (v
, precision
);
447 show_precision (variable
* v
)
449 show_choice (v
, precision
);
453 init_signal (variable
* v
)
455 init_choice (v
, signal_choices
);
459 show_signal (variable
* v
)
461 show_choice (v
, signal_choices
);
465 static variable variable_table
[] = {
466 {"GFORTRAN_STDIN_UNIT", 5, &options
.stdin_unit
, init_integer
, show_integer
,
467 "Unit number that will be preconnected to standard input\n"
468 "(No preconnection if negative)", 0},
470 {"GFORTRAN_STDOUT_UNIT", 6, &options
.stdout_unit
, init_integer
,
472 "Unit number that will be preconnected to standard output\n"
473 "(No preconnection if negative)", 0},
475 {"GFORTRAN_STDERR_UNIT", 0, &options
.stderr_unit
, init_integer
,
477 "Unit number that will be preconnected to standard error\n"
478 "(No preconnection if negative)", 0},
480 {"GFORTRAN_USE_STDERR", 1, &options
.use_stderr
, init_boolean
,
482 "Sends library output to standard error instead of standard output.", 0},
484 {"GFORTRAN_TMPDIR", 0, NULL
, init_string
, show_string
,
485 "Directory for scratch files. Overrides the TMP environment variable\n"
486 "If TMP is not set " DEFAULT_TEMPDIR
" is used.", 0},
488 {"GFORTRAN_UNBUFFERED_ALL", 0, &options
.all_unbuffered
, init_boolean
,
490 "If TRUE, all output is unbuffered. This will slow down large writes "
491 "but can be\nuseful for forcing data to be displayed immediately.", 0},
493 {"GFORTRAN_SHOW_LOCUS", 1, &options
.locus
, init_boolean
, show_boolean
,
494 "If TRUE, print filename and line number where runtime errors happen.", 0},
496 {"GFORTRAN_OPTIONAL_PLUS", 0, &options
.optional_plus
, init_boolean
, show_boolean
,
497 "Print optional plus signs in numbers where permitted. Default FALSE.", 0},
499 {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL
, &options
.default_recl
,
500 init_unsigned_integer
, show_integer
,
501 "Default maximum record length for sequential files. Most useful for\n"
502 "adjusting line length of preconnected units. Default "
503 stringize (DEFAULT_RECL
), 0},
505 {"GFORTRAN_LIST_SEPARATOR", 0, NULL
, init_sep
, show_sep
,
506 "Separator to use when writing list output. May contain any number of "
507 "spaces\nand at most one comma. Default is a single space.", 0},
509 /* Memory related controls */
511 {"GFORTRAN_MEM_INIT", 0, NULL
, init_mem
, show_mem
,
512 "How to initialize allocated memory. Default value is NONE for no "
513 "initialization\n(faster), NAN for a Not-a-Number with the mantissa "
514 "0x40f95 or a custom\nhexadecimal value", 0},
516 {"GFORTRAN_MEM_CHECK", 0, &options
.mem_check
, init_boolean
, show_boolean
,
517 "Whether memory still allocated will be reported when the program ends.",
520 /* Signal handling (Unix). */
522 {"GFORTRAN_SIGHUP", 0, &options
.sighup
, init_signal
, show_signal
,
523 "Whether the program will IGNORE or ABORT on SIGHUP.", 0},
525 {"GFORTRAN_SIGINT", 0, &options
.sigint
, init_signal
, show_signal
,
526 "Whether the program will IGNORE or ABORT on SIGINT.", 0},
528 /* Floating point control */
530 {"GFORTRAN_FPU_ROUND", 0, &options
.fpu_round
, init_round
, show_round
,
531 "Set floating point rounding. Values are NEAREST, UP, DOWN, ZERO.", 0},
533 {"GFORTRAN_FPU_PRECISION", 0, &options
.fpu_precision
, init_precision
,
535 "Precision of intermediate results. Values are 24, 53 and 64.", 0},
537 /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
539 {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted
, show_string
,
540 "Set format for unformatted files", 0},
542 {NULL
, 0, NULL
, NULL
, NULL
, NULL
, 0}
546 /* init_variables()-- Initialize most runtime variables from
547 * environment variables. */
550 init_variables (void)
554 for (v
= variable_table
; v
->name
; v
++)
559 /* check_buffered()-- Given an unit number n, determine if an override
560 * for the stream exists. Returns zero for unbuffered, one for
561 * buffered or two for not set. */
564 check_buffered (int n
)
566 char name
[22 + sizeof (n
) * 3];
570 if (options
.all_unbuffered
)
573 sprintf (name
, "GFORTRAN_UNBUFFERED_%d", n
);
586 show_variables (void)
591 /* TODO: print version number. */
592 st_printf ("GNU Fortran 95 runtime library version "
595 st_printf ("Environment variables:\n");
596 st_printf ("----------------------\n");
598 for (v
= variable_table
; v
->name
; v
++)
600 n
= st_printf ("%s", v
->name
);
601 print_spaces (25 - n
);
603 if (v
->show
== show_integer
)
604 st_printf ("Integer ");
605 else if (v
->show
== show_boolean
)
606 st_printf ("Boolean ");
608 st_printf ("String ");
611 st_printf ("%s\n\n", v
->desc
);
614 /* System error codes */
616 st_printf ("\nRuntime error codes:");
617 st_printf ("\n--------------------\n");
619 for (n
= ERROR_FIRST
+ 1; n
< ERROR_LAST
; n
++)
621 st_printf ("%d %s\n", n
, translate_error (n
));
623 st_printf (" %d %s\n", n
, translate_error (n
));
625 st_printf ("\nCommand line arguments:\n");
626 st_printf (" --help Print this list\n");
628 /* st_printf(" --resume <dropfile> Resume program execution from dropfile\n"); */
633 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
634 It is called from environ.c to parse this variable, and from
635 open.c to determine if the user specified a default for an
637 The syntax of the environment variable is, in bison grammar:
639 GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
640 mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
641 exception: mode ':' unit_list | unit_list ;
642 unit_list: unit_spec | unit_list unit_spec ;
643 unit_spec: INTEGER | INTEGER '-' INTEGER ;
646 /* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
653 /* Some space for additional tokens later. */
665 static char *p
; /* Main character pointer for parsing. */
666 static char *lastpos
; /* Auxiliary pointer, for backing up. */
667 static int unit_num
; /* The last unit number read. */
668 static int unit_count
; /* The number of units found. */
669 static int do_count
; /* Parsing is done twice - first to count the number
670 of units, then to fill in the table. This
671 variable controls what to do. */
672 static exception_t
*elist
; /* The list of exceptions to the default. This is
673 sorted according to unit number. */
674 static int n_elist
; /* Number of exceptions to the default. */
676 static unit_convert endian
; /* Current endianness. */
678 static unit_convert def
; /* Default as specified (if any). */
680 /* Search for a unit number, using a binary search. The
681 first argument is the unit number to search for. The second argument
682 is a pointer to an index.
683 If the unit number is found, the function returns 1, and the index
684 is that of the element.
685 If the unit number is not found, the function returns 0, and the
686 index is the one where the element would be inserted. */
689 search_unit (int unit
, int *ip
)
695 while (high
- low
> 1)
697 mid
= (low
+ high
) / 2;
698 if (unit
<= elist
[mid
].unit
)
704 if (elist
[high
].unit
== unit
)
710 /* This matches a keyword. If it is found, return the token supplied,
711 otherwise return ILLEGAL. */
714 match_word (const char *word
, int tok
)
718 if (strncasecmp (p
, word
, strlen (word
)) == 0)
729 /* Match an integer and store its value in unit_num. This only works
730 if p actually points to the start of an integer. The caller has
738 unit_num
= unit_num
* 10 + (*p
++ - '0');
743 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
744 Returned values are the different tokens. */
768 result
= match_word ("big_endian", BIG
);
773 result
= match_word ("little_endian", LITTLE
);
778 result
= match_word ("native", NATIVE
);
783 result
= match_word ("swap", SWAP
);
786 case '1': case '2': case '3': case '4': case '5':
787 case '6': case '7': case '8': case '9':
788 result
= match_integer ();
798 /* Back up the last token by setting back the character pointer. */
806 /* This is called when a unit is identified. If do_count is nonzero,
807 increment the number of units by one. If do_count is zero,
808 put the unit into the table. */
811 mark_single (int unit
)
820 if (search_unit (unit
, &i
))
822 elist
[unit
].conv
= endian
;
826 for (j
=n_elist
; j
>=i
; j
--)
827 elist
[j
+1] = elist
[j
];
830 elist
[i
].unit
= unit
;
831 elist
[i
].conv
= endian
;
835 /* This is called when a unit range is identified. If do_count is
836 nonzero, increase the number of units. If do_count is zero,
837 put the unit into the table. */
840 mark_range (int unit1
, int unit2
)
844 unit_count
+= abs (unit2
- unit1
) + 1;
848 for (i
=unit2
; i
<=unit1
; i
++)
851 for (i
=unit1
; i
<=unit2
; i
++)
856 /* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
857 twice, once to count the units and once to actually mark them in
858 the table. When counting, we don't check for double occurrences
874 /* Parse the string. First, let's look for a default. */
879 endian
= CONVERT_NATIVE
;
883 endian
= CONVERT_SWAP
;
887 endian
= CONVERT_BIG
;
891 endian
= CONVERT_LITTLE
;
895 /* A leading digit means that we are looking at an exception.
896 Reset the position to the beginning, and continue processing
897 at the exception list. */
919 /* This isn't a default after all. Reset the position to the
920 beginning, and continue processing at the exception list. */
936 /* Loop over all exceptions. */
943 if (next_token () != ':')
945 endian
= CONVERT_LITTLE
;
949 if (next_token () != ':')
951 endian
= CONVERT_BIG
;
966 /* We arrive here when we want to parse a list of
977 /* The number can be followed by a - and another number,
978 which means that this is a unit range, a comma
982 if (next_token () != INTEGER
)
985 mark_range (unit1
, unit_num
);
1014 } while (continue_ulist
);
1023 void init_unformatted (variable
* v
)
1026 val
= getenv (v
->name
);
1042 elist
= get_mem (unit_count
* sizeof (exception_t
));
1049 /* Get the default conversion for for an unformatted unit. */
1052 get_unformatted_convert (int unit
)
1058 else if (search_unit (unit
, &i
))
1059 return elist
[i
].conv
;