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