l4/pkg/libgfortran/lib/contrib/runtime/environ.c

   1 /* Copyright (C) 2002-2015 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 *
  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
  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 *
  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
 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
 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
 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
 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
 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
 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
 261 show_sep (variable * v)
 262 {
 263   st_printf ("%s  \"%s\"\n", var_source (v), options.separator);
 264 }
 265
 266
 267 static void
 268 init_string (variable * v __attribute__ ((unused)))
 269 {
 270 }
 271
 272 static void
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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
 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 }