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   /* When the loci is not associated with a column, it will have a
 311      value of zero.  We adjust this to 1 so that it will appear.  */
 312
 313   if (c1 == 0)
 314     c1 = 1;
 315   if (c2 == 0)
 316     c2 = 1;
 317
 318   /* If the two loci would appear in the same column, we shift
 319      '2' one column to the right, so as to print '12' rather than
 320      just '1'.  We do this here so it will be accounted for in the
 321      margin calculations.  */
 322
 323   if (c1 == c2)
 324     c2 += 1;
 325
 326   cmax = (c1 < c2) ? c2 : c1;
 327   if (cmax > terminal_width - 5)
 328     offset = cmax - terminal_width + 5;
 329
 330   /* Show the line itself, taking care not to print more than what can
 331      show up on the terminal.  Tabs are converted to spaces, and
 332      nonprintable characters are converted to a "\xNN" sequence.  */
 333
 334   /* TODO: Although setting i to the terminal width is clever, it fails
 335      to work correctly when nonprintable characters exist.  A better
 336      solution should be found.  */
 337
 338   p = &(lb->line[offset]);
 339   i = gfc_wide_strlen (p);
 340   if (i > terminal_width)
 341     i = terminal_width - 1;
 342
 343   for (; i > 0; i--)
 344     {
 345       static char buffer[11];
 346
 347       c = *p++;
 348       if (c == '\t')
 349         c = ' ';
 350
 351       print_wide_char_into_buffer (c, buffer);
 352       error_string (buffer);
 353     }
 354
 355   error_char ('\n');
 356
 357   /* Show the '1' and/or '2' corresponding to the column of the error
 358      locus.  Note that a value of -1 for c1 or c2 will simply cause
 359      the relevant number not to be printed.  */
 360
 361   c1 -= offset;
 362   c2 -= offset;
 363
 364   for (i = 1; i <= cmax; i++)
 365     {
 366       if (i == c1)
 367         error_char ('1');
 368       else if (i == c2)
 369         error_char ('2');
 370       else
 371         error_char (' ');
 372     }
 373
 374   error_char ('\n');
 375
 376 }
 377
 378
 379 /* As part of printing an error, we show the source lines that caused
 380    the problem.  We show at least one, and possibly two loci; the two
 381    loci may or may not be on the same source line.  */
 382
 383 static void
 384 show_loci (locus *l1, locus *l2)
 385 {
 386   int m, c1, c2;
 387
 388   if (l1 == NULL || l1->lb == NULL)
 389     {
 390       error_printf ("<During initialization>\n");
 391       return;
 392     }
 393
 394   /* While calculating parameters for printing the loci, we consider possible
 395      reasons for printing one per line.  If appropriate, print the loci
 396      individually; otherwise we print them both on the same line.  */
 397
 398   c1 = l1->nextc - l1->lb->line;
 399   if (l2 == NULL)
 400     {
 401       show_locus (l1, c1, -1);
 402       return;
 403     }
 404
 405   c2 = l2->nextc - l2->lb->line;
 406
 407   if (c1 < c2)
 408     m = c2 - c1;
 409   else
 410     m = c1 - c2;
 411
 412   /* Note that the margin value of 10 here needs to be less than the
 413      margin of 5 used in the calculation of offset in show_locus.  */
 414
 415   if (l1->lb != l2->lb || m > terminal_width - 10)
 416     {
 417       show_locus (l1, c1, -1);
 418       show_locus (l2, -1, c2);
 419       return;
 420     }
 421
 422   show_locus (l1, c1, c2);
 423
 424   return;
 425 }
 426
 427
 428 /* Workhorse for the error printing subroutines.  This subroutine is
 429    inspired by g77's error handling and is similar to printf() with
 430    the following %-codes:
 431
 432    %c Character, %d or %i Integer, %s String, %% Percent
 433    %L  Takes locus argument
 434    %C  Current locus (no argument)
 435
 436    If a locus pointer is given, the actual source line is printed out
 437    and the column is indicated.  Since we want the error message at
 438    the bottom of any source file information, we must scan the
 439    argument list twice -- once to determine whether the loci are
 440    present and record this for printing, and once to print the error
 441    message after and loci have been printed.  A maximum of two locus
 442    arguments are permitted.
 443
 444    This function is also called (recursively) by show_locus in the
 445    case of included files; however, as show_locus does not resupply
 446    any loci, the recursion is at most one level deep.  */
 447
 448 #define MAX_ARGS 10
 449
 450 static void ATTRIBUTE_GCC_GFC(2,0)
 451 error_print (const char *type, const char *format0, va_list argp)
 452 {
 453   enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER,
 454          TYPE_LONGINT, TYPE_ULONGINT, TYPE_CHAR, TYPE_STRING,
 455          NOTYPE };
 456   struct
 457   {
 458     int type;
 459     int pos;
 460     union
 461     {
 462       int intval;
 463       unsigned int uintval;
 464       long int longintval;
 465       unsigned long int ulongintval;
 466       char charval;
 467       const char * stringval;
 468     } u;
 469   } arg[MAX_ARGS], spec[MAX_ARGS];
 470   /* spec is the array of specifiers, in the same order as they
 471      appear in the format string.  arg is the array of arguments,
 472      in the same order as they appear in the va_list.  */
 473
 474   char c;
 475   int i, n, have_l1, pos, maxpos;
 476   locus *l1, *l2, *loc;
 477   const char *format;
 478
 479   l1 = l2 = NULL;
 480
 481   have_l1 = 0;
 482   pos = -1;
 483   maxpos = -1;
 484
 485   n = 0;
 486   format = format0;
 487
 488   for (i = 0; i < MAX_ARGS; i++)
 489     {
 490       arg[i].type = NOTYPE;
 491       spec[i].pos = -1;
 492     }
 493
 494   /* First parse the format string for position specifiers.  */
 495   while (*format)
 496     {
 497       c = *format++;
 498       if (c != '%')
 499         continue;
 500
 501       if (*format == '%')
 502         {
 503           format++;
 504           continue;
 505         }
 506
 507       if (ISDIGIT (*format))
 508         {
 509           /* This is a position specifier.  For example, the number
 510              12 in the format string "%12$d", which specifies the third
 511              argument of the va_list, formatted in %d format.
 512              For details, see "man 3 printf".  */
 513           pos = atoi(format) - 1;
 514           gcc_assert (pos >= 0);
 515           while (ISDIGIT(*format))
 516             format++;
 517           gcc_assert (*format++ == '$');
 518         }
 519       else
 520         pos++;
 521
 522       c = *format++;
 523
 524       if (pos > maxpos)
 525         maxpos = pos;
 526
 527       switch (c)
 528         {
 529           case 'C':
 530             arg[pos].type = TYPE_CURRENTLOC;
 531             break;
 532
 533           case 'L':
 534             arg[pos].type = TYPE_LOCUS;
 535             break;
 536
 537           case 'd':
 538           case 'i':
 539             arg[pos].type = TYPE_INTEGER;
 540             break;
 541
 542           case 'u':
 543             arg[pos].type = TYPE_UINTEGER;
 544
 545           case 'l':
 546             c = *format++;
 547             if (c == 'u')
 548               arg[pos].type = TYPE_ULONGINT;
 549             else if (c == 'i' || c == 'd')
 550               arg[pos].type = TYPE_LONGINT;
 551             else
 552               gcc_unreachable ();
 553             break;
 554
 555           case 'c':
 556             arg[pos].type = TYPE_CHAR;
 557             break;
 558
 559           case 's':
 560             arg[pos].type = TYPE_STRING;
 561             break;
 562
 563           default:
 564             gcc_unreachable ();
 565         }
 566
 567       spec[n++].pos = pos;
 568     }
 569
 570   /* Then convert the values for each %-style argument.  */
 571   for (pos = 0; pos <= maxpos; pos++)
 572     {
 573       gcc_assert (arg[pos].type != NOTYPE);
 574       switch (arg[pos].type)
 575         {
 576           case TYPE_CURRENTLOC:
 577             loc = &gfc_current_locus;
 578             /* Fall through.  */
 579
 580           case TYPE_LOCUS:
 581             if (arg[pos].type == TYPE_LOCUS)
 582               loc = va_arg (argp, locus *);
 583
 584             if (have_l1)
 585               {
 586                 l2 = loc;
 587                 arg[pos].u.stringval = "(2)";
 588               }
 589             else
 590               {
 591                 l1 = loc;
 592                 have_l1 = 1;
 593                 arg[pos].u.stringval = "(1)";
 594               }
 595             break;
 596
 597           case TYPE_INTEGER:
 598             arg[pos].u.intval = va_arg (argp, int);
 599             break;
 600
 601           case TYPE_UINTEGER:
 602             arg[pos].u.uintval = va_arg (argp, unsigned int);
 603             break;
 604
 605           case TYPE_LONGINT:
 606             arg[pos].u.longintval = va_arg (argp, long int);
 607             break;
 608
 609           case TYPE_ULONGINT:
 610             arg[pos].u.ulongintval = va_arg (argp, unsigned long int);
 611             break;
 612
 613           case TYPE_CHAR:
 614             arg[pos].u.charval = (char) va_arg (argp, int);
 615             break;
 616
 617           case TYPE_STRING:
 618             arg[pos].u.stringval = (const char *) va_arg (argp, char *);
 619             break;
 620
 621           default:
 622             gcc_unreachable ();
 623         }
 624     }
 625
 626   for (n = 0; spec[n].pos >= 0; n++)
 627     spec[n].u = arg[spec[n].pos].u;
 628
 629   /* Show the current loci if we have to.  */
 630   if (have_l1)
 631     show_loci (l1, l2);
 632
 633   if (*type)
 634     {
 635       error_string (type);
 636       error_char (' ');
 637     }
 638
 639   have_l1 = 0;
 640   format = format0;
 641   n = 0;
 642
 643   for (; *format; format++)
 644     {
 645       if (*format != '%')
 646         {
 647           error_char (*format);
 648           continue;
 649         }
 650
 651       format++;
 652       if (ISDIGIT (*format))
 653         {
 654           /* This is a position specifier.  See comment above.  */
 655           while (ISDIGIT (*format))
 656             format++;
 657
 658           /* Skip over the dollar sign.  */
 659           format++;
 660         }
 661
 662       switch (*format)
 663         {
 664         case '%':
 665           error_char ('%');
 666           break;
 667
 668         case 'c':
 669           error_char (spec[n++].u.charval);
 670           break;
 671
 672         case 's':
 673         case 'C':               /* Current locus */
 674         case 'L':               /* Specified locus */
 675           error_string (spec[n++].u.stringval);
 676           break;
 677
 678         case 'd':
 679         case 'i':
 680           error_integer (spec[n++].u.intval);
 681           break;
 682
 683         case 'u':
 684           error_uinteger (spec[n++].u.uintval);
 685           break;
 686
 687         case 'l':
 688           format++;
 689           if (*format == 'u')
 690             error_uinteger (spec[n++].u.ulongintval);
 691           else
 692             error_integer (spec[n++].u.longintval);
 693           break;
 694
 695         }
 696     }
 697
 698   error_char ('\n');
 699 }
 700
 701
 702 /* Wrapper for error_print().  */
 703
 704 static void
 705 error_printf (const char *nocmsgid, ...)
 706 {
 707   va_list argp;
 708
 709   va_start (argp, nocmsgid);
 710   error_print ("", _(nocmsgid), argp);
 711   va_end (argp);
 712 }
 713
 714
 715 /* Increment the number of errors, and check whether too many have
 716    been printed.  */
 717
 718 static void
 719 gfc_increment_error_count (void)
 720 {
 721   errors++;
 722   if ((gfc_option.max_errors != 0) && (errors >= gfc_option.max_errors))
 723     gfc_fatal_error ("Error count reached limit of %d.", gfc_option.max_errors);
 724 }
 725
 726
 727 /* Issue a warning.  */
 728
 729 void
 730 gfc_warning (const char *nocmsgid, ...)
 731 {
 732   va_list argp;
 733
 734   if (inhibit_warnings)
 735     return;
 736
 737   warning_buffer.flag = 1;
 738   warning_buffer.index = 0;
 739   cur_error_buffer = &warning_buffer;
 740
 741   va_start (argp, nocmsgid);
 742   error_print (_("Warning:"), _(nocmsgid), argp);
 743   va_end (argp);
 744
 745   error_char ('\0');
 746
 747   if (buffer_flag == 0)
 748   {
 749     warnings++;
 750     if (warnings_are_errors)
 751       gfc_increment_error_count();
 752   }
 753 }
 754
 755
 756 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 757    we should issue an error or a warning, or be quiet.  */
 758
 759 notification
 760 gfc_notification_std (int std)
 761 {
 762   bool warning;
 763
 764   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 765   if ((gfc_option.allow_std & std) != 0 && !warning)
 766     return SILENT;
 767
 768   return warning ? WARNING : ERROR;
 769 }
 770
 771
 772 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 773    feature.  An error/warning will be issued if the currently selected
 774    standard does not contain the requested bits.  Return FAILURE if
 775    an error is generated.  */
 776
 777 gfc_try
 778 gfc_notify_std (int std, const char *nocmsgid, ...)
 779 {
 780   va_list argp;
 781   bool warning;
 782
 783   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 784   if ((gfc_option.allow_std & std) != 0 && !warning)
 785     return SUCCESS;
 786
 787   if (suppress_errors)
 788     return warning ? SUCCESS : FAILURE;
 789
 790   cur_error_buffer = warning ? &warning_buffer : &error_buffer;
 791   cur_error_buffer->flag = 1;
 792   cur_error_buffer->index = 0;
 793
 794   va_start (argp, nocmsgid);
 795   if (warning)
 796     error_print (_("Warning:"), _(nocmsgid), argp);
 797   else
 798     error_print (_("Error:"), _(nocmsgid), argp);
 799   va_end (argp);
 800
 801   error_char ('\0');
 802
 803   if (buffer_flag == 0)
 804     {
 805       if (warning && !warnings_are_errors)
 806         warnings++;
 807       else
 808         gfc_increment_error_count();
 809     }
 810
 811   return (warning && !warnings_are_errors) ? SUCCESS : FAILURE;
 812 }
 813
 814
 815 /* Immediate warning (i.e. do not buffer the warning).  */
 816
 817 void
 818 gfc_warning_now (const char *nocmsgid, ...)
 819 {
 820   va_list argp;
 821   int i;
 822
 823   if (inhibit_warnings)
 824     return;
 825
 826   i = buffer_flag;
 827   buffer_flag = 0;
 828   warnings++;
 829   if (warnings_are_errors)
 830     gfc_increment_error_count();
 831
 832   va_start (argp, nocmsgid);
 833   error_print (_("Warning:"), _(nocmsgid), argp);
 834   va_end (argp);
 835
 836   error_char ('\0');
 837   buffer_flag = i;
 838 }
 839
 840
 841 /* Clear the warning flag.  */
 842
 843 void
 844 gfc_clear_warning (void)
 845 {
 846   warning_buffer.flag = 0;
 847 }
 848
 849
 850 /* Check to see if any warnings have been saved.
 851    If so, print the warning.  */
 852
 853 void
 854 gfc_warning_check (void)
 855 {
 856   if (warning_buffer.flag)
 857     {
 858       warnings++;
 859       if (warning_buffer.message != NULL)
 860         fputs (warning_buffer.message, stderr);
 861       warning_buffer.flag = 0;
 862     }
 863 }
 864
 865
 866 /* Issue an error.  */
 867
 868 void
 869 gfc_error (const char *nocmsgid, ...)
 870 {
 871   va_list argp;
 872
 873   if (suppress_errors)
 874     return;
 875
 876   error_buffer.flag = 1;
 877   error_buffer.index = 0;
 878   cur_error_buffer = &error_buffer;
 879
 880   va_start (argp, nocmsgid);
 881   error_print (_("Error:"), _(nocmsgid), argp);
 882   va_end (argp);
 883
 884   error_char ('\0');
 885
 886   if (buffer_flag == 0)
 887     gfc_increment_error_count();
 888 }
 889
 890
 891 /* Immediate error.  */
 892
 893 void
 894 gfc_error_now (const char *nocmsgid, ...)
 895 {
 896   va_list argp;
 897   int i;
 898
 899   error_buffer.flag = 1;
 900   error_buffer.index = 0;
 901   cur_error_buffer = &error_buffer;
 902
 903   i = buffer_flag;
 904   buffer_flag = 0;
 905
 906   va_start (argp, nocmsgid);
 907   error_print (_("Error:"), _(nocmsgid), argp);
 908   va_end (argp);
 909
 910   error_char ('\0');
 911
 912   gfc_increment_error_count();
 913
 914   buffer_flag = i;
 915
 916   if (flag_fatal_errors)
 917     exit (1);
 918 }
 919
 920
 921 /* Fatal error, never returns.  */
 922
 923 void
 924 gfc_fatal_error (const char *nocmsgid, ...)
 925 {
 926   va_list argp;
 927
 928   buffer_flag = 0;
 929
 930   va_start (argp, nocmsgid);
 931   error_print (_("Fatal Error:"), _(nocmsgid), argp);
 932   va_end (argp);
 933
 934   exit (3);
 935 }
 936
 937
 938 /* This shouldn't happen... but sometimes does.  */
 939
 940 void
 941 gfc_internal_error (const char *format, ...)
 942 {
 943   va_list argp;
 944
 945   buffer_flag = 0;
 946
 947   va_start (argp, format);
 948
 949   show_loci (&gfc_current_locus, NULL);
 950   error_printf ("Internal Error at (1):");
 951
 952   error_print ("", format, argp);
 953   va_end (argp);
 954
 955   exit (ICE_EXIT_CODE);
 956 }
 957
 958
 959 /* Clear the error flag when we start to compile a source line.  */
 960
 961 void
 962 gfc_clear_error (void)
 963 {
 964   error_buffer.flag = 0;
 965 }
 966
 967
 968 /* Tests the state of error_flag.  */
 969
 970 int
 971 gfc_error_flag_test (void)
 972 {
 973   return error_buffer.flag;
 974 }
 975
 976
 977 /* Check to see if any errors have been saved.
 978    If so, print the error.  Returns the state of error_flag.  */
 979
 980 int
 981 gfc_error_check (void)
 982 {
 983   int rc;
 984
 985   rc = error_buffer.flag;
 986
 987   if (error_buffer.flag)
 988     {
 989       if (error_buffer.message != NULL)
 990         fputs (error_buffer.message, stderr);
 991       error_buffer.flag = 0;
 992
 993       gfc_increment_error_count();
 994
 995       if (flag_fatal_errors)
 996         exit (1);
 997     }
 998
 999   return rc;
1000 }
1001
1002
1003 /* Save the existing error state.  */
1004
1005 void
1006 gfc_push_error (gfc_error_buf *err)
1007 {
1008   err->flag = error_buffer.flag;
1009   if (error_buffer.flag)
1010     err->message = xstrdup (error_buffer.message);
1011
1012   error_buffer.flag = 0;
1013 }
1014
1015
1016 /* Restore a previous pushed error state.  */
1017
1018 void
1019 gfc_pop_error (gfc_error_buf *err)
1020 {
1021   error_buffer.flag = err->flag;
1022   if (error_buffer.flag)
1023     {
1024       size_t len = strlen (err->message) + 1;
1025       gcc_assert (len <= error_buffer.allocated);
1026       memcpy (error_buffer.message, err->message, len);
1027       gfc_free (err->message);
1028     }
1029 }
1030
1031
1032 /* Free a pushed error state, but keep the current error state.  */
1033
1034 void
1035 gfc_free_error (gfc_error_buf *err)
1036 {
1037   if (err->flag)
1038     gfc_free (err->message);
1039 }
1040
1041
1042 /* Report the number of warnings and errors that occurred to the caller.  */
1043
1044 void
1045 gfc_get_errors (int *w, int *e)
1046 {
1047   if (w != NULL)
1048     *w = warnings;
1049   if (e != NULL)
1050     *e = errors;
1051 }