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 /* Give a warning about the command-line.  */
1056
1057 bool
1058 gfc_warning_cmdline (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
1074 /* Give a warning about the command-line.  */
1075
1076 bool
1077 gfc_warning_cmdline (const char *gmsgid, ...)
1078 {
1079   va_list argp;
1080   diagnostic_info diagnostic;
1081   bool ret;
1082
1083   va_start (argp, gmsgid);
1084   diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION,
1085                        DK_WARNING);
1086   ret = report_diagnostic (&diagnostic);
1087   va_end (argp);
1088   return ret;
1089 }
1090
1091
1092 /* Give an error about the command-line.  */
1093
1094 void
1095 gfc_error_cmdline (const char *gmsgid, ...)
1096 {
1097   va_list argp;
1098   diagnostic_info diagnostic;
1099
1100   va_start (argp, gmsgid);
1101   diagnostic_set_info (&diagnostic, gmsgid, &argp, UNKNOWN_LOCATION, DK_ERROR);
1102   report_diagnostic (&diagnostic);
1103   va_end (argp);
1104 }
1105
1106 /* Clear the warning flag.  */
1107
1108 void
1109 gfc_clear_warning (void)
1110 {
1111   warning_buffer.flag = 0;
1112 }
1113
1114
1115 /* Check to see if any warnings have been saved.
1116    If so, print the warning.  */
1117
1118 void
1119 gfc_warning_check (void)
1120 {
1121   if (warning_buffer.flag)
1122     {
1123       warnings++;
1124       if (warning_buffer.message != NULL)
1125         fputs (warning_buffer.message, stderr);
1126       warning_buffer.flag = 0;
1127     }
1128 }
1129
1130
1131 /* Issue an error.  */
1132
1133 void
1134 gfc_error (const char *gmsgid, ...)
1135 {
1136   va_list argp;
1137
1138   if (warnings_not_errors)
1139     goto warning;
1140
1141   if (suppress_errors)
1142     return;
1143
1144   error_buffer.flag = 1;
1145   error_buffer.index = 0;
1146   cur_error_buffer = &error_buffer;
1147
1148   va_start (argp, gmsgid);
1149   error_print (_("Error:"), _(gmsgid), argp);
1150   va_end (argp);
1151
1152   error_char ('\0');
1153
1154   if (buffer_flag == 0)
1155     gfc_increment_error_count();
1156
1157   return;
1158
1159 warning:
1160
1161   if (inhibit_warnings)
1162     return;
1163
1164   warning_buffer.flag = 1;
1165   warning_buffer.index = 0;
1166   cur_error_buffer = &warning_buffer;
1167
1168   va_start (argp, gmsgid);
1169   error_print (_("Warning:"), _(gmsgid), argp);
1170   va_end (argp);
1171
1172   error_char ('\0');
1173
1174   if (buffer_flag == 0)
1175   {
1176     warnings++;
1177     if (warnings_are_errors)
1178       gfc_increment_error_count();
1179   }
1180 }
1181
1182
1183 /* Immediate error.  */
1184
1185 void
1186 gfc_error_now (const char *gmsgid, ...)
1187 {
1188   va_list argp;
1189   int i;
1190
1191   error_buffer.flag = 1;
1192   error_buffer.index = 0;
1193   cur_error_buffer = &error_buffer;
1194
1195   i = buffer_flag;
1196   buffer_flag = 0;
1197
1198   va_start (argp, gmsgid);
1199   error_print (_("Error:"), _(gmsgid), argp);
1200   va_end (argp);
1201
1202   error_char ('\0');
1203
1204   gfc_increment_error_count();
1205
1206   buffer_flag = i;
1207
1208   if (flag_fatal_errors)
1209     exit (FATAL_EXIT_CODE);
1210 }
1211
1212
1213 /* Fatal error, never returns.  */
1214
1215 void
1216 gfc_fatal_error (const char *gmsgid, ...)
1217 {
1218   va_list argp;
1219
1220   buffer_flag = 0;
1221
1222   va_start (argp, gmsgid);
1223   error_print (_("Fatal Error:"), _(gmsgid), argp);
1224   va_end (argp);
1225
1226   exit (FATAL_EXIT_CODE);
1227 }
1228
1229
1230 /* This shouldn't happen... but sometimes does.  */
1231
1232 void
1233 gfc_internal_error (const char *format, ...)
1234 {
1235   va_list argp;
1236
1237   buffer_flag = 0;
1238
1239   va_start (argp, format);
1240
1241   show_loci (&gfc_current_locus, NULL);
1242   error_printf ("Internal Error at (1):");
1243
1244   error_print ("", format, argp);
1245   va_end (argp);
1246
1247   exit (ICE_EXIT_CODE);
1248 }
1249
1250
1251 /* Clear the error flag when we start to compile a source line.  */
1252
1253 void
1254 gfc_clear_error (void)
1255 {
1256   error_buffer.flag = 0;
1257   warnings_not_errors = 0;
1258 }
1259
1260
1261 /* Tests the state of error_flag.  */
1262
1263 int
1264 gfc_error_flag_test (void)
1265 {
1266   return error_buffer.flag;
1267 }
1268
1269
1270 /* Check to see if any errors have been saved.
1271    If so, print the error.  Returns the state of error_flag.  */
1272
1273 int
1274 gfc_error_check (void)
1275 {
1276   int rc;
1277
1278   rc = error_buffer.flag;
1279
1280   if (error_buffer.flag)
1281     {
1282       if (error_buffer.message != NULL)
1283         fputs (error_buffer.message, stderr);
1284       error_buffer.flag = 0;
1285
1286       gfc_increment_error_count();
1287
1288       if (flag_fatal_errors)
1289         exit (FATAL_EXIT_CODE);
1290     }
1291
1292   return rc;
1293 }
1294
1295
1296 /* Save the existing error state.  */
1297
1298 void
1299 gfc_push_error (gfc_error_buf *err)
1300 {
1301   err->flag = error_buffer.flag;
1302   if (error_buffer.flag)
1303     err->message = xstrdup (error_buffer.message);
1304
1305   error_buffer.flag = 0;
1306 }
1307
1308
1309 /* Restore a previous pushed error state.  */
1310
1311 void
1312 gfc_pop_error (gfc_error_buf *err)
1313 {
1314   error_buffer.flag = err->flag;
1315   if (error_buffer.flag)
1316     {
1317       size_t len = strlen (err->message) + 1;
1318       gcc_assert (len <= error_buffer.allocated);
1319       memcpy (error_buffer.message, err->message, len);
1320       free (err->message);
1321     }
1322 }
1323
1324
1325 /* Free a pushed error state, but keep the current error state.  */
1326
1327 void
1328 gfc_free_error (gfc_error_buf *err)
1329 {
1330   if (err->flag)
1331     free (err->message);
1332 }
1333
1334
1335 /* Report the number of warnings and errors that occurred to the caller.  */
1336
1337 void
1338 gfc_get_errors (int *w, int *e)
1339 {
1340   if (w != NULL)
1341     *w = warnings;
1342   if (e != NULL)
1343     *e = errors;
1344 }
1345
1346
1347 /* Switch errors into warnings.  */
1348
1349 void
1350 gfc_errors_to_warnings (int f)
1351 {
1352   warnings_not_errors = (f == 1) ? 1 : 0;
1353 }
1354
1355 void
1356 gfc_diagnostics_init (void)
1357 {
1358   diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1359   diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1360   global_dc->caret_char = '^';
1361 }