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