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 (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         source_range range
 943           = source_range::from_location (
 944               linemap_position_for_loc_and_offset (line_table,
 945                                                    loc->lb->location,
 946                                                    offset));
 947         text->set_range (loc_num, range, true);
 948         pp_string (pp, result[loc_num]);
 949         return true;
 950       }
 951     default:
 952       return false;
 953     }
 954 }
 955
 956 /* Return a malloc'd string describing the kind of diagnostic.  The
 957    caller is responsible for freeing the memory.  */
 958 static char *
 959 gfc_diagnostic_build_kind_prefix (diagnostic_context *context,
 960                                   const diagnostic_info *diagnostic)
 961 {
 962   static const char *const diagnostic_kind_text[] = {
 963 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T),
 964 #include "gfc-diagnostic.def"
 965 #undef DEFINE_DIAGNOSTIC_KIND
 966     "must-not-happen"
 967   };
 968   static const char *const diagnostic_kind_color[] = {
 969 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C),
 970 #include "gfc-diagnostic.def"
 971 #undef DEFINE_DIAGNOSTIC_KIND
 972     NULL
 973   };
 974   gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND);
 975   const char *text = _(diagnostic_kind_text[diagnostic->kind]);
 976   const char *text_cs = "", *text_ce = "";
 977   pretty_printer *pp = context->printer;
 978
 979   if (diagnostic_kind_color[diagnostic->kind])
 980     {
 981       text_cs = colorize_start (pp_show_color (pp),
 982                                 diagnostic_kind_color[diagnostic->kind]);
 983       text_ce = colorize_stop (pp_show_color (pp));
 984     }
 985   return build_message_string ("%s%s:%s ", text_cs, text, text_ce);
 986 }
 987
 988 /* Return a malloc'd string describing a location.  The caller is
 989    responsible for freeing the memory.  */
 990 static char *
 991 gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
 992                                    expanded_location s)
 993 {
 994   pretty_printer *pp = context->printer;
 995   const char *locus_cs = colorize_start (pp_show_color (pp), "locus");
 996   const char *locus_ce = colorize_stop (pp_show_color (pp));
 997   return (s.file == NULL
 998           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
 999           : !strcmp (s.file, N_("<built-in>"))
1000           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1001           : context->show_column
1002           ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line,
1003                                   s.column, locus_ce)
1004           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce));
1005 }
1006
1007 /* Return a malloc'd string describing two locations.  The caller is
1008    responsible for freeing the memory.  */
1009 static char *
1010 gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
1011                                    expanded_location s, expanded_location s2)
1012 {
1013   pretty_printer *pp = context->printer;
1014   const char *locus_cs = colorize_start (pp_show_color (pp), "locus");
1015   const char *locus_ce = colorize_stop (pp_show_color (pp));
1016
1017   return (s.file == NULL
1018           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
1019           : !strcmp (s.file, N_("<built-in>"))
1020           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1021           : context->show_column
1022           ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line,
1023                                   MIN (s.column, s2.column),
1024                                   MAX (s.column, s2.column), locus_ce)
1025           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line,
1026                                   locus_ce));
1027 }
1028
1029 /* This function prints the locus (file:line:column), the diagnostic kind
1030    (Error, Warning) and (optionally) the relevant lines of code with
1031    annotation lines with '1' and/or '2' below them.
1032
1033    With -fdiagnostic-show-caret (the default) it prints:
1034
1035        [locus of primary range]:
1036
1037           some code
1038                  1
1039        Error: Some error at (1)
1040
1041   With -fno-diagnostic-show-caret or if the primary range is not
1042   valid, it prints:
1043
1044        [locus of primary range]: Error: Some error at (1) and (2)
1045 */
1046 static void
1047 gfc_diagnostic_starter (diagnostic_context *context,
1048                         diagnostic_info *diagnostic)
1049 {
1050   char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic);
1051
1052   expanded_location s1 = diagnostic_expand_location (diagnostic);
1053   expanded_location s2;
1054   bool one_locus = diagnostic->richloc->get_num_locations () < 2;
1055   bool same_locus = false;
1056
1057   if (!one_locus)
1058     {
1059       s2 = diagnostic_expand_location (diagnostic, 1);
1060       same_locus = diagnostic_same_line (context, s1, s2);
1061     }
1062
1063   char * locus_prefix = (one_locus || !same_locus)
1064     ? gfc_diagnostic_build_locus_prefix (context, s1)
1065     : gfc_diagnostic_build_locus_prefix (context, s1, s2);
1066
1067   if (!context->show_caret
1068       || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION
1069       || diagnostic_location (diagnostic, 0) == context->last_location)
1070     {
1071       pp_set_prefix (context->printer,
1072                      concat (locus_prefix, " ", kind_prefix, NULL));
1073       free (locus_prefix);
1074
1075       if (one_locus || same_locus)
1076         {
1077           free (kind_prefix);
1078           return;
1079         }
1080       /* In this case, we print the previous locus and prefix as:
1081
1082           [locus]:[prefix]: (1)
1083
1084          and we flush with a new line before setting the new prefix.  */
1085       pp_string (context->printer, "(1)");
1086       pp_newline (context->printer);
1087       locus_prefix = gfc_diagnostic_build_locus_prefix (context, s2);
1088       pp_set_prefix (context->printer,
1089                      concat (locus_prefix, " ", kind_prefix, NULL));
1090       free (kind_prefix);
1091       free (locus_prefix);
1092     }
1093   else
1094     {
1095       pp_verbatim (context->printer, locus_prefix);
1096       free (locus_prefix);
1097       /* Fortran uses an empty line between locus and caret line.  */
1098       pp_newline (context->printer);
1099       diagnostic_show_locus (context, diagnostic);
1100       pp_newline (context->printer);
1101       /* If the caret line was shown, the prefix does not contain the
1102          locus.  */
1103       pp_set_prefix (context->printer, kind_prefix);
1104     }
1105 }
1106
1107 static void
1108 gfc_diagnostic_finalizer (diagnostic_context *context,
1109                           diagnostic_info *diagnostic ATTRIBUTE_UNUSED)
1110 {
1111   pp_destroy_prefix (context->printer);
1112   pp_newline_and_flush (context->printer);
1113 }
1114
1115 /* Immediate warning (i.e. do not buffer the warning) with an explicit
1116    location.  */
1117
1118 bool
1119 gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...)
1120 {
1121   va_list argp;
1122   diagnostic_info diagnostic;
1123   rich_location rich_loc (loc);
1124   bool ret;
1125
1126   va_start (argp, gmsgid);
1127   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING);
1128   diagnostic.option_index = opt;
1129   ret = report_diagnostic (&diagnostic);
1130   va_end (argp);
1131   return ret;
1132 }
1133
1134 /* Immediate warning (i.e. do not buffer the warning).  */
1135
1136 bool
1137 gfc_warning_now (int opt, const char *gmsgid, ...)
1138 {
1139   va_list argp;
1140   diagnostic_info diagnostic;
1141   rich_location rich_loc (UNKNOWN_LOCATION);
1142   bool ret;
1143
1144   va_start (argp, gmsgid);
1145   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
1146                        DK_WARNING);
1147   diagnostic.option_index = opt;
1148   ret = report_diagnostic (&diagnostic);
1149   va_end (argp);
1150   return ret;
1151 }
1152
1153
1154 /* Immediate error (i.e. do not buffer).  */
1155
1156 void
1157 gfc_error_now (const char *gmsgid, ...)
1158 {
1159   va_list argp;
1160   diagnostic_info diagnostic;
1161   rich_location rich_loc (UNKNOWN_LOCATION);
1162
1163   error_buffer.flag = true;
1164
1165   va_start (argp, gmsgid);
1166   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR);
1167   report_diagnostic (&diagnostic);
1168   va_end (argp);
1169 }
1170
1171
1172 /* Fatal error, never returns.  */
1173
1174 void
1175 gfc_fatal_error (const char *gmsgid, ...)
1176 {
1177   va_list argp;
1178   diagnostic_info diagnostic;
1179   rich_location rich_loc (UNKNOWN_LOCATION);
1180
1181   va_start (argp, gmsgid);
1182   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL);
1183   report_diagnostic (&diagnostic);
1184   va_end (argp);
1185
1186   gcc_unreachable ();
1187 }
1188
1189 /* Clear the warning flag.  */
1190
1191 void
1192 gfc_clear_warning (void)
1193 {
1194   gfc_clear_pp_buffer (pp_warning_buffer);
1195   warningcount_buffered = 0;
1196   werrorcount_buffered = 0;
1197 }
1198
1199
1200 /* Check to see if any warnings have been saved.
1201    If so, print the warning.  */
1202
1203 void
1204 gfc_warning_check (void)
1205 {
1206   if (! gfc_output_buffer_empty_p (pp_warning_buffer))
1207     {
1208       pretty_printer *pp = global_dc->printer;
1209       output_buffer *tmp_buffer = pp->buffer;
1210       pp->buffer = pp_warning_buffer;
1211       pp_really_flush (pp);
1212       warningcount += warningcount_buffered;
1213       werrorcount += werrorcount_buffered;
1214       gcc_assert (warningcount_buffered + werrorcount_buffered == 1);
1215       pp->buffer = tmp_buffer;
1216       diagnostic_action_after_output (global_dc,
1217                                       warningcount_buffered
1218                                       ? DK_WARNING : DK_ERROR);
1219     }
1220 }
1221
1222
1223 /* Issue an error.  */
1224
1225 static void
1226 gfc_error (const char *gmsgid, va_list ap)
1227 {
1228   va_list argp;
1229   va_copy (argp, ap);
1230
1231   if (warnings_not_errors)
1232     {
1233       gfc_warning (/*opt=*/0, gmsgid, argp);
1234       va_end (argp);
1235       return;
1236     }
1237
1238   if (suppress_errors)
1239     {
1240       va_end (argp);
1241       return;
1242     }
1243
1244   diagnostic_info diagnostic;
1245   rich_location richloc (UNKNOWN_LOCATION);
1246   bool fatal_errors = global_dc->fatal_errors;
1247   pretty_printer *pp = global_dc->printer;
1248   output_buffer *tmp_buffer = pp->buffer;
1249
1250   gfc_clear_pp_buffer (pp_error_buffer);
1251
1252   if (buffered_p)
1253     {
1254       pp->buffer = pp_error_buffer;
1255       global_dc->fatal_errors = false;
1256       /* To prevent -fmax-errors= triggering, we decrease it before
1257      report_diagnostic increases it.  */
1258       --errorcount;
1259     }
1260
1261   diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR);
1262   report_diagnostic (&diagnostic);
1263
1264   if (buffered_p)
1265     {
1266       pp->buffer = tmp_buffer;
1267       global_dc->fatal_errors = fatal_errors;
1268     }
1269
1270   va_end (argp);
1271 }
1272
1273
1274 void
1275 gfc_error (const char *gmsgid, ...)
1276 {
1277   va_list argp;
1278   va_start (argp, gmsgid);
1279   gfc_error (gmsgid, argp);
1280   va_end (argp);
1281 }
1282
1283
1284 /* This shouldn't happen... but sometimes does.  */
1285
1286 void
1287 gfc_internal_error (const char *gmsgid, ...)
1288 {
1289   va_list argp;
1290   diagnostic_info diagnostic;
1291   rich_location rich_loc (UNKNOWN_LOCATION);
1292
1293   va_start (argp, gmsgid);
1294   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE);
1295   report_diagnostic (&diagnostic);
1296   va_end (argp);
1297
1298   gcc_unreachable ();
1299 }
1300
1301
1302 /* Clear the error flag when we start to compile a source line.  */
1303
1304 void
1305 gfc_clear_error (void)
1306 {
1307   error_buffer.flag = 0;
1308   warnings_not_errors = false;
1309   gfc_clear_pp_buffer (pp_error_buffer);
1310 }
1311
1312
1313 /* Tests the state of error_flag.  */
1314
1315 bool
1316 gfc_error_flag_test (void)
1317 {
1318   return error_buffer.flag
1319     || !gfc_output_buffer_empty_p (pp_error_buffer);
1320 }
1321
1322
1323 /* Check to see if any errors have been saved.
1324    If so, print the error.  Returns the state of error_flag.  */
1325
1326 bool
1327 gfc_error_check (void)
1328 {
1329   if (error_buffer.flag
1330       || ! gfc_output_buffer_empty_p (pp_error_buffer))
1331     {
1332       error_buffer.flag = false;
1333       pretty_printer *pp = global_dc->printer;
1334       output_buffer *tmp_buffer = pp->buffer;
1335       pp->buffer = pp_error_buffer;
1336       pp_really_flush (pp);
1337       ++errorcount;
1338       gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer));
1339       pp->buffer = tmp_buffer;
1340       diagnostic_action_after_output (global_dc, DK_ERROR);
1341       return true;
1342     }
1343
1344   return false;
1345 }
1346
1347 /* Move the text buffered from FROM to TO, then clear
1348    FROM. Independently if there was text in FROM, TO is also
1349    cleared. */
1350
1351 static void
1352 gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from,
1353                                gfc_error_buffer * buffer_to)
1354 {
1355   output_buffer * from = &(buffer_from->buffer);
1356   output_buffer * to =  &(buffer_to->buffer);
1357
1358   buffer_to->flag = buffer_from->flag;
1359   buffer_from->flag = false;
1360
1361   gfc_clear_pp_buffer (to);
1362   /* We make sure this is always buffered.  */
1363   to->flush_p = false;
1364
1365   if (! gfc_output_buffer_empty_p (from))
1366     {
1367       const char *str = output_buffer_formatted_text (from);
1368       output_buffer_append_r (to, str, strlen (str));
1369       gfc_clear_pp_buffer (from);
1370     }
1371 }
1372
1373 /* Save the existing error state.  */
1374
1375 void
1376 gfc_push_error (gfc_error_buffer *err)
1377 {
1378   gfc_move_error_buffer_from_to (&error_buffer, err);
1379 }
1380
1381
1382 /* Restore a previous pushed error state.  */
1383
1384 void
1385 gfc_pop_error (gfc_error_buffer *err)
1386 {
1387   gfc_move_error_buffer_from_to (err, &error_buffer);
1388 }
1389
1390
1391 /* Free a pushed error state, but keep the current error state.  */
1392
1393 void
1394 gfc_free_error (gfc_error_buffer *err)
1395 {
1396   gfc_clear_pp_buffer (&(err->buffer));
1397 }
1398
1399
1400 /* Report the number of warnings and errors that occurred to the caller.  */
1401
1402 void
1403 gfc_get_errors (int *w, int *e)
1404 {
1405   if (w != NULL)
1406     *w = warningcount + werrorcount;
1407   if (e != NULL)
1408     *e = errorcount + sorrycount + werrorcount;
1409 }
1410
1411
1412 /* Switch errors into warnings.  */
1413
1414 void
1415 gfc_errors_to_warnings (bool f)
1416 {
1417   warnings_not_errors = f;
1418 }
1419
1420 void
1421 gfc_diagnostics_init (void)
1422 {
1423   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1424   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1425   diagnostic_format_decoder (global_dc) = gfc_format_decoder;
1426   global_dc->caret_chars[0] = '1';
1427   global_dc->caret_chars[1] = '2';
1428   pp_warning_buffer = new (XNEW (output_buffer)) output_buffer ();
1429   pp_warning_buffer->flush_p = false;
1430   /* pp_error_buffer is statically allocated.  This simplifies memory
1431      management when using gfc_push/pop_error. */
1432   pp_error_buffer = &(error_buffer.buffer);
1433   pp_error_buffer->flush_p = false;
1434 }
1435
1436 void
1437 gfc_diagnostics_finish (void)
1438 {
1439   tree_diagnostics_defaults (global_dc);
1440   /* We still want to use the gfc starter and finalizer, not the tree
1441      defaults.  */
1442   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1443   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1444   global_dc->caret_chars[0] = '^';
1445   global_dc->caret_chars[1] = '^';
1446 }