2 Copyright (C) 2000-2021 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
;
911 gfc_current_locus
= old_loc
;
914 skip_comment_line ();
921 if (openmp_flag
&& at_bol
)
924 if (openacc_flag
&& at_bol
)
927 gcc_attribute_flag
= 0;
928 gfc_current_locus
= start
;
932 /* Return true if MP was matched in fixed form. */
934 skip_fixed_omp_sentinel (locus
*start
)
937 if (((c
= next_char ()) == 'm' || c
== 'M')
938 && ((c
= next_char ()) == 'p' || c
== 'P'))
943 || c
== ' ' || c
== '\t' || c
== '0'))
947 while (gfc_is_whitespace (c
));
948 if (c
!= '\n' && c
!= '!')
950 /* Canonicalize to *$omp. */
953 gfc_current_locus
= *start
;
961 /* Return true if CC was matched in fixed form. */
963 skip_fixed_oacc_sentinel (locus
*start
)
966 if (((c
= next_char ()) == 'c' || c
== 'C')
967 && ((c
= next_char ()) == 'c' || c
== 'C'))
972 || c
== ' ' || c
== '\t' || c
== '0'))
976 while (gfc_is_whitespace (c
));
977 if (c
!= '\n' && c
!= '!')
979 /* Canonicalize to *$acc. */
982 gfc_current_locus
= *start
;
990 /* Skip comment lines in fixed source mode. We have the same rules as
991 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
992 in column 1, and a '!' cannot be in column 6. Also, we deal with
993 lines with 'd' or 'D' in column 1, if the user requested this. */
996 skip_fixed_comments (void)
1002 if (! gfc_at_bol ())
1004 start
= gfc_current_locus
;
1005 if (! gfc_at_eof ())
1009 while (gfc_is_whitespace (c
));
1012 gfc_advance_line ();
1014 skip_comment_line ();
1017 if (! gfc_at_bol ())
1019 gfc_current_locus
= start
;
1026 start
= gfc_current_locus
;
1033 gfc_advance_line ();
1037 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
1039 if (skip_gcc_attribute (start
))
1041 /* Canonicalize to *$omp. */
1046 if (gfc_current_locus
.lb
!= NULL
1047 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1048 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1050 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
1051 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
1053 2) handle OpenMP/OpenACC conditional compilation, where
1054 !$|c$|*$ should be treated as 2 spaces if the characters
1055 in columns 3 to 6 are valid fixed form label columns
1057 if ((flag_openmp
|| flag_openmp_simd
) && !flag_openacc
)
1059 if (next_char () == '$')
1062 if (c
== 'o' || c
== 'O')
1064 if (skip_fixed_omp_sentinel (&start
))
1068 goto check_for_digits
;
1070 gfc_current_locus
= start
;
1072 else if (flag_openacc
&& !(flag_openmp
|| flag_openmp_simd
))
1074 if (next_char () == '$')
1077 if (c
== 'a' || c
== 'A')
1079 if (skip_fixed_oacc_sentinel (&start
))
1083 gfc_current_locus
= start
;
1085 else if (flag_openacc
|| flag_openmp
|| flag_openmp_simd
)
1087 if (next_char () == '$')
1090 if (c
== 'a' || c
== 'A')
1092 if (skip_fixed_oacc_sentinel (&start
))
1095 else if (c
== 'o' || c
== 'O')
1097 if (skip_fixed_omp_sentinel (&start
))
1101 goto check_for_digits
;
1103 gfc_current_locus
= start
;
1106 skip_comment_line ();
1112 /* Required for OpenMP's conditional compilation sentinel. */
1115 for (col
= 3; col
< 6; col
++, c
= next_char ())
1123 else if (c
< '0' || c
> '9')
1128 if (col
== 6 && c
!= '\n'
1129 && ((continue_flag
&& !digit_seen
)
1130 || c
== ' ' || c
== '\t' || c
== '0'))
1132 gfc_current_locus
= start
;
1133 start
.nextc
[0] = ' ';
1134 start
.nextc
[1] = ' ';
1138 skip_comment_line ();
1142 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
1144 if (gfc_option
.flag_d_lines
== 0)
1146 skip_comment_line ();
1150 *start
.nextc
= c
= ' ';
1155 while (gfc_is_whitespace (c
))
1163 gfc_advance_line ();
1167 if (col
!= 6 && c
== '!')
1169 if (gfc_current_locus
.lb
!= NULL
1170 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1171 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1172 skip_comment_line ();
1181 gcc_attribute_flag
= 0;
1182 gfc_current_locus
= start
;
1186 /* Skips the current line if it is a comment. */
1189 gfc_skip_comments (void)
1191 if (gfc_current_form
== FORM_FREE
)
1192 skip_free_comments ();
1194 skip_fixed_comments ();
1198 /* Get the next character from the input, taking continuation lines
1199 and end-of-line comments into account. This implies that comment
1200 lines between continued lines must be eaten here. For higher-level
1201 subroutines, this flattens continued lines into a single logical
1202 line. The in_string flag denotes whether we're inside a character
1206 gfc_next_char_literal (gfc_instring in_string
)
1209 int i
, prev_openmp_flag
, prev_openacc_flag
;
1213 prev_openacc_flag
= prev_openmp_flag
= 0;
1223 if (gfc_current_form
== FORM_FREE
)
1225 bool openmp_cond_flag
;
1227 if (!in_string
&& c
== '!')
1229 if (gcc_attribute_flag
1230 && memcmp (&gfc_current_locus
, &gcc_attribute_locus
,
1231 sizeof (gfc_current_locus
)) == 0)
1235 && memcmp (&gfc_current_locus
, &openmp_locus
,
1236 sizeof (gfc_current_locus
)) == 0)
1240 && memcmp (&gfc_current_locus
, &openacc_locus
,
1241 sizeof (gfc_current_locus
)) == 0)
1244 /* This line can't be continued */
1251 /* Avoid truncation warnings for comment ending lines. */
1252 gfc_current_locus
.lb
->truncated
= 0;
1257 /* Check to see if the continuation line was truncated. */
1258 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1259 && gfc_current_locus
.lb
->truncated
)
1261 int maxlen
= flag_free_line_length
;
1262 gfc_char_t
*current_nextc
= gfc_current_locus
.nextc
;
1264 gfc_current_locus
.lb
->truncated
= 0;
1265 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
+ maxlen
;
1266 gfc_warning_now (OPT_Wline_truncation
,
1267 "Line truncated at %L", &gfc_current_locus
);
1268 gfc_current_locus
.nextc
= current_nextc
;
1274 /* If the next nonblank character is a ! or \n, we've got a
1275 continuation line. */
1276 old_loc
= gfc_current_locus
;
1279 while (gfc_is_whitespace (c
))
1282 /* Character constants to be continued cannot have commentary
1283 after the '&'. However, there are cases where we may think we
1284 are still in a string and we are looking for a possible
1285 doubled quote and we end up here. See PR64506. */
1287 if (in_string
&& c
!= '\n')
1289 gfc_current_locus
= old_loc
;
1294 if (c
!= '!' && c
!= '\n')
1296 gfc_current_locus
= old_loc
;
1302 prev_openmp_flag
= openmp_flag
;
1304 prev_openacc_flag
= openacc_flag
;
1306 /* This can happen if the input file changed or via cpp's #line
1307 without getting reset (e.g. via input_stmt). It also happens
1308 when pre-including files via -fpre-include=. */
1309 if (continue_count
== 0
1310 && gfc_current_locus
.lb
1311 && continue_line
> gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1)
1312 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1;
1316 skip_comment_line ();
1318 gfc_advance_line ();
1321 goto not_continuation
;
1323 /* We've got a continuation line. If we are on the very next line after
1324 the last continuation, increment the continuation line count and
1325 check whether the limit has been exceeded. */
1326 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1328 if (++continue_count
== gfc_option
.max_continue_free
)
1330 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1331 gfc_warning (0, "Limit of %d continuations exceeded in "
1332 "statement at %C", gfc_option
.max_continue_free
);
1336 /* Now find where it continues. First eat any comment lines. */
1337 openmp_cond_flag
= skip_free_comments ();
1339 if (gfc_current_locus
.lb
!= NULL
1340 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1341 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1344 if (prev_openmp_flag
!= openmp_flag
&& !openacc_flag
)
1346 gfc_current_locus
= old_loc
;
1347 openmp_flag
= prev_openmp_flag
;
1353 if (prev_openacc_flag
!= openacc_flag
&& !openmp_flag
)
1355 gfc_current_locus
= old_loc
;
1356 openacc_flag
= prev_openacc_flag
;
1361 /* Now that we have a non-comment line, probe ahead for the
1362 first non-whitespace character. If it is another '&', then
1363 reading starts at the next character, otherwise we must back
1364 up to where the whitespace started and resume from there. */
1366 old_loc
= gfc_current_locus
;
1369 while (gfc_is_whitespace (c
))
1372 if (openmp_flag
&& !openacc_flag
)
1374 for (i
= 0; i
< 5; i
++, c
= next_char ())
1376 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1378 old_loc
= gfc_current_locus
;
1380 while (gfc_is_whitespace (c
))
1383 if (openacc_flag
&& !openmp_flag
)
1385 for (i
= 0; i
< 5; i
++, c
= next_char ())
1387 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$acc"[i
]);
1389 old_loc
= gfc_current_locus
;
1391 while (gfc_is_whitespace (c
))
1395 /* In case we have an OpenMP directive continued by OpenACC
1396 sentinel, or vice versa, we get both openmp_flag and
1399 if (openacc_flag
&& openmp_flag
)
1402 for (i
= 0; i
< 5; i
++, c
= next_char ())
1404 if (gfc_wide_tolower (c
) != (unsigned char) "!$acc"[i
])
1407 old_loc
= gfc_current_locus
;
1409 gfc_error (is_openmp
1410 ? G_("Wrong OpenACC continuation at %C: "
1411 "expected !$ACC, got !$OMP")
1412 : G_("Wrong OpenMP continuation at %C: "
1413 "expected !$OMP, got !$ACC"));
1418 if (in_string
&& gfc_current_locus
.nextc
)
1420 gfc_current_locus
.nextc
--;
1421 if (warn_ampersand
&& in_string
== INSTRING_WARN
)
1422 gfc_warning (OPT_Wampersand
,
1423 "Missing %<&%> in continued character "
1426 else if (!in_string
&& (c
== '\'' || c
== '"'))
1428 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1429 continuation line only optionally. */
1430 else if (openmp_flag
|| openacc_flag
|| openmp_cond_flag
)
1432 if (gfc_current_locus
.nextc
)
1433 gfc_current_locus
.nextc
--;
1438 gfc_current_locus
= old_loc
;
1443 else /* Fixed form. */
1445 /* Fixed form continuation. */
1446 if (in_string
!= INSTRING_WARN
&& c
== '!')
1448 /* Skip comment at end of line. */
1455 /* Avoid truncation warnings for comment ending lines. */
1456 gfc_current_locus
.lb
->truncated
= 0;
1462 /* Check to see if the continuation line was truncated. */
1463 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1464 && gfc_current_locus
.lb
->truncated
)
1466 gfc_current_locus
.lb
->truncated
= 0;
1467 gfc_warning_now (OPT_Wline_truncation
,
1468 "Line truncated at %L", &gfc_current_locus
);
1472 prev_openmp_flag
= openmp_flag
;
1474 prev_openacc_flag
= openacc_flag
;
1476 /* This can happen if the input file changed or via cpp's #line
1477 without getting reset (e.g. via input_stmt). It also happens
1478 when pre-including files via -fpre-include=. */
1479 if (continue_count
== 0
1480 && gfc_current_locus
.lb
1481 && continue_line
> gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1)
1482 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
) + 1;
1485 old_loc
= gfc_current_locus
;
1487 gfc_advance_line ();
1488 skip_fixed_comments ();
1490 /* See if this line is a continuation line. */
1491 if (flag_openmp
&& openmp_flag
!= prev_openmp_flag
&& !openacc_flag
)
1493 openmp_flag
= prev_openmp_flag
;
1494 goto not_continuation
;
1496 if (flag_openacc
&& openacc_flag
!= prev_openacc_flag
&& !openmp_flag
)
1498 openacc_flag
= prev_openacc_flag
;
1499 goto not_continuation
;
1502 /* In case we have an OpenMP directive continued by OpenACC
1503 sentinel, or vice versa, we get both openmp_flag and
1505 if (openacc_flag
&& openmp_flag
)
1508 for (i
= 0; i
< 5; i
++)
1511 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1514 gfc_error (is_openmp
1515 ? G_("Wrong OpenACC continuation at %C: "
1516 "expected !$ACC, got !$OMP")
1517 : G_("Wrong OpenMP continuation at %C: "
1518 "expected !$OMP, got !$ACC"));
1520 else if (!openmp_flag
&& !openacc_flag
)
1521 for (i
= 0; i
< 5; i
++)
1525 goto not_continuation
;
1527 else if (openmp_flag
)
1528 for (i
= 0; i
< 5; i
++)
1531 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1532 goto not_continuation
;
1534 else if (openacc_flag
)
1535 for (i
= 0; i
< 5; i
++)
1538 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1539 goto not_continuation
;
1543 if (c
== '0' || c
== ' ' || c
== '\n')
1544 goto not_continuation
;
1546 /* We've got a continuation line. If we are on the very next line after
1547 the last continuation, increment the continuation line count and
1548 check whether the limit has been exceeded. */
1549 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1551 if (++continue_count
== gfc_option
.max_continue_fixed
)
1553 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1554 gfc_warning (0, "Limit of %d continuations exceeded in "
1556 gfc_option
.max_continue_fixed
);
1560 if (gfc_current_locus
.lb
!= NULL
1561 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1562 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1565 /* Ready to read first character of continuation line, which might
1566 be another continuation line! */
1571 gfc_current_locus
= old_loc
;
1582 /* Get the next character of input, folded to lowercase. In fixed
1583 form mode, we also ignore spaces. When matcher subroutines are
1584 parsing character literals, they have to call
1585 gfc_next_char_literal(). */
1588 gfc_next_char (void)
1594 c
= gfc_next_char_literal (NONSTRING
);
1596 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1598 return gfc_wide_tolower (c
);
1602 gfc_next_ascii_char (void)
1604 gfc_char_t c
= gfc_next_char ();
1606 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1607 : (unsigned char) UCHAR_MAX
);
1612 gfc_peek_char (void)
1617 old_loc
= gfc_current_locus
;
1618 c
= gfc_next_char ();
1619 gfc_current_locus
= old_loc
;
1626 gfc_peek_ascii_char (void)
1628 gfc_char_t c
= gfc_peek_char ();
1630 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1631 : (unsigned char) UCHAR_MAX
);
1635 /* Recover from an error. We try to get past the current statement
1636 and get lined up for the next. The next statement follows a '\n'
1637 or a ';'. We also assume that we are not within a character
1638 constant, and deal with finding a '\'' or '"'. */
1641 gfc_error_recovery (void)
1643 gfc_char_t c
, delim
;
1650 c
= gfc_next_char ();
1651 if (c
== '\n' || c
== ';')
1654 if (c
!= '\'' && c
!= '"')
1683 /* Read ahead until the next character to be read is not whitespace. */
1686 gfc_gobble_whitespace (void)
1688 static int linenum
= 0;
1694 old_loc
= gfc_current_locus
;
1695 c
= gfc_next_char_literal (NONSTRING
);
1696 /* Issue a warning for nonconforming tabs. We keep track of the line
1697 number because the Fortran matchers will often back up and the same
1698 line will be scanned multiple times. */
1699 if (warn_tabs
&& c
== '\t')
1701 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1702 if (cur_linenum
!= linenum
)
1704 linenum
= cur_linenum
;
1705 gfc_warning_now (OPT_Wtabs
, "Nonconforming tab character at %C");
1709 while (gfc_is_whitespace (c
));
1711 if (!ISPRINT(c
) && c
!= '\n' && last_error_char
!= gfc_current_locus
.nextc
)
1714 last_error_char
= gfc_current_locus
.nextc
;
1715 snprintf (buf
, 20, "%2.2X", c
);
1716 gfc_error_now ("Invalid character 0x%s at %C", buf
);
1719 gfc_current_locus
= old_loc
;
1723 /* Load a single line into pbuf.
1725 If pbuf points to a NULL pointer, it is allocated.
1726 We truncate lines that are too long, unless we're dealing with
1727 preprocessor lines or if the option -ffixed-line-length-none is set,
1728 in which case we reallocate the buffer to fit the entire line, if
1730 In fixed mode, we expand a tab that occurs within the statement
1731 label region to expand to spaces that leave the next character in
1734 If first_char is not NULL, it's a pointer to a single char value holding
1735 the first character of the line, which has already been read by the
1736 caller. This avoids the use of ungetc().
1738 load_line returns whether the line was truncated.
1740 NOTE: The error machinery isn't available at this point, so we can't
1741 easily report line and column numbers consistent with other
1742 parts of gfortran. */
1745 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1747 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1748 int quoted
= ' ', comment_ix
= -1;
1749 bool seen_comment
= false;
1750 bool first_comment
= true;
1751 bool trunc_flag
= false;
1752 bool seen_printable
= false;
1753 bool seen_ampersand
= false;
1754 bool found_tab
= false;
1755 bool warned_tabs
= false;
1758 /* Determine the maximum allowed line length. */
1759 if (gfc_current_form
== FORM_FREE
)
1760 maxlen
= flag_free_line_length
;
1761 else if (gfc_current_form
== FORM_FIXED
)
1762 maxlen
= flag_fixed_line_length
;
1768 /* Allocate the line buffer, storing its length into buflen.
1769 Note that if maxlen==0, indicating that arbitrary-length lines
1770 are allowed, the buffer will be reallocated if this length is
1771 insufficient; since 132 characters is the length of a standard
1772 free-form line, we use that as a starting guess. */
1778 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1789 /* In order to not truncate preprocessor lines, we have to
1790 remember that this is one. */
1791 preprocessor_flag
= (c
== '#');
1800 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1801 if (gfc_current_form
== FORM_FREE
1802 && !seen_printable
&& seen_ampersand
)
1805 gfc_error_now ("%<&%> not allowed by itself in line %d",
1806 current_file
->line
);
1808 gfc_warning_now (0, "%<&%> not allowed by itself in line %d",
1809 current_file
->line
);
1814 if (c
== '\r' || c
== '\0')
1815 goto next_char
; /* Gobble characters. */
1821 seen_ampersand
= false;
1822 seen_printable
= true;
1825 seen_ampersand
= true;
1828 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1829 seen_printable
= true;
1831 /* Is this a fixed-form comment? */
1832 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1833 && (c
== '*' || c
== 'c' || c
== 'C'
1834 || (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))))
1836 seen_comment
= true;
1842 if (c
== '\'' || c
== '"')
1845 else if (c
== quoted
)
1848 /* Is this a free-form comment? */
1849 if (c
== '!' && quoted
== ' ')
1852 first_comment
= false;
1853 seen_comment
= true;
1857 /* For truncation and tab warnings, set seen_comment to false if one has
1858 either an OpenMP or OpenACC directive - or a !GCC$ attribute. If
1859 OpenMP is enabled, use '!$' as as conditional compilation sentinel
1860 and OpenMP directive ('!$omp'). */
1861 if (seen_comment
&& first_comment
&& flag_openmp
&& comment_ix
+ 1 == i
1863 first_comment
= seen_comment
= false;
1864 if (seen_comment
&& first_comment
&& comment_ix
+ 4 == i
)
1866 if (((*pbuf
)[comment_ix
+1] == 'g' || (*pbuf
)[comment_ix
+1] == 'G')
1867 && ((*pbuf
)[comment_ix
+2] == 'c' || (*pbuf
)[comment_ix
+2] == 'C')
1868 && ((*pbuf
)[comment_ix
+3] == 'c' || (*pbuf
)[comment_ix
+3] == 'C')
1870 first_comment
= seen_comment
= false;
1872 && (*pbuf
)[comment_ix
+1] == '$'
1873 && ((*pbuf
)[comment_ix
+2] == 'a' || (*pbuf
)[comment_ix
+2] == 'A')
1874 && ((*pbuf
)[comment_ix
+3] == 'c' || (*pbuf
)[comment_ix
+3] == 'C')
1875 && (c
== 'c' || c
== 'C'))
1876 first_comment
= seen_comment
= false;
1879 /* Vendor extension: "<tab>1" marks a continuation line. */
1883 if (c
>= '1' && c
<= '9')
1890 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1894 if (warn_tabs
&& seen_comment
== 0 && !warned_tabs
)
1897 gfc_warning_now (OPT_Wtabs
,
1898 "Nonconforming tab character in column %d "
1899 "of line %d", i
+ 1, current_file
->line
);
1914 if (maxlen
== 0 || preprocessor_flag
)
1918 /* Reallocate line buffer to double size to hold the
1920 buflen
= buflen
* 2;
1921 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1922 buffer
= (*pbuf
) + i
;
1925 else if (i
>= maxlen
)
1927 bool trunc_warn
= true;
1929 /* Enhancement, if the very next non-space character is an ampersand
1930 or comment that we would otherwise warn about, don't mark as
1933 /* Truncate the rest of the line. */
1937 if (c
== '\r' || c
== ' ')
1940 if (c
== '\n' || c
== EOF
)
1943 if (!trunc_warn
&& c
!= '!')
1946 if (trunc_warn
&& ((gfc_current_form
== FORM_FIXED
&& c
== '&')
1953 if (trunc_warn
&& !seen_comment
)
1965 /* Pad lines to the selected line length in fixed form. */
1966 if (gfc_current_form
== FORM_FIXED
1967 && flag_fixed_line_length
!= 0
1969 && !preprocessor_flag
1972 while (i
++ < maxlen
)
1983 /* Get a gfc_file structure, initialize it and add it to
1987 get_file (const char *name
, enum lc_reason reason
)
1991 f
= XCNEW (gfc_file
);
1993 f
->filename
= xstrdup (name
);
1995 f
->next
= file_head
;
1998 f
->up
= current_file
;
1999 if (current_file
!= NULL
)
2000 f
->inclusion_line
= current_file
->line
;
2002 linemap_add (line_table
, reason
, false, f
->filename
, 1);
2008 /* Deal with a line from the C preprocessor. The
2009 initial octothorp has already been seen. */
2012 preprocessor_line (gfc_char_t
*c
)
2016 gfc_char_t
*wide_filename
;
2018 int escaped
, unescape
;
2022 while (*c
== ' ' || *c
== '\t')
2025 if (*c
< '0' || *c
> '9')
2028 line
= wide_atoi (c
);
2030 c
= wide_strchr (c
, ' ');
2033 /* No file name given. Set new line number. */
2034 current_file
->line
= line
;
2039 while (*c
== ' ' || *c
== '\t')
2049 /* Make filename end at quote. */
2052 while (*c
&& ! (!escaped
&& *c
== '"'))
2056 else if (*c
== '\\')
2065 /* Preprocessor line has no closing quote. */
2070 /* Undo effects of cpp_quote_string. */
2073 gfc_char_t
*s
= wide_filename
;
2074 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
2090 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
2094 c
= wide_strchr (c
, ' ');
2101 if (i
>= 1 && i
<= 4)
2105 /* Convert the filename in wide characters into a filename in narrow
2107 filename
= gfc_widechar_to_char (wide_filename
, -1);
2109 /* Interpret flags. */
2111 if (flag
[1]) /* Starting new file. */
2113 f
= get_file (filename
, LC_RENAME
);
2114 add_file_change (f
->filename
, f
->inclusion_line
);
2118 if (flag
[2]) /* Ending current file. */
2120 if (!current_file
->up
2121 || filename_cmp (current_file
->up
->filename
, filename
) != 0)
2123 linemap_line_start (line_table
, current_file
->line
, 80);
2124 /* ??? One could compute the exact column where the filename
2125 starts and compute the exact location here. */
2126 gfc_warning_now_at (linemap_position_for_column (line_table
, 1),
2127 0, "file %qs left but not entered",
2129 current_file
->line
++;
2131 free (wide_filename
);
2136 add_file_change (NULL
, line
);
2137 current_file
= current_file
->up
;
2138 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
2139 current_file
->line
);
2142 /* The name of the file can be a temporary file produced by
2143 cpp. Replace the name if it is different. */
2145 if (filename_cmp (current_file
->filename
, filename
) != 0)
2147 /* FIXME: we leak the old filename because a pointer to it may be stored
2148 in the linemap. Alternative could be using GC or updating linemap to
2149 point to the new name, but there is no API for that currently. */
2150 current_file
->filename
= xstrdup (filename
);
2152 /* We need to tell the linemap API that the filename changed. Just
2153 changing current_file is insufficient. */
2154 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
, line
);
2157 /* Set new line number. */
2158 current_file
->line
= line
;
2160 free (wide_filename
);
2165 linemap_line_start (line_table
, current_file
->line
, 80);
2166 /* ??? One could compute the exact column where the directive
2167 starts and compute the exact location here. */
2168 gfc_warning_now_at (linemap_position_for_column (line_table
, 2), 0,
2169 "Illegal preprocessor directive");
2170 current_file
->line
++;
2174 static bool load_file (const char *, const char *, bool);
2176 /* include_line()-- Checks a line buffer to see if it is an include
2177 line. If so, we call load_file() recursively to load the included
2178 file. We never return a syntax error because a statement like
2179 "include = 5" is perfectly legal. We return 0 if no include was
2180 processed, 1 if we matched an include or -1 if include was
2181 partially processed, but will need continuation lines. */
2184 include_line (gfc_char_t
*line
)
2186 gfc_char_t quote
, *c
, *begin
, *stop
;
2188 const char *include
= "include";
2189 bool allow_continuation
= flag_dec_include
;
2194 if (flag_openmp
|| flag_openmp_simd
)
2196 if (gfc_current_form
== FORM_FREE
)
2198 while (*c
== ' ' || *c
== '\t')
2200 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
2205 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
2206 && c
[1] == '$' && c
[2] == ' ')
2211 if (gfc_current_form
== FORM_FREE
)
2213 while (*c
== ' ' || *c
== '\t')
2215 if (gfc_wide_strncasecmp (c
, "include", 7))
2217 if (!allow_continuation
)
2219 for (i
= 0; i
< 7; ++i
)
2221 gfc_char_t c1
= gfc_wide_tolower (*c
);
2222 if (c1
!= (unsigned char) include
[i
])
2226 if (i
== 0 || *c
!= '&')
2229 while (*c
== ' ' || *c
== '\t')
2231 if (*c
== '\0' || *c
== '!')
2240 while (*c
== ' ' || *c
== '\t')
2242 if (flag_dec_include
&& *c
== '0' && c
- line
== 5)
2245 while (*c
== ' ' || *c
== '\t')
2249 allow_continuation
= false;
2250 for (i
= 0; i
< 7; ++i
)
2252 gfc_char_t c1
= gfc_wide_tolower (*c
);
2253 if (c1
!= (unsigned char) include
[i
])
2256 while (*c
== ' ' || *c
== '\t')
2259 if (!allow_continuation
)
2269 /* At the end of line or comment this might be continued. */
2270 if (*c
== '\0' || *c
== '!')
2277 while (*c
== ' ' || *c
== '\t')
2280 /* Find filename between quotes. */
2283 if (quote
!= '"' && quote
!= '\'')
2285 if (allow_continuation
)
2287 if (gfc_current_form
== FORM_FREE
)
2291 while (*c
== ' ' || *c
== '\t')
2293 if (*c
== '\0' || *c
== '!')
2297 else if (quote
== '\0' || quote
== '!')
2306 while (*c
!= quote
&& *c
!= '\0')
2308 if (allow_continuation
&& gfc_current_form
== FORM_FREE
)
2312 else if (*c
!= ' ' && *c
!= '\t')
2320 if (allow_continuation
2321 && (cont
|| gfc_current_form
!= FORM_FREE
))
2328 while (*c
== ' ' || *c
== '\t')
2331 if (*c
!= '\0' && *c
!= '!')
2334 /* We have an include line at this point. */
2336 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
2337 read by anything else. */
2339 filename
= gfc_widechar_to_char (begin
, -1);
2340 if (!load_file (filename
, NULL
, false))
2341 exit (FATAL_EXIT_CODE
);
2347 /* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc.
2348 APIs. Return 1 if recognized as valid INCLUDE statement and load_file has
2349 been called, 0 if it is not a valid INCLUDE statement and -1 if eof has
2350 been encountered while parsing it. */
2352 include_stmt (gfc_linebuf
*b
)
2354 int ret
= 0, i
, length
;
2355 const char *include
= "include";
2356 gfc_char_t c
, quote
= 0;
2362 gcc_attribute_flag
= 0;
2367 gfc_current_locus
.lb
= b
;
2368 gfc_current_locus
.nextc
= b
->line
;
2370 gfc_skip_comments ();
2371 gfc_gobble_whitespace ();
2373 for (i
= 0; i
< 7; i
++)
2375 c
= gfc_next_char ();
2376 if (c
!= (unsigned char) include
[i
])
2378 if (gfc_current_form
== FORM_FIXED
2381 && gfc_current_locus
.nextc
== b
->line
+ 6)
2383 gfc_gobble_whitespace ();
2387 gcc_assert (i
!= 0);
2390 gfc_advance_line ();
2391 gfc_skip_comments ();
2398 gfc_gobble_whitespace ();
2400 c
= gfc_next_char ();
2401 if (c
== '\'' || c
== '"')
2407 gfc_advance_line ();
2408 gfc_skip_comments ();
2415 str_locus
= gfc_current_locus
;
2419 c
= gfc_next_char_literal (INSTRING_NOWARN
);
2424 gfc_advance_line ();
2425 gfc_skip_comments ();
2434 gfc_gobble_whitespace ();
2435 c
= gfc_next_char ();
2439 gfc_current_locus
= str_locus
;
2441 filename
= XNEWVEC (char, length
+ 1);
2442 for (i
= 0; i
< length
; i
++)
2444 c
= gfc_next_char_literal (INSTRING_WARN
);
2445 gcc_assert (gfc_wide_fits_in_byte (c
));
2446 filename
[i
] = (unsigned char) c
;
2448 filename
[length
] = '\0';
2449 if (!load_file (filename
, NULL
, false))
2450 exit (FATAL_EXIT_CODE
);
2457 gcc_attribute_flag
= 0;
2462 memset (&gfc_current_locus
, '\0', sizeof (locus
));
2463 memset (&openmp_locus
, '\0', sizeof (locus
));
2464 memset (&openacc_locus
, '\0', sizeof (locus
));
2465 memset (&gcc_attribute_locus
, '\0', sizeof (locus
));
2469 /* Load a file into memory by calling load_line until the file ends. */
2472 load_file (const char *realfilename
, const char *displayedname
, bool initial
)
2475 gfc_linebuf
*b
, *include_b
= NULL
;
2482 const char *filename
;
2483 /* If realfilename and displayedname are different and non-null then
2484 surely realfilename is the preprocessed form of
2486 bool preprocessed_p
= (realfilename
&& displayedname
2487 && strcmp (realfilename
, displayedname
));
2489 filename
= displayedname
? displayedname
: realfilename
;
2491 for (f
= current_file
; f
; f
= f
->up
)
2492 if (filename_cmp (filename
, f
->filename
) == 0)
2494 fprintf (stderr
, "%s:%d: Error: File '%s' is being included "
2495 "recursively\n", current_file
->filename
, current_file
->line
,
2504 input
= gfc_src_file
;
2505 gfc_src_file
= NULL
;
2508 input
= gfc_open_file (realfilename
);
2512 gfc_error_now ("Cannot open file %qs", filename
);
2518 input
= gfc_open_included_file (realfilename
, false, false);
2521 /* For -fpre-include file, current_file is NULL. */
2523 fprintf (stderr
, "%s:%d: Error: Can't open included file '%s'\n",
2524 current_file
->filename
, current_file
->line
, filename
);
2526 fprintf (stderr
, "Error: Can't open pre-included file '%s'\n",
2531 stat_result
= stat (realfilename
, &st
);
2532 if (stat_result
== 0 && !S_ISREG(st
.st_mode
))
2534 fprintf (stderr
, "%s:%d: Error: Included path '%s'"
2535 " is not a regular file\n",
2536 current_file
->filename
, current_file
->line
, filename
);
2544 A "non-initial" file means a file that is being included. In
2545 that case we are creating an LC_ENTER map.
2547 An "initial" file means a main file; one that is not included.
2548 That file has already got at least one (surely more) line map(s)
2549 created by gfc_init. So the subsequent map created in that case
2550 must have LC_RENAME reason.
2552 This latter case is not true for a preprocessed file. In that
2553 case, although the file is "initial", the line maps created by
2554 gfc_init was used during the preprocessing of the file. Now that
2555 the preprocessing is over and we are being fed the result of that
2556 preprocessing, we need to create a brand new line map for the
2557 preprocessed file, so the reason is going to be LC_ENTER. */
2559 f
= get_file (filename
, (initial
&& !preprocessed_p
) ? LC_RENAME
: LC_ENTER
);
2561 add_file_change (f
->filename
, f
->inclusion_line
);
2563 current_file
->line
= 1;
2568 if (initial
&& gfc_src_preprocessor_lines
[0])
2570 preprocessor_line (gfc_src_preprocessor_lines
[0]);
2571 free (gfc_src_preprocessor_lines
[0]);
2572 gfc_src_preprocessor_lines
[0] = NULL
;
2573 if (gfc_src_preprocessor_lines
[1])
2575 preprocessor_line (gfc_src_preprocessor_lines
[1]);
2576 free (gfc_src_preprocessor_lines
[1]);
2577 gfc_src_preprocessor_lines
[1] = NULL
;
2583 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
2586 len
= gfc_wide_strlen (line
);
2587 if (feof (input
) && len
== 0)
2590 /* If this is the first line of the file, it can contain a byte
2591 order mark (BOM), which we will ignore:
2592 FF FE is UTF-16 little endian,
2593 FE FF is UTF-16 big endian,
2594 EF BB BF is UTF-8. */
2596 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
2597 && line
[1] == (unsigned char) '\xFE')
2598 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
2599 && line
[1] == (unsigned char) '\xFF')
2600 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
2601 && line
[1] == (unsigned char) '\xBB'
2602 && line
[2] == (unsigned char) '\xBF')))
2604 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
2605 gfc_char_t
*new_char
= gfc_get_wide_string (line_len
);
2607 wide_strcpy (new_char
, &line
[n
]);
2613 /* There are three things this line can be: a line of Fortran
2614 source, an include line or a C preprocessor directive. */
2618 /* When -g3 is specified, it's possible that we emit #define
2619 and #undef lines, which we need to pass to the middle-end
2620 so that it can emit correct debug info. */
2621 if (debug_info_level
== DINFO_LEVEL_VERBOSE
2622 && (wide_strncmp (line
, "#define ", 8) == 0
2623 || wide_strncmp (line
, "#undef ", 7) == 0))
2627 preprocessor_line (line
);
2632 /* Preprocessed files have preprocessor lines added before the byte
2633 order mark, so first_line is not about the first line of the file
2634 but the first line that's not a preprocessor line. */
2637 inc_line
= include_line (line
);
2640 current_file
->line
++;
2646 b
= XCNEWVAR (gfc_linebuf
, gfc_linebuf_header_size
2647 + (len
+ 1) * sizeof (gfc_char_t
));
2651 = linemap_line_start (line_table
, current_file
->line
++, len
);
2652 /* ??? We add the location for the maximum column possible here,
2653 because otherwise if the next call creates a new line-map, it
2654 will not reserve space for any offset. */
2656 linemap_position_for_column (line_table
, len
);
2658 b
->file
= current_file
;
2659 b
->truncated
= trunc
;
2660 wide_strcpy (b
->line
, line
);
2662 if (line_head
== NULL
)
2665 line_tail
->next
= b
;
2669 while (file_changes_cur
< file_changes_count
)
2670 file_changes
[file_changes_cur
++].lb
= b
;
2672 if (flag_dec_include
)
2674 if (include_b
&& b
!= include_b
)
2676 int inc_line2
= include_stmt (include_b
);
2679 else if (inc_line2
> 0)
2683 if (gfc_current_form
== FORM_FIXED
)
2685 for (gfc_char_t
*p
= include_b
->line
; *p
; p
++)
2689 include_b
->line
[0] = '\0';
2692 include_b
= include_b
->next
;
2698 if (inc_line
== -1 && !include_b
)
2703 /* Release the line buffer allocated in load_line. */
2709 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
2710 current_file
= current_file
->up
;
2711 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
2716 /* Open a new file and start scanning from that file. Returns true
2717 if everything went OK, false otherwise. If form == FORM_UNKNOWN
2718 it tries to determine the source form from the filename, defaulting
2726 if (flag_pre_include
!= NULL
2727 && !load_file (flag_pre_include
, NULL
, false))
2728 exit (FATAL_EXIT_CODE
);
2730 if (gfc_cpp_enabled ())
2732 result
= gfc_cpp_preprocess (gfc_source_file
);
2733 if (!gfc_cpp_preprocess_only ())
2734 result
= load_file (gfc_cpp_temporary_file (), gfc_source_file
, true);
2737 result
= load_file (gfc_source_file
, NULL
, true);
2739 gfc_current_locus
.lb
= line_head
;
2740 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
2742 #if 0 /* Debugging aid. */
2743 for (; line_head
; line_head
= line_head
->next
)
2744 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
2745 LOCATION_LINE (line_head
->location
), line_head
->line
);
2747 exit (SUCCESS_EXIT_CODE
);
2754 unescape_filename (const char *ptr
)
2756 const char *p
= ptr
, *s
;
2758 int escaped
, unescape
= 0;
2760 /* Make filename end at quote. */
2762 while (*p
&& ! (! escaped
&& *p
== '"'))
2766 else if (*p
== '\\')
2777 /* Undo effects of cpp_quote_string. */
2779 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
2794 /* For preprocessed files, if the first tokens are of the form # NUM.
2795 handle the directives so we know the original file name. */
2798 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
2801 char *dirname
, *tmp
;
2803 gfc_src_file
= gfc_open_file (filename
);
2804 if (gfc_src_file
== NULL
)
2807 c
= getc (gfc_src_file
);
2813 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2815 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2818 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2819 filename
= unescape_filename (tmp
);
2821 if (filename
== NULL
)
2824 c
= getc (gfc_src_file
);
2830 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2832 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2835 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2836 dirname
= unescape_filename (tmp
);
2838 if (dirname
== NULL
)
2841 len
= strlen (dirname
);
2842 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2847 dirname
[len
- 2] = '\0';
2848 set_src_pwd (dirname
);
2850 if (! IS_ABSOLUTE_PATH (filename
))
2852 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2854 memcpy (p
, dirname
, len
- 2);
2856 strcpy (p
+ len
- 1, filename
);
2857 *canon_source_file
= p
;