2 Copyright (C) 2000-2014 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. */
53 /* List of include file search directories. */
54 gfc_directorylist
*include_dirs
, *intrinsic_modules_dirs
;
56 static gfc_file
*file_head
, *current_file
;
58 static int continue_flag
, end_flag
, openmp_flag
, gcc_attribute_flag
;
59 static int continue_count
, continue_line
;
60 static locus openmp_locus
;
61 static locus gcc_attribute_locus
;
63 gfc_source_form gfc_current_form
;
64 static gfc_linebuf
*line_head
, *line_tail
;
66 locus gfc_current_locus
;
67 const char *gfc_source_file
;
68 static FILE *gfc_src_file
;
69 static gfc_char_t
*gfc_src_preprocessor_lines
[2];
71 static struct gfc_file_change
77 size_t file_changes_cur
, file_changes_count
;
78 size_t file_changes_allocated
;
81 /* Functions dealing with our wide characters (gfc_char_t) and
82 sequences of such characters. */
85 gfc_wide_fits_in_byte (gfc_char_t c
)
87 return (c
<= UCHAR_MAX
);
91 wide_is_ascii (gfc_char_t c
)
93 return (gfc_wide_fits_in_byte (c
) && ((unsigned char) c
& ~0x7f) == 0);
97 gfc_wide_is_printable (gfc_char_t c
)
99 return (gfc_wide_fits_in_byte (c
) && ISPRINT ((unsigned char) c
));
103 gfc_wide_tolower (gfc_char_t c
)
105 return (wide_is_ascii (c
) ? (gfc_char_t
) TOLOWER((unsigned char) c
) : c
);
109 gfc_wide_toupper (gfc_char_t c
)
111 return (wide_is_ascii (c
) ? (gfc_char_t
) TOUPPER((unsigned char) c
) : c
);
115 gfc_wide_is_digit (gfc_char_t c
)
117 return (c
>= '0' && c
<= '9');
121 wide_atoi (gfc_char_t
*c
)
123 #define MAX_DIGITS 20
124 char buf
[MAX_DIGITS
+1];
127 while (gfc_wide_is_digit(*c
) && i
< MAX_DIGITS
)
134 gfc_wide_strlen (const gfc_char_t
*str
)
138 for (i
= 0; str
[i
]; i
++)
145 gfc_wide_memset (gfc_char_t
*b
, gfc_char_t c
, size_t len
)
149 for (i
= 0; i
< len
; i
++)
156 wide_strcpy (gfc_char_t
*dest
, const gfc_char_t
*src
)
160 for (d
= dest
; (*d
= *src
) != '\0'; ++src
, ++d
)
167 wide_strchr (const gfc_char_t
*s
, gfc_char_t c
)
172 return CONST_CAST(gfc_char_t
*, s
);
179 gfc_widechar_to_char (const gfc_char_t
*s
, int length
)
187 /* Passing a negative length is used to indicate that length should be
188 calculated using gfc_wide_strlen(). */
189 len
= (length
>= 0 ? (size_t) length
: gfc_wide_strlen (s
));
190 res
= XNEWVEC (char, len
+ 1);
192 for (i
= 0; i
< len
; i
++)
194 gcc_assert (gfc_wide_fits_in_byte (s
[i
]));
195 res
[i
] = (unsigned char) s
[i
];
203 gfc_char_to_widechar (const char *s
)
212 res
= gfc_get_wide_string (len
+ 1);
214 for (i
= 0; i
< len
; i
++)
215 res
[i
] = (unsigned char) s
[i
];
222 wide_strncmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
231 return (c1
> c2
? 1 : -1);
239 gfc_wide_strncasecmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
245 c1
= gfc_wide_tolower (*s1
++);
246 c2
= TOLOWER (*s2
++);
248 return (c1
> c2
? 1 : -1);
256 /* Main scanner initialization. */
259 gfc_scanner_init_1 (void)
272 /* Main scanner destructor. */
275 gfc_scanner_done_1 (void)
280 while(line_head
!= NULL
)
282 lb
= line_head
->next
;
287 while(file_head
!= NULL
)
290 free (file_head
->filename
);
297 /* Adds path to the list pointed to by list. */
300 add_path_to_list (gfc_directorylist
**list
, const char *path
,
301 bool use_for_modules
, bool head
, bool warn
)
303 gfc_directorylist
*dir
;
311 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
315 /* Strip trailing directory separators from the path, as this
316 will confuse Windows systems. */
318 q
= (char *) alloca (len
+ 1);
319 memcpy (q
, p
, len
+ 1);
321 while (i
>=0 && IS_DIR_SEPARATOR (q
[i
]))
327 gfc_warning_now ("Include directory \"%s\": %s", path
,
331 /* FIXME: Also support -Wmissing-include-dirs. */
333 gfc_warning_now ("Nonexistent include directory \"%s\"", path
);
337 else if (!S_ISDIR (st
.st_mode
))
339 gfc_warning_now ("\"%s\" is not a directory", path
);
343 if (head
|| *list
== NULL
)
345 dir
= XCNEW (gfc_directorylist
);
355 dir
->next
= XCNEW (gfc_directorylist
);
359 dir
->next
= head
? *list
: NULL
;
362 dir
->use_for_modules
= use_for_modules
;
363 dir
->path
= XCNEWVEC (char, strlen (p
) + 2);
364 strcpy (dir
->path
, p
);
365 strcat (dir
->path
, "/"); /* make '/' last character */
370 gfc_add_include_path (const char *path
, bool use_for_modules
, bool file_dir
,
373 add_path_to_list (&include_dirs
, path
, use_for_modules
, file_dir
, warn
);
375 /* For '#include "..."' these directories are automatically searched. */
377 gfc_cpp_add_include_path (xstrdup(path
), true);
382 gfc_add_intrinsic_modules_path (const char *path
)
384 add_path_to_list (&intrinsic_modules_dirs
, path
, true, false, false);
388 /* Release resources allocated for options. */
391 gfc_release_include_path (void)
393 gfc_directorylist
*p
;
395 while (include_dirs
!= NULL
)
398 include_dirs
= include_dirs
->next
;
403 while (intrinsic_modules_dirs
!= NULL
)
405 p
= intrinsic_modules_dirs
;
406 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
411 free (gfc_option
.module_dir
);
416 open_included_file (const char *name
, gfc_directorylist
*list
,
417 bool module
, bool system
)
420 gfc_directorylist
*p
;
423 for (p
= list
; p
; p
= p
->next
)
425 if (module
&& !p
->use_for_modules
)
428 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
429 strcpy (fullname
, p
->path
);
430 strcat (fullname
, name
);
432 f
= gfc_open_file (fullname
);
435 if (gfc_cpp_makedep ())
436 gfc_cpp_add_dep (fullname
, system
);
446 /* Opens file for reading, searching through the include directories
447 given if necessary. If the include_cwd argument is true, we try
448 to open the file in the current directory first. */
451 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
455 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
457 f
= gfc_open_file (name
);
458 if (f
&& gfc_cpp_makedep ())
459 gfc_cpp_add_dep (name
, false);
463 f
= open_included_file (name
, include_dirs
, module
, false);
469 /* Test to see if we're at the end of the main source file. */
478 /* Test to see if we're at the end of the current file. */
486 if (line_head
== NULL
)
487 return 1; /* Null file */
489 if (gfc_current_locus
.lb
== NULL
)
496 /* Test to see if we're at the beginning of a new line. */
504 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
508 /* Test to see if we're at the end of a line. */
516 return (*gfc_current_locus
.nextc
== '\0');
520 add_file_change (const char *filename
, int line
)
522 if (file_changes_count
== file_changes_allocated
)
524 if (file_changes_allocated
)
525 file_changes_allocated
*= 2;
527 file_changes_allocated
= 16;
528 file_changes
= XRESIZEVEC (struct gfc_file_change
, file_changes
,
529 file_changes_allocated
);
531 file_changes
[file_changes_count
].filename
= filename
;
532 file_changes
[file_changes_count
].lb
= NULL
;
533 file_changes
[file_changes_count
++].line
= line
;
537 report_file_change (gfc_linebuf
*lb
)
539 size_t c
= file_changes_cur
;
540 while (c
< file_changes_count
541 && file_changes
[c
].lb
== lb
)
543 if (file_changes
[c
].filename
)
544 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
545 file_changes
[c
].filename
);
547 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
550 file_changes_cur
= c
;
554 gfc_start_source_files (void)
556 /* If the debugger wants the name of the main source file,
558 if (debug_hooks
->start_end_main_source_file
)
559 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
561 file_changes_cur
= 0;
562 report_file_change (gfc_current_locus
.lb
);
566 gfc_end_source_files (void)
568 report_file_change (NULL
);
570 if (debug_hooks
->start_end_main_source_file
)
571 (*debug_hooks
->end_source_file
) (0);
574 /* Advance the current line pointer to the next line. */
577 gfc_advance_line (void)
582 if (gfc_current_locus
.lb
== NULL
)
588 if (gfc_current_locus
.lb
->next
589 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
591 report_file_change (gfc_current_locus
.lb
->next
);
592 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
595 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
597 if (gfc_current_locus
.lb
!= NULL
)
598 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
601 gfc_current_locus
.nextc
= NULL
;
607 /* Get the next character from the input, advancing gfc_current_file's
608 locus. When we hit the end of the line or the end of the file, we
609 start returning a '\n' in order to complete the current statement.
610 No Fortran line conventions are implemented here.
612 Requiring explicit advances to the next line prevents the parse
613 pointer from being on the wrong line if the current statement ends
621 if (gfc_current_locus
.nextc
== NULL
)
624 c
= *gfc_current_locus
.nextc
++;
627 gfc_current_locus
.nextc
--; /* Remain on this line. */
635 /* Skip a comment. When we come here the parse pointer is positioned
636 immediately after the comment character. If we ever implement
637 compiler directives within comments, here is where we parse the
641 skip_comment_line (void)
656 gfc_define_undef_line (void)
660 /* All lines beginning with '#' are either #define or #undef. */
661 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
664 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
666 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
667 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
672 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
674 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
675 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
680 /* Skip the rest of the line. */
681 skip_comment_line ();
687 /* Return true if GCC$ was matched. */
689 skip_gcc_attribute (locus start
)
693 locus old_loc
= gfc_current_locus
;
695 if ((c
= next_char ()) == 'g' || c
== 'G')
696 if ((c
= next_char ()) == 'c' || c
== 'C')
697 if ((c
= next_char ()) == 'c' || c
== 'C')
698 if ((c
= next_char ()) == '$')
702 gfc_current_locus
= old_loc
;
705 gcc_attribute_flag
= 1;
706 gcc_attribute_locus
= old_loc
;
707 gfc_current_locus
= start
;
715 /* Comment lines are null lines, lines containing only blanks or lines
716 on which the first nonblank line is a '!'.
717 Return true if !$ openmp conditional compilation sentinel was
721 skip_free_comments (void)
729 at_bol
= gfc_at_bol ();
730 start
= gfc_current_locus
;
736 while (gfc_is_whitespace (c
));
746 /* Keep the !GCC$ line. */
747 if (at_bol
&& skip_gcc_attribute (start
))
750 /* If -fopenmp, we need to handle here 2 things:
751 1) don't treat !$omp as comments, but directives
752 2) handle OpenMP conditional compilation, where
753 !$ should be treated as 2 spaces (for initial lines
754 only if followed by space). */
755 if (gfc_option
.gfc_flag_openmp
&& at_bol
)
757 locus old_loc
= gfc_current_locus
;
758 if (next_char () == '$')
761 if (c
== 'o' || c
== 'O')
763 if (((c
= next_char ()) == 'm' || c
== 'M')
764 && ((c
= next_char ()) == 'p' || c
== 'P'))
766 if ((c
= next_char ()) == ' ' || c
== '\t'
769 while (gfc_is_whitespace (c
))
771 if (c
!= '\n' && c
!= '!')
774 openmp_locus
= old_loc
;
775 gfc_current_locus
= start
;
780 gfc_warning_now ("!$OMP at %C starts a commented "
781 "line as it neither is followed "
782 "by a space nor is a "
783 "continuation line");
785 gfc_current_locus
= old_loc
;
789 if (continue_flag
|| c
== ' ' || c
== '\t')
791 gfc_current_locus
= old_loc
;
797 gfc_current_locus
= old_loc
;
799 skip_comment_line ();
806 if (openmp_flag
&& at_bol
)
809 gcc_attribute_flag
= 0;
810 gfc_current_locus
= start
;
815 /* Skip comment lines in fixed source mode. We have the same rules as
816 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
817 in column 1, and a '!' cannot be in column 6. Also, we deal with
818 lines with 'd' or 'D' in column 1, if the user requested this. */
821 skip_fixed_comments (void)
829 start
= gfc_current_locus
;
834 while (gfc_is_whitespace (c
));
839 skip_comment_line ();
844 gfc_current_locus
= start
;
851 start
= gfc_current_locus
;
862 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
864 if (skip_gcc_attribute (start
))
866 /* Canonicalize to *$omp. */
871 /* If -fopenmp, we need to handle here 2 things:
872 1) don't treat !$omp|c$omp|*$omp as comments, but directives
873 2) handle OpenMP conditional compilation, where
874 !$|c$|*$ should be treated as 2 spaces if the characters
875 in columns 3 to 6 are valid fixed form label columns
877 if (gfc_current_locus
.lb
!= NULL
878 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
879 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
881 if (gfc_option
.gfc_flag_openmp
)
883 if (next_char () == '$')
886 if (c
== 'o' || c
== 'O')
888 if (((c
= next_char ()) == 'm' || c
== 'M')
889 && ((c
= next_char ()) == 'p' || c
== 'P'))
893 && ((openmp_flag
&& continue_flag
)
894 || c
== ' ' || c
== '\t' || c
== '0'))
898 while (gfc_is_whitespace (c
));
899 if (c
!= '\n' && c
!= '!')
901 /* Canonicalize to *$omp. */
904 gfc_current_locus
= start
;
914 for (col
= 3; col
< 6; col
++, c
= next_char ())
922 else if (c
< '0' || c
> '9')
927 if (col
== 6 && c
!= '\n'
928 && ((continue_flag
&& !digit_seen
)
929 || c
== ' ' || c
== '\t' || c
== '0'))
931 gfc_current_locus
= start
;
932 start
.nextc
[0] = ' ';
933 start
.nextc
[1] = ' ';
938 gfc_current_locus
= start
;
940 skip_comment_line ();
944 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
946 if (gfc_option
.flag_d_lines
== 0)
948 skip_comment_line ();
952 *start
.nextc
= c
= ' ';
957 while (gfc_is_whitespace (c
))
969 if (col
!= 6 && c
== '!')
971 if (gfc_current_locus
.lb
!= NULL
972 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
973 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
974 skip_comment_line ();
982 gcc_attribute_flag
= 0;
983 gfc_current_locus
= start
;
987 /* Skips the current line if it is a comment. */
990 gfc_skip_comments (void)
992 if (gfc_current_form
== FORM_FREE
)
993 skip_free_comments ();
995 skip_fixed_comments ();
999 /* Get the next character from the input, taking continuation lines
1000 and end-of-line comments into account. This implies that comment
1001 lines between continued lines must be eaten here. For higher-level
1002 subroutines, this flattens continued lines into a single logical
1003 line. The in_string flag denotes whether we're inside a character
1007 gfc_next_char_literal (gfc_instring in_string
)
1010 int i
, prev_openmp_flag
;
1023 if (gfc_current_form
== FORM_FREE
)
1025 bool openmp_cond_flag
;
1027 if (!in_string
&& c
== '!')
1029 if (gcc_attribute_flag
1030 && memcmp (&gfc_current_locus
, &gcc_attribute_locus
,
1031 sizeof (gfc_current_locus
)) == 0)
1035 && memcmp (&gfc_current_locus
, &openmp_locus
,
1036 sizeof (gfc_current_locus
)) == 0)
1039 /* This line can't be continued */
1046 /* Avoid truncation warnings for comment ending lines. */
1047 gfc_current_locus
.lb
->truncated
= 0;
1052 /* Check to see if the continuation line was truncated. */
1053 if (gfc_option
.warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1054 && gfc_current_locus
.lb
->truncated
)
1056 int maxlen
= gfc_option
.free_line_length
;
1057 gfc_char_t
*current_nextc
= gfc_current_locus
.nextc
;
1059 gfc_current_locus
.lb
->truncated
= 0;
1060 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
+ maxlen
;
1061 gfc_warning_now ("Line truncated at %L", &gfc_current_locus
);
1062 gfc_current_locus
.nextc
= current_nextc
;
1068 /* If the next nonblank character is a ! or \n, we've got a
1069 continuation line. */
1070 old_loc
= gfc_current_locus
;
1073 while (gfc_is_whitespace (c
))
1076 /* Character constants to be continued cannot have commentary
1079 if (in_string
&& c
!= '\n')
1081 gfc_current_locus
= old_loc
;
1086 if (c
!= '!' && c
!= '\n')
1088 gfc_current_locus
= old_loc
;
1093 prev_openmp_flag
= openmp_flag
;
1096 skip_comment_line ();
1098 gfc_advance_line ();
1101 goto not_continuation
;
1103 /* We've got a continuation line. If we are on the very next line after
1104 the last continuation, increment the continuation line count and
1105 check whether the limit has been exceeded. */
1106 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1108 if (++continue_count
== gfc_option
.max_continue_free
)
1110 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1111 gfc_warning ("Limit of %d continuations exceeded in "
1112 "statement at %C", gfc_option
.max_continue_free
);
1116 /* Now find where it continues. First eat any comment lines. */
1117 openmp_cond_flag
= skip_free_comments ();
1119 if (gfc_current_locus
.lb
!= NULL
1120 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1121 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1123 if (prev_openmp_flag
!= openmp_flag
)
1125 gfc_current_locus
= old_loc
;
1126 openmp_flag
= prev_openmp_flag
;
1131 /* Now that we have a non-comment line, probe ahead for the
1132 first non-whitespace character. If it is another '&', then
1133 reading starts at the next character, otherwise we must back
1134 up to where the whitespace started and resume from there. */
1136 old_loc
= gfc_current_locus
;
1139 while (gfc_is_whitespace (c
))
1144 for (i
= 0; i
< 5; i
++, c
= next_char ())
1146 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1148 old_loc
= gfc_current_locus
;
1150 while (gfc_is_whitespace (c
))
1158 gfc_current_locus
.nextc
--;
1159 if (gfc_option
.warn_ampersand
&& in_string
== INSTRING_WARN
)
1160 gfc_warning ("Missing '&' in continued character "
1163 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1164 continuation line only optionally. */
1165 else if (openmp_flag
|| openmp_cond_flag
)
1166 gfc_current_locus
.nextc
--;
1170 gfc_current_locus
= old_loc
;
1175 else /* Fixed form. */
1177 /* Fixed form continuation. */
1178 if (!in_string
&& c
== '!')
1180 /* Skip comment at end of line. */
1187 /* Avoid truncation warnings for comment ending lines. */
1188 gfc_current_locus
.lb
->truncated
= 0;
1194 /* Check to see if the continuation line was truncated. */
1195 if (gfc_option
.warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1196 && gfc_current_locus
.lb
->truncated
)
1198 gfc_current_locus
.lb
->truncated
= 0;
1199 gfc_warning_now ("Line truncated at %L", &gfc_current_locus
);
1202 prev_openmp_flag
= openmp_flag
;
1204 old_loc
= gfc_current_locus
;
1206 gfc_advance_line ();
1207 skip_fixed_comments ();
1209 /* See if this line is a continuation line. */
1210 if (openmp_flag
!= prev_openmp_flag
)
1212 openmp_flag
= prev_openmp_flag
;
1213 goto not_continuation
;
1217 for (i
= 0; i
< 5; i
++)
1221 goto not_continuation
;
1224 for (i
= 0; i
< 5; i
++)
1227 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1228 goto not_continuation
;
1232 if (c
== '0' || c
== ' ' || c
== '\n')
1233 goto not_continuation
;
1235 /* We've got a continuation line. If we are on the very next line after
1236 the last continuation, increment the continuation line count and
1237 check whether the limit has been exceeded. */
1238 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1240 if (++continue_count
== gfc_option
.max_continue_fixed
)
1242 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1243 gfc_warning ("Limit of %d continuations exceeded in "
1245 gfc_option
.max_continue_fixed
);
1249 if (gfc_current_locus
.lb
!= NULL
1250 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1251 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1254 /* Ready to read first character of continuation line, which might
1255 be another continuation line! */
1260 gfc_current_locus
= old_loc
;
1270 /* Get the next character of input, folded to lowercase. In fixed
1271 form mode, we also ignore spaces. When matcher subroutines are
1272 parsing character literals, they have to call
1273 gfc_next_char_literal(). */
1276 gfc_next_char (void)
1282 c
= gfc_next_char_literal (NONSTRING
);
1284 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1286 return gfc_wide_tolower (c
);
1290 gfc_next_ascii_char (void)
1292 gfc_char_t c
= gfc_next_char ();
1294 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1295 : (unsigned char) UCHAR_MAX
);
1300 gfc_peek_char (void)
1305 old_loc
= gfc_current_locus
;
1306 c
= gfc_next_char ();
1307 gfc_current_locus
= old_loc
;
1314 gfc_peek_ascii_char (void)
1316 gfc_char_t c
= gfc_peek_char ();
1318 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1319 : (unsigned char) UCHAR_MAX
);
1323 /* Recover from an error. We try to get past the current statement
1324 and get lined up for the next. The next statement follows a '\n'
1325 or a ';'. We also assume that we are not within a character
1326 constant, and deal with finding a '\'' or '"'. */
1329 gfc_error_recovery (void)
1331 gfc_char_t c
, delim
;
1338 c
= gfc_next_char ();
1339 if (c
== '\n' || c
== ';')
1342 if (c
!= '\'' && c
!= '"')
1371 /* Read ahead until the next character to be read is not whitespace. */
1374 gfc_gobble_whitespace (void)
1376 static int linenum
= 0;
1382 old_loc
= gfc_current_locus
;
1383 c
= gfc_next_char_literal (NONSTRING
);
1384 /* Issue a warning for nonconforming tabs. We keep track of the line
1385 number because the Fortran matchers will often back up and the same
1386 line will be scanned multiple times. */
1387 if (!gfc_option
.warn_tabs
&& c
== '\t')
1389 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1390 if (cur_linenum
!= linenum
)
1392 linenum
= cur_linenum
;
1393 gfc_warning_now ("Nonconforming tab character at %C");
1397 while (gfc_is_whitespace (c
));
1399 gfc_current_locus
= old_loc
;
1403 /* Load a single line into pbuf.
1405 If pbuf points to a NULL pointer, it is allocated.
1406 We truncate lines that are too long, unless we're dealing with
1407 preprocessor lines or if the option -ffixed-line-length-none is set,
1408 in which case we reallocate the buffer to fit the entire line, if
1410 In fixed mode, we expand a tab that occurs within the statement
1411 label region to expand to spaces that leave the next character in
1414 If first_char is not NULL, it's a pointer to a single char value holding
1415 the first character of the line, which has already been read by the
1416 caller. This avoids the use of ungetc().
1418 load_line returns whether the line was truncated.
1420 NOTE: The error machinery isn't available at this point, so we can't
1421 easily report line and column numbers consistent with other
1422 parts of gfortran. */
1425 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1427 static int linenum
= 0, current_line
= 1;
1428 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1429 int trunc_flag
= 0, seen_comment
= 0;
1430 int seen_printable
= 0, seen_ampersand
= 0, quoted
= ' ';
1432 bool found_tab
= false;
1434 /* Determine the maximum allowed line length. */
1435 if (gfc_current_form
== FORM_FREE
)
1436 maxlen
= gfc_option
.free_line_length
;
1437 else if (gfc_current_form
== FORM_FIXED
)
1438 maxlen
= gfc_option
.fixed_line_length
;
1444 /* Allocate the line buffer, storing its length into buflen.
1445 Note that if maxlen==0, indicating that arbitrary-length lines
1446 are allowed, the buffer will be reallocated if this length is
1447 insufficient; since 132 characters is the length of a standard
1448 free-form line, we use that as a starting guess. */
1454 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1465 /* In order to not truncate preprocessor lines, we have to
1466 remember that this is one. */
1467 preprocessor_flag
= (c
== '#' ? 1 : 0);
1476 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1477 if (gfc_current_form
== FORM_FREE
1478 && !seen_printable
&& seen_ampersand
)
1481 gfc_error_now ("'&' not allowed by itself in line %d",
1484 gfc_warning_now ("'&' not allowed by itself in line %d",
1490 if (c
== '\r' || c
== '\0')
1491 goto next_char
; /* Gobble characters. */
1504 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1507 /* Is this a fixed-form comment? */
1508 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1509 && (c
== '*' || c
== 'c' || c
== 'd'))
1514 if (c
== '\'' || c
== '"')
1517 else if (c
== quoted
)
1520 /* Is this a free-form comment? */
1521 if (c
== '!' && quoted
== ' ')
1524 /* Vendor extension: "<tab>1" marks a continuation line. */
1528 if (c
>= '1' && c
<= '9')
1535 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1539 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1540 && current_line
!= linenum
)
1542 linenum
= current_line
;
1543 gfc_warning_now ("Nonconforming tab character in column %d "
1544 "of line %d", i
+1, linenum
);
1559 if (maxlen
== 0 || preprocessor_flag
)
1563 /* Reallocate line buffer to double size to hold the
1565 buflen
= buflen
* 2;
1566 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1567 buffer
= (*pbuf
) + i
;
1570 else if (i
>= maxlen
)
1572 bool trunc_warn
= true;
1574 /* Enhancement, if the very next non-space character is an ampersand
1575 or comment that we would otherwise warn about, don't mark as
1578 /* Truncate the rest of the line. */
1582 if (c
== '\r' || c
== ' ')
1585 if (c
== '\n' || c
== EOF
)
1588 if (!trunc_warn
&& c
!= '!')
1591 if (trunc_warn
&& ((gfc_current_form
== FORM_FIXED
&& c
== '&')
1598 if (trunc_warn
&& !seen_comment
)
1610 /* Pad lines to the selected line length in fixed form. */
1611 if (gfc_current_form
== FORM_FIXED
1612 && gfc_option
.fixed_line_length
!= 0
1613 && !preprocessor_flag
1616 while (i
++ < maxlen
)
1628 /* Get a gfc_file structure, initialize it and add it to
1632 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1636 f
= XCNEW (gfc_file
);
1638 f
->filename
= xstrdup (name
);
1640 f
->next
= file_head
;
1643 f
->up
= current_file
;
1644 if (current_file
!= NULL
)
1645 f
->inclusion_line
= current_file
->line
;
1647 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1653 /* Deal with a line from the C preprocessor. The
1654 initial octothorp has already been seen. */
1657 preprocessor_line (gfc_char_t
*c
)
1661 gfc_char_t
*wide_filename
;
1663 int escaped
, unescape
;
1667 while (*c
== ' ' || *c
== '\t')
1670 if (*c
< '0' || *c
> '9')
1673 line
= wide_atoi (c
);
1675 c
= wide_strchr (c
, ' ');
1678 /* No file name given. Set new line number. */
1679 current_file
->line
= line
;
1684 while (*c
== ' ' || *c
== '\t')
1694 /* Make filename end at quote. */
1697 while (*c
&& ! (!escaped
&& *c
== '"'))
1701 else if (*c
== '\\')
1710 /* Preprocessor line has no closing quote. */
1715 /* Undo effects of cpp_quote_string. */
1718 gfc_char_t
*s
= wide_filename
;
1719 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
1735 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1739 c
= wide_strchr (c
, ' ');
1746 if (1 <= i
&& i
<= 4)
1750 /* Convert the filename in wide characters into a filename in narrow
1752 filename
= gfc_widechar_to_char (wide_filename
, -1);
1754 /* Interpret flags. */
1756 if (flag
[1]) /* Starting new file. */
1758 f
= get_file (filename
, LC_RENAME
);
1759 add_file_change (f
->filename
, f
->inclusion_line
);
1763 if (flag
[2]) /* Ending current file. */
1765 if (!current_file
->up
1766 || filename_cmp (current_file
->up
->filename
, filename
) != 0)
1768 gfc_warning_now ("%s:%d: file %s left but not entered",
1769 current_file
->filename
, current_file
->line
,
1772 free (wide_filename
);
1777 add_file_change (NULL
, line
);
1778 current_file
= current_file
->up
;
1779 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
1780 current_file
->line
);
1783 /* The name of the file can be a temporary file produced by
1784 cpp. Replace the name if it is different. */
1786 if (filename_cmp (current_file
->filename
, filename
) != 0)
1788 /* FIXME: we leak the old filename because a pointer to it may be stored
1789 in the linemap. Alternative could be using GC or updating linemap to
1790 point to the new name, but there is no API for that currently. */
1791 current_file
->filename
= xstrdup (filename
);
1794 /* Set new line number. */
1795 current_file
->line
= line
;
1797 free (wide_filename
);
1802 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1803 current_file
->filename
, current_file
->line
);
1804 current_file
->line
++;
1808 static bool load_file (const char *, const char *, bool);
1810 /* include_line()-- Checks a line buffer to see if it is an include
1811 line. If so, we call load_file() recursively to load the included
1812 file. We never return a syntax error because a statement like
1813 "include = 5" is perfectly legal. We return false if no include was
1814 processed or true if we matched an include. */
1817 include_line (gfc_char_t
*line
)
1819 gfc_char_t quote
, *c
, *begin
, *stop
;
1824 if (gfc_option
.gfc_flag_openmp
)
1826 if (gfc_current_form
== FORM_FREE
)
1828 while (*c
== ' ' || *c
== '\t')
1830 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1835 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1836 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1841 while (*c
== ' ' || *c
== '\t')
1844 if (gfc_wide_strncasecmp (c
, "include", 7))
1848 while (*c
== ' ' || *c
== '\t')
1851 /* Find filename between quotes. */
1854 if (quote
!= '"' && quote
!= '\'')
1859 while (*c
!= quote
&& *c
!= '\0')
1867 while (*c
== ' ' || *c
== '\t')
1870 if (*c
!= '\0' && *c
!= '!')
1873 /* We have an include line at this point. */
1875 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1876 read by anything else. */
1878 filename
= gfc_widechar_to_char (begin
, -1);
1879 if (!load_file (filename
, NULL
, false))
1880 exit (FATAL_EXIT_CODE
);
1887 /* Load a file into memory by calling load_line until the file ends. */
1890 load_file (const char *realfilename
, const char *displayedname
, bool initial
)
1898 const char *filename
;
1899 /* If realfilename and displayedname are different and non-null then
1900 surely realfilename is the preprocessed form of
1902 bool preprocessed_p
= (realfilename
&& displayedname
1903 && strcmp (realfilename
, displayedname
));
1905 filename
= displayedname
? displayedname
: realfilename
;
1907 for (f
= current_file
; f
; f
= f
->up
)
1908 if (filename_cmp (filename
, f
->filename
) == 0)
1910 fprintf (stderr
, "%s:%d: Error: File '%s' is being included "
1911 "recursively\n", current_file
->filename
, current_file
->line
,
1920 input
= gfc_src_file
;
1921 gfc_src_file
= NULL
;
1924 input
= gfc_open_file (realfilename
);
1927 gfc_error_now ("Can't open file '%s'", filename
);
1933 input
= gfc_open_included_file (realfilename
, false, false);
1936 fprintf (stderr
, "%s:%d: Error: Can't open included file '%s'\n",
1937 current_file
->filename
, current_file
->line
, filename
);
1944 A "non-initial" file means a file that is being included. In
1945 that case we are creating an LC_ENTER map.
1947 An "initial" file means a main file; one that is not included.
1948 That file has already got at least one (surely more) line map(s)
1949 created by gfc_init. So the subsequent map created in that case
1950 must have LC_RENAME reason.
1952 This latter case is not true for a preprocessed file. In that
1953 case, although the file is "initial", the line maps created by
1954 gfc_init was used during the preprocessing of the file. Now that
1955 the preprocessing is over and we are being fed the result of that
1956 preprocessing, we need to create a brand new line map for the
1957 preprocessed file, so the reason is going to be LC_ENTER. */
1959 f
= get_file (filename
, (initial
&& !preprocessed_p
) ? LC_RENAME
: LC_ENTER
);
1961 add_file_change (f
->filename
, f
->inclusion_line
);
1963 current_file
->line
= 1;
1968 if (initial
&& gfc_src_preprocessor_lines
[0])
1970 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1971 free (gfc_src_preprocessor_lines
[0]);
1972 gfc_src_preprocessor_lines
[0] = NULL
;
1973 if (gfc_src_preprocessor_lines
[1])
1975 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1976 free (gfc_src_preprocessor_lines
[1]);
1977 gfc_src_preprocessor_lines
[1] = NULL
;
1983 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
1985 len
= gfc_wide_strlen (line
);
1986 if (feof (input
) && len
== 0)
1989 /* If this is the first line of the file, it can contain a byte
1990 order mark (BOM), which we will ignore:
1991 FF FE is UTF-16 little endian,
1992 FE FF is UTF-16 big endian,
1993 EF BB BF is UTF-8. */
1995 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
1996 && line
[1] == (unsigned char) '\xFE')
1997 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
1998 && line
[1] == (unsigned char) '\xFF')
1999 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
2000 && line
[1] == (unsigned char) '\xBB'
2001 && line
[2] == (unsigned char) '\xBF')))
2003 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
2004 gfc_char_t
*new_char
= gfc_get_wide_string (line_len
);
2006 wide_strcpy (new_char
, &line
[n
]);
2012 /* There are three things this line can be: a line of Fortran
2013 source, an include line or a C preprocessor directive. */
2017 /* When -g3 is specified, it's possible that we emit #define
2018 and #undef lines, which we need to pass to the middle-end
2019 so that it can emit correct debug info. */
2020 if (debug_info_level
== DINFO_LEVEL_VERBOSE
2021 && (wide_strncmp (line
, "#define ", 8) == 0
2022 || wide_strncmp (line
, "#undef ", 7) == 0))
2026 preprocessor_line (line
);
2031 /* Preprocessed files have preprocessor lines added before the byte
2032 order mark, so first_line is not about the first line of the file
2033 but the first line that's not a preprocessor line. */
2036 if (include_line (line
))
2038 current_file
->line
++;
2044 b
= XCNEWVAR (gfc_linebuf
, gfc_linebuf_header_size
2045 + (len
+ 1) * sizeof (gfc_char_t
));
2048 = linemap_line_start (line_table
, current_file
->line
++, 120);
2049 b
->file
= current_file
;
2050 b
->truncated
= trunc
;
2051 wide_strcpy (b
->line
, line
);
2053 if (line_head
== NULL
)
2056 line_tail
->next
= b
;
2060 while (file_changes_cur
< file_changes_count
)
2061 file_changes
[file_changes_cur
++].lb
= b
;
2064 /* Release the line buffer allocated in load_line. */
2070 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
2071 current_file
= current_file
->up
;
2072 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
2077 /* Open a new file and start scanning from that file. Returns true
2078 if everything went OK, false otherwise. If form == FORM_UNKNOWN
2079 it tries to determine the source form from the filename, defaulting
2087 if (gfc_cpp_enabled ())
2089 result
= gfc_cpp_preprocess (gfc_source_file
);
2090 if (!gfc_cpp_preprocess_only ())
2091 result
= load_file (gfc_cpp_temporary_file (), gfc_source_file
, true);
2094 result
= load_file (gfc_source_file
, NULL
, true);
2096 gfc_current_locus
.lb
= line_head
;
2097 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
2099 #if 0 /* Debugging aid. */
2100 for (; line_head
; line_head
= line_head
->next
)
2101 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
2102 LOCATION_LINE (line_head
->location
), line_head
->line
);
2104 exit (SUCCESS_EXIT_CODE
);
2111 unescape_filename (const char *ptr
)
2113 const char *p
= ptr
, *s
;
2115 int escaped
, unescape
= 0;
2117 /* Make filename end at quote. */
2119 while (*p
&& ! (! escaped
&& *p
== '"'))
2123 else if (*p
== '\\')
2134 /* Undo effects of cpp_quote_string. */
2136 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
2151 /* For preprocessed files, if the first tokens are of the form # NUM.
2152 handle the directives so we know the original file name. */
2155 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
2158 char *dirname
, *tmp
;
2160 gfc_src_file
= gfc_open_file (filename
);
2161 if (gfc_src_file
== NULL
)
2164 c
= getc (gfc_src_file
);
2170 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2172 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2175 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2176 filename
= unescape_filename (tmp
);
2178 if (filename
== NULL
)
2181 c
= getc (gfc_src_file
);
2187 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2189 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2192 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2193 dirname
= unescape_filename (tmp
);
2195 if (dirname
== NULL
)
2198 len
= strlen (dirname
);
2199 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2204 dirname
[len
- 2] = '\0';
2205 set_src_pwd (dirname
);
2207 if (! IS_ABSOLUTE_PATH (filename
))
2209 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2211 memcpy (p
, dirname
, len
- 2);
2213 strcpy (p
+ len
- 1, filename
);
2214 *canon_source_file
= p
;