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;
67 static int continue_count, continue_line;
68 static locus openmp_locus;
70 gfc_source_form gfc_current_form;
71 static gfc_linebuf *line_head, *line_tail;
73 locus gfc_current_locus;
74 const char *gfc_source_file;
75 static FILE *gfc_src_file;
76 static gfc_char_t *gfc_src_preprocessor_lines[2];
80 static struct gfc_file_change
86 size_t file_changes_cur, file_changes_count;
87 size_t file_changes_allocated;
90 /* Functions dealing with our wide characters (gfc_char_t) and
91 sequences of such characters. */
94 gfc_wide_fits_in_byte (gfc_char_t c)
96 return (c <= UCHAR_MAX);
100 wide_is_ascii (gfc_char_t c)
102 return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0);
106 gfc_wide_is_printable (gfc_char_t c)
108 return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c));
112 gfc_wide_tolower (gfc_char_t c)
114 return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
118 gfc_wide_toupper (gfc_char_t c)
120 return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c);
124 gfc_wide_is_digit (gfc_char_t c)
126 return (c >= '0' && c <= '9');
130 wide_atoi (gfc_char_t *c)
132 #define MAX_DIGITS 20
133 char buf[MAX_DIGITS+1];
136 while (gfc_wide_is_digit(*c) && i < MAX_DIGITS)
143 gfc_wide_strlen (const gfc_char_t *str)
147 for (i = 0; str[i]; i++)
154 gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len)
158 for (i = 0; i < len; i++)
165 wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
169 for (d = dest; (*d = *src) != '\0'; ++src, ++d)
176 wide_strchr (const gfc_char_t *s, gfc_char_t c)
181 return CONST_CAST(gfc_char_t *, s);
188 gfc_widechar_to_char (const gfc_char_t *s, int length)
196 /* Passing a negative length is used to indicate that length should be
197 calculated using gfc_wide_strlen(). */
198 len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s));
199 res = XNEWVEC (char, len + 1);
201 for (i = 0; i < len; i++)
203 gcc_assert (gfc_wide_fits_in_byte (s[i]));
204 res[i] = (unsigned char) s[i];
212 gfc_char_to_widechar (const char *s)
221 res = gfc_get_wide_string (len + 1);
223 for (i = 0; i < len; i++)
224 res[i] = (unsigned char) s[i];
231 wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n)
240 return (c1 > c2 ? 1 : -1);
248 gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
254 c1 = gfc_wide_tolower (*s1++);
255 c2 = TOLOWER (*s2++);
257 return (c1 > c2 ? 1 : -1);
265 /* Main scanner initialization. */
268 gfc_scanner_init_1 (void)
281 /* Main scanner destructor. */
284 gfc_scanner_done_1 (void)
289 while(line_head != NULL)
291 lb = line_head->next;
296 while(file_head != NULL)
299 gfc_free(file_head->filename);
306 /* Adds path to the list pointed to by list. */
309 add_path_to_list (gfc_directorylist **list, const char *path,
310 bool use_for_modules, bool head)
312 gfc_directorylist *dir;
316 while (*p == ' ' || *p == '\t') /* someone might do "-I include" */
320 if (head || *list == NULL)
322 dir = XCNEW (gfc_directorylist);
332 dir->next = XCNEW (gfc_directorylist);
336 dir->next = head ? *list : NULL;
339 dir->use_for_modules = use_for_modules;
340 dir->path = XCNEWVEC (char, strlen (p) + 2);
341 strcpy (dir->path, p);
342 strcat (dir->path, "/"); /* make '/' last character */
347 gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir)
349 add_path_to_list (&include_dirs, path, use_for_modules, file_dir);
351 /* For '#include "..."' these directories are automatically searched. */
353 gfc_cpp_add_include_path (xstrdup(path), true);
358 gfc_add_intrinsic_modules_path (const char *path)
360 add_path_to_list (&intrinsic_modules_dirs, path, true, false);
364 /* Release resources allocated for options. */
367 gfc_release_include_path (void)
369 gfc_directorylist *p;
371 while (include_dirs != NULL)
374 include_dirs = include_dirs->next;
379 while (intrinsic_modules_dirs != NULL)
381 p = intrinsic_modules_dirs;
382 intrinsic_modules_dirs = intrinsic_modules_dirs->next;
387 gfc_free (gfc_option.module_dir);
392 open_included_file (const char *name, gfc_directorylist *list, bool module)
395 gfc_directorylist *p;
398 for (p = list; p; p = p->next)
400 if (module && !p->use_for_modules)
403 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
404 strcpy (fullname, p->path);
405 strcat (fullname, name);
407 f = gfc_open_file (fullname);
416 /* Opens file for reading, searching through the include directories
417 given if necessary. If the include_cwd argument is true, we try
418 to open the file in the current directory first. */
421 gfc_open_included_file (const char *name, bool include_cwd, bool module)
425 if (IS_ABSOLUTE_PATH (name))
426 return gfc_open_file (name);
430 f = gfc_open_file (name);
435 return open_included_file (name, include_dirs, module);
439 gfc_open_intrinsic_module (const char *name)
441 if (IS_ABSOLUTE_PATH (name))
442 return gfc_open_file (name);
444 return open_included_file (name, intrinsic_modules_dirs, true);
448 /* Test to see if we're at the end of the main source file. */
457 /* Test to see if we're at the end of the current file. */
465 if (line_head == NULL)
466 return 1; /* Null file */
468 if (gfc_current_locus.lb == NULL)
475 /* Test to see if we're at the beginning of a new line. */
483 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
487 /* Test to see if we're at the end of a line. */
495 return (*gfc_current_locus.nextc == '\0');
499 add_file_change (const char *filename, int line)
501 if (file_changes_count == file_changes_allocated)
503 if (file_changes_allocated)
504 file_changes_allocated *= 2;
506 file_changes_allocated = 16;
507 file_changes = XRESIZEVEC (struct gfc_file_change, file_changes,
508 file_changes_allocated);
510 file_changes[file_changes_count].filename = filename;
511 file_changes[file_changes_count].lb = NULL;
512 file_changes[file_changes_count++].line = line;
516 report_file_change (gfc_linebuf *lb)
518 size_t c = file_changes_cur;
519 while (c < file_changes_count
520 && file_changes[c].lb == lb)
522 if (file_changes[c].filename)
523 (*debug_hooks->start_source_file) (file_changes[c].line,
524 file_changes[c].filename);
526 (*debug_hooks->end_source_file) (file_changes[c].line);
529 file_changes_cur = c;
533 gfc_start_source_files (void)
535 /* If the debugger wants the name of the main source file,
537 if (debug_hooks->start_end_main_source_file)
538 (*debug_hooks->start_source_file) (0, gfc_source_file);
540 file_changes_cur = 0;
541 report_file_change (gfc_current_locus.lb);
545 gfc_end_source_files (void)
547 report_file_change (NULL);
549 if (debug_hooks->start_end_main_source_file)
550 (*debug_hooks->end_source_file) (0);
553 /* Advance the current line pointer to the next line. */
556 gfc_advance_line (void)
561 if (gfc_current_locus.lb == NULL)
567 if (gfc_current_locus.lb->next
568 && !gfc_current_locus.lb->next->dbg_emitted)
570 report_file_change (gfc_current_locus.lb->next);
571 gfc_current_locus.lb->next->dbg_emitted = true;
574 gfc_current_locus.lb = gfc_current_locus.lb->next;
576 if (gfc_current_locus.lb != NULL)
577 gfc_current_locus.nextc = gfc_current_locus.lb->line;
580 gfc_current_locus.nextc = NULL;
586 /* Get the next character from the input, advancing gfc_current_file's
587 locus. When we hit the end of the line or the end of the file, we
588 start returning a '\n' in order to complete the current statement.
589 No Fortran line conventions are implemented here.
591 Requiring explicit advances to the next line prevents the parse
592 pointer from being on the wrong line if the current statement ends
600 if (gfc_current_locus.nextc == NULL)
603 c = *gfc_current_locus.nextc++;
606 gfc_current_locus.nextc--; /* Remain on this line. */
614 /* Skip a comment. When we come here the parse pointer is positioned
615 immediately after the comment character. If we ever implement
616 compiler directives withing comments, here is where we parse the
620 skip_comment_line (void)
635 gfc_define_undef_line (void)
639 /* All lines beginning with '#' are either #define or #undef. */
640 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
643 if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
645 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
646 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
651 if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
653 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
654 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
659 /* Skip the rest of the line. */
660 skip_comment_line ();
666 /* Comment lines are null lines, lines containing only blanks or lines
667 on which the first nonblank line is a '!'.
668 Return true if !$ openmp conditional compilation sentinel was
672 skip_free_comments (void)
680 at_bol = gfc_at_bol ();
681 start = gfc_current_locus;
687 while (gfc_is_whitespace (c));
697 /* If -fopenmp, we need to handle here 2 things:
698 1) don't treat !$omp as comments, but directives
699 2) handle OpenMP conditional compilation, where
700 !$ should be treated as 2 spaces (for initial lines
701 only if followed by space). */
702 if (gfc_option.flag_openmp && at_bol)
704 locus old_loc = gfc_current_locus;
705 if (next_char () == '$')
708 if (c == 'o' || c == 'O')
710 if (((c = next_char ()) == 'm' || c == 'M')
711 && ((c = next_char ()) == 'p' || c == 'P'))
713 if ((c = next_char ()) == ' ' || c == '\t'
716 while (gfc_is_whitespace (c))
718 if (c != '\n' && c != '!')
721 openmp_locus = old_loc;
722 gfc_current_locus = start;
727 gfc_warning_now ("!$OMP at %C starts a commented "
728 "line as it neither is followed "
729 "by a space nor is a "
730 "continuation line");
732 gfc_current_locus = old_loc;
736 if (continue_flag || c == ' ' || c == '\t')
738 gfc_current_locus = old_loc;
744 gfc_current_locus = old_loc;
746 skip_comment_line ();
753 if (openmp_flag && at_bol)
755 gfc_current_locus = start;
760 /* Skip comment lines in fixed source mode. We have the same rules as
761 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
762 in column 1, and a '!' cannot be in column 6. Also, we deal with
763 lines with 'd' or 'D' in column 1, if the user requested this. */
766 skip_fixed_comments (void)
774 start = gfc_current_locus;
779 while (gfc_is_whitespace (c));
784 skip_comment_line ();
789 gfc_current_locus = start;
796 start = gfc_current_locus;
807 if (c == '!' || c == 'c' || c == 'C' || c == '*')
809 /* If -fopenmp, we need to handle here 2 things:
810 1) don't treat !$omp|c$omp|*$omp as comments, but directives
811 2) handle OpenMP conditional compilation, where
812 !$|c$|*$ should be treated as 2 spaces if the characters
813 in columns 3 to 6 are valid fixed form label columns
815 if (gfc_current_locus.lb != NULL
816 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
817 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
819 if (gfc_option.flag_openmp)
821 if (next_char () == '$')
824 if (c == 'o' || c == 'O')
826 if (((c = next_char ()) == 'm' || c == 'M')
827 && ((c = next_char ()) == 'p' || c == 'P'))
831 && ((openmp_flag && continue_flag)
832 || c == ' ' || c == '\t' || c == '0'))
836 while (gfc_is_whitespace (c));
837 if (c != '\n' && c != '!')
839 /* Canonicalize to *$omp. */
842 gfc_current_locus = start;
852 for (col = 3; col < 6; col++, c = next_char ())
860 else if (c < '0' || c > '9')
865 if (col == 6 && c != '\n'
866 && ((continue_flag && !digit_seen)
867 || c == ' ' || c == '\t' || c == '0'))
869 gfc_current_locus = start;
870 start.nextc[0] = ' ';
871 start.nextc[1] = ' ';
876 gfc_current_locus = start;
878 skip_comment_line ();
882 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
884 if (gfc_option.flag_d_lines == 0)
886 skip_comment_line ();
890 *start.nextc = c = ' ';
895 while (gfc_is_whitespace (c))
907 if (col != 6 && c == '!')
909 if (gfc_current_locus.lb != NULL
910 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
911 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
912 skip_comment_line ();
920 gfc_current_locus = start;
924 /* Skips the current line if it is a comment. */
927 gfc_skip_comments (void)
929 if (gfc_current_form == FORM_FREE)
930 skip_free_comments ();
932 skip_fixed_comments ();
936 /* Get the next character from the input, taking continuation lines
937 and end-of-line comments into account. This implies that comment
938 lines between continued lines must be eaten here. For higher-level
939 subroutines, this flattens continued lines into a single logical
940 line. The in_string flag denotes whether we're inside a character
944 gfc_next_char_literal (int in_string)
947 int i, prev_openmp_flag;
960 if (gfc_current_form == FORM_FREE)
962 bool openmp_cond_flag;
964 if (!in_string && c == '!')
967 && memcmp (&gfc_current_locus, &openmp_locus,
968 sizeof (gfc_current_locus)) == 0)
971 /* This line can't be continued */
978 /* Avoid truncation warnings for comment ending lines. */
979 gfc_current_locus.lb->truncated = 0;
987 /* If the next nonblank character is a ! or \n, we've got a
988 continuation line. */
989 old_loc = gfc_current_locus;
992 while (gfc_is_whitespace (c))
995 /* Character constants to be continued cannot have commentary
998 if (in_string && c != '\n')
1000 gfc_current_locus = old_loc;
1005 if (c != '!' && c != '\n')
1007 gfc_current_locus = old_loc;
1012 prev_openmp_flag = openmp_flag;
1015 skip_comment_line ();
1017 gfc_advance_line ();
1020 goto not_continuation;
1022 /* We've got a continuation line. If we are on the very next line after
1023 the last continuation, increment the continuation line count and
1024 check whether the limit has been exceeded. */
1025 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1027 if (++continue_count == gfc_option.max_continue_free)
1029 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1030 gfc_warning ("Limit of %d continuations exceeded in "
1031 "statement at %C", gfc_option.max_continue_free);
1035 /* Now find where it continues. First eat any comment lines. */
1036 openmp_cond_flag = skip_free_comments ();
1038 if (gfc_current_locus.lb != NULL
1039 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1040 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1042 if (prev_openmp_flag != openmp_flag)
1044 gfc_current_locus = old_loc;
1045 openmp_flag = prev_openmp_flag;
1050 /* Now that we have a non-comment line, probe ahead for the
1051 first non-whitespace character. If it is another '&', then
1052 reading starts at the next character, otherwise we must back
1053 up to where the whitespace started and resume from there. */
1055 old_loc = gfc_current_locus;
1058 while (gfc_is_whitespace (c))
1063 for (i = 0; i < 5; i++, c = next_char ())
1065 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1067 old_loc = gfc_current_locus;
1069 while (gfc_is_whitespace (c))
1077 if (gfc_option.warn_ampersand)
1078 gfc_warning_now ("Missing '&' in continued character "
1080 gfc_current_locus.nextc--;
1082 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1083 continuation line only optionally. */
1084 else if (openmp_flag || openmp_cond_flag)
1085 gfc_current_locus.nextc--;
1089 gfc_current_locus = old_loc;
1096 /* Fixed form continuation. */
1097 if (!in_string && c == '!')
1099 /* Skip comment at end of line. */
1106 /* Avoid truncation warnings for comment ending lines. */
1107 gfc_current_locus.lb->truncated = 0;
1113 prev_openmp_flag = openmp_flag;
1115 old_loc = gfc_current_locus;
1117 gfc_advance_line ();
1118 skip_fixed_comments ();
1120 /* See if this line is a continuation line. */
1121 if (openmp_flag != prev_openmp_flag)
1123 openmp_flag = prev_openmp_flag;
1124 goto not_continuation;
1128 for (i = 0; i < 5; i++)
1132 goto not_continuation;
1135 for (i = 0; i < 5; i++)
1138 if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1139 goto not_continuation;
1143 if (c == '0' || c == ' ' || c == '\n')
1144 goto not_continuation;
1146 /* We've got a continuation line. If we are on the very next line after
1147 the last continuation, increment the continuation line count and
1148 check whether the limit has been exceeded. */
1149 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1151 if (++continue_count == gfc_option.max_continue_fixed)
1153 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1154 gfc_warning ("Limit of %d continuations exceeded in "
1156 gfc_option.max_continue_fixed);
1160 if (gfc_current_locus.lb != NULL
1161 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1162 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1165 /* Ready to read first character of continuation line, which might
1166 be another continuation line! */
1171 gfc_current_locus = old_loc;
1181 /* Get the next character of input, folded to lowercase. In fixed
1182 form mode, we also ignore spaces. When matcher subroutines are
1183 parsing character literals, they have to call
1184 gfc_next_char_literal(). */
1187 gfc_next_char (void)
1193 c = gfc_next_char_literal (0);
1195 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1197 return gfc_wide_tolower (c);
1201 gfc_next_ascii_char (void)
1203 gfc_char_t c = gfc_next_char ();
1205 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1206 : (unsigned char) UCHAR_MAX);
1211 gfc_peek_char (void)
1216 old_loc = gfc_current_locus;
1217 c = gfc_next_char ();
1218 gfc_current_locus = old_loc;
1225 gfc_peek_ascii_char (void)
1227 gfc_char_t c = gfc_peek_char ();
1229 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1230 : (unsigned char) UCHAR_MAX);
1234 /* Recover from an error. We try to get past the current statement
1235 and get lined up for the next. The next statement follows a '\n'
1236 or a ';'. We also assume that we are not within a character
1237 constant, and deal with finding a '\'' or '"'. */
1240 gfc_error_recovery (void)
1242 gfc_char_t c, delim;
1249 c = gfc_next_char ();
1250 if (c == '\n' || c == ';')
1253 if (c != '\'' && c != '"')
1282 /* Read ahead until the next character to be read is not whitespace. */
1285 gfc_gobble_whitespace (void)
1287 static int linenum = 0;
1293 old_loc = gfc_current_locus;
1294 c = gfc_next_char_literal (0);
1295 /* Issue a warning for nonconforming tabs. We keep track of the line
1296 number because the Fortran matchers will often back up and the same
1297 line will be scanned multiple times. */
1298 if (!gfc_option.warn_tabs && c == '\t')
1300 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1301 if (cur_linenum != linenum)
1303 linenum = cur_linenum;
1304 gfc_warning_now ("Nonconforming tab character at %C");
1308 while (gfc_is_whitespace (c));
1310 gfc_current_locus = old_loc;
1314 /* Load a single line into pbuf.
1316 If pbuf points to a NULL pointer, it is allocated.
1317 We truncate lines that are too long, unless we're dealing with
1318 preprocessor lines or if the option -ffixed-line-length-none is set,
1319 in which case we reallocate the buffer to fit the entire line, if
1321 In fixed mode, we expand a tab that occurs within the statement
1322 label region to expand to spaces that leave the next character in
1325 If first_char is not NULL, it's a pointer to a single char value holding
1326 the first character of the line, which has already been read by the
1327 caller. This avoids the use of ungetc().
1329 load_line returns whether the line was truncated.
1331 NOTE: The error machinery isn't available at this point, so we can't
1332 easily report line and column numbers consistent with other
1333 parts of gfortran. */
1336 load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1338 static int linenum = 0, current_line = 1;
1339 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1340 int trunc_flag = 0, seen_comment = 0;
1341 int seen_printable = 0, seen_ampersand = 0;
1343 bool found_tab = false;
1345 /* Determine the maximum allowed line length. */
1346 if (gfc_current_form == FORM_FREE)
1347 maxlen = gfc_option.free_line_length;
1348 else if (gfc_current_form == FORM_FIXED)
1349 maxlen = gfc_option.fixed_line_length;
1355 /* Allocate the line buffer, storing its length into buflen.
1356 Note that if maxlen==0, indicating that arbitrary-length lines
1357 are allowed, the buffer will be reallocated if this length is
1358 insufficient; since 132 characters is the length of a standard
1359 free-form line, we use that as a starting guess. */
1365 *pbuf = gfc_get_wide_string (buflen + 1);
1376 /* In order to not truncate preprocessor lines, we have to
1377 remember that this is one. */
1378 preprocessor_flag = (c == '#' ? 1 : 0);
1387 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1388 if (gfc_current_form == FORM_FREE
1389 && !seen_printable && seen_ampersand)
1392 gfc_error_now ("'&' not allowed by itself in line %d",
1395 gfc_warning_now ("'&' not allowed by itself in line %d",
1401 if (c == '\r' || c == '\0')
1402 goto next_char; /* Gobble characters. */
1412 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1415 /* Is this a fixed-form comment? */
1416 if (gfc_current_form == FORM_FIXED && i == 0
1417 && (c == '*' || c == 'c' || c == 'd'))
1420 /* Vendor extension: "<tab>1" marks a continuation line. */
1424 if (c >= '1' && c <= '9')
1431 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1435 if (!gfc_option.warn_tabs && seen_comment == 0
1436 && current_line != linenum)
1438 linenum = current_line;
1439 gfc_warning_now ("Nonconforming tab character in column %d "
1440 "of line %d", i+1, linenum);
1455 if (maxlen == 0 || preprocessor_flag)
1459 /* Reallocate line buffer to double size to hold the
1461 buflen = buflen * 2;
1462 *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
1463 buffer = (*pbuf) + i;
1466 else if (i >= maxlen)
1468 /* Truncate the rest of the line. */
1475 if (c == '\n' || c == EOF)
1489 /* Pad lines to the selected line length in fixed form. */
1490 if (gfc_current_form == FORM_FIXED
1491 && gfc_option.fixed_line_length != 0
1492 && !preprocessor_flag
1495 while (i++ < maxlen)
1507 /* Get a gfc_file structure, initialize it and add it to
1511 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1515 f = XCNEW (gfc_file);
1517 f->filename = xstrdup (name);
1519 f->next = file_head;
1522 f->up = current_file;
1523 if (current_file != NULL)
1524 f->inclusion_line = current_file->line;
1526 linemap_add (line_table, reason, false, f->filename, 1);
1532 /* Deal with a line from the C preprocessor. The
1533 initial octothorp has already been seen. */
1536 preprocessor_line (gfc_char_t *c)
1540 gfc_char_t *wide_filename;
1542 int escaped, unescape;
1546 while (*c == ' ' || *c == '\t')
1549 if (*c < '0' || *c > '9')
1552 line = wide_atoi (c);
1554 c = wide_strchr (c, ' ');
1557 /* No file name given. Set new line number. */
1558 current_file->line = line;
1563 while (*c == ' ' || *c == '\t')
1573 /* Make filename end at quote. */
1576 while (*c && ! (!escaped && *c == '"'))
1580 else if (*c == '\\')
1589 /* Preprocessor line has no closing quote. */
1594 /* Undo effects of cpp_quote_string. */
1597 gfc_char_t *s = wide_filename;
1598 gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
1614 flag[1] = flag[2] = flag[3] = flag[4] = false;
1618 c = wide_strchr (c, ' ');
1625 if (1 <= i && i <= 4)
1629 /* Convert the filename in wide characters into a filename in narrow
1631 filename = gfc_widechar_to_char (wide_filename, -1);
1633 /* Interpret flags. */
1635 if (flag[1]) /* Starting new file. */
1637 f = get_file (filename, LC_RENAME);
1638 add_file_change (f->filename, f->inclusion_line);
1642 if (flag[2]) /* Ending current file. */
1644 if (!current_file->up
1645 || strcmp (current_file->up->filename, filename) != 0)
1647 gfc_warning_now ("%s:%d: file %s left but not entered",
1648 current_file->filename, current_file->line,
1651 gfc_free (wide_filename);
1652 gfc_free (filename);
1656 add_file_change (NULL, line);
1657 current_file = current_file->up;
1658 linemap_add (line_table, LC_RENAME, false, current_file->filename,
1659 current_file->line);
1662 /* The name of the file can be a temporary file produced by
1663 cpp. Replace the name if it is different. */
1665 if (strcmp (current_file->filename, filename) != 0)
1667 /* FIXME: we leak the old filename because a pointer to it may be stored
1668 in the linemap. Alternative could be using GC or updating linemap to
1669 point to the new name, but there is no API for that currently. */
1670 current_file->filename = xstrdup (filename);
1673 /* Set new line number. */
1674 current_file->line = line;
1676 gfc_free (wide_filename);
1677 gfc_free (filename);
1681 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1682 current_file->filename, current_file->line);
1683 current_file->line++;
1687 static gfc_try load_file (const char *, const char *, bool);
1689 /* include_line()-- Checks a line buffer to see if it is an include
1690 line. If so, we call load_file() recursively to load the included
1691 file. We never return a syntax error because a statement like
1692 "include = 5" is perfectly legal. We return false if no include was
1693 processed or true if we matched an include. */
1696 include_line (gfc_char_t *line)
1698 gfc_char_t quote, *c, *begin, *stop;
1703 if (gfc_option.flag_openmp)
1705 if (gfc_current_form == FORM_FREE)
1707 while (*c == ' ' || *c == '\t')
1709 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1714 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1715 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1720 while (*c == ' ' || *c == '\t')
1723 if (gfc_wide_strncasecmp (c, "include", 7))
1727 while (*c == ' ' || *c == '\t')
1730 /* Find filename between quotes. */
1733 if (quote != '"' && quote != '\'')
1738 while (*c != quote && *c != '\0')
1746 while (*c == ' ' || *c == '\t')
1749 if (*c != '\0' && *c != '!')
1752 /* We have an include line at this point. */
1754 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1755 read by anything else. */
1757 filename = gfc_widechar_to_char (begin, -1);
1758 load_file (filename, NULL, false);
1759 gfc_free (filename);
1764 /* Load a file into memory by calling load_line until the file ends. */
1767 load_file (const char *realfilename, const char *displayedname, bool initial)
1775 const char *filename;
1777 filename = displayedname ? displayedname : realfilename;
1779 for (f = current_file; f; f = f->up)
1780 if (strcmp (filename, f->filename) == 0)
1782 fprintf (stderr, "%s:%d: Error: File '%s' is being included "
1783 "recursively\n", current_file->filename, current_file->line,
1792 input = gfc_src_file;
1793 gfc_src_file = NULL;
1796 input = gfc_open_file (realfilename);
1799 gfc_error_now ("Can't open file '%s'", filename);
1805 input = gfc_open_included_file (realfilename, false, false);
1808 fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n",
1809 current_file->filename, current_file->line, filename);
1814 /* Load the file. */
1816 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1818 add_file_change (f->filename, f->inclusion_line);
1820 current_file->line = 1;
1825 if (initial && gfc_src_preprocessor_lines[0])
1827 preprocessor_line (gfc_src_preprocessor_lines[0]);
1828 gfc_free (gfc_src_preprocessor_lines[0]);
1829 gfc_src_preprocessor_lines[0] = NULL;
1830 if (gfc_src_preprocessor_lines[1])
1832 preprocessor_line (gfc_src_preprocessor_lines[1]);
1833 gfc_free (gfc_src_preprocessor_lines[1]);
1834 gfc_src_preprocessor_lines[1] = NULL;
1840 int trunc = load_line (input, &line, &line_len, NULL);
1842 len = gfc_wide_strlen (line);
1843 if (feof (input) && len == 0)
1846 /* If this is the first line of the file, it can contain a byte
1847 order mark (BOM), which we will ignore:
1848 FF FE is UTF-16 little endian,
1849 FE FF is UTF-16 big endian,
1850 EF BB BF is UTF-8. */
1852 && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
1853 && line[1] == (unsigned char) '\xFE')
1854 || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
1855 && line[1] == (unsigned char) '\xFF')
1856 || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
1857 && line[1] == (unsigned char) '\xBB'
1858 && line[2] == (unsigned char) '\xBF')))
1860 int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
1861 gfc_char_t *new_char = gfc_get_wide_string (line_len);
1863 wide_strcpy (new_char, &line[n]);
1869 /* There are three things this line can be: a line of Fortran
1870 source, an include line or a C preprocessor directive. */
1874 /* When -g3 is specified, it's possible that we emit #define
1875 and #undef lines, which we need to pass to the middle-end
1876 so that it can emit correct debug info. */
1877 if (debug_info_level == DINFO_LEVEL_VERBOSE
1878 && (wide_strncmp (line, "#define ", 8) == 0
1879 || wide_strncmp (line, "#undef ", 7) == 0))
1883 preprocessor_line (line);
1888 /* Preprocessed files have preprocessor lines added before the byte
1889 order mark, so first_line is not about the first line of the file
1890 but the first line that's not a preprocessor line. */
1893 if (include_line (line))
1895 current_file->line++;
1901 b = (gfc_linebuf *) gfc_getmem (gfc_linebuf_header_size
1902 + (len + 1) * sizeof (gfc_char_t));
1905 = linemap_line_start (line_table, current_file->line++, 120);
1906 b->file = current_file;
1907 b->truncated = trunc;
1908 wide_strcpy (b->line, line);
1910 if (line_head == NULL)
1913 line_tail->next = b;
1917 while (file_changes_cur < file_changes_count)
1918 file_changes[file_changes_cur++].lb = b;
1921 /* Release the line buffer allocated in load_line. */
1927 add_file_change (NULL, current_file->inclusion_line + 1);
1928 current_file = current_file->up;
1929 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
1934 /* Open a new file and start scanning from that file. Returns SUCCESS
1935 if everything went OK, FAILURE otherwise. If form == FORM_UNKNOWN
1936 it tries to determine the source form from the filename, defaulting
1944 if (gfc_cpp_enabled ())
1946 result = gfc_cpp_preprocess (gfc_source_file);
1947 if (!gfc_cpp_preprocess_only ())
1948 result = load_file (gfc_cpp_temporary_file (), gfc_source_file, true);
1951 result = load_file (gfc_source_file, NULL, true);
1953 gfc_current_locus.lb = line_head;
1954 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1956 #if 0 /* Debugging aid. */
1957 for (; line_head; line_head = line_head->next)
1958 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
1959 LOCATION_LINE (line_head->location), line_head->line);
1968 unescape_filename (const char *ptr)
1970 const char *p = ptr, *s;
1972 int escaped, unescape = 0;
1974 /* Make filename end at quote. */
1976 while (*p && ! (! escaped && *p == '"'))
1980 else if (*p == '\\')
1991 /* Undo effects of cpp_quote_string. */
1993 d = XCNEWVEC (char, p + 1 - ptr - unescape);
2008 /* For preprocessed files, if the first tokens are of the form # NUM.
2009 handle the directives so we know the original file name. */
2012 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
2015 char *dirname, *tmp;
2017 gfc_src_file = gfc_open_file (filename);
2018 if (gfc_src_file == NULL)
2021 c = getc (gfc_src_file);
2027 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c);
2029 if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
2032 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
2033 filename = unescape_filename (tmp);
2035 if (filename == NULL)
2038 c = getc (gfc_src_file);
2044 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c);
2046 if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
2049 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
2050 dirname = unescape_filename (tmp);
2052 if (dirname == NULL)
2055 len = strlen (dirname);
2056 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
2061 dirname[len - 2] = '\0';
2062 set_src_pwd (dirname);
2064 if (! IS_ABSOLUTE_PATH (filename))
2066 char *p = XCNEWVEC (char, len + strlen (filename));
2068 memcpy (p, dirname, len - 2);
2070 strcpy (p + len - 1, filename);
2071 *canon_source_file = p;