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