2 Copyright (C) 2000-2016 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
;
84 /* Functions dealing with our wide characters (gfc_char_t) and
85 sequences of such characters. */
88 gfc_wide_fits_in_byte (gfc_char_t c
)
90 return (c
<= UCHAR_MAX
);
94 wide_is_ascii (gfc_char_t c
)
96 return (gfc_wide_fits_in_byte (c
) && ((unsigned char) c
& ~0x7f) == 0);
100 gfc_wide_is_printable (gfc_char_t c
)
102 return (gfc_wide_fits_in_byte (c
) && ISPRINT ((unsigned char) c
));
106 gfc_wide_tolower (gfc_char_t c
)
108 return (wide_is_ascii (c
) ? (gfc_char_t
) TOLOWER((unsigned char) c
) : c
);
112 gfc_wide_toupper (gfc_char_t c
)
114 return (wide_is_ascii (c
) ? (gfc_char_t
) TOUPPER((unsigned char) c
) : c
);
118 gfc_wide_is_digit (gfc_char_t c
)
120 return (c
>= '0' && c
<= '9');
124 wide_atoi (gfc_char_t
*c
)
126 #define MAX_DIGITS 20
127 char buf
[MAX_DIGITS
+1];
130 while (gfc_wide_is_digit(*c
) && i
< MAX_DIGITS
)
137 gfc_wide_strlen (const gfc_char_t
*str
)
141 for (i
= 0; str
[i
]; i
++)
148 gfc_wide_memset (gfc_char_t
*b
, gfc_char_t c
, size_t len
)
152 for (i
= 0; i
< len
; i
++)
159 wide_strcpy (gfc_char_t
*dest
, const gfc_char_t
*src
)
163 for (d
= dest
; (*d
= *src
) != '\0'; ++src
, ++d
)
170 wide_strchr (const gfc_char_t
*s
, gfc_char_t c
)
175 return CONST_CAST(gfc_char_t
*, s
);
182 gfc_widechar_to_char (const gfc_char_t
*s
, int length
)
190 /* Passing a negative length is used to indicate that length should be
191 calculated using gfc_wide_strlen(). */
192 len
= (length
>= 0 ? (size_t) length
: gfc_wide_strlen (s
));
193 res
= XNEWVEC (char, len
+ 1);
195 for (i
= 0; i
< len
; i
++)
197 gcc_assert (gfc_wide_fits_in_byte (s
[i
]));
198 res
[i
] = (unsigned char) s
[i
];
206 gfc_char_to_widechar (const char *s
)
215 res
= gfc_get_wide_string (len
+ 1);
217 for (i
= 0; i
< len
; i
++)
218 res
[i
] = (unsigned char) s
[i
];
225 wide_strncmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
234 return (c1
> c2
? 1 : -1);
242 gfc_wide_strncasecmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
248 c1
= gfc_wide_tolower (*s1
++);
249 c2
= TOLOWER (*s2
++);
251 return (c1
> c2
? 1 : -1);
259 /* Main scanner initialization. */
262 gfc_scanner_init_1 (void)
275 /* Main scanner destructor. */
278 gfc_scanner_done_1 (void)
283 while(line_head
!= NULL
)
285 lb
= line_head
->next
;
290 while(file_head
!= NULL
)
293 free (file_head
->filename
);
300 /* Adds path to the list pointed to by list. */
303 add_path_to_list (gfc_directorylist
**list
, const char *path
,
304 bool use_for_modules
, bool head
, bool warn
)
306 gfc_directorylist
*dir
;
314 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
318 /* Strip trailing directory separators from the path, as this
319 will confuse Windows systems. */
321 q
= (char *) alloca (len
+ 1);
322 memcpy (q
, p
, len
+ 1);
324 while (i
>=0 && IS_DIR_SEPARATOR (q
[i
]))
330 gfc_warning_now (0, "Include directory %qs: %s", path
,
333 gfc_warning_now (OPT_Wmissing_include_dirs
,
334 "Nonexistent include directory %qs", path
);
337 else if (!S_ISDIR (st
.st_mode
))
339 gfc_fatal_error ("%qs is not a directory", path
);
343 if (head
|| *list
== NULL
)
345 dir
= XCNEW (gfc_directorylist
);
355 dir
->next
= XCNEW (gfc_directorylist
);
359 dir
->next
= head
? *list
: NULL
;
362 dir
->use_for_modules
= use_for_modules
;
363 dir
->path
= XCNEWVEC (char, strlen (p
) + 2);
364 strcpy (dir
->path
, p
);
365 strcat (dir
->path
, "/"); /* make '/' last character */
370 gfc_add_include_path (const char *path
, bool use_for_modules
, bool file_dir
,
373 add_path_to_list (&include_dirs
, path
, use_for_modules
, file_dir
, warn
);
375 /* For '#include "..."' these directories are automatically searched. */
377 gfc_cpp_add_include_path (xstrdup(path
), true);
382 gfc_add_intrinsic_modules_path (const char *path
)
384 add_path_to_list (&intrinsic_modules_dirs
, path
, true, false, false);
388 /* Release resources allocated for options. */
391 gfc_release_include_path (void)
393 gfc_directorylist
*p
;
395 while (include_dirs
!= NULL
)
398 include_dirs
= include_dirs
->next
;
403 while (intrinsic_modules_dirs
!= NULL
)
405 p
= intrinsic_modules_dirs
;
406 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
411 free (gfc_option
.module_dir
);
416 open_included_file (const char *name
, gfc_directorylist
*list
,
417 bool module
, bool system
)
420 gfc_directorylist
*p
;
423 for (p
= list
; p
; p
= p
->next
)
425 if (module
&& !p
->use_for_modules
)
428 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
429 strcpy (fullname
, p
->path
);
430 strcat (fullname
, name
);
432 f
= gfc_open_file (fullname
);
435 if (gfc_cpp_makedep ())
436 gfc_cpp_add_dep (fullname
, system
);
446 /* Opens file for reading, searching through the include directories
447 given if necessary. If the include_cwd argument is true, we try
448 to open the file in the current directory first. */
451 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
455 if (IS_ABSOLUTE_PATH (name
) || include_cwd
)
457 f
= gfc_open_file (name
);
458 if (f
&& gfc_cpp_makedep ())
459 gfc_cpp_add_dep (name
, false);
463 f
= open_included_file (name
, include_dirs
, module
, false);
469 /* Test to see if we're at the end of the main source file. */
478 /* Test to see if we're at the end of the current file. */
486 if (line_head
== NULL
)
487 return 1; /* Null file */
489 if (gfc_current_locus
.lb
== NULL
)
496 /* Test to see if we're at the beginning of a new line. */
504 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
508 /* Test to see if we're at the end of a line. */
516 return (*gfc_current_locus
.nextc
== '\0');
520 add_file_change (const char *filename
, int line
)
522 if (file_changes_count
== file_changes_allocated
)
524 if (file_changes_allocated
)
525 file_changes_allocated
*= 2;
527 file_changes_allocated
= 16;
528 file_changes
= XRESIZEVEC (struct gfc_file_change
, file_changes
,
529 file_changes_allocated
);
531 file_changes
[file_changes_count
].filename
= filename
;
532 file_changes
[file_changes_count
].lb
= NULL
;
533 file_changes
[file_changes_count
++].line
= line
;
537 report_file_change (gfc_linebuf
*lb
)
539 size_t c
= file_changes_cur
;
540 while (c
< file_changes_count
541 && file_changes
[c
].lb
== lb
)
543 if (file_changes
[c
].filename
)
544 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
545 file_changes
[c
].filename
);
547 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
550 file_changes_cur
= c
;
554 gfc_start_source_files (void)
556 /* If the debugger wants the name of the main source file,
558 if (debug_hooks
->start_end_main_source_file
)
559 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
561 file_changes_cur
= 0;
562 report_file_change (gfc_current_locus
.lb
);
566 gfc_end_source_files (void)
568 report_file_change (NULL
);
570 if (debug_hooks
->start_end_main_source_file
)
571 (*debug_hooks
->end_source_file
) (0);
574 /* Advance the current line pointer to the next line. */
577 gfc_advance_line (void)
582 if (gfc_current_locus
.lb
== NULL
)
588 if (gfc_current_locus
.lb
->next
589 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
591 report_file_change (gfc_current_locus
.lb
->next
);
592 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
595 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
597 if (gfc_current_locus
.lb
!= NULL
)
598 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
601 gfc_current_locus
.nextc
= NULL
;
607 /* Get the next character from the input, advancing gfc_current_file's
608 locus. When we hit the end of the line or the end of the file, we
609 start returning a '\n' in order to complete the current statement.
610 No Fortran line conventions are implemented here.
612 Requiring explicit advances to the next line prevents the parse
613 pointer from being on the wrong line if the current statement ends
621 if (gfc_current_locus
.nextc
== NULL
)
624 c
= *gfc_current_locus
.nextc
++;
627 gfc_current_locus
.nextc
--; /* Remain on this line. */
635 /* Skip a comment. When we come here the parse pointer is positioned
636 immediately after the comment character. If we ever implement
637 compiler directives within comments, here is where we parse the
641 skip_comment_line (void)
656 gfc_define_undef_line (void)
660 /* All lines beginning with '#' are either #define or #undef. */
661 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
664 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
666 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
667 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
672 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
674 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
675 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
680 /* Skip the rest of the line. */
681 skip_comment_line ();
687 /* Return true if GCC$ was matched. */
689 skip_gcc_attribute (locus start
)
693 locus old_loc
= gfc_current_locus
;
695 if ((c
= next_char ()) == 'g' || c
== 'G')
696 if ((c
= next_char ()) == 'c' || c
== 'C')
697 if ((c
= next_char ()) == 'c' || c
== 'C')
698 if ((c
= next_char ()) == '$')
702 gfc_current_locus
= old_loc
;
705 gcc_attribute_flag
= 1;
706 gcc_attribute_locus
= old_loc
;
707 gfc_current_locus
= start
;
713 /* Return true if CC was matched. */
715 skip_free_oacc_sentinel (locus start
, locus old_loc
)
720 if ((c
= next_char ()) == 'c' || c
== 'C')
721 if ((c
= next_char ()) == 'c' || c
== 'C')
726 if ((c
= next_char ()) == ' ' || c
== '\t'
729 while (gfc_is_whitespace (c
))
731 if (c
!= '\n' && c
!= '!')
734 openacc_locus
= old_loc
;
735 gfc_current_locus
= start
;
742 gfc_warning_now (0, "!$ACC at %C starts a commented "
743 "line as it neither is followed "
744 "by a space nor is a "
745 "continuation line");
753 /* Return true if MP was matched. */
755 skip_free_omp_sentinel (locus start
, locus old_loc
)
760 if ((c
= next_char ()) == 'm' || c
== 'M')
761 if ((c
= next_char ()) == 'p' || c
== 'P')
766 if ((c
= next_char ()) == ' ' || c
== '\t'
769 while (gfc_is_whitespace (c
))
771 if (c
!= '\n' && c
!= '!')
774 openmp_locus
= old_loc
;
775 gfc_current_locus
= start
;
782 gfc_warning_now (0, "!$OMP at %C starts a commented "
783 "line as it neither is followed "
784 "by a space nor is a "
785 "continuation line");
793 /* Comment lines are null lines, lines containing only blanks or lines
794 on which the first nonblank line is a '!'.
795 Return true if !$ openmp or openacc conditional compilation sentinel was
799 skip_free_comments (void)
807 at_bol
= gfc_at_bol ();
808 start
= gfc_current_locus
;
814 while (gfc_is_whitespace (c
));
824 /* Keep the !GCC$ line. */
825 if (at_bol
&& skip_gcc_attribute (start
))
828 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
829 1) don't treat !$omp/!$acc as comments, but directives
830 2) handle OpenMP/OpenACC conditional compilation, where
831 !$ should be treated as 2 spaces (for initial lines
832 only if followed by space). */
835 if ((flag_openmp
|| flag_openmp_simd
)
838 locus old_loc
= gfc_current_locus
;
839 if (next_char () == '$')
842 if (c
== 'o' || c
== 'O')
844 if (skip_free_omp_sentinel (start
, old_loc
))
846 gfc_current_locus
= old_loc
;
850 else if (c
== 'a' || c
== 'A')
852 if (skip_free_oacc_sentinel (start
, old_loc
))
854 gfc_current_locus
= old_loc
;
858 if (continue_flag
|| c
== ' ' || c
== '\t')
860 gfc_current_locus
= old_loc
;
862 openmp_flag
= openacc_flag
= 0;
866 gfc_current_locus
= old_loc
;
868 else if ((flag_openmp
|| flag_openmp_simd
)
871 locus old_loc
= gfc_current_locus
;
872 if (next_char () == '$')
875 if (c
== 'o' || c
== 'O')
877 if (skip_free_omp_sentinel (start
, old_loc
))
879 gfc_current_locus
= old_loc
;
883 if (continue_flag
|| c
== ' ' || c
== '\t')
885 gfc_current_locus
= old_loc
;
891 gfc_current_locus
= old_loc
;
893 else if (flag_openacc
894 && !(flag_openmp
|| flag_openmp_simd
))
896 locus old_loc
= gfc_current_locus
;
897 if (next_char () == '$')
900 if (c
== 'a' || c
== 'A')
902 if (skip_free_oacc_sentinel (start
, old_loc
))
904 gfc_current_locus
= old_loc
;
908 if (continue_flag
|| c
== ' ' || c
== '\t')
910 gfc_current_locus
= old_loc
;
916 gfc_current_locus
= old_loc
;
919 skip_comment_line ();
926 if (openmp_flag
&& at_bol
)
929 if (openacc_flag
&& at_bol
)
932 gcc_attribute_flag
= 0;
933 gfc_current_locus
= start
;
937 /* Return true if MP was matched in fixed form. */
939 skip_fixed_omp_sentinel (locus
*start
)
942 if (((c
= next_char ()) == 'm' || c
== 'M')
943 && ((c
= next_char ()) == 'p' || c
== 'P'))
948 || c
== ' ' || c
== '\t' || c
== '0'))
952 while (gfc_is_whitespace (c
));
953 if (c
!= '\n' && c
!= '!')
955 /* Canonicalize to *$omp. */
958 gfc_current_locus
= *start
;
966 /* Return true if CC was matched in fixed form. */
968 skip_fixed_oacc_sentinel (locus
*start
)
971 if (((c
= next_char ()) == 'c' || c
== 'C')
972 && ((c
= next_char ()) == 'c' || c
== 'C'))
977 || c
== ' ' || c
== '\t' || c
== '0'))
981 while (gfc_is_whitespace (c
));
982 if (c
!= '\n' && c
!= '!')
984 /* Canonicalize to *$acc. */
987 gfc_current_locus
= *start
;
995 /* Skip comment lines in fixed source mode. We have the same rules as
996 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
997 in column 1, and a '!' cannot be in column 6. Also, we deal with
998 lines with 'd' or 'D' in column 1, if the user requested this. */
1001 skip_fixed_comments (void)
1007 if (! gfc_at_bol ())
1009 start
= gfc_current_locus
;
1010 if (! gfc_at_eof ())
1014 while (gfc_is_whitespace (c
));
1017 gfc_advance_line ();
1019 skip_comment_line ();
1022 if (! gfc_at_bol ())
1024 gfc_current_locus
= start
;
1031 start
= gfc_current_locus
;
1038 gfc_advance_line ();
1042 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
1044 if (skip_gcc_attribute (start
))
1046 /* Canonicalize to *$omp. */
1051 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
1052 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
1054 2) handle OpenMP/OpenACC conditional compilation, where
1055 !$|c$|*$ should be treated as 2 spaces if the characters
1056 in columns 3 to 6 are valid fixed form label columns
1058 if (gfc_current_locus
.lb
!= NULL
1059 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1060 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1062 if ((flag_openmp
|| flag_openmp_simd
) && !flag_openacc
)
1064 if (next_char () == '$')
1067 if (c
== 'o' || c
== 'O')
1069 if (skip_fixed_omp_sentinel (&start
))
1073 goto check_for_digits
;
1075 gfc_current_locus
= start
;
1078 if (flag_openacc
&& !(flag_openmp
|| flag_openmp_simd
))
1080 if (next_char () == '$')
1083 if (c
== 'a' || c
== 'A')
1085 if (skip_fixed_oacc_sentinel (&start
))
1089 goto check_for_digits
;
1091 gfc_current_locus
= start
;
1094 if (flag_openacc
|| flag_openmp
|| flag_openmp_simd
)
1096 if (next_char () == '$')
1099 if (c
== 'a' || c
== 'A')
1101 if (skip_fixed_oacc_sentinel (&start
))
1104 else if (c
== 'o' || c
== 'O')
1106 if (skip_fixed_omp_sentinel (&start
))
1110 goto check_for_digits
;
1112 gfc_current_locus
= start
;
1115 skip_comment_line ();
1123 for (col
= 3; col
< 6; col
++, c
= next_char ())
1131 else if (c
< '0' || c
> '9')
1136 if (col
== 6 && c
!= '\n'
1137 && ((continue_flag
&& !digit_seen
)
1138 || c
== ' ' || c
== '\t' || c
== '0'))
1140 gfc_current_locus
= start
;
1141 start
.nextc
[0] = ' ';
1142 start
.nextc
[1] = ' ';
1146 skip_comment_line ();
1150 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
1152 if (gfc_option
.flag_d_lines
== 0)
1154 skip_comment_line ();
1158 *start
.nextc
= c
= ' ';
1163 while (gfc_is_whitespace (c
))
1171 gfc_advance_line ();
1175 if (col
!= 6 && c
== '!')
1177 if (gfc_current_locus
.lb
!= NULL
1178 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1179 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1180 skip_comment_line ();
1189 gcc_attribute_flag
= 0;
1190 gfc_current_locus
= start
;
1194 /* Skips the current line if it is a comment. */
1197 gfc_skip_comments (void)
1199 if (gfc_current_form
== FORM_FREE
)
1200 skip_free_comments ();
1202 skip_fixed_comments ();
1206 /* Get the next character from the input, taking continuation lines
1207 and end-of-line comments into account. This implies that comment
1208 lines between continued lines must be eaten here. For higher-level
1209 subroutines, this flattens continued lines into a single logical
1210 line. The in_string flag denotes whether we're inside a character
1214 gfc_next_char_literal (gfc_instring in_string
)
1217 int i
, prev_openmp_flag
, prev_openacc_flag
;
1221 prev_openacc_flag
= prev_openmp_flag
= 0;
1231 if (gfc_current_form
== FORM_FREE
)
1233 bool openmp_cond_flag
;
1235 if (!in_string
&& c
== '!')
1237 if (gcc_attribute_flag
1238 && memcmp (&gfc_current_locus
, &gcc_attribute_locus
,
1239 sizeof (gfc_current_locus
)) == 0)
1243 && memcmp (&gfc_current_locus
, &openmp_locus
,
1244 sizeof (gfc_current_locus
)) == 0)
1248 && memcmp (&gfc_current_locus
, &openacc_locus
,
1249 sizeof (gfc_current_locus
)) == 0)
1252 /* This line can't be continued */
1259 /* Avoid truncation warnings for comment ending lines. */
1260 gfc_current_locus
.lb
->truncated
= 0;
1265 /* Check to see if the continuation line was truncated. */
1266 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1267 && gfc_current_locus
.lb
->truncated
)
1269 int maxlen
= flag_free_line_length
;
1270 gfc_char_t
*current_nextc
= gfc_current_locus
.nextc
;
1272 gfc_current_locus
.lb
->truncated
= 0;
1273 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
+ maxlen
;
1274 gfc_warning_now (OPT_Wline_truncation
,
1275 "Line truncated at %L", &gfc_current_locus
);
1276 gfc_current_locus
.nextc
= current_nextc
;
1282 /* If the next nonblank character is a ! or \n, we've got a
1283 continuation line. */
1284 old_loc
= gfc_current_locus
;
1287 while (gfc_is_whitespace (c
))
1290 /* Character constants to be continued cannot have commentary
1291 after the '&'. However, there are cases where we may think we
1292 are still in a string and we are looking for a possible
1293 doubled quote and we end up here. See PR64506. */
1295 if (in_string
&& c
!= '\n')
1297 gfc_current_locus
= old_loc
;
1302 if (c
!= '!' && c
!= '\n')
1304 gfc_current_locus
= old_loc
;
1310 prev_openmp_flag
= openmp_flag
;
1312 prev_openacc_flag
= openacc_flag
;
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
? "Wrong OpenACC continuation at %C: "
1410 "expected !$ACC, got !$OMP"
1411 : "Wrong OpenMP continuation at %C: "
1412 "expected !$OMP, got !$ACC");
1417 if (in_string
&& gfc_current_locus
.nextc
)
1419 gfc_current_locus
.nextc
--;
1420 if (warn_ampersand
&& in_string
== INSTRING_WARN
)
1421 gfc_warning (OPT_Wampersand
,
1422 "Missing %<&%> in continued character "
1425 else if (!in_string
&& (c
== '\'' || c
== '"'))
1427 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1428 continuation line only optionally. */
1429 else if (openmp_flag
|| openacc_flag
|| openmp_cond_flag
)
1431 if (gfc_current_locus
.nextc
)
1432 gfc_current_locus
.nextc
--;
1437 gfc_current_locus
= old_loc
;
1442 else /* Fixed form. */
1444 /* Fixed form continuation. */
1445 if (in_string
!= INSTRING_WARN
&& c
== '!')
1447 /* Skip comment at end of line. */
1454 /* Avoid truncation warnings for comment ending lines. */
1455 gfc_current_locus
.lb
->truncated
= 0;
1461 /* Check to see if the continuation line was truncated. */
1462 if (warn_line_truncation
&& gfc_current_locus
.lb
!= NULL
1463 && gfc_current_locus
.lb
->truncated
)
1465 gfc_current_locus
.lb
->truncated
= 0;
1466 gfc_warning_now (OPT_Wline_truncation
,
1467 "Line truncated at %L", &gfc_current_locus
);
1471 prev_openmp_flag
= openmp_flag
;
1473 prev_openacc_flag
= openacc_flag
;
1476 old_loc
= gfc_current_locus
;
1478 gfc_advance_line ();
1479 skip_fixed_comments ();
1481 /* See if this line is a continuation line. */
1482 if (flag_openmp
&& openmp_flag
!= prev_openmp_flag
&& !openacc_flag
)
1484 openmp_flag
= prev_openmp_flag
;
1485 goto not_continuation
;
1487 if (flag_openacc
&& openacc_flag
!= prev_openacc_flag
&& !openmp_flag
)
1489 openacc_flag
= prev_openacc_flag
;
1490 goto not_continuation
;
1493 /* In case we have an OpenMP directive continued by OpenACC
1494 sentinel, or vice versa, we get both openmp_flag and
1496 if (openacc_flag
&& openmp_flag
)
1499 for (i
= 0; i
< 5; i
++)
1502 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1505 gfc_error (is_openmp
? "Wrong OpenACC continuation at %C: "
1506 "expected !$ACC, got !$OMP"
1507 : "Wrong OpenMP continuation at %C: "
1508 "expected !$OMP, got !$ACC");
1510 else if (!openmp_flag
&& !openacc_flag
)
1511 for (i
= 0; i
< 5; i
++)
1515 goto not_continuation
;
1517 else if (openmp_flag
)
1518 for (i
= 0; i
< 5; i
++)
1521 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1522 goto not_continuation
;
1524 else if (openacc_flag
)
1525 for (i
= 0; i
< 5; i
++)
1528 if (gfc_wide_tolower (c
) != (unsigned char) "*$acc"[i
])
1529 goto not_continuation
;
1533 if (c
== '0' || c
== ' ' || c
== '\n')
1534 goto not_continuation
;
1536 /* We've got a continuation line. If we are on the very next line after
1537 the last continuation, increment the continuation line count and
1538 check whether the limit has been exceeded. */
1539 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1541 if (++continue_count
== gfc_option
.max_continue_fixed
)
1543 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1544 gfc_warning (0, "Limit of %d continuations exceeded in "
1546 gfc_option
.max_continue_fixed
);
1550 if (gfc_current_locus
.lb
!= NULL
1551 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1552 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1555 /* Ready to read first character of continuation line, which might
1556 be another continuation line! */
1561 gfc_current_locus
= old_loc
;
1572 /* Get the next character of input, folded to lowercase. In fixed
1573 form mode, we also ignore spaces. When matcher subroutines are
1574 parsing character literals, they have to call
1575 gfc_next_char_literal(). */
1578 gfc_next_char (void)
1584 c
= gfc_next_char_literal (NONSTRING
);
1586 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1588 return gfc_wide_tolower (c
);
1592 gfc_next_ascii_char (void)
1594 gfc_char_t c
= gfc_next_char ();
1596 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1597 : (unsigned char) UCHAR_MAX
);
1602 gfc_peek_char (void)
1607 old_loc
= gfc_current_locus
;
1608 c
= gfc_next_char ();
1609 gfc_current_locus
= old_loc
;
1616 gfc_peek_ascii_char (void)
1618 gfc_char_t c
= gfc_peek_char ();
1620 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1621 : (unsigned char) UCHAR_MAX
);
1625 /* Recover from an error. We try to get past the current statement
1626 and get lined up for the next. The next statement follows a '\n'
1627 or a ';'. We also assume that we are not within a character
1628 constant, and deal with finding a '\'' or '"'. */
1631 gfc_error_recovery (void)
1633 gfc_char_t c
, delim
;
1640 c
= gfc_next_char ();
1641 if (c
== '\n' || c
== ';')
1644 if (c
!= '\'' && c
!= '"')
1673 /* Read ahead until the next character to be read is not whitespace. */
1676 gfc_gobble_whitespace (void)
1678 static int linenum
= 0;
1684 old_loc
= gfc_current_locus
;
1685 c
= gfc_next_char_literal (NONSTRING
);
1686 /* Issue a warning for nonconforming tabs. We keep track of the line
1687 number because the Fortran matchers will often back up and the same
1688 line will be scanned multiple times. */
1689 if (warn_tabs
&& c
== '\t')
1691 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1692 if (cur_linenum
!= linenum
)
1694 linenum
= cur_linenum
;
1695 gfc_warning_now (OPT_Wtabs
, "Nonconforming tab character at %C");
1699 while (gfc_is_whitespace (c
));
1701 gfc_current_locus
= old_loc
;
1705 /* Load a single line into pbuf.
1707 If pbuf points to a NULL pointer, it is allocated.
1708 We truncate lines that are too long, unless we're dealing with
1709 preprocessor lines or if the option -ffixed-line-length-none is set,
1710 in which case we reallocate the buffer to fit the entire line, if
1712 In fixed mode, we expand a tab that occurs within the statement
1713 label region to expand to spaces that leave the next character in
1716 If first_char is not NULL, it's a pointer to a single char value holding
1717 the first character of the line, which has already been read by the
1718 caller. This avoids the use of ungetc().
1720 load_line returns whether the line was truncated.
1722 NOTE: The error machinery isn't available at this point, so we can't
1723 easily report line and column numbers consistent with other
1724 parts of gfortran. */
1727 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1729 static int linenum
= 0, current_line
= 1;
1730 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1731 int trunc_flag
= 0, seen_comment
= 0;
1732 int seen_printable
= 0, seen_ampersand
= 0, quoted
= ' ';
1734 bool found_tab
= false;
1736 /* Determine the maximum allowed line length. */
1737 if (gfc_current_form
== FORM_FREE
)
1738 maxlen
= flag_free_line_length
;
1739 else if (gfc_current_form
== FORM_FIXED
)
1740 maxlen
= flag_fixed_line_length
;
1746 /* Allocate the line buffer, storing its length into buflen.
1747 Note that if maxlen==0, indicating that arbitrary-length lines
1748 are allowed, the buffer will be reallocated if this length is
1749 insufficient; since 132 characters is the length of a standard
1750 free-form line, we use that as a starting guess. */
1756 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1767 /* In order to not truncate preprocessor lines, we have to
1768 remember that this is one. */
1769 preprocessor_flag
= (c
== '#' ? 1 : 0);
1778 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1779 if (gfc_current_form
== FORM_FREE
1780 && !seen_printable
&& seen_ampersand
)
1783 gfc_error_now ("%<&%> not allowed by itself in line %d",
1786 gfc_warning_now (0, "%<&%> not allowed by itself in line %d",
1792 if (c
== '\r' || c
== '\0')
1793 goto next_char
; /* Gobble characters. */
1806 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1809 /* Is this a fixed-form comment? */
1810 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1811 && (c
== '*' || c
== 'c' || c
== 'd'))
1816 if (c
== '\'' || c
== '"')
1819 else if (c
== quoted
)
1822 /* Is this a free-form comment? */
1823 if (c
== '!' && quoted
== ' ')
1826 /* Vendor extension: "<tab>1" marks a continuation line. */
1830 if (c
>= '1' && c
<= '9')
1837 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1841 if (warn_tabs
&& seen_comment
== 0 && current_line
!= linenum
)
1843 linenum
= current_line
;
1844 gfc_warning_now (OPT_Wtabs
,
1845 "Nonconforming tab character in column %d "
1846 "of line %d", i
+1, linenum
);
1861 if (maxlen
== 0 || preprocessor_flag
)
1865 /* Reallocate line buffer to double size to hold the
1867 buflen
= buflen
* 2;
1868 *pbuf
= XRESIZEVEC (gfc_char_t
, *pbuf
, (buflen
+ 1));
1869 buffer
= (*pbuf
) + i
;
1872 else if (i
>= maxlen
)
1874 bool trunc_warn
= true;
1876 /* Enhancement, if the very next non-space character is an ampersand
1877 or comment that we would otherwise warn about, don't mark as
1880 /* Truncate the rest of the line. */
1884 if (c
== '\r' || c
== ' ')
1887 if (c
== '\n' || c
== EOF
)
1890 if (!trunc_warn
&& c
!= '!')
1893 if (trunc_warn
&& ((gfc_current_form
== FORM_FIXED
&& c
== '&')
1900 if (trunc_warn
&& !seen_comment
)
1912 /* Pad lines to the selected line length in fixed form. */
1913 if (gfc_current_form
== FORM_FIXED
1914 && flag_fixed_line_length
!= 0
1915 && !preprocessor_flag
1918 while (i
++ < maxlen
)
1930 /* Get a gfc_file structure, initialize it and add it to
1934 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1938 f
= XCNEW (gfc_file
);
1940 f
->filename
= xstrdup (name
);
1942 f
->next
= file_head
;
1945 f
->up
= current_file
;
1946 if (current_file
!= NULL
)
1947 f
->inclusion_line
= current_file
->line
;
1949 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1955 /* Deal with a line from the C preprocessor. The
1956 initial octothorp has already been seen. */
1959 preprocessor_line (gfc_char_t
*c
)
1963 gfc_char_t
*wide_filename
;
1965 int escaped
, unescape
;
1969 while (*c
== ' ' || *c
== '\t')
1972 if (*c
< '0' || *c
> '9')
1975 line
= wide_atoi (c
);
1977 c
= wide_strchr (c
, ' ');
1980 /* No file name given. Set new line number. */
1981 current_file
->line
= line
;
1986 while (*c
== ' ' || *c
== '\t')
1996 /* Make filename end at quote. */
1999 while (*c
&& ! (!escaped
&& *c
== '"'))
2003 else if (*c
== '\\')
2012 /* Preprocessor line has no closing quote. */
2017 /* Undo effects of cpp_quote_string. */
2020 gfc_char_t
*s
= wide_filename
;
2021 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
2037 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
2041 c
= wide_strchr (c
, ' ');
2048 if (1 <= i
&& i
<= 4)
2052 /* Convert the filename in wide characters into a filename in narrow
2054 filename
= gfc_widechar_to_char (wide_filename
, -1);
2056 /* Interpret flags. */
2058 if (flag
[1]) /* Starting new file. */
2060 f
= get_file (filename
, LC_RENAME
);
2061 add_file_change (f
->filename
, f
->inclusion_line
);
2065 if (flag
[2]) /* Ending current file. */
2067 if (!current_file
->up
2068 || filename_cmp (current_file
->up
->filename
, filename
) != 0)
2070 linemap_line_start (line_table
, current_file
->line
, 80);
2071 /* ??? One could compute the exact column where the filename
2072 starts and compute the exact location here. */
2073 gfc_warning_now_at (linemap_position_for_column (line_table
, 1),
2074 0, "file %qs left but not entered",
2076 current_file
->line
++;
2078 free (wide_filename
);
2083 add_file_change (NULL
, line
);
2084 current_file
= current_file
->up
;
2085 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
2086 current_file
->line
);
2089 /* The name of the file can be a temporary file produced by
2090 cpp. Replace the name if it is different. */
2092 if (filename_cmp (current_file
->filename
, filename
) != 0)
2094 /* FIXME: we leak the old filename because a pointer to it may be stored
2095 in the linemap. Alternative could be using GC or updating linemap to
2096 point to the new name, but there is no API for that currently. */
2097 current_file
->filename
= xstrdup (filename
);
2100 /* Set new line number. */
2101 current_file
->line
= line
;
2103 free (wide_filename
);
2108 linemap_line_start (line_table
, current_file
->line
, 80);
2109 /* ??? One could compute the exact column where the directive
2110 starts and compute the exact location here. */
2111 gfc_warning_now_at (linemap_position_for_column (line_table
, 2), 0,
2112 "Illegal preprocessor directive");
2113 current_file
->line
++;
2117 static bool load_file (const char *, const char *, bool);
2119 /* include_line()-- Checks a line buffer to see if it is an include
2120 line. If so, we call load_file() recursively to load the included
2121 file. We never return a syntax error because a statement like
2122 "include = 5" is perfectly legal. We return false if no include was
2123 processed or true if we matched an include. */
2126 include_line (gfc_char_t
*line
)
2128 gfc_char_t quote
, *c
, *begin
, *stop
;
2133 if (flag_openmp
|| flag_openmp_simd
)
2135 if (gfc_current_form
== FORM_FREE
)
2137 while (*c
== ' ' || *c
== '\t')
2139 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
2144 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
2145 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
2150 while (*c
== ' ' || *c
== '\t')
2153 if (gfc_wide_strncasecmp (c
, "include", 7))
2157 while (*c
== ' ' || *c
== '\t')
2160 /* Find filename between quotes. */
2163 if (quote
!= '"' && quote
!= '\'')
2168 while (*c
!= quote
&& *c
!= '\0')
2176 while (*c
== ' ' || *c
== '\t')
2179 if (*c
!= '\0' && *c
!= '!')
2182 /* We have an include line at this point. */
2184 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
2185 read by anything else. */
2187 filename
= gfc_widechar_to_char (begin
, -1);
2188 if (!load_file (filename
, NULL
, false))
2189 exit (FATAL_EXIT_CODE
);
2196 /* Load a file into memory by calling load_line until the file ends. */
2199 load_file (const char *realfilename
, const char *displayedname
, bool initial
)
2209 const char *filename
;
2210 /* If realfilename and displayedname are different and non-null then
2211 surely realfilename is the preprocessed form of
2213 bool preprocessed_p
= (realfilename
&& displayedname
2214 && strcmp (realfilename
, displayedname
));
2216 filename
= displayedname
? displayedname
: realfilename
;
2218 for (f
= current_file
; f
; f
= f
->up
)
2219 if (filename_cmp (filename
, f
->filename
) == 0)
2221 fprintf (stderr
, "%s:%d: Error: File '%s' is being included "
2222 "recursively\n", current_file
->filename
, current_file
->line
,
2231 input
= gfc_src_file
;
2232 gfc_src_file
= NULL
;
2235 input
= gfc_open_file (realfilename
);
2239 gfc_error_now ("Can't open file %qs", filename
);
2245 input
= gfc_open_included_file (realfilename
, false, false);
2248 fprintf (stderr
, "%s:%d: Error: Can't open included file '%s'\n",
2249 current_file
->filename
, current_file
->line
, filename
);
2252 stat_result
= stat (realfilename
, &st
);
2253 if (stat_result
== 0 && !S_ISREG(st
.st_mode
))
2255 fprintf (stderr
, "%s:%d: Error: Included path '%s'"
2256 " is not a regular file\n",
2257 current_file
->filename
, current_file
->line
, filename
);
2265 A "non-initial" file means a file that is being included. In
2266 that case we are creating an LC_ENTER map.
2268 An "initial" file means a main file; one that is not included.
2269 That file has already got at least one (surely more) line map(s)
2270 created by gfc_init. So the subsequent map created in that case
2271 must have LC_RENAME reason.
2273 This latter case is not true for a preprocessed file. In that
2274 case, although the file is "initial", the line maps created by
2275 gfc_init was used during the preprocessing of the file. Now that
2276 the preprocessing is over and we are being fed the result of that
2277 preprocessing, we need to create a brand new line map for the
2278 preprocessed file, so the reason is going to be LC_ENTER. */
2280 f
= get_file (filename
, (initial
&& !preprocessed_p
) ? LC_RENAME
: LC_ENTER
);
2282 add_file_change (f
->filename
, f
->inclusion_line
);
2284 current_file
->line
= 1;
2289 if (initial
&& gfc_src_preprocessor_lines
[0])
2291 preprocessor_line (gfc_src_preprocessor_lines
[0]);
2292 free (gfc_src_preprocessor_lines
[0]);
2293 gfc_src_preprocessor_lines
[0] = NULL
;
2294 if (gfc_src_preprocessor_lines
[1])
2296 preprocessor_line (gfc_src_preprocessor_lines
[1]);
2297 free (gfc_src_preprocessor_lines
[1]);
2298 gfc_src_preprocessor_lines
[1] = NULL
;
2304 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
2306 len
= gfc_wide_strlen (line
);
2307 if (feof (input
) && len
== 0)
2310 /* If this is the first line of the file, it can contain a byte
2311 order mark (BOM), which we will ignore:
2312 FF FE is UTF-16 little endian,
2313 FE FF is UTF-16 big endian,
2314 EF BB BF is UTF-8. */
2316 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
2317 && line
[1] == (unsigned char) '\xFE')
2318 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
2319 && line
[1] == (unsigned char) '\xFF')
2320 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
2321 && line
[1] == (unsigned char) '\xBB'
2322 && line
[2] == (unsigned char) '\xBF')))
2324 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
2325 gfc_char_t
*new_char
= gfc_get_wide_string (line_len
);
2327 wide_strcpy (new_char
, &line
[n
]);
2333 /* There are three things this line can be: a line of Fortran
2334 source, an include line or a C preprocessor directive. */
2338 /* When -g3 is specified, it's possible that we emit #define
2339 and #undef lines, which we need to pass to the middle-end
2340 so that it can emit correct debug info. */
2341 if (debug_info_level
== DINFO_LEVEL_VERBOSE
2342 && (wide_strncmp (line
, "#define ", 8) == 0
2343 || wide_strncmp (line
, "#undef ", 7) == 0))
2347 preprocessor_line (line
);
2352 /* Preprocessed files have preprocessor lines added before the byte
2353 order mark, so first_line is not about the first line of the file
2354 but the first line that's not a preprocessor line. */
2357 if (include_line (line
))
2359 current_file
->line
++;
2365 b
= XCNEWVAR (gfc_linebuf
, gfc_linebuf_header_size
2366 + (len
+ 1) * sizeof (gfc_char_t
));
2370 = linemap_line_start (line_table
, current_file
->line
++, len
);
2371 /* ??? We add the location for the maximum column possible here,
2372 because otherwise if the next call creates a new line-map, it
2373 will not reserve space for any offset. */
2375 linemap_position_for_column (line_table
, len
);
2377 b
->file
= current_file
;
2378 b
->truncated
= trunc
;
2379 wide_strcpy (b
->line
, line
);
2381 if (line_head
== NULL
)
2384 line_tail
->next
= b
;
2388 while (file_changes_cur
< file_changes_count
)
2389 file_changes
[file_changes_cur
++].lb
= b
;
2392 /* Release the line buffer allocated in load_line. */
2398 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
2399 current_file
= current_file
->up
;
2400 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
2405 /* Open a new file and start scanning from that file. Returns true
2406 if everything went OK, false otherwise. If form == FORM_UNKNOWN
2407 it tries to determine the source form from the filename, defaulting
2415 if (gfc_cpp_enabled ())
2417 result
= gfc_cpp_preprocess (gfc_source_file
);
2418 if (!gfc_cpp_preprocess_only ())
2419 result
= load_file (gfc_cpp_temporary_file (), gfc_source_file
, true);
2422 result
= load_file (gfc_source_file
, NULL
, true);
2424 gfc_current_locus
.lb
= line_head
;
2425 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
2427 #if 0 /* Debugging aid. */
2428 for (; line_head
; line_head
= line_head
->next
)
2429 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
2430 LOCATION_LINE (line_head
->location
), line_head
->line
);
2432 exit (SUCCESS_EXIT_CODE
);
2439 unescape_filename (const char *ptr
)
2441 const char *p
= ptr
, *s
;
2443 int escaped
, unescape
= 0;
2445 /* Make filename end at quote. */
2447 while (*p
&& ! (! escaped
&& *p
== '"'))
2451 else if (*p
== '\\')
2462 /* Undo effects of cpp_quote_string. */
2464 d
= XCNEWVEC (char, p
+ 1 - ptr
- unescape
);
2479 /* For preprocessed files, if the first tokens are of the form # NUM.
2480 handle the directives so we know the original file name. */
2483 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
2486 char *dirname
, *tmp
;
2488 gfc_src_file
= gfc_open_file (filename
);
2489 if (gfc_src_file
== NULL
)
2492 c
= getc (gfc_src_file
);
2498 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2500 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2503 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2504 filename
= unescape_filename (tmp
);
2506 if (filename
== NULL
)
2509 c
= getc (gfc_src_file
);
2515 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2517 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2520 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2521 dirname
= unescape_filename (tmp
);
2523 if (dirname
== NULL
)
2526 len
= strlen (dirname
);
2527 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2532 dirname
[len
- 2] = '\0';
2533 set_src_pwd (dirname
);
2535 if (! IS_ABSOLUTE_PATH (filename
))
2537 char *p
= XCNEWVEC (char, len
+ strlen (filename
));
2539 memcpy (p
, dirname
, len
- 2);
2541 strcpy (p
+ len
- 1, filename
);
2542 *canon_source_file
= p
;