1 /* Copyright (C) 2002-2023 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 <strings.h>
29
30 #ifdef HAVE_UNISTD_H
31 #include <unistd.h>
32 #endif
33
34
35 /* Implementation of secure_getenv() for targets where it is not
36 provided. */
37
38 #ifdef FALLBACK_SECURE_GETENV
39
40 #if SUPPORTS_WEAKREF && defined(HAVE___SECURE_GETENV)
41 static char* weak_secure_getenv (const char*)
42 __attribute__((__weakref__("__secure_getenv")));
43 #endif
44
45 char *
46 secure_getenv (const char *name)
47 {
48 #if SUPPORTS_WEAKREF && defined(HAVE___SECURE_GETENV)
49 if (weak_secure_getenv)
50 return weak_secure_getenv (name);
51 #endif
52
53 if ((getuid () == geteuid ()) && (getgid () == getegid ()))
54 return getenv (name);
55 else
56 return NULL;
57 }
58 #endif
59
60
61
62 /* Examine the environment for controlling aspects of the program's
63 execution. Our philosophy here that the environment should not prevent
64 the program from running, so any invalid value will be ignored. */
65
66
67 options_t options;
68
69 typedef struct variable
70 {
71 const char *name;
72 int default_value;
73 int *var;
74 void (*init) (struct variable *);
75 }
76 variable;
77
78 static void init_unformatted (variable *);
79
80
81 /* Initialize an integer environment variable. */
82
83 static void
84 init_integer (variable * v)
85 {
86 char *p, *q;
87
88 p = getenv (v->name);
89 if (p == NULL)
90 return;
91
92 for (q = p; *q; q++)
93 if (!safe_isdigit (*q) && (p != q || *q != '-'))
94 return;
95
96 *v->var = atoi (p);
97 }
98
99
100 /* Initialize a boolean environment variable. We only look at the first
101 letter of the value. */
102
103 static void
104 init_boolean (variable * v)
105 {
106 char *p;
107
108 p = getenv (v->name);
109 if (p == NULL)
110 return;
111
112 if (*p == '1' || *p == 'Y' || *p == 'y')
113 *v->var = 1;
114 else if (*p == '0' || *p == 'N' || *p == 'n')
115 *v->var = 0;
116 }
117
118
119 /* Initialize a list output separator. It may contain any number of spaces
120 and at most one comma. */
121
122 static void
123 init_sep (variable * v)
124 {
125 int seen_comma;
126 char *p;
127
128 p = getenv (v->name);
129 if (p == NULL)
130 goto set_default;
131
132 options.separator = p;
133 options.separator_len = strlen (p);
134
135 /* Make sure the separator is valid */
136
137 if (options.separator_len == 0)
138 goto set_default;
139 seen_comma = 0;
140
141 while (*p)
142 {
143 if (*p == ',')
144 {
145 if (seen_comma)
146 goto set_default;
147 seen_comma = 1;
148 p++;
149 continue;
150 }
151
152 if (*p++ != ' ')
153 goto set_default;
154 }
155
156 return;
157
158 set_default:
159 options.separator = " ";
160 options.separator_len = 1;
161 }
162
163
164 static variable variable_table[] = {
165
166 /* Unit number that will be preconnected to standard input */
167 { "GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
168 init_integer },
169
170 /* Unit number that will be preconnected to standard output */
171 { "GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
172 init_integer },
173
174 /* Unit number that will be preconnected to standard error */
175 { "GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
176 init_integer },
177
178 /* If TRUE, all output will be unbuffered */
179 { "GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean },
180
181 /* If TRUE, output to preconnected units will be unbuffered */
182 { "GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
183 init_boolean },
184
185 /* Whether to print filename and line number on runtime error */
186 { "GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean },
187
188 /* Print optional plus signs in numbers where permitted */
189 { "GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean },
190
191 /* Separator to use when writing list output */
192 { "GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep },
193
194 /* Set the default data conversion for unformatted I/O */
195 { "GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted },
196
197 /* Print out a backtrace if possible on runtime error */
198 { "GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace, init_boolean },
199
200 /* Buffer size for unformatted files. */
201 { "GFORTRAN_UNFORMATTED_BUFFER_SIZE", 0, &options.unformatted_buffer_size,
202 init_integer },
203
204 /* Buffer size for formatted files. */
205 { "GFORTRAN_FORMATTED_BUFFER_SIZE", 0, &options.formatted_buffer_size,
206 init_integer },
207
208 { NULL, 0, NULL, NULL }
209 };
210
211
212 /* Initialize most runtime variables from
213 * environment variables. */
214
215 void
216 init_variables (void)
217 {
218 variable *v;
219
220 for (v = variable_table; v->name; v++)
221 {
222 if (v->var)
223 *v->var = v->default_value;
224 v->init (v);
225 }
226 }
227
228
229 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
230 It is called from environ.c to parse this variable, and from
231 open.c to determine if the user specified a default for an
232 unformatted file.
233 The syntax of the environment variable is, in bison grammar:
234
235 GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
236 mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
237 exception: mode ':' unit_list | unit_list ;
238 unit_list: unit_spec | unit_list unit_spec ;
239 unit_spec: INTEGER | INTEGER '-' INTEGER ;
240 */
241
242 /* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
243
244
245 #define NATIVE 257
246 #define SWAP 258
247 #define BIG 259
248 #define LITTLE 260
249 #ifdef HAVE_GFC_REAL_17
250 #define R16_IEEE 261
251 #define R16_IBM 262
252 #endif
253
254 /* Some space for additional tokens later. */
255 #define INTEGER 273
256 #define END (-1)
257 #define ILLEGAL (-2)
258
259 typedef struct
260 {
261 int unit;
262 unit_convert conv;
263 } exception_t;
264
265
266 static char *p; /* Main character pointer for parsing. */
267 static char *lastpos; /* Auxiliary pointer, for backing up. */
268 static int unit_num; /* The last unit number read. */
269 static int unit_count; /* The number of units found. */
270 static int do_count; /* Parsing is done twice - first to count the number
271 of units, then to fill in the table. This
272 variable controls what to do. */
273 static exception_t *elist; /* The list of exceptions to the default. This is
274 sorted according to unit number. */
275 static int n_elist; /* Number of exceptions to the default. */
276
277 static unit_convert endian; /* Current endianness. */
278
279 static unit_convert def; /* Default as specified (if any). */
280
281 /* Search for a unit number, using a binary search. The
282 first argument is the unit number to search for. The second argument
283 is a pointer to an index.
284 If the unit number is found, the function returns 1, and the index
285 is that of the element.
286 If the unit number is not found, the function returns 0, and the
287 index is the one where the element would be inserted. */
288
289 static int
290 search_unit (int unit, int *ip)
291 {
292 int low, high, mid;
293
294 if (n_elist == 0)
295 {
296 *ip = 0;
297 return 0;
298 }
299
300 low = 0;
301 high = n_elist - 1;
302
303 do
304 {
305 mid = (low + high) / 2;
306 if (unit == elist[mid].unit)
307 {
308 *ip = mid;
309 return 1;
310 }
311 else if (unit > elist[mid].unit)
312 low = mid + 1;
313 else
314 high = mid - 1;
315 } while (low <= high);
316
317 if (unit > elist[mid].unit)
318 *ip = mid + 1;
319 else
320 *ip = mid;
321
322 return 0;
323 }
324
325 /* This matches a keyword. If it is found, return the token supplied,
326 otherwise return ILLEGAL. */
327
328 static int
329 match_word (const char *word, int tok)
330 {
331 int res;
332
333 if (strncasecmp (p, word, strlen (word)) == 0)
334 {
335 p += strlen (word);
336 res = tok;
337 }
338 else
339 res = ILLEGAL;
340 return res;
341 }
342
343 /* Match an integer and store its value in unit_num. This only works
344 if p actually points to the start of an integer. The caller has
345 to ensure this. */
346
347 static int
348 match_integer (void)
349 {
350 unit_num = 0;
351 while (safe_isdigit (*p))
352 unit_num = unit_num * 10 + (*p++ - '0');
353 return INTEGER;
354 }
355
356 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
357 Returned values are the different tokens. */
358
359 static int
360 next_token (void)
361 {
362 int result;
363
364 lastpos = p;
365 switch (*p)
366 {
367 case '\0':
368 result = END;
369 break;
370
371 case ':':
372 case ',':
373 case '-':
374 case ';':
375 result = *p;
376 p++;
377 break;
378
379 case 'b':
380 case 'B':
381 result = match_word ("big_endian", BIG);
382 break;
383
384 case 'l':
385 case 'L':
386 result = match_word ("little_endian", LITTLE);
387 break;
388
389 case 'n':
390 case 'N':
391 result = match_word ("native", NATIVE);
392 break;
393
394 case 's':
395 case 'S':
396 result = match_word ("swap", SWAP);
397 break;
398
399 #ifdef HAVE_GFC_REAL_17
400 case 'r':
401 case 'R':
402 result = match_word ("r16_ieee", R16_IEEE);
403 if (result == ILLEGAL)
404 result = match_word ("r16_ibm", R16_IBM);
405 break;
406
407 #endif
408 case '1': case '2': case '3': case '4': case '5':
409 case '6': case '7': case '8': case '9':
410 result = match_integer ();
411 break;
412
413 default:
414 result = ILLEGAL;
415 break;
416 }
417 return result;
418 }
419
420 /* Back up the last token by setting back the character pointer. */
421
422 static void
423 push_token (void)
424 {
425 p = lastpos;
426 }
427
428 /* This is called when a unit is identified. If do_count is nonzero,
429 increment the number of units by one. If do_count is zero,
430 put the unit into the table. For POWER, we have to make sure that
431 we can also put in the conversion btween IBM and IEEE long double. */
432
433 static void
434 mark_single (int unit)
435 {
436 int i,j;
437
438 if (do_count)
439 {
440 unit_count++;
441 return;
442 }
443 if (search_unit (unit, &i))
444 {
445 #ifdef HAVE_GFC_REAL_17
446 elist[i].conv |= endian;
447 #else
448 elist[i].conv = endian;
449 #endif
450 }
451 else
452 {
453 for (j=n_elist-1; j>=i; j--)
454 elist[j+1] = elist[j];
455
456 n_elist += 1;
457 elist[i].unit = unit;
458 #ifdef HAVE_GFC_REAL_17
459 elist[i].conv |= endian;
460 #else
461 elist[i].conv = endian;
462 #endif
463 }
464 }
465
466 /* This is called when a unit range is identified. If do_count is
467 nonzero, increase the number of units. If do_count is zero,
468 put the unit into the table. */
469
470 static void
471 mark_range (int unit1, int unit2)
472 {
473 int i;
474 if (do_count)
475 unit_count += abs (unit2 - unit1) + 1;
476 else
477 {
478 if (unit2 < unit1)
479 for (i=unit2; i<=unit1; i++)
480 mark_single (i);
481 else
482 for (i=unit1; i<=unit2; i++)
483 mark_single (i);
484 }
485 }
486
487 /* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
488 twice, once to count the units and once to actually mark them in
489 the table. When counting, we don't check for double occurrences
490 of units. */
491
492 static int
493 do_parse (void)
494 {
495 int tok;
496 int unit1;
497 int continue_ulist;
498 char *start;
499
500 unit_count = 0;
501
502 /* Parse the string. First, let's look for a default. */
503 endian = 0;
504 while (1)
505 {
506 start = p;
507 tok = next_token ();
508 switch (tok)
509 {
510 case NATIVE:
511 endian = GFC_CONVERT_NATIVE;
512 break;
513
514 case SWAP:
515 endian = GFC_CONVERT_SWAP;
516 break;
517
518 case BIG:
519 endian = GFC_CONVERT_BIG;
520 break;
521
522 case LITTLE:
523 endian = GFC_CONVERT_LITTLE;
524 break;
525
526 #ifdef HAVE_GFC_REAL_17
527 case R16_IEEE:
528 endian = GFC_CONVERT_R16_IEEE;
529 break;
530
531 case R16_IBM:
532 endian = GFC_CONVERT_R16_IBM;
533 break;
534 #endif
535 case INTEGER:
536 /* A leading digit means that we are looking at an exception.
537 Reset the position to the beginning, and continue processing
538 at the exception list. */
539 p = start;
540 goto exceptions;
541 break;
542
543 case END:
544 goto end;
545 break;
546
547 default:
548 goto error;
549 break;
550 }
551
552 tok = next_token ();
553 switch (tok)
554 {
555 case ';':
556 def = def == GFC_CONVERT_NONE ? endian : def | endian;
557 break;
558
559 case ':':
560 /* This isn't a default after all. Reset the position to the
561 beginning, and continue processing at the exception list. */
562 p = start;
563 goto exceptions;
564 break;
565
566 case END:
567 def = def == GFC_CONVERT_NONE ? endian : def | endian;
568 goto end;
569 break;
570
571 default:
572 goto error;
573 break;
574 }
575 }
576
577 exceptions:
578
579 /* Loop over all exceptions. */
580 while(1)
581 {
582 tok = next_token ();
583 switch (tok)
584 {
585 case NATIVE:
586 if (next_token () != ':')
587 goto error;
588 endian = GFC_CONVERT_NATIVE;
589 break;
590
591 case SWAP:
592 if (next_token () != ':')
593 goto error;
594 endian = GFC_CONVERT_SWAP;
595 break;
596
597 case LITTLE:
598 if (next_token () != ':')
599 goto error;
600 endian = GFC_CONVERT_LITTLE;
601 break;
602
603 case BIG:
604 if (next_token () != ':')
605 goto error;
606 endian = GFC_CONVERT_BIG;
607 break;
608 #ifdef HAVE_GFC_REAL_17
609 case R16_IEEE:
610 if (next_token () != ':')
611 goto error;
612 endian = GFC_CONVERT_R16_IEEE;
613 break;
614
615 case R16_IBM:
616 if (next_token () != ':')
617 goto error;
618 endian = GFC_CONVERT_R16_IBM;
619 break;
620 #endif
621
622 case INTEGER:
623 push_token ();
624 break;
625
626 case END:
627 goto end;
628 break;
629
630 default:
631 goto error;
632 break;
633 }
634 /* We arrive here when we want to parse a list of
635 numbers. */
636 continue_ulist = 1;
637 do
638 {
639 tok = next_token ();
640 if (tok != INTEGER)
641 goto error;
642
643 unit1 = unit_num;
644 tok = next_token ();
645 /* The number can be followed by a - and another number,
646 which means that this is a unit range, a comma
647 or a semicolon. */
648 if (tok == '-')
649 {
650 if (next_token () != INTEGER)
651 goto error;
652
653 mark_range (unit1, unit_num);
654 tok = next_token ();
655 if (tok == END)
656 goto end;
657 else if (tok == ';')
658 continue_ulist = 0;
659 else if (tok != ',')
660 goto error;
661 }
662 else
663 {
664 mark_single (unit1);
665 switch (tok)
666 {
667 case ';':
668 continue_ulist = 0;
669 break;
670
671 case ',':
672 break;
673
674 case END:
675 goto end;
676 break;
677
678 default:
679 goto error;
680 }
681 }
682 } while (continue_ulist);
683 }
684 end:
685 return 0;
686 error:
687 def = GFC_CONVERT_NONE;
688 return -1;
689 }
690
691 void init_unformatted (variable * v)
692 {
693 char *val;
694 val = getenv (v->name);
695 def = GFC_CONVERT_NONE;
696 n_elist = 0;
697
698 if (val == NULL)
699 return;
700 do_count = 1;
701 p = val;
702 do_parse ();
703 if (do_count <= 0)
704 {
705 n_elist = 0;
706 elist = NULL;
707 }
708 else
709 {
710 elist = xmallocarray (unit_count, sizeof (exception_t));
711 do_count = 0;
712 p = val;
713 do_parse ();
714 }
715 }
716
717 /* Get the default conversion for for an unformatted unit. */
718
719 unit_convert
720 get_unformatted_convert (int unit)
721 {
722 int i;
723
724 if (elist == NULL)
725 return def;
726 else if (search_unit (unit, &i))
727 return elist[i].conv;
728 else
729 return def;
730 }