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_USE_STDERR", 1, &options.use_stderr, init_boolean,
 447    show_boolean,
 448    "Sends library output to standard error instead of standard output."},
 449
 450   {"GFORTRAN_TMPDIR", 0, NULL, init_string, show_string,
 451    "Directory for scratch files.  Overrides the TMP environment variable\n"
 452    "If TMP is not set " DEFAULT_TEMPDIR " is used."},
 453
 454   {"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean,
 455    show_boolean,
 456    "If TRUE, all output is unbuffered.  This will slow down large writes "
 457    "but can be\nuseful for forcing data to be displayed immediately."},
 458
 459   {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
 460    "If TRUE, print filename and line number where runtime errors happen."},
 461
 462 /* GFORTRAN_NAME_xx (where xx is a unit number) gives the names of files
 463  * preconnected to those units. */
 464
 465 /* GFORTRAN_UNBUFFERED_xx (where xx is a unit number) gives a boolean that is used
 466  * to turn off buffering for that unit. */
 467
 468   {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
 469    "Print optional plus signs in numbers where permitted.  Default FALSE."},
 470
 471   {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
 472    init_integer, show_integer,
 473    "Default maximum record length for sequential files.  Most useful for\n"
 474    "adjusting line length of preconnected units.  Default "
 475    stringize (DEFAULT_RECL)},
 476
 477   {"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
 478    "Separatator to use when writing list output.  May contain any number of "
 479    "spaces\nand at most one comma.  Default is a single space."},
 480
 481   /* Memory related controls */
 482
 483   {"GFORTRAN_MEM_INIT", 0, NULL, init_mem, show_mem,
 484    "How to initialize allocated memory.  Default value is NONE for no "
 485    "initialization\n(faster), NAN for a Not-a-Number with the mantissa "
 486    "0x40f95 or a custom\nhexadecimal value"},
 487
 488   {"GFORTRAN_MEM_CHECK", 0, &options.mem_check, init_boolean, show_boolean,
 489    "Whether memory still allocated will be reported when the program ends."},
 490
 491   /* Signal handling (Unix).  */
 492
 493   {"GFORTRAN_SIGHUP", 0, &options.sighup, init_signal, show_signal,
 494    "Whether the program will IGNORE or ABORT on SIGHUP."},
 495
 496   {"GFORTRAN_SIGINT", 0, &options.sigint, init_signal, show_signal,
 497    "Whether the program will IGNORE or ABORT on SIGINT."},
 498
 499   /* Floating point control */
 500
 501   {"GFORTRAN_FPU_ROUND", 0, &options.fpu_round, init_round, show_round,
 502    "Set floating point rounding.  Values are NEAREST, UP, DOWN, ZERO."},
 503
 504   {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision, init_precision,
 505    show_precision,
 506    "Precision of intermediate results.  Values are 24, 53 and 64."},
 507
 508   {"GFORTRAN_FPU_INVALID", 1, &options.fpu_invalid, init_boolean,
 509    show_boolean,
 510    "Raise a floating point exception on invalid FP operation."},
 511
 512   {"GFORTRAN_FPU_DENORMAL", 1, &options.fpu_denormal, init_boolean,
 513    show_boolean,
 514    "Raise a floating point exception when denormal numbers are encountered."},
 515
 516   {"GFORTRAN_FPU_ZERO", 0, &options.fpu_zerodiv, init_boolean, show_boolean,
 517    "Raise a floating point exception when dividing by zero."},
 518
 519   {"GFORTRAN_FPU_OVERFLOW", 0, &options.fpu_overflow, init_boolean,
 520    show_boolean,
 521    "Raise a floating point exception on overflow."},
 522
 523   {"GFORTRAN_FPU_UNDERFLOW", 0, &options.fpu_underflow, init_boolean,
 524    show_boolean,
 525    "Raise a floating point exception on underflow."},
 526
 527   {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision_loss, init_boolean,
 528    show_boolean,
 529    "Raise a floating point exception on precision loss."},
 530
 531   {NULL}
 532 };
 533
 534
 535 /* init_variables()-- Initialize most runtime variables from
 536  * environment variables. */
 537
 538 void
 539 init_variables (void)
 540 {
 541   variable *v;
 542
 543   for (v = variable_table; v->name; v++)
 544     v->init (v);
 545 }
 546
 547
 548 /* check_buffered()-- Given an unit number n, determine if an override
 549  * for the stream exists.  Returns zero for unbuffered, one for
 550  * buffered or two for not set. */
 551
 552 int
 553 check_buffered (int n)
 554 {
 555   char name[40];
 556   variable v;
 557   int rv;
 558
 559   if (options.all_unbuffered)
 560     return 0;
 561
 562   strcpy (name, "GFORTRAN_UNBUFFERED_");
 563   strcat (name, gfc_itoa (n));
 564
 565   v.name = name;
 566   v.value = 2;
 567   v.var = &rv;
 568
 569   init_boolean (&v);
 570
 571   return rv;
 572 }
 573
 574
 575 /* pattern_scan()-- Given an environment string, check that the name
 576  * has the same name as the pattern followed by an integer.  On a
 577  * match, a pointer to the value is returned and the integer pointed
 578  * to by n is updated.  Returns NULL on no match. */
 579
 580 static char *
 581 pattern_scan (char *env, const char *pattern, int *n)
 582 {
 583   char *p;
 584   size_t len;
 585
 586   len = strlen (pattern);
 587   if (strncasecmp (env, pattern, len) != 0)
 588     return NULL;
 589   p = env + len;
 590
 591   if (!isdigit (*p))
 592     return NULL;
 593
 594   while (isdigit (*p))
 595     p++;
 596
 597   if (*p != '=')
 598     return NULL;
 599
 600   *p = '\0';
 601   *n = atoi (env + len);
 602   *p++ = '=';
 603
 604   return p;
 605 }
 606
 607
 608 void
 609 show_variables (void)
 610 {
 611   char *p, **e;
 612   variable *v;
 613   int n;
 614
 615   /* TODO: print version number.  */
 616   st_printf ("GNU Fortran 95 runtime library version "
 617              "UNKNOWN" "\n\n");
 618
 619   st_printf ("Environment variables:\n");
 620   st_printf ("----------------------\n");
 621
 622   for (v = variable_table; v->name; v++)
 623     {
 624       n = st_printf ("%s", v->name);
 625       print_spaces (25 - n);
 626
 627       if (v->show == show_integer)
 628         st_printf ("Integer ");
 629       else if (v->show == show_boolean)
 630         st_printf ("Boolean ");
 631       else
 632         st_printf ("String  ");
 633
 634       v->show (v);
 635       st_printf ("%s\n\n", v->desc);
 636     }
 637
 638   st_printf ("\nDefault unit names (GFORTRAN_NAME_x):\n");
 639
 640   for (e = environ; *e; e++)
 641     {
 642       p = pattern_scan (*e, "GFORTRAN_NAME_", &n);
 643       if (p == NULL)
 644         continue;
 645       st_printf ("GFORTRAN_NAME_%d         %s\n", n, p);
 646     }
 647
 648   st_printf ("\nUnit buffering overrides (GFORTRAN_UNBUFFERED_x):\n");
 649   for (e = environ; *e; e++)
 650     {
 651       p = pattern_scan (*e, "GFORTRAN_UNBUFFERED_", &n);
 652       if (p == NULL)
 653         continue;
 654
 655       st_printf ("GFORTRAN_UNBUFFERED_%d = %s\n", n, p);
 656     }
 657
 658   /* System error codes */
 659
 660   st_printf ("\nRuntime error codes:");
 661   st_printf ("\n--------------------\n");
 662
 663   for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++)
 664     if (n < 0 || n > 9)
 665       st_printf ("%d  %s\n", n, translate_error (n));
 666     else
 667       st_printf (" %d  %s\n", n, translate_error (n));
 668
 669   st_printf ("\nCommand line arguments:\n");
 670   st_printf ("  --help               Print this list\n");
 671
 672   /* st_printf("  --resume <dropfile>  Resume program execution from dropfile\n"); */
 673
 674   sys_exit (0);
 675 }