1 /* Copyright (C) 2002-2014 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3
4 This file is part of the GNU Fortran runtime library (libgfortran).
5
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)
9 any later version.
10
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.
15
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.
19
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/>. */
24
25 #include "libgfortran.h"
26
27 #include <string.h>
28 #include <stdlib.h>
29 #include <ctype.h>
30
31 #ifdef HAVE_UNISTD_H
32 #include <unistd.h>
33 #endif
34
35
36 /* Environment scanner. Examine the environment for controlling minor
37 * aspects of the program's execution. Our philosophy here that the
38 * environment should not prevent the program from running, so an
39 * environment variable with a messed-up value will be interpreted in
40 * the default way.
41 *
42 * Most of the environment is checked early in the startup sequence,
43 * but other variables are checked during execution of the user's
44 * program. */
45
46 options_t options;
47
48
49 typedef struct variable
50 {
51 const char *name;
52 int value, *var;
53 void (*init) (struct variable *);
54 void (*show) (struct variable *);
55 const char *desc;
56 int bad;
57 }
58 variable;
59
60 static void init_unformatted (variable *);
61
62
63 #ifdef FALLBACK_SECURE_GETENV
64 char *
secure_getenv(const char * name)65 secure_getenv (const char *name)
66 {
67 if ((getuid () == geteuid ()) && (getgid () == getegid ()))
68 return getenv (name);
69 else
70 return NULL;
71 }
72 #endif
73
74
75 /* print_spaces()-- Print a particular number of spaces. */
76
77 static void
print_spaces(int n)78 print_spaces (int n)
79 {
80 char buffer[80];
81 int i;
82
83 if (n <= 0)
84 return;
85
86 for (i = 0; i < n; i++)
87 buffer[i] = ' ';
88
89 buffer[i] = '\0';
90
91 estr_write (buffer);
92 }
93
94
95 /* var_source()-- Return a string that describes where the value of a
96 * variable comes from */
97
98 static const char *
var_source(variable * v)99 var_source (variable * v)
100 {
101 if (getenv (v->name) == NULL)
102 return "Default";
103
104 if (v->bad)
105 return "Bad ";
106
107 return "Set ";
108 }
109
110
111 /* init_integer()-- Initialize an integer environment variable. */
112
113 static void
init_integer(variable * v)114 init_integer (variable * v)
115 {
116 char *p, *q;
117
118 p = getenv (v->name);
119 if (p == NULL)
120 goto set_default;
121
122 for (q = p; *q; q++)
123 if (!isdigit (*q) && (p != q || *q != '-'))
124 {
125 v->bad = 1;
126 goto set_default;
127 }
128
129 *v->var = atoi (p);
130 return;
131
132 set_default:
133 *v->var = v->value;
134 return;
135 }
136
137
138 /* init_unsigned_integer()-- Initialize an integer environment variable
139 which has to be positive. */
140
141 static void
init_unsigned_integer(variable * v)142 init_unsigned_integer (variable * v)
143 {
144 char *p, *q;
145
146 p = getenv (v->name);
147 if (p == NULL)
148 goto set_default;
149
150 for (q = p; *q; q++)
151 if (!isdigit (*q))
152 {
153 v->bad = 1;
154 goto set_default;
155 }
156
157 *v->var = atoi (p);
158 return;
159
160 set_default:
161 *v->var = v->value;
162 return;
163 }
164
165
166 /* show_integer()-- Show an integer environment variable */
167
168 static void
show_integer(variable * v)169 show_integer (variable * v)
170 {
171 st_printf ("%s %d\n", var_source (v), *v->var);
172 }
173
174
175 /* init_boolean()-- Initialize a boolean environment variable. We
176 * only look at the first letter of the variable. */
177
178 static void
init_boolean(variable * v)179 init_boolean (variable * v)
180 {
181 char *p;
182
183 p = getenv (v->name);
184 if (p == NULL)
185 goto set_default;
186
187 if (*p == '1' || *p == 'Y' || *p == 'y')
188 {
189 *v->var = 1;
190 return;
191 }
192
193 if (*p == '0' || *p == 'N' || *p == 'n')
194 {
195 *v->var = 0;
196 return;
197 }
198
199 v->bad = 1;
200
201 set_default:
202 *v->var = v->value;
203 return;
204 }
205
206
207 /* show_boolean()-- Show a boolean environment variable */
208
209 static void
show_boolean(variable * v)210 show_boolean (variable * v)
211 {
212 st_printf ("%s %s\n", var_source (v), *v->var ? "Yes" : "No");
213 }
214
215
216 static void
init_sep(variable * v)217 init_sep (variable * v)
218 {
219 int seen_comma;
220 char *p;
221
222 p = getenv (v->name);
223 if (p == NULL)
224 goto set_default;
225
226 v->bad = 1;
227 options.separator = p;
228 options.separator_len = strlen (p);
229
230 /* Make sure the separator is valid */
231
232 if (options.separator_len == 0)
233 goto set_default;
234 seen_comma = 0;
235
236 while (*p)
237 {
238 if (*p == ',')
239 {
240 if (seen_comma)
241 goto set_default;
242 seen_comma = 1;
243 p++;
244 continue;
245 }
246
247 if (*p++ != ' ')
248 goto set_default;
249 }
250
251 v->bad = 0;
252 return;
253
254 set_default:
255 options.separator = " ";
256 options.separator_len = 1;
257 }
258
259
260 static void
show_sep(variable * v)261 show_sep (variable * v)
262 {
263 st_printf ("%s \"%s\"\n", var_source (v), options.separator);
264 }
265
266
267 static void
init_string(variable * v)268 init_string (variable * v __attribute__ ((unused)))
269 {
270 }
271
272 static void
show_string(variable * v)273 show_string (variable * v)
274 {
275 const char *p;
276
277 p = getenv (v->name);
278 if (p == NULL)
279 p = "";
280
281 estr_write (var_source (v));
282 estr_write (" \"");
283 estr_write (p);
284 estr_write ("\"\n");
285 }
286
287
288 static variable variable_table[] = {
289 {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
290 init_integer, show_integer,
291 "Unit number that will be preconnected to standard input\n"
292 "(No preconnection if negative)", 0},
293
294 {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
295 init_integer, show_integer,
296 "Unit number that will be preconnected to standard output\n"
297 "(No preconnection if negative)", 0},
298
299 {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
300 init_integer, show_integer,
301 "Unit number that will be preconnected to standard error\n"
302 "(No preconnection if negative)", 0},
303
304 {"TMPDIR", 0, NULL, init_string, show_string,
305 "Directory for scratch files.", 0},
306
307 {"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean,
308 show_boolean,
309 "If TRUE, all output is unbuffered. This will slow down large writes "
310 "but can be\nuseful for forcing data to be displayed immediately.", 0},
311
312 {"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
313 init_boolean, show_boolean,
314 "If TRUE, output to preconnected units is unbuffered.", 0},
315
316 {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
317 "If TRUE, print filename and line number where runtime errors happen.", 0},
318
319 {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
320 "Print optional plus signs in numbers where permitted. Default FALSE.", 0},
321
322 {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
323 init_unsigned_integer, show_integer,
324 "Default maximum record length for sequential files. Most useful for\n"
325 "adjusting line length of preconnected units. Default "
326 stringize (DEFAULT_RECL), 0},
327
328 {"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
329 "Separator to use when writing list output. May contain any number of "
330 "spaces\nand at most one comma. Default is a single space.", 0},
331
332 /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
333 unformatted I/O. */
334 {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string,
335 "Set format for unformatted files", 0},
336
337 {"GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace,
338 init_boolean, show_boolean,
339 "Print out a backtrace (if possible) on runtime error", -1},
340
341 {NULL, 0, NULL, NULL, NULL, NULL, 0}
342 };
343
344
345 /* init_variables()-- Initialize most runtime variables from
346 * environment variables. */
347
348 void
init_variables(void)349 init_variables (void)
350 {
351 variable *v;
352
353 for (v = variable_table; v->name; v++)
354 v->init (v);
355 }
356
357
358 void
show_variables(void)359 show_variables (void)
360 {
361 variable *v;
362 int n;
363
364 /* TODO: print version number. */
365 estr_write ("GNU Fortran runtime library version "
366 "UNKNOWN" "\n\n");
367
368 estr_write ("Environment variables:\n");
369 estr_write ("----------------------\n");
370
371 for (v = variable_table; v->name; v++)
372 {
373 n = estr_write (v->name);
374 print_spaces (25 - n);
375
376 if (v->show == show_integer)
377 estr_write ("Integer ");
378 else if (v->show == show_boolean)
379 estr_write ("Boolean ");
380 else
381 estr_write ("String ");
382
383 v->show (v);
384 estr_write (v->desc);
385 estr_write ("\n\n");
386 }
387
388 /* System error codes */
389
390 estr_write ("\nRuntime error codes:");
391 estr_write ("\n--------------------\n");
392
393 for (n = LIBERROR_FIRST + 1; n < LIBERROR_LAST; n++)
394 if (n < 0 || n > 9)
395 st_printf ("%d %s\n", n, translate_error (n));
396 else
397 st_printf (" %d %s\n", n, translate_error (n));
398
399 estr_write ("\nCommand line arguments:\n");
400 estr_write (" --help Print this list\n");
401
402 exit (0);
403 }
404
405 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
406 It is called from environ.c to parse this variable, and from
407 open.c to determine if the user specified a default for an
408 unformatted file.
409 The syntax of the environment variable is, in bison grammar:
410
411 GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
412 mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
413 exception: mode ':' unit_list | unit_list ;
414 unit_list: unit_spec | unit_list unit_spec ;
415 unit_spec: INTEGER | INTEGER '-' INTEGER ;
416 */
417
418 /* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
419
420
421 #define NATIVE 257
422 #define SWAP 258
423 #define BIG 259
424 #define LITTLE 260
425 /* Some space for additional tokens later. */
426 #define INTEGER 273
427 #define END (-1)
428 #define ILLEGAL (-2)
429
430 typedef struct
431 {
432 int unit;
433 unit_convert conv;
434 } exception_t;
435
436
437 static char *p; /* Main character pointer for parsing. */
438 static char *lastpos; /* Auxiliary pointer, for backing up. */
439 static int unit_num; /* The last unit number read. */
440 static int unit_count; /* The number of units found. */
441 static int do_count; /* Parsing is done twice - first to count the number
442 of units, then to fill in the table. This
443 variable controls what to do. */
444 static exception_t *elist; /* The list of exceptions to the default. This is
445 sorted according to unit number. */
446 static int n_elist; /* Number of exceptions to the default. */
447
448 static unit_convert endian; /* Current endianness. */
449
450 static unit_convert def; /* Default as specified (if any). */
451
452 /* Search for a unit number, using a binary search. The
453 first argument is the unit number to search for. The second argument
454 is a pointer to an index.
455 If the unit number is found, the function returns 1, and the index
456 is that of the element.
457 If the unit number is not found, the function returns 0, and the
458 index is the one where the element would be inserted. */
459
460 static int
search_unit(int unit,int * ip)461 search_unit (int unit, int *ip)
462 {
463 int low, high, mid;
464
465 if (n_elist == 0)
466 {
467 *ip = 0;
468 return 0;
469 }
470
471 low = 0;
472 high = n_elist - 1;
473
474 do
475 {
476 mid = (low + high) / 2;
477 if (unit == elist[mid].unit)
478 {
479 *ip = mid;
480 return 1;
481 }
482 else if (unit > elist[mid].unit)
483 low = mid + 1;
484 else
485 high = mid - 1;
486 } while (low <= high);
487
488 if (unit > elist[mid].unit)
489 *ip = mid + 1;
490 else
491 *ip = mid;
492
493 return 0;
494 }
495
496 /* This matches a keyword. If it is found, return the token supplied,
497 otherwise return ILLEGAL. */
498
499 static int
match_word(const char * word,int tok)500 match_word (const char *word, int tok)
501 {
502 int res;
503
504 if (strncasecmp (p, word, strlen (word)) == 0)
505 {
506 p += strlen (word);
507 res = tok;
508 }
509 else
510 res = ILLEGAL;
511 return res;
512
513 }
514
515 /* Match an integer and store its value in unit_num. This only works
516 if p actually points to the start of an integer. The caller has
517 to ensure this. */
518
519 static int
match_integer(void)520 match_integer (void)
521 {
522 unit_num = 0;
523 while (isdigit (*p))
524 unit_num = unit_num * 10 + (*p++ - '0');
525 return INTEGER;
526
527 }
528
529 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
530 Returned values are the different tokens. */
531
532 static int
next_token(void)533 next_token (void)
534 {
535 int result;
536
537 lastpos = p;
538 switch (*p)
539 {
540 case '\0':
541 result = END;
542 break;
543
544 case ':':
545 case ',':
546 case '-':
547 case ';':
548 result = *p;
549 p++;
550 break;
551
552 case 'b':
553 case 'B':
554 result = match_word ("big_endian", BIG);
555 break;
556
557 case 'l':
558 case 'L':
559 result = match_word ("little_endian", LITTLE);
560 break;
561
562 case 'n':
563 case 'N':
564 result = match_word ("native", NATIVE);
565 break;
566
567 case 's':
568 case 'S':
569 result = match_word ("swap", SWAP);
570 break;
571
572 case '1': case '2': case '3': case '4': case '5':
573 case '6': case '7': case '8': case '9':
574 result = match_integer ();
575 break;
576
577 default:
578 result = ILLEGAL;
579 break;
580 }
581 return result;
582 }
583
584 /* Back up the last token by setting back the character pointer. */
585
586 static void
push_token(void)587 push_token (void)
588 {
589 p = lastpos;
590 }
591
592 /* This is called when a unit is identified. If do_count is nonzero,
593 increment the number of units by one. If do_count is zero,
594 put the unit into the table. */
595
596 static void
mark_single(int unit)597 mark_single (int unit)
598 {
599 int i,j;
600
601 if (do_count)
602 {
603 unit_count++;
604 return;
605 }
606 if (search_unit (unit, &i))
607 {
608 elist[i].conv = endian;
609 }
610 else
611 {
612 for (j=n_elist-1; j>=i; j--)
613 elist[j+1] = elist[j];
614
615 n_elist += 1;
616 elist[i].unit = unit;
617 elist[i].conv = endian;
618 }
619 }
620
621 /* This is called when a unit range is identified. If do_count is
622 nonzero, increase the number of units. If do_count is zero,
623 put the unit into the table. */
624
625 static void
mark_range(int unit1,int unit2)626 mark_range (int unit1, int unit2)
627 {
628 int i;
629 if (do_count)
630 unit_count += abs (unit2 - unit1) + 1;
631 else
632 {
633 if (unit2 < unit1)
634 for (i=unit2; i<=unit1; i++)
635 mark_single (i);
636 else
637 for (i=unit1; i<=unit2; i++)
638 mark_single (i);
639 }
640 }
641
642 /* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
643 twice, once to count the units and once to actually mark them in
644 the table. When counting, we don't check for double occurrences
645 of units. */
646
647 static int
do_parse(void)648 do_parse (void)
649 {
650 int tok;
651 int unit1;
652 int continue_ulist;
653 char *start;
654
655 unit_count = 0;
656
657 start = p;
658
659 /* Parse the string. First, let's look for a default. */
660 tok = next_token ();
661 switch (tok)
662 {
663 case NATIVE:
664 endian = GFC_CONVERT_NATIVE;
665 break;
666
667 case SWAP:
668 endian = GFC_CONVERT_SWAP;
669 break;
670
671 case BIG:
672 endian = GFC_CONVERT_BIG;
673 break;
674
675 case LITTLE:
676 endian = GFC_CONVERT_LITTLE;
677 break;
678
679 case INTEGER:
680 /* A leading digit means that we are looking at an exception.
681 Reset the position to the beginning, and continue processing
682 at the exception list. */
683 p = start;
684 goto exceptions;
685 break;
686
687 case END:
688 goto end;
689 break;
690
691 default:
692 goto error;
693 break;
694 }
695
696 tok = next_token ();
697 switch (tok)
698 {
699 case ';':
700 def = endian;
701 break;
702
703 case ':':
704 /* This isn't a default after all. Reset the position to the
705 beginning, and continue processing at the exception list. */
706 p = start;
707 goto exceptions;
708 break;
709
710 case END:
711 def = endian;
712 goto end;
713 break;
714
715 default:
716 goto error;
717 break;
718 }
719
720 exceptions:
721
722 /* Loop over all exceptions. */
723 while(1)
724 {
725 tok = next_token ();
726 switch (tok)
727 {
728 case NATIVE:
729 if (next_token () != ':')
730 goto error;
731 endian = GFC_CONVERT_NATIVE;
732 break;
733
734 case SWAP:
735 if (next_token () != ':')
736 goto error;
737 endian = GFC_CONVERT_SWAP;
738 break;
739
740 case LITTLE:
741 if (next_token () != ':')
742 goto error;
743 endian = GFC_CONVERT_LITTLE;
744 break;
745
746 case BIG:
747 if (next_token () != ':')
748 goto error;
749 endian = GFC_CONVERT_BIG;
750 break;
751
752 case INTEGER:
753 push_token ();
754 break;
755
756 case END:
757 goto end;
758 break;
759
760 default:
761 goto error;
762 break;
763 }
764 /* We arrive here when we want to parse a list of
765 numbers. */
766 continue_ulist = 1;
767 do
768 {
769 tok = next_token ();
770 if (tok != INTEGER)
771 goto error;
772
773 unit1 = unit_num;
774 tok = next_token ();
775 /* The number can be followed by a - and another number,
776 which means that this is a unit range, a comma
777 or a semicolon. */
778 if (tok == '-')
779 {
780 if (next_token () != INTEGER)
781 goto error;
782
783 mark_range (unit1, unit_num);
784 tok = next_token ();
785 if (tok == END)
786 goto end;
787 else if (tok == ';')
788 continue_ulist = 0;
789 else if (tok != ',')
790 goto error;
791 }
792 else
793 {
794 mark_single (unit1);
795 switch (tok)
796 {
797 case ';':
798 continue_ulist = 0;
799 break;
800
801 case ',':
802 break;
803
804 case END:
805 goto end;
806 break;
807
808 default:
809 goto error;
810 }
811 }
812 } while (continue_ulist);
813 }
814 end:
815 return 0;
816 error:
817 def = GFC_CONVERT_NONE;
818 return -1;
819 }
820
init_unformatted(variable * v)821 void init_unformatted (variable * v)
822 {
823 char *val;
824 val = getenv (v->name);
825 def = GFC_CONVERT_NONE;
826 n_elist = 0;
827
828 if (val == NULL)
829 return;
830 do_count = 1;
831 p = val;
832 do_parse ();
833 if (do_count <= 0)
834 {
835 n_elist = 0;
836 elist = NULL;
837 }
838 else
839 {
840 elist = xmallocarray (unit_count, sizeof (exception_t));
841 do_count = 0;
842 p = val;
843 do_parse ();
844 }
845 }
846
847 /* Get the default conversion for for an unformatted unit. */
848
849 unit_convert
get_unformatted_convert(int unit)850 get_unformatted_convert (int unit)
851 {
852 int i;
853
854 if (elist == NULL)
855 return def;
856 else if (search_unit (unit, &i))
857 return elist[i].conv;
858 else
859 return def;
860 }
861