gcc/fortran/error.c

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