OSDN Git Service

PR c/18946
[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           goto done;
462         }
463
464       if (c != '&')
465         goto done;
466
467       /* If the next nonblank character is a ! or \n, we've got a
468          continuation line.  */
469       old_loc = gfc_current_locus;
470
471       c = next_char ();
472       while (gfc_is_whitespace (c))
473         c = next_char ();
474
475       /* Character constants to be continued cannot have commentary
476          after the '&'.  */
477
478       if (in_string && c != '\n')
479         {
480           gfc_current_locus = old_loc;
481           c = '&';
482           goto done;
483         }
484
485       if (c != '!' && c != '\n')
486         {
487           gfc_current_locus = old_loc;
488           c = '&';
489           goto done;
490         }
491
492       continue_flag = 1;
493       if (c == '!')
494         skip_comment_line ();
495       else
496         gfc_advance_line ();
497
498       /* We've got a continuation line and need to find where it continues.
499          First eat any comment lines.  */
500       gfc_skip_comments ();
501
502       /* Now that we have a non-comment line, probe ahead for the
503          first non-whitespace character.  If it is another '&', then
504          reading starts at the next character, otherwise we must back
505          up to where the whitespace started and resume from there.  */
506
507       old_loc = gfc_current_locus;
508
509       c = next_char ();
510       while (gfc_is_whitespace (c))
511         c = next_char ();
512
513       if (c != '&')
514         gfc_current_locus = old_loc;
515
516     }
517   else
518     {
519       /* Fixed form continuation.  */
520       if (!in_string && c == '!')
521         {
522           /* Skip comment at end of line.  */
523           do
524             {
525               c = next_char ();
526             }
527           while (c != '\n');
528         }
529
530       if (c != '\n')
531         goto done;
532
533       continue_flag = 1;
534       old_loc = gfc_current_locus;
535
536       gfc_advance_line ();
537       gfc_skip_comments ();
538
539       /* See if this line is a continuation line.  */
540       for (i = 0; i < 5; i++)
541         {
542           c = next_char ();
543           if (c != ' ')
544             goto not_continuation;
545         }
546
547       c = next_char ();
548       if (c == '0' || c == ' ')
549         goto not_continuation;
550     }
551
552   /* Ready to read first character of continuation line, which might
553      be another continuation line!  */
554   goto restart;
555
556 not_continuation:
557   c = '\n';
558   gfc_current_locus = old_loc;
559
560 done:
561   continue_flag = 0;
562   return c;
563 }
564
565
566 /* Get the next character of input, folded to lowercase.  In fixed
567    form mode, we also ignore spaces.  When matcher subroutines are
568    parsing character literals, they have to call
569    gfc_next_char_literal().  */
570
571 int
572 gfc_next_char (void)
573 {
574   int c;
575
576   do
577     {
578       c = gfc_next_char_literal (0);
579     }
580   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
581
582   return TOLOWER (c);
583 }
584
585
586 int
587 gfc_peek_char (void)
588 {
589   locus old_loc;
590   int c;
591
592   old_loc = gfc_current_locus;
593   c = gfc_next_char ();
594   gfc_current_locus = old_loc;
595
596   return c;
597 }
598
599
600 /* Recover from an error.  We try to get past the current statement
601    and get lined up for the next.  The next statement follows a '\n'
602    or a ';'.  We also assume that we are not within a character
603    constant, and deal with finding a '\'' or '"'.  */
604
605 void
606 gfc_error_recovery (void)
607 {
608   char c, delim;
609
610   if (gfc_at_eof ())
611     return;
612
613   for (;;)
614     {
615       c = gfc_next_char ();
616       if (c == '\n' || c == ';')
617         break;
618
619       if (c != '\'' && c != '"')
620         {
621           if (gfc_at_eof ())
622             break;
623           continue;
624         }
625       delim = c;
626
627       for (;;)
628         {
629           c = next_char ();
630
631           if (c == delim)
632             break;
633           if (c == '\n')
634             goto done;
635           if (c == '\\')
636             {
637               c = next_char ();
638               if (c == '\n')
639                 goto done;
640             }
641         }
642       if (gfc_at_eof ())
643         break;
644     }
645
646 done:
647   if (c == '\n')
648     gfc_advance_line ();
649 }
650
651
652 /* Read ahead until the next character to be read is not whitespace.  */
653
654 void
655 gfc_gobble_whitespace (void)
656 {
657   locus old_loc;
658   int c;
659
660   do
661     {
662       old_loc = gfc_current_locus;
663       c = gfc_next_char_literal (0);
664     }
665   while (gfc_is_whitespace (c));
666
667   gfc_current_locus = old_loc;
668 }
669
670
671 /* Load a single line into pbuf.
672
673    If pbuf points to a NULL pointer, it is allocated.
674    We truncate lines that are too long, unless we're dealing with
675    preprocessor lines or if the option -ffixed-line-length-none is set,
676    in which case we reallocate the buffer to fit the entire line, if
677    need be.
678    In fixed mode, we expand a tab that occurs within the statement
679    label region to expand to spaces that leave the next character in
680    the source region.  */
681
682 static void
683 load_line (FILE * input, char **pbuf, char *filename, int linenum)
684 {
685   int c, maxlen, i, trunc_flag, preprocessor_flag;
686   static int buflen = 0;
687   char *buffer;
688
689   /* Determine the maximum allowed line length.  */
690   if (gfc_current_form == FORM_FREE)
691     maxlen = GFC_MAX_LINE;
692   else
693     maxlen = gfc_option.fixed_line_length;
694
695   if (*pbuf == NULL)
696     {
697       /* Allocate the line buffer, storing its length into buflen.  */
698       if (maxlen > 0)
699         buflen = maxlen;
700       else
701         buflen = GFC_MAX_LINE;
702
703       *pbuf = gfc_getmem (buflen + 1);
704     }
705
706   i = 0;
707   buffer = *pbuf;
708
709   preprocessor_flag = 0;
710   c = fgetc (input);
711   if (c == '#')
712     /* In order to not truncate preprocessor lines, we have to
713        remember that this is one.  */
714     preprocessor_flag = 1;
715   ungetc (c, input);
716
717   for (;;)
718     {
719       c = fgetc (input);
720
721       if (c == EOF)
722         break;
723       if (c == '\n')
724         break;
725
726       if (c == '\r')
727         continue;               /* Gobble characters.  */
728       if (c == '\0')
729         continue;
730
731       if (c == '\032')
732         {
733           /* Ctrl-Z ends the file.  */
734           while (fgetc (input) != EOF);
735           break;
736         }
737
738       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
739         {                       /* Tab expansion.  */
740           while (i <= 6)
741             {
742               *buffer++ = ' ';
743               i++;
744             }
745
746           continue;
747         }
748
749       *buffer++ = c;
750       i++;
751
752       if (i >= buflen && (maxlen == 0 || preprocessor_flag))
753         {
754           /* Reallocate line buffer to double size to hold the
755              overlong line.  */
756           buflen = buflen * 2;
757           *pbuf = xrealloc (*pbuf, buflen);
758           buffer = (*pbuf)+i;
759         }
760       else if (i >= buflen)
761         {                       
762           /* Truncate the rest of the line.  */
763           trunc_flag = 1;
764
765           for (;;)
766             {
767               c = fgetc (input);
768               if (c == '\n' || c == EOF)
769                 break;
770
771               if (gfc_option.warn_line_truncation
772                   && trunc_flag
773                   && !gfc_is_whitespace (c))
774                 {
775                   gfc_warning_now ("%s:%d: Line is being truncated",
776                                    filename, linenum);
777                   trunc_flag = 0;
778                 }
779             }
780
781           ungetc ('\n', input);
782         }
783     }
784
785   /* Pad lines to the selected line length in fixed form.  */
786   if (gfc_current_form == FORM_FIXED
787       && gfc_option.fixed_line_length > 0
788       && !preprocessor_flag
789       && c != EOF)
790     while (i++ < buflen)
791       *buffer++ = ' ';
792
793   *buffer = '\0';
794 }
795
796
797 /* Get a gfc_file structure, initialize it and add it to
798    the file stack.  */
799
800 static gfc_file *
801 get_file (char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
802 {
803   gfc_file *f;
804
805   f = gfc_getmem (sizeof (gfc_file));
806
807   f->filename = gfc_getmem (strlen (name) + 1);
808   strcpy (f->filename, name);
809
810   f->next = file_head;
811   file_head = f;
812
813   f->included_by = current_file;
814   if (current_file != NULL)
815     f->inclusion_line = current_file->line;
816
817 #ifdef USE_MAPPED_LOCATION
818   linemap_add (&line_table, reason, false, f->filename, 1);
819 #endif
820
821   return f;
822 }
823
824 /* Deal with a line from the C preprocessor. The
825    initial octothorp has already been seen.  */
826
827 static void
828 preprocessor_line (char *c)
829 {
830   bool flag[5];
831   int i, line;
832   char *filename;
833   gfc_file *f;
834   int escaped;
835
836   c++;
837   while (*c == ' ' || *c == '\t')
838     c++;
839
840   if (*c < '0' || *c > '9')
841     goto bad_cpp_line;
842
843   line = atoi (c);
844
845   /* Set new line number.  */
846   current_file->line = line;
847
848   c = strchr (c, ' '); 
849   if (c == NULL)
850     /* No file name given.  */
851     return;
852
853
854
855   /* Skip spaces.  */
856   while (*c == ' ' || *c == '\t')
857     c++;
858
859   /* Skip quote.  */
860   if (*c != '"')
861     goto bad_cpp_line;
862   ++c;
863
864   filename = c;
865
866   /* Make filename end at quote.  */
867   escaped = false;
868   while (*c && ! (! escaped && *c == '"'))
869     {
870       if (escaped)
871         escaped = false;
872       else
873         escaped = *c == '\\';
874       ++c;
875     }
876
877   if (! *c)
878     /* Preprocessor line has no closing quote.  */
879     goto bad_cpp_line;
880
881   *c++ = '\0';
882
883
884
885   /* Get flags.  */
886   
887   flag[1] = flag[2] = flag[3] = flag[4] = flag[5] = false;
888
889   for (;;)
890     {
891       c = strchr (c, ' ');
892       if (c == NULL)
893         break;
894
895       c++;
896       i = atoi (c);
897
898       if (1 <= i && i <= 4)
899         flag[i] = true;
900     }
901      
902   /* Interpret flags.  */
903   
904   if (flag[1] || flag[3]) /* Starting new file.  */
905     {
906       f = get_file (filename, LC_RENAME);
907       f->up = current_file;
908       current_file = f;
909     }
910   
911   if (flag[2]) /* Ending current file.  */
912     {
913       current_file = current_file->up;
914     }
915   
916   /* The name of the file can be a temporary file produced by
917      cpp. Replace the name if it is different.  */
918   
919   if (strcmp (current_file->filename, filename) != 0)
920     {
921       gfc_free (current_file->filename);
922       current_file->filename = gfc_getmem (strlen (filename) + 1);
923       strcpy (current_file->filename, filename);
924     }
925
926   return;
927
928  bad_cpp_line:
929   gfc_warning_now ("%s:%d: Illegal preprocessor directive", 
930                    current_file->filename, current_file->line);
931   current_file->line++;
932 }
933
934
935 static try load_file (char *, bool);
936
937 /* include_line()-- Checks a line buffer to see if it is an include
938    line.  If so, we call load_file() recursively to load the included
939    file.  We never return a syntax error because a statement like
940    "include = 5" is perfectly legal.  We return false if no include was
941    processed or true if we matched an include.  */
942
943 static bool
944 include_line (char *line)
945 {
946   char quote, *c, *begin, *stop;
947   
948   c = line;
949   while (*c == ' ' || *c == '\t')
950     c++;
951
952   if (strncasecmp (c, "include", 7))
953       return false;
954
955   c += 7;
956   while (*c == ' ' || *c == '\t')
957     c++;
958
959   /* Find filename between quotes.  */
960   
961   quote = *c++;
962   if (quote != '"' && quote != '\'')
963     return false;
964
965   begin = c;
966
967   while (*c != quote && *c != '\0')
968     c++;
969
970   if (*c == '\0')
971     return false;
972
973   stop = c++;
974   
975   while (*c == ' ' || *c == '\t')
976     c++;
977
978   if (*c != '\0' && *c != '!')
979     return false;
980
981   /* We have an include line at this point.  */
982
983   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
984                    read by anything else.  */
985
986   load_file (begin, false);
987   return true;
988 }
989
990 /* Load a file into memory by calling load_line until the file ends.  */
991
992 static try
993 load_file (char *filename, bool initial)
994 {
995   char *line;
996   gfc_linebuf *b;
997   gfc_file *f;
998   FILE *input;
999   int len;
1000
1001   for (f = current_file; f; f = f->up)
1002     if (strcmp (filename, f->filename) == 0)
1003       {
1004         gfc_error_now ("File '%s' is being included recursively", filename);
1005         return FAILURE;
1006       }
1007
1008   if (initial)
1009     {
1010       input = gfc_open_file (filename);
1011       if (input == NULL)
1012         {
1013           gfc_error_now ("Can't open file '%s'", filename);
1014           return FAILURE;
1015         }
1016     }
1017   else
1018     {
1019       input = gfc_open_included_file (filename);
1020       if (input == NULL)
1021         {
1022           gfc_error_now ("Can't open included file '%s'", filename);
1023           return FAILURE;
1024         }
1025     }
1026
1027   /* Load the file.  */
1028
1029   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1030   f->up = current_file;
1031   current_file = f;
1032   current_file->line = 1;
1033   line = NULL;
1034
1035   for (;;) 
1036     {
1037       load_line (input, &line, filename, current_file->line);
1038
1039       len = strlen (line);
1040       if (feof (input) && len == 0)
1041         break;
1042
1043       /* There are three things this line can be: a line of Fortran
1044          source, an include line or a C preprocessor directive.  */
1045
1046       if (line[0] == '#')
1047         {
1048           preprocessor_line (line);
1049           continue;
1050         }
1051
1052       if (include_line (line))
1053         {
1054           current_file->line++;
1055           continue;
1056         }
1057
1058       /* Add line.  */
1059
1060       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1061
1062 #ifdef USE_MAPPED_LOCATION
1063       b->location
1064         = linemap_line_start (&line_table, current_file->line++, 120);
1065 #else
1066       b->linenum = current_file->line++;
1067 #endif
1068       b->file = current_file;
1069       strcpy (b->line, line);
1070
1071       if (line_head == NULL)
1072         line_head = b;
1073       else
1074         line_tail->next = b;
1075
1076       line_tail = b;
1077     }
1078
1079   /* Release the line buffer allocated in load_line.  */
1080   gfc_free (line);
1081
1082   fclose (input);
1083
1084   current_file = current_file->up;
1085 #ifdef USE_MAPPED_LOCATION
1086   linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1087 #endif
1088   return SUCCESS;
1089 }
1090
1091
1092 /* Determine the source form from the filename extension.  We assume
1093    case insensitivity.  */
1094
1095 static gfc_source_form
1096 form_from_filename (const char *filename)
1097 {
1098
1099   static const struct
1100   {
1101     const char *extension;
1102     gfc_source_form form;
1103   }
1104   exttype[] =
1105   {
1106     {
1107     ".f90", FORM_FREE}
1108     ,
1109     {
1110     ".f95", FORM_FREE}
1111     ,
1112     {
1113     ".f", FORM_FIXED}
1114     ,
1115     {
1116     ".for", FORM_FIXED}
1117     ,
1118     {
1119     "", FORM_UNKNOWN}
1120   };            /* sentinel value */
1121
1122   gfc_source_form f_form;
1123   const char *fileext;
1124   int i;
1125
1126   /* Find end of file name.  */
1127   i = 0;
1128   while ((i < PATH_MAX) && (filename[i] != '\0'))
1129     i++;
1130
1131   /* Improperly terminated or too-long filename.  */
1132   if (i == PATH_MAX)
1133     return FORM_UNKNOWN;
1134
1135   /* Find last period.  */
1136   while (i >= 0 && (filename[i] != '.'))
1137     i--;
1138
1139   /* Did we see a file extension?  */
1140   if (i < 0)
1141     return FORM_UNKNOWN; /* Nope  */
1142
1143   /* Get file extension and compare it to others.  */
1144   fileext = &(filename[i]);
1145
1146   i = -1;
1147   f_form = FORM_UNKNOWN;
1148   do
1149     {
1150       i++;
1151       if (strcasecmp (fileext, exttype[i].extension) == 0)
1152         {
1153           f_form = exttype[i].form;
1154           break;
1155         }
1156     }
1157   while (exttype[i].form != FORM_UNKNOWN);
1158
1159   return f_form;
1160 }
1161
1162
1163 /* Open a new file and start scanning from that file. Returns SUCCESS
1164    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1165    it tries to determine the source form from the filename, defaulting
1166    to free form.  */
1167
1168 try
1169 gfc_new_file (const char *filename, gfc_source_form form)
1170 {
1171   try result;
1172
1173   if (filename != NULL)
1174     {
1175       gfc_source_file = gfc_getmem (strlen (filename) + 1);
1176       strcpy (gfc_source_file, filename);
1177     }
1178   else
1179     gfc_source_file = NULL;
1180
1181   /* Decide which form the file will be read in as.  */
1182
1183   if (form != FORM_UNKNOWN)
1184     gfc_current_form = form;
1185   else
1186     {
1187       gfc_current_form = form_from_filename (filename);
1188
1189       if (gfc_current_form == FORM_UNKNOWN)
1190         {
1191           gfc_current_form = FORM_FREE;
1192           gfc_warning_now ("Reading file '%s' as free form.", 
1193                            (filename[0] == '\0') ? "<stdin>" : filename); 
1194         }
1195     }
1196
1197   result = load_file (gfc_source_file, true);
1198
1199   gfc_current_locus.lb = line_head;
1200   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1201
1202 #if 0 /* Debugging aid.  */
1203   for (; line_head; line_head = line_head->next)
1204     gfc_status ("%s:%3d %s\n", line_head->file->filename, 
1205 #ifdef USE_MAPPED_LOCATION
1206                 LOCATION_LINE (line_head->location),
1207 #else
1208                 line_head->linenum,
1209 #endif
1210                 line_head->line);
1211
1212   exit (0);
1213 #endif
1214
1215   return result;
1216 }