OSDN Git Service

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