libgfortran/runtime/environ.c

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