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_2 instead, unless gmsgid contains a %L.  */
 937
 938 void
 939 gfc_warning_now (const char *gmsgid, ...)
 940 {
 941   va_list argp;
 942   int i;
 943
 944   if (inhibit_warnings)
 945     return;
 946
 947   i = buffer_flag;
 948   buffer_flag = 0;
 949   warnings++;
 950
 951   va_start (argp, gmsgid);
 952   error_print (_("Warning:"), _(gmsgid), argp);
 953   va_end (argp);
 954
 955   error_char ('\0');
 956
 957   if (warnings_are_errors)
 958     gfc_increment_error_count();
 959
 960   buffer_flag = i;
 961 }
 962
 963 /* Called from output_format -- during diagnostic message processing
 964    to handle Fortran specific format specifiers with the following meanings:
 965
 966    %C  Current locus (no argument)
 967 */
 968 static bool
 969 gfc_format_decoder (pretty_printer *pp,
 970                     text_info *text, const char *spec,
 971                     int precision ATTRIBUTE_UNUSED, bool wide ATTRIBUTE_UNUSED,
 972                     bool plus ATTRIBUTE_UNUSED, bool hash ATTRIBUTE_UNUSED)
 973 {
 974   switch (*spec)
 975     {
 976     case 'C':
 977       {
 978         static const char *result = "(1)";
 979         gcc_assert (gfc_current_locus.nextc - gfc_current_locus.lb->line >= 0);
 980         unsigned int c1 = gfc_current_locus.nextc - gfc_current_locus.lb->line;
 981         gcc_assert (text->locus);
 982         *text->locus
 983           = linemap_position_for_loc_and_offset (line_table,
 984                                                  gfc_current_locus.lb->location,
 985                                                  c1);
 986         global_dc->caret_char = '1';
 987         pp_string (pp, result);
 988         return true;
 989       }
 990     default:
 991       return false;
 992     }
 993 }
 994
 995 /* Return a malloc'd string describing a location.  The caller is
 996    responsible for freeing the memory.  */
 997 static char *
 998 gfc_diagnostic_build_prefix (diagnostic_context *context,
 999                              const diagnostic_info *diagnostic)
1000 {
1001   static const char *const diagnostic_kind_text[] = {
1002 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T),
1003 #include "gfc-diagnostic.def"
1004 #undef DEFINE_DIAGNOSTIC_KIND
1005     "must-not-happen"
1006   };
1007   static const char *const diagnostic_kind_color[] = {
1008 #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C),
1009 #include "gfc-diagnostic.def"
1010 #undef DEFINE_DIAGNOSTIC_KIND
1011     NULL
1012   };
1013   gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND);
1014   const char *text = _(diagnostic_kind_text[diagnostic->kind]);
1015   const char *text_cs = "", *text_ce = "";
1016   pretty_printer *pp = context->printer;
1017
1018   if (diagnostic_kind_color[diagnostic->kind])
1019     {
1020       text_cs = colorize_start (pp_show_color (pp),
1021                                 diagnostic_kind_color[diagnostic->kind]);
1022       text_ce = colorize_stop (pp_show_color (pp));
1023     }
1024   return build_message_string ("%s%s%s: ", text_cs, text, text_ce);
1025 }
1026
1027 /* Return a malloc'd string describing a location.  The caller is
1028    responsible for freeing the memory.  */
1029 static char *
1030 gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
1031                                    const diagnostic_info *diagnostic)
1032 {
1033   pretty_printer *pp = context->printer;
1034   const char *locus_cs = colorize_start (pp_show_color (pp), "locus");
1035   const char *locus_ce = colorize_stop (pp_show_color (pp));
1036   expanded_location s = expand_location_to_spelling_point (diagnostic->location);
1037   if (diagnostic->override_column)
1038     s.column = diagnostic->override_column;
1039
1040   return (s.file == NULL
1041           ? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
1042           : !strcmp (s.file, N_("<built-in>"))
1043           ? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1044           : context->show_column
1045           ? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line,
1046                                   s.column, locus_ce)
1047           : build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce));
1048 }
1049
1050 static void
1051 gfc_diagnostic_starter (diagnostic_context *context,
1052                         diagnostic_info *diagnostic)
1053 {
1054   char * locus_prefix = gfc_diagnostic_build_locus_prefix (context, diagnostic);
1055   char * prefix = gfc_diagnostic_build_prefix (context, diagnostic);
1056   /* First we assume there is a caret line.  */
1057   pp_set_prefix (context->printer, NULL);
1058   if (pp_needs_newline (context->printer))
1059     pp_newline (context->printer);
1060   pp_verbatim (context->printer, locus_prefix);
1061   /* Fortran uses an empty line between locus and caret line.  */
1062   pp_newline (context->printer);
1063   diagnostic_show_locus (context, diagnostic);
1064   if (pp_needs_newline (context->printer))
1065     {
1066       pp_newline (context->printer);
1067       /* If the caret line was shown, the prefix does not contain the
1068          locus.  */
1069       pp_set_prefix (context->printer, prefix);
1070     }
1071   else
1072     {
1073       /* Otherwise, start again.  */
1074       pp_clear_output_area(context->printer);
1075       pp_set_prefix (context->printer, concat (locus_prefix, " ", prefix, NULL));
1076       free (prefix);
1077     }
1078   free (locus_prefix);
1079 }
1080
1081 static void
1082 gfc_diagnostic_finalizer (diagnostic_context *context,
1083                           diagnostic_info *diagnostic ATTRIBUTE_UNUSED)
1084 {
1085   pp_destroy_prefix (context->printer);
1086   pp_newline_and_flush (context->printer);
1087 }
1088
1089 /* Immediate warning (i.e. do not buffer the warning).  */
1090 /* This function uses the common diagnostics, but does not support %L, yet.  */
1091
1092 bool
1093 gfc_warning_now_2 (int opt, const char *gmsgid, ...)
1094 {
1095   va_list argp;
1096   diagnostic_info diagnostic;
1097   bool ret;
1098
1099   va_start (argp, gmsgid);
1100   diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION,
1101                        DK_WARNING);
1102   diagnostic.option_index = opt;
1103   ret = report_diagnostic (&diagnostic);
1104   va_end (argp);
1105   return ret;
1106 }
1107
1108 /* Immediate warning (i.e. do not buffer the warning).  */
1109 /* This function uses the common diagnostics, but does not support %L, yet.  */
1110
1111 bool
1112 gfc_warning_now_2 (const char *gmsgid, ...)
1113 {
1114   va_list argp;
1115   diagnostic_info diagnostic;
1116   bool ret;
1117
1118   va_start (argp, gmsgid);
1119   diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION,
1120                        DK_WARNING);
1121   ret = report_diagnostic (&diagnostic);
1122   va_end (argp);
1123   return ret;
1124 }
1125
1126
1127 /* Immediate error (i.e. do not buffer).  */
1128 /* This function uses the common diagnostics, but does not support %L, yet.  */
1129
1130 void
1131 gfc_error_now_2 (const char *gmsgid, ...)
1132 {
1133   va_list argp;
1134   diagnostic_info diagnostic;
1135
1136   va_start (argp, gmsgid);
1137   diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR);
1138   report_diagnostic (&diagnostic);
1139   va_end (argp);
1140 }
1141
1142
1143 /* Fatal error, never returns.  */
1144 /* This function uses the common diagnostics, but does not support %L, yet.  */
1145
1146 void
1147 gfc_fatal_error (const char *gmsgid, ...)
1148 {
1149   va_list argp;
1150   diagnostic_info diagnostic;
1151
1152   va_start (argp, gmsgid);
1153   diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_FATAL);
1154   report_diagnostic (&diagnostic);
1155   va_end (argp);
1156
1157   gcc_unreachable ();
1158 }
1159
1160 /* Clear the warning flag.  */
1161
1162 void
1163 gfc_clear_warning (void)
1164 {
1165   warning_buffer.flag = 0;
1166 }
1167
1168
1169 /* Check to see if any warnings have been saved.
1170    If so, print the warning.  */
1171
1172 void
1173 gfc_warning_check (void)
1174 {
1175   if (warning_buffer.flag)
1176     {
1177       warnings++;
1178       if (warning_buffer.message != NULL)
1179         fputs (warning_buffer.message, stderr);
1180       warning_buffer.flag = 0;
1181     }
1182 }
1183
1184
1185 /* Issue an error.  */
1186
1187 void
1188 gfc_error (const char *gmsgid, ...)
1189 {
1190   va_list argp;
1191
1192   if (warnings_not_errors)
1193     goto warning;
1194
1195   if (suppress_errors)
1196     return;
1197
1198   error_buffer.flag = 1;
1199   error_buffer.index = 0;
1200   cur_error_buffer = &error_buffer;
1201
1202   va_start (argp, gmsgid);
1203   error_print (_("Error:"), _(gmsgid), argp);
1204   va_end (argp);
1205
1206   error_char ('\0');
1207
1208   if (buffer_flag == 0)
1209     gfc_increment_error_count();
1210
1211   return;
1212
1213 warning:
1214
1215   if (inhibit_warnings)
1216     return;
1217
1218   warning_buffer.flag = 1;
1219   warning_buffer.index = 0;
1220   cur_error_buffer = &warning_buffer;
1221
1222   va_start (argp, gmsgid);
1223   error_print (_("Warning:"), _(gmsgid), argp);
1224   va_end (argp);
1225
1226   error_char ('\0');
1227
1228   if (buffer_flag == 0)
1229   {
1230     warnings++;
1231     if (warnings_are_errors)
1232       gfc_increment_error_count();
1233   }
1234 }
1235
1236
1237 /* Immediate error.  */
1238 /* Use gfc_error_now_2 instead, unless gmsgid contains a %L.  */
1239
1240 void
1241 gfc_error_now (const char *gmsgid, ...)
1242 {
1243   va_list argp;
1244   int i;
1245
1246   error_buffer.flag = 1;
1247   error_buffer.index = 0;
1248   cur_error_buffer = &error_buffer;
1249
1250   i = buffer_flag;
1251   buffer_flag = 0;
1252
1253   va_start (argp, gmsgid);
1254   error_print (_("Error:"), _(gmsgid), argp);
1255   va_end (argp);
1256
1257   error_char ('\0');
1258
1259   gfc_increment_error_count();
1260
1261   buffer_flag = i;
1262
1263   if (flag_fatal_errors)
1264     exit (FATAL_EXIT_CODE);
1265 }
1266
1267
1268 /* Fatal error, never returns.  */
1269 /* Use gfc_fatal_error instead, unless gmsgid contains a %L.  */
1270
1271 void
1272 gfc_fatal_error_1 (const char *gmsgid, ...)
1273 {
1274   va_list argp;
1275
1276   buffer_flag = 0;
1277
1278   va_start (argp, gmsgid);
1279   error_print (_("Fatal Error:"), _(gmsgid), argp);
1280   va_end (argp);
1281
1282   exit (FATAL_EXIT_CODE);
1283 }
1284
1285
1286 /* This shouldn't happen... but sometimes does.  */
1287
1288 void
1289 gfc_internal_error (const char *format, ...)
1290 {
1291   va_list argp;
1292
1293   buffer_flag = 0;
1294
1295   va_start (argp, format);
1296
1297   show_loci (&gfc_current_locus, NULL);
1298   error_printf ("Internal Error at (1):");
1299
1300   error_print ("", format, argp);
1301   va_end (argp);
1302
1303   exit (ICE_EXIT_CODE);
1304 }
1305
1306
1307 /* Clear the error flag when we start to compile a source line.  */
1308
1309 void
1310 gfc_clear_error (void)
1311 {
1312   error_buffer.flag = 0;
1313   warnings_not_errors = 0;
1314 }
1315
1316
1317 /* Tests the state of error_flag.  */
1318
1319 int
1320 gfc_error_flag_test (void)
1321 {
1322   return error_buffer.flag;
1323 }
1324
1325
1326 /* Check to see if any errors have been saved.
1327    If so, print the error.  Returns the state of error_flag.  */
1328
1329 int
1330 gfc_error_check (void)
1331 {
1332   int rc;
1333
1334   rc = error_buffer.flag;
1335
1336   if (error_buffer.flag)
1337     {
1338       if (error_buffer.message != NULL)
1339         fputs (error_buffer.message, stderr);
1340       error_buffer.flag = 0;
1341
1342       gfc_increment_error_count();
1343
1344       if (flag_fatal_errors)
1345         exit (FATAL_EXIT_CODE);
1346     }
1347
1348   return rc;
1349 }
1350
1351
1352 /* Save the existing error state.  */
1353
1354 void
1355 gfc_push_error (gfc_error_buf *err)
1356 {
1357   err->flag = error_buffer.flag;
1358   if (error_buffer.flag)
1359     err->message = xstrdup (error_buffer.message);
1360
1361   error_buffer.flag = 0;
1362 }
1363
1364
1365 /* Restore a previous pushed error state.  */
1366
1367 void
1368 gfc_pop_error (gfc_error_buf *err)
1369 {
1370   error_buffer.flag = err->flag;
1371   if (error_buffer.flag)
1372     {
1373       size_t len = strlen (err->message) + 1;
1374       gcc_assert (len <= error_buffer.allocated);
1375       memcpy (error_buffer.message, err->message, len);
1376       free (err->message);
1377     }
1378 }
1379
1380
1381 /* Free a pushed error state, but keep the current error state.  */
1382
1383 void
1384 gfc_free_error (gfc_error_buf *err)
1385 {
1386   if (err->flag)
1387     free (err->message);
1388 }
1389
1390
1391 /* Report the number of warnings and errors that occurred to the caller.  */
1392
1393 void
1394 gfc_get_errors (int *w, int *e)
1395 {
1396   if (w != NULL)
1397     *w = warnings;
1398   if (e != NULL)
1399     *e = errors;
1400 }
1401
1402
1403 /* Switch errors into warnings.  */
1404
1405 void
1406 gfc_errors_to_warnings (int f)
1407 {
1408   warnings_not_errors = (f == 1) ? 1 : 0;
1409 }
1410
1411 void
1412 gfc_diagnostics_init (void)
1413 {
1414   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1415   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1416   diagnostic_format_decoder (global_dc) = gfc_format_decoder;
1417   global_dc->caret_char = '^';
1418 }
1419
1420 void
1421 gfc_diagnostics_finish (void)
1422 {
1423   tree_diagnostics_defaults (global_dc);
1424   /* We still want to use the gfc starter and finalizer, not the tree
1425      defaults.  */
1426   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1427   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1428   global_dc->caret_char = '^';
1429 }