1	/* Handle errors.
2	Copyright (C) 2000-2023 Free Software Foundation, Inc.
3	Contributed by Andy Vaught & Niels Kristian Bech Jensen
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	/* Handle the inevitable errors. A major catch here is that things
22	flagged as errors in one match subroutine can conceivably be legal
23	elsewhere. This means that error messages are recorded and saved
24	for possible use later. If a line does not match a legal
25	construction, then the saved error message is reported. */
26
27	#include "config.h"
28	#include "system.h"
29	#include "coretypes.h"
30	#include "options.h"
31	#include "gfortran.h"
32
33	#include "diagnostic.h"
34	#include "diagnostic-color.h"
35	#include "tree-diagnostic.h" /* tree_diagnostics_defaults */
36
37	static int suppress_errors = 0;
38
39	static bool warnings_not_errors = false;
40
41	static int terminal_width;
42
43	/* True if the error/warnings should be buffered. */
44	static bool buffered_p;
45
46	static gfc_error_buffer error_buffer;
47	/* These are always buffered buffers (.flush_p == false) to be used by
48	the pretty-printer. */
49	static output_buffer *pp_error_buffer, *pp_warning_buffer;
50	static int warningcount_buffered, werrorcount_buffered;
51
52	/* Return buffered_p. */
53	bool
54	gfc_buffered_p (void)
55	{
56	return buffered_p;
57	}
58
59	/* Return true if there output_buffer is empty. */
60
61	static bool
62	gfc_output_buffer_empty_p (const output_buffer * buf)
63	{
64	return output_buffer_last_position_in_text (buff: buf) == NULL;
65	}
66
67	/* Go one level deeper suppressing errors. */
68
69	void
70	gfc_push_suppress_errors (void)
71	{
72	gcc_assert (suppress_errors >= 0);
73	++suppress_errors;
74	}
75
76	static void
77	gfc_error_opt (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
78
79	static bool
80	gfc_warning (int opt, const char *gmsgid, va_list ap) ATTRIBUTE_GCC_GFC(2,0);
81
82
83	/* Leave one level of error suppressing. */
84
85	void
86	gfc_pop_suppress_errors (void)
87	{
88	gcc_assert (suppress_errors > 0);
89	--suppress_errors;
90	}
91
92
93	/* Query whether errors are suppressed. */
94
95	bool
96	gfc_query_suppress_errors (void)
97	{
98	return suppress_errors > 0;
99	}
100
101
102	/* Determine terminal width (for trimming source lines in output). */
103
104	static int
105	gfc_get_terminal_width (void)
106	{
107	return isatty (STDERR_FILENO) ? get_terminal_width () : INT_MAX;
108	}
109
110
111	/* Per-file error initialization. */
112
113	void
114	gfc_error_init_1 (void)
115	{
116	terminal_width = gfc_get_terminal_width ();
117	gfc_buffer_error (false);
118	}
119
120
121	/* Set the flag for buffering errors or not. */
122
123	void
124	gfc_buffer_error (bool flag)
125	{
126	buffered_p = flag;
127	}
128
129
130	/* Add a single character to the error buffer or output depending on
131	buffered_p. */
132
133	static void
134	error_char (char)
135	{
136	/* FIXME: Unused function to be removed in a subsequent patch. */
137	}
138
139
140	/* Copy a string to wherever it needs to go. */
141
142	static void
143	error_string (const char *p)
144	{
145	while (*p)
146	error_char (*p++);
147	}
148
149
150	/* Print a formatted integer to the error buffer or output. */
151
152	#define IBUF_LEN 60
153
154	static void
155	error_uinteger (unsigned long long int i)
156	{
157	char *p, int_buf[IBUF_LEN];
158
159	p = int_buf + IBUF_LEN - 1;
160	*p-- = '\0';
161
162	if (i == 0)
163	*p-- = '0';
164
165	while (i > 0)
166	{
167	*p-- = i % 10 + '0';
168	i = i / 10;
169	}
170
171	error_string (p: p + 1);
172	}
173
174	static void
175	error_integer (long long int i)
176	{
177	unsigned long long int u;
178
179	if (i < 0)
180	{
181	u = (unsigned long long int) -i;
182	error_char ('-');
183	}
184	else
185	u = i;
186
187	error_uinteger (i: u);
188	}
189
190
191	static void
192	error_hwuint (unsigned HOST_WIDE_INT i)
193	{
194	char *p, int_buf[IBUF_LEN];
195
196	p = int_buf + IBUF_LEN - 1;
197	*p-- = '\0';
198
199	if (i == 0)
200	*p-- = '0';
201
202	while (i > 0)
203	{
204	*p-- = i % 10 + '0';
205	i = i / 10;
206	}
207
208	error_string (p: p + 1);
209	}
210
211	static void
212	error_hwint (HOST_WIDE_INT i)
213	{
214	unsigned HOST_WIDE_INT u;
215
216	if (i < 0)
217	{
218	u = (unsigned HOST_WIDE_INT) -i;
219	error_char ('-');
220	}
221	else
222	u = i;
223
224	error_uinteger (i: u);
225	}
226
227
228	static size_t
229	gfc_widechar_display_length (gfc_char_t c)
230	{
231	if (gfc_wide_is_printable (c) || c == '\t')
232	/* Printable ASCII character, or tabulation (output as a space). */
233	return 1;
234	else if (c < ((gfc_char_t) 1 << 8))
235	/* Displayed as \x?? */
236	return 4;
237	else if (c < ((gfc_char_t) 1 << 16))
238	/* Displayed as \u???? */
239	return 6;
240	else
241	/* Displayed as \U???????? */
242	return 10;
243	}
244
245
246	/* Length of the ASCII representation of the wide string, escaping wide
247	characters as print_wide_char_into_buffer() does. */
248
249	static size_t
250	gfc_wide_display_length (const gfc_char_t *str)
251	{
252	size_t i, len;
253
254	for (i = 0, len = 0; str[i]; i++)
255	len += gfc_widechar_display_length (c: str[i]);
256
257	return len;
258	}
259
260	static int
261	print_wide_char_into_buffer (gfc_char_t c, char *buf)
262	{
263	static const char xdigit[16] = { '0', '1', '2', '3', '4', '5', '6',
264	'7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' };
265
266	if (gfc_wide_is_printable (c) || c == '\t')
267	{
268	buf[1] = '\0';
269	/* Tabulation is output as a space. */
270	buf[0] = (unsigned char) (c == '\t' ? ' ' : c);
271	return 1;
272	}
273	else if (c < ((gfc_char_t) 1 << 8))
274	{
275	buf[4] = '\0';
276	buf[3] = xdigit[c & 0x0F];
277	c = c >> 4;
278	buf[2] = xdigit[c & 0x0F];
279
280	buf[1] = 'x';
281	buf[0] = '\\';
282	return 4;
283	}
284	else if (c < ((gfc_char_t) 1 << 16))
285	{
286	buf[6] = '\0';
287	buf[5] = xdigit[c & 0x0F];
288	c = c >> 4;
289	buf[4] = xdigit[c & 0x0F];
290	c = c >> 4;
291	buf[3] = xdigit[c & 0x0F];
292	c = c >> 4;
293	buf[2] = xdigit[c & 0x0F];
294
295	buf[1] = 'u';
296	buf[0] = '\\';
297	return 6;
298	}
299	else
300	{
301	buf[10] = '\0';
302	buf[9] = xdigit[c & 0x0F];
303	c = c >> 4;
304	buf[8] = xdigit[c & 0x0F];
305	c = c >> 4;
306	buf[7] = xdigit[c & 0x0F];
307	c = c >> 4;
308	buf[6] = xdigit[c & 0x0F];
309	c = c >> 4;
310	buf[5] = xdigit[c & 0x0F];
311	c = c >> 4;
312	buf[4] = xdigit[c & 0x0F];
313	c = c >> 4;
314	buf[3] = xdigit[c & 0x0F];
315	c = c >> 4;
316	buf[2] = xdigit[c & 0x0F];
317
318	buf[1] = 'U';
319	buf[0] = '\\';
320	return 10;
321	}
322	}
323
324	static char wide_char_print_buffer[11];
325
326	const char *
327	gfc_print_wide_char (gfc_char_t c)
328	{
329	print_wide_char_into_buffer (c, buf: wide_char_print_buffer);
330	return wide_char_print_buffer;
331	}
332
333
334	/* Show the file, where it was included, and the source line, give a
335	locus. Calls error_printf() recursively, but the recursion is at
336	most one level deep. */
337
338	static void error_printf (const char *, ...) ATTRIBUTE_GCC_GFC(1,2);
339
340	static void
341	show_locus (locus *loc, int c1, int c2)
342	{
343	gfc_linebuf *lb;
344	gfc_file *f;
345	gfc_char_t *p;
346	int i, offset, cmax;
347
348	/* TODO: Either limit the total length and number of included files
349	displayed or add buffering of arbitrary number of characters in
350	error messages. */
351
352	/* Write out the error header line, giving the source file and error
353	location (in GNU standard "[file]:[line].[column]:" format),
354	followed by an "included by" stack and a blank line. This header
355	format is matched by a testsuite parser defined in
356	lib/gfortran-dg.exp. */
357
358	lb = loc->lb;
359	f = lb->file;
360
361	error_string (p: f->filename);
362	error_char (':');
363
364	error_integer (LOCATION_LINE (lb->location));
365
366	if ((c1 > 0) || (c2 > 0))
367	error_char ('.');
368
369	if (c1 > 0)
370	error_integer (i: c1);
371
372	if ((c1 > 0) && (c2 > 0))
373	error_char ('-');
374
375	if (c2 > 0)
376	error_integer (i: c2);
377
378	error_char (':');
379	error_char ('\n');
380
381	for (;;)
382	{
383	i = f->inclusion_line;
384
385	f = f->up;
386	if (f == NULL) break;
387
388	error_printf (" Included at %s:%d:", f->filename, i);
389	}
390
391	error_char ('\n');
392
393	/* Calculate an appropriate horizontal offset of the source line in
394	order to get the error locus within the visible portion of the
395	line. Note that if the margin of 5 here is changed, the
396	corresponding margin of 10 in show_loci should be changed. */
397
398	offset = 0;
399
400	/* If the two loci would appear in the same column, we shift
401	'2' one column to the right, so as to print '12' rather than
402	just '1'. We do this here so it will be accounted for in the
403	margin calculations. */
404
405	if (c1 == c2)
406	c2 += 1;
407
408	cmax = (c1 < c2) ? c2 : c1;
409	if (cmax > terminal_width - 5)
410	offset = cmax - terminal_width + 5;
411
412	/* Show the line itself, taking care not to print more than what can
413	show up on the terminal. Tabs are converted to spaces, and
414	nonprintable characters are converted to a "\xNN" sequence. */
415
416	p = &(lb->line[offset]);
417	i = gfc_wide_display_length (str: p);
418	if (i > terminal_width)
419	i = terminal_width - 1;
420
421	while (i > 0)
422	{
423	static char buffer[11];
424	i -= print_wide_char_into_buffer (c: *p++, buf: buffer);
425	error_string (p: buffer);
426	}
427
428	error_char ('\n');
429
430	/* Show the '1' and/or '2' corresponding to the column of the error
431	locus. Note that a value of -1 for c1 or c2 will simply cause
432	the relevant number not to be printed. */
433
434	c1 -= offset;
435	c2 -= offset;
436	cmax -= offset;
437
438	p = &(lb->line[offset]);
439	for (i = 0; i < cmax; i++)
440	{
441	int spaces, j;
442	spaces = gfc_widechar_display_length (c: *p++);
443
444	if (i == c1)
445	error_char ('1'), spaces--;
446	else if (i == c2)
447	error_char ('2'), spaces--;
448
449	for (j = 0; j < spaces; j++)
450	error_char (' ');
451	}
452
453	if (i == c1)
454	error_char ('1');
455	else if (i == c2)
456	error_char ('2');
457
458	error_char ('\n');
459
460	}
461
462
463	/* As part of printing an error, we show the source lines that caused
464	the problem. We show at least one, and possibly two loci; the two
465	loci may or may not be on the same source line. */
466
467	static void
468	show_loci (locus *l1, locus *l2)
469	{
470	int m, c1, c2;
471
472	if (l1 == NULL || l1->lb == NULL)
473	{
474	error_printf ("<During initialization>\n");
475	return;
476	}
477
478	/* While calculating parameters for printing the loci, we consider possible
479	reasons for printing one per line. If appropriate, print the loci
480	individually; otherwise we print them both on the same line. */
481
482	c1 = l1->nextc - l1->lb->line;
483	if (l2 == NULL)
484	{
485	show_locus (loc: l1, c1, c2: -1);
486	return;
487	}
488
489	c2 = l2->nextc - l2->lb->line;
490
491	if (c1 < c2)
492	m = c2 - c1;
493	else
494	m = c1 - c2;
495
496	/* Note that the margin value of 10 here needs to be less than the
497	margin of 5 used in the calculation of offset in show_locus. */
498
499	if (l1->lb != l2->lb || m > terminal_width - 10)
500	{
501	show_locus (loc: l1, c1, c2: -1);
502	show_locus (loc: l2, c1: -1, c2);
503	return;
504	}
505
506	show_locus (loc: l1, c1, c2);
507
508	return;
509	}
510
511
512	/* Workhorse for the error printing subroutines. This subroutine is
513	inspired by g77's error handling and is similar to printf() with
514	the following %-codes:
515
516	%c Character, %d or %i Integer, %s String, %% Percent
517	%L Takes locus argument
518	%C Current locus (no argument)
519
520	If a locus pointer is given, the actual source line is printed out
521	and the column is indicated. Since we want the error message at
522	the bottom of any source file information, we must scan the
523	argument list twice -- once to determine whether the loci are
524	present and record this for printing, and once to print the error
525	message after and loci have been printed. A maximum of two locus
526	arguments are permitted.
527
528	This function is also called (recursively) by show_locus in the
529	case of included files; however, as show_locus does not resupply
530	any loci, the recursion is at most one level deep. */
531
532	#define MAX_ARGS 10
533
534	static void ATTRIBUTE_GCC_GFC(2,0)
535	error_print (const char *type, const char *format0, va_list argp)
536	{
537	enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_UINTEGER,
538	TYPE_LONGINT, TYPE_ULONGINT, TYPE_LLONGINT, TYPE_ULLONGINT,
539	TYPE_HWINT, TYPE_HWUINT, TYPE_CHAR, TYPE_STRING, NOTYPE };
540	struct
541	{
542	int type;
543	int pos;
544	union
545	{
546	int intval;
547	unsigned int uintval;
548	long int longintval;
549	unsigned long int ulongintval;
550	long long int llongintval;
551	unsigned long long int ullongintval;
552	HOST_WIDE_INT hwintval;
553	unsigned HOST_WIDE_INT hwuintval;
554	char charval;
555	const char * stringval;
556	} u;
557	} arg[MAX_ARGS], spec[MAX_ARGS];
558	/* spec is the array of specifiers, in the same order as they
559	appear in the format string. arg is the array of arguments,
560	in the same order as they appear in the va_list. */
561
562	char c;
563	int i, n, have_l1, pos, maxpos;
564	locus *l1, *l2, *loc;
565	const char *format;
566
567	loc = l1 = l2 = NULL;
568
569	have_l1 = 0;
570	pos = -1;
571	maxpos = -1;
572
573	n = 0;
574	format = format0;
575
576	for (i = 0; i < MAX_ARGS; i++)
577	{
578	arg[i].type = NOTYPE;
579	spec[i].pos = -1;
580	}
581
582	/* First parse the format string for position specifiers. */
583	while (*format)
584	{
585	c = *format++;
586	if (c != '%')
587	continue;
588
589	if (*format == '%')
590	{
591	format++;
592	continue;
593	}
594
595	if (ISDIGIT (*format))
596	{
597	/* This is a position specifier. For example, the number
598	12 in the format string "%12$d", which specifies the third
599	argument of the va_list, formatted in %d format.
600	For details, see "man 3 printf". */
601	pos = atoi(nptr: format) - 1;
602	gcc_assert (pos >= 0);
603	while (ISDIGIT(*format))
604	format++;
605	gcc_assert (*format == '$');
606	format++;
607	}
608	else
609	pos++;
610
611	c = *format++;
612
613	if (pos > maxpos)
614	maxpos = pos;
615
616	switch (c)
617	{
618	case 'C':
619	arg[pos].type = TYPE_CURRENTLOC;
620	break;
621
622	case 'L':
623	arg[pos].type = TYPE_LOCUS;
624	break;
625
626	case 'd':
627	case 'i':
628	arg[pos].type = TYPE_INTEGER;
629	break;
630
631	case 'u':
632	arg[pos].type = TYPE_UINTEGER;
633	break;
634
635	case 'l':
636	c = *format++;
637	if (c == 'l')
638	{
639	c = *format++;
640	if (c == 'u')
641	arg[pos].type = TYPE_ULLONGINT;
642	else if (c == 'i' || c == 'd')
643	arg[pos].type = TYPE_LLONGINT;
644	else
645	gcc_unreachable ();
646	}
647	else if (c == 'u')
648	arg[pos].type = TYPE_ULONGINT;
649	else if (c == 'i' || c == 'd')
650	arg[pos].type = TYPE_LONGINT;
651	else
652	gcc_unreachable ();
653	break;
654
655	case 'w':
656	c = *format++;
657	if (c == 'u')
658	arg[pos].type = TYPE_HWUINT;
659	else if (c == 'i' || c == 'd')
660	arg[pos].type = TYPE_HWINT;
661	else
662	gcc_unreachable ();
663	break;
664
665	case 'c':
666	arg[pos].type = TYPE_CHAR;
667	break;
668
669	case 's':
670	arg[pos].type = TYPE_STRING;
671	break;
672
673	default:
674	gcc_unreachable ();
675	}
676
677	spec[n++].pos = pos;
678	}
679
680	/* Then convert the values for each %-style argument. */
681	for (pos = 0; pos <= maxpos; pos++)
682	{
683	gcc_assert (arg[pos].type != NOTYPE);
684	switch (arg[pos].type)
685	{
686	case TYPE_CURRENTLOC:
687	loc = &gfc_current_locus;
688	/* Fall through. */
689
690	case TYPE_LOCUS:
691	if (arg[pos].type == TYPE_LOCUS)
692	loc = va_arg (argp, locus *);
693
694	if (have_l1)
695	{
696	l2 = loc;
697	arg[pos].u.stringval = "(2)";
698	/* Point %C first offending character not the last good one. */
699	if (arg[pos].type == TYPE_CURRENTLOC && *l2->nextc != '\0')
700	l2->nextc++;
701	}
702	else
703	{
704	l1 = loc;
705	have_l1 = 1;
706	arg[pos].u.stringval = "(1)";
707	/* Point %C first offending character not the last good one. */
708	if (arg[pos].type == TYPE_CURRENTLOC && *l1->nextc != '\0')
709	l1->nextc++;
710	}
711	break;
712
713	case TYPE_INTEGER:
714	arg[pos].u.intval = va_arg (argp, int);
715	break;
716
717	case TYPE_UINTEGER:
718	arg[pos].u.uintval = va_arg (argp, unsigned int);
719	break;
720
721	case TYPE_LONGINT:
722	arg[pos].u.longintval = va_arg (argp, long int);
723	break;
724
725	case TYPE_ULONGINT:
726	arg[pos].u.ulongintval = va_arg (argp, unsigned long int);
727	break;
728
729	case TYPE_LLONGINT:
730	arg[pos].u.llongintval = va_arg (argp, long long int);
731	break;
732
733	case TYPE_ULLONGINT:
734	arg[pos].u.ullongintval = va_arg (argp, unsigned long long int);
735	break;
736
737	case TYPE_HWINT:
738	arg[pos].u.hwintval = va_arg (argp, HOST_WIDE_INT);
739	break;
740
741	case TYPE_HWUINT:
742	arg[pos].u.hwuintval = va_arg (argp, unsigned HOST_WIDE_INT);
743	break;
744
745	case TYPE_CHAR:
746	arg[pos].u.charval = (char) va_arg (argp, int);
747	break;
748
749	case TYPE_STRING:
750	arg[pos].u.stringval = (const char *) va_arg (argp, char *);
751	break;
752
753	default:
754	gcc_unreachable ();
755	}
756	}
757
758	for (n = 0; spec[n].pos >= 0; n++)
759	spec[n].u = arg[spec[n].pos].u;
760
761	/* Show the current loci if we have to. */
762	if (have_l1)
763	show_loci (l1, l2);
764
765	if (*type)
766	{
767	error_string (p: type);
768	error_char (' ');
769	}
770
771	have_l1 = 0;
772	format = format0;
773	n = 0;
774
775	for (; *format; format++)
776	{
777	if (*format != '%')
778	{
779	error_char (*format);
780	continue;
781	}
782
783	format++;
784	if (ISDIGIT (*format))
785	{
786	/* This is a position specifier. See comment above. */
787	while (ISDIGIT (*format))
788	format++;
789
790	/* Skip over the dollar sign. */
791	format++;
792	}
793
794	switch (*format)
795	{
796	case '%':
797	error_char ('%');
798	break;
799
800	case 'c':
801	error_char (spec[n++].u.charval);
802	break;
803
804	case 's':
805	case 'C': /* Current locus */
806	case 'L': /* Specified locus */
807	error_string (p: spec[n++].u.stringval);
808	break;
809
810	case 'd':
811	case 'i':
812	error_integer (i: spec[n++].u.intval);
813	break;
814
815	case 'u':
816	error_uinteger (i: spec[n++].u.uintval);
817	break;
818
819	case 'l':
820	format++;
821	if (*format == 'l')
822	{
823	format++;
824	if (*format == 'u')
825	error_uinteger (i: spec[n++].u.ullongintval);
826	else
827	error_integer (i: spec[n++].u.llongintval);
828	}
829	if (*format == 'u')
830	error_uinteger (i: spec[n++].u.ulongintval);
831	else
832	error_integer (i: spec[n++].u.longintval);
833	break;
834
835	case 'w':
836	format++;
837	if (*format == 'u')
838	error_hwuint (i: spec[n++].u.hwintval);
839	else
840	error_hwint (i: spec[n++].u.hwuintval);
841	break;
842	}
843	}
844
845	error_char ('\n');
846	}
847
848
849	/* Wrapper for error_print(). */
850
851	static void
852	error_printf (const char *gmsgid, ...)
853	{
854	va_list argp;
855
856	va_start (argp, gmsgid);
857	error_print (type: "", _(gmsgid), argp);
858	va_end (argp);
859	}
860
861
862	/* Clear any output buffered in a pretty-print output_buffer. */
863
864	static void
865	gfc_clear_pp_buffer (output_buffer *this_buffer)
866	{
867	pretty_printer *pp = global_dc->printer;
868	output_buffer *tmp_buffer = pp->buffer;
869	pp->buffer = this_buffer;
870	pp_clear_output_area (pp);
871	pp->buffer = tmp_buffer;
872	/* We need to reset last_location, otherwise we may skip caret lines
873	when we actually give a diagnostic. */
874	global_dc->m_last_location = UNKNOWN_LOCATION;
875	}
876
877	/* The currently-printing diagnostic, for use by gfc_format_decoder,
878	for colorizing %C and %L. */
879
880	static diagnostic_info *curr_diagnostic;
881
882	/* A helper function to call diagnostic_report_diagnostic, while setting
883	curr_diagnostic for the duration of the call. */
884
885	static bool
886	gfc_report_diagnostic (diagnostic_info *diagnostic)
887	{
888	gcc_assert (diagnostic != NULL);
889	curr_diagnostic = diagnostic;
890	bool ret = diagnostic_report_diagnostic (context: global_dc, diagnostic);
891	curr_diagnostic = NULL;
892	return ret;
893	}
894
895	/* This is just a helper function to avoid duplicating the logic of
896	gfc_warning. */
897
898	static bool
899	gfc_warning (int opt, const char *gmsgid, va_list ap)
900	{
901	va_list argp;
902	va_copy (argp, ap);
903
904	diagnostic_info diagnostic;
905	rich_location rich_loc (line_table, UNKNOWN_LOCATION);
906	bool fatal_errors = global_dc->m_fatal_errors;
907	pretty_printer *pp = global_dc->printer;
908	output_buffer *tmp_buffer = pp->buffer;
909
910	gfc_clear_pp_buffer (this_buffer: pp_warning_buffer);
911
912	if (buffered_p)
913	{
914	pp->buffer = pp_warning_buffer;
915	global_dc->m_fatal_errors = false;
916	/* To prevent -fmax-errors= triggering. */
917	--werrorcount;
918	}
919
920	diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
921	DK_WARNING);
922	diagnostic.option_index = opt;
923	bool ret = gfc_report_diagnostic (diagnostic: &diagnostic);
924
925	if (buffered_p)
926	{
927	pp->buffer = tmp_buffer;
928	global_dc->m_fatal_errors = fatal_errors;
929
930	warningcount_buffered = 0;
931	werrorcount_buffered = 0;
932	/* Undo the above --werrorcount if not Werror, otherwise
933	werrorcount is correct already. */
934	if (!ret)
935	++werrorcount;
936	else if (diagnostic.kind == DK_ERROR)
937	++werrorcount_buffered;
938	else
939	++werrorcount, --warningcount, ++warningcount_buffered;
940	}
941
942	va_end (argp);
943	return ret;
944	}
945
946	/* Issue a warning. */
947
948	bool
949	gfc_warning (int opt, const char *gmsgid, ...)
950	{
951	va_list argp;
952
953	va_start (argp, gmsgid);
954	bool ret = gfc_warning (opt, gmsgid, ap: argp);
955	va_end (argp);
956	return ret;
957	}
958
959
960	/* Whether, for a feature included in a given standard set (GFC_STD_*),
961	we should issue an error or a warning, or be quiet. */
962
963	notification
964	gfc_notification_std (int std)
965	{
966	bool warning;
967
968	warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings;
969	if ((gfc_option.allow_std & std) != 0 && !warning)
970	return SILENT;
971
972	return warning ? WARNING : ERROR;
973	}
974
975
976	/* Return a string describing the nature of a standard violation
977	* and/or the relevant version of the standard. */
978
979	char const*
980	notify_std_msg(int std)
981	{
982
983	if (std & GFC_STD_F2018_DEL)
984	return _("Fortran 2018 deleted feature:");
985	else if (std & GFC_STD_F2018_OBS)
986	return _("Fortran 2018 obsolescent feature:");
987	else if (std & GFC_STD_F2018)
988	return _("Fortran 2018:");
989	else if (std & GFC_STD_F2008_OBS)
990	return _("Fortran 2008 obsolescent feature:");
991	else if (std & GFC_STD_F2008)
992	return "Fortran 2008:";
993	else if (std & GFC_STD_F2003)
994	return "Fortran 2003:";
995	else if (std & GFC_STD_GNU)
996	return _("GNU Extension:");
997	else if (std & GFC_STD_LEGACY)
998	return _("Legacy Extension:");
999	else if (std & GFC_STD_F95_OBS)
1000	return _("Obsolescent feature:");
1001	else if (std & GFC_STD_F95_DEL)
1002	return _("Deleted feature:");
1003	else
1004	gcc_unreachable ();
1005	}
1006
1007
1008	/* Possibly issue a warning/error about use of a nonstandard (or deleted)
1009	feature. An error/warning will be issued if the currently selected
1010	standard does not contain the requested bits. Return false if
1011	an error is generated. */
1012
1013	bool
1014	gfc_notify_std (int std, const char *gmsgid, ...)
1015	{
1016	va_list argp;
1017	const char *msg, *msg2;
1018	char *buffer;
1019
1020	/* Determine whether an error or a warning is needed. */
1021	const int wstd = std & gfc_option.warn_std; /* Standard to warn about. */
1022	const int estd = std & ~gfc_option.allow_std; /* Standard to error about. */
1023	const bool warning = (wstd != 0) && !inhibit_warnings;
1024	const bool error = (estd != 0);
1025
1026	if (!error && !warning)
1027	return true;
1028	if (suppress_errors)
1029	return !error;
1030
1031	if (error)
1032	msg = notify_std_msg (std: estd);
1033	else
1034	msg = notify_std_msg (std: wstd);
1035
1036	msg2 = _(gmsgid);
1037	buffer = (char *) alloca (strlen (msg) + strlen (msg2) + 2);
1038	strcpy (dest: buffer, src: msg);
1039	strcat (dest: buffer, src: " ");
1040	strcat (dest: buffer, src: msg2);
1041
1042	va_start (argp, gmsgid);
1043	if (error)
1044	gfc_error_opt (opt: 0, gmsgid: buffer, ap: argp);
1045	else
1046	gfc_warning (opt: 0, gmsgid: buffer, ap: argp);
1047	va_end (argp);
1048
1049	if (error)
1050	return false;
1051	else
1052	return (warning && !warnings_are_errors);
1053	}
1054
1055
1056	/* Called from output_format -- during diagnostic message processing
1057	to handle Fortran specific format specifiers with the following meanings:
1058
1059	%C Current locus (no argument)
1060	%L Takes locus argument
1061	*/
1062	static bool
1063	gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec,
1064	int precision, bool wide, bool set_locus, bool hash,
1065	bool *quoted, const char **buffer_ptr)
1066	{
1067	switch (*spec)
1068	{
1069	case 'C':
1070	case 'L':
1071	{
1072	static const char *result[2] = { "(1)", "(2)" };
1073	locus *loc;
1074	if (*spec == 'C')
1075	loc = &gfc_current_locus;
1076	else
1077	loc = va_arg (*text->m_args_ptr, locus *);
1078	gcc_assert (loc->nextc - loc->lb->line >= 0);
1079	unsigned int offset = loc->nextc - loc->lb->line;
1080	if (*spec == 'C' && *loc->nextc != '\0')
1081	/* Point %C first offending character not the last good one. */
1082	offset++;
1083	/* If location[0] != UNKNOWN_LOCATION means that we already
1084	processed one of %C/%L. */
1085	int loc_num = text->get_location (index_of_location: 0) == UNKNOWN_LOCATION ? 0 : 1;
1086	location_t src_loc
1087	= linemap_position_for_loc_and_offset (set: line_table,
1088	loc: loc->lb->location,
1089	offset);
1090	text->set_location (idx: loc_num, loc: src_loc, range_display_kind: SHOW_RANGE_WITH_CARET);
1091	/* Colorize the markers to match the color choices of
1092	diagnostic_show_locus (the initial location has a color given
1093	by the "kind" of the diagnostic, the secondary location has
1094	color "range1"). */
1095	gcc_assert (curr_diagnostic != NULL);
1096	const char *color
1097	= (loc_num
1098	? "range1"
1099	: diagnostic_get_color_for_kind (kind: curr_diagnostic->kind));
1100	pp_string (pp, colorize_start (pp_show_color (pp), name: color));
1101	pp_string (pp, result[loc_num]);
1102	pp_string (pp, colorize_stop (pp_show_color (pp)));
1103	return true;
1104	}
1105	default:
1106	/* Fall through info the middle-end decoder, as e.g. stor-layout.cc
1107	etc. diagnostics can use the FE printer while the FE is still
1108	active. */
1109	return default_tree_printer (pp, text, spec, precision, wide,
1110	set_locus, hash, quoted, buffer_ptr);
1111	}
1112	}
1113
1114	/* Return a malloc'd string describing the kind of diagnostic. The
1115	caller is responsible for freeing the memory. */
1116	static char *
1117	gfc_diagnostic_build_kind_prefix (diagnostic_context *context,
1118	const diagnostic_info *diagnostic)
1119	{
1120	static const char *const diagnostic_kind_text[] = {
1121	#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T),
1122	#include "gfc-diagnostic.def"
1123	#undef DEFINE_DIAGNOSTIC_KIND
1124	"must-not-happen"
1125	};
1126	static const char *const diagnostic_kind_color[] = {
1127	#define DEFINE_DIAGNOSTIC_KIND(K, T, C) (C),
1128	#include "gfc-diagnostic.def"
1129	#undef DEFINE_DIAGNOSTIC_KIND
1130	NULL
1131	};
1132	gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND);
1133	const char *text = _(diagnostic_kind_text[diagnostic->kind]);
1134	const char *text_cs = "", *text_ce = "";
1135	pretty_printer *pp = context->printer;
1136
1137	if (diagnostic_kind_color[diagnostic->kind])
1138	{
1139	text_cs = colorize_start (pp_show_color (pp),
1140	name: diagnostic_kind_color[diagnostic->kind]);
1141	text_ce = colorize_stop (pp_show_color (pp));
1142	}
1143	return build_message_string ("%s%s:%s ", text_cs, text, text_ce);
1144	}
1145
1146	/* Return a malloc'd string describing a location. The caller is
1147	responsible for freeing the memory. */
1148	static char *
1149	gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
1150	expanded_location s)
1151	{
1152	pretty_printer *pp = context->printer;
1153	const char *locus_cs = colorize_start (pp_show_color (pp), name: "locus");
1154	const char *locus_ce = colorize_stop (pp_show_color (pp));
1155	return (s.file == NULL
1156	? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
1157	: !strcmp (s1: s.file, s2: special_fname_builtin ())
1158	? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1159	: context->m_show_column
1160	? build_message_string ("%s%s:%d:%d:%s", locus_cs, s.file, s.line,
1161	s.column, locus_ce)
1162	: build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line, locus_ce));
1163	}
1164
1165	/* Return a malloc'd string describing two locations. The caller is
1166	responsible for freeing the memory. */
1167	static char *
1168	gfc_diagnostic_build_locus_prefix (diagnostic_context *context,
1169	expanded_location s, expanded_location s2)
1170	{
1171	pretty_printer *pp = context->printer;
1172	const char *locus_cs = colorize_start (pp_show_color (pp), name: "locus");
1173	const char *locus_ce = colorize_stop (pp_show_color (pp));
1174
1175	return (s.file == NULL
1176	? build_message_string ("%s%s:%s", locus_cs, progname, locus_ce )
1177	: !strcmp (s1: s.file, s2: special_fname_builtin ())
1178	? build_message_string ("%s%s:%s", locus_cs, s.file, locus_ce)
1179	: context->m_show_column
1180	? build_message_string ("%s%s:%d:%d-%d:%s", locus_cs, s.file, s.line,
1181	MIN (s.column, s2.column),
1182	MAX (s.column, s2.column), locus_ce)
1183	: build_message_string ("%s%s:%d:%s", locus_cs, s.file, s.line,
1184	locus_ce));
1185	}
1186
1187	/* This function prints the locus (file:line:column), the diagnostic kind
1188	(Error, Warning) and (optionally) the relevant lines of code with
1189	annotation lines with '1' and/or '2' below them.
1190
1191	With -fdiagnostic-show-caret (the default) it prints:
1192
1193	[locus of primary range]:
1194
1195	some code
1196	1
1197	Error: Some error at (1)
1198
1199	With -fno-diagnostic-show-caret or if the primary range is not
1200	valid, it prints:
1201
1202	[locus of primary range]: Error: Some error at (1) and (2)
1203	*/
1204	static void
1205	gfc_diagnostic_starter (diagnostic_context *context,
1206	diagnostic_info *diagnostic)
1207	{
1208	char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic);
1209
1210	expanded_location s1 = diagnostic_expand_location (diagnostic);
1211	expanded_location s2;
1212	bool one_locus = diagnostic->richloc->get_num_locations () < 2;
1213	bool same_locus = false;
1214
1215	if (!one_locus)
1216	{
1217	s2 = diagnostic_expand_location (diagnostic, which: 1);
1218	same_locus = diagnostic_same_line (context, s1, s2);
1219	}
1220
1221	char * locus_prefix = (one_locus || !same_locus)
1222	? gfc_diagnostic_build_locus_prefix (context, s: s1)
1223	: gfc_diagnostic_build_locus_prefix (context, s: s1, s2);
1224
1225	if (!context->m_source_printing.enabled
1226	|| diagnostic_location (diagnostic, which: 0) <= BUILTINS_LOCATION
1227	|| diagnostic_location (diagnostic, which: 0) == context->m_last_location)
1228	{
1229	pp_set_prefix (context->printer,
1230	concat (locus_prefix, " ", kind_prefix, NULL));
1231	free (ptr: locus_prefix);
1232
1233	if (one_locus || same_locus)
1234	{
1235	free (ptr: kind_prefix);
1236	return;
1237	}
1238	/* In this case, we print the previous locus and prefix as:
1239
1240	[locus]:[prefix]: (1)
1241
1242	and we flush with a new line before setting the new prefix. */
1243	pp_string (context->printer, "(1)");
1244	pp_newline (context->printer);
1245	locus_prefix = gfc_diagnostic_build_locus_prefix (context, s: s2);
1246	pp_set_prefix (context->printer,
1247	concat (locus_prefix, " ", kind_prefix, NULL));
1248	free (ptr: kind_prefix);
1249	free (ptr: locus_prefix);
1250	}
1251	else
1252	{
1253	pp_verbatim (context->printer, "%s", locus_prefix);
1254	free (ptr: locus_prefix);
1255	/* Fortran uses an empty line between locus and caret line. */
1256	pp_newline (context->printer);
1257	pp_set_prefix (context->printer, NULL);
1258	pp_newline (context->printer);
1259	diagnostic_show_locus (context, richloc: diagnostic->richloc, diagnostic_kind: diagnostic->kind);
1260	/* If the caret line was shown, the prefix does not contain the
1261	locus. */
1262	pp_set_prefix (context->printer, kind_prefix);
1263	}
1264	}
1265
1266	static void
1267	gfc_diagnostic_start_span (diagnostic_context *context,
1268	expanded_location exploc)
1269	{
1270	char *locus_prefix;
1271	locus_prefix = gfc_diagnostic_build_locus_prefix (context, s: exploc);
1272	pp_verbatim (context->printer, "%s", locus_prefix);
1273	free (ptr: locus_prefix);
1274	pp_newline (context->printer);
1275	/* Fortran uses an empty line between locus and caret line. */
1276	pp_newline (context->printer);
1277	}
1278
1279
1280	static void
1281	gfc_diagnostic_finalizer (diagnostic_context *context,
1282	diagnostic_info *diagnostic ATTRIBUTE_UNUSED,
1283	diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED)
1284	{
1285	pp_destroy_prefix (context->printer);
1286	pp_newline_and_flush (context->printer);
1287	}
1288
1289	/* Immediate warning (i.e. do not buffer the warning) with an explicit
1290	location. */
1291
1292	bool
1293	gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...)
1294	{
1295	va_list argp;
1296	diagnostic_info diagnostic;
1297	rich_location rich_loc (line_table, loc);
1298	bool ret;
1299
1300	va_start (argp, gmsgid);
1301	diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING);
1302	diagnostic.option_index = opt;
1303	ret = gfc_report_diagnostic (diagnostic: &diagnostic);
1304	va_end (argp);
1305	return ret;
1306	}
1307
1308	/* Immediate warning (i.e. do not buffer the warning). */
1309
1310	bool
1311	gfc_warning_now (int opt, const char *gmsgid, ...)
1312	{
1313	va_list argp;
1314	diagnostic_info diagnostic;
1315	rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1316	bool ret;
1317
1318	va_start (argp, gmsgid);
1319	diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
1320	DK_WARNING);
1321	diagnostic.option_index = opt;
1322	ret = gfc_report_diagnostic (diagnostic: &diagnostic);
1323	va_end (argp);
1324	return ret;
1325	}
1326
1327	/* Internal warning, do not buffer. */
1328
1329	bool
1330	gfc_warning_internal (int opt, const char *gmsgid, ...)
1331	{
1332	va_list argp;
1333	diagnostic_info diagnostic;
1334	rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1335	bool ret;
1336
1337	va_start (argp, gmsgid);
1338	diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc,
1339	DK_WARNING);
1340	diagnostic.option_index = opt;
1341	ret = gfc_report_diagnostic (diagnostic: &diagnostic);
1342	va_end (argp);
1343	return ret;
1344	}
1345
1346	/* Immediate error (i.e. do not buffer). */
1347
1348	void
1349	gfc_error_now (const char *gmsgid, ...)
1350	{
1351	va_list argp;
1352	diagnostic_info diagnostic;
1353	rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1354
1355	error_buffer.flag = true;
1356
1357	va_start (argp, gmsgid);
1358	diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR);
1359	gfc_report_diagnostic (diagnostic: &diagnostic);
1360	va_end (argp);
1361	}
1362
1363
1364	/* Fatal error, never returns. */
1365
1366	void
1367	gfc_fatal_error (const char *gmsgid, ...)
1368	{
1369	va_list argp;
1370	diagnostic_info diagnostic;
1371	rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1372
1373	va_start (argp, gmsgid);
1374	diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL);
1375	gfc_report_diagnostic (diagnostic: &diagnostic);
1376	va_end (argp);
1377
1378	gcc_unreachable ();
1379	}
1380
1381	/* Clear the warning flag. */
1382
1383	void
1384	gfc_clear_warning (void)
1385	{
1386	gfc_clear_pp_buffer (this_buffer: pp_warning_buffer);
1387	warningcount_buffered = 0;
1388	werrorcount_buffered = 0;
1389	}
1390
1391
1392	/* Check to see if any warnings have been saved.
1393	If so, print the warning. */
1394
1395	void
1396	gfc_warning_check (void)
1397	{
1398	if (! gfc_output_buffer_empty_p (buf: pp_warning_buffer))
1399	{
1400	pretty_printer *pp = global_dc->printer;
1401	output_buffer *tmp_buffer = pp->buffer;
1402	pp->buffer = pp_warning_buffer;
1403	pp_really_flush (pp);
1404	warningcount += warningcount_buffered;
1405	werrorcount += werrorcount_buffered;
1406	gcc_assert (warningcount_buffered + werrorcount_buffered == 1);
1407	pp->buffer = tmp_buffer;
1408	diagnostic_action_after_output (context: global_dc,
1409	diag_kind: warningcount_buffered
1410	? DK_WARNING : DK_ERROR);
1411	diagnostic_check_max_errors (context: global_dc, flush: true);
1412	}
1413	}
1414
1415
1416	/* Issue an error. */
1417
1418	static void
1419	gfc_error_opt (int opt, const char *gmsgid, va_list ap)
1420	{
1421	va_list argp;
1422	va_copy (argp, ap);
1423	bool saved_abort_on_error = false;
1424
1425	if (warnings_not_errors)
1426	{
1427	gfc_warning (opt, gmsgid, ap: argp);
1428	va_end (argp);
1429	return;
1430	}
1431
1432	if (suppress_errors)
1433	{
1434	va_end (argp);
1435	return;
1436	}
1437
1438	diagnostic_info diagnostic;
1439	rich_location richloc (line_table, UNKNOWN_LOCATION);
1440	bool fatal_errors = global_dc->m_fatal_errors;
1441	pretty_printer *pp = global_dc->printer;
1442	output_buffer *tmp_buffer = pp->buffer;
1443
1444	gfc_clear_pp_buffer (this_buffer: pp_error_buffer);
1445
1446	if (buffered_p)
1447	{
1448	/* To prevent -dH from triggering an abort on a buffered error,
1449	save abort_on_error and restore it below. */
1450	saved_abort_on_error = global_dc->m_abort_on_error;
1451	global_dc->m_abort_on_error = false;
1452	pp->buffer = pp_error_buffer;
1453	global_dc->m_fatal_errors = false;
1454	/* To prevent -fmax-errors= triggering, we decrease it before
1455	report_diagnostic increases it. */
1456	--errorcount;
1457	}
1458
1459	diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR);
1460	gfc_report_diagnostic (diagnostic: &diagnostic);
1461
1462	if (buffered_p)
1463	{
1464	pp->buffer = tmp_buffer;
1465	global_dc->m_fatal_errors = fatal_errors;
1466	global_dc->m_abort_on_error = saved_abort_on_error;
1467
1468	}
1469
1470	va_end (argp);
1471	}
1472
1473
1474	void
1475	gfc_error_opt (int opt, const char *gmsgid, ...)
1476	{
1477	va_list argp;
1478	va_start (argp, gmsgid);
1479	gfc_error_opt (opt, gmsgid, ap: argp);
1480	va_end (argp);
1481	}
1482
1483
1484	void
1485	gfc_error (const char *gmsgid, ...)
1486	{
1487	va_list argp;
1488	va_start (argp, gmsgid);
1489	gfc_error_opt (opt: 0, gmsgid, ap: argp);
1490	va_end (argp);
1491	}
1492
1493
1494	/* This shouldn't happen... but sometimes does. */
1495
1496	void
1497	gfc_internal_error (const char *gmsgid, ...)
1498	{
1499	int e, w;
1500	va_list argp;
1501	diagnostic_info diagnostic;
1502	rich_location rich_loc (line_table, UNKNOWN_LOCATION);
1503
1504	gfc_get_errors (&w, &e);
1505	if (e > 0)
1506	exit(EXIT_FAILURE);
1507
1508	va_start (argp, gmsgid);
1509	diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE);
1510	gfc_report_diagnostic (diagnostic: &diagnostic);
1511	va_end (argp);
1512
1513	gcc_unreachable ();
1514	}
1515
1516
1517	/* Clear the error flag when we start to compile a source line. */
1518
1519	void
1520	gfc_clear_error (void)
1521	{
1522	error_buffer.flag = false;
1523	warnings_not_errors = false;
1524	gfc_clear_pp_buffer (this_buffer: pp_error_buffer);
1525	}
1526
1527
1528	/* Tests the state of error_flag. */
1529
1530	bool
1531	gfc_error_flag_test (void)
1532	{
1533	return error_buffer.flag
1534	|| !gfc_output_buffer_empty_p (buf: pp_error_buffer);
1535	}
1536
1537
1538	/* Check to see if any errors have been saved.
1539	If so, print the error. Returns the state of error_flag. */
1540
1541	bool
1542	gfc_error_check (void)
1543	{
1544	if (error_buffer.flag
1545	|| ! gfc_output_buffer_empty_p (buf: pp_error_buffer))
1546	{
1547	error_buffer.flag = false;
1548	pretty_printer *pp = global_dc->printer;
1549	output_buffer *tmp_buffer = pp->buffer;
1550	pp->buffer = pp_error_buffer;
1551	pp_really_flush (pp);
1552	++errorcount;
1553	gcc_assert (gfc_output_buffer_empty_p (pp_error_buffer));
1554	pp->buffer = tmp_buffer;
1555	diagnostic_action_after_output (context: global_dc, diag_kind: DK_ERROR);
1556	diagnostic_check_max_errors (context: global_dc, flush: true);
1557	return true;
1558	}
1559
1560	return false;
1561	}
1562
1563	/* Move the text buffered from FROM to TO, then clear
1564	FROM. Independently if there was text in FROM, TO is also
1565	cleared. */
1566
1567	static void
1568	gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from,
1569	gfc_error_buffer * buffer_to)
1570	{
1571	output_buffer * from = &(buffer_from->buffer);
1572	output_buffer * to = &(buffer_to->buffer);
1573
1574	buffer_to->flag = buffer_from->flag;
1575	buffer_from->flag = false;
1576
1577	gfc_clear_pp_buffer (this_buffer: to);
1578	/* We make sure this is always buffered. */
1579	to->flush_p = false;
1580
1581	if (! gfc_output_buffer_empty_p (buf: from))
1582	{
1583	const char *str = output_buffer_formatted_text (buff: from);
1584	output_buffer_append_r (buff: to, start: str, length: strlen (s: str));
1585	gfc_clear_pp_buffer (this_buffer: from);
1586	}
1587	}
1588
1589	/* Save the existing error state. */
1590
1591	void
1592	gfc_push_error (gfc_error_buffer *err)
1593	{
1594	gfc_move_error_buffer_from_to (buffer_from: &error_buffer, buffer_to: err);
1595	}
1596
1597
1598	/* Restore a previous pushed error state. */
1599
1600	void
1601	gfc_pop_error (gfc_error_buffer *err)
1602	{
1603	gfc_move_error_buffer_from_to (buffer_from: err, buffer_to: &error_buffer);
1604	}
1605
1606
1607	/* Free a pushed error state, but keep the current error state. */
1608
1609	void
1610	gfc_free_error (gfc_error_buffer *err)
1611	{
1612	gfc_clear_pp_buffer (this_buffer: &(err->buffer));
1613	}
1614
1615
1616	/* Report the number of warnings and errors that occurred to the caller. */
1617
1618	void
1619	gfc_get_errors (int *w, int *e)
1620	{
1621	if (w != NULL)
1622	*w = warningcount + werrorcount;
1623	if (e != NULL)
1624	*e = errorcount + sorrycount + werrorcount;
1625	}
1626
1627
1628	/* Switch errors into warnings. */
1629
1630	void
1631	gfc_errors_to_warnings (bool f)
1632	{
1633	warnings_not_errors = f;
1634	}
1635
1636	void
1637	gfc_diagnostics_init (void)
1638	{
1639	diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1640	global_dc->m_text_callbacks.start_span = gfc_diagnostic_start_span;
1641	diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1642	diagnostic_format_decoder (global_dc) = gfc_format_decoder;
1643	global_dc->m_source_printing.caret_chars[0] = '1';
1644	global_dc->m_source_printing.caret_chars[1] = '2';
1645	pp_warning_buffer = new (XNEW (output_buffer)) output_buffer ();
1646	pp_warning_buffer->flush_p = false;
1647	/* pp_error_buffer is statically allocated. This simplifies memory
1648	management when using gfc_push/pop_error. */
1649	pp_error_buffer = &(error_buffer.buffer);
1650	pp_error_buffer->flush_p = false;
1651	}
1652
1653	void
1654	gfc_diagnostics_finish (void)
1655	{
1656	tree_diagnostics_defaults (context: global_dc);
1657	/* We still want to use the gfc starter and finalizer, not the tree
1658	defaults. */
1659	diagnostic_starter (global_dc) = gfc_diagnostic_starter;
1660	diagnostic_finalizer (global_dc) = gfc_diagnostic_finalizer;
1661	global_dc->m_source_printing.caret_chars[0] = '^';
1662	global_dc->m_source_printing.caret_chars[1] = '^';
1663	}
1664