gcc/fortran/error.c

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