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
 825   va_start (argp, nocmsgid);
 826   error_print (_("Warning:"), _(nocmsgid), argp);
 827   va_end (argp);
 828
 829   error_char ('\0');
 830
 831   if (warnings_are_errors)
 832     gfc_increment_error_count();
 833
 834   buffer_flag = i;
 835 }
 836
 837
 838 /* Clear the warning flag.  */
 839
 840 void
 841 gfc_clear_warning (void)
 842 {
 843   warning_buffer.flag = 0;
 844 }
 845
 846
 847 /* Check to see if any warnings have been saved.
 848    If so, print the warning.  */
 849
 850 void
 851 gfc_warning_check (void)
 852 {
 853   if (warning_buffer.flag)
 854     {
 855       warnings++;
 856       if (warning_buffer.message != NULL)
 857         fputs (warning_buffer.message, stderr);
 858       warning_buffer.flag = 0;
 859     }
 860 }
 861
 862
 863 /* Issue an error.  */
 864
 865 void
 866 gfc_error (const char *nocmsgid, ...)
 867 {
 868   va_list argp;
 869
 870   if (warnings_not_errors)
 871     goto warning;
 872
 873   if (suppress_errors)
 874     return;
 875
 876   error_buffer.flag = 1;
 877   error_buffer.index = 0;
 878   cur_error_buffer = &error_buffer;
 879
 880   va_start (argp, nocmsgid);
 881   error_print (_("Error:"), _(nocmsgid), argp);
 882   va_end (argp);
 883
 884   error_char ('\0');
 885
 886   if (buffer_flag == 0)
 887     gfc_increment_error_count();
 888
 889   return;
 890
 891 warning:
 892
 893   if (inhibit_warnings)
 894     return;
 895
 896   warning_buffer.flag = 1;
 897   warning_buffer.index = 0;
 898   cur_error_buffer = &warning_buffer;
 899
 900   va_start (argp, nocmsgid);
 901   error_print (_("Warning:"), _(nocmsgid), argp);
 902   va_end (argp);
 903
 904   error_char ('\0');
 905
 906   if (buffer_flag == 0)
 907   {
 908     warnings++;
 909     if (warnings_are_errors)
 910       gfc_increment_error_count();
 911   }
 912 }
 913
 914
 915 /* Immediate error.  */
 916
 917 void
 918 gfc_error_now (const char *nocmsgid, ...)
 919 {
 920   va_list argp;
 921   int i;
 922
 923   error_buffer.flag = 1;
 924   error_buffer.index = 0;
 925   cur_error_buffer = &error_buffer;
 926
 927   i = buffer_flag;
 928   buffer_flag = 0;
 929
 930   va_start (argp, nocmsgid);
 931   error_print (_("Error:"), _(nocmsgid), argp);
 932   va_end (argp);
 933
 934   error_char ('\0');
 935
 936   gfc_increment_error_count();
 937
 938   buffer_flag = i;
 939
 940   if (flag_fatal_errors)
 941     exit (1);
 942 }
 943
 944
 945 /* Fatal error, never returns.  */
 946
 947 void
 948 gfc_fatal_error (const char *nocmsgid, ...)
 949 {
 950   va_list argp;
 951
 952   buffer_flag = 0;
 953
 954   va_start (argp, nocmsgid);
 955   error_print (_("Fatal Error:"), _(nocmsgid), argp);
 956   va_end (argp);
 957
 958   exit (3);
 959 }
 960
 961
 962 /* This shouldn't happen... but sometimes does.  */
 963
 964 void
 965 gfc_internal_error (const char *format, ...)
 966 {
 967   va_list argp;
 968
 969   buffer_flag = 0;
 970
 971   va_start (argp, format);
 972
 973   show_loci (&gfc_current_locus, NULL);
 974   error_printf ("Internal Error at (1):");
 975
 976   error_print ("", format, argp);
 977   va_end (argp);
 978
 979   exit (ICE_EXIT_CODE);
 980 }
 981
 982
 983 /* Clear the error flag when we start to compile a source line.  */
 984
 985 void
 986 gfc_clear_error (void)
 987 {
 988   error_buffer.flag = 0;
 989   warnings_not_errors = 0;
 990 }
 991
 992
 993 /* Tests the state of error_flag.  */
 994
 995 int
 996 gfc_error_flag_test (void)
 997 {
 998   return error_buffer.flag;
 999 }
1000
1001
1002 /* Check to see if any errors have been saved.
1003    If so, print the error.  Returns the state of error_flag.  */
1004
1005 int
1006 gfc_error_check (void)
1007 {
1008   int rc;
1009
1010   rc = error_buffer.flag;
1011
1012   if (error_buffer.flag)
1013     {
1014       if (error_buffer.message != NULL)
1015         fputs (error_buffer.message, stderr);
1016       error_buffer.flag = 0;
1017
1018       gfc_increment_error_count();
1019
1020       if (flag_fatal_errors)
1021         exit (1);
1022     }
1023
1024   return rc;
1025 }
1026
1027
1028 /* Save the existing error state.  */
1029
1030 void
1031 gfc_push_error (gfc_error_buf *err)
1032 {
1033   err->flag = error_buffer.flag;
1034   if (error_buffer.flag)
1035     err->message = xstrdup (error_buffer.message);
1036
1037   error_buffer.flag = 0;
1038 }
1039
1040
1041 /* Restore a previous pushed error state.  */
1042
1043 void
1044 gfc_pop_error (gfc_error_buf *err)
1045 {
1046   error_buffer.flag = err->flag;
1047   if (error_buffer.flag)
1048     {
1049       size_t len = strlen (err->message) + 1;
1050       gcc_assert (len <= error_buffer.allocated);
1051       memcpy (error_buffer.message, err->message, len);
1052       gfc_free (err->message);
1053     }
1054 }
1055
1056
1057 /* Free a pushed error state, but keep the current error state.  */
1058
1059 void
1060 gfc_free_error (gfc_error_buf *err)
1061 {
1062   if (err->flag)
1063     gfc_free (err->message);
1064 }
1065
1066
1067 /* Report the number of warnings and errors that occurred to the caller.  */
1068
1069 void
1070 gfc_get_errors (int *w, int *e)
1071 {
1072   if (w != NULL)
1073     *w = warnings;
1074   if (e != NULL)
1075     *e = errors;
1076 }
1077
1078
1079 /* Switch errors into warnings.  */
1080
1081 void
1082 gfc_errors_to_warnings (int f)
1083 {
1084   warnings_not_errors = (f == 1) ? 1 : 0;
1085 }