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 withing 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 /* Now find where it continues. First eat any comment lines. */
1084 openmp_cond_flag = skip_free_comments ();
1086 if (gfc_current_locus.lb != NULL
1087 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1088 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1090 if (prev_openmp_flag != openmp_flag)
1092 gfc_current_locus = old_loc;
1093 openmp_flag = prev_openmp_flag;
1098 /* Now that we have a non-comment line, probe ahead for the
1099 first non-whitespace character. If it is another '&', then
1100 reading starts at the next character, otherwise we must back
1101 up to where the whitespace started and resume from there. */
1103 old_loc = gfc_current_locus;
1106 while (gfc_is_whitespace (c))
1111 for (i = 0; i < 5; i++, c = next_char ())
1113 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1115 old_loc = gfc_current_locus;
1117 while (gfc_is_whitespace (c))
1125 if (gfc_option.warn_ampersand)
1126 gfc_warning_now ("Missing '&' in continued character "
1128 gfc_current_locus.nextc--;
1130 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1131 continuation line only optionally. */
1132 else if (openmp_flag || openmp_cond_flag)
1133 gfc_current_locus.nextc--;
1137 gfc_current_locus = old_loc;
1144 /* Fixed form continuation. */
1145 if (!in_string && c == '!')
1147 /* Skip comment at end of line. */
1154 /* Avoid truncation warnings for comment ending lines. */
1155 gfc_current_locus.lb->truncated = 0;
1161 prev_openmp_flag = openmp_flag;
1163 old_loc = gfc_current_locus;
1165 gfc_advance_line ();
1166 skip_fixed_comments ();
1168 /* See if this line is a continuation line. */
1169 if (openmp_flag != prev_openmp_flag)
1171 openmp_flag = prev_openmp_flag;
1172 goto not_continuation;
1176 for (i = 0; i < 5; i++)
1180 goto not_continuation;
1183 for (i = 0; i < 5; i++)
1186 if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1187 goto not_continuation;
1191 if (c == '0' || c == ' ' || c == '\n')
1192 goto not_continuation;
1194 /* We've got a continuation line. If we are on the very next line after
1195 the last continuation, increment the continuation line count and
1196 check whether the limit has been exceeded. */
1197 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1199 if (++continue_count == gfc_option.max_continue_fixed)
1201 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1202 gfc_warning ("Limit of %d continuations exceeded in "
1204 gfc_option.max_continue_fixed);
1208 if (gfc_current_locus.lb != NULL
1209 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1210 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1213 /* Ready to read first character of continuation line, which might
1214 be another continuation line! */
1219 gfc_current_locus = old_loc;
1229 /* Get the next character of input, folded to lowercase. In fixed
1230 form mode, we also ignore spaces. When matcher subroutines are
1231 parsing character literals, they have to call
1232 gfc_next_char_literal(). */
1235 gfc_next_char (void)
1241 c = gfc_next_char_literal (0);
1243 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1245 return gfc_wide_tolower (c);
1249 gfc_next_ascii_char (void)
1251 gfc_char_t c = gfc_next_char ();
1253 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1254 : (unsigned char) UCHAR_MAX);
1259 gfc_peek_char (void)
1264 old_loc = gfc_current_locus;
1265 c = gfc_next_char ();
1266 gfc_current_locus = old_loc;
1273 gfc_peek_ascii_char (void)
1275 gfc_char_t c = gfc_peek_char ();
1277 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1278 : (unsigned char) UCHAR_MAX);
1282 /* Recover from an error. We try to get past the current statement
1283 and get lined up for the next. The next statement follows a '\n'
1284 or a ';'. We also assume that we are not within a character
1285 constant, and deal with finding a '\'' or '"'. */
1288 gfc_error_recovery (void)
1290 gfc_char_t c, delim;
1297 c = gfc_next_char ();
1298 if (c == '\n' || c == ';')
1301 if (c != '\'' && c != '"')
1330 /* Read ahead until the next character to be read is not whitespace. */
1333 gfc_gobble_whitespace (void)
1335 static int linenum = 0;
1341 old_loc = gfc_current_locus;
1342 c = gfc_next_char_literal (0);
1343 /* Issue a warning for nonconforming tabs. We keep track of the line
1344 number because the Fortran matchers will often back up and the same
1345 line will be scanned multiple times. */
1346 if (!gfc_option.warn_tabs && c == '\t')
1348 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1349 if (cur_linenum != linenum)
1351 linenum = cur_linenum;
1352 gfc_warning_now ("Nonconforming tab character at %C");
1356 while (gfc_is_whitespace (c));
1358 gfc_current_locus = old_loc;
1362 /* Load a single line into pbuf.
1364 If pbuf points to a NULL pointer, it is allocated.
1365 We truncate lines that are too long, unless we're dealing with
1366 preprocessor lines or if the option -ffixed-line-length-none is set,
1367 in which case we reallocate the buffer to fit the entire line, if
1369 In fixed mode, we expand a tab that occurs within the statement
1370 label region to expand to spaces that leave the next character in
1373 If first_char is not NULL, it's a pointer to a single char value holding
1374 the first character of the line, which has already been read by the
1375 caller. This avoids the use of ungetc().
1377 load_line returns whether the line was truncated.
1379 NOTE: The error machinery isn't available at this point, so we can't
1380 easily report line and column numbers consistent with other
1381 parts of gfortran. */
1384 load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1386 static int linenum = 0, current_line = 1;
1387 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1388 int trunc_flag = 0, seen_comment = 0;
1389 int seen_printable = 0, seen_ampersand = 0;
1391 bool found_tab = false;
1393 /* Determine the maximum allowed line length. */
1394 if (gfc_current_form == FORM_FREE)
1395 maxlen = gfc_option.free_line_length;
1396 else if (gfc_current_form == FORM_FIXED)
1397 maxlen = gfc_option.fixed_line_length;
1403 /* Allocate the line buffer, storing its length into buflen.
1404 Note that if maxlen==0, indicating that arbitrary-length lines
1405 are allowed, the buffer will be reallocated if this length is
1406 insufficient; since 132 characters is the length of a standard
1407 free-form line, we use that as a starting guess. */
1413 *pbuf = gfc_get_wide_string (buflen + 1);
1424 /* In order to not truncate preprocessor lines, we have to
1425 remember that this is one. */
1426 preprocessor_flag = (c == '#' ? 1 : 0);
1435 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1436 if (gfc_current_form == FORM_FREE
1437 && !seen_printable && seen_ampersand)
1440 gfc_error_now ("'&' not allowed by itself in line %d",
1443 gfc_warning_now ("'&' not allowed by itself in line %d",
1449 if (c == '\r' || c == '\0')
1450 goto next_char; /* Gobble characters. */
1463 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1466 /* Is this a fixed-form comment? */
1467 if (gfc_current_form == FORM_FIXED && i == 0
1468 && (c == '*' || c == 'c' || c == 'd'))
1471 /* Vendor extension: "<tab>1" marks a continuation line. */
1475 if (c >= '1' && c <= '9')
1482 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1486 if (!gfc_option.warn_tabs && seen_comment == 0
1487 && current_line != linenum)
1489 linenum = current_line;
1490 gfc_warning_now ("Nonconforming tab character in column %d "
1491 "of line %d", i+1, linenum);
1506 if (maxlen == 0 || preprocessor_flag)
1510 /* Reallocate line buffer to double size to hold the
1512 buflen = buflen * 2;
1513 *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
1514 buffer = (*pbuf) + i;
1517 else if (i >= maxlen)
1519 /* Truncate the rest of the line. */
1526 if (c == '\n' || c == EOF)
1540 /* Pad lines to the selected line length in fixed form. */
1541 if (gfc_current_form == FORM_FIXED
1542 && gfc_option.fixed_line_length != 0
1543 && !preprocessor_flag
1546 while (i++ < maxlen)
1558 /* Get a gfc_file structure, initialize it and add it to
1562 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1566 f = XCNEW (gfc_file);
1568 f->filename = xstrdup (name);
1570 f->next = file_head;
1573 f->up = current_file;
1574 if (current_file != NULL)
1575 f->inclusion_line = current_file->line;
1577 linemap_add (line_table, reason, false, f->filename, 1);
1583 /* Deal with a line from the C preprocessor. The
1584 initial octothorp has already been seen. */
1587 preprocessor_line (gfc_char_t *c)
1591 gfc_char_t *wide_filename;
1593 int escaped, unescape;
1597 while (*c == ' ' || *c == '\t')
1600 if (*c < '0' || *c > '9')
1603 line = wide_atoi (c);
1605 c = wide_strchr (c, ' ');
1608 /* No file name given. Set new line number. */
1609 current_file->line = line;
1614 while (*c == ' ' || *c == '\t')
1624 /* Make filename end at quote. */
1627 while (*c && ! (!escaped && *c == '"'))
1631 else if (*c == '\\')
1640 /* Preprocessor line has no closing quote. */
1645 /* Undo effects of cpp_quote_string. */
1648 gfc_char_t *s = wide_filename;
1649 gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
1665 flag[1] = flag[2] = flag[3] = flag[4] = false;
1669 c = wide_strchr (c, ' ');
1676 if (1 <= i && i <= 4)
1680 /* Convert the filename in wide characters into a filename in narrow
1682 filename = gfc_widechar_to_char (wide_filename, -1);
1684 /* Interpret flags. */
1686 if (flag[1]) /* Starting new file. */
1688 f = get_file (filename, LC_RENAME);
1689 add_file_change (f->filename, f->inclusion_line);
1693 if (flag[2]) /* Ending current file. */
1695 if (!current_file->up
1696 || strcmp (current_file->up->filename, filename) != 0)
1698 gfc_warning_now ("%s:%d: file %s left but not entered",
1699 current_file->filename, current_file->line,
1702 gfc_free (wide_filename);
1703 gfc_free (filename);
1707 add_file_change (NULL, line);
1708 current_file = current_file->up;
1709 linemap_add (line_table, LC_RENAME, false, current_file->filename,
1710 current_file->line);
1713 /* The name of the file can be a temporary file produced by
1714 cpp. Replace the name if it is different. */
1716 if (strcmp (current_file->filename, filename) != 0)
1718 /* FIXME: we leak the old filename because a pointer to it may be stored
1719 in the linemap. Alternative could be using GC or updating linemap to
1720 point to the new name, but there is no API for that currently. */
1721 current_file->filename = xstrdup (filename);
1724 /* Set new line number. */
1725 current_file->line = line;
1727 gfc_free (wide_filename);
1728 gfc_free (filename);
1732 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1733 current_file->filename, current_file->line);
1734 current_file->line++;
1738 static gfc_try load_file (const char *, const char *, bool);
1740 /* include_line()-- Checks a line buffer to see if it is an include
1741 line. If so, we call load_file() recursively to load the included
1742 file. We never return a syntax error because a statement like
1743 "include = 5" is perfectly legal. We return false if no include was
1744 processed or true if we matched an include. */
1747 include_line (gfc_char_t *line)
1749 gfc_char_t quote, *c, *begin, *stop;
1754 if (gfc_option.flag_openmp)
1756 if (gfc_current_form == FORM_FREE)
1758 while (*c == ' ' || *c == '\t')
1760 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1765 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1766 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1771 while (*c == ' ' || *c == '\t')
1774 if (gfc_wide_strncasecmp (c, "include", 7))
1778 while (*c == ' ' || *c == '\t')
1781 /* Find filename between quotes. */
1784 if (quote != '"' && quote != '\'')
1789 while (*c != quote && *c != '\0')
1797 while (*c == ' ' || *c == '\t')
1800 if (*c != '\0' && *c != '!')
1803 /* We have an include line at this point. */
1805 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1806 read by anything else. */
1808 filename = gfc_widechar_to_char (begin, -1);
1809 load_file (filename, NULL, false);
1810 gfc_free (filename);
1815 /* Load a file into memory by calling load_line until the file ends. */
1818 load_file (const char *realfilename, const char *displayedname, bool initial)
1826 const char *filename;
1828 filename = displayedname ? displayedname : realfilename;
1830 for (f = current_file; f; f = f->up)
1831 if (strcmp (filename, f->filename) == 0)
1833 fprintf (stderr, "%s:%d: Error: File '%s' is being included "
1834 "recursively\n", current_file->filename, current_file->line,
1843 input = gfc_src_file;
1844 gfc_src_file = NULL;
1847 input = gfc_open_file (realfilename);
1850 gfc_error_now ("Can't open file '%s'", filename);
1856 input = gfc_open_included_file (realfilename, false, false);
1859 fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n",
1860 current_file->filename, current_file->line, filename);
1865 /* Load the file. */
1867 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1869 add_file_change (f->filename, f->inclusion_line);
1871 current_file->line = 1;
1876 if (initial && gfc_src_preprocessor_lines[0])
1878 preprocessor_line (gfc_src_preprocessor_lines[0]);
1879 gfc_free (gfc_src_preprocessor_lines[0]);
1880 gfc_src_preprocessor_lines[0] = NULL;
1881 if (gfc_src_preprocessor_lines[1])
1883 preprocessor_line (gfc_src_preprocessor_lines[1]);
1884 gfc_free (gfc_src_preprocessor_lines[1]);
1885 gfc_src_preprocessor_lines[1] = NULL;
1891 int trunc = load_line (input, &line, &line_len, NULL);
1893 len = gfc_wide_strlen (line);
1894 if (feof (input) && len == 0)
1897 /* If this is the first line of the file, it can contain a byte
1898 order mark (BOM), which we will ignore:
1899 FF FE is UTF-16 little endian,
1900 FE FF is UTF-16 big endian,
1901 EF BB BF is UTF-8. */
1903 && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
1904 && line[1] == (unsigned char) '\xFE')
1905 || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
1906 && line[1] == (unsigned char) '\xFF')
1907 || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
1908 && line[1] == (unsigned char) '\xBB'
1909 && line[2] == (unsigned char) '\xBF')))
1911 int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
1912 gfc_char_t *new_char = gfc_get_wide_string (line_len);
1914 wide_strcpy (new_char, &line[n]);
1920 /* There are three things this line can be: a line of Fortran
1921 source, an include line or a C preprocessor directive. */
1925 /* When -g3 is specified, it's possible that we emit #define
1926 and #undef lines, which we need to pass to the middle-end
1927 so that it can emit correct debug info. */
1928 if (debug_info_level == DINFO_LEVEL_VERBOSE
1929 && (wide_strncmp (line, "#define ", 8) == 0
1930 || wide_strncmp (line, "#undef ", 7) == 0))
1934 preprocessor_line (line);
1939 /* Preprocessed files have preprocessor lines added before the byte
1940 order mark, so first_line is not about the first line of the file
1941 but the first line that's not a preprocessor line. */
1944 if (include_line (line))
1946 current_file->line++;
1952 b = (gfc_linebuf *) gfc_getmem (gfc_linebuf_header_size
1953 + (len + 1) * sizeof (gfc_char_t));
1956 = linemap_line_start (line_table, current_file->line++, 120);
1957 b->file = current_file;
1958 b->truncated = trunc;
1959 wide_strcpy (b->line, line);
1961 if (line_head == NULL)
1964 line_tail->next = b;
1968 while (file_changes_cur < file_changes_count)
1969 file_changes[file_changes_cur++].lb = b;
1972 /* Release the line buffer allocated in load_line. */
1978 add_file_change (NULL, current_file->inclusion_line + 1);
1979 current_file = current_file->up;
1980 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
1985 /* Open a new file and start scanning from that file. Returns SUCCESS
1986 if everything went OK, FAILURE otherwise. If form == FORM_UNKNOWN
1987 it tries to determine the source form from the filename, defaulting
1995 if (gfc_cpp_enabled ())
1997 result = gfc_cpp_preprocess (gfc_source_file);
1998 if (!gfc_cpp_preprocess_only ())
1999 result = load_file (gfc_cpp_temporary_file (), gfc_source_file, true);
2002 result = load_file (gfc_source_file, NULL, true);
2004 gfc_current_locus.lb = line_head;
2005 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
2007 #if 0 /* Debugging aid. */
2008 for (; line_head; line_head = line_head->next)
2009 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
2010 LOCATION_LINE (line_head->location), line_head->line);
2019 unescape_filename (const char *ptr)
2021 const char *p = ptr, *s;
2023 int escaped, unescape = 0;
2025 /* Make filename end at quote. */
2027 while (*p && ! (! escaped && *p == '"'))
2031 else if (*p == '\\')
2042 /* Undo effects of cpp_quote_string. */
2044 d = XCNEWVEC (char, p + 1 - ptr - unescape);
2059 /* For preprocessed files, if the first tokens are of the form # NUM.
2060 handle the directives so we know the original file name. */
2063 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
2066 char *dirname, *tmp;
2068 gfc_src_file = gfc_open_file (filename);
2069 if (gfc_src_file == NULL)
2072 c = getc (gfc_src_file);
2078 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c);
2080 if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
2083 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
2084 filename = unescape_filename (tmp);
2086 if (filename == NULL)
2089 c = getc (gfc_src_file);
2095 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c);
2097 if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
2100 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
2101 dirname = unescape_filename (tmp);
2103 if (dirname == NULL)
2106 len = strlen (dirname);
2107 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
2112 dirname[len - 2] = '\0';
2113 set_src_pwd (dirname);
2115 if (! IS_ABSOLUTE_PATH (filename))
2117 char *p = XCNEWVEC (char, len + strlen (filename));
2119 memcpy (p, dirname, len - 2);
2121 strcpy (p + len - 1, filename);
2122 *canon_source_file = p;