gcc/fortran/error.c

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