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 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->up;
 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 ? &warning_buffer : &error_buffer;
 719   cur_error_buffer->flag = 1;
 720   cur_error_buffer->index = 0;
 721
 722   va_start (argp, nocmsgid);
 723   if (warning)
 724     error_print (_("Warning:"), _(nocmsgid), argp);
 725   else
 726     error_print (_("Error:"), _(nocmsgid), argp);
 727   va_end (argp);
 728
 729   error_char ('\0');
 730
 731   if (buffer_flag == 0)
 732     {
 733       if (warning && !warnings_are_errors)
 734         warnings++;
 735       else
 736         gfc_increment_error_count();
 737     }
 738
 739   return (warning && !warnings_are_errors) ? SUCCESS : FAILURE;
 740 }
 741
 742
 743 /* Immediate warning (i.e. do not buffer the warning).  */
 744
 745 void
 746 gfc_warning_now (const char *nocmsgid, ...)
 747 {
 748   va_list argp;
 749   int i;
 750
 751   if (inhibit_warnings)
 752     return;
 753
 754   i = buffer_flag;
 755   buffer_flag = 0;
 756   warnings++;
 757   if (warnings_are_errors)
 758     gfc_increment_error_count();
 759
 760   va_start (argp, nocmsgid);
 761   error_print (_("Warning:"), _(nocmsgid), argp);
 762   va_end (argp);
 763
 764   error_char ('\0');
 765   buffer_flag = i;
 766 }
 767
 768
 769 /* Clear the warning flag.  */
 770
 771 void
 772 gfc_clear_warning (void)
 773 {
 774   warning_buffer.flag = 0;
 775 }
 776
 777
 778 /* Check to see if any warnings have been saved.
 779    If so, print the warning.  */
 780
 781 void
 782 gfc_warning_check (void)
 783 {
 784   if (warning_buffer.flag)
 785     {
 786       warnings++;
 787       if (warning_buffer.message != NULL)
 788         fputs (warning_buffer.message, stderr);
 789       warning_buffer.flag = 0;
 790     }
 791 }
 792
 793
 794 /* Issue an error.  */
 795
 796 void
 797 gfc_error (const char *nocmsgid, ...)
 798 {
 799   va_list argp;
 800
 801   if (gfc_suppress_error)
 802     return;
 803
 804   error_buffer.flag = 1;
 805   error_buffer.index = 0;
 806   cur_error_buffer = &error_buffer;
 807
 808   va_start (argp, nocmsgid);
 809   error_print (_("Error:"), _(nocmsgid), argp);
 810   va_end (argp);
 811
 812   error_char ('\0');
 813
 814   if (buffer_flag == 0)
 815     gfc_increment_error_count();
 816 }
 817
 818
 819 /* Immediate error.  */
 820
 821 void
 822 gfc_error_now (const char *nocmsgid, ...)
 823 {
 824   va_list argp;
 825   int i;
 826
 827   error_buffer.flag = 1;
 828   error_buffer.index = 0;
 829   cur_error_buffer = &error_buffer;
 830
 831   i = buffer_flag;
 832   buffer_flag = 0;
 833
 834   va_start (argp, nocmsgid);
 835   error_print (_("Error:"), _(nocmsgid), argp);
 836   va_end (argp);
 837
 838   error_char ('\0');
 839
 840   gfc_increment_error_count();
 841
 842   buffer_flag = i;
 843
 844   if (flag_fatal_errors)
 845     exit (1);
 846 }
 847
 848
 849 /* Fatal error, never returns.  */
 850
 851 void
 852 gfc_fatal_error (const char *nocmsgid, ...)
 853 {
 854   va_list argp;
 855
 856   buffer_flag = 0;
 857
 858   va_start (argp, nocmsgid);
 859   error_print (_("Fatal Error:"), _(nocmsgid), argp);
 860   va_end (argp);
 861
 862   exit (3);
 863 }
 864
 865
 866 /* This shouldn't happen... but sometimes does.  */
 867
 868 void
 869 gfc_internal_error (const char *format, ...)
 870 {
 871   va_list argp;
 872
 873   buffer_flag = 0;
 874
 875   va_start (argp, format);
 876
 877   show_loci (&gfc_current_locus, NULL);
 878   error_printf ("Internal Error at (1):");
 879
 880   error_print ("", format, argp);
 881   va_end (argp);
 882
 883   exit (ICE_EXIT_CODE);
 884 }
 885
 886
 887 /* Clear the error flag when we start to compile a source line.  */
 888
 889 void
 890 gfc_clear_error (void)
 891 {
 892   error_buffer.flag = 0;
 893 }
 894
 895
 896 /* Tests the state of error_flag.  */
 897
 898 int
 899 gfc_error_flag_test (void)
 900 {
 901   return error_buffer.flag;
 902 }
 903
 904
 905 /* Check to see if any errors have been saved.
 906    If so, print the error.  Returns the state of error_flag.  */
 907
 908 int
 909 gfc_error_check (void)
 910 {
 911   int rc;
 912
 913   rc = error_buffer.flag;
 914
 915   if (error_buffer.flag)
 916     {
 917       if (error_buffer.message != NULL)
 918         fputs (error_buffer.message, stderr);
 919       error_buffer.flag = 0;
 920
 921       gfc_increment_error_count();
 922
 923       if (flag_fatal_errors)
 924         exit (1);
 925     }
 926
 927   return rc;
 928 }
 929
 930
 931 /* Save the existing error state.  */
 932
 933 void
 934 gfc_push_error (gfc_error_buf *err)
 935 {
 936   err->flag = error_buffer.flag;
 937   if (error_buffer.flag)
 938     err->message = xstrdup (error_buffer.message);
 939
 940   error_buffer.flag = 0;
 941 }
 942
 943
 944 /* Restore a previous pushed error state.  */
 945
 946 void
 947 gfc_pop_error (gfc_error_buf *err)
 948 {
 949   error_buffer.flag = err->flag;
 950   if (error_buffer.flag)
 951     {
 952       size_t len = strlen (err->message) + 1;
 953       gcc_assert (len <= error_buffer.allocated);
 954       memcpy (error_buffer.message, err->message, len);
 955       gfc_free (err->message);
 956     }
 957 }
 958
 959
 960 /* Free a pushed error state, but keep the current error state.  */
 961
 962 void
 963 gfc_free_error (gfc_error_buf *err)
 964 {
 965   if (err->flag)
 966     gfc_free (err->message);
 967 }
 968
 969
 970 /* Debug wrapper for printf.  */
 971
 972 void
 973 gfc_status (const char *cmsgid, ...)
 974 {
 975   va_list argp;
 976
 977   va_start (argp, cmsgid);
 978
 979   vprintf (_(cmsgid), argp);
 980
 981   va_end (argp);
 982 }
 983
 984
 985 /* Subroutine for outputting a single char so that we don't have to go
 986    around creating a lot of 1-character strings.  */
 987
 988 void
 989 gfc_status_char (char c)
 990 {
 991   putchar (c);
 992 }
 993
 994
 995 /* Report the number of warnings and errors that occurred to the caller.  */
 996
 997 void
 998 gfc_get_errors (int *w, int *e)
 999 {
1000   if (w != NULL)
1001     *w = warnings;
1002   if (e != NULL)
1003     *e = errors;
1004 }