2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
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 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
23 /* Set of subroutines to (ultimately) return the next character to the
24 various matching subroutines. This file's job is to read files and
25 build up lines that are parsed by the parser. This means that we
26 handle continuation lines and "include" lines.
28 The first thing the scanner does is to load an entire file into
29 memory. We load the entire file into memory for a couple reasons.
30 The first is that we want to be able to deal with nonseekable input
31 (pipes, stdin) and there is a lot of backing up involved during
34 The second is that we want to be able to print the locus of errors,
35 and an error on line 999999 could conflict with something on line
36 one. Given nonseekable input, we've got to store the whole thing.
38 One thing that helps are the column truncation limits that give us
39 an upper bound on the size of individual lines. We don't store the
42 From the scanner's viewpoint, the higher level subroutines ask for
43 new characters and do a lot of jumping backwards. */
50 /* Structure for holding module and include file search path. */
51 typedef struct gfc_directorylist
54 struct gfc_directorylist *next;
58 /* List of include file search directories. */
59 static gfc_directorylist *include_dirs;
61 static gfc_file *file_head, *current_file;
63 static int continue_flag, end_flag, openmp_flag;
64 static int continue_count, continue_line;
65 static locus openmp_locus;
67 gfc_source_form gfc_current_form;
68 static gfc_linebuf *line_head, *line_tail;
70 locus gfc_current_locus;
71 const char *gfc_source_file;
72 static FILE *gfc_src_file;
73 static char *gfc_src_preprocessor_lines[2];
77 /* Main scanner initialization. */
80 gfc_scanner_init_1 (void)
93 /* Main scanner destructor. */
96 gfc_scanner_done_1 (void)
101 while(line_head != NULL)
103 lb = line_head->next;
108 while(file_head != NULL)
111 gfc_free(file_head->filename);
119 /* Adds path to the list pointed to by list. */
122 gfc_add_include_path (const char *path)
124 gfc_directorylist *dir;
128 while (*p == ' ' || *p == '\t') /* someone might do 'gfortran "-I include"' */
135 dir = include_dirs = gfc_getmem (sizeof (gfc_directorylist));
142 dir->next = gfc_getmem (sizeof (gfc_directorylist));
147 dir->path = gfc_getmem (strlen (p) + 2);
148 strcpy (dir->path, p);
149 strcat (dir->path, "/"); /* make '/' last character */
153 /* Release resources allocated for options. */
156 gfc_release_include_path (void)
158 gfc_directorylist *p;
160 gfc_free (gfc_option.module_dir);
161 while (include_dirs != NULL)
164 include_dirs = include_dirs->next;
170 /* Opens file for reading, searching through the include directories
171 given if necessary. If the include_cwd argument is true, we try
172 to open the file in the current directory first. */
175 gfc_open_included_file (const char *name, const bool include_cwd)
178 gfc_directorylist *p;
183 f = gfc_open_file (name);
188 for (p = include_dirs; p; p = p->next)
190 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
191 strcpy (fullname, p->path);
192 strcat (fullname, name);
194 f = gfc_open_file (fullname);
202 /* Test to see if we're at the end of the main source file. */
212 /* Test to see if we're at the end of the current file. */
221 if (line_head == NULL)
222 return 1; /* Null file */
224 if (gfc_current_locus.lb == NULL)
231 /* Test to see if we're at the beginning of a new line. */
239 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
243 /* Test to see if we're at the end of a line. */
252 return (*gfc_current_locus.nextc == '\0');
256 /* Advance the current line pointer to the next line. */
259 gfc_advance_line (void)
264 if (gfc_current_locus.lb == NULL)
270 gfc_current_locus.lb = gfc_current_locus.lb->next;
272 if (gfc_current_locus.lb != NULL)
273 gfc_current_locus.nextc = gfc_current_locus.lb->line;
276 gfc_current_locus.nextc = NULL;
282 /* Get the next character from the input, advancing gfc_current_file's
283 locus. When we hit the end of the line or the end of the file, we
284 start returning a '\n' in order to complete the current statement.
285 No Fortran line conventions are implemented here.
287 Requiring explicit advances to the next line prevents the parse
288 pointer from being on the wrong line if the current statement ends
296 if (gfc_current_locus.nextc == NULL)
299 c = *gfc_current_locus.nextc++;
302 gfc_current_locus.nextc--; /* Remain on this line. */
309 /* Skip a comment. When we come here the parse pointer is positioned
310 immediately after the comment character. If we ever implement
311 compiler directives withing comments, here is where we parse the
315 skip_comment_line (void)
329 /* Comment lines are null lines, lines containing only blanks or lines
330 on which the first nonblank line is a '!'. */
333 skip_free_comments (void)
341 at_bol = gfc_at_bol ();
342 start = gfc_current_locus;
348 while (gfc_is_whitespace (c));
358 /* If -fopenmp, we need to handle here 2 things:
359 1) don't treat !$omp as comments, but directives
360 2) handle OpenMP conditional compilation, where
361 !$ should be treated as 2 spaces (for initial lines
362 only if followed by space). */
363 if (gfc_option.flag_openmp && at_bol)
365 locus old_loc = gfc_current_locus;
366 if (next_char () == '$')
369 if (c == 'o' || c == 'O')
371 if (((c = next_char ()) == 'm' || c == 'M')
372 && ((c = next_char ()) == 'p' || c == 'P')
373 && ((c = next_char ()) == ' ' || continue_flag))
375 while (gfc_is_whitespace (c))
377 if (c != '\n' && c != '!')
380 openmp_locus = old_loc;
381 gfc_current_locus = start;
385 gfc_current_locus = old_loc;
389 if (continue_flag || c == ' ')
391 gfc_current_locus = old_loc;
396 gfc_current_locus = old_loc;
398 skip_comment_line ();
405 if (openmp_flag && at_bol)
407 gfc_current_locus = start;
411 /* Skip comment lines in fixed source mode. We have the same rules as
412 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
413 in column 1, and a '!' cannot be in column 6. Also, we deal with
414 lines with 'd' or 'D' in column 1, if the user requested this. */
417 skip_fixed_comments (void)
425 start = gfc_current_locus;
430 while (gfc_is_whitespace (c));
435 skip_comment_line ();
440 gfc_current_locus = start;
447 start = gfc_current_locus;
458 if (c == '!' || c == 'c' || c == 'C' || c == '*')
460 /* If -fopenmp, we need to handle here 2 things:
461 1) don't treat !$omp|c$omp|*$omp as comments, but directives
462 2) handle OpenMP conditional compilation, where
463 !$|c$|*$ should be treated as 2 spaces if the characters
464 in columns 3 to 6 are valid fixed form label columns
466 if (gfc_option.flag_openmp)
468 if (next_char () == '$')
471 if (c == 'o' || c == 'O')
473 if (((c = next_char ()) == 'm' || c == 'M')
474 && ((c = next_char ()) == 'p' || c == 'P'))
478 && ((openmp_flag && continue_flag)
479 || c == ' ' || c == '0'))
482 while (gfc_is_whitespace (c))
484 if (c != '\n' && c != '!')
486 /* Canonicalize to *$omp. */
489 gfc_current_locus = start;
499 for (col = 3; col < 6; col++, c = next_char ())
502 else if (c < '0' || c > '9')
507 if (col == 6 && c != '\n'
508 && ((continue_flag && !digit_seen)
509 || c == ' ' || c == '0'))
511 gfc_current_locus = start;
512 start.nextc[0] = ' ';
513 start.nextc[1] = ' ';
518 gfc_current_locus = start;
520 skip_comment_line ();
524 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
526 if (gfc_option.flag_d_lines == 0)
528 skip_comment_line ();
532 *start.nextc = c = ' ';
537 while (gfc_is_whitespace (c))
549 if (col != 6 && c == '!')
551 skip_comment_line ();
559 gfc_current_locus = start;
563 /* Skips the current line if it is a comment. */
566 gfc_skip_comments (void)
568 if (gfc_current_form == FORM_FREE)
569 skip_free_comments ();
571 skip_fixed_comments ();
575 /* Get the next character from the input, taking continuation lines
576 and end-of-line comments into account. This implies that comment
577 lines between continued lines must be eaten here. For higher-level
578 subroutines, this flattens continued lines into a single logical
579 line. The in_string flag denotes whether we're inside a character
583 gfc_next_char_literal (int in_string)
586 int i, c, prev_openmp_flag;
598 if (gfc_current_form == FORM_FREE)
600 if (!in_string && c == '!')
603 && memcmp (&gfc_current_locus, &openmp_locus,
604 sizeof (gfc_current_locus)) == 0)
607 /* This line can't be continued */
614 /* Avoid truncation warnings for comment ending lines. */
615 gfc_current_locus.lb->truncated = 0;
623 /* If the next nonblank character is a ! or \n, we've got a
624 continuation line. */
625 old_loc = gfc_current_locus;
628 while (gfc_is_whitespace (c))
631 /* Character constants to be continued cannot have commentary
634 if (in_string && c != '\n')
636 gfc_current_locus = old_loc;
641 if (c != '!' && c != '\n')
643 gfc_current_locus = old_loc;
648 prev_openmp_flag = openmp_flag;
651 skip_comment_line ();
655 /* We've got a continuation line. If we are on the very next line after
656 the last continuation, increment the continuation line count and
657 check whether the limit has been exceeded. */
658 if (gfc_current_locus.lb->linenum == continue_line + 1)
660 if (++continue_count == gfc_option.max_continue_free)
662 if (gfc_notification_std (GFC_STD_GNU)
664 gfc_warning ("Limit of %d continuations exceeded in statement at %C",
665 gfc_option.max_continue_free);
668 continue_line = gfc_current_locus.lb->linenum;
670 /* Now find where it continues. First eat any comment lines. */
671 gfc_skip_comments ();
673 if (prev_openmp_flag != openmp_flag)
675 gfc_current_locus = old_loc;
676 openmp_flag = prev_openmp_flag;
681 /* Now that we have a non-comment line, probe ahead for the
682 first non-whitespace character. If it is another '&', then
683 reading starts at the next character, otherwise we must back
684 up to where the whitespace started and resume from there. */
686 old_loc = gfc_current_locus;
689 while (gfc_is_whitespace (c))
694 for (i = 0; i < 5; i++, c = next_char ())
696 gcc_assert (TOLOWER (c) == "!$omp"[i]);
698 old_loc = gfc_current_locus;
700 while (gfc_is_whitespace (c))
708 if (gfc_option.warn_ampersand)
709 gfc_warning_now ("Missing '&' in continued character constant at %C");
710 gfc_current_locus.nextc--;
715 gfc_current_locus = old_loc;
722 /* Fixed form continuation. */
723 if (!in_string && c == '!')
725 /* Skip comment at end of line. */
732 /* Avoid truncation warnings for comment ending lines. */
733 gfc_current_locus.lb->truncated = 0;
739 prev_openmp_flag = openmp_flag;
741 old_loc = gfc_current_locus;
744 gfc_skip_comments ();
746 /* See if this line is a continuation line. */
747 if (openmp_flag != prev_openmp_flag)
749 openmp_flag = prev_openmp_flag;
750 goto not_continuation;
754 for (i = 0; i < 5; i++)
758 goto not_continuation;
761 for (i = 0; i < 5; i++)
764 if (TOLOWER (c) != "*$omp"[i])
765 goto not_continuation;
769 if (c == '0' || c == ' ' || c == '\n')
770 goto not_continuation;
772 /* We've got a continuation line. If we are on the very next line after
773 the last continuation, increment the continuation line count and
774 check whether the limit has been exceeded. */
775 if (gfc_current_locus.lb->linenum == continue_line + 1)
777 if (++continue_count == gfc_option.max_continue_fixed)
779 if (gfc_notification_std (GFC_STD_GNU)
781 gfc_warning ("Limit of %d continuations exceeded in statement at %C",
782 gfc_option.max_continue_fixed);
786 if (continue_line < gfc_current_locus.lb->linenum)
787 continue_line = gfc_current_locus.lb->linenum;
790 /* Ready to read first character of continuation line, which might
791 be another continuation line! */
796 gfc_current_locus = old_loc;
806 /* Get the next character of input, folded to lowercase. In fixed
807 form mode, we also ignore spaces. When matcher subroutines are
808 parsing character literals, they have to call
809 gfc_next_char_literal(). */
818 c = gfc_next_char_literal (0);
820 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
832 old_loc = gfc_current_locus;
833 c = gfc_next_char ();
834 gfc_current_locus = old_loc;
840 /* Recover from an error. We try to get past the current statement
841 and get lined up for the next. The next statement follows a '\n'
842 or a ';'. We also assume that we are not within a character
843 constant, and deal with finding a '\'' or '"'. */
846 gfc_error_recovery (void)
855 c = gfc_next_char ();
856 if (c == '\n' || c == ';')
859 if (c != '\'' && c != '"')
888 /* Read ahead until the next character to be read is not whitespace. */
891 gfc_gobble_whitespace (void)
893 static int linenum = 0;
899 old_loc = gfc_current_locus;
900 c = gfc_next_char_literal (0);
901 /* Issue a warning for nonconforming tabs. We keep track of the line
902 number because the Fortran matchers will often back up and the same
903 line will be scanned multiple times. */
904 if (!gfc_option.warn_tabs && c == '\t')
906 #ifdef USE_MAPPED_LOCATION
907 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
909 int cur_linenum = gfc_current_locus.lb->linenum;
911 if (cur_linenum != linenum)
913 linenum = cur_linenum;
914 gfc_warning_now ("Nonconforming tab character at %C");
918 while (gfc_is_whitespace (c));
920 gfc_current_locus = old_loc;
924 /* Load a single line into pbuf.
926 If pbuf points to a NULL pointer, it is allocated.
927 We truncate lines that are too long, unless we're dealing with
928 preprocessor lines or if the option -ffixed-line-length-none is set,
929 in which case we reallocate the buffer to fit the entire line, if
931 In fixed mode, we expand a tab that occurs within the statement
932 label region to expand to spaces that leave the next character in
934 load_line returns whether the line was truncated. */
937 load_line (FILE * input, char **pbuf, int *pbuflen)
939 static int linenum = 0, current_line = 1;
940 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
941 int trunc_flag = 0, seen_comment = 0;
944 /* Determine the maximum allowed line length.
945 The default for free-form is GFC_MAX_LINE, for fixed-form or for
946 unknown form it is 72. Refer to the documentation in gfc_option_t. */
947 if (gfc_current_form == FORM_FREE)
949 if (gfc_option.free_line_length == -1)
950 maxlen = GFC_MAX_LINE;
952 maxlen = gfc_option.free_line_length;
954 else if (gfc_current_form == FORM_FIXED)
956 if (gfc_option.fixed_line_length == -1)
959 maxlen = gfc_option.fixed_line_length;
966 /* Allocate the line buffer, storing its length into buflen. */
970 buflen = GFC_MAX_LINE;
972 *pbuf = gfc_getmem (buflen + 1);
978 preprocessor_flag = 0;
981 /* In order to not truncate preprocessor lines, we have to
982 remember that this is one. */
983 preprocessor_flag = 1;
996 continue; /* Gobble characters. */
1002 /* Ctrl-Z ends the file. */
1003 while (fgetc (input) != EOF);
1007 /* Is this a fixed-form comment? */
1008 if (gfc_current_form == FORM_FIXED && i == 0
1009 && (c == '*' || c == 'c' || c == 'd'))
1012 if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
1014 /* The error machinery isn't available at this point, so we can't
1015 easily report line and column numbers consistent with other
1016 parts of gfortran. */
1017 if (!gfc_option.warn_tabs && seen_comment == 0
1018 && current_line != linenum)
1020 linenum = current_line;
1022 "Nonconforming tab character in column 1 of line %d", linenum);
1037 if (maxlen == 0 || preprocessor_flag)
1041 /* Reallocate line buffer to double size to hold the
1043 buflen = buflen * 2;
1044 *pbuf = xrealloc (*pbuf, buflen + 1);
1048 else if (i >= maxlen)
1050 /* Truncate the rest of the line. */
1054 if (c == '\n' || c == EOF)
1060 ungetc ('\n', input);
1064 /* Pad lines to the selected line length in fixed form. */
1065 if (gfc_current_form == FORM_FIXED
1066 && gfc_option.fixed_line_length != 0
1067 && !preprocessor_flag
1070 while (i++ < maxlen)
1082 /* Get a gfc_file structure, initialize it and add it to
1086 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1090 f = gfc_getmem (sizeof (gfc_file));
1092 f->filename = gfc_getmem (strlen (name) + 1);
1093 strcpy (f->filename, name);
1095 f->next = file_head;
1098 f->included_by = current_file;
1099 if (current_file != NULL)
1100 f->inclusion_line = current_file->line;
1102 #ifdef USE_MAPPED_LOCATION
1103 linemap_add (&line_table, reason, false, f->filename, 1);
1109 /* Deal with a line from the C preprocessor. The
1110 initial octothorp has already been seen. */
1113 preprocessor_line (char *c)
1119 int escaped, unescape;
1122 while (*c == ' ' || *c == '\t')
1125 if (*c < '0' || *c > '9')
1130 c = strchr (c, ' ');
1133 /* No file name given. Set new line number. */
1134 current_file->line = line;
1139 while (*c == ' ' || *c == '\t')
1149 /* Make filename end at quote. */
1152 while (*c && ! (! escaped && *c == '"'))
1156 else if (*c == '\\')
1165 /* Preprocessor line has no closing quote. */
1170 /* Undo effects of cpp_quote_string. */
1174 char *d = gfc_getmem (c - filename - unescape);
1190 flag[1] = flag[2] = flag[3] = flag[4] = false;
1194 c = strchr (c, ' ');
1201 if (1 <= i && i <= 4)
1205 /* Interpret flags. */
1207 if (flag[1]) /* Starting new file. */
1209 f = get_file (filename, LC_RENAME);
1210 f->up = current_file;
1214 if (flag[2]) /* Ending current file. */
1216 if (!current_file->up
1217 || strcmp (current_file->up->filename, filename) != 0)
1219 gfc_warning_now ("%s:%d: file %s left but not entered",
1220 current_file->filename, current_file->line,
1223 gfc_free (filename);
1226 current_file = current_file->up;
1229 /* The name of the file can be a temporary file produced by
1230 cpp. Replace the name if it is different. */
1232 if (strcmp (current_file->filename, filename) != 0)
1234 gfc_free (current_file->filename);
1235 current_file->filename = gfc_getmem (strlen (filename) + 1);
1236 strcpy (current_file->filename, filename);
1239 /* Set new line number. */
1240 current_file->line = line;
1242 gfc_free (filename);
1246 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1247 current_file->filename, current_file->line);
1248 current_file->line++;
1252 static try load_file (const char *, bool);
1254 /* include_line()-- Checks a line buffer to see if it is an include
1255 line. If so, we call load_file() recursively to load the included
1256 file. We never return a syntax error because a statement like
1257 "include = 5" is perfectly legal. We return false if no include was
1258 processed or true if we matched an include. */
1261 include_line (char *line)
1263 char quote, *c, *begin, *stop;
1267 if (gfc_option.flag_openmp)
1269 if (gfc_current_form == FORM_FREE)
1271 while (*c == ' ' || *c == '\t')
1273 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1278 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1279 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1284 while (*c == ' ' || *c == '\t')
1287 if (strncasecmp (c, "include", 7))
1291 while (*c == ' ' || *c == '\t')
1294 /* Find filename between quotes. */
1297 if (quote != '"' && quote != '\'')
1302 while (*c != quote && *c != '\0')
1310 while (*c == ' ' || *c == '\t')
1313 if (*c != '\0' && *c != '!')
1316 /* We have an include line at this point. */
1318 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1319 read by anything else. */
1321 load_file (begin, false);
1325 /* Load a file into memory by calling load_line until the file ends. */
1328 load_file (const char *filename, bool initial)
1336 for (f = current_file; f; f = f->up)
1337 if (strcmp (filename, f->filename) == 0)
1339 gfc_error_now ("File '%s' is being included recursively", filename);
1347 input = gfc_src_file;
1348 gfc_src_file = NULL;
1351 input = gfc_open_file (filename);
1354 gfc_error_now ("Can't open file '%s'", filename);
1360 input = gfc_open_included_file (filename, false);
1363 gfc_error_now ("Can't open included file '%s'", filename);
1368 /* Load the file. */
1370 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1371 f->up = current_file;
1373 current_file->line = 1;
1377 if (initial && gfc_src_preprocessor_lines[0])
1379 preprocessor_line (gfc_src_preprocessor_lines[0]);
1380 gfc_free (gfc_src_preprocessor_lines[0]);
1381 gfc_src_preprocessor_lines[0] = NULL;
1382 if (gfc_src_preprocessor_lines[1])
1384 preprocessor_line (gfc_src_preprocessor_lines[1]);
1385 gfc_free (gfc_src_preprocessor_lines[1]);
1386 gfc_src_preprocessor_lines[1] = NULL;
1392 int trunc = load_line (input, &line, &line_len);
1394 len = strlen (line);
1395 if (feof (input) && len == 0)
1398 /* There are three things this line can be: a line of Fortran
1399 source, an include line or a C preprocessor directive. */
1403 preprocessor_line (line);
1407 if (include_line (line))
1409 current_file->line++;
1415 b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1417 #ifdef USE_MAPPED_LOCATION
1419 = linemap_line_start (&line_table, current_file->line++, 120);
1421 b->linenum = current_file->line++;
1423 b->file = current_file;
1424 b->truncated = trunc;
1425 strcpy (b->line, line);
1427 if (line_head == NULL)
1430 line_tail->next = b;
1435 /* Release the line buffer allocated in load_line. */
1440 current_file = current_file->up;
1441 #ifdef USE_MAPPED_LOCATION
1442 linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1448 /* Open a new file and start scanning from that file. Returns SUCCESS
1449 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1450 it tries to determine the source form from the filename, defaulting
1458 result = load_file (gfc_source_file, true);
1460 gfc_current_locus.lb = line_head;
1461 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1463 #if 0 /* Debugging aid. */
1464 for (; line_head; line_head = line_head->next)
1465 gfc_status ("%s:%3d %s\n", line_head->file->filename,
1466 #ifdef USE_MAPPED_LOCATION
1467 LOCATION_LINE (line_head->location),
1480 unescape_filename (const char *ptr)
1482 const char *p = ptr, *s;
1484 int escaped, unescape = 0;
1486 /* Make filename end at quote. */
1488 while (*p && ! (! escaped && *p == '"'))
1492 else if (*p == '\\')
1503 /* Undo effects of cpp_quote_string. */
1505 d = gfc_getmem (p + 1 - ptr - unescape);
1520 /* For preprocessed files, if the first tokens are of the form # NUM.
1521 handle the directives so we know the original file name. */
1524 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1529 gfc_src_file = gfc_open_file (filename);
1530 if (gfc_src_file == NULL)
1533 c = fgetc (gfc_src_file);
1534 ungetc (c, gfc_src_file);
1540 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1542 if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1545 filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
1546 if (filename == NULL)
1549 c = fgetc (gfc_src_file);
1550 ungetc (c, gfc_src_file);
1556 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1558 if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1561 dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
1562 if (dirname == NULL)
1565 len = strlen (dirname);
1566 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1571 dirname[len - 2] = '\0';
1572 set_src_pwd (dirname);
1574 if (! IS_ABSOLUTE_PATH (filename))
1576 char *p = gfc_getmem (len + strlen (filename));
1578 memcpy (p, dirname, len - 2);
1580 strcpy (p + len - 1, filename);
1581 *canon_source_file = p;