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   st_printf (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   st_printf ("%s  \"%s\"\n", var_source (v), p);
 265 }
 266
 267
 268 static variable variable_table[] = {
 269   {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
 270    init_integer, show_integer,
 271    "Unit number that will be preconnected to standard input\n"
 272    "(No preconnection if negative)", 0},
 273
 274   {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
 275    init_integer, show_integer,
 276    "Unit number that will be preconnected to standard output\n"
 277    "(No preconnection if negative)", 0},
 278
 279   {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
 280    init_integer, show_integer,
 281    "Unit number that will be preconnected to standard error\n"
 282    "(No preconnection if negative)", 0},
 283
 284   {"GFORTRAN_USE_STDERR", 1, &options.use_stderr, init_boolean,
 285    show_boolean,
 286    "Sends library output to standard error instead of standard output.", 0},
 287
 288   {"GFORTRAN_TMPDIR", 0, NULL, init_string, show_string,
 289    "Directory for scratch files.  Overrides the TMP environment variable\n"
 290    "If TMP is not set " DEFAULT_TEMPDIR " is used.", 0},
 291
 292   {"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean,
 293    show_boolean,
 294    "If TRUE, all output is unbuffered.  This will slow down large writes "
 295    "but can be\nuseful for forcing data to be displayed immediately.", 0},
 296
 297   {"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
 298    init_boolean, show_boolean,
 299    "If TRUE, output to preconnected units is unbuffered.", 0},
 300
 301   {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
 302    "If TRUE, print filename and line number where runtime errors happen.", 0},
 303
 304   {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
 305    "Print optional plus signs in numbers where permitted.  Default FALSE.", 0},
 306
 307   {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
 308    init_unsigned_integer, show_integer,
 309    "Default maximum record length for sequential files.  Most useful for\n"
 310    "adjusting line length of preconnected units.  Default "
 311    stringize (DEFAULT_RECL), 0},
 312
 313   {"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
 314    "Separator to use when writing list output.  May contain any number of "
 315    "spaces\nand at most one comma.  Default is a single space.", 0},
 316
 317   /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
 318    unformatted I/O.  */
 319   {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string,
 320    "Set format for unformatted files", 0},
 321
 322   /* Behaviour when encoutering a runtime error.  */
 323   {"GFORTRAN_ERROR_DUMPCORE", -1, &options.dump_core,
 324     init_boolean, show_boolean,
 325     "Dump a core file (if possible) on runtime error", -1},
 326
 327   {"GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace,
 328     init_boolean, show_boolean,
 329     "Print out a backtrace (if possible) on runtime error", -1},
 330
 331   {NULL, 0, NULL, NULL, NULL, NULL, 0}
 332 };
 333
 334
 335 /* init_variables()-- Initialize most runtime variables from
 336  * environment variables. */
 337
 338 void
 339 init_variables (void)
 340 {
 341   variable *v;
 342
 343   for (v = variable_table; v->name; v++)
 344     v->init (v);
 345 }
 346
 347
 348 void
 349 show_variables (void)
 350 {
 351   variable *v;
 352   int n;
 353
 354   /* TODO: print version number.  */
 355   st_printf ("GNU Fortran 95 runtime library version "
 356              "UNKNOWN" "\n\n");
 357
 358   st_printf ("Environment variables:\n");
 359   st_printf ("----------------------\n");
 360
 361   for (v = variable_table; v->name; v++)
 362     {
 363       n = st_printf ("%s", v->name);
 364       print_spaces (25 - n);
 365
 366       if (v->show == show_integer)
 367         st_printf ("Integer ");
 368       else if (v->show == show_boolean)
 369         st_printf ("Boolean ");
 370       else
 371         st_printf ("String  ");
 372
 373       v->show (v);
 374       st_printf ("%s\n\n", v->desc);
 375     }
 376
 377   /* System error codes */
 378
 379   st_printf ("\nRuntime error codes:");
 380   st_printf ("\n--------------------\n");
 381
 382   for (n = LIBERROR_FIRST + 1; n < LIBERROR_LAST; n++)
 383     if (n < 0 || n > 9)
 384       st_printf ("%d  %s\n", n, translate_error (n));
 385     else
 386       st_printf (" %d  %s\n", n, translate_error (n));
 387
 388   st_printf ("\nCommand line arguments:\n");
 389   st_printf ("  --help               Print this list\n");
 390
 391   /* st_printf("  --resume <dropfile>  Resume program execution from dropfile\n"); */
 392
 393   sys_exit (0);
 394 }
 395
 396 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
 397    It is called from environ.c to parse this variable, and from
 398    open.c to determine if the user specified a default for an
 399    unformatted file.
 400    The syntax of the environment variable is, in bison grammar:
 401
 402    GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
 403    mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
 404    exception: mode ':' unit_list | unit_list ;
 405    unit_list: unit_spec | unit_list unit_spec ;
 406    unit_spec: INTEGER | INTEGER '-' INTEGER ;
 407 */
 408
 409 /* Defines for the tokens.  Other valid tokens are ',', ':', '-'.  */
 410
 411
 412 #define NATIVE   257
 413 #define SWAP     258
 414 #define BIG      259
 415 #define LITTLE   260
 416 /* Some space for additional tokens later.  */
 417 #define INTEGER  273
 418 #define END      (-1)
 419 #define ILLEGAL  (-2)
 420
 421 typedef struct
 422 {
 423   int unit;
 424   unit_convert conv;
 425 } exception_t;
 426
 427
 428 static char *p;            /* Main character pointer for parsing.  */
 429 static char *lastpos;      /* Auxiliary pointer, for backing up.  */
 430 static int unit_num;       /* The last unit number read.  */
 431 static int unit_count;     /* The number of units found. */
 432 static int do_count;       /* Parsing is done twice - first to count the number
 433                               of units, then to fill in the table.  This
 434                               variable controls what to do.  */
 435 static exception_t *elist; /* The list of exceptions to the default. This is
 436                               sorted according to unit number.  */
 437 static int n_elist;        /* Number of exceptions to the default.  */
 438
 439 static unit_convert endian; /* Current endianness.  */
 440
 441 static unit_convert def; /* Default as specified (if any).  */
 442
 443 /* Search for a unit number, using a binary search.  The
 444    first argument is the unit number to search for.  The second argument
 445    is a pointer to an index.
 446    If the unit number is found, the function returns 1, and the index
 447    is that of the element.
 448    If the unit number is not found, the function returns 0, and the
 449    index is the one where the element would be inserted.  */
 450
 451 static int
 452 search_unit (int unit, int *ip)
 453 {
 454   int low, high, mid;
 455
 456   low = -1;
 457   high = n_elist;
 458   while (high - low > 1)
 459     {
 460       mid = (low + high) / 2;
 461       if (unit <= elist[mid].unit)
 462         high = mid;
 463       else
 464         low = mid;
 465     }
 466   *ip = high;
 467   if (elist[high].unit == unit)
 468     return 1;
 469   else
 470     return 0;
 471 }
 472
 473 /* This matches a keyword.  If it is found, return the token supplied,
 474    otherwise return ILLEGAL.  */
 475
 476 static int
 477 match_word (const char *word, int tok)
 478 {
 479   int res;
 480
 481   if (strncasecmp (p, word, strlen (word)) == 0)
 482     {
 483       p += strlen (word);
 484       res = tok;
 485     }
 486   else
 487     res = ILLEGAL;
 488   return res;
 489
 490 }
 491
 492 /* Match an integer and store its value in unit_num.  This only works
 493    if p actually points to the start of an integer.  The caller has
 494    to ensure this.  */
 495
 496 static int
 497 match_integer (void)
 498 {
 499   unit_num = 0;
 500   while (isdigit (*p))
 501     unit_num = unit_num * 10 + (*p++ - '0');
 502   return INTEGER;
 503
 504 }
 505
 506 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
 507    Returned values are the different tokens.  */
 508
 509 static int
 510 next_token (void)
 511 {
 512   int result;
 513
 514   lastpos = p;
 515   switch (*p)
 516     {
 517     case '\0':
 518       result = END;
 519       break;
 520
 521     case ':':
 522     case ',':
 523     case '-':
 524     case ';':
 525       result = *p;
 526       p++;
 527       break;
 528
 529     case 'b':
 530     case 'B':
 531       result = match_word ("big_endian", BIG);
 532       break;
 533
 534     case 'l':
 535     case 'L':
 536       result = match_word ("little_endian", LITTLE);
 537       break;
 538
 539     case 'n':
 540     case 'N':
 541       result = match_word ("native", NATIVE);
 542       break;
 543
 544     case 's':
 545     case 'S':
 546       result = match_word ("swap", SWAP);
 547       break;
 548
 549     case '1': case '2': case '3': case '4': case '5':
 550     case '6': case '7': case '8': case '9':
 551       result = match_integer ();
 552       break;
 553
 554     default:
 555       result = ILLEGAL;
 556       break;
 557     }
 558   return result;
 559 }
 560
 561 /* Back up the last token by setting back the character pointer.  */
 562
 563 static void
 564 push_token (void)
 565 {
 566   p = lastpos;
 567 }
 568
 569 /* This is called when a unit is identified.  If do_count is nonzero,
 570    increment the number of units by one.  If do_count is zero,
 571    put the unit into the table.  */
 572
 573 static void
 574 mark_single (int unit)
 575 {
 576   int i,j;
 577
 578   if (do_count)
 579     {
 580       unit_count++;
 581       return;
 582     }
 583   if (search_unit (unit, &i))
 584     {
 585       elist[unit].conv = endian;
 586     }
 587   else
 588     {
 589       for (j=n_elist; j>=i; j--)
 590         elist[j+1] = elist[j];
 591
 592       n_elist += 1;
 593       elist[i].unit = unit;
 594       elist[i].conv = endian;
 595     }
 596 }
 597
 598 /* This is called when a unit range is identified.  If do_count is
 599    nonzero, increase the number of units.  If do_count is zero,
 600    put the unit into the table.  */
 601
 602 static void
 603 mark_range (int unit1, int unit2)
 604 {
 605   int i;
 606   if (do_count)
 607     unit_count += abs (unit2 - unit1) + 1;
 608   else
 609     {
 610       if (unit2 < unit1)
 611         for (i=unit2; i<=unit1; i++)
 612           mark_single (i);
 613       else
 614         for (i=unit1; i<=unit2; i++)
 615           mark_single (i);
 616     }
 617 }
 618
 619 /* Parse the GFORTRAN_CONVERT_UNITS variable.  This is called
 620    twice, once to count the units and once to actually mark them in
 621    the table.  When counting, we don't check for double occurrences
 622    of units.  */
 623
 624 static int
 625 do_parse (void)
 626 {
 627   int tok;
 628   int unit1;
 629   int continue_ulist;
 630   char *start;
 631
 632   unit_count = 0;
 633
 634   start = p;
 635
 636   /* Parse the string.  First, let's look for a default.  */
 637   tok = next_token ();
 638   switch (tok)
 639     {
 640     case NATIVE:
 641       endian = GFC_CONVERT_NATIVE;
 642       break;
 643
 644     case SWAP:
 645       endian = GFC_CONVERT_SWAP;
 646       break;
 647
 648     case BIG:
 649       endian = GFC_CONVERT_BIG;
 650       break;
 651
 652     case LITTLE:
 653       endian = GFC_CONVERT_LITTLE;
 654       break;
 655
 656     case INTEGER:
 657       /* A leading digit means that we are looking at an exception.
 658          Reset the position to the beginning, and continue processing
 659          at the exception list.  */
 660       p = start;
 661       goto exceptions;
 662       break;
 663
 664     case END:
 665       goto end;
 666       break;
 667
 668     default:
 669       goto error;
 670       break;
 671     }
 672
 673   tok = next_token ();
 674   switch (tok)
 675     {
 676     case ';':
 677       def = endian;
 678       break;
 679
 680     case ':':
 681       /* This isn't a default after all.  Reset the position to the
 682          beginning, and continue processing at the exception list.  */
 683       p = start;
 684       goto exceptions;
 685       break;
 686
 687     case END:
 688       def = endian;
 689       goto end;
 690       break;
 691
 692     default:
 693       goto error;
 694       break;
 695     }
 696
 697  exceptions:
 698
 699   /* Loop over all exceptions.  */
 700   while(1)
 701     {
 702       tok = next_token ();
 703       switch (tok)
 704         {
 705         case NATIVE:
 706           if (next_token () != ':')
 707             goto error;
 708           endian = GFC_CONVERT_NATIVE;
 709           break;
 710
 711         case SWAP:
 712           if (next_token () != ':')
 713             goto error;
 714           endian = GFC_CONVERT_SWAP;
 715           break;
 716
 717         case LITTLE:
 718           if (next_token () != ':')
 719             goto error;
 720           endian = GFC_CONVERT_LITTLE;
 721           break;
 722
 723         case BIG:
 724           if (next_token () != ':')
 725             goto error;
 726           endian = GFC_CONVERT_BIG;
 727           break;
 728
 729         case INTEGER:
 730           push_token ();
 731           break;
 732
 733         case END:
 734           goto end;
 735           break;
 736
 737         default:
 738           goto error;
 739           break;
 740         }
 741       /* We arrive here when we want to parse a list of
 742          numbers.  */
 743       continue_ulist = 1;
 744       do
 745         {
 746           tok = next_token ();
 747           if (tok != INTEGER)
 748             goto error;
 749
 750           unit1 = unit_num;
 751           tok = next_token ();
 752           /* The number can be followed by a - and another number,
 753              which means that this is a unit range, a comma
 754              or a semicolon.  */
 755           if (tok == '-')
 756             {
 757               if (next_token () != INTEGER)
 758                 goto error;
 759
 760               mark_range (unit1, unit_num);
 761               tok = next_token ();
 762               if (tok == END)
 763                 goto end;
 764               else if (tok == ';')
 765                 continue_ulist = 0;
 766               else if (tok != ',')
 767                 goto error;
 768             }
 769           else
 770             {
 771               mark_single (unit1);
 772               switch (tok)
 773                 {
 774                 case ';':
 775                   continue_ulist = 0;
 776                   break;
 777
 778                 case ',':
 779                   break;
 780
 781                 case END:
 782                   goto end;
 783                   break;
 784
 785                 default:
 786                   goto error;
 787                 }
 788             }
 789         } while (continue_ulist);
 790     }
 791  end:
 792   return 0;
 793  error:
 794   def = GFC_CONVERT_NONE;
 795   return -1;
 796 }
 797
 798 void init_unformatted (variable * v)
 799 {
 800   char *val;
 801   val = getenv (v->name);
 802   def = GFC_CONVERT_NONE;
 803   n_elist = 0;
 804
 805   if (val == NULL)
 806     return;
 807   do_count = 1;
 808   p = val;
 809   do_parse ();
 810   if (do_count <= 0)
 811     {
 812       n_elist = 0;
 813       elist = NULL;
 814     }
 815   else
 816     {
 817       elist = get_mem (unit_count * sizeof (exception_t));
 818       do_count = 0;
 819       p = val;
 820       do_parse ();
 821     }
 822 }
 823
 824 /* Get the default conversion for for an unformatted unit.  */
 825
 826 unit_convert
 827 get_unformatted_convert (int unit)
 828 {
 829   int i;
 830
 831   if (elist == NULL)
 832     return def;
 833   else if (search_unit (unit, &i))
 834     return elist[i].conv;
 835   else
 836     return def;
 837 }