1	/* Character scanner.
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught
4
5	This file is part of GCC.
6
7	GCC is free software; you can redistribute it and/or modify it under
8	the terms of the GNU General Public License as published by the Free
9	Software Foundation; either version 3, or (at your option) any later
10	version.
11
12	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13	WARRANTY; without even the implied warranty of MERCHANTABILITY or
14	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15	for more details.
16
17	You should have received a copy of the GNU General Public License
18	along with GCC; see the file COPYING3. If not see
19	<http://www.gnu.org/licenses/>. */
20
21	/* Set of subroutines to (ultimately) return the next character to the
22	various matching subroutines. This file's job is to read files and
23	build up lines that are parsed by the parser. This means that we
24	handle continuation lines and "include" lines.
25
26	The first thing the scanner does is to load an entire file into
27	memory. We load the entire file into memory for a couple reasons.
28	The first is that we want to be able to deal with nonseekable input
29	(pipes, stdin) and there is a lot of backing up involved during
30	parsing.
31
32	The second is that we want to be able to print the locus of errors,
33	and an error on line 999999 could conflict with something on line
34	one. Given nonseekable input, we've got to store the whole thing.
35
36	One thing that helps are the column truncation limits that give us
37	an upper bound on the size of individual lines. We don't store the
38	truncated stuff.
39
40	From the scanner's viewpoint, the higher level subroutines ask for
41	new characters and do a lot of jumping backwards. */
42
43	#include "config.h"
44	#include "system.h"
45	#include "coretypes.h"
46	#include "gfortran.h"
47	#include "toplev.h" /* For set_src_pwd. */
48	#include "debug.h"
49	#include "options.h"
50	#include "diagnostic-core.h" /* For fatal_error. */
51	#include "cpp.h"
52	#include "scanner.h"
53
54	/* List of include file search directories. */
55	gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
56
57	static gfc_file *file_head, *current_file;
58
59	static bool continue_flag, end_flag, gcc_attribute_flag;
60	/* If !$omp/!$acc occurred in current comment line. */
61	static int openmp_flag, openacc_flag;
62	static int continue_count, continue_line;
63	static locus openmp_locus;
64	static locus openacc_locus;
65	static locus gcc_attribute_locus;
66
67	gfc_source_form gfc_current_form;
68	static gfc_linebuf *line_head, *line_tail;
69
70	locus gfc_current_locus;
71	const char *gfc_source_file;
72	static FILE *gfc_src_file;
73	static gfc_char_t *gfc_src_preprocessor_lines[2];
74
75	static struct gfc_file_change
76	{
77	const char *filename;
78	gfc_linebuf *lb;
79	int line;
80	} *file_changes;
81	static size_t file_changes_cur, file_changes_count;
82	static size_t file_changes_allocated;
83
84	static gfc_char_t *last_error_char;
85
86	/* Functions dealing with our wide characters (gfc_char_t) and
87	sequences of such characters. */
88
89	bool
90	gfc_wide_fits_in_byte (gfc_char_t c)
91	{
92	return (c <= UCHAR_MAX);
93	}
94
95	static inline int
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	bool
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
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
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	bool
120	gfc_wide_is_digit (gfc_char_t c)
121	{
122	return (c >= '0' && c <= '9');
123	}
124
125	static inline int
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: *c) && i < MAX_DIGITS)
133	buf[i++] = *c++;
134	buf[i] = '\0';
135	return atoi (nptr: buf);
136	}
137
138	size_t
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 *
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 *
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 *
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 *
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 (str: 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 *
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: 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
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
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 (c: *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
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
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 (ptr: line_head);
290	line_head = lb;
291	}
292
293	while(file_head != NULL)
294	{
295	f = file_head->next;
296	free (ptr: file_head->filename);
297	free (ptr: file_head);
298	file_head = f;
299	}
300	}
301
302	static bool
303	gfc_do_check_include_dir (const char *path, bool warn)
304	{
305	struct stat st;
306	if (stat (file: path, buf: &st))
307	{
308	if (errno != ENOENT)
309	gfc_warning_now (opt: 0, "Include directory %qs: %s",
310	path, xstrerror(errno));
311	else if (warn)
312	gfc_warning_now (opt: 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
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 (path: q->path, warn: 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 (ptr: q->path);
345	free (ptr: q);
346	}
347	}
348
349	void
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 (list: &include_dirs, do_warn: warn);
357	gfc_do_check_include_dirs (list: &intrinsic_modules_dirs, do_warn: verbose_missing_dir_warn);
358	if (gfc_option.module_dir && gfc_cpp_enabled ())
359	gfc_do_check_include_dirs (list: &include_dirs, do_warn: true);
360	}
361
362	/* Adds path to the list pointed to by list. */
363
364	static void
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 (s: p);
382	q = (char *) alloca (len + 1);
383	memcpy (dest: q, src: p, n: 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 (path: 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
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 (list: &include_dirs, path, use_for_modules, head: 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 (path: xstrdup(path), user_supplied: true);
427	}
428
429
430	void
431	gfc_add_intrinsic_modules_path (const char *path)
432	{
433	add_path_to_list (list: &intrinsic_modules_dirs, path, use_for_modules: true, head: false, warn: false, defer_warn: false);
434	}
435
436
437	/* Release resources allocated for options. */
438
439	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 (ptr: p->path);
449	free (ptr: 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 (ptr: p->path);
457	free (ptr: p);
458	}
459
460	free (ptr: gfc_option.module_dir);
461	}
462
463
464	static FILE *
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 (dest: fullname, src: p->path);
479	strcat (dest: fullname, src: "/");
480	strcat (dest: fullname, src: name);
481
482	f = gfc_open_file (fullname);
483	if (f != NULL)
484	{
485	if (gfc_cpp_makedep ())
486	gfc_cpp_add_dep (name: fullname, system);
487
488	return f;
489	}
490	}
491
492	return NULL;
493	}
494
495
496	/* Opens file for reading, searching through the include directories
497	given if necessary. If the include_cwd argument is true, we try
498	to open the file in the current directory first. */
499
500	FILE *
501	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, system: false);
510	}
511
512	if (!f)
513	f = open_included_file (name, list: include_dirs, module, system: 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	bool
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	bool
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	bool
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	bool
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
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
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
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 (lb: gfc_current_locus.lb);
613	}
614
615	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
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 (lb: 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
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
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	bool
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 (s1: gfc_current_locus.nextc, s2: "#define ", n: 8) == 0)
715	{
716	tmp = gfc_widechar_to_char (s: &gfc_current_locus.nextc[8], length: -1);
717	(*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
718	tmp);
719	free (ptr: tmp);
720	}
721
722	if (wide_strncmp (s1: gfc_current_locus.nextc, s2: "#undef ", n: 7) == 0)
723	{
724	tmp = gfc_widechar_to_char (s: &gfc_current_locus.nextc[7], length: -1);
725	(*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
726	tmp);
727	free (ptr: 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
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
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 (opt: 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
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 (opt: 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
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 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
982	skip_fixed_omp_sentinel (locus *start)
983	{
984	gfc_char_t c;
985	if ((c = next_char ()) != 'm' && c != 'M')
986	return false;
987	if ((c = next_char ()) == 'p' || c == 'P')
988	{
989	c = next_char ();
990	if (c != '\n'
991	&& (continue_flag
992	|| c == ' ' || c == '\t' || c == '0'))
993	{
994	if (c == ' ' || c == '\t' || c == '0')
995	openacc_flag = 0;
996	do
997	c = next_char ();
998	while (gfc_is_whitespace (c));
999	if (c != '\n' && c != '!')
1000	{
1001	/* Canonicalize to *$omp. */
1002	*start->nextc = '*';
1003	openmp_flag = 1;
1004	gfc_current_locus = *start;
1005	return true;
1006	}
1007	}
1008	}
1009	else if (UNLIKELY (c == 'x' || c == 'X'))
1010	gfc_warning_now (opt: OPT_Wsurprising,
1011	"Ignoring '!$omx' vendor-extension sentinel at %C");
1012	return false;
1013	}
1014
1015	/* Return true if CC was matched in fixed form. */
1016	static bool
1017	skip_fixed_oacc_sentinel (locus *start)
1018	{
1019	gfc_char_t c;
1020	if (((c = next_char ()) == 'c' || c == 'C')
1021	&& ((c = next_char ()) == 'c' || c == 'C'))
1022	{
1023	c = next_char ();
1024	if (c != '\n'
1025	&& (continue_flag
1026	|| c == ' ' || c == '\t' || c == '0'))
1027	{
1028	if (c == ' ' || c == '\t' || c == '0')
1029	openmp_flag = 0;
1030	do
1031	c = next_char ();
1032	while (gfc_is_whitespace (c));
1033	if (c != '\n' && c != '!')
1034	{
1035	/* Canonicalize to *$acc. */
1036	*start->nextc = '*';
1037	openacc_flag = 1;
1038	gfc_current_locus = *start;
1039	return true;
1040	}
1041	}
1042	}
1043	return false;
1044	}
1045
1046	/* Skip comment lines in fixed source mode. We have the same rules as
1047	in skip_free_comment(), except that we can have a 'c', 'C' or '*'
1048	in column 1, and a '!' cannot be in column 6. Also, we deal with
1049	lines with 'd' or 'D' in column 1, if the user requested this. */
1050
1051	static void
1052	skip_fixed_comments (void)
1053	{
1054	locus start;
1055	int col;
1056	gfc_char_t c;
1057
1058	if (! gfc_at_bol ())
1059	{
1060	start = gfc_current_locus;
1061	if (! gfc_at_eof ())
1062	{
1063	do
1064	c = next_char ();
1065	while (gfc_is_whitespace (c));
1066
1067	if (c == '\n')
1068	gfc_advance_line ();
1069	else if (c == '!')
1070	skip_comment_line ();
1071	}
1072
1073	if (! gfc_at_bol ())
1074	{
1075	gfc_current_locus = start;
1076	return;
1077	}
1078	}
1079
1080	for (;;)
1081	{
1082	start = gfc_current_locus;
1083	if (gfc_at_eof ())
1084	break;
1085
1086	c = next_char ();
1087	if (c == '\n')
1088	{
1089	gfc_advance_line ();
1090	continue;
1091	}
1092
1093	if (c == '!' || c == 'c' || c == 'C' || c == '*')
1094	{
1095	if (skip_gcc_attribute (start))
1096	{
1097	/* Canonicalize to *$omp. */
1098	*start.nextc = '*';
1099	return;
1100	}
1101
1102	if (gfc_current_locus.lb != NULL
1103	&& continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1104	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1105
1106	/* If -fopenmp/-fopenacc, we need to handle here 2 things:
1107	1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
1108	but directives
1109	2) handle OpenMP conditional compilation, where
1110	!$|c$|*$ should be treated as 2 spaces if the characters
1111	in columns 3 to 6 are valid fixed form label columns
1112	characters. */
1113	if ((flag_openmp || flag_openmp_simd) && !flag_openacc)
1114	{
1115	if (next_char () == '$')
1116	{
1117	c = next_char ();
1118	if (c == 'o' || c == 'O')
1119	{
1120	if (skip_fixed_omp_sentinel (start: &start))
1121	return;
1122	}
1123	else
1124	goto check_for_digits;
1125	}
1126	gfc_current_locus = start;
1127	}
1128	else if (flag_openacc && !(flag_openmp || flag_openmp_simd))
1129	{
1130	if (next_char () == '$')
1131	{
1132	c = next_char ();
1133	if (c == 'a' || c == 'A')
1134	{
1135	if (skip_fixed_oacc_sentinel (start: &start))
1136	return;
1137	}
1138	}
1139	gfc_current_locus = start;
1140	}
1141	else if (flag_openacc || flag_openmp || flag_openmp_simd)
1142	{
1143	if (next_char () == '$')
1144	{
1145	c = next_char ();
1146	if (c == 'a' || c == 'A')
1147	{
1148	if (skip_fixed_oacc_sentinel (start: &start))
1149	return;
1150	}
1151	else if (c == 'o' || c == 'O')
1152	{
1153	if (skip_fixed_omp_sentinel (start: &start))
1154	return;
1155	}
1156	else
1157	goto check_for_digits;
1158	}
1159	gfc_current_locus = start;
1160	}
1161
1162	skip_comment_line ();
1163	continue;
1164
1165	check_for_digits:
1166	{
1167	/* Required for OpenMP's conditional compilation sentinel. */
1168	int digit_seen = 0;
1169
1170	for (col = 3; col < 6; col++, c = next_char ())
1171	if (c == ' ')
1172	continue;
1173	else if (c == '\t')
1174	{
1175	col = 6;
1176	break;
1177	}
1178	else if (c < '0' || c > '9')
1179	break;
1180	else
1181	digit_seen = 1;
1182
1183	if (col == 6 && c != '\n'
1184	&& ((continue_flag && !digit_seen)
1185	|| c == ' ' || c == '\t' || c == '0'))
1186	{
1187	gfc_current_locus = start;
1188	start.nextc[0] = ' ';
1189	start.nextc[1] = ' ';
1190	continue;
1191	}
1192	}
1193	skip_comment_line ();
1194	continue;
1195	}
1196
1197	if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
1198	{
1199	if (gfc_option.flag_d_lines == 0)
1200	{
1201	skip_comment_line ();
1202	continue;
1203	}
1204	else
1205	*start.nextc = c = ' ';
1206	}
1207
1208	col = 1;
1209
1210	while (gfc_is_whitespace (c))
1211	{
1212	c = next_char ();
1213	col++;
1214	}
1215
1216	if (c == '\n')
1217	{
1218	gfc_advance_line ();
1219	continue;
1220	}
1221
1222	if (col != 6 && c == '!')
1223	{
1224	if (gfc_current_locus.lb != NULL
1225	&& continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1226	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1227	skip_comment_line ();
1228	continue;
1229	}
1230
1231	break;
1232	}
1233
1234	openmp_flag = 0;
1235	openacc_flag = 0;
1236	gcc_attribute_flag = 0;
1237	gfc_current_locus = start;
1238	}
1239
1240
1241	/* Skips the current line if it is a comment. */
1242
1243	void
1244	gfc_skip_comments (void)
1245	{
1246	if (gfc_current_form == FORM_FREE)
1247	skip_free_comments ();
1248	else
1249	skip_fixed_comments ();
1250	}
1251
1252
1253	/* Get the next character from the input, taking continuation lines
1254	and end-of-line comments into account. This implies that comment
1255	lines between continued lines must be eaten here. For higher-level
1256	subroutines, this flattens continued lines into a single logical
1257	line. The in_string flag denotes whether we're inside a character
1258	context or not. */
1259
1260	gfc_char_t
1261	gfc_next_char_literal (gfc_instring in_string)
1262	{
1263	static locus omp_acc_err_loc = {};
1264	locus old_loc;
1265	int i, prev_openmp_flag, prev_openacc_flag;
1266	gfc_char_t c;
1267
1268	continue_flag = 0;
1269	prev_openacc_flag = prev_openmp_flag = 0;
1270
1271	restart:
1272	c = next_char ();
1273	if (gfc_at_end ())
1274	{
1275	continue_count = 0;
1276	return c;
1277	}
1278
1279	if (gfc_current_form == FORM_FREE)
1280	{
1281	bool openmp_cond_flag;
1282
1283	if (!in_string && c == '!')
1284	{
1285	if (gcc_attribute_flag
1286	&& memcmp (s1: &gfc_current_locus, s2: &gcc_attribute_locus,
1287	n: sizeof (gfc_current_locus)) == 0)
1288	goto done;
1289
1290	if (openmp_flag
1291	&& memcmp (s1: &gfc_current_locus, s2: &openmp_locus,
1292	n: sizeof (gfc_current_locus)) == 0)
1293	goto done;
1294
1295	if (openacc_flag
1296	&& memcmp (s1: &gfc_current_locus, s2: &openacc_locus,
1297	n: sizeof (gfc_current_locus)) == 0)
1298	goto done;
1299
1300	/* This line can't be continued */
1301	do
1302	{
1303	c = next_char ();
1304	}
1305	while (c != '\n');
1306
1307	/* Avoid truncation warnings for comment ending lines. */
1308	gfc_current_locus.lb->truncated = 0;
1309
1310	goto done;
1311	}
1312
1313	/* Check to see if the continuation line was truncated. */
1314	if (warn_line_truncation && gfc_current_locus.lb != NULL
1315	&& gfc_current_locus.lb->truncated)
1316	{
1317	int maxlen = flag_free_line_length;
1318	gfc_char_t *current_nextc = gfc_current_locus.nextc;
1319
1320	gfc_current_locus.lb->truncated = 0;
1321	gfc_current_locus.nextc = gfc_current_locus.lb->line + maxlen;
1322	gfc_warning_now (opt: OPT_Wline_truncation,
1323	"Line truncated at %L", &gfc_current_locus);
1324	gfc_current_locus.nextc = current_nextc;
1325	}
1326
1327	if (c != '&')
1328	goto done;
1329
1330	/* If the next nonblank character is a ! or \n, we've got a
1331	continuation line. */
1332	old_loc = gfc_current_locus;
1333
1334	c = next_char ();
1335	while (gfc_is_whitespace (c))
1336	c = next_char ();
1337
1338	/* Character constants to be continued cannot have commentary
1339	after the '&'. However, there are cases where we may think we
1340	are still in a string and we are looking for a possible
1341	doubled quote and we end up here. See PR64506. */
1342
1343	if (in_string && c != '\n')
1344	{
1345	gfc_current_locus = old_loc;
1346	c = '&';
1347	goto done;
1348	}
1349
1350	if (c != '!' && c != '\n')
1351	{
1352	gfc_current_locus = old_loc;
1353	c = '&';
1354	goto done;
1355	}
1356
1357	if (flag_openmp)
1358	prev_openmp_flag = openmp_flag;
1359	if (flag_openacc)
1360	prev_openacc_flag = openacc_flag;
1361
1362	/* This can happen if the input file changed or via cpp's #line
1363	without getting reset (e.g. via input_stmt). It also happens
1364	when pre-including files via -fpre-include=. */
1365	if (continue_count == 0
1366	&& gfc_current_locus.lb
1367	&& continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1)
1368	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1;
1369
1370	continue_flag = 1;
1371	if (c == '!')
1372	skip_comment_line ();
1373	else
1374	gfc_advance_line ();
1375
1376	if (gfc_at_eof ())
1377	goto not_continuation;
1378
1379	/* We've got a continuation line. If we are on the very next line after
1380	the last continuation, increment the continuation line count and
1381	check whether the limit has been exceeded. */
1382	if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1383	{
1384	if (++continue_count == gfc_option.max_continue_free)
1385	{
1386	if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1387	gfc_warning (opt: 0, "Limit of %d continuations exceeded in "
1388	"statement at %C", gfc_option.max_continue_free);
1389	}
1390	}
1391
1392	/* Now find where it continues. First eat any comment lines. */
1393	openmp_cond_flag = skip_free_comments ();
1394
1395	if (gfc_current_locus.lb != NULL
1396	&& continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1397	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1398
1399	if (flag_openmp)
1400	if (prev_openmp_flag != openmp_flag && !openacc_flag)
1401	{
1402	gfc_current_locus = old_loc;
1403	openmp_flag = prev_openmp_flag;
1404	c = '&';
1405	goto done;
1406	}
1407
1408	if (flag_openacc)
1409	if (prev_openacc_flag != openacc_flag && !openmp_flag)
1410	{
1411	gfc_current_locus = old_loc;
1412	openacc_flag = prev_openacc_flag;
1413	c = '&';
1414	goto done;
1415	}
1416
1417	/* Now that we have a non-comment line, probe ahead for the
1418	first non-whitespace character. If it is another '&', then
1419	reading starts at the next character, otherwise we must back
1420	up to where the whitespace started and resume from there. */
1421
1422	old_loc = gfc_current_locus;
1423
1424	c = next_char ();
1425	while (gfc_is_whitespace (c))
1426	c = next_char ();
1427
1428	if (openmp_flag && !openacc_flag)
1429	{
1430	for (i = 0; i < 5; i++, c = next_char ())
1431	{
1432	gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]);
1433	if (i == 4)
1434	old_loc = gfc_current_locus;
1435	}
1436	while (gfc_is_whitespace (c))
1437	c = next_char ();
1438	}
1439	if (openacc_flag && !openmp_flag)
1440	{
1441	for (i = 0; i < 5; i++, c = next_char ())
1442	{
1443	gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$acc"[i]);
1444	if (i == 4)
1445	old_loc = gfc_current_locus;
1446	}
1447	while (gfc_is_whitespace (c))
1448	c = next_char ();
1449	}
1450
1451	/* In case we have an OpenMP directive continued by OpenACC
1452	sentinel, or vice versa, we get both openmp_flag and
1453	openacc_flag on. */
1454
1455	if (openacc_flag && openmp_flag)
1456	{
1457	int is_openmp = 0;
1458	for (i = 0; i < 5; i++, c = next_char ())
1459	{
1460	if (gfc_wide_tolower (c) != (unsigned char) "!$acc"[i])
1461	is_openmp = 1;
1462	}
1463	if (omp_acc_err_loc.nextc != gfc_current_locus.nextc
1464	|| omp_acc_err_loc.lb != gfc_current_locus.lb)
1465	gfc_error_now (is_openmp
1466	? G_("Wrong OpenACC continuation at %C: "
1467	"expected !$ACC, got !$OMP")
1468	: G_("Wrong OpenMP continuation at %C: "
1469	"expected !$OMP, got !$ACC"));
1470	omp_acc_err_loc = gfc_current_locus;
1471	goto not_continuation;
1472	}
1473
1474	if (c != '&')
1475	{
1476	if (in_string && gfc_current_locus.nextc)
1477	{
1478	gfc_current_locus.nextc--;
1479	if (warn_ampersand && in_string == INSTRING_WARN)
1480	gfc_warning (opt: OPT_Wampersand,
1481	"Missing %<&%> in continued character "
1482	"constant at %C");
1483	}
1484	else if (!in_string && (c == '\'' || c == '"'))
1485	goto done;
1486	/* Both !$omp and !$ -fopenmp continuation lines have & on the
1487	continuation line only optionally. */
1488	else if (openmp_flag || openacc_flag || openmp_cond_flag)
1489	{
1490	if (gfc_current_locus.nextc)
1491	gfc_current_locus.nextc--;
1492	}
1493	else
1494	{
1495	c = ' ';
1496	gfc_current_locus = old_loc;
1497	goto done;
1498	}
1499	}
1500	}
1501	else /* Fixed form. */
1502	{
1503	/* Fixed form continuation. */
1504	if (in_string != INSTRING_WARN && c == '!')
1505	{
1506	/* Skip comment at end of line. */
1507	do
1508	{
1509	c = next_char ();
1510	}
1511	while (c != '\n');
1512
1513	/* Avoid truncation warnings for comment ending lines. */
1514	gfc_current_locus.lb->truncated = 0;
1515	}
1516
1517	if (c != '\n')
1518	goto done;
1519
1520	/* Check to see if the continuation line was truncated. */
1521	if (warn_line_truncation && gfc_current_locus.lb != NULL
1522	&& gfc_current_locus.lb->truncated)
1523	{
1524	gfc_current_locus.lb->truncated = 0;
1525	gfc_warning_now (opt: OPT_Wline_truncation,
1526	"Line truncated at %L", &gfc_current_locus);
1527	}
1528
1529	if (flag_openmp)
1530	prev_openmp_flag = openmp_flag;
1531	if (flag_openacc)
1532	prev_openacc_flag = openacc_flag;
1533
1534	/* This can happen if the input file changed or via cpp's #line
1535	without getting reset (e.g. via input_stmt). It also happens
1536	when pre-including files via -fpre-include=. */
1537	if (continue_count == 0
1538	&& gfc_current_locus.lb
1539	&& continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1)
1540	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1;
1541
1542	continue_flag = 1;
1543	old_loc = gfc_current_locus;
1544
1545	gfc_advance_line ();
1546	skip_fixed_comments ();
1547
1548	/* See if this line is a continuation line. */
1549	if (flag_openmp && openmp_flag != prev_openmp_flag && !openacc_flag)
1550	{
1551	openmp_flag = prev_openmp_flag;
1552	goto not_continuation;
1553	}
1554	if (flag_openacc && openacc_flag != prev_openacc_flag && !openmp_flag)
1555	{
1556	openacc_flag = prev_openacc_flag;
1557	goto not_continuation;
1558	}
1559
1560	/* In case we have an OpenMP directive continued by OpenACC
1561	sentinel, or vice versa, we get both openmp_flag and
1562	openacc_flag on. */
1563	if (openacc_flag && openmp_flag)
1564	{
1565	int is_openmp = 0;
1566	for (i = 0; i < 5; i++)
1567	{
1568	c = next_char ();
1569	if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i])
1570	is_openmp = 1;
1571	}
1572	if (omp_acc_err_loc.nextc != gfc_current_locus.nextc
1573	|| omp_acc_err_loc.lb != gfc_current_locus.lb)
1574	gfc_error_now (is_openmp
1575	? G_("Wrong OpenACC continuation at %C: "
1576	"expected !$ACC, got !$OMP")
1577	: G_("Wrong OpenMP continuation at %C: "
1578	"expected !$OMP, got !$ACC"));
1579	omp_acc_err_loc = gfc_current_locus;
1580	goto not_continuation;
1581	}
1582	else if (!openmp_flag && !openacc_flag)
1583	for (i = 0; i < 5; i++)
1584	{
1585	c = next_char ();
1586	if (c != ' ')
1587	goto not_continuation;
1588	}
1589	else if (openmp_flag)
1590	for (i = 0; i < 5; i++)
1591	{
1592	c = next_char ();
1593	if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i])
1594	goto not_continuation;
1595	}
1596	else if (openacc_flag)
1597	for (i = 0; i < 5; i++)
1598	{
1599	c = next_char ();
1600	if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i])
1601	goto not_continuation;
1602	}
1603
1604	c = next_char ();
1605	if (c == '0' || c == ' ' || c == '\n')
1606	goto not_continuation;
1607
1608	/* We've got a continuation line. If we are on the very next line after
1609	the last continuation, increment the continuation line count and
1610	check whether the limit has been exceeded. */
1611	if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
1612	{
1613	if (++continue_count == gfc_option.max_continue_fixed)
1614	{
1615	if (gfc_notification_std (GFC_STD_GNU) || pedantic)
1616	gfc_warning (opt: 0, "Limit of %d continuations exceeded in "
1617	"statement at %C",
1618	gfc_option.max_continue_fixed);
1619	}
1620	}
1621
1622	if (gfc_current_locus.lb != NULL
1623	&& continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
1624	continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
1625	}
1626
1627	/* Ready to read first character of continuation line, which might
1628	be another continuation line! */
1629	goto restart;
1630
1631	not_continuation:
1632	c = '\n';
1633	gfc_current_locus = old_loc;
1634	end_flag = 0;
1635
1636	done:
1637	if (c == '\n')
1638	continue_count = 0;
1639	continue_flag = 0;
1640	return c;
1641	}
1642
1643
1644	/* Get the next character of input, folded to lowercase. In fixed
1645	form mode, we also ignore spaces. When matcher subroutines are
1646	parsing character literals, they have to call
1647	gfc_next_char_literal(). */
1648
1649	gfc_char_t
1650	gfc_next_char (void)
1651	{
1652	gfc_char_t c;
1653
1654	do
1655	{
1656	c = gfc_next_char_literal (in_string: NONSTRING);
1657	}
1658	while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
1659
1660	return gfc_wide_tolower (c);
1661	}
1662
1663	char
1664	gfc_next_ascii_char (void)
1665	{
1666	gfc_char_t c = gfc_next_char ();
1667
1668	return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1669	: (unsigned char) UCHAR_MAX);
1670	}
1671
1672
1673	gfc_char_t
1674	gfc_peek_char (void)
1675	{
1676	locus old_loc;
1677	gfc_char_t c;
1678
1679	old_loc = gfc_current_locus;
1680	c = gfc_next_char ();
1681	gfc_current_locus = old_loc;
1682
1683	return c;
1684	}
1685
1686
1687	char
1688	gfc_peek_ascii_char (void)
1689	{
1690	gfc_char_t c = gfc_peek_char ();
1691
1692	return (gfc_wide_fits_in_byte (c) ? (unsigned char) c
1693	: (unsigned char) UCHAR_MAX);
1694	}
1695
1696
1697	/* Recover from an error. We try to get past the current statement
1698	and get lined up for the next. The next statement follows a '\n'
1699	or a ';'. We also assume that we are not within a character
1700	constant, and deal with finding a '\'' or '"'. */
1701
1702	void
1703	gfc_error_recovery (void)
1704	{
1705	gfc_char_t c, delim;
1706
1707	if (gfc_at_eof ())
1708	return;
1709
1710	for (;;)
1711	{
1712	c = gfc_next_char ();
1713	if (c == '\n' || c == ';')
1714	break;
1715
1716	if (c != '\'' && c != '"')
1717	{
1718	if (gfc_at_eof ())
1719	break;
1720	continue;
1721	}
1722	delim = c;
1723
1724	for (;;)
1725	{
1726	c = next_char ();
1727
1728	if (c == delim)
1729	break;
1730	if (c == '\n')
1731	return;
1732	if (c == '\\')
1733	{
1734	c = next_char ();
1735	if (c == '\n')
1736	return;
1737	}
1738	}
1739	if (gfc_at_eof ())
1740	break;
1741	}
1742	}
1743
1744
1745	/* Read ahead until the next character to be read is not whitespace. */
1746
1747	void
1748	gfc_gobble_whitespace (void)
1749	{
1750	static int linenum = 0;
1751	locus old_loc;
1752	gfc_char_t c;
1753
1754	do
1755	{
1756	old_loc = gfc_current_locus;
1757	c = gfc_next_char_literal (in_string: NONSTRING);
1758	/* Issue a warning for nonconforming tabs. We keep track of the line
1759	number because the Fortran matchers will often back up and the same
1760	line will be scanned multiple times. */
1761	if (warn_tabs && c == '\t')
1762	{
1763	int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
1764	if (cur_linenum != linenum)
1765	{
1766	linenum = cur_linenum;
1767	gfc_warning_now (opt: OPT_Wtabs, "Nonconforming tab character at %C");
1768	}
1769	}
1770	}
1771	while (gfc_is_whitespace (c));
1772
1773	if (!ISPRINT(c) && c != '\n' && last_error_char != gfc_current_locus.nextc)
1774	{
1775	char buf[20];
1776	last_error_char = gfc_current_locus.nextc;
1777	snprintf (s: buf, maxlen: 20, format: "%2.2X", c);
1778	gfc_error_now ("Invalid character 0x%s at %C", buf);
1779	}
1780
1781	gfc_current_locus = old_loc;
1782	}
1783
1784
1785	/* Load a single line into pbuf.
1786
1787	If pbuf points to a NULL pointer, it is allocated.
1788	We truncate lines that are too long, unless we're dealing with
1789	preprocessor lines or if the option -ffixed-line-length-none is set,
1790	in which case we reallocate the buffer to fit the entire line, if
1791	need be.
1792	In fixed mode, we expand a tab that occurs within the statement
1793	label region to expand to spaces that leave the next character in
1794	the source region.
1795
1796	If first_char is not NULL, it's a pointer to a single char value holding
1797	the first character of the line, which has already been read by the
1798	caller. This avoids the use of ungetc().
1799
1800	load_line returns whether the line was truncated.
1801
1802	NOTE: The error machinery isn't available at this point, so we can't
1803	easily report line and column numbers consistent with other
1804	parts of gfortran. */
1805
1806	static bool
1807	load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char)
1808	{
1809	int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1810	int quoted = ' ', comment_ix = -1;
1811	bool seen_comment = false;
1812	bool first_comment = true;
1813	bool trunc_flag = false;
1814	bool seen_printable = false;
1815	bool seen_ampersand = false;
1816	bool found_tab = false;
1817	bool warned_tabs = false;
1818	gfc_char_t *buffer;
1819
1820	/* Determine the maximum allowed line length. */
1821	if (gfc_current_form == FORM_FREE)
1822	maxlen = flag_free_line_length;
1823	else if (gfc_current_form == FORM_FIXED)
1824	maxlen = flag_fixed_line_length;
1825	else
1826	maxlen = 72;
1827
1828	if (*pbuf == NULL)
1829	{
1830	/* Allocate the line buffer, storing its length into buflen.
1831	Note that if maxlen==0, indicating that arbitrary-length lines
1832	are allowed, the buffer will be reallocated if this length is
1833	insufficient; since 132 characters is the length of a standard
1834	free-form line, we use that as a starting guess. */
1835	if (maxlen > 0)
1836	buflen = maxlen;
1837	else
1838	buflen = 132;
1839
1840	*pbuf = gfc_get_wide_string (buflen + 1);
1841	}
1842
1843	i = 0;
1844	buffer = *pbuf;
1845
1846	if (first_char)
1847	c = *first_char;
1848	else
1849	c = getc (stream: input);
1850
1851	/* In order to not truncate preprocessor lines, we have to
1852	remember that this is one. */
1853	preprocessor_flag = (c == '#');
1854
1855	for (;;)
1856	{
1857	if (c == EOF)
1858	break;
1859
1860	if (c == '\n')
1861	{
1862	/* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */
1863	if (gfc_current_form == FORM_FREE
1864	&& !seen_printable && seen_ampersand)
1865	{
1866	if (pedantic)
1867	gfc_error_now ("%<&%> not allowed by itself in line %d",
1868	current_file->line);
1869	else
1870	gfc_warning_now (opt: 0, "%<&%> not allowed by itself in line %d",
1871	current_file->line);
1872	}
1873	break;
1874	}
1875
1876	if (c == '\r' || c == '\0')
1877	goto next_char; /* Gobble characters. */
1878
1879	if (c == '&')
1880	{
1881	if (seen_ampersand)
1882	{
1883	seen_ampersand = false;
1884	seen_printable = true;
1885	}
1886	else
1887	seen_ampersand = true;
1888	}
1889
1890	if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand))
1891	seen_printable = true;
1892
1893	/* Is this a fixed-form comment? */
1894	if (gfc_current_form == FORM_FIXED && i == 0
1895	&& (c == '*' || c == 'c' || c == 'C'
1896	|| (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))))
1897	{
1898	seen_comment = true;
1899	comment_ix = i;
1900	}
1901
1902	if (quoted == ' ')
1903	{
1904	if (c == '\'' || c == '"')
1905	quoted = c;
1906	}
1907	else if (c == quoted)
1908	quoted = ' ';
1909
1910	/* Is this a free-form comment? */
1911	if (c == '!' && quoted == ' ')
1912	{
1913	if (seen_comment)
1914	first_comment = false;
1915	seen_comment = true;
1916	comment_ix = i;
1917	}
1918
1919	/* For truncation and tab warnings, set seen_comment to false if one has
1920	either an OpenMP or OpenACC directive - or a !GCC$ attribute. If
1921	OpenMP is enabled, use '!$' as conditional compilation sentinel
1922	and OpenMP directive ('!$omp'). */
1923	if (seen_comment && first_comment && flag_openmp && comment_ix + 1 == i
1924	&& c == '$')
1925	first_comment = seen_comment = false;
1926	if (seen_comment && first_comment && comment_ix + 4 == i)
1927	{
1928	if (((*pbuf)[comment_ix+1] == 'g' || (*pbuf)[comment_ix+1] == 'G')
1929	&& ((*pbuf)[comment_ix+2] == 'c' || (*pbuf)[comment_ix+2] == 'C')
1930	&& ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C')
1931	&& c == '$')
1932	first_comment = seen_comment = false;
1933	if (flag_openacc
1934	&& (*pbuf)[comment_ix+1] == '$'
1935	&& ((*pbuf)[comment_ix+2] == 'a' || (*pbuf)[comment_ix+2] == 'A')
1936	&& ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C')
1937	&& (c == 'c' || c == 'C'))
1938	first_comment = seen_comment = false;
1939	}
1940
1941	/* Vendor extension: "<tab>1" marks a continuation line. */
1942	if (found_tab)
1943	{
1944	found_tab = false;
1945	if (c >= '1' && c <= '9')
1946	{
1947	*(buffer-1) = c;
1948	goto next_char;
1949	}
1950	}
1951
1952	if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6)
1953	{
1954	found_tab = true;
1955
1956	if (warn_tabs && seen_comment == 0 && !warned_tabs)
1957	{
1958	warned_tabs = true;
1959	gfc_warning_now (opt: OPT_Wtabs,
1960	"Nonconforming tab character in column %d "
1961	"of line %d", i + 1, current_file->line);
1962	}
1963
1964	while (i < 6)
1965	{
1966	*buffer++ = ' ';
1967	i++;
1968	}
1969
1970	goto next_char;
1971	}
1972
1973	*buffer++ = c;
1974	i++;
1975
1976	if (maxlen == 0 || preprocessor_flag)
1977	{
1978	if (i >= buflen)
1979	{
1980	/* Reallocate line buffer to double size to hold the
1981	overlong line. */
1982	buflen = buflen * 2;
1983	*pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1));
1984	buffer = (*pbuf) + i;
1985	}
1986	}
1987	else if (i >= maxlen)
1988	{
1989	bool trunc_warn = true;
1990
1991	/* Enhancement, if the very next non-space character is an ampersand
1992	or comment that we would otherwise warn about, don't mark as
1993	truncated. */
1994
1995	/* Truncate the rest of the line. */
1996	for (;;)
1997	{
1998	c = getc (stream: input);
1999	if (c == '\r' || c == ' ')
2000	continue;
2001
2002	if (c == '\n' || c == EOF)
2003	break;
2004
2005	if (!trunc_warn && c != '!')
2006	trunc_warn = true;
2007
2008	if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&')
2009	|| c == '!'))
2010	trunc_warn = false;
2011
2012	if (c == '!')
2013	seen_comment = 1;
2014
2015	if (trunc_warn && !seen_comment)
2016	trunc_flag = 1;
2017	}
2018
2019	c = '\n';
2020	continue;
2021	}
2022
2023	next_char:
2024	c = getc (stream: input);
2025	}
2026
2027	/* Pad lines to the selected line length in fixed form. */
2028	if (gfc_current_form == FORM_FIXED
2029	&& flag_fixed_line_length != 0
2030	&& flag_pad_source
2031	&& !preprocessor_flag
2032	&& c != EOF)
2033	{
2034	while (i++ < maxlen)
2035	*buffer++ = ' ';
2036	}
2037
2038	*buffer = '\0';
2039	*pbuflen = buflen;
2040
2041	return trunc_flag;
2042	}
2043
2044
2045	/* Get a gfc_file structure, initialize it and add it to
2046	the file stack. */
2047
2048	static gfc_file *
2049	get_file (const char *name, enum lc_reason reason)
2050	{
2051	gfc_file *f;
2052
2053	f = XCNEW (gfc_file);
2054
2055	f->filename = xstrdup (name);
2056
2057	f->next = file_head;
2058	file_head = f;
2059
2060	f->up = current_file;
2061	if (current_file != NULL)
2062	f->inclusion_line = current_file->line;
2063
2064	linemap_add (line_table, reason, sysp: false, to_file: f->filename, to_line: 1);
2065
2066	return f;
2067	}
2068
2069
2070	/* Deal with a line from the C preprocessor. The
2071	initial octothorp has already been seen. */
2072
2073	static void
2074	preprocessor_line (gfc_char_t *c)
2075	{
2076	bool flag[5];
2077	int i, line;
2078	gfc_char_t *wide_filename;
2079	gfc_file *f;
2080	int escaped, unescape;
2081	char *filename;
2082
2083	c++;
2084	while (*c == ' ' || *c == '\t')
2085	c++;
2086
2087	if (*c < '0' || *c > '9')
2088	goto bad_cpp_line;
2089
2090	line = wide_atoi (c);
2091
2092	c = wide_strchr (s: c, c: ' ');
2093	if (c == NULL)
2094	{
2095	/* No file name given. Set new line number. */
2096	current_file->line = line;
2097	return;
2098	}
2099
2100	/* Skip spaces. */
2101	while (*c == ' ' || *c == '\t')
2102	c++;
2103
2104	/* Skip quote. */
2105	if (*c != '"')
2106	goto bad_cpp_line;
2107	++c;
2108
2109	wide_filename = c;
2110
2111	/* Make filename end at quote. */
2112	unescape = 0;
2113	escaped = false;
2114	while (*c && ! (!escaped && *c == '"'))
2115	{
2116	if (escaped)
2117	escaped = false;
2118	else if (*c == '\\')
2119	{
2120	escaped = true;
2121	unescape++;
2122	}
2123	++c;
2124	}
2125
2126	if (! *c)
2127	/* Preprocessor line has no closing quote. */
2128	goto bad_cpp_line;
2129
2130	*c++ = '\0';
2131
2132	/* Undo effects of cpp_quote_string. */
2133	if (unescape)
2134	{
2135	gfc_char_t *s = wide_filename;
2136	gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape);
2137
2138	wide_filename = d;
2139	while (*s)
2140	{
2141	if (*s == '\\')
2142	*d++ = *++s;
2143	else
2144	*d++ = *s;
2145	s++;
2146	}
2147	*d = '\0';
2148	}
2149
2150	/* Get flags. */
2151
2152	flag[1] = flag[2] = flag[3] = flag[4] = false;
2153
2154	for (;;)
2155	{
2156	c = wide_strchr (s: c, c: ' ');
2157	if (c == NULL)
2158	break;
2159
2160	c++;
2161	i = wide_atoi (c);
2162
2163	if (i >= 1 && i <= 4)
2164	flag[i] = true;
2165	}
2166
2167	/* Convert the filename in wide characters into a filename in narrow
2168	characters. */
2169	filename = gfc_widechar_to_char (s: wide_filename, length: -1);
2170
2171	/* Interpret flags. */
2172
2173	if (flag[1]) /* Starting new file. */
2174	{
2175	f = get_file (name: filename, reason: LC_RENAME);
2176	add_file_change (filename: f->filename, line: f->inclusion_line);
2177	current_file = f;
2178	}
2179
2180	if (flag[2]) /* Ending current file. */
2181	{
2182	if (!current_file->up
2183	|| filename_cmp (s1: current_file->up->filename, s2: filename) != 0)
2184	{
2185	linemap_line_start (set: line_table, to_line: current_file->line, max_column_hint: 80);
2186	/* ??? One could compute the exact column where the filename
2187	starts and compute the exact location here. */
2188	gfc_warning_now_at (loc: linemap_position_for_column (line_table, 1),
2189	opt: 0, gmsgid: "file %qs left but not entered",
2190	filename);
2191	current_file->line++;
2192	if (unescape)
2193	free (ptr: wide_filename);
2194	free (ptr: filename);
2195	return;
2196	}
2197
2198	add_file_change (NULL, line);
2199	current_file = current_file->up;
2200	linemap_add (line_table, LC_RENAME, sysp: false, to_file: current_file->filename,
2201	to_line: current_file->line);
2202	}
2203
2204	/* The name of the file can be a temporary file produced by
2205	cpp. Replace the name if it is different. */
2206
2207	if (filename_cmp (s1: current_file->filename, s2: filename) != 0)
2208	{
2209	/* FIXME: we leak the old filename because a pointer to it may be stored
2210	in the linemap. Alternative could be using GC or updating linemap to
2211	point to the new name, but there is no API for that currently. */
2212	current_file->filename = xstrdup (filename);
2213
2214	/* We need to tell the linemap API that the filename changed. Just
2215	changing current_file is insufficient. */
2216	linemap_add (line_table, LC_RENAME, sysp: false, to_file: current_file->filename, to_line: line);
2217	}
2218
2219	/* Set new line number. */
2220	current_file->line = line;
2221	if (unescape)
2222	free (ptr: wide_filename);
2223	free (ptr: filename);
2224	return;
2225
2226	bad_cpp_line:
2227	linemap_line_start (set: line_table, to_line: current_file->line, max_column_hint: 80);
2228	/* ??? One could compute the exact column where the directive
2229	starts and compute the exact location here. */
2230	gfc_warning_now_at (loc: linemap_position_for_column (line_table, 2), opt: 0,
2231	gmsgid: "Illegal preprocessor directive");
2232	current_file->line++;
2233	}
2234
2235
2236	static void load_file (const char *, const char *, bool);
2237
2238	/* include_line()-- Checks a line buffer to see if it is an include
2239	line. If so, we call load_file() recursively to load the included
2240	file. We never return a syntax error because a statement like
2241	"include = 5" is perfectly legal. We return 0 if no include was
2242	processed, 1 if we matched an include or -1 if include was
2243	partially processed, but will need continuation lines. */
2244
2245	static int
2246	include_line (gfc_char_t *line)
2247	{
2248	gfc_char_t quote, *c, *begin, *stop;
2249	char *filename;
2250	const char *include = "include";
2251	bool allow_continuation = flag_dec_include;
2252	int i;
2253
2254	c = line;
2255
2256	if (flag_openmp || flag_openmp_simd)
2257	{
2258	if (gfc_current_form == FORM_FREE)
2259	{
2260	while (*c == ' ' || *c == '\t')
2261	c++;
2262	if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
2263	c += 3;
2264	}
2265	else
2266	{
2267	if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
2268	&& c[1] == '$' && c[2] == ' ')
2269	c += 3;
2270	}
2271	}
2272
2273	if (gfc_current_form == FORM_FREE)
2274	{
2275	while (*c == ' ' || *c == '\t')
2276	c++;
2277	if (gfc_wide_strncasecmp (s1: c, s2: "include", n: 7))
2278	{
2279	if (!allow_continuation)
2280	return 0;
2281	for (i = 0; i < 7; ++i)
2282	{
2283	gfc_char_t c1 = gfc_wide_tolower (c: *c);
2284	if (c1 != (unsigned char) include[i])
2285	break;
2286	c++;
2287	}
2288	if (i == 0 || *c != '&')
2289	return 0;
2290	c++;
2291	while (*c == ' ' || *c == '\t')
2292	c++;
2293	if (*c == '\0' || *c == '!')
2294	return -1;
2295	return 0;
2296	}
2297
2298	c += 7;
2299	}
2300	else
2301	{
2302	while (*c == ' ' || *c == '\t')
2303	c++;
2304	if (flag_dec_include && *c == '0' && c - line == 5)
2305	{
2306	c++;
2307	while (*c == ' ' || *c == '\t')
2308	c++;
2309	}
2310	if (c - line < 6)
2311	allow_continuation = false;
2312	for (i = 0; i < 7; ++i)
2313	{
2314	gfc_char_t c1 = gfc_wide_tolower (c: *c);
2315	if (c1 != (unsigned char) include[i])
2316	break;
2317	c++;
2318	while (*c == ' ' || *c == '\t')
2319	c++;
2320	}
2321	if (!allow_continuation)
2322	{
2323	if (i != 7)
2324	return 0;
2325	}
2326	else if (i != 7)
2327	{
2328	if (i == 0)
2329	return 0;
2330
2331	/* At the end of line or comment this might be continued. */
2332	if (*c == '\0' || *c == '!')
2333	return -1;
2334
2335	return 0;
2336	}
2337	}
2338
2339	while (*c == ' ' || *c == '\t')
2340	c++;
2341
2342	/* Find filename between quotes. */
2343
2344	quote = *c++;
2345	if (quote != '"' && quote != '\'')
2346	{
2347	if (allow_continuation)
2348	{
2349	if (gfc_current_form == FORM_FREE)
2350	{
2351	if (quote == '&')
2352	{
2353	while (*c == ' ' || *c == '\t')
2354	c++;
2355	if (*c == '\0' || *c == '!')
2356	return -1;
2357	}
2358	}
2359	else if (quote == '\0' || quote == '!')
2360	return -1;
2361	}
2362	return 0;
2363	}
2364
2365	begin = c;
2366
2367	bool cont = false;
2368	while (*c != quote && *c != '\0')
2369	{
2370	if (allow_continuation && gfc_current_form == FORM_FREE)
2371	{
2372	if (*c == '&')
2373	cont = true;
2374	else if (*c != ' ' && *c != '\t')
2375	cont = false;
2376	}
2377	c++;
2378	}
2379
2380	if (*c == '\0')
2381	{
2382	if (allow_continuation
2383	&& (cont || gfc_current_form != FORM_FREE))
2384	return -1;
2385	return 0;
2386	}
2387
2388	stop = c++;
2389
2390	while (*c == ' ' || *c == '\t')
2391	c++;
2392
2393	if (*c != '\0' && *c != '!')
2394	return 0;
2395
2396	/* We have an include line at this point. */
2397
2398	*stop = '\0'; /* It's ok to trash the buffer, as this line won't be
2399	read by anything else. */
2400
2401	filename = gfc_widechar_to_char (s: begin, length: -1);
2402	load_file (filename, NULL, false);
2403	free (ptr: filename);
2404	return 1;
2405	}
2406
2407	/* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc.
2408	APIs. Return 1 if recognized as valid INCLUDE statement and load_file has
2409	been called, 0 if it is not a valid INCLUDE statement and -1 if eof has
2410	been encountered while parsing it. */
2411	static int
2412	include_stmt (gfc_linebuf *b)
2413	{
2414	int ret = 0, i, length;
2415	const char *include = "include";
2416	gfc_char_t c, quote = 0;
2417	locus str_locus;
2418	char *filename;
2419
2420	continue_flag = 0;
2421	end_flag = 0;
2422	gcc_attribute_flag = 0;
2423	openmp_flag = 0;
2424	openacc_flag = 0;
2425	continue_count = 0;
2426	continue_line = 0;
2427	gfc_current_locus.lb = b;
2428	gfc_current_locus.nextc = b->line;
2429
2430	gfc_skip_comments ();
2431	gfc_gobble_whitespace ();
2432
2433	for (i = 0; i < 7; i++)
2434	{
2435	c = gfc_next_char ();
2436	if (c != (unsigned char) include[i])
2437	{
2438	if (gfc_current_form == FORM_FIXED
2439	&& i == 0
2440	&& c == '0'
2441	&& gfc_current_locus.nextc == b->line + 6)
2442	{
2443	gfc_gobble_whitespace ();
2444	i--;
2445	continue;
2446	}
2447	gcc_assert (i != 0);
2448	if (c == '\n')
2449	{
2450	gfc_advance_line ();
2451	gfc_skip_comments ();
2452	if (gfc_at_eof ())
2453	ret = -1;
2454	}
2455	goto do_ret;
2456	}
2457	}
2458	gfc_gobble_whitespace ();
2459
2460	c = gfc_next_char ();
2461	if (c == '\'' || c == '"')
2462	quote = c;
2463	else
2464	{
2465	if (c == '\n')
2466	{
2467	gfc_advance_line ();
2468	gfc_skip_comments ();
2469	if (gfc_at_eof ())
2470	ret = -1;
2471	}
2472	goto do_ret;
2473	}
2474
2475	str_locus = gfc_current_locus;
2476	length = 0;
2477	do
2478	{
2479	c = gfc_next_char_literal (in_string: INSTRING_NOWARN);
2480	if (c == quote)
2481	break;
2482	if (c == '\n')
2483	{
2484	gfc_advance_line ();
2485	gfc_skip_comments ();
2486	if (gfc_at_eof ())
2487	ret = -1;
2488	goto do_ret;
2489	}
2490	length++;
2491	}
2492	while (1);
2493
2494	gfc_gobble_whitespace ();
2495	c = gfc_next_char ();
2496	if (c != '\n')
2497	goto do_ret;
2498
2499	gfc_current_locus = str_locus;
2500	ret = 1;
2501	filename = XNEWVEC (char, length + 1);
2502	for (i = 0; i < length; i++)
2503	{
2504	c = gfc_next_char_literal (in_string: INSTRING_WARN);
2505	gcc_assert (gfc_wide_fits_in_byte (c));
2506	filename[i] = (unsigned char) c;
2507	}
2508	filename[length] = '\0';
2509	load_file (filename, NULL, false);
2510	free (ptr: filename);
2511
2512	do_ret:
2513	continue_flag = 0;
2514	end_flag = 0;
2515	gcc_attribute_flag = 0;
2516	openmp_flag = 0;
2517	openacc_flag = 0;
2518	continue_count = 0;
2519	continue_line = 0;
2520	memset (s: &gfc_current_locus, c: '\0', n: sizeof (locus));
2521	memset (s: &openmp_locus, c: '\0', n: sizeof (locus));
2522	memset (s: &openacc_locus, c: '\0', n: sizeof (locus));
2523	memset (s: &gcc_attribute_locus, c: '\0', n: sizeof (locus));
2524	return ret;
2525	}
2526
2527
2528
2529	/* Load a file into memory by calling load_line until the file ends. */
2530
2531	static void
2532	load_file (const char *realfilename, const char *displayedname, bool initial)
2533	{
2534	gfc_char_t *line;
2535	gfc_linebuf *b, *include_b = NULL;
2536	gfc_file *f;
2537	FILE *input;
2538	int len, line_len;
2539	bool first_line;
2540	struct stat st;
2541	int stat_result;
2542	const char *filename;
2543	/* If realfilename and displayedname are different and non-null then
2544	surely realfilename is the preprocessed form of
2545	displayedname. */
2546	bool preprocessed_p = (realfilename && displayedname
2547	&& strcmp (s1: realfilename, s2: displayedname));
2548
2549	filename = displayedname ? displayedname : realfilename;
2550
2551	for (f = current_file; f; f = f->up)
2552	if (filename_cmp (s1: filename, s2: f->filename) == 0)
2553	fatal_error (linemap_line_start (set: line_table, to_line: current_file->line, max_column_hint: 0),
2554	"File %qs is being included recursively", filename);
2555	if (initial)
2556	{
2557	if (gfc_src_file)
2558	{
2559	input = gfc_src_file;
2560	gfc_src_file = NULL;
2561	}
2562	else
2563	input = gfc_open_file (realfilename);
2564
2565	if (input == NULL)
2566	gfc_fatal_error ("Cannot open file %qs", filename);
2567	}
2568	else
2569	{
2570	input = gfc_open_included_file (name: realfilename, include_cwd: false, module: false);
2571	if (input == NULL)
2572	{
2573	/* For -fpre-include file, current_file is NULL. */
2574	if (current_file)
2575	fatal_error (linemap_line_start (set: line_table, to_line: current_file->line, max_column_hint: 0),
2576	"Cannot open included file %qs", filename);
2577	else
2578	gfc_fatal_error ("Cannot open pre-included file %qs", filename);
2579	}
2580	stat_result = stat (file: realfilename, buf: &st);
2581	if (stat_result == 0 && !S_ISREG (st.st_mode))
2582	{
2583	fclose (stream: input);
2584	if (current_file)
2585	fatal_error (linemap_line_start (set: line_table, to_line: current_file->line, max_column_hint: 0),
2586	"Included file %qs is not a regular file", filename);
2587	else
2588	gfc_fatal_error ("Included file %qs is not a regular file", filename);
2589	}
2590	}
2591
2592	/* Load the file.
2593
2594	A "non-initial" file means a file that is being included. In
2595	that case we are creating an LC_ENTER map.
2596
2597	An "initial" file means a main file; one that is not included.
2598	That file has already got at least one (surely more) line map(s)
2599	created by gfc_init. So the subsequent map created in that case
2600	must have LC_RENAME reason.
2601
2602	This latter case is not true for a preprocessed file. In that
2603	case, although the file is "initial", the line maps created by
2604	gfc_init was used during the preprocessing of the file. Now that
2605	the preprocessing is over and we are being fed the result of that
2606	preprocessing, we need to create a brand new line map for the
2607	preprocessed file, so the reason is going to be LC_ENTER. */
2608
2609	f = get_file (name: filename, reason: (initial && !preprocessed_p) ? LC_RENAME : LC_ENTER);
2610	if (!initial)
2611	add_file_change (filename: f->filename, line: f->inclusion_line);
2612	current_file = f;
2613	current_file->line = 1;
2614	line = NULL;
2615	line_len = 0;
2616	first_line = true;
2617
2618	if (initial && gfc_src_preprocessor_lines[0])
2619	{
2620	preprocessor_line (c: gfc_src_preprocessor_lines[0]);
2621	free (ptr: gfc_src_preprocessor_lines[0]);
2622	gfc_src_preprocessor_lines[0] = NULL;
2623	if (gfc_src_preprocessor_lines[1])
2624	{
2625	preprocessor_line (c: gfc_src_preprocessor_lines[1]);
2626	free (ptr: gfc_src_preprocessor_lines[1]);
2627	gfc_src_preprocessor_lines[1] = NULL;
2628	}
2629	}
2630
2631	for (;;)
2632	{
2633	int trunc = load_line (input, pbuf: &line, pbuflen: &line_len, NULL);
2634	int inc_line;
2635
2636	len = gfc_wide_strlen (str: line);
2637	if (feof (stream: input) && len == 0)
2638	break;
2639
2640	/* If this is the first line of the file, it can contain a byte
2641	order mark (BOM), which we will ignore:
2642	FF FE is UTF-16 little endian,
2643	FE FF is UTF-16 big endian,
2644	EF BB BF is UTF-8. */
2645	if (first_line
2646	&& ((line_len >= 2 && line[0] == (unsigned char) '\xFF'
2647	&& line[1] == (unsigned char) '\xFE')
2648	|| (line_len >= 2 && line[0] == (unsigned char) '\xFE'
2649	&& line[1] == (unsigned char) '\xFF')
2650	|| (line_len >= 3 && line[0] == (unsigned char) '\xEF'
2651	&& line[1] == (unsigned char) '\xBB'
2652	&& line[2] == (unsigned char) '\xBF')))
2653	{
2654	int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
2655	gfc_char_t *new_char = gfc_get_wide_string (line_len);
2656
2657	wide_strcpy (dest: new_char, src: &line[n]);
2658	free (ptr: line);
2659	line = new_char;
2660	len -= n;
2661	}
2662
2663	/* There are three things this line can be: a line of Fortran
2664	source, an include line or a C preprocessor directive. */
2665
2666	if (line[0] == '#')
2667	{
2668	/* When -g3 is specified, it's possible that we emit #define
2669	and #undef lines, which we need to pass to the middle-end
2670	so that it can emit correct debug info. */
2671	if (debug_info_level == DINFO_LEVEL_VERBOSE
2672	&& (wide_strncmp (s1: line, s2: "#define ", n: 8) == 0
2673	|| wide_strncmp (s1: line, s2: "#undef ", n: 7) == 0))
2674	;
2675	else
2676	{
2677	preprocessor_line (c: line);
2678	continue;
2679	}
2680	}
2681
2682	/* Preprocessed files have preprocessor lines added before the byte
2683	order mark, so first_line is not about the first line of the file
2684	but the first line that's not a preprocessor line. */
2685	first_line = false;
2686
2687	inc_line = include_line (line);
2688	if (inc_line > 0)
2689	{
2690	current_file->line++;
2691	continue;
2692	}
2693
2694	/* Add line. */
2695
2696	b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size
2697	+ (len + 1) * sizeof (gfc_char_t));
2698
2699
2700	b->location
2701	= linemap_line_start (set: line_table, to_line: current_file->line++, max_column_hint: len);
2702	/* ??? We add the location for the maximum column possible here,
2703	because otherwise if the next call creates a new line-map, it
2704	will not reserve space for any offset. */
2705	if (len > 0)
2706	linemap_position_for_column (line_table, len);
2707
2708	b->file = current_file;
2709	b->truncated = trunc;
2710	wide_strcpy (dest: b->line, src: line);
2711
2712	if (line_head == NULL)
2713	line_head = b;
2714	else
2715	line_tail->next = b;
2716
2717	line_tail = b;
2718
2719	while (file_changes_cur < file_changes_count)
2720	file_changes[file_changes_cur++].lb = b;
2721
2722	if (flag_dec_include)
2723	{
2724	if (include_b && b != include_b)
2725	{
2726	int inc_line2 = include_stmt (b: include_b);
2727	if (inc_line2 == 0)
2728	include_b = NULL;
2729	else if (inc_line2 > 0)
2730	{
2731	do
2732	{
2733	if (gfc_current_form == FORM_FIXED)
2734	{
2735	for (gfc_char_t *p = include_b->line; *p; p++)
2736	*p = ' ';
2737	}
2738	else
2739	include_b->line[0] = '\0';
2740	if (include_b == b)
2741	break;
2742	include_b = include_b->next;
2743	}
2744	while (1);
2745	include_b = NULL;
2746	}
2747	}
2748	if (inc_line == -1 && !include_b)
2749	include_b = b;
2750	}
2751	}
2752
2753	/* Release the line buffer allocated in load_line. */
2754	free (ptr: line);
2755
2756	fclose (stream: input);
2757
2758	if (!initial)
2759	add_file_change (NULL, line: current_file->inclusion_line + 1);
2760	current_file = current_file->up;
2761	linemap_add (line_table, LC_LEAVE, sysp: 0, NULL, to_line: 0);
2762	}
2763
2764
2765	/* Open a new file and start scanning from that file. Returns true
2766	if everything went OK, false otherwise. If form == FORM_UNKNOWN
2767	it tries to determine the source form from the filename, defaulting
2768	to free form. */
2769
2770	void
2771	gfc_new_file (void)
2772	{
2773	if (flag_pre_include != NULL)
2774	load_file (flag_pre_include, NULL, initial: false);
2775
2776	if (gfc_cpp_enabled ())
2777	{
2778	gfc_cpp_preprocess (source_file: gfc_source_file);
2779	if (!gfc_cpp_preprocess_only ())
2780	load_file (realfilename: gfc_cpp_temporary_file (), displayedname: gfc_source_file, initial: true);
2781	}
2782	else
2783	load_file (realfilename: gfc_source_file, NULL, initial: true);
2784
2785	gfc_current_locus.lb = line_head;
2786	gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
2787
2788	#if 0 /* Debugging aid. */
2789	for (; line_head; line_head = line_head->next)
2790	printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
2791	LOCATION_LINE (line_head->location), line_head->line);
2792
2793	exit (SUCCESS_EXIT_CODE);
2794	#endif
2795	}
2796
2797	static char *
2798	unescape_filename (const char *ptr)
2799	{
2800	const char *p = ptr, *s;
2801	char *d, *ret;
2802	int escaped, unescape = 0;
2803
2804	/* Make filename end at quote. */
2805	escaped = false;
2806	while (*p && ! (! escaped && *p == '"'))
2807	{
2808	if (escaped)
2809	escaped = false;
2810	else if (*p == '\\')
2811	{
2812	escaped = true;
2813	unescape++;
2814	}
2815	++p;
2816	}
2817
2818	if (!*p || p[1])
2819	return NULL;
2820
2821	/* Undo effects of cpp_quote_string. */
2822	s = ptr;
2823	d = XCNEWVEC (char, p + 1 - ptr - unescape);
2824	ret = d;
2825
2826	while (s != p)
2827	{
2828	if (*s == '\\')
2829	*d++ = *++s;
2830	else
2831	*d++ = *s;
2832	s++;
2833	}
2834	*d = '\0';
2835	return ret;
2836	}
2837
2838	/* For preprocessed files, if the first tokens are of the form # NUM.
2839	handle the directives so we know the original file name. */
2840
2841	const char *
2842	gfc_read_orig_filename (const char *filename, const char **canon_source_file)
2843	{
2844	int c, len;
2845	char *dirname, *tmp;
2846
2847	gfc_src_file = gfc_open_file (filename);
2848	if (gfc_src_file == NULL)
2849	return NULL;
2850
2851	c = getc (stream: gfc_src_file);
2852
2853	if (c != '#')
2854	return NULL;
2855
2856	len = 0;
2857	load_line (input: gfc_src_file, pbuf: &gfc_src_preprocessor_lines[0], pbuflen: &len, first_char: &c);
2858
2859	if (wide_strncmp (s1: gfc_src_preprocessor_lines[0], s2: "# 1 \"", n: 5) != 0)
2860	return NULL;
2861
2862	tmp = gfc_widechar_to_char (s: &gfc_src_preprocessor_lines[0][5], length: -1);
2863	filename = unescape_filename (ptr: tmp);
2864	free (ptr: tmp);
2865	if (filename == NULL)
2866	return NULL;
2867
2868	c = getc (stream: gfc_src_file);
2869
2870	if (c != '#')
2871	return filename;
2872
2873	len = 0;
2874	load_line (input: gfc_src_file, pbuf: &gfc_src_preprocessor_lines[1], pbuflen: &len, first_char: &c);
2875
2876	if (wide_strncmp (s1: gfc_src_preprocessor_lines[1], s2: "# 1 \"", n: 5) != 0)
2877	return filename;
2878
2879	tmp = gfc_widechar_to_char (s: &gfc_src_preprocessor_lines[1][5], length: -1);
2880	dirname = unescape_filename (ptr: tmp);
2881	free (ptr: tmp);
2882	if (dirname == NULL)
2883	return filename;
2884
2885	len = strlen (s: dirname);
2886	if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
2887	{
2888	free (ptr: dirname);
2889	return filename;
2890	}
2891	dirname[len - 2] = '\0';
2892	set_src_pwd (dirname);
2893
2894	if (! IS_ABSOLUTE_PATH (filename))
2895	{
2896	char *p = XCNEWVEC (char, len + strlen (filename));
2897
2898	memcpy (dest: p, src: dirname, n: len - 2);
2899	p[len - 2] = '/';
2900	strcpy (dest: p + len - 1, src: filename);
2901	*canon_source_file = p;
2902	}
2903
2904	free (ptr: dirname);
2905	return filename;
2906	}
2907