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