gcc/fortran/error.c

   1 /* Handle errors.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   3    2010
   4    Free Software Foundation, Inc.
   5    Contributed by Andy Vaught & Niels Kristian Bech Jensen
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* Handle the inevitable errors.  A major catch here is that things
  24    flagged as errors in one match subroutine can conceivably be legal
  25    elsewhere.  This means that error messages are recorded and saved
  26    for possible use later.  If a line does not match a legal
  27    construction, then the saved error message is reported.  */
  28
  29 #include "config.h"
  30 #include "system.h"
  31 #include "flags.h"
  32 #include "gfortran.h"
  33
  34 static int suppress_errors = 0;
  35
  36 static int warnings_not_errors = 0;
  37
  38 static int terminal_width, buffer_flag, errors, warnings;
  39
  40 static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
  41
  42
  43 /* Go one level deeper suppressing errors.  */
  44
  45 void
  46 gfc_push_suppress_errors (void)
  47 {
  48   gcc_assert (suppress_errors >= 0);
  49   ++suppress_errors;
  50 }
  51
  52
  53 /* Leave one level of error suppressing.  */
  54
  55 void
  56 gfc_pop_suppress_errors (void)
  57 {
  58   gcc_assert (suppress_errors > 0);
  59   --suppress_errors;
  60 }
  61
  62
  63 /* Per-file error initialization.  */
  64
  65 void
  66 gfc_error_init_1 (void)
  67 {
  68   terminal_width = gfc_terminal_width ();
  69   errors = 0;
  70   warnings = 0;
  71   buffer_flag = 0;
  72 }
  73
  74
  75 /* Set the flag for buffering errors or not.  */
  76
  77 void
  78 gfc_buffer_error (int flag)
  79 {
  80   buffer_flag = flag;
  81 }
  82
  83
  84 /* Add a single character to the error buffer or output depending on
  85    buffer_flag.  */
  86
  87 static void
  88 error_char (char c)
  89 {
  90   if (buffer_flag)
  91     {
  92       if (cur_error_buffer->index >= cur_error_buffer->allocated)
  93         {
  94           cur_error_buffer->allocated = cur_error_buffer->allocated
  95                                       ? cur_error_buffer->allocated * 2 : 1000;
  96           cur_error_buffer->message = XRESIZEVEC (char, cur_error_buffer->message,
  97                                                   cur_error_buffer->allocated);
  98         }
  99       cur_error_buffer->message[cur_error_buffer->index++] = c;
 100     }
 101   else
 102     {
 103       if (c != 0)
 104         {
 105           /* We build up complete lines before handing things
 106              over to the library in order to speed up error printing.  */
 107           static char *line;
 108           static size_t allocated = 0, index = 0;
 109
 110           if (index + 1 >= allocated)
 111             {
 112               allocated = allocated ? allocated * 2 : 1000;
 113               line = XRESIZEVEC (char, line, allocated);
 114             }
 115           line[index++] = c;
 116           if (c == '\n')
 117             {
 118               line[index] = '\0';
 119               fputs (line, stderr);
 120               index = 0;
 121             }
 122         }
 123     }
 124 }
 125
 126
 127 /* Copy a string to wherever it needs to go.  */
 128
 129 static void
 130 error_string (const char *p)
 131 {
 132   while (*p)
 133     error_char (*p++);
 134 }
 135
 136
 137 /* Print a formatted integer to the error buffer or output.  */
 138
 139 #define IBUF_LEN 60
 140
 141 static void
 142 error_uinteger (unsigned long int i)
 143 {
 144   char *p, int_buf[IBUF_LEN];
 145
 146   p = int_buf + IBUF_LEN - 1;
 147   *p-- = '\0';
 148
 149   if (i == 0)
 150     *p-- = '0';
 151
 152   while (i > 0)
 153     {
 154       *p-- = i % 10 + '0';
 155       i = i / 10;
 156     }
 157
 158   error_string (p + 1);
 159 }
 160
 161 static void
 162 error_integer (long int i)
 163 {
 164   unsigned long int u;
 165
 166   if (i < 0)
 167     {
 168       u = (unsigned long int) -i;
 169       error_char ('-');
 170     }
 171   else
 172     u = i;
 173
 174   error_uinteger (u);
 175 }
 176
 177
 178 static size_t
 179 gfc_widechar_display_length (gfc_char_t c)
 180 {
 181   if (gfc_wide_is_printable (c))
 182     /* Simple ASCII character  */
 183     return 1;
 184   else if (c < ((gfc_char_t) 1 << 8))
 185     /* Displayed as \x??  */
 186     return 4;
 187   else if (c < ((gfc_char_t) 1 << 16))
 188     /* Displayed as \u????  */
 189     return 6;
 190   else
 191     /* Displayed as \U????????  */
 192     return 10;
 193 }
 194
 195
 196 /* Length of the ASCII representation of the wide string, escaping wide
 197    characters as print_wide_char_into_buffer() does.  */
 198
 199 static size_t
 200 gfc_wide_display_length (const gfc_char_t *str)
 201 {
 202   size_t i, len;
 203
 204   for (i = 0, len = 0; str[i]; i++)
 205     len += gfc_widechar_display_length (str[i]);
 206
 207   return len;
 208 }
 209
 210 static int
 211 print_wide_char_into_buffer (gfc_char_t c, char *buf)
 212 {
 213   static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
 214     '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
 215
 216   if (gfc_wide_is_printable (c))
 217     {
 218       buf[1] = '\0';
 219       buf[0] = (unsigned char) 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 c, *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
 374       c = *p++;
 375       if (c == '\t')
 376         c = ' ';
 377
 378       i -= print_wide_char_into_buffer (c, buffer);
 379       error_string (buffer);
 380     }
 381
 382   error_char ('\n');
 383
 384   /* Show the '1' and/or '2' corresponding to the column of the error
 385      locus.  Note that a value of -1 for c1 or c2 will simply cause
 386      the relevant number not to be printed.  */
 387
 388   c1 -= offset;
 389   c2 -= offset;
 390
 391   p = &(lb->line[offset]);
 392   for (i = 0; i <= cmax; i++)
 393     {
 394       int spaces, j;
 395       spaces = gfc_widechar_display_length (*p++);
 396
 397       if (i == c1)
 398         error_char ('1'), spaces--;
 399       else if (i == c2)
 400         error_char ('2'), spaces--;
 401
 402       for (j = 0; j < spaces; j++)
 403         error_char (' ');
 404     }
 405
 406   error_char ('\n');
 407
 408 }
 409
 410
 411 /* As part of printing an error, we show the source lines that caused
 412    the problem.  We show at least one, and possibly two loci; the two
 413    loci may or may not be on the same source line.  */
 414
 415 static void
 416 show_loci (locus *l1, locus *l2)
 417 {
 418   int m, c1, c2;
 419
 420   if (l1 == NULL || l1->lb == NULL)
 421     {
 422       error_printf ("<During initialization>\n");
 423       return;
 424     }
 425
 426   /* While calculating parameters for printing the loci, we consider possible
 427      reasons for printing one per line.  If appropriate, print the loci
 428      individually; otherwise we print them both on the same line.  */
 429
 430   c1 = l1->nextc - l1->lb->line;
 431   if (l2 == NULL)
 432     {
 433       show_locus (l1, c1, -1);
 434       return;
 435     }
 436
 437   c2 = l2->nextc - l2->lb->line;
 438
 439   if (c1 < c2)
 440     m = c2 - c1;
 441   else
 442     m = c1 - c2;
 443
 444   /* Note that the margin value of 10 here needs to be less than the
 445      margin of 5 used in the calculation of offset in show_locus.  */
 446
 447   if (l1->lb != l2->lb || m > terminal_width - 10)
 448     {
 449       show_locus (l1, c1, -1);
 450       show_locus (l2, -1, c2);
 451       return;
 452     }
 453
 454   show_locus (l1, c1, c2);
 455
 456   return;
 457 }
 458
 459
 460 /* Workhorse for the error printing subroutines.  This subroutine is
 461    inspired by g77's error handling and is similar to printf() with
 462    the following %-codes:
 463
 464    %c Character, %d or %i Integer, %s String, %% Percent
 465    %L  Takes locus argument
 466    %C  Current locus (no argument)
 467
 468    If a locus pointer is given, the actual source line is printed out
 469    and the column is indicated.  Since we want the error message at
 470    the bottom of any source file information, we must scan the
 471    argument list twice -- once to determine whether the loci are
 472    present and record this for printing, and once to print the error
 473    message after and loci have been printed.  A maximum of two locus
 474    arguments are permitted.
 475
 476    This function is also called (recursively) by show_locus in the
 477    case of included files; however, as show_locus does not resupply
 478    any loci, the recursion is at most one level deep.  */
 479
 480 #define MAX_ARGS 10
 481
 482 static void ATTRIBUTE_GCC_GFC(2,0)
 483 error_print (const char *type, const char *format0, va_list argp)
 484 {
 485   enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER,
 486          TYPE_LONGINT, TYPE_ULONGINT, TYPE_CHAR, TYPE_STRING,
 487          NOTYPE };
 488   struct
 489   {
 490     int type;
 491     int pos;
 492     union
 493     {
 494       int intval;
 495       unsigned int uintval;
 496       long int longintval;
 497       unsigned long int ulongintval;
 498       char charval;
 499       const char * stringval;
 500     } u;
 501   } arg[MAX_ARGS], spec[MAX_ARGS];
 502   /* spec is the array of specifiers, in the same order as they
 503      appear in the format string.  arg is the array of arguments,
 504      in the same order as they appear in the va_list.  */
 505
 506   char c;
 507   int i, n, have_l1, pos, maxpos;
 508   locus *l1, *l2, *loc;
 509   const char *format;
 510
 511   loc = l1 = l2 = NULL;
 512
 513   have_l1 = 0;
 514   pos = -1;
 515   maxpos = -1;
 516
 517   n = 0;
 518   format = format0;
 519
 520   for (i = 0; i < MAX_ARGS; i++)
 521     {
 522       arg[i].type = NOTYPE;
 523       spec[i].pos = -1;
 524     }
 525
 526   /* First parse the format string for position specifiers.  */
 527   while (*format)
 528     {
 529       c = *format++;
 530       if (c != '%')
 531         continue;
 532
 533       if (*format == '%')
 534         {
 535           format++;
 536           continue;
 537         }
 538
 539       if (ISDIGIT (*format))
 540         {
 541           /* This is a position specifier.  For example, the number
 542              12 in the format string "%12$d", which specifies the third
 543              argument of the va_list, formatted in %d format.
 544              For details, see "man 3 printf".  */
 545           pos = atoi(format) - 1;
 546           gcc_assert (pos >= 0);
 547           while (ISDIGIT(*format))
 548             format++;
 549           gcc_assert (*format++ == '$');
 550         }
 551       else
 552         pos++;
 553
 554       c = *format++;
 555
 556       if (pos > maxpos)
 557         maxpos = pos;
 558
 559       switch (c)
 560         {
 561           case 'C':
 562             arg[pos].type = TYPE_CURRENTLOC;
 563             break;
 564
 565           case 'L':
 566             arg[pos].type = TYPE_LOCUS;
 567             break;
 568
 569           case 'd':
 570           case 'i':
 571             arg[pos].type = TYPE_INTEGER;
 572             break;
 573
 574           case 'u':
 575             arg[pos].type = TYPE_UINTEGER;
 576             break;
 577
 578           case 'l':
 579             c = *format++;
 580             if (c == 'u')
 581               arg[pos].type = TYPE_ULONGINT;
 582             else if (c == 'i' || c == 'd')
 583               arg[pos].type = TYPE_LONGINT;
 584             else
 585               gcc_unreachable ();
 586             break;
 587
 588           case 'c':
 589             arg[pos].type = TYPE_CHAR;
 590             break;
 591
 592           case 's':
 593             arg[pos].type = TYPE_STRING;
 594             break;
 595
 596           default:
 597             gcc_unreachable ();
 598         }
 599
 600       spec[n++].pos = pos;
 601     }
 602
 603   /* Then convert the values for each %-style argument.  */
 604   for (pos = 0; pos <= maxpos; pos++)
 605     {
 606       gcc_assert (arg[pos].type != NOTYPE);
 607       switch (arg[pos].type)
 608         {
 609           case TYPE_CURRENTLOC:
 610             loc = &gfc_current_locus;
 611             /* Fall through.  */
 612
 613           case TYPE_LOCUS:
 614             if (arg[pos].type == TYPE_LOCUS)
 615               loc = va_arg (argp, locus *);
 616
 617             if (have_l1)
 618               {
 619                 l2 = loc;
 620                 arg[pos].u.stringval = "(2)";
 621               }
 622             else
 623               {
 624                 l1 = loc;
 625                 have_l1 = 1;
 626                 arg[pos].u.stringval = "(1)";
 627               }
 628             break;
 629
 630           case TYPE_INTEGER:
 631             arg[pos].u.intval = va_arg (argp, int);
 632             break;
 633
 634           case TYPE_UINTEGER:
 635             arg[pos].u.uintval = va_arg (argp, unsigned int);
 636             break;
 637
 638           case TYPE_LONGINT:
 639             arg[pos].u.longintval = va_arg (argp, long int);
 640             break;
 641
 642           case TYPE_ULONGINT:
 643             arg[pos].u.ulongintval = va_arg (argp, unsigned long int);
 644             break;
 645
 646           case TYPE_CHAR:
 647             arg[pos].u.charval = (char) va_arg (argp, int);
 648             break;
 649
 650           case TYPE_STRING:
 651             arg[pos].u.stringval = (const char *) va_arg (argp, char *);
 652             break;
 653
 654           default:
 655             gcc_unreachable ();
 656         }
 657     }
 658
 659   for (n = 0; spec[n].pos >= 0; n++)
 660     spec[n].u = arg[spec[n].pos].u;
 661
 662   /* Show the current loci if we have to.  */
 663   if (have_l1)
 664     show_loci (l1, l2);
 665
 666   if (*type)
 667     {
 668       error_string (type);
 669       error_char (' ');
 670     }
 671
 672   have_l1 = 0;
 673   format = format0;
 674   n = 0;
 675
 676   for (; *format; format++)
 677     {
 678       if (*format != '%')
 679         {
 680           error_char (*format);
 681           continue;
 682         }
 683
 684       format++;
 685       if (ISDIGIT (*format))
 686         {
 687           /* This is a position specifier.  See comment above.  */
 688           while (ISDIGIT (*format))
 689             format++;
 690
 691           /* Skip over the dollar sign.  */
 692           format++;
 693         }
 694
 695       switch (*format)
 696         {
 697         case '%':
 698           error_char ('%');
 699           break;
 700
 701         case 'c':
 702           error_char (spec[n++].u.charval);
 703           break;
 704
 705         case 's':
 706         case 'C':               /* Current locus */
 707         case 'L':               /* Specified locus */
 708           error_string (spec[n++].u.stringval);
 709           break;
 710
 711         case 'd':
 712         case 'i':
 713           error_integer (spec[n++].u.intval);
 714           break;
 715
 716         case 'u':
 717           error_uinteger (spec[n++].u.uintval);
 718           break;
 719
 720         case 'l':
 721           format++;
 722           if (*format == 'u')
 723             error_uinteger (spec[n++].u.ulongintval);
 724           else
 725             error_integer (spec[n++].u.longintval);
 726           break;
 727
 728         }
 729     }
 730
 731   error_char ('\n');
 732 }
 733
 734
 735 /* Wrapper for error_print().  */
 736
 737 static void
 738 error_printf (const char *gmsgid, ...)
 739 {
 740   va_list argp;
 741
 742   va_start (argp, gmsgid);
 743   error_print ("", _(gmsgid), argp);
 744   va_end (argp);
 745 }
 746
 747
 748 /* Increment the number of errors, and check whether too many have
 749    been printed.  */
 750
 751 static void
 752 gfc_increment_error_count (void)
 753 {
 754   errors++;
 755   if ((gfc_option.max_errors != 0) && (errors >= gfc_option.max_errors))
 756     gfc_fatal_error ("Error count reached limit of %d.", gfc_option.max_errors);
 757 }
 758
 759
 760 /* Issue a warning.  */
 761
 762 void
 763 gfc_warning (const char *gmsgid, ...)
 764 {
 765   va_list argp;
 766
 767   if (inhibit_warnings)
 768     return;
 769
 770   warning_buffer.flag = 1;
 771   warning_buffer.index = 0;
 772   cur_error_buffer = &warning_buffer;
 773
 774   va_start (argp, gmsgid);
 775   error_print (_("Warning:"), _(gmsgid), argp);
 776   va_end (argp);
 777
 778   error_char ('\0');
 779
 780   if (buffer_flag == 0)
 781   {
 782     warnings++;
 783     if (warnings_are_errors)
 784       gfc_increment_error_count();
 785   }
 786 }
 787
 788
 789 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 790    we should issue an error or a warning, or be quiet.  */
 791
 792 notification
 793 gfc_notification_std (int std)
 794 {
 795   bool warning;
 796
 797   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 798   if ((gfc_option.allow_std & std) != 0 && !warning)
 799     return SILENT;
 800
 801   return warning ? WARNING : ERROR;
 802 }
 803
 804
 805 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 806    feature.  An error/warning will be issued if the currently selected
 807    standard does not contain the requested bits.  Return FAILURE if
 808    an error is generated.  */
 809
 810 gfc_try
 811 gfc_notify_std (int std, const char *gmsgid, ...)
 812 {
 813   va_list argp;
 814   bool warning;
 815
 816   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 817   if ((gfc_option.allow_std & std) != 0 && !warning)
 818     return SUCCESS;
 819
 820   if (suppress_errors)
 821     return warning ? SUCCESS : FAILURE;
 822
 823   cur_error_buffer = warning ? &warning_buffer : &error_buffer;
 824   cur_error_buffer->flag = 1;
 825   cur_error_buffer->index = 0;
 826
 827   va_start (argp, gmsgid);
 828   if (warning)
 829     error_print (_("Warning:"), _(gmsgid), argp);
 830   else
 831     error_print (_("Error:"), _(gmsgid), argp);
 832   va_end (argp);
 833
 834   error_char ('\0');
 835
 836   if (buffer_flag == 0)
 837     {
 838       if (warning && !warnings_are_errors)
 839         warnings++;
 840       else
 841         gfc_increment_error_count();
 842     }
 843
 844   return (warning && !warnings_are_errors) ? SUCCESS : FAILURE;
 845 }
 846
 847
 848 /* Immediate warning (i.e. do not buffer the warning).  */
 849
 850 void
 851 gfc_warning_now (const char *gmsgid, ...)
 852 {
 853   va_list argp;
 854   int i;
 855
 856   if (inhibit_warnings)
 857     return;
 858
 859   i = buffer_flag;
 860   buffer_flag = 0;
 861   warnings++;
 862
 863   va_start (argp, gmsgid);
 864   error_print (_("Warning:"), _(gmsgid), argp);
 865   va_end (argp);
 866
 867   error_char ('\0');
 868
 869   if (warnings_are_errors)
 870     gfc_increment_error_count();
 871
 872   buffer_flag = i;
 873 }
 874
 875
 876 /* Clear the warning flag.  */
 877
 878 void
 879 gfc_clear_warning (void)
 880 {
 881   warning_buffer.flag = 0;
 882 }
 883
 884
 885 /* Check to see if any warnings have been saved.
 886    If so, print the warning.  */
 887
 888 void
 889 gfc_warning_check (void)
 890 {
 891   if (warning_buffer.flag)
 892     {
 893       warnings++;
 894       if (warning_buffer.message != NULL)
 895         fputs (warning_buffer.message, stderr);
 896       warning_buffer.flag = 0;
 897     }
 898 }
 899
 900
 901 /* Issue an error.  */
 902
 903 void
 904 gfc_error (const char *gmsgid, ...)
 905 {
 906   va_list argp;
 907
 908   if (warnings_not_errors)
 909     goto warning;
 910
 911   if (suppress_errors)
 912     return;
 913
 914   error_buffer.flag = 1;
 915   error_buffer.index = 0;
 916   cur_error_buffer = &error_buffer;
 917
 918   va_start (argp, gmsgid);
 919   error_print (_("Error:"), _(gmsgid), argp);
 920   va_end (argp);
 921
 922   error_char ('\0');
 923
 924   if (buffer_flag == 0)
 925     gfc_increment_error_count();
 926
 927   return;
 928
 929 warning:
 930
 931   if (inhibit_warnings)
 932     return;
 933
 934   warning_buffer.flag = 1;
 935   warning_buffer.index = 0;
 936   cur_error_buffer = &warning_buffer;
 937
 938   va_start (argp, gmsgid);
 939   error_print (_("Warning:"), _(gmsgid), argp);
 940   va_end (argp);
 941
 942   error_char ('\0');
 943
 944   if (buffer_flag == 0)
 945   {
 946     warnings++;
 947     if (warnings_are_errors)
 948       gfc_increment_error_count();
 949   }
 950 }
 951
 952
 953 /* Immediate error.  */
 954
 955 void
 956 gfc_error_now (const char *gmsgid, ...)
 957 {
 958   va_list argp;
 959   int i;
 960
 961   error_buffer.flag = 1;
 962   error_buffer.index = 0;
 963   cur_error_buffer = &error_buffer;
 964
 965   i = buffer_flag;
 966   buffer_flag = 0;
 967
 968   va_start (argp, gmsgid);
 969   error_print (_("Error:"), _(gmsgid), argp);
 970   va_end (argp);
 971
 972   error_char ('\0');
 973
 974   gfc_increment_error_count();
 975
 976   buffer_flag = i;
 977
 978   if (flag_fatal_errors)
 979     exit (FATAL_EXIT_CODE);
 980 }
 981
 982
 983 /* Fatal error, never returns.  */
 984
 985 void
 986 gfc_fatal_error (const char *gmsgid, ...)
 987 {
 988   va_list argp;
 989
 990   buffer_flag = 0;
 991
 992   va_start (argp, gmsgid);
 993   error_print (_("Fatal Error:"), _(gmsgid), argp);
 994   va_end (argp);
 995
 996   exit (FATAL_EXIT_CODE);
 997 }
 998
 999
1000 /* This shouldn't happen... but sometimes does.  */
1001
1002 void
1003 gfc_internal_error (const char *format, ...)
1004 {
1005   va_list argp;
1006
1007   buffer_flag = 0;
1008
1009   va_start (argp, format);
1010
1011   show_loci (&gfc_current_locus, NULL);
1012   error_printf ("Internal Error at (1):");
1013
1014   error_print ("", format, argp);
1015   va_end (argp);
1016
1017   exit (ICE_EXIT_CODE);
1018 }
1019
1020
1021 /* Clear the error flag when we start to compile a source line.  */
1022
1023 void
1024 gfc_clear_error (void)
1025 {
1026   error_buffer.flag = 0;
1027   warnings_not_errors = 0;
1028 }
1029
1030
1031 /* Tests the state of error_flag.  */
1032
1033 int
1034 gfc_error_flag_test (void)
1035 {
1036   return error_buffer.flag;
1037 }
1038
1039
1040 /* Check to see if any errors have been saved.
1041    If so, print the error.  Returns the state of error_flag.  */
1042
1043 int
1044 gfc_error_check (void)
1045 {
1046   int rc;
1047
1048   rc = error_buffer.flag;
1049
1050   if (error_buffer.flag)
1051     {
1052       if (error_buffer.message != NULL)
1053         fputs (error_buffer.message, stderr);
1054       error_buffer.flag = 0;
1055
1056       gfc_increment_error_count();
1057
1058       if (flag_fatal_errors)
1059         exit (FATAL_EXIT_CODE);
1060     }
1061
1062   return rc;
1063 }
1064
1065
1066 /* Save the existing error state.  */
1067
1068 void
1069 gfc_push_error (gfc_error_buf *err)
1070 {
1071   err->flag = error_buffer.flag;
1072   if (error_buffer.flag)
1073     err->message = xstrdup (error_buffer.message);
1074
1075   error_buffer.flag = 0;
1076 }
1077
1078
1079 /* Restore a previous pushed error state.  */
1080
1081 void
1082 gfc_pop_error (gfc_error_buf *err)
1083 {
1084   error_buffer.flag = err->flag;
1085   if (error_buffer.flag)
1086     {
1087       size_t len = strlen (err->message) + 1;
1088       gcc_assert (len <= error_buffer.allocated);
1089       memcpy (error_buffer.message, err->message, len);
1090       free (err->message);
1091     }
1092 }
1093
1094
1095 /* Free a pushed error state, but keep the current error state.  */
1096
1097 void
1098 gfc_free_error (gfc_error_buf *err)
1099 {
1100   if (err->flag)
1101     free (err->message);
1102 }
1103
1104
1105 /* Report the number of warnings and errors that occurred to the caller.  */
1106
1107 void
1108 gfc_get_errors (int *w, int *e)
1109 {
1110   if (w != NULL)
1111     *w = warnings;
1112   if (e != NULL)
1113     *e = errors;
1114 }
1115
1116
1117 /* Switch errors into warnings.  */
1118
1119 void
1120 gfc_errors_to_warnings (int f)
1121 {
1122   warnings_not_errors = (f == 1) ? 1 : 0;
1123 }