libgfortran/runtime/environ.c

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