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