Branch data Line data Source code
1 : : /* Handle errors.
2 : : Copyright (C) 2000-2025 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 : 8374603 : gfc_error_buffer::gfc_error_buffer ()
50 : 8374603 : : flag (false), buffer (*global_dc)
51 : : {
52 : 8374603 : }
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 : 19977303 : gfc_get_location_with_offset (locus *loc, unsigned offset)
62 : : {
63 : 19977303 : if (loc->nextc == (gfc_char_t *) -1)
64 : : {
65 : 402082 : gcc_checking_assert (offset == 0);
66 : 402082 : return loc->u.location;
67 : : }
68 : 19575221 : gcc_checking_assert (loc->nextc >= loc->u.lb->line);
69 : 19575221 : return linemap_position_for_loc_and_offset (line_table, loc->u.lb->location,
70 : 19575221 : loc->nextc - loc->u.lb->line
71 : 19575221 : + offset);
72 : : }
73 : :
74 : : /* Convert a locus to a range. */
75 : :
76 : : locus
77 : 7538616 : gfc_get_location_range (locus *caret_loc, unsigned caret_offset,
78 : : locus *start_loc, unsigned start_offset,
79 : : locus *end_loc)
80 : : {
81 : 7538616 : location_t caret;
82 : 7538616 : location_t start = gfc_get_location_with_offset (start_loc, start_offset);
83 : 7538616 : location_t end = gfc_get_location_with_offset (end_loc, 0);
84 : :
85 : 7538616 : 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 : 7538616 : range.u.location = make_location (caret_loc ? caret : start, start, end);
91 : 7538616 : 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 : 457658 : gfc_push_suppress_errors (void)
105 : : {
106 : 457658 : gcc_assert (suppress_errors >= 0);
107 : 457658 : ++suppress_errors;
108 : 457658 : }
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 : 457658 : gfc_pop_suppress_errors (void)
121 : : {
122 : 457658 : gcc_assert (suppress_errors > 0);
123 : 457658 : --suppress_errors;
124 : 457658 : }
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 : 30852 : gfc_error_init_1 (void)
140 : : {
141 : 30852 : gfc_buffer_error (false);
142 : 30852 : }
143 : :
144 : :
145 : : /* Set the flag for buffering errors or not. */
146 : :
147 : : void
148 : 6240041 : gfc_buffer_error (bool flag)
149 : : {
150 : 6240041 : buffered_p = flag;
151 : 6240041 : }
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 : 22877705 : gfc_clear_diagnostic_buffer (diagnostics::buffer *this_buffer)
233 : : {
234 : 22877705 : gcc_assert (this_buffer);
235 : 22877705 : global_dc->clear_diagnostic_buffer (*this_buffer);
236 : 22877705 : }
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 : 1232915 : gfc_report_diagnostic (diagnostics::diagnostic_info *diagnostic)
248 : : {
249 : 1232915 : gcc_assert (diagnostic != NULL);
250 : 1232915 : curr_diagnostic = diagnostic;
251 : 1232915 : bool ret = diagnostic_report_diagnostic (global_dc, diagnostic);
252 : 1232905 : curr_diagnostic = NULL;
253 : 1232905 : 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 : 20264 : gfc_warning (int opt, const char *gmsgid, va_list ap)
261 : : {
262 : 20264 : va_list argp;
263 : 20264 : va_copy (argp, ap);
264 : :
265 : 20264 : diagnostics::diagnostic_info diagnostic;
266 : 20264 : rich_location rich_loc (line_table, UNKNOWN_LOCATION);
267 : 20264 : diagnostics::buffer *old_buffer = global_dc->get_diagnostic_buffer ();
268 : 20264 : gcc_assert (!old_buffer);
269 : :
270 : 20264 : gfc_clear_diagnostic_buffer (pp_warning_buffer);
271 : :
272 : 20264 : if (buffered_p)
273 : 15985 : global_dc->set_diagnostic_buffer (pp_warning_buffer);
274 : :
275 : 20264 : diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
276 : : diagnostics::kind::warning);
277 : 20264 : diagnostic.m_option_id = opt;
278 : 20264 : bool ret = gfc_report_diagnostic (&diagnostic);
279 : :
280 : 20264 : if (buffered_p)
281 : 15985 : global_dc->set_diagnostic_buffer (old_buffer);
282 : :
283 : 20264 : va_end (argp);
284 : 40528 : return ret;
285 : 20264 : }
286 : :
287 : : /* Issue a warning. */
288 : :
289 : : bool
290 : 4413 : gfc_warning (int opt, const char *gmsgid, ...)
291 : : {
292 : 4413 : va_list argp;
293 : :
294 : 4413 : va_start (argp, gmsgid);
295 : 4413 : bool ret = gfc_warning (opt, gmsgid, argp);
296 : 4413 : va_end (argp);
297 : 4413 : 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 : 253894 : gfc_notification_std (int std)
306 : : {
307 : 253894 : bool warning;
308 : :
309 : 253894 : warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
310 : 253894 : 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 : 16550 : notify_std_msg(int std)
322 : : {
323 : :
324 : 16550 : if (std & GFC_STD_F2023_DEL)
325 : 10 : return _("Prohibited in Fortran 2023:");
326 : 16540 : else if (std & GFC_STD_F2023)
327 : 9 : return _("Fortran 2023:");
328 : 16531 : else if (std & GFC_STD_F2018_DEL)
329 : 1 : return _("Fortran 2018 deleted feature:");
330 : 16530 : else if (std & GFC_STD_F2018_OBS)
331 : 8 : return _("Fortran 2018 obsolescent feature:");
332 : 16522 : else if (std & GFC_STD_F2018)
333 : 119 : return _("Fortran 2018:");
334 : 16403 : else if (std & GFC_STD_F2008_OBS)
335 : 2 : return _("Fortran 2008 obsolescent feature:");
336 : 16401 : else if (std & GFC_STD_F2008)
337 : : return "Fortran 2008:";
338 : 16011 : else if (std & GFC_STD_F2003)
339 : : return "Fortran 2003:";
340 : 15886 : else if (std & GFC_STD_GNU)
341 : 378 : return _("GNU Extension:");
342 : 15508 : else if (std & GFC_STD_LEGACY)
343 : 11560 : return _("Legacy Extension:");
344 : 3948 : else if (std & GFC_STD_F95_OBS)
345 : 3817 : 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 : 336276 : gfc_notify_std (int std, const char *gmsgid, ...)
362 : : {
363 : 336276 : va_list argp;
364 : 336276 : const char *msg, *msg2;
365 : 336276 : char *buffer;
366 : :
367 : : /* Determine whether an error or a warning is needed. */
368 : 336276 : const int wstd = std & gfc_option.warn_std; /* Standard to warn about. */
369 : 336276 : const int estd = std & ~gfc_option.allow_std; /* Standard to error about. */
370 : 336276 : const bool warning = (wstd != 0) && !inhibit_warnings;
371 : 336276 : const bool error = (estd != 0);
372 : :
373 : 336276 : if (!error && !warning)
374 : : return true;
375 : 16551 : if (suppress_errors)
376 : : return !error;
377 : :
378 : 16550 : if (error)
379 : 742 : msg = notify_std_msg (estd);
380 : : else
381 : 15808 : msg = notify_std_msg (wstd);
382 : :
383 : 16550 : msg2 = _(gmsgid);
384 : 16550 : buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2);
385 : 16550 : strcpy (buffer, msg);
386 : 16550 : strcat (buffer, " ");
387 : 16550 : strcat (buffer, msg2);
388 : :
389 : 16550 : va_start (argp, gmsgid);
390 : 16550 : if (error)
391 : 742 : gfc_error_opt (0, buffer, argp);
392 : : else
393 : 15808 : gfc_warning (0, buffer, argp);
394 : 16550 : va_end (argp);
395 : :
396 : 16550 : if (error)
397 : : return false;
398 : : else
399 : 15811 : 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 : 1205073 : 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 : 1205073 : unsigned offset = 0;
415 : 1205073 : switch (*spec)
416 : : {
417 : 1205050 : case 'C':
418 : 1205050 : case 'L':
419 : 1205050 : {
420 : 1205050 : static const char *result[2] = { "(1)", "(2)" };
421 : 1205050 : locus *loc;
422 : 1205050 : if (*spec == 'C')
423 : : {
424 : 1188159 : loc = &gfc_current_locus;
425 : : /* Point %C first offending character not the last good one. */
426 : 1188159 : if (*loc->nextc != '\0')
427 : 1125122 : offset++;
428 : : }
429 : : else
430 : 16891 : 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 : 1205050 : int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1;
435 : 1205050 : location_t src_loc = gfc_get_location_with_offset (loc, offset);
436 : 1205050 : 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 : 1205050 : gcc_assert (curr_diagnostic != NULL);
442 : 1205050 : const char *color
443 : : = (loc_num
444 : 1205050 : ? "range1"
445 : 1204534 : : diagnostics::get_color_for_kind (curr_diagnostic->m_kind));
446 : 1205050 : pp_string (pp, colorize_start (pp_show_color (pp), color));
447 : 1205050 : pp_string (pp, result[loc_num]);
448 : 1205050 : pp_string (pp, colorize_stop (pp_show_color (pp)));
449 : 1205050 : 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 : 1207578 : gfc_diagnostic_build_kind_prefix (diagnostics::context *context,
465 : : const diagnostics::diagnostic_info *diagnostic)
466 : : {
467 : 1207578 : 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 : 1207578 : 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 : 1207578 : const int diag_kind_idx = static_cast<int> (diagnostic->m_kind);
480 : 1207578 : gcc_assert (diagnostic->m_kind < diagnostics::kind::last_diagnostic_kind);
481 : 1207578 : const char *text = _(diagnostic_kind_text[diag_kind_idx]);
482 : 1207578 : const char *text_cs = "", *text_ce = "";
483 : 1207578 : pretty_printer *const pp = context->get_reference_printer ();
484 : :
485 : 1207578 : if (diagnostic_kind_color[diag_kind_idx])
486 : : {
487 : 2415156 : text_cs = colorize_start (pp_show_color (pp),
488 : 1207578 : diagnostic_kind_color[diag_kind_idx]);
489 : 1207578 : text_ce = colorize_stop (pp_show_color (pp));
490 : : }
491 : 1207578 : 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 : 1207735 : gfc_diagnostic_build_locus_prefix (const diagnostics::location_print_policy &loc_policy,
498 : : expanded_location s,
499 : : bool colorize)
500 : : {
501 : 1207735 : const char *locus_cs = colorize_start (colorize, "locus");
502 : 1207735 : const char *locus_ce = colorize_stop (colorize);
503 : 1207735 : return (s.file == NULL
504 : 1207735 : ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
505 : 1207668 : : !strcmp (s.file, special_fname_builtin ())
506 : 1207668 : ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
507 : 1207658 : : loc_policy.show_column_p ()
508 : 1207658 : ? 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 : 179 : gfc_diagnostic_build_locus_prefix (const diagnostics::location_print_policy &loc_policy,
517 : : expanded_location s, expanded_location s2,
518 : : bool colorize)
519 : : {
520 : 179 : const char *locus_cs = colorize_start (colorize, "locus");
521 : 179 : const char *locus_ce = colorize_stop (colorize);
522 : :
523 : 179 : return (s.file == NULL
524 : 179 : ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
525 : 179 : : !strcmp (s.file, special_fname_builtin ())
526 : 179 : ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
527 : 179 : : loc_policy.show_column_p ()
528 : 179 : ? 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 : 179 : 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 : 1207578 : gfc_diagnostic_text_starter (diagnostics::text_sink &text_output,
554 : : const diagnostics::diagnostic_info *diagnostic)
555 : : {
556 : 1207578 : diagnostics::context *const context = &text_output.get_context ();
557 : 1207578 : pretty_printer *const pp = text_output.get_printer ();
558 : 1207578 : char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic);
559 : :
560 : 1207578 : expanded_location s1 = diagnostic_expand_location (diagnostic);
561 : 1207578 : expanded_location s2;
562 : 1207578 : bool one_locus = diagnostic->m_richloc->get_num_locations () < 2;
563 : 1207578 : bool same_locus = false;
564 : :
565 : 1207578 : if (!one_locus)
566 : : {
567 : 516 : s2 = diagnostic_expand_location (diagnostic, 1);
568 : 1032 : same_locus = diagnostic_same_line (context, s1, s2);
569 : : }
570 : :
571 : 1207578 : diagnostics::location_print_policy loc_policy (text_output);
572 : 1207578 : const bool colorize = pp_show_color (pp);
573 : 1207578 : char * locus_prefix = (one_locus || !same_locus)
574 : 1207578 : ? gfc_diagnostic_build_locus_prefix (loc_policy, s1, colorize)
575 : 179 : : gfc_diagnostic_build_locus_prefix (loc_policy, s1, s2, colorize);
576 : :
577 : 1207578 : if (!context->get_source_printing_options ().enabled
578 : 16752 : || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION
579 : 1224330 : || diagnostic_location (diagnostic, 0) == context->m_last_location)
580 : : {
581 : 1190826 : pp_set_prefix (pp,
582 : : concat (locus_prefix, " ", kind_prefix, NULL));
583 : 1190826 : free (locus_prefix);
584 : :
585 : 1190826 : if (one_locus || same_locus)
586 : : {
587 : 1190491 : free (kind_prefix);
588 : 1190491 : 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 : 335 : pp_string (pp, "(1)");
596 : 335 : pp_newline (pp);
597 : 335 : locus_prefix = gfc_diagnostic_build_locus_prefix (loc_policy, s2, colorize);
598 : 335 : pp_set_prefix (pp,
599 : : concat (locus_prefix, " ", kind_prefix, NULL));
600 : 335 : free (kind_prefix);
601 : 335 : free (locus_prefix);
602 : : }
603 : : else
604 : : {
605 : 16752 : pp_verbatim (pp, "%s", locus_prefix);
606 : 16752 : free (locus_prefix);
607 : : /* Fortran uses an empty line between locus and caret line. */
608 : 16752 : pp_newline (pp);
609 : 16752 : pp_set_prefix (pp, NULL);
610 : 16752 : pp_newline (pp);
611 : 16752 : diagnostic_show_locus (context,
612 : 16752 : text_output.get_source_printing_options (),
613 : 16752 : diagnostic->m_richloc, diagnostic->m_kind,
614 : : pp);
615 : : /* If the caret line was shown, the prefix does not contain the
616 : : locus. */
617 : 16752 : 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 : 1207578 : 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 : 1207578 : pretty_printer *const pp = text_output.get_printer ();
644 : 1207578 : pp_destroy_prefix (pp);
645 : 1207578 : pp_newline_and_flush (pp);
646 : 1207578 : }
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 : 26970 : gfc_warning_now (int opt, const char *gmsgid, ...)
672 : : {
673 : 26970 : va_list argp;
674 : 26970 : diagnostics::diagnostic_info diagnostic;
675 : 26970 : rich_location rich_loc (line_table, UNKNOWN_LOCATION);
676 : 26970 : bool ret;
677 : :
678 : 26970 : va_start (argp, gmsgid);
679 : 26970 : diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
680 : : diagnostics::kind::warning);
681 : 26970 : diagnostic.m_option_id = opt;
682 : 26970 : ret = gfc_report_diagnostic (&diagnostic);
683 : 26970 : va_end (argp);
684 : 53940 : return ret;
685 : 26970 : }
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 : 435 : gfc_error_now (const char *gmsgid, ...)
710 : : {
711 : 435 : va_list argp;
712 : 435 : diagnostics::diagnostic_info diagnostic;
713 : 435 : rich_location rich_loc (line_table, UNKNOWN_LOCATION);
714 : :
715 : 435 : error_buffer->flag = true;
716 : :
717 : 435 : va_start (argp, gmsgid);
718 : 435 : diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
719 : : diagnostics::kind::error);
720 : 435 : gfc_report_diagnostic (&diagnostic);
721 : 435 : va_end (argp);
722 : 435 : }
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 : 13514982 : gfc_clear_warning (void)
747 : : {
748 : 13514982 : gfc_clear_diagnostic_buffer (pp_warning_buffer);
749 : 13514982 : }
750 : :
751 : :
752 : : /* Check to see if any warnings have been saved.
753 : : If so, print the warning. */
754 : :
755 : : void
756 : 1378490 : gfc_warning_check (void)
757 : : {
758 : 1378490 : if (! pp_warning_buffer->empty_p ())
759 : 4024 : global_dc->flush_diagnostic_buffer (*pp_warning_buffer);
760 : 1378490 : }
761 : :
762 : :
763 : : /* Issue an error. */
764 : :
765 : : static void
766 : 1202983 : gfc_error_opt (int opt, const char *gmsgid, va_list ap)
767 : : {
768 : 1202983 : va_list argp;
769 : 1202983 : va_copy (argp, ap);
770 : :
771 : 1202983 : if (warnings_not_errors)
772 : : {
773 : 43 : gfc_warning (opt, gmsgid, argp);
774 : 43 : va_end (argp);
775 : 17750 : return;
776 : : }
777 : :
778 : 1202940 : if (suppress_errors)
779 : : {
780 : 17707 : va_end (argp);
781 : 17707 : return;
782 : : }
783 : :
784 : 1185233 : diagnostics::diagnostic_info diagnostic;
785 : 1185233 : rich_location richloc (line_table, UNKNOWN_LOCATION);
786 : 1185233 : diagnostics::buffer *old_buffer = global_dc->get_diagnostic_buffer ();
787 : 1185233 : gcc_assert (!old_buffer);
788 : :
789 : 1185233 : gfc_clear_diagnostic_buffer (pp_error_buffer);
790 : :
791 : 1185233 : if (buffered_p)
792 : 1178148 : global_dc->set_diagnostic_buffer (pp_error_buffer);
793 : :
794 : 1185233 : diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc,
795 : : diagnostics::kind::error);
796 : 1185233 : gfc_report_diagnostic (&diagnostic);
797 : :
798 : 1185233 : if (buffered_p)
799 : 1178148 : global_dc->set_diagnostic_buffer (old_buffer);
800 : :
801 : 1185233 : va_end (argp);
802 : 1185233 : }
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 : 1201990 : gfc_error (const char *gmsgid, ...)
817 : : {
818 : 1201990 : va_list argp;
819 : 1201990 : va_start (argp, gmsgid);
820 : 1201990 : gfc_error_opt (0, gmsgid, argp);
821 : 1201990 : va_end (argp);
822 : 1201990 : }
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 : 4983842 : gfc_clear_error (void)
853 : : {
854 : 4983842 : error_buffer->flag = false;
855 : 4983842 : warnings_not_errors = false;
856 : 4983842 : gfc_clear_diagnostic_buffer (pp_error_buffer);
857 : 4983842 : }
858 : :
859 : :
860 : : /* Tests the state of error_flag. */
861 : :
862 : : bool
863 : 1626561 : gfc_error_flag_test (void)
864 : : {
865 : 1626561 : return (error_buffer->flag
866 : 1626561 : || !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 : 5444 : gfc_error_check (void)
875 : : {
876 : 5444 : if (error_buffer->flag
877 : 5444 : || ! pp_error_buffer->empty_p ())
878 : : {
879 : 3198 : error_buffer->flag = false;
880 : 3198 : global_dc->flush_diagnostic_buffer (*pp_error_buffer);
881 : 3198 : 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 : 2995557 : gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from,
893 : : gfc_error_buffer * buffer_to)
894 : : {
895 : 2995557 : diagnostics::buffer * from = &(buffer_from->buffer);
896 : 2995557 : diagnostics::buffer * to = &(buffer_to->buffer);
897 : :
898 : 2995557 : buffer_to->flag = buffer_from->flag;
899 : 2995557 : buffer_from->flag = false;
900 : :
901 : 2995557 : gfc_clear_diagnostic_buffer (to);
902 : :
903 : 2995557 : if (! from->empty_p ())
904 : : {
905 : 103600 : from->move_to (*to);
906 : 103600 : gfc_clear_diagnostic_buffer (from);
907 : : }
908 : 2995557 : }
909 : :
910 : : /* Save the existing error state. */
911 : :
912 : : void
913 : 1534976 : gfc_push_error (gfc_error_buffer *err)
914 : : {
915 : 1534976 : gfc_move_error_buffer_from_to (error_buffer, err);
916 : 1534976 : }
917 : :
918 : :
919 : : /* Restore a previous pushed error state. */
920 : :
921 : : void
922 : 1460581 : gfc_pop_error (gfc_error_buffer *err)
923 : : {
924 : 1460581 : gfc_move_error_buffer_from_to (err, error_buffer);
925 : 1460581 : }
926 : :
927 : :
928 : : /* Free a pushed error state, but keep the current error state. */
929 : :
930 : : void
931 : 74227 : gfc_free_error (gfc_error_buffer *err)
932 : : {
933 : 74227 : gfc_clear_diagnostic_buffer (&(err->buffer));
934 : 74227 : }
935 : :
936 : :
937 : : /* Report the number of warnings and errors that occurred to the caller. */
938 : :
939 : : void
940 : 353615 : gfc_get_errors (int *w, int *e)
941 : : {
942 : 353615 : if (w != NULL)
943 : 303366 : *w = warningcount + werrorcount;
944 : 353615 : if (e != NULL)
945 : 353615 : *e = errorcount + sorrycount + werrorcount;
946 : 353615 : }
947 : :
948 : :
949 : : /* Switch errors into warnings. */
950 : :
951 : : void
952 : 48955 : gfc_errors_to_warnings (bool f)
953 : : {
954 : 48955 : warnings_not_errors = f;
955 : 48955 : }
956 : :
957 : : void
958 : 30853 : gfc_diagnostics_init (void)
959 : : {
960 : 30853 : diagnostics::text_starter (global_dc) = gfc_diagnostic_text_starter;
961 : 30853 : diagnostics::start_span (global_dc) = gfc_diagnostic_start_span;
962 : 30853 : diagnostics::text_finalizer (global_dc) = gfc_diagnostic_text_finalizer;
963 : 30853 : global_dc->set_format_decoder (gfc_format_decoder);
964 : 30853 : auto &source_printing_opts = global_dc->get_source_printing_options ();
965 : 30853 : source_printing_opts.caret_chars[0] = '1';
966 : 30853 : source_printing_opts.caret_chars[1] = '2';
967 : 30853 : pp_warning_buffer = new diagnostics::buffer (*global_dc);
968 : 30853 : error_buffer = new gfc_error_buffer ();
969 : 30853 : pp_error_buffer = &(error_buffer->buffer);
970 : 30853 : }
971 : :
972 : : void
973 : 30824 : gfc_diagnostics_finish (void)
974 : : {
975 : 30824 : tree_diagnostics_defaults (global_dc);
976 : : /* We still want to use the gfc starter and finalizer, not the tree
977 : : defaults. */
978 : 30824 : diagnostics::text_starter (global_dc) = gfc_diagnostic_text_starter;
979 : 30824 : diagnostics::text_finalizer (global_dc) = gfc_diagnostic_text_finalizer;
980 : 30824 : auto &source_printing_opts = global_dc->get_source_printing_options ();
981 : 30824 : source_printing_opts.caret_chars[0] = '^';
982 : 30824 : source_printing_opts.caret_chars[1] = '^';
983 : 61648 : delete error_buffer;
984 : 30824 : error_buffer = nullptr;
985 : 30824 : pp_error_buffer = nullptr;
986 : 30824 : }
|
