2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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. */
52 /* Structure for holding module and include file search path. */
53 typedef struct gfc_directorylist
57 struct gfc_directorylist
*next
;
61 /* List of include file search directories. */
62 static gfc_directorylist
*include_dirs
, *intrinsic_modules_dirs
;
64 static gfc_file
*file_head
, *current_file
;
66 static int continue_flag
, end_flag
, openmp_flag
;
67 static int continue_count
, continue_line
;
68 static locus openmp_locus
;
70 gfc_source_form gfc_current_form
;
71 static gfc_linebuf
*line_head
, *line_tail
;
73 locus gfc_current_locus
;
74 const char *gfc_source_file
;
75 static FILE *gfc_src_file
;
76 static gfc_char_t
*gfc_src_preprocessor_lines
[2];
80 static struct gfc_file_change
86 size_t file_changes_cur
, file_changes_count
;
87 size_t file_changes_allocated
;
90 /* Functions dealing with our wide characters (gfc_char_t) and
91 sequences of such characters. */
94 gfc_wide_fits_in_byte (gfc_char_t c
)
96 return (c
<= UCHAR_MAX
);
100 wide_is_ascii (gfc_char_t c
)
102 return (gfc_wide_fits_in_byte (c
) && ((unsigned char) c
& ~0x7f) == 0);
106 gfc_wide_is_printable (gfc_char_t c
)
108 return (gfc_wide_fits_in_byte (c
) && ISPRINT ((unsigned char) c
));
112 gfc_wide_tolower (gfc_char_t c
)
114 return (wide_is_ascii (c
) ? (gfc_char_t
) TOLOWER((unsigned char) c
) : c
);
118 gfc_wide_toupper (gfc_char_t c
)
120 return (wide_is_ascii (c
) ? (gfc_char_t
) TOUPPER((unsigned char) c
) : c
);
124 gfc_wide_is_digit (gfc_char_t c
)
126 return (c
>= '0' && c
<= '9');
130 wide_atoi (gfc_char_t
*c
)
132 #define MAX_DIGITS 20
133 char buf
[MAX_DIGITS
+1];
136 while (gfc_wide_is_digit(*c
) && i
< MAX_DIGITS
)
143 gfc_wide_strlen (const gfc_char_t
*str
)
147 for (i
= 0; str
[i
]; i
++)
154 gfc_wide_memset (gfc_char_t
*b
, gfc_char_t c
, size_t len
)
158 for (i
= 0; i
< len
; i
++)
165 wide_strcpy (gfc_char_t
*dest
, const gfc_char_t
*src
)
169 for (d
= dest
; (*d
= *src
) != '\0'; ++src
, ++d
)
176 wide_strchr (const gfc_char_t
*s
, gfc_char_t c
)
181 return CONST_CAST(gfc_char_t
*, s
);
188 gfc_widechar_to_char (const gfc_char_t
*s
, int length
)
196 /* Passing a negative length is used to indicate that length should be
197 calculated using gfc_wide_strlen(). */
198 len
= (length
>= 0 ? (size_t) length
: gfc_wide_strlen (s
));
199 res
= XNEWVEC (char, len
+ 1);
201 for (i
= 0; i
< len
; i
++)
203 gcc_assert (gfc_wide_fits_in_byte (s
[i
]));
204 res
[i
] = (unsigned char) s
[i
];
212 gfc_char_to_widechar (const char *s
)
221 res
= gfc_get_wide_string (len
+ 1);
223 for (i
= 0; i
< len
; i
++)
224 res
[i
] = (unsigned char) s
[i
];
231 wide_strncmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
240 return (c1
> c2
? 1 : -1);
248 gfc_wide_strncasecmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
254 c1
= gfc_wide_tolower (*s1
++);
255 c2
= TOLOWER (*s2
++);
257 return (c1
> c2
? 1 : -1);
265 /* Main scanner initialization. */
268 gfc_scanner_init_1 (void)
281 /* Main scanner destructor. */
284 gfc_scanner_done_1 (void)
289 while(line_head
!= NULL
)
291 lb
= line_head
->next
;
296 while(file_head
!= NULL
)
299 gfc_free(file_head
->filename
);
306 /* Adds path to the list pointed to by list. */
309 add_path_to_list (gfc_directorylist
**list
, const char *path
,
310 bool use_for_modules
)
312 gfc_directorylist
*dir
;
316 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
322 dir
= *list
= XCNEW (gfc_directorylist
);
328 dir
->next
= XCNEW (gfc_directorylist
);
333 dir
->use_for_modules
= use_for_modules
;
334 dir
->path
= XCNEWVEC (char, strlen (p
) + 2);
335 strcpy (dir
->path
, p
);
336 strcat (dir
->path
, "/"); /* make '/' last character */
341 gfc_add_include_path (const char *path
, bool use_for_modules
)
343 add_path_to_list (&include_dirs
, path
, use_for_modules
);
344 gfc_cpp_add_include_path (xstrdup(path
), true);
349 gfc_add_intrinsic_modules_path (const char *path
)
351 add_path_to_list (&intrinsic_modules_dirs
, path
, true);
355 /* Release resources allocated for options. */
358 gfc_release_include_path (void)
360 gfc_directorylist
*p
;
362 while (include_dirs
!= NULL
)
365 include_dirs
= include_dirs
->next
;
370 while (intrinsic_modules_dirs
!= NULL
)
372 p
= intrinsic_modules_dirs
;
373 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
378 gfc_free (gfc_option
.module_dir
);
383 open_included_file (const char *name
, gfc_directorylist
*list
, bool module
)
386 gfc_directorylist
*p
;
389 for (p
= list
; p
; p
= p
->next
)
391 if (module
&& !p
->use_for_modules
)
394 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
395 strcpy (fullname
, p
->path
);
396 strcat (fullname
, name
);
398 f
= gfc_open_file (fullname
);
407 /* Opens file for reading, searching through the include directories
408 given if necessary. If the include_cwd argument is true, we try
409 to open the file in the current directory first. */
412 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
416 if (IS_ABSOLUTE_PATH (name
))
417 return gfc_open_file (name
);
421 f
= gfc_open_file (name
);
426 return open_included_file (name
, include_dirs
, module
);
430 gfc_open_intrinsic_module (const char *name
)
432 if (IS_ABSOLUTE_PATH (name
))
433 return gfc_open_file (name
);
435 return open_included_file (name
, intrinsic_modules_dirs
, true);
439 /* Test to see if we're at the end of the main source file. */
448 /* Test to see if we're at the end of the current file. */
456 if (line_head
== NULL
)
457 return 1; /* Null file */
459 if (gfc_current_locus
.lb
== NULL
)
466 /* Test to see if we're at the beginning of a new line. */
474 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
478 /* Test to see if we're at the end of a line. */
486 return (*gfc_current_locus
.nextc
== '\0');
490 add_file_change (const char *filename
, int line
)
492 if (file_changes_count
== file_changes_allocated
)
494 if (file_changes_allocated
)
495 file_changes_allocated
*= 2;
497 file_changes_allocated
= 16;
498 file_changes
= XRESIZEVEC (struct gfc_file_change
, file_changes
,
499 file_changes_allocated
);
501 file_changes
[file_changes_count
].filename
= filename
;
502 file_changes
[file_changes_count
].lb
= NULL
;
503 file_changes
[file_changes_count
++].line
= line
;
507 report_file_change (gfc_linebuf
*lb
)
509 size_t c
= file_changes_cur
;
510 while (c
< file_changes_count
511 && file_changes
[c
].lb
== lb
)
513 if (file_changes
[c
].filename
)
514 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
515 file_changes
[c
].filename
);
517 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
520 file_changes_cur
= c
;
524 gfc_start_source_files (void)
526 /* If the debugger wants the name of the main source file,
528 if (debug_hooks
->start_end_main_source_file
)
529 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
531 file_changes_cur
= 0;
532 report_file_change (gfc_current_locus
.lb
);
536 gfc_end_source_files (void)
538 report_file_change (NULL
);
540 if (debug_hooks
->start_end_main_source_file
)
541 (*debug_hooks
->end_source_file
) (0);
544 /* Advance the current line pointer to the next line. */
547 gfc_advance_line (void)
552 if (gfc_current_locus
.lb
== NULL
)
558 if (gfc_current_locus
.lb
->next
559 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
561 report_file_change (gfc_current_locus
.lb
->next
);
562 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
565 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
567 if (gfc_current_locus
.lb
!= NULL
)
568 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
571 gfc_current_locus
.nextc
= NULL
;
577 /* Get the next character from the input, advancing gfc_current_file's
578 locus. When we hit the end of the line or the end of the file, we
579 start returning a '\n' in order to complete the current statement.
580 No Fortran line conventions are implemented here.
582 Requiring explicit advances to the next line prevents the parse
583 pointer from being on the wrong line if the current statement ends
591 if (gfc_current_locus
.nextc
== NULL
)
594 c
= *gfc_current_locus
.nextc
++;
597 gfc_current_locus
.nextc
--; /* Remain on this line. */
605 /* Skip a comment. When we come here the parse pointer is positioned
606 immediately after the comment character. If we ever implement
607 compiler directives withing comments, here is where we parse the
611 skip_comment_line (void)
626 gfc_define_undef_line (void)
630 /* All lines beginning with '#' are either #define or #undef. */
631 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
634 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
636 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
637 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
642 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
644 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
645 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
650 /* Skip the rest of the line. */
651 skip_comment_line ();
657 /* Comment lines are null lines, lines containing only blanks or lines
658 on which the first nonblank line is a '!'.
659 Return true if !$ openmp conditional compilation sentinel was
663 skip_free_comments (void)
671 at_bol
= gfc_at_bol ();
672 start
= gfc_current_locus
;
678 while (gfc_is_whitespace (c
));
688 /* If -fopenmp, we need to handle here 2 things:
689 1) don't treat !$omp as comments, but directives
690 2) handle OpenMP conditional compilation, where
691 !$ should be treated as 2 spaces (for initial lines
692 only if followed by space). */
693 if (gfc_option
.flag_openmp
&& at_bol
)
695 locus old_loc
= gfc_current_locus
;
696 if (next_char () == '$')
699 if (c
== 'o' || c
== 'O')
701 if (((c
= next_char ()) == 'm' || c
== 'M')
702 && ((c
= next_char ()) == 'p' || c
== 'P'))
704 if ((c
= next_char ()) == ' ' || c
== '\t'
707 while (gfc_is_whitespace (c
))
709 if (c
!= '\n' && c
!= '!')
712 openmp_locus
= old_loc
;
713 gfc_current_locus
= start
;
718 gfc_warning_now ("!$OMP at %C starts a commented "
719 "line as it neither is followed "
720 "by a space nor is a "
721 "continuation line");
723 gfc_current_locus
= old_loc
;
727 if (continue_flag
|| c
== ' ' || c
== '\t')
729 gfc_current_locus
= old_loc
;
735 gfc_current_locus
= old_loc
;
737 skip_comment_line ();
744 if (openmp_flag
&& at_bol
)
746 gfc_current_locus
= start
;
751 /* Skip comment lines in fixed source mode. We have the same rules as
752 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
753 in column 1, and a '!' cannot be in column 6. Also, we deal with
754 lines with 'd' or 'D' in column 1, if the user requested this. */
757 skip_fixed_comments (void)
765 start
= gfc_current_locus
;
770 while (gfc_is_whitespace (c
));
775 skip_comment_line ();
780 gfc_current_locus
= start
;
787 start
= gfc_current_locus
;
798 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
800 /* If -fopenmp, we need to handle here 2 things:
801 1) don't treat !$omp|c$omp|*$omp as comments, but directives
802 2) handle OpenMP conditional compilation, where
803 !$|c$|*$ should be treated as 2 spaces if the characters
804 in columns 3 to 6 are valid fixed form label columns
806 if (gfc_current_locus
.lb
!= NULL
807 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
808 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
810 if (gfc_option
.flag_openmp
)
812 if (next_char () == '$')
815 if (c
== 'o' || c
== 'O')
817 if (((c
= next_char ()) == 'm' || c
== 'M')
818 && ((c
= next_char ()) == 'p' || c
== 'P'))
822 && ((openmp_flag
&& continue_flag
)
823 || c
== ' ' || c
== '\t' || c
== '0'))
827 while (gfc_is_whitespace (c
));
828 if (c
!= '\n' && c
!= '!')
830 /* Canonicalize to *$omp. */
833 gfc_current_locus
= start
;
843 for (col
= 3; col
< 6; col
++, c
= next_char ())
851 else if (c
< '0' || c
> '9')
856 if (col
== 6 && c
!= '\n'
857 && ((continue_flag
&& !digit_seen
)
858 || c
== ' ' || c
== '\t' || c
== '0'))
860 gfc_current_locus
= start
;
861 start
.nextc
[0] = ' ';
862 start
.nextc
[1] = ' ';
867 gfc_current_locus
= start
;
869 skip_comment_line ();
873 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
875 if (gfc_option
.flag_d_lines
== 0)
877 skip_comment_line ();
881 *start
.nextc
= c
= ' ';
886 while (gfc_is_whitespace (c
))
898 if (col
!= 6 && c
== '!')
900 if (gfc_current_locus
.lb
!= NULL
901 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
902 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
903 skip_comment_line ();
911 gfc_current_locus
= start
;
915 /* Skips the current line if it is a comment. */
918 gfc_skip_comments (void)
920 if (gfc_current_form
== FORM_FREE
)
921 skip_free_comments ();
923 skip_fixed_comments ();
927 /* Get the next character from the input, taking continuation lines
928 and end-of-line comments into account. This implies that comment
929 lines between continued lines must be eaten here. For higher-level
930 subroutines, this flattens continued lines into a single logical
931 line. The in_string flag denotes whether we're inside a character
935 gfc_next_char_literal (int in_string
)
938 int i
, prev_openmp_flag
;
951 if (gfc_current_form
== FORM_FREE
)
953 bool openmp_cond_flag
;
955 if (!in_string
&& c
== '!')
958 && memcmp (&gfc_current_locus
, &openmp_locus
,
959 sizeof (gfc_current_locus
)) == 0)
962 /* This line can't be continued */
969 /* Avoid truncation warnings for comment ending lines. */
970 gfc_current_locus
.lb
->truncated
= 0;
978 /* If the next nonblank character is a ! or \n, we've got a
979 continuation line. */
980 old_loc
= gfc_current_locus
;
983 while (gfc_is_whitespace (c
))
986 /* Character constants to be continued cannot have commentary
989 if (in_string
&& c
!= '\n')
991 gfc_current_locus
= old_loc
;
996 if (c
!= '!' && c
!= '\n')
998 gfc_current_locus
= old_loc
;
1003 prev_openmp_flag
= openmp_flag
;
1006 skip_comment_line ();
1008 gfc_advance_line ();
1011 goto not_continuation
;
1013 /* We've got a continuation line. If we are on the very next line after
1014 the last continuation, increment the continuation line count and
1015 check whether the limit has been exceeded. */
1016 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1018 if (++continue_count
== gfc_option
.max_continue_free
)
1020 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1021 gfc_warning ("Limit of %d continuations exceeded in "
1022 "statement at %C", gfc_option
.max_continue_free
);
1026 /* Now find where it continues. First eat any comment lines. */
1027 openmp_cond_flag
= skip_free_comments ();
1029 if (gfc_current_locus
.lb
!= NULL
1030 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1031 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1033 if (prev_openmp_flag
!= openmp_flag
)
1035 gfc_current_locus
= old_loc
;
1036 openmp_flag
= prev_openmp_flag
;
1041 /* Now that we have a non-comment line, probe ahead for the
1042 first non-whitespace character. If it is another '&', then
1043 reading starts at the next character, otherwise we must back
1044 up to where the whitespace started and resume from there. */
1046 old_loc
= gfc_current_locus
;
1049 while (gfc_is_whitespace (c
))
1054 for (i
= 0; i
< 5; i
++, c
= next_char ())
1056 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1058 old_loc
= gfc_current_locus
;
1060 while (gfc_is_whitespace (c
))
1068 if (gfc_option
.warn_ampersand
)
1069 gfc_warning_now ("Missing '&' in continued character "
1071 gfc_current_locus
.nextc
--;
1073 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1074 continuation line only optionally. */
1075 else if (openmp_flag
|| openmp_cond_flag
)
1076 gfc_current_locus
.nextc
--;
1080 gfc_current_locus
= old_loc
;
1087 /* Fixed form continuation. */
1088 if (!in_string
&& c
== '!')
1090 /* Skip comment at end of line. */
1097 /* Avoid truncation warnings for comment ending lines. */
1098 gfc_current_locus
.lb
->truncated
= 0;
1104 prev_openmp_flag
= openmp_flag
;
1106 old_loc
= gfc_current_locus
;
1108 gfc_advance_line ();
1109 skip_fixed_comments ();
1111 /* See if this line is a continuation line. */
1112 if (openmp_flag
!= prev_openmp_flag
)
1114 openmp_flag
= prev_openmp_flag
;
1115 goto not_continuation
;
1119 for (i
= 0; i
< 5; i
++)
1123 goto not_continuation
;
1126 for (i
= 0; i
< 5; i
++)
1129 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1130 goto not_continuation
;
1134 if (c
== '0' || c
== ' ' || c
== '\n')
1135 goto not_continuation
;
1137 /* We've got a continuation line. If we are on the very next line after
1138 the last continuation, increment the continuation line count and
1139 check whether the limit has been exceeded. */
1140 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1142 if (++continue_count
== gfc_option
.max_continue_fixed
)
1144 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1145 gfc_warning ("Limit of %d continuations exceeded in "
1147 gfc_option
.max_continue_fixed
);
1151 if (gfc_current_locus
.lb
!= NULL
1152 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1153 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1156 /* Ready to read first character of continuation line, which might
1157 be another continuation line! */
1162 gfc_current_locus
= old_loc
;
1172 /* Get the next character of input, folded to lowercase. In fixed
1173 form mode, we also ignore spaces. When matcher subroutines are
1174 parsing character literals, they have to call
1175 gfc_next_char_literal(). */
1178 gfc_next_char (void)
1184 c
= gfc_next_char_literal (0);
1186 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1188 return gfc_wide_tolower (c
);
1192 gfc_next_ascii_char (void)
1194 gfc_char_t c
= gfc_next_char ();
1196 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1197 : (unsigned char) UCHAR_MAX
);
1202 gfc_peek_char (void)
1207 old_loc
= gfc_current_locus
;
1208 c
= gfc_next_char ();
1209 gfc_current_locus
= old_loc
;
1216 gfc_peek_ascii_char (void)
1218 gfc_char_t c
= gfc_peek_char ();
1220 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1221 : (unsigned char) UCHAR_MAX
);
1225 /* Recover from an error. We try to get past the current statement
1226 and get lined up for the next. The next statement follows a '\n'
1227 or a ';'. We also assume that we are not within a character
1228 constant, and deal with finding a '\'' or '"'. */
1231 gfc_error_recovery (void)
1233 gfc_char_t c
, delim
;
1240 c
= gfc_next_char ();
1241 if (c
== '\n' || c
== ';')
1244 if (c
!= '\'' && c
!= '"')
1273 /* Read ahead until the next character to be read is not whitespace. */
1276 gfc_gobble_whitespace (void)
1278 static int linenum
= 0;
1284 old_loc
= gfc_current_locus
;
1285 c
= gfc_next_char_literal (0);
1286 /* Issue a warning for nonconforming tabs. We keep track of the line
1287 number because the Fortran matchers will often back up and the same
1288 line will be scanned multiple times. */
1289 if (!gfc_option
.warn_tabs
&& c
== '\t')
1291 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1292 if (cur_linenum
!= linenum
)
1294 linenum
= cur_linenum
;
1295 gfc_warning_now ("Nonconforming tab character at %C");
1299 while (gfc_is_whitespace (c
));
1301 gfc_current_locus
= old_loc
;
1305 /* Load a single line into pbuf.
1307 If pbuf points to a NULL pointer, it is allocated.
1308 We truncate lines that are too long, unless we're dealing with
1309 preprocessor lines or if the option -ffixed-line-length-none is set,
1310 in which case we reallocate the buffer to fit the entire line, if
1312 In fixed mode, we expand a tab that occurs within the statement
1313 label region to expand to spaces that leave the next character in
1316 If first_char is not NULL, it's a pointer to a single char value holding
1317 the first character of the line, which has already been read by the
1318 caller. This avoids the use of ungetc().
1320 load_line returns whether the line was truncated.
1322 NOTE: The error machinery isn't available at this point, so we can't
1323 easily report line and column numbers consistent with other
1324 parts of gfortran. */
1327 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1329 static int linenum
= 0, current_line
= 1;
1330 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1331 int trunc_flag
= 0, seen_comment
= 0;
1332 int seen_printable
= 0, seen_ampersand
= 0;
1334 bool found_tab
= false;
1336 /* Determine the maximum allowed line length. */
1337 if (gfc_current_form
== FORM_FREE
)
1338 maxlen
= gfc_option
.free_line_length
;
1339 else if (gfc_current_form
== FORM_FIXED
)
1340 maxlen
= gfc_option
.fixed_line_length
;
1346 /* Allocate the line buffer, storing its length into buflen.
1347 Note that if maxlen==0, indicating that arbitrary-length lines
1348 are allowed, the buffer will be reallocated if this length is
1349 insufficient; since 132 characters is the length of a standard
1350 free-form line, we use that as a starting guess. */
1356 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1367 /* In order to not truncate preprocessor lines, we have to
1368 remember that this is one. */
1369 preprocessor_flag
= (c
== '#' ? 1 : 0);
1378 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1379 if (gfc_current_form
== FORM_FREE
1380 && !seen_printable
&& seen_ampersand
)
1383 gfc_error_now ("'&' not allowed by itself in line %d",
1386 gfc_warning_now ("'&' not allowed by itself in line %d",
1392 if (c
== '\r' || c
== '\0')
1393 goto next_char
; /* Gobble characters. */
1403 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1406 /* Is this a fixed-form comment? */
1407 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1408 && (c
== '*' || c
== 'c' || c
== 'd'))
1411 /* Vendor extension: "<tab>1" marks a continuation line. */
1415 if (c
>= '1' && c
<= '9')
1422 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1426 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1427 && current_line
!= linenum
)
1429 linenum
= current_line
;
1430 gfc_warning_now ("Nonconforming tab character in column %d "
1431 "of line %d", i
+1, linenum
);
1446 if (maxlen
== 0 || preprocessor_flag
)
1450 /* Reallocate line buffer to double size to hold the
1452 buflen
= buflen
* 2;
1453 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1454 buffer
= (*pbuf
) + i
;
1457 else if (i
>= maxlen
)
1459 /* Truncate the rest of the line. */
1463 if (c
== '\n' || c
== EOF
)
1477 /* Pad lines to the selected line length in fixed form. */
1478 if (gfc_current_form
== FORM_FIXED
1479 && gfc_option
.fixed_line_length
!= 0
1480 && !preprocessor_flag
1483 while (i
++ < maxlen
)
1495 /* Get a gfc_file structure, initialize it and add it to
1499 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1503 f
= XCNEW (gfc_file
);
1505 f
->filename
= xstrdup (name
);
1507 f
->next
= file_head
;
1510 f
->up
= current_file
;
1511 if (current_file
!= NULL
)
1512 f
->inclusion_line
= current_file
->line
;
1514 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1520 /* Deal with a line from the C preprocessor. The
1521 initial octothorp has already been seen. */
1524 preprocessor_line (gfc_char_t
*c
)
1528 gfc_char_t
*wide_filename
;
1530 int escaped
, unescape
;
1534 while (*c
== ' ' || *c
== '\t')
1537 if (*c
< '0' || *c
> '9')
1540 line
= wide_atoi (c
);
1542 c
= wide_strchr (c
, ' ');
1545 /* No file name given. Set new line number. */
1546 current_file
->line
= line
;
1551 while (*c
== ' ' || *c
== '\t')
1561 /* Make filename end at quote. */
1564 while (*c
&& ! (!escaped
&& *c
== '"'))
1568 else if (*c
== '\\')
1577 /* Preprocessor line has no closing quote. */
1582 /* Undo effects of cpp_quote_string. */
1585 gfc_char_t
*s
= wide_filename
;
1586 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
1602 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1606 c
= wide_strchr (c
, ' ');
1613 if (1 <= i
&& i
<= 4)
1617 /* Convert the filename in wide characters into a filename in narrow
1619 filename
= gfc_widechar_to_char (wide_filename
, -1);
1621 /* Interpret flags. */
1623 if (flag
[1]) /* Starting new file. */
1625 f
= get_file (filename
, LC_RENAME
);
1626 add_file_change (f
->filename
, f
->inclusion_line
);
1630 if (flag
[2]) /* Ending current file. */
1632 if (!current_file
->up
1633 || strcmp (current_file
->up
->filename
, filename
) != 0)
1635 gfc_warning_now ("%s:%d: file %s left but not entered",
1636 current_file
->filename
, current_file
->line
,
1639 gfc_free (wide_filename
);
1640 gfc_free (filename
);
1644 add_file_change (NULL
, line
);
1645 current_file
= current_file
->up
;
1646 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
1647 current_file
->line
);
1650 /* The name of the file can be a temporary file produced by
1651 cpp. Replace the name if it is different. */
1653 if (strcmp (current_file
->filename
, filename
) != 0)
1655 /* FIXME: we leak the old filename because a pointer to it may be stored
1656 in the linemap. Alternative could be using GC or updating linemap to
1657 point to the new name, but there is no API for that currently. */
1658 current_file
->filename
= xstrdup (filename
);
1661 /* Set new line number. */
1662 current_file
->line
= line
;
1664 gfc_free (wide_filename
);
1665 gfc_free (filename
);
1669 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1670 current_file
->filename
, current_file
->line
);
1671 current_file
->line
++;
1675 static try load_file (const char *, bool);
1677 /* include_line()-- Checks a line buffer to see if it is an include
1678 line. If so, we call load_file() recursively to load the included
1679 file. We never return a syntax error because a statement like
1680 "include = 5" is perfectly legal. We return false if no include was
1681 processed or true if we matched an include. */
1684 include_line (gfc_char_t
*line
)
1686 gfc_char_t quote
, *c
, *begin
, *stop
;
1691 if (gfc_option
.flag_openmp
)
1693 if (gfc_current_form
== FORM_FREE
)
1695 while (*c
== ' ' || *c
== '\t')
1697 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1702 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1703 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1708 while (*c
== ' ' || *c
== '\t')
1711 if (gfc_wide_strncasecmp (c
, "include", 7))
1715 while (*c
== ' ' || *c
== '\t')
1718 /* Find filename between quotes. */
1721 if (quote
!= '"' && quote
!= '\'')
1726 while (*c
!= quote
&& *c
!= '\0')
1734 while (*c
== ' ' || *c
== '\t')
1737 if (*c
!= '\0' && *c
!= '!')
1740 /* We have an include line at this point. */
1742 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1743 read by anything else. */
1745 filename
= gfc_widechar_to_char (begin
, -1);
1746 load_file (filename
, false);
1747 gfc_free (filename
);
1752 /* Load a file into memory by calling load_line until the file ends. */
1755 load_file (const char *filename
, bool initial
)
1764 for (f
= current_file
; f
; f
= f
->up
)
1765 if (strcmp (filename
, f
->filename
) == 0)
1767 gfc_error_now ("File '%s' is being included recursively", filename
);
1775 input
= gfc_src_file
;
1776 gfc_src_file
= NULL
;
1779 input
= gfc_open_file (filename
);
1782 gfc_error_now ("Can't open file '%s'", filename
);
1788 input
= gfc_open_included_file (filename
, false, false);
1791 gfc_error_now ("Can't open included file '%s'", filename
);
1796 /* Load the file. */
1798 f
= get_file (filename
, initial
? LC_RENAME
: LC_ENTER
);
1800 add_file_change (f
->filename
, f
->inclusion_line
);
1802 current_file
->line
= 1;
1807 if (initial
&& gfc_src_preprocessor_lines
[0])
1809 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1810 gfc_free (gfc_src_preprocessor_lines
[0]);
1811 gfc_src_preprocessor_lines
[0] = NULL
;
1812 if (gfc_src_preprocessor_lines
[1])
1814 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1815 gfc_free (gfc_src_preprocessor_lines
[1]);
1816 gfc_src_preprocessor_lines
[1] = NULL
;
1822 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
1824 len
= gfc_wide_strlen (line
);
1825 if (feof (input
) && len
== 0)
1828 /* If this is the first line of the file, it can contain a byte
1829 order mark (BOM), which we will ignore:
1830 FF FE is UTF-16 little endian,
1831 FE FF is UTF-16 big endian,
1832 EF BB BF is UTF-8. */
1834 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
1835 && line
[1] == (unsigned char) '\xFE')
1836 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
1837 && line
[1] == (unsigned char) '\xFF')
1838 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
1839 && line
[1] == (unsigned char) '\xBB'
1840 && line
[2] == (unsigned char) '\xBF')))
1842 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
1843 gfc_char_t
*new = gfc_get_wide_string (line_len
);
1845 wide_strcpy (new, &line
[n
]);
1851 /* There are three things this line can be: a line of Fortran
1852 source, an include line or a C preprocessor directive. */
1856 /* When -g3 is specified, it's possible that we emit #define
1857 and #undef lines, which we need to pass to the middle-end
1858 so that it can emit correct debug info. */
1859 if (debug_info_level
== DINFO_LEVEL_VERBOSE
1860 && (wide_strncmp (line
, "#define ", 8) == 0
1861 || wide_strncmp (line
, "#undef ", 7) == 0))
1865 preprocessor_line (line
);
1870 /* Preprocessed files have preprocessor lines added before the byte
1871 order mark, so first_line is not about the first line of the file
1872 but the first line that's not a preprocessor line. */
1875 if (include_line (line
))
1877 current_file
->line
++;
1883 b
= (gfc_linebuf
*) gfc_getmem (gfc_linebuf_header_size
1884 + (len
+ 1) * sizeof (gfc_char_t
));
1887 = linemap_line_start (line_table
, current_file
->line
++, 120);
1888 b
->file
= current_file
;
1889 b
->truncated
= trunc
;
1890 wide_strcpy (b
->line
, line
);
1892 if (line_head
== NULL
)
1895 line_tail
->next
= b
;
1899 while (file_changes_cur
< file_changes_count
)
1900 file_changes
[file_changes_cur
++].lb
= b
;
1903 /* Release the line buffer allocated in load_line. */
1909 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
1910 current_file
= current_file
->up
;
1911 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
1916 /* Open a new file and start scanning from that file. Returns SUCCESS
1917 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1918 it tries to determine the source form from the filename, defaulting
1926 if (gfc_cpp_enabled ())
1928 result
= gfc_cpp_preprocess (gfc_source_file
);
1929 if (!gfc_cpp_preprocess_only ())
1930 result
= load_file (gfc_cpp_temporary_file (), true);
1933 result
= load_file (gfc_source_file
, true);
1935 gfc_current_locus
.lb
= line_head
;
1936 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
1938 #if 0 /* Debugging aid. */
1939 for (; line_head
; line_head
= line_head
->next
)
1940 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
1941 LOCATION_LINE (line_head
->location
), line_head
->line
);
1950 unescape_filename (const char *ptr
)
1952 const char *p
= ptr
, *s
;
1954 int escaped
, unescape
= 0;
1956 /* Make filename end at quote. */
1958 while (*p
&& ! (! escaped
&& *p
== '"'))
1962 else if (*p
== '\\')
1973 /* Undo effects of cpp_quote_string. */
1975 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
1990 /* For preprocessed files, if the first tokens are of the form # NUM.
1991 handle the directives so we know the original file name. */
1994 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
1997 char *dirname
, *tmp
;
1999 gfc_src_file
= gfc_open_file (filename
);
2000 if (gfc_src_file
== NULL
)
2003 c
= getc (gfc_src_file
);
2009 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2011 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2014 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2015 filename
= unescape_filename (tmp
);
2017 if (filename
== NULL
)
2020 c
= getc (gfc_src_file
);
2026 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2028 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2031 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2032 dirname
= unescape_filename (tmp
);
2034 if (dirname
== NULL
)
2037 len
= strlen (dirname
);
2038 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2043 dirname
[len
- 2] = '\0';
2044 set_src_pwd (dirname
);
2046 if (! IS_ABSOLUTE_PATH (filename
))
2048 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2050 memcpy (p
, dirname
, len
- 2);
2052 strcpy (p
+ len
- 1, filename
);
2053 *canon_source_file
= p
;