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