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. */
47 #include "toplev.h" /* For set_src_pwd. */
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,
394 bool module, bool system)
397 gfc_directorylist *p;
400 for (p = list; p; p = p->next)
402 if (module && !p->use_for_modules)
405 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
406 strcpy (fullname, p->path);
407 strcat (fullname, name);
409 f = gfc_open_file (fullname);
412 if (gfc_cpp_makedep ())
413 gfc_cpp_add_dep (fullname, system);
423 /* Opens file for reading, searching through the include directories
424 given if necessary. If the include_cwd argument is true, we try
425 to open the file in the current directory first. */
428 gfc_open_included_file (const char *name, bool include_cwd, bool module)
432 if (IS_ABSOLUTE_PATH (name) || include_cwd)
434 f = gfc_open_file (name);
435 if (f && gfc_cpp_makedep ())
436 gfc_cpp_add_dep (name, false);
440 f = open_included_file (name, include_dirs, module, false);
446 gfc_open_intrinsic_module (const char *name)
450 if (IS_ABSOLUTE_PATH (name))
452 f = gfc_open_file (name);
453 if (f && gfc_cpp_makedep ())
454 gfc_cpp_add_dep (name, true);
458 f = open_included_file (name, intrinsic_modules_dirs, true, true);
464 /* Test to see if we're at the end of the main source file. */
473 /* Test to see if we're at the end of the current file. */
481 if (line_head == NULL)
482 return 1; /* Null file */
484 if (gfc_current_locus.lb == NULL)
491 /* Test to see if we're at the beginning of a new line. */
499 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
503 /* Test to see if we're at the end of a line. */
511 return (*gfc_current_locus.nextc == '\0');
515 add_file_change (const char *filename, int line)
517 if (file_changes_count == file_changes_allocated)
519 if (file_changes_allocated)
520 file_changes_allocated *= 2;
522 file_changes_allocated = 16;
523 file_changes = XRESIZEVEC (struct gfc_file_change, file_changes,
524 file_changes_allocated);
526 file_changes[file_changes_count].filename = filename;
527 file_changes[file_changes_count].lb = NULL;
528 file_changes[file_changes_count++].line = line;
532 report_file_change (gfc_linebuf *lb)
534 size_t c = file_changes_cur;
535 while (c < file_changes_count
536 && file_changes[c].lb == lb)
538 if (file_changes[c].filename)
539 (*debug_hooks->start_source_file) (file_changes[c].line,
540 file_changes[c].filename);
542 (*debug_hooks->end_source_file) (file_changes[c].line);
545 file_changes_cur = c;
549 gfc_start_source_files (void)
551 /* If the debugger wants the name of the main source file,
553 if (debug_hooks->start_end_main_source_file)
554 (*debug_hooks->start_source_file) (0, gfc_source_file);
556 file_changes_cur = 0;
557 report_file_change (gfc_current_locus.lb);
561 gfc_end_source_files (void)
563 report_file_change (NULL);
565 if (debug_hooks->start_end_main_source_file)
566 (*debug_hooks->end_source_file) (0);
569 /* Advance the current line pointer to the next line. */
572 gfc_advance_line (void)
577 if (gfc_current_locus.lb == NULL)
583 if (gfc_current_locus.lb->next
584 && !gfc_current_locus.lb->next->dbg_emitted)
586 report_file_change (gfc_current_locus.lb->next);
587 gfc_current_locus.lb->next->dbg_emitted = true;
590 gfc_current_locus.lb = gfc_current_locus.lb->next;
592 if (gfc_current_locus.lb != NULL)
593 gfc_current_locus.nextc = gfc_current_locus.lb->line;
596 gfc_current_locus.nextc = NULL;
602 /* Get the next character from the input, advancing gfc_current_file's
603 locus. When we hit the end of the line or the end of the file, we
604 start returning a '\n' in order to complete the current statement.
605 No Fortran line conventions are implemented here.
607 Requiring explicit advances to the next line prevents the parse
608 pointer from being on the wrong line if the current statement ends
616 if (gfc_current_locus.nextc == NULL)
619 c = *gfc_current_locus.nextc++;
622 gfc_current_locus.nextc--; /* Remain on this line. */
630 /* Skip a comment. When we come here the parse pointer is positioned
631 immediately after the comment character. If we ever implement
632 compiler directives within comments, here is where we parse the
636 skip_comment_line (void)
651 gfc_define_undef_line (void)
655 /* All lines beginning with '#' are either #define or #undef. */
656 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
659 if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
661 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
662 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
667 if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
669 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
670 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
675 /* Skip the rest of the line. */
676 skip_comment_line ();
682 /* Return true if GCC$ was matched. */
684 skip_gcc_attribute (locus start)
688 locus old_loc = gfc_current_locus;
690 if ((c = next_char ()) == 'g' || c == 'G')
691 if ((c = next_char ()) == 'c' || c == 'C')
692 if ((c = next_char ()) == 'c' || c == 'C')
693 if ((c = next_char ()) == '$')
697 gfc_current_locus = old_loc;
700 gcc_attribute_flag = 1;
701 gcc_attribute_locus = old_loc;
702 gfc_current_locus = start;
710 /* Comment lines are null lines, lines containing only blanks or lines
711 on which the first nonblank line is a '!'.
712 Return true if !$ openmp conditional compilation sentinel was
716 skip_free_comments (void)
724 at_bol = gfc_at_bol ();
725 start = gfc_current_locus;
731 while (gfc_is_whitespace (c));
741 /* Keep the !GCC$ line. */
742 if (at_bol && skip_gcc_attribute (start))
745 /* If -fopenmp, we need to handle here 2 things:
746 1) don't treat !$omp as comments, but directives
747 2) handle OpenMP conditional compilation, where
748 !$ should be treated as 2 spaces (for initial lines
749 only if followed by space). */
750 if (gfc_option.flag_openmp && at_bol)
752 locus old_loc = gfc_current_locus;
753 if (next_char () == '$')
756 if (c == 'o' || c == 'O')
758 if (((c = next_char ()) == 'm' || c == 'M')
759 && ((c = next_char ()) == 'p' || c == 'P'))
761 if ((c = next_char ()) == ' ' || c == '\t'
764 while (gfc_is_whitespace (c))
766 if (c != '\n' && c != '!')
769 openmp_locus = old_loc;
770 gfc_current_locus = start;
775 gfc_warning_now ("!$OMP at %C starts a commented "
776 "line as it neither is followed "
777 "by a space nor is a "
778 "continuation line");
780 gfc_current_locus = old_loc;
784 if (continue_flag || c == ' ' || c == '\t')
786 gfc_current_locus = old_loc;
792 gfc_current_locus = old_loc;
794 skip_comment_line ();
801 if (openmp_flag && at_bol)
804 gcc_attribute_flag = 0;
805 gfc_current_locus = start;
810 /* Skip comment lines in fixed source mode. We have the same rules as
811 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
812 in column 1, and a '!' cannot be in column 6. Also, we deal with
813 lines with 'd' or 'D' in column 1, if the user requested this. */
816 skip_fixed_comments (void)
824 start = gfc_current_locus;
829 while (gfc_is_whitespace (c));
834 skip_comment_line ();
839 gfc_current_locus = start;
846 start = gfc_current_locus;
857 if (c == '!' || c == 'c' || c == 'C' || c == '*')
859 if (skip_gcc_attribute (start))
861 /* Canonicalize to *$omp. */
866 /* If -fopenmp, we need to handle here 2 things:
867 1) don't treat !$omp|c$omp|*$omp as comments, but directives
868 2) handle OpenMP conditional compilation, where
869 !$|c$|*$ should be treated as 2 spaces if the characters
870 in columns 3 to 6 are valid fixed form label columns
872 if (gfc_current_locus.lb != NULL
873 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
874 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
876 if (gfc_option.flag_openmp)
878 if (next_char () == '$')
881 if (c == 'o' || c == 'O')
883 if (((c = next_char ()) == 'm' || c == 'M')
884 && ((c = next_char ()) == 'p' || c == 'P'))
888 && ((openmp_flag && continue_flag)
889 || c == ' ' || c == '\t' || c == '0'))
893 while (gfc_is_whitespace (c));
894 if (c != '\n' && c != '!')
896 /* Canonicalize to *$omp. */
899 gfc_current_locus = start;
909 for (col = 3; col < 6; col++, c = next_char ())
917 else if (c < '0' || c > '9')
922 if (col == 6 && c != '\n'
923 && ((continue_flag && !digit_seen)
924 || c == ' ' || c == '\t' || c == '0'))
926 gfc_current_locus = start;
927 start.nextc[0] = ' ';
928 start.nextc[1] = ' ';
933 gfc_current_locus = start;
935 skip_comment_line ();
939 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
941 if (gfc_option.flag_d_lines == 0)
943 skip_comment_line ();
947 *start.nextc = c = ' ';
952 while (gfc_is_whitespace (c))
964 if (col != 6 && c == '!')
966 if (gfc_current_locus.lb != NULL
967 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
968 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
969 skip_comment_line ();
977 gcc_attribute_flag = 0;
978 gfc_current_locus = start;
982 /* Skips the current line if it is a comment. */
985 gfc_skip_comments (void)
987 if (gfc_current_form == FORM_FREE)
988 skip_free_comments ();
990 skip_fixed_comments ();
994 /* Get the next character from the input, taking continuation lines
995 and end-of-line comments into account. This implies that comment
996 lines between continued lines must be eaten here. For higher-level
997 subroutines, this flattens continued lines into a single logical
998 line. The in_string flag denotes whether we're inside a character
1002 gfc_next_char_literal (int in_string)
1005 int i, prev_openmp_flag;
1018 if (gfc_current_form == FORM_FREE)
1020 bool openmp_cond_flag;
1022 if (!in_string && c == '!')
1024 if (gcc_attribute_flag
1025 && memcmp (&gfc_current_locus, &gcc_attribute_locus,
1026 sizeof (gfc_current_locus)) == 0)
1030 && memcmp (&gfc_current_locus, &openmp_locus,
1031 sizeof (gfc_current_locus)) == 0)
1034 /* This line can't be continued */
1041 /* Avoid truncation warnings for comment ending lines. */
1042 gfc_current_locus.lb->truncated = 0;
1050 /* If the next nonblank character is a ! or \n, we've got a
1051 continuation line. */
1052 old_loc = gfc_current_locus;
1055 while (gfc_is_whitespace (c))
1058 /* Character constants to be continued cannot have commentary
1061 if (in_string && c != '\n')
1063 gfc_current_locus = old_loc;
1068 if (c != '!' && c != '\n')
1070 gfc_current_locus = old_loc;
1075 prev_openmp_flag = openmp_flag;
1078 skip_comment_line ();
1080 gfc_advance_line ();
1083 goto not_continuation;
1085 /* We've got a continuation line. If we are on the very next line after
1086 the last continuation, increment the continuation line count and
1087 check whether the limit has been exceeded. */
1088 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1090 if (++continue_count == gfc_option.max_continue_free)
1092 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1093 gfc_warning ("Limit of %d continuations exceeded in "
1094 "statement at %C", gfc_option.max_continue_free);
1098 /* Check to see if the continuation line was truncated. */
1099 if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
1100 && gfc_current_locus.lb->truncated)
1102 int maxlen = gfc_option.free_line_length;
1103 gfc_current_locus.lb->truncated = 0;
1104 gfc_current_locus.nextc += maxlen;
1105 gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
1106 gfc_current_locus.nextc -= maxlen;
1109 /* Now find where it continues. First eat any comment lines. */
1110 openmp_cond_flag = skip_free_comments ();
1112 if (gfc_current_locus.lb != NULL
1113 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1114 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1116 if (prev_openmp_flag != openmp_flag)
1118 gfc_current_locus = old_loc;
1119 openmp_flag = prev_openmp_flag;
1124 /* Now that we have a non-comment line, probe ahead for the
1125 first non-whitespace character. If it is another '&', then
1126 reading starts at the next character, otherwise we must back
1127 up to where the whitespace started and resume from there. */
1129 old_loc = gfc_current_locus;
1132 while (gfc_is_whitespace (c))
1137 for (i = 0; i < 5; i++, c = next_char ())
1139 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1141 old_loc = gfc_current_locus;
1143 while (gfc_is_whitespace (c))
1151 if (gfc_option.warn_ampersand)
1152 gfc_warning_now ("Missing '&' in continued character "
1154 gfc_current_locus.nextc--;
1156 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1157 continuation line only optionally. */
1158 else if (openmp_flag || openmp_cond_flag)
1159 gfc_current_locus.nextc--;
1163 gfc_current_locus = old_loc;
1168 else /* Fixed form. */
1170 /* Fixed form continuation. */
1171 if (!in_string && c == '!')
1173 /* Skip comment at end of line. */
1180 /* Avoid truncation warnings for comment ending lines. */
1181 gfc_current_locus.lb->truncated = 0;
1187 /* Check to see if the continuation line was truncated. */
1188 if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
1189 && gfc_current_locus.lb->truncated)
1191 gfc_current_locus.lb->truncated = 0;
1192 gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
1195 prev_openmp_flag = openmp_flag;
1197 old_loc = gfc_current_locus;
1199 gfc_advance_line ();
1200 skip_fixed_comments ();
1202 /* See if this line is a continuation line. */
1203 if (openmp_flag != prev_openmp_flag)
1205 openmp_flag = prev_openmp_flag;
1206 goto not_continuation;
1210 for (i = 0; i < 5; i++)
1214 goto not_continuation;
1217 for (i = 0; i < 5; i++)
1220 if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1221 goto not_continuation;
1225 if (c == '0' || c == ' ' || c == '\n')
1226 goto not_continuation;
1228 /* We've got a continuation line. If we are on the very next line after
1229 the last continuation, increment the continuation line count and
1230 check whether the limit has been exceeded. */
1231 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1233 if (++continue_count == gfc_option.max_continue_fixed)
1235 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1236 gfc_warning ("Limit of %d continuations exceeded in "
1238 gfc_option.max_continue_fixed);
1242 if (gfc_current_locus.lb != NULL
1243 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1244 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1247 /* Ready to read first character of continuation line, which might
1248 be another continuation line! */
1253 gfc_current_locus = old_loc;
1263 /* Get the next character of input, folded to lowercase. In fixed
1264 form mode, we also ignore spaces. When matcher subroutines are
1265 parsing character literals, they have to call
1266 gfc_next_char_literal(). */
1269 gfc_next_char (void)
1275 c = gfc_next_char_literal (0);
1277 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1279 return gfc_wide_tolower (c);
1283 gfc_next_ascii_char (void)
1285 gfc_char_t c = gfc_next_char ();
1287 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1288 : (unsigned char) UCHAR_MAX);
1293 gfc_peek_char (void)
1298 old_loc = gfc_current_locus;
1299 c = gfc_next_char ();
1300 gfc_current_locus = old_loc;
1307 gfc_peek_ascii_char (void)
1309 gfc_char_t c = gfc_peek_char ();
1311 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1312 : (unsigned char) UCHAR_MAX);
1316 /* Recover from an error. We try to get past the current statement
1317 and get lined up for the next. The next statement follows a '\n'
1318 or a ';'. We also assume that we are not within a character
1319 constant, and deal with finding a '\'' or '"'. */
1322 gfc_error_recovery (void)
1324 gfc_char_t c, delim;
1331 c = gfc_next_char ();
1332 if (c == '\n' || c == ';')
1335 if (c != '\'' && c != '"')
1364 /* Read ahead until the next character to be read is not whitespace. */
1367 gfc_gobble_whitespace (void)
1369 static int linenum = 0;
1375 old_loc = gfc_current_locus;
1376 c = gfc_next_char_literal (0);
1377 /* Issue a warning for nonconforming tabs. We keep track of the line
1378 number because the Fortran matchers will often back up and the same
1379 line will be scanned multiple times. */
1380 if (!gfc_option.warn_tabs && c == '\t')
1382 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1383 if (cur_linenum != linenum)
1385 linenum = cur_linenum;
1386 gfc_warning_now ("Nonconforming tab character at %C");
1390 while (gfc_is_whitespace (c));
1392 gfc_current_locus = old_loc;
1396 /* Load a single line into pbuf.
1398 If pbuf points to a NULL pointer, it is allocated.
1399 We truncate lines that are too long, unless we're dealing with
1400 preprocessor lines or if the option -ffixed-line-length-none is set,
1401 in which case we reallocate the buffer to fit the entire line, if
1403 In fixed mode, we expand a tab that occurs within the statement
1404 label region to expand to spaces that leave the next character in
1407 If first_char is not NULL, it's a pointer to a single char value holding
1408 the first character of the line, which has already been read by the
1409 caller. This avoids the use of ungetc().
1411 load_line returns whether the line was truncated.
1413 NOTE: The error machinery isn't available at this point, so we can't
1414 easily report line and column numbers consistent with other
1415 parts of gfortran. */
1418 load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1420 static int linenum = 0, current_line = 1;
1421 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1422 int trunc_flag = 0, seen_comment = 0;
1423 int seen_printable = 0, seen_ampersand = 0;
1425 bool found_tab = false;
1427 /* Determine the maximum allowed line length. */
1428 if (gfc_current_form == FORM_FREE)
1429 maxlen = gfc_option.free_line_length;
1430 else if (gfc_current_form == FORM_FIXED)
1431 maxlen = gfc_option.fixed_line_length;
1437 /* Allocate the line buffer, storing its length into buflen.
1438 Note that if maxlen==0, indicating that arbitrary-length lines
1439 are allowed, the buffer will be reallocated if this length is
1440 insufficient; since 132 characters is the length of a standard
1441 free-form line, we use that as a starting guess. */
1447 *pbuf = gfc_get_wide_string (buflen + 1);
1458 /* In order to not truncate preprocessor lines, we have to
1459 remember that this is one. */
1460 preprocessor_flag = (c == '#' ? 1 : 0);
1469 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1470 if (gfc_current_form == FORM_FREE
1471 && !seen_printable && seen_ampersand)
1474 gfc_error_now ("'&' not allowed by itself in line %d",
1477 gfc_warning_now ("'&' not allowed by itself in line %d",
1483 if (c == '\r' || c == '\0')
1484 goto next_char; /* Gobble characters. */
1497 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1500 /* Is this a fixed-form comment? */
1501 if (gfc_current_form == FORM_FIXED && i == 0
1502 && (c == '*' || c == 'c' || c == 'd'))
1505 /* Vendor extension: "<tab>1" marks a continuation line. */
1509 if (c >= '1' && c <= '9')
1516 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1520 if (!gfc_option.warn_tabs && seen_comment == 0
1521 && current_line != linenum)
1523 linenum = current_line;
1524 gfc_warning_now ("Nonconforming tab character in column %d "
1525 "of line %d", i+1, linenum);
1540 if (maxlen == 0 || preprocessor_flag)
1544 /* Reallocate line buffer to double size to hold the
1546 buflen = buflen * 2;
1547 *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
1548 buffer = (*pbuf) + i;
1551 else if (i >= maxlen)
1553 /* Truncate the rest of the line. */
1560 if (c == '\n' || c == EOF)
1574 /* Pad lines to the selected line length in fixed form. */
1575 if (gfc_current_form == FORM_FIXED
1576 && gfc_option.fixed_line_length != 0
1577 && !preprocessor_flag
1580 while (i++ < maxlen)
1592 /* Get a gfc_file structure, initialize it and add it to
1596 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1600 f = XCNEW (gfc_file);
1602 f->filename = xstrdup (name);
1604 f->next = file_head;
1607 f->up = current_file;
1608 if (current_file != NULL)
1609 f->inclusion_line = current_file->line;
1611 linemap_add (line_table, reason, false, f->filename, 1);
1617 /* Deal with a line from the C preprocessor. The
1618 initial octothorp has already been seen. */
1621 preprocessor_line (gfc_char_t *c)
1625 gfc_char_t *wide_filename;
1627 int escaped, unescape;
1631 while (*c == ' ' || *c == '\t')
1634 if (*c < '0' || *c > '9')
1637 line = wide_atoi (c);
1639 c = wide_strchr (c, ' ');
1642 /* No file name given. Set new line number. */
1643 current_file->line = line;
1648 while (*c == ' ' || *c == '\t')
1658 /* Make filename end at quote. */
1661 while (*c && ! (!escaped && *c == '"'))
1665 else if (*c == '\\')
1674 /* Preprocessor line has no closing quote. */
1679 /* Undo effects of cpp_quote_string. */
1682 gfc_char_t *s = wide_filename;
1683 gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
1699 flag[1] = flag[2] = flag[3] = flag[4] = false;
1703 c = wide_strchr (c, ' ');
1710 if (1 <= i && i <= 4)
1714 /* Convert the filename in wide characters into a filename in narrow
1716 filename = gfc_widechar_to_char (wide_filename, -1);
1718 /* Interpret flags. */
1720 if (flag[1]) /* Starting new file. */
1722 f = get_file (filename, LC_RENAME);
1723 add_file_change (f->filename, f->inclusion_line);
1727 if (flag[2]) /* Ending current file. */
1729 if (!current_file->up
1730 || strcmp (current_file->up->filename, filename) != 0)
1732 gfc_warning_now ("%s:%d: file %s left but not entered",
1733 current_file->filename, current_file->line,
1736 gfc_free (wide_filename);
1737 gfc_free (filename);
1741 add_file_change (NULL, line);
1742 current_file = current_file->up;
1743 linemap_add (line_table, LC_RENAME, false, current_file->filename,
1744 current_file->line);
1747 /* The name of the file can be a temporary file produced by
1748 cpp. Replace the name if it is different. */
1750 if (strcmp (current_file->filename, filename) != 0)
1752 /* FIXME: we leak the old filename because a pointer to it may be stored
1753 in the linemap. Alternative could be using GC or updating linemap to
1754 point to the new name, but there is no API for that currently. */
1755 current_file->filename = xstrdup (filename);
1758 /* Set new line number. */
1759 current_file->line = line;
1761 gfc_free (wide_filename);
1762 gfc_free (filename);
1766 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1767 current_file->filename, current_file->line);
1768 current_file->line++;
1772 static gfc_try load_file (const char *, const char *, bool);
1774 /* include_line()-- Checks a line buffer to see if it is an include
1775 line. If so, we call load_file() recursively to load the included
1776 file. We never return a syntax error because a statement like
1777 "include = 5" is perfectly legal. We return false if no include was
1778 processed or true if we matched an include. */
1781 include_line (gfc_char_t *line)
1783 gfc_char_t quote, *c, *begin, *stop;
1788 if (gfc_option.flag_openmp)
1790 if (gfc_current_form == FORM_FREE)
1792 while (*c == ' ' || *c == '\t')
1794 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1799 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1800 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1805 while (*c == ' ' || *c == '\t')
1808 if (gfc_wide_strncasecmp (c, "include", 7))
1812 while (*c == ' ' || *c == '\t')
1815 /* Find filename between quotes. */
1818 if (quote != '"' && quote != '\'')
1823 while (*c != quote && *c != '\0')
1831 while (*c == ' ' || *c == '\t')
1834 if (*c != '\0' && *c != '!')
1837 /* We have an include line at this point. */
1839 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1840 read by anything else. */
1842 filename = gfc_widechar_to_char (begin, -1);
1843 load_file (filename, NULL, false);
1844 gfc_free (filename);
1849 /* Load a file into memory by calling load_line until the file ends. */
1852 load_file (const char *realfilename, const char *displayedname, bool initial)
1860 const char *filename;
1862 filename = displayedname ? displayedname : realfilename;
1864 for (f = current_file; f; f = f->up)
1865 if (strcmp (filename, f->filename) == 0)
1867 fprintf (stderr, "%s:%d: Error: File '%s' is being included "
1868 "recursively\n", current_file->filename, current_file->line,
1877 input = gfc_src_file;
1878 gfc_src_file = NULL;
1881 input = gfc_open_file (realfilename);
1884 gfc_error_now ("Can't open file '%s'", filename);
1890 input = gfc_open_included_file (realfilename, false, false);
1893 fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n",
1894 current_file->filename, current_file->line, filename);
1899 /* Load the file. */
1901 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1903 add_file_change (f->filename, f->inclusion_line);
1905 current_file->line = 1;
1910 if (initial && gfc_src_preprocessor_lines[0])
1912 preprocessor_line (gfc_src_preprocessor_lines[0]);
1913 gfc_free (gfc_src_preprocessor_lines[0]);
1914 gfc_src_preprocessor_lines[0] = NULL;
1915 if (gfc_src_preprocessor_lines[1])
1917 preprocessor_line (gfc_src_preprocessor_lines[1]);
1918 gfc_free (gfc_src_preprocessor_lines[1]);
1919 gfc_src_preprocessor_lines[1] = NULL;
1925 int trunc = load_line (input, &line, &line_len, NULL);
1927 len = gfc_wide_strlen (line);
1928 if (feof (input) && len == 0)
1931 /* If this is the first line of the file, it can contain a byte
1932 order mark (BOM), which we will ignore:
1933 FF FE is UTF-16 little endian,
1934 FE FF is UTF-16 big endian,
1935 EF BB BF is UTF-8. */
1937 && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
1938 && line[1] == (unsigned char) '\xFE')
1939 || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
1940 && line[1] == (unsigned char) '\xFF')
1941 || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
1942 && line[1] == (unsigned char) '\xBB'
1943 && line[2] == (unsigned char) '\xBF')))
1945 int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
1946 gfc_char_t *new_char = gfc_get_wide_string (line_len);
1948 wide_strcpy (new_char, &line[n]);
1954 /* There are three things this line can be: a line of Fortran
1955 source, an include line or a C preprocessor directive. */
1959 /* When -g3 is specified, it's possible that we emit #define
1960 and #undef lines, which we need to pass to the middle-end
1961 so that it can emit correct debug info. */
1962 if (debug_info_level == DINFO_LEVEL_VERBOSE
1963 && (wide_strncmp (line, "#define ", 8) == 0
1964 || wide_strncmp (line, "#undef ", 7) == 0))
1968 preprocessor_line (line);
1973 /* Preprocessed files have preprocessor lines added before the byte
1974 order mark, so first_line is not about the first line of the file
1975 but the first line that's not a preprocessor line. */
1978 if (include_line (line))
1980 current_file->line++;
1986 b = (gfc_linebuf *) gfc_getmem (gfc_linebuf_header_size
1987 + (len + 1) * sizeof (gfc_char_t));
1990 = linemap_line_start (line_table, current_file->line++, 120);
1991 b->file = current_file;
1992 b->truncated = trunc;
1993 wide_strcpy (b->line, line);
1995 if (line_head == NULL)
1998 line_tail->next = b;
2002 while (file_changes_cur < file_changes_count)
2003 file_changes[file_changes_cur++].lb = b;
2006 /* Release the line buffer allocated in load_line. */
2012 add_file_change (NULL, current_file->inclusion_line + 1);
2013 current_file = current_file->up;
2014 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
2019 /* Open a new file and start scanning from that file. Returns SUCCESS
2020 if everything went OK, FAILURE otherwise. If form == FORM_UNKNOWN
2021 it tries to determine the source form from the filename, defaulting
2029 if (gfc_cpp_enabled ())
2031 result = gfc_cpp_preprocess (gfc_source_file);
2032 if (!gfc_cpp_preprocess_only ())
2033 result = load_file (gfc_cpp_temporary_file (), gfc_source_file, true);
2036 result = load_file (gfc_source_file, NULL, true);
2038 gfc_current_locus.lb = line_head;
2039 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
2041 #if 0 /* Debugging aid. */
2042 for (; line_head; line_head = line_head->next)
2043 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
2044 LOCATION_LINE (line_head->location), line_head->line);
2053 unescape_filename (const char *ptr)
2055 const char *p = ptr, *s;
2057 int escaped, unescape = 0;
2059 /* Make filename end at quote. */
2061 while (*p && ! (! escaped && *p == '"'))
2065 else if (*p == '\\')
2076 /* Undo effects of cpp_quote_string. */
2078 d = XCNEWVEC (char, p + 1 - ptr - unescape);
2093 /* For preprocessed files, if the first tokens are of the form # NUM.
2094 handle the directives so we know the original file name. */
2097 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
2100 char *dirname, *tmp;
2102 gfc_src_file = gfc_open_file (filename);
2103 if (gfc_src_file == NULL)
2106 c = getc (gfc_src_file);
2112 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c);
2114 if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
2117 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
2118 filename = unescape_filename (tmp);
2120 if (filename == NULL)
2123 c = getc (gfc_src_file);
2129 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c);
2131 if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
2134 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
2135 dirname = unescape_filename (tmp);
2137 if (dirname == NULL)
2140 len = strlen (dirname);
2141 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
2146 dirname[len - 2] = '\0';
2147 set_src_pwd (dirname);
2149 if (! IS_ABSOLUTE_PATH (filename))
2151 char *p = XCNEWVEC (char, len + strlen (filename));
2153 memcpy (p, dirname, len - 2);
2155 strcpy (p + len - 1, filename);
2156 *canon_source_file = p;