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