OSDN Git Service

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