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