gcc/fortran/error.c

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