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