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