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