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