gcc/fortran/error.c

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