2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
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 3, or (at your option) any later
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
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* Set of subroutines to (ultimately) return the next character to the
23 various matching subroutines. This file's job is to read files and
24 build up lines that are parsed by the parser. This means that we
25 handle continuation lines and "include" lines.
27 The first thing the scanner does is to load an entire file into
28 memory. We load the entire file into memory for a couple reasons.
29 The first is that we want to be able to deal with nonseekable input
30 (pipes, stdin) and there is a lot of backing up involved during
33 The second is that we want to be able to print the locus of errors,
34 and an error on line 999999 could conflict with something on line
35 one. Given nonseekable input, we've got to store the whole thing.
37 One thing that helps are the column truncation limits that give us
38 an upper bound on the size of individual lines. We don't store the
41 From the scanner's viewpoint, the higher level subroutines ask for
42 new characters and do a lot of jumping backwards. */
51 /* Structure for holding module and include file search path. */
52 typedef struct gfc_directorylist
56 struct gfc_directorylist *next;
60 /* List of include file search directories. */
61 static gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
63 static gfc_file *file_head, *current_file;
65 static int continue_flag, end_flag, openmp_flag;
66 static int continue_count, continue_line;
67 static locus openmp_locus;
69 gfc_source_form gfc_current_form;
70 static gfc_linebuf *line_head, *line_tail;
72 locus gfc_current_locus;
73 const char *gfc_source_file;
74 static FILE *gfc_src_file;
75 static gfc_char_t *gfc_src_preprocessor_lines[2];
79 static struct gfc_file_change
85 size_t file_changes_cur, file_changes_count;
86 size_t file_changes_allocated;
89 /* Functions dealing with our wide characters (gfc_char_t) and
90 sequences of such characters. */
93 gfc_wide_fits_in_byte (gfc_char_t c)
95 return (c <= UCHAR_MAX);
99 wide_is_ascii (gfc_char_t c)
101 return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0);
105 gfc_wide_is_printable (gfc_char_t c)
107 return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c));
111 gfc_wide_tolower (gfc_char_t c)
113 return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
117 gfc_wide_is_digit (gfc_char_t c)
119 return (c >= '0' && c <= '9');
123 wide_atoi (gfc_char_t *c)
125 #define MAX_DIGITS 20
126 char buf[MAX_DIGITS+1];
129 while (gfc_wide_is_digit(*c) && i < MAX_DIGITS)
136 gfc_wide_strlen (const gfc_char_t *str)
140 for (i = 0; str[i]; i++)
147 wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
151 for (d = dest; (*d = *src) != '\0'; ++src, ++d)
158 wide_strchr (gfc_char_t *s, gfc_char_t c)
163 return (gfc_char_t *) s;
170 widechar_to_char (gfc_char_t *s)
172 size_t len = gfc_wide_strlen (s), i;
173 char *res = gfc_getmem (len + 1);
175 for (i = 0; i < len; i++)
176 res[i] = gfc_wide_fits_in_byte (s[i]) ? (unsigned char) s[i] : '?';
183 wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n)
192 return (c1 > c2 ? 1 : -1);
200 wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
206 c1 = gfc_wide_tolower (*s1++);
207 c2 = TOLOWER (*s2++);
209 return (c1 > c2 ? 1 : -1);
217 /* Main scanner initialization. */
220 gfc_scanner_init_1 (void)
233 /* Main scanner destructor. */
236 gfc_scanner_done_1 (void)
241 while(line_head != NULL)
243 lb = line_head->next;
248 while(file_head != NULL)
251 gfc_free(file_head->filename);
258 /* Adds path to the list pointed to by list. */
261 add_path_to_list (gfc_directorylist **list, const char *path,
262 bool use_for_modules)
264 gfc_directorylist *dir;
268 while (*p == ' ' || *p == '\t') /* someone might do "-I include" */
274 dir = *list = gfc_getmem (sizeof (gfc_directorylist));
280 dir->next = gfc_getmem (sizeof (gfc_directorylist));
285 dir->use_for_modules = use_for_modules;
286 dir->path = gfc_getmem (strlen (p) + 2);
287 strcpy (dir->path, p);
288 strcat (dir->path, "/"); /* make '/' last character */
293 gfc_add_include_path (const char *path, bool use_for_modules)
295 add_path_to_list (&include_dirs, path, use_for_modules);
300 gfc_add_intrinsic_modules_path (const char *path)
302 add_path_to_list (&intrinsic_modules_dirs, path, true);
306 /* Release resources allocated for options. */
309 gfc_release_include_path (void)
311 gfc_directorylist *p;
313 while (include_dirs != NULL)
316 include_dirs = include_dirs->next;
321 while (intrinsic_modules_dirs != NULL)
323 p = intrinsic_modules_dirs;
324 intrinsic_modules_dirs = intrinsic_modules_dirs->next;
329 gfc_free (gfc_option.module_dir);
334 open_included_file (const char *name, gfc_directorylist *list, bool module)
337 gfc_directorylist *p;
340 for (p = list; p; p = p->next)
342 if (module && !p->use_for_modules)
345 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
346 strcpy (fullname, p->path);
347 strcat (fullname, name);
349 f = gfc_open_file (fullname);
358 /* Opens file for reading, searching through the include directories
359 given if necessary. If the include_cwd argument is true, we try
360 to open the file in the current directory first. */
363 gfc_open_included_file (const char *name, bool include_cwd, bool module)
367 if (IS_ABSOLUTE_PATH (name))
368 return gfc_open_file (name);
372 f = gfc_open_file (name);
377 return open_included_file (name, include_dirs, module);
381 gfc_open_intrinsic_module (const char *name)
383 if (IS_ABSOLUTE_PATH (name))
384 return gfc_open_file (name);
386 return open_included_file (name, intrinsic_modules_dirs, true);
390 /* Test to see if we're at the end of the main source file. */
399 /* Test to see if we're at the end of the current file. */
407 if (line_head == NULL)
408 return 1; /* Null file */
410 if (gfc_current_locus.lb == NULL)
417 /* Test to see if we're at the beginning of a new line. */
425 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
429 /* Test to see if we're at the end of a line. */
437 return (*gfc_current_locus.nextc == '\0');
441 add_file_change (const char *filename, int line)
443 if (file_changes_count == file_changes_allocated)
445 if (file_changes_allocated)
446 file_changes_allocated *= 2;
448 file_changes_allocated = 16;
450 = xrealloc (file_changes,
451 file_changes_allocated * sizeof (*file_changes));
453 file_changes[file_changes_count].filename = filename;
454 file_changes[file_changes_count].lb = NULL;
455 file_changes[file_changes_count++].line = line;
459 report_file_change (gfc_linebuf *lb)
461 size_t c = file_changes_cur;
462 while (c < file_changes_count
463 && file_changes[c].lb == lb)
465 if (file_changes[c].filename)
466 (*debug_hooks->start_source_file) (file_changes[c].line,
467 file_changes[c].filename);
469 (*debug_hooks->end_source_file) (file_changes[c].line);
472 file_changes_cur = c;
476 gfc_start_source_files (void)
478 /* If the debugger wants the name of the main source file,
480 if (debug_hooks->start_end_main_source_file)
481 (*debug_hooks->start_source_file) (0, gfc_source_file);
483 file_changes_cur = 0;
484 report_file_change (gfc_current_locus.lb);
488 gfc_end_source_files (void)
490 report_file_change (NULL);
492 if (debug_hooks->start_end_main_source_file)
493 (*debug_hooks->end_source_file) (0);
496 /* Advance the current line pointer to the next line. */
499 gfc_advance_line (void)
504 if (gfc_current_locus.lb == NULL)
510 if (gfc_current_locus.lb->next
511 && !gfc_current_locus.lb->next->dbg_emitted)
513 report_file_change (gfc_current_locus.lb->next);
514 gfc_current_locus.lb->next->dbg_emitted = true;
517 gfc_current_locus.lb = gfc_current_locus.lb->next;
519 if (gfc_current_locus.lb != NULL)
520 gfc_current_locus.nextc = gfc_current_locus.lb->line;
523 gfc_current_locus.nextc = NULL;
529 /* Get the next character from the input, advancing gfc_current_file's
530 locus. When we hit the end of the line or the end of the file, we
531 start returning a '\n' in order to complete the current statement.
532 No Fortran line conventions are implemented here.
534 Requiring explicit advances to the next line prevents the parse
535 pointer from being on the wrong line if the current statement ends
543 if (gfc_current_locus.nextc == NULL)
546 c = *gfc_current_locus.nextc++;
549 gfc_current_locus.nextc--; /* Remain on this line. */
557 /* Skip a comment. When we come here the parse pointer is positioned
558 immediately after the comment character. If we ever implement
559 compiler directives withing comments, here is where we parse the
563 skip_comment_line (void)
578 gfc_define_undef_line (void)
582 /* All lines beginning with '#' are either #define or #undef. */
583 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
586 if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
588 tmp = widechar_to_char (&gfc_current_locus.nextc[8]);
589 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
594 if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
596 tmp = widechar_to_char (&gfc_current_locus.nextc[7]);
597 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
602 /* Skip the rest of the line. */
603 skip_comment_line ();
609 /* Comment lines are null lines, lines containing only blanks or lines
610 on which the first nonblank line is a '!'.
611 Return true if !$ openmp conditional compilation sentinel was
615 skip_free_comments (void)
623 at_bol = gfc_at_bol ();
624 start = gfc_current_locus;
630 while (gfc_is_whitespace (c));
640 /* If -fopenmp, we need to handle here 2 things:
641 1) don't treat !$omp as comments, but directives
642 2) handle OpenMP conditional compilation, where
643 !$ should be treated as 2 spaces (for initial lines
644 only if followed by space). */
645 if (gfc_option.flag_openmp && at_bol)
647 locus old_loc = gfc_current_locus;
648 if (next_char () == '$')
651 if (c == 'o' || c == 'O')
653 if (((c = next_char ()) == 'm' || c == 'M')
654 && ((c = next_char ()) == 'p' || c == 'P'))
656 if ((c = next_char ()) == ' ' || continue_flag)
658 while (gfc_is_whitespace (c))
660 if (c != '\n' && c != '!')
663 openmp_locus = old_loc;
664 gfc_current_locus = start;
669 gfc_warning_now ("!$OMP at %C starts a commented "
670 "line as it neither is followed "
671 "by a space nor is a "
672 "continuation line");
674 gfc_current_locus = old_loc;
678 if (continue_flag || c == ' ')
680 gfc_current_locus = old_loc;
686 gfc_current_locus = old_loc;
688 skip_comment_line ();
695 if (openmp_flag && at_bol)
697 gfc_current_locus = start;
702 /* Skip comment lines in fixed source mode. We have the same rules as
703 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
704 in column 1, and a '!' cannot be in column 6. Also, we deal with
705 lines with 'd' or 'D' in column 1, if the user requested this. */
708 skip_fixed_comments (void)
716 start = gfc_current_locus;
721 while (gfc_is_whitespace (c));
726 skip_comment_line ();
731 gfc_current_locus = start;
738 start = gfc_current_locus;
749 if (c == '!' || c == 'c' || c == 'C' || c == '*')
751 /* If -fopenmp, we need to handle here 2 things:
752 1) don't treat !$omp|c$omp|*$omp as comments, but directives
753 2) handle OpenMP conditional compilation, where
754 !$|c$|*$ should be treated as 2 spaces if the characters
755 in columns 3 to 6 are valid fixed form label columns
757 if (gfc_current_locus.lb != NULL
758 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
759 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
761 if (gfc_option.flag_openmp)
763 if (next_char () == '$')
766 if (c == 'o' || c == 'O')
768 if (((c = next_char ()) == 'm' || c == 'M')
769 && ((c = next_char ()) == 'p' || c == 'P'))
773 && ((openmp_flag && continue_flag)
774 || c == ' ' || c == '0'))
777 while (gfc_is_whitespace (c))
779 if (c != '\n' && c != '!')
781 /* Canonicalize to *$omp. */
784 gfc_current_locus = start;
794 for (col = 3; col < 6; col++, c = next_char ())
797 else if (c < '0' || c > '9')
802 if (col == 6 && c != '\n'
803 && ((continue_flag && !digit_seen)
804 || c == ' ' || c == '0'))
806 gfc_current_locus = start;
807 start.nextc[0] = ' ';
808 start.nextc[1] = ' ';
813 gfc_current_locus = start;
815 skip_comment_line ();
819 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
821 if (gfc_option.flag_d_lines == 0)
823 skip_comment_line ();
827 *start.nextc = c = ' ';
832 while (gfc_is_whitespace (c))
844 if (col != 6 && c == '!')
846 if (gfc_current_locus.lb != NULL
847 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
848 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
849 skip_comment_line ();
857 gfc_current_locus = start;
861 /* Skips the current line if it is a comment. */
864 gfc_skip_comments (void)
866 if (gfc_current_form == FORM_FREE)
867 skip_free_comments ();
869 skip_fixed_comments ();
873 /* Get the next character from the input, taking continuation lines
874 and end-of-line comments into account. This implies that comment
875 lines between continued lines must be eaten here. For higher-level
876 subroutines, this flattens continued lines into a single logical
877 line. The in_string flag denotes whether we're inside a character
881 gfc_next_char_literal (int in_string)
884 int i, prev_openmp_flag;
897 if (gfc_current_form == FORM_FREE)
899 bool openmp_cond_flag;
901 if (!in_string && c == '!')
904 && memcmp (&gfc_current_locus, &openmp_locus,
905 sizeof (gfc_current_locus)) == 0)
908 /* This line can't be continued */
915 /* Avoid truncation warnings for comment ending lines. */
916 gfc_current_locus.lb->truncated = 0;
924 /* If the next nonblank character is a ! or \n, we've got a
925 continuation line. */
926 old_loc = gfc_current_locus;
929 while (gfc_is_whitespace (c))
932 /* Character constants to be continued cannot have commentary
935 if (in_string && c != '\n')
937 gfc_current_locus = old_loc;
942 if (c != '!' && c != '\n')
944 gfc_current_locus = old_loc;
949 prev_openmp_flag = openmp_flag;
952 skip_comment_line ();
957 goto not_continuation;
959 /* We've got a continuation line. If we are on the very next line after
960 the last continuation, increment the continuation line count and
961 check whether the limit has been exceeded. */
962 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
964 if (++continue_count == gfc_option.max_continue_free)
966 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
967 gfc_warning ("Limit of %d continuations exceeded in "
968 "statement at %C", gfc_option.max_continue_free);
972 /* Now find where it continues. First eat any comment lines. */
973 openmp_cond_flag = skip_free_comments ();
975 if (gfc_current_locus.lb != NULL
976 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
977 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
979 if (prev_openmp_flag != openmp_flag)
981 gfc_current_locus = old_loc;
982 openmp_flag = prev_openmp_flag;
987 /* Now that we have a non-comment line, probe ahead for the
988 first non-whitespace character. If it is another '&', then
989 reading starts at the next character, otherwise we must back
990 up to where the whitespace started and resume from there. */
992 old_loc = gfc_current_locus;
995 while (gfc_is_whitespace (c))
1000 for (i = 0; i < 5; i++, c = next_char ())
1002 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1004 old_loc = gfc_current_locus;
1006 while (gfc_is_whitespace (c))
1014 if (gfc_option.warn_ampersand)
1015 gfc_warning_now ("Missing '&' in continued character "
1017 gfc_current_locus.nextc--;
1019 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1020 continuation line only optionally. */
1021 else if (openmp_flag || openmp_cond_flag)
1022 gfc_current_locus.nextc--;
1026 gfc_current_locus = old_loc;
1033 /* Fixed form continuation. */
1034 if (!in_string && c == '!')
1036 /* Skip comment at end of line. */
1043 /* Avoid truncation warnings for comment ending lines. */
1044 gfc_current_locus.lb->truncated = 0;
1050 prev_openmp_flag = openmp_flag;
1052 old_loc = gfc_current_locus;
1054 gfc_advance_line ();
1055 skip_fixed_comments ();
1057 /* See if this line is a continuation line. */
1058 if (openmp_flag != prev_openmp_flag)
1060 openmp_flag = prev_openmp_flag;
1061 goto not_continuation;
1065 for (i = 0; i < 5; i++)
1069 goto not_continuation;
1072 for (i = 0; i < 5; i++)
1075 if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1076 goto not_continuation;
1080 if (c == '0' || c == ' ' || c == '\n')
1081 goto not_continuation;
1083 /* We've got a continuation line. If we are on the very next line after
1084 the last continuation, increment the continuation line count and
1085 check whether the limit has been exceeded. */
1086 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1088 if (++continue_count == gfc_option.max_continue_fixed)
1090 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1091 gfc_warning ("Limit of %d continuations exceeded in "
1093 gfc_option.max_continue_fixed);
1097 if (gfc_current_locus.lb != NULL
1098 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1099 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1102 /* Ready to read first character of continuation line, which might
1103 be another continuation line! */
1108 gfc_current_locus = old_loc;
1118 /* Get the next character of input, folded to lowercase. In fixed
1119 form mode, we also ignore spaces. When matcher subroutines are
1120 parsing character literals, they have to call
1121 gfc_next_char_literal(). */
1124 gfc_next_char (void)
1130 c = gfc_next_char_literal (0);
1132 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1134 return gfc_wide_tolower (c);
1138 gfc_next_ascii_char (void)
1140 gfc_char_t c = gfc_next_char ();
1142 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1143 : (unsigned char) UCHAR_MAX);
1148 gfc_peek_char (void)
1153 old_loc = gfc_current_locus;
1154 c = gfc_next_char ();
1155 gfc_current_locus = old_loc;
1162 gfc_peek_ascii_char (void)
1164 gfc_char_t c = gfc_peek_char ();
1166 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1167 : (unsigned char) UCHAR_MAX);
1171 /* Recover from an error. We try to get past the current statement
1172 and get lined up for the next. The next statement follows a '\n'
1173 or a ';'. We also assume that we are not within a character
1174 constant, and deal with finding a '\'' or '"'. */
1177 gfc_error_recovery (void)
1179 gfc_char_t c, delim;
1186 c = gfc_next_char ();
1187 if (c == '\n' || c == ';')
1190 if (c != '\'' && c != '"')
1219 /* Read ahead until the next character to be read is not whitespace. */
1222 gfc_gobble_whitespace (void)
1224 static int linenum = 0;
1230 old_loc = gfc_current_locus;
1231 c = gfc_next_char_literal (0);
1232 /* Issue a warning for nonconforming tabs. We keep track of the line
1233 number because the Fortran matchers will often back up and the same
1234 line will be scanned multiple times. */
1235 if (!gfc_option.warn_tabs && c == '\t')
1237 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1238 if (cur_linenum != linenum)
1240 linenum = cur_linenum;
1241 gfc_warning_now ("Nonconforming tab character at %C");
1245 while (gfc_is_whitespace (c));
1247 gfc_current_locus = old_loc;
1251 /* Load a single line into pbuf.
1253 If pbuf points to a NULL pointer, it is allocated.
1254 We truncate lines that are too long, unless we're dealing with
1255 preprocessor lines or if the option -ffixed-line-length-none is set,
1256 in which case we reallocate the buffer to fit the entire line, if
1258 In fixed mode, we expand a tab that occurs within the statement
1259 label region to expand to spaces that leave the next character in
1261 load_line returns whether the line was truncated.
1263 NOTE: The error machinery isn't available at this point, so we can't
1264 easily report line and column numbers consistent with other
1265 parts of gfortran. */
1268 load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen)
1270 static int linenum = 0, current_line = 1;
1271 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1272 int trunc_flag = 0, seen_comment = 0;
1273 int seen_printable = 0, seen_ampersand = 0;
1275 bool found_tab = false;
1277 /* Determine the maximum allowed line length. */
1278 if (gfc_current_form == FORM_FREE)
1279 maxlen = gfc_option.free_line_length;
1280 else if (gfc_current_form == FORM_FIXED)
1281 maxlen = gfc_option.fixed_line_length;
1287 /* Allocate the line buffer, storing its length into buflen.
1288 Note that if maxlen==0, indicating that arbitrary-length lines
1289 are allowed, the buffer will be reallocated if this length is
1290 insufficient; since 132 characters is the length of a standard
1291 free-form line, we use that as a starting guess. */
1297 *pbuf = gfc_getmem ((buflen + 1) * sizeof (gfc_char_t));
1303 preprocessor_flag = 0;
1306 /* In order to not truncate preprocessor lines, we have to
1307 remember that this is one. */
1308 preprocessor_flag = 1;
1319 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1320 if (gfc_current_form == FORM_FREE
1321 && !seen_printable && seen_ampersand)
1324 gfc_error_now ("'&' not allowed by itself in line %d",
1327 gfc_warning_now ("'&' not allowed by itself in line %d",
1334 continue; /* Gobble characters. */
1346 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1349 /* Is this a fixed-form comment? */
1350 if (gfc_current_form == FORM_FIXED && i == 0
1351 && (c == '*' || c == 'c' || c == 'd'))
1354 /* Vendor extension: "<tab>1" marks a continuation line. */
1358 if (c >= '1' && c <= '9')
1365 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1369 if (!gfc_option.warn_tabs && seen_comment == 0
1370 && current_line != linenum)
1372 linenum = current_line;
1373 gfc_warning_now ("Nonconforming tab character in column %d "
1374 "of line %d", i+1, linenum);
1389 if (maxlen == 0 || preprocessor_flag)
1393 /* Reallocate line buffer to double size to hold the
1395 buflen = buflen * 2;
1396 *pbuf = xrealloc (*pbuf, (buflen + 1) * sizeof (gfc_char_t));
1397 buffer = (*pbuf) + i;
1400 else if (i >= maxlen)
1402 /* Truncate the rest of the line. */
1406 if (c == '\n' || c == EOF)
1412 ungetc ('\n', input);
1416 /* Pad lines to the selected line length in fixed form. */
1417 if (gfc_current_form == FORM_FIXED
1418 && gfc_option.fixed_line_length != 0
1419 && !preprocessor_flag
1422 while (i++ < maxlen)
1434 /* Get a gfc_file structure, initialize it and add it to
1438 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1442 f = gfc_getmem (sizeof (gfc_file));
1444 f->filename = gfc_getmem (strlen (name) + 1);
1445 strcpy (f->filename, name);
1447 f->next = file_head;
1450 f->up = current_file;
1451 if (current_file != NULL)
1452 f->inclusion_line = current_file->line;
1454 linemap_add (line_table, reason, false, f->filename, 1);
1460 /* Deal with a line from the C preprocessor. The
1461 initial octothorp has already been seen. */
1464 preprocessor_line (gfc_char_t *c)
1468 gfc_char_t *wide_filename;
1470 int escaped, unescape;
1474 while (*c == ' ' || *c == '\t')
1477 if (*c < '0' || *c > '9')
1480 line = wide_atoi (c);
1482 c = wide_strchr (c, ' ');
1485 /* No file name given. Set new line number. */
1486 current_file->line = line;
1491 while (*c == ' ' || *c == '\t')
1501 /* Make filename end at quote. */
1504 while (*c && ! (!escaped && *c == '"'))
1508 else if (*c == '\\')
1517 /* Preprocessor line has no closing quote. */
1522 /* Undo effects of cpp_quote_string. */
1525 gfc_char_t *s = wide_filename;
1526 gfc_char_t *d = gfc_getmem (c - wide_filename - unescape);
1542 flag[1] = flag[2] = flag[3] = flag[4] = false;
1546 c = wide_strchr (c, ' ');
1553 if (1 <= i && i <= 4)
1557 /* Convert the filename in wide characters into a filename in narrow
1559 filename = widechar_to_char (wide_filename);
1561 /* Interpret flags. */
1563 if (flag[1]) /* Starting new file. */
1565 f = get_file (filename, LC_RENAME);
1566 add_file_change (f->filename, f->inclusion_line);
1570 if (flag[2]) /* Ending current file. */
1572 if (!current_file->up
1573 || strcmp (current_file->up->filename, filename) != 0)
1575 gfc_warning_now ("%s:%d: file %s left but not entered",
1576 current_file->filename, current_file->line,
1579 gfc_free (wide_filename);
1580 gfc_free (filename);
1584 add_file_change (NULL, line);
1585 current_file = current_file->up;
1586 linemap_add (line_table, LC_RENAME, false, current_file->filename,
1587 current_file->line);
1590 /* The name of the file can be a temporary file produced by
1591 cpp. Replace the name if it is different. */
1593 if (strcmp (current_file->filename, filename) != 0)
1595 gfc_free (current_file->filename);
1596 current_file->filename = gfc_getmem (strlen (filename) + 1);
1597 strcpy (current_file->filename, filename);
1600 /* Set new line number. */
1601 current_file->line = line;
1603 gfc_free (wide_filename);
1604 gfc_free (filename);
1608 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1609 current_file->filename, current_file->line);
1610 current_file->line++;
1614 static try load_file (const char *, bool);
1616 /* include_line()-- Checks a line buffer to see if it is an include
1617 line. If so, we call load_file() recursively to load the included
1618 file. We never return a syntax error because a statement like
1619 "include = 5" is perfectly legal. We return false if no include was
1620 processed or true if we matched an include. */
1623 include_line (gfc_char_t *line)
1625 gfc_char_t quote, *c, *begin, *stop;
1630 if (gfc_option.flag_openmp)
1632 if (gfc_current_form == FORM_FREE)
1634 while (*c == ' ' || *c == '\t')
1636 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1641 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1642 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1647 while (*c == ' ' || *c == '\t')
1650 if (wide_strncasecmp (c, "include", 7))
1654 while (*c == ' ' || *c == '\t')
1657 /* Find filename between quotes. */
1660 if (quote != '"' && quote != '\'')
1665 while (*c != quote && *c != '\0')
1673 while (*c == ' ' || *c == '\t')
1676 if (*c != '\0' && *c != '!')
1679 /* We have an include line at this point. */
1681 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1682 read by anything else. */
1684 filename = widechar_to_char (begin);
1685 load_file (filename, false);
1686 gfc_free (filename);
1691 /* Load a file into memory by calling load_line until the file ends. */
1694 load_file (const char *filename, bool initial)
1703 for (f = current_file; f; f = f->up)
1704 if (strcmp (filename, f->filename) == 0)
1706 gfc_error_now ("File '%s' is being included recursively", filename);
1714 input = gfc_src_file;
1715 gfc_src_file = NULL;
1718 input = gfc_open_file (filename);
1721 gfc_error_now ("Can't open file '%s'", filename);
1727 input = gfc_open_included_file (filename, false, false);
1730 gfc_error_now ("Can't open included file '%s'", filename);
1735 /* Load the file. */
1737 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1739 add_file_change (f->filename, f->inclusion_line);
1741 current_file->line = 1;
1746 if (initial && gfc_src_preprocessor_lines[0])
1748 preprocessor_line (gfc_src_preprocessor_lines[0]);
1749 gfc_free (gfc_src_preprocessor_lines[0]);
1750 gfc_src_preprocessor_lines[0] = NULL;
1751 if (gfc_src_preprocessor_lines[1])
1753 preprocessor_line (gfc_src_preprocessor_lines[1]);
1754 gfc_free (gfc_src_preprocessor_lines[1]);
1755 gfc_src_preprocessor_lines[1] = NULL;
1761 int trunc = load_line (input, &line, &line_len);
1763 len = gfc_wide_strlen (line);
1764 if (feof (input) && len == 0)
1767 /* If this is the first line of the file, it can contain a byte
1768 order mark (BOM), which we will ignore:
1769 FF FE is UTF-16 little endian,
1770 FE FF is UTF-16 big endian,
1771 EF BB BF is UTF-8. */
1773 && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
1774 && line[1] == (unsigned char) '\xFE')
1775 || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
1776 && line[1] == (unsigned char) '\xFF')
1777 || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
1778 && line[1] == (unsigned char) '\xBB'
1779 && line[2] == (unsigned char) '\xBF')))
1781 int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
1782 gfc_char_t *new = gfc_getmem (line_len * sizeof (gfc_char_t));
1784 wide_strcpy (new, &line[n]);
1790 /* There are three things this line can be: a line of Fortran
1791 source, an include line or a C preprocessor directive. */
1795 /* When -g3 is specified, it's possible that we emit #define
1796 and #undef lines, which we need to pass to the middle-end
1797 so that it can emit correct debug info. */
1798 if (debug_info_level == DINFO_LEVEL_VERBOSE
1799 && (wide_strncmp (line, "#define ", 8) == 0
1800 || wide_strncmp (line, "#undef ", 7) == 0))
1804 preprocessor_line (line);
1809 /* Preprocessed files have preprocessor lines added before the byte
1810 order mark, so first_line is not about the first line of the file
1811 but the first line that's not a preprocessor line. */
1814 if (include_line (line))
1816 current_file->line++;
1822 b = gfc_getmem (gfc_linebuf_header_size
1823 + (len + 1) * sizeof (gfc_char_t));
1826 = linemap_line_start (line_table, current_file->line++, 120);
1827 b->file = current_file;
1828 b->truncated = trunc;
1829 wide_strcpy (b->line, line);
1831 if (line_head == NULL)
1834 line_tail->next = b;
1838 while (file_changes_cur < file_changes_count)
1839 file_changes[file_changes_cur++].lb = b;
1842 /* Release the line buffer allocated in load_line. */
1848 add_file_change (NULL, current_file->inclusion_line + 1);
1849 current_file = current_file->up;
1850 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
1855 /* Open a new file and start scanning from that file. Returns SUCCESS
1856 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1857 it tries to determine the source form from the filename, defaulting
1865 result = load_file (gfc_source_file, true);
1867 gfc_current_locus.lb = line_head;
1868 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1870 #if 0 /* Debugging aid. */
1871 for (; line_head; line_head = line_head->next)
1872 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
1873 LOCATION_LINE (line_head->location), line_head->line);
1882 unescape_filename (const char *ptr)
1884 const char *p = ptr, *s;
1886 int escaped, unescape = 0;
1888 /* Make filename end at quote. */
1890 while (*p && ! (! escaped && *p == '"'))
1894 else if (*p == '\\')
1905 /* Undo effects of cpp_quote_string. */
1907 d = gfc_getmem (p + 1 - ptr - unescape);
1922 /* For preprocessed files, if the first tokens are of the form # NUM.
1923 handle the directives so we know the original file name. */
1926 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1929 char *dirname, *tmp;
1931 gfc_src_file = gfc_open_file (filename);
1932 if (gfc_src_file == NULL)
1935 c = getc (gfc_src_file);
1936 ungetc (c, gfc_src_file);
1942 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1944 if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1947 tmp = widechar_to_char (&gfc_src_preprocessor_lines[0][5]);
1948 filename = unescape_filename (tmp);
1950 if (filename == NULL)
1953 c = getc (gfc_src_file);
1954 ungetc (c, gfc_src_file);
1960 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1962 if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1965 tmp = widechar_to_char (&gfc_src_preprocessor_lines[1][5]);
1966 dirname = unescape_filename (tmp);
1968 if (dirname == NULL)
1971 len = strlen (dirname);
1972 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1977 dirname[len - 2] = '\0';
1978 set_src_pwd (dirname);
1980 if (! IS_ABSOLUTE_PATH (filename))
1982 char *p = gfc_getmem (len + strlen (filename));
1984 memcpy (p, dirname, len - 2);
1986 strcpy (p + len - 1, filename);
1987 *canon_source_file = p;