1 /* Copyright (C) 2002, 2003, 2005, 2007, 2009 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 3, or (at your option)
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
23 <http://www.gnu.org/licenses/>. */
25 #include "libgfortran.h"
32 /* Environment scanner. Examine the environment for controlling minor
33 * aspects of the program's execution. Our philosophy here that the
34 * environment should not prevent the program from running, so an
35 * environment variable with a messed-up value will be interpreted in
38 * Most of the environment is checked early in the startup sequence,
39 * but other variables are checked during execution of the user's
45 typedef struct variable
49 void (*init
) (struct variable
*);
50 void (*show
) (struct variable
*);
56 static void init_unformatted (variable
*);
58 /* print_spaces()-- Print a particular number of spaces. */
69 for (i
= 0; i
< n
; i
++)
78 /* var_source()-- Return a string that describes where the value of a
79 * variable comes from */
82 var_source (variable
* v
)
84 if (getenv (v
->name
) == NULL
)
94 /* init_integer()-- Initialize an integer environment variable. */
97 init_integer (variable
* v
)
101 p
= getenv (v
->name
);
106 if (!isdigit (*q
) && (p
!= q
|| *q
!= '-'))
121 /* init_unsigned_integer()-- Initialize an integer environment variable
122 which has to be positive. */
125 init_unsigned_integer (variable
* v
)
129 p
= getenv (v
->name
);
149 /* show_integer()-- Show an integer environment variable */
152 show_integer (variable
* v
)
154 st_printf ("%s %d\n", var_source (v
), *v
->var
);
158 /* init_boolean()-- Initialize a boolean environment variable. We
159 * only look at the first letter of the variable. */
162 init_boolean (variable
* v
)
166 p
= getenv (v
->name
);
170 if (*p
== '1' || *p
== 'Y' || *p
== 'y')
176 if (*p
== '0' || *p
== 'N' || *p
== 'n')
190 /* show_boolean()-- Show a boolean environment variable */
193 show_boolean (variable
* v
)
195 st_printf ("%s %s\n", var_source (v
), *v
->var
? "Yes" : "No");
200 init_sep (variable
* v
)
205 p
= getenv (v
->name
);
210 options
.separator
= p
;
211 options
.separator_len
= strlen (p
);
213 /* Make sure the separator is valid */
215 if (options
.separator_len
== 0)
238 options
.separator
= " ";
239 options
.separator_len
= 1;
244 show_sep (variable
* v
)
246 st_printf ("%s \"%s\"\n", var_source (v
), options
.separator
);
251 init_string (variable
* v
__attribute__ ((unused
)))
256 show_string (variable
* v
)
260 p
= getenv (v
->name
);
264 st_printf ("%s \"%s\"\n", var_source (v
), p
);
268 static variable variable_table
[] = {
269 {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER
, &options
.stdin_unit
,
270 init_integer
, show_integer
,
271 "Unit number that will be preconnected to standard input\n"
272 "(No preconnection if negative)", 0},
274 {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER
, &options
.stdout_unit
,
275 init_integer
, show_integer
,
276 "Unit number that will be preconnected to standard output\n"
277 "(No preconnection if negative)", 0},
279 {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER
, &options
.stderr_unit
,
280 init_integer
, show_integer
,
281 "Unit number that will be preconnected to standard error\n"
282 "(No preconnection if negative)", 0},
284 {"GFORTRAN_USE_STDERR", 1, &options
.use_stderr
, init_boolean
,
286 "Sends library output to standard error instead of standard output.", 0},
288 {"GFORTRAN_TMPDIR", 0, NULL
, init_string
, show_string
,
289 "Directory for scratch files. Overrides the TMP environment variable\n"
290 "If TMP is not set " DEFAULT_TEMPDIR
" is used.", 0},
292 {"GFORTRAN_UNBUFFERED_ALL", 0, &options
.all_unbuffered
, init_boolean
,
294 "If TRUE, all output is unbuffered. This will slow down large writes "
295 "but can be\nuseful for forcing data to be displayed immediately.", 0},
297 {"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options
.unbuffered_preconnected
,
298 init_boolean
, show_boolean
,
299 "If TRUE, output to preconnected units is unbuffered.", 0},
301 {"GFORTRAN_SHOW_LOCUS", 1, &options
.locus
, init_boolean
, show_boolean
,
302 "If TRUE, print filename and line number where runtime errors happen.", 0},
304 {"GFORTRAN_OPTIONAL_PLUS", 0, &options
.optional_plus
, init_boolean
, show_boolean
,
305 "Print optional plus signs in numbers where permitted. Default FALSE.", 0},
307 {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL
, &options
.default_recl
,
308 init_unsigned_integer
, show_integer
,
309 "Default maximum record length for sequential files. Most useful for\n"
310 "adjusting line length of preconnected units. Default "
311 stringize (DEFAULT_RECL
), 0},
313 {"GFORTRAN_LIST_SEPARATOR", 0, NULL
, init_sep
, show_sep
,
314 "Separator to use when writing list output. May contain any number of "
315 "spaces\nand at most one comma. Default is a single space.", 0},
317 /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
319 {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted
, show_string
,
320 "Set format for unformatted files", 0},
322 /* Behaviour when encoutering a runtime error. */
323 {"GFORTRAN_ERROR_DUMPCORE", -1, &options
.dump_core
,
324 init_boolean
, show_boolean
,
325 "Dump a core file (if possible) on runtime error", -1},
327 {"GFORTRAN_ERROR_BACKTRACE", -1, &options
.backtrace
,
328 init_boolean
, show_boolean
,
329 "Print out a backtrace (if possible) on runtime error", -1},
331 {NULL
, 0, NULL
, NULL
, NULL
, NULL
, 0}
335 /* init_variables()-- Initialize most runtime variables from
336 * environment variables. */
339 init_variables (void)
343 for (v
= variable_table
; v
->name
; v
++)
349 show_variables (void)
354 /* TODO: print version number. */
355 st_printf ("GNU Fortran 95 runtime library version "
358 st_printf ("Environment variables:\n");
359 st_printf ("----------------------\n");
361 for (v
= variable_table
; v
->name
; v
++)
363 n
= st_printf ("%s", v
->name
);
364 print_spaces (25 - n
);
366 if (v
->show
== show_integer
)
367 st_printf ("Integer ");
368 else if (v
->show
== show_boolean
)
369 st_printf ("Boolean ");
371 st_printf ("String ");
374 st_printf ("%s\n\n", v
->desc
);
377 /* System error codes */
379 st_printf ("\nRuntime error codes:");
380 st_printf ("\n--------------------\n");
382 for (n
= LIBERROR_FIRST
+ 1; n
< LIBERROR_LAST
; n
++)
384 st_printf ("%d %s\n", n
, translate_error (n
));
386 st_printf (" %d %s\n", n
, translate_error (n
));
388 st_printf ("\nCommand line arguments:\n");
389 st_printf (" --help Print this list\n");
391 /* st_printf(" --resume <dropfile> Resume program execution from dropfile\n"); */
396 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
397 It is called from environ.c to parse this variable, and from
398 open.c to determine if the user specified a default for an
400 The syntax of the environment variable is, in bison grammar:
402 GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
403 mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
404 exception: mode ':' unit_list | unit_list ;
405 unit_list: unit_spec | unit_list unit_spec ;
406 unit_spec: INTEGER | INTEGER '-' INTEGER ;
409 /* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
416 /* Some space for additional tokens later. */
428 static char *p
; /* Main character pointer for parsing. */
429 static char *lastpos
; /* Auxiliary pointer, for backing up. */
430 static int unit_num
; /* The last unit number read. */
431 static int unit_count
; /* The number of units found. */
432 static int do_count
; /* Parsing is done twice - first to count the number
433 of units, then to fill in the table. This
434 variable controls what to do. */
435 static exception_t
*elist
; /* The list of exceptions to the default. This is
436 sorted according to unit number. */
437 static int n_elist
; /* Number of exceptions to the default. */
439 static unit_convert endian
; /* Current endianness. */
441 static unit_convert def
; /* Default as specified (if any). */
443 /* Search for a unit number, using a binary search. The
444 first argument is the unit number to search for. The second argument
445 is a pointer to an index.
446 If the unit number is found, the function returns 1, and the index
447 is that of the element.
448 If the unit number is not found, the function returns 0, and the
449 index is the one where the element would be inserted. */
452 search_unit (int unit
, int *ip
)
458 while (high
- low
> 1)
460 mid
= (low
+ high
) / 2;
461 if (unit
<= elist
[mid
].unit
)
467 if (elist
[high
].unit
== unit
)
473 /* This matches a keyword. If it is found, return the token supplied,
474 otherwise return ILLEGAL. */
477 match_word (const char *word
, int tok
)
481 if (strncasecmp (p
, word
, strlen (word
)) == 0)
492 /* Match an integer and store its value in unit_num. This only works
493 if p actually points to the start of an integer. The caller has
501 unit_num
= unit_num
* 10 + (*p
++ - '0');
506 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
507 Returned values are the different tokens. */
531 result
= match_word ("big_endian", BIG
);
536 result
= match_word ("little_endian", LITTLE
);
541 result
= match_word ("native", NATIVE
);
546 result
= match_word ("swap", SWAP
);
549 case '1': case '2': case '3': case '4': case '5':
550 case '6': case '7': case '8': case '9':
551 result
= match_integer ();
561 /* Back up the last token by setting back the character pointer. */
569 /* This is called when a unit is identified. If do_count is nonzero,
570 increment the number of units by one. If do_count is zero,
571 put the unit into the table. */
574 mark_single (int unit
)
583 if (search_unit (unit
, &i
))
585 elist
[unit
].conv
= endian
;
589 for (j
=n_elist
; j
>=i
; j
--)
590 elist
[j
+1] = elist
[j
];
593 elist
[i
].unit
= unit
;
594 elist
[i
].conv
= endian
;
598 /* This is called when a unit range is identified. If do_count is
599 nonzero, increase the number of units. If do_count is zero,
600 put the unit into the table. */
603 mark_range (int unit1
, int unit2
)
607 unit_count
+= abs (unit2
- unit1
) + 1;
611 for (i
=unit2
; i
<=unit1
; i
++)
614 for (i
=unit1
; i
<=unit2
; i
++)
619 /* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
620 twice, once to count the units and once to actually mark them in
621 the table. When counting, we don't check for double occurrences
636 /* Parse the string. First, let's look for a default. */
641 endian
= GFC_CONVERT_NATIVE
;
645 endian
= GFC_CONVERT_SWAP
;
649 endian
= GFC_CONVERT_BIG
;
653 endian
= GFC_CONVERT_LITTLE
;
657 /* A leading digit means that we are looking at an exception.
658 Reset the position to the beginning, and continue processing
659 at the exception list. */
681 /* This isn't a default after all. Reset the position to the
682 beginning, and continue processing at the exception list. */
699 /* Loop over all exceptions. */
706 if (next_token () != ':')
708 endian
= GFC_CONVERT_NATIVE
;
712 if (next_token () != ':')
714 endian
= GFC_CONVERT_SWAP
;
718 if (next_token () != ':')
720 endian
= GFC_CONVERT_LITTLE
;
724 if (next_token () != ':')
726 endian
= GFC_CONVERT_BIG
;
741 /* We arrive here when we want to parse a list of
752 /* The number can be followed by a - and another number,
753 which means that this is a unit range, a comma
757 if (next_token () != INTEGER
)
760 mark_range (unit1
, unit_num
);
789 } while (continue_ulist
);
794 def
= GFC_CONVERT_NONE
;
798 void init_unformatted (variable
* v
)
801 val
= getenv (v
->name
);
802 def
= GFC_CONVERT_NONE
;
817 elist
= get_mem (unit_count
* sizeof (exception_t
));
824 /* Get the default conversion for for an unformatted unit. */
827 get_unformatted_convert (int unit
)
833 else if (search_unit (unit
, &i
))
834 return elist
[i
].conv
;