2 Copyright (C) 2000-2022 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 int 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
= XCNEWVEC (char, strlen (p
) + 2);
413 strcpy (dir
->path
, p
);
414 strcat (dir
->path
, "/"); /* make '/' last character */
417 /* defer_warn is set to true while parsing the commandline. */
420 gfc_add_include_path (const char *path
, bool use_for_modules
, bool file_dir
,
421 bool warn
, bool defer_warn
)
423 add_path_to_list (&include_dirs
, path
, use_for_modules
, file_dir
, warn
,
426 /* For '#include "..."' these directories are automatically searched. */
428 gfc_cpp_add_include_path (xstrdup(path
), true);
433 gfc_add_intrinsic_modules_path (const char *path
)
435 add_path_to_list (&intrinsic_modules_dirs
, path
, true, false, false, false);
439 /* Release resources allocated for options. */
442 gfc_release_include_path (void)
444 gfc_directorylist
*p
;
446 while (include_dirs
!= NULL
)
449 include_dirs
= include_dirs
->next
;
454 while (intrinsic_modules_dirs
!= NULL
)
456 p
= intrinsic_modules_dirs
;
457 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
462 free (gfc_option
.module_dir
);
467 open_included_file (const char *name
, gfc_directorylist
*list
,
468 bool module
, bool system
)
471 gfc_directorylist
*p
;
474 for (p
= list
; p
; p
= p
->next
)
476 if (module
&& !p
->use_for_modules
)
479 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
480 strcpy (fullname
, p
->path
);
481 strcat (fullname
, name
);
483 f
= gfc_open_file (fullname
);
486 if (gfc_cpp_makedep ())
487 gfc_cpp_add_dep (fullname
, system
);
497 /* Opens file for reading, searching through the include directories
498 given if necessary. If the include_cwd argument is true, we try
499 to open the file in the current directory first. */
502 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
506 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
508 f
= gfc_open_file (name
);
509 if (f
&& gfc_cpp_makedep ())
510 gfc_cpp_add_dep (name
, false);
514 f
= open_included_file (name
, include_dirs
, module
, false);
520 /* Test to see if we're at the end of the main source file. */
529 /* Test to see if we're at the end of the current file. */
537 if (line_head
== NULL
)
538 return 1; /* Null file */
540 if (gfc_current_locus
.lb
== NULL
)
547 /* Test to see if we're at the beginning of a new line. */
555 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
559 /* Test to see if we're at the end of a line. */
567 return (*gfc_current_locus
.nextc
== '\0');
571 add_file_change (const char *filename
, int line
)
573 if (file_changes_count
== file_changes_allocated
)
575 if (file_changes_allocated
)
576 file_changes_allocated
*= 2;
578 file_changes_allocated
= 16;
579 file_changes
= XRESIZEVEC (struct gfc_file_change
, file_changes
,
580 file_changes_allocated
);
582 file_changes
[file_changes_count
].filename
= filename
;
583 file_changes
[file_changes_count
].lb
= NULL
;
584 file_changes
[file_changes_count
++].line
= line
;
588 report_file_change (gfc_linebuf
*lb
)
590 size_t c
= file_changes_cur
;
591 while (c
< file_changes_count
592 && file_changes
[c
].lb
== lb
)
594 if (file_changes
[c
].filename
)
595 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
596 file_changes
[c
].filename
);
598 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
601 file_changes_cur
= c
;
605 gfc_start_source_files (void)
607 /* If the debugger wants the name of the main source file,
609 if (debug_hooks
->start_end_main_source_file
)
610 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
612 file_changes_cur
= 0;
613 report_file_change (gfc_current_locus
.lb
);
617 gfc_end_source_files (void)
619 report_file_change (NULL
);
621 if (debug_hooks
->start_end_main_source_file
)
622 (*debug_hooks
->end_source_file
) (0);
625 /* Advance the current line pointer to the next line. */
628 gfc_advance_line (void)
633 if (gfc_current_locus
.lb
== NULL
)
639 if (gfc_current_locus
.lb
->next
640 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
642 report_file_change (gfc_current_locus
.lb
->next
);
643 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
646 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
648 if (gfc_current_locus
.lb
!= NULL
)
649 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
652 gfc_current_locus
.nextc
= NULL
;
658 /* Get the next character from the input, advancing gfc_current_file's
659 locus. When we hit the end of the line or the end of the file, we
660 start returning a '\n' in order to complete the current statement.
661 No Fortran line conventions are implemented here.
663 Requiring explicit advances to the next line prevents the parse
664 pointer from being on the wrong line if the current statement ends
672 if (gfc_current_locus
.nextc
== NULL
)
675 c
= *gfc_current_locus
.nextc
++;
678 gfc_current_locus
.nextc
--; /* Remain on this line. */
686 /* Skip a comment. When we come here the parse pointer is positioned
687 immediately after the comment character. If we ever implement
688 compiler directives within comments, here is where we parse the
692 skip_comment_line (void)
707 gfc_define_undef_line (void)
711 /* All lines beginning with '#' are either #define or #undef. */
712 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
715 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
717 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
718 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
723 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
725 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
726 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
731 /* Skip the rest of the line. */
732 skip_comment_line ();
738 /* Return true if GCC$ was matched. */
740 skip_gcc_attribute (locus start
)
744 locus old_loc
= gfc_current_locus
;
746 if ((c
= next_char ()) == 'g' || c
== 'G')
747 if ((c
= next_char ()) == 'c' || c
== 'C')
748 if ((c
= next_char ()) == 'c' || c
== 'C')
749 if ((c
= next_char ()) == '$')
753 gfc_current_locus
= old_loc
;
756 gcc_attribute_flag
= 1;
757 gcc_attribute_locus
= old_loc
;
758 gfc_current_locus
= start
;
764 /* Return true if CC was matched. */
766 skip_free_oacc_sentinel (locus start
, locus old_loc
)
771 if ((c
= next_char ()) == 'c' || c
== 'C')
772 if ((c
= next_char ()) == 'c' || c
== 'C')
777 if ((c
= next_char ()) == ' ' || c
== '\t'
780 while (gfc_is_whitespace (c
))
782 if (c
!= '\n' && c
!= '!')
785 openacc_locus
= old_loc
;
786 gfc_current_locus
= start
;
793 gfc_warning_now (0, "!$ACC at %C starts a commented "
794 "line as it neither is followed "
795 "by a space nor is a "
796 "continuation line");
804 /* Return true if MP was matched. */
806 skip_free_omp_sentinel (locus start
, locus old_loc
)
811 if ((c
= next_char ()) == 'm' || c
== 'M')
812 if ((c
= next_char ()) == 'p' || c
== 'P')
817 if ((c
= next_char ()) == ' ' || c
== '\t'
820 while (gfc_is_whitespace (c
))
822 if (c
!= '\n' && c
!= '!')
825 openmp_locus
= old_loc
;
826 gfc_current_locus
= start
;
833 gfc_warning_now (0, "!$OMP at %C starts a commented "
834 "line as it neither is followed "
835 "by a space nor is a "
836 "continuation line");
844 /* Comment lines are null lines, lines containing only blanks or lines
845 on which the first nonblank line is a '!'.
846 Return true if !$ openmp or openacc conditional compilation sentinel was
850 skip_free_comments (void)
858 at_bol
= gfc_at_bol ();
859 start
= gfc_current_locus
;
865 while (gfc_is_whitespace (c
));
875 /* Keep the !GCC$ line. */
876 if (at_bol
&& skip_gcc_attribute (start
))
879 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
880 1) don't treat !$omp/!$acc as comments, but directives
881 2) handle OpenMP/OpenACC conditional compilation, where
882 !$ should be treated as 2 spaces (for initial lines
883 only if followed by space). */
886 if ((flag_openmp
|| flag_openmp_simd
)
889 locus old_loc
= gfc_current_locus
;
890 if (next_char () == '$')
893 if (c
== 'o' || c
== 'O')
895 if (skip_free_omp_sentinel (start
, old_loc
))
897 gfc_current_locus
= old_loc
;
901 else if (c
== 'a' || c
== 'A')
903 if (skip_free_oacc_sentinel (start
, old_loc
))
905 gfc_current_locus
= old_loc
;
909 if (continue_flag
|| c
== ' ' || c
== '\t')
911 gfc_current_locus
= old_loc
;
913 openmp_flag
= openacc_flag
= 0;
917 gfc_current_locus
= old_loc
;
919 else if ((flag_openmp
|| flag_openmp_simd
)
922 locus old_loc
= gfc_current_locus
;
923 if (next_char () == '$')
926 if (c
== 'o' || c
== 'O')
928 if (skip_free_omp_sentinel (start
, old_loc
))
930 gfc_current_locus
= old_loc
;
934 if (continue_flag
|| c
== ' ' || c
== '\t')
936 gfc_current_locus
= old_loc
;
942 gfc_current_locus
= old_loc
;
944 else if (flag_openacc
945 && !(flag_openmp
|| flag_openmp_simd
))
947 locus old_loc
= gfc_current_locus
;
948 if (next_char () == '$')
951 if (c
== 'a' || c
== 'A')
953 if (skip_free_oacc_sentinel (start
, old_loc
))
955 gfc_current_locus
= old_loc
;
960 gfc_current_locus
= old_loc
;
963 skip_comment_line ();
970 if (openmp_flag
&& at_bol
)
973 if (openacc_flag
&& at_bol
)
976 gcc_attribute_flag
= 0;
977 gfc_current_locus
= start
;
981 /* Return true if MP was matched in fixed form. */
983 skip_fixed_omp_sentinel (locus
*start
)
986 if (((c
= next_char ()) == 'm' || c
== 'M')
987 && ((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
;
1012 /* Return true if CC was matched in fixed form. */
1014 skip_fixed_oacc_sentinel (locus
*start
)
1017 if (((c
= next_char ()) == 'c' || c
== 'C')
1018 && ((c
= next_char ()) == 'c' || c
== 'C'))
1023 || c
== ' ' || c
== '\t' || c
== '0'))
1025 if (c
== ' ' || c
== '\t' || c
== '0')
1029 while (gfc_is_whitespace (c
));
1030 if (c
!= '\n' && c
!= '!')
1032 /* Canonicalize to *$acc. */
1033 *start
->nextc
= '*';
1035 gfc_current_locus
= *start
;
1043 /* Skip comment lines in fixed source mode. We have the same rules as
1044 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
1045 in column 1, and a '!' cannot be in column 6. Also, we deal with
1046 lines with 'd' or 'D' in column 1, if the user requested this. */
1049 skip_fixed_comments (void)
1055 if (! gfc_at_bol ())
1057 start
= gfc_current_locus
;
1058 if (! gfc_at_eof ())
1062 while (gfc_is_whitespace (c
));
1065 gfc_advance_line ();
1067 skip_comment_line ();
1070 if (! gfc_at_bol ())
1072 gfc_current_locus
= start
;
1079 start
= gfc_current_locus
;
1086 gfc_advance_line ();
1090 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
1092 if (skip_gcc_attribute (start
))
1094 /* Canonicalize to *$omp. */
1099 if (gfc_current_locus
.lb
!= NULL
1100 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1101 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1103 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
1104 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
1106 2) handle OpenMP/OpenACC conditional compilation, where
1107 !$|c$|*$ should be treated as 2 spaces if the characters
1108 in columns 3 to 6 are valid fixed form label columns
1110 if ((flag_openmp
|| flag_openmp_simd
) && !flag_openacc
)
1112 if (next_char () == '$')
1115 if (c
== 'o' || c
== 'O')
1117 if (skip_fixed_omp_sentinel (&start
))
1121 goto check_for_digits
;
1123 gfc_current_locus
= start
;
1125 else if (flag_openacc
&& !(flag_openmp
|| flag_openmp_simd
))
1127 if (next_char () == '$')
1130 if (c
== 'a' || c
== 'A')
1132 if (skip_fixed_oacc_sentinel (&start
))
1136 gfc_current_locus
= start
;
1138 else if (flag_openacc
|| flag_openmp
|| flag_openmp_simd
)
1140 if (next_char () == '$')
1143 if (c
== 'a' || c
== 'A')
1145 if (skip_fixed_oacc_sentinel (&start
))
1148 else if (c
== 'o' || c
== 'O')
1150 if (skip_fixed_omp_sentinel (&start
))
1154 goto check_for_digits
;
1156 gfc_current_locus
= start
;
1159 skip_comment_line ();
1164 /* Required for OpenMP's conditional compilation sentinel. */
1167 for (col
= 3; col
< 6; col
++, c
= next_char ())
1175 else if (c
< '0' || c
> '9')
1180 if (col
== 6 && c
!= '\n'
1181 && ((continue_flag
&& !digit_seen
)
1182 || c
== ' ' || c
== '\t' || c
== '0'))
1184 gfc_current_locus
= start
;
1185 start
.nextc
[0] = ' ';
1186 start
.nextc
[1] = ' ';
1190 skip_comment_line ();
1194 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
1196 if (gfc_option
.flag_d_lines
== 0)
1198 skip_comment_line ();
1202 *start
.nextc
= c
= ' ';
1207 while (gfc_is_whitespace (c
))
1215 gfc_advance_line ();
1219 if (col
!= 6 && c
== '!')
1221 if (gfc_current_locus
.lb
!= NULL
1222 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1223 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1224 skip_comment_line ();
1233 gcc_attribute_flag
= 0;
1234 gfc_current_locus
= start
;
1238 /* Skips the current line if it is a comment. */
1241 gfc_skip_comments (void)
1243 if (gfc_current_form
== FORM_FREE
)
1244 skip_free_comments ();
1246 skip_fixed_comments ();
1250 /* Get the next character from the input, taking continuation lines
1251 and end-of-line comments into account. This implies that comment
1252 lines between continued lines must be eaten here. For higher-level
1253 subroutines, this flattens continued lines into a single logical
1254 line. The in_string flag denotes whether we're inside a character
1258 gfc_next_char_literal (gfc_instring in_string
)
1260 static locus omp_acc_err_loc
= {};
1262 int i
, prev_openmp_flag
, prev_openacc_flag
;
1266 prev_openacc_flag
= prev_openmp_flag
= 0;
1276 if (gfc_current_form
== FORM_FREE
)
1278 bool openmp_cond_flag
;
1280 if (!in_string
&& c
== '!')
1282 if (gcc_attribute_flag
1283 && memcmp (&gfc_current_locus
, &gcc_attribute_locus
,
1284 sizeof (gfc_current_locus
)) == 0)
1288 && memcmp (&gfc_current_locus
, &openmp_locus
,
1289 sizeof (gfc_current_locus
)) == 0)
1293 && memcmp (&gfc_current_locus
, &openacc_locus
,
1294 sizeof (gfc_current_locus
)) == 0)
1297 /* This line can't be continued */
1304 /* Avoid truncation warnings for comment ending lines. */
1305 gfc_current_locus
.lb
->truncated
= 0;
1310 /* Check to see if the continuation line was truncated. */
1311 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1312 && gfc_current_locus
.lb
->truncated
)
1314 int maxlen
= flag_free_line_length
;
1315 gfc_char_t
*current_nextc
= gfc_current_locus
.nextc
;
1317 gfc_current_locus
.lb
->truncated
= 0;
1318 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
+ maxlen
;
1319 gfc_warning_now (OPT_Wline_truncation
,
1320 "Line truncated at %L", &gfc_current_locus
);
1321 gfc_current_locus
.nextc
= current_nextc
;
1327 /* If the next nonblank character is a ! or \n, we've got a
1328 continuation line. */
1329 old_loc
= gfc_current_locus
;
1332 while (gfc_is_whitespace (c
))
1335 /* Character constants to be continued cannot have commentary
1336 after the '&'. However, there are cases where we may think we
1337 are still in a string and we are looking for a possible
1338 doubled quote and we end up here. See PR64506. */
1340 if (in_string
&& c
!= '\n')
1342 gfc_current_locus
= old_loc
;
1347 if (c
!= '!' && c
!= '\n')
1349 gfc_current_locus
= old_loc
;
1355 prev_openmp_flag
= openmp_flag
;
1357 prev_openacc_flag
= openacc_flag
;
1359 /* This can happen if the input file changed or via cpp's #line
1360 without getting reset (e.g. via input_stmt). It also happens
1361 when pre-including files via -fpre-include=. */
1362 if (continue_count
== 0
1363 && gfc_current_locus
.lb
1364 && continue_line
> gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1)
1365 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1;
1369 skip_comment_line ();
1371 gfc_advance_line ();
1374 goto not_continuation
;
1376 /* We've got a continuation line. If we are on the very next line after
1377 the last continuation, increment the continuation line count and
1378 check whether the limit has been exceeded. */
1379 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1381 if (++continue_count
== gfc_option
.max_continue_free
)
1383 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1384 gfc_warning (0, "Limit of %d continuations exceeded in "
1385 "statement at %C", gfc_option
.max_continue_free
);
1389 /* Now find where it continues. First eat any comment lines. */
1390 openmp_cond_flag
= skip_free_comments ();
1392 if (gfc_current_locus
.lb
!= NULL
1393 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1394 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1397 if (prev_openmp_flag
!= openmp_flag
&& !openacc_flag
)
1399 gfc_current_locus
= old_loc
;
1400 openmp_flag
= prev_openmp_flag
;
1406 if (prev_openacc_flag
!= openacc_flag
&& !openmp_flag
)
1408 gfc_current_locus
= old_loc
;
1409 openacc_flag
= prev_openacc_flag
;
1414 /* Now that we have a non-comment line, probe ahead for the
1415 first non-whitespace character. If it is another '&', then
1416 reading starts at the next character, otherwise we must back
1417 up to where the whitespace started and resume from there. */
1419 old_loc
= gfc_current_locus
;
1422 while (gfc_is_whitespace (c
))
1425 if (openmp_flag
&& !openacc_flag
)
1427 for (i
= 0; i
< 5; i
++, c
= next_char ())
1429 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1431 old_loc
= gfc_current_locus
;
1433 while (gfc_is_whitespace (c
))
1436 if (openacc_flag
&& !openmp_flag
)
1438 for (i
= 0; i
< 5; i
++, c
= next_char ())
1440 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$acc"[i
]);
1442 old_loc
= gfc_current_locus
;
1444 while (gfc_is_whitespace (c
))
1448 /* In case we have an OpenMP directive continued by OpenACC
1449 sentinel, or vice versa, we get both openmp_flag and
1452 if (openacc_flag
&& openmp_flag
)
1455 for (i
= 0; i
< 5; i
++, c
= next_char ())
1457 if (gfc_wide_tolower (c
) != (unsigned char) "!$acc"[i
])
1460 if (omp_acc_err_loc
.nextc
!= gfc_current_locus
.nextc
1461 || omp_acc_err_loc
.lb
!= gfc_current_locus
.lb
)
1462 gfc_error_now (is_openmp
1463 ? G_("Wrong OpenACC continuation at %C: "
1464 "expected !$ACC, got !$OMP")
1465 : G_("Wrong OpenMP continuation at %C: "
1466 "expected !$OMP, got !$ACC"));
1467 omp_acc_err_loc
= gfc_current_locus
;
1468 goto not_continuation
;
1473 if (in_string
&& gfc_current_locus
.nextc
)
1475 gfc_current_locus
.nextc
--;
1476 if (warn_ampersand
&& in_string
== INSTRING_WARN
)
1477 gfc_warning (OPT_Wampersand
,
1478 "Missing %<&%> in continued character "
1481 else if (!in_string
&& (c
== '\'' || c
== '"'))
1483 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1484 continuation line only optionally. */
1485 else if (openmp_flag
|| openacc_flag
|| openmp_cond_flag
)
1487 if (gfc_current_locus
.nextc
)
1488 gfc_current_locus
.nextc
--;
1493 gfc_current_locus
= old_loc
;
1498 else /* Fixed form. */
1500 /* Fixed form continuation. */
1501 if (in_string
!= INSTRING_WARN
&& c
== '!')
1503 /* Skip comment at end of line. */
1510 /* Avoid truncation warnings for comment ending lines. */
1511 gfc_current_locus
.lb
->truncated
= 0;
1517 /* Check to see if the continuation line was truncated. */
1518 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1519 && gfc_current_locus
.lb
->truncated
)
1521 gfc_current_locus
.lb
->truncated
= 0;
1522 gfc_warning_now (OPT_Wline_truncation
,
1523 "Line truncated at %L", &gfc_current_locus
);
1527 prev_openmp_flag
= openmp_flag
;
1529 prev_openacc_flag
= openacc_flag
;
1531 /* This can happen if the input file changed or via cpp's #line
1532 without getting reset (e.g. via input_stmt). It also happens
1533 when pre-including files via -fpre-include=. */
1534 if (continue_count
== 0
1535 && gfc_current_locus
.lb
1536 && continue_line
> gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1)
1537 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1;
1540 old_loc
= gfc_current_locus
;
1542 gfc_advance_line ();
1543 skip_fixed_comments ();
1545 /* See if this line is a continuation line. */
1546 if (flag_openmp
&& openmp_flag
!= prev_openmp_flag
&& !openacc_flag
)
1548 openmp_flag
= prev_openmp_flag
;
1549 goto not_continuation
;
1551 if (flag_openacc
&& openacc_flag
!= prev_openacc_flag
&& !openmp_flag
)
1553 openacc_flag
= prev_openacc_flag
;
1554 goto not_continuation
;
1557 /* In case we have an OpenMP directive continued by OpenACC
1558 sentinel, or vice versa, we get both openmp_flag and
1560 if (openacc_flag
&& openmp_flag
)
1563 for (i
= 0; i
< 5; i
++)
1566 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1569 if (omp_acc_err_loc
.nextc
!= gfc_current_locus
.nextc
1570 || omp_acc_err_loc
.lb
!= gfc_current_locus
.lb
)
1571 gfc_error_now (is_openmp
1572 ? G_("Wrong OpenACC continuation at %C: "
1573 "expected !$ACC, got !$OMP")
1574 : G_("Wrong OpenMP continuation at %C: "
1575 "expected !$OMP, got !$ACC"));
1576 omp_acc_err_loc
= gfc_current_locus
;
1577 goto not_continuation
;
1579 else if (!openmp_flag
&& !openacc_flag
)
1580 for (i
= 0; i
< 5; i
++)
1584 goto not_continuation
;
1586 else if (openmp_flag
)
1587 for (i
= 0; i
< 5; i
++)
1590 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1591 goto not_continuation
;
1593 else if (openacc_flag
)
1594 for (i
= 0; i
< 5; i
++)
1597 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1598 goto not_continuation
;
1602 if (c
== '0' || c
== ' ' || c
== '\n')
1603 goto not_continuation
;
1605 /* We've got a continuation line. If we are on the very next line after
1606 the last continuation, increment the continuation line count and
1607 check whether the limit has been exceeded. */
1608 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1610 if (++continue_count
== gfc_option
.max_continue_fixed
)
1612 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1613 gfc_warning (0, "Limit of %d continuations exceeded in "
1615 gfc_option
.max_continue_fixed
);
1619 if (gfc_current_locus
.lb
!= NULL
1620 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1621 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1624 /* Ready to read first character of continuation line, which might
1625 be another continuation line! */
1630 gfc_current_locus
= old_loc
;
1641 /* Get the next character of input, folded to lowercase. In fixed
1642 form mode, we also ignore spaces. When matcher subroutines are
1643 parsing character literals, they have to call
1644 gfc_next_char_literal(). */
1647 gfc_next_char (void)
1653 c
= gfc_next_char_literal (NONSTRING
);
1655 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1657 return gfc_wide_tolower (c
);
1661 gfc_next_ascii_char (void)
1663 gfc_char_t c
= gfc_next_char ();
1665 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1666 : (unsigned char) UCHAR_MAX
);
1671 gfc_peek_char (void)
1676 old_loc
= gfc_current_locus
;
1677 c
= gfc_next_char ();
1678 gfc_current_locus
= old_loc
;
1685 gfc_peek_ascii_char (void)
1687 gfc_char_t c
= gfc_peek_char ();
1689 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1690 : (unsigned char) UCHAR_MAX
);
1694 /* Recover from an error. We try to get past the current statement
1695 and get lined up for the next. The next statement follows a '\n'
1696 or a ';'. We also assume that we are not within a character
1697 constant, and deal with finding a '\'' or '"'. */
1700 gfc_error_recovery (void)
1702 gfc_char_t c
, delim
;
1709 c
= gfc_next_char ();
1710 if (c
== '\n' || c
== ';')
1713 if (c
!= '\'' && c
!= '"')
1742 /* Read ahead until the next character to be read is not whitespace. */
1745 gfc_gobble_whitespace (void)
1747 static int linenum
= 0;
1753 old_loc
= gfc_current_locus
;
1754 c
= gfc_next_char_literal (NONSTRING
);
1755 /* Issue a warning for nonconforming tabs. We keep track of the line
1756 number because the Fortran matchers will often back up and the same
1757 line will be scanned multiple times. */
1758 if (warn_tabs
&& c
== '\t')
1760 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1761 if (cur_linenum
!= linenum
)
1763 linenum
= cur_linenum
;
1764 gfc_warning_now (OPT_Wtabs
, "Nonconforming tab character at %C");
1768 while (gfc_is_whitespace (c
));
1770 if (!ISPRINT(c
) && c
!= '\n' && last_error_char
!= gfc_current_locus
.nextc
)
1773 last_error_char
= gfc_current_locus
.nextc
;
1774 snprintf (buf
, 20, "%2.2X", c
);
1775 gfc_error_now ("Invalid character 0x%s at %C", buf
);
1778 gfc_current_locus
= old_loc
;
1782 /* Load a single line into pbuf.
1784 If pbuf points to a NULL pointer, it is allocated.
1785 We truncate lines that are too long, unless we're dealing with
1786 preprocessor lines or if the option -ffixed-line-length-none is set,
1787 in which case we reallocate the buffer to fit the entire line, if
1789 In fixed mode, we expand a tab that occurs within the statement
1790 label region to expand to spaces that leave the next character in
1793 If first_char is not NULL, it's a pointer to a single char value holding
1794 the first character of the line, which has already been read by the
1795 caller. This avoids the use of ungetc().
1797 load_line returns whether the line was truncated.
1799 NOTE: The error machinery isn't available at this point, so we can't
1800 easily report line and column numbers consistent with other
1801 parts of gfortran. */
1804 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1806 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1807 int quoted
= ' ', comment_ix
= -1;
1808 bool seen_comment
= false;
1809 bool first_comment
= true;
1810 bool trunc_flag
= false;
1811 bool seen_printable
= false;
1812 bool seen_ampersand
= false;
1813 bool found_tab
= false;
1814 bool warned_tabs
= false;
1817 /* Determine the maximum allowed line length. */
1818 if (gfc_current_form
== FORM_FREE
)
1819 maxlen
= flag_free_line_length
;
1820 else if (gfc_current_form
== FORM_FIXED
)
1821 maxlen
= flag_fixed_line_length
;
1827 /* Allocate the line buffer, storing its length into buflen.
1828 Note that if maxlen==0, indicating that arbitrary-length lines
1829 are allowed, the buffer will be reallocated if this length is
1830 insufficient; since 132 characters is the length of a standard
1831 free-form line, we use that as a starting guess. */
1837 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1848 /* In order to not truncate preprocessor lines, we have to
1849 remember that this is one. */
1850 preprocessor_flag
= (c
== '#');
1859 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1860 if (gfc_current_form
== FORM_FREE
1861 && !seen_printable
&& seen_ampersand
)
1864 gfc_error_now ("%<&%> not allowed by itself in line %d",
1865 current_file
->line
);
1867 gfc_warning_now (0, "%<&%> not allowed by itself in line %d",
1868 current_file
->line
);
1873 if (c
== '\r' || c
== '\0')
1874 goto next_char
; /* Gobble characters. */
1880 seen_ampersand
= false;
1881 seen_printable
= true;
1884 seen_ampersand
= true;
1887 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1888 seen_printable
= true;
1890 /* Is this a fixed-form comment? */
1891 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1892 && (c
== '*' || c
== 'c' || c
== 'C'
1893 || (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))))
1895 seen_comment
= true;
1901 if (c
== '\'' || c
== '"')
1904 else if (c
== quoted
)
1907 /* Is this a free-form comment? */
1908 if (c
== '!' && quoted
== ' ')
1911 first_comment
= false;
1912 seen_comment
= true;
1916 /* For truncation and tab warnings, set seen_comment to false if one has
1917 either an OpenMP or OpenACC directive - or a !GCC$ attribute. If
1918 OpenMP is enabled, use '!$' as as conditional compilation sentinel
1919 and OpenMP directive ('!$omp'). */
1920 if (seen_comment
&& first_comment
&& flag_openmp
&& comment_ix
+ 1 == i
1922 first_comment
= seen_comment
= false;
1923 if (seen_comment
&& first_comment
&& comment_ix
+ 4 == i
)
1925 if (((*pbuf
)[comment_ix
+1] == 'g' || (*pbuf
)[comment_ix
+1] == 'G')
1926 && ((*pbuf
)[comment_ix
+2] == 'c' || (*pbuf
)[comment_ix
+2] == 'C')
1927 && ((*pbuf
)[comment_ix
+3] == 'c' || (*pbuf
)[comment_ix
+3] == 'C')
1929 first_comment
= seen_comment
= false;
1931 && (*pbuf
)[comment_ix
+1] == '$'
1932 && ((*pbuf
)[comment_ix
+2] == 'a' || (*pbuf
)[comment_ix
+2] == 'A')
1933 && ((*pbuf
)[comment_ix
+3] == 'c' || (*pbuf
)[comment_ix
+3] == 'C')
1934 && (c
== 'c' || c
== 'C'))
1935 first_comment
= seen_comment
= false;
1938 /* Vendor extension: "<tab>1" marks a continuation line. */
1942 if (c
>= '1' && c
<= '9')
1949 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1953 if (warn_tabs
&& seen_comment
== 0 && !warned_tabs
)
1956 gfc_warning_now (OPT_Wtabs
,
1957 "Nonconforming tab character in column %d "
1958 "of line %d", i
+ 1, current_file
->line
);
1973 if (maxlen
== 0 || preprocessor_flag
)
1977 /* Reallocate line buffer to double size to hold the
1979 buflen
= buflen
* 2;
1980 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1981 buffer
= (*pbuf
) + i
;
1984 else if (i
>= maxlen
)
1986 bool trunc_warn
= true;
1988 /* Enhancement, if the very next non-space character is an ampersand
1989 or comment that we would otherwise warn about, don't mark as
1992 /* Truncate the rest of the line. */
1996 if (c
== '\r' || c
== ' ')
1999 if (c
== '\n' || c
== EOF
)
2002 if (!trunc_warn
&& c
!= '!')
2005 if (trunc_warn
&& ((gfc_current_form
== FORM_FIXED
&& c
== '&')
2012 if (trunc_warn
&& !seen_comment
)
2024 /* Pad lines to the selected line length in fixed form. */
2025 if (gfc_current_form
== FORM_FIXED
2026 && flag_fixed_line_length
!= 0
2028 && !preprocessor_flag
2031 while (i
++ < maxlen
)
2042 /* Get a gfc_file structure, initialize it and add it to
2046 get_file (const char *name
, enum lc_reason reason
)
2050 f
= XCNEW (gfc_file
);
2052 f
->filename
= xstrdup (name
);
2054 f
->next
= file_head
;
2057 f
->up
= current_file
;
2058 if (current_file
!= NULL
)
2059 f
->inclusion_line
= current_file
->line
;
2061 linemap_add (line_table
, reason
, false, f
->filename
, 1);
2067 /* Deal with a line from the C preprocessor. The
2068 initial octothorp has already been seen. */
2071 preprocessor_line (gfc_char_t
*c
)
2075 gfc_char_t
*wide_filename
;
2077 int escaped
, unescape
;
2081 while (*c
== ' ' || *c
== '\t')
2084 if (*c
< '0' || *c
> '9')
2087 line
= wide_atoi (c
);
2089 c
= wide_strchr (c
, ' ');
2092 /* No file name given. Set new line number. */
2093 current_file
->line
= line
;
2098 while (*c
== ' ' || *c
== '\t')
2108 /* Make filename end at quote. */
2111 while (*c
&& ! (!escaped
&& *c
== '"'))
2115 else if (*c
== '\\')
2124 /* Preprocessor line has no closing quote. */
2129 /* Undo effects of cpp_quote_string. */
2132 gfc_char_t
*s
= wide_filename
;
2133 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
2149 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
2153 c
= wide_strchr (c
, ' ');
2160 if (i
>= 1 && i
<= 4)
2164 /* Convert the filename in wide characters into a filename in narrow
2166 filename
= gfc_widechar_to_char (wide_filename
, -1);
2168 /* Interpret flags. */
2170 if (flag
[1]) /* Starting new file. */
2172 f
= get_file (filename
, LC_RENAME
);
2173 add_file_change (f
->filename
, f
->inclusion_line
);
2177 if (flag
[2]) /* Ending current file. */
2179 if (!current_file
->up
2180 || filename_cmp (current_file
->up
->filename
, filename
) != 0)
2182 linemap_line_start (line_table
, current_file
->line
, 80);
2183 /* ??? One could compute the exact column where the filename
2184 starts and compute the exact location here. */
2185 gfc_warning_now_at (linemap_position_for_column (line_table
, 1),
2186 0, "file %qs left but not entered",
2188 current_file
->line
++;
2190 free (wide_filename
);
2195 add_file_change (NULL
, line
);
2196 current_file
= current_file
->up
;
2197 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
2198 current_file
->line
);
2201 /* The name of the file can be a temporary file produced by
2202 cpp. Replace the name if it is different. */
2204 if (filename_cmp (current_file
->filename
, filename
) != 0)
2206 /* FIXME: we leak the old filename because a pointer to it may be stored
2207 in the linemap. Alternative could be using GC or updating linemap to
2208 point to the new name, but there is no API for that currently. */
2209 current_file
->filename
= xstrdup (filename
);
2211 /* We need to tell the linemap API that the filename changed. Just
2212 changing current_file is insufficient. */
2213 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
, line
);
2216 /* Set new line number. */
2217 current_file
->line
= line
;
2219 free (wide_filename
);
2224 linemap_line_start (line_table
, current_file
->line
, 80);
2225 /* ??? One could compute the exact column where the directive
2226 starts and compute the exact location here. */
2227 gfc_warning_now_at (linemap_position_for_column (line_table
, 2), 0,
2228 "Illegal preprocessor directive");
2229 current_file
->line
++;
2233 static void load_file (const char *, const char *, bool);
2235 /* include_line()-- Checks a line buffer to see if it is an include
2236 line. If so, we call load_file() recursively to load the included
2237 file. We never return a syntax error because a statement like
2238 "include = 5" is perfectly legal. We return 0 if no include was
2239 processed, 1 if we matched an include or -1 if include was
2240 partially processed, but will need continuation lines. */
2243 include_line (gfc_char_t
*line
)
2245 gfc_char_t quote
, *c
, *begin
, *stop
;
2247 const char *include
= "include";
2248 bool allow_continuation
= flag_dec_include
;
2253 if (flag_openmp
|| flag_openmp_simd
)
2255 if (gfc_current_form
== FORM_FREE
)
2257 while (*c
== ' ' || *c
== '\t')
2259 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
2264 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
2265 && c
[1] == '$' && c
[2] == ' ')
2270 if (gfc_current_form
== FORM_FREE
)
2272 while (*c
== ' ' || *c
== '\t')
2274 if (gfc_wide_strncasecmp (c
, "include", 7))
2276 if (!allow_continuation
)
2278 for (i
= 0; i
< 7; ++i
)
2280 gfc_char_t c1
= gfc_wide_tolower (*c
);
2281 if (c1
!= (unsigned char) include
[i
])
2285 if (i
== 0 || *c
!= '&')
2288 while (*c
== ' ' || *c
== '\t')
2290 if (*c
== '\0' || *c
== '!')
2299 while (*c
== ' ' || *c
== '\t')
2301 if (flag_dec_include
&& *c
== '0' && c
- line
== 5)
2304 while (*c
== ' ' || *c
== '\t')
2308 allow_continuation
= false;
2309 for (i
= 0; i
< 7; ++i
)
2311 gfc_char_t c1
= gfc_wide_tolower (*c
);
2312 if (c1
!= (unsigned char) include
[i
])
2315 while (*c
== ' ' || *c
== '\t')
2318 if (!allow_continuation
)
2328 /* At the end of line or comment this might be continued. */
2329 if (*c
== '\0' || *c
== '!')
2336 while (*c
== ' ' || *c
== '\t')
2339 /* Find filename between quotes. */
2342 if (quote
!= '"' && quote
!= '\'')
2344 if (allow_continuation
)
2346 if (gfc_current_form
== FORM_FREE
)
2350 while (*c
== ' ' || *c
== '\t')
2352 if (*c
== '\0' || *c
== '!')
2356 else if (quote
== '\0' || quote
== '!')
2365 while (*c
!= quote
&& *c
!= '\0')
2367 if (allow_continuation
&& gfc_current_form
== FORM_FREE
)
2371 else if (*c
!= ' ' && *c
!= '\t')
2379 if (allow_continuation
2380 && (cont
|| gfc_current_form
!= FORM_FREE
))
2387 while (*c
== ' ' || *c
== '\t')
2390 if (*c
!= '\0' && *c
!= '!')
2393 /* We have an include line at this point. */
2395 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
2396 read by anything else. */
2398 filename
= gfc_widechar_to_char (begin
, -1);
2399 load_file (filename
, NULL
, false);
2404 /* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc.
2405 APIs. Return 1 if recognized as valid INCLUDE statement and load_file has
2406 been called, 0 if it is not a valid INCLUDE statement and -1 if eof has
2407 been encountered while parsing it. */
2409 include_stmt (gfc_linebuf
*b
)
2411 int ret
= 0, i
, length
;
2412 const char *include
= "include";
2413 gfc_char_t c
, quote
= 0;
2419 gcc_attribute_flag
= 0;
2424 gfc_current_locus
.lb
= b
;
2425 gfc_current_locus
.nextc
= b
->line
;
2427 gfc_skip_comments ();
2428 gfc_gobble_whitespace ();
2430 for (i
= 0; i
< 7; i
++)
2432 c
= gfc_next_char ();
2433 if (c
!= (unsigned char) include
[i
])
2435 if (gfc_current_form
== FORM_FIXED
2438 && gfc_current_locus
.nextc
== b
->line
+ 6)
2440 gfc_gobble_whitespace ();
2444 gcc_assert (i
!= 0);
2447 gfc_advance_line ();
2448 gfc_skip_comments ();
2455 gfc_gobble_whitespace ();
2457 c
= gfc_next_char ();
2458 if (c
== '\'' || c
== '"')
2464 gfc_advance_line ();
2465 gfc_skip_comments ();
2472 str_locus
= gfc_current_locus
;
2476 c
= gfc_next_char_literal (INSTRING_NOWARN
);
2481 gfc_advance_line ();
2482 gfc_skip_comments ();
2491 gfc_gobble_whitespace ();
2492 c
= gfc_next_char ();
2496 gfc_current_locus
= str_locus
;
2498 filename
= XNEWVEC (char, length
+ 1);
2499 for (i
= 0; i
< length
; i
++)
2501 c
= gfc_next_char_literal (INSTRING_WARN
);
2502 gcc_assert (gfc_wide_fits_in_byte (c
));
2503 filename
[i
] = (unsigned char) c
;
2505 filename
[length
] = '\0';
2506 load_file (filename
, NULL
, false);
2512 gcc_attribute_flag
= 0;
2517 memset (&gfc_current_locus
, '\0', sizeof (locus
));
2518 memset (&openmp_locus
, '\0', sizeof (locus
));
2519 memset (&openacc_locus
, '\0', sizeof (locus
));
2520 memset (&gcc_attribute_locus
, '\0', sizeof (locus
));
2526 /* Load a file into memory by calling load_line until the file ends. */
2529 load_file (const char *realfilename
, const char *displayedname
, bool initial
)
2532 gfc_linebuf
*b
, *include_b
= NULL
;
2539 const char *filename
;
2540 /* If realfilename and displayedname are different and non-null then
2541 surely realfilename is the preprocessed form of
2543 bool preprocessed_p
= (realfilename
&& displayedname
2544 && strcmp (realfilename
, displayedname
));
2546 filename
= displayedname
? displayedname
: realfilename
;
2548 for (f
= current_file
; f
; f
= f
->up
)
2549 if (filename_cmp (filename
, f
->filename
) == 0)
2550 fatal_error (linemap_line_start (line_table
, current_file
->line
, 0),
2551 "File %qs is being included recursively", filename
);
2556 input
= gfc_src_file
;
2557 gfc_src_file
= NULL
;
2560 input
= gfc_open_file (realfilename
);
2563 gfc_fatal_error ("Cannot open file %qs", filename
);
2567 input
= gfc_open_included_file (realfilename
, false, false);
2570 /* For -fpre-include file, current_file is NULL. */
2572 fatal_error (linemap_line_start (line_table
, current_file
->line
, 0),
2573 "Cannot open included file %qs", filename
);
2575 gfc_fatal_error ("Cannot open pre-included file %qs", filename
);
2577 stat_result
= stat (realfilename
, &st
);
2578 if (stat_result
== 0 && !S_ISREG (st
.st_mode
))
2582 fatal_error (linemap_line_start (line_table
, current_file
->line
, 0),
2583 "Included file %qs is not a regular file", filename
);
2585 gfc_fatal_error ("Included file %qs is not a regular file", filename
);
2591 A "non-initial" file means a file that is being included. In
2592 that case we are creating an LC_ENTER map.
2594 An "initial" file means a main file; one that is not included.
2595 That file has already got at least one (surely more) line map(s)
2596 created by gfc_init. So the subsequent map created in that case
2597 must have LC_RENAME reason.
2599 This latter case is not true for a preprocessed file. In that
2600 case, although the file is "initial", the line maps created by
2601 gfc_init was used during the preprocessing of the file. Now that
2602 the preprocessing is over and we are being fed the result of that
2603 preprocessing, we need to create a brand new line map for the
2604 preprocessed file, so the reason is going to be LC_ENTER. */
2606 f
= get_file (filename
, (initial
&& !preprocessed_p
) ? LC_RENAME
: LC_ENTER
);
2608 add_file_change (f
->filename
, f
->inclusion_line
);
2610 current_file
->line
= 1;
2615 if (initial
&& gfc_src_preprocessor_lines
[0])
2617 preprocessor_line (gfc_src_preprocessor_lines
[0]);
2618 free (gfc_src_preprocessor_lines
[0]);
2619 gfc_src_preprocessor_lines
[0] = NULL
;
2620 if (gfc_src_preprocessor_lines
[1])
2622 preprocessor_line (gfc_src_preprocessor_lines
[1]);
2623 free (gfc_src_preprocessor_lines
[1]);
2624 gfc_src_preprocessor_lines
[1] = NULL
;
2630 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
2633 len
= gfc_wide_strlen (line
);
2634 if (feof (input
) && len
== 0)
2637 /* If this is the first line of the file, it can contain a byte
2638 order mark (BOM), which we will ignore:
2639 FF FE is UTF-16 little endian,
2640 FE FF is UTF-16 big endian,
2641 EF BB BF is UTF-8. */
2643 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
2644 && line
[1] == (unsigned char) '\xFE')
2645 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
2646 && line
[1] == (unsigned char) '\xFF')
2647 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
2648 && line
[1] == (unsigned char) '\xBB'
2649 && line
[2] == (unsigned char) '\xBF')))
2651 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
2652 gfc_char_t
*new_char
= gfc_get_wide_string (line_len
);
2654 wide_strcpy (new_char
, &line
[n
]);
2660 /* There are three things this line can be: a line of Fortran
2661 source, an include line or a C preprocessor directive. */
2665 /* When -g3 is specified, it's possible that we emit #define
2666 and #undef lines, which we need to pass to the middle-end
2667 so that it can emit correct debug info. */
2668 if (debug_info_level
== DINFO_LEVEL_VERBOSE
2669 && (wide_strncmp (line
, "#define ", 8) == 0
2670 || wide_strncmp (line
, "#undef ", 7) == 0))
2674 preprocessor_line (line
);
2679 /* Preprocessed files have preprocessor lines added before the byte
2680 order mark, so first_line is not about the first line of the file
2681 but the first line that's not a preprocessor line. */
2684 inc_line
= include_line (line
);
2687 current_file
->line
++;
2693 b
= XCNEWVAR (gfc_linebuf
, gfc_linebuf_header_size
2694 + (len
+ 1) * sizeof (gfc_char_t
));
2698 = linemap_line_start (line_table
, current_file
->line
++, len
);
2699 /* ??? We add the location for the maximum column possible here,
2700 because otherwise if the next call creates a new line-map, it
2701 will not reserve space for any offset. */
2703 linemap_position_for_column (line_table
, len
);
2705 b
->file
= current_file
;
2706 b
->truncated
= trunc
;
2707 wide_strcpy (b
->line
, line
);
2709 if (line_head
== NULL
)
2712 line_tail
->next
= b
;
2716 while (file_changes_cur
< file_changes_count
)
2717 file_changes
[file_changes_cur
++].lb
= b
;
2719 if (flag_dec_include
)
2721 if (include_b
&& b
!= include_b
)
2723 int inc_line2
= include_stmt (include_b
);
2726 else if (inc_line2
> 0)
2730 if (gfc_current_form
== FORM_FIXED
)
2732 for (gfc_char_t
*p
= include_b
->line
; *p
; p
++)
2736 include_b
->line
[0] = '\0';
2739 include_b
= include_b
->next
;
2745 if (inc_line
== -1 && !include_b
)
2750 /* Release the line buffer allocated in load_line. */
2756 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
2757 current_file
= current_file
->up
;
2758 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
2762 /* Open a new file and start scanning from that file. Returns true
2763 if everything went OK, false otherwise. If form == FORM_UNKNOWN
2764 it tries to determine the source form from the filename, defaulting
2770 if (flag_pre_include
!= NULL
)
2771 load_file (flag_pre_include
, NULL
, false);
2773 if (gfc_cpp_enabled ())
2775 gfc_cpp_preprocess (gfc_source_file
);
2776 if (!gfc_cpp_preprocess_only ())
2777 load_file (gfc_cpp_temporary_file (), gfc_source_file
, true);
2780 load_file (gfc_source_file
, NULL
, true);
2782 gfc_current_locus
.lb
= line_head
;
2783 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
2785 #if 0 /* Debugging aid. */
2786 for (; line_head
; line_head
= line_head
->next
)
2787 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
2788 LOCATION_LINE (line_head
->location
), line_head
->line
);
2790 exit (SUCCESS_EXIT_CODE
);
2795 unescape_filename (const char *ptr
)
2797 const char *p
= ptr
, *s
;
2799 int escaped
, unescape
= 0;
2801 /* Make filename end at quote. */
2803 while (*p
&& ! (! escaped
&& *p
== '"'))
2807 else if (*p
== '\\')
2818 /* Undo effects of cpp_quote_string. */
2820 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
2835 /* For preprocessed files, if the first tokens are of the form # NUM.
2836 handle the directives so we know the original file name. */
2839 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
2842 char *dirname
, *tmp
;
2844 gfc_src_file
= gfc_open_file (filename
);
2845 if (gfc_src_file
== NULL
)
2848 c
= getc (gfc_src_file
);
2854 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2856 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2859 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2860 filename
= unescape_filename (tmp
);
2862 if (filename
== NULL
)
2865 c
= getc (gfc_src_file
);
2871 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2873 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2876 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2877 dirname
= unescape_filename (tmp
);
2879 if (dirname
== NULL
)
2882 len
= strlen (dirname
);
2883 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2888 dirname
[len
- 2] = '\0';
2889 set_src_pwd (dirname
);
2891 if (! IS_ABSOLUTE_PATH (filename
))
2893 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2895 memcpy (p
, dirname
, len
- 2);
2897 strcpy (p
+ len
- 1, filename
);
2898 *canon_source_file
= p
;