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