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