1 /* Character scanner.
2 Copyright (C) 2000-2022 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 "options.h"
50 #include "diagnostic-core.h" /* For fatal_error. */
51 #include "cpp.h"
52 #include "scanner.h"
53
54 /* List of include file search directories. */
55 gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
56
57 static gfc_file *file_head, *current_file;
58
59 static int continue_flag, end_flag, gcc_attribute_flag;
60 /* If !$omp/!$acc occurred in current comment line. */
61 static int openmp_flag, openacc_flag;
62 static int continue_count, continue_line;
63 static locus openmp_locus;
64 static locus openacc_locus;
65 static locus gcc_attribute_locus;
66
67 gfc_source_form gfc_current_form;
68 static gfc_linebuf *line_head, *line_tail;
69
70 locus gfc_current_locus;
71 const char *gfc_source_file;
72 static FILE *gfc_src_file;
73 static gfc_char_t *gfc_src_preprocessor_lines[2];
74
75 static struct gfc_file_change
76 {
77 const char *filename;
78 gfc_linebuf *lb;
79 int line;
80 } *file_changes;
81 static size_t file_changes_cur, file_changes_count;
82 static size_t file_changes_allocated;
83
84 static gfc_char_t *last_error_char;
85
86 /* Functions dealing with our wide characters (gfc_char_t) and
87 sequences of such characters. */
88
89 int
gfc_wide_fits_in_byte(gfc_char_t c)90 gfc_wide_fits_in_byte (gfc_char_t c)
91 {
92 return (c <= UCHAR_MAX);
93 }
94
95 static inline int
wide_is_ascii(gfc_char_t c)96 wide_is_ascii (gfc_char_t c)
97 {
98 return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0);
99 }
100
101 int
gfc_wide_is_printable(gfc_char_t c)102 gfc_wide_is_printable (gfc_char_t c)
103 {
104 return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c));
105 }
106
107 gfc_char_t
gfc_wide_tolower(gfc_char_t c)108 gfc_wide_tolower (gfc_char_t c)
109 {
110 return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
111 }
112
113 gfc_char_t
gfc_wide_toupper(gfc_char_t c)114 gfc_wide_toupper (gfc_char_t c)
115 {
116 return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c);
117 }
118
119 int
gfc_wide_is_digit(gfc_char_t c)120 gfc_wide_is_digit (gfc_char_t c)
121 {
122 return (c >= '0' && c <= '9');
123 }
124
125 static inline int
wide_atoi(gfc_char_t * c)126 wide_atoi (gfc_char_t *c)
127 {
128 #define MAX_DIGITS 20
129 char buf[MAX_DIGITS+1];
130 int i = 0;
131
132 while (gfc_wide_is_digit(*c) && i < MAX_DIGITS)
133 buf[i++] = *c++;
134 buf[i] = '\0';
135 return atoi (buf);
136 }
137
138 size_t
gfc_wide_strlen(const gfc_char_t * str)139 gfc_wide_strlen (const gfc_char_t *str)
140 {
141 size_t i;
142
143 for (i = 0; str[i]; i++)
144 ;
145
146 return i;
147 }
148
149 gfc_char_t *
gfc_wide_memset(gfc_char_t * b,gfc_char_t c,size_t len)150 gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len)
151 {
152 size_t i;
153
154 for (i = 0; i < len; i++)
155 b[i] = c;
156
157 return b;
158 }
159
160 static gfc_char_t *
wide_strcpy(gfc_char_t * dest,const gfc_char_t * src)161 wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
162 {
163 gfc_char_t *d;
164
165 for (d = dest; (*d = *src) != '\0'; ++src, ++d)
166 ;
167
168 return dest;
169 }
170
171 static gfc_char_t *
wide_strchr(const gfc_char_t * s,gfc_char_t c)172 wide_strchr (const gfc_char_t *s, gfc_char_t c)
173 {
174 do {
175 if (*s == c)
176 {
177 return CONST_CAST(gfc_char_t *, s);
178 }
179 } while (*s++);
180 return 0;
181 }
182
183 char *
gfc_widechar_to_char(const gfc_char_t * s,int length)184 gfc_widechar_to_char (const gfc_char_t *s, int length)
185 {
186 size_t len, i;
187 char *res;
188
189 if (s == NULL)
190 return NULL;
191
192 /* Passing a negative length is used to indicate that length should be
193 calculated using gfc_wide_strlen(). */
194 len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s));
195 res = XNEWVEC (char, len + 1);
196
197 for (i = 0; i < len; i++)
198 {
199 gcc_assert (gfc_wide_fits_in_byte (s[i]));
200 res[i] = (unsigned char) s[i];
201 }
202
203 res[len] = '\0';
204 return res;
205 }
206
207 gfc_char_t *
gfc_char_to_widechar(const char * s)208 gfc_char_to_widechar (const char *s)
209 {
210 size_t len, i;
211 gfc_char_t *res;
212
213 if (s == NULL)
214 return NULL;
215
216 len = strlen (s);
217 res = gfc_get_wide_string (len + 1);
218
219 for (i = 0; i < len; i++)
220 res[i] = (unsigned char) s[i];
221
222 res[len] = '\0';
223 return res;
224 }
225
226 static int
wide_strncmp(const gfc_char_t * s1,const char * s2,size_t n)227 wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n)
228 {
229 gfc_char_t c1, c2;
230
231 while (n-- > 0)
232 {
233 c1 = *s1++;
234 c2 = *s2++;
235 if (c1 != c2)
236 return (c1 > c2 ? 1 : -1);
237 if (c1 == '\0')
238 return 0;
239 }
240 return 0;
241 }
242
243 int
gfc_wide_strncasecmp(const gfc_char_t * s1,const char * s2,size_t n)244 gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
245 {
246 gfc_char_t c1, c2;
247
248 while (n-- > 0)
249 {
250 c1 = gfc_wide_tolower (*s1++);
251 c2 = TOLOWER (*s2++);
252 if (c1 != c2)
253 return (c1 > c2 ? 1 : -1);
254 if (c1 == '\0')
255 return 0;
256 }
257 return 0;
258 }
259
260
261 /* Main scanner initialization. */
262
263 void
gfc_scanner_init_1(void)264 gfc_scanner_init_1 (void)
265 {
266 file_head = NULL;
267 line_head = NULL;
268 line_tail = NULL;
269
270 continue_count = 0;
271 continue_line = 0;
272
273 end_flag = 0;
274 last_error_char = NULL;
275 }
276
277
278 /* Main scanner destructor. */
279
280 void
gfc_scanner_done_1(void)281 gfc_scanner_done_1 (void)
282 {
283 gfc_linebuf *lb;
284 gfc_file *f;
285
286 while(line_head != NULL)
287 {
288 lb = line_head->next;
289 free (line_head);
290 line_head = lb;
291 }
292
293 while(file_head != NULL)
294 {
295 f = file_head->next;
296 free (file_head->filename);
297 free (file_head);
298 file_head = f;
299 }
300 }
301
302 static bool
gfc_do_check_include_dir(const char * path,bool warn)303 gfc_do_check_include_dir (const char *path, bool warn)
304 {
305 struct stat st;
306 if (stat (path, &st))
307 {
308 if (errno != ENOENT)
309 gfc_warning_now (0, "Include directory %qs: %s",
310 path, xstrerror(errno));
311 else if (warn)
312 gfc_warning_now (OPT_Wmissing_include_dirs,
313 "Nonexistent include directory %qs", path);
314 return false;
315 }
316 else if (!S_ISDIR (st.st_mode))
317 {
318 gfc_fatal_error ("%qs is not a directory", path);
319 return false;
320 }
321 return true;
322 }
323
324 /* In order that -W(no-)missing-include-dirs works, the diagnostic can only be
325 run after processing the commandline. */
326 static void
gfc_do_check_include_dirs(gfc_directorylist ** list,bool do_warn)327 gfc_do_check_include_dirs (gfc_directorylist **list, bool do_warn)
328 {
329 gfc_directorylist *prev, *q, *n;
330 prev = NULL;
331 n = *list;
332 while (n)
333 {
334 q = n; n = n->next;
335 if (gfc_do_check_include_dir (q->path, q->warn && do_warn))
336 {
337 prev = q;
338 continue;
339 }
340 if (prev == NULL)
341 *list = n;
342 else
343 prev->next = n;
344 free (q->path);
345 free (q);
346 }
347 }
348
349 void
gfc_check_include_dirs(bool verbose_missing_dir_warn)350 gfc_check_include_dirs (bool verbose_missing_dir_warn)
351 {
352 /* This is a bit convoluted: If gfc_cpp_enabled () and
353 verbose_missing_dir_warn, the warning is shown by libcpp. Otherwise,
354 it is shown here, still conditional on OPT_Wmissing_include_dirs. */
355 bool warn = !gfc_cpp_enabled () || !verbose_missing_dir_warn;
356 gfc_do_check_include_dirs (&include_dirs, warn);
357 gfc_do_check_include_dirs (&intrinsic_modules_dirs, verbose_missing_dir_warn);
358 if (gfc_option.module_dir && gfc_cpp_enabled ())
359 gfc_do_check_include_dirs (&include_dirs, true);
360 }
361
362 /* Adds path to the list pointed to by list. */
363
364 static void
add_path_to_list(gfc_directorylist ** list,const char * path,bool use_for_modules,bool head,bool warn,bool defer_warn)365 add_path_to_list (gfc_directorylist **list, const char *path,
366 bool use_for_modules, bool head, bool warn, bool defer_warn)
367 {
368 gfc_directorylist *dir;
369 const char *p;
370 char *q;
371 size_t len;
372 int i;
373
374 p = path;
375 while (*p == ' ' || *p == '\t') /* someone might do "-I include" */
376 if (*p++ == '\0')
377 return;
378
379 /* Strip trailing directory separators from the path, as this
380 will confuse Windows systems. */
381 len = strlen (p);
382 q = (char *) alloca (len + 1);
383 memcpy (q, p, len + 1);
384 i = len - 1;
385 while (i >=0 && IS_DIR_SEPARATOR (q[i]))
386 q[i--] = '\0';
387
388 if (!defer_warn && !gfc_do_check_include_dir (q, warn))
389 return;
390
391 if (head || *list == NULL)
392 {
393 dir = XCNEW (gfc_directorylist);
394 if (!head)
395 *list = dir;
396 }
397 else
398 {
399 dir = *list;
400 while (dir->next)
401 dir = dir->next;
402
403 dir->next = XCNEW (gfc_directorylist);
404 dir = dir->next;
405 }
406
407 dir->next = head ? *list : NULL;
408 if (head)
409 *list = dir;
410 dir->use_for_modules = use_for_modules;
411 dir->warn = warn;
412 dir->path = xstrdup (p);
413 }
414
415 /* defer_warn is set to true while parsing the commandline. */
416
417 void
gfc_add_include_path(const char * path,bool use_for_modules,bool file_dir,bool warn,bool defer_warn)418 gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir,
419 bool warn, bool defer_warn)
420 {
421 add_path_to_list (&include_dirs, path, use_for_modules, file_dir, warn,
422 defer_warn);
423
424 /* For '#include "..."' these directories are automatically searched. */
425 if (!file_dir)
426 gfc_cpp_add_include_path (xstrdup(path), true);
427 }
428
429
430 void
gfc_add_intrinsic_modules_path(const char * path)431 gfc_add_intrinsic_modules_path (const char *path)
432 {
433 add_path_to_list (&intrinsic_modules_dirs, path, true, false, false, false);
434 }
435
436
437 /* Release resources allocated for options. */
438
439 void
gfc_release_include_path(void)440 gfc_release_include_path (void)
441 {
442 gfc_directorylist *p;
443
444 while (include_dirs != NULL)
445 {
446 p = include_dirs;
447 include_dirs = include_dirs->next;
448 free (p->path);
449 free (p);
450 }
451
452 while (intrinsic_modules_dirs != NULL)
453 {
454 p = intrinsic_modules_dirs;
455 intrinsic_modules_dirs = intrinsic_modules_dirs->next;
456 free (p->path);
457 free (p);
458 }
459
460 free (gfc_option.module_dir);
461 }
462
463
464 static FILE *
open_included_file(const char * name,gfc_directorylist * list,bool module,bool system)465 open_included_file (const char *name, gfc_directorylist *list,
466 bool module, bool system)
467 {
468 char *fullname;
469 gfc_directorylist *p;
470 FILE *f;
471
472 for (p = list; p; p = p->next)
473 {
474 if (module && !p->use_for_modules)
475 continue;
476
477 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 2);
478 strcpy (fullname, p->path);
479 strcat (fullname, "/");
480 strcat (fullname, name);
481
482 f = gfc_open_file (fullname);
483 if (f != NULL)
484 {
485 if (gfc_cpp_makedep ())
486 gfc_cpp_add_dep (fullname, system);
487
488 return f;
489 }
490 }
491
492 return NULL;
493 }
494
495
496 /* Opens file for reading, searching through the include directories
497 given if necessary. If the include_cwd argument is true, we try
498 to open the file in the current directory first. */
499
500 FILE *
gfc_open_included_file(const char * name,bool include_cwd,bool module)501 gfc_open_included_file (const char *name, bool include_cwd, bool module)
502 {
503 FILE *f = NULL;
504
505 if (IS_ABSOLUTE_PATH (name) || include_cwd)
506 {
507 f = gfc_open_file (name);
508 if (f && gfc_cpp_makedep ())
509 gfc_cpp_add_dep (name, false);
510 }
511
512 if (!f)
513 f = open_included_file (name, include_dirs, module, false);
514
515 return f;
516 }
517
518
519 /* Test to see if we're at the end of the main source file. */
520
521 int
gfc_at_end(void)522 gfc_at_end (void)
523 {
524 return end_flag;
525 }
526
527
528 /* Test to see if we're at the end of the current file. */
529
530 int
gfc_at_eof(void)531 gfc_at_eof (void)
532 {
533 if (gfc_at_end ())
534 return 1;
535
536 if (line_head == NULL)
537 return 1; /* Null file */
538
539 if (gfc_current_locus.lb == NULL)
540 return 1;
541
542 return 0;
543 }
544
545
546 /* Test to see if we're at the beginning of a new line. */
547
548 int
gfc_at_bol(void)549 gfc_at_bol (void)
550 {
551 if (gfc_at_eof ())
552 return 1;
553
554 return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
555 }
556
557
558 /* Test to see if we're at the end of a line. */
559
560 int
gfc_at_eol(void)561 gfc_at_eol (void)
562 {
563 if (gfc_at_eof ())
564 return 1;
565
566 return (*gfc_current_locus.nextc == '\0');
567 }
568
569 static void
add_file_change(const char * filename,int line)570 add_file_change (const char *filename, int line)
571 {
572 if (file_changes_count == file_changes_allocated)
573 {
574 if (file_changes_allocated)
575 file_changes_allocated *= 2;
576 else
577 file_changes_allocated = 16;
578 file_changes = XRESIZEVEC (struct gfc_file_change, file_changes,
579 file_changes_allocated);
580 }
581 file_changes[file_changes_count].filename = filename;
582 file_changes[file_changes_count].lb = NULL;
583 file_changes[file_changes_count++].line = line;
584 }
585
586 static void
report_file_change(gfc_linebuf * lb)587 report_file_change (gfc_linebuf *lb)
588 {
589 size_t c = file_changes_cur;
590 while (c < file_changes_count
591 && file_changes[c].lb == lb)
592 {
593 if (file_changes[c].filename)
594 (*debug_hooks->start_source_file) (file_changes[c].line,
595 file_changes[c].filename);
596 else
597 (*debug_hooks->end_source_file) (file_changes[c].line);
598 ++c;
599 }
600 file_changes_cur = c;
601 }
602
603 void
gfc_start_source_files(void)604 gfc_start_source_files (void)
605 {
606 /* If the debugger wants the name of the main source file,
607 we give it. */
608 if (debug_hooks->start_end_main_source_file)
609 (*debug_hooks->start_source_file) (0, gfc_source_file);
610
611 file_changes_cur = 0;
612 report_file_change (gfc_current_locus.lb);
613 }
614
615 void
gfc_end_source_files(void)616 gfc_end_source_files (void)
617 {
618 report_file_change (NULL);
619
620 if (debug_hooks->start_end_main_source_file)
621 (*debug_hooks->end_source_file) (0);
622 }
623
624 /* Advance the current line pointer to the next line. */
625
626 void
gfc_advance_line(void)627 gfc_advance_line (void)
628 {
629 if (gfc_at_end ())
630 return;
631
632 if (gfc_current_locus.lb == NULL)
633 {
634 end_flag = 1;
635 return;
636 }
637
638 if (gfc_current_locus.lb->next
639 && !gfc_current_locus.lb->next->dbg_emitted)
640 {
641 report_file_change (gfc_current_locus.lb->next);
642 gfc_current_locus.lb->next->dbg_emitted = true;
643 }
644
645 gfc_current_locus.lb = gfc_current_locus.lb->next;
646
647 if (gfc_current_locus.lb != NULL)
648 gfc_current_locus.nextc = gfc_current_locus.lb->line;
649 else
650 {
651 gfc_current_locus.nextc = NULL;
652 end_flag = 1;
653 }
654 }
655
656
657 /* Get the next character from the input, advancing gfc_current_file's
658 locus. When we hit the end of the line or the end of the file, we
659 start returning a '\n' in order to complete the current statement.
660 No Fortran line conventions are implemented here.
661
662 Requiring explicit advances to the next line prevents the parse
663 pointer from being on the wrong line if the current statement ends
664 prematurely. */
665
666 static gfc_char_t
next_char(void)667 next_char (void)
668 {
669 gfc_char_t c;
670
671 if (gfc_current_locus.nextc == NULL)
672 return '\n';
673
674 c = *gfc_current_locus.nextc++;
675 if (c == '\0')
676 {
677 gfc_current_locus.nextc--; /* Remain on this line. */
678 c = '\n';
679 }
680
681 return c;
682 }
683
684
685 /* Skip a comment. When we come here the parse pointer is positioned
686 immediately after the comment character. If we ever implement
687 compiler directives within comments, here is where we parse the
688 directive. */
689
690 static void
skip_comment_line(void)691 skip_comment_line (void)
692 {
693 gfc_char_t c;
694
695 do
696 {
697 c = next_char ();
698 }
699 while (c != '\n');
700
701 gfc_advance_line ();
702 }
703
704
705 int
gfc_define_undef_line(void)706 gfc_define_undef_line (void)
707 {
708 char *tmp;
709
710 /* All lines beginning with '#' are either #define or #undef. */
711 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
712 return 0;
713
714 if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
715 {
716 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
717 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
718 tmp);
719 free (tmp);
720 }
721
722 if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
723 {
724 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
725 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
726 tmp);
727 free (tmp);
728 }
729
730 /* Skip the rest of the line. */
731 skip_comment_line ();
732
733 return 1;
734 }
735
736
737 /* Return true if GCC$ was matched. */
738 static bool
skip_gcc_attribute(locus start)739 skip_gcc_attribute (locus start)
740 {
741 bool r = false;
742 char c;
743 locus old_loc = gfc_current_locus;
744
745 if ((c = next_char ()) == 'g' || c == 'G')
746 if ((c = next_char ()) == 'c' || c == 'C')
747 if ((c = next_char ()) == 'c' || c == 'C')
748 if ((c = next_char ()) == '$')
749 r = true;
750
751 if (r == false)
752 gfc_current_locus = old_loc;
753 else
754 {
755 gcc_attribute_flag = 1;
756 gcc_attribute_locus = old_loc;
757 gfc_current_locus = start;
758 }
759
760 return r;
761 }
762
763 /* Return true if CC was matched. */
764 static bool
skip_free_oacc_sentinel(locus start,locus old_loc)765 skip_free_oacc_sentinel (locus start, locus old_loc)
766 {
767 bool r = false;
768 char c;
769
770 if ((c = next_char ()) == 'c' || c == 'C')
771 if ((c = next_char ()) == 'c' || c == 'C')
772 r = true;
773
774 if (r)
775 {
776 if ((c = next_char ()) == ' ' || c == '\t'
777 || continue_flag)
778 {
779 while (gfc_is_whitespace (c))
780 c = next_char ();
781 if (c != '\n' && c != '!')
782 {
783 openacc_flag = 1;
784 openacc_locus = old_loc;
785 gfc_current_locus = start;
786 }
787 else
788 r = false;
789 }
790 else
791 {
792 gfc_warning_now (0, "!$ACC at %C starts a commented "
793 "line as it neither is followed "
794 "by a space nor is a "
795 "continuation line");
796 r = false;
797 }
798 }
799
800 return r;
801 }
802
803 /* Return true if MP was matched. */
804 static bool
skip_free_omp_sentinel(locus start,locus old_loc)805 skip_free_omp_sentinel (locus start, locus old_loc)
806 {
807 bool r = false;
808 char c;
809
810 if ((c = next_char ()) == 'm' || c == 'M')
811 if ((c = next_char ()) == 'p' || c == 'P')
812 r = true;
813
814 if (r)
815 {
816 if ((c = next_char ()) == ' ' || c == '\t'
817 || continue_flag)
818 {
819 while (gfc_is_whitespace (c))
820 c = next_char ();
821 if (c != '\n' && c != '!')
822 {
823 openmp_flag = 1;
824 openmp_locus = old_loc;
825 gfc_current_locus = start;
826 }
827 else
828 r = false;
829 }
830 else
831 {
832 gfc_warning_now (0, "!$OMP at %C starts a commented "
833 "line as it neither is followed "
834 "by a space nor is a "
835 "continuation line");
836 r = false;
837 }
838 }
839
840 return r;
841 }
842
843 /* Comment lines are null lines, lines containing only blanks or lines
844 on which the first nonblank line is a '!'.
845 Return true if !$ openmp or openacc conditional compilation sentinel was
846 seen. */
847
848 static bool
skip_free_comments(void)849 skip_free_comments (void)
850 {
851 locus start;
852 gfc_char_t c;
853 int at_bol;
854
855 for (;;)
856 {
857 at_bol = gfc_at_bol ();
858 start = gfc_current_locus;
859 if (gfc_at_eof ())
860 break;
861
862 do
863 c = next_char ();
864 while (gfc_is_whitespace (c));
865
866 if (c == '\n')
867 {
868 gfc_advance_line ();
869 continue;
870 }
871
872 if (c == '!')
873 {
874 /* Keep the !GCC$ line. */
875 if (at_bol && skip_gcc_attribute (start))
876 return false;
877
878 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
879 1) don't treat !$omp/!$acc as comments, but directives
880 2) handle OpenMP/OpenACC conditional compilation, where
881 !$ should be treated as 2 spaces (for initial lines
882 only if followed by space). */
883 if (at_bol)
884 {
885 if ((flag_openmp || flag_openmp_simd)
886 && flag_openacc)
887 {
888 locus old_loc = gfc_current_locus;
889 if (next_char () == '$')
890 {
891 c = next_char ();
892 if (c == 'o' || c == 'O')
893 {
894 if (skip_free_omp_sentinel (start, old_loc))
895 return false;
896 gfc_current_locus = old_loc;
897 next_char ();
898 c = next_char ();
899 }
900 else if (c == 'a' || c == 'A')
901 {
902 if (skip_free_oacc_sentinel (start, old_loc))
903 return false;
904 gfc_current_locus = old_loc;
905 next_char ();
906 c = next_char ();
907 }
908 if (continue_flag || c == ' ' || c == '\t')
909 {
910 gfc_current_locus = old_loc;
911 next_char ();
912 openmp_flag = openacc_flag = 0;
913 return true;
914 }
915 }
916 gfc_current_locus = old_loc;
917 }
918 else if ((flag_openmp || flag_openmp_simd)
919 && !flag_openacc)
920 {
921 locus old_loc = gfc_current_locus;
922 if (next_char () == '$')
923 {
924 c = next_char ();
925 if (c == 'o' || c == 'O')
926 {
927 if (skip_free_omp_sentinel (start, old_loc))
928 return false;
929 gfc_current_locus = old_loc;
930 next_char ();
931 c = next_char ();
932 }
933 if (continue_flag || c == ' ' || c == '\t')
934 {
935 gfc_current_locus = old_loc;
936 next_char ();
937 openmp_flag = 0;
938 return true;
939 }
940 }
941 gfc_current_locus = old_loc;
942 }
943 else if (flag_openacc
944 && !(flag_openmp || flag_openmp_simd))
945 {
946 locus old_loc = gfc_current_locus;
947 if (next_char () == '$')
948 {
949 c = next_char ();
950 if (c == 'a' || c == 'A')
951 {
952 if (skip_free_oacc_sentinel (start, old_loc))
953 return false;
954 gfc_current_locus = old_loc;
955 next_char();
956 c = next_char();
957 }
958 }
959 gfc_current_locus = old_loc;
960 }
961 }
962 skip_comment_line ();
963 continue;
964 }
965
966 break;
967 }
968
969 if (openmp_flag && at_bol)
970 openmp_flag = 0;
971
972 if (openacc_flag && at_bol)
973 openacc_flag = 0;
974
975 gcc_attribute_flag = 0;
976 gfc_current_locus = start;
977 return false;
978 }
979
980 /* Return true if MP was matched in fixed form. */
981 static bool
skip_fixed_omp_sentinel(locus * start)982 skip_fixed_omp_sentinel (locus *start)
983 {
984 gfc_char_t c;
985 if (((c = next_char ()) == 'm' || c == 'M')
986 && ((c = next_char ()) == 'p' || c == 'P'))
987 {
988 c = next_char ();
989 if (c != '\n'
990 && (continue_flag
991 || c == ' ' || c == '\t' || c == '0'))
992 {
993 if (c == ' ' || c == '\t' || c == '0')
994 openacc_flag = 0;
995 do
996 c = next_char ();
997 while (gfc_is_whitespace (c));
998 if (c != '\n' && c != '!')
999 {
1000 /* Canonicalize to *$omp. */
1001 *start->nextc = '*';
1002 openmp_flag = 1;
1003 gfc_current_locus = *start;
1004 return true;
1005 }
1006 }
1007 }
1008 return false;
1009 }
1010
1011 /* Return true if CC was matched in fixed form. */
1012 static bool
skip_fixed_oacc_sentinel(locus * start)1013 skip_fixed_oacc_sentinel (locus *start)
1014 {
1015 gfc_char_t c;
1016 if (((c = next_char ()) == 'c' || c == 'C')
1017 && ((c = next_char ()) == 'c' || c == 'C'))
1018 {
1019 c = next_char ();
1020 if (c != '\n'
1021 && (continue_flag
1022 || c == ' ' || c == '\t' || c == '0'))
1023 {
1024 if (c == ' ' || c == '\t' || c == '0')
1025 openmp_flag = 0;
1026 do
1027 c = next_char ();
1028 while (gfc_is_whitespace (c));
1029 if (c != '\n' && c != '!')
1030 {
1031 /* Canonicalize to *$acc. */
1032 *start->nextc = '*';
1033 openacc_flag = 1;
1034 gfc_current_locus = *start;
1035 return true;
1036 }
1037 }
1038 }
1039 return false;
1040 }
1041
1042 /* Skip comment lines in fixed source mode. We have the same rules as
1043 in skip_free_comment(), except that we can have a 'c', 'C' or '*'
1044 in column 1, and a '!' cannot be in column 6. Also, we deal with
1045 lines with 'd' or 'D' in column 1, if the user requested this. */
1046
1047 static void
skip_fixed_comments(void)1048 skip_fixed_comments (void)
1049 {
1050 locus start;
1051 int col;
1052 gfc_char_t c;
1053
1054 if (! gfc_at_bol ())
1055 {
1056 start = gfc_current_locus;
1057 if (! gfc_at_eof ())
1058 {
1059 do
1060 c = next_char ();
1061 while (gfc_is_whitespace (c));
1062
1063 if (c == '\n')
1064 gfc_advance_line ();
1065 else if (c == '!')
1066 skip_comment_line ();
1067 }
1068
1069 if (! gfc_at_bol ())
1070 {
1071 gfc_current_locus = start;
1072 return;
1073 }
1074 }
1075
1076 for (;;)
1077 {
1078 start = gfc_current_locus;
1079 if (gfc_at_eof ())
1080 break;
1081
1082 c = next_char ();
1083 if (c == '\n')
1084 {
1085 gfc_advance_line ();
1086 continue;
1087 }
1088
1089 if (c == '!' || c == 'c' || c == 'C' || c == '*')
1090 {
1091 if (skip_gcc_attribute (start))
1092 {
1093 /* Canonicalize to *$omp. */
1094 *start.nextc = '*';
1095 return;
1096 }
1097
1098 if (gfc_current_locus.lb != NULL
1099 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1100 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1101
1102 /* If -fopenmp/-fopenacc, we need to handle here 2 things:
1103 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
1104 but directives
1105 2) handle OpenMP/OpenACC conditional compilation, where
1106 !$|c$|*$ should be treated as 2 spaces if the characters
1107 in columns 3 to 6 are valid fixed form label columns
1108 characters. */
1109 if ((flag_openmp || flag_openmp_simd) && !flag_openacc)
1110 {
1111 if (next_char () == '$')
1112 {
1113 c = next_char ();
1114 if (c == 'o' || c == 'O')
1115 {
1116 if (skip_fixed_omp_sentinel (&start))
1117 return;
1118 }
1119 else
1120 goto check_for_digits;
1121 }
1122 gfc_current_locus = start;
1123 }
1124 else if (flag_openacc && !(flag_openmp || flag_openmp_simd))
1125 {
1126 if (next_char () == '$')
1127 {
1128 c = next_char ();
1129 if (c == 'a' || c == 'A')
1130 {
1131 if (skip_fixed_oacc_sentinel (&start))
1132 return;
1133 }
1134 }
1135 gfc_current_locus = start;
1136 }
1137 else if (flag_openacc || flag_openmp || flag_openmp_simd)
1138 {
1139 if (next_char () == '$')
1140 {
1141 c = next_char ();
1142 if (c == 'a' || c == 'A')
1143 {
1144 if (skip_fixed_oacc_sentinel (&start))
1145 return;
1146 }
1147 else if (c == 'o' || c == 'O')
1148 {
1149 if (skip_fixed_omp_sentinel (&start))
1150 return;
1151 }
1152 else
1153 goto check_for_digits;
1154 }
1155 gfc_current_locus = start;
1156 }
1157
1158 skip_comment_line ();
1159 continue;
1160
1161 check_for_digits:
1162 {
1163 /* Required for OpenMP's conditional compilation sentinel. */
1164 int digit_seen = 0;
1165
1166 for (col = 3; col < 6; col++, c = next_char ())
1167 if (c == ' ')
1168 continue;
1169 else if (c == '\t')
1170 {
1171 col = 6;
1172 break;
1173 }
1174 else if (c < '0' || c > '9')
1175 break;
1176 else
1177 digit_seen = 1;
1178
1179 if (col == 6 && c != '\n'
1180 && ((continue_flag && !digit_seen)
1181 || c == ' ' || c == '\t' || c == '0'))
1182 {
1183 gfc_current_locus = start;
1184 start.nextc[0] = ' ';
1185 start.nextc[1] = ' ';
1186 continue;
1187 }
1188 }
1189 skip_comment_line ();
1190 continue;
1191 }
1192
1193 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
1194 {
1195 if (gfc_option.flag_d_lines == 0)
1196 {
1197 skip_comment_line ();
1198 continue;
1199 }
1200 else
1201 *start.nextc = c = ' ';
1202 }
1203
1204 col = 1;
1205
1206 while (gfc_is_whitespace (c))
1207 {
1208 c = next_char ();
1209 col++;
1210 }
1211
1212 if (c == '\n')
1213 {
1214 gfc_advance_line ();
1215 continue;
1216 }
1217
1218 if (col != 6 && c == '!')
1219 {
1220 if (gfc_current_locus.lb != NULL
1221 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1222 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1223 skip_comment_line ();
1224 continue;
1225 }
1226
1227 break;
1228 }
1229
1230 openmp_flag = 0;
1231 openacc_flag = 0;
1232 gcc_attribute_flag = 0;
1233 gfc_current_locus = start;
1234 }
1235
1236
1237 /* Skips the current line if it is a comment. */
1238
1239 void
gfc_skip_comments(void)1240 gfc_skip_comments (void)
1241 {
1242 if (gfc_current_form == FORM_FREE)
1243 skip_free_comments ();
1244 else
1245 skip_fixed_comments ();
1246 }
1247
1248
1249 /* Get the next character from the input, taking continuation lines
1250 and end-of-line comments into account. This implies that comment
1251 lines between continued lines must be eaten here. For higher-level
1252 subroutines, this flattens continued lines into a single logical
1253 line. The in_string flag denotes whether we're inside a character
1254 context or not. */
1255
1256 gfc_char_t
gfc_next_char_literal(gfc_instring in_string)1257 gfc_next_char_literal (gfc_instring in_string)
1258 {
1259 static locus omp_acc_err_loc = {};
1260 locus old_loc;
1261 int i, prev_openmp_flag, prev_openacc_flag;
1262 gfc_char_t c;
1263
1264 continue_flag = 0;
1265 prev_openacc_flag = prev_openmp_flag = 0;
1266
1267 restart:
1268 c = next_char ();
1269 if (gfc_at_end ())
1270 {
1271 continue_count = 0;
1272 return c;
1273 }
1274
1275 if (gfc_current_form == FORM_FREE)
1276 {
1277 bool openmp_cond_flag;
1278
1279 if (!in_string && c == '!')
1280 {
1281 if (gcc_attribute_flag
1282 && memcmp (&gfc_current_locus, &gcc_attribute_locus,
1283 sizeof (gfc_current_locus)) == 0)
1284 goto done;
1285
1286 if (openmp_flag
1287 && memcmp (&gfc_current_locus, &openmp_locus,
1288 sizeof (gfc_current_locus)) == 0)
1289 goto done;
1290
1291 if (openacc_flag
1292 && memcmp (&gfc_current_locus, &openacc_locus,
1293 sizeof (gfc_current_locus)) == 0)
1294 goto done;
1295
1296 /* This line can't be continued */
1297 do
1298 {
1299 c = next_char ();
1300 }
1301 while (c != '\n');
1302
1303 /* Avoid truncation warnings for comment ending lines. */
1304 gfc_current_locus.lb->truncated = 0;
1305
1306 goto done;
1307 }
1308
1309 /* Check to see if the continuation line was truncated. */
1310 if (warn_line_truncation && gfc_current_locus.lb != NULL
1311 && gfc_current_locus.lb->truncated)
1312 {
1313 int maxlen = flag_free_line_length;
1314 gfc_char_t *current_nextc = gfc_current_locus.nextc;
1315
1316 gfc_current_locus.lb->truncated = 0;
1317 gfc_current_locus.nextc = gfc_current_locus.lb->line + maxlen;
1318 gfc_warning_now (OPT_Wline_truncation,
1319 "Line truncated at %L", &gfc_current_locus);
1320 gfc_current_locus.nextc = current_nextc;
1321 }
1322
1323 if (c != '&')
1324 goto done;
1325
1326 /* If the next nonblank character is a ! or \n, we've got a
1327 continuation line. */
1328 old_loc = gfc_current_locus;
1329
1330 c = next_char ();
1331 while (gfc_is_whitespace (c))
1332 c = next_char ();
1333
1334 /* Character constants to be continued cannot have commentary
1335 after the '&'. However, there are cases where we may think we
1336 are still in a string and we are looking for a possible
1337 doubled quote and we end up here. See PR64506. */
1338
1339 if (in_string && c != '\n')
1340 {
1341 gfc_current_locus = old_loc;
1342 c = '&';
1343 goto done;
1344 }
1345
1346 if (c != '!' && c != '\n')
1347 {
1348 gfc_current_locus = old_loc;
1349 c = '&';
1350 goto done;
1351 }
1352
1353 if (flag_openmp)
1354 prev_openmp_flag = openmp_flag;
1355 if (flag_openacc)
1356 prev_openacc_flag = openacc_flag;
1357
1358 /* This can happen if the input file changed or via cpp's #line
1359 without getting reset (e.g. via input_stmt). It also happens
1360 when pre-including files via -fpre-include=. */
1361 if (continue_count == 0
1362 && gfc_current_locus.lb
1363 && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1)
1364 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1;
1365
1366 continue_flag = 1;
1367 if (c == '!')
1368 skip_comment_line ();
1369 else
1370 gfc_advance_line ();
1371
1372 if (gfc_at_eof ())
1373 goto not_continuation;
1374
1375 /* We've got a continuation line. If we are on the very next line after
1376 the last continuation, increment the continuation line count and
1377 check whether the limit has been exceeded. */
1378 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1379 {
1380 if (++continue_count == gfc_option.max_continue_free)
1381 {
1382 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1383 gfc_warning (0, "Limit of %d continuations exceeded in "
1384 "statement at %C", gfc_option.max_continue_free);
1385 }
1386 }
1387
1388 /* Now find where it continues. First eat any comment lines. */
1389 openmp_cond_flag = skip_free_comments ();
1390
1391 if (gfc_current_locus.lb != NULL
1392 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1393 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1394
1395 if (flag_openmp)
1396 if (prev_openmp_flag != openmp_flag && !openacc_flag)
1397 {
1398 gfc_current_locus = old_loc;
1399 openmp_flag = prev_openmp_flag;
1400 c = '&';
1401 goto done;
1402 }
1403
1404 if (flag_openacc)
1405 if (prev_openacc_flag != openacc_flag && !openmp_flag)
1406 {
1407 gfc_current_locus = old_loc;
1408 openacc_flag = prev_openacc_flag;
1409 c = '&';
1410 goto done;
1411 }
1412
1413 /* Now that we have a non-comment line, probe ahead for the
1414 first non-whitespace character. If it is another '&', then
1415 reading starts at the next character, otherwise we must back
1416 up to where the whitespace started and resume from there. */
1417
1418 old_loc = gfc_current_locus;
1419
1420 c = next_char ();
1421 while (gfc_is_whitespace (c))
1422 c = next_char ();
1423
1424 if (openmp_flag && !openacc_flag)
1425 {
1426 for (i = 0; i < 5; i++, c = next_char ())
1427 {
1428 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1429 if (i == 4)
1430 old_loc = gfc_current_locus;
1431 }
1432 while (gfc_is_whitespace (c))
1433 c = next_char ();
1434 }
1435 if (openacc_flag && !openmp_flag)
1436 {
1437 for (i = 0; i < 5; i++, c = next_char ())
1438 {
1439 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$acc"[i]);
1440 if (i == 4)
1441 old_loc = gfc_current_locus;
1442 }
1443 while (gfc_is_whitespace (c))
1444 c = next_char ();
1445 }
1446
1447 /* In case we have an OpenMP directive continued by OpenACC
1448 sentinel, or vice versa, we get both openmp_flag and
1449 openacc_flag on. */
1450
1451 if (openacc_flag && openmp_flag)
1452 {
1453 int is_openmp = 0;
1454 for (i = 0; i < 5; i++, c = next_char ())
1455 {
1456 if (gfc_wide_tolower (c) != (unsigned char) "!$acc"[i])
1457 is_openmp = 1;
1458 }
1459 if (omp_acc_err_loc.nextc != gfc_current_locus.nextc
1460 || omp_acc_err_loc.lb != gfc_current_locus.lb)
1461 gfc_error_now (is_openmp
1462 ? G_("Wrong OpenACC continuation at %C: "
1463 "expected !$ACC, got !$OMP")
1464 : G_("Wrong OpenMP continuation at %C: "
1465 "expected !$OMP, got !$ACC"));
1466 omp_acc_err_loc = gfc_current_locus;
1467 goto not_continuation;
1468 }
1469
1470 if (c != '&')
1471 {
1472 if (in_string && gfc_current_locus.nextc)
1473 {
1474 gfc_current_locus.nextc--;
1475 if (warn_ampersand && in_string == INSTRING_WARN)
1476 gfc_warning (OPT_Wampersand,
1477 "Missing %<&%> in continued character "
1478 "constant at %C");
1479 }
1480 else if (!in_string && (c == '\'' || c == '"'))
1481 goto done;
1482 /* Both !$omp and !$ -fopenmp continuation lines have & on the
1483 continuation line only optionally. */
1484 else if (openmp_flag || openacc_flag || openmp_cond_flag)
1485 {
1486 if (gfc_current_locus.nextc)
1487 gfc_current_locus.nextc--;
1488 }
1489 else
1490 {
1491 c = ' ';
1492 gfc_current_locus = old_loc;
1493 goto done;
1494 }
1495 }
1496 }
1497 else /* Fixed form. */
1498 {
1499 /* Fixed form continuation. */
1500 if (in_string != INSTRING_WARN && c == '!')
1501 {
1502 /* Skip comment at end of line. */
1503 do
1504 {
1505 c = next_char ();
1506 }
1507 while (c != '\n');
1508
1509 /* Avoid truncation warnings for comment ending lines. */
1510 gfc_current_locus.lb->truncated = 0;
1511 }
1512
1513 if (c != '\n')
1514 goto done;
1515
1516 /* Check to see if the continuation line was truncated. */
1517 if (warn_line_truncation && gfc_current_locus.lb != NULL
1518 && gfc_current_locus.lb->truncated)
1519 {
1520 gfc_current_locus.lb->truncated = 0;
1521 gfc_warning_now (OPT_Wline_truncation,
1522 "Line truncated at %L", &gfc_current_locus);
1523 }
1524
1525 if (flag_openmp)
1526 prev_openmp_flag = openmp_flag;
1527 if (flag_openacc)
1528 prev_openacc_flag = openacc_flag;
1529
1530 /* This can happen if the input file changed or via cpp's #line
1531 without getting reset (e.g. via input_stmt). It also happens
1532 when pre-including files via -fpre-include=. */
1533 if (continue_count == 0
1534 && gfc_current_locus.lb
1535 && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1)
1536 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1;
1537
1538 continue_flag = 1;
1539 old_loc = gfc_current_locus;
1540
1541 gfc_advance_line ();
1542 skip_fixed_comments ();
1543
1544 /* See if this line is a continuation line. */
1545 if (flag_openmp && openmp_flag != prev_openmp_flag && !openacc_flag)
1546 {
1547 openmp_flag = prev_openmp_flag;
1548 goto not_continuation;
1549 }
1550 if (flag_openacc && openacc_flag != prev_openacc_flag && !openmp_flag)
1551 {
1552 openacc_flag = prev_openacc_flag;
1553 goto not_continuation;
1554 }
1555
1556 /* In case we have an OpenMP directive continued by OpenACC
1557 sentinel, or vice versa, we get both openmp_flag and
1558 openacc_flag on. */
1559 if (openacc_flag && openmp_flag)
1560 {
1561 int is_openmp = 0;
1562 for (i = 0; i < 5; i++)
1563 {
1564 c = next_char ();
1565 if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i])
1566 is_openmp = 1;
1567 }
1568 if (omp_acc_err_loc.nextc != gfc_current_locus.nextc
1569 || omp_acc_err_loc.lb != gfc_current_locus.lb)
1570 gfc_error_now (is_openmp
1571 ? G_("Wrong OpenACC continuation at %C: "
1572 "expected !$ACC, got !$OMP")
1573 : G_("Wrong OpenMP continuation at %C: "
1574 "expected !$OMP, got !$ACC"));
1575 omp_acc_err_loc = gfc_current_locus;
1576 goto not_continuation;
1577 }
1578 else if (!openmp_flag && !openacc_flag)
1579 for (i = 0; i < 5; i++)
1580 {
1581 c = next_char ();
1582 if (c != ' ')
1583 goto not_continuation;
1584 }
1585 else if (openmp_flag)
1586 for (i = 0; i < 5; i++)
1587 {
1588 c = next_char ();
1589 if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1590 goto not_continuation;
1591 }
1592 else if (openacc_flag)
1593 for (i = 0; i < 5; i++)
1594 {
1595 c = next_char ();
1596 if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i])
1597 goto not_continuation;
1598 }
1599
1600 c = next_char ();
1601 if (c == '0' || c == ' ' || c == '\n')
1602 goto not_continuation;
1603
1604 /* We've got a continuation line. If we are on the very next line after
1605 the last continuation, increment the continuation line count and
1606 check whether the limit has been exceeded. */
1607 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1608 {
1609 if (++continue_count == gfc_option.max_continue_fixed)
1610 {
1611 if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1612 gfc_warning (0, "Limit of %d continuations exceeded in "
1613 "statement at %C",
1614 gfc_option.max_continue_fixed);
1615 }
1616 }
1617
1618 if (gfc_current_locus.lb != NULL
1619 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1620 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1621 }
1622
1623 /* Ready to read first character of continuation line, which might
1624 be another continuation line! */
1625 goto restart;
1626
1627 not_continuation:
1628 c = '\n';
1629 gfc_current_locus = old_loc;
1630 end_flag = 0;
1631
1632 done:
1633 if (c == '\n')
1634 continue_count = 0;
1635 continue_flag = 0;
1636 return c;
1637 }
1638
1639
1640 /* Get the next character of input, folded to lowercase. In fixed
1641 form mode, we also ignore spaces. When matcher subroutines are
1642 parsing character literals, they have to call
1643 gfc_next_char_literal(). */
1644
1645 gfc_char_t
gfc_next_char(void)1646 gfc_next_char (void)
1647 {
1648 gfc_char_t c;
1649
1650 do
1651 {
1652 c = gfc_next_char_literal (NONSTRING);
1653 }
1654 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1655
1656 return gfc_wide_tolower (c);
1657 }
1658
1659 char
gfc_next_ascii_char(void)1660 gfc_next_ascii_char (void)
1661 {
1662 gfc_char_t c = gfc_next_char ();
1663
1664 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1665 : (unsigned char) UCHAR_MAX);
1666 }
1667
1668
1669 gfc_char_t
gfc_peek_char(void)1670 gfc_peek_char (void)
1671 {
1672 locus old_loc;
1673 gfc_char_t c;
1674
1675 old_loc = gfc_current_locus;
1676 c = gfc_next_char ();
1677 gfc_current_locus = old_loc;
1678
1679 return c;
1680 }
1681
1682
1683 char
gfc_peek_ascii_char(void)1684 gfc_peek_ascii_char (void)
1685 {
1686 gfc_char_t c = gfc_peek_char ();
1687
1688 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1689 : (unsigned char) UCHAR_MAX);
1690 }
1691
1692
1693 /* Recover from an error. We try to get past the current statement
1694 and get lined up for the next. The next statement follows a '\n'
1695 or a ';'. We also assume that we are not within a character
1696 constant, and deal with finding a '\'' or '"'. */
1697
1698 void
gfc_error_recovery(void)1699 gfc_error_recovery (void)
1700 {
1701 gfc_char_t c, delim;
1702
1703 if (gfc_at_eof ())
1704 return;
1705
1706 for (;;)
1707 {
1708 c = gfc_next_char ();
1709 if (c == '\n' || c == ';')
1710 break;
1711
1712 if (c != '\'' && c != '"')
1713 {
1714 if (gfc_at_eof ())
1715 break;
1716 continue;
1717 }
1718 delim = c;
1719
1720 for (;;)
1721 {
1722 c = next_char ();
1723
1724 if (c == delim)
1725 break;
1726 if (c == '\n')
1727 return;
1728 if (c == '\\')
1729 {
1730 c = next_char ();
1731 if (c == '\n')
1732 return;
1733 }
1734 }
1735 if (gfc_at_eof ())
1736 break;
1737 }
1738 }
1739
1740
1741 /* Read ahead until the next character to be read is not whitespace. */
1742
1743 void
gfc_gobble_whitespace(void)1744 gfc_gobble_whitespace (void)
1745 {
1746 static int linenum = 0;
1747 locus old_loc;
1748 gfc_char_t c;
1749
1750 do
1751 {
1752 old_loc = gfc_current_locus;
1753 c = gfc_next_char_literal (NONSTRING);
1754 /* Issue a warning for nonconforming tabs. We keep track of the line
1755 number because the Fortran matchers will often back up and the same
1756 line will be scanned multiple times. */
1757 if (warn_tabs && c == '\t')
1758 {
1759 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1760 if (cur_linenum != linenum)
1761 {
1762 linenum = cur_linenum;
1763 gfc_warning_now (OPT_Wtabs, "Nonconforming tab character at %C");
1764 }
1765 }
1766 }
1767 while (gfc_is_whitespace (c));
1768
1769 if (!ISPRINT(c) && c != '\n' && last_error_char != gfc_current_locus.nextc)
1770 {
1771 char buf[20];
1772 last_error_char = gfc_current_locus.nextc;
1773 snprintf (buf, 20, "%2.2X", c);
1774 gfc_error_now ("Invalid character 0x%s at %C", buf);
1775 }
1776
1777 gfc_current_locus = old_loc;
1778 }
1779
1780
1781 /* Load a single line into pbuf.
1782
1783 If pbuf points to a NULL pointer, it is allocated.
1784 We truncate lines that are too long, unless we're dealing with
1785 preprocessor lines or if the option -ffixed-line-length-none is set,
1786 in which case we reallocate the buffer to fit the entire line, if
1787 need be.
1788 In fixed mode, we expand a tab that occurs within the statement
1789 label region to expand to spaces that leave the next character in
1790 the source region.
1791
1792 If first_char is not NULL, it's a pointer to a single char value holding
1793 the first character of the line, which has already been read by the
1794 caller. This avoids the use of ungetc().
1795
1796 load_line returns whether the line was truncated.
1797
1798 NOTE: The error machinery isn't available at this point, so we can't
1799 easily report line and column numbers consistent with other
1800 parts of gfortran. */
1801
1802 static int
load_line(FILE * input,gfc_char_t ** pbuf,int * pbuflen,const int * first_char)1803 load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1804 {
1805 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1806 int quoted = ' ', comment_ix = -1;
1807 bool seen_comment = false;
1808 bool first_comment = true;
1809 bool trunc_flag = false;
1810 bool seen_printable = false;
1811 bool seen_ampersand = false;
1812 bool found_tab = false;
1813 bool warned_tabs = false;
1814 gfc_char_t *buffer;
1815
1816 /* Determine the maximum allowed line length. */
1817 if (gfc_current_form == FORM_FREE)
1818 maxlen = flag_free_line_length;
1819 else if (gfc_current_form == FORM_FIXED)
1820 maxlen = flag_fixed_line_length;
1821 else
1822 maxlen = 72;
1823
1824 if (*pbuf == NULL)
1825 {
1826 /* Allocate the line buffer, storing its length into buflen.
1827 Note that if maxlen==0, indicating that arbitrary-length lines
1828 are allowed, the buffer will be reallocated if this length is
1829 insufficient; since 132 characters is the length of a standard
1830 free-form line, we use that as a starting guess. */
1831 if (maxlen > 0)
1832 buflen = maxlen;
1833 else
1834 buflen = 132;
1835
1836 *pbuf = gfc_get_wide_string (buflen + 1);
1837 }
1838
1839 i = 0;
1840 buffer = *pbuf;
1841
1842 if (first_char)
1843 c = *first_char;
1844 else
1845 c = getc (input);
1846
1847 /* In order to not truncate preprocessor lines, we have to
1848 remember that this is one. */
1849 preprocessor_flag = (c == '#');
1850
1851 for (;;)
1852 {
1853 if (c == EOF)
1854 break;
1855
1856 if (c == '\n')
1857 {
1858 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1859 if (gfc_current_form == FORM_FREE
1860 && !seen_printable && seen_ampersand)
1861 {
1862 if (pedantic)
1863 gfc_error_now ("%<&%> not allowed by itself in line %d",
1864 current_file->line);
1865 else
1866 gfc_warning_now (0, "%<&%> not allowed by itself in line %d",
1867 current_file->line);
1868 }
1869 break;
1870 }
1871
1872 if (c == '\r' || c == '\0')
1873 goto next_char; /* Gobble characters. */
1874
1875 if (c == '&')
1876 {
1877 if (seen_ampersand)
1878 {
1879 seen_ampersand = false;
1880 seen_printable = true;
1881 }
1882 else
1883 seen_ampersand = true;
1884 }
1885
1886 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1887 seen_printable = true;
1888
1889 /* Is this a fixed-form comment? */
1890 if (gfc_current_form == FORM_FIXED && i == 0
1891 && (c == '*' || c == 'c' || c == 'C'
1892 || (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))))
1893 {
1894 seen_comment = true;
1895 comment_ix = i;
1896 }
1897
1898 if (quoted == ' ')
1899 {
1900 if (c == '\'' || c == '"')
1901 quoted = c;
1902 }
1903 else if (c == quoted)
1904 quoted = ' ';
1905
1906 /* Is this a free-form comment? */
1907 if (c == '!' && quoted == ' ')
1908 {
1909 if (seen_comment)
1910 first_comment = false;
1911 seen_comment = true;
1912 comment_ix = i;
1913 }
1914
1915 /* For truncation and tab warnings, set seen_comment to false if one has
1916 either an OpenMP or OpenACC directive - or a !GCC$ attribute. If
1917 OpenMP is enabled, use '!$' as conditional compilation sentinel
1918 and OpenMP directive ('!$omp'). */
1919 if (seen_comment && first_comment && flag_openmp && comment_ix + 1 == i
1920 && c == '$')
1921 first_comment = seen_comment = false;
1922 if (seen_comment && first_comment && comment_ix + 4 == i)
1923 {
1924 if (((*pbuf)[comment_ix+1] == 'g' || (*pbuf)[comment_ix+1] == 'G')
1925 && ((*pbuf)[comment_ix+2] == 'c' || (*pbuf)[comment_ix+2] == 'C')
1926 && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C')
1927 && c == '$')
1928 first_comment = seen_comment = false;
1929 if (flag_openacc
1930 && (*pbuf)[comment_ix+1] == '$'
1931 && ((*pbuf)[comment_ix+2] == 'a' || (*pbuf)[comment_ix+2] == 'A')
1932 && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C')
1933 && (c == 'c' || c == 'C'))
1934 first_comment = seen_comment = false;
1935 }
1936
1937 /* Vendor extension: "<tab>1" marks a continuation line. */
1938 if (found_tab)
1939 {
1940 found_tab = false;
1941 if (c >= '1' && c <= '9')
1942 {
1943 *(buffer-1) = c;
1944 goto next_char;
1945 }
1946 }
1947
1948 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1949 {
1950 found_tab = true;
1951
1952 if (warn_tabs && seen_comment == 0 && !warned_tabs)
1953 {
1954 warned_tabs = true;
1955 gfc_warning_now (OPT_Wtabs,
1956 "Nonconforming tab character in column %d "
1957 "of line %d", i + 1, current_file->line);
1958 }
1959
1960 while (i < 6)
1961 {
1962 *buffer++ = ' ';
1963 i++;
1964 }
1965
1966 goto next_char;
1967 }
1968
1969 *buffer++ = c;
1970 i++;
1971
1972 if (maxlen == 0 || preprocessor_flag)
1973 {
1974 if (i >= buflen)
1975 {
1976 /* Reallocate line buffer to double size to hold the
1977 overlong line. */
1978 buflen = buflen * 2;
1979 *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
1980 buffer = (*pbuf) + i;
1981 }
1982 }
1983 else if (i >= maxlen)
1984 {
1985 bool trunc_warn = true;
1986
1987 /* Enhancement, if the very next non-space character is an ampersand
1988 or comment that we would otherwise warn about, don't mark as
1989 truncated. */
1990
1991 /* Truncate the rest of the line. */
1992 for (;;)
1993 {
1994 c = getc (input);
1995 if (c == '\r' || c == ' ')
1996 continue;
1997
1998 if (c == '\n' || c == EOF)
1999 break;
2000
2001 if (!trunc_warn && c != '!')
2002 trunc_warn = true;
2003
2004 if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&')
2005 || c == '!'))
2006 trunc_warn = false;
2007
2008 if (c == '!')
2009 seen_comment = 1;
2010
2011 if (trunc_warn && !seen_comment)
2012 trunc_flag = 1;
2013 }
2014
2015 c = '\n';
2016 continue;
2017 }
2018
2019 next_char:
2020 c = getc (input);
2021 }
2022
2023 /* Pad lines to the selected line length in fixed form. */
2024 if (gfc_current_form == FORM_FIXED
2025 && flag_fixed_line_length != 0
2026 && flag_pad_source
2027 && !preprocessor_flag
2028 && c != EOF)
2029 {
2030 while (i++ < maxlen)
2031 *buffer++ = ' ';
2032 }
2033
2034 *buffer = '\0';
2035 *pbuflen = buflen;
2036
2037 return trunc_flag;
2038 }
2039
2040
2041 /* Get a gfc_file structure, initialize it and add it to
2042 the file stack. */
2043
2044 static gfc_file *
get_file(const char * name,enum lc_reason reason)2045 get_file (const char *name, enum lc_reason reason)
2046 {
2047 gfc_file *f;
2048
2049 f = XCNEW (gfc_file);
2050
2051 f->filename = xstrdup (name);
2052
2053 f->next = file_head;
2054 file_head = f;
2055
2056 f->up = current_file;
2057 if (current_file != NULL)
2058 f->inclusion_line = current_file->line;
2059
2060 linemap_add (line_table, reason, false, f->filename, 1);
2061
2062 return f;
2063 }
2064
2065
2066 /* Deal with a line from the C preprocessor. The
2067 initial octothorp has already been seen. */
2068
2069 static void
preprocessor_line(gfc_char_t * c)2070 preprocessor_line (gfc_char_t *c)
2071 {
2072 bool flag[5];
2073 int i, line;
2074 gfc_char_t *wide_filename;
2075 gfc_file *f;
2076 int escaped, unescape;
2077 char *filename;
2078
2079 c++;
2080 while (*c == ' ' || *c == '\t')
2081 c++;
2082
2083 if (*c < '0' || *c > '9')
2084 goto bad_cpp_line;
2085
2086 line = wide_atoi (c);
2087
2088 c = wide_strchr (c, ' ');
2089 if (c == NULL)
2090 {
2091 /* No file name given. Set new line number. */
2092 current_file->line = line;
2093 return;
2094 }
2095
2096 /* Skip spaces. */
2097 while (*c == ' ' || *c == '\t')
2098 c++;
2099
2100 /* Skip quote. */
2101 if (*c != '"')
2102 goto bad_cpp_line;
2103 ++c;
2104
2105 wide_filename = c;
2106
2107 /* Make filename end at quote. */
2108 unescape = 0;
2109 escaped = false;
2110 while (*c && ! (!escaped && *c == '"'))
2111 {
2112 if (escaped)
2113 escaped = false;
2114 else if (*c == '\\')
2115 {
2116 escaped = true;
2117 unescape++;
2118 }
2119 ++c;
2120 }
2121
2122 if (! *c)
2123 /* Preprocessor line has no closing quote. */
2124 goto bad_cpp_line;
2125
2126 *c++ = '\0';
2127
2128 /* Undo effects of cpp_quote_string. */
2129 if (unescape)
2130 {
2131 gfc_char_t *s = wide_filename;
2132 gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
2133
2134 wide_filename = d;
2135 while (*s)
2136 {
2137 if (*s == '\\')
2138 *d++ = *++s;
2139 else
2140 *d++ = *s;
2141 s++;
2142 }
2143 *d = '\0';
2144 }
2145
2146 /* Get flags. */
2147
2148 flag[1] = flag[2] = flag[3] = flag[4] = false;
2149
2150 for (;;)
2151 {
2152 c = wide_strchr (c, ' ');
2153 if (c == NULL)
2154 break;
2155
2156 c++;
2157 i = wide_atoi (c);
2158
2159 if (i >= 1 && i <= 4)
2160 flag[i] = true;
2161 }
2162
2163 /* Convert the filename in wide characters into a filename in narrow
2164 characters. */
2165 filename = gfc_widechar_to_char (wide_filename, -1);
2166
2167 /* Interpret flags. */
2168
2169 if (flag[1]) /* Starting new file. */
2170 {
2171 f = get_file (filename, LC_RENAME);
2172 add_file_change (f->filename, f->inclusion_line);
2173 current_file = f;
2174 }
2175
2176 if (flag[2]) /* Ending current file. */
2177 {
2178 if (!current_file->up
2179 || filename_cmp (current_file->up->filename, filename) != 0)
2180 {
2181 linemap_line_start (line_table, current_file->line, 80);
2182 /* ??? One could compute the exact column where the filename
2183 starts and compute the exact location here. */
2184 gfc_warning_now_at (linemap_position_for_column (line_table, 1),
2185 0, "file %qs left but not entered",
2186 filename);
2187 current_file->line++;
2188 if (unescape)
2189 free (wide_filename);
2190 free (filename);
2191 return;
2192 }
2193
2194 add_file_change (NULL, line);
2195 current_file = current_file->up;
2196 linemap_add (line_table, LC_RENAME, false, current_file->filename,
2197 current_file->line);
2198 }
2199
2200 /* The name of the file can be a temporary file produced by
2201 cpp. Replace the name if it is different. */
2202
2203 if (filename_cmp (current_file->filename, filename) != 0)
2204 {
2205 /* FIXME: we leak the old filename because a pointer to it may be stored
2206 in the linemap. Alternative could be using GC or updating linemap to
2207 point to the new name, but there is no API for that currently. */
2208 current_file->filename = xstrdup (filename);
2209
2210 /* We need to tell the linemap API that the filename changed. Just
2211 changing current_file is insufficient. */
2212 linemap_add (line_table, LC_RENAME, false, current_file->filename, line);
2213 }
2214
2215 /* Set new line number. */
2216 current_file->line = line;
2217 if (unescape)
2218 free (wide_filename);
2219 free (filename);
2220 return;
2221
2222 bad_cpp_line:
2223 linemap_line_start (line_table, current_file->line, 80);
2224 /* ??? One could compute the exact column where the directive
2225 starts and compute the exact location here. */
2226 gfc_warning_now_at (linemap_position_for_column (line_table, 2), 0,
2227 "Illegal preprocessor directive");
2228 current_file->line++;
2229 }
2230
2231
2232 static void load_file (const char *, const char *, bool);
2233
2234 /* include_line()-- Checks a line buffer to see if it is an include
2235 line. If so, we call load_file() recursively to load the included
2236 file. We never return a syntax error because a statement like
2237 "include = 5" is perfectly legal. We return 0 if no include was
2238 processed, 1 if we matched an include or -1 if include was
2239 partially processed, but will need continuation lines. */
2240
2241 static int
include_line(gfc_char_t * line)2242 include_line (gfc_char_t *line)
2243 {
2244 gfc_char_t quote, *c, *begin, *stop;
2245 char *filename;
2246 const char *include = "include";
2247 bool allow_continuation = flag_dec_include;
2248 int i;
2249
2250 c = line;
2251
2252 if (flag_openmp || flag_openmp_simd)
2253 {
2254 if (gfc_current_form == FORM_FREE)
2255 {
2256 while (*c == ' ' || *c == '\t')
2257 c++;
2258 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
2259 c += 3;
2260 }
2261 else
2262 {
2263 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
2264 && c[1] == '$' && c[2] == ' ')
2265 c += 3;
2266 }
2267 }
2268
2269 if (gfc_current_form == FORM_FREE)
2270 {
2271 while (*c == ' ' || *c == '\t')
2272 c++;
2273 if (gfc_wide_strncasecmp (c, "include", 7))
2274 {
2275 if (!allow_continuation)
2276 return 0;
2277 for (i = 0; i < 7; ++i)
2278 {
2279 gfc_char_t c1 = gfc_wide_tolower (*c);
2280 if (c1 != (unsigned char) include[i])
2281 break;
2282 c++;
2283 }
2284 if (i == 0 || *c != '&')
2285 return 0;
2286 c++;
2287 while (*c == ' ' || *c == '\t')
2288 c++;
2289 if (*c == '\0' || *c == '!')
2290 return -1;
2291 return 0;
2292 }
2293
2294 c += 7;
2295 }
2296 else
2297 {
2298 while (*c == ' ' || *c == '\t')
2299 c++;
2300 if (flag_dec_include && *c == '0' && c - line == 5)
2301 {
2302 c++;
2303 while (*c == ' ' || *c == '\t')
2304 c++;
2305 }
2306 if (c - line < 6)
2307 allow_continuation = false;
2308 for (i = 0; i < 7; ++i)
2309 {
2310 gfc_char_t c1 = gfc_wide_tolower (*c);
2311 if (c1 != (unsigned char) include[i])
2312 break;
2313 c++;
2314 while (*c == ' ' || *c == '\t')
2315 c++;
2316 }
2317 if (!allow_continuation)
2318 {
2319 if (i != 7)
2320 return 0;
2321 }
2322 else if (i != 7)
2323 {
2324 if (i == 0)
2325 return 0;
2326
2327 /* At the end of line or comment this might be continued. */
2328 if (*c == '\0' || *c == '!')
2329 return -1;
2330
2331 return 0;
2332 }
2333 }
2334
2335 while (*c == ' ' || *c == '\t')
2336 c++;
2337
2338 /* Find filename between quotes. */
2339
2340 quote = *c++;
2341 if (quote != '"' && quote != '\'')
2342 {
2343 if (allow_continuation)
2344 {
2345 if (gfc_current_form == FORM_FREE)
2346 {
2347 if (quote == '&')
2348 {
2349 while (*c == ' ' || *c == '\t')
2350 c++;
2351 if (*c == '\0' || *c == '!')
2352 return -1;
2353 }
2354 }
2355 else if (quote == '\0' || quote == '!')
2356 return -1;
2357 }
2358 return 0;
2359 }
2360
2361 begin = c;
2362
2363 bool cont = false;
2364 while (*c != quote && *c != '\0')
2365 {
2366 if (allow_continuation && gfc_current_form == FORM_FREE)
2367 {
2368 if (*c == '&')
2369 cont = true;
2370 else if (*c != ' ' && *c != '\t')
2371 cont = false;
2372 }
2373 c++;
2374 }
2375
2376 if (*c == '\0')
2377 {
2378 if (allow_continuation
2379 && (cont || gfc_current_form != FORM_FREE))
2380 return -1;
2381 return 0;
2382 }
2383
2384 stop = c++;
2385
2386 while (*c == ' ' || *c == '\t')
2387 c++;
2388
2389 if (*c != '\0' && *c != '!')
2390 return 0;
2391
2392 /* We have an include line at this point. */
2393
2394 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
2395 read by anything else. */
2396
2397 filename = gfc_widechar_to_char (begin, -1);
2398 load_file (filename, NULL, false);
2399 free (filename);
2400 return 1;
2401 }
2402
2403 /* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc.
2404 APIs. Return 1 if recognized as valid INCLUDE statement and load_file has
2405 been called, 0 if it is not a valid INCLUDE statement and -1 if eof has
2406 been encountered while parsing it. */
2407 static int
include_stmt(gfc_linebuf * b)2408 include_stmt (gfc_linebuf *b)
2409 {
2410 int ret = 0, i, length;
2411 const char *include = "include";
2412 gfc_char_t c, quote = 0;
2413 locus str_locus;
2414 char *filename;
2415
2416 continue_flag = 0;
2417 end_flag = 0;
2418 gcc_attribute_flag = 0;
2419 openmp_flag = 0;
2420 openacc_flag = 0;
2421 continue_count = 0;
2422 continue_line = 0;
2423 gfc_current_locus.lb = b;
2424 gfc_current_locus.nextc = b->line;
2425
2426 gfc_skip_comments ();
2427 gfc_gobble_whitespace ();
2428
2429 for (i = 0; i < 7; i++)
2430 {
2431 c = gfc_next_char ();
2432 if (c != (unsigned char) include[i])
2433 {
2434 if (gfc_current_form == FORM_FIXED
2435 && i == 0
2436 && c == '0'
2437 && gfc_current_locus.nextc == b->line + 6)
2438 {
2439 gfc_gobble_whitespace ();
2440 i--;
2441 continue;
2442 }
2443 gcc_assert (i != 0);
2444 if (c == '\n')
2445 {
2446 gfc_advance_line ();
2447 gfc_skip_comments ();
2448 if (gfc_at_eof ())
2449 ret = -1;
2450 }
2451 goto do_ret;
2452 }
2453 }
2454 gfc_gobble_whitespace ();
2455
2456 c = gfc_next_char ();
2457 if (c == '\'' || c == '"')
2458 quote = c;
2459 else
2460 {
2461 if (c == '\n')
2462 {
2463 gfc_advance_line ();
2464 gfc_skip_comments ();
2465 if (gfc_at_eof ())
2466 ret = -1;
2467 }
2468 goto do_ret;
2469 }
2470
2471 str_locus = gfc_current_locus;
2472 length = 0;
2473 do
2474 {
2475 c = gfc_next_char_literal (INSTRING_NOWARN);
2476 if (c == quote)
2477 break;
2478 if (c == '\n')
2479 {
2480 gfc_advance_line ();
2481 gfc_skip_comments ();
2482 if (gfc_at_eof ())
2483 ret = -1;
2484 goto do_ret;
2485 }
2486 length++;
2487 }
2488 while (1);
2489
2490 gfc_gobble_whitespace ();
2491 c = gfc_next_char ();
2492 if (c != '\n')
2493 goto do_ret;
2494
2495 gfc_current_locus = str_locus;
2496 ret = 1;
2497 filename = XNEWVEC (char, length + 1);
2498 for (i = 0; i < length; i++)
2499 {
2500 c = gfc_next_char_literal (INSTRING_WARN);
2501 gcc_assert (gfc_wide_fits_in_byte (c));
2502 filename[i] = (unsigned char) c;
2503 }
2504 filename[length] = '\0';
2505 load_file (filename, NULL, false);
2506 free (filename);
2507
2508 do_ret:
2509 continue_flag = 0;
2510 end_flag = 0;
2511 gcc_attribute_flag = 0;
2512 openmp_flag = 0;
2513 openacc_flag = 0;
2514 continue_count = 0;
2515 continue_line = 0;
2516 memset (&gfc_current_locus, '\0', sizeof (locus));
2517 memset (&openmp_locus, '\0', sizeof (locus));
2518 memset (&openacc_locus, '\0', sizeof (locus));
2519 memset (&gcc_attribute_locus, '\0', sizeof (locus));
2520 return ret;
2521 }
2522
2523
2524
2525 /* Load a file into memory by calling load_line until the file ends. */
2526
2527 static void
load_file(const char * realfilename,const char * displayedname,bool initial)2528 load_file (const char *realfilename, const char *displayedname, bool initial)
2529 {
2530 gfc_char_t *line;
2531 gfc_linebuf *b, *include_b = NULL;
2532 gfc_file *f;
2533 FILE *input;
2534 int len, line_len;
2535 bool first_line;
2536 struct stat st;
2537 int stat_result;
2538 const char *filename;
2539 /* If realfilename and displayedname are different and non-null then
2540 surely realfilename is the preprocessed form of
2541 displayedname. */
2542 bool preprocessed_p = (realfilename && displayedname
2543 && strcmp (realfilename, displayedname));
2544
2545 filename = displayedname ? displayedname : realfilename;
2546
2547 for (f = current_file; f; f = f->up)
2548 if (filename_cmp (filename, f->filename) == 0)
2549 fatal_error (linemap_line_start (line_table, current_file->line, 0),
2550 "File %qs is being included recursively", filename);
2551 if (initial)
2552 {
2553 if (gfc_src_file)
2554 {
2555 input = gfc_src_file;
2556 gfc_src_file = NULL;
2557 }
2558 else
2559 input = gfc_open_file (realfilename);
2560
2561 if (input == NULL)
2562 gfc_fatal_error ("Cannot open file %qs", filename);
2563 }
2564 else
2565 {
2566 input = gfc_open_included_file (realfilename, false, false);
2567 if (input == NULL)
2568 {
2569 /* For -fpre-include file, current_file is NULL. */
2570 if (current_file)
2571 fatal_error (linemap_line_start (line_table, current_file->line, 0),
2572 "Cannot open included file %qs", filename);
2573 else
2574 gfc_fatal_error ("Cannot open pre-included file %qs", filename);
2575 }
2576 stat_result = stat (realfilename, &st);
2577 if (stat_result == 0 && !S_ISREG (st.st_mode))
2578 {
2579 fclose (input);
2580 if (current_file)
2581 fatal_error (linemap_line_start (line_table, current_file->line, 0),
2582 "Included file %qs is not a regular file", filename);
2583 else
2584 gfc_fatal_error ("Included file %qs is not a regular file", filename);
2585 }
2586 }
2587
2588 /* Load the file.
2589
2590 A "non-initial" file means a file that is being included. In
2591 that case we are creating an LC_ENTER map.
2592
2593 An "initial" file means a main file; one that is not included.
2594 That file has already got at least one (surely more) line map(s)
2595 created by gfc_init. So the subsequent map created in that case
2596 must have LC_RENAME reason.
2597
2598 This latter case is not true for a preprocessed file. In that
2599 case, although the file is "initial", the line maps created by
2600 gfc_init was used during the preprocessing of the file. Now that
2601 the preprocessing is over and we are being fed the result of that
2602 preprocessing, we need to create a brand new line map for the
2603 preprocessed file, so the reason is going to be LC_ENTER. */
2604
2605 f = get_file (filename, (initial && !preprocessed_p) ? LC_RENAME : LC_ENTER);
2606 if (!initial)
2607 add_file_change (f->filename, f->inclusion_line);
2608 current_file = f;
2609 current_file->line = 1;
2610 line = NULL;
2611 line_len = 0;
2612 first_line = true;
2613
2614 if (initial && gfc_src_preprocessor_lines[0])
2615 {
2616 preprocessor_line (gfc_src_preprocessor_lines[0]);
2617 free (gfc_src_preprocessor_lines[0]);
2618 gfc_src_preprocessor_lines[0] = NULL;
2619 if (gfc_src_preprocessor_lines[1])
2620 {
2621 preprocessor_line (gfc_src_preprocessor_lines[1]);
2622 free (gfc_src_preprocessor_lines[1]);
2623 gfc_src_preprocessor_lines[1] = NULL;
2624 }
2625 }
2626
2627 for (;;)
2628 {
2629 int trunc = load_line (input, &line, &line_len, NULL);
2630 int inc_line;
2631
2632 len = gfc_wide_strlen (line);
2633 if (feof (input) && len == 0)
2634 break;
2635
2636 /* If this is the first line of the file, it can contain a byte
2637 order mark (BOM), which we will ignore:
2638 FF FE is UTF-16 little endian,
2639 FE FF is UTF-16 big endian,
2640 EF BB BF is UTF-8. */
2641 if (first_line
2642 && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
2643 && line[1] == (unsigned char) '\xFE')
2644 || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
2645 && line[1] == (unsigned char) '\xFF')
2646 || (line_len >= 3 && line[0] == (unsigned char) '\xEF'
2647 && line[1] == (unsigned char) '\xBB'
2648 && line[2] == (unsigned char) '\xBF')))
2649 {
2650 int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
2651 gfc_char_t *new_char = gfc_get_wide_string (line_len);
2652
2653 wide_strcpy (new_char, &line[n]);
2654 free (line);
2655 line = new_char;
2656 len -= n;
2657 }
2658
2659 /* There are three things this line can be: a line of Fortran
2660 source, an include line or a C preprocessor directive. */
2661
2662 if (line[0] == '#')
2663 {
2664 /* When -g3 is specified, it's possible that we emit #define
2665 and #undef lines, which we need to pass to the middle-end
2666 so that it can emit correct debug info. */
2667 if (debug_info_level == DINFO_LEVEL_VERBOSE
2668 && (wide_strncmp (line, "#define ", 8) == 0
2669 || wide_strncmp (line, "#undef ", 7) == 0))
2670 ;
2671 else
2672 {
2673 preprocessor_line (line);
2674 continue;
2675 }
2676 }
2677
2678 /* Preprocessed files have preprocessor lines added before the byte
2679 order mark, so first_line is not about the first line of the file
2680 but the first line that's not a preprocessor line. */
2681 first_line = false;
2682
2683 inc_line = include_line (line);
2684 if (inc_line > 0)
2685 {
2686 current_file->line++;
2687 continue;
2688 }
2689
2690 /* Add line. */
2691
2692 b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size
2693 + (len + 1) * sizeof (gfc_char_t));
2694
2695
2696 b->location
2697 = linemap_line_start (line_table, current_file->line++, len);
2698 /* ??? We add the location for the maximum column possible here,
2699 because otherwise if the next call creates a new line-map, it
2700 will not reserve space for any offset. */
2701 if (len > 0)
2702 linemap_position_for_column (line_table, len);
2703
2704 b->file = current_file;
2705 b->truncated = trunc;
2706 wide_strcpy (b->line, line);
2707
2708 if (line_head == NULL)
2709 line_head = b;
2710 else
2711 line_tail->next = b;
2712
2713 line_tail = b;
2714
2715 while (file_changes_cur < file_changes_count)
2716 file_changes[file_changes_cur++].lb = b;
2717
2718 if (flag_dec_include)
2719 {
2720 if (include_b && b != include_b)
2721 {
2722 int inc_line2 = include_stmt (include_b);
2723 if (inc_line2 == 0)
2724 include_b = NULL;
2725 else if (inc_line2 > 0)
2726 {
2727 do
2728 {
2729 if (gfc_current_form == FORM_FIXED)
2730 {
2731 for (gfc_char_t *p = include_b->line; *p; p++)
2732 *p = ' ';
2733 }
2734 else
2735 include_b->line[0] = '\0';
2736 if (include_b == b)
2737 break;
2738 include_b = include_b->next;
2739 }
2740 while (1);
2741 include_b = NULL;
2742 }
2743 }
2744 if (inc_line == -1 && !include_b)
2745 include_b = b;
2746 }
2747 }
2748
2749 /* Release the line buffer allocated in load_line. */
2750 free (line);
2751
2752 fclose (input);
2753
2754 if (!initial)
2755 add_file_change (NULL, current_file->inclusion_line + 1);
2756 current_file = current_file->up;
2757 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
2758 }
2759
2760
2761 /* Open a new file and start scanning from that file. Returns true
2762 if everything went OK, false otherwise. If form == FORM_UNKNOWN
2763 it tries to determine the source form from the filename, defaulting
2764 to free form. */
2765
2766 void
gfc_new_file(void)2767 gfc_new_file (void)
2768 {
2769 if (flag_pre_include != NULL)
2770 load_file (flag_pre_include, NULL, false);
2771
2772 if (gfc_cpp_enabled ())
2773 {
2774 gfc_cpp_preprocess (gfc_source_file);
2775 if (!gfc_cpp_preprocess_only ())
2776 load_file (gfc_cpp_temporary_file (), gfc_source_file, true);
2777 }
2778 else
2779 load_file (gfc_source_file, NULL, true);
2780
2781 gfc_current_locus.lb = line_head;
2782 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
2783
2784 #if 0 /* Debugging aid. */
2785 for (; line_head; line_head = line_head->next)
2786 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
2787 LOCATION_LINE (line_head->location), line_head->line);
2788
2789 exit (SUCCESS_EXIT_CODE);
2790 #endif
2791 }
2792
2793 static char *
unescape_filename(const char * ptr)2794 unescape_filename (const char *ptr)
2795 {
2796 const char *p = ptr, *s;
2797 char *d, *ret;
2798 int escaped, unescape = 0;
2799
2800 /* Make filename end at quote. */
2801 escaped = false;
2802 while (*p && ! (! escaped && *p == '"'))
2803 {
2804 if (escaped)
2805 escaped = false;
2806 else if (*p == '\\')
2807 {
2808 escaped = true;
2809 unescape++;
2810 }
2811 ++p;
2812 }
2813
2814 if (!*p || p[1])
2815 return NULL;
2816
2817 /* Undo effects of cpp_quote_string. */
2818 s = ptr;
2819 d = XCNEWVEC (char, p + 1 - ptr - unescape);
2820 ret = d;
2821
2822 while (s != p)
2823 {
2824 if (*s == '\\')
2825 *d++ = *++s;
2826 else
2827 *d++ = *s;
2828 s++;
2829 }
2830 *d = '\0';
2831 return ret;
2832 }
2833
2834 /* For preprocessed files, if the first tokens are of the form # NUM.
2835 handle the directives so we know the original file name. */
2836
2837 const char *
gfc_read_orig_filename(const char * filename,const char ** canon_source_file)2838 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
2839 {
2840 int c, len;
2841 char *dirname, *tmp;
2842
2843 gfc_src_file = gfc_open_file (filename);
2844 if (gfc_src_file == NULL)
2845 return NULL;
2846
2847 c = getc (gfc_src_file);
2848
2849 if (c != '#')
2850 return NULL;
2851
2852 len = 0;
2853 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c);
2854
2855 if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
2856 return NULL;
2857
2858 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1);
2859 filename = unescape_filename (tmp);
2860 free (tmp);
2861 if (filename == NULL)
2862 return NULL;
2863
2864 c = getc (gfc_src_file);
2865
2866 if (c != '#')
2867 return filename;
2868
2869 len = 0;
2870 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c);
2871
2872 if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
2873 return filename;
2874
2875 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1);
2876 dirname = unescape_filename (tmp);
2877 free (tmp);
2878 if (dirname == NULL)
2879 return filename;
2880
2881 len = strlen (dirname);
2882 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
2883 {
2884 free (dirname);
2885 return filename;
2886 }
2887 dirname[len - 2] = '\0';
2888 set_src_pwd (dirname);
2889
2890 if (! IS_ABSOLUTE_PATH (filename))
2891 {
2892 char *p = XCNEWVEC (char, len + strlen (filename));
2893
2894 memcpy (p, dirname, len - 2);
2895 p[len - 2] = '/';
2896 strcpy (p + len - 1, filename);
2897 *canon_source_file = p;
2898 }
2899
2900 free (dirname);
2901 return filename;
2902 }
2903