]>
Commit | Line | Data |
---|---|---|
6de9cd9a DN |
1 | /* Character scanner. |
2 | Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. | |
3 | Contributed by Andy Vaught | |
4 | ||
9fc4d79b | 5 | This file is part of GCC. |
6de9cd9a | 6 | |
9fc4d79b TS |
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. | |
6de9cd9a | 11 | |
9fc4d79b TS |
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. | |
6de9cd9a DN |
16 | |
17 | You should have received a copy of the GNU General Public License | |
9fc4d79b TS |
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. */ | |
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. */ | |
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 *first_file, *first_duplicated_file; | |
64 | static int continue_flag, end_flag; | |
65 | ||
66 | gfc_file *gfc_current_file; | |
67 | ||
68 | ||
69 | /* Main scanner initialization. */ | |
70 | ||
71 | void | |
72 | gfc_scanner_init_1 (void) | |
73 | { | |
74 | ||
75 | gfc_current_file = NULL; | |
76 | first_file = NULL; | |
77 | first_duplicated_file = NULL; | |
78 | end_flag = 0; | |
79 | } | |
80 | ||
81 | ||
82 | /* Main scanner destructor. */ | |
83 | ||
84 | void | |
85 | gfc_scanner_done_1 (void) | |
86 | { | |
87 | ||
88 | linebuf *lp, *lp2; | |
89 | gfc_file *fp, *fp2; | |
90 | ||
91 | for (fp = first_file; fp; fp = fp2) | |
92 | { | |
93 | ||
94 | if (fp->start != NULL) | |
95 | { | |
96 | /* Free linebuf blocks */ | |
97 | for (fp2 = fp->next; fp2; fp2 = fp2->next) | |
98 | if (fp->start == fp2->start) | |
99 | fp2->start = NULL; | |
100 | ||
101 | for (lp = fp->start; lp; lp = lp2) | |
102 | { | |
103 | lp2 = lp->next; | |
104 | gfc_free (lp); | |
105 | } | |
106 | } | |
107 | ||
108 | fp2 = fp->next; | |
109 | gfc_free (fp); | |
110 | } | |
111 | ||
112 | for (fp = first_duplicated_file; fp; fp = fp2) | |
113 | { | |
114 | fp2 = fp->next; | |
115 | gfc_free (fp); | |
116 | } | |
117 | } | |
118 | ||
119 | ||
120 | /* Adds path to the list pointed to by list. */ | |
121 | ||
122 | void | |
123 | gfc_add_include_path (const char *path) | |
124 | { | |
125 | gfc_directorylist *dir; | |
126 | const char *p; | |
127 | ||
128 | p = path; | |
129 | while (*p == ' ' || *p == '\t') /* someone might do 'gfortran "-I include"' */ | |
130 | if (*p++ == '\0') | |
131 | return; | |
132 | ||
133 | dir = include_dirs; | |
134 | if (!dir) | |
135 | { | |
136 | dir = include_dirs = gfc_getmem (sizeof (gfc_directorylist)); | |
137 | } | |
138 | else | |
139 | { | |
140 | while (dir->next) | |
141 | dir = dir->next; | |
142 | ||
143 | dir->next = gfc_getmem (sizeof (gfc_directorylist)); | |
144 | dir = dir->next; | |
145 | } | |
146 | ||
147 | dir->next = NULL; | |
148 | dir->path = gfc_getmem (strlen (p) + 2); | |
149 | strcpy (dir->path, p); | |
150 | strcat (dir->path, "/"); /* make '/' last character */ | |
151 | } | |
152 | ||
153 | ||
154 | /* Release resources allocated for options. */ | |
155 | ||
156 | void | |
157 | gfc_release_include_path (void) | |
158 | { | |
159 | gfc_directorylist *p; | |
160 | ||
161 | gfc_free (gfc_option.module_dir); | |
162 | while (include_dirs != NULL) | |
163 | { | |
164 | p = include_dirs; | |
165 | include_dirs = include_dirs->next; | |
166 | gfc_free (p->path); | |
167 | gfc_free (p); | |
168 | } | |
169 | } | |
170 | ||
171 | ||
172 | /* Opens file for reading, searching through the include directories | |
173 | given if necessary. */ | |
174 | ||
175 | FILE * | |
176 | gfc_open_included_file (const char *name) | |
177 | { | |
178 | char fullname[PATH_MAX]; | |
179 | gfc_directorylist *p; | |
180 | FILE *f; | |
181 | ||
182 | f = gfc_open_file (name); | |
183 | if (f != NULL) | |
184 | return f; | |
185 | ||
186 | for (p = include_dirs; p; p = p->next) | |
187 | { | |
188 | if (strlen (p->path) + strlen (name) + 1 > PATH_MAX) | |
189 | continue; | |
190 | ||
191 | strcpy (fullname, p->path); | |
192 | strcat (fullname, name); | |
193 | ||
194 | f = gfc_open_file (fullname); | |
195 | if (f != NULL) | |
196 | return f; | |
197 | } | |
198 | ||
199 | return NULL; | |
200 | } | |
201 | ||
202 | ||
203 | /* Return a pointer to the current locus. */ | |
204 | ||
205 | locus * | |
206 | gfc_current_locus (void) | |
207 | { | |
208 | ||
209 | if (gfc_current_file == NULL) | |
210 | return NULL; | |
211 | return &gfc_current_file->loc; | |
212 | } | |
213 | ||
214 | ||
215 | /* Let a caller move the current read pointer (backwards). */ | |
216 | ||
217 | void | |
218 | gfc_set_locus (locus * lp) | |
219 | { | |
220 | ||
221 | gfc_current_file->loc = *lp; | |
222 | } | |
223 | ||
224 | ||
225 | /* Test to see if we're at the end of the main source file. */ | |
226 | ||
227 | int | |
228 | gfc_at_end (void) | |
229 | { | |
230 | ||
231 | return end_flag; | |
232 | } | |
233 | ||
234 | ||
235 | /* Test to see if we're at the end of the current file. */ | |
236 | ||
237 | int | |
238 | gfc_at_eof (void) | |
239 | { | |
240 | ||
241 | if (gfc_at_end ()) | |
242 | return 1; | |
243 | ||
244 | if (gfc_current_file->start->lines == 0) | |
245 | return 1; /* Null file */ | |
246 | ||
247 | if (gfc_current_file->loc.lp == NULL) | |
248 | return 1; | |
249 | ||
250 | return 0; | |
251 | } | |
252 | ||
253 | ||
254 | /* Test to see if we're at the beginning of a new line. */ | |
255 | ||
256 | int | |
257 | gfc_at_bol (void) | |
258 | { | |
259 | int i; | |
260 | ||
261 | if (gfc_at_eof ()) | |
262 | return 1; | |
263 | ||
264 | i = gfc_current_file->loc.line; | |
265 | ||
266 | return gfc_current_file->loc.nextc == gfc_current_file->loc.lp->line[i]; | |
267 | } | |
268 | ||
269 | ||
270 | /* Test to see if we're at the end of a line. */ | |
271 | ||
272 | int | |
273 | gfc_at_eol (void) | |
274 | { | |
275 | ||
276 | if (gfc_at_eof ()) | |
277 | return 1; | |
278 | ||
279 | return *gfc_current_file->loc.nextc == '\0'; | |
280 | } | |
281 | ||
282 | ||
283 | /* Advance the current line pointer to the next line. */ | |
284 | ||
285 | void | |
286 | gfc_advance_line (void) | |
287 | { | |
288 | locus *locp; | |
289 | linebuf *lp; | |
290 | ||
291 | if (gfc_at_end ()) | |
292 | return; | |
293 | ||
294 | locp = &gfc_current_file->loc; | |
295 | lp = locp->lp; | |
296 | if (lp == NULL) | |
297 | return; | |
298 | ||
299 | if (++locp->line >= lp->lines) | |
300 | { | |
301 | locp->lp = lp = lp->next; | |
302 | if (lp == NULL) | |
303 | return; /* End of this file */ | |
304 | ||
305 | locp->line = 0; | |
306 | } | |
307 | ||
308 | locp->nextc = lp->line[locp->line]; | |
309 | } | |
310 | ||
311 | ||
312 | /* Get the next character from the input, advancing gfc_current_file's | |
313 | locus. When we hit the end of the line or the end of the file, we | |
314 | start returning a '\n' in order to complete the current statement. | |
315 | No Fortran line conventions are implemented here. | |
316 | ||
317 | Requiring explicit advances to the next line prevents the parse | |
318 | pointer from being on the wrong line if the current statement ends | |
319 | prematurely. */ | |
320 | ||
321 | static int | |
322 | next_char (void) | |
323 | { | |
324 | locus *locp; | |
325 | int c; | |
326 | ||
327 | /* End the current include level, but not if we're in the middle | |
328 | of processing a continuation. */ | |
329 | if (gfc_at_eof ()) | |
330 | { | |
331 | if (continue_flag != 0 || gfc_at_end ()) | |
332 | return '\n'; | |
333 | ||
334 | if (gfc_current_file->included_by == NULL) | |
335 | end_flag = 1; | |
336 | ||
337 | return '\n'; | |
338 | } | |
339 | ||
340 | locp = &gfc_current_file->loc; | |
341 | if (locp->nextc == NULL) | |
342 | return '\n'; | |
343 | ||
344 | c = *locp->nextc++; | |
345 | if (c == '\0') | |
346 | { | |
347 | locp->nextc--; /* Stay stuck on this line */ | |
348 | c = '\n'; | |
349 | } | |
350 | ||
351 | return c; | |
352 | } | |
353 | ||
354 | ||
355 | /* Checks the current line buffer to see if it is an include line. If | |
356 | so, we load the new file and prepare to read from it. Include | |
357 | lines happen at a lower level than regular parsing because the | |
358 | string-matching subroutine is far simpler than the normal one. | |
359 | ||
360 | We never return a syntax error because a statement like "include = 5" | |
361 | is perfectly legal. We return zero if no include was processed or | |
362 | nonzero if we matched an include. */ | |
363 | ||
364 | int | |
365 | gfc_check_include (void) | |
366 | { | |
367 | char c, quote, path[PATH_MAX + 1]; | |
368 | const char *include; | |
369 | locus start; | |
370 | int i; | |
371 | ||
372 | include = "include"; | |
373 | ||
374 | start = *gfc_current_locus (); | |
375 | gfc_gobble_whitespace (); | |
376 | ||
377 | /* Match the 'include' */ | |
378 | while (*include != '\0') | |
379 | if (*include++ != gfc_next_char ()) | |
380 | goto no_include; | |
381 | ||
382 | gfc_gobble_whitespace (); | |
383 | ||
384 | quote = next_char (); | |
385 | if (quote != '"' && quote != '\'') | |
386 | goto no_include; | |
387 | ||
388 | /* Copy the filename */ | |
389 | for (i = 0;;) | |
390 | { | |
391 | c = next_char (); | |
392 | if (c == '\n') | |
393 | goto no_include; /* No close quote */ | |
394 | if (c == quote) | |
395 | break; | |
396 | ||
397 | /* This shouldn't happen-- PATH_MAX should be way longer than the | |
398 | max line length. */ | |
399 | ||
400 | if (i >= PATH_MAX) | |
401 | gfc_internal_error ("Pathname of include file is too long at %C"); | |
402 | ||
403 | path[i++] = c; | |
404 | } | |
405 | ||
406 | path[i] = '\0'; | |
407 | if (i == 0) | |
408 | goto no_include; /* No filename! */ | |
409 | ||
410 | /* At this point, we've got a filename to be included. The rest | |
411 | of the include line is ignored */ | |
412 | ||
413 | gfc_new_file (path, gfc_current_file->form); | |
414 | return 1; | |
415 | ||
416 | no_include: | |
417 | gfc_set_locus (&start); | |
418 | return 0; | |
419 | } | |
420 | ||
421 | ||
422 | /* Skip a comment. When we come here the parse pointer is positioned | |
423 | immediately after the comment character. If we ever implement | |
424 | compiler directives withing comments, here is where we parse the | |
425 | directive. */ | |
426 | ||
427 | static void | |
428 | skip_comment_line (void) | |
429 | { | |
430 | char c; | |
431 | ||
432 | do | |
433 | { | |
434 | c = next_char (); | |
435 | } | |
436 | while (c != '\n'); | |
437 | ||
438 | gfc_advance_line (); | |
439 | } | |
440 | ||
441 | ||
442 | /* Comment lines are null lines, lines containing only blanks or lines | |
443 | on which the first nonblank line is a '!'. */ | |
444 | ||
445 | static void | |
446 | skip_free_comments (void) | |
447 | { | |
448 | locus start; | |
449 | char c; | |
450 | ||
451 | for (;;) | |
452 | { | |
453 | start = *gfc_current_locus (); | |
454 | if (gfc_at_eof ()) | |
455 | break; | |
456 | ||
457 | do | |
458 | { | |
459 | c = next_char (); | |
460 | } | |
461 | while (gfc_is_whitespace (c)); | |
462 | ||
463 | if (c == '\n') | |
464 | { | |
465 | gfc_advance_line (); | |
466 | continue; | |
467 | } | |
468 | ||
469 | if (c == '!') | |
470 | { | |
471 | skip_comment_line (); | |
472 | continue; | |
473 | } | |
474 | ||
475 | break; | |
476 | } | |
477 | ||
478 | gfc_set_locus (&start); | |
479 | } | |
480 | ||
481 | ||
482 | /* Skip comment lines in fixed source mode. We have the same rules as | |
483 | in skip_free_comment(), except that we can have a 'c', 'C' or '*' | |
484 | in column 1. and a '!' cannot be in* column 6. */ | |
485 | ||
486 | static void | |
487 | skip_fixed_comments (void) | |
488 | { | |
489 | locus start; | |
490 | int col; | |
491 | char c; | |
492 | ||
493 | for (;;) | |
494 | { | |
495 | start = *gfc_current_locus (); | |
496 | if (gfc_at_eof ()) | |
497 | break; | |
498 | ||
499 | c = next_char (); | |
500 | if (c == '\n') | |
501 | { | |
502 | gfc_advance_line (); | |
503 | continue; | |
504 | } | |
505 | ||
506 | if (c == '!' || c == 'c' || c == 'C' || c == '*') | |
507 | { | |
508 | skip_comment_line (); | |
509 | continue; | |
510 | } | |
511 | ||
512 | col = 1; | |
513 | do | |
514 | { | |
515 | c = next_char (); | |
516 | col++; | |
517 | } | |
518 | while (gfc_is_whitespace (c)); | |
519 | ||
520 | if (c == '\n') | |
521 | { | |
522 | gfc_advance_line (); | |
523 | continue; | |
524 | } | |
525 | ||
526 | if (col != 6 && c == '!') | |
527 | { | |
528 | skip_comment_line (); | |
529 | continue; | |
530 | } | |
531 | ||
532 | break; | |
533 | } | |
534 | ||
535 | gfc_set_locus (&start); | |
536 | } | |
537 | ||
538 | ||
539 | /* Skips the current line if it is a comment. Assumes that we are at | |
540 | the start of the current line. */ | |
541 | ||
542 | void | |
543 | gfc_skip_comments (void) | |
544 | { | |
545 | ||
546 | if (!gfc_at_bol () || gfc_current_file->form == FORM_FREE) | |
547 | skip_free_comments (); | |
548 | else | |
549 | skip_fixed_comments (); | |
550 | } | |
551 | ||
552 | ||
553 | /* Get the next character from the input, taking continuation lines | |
554 | and end-of-line comments into account. This implies that comment | |
555 | lines between continued lines must be eaten here. For higher-level | |
556 | subroutines, this flattens continued lines into a single logical | |
557 | line. The in_string flag denotes whether we're inside a character | |
558 | context or not. */ | |
559 | ||
560 | int | |
561 | gfc_next_char_literal (int in_string) | |
562 | { | |
563 | locus old_loc; | |
564 | int i, c; | |
565 | ||
566 | continue_flag = 0; | |
567 | ||
568 | restart: | |
569 | c = next_char (); | |
570 | if (gfc_at_end ()) | |
571 | return c; | |
572 | ||
573 | if (gfc_current_file->form == FORM_FREE) | |
574 | { | |
575 | ||
576 | if (!in_string && c == '!') | |
577 | { | |
578 | /* This line can't be continued */ | |
579 | do | |
580 | { | |
581 | c = next_char (); | |
582 | } | |
583 | while (c != '\n'); | |
584 | ||
585 | goto done; | |
586 | } | |
587 | ||
588 | if (c != '&') | |
589 | goto done; | |
590 | ||
591 | /* If the next nonblank character is a ! or \n, we've got a | |
592 | continuation line. */ | |
593 | old_loc = gfc_current_file->loc; | |
594 | ||
595 | c = next_char (); | |
596 | while (gfc_is_whitespace (c)) | |
597 | c = next_char (); | |
598 | ||
599 | /* Character constants to be continued cannot have commentary | |
600 | after the '&'. */ | |
601 | ||
602 | if (in_string && c != '\n') | |
603 | { | |
604 | gfc_set_locus (&old_loc); | |
605 | c = '&'; | |
606 | goto done; | |
607 | } | |
608 | ||
609 | if (c != '!' && c != '\n') | |
610 | { | |
611 | gfc_set_locus (&old_loc); | |
612 | c = '&'; | |
613 | goto done; | |
614 | } | |
615 | ||
616 | continue_flag = 1; | |
617 | if (c == '!') | |
618 | skip_comment_line (); | |
619 | else | |
620 | gfc_advance_line (); | |
621 | ||
622 | /* We've got a continuation line and need to find where it continues. | |
623 | First eat any comment lines. */ | |
624 | gfc_skip_comments (); | |
625 | ||
626 | /* Now that we have a non-comment line, probe ahead for the | |
627 | first non-whitespace character. If it is another '&', then | |
628 | reading starts at the next character, otherwise we must back | |
629 | up to where the whitespace started and resume from there. */ | |
630 | ||
631 | old_loc = *gfc_current_locus (); | |
632 | ||
633 | c = next_char (); | |
634 | while (gfc_is_whitespace (c)) | |
635 | c = next_char (); | |
636 | ||
637 | if (c != '&') | |
638 | gfc_set_locus (&old_loc); | |
639 | ||
640 | } | |
641 | else | |
642 | { | |
643 | /* Fixed form continuation. */ | |
644 | if (!in_string && c == '!') | |
645 | { | |
646 | /* Skip comment at end of line. */ | |
647 | do | |
648 | { | |
649 | c = next_char (); | |
650 | } | |
651 | while (c != '\n'); | |
652 | } | |
653 | ||
654 | if (c != '\n') | |
655 | goto done; | |
656 | ||
657 | continue_flag = 1; | |
658 | old_loc = *gfc_current_locus (); | |
659 | ||
660 | gfc_advance_line (); | |
661 | gfc_skip_comments (); | |
662 | ||
663 | /* See if this line is a continuation line. */ | |
664 | for (i = 0; i < 5; i++) | |
665 | { | |
666 | c = next_char (); | |
667 | if (c != ' ') | |
668 | goto not_continuation; | |
669 | } | |
670 | ||
671 | c = next_char (); | |
672 | if (c == '0' || c == ' ') | |
673 | goto not_continuation; | |
674 | } | |
675 | ||
676 | /* Ready to read first character of continuation line, which might | |
677 | be another continuation line! */ | |
678 | goto restart; | |
679 | ||
680 | not_continuation: | |
681 | c = '\n'; | |
682 | gfc_set_locus (&old_loc); | |
683 | ||
684 | done: | |
685 | continue_flag = 0; | |
686 | return c; | |
687 | } | |
688 | ||
689 | ||
690 | /* Get the next character of input, folded to lowercase. In fixed | |
691 | form mode, we also ignore spaces. When matcher subroutines are | |
692 | parsing character literals, they have to call | |
693 | gfc_next_char_literal(). */ | |
694 | ||
695 | int | |
696 | gfc_next_char (void) | |
697 | { | |
698 | int c; | |
699 | ||
700 | do | |
701 | { | |
702 | c = gfc_next_char_literal (0); | |
703 | } | |
704 | while (gfc_current_file->form == FORM_FIXED && gfc_is_whitespace (c)); | |
705 | ||
706 | return TOLOWER (c); | |
707 | } | |
708 | ||
709 | ||
710 | int | |
711 | gfc_peek_char (void) | |
712 | { | |
713 | locus old_loc; | |
714 | int c; | |
715 | ||
716 | old_loc = *gfc_current_locus (); | |
717 | c = gfc_next_char (); | |
718 | gfc_set_locus (&old_loc); | |
719 | ||
720 | return c; | |
721 | } | |
722 | ||
723 | ||
724 | /* Recover from an error. We try to get past the current statement | |
725 | and get lined up for the next. The next statement follows a '\n' | |
726 | or a ';'. We also assume that we are not within a character | |
727 | constant, and deal with finding a '\'' or '"'. */ | |
728 | ||
729 | void | |
730 | gfc_error_recovery (void) | |
731 | { | |
732 | char c, delim; | |
733 | ||
734 | if (gfc_at_eof ()) | |
735 | return; | |
736 | ||
737 | for (;;) | |
738 | { | |
739 | c = gfc_next_char (); | |
740 | if (c == '\n' || c == ';') | |
741 | break; | |
742 | ||
743 | if (c != '\'' && c != '"') | |
744 | { | |
745 | if (gfc_at_eof ()) | |
746 | break; | |
747 | continue; | |
748 | } | |
749 | delim = c; | |
750 | ||
751 | for (;;) | |
752 | { | |
753 | c = next_char (); | |
754 | ||
755 | if (c == delim) | |
756 | break; | |
757 | if (c == '\n') | |
758 | goto done; | |
759 | if (c == '\\') | |
760 | { | |
761 | c = next_char (); | |
762 | if (c == '\n') | |
763 | goto done; | |
764 | } | |
765 | } | |
766 | if (gfc_at_eof ()) | |
767 | break; | |
768 | } | |
769 | ||
770 | done: | |
771 | if (c == '\n') | |
772 | gfc_advance_line (); | |
773 | } | |
774 | ||
775 | ||
776 | /* Read ahead until the next character to be read is not whitespace. */ | |
777 | ||
778 | void | |
779 | gfc_gobble_whitespace (void) | |
780 | { | |
781 | locus old_loc; | |
782 | int c; | |
783 | ||
784 | do | |
785 | { | |
786 | old_loc = *gfc_current_locus (); | |
787 | c = gfc_next_char_literal (0); | |
788 | } | |
789 | while (gfc_is_whitespace (c)); | |
790 | ||
791 | gfc_set_locus (&old_loc); | |
792 | } | |
793 | ||
794 | ||
795 | /* Load a single line into the buffer. We truncate lines that are too | |
796 | long. In fixed mode, we expand a tab that occurs within the | |
797 | statement label region to expand to spaces that leave the next | |
798 | character in the source region. */ | |
799 | ||
800 | static void | |
801 | load_line (FILE * input, gfc_source_form form, char *buffer, | |
802 | char *filename, int linenum) | |
803 | { | |
804 | int c, maxlen, i, trunc_flag; | |
805 | ||
806 | maxlen = (form == FORM_FREE) ? 132 : gfc_option.fixed_line_length; | |
807 | ||
808 | i = 0; | |
809 | ||
810 | for (;;) | |
811 | { | |
812 | c = fgetc (input); | |
813 | ||
814 | if (c == EOF) | |
815 | break; | |
816 | if (c == '\n') | |
817 | break; | |
818 | ||
819 | if (c == '\r') | |
820 | continue; /* Gobble characters */ | |
821 | if (c == '\0') | |
822 | continue; | |
823 | ||
824 | if (form == FORM_FIXED && c == '\t' && i <= 6) | |
825 | { /* Tab expandsion */ | |
826 | while (i <= 6) | |
827 | { | |
828 | *buffer++ = ' '; | |
829 | i++; | |
830 | } | |
831 | ||
832 | continue; | |
833 | } | |
834 | ||
835 | *buffer++ = c; | |
836 | i++; | |
837 | ||
838 | if (i >= maxlen) | |
839 | { /* Truncate the rest of the line */ | |
840 | trunc_flag = 1; | |
841 | ||
842 | for (;;) | |
843 | { | |
844 | c = fgetc (input); | |
845 | if (c == '\n' || c == EOF) | |
846 | break; | |
847 | ||
848 | if (gfc_option.warn_line_truncation | |
849 | && trunc_flag | |
850 | && !gfc_is_whitespace (c)) | |
851 | { | |
852 | gfc_warning_now ("Line %d of %s is being truncated", | |
853 | linenum, filename); | |
854 | trunc_flag = 0; | |
855 | } | |
856 | } | |
857 | ||
858 | ungetc ('\n', input); | |
859 | } | |
860 | } | |
861 | ||
862 | *buffer = '\0'; | |
863 | } | |
864 | ||
865 | ||
866 | /* Load a file into memory by calling load_line until the file ends. */ | |
867 | ||
868 | static void | |
869 | load_file (FILE * input, gfc_file * fp) | |
870 | { | |
871 | char *linep, line[GFC_MAX_LINE + 1]; | |
872 | int len, linenum; | |
873 | linebuf *lp; | |
874 | ||
875 | fp->start = lp = gfc_getmem (sizeof (linebuf)); | |
876 | ||
877 | linenum = 1; | |
878 | lp->lines = 0; | |
879 | lp->start_line = 1; | |
880 | lp->next = NULL; | |
881 | ||
882 | linep = (char *) (lp + 1); | |
883 | ||
884 | /* Load the file. */ | |
885 | for (;;) | |
886 | { | |
887 | load_line (input, fp->form, line, fp->filename, linenum); | |
888 | linenum++; | |
889 | ||
890 | len = strlen (line); | |
891 | ||
892 | if (feof (input) && len == 0) | |
893 | break; | |
894 | ||
895 | /* See if we need another linebuf. */ | |
896 | if (((char *) &lp->line[lp->lines + 2]) > linep - len - 1) | |
897 | { | |
898 | lp->next = gfc_getmem (sizeof (linebuf)); | |
899 | ||
900 | lp->next->start_line = lp->start_line + lp->lines; | |
901 | lp = lp->next; | |
902 | lp->lines = 0; | |
903 | ||
904 | linep = (char *) (lp + 1); | |
905 | } | |
906 | ||
907 | linep = linep - len - 1; | |
908 | lp->line[lp->lines++] = linep; | |
909 | strcpy (linep, line); | |
910 | } | |
911 | } | |
912 | ||
913 | ||
914 | /* Determine the source form from the filename extension. We assume | |
915 | case insensitivity. */ | |
916 | ||
917 | static gfc_source_form | |
918 | form_from_filename (const char *filename) | |
919 | { | |
920 | ||
921 | static const struct | |
922 | { | |
923 | const char *extension; | |
924 | gfc_source_form form; | |
925 | } | |
926 | exttype[] = | |
927 | { | |
928 | { | |
929 | ".f90", FORM_FREE} | |
930 | , | |
931 | { | |
932 | ".f95", FORM_FREE} | |
933 | , | |
934 | { | |
935 | ".f", FORM_FIXED} | |
936 | , | |
937 | { | |
938 | ".for", FORM_FIXED} | |
939 | , | |
940 | { | |
941 | "", FORM_UNKNOWN} | |
942 | }; /* sentinel value */ | |
943 | ||
944 | gfc_source_form f_form; | |
945 | const char *fileext; | |
946 | int i; | |
947 | ||
948 | /* Find end of file name. */ | |
949 | i = 0; | |
950 | while ((i < PATH_MAX) && (filename[i] != '\0')) | |
951 | i++; | |
952 | ||
953 | /* Improperly terminated or too-long filename. */ | |
954 | if (i == PATH_MAX) | |
955 | return FORM_UNKNOWN; | |
956 | ||
957 | /* Find last period. */ | |
958 | while (i >= 0 && (filename[i] != '.')) | |
959 | i--; | |
960 | ||
961 | /* Did we see a file extension? */ | |
962 | if (i < 0) | |
963 | return FORM_UNKNOWN; /* Nope */ | |
964 | ||
965 | /* Get file extension and compare it to others. */ | |
966 | fileext = &(filename[i]); | |
967 | ||
968 | i = -1; | |
969 | f_form = FORM_UNKNOWN; | |
970 | do | |
971 | { | |
972 | i++; | |
973 | if (strcasecmp (fileext, exttype[i].extension) == 0) | |
974 | { | |
975 | f_form = exttype[i].form; | |
976 | break; | |
977 | } | |
978 | } | |
979 | while (exttype[i].form != FORM_UNKNOWN); | |
980 | ||
981 | return f_form; | |
982 | } | |
983 | ||
984 | ||
985 | /* Open a new file and start scanning from that file. Every new file | |
986 | gets a gfc_file node, even if it is a duplicate file. Returns SUCCESS | |
987 | if everything went OK, FAILURE otherwise. */ | |
988 | ||
989 | try | |
990 | gfc_new_file (const char *filename, gfc_source_form form) | |
991 | { | |
992 | gfc_file *fp, *fp2; | |
993 | FILE *input; | |
994 | int len; | |
995 | ||
996 | len = strlen (filename); | |
997 | if (len > PATH_MAX) | |
998 | { | |
999 | gfc_error_now ("Filename '%s' is too long- ignoring it", filename); | |
1000 | return FAILURE; | |
1001 | } | |
1002 | ||
1003 | fp = gfc_getmem (sizeof (gfc_file)); | |
1004 | ||
1005 | /* Make sure this file isn't being included recursively. */ | |
1006 | for (fp2 = gfc_current_file; fp2; fp2 = fp2->included_by) | |
1007 | if (strcmp (filename, fp2->filename) == 0) | |
1008 | { | |
1009 | gfc_error_now ("Recursive inclusion of file '%s' at %C- ignoring it", | |
1010 | filename); | |
1011 | gfc_free (fp); | |
1012 | return FAILURE; | |
1013 | } | |
1014 | ||
1015 | /* See if the file has already been included. */ | |
1016 | for (fp2 = first_file; fp2; fp2 = fp2->next) | |
1017 | if (strcmp (filename, fp2->filename) == 0) | |
1018 | { | |
1019 | *fp = *fp2; | |
1020 | fp->next = first_duplicated_file; | |
1021 | first_duplicated_file = fp; | |
1022 | goto init_fp; | |
1023 | } | |
1024 | ||
1025 | strcpy (fp->filename, filename); | |
1026 | ||
1027 | if (gfc_current_file == NULL) | |
1028 | input = gfc_open_file (filename); | |
1029 | else | |
1030 | input = gfc_open_included_file (filename); | |
1031 | ||
1032 | if (input == NULL) | |
1033 | { | |
1034 | if (gfc_current_file == NULL) | |
1035 | gfc_error_now ("Can't open file '%s'", filename); | |
1036 | else | |
1037 | gfc_error_now ("Can't open file '%s' included at %C", filename); | |
1038 | ||
1039 | gfc_free (fp); | |
1040 | return FAILURE; | |
1041 | } | |
1042 | ||
1043 | /* Decide which form the file will be read in as. */ | |
1044 | if (form != FORM_UNKNOWN) | |
1045 | fp->form = form; | |
1046 | else | |
1047 | { | |
1048 | fp->form = form_from_filename (filename); | |
1049 | ||
1050 | if (fp->form == FORM_UNKNOWN) | |
1051 | { | |
1052 | fp->form = FORM_FREE; | |
1053 | gfc_warning_now ("Reading file %s as free form", filename); | |
1054 | } | |
1055 | } | |
1056 | ||
1057 | fp->next = first_file; | |
1058 | first_file = fp; | |
1059 | ||
1060 | load_file (input, fp); | |
1061 | fclose (input); | |
1062 | ||
1063 | init_fp: | |
1064 | fp->included_by = gfc_current_file; | |
1065 | gfc_current_file = fp; | |
1066 | ||
1067 | fp->loc.line = 0; | |
1068 | fp->loc.lp = fp->start; | |
1069 | fp->loc.nextc = fp->start->line[0]; | |
1070 | fp->loc.file = fp; | |
1071 | ||
1072 | return SUCCESS; | |
1073 | } |