gcc/fortran/error.c

   1 /* Handle errors.
   2    Copyright (C) 2000-2018 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_F2018_DEL:
 868       msg = _("Fortran 2018 deleted feature:");
 869       break;
 870     case GFC_STD_F2018_OBS:
 871       msg = _("Fortran 2018 obsolescent feature:");
 872       break;
 873     case GFC_STD_F2018:
 874       msg = _("Fortran 2018:");
 875       break;
 876     case GFC_STD_F2008_TS:
 877       msg = "TS 29113/TS 18508:";
 878       break;
 879     case GFC_STD_F2008_OBS:
 880       msg = _("Fortran 2008 obsolescent feature:");
 881       break;
 882     case GFC_STD_F2008:
 883       msg = "Fortran 2008:";
 884       break;
 885     case GFC_STD_F2003:
 886       msg = "Fortran 2003:";
 887       break;
 888     case GFC_STD_GNU:
 889       msg = _("GNU Extension:");
 890       break;
 891     case GFC_STD_LEGACY:
 892       msg = _("Legacy Extension:");
 893       break;
 894     case GFC_STD_F95_OBS:
 895       msg = _("Obsolescent feature:");
 896       break;
 897     case GFC_STD_F95_DEL:
 898       msg = _("Deleted feature:");
 899       break;
 900     default:
 901       gcc_unreachable ();
 902   }
 903
 904   msg2 = _(gmsgid);
 905   buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2);
 906   strcpy (buffer, msg);
 907   strcat (buffer, " ");
 908   strcat (buffer, msg2);
 909
 910   va_start (argp, gmsgid);
 911   if (warning)
 912     gfc_warning (0, buffer, argp);
 913   else
 914     gfc_error_opt (0, buffer, argp);
 915   va_end (argp);
 916
 917   return (warning && !warnings_are_errors) ? true : false;
 918 }
 919
 920
 921 /* Called from output_format -- during diagnostic message processing
 922    to handle Fortran specific format specifiers with the following meanings:
 923
 924    %C  Current locus (no argument)
 925    %L  Takes locus argument
 926 */
 927 static bool
 928 gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec,
 929                     int precision, bool wide, bool set_locus, bool hash,
 930                     bool *quoted, const char **buffer_ptr)
 931 {
 932   switch (*spec)
 933     {
 934     case 'C':
 935     case 'L':
 936       {
 937         static const char *result[2] = { "(1)", "(2)" };
 938         locus *loc;
 939         if (*spec == 'C')
 940           loc = &gfc_current_locus;
 941         else
 942           loc = va_arg (*text->args_ptr, locus *);
 943         gcc_assert (loc->nextc - loc->lb->line >= 0);
 944         unsigned int offset = loc->nextc - loc->lb->line;
 945         /* If location[0] != UNKNOWN_LOCATION means that we already
 946            processed one of %C/%L.  */
 947         int loc_num = text->get_location (0) == UNKNOWN_LOCATION ? 0 : 1;
 948         location_t src_loc
 949           = linemap_position_for_loc_and_offset (line_table,
 950                                                  loc->lb->location,
 951                                                  offset);
 952         text->set_location (loc_num, src_loc, true);
 953         pp_string (pp, result[loc_num]);
 954         return true;
 955       }
 956     default:
 957       /* Fall through info the middle-end decoder, as e.g. stor-layout.c
 958          etc. diagnostics can use the FE printer while the FE is still
 959          active.  */
 960       return default_tree_printer (pp, text, spec, precision, wide,
 961                                    set_locus, hash, quoted, buffer_ptr);
 962     }
 963 }
 964
 965 /* Return a malloc'd string describing the kind of diagnostic.  The
 966    caller is responsible for freeing the memory.  */
 967 static char *
 968 gfc_diagnostic_build_kind_prefix (diagnostic_context *context,
 969                                   const diagnostic_info *diagnostic)
 970 {
 971   static const char *const diagnostic_kind_text[] = {
 972 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T),
 973 #include "gfc-diagnostic.def"
 974 #undef DEFINE_DIAGNOSTIC_KIND
 975     "must-not-happen"
 976   };
 977   static const char *const diagnostic_kind_color[] = {
 978 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C),
 979 #include "gfc-diagnostic.def"
 980 #undef DEFINE_DIAGNOSTIC_KIND
 981     NULL
 982   };
 983   gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND);
 984   const char *text = _(diagnostic_kind_text[diagnostic->kind]);
 985   const char *text_cs = "", *text_ce = "";
 986   pretty_printer *pp = context->printer;
 987
 988   if (diagnostic_kind_color[diagnostic->kind])
 989     {
 990       text_cs = colorize_start (pp_show_color (pp),
 991                                 diagnostic_kind_color[diagnostic->kind]);
 992       text_ce = colorize_stop (pp_show_color (pp));
 993     }
 994   return build_message_string ("%s%s:%s ", text_cs, text, text_ce);
 995 }
 996
 997 /* Return a malloc'd string describing a location.  The caller is
 998    responsible for freeing the memory.  */
 999 static char *
1000 gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
1001                                    expanded_location s)
1002 {
1003   pretty_printer *pp = context->printer;
1004   const char *locus_cs = colorize_start (pp_show_color (pp), "locus");
1005   const char *locus_ce = colorize_stop (pp_show_color (pp));
1006   return (s.file == NULL
1007           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
1008           : !strcmp (s.file, N_("<built-in>"))
1009           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1010           : context->show_column
1011           ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line,
1012                                   s.column, locus_ce)
1013           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce));
1014 }
1015
1016 /* Return a malloc'd string describing two locations.  The caller is
1017    responsible for freeing the memory.  */
1018 static char *
1019 gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
1020                                    expanded_location s, expanded_location s2)
1021 {
1022   pretty_printer *pp = context->printer;
1023   const char *locus_cs = colorize_start (pp_show_color (pp), "locus");
1024   const char *locus_ce = colorize_stop (pp_show_color (pp));
1025
1026   return (s.file == NULL
1027           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
1028           : !strcmp (s.file, N_("<built-in>"))
1029           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1030           : context->show_column
1031           ? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line,
1032                                   MIN (s.column, s2.column),
1033                                   MAX (s.column, s2.column), locus_ce)
1034           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line,
1035                                   locus_ce));
1036 }
1037
1038 /* This function prints the locus (file:line:column), the diagnostic kind
1039    (Error, Warning) and (optionally) the relevant lines of code with
1040    annotation lines with '1' and/or '2' below them.
1041
1042    With -fdiagnostic-show-caret (the default) it prints:
1043
1044        [locus of primary range]:
1045
1046           some code
1047                  1
1048        Error: Some error at (1)
1049
1050   With -fno-diagnostic-show-caret or if the primary range is not
1051   valid, it prints:
1052
1053        [locus of primary range]: Error: Some error at (1) and (2)
1054 */
1055 static void
1056 gfc_diagnostic_starter (diagnostic_context *context,
1057                         diagnostic_info *diagnostic)
1058 {
1059   char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic);
1060
1061   expanded_location s1 = diagnostic_expand_location (diagnostic);
1062   expanded_location s2;
1063   bool one_locus = diagnostic->richloc->get_num_locations () < 2;
1064   bool same_locus = false;
1065
1066   if (!one_locus)
1067     {
1068       s2 = diagnostic_expand_location (diagnostic, 1);
1069       same_locus = diagnostic_same_line (context, s1, s2);
1070     }
1071
1072   char * locus_prefix = (one_locus || !same_locus)
1073     ? gfc_diagnostic_build_locus_prefix (context, s1)
1074     : gfc_diagnostic_build_locus_prefix (context, s1, s2);
1075
1076   if (!context->show_caret
1077       || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION
1078       || diagnostic_location (diagnostic, 0) == context->last_location)
1079     {
1080       pp_set_prefix (context->printer,
1081                      concat (locus_prefix, " ", kind_prefix, NULL));
1082       free (locus_prefix);
1083
1084       if (one_locus || same_locus)
1085         {
1086           free (kind_prefix);
1087           return;
1088         }
1089       /* In this case, we print the previous locus and prefix as:
1090
1091           [locus]:[prefix]: (1)
1092
1093          and we flush with a new line before setting the new prefix.  */
1094       pp_string (context->printer, "(1)");
1095       pp_newline (context->printer);
1096       locus_prefix = gfc_diagnostic_build_locus_prefix (context, s2);
1097       pp_set_prefix (context->printer,
1098                      concat (locus_prefix, " ", kind_prefix, NULL));
1099       free (kind_prefix);
1100       free (locus_prefix);
1101     }
1102   else
1103     {
1104       pp_verbatim (context->printer, "%s", locus_prefix);
1105       free (locus_prefix);
1106       /* Fortran uses an empty line between locus and caret line.  */
1107       pp_newline (context->printer);
1108       diagnostic_show_locus (context, diagnostic->richloc, diagnostic->kind);
1109       /* If the caret line was shown, the prefix does not contain the
1110          locus.  */
1111       pp_set_prefix (context->printer, kind_prefix);
1112     }
1113 }
1114
1115 static void
1116 gfc_diagnostic_start_span (diagnostic_context *context,
1117                            expanded_location exploc)
1118 {
1119   char *locus_prefix;
1120   locus_prefix = gfc_diagnostic_build_locus_prefix (context, exploc);
1121   pp_verbatim (context->printer, "%s", locus_prefix);
1122   free (locus_prefix);
1123   pp_newline (context->printer);
1124   /* Fortran uses an empty line between locus and caret line.  */
1125   pp_newline (context->printer);
1126 }
1127
1128
1129 static void
1130 gfc_diagnostic_finalizer (diagnostic_context *context,
1131                           diagnostic_info *diagnostic ATTRIBUTE_UNUSED)
1132 {
1133   pp_destroy_prefix (context->printer);
1134   pp_newline_and_flush (context->printer);
1135 }
1136
1137 /* Immediate warning (i.e. do not buffer the warning) with an explicit
1138    location.  */
1139
1140 bool
1141 gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...)
1142 {
1143   va_list argp;
1144   diagnostic_info diagnostic;
1145   rich_location rich_loc (line_table, loc);
1146   bool ret;
1147
1148   va_start (argp, gmsgid);
1149   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING);
1150   diagnostic.option_index = opt;
1151   ret = diagnostic_report_diagnostic (global_dc, &diagnostic);
1152   va_end (argp);
1153   return ret;
1154 }
1155
1156 /* Immediate warning (i.e. do not buffer the warning).  */
1157
1158 bool
1159 gfc_warning_now (int opt, const char *gmsgid, ...)
1160 {
1161   va_list argp;
1162   diagnostic_info diagnostic;
1163   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1164   bool ret;
1165
1166   va_start (argp, gmsgid);
1167   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
1168                        DK_WARNING);
1169   diagnostic.option_index = opt;
1170   ret = diagnostic_report_diagnostic (global_dc, &diagnostic);
1171   va_end (argp);
1172   return ret;
1173 }
1174
1175 /* Internal warning, do not buffer.  */
1176
1177 bool
1178 gfc_warning_internal (int opt, const char *gmsgid, ...)
1179 {
1180   va_list argp;
1181   diagnostic_info diagnostic;
1182   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1183   bool ret;
1184
1185   va_start (argp, gmsgid);
1186   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
1187                        DK_WARNING);
1188   diagnostic.option_index = opt;
1189   ret = diagnostic_report_diagnostic (global_dc, &diagnostic);
1190   va_end (argp);
1191   return ret;
1192 }
1193
1194 /* Immediate error (i.e. do not buffer).  */
1195
1196 void
1197 gfc_error_now (const char *gmsgid, ...)
1198 {
1199   va_list argp;
1200   diagnostic_info diagnostic;
1201   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1202
1203   error_buffer.flag = true;
1204
1205   va_start (argp, gmsgid);
1206   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR);
1207   diagnostic_report_diagnostic (global_dc, &diagnostic);
1208   va_end (argp);
1209 }
1210
1211
1212 /* Fatal error, never returns.  */
1213
1214 void
1215 gfc_fatal_error (const char *gmsgid, ...)
1216 {
1217   va_list argp;
1218   diagnostic_info diagnostic;
1219   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1220
1221   va_start (argp, gmsgid);
1222   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL);
1223   diagnostic_report_diagnostic (global_dc, &diagnostic);
1224   va_end (argp);
1225
1226   gcc_unreachable ();
1227 }
1228
1229 /* Clear the warning flag.  */
1230
1231 void
1232 gfc_clear_warning (void)
1233 {
1234   gfc_clear_pp_buffer (pp_warning_buffer);
1235   warningcount_buffered = 0;
1236   werrorcount_buffered = 0;
1237 }
1238
1239
1240 /* Check to see if any warnings have been saved.
1241    If so, print the warning.  */
1242
1243 void
1244 gfc_warning_check (void)
1245 {
1246   if (! gfc_output_buffer_empty_p (pp_warning_buffer))
1247     {
1248       pretty_printer *pp = global_dc->printer;
1249       output_buffer *tmp_buffer = pp->buffer;
1250       pp->buffer = pp_warning_buffer;
1251       pp_really_flush (pp);
1252       warningcount += warningcount_buffered;
1253       werrorcount += werrorcount_buffered;
1254       gcc_assert (warningcount_buffered + werrorcount_buffered == 1);
1255       pp->buffer = tmp_buffer;
1256       diagnostic_action_after_output (global_dc,
1257                                       warningcount_buffered
1258                                       ? DK_WARNING : DK_ERROR);
1259       diagnostic_check_max_errors (global_dc, true);
1260     }
1261 }
1262
1263
1264 /* Issue an error.  */
1265
1266 static void
1267 gfc_error_opt (int opt, const char *gmsgid, va_list ap)
1268 {
1269   va_list argp;
1270   va_copy (argp, ap);
1271   bool saved_abort_on_error = false;
1272
1273   if (warnings_not_errors)
1274     {
1275       gfc_warning (opt, gmsgid, argp);
1276       va_end (argp);
1277       return;
1278     }
1279
1280   if (suppress_errors)
1281     {
1282       va_end (argp);
1283       return;
1284     }
1285
1286   diagnostic_info diagnostic;
1287   rich_location richloc (line_table, UNKNOWN_LOCATION);
1288   bool fatal_errors = global_dc->fatal_errors;
1289   pretty_printer *pp = global_dc->printer;
1290   output_buffer *tmp_buffer = pp->buffer;
1291
1292   gfc_clear_pp_buffer (pp_error_buffer);
1293
1294   if (buffered_p)
1295     {
1296       /* To prevent -dH from triggering an abort on a buffered error,
1297          save abort_on_error and restore it below.  */
1298       saved_abort_on_error = global_dc->abort_on_error;
1299       global_dc->abort_on_error = false;
1300       pp->buffer = pp_error_buffer;
1301       global_dc->fatal_errors = false;
1302       /* To prevent -fmax-errors= triggering, we decrease it before
1303          report_diagnostic increases it.  */
1304       --errorcount;
1305     }
1306
1307   diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR);
1308   diagnostic_report_diagnostic (global_dc, &diagnostic);
1309
1310   if (buffered_p)
1311     {
1312       pp->buffer = tmp_buffer;
1313       global_dc->fatal_errors = fatal_errors;
1314       global_dc->abort_on_error = saved_abort_on_error;
1315
1316     }
1317
1318   va_end (argp);
1319 }
1320
1321
1322 void
1323 gfc_error_opt (int opt, const char *gmsgid, ...)
1324 {
1325   va_list argp;
1326   va_start (argp, gmsgid);
1327   gfc_error_opt (opt, gmsgid, argp);
1328   va_end (argp);
1329 }
1330
1331
1332 void
1333 gfc_error (const char *gmsgid, ...)
1334 {
1335   va_list argp;
1336   va_start (argp, gmsgid);
1337   gfc_error_opt (0, gmsgid, argp);
1338   va_end (argp);
1339 }
1340
1341
1342 /* This shouldn't happen... but sometimes does.  */
1343
1344 void
1345 gfc_internal_error (const char *gmsgid, ...)
1346 {
1347   int e, w;
1348   va_list argp;
1349   diagnostic_info diagnostic;
1350   rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1351
1352   gfc_get_errors (&w, &e);
1353   if (e > 0)
1354     exit(EXIT_FAILURE);
1355
1356   va_start (argp, gmsgid);
1357   diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE);
1358   diagnostic_report_diagnostic (global_dc, &diagnostic);
1359   va_end (argp);
1360
1361   gcc_unreachable ();
1362 }
1363
1364
1365 /* Clear the error flag when we start to compile a source line.  */
1366
1367 void
1368 gfc_clear_error (void)
1369 {
1370   error_buffer.flag = 0;
1371   warnings_not_errors = false;
1372   gfc_clear_pp_buffer (pp_error_buffer);
1373 }
1374
1375
1376 /* Tests the state of error_flag.  */
1377
1378 bool
1379 gfc_error_flag_test (void)
1380 {
1381   return error_buffer.flag
1382     || !gfc_output_buffer_empty_p (pp_error_buffer);
1383 }
1384
1385
1386 /* Check to see if any errors have been saved.
1387    If so, print the error.  Returns the state of error_flag.  */
1388
1389 bool
1390 gfc_error_check (void)
1391 {
1392   if (error_buffer.flag
1393       || ! gfc_output_buffer_empty_p (pp_error_buffer))
1394     {
1395       error_buffer.flag = false;
1396       pretty_printer *pp = global_dc->printer;
1397       output_buffer *tmp_buffer = pp->buffer;
1398       pp->buffer = pp_error_buffer;
1399       pp_really_flush (pp);
1400       ++errorcount;
1401       gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer));
1402       pp->buffer = tmp_buffer;
1403       diagnostic_action_after_output (global_dc, DK_ERROR);
1404       diagnostic_check_max_errors (global_dc, true);
1405       return true;
1406     }
1407
1408   return false;
1409 }
1410
1411 /* Move the text buffered from FROM to TO, then clear
1412    FROM. Independently if there was text in FROM, TO is also
1413    cleared. */
1414
1415 static void
1416 gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from,
1417                                gfc_error_buffer * buffer_to)
1418 {
1419   output_buffer * from = &(buffer_from->buffer);
1420   output_buffer * to =  &(buffer_to->buffer);
1421
1422   buffer_to->flag = buffer_from->flag;
1423   buffer_from->flag = false;
1424
1425   gfc_clear_pp_buffer (to);
1426   /* We make sure this is always buffered.  */
1427   to->flush_p = false;
1428
1429   if (! gfc_output_buffer_empty_p (from))
1430     {
1431       const char *str = output_buffer_formatted_text (from);
1432       output_buffer_append_r (to, str, strlen (str));
1433       gfc_clear_pp_buffer (from);
1434     }
1435 }
1436
1437 /* Save the existing error state.  */
1438
1439 void
1440 gfc_push_error (gfc_error_buffer *err)
1441 {
1442   gfc_move_error_buffer_from_to (&error_buffer, err);
1443 }
1444
1445
1446 /* Restore a previous pushed error state.  */
1447
1448 void
1449 gfc_pop_error (gfc_error_buffer *err)
1450 {
1451   gfc_move_error_buffer_from_to (err, &error_buffer);
1452 }
1453
1454
1455 /* Free a pushed error state, but keep the current error state.  */
1456
1457 void
1458 gfc_free_error (gfc_error_buffer *err)
1459 {
1460   gfc_clear_pp_buffer (&(err->buffer));
1461 }
1462
1463
1464 /* Report the number of warnings and errors that occurred to the caller.  */
1465
1466 void
1467 gfc_get_errors (int *w, int *e)
1468 {
1469   if (w != NULL)
1470     *w = warningcount + werrorcount;
1471   if (e != NULL)
1472     *e = errorcount + sorrycount + werrorcount;
1473 }
1474
1475
1476 /* Switch errors into warnings.  */
1477
1478 void
1479 gfc_errors_to_warnings (bool f)
1480 {
1481   warnings_not_errors = f;
1482 }
1483
1484 void
1485 gfc_diagnostics_init (void)
1486 {
1487   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1488   global_dc->start_span = gfc_diagnostic_start_span;
1489   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1490   diagnostic_format_decoder (global_dc) = gfc_format_decoder;
1491   global_dc->caret_chars[0] = '1';
1492   global_dc->caret_chars[1] = '2';
1493   pp_warning_buffer = new (XNEW (output_buffer)) output_buffer ();
1494   pp_warning_buffer->flush_p = false;
1495   /* pp_error_buffer is statically allocated.  This simplifies memory
1496      management when using gfc_push/pop_error. */
1497   pp_error_buffer = &(error_buffer.buffer);
1498   pp_error_buffer->flush_p = false;
1499 }
1500
1501 void
1502 gfc_diagnostics_finish (void)
1503 {
1504   tree_diagnostics_defaults (global_dc);
1505   /* We still want to use the gfc starter and finalizer, not the tree
1506      defaults.  */
1507   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1508   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1509   global_dc->caret_chars[0] = '^';
1510   global_dc->caret_chars[1] = '^';
1511 }