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