OSDN Git Service

1cfa3e2aa4bf1cc90692a46c94d4c31bf1eba81b
[pf3gnuchains/gcc-fork.git] / gcc / fortran / error.c
1 /* Handle errors.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3    Free Software Foundation, Inc.
4    Contributed by Andy Vaught & Niels Kristian Bech Jensen
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21
22 /* Handle the inevitable errors.  A major catch here is that things
23    flagged as errors in one match subroutine can conceivably be legal
24    elsewhere.  This means that error messages are recorded and saved
25    for possible use later.  If a line does not match a legal
26    construction, then the saved error message is reported.  */
27
28 #include "config.h"
29 #include "system.h"
30 #include "flags.h"
31 #include "gfortran.h"
32
33 static int suppress_errors = 0;
34
35 static int warnings_not_errors = 0; 
36
37 static int terminal_width, buffer_flag, errors, warnings;
38
39 static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
40
41
42 /* Go one level deeper suppressing errors.  */
43
44 void
45 gfc_push_suppress_errors (void)
46 {
47   gcc_assert (suppress_errors >= 0);
48   ++suppress_errors;
49 }
50
51
52 /* Leave one level of error suppressing.  */
53
54 void
55 gfc_pop_suppress_errors (void)
56 {
57   gcc_assert (suppress_errors > 0);
58   --suppress_errors;
59 }
60
61
62 /* Per-file error initialization.  */
63
64 void
65 gfc_error_init_1 (void)
66 {
67   terminal_width = gfc_terminal_width ();
68   errors = 0;
69   warnings = 0;
70   buffer_flag = 0;
71 }
72
73
74 /* Set the flag for buffering errors or not.  */
75
76 void
77 gfc_buffer_error (int flag)
78 {
79   buffer_flag = flag;
80 }
81
82
83 /* Add a single character to the error buffer or output depending on
84    buffer_flag.  */
85
86 static void
87 error_char (char c)
88 {
89   if (buffer_flag)
90     {
91       if (cur_error_buffer->index >= cur_error_buffer->allocated)
92         {
93           cur_error_buffer->allocated = cur_error_buffer->allocated
94                                       ? cur_error_buffer->allocated * 2 : 1000;
95           cur_error_buffer->message = XRESIZEVEC (char, cur_error_buffer->message,
96                                                   cur_error_buffer->allocated);
97         }
98       cur_error_buffer->message[cur_error_buffer->index++] = c;
99     }
100   else
101     {
102       if (c != 0)
103         {
104           /* We build up complete lines before handing things
105              over to the library in order to speed up error printing.  */
106           static char *line;
107           static size_t allocated = 0, index = 0;
108
109           if (index + 1 >= allocated)
110             {
111               allocated = allocated ? allocated * 2 : 1000;
112               line = XRESIZEVEC (char, line, allocated);
113             }
114           line[index++] = c;
115           if (c == '\n')
116             {
117               line[index] = '\0';
118               fputs (line, stderr);
119               index = 0;
120             }
121         }
122     }
123 }
124
125
126 /* Copy a string to wherever it needs to go.  */
127
128 static void
129 error_string (const char *p)
130 {
131   while (*p)
132     error_char (*p++);
133 }
134
135
136 /* Print a formatted integer to the error buffer or output.  */
137
138 #define IBUF_LEN 60
139
140 static void
141 error_uinteger (unsigned long int i)
142 {
143   char *p, int_buf[IBUF_LEN];
144
145   p = int_buf + IBUF_LEN - 1;
146   *p-- = '\0';
147
148   if (i == 0)
149     *p-- = '0';
150
151   while (i > 0)
152     {
153       *p-- = i % 10 + '0';
154       i = i / 10;
155     }
156
157   error_string (p + 1);
158 }
159
160 static void
161 error_integer (long int i)
162 {
163   unsigned long int u;
164
165   if (i < 0)
166     {
167       u = (unsigned long int) -i;
168       error_char ('-');
169     }
170   else
171     u = i;
172
173   error_uinteger (u);
174 }
175
176
177 static void
178 print_wide_char_into_buffer (gfc_char_t c, char *buf)
179 {
180   static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
181     '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
182
183   if (gfc_wide_is_printable (c))
184     {
185       buf[1] = '\0';
186       buf[0] = (unsigned char) c;
187     }
188   else if (c < ((gfc_char_t) 1 << 8))
189     {
190       buf[4] = '\0';
191       buf[3] = xdigit[c & 0x0F];
192       c = c >> 4;
193       buf[2] = xdigit[c & 0x0F];
194
195       buf[1] = 'x';
196       buf[0] = '\\';
197     }
198   else if (c < ((gfc_char_t) 1 << 16))
199     {
200       buf[6] = '\0';
201       buf[5] = xdigit[c & 0x0F];
202       c = c >> 4;
203       buf[4] = xdigit[c & 0x0F];
204       c = c >> 4;
205       buf[3] = xdigit[c & 0x0F];
206       c = c >> 4;
207       buf[2] = xdigit[c & 0x0F];
208
209       buf[1] = 'u';
210       buf[0] = '\\';
211     }
212   else
213     {
214       buf[10] = '\0';
215       buf[9] = xdigit[c & 0x0F];
216       c = c >> 4;
217       buf[8] = xdigit[c & 0x0F];
218       c = c >> 4;
219       buf[7] = xdigit[c & 0x0F];
220       c = c >> 4;
221       buf[6] = xdigit[c & 0x0F];
222       c = c >> 4;
223       buf[5] = xdigit[c & 0x0F];
224       c = c >> 4;
225       buf[4] = xdigit[c & 0x0F];
226       c = c >> 4;
227       buf[3] = xdigit[c & 0x0F];
228       c = c >> 4;
229       buf[2] = xdigit[c & 0x0F];
230
231       buf[1] = 'U';
232       buf[0] = '\\';
233     }
234 }
235
236 static char wide_char_print_buffer[11];
237
238 const char *
239 gfc_print_wide_char (gfc_char_t c)
240 {
241   print_wide_char_into_buffer (c, wide_char_print_buffer);
242   return wide_char_print_buffer;
243 }
244
245
246 /* Show the file, where it was included, and the source line, give a
247    locus.  Calls error_printf() recursively, but the recursion is at
248    most one level deep.  */
249
250 static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
251
252 static void
253 show_locus (locus *loc, int c1, int c2)
254 {
255   gfc_linebuf *lb;
256   gfc_file *f;
257   gfc_char_t c, *p;
258   int i, offset, cmax;
259
260   /* TODO: Either limit the total length and number of included files
261      displayed or add buffering of arbitrary number of characters in
262      error messages.  */
263
264   /* Write out the error header line, giving the source file and error
265      location (in GNU standard "[file]:[line].[column]:" format),
266      followed by an "included by" stack and a blank line.  This header
267      format is matched by a testsuite parser defined in
268      lib/gfortran-dg.exp.  */
269
270   lb = loc->lb;
271   f = lb->file;
272
273   error_string (f->filename);
274   error_char (':');
275     
276   error_integer (LOCATION_LINE (lb->location));
277
278   if ((c1 > 0) || (c2 > 0))
279     error_char ('.');
280
281   if (c1 > 0)
282     error_integer (c1);
283
284   if ((c1 > 0) && (c2 > 0))
285     error_char ('-');
286
287   if (c2 > 0)
288     error_integer (c2);
289
290   error_char (':');
291   error_char ('\n');
292
293   for (;;)
294     {
295       i = f->inclusion_line;
296
297       f = f->up;
298       if (f == NULL) break;
299
300       error_printf ("    Included at %s:%d:", f->filename, i);
301     }
302
303   error_char ('\n');
304
305   /* Calculate an appropriate horizontal offset of the source line in
306      order to get the error locus within the visible portion of the
307      line.  Note that if the margin of 5 here is changed, the
308      corresponding margin of 10 in show_loci should be changed.  */
309
310   offset = 0;
311
312   /* If the two loci would appear in the same column, we shift
313      '2' one column to the right, so as to print '12' rather than
314      just '1'.  We do this here so it will be accounted for in the
315      margin calculations.  */
316
317   if (c1 == c2)
318     c2 += 1;
319
320   cmax = (c1 < c2) ? c2 : c1;
321   if (cmax > terminal_width - 5)
322     offset = cmax - terminal_width + 5;
323
324   /* Show the line itself, taking care not to print more than what can
325      show up on the terminal.  Tabs are converted to spaces, and 
326      nonprintable characters are converted to a "\xNN" sequence.  */
327
328   /* TODO: Although setting i to the terminal width is clever, it fails
329      to work correctly when nonprintable characters exist.  A better 
330      solution should be found.  */
331
332   p = &(lb->line[offset]);
333   i = gfc_wide_strlen (p);
334   if (i > terminal_width)
335     i = terminal_width - 1;
336
337   for (; i > 0; i--)
338     {
339       static char buffer[11];
340
341       c = *p++;
342       if (c == '\t')
343         c = ' ';
344
345       print_wide_char_into_buffer (c, buffer);
346       error_string (buffer);
347     }
348
349   error_char ('\n');
350
351   /* Show the '1' and/or '2' corresponding to the column of the error
352      locus.  Note that a value of -1 for c1 or c2 will simply cause 
353      the relevant number not to be printed.  */
354
355   c1 -= offset;
356   c2 -= offset;
357
358   for (i = 0; i <= cmax; i++)
359     {
360       if (i == c1)
361         error_char ('1');
362       else if (i == c2)
363         error_char ('2');
364       else
365         error_char (' ');
366     }
367
368   error_char ('\n');
369
370 }
371
372
373 /* As part of printing an error, we show the source lines that caused
374    the problem.  We show at least one, and possibly two loci; the two
375    loci may or may not be on the same source line.  */
376
377 static void
378 show_loci (locus *l1, locus *l2)
379 {
380   int m, c1, c2;
381
382   if (l1 == NULL || l1->lb == NULL)
383     {
384       error_printf ("<During initialization>\n");
385       return;
386     }
387
388   /* While calculating parameters for printing the loci, we consider possible
389      reasons for printing one per line.  If appropriate, print the loci
390      individually; otherwise we print them both on the same line.  */
391
392   c1 = l1->nextc - l1->lb->line;
393   if (l2 == NULL)
394     {
395       show_locus (l1, c1, -1);
396       return;
397     }
398
399   c2 = l2->nextc - l2->lb->line;
400
401   if (c1 < c2)
402     m = c2 - c1;
403   else
404     m = c1 - c2;
405
406   /* Note that the margin value of 10 here needs to be less than the 
407      margin of 5 used in the calculation of offset in show_locus.  */
408
409   if (l1->lb != l2->lb || m > terminal_width - 10)
410     {
411       show_locus (l1, c1, -1);
412       show_locus (l2, -1, c2);
413       return;
414     }
415
416   show_locus (l1, c1, c2);
417
418   return;
419 }
420
421
422 /* Workhorse for the error printing subroutines.  This subroutine is
423    inspired by g77's error handling and is similar to printf() with
424    the following %-codes:
425
426    %c Character, %d or %i Integer, %s String, %% Percent
427    %L  Takes locus argument
428    %C  Current locus (no argument)
429
430    If a locus pointer is given, the actual source line is printed out
431    and the column is indicated.  Since we want the error message at
432    the bottom of any source file information, we must scan the
433    argument list twice -- once to determine whether the loci are 
434    present and record this for printing, and once to print the error
435    message after and loci have been printed.  A maximum of two locus
436    arguments are permitted.
437    
438    This function is also called (recursively) by show_locus in the
439    case of included files; however, as show_locus does not resupply
440    any loci, the recursion is at most one level deep.  */
441
442 #define MAX_ARGS 10
443
444 static void ATTRIBUTE_GCC_GFC(2,0)
445 error_print (const char *type, const char *format0, va_list argp)
446 {
447   enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER,
448          TYPE_LONGINT, TYPE_ULONGINT, TYPE_CHAR, TYPE_STRING,
449          NOTYPE };
450   struct
451   {
452     int type;
453     int pos;
454     union
455     {
456       int intval;
457       unsigned int uintval;
458       long int longintval;
459       unsigned long int ulongintval;
460       char charval;
461       const char * stringval;
462     } u;
463   } arg[MAX_ARGS], spec[MAX_ARGS];
464   /* spec is the array of specifiers, in the same order as they
465      appear in the format string.  arg is the array of arguments,
466      in the same order as they appear in the va_list.  */
467
468   char c;
469   int i, n, have_l1, pos, maxpos;
470   locus *l1, *l2, *loc;
471   const char *format;
472
473   l1 = l2 = NULL;
474
475   have_l1 = 0;
476   pos = -1;
477   maxpos = -1;
478
479   n = 0;
480   format = format0;
481
482   for (i = 0; i < MAX_ARGS; i++)
483     {
484       arg[i].type = NOTYPE;
485       spec[i].pos = -1;
486     }
487
488   /* First parse the format string for position specifiers.  */
489   while (*format)
490     {
491       c = *format++;
492       if (c != '%')
493         continue;
494
495       if (*format == '%')
496         {
497           format++;
498           continue;
499         }
500
501       if (ISDIGIT (*format))
502         {
503           /* This is a position specifier.  For example, the number
504              12 in the format string "%12$d", which specifies the third
505              argument of the va_list, formatted in %d format.
506              For details, see "man 3 printf".  */
507           pos = atoi(format) - 1;
508           gcc_assert (pos >= 0);
509           while (ISDIGIT(*format))
510             format++;
511           gcc_assert (*format++ == '$');
512         }
513       else
514         pos++;
515
516       c = *format++;
517
518       if (pos > maxpos)
519         maxpos = pos;
520
521       switch (c)
522         {
523           case 'C':
524             arg[pos].type = TYPE_CURRENTLOC;
525             break;
526
527           case 'L':
528             arg[pos].type = TYPE_LOCUS;
529             break;
530
531           case 'd':
532           case 'i':
533             arg[pos].type = TYPE_INTEGER;
534             break;
535
536           case 'u':
537             arg[pos].type = TYPE_UINTEGER;
538             break;
539
540           case 'l':
541             c = *format++;
542             if (c == 'u')
543               arg[pos].type = TYPE_ULONGINT;
544             else if (c == 'i' || c == 'd')
545               arg[pos].type = TYPE_LONGINT;
546             else
547               gcc_unreachable ();
548             break;
549
550           case 'c':
551             arg[pos].type = TYPE_CHAR;
552             break;
553
554           case 's':
555             arg[pos].type = TYPE_STRING;
556             break;
557
558           default:
559             gcc_unreachable ();
560         }
561
562       spec[n++].pos = pos;
563     }
564
565   /* Then convert the values for each %-style argument.  */
566   for (pos = 0; pos <= maxpos; pos++)
567     {
568       gcc_assert (arg[pos].type != NOTYPE);
569       switch (arg[pos].type)
570         {
571           case TYPE_CURRENTLOC:
572             loc = &gfc_current_locus;
573             /* Fall through.  */
574
575           case TYPE_LOCUS:
576             if (arg[pos].type == TYPE_LOCUS)
577               loc = va_arg (argp, locus *);
578
579             if (have_l1)
580               {
581                 l2 = loc;
582                 arg[pos].u.stringval = "(2)";
583               }
584             else
585               {
586                 l1 = loc;
587                 have_l1 = 1;
588                 arg[pos].u.stringval = "(1)";
589               }
590             break;
591
592           case TYPE_INTEGER:
593             arg[pos].u.intval = va_arg (argp, int);
594             break;
595
596           case TYPE_UINTEGER:
597             arg[pos].u.uintval = va_arg (argp, unsigned int);
598             break;
599
600           case TYPE_LONGINT:
601             arg[pos].u.longintval = va_arg (argp, long int);
602             break;
603
604           case TYPE_ULONGINT:
605             arg[pos].u.ulongintval = va_arg (argp, unsigned long int);
606             break;
607
608           case TYPE_CHAR:
609             arg[pos].u.charval = (char) va_arg (argp, int);
610             break;
611
612           case TYPE_STRING:
613             arg[pos].u.stringval = (const char *) va_arg (argp, char *);
614             break;
615
616           default:
617             gcc_unreachable ();
618         }
619     }
620
621   for (n = 0; spec[n].pos >= 0; n++)
622     spec[n].u = arg[spec[n].pos].u;
623
624   /* Show the current loci if we have to.  */
625   if (have_l1)
626     show_loci (l1, l2);
627
628   if (*type)
629     {
630       error_string (type);
631       error_char (' ');
632     }
633
634   have_l1 = 0;
635   format = format0;
636   n = 0;
637
638   for (; *format; format++)
639     {
640       if (*format != '%')
641         {
642           error_char (*format);
643           continue;
644         }
645
646       format++;
647       if (ISDIGIT (*format))
648         {
649           /* This is a position specifier.  See comment above.  */
650           while (ISDIGIT (*format))
651             format++;
652             
653           /* Skip over the dollar sign.  */
654           format++;
655         }
656         
657       switch (*format)
658         {
659         case '%':
660           error_char ('%');
661           break;
662
663         case 'c':
664           error_char (spec[n++].u.charval);
665           break;
666
667         case 's':
668         case 'C':               /* Current locus */
669         case 'L':               /* Specified locus */
670           error_string (spec[n++].u.stringval);
671           break;
672
673         case 'd':
674         case 'i':
675           error_integer (spec[n++].u.intval);
676           break;
677
678         case 'u':
679           error_uinteger (spec[n++].u.uintval);
680           break;
681
682         case 'l':
683           format++;
684           if (*format == 'u')
685             error_uinteger (spec[n++].u.ulongintval);
686           else
687             error_integer (spec[n++].u.longintval);
688           break;
689
690         }
691     }
692
693   error_char ('\n');
694 }
695
696
697 /* Wrapper for error_print().  */
698
699 static void
700 error_printf (const char *gmsgid, ...)
701 {
702   va_list argp;
703
704   va_start (argp, gmsgid);
705   error_print ("", _(gmsgid), argp);
706   va_end (argp);
707 }
708
709
710 /* Increment the number of errors, and check whether too many have 
711    been printed.  */
712
713 static void
714 gfc_increment_error_count (void)
715 {
716   errors++;
717   if ((gfc_option.max_errors != 0) && (errors >= gfc_option.max_errors))
718     gfc_fatal_error ("Error count reached limit of %d.", gfc_option.max_errors);
719 }
720
721
722 /* Issue a warning.  */
723
724 void
725 gfc_warning (const char *gmsgid, ...)
726 {
727   va_list argp;
728
729   if (inhibit_warnings)
730     return;
731
732   warning_buffer.flag = 1;
733   warning_buffer.index = 0;
734   cur_error_buffer = &warning_buffer;
735
736   va_start (argp, gmsgid);
737   error_print (_("Warning:"), _(gmsgid), argp);
738   va_end (argp);
739
740   error_char ('\0');
741
742   if (buffer_flag == 0)
743   {
744     warnings++;
745     if (warnings_are_errors)
746       gfc_increment_error_count();
747   }
748 }
749
750
751 /* Whether, for a feature included in a given standard set (GFC_STD_*),
752    we should issue an error or a warning, or be quiet.  */
753
754 notification
755 gfc_notification_std (int std)
756 {
757   bool warning;
758
759   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
760   if ((gfc_option.allow_std & std) != 0 && !warning)
761     return SILENT;
762
763   return warning ? WARNING : ERROR;
764 }
765
766
767 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
768    feature.  An error/warning will be issued if the currently selected
769    standard does not contain the requested bits.  Return FAILURE if
770    an error is generated.  */
771
772 gfc_try
773 gfc_notify_std (int std, const char *gmsgid, ...)
774 {
775   va_list argp;
776   bool warning;
777
778   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
779   if ((gfc_option.allow_std & std) != 0 && !warning)
780     return SUCCESS;
781
782   if (suppress_errors)
783     return warning ? SUCCESS : FAILURE;
784
785   cur_error_buffer = warning ? &warning_buffer : &error_buffer;
786   cur_error_buffer->flag = 1;
787   cur_error_buffer->index = 0;
788
789   va_start (argp, gmsgid);
790   if (warning)
791     error_print (_("Warning:"), _(gmsgid), argp);
792   else
793     error_print (_("Error:"), _(gmsgid), argp);
794   va_end (argp);
795
796   error_char ('\0');
797
798   if (buffer_flag == 0)
799     {
800       if (warning && !warnings_are_errors)
801         warnings++;
802       else
803         gfc_increment_error_count();
804     }
805
806   return (warning && !warnings_are_errors) ? SUCCESS : FAILURE;
807 }
808
809
810 /* Immediate warning (i.e. do not buffer the warning).  */
811
812 void
813 gfc_warning_now (const char *gmsgid, ...)
814 {
815   va_list argp;
816   int i;
817
818   if (inhibit_warnings)
819     return;
820
821   i = buffer_flag;
822   buffer_flag = 0;
823   warnings++;
824
825   va_start (argp, gmsgid);
826   error_print (_("Warning:"), _(gmsgid), argp);
827   va_end (argp);
828
829   error_char ('\0');
830
831   if (warnings_are_errors)
832     gfc_increment_error_count();
833
834   buffer_flag = i;
835 }
836
837
838 /* Clear the warning flag.  */
839
840 void
841 gfc_clear_warning (void)
842 {
843   warning_buffer.flag = 0;
844 }
845
846
847 /* Check to see if any warnings have been saved.
848    If so, print the warning.  */
849
850 void
851 gfc_warning_check (void)
852 {
853   if (warning_buffer.flag)
854     {
855       warnings++;
856       if (warning_buffer.message != NULL)
857         fputs (warning_buffer.message, stderr);
858       warning_buffer.flag = 0;
859     }
860 }
861
862
863 /* Issue an error.  */
864
865 void
866 gfc_error (const char *gmsgid, ...)
867 {
868   va_list argp;
869
870   if (warnings_not_errors)
871     goto warning;
872
873   if (suppress_errors)
874     return;
875
876   error_buffer.flag = 1;
877   error_buffer.index = 0;
878   cur_error_buffer = &error_buffer;
879
880   va_start (argp, gmsgid);
881   error_print (_("Error:"), _(gmsgid), argp);
882   va_end (argp);
883
884   error_char ('\0');
885
886   if (buffer_flag == 0)
887     gfc_increment_error_count();
888
889   return;
890
891 warning:
892
893   if (inhibit_warnings)
894     return;
895
896   warning_buffer.flag = 1;
897   warning_buffer.index = 0;
898   cur_error_buffer = &warning_buffer;
899
900   va_start (argp, gmsgid);
901   error_print (_("Warning:"), _(gmsgid), argp);
902   va_end (argp);
903
904   error_char ('\0');
905
906   if (buffer_flag == 0)
907   {
908     warnings++;
909     if (warnings_are_errors)
910       gfc_increment_error_count();
911   }
912 }
913
914
915 /* Immediate error.  */
916
917 void
918 gfc_error_now (const char *gmsgid, ...)
919 {
920   va_list argp;
921   int i;
922
923   error_buffer.flag = 1;
924   error_buffer.index = 0;
925   cur_error_buffer = &error_buffer;
926
927   i = buffer_flag;
928   buffer_flag = 0;
929
930   va_start (argp, gmsgid);
931   error_print (_("Error:"), _(gmsgid), argp);
932   va_end (argp);
933
934   error_char ('\0');
935
936   gfc_increment_error_count();
937
938   buffer_flag = i;
939
940   if (flag_fatal_errors)
941     exit (1);
942 }
943
944
945 /* Fatal error, never returns.  */
946
947 void
948 gfc_fatal_error (const char *gmsgid, ...)
949 {
950   va_list argp;
951
952   buffer_flag = 0;
953
954   va_start (argp, gmsgid);
955   error_print (_("Fatal Error:"), _(gmsgid), argp);
956   va_end (argp);
957
958   exit (3);
959 }
960
961
962 /* This shouldn't happen... but sometimes does.  */
963
964 void
965 gfc_internal_error (const char *format, ...)
966 {
967   va_list argp;
968
969   buffer_flag = 0;
970
971   va_start (argp, format);
972
973   show_loci (&gfc_current_locus, NULL);
974   error_printf ("Internal Error at (1):");
975
976   error_print ("", format, argp);
977   va_end (argp);
978
979   exit (ICE_EXIT_CODE);
980 }
981
982
983 /* Clear the error flag when we start to compile a source line.  */
984
985 void
986 gfc_clear_error (void)
987 {
988   error_buffer.flag = 0;
989   warnings_not_errors = 0;
990 }
991
992
993 /* Tests the state of error_flag.  */
994
995 int
996 gfc_error_flag_test (void)
997 {
998   return error_buffer.flag;
999 }
1000
1001
1002 /* Check to see if any errors have been saved.
1003    If so, print the error.  Returns the state of error_flag.  */
1004
1005 int
1006 gfc_error_check (void)
1007 {
1008   int rc;
1009
1010   rc = error_buffer.flag;
1011
1012   if (error_buffer.flag)
1013     {
1014       if (error_buffer.message != NULL)
1015         fputs (error_buffer.message, stderr);
1016       error_buffer.flag = 0;
1017
1018       gfc_increment_error_count();
1019
1020       if (flag_fatal_errors)
1021         exit (1);
1022     }
1023
1024   return rc;
1025 }
1026
1027
1028 /* Save the existing error state.  */
1029
1030 void
1031 gfc_push_error (gfc_error_buf *err)
1032 {
1033   err->flag = error_buffer.flag;
1034   if (error_buffer.flag)
1035     err->message = xstrdup (error_buffer.message);
1036
1037   error_buffer.flag = 0;
1038 }
1039
1040
1041 /* Restore a previous pushed error state.  */
1042
1043 void
1044 gfc_pop_error (gfc_error_buf *err)
1045 {
1046   error_buffer.flag = err->flag;
1047   if (error_buffer.flag)
1048     {
1049       size_t len = strlen (err->message) + 1;
1050       gcc_assert (len <= error_buffer.allocated);
1051       memcpy (error_buffer.message, err->message, len);
1052       gfc_free (err->message);
1053     }
1054 }
1055
1056
1057 /* Free a pushed error state, but keep the current error state.  */
1058
1059 void
1060 gfc_free_error (gfc_error_buf *err)
1061 {
1062   if (err->flag)
1063     gfc_free (err->message);
1064 }
1065
1066
1067 /* Report the number of warnings and errors that occurred to the caller.  */
1068
1069 void
1070 gfc_get_errors (int *w, int *e)
1071 {
1072   if (w != NULL)
1073     *w = warnings;
1074   if (e != NULL)
1075     *e = errors;
1076 }
1077
1078
1079 /* Switch errors into warnings.  */
1080
1081 void
1082 gfc_errors_to_warnings (int f)
1083 {
1084   warnings_not_errors = (f == 1) ? 1 : 0;
1085 }