]> gcc.gnu.org Git - gcc.git/blob - gcc/fortran/scanner.c
re PR fortran/14569 ([4.0 only] should not warn about truncated comment lines)
[gcc.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 return;
635 if (c == '\\')
636 {
637 c = next_char ();
638 if (c == '\n')
639 return;
640 }
641 }
642 if (gfc_at_eof ())
643 break;
644 }
645 }
646
647
648 /* Read ahead until the next character to be read is not whitespace. */
649
650 void
651 gfc_gobble_whitespace (void)
652 {
653 locus old_loc;
654 int c;
655
656 do
657 {
658 old_loc = gfc_current_locus;
659 c = gfc_next_char_literal (0);
660 }
661 while (gfc_is_whitespace (c));
662
663 gfc_current_locus = old_loc;
664 }
665
666
667 /* Load a single line into pbuf.
668
669 If pbuf points to a NULL pointer, it is allocated.
670 We truncate lines that are too long, unless we're dealing with
671 preprocessor lines or if the option -ffixed-line-length-none is set,
672 in which case we reallocate the buffer to fit the entire line, if
673 need be.
674 In fixed mode, we expand a tab that occurs within the statement
675 label region to expand to spaces that leave the next character in
676 the source region.
677 load_line returns wether the line was truncated. */
678
679 static int
680 load_line (FILE * input, char **pbuf)
681 {
682 int c, maxlen, i, preprocessor_flag;
683 int trunc_flag = 0;
684 static int buflen = 0;
685 char *buffer;
686
687 /* Determine the maximum allowed line length. */
688 if (gfc_current_form == FORM_FREE)
689 maxlen = GFC_MAX_LINE;
690 else
691 maxlen = gfc_option.fixed_line_length;
692
693 if (*pbuf == NULL)
694 {
695 /* Allocate the line buffer, storing its length into buflen. */
696 if (maxlen > 0)
697 buflen = maxlen;
698 else
699 buflen = GFC_MAX_LINE;
700
701 *pbuf = gfc_getmem (buflen + 1);
702 }
703
704 i = 0;
705 buffer = *pbuf;
706
707 preprocessor_flag = 0;
708 c = fgetc (input);
709 if (c == '#')
710 /* In order to not truncate preprocessor lines, we have to
711 remember that this is one. */
712 preprocessor_flag = 1;
713 ungetc (c, input);
714
715 for (;;)
716 {
717 c = fgetc (input);
718
719 if (c == EOF)
720 break;
721 if (c == '\n')
722 break;
723
724 if (c == '\r')
725 continue; /* Gobble characters. */
726 if (c == '\0')
727 continue;
728
729 if (c == '\032')
730 {
731 /* Ctrl-Z ends the file. */
732 while (fgetc (input) != EOF);
733 break;
734 }
735
736 if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
737 { /* Tab expansion. */
738 while (i <= 6)
739 {
740 *buffer++ = ' ';
741 i++;
742 }
743
744 continue;
745 }
746
747 *buffer++ = c;
748 i++;
749
750 if (i >= buflen && (maxlen == 0 || preprocessor_flag))
751 {
752 /* Reallocate line buffer to double size to hold the
753 overlong line. */
754 buflen = buflen * 2;
755 *pbuf = xrealloc (*pbuf, buflen);
756 buffer = (*pbuf)+i;
757 }
758 else if (i >= buflen)
759 {
760 /* Truncate the rest of the line. */
761 trunc_flag = 1;
762
763 for (;;)
764 {
765 c = fgetc (input);
766 if (c == '\n' || c == EOF)
767 break;
768 }
769
770 ungetc ('\n', input);
771 }
772 }
773
774 /* Pad lines to the selected line length in fixed form. */
775 if (gfc_current_form == FORM_FIXED
776 && gfc_option.fixed_line_length > 0
777 && !preprocessor_flag
778 && c != EOF)
779 while (i++ < buflen)
780 *buffer++ = ' ';
781
782 *buffer = '\0';
783
784 return trunc_flag;
785 }
786
787
788 /* Get a gfc_file structure, initialize it and add it to
789 the file stack. */
790
791 static gfc_file *
792 get_file (char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
793 {
794 gfc_file *f;
795
796 f = gfc_getmem (sizeof (gfc_file));
797
798 f->filename = gfc_getmem (strlen (name) + 1);
799 strcpy (f->filename, name);
800
801 f->next = file_head;
802 file_head = f;
803
804 f->included_by = current_file;
805 if (current_file != NULL)
806 f->inclusion_line = current_file->line;
807
808 #ifdef USE_MAPPED_LOCATION
809 linemap_add (&line_table, reason, false, f->filename, 1);
810 #endif
811
812 return f;
813 }
814
815 /* Deal with a line from the C preprocessor. The
816 initial octothorp has already been seen. */
817
818 static void
819 preprocessor_line (char *c)
820 {
821 bool flag[5];
822 int i, line;
823 char *filename;
824 gfc_file *f;
825 int escaped;
826
827 c++;
828 while (*c == ' ' || *c == '\t')
829 c++;
830
831 if (*c < '0' || *c > '9')
832 goto bad_cpp_line;
833
834 line = atoi (c);
835
836 /* Set new line number. */
837 current_file->line = line;
838
839 c = strchr (c, ' ');
840 if (c == NULL)
841 /* No file name given. */
842 return;
843
844
845
846 /* Skip spaces. */
847 while (*c == ' ' || *c == '\t')
848 c++;
849
850 /* Skip quote. */
851 if (*c != '"')
852 goto bad_cpp_line;
853 ++c;
854
855 filename = c;
856
857 /* Make filename end at quote. */
858 escaped = false;
859 while (*c && ! (! escaped && *c == '"'))
860 {
861 if (escaped)
862 escaped = false;
863 else
864 escaped = *c == '\\';
865 ++c;
866 }
867
868 if (! *c)
869 /* Preprocessor line has no closing quote. */
870 goto bad_cpp_line;
871
872 *c++ = '\0';
873
874
875
876 /* Get flags. */
877
878 flag[1] = flag[2] = flag[3] = flag[4] = flag[5] = false;
879
880 for (;;)
881 {
882 c = strchr (c, ' ');
883 if (c == NULL)
884 break;
885
886 c++;
887 i = atoi (c);
888
889 if (1 <= i && i <= 4)
890 flag[i] = true;
891 }
892
893 /* Interpret flags. */
894
895 if (flag[1] || flag[3]) /* Starting new file. */
896 {
897 f = get_file (filename, LC_RENAME);
898 f->up = current_file;
899 current_file = f;
900 }
901
902 if (flag[2]) /* Ending current file. */
903 {
904 current_file = current_file->up;
905 }
906
907 /* The name of the file can be a temporary file produced by
908 cpp. Replace the name if it is different. */
909
910 if (strcmp (current_file->filename, filename) != 0)
911 {
912 gfc_free (current_file->filename);
913 current_file->filename = gfc_getmem (strlen (filename) + 1);
914 strcpy (current_file->filename, filename);
915 }
916
917 return;
918
919 bad_cpp_line:
920 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
921 current_file->filename, current_file->line);
922 current_file->line++;
923 }
924
925
926 static try load_file (char *, bool);
927
928 /* include_line()-- Checks a line buffer to see if it is an include
929 line. If so, we call load_file() recursively to load the included
930 file. We never return a syntax error because a statement like
931 "include = 5" is perfectly legal. We return false if no include was
932 processed or true if we matched an include. */
933
934 static bool
935 include_line (char *line)
936 {
937 char quote, *c, *begin, *stop;
938
939 c = line;
940 while (*c == ' ' || *c == '\t')
941 c++;
942
943 if (strncasecmp (c, "include", 7))
944 return false;
945
946 c += 7;
947 while (*c == ' ' || *c == '\t')
948 c++;
949
950 /* Find filename between quotes. */
951
952 quote = *c++;
953 if (quote != '"' && quote != '\'')
954 return false;
955
956 begin = c;
957
958 while (*c != quote && *c != '\0')
959 c++;
960
961 if (*c == '\0')
962 return false;
963
964 stop = c++;
965
966 while (*c == ' ' || *c == '\t')
967 c++;
968
969 if (*c != '\0' && *c != '!')
970 return false;
971
972 /* We have an include line at this point. */
973
974 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
975 read by anything else. */
976
977 load_file (begin, false);
978 return true;
979 }
980
981 /* Load a file into memory by calling load_line until the file ends. */
982
983 static try
984 load_file (char *filename, bool initial)
985 {
986 char *line;
987 gfc_linebuf *b;
988 gfc_file *f;
989 FILE *input;
990 int len;
991
992 for (f = current_file; f; f = f->up)
993 if (strcmp (filename, f->filename) == 0)
994 {
995 gfc_error_now ("File '%s' is being included recursively", filename);
996 return FAILURE;
997 }
998
999 if (initial)
1000 {
1001 input = gfc_open_file (filename);
1002 if (input == NULL)
1003 {
1004 gfc_error_now ("Can't open file '%s'", filename);
1005 return FAILURE;
1006 }
1007 }
1008 else
1009 {
1010 input = gfc_open_included_file (filename);
1011 if (input == NULL)
1012 {
1013 gfc_error_now ("Can't open included file '%s'", filename);
1014 return FAILURE;
1015 }
1016 }
1017
1018 /* Load the file. */
1019
1020 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1021 f->up = current_file;
1022 current_file = f;
1023 current_file->line = 1;
1024 line = NULL;
1025
1026 for (;;)
1027 {
1028 int trunc = load_line (input, &line);
1029
1030 len = strlen (line);
1031 if (feof (input) && len == 0)
1032 break;
1033
1034 /* There are three things this line can be: a line of Fortran
1035 source, an include line or a C preprocessor directive. */
1036
1037 if (line[0] == '#')
1038 {
1039 preprocessor_line (line);
1040 continue;
1041 }
1042
1043 if (include_line (line))
1044 {
1045 current_file->line++;
1046 continue;
1047 }
1048
1049 /* Add line. */
1050
1051 b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1052
1053 #ifdef USE_MAPPED_LOCATION
1054 b->location
1055 = linemap_line_start (&line_table, current_file->line++, 120);
1056 #else
1057 b->linenum = current_file->line++;
1058 #endif
1059 b->file = current_file;
1060 b->truncated = trunc;
1061 strcpy (b->line, line);
1062
1063 if (line_head == NULL)
1064 line_head = b;
1065 else
1066 line_tail->next = b;
1067
1068 line_tail = b;
1069 }
1070
1071 /* Release the line buffer allocated in load_line. */
1072 gfc_free (line);
1073
1074 fclose (input);
1075
1076 current_file = current_file->up;
1077 #ifdef USE_MAPPED_LOCATION
1078 linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1079 #endif
1080 return SUCCESS;
1081 }
1082
1083
1084 /* Determine the source form from the filename extension. We assume
1085 case insensitivity. */
1086
1087 static gfc_source_form
1088 form_from_filename (const char *filename)
1089 {
1090
1091 static const struct
1092 {
1093 const char *extension;
1094 gfc_source_form form;
1095 }
1096 exttype[] =
1097 {
1098 {
1099 ".f90", FORM_FREE}
1100 ,
1101 {
1102 ".f95", FORM_FREE}
1103 ,
1104 {
1105 ".f", FORM_FIXED}
1106 ,
1107 {
1108 ".for", FORM_FIXED}
1109 ,
1110 {
1111 "", FORM_UNKNOWN}
1112 }; /* sentinel value */
1113
1114 gfc_source_form f_form;
1115 const char *fileext;
1116 int i;
1117
1118 /* Find end of file name. */
1119 i = 0;
1120 while ((i < PATH_MAX) && (filename[i] != '\0'))
1121 i++;
1122
1123 /* Improperly terminated or too-long filename. */
1124 if (i == PATH_MAX)
1125 return FORM_UNKNOWN;
1126
1127 /* Find last period. */
1128 while (i >= 0 && (filename[i] != '.'))
1129 i--;
1130
1131 /* Did we see a file extension? */
1132 if (i < 0)
1133 return FORM_UNKNOWN; /* Nope */
1134
1135 /* Get file extension and compare it to others. */
1136 fileext = &(filename[i]);
1137
1138 i = -1;
1139 f_form = FORM_UNKNOWN;
1140 do
1141 {
1142 i++;
1143 if (strcasecmp (fileext, exttype[i].extension) == 0)
1144 {
1145 f_form = exttype[i].form;
1146 break;
1147 }
1148 }
1149 while (exttype[i].form != FORM_UNKNOWN);
1150
1151 return f_form;
1152 }
1153
1154
1155 /* Open a new file and start scanning from that file. Returns SUCCESS
1156 if everything went OK, FAILURE otherwise. If form == FORM_UKNOWN
1157 it tries to determine the source form from the filename, defaulting
1158 to free form. */
1159
1160 try
1161 gfc_new_file (const char *filename, gfc_source_form form)
1162 {
1163 try result;
1164
1165 if (filename != NULL)
1166 {
1167 gfc_source_file = gfc_getmem (strlen (filename) + 1);
1168 strcpy (gfc_source_file, filename);
1169 }
1170 else
1171 gfc_source_file = NULL;
1172
1173 /* Decide which form the file will be read in as. */
1174
1175 if (form != FORM_UNKNOWN)
1176 gfc_current_form = form;
1177 else
1178 {
1179 gfc_current_form = form_from_filename (filename);
1180
1181 if (gfc_current_form == FORM_UNKNOWN)
1182 {
1183 gfc_current_form = FORM_FREE;
1184 gfc_warning_now ("Reading file '%s' as free form.",
1185 (filename[0] == '\0') ? "<stdin>" : filename);
1186 }
1187 }
1188
1189 result = load_file (gfc_source_file, true);
1190
1191 gfc_current_locus.lb = line_head;
1192 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1193
1194 #if 0 /* Debugging aid. */
1195 for (; line_head; line_head = line_head->next)
1196 gfc_status ("%s:%3d %s\n", line_head->file->filename,
1197 #ifdef USE_MAPPED_LOCATION
1198 LOCATION_LINE (line_head->location),
1199 #else
1200 line_head->linenum,
1201 #endif
1202 line_head->line);
1203
1204 exit (0);
1205 #endif
1206
1207 return result;
1208 }
This page took 0.129473 seconds and 6 git commands to generate.