1 /* Copyright (C) 2002, 2003, 2005, 2007 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. */
30 #include "libgfortran.h"
37 /* Environment scanner. Examine the environment for controlling minor
38 * aspects of the program's execution. Our philosophy here that the
39 * environment should not prevent the program from running, so an
40 * environment variable with a messed-up value will be interpreted in
43 * Most of the environment is checked early in the startup sequence,
44 * but other variables are checked during execution of the user's
50 typedef struct variable
54 void (*init
) (struct variable
*);
55 void (*show
) (struct variable
*);
61 static void init_unformatted (variable
*);
63 /* print_spaces()-- Print a particular number of spaces. */
74 for (i
= 0; i
< n
; i
++)
83 /* var_source()-- Return a string that describes where the value of a
84 * variable comes from */
87 var_source (variable
* v
)
89 if (getenv (v
->name
) == NULL
)
99 /* init_integer()-- Initialize an integer environment variable. */
102 init_integer (variable
* v
)
106 p
= getenv (v
->name
);
111 if (!isdigit (*q
) && (p
!= q
|| *q
!= '-'))
126 /* init_unsigned_integer()-- Initialize an integer environment variable
127 which has to be positive. */
130 init_unsigned_integer (variable
* v
)
134 p
= getenv (v
->name
);
154 /* show_integer()-- Show an integer environment variable */
157 show_integer (variable
* v
)
159 st_printf ("%s %d\n", var_source (v
), *v
->var
);
163 /* init_boolean()-- Initialize a boolean environment variable. We
164 * only look at the first letter of the variable. */
167 init_boolean (variable
* v
)
171 p
= getenv (v
->name
);
175 if (*p
== '1' || *p
== 'Y' || *p
== 'y')
181 if (*p
== '0' || *p
== 'N' || *p
== 'n')
195 /* show_boolean()-- Show a boolean environment variable */
198 show_boolean (variable
* v
)
200 st_printf ("%s %s\n", var_source (v
), *v
->var
? "Yes" : "No");
205 init_sep (variable
* v
)
210 p
= getenv (v
->name
);
215 options
.separator
= p
;
216 options
.separator_len
= strlen (p
);
218 /* Make sure the separator is valid */
220 if (options
.separator_len
== 0)
243 options
.separator
= " ";
244 options
.separator_len
= 1;
249 show_sep (variable
* v
)
251 st_printf ("%s \"%s\"\n", var_source (v
), options
.separator
);
256 init_string (variable
* v
__attribute__ ((unused
)))
261 show_string (variable
* v
)
265 p
= getenv (v
->name
);
269 st_printf ("%s \"%s\"\n", var_source (v
), p
);
273 static variable variable_table
[] = {
274 {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER
, &options
.stdin_unit
,
275 init_integer
, show_integer
,
276 "Unit number that will be preconnected to standard input\n"
277 "(No preconnection if negative)", 0},
279 {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER
, &options
.stdout_unit
,
280 init_integer
, show_integer
,
281 "Unit number that will be preconnected to standard output\n"
282 "(No preconnection if negative)", 0},
284 {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER
, &options
.stderr_unit
,
285 init_integer
, show_integer
,
286 "Unit number that will be preconnected to standard error\n"
287 "(No preconnection if negative)", 0},
289 {"GFORTRAN_USE_STDERR", 1, &options
.use_stderr
, init_boolean
,
291 "Sends library output to standard error instead of standard output.", 0},
293 {"GFORTRAN_TMPDIR", 0, NULL
, init_string
, show_string
,
294 "Directory for scratch files. Overrides the TMP environment variable\n"
295 "If TMP is not set " DEFAULT_TEMPDIR
" is used.", 0},
297 {"GFORTRAN_UNBUFFERED_ALL", 0, &options
.all_unbuffered
, init_boolean
,
299 "If TRUE, all output is unbuffered. This will slow down large writes "
300 "but can be\nuseful for forcing data to be displayed immediately.", 0},
302 {"GFORTRAN_SHOW_LOCUS", 1, &options
.locus
, init_boolean
, show_boolean
,
303 "If TRUE, print filename and line number where runtime errors happen.", 0},
305 {"GFORTRAN_OPTIONAL_PLUS", 0, &options
.optional_plus
, init_boolean
, show_boolean
,
306 "Print optional plus signs in numbers where permitted. Default FALSE.", 0},
308 {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL
, &options
.default_recl
,
309 init_unsigned_integer
, show_integer
,
310 "Default maximum record length for sequential files. Most useful for\n"
311 "adjusting line length of preconnected units. Default "
312 stringize (DEFAULT_RECL
), 0},
314 {"GFORTRAN_LIST_SEPARATOR", 0, NULL
, init_sep
, show_sep
,
315 "Separator to use when writing list output. May contain any number of "
316 "spaces\nand at most one comma. Default is a single space.", 0},
318 /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
320 {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted
, show_string
,
321 "Set format for unformatted files", 0},
323 /* Behaviour when encoutering a runtime error. */
324 {"GFORTRAN_ERROR_DUMPCORE", -1, &options
.dump_core
,
325 init_boolean
, show_boolean
,
326 "Dump a core file (if possible) on runtime error", -1},
328 {"GFORTRAN_ERROR_BACKTRACE", -1, &options
.backtrace
,
329 init_boolean
, show_boolean
,
330 "Print out a backtrace (if possible) on runtime error", -1},
332 {NULL
, 0, NULL
, NULL
, NULL
, NULL
, 0}
336 /* init_variables()-- Initialize most runtime variables from
337 * environment variables. */
340 init_variables (void)
344 for (v
= variable_table
; v
->name
; v
++)
349 /* check_buffered()-- Given an unit number n, determine if an override
350 * for the stream exists. Returns zero for unbuffered, one for
351 * buffered or two for not set. */
354 check_buffered (int n
)
356 char name
[22 + sizeof (n
) * 3];
360 if (options
.all_unbuffered
)
363 sprintf (name
, "GFORTRAN_UNBUFFERED_%d", n
);
376 show_variables (void)
381 /* TODO: print version number. */
382 st_printf ("GNU Fortran 95 runtime library version "
385 st_printf ("Environment variables:\n");
386 st_printf ("----------------------\n");
388 for (v
= variable_table
; v
->name
; v
++)
390 n
= st_printf ("%s", v
->name
);
391 print_spaces (25 - n
);
393 if (v
->show
== show_integer
)
394 st_printf ("Integer ");
395 else if (v
->show
== show_boolean
)
396 st_printf ("Boolean ");
398 st_printf ("String ");
401 st_printf ("%s\n\n", v
->desc
);
404 /* System error codes */
406 st_printf ("\nRuntime error codes:");
407 st_printf ("\n--------------------\n");
409 for (n
= LIBERROR_FIRST
+ 1; n
< LIBERROR_LAST
; n
++)
411 st_printf ("%d %s\n", n
, translate_error (n
));
413 st_printf (" %d %s\n", n
, translate_error (n
));
415 st_printf ("\nCommand line arguments:\n");
416 st_printf (" --help Print this list\n");
418 /* st_printf(" --resume <dropfile> Resume program execution from dropfile\n"); */
423 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
424 It is called from environ.c to parse this variable, and from
425 open.c to determine if the user specified a default for an
427 The syntax of the environment variable is, in bison grammar:
429 GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
430 mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
431 exception: mode ':' unit_list | unit_list ;
432 unit_list: unit_spec | unit_list unit_spec ;
433 unit_spec: INTEGER | INTEGER '-' INTEGER ;
436 /* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
443 /* Some space for additional tokens later. */
455 static char *p
; /* Main character pointer for parsing. */
456 static char *lastpos
; /* Auxiliary pointer, for backing up. */
457 static int unit_num
; /* The last unit number read. */
458 static int unit_count
; /* The number of units found. */
459 static int do_count
; /* Parsing is done twice - first to count the number
460 of units, then to fill in the table. This
461 variable controls what to do. */
462 static exception_t
*elist
; /* The list of exceptions to the default. This is
463 sorted according to unit number. */
464 static int n_elist
; /* Number of exceptions to the default. */
466 static unit_convert endian
; /* Current endianness. */
468 static unit_convert def
; /* Default as specified (if any). */
470 /* Search for a unit number, using a binary search. The
471 first argument is the unit number to search for. The second argument
472 is a pointer to an index.
473 If the unit number is found, the function returns 1, and the index
474 is that of the element.
475 If the unit number is not found, the function returns 0, and the
476 index is the one where the element would be inserted. */
479 search_unit (int unit
, int *ip
)
485 while (high
- low
> 1)
487 mid
= (low
+ high
) / 2;
488 if (unit
<= elist
[mid
].unit
)
494 if (elist
[high
].unit
== unit
)
500 /* This matches a keyword. If it is found, return the token supplied,
501 otherwise return ILLEGAL. */
504 match_word (const char *word
, int tok
)
508 if (strncasecmp (p
, word
, strlen (word
)) == 0)
519 /* Match an integer and store its value in unit_num. This only works
520 if p actually points to the start of an integer. The caller has
528 unit_num
= unit_num
* 10 + (*p
++ - '0');
533 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
534 Returned values are the different tokens. */
558 result
= match_word ("big_endian", BIG
);
563 result
= match_word ("little_endian", LITTLE
);
568 result
= match_word ("native", NATIVE
);
573 result
= match_word ("swap", SWAP
);
576 case '1': case '2': case '3': case '4': case '5':
577 case '6': case '7': case '8': case '9':
578 result
= match_integer ();
588 /* Back up the last token by setting back the character pointer. */
596 /* This is called when a unit is identified. If do_count is nonzero,
597 increment the number of units by one. If do_count is zero,
598 put the unit into the table. */
601 mark_single (int unit
)
610 if (search_unit (unit
, &i
))
612 elist
[unit
].conv
= endian
;
616 for (j
=n_elist
; j
>=i
; j
--)
617 elist
[j
+1] = elist
[j
];
620 elist
[i
].unit
= unit
;
621 elist
[i
].conv
= endian
;
625 /* This is called when a unit range is identified. If do_count is
626 nonzero, increase the number of units. If do_count is zero,
627 put the unit into the table. */
630 mark_range (int unit1
, int unit2
)
634 unit_count
+= abs (unit2
- unit1
) + 1;
638 for (i
=unit2
; i
<=unit1
; i
++)
641 for (i
=unit1
; i
<=unit2
; i
++)
646 /* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
647 twice, once to count the units and once to actually mark them in
648 the table. When counting, we don't check for double occurrences
663 /* Parse the string. First, let's look for a default. */
668 endian
= GFC_CONVERT_NATIVE
;
672 endian
= GFC_CONVERT_SWAP
;
676 endian
= GFC_CONVERT_BIG
;
680 endian
= GFC_CONVERT_LITTLE
;
684 /* A leading digit means that we are looking at an exception.
685 Reset the position to the beginning, and continue processing
686 at the exception list. */
708 /* This isn't a default after all. Reset the position to the
709 beginning, and continue processing at the exception list. */
726 /* Loop over all exceptions. */
733 if (next_token () != ':')
735 endian
= GFC_CONVERT_NATIVE
;
739 if (next_token () != ':')
741 endian
= GFC_CONVERT_SWAP
;
745 if (next_token () != ':')
747 endian
= GFC_CONVERT_LITTLE
;
751 if (next_token () != ':')
753 endian
= GFC_CONVERT_BIG
;
768 /* We arrive here when we want to parse a list of
779 /* The number can be followed by a - and another number,
780 which means that this is a unit range, a comma
784 if (next_token () != INTEGER
)
787 mark_range (unit1
, unit_num
);
816 } while (continue_ulist
);
821 def
= GFC_CONVERT_NONE
;
825 void init_unformatted (variable
* v
)
828 val
= getenv (v
->name
);
829 def
= GFC_CONVERT_NONE
;
844 elist
= get_mem (unit_count
* sizeof (exception_t
));
851 /* Get the default conversion for for an unformatted unit. */
854 get_unformatted_convert (int unit
)
860 else if (search_unit (unit
, &i
))
861 return elist
[i
].conv
;