OSDN Git Service

* runtime/normalize.c (almostone_r4, almostone_r8): Fix parameter
[pf3gnuchains/gcc-fork.git] / 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 __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 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 choice precision[] =
368 {
369   { "24", 1},
370   { "53", 2},
371   { "64", 0},
372   { NULL, 0}
373 };
374
375 static choice signal_choices[] =
376 {
377   { "IGNORE", 1},
378   { "ABORT", 0},
379   { NULL, 0}
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)", 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 }