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