1 /* Copyright (C) 2002-2022 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 } 731