2 Copyright (C) 2000-2024 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. */
50 #include "diagnostic-core.h" /* For fatal_error. */
54 /* List of include file search directories. */
55 gfc_directorylist
*include_dirs
, *intrinsic_modules_dirs
;
57 static gfc_file
*file_head
, *current_file
;
59 static bool continue_flag
, end_flag
, gcc_attribute_flag
;
60 /* If !$omp/!$acc occurred in current comment line. */
61 static int openmp_flag
, openacc_flag
;
62 static int continue_count
, continue_line
;
63 static locus openmp_locus
;
64 static locus openacc_locus
;
65 static locus gcc_attribute_locus
;
67 gfc_source_form gfc_current_form
;
68 static gfc_linebuf
*line_head
, *line_tail
;
70 locus gfc_current_locus
;
71 const char *gfc_source_file
;
72 static FILE *gfc_src_file
;
73 static gfc_char_t
*gfc_src_preprocessor_lines
[2];
75 static struct gfc_file_change
81 static size_t file_changes_cur
, file_changes_count
;
82 static size_t file_changes_allocated
;
84 static gfc_char_t
*last_error_char
;
86 /* Functions dealing with our wide characters (gfc_char_t) and
87 sequences of such characters. */
90 gfc_wide_fits_in_byte (gfc_char_t c
)
92 return (c
<= UCHAR_MAX
);
96 wide_is_ascii (gfc_char_t c
)
98 return (gfc_wide_fits_in_byte (c
) && ((unsigned char) c
& ~0x7f) == 0);
102 gfc_wide_is_printable (gfc_char_t c
)
104 return (gfc_wide_fits_in_byte (c
) && ISPRINT ((unsigned char) c
));
108 gfc_wide_tolower (gfc_char_t c
)
110 return (wide_is_ascii (c
) ? (gfc_char_t
) TOLOWER((unsigned char) c
) : c
);
114 gfc_wide_toupper (gfc_char_t c
)
116 return (wide_is_ascii (c
) ? (gfc_char_t
) TOUPPER((unsigned char) c
) : c
);
120 gfc_wide_is_digit (gfc_char_t c
)
122 return (c
>= '0' && c
<= '9');
126 wide_atoi (gfc_char_t
*c
)
128 #define MAX_DIGITS 20
129 char buf
[MAX_DIGITS
+1];
132 while (gfc_wide_is_digit(*c
) && i
< MAX_DIGITS
)
139 gfc_wide_strlen (const gfc_char_t
*str
)
143 for (i
= 0; str
[i
]; i
++)
150 gfc_wide_memset (gfc_char_t
*b
, gfc_char_t c
, size_t len
)
154 for (i
= 0; i
< len
; i
++)
161 wide_strcpy (gfc_char_t
*dest
, const gfc_char_t
*src
)
165 for (d
= dest
; (*d
= *src
) != '\0'; ++src
, ++d
)
172 wide_strchr (const gfc_char_t
*s
, gfc_char_t c
)
177 return CONST_CAST(gfc_char_t
*, s
);
184 gfc_widechar_to_char (const gfc_char_t
*s
, int length
)
192 /* Passing a negative length is used to indicate that length should be
193 calculated using gfc_wide_strlen(). */
194 len
= (length
>= 0 ? (size_t) length
: gfc_wide_strlen (s
));
195 res
= XNEWVEC (char, len
+ 1);
197 for (i
= 0; i
< len
; i
++)
199 gcc_assert (gfc_wide_fits_in_byte (s
[i
]));
200 res
[i
] = (unsigned char) s
[i
];
208 gfc_char_to_widechar (const char *s
)
217 res
= gfc_get_wide_string (len
+ 1);
219 for (i
= 0; i
< len
; i
++)
220 res
[i
] = (unsigned char) s
[i
];
227 wide_strncmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
236 return (c1
> c2
? 1 : -1);
244 gfc_wide_strncasecmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
250 c1
= gfc_wide_tolower (*s1
++);
251 c2
= TOLOWER (*s2
++);
253 return (c1
> c2
? 1 : -1);
261 /* Main scanner initialization. */
264 gfc_scanner_init_1 (void)
274 last_error_char
= NULL
;
278 /* Main scanner destructor. */
281 gfc_scanner_done_1 (void)
286 while(line_head
!= NULL
)
288 lb
= line_head
->next
;
293 while(file_head
!= NULL
)
296 free (file_head
->filename
);
303 gfc_do_check_include_dir (const char *path
, bool warn
)
306 if (stat (path
, &st
))
309 gfc_warning_now (0, "Include directory %qs: %s",
310 path
, xstrerror(errno
));
312 gfc_warning_now (OPT_Wmissing_include_dirs
,
313 "Nonexistent include directory %qs", path
);
316 else if (!S_ISDIR (st
.st_mode
))
318 gfc_fatal_error ("%qs is not a directory", path
);
324 /* In order that -W(no-)missing-include-dirs works, the diagnostic can only be
325 run after processing the commandline. */
327 gfc_do_check_include_dirs (gfc_directorylist
**list
, bool do_warn
)
329 gfc_directorylist
*prev
, *q
, *n
;
335 if (gfc_do_check_include_dir (q
->path
, q
->warn
&& do_warn
))
350 gfc_check_include_dirs (bool verbose_missing_dir_warn
)
352 /* This is a bit convoluted: If gfc_cpp_enabled () and
353 verbose_missing_dir_warn, the warning is shown by libcpp. Otherwise,
354 it is shown here, still conditional on OPT_Wmissing_include_dirs. */
355 bool warn
= !gfc_cpp_enabled () || !verbose_missing_dir_warn
;
356 gfc_do_check_include_dirs (&include_dirs
, warn
);
357 gfc_do_check_include_dirs (&intrinsic_modules_dirs
, verbose_missing_dir_warn
);
358 if (gfc_option
.module_dir
&& gfc_cpp_enabled ())
359 gfc_do_check_include_dirs (&include_dirs
, true);
362 /* Adds path to the list pointed to by list. */
365 add_path_to_list (gfc_directorylist
**list
, const char *path
,
366 bool use_for_modules
, bool head
, bool warn
, bool defer_warn
)
368 gfc_directorylist
*dir
;
375 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
379 /* Strip trailing directory separators from the path, as this
380 will confuse Windows systems. */
382 q
= (char *) alloca (len
+ 1);
383 memcpy (q
, p
, len
+ 1);
385 while (i
>=0 && IS_DIR_SEPARATOR (q
[i
]))
388 if (!defer_warn
&& !gfc_do_check_include_dir (q
, warn
))
391 if (head
|| *list
== NULL
)
393 dir
= XCNEW (gfc_directorylist
);
403 dir
->next
= XCNEW (gfc_directorylist
);
407 dir
->next
= head
? *list
: NULL
;
410 dir
->use_for_modules
= use_for_modules
;
412 dir
->path
= xstrdup (p
);
415 /* defer_warn is set to true while parsing the commandline. */
418 gfc_add_include_path (const char *path
, bool use_for_modules
, bool file_dir
,
419 bool warn
, bool defer_warn
)
421 add_path_to_list (&include_dirs
, path
, use_for_modules
, file_dir
, warn
,
424 /* For '#include "..."' these directories are automatically searched. */
426 gfc_cpp_add_include_path (xstrdup(path
), true);
431 gfc_add_intrinsic_modules_path (const char *path
)
433 add_path_to_list (&intrinsic_modules_dirs
, path
, true, false, false, false);
437 /* Release resources allocated for options. */
440 gfc_release_include_path (void)
442 gfc_directorylist
*p
;
444 while (include_dirs
!= NULL
)
447 include_dirs
= include_dirs
->next
;
452 while (intrinsic_modules_dirs
!= NULL
)
454 p
= intrinsic_modules_dirs
;
455 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
460 free (gfc_option
.module_dir
);
465 open_included_file (const char *name
, gfc_directorylist
*list
,
466 bool module
, bool system
)
469 gfc_directorylist
*p
;
472 for (p
= list
; p
; p
= p
->next
)
474 if (module
&& !p
->use_for_modules
)
477 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 2);
478 strcpy (fullname
, p
->path
);
479 strcat (fullname
, "/");
480 strcat (fullname
, name
);
482 f
= gfc_open_file (fullname
);
485 if (gfc_cpp_makedep ())
486 gfc_cpp_add_dep (fullname
, system
);
496 /* Opens file for reading, searching through the include directories
497 given if necessary. If the include_cwd argument is true, we try
498 to open the file in the current directory first. */
501 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
505 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
507 f
= gfc_open_file (name
);
508 if (f
&& gfc_cpp_makedep ())
509 gfc_cpp_add_dep (name
, false);
513 f
= open_included_file (name
, include_dirs
, module
, false);
519 /* Test to see if we're at the end of the main source file. */
528 /* Test to see if we're at the end of the current file. */
536 if (line_head
== NULL
)
537 return 1; /* Null file */
539 if (gfc_current_locus
.lb
== NULL
)
546 /* Test to see if we're at the beginning of a new line. */
554 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
558 /* Test to see if we're at the end of a line. */
566 return (*gfc_current_locus
.nextc
== '\0');
570 add_file_change (const char *filename
, int line
)
572 if (file_changes_count
== file_changes_allocated
)
574 if (file_changes_allocated
)
575 file_changes_allocated
*= 2;
577 file_changes_allocated
= 16;
578 file_changes
= XRESIZEVEC (struct gfc_file_change
, file_changes
,
579 file_changes_allocated
);
581 file_changes
[file_changes_count
].filename
= filename
;
582 file_changes
[file_changes_count
].lb
= NULL
;
583 file_changes
[file_changes_count
++].line
= line
;
587 report_file_change (gfc_linebuf
*lb
)
589 size_t c
= file_changes_cur
;
590 while (c
< file_changes_count
591 && file_changes
[c
].lb
== lb
)
593 if (file_changes
[c
].filename
)
594 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
595 file_changes
[c
].filename
);
597 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
600 file_changes_cur
= c
;
604 gfc_start_source_files (void)
606 /* If the debugger wants the name of the main source file,
608 if (debug_hooks
->start_end_main_source_file
)
609 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
611 file_changes_cur
= 0;
612 report_file_change (gfc_current_locus
.lb
);
616 gfc_end_source_files (void)
618 report_file_change (NULL
);
620 if (debug_hooks
->start_end_main_source_file
)
621 (*debug_hooks
->end_source_file
) (0);
624 /* Advance the current line pointer to the next line. */
627 gfc_advance_line (void)
632 if (gfc_current_locus
.lb
== NULL
)
638 if (gfc_current_locus
.lb
->next
639 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
641 report_file_change (gfc_current_locus
.lb
->next
);
642 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
645 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
647 if (gfc_current_locus
.lb
!= NULL
)
648 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
651 gfc_current_locus
.nextc
= NULL
;
657 /* Get the next character from the input, advancing gfc_current_file's
658 locus. When we hit the end of the line or the end of the file, we
659 start returning a '\n' in order to complete the current statement.
660 No Fortran line conventions are implemented here.
662 Requiring explicit advances to the next line prevents the parse
663 pointer from being on the wrong line if the current statement ends
671 if (gfc_current_locus
.nextc
== NULL
)
674 c
= *gfc_current_locus
.nextc
++;
677 gfc_current_locus
.nextc
--; /* Remain on this line. */
685 /* Skip a comment. When we come here the parse pointer is positioned
686 immediately after the comment character. If we ever implement
687 compiler directives within comments, here is where we parse the
691 skip_comment_line (void)
706 gfc_define_undef_line (void)
710 /* All lines beginning with '#' are either #define or #undef. */
711 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
714 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
716 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
717 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
722 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
724 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
725 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
730 /* Skip the rest of the line. */
731 skip_comment_line ();
737 /* Return true if GCC$ was matched. */
739 skip_gcc_attribute (locus start
)
743 locus old_loc
= gfc_current_locus
;
745 if ((c
= next_char ()) == 'g' || c
== 'G')
746 if ((c
= next_char ()) == 'c' || c
== 'C')
747 if ((c
= next_char ()) == 'c' || c
== 'C')
748 if ((c
= next_char ()) == '$')
752 gfc_current_locus
= old_loc
;
755 gcc_attribute_flag
= 1;
756 gcc_attribute_locus
= old_loc
;
757 gfc_current_locus
= start
;
763 /* Return true if CC was matched. */
765 skip_free_oacc_sentinel (locus start
, locus old_loc
)
770 if ((c
= next_char ()) == 'c' || c
== 'C')
771 if ((c
= next_char ()) == 'c' || c
== 'C')
776 if ((c
= next_char ()) == ' ' || c
== '\t'
779 while (gfc_is_whitespace (c
))
781 if (c
!= '\n' && c
!= '!')
784 openacc_locus
= old_loc
;
785 gfc_current_locus
= start
;
792 gfc_warning_now (0, "!$ACC at %C starts a commented "
793 "line as it neither is followed "
794 "by a space nor is a "
795 "continuation line");
803 /* Return true if MP was matched. */
805 skip_free_omp_sentinel (locus start
, locus old_loc
)
810 if ((c
= next_char ()) == 'm' || c
== 'M')
811 if ((c
= next_char ()) == 'p' || c
== 'P')
816 if ((c
= next_char ()) == ' ' || c
== '\t'
819 while (gfc_is_whitespace (c
))
821 if (c
!= '\n' && c
!= '!')
824 openmp_locus
= old_loc
;
825 gfc_current_locus
= start
;
832 gfc_warning_now (0, "!$OMP at %C starts a commented "
833 "line as it neither is followed "
834 "by a space nor is a "
835 "continuation line");
843 /* Comment lines are null lines, lines containing only blanks or lines
844 on which the first nonblank line is a '!'.
845 Return true if !$ openmp or openacc conditional compilation sentinel was
849 skip_free_comments (void)
857 at_bol
= gfc_at_bol ();
858 start
= gfc_current_locus
;
864 while (gfc_is_whitespace (c
));
874 /* Keep the !GCC$ line. */
875 if (at_bol
&& skip_gcc_attribute (start
))
878 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
879 1) don't treat !$omp/!$acc as comments, but directives
880 2) handle OpenMP conditional compilation, where
881 !$ should be treated as 2 spaces (for initial lines
882 only if followed by space). */
885 if ((flag_openmp
|| flag_openmp_simd
)
888 locus old_loc
= gfc_current_locus
;
889 if (next_char () == '$')
892 if (c
== 'o' || c
== 'O')
894 if (skip_free_omp_sentinel (start
, old_loc
))
896 gfc_current_locus
= old_loc
;
900 else if (c
== 'a' || c
== 'A')
902 if (skip_free_oacc_sentinel (start
, old_loc
))
904 gfc_current_locus
= old_loc
;
908 if (continue_flag
|| c
== ' ' || c
== '\t')
910 gfc_current_locus
= old_loc
;
912 openmp_flag
= openacc_flag
= 0;
916 gfc_current_locus
= old_loc
;
918 else if ((flag_openmp
|| flag_openmp_simd
)
921 locus old_loc
= gfc_current_locus
;
922 if (next_char () == '$')
925 if (c
== 'o' || c
== 'O')
927 if (skip_free_omp_sentinel (start
, old_loc
))
929 gfc_current_locus
= old_loc
;
933 if (continue_flag
|| c
== ' ' || c
== '\t')
935 gfc_current_locus
= old_loc
;
941 gfc_current_locus
= old_loc
;
943 else if (flag_openacc
944 && !(flag_openmp
|| flag_openmp_simd
))
946 locus old_loc
= gfc_current_locus
;
947 if (next_char () == '$')
950 if (c
== 'a' || c
== 'A')
952 if (skip_free_oacc_sentinel (start
, old_loc
))
954 gfc_current_locus
= old_loc
;
959 gfc_current_locus
= old_loc
;
962 skip_comment_line ();
969 if (openmp_flag
&& at_bol
)
972 if (openacc_flag
&& at_bol
)
975 gcc_attribute_flag
= 0;
976 gfc_current_locus
= start
;
980 /* Return true if MP was matched in fixed form. */
982 skip_fixed_omp_sentinel (locus
*start
)
985 if ((c
= next_char ()) != 'm' && c
!= 'M')
987 if ((c
= next_char ()) == 'p' || c
== 'P')
992 || c
== ' ' || c
== '\t' || c
== '0'))
994 if (c
== ' ' || c
== '\t' || c
== '0')
998 while (gfc_is_whitespace (c
));
999 if (c
!= '\n' && c
!= '!')
1001 /* Canonicalize to *$omp. */
1002 *start
->nextc
= '*';
1004 gfc_current_locus
= *start
;
1009 else if (UNLIKELY (c
== 'x' || c
== 'X'))
1010 gfc_warning_now (OPT_Wsurprising
,
1011 "Ignoring '!$omx' vendor-extension sentinel at %C");
1015 /* Return true if CC was matched in fixed form. */
1017 skip_fixed_oacc_sentinel (locus
*start
)
1020 if (((c
= next_char ()) == 'c' || c
== 'C')
1021 && ((c
= next_char ()) == 'c' || c
== 'C'))
1026 || c
== ' ' || c
== '\t' || c
== '0'))
1028 if (c
== ' ' || c
== '\t' || c
== '0')
1032 while (gfc_is_whitespace (c
));
1033 if (c
!= '\n' && c
!= '!')
1035 /* Canonicalize to *$acc. */
1036 *start
->nextc
= '*';
1038 gfc_current_locus
= *start
;
1046 /* Skip comment lines in fixed source mode. We have the same rules as
1047 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
1048 in column 1, and a '!' cannot be in column 6. Also, we deal with
1049 lines with 'd' or 'D' in column 1, if the user requested this. */
1052 skip_fixed_comments (void)
1058 if (! gfc_at_bol ())
1060 start
= gfc_current_locus
;
1061 if (! gfc_at_eof ())
1065 while (gfc_is_whitespace (c
));
1068 gfc_advance_line ();
1070 skip_comment_line ();
1073 if (! gfc_at_bol ())
1075 gfc_current_locus
= start
;
1082 start
= gfc_current_locus
;
1089 gfc_advance_line ();
1093 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
1095 if (skip_gcc_attribute (start
))
1097 /* Canonicalize to *$omp. */
1102 if (gfc_current_locus
.lb
!= NULL
1103 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1104 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1106 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
1107 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
1109 2) handle OpenMP conditional compilation, where
1110 !$|c$|*$ should be treated as 2 spaces if the characters
1111 in columns 3 to 6 are valid fixed form label columns
1113 if ((flag_openmp
|| flag_openmp_simd
) && !flag_openacc
)
1115 if (next_char () == '$')
1118 if (c
== 'o' || c
== 'O')
1120 if (skip_fixed_omp_sentinel (&start
))
1124 goto check_for_digits
;
1126 gfc_current_locus
= start
;
1128 else if (flag_openacc
&& !(flag_openmp
|| flag_openmp_simd
))
1130 if (next_char () == '$')
1133 if (c
== 'a' || c
== 'A')
1135 if (skip_fixed_oacc_sentinel (&start
))
1139 gfc_current_locus
= start
;
1141 else if (flag_openacc
|| flag_openmp
|| flag_openmp_simd
)
1143 if (next_char () == '$')
1146 if (c
== 'a' || c
== 'A')
1148 if (skip_fixed_oacc_sentinel (&start
))
1151 else if (c
== 'o' || c
== 'O')
1153 if (skip_fixed_omp_sentinel (&start
))
1157 goto check_for_digits
;
1159 gfc_current_locus
= start
;
1162 skip_comment_line ();
1167 /* Required for OpenMP's conditional compilation sentinel. */
1170 for (col
= 3; col
< 6; col
++, c
= next_char ())
1178 else if (c
< '0' || c
> '9')
1183 if (col
== 6 && c
!= '\n'
1184 && ((continue_flag
&& !digit_seen
)
1185 || c
== ' ' || c
== '\t' || c
== '0'))
1187 gfc_current_locus
= start
;
1188 start
.nextc
[0] = ' ';
1189 start
.nextc
[1] = ' ';
1193 skip_comment_line ();
1197 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
1199 if (gfc_option
.flag_d_lines
== 0)
1201 skip_comment_line ();
1205 *start
.nextc
= c
= ' ';
1210 while (gfc_is_whitespace (c
))
1218 gfc_advance_line ();
1222 if (col
!= 6 && c
== '!')
1224 if (gfc_current_locus
.lb
!= NULL
1225 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1226 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1227 skip_comment_line ();
1236 gcc_attribute_flag
= 0;
1237 gfc_current_locus
= start
;
1241 /* Skips the current line if it is a comment. */
1244 gfc_skip_comments (void)
1246 if (gfc_current_form
== FORM_FREE
)
1247 skip_free_comments ();
1249 skip_fixed_comments ();
1253 /* Get the next character from the input, taking continuation lines
1254 and end-of-line comments into account. This implies that comment
1255 lines between continued lines must be eaten here. For higher-level
1256 subroutines, this flattens continued lines into a single logical
1257 line. The in_string flag denotes whether we're inside a character
1261 gfc_next_char_literal (gfc_instring in_string
)
1263 static locus omp_acc_err_loc
= {};
1265 int i
, prev_openmp_flag
, prev_openacc_flag
;
1269 prev_openacc_flag
= prev_openmp_flag
= 0;
1279 if (gfc_current_form
== FORM_FREE
)
1281 bool openmp_cond_flag
;
1283 if (!in_string
&& c
== '!')
1285 if (gcc_attribute_flag
1286 && memcmp (&gfc_current_locus
, &gcc_attribute_locus
,
1287 sizeof (gfc_current_locus
)) == 0)
1291 && memcmp (&gfc_current_locus
, &openmp_locus
,
1292 sizeof (gfc_current_locus
)) == 0)
1296 && memcmp (&gfc_current_locus
, &openacc_locus
,
1297 sizeof (gfc_current_locus
)) == 0)
1300 /* This line can't be continued */
1307 /* Avoid truncation warnings for comment ending lines. */
1308 gfc_current_locus
.lb
->truncated
= 0;
1313 /* Check to see if the continuation line was truncated. */
1314 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1315 && gfc_current_locus
.lb
->truncated
)
1317 int maxlen
= flag_free_line_length
;
1318 gfc_char_t
*current_nextc
= gfc_current_locus
.nextc
;
1320 gfc_current_locus
.lb
->truncated
= 0;
1321 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
+ maxlen
;
1322 gfc_warning_now (OPT_Wline_truncation
,
1323 "Line truncated at %L", &gfc_current_locus
);
1324 gfc_current_locus
.nextc
= current_nextc
;
1330 /* If the next nonblank character is a ! or \n, we've got a
1331 continuation line. */
1332 old_loc
= gfc_current_locus
;
1335 while (gfc_is_whitespace (c
))
1338 /* Character constants to be continued cannot have commentary
1339 after the '&'. However, there are cases where we may think we
1340 are still in a string and we are looking for a possible
1341 doubled quote and we end up here. See PR64506. */
1343 if (in_string
&& c
!= '\n')
1345 gfc_current_locus
= old_loc
;
1350 if (c
!= '!' && c
!= '\n')
1352 gfc_current_locus
= old_loc
;
1358 prev_openmp_flag
= openmp_flag
;
1360 prev_openacc_flag
= openacc_flag
;
1362 /* This can happen if the input file changed or via cpp's #line
1363 without getting reset (e.g. via input_stmt). It also happens
1364 when pre-including files via -fpre-include=. */
1365 if (continue_count
== 0
1366 && gfc_current_locus
.lb
1367 && continue_line
> gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1)
1368 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1;
1372 skip_comment_line ();
1374 gfc_advance_line ();
1377 goto not_continuation
;
1379 /* We've got a continuation line. If we are on the very next line after
1380 the last continuation, increment the continuation line count and
1381 check whether the limit has been exceeded. */
1382 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1384 if (++continue_count
== gfc_option
.max_continue_free
)
1386 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1387 gfc_warning (0, "Limit of %d continuations exceeded in "
1388 "statement at %C", gfc_option
.max_continue_free
);
1392 /* Now find where it continues. First eat any comment lines. */
1393 openmp_cond_flag
= skip_free_comments ();
1395 if (gfc_current_locus
.lb
!= NULL
1396 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1397 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1400 if (prev_openmp_flag
!= openmp_flag
&& !openacc_flag
)
1402 gfc_current_locus
= old_loc
;
1403 openmp_flag
= prev_openmp_flag
;
1409 if (prev_openacc_flag
!= openacc_flag
&& !openmp_flag
)
1411 gfc_current_locus
= old_loc
;
1412 openacc_flag
= prev_openacc_flag
;
1417 /* Now that we have a non-comment line, probe ahead for the
1418 first non-whitespace character. If it is another '&', then
1419 reading starts at the next character, otherwise we must back
1420 up to where the whitespace started and resume from there. */
1422 old_loc
= gfc_current_locus
;
1425 while (gfc_is_whitespace (c
))
1428 if (openmp_flag
&& !openacc_flag
)
1430 for (i
= 0; i
< 5; i
++, c
= next_char ())
1432 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1434 old_loc
= gfc_current_locus
;
1436 while (gfc_is_whitespace (c
))
1439 if (openacc_flag
&& !openmp_flag
)
1441 for (i
= 0; i
< 5; i
++, c
= next_char ())
1443 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$acc"[i
]);
1445 old_loc
= gfc_current_locus
;
1447 while (gfc_is_whitespace (c
))
1451 /* In case we have an OpenMP directive continued by OpenACC
1452 sentinel, or vice versa, we get both openmp_flag and
1455 if (openacc_flag
&& openmp_flag
)
1458 for (i
= 0; i
< 5; i
++, c
= next_char ())
1460 if (gfc_wide_tolower (c
) != (unsigned char) "!$acc"[i
])
1463 if (omp_acc_err_loc
.nextc
!= gfc_current_locus
.nextc
1464 || omp_acc_err_loc
.lb
!= gfc_current_locus
.lb
)
1465 gfc_error_now (is_openmp
1466 ? G_("Wrong OpenACC continuation at %C: "
1467 "expected !$ACC, got !$OMP")
1468 : G_("Wrong OpenMP continuation at %C: "
1469 "expected !$OMP, got !$ACC"));
1470 omp_acc_err_loc
= gfc_current_locus
;
1471 goto not_continuation
;
1476 if (in_string
&& gfc_current_locus
.nextc
)
1478 gfc_current_locus
.nextc
--;
1479 if (warn_ampersand
&& in_string
== INSTRING_WARN
)
1480 gfc_warning (OPT_Wampersand
,
1481 "Missing %<&%> in continued character "
1484 else if (!in_string
&& (c
== '\'' || c
== '"'))
1486 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1487 continuation line only optionally. */
1488 else if (openmp_flag
|| openacc_flag
|| openmp_cond_flag
)
1490 if (gfc_current_locus
.nextc
)
1491 gfc_current_locus
.nextc
--;
1496 gfc_current_locus
= old_loc
;
1501 else /* Fixed form. */
1503 /* Fixed form continuation. */
1504 if (in_string
!= INSTRING_WARN
&& c
== '!')
1506 /* Skip comment at end of line. */
1513 /* Avoid truncation warnings for comment ending lines. */
1514 gfc_current_locus
.lb
->truncated
= 0;
1520 /* Check to see if the continuation line was truncated. */
1521 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1522 && gfc_current_locus
.lb
->truncated
)
1524 gfc_current_locus
.lb
->truncated
= 0;
1525 gfc_warning_now (OPT_Wline_truncation
,
1526 "Line truncated at %L", &gfc_current_locus
);
1530 prev_openmp_flag
= openmp_flag
;
1532 prev_openacc_flag
= openacc_flag
;
1534 /* This can happen if the input file changed or via cpp's #line
1535 without getting reset (e.g. via input_stmt). It also happens
1536 when pre-including files via -fpre-include=. */
1537 if (continue_count
== 0
1538 && gfc_current_locus
.lb
1539 && continue_line
> gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1)
1540 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1;
1543 old_loc
= gfc_current_locus
;
1545 gfc_advance_line ();
1546 skip_fixed_comments ();
1548 /* See if this line is a continuation line. */
1549 if (flag_openmp
&& openmp_flag
!= prev_openmp_flag
&& !openacc_flag
)
1551 openmp_flag
= prev_openmp_flag
;
1552 goto not_continuation
;
1554 if (flag_openacc
&& openacc_flag
!= prev_openacc_flag
&& !openmp_flag
)
1556 openacc_flag
= prev_openacc_flag
;
1557 goto not_continuation
;
1560 /* In case we have an OpenMP directive continued by OpenACC
1561 sentinel, or vice versa, we get both openmp_flag and
1563 if (openacc_flag
&& openmp_flag
)
1566 for (i
= 0; i
< 5; i
++)
1569 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1572 if (omp_acc_err_loc
.nextc
!= gfc_current_locus
.nextc
1573 || omp_acc_err_loc
.lb
!= gfc_current_locus
.lb
)
1574 gfc_error_now (is_openmp
1575 ? G_("Wrong OpenACC continuation at %C: "
1576 "expected !$ACC, got !$OMP")
1577 : G_("Wrong OpenMP continuation at %C: "
1578 "expected !$OMP, got !$ACC"));
1579 omp_acc_err_loc
= gfc_current_locus
;
1580 goto not_continuation
;
1582 else if (!openmp_flag
&& !openacc_flag
)
1583 for (i
= 0; i
< 5; i
++)
1587 goto not_continuation
;
1589 else if (openmp_flag
)
1590 for (i
= 0; i
< 5; i
++)
1593 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1594 goto not_continuation
;
1596 else if (openacc_flag
)
1597 for (i
= 0; i
< 5; i
++)
1600 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1601 goto not_continuation
;
1605 if (c
== '0' || c
== ' ' || c
== '\n')
1606 goto not_continuation
;
1608 /* We've got a continuation line. If we are on the very next line after
1609 the last continuation, increment the continuation line count and
1610 check whether the limit has been exceeded. */
1611 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1613 if (++continue_count
== gfc_option
.max_continue_fixed
)
1615 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1616 gfc_warning (0, "Limit of %d continuations exceeded in "
1618 gfc_option
.max_continue_fixed
);
1622 if (gfc_current_locus
.lb
!= NULL
1623 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1624 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1627 /* Ready to read first character of continuation line, which might
1628 be another continuation line! */
1633 gfc_current_locus
= old_loc
;
1644 /* Get the next character of input, folded to lowercase. In fixed
1645 form mode, we also ignore spaces. When matcher subroutines are
1646 parsing character literals, they have to call
1647 gfc_next_char_literal(). */
1650 gfc_next_char (void)
1656 c
= gfc_next_char_literal (NONSTRING
);
1658 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1660 return gfc_wide_tolower (c
);
1664 gfc_next_ascii_char (void)
1666 gfc_char_t c
= gfc_next_char ();
1668 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1669 : (unsigned char) UCHAR_MAX
);
1674 gfc_peek_char (void)
1679 old_loc
= gfc_current_locus
;
1680 c
= gfc_next_char ();
1681 gfc_current_locus
= old_loc
;
1688 gfc_peek_ascii_char (void)
1690 gfc_char_t c
= gfc_peek_char ();
1692 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1693 : (unsigned char) UCHAR_MAX
);
1697 /* Recover from an error. We try to get past the current statement
1698 and get lined up for the next. The next statement follows a '\n'
1699 or a ';'. We also assume that we are not within a character
1700 constant, and deal with finding a '\'' or '"'. */
1703 gfc_error_recovery (void)
1705 gfc_char_t c
, delim
;
1712 c
= gfc_next_char ();
1713 if (c
== '\n' || c
== ';')
1716 if (c
!= '\'' && c
!= '"')
1745 /* Read ahead until the next character to be read is not whitespace. */
1748 gfc_gobble_whitespace (void)
1750 static int linenum
= 0;
1756 old_loc
= gfc_current_locus
;
1757 c
= gfc_next_char_literal (NONSTRING
);
1758 /* Issue a warning for nonconforming tabs. We keep track of the line
1759 number because the Fortran matchers will often back up and the same
1760 line will be scanned multiple times. */
1761 if (warn_tabs
&& c
== '\t')
1763 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1764 if (cur_linenum
!= linenum
)
1766 linenum
= cur_linenum
;
1767 gfc_warning_now (OPT_Wtabs
, "Nonconforming tab character at %C");
1771 while (gfc_is_whitespace (c
));
1773 if (!ISPRINT(c
) && c
!= '\n' && last_error_char
!= gfc_current_locus
.nextc
)
1776 last_error_char
= gfc_current_locus
.nextc
;
1777 snprintf (buf
, 20, "%2.2X", c
);
1778 gfc_error_now ("Invalid character 0x%s at %C", buf
);
1781 gfc_current_locus
= old_loc
;
1785 /* Load a single line into pbuf.
1787 If pbuf points to a NULL pointer, it is allocated.
1788 We truncate lines that are too long, unless we're dealing with
1789 preprocessor lines or if the option -ffixed-line-length-none is set,
1790 in which case we reallocate the buffer to fit the entire line, if
1792 In fixed mode, we expand a tab that occurs within the statement
1793 label region to expand to spaces that leave the next character in
1796 If first_char is not NULL, it's a pointer to a single char value holding
1797 the first character of the line, which has already been read by the
1798 caller. This avoids the use of ungetc().
1800 load_line returns whether the line was truncated.
1802 NOTE: The error machinery isn't available at this point, so we can't
1803 easily report line and column numbers consistent with other
1804 parts of gfortran. */
1807 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1809 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1810 int quoted
= ' ', comment_ix
= -1;
1811 bool seen_comment
= false;
1812 bool first_comment
= true;
1813 bool trunc_flag
= false;
1814 bool seen_printable
= false;
1815 bool seen_ampersand
= false;
1816 bool found_tab
= false;
1817 bool warned_tabs
= false;
1820 /* Determine the maximum allowed line length. */
1821 if (gfc_current_form
== FORM_FREE
)
1822 maxlen
= flag_free_line_length
;
1823 else if (gfc_current_form
== FORM_FIXED
)
1824 maxlen
= flag_fixed_line_length
;
1830 /* Allocate the line buffer, storing its length into buflen.
1831 Note that if maxlen==0, indicating that arbitrary-length lines
1832 are allowed, the buffer will be reallocated if this length is
1833 insufficient; since 132 characters is the length of a standard
1834 free-form line, we use that as a starting guess. */
1840 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1851 /* In order to not truncate preprocessor lines, we have to
1852 remember that this is one. */
1853 preprocessor_flag
= (c
== '#');
1862 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1863 if (gfc_current_form
== FORM_FREE
1864 && !seen_printable
&& seen_ampersand
)
1867 gfc_error_now ("%<&%> not allowed by itself in line %d",
1868 current_file
->line
);
1870 gfc_warning_now (0, "%<&%> not allowed by itself in line %d",
1871 current_file
->line
);
1876 if (c
== '\r' || c
== '\0')
1877 goto next_char
; /* Gobble characters. */
1883 seen_ampersand
= false;
1884 seen_printable
= true;
1887 seen_ampersand
= true;
1890 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1891 seen_printable
= true;
1893 /* Is this a fixed-form comment? */
1894 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1895 && (c
== '*' || c
== 'c' || c
== 'C'
1896 || (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))))
1898 seen_comment
= true;
1904 if (c
== '\'' || c
== '"')
1907 else if (c
== quoted
)
1910 /* Is this a free-form comment? */
1911 if (c
== '!' && quoted
== ' ')
1914 first_comment
= false;
1915 seen_comment
= true;
1919 /* For truncation and tab warnings, set seen_comment to false if one has
1920 either an OpenMP or OpenACC directive - or a !GCC$ attribute. If
1921 OpenMP is enabled, use '!$' as conditional compilation sentinel
1922 and OpenMP directive ('!$omp'). */
1923 if (seen_comment
&& first_comment
&& flag_openmp
&& comment_ix
+ 1 == i
1925 first_comment
= seen_comment
= false;
1926 if (seen_comment
&& first_comment
&& comment_ix
+ 4 == i
)
1928 if (((*pbuf
)[comment_ix
+1] == 'g' || (*pbuf
)[comment_ix
+1] == 'G')
1929 && ((*pbuf
)[comment_ix
+2] == 'c' || (*pbuf
)[comment_ix
+2] == 'C')
1930 && ((*pbuf
)[comment_ix
+3] == 'c' || (*pbuf
)[comment_ix
+3] == 'C')
1932 first_comment
= seen_comment
= false;
1934 && (*pbuf
)[comment_ix
+1] == '$'
1935 && ((*pbuf
)[comment_ix
+2] == 'a' || (*pbuf
)[comment_ix
+2] == 'A')
1936 && ((*pbuf
)[comment_ix
+3] == 'c' || (*pbuf
)[comment_ix
+3] == 'C')
1937 && (c
== 'c' || c
== 'C'))
1938 first_comment
= seen_comment
= false;
1941 /* Vendor extension: "<tab>1" marks a continuation line. */
1945 if (c
>= '1' && c
<= '9')
1952 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1956 if (warn_tabs
&& seen_comment
== 0 && !warned_tabs
)
1959 gfc_warning_now (OPT_Wtabs
,
1960 "Nonconforming tab character in column %d "
1961 "of line %d", i
+ 1, current_file
->line
);
1976 if (maxlen
== 0 || preprocessor_flag
)
1980 /* Reallocate line buffer to double size to hold the
1982 buflen
= buflen
* 2;
1983 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1984 buffer
= (*pbuf
) + i
;
1987 else if (i
>= maxlen
)
1989 bool trunc_warn
= true;
1991 /* Enhancement, if the very next non-space character is an ampersand
1992 or comment that we would otherwise warn about, don't mark as
1995 /* Truncate the rest of the line. */
1999 if (c
== '\r' || c
== ' ')
2002 if (c
== '\n' || c
== EOF
)
2005 if (!trunc_warn
&& c
!= '!')
2008 if (trunc_warn
&& ((gfc_current_form
== FORM_FIXED
&& c
== '&')
2015 if (trunc_warn
&& !seen_comment
)
2027 /* Pad lines to the selected line length in fixed form. */
2028 if (gfc_current_form
== FORM_FIXED
2029 && flag_fixed_line_length
!= 0
2031 && !preprocessor_flag
2034 while (i
++ < maxlen
)
2045 /* Get a gfc_file structure, initialize it and add it to
2049 get_file (const char *name
, enum lc_reason reason
)
2053 f
= XCNEW (gfc_file
);
2055 f
->filename
= xstrdup (name
);
2057 f
->next
= file_head
;
2060 f
->up
= current_file
;
2061 if (current_file
!= NULL
)
2062 f
->inclusion_line
= current_file
->line
;
2064 linemap_add (line_table
, reason
, false, f
->filename
, 1);
2070 /* Deal with a line from the C preprocessor. The
2071 initial octothorp has already been seen. */
2074 preprocessor_line (gfc_char_t
*c
)
2078 gfc_char_t
*wide_filename
;
2080 int escaped
, unescape
;
2084 while (*c
== ' ' || *c
== '\t')
2087 if (*c
< '0' || *c
> '9')
2090 line
= wide_atoi (c
);
2092 c
= wide_strchr (c
, ' ');
2095 /* No file name given. Set new line number. */
2096 current_file
->line
= line
;
2101 while (*c
== ' ' || *c
== '\t')
2111 /* Make filename end at quote. */
2114 while (*c
&& ! (!escaped
&& *c
== '"'))
2118 else if (*c
== '\\')
2127 /* Preprocessor line has no closing quote. */
2132 /* Undo effects of cpp_quote_string. */
2135 gfc_char_t
*s
= wide_filename
;
2136 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
2152 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
2156 c
= wide_strchr (c
, ' ');
2163 if (i
>= 1 && i
<= 4)
2167 /* Convert the filename in wide characters into a filename in narrow
2169 filename
= gfc_widechar_to_char (wide_filename
, -1);
2171 /* Interpret flags. */
2173 if (flag
[1]) /* Starting new file. */
2175 f
= get_file (filename
, LC_RENAME
);
2176 add_file_change (f
->filename
, f
->inclusion_line
);
2180 if (flag
[2]) /* Ending current file. */
2182 if (!current_file
->up
2183 || filename_cmp (current_file
->up
->filename
, filename
) != 0)
2185 linemap_line_start (line_table
, current_file
->line
, 80);
2186 /* ??? One could compute the exact column where the filename
2187 starts and compute the exact location here. */
2188 gfc_warning_now_at (linemap_position_for_column (line_table
, 1),
2189 0, "file %qs left but not entered",
2191 current_file
->line
++;
2193 free (wide_filename
);
2198 add_file_change (NULL
, line
);
2199 current_file
= current_file
->up
;
2200 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
2201 current_file
->line
);
2204 /* The name of the file can be a temporary file produced by
2205 cpp. Replace the name if it is different. */
2207 if (filename_cmp (current_file
->filename
, filename
) != 0)
2209 /* FIXME: we leak the old filename because a pointer to it may be stored
2210 in the linemap. Alternative could be using GC or updating linemap to
2211 point to the new name, but there is no API for that currently. */
2212 current_file
->filename
= xstrdup (filename
);
2214 /* We need to tell the linemap API that the filename changed. Just
2215 changing current_file is insufficient. */
2216 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
, line
);
2219 /* Set new line number. */
2220 current_file
->line
= line
;
2222 free (wide_filename
);
2227 linemap_line_start (line_table
, current_file
->line
, 80);
2228 /* ??? One could compute the exact column where the directive
2229 starts and compute the exact location here. */
2230 gfc_warning_now_at (linemap_position_for_column (line_table
, 2), 0,
2231 "Illegal preprocessor directive");
2232 current_file
->line
++;
2236 static void load_file (const char *, const char *, bool);
2238 /* include_line()-- Checks a line buffer to see if it is an include
2239 line. If so, we call load_file() recursively to load the included
2240 file. We never return a syntax error because a statement like
2241 "include = 5" is perfectly legal. We return 0 if no include was
2242 processed, 1 if we matched an include or -1 if include was
2243 partially processed, but will need continuation lines. */
2246 include_line (gfc_char_t
*line
)
2248 gfc_char_t quote
, *c
, *begin
, *stop
;
2250 const char *include
= "include";
2251 bool allow_continuation
= flag_dec_include
;
2256 if (flag_openmp
|| flag_openmp_simd
)
2258 if (gfc_current_form
== FORM_FREE
)
2260 while (*c
== ' ' || *c
== '\t')
2262 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
2267 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
2268 && c
[1] == '$' && c
[2] == ' ')
2273 if (gfc_current_form
== FORM_FREE
)
2275 while (*c
== ' ' || *c
== '\t')
2277 if (gfc_wide_strncasecmp (c
, "include", 7))
2279 if (!allow_continuation
)
2281 for (i
= 0; i
< 7; ++i
)
2283 gfc_char_t c1
= gfc_wide_tolower (*c
);
2284 if (c1
!= (unsigned char) include
[i
])
2288 if (i
== 0 || *c
!= '&')
2291 while (*c
== ' ' || *c
== '\t')
2293 if (*c
== '\0' || *c
== '!')
2302 while (*c
== ' ' || *c
== '\t')
2304 if (flag_dec_include
&& *c
== '0' && c
- line
== 5)
2307 while (*c
== ' ' || *c
== '\t')
2311 allow_continuation
= false;
2312 for (i
= 0; i
< 7; ++i
)
2314 gfc_char_t c1
= gfc_wide_tolower (*c
);
2315 if (c1
!= (unsigned char) include
[i
])
2318 while (*c
== ' ' || *c
== '\t')
2321 if (!allow_continuation
)
2331 /* At the end of line or comment this might be continued. */
2332 if (*c
== '\0' || *c
== '!')
2339 while (*c
== ' ' || *c
== '\t')
2342 /* Find filename between quotes. */
2345 if (quote
!= '"' && quote
!= '\'')
2347 if (allow_continuation
)
2349 if (gfc_current_form
== FORM_FREE
)
2353 while (*c
== ' ' || *c
== '\t')
2355 if (*c
== '\0' || *c
== '!')
2359 else if (quote
== '\0' || quote
== '!')
2368 while (*c
!= quote
&& *c
!= '\0')
2370 if (allow_continuation
&& gfc_current_form
== FORM_FREE
)
2374 else if (*c
!= ' ' && *c
!= '\t')
2382 if (allow_continuation
2383 && (cont
|| gfc_current_form
!= FORM_FREE
))
2390 while (*c
== ' ' || *c
== '\t')
2393 if (*c
!= '\0' && *c
!= '!')
2396 /* We have an include line at this point. */
2398 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
2399 read by anything else. */
2401 filename
= gfc_widechar_to_char (begin
, -1);
2402 load_file (filename
, NULL
, false);
2407 /* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc.
2408 APIs. Return 1 if recognized as valid INCLUDE statement and load_file has
2409 been called, 0 if it is not a valid INCLUDE statement and -1 if eof has
2410 been encountered while parsing it. */
2412 include_stmt (gfc_linebuf
*b
)
2414 int ret
= 0, i
, length
;
2415 const char *include
= "include";
2416 gfc_char_t c
, quote
= 0;
2422 gcc_attribute_flag
= 0;
2427 gfc_current_locus
.lb
= b
;
2428 gfc_current_locus
.nextc
= b
->line
;
2430 gfc_skip_comments ();
2431 gfc_gobble_whitespace ();
2433 for (i
= 0; i
< 7; i
++)
2435 c
= gfc_next_char ();
2436 if (c
!= (unsigned char) include
[i
])
2438 if (gfc_current_form
== FORM_FIXED
2441 && gfc_current_locus
.nextc
== b
->line
+ 6)
2443 gfc_gobble_whitespace ();
2447 gcc_assert (i
!= 0);
2450 gfc_advance_line ();
2451 gfc_skip_comments ();
2458 gfc_gobble_whitespace ();
2460 c
= gfc_next_char ();
2461 if (c
== '\'' || c
== '"')
2467 gfc_advance_line ();
2468 gfc_skip_comments ();
2475 str_locus
= gfc_current_locus
;
2479 c
= gfc_next_char_literal (INSTRING_NOWARN
);
2484 gfc_advance_line ();
2485 gfc_skip_comments ();
2494 gfc_gobble_whitespace ();
2495 c
= gfc_next_char ();
2499 gfc_current_locus
= str_locus
;
2501 filename
= XNEWVEC (char, length
+ 1);
2502 for (i
= 0; i
< length
; i
++)
2504 c
= gfc_next_char_literal (INSTRING_WARN
);
2505 gcc_assert (gfc_wide_fits_in_byte (c
));
2506 filename
[i
] = (unsigned char) c
;
2508 filename
[length
] = '\0';
2509 load_file (filename
, NULL
, false);
2515 gcc_attribute_flag
= 0;
2520 memset (&gfc_current_locus
, '\0', sizeof (locus
));
2521 memset (&openmp_locus
, '\0', sizeof (locus
));
2522 memset (&openacc_locus
, '\0', sizeof (locus
));
2523 memset (&gcc_attribute_locus
, '\0', sizeof (locus
));
2529 /* Load a file into memory by calling load_line until the file ends. */
2532 load_file (const char *realfilename
, const char *displayedname
, bool initial
)
2535 gfc_linebuf
*b
, *include_b
= NULL
;
2542 const char *filename
;
2543 /* If realfilename and displayedname are different and non-null then
2544 surely realfilename is the preprocessed form of
2546 bool preprocessed_p
= (realfilename
&& displayedname
2547 && strcmp (realfilename
, displayedname
));
2549 filename
= displayedname
? displayedname
: realfilename
;
2551 for (f
= current_file
; f
; f
= f
->up
)
2552 if (filename_cmp (filename
, f
->filename
) == 0)
2553 fatal_error (linemap_line_start (line_table
, current_file
->line
, 0),
2554 "File %qs is being included recursively", filename
);
2559 input
= gfc_src_file
;
2560 gfc_src_file
= NULL
;
2563 input
= gfc_open_file (realfilename
);
2566 gfc_fatal_error ("Cannot open file %qs", filename
);
2570 input
= gfc_open_included_file (realfilename
, false, false);
2573 /* For -fpre-include file, current_file is NULL. */
2575 fatal_error (linemap_line_start (line_table
, current_file
->line
, 0),
2576 "Cannot open included file %qs", filename
);
2578 gfc_fatal_error ("Cannot open pre-included file %qs", filename
);
2580 stat_result
= stat (realfilename
, &st
);
2581 if (stat_result
== 0 && !S_ISREG (st
.st_mode
))
2585 fatal_error (linemap_line_start (line_table
, current_file
->line
, 0),
2586 "Included file %qs is not a regular file", filename
);
2588 gfc_fatal_error ("Included file %qs is not a regular file", filename
);
2594 A "non-initial" file means a file that is being included. In
2595 that case we are creating an LC_ENTER map.
2597 An "initial" file means a main file; one that is not included.
2598 That file has already got at least one (surely more) line map(s)
2599 created by gfc_init. So the subsequent map created in that case
2600 must have LC_RENAME reason.
2602 This latter case is not true for a preprocessed file. In that
2603 case, although the file is "initial", the line maps created by
2604 gfc_init was used during the preprocessing of the file. Now that
2605 the preprocessing is over and we are being fed the result of that
2606 preprocessing, we need to create a brand new line map for the
2607 preprocessed file, so the reason is going to be LC_ENTER. */
2609 f
= get_file (filename
, (initial
&& !preprocessed_p
) ? LC_RENAME
: LC_ENTER
);
2611 add_file_change (f
->filename
, f
->inclusion_line
);
2613 current_file
->line
= 1;
2618 if (initial
&& gfc_src_preprocessor_lines
[0])
2620 preprocessor_line (gfc_src_preprocessor_lines
[0]);
2621 free (gfc_src_preprocessor_lines
[0]);
2622 gfc_src_preprocessor_lines
[0] = NULL
;
2623 if (gfc_src_preprocessor_lines
[1])
2625 preprocessor_line (gfc_src_preprocessor_lines
[1]);
2626 free (gfc_src_preprocessor_lines
[1]);
2627 gfc_src_preprocessor_lines
[1] = NULL
;
2633 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
2636 len
= gfc_wide_strlen (line
);
2637 if (feof (input
) && len
== 0)
2640 /* If this is the first line of the file, it can contain a byte
2641 order mark (BOM), which we will ignore:
2642 FF FE is UTF-16 little endian,
2643 FE FF is UTF-16 big endian,
2644 EF BB BF is UTF-8. */
2646 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
2647 && line
[1] == (unsigned char) '\xFE')
2648 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
2649 && line
[1] == (unsigned char) '\xFF')
2650 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
2651 && line
[1] == (unsigned char) '\xBB'
2652 && line
[2] == (unsigned char) '\xBF')))
2654 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
2655 gfc_char_t
*new_char
= gfc_get_wide_string (line_len
);
2657 wide_strcpy (new_char
, &line
[n
]);
2663 /* There are three things this line can be: a line of Fortran
2664 source, an include line or a C preprocessor directive. */
2668 /* When -g3 is specified, it's possible that we emit #define
2669 and #undef lines, which we need to pass to the middle-end
2670 so that it can emit correct debug info. */
2671 if (debug_info_level
== DINFO_LEVEL_VERBOSE
2672 && (wide_strncmp (line
, "#define ", 8) == 0
2673 || wide_strncmp (line
, "#undef ", 7) == 0))
2677 preprocessor_line (line
);
2682 /* Preprocessed files have preprocessor lines added before the byte
2683 order mark, so first_line is not about the first line of the file
2684 but the first line that's not a preprocessor line. */
2687 inc_line
= include_line (line
);
2690 current_file
->line
++;
2696 b
= XCNEWVAR (gfc_linebuf
, gfc_linebuf_header_size
2697 + (len
+ 1) * sizeof (gfc_char_t
));
2701 = linemap_line_start (line_table
, current_file
->line
++, len
);
2702 /* ??? We add the location for the maximum column possible here,
2703 because otherwise if the next call creates a new line-map, it
2704 will not reserve space for any offset. */
2706 linemap_position_for_column (line_table
, len
);
2708 b
->file
= current_file
;
2709 b
->truncated
= trunc
;
2710 wide_strcpy (b
->line
, line
);
2712 if (line_head
== NULL
)
2715 line_tail
->next
= b
;
2719 while (file_changes_cur
< file_changes_count
)
2720 file_changes
[file_changes_cur
++].lb
= b
;
2722 if (flag_dec_include
)
2724 if (include_b
&& b
!= include_b
)
2726 int inc_line2
= include_stmt (include_b
);
2729 else if (inc_line2
> 0)
2733 if (gfc_current_form
== FORM_FIXED
)
2735 for (gfc_char_t
*p
= include_b
->line
; *p
; p
++)
2739 include_b
->line
[0] = '\0';
2742 include_b
= include_b
->next
;
2748 if (inc_line
== -1 && !include_b
)
2753 /* Release the line buffer allocated in load_line. */
2759 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
2760 current_file
= current_file
->up
;
2761 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
2765 /* Open a new file and start scanning from that file. Returns true
2766 if everything went OK, false otherwise. If form == FORM_UNKNOWN
2767 it tries to determine the source form from the filename, defaulting
2773 if (flag_pre_include
!= NULL
)
2774 load_file (flag_pre_include
, NULL
, false);
2776 if (gfc_cpp_enabled ())
2778 gfc_cpp_preprocess (gfc_source_file
);
2779 if (!gfc_cpp_preprocess_only ())
2780 load_file (gfc_cpp_temporary_file (), gfc_source_file
, true);
2783 load_file (gfc_source_file
, NULL
, true);
2785 gfc_current_locus
.lb
= line_head
;
2786 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
2788 #if 0 /* Debugging aid. */
2789 for (; line_head
; line_head
= line_head
->next
)
2790 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
2791 LOCATION_LINE (line_head
->location
), line_head
->line
);
2793 exit (SUCCESS_EXIT_CODE
);
2798 unescape_filename (const char *ptr
)
2800 const char *p
= ptr
, *s
;
2802 int escaped
, unescape
= 0;
2804 /* Make filename end at quote. */
2806 while (*p
&& ! (! escaped
&& *p
== '"'))
2810 else if (*p
== '\\')
2821 /* Undo effects of cpp_quote_string. */
2823 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
2838 /* For preprocessed files, if the first tokens are of the form # NUM.
2839 handle the directives so we know the original file name. */
2842 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
2845 char *dirname
, *tmp
;
2847 gfc_src_file
= gfc_open_file (filename
);
2848 if (gfc_src_file
== NULL
)
2851 c
= getc (gfc_src_file
);
2857 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2859 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2862 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2863 filename
= unescape_filename (tmp
);
2865 if (filename
== NULL
)
2868 c
= getc (gfc_src_file
);
2874 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2876 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2879 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2880 dirname
= unescape_filename (tmp
);
2882 if (dirname
== NULL
)
2885 len
= strlen (dirname
);
2886 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2891 dirname
[len
- 2] = '\0';
2892 set_src_pwd (dirname
);
2894 if (! IS_ABSOLUTE_PATH (filename
))
2896 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2898 memcpy (p
, dirname
, len
- 2);
2900 strcpy (p
+ len
- 1, filename
);
2901 *canon_source_file
= p
;