1/* Handle errors. 2 Copyright (C) 2000-2020 Free Software Foundation, Inc. 3 Contributed by Andy Vaught & Niels Kristian Bech Jensen 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21/* Handle the inevitable errors. A major catch here is that things 22 flagged as errors in one match subroutine can conceivably be legal 23 elsewhere. This means that error messages are recorded and saved 24 for possible use later. If a line does not match a legal 25 construction, then the saved error message is reported. */ 26 27#include "config.h" 28#include "system.h" 29#include "coretypes.h" 30#include "options.h" 31#include "gfortran.h" 32 33#include "diagnostic.h" 34#include "diagnostic-color.h" 35#include "tree-diagnostic.h" /* tree_diagnostics_defaults */ 36 37static int suppress_errors = 0; 38 39static bool warnings_not_errors = false; 40 41static int terminal_width; 42 43/* True if the error/warnings should be buffered. */ 44static bool buffered_p; 45 46static gfc_error_buffer error_buffer; 47/* These are always buffered buffers (.flush_p == false) to be used by 48 the pretty-printer. */ 49static output_buffer *pp_error_buffer, *pp_warning_buffer; 50static int warningcount_buffered, werrorcount_buffered; 51 52/* Return true if there output_buffer is empty. */ 53 54static bool 55gfc_output_buffer_empty_p (const output_buffer * buf) 56{ 57 return output_buffer_last_position_in_text (buf) == NULL; 58} 59 60/* Go one level deeper suppressing errors. */ 61 62void 63gfc_push_suppress_errors (void) 64{ 65 gcc_assert (suppress_errors >= 0); 66 ++suppress_errors; 67} 68 69static void 70gfc_error_opt (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0); 71 72static bool 73gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0); 74 75 76/* Leave one level of error suppressing. */ 77 78void 79gfc_pop_suppress_errors (void) 80{ 81 gcc_assert (suppress_errors > 0); 82 --suppress_errors; 83} 84 85 86/* Determine terminal width (for trimming source lines in output). */ 87 88static int 89gfc_get_terminal_width (void) 90{ 91 return isatty (STDERR_FILENO) ? get_terminal_width () : INT_MAX; 92} 93 94 95/* Per-file error initialization. */ 96 97void 98gfc_error_init_1 (void) 99{ 100 terminal_width = gfc_get_terminal_width (); 101 gfc_buffer_error (false); 102} 103 104 105/* Set the flag for buffering errors or not. */ 106 107void 108gfc_buffer_error (bool flag) 109{ 110 buffered_p = flag; 111} 112 113 114/* Add a single character to the error buffer or output depending on 115 buffered_p. */ 116 117static void 118error_char (char) 119{ 120 /* FIXME: Unused function to be removed in a subsequent patch. */ 121} 122 123 124/* Copy a string to wherever it needs to go. */ 125 126static void 127error_string (const char *p) 128{ 129 while (*p) 130 error_char (*p++); 131} 132 133 134/* Print a formatted integer to the error buffer or output. */ 135 136#define IBUF_LEN 60 137 138static void 139error_uinteger (unsigned long int i) 140{ 141 char *p, int_buf[IBUF_LEN]; 142 143 p = int_buf + IBUF_LEN - 1; 144 *p-- = '\0'; 145 146 if (i == 0) 147 *p-- = '0'; 148 149 while (i > 0) 150 { 151 *p-- = i % 10 + '0'; 152 i = i / 10; 153 } 154 155 error_string (p + 1); 156} 157 158static void 159error_integer (long int i) 160{ 161 unsigned long int u; 162 163 if (i < 0) 164 { 165 u = (unsigned long int) -i; 166 error_char ('-'); 167 } 168 else 169 u = i; 170 171 error_uinteger (u); 172} 173 174 175static size_t 176gfc_widechar_display_length (gfc_char_t c) 177{ 178 if (gfc_wide_is_printable (c) || c == '\t') 179 /* Printable ASCII character, or tabulation (output as a space). */ 180 return 1; 181 else if (c < ((gfc_char_t) 1 << 8)) 182 /* Displayed as \x?? */ 183 return 4; 184 else if (c < ((gfc_char_t) 1 << 16)) 185 /* Displayed as \u???? */ 186 return 6; 187 else 188 /* Displayed as \U???????? */ 189 return 10; 190} 191 192 193/* Length of the ASCII representation of the wide string, escaping wide 194 characters as print_wide_char_into_buffer() does. */ 195 196static size_t 197gfc_wide_display_length (const gfc_char_t *str) 198{ 199 size_t i, len; 200 201 for (i = 0, len = 0; str[i]; i++) 202 len += gfc_widechar_display_length (str[i]); 203 204 return len; 205} 206 207static int 208print_wide_char_into_buffer (gfc_char_t c, char *buf) 209{ 210 static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6', 211 '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' }; 212 213 if (gfc_wide_is_printable (c) || c == '\t') 214 { 215 buf[1] = '\0'; 216 /* Tabulation is output as a space. */ 217 buf[0] = (unsigned char) (c == '\t' ? ' ' : c); 218 return 1; 219 } 220 else if (c < ((gfc_char_t) 1 << 8)) 221 { 222 buf[4] = '\0'; 223 buf[3] = xdigit[c & 0x0F]; 224 c = c >> 4; 225 buf[2] = xdigit[c & 0x0F]; 226 227 buf[1] = 'x'; 228 buf[0] = '\\'; 229 return 4; 230 } 231 else if (c < ((gfc_char_t) 1 << 16)) 232 { 233 buf[6] = '\0'; 234 buf[5] = xdigit[c & 0x0F]; 235 c = c >> 4; 236 buf[4] = xdigit[c & 0x0F]; 237 c = c >> 4; 238 buf[3] = xdigit[c & 0x0F]; 239 c = c >> 4; 240 buf[2] = xdigit[c & 0x0F]; 241 242 buf[1] = 'u'; 243 buf[0] = '\\'; 244 return 6; 245 } 246 else 247 { 248 buf[10] = '\0'; 249 buf[9] = xdigit[c & 0x0F]; 250 c = c >> 4; 251 buf[8] = xdigit[c & 0x0F]; 252 c = c >> 4; 253 buf[7] = xdigit[c & 0x0F]; 254 c = c >> 4; 255 buf[6] = xdigit[c & 0x0F]; 256 c = c >> 4; 257 buf[5] = xdigit[c & 0x0F]; 258 c = c >> 4; 259 buf[4] = xdigit[c & 0x0F]; 260 c = c >> 4; 261 buf[3] = xdigit[c & 0x0F]; 262 c = c >> 4; 263 buf[2] = xdigit[c & 0x0F]; 264 265 buf[1] = 'U'; 266 buf[0] = '\\'; 267 return 10; 268 } 269} 270 271static char wide_char_print_buffer[11]; 272 273const char * 274gfc_print_wide_char (gfc_char_t c) 275{ 276 print_wide_char_into_buffer (c, wide_char_print_buffer); 277 return wide_char_print_buffer; 278} 279 280 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. */ 284 285static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2); 286 287static void 288show_locus (locus *loc, int c1, int c2) 289{ 290 gfc_linebuf *lb; 291 gfc_file *f; 292 gfc_char_t *p; 293 int i, offset, cmax; 294 295 /* TODO: Either limit the total length and number of included files 296 displayed or add buffering of arbitrary number of characters in 297 error messages. */ 298 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. */ 304 305 lb = loc->lb; 306 f = lb->file; 307 308 error_string (f->filename); 309 error_char (':'); 310 311 error_integer (LOCATION_LINE (lb->location)); 312 313 if ((c1 > 0) || (c2 > 0)) 314 error_char ('.'); 315 316 if (c1 > 0) 317 error_integer (c1); 318 319 if ((c1 > 0) && (c2 > 0)) 320 error_char ('-'); 321 322 if (c2 > 0) 323 error_integer (c2); 324 325 error_char (':'); 326 error_char ('\n'); 327 328 for (;;) 329 { 330 i = f->inclusion_line; 331 332 f = f->up; 333 if (f == NULL) break; 334 335 error_printf (" Included at %s:%d:", f->filename, i); 336 } 337 338 error_char ('\n'); 339 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. */ 344 345 offset = 0; 346 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. */ 351 352 if (c1 == c2) 353 c2 += 1; 354 355 cmax = (c1 < c2) ? c2 : c1; 356 if (cmax > terminal_width - 5) 357 offset = cmax - terminal_width + 5; 358 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. */ 362 363 p = &(lb->line[offset]); 364 i = gfc_wide_display_length (p); 365 if (i > terminal_width) 366 i = terminal_width - 1; 367 368 while (i > 0) 369 { 370 static char buffer[11]; 371 i -= print_wide_char_into_buffer (*p++, buffer); 372 error_string (buffer); 373 } 374 375 error_char ('\n'); 376 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. */ 380 381 c1 -= offset; 382 c2 -= offset; 383 cmax -= offset; 384 385 p = &(lb->line[offset]); 386 for (i = 0; i < cmax; i++) 387 { 388 int spaces, j; 389 spaces = gfc_widechar_display_length (*p++); 390 391 if (i == c1) 392 error_char ('1'), spaces--; 393 else if (i == c2) 394 error_char ('2'), spaces--; 395 396 for (j = 0; j < spaces; j++) 397 error_char (' '); 398 } 399 400 if (i == c1) 401 error_char ('1'); 402 else if (i == c2) 403 error_char ('2'); 404 405 error_char ('\n'); 406 407} 408 409 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. */ 413 414static void 415show_loci (locus *l1, locus *l2) 416{ 417 int m, c1, c2; 418 419 if (l1 == NULL || l1->lb == NULL) 420 { 421 error_printf ("<During initialization>\n"); 422 return; 423 } 424 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. */ 428 429 c1 = l1->nextc - l1->lb->line; 430 if (l2 == NULL) 431 { 432 show_locus (l1, c1, -1); 433 return; 434 } 435 436 c2 = l2->nextc - l2->lb->line; 437 438 if (c1 < c2) 439 m = c2 - c1; 440 else 441 m = c1 - c2; 442 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. */ 445 446 if (l1->lb != l2->lb || m > terminal_width - 10) 447 { 448 show_locus (l1, c1, -1); 449 show_locus (l2, -1, c2); 450 return; 451 } 452 453 show_locus (l1, c1, c2); 454 455 return; 456} 457 458 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: 462 463 %c Character, %d or %i Integer, %s String, %% Percent 464 %L Takes locus argument 465 %C Current locus (no argument) 466 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. 474 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. */ 478 479#define MAX_ARGS 10 480 481static void ATTRIBUTE_GCC_GFC(2,0) 482error_print (const char *type, const char *format0, va_list argp) 483{ 484 enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER, 485 TYPE_LONGINT, TYPE_ULONGINT, TYPE_CHAR, TYPE_STRING, 486 NOTYPE }; 487 struct 488 { 489 int type; 490 int pos; 491 union 492 { 493 int intval; 494 unsigned int uintval; 495 long int longintval; 496 unsigned long int ulongintval; 497 char charval; 498 const char * stringval; 499 } u; 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. */ 504 505 char c; 506 int i, n, have_l1, pos, maxpos; 507 locus *l1, *l2, *loc; 508 const char *format; 509 510 loc = l1 = l2 = NULL; 511 512 have_l1 = 0; 513 pos = -1; 514 maxpos = -1; 515 516 n = 0; 517 format = format0; 518 519 for (i = 0; i < MAX_ARGS; i++) 520 { 521 arg[i].type = NOTYPE; 522 spec[i].pos = -1; 523 } 524 525 /* First parse the format string for position specifiers. */ 526 while (*format) 527 { 528 c = *format++; 529 if (c != '%') 530 continue; 531 532 if (*format == '%') 533 { 534 format++; 535 continue; 536 } 537 538 if (ISDIGIT (*format)) 539 { 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)) 547 format++; 548 gcc_assert (*format == '$'); 549 format++; 550 } 551 else 552 pos++; 553 554 c = *format++; 555 556 if (pos > maxpos) 557 maxpos = pos; 558 559 switch (c) 560 { 561 case 'C': 562 arg[pos].type = TYPE_CURRENTLOC; 563 break; 564 565 case 'L': 566 arg[pos].type = TYPE_LOCUS; 567 break; 568 569 case 'd': 570 case 'i': 571 arg[pos].type = TYPE_INTEGER; 572 break; 573 574 case 'u': 575 arg[pos].type = TYPE_UINTEGER; 576 break; 577 578 case 'l': 579 c = *format++; 580 if (c == 'u') 581 arg[pos].type = TYPE_ULONGINT; 582 else if (c == 'i' || c == 'd') 583 arg[pos].type = TYPE_LONGINT; 584 else 585 gcc_unreachable (); 586 break; 587 588 case 'c': 589 arg[pos].type = TYPE_CHAR; 590 break; 591 592 case 's': 593 arg[pos].type = TYPE_STRING; 594 break; 595 596 default: 597 gcc_unreachable (); 598 } 599 600 spec[n++].pos = pos; 601 } 602 603 /* Then convert the values for each %-style argument. */ 604 for (pos = 0; pos <= maxpos; pos++) 605 { 606 gcc_assert (arg[pos].type != NOTYPE); 607 switch (arg[pos].type) 608 { 609 case TYPE_CURRENTLOC: 610 loc = &gfc_current_locus; 611 /* Fall through. */ 612 613 case TYPE_LOCUS: 614 if (arg[pos].type == TYPE_LOCUS) 615 loc = va_arg (argp, locus *); 616 617 if (have_l1) 618 { 619 l2 = loc; 620 arg[pos].u.stringval = "(2)"; 621 /* Point %C first offending character not the last good one. */ 622 if (arg[pos].type == TYPE_CURRENTLOC && *l2->nextc != '\0') 623 l2->nextc++; 624 } 625 else 626 { 627 l1 = loc; 628 have_l1 = 1; 629 arg[pos].u.stringval = "(1)"; 630 /* Point %C first offending character not the last good one. */ 631 if (arg[pos].type == TYPE_CURRENTLOC && *l1->nextc != '\0') 632 l1->nextc++; 633 } 634 break; 635 636 case TYPE_INTEGER: 637 arg[pos].u.intval = va_arg (argp, int); 638 break; 639 640 case TYPE_UINTEGER: 641 arg[pos].u.uintval = va_arg (argp, unsigned int); 642 break; 643 644 case TYPE_LONGINT: 645 arg[pos].u.longintval = va_arg (argp, long int); 646 break; 647 648 case TYPE_ULONGINT: 649 arg[pos].u.ulongintval = va_arg (argp, unsigned long int); 650 break; 651 652 case TYPE_CHAR: 653 arg[pos].u.charval = (char) va_arg (argp, int); 654 break; 655 656 case TYPE_STRING: 657 arg[pos].u.stringval = (const char *) va_arg (argp, char *); 658 break; 659 660 default: 661 gcc_unreachable (); 662 } 663 } 664 665 for (n = 0; spec[n].pos >= 0; n++) 666 spec[n].u = arg[spec[n].pos].u; 667 668 /* Show the current loci if we have to. */ 669 if (have_l1) 670 show_loci (l1, l2); 671 672 if (*type) 673 { 674 error_string (type); 675 error_char (' '); 676 } 677 678 have_l1 = 0; 679 format = format0; 680 n = 0; 681 682 for (; *format; format++) 683 { 684 if (*format != '%') 685 { 686 error_char (*format); 687 continue; 688 } 689 690 format++; 691 if (ISDIGIT (*format)) 692 { 693 /* This is a position specifier. See comment above. */ 694 while (ISDIGIT (*format)) 695 format++; 696 697 /* Skip over the dollar sign. */ 698 format++; 699 } 700 701 switch (*format) 702 { 703 case '%': 704 error_char ('%'); 705 break; 706 707 case 'c': 708 error_char (spec[n++].u.charval); 709 break; 710 711 case 's': 712 case 'C': /* Current locus */ 713 case 'L': /* Specified locus */ 714 error_string (spec[n++].u.stringval); 715 break; 716 717 case 'd': 718 case 'i': 719 error_integer (spec[n++].u.intval); 720 break; 721 722 case 'u': 723 error_uinteger (spec[n++].u.uintval); 724 break; 725 726 case 'l': 727 format++; 728 if (*format == 'u') 729 error_uinteger (spec[n++].u.ulongintval); 730 else 731 error_integer (spec[n++].u.longintval); 732 break; 733 734 } 735 } 736 737 error_char ('\n'); 738} 739 740 741/* Wrapper for error_print(). */ 742 743static void 744error_printf (const char *gmsgid, ...) 745{ 746 va_list argp; 747 748 va_start (argp, gmsgid); 749 error_print ("", _(gmsgid), argp); 750 va_end (argp); 751} 752 753 754/* Clear any output buffered in a pretty-print output_buffer. */ 755 756static void 757gfc_clear_pp_buffer (output_buffer *this_buffer) 758{ 759 pretty_printer *pp = global_dc->printer; 760 output_buffer *tmp_buffer = pp->buffer; 761 pp->buffer = this_buffer; 762 pp_clear_output_area (pp); 763 pp->buffer = tmp_buffer; 764 /* We need to reset last_location, otherwise we may skip caret lines 765 when we actually give a diagnostic. */ 766 global_dc->last_location = UNKNOWN_LOCATION; 767} 768 769/* The currently-printing diagnostic, for use by gfc_format_decoder, 770 for colorizing %C and %L. */ 771 772static diagnostic_info *curr_diagnostic; 773 774/* A helper function to call diagnostic_report_diagnostic, while setting 775 curr_diagnostic for the duration of the call. */ 776 777static bool 778gfc_report_diagnostic (diagnostic_info *diagnostic) 779{ 780 gcc_assert (diagnostic != NULL); 781 curr_diagnostic = diagnostic; 782 bool ret = diagnostic_report_diagnostic (global_dc, diagnostic); 783 curr_diagnostic = NULL; 784 return ret; 785} 786 787/* This is just a helper function to avoid duplicating the logic of 788 gfc_warning. */ 789 790static bool 791gfc_warning (int opt, const char *gmsgid, va_list ap) 792{ 793 va_list argp; 794 va_copy (argp, ap); 795 796 diagnostic_info diagnostic; 797 rich_location rich_loc (line_table, UNKNOWN_LOCATION); 798 bool fatal_errors = global_dc->fatal_errors; 799 pretty_printer *pp = global_dc->printer; 800 output_buffer *tmp_buffer = pp->buffer; 801 802 gfc_clear_pp_buffer (pp_warning_buffer); 803 804 if (buffered_p) 805 { 806 pp->buffer = pp_warning_buffer; 807 global_dc->fatal_errors = false; 808 /* To prevent -fmax-errors= triggering. */ 809 --werrorcount; 810 } 811 812 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, 813 DK_WARNING); 814 diagnostic.option_index = opt; 815 bool ret = gfc_report_diagnostic (&diagnostic); 816 817 if (buffered_p) 818 { 819 pp->buffer = tmp_buffer; 820 global_dc->fatal_errors = fatal_errors; 821 822 warningcount_buffered = 0; 823 werrorcount_buffered = 0; 824 /* Undo the above --werrorcount if not Werror, otherwise 825 werrorcount is correct already. */ 826 if (!ret) 827 ++werrorcount; 828 else if (diagnostic.kind == DK_ERROR) 829 ++werrorcount_buffered; 830 else 831 ++werrorcount, --warningcount, ++warningcount_buffered; 832 } 833 834 va_end (argp); 835 return ret; 836} 837 838/* Issue a warning. */ 839 840bool 841gfc_warning (int opt, const char *gmsgid, ...) 842{ 843 va_list argp; 844 845 va_start (argp, gmsgid); 846 bool ret = gfc_warning (opt, gmsgid, argp); 847 va_end (argp); 848 return ret; 849} 850 851 852/* Whether, for a feature included in a given standard set (GFC_STD_*), 853 we should issue an error or a warning, or be quiet. */ 854 855notification 856gfc_notification_std (int std) 857{ 858 bool warning; 859 860 warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings; 861 if ((gfc_option.allow_std & std) != 0 && !warning) 862 return SILENT; 863 864 return warning ? WARNING : ERROR; 865} 866 867 868/* Return a string describing the nature of a standard violation 869 * and/or the relevant version of the standard. */ 870 871char const* 872notify_std_msg(int std) 873{ 874 875 if (std & GFC_STD_F2018_DEL) 876 return _("Fortran 2018 deleted feature:"); 877 else if (std & GFC_STD_F2018_OBS) 878 return _("Fortran 2018 obsolescent feature:"); 879 else if (std & GFC_STD_F2018) 880 return _("Fortran 2018:"); 881 else if (std & GFC_STD_F2008_OBS) 882 return _("Fortran 2008 obsolescent feature:"); 883 else if (std & GFC_STD_F2008) 884 return "Fortran 2008:"; 885 else if (std & GFC_STD_F2003) 886 return "Fortran 2003:"; 887 else if (std & GFC_STD_GNU) 888 return _("GNU Extension:"); 889 else if (std & GFC_STD_LEGACY) 890 return _("Legacy Extension:"); 891 else if (std & GFC_STD_F95_OBS) 892 return _("Obsolescent feature:"); 893 else if (std & GFC_STD_F95_DEL) 894 return _("Deleted feature:"); 895 else 896 gcc_unreachable (); 897} 898 899 900/* Possibly issue a warning/error about use of a nonstandard (or deleted) 901 feature. An error/warning will be issued if the currently selected 902 standard does not contain the requested bits. Return false if 903 an error is generated. */ 904 905bool 906gfc_notify_std (int std, const char *gmsgid, ...) 907{ 908 va_list argp; 909 const char *msg, *msg2; 910 char *buffer; 911 912 /* Determine whether an error or a warning is needed. */ 913 const int wstd = std & gfc_option.warn_std; /* Standard to warn about. */ 914 const int estd = std & ~gfc_option.allow_std; /* Standard to error about. */ 915 const bool warning = (wstd != 0) && !inhibit_warnings; 916 const bool error = (estd != 0); 917 918 if (!error && !warning) 919 return true; 920 if (suppress_errors) 921 return !error; 922 923 if (error) 924 msg = notify_std_msg (estd); 925 else 926 msg = notify_std_msg (wstd); 927 928 msg2 = _(gmsgid); 929 buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2); 930 strcpy (buffer, msg); 931 strcat (buffer, " "); 932 strcat (buffer, msg2); 933 934 va_start (argp, gmsgid); 935 if (error) 936 gfc_error_opt (0, buffer, argp); 937 else 938 gfc_warning (0, buffer, argp); 939 va_end (argp); 940 941 if (error) 942 return false; 943 else 944 return (warning && !warnings_are_errors); 945} 946 947 948/* Called from output_format -- during diagnostic message processing 949 to handle Fortran specific format specifiers with the following meanings: 950 951 %C Current locus (no argument) 952 %L Takes locus argument 953*/ 954static bool 955gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec, 956 int precision, bool wide, bool set_locus, bool hash, 957 bool *quoted, const char **buffer_ptr) 958{ 959 switch (*spec) 960 { 961 case 'C': 962 case 'L': 963 { 964 static const char *result[2] = { "(1)", "(2)" }; 965 locus *loc; 966 if (*spec == 'C') 967 loc = &gfc_current_locus; 968 else 969 loc = va_arg (*text->args_ptr, locus *); 970 gcc_assert (loc->nextc - loc->lb->line >= 0); 971 unsigned int offset = loc->nextc - loc->lb->line; 972 if (*spec == 'C' && *loc->nextc != '\0') 973 /* Point %C first offending character not the last good one. */ 974 offset++; 975 /* If location[0] != UNKNOWN_LOCATION means that we already 976 processed one of %C/%L. */ 977 int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1; 978 location_t src_loc 979 = linemap_position_for_loc_and_offset (line_table, 980 loc->lb->location, 981 offset); 982 text->set_location (loc_num, src_loc, SHOW_RANGE_WITH_CARET); 983 /* Colorize the markers to match the color choices of 984 diagnostic_show_locus (the initial location has a color given 985 by the "kind" of the diagnostic, the secondary location has 986 color "range1"). */ 987 gcc_assert (curr_diagnostic != NULL); 988 const char *color 989 = (loc_num 990 ? "range1" 991 : diagnostic_get_color_for_kind (curr_diagnostic->kind)); 992 pp_string (pp, colorize_start (pp_show_color (pp), color)); 993 pp_string (pp, result[loc_num]); 994 pp_string (pp, colorize_stop (pp_show_color (pp))); 995 return true; 996 } 997 default: 998 /* Fall through info the middle-end decoder, as e.g. stor-layout.c 999 etc. diagnostics can use the FE printer while the FE is still 1000 active. */ 1001 return default_tree_printer (pp, text, spec, precision, wide, 1002 set_locus, hash, quoted, buffer_ptr); 1003 } 1004} 1005 1006/* Return a malloc'd string describing the kind of diagnostic. The 1007 caller is responsible for freeing the memory. */ 1008static char * 1009gfc_diagnostic_build_kind_prefix (diagnostic_context *context, 1010 const diagnostic_info *diagnostic) 1011{ 1012 static const char *const diagnostic_kind_text[] = { 1013#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T), 1014#include "gfc-diagnostic.def" 1015#undef DEFINE_DIAGNOSTIC_KIND 1016 "must-not-happen" 1017 }; 1018 static const char *const diagnostic_kind_color[] = { 1019#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C), 1020#include "gfc-diagnostic.def" 1021#undef DEFINE_DIAGNOSTIC_KIND 1022 NULL 1023 }; 1024 gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND); 1025 const char *text = _(diagnostic_kind_text[diagnostic->kind]); 1026 const char *text_cs = "", *text_ce = ""; 1027 pretty_printer *pp = context->printer; 1028 1029 if (diagnostic_kind_color[diagnostic->kind]) 1030 { 1031 text_cs = colorize_start (pp_show_color (pp), 1032 diagnostic_kind_color[diagnostic->kind]); 1033 text_ce = colorize_stop (pp_show_color (pp)); 1034 } 1035 return build_message_string ("%s%s:%s ", text_cs, text, text_ce); 1036} 1037 1038/* Return a malloc'd string describing a location. The caller is 1039 responsible for freeing the memory. */ 1040static char * 1041gfc_diagnostic_build_locus_prefix (diagnostic_context *context, 1042 expanded_location s) 1043{ 1044 pretty_printer *pp = context->printer; 1045 const char *locus_cs = colorize_start (pp_show_color (pp), "locus"); 1046 const char *locus_ce = colorize_stop (pp_show_color (pp)); 1047 return (s.file == NULL 1048 ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce ) 1049 : !strcmp (s.file, N_("<built-in>")) 1050 ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce) 1051 : context->show_column 1052 ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line, 1053 s.column, locus_ce) 1054 : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce)); 1055} 1056 1057/* Return a malloc'd string describing two locations. The caller is 1058 responsible for freeing the memory. */ 1059static char * 1060gfc_diagnostic_build_locus_prefix (diagnostic_context *context, 1061 expanded_location s, expanded_location s2) 1062{ 1063 pretty_printer *pp = context->printer; 1064 const char *locus_cs = colorize_start (pp_show_color (pp), "locus"); 1065 const char *locus_ce = colorize_stop (pp_show_color (pp)); 1066 1067 return (s.file == NULL 1068 ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce ) 1069 : !strcmp (s.file, N_("<built-in>")) 1070 ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce) 1071 : context->show_column 1072 ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line, 1073 MIN (s.column, s2.column), 1074 MAX (s.column, s2.column), locus_ce) 1075 : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, 1076 locus_ce)); 1077} 1078 1079/* This function prints the locus (file:line:column), the diagnostic kind 1080 (Error, Warning) and (optionally) the relevant lines of code with 1081 annotation lines with '1' and/or '2' below them. 1082 1083 With -fdiagnostic-show-caret (the default) it prints: 1084 1085 [locus of primary range]: 1086 1087 some code 1088 1 1089 Error: Some error at (1) 1090 1091 With -fno-diagnostic-show-caret or if the primary range is not 1092 valid, it prints: 1093 1094 [locus of primary range]: Error: Some error at (1) and (2) 1095*/ 1096static void 1097gfc_diagnostic_starter (diagnostic_context *context, 1098 diagnostic_info *diagnostic) 1099{ 1100 char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic); 1101 1102 expanded_location s1 = diagnostic_expand_location (diagnostic); 1103 expanded_location s2; 1104 bool one_locus = diagnostic->richloc->get_num_locations () < 2; 1105 bool same_locus = false; 1106 1107 if (!one_locus) 1108 { 1109 s2 = diagnostic_expand_location (diagnostic, 1); 1110 same_locus = diagnostic_same_line (context, s1, s2); 1111 } 1112 1113 char * locus_prefix = (one_locus || !same_locus) 1114 ? gfc_diagnostic_build_locus_prefix (context, s1) 1115 : gfc_diagnostic_build_locus_prefix (context, s1, s2); 1116 1117 if (!context->show_caret 1118 || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION 1119 || diagnostic_location (diagnostic, 0) == context->last_location) 1120 { 1121 pp_set_prefix (context->printer, 1122 concat (locus_prefix, " ", kind_prefix, NULL)); 1123 free (locus_prefix); 1124 1125 if (one_locus || same_locus) 1126 { 1127 free (kind_prefix); 1128 return; 1129 } 1130 /* In this case, we print the previous locus and prefix as: 1131 1132 [locus]:[prefix]: (1) 1133 1134 and we flush with a new line before setting the new prefix. */ 1135 pp_string (context->printer, "(1)"); 1136 pp_newline (context->printer); 1137 locus_prefix = gfc_diagnostic_build_locus_prefix (context, s2); 1138 pp_set_prefix (context->printer, 1139 concat (locus_prefix, " ", kind_prefix, NULL)); 1140 free (kind_prefix); 1141 free (locus_prefix); 1142 } 1143 else 1144 { 1145 pp_verbatim (context->printer, "%s", locus_prefix); 1146 free (locus_prefix); 1147 /* Fortran uses an empty line between locus and caret line. */ 1148 pp_newline (context->printer); 1149 pp_set_prefix (context->printer, NULL); 1150 pp_newline (context->printer); 1151 diagnostic_show_locus (context, diagnostic->richloc, diagnostic->kind); 1152 /* If the caret line was shown, the prefix does not contain the 1153 locus. */ 1154 pp_set_prefix (context->printer, kind_prefix); 1155 } 1156} 1157 1158static void 1159gfc_diagnostic_start_span (diagnostic_context *context, 1160 expanded_location exploc) 1161{ 1162 char *locus_prefix; 1163 locus_prefix = gfc_diagnostic_build_locus_prefix (context, exploc); 1164 pp_verbatim (context->printer, "%s", locus_prefix); 1165 free (locus_prefix); 1166 pp_newline (context->printer); 1167 /* Fortran uses an empty line between locus and caret line. */ 1168 pp_newline (context->printer); 1169} 1170 1171 1172static void 1173gfc_diagnostic_finalizer (diagnostic_context *context, 1174 diagnostic_info *diagnostic ATTRIBUTE_UNUSED, 1175 diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED) 1176{ 1177 pp_destroy_prefix (context->printer); 1178 pp_newline_and_flush (context->printer); 1179} 1180 1181/* Immediate warning (i.e. do not buffer the warning) with an explicit 1182 location. */ 1183 1184bool 1185gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...) 1186{ 1187 va_list argp; 1188 diagnostic_info diagnostic; 1189 rich_location rich_loc (line_table, loc); 1190 bool ret; 1191 1192 va_start (argp, gmsgid); 1193 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING); 1194 diagnostic.option_index = opt; 1195 ret = gfc_report_diagnostic (&diagnostic); 1196 va_end (argp); 1197 return ret; 1198} 1199 1200/* Immediate warning (i.e. do not buffer the warning). */ 1201 1202bool 1203gfc_warning_now (int opt, const char *gmsgid, ...) 1204{ 1205 va_list argp; 1206 diagnostic_info diagnostic; 1207 rich_location rich_loc (line_table, UNKNOWN_LOCATION); 1208 bool ret; 1209 1210 va_start (argp, gmsgid); 1211 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, 1212 DK_WARNING); 1213 diagnostic.option_index = opt; 1214 ret = gfc_report_diagnostic (&diagnostic); 1215 va_end (argp); 1216 return ret; 1217} 1218 1219/* Internal warning, do not buffer. */ 1220 1221bool 1222gfc_warning_internal (int opt, const char *gmsgid, ...) 1223{ 1224 va_list argp; 1225 diagnostic_info diagnostic; 1226 rich_location rich_loc (line_table, UNKNOWN_LOCATION); 1227 bool ret; 1228 1229 va_start (argp, gmsgid); 1230 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, 1231 DK_WARNING); 1232 diagnostic.option_index = opt; 1233 ret = gfc_report_diagnostic (&diagnostic); 1234 va_end (argp); 1235 return ret; 1236} 1237 1238/* Immediate error (i.e. do not buffer). */ 1239 1240void 1241gfc_error_now (const char *gmsgid, ...) 1242{ 1243 va_list argp; 1244 diagnostic_info diagnostic; 1245 rich_location rich_loc (line_table, UNKNOWN_LOCATION); 1246 1247 error_buffer.flag = true; 1248 1249 va_start (argp, gmsgid); 1250 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR); 1251 gfc_report_diagnostic (&diagnostic); 1252 va_end (argp); 1253} 1254 1255 1256/* Fatal error, never returns. */ 1257 1258void 1259gfc_fatal_error (const char *gmsgid, ...) 1260{ 1261 va_list argp; 1262 diagnostic_info diagnostic; 1263 rich_location rich_loc (line_table, UNKNOWN_LOCATION); 1264 1265 va_start (argp, gmsgid); 1266 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL); 1267 gfc_report_diagnostic (&diagnostic); 1268 va_end (argp); 1269 1270 gcc_unreachable (); 1271} 1272 1273/* Clear the warning flag. */ 1274 1275void 1276gfc_clear_warning (void) 1277{ 1278 gfc_clear_pp_buffer (pp_warning_buffer); 1279 warningcount_buffered = 0; 1280 werrorcount_buffered = 0; 1281} 1282 1283 1284/* Check to see if any warnings have been saved. 1285 If so, print the warning. */ 1286 1287void 1288gfc_warning_check (void) 1289{ 1290 if (! gfc_output_buffer_empty_p (pp_warning_buffer)) 1291 { 1292 pretty_printer *pp = global_dc->printer; 1293 output_buffer *tmp_buffer = pp->buffer; 1294 pp->buffer = pp_warning_buffer; 1295 pp_really_flush (pp); 1296 warningcount += warningcount_buffered; 1297 werrorcount += werrorcount_buffered; 1298 gcc_assert (warningcount_buffered + werrorcount_buffered == 1); 1299 pp->buffer = tmp_buffer; 1300 diagnostic_action_after_output (global_dc, 1301 warningcount_buffered 1302 ? DK_WARNING : DK_ERROR); 1303 diagnostic_check_max_errors (global_dc, true); 1304 } 1305} 1306 1307 1308/* Issue an error. */ 1309 1310static void 1311gfc_error_opt (int opt, const char *gmsgid, va_list ap) 1312{ 1313 va_list argp; 1314 va_copy (argp, ap); 1315 bool saved_abort_on_error = false; 1316 1317 if (warnings_not_errors) 1318 { 1319 gfc_warning (opt, gmsgid, argp); 1320 va_end (argp); 1321 return; 1322 } 1323 1324 if (suppress_errors) 1325 { 1326 va_end (argp); 1327 return; 1328 } 1329 1330 diagnostic_info diagnostic; 1331 rich_location richloc (line_table, UNKNOWN_LOCATION); 1332 bool fatal_errors = global_dc->fatal_errors; 1333 pretty_printer *pp = global_dc->printer; 1334 output_buffer *tmp_buffer = pp->buffer; 1335 1336 gfc_clear_pp_buffer (pp_error_buffer); 1337 1338 if (buffered_p) 1339 { 1340 /* To prevent -dH from triggering an abort on a buffered error, 1341 save abort_on_error and restore it below. */ 1342 saved_abort_on_error = global_dc->abort_on_error; 1343 global_dc->abort_on_error = false; 1344 pp->buffer = pp_error_buffer; 1345 global_dc->fatal_errors = false; 1346 /* To prevent -fmax-errors= triggering, we decrease it before 1347 report_diagnostic increases it. */ 1348 --errorcount; 1349 } 1350 1351 diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR); 1352 gfc_report_diagnostic (&diagnostic); 1353 1354 if (buffered_p) 1355 { 1356 pp->buffer = tmp_buffer; 1357 global_dc->fatal_errors = fatal_errors; 1358 global_dc->abort_on_error = saved_abort_on_error; 1359 1360 } 1361 1362 va_end (argp); 1363} 1364 1365 1366void 1367gfc_error_opt (int opt, const char *gmsgid, ...) 1368{ 1369 va_list argp; 1370 va_start (argp, gmsgid); 1371 gfc_error_opt (opt, gmsgid, argp); 1372 va_end (argp); 1373} 1374 1375 1376void 1377gfc_error (const char *gmsgid, ...) 1378{ 1379 va_list argp; 1380 va_start (argp, gmsgid); 1381 gfc_error_opt (0, gmsgid, argp); 1382 va_end (argp); 1383} 1384 1385 1386/* This shouldn't happen... but sometimes does. */ 1387 1388void 1389gfc_internal_error (const char *gmsgid, ...) 1390{ 1391 int e, w; 1392 va_list argp; 1393 diagnostic_info diagnostic; 1394 rich_location rich_loc (line_table, UNKNOWN_LOCATION); 1395 1396 gfc_get_errors (&w, &e); 1397 if (e > 0) 1398 exit(EXIT_FAILURE); 1399 1400 va_start (argp, gmsgid); 1401 diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE); 1402 gfc_report_diagnostic (&diagnostic); 1403 va_end (argp); 1404 1405 gcc_unreachable (); 1406} 1407 1408 1409/* Clear the error flag when we start to compile a source line. */ 1410 1411void 1412gfc_clear_error (void) 1413{ 1414 error_buffer.flag = false; 1415 warnings_not_errors = false; 1416 gfc_clear_pp_buffer (pp_error_buffer); 1417} 1418 1419 1420/* Tests the state of error_flag. */ 1421 1422bool 1423gfc_error_flag_test (void) 1424{ 1425 return error_buffer.flag 1426 || !gfc_output_buffer_empty_p (pp_error_buffer); 1427} 1428 1429 1430/* Check to see if any errors have been saved. 1431 If so, print the error. Returns the state of error_flag. */ 1432 1433bool 1434gfc_error_check (void) 1435{ 1436 if (error_buffer.flag 1437 || ! gfc_output_buffer_empty_p (pp_error_buffer)) 1438 { 1439 error_buffer.flag = false; 1440 pretty_printer *pp = global_dc->printer; 1441 output_buffer *tmp_buffer = pp->buffer; 1442 pp->buffer = pp_error_buffer; 1443 pp_really_flush (pp); 1444 ++errorcount; 1445 gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer)); 1446 pp->buffer = tmp_buffer; 1447 diagnostic_action_after_output (global_dc, DK_ERROR); 1448 diagnostic_check_max_errors (global_dc, true); 1449 return true; 1450 } 1451 1452 return false; 1453} 1454 1455/* Move the text buffered from FROM to TO, then clear 1456 FROM. Independently if there was text in FROM, TO is also 1457 cleared. */ 1458 1459static void 1460gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from, 1461 gfc_error_buffer * buffer_to) 1462{ 1463 output_buffer * from = &(buffer_from->buffer); 1464 output_buffer * to = &(buffer_to->buffer); 1465 1466 buffer_to->flag = buffer_from->flag; 1467 buffer_from->flag = false; 1468 1469 gfc_clear_pp_buffer (to); 1470 /* We make sure this is always buffered. */ 1471 to->flush_p = false; 1472 1473 if (! gfc_output_buffer_empty_p (from)) 1474 { 1475 const char *str = output_buffer_formatted_text (from); 1476 output_buffer_append_r (to, str, strlen (str)); 1477 gfc_clear_pp_buffer (from); 1478 } 1479} 1480 1481/* Save the existing error state. */ 1482 1483void 1484gfc_push_error (gfc_error_buffer *err) 1485{ 1486 gfc_move_error_buffer_from_to (&error_buffer, err); 1487} 1488 1489 1490/* Restore a previous pushed error state. */ 1491 1492void 1493gfc_pop_error (gfc_error_buffer *err) 1494{ 1495 gfc_move_error_buffer_from_to (err, &error_buffer); 1496} 1497 1498 1499/* Free a pushed error state, but keep the current error state. */ 1500 1501void 1502gfc_free_error (gfc_error_buffer *err) 1503{ 1504 gfc_clear_pp_buffer (&(err->buffer)); 1505} 1506 1507 1508/* Report the number of warnings and errors that occurred to the caller. */ 1509 1510void 1511gfc_get_errors (int *w, int *e) 1512{ 1513 if (w != NULL) 1514 *w = warningcount + werrorcount; 1515 if (e != NULL) 1516 *e = errorcount + sorrycount + werrorcount; 1517} 1518 1519 1520/* Switch errors into warnings. */ 1521 1522void 1523gfc_errors_to_warnings (bool f) 1524{ 1525 warnings_not_errors = f; 1526} 1527 1528void 1529gfc_diagnostics_init (void) 1530{ 1531 diagnostic_starter (global_dc) = gfc_diagnostic_starter; 1532 global_dc->start_span = gfc_diagnostic_start_span; 1533 diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; 1534 diagnostic_format_decoder (global_dc) = gfc_format_decoder; 1535 global_dc->caret_chars[0] = '1'; 1536 global_dc->caret_chars[1] = '2'; 1537 pp_warning_buffer = new (XNEW (output_buffer)) output_buffer (); 1538 pp_warning_buffer->flush_p = false; 1539 /* pp_error_buffer is statically allocated. This simplifies memory 1540 management when using gfc_push/pop_error. */ 1541 pp_error_buffer = &(error_buffer.buffer); 1542 pp_error_buffer->flush_p = false; 1543} 1544 1545void 1546gfc_diagnostics_finish (void) 1547{ 1548 tree_diagnostics_defaults (global_dc); 1549 /* We still want to use the gfc starter and finalizer, not the tree 1550 defaults. */ 1551 diagnostic_starter (global_dc) = gfc_diagnostic_starter; 1552 diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer; 1553 global_dc->caret_chars[0] = '^'; 1554 global_dc->caret_chars[1] = '^'; 1555} 1556