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 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_option
.flag_openmp
)
620 if (next_char () == '$')
623 if (c
== 'o' || c
== 'O')
625 if (((c
= next_char ()) == 'm' || c
== 'M')
626 && ((c
= next_char ()) == 'p' || c
== 'P'))
630 && ((openmp_flag
&& continue_flag
)
631 || c
== ' ' || c
== '0'))
634 while (gfc_is_whitespace (c
))
636 if (c
!= '\n' && c
!= '!')
638 /* Canonicalize to *$omp. */
641 gfc_current_locus
= start
;
651 for (col
= 3; col
< 6; col
++, c
= next_char ())
654 else if (c
< '0' || c
> '9')
659 if (col
== 6 && c
!= '\n'
660 && ((continue_flag
&& !digit_seen
)
661 || c
== ' ' || c
== '0'))
663 gfc_current_locus
= start
;
664 start
.nextc
[0] = ' ';
665 start
.nextc
[1] = ' ';
670 gfc_current_locus
= start
;
672 skip_comment_line ();
676 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
678 if (gfc_option
.flag_d_lines
== 0)
680 skip_comment_line ();
684 *start
.nextc
= c
= ' ';
689 while (gfc_is_whitespace (c
))
701 if (col
!= 6 && c
== '!')
703 skip_comment_line ();
711 gfc_current_locus
= start
;
715 /* Skips the current line if it is a comment. */
718 gfc_skip_comments (void)
720 if (gfc_current_form
== FORM_FREE
)
721 skip_free_comments ();
723 skip_fixed_comments ();
727 /* Get the next character from the input, taking continuation lines
728 and end-of-line comments into account. This implies that comment
729 lines between continued lines must be eaten here. For higher-level
730 subroutines, this flattens continued lines into a single logical
731 line. The in_string flag denotes whether we're inside a character
735 gfc_next_char_literal (int in_string
)
738 int i
, c
, prev_openmp_flag
;
750 if (gfc_current_form
== FORM_FREE
)
752 bool openmp_cond_flag
;
754 if (!in_string
&& c
== '!')
757 && memcmp (&gfc_current_locus
, &openmp_locus
,
758 sizeof (gfc_current_locus
)) == 0)
761 /* This line can't be continued */
768 /* Avoid truncation warnings for comment ending lines. */
769 gfc_current_locus
.lb
->truncated
= 0;
777 /* If the next nonblank character is a ! or \n, we've got a
778 continuation line. */
779 old_loc
= gfc_current_locus
;
782 while (gfc_is_whitespace (c
))
785 /* Character constants to be continued cannot have commentary
788 if (in_string
&& c
!= '\n')
790 gfc_current_locus
= old_loc
;
795 if (c
!= '!' && c
!= '\n')
797 gfc_current_locus
= old_loc
;
802 prev_openmp_flag
= openmp_flag
;
805 skip_comment_line ();
810 goto not_continuation
;
812 /* We've got a continuation line. If we are on the very next line after
813 the last continuation, increment the continuation line count and
814 check whether the limit has been exceeded. */
815 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
817 if (++continue_count
== gfc_option
.max_continue_free
)
819 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
820 gfc_warning ("Limit of %d continuations exceeded in "
821 "statement at %C", gfc_option
.max_continue_free
);
824 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
826 /* Now find where it continues. First eat any comment lines. */
827 openmp_cond_flag
= skip_free_comments ();
829 if (prev_openmp_flag
!= openmp_flag
)
831 gfc_current_locus
= old_loc
;
832 openmp_flag
= prev_openmp_flag
;
837 /* Now that we have a non-comment line, probe ahead for the
838 first non-whitespace character. If it is another '&', then
839 reading starts at the next character, otherwise we must back
840 up to where the whitespace started and resume from there. */
842 old_loc
= gfc_current_locus
;
845 while (gfc_is_whitespace (c
))
850 for (i
= 0; i
< 5; i
++, c
= next_char ())
852 gcc_assert (TOLOWER (c
) == "!$omp"[i
]);
854 old_loc
= gfc_current_locus
;
856 while (gfc_is_whitespace (c
))
864 if (gfc_option
.warn_ampersand
)
865 gfc_warning_now ("Missing '&' in continued character "
867 gfc_current_locus
.nextc
--;
869 /* Both !$omp and !$ -fopenmp continuation lines have & on the
870 continuation line only optionally. */
871 else if (openmp_flag
|| openmp_cond_flag
)
872 gfc_current_locus
.nextc
--;
876 gfc_current_locus
= old_loc
;
883 /* Fixed form continuation. */
884 if (!in_string
&& c
== '!')
886 /* Skip comment at end of line. */
893 /* Avoid truncation warnings for comment ending lines. */
894 gfc_current_locus
.lb
->truncated
= 0;
900 prev_openmp_flag
= openmp_flag
;
902 old_loc
= gfc_current_locus
;
905 skip_fixed_comments ();
907 /* See if this line is a continuation line. */
908 if (openmp_flag
!= prev_openmp_flag
)
910 openmp_flag
= prev_openmp_flag
;
911 goto not_continuation
;
915 for (i
= 0; i
< 5; i
++)
919 goto not_continuation
;
922 for (i
= 0; i
< 5; i
++)
925 if (TOLOWER (c
) != "*$omp"[i
])
926 goto not_continuation
;
930 if (c
== '0' || c
== ' ' || c
== '\n')
931 goto not_continuation
;
933 /* We've got a continuation line. If we are on the very next line after
934 the last continuation, increment the continuation line count and
935 check whether the limit has been exceeded. */
936 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
938 if (++continue_count
== gfc_option
.max_continue_fixed
)
940 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
941 gfc_warning ("Limit of %d continuations exceeded in "
943 gfc_option
.max_continue_fixed
);
947 if (continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
948 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
951 /* Ready to read first character of continuation line, which might
952 be another continuation line! */
957 gfc_current_locus
= old_loc
;
967 /* Get the next character of input, folded to lowercase. In fixed
968 form mode, we also ignore spaces. When matcher subroutines are
969 parsing character literals, they have to call
970 gfc_next_char_literal(). */
979 c
= gfc_next_char_literal (0);
981 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
993 old_loc
= gfc_current_locus
;
994 c
= gfc_next_char ();
995 gfc_current_locus
= old_loc
;
1001 /* Recover from an error. We try to get past the current statement
1002 and get lined up for the next. The next statement follows a '\n'
1003 or a ';'. We also assume that we are not within a character
1004 constant, and deal with finding a '\'' or '"'. */
1007 gfc_error_recovery (void)
1016 c
= gfc_next_char ();
1017 if (c
== '\n' || c
== ';')
1020 if (c
!= '\'' && c
!= '"')
1049 /* Read ahead until the next character to be read is not whitespace. */
1052 gfc_gobble_whitespace (void)
1054 static int linenum
= 0;
1060 old_loc
= gfc_current_locus
;
1061 c
= gfc_next_char_literal (0);
1062 /* Issue a warning for nonconforming tabs. We keep track of the line
1063 number because the Fortran matchers will often back up and the same
1064 line will be scanned multiple times. */
1065 if (!gfc_option
.warn_tabs
&& c
== '\t')
1067 #ifdef USE_MAPPED_LOCATION
1068 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1070 int cur_linenum
= gfc_current_locus
.lb
->linenum
;
1072 if (cur_linenum
!= linenum
)
1074 linenum
= cur_linenum
;
1075 gfc_warning_now ("Nonconforming tab character at %C");
1079 while (gfc_is_whitespace (c
));
1081 gfc_current_locus
= old_loc
;
1085 /* Load a single line into pbuf.
1087 If pbuf points to a NULL pointer, it is allocated.
1088 We truncate lines that are too long, unless we're dealing with
1089 preprocessor lines or if the option -ffixed-line-length-none is set,
1090 in which case we reallocate the buffer to fit the entire line, if
1092 In fixed mode, we expand a tab that occurs within the statement
1093 label region to expand to spaces that leave the next character in
1095 load_line returns whether the line was truncated.
1097 NOTE: The error machinery isn't available at this point, so we can't
1098 easily report line and column numbers consistent with other
1099 parts of gfortran. */
1102 load_line (FILE *input
, char **pbuf
, int *pbuflen
)
1104 static int linenum
= 0, current_line
= 1;
1105 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1106 int trunc_flag
= 0, seen_comment
= 0;
1107 int seen_printable
= 0, seen_ampersand
= 0;
1110 /* Determine the maximum allowed line length. */
1111 if (gfc_current_form
== FORM_FREE
)
1112 maxlen
= gfc_option
.free_line_length
;
1113 else if (gfc_current_form
== FORM_FIXED
)
1114 maxlen
= gfc_option
.fixed_line_length
;
1120 /* Allocate the line buffer, storing its length into buflen.
1121 Note that if maxlen==0, indicating that arbitrary-length lines
1122 are allowed, the buffer will be reallocated if this length is
1123 insufficient; since 132 characters is the length of a standard
1124 free-form line, we use that as a starting guess. */
1130 *pbuf
= gfc_getmem (buflen
+ 1);
1136 preprocessor_flag
= 0;
1139 /* In order to not truncate preprocessor lines, we have to
1140 remember that this is one. */
1141 preprocessor_flag
= 1;
1152 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1153 if (gfc_current_form
== FORM_FREE
1154 && !seen_printable
&& seen_ampersand
)
1157 gfc_error_now ("'&' not allowed by itself in line %d",
1160 gfc_warning_now ("'&' not allowed by itself in line %d",
1167 continue; /* Gobble characters. */
1179 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1182 /* Is this a fixed-form comment? */
1183 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1184 && (c
== '*' || c
== 'c' || c
== 'd'))
1187 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
<= 6)
1189 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1190 && current_line
!= linenum
)
1192 linenum
= current_line
;
1193 gfc_warning_now ("Nonconforming tab character in column 1 "
1194 "of line %d", linenum
);
1209 if (maxlen
== 0 || preprocessor_flag
)
1213 /* Reallocate line buffer to double size to hold the
1215 buflen
= buflen
* 2;
1216 *pbuf
= xrealloc (*pbuf
, buflen
+ 1);
1217 buffer
= (*pbuf
) + i
;
1220 else if (i
>= maxlen
)
1222 /* Truncate the rest of the line. */
1226 if (c
== '\n' || c
== EOF
)
1232 ungetc ('\n', input
);
1236 /* Pad lines to the selected line length in fixed form. */
1237 if (gfc_current_form
== FORM_FIXED
1238 && gfc_option
.fixed_line_length
!= 0
1239 && !preprocessor_flag
1242 while (i
++ < maxlen
)
1254 /* Get a gfc_file structure, initialize it and add it to
1258 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1262 f
= gfc_getmem (sizeof (gfc_file
));
1264 f
->filename
= gfc_getmem (strlen (name
) + 1);
1265 strcpy (f
->filename
, name
);
1267 f
->next
= file_head
;
1270 f
->up
= current_file
;
1271 if (current_file
!= NULL
)
1272 f
->inclusion_line
= current_file
->line
;
1274 #ifdef USE_MAPPED_LOCATION
1275 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1281 /* Deal with a line from the C preprocessor. The
1282 initial octothorp has already been seen. */
1285 preprocessor_line (char *c
)
1291 int escaped
, unescape
;
1294 while (*c
== ' ' || *c
== '\t')
1297 if (*c
< '0' || *c
> '9')
1302 c
= strchr (c
, ' ');
1305 /* No file name given. Set new line number. */
1306 current_file
->line
= line
;
1311 while (*c
== ' ' || *c
== '\t')
1321 /* Make filename end at quote. */
1324 while (*c
&& ! (!escaped
&& *c
== '"'))
1328 else if (*c
== '\\')
1337 /* Preprocessor line has no closing quote. */
1342 /* Undo effects of cpp_quote_string. */
1346 char *d
= gfc_getmem (c
- filename
- unescape
);
1362 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1366 c
= strchr (c
, ' ');
1373 if (1 <= i
&& i
<= 4)
1377 /* Interpret flags. */
1379 if (flag
[1]) /* Starting new file. */
1381 f
= get_file (filename
, LC_RENAME
);
1382 add_file_change (f
->filename
, f
->inclusion_line
);
1386 if (flag
[2]) /* Ending current file. */
1388 if (!current_file
->up
1389 || strcmp (current_file
->up
->filename
, filename
) != 0)
1391 gfc_warning_now ("%s:%d: file %s left but not entered",
1392 current_file
->filename
, current_file
->line
,
1395 gfc_free (filename
);
1399 add_file_change (NULL
, line
);
1400 current_file
= current_file
->up
;
1401 #ifdef USE_MAPPED_LOCATION
1402 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
1403 current_file
->line
);
1407 /* The name of the file can be a temporary file produced by
1408 cpp. Replace the name if it is different. */
1410 if (strcmp (current_file
->filename
, filename
) != 0)
1412 gfc_free (current_file
->filename
);
1413 current_file
->filename
= gfc_getmem (strlen (filename
) + 1);
1414 strcpy (current_file
->filename
, filename
);
1417 /* Set new line number. */
1418 current_file
->line
= line
;
1420 gfc_free (filename
);
1424 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1425 current_file
->filename
, current_file
->line
);
1426 current_file
->line
++;
1430 static try load_file (const char *, bool);
1432 /* include_line()-- Checks a line buffer to see if it is an include
1433 line. If so, we call load_file() recursively to load the included
1434 file. We never return a syntax error because a statement like
1435 "include = 5" is perfectly legal. We return false if no include was
1436 processed or true if we matched an include. */
1439 include_line (char *line
)
1441 char quote
, *c
, *begin
, *stop
;
1445 if (gfc_option
.flag_openmp
)
1447 if (gfc_current_form
== FORM_FREE
)
1449 while (*c
== ' ' || *c
== '\t')
1451 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1456 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1457 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1462 while (*c
== ' ' || *c
== '\t')
1465 if (strncasecmp (c
, "include", 7))
1469 while (*c
== ' ' || *c
== '\t')
1472 /* Find filename between quotes. */
1475 if (quote
!= '"' && quote
!= '\'')
1480 while (*c
!= quote
&& *c
!= '\0')
1488 while (*c
== ' ' || *c
== '\t')
1491 if (*c
!= '\0' && *c
!= '!')
1494 /* We have an include line at this point. */
1496 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1497 read by anything else. */
1499 load_file (begin
, false);
1504 /* Load a file into memory by calling load_line until the file ends. */
1507 load_file (const char *filename
, bool initial
)
1516 for (f
= current_file
; f
; f
= f
->up
)
1517 if (strcmp (filename
, f
->filename
) == 0)
1519 gfc_error_now ("File '%s' is being included recursively", filename
);
1527 input
= gfc_src_file
;
1528 gfc_src_file
= NULL
;
1531 input
= gfc_open_file (filename
);
1534 gfc_error_now ("Can't open file '%s'", filename
);
1540 input
= gfc_open_included_file (filename
, false, false);
1543 gfc_error_now ("Can't open included file '%s'", filename
);
1548 /* Load the file. */
1550 f
= get_file (filename
, initial
? LC_RENAME
: LC_ENTER
);
1552 add_file_change (f
->filename
, f
->inclusion_line
);
1554 current_file
->line
= 1;
1559 if (initial
&& gfc_src_preprocessor_lines
[0])
1561 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1562 gfc_free (gfc_src_preprocessor_lines
[0]);
1563 gfc_src_preprocessor_lines
[0] = NULL
;
1564 if (gfc_src_preprocessor_lines
[1])
1566 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1567 gfc_free (gfc_src_preprocessor_lines
[1]);
1568 gfc_src_preprocessor_lines
[1] = NULL
;
1574 int trunc
= load_line (input
, &line
, &line_len
);
1576 len
= strlen (line
);
1577 if (feof (input
) && len
== 0)
1580 /* If this is the first line of the file, it can contain a byte
1581 order mark (BOM), which we will ignore:
1582 FF FE is UTF-16 little endian,
1583 FE FF is UTF-16 big endian,
1584 EF BB BF is UTF-8. */
1586 && ((line_len
>= 2 && line
[0] == '\xFF' && line
[1] == '\xFE')
1587 || (line_len
>= 2 && line
[0] == '\xFE' && line
[1] == '\xFF')
1588 || (line_len
>= 3 && line
[0] == '\xEF' && line
[1] == '\xBB'
1589 && line
[2] == '\xBF')))
1591 int n
= line
[1] == '\xBB' ? 3 : 2;
1592 char * new = gfc_getmem (line_len
);
1594 strcpy (new, line
+ n
);
1600 /* There are three things this line can be: a line of Fortran
1601 source, an include line or a C preprocessor directive. */
1605 /* When -g3 is specified, it's possible that we emit #define
1606 and #undef lines, which we need to pass to the middle-end
1607 so that it can emit correct debug info. */
1608 if (debug_info_level
== DINFO_LEVEL_VERBOSE
1609 && (strncmp (line
, "#define ", 8) == 0
1610 || strncmp (line
, "#undef ", 7) == 0))
1614 preprocessor_line (line
);
1619 /* Preprocessed files have preprocessor lines added before the byte
1620 order mark, so first_line is not about the first line of the file
1621 but the first line that's not a preprocessor line. */
1624 if (include_line (line
))
1626 current_file
->line
++;
1632 b
= gfc_getmem (gfc_linebuf_header_size
+ len
+ 1);
1634 #ifdef USE_MAPPED_LOCATION
1636 = linemap_line_start (line_table
, current_file
->line
++, 120);
1638 b
->linenum
= current_file
->line
++;
1640 b
->file
= current_file
;
1641 b
->truncated
= trunc
;
1642 strcpy (b
->line
, line
);
1644 if (line_head
== NULL
)
1647 line_tail
->next
= b
;
1651 while (file_changes_cur
< file_changes_count
)
1652 file_changes
[file_changes_cur
++].lb
= b
;
1655 /* Release the line buffer allocated in load_line. */
1661 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
1662 current_file
= current_file
->up
;
1663 #ifdef USE_MAPPED_LOCATION
1664 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
1670 /* Open a new file and start scanning from that file. Returns SUCCESS
1671 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1672 it tries to determine the source form from the filename, defaulting
1680 result
= load_file (gfc_source_file
, true);
1682 gfc_current_locus
.lb
= line_head
;
1683 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
1685 #if 0 /* Debugging aid. */
1686 for (; line_head
; line_head
= line_head
->next
)
1687 gfc_status ("%s:%3d %s\n",
1688 #ifdef USE_MAPPED_LOCATION
1689 LOCATION_FILE (line_head
->location
),
1690 LOCATION_LINE (line_head
->location
),
1692 line_head
->file
->filename
,
1704 unescape_filename (const char *ptr
)
1706 const char *p
= ptr
, *s
;
1708 int escaped
, unescape
= 0;
1710 /* Make filename end at quote. */
1712 while (*p
&& ! (! escaped
&& *p
== '"'))
1716 else if (*p
== '\\')
1727 /* Undo effects of cpp_quote_string. */
1729 d
= gfc_getmem (p
+ 1 - ptr
- unescape
);
1744 /* For preprocessed files, if the first tokens are of the form # NUM.
1745 handle the directives so we know the original file name. */
1748 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
1753 gfc_src_file
= gfc_open_file (filename
);
1754 if (gfc_src_file
== NULL
)
1757 c
= getc (gfc_src_file
);
1758 ungetc (c
, gfc_src_file
);
1764 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
);
1766 if (strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
1769 filename
= unescape_filename (gfc_src_preprocessor_lines
[0] + 5);
1770 if (filename
== NULL
)
1773 c
= getc (gfc_src_file
);
1774 ungetc (c
, gfc_src_file
);
1780 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
);
1782 if (strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
1785 dirname
= unescape_filename (gfc_src_preprocessor_lines
[1] + 5);
1786 if (dirname
== NULL
)
1789 len
= strlen (dirname
);
1790 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
1795 dirname
[len
- 2] = '\0';
1796 set_src_pwd (dirname
);
1798 if (! IS_ABSOLUTE_PATH (filename
))
1800 char *p
= gfc_getmem (len
+ strlen (filename
));
1802 memcpy (p
, dirname
, len
- 2);
1804 strcpy (p
+ len
- 1, filename
);
1805 *canon_source_file
= p
;