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