2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* Set of subroutines to (ultimately) return the next character to the
22 various matching subroutines. This file's job is to read files and
23 build up lines that are parsed by the parser. This means that we
24 handle continuation lines and "include" lines.
26 The first thing the scanner does is to load an entire file into
27 memory. We load the entire file into memory for a couple reasons.
28 The first is that we want to be able to deal with nonseekable input
29 (pipes, stdin) and there is a lot of backing up involved during
32 The second is that we want to be able to print the locus of errors,
33 and an error on line 999999 could conflict with something on line
34 one. Given nonseekable input, we've got to store the whole thing.
36 One thing that helps are the column truncation limits that give us
37 an upper bound on the size of individual lines. We don't store the
40 From the scanner's viewpoint, the higher level subroutines ask for
41 new characters and do a lot of jumping backwards. */
45 #include "coretypes.h"
47 #include "toplev.h" /* For set_src_pwd. */
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
, gcc_attribute_flag
;
67 static int continue_count
, continue_line
;
68 static locus openmp_locus
;
69 static locus gcc_attribute_locus
;
71 gfc_source_form gfc_current_form
;
72 static gfc_linebuf
*line_head
, *line_tail
;
74 locus gfc_current_locus
;
75 const char *gfc_source_file
;
76 static FILE *gfc_src_file
;
77 static gfc_char_t
*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
;
89 /* Functions dealing with our wide characters (gfc_char_t) and
90 sequences of such characters. */
93 gfc_wide_fits_in_byte (gfc_char_t c
)
95 return (c
<= UCHAR_MAX
);
99 wide_is_ascii (gfc_char_t c
)
101 return (gfc_wide_fits_in_byte (c
) && ((unsigned char) c
& ~0x7f) == 0);
105 gfc_wide_is_printable (gfc_char_t c
)
107 return (gfc_wide_fits_in_byte (c
) && ISPRINT ((unsigned char) c
));
111 gfc_wide_tolower (gfc_char_t c
)
113 return (wide_is_ascii (c
) ? (gfc_char_t
) TOLOWER((unsigned char) c
) : c
);
117 gfc_wide_toupper (gfc_char_t c
)
119 return (wide_is_ascii (c
) ? (gfc_char_t
) TOUPPER((unsigned char) c
) : c
);
123 gfc_wide_is_digit (gfc_char_t c
)
125 return (c
>= '0' && c
<= '9');
129 wide_atoi (gfc_char_t
*c
)
131 #define MAX_DIGITS 20
132 char buf
[MAX_DIGITS
+1];
135 while (gfc_wide_is_digit(*c
) && i
< MAX_DIGITS
)
142 gfc_wide_strlen (const gfc_char_t
*str
)
146 for (i
= 0; str
[i
]; i
++)
153 gfc_wide_memset (gfc_char_t
*b
, gfc_char_t c
, size_t len
)
157 for (i
= 0; i
< len
; i
++)
164 wide_strcpy (gfc_char_t
*dest
, const gfc_char_t
*src
)
168 for (d
= dest
; (*d
= *src
) != '\0'; ++src
, ++d
)
175 wide_strchr (const gfc_char_t
*s
, gfc_char_t c
)
180 return CONST_CAST(gfc_char_t
*, s
);
187 gfc_widechar_to_char (const gfc_char_t
*s
, int length
)
195 /* Passing a negative length is used to indicate that length should be
196 calculated using gfc_wide_strlen(). */
197 len
= (length
>= 0 ? (size_t) length
: gfc_wide_strlen (s
));
198 res
= XNEWVEC (char, len
+ 1);
200 for (i
= 0; i
< len
; i
++)
202 gcc_assert (gfc_wide_fits_in_byte (s
[i
]));
203 res
[i
] = (unsigned char) s
[i
];
211 gfc_char_to_widechar (const char *s
)
220 res
= gfc_get_wide_string (len
+ 1);
222 for (i
= 0; i
< len
; i
++)
223 res
[i
] = (unsigned char) s
[i
];
230 wide_strncmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
239 return (c1
> c2
? 1 : -1);
247 gfc_wide_strncasecmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
253 c1
= gfc_wide_tolower (*s1
++);
254 c2
= TOLOWER (*s2
++);
256 return (c1
> c2
? 1 : -1);
264 /* Main scanner initialization. */
267 gfc_scanner_init_1 (void)
280 /* Main scanner destructor. */
283 gfc_scanner_done_1 (void)
288 while(line_head
!= NULL
)
290 lb
= line_head
->next
;
295 while(file_head
!= NULL
)
298 free (file_head
->filename
);
305 /* Adds path to the list pointed to by list. */
308 add_path_to_list (gfc_directorylist
**list
, const char *path
,
309 bool use_for_modules
, bool head
, bool warn
)
311 gfc_directorylist
*dir
;
319 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
323 /* Strip trailing directory separators from the path, as this
324 will confuse Windows systems. */
326 q
= (char *) alloca (len
+ 1);
327 memcpy (q
, p
, len
+ 1);
329 while (i
>=0 && IS_DIR_SEPARATOR(q
[i
]))
335 gfc_warning_now ("Include directory \"%s\": %s", path
,
339 /* FIXME: Also support -Wmissing-include-dirs. */
341 gfc_warning_now ("Nonexistent include directory \"%s\"", path
);
345 else if (!S_ISDIR (st
.st_mode
))
347 gfc_warning_now ("\"%s\" is not a directory", path
);
351 if (head
|| *list
== NULL
)
353 dir
= XCNEW (gfc_directorylist
);
363 dir
->next
= XCNEW (gfc_directorylist
);
367 dir
->next
= head
? *list
: NULL
;
370 dir
->use_for_modules
= use_for_modules
;
371 dir
->path
= XCNEWVEC (char, strlen (p
) + 2);
372 strcpy (dir
->path
, p
);
373 strcat (dir
->path
, "/"); /* make '/' last character */
378 gfc_add_include_path (const char *path
, bool use_for_modules
, bool file_dir
)
380 add_path_to_list (&include_dirs
, path
, use_for_modules
, file_dir
, true);
382 /* For '#include "..."' these directories are automatically searched. */
384 gfc_cpp_add_include_path (xstrdup(path
), true);
389 gfc_add_intrinsic_modules_path (const char *path
)
391 add_path_to_list (&intrinsic_modules_dirs
, path
, true, false, false);
395 /* Release resources allocated for options. */
398 gfc_release_include_path (void)
400 gfc_directorylist
*p
;
402 while (include_dirs
!= NULL
)
405 include_dirs
= include_dirs
->next
;
410 while (intrinsic_modules_dirs
!= NULL
)
412 p
= intrinsic_modules_dirs
;
413 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
418 free (gfc_option
.module_dir
);
423 open_included_file (const char *name
, gfc_directorylist
*list
,
424 bool module
, bool system
)
427 gfc_directorylist
*p
;
430 for (p
= list
; p
; p
= p
->next
)
432 if (module
&& !p
->use_for_modules
)
435 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
436 strcpy (fullname
, p
->path
);
437 strcat (fullname
, name
);
439 f
= gfc_open_file (fullname
);
442 if (gfc_cpp_makedep ())
443 gfc_cpp_add_dep (fullname
, system
);
453 /* Opens file for reading, searching through the include directories
454 given if necessary. If the include_cwd argument is true, we try
455 to open the file in the current directory first. */
458 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
462 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
464 f
= gfc_open_file (name
);
465 if (f
&& gfc_cpp_makedep ())
466 gfc_cpp_add_dep (name
, false);
470 f
= open_included_file (name
, include_dirs
, module
, false);
476 gfc_open_intrinsic_module (const char *name
)
480 if (IS_ABSOLUTE_PATH (name
))
482 f
= gfc_open_file (name
);
483 if (f
&& gfc_cpp_makedep ())
484 gfc_cpp_add_dep (name
, true);
488 f
= open_included_file (name
, intrinsic_modules_dirs
, true, true);
494 /* Test to see if we're at the end of the main source file. */
503 /* Test to see if we're at the end of the current file. */
511 if (line_head
== NULL
)
512 return 1; /* Null file */
514 if (gfc_current_locus
.lb
== NULL
)
521 /* Test to see if we're at the beginning of a new line. */
529 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
533 /* Test to see if we're at the end of a line. */
541 return (*gfc_current_locus
.nextc
== '\0');
545 add_file_change (const char *filename
, int line
)
547 if (file_changes_count
== file_changes_allocated
)
549 if (file_changes_allocated
)
550 file_changes_allocated
*= 2;
552 file_changes_allocated
= 16;
553 file_changes
= XRESIZEVEC (struct gfc_file_change
, file_changes
,
554 file_changes_allocated
);
556 file_changes
[file_changes_count
].filename
= filename
;
557 file_changes
[file_changes_count
].lb
= NULL
;
558 file_changes
[file_changes_count
++].line
= line
;
562 report_file_change (gfc_linebuf
*lb
)
564 size_t c
= file_changes_cur
;
565 while (c
< file_changes_count
566 && file_changes
[c
].lb
== lb
)
568 if (file_changes
[c
].filename
)
569 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
570 file_changes
[c
].filename
);
572 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
575 file_changes_cur
= c
;
579 gfc_start_source_files (void)
581 /* If the debugger wants the name of the main source file,
583 if (debug_hooks
->start_end_main_source_file
)
584 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
586 file_changes_cur
= 0;
587 report_file_change (gfc_current_locus
.lb
);
591 gfc_end_source_files (void)
593 report_file_change (NULL
);
595 if (debug_hooks
->start_end_main_source_file
)
596 (*debug_hooks
->end_source_file
) (0);
599 /* Advance the current line pointer to the next line. */
602 gfc_advance_line (void)
607 if (gfc_current_locus
.lb
== NULL
)
613 if (gfc_current_locus
.lb
->next
614 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
616 report_file_change (gfc_current_locus
.lb
->next
);
617 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
620 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
622 if (gfc_current_locus
.lb
!= NULL
)
623 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
626 gfc_current_locus
.nextc
= NULL
;
632 /* Get the next character from the input, advancing gfc_current_file's
633 locus. When we hit the end of the line or the end of the file, we
634 start returning a '\n' in order to complete the current statement.
635 No Fortran line conventions are implemented here.
637 Requiring explicit advances to the next line prevents the parse
638 pointer from being on the wrong line if the current statement ends
646 if (gfc_current_locus
.nextc
== NULL
)
649 c
= *gfc_current_locus
.nextc
++;
652 gfc_current_locus
.nextc
--; /* Remain on this line. */
660 /* Skip a comment. When we come here the parse pointer is positioned
661 immediately after the comment character. If we ever implement
662 compiler directives within comments, here is where we parse the
666 skip_comment_line (void)
681 gfc_define_undef_line (void)
685 /* All lines beginning with '#' are either #define or #undef. */
686 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
689 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
691 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
692 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
697 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
699 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
700 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
705 /* Skip the rest of the line. */
706 skip_comment_line ();
712 /* Return true if GCC$ was matched. */
714 skip_gcc_attribute (locus start
)
718 locus old_loc
= gfc_current_locus
;
720 if ((c
= next_char ()) == 'g' || c
== 'G')
721 if ((c
= next_char ()) == 'c' || c
== 'C')
722 if ((c
= next_char ()) == 'c' || c
== 'C')
723 if ((c
= next_char ()) == '$')
727 gfc_current_locus
= old_loc
;
730 gcc_attribute_flag
= 1;
731 gcc_attribute_locus
= old_loc
;
732 gfc_current_locus
= start
;
740 /* Comment lines are null lines, lines containing only blanks or lines
741 on which the first nonblank line is a '!'.
742 Return true if !$ openmp conditional compilation sentinel was
746 skip_free_comments (void)
754 at_bol
= gfc_at_bol ();
755 start
= gfc_current_locus
;
761 while (gfc_is_whitespace (c
));
771 /* Keep the !GCC$ line. */
772 if (at_bol
&& skip_gcc_attribute (start
))
775 /* If -fopenmp, we need to handle here 2 things:
776 1) don't treat !$omp as comments, but directives
777 2) handle OpenMP conditional compilation, where
778 !$ should be treated as 2 spaces (for initial lines
779 only if followed by space). */
780 if (gfc_option
.gfc_flag_openmp
&& at_bol
)
782 locus old_loc
= gfc_current_locus
;
783 if (next_char () == '$')
786 if (c
== 'o' || c
== 'O')
788 if (((c
= next_char ()) == 'm' || c
== 'M')
789 && ((c
= next_char ()) == 'p' || c
== 'P'))
791 if ((c
= next_char ()) == ' ' || c
== '\t'
794 while (gfc_is_whitespace (c
))
796 if (c
!= '\n' && c
!= '!')
799 openmp_locus
= old_loc
;
800 gfc_current_locus
= start
;
805 gfc_warning_now ("!$OMP at %C starts a commented "
806 "line as it neither is followed "
807 "by a space nor is a "
808 "continuation line");
810 gfc_current_locus
= old_loc
;
814 if (continue_flag
|| c
== ' ' || c
== '\t')
816 gfc_current_locus
= old_loc
;
822 gfc_current_locus
= old_loc
;
824 skip_comment_line ();
831 if (openmp_flag
&& at_bol
)
834 gcc_attribute_flag
= 0;
835 gfc_current_locus
= start
;
840 /* Skip comment lines in fixed source mode. We have the same rules as
841 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
842 in column 1, and a '!' cannot be in column 6. Also, we deal with
843 lines with 'd' or 'D' in column 1, if the user requested this. */
846 skip_fixed_comments (void)
854 start
= gfc_current_locus
;
859 while (gfc_is_whitespace (c
));
864 skip_comment_line ();
869 gfc_current_locus
= start
;
876 start
= gfc_current_locus
;
887 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
889 if (skip_gcc_attribute (start
))
891 /* Canonicalize to *$omp. */
896 /* If -fopenmp, we need to handle here 2 things:
897 1) don't treat !$omp|c$omp|*$omp as comments, but directives
898 2) handle OpenMP conditional compilation, where
899 !$|c$|*$ should be treated as 2 spaces if the characters
900 in columns 3 to 6 are valid fixed form label columns
902 if (gfc_current_locus
.lb
!= NULL
903 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
904 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
906 if (gfc_option
.gfc_flag_openmp
)
908 if (next_char () == '$')
911 if (c
== 'o' || c
== 'O')
913 if (((c
= next_char ()) == 'm' || c
== 'M')
914 && ((c
= next_char ()) == 'p' || c
== 'P'))
918 && ((openmp_flag
&& continue_flag
)
919 || c
== ' ' || c
== '\t' || c
== '0'))
923 while (gfc_is_whitespace (c
));
924 if (c
!= '\n' && c
!= '!')
926 /* Canonicalize to *$omp. */
929 gfc_current_locus
= start
;
939 for (col
= 3; col
< 6; col
++, c
= next_char ())
947 else if (c
< '0' || c
> '9')
952 if (col
== 6 && c
!= '\n'
953 && ((continue_flag
&& !digit_seen
)
954 || c
== ' ' || c
== '\t' || c
== '0'))
956 gfc_current_locus
= start
;
957 start
.nextc
[0] = ' ';
958 start
.nextc
[1] = ' ';
963 gfc_current_locus
= start
;
965 skip_comment_line ();
969 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
971 if (gfc_option
.flag_d_lines
== 0)
973 skip_comment_line ();
977 *start
.nextc
= c
= ' ';
982 while (gfc_is_whitespace (c
))
994 if (col
!= 6 && c
== '!')
996 if (gfc_current_locus
.lb
!= NULL
997 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
998 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
999 skip_comment_line ();
1007 gcc_attribute_flag
= 0;
1008 gfc_current_locus
= start
;
1012 /* Skips the current line if it is a comment. */
1015 gfc_skip_comments (void)
1017 if (gfc_current_form
== FORM_FREE
)
1018 skip_free_comments ();
1020 skip_fixed_comments ();
1024 /* Get the next character from the input, taking continuation lines
1025 and end-of-line comments into account. This implies that comment
1026 lines between continued lines must be eaten here. For higher-level
1027 subroutines, this flattens continued lines into a single logical
1028 line. The in_string flag denotes whether we're inside a character
1032 gfc_next_char_literal (gfc_instring in_string
)
1035 int i
, prev_openmp_flag
;
1048 if (gfc_current_form
== FORM_FREE
)
1050 bool openmp_cond_flag
;
1052 if (!in_string
&& c
== '!')
1054 if (gcc_attribute_flag
1055 && memcmp (&gfc_current_locus
, &gcc_attribute_locus
,
1056 sizeof (gfc_current_locus
)) == 0)
1060 && memcmp (&gfc_current_locus
, &openmp_locus
,
1061 sizeof (gfc_current_locus
)) == 0)
1064 /* This line can't be continued */
1071 /* Avoid truncation warnings for comment ending lines. */
1072 gfc_current_locus
.lb
->truncated
= 0;
1077 /* Check to see if the continuation line was truncated. */
1078 if (gfc_option
.warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1079 && gfc_current_locus
.lb
->truncated
)
1081 int maxlen
= gfc_option
.free_line_length
;
1082 gfc_char_t
*current_nextc
= gfc_current_locus
.nextc
;
1084 gfc_current_locus
.lb
->truncated
= 0;
1085 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
+ maxlen
;
1086 gfc_warning_now ("Line truncated at %L", &gfc_current_locus
);
1087 gfc_current_locus
.nextc
= current_nextc
;
1093 /* If the next nonblank character is a ! or \n, we've got a
1094 continuation line. */
1095 old_loc
= gfc_current_locus
;
1098 while (gfc_is_whitespace (c
))
1101 /* Character constants to be continued cannot have commentary
1104 if (in_string
&& c
!= '\n')
1106 gfc_current_locus
= old_loc
;
1111 if (c
!= '!' && c
!= '\n')
1113 gfc_current_locus
= old_loc
;
1118 prev_openmp_flag
= openmp_flag
;
1121 skip_comment_line ();
1123 gfc_advance_line ();
1126 goto not_continuation
;
1128 /* We've got a continuation line. If we are on the very next line after
1129 the last continuation, increment the continuation line count and
1130 check whether the limit has been exceeded. */
1131 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1133 if (++continue_count
== gfc_option
.max_continue_free
)
1135 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1136 gfc_warning ("Limit of %d continuations exceeded in "
1137 "statement at %C", gfc_option
.max_continue_free
);
1141 /* Now find where it continues. First eat any comment lines. */
1142 openmp_cond_flag
= skip_free_comments ();
1144 if (gfc_current_locus
.lb
!= NULL
1145 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1146 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1148 if (prev_openmp_flag
!= openmp_flag
)
1150 gfc_current_locus
= old_loc
;
1151 openmp_flag
= prev_openmp_flag
;
1156 /* Now that we have a non-comment line, probe ahead for the
1157 first non-whitespace character. If it is another '&', then
1158 reading starts at the next character, otherwise we must back
1159 up to where the whitespace started and resume from there. */
1161 old_loc
= gfc_current_locus
;
1164 while (gfc_is_whitespace (c
))
1169 for (i
= 0; i
< 5; i
++, c
= next_char ())
1171 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1173 old_loc
= gfc_current_locus
;
1175 while (gfc_is_whitespace (c
))
1183 gfc_current_locus
.nextc
--;
1184 if (gfc_option
.warn_ampersand
&& in_string
== INSTRING_WARN
)
1185 gfc_warning ("Missing '&' in continued character "
1188 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1189 continuation line only optionally. */
1190 else if (openmp_flag
|| openmp_cond_flag
)
1191 gfc_current_locus
.nextc
--;
1195 gfc_current_locus
= old_loc
;
1200 else /* Fixed form. */
1202 /* Fixed form continuation. */
1203 if (!in_string
&& c
== '!')
1205 /* Skip comment at end of line. */
1212 /* Avoid truncation warnings for comment ending lines. */
1213 gfc_current_locus
.lb
->truncated
= 0;
1219 /* Check to see if the continuation line was truncated. */
1220 if (gfc_option
.warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1221 && gfc_current_locus
.lb
->truncated
)
1223 gfc_current_locus
.lb
->truncated
= 0;
1224 gfc_warning_now ("Line truncated at %L", &gfc_current_locus
);
1227 prev_openmp_flag
= openmp_flag
;
1229 old_loc
= gfc_current_locus
;
1231 gfc_advance_line ();
1232 skip_fixed_comments ();
1234 /* See if this line is a continuation line. */
1235 if (openmp_flag
!= prev_openmp_flag
)
1237 openmp_flag
= prev_openmp_flag
;
1238 goto not_continuation
;
1242 for (i
= 0; i
< 5; i
++)
1246 goto not_continuation
;
1249 for (i
= 0; i
< 5; i
++)
1252 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1253 goto not_continuation
;
1257 if (c
== '0' || c
== ' ' || c
== '\n')
1258 goto not_continuation
;
1260 /* We've got a continuation line. If we are on the very next line after
1261 the last continuation, increment the continuation line count and
1262 check whether the limit has been exceeded. */
1263 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1265 if (++continue_count
== gfc_option
.max_continue_fixed
)
1267 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1268 gfc_warning ("Limit of %d continuations exceeded in "
1270 gfc_option
.max_continue_fixed
);
1274 if (gfc_current_locus
.lb
!= NULL
1275 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1276 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1279 /* Ready to read first character of continuation line, which might
1280 be another continuation line! */
1285 gfc_current_locus
= old_loc
;
1295 /* Get the next character of input, folded to lowercase. In fixed
1296 form mode, we also ignore spaces. When matcher subroutines are
1297 parsing character literals, they have to call
1298 gfc_next_char_literal(). */
1301 gfc_next_char (void)
1307 c
= gfc_next_char_literal (NONSTRING
);
1309 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1311 return gfc_wide_tolower (c
);
1315 gfc_next_ascii_char (void)
1317 gfc_char_t c
= gfc_next_char ();
1319 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1320 : (unsigned char) UCHAR_MAX
);
1325 gfc_peek_char (void)
1330 old_loc
= gfc_current_locus
;
1331 c
= gfc_next_char ();
1332 gfc_current_locus
= old_loc
;
1339 gfc_peek_ascii_char (void)
1341 gfc_char_t c
= gfc_peek_char ();
1343 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1344 : (unsigned char) UCHAR_MAX
);
1348 /* Recover from an error. We try to get past the current statement
1349 and get lined up for the next. The next statement follows a '\n'
1350 or a ';'. We also assume that we are not within a character
1351 constant, and deal with finding a '\'' or '"'. */
1354 gfc_error_recovery (void)
1356 gfc_char_t c
, delim
;
1363 c
= gfc_next_char ();
1364 if (c
== '\n' || c
== ';')
1367 if (c
!= '\'' && c
!= '"')
1396 /* Read ahead until the next character to be read is not whitespace. */
1399 gfc_gobble_whitespace (void)
1401 static int linenum
= 0;
1407 old_loc
= gfc_current_locus
;
1408 c
= gfc_next_char_literal (NONSTRING
);
1409 /* Issue a warning for nonconforming tabs. We keep track of the line
1410 number because the Fortran matchers will often back up and the same
1411 line will be scanned multiple times. */
1412 if (!gfc_option
.warn_tabs
&& c
== '\t')
1414 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1415 if (cur_linenum
!= linenum
)
1417 linenum
= cur_linenum
;
1418 gfc_warning_now ("Nonconforming tab character at %C");
1422 while (gfc_is_whitespace (c
));
1424 gfc_current_locus
= old_loc
;
1428 /* Load a single line into pbuf.
1430 If pbuf points to a NULL pointer, it is allocated.
1431 We truncate lines that are too long, unless we're dealing with
1432 preprocessor lines or if the option -ffixed-line-length-none is set,
1433 in which case we reallocate the buffer to fit the entire line, if
1435 In fixed mode, we expand a tab that occurs within the statement
1436 label region to expand to spaces that leave the next character in
1439 If first_char is not NULL, it's a pointer to a single char value holding
1440 the first character of the line, which has already been read by the
1441 caller. This avoids the use of ungetc().
1443 load_line returns whether the line was truncated.
1445 NOTE: The error machinery isn't available at this point, so we can't
1446 easily report line and column numbers consistent with other
1447 parts of gfortran. */
1450 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1452 static int linenum
= 0, current_line
= 1;
1453 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1454 int trunc_flag
= 0, seen_comment
= 0;
1455 int seen_printable
= 0, seen_ampersand
= 0, quoted
= ' ';
1457 bool found_tab
= false;
1459 /* Determine the maximum allowed line length. */
1460 if (gfc_current_form
== FORM_FREE
)
1461 maxlen
= gfc_option
.free_line_length
;
1462 else if (gfc_current_form
== FORM_FIXED
)
1463 maxlen
= gfc_option
.fixed_line_length
;
1469 /* Allocate the line buffer, storing its length into buflen.
1470 Note that if maxlen==0, indicating that arbitrary-length lines
1471 are allowed, the buffer will be reallocated if this length is
1472 insufficient; since 132 characters is the length of a standard
1473 free-form line, we use that as a starting guess. */
1479 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1490 /* In order to not truncate preprocessor lines, we have to
1491 remember that this is one. */
1492 preprocessor_flag
= (c
== '#' ? 1 : 0);
1501 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1502 if (gfc_current_form
== FORM_FREE
1503 && !seen_printable
&& seen_ampersand
)
1506 gfc_error_now ("'&' not allowed by itself in line %d",
1509 gfc_warning_now ("'&' not allowed by itself in line %d",
1515 if (c
== '\r' || c
== '\0')
1516 goto next_char
; /* Gobble characters. */
1529 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1532 /* Is this a fixed-form comment? */
1533 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1534 && (c
== '*' || c
== 'c' || c
== 'd'))
1539 if (c
== '\'' || c
== '"')
1542 else if (c
== quoted
)
1545 /* Is this a free-form comment? */
1546 if (c
== '!' && quoted
== ' ')
1549 /* Vendor extension: "<tab>1" marks a continuation line. */
1553 if (c
>= '1' && c
<= '9')
1560 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1564 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1565 && current_line
!= linenum
)
1567 linenum
= current_line
;
1568 gfc_warning_now ("Nonconforming tab character in column %d "
1569 "of line %d", i
+1, linenum
);
1584 if (maxlen
== 0 || preprocessor_flag
)
1588 /* Reallocate line buffer to double size to hold the
1590 buflen
= buflen
* 2;
1591 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1592 buffer
= (*pbuf
) + i
;
1595 else if (i
>= maxlen
)
1597 bool trunc_warn
= true;
1599 /* Enhancement, if the very next non-space character is an ampersand
1600 or comment that we would otherwise warn about, don't mark as
1603 /* Truncate the rest of the line. */
1607 if (c
== '\r' || c
== ' ')
1610 if (c
== '\n' || c
== EOF
)
1613 if (!trunc_warn
&& c
!= '!')
1616 if (trunc_warn
&& ((gfc_current_form
== FORM_FIXED
&& c
== '&')
1623 if (trunc_warn
&& !seen_comment
)
1635 /* Pad lines to the selected line length in fixed form. */
1636 if (gfc_current_form
== FORM_FIXED
1637 && gfc_option
.fixed_line_length
!= 0
1638 && !preprocessor_flag
1641 while (i
++ < maxlen
)
1653 /* Get a gfc_file structure, initialize it and add it to
1657 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1661 f
= XCNEW (gfc_file
);
1663 f
->filename
= xstrdup (name
);
1665 f
->next
= file_head
;
1668 f
->up
= current_file
;
1669 if (current_file
!= NULL
)
1670 f
->inclusion_line
= current_file
->line
;
1672 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1678 /* Deal with a line from the C preprocessor. The
1679 initial octothorp has already been seen. */
1682 preprocessor_line (gfc_char_t
*c
)
1686 gfc_char_t
*wide_filename
;
1688 int escaped
, unescape
;
1692 while (*c
== ' ' || *c
== '\t')
1695 if (*c
< '0' || *c
> '9')
1698 line
= wide_atoi (c
);
1700 c
= wide_strchr (c
, ' ');
1703 /* No file name given. Set new line number. */
1704 current_file
->line
= line
;
1709 while (*c
== ' ' || *c
== '\t')
1719 /* Make filename end at quote. */
1722 while (*c
&& ! (!escaped
&& *c
== '"'))
1726 else if (*c
== '\\')
1735 /* Preprocessor line has no closing quote. */
1740 /* Undo effects of cpp_quote_string. */
1743 gfc_char_t
*s
= wide_filename
;
1744 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
1760 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1764 c
= wide_strchr (c
, ' ');
1771 if (1 <= i
&& i
<= 4)
1775 /* Convert the filename in wide characters into a filename in narrow
1777 filename
= gfc_widechar_to_char (wide_filename
, -1);
1779 /* Interpret flags. */
1781 if (flag
[1]) /* Starting new file. */
1783 f
= get_file (filename
, LC_RENAME
);
1784 add_file_change (f
->filename
, f
->inclusion_line
);
1788 if (flag
[2]) /* Ending current file. */
1790 if (!current_file
->up
1791 || filename_cmp (current_file
->up
->filename
, filename
) != 0)
1793 gfc_warning_now ("%s:%d: file %s left but not entered",
1794 current_file
->filename
, current_file
->line
,
1797 free (wide_filename
);
1802 add_file_change (NULL
, line
);
1803 current_file
= current_file
->up
;
1804 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
1805 current_file
->line
);
1808 /* The name of the file can be a temporary file produced by
1809 cpp. Replace the name if it is different. */
1811 if (filename_cmp (current_file
->filename
, filename
) != 0)
1813 /* FIXME: we leak the old filename because a pointer to it may be stored
1814 in the linemap. Alternative could be using GC or updating linemap to
1815 point to the new name, but there is no API for that currently. */
1816 current_file
->filename
= xstrdup (filename
);
1819 /* Set new line number. */
1820 current_file
->line
= line
;
1822 free (wide_filename
);
1827 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1828 current_file
->filename
, current_file
->line
);
1829 current_file
->line
++;
1833 static gfc_try
load_file (const char *, const char *, bool);
1835 /* include_line()-- Checks a line buffer to see if it is an include
1836 line. If so, we call load_file() recursively to load the included
1837 file. We never return a syntax error because a statement like
1838 "include = 5" is perfectly legal. We return false if no include was
1839 processed or true if we matched an include. */
1842 include_line (gfc_char_t
*line
)
1844 gfc_char_t quote
, *c
, *begin
, *stop
;
1849 if (gfc_option
.gfc_flag_openmp
)
1851 if (gfc_current_form
== FORM_FREE
)
1853 while (*c
== ' ' || *c
== '\t')
1855 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1860 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1861 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1866 while (*c
== ' ' || *c
== '\t')
1869 if (gfc_wide_strncasecmp (c
, "include", 7))
1873 while (*c
== ' ' || *c
== '\t')
1876 /* Find filename between quotes. */
1879 if (quote
!= '"' && quote
!= '\'')
1884 while (*c
!= quote
&& *c
!= '\0')
1892 while (*c
== ' ' || *c
== '\t')
1895 if (*c
!= '\0' && *c
!= '!')
1898 /* We have an include line at this point. */
1900 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1901 read by anything else. */
1903 filename
= gfc_widechar_to_char (begin
, -1);
1904 if (load_file (filename
, NULL
, false) == FAILURE
)
1905 exit (FATAL_EXIT_CODE
);
1912 /* Load a file into memory by calling load_line until the file ends. */
1915 load_file (const char *realfilename
, const char *displayedname
, bool initial
)
1923 const char *filename
;
1924 /* If realfilename and displayedname are different and non-null then
1925 surely realfilename is the preprocessed form of
1927 bool preprocessed_p
= (realfilename
&& displayedname
1928 && strcmp (realfilename
, displayedname
));
1930 filename
= displayedname
? displayedname
: realfilename
;
1932 for (f
= current_file
; f
; f
= f
->up
)
1933 if (filename_cmp (filename
, f
->filename
) == 0)
1935 fprintf (stderr
, "%s:%d: Error: File '%s' is being included "
1936 "recursively\n", current_file
->filename
, current_file
->line
,
1945 input
= gfc_src_file
;
1946 gfc_src_file
= NULL
;
1949 input
= gfc_open_file (realfilename
);
1952 gfc_error_now ("Can't open file '%s'", filename
);
1958 input
= gfc_open_included_file (realfilename
, false, false);
1961 fprintf (stderr
, "%s:%d: Error: Can't open included file '%s'\n",
1962 current_file
->filename
, current_file
->line
, filename
);
1969 A "non-initial" file means a file that is being included. In
1970 that case we are creating an LC_ENTER map.
1972 An "initial" file means a main file; one that is not included.
1973 That file has already got at least one (surely more) line map(s)
1974 created by gfc_init. So the subsequent map created in that case
1975 must have LC_RENAME reason.
1977 This latter case is not true for a preprocessed file. In that
1978 case, although the file is "initial", the line maps created by
1979 gfc_init was used during the preprocessing of the file. Now that
1980 the preprocessing is over and we are being fed the result of that
1981 preprocessing, we need to create a brand new line map for the
1982 preprocessed file, so the reason is going to be LC_ENTER. */
1984 f
= get_file (filename
, (initial
&& !preprocessed_p
) ? LC_RENAME
: LC_ENTER
);
1986 add_file_change (f
->filename
, f
->inclusion_line
);
1988 current_file
->line
= 1;
1993 if (initial
&& gfc_src_preprocessor_lines
[0])
1995 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1996 free (gfc_src_preprocessor_lines
[0]);
1997 gfc_src_preprocessor_lines
[0] = NULL
;
1998 if (gfc_src_preprocessor_lines
[1])
2000 preprocessor_line (gfc_src_preprocessor_lines
[1]);
2001 free (gfc_src_preprocessor_lines
[1]);
2002 gfc_src_preprocessor_lines
[1] = NULL
;
2008 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
2010 len
= gfc_wide_strlen (line
);
2011 if (feof (input
) && len
== 0)
2014 /* If this is the first line of the file, it can contain a byte
2015 order mark (BOM), which we will ignore:
2016 FF FE is UTF-16 little endian,
2017 FE FF is UTF-16 big endian,
2018 EF BB BF is UTF-8. */
2020 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
2021 && line
[1] == (unsigned char) '\xFE')
2022 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
2023 && line
[1] == (unsigned char) '\xFF')
2024 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
2025 && line
[1] == (unsigned char) '\xBB'
2026 && line
[2] == (unsigned char) '\xBF')))
2028 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
2029 gfc_char_t
*new_char
= gfc_get_wide_string (line_len
);
2031 wide_strcpy (new_char
, &line
[n
]);
2037 /* There are three things this line can be: a line of Fortran
2038 source, an include line or a C preprocessor directive. */
2042 /* When -g3 is specified, it's possible that we emit #define
2043 and #undef lines, which we need to pass to the middle-end
2044 so that it can emit correct debug info. */
2045 if (debug_info_level
== DINFO_LEVEL_VERBOSE
2046 && (wide_strncmp (line
, "#define ", 8) == 0
2047 || wide_strncmp (line
, "#undef ", 7) == 0))
2051 preprocessor_line (line
);
2056 /* Preprocessed files have preprocessor lines added before the byte
2057 order mark, so first_line is not about the first line of the file
2058 but the first line that's not a preprocessor line. */
2061 if (include_line (line
))
2063 current_file
->line
++;
2069 b
= XCNEWVAR (gfc_linebuf
, gfc_linebuf_header_size
2070 + (len
+ 1) * sizeof (gfc_char_t
));
2073 = linemap_line_start (line_table
, current_file
->line
++, 120);
2074 b
->file
= current_file
;
2075 b
->truncated
= trunc
;
2076 wide_strcpy (b
->line
, line
);
2078 if (line_head
== NULL
)
2081 line_tail
->next
= b
;
2085 while (file_changes_cur
< file_changes_count
)
2086 file_changes
[file_changes_cur
++].lb
= b
;
2089 /* Release the line buffer allocated in load_line. */
2095 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
2096 current_file
= current_file
->up
;
2097 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
2102 /* Open a new file and start scanning from that file. Returns SUCCESS
2103 if everything went OK, FAILURE otherwise. If form == FORM_UNKNOWN
2104 it tries to determine the source form from the filename, defaulting
2112 if (gfc_cpp_enabled ())
2114 result
= gfc_cpp_preprocess (gfc_source_file
);
2115 if (!gfc_cpp_preprocess_only ())
2116 result
= load_file (gfc_cpp_temporary_file (), gfc_source_file
, true);
2119 result
= load_file (gfc_source_file
, NULL
, true);
2121 gfc_current_locus
.lb
= line_head
;
2122 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
2124 #if 0 /* Debugging aid. */
2125 for (; line_head
; line_head
= line_head
->next
)
2126 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
2127 LOCATION_LINE (line_head
->location
), line_head
->line
);
2129 exit (SUCCESS_EXIT_CODE
);
2136 unescape_filename (const char *ptr
)
2138 const char *p
= ptr
, *s
;
2140 int escaped
, unescape
= 0;
2142 /* Make filename end at quote. */
2144 while (*p
&& ! (! escaped
&& *p
== '"'))
2148 else if (*p
== '\\')
2159 /* Undo effects of cpp_quote_string. */
2161 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
2176 /* For preprocessed files, if the first tokens are of the form # NUM.
2177 handle the directives so we know the original file name. */
2180 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
2183 char *dirname
, *tmp
;
2185 gfc_src_file
= gfc_open_file (filename
);
2186 if (gfc_src_file
== NULL
)
2189 c
= getc (gfc_src_file
);
2195 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2197 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2200 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2201 filename
= unescape_filename (tmp
);
2203 if (filename
== NULL
)
2206 c
= getc (gfc_src_file
);
2212 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2214 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2217 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2218 dirname
= unescape_filename (tmp
);
2220 if (dirname
== NULL
)
2223 len
= strlen (dirname
);
2224 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2229 dirname
[len
- 2] = '\0';
2230 set_src_pwd (dirname
);
2232 if (! IS_ABSOLUTE_PATH (filename
))
2234 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2236 memcpy (p
, dirname
, len
- 2);
2238 strcpy (p
+ len
- 1, filename
);
2239 *canon_source_file
= p
;