OSDN Git Service

2008-04-06 Tobias Schlter <tobi@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / scanner.c
1 /* Character scanner.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3    Free Software Foundation, Inc.
4    Contributed by Andy Vaught
5
6 This file is part of GCC.
7
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
11 version.
12
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
16 for more details.
17
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/>.  */
21
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.
26
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
31    parsing.
32
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.
36
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
39    truncated stuff.
40
41    From the scanner's viewpoint, the higher level subroutines ask for
42    new characters and do a lot of jumping backwards.  */
43
44 #include "config.h"
45 #include "system.h"
46 #include "gfortran.h"
47 #include "toplev.h"
48 #include "debug.h"
49 #include "flags.h"
50
51 /* Structure for holding module and include file search path.  */
52 typedef struct gfc_directorylist
53 {
54   char *path;
55   bool use_for_modules;
56   struct gfc_directorylist *next;
57 }
58 gfc_directorylist;
59
60 /* List of include file search directories.  */
61 static gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
62
63 static gfc_file *file_head, *current_file;
64
65 static int continue_flag, end_flag, openmp_flag;
66 static int continue_count, continue_line;
67 static locus openmp_locus;
68
69 gfc_source_form gfc_current_form;
70 static gfc_linebuf *line_head, *line_tail;
71        
72 locus gfc_current_locus;
73 const char *gfc_source_file;
74 static FILE *gfc_src_file;
75 static char *gfc_src_preprocessor_lines[2];
76
77 extern int pedantic;
78
79 static struct gfc_file_change
80 {
81   const char *filename;
82   gfc_linebuf *lb;
83   int line;
84 } *file_changes;
85 size_t file_changes_cur, file_changes_count;
86 size_t file_changes_allocated;
87
88 /* Main scanner initialization.  */
89
90 void
91 gfc_scanner_init_1 (void)
92 {
93   file_head = NULL;
94   line_head = NULL;
95   line_tail = NULL;
96
97   continue_count = 0;
98   continue_line = 0;
99
100   end_flag = 0;
101 }
102
103
104 /* Main scanner destructor.  */
105
106 void
107 gfc_scanner_done_1 (void)
108 {
109   gfc_linebuf *lb;
110   gfc_file *f;
111
112   while(line_head != NULL) 
113     {
114       lb = line_head->next;
115       gfc_free(line_head);
116       line_head = lb;
117     }
118      
119   while(file_head != NULL) 
120     {
121       f = file_head->next;
122       gfc_free(file_head->filename);
123       gfc_free(file_head);
124       file_head = f;    
125     }
126 }
127
128
129 /* Adds path to the list pointed to by list.  */
130
131 static void
132 add_path_to_list (gfc_directorylist **list, const char *path,
133                   bool use_for_modules)
134 {
135   gfc_directorylist *dir;
136   const char *p;
137
138   p = path;
139   while (*p == ' ' || *p == '\t')  /* someone might do "-I include" */
140     if (*p++ == '\0')
141       return;
142
143   dir = *list;
144   if (!dir)
145     dir = *list = gfc_getmem (sizeof (gfc_directorylist));
146   else
147     {
148       while (dir->next)
149         dir = dir->next;
150
151       dir->next = gfc_getmem (sizeof (gfc_directorylist));
152       dir = dir->next;
153     }
154
155   dir->next = NULL;
156   dir->use_for_modules = use_for_modules;
157   dir->path = gfc_getmem (strlen (p) + 2);
158   strcpy (dir->path, p);
159   strcat (dir->path, "/");      /* make '/' last character */
160 }
161
162
163 void
164 gfc_add_include_path (const char *path, bool use_for_modules)
165 {
166   add_path_to_list (&include_dirs, path, use_for_modules);
167 }
168
169
170 void
171 gfc_add_intrinsic_modules_path (const char *path)
172 {
173   add_path_to_list (&intrinsic_modules_dirs, path, true);
174 }
175
176
177 /* Release resources allocated for options.  */
178
179 void
180 gfc_release_include_path (void)
181 {
182   gfc_directorylist *p;
183
184   while (include_dirs != NULL)
185     {
186       p = include_dirs;
187       include_dirs = include_dirs->next;
188       gfc_free (p->path);
189       gfc_free (p);
190     }
191
192   while (intrinsic_modules_dirs != NULL)
193     {
194       p = intrinsic_modules_dirs;
195       intrinsic_modules_dirs = intrinsic_modules_dirs->next;
196       gfc_free (p->path);
197       gfc_free (p);
198     }
199
200   gfc_free (gfc_option.module_dir);
201 }
202
203
204 static FILE *
205 open_included_file (const char *name, gfc_directorylist *list, bool module)
206 {
207   char *fullname;
208   gfc_directorylist *p;
209   FILE *f;
210
211   for (p = list; p; p = p->next)
212     {
213       if (module && !p->use_for_modules)
214         continue;
215
216       fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
217       strcpy (fullname, p->path);
218       strcat (fullname, name);
219
220       f = gfc_open_file (fullname);
221       if (f != NULL)
222         return f;
223     }
224
225   return NULL;
226 }
227
228
229 /* Opens file for reading, searching through the include directories
230    given if necessary.  If the include_cwd argument is true, we try
231    to open the file in the current directory first.  */
232
233 FILE *
234 gfc_open_included_file (const char *name, bool include_cwd, bool module)
235 {
236   FILE *f;
237
238   if (IS_ABSOLUTE_PATH (name))
239     return gfc_open_file (name);
240
241   if (include_cwd)
242     {
243       f = gfc_open_file (name);
244       if (f != NULL)
245         return f;
246     }
247
248   return open_included_file (name, include_dirs, module);
249 }
250
251 FILE *
252 gfc_open_intrinsic_module (const char *name)
253 {
254   if (IS_ABSOLUTE_PATH (name))
255     return gfc_open_file (name);
256
257   return open_included_file (name, intrinsic_modules_dirs, true);
258 }
259
260
261 /* Test to see if we're at the end of the main source file.  */
262
263 int
264 gfc_at_end (void)
265 {
266   return end_flag;
267 }
268
269
270 /* Test to see if we're at the end of the current file.  */
271
272 int
273 gfc_at_eof (void)
274 {
275   if (gfc_at_end ())
276     return 1;
277
278   if (line_head == NULL)
279     return 1;                   /* Null file */
280
281   if (gfc_current_locus.lb == NULL)
282     return 1;
283
284   return 0;
285 }
286
287
288 /* Test to see if we're at the beginning of a new line.  */
289
290 int
291 gfc_at_bol (void)
292 {
293   if (gfc_at_eof ())
294     return 1;
295
296   return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
297 }
298
299
300 /* Test to see if we're at the end of a line.  */
301
302 int
303 gfc_at_eol (void)
304 {
305   if (gfc_at_eof ())
306     return 1;
307
308   return (*gfc_current_locus.nextc == '\0');
309 }
310
311 static void
312 add_file_change (const char *filename, int line)
313 {
314   if (file_changes_count == file_changes_allocated)
315     {
316       if (file_changes_allocated)
317         file_changes_allocated *= 2;
318       else
319         file_changes_allocated = 16;
320       file_changes
321         = xrealloc (file_changes,
322                     file_changes_allocated * sizeof (*file_changes));
323     }
324   file_changes[file_changes_count].filename = filename;
325   file_changes[file_changes_count].lb = NULL;
326   file_changes[file_changes_count++].line = line;
327 }
328
329 static void
330 report_file_change (gfc_linebuf *lb)
331 {
332   size_t c = file_changes_cur;
333   while (c < file_changes_count
334          && file_changes[c].lb == lb)
335     {
336       if (file_changes[c].filename)
337         (*debug_hooks->start_source_file) (file_changes[c].line,
338                                            file_changes[c].filename);
339       else
340         (*debug_hooks->end_source_file) (file_changes[c].line);
341       ++c;
342     }
343   file_changes_cur = c;
344 }
345
346 void
347 gfc_start_source_files (void)
348 {
349   /* If the debugger wants the name of the main source file,
350      we give it.  */
351   if (debug_hooks->start_end_main_source_file)
352     (*debug_hooks->start_source_file) (0, gfc_source_file);
353
354   file_changes_cur = 0;
355   report_file_change (gfc_current_locus.lb);
356 }
357
358 void
359 gfc_end_source_files (void)
360 {
361   report_file_change (NULL);
362
363   if (debug_hooks->start_end_main_source_file)
364     (*debug_hooks->end_source_file) (0);
365 }
366
367 /* Advance the current line pointer to the next line.  */
368
369 void
370 gfc_advance_line (void)
371 {
372   if (gfc_at_end ())
373     return;
374
375   if (gfc_current_locus.lb == NULL) 
376     {
377       end_flag = 1;
378       return;
379     } 
380
381   if (gfc_current_locus.lb->next
382       && !gfc_current_locus.lb->next->dbg_emitted)
383     {
384       report_file_change (gfc_current_locus.lb->next);
385       gfc_current_locus.lb->next->dbg_emitted = true;
386     }
387
388   gfc_current_locus.lb = gfc_current_locus.lb->next;
389
390   if (gfc_current_locus.lb != NULL)      
391     gfc_current_locus.nextc = gfc_current_locus.lb->line;
392   else 
393     {
394       gfc_current_locus.nextc = NULL;
395       end_flag = 1;
396     }       
397 }
398
399
400 /* Get the next character from the input, advancing gfc_current_file's
401    locus.  When we hit the end of the line or the end of the file, we
402    start returning a '\n' in order to complete the current statement.
403    No Fortran line conventions are implemented here.
404
405    Requiring explicit advances to the next line prevents the parse
406    pointer from being on the wrong line if the current statement ends
407    prematurely.  */
408
409 static int
410 next_char (void)
411 {
412   int c;
413   
414   if (gfc_current_locus.nextc == NULL)
415     return '\n';
416
417   c = (unsigned char) *gfc_current_locus.nextc++;
418   if (c == '\0')
419     {
420       gfc_current_locus.nextc--; /* Remain on this line.  */
421       c = '\n';
422     }
423
424   return c;
425 }
426
427
428 /* Skip a comment.  When we come here the parse pointer is positioned
429    immediately after the comment character.  If we ever implement
430    compiler directives withing comments, here is where we parse the
431    directive.  */
432
433 static void
434 skip_comment_line (void)
435 {
436   char c;
437
438   do
439     {
440       c = next_char ();
441     }
442   while (c != '\n');
443
444   gfc_advance_line ();
445 }
446
447
448 int
449 gfc_define_undef_line (void)
450 {
451   /* All lines beginning with '#' are either #define or #undef.  */
452   if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_char () != '#')
453     return 0;
454
455   if (strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
456     (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
457                             &(gfc_current_locus.nextc[8]));
458
459   if (strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
460     (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
461                            &(gfc_current_locus.nextc[7]));
462
463   /* Skip the rest of the line.  */
464   skip_comment_line ();
465
466   return 1;
467 }
468
469
470 /* Comment lines are null lines, lines containing only blanks or lines
471    on which the first nonblank line is a '!'.
472    Return true if !$ openmp conditional compilation sentinel was
473    seen.  */
474
475 static bool
476 skip_free_comments (void)
477 {
478   locus start;
479   char c;
480   int at_bol;
481
482   for (;;)
483     {
484       at_bol = gfc_at_bol ();
485       start = gfc_current_locus;
486       if (gfc_at_eof ())
487         break;
488
489       do
490         c = next_char ();
491       while (gfc_is_whitespace (c));
492
493       if (c == '\n')
494         {
495           gfc_advance_line ();
496           continue;
497         }
498
499       if (c == '!')
500         {
501           /* If -fopenmp, we need to handle here 2 things:
502              1) don't treat !$omp as comments, but directives
503              2) handle OpenMP conditional compilation, where
504                 !$ should be treated as 2 spaces (for initial lines
505                 only if followed by space).  */
506           if (gfc_option.flag_openmp && at_bol)
507             {
508               locus old_loc = gfc_current_locus;
509               if (next_char () == '$')
510                 {
511                   c = next_char ();
512                   if (c == 'o' || c == 'O')
513                     {
514                       if (((c = next_char ()) == 'm' || c == 'M')
515                           && ((c = next_char ()) == 'p' || c == 'P'))
516                         {
517                           if ((c = next_char ()) == ' ' || continue_flag)
518                             {
519                               while (gfc_is_whitespace (c))
520                                 c = next_char ();
521                               if (c != '\n' && c != '!')
522                                 {
523                                   openmp_flag = 1;
524                                   openmp_locus = old_loc;
525                                   gfc_current_locus = start;
526                                   return false;
527                                 }
528                             }
529                           else
530                             gfc_warning_now ("!$OMP at %C starts a commented "
531                                              "line as it neither is followed "
532                                              "by a space nor is a "
533                                              "continuation line");
534                         }
535                       gfc_current_locus = old_loc;
536                       next_char ();
537                       c = next_char ();
538                     }
539                   if (continue_flag || c == ' ')
540                     {
541                       gfc_current_locus = old_loc;
542                       next_char ();
543                       openmp_flag = 0;
544                       return true;
545                     }
546                 }
547               gfc_current_locus = old_loc;
548             }
549           skip_comment_line ();
550           continue;
551         }
552
553       break;
554     }
555
556   if (openmp_flag && at_bol)
557     openmp_flag = 0;
558   gfc_current_locus = start;
559   return false;
560 }
561
562
563 /* Skip comment lines in fixed source mode.  We have the same rules as
564    in skip_free_comment(), except that we can have a 'c', 'C' or '*'
565    in column 1, and a '!' cannot be in column 6.  Also, we deal with
566    lines with 'd' or 'D' in column 1, if the user requested this.  */
567
568 static void
569 skip_fixed_comments (void)
570 {
571   locus start;
572   int col;
573   char c;
574
575   if (! gfc_at_bol ())
576     {
577       start = gfc_current_locus;
578       if (! gfc_at_eof ())
579         {
580           do
581             c = next_char ();
582           while (gfc_is_whitespace (c));
583
584           if (c == '\n')
585             gfc_advance_line ();
586           else if (c == '!')
587             skip_comment_line ();
588         }
589
590       if (! gfc_at_bol ())
591         {
592           gfc_current_locus = start;
593           return;
594         }
595     }
596
597   for (;;)
598     {
599       start = gfc_current_locus;
600       if (gfc_at_eof ())
601         break;
602
603       c = next_char ();
604       if (c == '\n')
605         {
606           gfc_advance_line ();
607           continue;
608         }
609
610       if (c == '!' || c == 'c' || c == 'C' || c == '*')
611         {
612           /* If -fopenmp, we need to handle here 2 things:
613              1) don't treat !$omp|c$omp|*$omp as comments, but directives
614              2) handle OpenMP conditional compilation, where
615                 !$|c$|*$ should be treated as 2 spaces if the characters
616                 in columns 3 to 6 are valid fixed form label columns
617                 characters.  */
618           if (gfc_option.flag_openmp)
619             {
620               if (next_char () == '$')
621                 {
622                   c = next_char ();
623                   if (c == 'o' || c == 'O')
624                     {
625                       if (((c = next_char ()) == 'm' || c == 'M')
626                           && ((c = next_char ()) == 'p' || c == 'P'))
627                         {
628                           c = next_char ();
629                           if (c != '\n'
630                               && ((openmp_flag && continue_flag)
631                                   || c == ' ' || c == '0'))
632                             {
633                               c = next_char ();
634                               while (gfc_is_whitespace (c))
635                                 c = next_char ();
636                               if (c != '\n' && c != '!')
637                                 {
638                                   /* Canonicalize to *$omp.  */
639                                   *start.nextc = '*';
640                                   openmp_flag = 1;
641                                   gfc_current_locus = start;
642                                   return;
643                                 }
644                             }
645                         }
646                     }
647                   else
648                     {
649                       int digit_seen = 0;
650
651                       for (col = 3; col < 6; col++, c = next_char ())
652                         if (c == ' ')
653                           continue;
654                         else if (c < '0' || c > '9')
655                           break;
656                         else
657                           digit_seen = 1;
658
659                       if (col == 6 && c != '\n'
660                           && ((continue_flag && !digit_seen)
661                               || c == ' ' || c == '0'))
662                         {
663                           gfc_current_locus = start;
664                           start.nextc[0] = ' ';
665                           start.nextc[1] = ' ';
666                           continue;
667                         }
668                     }
669                 }
670               gfc_current_locus = start;
671             }
672           skip_comment_line ();
673           continue;
674         }
675
676       if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
677         {
678           if (gfc_option.flag_d_lines == 0)
679             {
680               skip_comment_line ();
681               continue;
682             }
683           else
684             *start.nextc = c = ' ';
685         }
686
687       col = 1;
688
689       while (gfc_is_whitespace (c))
690         {
691           c = next_char ();
692           col++;
693         }
694
695       if (c == '\n')
696         {
697           gfc_advance_line ();
698           continue;
699         }
700
701       if (col != 6 && c == '!')
702         {
703           skip_comment_line ();
704           continue;
705         }
706
707       break;
708     }
709
710   openmp_flag = 0;
711   gfc_current_locus = start;
712 }
713
714
715 /* Skips the current line if it is a comment.  */
716
717 void
718 gfc_skip_comments (void)
719 {
720   if (gfc_current_form == FORM_FREE)
721     skip_free_comments ();
722   else
723     skip_fixed_comments ();
724 }
725
726
727 /* Get the next character from the input, taking continuation lines
728    and end-of-line comments into account.  This implies that comment
729    lines between continued lines must be eaten here.  For higher-level
730    subroutines, this flattens continued lines into a single logical
731    line.  The in_string flag denotes whether we're inside a character
732    context or not.  */
733
734 int
735 gfc_next_char_literal (int in_string)
736 {
737   locus old_loc;
738   int i, c, prev_openmp_flag;
739
740   continue_flag = 0;
741
742 restart:
743   c = next_char ();
744   if (gfc_at_end ())
745     {
746       continue_count = 0;
747       return c;
748     }
749
750   if (gfc_current_form == FORM_FREE)
751     {
752       bool openmp_cond_flag;
753
754       if (!in_string && c == '!')
755         {
756           if (openmp_flag
757               && memcmp (&gfc_current_locus, &openmp_locus,
758                  sizeof (gfc_current_locus)) == 0)
759             goto done;
760
761           /* This line can't be continued */
762           do
763             {
764               c = next_char ();
765             }
766           while (c != '\n');
767
768           /* Avoid truncation warnings for comment ending lines.  */
769           gfc_current_locus.lb->truncated = 0;
770
771           goto done;
772         }
773
774       if (c != '&')
775         goto done;
776
777       /* If the next nonblank character is a ! or \n, we've got a
778          continuation line.  */
779       old_loc = gfc_current_locus;
780
781       c = next_char ();
782       while (gfc_is_whitespace (c))
783         c = next_char ();
784
785       /* Character constants to be continued cannot have commentary
786          after the '&'.  */
787
788       if (in_string && c != '\n')
789         {
790           gfc_current_locus = old_loc;
791           c = '&';
792           goto done;
793         }
794
795       if (c != '!' && c != '\n')
796         {
797           gfc_current_locus = old_loc;
798           c = '&';
799           goto done;
800         }
801
802       prev_openmp_flag = openmp_flag;
803       continue_flag = 1;
804       if (c == '!')
805         skip_comment_line ();
806       else
807         gfc_advance_line ();
808       
809       if (gfc_at_eof())
810         goto not_continuation;
811
812       /* We've got a continuation line.  If we are on the very next line after
813          the last continuation, increment the continuation line count and
814          check whether the limit has been exceeded.  */
815       if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
816         {
817           if (++continue_count == gfc_option.max_continue_free)
818             {
819               if (gfc_notification_std (GFC_STD_GNU) || pedantic)
820                 gfc_warning ("Limit of %d continuations exceeded in "
821                              "statement at %C", gfc_option.max_continue_free);
822             }
823         }
824       continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
825
826       /* Now find where it continues. First eat any comment lines.  */
827       openmp_cond_flag = skip_free_comments ();
828
829       if (prev_openmp_flag != openmp_flag)
830         {
831           gfc_current_locus = old_loc;
832           openmp_flag = prev_openmp_flag;
833           c = '&';
834           goto done;
835         }
836
837       /* Now that we have a non-comment line, probe ahead for the
838          first non-whitespace character.  If it is another '&', then
839          reading starts at the next character, otherwise we must back
840          up to where the whitespace started and resume from there.  */
841
842       old_loc = gfc_current_locus;
843
844       c = next_char ();
845       while (gfc_is_whitespace (c))
846         c = next_char ();
847
848       if (openmp_flag)
849         {
850           for (i = 0; i < 5; i++, c = next_char ())
851             {
852               gcc_assert (TOLOWER (c) == "!$omp"[i]);
853               if (i == 4)
854                 old_loc = gfc_current_locus;
855             }
856           while (gfc_is_whitespace (c))
857             c = next_char ();
858         }
859
860       if (c != '&')
861         {
862           if (in_string)
863             {
864               if (gfc_option.warn_ampersand)
865                 gfc_warning_now ("Missing '&' in continued character "
866                                  "constant at %C");
867               gfc_current_locus.nextc--;
868             }
869           /* Both !$omp and !$ -fopenmp continuation lines have & on the
870              continuation line only optionally.  */
871           else if (openmp_flag || openmp_cond_flag)
872             gfc_current_locus.nextc--;
873           else
874             {
875               c = ' ';
876               gfc_current_locus = old_loc;
877               goto done;
878             }
879         }
880     }
881   else
882     {
883       /* Fixed form continuation.  */
884       if (!in_string && c == '!')
885         {
886           /* Skip comment at end of line.  */
887           do
888             {
889               c = next_char ();
890             }
891           while (c != '\n');
892
893           /* Avoid truncation warnings for comment ending lines.  */
894           gfc_current_locus.lb->truncated = 0;
895         }
896
897       if (c != '\n')
898         goto done;
899
900       prev_openmp_flag = openmp_flag;
901       continue_flag = 1;
902       old_loc = gfc_current_locus;
903
904       gfc_advance_line ();
905       skip_fixed_comments ();
906
907       /* See if this line is a continuation line.  */
908       if (openmp_flag != prev_openmp_flag)
909         {
910           openmp_flag = prev_openmp_flag;
911           goto not_continuation;
912         }
913
914       if (!openmp_flag)
915         for (i = 0; i < 5; i++)
916           {
917             c = next_char ();
918             if (c != ' ')
919               goto not_continuation;
920           }
921       else
922         for (i = 0; i < 5; i++)
923           {
924             c = next_char ();
925             if (TOLOWER (c) != "*$omp"[i])
926               goto not_continuation;
927           }
928
929       c = next_char ();
930       if (c == '0' || c == ' ' || c == '\n')
931         goto not_continuation;
932
933       /* We've got a continuation line.  If we are on the very next line after
934          the last continuation, increment the continuation line count and
935          check whether the limit has been exceeded.  */
936       if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
937         {
938           if (++continue_count == gfc_option.max_continue_fixed)
939             {
940               if (gfc_notification_std (GFC_STD_GNU) || pedantic)
941                 gfc_warning ("Limit of %d continuations exceeded in "
942                              "statement at %C",
943                              gfc_option.max_continue_fixed);
944             }
945         }
946
947       if (continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
948         continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
949     }
950
951   /* Ready to read first character of continuation line, which might
952      be another continuation line!  */
953   goto restart;
954
955 not_continuation:
956   c = '\n';
957   gfc_current_locus = old_loc;
958
959 done:
960   if (c == '\n')
961     continue_count = 0;
962   continue_flag = 0;
963   return c;
964 }
965
966
967 /* Get the next character of input, folded to lowercase.  In fixed
968    form mode, we also ignore spaces.  When matcher subroutines are
969    parsing character literals, they have to call
970    gfc_next_char_literal().  */
971
972 int
973 gfc_next_char (void)
974 {
975   int c;
976
977   do
978     {
979       c = gfc_next_char_literal (0);
980     }
981   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
982
983   return TOLOWER (c);
984 }
985
986
987 int
988 gfc_peek_char (void)
989 {
990   locus old_loc;
991   int c;
992
993   old_loc = gfc_current_locus;
994   c = gfc_next_char ();
995   gfc_current_locus = old_loc;
996
997   return c;
998 }
999
1000
1001 /* Recover from an error.  We try to get past the current statement
1002    and get lined up for the next.  The next statement follows a '\n'
1003    or a ';'.  We also assume that we are not within a character
1004    constant, and deal with finding a '\'' or '"'.  */
1005
1006 void
1007 gfc_error_recovery (void)
1008 {
1009   char c, delim;
1010
1011   if (gfc_at_eof ())
1012     return;
1013
1014   for (;;)
1015     {
1016       c = gfc_next_char ();
1017       if (c == '\n' || c == ';')
1018         break;
1019
1020       if (c != '\'' && c != '"')
1021         {
1022           if (gfc_at_eof ())
1023             break;
1024           continue;
1025         }
1026       delim = c;
1027
1028       for (;;)
1029         {
1030           c = next_char ();
1031
1032           if (c == delim)
1033             break;
1034           if (c == '\n')
1035             return;
1036           if (c == '\\')
1037             {
1038               c = next_char ();
1039               if (c == '\n')
1040                 return;
1041             }
1042         }
1043       if (gfc_at_eof ())
1044         break;
1045     }
1046 }
1047
1048
1049 /* Read ahead until the next character to be read is not whitespace.  */
1050
1051 void
1052 gfc_gobble_whitespace (void)
1053 {
1054   static int linenum = 0;
1055   locus old_loc;
1056   int c;
1057
1058   do
1059     {
1060       old_loc = gfc_current_locus;
1061       c = gfc_next_char_literal (0);
1062       /* Issue a warning for nonconforming tabs.  We keep track of the line
1063          number because the Fortran matchers will often back up and the same
1064          line will be scanned multiple times.  */
1065       if (!gfc_option.warn_tabs && c == '\t')
1066         {
1067           int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1068           if (cur_linenum != linenum)
1069             {
1070               linenum = cur_linenum;
1071               gfc_warning_now ("Nonconforming tab character at %C");
1072             }
1073         }
1074     }
1075   while (gfc_is_whitespace (c));
1076
1077   gfc_current_locus = old_loc;
1078 }
1079
1080
1081 /* Load a single line into pbuf.
1082
1083    If pbuf points to a NULL pointer, it is allocated.
1084    We truncate lines that are too long, unless we're dealing with
1085    preprocessor lines or if the option -ffixed-line-length-none is set,
1086    in which case we reallocate the buffer to fit the entire line, if
1087    need be.
1088    In fixed mode, we expand a tab that occurs within the statement
1089    label region to expand to spaces that leave the next character in
1090    the source region.
1091    load_line returns whether the line was truncated.
1092
1093    NOTE: The error machinery isn't available at this point, so we can't
1094          easily report line and column numbers consistent with other 
1095          parts of gfortran.  */
1096
1097 static int
1098 load_line (FILE *input, char **pbuf, int *pbuflen)
1099 {
1100   static int linenum = 0, current_line = 1;
1101   int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1102   int trunc_flag = 0, seen_comment = 0;
1103   int seen_printable = 0, seen_ampersand = 0;
1104   char *buffer;
1105   bool found_tab = false;
1106
1107   /* Determine the maximum allowed line length.  */
1108   if (gfc_current_form == FORM_FREE)
1109     maxlen = gfc_option.free_line_length;
1110   else if (gfc_current_form == FORM_FIXED)
1111     maxlen = gfc_option.fixed_line_length;
1112   else
1113     maxlen = 72;
1114
1115   if (*pbuf == NULL)
1116     {
1117       /* Allocate the line buffer, storing its length into buflen.
1118          Note that if maxlen==0, indicating that arbitrary-length lines
1119          are allowed, the buffer will be reallocated if this length is
1120          insufficient; since 132 characters is the length of a standard
1121          free-form line, we use that as a starting guess.  */
1122       if (maxlen > 0)
1123         buflen = maxlen;
1124       else
1125         buflen = 132;
1126
1127       *pbuf = gfc_getmem (buflen + 1);
1128     }
1129
1130   i = 0;
1131   buffer = *pbuf;
1132
1133   preprocessor_flag = 0;
1134   c = getc (input);
1135   if (c == '#')
1136     /* In order to not truncate preprocessor lines, we have to
1137        remember that this is one.  */
1138     preprocessor_flag = 1;
1139   ungetc (c, input);
1140
1141   for (;;)
1142     {
1143       c = getc (input);
1144
1145       if (c == EOF)
1146         break;
1147       if (c == '\n')
1148         {
1149           /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3.  */
1150           if (gfc_current_form == FORM_FREE 
1151               && !seen_printable && seen_ampersand)
1152             {
1153               if (pedantic)
1154                 gfc_error_now ("'&' not allowed by itself in line %d",
1155                                current_line);
1156               else
1157                 gfc_warning_now ("'&' not allowed by itself in line %d",
1158                                  current_line);
1159             }
1160           break;
1161         }
1162
1163       if (c == '\r')
1164         continue;               /* Gobble characters.  */
1165       if (c == '\0')
1166         continue;
1167
1168       if (c == '&')
1169         {
1170           if (seen_ampersand)
1171             seen_ampersand = 0;
1172           else
1173             seen_ampersand = 1;
1174         }
1175
1176       if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1177         seen_printable = 1;
1178
1179       /* Is this a fixed-form comment?  */
1180       if (gfc_current_form == FORM_FIXED && i == 0
1181           && (c == '*' || c == 'c' || c == 'd'))
1182         seen_comment = 1;
1183
1184       /* Vendor extension: "<tab>1" marks a continuation line.  */
1185       if (found_tab)
1186         {
1187           found_tab = false;
1188           if (c >= '1' && c <= '9')
1189             {
1190               *(buffer-1) = c;
1191               continue;
1192             }
1193         }
1194
1195       if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1196         {
1197           found_tab = true;
1198
1199           if (!gfc_option.warn_tabs && seen_comment == 0
1200               && current_line != linenum)
1201             {
1202               linenum = current_line;
1203               gfc_warning_now ("Nonconforming tab character in column %d "
1204                                "of line %d", i+1, linenum);
1205             }
1206
1207           while (i < 6)
1208             {
1209               *buffer++ = ' ';
1210               i++;
1211             }
1212
1213           continue;
1214         }
1215
1216       *buffer++ = c;
1217       i++;
1218
1219       if (maxlen == 0 || preprocessor_flag)
1220         {
1221           if (i >= buflen)
1222             {
1223               /* Reallocate line buffer to double size to hold the
1224                 overlong line.  */
1225               buflen = buflen * 2;
1226               *pbuf = xrealloc (*pbuf, buflen + 1);
1227               buffer = (*pbuf) + i;
1228             }
1229         }
1230       else if (i >= maxlen)
1231         {
1232           /* Truncate the rest of the line.  */
1233           for (;;)
1234             {
1235               c = getc (input);
1236               if (c == '\n' || c == EOF)
1237                 break;
1238
1239               trunc_flag = 1;
1240             }
1241
1242           ungetc ('\n', input);
1243         }
1244     }
1245
1246   /* Pad lines to the selected line length in fixed form.  */
1247   if (gfc_current_form == FORM_FIXED
1248       && gfc_option.fixed_line_length != 0
1249       && !preprocessor_flag
1250       && c != EOF)
1251     {
1252       while (i++ < maxlen)
1253         *buffer++ = ' ';
1254     }
1255
1256   *buffer = '\0';
1257   *pbuflen = buflen;
1258   current_line++;
1259
1260   return trunc_flag;
1261 }
1262
1263
1264 /* Get a gfc_file structure, initialize it and add it to
1265    the file stack.  */
1266
1267 static gfc_file *
1268 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1269 {
1270   gfc_file *f;
1271
1272   f = gfc_getmem (sizeof (gfc_file));
1273
1274   f->filename = gfc_getmem (strlen (name) + 1);
1275   strcpy (f->filename, name);
1276
1277   f->next = file_head;
1278   file_head = f;
1279
1280   f->up = current_file;
1281   if (current_file != NULL)
1282     f->inclusion_line = current_file->line;
1283
1284   linemap_add (line_table, reason, false, f->filename, 1);
1285
1286   return f;
1287 }
1288
1289 /* Deal with a line from the C preprocessor. The
1290    initial octothorp has already been seen.  */
1291
1292 static void
1293 preprocessor_line (char *c)
1294 {
1295   bool flag[5];
1296   int i, line;
1297   char *filename;
1298   gfc_file *f;
1299   int escaped, unescape;
1300
1301   c++;
1302   while (*c == ' ' || *c == '\t')
1303     c++;
1304
1305   if (*c < '0' || *c > '9')
1306     goto bad_cpp_line;
1307
1308   line = atoi (c);
1309
1310   c = strchr (c, ' ');
1311   if (c == NULL)
1312     {
1313       /* No file name given.  Set new line number.  */
1314       current_file->line = line;
1315       return;
1316     }
1317
1318   /* Skip spaces.  */
1319   while (*c == ' ' || *c == '\t')
1320     c++;
1321
1322   /* Skip quote.  */
1323   if (*c != '"')
1324     goto bad_cpp_line;
1325   ++c;
1326
1327   filename = c;
1328
1329   /* Make filename end at quote.  */
1330   unescape = 0;
1331   escaped = false;
1332   while (*c && ! (!escaped && *c == '"'))
1333     {
1334       if (escaped)
1335         escaped = false;
1336       else if (*c == '\\')
1337         {
1338           escaped = true;
1339           unescape++;
1340         }
1341       ++c;
1342     }
1343
1344   if (! *c)
1345     /* Preprocessor line has no closing quote.  */
1346     goto bad_cpp_line;
1347
1348   *c++ = '\0';
1349
1350   /* Undo effects of cpp_quote_string.  */
1351   if (unescape)
1352     {
1353       char *s = filename;
1354       char *d = gfc_getmem (c - filename - unescape);
1355
1356       filename = d;
1357       while (*s)
1358         {
1359           if (*s == '\\')
1360             *d++ = *++s;
1361           else
1362             *d++ = *s;
1363           s++;
1364         }
1365       *d = '\0';
1366     }
1367
1368   /* Get flags.  */
1369
1370   flag[1] = flag[2] = flag[3] = flag[4] = false;
1371
1372   for (;;)
1373     {
1374       c = strchr (c, ' ');
1375       if (c == NULL)
1376         break;
1377
1378       c++;
1379       i = atoi (c);
1380
1381       if (1 <= i && i <= 4)
1382         flag[i] = true;
1383     }
1384
1385   /* Interpret flags.  */
1386
1387   if (flag[1]) /* Starting new file.  */
1388     {
1389       f = get_file (filename, LC_RENAME);
1390       add_file_change (f->filename, f->inclusion_line);
1391       current_file = f;
1392     }
1393
1394   if (flag[2]) /* Ending current file.  */
1395     {
1396       if (!current_file->up
1397           || strcmp (current_file->up->filename, filename) != 0)
1398         {
1399           gfc_warning_now ("%s:%d: file %s left but not entered",
1400                            current_file->filename, current_file->line,
1401                            filename);
1402           if (unescape)
1403             gfc_free (filename);
1404           return;
1405         }
1406
1407       add_file_change (NULL, line);
1408       current_file = current_file->up;
1409       linemap_add (line_table, LC_RENAME, false, current_file->filename,
1410                    current_file->line);
1411     }
1412
1413   /* The name of the file can be a temporary file produced by
1414      cpp. Replace the name if it is different.  */
1415
1416   if (strcmp (current_file->filename, filename) != 0)
1417     {
1418       gfc_free (current_file->filename);
1419       current_file->filename = gfc_getmem (strlen (filename) + 1);
1420       strcpy (current_file->filename, filename);
1421     }
1422
1423   /* Set new line number.  */
1424   current_file->line = line;
1425   if (unescape)
1426     gfc_free (filename);
1427   return;
1428
1429  bad_cpp_line:
1430   gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1431                    current_file->filename, current_file->line);
1432   current_file->line++;
1433 }
1434
1435
1436 static try load_file (const char *, bool);
1437
1438 /* include_line()-- Checks a line buffer to see if it is an include
1439    line.  If so, we call load_file() recursively to load the included
1440    file.  We never return a syntax error because a statement like
1441    "include = 5" is perfectly legal.  We return false if no include was
1442    processed or true if we matched an include.  */
1443
1444 static bool
1445 include_line (char *line)
1446 {
1447   char quote, *c, *begin, *stop;
1448
1449   c = line;
1450
1451   if (gfc_option.flag_openmp)
1452     {
1453       if (gfc_current_form == FORM_FREE)
1454         {
1455           while (*c == ' ' || *c == '\t')
1456             c++;
1457           if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1458             c += 3;
1459         }
1460       else
1461         {
1462           if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1463               && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1464             c += 3;
1465         }
1466     }
1467
1468   while (*c == ' ' || *c == '\t')
1469     c++;
1470
1471   if (strncasecmp (c, "include", 7))
1472       return false;
1473
1474   c += 7;
1475   while (*c == ' ' || *c == '\t')
1476     c++;
1477
1478   /* Find filename between quotes.  */
1479   
1480   quote = *c++;
1481   if (quote != '"' && quote != '\'')
1482     return false;
1483
1484   begin = c;
1485
1486   while (*c != quote && *c != '\0')
1487     c++;
1488
1489   if (*c == '\0')
1490     return false;
1491
1492   stop = c++;
1493   
1494   while (*c == ' ' || *c == '\t')
1495     c++;
1496
1497   if (*c != '\0' && *c != '!')
1498     return false;
1499
1500   /* We have an include line at this point.  */
1501
1502   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1503                    read by anything else.  */
1504
1505   load_file (begin, false);
1506   return true;
1507 }
1508
1509
1510 /* Load a file into memory by calling load_line until the file ends.  */
1511
1512 static try
1513 load_file (const char *filename, bool initial)
1514 {
1515   char *line;
1516   gfc_linebuf *b;
1517   gfc_file *f;
1518   FILE *input;
1519   int len, line_len;
1520   bool first_line;
1521
1522   for (f = current_file; f; f = f->up)
1523     if (strcmp (filename, f->filename) == 0)
1524       {
1525         gfc_error_now ("File '%s' is being included recursively", filename);
1526         return FAILURE;
1527       }
1528
1529   if (initial)
1530     {
1531       if (gfc_src_file)
1532         {
1533           input = gfc_src_file;
1534           gfc_src_file = NULL;
1535         }
1536       else
1537         input = gfc_open_file (filename);
1538       if (input == NULL)
1539         {
1540           gfc_error_now ("Can't open file '%s'", filename);
1541           return FAILURE;
1542         }
1543     }
1544   else
1545     {
1546       input = gfc_open_included_file (filename, false, false);
1547       if (input == NULL)
1548         {
1549           gfc_error_now ("Can't open included file '%s'", filename);
1550           return FAILURE;
1551         }
1552     }
1553
1554   /* Load the file.  */
1555
1556   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1557   if (!initial)
1558     add_file_change (f->filename, f->inclusion_line);
1559   current_file = f;
1560   current_file->line = 1;
1561   line = NULL;
1562   line_len = 0;
1563   first_line = true;
1564
1565   if (initial && gfc_src_preprocessor_lines[0])
1566     {
1567       preprocessor_line (gfc_src_preprocessor_lines[0]);
1568       gfc_free (gfc_src_preprocessor_lines[0]);
1569       gfc_src_preprocessor_lines[0] = NULL;
1570       if (gfc_src_preprocessor_lines[1])
1571         {
1572           preprocessor_line (gfc_src_preprocessor_lines[1]);
1573           gfc_free (gfc_src_preprocessor_lines[1]);
1574           gfc_src_preprocessor_lines[1] = NULL;
1575         }
1576     }
1577
1578   for (;;)
1579     {
1580       int trunc = load_line (input, &line, &line_len);
1581
1582       len = strlen (line);
1583       if (feof (input) && len == 0)
1584         break;
1585
1586       /* If this is the first line of the file, it can contain a byte
1587          order mark (BOM), which we will ignore:
1588            FF FE is UTF-16 little endian,
1589            FE FF is UTF-16 big endian,
1590            EF BB BF is UTF-8.  */
1591       if (first_line
1592           && ((line_len >= 2 && line[0] == '\xFF' && line[1] == '\xFE')
1593               || (line_len >= 2 && line[0] == '\xFE' && line[1] == '\xFF')
1594               || (line_len >= 3 && line[0] == '\xEF' && line[1] == '\xBB'
1595                   && line[2] == '\xBF')))
1596         {
1597           int n = line[1] == '\xBB' ? 3 : 2;
1598           char * new = gfc_getmem (line_len);
1599
1600           strcpy (new, line + n);
1601           gfc_free (line);
1602           line = new;
1603           len -= n;
1604         }
1605
1606       /* There are three things this line can be: a line of Fortran
1607          source, an include line or a C preprocessor directive.  */
1608
1609       if (line[0] == '#')
1610         {
1611           /* When -g3 is specified, it's possible that we emit #define
1612              and #undef lines, which we need to pass to the middle-end
1613              so that it can emit correct debug info.  */
1614           if (debug_info_level == DINFO_LEVEL_VERBOSE
1615               && (strncmp (line, "#define ", 8) == 0
1616                   || strncmp (line, "#undef ", 7) == 0))
1617             ;
1618           else
1619             {
1620               preprocessor_line (line);
1621               continue;
1622             }
1623         }
1624
1625       /* Preprocessed files have preprocessor lines added before the byte
1626          order mark, so first_line is not about the first line of the file
1627          but the first line that's not a preprocessor line.  */
1628       first_line = false;
1629
1630       if (include_line (line))
1631         {
1632           current_file->line++;
1633           continue;
1634         }
1635
1636       /* Add line.  */
1637
1638       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1639
1640       b->location
1641         = linemap_line_start (line_table, current_file->line++, 120);
1642       b->file = current_file;
1643       b->truncated = trunc;
1644       strcpy (b->line, line);
1645
1646       if (line_head == NULL)
1647         line_head = b;
1648       else
1649         line_tail->next = b;
1650
1651       line_tail = b;
1652
1653       while (file_changes_cur < file_changes_count)
1654         file_changes[file_changes_cur++].lb = b;
1655     }
1656
1657   /* Release the line buffer allocated in load_line.  */
1658   gfc_free (line);
1659
1660   fclose (input);
1661
1662   if (!initial)
1663     add_file_change (NULL, current_file->inclusion_line + 1);
1664   current_file = current_file->up;
1665   linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
1666   return SUCCESS;
1667 }
1668
1669
1670 /* Open a new file and start scanning from that file. Returns SUCCESS
1671    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1672    it tries to determine the source form from the filename, defaulting
1673    to free form.  */
1674
1675 try
1676 gfc_new_file (void)
1677 {
1678   try result;
1679
1680   result = load_file (gfc_source_file, true);
1681
1682   gfc_current_locus.lb = line_head;
1683   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1684
1685 #if 0 /* Debugging aid.  */
1686   for (; line_head; line_head = line_head->next)
1687     printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
1688             LOCATION_LINE (line_head->location), line_head->line);
1689
1690   exit (0);
1691 #endif
1692
1693   return result;
1694 }
1695
1696 static char *
1697 unescape_filename (const char *ptr)
1698 {
1699   const char *p = ptr, *s;
1700   char *d, *ret;
1701   int escaped, unescape = 0;
1702
1703   /* Make filename end at quote.  */
1704   escaped = false;
1705   while (*p && ! (! escaped && *p == '"'))
1706     {
1707       if (escaped)
1708         escaped = false;
1709       else if (*p == '\\')
1710         {
1711           escaped = true;
1712           unescape++;
1713         }
1714       ++p;
1715     }
1716
1717   if (!*p || p[1])
1718     return NULL;
1719
1720   /* Undo effects of cpp_quote_string.  */
1721   s = ptr;
1722   d = gfc_getmem (p + 1 - ptr - unescape);
1723   ret = d;
1724
1725   while (s != p)
1726     {
1727       if (*s == '\\')
1728         *d++ = *++s;
1729       else
1730         *d++ = *s;
1731       s++;
1732     }
1733   *d = '\0';
1734   return ret;
1735 }
1736
1737 /* For preprocessed files, if the first tokens are of the form # NUM.
1738    handle the directives so we know the original file name.  */
1739
1740 const char *
1741 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1742 {
1743   int c, len;
1744   char *dirname;
1745
1746   gfc_src_file = gfc_open_file (filename);
1747   if (gfc_src_file == NULL)
1748     return NULL;
1749
1750   c = getc (gfc_src_file);
1751   ungetc (c, gfc_src_file);
1752
1753   if (c != '#')
1754     return NULL;
1755
1756   len = 0;
1757   load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1758
1759   if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1760     return NULL;
1761
1762   filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
1763   if (filename == NULL)
1764     return NULL;
1765
1766   c = getc (gfc_src_file);
1767   ungetc (c, gfc_src_file);
1768
1769   if (c != '#')
1770     return filename;
1771
1772   len = 0;
1773   load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1774
1775   if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1776     return filename;
1777
1778   dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
1779   if (dirname == NULL)
1780     return filename;
1781
1782   len = strlen (dirname);
1783   if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1784     {
1785       gfc_free (dirname);
1786       return filename;
1787     }
1788   dirname[len - 2] = '\0';
1789   set_src_pwd (dirname);
1790
1791   if (! IS_ABSOLUTE_PATH (filename))
1792     {
1793       char *p = gfc_getmem (len + strlen (filename));
1794
1795       memcpy (p, dirname, len - 2);
1796       p[len - 2] = '/';
1797       strcpy (p + len - 1, filename);
1798       *canon_source_file = p;
1799     }
1800
1801   gfc_free (dirname);
1802   return filename;
1803 }