gcc/fortran/error.c

   1 /* Handle errors.
   2    Copyright (C) 2000-2017 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_opt (int opt, const char *gmsgid, va_list ap)  ATTRIBUTE_GCC_GFC(2,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 = diagnostic_report_diagnostic (global_dc, &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_opt (0, 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, text_info *text, const char *spec,
 920                     int precision, bool wide, bool set_locus, bool hash,
 921                     bool quoted, const char **buffer_ptr)
 922 {
 923   switch (*spec)
 924     {
 925     case 'C':
 926     case 'L':
 927       {
 928         static const char *result[2] = { "(1)", "(2)" };
 929         locus *loc;
 930         if (*spec == 'C')
 931           loc = &gfc_current_locus;
 932         else
 933           loc = va_arg (*text->args_ptr, locus *);
 934         gcc_assert (loc->nextc - loc->lb->line >= 0);
 935         unsigned int offset = loc->nextc - loc->lb->line;
 936         /* If location[0] != UNKNOWN_LOCATION means that we already
 937            processed one of %C/%L.  */
 938         int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1;
 939         location_t src_loc
 940           = linemap_position_for_loc_and_offset (line_table,
 941                                                  loc->lb->location,
 942                                                  offset);
 943         text->set_location (loc_num, src_loc, true);
 944         pp_string (pp, result[loc_num]);
 945         return true;
 946       }
 947     default:
 948       /* Fall through info the middle-end decoder, as e.g. stor-layout.c
 949          etc. diagnostics can use the FE printer while the FE is still
 950          active.  */
 951       return default_tree_printer (pp, text, spec, precision, wide,
 952                                    set_locus, hash, quoted, buffer_ptr);
 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, "%s", 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->richloc, diagnostic->kind);
1100       /* If the caret line was shown, the prefix does not contain the
1101          locus.  */
1102       pp_set_prefix (context->printer, kind_prefix);
1103     }
1104 }
1105
1106 static void
1107 gfc_diagnostic_start_span (diagnostic_context *context,
1108                            expanded_location exploc)
1109 {
1110   char *locus_prefix;
1111   locus_prefix = gfc_diagnostic_build_locus_prefix (context, exploc);
1112   pp_verbatim (context->printer, "%s", locus_prefix);
1113   free (locus_prefix);
1114   pp_newline (context->printer);
1115   /* Fortran uses an empty line between locus and caret line.  */
1116   pp_newline (context->printer);
1117 }
1118
1119
1120 static void
1121 gfc_diagnostic_finalizer (diagnostic_context *context,
1122                           diagnostic_info *diagnostic ATTRIBUTE_UNUSED)
1123 {
1124   pp_destroy_prefix (context->printer);
1125   pp_newline_and_flush (context->printer);
1126 }
1127
1128 /* Immediate warning (i.e. do not buffer the warning) with an explicit
1129    location.  */
1130
1131 bool
1132 gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...)
1133 {
1134   va_list argp;
1135   diagnostic_info diagnostic;
1136   rich_location rich_loc (line_table, loc);
1137   bool ret;
1138
1139   va_start (argp, gmsgid);
1140   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING);
1141   diagnostic.option_index = opt;
1142   ret = diagnostic_report_diagnostic (global_dc, &diagnostic);
1143   va_end (argp);
1144   return ret;
1145 }
1146
1147 /* Immediate warning (i.e. do not buffer the warning).  */
1148
1149 bool
1150 gfc_warning_now (int opt, const char *gmsgid, ...)
1151 {
1152   va_list argp;
1153   diagnostic_info diagnostic;
1154   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1155   bool ret;
1156
1157   va_start (argp, gmsgid);
1158   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
1159                        DK_WARNING);
1160   diagnostic.option_index = opt;
1161   ret = diagnostic_report_diagnostic (global_dc, &diagnostic);
1162   va_end (argp);
1163   return ret;
1164 }
1165
1166 /* Internal warning, do not buffer.  */
1167
1168 bool
1169 gfc_warning_internal (int opt, const char *gmsgid, ...)
1170 {
1171   va_list argp;
1172   diagnostic_info diagnostic;
1173   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1174   bool ret;
1175
1176   va_start (argp, gmsgid);
1177   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
1178                        DK_WARNING);
1179   diagnostic.option_index = opt;
1180   ret = diagnostic_report_diagnostic (global_dc, &diagnostic);
1181   va_end (argp);
1182   return ret;
1183 }
1184
1185 /* Immediate error (i.e. do not buffer).  */
1186
1187 void
1188 gfc_error_now (const char *gmsgid, ...)
1189 {
1190   va_list argp;
1191   diagnostic_info diagnostic;
1192   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1193
1194   error_buffer.flag = true;
1195
1196   va_start (argp, gmsgid);
1197   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR);
1198   diagnostic_report_diagnostic (global_dc, &diagnostic);
1199   va_end (argp);
1200 }
1201
1202
1203 /* Fatal error, never returns.  */
1204
1205 void
1206 gfc_fatal_error (const char *gmsgid, ...)
1207 {
1208   va_list argp;
1209   diagnostic_info diagnostic;
1210   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1211
1212   va_start (argp, gmsgid);
1213   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL);
1214   diagnostic_report_diagnostic (global_dc, &diagnostic);
1215   va_end (argp);
1216
1217   gcc_unreachable ();
1218 }
1219
1220 /* Clear the warning flag.  */
1221
1222 void
1223 gfc_clear_warning (void)
1224 {
1225   gfc_clear_pp_buffer (pp_warning_buffer);
1226   warningcount_buffered = 0;
1227   werrorcount_buffered = 0;
1228 }
1229
1230
1231 /* Check to see if any warnings have been saved.
1232    If so, print the warning.  */
1233
1234 void
1235 gfc_warning_check (void)
1236 {
1237   if (! gfc_output_buffer_empty_p (pp_warning_buffer))
1238     {
1239       pretty_printer *pp = global_dc->printer;
1240       output_buffer *tmp_buffer = pp->buffer;
1241       pp->buffer = pp_warning_buffer;
1242       pp_really_flush (pp);
1243       warningcount += warningcount_buffered;
1244       werrorcount += werrorcount_buffered;
1245       gcc_assert (warningcount_buffered + werrorcount_buffered == 1);
1246       pp->buffer = tmp_buffer;
1247       diagnostic_action_after_output (global_dc,
1248                                       warningcount_buffered
1249                                       ? DK_WARNING : DK_ERROR);
1250       diagnostic_check_max_errors (global_dc, true);
1251     }
1252 }
1253
1254
1255 /* Issue an error.  */
1256
1257 static void
1258 gfc_error_opt (int opt, const char *gmsgid, va_list ap)
1259 {
1260   va_list argp;
1261   va_copy (argp, ap);
1262   bool saved_abort_on_error = false;
1263
1264   if (warnings_not_errors)
1265     {
1266       gfc_warning (opt, gmsgid, argp);
1267       va_end (argp);
1268       return;
1269     }
1270
1271   if (suppress_errors)
1272     {
1273       va_end (argp);
1274       return;
1275     }
1276
1277   diagnostic_info diagnostic;
1278   rich_location richloc (line_table, UNKNOWN_LOCATION);
1279   bool fatal_errors = global_dc->fatal_errors;
1280   pretty_printer *pp = global_dc->printer;
1281   output_buffer *tmp_buffer = pp->buffer;
1282
1283   gfc_clear_pp_buffer (pp_error_buffer);
1284
1285   if (buffered_p)
1286     {
1287       /* To prevent -dH from triggering an abort on a buffered error,
1288          save abort_on_error and restore it below.  */
1289       saved_abort_on_error = global_dc->abort_on_error;
1290       global_dc->abort_on_error = false;
1291       pp->buffer = pp_error_buffer;
1292       global_dc->fatal_errors = false;
1293       /* To prevent -fmax-errors= triggering, we decrease it before
1294          report_diagnostic increases it.  */
1295       --errorcount;
1296     }
1297
1298   diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR);
1299   diagnostic_report_diagnostic (global_dc, &diagnostic);
1300
1301   if (buffered_p)
1302     {
1303       pp->buffer = tmp_buffer;
1304       global_dc->fatal_errors = fatal_errors;
1305       global_dc->abort_on_error = saved_abort_on_error;
1306
1307     }
1308
1309   va_end (argp);
1310 }
1311
1312
1313 void
1314 gfc_error_opt (int opt, const char *gmsgid, ...)
1315 {
1316   va_list argp;
1317   va_start (argp, gmsgid);
1318   gfc_error_opt (opt, gmsgid, argp);
1319   va_end (argp);
1320 }
1321
1322
1323 void
1324 gfc_error (const char *gmsgid, ...)
1325 {
1326   va_list argp;
1327   va_start (argp, gmsgid);
1328   gfc_error_opt (0, gmsgid, argp);
1329   va_end (argp);
1330 }
1331
1332
1333 /* This shouldn't happen... but sometimes does.  */
1334
1335 void
1336 gfc_internal_error (const char *gmsgid, ...)
1337 {
1338   int e, w;
1339   va_list argp;
1340   diagnostic_info diagnostic;
1341   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1342
1343   gfc_get_errors (&w, &e);
1344   if (e > 0)
1345     exit(EXIT_FAILURE);
1346
1347   va_start (argp, gmsgid);
1348   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE);
1349   diagnostic_report_diagnostic (global_dc, &diagnostic);
1350   va_end (argp);
1351
1352   gcc_unreachable ();
1353 }
1354
1355
1356 /* Clear the error flag when we start to compile a source line.  */
1357
1358 void
1359 gfc_clear_error (void)
1360 {
1361   error_buffer.flag = 0;
1362   warnings_not_errors = false;
1363   gfc_clear_pp_buffer (pp_error_buffer);
1364 }
1365
1366
1367 /* Tests the state of error_flag.  */
1368
1369 bool
1370 gfc_error_flag_test (void)
1371 {
1372   return error_buffer.flag
1373     || !gfc_output_buffer_empty_p (pp_error_buffer);
1374 }
1375
1376
1377 /* Check to see if any errors have been saved.
1378    If so, print the error.  Returns the state of error_flag.  */
1379
1380 bool
1381 gfc_error_check (void)
1382 {
1383   if (error_buffer.flag
1384       || ! gfc_output_buffer_empty_p (pp_error_buffer))
1385     {
1386       error_buffer.flag = false;
1387       pretty_printer *pp = global_dc->printer;
1388       output_buffer *tmp_buffer = pp->buffer;
1389       pp->buffer = pp_error_buffer;
1390       pp_really_flush (pp);
1391       ++errorcount;
1392       gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer));
1393       pp->buffer = tmp_buffer;
1394       diagnostic_action_after_output (global_dc, DK_ERROR);
1395       diagnostic_check_max_errors (global_dc, true);
1396       return true;
1397     }
1398
1399   return false;
1400 }
1401
1402 /* Move the text buffered from FROM to TO, then clear
1403    FROM. Independently if there was text in FROM, TO is also
1404    cleared. */
1405
1406 static void
1407 gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from,
1408                                gfc_error_buffer * buffer_to)
1409 {
1410   output_buffer * from = &(buffer_from->buffer);
1411   output_buffer * to =  &(buffer_to->buffer);
1412
1413   buffer_to->flag = buffer_from->flag;
1414   buffer_from->flag = false;
1415
1416   gfc_clear_pp_buffer (to);
1417   /* We make sure this is always buffered.  */
1418   to->flush_p = false;
1419
1420   if (! gfc_output_buffer_empty_p (from))
1421     {
1422       const char *str = output_buffer_formatted_text (from);
1423       output_buffer_append_r (to, str, strlen (str));
1424       gfc_clear_pp_buffer (from);
1425     }
1426 }
1427
1428 /* Save the existing error state.  */
1429
1430 void
1431 gfc_push_error (gfc_error_buffer *err)
1432 {
1433   gfc_move_error_buffer_from_to (&error_buffer, err);
1434 }
1435
1436
1437 /* Restore a previous pushed error state.  */
1438
1439 void
1440 gfc_pop_error (gfc_error_buffer *err)
1441 {
1442   gfc_move_error_buffer_from_to (err, &error_buffer);
1443 }
1444
1445
1446 /* Free a pushed error state, but keep the current error state.  */
1447
1448 void
1449 gfc_free_error (gfc_error_buffer *err)
1450 {
1451   gfc_clear_pp_buffer (&(err->buffer));
1452 }
1453
1454
1455 /* Report the number of warnings and errors that occurred to the caller.  */
1456
1457 void
1458 gfc_get_errors (int *w, int *e)
1459 {
1460   if (w != NULL)
1461     *w = warningcount + werrorcount;
1462   if (e != NULL)
1463     *e = errorcount + sorrycount + werrorcount;
1464 }
1465
1466
1467 /* Switch errors into warnings.  */
1468
1469 void
1470 gfc_errors_to_warnings (bool f)
1471 {
1472   warnings_not_errors = f;
1473 }
1474
1475 void
1476 gfc_diagnostics_init (void)
1477 {
1478   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1479   global_dc->start_span = gfc_diagnostic_start_span;
1480   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1481   diagnostic_format_decoder (global_dc) = gfc_format_decoder;
1482   global_dc->caret_chars[0] = '1';
1483   global_dc->caret_chars[1] = '2';
1484   pp_warning_buffer = new (XNEW (output_buffer)) output_buffer ();
1485   pp_warning_buffer->flush_p = false;
1486   /* pp_error_buffer is statically allocated.  This simplifies memory
1487      management when using gfc_push/pop_error. */
1488   pp_error_buffer = &(error_buffer.buffer);
1489   pp_error_buffer->flush_p = false;
1490 }
1491
1492 void
1493 gfc_diagnostics_finish (void)
1494 {
1495   tree_diagnostics_defaults (global_dc);
1496   /* We still want to use the gfc starter and finalizer, not the tree
1497      defaults.  */
1498   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1499   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1500   global_dc->caret_chars[0] = '^';
1501   global_dc->caret_chars[1] = '^';
1502 }