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