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. */
51 /* Structure for holding module and include file search path. */
52 typedef struct gfc_directorylist
56 struct gfc_directorylist
*next
;
60 /* List of include file search directories. */
61 static gfc_directorylist
*include_dirs
, *intrinsic_modules_dirs
;
63 static gfc_file
*file_head
, *current_file
;
65 static int continue_flag
, end_flag
, openmp_flag
;
66 static int continue_count
, continue_line
;
67 static locus openmp_locus
;
69 gfc_source_form gfc_current_form
;
70 static gfc_linebuf
*line_head
, *line_tail
;
72 locus gfc_current_locus
;
73 const char *gfc_source_file
;
74 static FILE *gfc_src_file
;
75 static gfc_char_t
*gfc_src_preprocessor_lines
[2];
79 static struct gfc_file_change
85 size_t file_changes_cur
, file_changes_count
;
86 size_t file_changes_allocated
;
89 /* Functions dealing with our wide characters (gfc_char_t) and
90 sequences of such characters. */
93 gfc_wide_fits_in_byte (gfc_char_t c
)
95 return (c
<= UCHAR_MAX
);
99 wide_is_ascii (gfc_char_t c
)
101 return (gfc_wide_fits_in_byte (c
) && ((unsigned char) c
& ~0x7f) == 0);
105 gfc_wide_is_printable (gfc_char_t c
)
107 return (gfc_wide_fits_in_byte (c
) && ISPRINT ((unsigned char) c
));
111 gfc_wide_tolower (gfc_char_t c
)
113 return (wide_is_ascii (c
) ? (gfc_char_t
) TOLOWER((unsigned char) c
) : c
);
117 gfc_wide_toupper (gfc_char_t c
)
119 return (wide_is_ascii (c
) ? (gfc_char_t
) TOUPPER((unsigned char) c
) : c
);
123 gfc_wide_is_digit (gfc_char_t c
)
125 return (c
>= '0' && c
<= '9');
129 wide_atoi (gfc_char_t
*c
)
131 #define MAX_DIGITS 20
132 char buf
[MAX_DIGITS
+1];
135 while (gfc_wide_is_digit(*c
) && i
< MAX_DIGITS
)
142 gfc_wide_strlen (const gfc_char_t
*str
)
146 for (i
= 0; str
[i
]; i
++)
153 gfc_wide_memset (gfc_char_t
*b
, gfc_char_t c
, size_t len
)
157 for (i
= 0; i
< len
; i
++)
164 wide_strcpy (gfc_char_t
*dest
, const gfc_char_t
*src
)
168 for (d
= dest
; (*d
= *src
) != '\0'; ++src
, ++d
)
175 wide_strchr (const gfc_char_t
*s
, gfc_char_t c
)
180 return CONST_CAST(gfc_char_t
*, s
);
187 gfc_widechar_to_char (const gfc_char_t
*s
, int length
)
195 /* Passing a negative length is used to indicate that length should be
196 calculated using gfc_wide_strlen(). */
197 len
= (length
>= 0 ? (size_t) length
: gfc_wide_strlen (s
));
198 res
= gfc_getmem (len
+ 1);
200 for (i
= 0; i
< len
; i
++)
202 gcc_assert (gfc_wide_fits_in_byte (s
[i
]));
203 res
[i
] = (unsigned char) s
[i
];
211 gfc_char_to_widechar (const char *s
)
220 res
= gfc_get_wide_string (len
+ 1);
222 for (i
= 0; i
< len
; i
++)
223 res
[i
] = (unsigned char) s
[i
];
230 wide_strncmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
239 return (c1
> c2
? 1 : -1);
247 gfc_wide_strncasecmp (const gfc_char_t
*s1
, const char *s2
, size_t n
)
253 c1
= gfc_wide_tolower (*s1
++);
254 c2
= TOLOWER (*s2
++);
256 return (c1
> c2
? 1 : -1);
264 /* Main scanner initialization. */
267 gfc_scanner_init_1 (void)
280 /* Main scanner destructor. */
283 gfc_scanner_done_1 (void)
288 while(line_head
!= NULL
)
290 lb
= line_head
->next
;
295 while(file_head
!= NULL
)
298 gfc_free(file_head
->filename
);
305 /* Adds path to the list pointed to by list. */
308 add_path_to_list (gfc_directorylist
**list
, const char *path
,
309 bool use_for_modules
)
311 gfc_directorylist
*dir
;
315 while (*p
== ' ' || *p
== '\t') /* someone might do "-I include" */
321 dir
= *list
= gfc_getmem (sizeof (gfc_directorylist
));
327 dir
->next
= gfc_getmem (sizeof (gfc_directorylist
));
332 dir
->use_for_modules
= use_for_modules
;
333 dir
->path
= gfc_getmem (strlen (p
) + 2);
334 strcpy (dir
->path
, p
);
335 strcat (dir
->path
, "/"); /* make '/' last character */
340 gfc_add_include_path (const char *path
, bool use_for_modules
)
342 add_path_to_list (&include_dirs
, path
, use_for_modules
);
347 gfc_add_intrinsic_modules_path (const char *path
)
349 add_path_to_list (&intrinsic_modules_dirs
, path
, true);
353 /* Release resources allocated for options. */
356 gfc_release_include_path (void)
358 gfc_directorylist
*p
;
360 while (include_dirs
!= NULL
)
363 include_dirs
= include_dirs
->next
;
368 while (intrinsic_modules_dirs
!= NULL
)
370 p
= intrinsic_modules_dirs
;
371 intrinsic_modules_dirs
= intrinsic_modules_dirs
->next
;
376 gfc_free (gfc_option
.module_dir
);
381 open_included_file (const char *name
, gfc_directorylist
*list
, bool module
)
384 gfc_directorylist
*p
;
387 for (p
= list
; p
; p
= p
->next
)
389 if (module
&& !p
->use_for_modules
)
392 fullname
= (char *) alloca(strlen (p
->path
) + strlen (name
) + 1);
393 strcpy (fullname
, p
->path
);
394 strcat (fullname
, name
);
396 f
= gfc_open_file (fullname
);
405 /* Opens file for reading, searching through the include directories
406 given if necessary. If the include_cwd argument is true, we try
407 to open the file in the current directory first. */
410 gfc_open_included_file (const char *name
, bool include_cwd
, bool module
)
414 if (IS_ABSOLUTE_PATH (name
))
415 return gfc_open_file (name
);
419 f
= gfc_open_file (name
);
424 return open_included_file (name
, include_dirs
, module
);
428 gfc_open_intrinsic_module (const char *name
)
430 if (IS_ABSOLUTE_PATH (name
))
431 return gfc_open_file (name
);
433 return open_included_file (name
, intrinsic_modules_dirs
, true);
437 /* Test to see if we're at the end of the main source file. */
446 /* Test to see if we're at the end of the current file. */
454 if (line_head
== NULL
)
455 return 1; /* Null file */
457 if (gfc_current_locus
.lb
== NULL
)
464 /* Test to see if we're at the beginning of a new line. */
472 return (gfc_current_locus
.nextc
== gfc_current_locus
.lb
->line
);
476 /* Test to see if we're at the end of a line. */
484 return (*gfc_current_locus
.nextc
== '\0');
488 add_file_change (const char *filename
, int line
)
490 if (file_changes_count
== file_changes_allocated
)
492 if (file_changes_allocated
)
493 file_changes_allocated
*= 2;
495 file_changes_allocated
= 16;
497 = xrealloc (file_changes
,
498 file_changes_allocated
* sizeof (*file_changes
));
500 file_changes
[file_changes_count
].filename
= filename
;
501 file_changes
[file_changes_count
].lb
= NULL
;
502 file_changes
[file_changes_count
++].line
= line
;
506 report_file_change (gfc_linebuf
*lb
)
508 size_t c
= file_changes_cur
;
509 while (c
< file_changes_count
510 && file_changes
[c
].lb
== lb
)
512 if (file_changes
[c
].filename
)
513 (*debug_hooks
->start_source_file
) (file_changes
[c
].line
,
514 file_changes
[c
].filename
);
516 (*debug_hooks
->end_source_file
) (file_changes
[c
].line
);
519 file_changes_cur
= c
;
523 gfc_start_source_files (void)
525 /* If the debugger wants the name of the main source file,
527 if (debug_hooks
->start_end_main_source_file
)
528 (*debug_hooks
->start_source_file
) (0, gfc_source_file
);
530 file_changes_cur
= 0;
531 report_file_change (gfc_current_locus
.lb
);
535 gfc_end_source_files (void)
537 report_file_change (NULL
);
539 if (debug_hooks
->start_end_main_source_file
)
540 (*debug_hooks
->end_source_file
) (0);
543 /* Advance the current line pointer to the next line. */
546 gfc_advance_line (void)
551 if (gfc_current_locus
.lb
== NULL
)
557 if (gfc_current_locus
.lb
->next
558 && !gfc_current_locus
.lb
->next
->dbg_emitted
)
560 report_file_change (gfc_current_locus
.lb
->next
);
561 gfc_current_locus
.lb
->next
->dbg_emitted
= true;
564 gfc_current_locus
.lb
= gfc_current_locus
.lb
->next
;
566 if (gfc_current_locus
.lb
!= NULL
)
567 gfc_current_locus
.nextc
= gfc_current_locus
.lb
->line
;
570 gfc_current_locus
.nextc
= NULL
;
576 /* Get the next character from the input, advancing gfc_current_file's
577 locus. When we hit the end of the line or the end of the file, we
578 start returning a '\n' in order to complete the current statement.
579 No Fortran line conventions are implemented here.
581 Requiring explicit advances to the next line prevents the parse
582 pointer from being on the wrong line if the current statement ends
590 if (gfc_current_locus
.nextc
== NULL
)
593 c
= *gfc_current_locus
.nextc
++;
596 gfc_current_locus
.nextc
--; /* Remain on this line. */
604 /* Skip a comment. When we come here the parse pointer is positioned
605 immediately after the comment character. If we ever implement
606 compiler directives withing comments, here is where we parse the
610 skip_comment_line (void)
625 gfc_define_undef_line (void)
629 /* All lines beginning with '#' are either #define or #undef. */
630 if (debug_info_level
!= DINFO_LEVEL_VERBOSE
|| gfc_peek_ascii_char () != '#')
633 if (wide_strncmp (gfc_current_locus
.nextc
, "#define ", 8) == 0)
635 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[8], -1);
636 (*debug_hooks
->define
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
641 if (wide_strncmp (gfc_current_locus
.nextc
, "#undef ", 7) == 0)
643 tmp
= gfc_widechar_to_char (&gfc_current_locus
.nextc
[7], -1);
644 (*debug_hooks
->undef
) (gfc_linebuf_linenum (gfc_current_locus
.lb
),
649 /* Skip the rest of the line. */
650 skip_comment_line ();
656 /* Comment lines are null lines, lines containing only blanks or lines
657 on which the first nonblank line is a '!'.
658 Return true if !$ openmp conditional compilation sentinel was
662 skip_free_comments (void)
670 at_bol
= gfc_at_bol ();
671 start
= gfc_current_locus
;
677 while (gfc_is_whitespace (c
));
687 /* If -fopenmp, we need to handle here 2 things:
688 1) don't treat !$omp as comments, but directives
689 2) handle OpenMP conditional compilation, where
690 !$ should be treated as 2 spaces (for initial lines
691 only if followed by space). */
692 if (gfc_option
.flag_openmp
&& at_bol
)
694 locus old_loc
= gfc_current_locus
;
695 if (next_char () == '$')
698 if (c
== 'o' || c
== 'O')
700 if (((c
= next_char ()) == 'm' || c
== 'M')
701 && ((c
= next_char ()) == 'p' || c
== 'P'))
703 if ((c
= next_char ()) == ' ' || continue_flag
)
705 while (gfc_is_whitespace (c
))
707 if (c
!= '\n' && c
!= '!')
710 openmp_locus
= old_loc
;
711 gfc_current_locus
= start
;
716 gfc_warning_now ("!$OMP at %C starts a commented "
717 "line as it neither is followed "
718 "by a space nor is a "
719 "continuation line");
721 gfc_current_locus
= old_loc
;
725 if (continue_flag
|| c
== ' ')
727 gfc_current_locus
= old_loc
;
733 gfc_current_locus
= old_loc
;
735 skip_comment_line ();
742 if (openmp_flag
&& at_bol
)
744 gfc_current_locus
= start
;
749 /* Skip comment lines in fixed source mode. We have the same rules as
750 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
751 in column 1, and a '!' cannot be in column 6. Also, we deal with
752 lines with 'd' or 'D' in column 1, if the user requested this. */
755 skip_fixed_comments (void)
763 start
= gfc_current_locus
;
768 while (gfc_is_whitespace (c
));
773 skip_comment_line ();
778 gfc_current_locus
= start
;
785 start
= gfc_current_locus
;
796 if (c
== '!' || c
== 'c' || c
== 'C' || c
== '*')
798 /* If -fopenmp, we need to handle here 2 things:
799 1) don't treat !$omp|c$omp|*$omp as comments, but directives
800 2) handle OpenMP conditional compilation, where
801 !$|c$|*$ should be treated as 2 spaces if the characters
802 in columns 3 to 6 are valid fixed form label columns
804 if (gfc_current_locus
.lb
!= NULL
805 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
806 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
808 if (gfc_option
.flag_openmp
)
810 if (next_char () == '$')
813 if (c
== 'o' || c
== 'O')
815 if (((c
= next_char ()) == 'm' || c
== 'M')
816 && ((c
= next_char ()) == 'p' || c
== 'P'))
820 && ((openmp_flag
&& continue_flag
)
821 || c
== ' ' || c
== '0'))
824 while (gfc_is_whitespace (c
))
826 if (c
!= '\n' && c
!= '!')
828 /* Canonicalize to *$omp. */
831 gfc_current_locus
= start
;
841 for (col
= 3; col
< 6; col
++, c
= next_char ())
844 else if (c
< '0' || c
> '9')
849 if (col
== 6 && c
!= '\n'
850 && ((continue_flag
&& !digit_seen
)
851 || c
== ' ' || c
== '0'))
853 gfc_current_locus
= start
;
854 start
.nextc
[0] = ' ';
855 start
.nextc
[1] = ' ';
860 gfc_current_locus
= start
;
862 skip_comment_line ();
866 if (gfc_option
.flag_d_lines
!= -1 && (c
== 'd' || c
== 'D'))
868 if (gfc_option
.flag_d_lines
== 0)
870 skip_comment_line ();
874 *start
.nextc
= c
= ' ';
879 while (gfc_is_whitespace (c
))
891 if (col
!= 6 && c
== '!')
893 if (gfc_current_locus
.lb
!= NULL
894 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
895 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
896 skip_comment_line ();
904 gfc_current_locus
= start
;
908 /* Skips the current line if it is a comment. */
911 gfc_skip_comments (void)
913 if (gfc_current_form
== FORM_FREE
)
914 skip_free_comments ();
916 skip_fixed_comments ();
920 /* Get the next character from the input, taking continuation lines
921 and end-of-line comments into account. This implies that comment
922 lines between continued lines must be eaten here. For higher-level
923 subroutines, this flattens continued lines into a single logical
924 line. The in_string flag denotes whether we're inside a character
928 gfc_next_char_literal (int in_string
)
931 int i
, prev_openmp_flag
;
944 if (gfc_current_form
== FORM_FREE
)
946 bool openmp_cond_flag
;
948 if (!in_string
&& c
== '!')
951 && memcmp (&gfc_current_locus
, &openmp_locus
,
952 sizeof (gfc_current_locus
)) == 0)
955 /* This line can't be continued */
962 /* Avoid truncation warnings for comment ending lines. */
963 gfc_current_locus
.lb
->truncated
= 0;
971 /* If the next nonblank character is a ! or \n, we've got a
972 continuation line. */
973 old_loc
= gfc_current_locus
;
976 while (gfc_is_whitespace (c
))
979 /* Character constants to be continued cannot have commentary
982 if (in_string
&& c
!= '\n')
984 gfc_current_locus
= old_loc
;
989 if (c
!= '!' && c
!= '\n')
991 gfc_current_locus
= old_loc
;
996 prev_openmp_flag
= openmp_flag
;
999 skip_comment_line ();
1001 gfc_advance_line ();
1004 goto not_continuation
;
1006 /* We've got a continuation line. If we are on the very next line after
1007 the last continuation, increment the continuation line count and
1008 check whether the limit has been exceeded. */
1009 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1011 if (++continue_count
== gfc_option
.max_continue_free
)
1013 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1014 gfc_warning ("Limit of %d continuations exceeded in "
1015 "statement at %C", gfc_option
.max_continue_free
);
1019 /* Now find where it continues. First eat any comment lines. */
1020 openmp_cond_flag
= skip_free_comments ();
1022 if (gfc_current_locus
.lb
!= NULL
1023 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1024 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1026 if (prev_openmp_flag
!= openmp_flag
)
1028 gfc_current_locus
= old_loc
;
1029 openmp_flag
= prev_openmp_flag
;
1034 /* Now that we have a non-comment line, probe ahead for the
1035 first non-whitespace character. If it is another '&', then
1036 reading starts at the next character, otherwise we must back
1037 up to where the whitespace started and resume from there. */
1039 old_loc
= gfc_current_locus
;
1042 while (gfc_is_whitespace (c
))
1047 for (i
= 0; i
< 5; i
++, c
= next_char ())
1049 gcc_assert (gfc_wide_tolower (c
) == (unsigned char) "!$omp"[i
]);
1051 old_loc
= gfc_current_locus
;
1053 while (gfc_is_whitespace (c
))
1061 if (gfc_option
.warn_ampersand
)
1062 gfc_warning_now ("Missing '&' in continued character "
1064 gfc_current_locus
.nextc
--;
1066 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1067 continuation line only optionally. */
1068 else if (openmp_flag
|| openmp_cond_flag
)
1069 gfc_current_locus
.nextc
--;
1073 gfc_current_locus
= old_loc
;
1080 /* Fixed form continuation. */
1081 if (!in_string
&& c
== '!')
1083 /* Skip comment at end of line. */
1090 /* Avoid truncation warnings for comment ending lines. */
1091 gfc_current_locus
.lb
->truncated
= 0;
1097 prev_openmp_flag
= openmp_flag
;
1099 old_loc
= gfc_current_locus
;
1101 gfc_advance_line ();
1102 skip_fixed_comments ();
1104 /* See if this line is a continuation line. */
1105 if (openmp_flag
!= prev_openmp_flag
)
1107 openmp_flag
= prev_openmp_flag
;
1108 goto not_continuation
;
1112 for (i
= 0; i
< 5; i
++)
1116 goto not_continuation
;
1119 for (i
= 0; i
< 5; i
++)
1122 if (gfc_wide_tolower (c
) != (unsigned char) "*$omp"[i
])
1123 goto not_continuation
;
1127 if (c
== '0' || c
== ' ' || c
== '\n')
1128 goto not_continuation
;
1130 /* We've got a continuation line. If we are on the very next line after
1131 the last continuation, increment the continuation line count and
1132 check whether the limit has been exceeded. */
1133 if (gfc_linebuf_linenum (gfc_current_locus
.lb
) == continue_line
+ 1)
1135 if (++continue_count
== gfc_option
.max_continue_fixed
)
1137 if (gfc_notification_std (GFC_STD_GNU
) || pedantic
)
1138 gfc_warning ("Limit of %d continuations exceeded in "
1140 gfc_option
.max_continue_fixed
);
1144 if (gfc_current_locus
.lb
!= NULL
1145 && continue_line
< gfc_linebuf_linenum (gfc_current_locus
.lb
))
1146 continue_line
= gfc_linebuf_linenum (gfc_current_locus
.lb
);
1149 /* Ready to read first character of continuation line, which might
1150 be another continuation line! */
1155 gfc_current_locus
= old_loc
;
1165 /* Get the next character of input, folded to lowercase. In fixed
1166 form mode, we also ignore spaces. When matcher subroutines are
1167 parsing character literals, they have to call
1168 gfc_next_char_literal(). */
1171 gfc_next_char (void)
1177 c
= gfc_next_char_literal (0);
1179 while (gfc_current_form
== FORM_FIXED
&& gfc_is_whitespace (c
));
1181 return gfc_wide_tolower (c
);
1185 gfc_next_ascii_char (void)
1187 gfc_char_t c
= gfc_next_char ();
1189 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1190 : (unsigned char) UCHAR_MAX
);
1195 gfc_peek_char (void)
1200 old_loc
= gfc_current_locus
;
1201 c
= gfc_next_char ();
1202 gfc_current_locus
= old_loc
;
1209 gfc_peek_ascii_char (void)
1211 gfc_char_t c
= gfc_peek_char ();
1213 return (gfc_wide_fits_in_byte (c
) ? (unsigned char) c
1214 : (unsigned char) UCHAR_MAX
);
1218 /* Recover from an error. We try to get past the current statement
1219 and get lined up for the next. The next statement follows a '\n'
1220 or a ';'. We also assume that we are not within a character
1221 constant, and deal with finding a '\'' or '"'. */
1224 gfc_error_recovery (void)
1226 gfc_char_t c
, delim
;
1233 c
= gfc_next_char ();
1234 if (c
== '\n' || c
== ';')
1237 if (c
!= '\'' && c
!= '"')
1266 /* Read ahead until the next character to be read is not whitespace. */
1269 gfc_gobble_whitespace (void)
1271 static int linenum
= 0;
1277 old_loc
= gfc_current_locus
;
1278 c
= gfc_next_char_literal (0);
1279 /* Issue a warning for nonconforming tabs. We keep track of the line
1280 number because the Fortran matchers will often back up and the same
1281 line will be scanned multiple times. */
1282 if (!gfc_option
.warn_tabs
&& c
== '\t')
1284 int cur_linenum
= LOCATION_LINE (gfc_current_locus
.lb
->location
);
1285 if (cur_linenum
!= linenum
)
1287 linenum
= cur_linenum
;
1288 gfc_warning_now ("Nonconforming tab character at %C");
1292 while (gfc_is_whitespace (c
));
1294 gfc_current_locus
= old_loc
;
1298 /* Load a single line into pbuf.
1300 If pbuf points to a NULL pointer, it is allocated.
1301 We truncate lines that are too long, unless we're dealing with
1302 preprocessor lines or if the option -ffixed-line-length-none is set,
1303 in which case we reallocate the buffer to fit the entire line, if
1305 In fixed mode, we expand a tab that occurs within the statement
1306 label region to expand to spaces that leave the next character in
1308 load_line returns whether the line was truncated.
1310 NOTE: The error machinery isn't available at this point, so we can't
1311 easily report line and column numbers consistent with other
1312 parts of gfortran. */
1315 load_line (FILE *input
, gfc_char_t
**pbuf
, int *pbuflen
)
1317 static int linenum
= 0, current_line
= 1;
1318 int c
, maxlen
, i
, preprocessor_flag
, buflen
= *pbuflen
;
1319 int trunc_flag
= 0, seen_comment
= 0;
1320 int seen_printable
= 0, seen_ampersand
= 0;
1322 bool found_tab
= false;
1324 /* Determine the maximum allowed line length. */
1325 if (gfc_current_form
== FORM_FREE
)
1326 maxlen
= gfc_option
.free_line_length
;
1327 else if (gfc_current_form
== FORM_FIXED
)
1328 maxlen
= gfc_option
.fixed_line_length
;
1334 /* Allocate the line buffer, storing its length into buflen.
1335 Note that if maxlen==0, indicating that arbitrary-length lines
1336 are allowed, the buffer will be reallocated if this length is
1337 insufficient; since 132 characters is the length of a standard
1338 free-form line, we use that as a starting guess. */
1344 *pbuf
= gfc_get_wide_string (buflen
+ 1);
1350 preprocessor_flag
= 0;
1353 /* In order to not truncate preprocessor lines, we have to
1354 remember that this is one. */
1355 preprocessor_flag
= 1;
1366 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1367 if (gfc_current_form
== FORM_FREE
1368 && !seen_printable
&& seen_ampersand
)
1371 gfc_error_now ("'&' not allowed by itself in line %d",
1374 gfc_warning_now ("'&' not allowed by itself in line %d",
1381 continue; /* Gobble characters. */
1393 if ((c
!= '&' && c
!= '!' && c
!= ' ') || (c
== '!' && !seen_ampersand
))
1396 /* Is this a fixed-form comment? */
1397 if (gfc_current_form
== FORM_FIXED
&& i
== 0
1398 && (c
== '*' || c
== 'c' || c
== 'd'))
1401 /* Vendor extension: "<tab>1" marks a continuation line. */
1405 if (c
>= '1' && c
<= '9')
1412 if (gfc_current_form
== FORM_FIXED
&& c
== '\t' && i
< 6)
1416 if (!gfc_option
.warn_tabs
&& seen_comment
== 0
1417 && current_line
!= linenum
)
1419 linenum
= current_line
;
1420 gfc_warning_now ("Nonconforming tab character in column %d "
1421 "of line %d", i
+1, linenum
);
1436 if (maxlen
== 0 || preprocessor_flag
)
1440 /* Reallocate line buffer to double size to hold the
1442 buflen
= buflen
* 2;
1443 *pbuf
= xrealloc (*pbuf
, (buflen
+ 1) * sizeof (gfc_char_t
));
1444 buffer
= (*pbuf
) + i
;
1447 else if (i
>= maxlen
)
1449 /* Truncate the rest of the line. */
1453 if (c
== '\n' || c
== EOF
)
1459 ungetc ('\n', input
);
1463 /* Pad lines to the selected line length in fixed form. */
1464 if (gfc_current_form
== FORM_FIXED
1465 && gfc_option
.fixed_line_length
!= 0
1466 && !preprocessor_flag
1469 while (i
++ < maxlen
)
1481 /* Get a gfc_file structure, initialize it and add it to
1485 get_file (const char *name
, enum lc_reason reason ATTRIBUTE_UNUSED
)
1489 f
= gfc_getmem (sizeof (gfc_file
));
1491 f
->filename
= gfc_getmem (strlen (name
) + 1);
1492 strcpy (f
->filename
, name
);
1494 f
->next
= file_head
;
1497 f
->up
= current_file
;
1498 if (current_file
!= NULL
)
1499 f
->inclusion_line
= current_file
->line
;
1501 linemap_add (line_table
, reason
, false, f
->filename
, 1);
1507 /* Deal with a line from the C preprocessor. The
1508 initial octothorp has already been seen. */
1511 preprocessor_line (gfc_char_t
*c
)
1515 gfc_char_t
*wide_filename
;
1517 int escaped
, unescape
;
1521 while (*c
== ' ' || *c
== '\t')
1524 if (*c
< '0' || *c
> '9')
1527 line
= wide_atoi (c
);
1529 c
= wide_strchr (c
, ' ');
1532 /* No file name given. Set new line number. */
1533 current_file
->line
= line
;
1538 while (*c
== ' ' || *c
== '\t')
1548 /* Make filename end at quote. */
1551 while (*c
&& ! (!escaped
&& *c
== '"'))
1555 else if (*c
== '\\')
1564 /* Preprocessor line has no closing quote. */
1569 /* Undo effects of cpp_quote_string. */
1572 gfc_char_t
*s
= wide_filename
;
1573 gfc_char_t
*d
= gfc_get_wide_string (c
- wide_filename
- unescape
);
1589 flag
[1] = flag
[2] = flag
[3] = flag
[4] = false;
1593 c
= wide_strchr (c
, ' ');
1600 if (1 <= i
&& i
<= 4)
1604 /* Convert the filename in wide characters into a filename in narrow
1606 filename
= gfc_widechar_to_char (wide_filename
, -1);
1608 /* Interpret flags. */
1610 if (flag
[1]) /* Starting new file. */
1612 f
= get_file (filename
, LC_RENAME
);
1613 add_file_change (f
->filename
, f
->inclusion_line
);
1617 if (flag
[2]) /* Ending current file. */
1619 if (!current_file
->up
1620 || strcmp (current_file
->up
->filename
, filename
) != 0)
1622 gfc_warning_now ("%s:%d: file %s left but not entered",
1623 current_file
->filename
, current_file
->line
,
1626 gfc_free (wide_filename
);
1627 gfc_free (filename
);
1631 add_file_change (NULL
, line
);
1632 current_file
= current_file
->up
;
1633 linemap_add (line_table
, LC_RENAME
, false, current_file
->filename
,
1634 current_file
->line
);
1637 /* The name of the file can be a temporary file produced by
1638 cpp. Replace the name if it is different. */
1640 if (strcmp (current_file
->filename
, filename
) != 0)
1642 gfc_free (current_file
->filename
);
1643 current_file
->filename
= gfc_getmem (strlen (filename
) + 1);
1644 strcpy (current_file
->filename
, filename
);
1647 /* Set new line number. */
1648 current_file
->line
= line
;
1650 gfc_free (wide_filename
);
1651 gfc_free (filename
);
1655 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1656 current_file
->filename
, current_file
->line
);
1657 current_file
->line
++;
1661 static try load_file (const char *, bool);
1663 /* include_line()-- Checks a line buffer to see if it is an include
1664 line. If so, we call load_file() recursively to load the included
1665 file. We never return a syntax error because a statement like
1666 "include = 5" is perfectly legal. We return false if no include was
1667 processed or true if we matched an include. */
1670 include_line (gfc_char_t
*line
)
1672 gfc_char_t quote
, *c
, *begin
, *stop
;
1677 if (gfc_option
.flag_openmp
)
1679 if (gfc_current_form
== FORM_FREE
)
1681 while (*c
== ' ' || *c
== '\t')
1683 if (*c
== '!' && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1688 if ((*c
== '!' || *c
== 'c' || *c
== 'C' || *c
== '*')
1689 && c
[1] == '$' && (c
[2] == ' ' || c
[2] == '\t'))
1694 while (*c
== ' ' || *c
== '\t')
1697 if (gfc_wide_strncasecmp (c
, "include", 7))
1701 while (*c
== ' ' || *c
== '\t')
1704 /* Find filename between quotes. */
1707 if (quote
!= '"' && quote
!= '\'')
1712 while (*c
!= quote
&& *c
!= '\0')
1720 while (*c
== ' ' || *c
== '\t')
1723 if (*c
!= '\0' && *c
!= '!')
1726 /* We have an include line at this point. */
1728 *stop
= '\0'; /* It's ok to trash the buffer, as this line won't be
1729 read by anything else. */
1731 filename
= gfc_widechar_to_char (begin
, -1);
1732 load_file (filename
, false);
1733 gfc_free (filename
);
1738 /* Load a file into memory by calling load_line until the file ends. */
1741 load_file (const char *filename
, bool initial
)
1750 for (f
= current_file
; f
; f
= f
->up
)
1751 if (strcmp (filename
, f
->filename
) == 0)
1753 gfc_error_now ("File '%s' is being included recursively", filename
);
1761 input
= gfc_src_file
;
1762 gfc_src_file
= NULL
;
1765 input
= gfc_open_file (filename
);
1768 gfc_error_now ("Can't open file '%s'", filename
);
1774 input
= gfc_open_included_file (filename
, false, false);
1777 gfc_error_now ("Can't open included file '%s'", filename
);
1782 /* Load the file. */
1784 f
= get_file (filename
, initial
? LC_RENAME
: LC_ENTER
);
1786 add_file_change (f
->filename
, f
->inclusion_line
);
1788 current_file
->line
= 1;
1793 if (initial
&& gfc_src_preprocessor_lines
[0])
1795 preprocessor_line (gfc_src_preprocessor_lines
[0]);
1796 gfc_free (gfc_src_preprocessor_lines
[0]);
1797 gfc_src_preprocessor_lines
[0] = NULL
;
1798 if (gfc_src_preprocessor_lines
[1])
1800 preprocessor_line (gfc_src_preprocessor_lines
[1]);
1801 gfc_free (gfc_src_preprocessor_lines
[1]);
1802 gfc_src_preprocessor_lines
[1] = NULL
;
1808 int trunc
= load_line (input
, &line
, &line_len
);
1810 len
= gfc_wide_strlen (line
);
1811 if (feof (input
) && len
== 0)
1814 /* If this is the first line of the file, it can contain a byte
1815 order mark (BOM), which we will ignore:
1816 FF FE is UTF-16 little endian,
1817 FE FF is UTF-16 big endian,
1818 EF BB BF is UTF-8. */
1820 && ((line_len
>= 2 && line
[0] == (unsigned char) '\xFF'
1821 && line
[1] == (unsigned char) '\xFE')
1822 || (line_len
>= 2 && line
[0] == (unsigned char) '\xFE'
1823 && line
[1] == (unsigned char) '\xFF')
1824 || (line_len
>= 3 && line
[0] == (unsigned char) '\xEF'
1825 && line
[1] == (unsigned char) '\xBB'
1826 && line
[2] == (unsigned char) '\xBF')))
1828 int n
= line
[1] == (unsigned char) '\xBB' ? 3 : 2;
1829 gfc_char_t
*new = gfc_get_wide_string (line_len
);
1831 wide_strcpy (new, &line
[n
]);
1837 /* There are three things this line can be: a line of Fortran
1838 source, an include line or a C preprocessor directive. */
1842 /* When -g3 is specified, it's possible that we emit #define
1843 and #undef lines, which we need to pass to the middle-end
1844 so that it can emit correct debug info. */
1845 if (debug_info_level
== DINFO_LEVEL_VERBOSE
1846 && (wide_strncmp (line
, "#define ", 8) == 0
1847 || wide_strncmp (line
, "#undef ", 7) == 0))
1851 preprocessor_line (line
);
1856 /* Preprocessed files have preprocessor lines added before the byte
1857 order mark, so first_line is not about the first line of the file
1858 but the first line that's not a preprocessor line. */
1861 if (include_line (line
))
1863 current_file
->line
++;
1869 b
= gfc_getmem (gfc_linebuf_header_size
1870 + (len
+ 1) * sizeof (gfc_char_t
));
1873 = linemap_line_start (line_table
, current_file
->line
++, 120);
1874 b
->file
= current_file
;
1875 b
->truncated
= trunc
;
1876 wide_strcpy (b
->line
, line
);
1878 if (line_head
== NULL
)
1881 line_tail
->next
= b
;
1885 while (file_changes_cur
< file_changes_count
)
1886 file_changes
[file_changes_cur
++].lb
= b
;
1889 /* Release the line buffer allocated in load_line. */
1895 add_file_change (NULL
, current_file
->inclusion_line
+ 1);
1896 current_file
= current_file
->up
;
1897 linemap_add (line_table
, LC_LEAVE
, 0, NULL
, 0);
1902 /* Open a new file and start scanning from that file. Returns SUCCESS
1903 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1904 it tries to determine the source form from the filename, defaulting
1912 result
= load_file (gfc_source_file
, true);
1914 gfc_current_locus
.lb
= line_head
;
1915 gfc_current_locus
.nextc
= (line_head
== NULL
) ? NULL
: line_head
->line
;
1917 #if 0 /* Debugging aid. */
1918 for (; line_head
; line_head
= line_head
->next
)
1919 printf ("%s:%3d %s\n", LOCATION_FILE (line_head
->location
),
1920 LOCATION_LINE (line_head
->location
), line_head
->line
);
1929 unescape_filename (const char *ptr
)
1931 const char *p
= ptr
, *s
;
1933 int escaped
, unescape
= 0;
1935 /* Make filename end at quote. */
1937 while (*p
&& ! (! escaped
&& *p
== '"'))
1941 else if (*p
== '\\')
1952 /* Undo effects of cpp_quote_string. */
1954 d
= gfc_getmem (p
+ 1 - ptr
- unescape
);
1969 /* For preprocessed files, if the first tokens are of the form # NUM.
1970 handle the directives so we know the original file name. */
1973 gfc_read_orig_filename (const char *filename
, const char **canon_source_file
)
1976 char *dirname
, *tmp
;
1978 gfc_src_file
= gfc_open_file (filename
);
1979 if (gfc_src_file
== NULL
)
1982 c
= getc (gfc_src_file
);
1983 ungetc (c
, gfc_src_file
);
1989 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[0], &len
);
1991 if (wide_strncmp (gfc_src_preprocessor_lines
[0], "# 1 \"", 5) != 0)
1994 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[0][5], -1);
1995 filename
= unescape_filename (tmp
);
1997 if (filename
== NULL
)
2000 c
= getc (gfc_src_file
);
2001 ungetc (c
, gfc_src_file
);
2007 load_line (gfc_src_file
, &gfc_src_preprocessor_lines
[1], &len
);
2009 if (wide_strncmp (gfc_src_preprocessor_lines
[1], "# 1 \"", 5) != 0)
2012 tmp
= gfc_widechar_to_char (&gfc_src_preprocessor_lines
[1][5], -1);
2013 dirname
= unescape_filename (tmp
);
2015 if (dirname
== NULL
)
2018 len
= strlen (dirname
);
2019 if (len
< 3 || dirname
[len
- 1] != '/' || dirname
[len
- 2] != '/')
2024 dirname
[len
- 2] = '\0';
2025 set_src_pwd (dirname
);
2027 if (! IS_ABSOLUTE_PATH (filename
))
2029 char *p
= gfc_getmem (len
+ strlen (filename
));
2031 memcpy (p
, dirname
, len
- 2);
2033 strcpy (p
+ len
- 1, filename
);
2034 *canon_source_file
= p
;