gcc/fortran/error.c

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