gcc/fortran/error.c

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