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