1	/* Print GENERIC declaration (functions, variables, types) trees coming from
2	the C and C++ front-ends as well as macros in Ada syntax.
3	Copyright (C) 2010-2023 Free Software Foundation, Inc.
4	Adapted from tree-pretty-print.cc by Arnaud Charlet <charlet@adacore.com>
5
6	This file is part of GCC.
7
8	GCC is free software; you can redistribute it and/or modify it under
9	the terms of the GNU General Public License as published by the Free
10	Software Foundation; either version 3, or (at your option) any later
11	version.
12
13	GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14	WARRANTY; without even the implied warranty of MERCHANTABILITY or
15	FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16	for more details.
17
18	You should have received a copy of the GNU General Public License
19	along with GCC; see the file COPYING3. If not see
20	<http://www.gnu.org/licenses/>. */
21
22	#include "config.h"
23	#include "system.h"
24	#include "coretypes.h"
25	#include "tm.h"
26	#include "stringpool.h"
27	#include "tree.h"
28	#include "c-ada-spec.h"
29	#include "fold-const.h"
30	#include "c-pragma.h"
31	#include "diagnostic.h"
32	#include "stringpool.h"
33	#include "attribs.h"
34	#include "bitmap.h"
35
36	/* Local functions, macros and variables. */
37	static int dump_ada_node (pretty_printer *, tree, tree, int, bool, bool);
38	static int dump_ada_declaration (pretty_printer *, tree, tree, int);
39	static void dump_ada_structure (pretty_printer *, tree, tree, bool, int);
40	static char *to_ada_name (const char *, bool *);
41
42	#define INDENT(SPACE) \
43	do { int i; for (i = 0; i<SPACE; i++) pp_space (buffer); } while (0)
44
45	#define INDENT_INCR 3
46
47	/* Global hook used to perform C++ queries on nodes. */
48	static int (*cpp_check) (tree, cpp_operation) = NULL;
49
50	/* Global variables used in macro-related callbacks. */
51	static int max_ada_macros;
52	static int store_ada_macro_index;
53	static const char *macro_source_file;
54
55	/* Given a cpp MACRO, compute the max length BUFFER_LEN of the macro, as well
56	as max length PARAM_LEN of arguments for fun_like macros, and also set
57	SUPPORTED to 0 if the macro cannot be mapped to an Ada construct. */
58
59	static void
60	macro_length (const cpp_macro *macro, int *supported, int *buffer_len,
61	int *param_len)
62	{
63	int i;
64	unsigned j;
65
66	*supported = 1;
67	*buffer_len = 0;
68	*param_len = 0;
69
70	if (macro->fun_like)
71	{
72	(*param_len)++;
73	for (i = 0; i < macro->paramc; i++)
74	{
75	cpp_hashnode *param = macro->parm.params[i];
76
77	*param_len += NODE_LEN (param);
78
79	if (i + 1 < macro->paramc)
80	{
81	*param_len += 2; /* ", " */
82	}
83	else if (macro->variadic)
84	{
85	*supported = 0;
86	return;
87	}
88	}
89	*param_len += 2; /* ")\0" */
90	}
91
92	for (j = 0; j < macro->count; j++)
93	{
94	const cpp_token *token = &macro->exp.tokens[j];
95
96	if (token->flags & PREV_WHITE)
97	(*buffer_len)++;
98
99	if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT)
100	{
101	*supported = 0;
102	return;
103	}
104
105	if (token->type == CPP_MACRO_ARG)
106	*buffer_len +=
107	NODE_LEN (macro->parm.params[token->val.macro_arg.arg_no - 1]);
108	else
109	/* Include enough extra space to handle e.g. special characters. */
110	*buffer_len += (cpp_token_len (token) + 1) * 8;
111	}
112
113	(*buffer_len)++;
114	}
115
116	/* Dump all digits/hex chars from NUMBER to BUFFER and return a pointer
117	to the character after the last character written. If FLOAT_P is true,
118	this is a floating-point number. */
119
120	static unsigned char *
121	dump_number (unsigned char *number, unsigned char *buffer, bool float_p)
122	{
123	while (*number != '\0'
124	&& *number != (float_p ? 'F' : 'U')
125	&& *number != (float_p ? 'f' : 'u')
126	&& *number != 'l'
127	&& *number != 'L')
128	*buffer++ = *number++;
129
130	return buffer;
131	}
132
133	/* Handle escape character C and convert to an Ada character into BUFFER.
134	Return a pointer to the character after the last character written, or
135	NULL if the escape character is not supported. */
136
137	static unsigned char *
138	handle_escape_character (unsigned char *buffer, char c)
139	{
140	switch (c)
141	{
142	case '"':
143	*buffer++ = '"';
144	*buffer++ = '"';
145	break;
146
147	case 'n':
148	strcpy (dest: (char *) buffer, src: "\" & ASCII.LF & \"");
149	buffer += 16;
150	break;
151
152	case 'r':
153	strcpy (dest: (char *) buffer, src: "\" & ASCII.CR & \"");
154	buffer += 16;
155	break;
156
157	case 't':
158	strcpy (dest: (char *) buffer, src: "\" & ASCII.HT & \"");
159	buffer += 16;
160	break;
161
162	default:
163	return NULL;
164	}
165
166	return buffer;
167	}
168
169	/* Callback used to count the number of macros from cpp_forall_identifiers.
170	PFILE and V are not used. NODE is the current macro to consider. */
171
172	static int
173	count_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *node,
174	void *v ATTRIBUTE_UNUSED)
175	{
176	if (cpp_user_macro_p (node) && *NODE_NAME (node) != '_')
177	{
178	const cpp_macro *macro = node->value.macro;
179	if (macro->count && LOCATION_FILE (macro->line) == macro_source_file)
180	max_ada_macros++;
181	}
182
183	return 1;
184	}
185
186	/* Callback used to store relevant macros from cpp_forall_identifiers.
187	PFILE is not used. NODE is the current macro to store if relevant.
188	MACROS is an array of cpp_hashnode* used to store NODE. */
189
190	static int
191	store_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED,
192	cpp_hashnode *node, void *macros)
193	{
194	if (cpp_user_macro_p (node) && *NODE_NAME (node) != '_')
195	{
196	const cpp_macro *macro = node->value.macro;
197	if (macro->count
198	&& LOCATION_FILE (macro->line) == macro_source_file)
199	((cpp_hashnode **) macros)[store_ada_macro_index++] = node;
200	}
201	return 1;
202	}
203
204	/* Callback used to compare (during qsort) macros. NODE1 and NODE2 are the
205	two macro nodes to compare. */
206
207	static int
208	compare_macro (const void *node1, const void *node2)
209	{
210	typedef const cpp_hashnode *const_hnode;
211
212	const_hnode n1 = *(const const_hnode *) node1;
213	const_hnode n2 = *(const const_hnode *) node2;
214
215	return n1->value.macro->line - n2->value.macro->line;
216	}
217
218	/* Dump in PP all relevant macros appearing in FILE. */
219
220	static void
221	dump_ada_macros (pretty_printer *pp, const char* file)
222	{
223	int num_macros = 0, prev_line = -1;
224	cpp_hashnode **macros;
225
226	/* Initialize file-scope variables. */
227	max_ada_macros = 0;
228	store_ada_macro_index = 0;
229	macro_source_file = file;
230
231	/* Count all potentially relevant macros, and then sort them by sloc. */
232	cpp_forall_identifiers (parse_in, count_ada_macro, NULL);
233	macros = XALLOCAVEC (cpp_hashnode *, max_ada_macros);
234	cpp_forall_identifiers (parse_in, store_ada_macro, macros);
235	qsort (macros, max_ada_macros, sizeof (cpp_hashnode *), compare_macro);
236
237	for (int j = 0; j < max_ada_macros; j++)
238	{
239	cpp_hashnode *node = macros[j];
240	const cpp_macro *macro = node->value.macro;
241	unsigned i;
242	int supported = 1, prev_is_one = 0, buffer_len, param_len;
243	int is_string = 0, is_char = 0;
244	char *ada_name;
245	unsigned char *s, *params, *buffer, *buf_param, *char_one = NULL, *tmp;
246
247	macro_length (macro, supported: &supported, buffer_len: &buffer_len, param_len: &param_len);
248	s = buffer = XALLOCAVEC (unsigned char, buffer_len);
249	params = buf_param = XALLOCAVEC (unsigned char, param_len);
250
251	if (supported)
252	{
253	if (macro->fun_like)
254	{
255	*buf_param++ = '(';
256	for (i = 0; i < macro->paramc; i++)
257	{
258	cpp_hashnode *param = macro->parm.params[i];
259
260	memcpy (dest: buf_param, NODE_NAME (param), NODE_LEN (param));
261	buf_param += NODE_LEN (param);
262
263	if (i + 1 < macro->paramc)
264	{
265	*buf_param++ = ',';
266	*buf_param++ = ' ';
267	}
268	else if (macro->variadic)
269	{
270	supported = 0;
271	break;
272	}
273	}
274	*buf_param++ = ')';
275	*buf_param = '\0';
276	}
277
278	for (i = 0; supported && i < macro->count; i++)
279	{
280	const cpp_token *token = &macro->exp.tokens[i];
281	int is_one = 0;
282
283	if (token->flags & PREV_WHITE)
284	*buffer++ = ' ';
285
286	if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT)
287	{
288	supported = 0;
289	break;
290	}
291
292	switch (token->type)
293	{
294	case CPP_MACRO_ARG:
295	{
296	cpp_hashnode *param =
297	macro->parm.params[token->val.macro_arg.arg_no - 1];
298	memcpy (dest: buffer, NODE_NAME (param), NODE_LEN (param));
299	buffer += NODE_LEN (param);
300	}
301	break;
302
303	case CPP_EQ_EQ: *buffer++ = '='; break;
304	case CPP_GREATER: *buffer++ = '>'; break;
305	case CPP_LESS: *buffer++ = '<'; break;
306	case CPP_PLUS: *buffer++ = '+'; break;
307	case CPP_MINUS: *buffer++ = '-'; break;
308	case CPP_MULT: *buffer++ = '*'; break;
309	case CPP_DIV: *buffer++ = '/'; break;
310	case CPP_COMMA: *buffer++ = ','; break;
311	case CPP_OPEN_SQUARE:
312	case CPP_OPEN_PAREN: *buffer++ = '('; break;
313	case CPP_CLOSE_SQUARE: /* fallthrough */
314	case CPP_CLOSE_PAREN: *buffer++ = ')'; break;
315	case CPP_DEREF: /* fallthrough */
316	case CPP_SCOPE: /* fallthrough */
317	case CPP_DOT: *buffer++ = '.'; break;
318
319	case CPP_EQ: *buffer++ = ':'; *buffer++ = '='; break;
320	case CPP_NOT_EQ: *buffer++ = '/'; *buffer++ = '='; break;
321	case CPP_GREATER_EQ: *buffer++ = '>'; *buffer++ = '='; break;
322	case CPP_LESS_EQ: *buffer++ = '<'; *buffer++ = '='; break;
323
324	case CPP_NOT:
325	*buffer++ = 'n'; *buffer++ = 'o'; *buffer++ = 't'; break;
326	case CPP_MOD:
327	*buffer++ = 'm'; *buffer++ = 'o'; *buffer++ = 'd'; break;
328	case CPP_AND:
329	*buffer++ = 'a'; *buffer++ = 'n'; *buffer++ = 'd'; break;
330	case CPP_OR:
331	*buffer++ = 'o'; *buffer++ = 'r'; break;
332	case CPP_XOR:
333	*buffer++ = 'x'; *buffer++ = 'o'; *buffer++ = 'r'; break;
334	case CPP_AND_AND:
335	strcpy (dest: (char *) buffer, src: " and then ");
336	buffer += 10;
337	break;
338	case CPP_OR_OR:
339	strcpy (dest: (char *) buffer, src: " or else ");
340	buffer += 9;
341	break;
342
343	case CPP_PADDING:
344	*buffer++ = ' ';
345	is_one = prev_is_one;
346	break;
347
348	case CPP_COMMENT:
349	break;
350
351	case CPP_WSTRING:
352	case CPP_STRING16:
353	case CPP_STRING32:
354	case CPP_UTF8STRING:
355	case CPP_WCHAR:
356	case CPP_CHAR16:
357	case CPP_CHAR32:
358	case CPP_UTF8CHAR:
359	case CPP_NAME:
360	if (!macro->fun_like)
361	supported = 0;
362	else
363	buffer
364	= cpp_spell_token (parse_in, token, buffer, false);
365	break;
366
367	case CPP_STRING:
368	if (is_string)
369	{
370	*buffer++ = '&';
371	*buffer++ = ' ';
372	}
373	else
374	is_string = 1;
375	{
376	const unsigned char *s = token->val.str.text;
377
378	for (; *s; s++)
379	if (*s == '\\')
380	{
381	s++;
382	buffer = handle_escape_character (buffer, c: *s);
383	if (buffer == NULL)
384	{
385	supported = 0;
386	break;
387	}
388	}
389	else
390	*buffer++ = *s;
391	}
392	break;
393
394	case CPP_CHAR:
395	is_char = 1;
396	{
397	unsigned chars_seen;
398	int ignored;
399	cppchar_t c;
400
401	c = cpp_interpret_charconst (parse_in, token,
402	&chars_seen, &ignored);
403	if (c >= 32 && c <= 126)
404	{
405	*buffer++ = '\'';
406	*buffer++ = (char) c;
407	*buffer++ = '\'';
408	}
409	else
410	{
411	chars_seen = sprintf (s: (char *) buffer,
412	format: "Character'Val (%d)", (int) c);
413	buffer += chars_seen;
414	}
415	}
416	break;
417
418	case CPP_NUMBER:
419	tmp = cpp_token_as_text (parse_in, token);
420
421	switch (*tmp)
422	{
423	case '0':
424	switch (tmp[1])
425	{
426	case '\0':
427	case 'l':
428	case 'L':
429	case 'u':
430	case 'U':
431	*buffer++ = '0';
432	break;
433
434	case 'x':
435	case 'X':
436	*buffer++ = '1';
437	*buffer++ = '6';
438	*buffer++ = '#';
439	buffer = dump_number (number: tmp + 2, buffer, float_p: false);
440	*buffer++ = '#';
441	break;
442
443	case 'b':
444	case 'B':
445	*buffer++ = '2';
446	*buffer++ = '#';
447	buffer = dump_number (number: tmp + 2, buffer, float_p: false);
448	*buffer++ = '#';
449	break;
450
451	default:
452	/* Dump floating-point constant unmodified. */
453	if (strchr (s: (const char *)tmp, c: '.'))
454	buffer = dump_number (number: tmp, buffer, float_p: true);
455	else
456	{
457	*buffer++ = '8';
458	*buffer++ = '#';
459	buffer
460	= dump_number (number: tmp + 1, buffer, float_p: false);
461	*buffer++ = '#';
462	}
463	break;
464	}
465	break;
466
467	case '1':
468	if (tmp[1] == '\0'
469	|| tmp[1] == 'u'
470	|| tmp[1] == 'U'
471	|| tmp[1] == 'l'
472	|| tmp[1] == 'L')
473	{
474	is_one = 1;
475	char_one = buffer;
476	*buffer++ = '1';
477	break;
478	}
479	/* fallthrough */
480
481	default:
482	buffer
483	= dump_number (number: tmp, buffer,
484	float_p: strchr (s: (const char *)tmp, c: '.'));
485	break;
486	}
487	break;
488
489	case CPP_LSHIFT:
490	if (prev_is_one)
491	{
492	/* Replace "1 << N" by "2 ** N" */
493	*char_one = '2';
494	*buffer++ = '*';
495	*buffer++ = '*';
496	break;
497	}
498	/* fallthrough */
499
500	case CPP_RSHIFT:
501	case CPP_COMPL:
502	case CPP_QUERY:
503	case CPP_EOF:
504	case CPP_PLUS_EQ:
505	case CPP_MINUS_EQ:
506	case CPP_MULT_EQ:
507	case CPP_DIV_EQ:
508	case CPP_MOD_EQ:
509	case CPP_AND_EQ:
510	case CPP_OR_EQ:
511	case CPP_XOR_EQ:
512	case CPP_RSHIFT_EQ:
513	case CPP_LSHIFT_EQ:
514	case CPP_PRAGMA:
515	case CPP_PRAGMA_EOL:
516	case CPP_HASH:
517	case CPP_PASTE:
518	case CPP_OPEN_BRACE:
519	case CPP_CLOSE_BRACE:
520	case CPP_SEMICOLON:
521	case CPP_ELLIPSIS:
522	case CPP_PLUS_PLUS:
523	case CPP_MINUS_MINUS:
524	case CPP_DEREF_STAR:
525	case CPP_DOT_STAR:
526	case CPP_ATSIGN:
527	case CPP_HEADER_NAME:
528	case CPP_AT_NAME:
529	case CPP_OTHER:
530	case CPP_OBJC_STRING:
531	default:
532	if (!macro->fun_like)
533	supported = 0;
534	else
535	buffer = cpp_spell_token (parse_in, token, buffer, false);
536	break;
537	}
538
539	prev_is_one = is_one;
540	}
541
542	if (supported)
543	*buffer = '\0';
544	}
545
546	if (macro->fun_like && supported)
547	{
548	char *start = (char *) s;
549	int is_function = 0;
550
551	pp_string (pp, " -- arg-macro: ");
552
553	if (*start == '(' && buffer[-1] == ')')
554	{
555	start++;
556	buffer[-1] = '\0';
557	is_function = 1;
558	pp_string (pp, "function ");
559	}
560	else
561	{
562	pp_string (pp, "procedure ");
563	}
564
565	pp_string (pp, (const char *) NODE_NAME (node));
566	pp_space (pp);
567	pp_string (pp, (char *) params);
568	pp_newline (pp);
569	pp_string (pp, " -- ");
570
571	if (is_function)
572	{
573	pp_string (pp, "return ");
574	pp_string (pp, start);
575	pp_semicolon (pp);
576	}
577	else
578	pp_string (pp, start);
579
580	pp_newline (pp);
581	}
582	else if (supported)
583	{
584	expanded_location sloc = expand_location (macro->line);
585
586	if (sloc.line != prev_line + 1 && prev_line > 0)
587	pp_newline (pp);
588
589	num_macros++;
590	prev_line = sloc.line;
591
592	pp_string (pp, " ");
593	ada_name = to_ada_name ((const char *) NODE_NAME (node), NULL);
594	pp_string (pp, ada_name);
595	free (ptr: ada_name);
596	pp_string (pp, " : ");
597
598	if (is_string)
599	pp_string (pp, "aliased constant String");
600	else if (is_char)
601	pp_string (pp, "aliased constant Character");
602	else
603	pp_string (pp, "constant");
604
605	pp_string (pp, " := ");
606	pp_string (pp, (char *) s);
607
608	if (is_string)
609	pp_string (pp, " & ASCII.NUL");
610
611	pp_string (pp, "; -- ");
612	pp_string (pp, sloc.file);
613	pp_colon (pp);
614	pp_decimal_int (pp, sloc.line);
615	pp_newline (pp);
616	}
617	else
618	{
619	pp_string (pp, " -- unsupported macro: ");
620	pp_string (pp, (const char *) cpp_macro_definition (parse_in, node));
621	pp_newline (pp);
622	}
623	}
624
625	if (num_macros > 0)
626	pp_newline (pp);
627	}
628
629	/* Current source file being handled. */
630	static const char *current_source_file;
631
632	/* Return sloc of DECL, using sloc of last field if LAST is true. */
633
634	static location_t
635	decl_sloc (const_tree decl, bool last)
636	{
637	tree field;
638
639	/* Compare the declaration of struct-like types based on the sloc of their
640	last field (if LAST is true), so that more nested types collate before
641	less nested ones. */
642	if (TREE_CODE (decl) == TYPE_DECL
643	&& !DECL_ORIGINAL_TYPE (decl)
644	&& RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl))
645	&& (field = TYPE_FIELDS (TREE_TYPE (decl))))
646	{
647	if (last)
648	while (DECL_CHAIN (field))
649	field = DECL_CHAIN (field);
650	return DECL_SOURCE_LOCATION (field);
651	}
652
653	return DECL_SOURCE_LOCATION (decl);
654	}
655
656	/* Compare two locations LHS and RHS. */
657
658	static int
659	compare_location (location_t lhs, location_t rhs)
660	{
661	expanded_location xlhs = expand_location (lhs);
662	expanded_location xrhs = expand_location (rhs);
663
664	if (xlhs.file != xrhs.file)
665	return filename_cmp (s1: xlhs.file, s2: xrhs.file);
666
667	if (xlhs.line != xrhs.line)
668	return xlhs.line - xrhs.line;
669
670	if (xlhs.column != xrhs.column)
671	return xlhs.column - xrhs.column;
672
673	return 0;
674	}
675
676	/* Compare two declarations (LP and RP) by their source location. */
677
678	static int
679	compare_node (const void *lp, const void *rp)
680	{
681	const_tree lhs = *((const tree *) lp);
682	const_tree rhs = *((const tree *) rp);
683	const int ret
684	= compare_location (lhs: decl_sloc (decl: lhs, last: true), rhs: decl_sloc (decl: rhs, last: true));
685
686	return ret ? ret : DECL_UID (lhs) - DECL_UID (rhs);
687	}
688
689	/* Compare two comments (LP and RP) by their source location. */
690
691	static int
692	compare_comment (const void *lp, const void *rp)
693	{
694	const cpp_comment *lhs = (const cpp_comment *) lp;
695	const cpp_comment *rhs = (const cpp_comment *) rp;
696
697	return compare_location (lhs: lhs->sloc, rhs: rhs->sloc);
698	}
699
700	static tree *to_dump = NULL;
701	static int to_dump_count = 0;
702
703	/* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped
704	by a subsequent call to dump_ada_nodes. */
705
706	void
707	collect_ada_nodes (tree t, const char *source_file)
708	{
709	tree n;
710	int i = to_dump_count;
711
712	/* Count the likely relevant nodes: do not dump builtins (they are irrelevant
713	in the context of bindings) and namespaces (we do not handle them properly
714	yet). */
715	for (n = t; n; n = TREE_CHAIN (n))
716	if (!DECL_IS_UNDECLARED_BUILTIN (n)
717	&& TREE_CODE (n) != NAMESPACE_DECL
718	&& LOCATION_FILE (decl_sloc (n, false)) == source_file)
719	to_dump_count++;
720
721	/* Allocate sufficient storage for all nodes. */
722	to_dump = XRESIZEVEC (tree, to_dump, to_dump_count);
723
724	/* Store the relevant nodes. */
725	for (n = t; n; n = TREE_CHAIN (n))
726	if (!DECL_IS_UNDECLARED_BUILTIN (n)
727	&& TREE_CODE (n) != NAMESPACE_DECL
728	&& LOCATION_FILE (decl_sloc (n, false)) == source_file)
729	to_dump[i++] = n;
730	}
731
732	/* Call back for walk_tree to clear the TREE_VISITED flag of TP. */
733
734	static tree
735	unmark_visited_r (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
736	void *data ATTRIBUTE_UNUSED)
737	{
738	if (TREE_VISITED (*tp))
739	TREE_VISITED (*tp) = 0;
740	else
741	*walk_subtrees = 0;
742
743	return NULL_TREE;
744	}
745
746	/* Print a COMMENT to the output stream PP. */
747
748	static void
749	print_comment (pretty_printer *pp, const char *comment)
750	{
751	int len = strlen (s: comment);
752	char *str = XALLOCAVEC (char, len + 1);
753	char *tok;
754	bool extra_newline = false;
755
756	memcpy (dest: str, src: comment, n: len + 1);
757
758	/* Trim C/C++ comment indicators. */
759	if (str[len - 2] == '*' && str[len - 1] == '/')
760	{
761	str[len - 2] = ' ';
762	str[len - 1] = '\0';
763	}
764	str += 2;
765
766	tok = strtok (s: str, delim: "\n");
767	while (tok) {
768	pp_string (pp, " --");
769	pp_string (pp, tok);
770	pp_newline (pp);
771	tok = strtok (NULL, delim: "\n");
772
773	/* Leave a blank line after multi-line comments. */
774	if (tok)
775	extra_newline = true;
776	}
777
778	if (extra_newline)
779	pp_newline (pp);
780	}
781
782	/* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls
783	to collect_ada_nodes. */
784
785	static void
786	dump_ada_nodes (pretty_printer *pp, const char *source_file)
787	{
788	int i, j;
789	cpp_comment_table *comments;
790
791	/* Sort the table of declarations to dump by sloc. */
792	qsort (to_dump, to_dump_count, sizeof (tree), compare_node);
793
794	/* Fetch the table of comments. */
795	comments = cpp_get_comments (parse_in);
796
797	/* Sort the comments table by sloc. */
798	if (comments->count > 1)
799	qsort (comments->entries, comments->count, sizeof (cpp_comment),
800	compare_comment);
801
802	/* Interleave comments and declarations in line number order. */
803	i = j = 0;
804	do
805	{
806	/* Advance j until comment j is in this file. */
807	while (j != comments->count
808	&& LOCATION_FILE (comments->entries[j].sloc) != source_file)
809	j++;
810
811	/* Advance j until comment j is not a duplicate. */
812	while (j < comments->count - 1
813	&& !compare_comment (lp: &comments->entries[j],
814	rp: &comments->entries[j + 1]))
815	j++;
816
817	/* Write decls until decl i collates after comment j. */
818	while (i != to_dump_count)
819	{
820	if (j == comments->count
821	|| LOCATION_LINE (decl_sloc (to_dump[i], false))
822	< LOCATION_LINE (comments->entries[j].sloc))
823	{
824	current_source_file = source_file;
825
826	if (dump_ada_declaration (pp, to_dump[i++], NULL_TREE,
827	INDENT_INCR))
828	{
829	pp_newline (pp);
830	pp_newline (pp);
831	}
832	}
833	else
834	break;
835	}
836
837	/* Write comment j, if there is one. */
838	if (j != comments->count)
839	print_comment (pp, comment: comments->entries[j++].comment);
840
841	} while (i != to_dump_count || j != comments->count);
842
843	/* Clear the TREE_VISITED flag over each subtree we've dumped. */
844	for (i = 0; i < to_dump_count; i++)
845	walk_tree (&to_dump[i], unmark_visited_r, NULL, NULL);
846
847	/* Finalize the to_dump table. */
848	if (to_dump)
849	{
850	free (ptr: to_dump);
851	to_dump = NULL;
852	to_dump_count = 0;
853	}
854	}
855
856	/* Dump a newline and indent BUFFER by SPC chars. */
857
858	static void
859	newline_and_indent (pretty_printer *buffer, int spc)
860	{
861	pp_newline (buffer);
862	INDENT (spc);
863	}
864
865	struct with { char *s; const char *in_file; bool limited; };
866	static struct with *withs = NULL;
867	static int withs_max = 4096;
868	static int with_len = 0;
869
870	/* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is
871	true), if not already done. */
872
873	static void
874	append_withs (const char *s, bool limited_access)
875	{
876	int i;
877
878	if (withs == NULL)
879	withs = XNEWVEC (struct with, withs_max);
880
881	if (with_len == withs_max)
882	{
883	withs_max *= 2;
884	withs = XRESIZEVEC (struct with, withs, withs_max);
885	}
886
887	for (i = 0; i < with_len; i++)
888	if (!strcmp (s1: s, s2: withs[i].s)
889	&& current_source_file == withs[i].in_file)
890	{
891	withs[i].limited &= limited_access;
892	return;
893	}
894
895	withs[with_len].s = xstrdup (s);
896	withs[with_len].in_file = current_source_file;
897	withs[with_len].limited = limited_access;
898	with_len++;
899	}
900
901	/* Reset "with" clauses. */
902
903	static void
904	reset_ada_withs (void)
905	{
906	int i;
907
908	if (!withs)
909	return;
910
911	for (i = 0; i < with_len; i++)
912	free (ptr: withs[i].s);
913	free (ptr: withs);
914	withs = NULL;
915	withs_max = 4096;
916	with_len = 0;
917	}
918
919	/* Dump "with" clauses in F. */
920
921	static void
922	dump_ada_withs (FILE *f)
923	{
924	int i;
925
926	fprintf (stream: f, format: "with Interfaces.C; use Interfaces.C;\n");
927
928	for (i = 0; i < with_len; i++)
929	fprintf
930	(stream: f, format: "%swith %s;\n", withs[i].limited ? "limited " : "", withs[i].s);
931	}
932
933	/* Return suitable Ada package name from FILE. */
934
935	static char *
936	get_ada_package (const char *file)
937	{
938	const char *base;
939	char *res;
940	const char *s;
941	int i;
942	size_t plen;
943
944	s = strstr (haystack: file, needle: "/include/");
945	if (s)
946	base = s + 9;
947	else
948	base = lbasename (file);
949
950	if (ada_specs_parent == NULL)
951	plen = 0;
952	else
953	plen = strlen (ada_specs_parent) + 1;
954
955	res = XNEWVEC (char, plen + strlen (base) + 1);
956	if (ada_specs_parent != NULL) {
957	strcpy (dest: res, ada_specs_parent);
958	res[plen - 1] = '.';
959	}
960
961	for (i = plen; *base; base++, i++)
962	switch (*base)
963	{
964	case '+':
965	res[i] = 'p';
966	break;
967
968	case '.':
969	case '-':
970	case '_':
971	case '/':
972	case '\\':
973	res[i] = (i == 0 || res[i - 1] == '.' || res[i - 1] == '_') ? 'u' : '_';
974	break;
975
976	default:
977	res[i] = *base;
978	break;
979	}
980	res[i] = '\0';
981
982	return res;
983	}
984
985	static const char *ada_reserved[] = {
986	"abort", "abs", "abstract", "accept", "access", "aliased", "all", "and",
987	"array", "at", "begin", "body", "case", "constant", "declare", "delay",
988	"delta", "digits", "do", "else", "elsif", "end", "entry", "exception",
989	"exit", "for", "function", "generic", "goto", "if", "in", "interface", "is",
990	"limited", "loop", "mod", "new", "not", "null", "others", "out", "of", "or",
991	"overriding", "package", "pragma", "private", "procedure", "protected",
992	"raise", "range", "record", "rem", "renames", "requeue", "return", "reverse",
993	"select", "separate", "subtype", "synchronized", "tagged", "task",
994	"terminate", "then", "type", "until", "use", "when", "while", "with", "xor",
995	NULL};
996
997	/* ??? would be nice to specify this list via a config file, so that users
998	can create their own dictionary of conflicts. */
999	static const char *c_duplicates[] = {
1000	/* system will cause troubles with System.Address. */
1001	"system",
1002
1003	/* The following values have other definitions with same name/other
1004	casing. */
1005	"funmap",
1006	"rl_vi_fWord",
1007	"rl_vi_bWord",
1008	"rl_vi_eWord",
1009	"rl_readline_version",
1010	"_Vx_ushort",
1011	"USHORT",
1012	"XLookupKeysym",
1013	NULL};
1014
1015	/* Return a declaration tree corresponding to TYPE. */
1016
1017	static tree
1018	get_underlying_decl (tree type)
1019	{
1020	if (!type)
1021	return NULL_TREE;
1022
1023	/* type is a declaration. */
1024	if (DECL_P (type))
1025	return type;
1026
1027	if (TYPE_P (type))
1028	{
1029	/* Strip qualifiers but do not look through typedefs. */
1030	if (TYPE_QUALS_NO_ADDR_SPACE (type))
1031	type = TYPE_MAIN_VARIANT (type);
1032
1033	/* type is a typedef. */
1034	if (TYPE_NAME (type) && DECL_P (TYPE_NAME (type)))
1035	return TYPE_NAME (type);
1036
1037	/* TYPE_STUB_DECL has been set for type. */
1038	if (TYPE_STUB_DECL (type))
1039	return TYPE_STUB_DECL (type);
1040	}
1041
1042	return NULL_TREE;
1043	}
1044
1045	/* Return whether TYPE has static fields. */
1046
1047	static bool
1048	has_static_fields (const_tree type)
1049	{
1050	if (!type || !RECORD_OR_UNION_TYPE_P (type) || !COMPLETE_TYPE_P (type))
1051	return false;
1052
1053	for (tree fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))
1054	if (VAR_P (fld) && DECL_NAME (fld))
1055	return true;
1056
1057	return false;
1058	}
1059
1060	/* Return whether TYPE corresponds to an Ada tagged type (has a dispatch
1061	table). */
1062
1063	static bool
1064	is_tagged_type (const_tree type)
1065	{
1066	if (!type || !RECORD_OR_UNION_TYPE_P (type) || !COMPLETE_TYPE_P (type))
1067	return false;
1068
1069	for (tree fld = TYPE_FIELDS (type); fld; fld = TREE_CHAIN (fld))
1070	if (TREE_CODE (fld) == FUNCTION_DECL && DECL_VINDEX (fld))
1071	return true;
1072
1073	return false;
1074	}
1075
1076	/* Return whether TYPE has non-trivial methods, i.e. methods that do something
1077	for the objects of TYPE. In C++, all classes have implicit special methods,
1078	e.g. constructors and destructors, but they can be trivial if the type is
1079	sufficiently simple. */
1080
1081	static bool
1082	has_nontrivial_methods (tree type)
1083	{
1084	if (!type || !RECORD_OR_UNION_TYPE_P (type) || !COMPLETE_TYPE_P (type))
1085	return false;
1086
1087	/* Only C++ types can have methods. */
1088	if (!cpp_check)
1089	return false;
1090
1091	/* A non-trivial type has non-trivial special methods. */
1092	if (!cpp_check (type, IS_TRIVIAL))
1093	return true;
1094
1095	/* If there are user-defined methods, they are deemed non-trivial. */
1096	for (tree fld = TYPE_FIELDS (type); fld; fld = DECL_CHAIN (fld))
1097	if (TREE_CODE (fld) == FUNCTION_DECL && !DECL_ARTIFICIAL (fld))
1098	return true;
1099
1100	return false;
1101	}
1102
1103	#define INDEX_LENGTH 8
1104
1105	/* Generate a legal Ada name from a C/C++ NAME and return a malloc'ed string.
1106	SPACE_FOUND, if not NULL, is used to indicate whether a space was found in
1107	NAME. */
1108
1109	static char *
1110	to_ada_name (const char *name, bool *space_found)
1111	{
1112	const char **names;
1113	const int len = strlen (s: name);
1114	int j, len2 = 0;
1115	bool found = false;
1116	char *s = XNEWVEC (char, len * 2 + 5);
1117	char c;
1118
1119	if (space_found)
1120	*space_found = false;
1121
1122	/* Add "c_" prefix if name is an Ada reserved word. */
1123	for (names = ada_reserved; *names; names++)
1124	if (!strcasecmp (s1: name, s2: *names))
1125	{
1126	s[len2++] = 'c';
1127	s[len2++] = '_';
1128	found = true;
1129	break;
1130	}
1131
1132	if (!found)
1133	/* Add "c_" prefix if name is a potential case sensitive duplicate. */
1134	for (names = c_duplicates; *names; names++)
1135	if (!strcmp (s1: name, s2: *names))
1136	{
1137	s[len2++] = 'c';
1138	s[len2++] = '_';
1139	found = true;
1140	break;
1141	}
1142
1143	for (j = 0; name[j] == '_'; j++)
1144	s[len2++] = 'u';
1145
1146	if (j > 0)
1147	s[len2++] = '_';
1148	else if (*name == '.' || *name == '$')
1149	{
1150	s[0] = 'a';
1151	s[1] = 'n';
1152	s[2] = 'o';
1153	s[3] = 'n';
1154	len2 = 4;
1155	j++;
1156	}
1157
1158	/* Replace unsuitable characters for Ada identifiers. */
1159	for (; j < len; j++)
1160	switch (name[j])
1161	{
1162	case ' ':
1163	if (space_found)
1164	*space_found = true;
1165	s[len2++] = '_';
1166	break;
1167
1168	/* ??? missing some C++ operators. */
1169	case '=':
1170	s[len2++] = '_';
1171
1172	if (name[j + 1] == '=')
1173	{
1174	j++;
1175	s[len2++] = 'e';
1176	s[len2++] = 'q';
1177	}
1178	else
1179	{
1180	s[len2++] = 'a';
1181	s[len2++] = 's';
1182	}
1183	break;
1184
1185	case '!':
1186	s[len2++] = '_';
1187	if (name[j + 1] == '=')
1188	{
1189	j++;
1190	s[len2++] = 'n';
1191	s[len2++] = 'e';
1192	}
1193	break;
1194
1195	case '~':
1196	s[len2++] = '_';
1197	s[len2++] = 't';
1198	s[len2++] = 'i';
1199	break;
1200
1201	case '&':
1202	case '|':
1203	case '^':
1204	s[len2++] = '_';
1205	s[len2++] = name[j] == '&' ? 'a' : name[j] == '|' ? 'o' : 'x';
1206
1207	if (name[j + 1] == '=')
1208	{
1209	j++;
1210	s[len2++] = 'e';
1211	}
1212	break;
1213
1214	case '+':
1215	case '-':
1216	case '*':
1217	case '/':
1218	case '(':
1219	case '[':
1220	if (s[len2 - 1] != '_')
1221	s[len2++] = '_';
1222
1223	switch (name[j + 1]) {
1224	case '\0':
1225	j++;
1226	switch (name[j - 1]) {
1227	case '+': s[len2++] = 'p'; break; /* + */
1228	case '-': s[len2++] = 'm'; break; /* - */
1229	case '*': s[len2++] = 't'; break; /* * */
1230	case '/': s[len2++] = 'd'; break; /* / */
1231	}
1232	break;
1233
1234	case '=':
1235	j++;
1236	switch (name[j - 1]) {
1237	case '+': s[len2++] = 'p'; break; /* += */
1238	case '-': s[len2++] = 'm'; break; /* -= */
1239	case '*': s[len2++] = 't'; break; /* *= */
1240	case '/': s[len2++] = 'd'; break; /* /= */
1241	}
1242	s[len2++] = 'a';
1243	break;
1244
1245	case '-': /* -- */
1246	j++;
1247	s[len2++] = 'm';
1248	s[len2++] = 'm';
1249	break;
1250
1251	case '+': /* ++ */
1252	j++;
1253	s[len2++] = 'p';
1254	s[len2++] = 'p';
1255	break;
1256
1257	case ')': /* () */
1258	j++;
1259	s[len2++] = 'o';
1260	s[len2++] = 'p';
1261	break;
1262
1263	case ']': /* [] */
1264	j++;
1265	s[len2++] = 'o';
1266	s[len2++] = 'b';
1267	break;
1268	}
1269
1270	break;
1271
1272	case '<':
1273	case '>':
1274	c = name[j] == '<' ? 'l' : 'g';
1275	s[len2++] = '_';
1276
1277	switch (name[j + 1]) {
1278	case '\0':
1279	s[len2++] = c;
1280	s[len2++] = 't';
1281	break;
1282	case '=':
1283	j++;
1284	s[len2++] = c;
1285	s[len2++] = 'e';
1286	break;
1287	case '>':
1288	j++;
1289	s[len2++] = 's';
1290	s[len2++] = 'r';
1291	break;
1292	case '<':
1293	j++;
1294	s[len2++] = 's';
1295	s[len2++] = 'l';
1296	break;
1297	default:
1298	break;
1299	}
1300	break;
1301
1302	case '_':
1303	if (len2 && s[len2 - 1] == '_')
1304	s[len2++] = 'u';
1305	/* fall through */
1306
1307	default:
1308	s[len2++] = name[j];
1309	}
1310
1311	if (s[len2 - 1] == '_')
1312	s[len2++] = 'u';
1313
1314	s[len2] = '\0';
1315
1316	return s;
1317	}
1318
1319	/* Return true if DECL refers to a C++ class type for which a
1320	separate enclosing package has been or should be generated. */
1321
1322	static bool
1323	separate_class_package (tree decl)
1324	{
1325	tree type = TREE_TYPE (decl);
1326	return has_nontrivial_methods (type) || has_static_fields (type);
1327	}
1328
1329	static bool package_prefix = true;
1330
1331	/* Dump in BUFFER the name of an identifier NODE of type TYPE, following Ada
1332	syntax. LIMITED_ACCESS indicates whether NODE can be accessed through a
1333	limited 'with' clause rather than a regular 'with' clause. */
1334
1335	static void
1336	pp_ada_tree_identifier (pretty_printer *buffer, tree node, tree type,
1337	bool limited_access)
1338	{
1339	const char *name = IDENTIFIER_POINTER (node);
1340	bool space_found = false;
1341	char *s = to_ada_name (name, space_found: &space_found);
1342	tree decl = get_underlying_decl (type);
1343
1344	if (decl)
1345	{
1346	/* If the entity comes from another file, generate a package prefix. */
1347	const expanded_location xloc = expand_location (decl_sloc (decl, last: false));
1348
1349	if (xloc.line && xloc.file && xloc.file != current_source_file)
1350	{
1351	switch (TREE_CODE (type))
1352	{
1353	case ENUMERAL_TYPE:
1354	case INTEGER_TYPE:
1355	case REAL_TYPE:
1356	case FIXED_POINT_TYPE:
1357	case BOOLEAN_TYPE:
1358	case REFERENCE_TYPE:
1359	case POINTER_TYPE:
1360	case ARRAY_TYPE:
1361	case RECORD_TYPE:
1362	case UNION_TYPE:
1363	case TYPE_DECL:
1364	if (package_prefix)
1365	{
1366	char *s1 = get_ada_package (file: xloc.file);
1367	append_withs (s: s1, limited_access);
1368	pp_string (buffer, s1);
1369	pp_dot (buffer);
1370	free (ptr: s1);
1371	}
1372	break;
1373	default:
1374	break;
1375	}
1376
1377	/* Generate the additional package prefix for C++ classes. */
1378	if (separate_class_package (decl))
1379	{
1380	pp_string (buffer, "Class_");
1381	pp_string (buffer, s);
1382	pp_dot (buffer);
1383	}
1384	}
1385	}
1386
1387	if (space_found)
1388	if (!strcmp (s1: s, s2: "short_int"))
1389	pp_string (buffer, "short");
1390	else if (!strcmp (s1: s, s2: "short_unsigned_int"))
1391	pp_string (buffer, "unsigned_short");
1392	else if (!strcmp (s1: s, s2: "unsigned_int"))
1393	pp_string (buffer, "unsigned");
1394	else if (!strcmp (s1: s, s2: "long_int"))
1395	pp_string (buffer, "long");
1396	else if (!strcmp (s1: s, s2: "long_unsigned_int"))
1397	pp_string (buffer, "unsigned_long");
1398	else if (!strcmp (s1: s, s2: "long_long_int"))
1399	pp_string (buffer, "Long_Long_Integer");
1400	else if (!strcmp (s1: s, s2: "long_long_unsigned_int"))
1401	{
1402	if (package_prefix)
1403	{
1404	append_withs (s: "Interfaces.C.Extensions", limited_access: false);
1405	pp_string (buffer, "Extensions.unsigned_long_long");
1406	}
1407	else
1408	pp_string (buffer, "unsigned_long_long");
1409	}
1410	else
1411	pp_string(buffer, s);
1412	else
1413	if (!strcmp (s1: s, s2: "u_Bool") || !strcmp (s1: s, s2: "bool"))
1414	{
1415	if (package_prefix)
1416	{
1417	append_withs (s: "Interfaces.C.Extensions", limited_access: false);
1418	pp_string (buffer, "Extensions.bool");
1419	}
1420	else
1421	pp_string (buffer, "bool");
1422	}
1423	else
1424	pp_string(buffer, s);
1425
1426	free (ptr: s);
1427	}
1428
1429	/* Dump in BUFFER the assembly name of T. */
1430
1431	static void
1432	pp_asm_name (pretty_printer *buffer, tree t)
1433	{
1434	tree name = DECL_ASSEMBLER_NAME (t);
1435	char *ada_name = XALLOCAVEC (char, IDENTIFIER_LENGTH (name) + 1), *s;
1436	const char *ident = IDENTIFIER_POINTER (name);
1437
1438	for (s = ada_name; *ident; ident++)
1439	{
1440	if (*ident == ' ')
1441	break;
1442	else if (*ident != '*')
1443	*s++ = *ident;
1444	}
1445
1446	*s = '\0';
1447	pp_string (buffer, ada_name);
1448	}
1449
1450	/* Dump in BUFFER the name of a DECL node if set, in Ada syntax.
1451	LIMITED_ACCESS indicates whether NODE can be accessed via a
1452	limited 'with' clause rather than a regular 'with' clause. */
1453
1454	static void
1455	dump_ada_decl_name (pretty_printer *buffer, tree decl, bool limited_access)
1456	{
1457	if (DECL_NAME (decl))
1458	pp_ada_tree_identifier (buffer, DECL_NAME (decl), type: decl, limited_access);
1459	else
1460	{
1461	tree type_name = TYPE_NAME (TREE_TYPE (decl));
1462
1463	if (!type_name)
1464	{
1465	pp_string (buffer, "anon");
1466	if (TREE_CODE (decl) == FIELD_DECL)
1467	pp_decimal_int (buffer, DECL_UID (decl));
1468	else
1469	pp_decimal_int (buffer, TYPE_UID (TREE_TYPE (decl)));
1470	}
1471	else if (TREE_CODE (type_name) == IDENTIFIER_NODE)
1472	pp_ada_tree_identifier (buffer, node: type_name, type: decl, limited_access);
1473	}
1474	}
1475
1476	/* Dump in BUFFER a name for the type T, which is a TYPE without TYPE_NAME. */
1477
1478	static void
1479	dump_anonymous_type_name (pretty_printer *buffer, tree t)
1480	{
1481	pp_string (buffer, "anon");
1482
1483	switch (TREE_CODE (t))
1484	{
1485	case ARRAY_TYPE:
1486	pp_string (buffer, "_array");
1487	break;
1488	case ENUMERAL_TYPE:
1489	pp_string (buffer, "_enum");
1490	break;
1491	case RECORD_TYPE:
1492	pp_string (buffer, "_struct");
1493	break;
1494	case UNION_TYPE:
1495	pp_string (buffer, "_union");
1496	break;
1497	default:
1498	pp_string (buffer, "_unknown");
1499	break;
1500	}
1501
1502	pp_decimal_int (buffer, TYPE_UID (t));
1503	}
1504
1505	/* Dump in BUFFER aspect Import on a given node T. SPC is the current
1506	indentation level. */
1507
1508	static void
1509	dump_ada_import (pretty_printer *buffer, tree t, int spc)
1510	{
1511	const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (t));
1512	const bool is_stdcall
1513	= TREE_CODE (t) == FUNCTION_DECL
1514	&& lookup_attribute (attr_name: "stdcall", TYPE_ATTRIBUTES (TREE_TYPE (t)));
1515
1516	pp_string (buffer, "with Import => True, ");
1517
1518	newline_and_indent (buffer, spc: spc + 5);
1519
1520	if (is_stdcall)
1521	pp_string (buffer, "Convention => Stdcall, ");
1522	else if (name[0] == '_' && name[1] == 'Z')
1523	pp_string (buffer, "Convention => CPP, ");
1524	else
1525	pp_string (buffer, "Convention => C, ");
1526
1527	newline_and_indent (buffer, spc: spc + 5);
1528
1529	tree sec = lookup_attribute (attr_name: "section", DECL_ATTRIBUTES (t));
1530	if (sec)
1531	{
1532	pp_string (buffer, "Linker_Section => \"");
1533	pp_string (buffer, TREE_STRING_POINTER (TREE_VALUE (TREE_VALUE (sec))));
1534	pp_string (buffer, "\", ");
1535	newline_and_indent (buffer, spc: spc + 5);
1536	}
1537
1538	pp_string (buffer, "External_Name => \"");
1539
1540	if (is_stdcall)
1541	pp_string (buffer, IDENTIFIER_POINTER (DECL_NAME (t)));
1542	else
1543	pp_asm_name (buffer, t);
1544
1545	pp_string (buffer, "\";");
1546	}
1547
1548	/* Check whether T and its type have different names, and append "the_"
1549	otherwise in BUFFER. */
1550
1551	static void
1552	check_type_name_conflict (pretty_printer *buffer, tree t)
1553	{
1554	tree tmp = TREE_TYPE (t);
1555
1556	while (TREE_CODE (tmp) == POINTER_TYPE && !TYPE_NAME (tmp))
1557	tmp = TREE_TYPE (tmp);
1558
1559	if (TREE_CODE (tmp) != FUNCTION_TYPE)
1560	{
1561	const char *s;
1562
1563	if (TREE_CODE (tmp) == IDENTIFIER_NODE)
1564	s = IDENTIFIER_POINTER (tmp);
1565	else if (!TYPE_NAME (tmp))
1566	s = "";
1567	else if (TREE_CODE (TYPE_NAME (tmp)) == IDENTIFIER_NODE)
1568	s = IDENTIFIER_POINTER (TYPE_NAME (tmp));
1569	else
1570	s = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp)));
1571
1572	if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t)), s2: s))
1573	pp_string (buffer, "the_");
1574	}
1575	}
1576
1577	/* Dump in BUFFER a function declaration FUNC in Ada syntax.
1578	IS_METHOD indicates whether FUNC is a C++ method.
1579	IS_CONSTRUCTOR whether FUNC is a C++ constructor.
1580	IS_DESTRUCTOR whether FUNC is a C++ destructor.
1581	SPC is the current indentation level. */
1582
1583	static void
1584	dump_ada_function_declaration (pretty_printer *buffer, tree func,
1585	bool is_method, bool is_constructor,
1586	bool is_destructor, int spc)
1587	{
1588	tree type = TREE_TYPE (func);
1589	tree arg = TYPE_ARG_TYPES (type);
1590	tree t;
1591	char buf[18];
1592	int num, num_args = 0, have_args = true, have_ellipsis = false;
1593
1594	/* Compute number of arguments. */
1595	if (arg)
1596	{
1597	while (TREE_CHAIN (arg) && arg != error_mark_node)
1598	{
1599	num_args++;
1600	arg = TREE_CHAIN (arg);
1601	}
1602
1603	if (TREE_CODE (TREE_VALUE (arg)) != VOID_TYPE)
1604	{
1605	num_args++;
1606	have_ellipsis = true;
1607	}
1608	}
1609
1610	if (is_constructor)
1611	num_args--;
1612
1613	if (is_destructor)
1614	num_args = 1;
1615
1616	if (num_args > 2)
1617	newline_and_indent (buffer, spc: spc + 1);
1618
1619	if (num_args > 0)
1620	{
1621	pp_space (buffer);
1622	pp_left_paren (buffer);
1623	}
1624
1625	/* For a function, see if we have the corresponding arguments. */
1626	if (TREE_CODE (func) == FUNCTION_DECL)
1627	{
1628	arg = DECL_ARGUMENTS (func);
1629	for (t = arg, num = 0; t; t = DECL_CHAIN (t))
1630	num++;
1631	if (num < num_args)
1632	arg = NULL_TREE;
1633	}
1634	else
1635	arg = NULL_TREE;
1636
1637	/* Otherwise, only print the types. */
1638	if (!arg)
1639	{
1640	have_args = false;
1641	arg = TYPE_ARG_TYPES (type);
1642	}
1643
1644	if (is_constructor)
1645	arg = TREE_CHAIN (arg);
1646
1647	/* Print the argument names (if available) and types. */
1648	for (num = 1; num <= num_args; num++)
1649	{
1650	if (have_args)
1651	{
1652	if (DECL_NAME (arg))
1653	{
1654	check_type_name_conflict (buffer, t: arg);
1655	pp_ada_tree_identifier (buffer, DECL_NAME (arg), NULL_TREE,
1656	limited_access: false);
1657	pp_string (buffer, " : ");
1658	}
1659	else
1660	{
1661	sprintf (s: buf, format: "arg%d : ", num);
1662	pp_string (buffer, buf);
1663	}
1664
1665	dump_ada_node (buffer, TREE_TYPE (arg), type, spc, false, true);
1666	}
1667	else
1668	{
1669	sprintf (s: buf, format: "arg%d : ", num);
1670	pp_string (buffer, buf);
1671	dump_ada_node (buffer, TREE_VALUE (arg), type, spc, false, true);
1672	}
1673
1674	/* If the type is a pointer to a tagged type, we need to differentiate
1675	virtual methods from the rest (non-virtual methods, static member
1676	or regular functions) and import only them as primitive operations,
1677	because they make up the virtual table which is mirrored on the Ada
1678	side by the dispatch table. So we add 'Class to the type of every
1679	parameter that is not the first one of a method which either has a
1680	slot in the virtual table or is a constructor. */
1681	if (TREE_TYPE (arg)
1682	&& POINTER_TYPE_P (TREE_TYPE (arg))
1683	&& is_tagged_type (TREE_TYPE (TREE_TYPE (arg)))
1684	&& !(num == 1 && is_method && (DECL_VINDEX (func) || is_constructor)))
1685	pp_string (buffer, "'Class");
1686
1687	arg = TREE_CHAIN (arg);
1688
1689	if (num < num_args)
1690	{
1691	pp_semicolon (buffer);
1692
1693	if (num_args > 2)
1694	newline_and_indent (buffer, spc: spc + INDENT_INCR);
1695	else
1696	pp_space (buffer);
1697	}
1698	}
1699
1700	if (have_ellipsis)
1701	{
1702	pp_string (buffer, " -- , ...");
1703	newline_and_indent (buffer, spc: spc + INDENT_INCR);
1704	}
1705
1706	if (num_args > 0)
1707	pp_right_paren (buffer);
1708
1709	if (is_constructor || !VOID_TYPE_P (TREE_TYPE (type)))
1710	{
1711	pp_string (buffer, " return ");
1712	tree rtype = is_constructor ? DECL_CONTEXT (func) : TREE_TYPE (type);
1713	dump_ada_node (buffer, rtype, rtype, spc, false, true);
1714	}
1715	}
1716
1717	/* Dump in BUFFER all the domains associated with an array NODE,
1718	in Ada syntax. SPC is the current indentation level. */
1719
1720	static void
1721	dump_ada_array_domains (pretty_printer *buffer, tree node, int spc)
1722	{
1723	bool first = true;
1724
1725	pp_left_paren (buffer);
1726
1727	for (; TREE_CODE (node) == ARRAY_TYPE; node = TREE_TYPE (node))
1728	{
1729	tree domain = TYPE_DOMAIN (node);
1730
1731	if (domain)
1732	{
1733	tree min = TYPE_MIN_VALUE (domain);
1734	tree max = TYPE_MAX_VALUE (domain);
1735
1736	if (!first)
1737	pp_string (buffer, ", ");
1738	first = false;
1739
1740	if (min)
1741	dump_ada_node (buffer, min, NULL_TREE, spc, false, true);
1742	pp_string (buffer, " .. ");
1743
1744	/* If the upper bound is zero, gcc may generate a NULL_TREE
1745	for TYPE_MAX_VALUE rather than an integer_cst. */
1746	if (max)
1747	dump_ada_node (buffer, max, NULL_TREE, spc, false, true);
1748	else
1749	pp_string (buffer, "0");
1750	}
1751	else
1752	{
1753	pp_string (buffer, "size_t");
1754	first = false;
1755	}
1756	}
1757	pp_right_paren (buffer);
1758	}
1759
1760	/* Dump in BUFFER file:line information related to NODE. */
1761
1762	static void
1763	dump_sloc (pretty_printer *buffer, tree node)
1764	{
1765	expanded_location xloc;
1766
1767	if (DECL_P (node))
1768	xloc = expand_location (DECL_SOURCE_LOCATION (node));
1769	else if (EXPR_HAS_LOCATION (node))
1770	xloc = expand_location (EXPR_LOCATION (node));
1771	else
1772	xloc.file = NULL;
1773
1774	if (xloc.file)
1775	{
1776	pp_string (buffer, xloc.file);
1777	pp_colon (buffer);
1778	pp_decimal_int (buffer, xloc.line);
1779	}
1780	}
1781
1782	/* Return true if type T designates a 1-dimension array of "char". */
1783
1784	static bool
1785	is_char_array (tree t)
1786	{
1787	int num_dim = 0;
1788
1789	while (TREE_CODE (t) == ARRAY_TYPE)
1790	{
1791	num_dim++;
1792	t = TREE_TYPE (t);
1793	}
1794
1795	return num_dim == 1
1796	&& TREE_CODE (t) == INTEGER_TYPE
1797	&& id_equal (DECL_NAME (TYPE_NAME (t)), str: "char");
1798	}
1799
1800	/* Dump in BUFFER an array type NODE in Ada syntax. SPC is the indentation
1801	level. */
1802
1803	static void
1804	dump_ada_array_type (pretty_printer *buffer, tree node, int spc)
1805	{
1806	const bool char_array = is_char_array (t: node);
1807
1808	/* Special case char arrays. */
1809	if (char_array)
1810	pp_string (buffer, "Interfaces.C.char_array ");
1811	else
1812	pp_string (buffer, "array ");
1813
1814	/* Print the dimensions. */
1815	dump_ada_array_domains (buffer, node, spc);
1816
1817	/* Print the component type. */
1818	if (!char_array)
1819	{
1820	tree tmp = node;
1821	while (TREE_CODE (tmp) == ARRAY_TYPE)
1822	tmp = TREE_TYPE (tmp);
1823
1824	pp_string (buffer, " of ");
1825
1826	if (TREE_CODE (tmp) != POINTER_TYPE)
1827	pp_string (buffer, "aliased ");
1828
1829	if (TYPE_NAME (tmp)
1830	|| (!RECORD_OR_UNION_TYPE_P (tmp)
1831	&& TREE_CODE (tmp) != ENUMERAL_TYPE))
1832	dump_ada_node (buffer, tmp, node, spc, false, true);
1833	else
1834	dump_anonymous_type_name (buffer, t: tmp);
1835	}
1836	}
1837
1838	/* Dump in BUFFER type names associated with a template, each prepended with
1839	'_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS. SPC is
1840	the indentation level. */
1841
1842	static void
1843	dump_template_types (pretty_printer *buffer, tree types, int spc)
1844	{
1845	for (int i = 0; i < TREE_VEC_LENGTH (types); i++)
1846	{
1847	tree elem = TREE_VEC_ELT (types, i);
1848	pp_underscore (buffer);
1849
1850	if (!dump_ada_node (buffer, elem, NULL_TREE, spc, false, true))
1851	{
1852	pp_string (buffer, "unknown");
1853	pp_scalar (buffer, "%lu", (unsigned long) TREE_HASH (elem));
1854	}
1855	}
1856	}
1857
1858	/* Dump in BUFFER the contents of all class instantiations associated with
1859	a given template T. SPC is the indentation level. */
1860
1861	static int
1862	dump_ada_template (pretty_printer *buffer, tree t, int spc)
1863	{
1864	/* DECL_SIZE_UNIT is DECL_TEMPLATE_INSTANTIATIONS in this context. */
1865	tree inst = DECL_SIZE_UNIT (t);
1866	/* This emulates DECL_TEMPLATE_RESULT in this context. */
1867	struct tree_template_decl {
1868	struct tree_decl_common common;
1869	tree arguments;
1870	tree result;
1871	};
1872	tree result = ((struct tree_template_decl *) t)->result;
1873	int num_inst = 0;
1874
1875	/* Don't look at template declarations declaring something coming from
1876	another file. This can occur for template friend declarations. */
1877	if (LOCATION_FILE (decl_sloc (result, false))
1878	!= LOCATION_FILE (decl_sloc (t, false)))
1879	return 0;
1880
1881	for (; inst && inst != error_mark_node; inst = TREE_CHAIN (inst))
1882	{
1883	tree types = TREE_PURPOSE (inst);
1884	tree instance = TREE_VALUE (inst);
1885
1886	if (TREE_VEC_LENGTH (types) == 0)
1887	break;
1888
1889	if (!RECORD_OR_UNION_TYPE_P (instance))
1890	break;
1891
1892	/* We are interested in concrete template instantiations only: skip
1893	partially specialized nodes. */
1894	if (RECORD_OR_UNION_TYPE_P (instance)
1895	&& cpp_check
1896	&& cpp_check (instance, HAS_DEPENDENT_TEMPLATE_ARGS))
1897	continue;
1898
1899	num_inst++;
1900	INDENT (spc);
1901	pp_string (buffer, "package ");
1902	package_prefix = false;
1903	dump_ada_node (buffer, instance, t, spc, false, true);
1904	dump_template_types (buffer, types, spc);
1905	pp_string (buffer, " is");
1906	spc += INDENT_INCR;
1907	newline_and_indent (buffer, spc);
1908
1909	TREE_VISITED (get_underlying_decl (instance)) = 1;
1910	pp_string (buffer, "type ");
1911	dump_ada_node (buffer, instance, t, spc, false, true);
1912	package_prefix = true;
1913
1914	if (is_tagged_type (type: instance))
1915	pp_string (buffer, " is tagged limited ");
1916	else
1917	pp_string (buffer, " is limited ");
1918
1919	dump_ada_node (buffer, instance, t, spc, false, false);
1920	pp_newline (buffer);
1921	spc -= INDENT_INCR;
1922	newline_and_indent (buffer, spc);
1923
1924	pp_string (buffer, "end;");
1925	newline_and_indent (buffer, spc);
1926	pp_string (buffer, "use ");
1927	package_prefix = false;
1928	dump_ada_node (buffer, instance, t, spc, false, true);
1929	dump_template_types (buffer, types, spc);
1930	package_prefix = true;
1931	pp_semicolon (buffer);
1932	pp_newline (buffer);
1933	pp_newline (buffer);
1934	}
1935
1936	return num_inst > 0;
1937	}
1938
1939	/* Return true if NODE is a simple enumeral type that can be mapped to an
1940	Ada enumeration type directly. */
1941
1942	static bool
1943	is_simple_enum (tree node)
1944	{
1945	HOST_WIDE_INT count = 0;
1946
1947	for (tree value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
1948	{
1949	tree int_val = TREE_VALUE (value);
1950
1951	if (TREE_CODE (int_val) != INTEGER_CST)
1952	int_val = DECL_INITIAL (int_val);
1953
1954	if (!tree_fits_shwi_p (int_val) || tree_to_shwi (int_val) != count)
1955	return false;
1956
1957	count++;
1958	}
1959
1960	return true;
1961	}
1962
1963	/* Dump in BUFFER the declaration of enumeral NODE of type TYPE in Ada syntax.
1964	SPC is the indentation level. */
1965
1966	static void
1967	dump_ada_enum_type (pretty_printer *buffer, tree node, tree type, int spc)
1968	{
1969	if (is_simple_enum (node))
1970	{
1971	bool first = true;
1972	spc += INDENT_INCR;
1973	newline_and_indent (buffer, spc: spc - 1);
1974	pp_left_paren (buffer);
1975	for (tree value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
1976	{
1977	if (first)
1978	first = false;
1979	else
1980	{
1981	pp_comma (buffer);
1982	newline_and_indent (buffer, spc);
1983	}
1984
1985	pp_ada_tree_identifier (buffer, TREE_PURPOSE (value), type: node, limited_access: false);
1986	}
1987	pp_string (buffer, ")");
1988	spc -= INDENT_INCR;
1989	newline_and_indent (buffer, spc);
1990	pp_string (buffer, "with Convention => C");
1991	}
1992	else
1993	{
1994	if (TYPE_UNSIGNED (node))
1995	pp_string (buffer, "unsigned");
1996	else
1997	pp_string (buffer, "int");
1998
1999	for (tree value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
2000	{
2001	tree int_val = TREE_VALUE (value);
2002
2003	if (TREE_CODE (int_val) != INTEGER_CST)
2004	int_val = DECL_INITIAL (int_val);
2005
2006	pp_semicolon (buffer);
2007	newline_and_indent (buffer, spc);
2008
2009	if (TYPE_NAME (node))
2010	dump_ada_node (buffer, node, NULL_TREE, spc, false, true);
2011	else if (type)
2012	dump_ada_node (buffer, type, NULL_TREE, spc, false, true);
2013	else
2014	dump_anonymous_type_name (buffer, t: node);
2015	pp_underscore (buffer);
2016	pp_ada_tree_identifier (buffer, TREE_PURPOSE (value), type: node, limited_access: false);
2017
2018	pp_string (buffer, " : constant ");
2019
2020	if (TYPE_NAME (node))
2021	dump_ada_node (buffer, node, NULL_TREE, spc, false, true);
2022	else if (type)
2023	dump_ada_node (buffer, type, NULL_TREE, spc, false, true);
2024	else
2025	dump_anonymous_type_name (buffer, t: node);
2026
2027	pp_string (buffer, " := ");
2028	dump_ada_node (buffer, int_val, node, spc, false, true);
2029	}
2030	}
2031	}
2032
2033	/* Return true if NODE is the _Float32/_Float32x type. */
2034
2035	static bool
2036	is_float32 (tree node)
2037	{
2038	if (!TYPE_NAME (node) || TREE_CODE (TYPE_NAME (node)) != TYPE_DECL)
2039	return false;
2040
2041	tree name = DECL_NAME (TYPE_NAME (node));
2042
2043	if (IDENTIFIER_POINTER (name) [0] != '_')
2044	return false;
2045
2046	return id_equal (id: name, str: "_Float32") || id_equal (id: name, str: "_Float32x");
2047	}
2048
2049	/* Return true if NODE is the _Float64/_Float64x type. */
2050
2051	static bool
2052	is_float64 (tree node)
2053	{
2054	if (!TYPE_NAME (node) || TREE_CODE (TYPE_NAME (node)) != TYPE_DECL)
2055	return false;
2056
2057	tree name = DECL_NAME (TYPE_NAME (node));
2058
2059	if (IDENTIFIER_POINTER (name) [0] != '_')
2060	return false;
2061
2062	return id_equal (id: name, str: "_Float64") || id_equal (id: name, str: "_Float64x");
2063	}
2064
2065	/* Return true if NODE is the __float128/_Float128/_Float128x type. */
2066
2067	static bool
2068	is_float128 (tree node)
2069	{
2070	if (!TYPE_NAME (node) || TREE_CODE (TYPE_NAME (node)) != TYPE_DECL)
2071	return false;
2072
2073	tree name = DECL_NAME (TYPE_NAME (node));
2074
2075	if (IDENTIFIER_POINTER (name) [0] != '_')
2076	return false;
2077
2078	return id_equal (id: name, str: "__float128")
2079	|| id_equal (id: name, str: "_Float128")
2080	|| id_equal (id: name, str: "_Float128x");
2081	}
2082
2083	static bool bitfield_used = false;
2084	static bool packed_layout = false;
2085
2086	/* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
2087	TYPE. SPC is the indentation level. LIMITED_ACCESS indicates whether NODE
2088	can be referenced via a "limited with" clause. NAME_ONLY indicates whether
2089	we should only dump the name of NODE, instead of its full declaration. */
2090
2091	static int
2092	dump_ada_node (pretty_printer *buffer, tree node, tree type, int spc,
2093	bool limited_access, bool name_only)
2094	{
2095	if (node == NULL_TREE)
2096	return 0;
2097
2098	switch (TREE_CODE (node))
2099	{
2100	case ERROR_MARK:
2101	pp_string (buffer, "<<< error >>>");
2102	return 0;
2103
2104	case IDENTIFIER_NODE:
2105	pp_ada_tree_identifier (buffer, node, type, limited_access);
2106	break;
2107
2108	case TREE_LIST:
2109	pp_string (buffer, "--- unexpected node: TREE_LIST");
2110	return 0;
2111
2112	case TREE_BINFO:
2113	dump_ada_node (buffer, BINFO_TYPE (node), type, spc, limited_access,
2114	name_only);
2115	return 0;
2116
2117	case TREE_VEC:
2118	pp_string (buffer, "--- unexpected node: TREE_VEC");
2119	return 0;
2120
2121	case NULLPTR_TYPE:
2122	case VOID_TYPE:
2123	if (package_prefix)
2124	{
2125	append_withs (s: "System", limited_access: false);
2126	pp_string (buffer, "System.Address");
2127	}
2128	else
2129	pp_string (buffer, "address");
2130	break;
2131
2132	case VECTOR_TYPE:
2133	pp_string (buffer, "<vector>");
2134	break;
2135
2136	case COMPLEX_TYPE:
2137	if (is_float128 (TREE_TYPE (node)))
2138	{
2139	append_withs (s: "Interfaces.C.Extensions", limited_access: false);
2140	pp_string (buffer, "Extensions.CFloat_128");
2141	}
2142	else if (TREE_TYPE (node) == float_type_node)
2143	{
2144	append_withs (s: "Ada.Numerics.Complex_Types", limited_access: false);
2145	pp_string (buffer, "Ada.Numerics.Complex_Types.Complex");
2146	}
2147	else if (TREE_TYPE (node) == double_type_node)
2148	{
2149	append_withs (s: "Ada.Numerics.Long_Complex_Types", limited_access: false);
2150	pp_string (buffer, "Ada.Numerics.Long_Complex_Types.Complex");
2151	}
2152	else if (TREE_TYPE (node) == long_double_type_node)
2153	{
2154	append_withs (s: "Ada.Numerics.Long_Long_Complex_Types", limited_access: false);
2155	pp_string (buffer, "Ada.Numerics.Long_Long_Complex_Types.Complex");
2156	}
2157	else
2158	pp_string (buffer, "<complex>");
2159	break;
2160
2161	case ENUMERAL_TYPE:
2162	if (name_only)
2163	dump_ada_node (buffer, TYPE_NAME (node), type: node, spc, limited_access: false, name_only: true);
2164	else
2165	dump_ada_enum_type (buffer, node, type, spc);
2166	break;
2167
2168	case REAL_TYPE:
2169	if (is_float32 (node))
2170	{
2171	pp_string (buffer, "Float");
2172	break;
2173	}
2174	else if (is_float64 (node))
2175	{
2176	pp_string (buffer, "Long_Float");
2177	break;
2178	}
2179	else if (is_float128 (node))
2180	{
2181	append_withs (s: "Interfaces.C.Extensions", limited_access: false);
2182	pp_string (buffer, "Extensions.Float_128");
2183	break;
2184	}
2185
2186	/* fallthrough */
2187
2188	case INTEGER_TYPE:
2189	case FIXED_POINT_TYPE:
2190	case BOOLEAN_TYPE:
2191	if (TYPE_NAME (node)
2192	&& !(TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
2193	&& !strcmp (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (node))),
2194	s2: "__int128")))
2195	{
2196	if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE)
2197	pp_ada_tree_identifier (buffer, TYPE_NAME (node), type: node,
2198	limited_access);
2199	else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
2200	&& DECL_NAME (TYPE_NAME (node)))
2201	dump_ada_decl_name (buffer, TYPE_NAME (node), limited_access);
2202	else
2203	pp_string (buffer, "<unnamed type>");
2204	}
2205	else if (TREE_CODE (node) == INTEGER_TYPE)
2206	{
2207	append_withs (s: "Interfaces.C.Extensions", limited_access: false);
2208	bitfield_used = true;
2209
2210	if (TYPE_PRECISION (node) == 1)
2211	pp_string (buffer, "Extensions.Unsigned_1");
2212	else
2213	{
2214	pp_string (buffer, TYPE_UNSIGNED (node)
2215	? "Extensions.Unsigned_"
2216	: "Extensions.Signed_");
2217	pp_decimal_int (buffer, TYPE_PRECISION (node));
2218	}
2219	}
2220	else
2221	pp_string (buffer, "<unnamed type>");
2222	break;
2223
2224	case POINTER_TYPE:
2225	case REFERENCE_TYPE:
2226	if (name_only && TYPE_NAME (node))
2227	dump_ada_node (buffer, TYPE_NAME (node), type: node, spc, limited_access,
2228	name_only: true);
2229
2230	else if (TREE_CODE (TREE_TYPE (node)) == FUNCTION_TYPE)
2231	{
2232	if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (node))))
2233	pp_string (buffer, "access procedure");
2234	else
2235	pp_string (buffer, "access function");
2236
2237	dump_ada_function_declaration (buffer, func: node, is_method: false, is_constructor: false, is_destructor: false,
2238	spc: spc + INDENT_INCR);
2239
2240	/* If we are dumping the full type, it means we are part of a
2241	type definition and need also a Convention C aspect. */
2242	if (!name_only)
2243	{
2244	newline_and_indent (buffer, spc);
2245	pp_string (buffer, "with Convention => C");
2246	}
2247	}
2248	else
2249	{
2250	tree ref_type = TREE_TYPE (node);
2251	const unsigned int quals = TYPE_QUALS (ref_type);
2252	bool is_access;
2253
2254	if (VOID_TYPE_P (ref_type))
2255	{
2256	if (!name_only)
2257	pp_string (buffer, "new ");
2258	if (package_prefix)
2259	{
2260	append_withs (s: "System", limited_access: false);
2261	pp_string (buffer, "System.Address");
2262	}
2263	else
2264	pp_string (buffer, "address");
2265	}
2266	else
2267	{
2268	if (TREE_CODE (node) == POINTER_TYPE
2269	&& TREE_CODE (ref_type) == INTEGER_TYPE
2270	&& id_equal (DECL_NAME (TYPE_NAME (ref_type)), str: "char"))
2271	{
2272	if (!name_only)
2273	pp_string (buffer, "new ");
2274
2275	if (package_prefix)
2276	{
2277	pp_string (buffer, "Interfaces.C.Strings.chars_ptr");
2278	append_withs (s: "Interfaces.C.Strings", limited_access: false);
2279	}
2280	else
2281	pp_string (buffer, "chars_ptr");
2282	}
2283	else
2284	{
2285	tree stub = TYPE_STUB_DECL (ref_type);
2286	tree type_name = TYPE_NAME (ref_type);
2287
2288	/* For now, handle access-to-access as System.Address. */
2289	if (TREE_CODE (ref_type) == POINTER_TYPE)
2290	{
2291	if (package_prefix)
2292	{
2293	append_withs (s: "System", limited_access: false);
2294	if (!name_only)
2295	pp_string (buffer, "new ");
2296	pp_string (buffer, "System.Address");
2297	}
2298	else
2299	pp_string (buffer, "address");
2300	return spc;
2301	}
2302
2303	if (!package_prefix)
2304	{
2305	is_access = false;
2306	pp_string (buffer, "access");
2307	}
2308	else if (AGGREGATE_TYPE_P (ref_type))
2309	{
2310	if (!type || TREE_CODE (type) != FUNCTION_DECL)
2311	{
2312	is_access = true;
2313	pp_string (buffer, "access ");
2314
2315	if (quals & TYPE_QUAL_CONST)
2316	pp_string (buffer, "constant ");
2317	else if (!name_only)
2318	pp_string (buffer, "all ");
2319	}
2320	else if (quals & TYPE_QUAL_CONST)
2321	{
2322	is_access = false;
2323	pp_string (buffer, "in ");
2324	}
2325	else
2326	{
2327	is_access = true;
2328	pp_string (buffer, "access ");
2329	}
2330	}
2331	else
2332	{
2333	/* We want to use regular with clauses for scalar types,
2334	as they are not involved in circular declarations. */
2335	is_access = false;
2336	pp_string (buffer, "access ");
2337
2338	if (!name_only)
2339	pp_string (buffer, "all ");
2340	}
2341
2342	/* If this is the anonymous original type of a typedef'ed
2343	type, then use the name of the latter. */
2344	if (!type_name
2345	&& stub
2346	&& DECL_CHAIN (stub)
2347	&& TREE_CODE (DECL_CHAIN (stub)) == TYPE_DECL
2348	&& DECL_ORIGINAL_TYPE (DECL_CHAIN (stub)) == ref_type)
2349	ref_type = TREE_TYPE (DECL_CHAIN (stub));
2350
2351	/* Generate "access <type>" instead of "access <subtype>"
2352	if the subtype comes from another file, because subtype
2353	declarations do not contribute to the limited view of a
2354	package and thus subtypes cannot be referenced through
2355	a limited_with clause. */
2356	else if (is_access)
2357	while (type_name
2358	&& TREE_CODE (type_name) == TYPE_DECL
2359	&& DECL_ORIGINAL_TYPE (type_name)
2360	&& TYPE_NAME (DECL_ORIGINAL_TYPE (type_name)))
2361	{
2362	const expanded_location xloc
2363	= expand_location (decl_sloc (decl: type_name, last: false));
2364	if (xloc.line
2365	&& xloc.file
2366	&& xloc.file != current_source_file)
2367	{
2368	ref_type = DECL_ORIGINAL_TYPE (type_name);
2369	type_name = TYPE_NAME (ref_type);
2370	}
2371	else
2372	break;
2373	}
2374
2375	dump_ada_node (buffer, node: ref_type, type: ref_type, spc, limited_access: is_access,
2376	name_only: true);
2377	}
2378	}
2379	}
2380	break;
2381
2382	case ARRAY_TYPE:
2383	if (name_only)
2384	dump_ada_node (buffer, TYPE_NAME (node), type: node, spc, limited_access,
2385	name_only: true);
2386	else
2387	dump_ada_array_type (buffer, node, spc);
2388	break;
2389
2390	case RECORD_TYPE:
2391	case UNION_TYPE:
2392	if (name_only)
2393	dump_ada_node (buffer, TYPE_NAME (node), type: node, spc, limited_access,
2394	name_only: true);
2395	else
2396	dump_ada_structure (buffer, node, type, false, spc);
2397	break;
2398
2399	case INTEGER_CST:
2400	/* We treat the upper half of the sizetype range as negative. This
2401	is consistent with the internal treatment and makes it possible
2402	to generate the (0 .. -1) range for flexible array members. */
2403	if (TREE_TYPE (node) == sizetype)
2404	node = fold_convert (ssizetype, node);
2405	if (tree_fits_shwi_p (node))
2406	pp_wide_integer (pp: buffer, i: tree_to_shwi (node));
2407	else if (tree_fits_uhwi_p (node))
2408	pp_unsigned_wide_integer (buffer, tree_to_uhwi (node));
2409	else
2410	{
2411	wide_int val = wi::to_wide (t: node);
2412	int i;
2413	if (wi::neg_p (x: val))
2414	{
2415	pp_minus (buffer);
2416	val = -val;
2417	}
2418	sprintf (pp_buffer (buffer)->digit_buffer,
2419	format: "16#%" HOST_WIDE_INT_PRINT "x",
2420	val.elt (i: val.get_len () - 1));
2421	for (i = val.get_len () - 2; i >= 0; i--)
2422	sprintf (pp_buffer (buffer)->digit_buffer,
2423	HOST_WIDE_INT_PRINT_PADDED_HEX, val.elt (i));
2424	pp_string (buffer, pp_buffer (buffer)->digit_buffer);
2425	}
2426	break;
2427
2428	case REAL_CST:
2429	case FIXED_CST:
2430	case COMPLEX_CST:
2431	case STRING_CST:
2432	case VECTOR_CST:
2433	return 0;
2434
2435	case TYPE_DECL:
2436	if (DECL_IS_UNDECLARED_BUILTIN (node))
2437	{
2438	/* Don't print the declaration of built-in types. */
2439	if (name_only)
2440	{
2441	/* If we're in the middle of a declaration, defaults to
2442	System.Address. */
2443	if (package_prefix)
2444	{
2445	append_withs (s: "System", limited_access: false);
2446	pp_string (buffer, "System.Address");
2447	}
2448	else
2449	pp_string (buffer, "address");
2450	}
2451	}
2452	else if (name_only)
2453	dump_ada_decl_name (buffer, decl: node, limited_access);
2454	else
2455	{
2456	if (is_tagged_type (TREE_TYPE (node)))
2457	{
2458	int first = true;
2459
2460	/* Look for ancestors. */
2461	for (tree fld = TYPE_FIELDS (TREE_TYPE (node));
2462	fld;
2463	fld = TREE_CHAIN (fld))
2464	{
2465	if (!DECL_NAME (fld) && is_tagged_type (TREE_TYPE (fld)))
2466	{
2467	if (first)
2468	{
2469	pp_string (buffer, "limited new ");
2470	first = false;
2471	}
2472	else
2473	pp_string (buffer, " and ");
2474
2475	dump_ada_decl_name (buffer, TYPE_NAME (TREE_TYPE (fld)),
2476	limited_access: false);
2477	}
2478	}
2479
2480	pp_string (buffer, first ? "tagged limited " : " with ");
2481	}
2482	else if (has_nontrivial_methods (TREE_TYPE (node)))
2483	pp_string (buffer, "limited ");
2484
2485	dump_ada_node (buffer, TREE_TYPE (node), type, spc, limited_access: false, name_only: false);
2486	}
2487	break;
2488
2489	case FUNCTION_DECL:
2490	case CONST_DECL:
2491	case VAR_DECL:
2492	case PARM_DECL:
2493	case FIELD_DECL:
2494	case NAMESPACE_DECL:
2495	dump_ada_decl_name (buffer, decl: node, limited_access: false);
2496	break;
2497
2498	default:
2499	/* Ignore other nodes (e.g. expressions). */
2500	return 0;
2501	}
2502
2503	return 1;
2504	}
2505
2506	/* Dump in BUFFER NODE's methods. SPC is the indentation level. Return 1 if
2507	methods were printed, 0 otherwise. */
2508
2509	static int
2510	dump_ada_methods (pretty_printer *buffer, tree node, int spc)
2511	{
2512	if (!has_nontrivial_methods (type: node))
2513	return 0;
2514
2515	pp_semicolon (buffer);
2516
2517	int res = 1;
2518	for (tree fld = TYPE_FIELDS (node); fld; fld = DECL_CHAIN (fld))
2519	if (TREE_CODE (fld) == FUNCTION_DECL)
2520	{
2521	if (res)
2522	{
2523	pp_newline (buffer);
2524	pp_newline (buffer);
2525	}
2526
2527	res = dump_ada_declaration (buffer, fld, node, spc);
2528	}
2529
2530	return 1;
2531	}
2532
2533	/* Dump in BUFFER a forward declaration for TYPE present inside T.
2534	SPC is the indentation level. */
2535
2536	static void
2537	dump_forward_type (pretty_printer *buffer, tree type, tree t, int spc)
2538	{
2539	tree decl = get_underlying_decl (type);
2540
2541	/* Anonymous pointer and function types. */
2542	if (!decl)
2543	{
2544	if (TREE_CODE (type) == POINTER_TYPE)
2545	dump_forward_type (buffer, TREE_TYPE (type), t, spc);
2546	else if (TREE_CODE (type) == FUNCTION_TYPE)
2547	{
2548	function_args_iterator args_iter;
2549	tree arg;
2550	dump_forward_type (buffer, TREE_TYPE (type), t, spc);
2551	FOREACH_FUNCTION_ARGS (type, arg, args_iter)
2552	dump_forward_type (buffer, type: arg, t, spc);
2553	}
2554	return;
2555	}
2556
2557	if (DECL_IS_UNDECLARED_BUILTIN (decl) || TREE_VISITED (decl))
2558	return;
2559
2560	/* Forward declarations are only needed within a given file. */
2561	if (DECL_SOURCE_FILE (decl) != DECL_SOURCE_FILE (t))
2562	return;
2563
2564	if (TREE_CODE (type) == FUNCTION_TYPE)
2565	return;
2566
2567	/* Generate an incomplete type declaration. */
2568	pp_string (buffer, "type ");
2569	dump_ada_node (buffer, node: decl, NULL_TREE, spc, limited_access: false, name_only: true);
2570	pp_semicolon (buffer);
2571	newline_and_indent (buffer, spc);
2572
2573	/* Only one incomplete declaration is legal for a given type. */
2574	TREE_VISITED (decl) = 1;
2575	}
2576
2577	/* Bitmap of anonymous types already dumped. Anonymous array types are shared
2578	throughout the compilation so it needs to be global. */
2579
2580	static bitmap dumped_anonymous_types;
2581
2582	static void dump_nested_type (pretty_printer *, tree, tree, int);
2583
2584	/* Dump in BUFFER anonymous types nested inside T's definition. PARENT is the
2585	parent node of T. DUMPED_TYPES is the bitmap of already dumped types. SPC
2586	is the indentation level.
2587
2588	In C anonymous nested tagged types have no name whereas in C++ they have
2589	one. In C their TYPE_DECL is at top level whereas in C++ it is nested.
2590	In both languages untagged types (pointers and arrays) have no name.
2591	In C++ the nested TYPE_DECLs can come after their associated FIELD_DECL.
2592
2593	Therefore, in order to have a common processing for both languages, we
2594	disregard anonymous TYPE_DECLs at top level and here we make a first
2595	pass on the nested TYPE_DECLs and a second pass on the unnamed types. */
2596
2597	static void
2598	dump_nested_types (pretty_printer *buffer, tree t, int spc)
2599	{
2600	tree type, field;
2601
2602	/* Find possible anonymous pointers/arrays/structs/unions recursively. */
2603	type = TREE_TYPE (t);
2604	if (!type)
2605	return;
2606
2607	for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
2608	if (TREE_CODE (field) == TYPE_DECL
2609	&& DECL_NAME (field) != DECL_NAME (t)
2610	&& !DECL_ORIGINAL_TYPE (field)
2611	&& TYPE_NAME (TREE_TYPE (field)) != TYPE_NAME (type))
2612	dump_nested_type (buffer, field, t, spc);
2613
2614	for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
2615	if (TREE_CODE (field) == FIELD_DECL && !TYPE_NAME (TREE_TYPE (field)))
2616	dump_nested_type (buffer, field, t, spc);
2617	}
2618
2619	/* Dump in BUFFER the anonymous type of FIELD inside T. SPC is the indentation
2620	level. */
2621
2622	static void
2623	dump_nested_type (pretty_printer *buffer, tree field, tree t, int spc)
2624	{
2625	tree field_type = TREE_TYPE (field);
2626	tree decl, tmp;
2627
2628	switch (TREE_CODE (field_type))
2629	{
2630	case POINTER_TYPE:
2631	tmp = TREE_TYPE (field_type);
2632	dump_forward_type (buffer, type: tmp, t, spc);
2633	break;
2634
2635	case ARRAY_TYPE:
2636	/* Anonymous array types are shared. */
2637	if (!bitmap_set_bit (dumped_anonymous_types, TYPE_UID (field_type)))
2638	return;
2639
2640	/* Recurse on the element type if need be. */
2641	tmp = TREE_TYPE (field_type);
2642	while (TREE_CODE (tmp) == ARRAY_TYPE)
2643	tmp = TREE_TYPE (tmp);
2644	decl = get_underlying_decl (type: tmp);
2645	if (decl
2646	&& !DECL_NAME (decl)
2647	&& DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t)
2648	&& !TREE_VISITED (decl))
2649	{
2650	/* Generate full declaration. */
2651	dump_nested_type (buffer, field: decl, t, spc);
2652	TREE_VISITED (decl) = 1;
2653	}
2654	else if (!decl && TREE_CODE (tmp) == POINTER_TYPE)
2655	dump_forward_type (buffer, TREE_TYPE (tmp), t, spc);
2656
2657	/* Special case char arrays. */
2658	if (is_char_array (t: field_type))
2659	pp_string (buffer, "subtype ");
2660	else
2661	pp_string (buffer, "type ");
2662
2663	dump_anonymous_type_name (buffer, t: field_type);
2664	pp_string (buffer, " is ");
2665	dump_ada_array_type (buffer, node: field_type, spc);
2666	pp_semicolon (buffer);
2667	newline_and_indent (buffer, spc);
2668	break;
2669
2670	case ENUMERAL_TYPE:
2671	if (is_simple_enum (node: field_type))
2672	pp_string (buffer, "type ");
2673	else
2674	pp_string (buffer, "subtype ");
2675
2676	if (TYPE_NAME (field_type))
2677	dump_ada_node (buffer, node: field_type, NULL_TREE, spc, limited_access: false, name_only: true);
2678	else
2679	dump_anonymous_type_name (buffer, t: field_type);
2680	pp_string (buffer, " is ");
2681	dump_ada_enum_type (buffer, node: field_type, NULL_TREE, spc);
2682	pp_semicolon (buffer);
2683	newline_and_indent (buffer, spc);
2684	break;
2685
2686	case RECORD_TYPE:
2687	case UNION_TYPE:
2688	dump_nested_types (buffer, t: field, spc);
2689
2690	pp_string (buffer, "type ");
2691
2692	if (TYPE_NAME (field_type))
2693	dump_ada_node (buffer, node: field_type, NULL_TREE, spc, limited_access: false, name_only: true);
2694	else
2695	dump_anonymous_type_name (buffer, t: field_type);
2696
2697	if (TREE_CODE (field_type) == UNION_TYPE)
2698	pp_string (buffer, " (discr : unsigned := 0)");
2699
2700	pp_string (buffer, " is ");
2701	dump_ada_structure (buffer, field_type, t, true, spc);
2702	pp_semicolon (buffer);
2703	newline_and_indent (buffer, spc);
2704	break;
2705
2706	default:
2707	break;
2708	}
2709	}
2710
2711	/* Hash table of overloaded names that we cannot support. It is needed even
2712	in Ada 2012 because we merge different types, e.g. void * and const void *
2713	in System.Address, so we cannot have overloading for them in Ada. */
2714
2715	struct overloaded_name_hash {
2716	hashval_t hash;
2717	tree name;
2718	unsigned int n;
2719	};
2720
2721	struct overloaded_name_hasher : delete_ptr_hash<overloaded_name_hash>
2722	{
2723	static inline hashval_t hash (overloaded_name_hash *t)
2724	{ return t->hash; }
2725	static inline bool equal (overloaded_name_hash *a, overloaded_name_hash *b)
2726	{ return a->name == b->name; }
2727	};
2728
2729	typedef hash_table<overloaded_name_hasher> htable_t;
2730
2731	static htable_t *overloaded_names;
2732
2733	/* Add an overloaded NAME with N occurrences to TABLE. */
2734
2735	static void
2736	add_name (const char *name, unsigned int n, htable_t *table)
2737	{
2738	struct overloaded_name_hash in, *h, **slot;
2739	tree id = get_identifier (name);
2740	hashval_t hash = htab_hash_pointer (id);
2741	in.hash = hash;
2742	in.name = id;
2743	slot = table->find_slot_with_hash (comparable: &in, hash, insert: INSERT);
2744	h = new overloaded_name_hash;
2745	h->hash = hash;
2746	h->name = id;
2747	h->n = n;
2748	*slot = h;
2749	}
2750
2751	/* Initialize the table with the problematic overloaded names. */
2752
2753	static htable_t *
2754	init_overloaded_names (void)
2755	{
2756	static const char *names[] =
2757	/* The overloaded names from the /usr/include/string.h file. */
2758	{ "memchr", "rawmemchr", "memrchr", "strchr", "strrchr", "strchrnul",
2759	"strpbrk", "strstr", "strcasestr", "index", "rindex", "basename" };
2760
2761	htable_t *table = new htable_t (64);
2762
2763	for (unsigned int i = 0; i < ARRAY_SIZE (names); i++)
2764	add_name (name: names[i], n: 0, table);
2765
2766	/* Consider that sigaction() is overloaded by struct sigaction for QNX. */
2767	add_name (name: "sigaction", n: 1, table);
2768
2769	/* Consider that stat() is overloaded by struct stat for QNX. */
2770	add_name (name: "stat", n: 1, table);
2771
2772	return table;
2773	}
2774
2775	/* Return the overloading index of NAME or 0 if NAME is not overloaded. */
2776
2777	static unsigned int
2778	overloading_index (tree name)
2779	{
2780	struct overloaded_name_hash in, *h;
2781	hashval_t hash = htab_hash_pointer (name);
2782	in.hash = hash;
2783	in.name = name;
2784	h = overloaded_names->find_with_hash (comparable: &in, hash);
2785	return h ? ++h->n : 0;
2786	}
2787
2788	/* Dump in BUFFER constructor spec corresponding to T for TYPE. */
2789
2790	static void
2791	print_constructor (pretty_printer *buffer, tree t, tree type)
2792	{
2793	tree decl_name = DECL_NAME (TYPE_NAME (type));
2794
2795	pp_string (buffer, "New_");
2796	pp_ada_tree_identifier (buffer, node: decl_name, type: t, limited_access: false);
2797	}
2798
2799	/* Dump in BUFFER destructor spec corresponding to T. */
2800
2801	static void
2802	print_destructor (pretty_printer *buffer, tree t, tree type)
2803	{
2804	tree decl_name = DECL_NAME (TYPE_NAME (type));
2805
2806	pp_string (buffer, "Delete_");
2807	if (startswith (IDENTIFIER_POINTER (DECL_NAME (t)), prefix: "__dt_del"))
2808	pp_string (buffer, "And_Free_");
2809	pp_ada_tree_identifier (buffer, node: decl_name, type: t, limited_access: false);
2810	}
2811
2812	/* Dump in BUFFER assignment operator spec corresponding to T. */
2813
2814	static void
2815	print_assignment_operator (pretty_printer *buffer, tree t, tree type)
2816	{
2817	tree decl_name = DECL_NAME (TYPE_NAME (type));
2818
2819	pp_string (buffer, "Assign_");
2820	pp_ada_tree_identifier (buffer, node: decl_name, type: t, limited_access: false);
2821	}
2822
2823	/* Return the name of type T. */
2824
2825	static const char *
2826	type_name (tree t)
2827	{
2828	tree n = TYPE_NAME (t);
2829
2830	if (TREE_CODE (n) == IDENTIFIER_NODE)
2831	return IDENTIFIER_POINTER (n);
2832	else
2833	return IDENTIFIER_POINTER (DECL_NAME (n));
2834	}
2835
2836	/* Dump in BUFFER the declaration of object T of type TYPE in Ada syntax.
2837	SPC is the indentation level. Return 1 if a declaration was printed,
2838	0 otherwise. */
2839
2840	static int
2841	dump_ada_declaration (pretty_printer *buffer, tree t, tree type, int spc)
2842	{
2843	bool is_var = false;
2844	bool need_indent = false;
2845	bool is_class = false;
2846	tree name = TYPE_NAME (TREE_TYPE (t));
2847	tree decl_name = DECL_NAME (t);
2848	tree orig = NULL_TREE;
2849
2850	if (cpp_check && cpp_check (t, IS_TEMPLATE))
2851	return dump_ada_template (buffer, t, spc);
2852
2853	/* Skip enumeral values: will be handled as part of the type itself. */
2854	if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2855	return 0;
2856
2857	if (TREE_CODE (t) == TYPE_DECL)
2858	{
2859	orig = DECL_ORIGINAL_TYPE (t);
2860
2861	/* This is a typedef. */
2862	if (orig && TYPE_STUB_DECL (orig))
2863	{
2864	tree stub = TYPE_STUB_DECL (orig);
2865
2866	/* If this is a typedef of a named type, then output it as a subtype
2867	declaration. ??? Use a derived type declaration instead. */
2868	if (TYPE_NAME (orig))
2869	{
2870	/* If the types have the same name (ignoring casing), then ignore
2871	the second type, but forward declare the first if need be. */
2872	if (type_name (t: orig) == type_name (TREE_TYPE (t))
2873	|| !strcasecmp (s1: type_name (t: orig), s2: type_name (TREE_TYPE (t))))
2874	{
2875	if (RECORD_OR_UNION_TYPE_P (orig) && !TREE_VISITED (stub))
2876	{
2877	INDENT (spc);
2878	dump_forward_type (buffer, type: orig, t, spc: 0);
2879	}
2880
2881	TREE_VISITED (t) = 1;
2882	return 0;
2883	}
2884
2885	INDENT (spc);
2886
2887	if (RECORD_OR_UNION_TYPE_P (orig) && !TREE_VISITED (stub))
2888	dump_forward_type (buffer, type: orig, t, spc);
2889
2890	pp_string (buffer, "subtype ");
2891	dump_ada_node (buffer, node: t, type, spc, limited_access: false, name_only: true);
2892	pp_string (buffer, " is ");
2893	dump_ada_node (buffer, node: orig, type, spc, limited_access: false, name_only: true);
2894	pp_string (buffer, "; -- ");
2895	dump_sloc (buffer, node: t);
2896
2897	TREE_VISITED (t) = 1;
2898	return 1;
2899	}
2900
2901	/* This is a typedef of an anonymous type. We'll output the full
2902	type declaration of the anonymous type with the typedef'ed name
2903	below. Prevent forward declarations for the anonymous type to
2904	be emitted from now on. */
2905	TREE_VISITED (stub) = 1;
2906	}
2907
2908	/* Skip unnamed or anonymous structs/unions/enum types. */
2909	if (!orig
2910	&& (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))
2911	|| TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2912	&& !decl_name
2913	&& !name)
2914	return 0;
2915
2916	/* Skip duplicates of structs/unions/enum types built in C++. */
2917	if (!orig
2918	&& (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))
2919	|| TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2920	&& decl_name
2921	&& (*IDENTIFIER_POINTER (decl_name) == '.'
2922	|| *IDENTIFIER_POINTER (decl_name) == '$'))
2923	return 0;
2924
2925	INDENT (spc);
2926
2927	switch (TREE_CODE (TREE_TYPE (t)))
2928	{
2929	case RECORD_TYPE:
2930	case UNION_TYPE:
2931	if (!COMPLETE_TYPE_P (TREE_TYPE (t)))
2932	{
2933	pp_string (buffer, "type ");
2934	dump_ada_node (buffer, node: t, type, spc, limited_access: false, name_only: true);
2935	pp_string (buffer, " is null record; -- incomplete struct");
2936	TREE_VISITED (t) = 1;
2937	return 1;
2938	}
2939
2940	/* Packed record layout is not fully supported. */
2941	if (TYPE_PACKED (TREE_TYPE (t)))
2942	{
2943	warning_at (DECL_SOURCE_LOCATION (t), 0, "packed layout");
2944	pp_string (buffer, "pragma Compile_Time_Warning (True, ");
2945	pp_string (buffer, "\"packed layout may be incorrect\");");
2946	newline_and_indent (buffer, spc);
2947	packed_layout = true;
2948	}
2949
2950	if (orig && TYPE_NAME (orig))
2951	pp_string (buffer, "subtype ");
2952	else
2953	{
2954	if (separate_class_package (decl: t))
2955	{
2956	is_class = true;
2957	pp_string (buffer, "package Class_");
2958	dump_ada_node (buffer, node: t, type, spc, limited_access: false, name_only: true);
2959	pp_string (buffer, " is");
2960	spc += INDENT_INCR;
2961	newline_and_indent (buffer, spc);
2962	}
2963
2964	dump_nested_types (buffer, t, spc);
2965
2966	pp_string (buffer, "type ");
2967	}
2968	break;
2969
2970	case POINTER_TYPE:
2971	case REFERENCE_TYPE:
2972	dump_forward_type (buffer, TREE_TYPE (TREE_TYPE (t)), t, spc);
2973	if (orig && TYPE_NAME (orig))
2974	pp_string (buffer, "subtype ");
2975	else
2976	pp_string (buffer, "type ");
2977	break;
2978
2979	case ARRAY_TYPE:
2980	if ((orig && TYPE_NAME (orig)) || is_char_array (TREE_TYPE (t)))
2981	pp_string (buffer, "subtype ");
2982	else
2983	pp_string (buffer, "type ");
2984	break;
2985
2986	case FUNCTION_TYPE:
2987	pp_string (buffer, "-- skipped function type ");
2988	dump_ada_node (buffer, node: t, type, spc, limited_access: false, name_only: true);
2989	return 1;
2990
2991	case ENUMERAL_TYPE:
2992	if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2993	|| !is_simple_enum (TREE_TYPE (t)))
2994	pp_string (buffer, "subtype ");
2995	else
2996	pp_string (buffer, "type ");
2997	break;
2998
2999	default:
3000	pp_string (buffer, "subtype ");
3001	}
3002
3003	TREE_VISITED (t) = 1;
3004	}
3005	else
3006	{
3007	if (VAR_P (t)
3008	&& decl_name
3009	&& *IDENTIFIER_POINTER (decl_name) == '_')
3010	return 0;
3011
3012	need_indent = true;
3013	}
3014
3015	/* Print the type and name. */
3016	if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
3017	{
3018	if (need_indent)
3019	INDENT (spc);
3020
3021	/* Print variable's name. */
3022	dump_ada_node (buffer, node: t, type, spc, limited_access: false, name_only: true);
3023
3024	if (TREE_CODE (t) == TYPE_DECL)
3025	{
3026	pp_string (buffer, " is ");
3027
3028	if (orig && TYPE_NAME (orig))
3029	dump_ada_node (buffer, TYPE_NAME (orig), type, spc, limited_access: false, name_only: true);
3030	else
3031	dump_ada_array_type (buffer, TREE_TYPE (t), spc);
3032	}
3033	else
3034	{
3035	if (spc == INDENT_INCR || TREE_STATIC (t))
3036	is_var = true;
3037
3038	pp_string (buffer, " : ");
3039
3040	if (TREE_CODE (TREE_TYPE (TREE_TYPE (t))) != POINTER_TYPE
3041	&& !packed_layout)
3042	pp_string (buffer, "aliased ");
3043
3044	if (TYPE_NAME (TREE_TYPE (t)))
3045	dump_ada_node (buffer, TREE_TYPE (t), type, spc, limited_access: false, name_only: true);
3046	else if (type)
3047	dump_anonymous_type_name (buffer, TREE_TYPE (t));
3048	else
3049	dump_ada_array_type (buffer, TREE_TYPE (t), spc);
3050	}
3051	}
3052	else if (TREE_CODE (t) == FUNCTION_DECL)
3053	{
3054	tree decl_name = DECL_NAME (t);
3055	bool is_abstract_class = false;
3056	bool is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE;
3057	bool is_abstract = false;
3058	bool is_assignment_operator = false;
3059	bool is_constructor = false;
3060	bool is_destructor = false;
3061	bool is_copy_constructor = false;
3062	bool is_move_constructor = false;
3063
3064	if (!decl_name)
3065	return 0;
3066
3067	if (cpp_check)
3068	{
3069	is_abstract = cpp_check (t, IS_ABSTRACT);
3070	is_assignment_operator = cpp_check (t, IS_ASSIGNMENT_OPERATOR);
3071	is_constructor = cpp_check (t, IS_CONSTRUCTOR);
3072	is_destructor = cpp_check (t, IS_DESTRUCTOR);
3073	is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR);
3074	is_move_constructor = cpp_check (t, IS_MOVE_CONSTRUCTOR);
3075	}
3076
3077	/* Skip copy constructors and C++11 move constructors: some are internal
3078	only and those that are not cannot be called easily from Ada. */
3079	if (is_copy_constructor || is_move_constructor)
3080	return 0;
3081
3082	if (is_constructor || is_destructor)
3083	{
3084	/* ??? Skip implicit constructors/destructors for now. */
3085	if (DECL_ARTIFICIAL (t))
3086	return 0;
3087
3088	/* Only consider complete constructors and deleting destructors. */
3089	if (!startswith (IDENTIFIER_POINTER (decl_name), prefix: "__ct_comp")
3090	&& !startswith (IDENTIFIER_POINTER (decl_name), prefix: "__dt_comp")
3091	&& !startswith (IDENTIFIER_POINTER (decl_name), prefix: "__dt_del"))
3092	return 0;
3093	}
3094
3095	else if (is_assignment_operator)
3096	{
3097	/* ??? Skip implicit or non-method assignment operators for now. */
3098	if (DECL_ARTIFICIAL (t) || !is_method)
3099	return 0;
3100	}
3101
3102	/* If this function has an entry in the vtable, we cannot omit it. */
3103	else if (!DECL_VINDEX (t) && *IDENTIFIER_POINTER (decl_name) == '_')
3104	{
3105	INDENT (spc);
3106	pp_string (buffer, "-- skipped func ");
3107	pp_string (buffer, IDENTIFIER_POINTER (decl_name));
3108	return 1;
3109	}
3110
3111	INDENT (spc);
3112
3113	dump_forward_type (buffer, TREE_TYPE (t), t, spc);
3114
3115	if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))) && !is_constructor)
3116	pp_string (buffer, "procedure ");
3117	else
3118	pp_string (buffer, "function ");
3119
3120	if (is_constructor)
3121	print_constructor (buffer, t, type);
3122	else if (is_destructor)
3123	print_destructor (buffer, t, type);
3124	else if (is_assignment_operator)
3125	print_assignment_operator (buffer, t, type);
3126	else
3127	{
3128	const unsigned int suffix = overloading_index (name: decl_name);
3129	pp_ada_tree_identifier (buffer, node: decl_name, type: t, limited_access: false);
3130	if (suffix > 1)
3131	pp_decimal_int (buffer, suffix);
3132	}
3133
3134	dump_ada_function_declaration
3135	(buffer, func: t, is_method, is_constructor, is_destructor, spc);
3136
3137	if (is_constructor && RECORD_OR_UNION_TYPE_P (type))
3138	for (tree fld = TYPE_FIELDS (type); fld; fld = DECL_CHAIN (fld))
3139	if (TREE_CODE (fld) == FUNCTION_DECL && cpp_check (fld, IS_ABSTRACT))
3140	{
3141	is_abstract_class = true;
3142	break;
3143	}
3144
3145	if (is_abstract || is_abstract_class)
3146	pp_string (buffer, " is abstract");
3147
3148	if (is_abstract || !DECL_ASSEMBLER_NAME (t))
3149	{
3150	pp_semicolon (buffer);
3151	pp_string (buffer, " -- ");
3152	dump_sloc (buffer, node: t);
3153	}
3154	else if (is_constructor)
3155	{
3156	pp_semicolon (buffer);
3157	pp_string (buffer, " -- ");
3158	dump_sloc (buffer, node: t);
3159
3160	newline_and_indent (buffer, spc);
3161	pp_string (buffer, "pragma CPP_Constructor (");
3162	print_constructor (buffer, t, type);
3163	pp_string (buffer, ", \"");
3164	pp_asm_name (buffer, t);
3165	pp_string (buffer, "\");");
3166	}
3167	else
3168	{
3169	pp_string (buffer, " -- ");
3170	dump_sloc (buffer, node: t);
3171
3172	newline_and_indent (buffer, spc);
3173	dump_ada_import (buffer, t, spc);
3174	}
3175
3176	return 1;
3177	}
3178	else if (TREE_CODE (t) == TYPE_DECL && !orig)
3179	{
3180	bool is_interface = false;
3181	bool is_abstract_record = false;
3182
3183	/* Anonymous structs/unions. */
3184	dump_ada_node (buffer, TREE_TYPE (t), type: t, spc, limited_access: false, name_only: true);
3185
3186	if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE)
3187	pp_string (buffer, " (discr : unsigned := 0)");
3188
3189	pp_string (buffer, " is ");
3190
3191	/* Check whether we have an Ada interface compatible class.
3192	That is only have a vtable non-static data member and no
3193	non-abstract methods. */
3194	if (cpp_check
3195	&& RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
3196	{
3197	bool has_fields = false;
3198
3199	/* Check that there are no fields other than the virtual table. */
3200	for (tree fld = TYPE_FIELDS (TREE_TYPE (t));
3201	fld;
3202	fld = TREE_CHAIN (fld))
3203	{
3204	if (TREE_CODE (fld) == FIELD_DECL)
3205	{
3206	if (!has_fields && DECL_VIRTUAL_P (fld))
3207	is_interface = true;
3208	else
3209	is_interface = false;
3210	has_fields = true;
3211	}
3212	else if (TREE_CODE (fld) == FUNCTION_DECL
3213	&& !DECL_ARTIFICIAL (fld))
3214	{
3215	if (cpp_check (fld, IS_ABSTRACT))
3216	is_abstract_record = true;
3217	else
3218	is_interface = false;
3219	}
3220	}
3221	}
3222
3223	TREE_VISITED (t) = 1;
3224	if (is_interface)
3225	{
3226	pp_string (buffer, "limited interface -- ");
3227	dump_sloc (buffer, node: t);
3228	newline_and_indent (buffer, spc);
3229	pp_string (buffer, "with Import => True,");
3230	newline_and_indent (buffer, spc: spc + 5);
3231	pp_string (buffer, "Convention => CPP");
3232
3233	dump_ada_methods (buffer, TREE_TYPE (t), spc);
3234	}
3235	else
3236	{
3237	if (is_abstract_record)
3238	pp_string (buffer, "abstract ");
3239	dump_ada_node (buffer, node: t, type: t, spc, limited_access: false, name_only: false);
3240	}
3241	}
3242	else
3243	{
3244	if (need_indent)
3245	INDENT (spc);
3246
3247	if ((TREE_CODE (t) == FIELD_DECL || VAR_P (t))
3248	&& DECL_NAME (t))
3249	check_type_name_conflict (buffer, t);
3250
3251	/* Print variable/type's name. */
3252	dump_ada_node (buffer, node: t, type: t, spc, limited_access: false, name_only: true);
3253
3254	if (TREE_CODE (t) == TYPE_DECL)
3255	{
3256	const bool is_subtype = TYPE_NAME (orig);
3257
3258	if (!is_subtype && TREE_CODE (TREE_TYPE (t)) == UNION_TYPE)
3259	pp_string (buffer, " (discr : unsigned := 0)");
3260
3261	pp_string (buffer, " is ");
3262
3263	dump_ada_node (buffer, node: orig, type: t, spc, limited_access: false, name_only: is_subtype);
3264	}
3265	else
3266	{
3267	if (spc == INDENT_INCR || TREE_STATIC (t))
3268	is_var = true;
3269
3270	pp_string (buffer, " : ");
3271
3272	if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE
3273	&& (TYPE_NAME (TREE_TYPE (t))
3274	|| (TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE
3275	&& TREE_CODE (TREE_TYPE (t)) != ENUMERAL_TYPE))
3276	&& !packed_layout)
3277	pp_string (buffer, "aliased ");
3278
3279	if (TREE_READONLY (t) && TREE_CODE (t) != FIELD_DECL)
3280	pp_string (buffer, "constant ");
3281
3282	if (TYPE_NAME (TREE_TYPE (t))
3283	|| (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))
3284	&& TREE_CODE (TREE_TYPE (t)) != ENUMERAL_TYPE))
3285	dump_ada_node (buffer, TREE_TYPE (t), type: t, spc, limited_access: false, name_only: true);
3286	else if (type)
3287	dump_anonymous_type_name (buffer, TREE_TYPE (t));
3288	}
3289	}
3290
3291	if (is_class)
3292	{
3293	spc -= INDENT_INCR;
3294	newline_and_indent (buffer, spc);
3295	pp_string (buffer, "end;");
3296	newline_and_indent (buffer, spc);
3297	pp_string (buffer, "use Class_");
3298	dump_ada_node (buffer, node: t, type, spc, limited_access: false, name_only: true);
3299	pp_semicolon (buffer);
3300	pp_newline (buffer);
3301
3302	/* All needed indentation/newline performed already, so return 0. */
3303	return 0;
3304	}
3305	else if (is_var)
3306	{
3307	pp_string (buffer, " -- ");
3308	dump_sloc (buffer, node: t);
3309	newline_and_indent (buffer, spc);
3310	dump_ada_import (buffer, t, spc);
3311	}
3312
3313	else
3314	{
3315	pp_string (buffer, "; -- ");
3316	dump_sloc (buffer, node: t);
3317	}
3318
3319	return 1;
3320	}
3321
3322	/* Dump in BUFFER a structure NODE of type TYPE in Ada syntax. If NESTED is
3323	true, it's an anonymous nested type. SPC is the indentation level. */
3324
3325	static void
3326	dump_ada_structure (pretty_printer *buffer, tree node, tree type, bool nested,
3327	int spc)
3328	{
3329	const bool is_union = (TREE_CODE (node) == UNION_TYPE);
3330	char buf[32];
3331	int field_num = 0;
3332	int field_spc = spc + INDENT_INCR;
3333	int need_semicolon;
3334
3335	bitfield_used = false;
3336
3337	/* Print the contents of the structure. */
3338	pp_string (buffer, "record");
3339
3340	if (is_union)
3341	{
3342	newline_and_indent (buffer, spc: spc + INDENT_INCR);
3343	pp_string (buffer, "case discr is");
3344	field_spc = spc + INDENT_INCR * 3;
3345	}
3346
3347	pp_newline (buffer);
3348
3349	/* Print the non-static fields of the structure. */
3350	for (tree tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3351	{
3352	/* Add parent field if needed. */
3353	if (!DECL_NAME (tmp))
3354	{
3355	if (!is_tagged_type (TREE_TYPE (tmp)))
3356	{
3357	if (!TYPE_NAME (TREE_TYPE (tmp)))
3358	dump_ada_declaration (buffer, t: tmp, type, spc: field_spc);
3359	else
3360	{
3361	INDENT (field_spc);
3362
3363	if (field_num == 0)
3364	pp_string (buffer, "parent : aliased ");
3365	else
3366	{
3367	sprintf (s: buf, format: "field_%d : aliased ", field_num + 1);
3368	pp_string (buffer, buf);
3369	}
3370	dump_ada_decl_name (buffer, TYPE_NAME (TREE_TYPE (tmp)),
3371	limited_access: false);
3372	pp_semicolon (buffer);
3373	}
3374
3375	pp_newline (buffer);
3376	field_num++;
3377	}
3378	}
3379	else if (TREE_CODE (tmp) == FIELD_DECL)
3380	{
3381	/* Skip internal virtual table field. */
3382	if (!DECL_VIRTUAL_P (tmp))
3383	{
3384	if (is_union)
3385	{
3386	if (TREE_CHAIN (tmp)
3387	&& TREE_TYPE (TREE_CHAIN (tmp)) != node
3388	&& TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL)
3389	sprintf (s: buf, format: "when %d =>", field_num);
3390	else
3391	sprintf (s: buf, format: "when others =>");
3392
3393	INDENT (spc + INDENT_INCR * 2);
3394	pp_string (buffer, buf);
3395	pp_newline (buffer);
3396	}
3397
3398	if (dump_ada_declaration (buffer, t: tmp, type, spc: field_spc))
3399	{
3400	pp_newline (buffer);
3401	field_num++;
3402	}
3403	}
3404	}
3405	}
3406
3407	if (is_union)
3408	{
3409	INDENT (spc + INDENT_INCR);
3410	pp_string (buffer, "end case;");
3411	pp_newline (buffer);
3412	}
3413
3414	if (field_num == 0)
3415	{
3416	INDENT (spc + INDENT_INCR);
3417	pp_string (buffer, "null;");
3418	pp_newline (buffer);
3419	}
3420
3421	INDENT (spc);
3422	pp_string (buffer, "end record");
3423
3424	newline_and_indent (buffer, spc);
3425
3426	/* We disregard the methods for anonymous nested types. */
3427	if (has_nontrivial_methods (type: node) && !nested)
3428	{
3429	pp_string (buffer, "with Import => True,");
3430	newline_and_indent (buffer, spc: spc + 5);
3431	pp_string (buffer, "Convention => CPP");
3432	}
3433	else
3434	pp_string (buffer, "with Convention => C_Pass_By_Copy");
3435
3436	if (is_union)
3437	{
3438	pp_comma (buffer);
3439	newline_and_indent (buffer, spc: spc + 5);
3440	pp_string (buffer, "Unchecked_Union => True");
3441	}
3442
3443	if (bitfield_used || packed_layout)
3444	{
3445	char buf[32];
3446	pp_comma (buffer);
3447	newline_and_indent (buffer, spc: spc + 5);
3448	pp_string (buffer, "Pack => True");
3449	pp_comma (buffer);
3450	newline_and_indent (buffer, spc: spc + 5);
3451	sprintf (s: buf, format: "Alignment => %d", TYPE_ALIGN (node) / BITS_PER_UNIT);
3452	pp_string (buffer, buf);
3453	bitfield_used = false;
3454	packed_layout = false;
3455	}
3456
3457	if (nested)
3458	return;
3459
3460	need_semicolon = !dump_ada_methods (buffer, node, spc);
3461
3462	/* Print the static fields of the structure, if any. */
3463	for (tree tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3464	{
3465	if (VAR_P (tmp) && DECL_NAME (tmp))
3466	{
3467	if (need_semicolon)
3468	{
3469	need_semicolon = false;
3470	pp_semicolon (buffer);
3471	}
3472	pp_newline (buffer);
3473	pp_newline (buffer);
3474	dump_ada_declaration (buffer, t: tmp, type, spc);
3475	}
3476	}
3477	}
3478
3479	/* Dump all the declarations in SOURCE_FILE to an Ada spec.
3480	COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3481	nodes for SOURCE_FILE. CHECK is used to perform C++ queries on nodes. */
3482
3483	static void
3484	dump_ads (const char *source_file,
3485	void (*collect_all_refs)(const char *),
3486	int (*check)(tree, cpp_operation))
3487	{
3488	char *ads_name;
3489	char *pkg_name;
3490	char *s;
3491	FILE *f;
3492
3493	pkg_name = get_ada_package (file: source_file);
3494
3495	/* Construct the .ads filename and package name. */
3496	ads_name = xstrdup (pkg_name);
3497
3498	for (s = ads_name; *s; s++)
3499	if (*s == '.')
3500	*s = '-';
3501	else
3502	*s = TOLOWER (*s);
3503
3504	ads_name = reconcat (ads_name, ads_name, ".ads", NULL);
3505
3506	/* Write out the .ads file. */
3507	f = fopen (filename: ads_name, modes: "w");
3508	if (f)
3509	{
3510	pretty_printer pp;
3511
3512	pp_needs_newline (&pp) = true;
3513	pp.buffer->stream = f;
3514
3515	/* Dump all relevant macros. */
3516	dump_ada_macros (pp: &pp, file: source_file);
3517
3518	/* Reset the table of withs for this file. */
3519	reset_ada_withs ();
3520
3521	(*collect_all_refs) (source_file);
3522
3523	/* Dump all references. */
3524	cpp_check = check;
3525	dump_ada_nodes (pp: &pp, source_file);
3526
3527	/* We require Ada 2012 syntax, so generate corresponding pragma. */
3528	fputs (s: "pragma Ada_2012;\n\n", stream: f);
3529
3530	/* Disable style checks and warnings on unused entities since this file
3531	is auto-generated and always has a with clause for Interfaces.C. */
3532	fputs (s: "pragma Style_Checks (Off);\n", stream: f);
3533	fputs (s: "pragma Warnings (Off, \"-gnatwu\");\n\n", stream: f);
3534
3535	/* Dump withs. */
3536	dump_ada_withs (f);
3537
3538	fprintf (stream: f, format: "\npackage %s is\n\n", pkg_name);
3539	pp_write_text_to_stream (&pp);
3540	/* ??? need to free pp */
3541	fprintf (stream: f, format: "end %s;\n\n", pkg_name);
3542
3543	fputs (s: "pragma Style_Checks (On);\n", stream: f);
3544	fputs (s: "pragma Warnings (On, \"-gnatwu\");\n", stream: f);
3545	fclose (stream: f);
3546	}
3547
3548	free (ptr: ads_name);
3549	free (ptr: pkg_name);
3550	}
3551
3552	static const char **source_refs = NULL;
3553	static int source_refs_used = 0;
3554	static int source_refs_allocd = 0;
3555
3556	/* Add an entry for FILENAME to the table SOURCE_REFS. */
3557
3558	void
3559	collect_source_ref (const char *filename)
3560	{
3561	int i;
3562
3563	if (!filename)
3564	return;
3565
3566	if (source_refs_allocd == 0)
3567	{
3568	source_refs_allocd = 1024;
3569	source_refs = XNEWVEC (const char *, source_refs_allocd);
3570	}
3571
3572	for (i = 0; i < source_refs_used; i++)
3573	if (filename == source_refs[i])
3574	return;
3575
3576	if (source_refs_used == source_refs_allocd)
3577	{
3578	source_refs_allocd *= 2;
3579	source_refs = XRESIZEVEC (const char *, source_refs, source_refs_allocd);
3580	}
3581
3582	source_refs[source_refs_used++] = filename;
3583	}
3584
3585	/* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
3586	using callbacks COLLECT_ALL_REFS and CHECK.
3587	COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3588	nodes for a given source file.
3589	CHECK is used to perform C++ queries on nodes, or NULL for the C
3590	front-end. */
3591
3592	void
3593	dump_ada_specs (void (*collect_all_refs)(const char *),
3594	int (*check)(tree, cpp_operation))
3595	{
3596	bitmap_obstack_initialize (NULL);
3597
3598	overloaded_names = init_overloaded_names ();
3599
3600	/* Iterate over the list of files to dump specs for. */
3601	for (int i = 0; i < source_refs_used; i++)
3602	{
3603	dumped_anonymous_types = BITMAP_ALLOC (NULL);
3604	dump_ads (source_file: source_refs[i], collect_all_refs, check);
3605	BITMAP_FREE (dumped_anonymous_types);
3606	}
3607
3608	/* Free various tables. */
3609	free (ptr: source_refs);
3610	delete overloaded_names;
3611
3612	bitmap_obstack_release (NULL);
3613	}
3614