2 Copyright (C) 2000-2019 Free Software Foundation, Inc.
3 Contributed by Andy Vaught & Niels Kristian Bech Jensen
5 This file is part of GCC.
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
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
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/>. */
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. */
29 #include "coretypes.h"
33 #include "diagnostic.h"
34 #include "diagnostic-color.h"
35 #include "tree-diagnostic.h" /* tree_diagnostics_defaults */
37 static int suppress_errors
= 0;
39 static bool warnings_not_errors
= false;
41 static int terminal_width
;
43 /* True if the error/warnings should be buffered. */
44 static bool buffered_p
;
46 static gfc_error_buffer error_buffer
;
47 /* These are always buffered buffers (.flush_p == false) to be used by
48 the pretty-printer. */
49 static output_buffer
*pp_error_buffer
, *pp_warning_buffer
;
50 static int warningcount_buffered
, werrorcount_buffered
;
52 /* Return true if there output_buffer is empty. */
55 gfc_output_buffer_empty_p (const output_buffer
* buf
)
57 return output_buffer_last_position_in_text (buf
) == NULL
;
60 /* Go one level deeper suppressing errors. */
63 gfc_push_suppress_errors (void)
65 gcc_assert (suppress_errors
>= 0);
70 gfc_error_opt (int opt
, const char *gmsgid
, va_list ap
) ATTRIBUTE_GCC_GFC(2,0);
73 gfc_warning (int opt
, const char *gmsgid
, va_list ap
) ATTRIBUTE_GCC_GFC(2,0);
76 /* Leave one level of error suppressing. */
79 gfc_pop_suppress_errors (void)
81 gcc_assert (suppress_errors
> 0);
86 /* Determine terminal width (for trimming source lines in output). */
89 gfc_get_terminal_width (void)
91 return isatty (STDERR_FILENO
) ? get_terminal_width () : INT_MAX
;
95 /* Per-file error initialization. */
98 gfc_error_init_1 (void)
100 terminal_width
= gfc_get_terminal_width ();
101 gfc_buffer_error (false);
105 /* Set the flag for buffering errors or not. */
108 gfc_buffer_error (bool flag
)
114 /* Add a single character to the error buffer or output depending on
120 /* FIXME: Unused function to be removed in a subsequent patch. */
124 /* Copy a string to wherever it needs to go. */
127 error_string (const char *p
)
134 /* Print a formatted integer to the error buffer or output. */
139 error_uinteger (unsigned long int i
)
141 char *p
, int_buf
[IBUF_LEN
];
143 p
= int_buf
+ IBUF_LEN
- 1;
155 error_string (p
+ 1);
159 error_integer (long int i
)
165 u
= (unsigned long int) -i
;
176 gfc_widechar_display_length (gfc_char_t c
)
178 if (gfc_wide_is_printable (c
) || c
== '\t')
179 /* Printable ASCII character, or tabulation (output as a space). */
181 else if (c
< ((gfc_char_t
) 1 << 8))
182 /* Displayed as \x?? */
184 else if (c
< ((gfc_char_t
) 1 << 16))
185 /* Displayed as \u???? */
188 /* Displayed as \U???????? */
193 /* Length of the ASCII representation of the wide string, escaping wide
194 characters as print_wide_char_into_buffer() does. */
197 gfc_wide_display_length (const gfc_char_t
*str
)
201 for (i
= 0, len
= 0; str
[i
]; i
++)
202 len
+= gfc_widechar_display_length (str
[i
]);
208 print_wide_char_into_buffer (gfc_char_t c
, char *buf
)
210 static const char xdigit
[16] = { '0', '1', '2', '3', '4', '5', '6',
211 '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
213 if (gfc_wide_is_printable (c
) || c
== '\t')
216 /* Tabulation is output as a space. */
217 buf
[0] = (unsigned char) (c
== '\t' ? ' ' : c
);
220 else if (c
< ((gfc_char_t
) 1 << 8))
223 buf
[3] = xdigit
[c
& 0x0F];
225 buf
[2] = xdigit
[c
& 0x0F];
231 else if (c
< ((gfc_char_t
) 1 << 16))
234 buf
[5] = xdigit
[c
& 0x0F];
236 buf
[4] = xdigit
[c
& 0x0F];
238 buf
[3] = xdigit
[c
& 0x0F];
240 buf
[2] = xdigit
[c
& 0x0F];
249 buf
[9] = xdigit
[c
& 0x0F];
251 buf
[8] = xdigit
[c
& 0x0F];
253 buf
[7] = xdigit
[c
& 0x0F];
255 buf
[6] = xdigit
[c
& 0x0F];
257 buf
[5] = xdigit
[c
& 0x0F];
259 buf
[4] = xdigit
[c
& 0x0F];
261 buf
[3] = xdigit
[c
& 0x0F];
263 buf
[2] = xdigit
[c
& 0x0F];
271 static char wide_char_print_buffer
[11];
274 gfc_print_wide_char (gfc_char_t c
)
276 print_wide_char_into_buffer (c
, wide_char_print_buffer
);
277 return wide_char_print_buffer
;
281 /* Show the file, where it was included, and the source line, give a
282 locus. Calls error_printf() recursively, but the recursion is at
283 most one level deep. */
285 static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
288 show_locus (locus
*loc
, int c1
, int c2
)
295 /* TODO: Either limit the total length and number of included files
296 displayed or add buffering of arbitrary number of characters in
299 /* Write out the error header line, giving the source file and error
300 location (in GNU standard "[file]:[line].[column]:" format),
301 followed by an "included by" stack and a blank line. This header
302 format is matched by a testsuite parser defined in
303 lib/gfortran-dg.exp. */
308 error_string (f
->filename
);
311 error_integer (LOCATION_LINE (lb
->location
));
313 if ((c1
> 0) || (c2
> 0))
319 if ((c1
> 0) && (c2
> 0))
330 i
= f
->inclusion_line
;
333 if (f
== NULL
) break;
335 error_printf (" Included at %s:%d:", f
->filename
, i
);
340 /* Calculate an appropriate horizontal offset of the source line in
341 order to get the error locus within the visible portion of the
342 line. Note that if the margin of 5 here is changed, the
343 corresponding margin of 10 in show_loci should be changed. */
347 /* If the two loci would appear in the same column, we shift
348 '2' one column to the right, so as to print '12' rather than
349 just '1'. We do this here so it will be accounted for in the
350 margin calculations. */
355 cmax
= (c1
< c2
) ? c2
: c1
;
356 if (cmax
> terminal_width
- 5)
357 offset
= cmax
- terminal_width
+ 5;
359 /* Show the line itself, taking care not to print more than what can
360 show up on the terminal. Tabs are converted to spaces, and
361 nonprintable characters are converted to a "\xNN" sequence. */
363 p
= &(lb
->line
[offset
]);
364 i
= gfc_wide_display_length (p
);
365 if (i
> terminal_width
)
366 i
= terminal_width
- 1;
370 static char buffer
[11];
371 i
-= print_wide_char_into_buffer (*p
++, buffer
);
372 error_string (buffer
);
377 /* Show the '1' and/or '2' corresponding to the column of the error
378 locus. Note that a value of -1 for c1 or c2 will simply cause
379 the relevant number not to be printed. */
385 p
= &(lb
->line
[offset
]);
386 for (i
= 0; i
< cmax
; i
++)
389 spaces
= gfc_widechar_display_length (*p
++);
392 error_char ('1'), spaces
--;
394 error_char ('2'), spaces
--;
396 for (j
= 0; j
< spaces
; j
++)
410 /* As part of printing an error, we show the source lines that caused
411 the problem. We show at least one, and possibly two loci; the two
412 loci may or may not be on the same source line. */
415 show_loci (locus
*l1
, locus
*l2
)
419 if (l1
== NULL
|| l1
->lb
== NULL
)
421 error_printf ("<During initialization>\n");
425 /* While calculating parameters for printing the loci, we consider possible
426 reasons for printing one per line. If appropriate, print the loci
427 individually; otherwise we print them both on the same line. */
429 c1
= l1
->nextc
- l1
->lb
->line
;
432 show_locus (l1
, c1
, -1);
436 c2
= l2
->nextc
- l2
->lb
->line
;
443 /* Note that the margin value of 10 here needs to be less than the
444 margin of 5 used in the calculation of offset in show_locus. */
446 if (l1
->lb
!= l2
->lb
|| m
> terminal_width
- 10)
448 show_locus (l1
, c1
, -1);
449 show_locus (l2
, -1, c2
);
453 show_locus (l1
, c1
, c2
);
459 /* Workhorse for the error printing subroutines. This subroutine is
460 inspired by g77's error handling and is similar to printf() with
461 the following %-codes:
463 %c Character, %d or %i Integer, %s String, %% Percent
464 %L Takes locus argument
465 %C Current locus (no argument)
467 If a locus pointer is given, the actual source line is printed out
468 and the column is indicated. Since we want the error message at
469 the bottom of any source file information, we must scan the
470 argument list twice -- once to determine whether the loci are
471 present and record this for printing, and once to print the error
472 message after and loci have been printed. A maximum of two locus
473 arguments are permitted.
475 This function is also called (recursively) by show_locus in the
476 case of included files; however, as show_locus does not resupply
477 any loci, the recursion is at most one level deep. */
481 static void ATTRIBUTE_GCC_GFC(2,0)
482 error_print (const char *type
, const char *format0
, va_list argp
)
484 enum { TYPE_CURRENTLOC
, TYPE_LOCUS
, TYPE_INTEGER
, TYPE_UINTEGER
,
485 TYPE_LONGINT
, TYPE_ULONGINT
, TYPE_CHAR
, TYPE_STRING
,
494 unsigned int uintval
;
496 unsigned long int ulongintval
;
498 const char * stringval
;
500 } arg
[MAX_ARGS
], spec
[MAX_ARGS
];
501 /* spec is the array of specifiers, in the same order as they
502 appear in the format string. arg is the array of arguments,
503 in the same order as they appear in the va_list. */
506 int i
, n
, have_l1
, pos
, maxpos
;
507 locus
*l1
, *l2
, *loc
;
510 loc
= l1
= l2
= NULL
;
519 for (i
= 0; i
< MAX_ARGS
; i
++)
521 arg
[i
].type
= NOTYPE
;
525 /* First parse the format string for position specifiers. */
538 if (ISDIGIT (*format
))
540 /* This is a position specifier. For example, the number
541 12 in the format string "%12$d", which specifies the third
542 argument of the va_list, formatted in %d format.
543 For details, see "man 3 printf". */
544 pos
= atoi(format
) - 1;
545 gcc_assert (pos
>= 0);
546 while (ISDIGIT(*format
))
548 gcc_assert (*format
== '$');
562 arg
[pos
].type
= TYPE_CURRENTLOC
;
566 arg
[pos
].type
= TYPE_LOCUS
;
571 arg
[pos
].type
= TYPE_INTEGER
;
575 arg
[pos
].type
= TYPE_UINTEGER
;
581 arg
[pos
].type
= TYPE_ULONGINT
;
582 else if (c
== 'i' || c
== 'd')
583 arg
[pos
].type
= TYPE_LONGINT
;
589 arg
[pos
].type
= TYPE_CHAR
;
593 arg
[pos
].type
= TYPE_STRING
;
603 /* Then convert the values for each %-style argument. */
604 for (pos
= 0; pos
<= maxpos
; pos
++)
606 gcc_assert (arg
[pos
].type
!= NOTYPE
);
607 switch (arg
[pos
].type
)
609 case TYPE_CURRENTLOC
:
610 loc
= &gfc_current_locus
;
614 if (arg
[pos
].type
== TYPE_LOCUS
)
615 loc
= va_arg (argp
, locus
*);
620 arg
[pos
].u
.stringval
= "(2)";
626 arg
[pos
].u
.stringval
= "(1)";
631 arg
[pos
].u
.intval
= va_arg (argp
, int);
635 arg
[pos
].u
.uintval
= va_arg (argp
, unsigned int);
639 arg
[pos
].u
.longintval
= va_arg (argp
, long int);
643 arg
[pos
].u
.ulongintval
= va_arg (argp
, unsigned long int);
647 arg
[pos
].u
.charval
= (char) va_arg (argp
, int);
651 arg
[pos
].u
.stringval
= (const char *) va_arg (argp
, char *);
659 for (n
= 0; spec
[n
].pos
>= 0; n
++)
660 spec
[n
].u
= arg
[spec
[n
].pos
].u
;
662 /* Show the current loci if we have to. */
676 for (; *format
; format
++)
680 error_char (*format
);
685 if (ISDIGIT (*format
))
687 /* This is a position specifier. See comment above. */
688 while (ISDIGIT (*format
))
691 /* Skip over the dollar sign. */
702 error_char (spec
[n
++].u
.charval
);
706 case 'C': /* Current locus */
707 case 'L': /* Specified locus */
708 error_string (spec
[n
++].u
.stringval
);
713 error_integer (spec
[n
++].u
.intval
);
717 error_uinteger (spec
[n
++].u
.uintval
);
723 error_uinteger (spec
[n
++].u
.ulongintval
);
725 error_integer (spec
[n
++].u
.longintval
);
735 /* Wrapper for error_print(). */
738 error_printf (const char *gmsgid
, ...)
742 va_start (argp
, gmsgid
);
743 error_print ("", _(gmsgid
), argp
);
748 /* Clear any output buffered in a pretty-print output_buffer. */
751 gfc_clear_pp_buffer (output_buffer
*this_buffer
)
753 pretty_printer
*pp
= global_dc
->printer
;
754 output_buffer
*tmp_buffer
= pp
->buffer
;
755 pp
->buffer
= this_buffer
;
756 pp_clear_output_area (pp
);
757 pp
->buffer
= tmp_buffer
;
758 /* We need to reset last_location, otherwise we may skip caret lines
759 when we actually give a diagnostic. */
760 global_dc
->last_location
= UNKNOWN_LOCATION
;
764 /* This is just a helper function to avoid duplicating the logic of
768 gfc_warning (int opt
, const char *gmsgid
, va_list ap
)
773 diagnostic_info diagnostic
;
774 rich_location
rich_loc (line_table
, UNKNOWN_LOCATION
);
775 bool fatal_errors
= global_dc
->fatal_errors
;
776 pretty_printer
*pp
= global_dc
->printer
;
777 output_buffer
*tmp_buffer
= pp
->buffer
;
779 gfc_clear_pp_buffer (pp_warning_buffer
);
783 pp
->buffer
= pp_warning_buffer
;
784 global_dc
->fatal_errors
= false;
785 /* To prevent -fmax-errors= triggering. */
789 diagnostic_set_info (&diagnostic
, gmsgid
, &argp
, &rich_loc
,
791 diagnostic
.option_index
= opt
;
792 bool ret
= diagnostic_report_diagnostic (global_dc
, &diagnostic
);
796 pp
->buffer
= tmp_buffer
;
797 global_dc
->fatal_errors
= fatal_errors
;
799 warningcount_buffered
= 0;
800 werrorcount_buffered
= 0;
801 /* Undo the above --werrorcount if not Werror, otherwise
802 werrorcount is correct already. */
805 else if (diagnostic
.kind
== DK_ERROR
)
806 ++werrorcount_buffered
;
808 ++werrorcount
, --warningcount
, ++warningcount_buffered
;
815 /* Issue a warning. */
818 gfc_warning (int opt
, const char *gmsgid
, ...)
822 va_start (argp
, gmsgid
);
823 bool ret
= gfc_warning (opt
, gmsgid
, argp
);
829 /* Whether, for a feature included in a given standard set (GFC_STD_*),
830 we should issue an error or a warning, or be quiet. */
833 gfc_notification_std (int std
)
837 warning
= ((gfc_option
.warn_std
& std
) != 0) && !inhibit_warnings
;
838 if ((gfc_option
.allow_std
& std
) != 0 && !warning
)
841 return warning
? WARNING
: ERROR
;
845 /* Return a string describing the nature of a standard violation
846 * and/or the relevant version of the standard. */
849 notify_std_msg(int std
)
852 if (std
& GFC_STD_F2018_DEL
)
853 return _("Fortran 2018 deleted feature:");
854 else if (std
& GFC_STD_F2018_OBS
)
855 return _("Fortran 2018 obsolescent feature:");
856 else if (std
& GFC_STD_F2018
)
857 return _("Fortran 2018:");
858 else if (std
& GFC_STD_F2008_OBS
)
859 return _("Fortran 2008 obsolescent feature:");
860 else if (std
& GFC_STD_F2008
)
861 return "Fortran 2008:";
862 else if (std
& GFC_STD_F2003
)
863 return "Fortran 2003:";
864 else if (std
& GFC_STD_GNU
)
865 return _("GNU Extension:");
866 else if (std
& GFC_STD_LEGACY
)
867 return _("Legacy Extension:");
868 else if (std
& GFC_STD_F95_OBS
)
869 return _("Obsolescent feature:");
870 else if (std
& GFC_STD_F95_DEL
)
871 return _("Deleted feature:");
877 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
878 feature. An error/warning will be issued if the currently selected
879 standard does not contain the requested bits. Return false if
880 an error is generated. */
883 gfc_notify_std (int std
, const char *gmsgid
, ...)
886 const char *msg
, *msg2
;
889 /* Determine whether an error or a warning is needed. */
890 const int wstd
= std
& gfc_option
.warn_std
; /* Standard to warn about. */
891 const int estd
= std
& ~gfc_option
.allow_std
; /* Standard to error about. */
892 const bool warning
= (wstd
!= 0) && !inhibit_warnings
;
893 const bool error
= (estd
!= 0);
895 if (!error
&& !warning
)
901 msg
= notify_std_msg (estd
);
903 msg
= notify_std_msg (wstd
);
906 buffer
= (char *) alloca (strlen (msg
) + strlen (msg2
) + 2);
907 strcpy (buffer
, msg
);
908 strcat (buffer
, " ");
909 strcat (buffer
, msg2
);
911 va_start (argp
, gmsgid
);
913 gfc_error_opt (0, buffer
, argp
);
915 gfc_warning (0, buffer
, argp
);
921 return (warning
&& !warnings_are_errors
);
925 /* Called from output_format -- during diagnostic message processing
926 to handle Fortran specific format specifiers with the following meanings:
928 %C Current locus (no argument)
929 %L Takes locus argument
932 gfc_format_decoder (pretty_printer
*pp
, text_info
*text
, const char *spec
,
933 int precision
, bool wide
, bool set_locus
, bool hash
,
934 bool *quoted
, const char **buffer_ptr
)
941 static const char *result
[2] = { "(1)", "(2)" };
944 loc
= &gfc_current_locus
;
946 loc
= va_arg (*text
->args_ptr
, locus
*);
947 gcc_assert (loc
->nextc
- loc
->lb
->line
>= 0);
948 unsigned int offset
= loc
->nextc
- loc
->lb
->line
;
949 /* If location[0] != UNKNOWN_LOCATION means that we already
950 processed one of %C/%L. */
951 int loc_num
= text
->get_location (0) == UNKNOWN_LOCATION
? 0 : 1;
953 = linemap_position_for_loc_and_offset (line_table
,
956 text
->set_location (loc_num
, src_loc
, SHOW_RANGE_WITH_CARET
);
957 pp_string (pp
, result
[loc_num
]);
961 /* Fall through info the middle-end decoder, as e.g. stor-layout.c
962 etc. diagnostics can use the FE printer while the FE is still
964 return default_tree_printer (pp
, text
, spec
, precision
, wide
,
965 set_locus
, hash
, quoted
, buffer_ptr
);
969 /* Return a malloc'd string describing the kind of diagnostic. The
970 caller is responsible for freeing the memory. */
972 gfc_diagnostic_build_kind_prefix (diagnostic_context
*context
,
973 const diagnostic_info
*diagnostic
)
975 static const char *const diagnostic_kind_text
[] = {
976 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T),
977 #include "gfc-diagnostic.def"
978 #undef DEFINE_DIAGNOSTIC_KIND
981 static const char *const diagnostic_kind_color
[] = {
982 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C),
983 #include "gfc-diagnostic.def"
984 #undef DEFINE_DIAGNOSTIC_KIND
987 gcc_assert (diagnostic
->kind
< DK_LAST_DIAGNOSTIC_KIND
);
988 const char *text
= _(diagnostic_kind_text
[diagnostic
->kind
]);
989 const char *text_cs
= "", *text_ce
= "";
990 pretty_printer
*pp
= context
->printer
;
992 if (diagnostic_kind_color
[diagnostic
->kind
])
994 text_cs
= colorize_start (pp_show_color (pp
),
995 diagnostic_kind_color
[diagnostic
->kind
]);
996 text_ce
= colorize_stop (pp_show_color (pp
));
998 return build_message_string ("%s%s:%s ", text_cs
, text
, text_ce
);
1001 /* Return a malloc'd string describing a location. The caller is
1002 responsible for freeing the memory. */
1004 gfc_diagnostic_build_locus_prefix (diagnostic_context
*context
,
1005 expanded_location s
)
1007 pretty_printer
*pp
= context
->printer
;
1008 const char *locus_cs
= colorize_start (pp_show_color (pp
), "locus");
1009 const char *locus_ce
= colorize_stop (pp_show_color (pp
));
1010 return (s
.file
== NULL
1011 ? build_message_string ("%s%s:%s", locus_cs
, progname
, locus_ce
)
1012 : !strcmp (s
.file
, N_("<built-in>"))
1013 ? build_message_string ("%s%s:%s", locus_cs
, s
.file
, locus_ce
)
1014 : context
->show_column
1015 ? build_message_string ("%s%s:%d:%d:%s", locus_cs
, s
.file
, s
.line
,
1017 : build_message_string ("%s%s:%d:%s", locus_cs
, s
.file
, s
.line
, locus_ce
));
1020 /* Return a malloc'd string describing two locations. The caller is
1021 responsible for freeing the memory. */
1023 gfc_diagnostic_build_locus_prefix (diagnostic_context
*context
,
1024 expanded_location s
, expanded_location s2
)
1026 pretty_printer
*pp
= context
->printer
;
1027 const char *locus_cs
= colorize_start (pp_show_color (pp
), "locus");
1028 const char *locus_ce
= colorize_stop (pp_show_color (pp
));
1030 return (s
.file
== NULL
1031 ? build_message_string ("%s%s:%s", locus_cs
, progname
, locus_ce
)
1032 : !strcmp (s
.file
, N_("<built-in>"))
1033 ? build_message_string ("%s%s:%s", locus_cs
, s
.file
, locus_ce
)
1034 : context
->show_column
1035 ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs
, s
.file
, s
.line
,
1036 MIN (s
.column
, s2
.column
),
1037 MAX (s
.column
, s2
.column
), locus_ce
)
1038 : build_message_string ("%s%s:%d:%s", locus_cs
, s
.file
, s
.line
,
1042 /* This function prints the locus (file:line:column), the diagnostic kind
1043 (Error, Warning) and (optionally) the relevant lines of code with
1044 annotation lines with '1' and/or '2' below them.
1046 With -fdiagnostic-show-caret (the default) it prints:
1048 [locus of primary range]:
1052 Error: Some error at (1)
1054 With -fno-diagnostic-show-caret or if the primary range is not
1057 [locus of primary range]: Error: Some error at (1) and (2)
1060 gfc_diagnostic_starter (diagnostic_context
*context
,
1061 diagnostic_info
*diagnostic
)
1063 char * kind_prefix
= gfc_diagnostic_build_kind_prefix (context
, diagnostic
);
1065 expanded_location s1
= diagnostic_expand_location (diagnostic
);
1066 expanded_location s2
;
1067 bool one_locus
= diagnostic
->richloc
->get_num_locations () < 2;
1068 bool same_locus
= false;
1072 s2
= diagnostic_expand_location (diagnostic
, 1);
1073 same_locus
= diagnostic_same_line (context
, s1
, s2
);
1076 char * locus_prefix
= (one_locus
|| !same_locus
)
1077 ? gfc_diagnostic_build_locus_prefix (context
, s1
)
1078 : gfc_diagnostic_build_locus_prefix (context
, s1
, s2
);
1080 if (!context
->show_caret
1081 || diagnostic_location (diagnostic
, 0) <= BUILTINS_LOCATION
1082 || diagnostic_location (diagnostic
, 0) == context
->last_location
)
1084 pp_set_prefix (context
->printer
,
1085 concat (locus_prefix
, " ", kind_prefix
, NULL
));
1086 free (locus_prefix
);
1088 if (one_locus
|| same_locus
)
1093 /* In this case, we print the previous locus and prefix as:
1095 [locus]:[prefix]: (1)
1097 and we flush with a new line before setting the new prefix. */
1098 pp_string (context
->printer
, "(1)");
1099 pp_newline (context
->printer
);
1100 locus_prefix
= gfc_diagnostic_build_locus_prefix (context
, s2
);
1101 pp_set_prefix (context
->printer
,
1102 concat (locus_prefix
, " ", kind_prefix
, NULL
));
1104 free (locus_prefix
);
1108 pp_verbatim (context
->printer
, "%s", locus_prefix
);
1109 free (locus_prefix
);
1110 /* Fortran uses an empty line between locus and caret line. */
1111 pp_newline (context
->printer
);
1112 diagnostic_show_locus (context
, diagnostic
->richloc
, diagnostic
->kind
);
1113 /* If the caret line was shown, the prefix does not contain the
1115 pp_set_prefix (context
->printer
, kind_prefix
);
1120 gfc_diagnostic_start_span (diagnostic_context
*context
,
1121 expanded_location exploc
)
1124 locus_prefix
= gfc_diagnostic_build_locus_prefix (context
, exploc
);
1125 pp_verbatim (context
->printer
, "%s", locus_prefix
);
1126 free (locus_prefix
);
1127 pp_newline (context
->printer
);
1128 /* Fortran uses an empty line between locus and caret line. */
1129 pp_newline (context
->printer
);
1134 gfc_diagnostic_finalizer (diagnostic_context
*context
,
1135 diagnostic_info
*diagnostic ATTRIBUTE_UNUSED
,
1136 diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED
)
1138 pp_destroy_prefix (context
->printer
);
1139 pp_newline_and_flush (context
->printer
);
1142 /* Immediate warning (i.e. do not buffer the warning) with an explicit
1146 gfc_warning_now_at (location_t loc
, int opt
, const char *gmsgid
, ...)
1149 diagnostic_info diagnostic
;
1150 rich_location
rich_loc (line_table
, loc
);
1153 va_start (argp
, gmsgid
);
1154 diagnostic_set_info (&diagnostic
, gmsgid
, &argp
, &rich_loc
, DK_WARNING
);
1155 diagnostic
.option_index
= opt
;
1156 ret
= diagnostic_report_diagnostic (global_dc
, &diagnostic
);
1161 /* Immediate warning (i.e. do not buffer the warning). */
1164 gfc_warning_now (int opt
, const char *gmsgid
, ...)
1167 diagnostic_info diagnostic
;
1168 rich_location
rich_loc (line_table
, UNKNOWN_LOCATION
);
1171 va_start (argp
, gmsgid
);
1172 diagnostic_set_info (&diagnostic
, gmsgid
, &argp
, &rich_loc
,
1174 diagnostic
.option_index
= opt
;
1175 ret
= diagnostic_report_diagnostic (global_dc
, &diagnostic
);
1180 /* Internal warning, do not buffer. */
1183 gfc_warning_internal (int opt
, const char *gmsgid
, ...)
1186 diagnostic_info diagnostic
;
1187 rich_location
rich_loc (line_table
, UNKNOWN_LOCATION
);
1190 va_start (argp
, gmsgid
);
1191 diagnostic_set_info (&diagnostic
, gmsgid
, &argp
, &rich_loc
,
1193 diagnostic
.option_index
= opt
;
1194 ret
= diagnostic_report_diagnostic (global_dc
, &diagnostic
);
1199 /* Immediate error (i.e. do not buffer). */
1202 gfc_error_now (const char *gmsgid
, ...)
1205 diagnostic_info diagnostic
;
1206 rich_location
rich_loc (line_table
, UNKNOWN_LOCATION
);
1208 error_buffer
.flag
= true;
1210 va_start (argp
, gmsgid
);
1211 diagnostic_set_info (&diagnostic
, gmsgid
, &argp
, &rich_loc
, DK_ERROR
);
1212 diagnostic_report_diagnostic (global_dc
, &diagnostic
);
1217 /* Fatal error, never returns. */
1220 gfc_fatal_error (const char *gmsgid
, ...)
1223 diagnostic_info diagnostic
;
1224 rich_location
rich_loc (line_table
, UNKNOWN_LOCATION
);
1226 va_start (argp
, gmsgid
);
1227 diagnostic_set_info (&diagnostic
, gmsgid
, &argp
, &rich_loc
, DK_FATAL
);
1228 diagnostic_report_diagnostic (global_dc
, &diagnostic
);
1234 /* Clear the warning flag. */
1237 gfc_clear_warning (void)
1239 gfc_clear_pp_buffer (pp_warning_buffer
);
1240 warningcount_buffered
= 0;
1241 werrorcount_buffered
= 0;
1245 /* Check to see if any warnings have been saved.
1246 If so, print the warning. */
1249 gfc_warning_check (void)
1251 if (! gfc_output_buffer_empty_p (pp_warning_buffer
))
1253 pretty_printer
*pp
= global_dc
->printer
;
1254 output_buffer
*tmp_buffer
= pp
->buffer
;
1255 pp
->buffer
= pp_warning_buffer
;
1256 pp_really_flush (pp
);
1257 warningcount
+= warningcount_buffered
;
1258 werrorcount
+= werrorcount_buffered
;
1259 gcc_assert (warningcount_buffered
+ werrorcount_buffered
== 1);
1260 pp
->buffer
= tmp_buffer
;
1261 diagnostic_action_after_output (global_dc
,
1262 warningcount_buffered
1263 ? DK_WARNING
: DK_ERROR
);
1264 diagnostic_check_max_errors (global_dc
, true);
1269 /* Issue an error. */
1272 gfc_error_opt (int opt
, const char *gmsgid
, va_list ap
)
1276 bool saved_abort_on_error
= false;
1278 if (warnings_not_errors
)
1280 gfc_warning (opt
, gmsgid
, argp
);
1285 if (suppress_errors
)
1291 diagnostic_info diagnostic
;
1292 rich_location
richloc (line_table
, UNKNOWN_LOCATION
);
1293 bool fatal_errors
= global_dc
->fatal_errors
;
1294 pretty_printer
*pp
= global_dc
->printer
;
1295 output_buffer
*tmp_buffer
= pp
->buffer
;
1297 gfc_clear_pp_buffer (pp_error_buffer
);
1301 /* To prevent -dH from triggering an abort on a buffered error,
1302 save abort_on_error and restore it below. */
1303 saved_abort_on_error
= global_dc
->abort_on_error
;
1304 global_dc
->abort_on_error
= false;
1305 pp
->buffer
= pp_error_buffer
;
1306 global_dc
->fatal_errors
= false;
1307 /* To prevent -fmax-errors= triggering, we decrease it before
1308 report_diagnostic increases it. */
1312 diagnostic_set_info (&diagnostic
, gmsgid
, &argp
, &richloc
, DK_ERROR
);
1313 diagnostic_report_diagnostic (global_dc
, &diagnostic
);
1317 pp
->buffer
= tmp_buffer
;
1318 global_dc
->fatal_errors
= fatal_errors
;
1319 global_dc
->abort_on_error
= saved_abort_on_error
;
1328 gfc_error_opt (int opt
, const char *gmsgid
, ...)
1331 va_start (argp
, gmsgid
);
1332 gfc_error_opt (opt
, gmsgid
, argp
);
1338 gfc_error (const char *gmsgid
, ...)
1341 va_start (argp
, gmsgid
);
1342 gfc_error_opt (0, gmsgid
, argp
);
1347 /* This shouldn't happen... but sometimes does. */
1350 gfc_internal_error (const char *gmsgid
, ...)
1354 diagnostic_info diagnostic
;
1355 rich_location
rich_loc (line_table
, UNKNOWN_LOCATION
);
1357 gfc_get_errors (&w
, &e
);
1361 va_start (argp
, gmsgid
);
1362 diagnostic_set_info (&diagnostic
, gmsgid
, &argp
, &rich_loc
, DK_ICE
);
1363 diagnostic_report_diagnostic (global_dc
, &diagnostic
);
1370 /* Clear the error flag when we start to compile a source line. */
1373 gfc_clear_error (void)
1375 error_buffer
.flag
= 0;
1376 warnings_not_errors
= false;
1377 gfc_clear_pp_buffer (pp_error_buffer
);
1381 /* Tests the state of error_flag. */
1384 gfc_error_flag_test (void)
1386 return error_buffer
.flag
1387 || !gfc_output_buffer_empty_p (pp_error_buffer
);
1391 /* Check to see if any errors have been saved.
1392 If so, print the error. Returns the state of error_flag. */
1395 gfc_error_check (void)
1397 if (error_buffer
.flag
1398 || ! gfc_output_buffer_empty_p (pp_error_buffer
))
1400 error_buffer
.flag
= false;
1401 pretty_printer
*pp
= global_dc
->printer
;
1402 output_buffer
*tmp_buffer
= pp
->buffer
;
1403 pp
->buffer
= pp_error_buffer
;
1404 pp_really_flush (pp
);
1406 gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer
));
1407 pp
->buffer
= tmp_buffer
;
1408 diagnostic_action_after_output (global_dc
, DK_ERROR
);
1409 diagnostic_check_max_errors (global_dc
, true);
1416 /* Move the text buffered from FROM to TO, then clear
1417 FROM. Independently if there was text in FROM, TO is also
1421 gfc_move_error_buffer_from_to (gfc_error_buffer
* buffer_from
,
1422 gfc_error_buffer
* buffer_to
)
1424 output_buffer
* from
= &(buffer_from
->buffer
);
1425 output_buffer
* to
= &(buffer_to
->buffer
);
1427 buffer_to
->flag
= buffer_from
->flag
;
1428 buffer_from
->flag
= false;
1430 gfc_clear_pp_buffer (to
);
1431 /* We make sure this is always buffered. */
1432 to
->flush_p
= false;
1434 if (! gfc_output_buffer_empty_p (from
))
1436 const char *str
= output_buffer_formatted_text (from
);
1437 output_buffer_append_r (to
, str
, strlen (str
));
1438 gfc_clear_pp_buffer (from
);
1442 /* Save the existing error state. */
1445 gfc_push_error (gfc_error_buffer
*err
)
1447 gfc_move_error_buffer_from_to (&error_buffer
, err
);
1451 /* Restore a previous pushed error state. */
1454 gfc_pop_error (gfc_error_buffer
*err
)
1456 gfc_move_error_buffer_from_to (err
, &error_buffer
);
1460 /* Free a pushed error state, but keep the current error state. */
1463 gfc_free_error (gfc_error_buffer
*err
)
1465 gfc_clear_pp_buffer (&(err
->buffer
));
1469 /* Report the number of warnings and errors that occurred to the caller. */
1472 gfc_get_errors (int *w
, int *e
)
1475 *w
= warningcount
+ werrorcount
;
1477 *e
= errorcount
+ sorrycount
+ werrorcount
;
1481 /* Switch errors into warnings. */
1484 gfc_errors_to_warnings (bool f
)
1486 warnings_not_errors
= f
;
1490 gfc_diagnostics_init (void)
1492 diagnostic_starter (global_dc
) = gfc_diagnostic_starter
;
1493 global_dc
->start_span
= gfc_diagnostic_start_span
;
1494 diagnostic_finalizer (global_dc
) = gfc_diagnostic_finalizer
;
1495 diagnostic_format_decoder (global_dc
) = gfc_format_decoder
;
1496 global_dc
->caret_chars
[0] = '1';
1497 global_dc
->caret_chars
[1] = '2';
1498 pp_warning_buffer
= new (XNEW (output_buffer
)) output_buffer ();
1499 pp_warning_buffer
->flush_p
= false;
1500 /* pp_error_buffer is statically allocated. This simplifies memory
1501 management when using gfc_push/pop_error. */
1502 pp_error_buffer
= &(error_buffer
.buffer
);
1503 pp_error_buffer
->flush_p
= false;
1507 gfc_diagnostics_finish (void)
1509 tree_diagnostics_defaults (global_dc
);
1510 /* We still want to use the gfc starter and finalizer, not the tree
1512 diagnostic_starter (global_dc
) = gfc_diagnostic_starter
;
1513 diagnostic_finalizer (global_dc
) = gfc_diagnostic_finalizer
;
1514 global_dc
->caret_chars
[0] = '^';
1515 global_dc
->caret_chars
[1] = '^';