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