2 Copyright (C) 2000-2020 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* Set of subroutines to (ultimately) return the next character to the
22 various matching subroutines. This file's job is to read files and
23 build up lines that are parsed by the parser. This means that we
24 handle continuation lines and "include" lines.
26 The first thing the scanner does is to load an entire file into
27 memory. We load the entire file into memory for a couple reasons.
28 The first is that we want to be able to deal with nonseekable input
29 (pipes, stdin) and there is a lot of backing up involved during
32 The second is that we want to be able to print the locus of errors,
33 and an error on line 999999 could conflict with something on line
34 one. Given nonseekable input, we've got to store the whole thing.
36 One thing that helps are the column truncation limits that give us
37 an upper bound on the size of individual lines. We don't store the
40 From the scanner's viewpoint, the higher level subroutines ask for
41 new characters and do a lot of jumping backwards. */
45 #include "coretypes.h"
47 #include "toplev.h" /* For set_src_pwd. */
53 /* List of include file search directories. */
54 gfc_directorylist
*include_dirs
, *intrinsic_modules_dirs
;
56 static gfc_file
*file_head
, *current_file
;
58 static int continue_flag
, end_flag
, gcc_attribute_flag
;
59 /* If !$omp/!$acc occurred in current comment line. */
60 static int openmp_flag
, openacc_flag
;
61 static int continue_count
, continue_line
;
62 static locus openmp_locus
;
63 static locus openacc_locus
;
64 static locus gcc_attribute_locus
;
66 gfc_source_form gfc_current_form
;
67 static gfc_linebuf
*line_head
, *line_tail
;
69 locus gfc_current_locus
;
70 const char *gfc_source_file
;
71 static FILE *gfc_src_file
;
72 static gfc_char_t
*gfc_src_preprocessor_lines
[2];
74 static struct gfc_file_change
80 size_t file_changes_cur
, file_changes_count
;
81 size_t file_changes_allocated
;
83 static gfc_char_t
*last_error_char
;
85 /* Functions dealing with our wide characters (gfc_char_t) and
86 sequences of such characters. */
89 gfc_wide_fits_in_byte (gfc_char_t c
)
91 return (c
<= UCHAR_MAX
);
95 wide_is_ascii (gfc_char_t c
)
97 return (gfc_wide_fits_in_byte (c
) && ((unsigned char) c
& ~0x7f) == 0);
101 gfc_wide_is_printable (gfc_char_t c
)
103 return (gfc_wide_fits_in_byte (c
) && ISPRINT ((unsigned char) c
));
107 gfc_wide_tolower (gfc_char_t c
)
109 return (wide_is_ascii (c
) ? (gfc_char_t
) TOLOWER((unsigned char) c
) : c
);
113 gfc_wide_toupper (gfc_char_t c
)
115 return (wide_is_ascii (c
) ? (gfc_char_t
) TOUPPER((unsigned char) c
) : c
);
119 gfc_wide_is_digit (gfc_char_t c
)
121 return (c
>= '0' && c
<= '9');
125 wide_atoi (gfc_char_t
*c
)
127 #define MAX_DIGITS 20
128 char buf
[MAX_DIGITS
+1];
131 while (gfc_wide_is_digit(*c
) && i
< MAX_DIGITS
)
138 gfc_wide_strlen (const gfc_char_t
*str
)
142 for (i
= 0; str
[i
]; i
++)
149 gfc_wide_memset (gfc_char_t
*b
, gfc_char_t c
, size_t len
)
153 for (i
= 0; i
< len
; i
++)
160 wide_strcpy (gfc_char_t
*dest
, const gfc_char_t
*src
)
164 for (d
= dest
; (*d
= *src
) != '\0'; ++src
, ++d
)
171 wide_strchr (const gfc_char_t
*s
, gfc_char_t c
)
176 return CONST_CAST(gfc_char_t
*, s
);
183 gfc_widechar_to_char (const gfc_char_t
*s
, int length
)
191 /* Passing a negative length is used to indicate that length should be
192 calculated using gfc_wide_strlen(). */
193 len
= (length
>= 0 ? (size_t) length
: gfc_wide_strlen (s
));
194 res
= XNEWVEC (char, len
+ 1);
196 for (i
= 0; i
< len
; i
++)
198 gcc_assert (gfc_wide_fits_in_byte (s
[i
]));
199 res
[i
] = (unsigned char) s
[i
];
207 gfc_char_to_widechar (const char *s
)
216 res
= gfc_get_wide_string (len
+ 1);
218 for (i
= 0; i
< len
; i
++)
219 res
[i
] = (unsigned char) s
[i
];
226 wide_strncmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
235 return (c1
> c2
? 1 : -1);
243 gfc_wide_strncasecmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
249 c1
= gfc_wide_tolower (*s1
++);
250 c2
= TOLOWER (*s2
++);
252 return (c1
> c2
? 1 : -1);
260 /* Main scanner initialization. */
263 gfc_scanner_init_1 (void)
273 last_error_char
= NULL
;
277 /* Main scanner destructor. */
280 gfc_scanner_done_1 (void)
285 while(line_head
!= NULL
)
287 lb
= line_head
->next
;
292 while(file_head
!= NULL
)
295 free (file_head
->filename
);
302 /* Adds path to the list pointed to by list. */
305 add_path_to_list (gfc_directorylist
**list
, const char *path
,
306 bool use_for_modules
, bool head
, bool warn
)
308 gfc_directorylist
*dir
;
316 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
320 /* Strip trailing directory separators from the path, as this
321 will confuse Windows systems. */
323 q
= (char *) alloca (len
+ 1);
324 memcpy (q
, p
, len
+ 1);
326 while (i
>=0 && IS_DIR_SEPARATOR (q
[i
]))
332 gfc_warning_now (0, "Include directory %qs: %s", path
,
335 gfc_warning_now (OPT_Wmissing_include_dirs
,
336 "Nonexistent include directory %qs", path
);
339 else if (!S_ISDIR (st
.st_mode
))
341 gfc_fatal_error ("%qs is not a directory", path
);
345 if (head
|| *list
== NULL
)
347 dir
= XCNEW (gfc_directorylist
);
357 dir
->next
= XCNEW (gfc_directorylist
);
361 dir
->next
= head
? *list
: NULL
;
364 dir
->use_for_modules
= use_for_modules
;
365 dir
->path
= XCNEWVEC (char, strlen (p
) + 2);
366 strcpy (dir
->path
, p
);
367 strcat (dir
->path
, "/"); /* make '/' last character */
372 gfc_add_include_path (const char *path
, bool use_for_modules
, bool file_dir
,
375 add_path_to_list (&include_dirs
, path
, use_for_modules
, file_dir
, warn
);
377 /* For '#include "..."' these directories are automatically searched. */
379 gfc_cpp_add_include_path (xstrdup(path
), true);
384 gfc_add_intrinsic_modules_path (const char *path
)
386 add_path_to_list (&intrinsic_modules_dirs
, path
, true, false, false);
390 /* Release resources allocated for options. */
393 gfc_release_include_path (void)
395 gfc_directorylist
*p
;
397 while (include_dirs
!= NULL
)
400 include_dirs
= include_dirs
->next
;
405 while (intrinsic_modules_dirs
!= NULL
)
407 p
= intrinsic_modules_dirs
;
408 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
413 free (gfc_option
.module_dir
);
418 open_included_file (const char *name
, gfc_directorylist
*list
,
419 bool module
, bool system
)
422 gfc_directorylist
*p
;
425 for (p
= list
; p
; p
= p
->next
)
427 if (module
&& !p
->use_for_modules
)
430 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
431 strcpy (fullname
, p
->path
);
432 strcat (fullname
, name
);
434 f
= gfc_open_file (fullname
);
437 if (gfc_cpp_makedep ())
438 gfc_cpp_add_dep (fullname
, system
);
448 /* Opens file for reading, searching through the include directories
449 given if necessary. If the include_cwd argument is true, we try
450 to open the file in the current directory first. */
453 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
457 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
459 f
= gfc_open_file (name
);
460 if (f
&& gfc_cpp_makedep ())
461 gfc_cpp_add_dep (name
, false);
465 f
= open_included_file (name
, include_dirs
, module
, false);
471 /* Test to see if we're at the end of the main source file. */
480 /* Test to see if we're at the end of the current file. */
488 if (line_head
== NULL
)
489 return 1; /* Null file */
491 if (gfc_current_locus
.lb
== NULL
)
498 /* Test to see if we're at the beginning of a new line. */
506 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
510 /* Test to see if we're at the end of a line. */
518 return (*gfc_current_locus
.nextc
== '\0');
522 add_file_change (const char *filename
, int line
)
524 if (file_changes_count
== file_changes_allocated
)
526 if (file_changes_allocated
)
527 file_changes_allocated
*= 2;
529 file_changes_allocated
= 16;
530 file_changes
= XRESIZEVEC (struct gfc_file_change
, file_changes
,
531 file_changes_allocated
);
533 file_changes
[file_changes_count
].filename
= filename
;
534 file_changes
[file_changes_count
].lb
= NULL
;
535 file_changes
[file_changes_count
++].line
= line
;
539 report_file_change (gfc_linebuf
*lb
)
541 size_t c
= file_changes_cur
;
542 while (c
< file_changes_count
543 && file_changes
[c
].lb
== lb
)
545 if (file_changes
[c
].filename
)
546 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
547 file_changes
[c
].filename
);
549 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
552 file_changes_cur
= c
;
556 gfc_start_source_files (void)
558 /* If the debugger wants the name of the main source file,
560 if (debug_hooks
->start_end_main_source_file
)
561 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
563 file_changes_cur
= 0;
564 report_file_change (gfc_current_locus
.lb
);
568 gfc_end_source_files (void)
570 report_file_change (NULL
);
572 if (debug_hooks
->start_end_main_source_file
)
573 (*debug_hooks
->end_source_file
) (0);
576 /* Advance the current line pointer to the next line. */
579 gfc_advance_line (void)
584 if (gfc_current_locus
.lb
== NULL
)
590 if (gfc_current_locus
.lb
->next
591 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
593 report_file_change (gfc_current_locus
.lb
->next
);
594 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
597 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
599 if (gfc_current_locus
.lb
!= NULL
)
600 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
603 gfc_current_locus
.nextc
= NULL
;
609 /* Get the next character from the input, advancing gfc_current_file's
610 locus. When we hit the end of the line or the end of the file, we
611 start returning a '\n' in order to complete the current statement.
612 No Fortran line conventions are implemented here.
614 Requiring explicit advances to the next line prevents the parse
615 pointer from being on the wrong line if the current statement ends
623 if (gfc_current_locus
.nextc
== NULL
)
626 c
= *gfc_current_locus
.nextc
++;
629 gfc_current_locus
.nextc
--; /* Remain on this line. */
637 /* Skip a comment. When we come here the parse pointer is positioned
638 immediately after the comment character. If we ever implement
639 compiler directives within comments, here is where we parse the
643 skip_comment_line (void)
658 gfc_define_undef_line (void)
662 /* All lines beginning with '#' are either #define or #undef. */
663 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
666 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
668 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
669 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
674 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
676 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
677 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
682 /* Skip the rest of the line. */
683 skip_comment_line ();
689 /* Return true if GCC$ was matched. */
691 skip_gcc_attribute (locus start
)
695 locus old_loc
= gfc_current_locus
;
697 if ((c
= next_char ()) == 'g' || c
== 'G')
698 if ((c
= next_char ()) == 'c' || c
== 'C')
699 if ((c
= next_char ()) == 'c' || c
== 'C')
700 if ((c
= next_char ()) == '$')
704 gfc_current_locus
= old_loc
;
707 gcc_attribute_flag
= 1;
708 gcc_attribute_locus
= old_loc
;
709 gfc_current_locus
= start
;
715 /* Return true if CC was matched. */
717 skip_free_oacc_sentinel (locus start
, locus old_loc
)
722 if ((c
= next_char ()) == 'c' || c
== 'C')
723 if ((c
= next_char ()) == 'c' || c
== 'C')
728 if ((c
= next_char ()) == ' ' || c
== '\t'
731 while (gfc_is_whitespace (c
))
733 if (c
!= '\n' && c
!= '!')
736 openacc_locus
= old_loc
;
737 gfc_current_locus
= start
;
744 gfc_warning_now (0, "!$ACC at %C starts a commented "
745 "line as it neither is followed "
746 "by a space nor is a "
747 "continuation line");
755 /* Return true if MP was matched. */
757 skip_free_omp_sentinel (locus start
, locus old_loc
)
762 if ((c
= next_char ()) == 'm' || c
== 'M')
763 if ((c
= next_char ()) == 'p' || c
== 'P')
768 if ((c
= next_char ()) == ' ' || c
== '\t'
771 while (gfc_is_whitespace (c
))
773 if (c
!= '\n' && c
!= '!')
776 openmp_locus
= old_loc
;
777 gfc_current_locus
= start
;
784 gfc_warning_now (0, "!$OMP at %C starts a commented "
785 "line as it neither is followed "
786 "by a space nor is a "
787 "continuation line");
795 /* Comment lines are null lines, lines containing only blanks or lines
796 on which the first nonblank line is a '!'.
797 Return true if !$ openmp or openacc conditional compilation sentinel was
801 skip_free_comments (void)
809 at_bol
= gfc_at_bol ();
810 start
= gfc_current_locus
;
816 while (gfc_is_whitespace (c
));
826 /* Keep the !GCC$ line. */
827 if (at_bol
&& skip_gcc_attribute (start
))
830 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
831 1) don't treat !$omp/!$acc as comments, but directives
832 2) handle OpenMP/OpenACC conditional compilation, where
833 !$ should be treated as 2 spaces (for initial lines
834 only if followed by space). */
837 if ((flag_openmp
|| flag_openmp_simd
)
840 locus old_loc
= gfc_current_locus
;
841 if (next_char () == '$')
844 if (c
== 'o' || c
== 'O')
846 if (skip_free_omp_sentinel (start
, old_loc
))
848 gfc_current_locus
= old_loc
;
852 else if (c
== 'a' || c
== 'A')
854 if (skip_free_oacc_sentinel (start
, old_loc
))
856 gfc_current_locus
= old_loc
;
860 if (continue_flag
|| c
== ' ' || c
== '\t')
862 gfc_current_locus
= old_loc
;
864 openmp_flag
= openacc_flag
= 0;
868 gfc_current_locus
= old_loc
;
870 else if ((flag_openmp
|| flag_openmp_simd
)
873 locus old_loc
= gfc_current_locus
;
874 if (next_char () == '$')
877 if (c
== 'o' || c
== 'O')
879 if (skip_free_omp_sentinel (start
, old_loc
))
881 gfc_current_locus
= old_loc
;
885 if (continue_flag
|| c
== ' ' || c
== '\t')
887 gfc_current_locus
= old_loc
;
893 gfc_current_locus
= old_loc
;
895 else if (flag_openacc
896 && !(flag_openmp
|| flag_openmp_simd
))
898 locus old_loc
= gfc_current_locus
;
899 if (next_char () == '$')
902 if (c
== 'a' || c
== 'A')
904 if (skip_free_oacc_sentinel (start
, old_loc
))
906 gfc_current_locus
= old_loc
;
910 if (continue_flag
|| c
== ' ' || c
== '\t')
912 gfc_current_locus
= old_loc
;
918 gfc_current_locus
= old_loc
;
921 skip_comment_line ();
928 if (openmp_flag
&& at_bol
)
931 if (openacc_flag
&& at_bol
)
934 gcc_attribute_flag
= 0;
935 gfc_current_locus
= start
;
939 /* Return true if MP was matched in fixed form. */
941 skip_fixed_omp_sentinel (locus
*start
)
944 if (((c
= next_char ()) == 'm' || c
== 'M')
945 && ((c
= next_char ()) == 'p' || c
== 'P'))
950 || c
== ' ' || c
== '\t' || c
== '0'))
954 while (gfc_is_whitespace (c
));
955 if (c
!= '\n' && c
!= '!')
957 /* Canonicalize to *$omp. */
960 gfc_current_locus
= *start
;
968 /* Return true if CC was matched in fixed form. */
970 skip_fixed_oacc_sentinel (locus
*start
)
973 if (((c
= next_char ()) == 'c' || c
== 'C')
974 && ((c
= next_char ()) == 'c' || c
== 'C'))
979 || c
== ' ' || c
== '\t' || c
== '0'))
983 while (gfc_is_whitespace (c
));
984 if (c
!= '\n' && c
!= '!')
986 /* Canonicalize to *$acc. */
989 gfc_current_locus
= *start
;
997 /* Skip comment lines in fixed source mode. We have the same rules as
998 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
999 in column 1, and a '!' cannot be in column 6. Also, we deal with
1000 lines with 'd' or 'D' in column 1, if the user requested this. */
1003 skip_fixed_comments (void)
1009 if (! gfc_at_bol ())
1011 start
= gfc_current_locus
;
1012 if (! gfc_at_eof ())
1016 while (gfc_is_whitespace (c
));
1019 gfc_advance_line ();
1021 skip_comment_line ();
1024 if (! gfc_at_bol ())
1026 gfc_current_locus
= start
;
1033 start
= gfc_current_locus
;
1040 gfc_advance_line ();
1044 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
1046 if (skip_gcc_attribute (start
))
1048 /* Canonicalize to *$omp. */
1053 if (gfc_current_locus
.lb
!= NULL
1054 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1055 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1057 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
1058 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
1060 2) handle OpenMP/OpenACC conditional compilation, where
1061 !$|c$|*$ should be treated as 2 spaces if the characters
1062 in columns 3 to 6 are valid fixed form label columns
1064 if ((flag_openmp
|| flag_openmp_simd
) && !flag_openacc
)
1066 if (next_char () == '$')
1069 if (c
== 'o' || c
== 'O')
1071 if (skip_fixed_omp_sentinel (&start
))
1075 goto check_for_digits
;
1077 gfc_current_locus
= start
;
1080 if (flag_openacc
&& !(flag_openmp
|| flag_openmp_simd
))
1082 if (next_char () == '$')
1085 if (c
== 'a' || c
== 'A')
1087 if (skip_fixed_oacc_sentinel (&start
))
1091 goto check_for_digits
;
1093 gfc_current_locus
= start
;
1096 if (flag_openacc
|| flag_openmp
|| flag_openmp_simd
)
1098 if (next_char () == '$')
1101 if (c
== 'a' || c
== 'A')
1103 if (skip_fixed_oacc_sentinel (&start
))
1106 else if (c
== 'o' || c
== 'O')
1108 if (skip_fixed_omp_sentinel (&start
))
1112 goto check_for_digits
;
1114 gfc_current_locus
= start
;
1117 skip_comment_line ();
1125 for (col
= 3; col
< 6; col
++, c
= next_char ())
1133 else if (c
< '0' || c
> '9')
1138 if (col
== 6 && c
!= '\n'
1139 && ((continue_flag
&& !digit_seen
)
1140 || c
== ' ' || c
== '\t' || c
== '0'))
1142 gfc_current_locus
= start
;
1143 start
.nextc
[0] = ' ';
1144 start
.nextc
[1] = ' ';
1148 skip_comment_line ();
1152 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
1154 if (gfc_option
.flag_d_lines
== 0)
1156 skip_comment_line ();
1160 *start
.nextc
= c
= ' ';
1165 while (gfc_is_whitespace (c
))
1173 gfc_advance_line ();
1177 if (col
!= 6 && c
== '!')
1179 if (gfc_current_locus
.lb
!= NULL
1180 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1181 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1182 skip_comment_line ();
1191 gcc_attribute_flag
= 0;
1192 gfc_current_locus
= start
;
1196 /* Skips the current line if it is a comment. */
1199 gfc_skip_comments (void)
1201 if (gfc_current_form
== FORM_FREE
)
1202 skip_free_comments ();
1204 skip_fixed_comments ();
1208 /* Get the next character from the input, taking continuation lines
1209 and end-of-line comments into account. This implies that comment
1210 lines between continued lines must be eaten here. For higher-level
1211 subroutines, this flattens continued lines into a single logical
1212 line. The in_string flag denotes whether we're inside a character
1216 gfc_next_char_literal (gfc_instring in_string
)
1219 int i
, prev_openmp_flag
, prev_openacc_flag
;
1223 prev_openacc_flag
= prev_openmp_flag
= 0;
1233 if (gfc_current_form
== FORM_FREE
)
1235 bool openmp_cond_flag
;
1237 if (!in_string
&& c
== '!')
1239 if (gcc_attribute_flag
1240 && memcmp (&gfc_current_locus
, &gcc_attribute_locus
,
1241 sizeof (gfc_current_locus
)) == 0)
1245 && memcmp (&gfc_current_locus
, &openmp_locus
,
1246 sizeof (gfc_current_locus
)) == 0)
1250 && memcmp (&gfc_current_locus
, &openacc_locus
,
1251 sizeof (gfc_current_locus
)) == 0)
1254 /* This line can't be continued */
1261 /* Avoid truncation warnings for comment ending lines. */
1262 gfc_current_locus
.lb
->truncated
= 0;
1267 /* Check to see if the continuation line was truncated. */
1268 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1269 && gfc_current_locus
.lb
->truncated
)
1271 int maxlen
= flag_free_line_length
;
1272 gfc_char_t
*current_nextc
= gfc_current_locus
.nextc
;
1274 gfc_current_locus
.lb
->truncated
= 0;
1275 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
+ maxlen
;
1276 gfc_warning_now (OPT_Wline_truncation
,
1277 "Line truncated at %L", &gfc_current_locus
);
1278 gfc_current_locus
.nextc
= current_nextc
;
1284 /* If the next nonblank character is a ! or \n, we've got a
1285 continuation line. */
1286 old_loc
= gfc_current_locus
;
1289 while (gfc_is_whitespace (c
))
1292 /* Character constants to be continued cannot have commentary
1293 after the '&'. However, there are cases where we may think we
1294 are still in a string and we are looking for a possible
1295 doubled quote and we end up here. See PR64506. */
1297 if (in_string
&& c
!= '\n')
1299 gfc_current_locus
= old_loc
;
1304 if (c
!= '!' && c
!= '\n')
1306 gfc_current_locus
= old_loc
;
1312 prev_openmp_flag
= openmp_flag
;
1314 prev_openacc_flag
= openacc_flag
;
1316 /* This can happen if the input file changed or via cpp's #line
1317 without getting reset (e.g. via input_stmt). It also happens
1318 when pre-including files via -fpre-include=. */
1319 if (continue_count
== 0
1320 && gfc_current_locus
.lb
1321 && continue_line
> gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1)
1322 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1;
1326 skip_comment_line ();
1328 gfc_advance_line ();
1331 goto not_continuation
;
1333 /* We've got a continuation line. If we are on the very next line after
1334 the last continuation, increment the continuation line count and
1335 check whether the limit has been exceeded. */
1336 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1338 if (++continue_count
== gfc_option
.max_continue_free
)
1340 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1341 gfc_warning (0, "Limit of %d continuations exceeded in "
1342 "statement at %C", gfc_option
.max_continue_free
);
1346 /* Now find where it continues. First eat any comment lines. */
1347 openmp_cond_flag
= skip_free_comments ();
1349 if (gfc_current_locus
.lb
!= NULL
1350 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1351 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1354 if (prev_openmp_flag
!= openmp_flag
&& !openacc_flag
)
1356 gfc_current_locus
= old_loc
;
1357 openmp_flag
= prev_openmp_flag
;
1363 if (prev_openacc_flag
!= openacc_flag
&& !openmp_flag
)
1365 gfc_current_locus
= old_loc
;
1366 openacc_flag
= prev_openacc_flag
;
1371 /* Now that we have a non-comment line, probe ahead for the
1372 first non-whitespace character. If it is another '&', then
1373 reading starts at the next character, otherwise we must back
1374 up to where the whitespace started and resume from there. */
1376 old_loc
= gfc_current_locus
;
1379 while (gfc_is_whitespace (c
))
1382 if (openmp_flag
&& !openacc_flag
)
1384 for (i
= 0; i
< 5; i
++, c
= next_char ())
1386 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1388 old_loc
= gfc_current_locus
;
1390 while (gfc_is_whitespace (c
))
1393 if (openacc_flag
&& !openmp_flag
)
1395 for (i
= 0; i
< 5; i
++, c
= next_char ())
1397 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$acc"[i
]);
1399 old_loc
= gfc_current_locus
;
1401 while (gfc_is_whitespace (c
))
1405 /* In case we have an OpenMP directive continued by OpenACC
1406 sentinel, or vice versa, we get both openmp_flag and
1409 if (openacc_flag
&& openmp_flag
)
1412 for (i
= 0; i
< 5; i
++, c
= next_char ())
1414 if (gfc_wide_tolower (c
) != (unsigned char) "!$acc"[i
])
1417 old_loc
= gfc_current_locus
;
1419 gfc_error (is_openmp
1420 ? G_("Wrong OpenACC continuation at %C: "
1421 "expected !$ACC, got !$OMP")
1422 : G_("Wrong OpenMP continuation at %C: "
1423 "expected !$OMP, got !$ACC"));
1428 if (in_string
&& gfc_current_locus
.nextc
)
1430 gfc_current_locus
.nextc
--;
1431 if (warn_ampersand
&& in_string
== INSTRING_WARN
)
1432 gfc_warning (OPT_Wampersand
,
1433 "Missing %<&%> in continued character "
1436 else if (!in_string
&& (c
== '\'' || c
== '"'))
1438 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1439 continuation line only optionally. */
1440 else if (openmp_flag
|| openacc_flag
|| openmp_cond_flag
)
1442 if (gfc_current_locus
.nextc
)
1443 gfc_current_locus
.nextc
--;
1448 gfc_current_locus
= old_loc
;
1453 else /* Fixed form. */
1455 /* Fixed form continuation. */
1456 if (in_string
!= INSTRING_WARN
&& c
== '!')
1458 /* Skip comment at end of line. */
1465 /* Avoid truncation warnings for comment ending lines. */
1466 gfc_current_locus
.lb
->truncated
= 0;
1472 /* Check to see if the continuation line was truncated. */
1473 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1474 && gfc_current_locus
.lb
->truncated
)
1476 gfc_current_locus
.lb
->truncated
= 0;
1477 gfc_warning_now (OPT_Wline_truncation
,
1478 "Line truncated at %L", &gfc_current_locus
);
1482 prev_openmp_flag
= openmp_flag
;
1484 prev_openacc_flag
= openacc_flag
;
1486 /* This can happen if the input file changed or via cpp's #line
1487 without getting reset (e.g. via input_stmt). It also happens
1488 when pre-including files via -fpre-include=. */
1489 if (continue_count
== 0
1490 && gfc_current_locus
.lb
1491 && continue_line
> gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1)
1492 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1;
1495 old_loc
= gfc_current_locus
;
1497 gfc_advance_line ();
1498 skip_fixed_comments ();
1500 /* See if this line is a continuation line. */
1501 if (flag_openmp
&& openmp_flag
!= prev_openmp_flag
&& !openacc_flag
)
1503 openmp_flag
= prev_openmp_flag
;
1504 goto not_continuation
;
1506 if (flag_openacc
&& openacc_flag
!= prev_openacc_flag
&& !openmp_flag
)
1508 openacc_flag
= prev_openacc_flag
;
1509 goto not_continuation
;
1512 /* In case we have an OpenMP directive continued by OpenACC
1513 sentinel, or vice versa, we get both openmp_flag and
1515 if (openacc_flag
&& openmp_flag
)
1518 for (i
= 0; i
< 5; i
++)
1521 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1524 gfc_error (is_openmp
1525 ? G_("Wrong OpenACC continuation at %C: "
1526 "expected !$ACC, got !$OMP")
1527 : G_("Wrong OpenMP continuation at %C: "
1528 "expected !$OMP, got !$ACC"));
1530 else if (!openmp_flag
&& !openacc_flag
)
1531 for (i
= 0; i
< 5; i
++)
1535 goto not_continuation
;
1537 else if (openmp_flag
)
1538 for (i
= 0; i
< 5; i
++)
1541 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1542 goto not_continuation
;
1544 else if (openacc_flag
)
1545 for (i
= 0; i
< 5; i
++)
1548 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1549 goto not_continuation
;
1553 if (c
== '0' || c
== ' ' || c
== '\n')
1554 goto not_continuation
;
1556 /* We've got a continuation line. If we are on the very next line after
1557 the last continuation, increment the continuation line count and
1558 check whether the limit has been exceeded. */
1559 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1561 if (++continue_count
== gfc_option
.max_continue_fixed
)
1563 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1564 gfc_warning (0, "Limit of %d continuations exceeded in "
1566 gfc_option
.max_continue_fixed
);
1570 if (gfc_current_locus
.lb
!= NULL
1571 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1572 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1575 /* Ready to read first character of continuation line, which might
1576 be another continuation line! */
1581 gfc_current_locus
= old_loc
;
1592 /* Get the next character of input, folded to lowercase. In fixed
1593 form mode, we also ignore spaces. When matcher subroutines are
1594 parsing character literals, they have to call
1595 gfc_next_char_literal(). */
1598 gfc_next_char (void)
1604 c
= gfc_next_char_literal (NONSTRING
);
1606 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1608 return gfc_wide_tolower (c
);
1612 gfc_next_ascii_char (void)
1614 gfc_char_t c
= gfc_next_char ();
1616 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1617 : (unsigned char) UCHAR_MAX
);
1622 gfc_peek_char (void)
1627 old_loc
= gfc_current_locus
;
1628 c
= gfc_next_char ();
1629 gfc_current_locus
= old_loc
;
1636 gfc_peek_ascii_char (void)
1638 gfc_char_t c
= gfc_peek_char ();
1640 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1641 : (unsigned char) UCHAR_MAX
);
1645 /* Recover from an error. We try to get past the current statement
1646 and get lined up for the next. The next statement follows a '\n'
1647 or a ';'. We also assume that we are not within a character
1648 constant, and deal with finding a '\'' or '"'. */
1651 gfc_error_recovery (void)
1653 gfc_char_t c
, delim
;
1660 c
= gfc_next_char ();
1661 if (c
== '\n' || c
== ';')
1664 if (c
!= '\'' && c
!= '"')
1693 /* Read ahead until the next character to be read is not whitespace. */
1696 gfc_gobble_whitespace (void)
1698 static int linenum
= 0;
1704 old_loc
= gfc_current_locus
;
1705 c
= gfc_next_char_literal (NONSTRING
);
1706 /* Issue a warning for nonconforming tabs. We keep track of the line
1707 number because the Fortran matchers will often back up and the same
1708 line will be scanned multiple times. */
1709 if (warn_tabs
&& c
== '\t')
1711 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1712 if (cur_linenum
!= linenum
)
1714 linenum
= cur_linenum
;
1715 gfc_warning_now (OPT_Wtabs
, "Nonconforming tab character at %C");
1719 while (gfc_is_whitespace (c
));
1721 if (!ISPRINT(c
) && c
!= '\n' && last_error_char
!= gfc_current_locus
.nextc
)
1724 last_error_char
= gfc_current_locus
.nextc
;
1725 snprintf (buf
, 20, "%2.2X", c
);
1726 gfc_error_now ("Invalid character 0x%s at %C", buf
);
1729 gfc_current_locus
= old_loc
;
1733 /* Load a single line into pbuf.
1735 If pbuf points to a NULL pointer, it is allocated.
1736 We truncate lines that are too long, unless we're dealing with
1737 preprocessor lines or if the option -ffixed-line-length-none is set,
1738 in which case we reallocate the buffer to fit the entire line, if
1740 In fixed mode, we expand a tab that occurs within the statement
1741 label region to expand to spaces that leave the next character in
1744 If first_char is not NULL, it's a pointer to a single char value holding
1745 the first character of the line, which has already been read by the
1746 caller. This avoids the use of ungetc().
1748 load_line returns whether the line was truncated.
1750 NOTE: The error machinery isn't available at this point, so we can't
1751 easily report line and column numbers consistent with other
1752 parts of gfortran. */
1755 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1757 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1758 int quoted
= ' ', comment_ix
= -1;
1759 bool seen_comment
= false;
1760 bool first_comment
= true;
1761 bool trunc_flag
= false;
1762 bool seen_printable
= false;
1763 bool seen_ampersand
= false;
1764 bool found_tab
= false;
1765 bool warned_tabs
= false;
1768 /* Determine the maximum allowed line length. */
1769 if (gfc_current_form
== FORM_FREE
)
1770 maxlen
= flag_free_line_length
;
1771 else if (gfc_current_form
== FORM_FIXED
)
1772 maxlen
= flag_fixed_line_length
;
1778 /* Allocate the line buffer, storing its length into buflen.
1779 Note that if maxlen==0, indicating that arbitrary-length lines
1780 are allowed, the buffer will be reallocated if this length is
1781 insufficient; since 132 characters is the length of a standard
1782 free-form line, we use that as a starting guess. */
1788 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1799 /* In order to not truncate preprocessor lines, we have to
1800 remember that this is one. */
1801 preprocessor_flag
= (c
== '#');
1810 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1811 if (gfc_current_form
== FORM_FREE
1812 && !seen_printable
&& seen_ampersand
)
1815 gfc_error_now ("%<&%> not allowed by itself in line %d",
1816 current_file
->line
);
1818 gfc_warning_now (0, "%<&%> not allowed by itself in line %d",
1819 current_file
->line
);
1824 if (c
== '\r' || c
== '\0')
1825 goto next_char
; /* Gobble characters. */
1831 seen_ampersand
= false;
1832 seen_printable
= true;
1835 seen_ampersand
= true;
1838 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1839 seen_printable
= true;
1841 /* Is this a fixed-form comment? */
1842 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1843 && (c
== '*' || c
== 'c' || c
== 'C'
1844 || (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))))
1846 seen_comment
= true;
1852 if (c
== '\'' || c
== '"')
1855 else if (c
== quoted
)
1858 /* Is this a free-form comment? */
1859 if (c
== '!' && quoted
== ' ')
1862 first_comment
= false;
1863 seen_comment
= true;
1867 /* For truncation and tab warnings, set seen_comment to false if one has
1868 either an OpenMP or OpenACC directive - or a !GCC$ attribute. If
1869 OpenMP is enabled, use '!$' as as conditional compilation sentinel
1870 and OpenMP directive ('!$omp'). */
1871 if (seen_comment
&& first_comment
&& flag_openmp
&& comment_ix
+ 1 == i
1873 first_comment
= seen_comment
= false;
1874 if (seen_comment
&& first_comment
&& comment_ix
+ 4 == i
)
1876 if (((*pbuf
)[comment_ix
+1] == 'g' || (*pbuf
)[comment_ix
+1] == 'G')
1877 && ((*pbuf
)[comment_ix
+2] == 'c' || (*pbuf
)[comment_ix
+2] == 'C')
1878 && ((*pbuf
)[comment_ix
+3] == 'c' || (*pbuf
)[comment_ix
+3] == 'C')
1879 && (*pbuf
)[comment_ix
+4] == '$')
1880 first_comment
= seen_comment
= false;
1882 && (*pbuf
)[comment_ix
+1] == '$'
1883 && ((*pbuf
)[comment_ix
+2] == 'a' || (*pbuf
)[comment_ix
+2] == 'A')
1884 && ((*pbuf
)[comment_ix
+3] == 'c' || (*pbuf
)[comment_ix
+3] == 'C')
1885 && ((*pbuf
)[comment_ix
+4] == 'c' || (*pbuf
)[comment_ix
+4] == 'C'))
1886 first_comment
= seen_comment
= false;
1889 /* Vendor extension: "<tab>1" marks a continuation line. */
1893 if (c
>= '1' && c
<= '9')
1900 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1904 if (warn_tabs
&& seen_comment
== 0 && !warned_tabs
)
1907 gfc_warning_now (OPT_Wtabs
,
1908 "Nonconforming tab character in column %d "
1909 "of line %d", i
+ 1, current_file
->line
);
1924 if (maxlen
== 0 || preprocessor_flag
)
1928 /* Reallocate line buffer to double size to hold the
1930 buflen
= buflen
* 2;
1931 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1932 buffer
= (*pbuf
) + i
;
1935 else if (i
>= maxlen
)
1937 bool trunc_warn
= true;
1939 /* Enhancement, if the very next non-space character is an ampersand
1940 or comment that we would otherwise warn about, don't mark as
1943 /* Truncate the rest of the line. */
1947 if (c
== '\r' || c
== ' ')
1950 if (c
== '\n' || c
== EOF
)
1953 if (!trunc_warn
&& c
!= '!')
1956 if (trunc_warn
&& ((gfc_current_form
== FORM_FIXED
&& c
== '&')
1963 if (trunc_warn
&& !seen_comment
)
1975 /* Pad lines to the selected line length in fixed form. */
1976 if (gfc_current_form
== FORM_FIXED
1977 && flag_fixed_line_length
!= 0
1979 && !preprocessor_flag
1982 while (i
++ < maxlen
)
1993 /* Get a gfc_file structure, initialize it and add it to
1997 get_file (const char *name
, enum lc_reason reason
)
2001 f
= XCNEW (gfc_file
);
2003 f
->filename
= xstrdup (name
);
2005 f
->next
= file_head
;
2008 f
->up
= current_file
;
2009 if (current_file
!= NULL
)
2010 f
->inclusion_line
= current_file
->line
;
2012 linemap_add (line_table
, reason
, false, f
->filename
, 1);
2018 /* Deal with a line from the C preprocessor. The
2019 initial octothorp has already been seen. */
2022 preprocessor_line (gfc_char_t
*c
)
2026 gfc_char_t
*wide_filename
;
2028 int escaped
, unescape
;
2032 while (*c
== ' ' || *c
== '\t')
2035 if (*c
< '0' || *c
> '9')
2038 line
= wide_atoi (c
);
2040 c
= wide_strchr (c
, ' ');
2043 /* No file name given. Set new line number. */
2044 current_file
->line
= line
;
2049 while (*c
== ' ' || *c
== '\t')
2059 /* Make filename end at quote. */
2062 while (*c
&& ! (!escaped
&& *c
== '"'))
2066 else if (*c
== '\\')
2075 /* Preprocessor line has no closing quote. */
2080 /* Undo effects of cpp_quote_string. */
2083 gfc_char_t
*s
= wide_filename
;
2084 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
2100 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
2104 c
= wide_strchr (c
, ' ');
2111 if (i
>= 1 && i
<= 4)
2115 /* Convert the filename in wide characters into a filename in narrow
2117 filename
= gfc_widechar_to_char (wide_filename
, -1);
2119 /* Interpret flags. */
2121 if (flag
[1]) /* Starting new file. */
2123 f
= get_file (filename
, LC_RENAME
);
2124 add_file_change (f
->filename
, f
->inclusion_line
);
2128 if (flag
[2]) /* Ending current file. */
2130 if (!current_file
->up
2131 || filename_cmp (current_file
->up
->filename
, filename
) != 0)
2133 linemap_line_start (line_table
, current_file
->line
, 80);
2134 /* ??? One could compute the exact column where the filename
2135 starts and compute the exact location here. */
2136 gfc_warning_now_at (linemap_position_for_column (line_table
, 1),
2137 0, "file %qs left but not entered",
2139 current_file
->line
++;
2141 free (wide_filename
);
2146 add_file_change (NULL
, line
);
2147 current_file
= current_file
->up
;
2148 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
2149 current_file
->line
);
2152 /* The name of the file can be a temporary file produced by
2153 cpp. Replace the name if it is different. */
2155 if (filename_cmp (current_file
->filename
, filename
) != 0)
2157 /* FIXME: we leak the old filename because a pointer to it may be stored
2158 in the linemap. Alternative could be using GC or updating linemap to
2159 point to the new name, but there is no API for that currently. */
2160 current_file
->filename
= xstrdup (filename
);
2162 /* We need to tell the linemap API that the filename changed. Just
2163 changing current_file is insufficient. */
2164 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
, line
);
2167 /* Set new line number. */
2168 current_file
->line
= line
;
2170 free (wide_filename
);
2175 linemap_line_start (line_table
, current_file
->line
, 80);
2176 /* ??? One could compute the exact column where the directive
2177 starts and compute the exact location here. */
2178 gfc_warning_now_at (linemap_position_for_column (line_table
, 2), 0,
2179 "Illegal preprocessor directive");
2180 current_file
->line
++;
2184 static bool load_file (const char *, const char *, bool);
2186 /* include_line()-- Checks a line buffer to see if it is an include
2187 line. If so, we call load_file() recursively to load the included
2188 file. We never return a syntax error because a statement like
2189 "include = 5" is perfectly legal. We return 0 if no include was
2190 processed, 1 if we matched an include or -1 if include was
2191 partially processed, but will need continuation lines. */
2194 include_line (gfc_char_t
*line
)
2196 gfc_char_t quote
, *c
, *begin
, *stop
;
2198 const char *include
= "include";
2199 bool allow_continuation
= flag_dec_include
;
2204 if (flag_openmp
|| flag_openmp_simd
)
2206 if (gfc_current_form
== FORM_FREE
)
2208 while (*c
== ' ' || *c
== '\t')
2210 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
2215 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
2216 && c
[1] == '$' && c
[2] == ' ')
2221 if (gfc_current_form
== FORM_FREE
)
2223 while (*c
== ' ' || *c
== '\t')
2225 if (gfc_wide_strncasecmp (c
, "include", 7))
2227 if (!allow_continuation
)
2229 for (i
= 0; i
< 7; ++i
)
2231 gfc_char_t c1
= gfc_wide_tolower (*c
);
2232 if (c1
!= (unsigned char) include
[i
])
2236 if (i
== 0 || *c
!= '&')
2239 while (*c
== ' ' || *c
== '\t')
2241 if (*c
== '\0' || *c
== '!')
2250 while (*c
== ' ' || *c
== '\t')
2252 if (flag_dec_include
&& *c
== '0' && c
- line
== 5)
2255 while (*c
== ' ' || *c
== '\t')
2259 allow_continuation
= false;
2260 for (i
= 0; i
< 7; ++i
)
2262 gfc_char_t c1
= gfc_wide_tolower (*c
);
2263 if (c1
!= (unsigned char) include
[i
])
2266 while (*c
== ' ' || *c
== '\t')
2269 if (!allow_continuation
)
2279 /* At the end of line or comment this might be continued. */
2280 if (*c
== '\0' || *c
== '!')
2287 while (*c
== ' ' || *c
== '\t')
2290 /* Find filename between quotes. */
2293 if (quote
!= '"' && quote
!= '\'')
2295 if (allow_continuation
)
2297 if (gfc_current_form
== FORM_FREE
)
2301 while (*c
== ' ' || *c
== '\t')
2303 if (*c
== '\0' || *c
== '!')
2307 else if (quote
== '\0' || quote
== '!')
2316 while (*c
!= quote
&& *c
!= '\0')
2318 if (allow_continuation
&& gfc_current_form
== FORM_FREE
)
2322 else if (*c
!= ' ' && *c
!= '\t')
2330 if (allow_continuation
2331 && (cont
|| gfc_current_form
!= FORM_FREE
))
2338 while (*c
== ' ' || *c
== '\t')
2341 if (*c
!= '\0' && *c
!= '!')
2344 /* We have an include line at this point. */
2346 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
2347 read by anything else. */
2349 filename
= gfc_widechar_to_char (begin
, -1);
2350 if (!load_file (filename
, NULL
, false))
2351 exit (FATAL_EXIT_CODE
);
2357 /* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc.
2358 APIs. Return 1 if recognized as valid INCLUDE statement and load_file has
2359 been called, 0 if it is not a valid INCLUDE statement and -1 if eof has
2360 been encountered while parsing it. */
2362 include_stmt (gfc_linebuf
*b
)
2364 int ret
= 0, i
, length
;
2365 const char *include
= "include";
2366 gfc_char_t c
, quote
= 0;
2372 gcc_attribute_flag
= 0;
2377 gfc_current_locus
.lb
= b
;
2378 gfc_current_locus
.nextc
= b
->line
;
2380 gfc_skip_comments ();
2381 gfc_gobble_whitespace ();
2383 for (i
= 0; i
< 7; i
++)
2385 c
= gfc_next_char ();
2386 if (c
!= (unsigned char) include
[i
])
2388 if (gfc_current_form
== FORM_FIXED
2391 && gfc_current_locus
.nextc
== b
->line
+ 6)
2393 gfc_gobble_whitespace ();
2397 gcc_assert (i
!= 0);
2400 gfc_advance_line ();
2401 gfc_skip_comments ();
2408 gfc_gobble_whitespace ();
2410 c
= gfc_next_char ();
2411 if (c
== '\'' || c
== '"')
2417 gfc_advance_line ();
2418 gfc_skip_comments ();
2425 str_locus
= gfc_current_locus
;
2429 c
= gfc_next_char_literal (INSTRING_NOWARN
);
2434 gfc_advance_line ();
2435 gfc_skip_comments ();
2444 gfc_gobble_whitespace ();
2445 c
= gfc_next_char ();
2449 gfc_current_locus
= str_locus
;
2451 filename
= XNEWVEC (char, length
+ 1);
2452 for (i
= 0; i
< length
; i
++)
2454 c
= gfc_next_char_literal (INSTRING_WARN
);
2455 gcc_assert (gfc_wide_fits_in_byte (c
));
2456 filename
[i
] = (unsigned char) c
;
2458 filename
[length
] = '\0';
2459 if (!load_file (filename
, NULL
, false))
2460 exit (FATAL_EXIT_CODE
);
2467 gcc_attribute_flag
= 0;
2472 memset (&gfc_current_locus
, '\0', sizeof (locus
));
2473 memset (&openmp_locus
, '\0', sizeof (locus
));
2474 memset (&openacc_locus
, '\0', sizeof (locus
));
2475 memset (&gcc_attribute_locus
, '\0', sizeof (locus
));
2479 /* Load a file into memory by calling load_line until the file ends. */
2482 load_file (const char *realfilename
, const char *displayedname
, bool initial
)
2485 gfc_linebuf
*b
, *include_b
= NULL
;
2492 const char *filename
;
2493 /* If realfilename and displayedname are different and non-null then
2494 surely realfilename is the preprocessed form of
2496 bool preprocessed_p
= (realfilename
&& displayedname
2497 && strcmp (realfilename
, displayedname
));
2499 filename
= displayedname
? displayedname
: realfilename
;
2501 for (f
= current_file
; f
; f
= f
->up
)
2502 if (filename_cmp (filename
, f
->filename
) == 0)
2504 fprintf (stderr
, "%s:%d: Error: File '%s' is being included "
2505 "recursively\n", current_file
->filename
, current_file
->line
,
2514 input
= gfc_src_file
;
2515 gfc_src_file
= NULL
;
2518 input
= gfc_open_file (realfilename
);
2522 gfc_error_now ("Cannot open file %qs", filename
);
2528 input
= gfc_open_included_file (realfilename
, false, false);
2531 /* For -fpre-include file, current_file is NULL. */
2533 fprintf (stderr
, "%s:%d: Error: Can't open included file '%s'\n",
2534 current_file
->filename
, current_file
->line
, filename
);
2536 fprintf (stderr
, "Error: Can't open pre-included file '%s'\n",
2541 stat_result
= stat (realfilename
, &st
);
2542 if (stat_result
== 0 && !S_ISREG(st
.st_mode
))
2544 fprintf (stderr
, "%s:%d: Error: Included path '%s'"
2545 " is not a regular file\n",
2546 current_file
->filename
, current_file
->line
, filename
);
2554 A "non-initial" file means a file that is being included. In
2555 that case we are creating an LC_ENTER map.
2557 An "initial" file means a main file; one that is not included.
2558 That file has already got at least one (surely more) line map(s)
2559 created by gfc_init. So the subsequent map created in that case
2560 must have LC_RENAME reason.
2562 This latter case is not true for a preprocessed file. In that
2563 case, although the file is "initial", the line maps created by
2564 gfc_init was used during the preprocessing of the file. Now that
2565 the preprocessing is over and we are being fed the result of that
2566 preprocessing, we need to create a brand new line map for the
2567 preprocessed file, so the reason is going to be LC_ENTER. */
2569 f
= get_file (filename
, (initial
&& !preprocessed_p
) ? LC_RENAME
: LC_ENTER
);
2571 add_file_change (f
->filename
, f
->inclusion_line
);
2573 current_file
->line
= 1;
2578 if (initial
&& gfc_src_preprocessor_lines
[0])
2580 preprocessor_line (gfc_src_preprocessor_lines
[0]);
2581 free (gfc_src_preprocessor_lines
[0]);
2582 gfc_src_preprocessor_lines
[0] = NULL
;
2583 if (gfc_src_preprocessor_lines
[1])
2585 preprocessor_line (gfc_src_preprocessor_lines
[1]);
2586 free (gfc_src_preprocessor_lines
[1]);
2587 gfc_src_preprocessor_lines
[1] = NULL
;
2593 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
2596 len
= gfc_wide_strlen (line
);
2597 if (feof (input
) && len
== 0)
2600 /* If this is the first line of the file, it can contain a byte
2601 order mark (BOM), which we will ignore:
2602 FF FE is UTF-16 little endian,
2603 FE FF is UTF-16 big endian,
2604 EF BB BF is UTF-8. */
2606 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
2607 && line
[1] == (unsigned char) '\xFE')
2608 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
2609 && line
[1] == (unsigned char) '\xFF')
2610 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
2611 && line
[1] == (unsigned char) '\xBB'
2612 && line
[2] == (unsigned char) '\xBF')))
2614 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
2615 gfc_char_t
*new_char
= gfc_get_wide_string (line_len
);
2617 wide_strcpy (new_char
, &line
[n
]);
2623 /* There are three things this line can be: a line of Fortran
2624 source, an include line or a C preprocessor directive. */
2628 /* When -g3 is specified, it's possible that we emit #define
2629 and #undef lines, which we need to pass to the middle-end
2630 so that it can emit correct debug info. */
2631 if (debug_info_level
== DINFO_LEVEL_VERBOSE
2632 && (wide_strncmp (line
, "#define ", 8) == 0
2633 || wide_strncmp (line
, "#undef ", 7) == 0))
2637 preprocessor_line (line
);
2642 /* Preprocessed files have preprocessor lines added before the byte
2643 order mark, so first_line is not about the first line of the file
2644 but the first line that's not a preprocessor line. */
2647 inc_line
= include_line (line
);
2650 current_file
->line
++;
2656 b
= XCNEWVAR (gfc_linebuf
, gfc_linebuf_header_size
2657 + (len
+ 1) * sizeof (gfc_char_t
));
2661 = linemap_line_start (line_table
, current_file
->line
++, len
);
2662 /* ??? We add the location for the maximum column possible here,
2663 because otherwise if the next call creates a new line-map, it
2664 will not reserve space for any offset. */
2666 linemap_position_for_column (line_table
, len
);
2668 b
->file
= current_file
;
2669 b
->truncated
= trunc
;
2670 wide_strcpy (b
->line
, line
);
2672 if (line_head
== NULL
)
2675 line_tail
->next
= b
;
2679 while (file_changes_cur
< file_changes_count
)
2680 file_changes
[file_changes_cur
++].lb
= b
;
2682 if (flag_dec_include
)
2684 if (include_b
&& b
!= include_b
)
2686 int inc_line2
= include_stmt (include_b
);
2689 else if (inc_line2
> 0)
2693 if (gfc_current_form
== FORM_FIXED
)
2695 for (gfc_char_t
*p
= include_b
->line
; *p
; p
++)
2699 include_b
->line
[0] = '\0';
2702 include_b
= include_b
->next
;
2708 if (inc_line
== -1 && !include_b
)
2713 /* Release the line buffer allocated in load_line. */
2719 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
2720 current_file
= current_file
->up
;
2721 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
2726 /* Open a new file and start scanning from that file. Returns true
2727 if everything went OK, false otherwise. If form == FORM_UNKNOWN
2728 it tries to determine the source form from the filename, defaulting
2736 if (flag_pre_include
!= NULL
2737 && !load_file (flag_pre_include
, NULL
, false))
2738 exit (FATAL_EXIT_CODE
);
2740 if (gfc_cpp_enabled ())
2742 result
= gfc_cpp_preprocess (gfc_source_file
);
2743 if (!gfc_cpp_preprocess_only ())
2744 result
= load_file (gfc_cpp_temporary_file (), gfc_source_file
, true);
2747 result
= load_file (gfc_source_file
, NULL
, true);
2749 gfc_current_locus
.lb
= line_head
;
2750 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
2752 #if 0 /* Debugging aid. */
2753 for (; line_head
; line_head
= line_head
->next
)
2754 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
2755 LOCATION_LINE (line_head
->location
), line_head
->line
);
2757 exit (SUCCESS_EXIT_CODE
);
2764 unescape_filename (const char *ptr
)
2766 const char *p
= ptr
, *s
;
2768 int escaped
, unescape
= 0;
2770 /* Make filename end at quote. */
2772 while (*p
&& ! (! escaped
&& *p
== '"'))
2776 else if (*p
== '\\')
2787 /* Undo effects of cpp_quote_string. */
2789 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
2804 /* For preprocessed files, if the first tokens are of the form # NUM.
2805 handle the directives so we know the original file name. */
2808 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
2811 char *dirname
, *tmp
;
2813 gfc_src_file
= gfc_open_file (filename
);
2814 if (gfc_src_file
== NULL
)
2817 c
= getc (gfc_src_file
);
2823 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2825 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2828 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2829 filename
= unescape_filename (tmp
);
2831 if (filename
== NULL
)
2834 c
= getc (gfc_src_file
);
2840 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2842 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2845 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2846 dirname
= unescape_filename (tmp
);
2848 if (dirname
== NULL
)
2851 len
= strlen (dirname
);
2852 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2857 dirname
[len
- 2] = '\0';
2858 set_src_pwd (dirname
);
2860 if (! IS_ABSOLUTE_PATH (filename
))
2862 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2864 memcpy (p
, dirname
, len
- 2);
2866 strcpy (p
+ len
- 1, filename
);
2867 *canon_source_file
= p
;