gcc/fortran/error.c

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