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, 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
  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)
 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 choice rounding[] = {
 360   {"NEAREST", FP_ROUND_NEAREST},
 361   {"UP", FP_ROUND_UP},
 362   {"DOWN", FP_ROUND_DOWN},
 363   {"ZERO", FP_ROUND_ZERO},
 364   {NULL}
 365 };
 366
 367 static choice precision[] =
 368 {
 369   { "24", 1},
 370   { "53", 2},
 371   { "64", 0},
 372   { NULL}
 373 };
 374
 375 static choice signal_choices[] =
 376 {
 377   { "IGNORE", 1},
 378   { "ABORT", 0},
 379   { NULL}
 380 };
 381
 382
 383 static void
 384 init_choice (variable * v, 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, 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)"},
 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)"},
 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)"},
 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."},
 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."},
 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."},
 490
 491   {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
 492    "If TRUE, print filename and line number where runtime errors happen."},
 493
 494   {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
 495    "Print optional plus signs in numbers where permitted.  Default FALSE."},
 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)},
 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."},
 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"},
 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
 517   /* Signal handling (Unix).  */
 518
 519   {"GFORTRAN_SIGHUP", 0, &options.sighup, init_signal, show_signal,
 520    "Whether the program will IGNORE or ABORT on SIGHUP."},
 521
 522   {"GFORTRAN_SIGINT", 0, &options.sigint, init_signal, show_signal,
 523    "Whether the program will IGNORE or ABORT on SIGINT."},
 524
 525   /* Floating point control */
 526
 527   {"GFORTRAN_FPU_ROUND", 0, &options.fpu_round, init_round, show_round,
 528    "Set floating point rounding.  Values are NEAREST, UP, DOWN, ZERO."},
 529
 530   {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision, init_precision,
 531    show_precision,
 532    "Precision of intermediate results.  Values are 24, 53 and 64."},
 533
 534   {"GFORTRAN_FPU_INVALID", 1, &options.fpu_invalid, init_boolean,
 535    show_boolean,
 536    "Raise a floating point exception on invalid FP operation."},
 537
 538   {"GFORTRAN_FPU_DENORMAL", 1, &options.fpu_denormal, init_boolean,
 539    show_boolean,
 540    "Raise a floating point exception when denormal numbers are encountered."},
 541
 542   {"GFORTRAN_FPU_ZERO", 0, &options.fpu_zerodiv, init_boolean, show_boolean,
 543    "Raise a floating point exception when dividing by zero."},
 544
 545   {"GFORTRAN_FPU_OVERFLOW", 0, &options.fpu_overflow, init_boolean,
 546    show_boolean,
 547    "Raise a floating point exception on overflow."},
 548
 549   {"GFORTRAN_FPU_UNDERFLOW", 0, &options.fpu_underflow, init_boolean,
 550    show_boolean,
 551    "Raise a floating point exception on underflow."},
 552
 553   {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision_loss, init_boolean,
 554    show_boolean,
 555    "Raise a floating point exception on precision loss."},
 556
 557   {NULL}
 558 };
 559
 560
 561 /* init_variables()-- Initialize most runtime variables from
 562  * environment variables. */
 563
 564 void
 565 init_variables (void)
 566 {
 567   variable *v;
 568
 569   for (v = variable_table; v->name; v++)
 570     v->init (v);
 571 }
 572
 573
 574 /* check_buffered()-- Given an unit number n, determine if an override
 575  * for the stream exists.  Returns zero for unbuffered, one for
 576  * buffered or two for not set. */
 577
 578 int
 579 check_buffered (int n)
 580 {
 581   char name[40];
 582   variable v;
 583   int rv;
 584
 585   if (options.all_unbuffered)
 586     return 0;
 587
 588   strcpy (name, "GFORTRAN_UNBUFFERED_");
 589   strcat (name, gfc_itoa (n));
 590
 591   v.name = name;
 592   v.value = 2;
 593   v.var = &rv;
 594
 595   init_boolean (&v);
 596
 597   return rv;
 598 }
 599
 600
 601 void
 602 show_variables (void)
 603 {
 604   variable *v;
 605   int n;
 606
 607   /* TODO: print version number.  */
 608   st_printf ("GNU Fortran 95 runtime library version "
 609              "UNKNOWN" "\n\n");
 610
 611   st_printf ("Environment variables:\n");
 612   st_printf ("----------------------\n");
 613
 614   for (v = variable_table; v->name; v++)
 615     {
 616       n = st_printf ("%s", v->name);
 617       print_spaces (25 - n);
 618
 619       if (v->show == show_integer)
 620         st_printf ("Integer ");
 621       else if (v->show == show_boolean)
 622         st_printf ("Boolean ");
 623       else
 624         st_printf ("String  ");
 625
 626       v->show (v);
 627       st_printf ("%s\n\n", v->desc);
 628     }
 629
 630   /* System error codes */
 631
 632   st_printf ("\nRuntime error codes:");
 633   st_printf ("\n--------------------\n");
 634
 635   for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++)
 636     if (n < 0 || n > 9)
 637       st_printf ("%d  %s\n", n, translate_error (n));
 638     else
 639       st_printf (" %d  %s\n", n, translate_error (n));
 640
 641   st_printf ("\nCommand line arguments:\n");
 642   st_printf ("  --help               Print this list\n");
 643
 644   /* st_printf("  --resume <dropfile>  Resume program execution from dropfile\n"); */
 645
 646   sys_exit (0);
 647 }