1 /* Character scanner.
2 Copyright (C) 2000-2013 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 3, 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 COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
20
21 /* Set of subroutines to (ultimately) return the next character to the
22 various matching subroutines. This file's job is to read files and
23 build up lines that are parsed by the parser. This means that we
24 handle continuation lines and "include" lines.
25
26 The first thing the scanner does is to load an entire file into
27 memory. We load the entire file into memory for a couple reasons.
28 The first is that we want to be able to deal with nonseekable input
29 (pipes, stdin) and there is a lot of backing up involved during
30 parsing.
31
32 The second is that we want to be able to print the locus of errors,
33 and an error on line 999999 could conflict with something on line
34 one. Given nonseekable input, we've got to store the whole thing.
35
36 One thing that helps are the column truncation limits that give us
37 an upper bound on the size of individual lines. We don't store the
38 truncated stuff.
39
40 From the scanner's viewpoint, the higher level subroutines ask for
41 new characters and do a lot of jumping backwards. */
42
43 #include "config.h"
44 #include "system.h"
45 #include "coretypes.h"
46 #include "gfortran.h"
47 #include "toplev.h" /* For set_src_pwd. */
48 #include "debug.h"
49 #include "flags.h"
50 #include "cpp.h"
51
52 /* Structure for holding module and include file search path. */
53 typedef struct gfc_directorylist
54 {
55 char *path;
56 bool use_for_modules;
57 struct gfc_directorylist *next;
58 }
59 gfc_directorylist;
60
61 /* List of include file search directories. */
62 static gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
63
64 static gfc_file *file_head, *current_file;
65
66 static int continue_flag, end_flag, openmp_flag, gcc_attribute_flag;
67 static int continue_count, continue_line;
68 static locus openmp_locus;
69 static locus gcc_attribute_locus;
70
71 gfc_source_form gfc_current_form;
72 static gfc_linebuf *line_head, *line_tail;
73
74 locus gfc_current_locus;
75 const char *gfc_source_file;
76 static FILE *gfc_src_file;
77 static gfc_char_t *gfc_src_preprocessor_lines[2];
78
79 static struct gfc_file_change
80 {
81 const char *filename;
82 gfc_linebuf *lb;
83 int line;
84 } *file_changes;
85 size_t file_changes_cur, file_changes_count;
86 size_t file_changes_allocated;
87
88
89 /* Functions dealing with our wide characters (gfc_char_t) and
90 sequences of such characters. */
91
92 int
gfc_wide_fits_in_byte(gfc_char_t c)93 gfc_wide_fits_in_byte (gfc_char_t c)
94 {
95 return (c <= UCHAR_MAX);
96 }
97
98 static inline int
wide_is_ascii(gfc_char_t c)99 wide_is_ascii (gfc_char_t c)
100 {
101 return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0);
102 }
103
104 int
gfc_wide_is_printable(gfc_char_t c)105 gfc_wide_is_printable (gfc_char_t c)
106 {
107 return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c));
108 }
109
110 gfc_char_t
gfc_wide_tolower(gfc_char_t c)111 gfc_wide_tolower (gfc_char_t c)
112 {
113 return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
114 }
115
116 gfc_char_t
gfc_wide_toupper(gfc_char_t c)117 gfc_wide_toupper (gfc_char_t c)
118 {
119 return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c);
120 }
121
122 int
gfc_wide_is_digit(gfc_char_t c)123 gfc_wide_is_digit (gfc_char_t c)
124 {
125 return (c >= '0' && c <= '9');
126 }
127
128 static inline int
wide_atoi(gfc_char_t * c)129 wide_atoi (gfc_char_t *c)
130 {
131 #define MAX_DIGITS 20
132 char buf[MAX_DIGITS+1];
133 int i = 0;
134
135 while (gfc_wide_is_digit(*c) && i < MAX_DIGITS)
136 buf[i++] = *c++;
137 buf[i] = '\0';
138 return atoi (buf);
139 }
140
141 size_t
gfc_wide_strlen(const gfc_char_t * str)142 gfc_wide_strlen (const gfc_char_t *str)
143 {
144 size_t i;
145
146 for (i = 0; str[i]; i++)
147 ;
148
149 return i;
150 }
151
152 gfc_char_t *
gfc_wide_memset(gfc_char_t * b,gfc_char_t c,size_t len)153 gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len)
154 {
155 size_t i;
156
157 for (i = 0; i < len; i++)
158 b[i] = c;
159
160 return b;
161 }
162
163 static gfc_char_t *
wide_strcpy(gfc_char_t * dest,const gfc_char_t * src)164 wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
165 {
166 gfc_char_t *d;
167
168 for (d = dest; (*d = *src) != '\0'; ++src, ++d)
169 ;
170
171 return dest;
172 }
173
174 static gfc_char_t *
wide_strchr(const gfc_char_t * s,gfc_char_t c)175 wide_strchr (const gfc_char_t *s, gfc_char_t c)
176 {
177 do {
178 if (*s == c)
179 {
180 return CONST_CAST(gfc_char_t *, s);
181 }
182 } while (*s++);
183 return 0;
184 }
185
186 char *
gfc_widechar_to_char(const gfc_char_t * s,int length)187 gfc_widechar_to_char (const gfc_char_t *s, int length)
188 {
189 size_t len, i;
190 char *res;
191
192 if (s == NULL)
193 return NULL;
194
195 /* Passing a negative length is used to indicate that length should be
196 calculated using gfc_wide_strlen(). */
197 len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s));
198 res = XNEWVEC (char, len + 1);
199
200 for (i = 0; i < len; i++)
201 {
202 gcc_assert (gfc_wide_fits_in_byte (s[i]));
203 res[i] = (unsigned char) s[i];
204 }
205
206 res[len] = '\0';
207 return res;
208 }
209
210 gfc_char_t *
gfc_char_to_widechar(const char * s)211 gfc_char_to_widechar (const char *s)
212 {
213 size_t len, i;
214 gfc_char_t *res;
215
216 if (s == NULL)
217 return NULL;
218
219 len = strlen (s);
220 res = gfc_get_wide_string (len + 1);
221
222 for (i = 0; i < len; i++)
223 res[i] = (unsigned char) s[i];
224
225 res[len] = '\0';
226 return res;
227 }
228
229 static int
wide_strncmp(const gfc_char_t * s1,const char * s2,size_t n)230 wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n)
231 {
232 gfc_char_t c1, c2;
233
234 while (n-- > 0)
235 {
236 c1 = *s1++;
237 c2 = *s2++;
238 if (c1 != c2)
239 return (c1 > c2 ? 1 : -1);
240 if (c1 == '\0')
241 return 0;
242 }
243 return 0;
244 }
245
246 int
gfc_wide_strncasecmp(const gfc_char_t * s1,const char * s2,size_t n)247 gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
248 {
249 gfc_char_t c1, c2;
250
251 while (n-- > 0)
252 {
253 c1 = gfc_wide_tolower (*s1++);
254 c2 = TOLOWER (*s2++);
255 if (c1 != c2)
256 return (c1 > c2 ? 1 : -1);
257 if (c1 == '\0')
258 return 0;
259 }
260 return 0;
261 }
262
263
264 /* Main scanner initialization. */
265
266 void
gfc_scanner_init_1(void)267 gfc_scanner_init_1 (void)
268 {
269 file_head = NULL;
270 line_head = NULL;
271 line_tail = NULL;
272
273 continue_count = 0;
274 continue_line = 0;
275
276 end_flag = 0;
277 }
278
279
280 /* Main scanner destructor. */
281
282 void
gfc_scanner_done_1(void)283 gfc_scanner_done_1 (void)
284 {
285 gfc_linebuf *lb;
286 gfc_file *f;
287
288 while(line_head != NULL)
289 {
290 lb = line_head->next;
291 free (line_head);
292 line_head = lb;
293 }
294
295 while(file_head != NULL)
296 {
297 f = file_head->next;
298 free (file_head->filename);
299 free (file_head);
300 file_head = f;
301 }
302 }
303
304
305 /* Adds path to the list pointed to by list. */
306
307 static void
add_path_to_list(gfc_directorylist ** list,const char * path,bool use_for_modules,bool head,bool warn)308 add_path_to_list (gfc_directorylist **list, const char *path,
309 bool use_for_modules, bool head, bool warn)
310 {
311 gfc_directorylist *dir;
312 const char *p;
313 char *q;
314 struct stat st;
315 size_t len;
316 int i;
317
318 p = path;
319 while (*p == ' ' || *p == '\t') /* someone might do "-I include" */
320 if (*p++ == '\0')
321 return;
322
323 /* Strip trailing directory separators from the path, as this
324 will confuse Windows systems. */
325 len = strlen (p);
326 q = (char *) alloca (len + 1);
327 memcpy (q, p, len + 1);
328 i = len - 1;
329 while (i >=0 && IS_DIR_SEPARATOR(q[i]))
330 q[i--] = '\0';
331
332 if (stat (q, &st))
333 {
334 if (errno != ENOENT)
335 gfc_warning_now ("Include directory \"%s\": %s", path,
336 xstrerror(errno));
337 else
338 {
339 /* FIXME: Also support -Wmissing-include-dirs. */
340 if (warn)
341 gfc_warning_now ("Nonexistent include directory \"%s\"", path);
342 }
343 return;
344 }
345 else if (!S_ISDIR (st.st_mode))
346 {
347 gfc_warning_now ("\"%s\" is not a directory", path);
348 return;
349 }
350
351 if (head || *list == NULL)
352 {
353 dir = XCNEW (gfc_directorylist);
354 if (!head)
355 *list = dir;
356 }
357 else
358 {
359 dir = *list;
360 while (dir->next)
361 dir = dir->next;
362
363 dir->next = XCNEW (gfc_directorylist);
364 dir = dir->next;
365 }
366
367 dir->next = head ? *list : NULL;
368 if (head)
369 *list = dir;
370 dir->use_for_modules = use_for_modules;
371 dir->path = XCNEWVEC (char, strlen (p) + 2);
372 strcpy (dir->path, p);
373 strcat (dir->path, "/"); /* make '/' last character */
374 }
375
376
377 void
gfc_add_include_path(const char * path,bool use_for_modules,bool file_dir,bool warn)378 gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir,
379 bool warn)
380 {
381 add_path_to_list (&include_dirs, path, use_for_modules, file_dir, warn);
382
383 /* For '#include "..."' these directories are automatically searched. */
384 if (!file_dir)
385 gfc_cpp_add_include_path (xstrdup(path), true);
386 }
387
388
389 void
gfc_add_intrinsic_modules_path(const char * path)390 gfc_add_intrinsic_modules_path (const char *path)
391 {
392 add_path_to_list (&intrinsic_modules_dirs, path, true, false, false);
393 }
394
395
396 /* Release resources allocated for options. */
397
398 void
gfc_release_include_path(void)399 gfc_release_include_path (void)
400 {
401 gfc_directorylist *p;
402
403 while (include_dirs != NULL)
404 {
405 p = include_dirs;
406 include_dirs = include_dirs->next;
407 free (p->path);
408 free (p);
409 }
410
411 while (intrinsic_modules_dirs != NULL)
412 {
413 p = intrinsic_modules_dirs;
414 intrinsic_modules_dirs = intrinsic_modules_dirs->next;
415 free (p->path);
416 free (p);
417 }
418
419 free (gfc_option.module_dir);
420 }
421
422
423 static FILE *
open_included_file(const char * name,gfc_directorylist * list,bool module,bool system)424 open_included_file (const char *name, gfc_directorylist *list,
425 bool module, bool system)
426 {
427 char *fullname;
428 gfc_directorylist *p;
429 FILE *f;
430
431 for (p = list; p; p = p->next)
432 {
433 if (module && !p->use_for_modules)
434 continue;
435
436 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
437 strcpy (fullname, p->path);
438 strcat (fullname, name);
439
440 f = gfc_open_file (fullname);
441 if (f != NULL)
442 {
443 if (gfc_cpp_makedep ())
444 gfc_cpp_add_dep (fullname, system);
445
446 return f;
447 }
448 }
449
450 return NULL;
451 }
452
453
454 /* Opens file for reading, searching through the include directories
455 given if necessary. If the include_cwd argument is true, we try
456 to open the file in the current directory first. */
457
458 FILE *
gfc_open_included_file(const char * name,bool include_cwd,bool module)459 gfc_open_included_file (const char *name, bool include_cwd, bool module)
460 {
461 FILE *f = NULL;
462
463 if (IS_ABSOLUTE_PATH (name) || include_cwd)
464 {
465 f = gfc_open_file (name);
466 if (f && gfc_cpp_makedep ())
467 gfc_cpp_add_dep (name, false);
468 }
469
470 if (!f)
471 f = open_included_file (name, include_dirs, module, false);
472
473 return f;
474 }
475
476 FILE *
gfc_open_intrinsic_module(const char * name)477 gfc_open_intrinsic_module (const char *name)
478 {
479 FILE *f = NULL;
480
481 if (IS_ABSOLUTE_PATH (name))
482 {
483 f = gfc_open_file (name);
484 if (f && gfc_cpp_makedep ())
485 gfc_cpp_add_dep (name, true);
486 }
487
488 if (!f)
489 f = open_included_file (name, intrinsic_modules_dirs, true, true);
490
491 return f;
492 }
493
494
495 /* Test to see if we're at the end of the main source file. */
496
497 int
gfc_at_end(void)498 gfc_at_end (void)
499 {
500 return end_flag;
501 }
502
503
504 /* Test to see if we're at the end of the current file. */
505
506 int
gfc_at_eof(void)507 gfc_at_eof (void)
508 {
509 if (gfc_at_end ())
510 return 1;
511
512 if (line_head == NULL)
513 return 1; /* Null file */
514
515 if (gfc_current_locus.lb == NULL)
516 return 1;
517
518 return 0;
519 }
520
521
522 /* Test to see if we're at the beginning of a new line. */
523
524 int
gfc_at_bol(void)525 gfc_at_bol (void)
526 {
527 if (gfc_at_eof ())
528 return 1;
529
530 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
531 }
532
533
534 /* Test to see if we're at the end of a line. */
535
536 int
gfc_at_eol(void)537 gfc_at_eol (void)
538 {
539 if (gfc_at_eof ())
540 return 1;
541
542 return (*gfc_current_locus.nextc == '\0');
543 }
544
545 static void
add_file_change(const char * filename,int line)546 add_file_change (const char *filename, int line)
547 {
548 if (file_changes_count == file_changes_allocated)
549 {
550 if (file_changes_allocated)
551 file_changes_allocated *= 2;
552 else
553 file_changes_allocated = 16;
554 file_changes = XRESIZEVEC (struct gfc_file_change, file_changes,
555 file_changes_allocated);
556 }
557 file_changes[file_changes_count].filename = filename;
558 file_changes[file_changes_count].lb = NULL;
559 file_changes[file_changes_count++].line = line;
560 }
561
562 static void
report_file_change(gfc_linebuf * lb)563 report_file_change (gfc_linebuf *lb)
564 {
565 size_t c = file_changes_cur;
566 while (c < file_changes_count
567 && file_changes[c].lb == lb)
568 {
569 if (file_changes[c].filename)
570 (*debug_hooks->start_source_file) (file_changes[c].line,
571 file_changes[c].filename);
572 else
573 (*debug_hooks->end_source_file) (file_changes[c].line);
574 ++c;
575 }
576 file_changes_cur = c;
577 }
578
579 void
gfc_start_source_files(void)580 gfc_start_source_files (void)
581 {
582 /* If the debugger wants the name of the main source file,
583 we give it. */
584 if (debug_hooks->start_end_main_source_file)
585 (*debug_hooks->start_source_file) (0, gfc_source_file);
586
587 file_changes_cur = 0;
588 report_file_change (gfc_current_locus.lb);
589 }
590
591 void
gfc_end_source_files(void)592 gfc_end_source_files (void)
593 {
594 report_file_change (NULL);
595
596 if (debug_hooks->start_end_main_source_file)
597 (*debug_hooks->end_source_file) (0);
598 }
599
600 /* Advance the current line pointer to the next line. */
601
602 void
gfc_advance_line(void)603 gfc_advance_line (void)
604 {
605 if (gfc_at_end ())
606 return;
607
608 if (gfc_current_locus.lb == NULL)
609 {
610 end_flag = 1;
611 return;
612 }
613
614 if (gfc_current_locus.lb->next
615 && !gfc_current_locus.lb->next->dbg_emitted)
616 {
617 report_file_change (gfc_current_locus.lb->next);
618 gfc_current_locus.lb->next->dbg_emitted = true;
619 }
620
621 gfc_current_locus.lb = gfc_current_locus.lb->next;
622
623 if (gfc_current_locus.lb != NULL)
624 gfc_current_locus.nextc = gfc_current_locus.lb->line;
625 else
626 {
627 gfc_current_locus.nextc = NULL;
628 end_flag = 1;
629 }
630 }
631
632
633 /* Get the next character from the input, advancing gfc_current_file's
634 locus. When we hit the end of the line or the end of the file, we
635 start returning a '\n' in order to complete the current statement.
636 No Fortran line conventions are implemented here.
637
638 Requiring explicit advances to the next line prevents the parse
639 pointer from being on the wrong line if the current statement ends
640 prematurely. */
641
642 static gfc_char_t
next_char(void)643 next_char (void)
644 {
645 gfc_char_t c;
646
647 if (gfc_current_locus.nextc == NULL)
648 return '\n';
649
650 c = *gfc_current_locus.nextc++;
651 if (c == '\0')
652 {
653 gfc_current_locus.nextc--; /* Remain on this line. */
654 c = '\n';
655 }
656
657 return c;
658 }
659
660
661 /* Skip a comment. When we come here the parse pointer is positioned
662 immediately after the comment character. If we ever implement
663 compiler directives within comments, here is where we parse the
664 directive. */
665
666 static void
skip_comment_line(void)667 skip_comment_line (void)
668 {
669 gfc_char_t c;
670
671 do
672 {
673 c = next_char ();
674 }
675 while (c != '\n');
676
677 gfc_advance_line ();
678 }
679
680
681 int
gfc_define_undef_line(void)682 gfc_define_undef_line (void)
683 {
684 char *tmp;
685
686 /* All lines beginning with '#' are either #define or #undef. */
687 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
688 return 0;
689
690 if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
691 {
692 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
693 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
694 tmp);
695 free (tmp);
696 }
697
698 if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
699 {
700 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
701 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
702 tmp);
703 free (tmp);
704 }
705
706 /* Skip the rest of the line. */
707 skip_comment_line ();
708
709 return 1;
710 }
711
712
713 /* Return true if GCC$ was matched. */
714 static bool
skip_gcc_attribute(locus start)715 skip_gcc_attribute (locus start)
716 {
717 bool r = false;
718 char c;
719 locus old_loc = gfc_current_locus;
720
721 if ((c = next_char ()) == 'g' || c == 'G')
722 if ((c = next_char ()) == 'c' || c == 'C')
723 if ((c = next_char ()) == 'c' || c == 'C')
724 if ((c = next_char ()) == '$')
725 r = true;
726
727 if (r == false)
728 gfc_current_locus = old_loc;
729 else
730 {
731 gcc_attribute_flag = 1;
732 gcc_attribute_locus = old_loc;
733 gfc_current_locus = start;
734 }
735
736 return r;
737 }
738
739
740
741 /* Comment lines are null lines, lines containing only blanks or lines
742 on which the first nonblank line is a '!'.
743 Return true if !$ openmp conditional compilation sentinel was
744 seen. */
745
746 static bool
skip_free_comments(void)747 skip_free_comments (void)
748 {
749 locus start;
750 gfc_char_t c;
751 int at_bol;
752
753 for (;;)
754 {
755 at_bol = gfc_at_bol ();
756 start = gfc_current_locus;
757 if (gfc_at_eof ())
758 break;
759
760 do
761 c = next_char ();
762 while (gfc_is_whitespace (c));
763
764 if (c == '\n')
765 {
766 gfc_advance_line ();
767 continue;
768 }
769
770 if (c == '!')
771 {
772 /* Keep the !GCC$ line. */
773 if (at_bol && skip_gcc_attribute (start))
774 return false;
775
776 /* If -fopenmp, we need to handle here 2 things:
777 1) don't treat !$omp as comments, but directives
778 2) handle OpenMP conditional compilation, where
779 !$ should be treated as 2 spaces (for initial lines
780 only if followed by space). */
781 if (gfc_option.gfc_flag_openmp && at_bol)
782 {
783 locus old_loc = gfc_current_locus;
784 if (next_char () == '$')
785 {
786 c = next_char ();
787 if (c == 'o' || c == 'O')
788 {
789 if (((c = next_char ()) == 'm' || c == 'M')
790 && ((c = next_char ()) == 'p' || c == 'P'))
791 {
792 if ((c = next_char ()) == ' ' || c == '\t'
793 || continue_flag)
794 {
795 while (gfc_is_whitespace (c))
796 c = next_char ();
797 if (c != '\n' && c != '!')
798 {
799 openmp_flag = 1;
800 openmp_locus = old_loc;
801 gfc_current_locus = start;
802 return false;
803 }
804 }
805 else
806 gfc_warning_now ("!$OMP at %C starts a commented "
807 "line as it neither is followed "
808 "by a space nor is a "
809 "continuation line");
810 }
811 gfc_current_locus = old_loc;
812 next_char ();
813 c = next_char ();
814 }
815 if (continue_flag || c == ' ' || c == '\t')
816 {
817 gfc_current_locus = old_loc;
818 next_char ();
819 openmp_flag = 0;
820 return true;
821 }
822 }
823 gfc_current_locus = old_loc;
824 }
825 skip_comment_line ();
826 continue;
827 }
828
829 break;
830 }
831
832 if (openmp_flag && at_bol)
833 openmp_flag = 0;
834
835 gcc_attribute_flag = 0;
836 gfc_current_locus = start;
837 return false;
838 }
839
840
841 /* Skip comment lines in fixed source mode. We have the same rules as
842 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
843 in column 1, and a '!' cannot be in column 6. Also, we deal with
844 lines with 'd' or 'D' in column 1, if the user requested this. */
845
846 static void
skip_fixed_comments(void)847 skip_fixed_comments (void)
848 {
849 locus start;
850 int col;
851 gfc_char_t c;
852
853 if (! gfc_at_bol ())
854 {
855 start = gfc_current_locus;
856 if (! gfc_at_eof ())
857 {
858 do
859 c = next_char ();
860 while (gfc_is_whitespace (c));
861
862 if (c == '\n')
863 gfc_advance_line ();
864 else if (c == '!')
865 skip_comment_line ();
866 }
867
868 if (! gfc_at_bol ())
869 {
870 gfc_current_locus = start;
871 return;
872 }
873 }
874
875 for (;;)
876 {
877 start = gfc_current_locus;
878 if (gfc_at_eof ())
879 break;
880
881 c = next_char ();
882 if (c == '\n')
883 {
884 gfc_advance_line ();
885 continue;
886 }
887
888 if (c == '!' || c == 'c' || c == 'C' || c == '*')
889 {
890 if (skip_gcc_attribute (start))
891 {
892 /* Canonicalize to *$omp. */
893 *start.nextc = '*';
894 return;
895 }
896
897 /* If -fopenmp, we need to handle here 2 things:
898 1) don't treat !$omp|c$omp|*$omp as comments, but directives
899 2) handle OpenMP conditional compilation, where
900 !$|c$|*$ should be treated as 2 spaces if the characters
901 in columns 3 to 6 are valid fixed form label columns
902 characters. */
903 if (gfc_current_locus.lb != NULL
904 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
905 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
906
907 if (gfc_option.gfc_flag_openmp)
908 {
909 if (next_char () == '$')
910 {
911 c = next_char ();
912 if (c == 'o' || c == 'O')
913 {
914 if (((c = next_char ()) == 'm' || c == 'M')
915 && ((c = next_char ()) == 'p' || c == 'P'))
916 {
917 c = next_char ();
918 if (c != '\n'
919 && ((openmp_flag && continue_flag)
920 || c == ' ' || c == '\t' || c == '0'))
921 {
922 do
923 c = next_char ();
924 while (gfc_is_whitespace (c));
925 if (c != '\n' && c != '!')
926 {
927 /* Canonicalize to *$omp. */
928 *start.nextc = '*';
929 openmp_flag = 1;
930 gfc_current_locus = start;
931 return;
932 }
933 }
934 }
935 }
936 else
937 {
938 int digit_seen = 0;
939
940 for (col = 3; col < 6; col++, c = next_char ())
941 if (c == ' ')
942 continue;
943 else if (c == '\t')
944 {
945 col = 6;
946 break;
947 }
948 else if (c < '0' || c > '9')
949 break;
950 else
951 digit_seen = 1;
952
953 if (col == 6 && c != '\n'
954 && ((continue_flag && !digit_seen)
955 || c == ' ' || c == '\t' || c == '0'))
956 {
957 gfc_current_locus = start;
958 start.nextc[0] = ' ';
959 start.nextc[1] = ' ';
960 continue;
961 }
962 }
963 }
964 gfc_current_locus = start;
965 }
966 skip_comment_line ();
967 continue;
968 }
969
970 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
971 {
972 if (gfc_option.flag_d_lines == 0)
973 {
974 skip_comment_line ();
975 continue;
976 }
977 else
978 *start.nextc = c = ' ';
979 }
980
981 col = 1;
982
983 while (gfc_is_whitespace (c))
984 {
985 c = next_char ();
986 col++;
987 }
988
989 if (c == '\n')
990 {
991 gfc_advance_line ();
992 continue;
993 }
994
995 if (col != 6 && c == '!')
996 {
997 if (gfc_current_locus.lb != NULL
998 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
999 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1000 skip_comment_line ();
1001 continue;
1002 }
1003
1004 break;
1005 }
1006
1007 openmp_flag = 0;
1008 gcc_attribute_flag = 0;
1009 gfc_current_locus = start;
1010 }
1011
1012
1013 /* Skips the current line if it is a comment. */
1014
1015 void
gfc_skip_comments(void)1016 gfc_skip_comments (void)
1017 {
1018 if (gfc_current_form == FORM_FREE)
1019 skip_free_comments ();
1020 else
1021 skip_fixed_comments ();
1022 }
1023
1024
1025 /* Get the next character from the input, taking continuation lines
1026 and end-of-line comments into account. This implies that comment
1027 lines between continued lines must be eaten here. For higher-level
1028 subroutines, this flattens continued lines into a single logical
1029 line. The in_string flag denotes whether we're inside a character
1030 context or not. */
1031
1032 gfc_char_t
gfc_next_char_literal(gfc_instring in_string)1033 gfc_next_char_literal (gfc_instring in_string)
1034 {
1035 locus old_loc;
1036 int i, prev_openmp_flag;
1037 gfc_char_t c;
1038
1039 continue_flag = 0;
1040
1041 restart:
1042 c = next_char ();
1043 if (gfc_at_end ())
1044 {
1045 continue_count = 0;
1046 return c;
1047 }
1048
1049 if (gfc_current_form == FORM_FREE)
1050 {
1051 bool openmp_cond_flag;
1052
1053 if (!in_string && c == '!')
1054 {
1055 if (gcc_attribute_flag
1056 && memcmp (&gfc_current_locus, &gcc_attribute_locus,
1057 sizeof (gfc_current_locus)) == 0)
1058 goto done;
1059
1060 if (openmp_flag
1061 && memcmp (&gfc_current_locus, &openmp_locus,
1062 sizeof (gfc_current_locus)) == 0)
1063 goto done;
1064
1065 /* This line can't be continued */
1066 do
1067 {
1068 c = next_char ();
1069 }
1070 while (c != '\n');
1071
1072 /* Avoid truncation warnings for comment ending lines. */
1073 gfc_current_locus.lb->truncated = 0;
1074
1075 goto done;
1076 }
1077
1078 /* Check to see if the continuation line was truncated. */
1079 if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
1080 && gfc_current_locus.lb->truncated)
1081 {
1082 int maxlen = gfc_option.free_line_length;
1083 gfc_char_t *current_nextc = gfc_current_locus.nextc;
1084
1085 gfc_current_locus.lb->truncated = 0;
1086 gfc_current_locus.nextc = gfc_current_locus.lb->line + maxlen;
1087 gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
1088 gfc_current_locus.nextc = current_nextc;
1089 }
1090
1091 if (c != '&')
1092 goto done;
1093
1094 /* If the next nonblank character is a ! or \n, we've got a
1095 continuation line. */
1096 old_loc = gfc_current_locus;
1097
1098 c = next_char ();
1099 while (gfc_is_whitespace (c))
1100 c = next_char ();
1101
1102 /* Character constants to be continued cannot have commentary
1103 after the '&'. */
1104
1105 if (in_string && c != '\n')
1106 {
1107 gfc_current_locus = old_loc;
1108 c = '&';
1109 goto done;
1110 }
1111
1112 if (c != '!' && c != '\n')
1113 {
1114 gfc_current_locus = old_loc;
1115 c = '&';
1116 goto done;
1117 }
1118
1119 prev_openmp_flag = openmp_flag;
1120 continue_flag = 1;
1121 if (c == '!')
1122 skip_comment_line ();
1123 else
1124 gfc_advance_line ();
1125
1126 if (gfc_at_eof())
1127 goto not_continuation;
1128
1129 /* We've got a continuation line. If we are on the very next line after
1130 the last continuation, increment the continuation line count and
1131 check whether the limit has been exceeded. */
1132 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1133 {
1134 if (++continue_count == gfc_option.max_continue_free)
1135 {
1136 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1137 gfc_warning ("Limit of %d continuations exceeded in "
1138 "statement at %C", gfc_option.max_continue_free);
1139 }
1140 }
1141
1142 /* Now find where it continues. First eat any comment lines. */
1143 openmp_cond_flag = skip_free_comments ();
1144
1145 if (gfc_current_locus.lb != NULL
1146 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1147 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1148
1149 if (prev_openmp_flag != openmp_flag)
1150 {
1151 gfc_current_locus = old_loc;
1152 openmp_flag = prev_openmp_flag;
1153 c = '&';
1154 goto done;
1155 }
1156
1157 /* Now that we have a non-comment line, probe ahead for the
1158 first non-whitespace character. If it is another '&', then
1159 reading starts at the next character, otherwise we must back
1160 up to where the whitespace started and resume from there. */
1161
1162 old_loc = gfc_current_locus;
1163
1164 c = next_char ();
1165 while (gfc_is_whitespace (c))
1166 c = next_char ();
1167
1168 if (openmp_flag)
1169 {
1170 for (i = 0; i < 5; i++, c = next_char ())
1171 {
1172 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1173 if (i == 4)
1174 old_loc = gfc_current_locus;
1175 }
1176 while (gfc_is_whitespace (c))
1177 c = next_char ();
1178 }
1179
1180 if (c != '&')
1181 {
1182 if (in_string)
1183 {
1184 gfc_current_locus.nextc--;
1185 if (gfc_option.warn_ampersand && in_string == INSTRING_WARN)
1186 gfc_warning ("Missing '&' in continued character "
1187 "constant at %C");
1188 }
1189 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1190 continuation line only optionally. */
1191 else if (openmp_flag || openmp_cond_flag)
1192 gfc_current_locus.nextc--;
1193 else
1194 {
1195 c = ' ';
1196 gfc_current_locus = old_loc;
1197 goto done;
1198 }
1199 }
1200 }
1201 else /* Fixed form. */
1202 {
1203 /* Fixed form continuation. */
1204 if (!in_string && c == '!')
1205 {
1206 /* Skip comment at end of line. */
1207 do
1208 {
1209 c = next_char ();
1210 }
1211 while (c != '\n');
1212
1213 /* Avoid truncation warnings for comment ending lines. */
1214 gfc_current_locus.lb->truncated = 0;
1215 }
1216
1217 if (c != '\n')
1218 goto done;
1219
1220 /* Check to see if the continuation line was truncated. */
1221 if (gfc_option.warn_line_truncation && gfc_current_locus.lb != NULL
1222 && gfc_current_locus.lb->truncated)
1223 {
1224 gfc_current_locus.lb->truncated = 0;
1225 gfc_warning_now ("Line truncated at %L", &gfc_current_locus);
1226 }
1227
1228 prev_openmp_flag = openmp_flag;
1229 continue_flag = 1;
1230 old_loc = gfc_current_locus;
1231
1232 gfc_advance_line ();
1233 skip_fixed_comments ();
1234
1235 /* See if this line is a continuation line. */
1236 if (openmp_flag != prev_openmp_flag)
1237 {
1238 openmp_flag = prev_openmp_flag;
1239 goto not_continuation;
1240 }
1241
1242 if (!openmp_flag)
1243 for (i = 0; i < 5; i++)
1244 {
1245 c = next_char ();
1246 if (c != ' ')
1247 goto not_continuation;
1248 }
1249 else
1250 for (i = 0; i < 5; i++)
1251 {
1252 c = next_char ();
1253 if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1254 goto not_continuation;
1255 }
1256
1257 c = next_char ();
1258 if (c == '0' || c == ' ' || c == '\n')
1259 goto not_continuation;
1260
1261 /* We've got a continuation line. If we are on the very next line after
1262 the last continuation, increment the continuation line count and
1263 check whether the limit has been exceeded. */
1264 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1265 {
1266 if (++continue_count == gfc_option.max_continue_fixed)
1267 {
1268 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1269 gfc_warning ("Limit of %d continuations exceeded in "
1270 "statement at %C",
1271 gfc_option.max_continue_fixed);
1272 }
1273 }
1274
1275 if (gfc_current_locus.lb != NULL
1276 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1277 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1278 }
1279
1280 /* Ready to read first character of continuation line, which might
1281 be another continuation line! */
1282 goto restart;
1283
1284 not_continuation:
1285 c = '\n';
1286 gfc_current_locus = old_loc;
1287
1288 done:
1289 if (c == '\n')
1290 continue_count = 0;
1291 continue_flag = 0;
1292 return c;
1293 }
1294
1295
1296 /* Get the next character of input, folded to lowercase. In fixed
1297 form mode, we also ignore spaces. When matcher subroutines are
1298 parsing character literals, they have to call
1299 gfc_next_char_literal(). */
1300
1301 gfc_char_t
gfc_next_char(void)1302 gfc_next_char (void)
1303 {
1304 gfc_char_t c;
1305
1306 do
1307 {
1308 c = gfc_next_char_literal (NONSTRING);
1309 }
1310 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1311
1312 return gfc_wide_tolower (c);
1313 }
1314
1315 char
gfc_next_ascii_char(void)1316 gfc_next_ascii_char (void)
1317 {
1318 gfc_char_t c = gfc_next_char ();
1319
1320 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1321 : (unsigned char) UCHAR_MAX);
1322 }
1323
1324
1325 gfc_char_t
gfc_peek_char(void)1326 gfc_peek_char (void)
1327 {
1328 locus old_loc;
1329 gfc_char_t c;
1330
1331 old_loc = gfc_current_locus;
1332 c = gfc_next_char ();
1333 gfc_current_locus = old_loc;
1334
1335 return c;
1336 }
1337
1338
1339 char
gfc_peek_ascii_char(void)1340 gfc_peek_ascii_char (void)
1341 {
1342 gfc_char_t c = gfc_peek_char ();
1343
1344 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1345 : (unsigned char) UCHAR_MAX);
1346 }
1347
1348
1349 /* Recover from an error. We try to get past the current statement
1350 and get lined up for the next. The next statement follows a '\n'
1351 or a ';'. We also assume that we are not within a character
1352 constant, and deal with finding a '\'' or '"'. */
1353
1354 void
gfc_error_recovery(void)1355 gfc_error_recovery (void)
1356 {
1357 gfc_char_t c, delim;
1358
1359 if (gfc_at_eof ())
1360 return;
1361
1362 for (;;)
1363 {
1364 c = gfc_next_char ();
1365 if (c == '\n' || c == ';')
1366 break;
1367
1368 if (c != '\'' && c != '"')
1369 {
1370 if (gfc_at_eof ())
1371 break;
1372 continue;
1373 }
1374 delim = c;
1375
1376 for (;;)
1377 {
1378 c = next_char ();
1379
1380 if (c == delim)
1381 break;
1382 if (c == '\n')
1383 return;
1384 if (c == '\\')
1385 {
1386 c = next_char ();
1387 if (c == '\n')
1388 return;
1389 }
1390 }
1391 if (gfc_at_eof ())
1392 break;
1393 }
1394 }
1395
1396
1397 /* Read ahead until the next character to be read is not whitespace. */
1398
1399 void
gfc_gobble_whitespace(void)1400 gfc_gobble_whitespace (void)
1401 {
1402 static int linenum = 0;
1403 locus old_loc;
1404 gfc_char_t c;
1405
1406 do
1407 {
1408 old_loc = gfc_current_locus;
1409 c = gfc_next_char_literal (NONSTRING);
1410 /* Issue a warning for nonconforming tabs. We keep track of the line
1411 number because the Fortran matchers will often back up and the same
1412 line will be scanned multiple times. */
1413 if (!gfc_option.warn_tabs && c == '\t')
1414 {
1415 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1416 if (cur_linenum != linenum)
1417 {
1418 linenum = cur_linenum;
1419 gfc_warning_now ("Nonconforming tab character at %C");
1420 }
1421 }
1422 }
1423 while (gfc_is_whitespace (c));
1424
1425 gfc_current_locus = old_loc;
1426 }
1427
1428
1429 /* Load a single line into pbuf.
1430
1431 If pbuf points to a NULL pointer, it is allocated.
1432 We truncate lines that are too long, unless we're dealing with
1433 preprocessor lines or if the option -ffixed-line-length-none is set,
1434 in which case we reallocate the buffer to fit the entire line, if
1435 need be.
1436 In fixed mode, we expand a tab that occurs within the statement
1437 label region to expand to spaces that leave the next character in
1438 the source region.
1439
1440 If first_char is not NULL, it's a pointer to a single char value holding
1441 the first character of the line, which has already been read by the
1442 caller. This avoids the use of ungetc().
1443
1444 load_line returns whether the line was truncated.
1445
1446 NOTE: The error machinery isn't available at this point, so we can't
1447 easily report line and column numbers consistent with other
1448 parts of gfortran. */
1449
1450 static int
load_line(FILE * input,gfc_char_t ** pbuf,int * pbuflen,const int * first_char)1451 load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1452 {
1453 static int linenum = 0, current_line = 1;
1454 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1455 int trunc_flag = 0, seen_comment = 0;
1456 int seen_printable = 0, seen_ampersand = 0, quoted = ' ';
1457 gfc_char_t *buffer;
1458 bool found_tab = false;
1459
1460 /* Determine the maximum allowed line length. */
1461 if (gfc_current_form == FORM_FREE)
1462 maxlen = gfc_option.free_line_length;
1463 else if (gfc_current_form == FORM_FIXED)
1464 maxlen = gfc_option.fixed_line_length;
1465 else
1466 maxlen = 72;
1467
1468 if (*pbuf == NULL)
1469 {
1470 /* Allocate the line buffer, storing its length into buflen.
1471 Note that if maxlen==0, indicating that arbitrary-length lines
1472 are allowed, the buffer will be reallocated if this length is
1473 insufficient; since 132 characters is the length of a standard
1474 free-form line, we use that as a starting guess. */
1475 if (maxlen > 0)
1476 buflen = maxlen;
1477 else
1478 buflen = 132;
1479
1480 *pbuf = gfc_get_wide_string (buflen + 1);
1481 }
1482
1483 i = 0;
1484 buffer = *pbuf;
1485
1486 if (first_char)
1487 c = *first_char;
1488 else
1489 c = getc (input);
1490
1491 /* In order to not truncate preprocessor lines, we have to
1492 remember that this is one. */
1493 preprocessor_flag = (c == '#' ? 1 : 0);
1494
1495 for (;;)
1496 {
1497 if (c == EOF)
1498 break;
1499
1500 if (c == '\n')
1501 {
1502 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1503 if (gfc_current_form == FORM_FREE
1504 && !seen_printable && seen_ampersand)
1505 {
1506 if (pedantic)
1507 gfc_error_now ("'&' not allowed by itself in line %d",
1508 current_line);
1509 else
1510 gfc_warning_now ("'&' not allowed by itself in line %d",
1511 current_line);
1512 }
1513 break;
1514 }
1515
1516 if (c == '\r' || c == '\0')
1517 goto next_char; /* Gobble characters. */
1518
1519 if (c == '&')
1520 {
1521 if (seen_ampersand)
1522 {
1523 seen_ampersand = 0;
1524 seen_printable = 1;
1525 }
1526 else
1527 seen_ampersand = 1;
1528 }
1529
1530 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1531 seen_printable = 1;
1532
1533 /* Is this a fixed-form comment? */
1534 if (gfc_current_form == FORM_FIXED && i == 0
1535 && (c == '*' || c == 'c' || c == 'd'))
1536 seen_comment = 1;
1537
1538 if (quoted == ' ')
1539 {
1540 if (c == '\'' || c == '"')
1541 quoted = c;
1542 }
1543 else if (c == quoted)
1544 quoted = ' ';
1545
1546 /* Is this a free-form comment? */
1547 if (c == '!' && quoted == ' ')
1548 seen_comment = 1;
1549
1550 /* Vendor extension: "<tab>1" marks a continuation line. */
1551 if (found_tab)
1552 {
1553 found_tab = false;
1554 if (c >= '1' && c <= '9')
1555 {
1556 *(buffer-1) = c;
1557 goto next_char;
1558 }
1559 }
1560
1561 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1562 {
1563 found_tab = true;
1564
1565 if (!gfc_option.warn_tabs && seen_comment == 0
1566 && current_line != linenum)
1567 {
1568 linenum = current_line;
1569 gfc_warning_now ("Nonconforming tab character in column %d "
1570 "of line %d", i+1, linenum);
1571 }
1572
1573 while (i < 6)
1574 {
1575 *buffer++ = ' ';
1576 i++;
1577 }
1578
1579 goto next_char;
1580 }
1581
1582 *buffer++ = c;
1583 i++;
1584
1585 if (maxlen == 0 || preprocessor_flag)
1586 {
1587 if (i >= buflen)
1588 {
1589 /* Reallocate line buffer to double size to hold the
1590 overlong line. */
1591 buflen = buflen * 2;
1592 *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
1593 buffer = (*pbuf) + i;
1594 }
1595 }
1596 else if (i >= maxlen)
1597 {
1598 bool trunc_warn = true;
1599
1600 /* Enhancement, if the very next non-space character is an ampersand
1601 or comment that we would otherwise warn about, don't mark as
1602 truncated. */
1603
1604 /* Truncate the rest of the line. */
1605 for (;;)
1606 {
1607 c = getc (input);
1608 if (c == '\r' || c == ' ')
1609 continue;
1610
1611 if (c == '\n' || c == EOF)
1612 break;
1613
1614 if (!trunc_warn && c != '!')
1615 trunc_warn = true;
1616
1617 if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&')
1618 || c == '!'))
1619 trunc_warn = false;
1620
1621 if (c == '!')
1622 seen_comment = 1;
1623
1624 if (trunc_warn && !seen_comment)
1625 trunc_flag = 1;
1626 }
1627
1628 c = '\n';
1629 continue;
1630 }
1631
1632 next_char:
1633 c = getc (input);
1634 }
1635
1636 /* Pad lines to the selected line length in fixed form. */
1637 if (gfc_current_form == FORM_FIXED
1638 && gfc_option.fixed_line_length != 0
1639 && !preprocessor_flag
1640 && c != EOF)
1641 {
1642 while (i++ < maxlen)
1643 *buffer++ = ' ';
1644 }
1645
1646 *buffer = '\0';
1647 *pbuflen = buflen;
1648 current_line++;
1649
1650 return trunc_flag;
1651 }
1652
1653
1654 /* Get a gfc_file structure, initialize it and add it to
1655 the file stack. */
1656
1657 static gfc_file *
get_file(const char * name,enum lc_reason reason ATTRIBUTE_UNUSED)1658 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1659 {
1660 gfc_file *f;
1661
1662 f = XCNEW (gfc_file);
1663
1664 f->filename = xstrdup (name);
1665
1666 f->next = file_head;
1667 file_head = f;
1668
1669 f->up = current_file;
1670 if (current_file != NULL)
1671 f->inclusion_line = current_file->line;
1672
1673 linemap_add (line_table, reason, false, f->filename, 1);
1674
1675 return f;
1676 }
1677
1678
1679 /* Deal with a line from the C preprocessor. The
1680 initial octothorp has already been seen. */
1681
1682 static void
preprocessor_line(gfc_char_t * c)1683 preprocessor_line (gfc_char_t *c)
1684 {
1685 bool flag[5];
1686 int i, line;
1687 gfc_char_t *wide_filename;
1688 gfc_file *f;
1689 int escaped, unescape;
1690 char *filename;
1691
1692 c++;
1693 while (*c == ' ' || *c == '\t')
1694 c++;
1695
1696 if (*c < '0' || *c > '9')
1697 goto bad_cpp_line;
1698
1699 line = wide_atoi (c);
1700
1701 c = wide_strchr (c, ' ');
1702 if (c == NULL)
1703 {
1704 /* No file name given. Set new line number. */
1705 current_file->line = line;
1706 return;
1707 }
1708
1709 /* Skip spaces. */
1710 while (*c == ' ' || *c == '\t')
1711 c++;
1712
1713 /* Skip quote. */
1714 if (*c != '"')
1715 goto bad_cpp_line;
1716 ++c;
1717
1718 wide_filename = c;
1719
1720 /* Make filename end at quote. */
1721 unescape = 0;
1722 escaped = false;
1723 while (*c && ! (!escaped && *c == '"'))
1724 {
1725 if (escaped)
1726 escaped = false;
1727 else if (*c == '\\')
1728 {
1729 escaped = true;
1730 unescape++;
1731 }
1732 ++c;
1733 }
1734
1735 if (! *c)
1736 /* Preprocessor line has no closing quote. */
1737 goto bad_cpp_line;
1738
1739 *c++ = '\0';
1740
1741 /* Undo effects of cpp_quote_string. */
1742 if (unescape)
1743 {
1744 gfc_char_t *s = wide_filename;
1745 gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
1746
1747 wide_filename = d;
1748 while (*s)
1749 {
1750 if (*s == '\\')
1751 *d++ = *++s;
1752 else
1753 *d++ = *s;
1754 s++;
1755 }
1756 *d = '\0';
1757 }
1758
1759 /* Get flags. */
1760
1761 flag[1] = flag[2] = flag[3] = flag[4] = false;
1762
1763 for (;;)
1764 {
1765 c = wide_strchr (c, ' ');
1766 if (c == NULL)
1767 break;
1768
1769 c++;
1770 i = wide_atoi (c);
1771
1772 if (1 <= i && i <= 4)
1773 flag[i] = true;
1774 }
1775
1776 /* Convert the filename in wide characters into a filename in narrow
1777 characters. */
1778 filename = gfc_widechar_to_char (wide_filename, -1);
1779
1780 /* Interpret flags. */
1781
1782 if (flag[1]) /* Starting new file. */
1783 {
1784 f = get_file (filename, LC_RENAME);
1785 add_file_change (f->filename, f->inclusion_line);
1786 current_file = f;
1787 }
1788
1789 if (flag[2]) /* Ending current file. */
1790 {
1791 if (!current_file->up
1792 || filename_cmp (current_file->up->filename, filename) != 0)
1793 {
1794 gfc_warning_now ("%s:%d: file %s left but not entered",
1795 current_file->filename, current_file->line,
1796 filename);
1797 if (unescape)
1798 free (wide_filename);
1799 free (filename);
1800 return;
1801 }
1802
1803 add_file_change (NULL, line);
1804 current_file = current_file->up;
1805 linemap_add (line_table, LC_RENAME, false, current_file->filename,
1806 current_file->line);
1807 }
1808
1809 /* The name of the file can be a temporary file produced by
1810 cpp. Replace the name if it is different. */
1811
1812 if (filename_cmp (current_file->filename, filename) != 0)
1813 {
1814 /* FIXME: we leak the old filename because a pointer to it may be stored
1815 in the linemap. Alternative could be using GC or updating linemap to
1816 point to the new name, but there is no API for that currently. */
1817 current_file->filename = xstrdup (filename);
1818 }
1819
1820 /* Set new line number. */
1821 current_file->line = line;
1822 if (unescape)
1823 free (wide_filename);
1824 free (filename);
1825 return;
1826
1827 bad_cpp_line:
1828 gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1829 current_file->filename, current_file->line);
1830 current_file->line++;
1831 }
1832
1833
1834 static gfc_try load_file (const char *, const char *, bool);
1835
1836 /* include_line()-- Checks a line buffer to see if it is an include
1837 line. If so, we call load_file() recursively to load the included
1838 file. We never return a syntax error because a statement like
1839 "include = 5" is perfectly legal. We return false if no include was
1840 processed or true if we matched an include. */
1841
1842 static bool
include_line(gfc_char_t * line)1843 include_line (gfc_char_t *line)
1844 {
1845 gfc_char_t quote, *c, *begin, *stop;
1846 char *filename;
1847
1848 c = line;
1849
1850 if (gfc_option.gfc_flag_openmp)
1851 {
1852 if (gfc_current_form == FORM_FREE)
1853 {
1854 while (*c == ' ' || *c == '\t')
1855 c++;
1856 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1857 c += 3;
1858 }
1859 else
1860 {
1861 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1862 && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1863 c += 3;
1864 }
1865 }
1866
1867 while (*c == ' ' || *c == '\t')
1868 c++;
1869
1870 if (gfc_wide_strncasecmp (c, "include", 7))
1871 return false;
1872
1873 c += 7;
1874 while (*c == ' ' || *c == '\t')
1875 c++;
1876
1877 /* Find filename between quotes. */
1878
1879 quote = *c++;
1880 if (quote != '"' && quote != '\'')
1881 return false;
1882
1883 begin = c;
1884
1885 while (*c != quote && *c != '\0')
1886 c++;
1887
1888 if (*c == '\0')
1889 return false;
1890
1891 stop = c++;
1892
1893 while (*c == ' ' || *c == '\t')
1894 c++;
1895
1896 if (*c != '\0' && *c != '!')
1897 return false;
1898
1899 /* We have an include line at this point. */
1900
1901 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1902 read by anything else. */
1903
1904 filename = gfc_widechar_to_char (begin, -1);
1905 if (load_file (filename, NULL, false) == FAILURE)
1906 exit (FATAL_EXIT_CODE);
1907
1908 free (filename);
1909 return true;
1910 }
1911
1912
1913 /* Load a file into memory by calling load_line until the file ends. */
1914
1915 static gfc_try
load_file(const char * realfilename,const char * displayedname,bool initial)1916 load_file (const char *realfilename, const char *displayedname, bool initial)
1917 {
1918 gfc_char_t *line;
1919 gfc_linebuf *b;
1920 gfc_file *f;
1921 FILE *input;
1922 int len, line_len;
1923 bool first_line;
1924 const char *filename;
1925 /* If realfilename and displayedname are different and non-null then
1926 surely realfilename is the preprocessed form of
1927 displayedname. */
1928 bool preprocessed_p = (realfilename && displayedname
1929 && strcmp (realfilename, displayedname));
1930
1931 filename = displayedname ? displayedname : realfilename;
1932
1933 for (f = current_file; f; f = f->up)
1934 if (filename_cmp (filename, f->filename) == 0)
1935 {
1936 fprintf (stderr, "%s:%d: Error: File '%s' is being included "
1937 "recursively\n", current_file->filename, current_file->line,
1938 filename);
1939 return FAILURE;
1940 }
1941
1942 if (initial)
1943 {
1944 if (gfc_src_file)
1945 {
1946 input = gfc_src_file;
1947 gfc_src_file = NULL;
1948 }
1949 else
1950 input = gfc_open_file (realfilename);
1951 if (input == NULL)
1952 {
1953 gfc_error_now ("Can't open file '%s'", filename);
1954 return FAILURE;
1955 }
1956 }
1957 else
1958 {
1959 input = gfc_open_included_file (realfilename, false, false);
1960 if (input == NULL)
1961 {
1962 fprintf (stderr, "%s:%d: Error: Can't open included file '%s'\n",
1963 current_file->filename, current_file->line, filename);
1964 return FAILURE;
1965 }
1966 }
1967
1968 /* Load the file.
1969
1970 A "non-initial" file means a file that is being included. In
1971 that case we are creating an LC_ENTER map.
1972
1973 An "initial" file means a main file; one that is not included.
1974 That file has already got at least one (surely more) line map(s)
1975 created by gfc_init. So the subsequent map created in that case
1976 must have LC_RENAME reason.
1977
1978 This latter case is not true for a preprocessed file. In that
1979 case, although the file is "initial", the line maps created by
1980 gfc_init was used during the preprocessing of the file. Now that
1981 the preprocessing is over and we are being fed the result of that
1982 preprocessing, we need to create a brand new line map for the
1983 preprocessed file, so the reason is going to be LC_ENTER. */
1984
1985 f = get_file (filename, (initial && !preprocessed_p) ? LC_RENAME : LC_ENTER);
1986 if (!initial)
1987 add_file_change (f->filename, f->inclusion_line);
1988 current_file = f;
1989 current_file->line = 1;
1990 line = NULL;
1991 line_len = 0;
1992 first_line = true;
1993
1994 if (initial && gfc_src_preprocessor_lines[0])
1995 {
1996 preprocessor_line (gfc_src_preprocessor_lines[0]);
1997 free (gfc_src_preprocessor_lines[0]);
1998 gfc_src_preprocessor_lines[0] = NULL;
1999 if (gfc_src_preprocessor_lines[1])
2000 {
2001 preprocessor_line (gfc_src_preprocessor_lines[1]);
2002 free (gfc_src_preprocessor_lines[1]);
2003 gfc_src_preprocessor_lines[1] = NULL;
2004 }
2005 }
2006
2007 for (;;)
2008 {
2009 int trunc = load_line (input, &line, &line_len, NULL);
2010
2011 len = gfc_wide_strlen (line);
2012 if (feof (input) && len == 0)
2013 break;
2014
2015 /* If this is the first line of the file, it can contain a byte
2016 order mark (BOM), which we will ignore:
2017 FF FE is UTF-16 little endian,
2018 FE FF is UTF-16 big endian,
2019 EF BB BF is UTF-8. */
2020 if (first_line
2021 && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
2022 && line[1] == (unsigned char) '\xFE')
2023 || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
2024 && line[1] == (unsigned char) '\xFF')
2025 || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
2026 && line[1] == (unsigned char) '\xBB'
2027 && line[2] == (unsigned char) '\xBF')))
2028 {
2029 int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
2030 gfc_char_t *new_char = gfc_get_wide_string (line_len);
2031
2032 wide_strcpy (new_char, &line[n]);
2033 free (line);
2034 line = new_char;
2035 len -= n;
2036 }
2037
2038 /* There are three things this line can be: a line of Fortran
2039 source, an include line or a C preprocessor directive. */
2040
2041 if (line[0] == '#')
2042 {
2043 /* When -g3 is specified, it's possible that we emit #define
2044 and #undef lines, which we need to pass to the middle-end
2045 so that it can emit correct debug info. */
2046 if (debug_info_level == DINFO_LEVEL_VERBOSE
2047 && (wide_strncmp (line, "#define ", 8) == 0
2048 || wide_strncmp (line, "#undef ", 7) == 0))
2049 ;
2050 else
2051 {
2052 preprocessor_line (line);
2053 continue;
2054 }
2055 }
2056
2057 /* Preprocessed files have preprocessor lines added before the byte
2058 order mark, so first_line is not about the first line of the file
2059 but the first line that's not a preprocessor line. */
2060 first_line = false;
2061
2062 if (include_line (line))
2063 {
2064 current_file->line++;
2065 continue;
2066 }
2067
2068 /* Add line. */
2069
2070 b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size
2071 + (len + 1) * sizeof (gfc_char_t));
2072
2073 b->location
2074 = linemap_line_start (line_table, current_file->line++, 120);
2075 b->file = current_file;
2076 b->truncated = trunc;
2077 wide_strcpy (b->line, line);
2078
2079 if (line_head == NULL)
2080 line_head = b;
2081 else
2082 line_tail->next = b;
2083
2084 line_tail = b;
2085
2086 while (file_changes_cur < file_changes_count)
2087 file_changes[file_changes_cur++].lb = b;
2088 }
2089
2090 /* Release the line buffer allocated in load_line. */
2091 free (line);
2092
2093 fclose (input);
2094
2095 if (!initial)
2096 add_file_change (NULL, current_file->inclusion_line + 1);
2097 current_file = current_file->up;
2098 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
2099 return SUCCESS;
2100 }
2101
2102
2103 /* Open a new file and start scanning from that file. Returns SUCCESS
2104 if everything went OK, FAILURE otherwise. If form == FORM_UNKNOWN
2105 it tries to determine the source form from the filename, defaulting
2106 to free form. */
2107
2108 gfc_try
gfc_new_file(void)2109 gfc_new_file (void)
2110 {
2111 gfc_try result;
2112
2113 if (gfc_cpp_enabled ())
2114 {
2115 result = gfc_cpp_preprocess (gfc_source_file);
2116 if (!gfc_cpp_preprocess_only ())
2117 result = load_file (gfc_cpp_temporary_file (), gfc_source_file, true);
2118 }
2119 else
2120 result = load_file (gfc_source_file, NULL, true);
2121
2122 gfc_current_locus.lb = line_head;
2123 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
2124
2125 #if 0 /* Debugging aid. */
2126 for (; line_head; line_head = line_head->next)
2127 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
2128 LOCATION_LINE (line_head->location), line_head->line);
2129
2130 exit (SUCCESS_EXIT_CODE);
2131 #endif
2132
2133 return result;
2134 }
2135
2136 static char *
unescape_filename(const char * ptr)2137 unescape_filename (const char *ptr)
2138 {
2139 const char *p = ptr, *s;
2140 char *d, *ret;
2141 int escaped, unescape = 0;
2142
2143 /* Make filename end at quote. */
2144 escaped = false;
2145 while (*p && ! (! escaped && *p == '"'))
2146 {
2147 if (escaped)
2148 escaped = false;
2149 else if (*p == '\\')
2150 {
2151 escaped = true;
2152 unescape++;
2153 }
2154 ++p;
2155 }
2156
2157 if (!*p || p[1])
2158 return NULL;
2159
2160 /* Undo effects of cpp_quote_string. */
2161 s = ptr;
2162 d = XCNEWVEC (char, p + 1 - ptr - unescape);
2163 ret = d;
2164
2165 while (s != p)
2166 {
2167 if (*s == '\\')
2168 *d++ = *++s;
2169 else
2170 *d++ = *s;
2171 s++;
2172 }
2173 *d = '\0';
2174 return ret;
2175 }
2176
2177 /* For preprocessed files, if the first tokens are of the form # NUM.
2178 handle the directives so we know the original file name. */
2179
2180 const char *
gfc_read_orig_filename(const char * filename,const char ** canon_source_file)2181 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
2182 {
2183 int c, len;
2184 char *dirname, *tmp;
2185
2186 gfc_src_file = gfc_open_file (filename);
2187 if (gfc_src_file == NULL)
2188 return NULL;
2189
2190 c = getc (gfc_src_file);
2191
2192 if (c != '#')
2193 return NULL;
2194
2195 len = 0;
2196 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c);
2197
2198 if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
2199 return NULL;
2200
2201 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
2202 filename = unescape_filename (tmp);
2203 free (tmp);
2204 if (filename == NULL)
2205 return NULL;
2206
2207 c = getc (gfc_src_file);
2208
2209 if (c != '#')
2210 return filename;
2211
2212 len = 0;
2213 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c);
2214
2215 if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
2216 return filename;
2217
2218 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
2219 dirname = unescape_filename (tmp);
2220 free (tmp);
2221 if (dirname == NULL)
2222 return filename;
2223
2224 len = strlen (dirname);
2225 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
2226 {
2227 free (dirname);
2228 return filename;
2229 }
2230 dirname[len - 2] = '\0';
2231 set_src_pwd (dirname);
2232
2233 if (! IS_ABSOLUTE_PATH (filename))
2234 {
2235 char *p = XCNEWVEC (char, len + strlen (filename));
2236
2237 memcpy (p, dirname, len - 2);
2238 p[len - 2] = '/';
2239 strcpy (p + len - 1, filename);
2240 *canon_source_file = p;
2241 }
2242
2243 free (dirname);
2244 return filename;
2245 }
2246