/* Character scanner.
- Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
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, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* Set of subroutines to (ultimately) return the next character to the
various matching subroutines. This file's job is to read files and
new characters and do a lot of jumping backwards. */
#include "config.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <strings.h>
-
+#include "system.h"
#include "gfortran.h"
+#include "toplev.h"
/* Structure for holding module and include file search path. */
typedef struct gfc_directorylist
static gfc_file *file_head, *current_file;
-static int continue_flag, end_flag;
+static int continue_flag, end_flag, openmp_flag;
+static int continue_count, continue_line;
+static locus openmp_locus;
gfc_source_form gfc_current_form;
static gfc_linebuf *line_head, *line_tail;
locus gfc_current_locus;
-char *gfc_source_file;
-
+const char *gfc_source_file;
+static FILE *gfc_src_file;
+static char *gfc_src_preprocessor_lines[2];
+
+extern int pedantic;
/* Main scanner initialization. */
line_head = NULL;
line_tail = NULL;
+ continue_count = 0;
+ continue_line = 0;
+
end_flag = 0;
}
}
/* Opens file for reading, searching through the include directories
- given if necessary. */
+ given if necessary. If the include_cwd argument is true, we try
+ to open the file in the current directory first. */
FILE *
-gfc_open_included_file (const char *name)
+gfc_open_included_file (const char *name, const bool include_cwd)
{
- char fullname[PATH_MAX];
+ char *fullname;
gfc_directorylist *p;
FILE *f;
- f = gfc_open_file (name);
- if (f != NULL)
- return f;
+ if (include_cwd)
+ {
+ f = gfc_open_file (name);
+ if (f != NULL)
+ return f;
+ }
for (p = include_dirs; p; p = p->next)
{
- if (strlen (p->path) + strlen (name) + 1 > PATH_MAX)
- continue;
-
+ fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
strcpy (fullname, p->path);
strcat (fullname, name);
/* Comment lines are null lines, lines containing only blanks or lines
- on which the first nonblank line is a '!'. */
+ on which the first nonblank line is a '!'.
+ Return true if !$ openmp conditional compilation sentinel was
+ seen. */
-static void
+static bool
skip_free_comments (void)
{
locus start;
char c;
+ int at_bol;
for (;;)
{
+ at_bol = gfc_at_bol ();
start = gfc_current_locus;
if (gfc_at_eof ())
break;
do
- {
- c = next_char ();
- }
+ c = next_char ();
while (gfc_is_whitespace (c));
if (c == '\n')
if (c == '!')
{
+ /* If -fopenmp, we need to handle here 2 things:
+ 1) don't treat !$omp as comments, but directives
+ 2) handle OpenMP conditional compilation, where
+ !$ should be treated as 2 spaces (for initial lines
+ only if followed by space). */
+ if (gfc_option.flag_openmp && at_bol)
+ {
+ locus old_loc = gfc_current_locus;
+ if (next_char () == '$')
+ {
+ c = next_char ();
+ if (c == 'o' || c == 'O')
+ {
+ if (((c = next_char ()) == 'm' || c == 'M')
+ && ((c = next_char ()) == 'p' || c == 'P')
+ && ((c = next_char ()) == ' ' || continue_flag))
+ {
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ if (c != '\n' && c != '!')
+ {
+ openmp_flag = 1;
+ openmp_locus = old_loc;
+ gfc_current_locus = start;
+ return false;
+ }
+ }
+ gfc_current_locus = old_loc;
+ next_char ();
+ c = next_char ();
+ }
+ if (continue_flag || c == ' ')
+ {
+ gfc_current_locus = old_loc;
+ next_char ();
+ openmp_flag = 0;
+ return true;
+ }
+ }
+ gfc_current_locus = old_loc;
+ }
skip_comment_line ();
continue;
}
break;
}
+ if (openmp_flag && at_bol)
+ openmp_flag = 0;
gfc_current_locus = start;
+ return false;
}
/* Skip comment lines in fixed source mode. We have the same rules as
in skip_free_comment(), except that we can have a 'c', 'C' or '*'
- in column 1. and a '!' cannot be in* column 6. */
+ in column 1, and a '!' cannot be in column 6. Also, we deal with
+ lines with 'd' or 'D' in column 1, if the user requested this. */
static void
skip_fixed_comments (void)
int col;
char c;
+ if (! gfc_at_bol ())
+ {
+ start = gfc_current_locus;
+ if (! gfc_at_eof ())
+ {
+ do
+ c = next_char ();
+ while (gfc_is_whitespace (c));
+
+ if (c == '\n')
+ gfc_advance_line ();
+ else if (c == '!')
+ skip_comment_line ();
+ }
+
+ if (! gfc_at_bol ())
+ {
+ gfc_current_locus = start;
+ return;
+ }
+ }
+
for (;;)
{
start = gfc_current_locus;
if (c == '!' || c == 'c' || c == 'C' || c == '*')
{
+ /* If -fopenmp, we need to handle here 2 things:
+ 1) don't treat !$omp|c$omp|*$omp as comments, but directives
+ 2) handle OpenMP conditional compilation, where
+ !$|c$|*$ should be treated as 2 spaces if the characters
+ in columns 3 to 6 are valid fixed form label columns
+ characters. */
+ if (gfc_option.flag_openmp)
+ {
+ if (next_char () == '$')
+ {
+ c = next_char ();
+ if (c == 'o' || c == 'O')
+ {
+ if (((c = next_char ()) == 'm' || c == 'M')
+ && ((c = next_char ()) == 'p' || c == 'P'))
+ {
+ c = next_char ();
+ if (c != '\n'
+ && ((openmp_flag && continue_flag)
+ || c == ' ' || c == '0'))
+ {
+ c = next_char ();
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ if (c != '\n' && c != '!')
+ {
+ /* Canonicalize to *$omp. */
+ *start.nextc = '*';
+ openmp_flag = 1;
+ gfc_current_locus = start;
+ return;
+ }
+ }
+ }
+ }
+ else
+ {
+ int digit_seen = 0;
+
+ for (col = 3; col < 6; col++, c = next_char ())
+ if (c == ' ')
+ continue;
+ else if (c < '0' || c > '9')
+ break;
+ else
+ digit_seen = 1;
+
+ if (col == 6 && c != '\n'
+ && ((continue_flag && !digit_seen)
+ || c == ' ' || c == '0'))
+ {
+ gfc_current_locus = start;
+ start.nextc[0] = ' ';
+ start.nextc[1] = ' ';
+ continue;
+ }
+ }
+ }
+ gfc_current_locus = start;
+ }
skip_comment_line ();
continue;
}
+ if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
+ {
+ if (gfc_option.flag_d_lines == 0)
+ {
+ skip_comment_line ();
+ continue;
+ }
+ else
+ *start.nextc = c = ' ';
+ }
+
col = 1;
- do
+
+ while (gfc_is_whitespace (c))
{
c = next_char ();
col++;
}
- while (gfc_is_whitespace (c));
if (c == '\n')
{
break;
}
+ openmp_flag = 0;
gfc_current_locus = start;
}
-/* Skips the current line if it is a comment. Assumes that we are at
- the start of the current line. */
+/* Skips the current line if it is a comment. */
void
gfc_skip_comments (void)
{
-
- if (!gfc_at_bol () || gfc_current_form == FORM_FREE)
+ if (gfc_current_form == FORM_FREE)
skip_free_comments ();
else
skip_fixed_comments ();
gfc_next_char_literal (int in_string)
{
locus old_loc;
- int i, c;
+ int i, c, prev_openmp_flag;
continue_flag = 0;
restart:
c = next_char ();
if (gfc_at_end ())
- return c;
+ {
+ continue_count = 0;
+ return c;
+ }
if (gfc_current_form == FORM_FREE)
{
+ bool openmp_cond_flag;
if (!in_string && c == '!')
{
+ if (openmp_flag
+ && memcmp (&gfc_current_locus, &openmp_locus,
+ sizeof (gfc_current_locus)) == 0)
+ goto done;
+
/* This line can't be continued */
do
{
}
while (c != '\n');
+ /* Avoid truncation warnings for comment ending lines. */
+ gfc_current_locus.lb->truncated = 0;
+
goto done;
}
goto done;
/* If the next nonblank character is a ! or \n, we've got a
- continuation line. */
+ continuation line. */
old_loc = gfc_current_locus;
c = next_char ();
c = next_char ();
/* Character constants to be continued cannot have commentary
- after the '&'. */
+ after the '&'. */
if (in_string && c != '\n')
{
goto done;
}
+ prev_openmp_flag = openmp_flag;
continue_flag = 1;
if (c == '!')
skip_comment_line ();
else
gfc_advance_line ();
- /* We've got a continuation line and need to find where it continues.
- First eat any comment lines. */
- gfc_skip_comments ();
+ /* We've got a continuation line. If we are on the very next line after
+ the last continuation, increment the continuation line count and
+ check whether the limit has been exceeded. */
+ if (gfc_current_locus.lb->linenum == continue_line + 1)
+ {
+ if (++continue_count == gfc_option.max_continue_free)
+ {
+ if (gfc_notification_std (GFC_STD_GNU)
+ || pedantic)
+ gfc_warning ("Limit of %d continuations exceeded in statement at %C",
+ gfc_option.max_continue_free);
+ }
+ }
+ continue_line = gfc_current_locus.lb->linenum;
+
+ /* Now find where it continues. First eat any comment lines. */
+ openmp_cond_flag = skip_free_comments ();
+
+ if (prev_openmp_flag != openmp_flag)
+ {
+ gfc_current_locus = old_loc;
+ openmp_flag = prev_openmp_flag;
+ c = '&';
+ goto done;
+ }
/* Now that we have a non-comment line, probe ahead for the
- first non-whitespace character. If it is another '&', then
- reading starts at the next character, otherwise we must back
- up to where the whitespace started and resume from there. */
+ first non-whitespace character. If it is another '&', then
+ reading starts at the next character, otherwise we must back
+ up to where the whitespace started and resume from there. */
old_loc = gfc_current_locus;
while (gfc_is_whitespace (c))
c = next_char ();
- if (c != '&')
- gfc_current_locus = old_loc;
+ if (openmp_flag)
+ {
+ for (i = 0; i < 5; i++, c = next_char ())
+ {
+ gcc_assert (TOLOWER (c) == "!$omp"[i]);
+ if (i == 4)
+ old_loc = gfc_current_locus;
+ }
+ while (gfc_is_whitespace (c))
+ c = next_char ();
+ }
+ if (c != '&')
+ {
+ if (in_string)
+ {
+ if (gfc_option.warn_ampersand)
+ gfc_warning_now ("Missing '&' in continued character constant at %C");
+ gfc_current_locus.nextc--;
+ }
+ /* Both !$omp and !$ -fopenmp continuation lines have & on the
+ continuation line only optionally. */
+ else if (openmp_flag || openmp_cond_flag)
+ gfc_current_locus.nextc--;
+ else
+ {
+ c = ' ';
+ gfc_current_locus = old_loc;
+ goto done;
+ }
+ }
}
else
{
c = next_char ();
}
while (c != '\n');
+
+ /* Avoid truncation warnings for comment ending lines. */
+ gfc_current_locus.lb->truncated = 0;
}
if (c != '\n')
goto done;
+ prev_openmp_flag = openmp_flag;
continue_flag = 1;
old_loc = gfc_current_locus;
gfc_advance_line ();
- gfc_skip_comments ();
+ skip_fixed_comments ();
/* See if this line is a continuation line. */
- for (i = 0; i < 5; i++)
+ if (openmp_flag != prev_openmp_flag)
{
- c = next_char ();
- if (c != ' ')
- goto not_continuation;
+ openmp_flag = prev_openmp_flag;
+ goto not_continuation;
}
+ if (!openmp_flag)
+ for (i = 0; i < 5; i++)
+ {
+ c = next_char ();
+ if (c != ' ')
+ goto not_continuation;
+ }
+ else
+ for (i = 0; i < 5; i++)
+ {
+ c = next_char ();
+ if (TOLOWER (c) != "*$omp"[i])
+ goto not_continuation;
+ }
+
c = next_char ();
- if (c == '0' || c == ' ')
+ if (c == '0' || c == ' ' || c == '\n')
goto not_continuation;
+
+ /* We've got a continuation line. If we are on the very next line after
+ the last continuation, increment the continuation line count and
+ check whether the limit has been exceeded. */
+ if (gfc_current_locus.lb->linenum == continue_line + 1)
+ {
+ if (++continue_count == gfc_option.max_continue_fixed)
+ {
+ if (gfc_notification_std (GFC_STD_GNU)
+ || pedantic)
+ gfc_warning ("Limit of %d continuations exceeded in statement at %C",
+ gfc_option.max_continue_fixed);
+ }
+ }
+
+ if (continue_line < gfc_current_locus.lb->linenum)
+ continue_line = gfc_current_locus.lb->linenum;
}
/* Ready to read first character of continuation line, which might
gfc_current_locus = old_loc;
done:
+ if (c == '\n')
+ continue_count = 0;
continue_flag = 0;
return c;
}
if (c == delim)
break;
if (c == '\n')
- goto done;
+ return;
if (c == '\\')
{
c = next_char ();
if (c == '\n')
- goto done;
+ return;
}
}
if (gfc_at_eof ())
break;
}
-
-done:
- if (c == '\n')
- gfc_advance_line ();
}
void
gfc_gobble_whitespace (void)
{
+ static int linenum = 0;
locus old_loc;
int c;
{
old_loc = gfc_current_locus;
c = gfc_next_char_literal (0);
+ /* Issue a warning for nonconforming tabs. We keep track of the line
+ number because the Fortran matchers will often back up and the same
+ line will be scanned multiple times. */
+ if (!gfc_option.warn_tabs && c == '\t')
+ {
+#ifdef USE_MAPPED_LOCATION
+ int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
+#else
+ int cur_linenum = gfc_current_locus.lb->linenum;
+#endif
+ if (cur_linenum != linenum)
+ {
+ linenum = cur_linenum;
+ gfc_warning_now ("Nonconforming tab character at %C");
+ }
+ }
}
while (gfc_is_whitespace (c));
need be.
In fixed mode, we expand a tab that occurs within the statement
label region to expand to spaces that leave the next character in
- the source region. */
+ the source region.
+ load_line returns whether the line was truncated.
-static void
-load_line (FILE * input, char **pbuf, char *filename, int linenum)
+ NOTE: The error machinery isn't available at this point, so we can't
+ easily report line and column numbers consistent with other
+ parts of gfortran. */
+
+static int
+load_line (FILE * input, char **pbuf, int *pbuflen)
{
- int c, maxlen, i, trunc_flag, preprocessor_flag;
- static int buflen = 0;
+ static int linenum = 0, current_line = 1;
+ int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
+ int trunc_flag = 0, seen_comment = 0;
+ int seen_printable = 0, seen_ampersand = 0;
char *buffer;
/* Determine the maximum allowed line length. */
if (gfc_current_form == FORM_FREE)
- maxlen = GFC_MAX_LINE;
- else
+ maxlen = gfc_option.free_line_length;
+ else if (gfc_current_form == FORM_FIXED)
maxlen = gfc_option.fixed_line_length;
+ else
+ maxlen = 72;
if (*pbuf == NULL)
{
- /* Allocate the line buffer, storing its length into buflen. */
+ /* Allocate the line buffer, storing its length into buflen.
+ Note that if maxlen==0, indicating that arbitrary-length lines
+ are allowed, the buffer will be reallocated if this length is
+ insufficient; since 132 characters is the length of a standard
+ free-form line, we use that as a starting guess. */
if (maxlen > 0)
buflen = maxlen;
else
- buflen = GFC_MAX_LINE;
+ buflen = 132;
*pbuf = gfc_getmem (buflen + 1);
}
if (c == EOF)
break;
if (c == '\n')
- break;
+ {
+ /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
+ if (gfc_current_form == FORM_FREE
+ && !seen_printable && seen_ampersand)
+ {
+ if (pedantic)
+ gfc_error_now
+ ("'&' not allowed by itself in line %d", current_line);
+ else
+ gfc_warning_now
+ ("'&' not allowed by itself in line %d", current_line);
+ }
+ break;
+ }
if (c == '\r')
continue; /* Gobble characters. */
break;
}
+ /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
+ if (c == '&')
+ seen_ampersand = 1;
+
+ if ((c != ' ' && c != '&' && c != '!') || (c == '!' && !seen_ampersand))
+ seen_printable = 1;
+
+ if (gfc_current_form == FORM_FREE
+ && c == '!' && !seen_printable && seen_ampersand)
+ {
+ if (pedantic)
+ gfc_error_now (
+ "'&' not allowed by itself with comment in line %d", current_line);
+ else
+ gfc_warning_now (
+ "'&' not allowed by itself with comment in line %d", current_line);
+ seen_printable = 1;
+ }
+
+ /* Is this a fixed-form comment? */
+ if (gfc_current_form == FORM_FIXED && i == 0
+ && (c == '*' || c == 'c' || c == 'd'))
+ seen_comment = 1;
+
if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
- { /* Tab expansion. */
+ {
+ if (!gfc_option.warn_tabs && seen_comment == 0
+ && current_line != linenum)
+ {
+ linenum = current_line;
+ gfc_warning_now (
+ "Nonconforming tab character in column 1 of line %d", linenum);
+ }
+
while (i <= 6)
{
*buffer++ = ' ';
*buffer++ = c;
i++;
- if (i >= buflen && (maxlen == 0 || preprocessor_flag))
+ if (maxlen == 0 || preprocessor_flag)
{
- /* Reallocate line buffer to double size to hold the
- overlong line. */
- buflen = buflen * 2;
- *pbuf = xrealloc (*pbuf, buflen);
- buffer = (*pbuf)+i;
+ if (i >= buflen)
+ {
+ /* Reallocate line buffer to double size to hold the
+ overlong line. */
+ buflen = buflen * 2;
+ *pbuf = xrealloc (*pbuf, buflen + 1);
+ buffer = (*pbuf)+i;
+ }
}
- else if (i >= buflen)
- {
+ else if (i >= maxlen)
+ {
/* Truncate the rest of the line. */
- trunc_flag = 1;
-
for (;;)
{
c = fgetc (input);
if (c == '\n' || c == EOF)
break;
- if (gfc_option.warn_line_truncation
- && trunc_flag
- && !gfc_is_whitespace (c))
- {
- gfc_warning_now ("%s:%d: Line is being truncated",
- filename, linenum);
- trunc_flag = 0;
- }
+ trunc_flag = 1;
}
ungetc ('\n', input);
/* Pad lines to the selected line length in fixed form. */
if (gfc_current_form == FORM_FIXED
- && gfc_option.fixed_line_length > 0
+ && gfc_option.fixed_line_length != 0
&& !preprocessor_flag
&& c != EOF)
- while (i++ < buflen)
- *buffer++ = ' ';
+ {
+ while (i++ < maxlen)
+ *buffer++ = ' ';
+ }
*buffer = '\0';
+ *pbuflen = buflen;
+ current_line++;
+
+ return trunc_flag;
}
the file stack. */
static gfc_file *
-get_file (char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
+get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
{
gfc_file *f;
int i, line;
char *filename;
gfc_file *f;
- int escaped;
+ int escaped, unescape;
c++;
while (*c == ' ' || *c == '\t')
line = atoi (c);
- /* Set new line number. */
- current_file->line = line;
-
- c = strchr (c, ' ');
+ c = strchr (c, ' ');
if (c == NULL)
- /* No file name given. */
- return;
-
-
+ {
+ /* No file name given. Set new line number. */
+ current_file->line = line;
+ return;
+ }
/* Skip spaces. */
while (*c == ' ' || *c == '\t')
filename = c;
/* Make filename end at quote. */
+ unescape = 0;
escaped = false;
while (*c && ! (! escaped && *c == '"'))
{
if (escaped)
escaped = false;
- else
- escaped = *c == '\\';
+ else if (*c == '\\')
+ {
+ escaped = true;
+ unescape++;
+ }
++c;
}
*c++ = '\0';
+ /* Undo effects of cpp_quote_string. */
+ if (unescape)
+ {
+ char *s = filename;
+ char *d = gfc_getmem (c - filename - unescape);
+ filename = d;
+ while (*s)
+ {
+ if (*s == '\\')
+ *d++ = *++s;
+ else
+ *d++ = *s;
+ s++;
+ }
+ *d = '\0';
+ }
/* Get flags. */
-
- flag[1] = flag[2] = flag[3] = flag[4] = flag[5] = false;
+
+ flag[1] = flag[2] = flag[3] = flag[4] = false;
for (;;)
{
if (1 <= i && i <= 4)
flag[i] = true;
}
-
+
/* Interpret flags. */
-
- if (flag[1] || flag[3]) /* Starting new file. */
+
+ if (flag[1]) /* Starting new file. */
{
f = get_file (filename, LC_RENAME);
f->up = current_file;
current_file = f;
}
-
+
if (flag[2]) /* Ending current file. */
{
+ if (!current_file->up
+ || strcmp (current_file->up->filename, filename) != 0)
+ {
+ gfc_warning_now ("%s:%d: file %s left but not entered",
+ current_file->filename, current_file->line,
+ filename);
+ if (unescape)
+ gfc_free (filename);
+ return;
+ }
current_file = current_file->up;
}
-
+
/* The name of the file can be a temporary file produced by
cpp. Replace the name if it is different. */
-
+
if (strcmp (current_file->filename, filename) != 0)
{
gfc_free (current_file->filename);
strcpy (current_file->filename, filename);
}
+ /* Set new line number. */
+ current_file->line = line;
+ if (unescape)
+ gfc_free (filename);
return;
bad_cpp_line:
- gfc_warning_now ("%s:%d: Illegal preprocessor directive",
+ gfc_warning_now ("%s:%d: Illegal preprocessor directive",
current_file->filename, current_file->line);
current_file->line++;
}
-static try load_file (char *, bool);
+static try load_file (const char *, bool);
/* include_line()-- Checks a line buffer to see if it is an include
line. If so, we call load_file() recursively to load the included
include_line (char *line)
{
char quote, *c, *begin, *stop;
-
+
c = line;
+
+ if (gfc_option.flag_openmp)
+ {
+ if (gfc_current_form == FORM_FREE)
+ {
+ while (*c == ' ' || *c == '\t')
+ c++;
+ if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
+ c += 3;
+ }
+ else
+ {
+ if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
+ && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
+ c += 3;
+ }
+ }
+
while (*c == ' ' || *c == '\t')
c++;
/* Load a file into memory by calling load_line until the file ends. */
static try
-load_file (char *filename, bool initial)
+load_file (const char *filename, bool initial)
{
char *line;
gfc_linebuf *b;
gfc_file *f;
FILE *input;
- int len;
+ int len, line_len;
for (f = current_file; f; f = f->up)
if (strcmp (filename, f->filename) == 0)
if (initial)
{
- input = gfc_open_file (filename);
+ if (gfc_src_file)
+ {
+ input = gfc_src_file;
+ gfc_src_file = NULL;
+ }
+ else
+ input = gfc_open_file (filename);
if (input == NULL)
{
gfc_error_now ("Can't open file '%s'", filename);
}
else
{
- input = gfc_open_included_file (filename);
+ input = gfc_open_included_file (filename, false);
if (input == NULL)
{
gfc_error_now ("Can't open included file '%s'", filename);
current_file = f;
current_file->line = 1;
line = NULL;
+ line_len = 0;
+
+ if (initial && gfc_src_preprocessor_lines[0])
+ {
+ preprocessor_line (gfc_src_preprocessor_lines[0]);
+ gfc_free (gfc_src_preprocessor_lines[0]);
+ gfc_src_preprocessor_lines[0] = NULL;
+ if (gfc_src_preprocessor_lines[1])
+ {
+ preprocessor_line (gfc_src_preprocessor_lines[1]);
+ gfc_free (gfc_src_preprocessor_lines[1]);
+ gfc_src_preprocessor_lines[1] = NULL;
+ }
+ }
- for (;;)
+ for (;;)
{
- load_line (input, &line, filename, current_file->line);
+ int trunc = load_line (input, &line, &line_len);
len = strlen (line);
if (feof (input) && len == 0)
b->linenum = current_file->line++;
#endif
b->file = current_file;
+ b->truncated = trunc;
strcpy (b->line, line);
if (line_head == NULL)
}
-/* Determine the source form from the filename extension. We assume
- case insensitivity. */
-
-static gfc_source_form
-form_from_filename (const char *filename)
-{
-
- static const struct
- {
- const char *extension;
- gfc_source_form form;
- }
- exttype[] =
- {
- {
- ".f90", FORM_FREE}
- ,
- {
- ".f95", FORM_FREE}
- ,
- {
- ".f", FORM_FIXED}
- ,
- {
- ".for", FORM_FIXED}
- ,
- {
- "", FORM_UNKNOWN}
- }; /* sentinel value */
-
- gfc_source_form f_form;
- const char *fileext;
- int i;
-
- /* Find end of file name. */
- i = 0;
- while ((i < PATH_MAX) && (filename[i] != '\0'))
- i++;
-
- /* Improperly terminated or too-long filename. */
- if (i == PATH_MAX)
- return FORM_UNKNOWN;
-
- /* Find last period. */
- while (i >= 0 && (filename[i] != '.'))
- i--;
-
- /* Did we see a file extension? */
- if (i < 0)
- return FORM_UNKNOWN; /* Nope */
-
- /* Get file extension and compare it to others. */
- fileext = &(filename[i]);
-
- i = -1;
- f_form = FORM_UNKNOWN;
- do
- {
- i++;
- if (strcasecmp (fileext, exttype[i].extension) == 0)
- {
- f_form = exttype[i].form;
- break;
- }
- }
- while (exttype[i].form != FORM_UNKNOWN);
-
- return f_form;
-}
-
-
/* Open a new file and start scanning from that file. Returns SUCCESS
if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
it tries to determine the source form from the filename, defaulting
to free form. */
try
-gfc_new_file (const char *filename, gfc_source_form form)
+gfc_new_file (void)
{
try result;
- if (filename != NULL)
- {
- gfc_source_file = gfc_getmem (strlen (filename) + 1);
- strcpy (gfc_source_file, filename);
- }
- else
- gfc_source_file = NULL;
-
- /* Decide which form the file will be read in as. */
-
- if (form != FORM_UNKNOWN)
- gfc_current_form = form;
- else
- {
- gfc_current_form = form_from_filename (filename);
-
- if (gfc_current_form == FORM_UNKNOWN)
- {
- gfc_current_form = FORM_FREE;
- gfc_warning_now ("Reading file '%s' as free form.",
- (filename[0] == '\0') ? "<stdin>" : filename);
- }
- }
-
result = load_file (gfc_source_file, true);
gfc_current_locus.lb = line_head;
return result;
}
+
+static char *
+unescape_filename (const char *ptr)
+{
+ const char *p = ptr, *s;
+ char *d, *ret;
+ int escaped, unescape = 0;
+
+ /* Make filename end at quote. */
+ escaped = false;
+ while (*p && ! (! escaped && *p == '"'))
+ {
+ if (escaped)
+ escaped = false;
+ else if (*p == '\\')
+ {
+ escaped = true;
+ unescape++;
+ }
+ ++p;
+ }
+
+ if (! *p || p[1])
+ return NULL;
+
+ /* Undo effects of cpp_quote_string. */
+ s = ptr;
+ d = gfc_getmem (p + 1 - ptr - unescape);
+ ret = d;
+
+ while (s != p)
+ {
+ if (*s == '\\')
+ *d++ = *++s;
+ else
+ *d++ = *s;
+ s++;
+ }
+ *d = '\0';
+ return ret;
+}
+
+/* For preprocessed files, if the first tokens are of the form # NUM.
+ handle the directives so we know the original file name. */
+
+const char *
+gfc_read_orig_filename (const char *filename, const char **canon_source_file)
+{
+ int c, len;
+ char *dirname;
+
+ gfc_src_file = gfc_open_file (filename);
+ if (gfc_src_file == NULL)
+ return NULL;
+
+ c = fgetc (gfc_src_file);
+ ungetc (c, gfc_src_file);
+
+ if (c != '#')
+ return NULL;
+
+ len = 0;
+ load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
+
+ if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
+ return NULL;
+
+ filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
+ if (filename == NULL)
+ return NULL;
+
+ c = fgetc (gfc_src_file);
+ ungetc (c, gfc_src_file);
+
+ if (c != '#')
+ return filename;
+
+ len = 0;
+ load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
+
+ if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
+ return filename;
+
+ dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
+ if (dirname == NULL)
+ return filename;
+
+ len = strlen (dirname);
+ if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
+ {
+ gfc_free (dirname);
+ return filename;
+ }
+ dirname[len - 2] = '\0';
+ set_src_pwd (dirname);
+
+ if (! IS_ABSOLUTE_PATH (filename))
+ {
+ char *p = gfc_getmem (len + strlen (filename));
+
+ memcpy (p, dirname, len - 2);
+ p[len - 2] = '/';
+ strcpy (p + len - 1, filename);
+ *canon_source_file = p;
+ }
+
+ gfc_free (dirname);
+ return filename;
+}