gcc/fortran/error.c

   1 /* Handle errors.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
   3    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, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, 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
  32 #include <string.h>
  33 #include <stdarg.h>
  34 #include <stdio.h>
  35 #include <stdlib.h>
  36
  37 #include "flags.h"
  38 #include "gfortran.h"
  39
  40 int gfc_suppress_error = 0;
  41
  42 static int terminal_width, buffer_flag, errors,
  43   use_warning_buffer, warnings;
  44
  45 static char *error_ptr, *warning_ptr;
  46
  47 static gfc_error_buf error_buffer, warning_buffer;
  48
  49
  50 /* Per-file error initialization.  */
  51
  52 void
  53 gfc_error_init_1 (void)
  54 {
  55
  56   terminal_width = gfc_terminal_width();
  57   errors = 0;
  58   warnings = 0;
  59   buffer_flag = 0;
  60 }
  61
  62
  63 /* Set the flag for buffering errors or not.  */
  64
  65 void
  66 gfc_buffer_error (int flag)
  67 {
  68
  69   buffer_flag = flag;
  70 }
  71
  72
  73 /* Add a single character to the error buffer or output depending on
  74    buffer_flag.  */
  75
  76 static void
  77 error_char (char c)
  78 {
  79
  80   if (buffer_flag)
  81     {
  82       if (use_warning_buffer)
  83         {
  84           *warning_ptr++ = c;
  85           if (warning_ptr - warning_buffer.message >= MAX_ERROR_MESSAGE)
  86             gfc_internal_error ("error_char(): Warning buffer overflow");
  87         }
  88       else
  89         {
  90           *error_ptr++ = c;
  91           if (error_ptr - error_buffer.message >= MAX_ERROR_MESSAGE)
  92             gfc_internal_error ("error_char(): Error buffer overflow");
  93         }
  94     }
  95   else
  96     {
  97       if (c != 0)
  98         fputc (c, stderr);
  99     }
 100 }
 101
 102
 103 /* Copy a string to wherever it needs to go.  */
 104
 105 static void
 106 error_string (const char *p)
 107 {
 108
 109   while (*p)
 110     error_char (*p++);
 111 }
 112
 113
 114 /* Show the file, where it was included and the source line give a
 115    locus.  Calls error_printf() recursively, but the recursion is at
 116    most one level deep.  */
 117
 118 static void error_printf (const char *, ...) ATTRIBUTE_PRINTF_1;
 119
 120 static void
 121 show_locus (int offset, locus * l)
 122 {
 123   gfc_file *f;
 124   char c, *p;
 125   int i, m;
 126
 127   /* TODO: Either limit the total length and number of included files
 128      displayed or add buffering of arbitrary number of characters in
 129      error messages.  */
 130   f = l->file;
 131   error_printf ("In file %s:%d\n", f->filename, l->lp->start_line + l->line);
 132
 133   f = f->included_by;
 134   while (f != NULL)
 135     {
 136       error_printf ("    Included at %s:%d\n", f->filename,
 137                     f->loc.lp->start_line + f->loc.line);
 138       f = f->included_by;
 139     }
 140
 141   /* Show the line itself, taking care not to print more than what can
 142      show up on the terminal.  Tabs are converted to spaces.  */
 143   p = l->lp->line[l->line] + offset;
 144   i = strlen (p);
 145   if (i > terminal_width)
 146     i = terminal_width - 1;
 147
 148   for (; i > 0; i--)
 149     {
 150       c = *p++;
 151       if (c == '\t')
 152         c = ' ';
 153
 154       if (ISPRINT (c))
 155         error_char (c);
 156       else
 157         {
 158           error_char ('\\');
 159           error_char ('x');
 160
 161           m = ((c >> 4) & 0x0F) + '0';
 162           if (m > '9')
 163             m += 'A' - '9' - 1;
 164           error_char (m);
 165
 166           m = (c & 0x0F) + '0';
 167           if (m > '9')
 168             m += 'A' - '9' - 1;
 169           error_char (m);
 170         }
 171     }
 172
 173   error_char ('\n');
 174 }
 175
 176
 177 /* As part of printing an error, we show the source lines that caused
 178    the problem.  We show at least one, possibly two loci.  If we're
 179    showing two loci and they both refer to the same file and line, we
 180    only print the line once.  */
 181
 182 static void
 183 show_loci (locus * l1, locus * l2)
 184 {
 185   int offset, flag, i, m, c1, c2, cmax;
 186
 187   if (l1 == NULL)
 188     {
 189       error_printf ("<During initialization>\n");
 190       return;
 191     }
 192
 193   c1 = l1->nextc - l1->lp->line[l1->line];
 194   c2 = 0;
 195   if (l2 == NULL)
 196     goto separate;
 197
 198   c2 = l2->nextc - l2->lp->line[l2->line];
 199
 200   if (c1 < c2)
 201     m = c2 - c1;
 202   else
 203     m = c1 - c2;
 204
 205
 206   if (l1->lp != l2->lp || l1->line != l2->line || m > terminal_width - 10)
 207     goto separate;
 208
 209   offset = 0;
 210   cmax = (c1 < c2) ? c2 : c1;
 211   if (cmax > terminal_width - 5)
 212     offset = cmax - terminal_width + 5;
 213
 214   if (offset < 0)
 215     offset = 0;
 216
 217   c1 -= offset;
 218   c2 -= offset;
 219
 220   show_locus (offset, l1);
 221
 222   /* Arrange that '1' and '2' will show up even if the two columns are equal.  */
 223   for (i = 1; i <= cmax; i++)
 224     {
 225       flag = 0;
 226       if (i == c1)
 227         {
 228           error_char ('1');
 229           flag = 1;
 230         }
 231       if (i == c2)
 232         {
 233           error_char ('2');
 234           flag = 1;
 235         }
 236       if (flag == 0)
 237         error_char (' ');
 238     }
 239
 240   error_char ('\n');
 241
 242   return;
 243
 244 separate:
 245   offset = 0;
 246
 247   if (c1 > terminal_width - 5)
 248     {
 249       offset = c1 - 5;
 250       if (offset < 0)
 251         offset = 0;
 252       c1 = c1 - offset;
 253     }
 254
 255   show_locus (offset, l1);
 256   for (i = 1; i < c1; i++)
 257     error_char (' ');
 258
 259   error_char ('1');
 260   error_char ('\n');
 261
 262   if (l2 != NULL)
 263     {
 264       offset = 0;
 265
 266       if (c2 > terminal_width - 20)
 267         {
 268           offset = c2 - 20;
 269           if (offset < 0)
 270             offset = 0;
 271           c2 = c2 - offset;
 272         }
 273
 274       show_locus (offset, l2);
 275
 276       for (i = 1; i < c2; i++)
 277         error_char (' ');
 278
 279       error_char ('2');
 280       error_char ('\n');
 281     }
 282 }
 283
 284
 285 /* Workhorse for the error printing subroutines.  This subroutine is
 286    inspired by g77's error handling and is similar to printf() with
 287    the following %-codes:
 288
 289    %c Character, %d Integer, %s String, %% Percent
 290    %L  Takes locus argument
 291    %C  Current locus (no argument)
 292
 293    If a locus pointer is given, the actual source line is printed out
 294    and the column is indicated.  Since we want the error message at
 295    the bottom of any source file information, we must scan the
 296    argument list twice.  A maximum of two locus arguments are
 297    permitted.  */
 298
 299 #define IBUF_LEN 30
 300 #define MAX_ARGS 10
 301
 302 static void
 303 error_print (const char *type, const char *format0, va_list argp)
 304 {
 305   char c, *p, int_buf[IBUF_LEN], c_arg[MAX_ARGS], *cp_arg[MAX_ARGS];
 306   int i, n, have_l1, i_arg[MAX_ARGS];
 307   locus *l1, *l2, *loc;
 308   const char *format;
 309
 310   l1 = l2 = loc = NULL;
 311
 312   have_l1 = 0;
 313
 314   n = 0;
 315   format = format0;
 316
 317   while (*format)
 318     {
 319       c = *format++;
 320       if (c == '%')
 321         {
 322           c = *format++;
 323
 324           switch (c)
 325             {
 326             case '%':
 327               break;
 328
 329             case 'L':
 330               loc = va_arg (argp, locus *);
 331               /* Fall through */
 332
 333             case 'C':
 334               if (c == 'C')
 335                 loc = gfc_current_locus ();
 336
 337               if (have_l1)
 338                 {
 339                   l2 = loc;
 340                 }
 341               else
 342                 {
 343                   l1 = loc;
 344                   have_l1 = 1;
 345                 }
 346               break;
 347
 348             case 'd':
 349             case 'i':
 350               i_arg[n++] = va_arg (argp, int);
 351               break;
 352
 353             case 'c':
 354               c_arg[n++] = va_arg (argp, int);
 355               break;
 356
 357             case 's':
 358               cp_arg[n++] = va_arg (argp, char *);
 359               break;
 360             }
 361         }
 362     }
 363
 364   /* Show the current loci if we have to.  */
 365   if (have_l1)
 366     show_loci (l1, l2);
 367   error_string (type);
 368   error_char (' ');
 369
 370   have_l1 = 0;
 371   format = format0;
 372   n = 0;
 373
 374   for (; *format; format++)
 375     {
 376       if (*format != '%')
 377         {
 378           error_char (*format);
 379           continue;
 380         }
 381
 382       format++;
 383       switch (*format)
 384         {
 385         case '%':
 386           error_char ('%');
 387           break;
 388
 389         case 'c':
 390           error_char (c_arg[n++]);
 391           break;
 392
 393         case 's':
 394           error_string (cp_arg[n++]);
 395           break;
 396
 397         case 'i':
 398         case 'd':
 399           i = i_arg[n++];
 400
 401           if (i < 0)
 402             {
 403               i = -i;
 404               error_char ('-');
 405             }
 406
 407           p = int_buf + IBUF_LEN - 1;
 408           *p-- = '\0';
 409
 410           if (i == 0)
 411             *p-- = '0';
 412
 413           while (i > 0)
 414             {
 415               *p-- = i % 10 + '0';
 416               i = i / 10;
 417             }
 418
 419           error_string (p + 1);
 420           break;
 421
 422         case 'C':               /* Current locus */
 423         case 'L':               /* Specified locus */
 424           error_string (have_l1 ? "(2)" : "(1)");
 425           have_l1 = 1;
 426           break;
 427         }
 428     }
 429
 430   error_char ('\n');
 431 }
 432
 433
 434 /* Wrapper for error_print().  */
 435
 436 static void
 437 error_printf (const char *format, ...)
 438 {
 439   va_list argp;
 440
 441   va_start (argp, format);
 442   error_print ("", format, argp);
 443   va_end (argp);
 444 }
 445
 446
 447 /* Issue a warning.  */
 448
 449 void
 450 gfc_warning (const char *format, ...)
 451 {
 452   va_list argp;
 453
 454   if (inhibit_warnings)
 455     return;
 456
 457   warning_buffer.flag = 1;
 458   warning_ptr = warning_buffer.message;
 459   use_warning_buffer = 1;
 460
 461   va_start (argp, format);
 462   if (buffer_flag == 0)
 463     warnings++;
 464   error_print ("Warning:", format, argp);
 465   va_end (argp);
 466
 467   error_char ('\0');
 468 }
 469
 470
 471 /* Possibly issue a warning/error about use of a nonstandard (or deleted)
 472    feature.  An error/warning will be issued if the currently selected
 473    standard does not contain the requested bits.  Return FAILURE if
 474    and error is generated.  */
 475
 476 try
 477 gfc_notify_std (int std, const char *format, ...)
 478 {
 479   va_list argp;
 480   bool warning;
 481
 482   warning = ((gfc_option.warn_std & std) != 0)
 483             && !inhibit_warnings;
 484   if ((gfc_option.allow_std & std) != 0
 485       && !warning)
 486     return SUCCESS;
 487
 488   if (gfc_suppress_error)
 489     return warning ? SUCCESS : FAILURE;
 490
 491   if (warning)
 492     {
 493       warning_buffer.flag = 1;
 494       warning_ptr = warning_buffer.message;
 495       use_warning_buffer = 1;
 496     }
 497   else
 498     {
 499       error_buffer.flag = 1;
 500       error_ptr = error_buffer.message;
 501       use_warning_buffer = 0;
 502     }
 503
 504   if (buffer_flag == 0)
 505     {
 506       if (warning)
 507         warnings++;
 508       else
 509         errors++;
 510     }
 511   va_start (argp, format);
 512   if (warning)
 513     error_print ("Warning:", format, argp);
 514   else
 515     error_print ("Error:", format, argp);
 516   va_end (argp);
 517
 518   error_char ('\0');
 519   return warning ? SUCCESS : FAILURE;
 520 }
 521
 522
 523 /* Immediate warning (i.e. do not buffer the warning).  */
 524
 525 void
 526 gfc_warning_now (const char *format, ...)
 527 {
 528   va_list argp;
 529   int i;
 530
 531   if (inhibit_warnings)
 532     return;
 533
 534   i = buffer_flag;
 535   buffer_flag = 0;
 536   warnings++;
 537
 538   va_start (argp, format);
 539   error_print ("Warning:", format, argp);
 540   va_end (argp);
 541
 542   error_char ('\0');
 543   buffer_flag = i;
 544 }
 545
 546
 547 /* Clear the warning flag.  */
 548
 549 void
 550 gfc_clear_warning (void)
 551 {
 552
 553   warning_buffer.flag = 0;
 554 }
 555
 556
 557 /* Check to see if any warnings have been saved.
 558    If so, print the warning.  */
 559
 560 void
 561 gfc_warning_check (void)
 562 {
 563
 564   if (warning_buffer.flag)
 565     {
 566       warnings++;
 567       fputs (warning_buffer.message, stderr);
 568       warning_buffer.flag = 0;
 569     }
 570 }
 571
 572
 573 /* Issue an error.  */
 574
 575 void
 576 gfc_error (const char *format, ...)
 577 {
 578   va_list argp;
 579
 580   if (gfc_suppress_error)
 581     return;
 582
 583   error_buffer.flag = 1;
 584   error_ptr = error_buffer.message;
 585   use_warning_buffer = 0;
 586
 587   va_start (argp, format);
 588   if (buffer_flag == 0)
 589     errors++;
 590   error_print ("Error:", format, argp);
 591   va_end (argp);
 592
 593   error_char ('\0');
 594 }
 595
 596
 597 /* Immediate error.  */
 598
 599 void
 600 gfc_error_now (const char *format, ...)
 601 {
 602   va_list argp;
 603   int i;
 604
 605   error_buffer.flag = 1;
 606   error_ptr = error_buffer.message;
 607
 608   i = buffer_flag;
 609   buffer_flag = 0;
 610   errors++;
 611
 612   va_start (argp, format);
 613   error_print ("Error:", format, argp);
 614   va_end (argp);
 615
 616   error_char ('\0');
 617   buffer_flag = i;
 618 }
 619
 620
 621 /* Fatal error, never returns.  */
 622
 623 void
 624 gfc_fatal_error (const char *format, ...)
 625 {
 626   va_list argp;
 627
 628   buffer_flag = 0;
 629
 630   va_start (argp, format);
 631   error_print ("Fatal Error:", format, argp);
 632   va_end (argp);
 633
 634   exit (3);
 635 }
 636
 637
 638 /* This shouldn't happen... but sometimes does.  */
 639
 640 void
 641 gfc_internal_error (const char *format, ...)
 642 {
 643   va_list argp;
 644
 645   buffer_flag = 0;
 646
 647   va_start (argp, format);
 648
 649   show_loci (gfc_current_locus (), NULL);
 650   error_printf ("Internal Error at (1):");
 651
 652   error_print ("", format, argp);
 653   va_end (argp);
 654
 655   exit (4);
 656 }
 657
 658
 659 /* Clear the error flag when we start to compile a source line.  */
 660
 661 void
 662 gfc_clear_error (void)
 663 {
 664
 665   error_buffer.flag = 0;
 666 }
 667
 668
 669 /* Check to see if any errors have been saved.
 670    If so, print the error.  Returns the state of error_flag.  */
 671
 672 int
 673 gfc_error_check (void)
 674 {
 675   int rc;
 676
 677   rc = error_buffer.flag;
 678
 679   if (error_buffer.flag)
 680     {
 681       errors++;
 682       fputs (error_buffer.message, stderr);
 683       error_buffer.flag = 0;
 684     }
 685
 686   return rc;
 687 }
 688
 689
 690 /* Save the existing error state.  */
 691
 692 void
 693 gfc_push_error (gfc_error_buf * err)
 694 {
 695
 696   err->flag = error_buffer.flag;
 697   if (error_buffer.flag)
 698     strcpy (err->message, error_buffer.message);
 699
 700   error_buffer.flag = 0;
 701 }
 702
 703
 704 /* Restore a previous pushed error state.  */
 705
 706 void
 707 gfc_pop_error (gfc_error_buf * err)
 708 {
 709
 710   error_buffer.flag = err->flag;
 711   if (error_buffer.flag)
 712     strcpy (error_buffer.message, err->message);
 713 }
 714
 715
 716 /* Debug wrapper for printf.  */
 717
 718 void
 719 gfc_status (const char *format, ...)
 720 {
 721   va_list argp;
 722
 723   va_start (argp, format);
 724
 725   vprintf (format, argp);
 726
 727   va_end (argp);
 728 }
 729
 730
 731 /* Subroutine for outputting a single char so that we don't have to go
 732    around creating a lot of 1-character strings.  */
 733
 734 void
 735 gfc_status_char (char c)
 736 {
 737   putchar (c);
 738 }
 739
 740
 741 /* Report the number of warnings and errors that occored to the caller.  */
 742
 743 void
 744 gfc_get_errors (int *w, int *e)
 745 {
 746
 747   if (w != NULL)
 748     *w = warnings;
 749   if (e != NULL)
 750     *e = errors;
 751 }