2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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, gcc_attribute_flag;
67 static int continue_count, continue_line;
68 static locus openmp_locus;
69 static locus gcc_attribute_locus;
71 gfc_source_form gfc_current_form;
72 static gfc_linebuf *line_head, *line_tail;
74 locus gfc_current_locus;
75 const char *gfc_source_file;
76 static FILE *gfc_src_file;
77 static gfc_char_t *gfc_src_preprocessor_lines[2];
81 static struct gfc_file_change
87 size_t file_changes_cur, file_changes_count;
88 size_t file_changes_allocated;
91 /* Functions dealing with our wide characters (gfc_char_t) and
92 sequences of such characters. */
95 gfc_wide_fits_in_byte (gfc_char_t c)
97 return (c <= UCHAR_MAX);
101 wide_is_ascii (gfc_char_t c)
103 return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0);
107 gfc_wide_is_printable (gfc_char_t c)
109 return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c));
113 gfc_wide_tolower (gfc_char_t c)
115 return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
119 gfc_wide_toupper (gfc_char_t c)
121 return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c);
125 gfc_wide_is_digit (gfc_char_t c)
127 return (c >= '0' && c <= '9');
131 wide_atoi (gfc_char_t *c)
133 #define MAX_DIGITS 20
134 char buf[MAX_DIGITS+1];
137 while (gfc_wide_is_digit(*c) && i < MAX_DIGITS)
144 gfc_wide_strlen (const gfc_char_t *str)
148 for (i = 0; str[i]; i++)
155 gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len)
159 for (i = 0; i < len; i++)
166 wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
170 for (d = dest; (*d = *src) != '\0'; ++src, ++d)
177 wide_strchr (const gfc_char_t *s, gfc_char_t c)
182 return CONST_CAST(gfc_char_t *, s);
189 gfc_widechar_to_char (const gfc_char_t *s, int length)
197 /* Passing a negative length is used to indicate that length should be
198 calculated using gfc_wide_strlen(). */
199 len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s));
200 res = XNEWVEC (char, len + 1);
202 for (i = 0; i < len; i++)
204 gcc_assert (gfc_wide_fits_in_byte (s[i]));
205 res[i] = (unsigned char) s[i];
213 gfc_char_to_widechar (const char *s)
222 res = gfc_get_wide_string (len + 1);
224 for (i = 0; i < len; i++)
225 res[i] = (unsigned char) s[i];
232 wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n)
241 return (c1 > c2 ? 1 : -1);
249 gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
255 c1 = gfc_wide_tolower (*s1++);
256 c2 = TOLOWER (*s2++);
258 return (c1 > c2 ? 1 : -1);
266 /* Main scanner initialization. */
269 gfc_scanner_init_1 (void)
282 /* Main scanner destructor. */
285 gfc_scanner_done_1 (void)
290 while(line_head != NULL)
292 lb = line_head->next;
297 while(file_head != NULL)
300 gfc_free(file_head->filename);
307 /* Adds path to the list pointed to by list. */
310 add_path_to_list (gfc_directorylist **list, const char *path,
311 bool use_for_modules, bool head)
313 gfc_directorylist *dir;
317 while (*p == ' ' || *p == '\t') /* someone might do "-I include" */
321 if (head || *list == NULL)
323 dir = XCNEW (gfc_directorylist);
333 dir->next = XCNEW (gfc_directorylist);
337 dir->next = head ? *list : NULL;
340 dir->use_for_modules = use_for_modules;
341 dir->path = XCNEWVEC (char, strlen (p) + 2);
342 strcpy (dir->path, p);
343 strcat (dir->path, "/"); /* make '/' last character */
348 gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir)
350 add_path_to_list (&include_dirs, path, use_for_modules, file_dir);
352 /* For '#include "..."' these directories are automatically searched. */
354 gfc_cpp_add_include_path (xstrdup(path), true);
359 gfc_add_intrinsic_modules_path (const char *path)
361 add_path_to_list (&intrinsic_modules_dirs, path, true, false);
365 /* Release resources allocated for options. */
368 gfc_release_include_path (void)
370 gfc_directorylist *p;
372 while (include_dirs != NULL)
375 include_dirs = include_dirs->next;
380 while (intrinsic_modules_dirs != NULL)
382 p = intrinsic_modules_dirs;
383 intrinsic_modules_dirs = intrinsic_modules_dirs->next;
388 gfc_free (gfc_option.module_dir);
393 open_included_file (const char *name, gfc_directorylist *list, bool module)
396 gfc_directorylist *p;
399 for (p = list; p; p = p->next)
401 if (module && !p->use_for_modules)
404 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
405 strcpy (fullname, p->path);
406 strcat (fullname, name);
408 f = gfc_open_file (fullname);
417 /* Opens file for reading, searching through the include directories
418 given if necessary. If the include_cwd argument is true, we try
419 to open the file in the current directory first. */
422 gfc_open_included_file (const char *name, bool include_cwd, bool module)
426 if (IS_ABSOLUTE_PATH (name))
427 return gfc_open_file (name);
431 f = gfc_open_file (name);
436 return open_included_file (name, include_dirs, module);
440 gfc_open_intrinsic_module (const char *name)
442 if (IS_ABSOLUTE_PATH (name))
443 return gfc_open_file (name);
445 return open_included_file (name, intrinsic_modules_dirs, true);
449 /* Test to see if we're at the end of the main source file. */
458 /* Test to see if we're at the end of the current file. */
466 if (line_head == NULL)
467 return 1; /* Null file */
469 if (gfc_current_locus.lb == NULL)
476 /* Test to see if we're at the beginning of a new line. */
484 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
488 /* Test to see if we're at the end of a line. */
496 return (*gfc_current_locus.nextc == '\0');
500 add_file_change (const char *filename, int line)
502 if (file_changes_count == file_changes_allocated)
504 if (file_changes_allocated)
505 file_changes_allocated *= 2;
507 file_changes_allocated = 16;
508 file_changes = XRESIZEVEC (struct gfc_file_change, file_changes,
509 file_changes_allocated);
511 file_changes[file_changes_count].filename = filename;
512 file_changes[file_changes_count].lb = NULL;
513 file_changes[file_changes_count++].line = line;
517 report_file_change (gfc_linebuf *lb)
519 size_t c = file_changes_cur;
520 while (c < file_changes_count
521 && file_changes[c].lb == lb)
523 if (file_changes[c].filename)
524 (*debug_hooks->start_source_file) (file_changes[c].line,
525 file_changes[c].filename);
527 (*debug_hooks->end_source_file) (file_changes[c].line);
530 file_changes_cur = c;
534 gfc_start_source_files (void)
536 /* If the debugger wants the name of the main source file,
538 if (debug_hooks->start_end_main_source_file)
539 (*debug_hooks->start_source_file) (0, gfc_source_file);
541 file_changes_cur = 0;
542 report_file_change (gfc_current_locus.lb);
546 gfc_end_source_files (void)
548 report_file_change (NULL);
550 if (debug_hooks->start_end_main_source_file)
551 (*debug_hooks->end_source_file) (0);
554 /* Advance the current line pointer to the next line. */
557 gfc_advance_line (void)
562 if (gfc_current_locus.lb == NULL)
568 if (gfc_current_locus.lb->next
569 && !gfc_current_locus.lb->next->dbg_emitted)
571 report_file_change (gfc_current_locus.lb->next);
572 gfc_current_locus.lb->next->dbg_emitted = true;
575 gfc_current_locus.lb = gfc_current_locus.lb->next;
577 if (gfc_current_locus.lb != NULL)
578 gfc_current_locus.nextc = gfc_current_locus.lb->line;
581 gfc_current_locus.nextc = NULL;
587 /* Get the next character from the input, advancing gfc_current_file's
588 locus. When we hit the end of the line or the end of the file, we
589 start returning a '\n' in order to complete the current statement.
590 No Fortran line conventions are implemented here.
592 Requiring explicit advances to the next line prevents the parse
593 pointer from being on the wrong line if the current statement ends
601 if (gfc_current_locus.nextc == NULL)
604 c = *gfc_current_locus.nextc++;
607 gfc_current_locus.nextc--; /* Remain on this line. */
615 /* Skip a comment. When we come here the parse pointer is positioned
616 immediately after the comment character. If we ever implement
617 compiler directives within comments, here is where we parse the
621 skip_comment_line (void)
636 gfc_define_undef_line (void)
640 /* All lines beginning with '#' are either #define or #undef. */
641 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
644 if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
646 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
647 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
652 if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
654 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
655 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
660 /* Skip the rest of the line. */
661 skip_comment_line ();
667 /* Return true if GCC$ was matched. */
669 skip_gcc_attribute (locus start)
673 locus old_loc = gfc_current_locus;
675 if ((c = next_char ()) == 'g' || c == 'G')
676 if ((c = next_char ()) == 'c' || c == 'C')
677 if ((c = next_char ()) == 'c' || c == 'C')
678 if ((c = next_char ()) == '$')
682 gfc_current_locus = old_loc;
685 gcc_attribute_flag = 1;
686 gcc_attribute_locus = old_loc;
687 gfc_current_locus = start;
695 /* Comment lines are null lines, lines containing only blanks or lines
696 on which the first nonblank line is a '!'.
697 Return true if !$ openmp conditional compilation sentinel was
701 skip_free_comments (void)
709 at_bol = gfc_at_bol ();
710 start = gfc_current_locus;
716 while (gfc_is_whitespace (c));
726 /* Keep the !GCC$ line. */
727 if (at_bol && skip_gcc_attribute (start))
730 /* If -fopenmp, we need to handle here 2 things:
731 1) don't treat !$omp as comments, but directives
732 2) handle OpenMP conditional compilation, where
733 !$ should be treated as 2 spaces (for initial lines
734 only if followed by space). */
735 if (gfc_option.flag_openmp && at_bol)
737 locus old_loc = gfc_current_locus;
738 if (next_char () == '$')
741 if (c == 'o' || c == 'O')
743 if (((c = next_char ()) == 'm' || c == 'M')
744 && ((c = next_char ()) == 'p' || c == 'P'))
746 if ((c = next_char ()) == ' ' || c == '\t'
749 while (gfc_is_whitespace (c))
751 if (c != '\n' && c != '!')
754 openmp_locus = old_loc;
755 gfc_current_locus = start;
760 gfc_warning_now ("!$OMP at %C starts a commented "
761 "line as it neither is followed "
762 "by a space nor is a "
763 "continuation line");
765 gfc_current_locus = old_loc;
769 if (continue_flag || c == ' ' || c == '\t')
771 gfc_current_locus = old_loc;
777 gfc_current_locus = old_loc;
779 skip_comment_line ();
786 if (openmp_flag && at_bol)
789 gcc_attribute_flag = 0;
790 gfc_current_locus = start;
795 /* Skip comment lines in fixed source mode. We have the same rules as
796 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
797 in column 1, and a '!' cannot be in column 6. Also, we deal with
798 lines with 'd' or 'D' in column 1, if the user requested this. */
801 skip_fixed_comments (void)
809 start = gfc_current_locus;
814 while (gfc_is_whitespace (c));
819 skip_comment_line ();
824 gfc_current_locus = start;
831 start = gfc_current_locus;
842 if (c == '!' || c == 'c' || c == 'C' || c == '*')
844 if (skip_gcc_attribute (start))
846 /* Canonicalize to *$omp. */
851 /* If -fopenmp, we need to handle here 2 things:
852 1) don't treat !$omp|c$omp|*$omp as comments, but directives
853 2) handle OpenMP conditional compilation, where
854 !$|c$|*$ should be treated as 2 spaces if the characters
855 in columns 3 to 6 are valid fixed form label columns
857 if (gfc_current_locus.lb != NULL
858 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
859 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
861 if (gfc_option.flag_openmp)
863 if (next_char () == '$')
866 if (c == 'o' || c == 'O')
868 if (((c = next_char ()) == 'm' || c == 'M')
869 && ((c = next_char ()) == 'p' || c == 'P'))
873 && ((openmp_flag && continue_flag)
874 || c == ' ' || c == '\t' || c == '0'))
878 while (gfc_is_whitespace (c));
879 if (c != '\n' && c != '!')
881 /* Canonicalize to *$omp. */
884 gfc_current_locus = start;
894 for (col = 3; col < 6; col++, c = next_char ())
902 else if (c < '0' || c > '9')
907 if (col == 6 && c != '\n'
908 && ((continue_flag && !digit_seen)
909 || c == ' ' || c == '\t' || c == '0'))
911 gfc_current_locus = start;
912 start.nextc[0] = ' ';
913 start.nextc[1] = ' ';
918 gfc_current_locus = start;
920 skip_comment_line ();
924 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
926 if (gfc_option.flag_d_lines == 0)
928 skip_comment_line ();
932 *start.nextc = c = ' ';
937 while (gfc_is_whitespace (c))
949 if (col != 6 && c == '!')
951 if (gfc_current_locus.lb != NULL
952 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
953 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
954 skip_comment_line ();
962 gcc_attribute_flag = 0;
963 gfc_current_locus = start;
967 /* Skips the current line if it is a comment. */
970 gfc_skip_comments (void)
972 if (gfc_current_form == FORM_FREE)
973 skip_free_comments ();
975 skip_fixed_comments ();
979 /* Get the next character from the input, taking continuation lines
980 and end-of-line comments into account. This implies that comment
981 lines between continued lines must be eaten here. For higher-level
982 subroutines, this flattens continued lines into a single logical
983 line. The in_string flag denotes whether we're inside a character
987 gfc_next_char_literal (int in_string)
990 int i, prev_openmp_flag;
1003 if (gfc_current_form == FORM_FREE)
1005 bool openmp_cond_flag;
1007 if (!in_string && c == '!')
1009 if (gcc_attribute_flag
1010 && memcmp (&gfc_current_locus, &gcc_attribute_locus,
1011 sizeof (gfc_current_locus)) == 0)
1015 && memcmp (&gfc_current_locus, &openmp_locus,
1016 sizeof (gfc_current_locus)) == 0)
1019 /* This line can't be continued */
1026 /* Avoid truncation warnings for comment ending lines. */
1027 gfc_current_locus.lb->truncated = 0;
1035 /* If the next nonblank character is a ! or \n, we've got a
1036 continuation line. */
1037 old_loc = gfc_current_locus;
1040 while (gfc_is_whitespace (c))
1043 /* Character constants to be continued cannot have commentary
1046 if (in_string && c != '\n')
1048 gfc_current_locus = old_loc;
1053 if (c != '!' && c != '\n')
1055 gfc_current_locus = old_loc;
1060 prev_openmp_flag = openmp_flag;
1063 skip_comment_line ();
1065 gfc_advance_line ();
1068 goto not_continuation;
1070 /* We've got a continuation line. If we are on the very next line after
1071 the last continuation, increment the continuation line count and
1072 check whether the limit has been exceeded. */
1073 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1075 if (++continue_count == gfc_option.max_continue_free)
1077 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1078 gfc_warning ("Limit of %d continuations exceeded in "
1079 "statement at %C", gfc_option.max_continue_free);
1083 /* Check to see if the continuation line was truncated. */
1084 if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
1085 && gfc_current_locus.lb->truncated)
1087 int maxlen = gfc_option.free_line_length;
1088 gfc_current_locus.lb->truncated = 0;
1089 gfc_current_locus.nextc += maxlen;
1090 gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
1091 gfc_current_locus.nextc -= maxlen;
1094 /* Now find where it continues. First eat any comment lines. */
1095 openmp_cond_flag = skip_free_comments ();
1097 if (gfc_current_locus.lb != NULL
1098 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1099 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1101 if (prev_openmp_flag != openmp_flag)
1103 gfc_current_locus = old_loc;
1104 openmp_flag = prev_openmp_flag;
1109 /* Now that we have a non-comment line, probe ahead for the
1110 first non-whitespace character. If it is another '&', then
1111 reading starts at the next character, otherwise we must back
1112 up to where the whitespace started and resume from there. */
1114 old_loc = gfc_current_locus;
1117 while (gfc_is_whitespace (c))
1122 for (i = 0; i < 5; i++, c = next_char ())
1124 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1126 old_loc = gfc_current_locus;
1128 while (gfc_is_whitespace (c))
1136 if (gfc_option.warn_ampersand)
1137 gfc_warning_now ("Missing '&' in continued character "
1139 gfc_current_locus.nextc--;
1141 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1142 continuation line only optionally. */
1143 else if (openmp_flag || openmp_cond_flag)
1144 gfc_current_locus.nextc--;
1148 gfc_current_locus = old_loc;
1153 else /* Fixed form. */
1155 /* Fixed form continuation. */
1156 if (!in_string && c == '!')
1158 /* Skip comment at end of line. */
1165 /* Avoid truncation warnings for comment ending lines. */
1166 gfc_current_locus.lb->truncated = 0;
1172 /* Check to see if the continuation line was truncated. */
1173 if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
1174 && gfc_current_locus.lb->truncated)
1176 gfc_current_locus.lb->truncated = 0;
1177 gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
1180 prev_openmp_flag = openmp_flag;
1182 old_loc = gfc_current_locus;
1184 gfc_advance_line ();
1185 skip_fixed_comments ();
1187 /* See if this line is a continuation line. */
1188 if (openmp_flag != prev_openmp_flag)
1190 openmp_flag = prev_openmp_flag;
1191 goto not_continuation;
1195 for (i = 0; i < 5; i++)
1199 goto not_continuation;
1202 for (i = 0; i < 5; i++)
1205 if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1206 goto not_continuation;
1210 if (c == '0' || c == ' ' || c == '\n')
1211 goto not_continuation;
1213 /* We've got a continuation line. If we are on the very next line after
1214 the last continuation, increment the continuation line count and
1215 check whether the limit has been exceeded. */
1216 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1218 if (++continue_count == gfc_option.max_continue_fixed)
1220 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1221 gfc_warning ("Limit of %d continuations exceeded in "
1223 gfc_option.max_continue_fixed);
1227 if (gfc_current_locus.lb != NULL
1228 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1229 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1232 /* Ready to read first character of continuation line, which might
1233 be another continuation line! */
1238 gfc_current_locus = old_loc;
1248 /* Get the next character of input, folded to lowercase. In fixed
1249 form mode, we also ignore spaces. When matcher subroutines are
1250 parsing character literals, they have to call
1251 gfc_next_char_literal(). */
1254 gfc_next_char (void)
1260 c = gfc_next_char_literal (0);
1262 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1264 return gfc_wide_tolower (c);
1268 gfc_next_ascii_char (void)
1270 gfc_char_t c = gfc_next_char ();
1272 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1273 : (unsigned char) UCHAR_MAX);
1278 gfc_peek_char (void)
1283 old_loc = gfc_current_locus;
1284 c = gfc_next_char ();
1285 gfc_current_locus = old_loc;
1292 gfc_peek_ascii_char (void)
1294 gfc_char_t c = gfc_peek_char ();
1296 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1297 : (unsigned char) UCHAR_MAX);
1301 /* Recover from an error. We try to get past the current statement
1302 and get lined up for the next. The next statement follows a '\n'
1303 or a ';'. We also assume that we are not within a character
1304 constant, and deal with finding a '\'' or '"'. */
1307 gfc_error_recovery (void)
1309 gfc_char_t c, delim;
1316 c = gfc_next_char ();
1317 if (c == '\n' || c == ';')
1320 if (c != '\'' && c != '"')
1349 /* Read ahead until the next character to be read is not whitespace. */
1352 gfc_gobble_whitespace (void)
1354 static int linenum = 0;
1360 old_loc = gfc_current_locus;
1361 c = gfc_next_char_literal (0);
1362 /* Issue a warning for nonconforming tabs. We keep track of the line
1363 number because the Fortran matchers will often back up and the same
1364 line will be scanned multiple times. */
1365 if (!gfc_option.warn_tabs && c == '\t')
1367 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1368 if (cur_linenum != linenum)
1370 linenum = cur_linenum;
1371 gfc_warning_now ("Nonconforming tab character at %C");
1375 while (gfc_is_whitespace (c));
1377 gfc_current_locus = old_loc;
1381 /* Load a single line into pbuf.
1383 If pbuf points to a NULL pointer, it is allocated.
1384 We truncate lines that are too long, unless we're dealing with
1385 preprocessor lines or if the option -ffixed-line-length-none is set,
1386 in which case we reallocate the buffer to fit the entire line, if
1388 In fixed mode, we expand a tab that occurs within the statement
1389 label region to expand to spaces that leave the next character in
1392 If first_char is not NULL, it's a pointer to a single char value holding
1393 the first character of the line, which has already been read by the
1394 caller. This avoids the use of ungetc().
1396 load_line returns whether the line was truncated.
1398 NOTE: The error machinery isn't available at this point, so we can't
1399 easily report line and column numbers consistent with other
1400 parts of gfortran. */
1403 load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1405 static int linenum = 0, current_line = 1;
1406 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1407 int trunc_flag = 0, seen_comment = 0;
1408 int seen_printable = 0, seen_ampersand = 0;
1410 bool found_tab = false;
1412 /* Determine the maximum allowed line length. */
1413 if (gfc_current_form == FORM_FREE)
1414 maxlen = gfc_option.free_line_length;
1415 else if (gfc_current_form == FORM_FIXED)
1416 maxlen = gfc_option.fixed_line_length;
1422 /* Allocate the line buffer, storing its length into buflen.
1423 Note that if maxlen==0, indicating that arbitrary-length lines
1424 are allowed, the buffer will be reallocated if this length is
1425 insufficient; since 132 characters is the length of a standard
1426 free-form line, we use that as a starting guess. */
1432 *pbuf = gfc_get_wide_string (buflen + 1);
1443 /* In order to not truncate preprocessor lines, we have to
1444 remember that this is one. */
1445 preprocessor_flag = (c == '#' ? 1 : 0);
1454 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1455 if (gfc_current_form == FORM_FREE
1456 && !seen_printable && seen_ampersand)
1459 gfc_error_now ("'&' not allowed by itself in line %d",
1462 gfc_warning_now ("'&' not allowed by itself in line %d",
1468 if (c == '\r' || c == '\0')
1469 goto next_char; /* Gobble characters. */
1482 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1485 /* Is this a fixed-form comment? */
1486 if (gfc_current_form == FORM_FIXED && i == 0
1487 && (c == '*' || c == 'c' || c == 'd'))
1490 /* Vendor extension: "<tab>1" marks a continuation line. */
1494 if (c >= '1' && c <= '9')
1501 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1505 if (!gfc_option.warn_tabs && seen_comment == 0
1506 && current_line != linenum)
1508 linenum = current_line;
1509 gfc_warning_now ("Nonconforming tab character in column %d "
1510 "of line %d", i+1, linenum);
1525 if (maxlen == 0 || preprocessor_flag)
1529 /* Reallocate line buffer to double size to hold the
1531 buflen = buflen * 2;
1532 *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
1533 buffer = (*pbuf) + i;
1536 else if (i >= maxlen)
1538 /* Truncate the rest of the line. */
1545 if (c == '\n' || c == EOF)
1559 /* Pad lines to the selected line length in fixed form. */
1560 if (gfc_current_form == FORM_FIXED
1561 && gfc_option.fixed_line_length != 0
1562 && !preprocessor_flag
1565 while (i++ < maxlen)
1577 /* Get a gfc_file structure, initialize it and add it to
1581 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1585 f = XCNEW (gfc_file);
1587 f->filename = xstrdup (name);
1589 f->next = file_head;
1592 f->up = current_file;
1593 if (current_file != NULL)
1594 f->inclusion_line = current_file->line;
1596 linemap_add (line_table, reason, false, f->filename, 1);
1602 /* Deal with a line from the C preprocessor. The
1603 initial octothorp has already been seen. */
1606 preprocessor_line (gfc_char_t *c)
1610 gfc_char_t *wide_filename;
1612 int escaped, unescape;
1616 while (*c == ' ' || *c == '\t')
1619 if (*c < '0' || *c > '9')
1622 line = wide_atoi (c);
1624 c = wide_strchr (c, ' ');
1627 /* No file name given. Set new line number. */
1628 current_file->line = line;
1633 while (*c == ' ' || *c == '\t')
1643 /* Make filename end at quote. */
1646 while (*c && ! (!escaped && *c == '"'))
1650 else if (*c == '\\')
1659 /* Preprocessor line has no closing quote. */
1664 /* Undo effects of cpp_quote_string. */
1667 gfc_char_t *s = wide_filename;
1668 gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
1684 flag[1] = flag[2] = flag[3] = flag[4] = false;
1688 c = wide_strchr (c, ' ');
1695 if (1 <= i && i <= 4)
1699 /* Convert the filename in wide characters into a filename in narrow
1701 filename = gfc_widechar_to_char (wide_filename, -1);
1703 /* Interpret flags. */
1705 if (flag[1]) /* Starting new file. */
1707 f = get_file (filename, LC_RENAME);
1708 add_file_change (f->filename, f->inclusion_line);
1712 if (flag[2]) /* Ending current file. */
1714 if (!current_file->up
1715 || strcmp (current_file->up->filename, filename) != 0)
1717 gfc_warning_now ("%s:%d: file %s left but not entered",
1718 current_file->filename, current_file->line,
1721 gfc_free (wide_filename);
1722 gfc_free (filename);
1726 add_file_change (NULL, line);
1727 current_file = current_file->up;
1728 linemap_add (line_table, LC_RENAME, false, current_file->filename,
1729 current_file->line);
1732 /* The name of the file can be a temporary file produced by
1733 cpp. Replace the name if it is different. */
1735 if (strcmp (current_file->filename, filename) != 0)
1737 /* FIXME: we leak the old filename because a pointer to it may be stored
1738 in the linemap. Alternative could be using GC or updating linemap to
1739 point to the new name, but there is no API for that currently. */
1740 current_file->filename = xstrdup (filename);
1743 /* Set new line number. */
1744 current_file->line = line;
1746 gfc_free (wide_filename);
1747 gfc_free (filename);
1751 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1752 current_file->filename, current_file->line);
1753 current_file->line++;
1757 static gfc_try load_file (const char *, const char *, bool);
1759 /* include_line()-- Checks a line buffer to see if it is an include
1760 line. If so, we call load_file() recursively to load the included
1761 file. We never return a syntax error because a statement like
1762 "include = 5" is perfectly legal. We return false if no include was
1763 processed or true if we matched an include. */
1766 include_line (gfc_char_t *line)
1768 gfc_char_t quote, *c, *begin, *stop;
1773 if (gfc_option.flag_openmp)
1775 if (gfc_current_form == FORM_FREE)
1777 while (*c == ' ' || *c == '\t')
1779 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1784 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1785 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1790 while (*c == ' ' || *c == '\t')
1793 if (gfc_wide_strncasecmp (c, "include", 7))
1797 while (*c == ' ' || *c == '\t')
1800 /* Find filename between quotes. */
1803 if (quote != '"' && quote != '\'')
1808 while (*c != quote && *c != '\0')
1816 while (*c == ' ' || *c == '\t')
1819 if (*c != '\0' && *c != '!')
1822 /* We have an include line at this point. */
1824 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1825 read by anything else. */
1827 filename = gfc_widechar_to_char (begin, -1);
1828 load_file (filename, NULL, false);
1829 gfc_free (filename);
1834 /* Load a file into memory by calling load_line until the file ends. */
1837 load_file (const char *realfilename, const char *displayedname, bool initial)
1845 const char *filename;
1847 filename = displayedname ? displayedname : realfilename;
1849 for (f = current_file; f; f = f->up)
1850 if (strcmp (filename, f->filename) == 0)
1852 fprintf (stderr, "%s:%d: Error: File '%s' is being included "
1853 "recursively\n", current_file->filename, current_file->line,
1862 input = gfc_src_file;
1863 gfc_src_file = NULL;
1866 input = gfc_open_file (realfilename);
1869 gfc_error_now ("Can't open file '%s'", filename);
1875 input = gfc_open_included_file (realfilename, false, false);
1878 fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n",
1879 current_file->filename, current_file->line, filename);
1884 /* Load the file. */
1886 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1888 add_file_change (f->filename, f->inclusion_line);
1890 current_file->line = 1;
1895 if (initial && gfc_src_preprocessor_lines[0])
1897 preprocessor_line (gfc_src_preprocessor_lines[0]);
1898 gfc_free (gfc_src_preprocessor_lines[0]);
1899 gfc_src_preprocessor_lines[0] = NULL;
1900 if (gfc_src_preprocessor_lines[1])
1902 preprocessor_line (gfc_src_preprocessor_lines[1]);
1903 gfc_free (gfc_src_preprocessor_lines[1]);
1904 gfc_src_preprocessor_lines[1] = NULL;
1910 int trunc = load_line (input, &line, &line_len, NULL);
1912 len = gfc_wide_strlen (line);
1913 if (feof (input) && len == 0)
1916 /* If this is the first line of the file, it can contain a byte
1917 order mark (BOM), which we will ignore:
1918 FF FE is UTF-16 little endian,
1919 FE FF is UTF-16 big endian,
1920 EF BB BF is UTF-8. */
1922 && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
1923 && line[1] == (unsigned char) '\xFE')
1924 || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
1925 && line[1] == (unsigned char) '\xFF')
1926 || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
1927 && line[1] == (unsigned char) '\xBB'
1928 && line[2] == (unsigned char) '\xBF')))
1930 int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
1931 gfc_char_t *new_char = gfc_get_wide_string (line_len);
1933 wide_strcpy (new_char, &line[n]);
1939 /* There are three things this line can be: a line of Fortran
1940 source, an include line or a C preprocessor directive. */
1944 /* When -g3 is specified, it's possible that we emit #define
1945 and #undef lines, which we need to pass to the middle-end
1946 so that it can emit correct debug info. */
1947 if (debug_info_level == DINFO_LEVEL_VERBOSE
1948 && (wide_strncmp (line, "#define ", 8) == 0
1949 || wide_strncmp (line, "#undef ", 7) == 0))
1953 preprocessor_line (line);
1958 /* Preprocessed files have preprocessor lines added before the byte
1959 order mark, so first_line is not about the first line of the file
1960 but the first line that's not a preprocessor line. */
1963 if (include_line (line))
1965 current_file->line++;
1971 b = (gfc_linebuf *) gfc_getmem (gfc_linebuf_header_size
1972 + (len + 1) * sizeof (gfc_char_t));
1975 = linemap_line_start (line_table, current_file->line++, 120);
1976 b->file = current_file;
1977 b->truncated = trunc;
1978 wide_strcpy (b->line, line);
1980 if (line_head == NULL)
1983 line_tail->next = b;
1987 while (file_changes_cur < file_changes_count)
1988 file_changes[file_changes_cur++].lb = b;
1991 /* Release the line buffer allocated in load_line. */
1997 add_file_change (NULL, current_file->inclusion_line + 1);
1998 current_file = current_file->up;
1999 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
2004 /* Open a new file and start scanning from that file. Returns SUCCESS
2005 if everything went OK, FAILURE otherwise. If form == FORM_UNKNOWN
2006 it tries to determine the source form from the filename, defaulting
2014 if (gfc_cpp_enabled ())
2016 result = gfc_cpp_preprocess (gfc_source_file);
2017 if (!gfc_cpp_preprocess_only ())
2018 result = load_file (gfc_cpp_temporary_file (), gfc_source_file, true);
2021 result = load_file (gfc_source_file, NULL, true);
2023 gfc_current_locus.lb = line_head;
2024 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
2026 #if 0 /* Debugging aid. */
2027 for (; line_head; line_head = line_head->next)
2028 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
2029 LOCATION_LINE (line_head->location), line_head->line);
2038 unescape_filename (const char *ptr)
2040 const char *p = ptr, *s;
2042 int escaped, unescape = 0;
2044 /* Make filename end at quote. */
2046 while (*p && ! (! escaped && *p == '"'))
2050 else if (*p == '\\')
2061 /* Undo effects of cpp_quote_string. */
2063 d = XCNEWVEC (char, p + 1 - ptr - unescape);
2078 /* For preprocessed files, if the first tokens are of the form # NUM.
2079 handle the directives so we know the original file name. */
2082 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
2085 char *dirname, *tmp;
2087 gfc_src_file = gfc_open_file (filename);
2088 if (gfc_src_file == NULL)
2091 c = getc (gfc_src_file);
2097 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c);
2099 if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
2102 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
2103 filename = unescape_filename (tmp);
2105 if (filename == NULL)
2108 c = getc (gfc_src_file);
2114 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c);
2116 if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
2119 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
2120 dirname = unescape_filename (tmp);
2122 if (dirname == NULL)
2125 len = strlen (dirname);
2126 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
2131 dirname[len - 2] = '\0';
2132 set_src_pwd (dirname);
2134 if (! IS_ABSOLUTE_PATH (filename))
2136 char *p = XCNEWVEC (char, len + strlen (filename));
2138 memcpy (p, dirname, len - 2);
2140 strcpy (p + len - 1, filename);
2141 *canon_source_file = p;