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