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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* Set of subroutines to (ultimately) return the next character to the
24 various matching subroutines. This file's job is to read files and
25 build up lines that are parsed by the parser. This means that we
26 handle continuation lines and "include" lines.
28 The first thing the scanner does is to load an entire file into
29 memory. We load the entire file into memory for a couple reasons.
30 The first is that we want to be able to deal with nonseekable input
31 (pipes, stdin) and there is a lot of backing up involved during
34 The second is that we want to be able to print the locus of errors,
35 and an error on line 999999 could conflict with something on line
36 one. Given nonseekable input, we've got to store the whole thing.
38 One thing that helps are the column truncation limits that give us
39 an upper bound on the size of individual lines. We don't store the
42 From the scanner's viewpoint, the higher level subroutines ask for
43 new characters and do a lot of jumping backwards. */
50 /* Structure for holding module and include file search path. */
51 typedef struct gfc_directorylist
55 struct gfc_directorylist
*next
;
59 /* List of include file search directories. */
60 static gfc_directorylist
*include_dirs
, *intrinsic_modules_dirs
;
62 static gfc_file
*file_head
, *current_file
;
64 static int continue_flag
, end_flag
, openmp_flag
;
65 static int continue_count
, continue_line
;
66 static locus openmp_locus
;
68 gfc_source_form gfc_current_form
;
69 static gfc_linebuf
*line_head
, *line_tail
;
71 locus gfc_current_locus
;
72 const char *gfc_source_file
;
73 static FILE *gfc_src_file
;
74 static char *gfc_src_preprocessor_lines
[2];
78 /* Main scanner initialization. */
81 gfc_scanner_init_1 (void)
94 /* Main scanner destructor. */
97 gfc_scanner_done_1 (void)
102 while(line_head
!= NULL
)
104 lb
= line_head
->next
;
109 while(file_head
!= NULL
)
112 gfc_free(file_head
->filename
);
119 /* Adds path to the list pointed to by list. */
122 add_path_to_list (gfc_directorylist
**list
, const char *path
,
123 bool use_for_modules
)
125 gfc_directorylist
*dir
;
129 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
135 dir
= *list
= gfc_getmem (sizeof (gfc_directorylist
));
141 dir
->next
= gfc_getmem (sizeof (gfc_directorylist
));
146 dir
->use_for_modules
= use_for_modules
;
147 dir
->path
= gfc_getmem (strlen (p
) + 2);
148 strcpy (dir
->path
, p
);
149 strcat (dir
->path
, "/"); /* make '/' last character */
154 gfc_add_include_path (const char *path
, bool use_for_modules
)
156 add_path_to_list (&include_dirs
, path
, use_for_modules
);
161 gfc_add_intrinsic_modules_path (const char *path
)
163 add_path_to_list (&intrinsic_modules_dirs
, path
, true);
167 /* Release resources allocated for options. */
170 gfc_release_include_path (void)
172 gfc_directorylist
*p
;
174 while (include_dirs
!= NULL
)
177 include_dirs
= include_dirs
->next
;
182 while (intrinsic_modules_dirs
!= NULL
)
184 p
= intrinsic_modules_dirs
;
185 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
190 gfc_free (gfc_option
.module_dir
);
195 open_included_file (const char *name
, gfc_directorylist
*list
, bool module
)
198 gfc_directorylist
*p
;
201 for (p
= list
; p
; p
= p
->next
)
203 if (module
&& !p
->use_for_modules
)
206 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
207 strcpy (fullname
, p
->path
);
208 strcat (fullname
, name
);
210 f
= gfc_open_file (fullname
);
219 /* Opens file for reading, searching through the include directories
220 given if necessary. If the include_cwd argument is true, we try
221 to open the file in the current directory first. */
224 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
228 if (IS_ABSOLUTE_PATH (name
))
229 return gfc_open_file (name
);
233 f
= gfc_open_file (name
);
238 return open_included_file (name
, include_dirs
, module
);
242 gfc_open_intrinsic_module (const char *name
)
244 if (IS_ABSOLUTE_PATH (name
))
245 return gfc_open_file (name
);
247 return open_included_file (name
, intrinsic_modules_dirs
, true);
251 /* Test to see if we're at the end of the main source file. */
260 /* Test to see if we're at the end of the current file. */
268 if (line_head
== NULL
)
269 return 1; /* Null file */
271 if (gfc_current_locus
.lb
== NULL
)
278 /* Test to see if we're at the beginning of a new line. */
286 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
290 /* Test to see if we're at the end of a line. */
298 return (*gfc_current_locus
.nextc
== '\0');
302 /* Advance the current line pointer to the next line. */
305 gfc_advance_line (void)
310 if (gfc_current_locus
.lb
== NULL
)
316 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
318 if (gfc_current_locus
.lb
!= NULL
)
319 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
322 gfc_current_locus
.nextc
= NULL
;
328 /* Get the next character from the input, advancing gfc_current_file's
329 locus. When we hit the end of the line or the end of the file, we
330 start returning a '\n' in order to complete the current statement.
331 No Fortran line conventions are implemented here.
333 Requiring explicit advances to the next line prevents the parse
334 pointer from being on the wrong line if the current statement ends
342 if (gfc_current_locus
.nextc
== NULL
)
345 c
= (unsigned char) *gfc_current_locus
.nextc
++;
348 gfc_current_locus
.nextc
--; /* Remain on this line. */
356 /* Skip a comment. When we come here the parse pointer is positioned
357 immediately after the comment character. If we ever implement
358 compiler directives withing comments, here is where we parse the
362 skip_comment_line (void)
376 /* Comment lines are null lines, lines containing only blanks or lines
377 on which the first nonblank line is a '!'.
378 Return true if !$ openmp conditional compilation sentinel was
382 skip_free_comments (void)
390 at_bol
= gfc_at_bol ();
391 start
= gfc_current_locus
;
397 while (gfc_is_whitespace (c
));
407 /* If -fopenmp, we need to handle here 2 things:
408 1) don't treat !$omp as comments, but directives
409 2) handle OpenMP conditional compilation, where
410 !$ should be treated as 2 spaces (for initial lines
411 only if followed by space). */
412 if (gfc_option
.flag_openmp
&& at_bol
)
414 locus old_loc
= gfc_current_locus
;
415 if (next_char () == '$')
418 if (c
== 'o' || c
== 'O')
420 if (((c
= next_char ()) == 'm' || c
== 'M')
421 && ((c
= next_char ()) == 'p' || c
== 'P')
422 && ((c
= next_char ()) == ' ' || continue_flag
))
424 while (gfc_is_whitespace (c
))
426 if (c
!= '\n' && c
!= '!')
429 openmp_locus
= old_loc
;
430 gfc_current_locus
= start
;
434 gfc_current_locus
= old_loc
;
438 if (continue_flag
|| c
== ' ')
440 gfc_current_locus
= old_loc
;
446 gfc_current_locus
= old_loc
;
448 skip_comment_line ();
455 if (openmp_flag
&& at_bol
)
457 gfc_current_locus
= start
;
462 /* Skip comment lines in fixed source mode. We have the same rules as
463 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
464 in column 1, and a '!' cannot be in column 6. Also, we deal with
465 lines with 'd' or 'D' in column 1, if the user requested this. */
468 skip_fixed_comments (void)
476 start
= gfc_current_locus
;
481 while (gfc_is_whitespace (c
));
486 skip_comment_line ();
491 gfc_current_locus
= start
;
498 start
= gfc_current_locus
;
509 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
511 /* If -fopenmp, we need to handle here 2 things:
512 1) don't treat !$omp|c$omp|*$omp as comments, but directives
513 2) handle OpenMP conditional compilation, where
514 !$|c$|*$ should be treated as 2 spaces if the characters
515 in columns 3 to 6 are valid fixed form label columns
517 if (gfc_option
.flag_openmp
)
519 if (next_char () == '$')
522 if (c
== 'o' || c
== 'O')
524 if (((c
= next_char ()) == 'm' || c
== 'M')
525 && ((c
= next_char ()) == 'p' || c
== 'P'))
529 && ((openmp_flag
&& continue_flag
)
530 || c
== ' ' || c
== '0'))
533 while (gfc_is_whitespace (c
))
535 if (c
!= '\n' && c
!= '!')
537 /* Canonicalize to *$omp. */
540 gfc_current_locus
= start
;
550 for (col
= 3; col
< 6; col
++, c
= next_char ())
553 else if (c
< '0' || c
> '9')
558 if (col
== 6 && c
!= '\n'
559 && ((continue_flag
&& !digit_seen
)
560 || c
== ' ' || c
== '0'))
562 gfc_current_locus
= start
;
563 start
.nextc
[0] = ' ';
564 start
.nextc
[1] = ' ';
569 gfc_current_locus
= start
;
571 skip_comment_line ();
575 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
577 if (gfc_option
.flag_d_lines
== 0)
579 skip_comment_line ();
583 *start
.nextc
= c
= ' ';
588 while (gfc_is_whitespace (c
))
600 if (col
!= 6 && c
== '!')
602 skip_comment_line ();
610 gfc_current_locus
= start
;
614 /* Skips the current line if it is a comment. */
617 gfc_skip_comments (void)
619 if (gfc_current_form
== FORM_FREE
)
620 skip_free_comments ();
622 skip_fixed_comments ();
626 /* Get the next character from the input, taking continuation lines
627 and end-of-line comments into account. This implies that comment
628 lines between continued lines must be eaten here. For higher-level
629 subroutines, this flattens continued lines into a single logical
630 line. The in_string flag denotes whether we're inside a character
634 gfc_next_char_literal (int in_string
)
637 int i
, c
, prev_openmp_flag
;
649 if (gfc_current_form
== FORM_FREE
)
651 bool openmp_cond_flag
;
653 if (!in_string
&& c
== '!')
656 && memcmp (&gfc_current_locus
, &openmp_locus
,
657 sizeof (gfc_current_locus
)) == 0)
660 /* This line can't be continued */
667 /* Avoid truncation warnings for comment ending lines. */
668 gfc_current_locus
.lb
->truncated
= 0;
676 /* If the next nonblank character is a ! or \n, we've got a
677 continuation line. */
678 old_loc
= gfc_current_locus
;
681 while (gfc_is_whitespace (c
))
684 /* Character constants to be continued cannot have commentary
687 if (in_string
&& c
!= '\n')
689 gfc_current_locus
= old_loc
;
694 if (c
!= '!' && c
!= '\n')
696 gfc_current_locus
= old_loc
;
701 prev_openmp_flag
= openmp_flag
;
704 skip_comment_line ();
708 /* We've got a continuation line. If we are on the very next line after
709 the last continuation, increment the continuation line count and
710 check whether the limit has been exceeded. */
711 if (gfc_current_locus
.lb
->linenum
== continue_line
+ 1)
713 if (++continue_count
== gfc_option
.max_continue_free
)
715 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
716 gfc_warning ("Limit of %d continuations exceeded in "
717 "statement at %C", gfc_option
.max_continue_free
);
720 continue_line
= gfc_current_locus
.lb
->linenum
;
722 /* Now find where it continues. First eat any comment lines. */
723 openmp_cond_flag
= skip_free_comments ();
725 if (prev_openmp_flag
!= openmp_flag
)
727 gfc_current_locus
= old_loc
;
728 openmp_flag
= prev_openmp_flag
;
733 /* Now that we have a non-comment line, probe ahead for the
734 first non-whitespace character. If it is another '&', then
735 reading starts at the next character, otherwise we must back
736 up to where the whitespace started and resume from there. */
738 old_loc
= gfc_current_locus
;
741 while (gfc_is_whitespace (c
))
746 for (i
= 0; i
< 5; i
++, c
= next_char ())
748 gcc_assert (TOLOWER (c
) == "!$omp"[i
]);
750 old_loc
= gfc_current_locus
;
752 while (gfc_is_whitespace (c
))
760 if (gfc_option
.warn_ampersand
)
761 gfc_warning_now ("Missing '&' in continued character "
763 gfc_current_locus
.nextc
--;
765 /* Both !$omp and !$ -fopenmp continuation lines have & on the
766 continuation line only optionally. */
767 else if (openmp_flag
|| openmp_cond_flag
)
768 gfc_current_locus
.nextc
--;
772 gfc_current_locus
= old_loc
;
779 /* Fixed form continuation. */
780 if (!in_string
&& c
== '!')
782 /* Skip comment at end of line. */
789 /* Avoid truncation warnings for comment ending lines. */
790 gfc_current_locus
.lb
->truncated
= 0;
796 prev_openmp_flag
= openmp_flag
;
798 old_loc
= gfc_current_locus
;
801 skip_fixed_comments ();
803 /* See if this line is a continuation line. */
804 if (openmp_flag
!= prev_openmp_flag
)
806 openmp_flag
= prev_openmp_flag
;
807 goto not_continuation
;
811 for (i
= 0; i
< 5; i
++)
815 goto not_continuation
;
818 for (i
= 0; i
< 5; i
++)
821 if (TOLOWER (c
) != "*$omp"[i
])
822 goto not_continuation
;
826 if (c
== '0' || c
== ' ' || c
== '\n')
827 goto not_continuation
;
829 /* We've got a continuation line. If we are on the very next line after
830 the last continuation, increment the continuation line count and
831 check whether the limit has been exceeded. */
832 if (gfc_current_locus
.lb
->linenum
== continue_line
+ 1)
834 if (++continue_count
== gfc_option
.max_continue_fixed
)
836 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
837 gfc_warning ("Limit of %d continuations exceeded in "
839 gfc_option
.max_continue_fixed
);
843 if (continue_line
< gfc_current_locus
.lb
->linenum
)
844 continue_line
= gfc_current_locus
.lb
->linenum
;
847 /* Ready to read first character of continuation line, which might
848 be another continuation line! */
853 gfc_current_locus
= old_loc
;
863 /* Get the next character of input, folded to lowercase. In fixed
864 form mode, we also ignore spaces. When matcher subroutines are
865 parsing character literals, they have to call
866 gfc_next_char_literal(). */
875 c
= gfc_next_char_literal (0);
877 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
889 old_loc
= gfc_current_locus
;
890 c
= gfc_next_char ();
891 gfc_current_locus
= old_loc
;
897 /* Recover from an error. We try to get past the current statement
898 and get lined up for the next. The next statement follows a '\n'
899 or a ';'. We also assume that we are not within a character
900 constant, and deal with finding a '\'' or '"'. */
903 gfc_error_recovery (void)
912 c
= gfc_next_char ();
913 if (c
== '\n' || c
== ';')
916 if (c
!= '\'' && c
!= '"')
945 /* Read ahead until the next character to be read is not whitespace. */
948 gfc_gobble_whitespace (void)
950 static int linenum
= 0;
956 old_loc
= gfc_current_locus
;
957 c
= gfc_next_char_literal (0);
958 /* Issue a warning for nonconforming tabs. We keep track of the line
959 number because the Fortran matchers will often back up and the same
960 line will be scanned multiple times. */
961 if (!gfc_option
.warn_tabs
&& c
== '\t')
963 #ifdef USE_MAPPED_LOCATION
964 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
966 int cur_linenum
= gfc_current_locus
.lb
->linenum
;
968 if (cur_linenum
!= linenum
)
970 linenum
= cur_linenum
;
971 gfc_warning_now ("Nonconforming tab character at %C");
975 while (gfc_is_whitespace (c
));
977 gfc_current_locus
= old_loc
;
981 /* Load a single line into pbuf.
983 If pbuf points to a NULL pointer, it is allocated.
984 We truncate lines that are too long, unless we're dealing with
985 preprocessor lines or if the option -ffixed-line-length-none is set,
986 in which case we reallocate the buffer to fit the entire line, if
988 In fixed mode, we expand a tab that occurs within the statement
989 label region to expand to spaces that leave the next character in
991 load_line returns whether the line was truncated.
993 NOTE: The error machinery isn't available at this point, so we can't
994 easily report line and column numbers consistent with other
995 parts of gfortran. */
998 load_line (FILE *input
, char **pbuf
, int *pbuflen
)
1000 static int linenum
= 0, current_line
= 1;
1001 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1002 int trunc_flag
= 0, seen_comment
= 0;
1003 int seen_printable
= 0, seen_ampersand
= 0;
1006 /* Determine the maximum allowed line length. */
1007 if (gfc_current_form
== FORM_FREE
)
1008 maxlen
= gfc_option
.free_line_length
;
1009 else if (gfc_current_form
== FORM_FIXED
)
1010 maxlen
= gfc_option
.fixed_line_length
;
1016 /* Allocate the line buffer, storing its length into buflen.
1017 Note that if maxlen==0, indicating that arbitrary-length lines
1018 are allowed, the buffer will be reallocated if this length is
1019 insufficient; since 132 characters is the length of a standard
1020 free-form line, we use that as a starting guess. */
1026 *pbuf
= gfc_getmem (buflen
+ 1);
1032 preprocessor_flag
= 0;
1035 /* In order to not truncate preprocessor lines, we have to
1036 remember that this is one. */
1037 preprocessor_flag
= 1;
1048 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1049 if (gfc_current_form
== FORM_FREE
1050 && !seen_printable
&& seen_ampersand
)
1053 gfc_error_now ("'&' not allowed by itself in line %d",
1056 gfc_warning_now ("'&' not allowed by itself in line %d",
1063 continue; /* Gobble characters. */
1067 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1071 if ((c
!= ' ' && c
!= '&' && c
!= '!') || (c
== '!' && !seen_ampersand
))
1074 if (gfc_current_form
== FORM_FREE
1075 && c
== '!' && !seen_printable
&& seen_ampersand
)
1078 gfc_error_now ("'&' not allowed by itself with comment in "
1079 "line %d", current_line
);
1081 gfc_warning_now ("'&' not allowed by itself with comment in "
1082 "line %d", current_line
);
1086 /* Is this a fixed-form comment? */
1087 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1088 && (c
== '*' || c
== 'c' || c
== 'd'))
1091 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
<= 6)
1093 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1094 && current_line
!= linenum
)
1096 linenum
= current_line
;
1097 gfc_warning_now ("Nonconforming tab character in column 1 "
1098 "of line %d", linenum
);
1113 if (maxlen
== 0 || preprocessor_flag
)
1117 /* Reallocate line buffer to double size to hold the
1119 buflen
= buflen
* 2;
1120 *pbuf
= xrealloc (*pbuf
, buflen
+ 1);
1121 buffer
= (*pbuf
) + i
;
1124 else if (i
>= maxlen
)
1126 /* Truncate the rest of the line. */
1130 if (c
== '\n' || c
== EOF
)
1136 ungetc ('\n', input
);
1140 /* Pad lines to the selected line length in fixed form. */
1141 if (gfc_current_form
== FORM_FIXED
1142 && gfc_option
.fixed_line_length
!= 0
1143 && !preprocessor_flag
1146 while (i
++ < maxlen
)
1158 /* Get a gfc_file structure, initialize it and add it to
1162 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1166 f
= gfc_getmem (sizeof (gfc_file
));
1168 f
->filename
= gfc_getmem (strlen (name
) + 1);
1169 strcpy (f
->filename
, name
);
1171 f
->next
= file_head
;
1174 f
->included_by
= current_file
;
1175 if (current_file
!= NULL
)
1176 f
->inclusion_line
= current_file
->line
;
1178 #ifdef USE_MAPPED_LOCATION
1179 linemap_add (&line_table
, reason
, false, f
->filename
, 1);
1185 /* Deal with a line from the C preprocessor. The
1186 initial octothorp has already been seen. */
1189 preprocessor_line (char *c
)
1195 int escaped
, unescape
;
1198 while (*c
== ' ' || *c
== '\t')
1201 if (*c
< '0' || *c
> '9')
1206 c
= strchr (c
, ' ');
1209 /* No file name given. Set new line number. */
1210 current_file
->line
= line
;
1215 while (*c
== ' ' || *c
== '\t')
1225 /* Make filename end at quote. */
1228 while (*c
&& ! (!escaped
&& *c
== '"'))
1232 else if (*c
== '\\')
1241 /* Preprocessor line has no closing quote. */
1246 /* Undo effects of cpp_quote_string. */
1250 char *d
= gfc_getmem (c
- filename
- unescape
);
1266 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1270 c
= strchr (c
, ' ');
1277 if (1 <= i
&& i
<= 4)
1281 /* Interpret flags. */
1283 if (flag
[1]) /* Starting new file. */
1285 f
= get_file (filename
, LC_RENAME
);
1286 f
->up
= current_file
;
1290 if (flag
[2]) /* Ending current file. */
1292 if (!current_file
->up
1293 || strcmp (current_file
->up
->filename
, filename
) != 0)
1295 gfc_warning_now ("%s:%d: file %s left but not entered",
1296 current_file
->filename
, current_file
->line
,
1299 gfc_free (filename
);
1302 current_file
= current_file
->up
;
1305 /* The name of the file can be a temporary file produced by
1306 cpp. Replace the name if it is different. */
1308 if (strcmp (current_file
->filename
, filename
) != 0)
1310 gfc_free (current_file
->filename
);
1311 current_file
->filename
= gfc_getmem (strlen (filename
) + 1);
1312 strcpy (current_file
->filename
, filename
);
1315 /* Set new line number. */
1316 current_file
->line
= line
;
1318 gfc_free (filename
);
1322 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1323 current_file
->filename
, current_file
->line
);
1324 current_file
->line
++;
1328 static try load_file (const char *, bool);
1330 /* include_line()-- Checks a line buffer to see if it is an include
1331 line. If so, we call load_file() recursively to load the included
1332 file. We never return a syntax error because a statement like
1333 "include = 5" is perfectly legal. We return false if no include was
1334 processed or true if we matched an include. */
1337 include_line (char *line
)
1339 char quote
, *c
, *begin
, *stop
;
1343 if (gfc_option
.flag_openmp
)
1345 if (gfc_current_form
== FORM_FREE
)
1347 while (*c
== ' ' || *c
== '\t')
1349 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1354 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1355 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1360 while (*c
== ' ' || *c
== '\t')
1363 if (strncasecmp (c
, "include", 7))
1367 while (*c
== ' ' || *c
== '\t')
1370 /* Find filename between quotes. */
1373 if (quote
!= '"' && quote
!= '\'')
1378 while (*c
!= quote
&& *c
!= '\0')
1386 while (*c
== ' ' || *c
== '\t')
1389 if (*c
!= '\0' && *c
!= '!')
1392 /* We have an include line at this point. */
1394 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1395 read by anything else. */
1397 load_file (begin
, false);
1402 /* Load a file into memory by calling load_line until the file ends. */
1405 load_file (const char *filename
, bool initial
)
1413 for (f
= current_file
; f
; f
= f
->up
)
1414 if (strcmp (filename
, f
->filename
) == 0)
1416 gfc_error_now ("File '%s' is being included recursively", filename
);
1424 input
= gfc_src_file
;
1425 gfc_src_file
= NULL
;
1428 input
= gfc_open_file (filename
);
1431 gfc_error_now ("Can't open file '%s'", filename
);
1437 input
= gfc_open_included_file (filename
, false, false);
1440 gfc_error_now ("Can't open included file '%s'", filename
);
1445 /* Load the file. */
1447 f
= get_file (filename
, initial
? LC_RENAME
: LC_ENTER
);
1448 f
->up
= current_file
;
1450 current_file
->line
= 1;
1454 if (initial
&& gfc_src_preprocessor_lines
[0])
1456 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1457 gfc_free (gfc_src_preprocessor_lines
[0]);
1458 gfc_src_preprocessor_lines
[0] = NULL
;
1459 if (gfc_src_preprocessor_lines
[1])
1461 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1462 gfc_free (gfc_src_preprocessor_lines
[1]);
1463 gfc_src_preprocessor_lines
[1] = NULL
;
1469 int trunc
= load_line (input
, &line
, &line_len
);
1471 len
= strlen (line
);
1472 if (feof (input
) && len
== 0)
1475 /* There are three things this line can be: a line of Fortran
1476 source, an include line or a C preprocessor directive. */
1480 preprocessor_line (line
);
1484 if (include_line (line
))
1486 current_file
->line
++;
1492 b
= gfc_getmem (gfc_linebuf_header_size
+ len
+ 1);
1494 #ifdef USE_MAPPED_LOCATION
1496 = linemap_line_start (&line_table
, current_file
->line
++, 120);
1498 b
->linenum
= current_file
->line
++;
1500 b
->file
= current_file
;
1501 b
->truncated
= trunc
;
1502 strcpy (b
->line
, line
);
1504 if (line_head
== NULL
)
1507 line_tail
->next
= b
;
1512 /* Release the line buffer allocated in load_line. */
1517 current_file
= current_file
->up
;
1518 #ifdef USE_MAPPED_LOCATION
1519 linemap_add (&line_table
, LC_LEAVE
, 0, NULL
, 0);
1525 /* Open a new file and start scanning from that file. Returns SUCCESS
1526 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1527 it tries to determine the source form from the filename, defaulting
1535 result
= load_file (gfc_source_file
, true);
1537 gfc_current_locus
.lb
= line_head
;
1538 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
1540 #if 0 /* Debugging aid. */
1541 for (; line_head
; line_head
= line_head
->next
)
1542 gfc_status ("%s:%3d %s\n", line_head
->file
->filename
,
1543 #ifdef USE_MAPPED_LOCATION
1544 LOCATION_LINE (line_head
->location
),
1557 unescape_filename (const char *ptr
)
1559 const char *p
= ptr
, *s
;
1561 int escaped
, unescape
= 0;
1563 /* Make filename end at quote. */
1565 while (*p
&& ! (! escaped
&& *p
== '"'))
1569 else if (*p
== '\\')
1580 /* Undo effects of cpp_quote_string. */
1582 d
= gfc_getmem (p
+ 1 - ptr
- unescape
);
1597 /* For preprocessed files, if the first tokens are of the form # NUM.
1598 handle the directives so we know the original file name. */
1601 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
1606 gfc_src_file
= gfc_open_file (filename
);
1607 if (gfc_src_file
== NULL
)
1610 c
= fgetc (gfc_src_file
);
1611 ungetc (c
, gfc_src_file
);
1617 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
);
1619 if (strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
1622 filename
= unescape_filename (gfc_src_preprocessor_lines
[0] + 5);
1623 if (filename
== NULL
)
1626 c
= fgetc (gfc_src_file
);
1627 ungetc (c
, gfc_src_file
);
1633 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
);
1635 if (strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
1638 dirname
= unescape_filename (gfc_src_preprocessor_lines
[1] + 5);
1639 if (dirname
== NULL
)
1642 len
= strlen (dirname
);
1643 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
1648 dirname
[len
- 2] = '\0';
1649 set_src_pwd (dirname
);
1651 if (! IS_ABSOLUTE_PATH (filename
))
1653 char *p
= gfc_getmem (len
+ strlen (filename
));
1655 memcpy (p
, dirname
, len
- 2);
1657 strcpy (p
+ len
- 1, filename
);
1658 *canon_source_file
= p
;