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
 537           case 'l':
 538             c = *format++;
 539             if (c == 'u')
 540               arg[pos].type = TYPE_ULONGINT;
 541             else if (c == 'i' || c == 'd')
 542               arg[pos].type = TYPE_LONGINT;
 543             else
 544               gcc_unreachable ();
 545             break;
 546
 547           case 'c':
 548             arg[pos].type = TYPE_CHAR;
 549             break;
 550
 551           case 's':
 552             arg[pos].type = TYPE_STRING;
 553             break;
 554
 555           default:
 556             gcc_unreachable ();
 557         }
 558
 559       spec[n++].pos = pos;
 560     }
 561
 562   /* Then convert the values for each %-style argument.  */
 563   for (pos = 0; pos <= maxpos; pos++)
 564     {
 565       gcc_assert (arg[pos].type != NOTYPE);
 566       switch (arg[pos].type)
 567         {
 568           case TYPE_CURRENTLOC:
 569             loc = &gfc_current_locus;
 570             /* Fall through.  */
 571
 572           case TYPE_LOCUS:
 573             if (arg[pos].type == TYPE_LOCUS)
 574               loc = va_arg (argp, locus *);
 575
 576             if (have_l1)
 577               {
 578                 l2 = loc;
 579                 arg[pos].u.stringval = "(2)";
 580               }
 581             else
 582               {
 583                 l1 = loc;
 584                 have_l1 = 1;
 585                 arg[pos].u.stringval = "(1)";
 586               }
 587             break;
 588
 589           case TYPE_INTEGER:
 590             arg[pos].u.intval = va_arg (argp, int);
 591             break;
 592
 593           case TYPE_UINTEGER:
 594             arg[pos].u.uintval = va_arg (argp, unsigned int);
 595             break;
 596
 597           case TYPE_LONGINT:
 598             arg[pos].u.longintval = va_arg (argp, long int);
 599             break;
 600
 601           case TYPE_ULONGINT:
 602             arg[pos].u.ulongintval = va_arg (argp, unsigned long int);
 603             break;
 604
 605           case TYPE_CHAR:
 606             arg[pos].u.charval = (char) va_arg (argp, int);
 607             break;
 608
 609           case TYPE_STRING:
 610             arg[pos].u.stringval = (const char *) va_arg (argp, char *);
 611             break;
 612
 613           default:
 614             gcc_unreachable ();
 615         }
 616     }
 617
 618   for (n = 0; spec[n].pos >= 0; n++)
 619     spec[n].u = arg[spec[n].pos].u;
 620
 621   /* Show the current loci if we have to.  */
 622   if (have_l1)
 623     show_loci (l1, l2);
 624
 625   if (*type)
 626     {
 627       error_string (type);
 628       error_char (' ');
 629     }
 630
 631   have_l1 = 0;
 632   format = format0;
 633   n = 0;
 634
 635   for (; *format; format++)
 636     {
 637       if (*format != '%')
 638         {
 639           error_char (*format);
 640           continue;
 641         }
 642
 643       format++;
 644       if (ISDIGIT (*format))
 645         {
 646           /* This is a position specifier.  See comment above.  */
 647           while (ISDIGIT (*format))
 648             format++;
 649
 650           /* Skip over the dollar sign.  */
 651           format++;
 652         }
 653
 654       switch (*format)
 655         {
 656         case '%':
 657           error_char ('%');
 658           break;
 659
 660         case 'c':
 661           error_char (spec[n++].u.charval);
 662           break;
 663
 664         case 's':
 665         case 'C':               /* Current locus */
 666         case 'L':               /* Specified locus */
 667           error_string (spec[n++].u.stringval);
 668           break;
 669
 670         case 'd':
 671         case 'i':
 672           error_integer (spec[n++].u.intval);
 673           break;
 674
 675         case 'u':
 676           error_uinteger (spec[n++].u.uintval);
 677           break;
 678
 679         case 'l':
 680           format++;
 681           if (*format == 'u')
 682             error_uinteger (spec[n++].u.ulongintval);
 683           else
 684             error_integer (spec[n++].u.longintval);
 685           break;
 686
 687         }
 688     }
 689
 690   error_char ('\n');
 691 }
 692
 693
 694 /* Wrapper for error_print().  */
 695
 696 static void
 697 error_printf (const char *nocmsgid, ...)
 698 {
 699   va_list argp;
 700
 701   va_start (argp, nocmsgid);
 702   error_print ("", _(nocmsgid), argp);
 703   va_end (argp);
 704 }
 705
 706
 707 /* Increment the number of errors, and check whether too many have
 708    been printed.  */
 709
 710 static void
 711 gfc_increment_error_count (void)
 712 {
 713   errors++;
 714   if ((gfc_option.max_errors != 0) && (errors >= gfc_option.max_errors))
 715     gfc_fatal_error ("Error count reached limit of %d.", gfc_option.max_errors);
 716 }
 717
 718
 719 /* Issue a warning.  */
 720
 721 void
 722 gfc_warning (const char *nocmsgid, ...)
 723 {
 724   va_list argp;
 725
 726   if (inhibit_warnings)
 727     return;
 728
 729   warning_buffer.flag = 1;
 730   warning_buffer.index = 0;
 731   cur_error_buffer = &warning_buffer;
 732
 733   va_start (argp, nocmsgid);
 734   error_print (_("Warning:"), _(nocmsgid), argp);
 735   va_end (argp);
 736
 737   error_char ('\0');
 738
 739   if (buffer_flag == 0)
 740   {
 741     warnings++;
 742     if (warnings_are_errors)
 743       gfc_increment_error_count();
 744   }
 745 }
 746
 747
 748 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 749    we should issue an error or a warning, or be quiet.  */
 750
 751 notification
 752 gfc_notification_std (int std)
 753 {
 754   bool warning;
 755
 756   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 757   if ((gfc_option.allow_std & std) != 0 && !warning)
 758     return SILENT;
 759
 760   return warning ? WARNING : ERROR;
 761 }
 762
 763
 764 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 765    feature.  An error/warning will be issued if the currently selected
 766    standard does not contain the requested bits.  Return FAILURE if
 767    an error is generated.  */
 768
 769 gfc_try
 770 gfc_notify_std (int std, const char *nocmsgid, ...)
 771 {
 772   va_list argp;
 773   bool warning;
 774
 775   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 776   if ((gfc_option.allow_std & std) != 0 && !warning)
 777     return SUCCESS;
 778
 779   if (suppress_errors)
 780     return warning ? SUCCESS : FAILURE;
 781
 782   cur_error_buffer = warning ? &warning_buffer : &error_buffer;
 783   cur_error_buffer->flag = 1;
 784   cur_error_buffer->index = 0;
 785
 786   va_start (argp, nocmsgid);
 787   if (warning)
 788     error_print (_("Warning:"), _(nocmsgid), argp);
 789   else
 790     error_print (_("Error:"), _(nocmsgid), argp);
 791   va_end (argp);
 792
 793   error_char ('\0');
 794
 795   if (buffer_flag == 0)
 796     {
 797       if (warning && !warnings_are_errors)
 798         warnings++;
 799       else
 800         gfc_increment_error_count();
 801     }
 802
 803   return (warning && !warnings_are_errors) ? SUCCESS : FAILURE;
 804 }
 805
 806
 807 /* Immediate warning (i.e. do not buffer the warning).  */
 808
 809 void
 810 gfc_warning_now (const char *nocmsgid, ...)
 811 {
 812   va_list argp;
 813   int i;
 814
 815   if (inhibit_warnings)
 816     return;
 817
 818   i = buffer_flag;
 819   buffer_flag = 0;
 820   warnings++;
 821   if (warnings_are_errors)
 822     gfc_increment_error_count();
 823
 824   va_start (argp, nocmsgid);
 825   error_print (_("Warning:"), _(nocmsgid), argp);
 826   va_end (argp);
 827
 828   error_char ('\0');
 829   buffer_flag = i;
 830 }
 831
 832
 833 /* Clear the warning flag.  */
 834
 835 void
 836 gfc_clear_warning (void)
 837 {
 838   warning_buffer.flag = 0;
 839 }
 840
 841
 842 /* Check to see if any warnings have been saved.
 843    If so, print the warning.  */
 844
 845 void
 846 gfc_warning_check (void)
 847 {
 848   if (warning_buffer.flag)
 849     {
 850       warnings++;
 851       if (warning_buffer.message != NULL)
 852         fputs (warning_buffer.message, stderr);
 853       warning_buffer.flag = 0;
 854     }
 855 }
 856
 857
 858 /* Issue an error.  */
 859
 860 void
 861 gfc_error (const char *nocmsgid, ...)
 862 {
 863   va_list argp;
 864
 865   if (suppress_errors)
 866     return;
 867
 868   error_buffer.flag = 1;
 869   error_buffer.index = 0;
 870   cur_error_buffer = &error_buffer;
 871
 872   va_start (argp, nocmsgid);
 873   error_print (_("Error:"), _(nocmsgid), argp);
 874   va_end (argp);
 875
 876   error_char ('\0');
 877
 878   if (buffer_flag == 0)
 879     gfc_increment_error_count();
 880 }
 881
 882
 883 /* Immediate error.  */
 884
 885 void
 886 gfc_error_now (const char *nocmsgid, ...)
 887 {
 888   va_list argp;
 889   int i;
 890
 891   error_buffer.flag = 1;
 892   error_buffer.index = 0;
 893   cur_error_buffer = &error_buffer;
 894
 895   i = buffer_flag;
 896   buffer_flag = 0;
 897
 898   va_start (argp, nocmsgid);
 899   error_print (_("Error:"), _(nocmsgid), argp);
 900   va_end (argp);
 901
 902   error_char ('\0');
 903
 904   gfc_increment_error_count();
 905
 906   buffer_flag = i;
 907
 908   if (flag_fatal_errors)
 909     exit (1);
 910 }
 911
 912
 913 /* Fatal error, never returns.  */
 914
 915 void
 916 gfc_fatal_error (const char *nocmsgid, ...)
 917 {
 918   va_list argp;
 919
 920   buffer_flag = 0;
 921
 922   va_start (argp, nocmsgid);
 923   error_print (_("Fatal Error:"), _(nocmsgid), argp);
 924   va_end (argp);
 925
 926   exit (3);
 927 }
 928
 929
 930 /* This shouldn't happen... but sometimes does.  */
 931
 932 void
 933 gfc_internal_error (const char *format, ...)
 934 {
 935   va_list argp;
 936
 937   buffer_flag = 0;
 938
 939   va_start (argp, format);
 940
 941   show_loci (&gfc_current_locus, NULL);
 942   error_printf ("Internal Error at (1):");
 943
 944   error_print ("", format, argp);
 945   va_end (argp);
 946
 947   exit (ICE_EXIT_CODE);
 948 }
 949
 950
 951 /* Clear the error flag when we start to compile a source line.  */
 952
 953 void
 954 gfc_clear_error (void)
 955 {
 956   error_buffer.flag = 0;
 957 }
 958
 959
 960 /* Tests the state of error_flag.  */
 961
 962 int
 963 gfc_error_flag_test (void)
 964 {
 965   return error_buffer.flag;
 966 }
 967
 968
 969 /* Check to see if any errors have been saved.
 970    If so, print the error.  Returns the state of error_flag.  */
 971
 972 int
 973 gfc_error_check (void)
 974 {
 975   int rc;
 976
 977   rc = error_buffer.flag;
 978
 979   if (error_buffer.flag)
 980     {
 981       if (error_buffer.message != NULL)
 982         fputs (error_buffer.message, stderr);
 983       error_buffer.flag = 0;
 984
 985       gfc_increment_error_count();
 986
 987       if (flag_fatal_errors)
 988         exit (1);
 989     }
 990
 991   return rc;
 992 }
 993
 994
 995 /* Save the existing error state.  */
 996
 997 void
 998 gfc_push_error (gfc_error_buf *err)
 999 {
1000   err->flag = error_buffer.flag;
1001   if (error_buffer.flag)
1002     err->message = xstrdup (error_buffer.message);
1003
1004   error_buffer.flag = 0;
1005 }
1006
1007
1008 /* Restore a previous pushed error state.  */
1009
1010 void
1011 gfc_pop_error (gfc_error_buf *err)
1012 {
1013   error_buffer.flag = err->flag;
1014   if (error_buffer.flag)
1015     {
1016       size_t len = strlen (err->message) + 1;
1017       gcc_assert (len <= error_buffer.allocated);
1018       memcpy (error_buffer.message, err->message, len);
1019       gfc_free (err->message);
1020     }
1021 }
1022
1023
1024 /* Free a pushed error state, but keep the current error state.  */
1025
1026 void
1027 gfc_free_error (gfc_error_buf *err)
1028 {
1029   if (err->flag)
1030     gfc_free (err->message);
1031 }
1032
1033
1034 /* Report the number of warnings and errors that occurred to the caller.  */
1035
1036 void
1037 gfc_get_errors (int *w, int *e)
1038 {
1039   if (w != NULL)
1040     *w = warnings;
1041   if (e != NULL)
1042     *e = errors;
1043 }