2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* Set of subroutines to (ultimately) return the next character to the
23 various matching subroutines. This file's job is to read files and
24 build up lines that are parsed by the parser. This means that we
25 handle continuation lines and "include" lines.
27 The first thing the scanner does is to load an entire file into
28 memory. We load the entire file into memory for a couple reasons.
29 The first is that we want to be able to deal with nonseekable input
30 (pipes, stdin) and there is a lot of backing up involved during
33 The second is that we want to be able to print the locus of errors,
34 and an error on line 999999 could conflict with something on line
35 one. Given nonseekable input, we've got to store the whole thing.
37 One thing that helps are the column truncation limits that give us
38 an upper bound on the size of individual lines. We don't store the
41 From the scanner's viewpoint, the higher level subroutines ask for
42 new characters and do a lot of jumping backwards. */
52 /* Structure for holding module and include file search path. */
53 typedef struct gfc_directorylist
57 struct gfc_directorylist
*next
;
61 /* List of include file search directories. */
62 static gfc_directorylist
*include_dirs
, *intrinsic_modules_dirs
;
64 static gfc_file
*file_head
, *current_file
;
66 static int continue_flag
, end_flag
, openmp_flag
;
67 static int continue_count
, continue_line
;
68 static locus openmp_locus
;
70 gfc_source_form gfc_current_form
;
71 static gfc_linebuf
*line_head
, *line_tail
;
73 locus gfc_current_locus
;
74 const char *gfc_source_file
;
75 static FILE *gfc_src_file
;
76 static gfc_char_t
*gfc_src_preprocessor_lines
[2];
80 static struct gfc_file_change
86 size_t file_changes_cur
, file_changes_count
;
87 size_t file_changes_allocated
;
90 /* Functions dealing with our wide characters (gfc_char_t) and
91 sequences of such characters. */
94 gfc_wide_fits_in_byte (gfc_char_t c
)
96 return (c
<= UCHAR_MAX
);
100 wide_is_ascii (gfc_char_t c
)
102 return (gfc_wide_fits_in_byte (c
) && ((unsigned char) c
& ~0x7f) == 0);
106 gfc_wide_is_printable (gfc_char_t c
)
108 return (gfc_wide_fits_in_byte (c
) && ISPRINT ((unsigned char) c
));
112 gfc_wide_tolower (gfc_char_t c
)
114 return (wide_is_ascii (c
) ? (gfc_char_t
) TOLOWER((unsigned char) c
) : c
);
118 gfc_wide_toupper (gfc_char_t c
)
120 return (wide_is_ascii (c
) ? (gfc_char_t
) TOUPPER((unsigned char) c
) : c
);
124 gfc_wide_is_digit (gfc_char_t c
)
126 return (c
>= '0' && c
<= '9');
130 wide_atoi (gfc_char_t
*c
)
132 #define MAX_DIGITS 20
133 char buf
[MAX_DIGITS
+1];
136 while (gfc_wide_is_digit(*c
) && i
< MAX_DIGITS
)
143 gfc_wide_strlen (const gfc_char_t
*str
)
147 for (i
= 0; str
[i
]; i
++)
154 gfc_wide_memset (gfc_char_t
*b
, gfc_char_t c
, size_t len
)
158 for (i
= 0; i
< len
; i
++)
165 wide_strcpy (gfc_char_t
*dest
, const gfc_char_t
*src
)
169 for (d
= dest
; (*d
= *src
) != '\0'; ++src
, ++d
)
176 wide_strchr (const gfc_char_t
*s
, gfc_char_t c
)
181 return CONST_CAST(gfc_char_t
*, s
);
188 gfc_widechar_to_char (const gfc_char_t
*s
, int length
)
196 /* Passing a negative length is used to indicate that length should be
197 calculated using gfc_wide_strlen(). */
198 len
= (length
>= 0 ? (size_t) length
: gfc_wide_strlen (s
));
199 res
= gfc_getmem (len
+ 1);
201 for (i
= 0; i
< len
; i
++)
203 gcc_assert (gfc_wide_fits_in_byte (s
[i
]));
204 res
[i
] = (unsigned char) s
[i
];
212 gfc_char_to_widechar (const char *s
)
221 res
= gfc_get_wide_string (len
+ 1);
223 for (i
= 0; i
< len
; i
++)
224 res
[i
] = (unsigned char) s
[i
];
231 wide_strncmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
240 return (c1
> c2
? 1 : -1);
248 gfc_wide_strncasecmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
254 c1
= gfc_wide_tolower (*s1
++);
255 c2
= TOLOWER (*s2
++);
257 return (c1
> c2
? 1 : -1);
265 /* Main scanner initialization. */
268 gfc_scanner_init_1 (void)
281 /* Main scanner destructor. */
284 gfc_scanner_done_1 (void)
289 while(line_head
!= NULL
)
291 lb
= line_head
->next
;
296 while(file_head
!= NULL
)
299 gfc_free(file_head
->filename
);
306 /* Adds path to the list pointed to by list. */
309 add_path_to_list (gfc_directorylist
**list
, const char *path
,
310 bool use_for_modules
)
312 gfc_directorylist
*dir
;
316 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
322 dir
= *list
= gfc_getmem (sizeof (gfc_directorylist
));
328 dir
->next
= gfc_getmem (sizeof (gfc_directorylist
));
333 dir
->use_for_modules
= use_for_modules
;
334 dir
->path
= gfc_getmem (strlen (p
) + 2);
335 strcpy (dir
->path
, p
);
336 strcat (dir
->path
, "/"); /* make '/' last character */
341 gfc_add_include_path (const char *path
, bool use_for_modules
)
343 add_path_to_list (&include_dirs
, path
, use_for_modules
);
344 gfc_cpp_add_include_path (xstrdup(path
), true);
349 gfc_add_intrinsic_modules_path (const char *path
)
351 add_path_to_list (&intrinsic_modules_dirs
, path
, true);
355 /* Release resources allocated for options. */
358 gfc_release_include_path (void)
360 gfc_directorylist
*p
;
362 while (include_dirs
!= NULL
)
365 include_dirs
= include_dirs
->next
;
370 while (intrinsic_modules_dirs
!= NULL
)
372 p
= intrinsic_modules_dirs
;
373 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
378 gfc_free (gfc_option
.module_dir
);
383 open_included_file (const char *name
, gfc_directorylist
*list
, bool module
)
386 gfc_directorylist
*p
;
389 for (p
= list
; p
; p
= p
->next
)
391 if (module
&& !p
->use_for_modules
)
394 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
395 strcpy (fullname
, p
->path
);
396 strcat (fullname
, name
);
398 f
= gfc_open_file (fullname
);
407 /* Opens file for reading, searching through the include directories
408 given if necessary. If the include_cwd argument is true, we try
409 to open the file in the current directory first. */
412 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
416 if (IS_ABSOLUTE_PATH (name
))
417 return gfc_open_file (name
);
421 f
= gfc_open_file (name
);
426 return open_included_file (name
, include_dirs
, module
);
430 gfc_open_intrinsic_module (const char *name
)
432 if (IS_ABSOLUTE_PATH (name
))
433 return gfc_open_file (name
);
435 return open_included_file (name
, intrinsic_modules_dirs
, true);
439 /* Test to see if we're at the end of the main source file. */
448 /* Test to see if we're at the end of the current file. */
456 if (line_head
== NULL
)
457 return 1; /* Null file */
459 if (gfc_current_locus
.lb
== NULL
)
466 /* Test to see if we're at the beginning of a new line. */
474 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
478 /* Test to see if we're at the end of a line. */
486 return (*gfc_current_locus
.nextc
== '\0');
490 add_file_change (const char *filename
, int line
)
492 if (file_changes_count
== file_changes_allocated
)
494 if (file_changes_allocated
)
495 file_changes_allocated
*= 2;
497 file_changes_allocated
= 16;
499 = xrealloc (file_changes
,
500 file_changes_allocated
* sizeof (*file_changes
));
502 file_changes
[file_changes_count
].filename
= filename
;
503 file_changes
[file_changes_count
].lb
= NULL
;
504 file_changes
[file_changes_count
++].line
= line
;
508 report_file_change (gfc_linebuf
*lb
)
510 size_t c
= file_changes_cur
;
511 while (c
< file_changes_count
512 && file_changes
[c
].lb
== lb
)
514 if (file_changes
[c
].filename
)
515 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
516 file_changes
[c
].filename
);
518 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
521 file_changes_cur
= c
;
525 gfc_start_source_files (void)
527 /* If the debugger wants the name of the main source file,
529 if (debug_hooks
->start_end_main_source_file
)
530 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
532 file_changes_cur
= 0;
533 report_file_change (gfc_current_locus
.lb
);
537 gfc_end_source_files (void)
539 report_file_change (NULL
);
541 if (debug_hooks
->start_end_main_source_file
)
542 (*debug_hooks
->end_source_file
) (0);
545 /* Advance the current line pointer to the next line. */
548 gfc_advance_line (void)
553 if (gfc_current_locus
.lb
== NULL
)
559 if (gfc_current_locus
.lb
->next
560 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
562 report_file_change (gfc_current_locus
.lb
->next
);
563 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
566 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
568 if (gfc_current_locus
.lb
!= NULL
)
569 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
572 gfc_current_locus
.nextc
= NULL
;
578 /* Get the next character from the input, advancing gfc_current_file's
579 locus. When we hit the end of the line or the end of the file, we
580 start returning a '\n' in order to complete the current statement.
581 No Fortran line conventions are implemented here.
583 Requiring explicit advances to the next line prevents the parse
584 pointer from being on the wrong line if the current statement ends
592 if (gfc_current_locus
.nextc
== NULL
)
595 c
= *gfc_current_locus
.nextc
++;
598 gfc_current_locus
.nextc
--; /* Remain on this line. */
606 /* Skip a comment. When we come here the parse pointer is positioned
607 immediately after the comment character. If we ever implement
608 compiler directives withing comments, here is where we parse the
612 skip_comment_line (void)
627 gfc_define_undef_line (void)
631 /* All lines beginning with '#' are either #define or #undef. */
632 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
635 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
637 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
638 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
643 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
645 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
646 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
651 /* Skip the rest of the line. */
652 skip_comment_line ();
658 /* Comment lines are null lines, lines containing only blanks or lines
659 on which the first nonblank line is a '!'.
660 Return true if !$ openmp conditional compilation sentinel was
664 skip_free_comments (void)
672 at_bol
= gfc_at_bol ();
673 start
= gfc_current_locus
;
679 while (gfc_is_whitespace (c
));
689 /* If -fopenmp, we need to handle here 2 things:
690 1) don't treat !$omp as comments, but directives
691 2) handle OpenMP conditional compilation, where
692 !$ should be treated as 2 spaces (for initial lines
693 only if followed by space). */
694 if (gfc_option
.flag_openmp
&& at_bol
)
696 locus old_loc
= gfc_current_locus
;
697 if (next_char () == '$')
700 if (c
== 'o' || c
== 'O')
702 if (((c
= next_char ()) == 'm' || c
== 'M')
703 && ((c
= next_char ()) == 'p' || c
== 'P'))
705 if ((c
= next_char ()) == ' ' || c
== '\t'
708 while (gfc_is_whitespace (c
))
710 if (c
!= '\n' && c
!= '!')
713 openmp_locus
= old_loc
;
714 gfc_current_locus
= start
;
719 gfc_warning_now ("!$OMP at %C starts a commented "
720 "line as it neither is followed "
721 "by a space nor is a "
722 "continuation line");
724 gfc_current_locus
= old_loc
;
728 if (continue_flag
|| c
== ' ' || c
== '\t')
730 gfc_current_locus
= old_loc
;
736 gfc_current_locus
= old_loc
;
738 skip_comment_line ();
745 if (openmp_flag
&& at_bol
)
747 gfc_current_locus
= start
;
752 /* Skip comment lines in fixed source mode. We have the same rules as
753 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
754 in column 1, and a '!' cannot be in column 6. Also, we deal with
755 lines with 'd' or 'D' in column 1, if the user requested this. */
758 skip_fixed_comments (void)
766 start
= gfc_current_locus
;
771 while (gfc_is_whitespace (c
));
776 skip_comment_line ();
781 gfc_current_locus
= start
;
788 start
= gfc_current_locus
;
799 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
801 /* If -fopenmp, we need to handle here 2 things:
802 1) don't treat !$omp|c$omp|*$omp as comments, but directives
803 2) handle OpenMP conditional compilation, where
804 !$|c$|*$ should be treated as 2 spaces if the characters
805 in columns 3 to 6 are valid fixed form label columns
807 if (gfc_current_locus
.lb
!= NULL
808 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
809 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
811 if (gfc_option
.flag_openmp
)
813 if (next_char () == '$')
816 if (c
== 'o' || c
== 'O')
818 if (((c
= next_char ()) == 'm' || c
== 'M')
819 && ((c
= next_char ()) == 'p' || c
== 'P'))
823 && ((openmp_flag
&& continue_flag
)
824 || c
== ' ' || c
== '\t' || c
== '0'))
828 while (gfc_is_whitespace (c
));
829 if (c
!= '\n' && c
!= '!')
831 /* Canonicalize to *$omp. */
834 gfc_current_locus
= start
;
844 for (col
= 3; col
< 6; col
++, c
= next_char ())
852 else if (c
< '0' || c
> '9')
857 if (col
== 6 && c
!= '\n'
858 && ((continue_flag
&& !digit_seen
)
859 || c
== ' ' || c
== '\t' || c
== '0'))
861 gfc_current_locus
= start
;
862 start
.nextc
[0] = ' ';
863 start
.nextc
[1] = ' ';
868 gfc_current_locus
= start
;
870 skip_comment_line ();
874 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
876 if (gfc_option
.flag_d_lines
== 0)
878 skip_comment_line ();
882 *start
.nextc
= c
= ' ';
887 while (gfc_is_whitespace (c
))
899 if (col
!= 6 && c
== '!')
901 if (gfc_current_locus
.lb
!= NULL
902 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
903 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
904 skip_comment_line ();
912 gfc_current_locus
= start
;
916 /* Skips the current line if it is a comment. */
919 gfc_skip_comments (void)
921 if (gfc_current_form
== FORM_FREE
)
922 skip_free_comments ();
924 skip_fixed_comments ();
928 /* Get the next character from the input, taking continuation lines
929 and end-of-line comments into account. This implies that comment
930 lines between continued lines must be eaten here. For higher-level
931 subroutines, this flattens continued lines into a single logical
932 line. The in_string flag denotes whether we're inside a character
936 gfc_next_char_literal (int in_string
)
939 int i
, prev_openmp_flag
;
952 if (gfc_current_form
== FORM_FREE
)
954 bool openmp_cond_flag
;
956 if (!in_string
&& c
== '!')
959 && memcmp (&gfc_current_locus
, &openmp_locus
,
960 sizeof (gfc_current_locus
)) == 0)
963 /* This line can't be continued */
970 /* Avoid truncation warnings for comment ending lines. */
971 gfc_current_locus
.lb
->truncated
= 0;
979 /* If the next nonblank character is a ! or \n, we've got a
980 continuation line. */
981 old_loc
= gfc_current_locus
;
984 while (gfc_is_whitespace (c
))
987 /* Character constants to be continued cannot have commentary
990 if (in_string
&& c
!= '\n')
992 gfc_current_locus
= old_loc
;
997 if (c
!= '!' && c
!= '\n')
999 gfc_current_locus
= old_loc
;
1004 prev_openmp_flag
= openmp_flag
;
1007 skip_comment_line ();
1009 gfc_advance_line ();
1012 goto not_continuation
;
1014 /* We've got a continuation line. If we are on the very next line after
1015 the last continuation, increment the continuation line count and
1016 check whether the limit has been exceeded. */
1017 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1019 if (++continue_count
== gfc_option
.max_continue_free
)
1021 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1022 gfc_warning ("Limit of %d continuations exceeded in "
1023 "statement at %C", gfc_option
.max_continue_free
);
1027 /* Now find where it continues. First eat any comment lines. */
1028 openmp_cond_flag
= skip_free_comments ();
1030 if (gfc_current_locus
.lb
!= NULL
1031 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1032 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1034 if (prev_openmp_flag
!= openmp_flag
)
1036 gfc_current_locus
= old_loc
;
1037 openmp_flag
= prev_openmp_flag
;
1042 /* Now that we have a non-comment line, probe ahead for the
1043 first non-whitespace character. If it is another '&', then
1044 reading starts at the next character, otherwise we must back
1045 up to where the whitespace started and resume from there. */
1047 old_loc
= gfc_current_locus
;
1050 while (gfc_is_whitespace (c
))
1055 for (i
= 0; i
< 5; i
++, c
= next_char ())
1057 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1059 old_loc
= gfc_current_locus
;
1061 while (gfc_is_whitespace (c
))
1069 if (gfc_option
.warn_ampersand
)
1070 gfc_warning_now ("Missing '&' in continued character "
1072 gfc_current_locus
.nextc
--;
1074 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1075 continuation line only optionally. */
1076 else if (openmp_flag
|| openmp_cond_flag
)
1077 gfc_current_locus
.nextc
--;
1081 gfc_current_locus
= old_loc
;
1088 /* Fixed form continuation. */
1089 if (!in_string
&& c
== '!')
1091 /* Skip comment at end of line. */
1098 /* Avoid truncation warnings for comment ending lines. */
1099 gfc_current_locus
.lb
->truncated
= 0;
1105 prev_openmp_flag
= openmp_flag
;
1107 old_loc
= gfc_current_locus
;
1109 gfc_advance_line ();
1110 skip_fixed_comments ();
1112 /* See if this line is a continuation line. */
1113 if (openmp_flag
!= prev_openmp_flag
)
1115 openmp_flag
= prev_openmp_flag
;
1116 goto not_continuation
;
1120 for (i
= 0; i
< 5; i
++)
1124 goto not_continuation
;
1127 for (i
= 0; i
< 5; i
++)
1130 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1131 goto not_continuation
;
1135 if (c
== '0' || c
== ' ' || c
== '\n')
1136 goto not_continuation
;
1138 /* We've got a continuation line. If we are on the very next line after
1139 the last continuation, increment the continuation line count and
1140 check whether the limit has been exceeded. */
1141 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1143 if (++continue_count
== gfc_option
.max_continue_fixed
)
1145 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1146 gfc_warning ("Limit of %d continuations exceeded in "
1148 gfc_option
.max_continue_fixed
);
1152 if (gfc_current_locus
.lb
!= NULL
1153 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1154 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1157 /* Ready to read first character of continuation line, which might
1158 be another continuation line! */
1163 gfc_current_locus
= old_loc
;
1173 /* Get the next character of input, folded to lowercase. In fixed
1174 form mode, we also ignore spaces. When matcher subroutines are
1175 parsing character literals, they have to call
1176 gfc_next_char_literal(). */
1179 gfc_next_char (void)
1185 c
= gfc_next_char_literal (0);
1187 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1189 return gfc_wide_tolower (c
);
1193 gfc_next_ascii_char (void)
1195 gfc_char_t c
= gfc_next_char ();
1197 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1198 : (unsigned char) UCHAR_MAX
);
1203 gfc_peek_char (void)
1208 old_loc
= gfc_current_locus
;
1209 c
= gfc_next_char ();
1210 gfc_current_locus
= old_loc
;
1217 gfc_peek_ascii_char (void)
1219 gfc_char_t c
= gfc_peek_char ();
1221 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1222 : (unsigned char) UCHAR_MAX
);
1226 /* Recover from an error. We try to get past the current statement
1227 and get lined up for the next. The next statement follows a '\n'
1228 or a ';'. We also assume that we are not within a character
1229 constant, and deal with finding a '\'' or '"'. */
1232 gfc_error_recovery (void)
1234 gfc_char_t c
, delim
;
1241 c
= gfc_next_char ();
1242 if (c
== '\n' || c
== ';')
1245 if (c
!= '\'' && c
!= '"')
1274 /* Read ahead until the next character to be read is not whitespace. */
1277 gfc_gobble_whitespace (void)
1279 static int linenum
= 0;
1285 old_loc
= gfc_current_locus
;
1286 c
= gfc_next_char_literal (0);
1287 /* Issue a warning for nonconforming tabs. We keep track of the line
1288 number because the Fortran matchers will often back up and the same
1289 line will be scanned multiple times. */
1290 if (!gfc_option
.warn_tabs
&& c
== '\t')
1292 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1293 if (cur_linenum
!= linenum
)
1295 linenum
= cur_linenum
;
1296 gfc_warning_now ("Nonconforming tab character at %C");
1300 while (gfc_is_whitespace (c
));
1302 gfc_current_locus
= old_loc
;
1306 /* Load a single line into pbuf.
1308 If pbuf points to a NULL pointer, it is allocated.
1309 We truncate lines that are too long, unless we're dealing with
1310 preprocessor lines or if the option -ffixed-line-length-none is set,
1311 in which case we reallocate the buffer to fit the entire line, if
1313 In fixed mode, we expand a tab that occurs within the statement
1314 label region to expand to spaces that leave the next character in
1317 If first_char is not NULL, it's a pointer to a single char value holding
1318 the first character of the line, which has already been read by the
1319 caller. This avoids the use of ungetc().
1321 load_line returns whether the line was truncated.
1323 NOTE: The error machinery isn't available at this point, so we can't
1324 easily report line and column numbers consistent with other
1325 parts of gfortran. */
1328 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
, const int *first_char
)
1330 static int linenum
= 0, current_line
= 1;
1331 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1332 int trunc_flag
= 0, seen_comment
= 0;
1333 int seen_printable
= 0, seen_ampersand
= 0;
1335 bool found_tab
= false;
1337 /* Determine the maximum allowed line length. */
1338 if (gfc_current_form
== FORM_FREE
)
1339 maxlen
= gfc_option
.free_line_length
;
1340 else if (gfc_current_form
== FORM_FIXED
)
1341 maxlen
= gfc_option
.fixed_line_length
;
1347 /* Allocate the line buffer, storing its length into buflen.
1348 Note that if maxlen==0, indicating that arbitrary-length lines
1349 are allowed, the buffer will be reallocated if this length is
1350 insufficient; since 132 characters is the length of a standard
1351 free-form line, we use that as a starting guess. */
1357 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1368 /* In order to not truncate preprocessor lines, we have to
1369 remember that this is one. */
1370 preprocessor_flag
= (c
== '#' ? 1 : 0);
1379 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1380 if (gfc_current_form
== FORM_FREE
1381 && !seen_printable
&& seen_ampersand
)
1384 gfc_error_now ("'&' not allowed by itself in line %d",
1387 gfc_warning_now ("'&' not allowed by itself in line %d",
1393 if (c
== '\r' || c
== '\0')
1394 goto next_char
; /* Gobble characters. */
1404 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1407 /* Is this a fixed-form comment? */
1408 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1409 && (c
== '*' || c
== 'c' || c
== 'd'))
1412 /* Vendor extension: "<tab>1" marks a continuation line. */
1416 if (c
>= '1' && c
<= '9')
1423 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1427 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1428 && current_line
!= linenum
)
1430 linenum
= current_line
;
1431 gfc_warning_now ("Nonconforming tab character in column %d "
1432 "of line %d", i
+1, linenum
);
1447 if (maxlen
== 0 || preprocessor_flag
)
1451 /* Reallocate line buffer to double size to hold the
1453 buflen
= buflen
* 2;
1454 *pbuf
= xrealloc (*pbuf
, (buflen
+ 1) * sizeof (gfc_char_t
));
1455 buffer
= (*pbuf
) + i
;
1458 else if (i
>= maxlen
)
1460 /* Truncate the rest of the line. */
1464 if (c
== '\n' || c
== EOF
)
1478 /* Pad lines to the selected line length in fixed form. */
1479 if (gfc_current_form
== FORM_FIXED
1480 && gfc_option
.fixed_line_length
!= 0
1481 && !preprocessor_flag
1484 while (i
++ < maxlen
)
1496 /* Get a gfc_file structure, initialize it and add it to
1500 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1504 f
= gfc_getmem (sizeof (gfc_file
));
1506 f
->filename
= gfc_getmem (strlen (name
) + 1);
1507 strcpy (f
->filename
, name
);
1509 f
->next
= file_head
;
1512 f
->up
= current_file
;
1513 if (current_file
!= NULL
)
1514 f
->inclusion_line
= current_file
->line
;
1516 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1522 /* Deal with a line from the C preprocessor. The
1523 initial octothorp has already been seen. */
1526 preprocessor_line (gfc_char_t
*c
)
1530 gfc_char_t
*wide_filename
;
1532 int escaped
, unescape
;
1536 while (*c
== ' ' || *c
== '\t')
1539 if (*c
< '0' || *c
> '9')
1542 line
= wide_atoi (c
);
1544 c
= wide_strchr (c
, ' ');
1547 /* No file name given. Set new line number. */
1548 current_file
->line
= line
;
1553 while (*c
== ' ' || *c
== '\t')
1563 /* Make filename end at quote. */
1566 while (*c
&& ! (!escaped
&& *c
== '"'))
1570 else if (*c
== '\\')
1579 /* Preprocessor line has no closing quote. */
1584 /* Undo effects of cpp_quote_string. */
1587 gfc_char_t
*s
= wide_filename
;
1588 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
1604 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1608 c
= wide_strchr (c
, ' ');
1615 if (1 <= i
&& i
<= 4)
1619 /* Convert the filename in wide characters into a filename in narrow
1621 filename
= gfc_widechar_to_char (wide_filename
, -1);
1623 /* Interpret flags. */
1625 if (flag
[1]) /* Starting new file. */
1627 f
= get_file (filename
, LC_RENAME
);
1628 add_file_change (f
->filename
, f
->inclusion_line
);
1632 if (flag
[2]) /* Ending current file. */
1634 if (!current_file
->up
1635 || strcmp (current_file
->up
->filename
, filename
) != 0)
1637 gfc_warning_now ("%s:%d: file %s left but not entered",
1638 current_file
->filename
, current_file
->line
,
1641 gfc_free (wide_filename
);
1642 gfc_free (filename
);
1646 add_file_change (NULL
, line
);
1647 current_file
= current_file
->up
;
1648 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
1649 current_file
->line
);
1652 /* The name of the file can be a temporary file produced by
1653 cpp. Replace the name if it is different. */
1655 if (strcmp (current_file
->filename
, filename
) != 0)
1657 gfc_free (current_file
->filename
);
1658 current_file
->filename
= gfc_getmem (strlen (filename
) + 1);
1659 strcpy (current_file
->filename
, filename
);
1662 /* Set new line number. */
1663 current_file
->line
= line
;
1665 gfc_free (wide_filename
);
1666 gfc_free (filename
);
1670 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1671 current_file
->filename
, current_file
->line
);
1672 current_file
->line
++;
1676 static try load_file (const char *, bool);
1678 /* include_line()-- Checks a line buffer to see if it is an include
1679 line. If so, we call load_file() recursively to load the included
1680 file. We never return a syntax error because a statement like
1681 "include = 5" is perfectly legal. We return false if no include was
1682 processed or true if we matched an include. */
1685 include_line (gfc_char_t
*line
)
1687 gfc_char_t quote
, *c
, *begin
, *stop
;
1692 if (gfc_option
.flag_openmp
)
1694 if (gfc_current_form
== FORM_FREE
)
1696 while (*c
== ' ' || *c
== '\t')
1698 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1703 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1704 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1709 while (*c
== ' ' || *c
== '\t')
1712 if (gfc_wide_strncasecmp (c
, "include", 7))
1716 while (*c
== ' ' || *c
== '\t')
1719 /* Find filename between quotes. */
1722 if (quote
!= '"' && quote
!= '\'')
1727 while (*c
!= quote
&& *c
!= '\0')
1735 while (*c
== ' ' || *c
== '\t')
1738 if (*c
!= '\0' && *c
!= '!')
1741 /* We have an include line at this point. */
1743 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1744 read by anything else. */
1746 filename
= gfc_widechar_to_char (begin
, -1);
1747 load_file (filename
, false);
1748 gfc_free (filename
);
1753 /* Load a file into memory by calling load_line until the file ends. */
1756 load_file (const char *filename
, bool initial
)
1765 for (f
= current_file
; f
; f
= f
->up
)
1766 if (strcmp (filename
, f
->filename
) == 0)
1768 gfc_error_now ("File '%s' is being included recursively", filename
);
1776 input
= gfc_src_file
;
1777 gfc_src_file
= NULL
;
1780 input
= gfc_open_file (filename
);
1783 gfc_error_now ("Can't open file '%s'", filename
);
1789 input
= gfc_open_included_file (filename
, false, false);
1792 gfc_error_now ("Can't open included file '%s'", filename
);
1797 /* Load the file. */
1799 f
= get_file (filename
, initial
? LC_RENAME
: LC_ENTER
);
1801 add_file_change (f
->filename
, f
->inclusion_line
);
1803 current_file
->line
= 1;
1808 if (initial
&& gfc_src_preprocessor_lines
[0])
1810 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1811 gfc_free (gfc_src_preprocessor_lines
[0]);
1812 gfc_src_preprocessor_lines
[0] = NULL
;
1813 if (gfc_src_preprocessor_lines
[1])
1815 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1816 gfc_free (gfc_src_preprocessor_lines
[1]);
1817 gfc_src_preprocessor_lines
[1] = NULL
;
1823 int trunc
= load_line (input
, &line
, &line_len
, NULL
);
1825 len
= gfc_wide_strlen (line
);
1826 if (feof (input
) && len
== 0)
1829 /* If this is the first line of the file, it can contain a byte
1830 order mark (BOM), which we will ignore:
1831 FF FE is UTF-16 little endian,
1832 FE FF is UTF-16 big endian,
1833 EF BB BF is UTF-8. */
1835 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
1836 && line
[1] == (unsigned char) '\xFE')
1837 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
1838 && line
[1] == (unsigned char) '\xFF')
1839 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
1840 && line
[1] == (unsigned char) '\xBB'
1841 && line
[2] == (unsigned char) '\xBF')))
1843 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
1844 gfc_char_t
*new = gfc_get_wide_string (line_len
);
1846 wide_strcpy (new, &line
[n
]);
1852 /* There are three things this line can be: a line of Fortran
1853 source, an include line or a C preprocessor directive. */
1857 /* When -g3 is specified, it's possible that we emit #define
1858 and #undef lines, which we need to pass to the middle-end
1859 so that it can emit correct debug info. */
1860 if (debug_info_level
== DINFO_LEVEL_VERBOSE
1861 && (wide_strncmp (line
, "#define ", 8) == 0
1862 || wide_strncmp (line
, "#undef ", 7) == 0))
1866 preprocessor_line (line
);
1871 /* Preprocessed files have preprocessor lines added before the byte
1872 order mark, so first_line is not about the first line of the file
1873 but the first line that's not a preprocessor line. */
1876 if (include_line (line
))
1878 current_file
->line
++;
1884 b
= gfc_getmem (gfc_linebuf_header_size
1885 + (len
+ 1) * sizeof (gfc_char_t
));
1888 = linemap_line_start (line_table
, current_file
->line
++, 120);
1889 b
->file
= current_file
;
1890 b
->truncated
= trunc
;
1891 wide_strcpy (b
->line
, line
);
1893 if (line_head
== NULL
)
1896 line_tail
->next
= b
;
1900 while (file_changes_cur
< file_changes_count
)
1901 file_changes
[file_changes_cur
++].lb
= b
;
1904 /* Release the line buffer allocated in load_line. */
1910 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
1911 current_file
= current_file
->up
;
1912 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
1917 /* Open a new file and start scanning from that file. Returns SUCCESS
1918 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1919 it tries to determine the source form from the filename, defaulting
1927 if (gfc_cpp_enabled ())
1929 result
= gfc_cpp_preprocess (gfc_source_file
);
1930 if (!gfc_cpp_preprocess_only ())
1931 result
= load_file (gfc_cpp_temporary_file (), true);
1934 result
= load_file (gfc_source_file
, true);
1936 gfc_current_locus
.lb
= line_head
;
1937 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
1939 #if 0 /* Debugging aid. */
1940 for (; line_head
; line_head
= line_head
->next
)
1941 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
1942 LOCATION_LINE (line_head
->location
), line_head
->line
);
1951 unescape_filename (const char *ptr
)
1953 const char *p
= ptr
, *s
;
1955 int escaped
, unescape
= 0;
1957 /* Make filename end at quote. */
1959 while (*p
&& ! (! escaped
&& *p
== '"'))
1963 else if (*p
== '\\')
1974 /* Undo effects of cpp_quote_string. */
1976 d
= gfc_getmem (p
+ 1 - ptr
- unescape
);
1991 /* For preprocessed files, if the first tokens are of the form # NUM.
1992 handle the directives so we know the original file name. */
1995 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
1998 char *dirname
, *tmp
;
2000 gfc_src_file
= gfc_open_file (filename
);
2001 if (gfc_src_file
== NULL
)
2004 c
= getc (gfc_src_file
);
2010 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
, &c
);
2012 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
2015 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
2016 filename
= unescape_filename (tmp
);
2018 if (filename
== NULL
)
2021 c
= getc (gfc_src_file
);
2027 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
, &c
);
2029 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2032 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2033 dirname
= unescape_filename (tmp
);
2035 if (dirname
== NULL
)
2038 len
= strlen (dirname
);
2039 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2044 dirname
[len
- 2] = '\0';
2045 set_src_pwd (dirname
);
2047 if (! IS_ABSOLUTE_PATH (filename
))
2049 char *p
= gfc_getmem (len
+ strlen (filename
));
2051 memcpy (p
, dirname
, len
- 2);
2053 strcpy (p
+ len
- 1, filename
);
2054 *canon_source_file
= p
;