gcc/fortran/error.c

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