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