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   /* Show the line itself, taking care not to print more than what can
 237      show up on the terminal.  Tabs are converted to spaces, and
 238      nonprintable characters are converted to a "\xNN" sequence.  */
 239
 240   /* TODO: Although setting i to the terminal width is clever, it fails
 241      to work correctly when nonprintable characters exist.  A better
 242      solution should be found.  */
 243
 244   p = lb->line + offset;
 245   i = strlen (p);
 246   if (i > terminal_width)
 247     i = terminal_width - 1;
 248
 249   for (; i > 0; i--)
 250     {
 251       c = *p++;
 252       if (c == '\t')
 253         c = ' ';
 254
 255       if (ISPRINT (c))
 256         error_char (c);
 257       else
 258         {
 259           error_char ('\\');
 260           error_char ('x');
 261
 262           m = ((c >> 4) & 0x0F) + '0';
 263           if (m > '9')
 264             m += 'A' - '9' - 1;
 265           error_char (m);
 266
 267           m = (c & 0x0F) + '0';
 268           if (m > '9')
 269             m += 'A' - '9' - 1;
 270           error_char (m);
 271         }
 272     }
 273
 274   error_char ('\n');
 275
 276   /* Show the '1' and/or '2' corresponding to the column of the error
 277      locus.  Note that a value of -1 for c1 or c2 will simply cause
 278      the relevant number not to be printed.  */
 279
 280   c1 -= offset;
 281   c2 -= offset;
 282
 283   for (i = 1; i <= cmax; i++)
 284     {
 285       if (i == c1)
 286         error_char ('1');
 287       else if (i == c2)
 288         error_char ('2');
 289       else
 290         error_char (' ');
 291     }
 292
 293   error_char ('\n');
 294
 295 }
 296
 297
 298 /* As part of printing an error, we show the source lines that caused
 299    the problem.  We show at least one, and possibly two loci; the two
 300    loci may or may not be on the same source line.  */
 301
 302 static void
 303 show_loci (locus *l1, locus *l2)
 304 {
 305   int m, c1, c2;
 306
 307   if (l1 == NULL || l1->lb == NULL)
 308     {
 309       error_printf ("<During initialization>\n");
 310       return;
 311     }
 312
 313   /* While calculating parameters for printing the loci, we consider possible
 314      reasons for printing one per line.  If appropriate, print the loci
 315      individually; otherwise we print them both on the same line.  */
 316
 317   c1 = l1->nextc - l1->lb->line;
 318   if (l2 == NULL)
 319     {
 320       show_locus (l1, c1, -1);
 321       return;
 322     }
 323
 324   c2 = l2->nextc - l2->lb->line;
 325
 326   if (c1 < c2)
 327     m = c2 - c1;
 328   else
 329     m = c1 - c2;
 330
 331   /* Note that the margin value of 10 here needs to be less than the
 332      margin of 5 used in the calculation of offset in show_locus.  */
 333
 334   if (l1->lb != l2->lb || m > terminal_width - 10)
 335     {
 336       show_locus (l1, c1, -1);
 337       show_locus (l2, -1, c2);
 338       return;
 339     }
 340
 341   show_locus (l1, c1, c2);
 342
 343   return;
 344 }
 345
 346
 347 /* Workhorse for the error printing subroutines.  This subroutine is
 348    inspired by g77's error handling and is similar to printf() with
 349    the following %-codes:
 350
 351    %c Character, %d or %i Integer, %s String, %% Percent
 352    %L  Takes locus argument
 353    %C  Current locus (no argument)
 354
 355    If a locus pointer is given, the actual source line is printed out
 356    and the column is indicated.  Since we want the error message at
 357    the bottom of any source file information, we must scan the
 358    argument list twice -- once to determine whether the loci are
 359    present and record this for printing, and once to print the error
 360    message after and loci have been printed.  A maximum of two locus
 361    arguments are permitted.
 362
 363    This function is also called (recursively) by show_locus in the
 364    case of included files; however, as show_locus does not resupply
 365    any loci, the recursion is at most one level deep.  */
 366
 367 #define MAX_ARGS 10
 368
 369 static void ATTRIBUTE_GCC_GFC(2,0)
 370 error_print (const char *type, const char *format0, va_list argp)
 371 {
 372   enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_CHAR, TYPE_STRING,
 373          NOTYPE };
 374   struct
 375   {
 376     int type;
 377     int pos;
 378     union
 379     {
 380       int intval;
 381       char charval;
 382       const char * stringval;
 383     } u;
 384   } arg[MAX_ARGS], spec[MAX_ARGS];
 385   /* spec is the array of specifiers, in the same order as they
 386      appear in the format string.  arg is the array of arguments,
 387      in the same order as they appear in the va_list.  */
 388
 389   char c;
 390   int i, n, have_l1, pos, maxpos;
 391   locus *l1, *l2, *loc;
 392   const char *format;
 393
 394   l1 = l2 = NULL;
 395
 396   have_l1 = 0;
 397   pos = -1;
 398   maxpos = -1;
 399
 400   n = 0;
 401   format = format0;
 402
 403   for (i = 0; i < MAX_ARGS; i++)
 404     {
 405       arg[i].type = NOTYPE;
 406       spec[i].pos = -1;
 407     }
 408
 409   /* First parse the format string for position specifiers.  */
 410   while (*format)
 411     {
 412       c = *format++;
 413       if (c != '%')
 414         continue;
 415
 416       if (*format == '%')
 417         continue;
 418
 419       if (ISDIGIT (*format))
 420         {
 421           /* This is a position specifier.  For example, the number
 422              12 in the format string "%12$d", which specifies the third
 423              argument of the va_list, formatted in %d format.
 424              For details, see "man 3 printf".  */
 425           pos = atoi(format) - 1;
 426           gcc_assert (pos >= 0);
 427           while (ISDIGIT(*format))
 428             format++;
 429           gcc_assert (*format++ == '$');
 430         }
 431       else
 432         pos++;
 433
 434       c = *format++;
 435
 436       if (pos > maxpos)
 437         maxpos = pos;
 438
 439       switch (c)
 440         {
 441           case 'C':
 442             arg[pos].type = TYPE_CURRENTLOC;
 443             break;
 444
 445           case 'L':
 446             arg[pos].type = TYPE_LOCUS;
 447             break;
 448
 449           case 'd':
 450           case 'i':
 451             arg[pos].type = TYPE_INTEGER;
 452             break;
 453
 454           case 'c':
 455             arg[pos].type = TYPE_CHAR;
 456             break;
 457
 458           case 's':
 459             arg[pos].type = TYPE_STRING;
 460             break;
 461
 462           default:
 463             gcc_unreachable ();
 464         }
 465
 466       spec[n++].pos = pos;
 467     }
 468
 469   /* Then convert the values for each %-style argument.  */
 470   for (pos = 0; pos <= maxpos; pos++)
 471     {
 472       gcc_assert (arg[pos].type != NOTYPE);
 473       switch (arg[pos].type)
 474         {
 475           case TYPE_CURRENTLOC:
 476             loc = &gfc_current_locus;
 477             /* Fall through.  */
 478
 479           case TYPE_LOCUS:
 480             if (arg[pos].type == TYPE_LOCUS)
 481               loc = va_arg (argp, locus *);
 482
 483             if (have_l1)
 484               {
 485                 l2 = loc;
 486                 arg[pos].u.stringval = "(2)";
 487               }
 488             else
 489               {
 490                 l1 = loc;
 491                 have_l1 = 1;
 492                 arg[pos].u.stringval = "(1)";
 493               }
 494             break;
 495
 496           case TYPE_INTEGER:
 497             arg[pos].u.intval = va_arg (argp, int);
 498             break;
 499
 500           case TYPE_CHAR:
 501             arg[pos].u.charval = (char) va_arg (argp, int);
 502             break;
 503
 504           case TYPE_STRING:
 505             arg[pos].u.stringval = (const char *) va_arg (argp, char *);
 506             break;
 507
 508           default:
 509             gcc_unreachable ();
 510         }
 511     }
 512
 513   for (n = 0; spec[n].pos >= 0; n++)
 514     spec[n].u = arg[spec[n].pos].u;
 515
 516   /* Show the current loci if we have to.  */
 517   if (have_l1)
 518     show_loci (l1, l2);
 519
 520   if (*type)
 521     {
 522       error_string (type);
 523       error_char (' ');
 524     }
 525
 526   have_l1 = 0;
 527   format = format0;
 528   n = 0;
 529
 530   for (; *format; format++)
 531     {
 532       if (*format != '%')
 533         {
 534           error_char (*format);
 535           continue;
 536         }
 537
 538       format++;
 539       if (ISDIGIT (*format))
 540         {
 541           /* This is a position specifier.  See comment above.  */
 542           while (ISDIGIT (*format))
 543             format++;
 544
 545           /* Skip over the dollar sign.  */
 546           format++;
 547         }
 548
 549       switch (*format)
 550         {
 551         case '%':
 552           error_char ('%');
 553           break;
 554
 555         case 'c':
 556           error_char (spec[n++].u.charval);
 557           break;
 558
 559         case 's':
 560         case 'C':               /* Current locus */
 561         case 'L':               /* Specified locus */
 562           error_string (spec[n++].u.stringval);
 563           break;
 564
 565         case 'd':
 566         case 'i':
 567           error_integer (spec[n++].u.intval);
 568           break;
 569         }
 570     }
 571
 572   error_char ('\n');
 573 }
 574
 575
 576 /* Wrapper for error_print().  */
 577
 578 static void
 579 error_printf (const char *nocmsgid, ...)
 580 {
 581   va_list argp;
 582
 583   va_start (argp, nocmsgid);
 584   error_print ("", _(nocmsgid), argp);
 585   va_end (argp);
 586 }
 587
 588
 589 /* Increment the number of errors, and check whether too many have
 590    been printed.  */
 591
 592 static void
 593 gfc_increment_error_count (void)
 594 {
 595   errors++;
 596   if ((gfc_option.max_errors != 0) && (errors >= gfc_option.max_errors))
 597     gfc_fatal_error ("Error count reached limit of %d.", gfc_option.max_errors);
 598 }
 599
 600
 601 /* Issue a warning.  */
 602
 603 void
 604 gfc_warning (const char *nocmsgid, ...)
 605 {
 606   va_list argp;
 607
 608   if (inhibit_warnings)
 609     return;
 610
 611   warning_buffer.flag = 1;
 612   warning_buffer.index = 0;
 613   cur_error_buffer = &warning_buffer;
 614
 615   va_start (argp, nocmsgid);
 616   error_print (_("Warning:"), _(nocmsgid), argp);
 617   va_end (argp);
 618
 619   error_char ('\0');
 620
 621   if (buffer_flag == 0)
 622   {
 623     warnings++;
 624     if (warnings_are_errors)
 625       gfc_increment_error_count();
 626   }
 627 }
 628
 629
 630 /* Whether, for a feature included in a given standard set (GFC_STD_*),
 631    we should issue an error or a warning, or be quiet.  */
 632
 633 notification
 634 gfc_notification_std (int std)
 635 {
 636   bool warning;
 637
 638   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 639   if ((gfc_option.allow_std & std) != 0 && !warning)
 640     return SILENT;
 641
 642   return warning ? WARNING : ERROR;
 643 }
 644
 645
 646 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 647    feature.  An error/warning will be issued if the currently selected
 648    standard does not contain the requested bits.  Return FAILURE if
 649    an error is generated.  */
 650
 651 try
 652 gfc_notify_std (int std, const char *nocmsgid, ...)
 653 {
 654   va_list argp;
 655   bool warning;
 656
 657   warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
 658   if ((gfc_option.allow_std & std) != 0 && !warning)
 659     return SUCCESS;
 660
 661   if (gfc_suppress_error)
 662     return warning ? SUCCESS : FAILURE;
 663
 664   cur_error_buffer = (warning && !warnings_are_errors)
 665                    ? &warning_buffer : &error_buffer;
 666   cur_error_buffer->flag = 1;
 667   cur_error_buffer->index = 0;
 668
 669   va_start (argp, nocmsgid);
 670   if (warning)
 671     error_print (_("Warning:"), _(nocmsgid), argp);
 672   else
 673     error_print (_("Error:"), _(nocmsgid), argp);
 674   va_end (argp);
 675
 676   error_char ('\0');
 677
 678   if (buffer_flag == 0)
 679     {
 680       if (warning && !warnings_are_errors)
 681         warnings++;
 682       else
 683         gfc_increment_error_count();
 684     }
 685
 686   return (warning && !warnings_are_errors) ? SUCCESS : FAILURE;
 687 }
 688
 689
 690 /* Immediate warning (i.e. do not buffer the warning).  */
 691
 692 void
 693 gfc_warning_now (const char *nocmsgid, ...)
 694 {
 695   va_list argp;
 696   int i;
 697
 698   if (inhibit_warnings)
 699     return;
 700
 701   i = buffer_flag;
 702   buffer_flag = 0;
 703   warnings++;
 704   if (warnings_are_errors)
 705     gfc_increment_error_count();
 706
 707   va_start (argp, nocmsgid);
 708   error_print (_("Warning:"), _(nocmsgid), argp);
 709   va_end (argp);
 710
 711   error_char ('\0');
 712   buffer_flag = i;
 713 }
 714
 715
 716 /* Clear the warning flag.  */
 717
 718 void
 719 gfc_clear_warning (void)
 720 {
 721   warning_buffer.flag = 0;
 722 }
 723
 724
 725 /* Check to see if any warnings have been saved.
 726    If so, print the warning.  */
 727
 728 void
 729 gfc_warning_check (void)
 730 {
 731   if (warning_buffer.flag)
 732     {
 733       warnings++;
 734       if (warning_buffer.message != NULL)
 735         fputs (warning_buffer.message, stderr);
 736       warning_buffer.flag = 0;
 737     }
 738 }
 739
 740
 741 /* Issue an error.  */
 742
 743 void
 744 gfc_error (const char *nocmsgid, ...)
 745 {
 746   va_list argp;
 747
 748   if (gfc_suppress_error)
 749     return;
 750
 751   error_buffer.flag = 1;
 752   error_buffer.index = 0;
 753   cur_error_buffer = &error_buffer;
 754
 755   va_start (argp, nocmsgid);
 756   error_print (_("Error:"), _(nocmsgid), argp);
 757   va_end (argp);
 758
 759   error_char ('\0');
 760
 761   if (buffer_flag == 0)
 762     gfc_increment_error_count();
 763 }
 764
 765
 766 /* Immediate error.  */
 767
 768 void
 769 gfc_error_now (const char *nocmsgid, ...)
 770 {
 771   va_list argp;
 772   int i;
 773
 774   error_buffer.flag = 1;
 775   error_buffer.index = 0;
 776   cur_error_buffer = &error_buffer;
 777
 778   i = buffer_flag;
 779   buffer_flag = 0;
 780
 781   va_start (argp, nocmsgid);
 782   error_print (_("Error:"), _(nocmsgid), argp);
 783   va_end (argp);
 784
 785   error_char ('\0');
 786
 787   gfc_increment_error_count();
 788
 789   buffer_flag = i;
 790
 791   if (flag_fatal_errors)
 792     exit (1);
 793 }
 794
 795
 796 /* Fatal error, never returns.  */
 797
 798 void
 799 gfc_fatal_error (const char *nocmsgid, ...)
 800 {
 801   va_list argp;
 802
 803   buffer_flag = 0;
 804
 805   va_start (argp, nocmsgid);
 806   error_print (_("Fatal Error:"), _(nocmsgid), argp);
 807   va_end (argp);
 808
 809   exit (3);
 810 }
 811
 812
 813 /* This shouldn't happen... but sometimes does.  */
 814
 815 void
 816 gfc_internal_error (const char *format, ...)
 817 {
 818   va_list argp;
 819
 820   buffer_flag = 0;
 821
 822   va_start (argp, format);
 823
 824   show_loci (&gfc_current_locus, NULL);
 825   error_printf ("Internal Error at (1):");
 826
 827   error_print ("", format, argp);
 828   va_end (argp);
 829
 830   exit (ICE_EXIT_CODE);
 831 }
 832
 833
 834 /* Clear the error flag when we start to compile a source line.  */
 835
 836 void
 837 gfc_clear_error (void)
 838 {
 839   error_buffer.flag = 0;
 840 }
 841
 842
 843 /* Tests the state of error_flag.  */
 844
 845 int
 846 gfc_error_flag_test (void)
 847 {
 848   return error_buffer.flag;
 849 }
 850
 851
 852 /* Check to see if any errors have been saved.
 853    If so, print the error.  Returns the state of error_flag.  */
 854
 855 int
 856 gfc_error_check (void)
 857 {
 858   int rc;
 859
 860   rc = error_buffer.flag;
 861
 862   if (error_buffer.flag)
 863     {
 864       if (error_buffer.message != NULL)
 865         fputs (error_buffer.message, stderr);
 866       error_buffer.flag = 0;
 867
 868       gfc_increment_error_count();
 869
 870       if (flag_fatal_errors)
 871         exit (1);
 872     }
 873
 874   return rc;
 875 }
 876
 877
 878 /* Save the existing error state.  */
 879
 880 void
 881 gfc_push_error (gfc_error_buf *err)
 882 {
 883   err->flag = error_buffer.flag;
 884   if (error_buffer.flag)
 885     err->message = xstrdup (error_buffer.message);
 886
 887   error_buffer.flag = 0;
 888 }
 889
 890
 891 /* Restore a previous pushed error state.  */
 892
 893 void
 894 gfc_pop_error (gfc_error_buf *err)
 895 {
 896   error_buffer.flag = err->flag;
 897   if (error_buffer.flag)
 898     {
 899       size_t len = strlen (err->message) + 1;
 900       gcc_assert (len <= error_buffer.allocated);
 901       memcpy (error_buffer.message, err->message, len);
 902       gfc_free (err->message);
 903     }
 904 }
 905
 906
 907 /* Free a pushed error state, but keep the current error state.  */
 908
 909 void
 910 gfc_free_error (gfc_error_buf *err)
 911 {
 912   if (err->flag)
 913     gfc_free (err->message);
 914 }
 915
 916
 917 /* Debug wrapper for printf.  */
 918
 919 void
 920 gfc_status (const char *cmsgid, ...)
 921 {
 922   va_list argp;
 923
 924   va_start (argp, cmsgid);
 925
 926   vprintf (_(cmsgid), argp);
 927
 928   va_end (argp);
 929 }
 930
 931
 932 /* Subroutine for outputting a single char so that we don't have to go
 933    around creating a lot of 1-character strings.  */
 934
 935 void
 936 gfc_status_char (char c)
 937 {
 938   putchar (c);
 939 }
 940
 941
 942 /* Report the number of warnings and errors that occurred to the caller.  */
 943
 944 void
 945 gfc_get_errors (int *w, int *e)
 946 {
 947   if (w != NULL)
 948     *w = warnings;
 949   if (e != NULL)
 950     *e = errors;
 951 }