1/* Handle errors.
2 Copyright (C) 2000-2025 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Niels Kristian Bech Jensen
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along 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 "options.h"
31#include "gfortran.h"
32
33#include "diagnostic.h"
34#include "diagnostic-color.h"
35#include "tree-diagnostic.h" /* tree_diagnostics_defaults */
36#include "diagnostic-format-text.h"
37
38static int suppress_errors = 0;
39
40static bool warnings_not_errors = false;
41
42/* True if the error/warnings should be buffered. */
43static bool buffered_p;
44
45static gfc_error_buffer *error_buffer;
46static diagnostic_buffer *pp_error_buffer, *pp_warning_buffer;
47
48gfc_error_buffer::gfc_error_buffer ()
49: flag (false), buffer (*global_dc)
50{
51}
52
53/* Return a location_t suitable for 'tree' for a gfortran locus. During
54 parsing in gfortran, loc->u.lb->location contains only the line number
55 and LOCATION_COLUMN is 0; hence, the column has to be added when generating
56 locations for 'tree'. If available, return location_t directly, which
57 might be a range. */
58
59location_t
60gfc_get_location_with_offset (locus *loc, unsigned offset)
61{
62 if (loc->nextc == (gfc_char_t *) -1)
63 {
64 gcc_checking_assert (offset == 0);
65 return loc->u.location;
66 }
67 gcc_checking_assert (loc->nextc >= loc->u.lb->line);
68 return linemap_position_for_loc_and_offset (set: line_table, loc: loc->u.lb->location,
69 offset: loc->nextc - loc->u.lb->line
70 + offset);
71}
72
73/* Convert a locus to a range. */
74
75locus
76gfc_get_location_range (locus *caret_loc, unsigned caret_offset,
77 locus *start_loc, unsigned start_offset,
78 locus *end_loc)
79{
80 location_t caret;
81 location_t start = gfc_get_location_with_offset (loc: start_loc, offset: start_offset);
82 location_t end = gfc_get_location_with_offset (loc: end_loc, offset: 0);
83
84 if (caret_loc)
85 caret = gfc_get_location_with_offset (loc: caret_loc, offset: caret_offset);
86
87 locus range;
88 range.nextc = (gfc_char_t *) -1;
89 range.u.location = make_location (caret: caret_loc ? caret : start, start, finish: end);
90 return range;
91}
92
93/* Return buffered_p. */
94bool
95gfc_buffered_p (void)
96{
97 return buffered_p;
98}
99
100/* Go one level deeper suppressing errors. */
101
102void
103gfc_push_suppress_errors (void)
104{
105 gcc_assert (suppress_errors >= 0);
106 ++suppress_errors;
107}
108
109static void
110gfc_error_opt (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
111
112static bool
113gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
114
115
116/* Leave one level of error suppressing. */
117
118void
119gfc_pop_suppress_errors (void)
120{
121 gcc_assert (suppress_errors > 0);
122 --suppress_errors;
123}
124
125
126/* Query whether errors are suppressed. */
127
128bool
129gfc_query_suppress_errors (void)
130{
131 return suppress_errors > 0;
132}
133
134
135/* Per-file error initialization. */
136
137void
138gfc_error_init_1 (void)
139{
140 gfc_buffer_error (false);
141}
142
143
144/* Set the flag for buffering errors or not. */
145
146void
147gfc_buffer_error (bool flag)
148{
149 buffered_p = flag;
150}
151
152
153static int
154print_wide_char_into_buffer (gfc_char_t c, char *buf)
155{
156 static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
157 '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
158
159 if (gfc_wide_is_printable (c) || c == '\t')
160 {
161 buf[1] = '\0';
162 /* Tabulation is output as a space. */
163 buf[0] = (unsigned char) (c == '\t' ? ' ' : c);
164 return 1;
165 }
166 else if (c < ((gfc_char_t) 1 << 8))
167 {
168 buf[4] = '\0';
169 buf[3] = xdigit[c & 0x0F];
170 c = c >> 4;
171 buf[2] = xdigit[c & 0x0F];
172
173 buf[1] = 'x';
174 buf[0] = '\\';
175 return 4;
176 }
177 else if (c < ((gfc_char_t) 1 << 16))
178 {
179 buf[6] = '\0';
180 buf[5] = xdigit[c & 0x0F];
181 c = c >> 4;
182 buf[4] = xdigit[c & 0x0F];
183 c = c >> 4;
184 buf[3] = xdigit[c & 0x0F];
185 c = c >> 4;
186 buf[2] = xdigit[c & 0x0F];
187
188 buf[1] = 'u';
189 buf[0] = '\\';
190 return 6;
191 }
192 else
193 {
194 buf[10] = '\0';
195 buf[9] = xdigit[c & 0x0F];
196 c = c >> 4;
197 buf[8] = xdigit[c & 0x0F];
198 c = c >> 4;
199 buf[7] = xdigit[c & 0x0F];
200 c = c >> 4;
201 buf[6] = xdigit[c & 0x0F];
202 c = c >> 4;
203 buf[5] = xdigit[c & 0x0F];
204 c = c >> 4;
205 buf[4] = xdigit[c & 0x0F];
206 c = c >> 4;
207 buf[3] = xdigit[c & 0x0F];
208 c = c >> 4;
209 buf[2] = xdigit[c & 0x0F];
210
211 buf[1] = 'U';
212 buf[0] = '\\';
213 return 10;
214 }
215}
216
217static char wide_char_print_buffer[11];
218
219const char *
220gfc_print_wide_char (gfc_char_t c)
221{
222 print_wide_char_into_buffer (c, buf: wide_char_print_buffer);
223 return wide_char_print_buffer;
224}
225
226
227/* Clear any output buffered in THIS_BUFFER without issuing
228 it to global_dc. */
229
230static void
231gfc_clear_diagnostic_buffer (diagnostic_buffer *this_buffer)
232{
233 gcc_assert (this_buffer);
234 global_dc->clear_diagnostic_buffer (*this_buffer);
235}
236
237/* The currently-printing diagnostic, for use by gfc_format_decoder,
238 for colorizing %C and %L. */
239
240static diagnostic_info *curr_diagnostic;
241
242/* A helper function to call diagnostic_report_diagnostic, while setting
243 curr_diagnostic for the duration of the call. */
244
245static bool
246gfc_report_diagnostic (diagnostic_info *diagnostic)
247{
248 gcc_assert (diagnostic != NULL);
249 curr_diagnostic = diagnostic;
250 bool ret = diagnostic_report_diagnostic (context: global_dc, diagnostic);
251 curr_diagnostic = NULL;
252 return ret;
253}
254
255/* This is just a helper function to avoid duplicating the logic of
256 gfc_warning. */
257
258static bool
259gfc_warning (int opt, const char *gmsgid, va_list ap)
260{
261 va_list argp;
262 va_copy (argp, ap);
263
264 diagnostic_info diagnostic;
265 rich_location rich_loc (line_table, UNKNOWN_LOCATION);
266 diagnostic_buffer *old_buffer = global_dc->get_diagnostic_buffer ();
267 gcc_assert (!old_buffer);
268
269 gfc_clear_diagnostic_buffer (this_buffer: pp_warning_buffer);
270
271 if (buffered_p)
272 global_dc->set_diagnostic_buffer (pp_warning_buffer);
273
274 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
275 DK_WARNING);
276 diagnostic.option_id = opt;
277 bool ret = gfc_report_diagnostic (diagnostic: &diagnostic);
278
279 if (buffered_p)
280 global_dc->set_diagnostic_buffer (old_buffer);
281
282 va_end (argp);
283 return ret;
284}
285
286/* Issue a warning. */
287
288bool
289gfc_warning (int opt, const char *gmsgid, ...)
290{
291 va_list argp;
292
293 va_start (argp, gmsgid);
294 bool ret = gfc_warning (opt, gmsgid, ap: argp);
295 va_end (argp);
296 return ret;
297}
298
299
300/* Whether, for a feature included in a given standard set (GFC_STD_*),
301 we should issue an error or a warning, or be quiet. */
302
303notification
304gfc_notification_std (int std)
305{
306 bool warning;
307
308 warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
309 if ((gfc_option.allow_std & std) != 0 && !warning)
310 return SILENT;
311
312 return warning ? WARNING : ERROR;
313}
314
315
316/* Return a string describing the nature of a standard violation
317 * and/or the relevant version of the standard. */
318
319char const*
320notify_std_msg(int std)
321{
322
323 if (std & GFC_STD_F2023_DEL)
324 return _("Prohibited in Fortran 2023:");
325 else if (std & GFC_STD_F2023)
326 return _("Fortran 2023:");
327 else if (std & GFC_STD_F2018_DEL)
328 return _("Fortran 2018 deleted feature:");
329 else if (std & GFC_STD_F2018_OBS)
330 return _("Fortran 2018 obsolescent feature:");
331 else if (std & GFC_STD_F2018)
332 return _("Fortran 2018:");
333 else if (std & GFC_STD_F2008_OBS)
334 return _("Fortran 2008 obsolescent feature:");
335 else if (std & GFC_STD_F2008)
336 return "Fortran 2008:";
337 else if (std & GFC_STD_F2003)
338 return "Fortran 2003:";
339 else if (std & GFC_STD_GNU)
340 return _("GNU Extension:");
341 else if (std & GFC_STD_LEGACY)
342 return _("Legacy Extension:");
343 else if (std & GFC_STD_F95_OBS)
344 return _("Obsolescent feature:");
345 else if (std & GFC_STD_F95_DEL)
346 return _("Deleted feature:");
347 else if (std & GFC_STD_UNSIGNED)
348 return _("Unsigned:");
349 else
350 gcc_unreachable ();
351}
352
353
354/* Possibly issue a warning/error about use of a nonstandard (or deleted)
355 feature. An error/warning will be issued if the currently selected
356 standard does not contain the requested bits. Return false if
357 an error is generated. */
358
359bool
360gfc_notify_std (int std, const char *gmsgid, ...)
361{
362 va_list argp;
363 const char *msg, *msg2;
364 char *buffer;
365
366 /* Determine whether an error or a warning is needed. */
367 const int wstd = std & gfc_option.warn_std; /* Standard to warn about. */
368 const int estd = std & ~gfc_option.allow_std; /* Standard to error about. */
369 const bool warning = (wstd != 0) && !inhibit_warnings;
370 const bool error = (estd != 0);
371
372 if (!error && !warning)
373 return true;
374 if (suppress_errors)
375 return !error;
376
377 if (error)
378 msg = notify_std_msg (std: estd);
379 else
380 msg = notify_std_msg (std: wstd);
381
382 msg2 = _(gmsgid);
383 buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2);
384 strcpy (dest: buffer, src: msg);
385 strcat (dest: buffer, src: " ");
386 strcat (dest: buffer, src: msg2);
387
388 va_start (argp, gmsgid);
389 if (error)
390 gfc_error_opt (opt: 0, gmsgid: buffer, ap: argp);
391 else
392 gfc_warning (opt: 0, gmsgid: buffer, ap: argp);
393 va_end (argp);
394
395 if (error)
396 return false;
397 else
398 return (warning && !warnings_are_errors);
399}
400
401
402/* Called from output_format -- during diagnostic message processing
403 to handle Fortran specific format specifiers with the following meanings:
404
405 %C Current locus (no argument)
406 %L Takes locus argument
407*/
408static bool
409gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec,
410 int precision, bool wide, bool set_locus, bool hash,
411 bool *quoted, pp_token_list &formatted_token_list)
412{
413 unsigned offset = 0;
414 switch (*spec)
415 {
416 case 'C':
417 case 'L':
418 {
419 static const char *result[2] = { "(1)", "(2)" };
420 locus *loc;
421 if (*spec == 'C')
422 {
423 loc = &gfc_current_locus;
424 /* Point %C first offending character not the last good one. */
425 if (*loc->nextc != '\0')
426 offset++;
427 }
428 else
429 loc = va_arg (*text->m_args_ptr, locus *);
430
431 /* If location[0] != UNKNOWN_LOCATION means that we already
432 processed one of %C/%L. */
433 int loc_num = text->get_location (index_of_location: 0) == UNKNOWN_LOCATION ? 0 : 1;
434 location_t src_loc = gfc_get_location_with_offset (loc, offset);
435 text->set_location (idx: loc_num, loc: src_loc, range_display_kind: SHOW_RANGE_WITH_CARET);
436 /* Colorize the markers to match the color choices of
437 diagnostic_show_locus (the initial location has a color given
438 by the "kind" of the diagnostic, the secondary location has
439 color "range1"). */
440 gcc_assert (curr_diagnostic != NULL);
441 const char *color
442 = (loc_num
443 ? "range1"
444 : diagnostic_get_color_for_kind (kind: curr_diagnostic->kind));
445 pp_string (pp, colorize_start (show_color: pp_show_color (pp), name: color));
446 pp_string (pp, result[loc_num]);
447 pp_string (pp, colorize_stop (pp_show_color (pp)));
448 return true;
449 }
450 default:
451 /* Fall through info the middle-end decoder, as e.g. stor-layout.cc
452 etc. diagnostics can use the FE printer while the FE is still
453 active. */
454 return default_tree_printer (pp, text, spec, precision, wide,
455 set_locus, hash, quoted,
456 formatted_token_list);
457 }
458}
459
460/* Return a malloc'd string describing the kind of diagnostic. The
461 caller is responsible for freeing the memory. */
462static char *
463gfc_diagnostic_build_kind_prefix (diagnostic_context *context,
464 const diagnostic_info *diagnostic)
465{
466 static const char *const diagnostic_kind_text[] = {
467#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T),
468#include "gfc-diagnostic.def"
469#undef DEFINE_DIAGNOSTIC_KIND
470 "must-not-happen"
471 };
472 static const char *const diagnostic_kind_color[] = {
473#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C),
474#include "gfc-diagnostic.def"
475#undef DEFINE_DIAGNOSTIC_KIND
476 NULL
477 };
478 gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND);
479 const char *text = _(diagnostic_kind_text[diagnostic->kind]);
480 const char *text_cs = "", *text_ce = "";
481 pretty_printer *const pp = context->get_reference_printer ();
482
483 if (diagnostic_kind_color[diagnostic->kind])
484 {
485 text_cs = colorize_start (show_color: pp_show_color (pp),
486 name: diagnostic_kind_color[diagnostic->kind]);
487 text_ce = colorize_stop (pp_show_color (pp));
488 }
489 return build_message_string ("%s%s:%s ", text_cs, text, text_ce);
490}
491
492/* Return a malloc'd string describing a location. The caller is
493 responsible for freeing the memory. */
494static char *
495gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_policy,
496 expanded_location s,
497 bool colorize)
498{
499 const char *locus_cs = colorize_start (show_color: colorize, name: "locus");
500 const char *locus_ce = colorize_stop (colorize);
501 return (s.file == NULL
502 ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
503 : !strcmp (s1: s.file, s2: special_fname_builtin ())
504 ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
505 : loc_policy.show_column_p ()
506 ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line,
507 s.column, locus_ce)
508 : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce));
509}
510
511/* Return a malloc'd string describing two locations. The caller is
512 responsible for freeing the memory. */
513static char *
514gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_policy,
515 expanded_location s, expanded_location s2,
516 bool colorize)
517{
518 const char *locus_cs = colorize_start (show_color: colorize, name: "locus");
519 const char *locus_ce = colorize_stop (colorize);
520
521 return (s.file == NULL
522 ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
523 : !strcmp (s1: s.file, s2: special_fname_builtin ())
524 ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
525 : loc_policy.show_column_p ()
526 ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line,
527 MIN (s.column, s2.column),
528 MAX (s.column, s2.column), locus_ce)
529 : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line,
530 locus_ce));
531}
532
533/* This function prints the locus (file:line:column), the diagnostic kind
534 (Error, Warning) and (optionally) the relevant lines of code with
535 annotation lines with '1' and/or '2' below them.
536
537 With -fdiagnostic-show-caret (the default) it prints:
538
539 [locus of primary range]:
540
541 some code
542 1
543 Error: Some error at (1)
544
545 With -fno-diagnostic-show-caret or if the primary range is not
546 valid, it prints:
547
548 [locus of primary range]: Error: Some error at (1) and (2)
549*/
550static void
551gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output,
552 const diagnostic_info *diagnostic)
553{
554 diagnostic_context *const context = &text_output.get_context ();
555 pretty_printer *const pp = text_output.get_printer ();
556 char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic);
557
558 expanded_location s1 = diagnostic_expand_location (diagnostic);
559 expanded_location s2;
560 bool one_locus = diagnostic->richloc->get_num_locations () < 2;
561 bool same_locus = false;
562
563 if (!one_locus)
564 {
565 s2 = diagnostic_expand_location (diagnostic, which: 1);
566 same_locus = diagnostic_same_line (context, s1, s2);
567 }
568
569 diagnostic_location_print_policy loc_policy (text_output);
570 const bool colorize = pp_show_color (pp);
571 char * locus_prefix = (one_locus || !same_locus)
572 ? gfc_diagnostic_build_locus_prefix (loc_policy, s: s1, colorize)
573 : gfc_diagnostic_build_locus_prefix (loc_policy, s: s1, s2, colorize);
574
575 if (!context->m_source_printing.enabled
576 || diagnostic_location (diagnostic, which: 0) <= BUILTINS_LOCATION
577 || diagnostic_location (diagnostic, which: 0) == context->m_last_location)
578 {
579 pp_set_prefix (pp,
580 prefix: concat (locus_prefix, " ", kind_prefix, NULL));
581 free (ptr: locus_prefix);
582
583 if (one_locus || same_locus)
584 {
585 free (ptr: kind_prefix);
586 return;
587 }
588 /* In this case, we print the previous locus and prefix as:
589
590 [locus]:[prefix]: (1)
591
592 and we flush with a new line before setting the new prefix. */
593 pp_string (pp, "(1)");
594 pp_newline (pp);
595 locus_prefix = gfc_diagnostic_build_locus_prefix (loc_policy, s: s2, colorize);
596 pp_set_prefix (pp,
597 prefix: concat (locus_prefix, " ", kind_prefix, NULL));
598 free (ptr: kind_prefix);
599 free (ptr: locus_prefix);
600 }
601 else
602 {
603 pp_verbatim (pp, "%s", locus_prefix);
604 free (ptr: locus_prefix);
605 /* Fortran uses an empty line between locus and caret line. */
606 pp_newline (pp);
607 pp_set_prefix (pp, NULL);
608 pp_newline (pp);
609 diagnostic_show_locus (context,
610 opts: text_output.get_source_printing_options (),
611 richloc: diagnostic->richloc, diagnostic_kind: diagnostic->kind,
612 pp);
613 /* If the caret line was shown, the prefix does not contain the
614 locus. */
615 pp_set_prefix (pp, prefix: kind_prefix);
616 }
617}
618
619static void
620gfc_diagnostic_start_span (const diagnostic_location_print_policy &loc_policy,
621 to_text &sink,
622 expanded_location exploc)
623{
624 pretty_printer *pp = get_printer (sink);
625 const bool colorize = pp_show_color (pp);
626 char *locus_prefix
627 = gfc_diagnostic_build_locus_prefix (loc_policy, s: exploc, colorize);
628 pp_verbatim (pp, "%s", locus_prefix);
629 free (ptr: locus_prefix);
630 pp_newline (pp);
631 /* Fortran uses an empty line between locus and caret line. */
632 pp_newline (pp);
633}
634
635
636static void
637gfc_diagnostic_text_finalizer (diagnostic_text_output_format &text_output,
638 const diagnostic_info *diagnostic ATTRIBUTE_UNUSED,
639 diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED)
640{
641 pretty_printer *const pp = text_output.get_printer ();
642 pp_destroy_prefix (pp);
643 pp_newline_and_flush (pp);
644}
645
646/* Immediate warning (i.e. do not buffer the warning) with an explicit
647 location. */
648
649bool
650gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...)
651{
652 va_list argp;
653 diagnostic_info diagnostic;
654 rich_location rich_loc (line_table, loc);
655 bool ret;
656
657 va_start (argp, gmsgid);
658 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING);
659 diagnostic.option_id = opt;
660 ret = gfc_report_diagnostic (diagnostic: &diagnostic);
661 va_end (argp);
662 return ret;
663}
664
665/* Immediate warning (i.e. do not buffer the warning). */
666
667bool
668gfc_warning_now (int opt, const char *gmsgid, ...)
669{
670 va_list argp;
671 diagnostic_info diagnostic;
672 rich_location rich_loc (line_table, UNKNOWN_LOCATION);
673 bool ret;
674
675 va_start (argp, gmsgid);
676 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
677 DK_WARNING);
678 diagnostic.option_id = opt;
679 ret = gfc_report_diagnostic (diagnostic: &diagnostic);
680 va_end (argp);
681 return ret;
682}
683
684/* Internal warning, do not buffer. */
685
686bool
687gfc_warning_internal (int opt, const char *gmsgid, ...)
688{
689 va_list argp;
690 diagnostic_info diagnostic;
691 rich_location rich_loc (line_table, UNKNOWN_LOCATION);
692 bool ret;
693
694 va_start (argp, gmsgid);
695 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
696 DK_WARNING);
697 diagnostic.option_id = opt;
698 ret = gfc_report_diagnostic (diagnostic: &diagnostic);
699 va_end (argp);
700 return ret;
701}
702
703/* Immediate error (i.e. do not buffer). */
704
705void
706gfc_error_now (const char *gmsgid, ...)
707{
708 va_list argp;
709 diagnostic_info diagnostic;
710 rich_location rich_loc (line_table, UNKNOWN_LOCATION);
711
712 error_buffer->flag = true;
713
714 va_start (argp, gmsgid);
715 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR);
716 gfc_report_diagnostic (diagnostic: &diagnostic);
717 va_end (argp);
718}
719
720
721/* Fatal error, never returns. */
722
723void
724gfc_fatal_error (const char *gmsgid, ...)
725{
726 va_list argp;
727 diagnostic_info diagnostic;
728 rich_location rich_loc (line_table, UNKNOWN_LOCATION);
729
730 va_start (argp, gmsgid);
731 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL);
732 gfc_report_diagnostic (diagnostic: &diagnostic);
733 va_end (argp);
734
735 gcc_unreachable ();
736}
737
738/* Clear the warning flag. */
739
740void
741gfc_clear_warning (void)
742{
743 gfc_clear_diagnostic_buffer (this_buffer: pp_warning_buffer);
744}
745
746
747/* Check to see if any warnings have been saved.
748 If so, print the warning. */
749
750void
751gfc_warning_check (void)
752{
753 if (! pp_warning_buffer->empty_p ())
754 global_dc->flush_diagnostic_buffer (*pp_warning_buffer);
755}
756
757
758/* Issue an error. */
759
760static void
761gfc_error_opt (int opt, const char *gmsgid, va_list ap)
762{
763 va_list argp;
764 va_copy (argp, ap);
765
766 if (warnings_not_errors)
767 {
768 gfc_warning (opt, gmsgid, ap: argp);
769 va_end (argp);
770 return;
771 }
772
773 if (suppress_errors)
774 {
775 va_end (argp);
776 return;
777 }
778
779 diagnostic_info diagnostic;
780 rich_location richloc (line_table, UNKNOWN_LOCATION);
781 diagnostic_buffer *old_buffer = global_dc->get_diagnostic_buffer ();
782 gcc_assert (!old_buffer);
783
784 gfc_clear_diagnostic_buffer (this_buffer: pp_error_buffer);
785
786 if (buffered_p)
787 global_dc->set_diagnostic_buffer (pp_error_buffer);
788
789 diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR);
790 gfc_report_diagnostic (diagnostic: &diagnostic);
791
792 if (buffered_p)
793 global_dc->set_diagnostic_buffer (old_buffer);
794
795 va_end (argp);
796}
797
798
799void
800gfc_error_opt (int opt, const char *gmsgid, ...)
801{
802 va_list argp;
803 va_start (argp, gmsgid);
804 gfc_error_opt (opt, gmsgid, ap: argp);
805 va_end (argp);
806}
807
808
809void
810gfc_error (const char *gmsgid, ...)
811{
812 va_list argp;
813 va_start (argp, gmsgid);
814 gfc_error_opt (opt: 0, gmsgid, ap: argp);
815 va_end (argp);
816}
817
818
819/* This shouldn't happen... but sometimes does. */
820
821void
822gfc_internal_error (const char *gmsgid, ...)
823{
824 int e, w;
825 va_list argp;
826 diagnostic_info diagnostic;
827 rich_location rich_loc (line_table, UNKNOWN_LOCATION);
828
829 gfc_get_errors (&w, &e);
830 if (e > 0)
831 exit(EXIT_FAILURE);
832
833 va_start (argp, gmsgid);
834 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE);
835 gfc_report_diagnostic (diagnostic: &diagnostic);
836 va_end (argp);
837
838 gcc_unreachable ();
839}
840
841
842/* Clear the error flag when we start to compile a source line. */
843
844void
845gfc_clear_error (void)
846{
847 error_buffer->flag = false;
848 warnings_not_errors = false;
849 gfc_clear_diagnostic_buffer (this_buffer: pp_error_buffer);
850}
851
852
853/* Tests the state of error_flag. */
854
855bool
856gfc_error_flag_test (void)
857{
858 return (error_buffer->flag
859 || !pp_error_buffer->empty_p ());
860}
861
862
863/* Check to see if any errors have been saved.
864 If so, print the error. Returns the state of error_flag. */
865
866bool
867gfc_error_check (void)
868{
869 if (error_buffer->flag
870 || ! pp_error_buffer->empty_p ())
871 {
872 error_buffer->flag = false;
873 global_dc->flush_diagnostic_buffer (*pp_error_buffer);
874 return true;
875 }
876
877 return false;
878}
879
880/* Move the text buffered from FROM to TO, then clear
881 FROM. Independently if there was text in FROM, TO is also
882 cleared. */
883
884static void
885gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from,
886 gfc_error_buffer * buffer_to)
887{
888 diagnostic_buffer * from = &(buffer_from->buffer);
889 diagnostic_buffer * to = &(buffer_to->buffer);
890
891 buffer_to->flag = buffer_from->flag;
892 buffer_from->flag = false;
893
894 gfc_clear_diagnostic_buffer (this_buffer: to);
895
896 if (! from->empty_p ())
897 {
898 from->move_to (dest&: *to);
899 gfc_clear_diagnostic_buffer (this_buffer: from);
900 }
901}
902
903/* Save the existing error state. */
904
905void
906gfc_push_error (gfc_error_buffer *err)
907{
908 gfc_move_error_buffer_from_to (buffer_from: error_buffer, buffer_to: err);
909}
910
911
912/* Restore a previous pushed error state. */
913
914void
915gfc_pop_error (gfc_error_buffer *err)
916{
917 gfc_move_error_buffer_from_to (buffer_from: err, buffer_to: error_buffer);
918}
919
920
921/* Free a pushed error state, but keep the current error state. */
922
923void
924gfc_free_error (gfc_error_buffer *err)
925{
926 gfc_clear_diagnostic_buffer (this_buffer: &(err->buffer));
927}
928
929
930/* Report the number of warnings and errors that occurred to the caller. */
931
932void
933gfc_get_errors (int *w, int *e)
934{
935 if (w != NULL)
936 *w = warningcount + werrorcount;
937 if (e != NULL)
938 *e = errorcount + sorrycount + werrorcount;
939}
940
941
942/* Switch errors into warnings. */
943
944void
945gfc_errors_to_warnings (bool f)
946{
947 warnings_not_errors = f;
948}
949
950void
951gfc_diagnostics_init (void)
952{
953 diagnostic_text_starter (context: global_dc) = gfc_diagnostic_text_starter;
954 diagnostic_start_span (context: global_dc) = gfc_diagnostic_start_span;
955 diagnostic_text_finalizer (context: global_dc) = gfc_diagnostic_text_finalizer;
956 global_dc->set_format_decoder (gfc_format_decoder);
957 global_dc->m_source_printing.caret_chars[0] = '1';
958 global_dc->m_source_printing.caret_chars[1] = '2';
959 pp_warning_buffer = new diagnostic_buffer (*global_dc);
960 error_buffer = new gfc_error_buffer ();
961 pp_error_buffer = &(error_buffer->buffer);
962}
963
964void
965gfc_diagnostics_finish (void)
966{
967 tree_diagnostics_defaults (context: global_dc);
968 /* We still want to use the gfc starter and finalizer, not the tree
969 defaults. */
970 diagnostic_text_starter (context: global_dc) = gfc_diagnostic_text_starter;
971 diagnostic_text_finalizer (context: global_dc) = gfc_diagnostic_text_finalizer;
972 global_dc->m_source_printing.caret_chars[0] = '^';
973 global_dc->m_source_printing.caret_chars[1] = '^';
974 delete error_buffer;
975 error_buffer = nullptr;
976 pp_error_buffer = nullptr;
977}
978

source code of gcc/fortran/error.cc