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 %qs: %s", path
,
330 gfc_warning_now (OPT_Wmissing_include_dirs
,
331 "Nonexistent include directory %qs", path
);
334 else if (!S_ISDIR (st
.st_mode
))
336 gfc_warning_now ("%qs is not a directory", path
);
340 if (head
|| *list
== NULL
)
342 dir
= XCNEW (gfc_directorylist
);
352 dir
->next
= XCNEW (gfc_directorylist
);
356 dir
->next
= head
? *list
: NULL
;
359 dir
->use_for_modules
= use_for_modules
;
360 dir
->path
= XCNEWVEC (char, strlen (p
) + 2);
361 strcpy (dir
->path
, p
);
362 strcat (dir
->path
, "/"); /* make '/' last character */
367 gfc_add_include_path (const char *path
, bool use_for_modules
, bool file_dir
,
370 add_path_to_list (&include_dirs
, path
, use_for_modules
, file_dir
, warn
);
372 /* For '#include "..."' these directories are automatically searched. */
374 gfc_cpp_add_include_path (xstrdup(path
), true);
379 gfc_add_intrinsic_modules_path (const char *path
)
381 add_path_to_list (&intrinsic_modules_dirs
, path
, true, false, false);
385 /* Release resources allocated for options. */
388 gfc_release_include_path (void)
390 gfc_directorylist
*p
;
392 while (include_dirs
!= NULL
)
395 include_dirs
= include_dirs
->next
;
400 while (intrinsic_modules_dirs
!= NULL
)
402 p
= intrinsic_modules_dirs
;
403 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
408 free (gfc_option
.module_dir
);
413 open_included_file (const char *name
, gfc_directorylist
*list
,
414 bool module
, bool system
)
417 gfc_directorylist
*p
;
420 for (p
= list
; p
; p
= p
->next
)
422 if (module
&& !p
->use_for_modules
)
425 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
426 strcpy (fullname
, p
->path
);
427 strcat (fullname
, name
);
429 f
= gfc_open_file (fullname
);
432 if (gfc_cpp_makedep ())
433 gfc_cpp_add_dep (fullname
, system
);
443 /* Opens file for reading, searching through the include directories
444 given if necessary. If the include_cwd argument is true, we try
445 to open the file in the current directory first. */
448 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
452 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
454 f
= gfc_open_file (name
);
455 if (f
&& gfc_cpp_makedep ())
456 gfc_cpp_add_dep (name
, false);
460 f
= open_included_file (name
, include_dirs
, module
, false);
466 /* Test to see if we're at the end of the main source file. */
475 /* Test to see if we're at the end of the current file. */
483 if (line_head
== NULL
)
484 return 1; /* Null file */
486 if (gfc_current_locus
.lb
== NULL
)
493 /* Test to see if we're at the beginning of a new line. */
501 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
505 /* Test to see if we're at the end of a line. */
513 return (*gfc_current_locus
.nextc
== '\0');
517 add_file_change (const char *filename
, int line
)
519 if (file_changes_count
== file_changes_allocated
)
521 if (file_changes_allocated
)
522 file_changes_allocated
*= 2;
524 file_changes_allocated
= 16;
525 file_changes
= XRESIZEVEC (struct gfc_file_change
, file_changes
,
526 file_changes_allocated
);
528 file_changes
[file_changes_count
].filename
= filename
;
529 file_changes
[file_changes_count
].lb
= NULL
;
530 file_changes
[file_changes_count
++].line
= line
;
534 report_file_change (gfc_linebuf
*lb
)
536 size_t c
= file_changes_cur
;
537 while (c
< file_changes_count
538 && file_changes
[c
].lb
== lb
)
540 if (file_changes
[c
].filename
)
541 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
542 file_changes
[c
].filename
);
544 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
547 file_changes_cur
= c
;
551 gfc_start_source_files (void)
553 /* If the debugger wants the name of the main source file,
555 if (debug_hooks
->start_end_main_source_file
)
556 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
558 file_changes_cur
= 0;
559 report_file_change (gfc_current_locus
.lb
);
563 gfc_end_source_files (void)
565 report_file_change (NULL
);
567 if (debug_hooks
->start_end_main_source_file
)
568 (*debug_hooks
->end_source_file
) (0);
571 /* Advance the current line pointer to the next line. */
574 gfc_advance_line (void)
579 if (gfc_current_locus
.lb
== NULL
)
585 if (gfc_current_locus
.lb
->next
586 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
588 report_file_change (gfc_current_locus
.lb
->next
);
589 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
592 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
594 if (gfc_current_locus
.lb
!= NULL
)
595 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
598 gfc_current_locus
.nextc
= NULL
;
604 /* Get the next character from the input, advancing gfc_current_file's
605 locus. When we hit the end of the line or the end of the file, we
606 start returning a '\n' in order to complete the current statement.
607 No Fortran line conventions are implemented here.
609 Requiring explicit advances to the next line prevents the parse
610 pointer from being on the wrong line if the current statement ends
618 if (gfc_current_locus
.nextc
== NULL
)
621 c
= *gfc_current_locus
.nextc
++;
624 gfc_current_locus
.nextc
--; /* Remain on this line. */
632 /* Skip a comment. When we come here the parse pointer is positioned
633 immediately after the comment character. If we ever implement
634 compiler directives within comments, here is where we parse the
638 skip_comment_line (void)
653 gfc_define_undef_line (void)
657 /* All lines beginning with '#' are either #define or #undef. */
658 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
661 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
663 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
664 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
669 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
671 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
672 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
677 /* Skip the rest of the line. */
678 skip_comment_line ();
684 /* Return true if GCC$ was matched. */
686 skip_gcc_attribute (locus start
)
690 locus old_loc
= gfc_current_locus
;
692 if ((c
= next_char ()) == 'g' || c
== 'G')
693 if ((c
= next_char ()) == 'c' || c
== 'C')
694 if ((c
= next_char ()) == 'c' || c
== 'C')
695 if ((c
= next_char ()) == '$')
699 gfc_current_locus
= old_loc
;
702 gcc_attribute_flag
= 1;
703 gcc_attribute_locus
= old_loc
;
704 gfc_current_locus
= start
;
712 /* Comment lines are null lines, lines containing only blanks or lines
713 on which the first nonblank line is a '!'.
714 Return true if !$ openmp conditional compilation sentinel was
718 skip_free_comments (void)
726 at_bol
= gfc_at_bol ();
727 start
= gfc_current_locus
;
733 while (gfc_is_whitespace (c
));
743 /* Keep the !GCC$ line. */
744 if (at_bol
&& skip_gcc_attribute (start
))
747 /* If -fopenmp, we need to handle here 2 things:
748 1) don't treat !$omp as comments, but directives
749 2) handle OpenMP conditional compilation, where
750 !$ should be treated as 2 spaces (for initial lines
751 only if followed by space). */
752 if ((gfc_option
.gfc_flag_openmp
753 || gfc_option
.gfc_flag_openmp_simd
) && at_bol
)
755 locus old_loc
= gfc_current_locus
;
756 if (next_char () == '$')
759 if (c
== 'o' || c
== 'O')
761 if (((c
= next_char ()) == 'm' || c
== 'M')
762 && ((c
= next_char ()) == 'p' || c
== 'P'))
764 if ((c
= next_char ()) == ' ' || c
== '\t'
767 while (gfc_is_whitespace (c
))
769 if (c
!= '\n' && c
!= '!')
772 openmp_locus
= old_loc
;
773 gfc_current_locus
= start
;
778 gfc_warning_now ("!$OMP at %C starts a commented "
779 "line as it neither is followed "
780 "by a space nor is a "
781 "continuation line");
783 gfc_current_locus
= old_loc
;
787 if (continue_flag
|| c
== ' ' || c
== '\t')
789 gfc_current_locus
= old_loc
;
795 gfc_current_locus
= old_loc
;
797 skip_comment_line ();
804 if (openmp_flag
&& at_bol
)
807 gcc_attribute_flag
= 0;
808 gfc_current_locus
= start
;
813 /* Skip comment lines in fixed source mode. We have the same rules as
814 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
815 in column 1, and a '!' cannot be in column 6. Also, we deal with
816 lines with 'd' or 'D' in column 1, if the user requested this. */
819 skip_fixed_comments (void)
827 start
= gfc_current_locus
;
832 while (gfc_is_whitespace (c
));
837 skip_comment_line ();
842 gfc_current_locus
= start
;
849 start
= gfc_current_locus
;
860 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
862 if (skip_gcc_attribute (start
))
864 /* Canonicalize to *$omp. */
869 /* If -fopenmp, we need to handle here 2 things:
870 1) don't treat !$omp|c$omp|*$omp as comments, but directives
871 2) handle OpenMP conditional compilation, where
872 !$|c$|*$ should be treated as 2 spaces if the characters
873 in columns 3 to 6 are valid fixed form label columns
875 if (gfc_current_locus
.lb
!= NULL
876 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
877 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
879 if (gfc_option
.gfc_flag_openmp
|| gfc_option
.gfc_flag_openmp_simd
)
881 if (next_char () == '$')
884 if (c
== 'o' || c
== 'O')
886 if (((c
= next_char ()) == 'm' || c
== 'M')
887 && ((c
= next_char ()) == 'p' || c
== 'P'))
891 && ((openmp_flag
&& continue_flag
)
892 || c
== ' ' || c
== '\t' || c
== '0'))
896 while (gfc_is_whitespace (c
));
897 if (c
!= '\n' && c
!= '!')
899 /* Canonicalize to *$omp. */
902 gfc_current_locus
= start
;
912 for (col
= 3; col
< 6; col
++, c
= next_char ())
920 else if (c
< '0' || c
> '9')
925 if (col
== 6 && c
!= '\n'
926 && ((continue_flag
&& !digit_seen
)
927 || c
== ' ' || c
== '\t' || c
== '0'))
929 gfc_current_locus
= start
;
930 start
.nextc
[0] = ' ';
931 start
.nextc
[1] = ' ';
936 gfc_current_locus
= start
;
938 skip_comment_line ();
942 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
944 if (gfc_option
.flag_d_lines
== 0)
946 skip_comment_line ();
950 *start
.nextc
= c
= ' ';
955 while (gfc_is_whitespace (c
))
967 if (col
!= 6 && c
== '!')
969 if (gfc_current_locus
.lb
!= NULL
970 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
971 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
972 skip_comment_line ();
980 gcc_attribute_flag
= 0;
981 gfc_current_locus
= start
;
985 /* Skips the current line if it is a comment. */
988 gfc_skip_comments (void)
990 if (gfc_current_form
== FORM_FREE
)
991 skip_free_comments ();
993 skip_fixed_comments ();
997 /* Get the next character from the input, taking continuation lines
998 and end-of-line comments into account. This implies that comment
999 lines between continued lines must be eaten here. For higher-level
1000 subroutines, this flattens continued lines into a single logical
1001 line. The in_string flag denotes whether we're inside a character
1005 gfc_next_char_literal (gfc_instring in_string
)
1008 int i
, prev_openmp_flag
;
1021 if (gfc_current_form
== FORM_FREE
)
1023 bool openmp_cond_flag
;
1025 if (!in_string
&& c
== '!')
1027 if (gcc_attribute_flag
1028 && memcmp (&gfc_current_locus
, &gcc_attribute_locus
,
1029 sizeof (gfc_current_locus
)) == 0)
1033 && memcmp (&gfc_current_locus
, &openmp_locus
,
1034 sizeof (gfc_current_locus
)) == 0)
1037 /* This line can't be continued */
1044 /* Avoid truncation warnings for comment ending lines. */
1045 gfc_current_locus
.lb
->truncated
= 0;
1050 /* Check to see if the continuation line was truncated. */
1051 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1052 && gfc_current_locus
.lb
->truncated
)
1054 int maxlen
= gfc_option
.free_line_length
;
1055 gfc_char_t
*current_nextc
= gfc_current_locus
.nextc
;
1057 gfc_current_locus
.lb
->truncated
= 0;
1058 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
+ maxlen
;
1059 gfc_warning_now_1 ("Line truncated at %L", &gfc_current_locus
);
1060 gfc_current_locus
.nextc
= current_nextc
;
1066 /* If the next nonblank character is a ! or \n, we've got a
1067 continuation line. */
1068 old_loc
= gfc_current_locus
;
1071 while (gfc_is_whitespace (c
))
1074 /* Character constants to be continued cannot have commentary
1077 if (in_string
&& c
!= '\n')
1079 gfc_current_locus
= old_loc
;
1084 if (c
!= '!' && c
!= '\n')
1086 gfc_current_locus
= old_loc
;
1091 prev_openmp_flag
= openmp_flag
;
1094 skip_comment_line ();
1096 gfc_advance_line ();
1099 goto not_continuation
;
1101 /* We've got a continuation line. If we are on the very next line after
1102 the last continuation, increment the continuation line count and
1103 check whether the limit has been exceeded. */
1104 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1106 if (++continue_count
== gfc_option
.max_continue_free
)
1108 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1109 gfc_warning ("Limit of %d continuations exceeded in "
1110 "statement at %C", gfc_option
.max_continue_free
);
1114 /* Now find where it continues. First eat any comment lines. */
1115 openmp_cond_flag
= skip_free_comments ();
1117 if (gfc_current_locus
.lb
!= NULL
1118 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1119 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1121 if (prev_openmp_flag
!= openmp_flag
)
1123 gfc_current_locus
= old_loc
;
1124 openmp_flag
= prev_openmp_flag
;
1129 /* Now that we have a non-comment line, probe ahead for the
1130 first non-whitespace character. If it is another '&', then
1131 reading starts at the next character, otherwise we must back
1132 up to where the whitespace started and resume from there. */
1134 old_loc
= gfc_current_locus
;
1137 while (gfc_is_whitespace (c
))
1142 for (i
= 0; i
< 5; i
++, c
= next_char ())
1144 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1146 old_loc
= gfc_current_locus
;
1148 while (gfc_is_whitespace (c
))
1156 gfc_current_locus
.nextc
--;
1157 if (warn_ampersand
&& in_string
== INSTRING_WARN
)
1158 gfc_warning (OPT_Wampersand
,
1159 "Missing %<&%> in continued character "
1162 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1163 continuation line only optionally. */
1164 else if (openmp_flag
|| openmp_cond_flag
)
1165 gfc_current_locus
.nextc
--;
1169 gfc_current_locus
= old_loc
;
1174 else /* Fixed form. */
1176 /* Fixed form continuation. */
1177 if (!in_string
&& c
== '!')
1179 /* Skip comment at end of line. */
1186 /* Avoid truncation warnings for comment ending lines. */
1187 gfc_current_locus
.lb
->truncated
= 0;
1193 /* Check to see if the continuation line was truncated. */
1194 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1195 && gfc_current_locus
.lb
->truncated
)
1197 gfc_current_locus
.lb
->truncated
= 0;
1198 gfc_warning_now_1 ("Line truncated at %L", &gfc_current_locus
);
1201 prev_openmp_flag
= openmp_flag
;
1203 old_loc
= gfc_current_locus
;
1205 gfc_advance_line ();
1206 skip_fixed_comments ();
1208 /* See if this line is a continuation line. */
1209 if (openmp_flag
!= prev_openmp_flag
)
1211 openmp_flag
= prev_openmp_flag
;
1212 goto not_continuation
;
1216 for (i
= 0; i
< 5; i
++)
1220 goto not_continuation
;
1223 for (i
= 0; i
< 5; i
++)
1226 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1227 goto not_continuation
;
1231 if (c
== '0' || c
== ' ' || c
== '\n')
1232 goto not_continuation
;
1234 /* We've got a continuation line. If we are on the very next line after
1235 the last continuation, increment the continuation line count and
1236 check whether the limit has been exceeded. */
1237 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1239 if (++continue_count
== gfc_option
.max_continue_fixed
)
1241 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1242 gfc_warning ("Limit of %d continuations exceeded in "
1244 gfc_option
.max_continue_fixed
);
1248 if (gfc_current_locus
.lb
!= NULL
1249 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1250 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1253 /* Ready to read first character of continuation line, which might
1254 be another continuation line! */
1259 gfc_current_locus
= old_loc
;
1269 /* Get the next character of input, folded to lowercase. In fixed
1270 form mode, we also ignore spaces. When matcher subroutines are
1271 parsing character literals, they have to call
1272 gfc_next_char_literal(). */
1275 gfc_next_char (void)
1281 c
= gfc_next_char_literal (NONSTRING
);
1283 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1285 return gfc_wide_tolower (c
);
1289 gfc_next_ascii_char (void)
1291 gfc_char_t c
= gfc_next_char ();
1293 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1294 : (unsigned char) UCHAR_MAX
);
1299 gfc_peek_char (void)
1304 old_loc
= gfc_current_locus
;
1305 c
= gfc_next_char ();
1306 gfc_current_locus
= old_loc
;
1313 gfc_peek_ascii_char (void)
1315 gfc_char_t c
= gfc_peek_char ();
1317 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1318 : (unsigned char) UCHAR_MAX
);
1322 /* Recover from an error. We try to get past the current statement
1323 and get lined up for the next. The next statement follows a '\n'
1324 or a ';'. We also assume that we are not within a character
1325 constant, and deal with finding a '\'' or '"'. */
1328 gfc_error_recovery (void)
1330 gfc_char_t c
, delim
;
1337 c
= gfc_next_char ();
1338 if (c
== '\n' || c
== ';')
1341 if (c
!= '\'' && c
!= '"')
1370 /* Read ahead until the next character to be read is not whitespace. */
1373 gfc_gobble_whitespace (void)
1375 static int linenum
= 0;
1381 old_loc
= gfc_current_locus
;
1382 c
= gfc_next_char_literal (NONSTRING
);
1383 /* Issue a warning for nonconforming tabs. We keep track of the line
1384 number because the Fortran matchers will often back up and the same
1385 line will be scanned multiple times. */
1386 if (warn_tabs
&& c
== '\t')
1388 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1389 if (cur_linenum
!= linenum
)
1391 linenum
= cur_linenum
;
1392 gfc_warning_now (OPT_Wtabs
, "Nonconforming tab character at %C");
1396 while (gfc_is_whitespace (c
));
1398 gfc_current_locus
= old_loc
;
1402 /* Load a single line into pbuf.
1404 If pbuf points to a NULL pointer, it is allocated.
1405 We truncate lines that are too long, unless we're dealing with
1406 preprocessor lines or if the option -ffixed-line-length-none is set,
1407 in which case we reallocate the buffer to fit the entire line, if
1409 In fixed mode, we expand a tab that occurs within the statement
1410 label region to expand to spaces that leave the next character in
1413 If first_char is not NULL, it's a pointer to a single char value holding
1414 the first character of the line, which has already been read by the
1415 caller. This avoids the use of ungetc().
1417 load_line returns whether the line was truncated.
1419 NOTE: The error machinery isn't available at this point, so we can't
1420 easily report line and column numbers consistent with other
1421 parts of gfortran. */
1424 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1426 static int linenum
= 0, current_line
= 1;
1427 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1428 int trunc_flag
= 0, seen_comment
= 0;
1429 int seen_printable
= 0, seen_ampersand
= 0, quoted
= ' ';
1431 bool found_tab
= false;
1433 /* Determine the maximum allowed line length. */
1434 if (gfc_current_form
== FORM_FREE
)
1435 maxlen
= gfc_option
.free_line_length
;
1436 else if (gfc_current_form
== FORM_FIXED
)
1437 maxlen
= gfc_option
.fixed_line_length
;
1443 /* Allocate the line buffer, storing its length into buflen.
1444 Note that if maxlen==0, indicating that arbitrary-length lines
1445 are allowed, the buffer will be reallocated if this length is
1446 insufficient; since 132 characters is the length of a standard
1447 free-form line, we use that as a starting guess. */
1453 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1464 /* In order to not truncate preprocessor lines, we have to
1465 remember that this is one. */
1466 preprocessor_flag
= (c
== '#' ? 1 : 0);
1475 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1476 if (gfc_current_form
== FORM_FREE
1477 && !seen_printable
&& seen_ampersand
)
1480 gfc_error_now ("%<&%> not allowed by itself in line %d",
1483 gfc_warning_now ("%<&%> not allowed by itself in line %d",
1489 if (c
== '\r' || c
== '\0')
1490 goto next_char
; /* Gobble characters. */
1503 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1506 /* Is this a fixed-form comment? */
1507 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1508 && (c
== '*' || c
== 'c' || c
== 'd'))
1513 if (c
== '\'' || c
== '"')
1516 else if (c
== quoted
)
1519 /* Is this a free-form comment? */
1520 if (c
== '!' && quoted
== ' ')
1523 /* Vendor extension: "<tab>1" marks a continuation line. */
1527 if (c
>= '1' && c
<= '9')
1534 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1538 if (warn_tabs
&& seen_comment
== 0 && current_line
!= linenum
)
1540 linenum
= current_line
;
1541 gfc_warning_now (OPT_Wtabs
,
1542 "Nonconforming tab character in column %d "
1543 "of line %d", i
+1, linenum
);
1558 if (maxlen
== 0 || preprocessor_flag
)
1562 /* Reallocate line buffer to double size to hold the
1564 buflen
= buflen
* 2;
1565 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1566 buffer
= (*pbuf
) + i
;
1569 else if (i
>= maxlen
)
1571 bool trunc_warn
= true;
1573 /* Enhancement, if the very next non-space character is an ampersand
1574 or comment that we would otherwise warn about, don't mark as
1577 /* Truncate the rest of the line. */
1581 if (c
== '\r' || c
== ' ')
1584 if (c
== '\n' || c
== EOF
)
1587 if (!trunc_warn
&& c
!= '!')
1590 if (trunc_warn
&& ((gfc_current_form
== FORM_FIXED
&& c
== '&')
1597 if (trunc_warn
&& !seen_comment
)
1609 /* Pad lines to the selected line length in fixed form. */
1610 if (gfc_current_form
== FORM_FIXED
1611 && gfc_option
.fixed_line_length
!= 0
1612 && !preprocessor_flag
1615 while (i
++ < maxlen
)
1627 /* Get a gfc_file structure, initialize it and add it to
1631 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1635 f
= XCNEW (gfc_file
);
1637 f
->filename
= xstrdup (name
);
1639 f
->next
= file_head
;
1642 f
->up
= current_file
;
1643 if (current_file
!= NULL
)
1644 f
->inclusion_line
= current_file
->line
;
1646 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1652 /* Deal with a line from the C preprocessor. The
1653 initial octothorp has already been seen. */
1656 preprocessor_line (gfc_char_t
*c
)
1660 gfc_char_t
*wide_filename
;
1662 int escaped
, unescape
;
1666 while (*c
== ' ' || *c
== '\t')
1669 if (*c
< '0' || *c
> '9')
1672 line
= wide_atoi (c
);
1674 c
= wide_strchr (c
, ' ');
1677 /* No file name given. Set new line number. */
1678 current_file
->line
= line
;
1683 while (*c
== ' ' || *c
== '\t')
1693 /* Make filename end at quote. */
1696 while (*c
&& ! (!escaped
&& *c
== '"'))
1700 else if (*c
== '\\')
1709 /* Preprocessor line has no closing quote. */
1714 /* Undo effects of cpp_quote_string. */
1717 gfc_char_t
*s
= wide_filename
;
1718 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
1734 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1738 c
= wide_strchr (c
, ' ');
1745 if (1 <= i
&& i
<= 4)
1749 /* Convert the filename in wide characters into a filename in narrow
1751 filename
= gfc_widechar_to_char (wide_filename
, -1);
1753 /* Interpret flags. */
1755 if (flag
[1]) /* Starting new file. */
1757 f
= get_file (filename
, LC_RENAME
);
1758 add_file_change (f
->filename
, f
->inclusion_line
);
1762 if (flag
[2]) /* Ending current file. */
1764 if (!current_file
->up
1765 || filename_cmp (current_file
->up
->filename
, filename
) != 0)
1767 gfc_warning_now_1 ("%s:%d: file %s left but not entered",
1768 current_file
->filename
, current_file
->line
,
1771 free (wide_filename
);
1776 add_file_change (NULL
, line
);
1777 current_file
= current_file
->up
;
1778 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
1779 current_file
->line
);
1782 /* The name of the file can be a temporary file produced by
1783 cpp. Replace the name if it is different. */
1785 if (filename_cmp (current_file
->filename
, filename
) != 0)
1787 /* FIXME: we leak the old filename because a pointer to it may be stored
1788 in the linemap. Alternative could be using GC or updating linemap to
1789 point to the new name, but there is no API for that currently. */
1790 current_file
->filename
= xstrdup (filename
);
1793 /* Set new line number. */
1794 current_file
->line
= line
;
1796 free (wide_filename
);
1801 gfc_warning_now_1 ("%s:%d: Illegal preprocessor directive",
1802 current_file
->filename
, current_file
->line
);
1803 current_file
->line
++;
1807 static bool load_file (const char *, const char *, bool);
1809 /* include_line()-- Checks a line buffer to see if it is an include
1810 line. If so, we call load_file() recursively to load the included
1811 file. We never return a syntax error because a statement like
1812 "include = 5" is perfectly legal. We return false if no include was
1813 processed or true if we matched an include. */
1816 include_line (gfc_char_t
*line
)
1818 gfc_char_t quote
, *c
, *begin
, *stop
;
1823 if (gfc_option
.gfc_flag_openmp
|| gfc_option
.gfc_flag_openmp_simd
)
1825 if (gfc_current_form
== FORM_FREE
)
1827 while (*c
== ' ' || *c
== '\t')
1829 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1834 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1835 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1840 while (*c
== ' ' || *c
== '\t')
1843 if (gfc_wide_strncasecmp (c
, "include", 7))
1847 while (*c
== ' ' || *c
== '\t')
1850 /* Find filename between quotes. */
1853 if (quote
!= '"' && quote
!= '\'')
1858 while (*c
!= quote
&& *c
!= '\0')
1866 while (*c
== ' ' || *c
== '\t')
1869 if (*c
!= '\0' && *c
!= '!')
1872 /* We have an include line at this point. */
1874 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1875 read by anything else. */
1877 filename
= gfc_widechar_to_char (begin
, -1);
1878 if (!load_file (filename
, NULL
, false))
1879 exit (FATAL_EXIT_CODE
);
1886 /* Load a file into memory by calling load_line until the file ends. */
1889 load_file (const char *realfilename
, const char *displayedname
, bool initial
)
1897 const char *filename
;
1898 /* If realfilename and displayedname are different and non-null then
1899 surely realfilename is the preprocessed form of
1901 bool preprocessed_p
= (realfilename
&& displayedname
1902 && strcmp (realfilename
, displayedname
));
1904 filename
= displayedname
? displayedname
: realfilename
;
1906 for (f
= current_file
; f
; f
= f
->up
)
1907 if (filename_cmp (filename
, f
->filename
) == 0)
1909 fprintf (stderr
, "%s:%d: Error: File '%s' is being included "
1910 "recursively\n", current_file
->filename
, current_file
->line
,
1919 input
= gfc_src_file
;
1920 gfc_src_file
= NULL
;
1923 input
= gfc_open_file (realfilename
);
1926 gfc_error_now ("Can't open file %qs", filename
);
1932 input
= gfc_open_included_file (realfilename
, false, false);
1935 fprintf (stderr
, "%s:%d: Error: Can't open included file '%s'\n",
1936 current_file
->filename
, current_file
->line
, filename
);
1943 A "non-initial" file means a file that is being included. In
1944 that case we are creating an LC_ENTER map.
1946 An "initial" file means a main file; one that is not included.
1947 That file has already got at least one (surely more) line map(s)
1948 created by gfc_init. So the subsequent map created in that case
1949 must have LC_RENAME reason.
1951 This latter case is not true for a preprocessed file. In that
1952 case, although the file is "initial", the line maps created by
1953 gfc_init was used during the preprocessing of the file. Now that
1954 the preprocessing is over and we are being fed the result of that
1955 preprocessing, we need to create a brand new line map for the
1956 preprocessed file, so the reason is going to be LC_ENTER. */
1958 f
= get_file (filename
, (initial
&& !preprocessed_p
) ? LC_RENAME
: LC_ENTER
);
1960 add_file_change (f
->filename
, f
->inclusion_line
);
1962 current_file
->line
= 1;
1967 if (initial
&& gfc_src_preprocessor_lines
[0])
1969 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1970 free (gfc_src_preprocessor_lines
[0]);
1971 gfc_src_preprocessor_lines
[0] = NULL
;
1972 if (gfc_src_preprocessor_lines
[1])
1974 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1975 free (gfc_src_preprocessor_lines
[1]);
1976 gfc_src_preprocessor_lines
[1] = NULL
;
1982 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
1984 len
= gfc_wide_strlen (line
);
1985 if (feof (input
) && len
== 0)
1988 /* If this is the first line of the file, it can contain a byte
1989 order mark (BOM), which we will ignore:
1990 FF FE is UTF-16 little endian,
1991 FE FF is UTF-16 big endian,
1992 EF BB BF is UTF-8. */
1994 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
1995 && line
[1] == (unsigned char) '\xFE')
1996 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
1997 && line
[1] == (unsigned char) '\xFF')
1998 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
1999 && line
[1] == (unsigned char) '\xBB'
2000 && line
[2] == (unsigned char) '\xBF')))
2002 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
2003 gfc_char_t
*new_char
= gfc_get_wide_string (line_len
);
2005 wide_strcpy (new_char
, &line
[n
]);
2011 /* There are three things this line can be: a line of Fortran
2012 source, an include line or a C preprocessor directive. */
2016 /* When -g3 is specified, it's possible that we emit #define
2017 and #undef lines, which we need to pass to the middle-end
2018 so that it can emit correct debug info. */
2019 if (debug_info_level
== DINFO_LEVEL_VERBOSE
2020 && (wide_strncmp (line
, "#define ", 8) == 0
2021 || wide_strncmp (line
, "#undef ", 7) == 0))
2025 preprocessor_line (line
);
2030 /* Preprocessed files have preprocessor lines added before the byte
2031 order mark, so first_line is not about the first line of the file
2032 but the first line that's not a preprocessor line. */
2035 if (include_line (line
))
2037 current_file
->line
++;
2043 b
= XCNEWVAR (gfc_linebuf
, gfc_linebuf_header_size
2044 + (len
+ 1) * sizeof (gfc_char_t
));
2047 = linemap_line_start (line_table
, current_file
->line
++, 120);
2048 b
->file
= current_file
;
2049 b
->truncated
= trunc
;
2050 wide_strcpy (b
->line
, line
);
2052 if (line_head
== NULL
)
2055 line_tail
->next
= b
;
2059 while (file_changes_cur
< file_changes_count
)
2060 file_changes
[file_changes_cur
++].lb
= b
;
2063 /* Release the line buffer allocated in load_line. */
2069 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
2070 current_file
= current_file
->up
;
2071 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
2076 /* Open a new file and start scanning from that file. Returns true
2077 if everything went OK, false otherwise. If form == FORM_UNKNOWN
2078 it tries to determine the source form from the filename, defaulting
2086 if (gfc_cpp_enabled ())
2088 result
= gfc_cpp_preprocess (gfc_source_file
);
2089 if (!gfc_cpp_preprocess_only ())
2090 result
= load_file (gfc_cpp_temporary_file (), gfc_source_file
, true);
2093 result
= load_file (gfc_source_file
, NULL
, true);
2095 gfc_current_locus
.lb
= line_head
;
2096 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
2098 #if 0 /* Debugging aid. */
2099 for (; line_head
; line_head
= line_head
->next
)
2100 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
2101 LOCATION_LINE (line_head
->location
), line_head
->line
);
2103 exit (SUCCESS_EXIT_CODE
);
2110 unescape_filename (const char *ptr
)
2112 const char *p
= ptr
, *s
;
2114 int escaped
, unescape
= 0;
2116 /* Make filename end at quote. */
2118 while (*p
&& ! (! escaped
&& *p
== '"'))
2122 else if (*p
== '\\')
2133 /* Undo effects of cpp_quote_string. */
2135 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
2150 /* For preprocessed files, if the first tokens are of the form # NUM.
2151 handle the directives so we know the original file name. */
2154 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
2157 char *dirname
, *tmp
;
2159 gfc_src_file
= gfc_open_file (filename
);
2160 if (gfc_src_file
== NULL
)
2163 c
= getc (gfc_src_file
);
2169 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2171 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2174 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2175 filename
= unescape_filename (tmp
);
2177 if (filename
== NULL
)
2180 c
= getc (gfc_src_file
);
2186 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2188 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2191 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2192 dirname
= unescape_filename (tmp
);
2194 if (dirname
== NULL
)
2197 len
= strlen (dirname
);
2198 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2203 dirname
[len
- 2] = '\0';
2204 set_src_pwd (dirname
);
2206 if (! IS_ABSOLUTE_PATH (filename
))
2208 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2210 memcpy (p
, dirname
, len
- 2);
2212 strcpy (p
+ len
- 1, filename
);
2213 *canon_source_file
= p
;