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;
1109 bool found_tab
= false;
1111 /* Determine the maximum allowed line length. */
1112 if (gfc_current_form
== FORM_FREE
)
1113 maxlen
= gfc_option
.free_line_length
;
1114 else if (gfc_current_form
== FORM_FIXED
)
1115 maxlen
= gfc_option
.fixed_line_length
;
1121 /* Allocate the line buffer, storing its length into buflen.
1122 Note that if maxlen==0, indicating that arbitrary-length lines
1123 are allowed, the buffer will be reallocated if this length is
1124 insufficient; since 132 characters is the length of a standard
1125 free-form line, we use that as a starting guess. */
1131 *pbuf
= gfc_getmem (buflen
+ 1);
1137 preprocessor_flag
= 0;
1140 /* In order to not truncate preprocessor lines, we have to
1141 remember that this is one. */
1142 preprocessor_flag
= 1;
1153 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1154 if (gfc_current_form
== FORM_FREE
1155 && !seen_printable
&& seen_ampersand
)
1158 gfc_error_now ("'&' not allowed by itself in line %d",
1161 gfc_warning_now ("'&' not allowed by itself in line %d",
1168 continue; /* Gobble characters. */
1180 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1183 /* Is this a fixed-form comment? */
1184 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1185 && (c
== '*' || c
== 'c' || c
== 'd'))
1188 /* Vendor extension: "<tab>1" marks a continuation line. */
1192 if (c
>= '1' && c
<= '9')
1199 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1203 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1204 && current_line
!= linenum
)
1206 linenum
= current_line
;
1207 gfc_warning_now ("Nonconforming tab character in column %d "
1208 "of line %d", i
+1, linenum
);
1223 if (maxlen
== 0 || preprocessor_flag
)
1227 /* Reallocate line buffer to double size to hold the
1229 buflen
= buflen
* 2;
1230 *pbuf
= xrealloc (*pbuf
, buflen
+ 1);
1231 buffer
= (*pbuf
) + i
;
1234 else if (i
>= maxlen
)
1236 /* Truncate the rest of the line. */
1240 if (c
== '\n' || c
== EOF
)
1246 ungetc ('\n', input
);
1250 /* Pad lines to the selected line length in fixed form. */
1251 if (gfc_current_form
== FORM_FIXED
1252 && gfc_option
.fixed_line_length
!= 0
1253 && !preprocessor_flag
1256 while (i
++ < maxlen
)
1268 /* Get a gfc_file structure, initialize it and add it to
1272 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1276 f
= gfc_getmem (sizeof (gfc_file
));
1278 f
->filename
= gfc_getmem (strlen (name
) + 1);
1279 strcpy (f
->filename
, name
);
1281 f
->next
= file_head
;
1284 f
->up
= current_file
;
1285 if (current_file
!= NULL
)
1286 f
->inclusion_line
= current_file
->line
;
1288 #ifdef USE_MAPPED_LOCATION
1289 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1295 /* Deal with a line from the C preprocessor. The
1296 initial octothorp has already been seen. */
1299 preprocessor_line (char *c
)
1305 int escaped
, unescape
;
1308 while (*c
== ' ' || *c
== '\t')
1311 if (*c
< '0' || *c
> '9')
1316 c
= strchr (c
, ' ');
1319 /* No file name given. Set new line number. */
1320 current_file
->line
= line
;
1325 while (*c
== ' ' || *c
== '\t')
1335 /* Make filename end at quote. */
1338 while (*c
&& ! (!escaped
&& *c
== '"'))
1342 else if (*c
== '\\')
1351 /* Preprocessor line has no closing quote. */
1356 /* Undo effects of cpp_quote_string. */
1360 char *d
= gfc_getmem (c
- filename
- unescape
);
1376 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1380 c
= strchr (c
, ' ');
1387 if (1 <= i
&& i
<= 4)
1391 /* Interpret flags. */
1393 if (flag
[1]) /* Starting new file. */
1395 f
= get_file (filename
, LC_RENAME
);
1396 add_file_change (f
->filename
, f
->inclusion_line
);
1400 if (flag
[2]) /* Ending current file. */
1402 if (!current_file
->up
1403 || strcmp (current_file
->up
->filename
, filename
) != 0)
1405 gfc_warning_now ("%s:%d: file %s left but not entered",
1406 current_file
->filename
, current_file
->line
,
1409 gfc_free (filename
);
1413 add_file_change (NULL
, line
);
1414 current_file
= current_file
->up
;
1415 #ifdef USE_MAPPED_LOCATION
1416 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
1417 current_file
->line
);
1421 /* The name of the file can be a temporary file produced by
1422 cpp. Replace the name if it is different. */
1424 if (strcmp (current_file
->filename
, filename
) != 0)
1426 gfc_free (current_file
->filename
);
1427 current_file
->filename
= gfc_getmem (strlen (filename
) + 1);
1428 strcpy (current_file
->filename
, filename
);
1431 /* Set new line number. */
1432 current_file
->line
= line
;
1434 gfc_free (filename
);
1438 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1439 current_file
->filename
, current_file
->line
);
1440 current_file
->line
++;
1444 static try load_file (const char *, bool);
1446 /* include_line()-- Checks a line buffer to see if it is an include
1447 line. If so, we call load_file() recursively to load the included
1448 file. We never return a syntax error because a statement like
1449 "include = 5" is perfectly legal. We return false if no include was
1450 processed or true if we matched an include. */
1453 include_line (char *line
)
1455 char quote
, *c
, *begin
, *stop
;
1459 if (gfc_option
.flag_openmp
)
1461 if (gfc_current_form
== FORM_FREE
)
1463 while (*c
== ' ' || *c
== '\t')
1465 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1470 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1471 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1476 while (*c
== ' ' || *c
== '\t')
1479 if (strncasecmp (c
, "include", 7))
1483 while (*c
== ' ' || *c
== '\t')
1486 /* Find filename between quotes. */
1489 if (quote
!= '"' && quote
!= '\'')
1494 while (*c
!= quote
&& *c
!= '\0')
1502 while (*c
== ' ' || *c
== '\t')
1505 if (*c
!= '\0' && *c
!= '!')
1508 /* We have an include line at this point. */
1510 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1511 read by anything else. */
1513 load_file (begin
, false);
1518 /* Load a file into memory by calling load_line until the file ends. */
1521 load_file (const char *filename
, bool initial
)
1530 for (f
= current_file
; f
; f
= f
->up
)
1531 if (strcmp (filename
, f
->filename
) == 0)
1533 gfc_error_now ("File '%s' is being included recursively", filename
);
1541 input
= gfc_src_file
;
1542 gfc_src_file
= NULL
;
1545 input
= gfc_open_file (filename
);
1548 gfc_error_now ("Can't open file '%s'", filename
);
1554 input
= gfc_open_included_file (filename
, false, false);
1557 gfc_error_now ("Can't open included file '%s'", filename
);
1562 /* Load the file. */
1564 f
= get_file (filename
, initial
? LC_RENAME
: LC_ENTER
);
1566 add_file_change (f
->filename
, f
->inclusion_line
);
1568 current_file
->line
= 1;
1573 if (initial
&& gfc_src_preprocessor_lines
[0])
1575 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1576 gfc_free (gfc_src_preprocessor_lines
[0]);
1577 gfc_src_preprocessor_lines
[0] = NULL
;
1578 if (gfc_src_preprocessor_lines
[1])
1580 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1581 gfc_free (gfc_src_preprocessor_lines
[1]);
1582 gfc_src_preprocessor_lines
[1] = NULL
;
1588 int trunc
= load_line (input
, &line
, &line_len
);
1590 len
= strlen (line
);
1591 if (feof (input
) && len
== 0)
1594 /* If this is the first line of the file, it can contain a byte
1595 order mark (BOM), which we will ignore:
1596 FF FE is UTF-16 little endian,
1597 FE FF is UTF-16 big endian,
1598 EF BB BF is UTF-8. */
1600 && ((line_len
>= 2 && line
[0] == '\xFF' && line
[1] == '\xFE')
1601 || (line_len
>= 2 && line
[0] == '\xFE' && line
[1] == '\xFF')
1602 || (line_len
>= 3 && line
[0] == '\xEF' && line
[1] == '\xBB'
1603 && line
[2] == '\xBF')))
1605 int n
= line
[1] == '\xBB' ? 3 : 2;
1606 char * new = gfc_getmem (line_len
);
1608 strcpy (new, line
+ n
);
1614 /* There are three things this line can be: a line of Fortran
1615 source, an include line or a C preprocessor directive. */
1619 /* When -g3 is specified, it's possible that we emit #define
1620 and #undef lines, which we need to pass to the middle-end
1621 so that it can emit correct debug info. */
1622 if (debug_info_level
== DINFO_LEVEL_VERBOSE
1623 && (strncmp (line
, "#define ", 8) == 0
1624 || strncmp (line
, "#undef ", 7) == 0))
1628 preprocessor_line (line
);
1633 /* Preprocessed files have preprocessor lines added before the byte
1634 order mark, so first_line is not about the first line of the file
1635 but the first line that's not a preprocessor line. */
1638 if (include_line (line
))
1640 current_file
->line
++;
1646 b
= gfc_getmem (gfc_linebuf_header_size
+ len
+ 1);
1648 #ifdef USE_MAPPED_LOCATION
1650 = linemap_line_start (line_table
, current_file
->line
++, 120);
1652 b
->linenum
= current_file
->line
++;
1654 b
->file
= current_file
;
1655 b
->truncated
= trunc
;
1656 strcpy (b
->line
, line
);
1658 if (line_head
== NULL
)
1661 line_tail
->next
= b
;
1665 while (file_changes_cur
< file_changes_count
)
1666 file_changes
[file_changes_cur
++].lb
= b
;
1669 /* Release the line buffer allocated in load_line. */
1675 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
1676 current_file
= current_file
->up
;
1677 #ifdef USE_MAPPED_LOCATION
1678 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
1684 /* Open a new file and start scanning from that file. Returns SUCCESS
1685 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1686 it tries to determine the source form from the filename, defaulting
1694 result
= load_file (gfc_source_file
, true);
1696 gfc_current_locus
.lb
= line_head
;
1697 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
1699 #if 0 /* Debugging aid. */
1700 for (; line_head
; line_head
= line_head
->next
)
1701 gfc_status ("%s:%3d %s\n",
1702 #ifdef USE_MAPPED_LOCATION
1703 LOCATION_FILE (line_head
->location
),
1704 LOCATION_LINE (line_head
->location
),
1706 line_head
->file
->filename
,
1718 unescape_filename (const char *ptr
)
1720 const char *p
= ptr
, *s
;
1722 int escaped
, unescape
= 0;
1724 /* Make filename end at quote. */
1726 while (*p
&& ! (! escaped
&& *p
== '"'))
1730 else if (*p
== '\\')
1741 /* Undo effects of cpp_quote_string. */
1743 d
= gfc_getmem (p
+ 1 - ptr
- unescape
);
1758 /* For preprocessed files, if the first tokens are of the form # NUM.
1759 handle the directives so we know the original file name. */
1762 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
1767 gfc_src_file
= gfc_open_file (filename
);
1768 if (gfc_src_file
== NULL
)
1771 c
= getc (gfc_src_file
);
1772 ungetc (c
, gfc_src_file
);
1778 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
);
1780 if (strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
1783 filename
= unescape_filename (gfc_src_preprocessor_lines
[0] + 5);
1784 if (filename
== NULL
)
1787 c
= getc (gfc_src_file
);
1788 ungetc (c
, gfc_src_file
);
1794 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
);
1796 if (strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
1799 dirname
= unescape_filename (gfc_src_preprocessor_lines
[1] + 5);
1800 if (dirname
== NULL
)
1803 len
= strlen (dirname
);
1804 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
1809 dirname
[len
- 2] = '\0';
1810 set_src_pwd (dirname
);
1812 if (! IS_ABSOLUTE_PATH (filename
))
1814 char *p
= gfc_getmem (len
+ strlen (filename
));
1816 memcpy (p
, dirname
, len
- 2);
1818 strcpy (p
+ len
- 1, filename
);
1819 *canon_source_file
= p
;