libgfortran/runtime/environ.c

   1 /* Copyright (C) 2002-2003 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, 59 Temple Place - Suite 330,
  28 Boston, MA 02111-1307, USA.  */
  29
  30 #include "config.h"
  31 #include <string.h>
  32 #include <stdlib.h>
  33 #include <ctype.h>
  34
  35 #include "libgfortran.h"
  36 #include "../io/io.h"
  37
  38
  39 /* Environment scanner.  Examine the environment for controlling minor
  40  * aspects of the program's execution.  Our philosophy here that the
  41  * environment should not prevent the program from running, so an
  42  * environment variable with a messed-up value will be interpreted in
  43  * the default way.
  44  *
  45  * Most of the environment is checked early in the startup sequence,
  46  * but other variables are checked during execution of the user's
  47  * program. */
  48
  49 options_t options = { };
  50
  51 extern char **environ;
  52
  53 typedef struct variable
  54 {
  55   const char *name;
  56   int value, *var;
  57   void (*init) (struct variable *);
  58   void (*show) (struct variable *);
  59   const char *desc;
  60   int bad;
  61 }
  62 variable;
  63
  64
  65 /* print_spaces()-- Print a particular number of spaces */
  66
  67 static void
  68 print_spaces (int n)
  69 {
  70   char buffer[80];
  71   int i;
  72
  73   if (n <= 0)
  74     return;
  75
  76   for (i = 0; i < n; i++)
  77     buffer[i] = ' ';
  78
  79   buffer[i] = '\0';
  80
  81   st_printf (buffer);
  82 }
  83
  84
  85 /* var_source()-- Return a string that describes where the value of a
  86  * variable comes from */
  87
  88 static const char *
  89 var_source (variable * v)
  90 {
  91   if (getenv (v->name) == NULL)
  92     return "Default";
  93
  94   if (v->bad)
  95     return "Bad    ";
  96
  97   return "Set    ";
  98 }
  99
 100
 101 /* init_integer()-- Initialize an integer environment variable */
 102
 103 static void
 104 init_integer (variable * v)
 105 {
 106   char *p, *q;
 107
 108   p = getenv (v->name);
 109   if (p == NULL)
 110     goto set_default;
 111
 112   for (q = p; *q; q++)
 113     if (!isdigit (*q))
 114       {
 115         v->bad = 1;
 116         goto set_default;
 117       }
 118
 119   *v->var = atoi (p);
 120   return;
 121
 122  set_default:
 123   *v->var = v->value;
 124   return;
 125 }
 126
 127
 128 /* show_integer()-- Show an integer environment variable */
 129
 130 static void
 131 show_integer (variable * v)
 132 {
 133   st_printf ("%s  %d\n", var_source (v), *v->var);
 134 }
 135
 136
 137 /* init_boolean()-- Initialize a boolean environment variable.  We
 138  * only look at the first letter of the variable. */
 139
 140 static void
 141 init_boolean (variable * v)
 142 {
 143   char *p;
 144
 145   p = getenv (v->name);
 146   if (p == NULL)
 147     goto set_default;
 148
 149   if (*p == '1' || *p == 'Y' || *p == 'y')
 150     {
 151       *v->var = 1;
 152       return;
 153     }
 154
 155   if (*p == '0' || *p == 'N' || *p == 'n')
 156     {
 157       *v->var = 0;
 158       return;
 159     }
 160
 161   v->bad = 1;
 162
 163 set_default:
 164   *v->var = v->value;
 165   return;
 166 }
 167
 168
 169 /* show_boolean()-- Show a boolean environment variable */
 170
 171 static void
 172 show_boolean (variable * v)
 173 {
 174   st_printf ("%s  %s\n", var_source (v), *v->var ? "Yes" : "No");
 175 }
 176
 177
 178 /* init_mem()-- Initialize environment variables that have to do with
 179  * how memory from an ALLOCATE statement is filled.  A single flag
 180  * enables filling and a second variable gives the value that is used
 181  * to initialize the memory. */
 182
 183 static void
 184 init_mem (variable * v)
 185 {
 186   int offset, n;
 187   char *p;
 188
 189   p = getenv (v->name);
 190
 191   options.allocate_init_flag = 0;       /* The default */
 192
 193   if (p == NULL)
 194     return;
 195
 196   if (strcasecmp (p, "NONE") == 0)
 197     return;
 198
 199   /* IEEE-754 Quiet Not-a-Number that will work for single and double
 200    * precision.  Look for the 'f95' mantissa in debug dumps. */
 201
 202   if (strcasecmp (p, "NaN") == 0)
 203     {
 204       options.allocate_init_flag = 1;
 205       options.allocate_init_value = 0xfff80f95;
 206       return;
 207     }
 208
 209   /* Interpret the string as a hexadecimal constant */
 210
 211   n = 0;
 212   while (*p)
 213     {
 214       if (!isxdigit (*p))
 215         {
 216           v->bad = 1;
 217           return;
 218         }
 219
 220       offset = '0';
 221       if (islower (*p))
 222         offset = 'a';
 223       if (isupper (*p))
 224         offset = 'A';
 225
 226       n = (n << 4) | (*p++ - offset);
 227     }
 228
 229   options.allocate_init_flag = 1;
 230   options.allocate_init_value = n;
 231 }
 232
 233
 234 static void
 235 show_mem (variable * v)
 236 {
 237   char *p;
 238
 239   p = getenv (v->name);
 240
 241   st_printf ("%s  ", var_source (v));
 242
 243   if (options.allocate_init_flag)
 244     st_printf ("0x%x", options.allocate_init_value);
 245
 246   st_printf ("\n");
 247 }
 248
 249
 250 static void
 251 init_sep (variable * v)
 252 {
 253   int seen_comma;
 254   char *p;
 255
 256   p = getenv (v->name);
 257   if (p == NULL)
 258     goto set_default;
 259
 260   v->bad = 1;
 261   options.separator = p;
 262   options.separator_len = strlen (p);
 263
 264   /* Make sure the separator is valid */
 265
 266   if (options.separator_len == 0)
 267     goto set_default;
 268   seen_comma = 0;
 269
 270   while (*p)
 271     {
 272       if (*p == ',')
 273         {
 274           if (seen_comma)
 275             goto set_default;
 276           seen_comma = 1;
 277           p++;
 278           continue;
 279         }
 280
 281       if (*p++ != ' ')
 282         goto set_default;
 283     }
 284
 285   v->bad = 0;
 286   return;
 287
 288 set_default:
 289   options.separator = " ";
 290   options.separator_len = 1;
 291 }
 292
 293
 294 static void
 295 show_sep (variable * v)
 296 {
 297   st_printf ("%s  \"%s\"\n", var_source (v), options.separator);
 298 }
 299
 300
 301 static void
 302 init_string (variable * v)
 303 {
 304 }
 305
 306 static void
 307 show_string (variable * v)
 308 {
 309   const char *p;
 310
 311   p = getenv (v->name);
 312   if (p == NULL)
 313     p = "";
 314
 315   st_printf ("%s  \"%s\"\n", var_source (v), p);
 316 }
 317
 318
 319 /* Structure for associating names and values.  */
 320
 321 typedef struct
 322 {
 323   const char *name;
 324   int value;
 325 }
 326 choice;
 327
 328
 329 enum
 330 { FP_ROUND_NEAREST, FP_ROUND_UP, FP_ROUND_DOWN, FP_ROUND_ZERO };
 331
 332 static choice rounding[] = {
 333   {"NEAREST", FP_ROUND_NEAREST},
 334   {"UP", FP_ROUND_UP},
 335   {"DOWN", FP_ROUND_DOWN},
 336   {"ZERO", FP_ROUND_ZERO},
 337   {NULL}
 338 };
 339
 340 static choice precision[] =
 341 {
 342   { "24", 1},
 343   { "53", 2},
 344   { "64", 0},
 345   { NULL}
 346 };
 347
 348 static choice signal_choices[] =
 349 {
 350   { "IGNORE", 1},
 351   { "ABORT", 0},
 352   { NULL}
 353 };
 354
 355
 356 static void
 357 init_choice (variable * v, choice * c)
 358 {
 359   char *p;
 360
 361   p = getenv (v->name);
 362   if (p == NULL)
 363     goto set_default;
 364
 365   for (; c->name; c++)
 366     if (strcasecmp (c->name, p) == 0)
 367       break;
 368
 369   if (c->name == NULL)
 370     {
 371       v->bad = 1;
 372       goto set_default;
 373     }
 374
 375   *v->var = c->value;
 376   return;
 377
 378  set_default:
 379   *v->var = v->value;
 380 }
 381
 382
 383 static void
 384 show_choice (variable * v, choice * c)
 385 {
 386   st_printf ("%s  ", var_source (v));
 387
 388   for (; c->name; c++)
 389     if (c->value == *v->var)
 390       break;
 391
 392   if (c->name)
 393     st_printf ("%s\n", c->name);
 394   else
 395     st_printf ("(Unknown)\n");
 396 }
 397
 398
 399 static void
 400 init_round (variable * v)
 401 {
 402   init_choice (v, rounding);
 403 }
 404
 405 static void
 406 show_round (variable * v)
 407 {
 408   show_choice (v, rounding);
 409 }
 410
 411 static void
 412 init_precision (variable * v)
 413 {
 414   init_choice (v, precision);
 415 }
 416
 417 static void
 418 show_precision (variable * v)
 419 {
 420   show_choice (v, precision);
 421 }
 422
 423 static void
 424 init_signal (variable * v)
 425 {
 426   init_choice (v, signal_choices);
 427 }
 428
 429 static void
 430 show_signal (variable * v)
 431 {
 432   show_choice (v, signal_choices);
 433 }
 434
 435
 436 static variable variable_table[] = {
 437   {"GFORTRAN_STDIN_UNIT", 5, &options.stdin_unit, init_integer, show_integer,
 438    "Unit number that will be preconnected to standard input\n"
 439    "(No preconnection if negative)"},
 440
 441   {"GFORTRAN_STDOUT_UNIT", 6, &options.stdout_unit, init_integer,
 442    show_integer,
 443    "Unit number that will be preconnected to standard output\n"
 444    "(No preconnection if negative)"},
 445
 446   {"GFORTRAN_STDERR_UNIT", 0, &options.stderr_unit, init_integer,
 447    show_integer,
 448    "Unit number that will be preconnected to standard error\n"
 449    "(No preconnection if negative)"},
 450
 451   {"GFORTRAN_USE_STDERR", 1, &options.use_stderr, init_boolean,
 452    show_boolean,
 453    "Sends library output to standard error instead of standard output."},
 454
 455   {"GFORTRAN_TMPDIR", 0, NULL, init_string, show_string,
 456    "Directory for scratch files.  Overrides the TMP environment variable\n"
 457    "If TMP is not set " DEFAULT_TEMPDIR " is used."},
 458
 459   {"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean,
 460    show_boolean,
 461    "If TRUE, all output is unbuffered.  This will slow down large writes "
 462    "but can be\nuseful for forcing data to be displayed immediately."},
 463
 464   {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
 465    "If TRUE, print filename and line number where runtime errors happen."},
 466
 467 /* GFORTRAN_NAME_xx (where xx is a unit number) gives the names of files
 468  * preconnected to those units. */
 469
 470 /* GFORTRAN_UNBUFFERED_xx (where xx is a unit number) gives a boolean that is used
 471  * to turn off buffering for that unit. */
 472
 473   {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
 474    "Print optional plus signs in numbers where permitted.  Default FALSE."},
 475
 476   {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
 477    init_integer, show_integer,
 478    "Default maximum record length for sequential files.  Most useful for\n"
 479    "adjusting line length of preconnected units.  Default "
 480    stringize (DEFAULT_RECL)},
 481
 482   {"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
 483    "Separatator to use when writing list output.  May contain any number of "
 484    "spaces\nand at most one comma.  Default is a single space."},
 485
 486   /* Memory related controls */
 487
 488   {"GFORTRAN_MEM_INIT", 0, NULL, init_mem, show_mem,
 489    "How to initialize allocated memory.  Default value is NONE for no "
 490    "initialization\n(faster), NAN for a Not-a-Number with the mantissa "
 491    "0x40f95 or a custom\nhexadecimal value"},
 492
 493   {"GFORTRAN_MEM_CHECK", 0, &options.mem_check, init_boolean, show_boolean,
 494    "Whether memory still allocated will be reported when the program ends."},
 495
 496   /* Signal handling (Unix).  */
 497
 498   {"GFORTRAN_SIGHUP", 0, &options.sighup, init_signal, show_signal,
 499    "Whether the program will IGNORE or ABORT on SIGHUP."},
 500
 501   {"GFORTRAN_SIGINT", 0, &options.sigint, init_signal, show_signal,
 502    "Whether the program will IGNORE or ABORT on SIGINT."},
 503
 504   /* Floating point control */
 505
 506   {"GFORTRAN_FPU_ROUND", 0, &options.fpu_round, init_round, show_round,
 507    "Set floating point rounding.  Values are NEAREST, UP, DOWN, ZERO."},
 508
 509   {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision, init_precision,
 510    show_precision,
 511    "Precision of intermediate results.  Values are 24, 53 and 64."},
 512
 513   {"GFORTRAN_FPU_INVALID", 1, &options.fpu_invalid, init_boolean,
 514    show_boolean,
 515    "Raise a floating point exception on invalid FP operation."},
 516
 517   {"GFORTRAN_FPU_DENORMAL", 1, &options.fpu_denormal, init_boolean,
 518    show_boolean,
 519    "Raise a floating point exception when denormal numbers are encountered."},
 520
 521   {"GFORTRAN_FPU_ZERO", 0, &options.fpu_zerodiv, init_boolean, show_boolean,
 522    "Raise a floating point exception when dividing by zero."},
 523
 524   {"GFORTRAN_FPU_OVERFLOW", 0, &options.fpu_overflow, init_boolean,
 525    show_boolean,
 526    "Raise a floating point exception on overflow."},
 527
 528   {"GFORTRAN_FPU_UNDERFLOW", 0, &options.fpu_underflow, init_boolean,
 529    show_boolean,
 530    "Raise a floating point exception on underflow."},
 531
 532   {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision_loss, init_boolean,
 533    show_boolean,
 534    "Raise a floating point exception on precision loss."},
 535
 536   {NULL}
 537 };
 538
 539
 540 /* init_variables()-- Initialize most runtime variables from
 541  * environment variables. */
 542
 543 void
 544 init_variables (void)
 545 {
 546   variable *v;
 547
 548   for (v = variable_table; v->name; v++)
 549     v->init (v);
 550 }
 551
 552
 553 /* check_buffered()-- Given an unit number n, determine if an override
 554  * for the stream exists.  Returns zero for unbuffered, one for
 555  * buffered or two for not set. */
 556
 557 int
 558 check_buffered (int n)
 559 {
 560   char name[40];
 561   variable v;
 562   int rv;
 563
 564   if (options.all_unbuffered)
 565     return 0;
 566
 567   strcpy (name, "GFORTRAN_UNBUFFERED_");
 568   strcat (name, gfc_itoa (n));
 569
 570   v.name = name;
 571   v.value = 2;
 572   v.var = &rv;
 573
 574   init_boolean (&v);
 575
 576   return rv;
 577 }
 578
 579
 580 /* pattern_scan()-- Given an environment string, check that the name
 581  * has the same name as the pattern followed by an integer.  On a
 582  * match, a pointer to the value is returned and the integer pointed
 583  * to by n is updated.  Returns NULL on no match. */
 584
 585 static char *
 586 pattern_scan (char *env, const char *pattern, int *n)
 587 {
 588   char *p;
 589   size_t len;
 590
 591   len = strlen (pattern);
 592   if (strncasecmp (env, pattern, len) != 0)
 593     return NULL;
 594   p = env + len;
 595
 596   if (!isdigit (*p))
 597     return NULL;
 598
 599   while (isdigit (*p))
 600     p++;
 601
 602   if (*p != '=')
 603     return NULL;
 604
 605   *p = '\0';
 606   *n = atoi (env + len);
 607   *p++ = '=';
 608
 609   return p;
 610 }
 611
 612
 613 void
 614 show_variables (void)
 615 {
 616   char *p, **e;
 617   variable *v;
 618   int n;
 619
 620   /* TODO: print version number.  */
 621   st_printf ("GNU Fortran 95 runtime library version "
 622              "UNKNOWN" "\n\n");
 623
 624   st_printf ("Environment variables:\n");
 625   st_printf ("----------------------\n");
 626
 627   for (v = variable_table; v->name; v++)
 628     {
 629       n = st_printf ("%s", v->name);
 630       print_spaces (25 - n);
 631
 632       if (v->show == show_integer)
 633         st_printf ("Integer ");
 634       else if (v->show == show_boolean)
 635         st_printf ("Boolean ");
 636       else
 637         st_printf ("String  ");
 638
 639       v->show (v);
 640       st_printf ("%s\n\n", v->desc);
 641     }
 642
 643   st_printf ("\nDefault unit names (GFORTRAN_NAME_x):\n");
 644
 645   for (e = environ; *e; e++)
 646     {
 647       p = pattern_scan (*e, "GFORTRAN_NAME_", &n);
 648       if (p == NULL)
 649         continue;
 650       st_printf ("GFORTRAN_NAME_%d         %s\n", n, p);
 651     }
 652
 653   st_printf ("\nUnit buffering overrides (GFORTRAN_UNBUFFERED_x):\n");
 654   for (e = environ; *e; e++)
 655     {
 656       p = pattern_scan (*e, "GFORTRAN_UNBUFFERED_", &n);
 657       if (p == NULL)
 658         continue;
 659
 660       st_printf ("GFORTRAN_UNBUFFERED_%d = %s\n", n, p);
 661     }
 662
 663   /* System error codes */
 664
 665   st_printf ("\nRuntime error codes:");
 666   st_printf ("\n--------------------\n");
 667
 668   for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++)
 669     if (n < 0 || n > 9)
 670       st_printf ("%d  %s\n", n, translate_error (n));
 671     else
 672       st_printf (" %d  %s\n", n, translate_error (n));
 673
 674   st_printf ("\nCommand line arguments:\n");
 675   st_printf ("  --help               Print this list\n");
 676
 677   /* st_printf("  --resume <dropfile>  Resume program execution from dropfile\n"); */
 678
 679   sys_exit (0);
 680 }