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