OSDN Git Service

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