2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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 /* Main scanner initialization. */
82 gfc_scanner_init_1 (void)
95 /* Main scanner destructor. */
98 gfc_scanner_done_1 (void)
103 while(line_head != NULL)
105 lb = line_head->next;
110 while(file_head != NULL)
113 gfc_free(file_head->filename);
120 /* Adds path to the list pointed to by list. */
123 add_path_to_list (gfc_directorylist **list, const char *path,
124 bool use_for_modules)
126 gfc_directorylist *dir;
130 while (*p == ' ' || *p == '\t') /* someone might do "-I include" */
136 dir = *list = gfc_getmem (sizeof (gfc_directorylist));
142 dir->next = gfc_getmem (sizeof (gfc_directorylist));
147 dir->use_for_modules = use_for_modules;
148 dir->path = gfc_getmem (strlen (p) + 2);
149 strcpy (dir->path, p);
150 strcat (dir->path, "/"); /* make '/' last character */
155 gfc_add_include_path (const char *path, bool use_for_modules)
157 add_path_to_list (&include_dirs, path, use_for_modules);
162 gfc_add_intrinsic_modules_path (const char *path)
164 add_path_to_list (&intrinsic_modules_dirs, path, true);
168 /* Release resources allocated for options. */
171 gfc_release_include_path (void)
173 gfc_directorylist *p;
175 while (include_dirs != NULL)
178 include_dirs = include_dirs->next;
183 while (intrinsic_modules_dirs != NULL)
185 p = intrinsic_modules_dirs;
186 intrinsic_modules_dirs = intrinsic_modules_dirs->next;
191 gfc_free (gfc_option.module_dir);
196 open_included_file (const char *name, gfc_directorylist *list, bool module)
199 gfc_directorylist *p;
202 for (p = list; p; p = p->next)
204 if (module && !p->use_for_modules)
207 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
208 strcpy (fullname, p->path);
209 strcat (fullname, name);
211 f = gfc_open_file (fullname);
220 /* Opens file for reading, searching through the include directories
221 given if necessary. If the include_cwd argument is true, we try
222 to open the file in the current directory first. */
225 gfc_open_included_file (const char *name, bool include_cwd, bool module)
229 if (IS_ABSOLUTE_PATH (name))
230 return gfc_open_file (name);
234 f = gfc_open_file (name);
239 return open_included_file (name, include_dirs, module);
243 gfc_open_intrinsic_module (const char *name)
245 if (IS_ABSOLUTE_PATH (name))
246 return gfc_open_file (name);
248 return open_included_file (name, intrinsic_modules_dirs, true);
252 /* Test to see if we're at the end of the main source file. */
261 /* Test to see if we're at the end of the current file. */
269 if (line_head == NULL)
270 return 1; /* Null file */
272 if (gfc_current_locus.lb == NULL)
279 /* Test to see if we're at the beginning of a new line. */
287 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
291 /* Test to see if we're at the end of a line. */
299 return (*gfc_current_locus.nextc == '\0');
303 struct file_entered_chainon
306 struct file_entered_chainon *prev;
309 static struct file_entered_chainon *last_file_entered = NULL;
312 start_source_file (int line, gfc_file *file)
314 struct file_entered_chainon *f = gfc_getmem (sizeof
315 (struct file_entered_chainon));
318 f->prev = last_file_entered;
319 last_file_entered = f;
321 (*debug_hooks->start_source_file) (line, file->filename);
325 end_source_file (int line)
327 gcc_assert (last_file_entered);
328 last_file_entered = last_file_entered->prev;
329 (*debug_hooks->end_source_file) (line);
333 exit_remaining_files (void)
335 struct file_entered_chainon *f = last_file_entered;
338 /* The line number doesn't matter much, because we're at the end of
339 the toplevel file anyway. */
340 (*debug_hooks->end_source_file) (0);
346 /* Advance the current line pointer to the next line. */
349 gfc_advance_line (void)
353 exit_remaining_files ();
357 if (gfc_current_locus.lb == NULL)
363 if (gfc_current_locus.lb->next
364 && gfc_current_locus.lb->next->file != gfc_current_locus.lb->file)
366 if (gfc_current_locus.lb->next->file
367 && !gfc_current_locus.lb->next->dbg_emitted
368 && gfc_current_locus.lb->file->up == gfc_current_locus.lb->next->file)
370 /* We exit from an included file. */
371 end_source_file (gfc_linebuf_linenum (gfc_current_locus.lb->next));
372 gfc_current_locus.lb->next->dbg_emitted = true;
374 else if (gfc_current_locus.lb->next->file != gfc_current_locus.lb->file
375 && !gfc_current_locus.lb->next->dbg_emitted)
377 /* We enter into a new file. */
378 start_source_file (gfc_linebuf_linenum (gfc_current_locus.lb),
379 gfc_current_locus.lb->next->file);
380 gfc_current_locus.lb->next->dbg_emitted = true;
384 gfc_current_locus.lb = gfc_current_locus.lb->next;
386 if (gfc_current_locus.lb != NULL)
387 gfc_current_locus.nextc = gfc_current_locus.lb->line;
390 gfc_current_locus.nextc = NULL;
396 /* Get the next character from the input, advancing gfc_current_file's
397 locus. When we hit the end of the line or the end of the file, we
398 start returning a '\n' in order to complete the current statement.
399 No Fortran line conventions are implemented here.
401 Requiring explicit advances to the next line prevents the parse
402 pointer from being on the wrong line if the current statement ends
410 if (gfc_current_locus.nextc == NULL)
413 c = (unsigned char) *gfc_current_locus.nextc++;
416 gfc_current_locus.nextc--; /* Remain on this line. */
424 /* Skip a comment. When we come here the parse pointer is positioned
425 immediately after the comment character. If we ever implement
426 compiler directives withing comments, here is where we parse the
430 skip_comment_line (void)
445 gfc_define_undef_line (void)
447 /* All lines beginning with '#' are either #define or #undef. */
448 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_char () != '#')
451 if (strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
452 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
453 &(gfc_current_locus.nextc[8]));
455 if (strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
456 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
457 &(gfc_current_locus.nextc[7]));
459 /* Skip the rest of the line. */
460 skip_comment_line ();
466 /* Comment lines are null lines, lines containing only blanks or lines
467 on which the first nonblank line is a '!'.
468 Return true if !$ openmp conditional compilation sentinel was
472 skip_free_comments (void)
480 at_bol = gfc_at_bol ();
481 start = gfc_current_locus;
487 while (gfc_is_whitespace (c));
497 /* If -fopenmp, we need to handle here 2 things:
498 1) don't treat !$omp as comments, but directives
499 2) handle OpenMP conditional compilation, where
500 !$ should be treated as 2 spaces (for initial lines
501 only if followed by space). */
502 if (gfc_option.flag_openmp && at_bol)
504 locus old_loc = gfc_current_locus;
505 if (next_char () == '$')
508 if (c == 'o' || c == 'O')
510 if (((c = next_char ()) == 'm' || c == 'M')
511 && ((c = next_char ()) == 'p' || c == 'P'))
513 if ((c = next_char ()) == ' ' || continue_flag)
515 while (gfc_is_whitespace (c))
517 if (c != '\n' && c != '!')
520 openmp_locus = old_loc;
521 gfc_current_locus = start;
526 gfc_warning_now ("!$OMP at %C starts a commented "
527 "line as it neither is followed "
528 "by a space nor is a "
529 "continuation line");
531 gfc_current_locus = old_loc;
535 if (continue_flag || c == ' ')
537 gfc_current_locus = old_loc;
543 gfc_current_locus = old_loc;
545 skip_comment_line ();
552 if (openmp_flag && at_bol)
554 gfc_current_locus = start;
559 /* Skip comment lines in fixed source mode. We have the same rules as
560 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
561 in column 1, and a '!' cannot be in column 6. Also, we deal with
562 lines with 'd' or 'D' in column 1, if the user requested this. */
565 skip_fixed_comments (void)
573 start = gfc_current_locus;
578 while (gfc_is_whitespace (c));
583 skip_comment_line ();
588 gfc_current_locus = start;
595 start = gfc_current_locus;
606 if (c == '!' || c == 'c' || c == 'C' || c == '*')
608 /* If -fopenmp, we need to handle here 2 things:
609 1) don't treat !$omp|c$omp|*$omp as comments, but directives
610 2) handle OpenMP conditional compilation, where
611 !$|c$|*$ should be treated as 2 spaces if the characters
612 in columns 3 to 6 are valid fixed form label columns
614 if (gfc_option.flag_openmp)
616 if (next_char () == '$')
619 if (c == 'o' || c == 'O')
621 if (((c = next_char ()) == 'm' || c == 'M')
622 && ((c = next_char ()) == 'p' || c == 'P'))
626 && ((openmp_flag && continue_flag)
627 || c == ' ' || c == '0'))
630 while (gfc_is_whitespace (c))
632 if (c != '\n' && c != '!')
634 /* Canonicalize to *$omp. */
637 gfc_current_locus = start;
647 for (col = 3; col < 6; col++, c = next_char ())
650 else if (c < '0' || c > '9')
655 if (col == 6 && c != '\n'
656 && ((continue_flag && !digit_seen)
657 || c == ' ' || c == '0'))
659 gfc_current_locus = start;
660 start.nextc[0] = ' ';
661 start.nextc[1] = ' ';
666 gfc_current_locus = start;
668 skip_comment_line ();
672 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
674 if (gfc_option.flag_d_lines == 0)
676 skip_comment_line ();
680 *start.nextc = c = ' ';
685 while (gfc_is_whitespace (c))
697 if (col != 6 && c == '!')
699 skip_comment_line ();
707 gfc_current_locus = start;
711 /* Skips the current line if it is a comment. */
714 gfc_skip_comments (void)
716 if (gfc_current_form == FORM_FREE)
717 skip_free_comments ();
719 skip_fixed_comments ();
723 /* Get the next character from the input, taking continuation lines
724 and end-of-line comments into account. This implies that comment
725 lines between continued lines must be eaten here. For higher-level
726 subroutines, this flattens continued lines into a single logical
727 line. The in_string flag denotes whether we're inside a character
731 gfc_next_char_literal (int in_string)
734 int i, c, prev_openmp_flag;
746 if (gfc_current_form == FORM_FREE)
748 bool openmp_cond_flag;
750 if (!in_string && c == '!')
753 && memcmp (&gfc_current_locus, &openmp_locus,
754 sizeof (gfc_current_locus)) == 0)
757 /* This line can't be continued */
764 /* Avoid truncation warnings for comment ending lines. */
765 gfc_current_locus.lb->truncated = 0;
773 /* If the next nonblank character is a ! or \n, we've got a
774 continuation line. */
775 old_loc = gfc_current_locus;
778 while (gfc_is_whitespace (c))
781 /* Character constants to be continued cannot have commentary
784 if (in_string && c != '\n')
786 gfc_current_locus = old_loc;
791 if (c != '!' && c != '\n')
793 gfc_current_locus = old_loc;
798 prev_openmp_flag = openmp_flag;
801 skip_comment_line ();
806 goto not_continuation;
808 /* We've got a continuation line. If we are on the very next line after
809 the last continuation, increment the continuation line count and
810 check whether the limit has been exceeded. */
811 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
813 if (++continue_count == gfc_option.max_continue_free)
815 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
816 gfc_warning ("Limit of %d continuations exceeded in "
817 "statement at %C", gfc_option.max_continue_free);
820 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
822 /* Now find where it continues. First eat any comment lines. */
823 openmp_cond_flag = skip_free_comments ();
825 if (prev_openmp_flag != openmp_flag)
827 gfc_current_locus = old_loc;
828 openmp_flag = prev_openmp_flag;
833 /* Now that we have a non-comment line, probe ahead for the
834 first non-whitespace character. If it is another '&', then
835 reading starts at the next character, otherwise we must back
836 up to where the whitespace started and resume from there. */
838 old_loc = gfc_current_locus;
841 while (gfc_is_whitespace (c))
846 for (i = 0; i < 5; i++, c = next_char ())
848 gcc_assert (TOLOWER (c) == "!$omp"[i]);
850 old_loc = gfc_current_locus;
852 while (gfc_is_whitespace (c))
860 if (gfc_option.warn_ampersand)
861 gfc_warning_now ("Missing '&' in continued character "
863 gfc_current_locus.nextc--;
865 /* Both !$omp and !$ -fopenmp continuation lines have & on the
866 continuation line only optionally. */
867 else if (openmp_flag || openmp_cond_flag)
868 gfc_current_locus.nextc--;
872 gfc_current_locus = old_loc;
879 /* Fixed form continuation. */
880 if (!in_string && c == '!')
882 /* Skip comment at end of line. */
889 /* Avoid truncation warnings for comment ending lines. */
890 gfc_current_locus.lb->truncated = 0;
896 prev_openmp_flag = openmp_flag;
898 old_loc = gfc_current_locus;
901 skip_fixed_comments ();
903 /* See if this line is a continuation line. */
904 if (openmp_flag != prev_openmp_flag)
906 openmp_flag = prev_openmp_flag;
907 goto not_continuation;
911 for (i = 0; i < 5; i++)
915 goto not_continuation;
918 for (i = 0; i < 5; i++)
921 if (TOLOWER (c) != "*$omp"[i])
922 goto not_continuation;
926 if (c == '0' || c == ' ' || c == '\n')
927 goto not_continuation;
929 /* We've got a continuation line. If we are on the very next line after
930 the last continuation, increment the continuation line count and
931 check whether the limit has been exceeded. */
932 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
934 if (++continue_count == gfc_option.max_continue_fixed)
936 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
937 gfc_warning ("Limit of %d continuations exceeded in "
939 gfc_option.max_continue_fixed);
943 if (continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
944 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
947 /* Ready to read first character of continuation line, which might
948 be another continuation line! */
953 gfc_current_locus = old_loc;
963 /* Get the next character of input, folded to lowercase. In fixed
964 form mode, we also ignore spaces. When matcher subroutines are
965 parsing character literals, they have to call
966 gfc_next_char_literal(). */
975 c = gfc_next_char_literal (0);
977 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
989 old_loc = gfc_current_locus;
990 c = gfc_next_char ();
991 gfc_current_locus = old_loc;
997 /* Recover from an error. We try to get past the current statement
998 and get lined up for the next. The next statement follows a '\n'
999 or a ';'. We also assume that we are not within a character
1000 constant, and deal with finding a '\'' or '"'. */
1003 gfc_error_recovery (void)
1012 c = gfc_next_char ();
1013 if (c == '\n' || c == ';')
1016 if (c != '\'' && c != '"')
1045 /* Read ahead until the next character to be read is not whitespace. */
1048 gfc_gobble_whitespace (void)
1050 static int linenum = 0;
1056 old_loc = gfc_current_locus;
1057 c = gfc_next_char_literal (0);
1058 /* Issue a warning for nonconforming tabs. We keep track of the line
1059 number because the Fortran matchers will often back up and the same
1060 line will be scanned multiple times. */
1061 if (!gfc_option.warn_tabs && c == '\t')
1063 #ifdef USE_MAPPED_LOCATION
1064 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1066 int cur_linenum = gfc_current_locus.lb->linenum;
1068 if (cur_linenum != linenum)
1070 linenum = cur_linenum;
1071 gfc_warning_now ("Nonconforming tab character at %C");
1075 while (gfc_is_whitespace (c));
1077 gfc_current_locus = old_loc;
1081 /* Load a single line into pbuf.
1083 If pbuf points to a NULL pointer, it is allocated.
1084 We truncate lines that are too long, unless we're dealing with
1085 preprocessor lines or if the option -ffixed-line-length-none is set,
1086 in which case we reallocate the buffer to fit the entire line, if
1088 In fixed mode, we expand a tab that occurs within the statement
1089 label region to expand to spaces that leave the next character in
1091 load_line returns whether the line was truncated.
1093 NOTE: The error machinery isn't available at this point, so we can't
1094 easily report line and column numbers consistent with other
1095 parts of gfortran. */
1098 load_line (FILE *input, char **pbuf, int *pbuflen)
1100 static int linenum = 0, current_line = 1;
1101 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1102 int trunc_flag = 0, seen_comment = 0;
1103 int seen_printable = 0, seen_ampersand = 0;
1106 /* Determine the maximum allowed line length. */
1107 if (gfc_current_form == FORM_FREE)
1108 maxlen = gfc_option.free_line_length;
1109 else if (gfc_current_form == FORM_FIXED)
1110 maxlen = gfc_option.fixed_line_length;
1116 /* Allocate the line buffer, storing its length into buflen.
1117 Note that if maxlen==0, indicating that arbitrary-length lines
1118 are allowed, the buffer will be reallocated if this length is
1119 insufficient; since 132 characters is the length of a standard
1120 free-form line, we use that as a starting guess. */
1126 *pbuf = gfc_getmem (buflen + 1);
1132 preprocessor_flag = 0;
1135 /* In order to not truncate preprocessor lines, we have to
1136 remember that this is one. */
1137 preprocessor_flag = 1;
1148 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1149 if (gfc_current_form == FORM_FREE
1150 && !seen_printable && seen_ampersand)
1153 gfc_error_now ("'&' not allowed by itself in line %d",
1156 gfc_warning_now ("'&' not allowed by itself in line %d",
1163 continue; /* Gobble characters. */
1175 if ((c != '&' && c != '!') || (c == '!' && !seen_ampersand))
1178 /* Is this a fixed-form comment? */
1179 if (gfc_current_form == FORM_FIXED && i == 0
1180 && (c == '*' || c == 'c' || c == 'd'))
1183 if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
1185 if (!gfc_option.warn_tabs && seen_comment == 0
1186 && current_line != linenum)
1188 linenum = current_line;
1189 gfc_warning_now ("Nonconforming tab character in column 1 "
1190 "of line %d", linenum);
1205 if (maxlen == 0 || preprocessor_flag)
1209 /* Reallocate line buffer to double size to hold the
1211 buflen = buflen * 2;
1212 *pbuf = xrealloc (*pbuf, buflen + 1);
1213 buffer = (*pbuf) + i;
1216 else if (i >= maxlen)
1218 /* Truncate the rest of the line. */
1222 if (c == '\n' || c == EOF)
1228 ungetc ('\n', input);
1232 /* Pad lines to the selected line length in fixed form. */
1233 if (gfc_current_form == FORM_FIXED
1234 && gfc_option.fixed_line_length != 0
1235 && !preprocessor_flag
1238 while (i++ < maxlen)
1250 /* Get a gfc_file structure, initialize it and add it to
1254 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1258 f = gfc_getmem (sizeof (gfc_file));
1260 f->filename = gfc_getmem (strlen (name) + 1);
1261 strcpy (f->filename, name);
1263 f->next = file_head;
1266 f->included_by = current_file;
1267 if (current_file != NULL)
1268 f->inclusion_line = current_file->line;
1270 #ifdef USE_MAPPED_LOCATION
1271 linemap_add (line_table, reason, false, f->filename, 1);
1277 /* Deal with a line from the C preprocessor. The
1278 initial octothorp has already been seen. */
1281 preprocessor_line (char *c)
1287 int escaped, unescape;
1290 while (*c == ' ' || *c == '\t')
1293 if (*c < '0' || *c > '9')
1298 c = strchr (c, ' ');
1301 /* No file name given. Set new line number. */
1302 current_file->line = line;
1307 while (*c == ' ' || *c == '\t')
1317 /* Make filename end at quote. */
1320 while (*c && ! (!escaped && *c == '"'))
1324 else if (*c == '\\')
1333 /* Preprocessor line has no closing quote. */
1338 /* Undo effects of cpp_quote_string. */
1342 char *d = gfc_getmem (c - filename - unescape);
1358 flag[1] = flag[2] = flag[3] = flag[4] = false;
1362 c = strchr (c, ' ');
1369 if (1 <= i && i <= 4)
1373 /* Interpret flags. */
1375 if (flag[1]) /* Starting new file. */
1377 f = get_file (filename, LC_RENAME);
1378 f->up = current_file;
1382 if (flag[2]) /* Ending current file. */
1384 if (!current_file->up
1385 || strcmp (current_file->up->filename, filename) != 0)
1387 gfc_warning_now ("%s:%d: file %s left but not entered",
1388 current_file->filename, current_file->line,
1391 gfc_free (filename);
1395 current_file = current_file->up;
1396 #ifdef USE_MAPPED_LOCATION
1397 linemap_add (line_table, LC_RENAME, false, current_file->filename,
1398 current_file->line);
1402 /* The name of the file can be a temporary file produced by
1403 cpp. Replace the name if it is different. */
1405 if (strcmp (current_file->filename, filename) != 0)
1407 gfc_free (current_file->filename);
1408 current_file->filename = gfc_getmem (strlen (filename) + 1);
1409 strcpy (current_file->filename, filename);
1412 /* Set new line number. */
1413 current_file->line = line;
1415 gfc_free (filename);
1419 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1420 current_file->filename, current_file->line);
1421 current_file->line++;
1425 static try load_file (const char *, bool);
1427 /* include_line()-- Checks a line buffer to see if it is an include
1428 line. If so, we call load_file() recursively to load the included
1429 file. We never return a syntax error because a statement like
1430 "include = 5" is perfectly legal. We return false if no include was
1431 processed or true if we matched an include. */
1434 include_line (char *line)
1436 char quote, *c, *begin, *stop;
1440 if (gfc_option.flag_openmp)
1442 if (gfc_current_form == FORM_FREE)
1444 while (*c == ' ' || *c == '\t')
1446 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1451 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1452 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1457 while (*c == ' ' || *c == '\t')
1460 if (strncasecmp (c, "include", 7))
1464 while (*c == ' ' || *c == '\t')
1467 /* Find filename between quotes. */
1470 if (quote != '"' && quote != '\'')
1475 while (*c != quote && *c != '\0')
1483 while (*c == ' ' || *c == '\t')
1486 if (*c != '\0' && *c != '!')
1489 /* We have an include line at this point. */
1491 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1492 read by anything else. */
1494 load_file (begin, false);
1499 /* Load a file into memory by calling load_line until the file ends. */
1502 load_file (const char *filename, bool initial)
1511 for (f = current_file; f; f = f->up)
1512 if (strcmp (filename, f->filename) == 0)
1514 gfc_error_now ("File '%s' is being included recursively", filename);
1522 input = gfc_src_file;
1523 gfc_src_file = NULL;
1526 input = gfc_open_file (filename);
1529 gfc_error_now ("Can't open file '%s'", filename);
1535 input = gfc_open_included_file (filename, false, false);
1538 gfc_error_now ("Can't open included file '%s'", filename);
1543 /* Load the file. */
1545 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1546 f->up = current_file;
1548 current_file->line = 1;
1553 if (initial && gfc_src_preprocessor_lines[0])
1555 preprocessor_line (gfc_src_preprocessor_lines[0]);
1556 gfc_free (gfc_src_preprocessor_lines[0]);
1557 gfc_src_preprocessor_lines[0] = NULL;
1558 if (gfc_src_preprocessor_lines[1])
1560 preprocessor_line (gfc_src_preprocessor_lines[1]);
1561 gfc_free (gfc_src_preprocessor_lines[1]);
1562 gfc_src_preprocessor_lines[1] = NULL;
1568 int trunc = load_line (input, &line, &line_len);
1570 len = strlen (line);
1571 if (feof (input) && len == 0)
1574 /* If this is the first line of the file, it can contain a byte
1575 order mark (BOM), which we will ignore:
1576 FF FE is UTF-16 little endian,
1577 FE FF is UTF-16 big endian,
1578 EF BB BF is UTF-8. */
1580 && ((line_len >= 2 && line[0] == '\xFF' && line[1] == '\xFE')
1581 || (line_len >= 2 && line[0] == '\xFE' && line[1] == '\xFF')
1582 || (line_len >= 3 && line[0] == '\xEF' && line[1] == '\xBB'
1583 && line[2] == '\xBF')))
1585 int n = line[1] == '\xBB' ? 3 : 2;
1586 char * new = gfc_getmem (line_len);
1588 strcpy (new, line + n);
1594 /* There are three things this line can be: a line of Fortran
1595 source, an include line or a C preprocessor directive. */
1599 /* When -g3 is specified, it's possible that we emit #define
1600 and #undef lines, which we need to pass to the middle-end
1601 so that it can emit correct debug info. */
1602 if (debug_info_level == DINFO_LEVEL_VERBOSE
1603 && (strncmp (line, "#define ", 8) == 0
1604 || strncmp (line, "#undef ", 7) == 0))
1608 preprocessor_line (line);
1613 /* Preprocessed files have preprocessor lines added before the byte
1614 order mark, so first_line is not about the first line of the file
1615 but the first line that's not a preprocessor line. */
1618 if (include_line (line))
1620 current_file->line++;
1626 b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1628 #ifdef USE_MAPPED_LOCATION
1630 = linemap_line_start (line_table, current_file->line++, 120);
1632 b->linenum = current_file->line++;
1634 b->file = current_file;
1635 b->truncated = trunc;
1636 strcpy (b->line, line);
1638 if (line_head == NULL)
1641 line_tail->next = b;
1646 /* Release the line buffer allocated in load_line. */
1651 current_file = current_file->up;
1652 #ifdef USE_MAPPED_LOCATION
1653 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
1659 /* Open a new file and start scanning from that file. Returns SUCCESS
1660 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1661 it tries to determine the source form from the filename, defaulting
1669 result = load_file (gfc_source_file, true);
1671 gfc_current_locus.lb = line_head;
1672 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1674 #if 0 /* Debugging aid. */
1675 for (; line_head; line_head = line_head->next)
1676 gfc_status ("%s:%3d %s\n",
1677 #ifdef USE_MAPPED_LOCATION
1678 LOCATION_FILE (line_head->location),
1679 LOCATION_LINE (line_head->location),
1681 line_head->file->filename,
1693 unescape_filename (const char *ptr)
1695 const char *p = ptr, *s;
1697 int escaped, unescape = 0;
1699 /* Make filename end at quote. */
1701 while (*p && ! (! escaped && *p == '"'))
1705 else if (*p == '\\')
1716 /* Undo effects of cpp_quote_string. */
1718 d = gfc_getmem (p + 1 - ptr - unescape);
1733 /* For preprocessed files, if the first tokens are of the form # NUM.
1734 handle the directives so we know the original file name. */
1737 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1742 gfc_src_file = gfc_open_file (filename);
1743 if (gfc_src_file == NULL)
1746 c = getc (gfc_src_file);
1747 ungetc (c, gfc_src_file);
1753 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1755 if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1758 filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
1759 if (filename == NULL)
1762 c = getc (gfc_src_file);
1763 ungetc (c, gfc_src_file);
1769 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1771 if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1774 dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
1775 if (dirname == NULL)
1778 len = strlen (dirname);
1779 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1784 dirname[len - 2] = '\0';
1785 set_src_pwd (dirname);
1787 if (! IS_ABSOLUTE_PATH (filename))
1789 char *p = gfc_getmem (len + strlen (filename));
1791 memcpy (p, dirname, len - 2);
1793 strcpy (p + len - 1, filename);
1794 *canon_source_file = p;