Bug Summary

File:build/gcc/fortran/scanner.c
Warning:line 908, column 4
Value stored to 'c' is never read

Annotated Source Code

Press '?' to see keyboard shortcuts

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