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