]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/scanner.c
re PR libfortran/17706 (reading a value of 0.0 gives a value of -0.0)
[thirdparty/gcc.git] / gcc / fortran / scanner.c
CommitLineData
6de9cd9a
DN
1/* Character scanner.
2 Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
9fc4d79b 5This file is part of GCC.
6de9cd9a 6
9fc4d79b
TS
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 2, or (at your option) any later
10version.
6de9cd9a 11
9fc4d79b
TS
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
6de9cd9a
DN
16
17You should have received a copy of the GNU General Public License
9fc4d79b
TS
18along with GCC; see the file COPYING. If not, write to the Free
19Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, USA. */
6de9cd9a
DN
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. */
53typedef struct gfc_directorylist
54{
55 char *path;
56 struct gfc_directorylist *next;
57}
58gfc_directorylist;
59
60/* List of include file search directories. */
61static gfc_directorylist *include_dirs;
62
d4fa05b9 63static gfc_file *file_head, *current_file;
6de9cd9a 64
d4fa05b9 65static int continue_flag, end_flag;
6de9cd9a 66
d4fa05b9
TS
67gfc_source_form gfc_current_form;
68static gfc_linebuf *line_head, *line_tail;
69
63645982 70locus gfc_current_locus;
d4fa05b9
TS
71char *gfc_source_file;
72
6de9cd9a
DN
73
74/* Main scanner initialization. */
75
76void
77gfc_scanner_init_1 (void)
78{
d4fa05b9
TS
79 file_head = NULL;
80 line_head = NULL;
81 line_tail = NULL;
6de9cd9a 82
6de9cd9a
DN
83 end_flag = 0;
84}
85
86
87/* Main scanner destructor. */
88
89void
90gfc_scanner_done_1 (void)
91{
d4fa05b9
TS
92 gfc_linebuf *lb;
93 gfc_file *f;
6de9cd9a 94
d4fa05b9 95 while(line_head != NULL)
6de9cd9a 96 {
d4fa05b9
TS
97 lb = line_head->next;
98 gfc_free(line_head);
99 line_head = lb;
6de9cd9a 100 }
d4fa05b9
TS
101
102 while(file_head != NULL)
6de9cd9a 103 {
d4fa05b9
TS
104 f = file_head->next;
105 gfc_free(file_head->filename);
106 gfc_free(file_head);
107 file_head = f;
6de9cd9a 108 }
d4fa05b9 109
6de9cd9a
DN
110}
111
112
113/* Adds path to the list pointed to by list. */
114
115void
116gfc_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
149void
150gfc_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
6de9cd9a
DN
164/* Opens file for reading, searching through the include directories
165 given if necessary. */
166
167FILE *
168gfc_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
6de9cd9a
DN
194/* Test to see if we're at the end of the main source file. */
195
196int
197gfc_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
206int
207gfc_at_eof (void)
208{
209
210 if (gfc_at_end ())
211 return 1;
212
d4fa05b9 213 if (line_head == NULL)
6de9cd9a
DN
214 return 1; /* Null file */
215
63645982 216 if (gfc_current_locus.lb == NULL)
6de9cd9a
DN
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
225int
226gfc_at_bol (void)
227{
6de9cd9a
DN
228 if (gfc_at_eof ())
229 return 1;
230
63645982 231 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
6de9cd9a
DN
232}
233
234
235/* Test to see if we're at the end of a line. */
236
237int
238gfc_at_eol (void)
239{
240
241 if (gfc_at_eof ())
242 return 1;
243
63645982 244 return (*gfc_current_locus.nextc == '\0');
6de9cd9a
DN
245}
246
247
248/* Advance the current line pointer to the next line. */
249
250void
251gfc_advance_line (void)
252{
6de9cd9a
DN
253 if (gfc_at_end ())
254 return;
255
63645982 256 if (gfc_current_locus.lb == NULL)
6de9cd9a 257 {
d4fa05b9
TS
258 end_flag = 1;
259 return;
260 }
6de9cd9a 261
63645982 262 gfc_current_locus.lb = gfc_current_locus.lb->next;
6de9cd9a 263
63645982
TS
264 if (gfc_current_locus.lb != NULL)
265 gfc_current_locus.nextc = gfc_current_locus.lb->line;
d4fa05b9
TS
266 else
267 {
63645982 268 gfc_current_locus.nextc = NULL;
d4fa05b9
TS
269 end_flag = 1;
270 }
6de9cd9a
DN
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
283static int
284next_char (void)
285{
6de9cd9a 286 int c;
d4fa05b9 287
63645982 288 if (gfc_current_locus.nextc == NULL)
6de9cd9a
DN
289 return '\n';
290
63645982 291 c = *gfc_current_locus.nextc++;
6de9cd9a
DN
292 if (c == '\0')
293 {
63645982 294 gfc_current_locus.nextc--; /* Remain on this line. */
6de9cd9a
DN
295 c = '\n';
296 }
297
298 return c;
299}
300
6de9cd9a
DN
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
306static void
307skip_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
324static void
325skip_free_comments (void)
326{
327 locus start;
328 char c;
329
330 for (;;)
331 {
63645982 332 start = gfc_current_locus;
6de9cd9a
DN
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
63645982 357 gfc_current_locus = start;
6de9cd9a
DN
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
365static void
366skip_fixed_comments (void)
367{
368 locus start;
369 int col;
370 char c;
371
372 for (;;)
373 {
63645982 374 start = gfc_current_locus;
6de9cd9a
DN
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
63645982 414 gfc_current_locus = start;
6de9cd9a
DN
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
421void
422gfc_skip_comments (void)
423{
424
d4fa05b9 425 if (!gfc_at_bol () || gfc_current_form == FORM_FREE)
6de9cd9a
DN
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
439int
440gfc_next_char_literal (int in_string)
441{
442 locus old_loc;
443 int i, c;
444
445 continue_flag = 0;
446
447restart:
448 c = next_char ();
449 if (gfc_at_end ())
450 return c;
451
d4fa05b9 452 if (gfc_current_form == FORM_FREE)
6de9cd9a
DN
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. */
63645982 472 old_loc = gfc_current_locus;
6de9cd9a
DN
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 {
63645982 483 gfc_current_locus = old_loc;
6de9cd9a
DN
484 c = '&';
485 goto done;
486 }
487
488 if (c != '!' && c != '\n')
489 {
63645982 490 gfc_current_locus = old_loc;
6de9cd9a
DN
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
63645982 510 old_loc = gfc_current_locus;
6de9cd9a
DN
511
512 c = next_char ();
513 while (gfc_is_whitespace (c))
514 c = next_char ();
515
516 if (c != '&')
63645982 517 gfc_current_locus = old_loc;
6de9cd9a
DN
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;
63645982 537 old_loc = gfc_current_locus;
6de9cd9a
DN
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
559not_continuation:
560 c = '\n';
63645982 561 gfc_current_locus = old_loc;
6de9cd9a
DN
562
563done:
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
574int
575gfc_next_char (void)
576{
577 int c;
578
579 do
580 {
581 c = gfc_next_char_literal (0);
582 }
d4fa05b9 583 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
6de9cd9a
DN
584
585 return TOLOWER (c);
586}
587
588
589int
590gfc_peek_char (void)
591{
592 locus old_loc;
593 int c;
594
63645982 595 old_loc = gfc_current_locus;
6de9cd9a 596 c = gfc_next_char ();
63645982 597 gfc_current_locus = old_loc;
6de9cd9a
DN
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
608void
609gfc_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
649done:
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
657void
658gfc_gobble_whitespace (void)
659{
660 locus old_loc;
661 int c;
662
663 do
664 {
63645982 665 old_loc = gfc_current_locus;
6de9cd9a
DN
666 c = gfc_next_char_literal (0);
667 }
668 while (gfc_is_whitespace (c));
669
63645982 670 gfc_current_locus = old_loc;
6de9cd9a
DN
671}
672
673
f56c5d5d
TS
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. */
6de9cd9a
DN
684
685static void
f56c5d5d 686load_line (FILE * input, char **pbuf, char *filename, int linenum)
6de9cd9a 687{
fa841200 688 int c, maxlen, i, trunc_flag, preprocessor_flag;
f56c5d5d
TS
689 static int buflen = 0;
690 char *buffer;
691
1f2959f0 692 /* Determine the maximum allowed line length. */
f56c5d5d
TS
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;
6de9cd9a 705
f56c5d5d
TS
706 *pbuf = gfc_getmem (buflen + 1);
707 }
6de9cd9a
DN
708
709 i = 0;
f56c5d5d 710 buffer = *pbuf;
6de9cd9a 711
fa841200
TS
712 preprocessor_flag = 0;
713 c = fgetc (input);
714 if (c == '#')
f56c5d5d
TS
715 /* In order to not truncate preprocessor lines, we have to
716 remember that this is one. */
fa841200
TS
717 preprocessor_flag = 1;
718 ungetc (c, input);
719
6de9cd9a
DN
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')
d4fa05b9 730 continue; /* Gobble characters. */
6de9cd9a
DN
731 if (c == '\0')
732 continue;
733
d4fa05b9
TS
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)
1f2959f0 742 { /* Tab expansion. */
6de9cd9a
DN
743 while (i <= 6)
744 {
745 *buffer++ = ' ';
746 i++;
747 }
748
749 continue;
750 }
751
752 *buffer++ = c;
753 i++;
754
f56c5d5d
TS
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. */
6de9cd9a
DN
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 {
fa841200
TS
778 gfc_warning_now ("%s:%d: Line is being truncated",
779 filename, linenum);
6de9cd9a
DN
780 trunc_flag = 0;
781 }
782 }
783
784 ungetc ('\n', input);
785 }
786 }
787
f56c5d5d
TS
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
6de9cd9a
DN
796 *buffer = '\0';
797}
798
799
d4fa05b9
TS
800/* Get a gfc_file structure, initialize it and add it to
801 the file stack. */
802
803static gfc_file *
4d28e183 804get_file (char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
d4fa05b9
TS
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
c8cc8542
PB
820#ifdef USE_MAPPED_LOCATION
821 linemap_add (&line_table, reason, false, f->filename, 1);
822#endif
823
d4fa05b9
TS
824 return f;
825}
826
827/* Deal with a line from the C preprocessor. The
828 initial octothorp has already been seen. */
6de9cd9a
DN
829
830static void
d4fa05b9 831preprocessor_line (char *c)
6de9cd9a 832{
d4fa05b9
TS
833 bool flag[5];
834 int i, line;
835 char *filename;
836 gfc_file *f;
6de9cd9a 837
d4fa05b9
TS
838 c++;
839 while (*c == ' ' || *c == '\t')
840 c++;
6de9cd9a 841
d4fa05b9 842 if (*c < '0' || *c > '9')
fa841200 843 goto bad_cpp_line;
6de9cd9a 844
d4fa05b9
TS
845 line = atoi (c);
846
fa841200
TS
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. */
d4fa05b9
TS
852 filename = c;
853
854 c = strchr (c, '"'); /* Make filename end at quote. */
fa841200
TS
855 if (c == NULL)
856 /* Preprocessor line has no closing quote. */
857 goto bad_cpp_line;
d4fa05b9
TS
858 *c++ = '\0';
859
860 /* Get flags. */
861
862 flag[1] = flag[2] = flag[3] = flag[4] = flag[5] = false;
6de9cd9a 863
6de9cd9a
DN
864 for (;;)
865 {
d4fa05b9
TS
866 c = strchr (c, ' ');
867 if (c == NULL)
868 break;
6de9cd9a 869
d4fa05b9
TS
870 c++;
871 i = atoi (c);
6de9cd9a 872
d4fa05b9
TS
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 {
c8cc8542 881 f = get_file (filename, LC_RENAME);
d4fa05b9
TS
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 }
fa841200
TS
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++;
d4fa05b9
TS
909}
910
911
912static 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
920static bool
921include_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
969static try
970load_file (char *filename, bool initial)
971{
f56c5d5d 972 char *line;
d4fa05b9
TS
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
c8cc8542 1006 f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
d4fa05b9
TS
1007 f->up = current_file;
1008 current_file = f;
1009 current_file->line = 1;
f56c5d5d 1010 line = NULL;
d4fa05b9
TS
1011
1012 for (;;)
1013 {
f56c5d5d 1014 load_line (input, &line, filename, current_file->line);
d4fa05b9
TS
1015
1016 len = strlen (line);
6de9cd9a
DN
1017 if (feof (input) && len == 0)
1018 break;
1019
d4fa05b9
TS
1020 /* There are three things this line can be: a line of Fortran
1021 source, an include line or a C preprocessor directive. */
6de9cd9a 1022
d4fa05b9
TS
1023 if (line[0] == '#')
1024 {
1025 preprocessor_line (line);
1026 continue;
1027 }
6de9cd9a 1028
d4fa05b9
TS
1029 if (include_line (line))
1030 {
1031 current_file->line++;
1032 continue;
6de9cd9a
DN
1033 }
1034
d4fa05b9
TS
1035 /* Add line. */
1036
4cdf7223 1037 b = gfc_getmem (gfc_linebuf_header_size + len + 1);
d4fa05b9 1038
c8cc8542
PB
1039#ifdef USE_MAPPED_LOCATION
1040 b->location
1041 = linemap_line_start (&line_table, current_file->line++, 120);
1042#else
d4fa05b9 1043 b->linenum = current_file->line++;
c8cc8542 1044#endif
d4fa05b9
TS
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;
6de9cd9a 1054 }
d4fa05b9 1055
f56c5d5d
TS
1056 /* Release the line buffer allocated in load_line. */
1057 gfc_free (line);
1058
d4fa05b9
TS
1059 fclose (input);
1060
1061 current_file = current_file->up;
c8cc8542
PB
1062#ifdef USE_MAPPED_LOCATION
1063 linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1064#endif
d4fa05b9 1065 return SUCCESS;
6de9cd9a
DN
1066}
1067
1068
1069/* Determine the source form from the filename extension. We assume
1070 case insensitivity. */
1071
1072static gfc_source_form
1073form_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
d4fa05b9
TS
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. */
6de9cd9a
DN
1144
1145try
1146gfc_new_file (const char *filename, gfc_source_form form)
1147{
d4fa05b9 1148 try result;
6de9cd9a 1149
d4fa05b9 1150 if (filename != NULL)
6de9cd9a 1151 {
d4fa05b9
TS
1152 gfc_source_file = gfc_getmem (strlen (filename) + 1);
1153 strcpy (gfc_source_file, filename);
6de9cd9a 1154 }
6de9cd9a 1155 else
d4fa05b9 1156 gfc_source_file = NULL;
6de9cd9a
DN
1157
1158 /* Decide which form the file will be read in as. */
d4fa05b9 1159
6de9cd9a 1160 if (form != FORM_UNKNOWN)
d4fa05b9 1161 gfc_current_form = form;
6de9cd9a
DN
1162 else
1163 {
d4fa05b9 1164 gfc_current_form = form_from_filename (filename);
6de9cd9a 1165
d4fa05b9 1166 if (gfc_current_form == FORM_UNKNOWN)
6de9cd9a 1167 {
d4fa05b9
TS
1168 gfc_current_form = FORM_FREE;
1169 gfc_warning_now ("Reading file '%s' as free form.",
1170 (filename[0] == '\0') ? "<stdin>" : filename);
6de9cd9a
DN
1171 }
1172 }
1173
d4fa05b9 1174 result = load_file (gfc_source_file, true);
6de9cd9a 1175
63645982
TS
1176 gfc_current_locus.lb = line_head;
1177 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
6de9cd9a 1178
d4fa05b9
TS
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,
c8cc8542
PB
1182#ifdef USE_MAPPED_LOCATION
1183 LOCATION_LINE (line_head->location),
1184#else
1185 line_head->linenum,
1186#endif
1187 line_head->line);
6de9cd9a 1188
d4fa05b9
TS
1189 exit (0);
1190#endif
6de9cd9a 1191
d4fa05b9 1192 return result;
6de9cd9a 1193}