gcc/fortran/error.c

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