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 char *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;
88 /* Main scanner initialization. */
91 gfc_scanner_init_1 (void)
104 /* Main scanner destructor. */
107 gfc_scanner_done_1 (void)
112 while(line_head != NULL)
114 lb = line_head->next;
119 while(file_head != NULL)
122 gfc_free(file_head->filename);
129 /* Adds path to the list pointed to by list. */
132 add_path_to_list (gfc_directorylist **list, const char *path,
133 bool use_for_modules)
135 gfc_directorylist *dir;
139 while (*p == ' ' || *p == '\t') /* someone might do "-I include" */
145 dir = *list = gfc_getmem (sizeof (gfc_directorylist));
151 dir->next = gfc_getmem (sizeof (gfc_directorylist));
156 dir->use_for_modules = use_for_modules;
157 dir->path = gfc_getmem (strlen (p) + 2);
158 strcpy (dir->path, p);
159 strcat (dir->path, "/"); /* make '/' last character */
164 gfc_add_include_path (const char *path, bool use_for_modules)
166 add_path_to_list (&include_dirs, path, use_for_modules);
171 gfc_add_intrinsic_modules_path (const char *path)
173 add_path_to_list (&intrinsic_modules_dirs, path, true);
177 /* Release resources allocated for options. */
180 gfc_release_include_path (void)
182 gfc_directorylist *p;
184 while (include_dirs != NULL)
187 include_dirs = include_dirs->next;
192 while (intrinsic_modules_dirs != NULL)
194 p = intrinsic_modules_dirs;
195 intrinsic_modules_dirs = intrinsic_modules_dirs->next;
200 gfc_free (gfc_option.module_dir);
205 open_included_file (const char *name, gfc_directorylist *list, bool module)
208 gfc_directorylist *p;
211 for (p = list; p; p = p->next)
213 if (module && !p->use_for_modules)
216 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
217 strcpy (fullname, p->path);
218 strcat (fullname, name);
220 f = gfc_open_file (fullname);
229 /* Opens file for reading, searching through the include directories
230 given if necessary. If the include_cwd argument is true, we try
231 to open the file in the current directory first. */
234 gfc_open_included_file (const char *name, bool include_cwd, bool module)
238 if (IS_ABSOLUTE_PATH (name))
239 return gfc_open_file (name);
243 f = gfc_open_file (name);
248 return open_included_file (name, include_dirs, module);
252 gfc_open_intrinsic_module (const char *name)
254 if (IS_ABSOLUTE_PATH (name))
255 return gfc_open_file (name);
257 return open_included_file (name, intrinsic_modules_dirs, true);
261 /* Test to see if we're at the end of the main source file. */
270 /* Test to see if we're at the end of the current file. */
278 if (line_head == NULL)
279 return 1; /* Null file */
281 if (gfc_current_locus.lb == NULL)
288 /* Test to see if we're at the beginning of a new line. */
296 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
300 /* Test to see if we're at the end of a line. */
308 return (*gfc_current_locus.nextc == '\0');
312 add_file_change (const char *filename, int line)
314 if (file_changes_count == file_changes_allocated)
316 if (file_changes_allocated)
317 file_changes_allocated *= 2;
319 file_changes_allocated = 16;
321 = xrealloc (file_changes,
322 file_changes_allocated * sizeof (*file_changes));
324 file_changes[file_changes_count].filename = filename;
325 file_changes[file_changes_count].lb = NULL;
326 file_changes[file_changes_count++].line = line;
330 report_file_change (gfc_linebuf *lb)
332 size_t c = file_changes_cur;
333 while (c < file_changes_count
334 && file_changes[c].lb == lb)
336 if (file_changes[c].filename)
337 (*debug_hooks->start_source_file) (file_changes[c].line,
338 file_changes[c].filename);
340 (*debug_hooks->end_source_file) (file_changes[c].line);
343 file_changes_cur = c;
347 gfc_start_source_files (void)
349 /* If the debugger wants the name of the main source file,
351 if (debug_hooks->start_end_main_source_file)
352 (*debug_hooks->start_source_file) (0, gfc_source_file);
354 file_changes_cur = 0;
355 report_file_change (gfc_current_locus.lb);
359 gfc_end_source_files (void)
361 report_file_change (NULL);
363 if (debug_hooks->start_end_main_source_file)
364 (*debug_hooks->end_source_file) (0);
367 /* Advance the current line pointer to the next line. */
370 gfc_advance_line (void)
375 if (gfc_current_locus.lb == NULL)
381 if (gfc_current_locus.lb->next
382 && !gfc_current_locus.lb->next->dbg_emitted)
384 report_file_change (gfc_current_locus.lb->next);
385 gfc_current_locus.lb->next->dbg_emitted = true;
388 gfc_current_locus.lb = gfc_current_locus.lb->next;
390 if (gfc_current_locus.lb != NULL)
391 gfc_current_locus.nextc = gfc_current_locus.lb->line;
394 gfc_current_locus.nextc = NULL;
400 /* Get the next character from the input, advancing gfc_current_file's
401 locus. When we hit the end of the line or the end of the file, we
402 start returning a '\n' in order to complete the current statement.
403 No Fortran line conventions are implemented here.
405 Requiring explicit advances to the next line prevents the parse
406 pointer from being on the wrong line if the current statement ends
414 if (gfc_current_locus.nextc == NULL)
417 c = (unsigned char) *gfc_current_locus.nextc++;
420 gfc_current_locus.nextc--; /* Remain on this line. */
428 /* Skip a comment. When we come here the parse pointer is positioned
429 immediately after the comment character. If we ever implement
430 compiler directives withing comments, here is where we parse the
434 skip_comment_line (void)
449 gfc_define_undef_line (void)
451 /* All lines beginning with '#' are either #define or #undef. */
452 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_char () != '#')
455 if (strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
456 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
457 &(gfc_current_locus.nextc[8]));
459 if (strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
460 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
461 &(gfc_current_locus.nextc[7]));
463 /* Skip the rest of the line. */
464 skip_comment_line ();
470 /* Comment lines are null lines, lines containing only blanks or lines
471 on which the first nonblank line is a '!'.
472 Return true if !$ openmp conditional compilation sentinel was
476 skip_free_comments (void)
484 at_bol = gfc_at_bol ();
485 start = gfc_current_locus;
491 while (gfc_is_whitespace (c));
501 /* If -fopenmp, we need to handle here 2 things:
502 1) don't treat !$omp as comments, but directives
503 2) handle OpenMP conditional compilation, where
504 !$ should be treated as 2 spaces (for initial lines
505 only if followed by space). */
506 if (gfc_option.flag_openmp && at_bol)
508 locus old_loc = gfc_current_locus;
509 if (next_char () == '$')
512 if (c == 'o' || c == 'O')
514 if (((c = next_char ()) == 'm' || c == 'M')
515 && ((c = next_char ()) == 'p' || c == 'P'))
517 if ((c = next_char ()) == ' ' || continue_flag)
519 while (gfc_is_whitespace (c))
521 if (c != '\n' && c != '!')
524 openmp_locus = old_loc;
525 gfc_current_locus = start;
530 gfc_warning_now ("!$OMP at %C starts a commented "
531 "line as it neither is followed "
532 "by a space nor is a "
533 "continuation line");
535 gfc_current_locus = old_loc;
539 if (continue_flag || c == ' ')
541 gfc_current_locus = old_loc;
547 gfc_current_locus = old_loc;
549 skip_comment_line ();
556 if (openmp_flag && at_bol)
558 gfc_current_locus = start;
563 /* Skip comment lines in fixed source mode. We have the same rules as
564 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
565 in column 1, and a '!' cannot be in column 6. Also, we deal with
566 lines with 'd' or 'D' in column 1, if the user requested this. */
569 skip_fixed_comments (void)
577 start = gfc_current_locus;
582 while (gfc_is_whitespace (c));
587 skip_comment_line ();
592 gfc_current_locus = start;
599 start = gfc_current_locus;
610 if (c == '!' || c == 'c' || c == 'C' || c == '*')
612 /* If -fopenmp, we need to handle here 2 things:
613 1) don't treat !$omp|c$omp|*$omp as comments, but directives
614 2) handle OpenMP conditional compilation, where
615 !$|c$|*$ should be treated as 2 spaces if the characters
616 in columns 3 to 6 are valid fixed form label columns
618 if (gfc_current_locus.lb != NULL
619 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
620 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
622 if (gfc_option.flag_openmp)
624 if (next_char () == '$')
627 if (c == 'o' || c == 'O')
629 if (((c = next_char ()) == 'm' || c == 'M')
630 && ((c = next_char ()) == 'p' || c == 'P'))
634 && ((openmp_flag && continue_flag)
635 || c == ' ' || c == '0'))
638 while (gfc_is_whitespace (c))
640 if (c != '\n' && c != '!')
642 /* Canonicalize to *$omp. */
645 gfc_current_locus = start;
655 for (col = 3; col < 6; col++, c = next_char ())
658 else if (c < '0' || c > '9')
663 if (col == 6 && c != '\n'
664 && ((continue_flag && !digit_seen)
665 || c == ' ' || c == '0'))
667 gfc_current_locus = start;
668 start.nextc[0] = ' ';
669 start.nextc[1] = ' ';
674 gfc_current_locus = start;
676 skip_comment_line ();
680 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
682 if (gfc_option.flag_d_lines == 0)
684 skip_comment_line ();
688 *start.nextc = c = ' ';
693 while (gfc_is_whitespace (c))
705 if (col != 6 && c == '!')
707 if (gfc_current_locus.lb != NULL
708 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
709 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
710 skip_comment_line ();
718 gfc_current_locus = start;
722 /* Skips the current line if it is a comment. */
725 gfc_skip_comments (void)
727 if (gfc_current_form == FORM_FREE)
728 skip_free_comments ();
730 skip_fixed_comments ();
734 /* Get the next character from the input, taking continuation lines
735 and end-of-line comments into account. This implies that comment
736 lines between continued lines must be eaten here. For higher-level
737 subroutines, this flattens continued lines into a single logical
738 line. The in_string flag denotes whether we're inside a character
742 gfc_next_char_literal (int in_string)
745 int i, c, prev_openmp_flag;
757 if (gfc_current_form == FORM_FREE)
759 bool openmp_cond_flag;
761 if (!in_string && c == '!')
764 && memcmp (&gfc_current_locus, &openmp_locus,
765 sizeof (gfc_current_locus)) == 0)
768 /* This line can't be continued */
775 /* Avoid truncation warnings for comment ending lines. */
776 gfc_current_locus.lb->truncated = 0;
784 /* If the next nonblank character is a ! or \n, we've got a
785 continuation line. */
786 old_loc = gfc_current_locus;
789 while (gfc_is_whitespace (c))
792 /* Character constants to be continued cannot have commentary
795 if (in_string && c != '\n')
797 gfc_current_locus = old_loc;
802 if (c != '!' && c != '\n')
804 gfc_current_locus = old_loc;
809 prev_openmp_flag = openmp_flag;
812 skip_comment_line ();
817 goto not_continuation;
819 /* We've got a continuation line. If we are on the very next line after
820 the last continuation, increment the continuation line count and
821 check whether the limit has been exceeded. */
822 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
824 if (++continue_count == gfc_option.max_continue_free)
826 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
827 gfc_warning ("Limit of %d continuations exceeded in "
828 "statement at %C", gfc_option.max_continue_free);
832 /* Now find where it continues. First eat any comment lines. */
833 openmp_cond_flag = skip_free_comments ();
835 if (gfc_current_locus.lb != NULL
836 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
837 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
839 if (prev_openmp_flag != openmp_flag)
841 gfc_current_locus = old_loc;
842 openmp_flag = prev_openmp_flag;
847 /* Now that we have a non-comment line, probe ahead for the
848 first non-whitespace character. If it is another '&', then
849 reading starts at the next character, otherwise we must back
850 up to where the whitespace started and resume from there. */
852 old_loc = gfc_current_locus;
855 while (gfc_is_whitespace (c))
860 for (i = 0; i < 5; i++, c = next_char ())
862 gcc_assert (TOLOWER (c) == "!$omp"[i]);
864 old_loc = gfc_current_locus;
866 while (gfc_is_whitespace (c))
874 if (gfc_option.warn_ampersand)
875 gfc_warning_now ("Missing '&' in continued character "
877 gfc_current_locus.nextc--;
879 /* Both !$omp and !$ -fopenmp continuation lines have & on the
880 continuation line only optionally. */
881 else if (openmp_flag || openmp_cond_flag)
882 gfc_current_locus.nextc--;
886 gfc_current_locus = old_loc;
893 /* Fixed form continuation. */
894 if (!in_string && c == '!')
896 /* Skip comment at end of line. */
903 /* Avoid truncation warnings for comment ending lines. */
904 gfc_current_locus.lb->truncated = 0;
910 prev_openmp_flag = openmp_flag;
912 old_loc = gfc_current_locus;
915 skip_fixed_comments ();
917 /* See if this line is a continuation line. */
918 if (openmp_flag != prev_openmp_flag)
920 openmp_flag = prev_openmp_flag;
921 goto not_continuation;
925 for (i = 0; i < 5; i++)
929 goto not_continuation;
932 for (i = 0; i < 5; i++)
935 if (TOLOWER (c) != "*$omp"[i])
936 goto not_continuation;
940 if (c == '0' || c == ' ' || c == '\n')
941 goto not_continuation;
943 /* We've got a continuation line. If we are on the very next line after
944 the last continuation, increment the continuation line count and
945 check whether the limit has been exceeded. */
946 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
948 if (++continue_count == gfc_option.max_continue_fixed)
950 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
951 gfc_warning ("Limit of %d continuations exceeded in "
953 gfc_option.max_continue_fixed);
957 if (gfc_current_locus.lb != NULL
958 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
959 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
962 /* Ready to read first character of continuation line, which might
963 be another continuation line! */
968 gfc_current_locus = old_loc;
978 /* Get the next character of input, folded to lowercase. In fixed
979 form mode, we also ignore spaces. When matcher subroutines are
980 parsing character literals, they have to call
981 gfc_next_char_literal(). */
990 c = gfc_next_char_literal (0);
992 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1004 old_loc = gfc_current_locus;
1005 c = gfc_next_char ();
1006 gfc_current_locus = old_loc;
1012 /* Recover from an error. We try to get past the current statement
1013 and get lined up for the next. The next statement follows a '\n'
1014 or a ';'. We also assume that we are not within a character
1015 constant, and deal with finding a '\'' or '"'. */
1018 gfc_error_recovery (void)
1027 c = gfc_next_char ();
1028 if (c == '\n' || c == ';')
1031 if (c != '\'' && c != '"')
1060 /* Read ahead until the next character to be read is not whitespace. */
1063 gfc_gobble_whitespace (void)
1065 static int linenum = 0;
1071 old_loc = gfc_current_locus;
1072 c = gfc_next_char_literal (0);
1073 /* Issue a warning for nonconforming tabs. We keep track of the line
1074 number because the Fortran matchers will often back up and the same
1075 line will be scanned multiple times. */
1076 if (!gfc_option.warn_tabs && c == '\t')
1078 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1079 if (cur_linenum != linenum)
1081 linenum = cur_linenum;
1082 gfc_warning_now ("Nonconforming tab character at %C");
1086 while (gfc_is_whitespace (c));
1088 gfc_current_locus = old_loc;
1092 /* Load a single line into pbuf.
1094 If pbuf points to a NULL pointer, it is allocated.
1095 We truncate lines that are too long, unless we're dealing with
1096 preprocessor lines or if the option -ffixed-line-length-none is set,
1097 in which case we reallocate the buffer to fit the entire line, if
1099 In fixed mode, we expand a tab that occurs within the statement
1100 label region to expand to spaces that leave the next character in
1102 load_line returns whether the line was truncated.
1104 NOTE: The error machinery isn't available at this point, so we can't
1105 easily report line and column numbers consistent with other
1106 parts of gfortran. */
1109 load_line (FILE *input, char **pbuf, int *pbuflen)
1111 static int linenum = 0, current_line = 1;
1112 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1113 int trunc_flag = 0, seen_comment = 0;
1114 int seen_printable = 0, seen_ampersand = 0;
1116 bool found_tab = false;
1118 /* Determine the maximum allowed line length. */
1119 if (gfc_current_form == FORM_FREE)
1120 maxlen = gfc_option.free_line_length;
1121 else if (gfc_current_form == FORM_FIXED)
1122 maxlen = gfc_option.fixed_line_length;
1128 /* Allocate the line buffer, storing its length into buflen.
1129 Note that if maxlen==0, indicating that arbitrary-length lines
1130 are allowed, the buffer will be reallocated if this length is
1131 insufficient; since 132 characters is the length of a standard
1132 free-form line, we use that as a starting guess. */
1138 *pbuf = gfc_getmem (buflen + 1);
1144 preprocessor_flag = 0;
1147 /* In order to not truncate preprocessor lines, we have to
1148 remember that this is one. */
1149 preprocessor_flag = 1;
1160 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1161 if (gfc_current_form == FORM_FREE
1162 && !seen_printable && seen_ampersand)
1165 gfc_error_now ("'&' not allowed by itself in line %d",
1168 gfc_warning_now ("'&' not allowed by itself in line %d",
1175 continue; /* Gobble characters. */
1187 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1190 /* Is this a fixed-form comment? */
1191 if (gfc_current_form == FORM_FIXED && i == 0
1192 && (c == '*' || c == 'c' || c == 'd'))
1195 /* Vendor extension: "<tab>1" marks a continuation line. */
1199 if (c >= '1' && c <= '9')
1206 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1210 if (!gfc_option.warn_tabs && seen_comment == 0
1211 && current_line != linenum)
1213 linenum = current_line;
1214 gfc_warning_now ("Nonconforming tab character in column %d "
1215 "of line %d", i+1, linenum);
1230 if (maxlen == 0 || preprocessor_flag)
1234 /* Reallocate line buffer to double size to hold the
1236 buflen = buflen * 2;
1237 *pbuf = xrealloc (*pbuf, buflen + 1);
1238 buffer = (*pbuf) + i;
1241 else if (i >= maxlen)
1243 /* Truncate the rest of the line. */
1247 if (c == '\n' || c == EOF)
1253 ungetc ('\n', input);
1257 /* Pad lines to the selected line length in fixed form. */
1258 if (gfc_current_form == FORM_FIXED
1259 && gfc_option.fixed_line_length != 0
1260 && !preprocessor_flag
1263 while (i++ < maxlen)
1275 /* Get a gfc_file structure, initialize it and add it to
1279 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1283 f = gfc_getmem (sizeof (gfc_file));
1285 f->filename = gfc_getmem (strlen (name) + 1);
1286 strcpy (f->filename, name);
1288 f->next = file_head;
1291 f->up = current_file;
1292 if (current_file != NULL)
1293 f->inclusion_line = current_file->line;
1295 linemap_add (line_table, reason, false, f->filename, 1);
1300 /* Deal with a line from the C preprocessor. The
1301 initial octothorp has already been seen. */
1304 preprocessor_line (char *c)
1310 int escaped, unescape;
1313 while (*c == ' ' || *c == '\t')
1316 if (*c < '0' || *c > '9')
1321 c = strchr (c, ' ');
1324 /* No file name given. Set new line number. */
1325 current_file->line = line;
1330 while (*c == ' ' || *c == '\t')
1340 /* Make filename end at quote. */
1343 while (*c && ! (!escaped && *c == '"'))
1347 else if (*c == '\\')
1356 /* Preprocessor line has no closing quote. */
1361 /* Undo effects of cpp_quote_string. */
1365 char *d = gfc_getmem (c - filename - unescape);
1381 flag[1] = flag[2] = flag[3] = flag[4] = false;
1385 c = strchr (c, ' ');
1392 if (1 <= i && i <= 4)
1396 /* Interpret flags. */
1398 if (flag[1]) /* Starting new file. */
1400 f = get_file (filename, LC_RENAME);
1401 add_file_change (f->filename, f->inclusion_line);
1405 if (flag[2]) /* Ending current file. */
1407 if (!current_file->up
1408 || strcmp (current_file->up->filename, filename) != 0)
1410 gfc_warning_now ("%s:%d: file %s left but not entered",
1411 current_file->filename, current_file->line,
1414 gfc_free (filename);
1418 add_file_change (NULL, line);
1419 current_file = current_file->up;
1420 linemap_add (line_table, LC_RENAME, false, current_file->filename,
1421 current_file->line);
1424 /* The name of the file can be a temporary file produced by
1425 cpp. Replace the name if it is different. */
1427 if (strcmp (current_file->filename, filename) != 0)
1429 gfc_free (current_file->filename);
1430 current_file->filename = gfc_getmem (strlen (filename) + 1);
1431 strcpy (current_file->filename, filename);
1434 /* Set new line number. */
1435 current_file->line = line;
1437 gfc_free (filename);
1441 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1442 current_file->filename, current_file->line);
1443 current_file->line++;
1447 static try load_file (const char *, bool);
1449 /* include_line()-- Checks a line buffer to see if it is an include
1450 line. If so, we call load_file() recursively to load the included
1451 file. We never return a syntax error because a statement like
1452 "include = 5" is perfectly legal. We return false if no include was
1453 processed or true if we matched an include. */
1456 include_line (char *line)
1458 char quote, *c, *begin, *stop;
1462 if (gfc_option.flag_openmp)
1464 if (gfc_current_form == FORM_FREE)
1466 while (*c == ' ' || *c == '\t')
1468 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1473 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1474 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1479 while (*c == ' ' || *c == '\t')
1482 if (strncasecmp (c, "include", 7))
1486 while (*c == ' ' || *c == '\t')
1489 /* Find filename between quotes. */
1492 if (quote != '"' && quote != '\'')
1497 while (*c != quote && *c != '\0')
1505 while (*c == ' ' || *c == '\t')
1508 if (*c != '\0' && *c != '!')
1511 /* We have an include line at this point. */
1513 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1514 read by anything else. */
1516 load_file (begin, false);
1521 /* Load a file into memory by calling load_line until the file ends. */
1524 load_file (const char *filename, bool initial)
1533 for (f = current_file; f; f = f->up)
1534 if (strcmp (filename, f->filename) == 0)
1536 gfc_error_now ("File '%s' is being included recursively", filename);
1544 input = gfc_src_file;
1545 gfc_src_file = NULL;
1548 input = gfc_open_file (filename);
1551 gfc_error_now ("Can't open file '%s'", filename);
1557 input = gfc_open_included_file (filename, false, false);
1560 gfc_error_now ("Can't open included file '%s'", filename);
1565 /* Load the file. */
1567 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1569 add_file_change (f->filename, f->inclusion_line);
1571 current_file->line = 1;
1576 if (initial && gfc_src_preprocessor_lines[0])
1578 preprocessor_line (gfc_src_preprocessor_lines[0]);
1579 gfc_free (gfc_src_preprocessor_lines[0]);
1580 gfc_src_preprocessor_lines[0] = NULL;
1581 if (gfc_src_preprocessor_lines[1])
1583 preprocessor_line (gfc_src_preprocessor_lines[1]);
1584 gfc_free (gfc_src_preprocessor_lines[1]);
1585 gfc_src_preprocessor_lines[1] = NULL;
1591 int trunc = load_line (input, &line, &line_len);
1593 len = strlen (line);
1594 if (feof (input) && len == 0)
1597 /* If this is the first line of the file, it can contain a byte
1598 order mark (BOM), which we will ignore:
1599 FF FE is UTF-16 little endian,
1600 FE FF is UTF-16 big endian,
1601 EF BB BF is UTF-8. */
1603 && ((line_len >= 2 && line[0] == '\xFF' && line[1] == '\xFE')
1604 || (line_len >= 2 && line[0] == '\xFE' && line[1] == '\xFF')
1605 || (line_len >= 3 && line[0] == '\xEF' && line[1] == '\xBB'
1606 && line[2] == '\xBF')))
1608 int n = line[1] == '\xBB' ? 3 : 2;
1609 char * new = gfc_getmem (line_len);
1611 strcpy (new, line + n);
1617 /* There are three things this line can be: a line of Fortran
1618 source, an include line or a C preprocessor directive. */
1622 /* When -g3 is specified, it's possible that we emit #define
1623 and #undef lines, which we need to pass to the middle-end
1624 so that it can emit correct debug info. */
1625 if (debug_info_level == DINFO_LEVEL_VERBOSE
1626 && (strncmp (line, "#define ", 8) == 0
1627 || strncmp (line, "#undef ", 7) == 0))
1631 preprocessor_line (line);
1636 /* Preprocessed files have preprocessor lines added before the byte
1637 order mark, so first_line is not about the first line of the file
1638 but the first line that's not a preprocessor line. */
1641 if (include_line (line))
1643 current_file->line++;
1649 b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1652 = linemap_line_start (line_table, current_file->line++, 120);
1653 b->file = current_file;
1654 b->truncated = trunc;
1655 strcpy (b->line, line);
1657 if (line_head == NULL)
1660 line_tail->next = b;
1664 while (file_changes_cur < file_changes_count)
1665 file_changes[file_changes_cur++].lb = b;
1668 /* Release the line buffer allocated in load_line. */
1674 add_file_change (NULL, current_file->inclusion_line + 1);
1675 current_file = current_file->up;
1676 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
1681 /* Open a new file and start scanning from that file. Returns SUCCESS
1682 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1683 it tries to determine the source form from the filename, defaulting
1691 result = load_file (gfc_source_file, true);
1693 gfc_current_locus.lb = line_head;
1694 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1696 #if 0 /* Debugging aid. */
1697 for (; line_head; line_head = line_head->next)
1698 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
1699 LOCATION_LINE (line_head->location), line_head->line);
1708 unescape_filename (const char *ptr)
1710 const char *p = ptr, *s;
1712 int escaped, unescape = 0;
1714 /* Make filename end at quote. */
1716 while (*p && ! (! escaped && *p == '"'))
1720 else if (*p == '\\')
1731 /* Undo effects of cpp_quote_string. */
1733 d = gfc_getmem (p + 1 - ptr - unescape);
1748 /* For preprocessed files, if the first tokens are of the form # NUM.
1749 handle the directives so we know the original file name. */
1752 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1757 gfc_src_file = gfc_open_file (filename);
1758 if (gfc_src_file == NULL)
1761 c = getc (gfc_src_file);
1762 ungetc (c, gfc_src_file);
1768 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1770 if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1773 filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
1774 if (filename == NULL)
1777 c = getc (gfc_src_file);
1778 ungetc (c, gfc_src_file);
1784 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1786 if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1789 dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
1790 if (dirname == NULL)
1793 len = strlen (dirname);
1794 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1799 dirname[len - 2] = '\0';
1800 set_src_pwd (dirname);
1802 if (! IS_ABSOLUTE_PATH (filename))
1804 char *p = gfc_getmem (len + strlen (filename));
1806 memcpy (p, dirname, len - 2);
1808 strcpy (p + len - 1, filename);
1809 *canon_source_file = p;