1 /* Copyright (C) 2002, 2003, 2005, 2007, 2009, 2012
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 #include "libgfortran.h"
33 /* Environment scanner. Examine the environment for controlling minor
34 * aspects of the program's execution. Our philosophy here that the
35 * environment should not prevent the program from running, so an
36 * environment variable with a messed-up value will be interpreted in
39 * Most of the environment is checked early in the startup sequence,
40 * but other variables are checked during execution of the user's
46 typedef struct variable
50 void (*init
) (struct variable
*);
51 void (*show
) (struct variable
*);
57 static void init_unformatted (variable
*);
60 #ifdef FALLBACK_SECURE_GETENV
62 secure_getenv (const char *name
)
64 if ((getuid () == geteuid ()) && (getgid () == getegid ()))
72 /* print_spaces()-- Print a particular number of spaces. */
83 for (i
= 0; i
< n
; i
++)
92 /* var_source()-- Return a string that describes where the value of a
93 * variable comes from */
96 var_source (variable
* v
)
98 if (getenv (v
->name
) == NULL
)
108 /* init_integer()-- Initialize an integer environment variable. */
111 init_integer (variable
* v
)
115 p
= getenv (v
->name
);
120 if (!isdigit (*q
) && (p
!= q
|| *q
!= '-'))
135 /* init_unsigned_integer()-- Initialize an integer environment variable
136 which has to be positive. */
139 init_unsigned_integer (variable
* v
)
143 p
= getenv (v
->name
);
163 /* show_integer()-- Show an integer environment variable */
166 show_integer (variable
* v
)
168 st_printf ("%s %d\n", var_source (v
), *v
->var
);
172 /* init_boolean()-- Initialize a boolean environment variable. We
173 * only look at the first letter of the variable. */
176 init_boolean (variable
* v
)
180 p
= getenv (v
->name
);
184 if (*p
== '1' || *p
== 'Y' || *p
== 'y')
190 if (*p
== '0' || *p
== 'N' || *p
== 'n')
204 /* show_boolean()-- Show a boolean environment variable */
207 show_boolean (variable
* v
)
209 st_printf ("%s %s\n", var_source (v
), *v
->var
? "Yes" : "No");
214 init_sep (variable
* v
)
219 p
= getenv (v
->name
);
224 options
.separator
= p
;
225 options
.separator_len
= strlen (p
);
227 /* Make sure the separator is valid */
229 if (options
.separator_len
== 0)
252 options
.separator
= " ";
253 options
.separator_len
= 1;
258 show_sep (variable
* v
)
260 st_printf ("%s \"%s\"\n", var_source (v
), options
.separator
);
265 init_string (variable
* v
__attribute__ ((unused
)))
270 show_string (variable
* v
)
274 p
= getenv (v
->name
);
278 estr_write (var_source (v
));
285 static variable variable_table
[] = {
286 {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER
, &options
.stdin_unit
,
287 init_integer
, show_integer
,
288 "Unit number that will be preconnected to standard input\n"
289 "(No preconnection if negative)", 0},
291 {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER
, &options
.stdout_unit
,
292 init_integer
, show_integer
,
293 "Unit number that will be preconnected to standard output\n"
294 "(No preconnection if negative)", 0},
296 {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER
, &options
.stderr_unit
,
297 init_integer
, show_integer
,
298 "Unit number that will be preconnected to standard error\n"
299 "(No preconnection if negative)", 0},
301 {"TMPDIR", 0, NULL
, init_string
, show_string
,
302 "Directory for scratch files.", 0},
304 {"GFORTRAN_UNBUFFERED_ALL", 0, &options
.all_unbuffered
, init_boolean
,
306 "If TRUE, all output is unbuffered. This will slow down large writes "
307 "but can be\nuseful for forcing data to be displayed immediately.", 0},
309 {"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options
.unbuffered_preconnected
,
310 init_boolean
, show_boolean
,
311 "If TRUE, output to preconnected units is unbuffered.", 0},
313 {"GFORTRAN_SHOW_LOCUS", 1, &options
.locus
, init_boolean
, show_boolean
,
314 "If TRUE, print filename and line number where runtime errors happen.", 0},
316 {"GFORTRAN_OPTIONAL_PLUS", 0, &options
.optional_plus
, init_boolean
, show_boolean
,
317 "Print optional plus signs in numbers where permitted. Default FALSE.", 0},
319 {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL
, &options
.default_recl
,
320 init_unsigned_integer
, show_integer
,
321 "Default maximum record length for sequential files. Most useful for\n"
322 "adjusting line length of preconnected units. Default "
323 stringize (DEFAULT_RECL
), 0},
325 {"GFORTRAN_LIST_SEPARATOR", 0, NULL
, init_sep
, show_sep
,
326 "Separator to use when writing list output. May contain any number of "
327 "spaces\nand at most one comma. Default is a single space.", 0},
329 /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
331 {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted
, show_string
,
332 "Set format for unformatted files", 0},
334 {"GFORTRAN_ERROR_BACKTRACE", -1, &options
.backtrace
,
335 init_boolean
, show_boolean
,
336 "Print out a backtrace (if possible) on runtime error", -1},
338 {NULL
, 0, NULL
, NULL
, NULL
, NULL
, 0}
342 /* init_variables()-- Initialize most runtime variables from
343 * environment variables. */
346 init_variables (void)
350 for (v
= variable_table
; v
->name
; v
++)
356 show_variables (void)
361 /* TODO: print version number. */
362 estr_write ("GNU Fortran runtime library version "
365 estr_write ("Environment variables:\n");
366 estr_write ("----------------------\n");
368 for (v
= variable_table
; v
->name
; v
++)
370 n
= estr_write (v
->name
);
371 print_spaces (25 - n
);
373 if (v
->show
== show_integer
)
374 estr_write ("Integer ");
375 else if (v
->show
== show_boolean
)
376 estr_write ("Boolean ");
378 estr_write ("String ");
381 estr_write (v
->desc
);
385 /* System error codes */
387 estr_write ("\nRuntime error codes:");
388 estr_write ("\n--------------------\n");
390 for (n
= LIBERROR_FIRST
+ 1; n
< LIBERROR_LAST
; n
++)
392 st_printf ("%d %s\n", n
, translate_error (n
));
394 st_printf (" %d %s\n", n
, translate_error (n
));
396 estr_write ("\nCommand line arguments:\n");
397 estr_write (" --help Print this list\n");
402 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
403 It is called from environ.c to parse this variable, and from
404 open.c to determine if the user specified a default for an
406 The syntax of the environment variable is, in bison grammar:
408 GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
409 mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
410 exception: mode ':' unit_list | unit_list ;
411 unit_list: unit_spec | unit_list unit_spec ;
412 unit_spec: INTEGER | INTEGER '-' INTEGER ;
415 /* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
422 /* Some space for additional tokens later. */
434 static char *p
; /* Main character pointer for parsing. */
435 static char *lastpos
; /* Auxiliary pointer, for backing up. */
436 static int unit_num
; /* The last unit number read. */
437 static int unit_count
; /* The number of units found. */
438 static int do_count
; /* Parsing is done twice - first to count the number
439 of units, then to fill in the table. This
440 variable controls what to do. */
441 static exception_t
*elist
; /* The list of exceptions to the default. This is
442 sorted according to unit number. */
443 static int n_elist
; /* Number of exceptions to the default. */
445 static unit_convert endian
; /* Current endianness. */
447 static unit_convert def
; /* Default as specified (if any). */
449 /* Search for a unit number, using a binary search. The
450 first argument is the unit number to search for. The second argument
451 is a pointer to an index.
452 If the unit number is found, the function returns 1, and the index
453 is that of the element.
454 If the unit number is not found, the function returns 0, and the
455 index is the one where the element would be inserted. */
458 search_unit (int unit
, int *ip
)
473 mid
= (low
+ high
) / 2;
474 if (unit
== elist
[mid
].unit
)
479 else if (unit
> elist
[mid
].unit
)
483 } while (low
<= high
);
485 if (unit
> elist
[mid
].unit
)
493 /* This matches a keyword. If it is found, return the token supplied,
494 otherwise return ILLEGAL. */
497 match_word (const char *word
, int tok
)
501 if (strncasecmp (p
, word
, strlen (word
)) == 0)
512 /* Match an integer and store its value in unit_num. This only works
513 if p actually points to the start of an integer. The caller has
521 unit_num
= unit_num
* 10 + (*p
++ - '0');
526 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
527 Returned values are the different tokens. */
551 result
= match_word ("big_endian", BIG
);
556 result
= match_word ("little_endian", LITTLE
);
561 result
= match_word ("native", NATIVE
);
566 result
= match_word ("swap", SWAP
);
569 case '1': case '2': case '3': case '4': case '5':
570 case '6': case '7': case '8': case '9':
571 result
= match_integer ();
581 /* Back up the last token by setting back the character pointer. */
589 /* This is called when a unit is identified. If do_count is nonzero,
590 increment the number of units by one. If do_count is zero,
591 put the unit into the table. */
594 mark_single (int unit
)
603 if (search_unit (unit
, &i
))
605 elist
[i
].conv
= endian
;
609 for (j
=n_elist
-1; j
>=i
; j
--)
610 elist
[j
+1] = elist
[j
];
613 elist
[i
].unit
= unit
;
614 elist
[i
].conv
= endian
;
618 /* This is called when a unit range is identified. If do_count is
619 nonzero, increase the number of units. If do_count is zero,
620 put the unit into the table. */
623 mark_range (int unit1
, int unit2
)
627 unit_count
+= abs (unit2
- unit1
) + 1;
631 for (i
=unit2
; i
<=unit1
; i
++)
634 for (i
=unit1
; i
<=unit2
; i
++)
639 /* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
640 twice, once to count the units and once to actually mark them in
641 the table. When counting, we don't check for double occurrences
656 /* Parse the string. First, let's look for a default. */
661 endian
= GFC_CONVERT_NATIVE
;
665 endian
= GFC_CONVERT_SWAP
;
669 endian
= GFC_CONVERT_BIG
;
673 endian
= GFC_CONVERT_LITTLE
;
677 /* A leading digit means that we are looking at an exception.
678 Reset the position to the beginning, and continue processing
679 at the exception list. */
701 /* This isn't a default after all. Reset the position to the
702 beginning, and continue processing at the exception list. */
719 /* Loop over all exceptions. */
726 if (next_token () != ':')
728 endian
= GFC_CONVERT_NATIVE
;
732 if (next_token () != ':')
734 endian
= GFC_CONVERT_SWAP
;
738 if (next_token () != ':')
740 endian
= GFC_CONVERT_LITTLE
;
744 if (next_token () != ':')
746 endian
= GFC_CONVERT_BIG
;
761 /* We arrive here when we want to parse a list of
772 /* The number can be followed by a - and another number,
773 which means that this is a unit range, a comma
777 if (next_token () != INTEGER
)
780 mark_range (unit1
, unit_num
);
809 } while (continue_ulist
);
814 def
= GFC_CONVERT_NONE
;
818 void init_unformatted (variable
* v
)
821 val
= getenv (v
->name
);
822 def
= GFC_CONVERT_NONE
;
837 elist
= xmalloc (unit_count
* sizeof (exception_t
));
844 /* Get the default conversion for for an unformatted unit. */
847 get_unformatted_convert (int unit
)
853 else if (search_unit (unit
, &i
))
854 return elist
[i
].conv
;