libgfortran/runtime/environ.c

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