URL https://opencores.org/ocsvn/scarts/scarts/trunk

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [fortran/] [error.c] - Blame information for rev 12

Details | Compare with Previous | View Log


/* Handle errors.
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
   Foundation, Inc.
   Contributed by Andy Vaught & Niels Kristian Bech Jensen
 
This file is part of GCC.
 
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.
 
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.
 
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.  */
 
/* Handle the inevitable errors.  A major catch here is that things
   flagged as errors in one match subroutine can conceivably be legal
   elsewhere.  This means that error messages are recorded and saved
   for possible use later.  If a line does not match a legal
   construction, then the saved error message is reported.  */
 
#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
 
int gfc_suppress_error = 0;
 
static int terminal_width, buffer_flag, errors, warnings;
 
static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
 
 
/* Per-file error initialization.  */
 
void
gfc_error_init_1 (void)
{
  terminal_width = gfc_terminal_width ();
  errors = 0;
  warnings = 0;
  buffer_flag = 0;
}
 
 
/* Set the flag for buffering errors or not.  */
 
void
gfc_buffer_error (int flag)
{
  buffer_flag = flag;
}
 
 
/* Add a single character to the error buffer or output depending on
   buffer_flag.  */
 
static void
error_char (char c)
{
  if (buffer_flag)
    {
      if (cur_error_buffer->index >= cur_error_buffer->allocated)
        {
          cur_error_buffer->allocated =
            cur_error_buffer->allocated
            ? cur_error_buffer->allocated * 2 : 1000;
          cur_error_buffer->message
            = xrealloc (cur_error_buffer->message,
                        cur_error_buffer->allocated);
        }
      cur_error_buffer->message[cur_error_buffer->index++] = c;
    }
  else
    {
      if (c != 0)
        {
          /* We build up complete lines before handing things
             over to the library in order to speed up error printing.  */
          static char *line;
          static size_t allocated = 0, index = 0;
 
          if (index + 1 >= allocated)
            {
              allocated = allocated ? allocated * 2 : 1000;
              line = xrealloc (line, allocated);
            }
          line[index++] = c;
          if (c == '\n')
            {
              line[index] = '\0';
              fputs (line, stderr);
              index = 0;
            }
        }
    }
}
 
 
/* Copy a string to wherever it needs to go.  */
 
static void
error_string (const char *p)
{
  while (*p)
    error_char (*p++);
}
 
 
/* Show the file, where it was included and the source line, give a
   locus.  Calls error_printf() recursively, but the recursion is at
   most one level deep.  */
 
static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
 
static void
show_locus (int offset, locus * loc)
{
  gfc_linebuf *lb;
  gfc_file *f;
  char c, *p;
  int i, m;
 
  /* TODO: Either limit the total length and number of included files
     displayed or add buffering of arbitrary number of characters in
     error messages.  */
 
  lb = loc->lb;
  f = lb->file;
  error_printf ("In file %s:%d\n", f->filename,
#ifdef USE_MAPPED_LOCATION
                LOCATION_LINE (lb->location)
#else
                lb->linenum
#endif
                );
 
  for (;;)
    {
      i = f->inclusion_line;
 
      f = f->included_by;
      if (f == NULL) break;
 
      error_printf ("    Included at %s:%d\n", f->filename, i);
    }
 
  /* Show the line itself, taking care not to print more than what can
     show up on the terminal.  Tabs are converted to spaces.  */
 
  p = lb->line + offset;
  i = strlen (p);
  if (i > terminal_width)
    i = terminal_width - 1;
 
  for (; i > 0; i--)
    {
      c = *p++;
      if (c == '\t')
        c = ' ';
 
      if (ISPRINT (c))
        error_char (c);
      else
        {
          error_char ('\\');
          error_char ('x');
 
          m = ((c >> 4) & 0x0F) + '0';
          if (m > '9')
            m += 'A' - '9' - 1;
          error_char (m);
 
          m = (c & 0x0F) + '0';
          if (m > '9')
            m += 'A' - '9' - 1;
          error_char (m);
        }
    }
 
  error_char ('\n');
}
 
 
/* As part of printing an error, we show the source lines that caused
   the problem.  We show at least one, possibly two loci.  If we're
   showing two loci and they both refer to the same file and line, we
   only print the line once.  */
 
static void
show_loci (locus * l1, locus * l2)
{
  int offset, flag, i, m, c1, c2, cmax;
 
  if (l1 == NULL)
    {
      error_printf ("<During initialization>\n");
      return;
    }
 
  c1 = l1->nextc - l1->lb->line;
  c2 = 0;
  if (l2 == NULL)
    goto separate;
 
  c2 = l2->nextc - l2->lb->line;
 
  if (c1 < c2)
    m = c2 - c1;
  else
    m = c1 - c2;
 
 
  if (l1->lb != l2->lb || m > terminal_width - 10)
    goto separate;
 
  offset = 0;
  cmax = (c1 < c2) ? c2 : c1;
  if (cmax > terminal_width - 5)
    offset = cmax - terminal_width + 5;
 
  if (offset < 0)
    offset = 0;
 
  c1 -= offset;
  c2 -= offset;
 
  show_locus (offset, l1);
 
  /* Arrange that '1' and '2' will show up even if the two columns are equal.  */
  for (i = 1; i <= cmax; i++)
    {
      flag = 0;
      if (i == c1)
        {
          error_char ('1');
          flag = 1;
        }
      if (i == c2)
        {
          error_char ('2');
          flag = 1;
        }
      if (flag == 0)
        error_char (' ');
    }
 
  error_char ('\n');
 
  return;
 
separate:
  offset = 0;
 
  if (c1 > terminal_width - 5)
    {
      offset = c1 - 5;
      if (offset < 0)
        offset = 0;
      c1 = c1 - offset;
    }
 
  show_locus (offset, l1);
  for (i = 1; i < c1; i++)
    error_char (' ');
 
  error_char ('1');
  error_char ('\n');
 
  if (l2 != NULL)
    {
      offset = 0;
 
      if (c2 > terminal_width - 20)
        {
          offset = c2 - 20;
          if (offset < 0)
            offset = 0;
          c2 = c2 - offset;
        }
 
      show_locus (offset, l2);
 
      for (i = 1; i < c2; i++)
        error_char (' ');
 
      error_char ('2');
      error_char ('\n');
    }
}
 
 
/* Workhorse for the error printing subroutines.  This subroutine is
   inspired by g77's error handling and is similar to printf() with
   the following %-codes:
 
   %c Character, %d Integer, %s String, %% Percent
   %L  Takes locus argument
   %C  Current locus (no argument)
 
   If a locus pointer is given, the actual source line is printed out
   and the column is indicated.  Since we want the error message at
   the bottom of any source file information, we must scan the
   argument list twice.  A maximum of two locus arguments are
   permitted.  */
 
#define IBUF_LEN 30
#define MAX_ARGS 10
 
static void ATTRIBUTE_GCC_GFC(2,0)
error_print (const char *type, const char *format0, va_list argp)
{
  char c, *p, int_buf[IBUF_LEN], c_arg[MAX_ARGS], *cp_arg[MAX_ARGS];
  int i, n, have_l1, i_arg[MAX_ARGS];
  locus *l1, *l2, *loc;
  const char *format;
 
  l1 = l2 = loc = NULL;
 
  have_l1 = 0;
 
  n = 0;
  format = format0;
 
  while (*format)
    {
      c = *format++;
      if (c == '%')
        {
          c = *format++;
 
          switch (c)
            {
            case '%':
              break;
 
            case 'L':
              loc = va_arg (argp, locus *);
              /* Fall through */
 
            case 'C':
              if (c == 'C')
                loc = &gfc_current_locus;
 
              if (have_l1)
                {
                  l2 = loc;
                }
              else
                {
                  l1 = loc;
                  have_l1 = 1;
                }
              break;
 
            case 'd':
            case 'i':
              i_arg[n++] = va_arg (argp, int);
              break;
 
            case 'c':
              c_arg[n++] = va_arg (argp, int);
              break;
 
            case 's':
              cp_arg[n++] = va_arg (argp, char *);
              break;
            }
        }
    }
 
  /* Show the current loci if we have to.  */
  if (have_l1)
    show_loci (l1, l2);
  error_string (type);
  error_char (' ');
 
  have_l1 = 0;
  format = format0;
  n = 0;
 
  for (; *format; format++)
    {
      if (*format != '%')
        {
          error_char (*format);
          continue;
        }
 
      format++;
      switch (*format)
        {
        case '%':
          error_char ('%');
          break;
 
        case 'c':
          error_char (c_arg[n++]);
          break;
 
        case 's':
          error_string (cp_arg[n++]);
          break;
 
        case 'i':
        case 'd':
          i = i_arg[n++];
 
          if (i < 0)
            {
              i = -i;
              error_char ('-');
            }
 
          p = int_buf + IBUF_LEN - 1;
          *p-- = '\0';
 
          if (i == 0)
            *p-- = '0';
 
          while (i > 0)
            {
              *p-- = i % 10 + '0';
              i = i / 10;
            }
 
          error_string (p + 1);
          break;
 
        case 'C':               /* Current locus */
        case 'L':               /* Specified locus */
          error_string (have_l1 ? "(2)" : "(1)");
          have_l1 = 1;
          break;
        }
    }
 
  error_char ('\n');
}
 
 
/* Wrapper for error_print().  */
 
static void
error_printf (const char *nocmsgid, ...)
{
  va_list argp;
 
  va_start (argp, nocmsgid);
  error_print ("", _(nocmsgid), argp);
  va_end (argp);
}
 
 
/* Issue a warning.  */
 
void
gfc_warning (const char *nocmsgid, ...)
{
  va_list argp;
 
  if (inhibit_warnings)
    return;
 
  warning_buffer.flag = 1;
  warning_buffer.index = 0;
  cur_error_buffer = &warning_buffer;
 
  va_start (argp, nocmsgid);
  if (buffer_flag == 0)
    warnings++;
  error_print (_("Warning:"), _(nocmsgid), argp);
  va_end (argp);
 
  error_char ('\0');
}
 
 
/* Whether, for a feature included in a given standard set (GFC_STD_*),
   we should issue an error or a warning, or be quiet.  */
 
notification
gfc_notification_std (int std)
{
  bool warning;
 
  warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
  if ((gfc_option.allow_std & std) != 0 && !warning)
    return SILENT;
 
  return warning ? WARNING : ERROR;
}
 
 
/* Possibly issue a warning/error about use of a nonstandard (or deleted)
   feature.  An error/warning will be issued if the currently selected
   standard does not contain the requested bits.  Return FAILURE if
   an error is generated.  */
 
try
gfc_notify_std (int std, const char *nocmsgid, ...)
{
  va_list argp;
  bool warning;
 
  warning = ((gfc_option.warn_std & std) != 0)
            && !inhibit_warnings;
  if ((gfc_option.allow_std & std) != 0
      && !warning)
    return SUCCESS;
 
  if (gfc_suppress_error)
    return warning ? SUCCESS : FAILURE;
 
  cur_error_buffer = warning ? &warning_buffer : &error_buffer;
  cur_error_buffer->flag = 1;
  cur_error_buffer->index = 0;
 
  if (buffer_flag == 0)
    {
      if (warning)
        warnings++;
      else
        errors++;
    }
  va_start (argp, nocmsgid);
  if (warning)
    error_print (_("Warning:"), _(nocmsgid), argp);
  else
    error_print (_("Error:"), _(nocmsgid), argp);
  va_end (argp);
 
  error_char ('\0');
  return warning ? SUCCESS : FAILURE;
}
 
 
/* Immediate warning (i.e. do not buffer the warning).  */
 
void
gfc_warning_now (const char *nocmsgid, ...)
{
  va_list argp;
  int i;
 
  if (inhibit_warnings)
    return;
 
  i = buffer_flag;
  buffer_flag = 0;
  warnings++;
 
  va_start (argp, nocmsgid);
  error_print (_("Warning:"), _(nocmsgid), argp);
  va_end (argp);
 
  error_char ('\0');
  buffer_flag = i;
}
 
 
/* Clear the warning flag.  */
 
void
gfc_clear_warning (void)
{
  warning_buffer.flag = 0;
}
 
 
/* Check to see if any warnings have been saved.
   If so, print the warning.  */
 
void
gfc_warning_check (void)
{
  if (warning_buffer.flag)
    {
      warnings++;
      if (warning_buffer.message != NULL)
        fputs (warning_buffer.message, stderr);
      warning_buffer.flag = 0;
    }
}
 
 
/* Issue an error.  */
 
void
gfc_error (const char *nocmsgid, ...)
{
  va_list argp;
 
  if (gfc_suppress_error)
    return;
 
  error_buffer.flag = 1;
  error_buffer.index = 0;
  cur_error_buffer = &error_buffer;
 
  va_start (argp, nocmsgid);
  if (buffer_flag == 0)
    errors++;
  error_print (_("Error:"), _(nocmsgid), argp);
  va_end (argp);
 
  error_char ('\0');
}
 
 
/* Immediate error.  */
 
void
gfc_error_now (const char *nocmsgid, ...)
{
  va_list argp;
  int i;
 
  error_buffer.flag = 1;
  error_buffer.index = 0;
  cur_error_buffer = &error_buffer;
 
  i = buffer_flag;
  buffer_flag = 0;
  errors++;
 
  va_start (argp, nocmsgid);
  error_print (_("Error:"), _(nocmsgid), argp);
  va_end (argp);
 
  error_char ('\0');
  buffer_flag = i;
 
  if (flag_fatal_errors)
    exit (1);
}
 
 
/* Fatal error, never returns.  */
 
void
gfc_fatal_error (const char *nocmsgid, ...)
{
  va_list argp;
 
  buffer_flag = 0;
 
  va_start (argp, nocmsgid);
  error_print (_("Fatal Error:"), _(nocmsgid), argp);
  va_end (argp);
 
  exit (3);
}
 
 
/* This shouldn't happen... but sometimes does.  */
 
void
gfc_internal_error (const char *format, ...)
{
  va_list argp;
 
  buffer_flag = 0;
 
  va_start (argp, format);
 
  show_loci (&gfc_current_locus, NULL);
  error_printf ("Internal Error at (1):");
 
  error_print ("", format, argp);
  va_end (argp);
 
  exit (4);
}
 
 
/* Clear the error flag when we start to compile a source line.  */
 
void
gfc_clear_error (void)
{
  error_buffer.flag = 0;
}
 
 
/* Check to see if any errors have been saved.
   If so, print the error.  Returns the state of error_flag.  */
 
int
gfc_error_check (void)
{
  int rc;
 
  rc = error_buffer.flag;
 
  if (error_buffer.flag)
    {
      errors++;
      if (error_buffer.message != NULL)
        fputs (error_buffer.message, stderr);
      error_buffer.flag = 0;
 
      if (flag_fatal_errors)
        exit (1);
    }
 
  return rc;
}
 
 
/* Save the existing error state.  */
 
void
gfc_push_error (gfc_error_buf * err)
{
  err->flag = error_buffer.flag;
  if (error_buffer.flag)
    err->message = xstrdup (error_buffer.message);
 
  error_buffer.flag = 0;
}
 
 
/* Restore a previous pushed error state.  */
 
void
gfc_pop_error (gfc_error_buf * err)
{
  error_buffer.flag = err->flag;
  if (error_buffer.flag)
    {
      size_t len = strlen (err->message) + 1;
      gcc_assert (len <= error_buffer.allocated);
      memcpy (error_buffer.message, err->message, len);
      gfc_free (err->message);
    }
}
 
 
/* Free a pushed error state, but keep the current error state.  */
 
void
gfc_free_error (gfc_error_buf * err)
{
  if (err->flag)
    gfc_free (err->message);
}
 
 
/* Debug wrapper for printf.  */
 
void
gfc_status (const char *cmsgid, ...)
{
  va_list argp;
 
  va_start (argp, cmsgid);
 
  vprintf (_(cmsgid), argp);
 
  va_end (argp);
}
 
 
/* Subroutine for outputting a single char so that we don't have to go
   around creating a lot of 1-character strings.  */
 
void
gfc_status_char (char c)
{
  putchar (c);
}
 
 
/* Report the number of warnings and errors that occurred to the caller.  */
 
void
gfc_get_errors (int *w, int *e)
{
  if (w != NULL)
    *w = warnings;
  if (e != NULL)
    *e = errors;
}

Browse

Tools

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [fortran/] [error.c] - Blame information for rev 12

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