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. */
49 /* Structure for holding module and include file search path. */
50 typedef struct gfc_directorylist
53 struct gfc_directorylist
*next
;
57 /* List of include file search directories. */
58 static gfc_directorylist
*include_dirs
;
60 static gfc_file
*file_head
, *current_file
;
62 static int continue_flag
, end_flag
, openmp_flag
;
63 static int continue_count
, continue_line
;
64 static locus openmp_locus
;
66 gfc_source_form gfc_current_form
;
67 static gfc_linebuf
*line_head
, *line_tail
;
69 locus gfc_current_locus
;
70 const char *gfc_source_file
;
71 static FILE *gfc_src_file
;
72 static char *gfc_src_preprocessor_lines
[2];
76 /* Main scanner initialization. */
79 gfc_scanner_init_1 (void)
92 /* Main scanner destructor. */
95 gfc_scanner_done_1 (void)
100 while(line_head
!= NULL
)
102 lb
= line_head
->next
;
107 while(file_head
!= NULL
)
110 gfc_free(file_head
->filename
);
118 /* Adds path to the list pointed to by list. */
121 gfc_add_include_path (const char *path
)
123 gfc_directorylist
*dir
;
127 while (*p
== ' ' || *p
== '\t') /* someone might do 'gfortran "-I include"' */
134 dir
= include_dirs
= gfc_getmem (sizeof (gfc_directorylist
));
141 dir
->next
= gfc_getmem (sizeof (gfc_directorylist
));
146 dir
->path
= gfc_getmem (strlen (p
) + 2);
147 strcpy (dir
->path
, p
);
148 strcat (dir
->path
, "/"); /* make '/' last character */
152 /* Release resources allocated for options. */
155 gfc_release_include_path (void)
157 gfc_directorylist
*p
;
159 gfc_free (gfc_option
.module_dir
);
160 while (include_dirs
!= NULL
)
163 include_dirs
= include_dirs
->next
;
169 /* Opens file for reading, searching through the include directories
170 given if necessary. If the include_cwd argument is true, we try
171 to open the file in the current directory first. */
174 gfc_open_included_file (const char *name
, const bool include_cwd
)
177 gfc_directorylist
*p
;
180 if (IS_ABSOLUTE_PATH (name
))
181 return gfc_open_file (name
);
185 f
= gfc_open_file (name
);
190 for (p
= include_dirs
; p
; p
= p
->next
)
192 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
193 strcpy (fullname
, p
->path
);
194 strcat (fullname
, name
);
196 f
= gfc_open_file (fullname
);
204 /* Test to see if we're at the end of the main source file. */
214 /* Test to see if we're at the end of the current file. */
223 if (line_head
== NULL
)
224 return 1; /* Null file */
226 if (gfc_current_locus
.lb
== NULL
)
233 /* Test to see if we're at the beginning of a new line. */
241 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
245 /* Test to see if we're at the end of a line. */
254 return (*gfc_current_locus
.nextc
== '\0');
258 /* Advance the current line pointer to the next line. */
261 gfc_advance_line (void)
266 if (gfc_current_locus
.lb
== NULL
)
272 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
274 if (gfc_current_locus
.lb
!= NULL
)
275 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
278 gfc_current_locus
.nextc
= NULL
;
284 /* Get the next character from the input, advancing gfc_current_file's
285 locus. When we hit the end of the line or the end of the file, we
286 start returning a '\n' in order to complete the current statement.
287 No Fortran line conventions are implemented here.
289 Requiring explicit advances to the next line prevents the parse
290 pointer from being on the wrong line if the current statement ends
298 if (gfc_current_locus
.nextc
== NULL
)
301 c
= (unsigned char) *gfc_current_locus
.nextc
++;
304 gfc_current_locus
.nextc
--; /* Remain on this line. */
311 /* Skip a comment. When we come here the parse pointer is positioned
312 immediately after the comment character. If we ever implement
313 compiler directives withing comments, here is where we parse the
317 skip_comment_line (void)
331 /* Comment lines are null lines, lines containing only blanks or lines
332 on which the first nonblank line is a '!'.
333 Return true if !$ openmp conditional compilation sentinel was
337 skip_free_comments (void)
345 at_bol
= gfc_at_bol ();
346 start
= gfc_current_locus
;
352 while (gfc_is_whitespace (c
));
362 /* If -fopenmp, we need to handle here 2 things:
363 1) don't treat !$omp as comments, but directives
364 2) handle OpenMP conditional compilation, where
365 !$ should be treated as 2 spaces (for initial lines
366 only if followed by space). */
367 if (gfc_option
.flag_openmp
&& at_bol
)
369 locus old_loc
= gfc_current_locus
;
370 if (next_char () == '$')
373 if (c
== 'o' || c
== 'O')
375 if (((c
= next_char ()) == 'm' || c
== 'M')
376 && ((c
= next_char ()) == 'p' || c
== 'P')
377 && ((c
= next_char ()) == ' ' || continue_flag
))
379 while (gfc_is_whitespace (c
))
381 if (c
!= '\n' && c
!= '!')
384 openmp_locus
= old_loc
;
385 gfc_current_locus
= start
;
389 gfc_current_locus
= old_loc
;
393 if (continue_flag
|| c
== ' ')
395 gfc_current_locus
= old_loc
;
401 gfc_current_locus
= old_loc
;
403 skip_comment_line ();
410 if (openmp_flag
&& at_bol
)
412 gfc_current_locus
= start
;
417 /* Skip comment lines in fixed source mode. We have the same rules as
418 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
419 in column 1, and a '!' cannot be in column 6. Also, we deal with
420 lines with 'd' or 'D' in column 1, if the user requested this. */
423 skip_fixed_comments (void)
431 start
= gfc_current_locus
;
436 while (gfc_is_whitespace (c
));
441 skip_comment_line ();
446 gfc_current_locus
= start
;
453 start
= gfc_current_locus
;
464 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
466 /* If -fopenmp, we need to handle here 2 things:
467 1) don't treat !$omp|c$omp|*$omp as comments, but directives
468 2) handle OpenMP conditional compilation, where
469 !$|c$|*$ should be treated as 2 spaces if the characters
470 in columns 3 to 6 are valid fixed form label columns
472 if (gfc_option
.flag_openmp
)
474 if (next_char () == '$')
477 if (c
== 'o' || c
== 'O')
479 if (((c
= next_char ()) == 'm' || c
== 'M')
480 && ((c
= next_char ()) == 'p' || c
== 'P'))
484 && ((openmp_flag
&& continue_flag
)
485 || c
== ' ' || c
== '0'))
488 while (gfc_is_whitespace (c
))
490 if (c
!= '\n' && c
!= '!')
492 /* Canonicalize to *$omp. */
495 gfc_current_locus
= start
;
505 for (col
= 3; col
< 6; col
++, c
= next_char ())
508 else if (c
< '0' || c
> '9')
513 if (col
== 6 && c
!= '\n'
514 && ((continue_flag
&& !digit_seen
)
515 || c
== ' ' || c
== '0'))
517 gfc_current_locus
= start
;
518 start
.nextc
[0] = ' ';
519 start
.nextc
[1] = ' ';
524 gfc_current_locus
= start
;
526 skip_comment_line ();
530 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
532 if (gfc_option
.flag_d_lines
== 0)
534 skip_comment_line ();
538 *start
.nextc
= c
= ' ';
543 while (gfc_is_whitespace (c
))
555 if (col
!= 6 && c
== '!')
557 skip_comment_line ();
565 gfc_current_locus
= start
;
569 /* Skips the current line if it is a comment. */
572 gfc_skip_comments (void)
574 if (gfc_current_form
== FORM_FREE
)
575 skip_free_comments ();
577 skip_fixed_comments ();
581 /* Get the next character from the input, taking continuation lines
582 and end-of-line comments into account. This implies that comment
583 lines between continued lines must be eaten here. For higher-level
584 subroutines, this flattens continued lines into a single logical
585 line. The in_string flag denotes whether we're inside a character
589 gfc_next_char_literal (int in_string
)
592 int i
, c
, prev_openmp_flag
;
604 if (gfc_current_form
== FORM_FREE
)
606 bool openmp_cond_flag
;
608 if (!in_string
&& c
== '!')
611 && memcmp (&gfc_current_locus
, &openmp_locus
,
612 sizeof (gfc_current_locus
)) == 0)
615 /* This line can't be continued */
622 /* Avoid truncation warnings for comment ending lines. */
623 gfc_current_locus
.lb
->truncated
= 0;
631 /* If the next nonblank character is a ! or \n, we've got a
632 continuation line. */
633 old_loc
= gfc_current_locus
;
636 while (gfc_is_whitespace (c
))
639 /* Character constants to be continued cannot have commentary
642 if (in_string
&& c
!= '\n')
644 gfc_current_locus
= old_loc
;
649 if (c
!= '!' && c
!= '\n')
651 gfc_current_locus
= old_loc
;
656 prev_openmp_flag
= openmp_flag
;
659 skip_comment_line ();
664 goto not_continuation
;
666 /* We've got a continuation line. If we are on the very next line after
667 the last continuation, increment the continuation line count and
668 check whether the limit has been exceeded. */
669 if (gfc_current_locus
.lb
->linenum
== continue_line
+ 1)
671 if (++continue_count
== gfc_option
.max_continue_free
)
673 if (gfc_notification_std (GFC_STD_GNU
)
675 gfc_warning ("Limit of %d continuations exceeded in statement at %C",
676 gfc_option
.max_continue_free
);
679 continue_line
= gfc_current_locus
.lb
->linenum
;
681 /* Now find where it continues. First eat any comment lines. */
682 openmp_cond_flag
= skip_free_comments ();
684 if (prev_openmp_flag
!= openmp_flag
)
686 gfc_current_locus
= old_loc
;
687 openmp_flag
= prev_openmp_flag
;
692 /* Now that we have a non-comment line, probe ahead for the
693 first non-whitespace character. If it is another '&', then
694 reading starts at the next character, otherwise we must back
695 up to where the whitespace started and resume from there. */
697 old_loc
= gfc_current_locus
;
700 while (gfc_is_whitespace (c
))
705 for (i
= 0; i
< 5; i
++, c
= next_char ())
707 gcc_assert (TOLOWER (c
) == "!$omp"[i
]);
709 old_loc
= gfc_current_locus
;
711 while (gfc_is_whitespace (c
))
719 if (gfc_option
.warn_ampersand
)
720 gfc_warning_now ("Missing '&' in continued character constant at %C");
721 gfc_current_locus
.nextc
--;
723 /* Both !$omp and !$ -fopenmp continuation lines have & on the
724 continuation line only optionally. */
725 else if (openmp_flag
|| openmp_cond_flag
)
726 gfc_current_locus
.nextc
--;
730 gfc_current_locus
= old_loc
;
737 /* Fixed form continuation. */
738 if (!in_string
&& c
== '!')
740 /* Skip comment at end of line. */
747 /* Avoid truncation warnings for comment ending lines. */
748 gfc_current_locus
.lb
->truncated
= 0;
754 prev_openmp_flag
= openmp_flag
;
756 old_loc
= gfc_current_locus
;
759 skip_fixed_comments ();
761 /* See if this line is a continuation line. */
762 if (openmp_flag
!= prev_openmp_flag
)
764 openmp_flag
= prev_openmp_flag
;
765 goto not_continuation
;
769 for (i
= 0; i
< 5; i
++)
773 goto not_continuation
;
776 for (i
= 0; i
< 5; i
++)
779 if (TOLOWER (c
) != "*$omp"[i
])
780 goto not_continuation
;
784 if (c
== '0' || c
== ' ' || c
== '\n')
785 goto not_continuation
;
787 /* We've got a continuation line. If we are on the very next line after
788 the last continuation, increment the continuation line count and
789 check whether the limit has been exceeded. */
790 if (gfc_current_locus
.lb
->linenum
== continue_line
+ 1)
792 if (++continue_count
== gfc_option
.max_continue_fixed
)
794 if (gfc_notification_std (GFC_STD_GNU
)
796 gfc_warning ("Limit of %d continuations exceeded in statement at %C",
797 gfc_option
.max_continue_fixed
);
801 if (continue_line
< gfc_current_locus
.lb
->linenum
)
802 continue_line
= gfc_current_locus
.lb
->linenum
;
805 /* Ready to read first character of continuation line, which might
806 be another continuation line! */
811 gfc_current_locus
= old_loc
;
821 /* Get the next character of input, folded to lowercase. In fixed
822 form mode, we also ignore spaces. When matcher subroutines are
823 parsing character literals, they have to call
824 gfc_next_char_literal(). */
833 c
= gfc_next_char_literal (0);
835 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
847 old_loc
= gfc_current_locus
;
848 c
= gfc_next_char ();
849 gfc_current_locus
= old_loc
;
855 /* Recover from an error. We try to get past the current statement
856 and get lined up for the next. The next statement follows a '\n'
857 or a ';'. We also assume that we are not within a character
858 constant, and deal with finding a '\'' or '"'. */
861 gfc_error_recovery (void)
870 c
= gfc_next_char ();
871 if (c
== '\n' || c
== ';')
874 if (c
!= '\'' && c
!= '"')
903 /* Read ahead until the next character to be read is not whitespace. */
906 gfc_gobble_whitespace (void)
908 static int linenum
= 0;
914 old_loc
= gfc_current_locus
;
915 c
= gfc_next_char_literal (0);
916 /* Issue a warning for nonconforming tabs. We keep track of the line
917 number because the Fortran matchers will often back up and the same
918 line will be scanned multiple times. */
919 if (!gfc_option
.warn_tabs
&& c
== '\t')
921 #ifdef USE_MAPPED_LOCATION
922 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
924 int cur_linenum
= gfc_current_locus
.lb
->linenum
;
926 if (cur_linenum
!= linenum
)
928 linenum
= cur_linenum
;
929 gfc_warning_now ("Nonconforming tab character at %C");
933 while (gfc_is_whitespace (c
));
935 gfc_current_locus
= old_loc
;
939 /* Load a single line into pbuf.
941 If pbuf points to a NULL pointer, it is allocated.
942 We truncate lines that are too long, unless we're dealing with
943 preprocessor lines or if the option -ffixed-line-length-none is set,
944 in which case we reallocate the buffer to fit the entire line, if
946 In fixed mode, we expand a tab that occurs within the statement
947 label region to expand to spaces that leave the next character in
949 load_line returns whether the line was truncated.
951 NOTE: The error machinery isn't available at this point, so we can't
952 easily report line and column numbers consistent with other
953 parts of gfortran. */
956 load_line (FILE * input
, char **pbuf
, int *pbuflen
)
958 static int linenum
= 0, current_line
= 1;
959 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
960 int trunc_flag
= 0, seen_comment
= 0;
961 int seen_printable
= 0, seen_ampersand
= 0;
964 /* Determine the maximum allowed line length.
965 The default for free-form is GFC_MAX_LINE, for fixed-form or for
966 unknown form it is 72. Refer to the documentation in gfc_option_t. */
967 if (gfc_current_form
== FORM_FREE
)
969 if (gfc_option
.free_line_length
== -1)
970 maxlen
= GFC_MAX_LINE
;
972 maxlen
= gfc_option
.free_line_length
;
974 else if (gfc_current_form
== FORM_FIXED
)
976 if (gfc_option
.fixed_line_length
== -1)
979 maxlen
= gfc_option
.fixed_line_length
;
986 /* Allocate the line buffer, storing its length into buflen. */
990 buflen
= GFC_MAX_LINE
;
992 *pbuf
= gfc_getmem (buflen
+ 1);
998 preprocessor_flag
= 0;
1001 /* In order to not truncate preprocessor lines, we have to
1002 remember that this is one. */
1003 preprocessor_flag
= 1;
1014 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1015 if (gfc_current_form
== FORM_FREE
1016 && !seen_printable
&& seen_ampersand
)
1020 ("'&' not allowed by itself in line %d", current_line
);
1023 ("'&' not allowed by itself in line %d", current_line
);
1029 continue; /* Gobble characters. */
1033 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1037 if ((c
!= ' ' && c
!= '&' && c
!= '!') || (c
== '!' && !seen_ampersand
))
1040 if (gfc_current_form
== FORM_FREE
1041 && c
== '!' && !seen_printable
&& seen_ampersand
)
1045 "'&' not allowed by itself with comment in line %d", current_line
);
1048 "'&' not allowed by itself with comment in line %d", current_line
);
1052 /* Is this a fixed-form comment? */
1053 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1054 && (c
== '*' || c
== 'c' || c
== 'd'))
1057 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
<= 6)
1059 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1060 && current_line
!= linenum
)
1062 linenum
= current_line
;
1064 "Nonconforming tab character in column 1 of line %d", linenum
);
1079 if (maxlen
== 0 || preprocessor_flag
)
1083 /* Reallocate line buffer to double size to hold the
1085 buflen
= buflen
* 2;
1086 *pbuf
= xrealloc (*pbuf
, buflen
+ 1);
1090 else if (i
>= maxlen
)
1092 /* Truncate the rest of the line. */
1096 if (c
== '\n' || c
== EOF
)
1102 ungetc ('\n', input
);
1106 /* Pad lines to the selected line length in fixed form. */
1107 if (gfc_current_form
== FORM_FIXED
1108 && gfc_option
.fixed_line_length
!= 0
1109 && !preprocessor_flag
1112 while (i
++ < maxlen
)
1124 /* Get a gfc_file structure, initialize it and add it to
1128 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1132 f
= gfc_getmem (sizeof (gfc_file
));
1134 f
->filename
= gfc_getmem (strlen (name
) + 1);
1135 strcpy (f
->filename
, name
);
1137 f
->next
= file_head
;
1140 f
->included_by
= current_file
;
1141 if (current_file
!= NULL
)
1142 f
->inclusion_line
= current_file
->line
;
1144 #ifdef USE_MAPPED_LOCATION
1145 linemap_add (&line_table
, reason
, false, f
->filename
, 1);
1151 /* Deal with a line from the C preprocessor. The
1152 initial octothorp has already been seen. */
1155 preprocessor_line (char *c
)
1161 int escaped
, unescape
;
1164 while (*c
== ' ' || *c
== '\t')
1167 if (*c
< '0' || *c
> '9')
1172 c
= strchr (c
, ' ');
1175 /* No file name given. Set new line number. */
1176 current_file
->line
= line
;
1181 while (*c
== ' ' || *c
== '\t')
1191 /* Make filename end at quote. */
1194 while (*c
&& ! (! escaped
&& *c
== '"'))
1198 else if (*c
== '\\')
1207 /* Preprocessor line has no closing quote. */
1212 /* Undo effects of cpp_quote_string. */
1216 char *d
= gfc_getmem (c
- filename
- unescape
);
1232 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1236 c
= strchr (c
, ' ');
1243 if (1 <= i
&& i
<= 4)
1247 /* Interpret flags. */
1249 if (flag
[1]) /* Starting new file. */
1251 f
= get_file (filename
, LC_RENAME
);
1252 f
->up
= current_file
;
1256 if (flag
[2]) /* Ending current file. */
1258 if (!current_file
->up
1259 || strcmp (current_file
->up
->filename
, filename
) != 0)
1261 gfc_warning_now ("%s:%d: file %s left but not entered",
1262 current_file
->filename
, current_file
->line
,
1265 gfc_free (filename
);
1268 current_file
= current_file
->up
;
1271 /* The name of the file can be a temporary file produced by
1272 cpp. Replace the name if it is different. */
1274 if (strcmp (current_file
->filename
, filename
) != 0)
1276 gfc_free (current_file
->filename
);
1277 current_file
->filename
= gfc_getmem (strlen (filename
) + 1);
1278 strcpy (current_file
->filename
, filename
);
1281 /* Set new line number. */
1282 current_file
->line
= line
;
1284 gfc_free (filename
);
1288 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1289 current_file
->filename
, current_file
->line
);
1290 current_file
->line
++;
1294 static try load_file (const char *, bool);
1296 /* include_line()-- Checks a line buffer to see if it is an include
1297 line. If so, we call load_file() recursively to load the included
1298 file. We never return a syntax error because a statement like
1299 "include = 5" is perfectly legal. We return false if no include was
1300 processed or true if we matched an include. */
1303 include_line (char *line
)
1305 char quote
, *c
, *begin
, *stop
;
1309 if (gfc_option
.flag_openmp
)
1311 if (gfc_current_form
== FORM_FREE
)
1313 while (*c
== ' ' || *c
== '\t')
1315 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1320 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1321 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1326 while (*c
== ' ' || *c
== '\t')
1329 if (strncasecmp (c
, "include", 7))
1333 while (*c
== ' ' || *c
== '\t')
1336 /* Find filename between quotes. */
1339 if (quote
!= '"' && quote
!= '\'')
1344 while (*c
!= quote
&& *c
!= '\0')
1352 while (*c
== ' ' || *c
== '\t')
1355 if (*c
!= '\0' && *c
!= '!')
1358 /* We have an include line at this point. */
1360 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1361 read by anything else. */
1363 load_file (begin
, false);
1367 /* Load a file into memory by calling load_line until the file ends. */
1370 load_file (const char *filename
, bool initial
)
1378 for (f
= current_file
; f
; f
= f
->up
)
1379 if (strcmp (filename
, f
->filename
) == 0)
1381 gfc_error_now ("File '%s' is being included recursively", filename
);
1389 input
= gfc_src_file
;
1390 gfc_src_file
= NULL
;
1393 input
= gfc_open_file (filename
);
1396 gfc_error_now ("Can't open file '%s'", filename
);
1402 input
= gfc_open_included_file (filename
, false);
1405 gfc_error_now ("Can't open included file '%s'", filename
);
1410 /* Load the file. */
1412 f
= get_file (filename
, initial
? LC_RENAME
: LC_ENTER
);
1413 f
->up
= current_file
;
1415 current_file
->line
= 1;
1419 if (initial
&& gfc_src_preprocessor_lines
[0])
1421 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1422 gfc_free (gfc_src_preprocessor_lines
[0]);
1423 gfc_src_preprocessor_lines
[0] = NULL
;
1424 if (gfc_src_preprocessor_lines
[1])
1426 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1427 gfc_free (gfc_src_preprocessor_lines
[1]);
1428 gfc_src_preprocessor_lines
[1] = NULL
;
1434 int trunc
= load_line (input
, &line
, &line_len
);
1436 len
= strlen (line
);
1437 if (feof (input
) && len
== 0)
1440 /* There are three things this line can be: a line of Fortran
1441 source, an include line or a C preprocessor directive. */
1445 preprocessor_line (line
);
1449 if (include_line (line
))
1451 current_file
->line
++;
1457 b
= gfc_getmem (gfc_linebuf_header_size
+ len
+ 1);
1459 #ifdef USE_MAPPED_LOCATION
1461 = linemap_line_start (&line_table
, current_file
->line
++, 120);
1463 b
->linenum
= current_file
->line
++;
1465 b
->file
= current_file
;
1466 b
->truncated
= trunc
;
1467 strcpy (b
->line
, line
);
1469 if (line_head
== NULL
)
1472 line_tail
->next
= b
;
1477 /* Release the line buffer allocated in load_line. */
1482 current_file
= current_file
->up
;
1483 #ifdef USE_MAPPED_LOCATION
1484 linemap_add (&line_table
, LC_LEAVE
, 0, NULL
, 0);
1490 /* Open a new file and start scanning from that file. Returns SUCCESS
1491 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1492 it tries to determine the source form from the filename, defaulting
1500 result
= load_file (gfc_source_file
, true);
1502 gfc_current_locus
.lb
= line_head
;
1503 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
1505 #if 0 /* Debugging aid. */
1506 for (; line_head
; line_head
= line_head
->next
)
1507 gfc_status ("%s:%3d %s\n", line_head
->file
->filename
,
1508 #ifdef USE_MAPPED_LOCATION
1509 LOCATION_LINE (line_head
->location
),
1522 unescape_filename (const char *ptr
)
1524 const char *p
= ptr
, *s
;
1526 int escaped
, unescape
= 0;
1528 /* Make filename end at quote. */
1530 while (*p
&& ! (! escaped
&& *p
== '"'))
1534 else if (*p
== '\\')
1545 /* Undo effects of cpp_quote_string. */
1547 d
= gfc_getmem (p
+ 1 - ptr
- unescape
);
1562 /* For preprocessed files, if the first tokens are of the form # NUM.
1563 handle the directives so we know the original file name. */
1566 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
1571 gfc_src_file
= gfc_open_file (filename
);
1572 if (gfc_src_file
== NULL
)
1575 c
= fgetc (gfc_src_file
);
1576 ungetc (c
, gfc_src_file
);
1582 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
);
1584 if (strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
1587 filename
= unescape_filename (gfc_src_preprocessor_lines
[0] + 5);
1588 if (filename
== NULL
)
1591 c
= fgetc (gfc_src_file
);
1592 ungetc (c
, gfc_src_file
);
1598 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
);
1600 if (strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
1603 dirname
= unescape_filename (gfc_src_preprocessor_lines
[1] + 5);
1604 if (dirname
== NULL
)
1607 len
= strlen (dirname
);
1608 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
1613 dirname
[len
- 2] = '\0';
1614 set_src_pwd (dirname
);
1616 if (! IS_ABSOLUTE_PATH (filename
))
1618 char *p
= gfc_getmem (len
+ strlen (filename
));
1620 memcpy (p
, dirname
, len
- 2);
1622 strcpy (p
+ len
- 1, filename
);
1623 *canon_source_file
= p
;