OSDN Git Service

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