OSDN Git Service

PR 48915 Abort handling
[pf3gnuchains/gcc-fork.git] / libgfortran / runtime / environ.c
1 /* Copyright (C) 2002, 2003, 2005, 2007, 2009 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 3, or (at your option)
9 any later version.
10
11 Libgfortran 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 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
19
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
23 <http://www.gnu.org/licenses/>.  */
24
25 #include "libgfortran.h"
26
27 #include <string.h>
28 #include <stdlib.h>
29 #include <ctype.h>
30
31
32 /* Environment scanner.  Examine the environment for controlling minor
33  * aspects of the program's execution.  Our philosophy here that the
34  * environment should not prevent the program from running, so an
35  * environment variable with a messed-up value will be interpreted in
36  * the default way.
37  *
38  * Most of the environment is checked early in the startup sequence,
39  * but other variables are checked during execution of the user's
40  * program. */
41
42 options_t options;
43
44
45 typedef struct variable
46 {
47   const char *name;
48   int value, *var;
49   void (*init) (struct variable *);
50   void (*show) (struct variable *);
51   const char *desc;
52   int bad;
53 }
54 variable;
55
56 static void init_unformatted (variable *);
57
58 /* print_spaces()-- Print a particular number of spaces.  */
59
60 static void
61 print_spaces (int n)
62 {
63   char buffer[80];
64   int i;
65
66   if (n <= 0)
67     return;
68
69   for (i = 0; i < n; i++)
70     buffer[i] = ' ';
71
72   buffer[i] = '\0';
73
74   estr_write (buffer);
75 }
76
77
78 /* var_source()-- Return a string that describes where the value of a
79  * variable comes from */
80
81 static const char *
82 var_source (variable * v)
83 {
84   if (getenv (v->name) == NULL)
85     return "Default";
86
87   if (v->bad)
88     return "Bad    ";
89
90   return "Set    ";
91 }
92
93
94 /* init_integer()-- Initialize an integer environment variable.  */
95
96 static void
97 init_integer (variable * v)
98 {
99   char *p, *q;
100
101   p = getenv (v->name);
102   if (p == NULL)
103     goto set_default;
104
105   for (q = p; *q; q++)
106     if (!isdigit (*q) && (p != q || *q != '-'))
107       {
108         v->bad = 1;
109         goto set_default;
110       }
111
112   *v->var = atoi (p);
113   return;
114
115  set_default:
116   *v->var = v->value;
117   return;
118 }
119
120
121 /* init_unsigned_integer()-- Initialize an integer environment variable
122    which has to be positive.  */
123
124 static void
125 init_unsigned_integer (variable * v)
126 {
127   char *p, *q;
128
129   p = getenv (v->name);
130   if (p == NULL)
131     goto set_default;
132
133   for (q = p; *q; q++)
134     if (!isdigit (*q))
135       {
136         v->bad = 1;
137         goto set_default;
138       }
139
140   *v->var = atoi (p);
141   return;
142
143  set_default:
144   *v->var = v->value;
145   return;
146 }
147
148
149 /* show_integer()-- Show an integer environment variable */
150
151 static void
152 show_integer (variable * v)
153 {
154   st_printf ("%s  %d\n", var_source (v), *v->var);
155 }
156
157
158 /* init_boolean()-- Initialize a boolean environment variable.  We
159  * only look at the first letter of the variable. */
160
161 static void
162 init_boolean (variable * v)
163 {
164   char *p;
165
166   p = getenv (v->name);
167   if (p == NULL)
168     goto set_default;
169
170   if (*p == '1' || *p == 'Y' || *p == 'y')
171     {
172       *v->var = 1;
173       return;
174     }
175
176   if (*p == '0' || *p == 'N' || *p == 'n')
177     {
178       *v->var = 0;
179       return;
180     }
181
182   v->bad = 1;
183
184 set_default:
185   *v->var = v->value;
186   return;
187 }
188
189
190 /* show_boolean()-- Show a boolean environment variable */
191
192 static void
193 show_boolean (variable * v)
194 {
195   st_printf ("%s  %s\n", var_source (v), *v->var ? "Yes" : "No");
196 }
197
198
199 static void
200 init_sep (variable * v)
201 {
202   int seen_comma;
203   char *p;
204
205   p = getenv (v->name);
206   if (p == NULL)
207     goto set_default;
208
209   v->bad = 1;
210   options.separator = p;
211   options.separator_len = strlen (p);
212
213   /* Make sure the separator is valid */
214
215   if (options.separator_len == 0)
216     goto set_default;
217   seen_comma = 0;
218
219   while (*p)
220     {
221       if (*p == ',')
222         {
223           if (seen_comma)
224             goto set_default;
225           seen_comma = 1;
226           p++;
227           continue;
228         }
229
230       if (*p++ != ' ')
231         goto set_default;
232     }
233
234   v->bad = 0;
235   return;
236
237 set_default:
238   options.separator = " ";
239   options.separator_len = 1;
240 }
241
242
243 static void
244 show_sep (variable * v)
245 {
246   st_printf ("%s  \"%s\"\n", var_source (v), options.separator);
247 }
248
249
250 static void
251 init_string (variable * v __attribute__ ((unused)))
252 {
253 }
254
255 static void
256 show_string (variable * v)
257 {
258   const char *p;
259
260   p = getenv (v->name);
261   if (p == NULL)
262     p = "";
263
264   estr_write (var_source (v));
265   estr_write ("  \"");
266   estr_write (p);
267   estr_write ("\"\n");
268 }
269
270
271 static variable variable_table[] = {
272   {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
273    init_integer, show_integer,
274    "Unit number that will be preconnected to standard input\n"
275    "(No preconnection if negative)", 0},
276
277   {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
278    init_integer, show_integer,
279    "Unit number that will be preconnected to standard output\n"
280    "(No preconnection if negative)", 0},
281
282   {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
283    init_integer, show_integer,
284    "Unit number that will be preconnected to standard error\n"
285    "(No preconnection if negative)", 0},
286
287   {"GFORTRAN_TMPDIR", 0, NULL, init_string, show_string,
288    "Directory for scratch files.  Overrides the TMP environment variable\n"
289    "If TMP is not set " DEFAULT_TEMPDIR " is used.", 0},
290
291   {"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean,
292    show_boolean,
293    "If TRUE, all output is unbuffered.  This will slow down large writes "
294    "but can be\nuseful for forcing data to be displayed immediately.", 0},
295
296   {"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
297    init_boolean, show_boolean,
298    "If TRUE, output to preconnected units is unbuffered.", 0},
299
300   {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
301    "If TRUE, print filename and line number where runtime errors happen.", 0},
302
303   {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
304    "Print optional plus signs in numbers where permitted.  Default FALSE.", 0},
305
306   {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
307    init_unsigned_integer, show_integer,
308    "Default maximum record length for sequential files.  Most useful for\n"
309    "adjusting line length of preconnected units.  Default "
310    stringize (DEFAULT_RECL), 0},
311
312   {"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
313    "Separator to use when writing list output.  May contain any number of "
314    "spaces\nand at most one comma.  Default is a single space.", 0},
315
316   /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
317    unformatted I/O.  */
318   {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string,
319    "Set format for unformatted files", 0},
320
321   {"GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace,
322     init_boolean, show_boolean,
323     "Print out a backtrace (if possible) on runtime error", -1},
324
325   {NULL, 0, NULL, NULL, NULL, NULL, 0}
326 };
327
328
329 /* init_variables()-- Initialize most runtime variables from
330  * environment variables. */
331
332 void
333 init_variables (void)
334 {
335   variable *v;
336
337   for (v = variable_table; v->name; v++)
338     v->init (v);
339 }
340
341
342 void
343 show_variables (void)
344 {
345   variable *v;
346   int n;
347
348   /* TODO: print version number.  */
349   estr_write ("GNU Fortran runtime library version "
350              "UNKNOWN" "\n\n");
351
352   estr_write ("Environment variables:\n");
353   estr_write ("----------------------\n");
354
355   for (v = variable_table; v->name; v++)
356     {
357       n = estr_write (v->name);
358       print_spaces (25 - n);
359
360       if (v->show == show_integer)
361         estr_write ("Integer ");
362       else if (v->show == show_boolean)
363         estr_write ("Boolean ");
364       else
365         estr_write ("String  ");
366
367       v->show (v);
368       estr_write (v->desc);
369       estr_write ("\n\n");
370     }
371
372   /* System error codes */
373
374   estr_write ("\nRuntime error codes:");
375   estr_write ("\n--------------------\n");
376
377   for (n = LIBERROR_FIRST + 1; n < LIBERROR_LAST; n++)
378     if (n < 0 || n > 9)
379       st_printf ("%d  %s\n", n, translate_error (n));
380     else
381       st_printf (" %d  %s\n", n, translate_error (n));
382
383   estr_write ("\nCommand line arguments:\n");
384   estr_write ("  --help               Print this list\n");
385
386   exit (0);
387 }
388
389 /* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
390    It is called from environ.c to parse this variable, and from
391    open.c to determine if the user specified a default for an
392    unformatted file.
393    The syntax of the environment variable is, in bison grammar:
394
395    GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
396    mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
397    exception: mode ':' unit_list | unit_list ;
398    unit_list: unit_spec | unit_list unit_spec ;
399    unit_spec: INTEGER | INTEGER '-' INTEGER ;
400 */
401
402 /* Defines for the tokens.  Other valid tokens are ',', ':', '-'.  */
403
404
405 #define NATIVE   257
406 #define SWAP     258
407 #define BIG      259
408 #define LITTLE   260
409 /* Some space for additional tokens later.  */
410 #define INTEGER  273
411 #define END      (-1)
412 #define ILLEGAL  (-2)
413
414 typedef struct
415 {
416   int unit;
417   unit_convert conv;
418 } exception_t;
419
420
421 static char *p;            /* Main character pointer for parsing.  */
422 static char *lastpos;      /* Auxiliary pointer, for backing up.  */
423 static int unit_num;       /* The last unit number read.  */
424 static int unit_count;     /* The number of units found. */
425 static int do_count;       /* Parsing is done twice - first to count the number
426                               of units, then to fill in the table.  This
427                               variable controls what to do.  */
428 static exception_t *elist; /* The list of exceptions to the default. This is
429                               sorted according to unit number.  */
430 static int n_elist;        /* Number of exceptions to the default.  */
431
432 static unit_convert endian; /* Current endianness.  */
433
434 static unit_convert def; /* Default as specified (if any).  */
435
436 /* Search for a unit number, using a binary search.  The
437    first argument is the unit number to search for.  The second argument
438    is a pointer to an index.
439    If the unit number is found, the function returns 1, and the index
440    is that of the element.
441    If the unit number is not found, the function returns 0, and the
442    index is the one where the element would be inserted.  */
443
444 static int
445 search_unit (int unit, int *ip)
446 {
447   int low, high, mid;
448
449   low = -1;
450   high = n_elist;
451   while (high - low > 1)
452     {
453       mid = (low + high) / 2;
454       if (unit <= elist[mid].unit)
455         high = mid;
456       else
457         low = mid;
458     }
459   *ip = high;
460   if (elist[high].unit == unit)
461     return 1;
462   else
463     return 0;
464 }
465
466 /* This matches a keyword.  If it is found, return the token supplied,
467    otherwise return ILLEGAL.  */
468
469 static int
470 match_word (const char *word, int tok)
471 {
472   int res;
473
474   if (strncasecmp (p, word, strlen (word)) == 0)
475     {
476       p += strlen (word);
477       res = tok;
478     }
479   else
480     res = ILLEGAL;
481   return res;
482
483 }
484
485 /* Match an integer and store its value in unit_num.  This only works
486    if p actually points to the start of an integer.  The caller has
487    to ensure this.  */
488
489 static int
490 match_integer (void)
491 {
492   unit_num = 0;
493   while (isdigit (*p))
494     unit_num = unit_num * 10 + (*p++ - '0');
495   return INTEGER;
496
497 }
498
499 /* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
500    Returned values are the different tokens.  */
501
502 static int
503 next_token (void)
504 {
505   int result;
506
507   lastpos = p;
508   switch (*p)
509     {
510     case '\0':
511       result = END;
512       break;
513       
514     case ':':
515     case ',': 
516     case '-':
517     case ';':
518       result = *p;
519       p++;
520       break;
521
522     case 'b':
523     case 'B':
524       result = match_word ("big_endian", BIG);
525       break;
526
527     case 'l':
528     case 'L':
529       result = match_word ("little_endian", LITTLE);
530       break;
531
532     case 'n':
533     case 'N':
534       result = match_word ("native", NATIVE);
535       break;
536
537     case 's':
538     case 'S':
539       result = match_word ("swap", SWAP);
540       break;
541
542     case '1': case '2': case '3': case '4': case '5':
543     case '6': case '7': case '8': case '9':
544       result = match_integer ();
545       break;
546
547     default:
548       result = ILLEGAL;
549       break;
550     }
551   return result;
552 }
553
554 /* Back up the last token by setting back the character pointer.  */
555
556 static void
557 push_token (void)
558 {
559   p = lastpos;
560 }
561
562 /* This is called when a unit is identified.  If do_count is nonzero,
563    increment the number of units by one.  If do_count is zero,
564    put the unit into the table.  */
565
566 static void
567 mark_single (int unit)
568 {
569   int i,j;
570
571   if (do_count)
572     {
573       unit_count++;
574       return;
575     }
576   if (search_unit (unit, &i))
577     {
578       elist[unit].conv = endian;
579     }
580   else
581     {
582       for (j=n_elist; j>=i; j--)
583         elist[j+1] = elist[j];
584     
585       n_elist += 1;
586       elist[i].unit = unit;
587       elist[i].conv = endian;
588     }
589 }
590
591 /* This is called when a unit range is identified.  If do_count is
592    nonzero, increase the number of units.  If do_count is zero,
593    put the unit into the table.  */
594
595 static void
596 mark_range (int unit1, int unit2)
597 {
598   int i;
599   if (do_count)
600     unit_count += abs (unit2 - unit1) + 1;
601   else
602     {
603       if (unit2 < unit1)
604         for (i=unit2; i<=unit1; i++)
605           mark_single (i);
606       else
607         for (i=unit1; i<=unit2; i++)
608           mark_single (i);
609     }
610 }
611
612 /* Parse the GFORTRAN_CONVERT_UNITS variable.  This is called
613    twice, once to count the units and once to actually mark them in
614    the table.  When counting, we don't check for double occurrences
615    of units.  */
616
617 static int
618 do_parse (void)
619 {
620   int tok;
621   int unit1;
622   int continue_ulist;
623   char *start;
624
625   unit_count = 0;
626
627   start = p;
628
629   /* Parse the string.  First, let's look for a default.  */
630   tok = next_token ();
631   switch (tok)
632     {
633     case NATIVE:
634       endian = GFC_CONVERT_NATIVE;
635       break;
636
637     case SWAP:
638       endian = GFC_CONVERT_SWAP;
639       break;
640
641     case BIG:
642       endian = GFC_CONVERT_BIG;
643       break;
644
645     case LITTLE:
646       endian = GFC_CONVERT_LITTLE;
647       break;
648
649     case INTEGER:
650       /* A leading digit means that we are looking at an exception.
651          Reset the position to the beginning, and continue processing
652          at the exception list.  */
653       p = start;
654       goto exceptions;
655       break;
656
657     case END:
658       goto end;
659       break;
660
661     default:
662       goto error;
663       break;
664     }
665
666   tok = next_token ();
667   switch (tok)
668     {
669     case ';':
670       def = endian;
671       break;
672
673     case ':':
674       /* This isn't a default after all.  Reset the position to the
675          beginning, and continue processing at the exception list.  */
676       p = start;
677       goto exceptions;
678       break;
679
680     case END:
681       def = endian;
682       goto end;
683       break;
684
685     default:
686       goto error;
687       break;
688     }
689
690  exceptions:
691
692   /* Loop over all exceptions.  */
693   while(1)
694     {
695       tok = next_token ();
696       switch (tok)
697         {
698         case NATIVE:
699           if (next_token () != ':')
700             goto error;
701           endian = GFC_CONVERT_NATIVE;
702           break;
703
704         case SWAP:
705           if (next_token () != ':')
706             goto error;
707           endian = GFC_CONVERT_SWAP;
708           break;
709
710         case LITTLE:
711           if (next_token () != ':')
712             goto error;
713           endian = GFC_CONVERT_LITTLE;
714           break;
715
716         case BIG:
717           if (next_token () != ':')
718             goto error;
719           endian = GFC_CONVERT_BIG;
720           break;
721
722         case INTEGER:
723           push_token ();
724           break;
725
726         case END:
727           goto end;
728           break;
729
730         default:
731           goto error;
732           break;
733         }
734       /* We arrive here when we want to parse a list of
735          numbers.  */
736       continue_ulist = 1;
737       do
738         {
739           tok = next_token ();
740           if (tok != INTEGER)
741             goto error;
742
743           unit1 = unit_num;
744           tok = next_token ();
745           /* The number can be followed by a - and another number,
746              which means that this is a unit range, a comma
747              or a semicolon.  */
748           if (tok == '-')
749             {
750               if (next_token () != INTEGER)
751                 goto error;
752
753               mark_range (unit1, unit_num);
754               tok = next_token ();
755               if (tok == END)
756                 goto end;
757               else if (tok == ';')
758                 continue_ulist = 0;
759               else if (tok != ',')
760                 goto error;
761             }
762           else
763             {
764               mark_single (unit1);
765               switch (tok)
766                 {
767                 case ';':
768                   continue_ulist = 0;
769                   break;
770
771                 case ',':
772                   break;
773
774                 case END:
775                   goto end;
776                   break;
777
778                 default:
779                   goto error;
780                 }
781             }
782         } while (continue_ulist);
783     }
784  end:
785   return 0;
786  error:
787   def = GFC_CONVERT_NONE;
788   return -1;
789 }
790
791 void init_unformatted (variable * v)
792 {
793   char *val;
794   val = getenv (v->name);
795   def = GFC_CONVERT_NONE;
796   n_elist = 0;
797
798   if (val == NULL)
799     return;
800   do_count = 1;
801   p = val;
802   do_parse ();
803   if (do_count <= 0)
804     {
805       n_elist = 0;
806       elist = NULL;
807     }
808   else
809     {
810       elist = get_mem (unit_count * sizeof (exception_t));
811       do_count = 0;
812       p = val;
813       do_parse ();
814     }
815 }
816
817 /* Get the default conversion for for an unformatted unit.  */
818
819 unit_convert
820 get_unformatted_convert (int unit)
821 {
822   int i;
823
824   if (elist == NULL)
825     return def;
826   else if (search_unit (unit, &i))
827     return elist[i].conv;
828   else
829     return def;
830 }