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