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