gcc/fortran/error.c

   1 #pragma GCC optimize("O0")
   2 /* Handle errors.
   3    Copyright (C) 2000-2019 Free Software Foundation, Inc.
   4    Contributed by Andy Vaught & Niels Kristian Bech Jensen
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 /* Handle the inevitable errors.  A major catch here is that things
  23    flagged as errors in one match subroutine can conceivably be legal
  24    elsewhere.  This means that error messages are recorded and saved
  25    for possible use later.  If a line does not match a legal
  26    construction, then the saved error message is reported.  */
  27
  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 "diagnostic-color.h"
  36 #include "tree-diagnostic.h" /* tree_diagnostics_defaults */
  37
  38 static int suppress_errors = 0;
  39
  40 static bool warnings_not_errors = false;
  41
  42 static int terminal_width;
  43
  44 /* True if the error/warnings should be buffered.  */
  45 static bool buffered_p;
  46
  47 static gfc_error_buffer error_buffer;
  48 /* These are always buffered buffers (.flush_p == false) to be used by
  49    the pretty-printer.  */
  50 static output_buffer *pp_error_buffer, *pp_warning_buffer;
  51 static int warningcount_buffered, werrorcount_buffered;
  52
  53 /* Return true if there output_buffer is empty.  */
  54
  55 static bool
  56 gfc_output_buffer_empty_p (const output_buffer * buf)
  57 {
  58   return output_buffer_last_position_in_text (buf) == NULL;
  59 }
  60
  61 /* Go one level deeper suppressing errors.  */
  62
  63 void
  64 gfc_push_suppress_errors (void)
  65 {
  66   gcc_assert (suppress_errors >= 0);
  67   ++suppress_errors;
  68 }
  69
  70 static void
  71 gfc_error_opt (int opt, const char *gmsgid, va_list ap)  ATTRIBUTE_GCC_GFC(2,0);
  72
  73 static bool
  74 gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
  75
  76
  77 /* Leave one level of error suppressing.  */
  78
  79 void
  80 gfc_pop_suppress_errors (void)
  81 {
  82   gcc_assert (suppress_errors > 0);
  83   --suppress_errors;
  84 }
  85
  86
  87 /* Determine terminal width (for trimming source lines in output).  */
  88
  89 static int
  90 gfc_get_terminal_width (void)
  91 {
  92   return isatty (STDERR_FILENO) ? get_terminal_width () : INT_MAX;
  93 }
  94
  95
  96 /* Per-file error initialization.  */
  97
  98 void
  99 gfc_error_init_1 (void)
 100 {
 101   terminal_width = gfc_get_terminal_width ();
 102   gfc_buffer_error (false);
 103 }
 104
 105
 106 /* Set the flag for buffering errors or not.  */
 107
 108 void
 109 gfc_buffer_error (bool flag)
 110 {
 111   buffered_p = flag;
 112 }
 113
 114
 115 /* Add a single character to the error buffer or output depending on
 116    buffered_p.  */
 117
 118 static void
 119 error_char (char)
 120 {
 121   /* FIXME: Unused function to be removed in a subsequent patch.  */
 122 }
 123
 124
 125 /* Copy a string to wherever it needs to go.  */
 126
 127 static void
 128 error_string (const char *p)
 129 {
 130   while (*p)
 131     error_char (*p++);
 132 }
 133
 134
 135 /* Print a formatted integer to the error buffer or output.  */
 136
 137 #define IBUF_LEN 60
 138
 139 static void
 140 error_uinteger (unsigned long int i)
 141 {
 142   char *p, int_buf[IBUF_LEN];
 143
 144   p = int_buf + IBUF_LEN - 1;
 145   *p-- = '\0';
 146
 147   if (i == 0)
 148     *p-- = '0';
 149
 150   while (i > 0)
 151     {
 152       *p-- = i % 10 + '0';
 153       i = i / 10;
 154     }
 155
 156   error_string (p + 1);
 157 }
 158
 159 static void
 160 error_integer (long int i)
 161 {
 162   unsigned long int u;
 163
 164   if (i < 0)
 165     {
 166       u = (unsigned long int) -i;
 167       error_char ('-');
 168     }
 169   else
 170     u = i;
 171
 172   error_uinteger (u);
 173 }
 174
 175
 176 static size_t
 177 gfc_widechar_display_length (gfc_char_t c)
 178 {
 179   if (gfc_wide_is_printable (c) || c == '\t')
 180     /* Printable ASCII character, or tabulation (output as a space).  */
 181     return 1;
 182   else if (c < ((gfc_char_t) 1 << 8))
 183     /* Displayed as \x??  */
 184     return 4;
 185   else if (c < ((gfc_char_t) 1 << 16))
 186     /* Displayed as \u????  */
 187     return 6;
 188   else
 189     /* Displayed as \U????????  */
 190     return 10;
 191 }
 192
 193
 194 /* Length of the ASCII representation of the wide string, escaping wide
 195    characters as print_wide_char_into_buffer() does.  */
 196
 197 static size_t
 198 gfc_wide_display_length (const gfc_char_t *str)
 199 {
 200   size_t i, len;
 201
 202   for (i = 0, len = 0; str[i]; i++)
 203     len += gfc_widechar_display_length (str[i]);
 204
 205   return len;
 206 }
 207
 208 static int
 209 print_wide_char_into_buffer (gfc_char_t c, char *buf)
 210 {
 211   static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
 212     '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
 213
 214   if (gfc_wide_is_printable (c) || c == '\t')
 215     {
 216       buf[1] = '\0';
 217       /* Tabulation is output as a space.  */
 218       buf[0] = (unsigned char) (c == '\t' ? ' ' : c);
 219       return 1;
 220     }
 221   else if (c < ((gfc_char_t) 1 << 8))
 222     {
 223       buf[4] = '\0';
 224       buf[3] = xdigit[c & 0x0F];
 225       c = c >> 4;
 226       buf[2] = xdigit[c & 0x0F];
 227
 228       buf[1] = 'x';
 229       buf[0] = '\\';
 230       return 4;
 231     }
 232   else if (c < ((gfc_char_t) 1 << 16))
 233     {
 234       buf[6] = '\0';
 235       buf[5] = xdigit[c & 0x0F];
 236       c = c >> 4;
 237       buf[4] = xdigit[c & 0x0F];
 238       c = c >> 4;
 239       buf[3] = xdigit[c & 0x0F];
 240       c = c >> 4;
 241       buf[2] = xdigit[c & 0x0F];
 242
 243       buf[1] = 'u';
 244       buf[0] = '\\';
 245       return 6;
 246     }
 247   else
 248     {
 249       buf[10] = '\0';
 250       buf[9] = xdigit[c & 0x0F];
 251       c = c >> 4;
 252       buf[8] = xdigit[c & 0x0F];
 253       c = c >> 4;
 254       buf[7] = xdigit[c & 0x0F];
 255       c = c >> 4;
 256       buf[6] = xdigit[c & 0x0F];
 257       c = c >> 4;
 258       buf[5] = xdigit[c & 0x0F];
 259       c = c >> 4;
 260       buf[4] = xdigit[c & 0x0F];
 261       c = c >> 4;
 262       buf[3] = xdigit[c & 0x0F];
 263       c = c >> 4;
 264       buf[2] = xdigit[c & 0x0F];
 265
 266       buf[1] = 'U';
 267       buf[0] = '\\';
 268       return 10;
 269     }
 270 }
 271
 272 static char wide_char_print_buffer[11];
 273
 274 const char *
 275 gfc_print_wide_char (gfc_char_t c)
 276 {
 277   print_wide_char_into_buffer (c, wide_char_print_buffer);
 278   return wide_char_print_buffer;
 279 }
 280
 281
 282 /* Show the file, where it was included, and the source line, give a
 283    locus.  Calls error_printf() recursively, but the recursion is at
 284    most one level deep.  */
 285
 286 static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
 287
 288 static void
 289 show_locus (locus *loc, int c1, int c2)
 290 {
 291   gfc_linebuf *lb;
 292   gfc_file *f;
 293   gfc_char_t *p;
 294   int i, offset, cmax;
 295
 296   /* TODO: Either limit the total length and number of included files
 297      displayed or add buffering of arbitrary number of characters in
 298      error messages.  */
 299
 300   /* Write out the error header line, giving the source file and error
 301      location (in GNU standard "[file]:[line].[column]:" format),
 302      followed by an "included by" stack and a blank line.  This header
 303      format is matched by a testsuite parser defined in
 304      lib/gfortran-dg.exp.  */
 305
 306   lb = loc->lb;
 307   f = lb->file;
 308
 309   error_string (f->filename);
 310   error_char (':');
 311
 312   error_integer (LOCATION_LINE (lb->location));
 313
 314   if ((c1 > 0) || (c2 > 0))
 315     error_char ('.');
 316
 317   if (c1 > 0)
 318     error_integer (c1);
 319
 320   if ((c1 > 0) && (c2 > 0))
 321     error_char ('-');
 322
 323   if (c2 > 0)
 324     error_integer (c2);
 325
 326   error_char (':');
 327   error_char ('\n');
 328
 329   for (;;)
 330     {
 331       i = f->inclusion_line;
 332
 333       f = f->up;
 334       if (f == NULL) break;
 335
 336       error_printf ("    Included at %s:%d:", f->filename, i);
 337     }
 338
 339   error_char ('\n');
 340
 341   /* Calculate an appropriate horizontal offset of the source line in
 342      order to get the error locus within the visible portion of the
 343      line.  Note that if the margin of 5 here is changed, the
 344      corresponding margin of 10 in show_loci should be changed.  */
 345
 346   offset = 0;
 347
 348   /* If the two loci would appear in the same column, we shift
 349      '2' one column to the right, so as to print '12' rather than
 350      just '1'.  We do this here so it will be accounted for in the
 351      margin calculations.  */
 352
 353   if (c1 == c2)
 354     c2 += 1;
 355
 356   cmax = (c1 < c2) ? c2 : c1;
 357   if (cmax > terminal_width - 5)
 358     offset = cmax - terminal_width + 5;
 359
 360   /* Show the line itself, taking care not to print more than what can
 361      show up on the terminal.  Tabs are converted to spaces, and
 362      nonprintable characters are converted to a "\xNN" sequence.  */
 363
 364   p = &(lb->line[offset]);
 365   i = gfc_wide_display_length (p);
 366   if (i > terminal_width)
 367     i = terminal_width - 1;
 368
 369   while (i > 0)
 370     {
 371       static char buffer[11];
 372       i -= print_wide_char_into_buffer (*p++, buffer);
 373       error_string (buffer);
 374     }
 375
 376   error_char ('\n');
 377
 378   /* Show the '1' and/or '2' corresponding to the column of the error
 379      locus.  Note that a value of -1 for c1 or c2 will simply cause
 380      the relevant number not to be printed.  */
 381
 382   c1 -= offset;
 383   c2 -= offset;
 384   cmax -= offset;
 385
 386   p = &(lb->line[offset]);
 387   for (i = 0; i < cmax; i++)
 388     {
 389       int spaces, j;
 390       spaces = gfc_widechar_display_length (*p++);
 391
 392       if (i == c1)
 393         error_char ('1'), spaces--;
 394       else if (i == c2)
 395         error_char ('2'), spaces--;
 396
 397       for (j = 0; j < spaces; j++)
 398         error_char (' ');
 399     }
 400
 401   if (i == c1)
 402     error_char ('1');
 403   else if (i == c2)
 404     error_char ('2');
 405
 406   error_char ('\n');
 407
 408 }
 409
 410
 411 /* As part of printing an error, we show the source lines that caused
 412    the problem.  We show at least one, and possibly two loci; the two
 413    loci may or may not be on the same source line.  */
 414
 415 static void
 416 show_loci (locus *l1, locus *l2)
 417 {
 418   int m, c1, c2;
 419
 420   if (l1 == NULL || l1->lb == NULL)
 421     {
 422       error_printf ("<During initialization>\n");
 423       return;
 424     }
 425
 426   /* While calculating parameters for printing the loci, we consider possible
 427      reasons for printing one per line.  If appropriate, print the loci
 428      individually; otherwise we print them both on the same line.  */
 429
 430   c1 = l1->nextc - l1->lb->line;
 431   if (l2 == NULL)
 432     {
 433       show_locus (l1, c1, -1);
 434       return;
 435     }
 436
 437   c2 = l2->nextc - l2->lb->line;
 438
 439   if (c1 < c2)
 440     m = c2 - c1;
 441   else
 442     m = c1 - c2;
 443
 444   /* Note that the margin value of 10 here needs to be less than the
 445      margin of 5 used in the calculation of offset in show_locus.  */
 446
 447   if (l1->lb != l2->lb || m > terminal_width - 10)
 448     {
 449       show_locus (l1, c1, -1);
 450       show_locus (l2, -1, c2);
 451       return;
 452     }
 453
 454   show_locus (l1, c1, c2);
 455
 456   return;
 457 }
 458
 459
 460 /* Workhorse for the error printing subroutines.  This subroutine is
 461    inspired by g77's error handling and is similar to printf() with
 462    the following %-codes:
 463
 464    %c Character, %d or %i Integer, %s String, %% Percent
 465    %L  Takes locus argument
 466    %C  Current locus (no argument)
 467
 468    If a locus pointer is given, the actual source line is printed out
 469    and the column is indicated.  Since we want the error message at
 470    the bottom of any source file information, we must scan the
 471    argument list twice -- once to determine whether the loci are
 472    present and record this for printing, and once to print the error
 473    message after and loci have been printed.  A maximum of two locus
 474    arguments are permitted.
 475
 476    This function is also called (recursively) by show_locus in the
 477    case of included files; however, as show_locus does not resupply
 478    any loci, the recursion is at most one level deep.  */
 479
 480 #define MAX_ARGS 10
 481
 482 static void ATTRIBUTE_GCC_GFC(2,0)
 483 error_print (const char *type, const char *format0, va_list argp)
 484 {
 485   enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER,
 486          TYPE_LONGINT, TYPE_ULONGINT, TYPE_CHAR, TYPE_STRING,
 487          NOTYPE };
 488   struct
 489   {
 490     int type;
 491     int pos;
 492     union
 493     {
 494       int intval;
 495       unsigned int uintval;
 496       long int longintval;
 497       unsigned long int ulongintval;
 498       char charval;
 499       const char * stringval;
 500     } u;
 501   } arg[MAX_ARGS], spec[MAX_ARGS];
 502   /* spec is the array of specifiers, in the same order as they
 503      appear in the format string.  arg is the array of arguments,
 504      in the same order as they appear in the va_list.  */
 505
 506   char c;
 507   int i, n, have_l1, pos, maxpos;
 508   locus *l1, *l2, *loc;
 509   const char *format;
 510
 511   loc = l1 = l2 = NULL;
 512
 513   have_l1 = 0;
 514   pos = -1;
 515   maxpos = -1;
 516
 517   n = 0;
 518   format = format0;
 519
 520   for (i = 0; i < MAX_ARGS; i++)
 521     {
 522       arg[i].type = NOTYPE;
 523       spec[i].pos = -1;
 524     }
 525
 526   /* First parse the format string for position specifiers.  */
 527   while (*format)
 528     {
 529       c = *format++;
 530       if (c != '%')
 531         continue;
 532
 533       if (*format == '%')
 534         {
 535           format++;
 536           continue;
 537         }
 538
 539       if (ISDIGIT (*format))
 540         {
 541           /* This is a position specifier.  For example, the number
 542              12 in the format string "%12$d", which specifies the third
 543              argument of the va_list, formatted in %d format.
 544              For details, see "man 3 printf".  */
 545           pos = atoi(format) - 1;
 546           gcc_assert (pos >= 0);
 547           while (ISDIGIT(*format))
 548             format++;
 549           gcc_assert (*format == '$');
 550           format++;
 551         }
 552       else
 553         pos++;
 554
 555       c = *format++;
 556
 557       if (pos > maxpos)
 558         maxpos = pos;
 559
 560       switch (c)
 561         {
 562           case 'C':
 563             arg[pos].type = TYPE_CURRENTLOC;
 564             break;
 565
 566           case 'L':
 567             arg[pos].type = TYPE_LOCUS;
 568             break;
 569
 570           case 'd':
 571           case 'i':
 572             arg[pos].type = TYPE_INTEGER;
 573             break;
 574
 575           case 'u':
 576             arg[pos].type = TYPE_UINTEGER;
 577             break;
 578
 579           case 'l':
 580             c = *format++;
 581             if (c == 'u')
 582               arg[pos].type = TYPE_ULONGINT;
 583             else if (c == 'i' || c == 'd')
 584               arg[pos].type = TYPE_LONGINT;
 585             else
 586               gcc_unreachable ();
 587             break;
 588
 589           case 'c':
 590             arg[pos].type = TYPE_CHAR;
 591             break;
 592
 593           case 's':
 594             arg[pos].type = TYPE_STRING;
 595             break;
 596
 597           default:
 598             gcc_unreachable ();
 599         }
 600
 601       spec[n++].pos = pos;
 602     }
 603
 604   /* Then convert the values for each %-style argument.  */
 605   for (pos = 0; pos <= maxpos; pos++)
 606     {
 607       gcc_assert (arg[pos].type != NOTYPE);
 608       switch (arg[pos].type)
 609         {
 610           case TYPE_CURRENTLOC:
 611             loc = &gfc_current_locus;
 612             /* Fall through.  */
 613
 614           case TYPE_LOCUS:
 615             if (arg[pos].type == TYPE_LOCUS)
 616               loc = va_arg (argp, locus *);
 617
 618             if (have_l1)
 619               {
 620                 l2 = loc;
 621                 arg[pos].u.stringval = "(2)";
 622                 /* Point %C first offending character not the last good one. */
 623                 if (arg[pos].type == TYPE_CURRENTLOC && *l2->nextc != '\0')
 624                   l2->nextc++;
 625               }
 626             else
 627               {
 628                 l1 = loc;
 629                 have_l1 = 1;
 630                 arg[pos].u.stringval = "(1)";
 631                 /* Point %C first offending character not the last good one. */
 632                 if (arg[pos].type == TYPE_CURRENTLOC && *l1->nextc != '\0')
 633                   l1->nextc++;
 634               }
 635             break;
 636
 637           case TYPE_INTEGER:
 638             arg[pos].u.intval = va_arg (argp, int);
 639             break;
 640
 641           case TYPE_UINTEGER:
 642             arg[pos].u.uintval = va_arg (argp, unsigned int);
 643             break;
 644
 645           case TYPE_LONGINT:
 646             arg[pos].u.longintval = va_arg (argp, long int);
 647             break;
 648
 649           case TYPE_ULONGINT:
 650             arg[pos].u.ulongintval = va_arg (argp, unsigned long int);
 651             break;
 652
 653           case TYPE_CHAR:
 654             arg[pos].u.charval = (char) va_arg (argp, int);
 655             break;
 656
 657           case TYPE_STRING:
 658             arg[pos].u.stringval = (const char *) va_arg (argp, char *);
 659             break;
 660
 661           default:
 662             gcc_unreachable ();
 663         }
 664     }
 665
 666   for (n = 0; spec[n].pos >= 0; n++)
 667     spec[n].u = arg[spec[n].pos].u;
 668
 669   /* Show the current loci if we have to.  */
 670   if (have_l1)
 671     show_loci (l1, l2);
 672
 673   if (*type)
 674     {
 675       error_string (type);
 676       error_char (' ');
 677     }
 678
 679   have_l1 = 0;
 680   format = format0;
 681   n = 0;
 682
 683   for (; *format; format++)
 684     {
 685       if (*format != '%')
 686         {
 687           error_char (*format);
 688           continue;
 689         }
 690
 691       format++;
 692       if (ISDIGIT (*format))
 693         {
 694           /* This is a position specifier.  See comment above.  */
 695           while (ISDIGIT (*format))
 696             format++;
 697
 698           /* Skip over the dollar sign.  */
 699           format++;
 700         }
 701
 702       switch (*format)
 703         {
 704         case '%':
 705           error_char ('%');
 706           break;
 707
 708         case 'c':
 709           error_char (spec[n++].u.charval);
 710           break;
 711
 712         case 's':
 713         case 'C':               /* Current locus */
 714         case 'L':               /* Specified locus */
 715           error_string (spec[n++].u.stringval);
 716           break;
 717
 718         case 'd':
 719         case 'i':
 720           error_integer (spec[n++].u.intval);
 721           break;
 722
 723         case 'u':
 724           error_uinteger (spec[n++].u.uintval);
 725           break;
 726
 727         case 'l':
 728           format++;
 729           if (*format == 'u')
 730             error_uinteger (spec[n++].u.ulongintval);
 731           else
 732             error_integer (spec[n++].u.longintval);
 733           break;
 734
 735         }
 736     }
 737
 738   error_char ('\n');
 739 }
 740
 741
 742 /* Wrapper for error_print().  */
 743
 744 static void
 745 error_printf (const char *gmsgid, ...)
 746 {
 747   va_list argp;
 748
 749   va_start (argp, gmsgid);
 750   error_print ("", _(gmsgid), argp);
 751   va_end (argp);
 752 }
 753
 754
 755 /* Clear any output buffered in a pretty-print output_buffer.  */
 756
 757 static void
 758 gfc_clear_pp_buffer (output_buffer *this_buffer)
 759 {
 760   pretty_printer *pp = global_dc->printer;
 761   output_buffer *tmp_buffer = pp->buffer;
 762   pp->buffer = this_buffer;
 763   pp_clear_output_area (pp);
 764   pp->buffer = tmp_buffer;
 765   /* We need to reset last_location, otherwise we may skip caret lines
 766      when we actually give a diagnostic.  */
 767   global_dc->last_location = UNKNOWN_LOCATION;
 768 }
 769
 770 /* The currently-printing diagnostic, for use by gfc_format_decoder,
 771    for colorizing %C and %L.  */
 772
 773 static diagnostic_info *curr_diagnostic;
 774
 775 /* A helper function to call diagnostic_report_diagnostic, while setting
 776    curr_diagnostic for the duration of the call.  */
 777
 778 static bool
 779 gfc_report_diagnostic (diagnostic_info *diagnostic)
 780 {
 781   gcc_assert (diagnostic != NULL);
 782   curr_diagnostic = diagnostic;
 783   bool ret = diagnostic_report_diagnostic (global_dc, diagnostic);
 784   curr_diagnostic = NULL;
 785   return ret;
 786 }
 787
 788 /* This is just a helper function to avoid duplicating the logic of
 789    gfc_warning.  */
 790
 791 static bool
 792 gfc_warning (int opt, const char *gmsgid, va_list ap)
 793 {
 794   va_list argp;
 795   va_copy (argp, ap);
 796
 797   diagnostic_info diagnostic;
 798   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
 799   bool fatal_errors = global_dc->fatal_errors;
 800   pretty_printer *pp = global_dc->printer;
 801   output_buffer *tmp_buffer = pp->buffer;
 802
 803   gfc_clear_pp_buffer (pp_warning_buffer);
 804
 805   if (buffered_p)
 806     {
 807       pp->buffer = pp_warning_buffer;
 808       global_dc->fatal_errors = false;
 809       /* To prevent -fmax-errors= triggering.  */
 810       --werrorcount;
 811     }
 812
 813   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
 814                        DK_WARNING);
 815   diagnostic.option_index = opt;
 816   bool ret = gfc_report_diagnostic (&diagnostic);
 817
 818   if (buffered_p)
 819     {
 820       pp->buffer = tmp_buffer;
 821       global_dc->fatal_errors = fatal_errors;
 822
 823       warningcount_buffered = 0;
 824       werrorcount_buffered = 0;
 825       /* Undo the above --werrorcount if not Werror, otherwise
 826          werrorcount is correct already.  */
 827       if (!ret)
 828         ++werrorcount;
 829       else if (diagnostic.kind == DK_ERROR)
 830         ++werrorcount_buffered;
 831       else
 832         ++werrorcount, --warningcount, ++warningcount_buffered;
 833     }
 834
 835   va_end (argp);
 836   return ret;
 837 }
 838
 839 /* Issue a warning.  */
 840
 841 bool
 842 gfc_warning (int opt, const char *gmsgid, ...)
 843 {
 844   va_list argp;
 845
 846   va_start (argp, gmsgid);
 847   bool ret = gfc_warning (opt, gmsgid, argp);
 848   va_end (argp);
 849   return ret;
 850 }
 851
 852
 853 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 854    we should issue an error or a warning, or be quiet.  */
 855
 856 notification
 857 gfc_notification_std (int std)
 858 {
 859   bool warning;
 860
 861   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 862   if ((gfc_option.allow_std & std) != 0 && !warning)
 863     return SILENT;
 864
 865   return warning ? WARNING : ERROR;
 866 }
 867
 868
 869 /* Return a string describing the nature of a standard violation
 870  * and/or the relevant version of the standard.  */
 871
 872 char const*
 873 notify_std_msg(int std)
 874 {
 875
 876   if (std & GFC_STD_F2018_DEL)
 877     return _("Fortran 2018 deleted feature:");
 878   else if (std & GFC_STD_F2018_OBS)
 879     return _("Fortran 2018 obsolescent feature:");
 880   else if (std & GFC_STD_F2018)
 881     return _("Fortran 2018:");
 882   else if (std & GFC_STD_F2008_OBS)
 883     return _("Fortran 2008 obsolescent feature:");
 884   else if (std & GFC_STD_F2008)
 885     return "Fortran 2008:";
 886   else if (std & GFC_STD_F2003)
 887     return "Fortran 2003:";
 888   else if (std & GFC_STD_GNU)
 889     return _("GNU Extension:");
 890   else if (std & GFC_STD_LEGACY)
 891     return _("Legacy Extension:");
 892   else if (std & GFC_STD_F95_OBS)
 893     return _("Obsolescent feature:");
 894   else if (std & GFC_STD_F95_DEL)
 895     return _("Deleted feature:");
 896   else
 897     gcc_unreachable ();
 898 }
 899
 900
 901 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 902    feature.  An error/warning will be issued if the currently selected
 903    standard does not contain the requested bits.  Return false if
 904    an error is generated.  */
 905
 906 bool
 907 gfc_notify_std (int std, const char *gmsgid, ...)
 908 {
 909   va_list argp;
 910   const char *msg, *msg2;
 911   char *buffer;
 912
 913   /* Determine whether an error or a warning is needed.  */
 914   const int wstd = std & gfc_option.warn_std;    /* Standard to warn about.  */
 915   const int estd = std & ~gfc_option.allow_std;  /* Standard to error about.  */
 916   const bool warning = (wstd != 0) && !inhibit_warnings;
 917   const bool error = (estd != 0);
 918
 919   if (!error && !warning)
 920     return true;
 921   if (suppress_errors)
 922     return !error;
 923
 924   if (error)
 925     msg = notify_std_msg (estd);
 926   else
 927     msg = notify_std_msg (wstd);
 928
 929   msg2 = _(gmsgid);
 930   buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2);
 931   strcpy (buffer, msg);
 932   strcat (buffer, " ");
 933   strcat (buffer, msg2);
 934
 935   va_start (argp, gmsgid);
 936   if (error)
 937     gfc_error_opt (0, buffer, argp);
 938   else
 939     gfc_warning (0, buffer, argp);
 940   va_end (argp);
 941
 942   if (error)
 943     return false;
 944   else
 945     return (warning && !warnings_are_errors);
 946 }
 947
 948
 949 /* Called from output_format -- during diagnostic message processing
 950    to handle Fortran specific format specifiers with the following meanings:
 951
 952    %C  Current locus (no argument)
 953    %L  Takes locus argument
 954 */
 955 static bool
 956 gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec,
 957                     int precision, bool wide, bool set_locus, bool hash,
 958                     bool *quoted, const char **buffer_ptr)
 959 {
 960   switch (*spec)
 961     {
 962     case 'C':
 963     case 'L':
 964       {
 965         static const char *result[2] = { "(1)", "(2)" };
 966         locus *loc;
 967         if (*spec == 'C')
 968           loc = &gfc_current_locus;
 969         else
 970           loc = va_arg (*text->args_ptr, locus *);
 971         gcc_assert (loc->nextc - loc->lb->line >= 0);
 972         unsigned int offset = loc->nextc - loc->lb->line;
 973         if (*spec == 'C' && *loc->nextc != '\0')
 974           /* Point %C first offending character not the last good one. */
 975           offset++;
 976         /* If location[0] != UNKNOWN_LOCATION means that we already
 977            processed one of %C/%L.  */
 978         int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1;
 979         location_t src_loc
 980           = linemap_position_for_loc_and_offset (line_table,
 981                                                  loc->lb->location,
 982                                                  offset);
 983         text->set_location (loc_num, src_loc, SHOW_RANGE_WITH_CARET);
 984         /* Colorize the markers to match the color choices of
 985            diagnostic_show_locus (the initial location has a color given
 986            by the "kind" of the diagnostic, the secondary location has
 987            color "range1").  */
 988         gcc_assert (curr_diagnostic != NULL);
 989         const char *color
 990           = (loc_num
 991              ? "range1"
 992              : diagnostic_get_color_for_kind (curr_diagnostic->kind));
 993         pp_string (pp, colorize_start (pp_show_color (pp), color));
 994         pp_string (pp, result[loc_num]);
 995         pp_string (pp, colorize_stop (pp_show_color (pp)));
 996         return true;
 997       }
 998     default:
 999       /* Fall through info the middle-end decoder, as e.g. stor-layout.c
1000          etc. diagnostics can use the FE printer while the FE is still
1001          active.  */
1002       return default_tree_printer (pp, text, spec, precision, wide,
1003                                    set_locus, hash, quoted, buffer_ptr);
1004     }
1005 }
1006
1007 /* Return a malloc'd string describing the kind of diagnostic.  The
1008    caller is responsible for freeing the memory.  */
1009 static char *
1010 gfc_diagnostic_build_kind_prefix (diagnostic_context *context,
1011                                   const diagnostic_info *diagnostic)
1012 {
1013   static const char *const diagnostic_kind_text[] = {
1014 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T),
1015 #include "gfc-diagnostic.def"
1016 #undef DEFINE_DIAGNOSTIC_KIND
1017     "must-not-happen"
1018   };
1019   static const char *const diagnostic_kind_color[] = {
1020 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C),
1021 #include "gfc-diagnostic.def"
1022 #undef DEFINE_DIAGNOSTIC_KIND
1023     NULL
1024   };
1025   gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND);
1026   const char *text = _(diagnostic_kind_text[diagnostic->kind]);
1027   const char *text_cs = "", *text_ce = "";
1028   pretty_printer *pp = context->printer;
1029
1030   if (diagnostic_kind_color[diagnostic->kind])
1031     {
1032       text_cs = colorize_start (pp_show_color (pp),
1033                                 diagnostic_kind_color[diagnostic->kind]);
1034       text_ce = colorize_stop (pp_show_color (pp));
1035     }
1036   return build_message_string ("%s%s:%s ", text_cs, text, text_ce);
1037 }
1038
1039 /* Return a malloc'd string describing a location.  The caller is
1040    responsible for freeing the memory.  */
1041 static char *
1042 gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
1043                                    expanded_location s)
1044 {
1045   pretty_printer *pp = context->printer;
1046   const char *locus_cs = colorize_start (pp_show_color (pp), "locus");
1047   const char *locus_ce = colorize_stop (pp_show_color (pp));
1048   return (s.file == NULL
1049           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
1050           : !strcmp (s.file, N_("<built-in>"))
1051           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1052           : context->show_column
1053           ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line,
1054                                   s.column, locus_ce)
1055           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce));
1056 }
1057
1058 /* Return a malloc'd string describing two locations.  The caller is
1059    responsible for freeing the memory.  */
1060 static char *
1061 gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
1062                                    expanded_location s, expanded_location s2)
1063 {
1064   pretty_printer *pp = context->printer;
1065   const char *locus_cs = colorize_start (pp_show_color (pp), "locus");
1066   const char *locus_ce = colorize_stop (pp_show_color (pp));
1067
1068   return (s.file == NULL
1069           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
1070           : !strcmp (s.file, N_("<built-in>"))
1071           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1072           : context->show_column
1073           ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line,
1074                                   MIN (s.column, s2.column),
1075                                   MAX (s.column, s2.column), locus_ce)
1076           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line,
1077                                   locus_ce));
1078 }
1079
1080 /* This function prints the locus (file:line:column), the diagnostic kind
1081    (Error, Warning) and (optionally) the relevant lines of code with
1082    annotation lines with '1' and/or '2' below them.
1083
1084    With -fdiagnostic-show-caret (the default) it prints:
1085
1086        [locus of primary range]:
1087
1088           some code
1089                  1
1090        Error: Some error at (1)
1091
1092   With -fno-diagnostic-show-caret or if the primary range is not
1093   valid, it prints:
1094
1095        [locus of primary range]: Error: Some error at (1) and (2)
1096 */
1097 static void
1098 gfc_diagnostic_starter (diagnostic_context *context,
1099                         diagnostic_info *diagnostic)
1100 {
1101   char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic);
1102
1103   expanded_location s1 = diagnostic_expand_location (diagnostic);
1104   expanded_location s2;
1105   bool one_locus = diagnostic->richloc->get_num_locations () < 2;
1106   bool same_locus = false;
1107
1108   if (!one_locus)
1109     {
1110       s2 = diagnostic_expand_location (diagnostic, 1);
1111       same_locus = diagnostic_same_line (context, s1, s2);
1112     }
1113
1114   char * locus_prefix = (one_locus || !same_locus)
1115     ? gfc_diagnostic_build_locus_prefix (context, s1)
1116     : gfc_diagnostic_build_locus_prefix (context, s1, s2);
1117
1118   if (!context->show_caret
1119       || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION
1120       || diagnostic_location (diagnostic, 0) == context->last_location)
1121     {
1122       pp_set_prefix (context->printer,
1123                      concat (locus_prefix, " ", kind_prefix, NULL));
1124       free (locus_prefix);
1125
1126       if (one_locus || same_locus)
1127         {
1128           free (kind_prefix);
1129           return;
1130         }
1131       /* In this case, we print the previous locus and prefix as:
1132
1133           [locus]:[prefix]: (1)
1134
1135          and we flush with a new line before setting the new prefix.  */
1136       pp_string (context->printer, "(1)");
1137       pp_newline (context->printer);
1138       locus_prefix = gfc_diagnostic_build_locus_prefix (context, s2);
1139       pp_set_prefix (context->printer,
1140                      concat (locus_prefix, " ", kind_prefix, NULL));
1141       free (kind_prefix);
1142       free (locus_prefix);
1143     }
1144   else
1145     {
1146       pp_verbatim (context->printer, "%s", locus_prefix);
1147       free (locus_prefix);
1148       /* Fortran uses an empty line between locus and caret line.  */
1149       pp_newline (context->printer);
1150       pp_set_prefix (context->printer, NULL);
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
1158 static void
1159 gfc_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
1172 static void
1173 gfc_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
1184 bool
1185 gfc_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
1202 bool
1203 gfc_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
1221 bool
1222 gfc_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
1240 void
1241 gfc_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
1258 void
1259 gfc_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
1275 void
1276 gfc_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
1287 void
1288 gfc_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
1310 static void
1311 gfc_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
1366 void
1367 gfc_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
1376 void
1377 gfc_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
1388 void
1389 gfc_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
1411 void
1412 gfc_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
1422 bool
1423 gfc_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
1433 bool
1434 gfc_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
1459 static void
1460 gfc_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
1483 void
1484 gfc_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
1492 void
1493 gfc_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
1501 void
1502 gfc_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
1510 void
1511 gfc_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
1522 void
1523 gfc_errors_to_warnings (bool f)
1524 {
1525   warnings_not_errors = f;
1526 }
1527
1528 void
1529 gfc_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
1545 void
1546 gfc_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 }