OSDN Git Service

69fa3a1e1865b6b212046ff37f762989e0351020
[pf3gnuchains/gcc-fork.git] / gcc / fortran / scanner.c
1 /* Character scanner.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005
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, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, 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
49 /* Structure for holding module and include file search path.  */
50 typedef struct gfc_directorylist
51 {
52   char *path;
53   struct gfc_directorylist *next;
54 }
55 gfc_directorylist;
56
57 /* List of include file search directories.  */
58 static gfc_directorylist *include_dirs;
59
60 static gfc_file *file_head, *current_file;
61
62 static int continue_flag, end_flag;
63
64 gfc_source_form gfc_current_form;
65 static gfc_linebuf *line_head, *line_tail;
66        
67 locus gfc_current_locus;
68 char *gfc_source_file;
69       
70
71 /* Main scanner initialization.  */
72
73 void
74 gfc_scanner_init_1 (void)
75 {
76   file_head = NULL;
77   line_head = NULL;
78   line_tail = NULL;
79
80   end_flag = 0;
81 }
82
83
84 /* Main scanner destructor.  */
85
86 void
87 gfc_scanner_done_1 (void)
88 {
89   gfc_linebuf *lb;
90   gfc_file *f;
91
92   while(line_head != NULL) 
93     {
94       lb = line_head->next;
95       gfc_free(line_head);
96       line_head = lb;
97     }
98      
99   while(file_head != NULL) 
100     {
101       f = file_head->next;
102       gfc_free(file_head->filename);
103       gfc_free(file_head);
104       file_head = f;    
105     }
106
107 }
108
109
110 /* Adds path to the list pointed to by list.  */
111
112 void
113 gfc_add_include_path (const char *path)
114 {
115   gfc_directorylist *dir;
116   const char *p;
117
118   p = path;
119   while (*p == ' ' || *p == '\t')  /* someone might do 'gfortran "-I include"' */
120     if (*p++ == '\0')
121       return;
122
123   dir = include_dirs;
124   if (!dir)
125     {
126       dir = include_dirs = gfc_getmem (sizeof (gfc_directorylist));
127     }
128   else
129     {
130       while (dir->next)
131         dir = dir->next;
132
133       dir->next = gfc_getmem (sizeof (gfc_directorylist));
134       dir = dir->next;
135     }
136
137   dir->next = NULL;
138   dir->path = gfc_getmem (strlen (p) + 2);
139   strcpy (dir->path, p);
140   strcat (dir->path, "/");      /* make '/' last character */
141 }
142
143
144 /* Release resources allocated for options.  */
145
146 void
147 gfc_release_include_path (void)
148 {
149   gfc_directorylist *p;
150
151   gfc_free (gfc_option.module_dir);
152   while (include_dirs != NULL)
153     {
154       p = include_dirs;
155       include_dirs = include_dirs->next;
156       gfc_free (p->path);
157       gfc_free (p);
158     }
159 }
160
161 /* Opens file for reading, searching through the include directories
162    given if necessary.  */
163
164 FILE *
165 gfc_open_included_file (const char *name)
166 {
167   char fullname[PATH_MAX];
168   gfc_directorylist *p;
169   FILE *f;
170
171   f = gfc_open_file (name);
172   if (f != NULL)
173     return f;
174
175   for (p = include_dirs; p; p = p->next)
176     {
177       if (strlen (p->path) + strlen (name) + 1 > PATH_MAX)
178         continue;
179
180       strcpy (fullname, p->path);
181       strcat (fullname, name);
182
183       f = gfc_open_file (fullname);
184       if (f != NULL)
185         return f;
186     }
187
188   return NULL;
189 }
190
191 /* Test to see if we're at the end of the main source file.  */
192
193 int
194 gfc_at_end (void)
195 {
196
197   return end_flag;
198 }
199
200
201 /* Test to see if we're at the end of the current file.  */
202
203 int
204 gfc_at_eof (void)
205 {
206
207   if (gfc_at_end ())
208     return 1;
209
210   if (line_head == NULL)
211     return 1;                   /* Null file */
212
213   if (gfc_current_locus.lb == NULL)
214     return 1;
215
216   return 0;
217 }
218
219
220 /* Test to see if we're at the beginning of a new line.  */
221
222 int
223 gfc_at_bol (void)
224 {
225   if (gfc_at_eof ())
226     return 1;
227
228   return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
229 }
230
231
232 /* Test to see if we're at the end of a line.  */
233
234 int
235 gfc_at_eol (void)
236 {
237
238   if (gfc_at_eof ())
239     return 1;
240
241   return (*gfc_current_locus.nextc == '\0');
242 }
243
244
245 /* Advance the current line pointer to the next line.  */
246
247 void
248 gfc_advance_line (void)
249 {
250   if (gfc_at_end ())
251     return;
252
253   if (gfc_current_locus.lb == NULL) 
254     {
255       end_flag = 1;
256       return;
257     } 
258
259   gfc_current_locus.lb = gfc_current_locus.lb->next;
260
261   if (gfc_current_locus.lb != NULL)         
262     gfc_current_locus.nextc = gfc_current_locus.lb->line;
263   else 
264     {
265       gfc_current_locus.nextc = NULL;
266       end_flag = 1;
267     }       
268 }
269
270
271 /* Get the next character from the input, advancing gfc_current_file's
272    locus.  When we hit the end of the line or the end of the file, we
273    start returning a '\n' in order to complete the current statement.
274    No Fortran line conventions are implemented here.
275
276    Requiring explicit advances to the next line prevents the parse
277    pointer from being on the wrong line if the current statement ends
278    prematurely.  */
279
280 static int
281 next_char (void)
282 {
283   int c;
284   
285   if (gfc_current_locus.nextc == NULL)
286     return '\n';
287
288   c = *gfc_current_locus.nextc++;
289   if (c == '\0')
290     {
291       gfc_current_locus.nextc--; /* Remain on this line.  */
292       c = '\n';
293     }
294
295   return c;
296 }
297
298 /* Skip a comment.  When we come here the parse pointer is positioned
299    immediately after the comment character.  If we ever implement
300    compiler directives withing comments, here is where we parse the
301    directive.  */
302
303 static void
304 skip_comment_line (void)
305 {
306   char c;
307
308   do
309     {
310       c = next_char ();
311     }
312   while (c != '\n');
313
314   gfc_advance_line ();
315 }
316
317
318 /* Comment lines are null lines, lines containing only blanks or lines
319    on which the first nonblank line is a '!'.  */
320
321 static void
322 skip_free_comments (void)
323 {
324   locus start;
325   char c;
326
327   for (;;)
328     {
329       start = gfc_current_locus;
330       if (gfc_at_eof ())
331         break;
332
333       do
334         {
335           c = next_char ();
336         }
337       while (gfc_is_whitespace (c));
338
339       if (c == '\n')
340         {
341           gfc_advance_line ();
342           continue;
343         }
344
345       if (c == '!')
346         {
347           skip_comment_line ();
348           continue;
349         }
350
351       break;
352     }
353
354   gfc_current_locus = start;
355 }
356
357
358 /* Skip comment lines in fixed source mode.  We have the same rules as
359    in skip_free_comment(), except that we can have a 'c', 'C' or '*'
360    in column 1, and a '!' cannot be in column 6.  */
361
362 static void
363 skip_fixed_comments (void)
364 {
365   locus start;
366   int col;
367   char c;
368
369   for (;;)
370     {
371       start = gfc_current_locus;
372       if (gfc_at_eof ())
373         break;
374
375       c = next_char ();
376       if (c == '\n')
377         {
378           gfc_advance_line ();
379           continue;
380         }
381
382       if (c == '!' || c == 'c' || c == 'C' || c == '*')
383         {
384           skip_comment_line ();
385           continue;
386         }
387
388       col = 1;
389       do
390         {
391           c = next_char ();
392           col++;
393         }
394       while (gfc_is_whitespace (c));
395
396       if (c == '\n')
397         {
398           gfc_advance_line ();
399           continue;
400         }
401
402       if (col != 6 && c == '!')
403         {
404           skip_comment_line ();
405           continue;
406         }
407
408       break;
409     }
410
411   gfc_current_locus = start;
412 }
413
414
415 /* Skips the current line if it is a comment.  Assumes that we are at
416    the start of the current line.  */
417
418 void
419 gfc_skip_comments (void)
420 {
421
422   if (!gfc_at_bol () || gfc_current_form == FORM_FREE)
423     skip_free_comments ();
424   else
425     skip_fixed_comments ();
426 }
427
428
429 /* Get the next character from the input, taking continuation lines
430    and end-of-line comments into account.  This implies that comment
431    lines between continued lines must be eaten here.  For higher-level
432    subroutines, this flattens continued lines into a single logical
433    line.  The in_string flag denotes whether we're inside a character
434    context or not.  */
435
436 int
437 gfc_next_char_literal (int in_string)
438 {
439   locus old_loc;
440   int i, c;
441
442   continue_flag = 0;
443
444 restart:
445   c = next_char ();
446   if (gfc_at_end ())
447     return c;
448
449   if (gfc_current_form == FORM_FREE)
450     {
451
452       if (!in_string && c == '!')
453         {
454           /* This line can't be continued */
455           do
456             {
457               c = next_char ();
458             }
459           while (c != '\n');
460
461           /* Avoid truncation warnings for comment ending lines.  */
462           gfc_current_locus.lb->truncated = 0;
463
464           goto done;
465         }
466
467       if (c != '&')
468         goto done;
469
470       /* If the next nonblank character is a ! or \n, we've got a
471          continuation line.  */
472       old_loc = gfc_current_locus;
473
474       c = next_char ();
475       while (gfc_is_whitespace (c))
476         c = next_char ();
477
478       /* Character constants to be continued cannot have commentary
479          after the '&'.  */
480
481       if (in_string && c != '\n')
482         {
483           gfc_current_locus = old_loc;
484           c = '&';
485           goto done;
486         }
487
488       if (c != '!' && c != '\n')
489         {
490           gfc_current_locus = old_loc;
491           c = '&';
492           goto done;
493         }
494
495       continue_flag = 1;
496       if (c == '!')
497         skip_comment_line ();
498       else
499         gfc_advance_line ();
500
501       /* We've got a continuation line and need to find where it continues.
502          First eat any comment lines.  */
503       gfc_skip_comments ();
504
505       /* Now that we have a non-comment line, probe ahead for the
506          first non-whitespace character.  If it is another '&', then
507          reading starts at the next character, otherwise we must back
508          up to where the whitespace started and resume from there.  */
509
510       old_loc = gfc_current_locus;
511
512       c = next_char ();
513       while (gfc_is_whitespace (c))
514         c = next_char ();
515
516       if (c != '&')
517         gfc_current_locus = old_loc;
518
519     }
520   else
521     {
522       /* Fixed form continuation.  */
523       if (!in_string && c == '!')
524         {
525           /* Skip comment at end of line.  */
526           do
527             {
528               c = next_char ();
529             }
530           while (c != '\n');
531
532           /* Avoid truncation warnings for comment ending lines.  */
533           gfc_current_locus.lb->truncated = 0;
534         }
535
536       if (c != '\n')
537         goto done;
538
539       continue_flag = 1;
540       old_loc = gfc_current_locus;
541
542       gfc_advance_line ();
543       gfc_skip_comments ();
544
545       /* See if this line is a continuation line.  */
546       for (i = 0; i < 5; i++)
547         {
548           c = next_char ();
549           if (c != ' ')
550             goto not_continuation;
551         }
552
553       c = next_char ();
554       if (c == '0' || c == ' ')
555         goto not_continuation;
556     }
557
558   /* Ready to read first character of continuation line, which might
559      be another continuation line!  */
560   goto restart;
561
562 not_continuation:
563   c = '\n';
564   gfc_current_locus = old_loc;
565
566 done:
567   continue_flag = 0;
568   return c;
569 }
570
571
572 /* Get the next character of input, folded to lowercase.  In fixed
573    form mode, we also ignore spaces.  When matcher subroutines are
574    parsing character literals, they have to call
575    gfc_next_char_literal().  */
576
577 int
578 gfc_next_char (void)
579 {
580   int c;
581
582   do
583     {
584       c = gfc_next_char_literal (0);
585     }
586   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
587
588   return TOLOWER (c);
589 }
590
591
592 int
593 gfc_peek_char (void)
594 {
595   locus old_loc;
596   int c;
597
598   old_loc = gfc_current_locus;
599   c = gfc_next_char ();
600   gfc_current_locus = old_loc;
601
602   return c;
603 }
604
605
606 /* Recover from an error.  We try to get past the current statement
607    and get lined up for the next.  The next statement follows a '\n'
608    or a ';'.  We also assume that we are not within a character
609    constant, and deal with finding a '\'' or '"'.  */
610
611 void
612 gfc_error_recovery (void)
613 {
614   char c, delim;
615
616   if (gfc_at_eof ())
617     return;
618
619   for (;;)
620     {
621       c = gfc_next_char ();
622       if (c == '\n' || c == ';')
623         break;
624
625       if (c != '\'' && c != '"')
626         {
627           if (gfc_at_eof ())
628             break;
629           continue;
630         }
631       delim = c;
632
633       for (;;)
634         {
635           c = next_char ();
636
637           if (c == delim)
638             break;
639           if (c == '\n')
640             return;
641           if (c == '\\')
642             {
643               c = next_char ();
644               if (c == '\n')
645                 return;
646             }
647         }
648       if (gfc_at_eof ())
649         break;
650     }
651 }
652
653
654 /* Read ahead until the next character to be read is not whitespace.  */
655
656 void
657 gfc_gobble_whitespace (void)
658 {
659   locus old_loc;
660   int c;
661
662   do
663     {
664       old_loc = gfc_current_locus;
665       c = gfc_next_char_literal (0);
666     }
667   while (gfc_is_whitespace (c));
668
669   gfc_current_locus = old_loc;
670 }
671
672
673 /* Load a single line into pbuf.
674
675    If pbuf points to a NULL pointer, it is allocated.
676    We truncate lines that are too long, unless we're dealing with
677    preprocessor lines or if the option -ffixed-line-length-none is set,
678    in which case we reallocate the buffer to fit the entire line, if
679    need be.
680    In fixed mode, we expand a tab that occurs within the statement
681    label region to expand to spaces that leave the next character in
682    the source region.
683    load_line returns wether the line was truncated.  */
684
685 static int
686 load_line (FILE * input, char **pbuf)
687 {
688   int c, maxlen, i, preprocessor_flag;
689   int trunc_flag = 0;
690   static int buflen = 0;
691   char *buffer;
692
693   /* Determine the maximum allowed line length.  */
694   if (gfc_current_form == FORM_FREE)
695     maxlen = GFC_MAX_LINE;
696   else
697     maxlen = gfc_option.fixed_line_length;
698
699   if (*pbuf == NULL)
700     {
701       /* Allocate the line buffer, storing its length into buflen.  */
702       if (maxlen > 0)
703         buflen = maxlen;
704       else
705         buflen = GFC_MAX_LINE;
706
707       *pbuf = gfc_getmem (buflen + 1);
708     }
709
710   i = 0;
711   buffer = *pbuf;
712
713   preprocessor_flag = 0;
714   c = fgetc (input);
715   if (c == '#')
716     /* In order to not truncate preprocessor lines, we have to
717        remember that this is one.  */
718     preprocessor_flag = 1;
719   ungetc (c, input);
720
721   for (;;)
722     {
723       c = fgetc (input);
724
725       if (c == EOF)
726         break;
727       if (c == '\n')
728         break;
729
730       if (c == '\r')
731         continue;               /* Gobble characters.  */
732       if (c == '\0')
733         continue;
734
735       if (c == '\032')
736         {
737           /* Ctrl-Z ends the file.  */
738           while (fgetc (input) != EOF);
739           break;
740         }
741
742       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
743         {                       /* Tab expansion.  */
744           while (i <= 6)
745             {
746               *buffer++ = ' ';
747               i++;
748             }
749
750           continue;
751         }
752
753       *buffer++ = c;
754       i++;
755
756       if (i >= buflen && (maxlen == 0 || preprocessor_flag))
757         {
758           /* Reallocate line buffer to double size to hold the
759              overlong line.  */
760           buflen = buflen * 2;
761           *pbuf = xrealloc (*pbuf, buflen);
762           buffer = (*pbuf)+i;
763         }
764       else if (i >= buflen)
765         {                       
766           /* Truncate the rest of the line.  */
767           for (;;)
768             {
769               c = fgetc (input);
770               if (c == '\n' || c == EOF)
771                 break;
772
773               trunc_flag = 1;
774             }
775
776           ungetc ('\n', input);
777         }
778     }
779
780   /* Pad lines to the selected line length in fixed form.  */
781   if (gfc_current_form == FORM_FIXED
782       && gfc_option.fixed_line_length > 0
783       && !preprocessor_flag
784       && c != EOF)
785     while (i++ < buflen)
786       *buffer++ = ' ';
787
788   *buffer = '\0';
789
790   return trunc_flag;
791 }
792
793
794 /* Get a gfc_file structure, initialize it and add it to
795    the file stack.  */
796
797 static gfc_file *
798 get_file (char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
799 {
800   gfc_file *f;
801
802   f = gfc_getmem (sizeof (gfc_file));
803
804   f->filename = gfc_getmem (strlen (name) + 1);
805   strcpy (f->filename, name);
806
807   f->next = file_head;
808   file_head = f;
809
810   f->included_by = current_file;
811   if (current_file != NULL)
812     f->inclusion_line = current_file->line;
813
814 #ifdef USE_MAPPED_LOCATION
815   linemap_add (&line_table, reason, false, f->filename, 1);
816 #endif
817
818   return f;
819 }
820
821 /* Deal with a line from the C preprocessor. The
822    initial octothorp has already been seen.  */
823
824 static void
825 preprocessor_line (char *c)
826 {
827   bool flag[5];
828   int i, line;
829   char *filename;
830   gfc_file *f;
831   int escaped;
832
833   c++;
834   while (*c == ' ' || *c == '\t')
835     c++;
836
837   if (*c < '0' || *c > '9')
838     goto bad_cpp_line;
839
840   line = atoi (c);
841
842   /* Set new line number.  */
843   current_file->line = line;
844
845   c = strchr (c, ' '); 
846   if (c == NULL)
847     /* No file name given.  */
848     return;
849
850
851
852   /* Skip spaces.  */
853   while (*c == ' ' || *c == '\t')
854     c++;
855
856   /* Skip quote.  */
857   if (*c != '"')
858     goto bad_cpp_line;
859   ++c;
860
861   filename = c;
862
863   /* Make filename end at quote.  */
864   escaped = false;
865   while (*c && ! (! escaped && *c == '"'))
866     {
867       if (escaped)
868         escaped = false;
869       else
870         escaped = *c == '\\';
871       ++c;
872     }
873
874   if (! *c)
875     /* Preprocessor line has no closing quote.  */
876     goto bad_cpp_line;
877
878   *c++ = '\0';
879
880
881
882   /* Get flags.  */
883   
884   flag[1] = flag[2] = flag[3] = flag[4] = flag[5] = false;
885
886   for (;;)
887     {
888       c = strchr (c, ' ');
889       if (c == NULL)
890         break;
891
892       c++;
893       i = atoi (c);
894
895       if (1 <= i && i <= 4)
896         flag[i] = true;
897     }
898      
899   /* Interpret flags.  */
900   
901   if (flag[1] || flag[3]) /* Starting new file.  */
902     {
903       f = get_file (filename, LC_RENAME);
904       f->up = current_file;
905       current_file = f;
906     }
907   
908   if (flag[2]) /* Ending current file.  */
909     {
910       current_file = current_file->up;
911     }
912   
913   /* The name of the file can be a temporary file produced by
914      cpp. Replace the name if it is different.  */
915   
916   if (strcmp (current_file->filename, filename) != 0)
917     {
918       gfc_free (current_file->filename);
919       current_file->filename = gfc_getmem (strlen (filename) + 1);
920       strcpy (current_file->filename, filename);
921     }
922
923   return;
924
925  bad_cpp_line:
926   gfc_warning_now ("%s:%d: Illegal preprocessor directive", 
927                    current_file->filename, current_file->line);
928   current_file->line++;
929 }
930
931
932 static try load_file (char *, bool);
933
934 /* include_line()-- Checks a line buffer to see if it is an include
935    line.  If so, we call load_file() recursively to load the included
936    file.  We never return a syntax error because a statement like
937    "include = 5" is perfectly legal.  We return false if no include was
938    processed or true if we matched an include.  */
939
940 static bool
941 include_line (char *line)
942 {
943   char quote, *c, *begin, *stop;
944   
945   c = line;
946   while (*c == ' ' || *c == '\t')
947     c++;
948
949   if (strncasecmp (c, "include", 7))
950       return false;
951
952   c += 7;
953   while (*c == ' ' || *c == '\t')
954     c++;
955
956   /* Find filename between quotes.  */
957   
958   quote = *c++;
959   if (quote != '"' && quote != '\'')
960     return false;
961
962   begin = c;
963
964   while (*c != quote && *c != '\0')
965     c++;
966
967   if (*c == '\0')
968     return false;
969
970   stop = c++;
971   
972   while (*c == ' ' || *c == '\t')
973     c++;
974
975   if (*c != '\0' && *c != '!')
976     return false;
977
978   /* We have an include line at this point.  */
979
980   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
981                    read by anything else.  */
982
983   load_file (begin, false);
984   return true;
985 }
986
987 /* Load a file into memory by calling load_line until the file ends.  */
988
989 static try
990 load_file (char *filename, bool initial)
991 {
992   char *line;
993   gfc_linebuf *b;
994   gfc_file *f;
995   FILE *input;
996   int len;
997
998   for (f = current_file; f; f = f->up)
999     if (strcmp (filename, f->filename) == 0)
1000       {
1001         gfc_error_now ("File '%s' is being included recursively", filename);
1002         return FAILURE;
1003       }
1004
1005   if (initial)
1006     {
1007       input = gfc_open_file (filename);
1008       if (input == NULL)
1009         {
1010           gfc_error_now ("Can't open file '%s'", filename);
1011           return FAILURE;
1012         }
1013     }
1014   else
1015     {
1016       input = gfc_open_included_file (filename);
1017       if (input == NULL)
1018         {
1019           gfc_error_now ("Can't open included file '%s'", filename);
1020           return FAILURE;
1021         }
1022     }
1023
1024   /* Load the file.  */
1025
1026   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1027   f->up = current_file;
1028   current_file = f;
1029   current_file->line = 1;
1030   line = NULL;
1031
1032   for (;;) 
1033     {
1034       int trunc = load_line (input, &line);
1035
1036       len = strlen (line);
1037       if (feof (input) && len == 0)
1038         break;
1039
1040       /* There are three things this line can be: a line of Fortran
1041          source, an include line or a C preprocessor directive.  */
1042
1043       if (line[0] == '#')
1044         {
1045           preprocessor_line (line);
1046           continue;
1047         }
1048
1049       if (include_line (line))
1050         {
1051           current_file->line++;
1052           continue;
1053         }
1054
1055       /* Add line.  */
1056
1057       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1058
1059 #ifdef USE_MAPPED_LOCATION
1060       b->location
1061         = linemap_line_start (&line_table, current_file->line++, 120);
1062 #else
1063       b->linenum = current_file->line++;
1064 #endif
1065       b->file = current_file;
1066       b->truncated = trunc;
1067       strcpy (b->line, line);
1068
1069       if (line_head == NULL)
1070         line_head = b;
1071       else
1072         line_tail->next = b;
1073
1074       line_tail = b;
1075     }
1076
1077   /* Release the line buffer allocated in load_line.  */
1078   gfc_free (line);
1079
1080   fclose (input);
1081
1082   current_file = current_file->up;
1083 #ifdef USE_MAPPED_LOCATION
1084   linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1085 #endif
1086   return SUCCESS;
1087 }
1088
1089
1090 /* Determine the source form from the filename extension.  We assume
1091    case insensitivity.  */
1092
1093 static gfc_source_form
1094 form_from_filename (const char *filename)
1095 {
1096
1097   static const struct
1098   {
1099     const char *extension;
1100     gfc_source_form form;
1101   }
1102   exttype[] =
1103   {
1104     {
1105     ".f90", FORM_FREE}
1106     ,
1107     {
1108     ".f95", FORM_FREE}
1109     ,
1110     {
1111     ".f", FORM_FIXED}
1112     ,
1113     {
1114     ".for", FORM_FIXED}
1115     ,
1116     {
1117     "", FORM_UNKNOWN}
1118   };            /* sentinel value */
1119
1120   gfc_source_form f_form;
1121   const char *fileext;
1122   int i;
1123
1124   /* Find end of file name.  */
1125   i = 0;
1126   while ((i < PATH_MAX) && (filename[i] != '\0'))
1127     i++;
1128
1129   /* Improperly terminated or too-long filename.  */
1130   if (i == PATH_MAX)
1131     return FORM_UNKNOWN;
1132
1133   /* Find last period.  */
1134   while (i >= 0 && (filename[i] != '.'))
1135     i--;
1136
1137   /* Did we see a file extension?  */
1138   if (i < 0)
1139     return FORM_UNKNOWN; /* Nope  */
1140
1141   /* Get file extension and compare it to others.  */
1142   fileext = &(filename[i]);
1143
1144   i = -1;
1145   f_form = FORM_UNKNOWN;
1146   do
1147     {
1148       i++;
1149       if (strcasecmp (fileext, exttype[i].extension) == 0)
1150         {
1151           f_form = exttype[i].form;
1152           break;
1153         }
1154     }
1155   while (exttype[i].form != FORM_UNKNOWN);
1156
1157   return f_form;
1158 }
1159
1160
1161 /* Open a new file and start scanning from that file. Returns SUCCESS
1162    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1163    it tries to determine the source form from the filename, defaulting
1164    to free form.  */
1165
1166 try
1167 gfc_new_file (const char *filename, gfc_source_form form)
1168 {
1169   try result;
1170
1171   if (filename != NULL)
1172     {
1173       gfc_source_file = gfc_getmem (strlen (filename) + 1);
1174       strcpy (gfc_source_file, filename);
1175     }
1176   else
1177     gfc_source_file = NULL;
1178
1179   /* Decide which form the file will be read in as.  */
1180
1181   if (form != FORM_UNKNOWN)
1182     gfc_current_form = form;
1183   else
1184     {
1185       gfc_current_form = form_from_filename (filename);
1186
1187       if (gfc_current_form == FORM_UNKNOWN)
1188         {
1189           gfc_current_form = FORM_FREE;
1190           gfc_warning_now ("Reading file '%s' as free form.", 
1191                            (filename[0] == '\0') ? "<stdin>" : filename); 
1192         }
1193     }
1194
1195   result = load_file (gfc_source_file, true);
1196
1197   gfc_current_locus.lb = line_head;
1198   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1199
1200 #if 0 /* Debugging aid.  */
1201   for (; line_head; line_head = line_head->next)
1202     gfc_status ("%s:%3d %s\n", line_head->file->filename, 
1203 #ifdef USE_MAPPED_LOCATION
1204                 LOCATION_LINE (line_head->location),
1205 #else
1206                 line_head->linenum,
1207 #endif
1208                 line_head->line);
1209
1210   exit (0);
1211 #endif
1212
1213   return result;
1214 }