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