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