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 1349721361 : gfc_wide_fits_in_byte (gfc_char_t c)
91 : {
92 1349721361 : return (c <= UCHAR_MAX);
93 : }
94 :
95 : static inline int
96 683717967 : wide_is_ascii (gfc_char_t c)
97 : {
98 683717967 : 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 683585956 : gfc_wide_tolower (gfc_char_t c)
109 : {
110 683585956 : return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c);
111 : }
112 :
113 : gfc_char_t
114 132011 : gfc_wide_toupper (gfc_char_t c)
115 : {
116 132011 : return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c);
117 : }
118 :
119 : bool
120 12559594 : gfc_wide_is_digit (gfc_char_t c)
121 : {
122 12559594 : 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 6818655 : gfc_wide_strlen (const gfc_char_t *str)
140 : {
141 6818655 : size_t i;
142 :
143 304959747 : for (i = 0; str[i]; i++)
144 : ;
145 :
146 6818655 : return i;
147 : }
148 :
149 : gfc_char_t *
150 348068 : gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len)
151 : {
152 348068 : size_t i;
153 :
154 3091171 : for (i = 0; i < len; i++)
155 2743103 : b[i] = c;
156 :
157 348068 : return b;
158 : }
159 :
160 : static gfc_char_t *
161 6729339 : wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
162 : {
163 6729339 : gfc_char_t *d;
164 :
165 303900540 : for (d = dest; (*d = *src) != '\0'; ++src, ++d)
166 : ;
167 :
168 6729339 : 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 2667 : gfc_char_to_widechar (const char *s)
207 : {
208 2667 : size_t len, i;
209 2667 : gfc_char_t *res;
210 :
211 2667 : if (s == NULL)
212 : return NULL;
213 :
214 2667 : len = strlen (s);
215 2667 : res = gfc_get_wide_string (len + 1);
216 :
217 44222 : for (i = 0; i < len; i++)
218 38888 : res[i] = (unsigned char) s[i];
219 :
220 2667 : res[len] = '\0';
221 2667 : 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 6394554 : gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n)
243 : {
244 6394554 : gfc_char_t c1, c2;
245 :
246 6916019 : while (n-- > 0)
247 : {
248 6907162 : c1 = gfc_wide_tolower (*s1++);
249 6907162 : c2 = TOLOWER (*s2++);
250 6907162 : if (c1 != c2)
251 12238128 : return (c1 > c2 ? 1 : -1);
252 521465 : if (c1 == '\0')
253 : return 0;
254 : }
255 : return 0;
256 : }
257 :
258 :
259 : /* Main scanner initialization. */
260 :
261 : void
262 31458 : gfc_scanner_init_1 (void)
263 : {
264 31458 : file_head = NULL;
265 31458 : line_head = NULL;
266 31458 : line_tail = NULL;
267 :
268 31458 : continue_count = 0;
269 31458 : continue_line = 0;
270 :
271 31458 : end_flag = 0;
272 31458 : last_error_char = NULL;
273 31458 : }
274 :
275 :
276 : /* Main scanner destructor. */
277 :
278 : void
279 31439 : gfc_scanner_done_1 (void)
280 : {
281 31439 : gfc_linebuf *lb;
282 31439 : gfc_file *f;
283 :
284 6758098 : while(line_head != NULL)
285 : {
286 6726659 : lb = line_head->next;
287 6726659 : free (line_head);
288 6726659 : line_head = lb;
289 : }
290 :
291 96782 : while(file_head != NULL)
292 : {
293 65343 : f = file_head->next;
294 65343 : free (file_head->filename);
295 65343 : free (file_head);
296 65343 : file_head = f;
297 : }
298 31439 : }
299 :
300 : static bool
301 123818 : gfc_do_check_include_dir (const char *path, bool warn)
302 : {
303 123818 : struct stat st;
304 123818 : if (stat (path, &st))
305 : {
306 62891 : if (errno != ENOENT)
307 0 : gfc_warning_now (0, "Include directory %qs: %s",
308 : path, xstrerror(errno));
309 62891 : else if (warn)
310 14 : gfc_warning_now (OPT_Wmissing_include_dirs,
311 : "Nonexistent include directory %qs", path);
312 62891 : return false;
313 : }
314 60927 : 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 62920 : gfc_do_check_include_dirs (gfc_directorylist **list, bool do_warn)
326 : {
327 62920 : gfc_directorylist *prev, *q, *n;
328 62920 : prev = NULL;
329 62920 : n = *list;
330 120082 : while (n)
331 : {
332 57163 : q = n; n = n->next;
333 96118 : if (gfc_do_check_include_dir (q->path, q->warn && do_warn))
334 : {
335 25711 : prev = q;
336 25711 : continue;
337 : }
338 31451 : if (prev == NULL)
339 26879 : *list = n;
340 : else
341 4572 : prev->next = n;
342 31451 : free (q->path);
343 31451 : free (q);
344 : }
345 62919 : }
346 :
347 : void
348 31459 : 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 31459 : bool warn = !gfc_cpp_enabled () || !verbose_missing_dir_warn;
354 31459 : gfc_do_check_include_dirs (&include_dirs, warn);
355 31458 : gfc_do_check_include_dirs (&intrinsic_modules_dirs, verbose_missing_dir_warn);
356 31458 : if (gfc_option.module_dir && gfc_cpp_enabled ())
357 3 : gfc_do_check_include_dirs (&include_dirs, true);
358 31458 : }
359 :
360 : /* Adds path to the list pointed to by list. */
361 :
362 : static void
363 120060 : add_path_to_list (gfc_directorylist **list, const char *path,
364 : bool use_for_modules, bool head, bool warn, bool defer_warn)
365 : {
366 120060 : gfc_directorylist *dir;
367 120060 : const char *p;
368 120060 : char *q;
369 120060 : size_t len;
370 120060 : int i;
371 :
372 120060 : p = path;
373 120060 : 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 120060 : len = strlen (p);
380 120060 : q = (char *) alloca (len + 1);
381 120060 : memcpy (q, p, len + 1);
382 120060 : i = len - 1;
383 120579 : while (i >=0 && IS_DIR_SEPARATOR (q[i]))
384 519 : q[i--] = '\0';
385 :
386 120060 : if (!defer_warn && !gfc_do_check_include_dir (q, warn))
387 : return;
388 :
389 88620 : if (head || *list == NULL)
390 : {
391 66653 : dir = XCNEW (gfc_directorylist);
392 66653 : if (!head)
393 35197 : *list = dir;
394 : }
395 : else
396 : {
397 : dir = *list;
398 80813 : while (dir->next)
399 : dir = dir->next;
400 :
401 21967 : dir->next = XCNEW (gfc_directorylist);
402 21967 : dir = dir->next;
403 : }
404 :
405 57164 : dir->next = head ? *list : NULL;
406 57164 : if (head)
407 31456 : *list = dir;
408 88620 : dir->use_for_modules = use_for_modules;
409 88620 : dir->warn = warn;
410 88620 : dir->path = xstrdup (p);
411 : }
412 :
413 : /* defer_warn is set to true while parsing the commandline. */
414 :
415 : void
416 84863 : gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir,
417 : bool warn, bool defer_warn)
418 : {
419 84863 : 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 84863 : if (!file_dir)
424 53405 : gfc_cpp_add_include_path (xstrdup(path), true);
425 84863 : }
426 :
427 :
428 : void
429 35197 : gfc_add_intrinsic_modules_path (const char *path)
430 : {
431 35197 : add_path_to_list (&intrinsic_modules_dirs, path, true, false, false, false);
432 35197 : }
433 :
434 :
435 : /* Release resources allocated for options. */
436 :
437 : void
438 31439 : gfc_release_include_path (void)
439 : {
440 31439 : gfc_directorylist *p;
441 :
442 84824 : while (include_dirs != NULL)
443 : {
444 53385 : p = include_dirs;
445 53385 : include_dirs = include_dirs->next;
446 53385 : free (p->path);
447 53385 : free (p);
448 : }
449 :
450 35197 : while (intrinsic_modules_dirs != NULL)
451 : {
452 3758 : p = intrinsic_modules_dirs;
453 3758 : intrinsic_modules_dirs = intrinsic_modules_dirs->next;
454 3758 : free (p->path);
455 3758 : free (p);
456 : }
457 :
458 31439 : free (gfc_option.module_dir);
459 31439 : }
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 31810 : gfc_open_included_file (const char *name, bool include_cwd, bool module)
500 : {
501 31810 : FILE *f = NULL;
502 :
503 31810 : if (IS_ABSOLUTE_PATH (name) || include_cwd)
504 : {
505 31438 : f = gfc_open_file (name);
506 31438 : if (f && gfc_cpp_makedep ())
507 0 : gfc_cpp_add_dep (name, false);
508 : }
509 :
510 31438 : if (!f)
511 373 : f = open_included_file (name, include_dirs, module, false);
512 :
513 31810 : return f;
514 : }
515 :
516 :
517 : /* Test to see if we're at the end of the main source file. */
518 :
519 : bool
520 1211016818 : gfc_at_end (void)
521 : {
522 1211016818 : return end_flag;
523 : }
524 :
525 :
526 : /* Test to see if we're at the end of the current file. */
527 :
528 : bool
529 31865931 : gfc_at_eof (void)
530 : {
531 31865931 : if (gfc_at_end ())
532 : return 1;
533 :
534 31590469 : if (line_head == NULL)
535 : return 1; /* Null file */
536 :
537 31590469 : 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 15060367 : gfc_at_bol (void)
548 : {
549 15060367 : if (gfc_at_eof ())
550 : return 1;
551 :
552 14938762 : 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 4836458 : gfc_at_eol (void)
560 : {
561 4836458 : if (gfc_at_eof ())
562 : return 1;
563 :
564 4836454 : return (*gfc_current_locus.nextc == '\0');
565 : }
566 :
567 : static void
568 67870 : add_file_change (const char *filename, int line)
569 : {
570 67870 : if (file_changes_count == file_changes_allocated)
571 : {
572 31443 : if (file_changes_allocated)
573 1 : file_changes_allocated *= 2;
574 : else
575 31442 : file_changes_allocated = 16;
576 31443 : file_changes = XRESIZEVEC (struct gfc_file_change, file_changes,
577 : file_changes_allocated);
578 : }
579 67870 : file_changes[file_changes_count].filename = filename;
580 67870 : file_changes[file_changes_count].lb = NULL;
581 67870 : file_changes[file_changes_count++].line = line;
582 67870 : }
583 :
584 : static void
585 6760283 : report_file_change (gfc_linebuf *lb)
586 : {
587 6760283 : size_t c = file_changes_cur;
588 6760283 : while (c < file_changes_count
589 6828147 : && file_changes[c].lb == lb)
590 : {
591 67864 : if (file_changes[c].filename)
592 33932 : (*debug_hooks->start_source_file) (file_changes[c].line,
593 : file_changes[c].filename);
594 : else
595 33932 : (*debug_hooks->end_source_file) (file_changes[c].line);
596 67864 : ++c;
597 : }
598 6760283 : file_changes_cur = c;
599 6760283 : }
600 :
601 : void
602 31441 : gfc_start_source_files (void)
603 : {
604 : /* If the debugger wants the name of the main source file,
605 : we give it. */
606 31441 : if (debug_hooks->start_end_main_source_file)
607 5130 : (*debug_hooks->start_source_file) (0, gfc_source_file);
608 :
609 31441 : file_changes_cur = 0;
610 31441 : report_file_change (gfc_current_locus.u.lb);
611 31441 : }
612 :
613 : void
614 31395 : gfc_end_source_files (void)
615 : {
616 31395 : report_file_change (NULL);
617 :
618 31395 : if (debug_hooks->start_end_main_source_file)
619 5130 : (*debug_hooks->end_source_file) (0);
620 31395 : }
621 :
622 : /* Advance the current line pointer to the next line. */
623 :
624 : void
625 11511682 : gfc_advance_line (void)
626 : {
627 11511682 : if (gfc_at_end ())
628 : return;
629 :
630 11511672 : if (gfc_current_locus.u.lb == NULL)
631 : {
632 0 : end_flag = 1;
633 0 : return;
634 : }
635 :
636 11511672 : if (gfc_current_locus.u.lb->next
637 11357870 : && !gfc_current_locus.u.lb->next->dbg_emitted)
638 : {
639 6697447 : report_file_change (gfc_current_locus.u.lb->next);
640 6697447 : gfc_current_locus.u.lb->next->dbg_emitted = true;
641 : }
642 :
643 11511672 : gfc_current_locus.u.lb = gfc_current_locus.u.lb->next;
644 :
645 11511672 : if (gfc_current_locus.u.lb != NULL)
646 11357870 : gfc_current_locus.nextc = gfc_current_locus.u.lb->line;
647 : else
648 : {
649 153802 : gfc_current_locus.nextc = NULL;
650 153802 : 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 1394899058 : next_char (void)
666 : {
667 1394899058 : gfc_char_t c;
668 :
669 1394899058 : if (gfc_current_locus.nextc == NULL)
670 : return '\n';
671 :
672 1394776728 : c = *gfc_current_locus.nextc++;
673 1394776728 : if (c == '\0')
674 : {
675 43041516 : gfc_current_locus.nextc--; /* Remain on this line. */
676 43041516 : 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 1388773 : skip_comment_line (void)
690 : {
691 81894394 : gfc_char_t c;
692 :
693 81894394 : do
694 : {
695 81894394 : c = next_char ();
696 : }
697 81894394 : while (c != '\n');
698 :
699 1388773 : gfc_advance_line ();
700 1388773 : }
701 :
702 :
703 : bool
704 4805026 : gfc_define_undef_line (void)
705 : {
706 4805026 : char *tmp;
707 :
708 : /* All lines beginning with '#' are either #define or #undef. */
709 4805026 : if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#')
710 4805018 : 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 5111613 : skip_gcc_attribute (locus start)
738 : {
739 5111613 : bool r = false;
740 5111613 : char c;
741 5111613 : locus old_loc = gfc_current_locus;
742 :
743 5111613 : if ((c = next_char ()) == 'g' || c == 'G')
744 3638027 : if ((c = next_char ()) == 'c' || c == 'C')
745 3635967 : if ((c = next_char ()) == 'c' || c == 'C')
746 3635967 : if ((c = next_char ()) == '$')
747 3635967 : r = true;
748 :
749 3635967 : if (r == false)
750 1475646 : gfc_current_locus = old_loc;
751 : else
752 : {
753 3635967 : gcc_attribute_flag = 1;
754 3635967 : gcc_attribute_locus = old_loc;
755 3635967 : gfc_current_locus = start;
756 : }
757 :
758 5111613 : 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 39087 : skip_free_omp_sentinel (locus start, locus old_loc)
806 : {
807 39087 : bool r = false;
808 39087 : char c;
809 :
810 39087 : if ((c = next_char ()) == 'm' || c == 'M')
811 39086 : if ((c = next_char ()) == 'p' || c == 'P')
812 39086 : r = true;
813 :
814 39086 : if (r)
815 : {
816 41174 : if ((c = next_char ()) == ' ' || c == '\t'
817 41173 : || continue_flag)
818 : {
819 39082 : if (!continue_flag && (c == ' ' || c == '\t'))
820 32629 : openacc_flag = 0;
821 78548 : while (gfc_is_whitespace (c))
822 39466 : c = next_char ();
823 39082 : if (c != '\n' && c != '!')
824 : {
825 39082 : openmp_flag = 1;
826 39082 : openmp_locus = old_loc;
827 39082 : 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 39087 : 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 4820508 : skip_free_comments (void)
852 : {
853 6683716 : locus start;
854 6683716 : gfc_char_t c;
855 6683716 : int at_bol;
856 :
857 6683716 : for (;;)
858 : {
859 6683716 : at_bol = gfc_at_bol ();
860 6683716 : start = gfc_current_locus;
861 6683716 : if (gfc_at_eof ())
862 : break;
863 :
864 14349261 : do
865 14349261 : c = next_char ();
866 14349261 : while (gfc_is_whitespace (c));
867 :
868 6654036 : if (c == '\n')
869 : {
870 1153152 : gfc_advance_line ();
871 1153152 : continue;
872 : }
873 :
874 5500884 : if (c == '!')
875 : {
876 : /* Keep the !GCC$ line. */
877 3975029 : 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 769983 : if (at_bol)
886 : {
887 769912 : if ((flag_openmp || flag_openmp_simd)
888 107598 : && 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 769281 : else if ((flag_openmp || flag_openmp_simd)
921 106967 : && !flag_openacc)
922 : {
923 106967 : locus old_loc = gfc_current_locus;
924 106967 : if (next_char () == '$')
925 : {
926 39437 : c = next_char ();
927 39437 : if (c == 'o' || c == 'O')
928 : {
929 38976 : if (skip_free_omp_sentinel (start, old_loc))
930 39382 : 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 67585 : gfc_current_locus = old_loc;
944 67585 : }
945 662314 : 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 710056 : skip_comment_line ();
965 710056 : continue;
966 710056 : }
967 :
968 : break;
969 : }
970 :
971 1555535 : if (openmp_flag && at_bol)
972 22552 : openmp_flag = 0;
973 :
974 1555535 : if (openacc_flag && at_bol)
975 11965 : openacc_flag = 0;
976 :
977 1555535 : gcc_attribute_flag = 0;
978 1555535 : gfc_current_locus = start;
979 1555535 : 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 3571585 : skip_fixed_comments (void)
1055 : {
1056 3571585 : locus start;
1057 3571585 : int col;
1058 3571585 : gfc_char_t c;
1059 :
1060 3571585 : 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 482157 : return;
1079 : }
1080 : }
1081 :
1082 4897522 : for (;;)
1083 : {
1084 4897522 : start = gfc_current_locus;
1085 4897522 : if (gfc_at_eof ())
1086 : break;
1087 :
1088 4773413 : c = next_char ();
1089 4773413 : if (c == '\n')
1090 : {
1091 4779 : gfc_advance_line ();
1092 4779 : continue;
1093 : }
1094 :
1095 : if (c == '!' || c == 'c' || c == 'C' || c == '*')
1096 : {
1097 1136655 : if (skip_gcc_attribute (start))
1098 : {
1099 : /* Canonicalize to *$omp. */
1100 430921 : *start.nextc = '*';
1101 430921 : return;
1102 : }
1103 :
1104 705734 : if (gfc_current_locus.u.lb != NULL
1105 705734 : && continue_line < gfc_linebuf_linenum (gfc_current_locus.u.lb))
1106 542888 : 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 705734 : 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 637217 : 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 483677 : 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 653849 : skip_comment_line ();
1165 653849 : 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 654498 : }
1198 :
1199 3631979 : 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 72256267 : while (gfc_is_whitespace (c))
1213 : {
1214 68624296 : c = next_char ();
1215 68624296 : col++;
1216 : }
1217 :
1218 3631971 : if (c == '\n')
1219 : {
1220 656285 : gfc_advance_line ();
1221 656285 : continue;
1222 : }
1223 :
1224 2975686 : 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 3089428 : openmp_flag = 0;
1237 3089428 : openacc_flag = 0;
1238 3089428 : gcc_attribute_flag = 0;
1239 3089428 : gfc_current_locus = start;
1240 : }
1241 :
1242 :
1243 : /* Skips the current line if it is a comment. */
1244 :
1245 : void
1246 4836561 : gfc_skip_comments (void)
1247 : {
1248 4836561 : if (gfc_current_form == FORM_FREE)
1249 4558242 : skip_free_comments ();
1250 : else
1251 278319 : skip_fixed_comments ();
1252 4836561 : }
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 1162737198 : gfc_next_char_literal (gfc_instring in_string)
1264 : {
1265 1162737198 : static locus omp_acc_err_loc = {};
1266 1162737198 : locus old_loc;
1267 1162737198 : int i, prev_openmp_flag, prev_openacc_flag;
1268 1162737198 : gfc_char_t c;
1269 :
1270 1162737198 : continue_flag = 0;
1271 1162737198 : prev_openacc_flag = prev_openmp_flag = 0;
1272 :
1273 1162802747 : restart:
1274 1162802747 : c = next_char ();
1275 1162802747 : if (gfc_at_end ())
1276 : {
1277 170 : continue_count = 0;
1278 170 : return c;
1279 : }
1280 :
1281 1162802577 : if (gfc_current_form == FORM_FREE)
1282 : {
1283 1042193046 : bool openmp_cond_flag;
1284 :
1285 1042193046 : if (!in_string && c == '!')
1286 : {
1287 10408022 : if (gcc_attribute_flag
1288 9616086 : && memcmp (&gfc_current_locus, &gcc_attribute_locus,
1289 : sizeof (gfc_current_locus)) == 0)
1290 9615570 : goto done;
1291 :
1292 792452 : if (openmp_flag
1293 111527 : && memcmp (&gfc_current_locus, &openmp_locus,
1294 : sizeof (gfc_current_locus)) == 0)
1295 97887 : goto done;
1296 :
1297 694565 : 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 22533536 : do
1304 : {
1305 22533536 : c = next_char ();
1306 : }
1307 22533536 : while (c != '\n');
1308 :
1309 : /* Avoid truncation warnings for comment ending lines. */
1310 635048 : gfc_current_locus.u.lb->truncated = 0;
1311 :
1312 635048 : goto done;
1313 : }
1314 :
1315 : /* Check to see if the continuation line was truncated. */
1316 1031785024 : if (warn_line_truncation && gfc_current_locus.u.lb != NULL
1317 1031693720 : && 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 1031785024 : if (c != '&')
1330 1031518398 : goto done;
1331 :
1332 : /* If the next nonblank character is a ! or \n, we've got a
1333 : continuation line. */
1334 266626 : old_loc = gfc_current_locus;
1335 :
1336 266626 : c = next_char ();
1337 554896 : 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 266626 : if (in_string && c != '\n')
1346 : {
1347 4142 : gfc_current_locus = old_loc;
1348 4142 : c = '&';
1349 4142 : goto done;
1350 : }
1351 :
1352 262484 : if (c != '!' && c != '\n')
1353 : {
1354 195 : gfc_current_locus = old_loc;
1355 195 : c = '&';
1356 195 : goto done;
1357 : }
1358 :
1359 262289 : if (flag_openmp)
1360 27483 : prev_openmp_flag = openmp_flag;
1361 262289 : 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 262289 : if (continue_count == 0
1368 118954 : && gfc_current_locus.u.lb
1369 381243 : && continue_line > gfc_linebuf_linenum (gfc_current_locus.u.lb) + 1)
1370 3941 : continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb) + 1;
1371 :
1372 262289 : continue_flag = 1;
1373 262289 : if (c == '!')
1374 13835 : skip_comment_line ();
1375 : else
1376 248454 : gfc_advance_line ();
1377 :
1378 262289 : 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 262266 : if (gfc_linebuf_linenum (gfc_current_locus.u.lb) == continue_line + 1)
1385 : {
1386 20848 : 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 262266 : openmp_cond_flag = skip_free_comments ();
1396 :
1397 262266 : if (gfc_current_locus.u.lb != NULL
1398 262266 : && continue_line < gfc_linebuf_linenum (gfc_current_locus.u.lb))
1399 36790 : continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb);
1400 :
1401 262266 : if (flag_openmp)
1402 27478 : 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 261988 : 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 261983 : old_loc = gfc_current_locus;
1425 :
1426 261983 : c = next_char ();
1427 3944839 : while (gfc_is_whitespace (c))
1428 3420873 : c = next_char ();
1429 :
1430 261983 : 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 261983 : 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 261983 : 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 261921 : if (c != '&')
1477 : {
1478 244087 : 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 244042 : 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 157432 : 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 154669 : c = ' ';
1498 154669 : gfc_current_locus = old_loc;
1499 154669 : goto done;
1500 : }
1501 : }
1502 : }
1503 : else /* Fixed form. */
1504 : {
1505 : /* Fixed form continuation. */
1506 120609531 : 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 120609531 : if (c != '\n')
1520 117316265 : goto done;
1521 :
1522 : /* Check to see if the continuation line was truncated. */
1523 3293266 : 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 3293266 : if (flag_openmp)
1532 460572 : prev_openmp_flag = openmp_flag;
1533 3293266 : 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 3293266 : if (continue_count == 0
1540 3263176 : && gfc_current_locus.u.lb
1541 6556442 : && continue_line > gfc_linebuf_linenum (gfc_current_locus.u.lb) + 1)
1542 89227 : continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb) + 1;
1543 :
1544 3293266 : continue_flag = 1;
1545 3293266 : old_loc = gfc_current_locus;
1546 :
1547 3293266 : gfc_advance_line ();
1548 3293266 : skip_fixed_comments ();
1549 :
1550 : /* See if this line is a continuation line. */
1551 3293266 : 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 3282282 : 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 3239879 : 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 3239793 : else if (!openmp_flag && !openacc_flag)
1585 17232146 : for (i = 0; i < 5; i++)
1586 : {
1587 14475051 : c = next_char ();
1588 14475051 : if (c != ' ')
1589 480456 : 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 2759337 : c = next_char ();
1607 2759337 : if (c == '0' || c == ' ' || c == '\n')
1608 2714429 : 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 3248443 : not_continuation:
1634 3248443 : c = '\n';
1635 3248443 : gfc_current_locus = old_loc;
1636 3248443 : end_flag = 0;
1637 :
1638 1162737028 : done:
1639 1162737028 : if (c == '\n')
1640 39407165 : continue_count = 0;
1641 1162737028 : continue_flag = 0;
1642 1162737028 : 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 676204096 : gfc_next_char (void)
1653 : {
1654 704349766 : gfc_char_t c;
1655 :
1656 704349766 : do
1657 : {
1658 704349766 : c = gfc_next_char_literal (NONSTRING);
1659 : }
1660 704349766 : while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1661 :
1662 676204096 : return gfc_wide_tolower (c);
1663 : }
1664 :
1665 : char
1666 627231664 : gfc_next_ascii_char (void)
1667 : {
1668 627231664 : gfc_char_t c = gfc_next_char ();
1669 :
1670 627231664 : return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1671 627231664 : : (unsigned char) UCHAR_MAX);
1672 : }
1673 :
1674 :
1675 : gfc_char_t
1676 38278817 : gfc_peek_char (void)
1677 : {
1678 38278817 : locus old_loc;
1679 38278817 : gfc_char_t c;
1680 :
1681 38278817 : old_loc = gfc_current_locus;
1682 38278817 : c = gfc_next_char ();
1683 38278817 : gfc_current_locus = old_loc;
1684 :
1685 38278817 : return c;
1686 : }
1687 :
1688 :
1689 : char
1690 38265874 : gfc_peek_ascii_char (void)
1691 : {
1692 38265874 : gfc_char_t c = gfc_peek_char ();
1693 :
1694 38265874 : return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1695 38265874 : : (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 350446011 : gfc_gobble_whitespace (void)
1751 : {
1752 436984020 : static int linenum = 0;
1753 436984020 : locus old_loc;
1754 436984020 : gfc_char_t c;
1755 :
1756 436984020 : do
1757 : {
1758 436984020 : old_loc = gfc_current_locus;
1759 436984020 : 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 436984020 : 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 436984020 : while (gfc_is_whitespace (c));
1774 :
1775 350446011 : 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 350446011 : gfc_current_locus = old_loc;
1784 350446011 : }
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 6801868 : load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1810 : {
1811 6801868 : int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1812 6801868 : int quoted = ' ', comment_ix = -1;
1813 6801868 : bool seen_comment = false;
1814 6801868 : bool first_comment = true;
1815 6801868 : bool trunc_flag = false;
1816 6801868 : bool seen_printable = false;
1817 6801868 : bool seen_ampersand = false;
1818 6801868 : bool found_tab = false;
1819 6801868 : bool warned_tabs = false;
1820 6801868 : gfc_char_t *buffer;
1821 :
1822 : /* Determine the maximum allowed line length. */
1823 6801868 : if (gfc_current_form == FORM_FREE)
1824 6449079 : maxlen = flag_free_line_length;
1825 352789 : else if (gfc_current_form == FORM_FIXED)
1826 352789 : maxlen = flag_fixed_line_length;
1827 : else
1828 : maxlen = 72;
1829 :
1830 6801868 : 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 63260 : if (maxlen > 0)
1838 : buflen = maxlen;
1839 : else
1840 308 : buflen = 132;
1841 :
1842 63260 : *pbuf = gfc_get_wide_string (buflen + 1);
1843 : }
1844 :
1845 6801868 : i = 0;
1846 6801868 : buffer = *pbuf;
1847 :
1848 6801868 : if (first_char)
1849 10 : c = *first_char;
1850 : else
1851 6801858 : c = getc (input);
1852 :
1853 : /* In order to not truncate preprocessor lines, we have to
1854 : remember that this is one. */
1855 6801868 : preprocessor_flag = (c == '#');
1856 :
1857 296703287 : for (;;)
1858 : {
1859 296703287 : 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 6738490 : if (gfc_current_form == FORM_FREE
1866 6389342 : && !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 40153 : if (seen_ampersand)
1884 : {
1885 : seen_ampersand = false;
1886 : seen_printable = true;
1887 : }
1888 : else
1889 37578 : seen_ampersand = true;
1890 : }
1891 :
1892 289890464 : if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1893 252355477 : seen_printable = true;
1894 :
1895 : /* Is this a fixed-form comment? */
1896 289890464 : if (gfc_current_form == FORM_FIXED && i == 0
1897 333677 : && (c == '*' || c == 'c' || c == 'C'
1898 319566 : || (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))))
1899 : {
1900 289890464 : seen_comment = true;
1901 289890464 : comment_ix = i;
1902 : }
1903 :
1904 289890464 : if (quoted == ' ')
1905 : {
1906 267544319 : if (c == '\'' || c == '"')
1907 289890464 : quoted = c;
1908 : }
1909 22346145 : else if (c == quoted)
1910 267534698 : quoted = ' ';
1911 :
1912 : /* Is this a free-form comment? */
1913 289890464 : if (c == '!' && quoted == ' ')
1914 : {
1915 4239327 : 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 289885291 : if (seen_comment && first_comment && flag_openmp && comment_ix + 1 == i
1926 429904 : && c == '$')
1927 : first_comment = seen_comment = false;
1928 289854894 : if (seen_comment && first_comment && comment_ix + 4 == i)
1929 : {
1930 4071336 : if (((*pbuf)[comment_ix+1] == 'g' || (*pbuf)[comment_ix+1] == 'G')
1931 3400293 : && ((*pbuf)[comment_ix+2] == 'c' || (*pbuf)[comment_ix+2] == 'C')
1932 3398234 : && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C')
1933 3398234 : && c == '$')
1934 4071336 : first_comment = seen_comment = false;
1935 4071336 : 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 289890464 : first_comment = seen_comment = false;
1941 : }
1942 :
1943 : /* Vendor extension: "<tab>1" marks a continuation line. */
1944 289890464 : 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 289890463 : 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 289890357 : *buffer++ = c;
1976 289890357 : i++;
1977 :
1978 289890357 : 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 286777585 : 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 113603 : for (;;)
1999 : {
2000 113603 : c = getc (input);
2001 113603 : if (c == '\r' || c == ' ')
2002 48730 : continue;
2003 :
2004 64873 : if (c == '\n' || c == EOF)
2005 : break;
2006 :
2007 56084 : if (!trunc_warn && c != '!')
2008 : trunc_warn = true;
2009 :
2010 56084 : if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&')
2011 54383 : || c == '!'))
2012 : trunc_warn = false;
2013 :
2014 1 : if (c == '!')
2015 65 : seen_comment = 1;
2016 :
2017 56084 : if (trunc_warn && !seen_comment)
2018 8452 : trunc_flag = 1;
2019 : }
2020 :
2021 8789 : c = '\n';
2022 8789 : continue;
2023 8789 : }
2024 :
2025 286768796 : next_char:
2026 289892630 : c = getc (input);
2027 : }
2028 :
2029 : /* Pad lines to the selected line length in fixed form. */
2030 6801868 : if (gfc_current_form == FORM_FIXED
2031 352789 : && flag_fixed_line_length != 0
2032 348763 : && flag_pad_source
2033 347941 : && !preprocessor_flag
2034 347941 : && c != EOF)
2035 : {
2036 8122566 : while (i++ < maxlen)
2037 7778545 : *buffer++ = ' ';
2038 : }
2039 :
2040 6801868 : *buffer = '\0';
2041 6801868 : *pbuflen = buflen;
2042 :
2043 6801868 : 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 65379 : get_file (const char *name, enum lc_reason reason)
2052 : {
2053 65379 : gfc_file *f;
2054 :
2055 65379 : f = XCNEW (gfc_file);
2056 :
2057 65379 : f->filename = xstrdup (name);
2058 :
2059 65379 : f->next = file_head;
2060 65379 : file_head = f;
2061 :
2062 65379 : f->up = current_file;
2063 65379 : if (current_file != NULL)
2064 2493 : f->inclusion_line = current_file->line;
2065 :
2066 65379 : linemap_add (line_table, reason, false, f->filename, 1);
2067 :
2068 65379 : 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 6729678 : include_line (gfc_char_t *line)
2249 : {
2250 6729678 : gfc_char_t quote, *c, *begin, *stop;
2251 6729678 : char *filename;
2252 6729678 : const char *include = "include";
2253 6729678 : bool allow_continuation = flag_dec_include;
2254 6729678 : int i;
2255 :
2256 6729678 : c = line;
2257 :
2258 6729678 : if (flag_openmp || flag_openmp_simd)
2259 : {
2260 665689 : if (gfc_current_form == FORM_FREE)
2261 : {
2262 1426213 : while (*c == ' ' || *c == '\t')
2263 793664 : c++;
2264 632549 : 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 6729678 : if (gfc_current_form == FORM_FREE)
2276 : {
2277 10077296 : while (*c == ' ' || *c == '\t')
2278 3696393 : c++;
2279 6380903 : if (gfc_wide_strncasecmp (c, "include", 7))
2280 : {
2281 6380621 : 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 2120946 : while (*c == ' ' || *c == '\t')
2305 1772171 : c++;
2306 348775 : if (flag_dec_include && *c == '0' && c - line == 5)
2307 : {
2308 6 : c++;
2309 6 : while (*c == ' ' || *c == '\t')
2310 0 : c++;
2311 : }
2312 348775 : if (c - line < 6)
2313 253460 : allow_continuation = false;
2314 387596 : for (i = 0; i < 7; ++i)
2315 : {
2316 387514 : gfc_char_t c1 = gfc_wide_tolower (*c);
2317 387514 : if (c1 != (unsigned char) include[i])
2318 : break;
2319 38821 : c++;
2320 39910 : while (*c == ' ' || *c == '\t')
2321 1089 : c++;
2322 : }
2323 348775 : if (!allow_continuation)
2324 : {
2325 348591 : 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 63253 : load_file (const char *realfilename, const char *displayedname, bool initial)
2535 : {
2536 63253 : gfc_char_t *line;
2537 63253 : gfc_linebuf *b, *include_b = NULL;
2538 63253 : gfc_file *f;
2539 63253 : FILE *input;
2540 63253 : int len, line_len;
2541 63253 : bool first_line;
2542 63253 : struct stat st;
2543 63253 : int stat_result;
2544 63253 : 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 188619 : bool preprocessed_p = (realfilename && displayedname
2549 63253 : && strcmp (realfilename, displayedname));
2550 :
2551 62113 : filename = displayedname ? displayedname : realfilename;
2552 :
2553 63623 : 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 63253 : if (initial)
2558 : {
2559 31444 : if (gfc_src_file)
2560 : {
2561 4 : input = gfc_src_file;
2562 4 : gfc_src_file = NULL;
2563 : }
2564 : else
2565 31440 : input = gfc_open_file (realfilename);
2566 :
2567 31444 : if (input == NULL)
2568 0 : gfc_fatal_error ("Cannot open file %qs", filename);
2569 : }
2570 : else
2571 : {
2572 31809 : input = gfc_open_included_file (realfilename, false, false);
2573 31809 : 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 31808 : stat_result = stat (realfilename, &st);
2583 31808 : 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 96196 : f = get_file (filename, (initial && !preprocessed_p) ? LC_RENAME : LC_ENTER);
2612 63250 : if (!initial)
2613 31806 : add_file_change (f->filename, f->inclusion_line);
2614 63250 : current_file = f;
2615 63250 : current_file->line = 1;
2616 63250 : line = NULL;
2617 63250 : line_len = 0;
2618 63250 : first_line = true;
2619 :
2620 63250 : 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 6801858 : for (;;)
2634 : {
2635 6801858 : int trunc = load_line (input, &line, &line_len, NULL);
2636 6801858 : int inc_line;
2637 :
2638 6801858 : len = gfc_wide_strlen (line);
2639 6801858 : 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 6738611 : if (first_line
2648 67823 : && ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
2649 3 : && line[1] == (unsigned char) '\xFE')
2650 67820 : || (line_len >= 2 && line[0] == (unsigned char) '\xFE'
2651 1 : && line[1] == (unsigned char) '\xFF')
2652 67819 : || (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 6738611 : 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 6729678 : first_line = false;
2688 :
2689 6729678 : inc_line = include_line (line);
2690 6729675 : if (inc_line > 0)
2691 : {
2692 342 : current_file->line++;
2693 342 : continue;
2694 : }
2695 :
2696 : /* Add line. */
2697 :
2698 6729333 : b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size
2699 : + (len + 1) * sizeof (gfc_char_t));
2700 :
2701 :
2702 6729333 : b->location
2703 6729333 : = 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 6729333 : if (len > 0)
2708 5582186 : linemap_position_for_column (line_table, len);
2709 :
2710 6729333 : b->file = current_file;
2711 6729333 : b->truncated = trunc;
2712 6729333 : wide_strcpy (b->line, line);
2713 :
2714 6729333 : if (line_head == NULL)
2715 31444 : line_head = b;
2716 : else
2717 6697889 : line_tail->next = b;
2718 :
2719 6729333 : line_tail = b;
2720 :
2721 6797122 : while (file_changes_cur < file_changes_count)
2722 67789 : file_changes[file_changes_cur++].lb = b;
2723 :
2724 6729333 : 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 63247 : free (line);
2757 :
2758 63247 : fclose (input);
2759 :
2760 63247 : if (!initial)
2761 31806 : add_file_change (NULL, current_file->inclusion_line + 1);
2762 63247 : current_file = current_file->up;
2763 63247 : linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
2764 63247 : }
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 31458 : gfc_new_file (void)
2774 : {
2775 31458 : if (flag_pre_include != NULL)
2776 31442 : load_file (flag_pre_include, NULL, false);
2777 :
2778 31458 : 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 30303 : load_file (gfc_source_file, NULL, true);
2790 :
2791 31454 : gfc_current_locus.u.lb = line_head;
2792 31454 : 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 31454 : }
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 : }
|
