gcc/fortran/error.c

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