?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
[gcc]
[official-gcc.git] / gcc / c-family / c-ada-spec.c
blob6cf298a126afc91af909de8dfde3ef3c10846dfa
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 the type is a pointer to a tagged type, we need to differentiate
1687 virtual methods from the rest (non-virtual methods, static member
1688 or regular functions) and import only them as primitive operations,
1689 because they make up the virtual table which is mirrored on the Ada
1690 side by the dispatch table. So we add 'Class to the type of every
1691 parameter that is not the first one of a method which either has a
1692 slot in the virtual table or is a constructor. */
1693 if (TREE_TYPE (arg)
1694 && POINTER_TYPE_P (TREE_TYPE (arg))
1695 && is_tagged_type (TREE_TYPE (TREE_TYPE (arg)))
1696 && !(num == 1 && is_method && (DECL_VINDEX (func) || is_constructor)))
1697 pp_string (buffer, "'Class");
1698
1699 arg = TREE_CHAIN (arg);
1700
1701 if (num < num_args)
1702 {
1703 pp_semicolon (buffer);
1704
1705 if (num_args > 2)
1706 newline_and_indent (buffer, spc + INDENT_INCR);
1707 else
1708 pp_space (buffer);
1709 }
1710 }
1711
1712 if (have_ellipsis)
1713 {
1714 pp_string (buffer, " -- , ...");
1715 newline_and_indent (buffer, spc + INDENT_INCR);
1716 }
1717
1718 if (num_args > 0)
1719 pp_right_paren (buffer);
1720 return num_args;
1721 }
1722
1723 /* Dump in BUFFER all the domains associated with an array NODE,
1724 using Ada syntax. SPC is the current indentation level. */
1725
1726 static void
1727 dump_ada_array_domains (pretty_printer *buffer, tree node, int spc)
1728 {
1729 int first = 1;
1730 pp_left_paren (buffer);
1731
1732 for (; TREE_CODE (node) == ARRAY_TYPE; node = TREE_TYPE (node))
1733 {
1734 tree domain = TYPE_DOMAIN (node);
1735
1736 if (domain)
1737 {
1738 tree min = TYPE_MIN_VALUE (domain);
1739 tree max = TYPE_MAX_VALUE (domain);
1740
1741 if (!first)
1742 pp_string (buffer, ", ");
1743 first = 0;
1744
1745 if (min)
1746 dump_generic_ada_node (buffer, min, NULL_TREE, spc, 0, true);
1747 pp_string (buffer, " .. ");
1748
1749 /* If the upper bound is zero, gcc may generate a NULL_TREE
1750 for TYPE_MAX_VALUE rather than an integer_cst. */
1751 if (max)
1752 dump_generic_ada_node (buffer, max, NULL_TREE, spc, 0, true);
1753 else
1754 pp_string (buffer, "0");
1755 }
1756 else
1757 pp_string (buffer, "size_t");
1758 }
1759 pp_right_paren (buffer);
1760 }
1761
1762 /* Dump in BUFFER file:line information related to NODE. */
1763
1764 static void
1765 dump_sloc (pretty_printer *buffer, tree node)
1766 {
1767 expanded_location xloc;
1768
1769 xloc.file = NULL;
1770
1771 if (DECL_P (node))
1772 xloc = expand_location (DECL_SOURCE_LOCATION (node));
1773 else if (EXPR_HAS_LOCATION (node))
1774 xloc = expand_location (EXPR_LOCATION (node));
1775
1776 if (xloc.file)
1777 {
1778 pp_string (buffer, xloc.file);
1779 pp_colon (buffer);
1780 pp_decimal_int (buffer, xloc.line);
1781 }
1782 }
1783
1784 /* Return true if T designates a one dimension array of "char". */
1785
1786 static bool
1787 is_char_array (tree t)
1788 {
1789 tree tmp;
1790 int num_dim = 0;
1791
1792 /* Retrieve array's type. */
1793 tmp = t;
1794 while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1795 {
1796 num_dim++;
1797 tmp = TREE_TYPE (tmp);
1798 }
1799
1800 tmp = TREE_TYPE (tmp);
1801 return num_dim == 1 && TREE_CODE (tmp) == INTEGER_TYPE
1802 && id_equal (DECL_NAME (TYPE_NAME (tmp)), "char");
1803 }
1804
1805 /* Dump in BUFFER an array type T in Ada syntax. Assume that the "type"
1806 keyword and name have already been printed. PARENT is the parent node of T.
1807 SPC is the indentation level. */
1808
1809 static void
1810 dump_ada_array_type (pretty_printer *buffer, tree t, tree parent, int spc)
1811 {
1812 const bool char_array = is_char_array (t);
1813 tree tmp;
1814
1815 /* Special case char arrays. */
1816 if (char_array)
1817 {
1818 pp_string (buffer, "Interfaces.C.char_array ");
1819 }
1820 else
1821 pp_string (buffer, "array ");
1822
1823 /* Print the dimensions. */
1824 dump_ada_array_domains (buffer, TREE_TYPE (t), spc);
1825
1826 /* Retrieve the element type. */
1827 tmp = TREE_TYPE (t);
1828 while (TREE_CODE (tmp) == ARRAY_TYPE)
1829 tmp = TREE_TYPE (tmp);
1830
1831 /* Print array's type. */
1832 if (!char_array)
1833 {
1834 pp_string (buffer, " of ");
1835
1836 if (TREE_CODE (tmp) != POINTER_TYPE)
1837 pp_string (buffer, "aliased ");
1838
1839 if (TYPE_NAME (tmp) || !RECORD_OR_UNION_TYPE_P (tmp))
1840 dump_generic_ada_node (buffer, tmp, TREE_TYPE (t), spc, false, true);
1841 else
1842 dump_ada_double_name (buffer, parent, get_underlying_decl (tmp));
1843 }
1844 }
1845
1846 /* Dump in BUFFER type names associated with a template, each prepended with
1847 '_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS. SPC is
1848 the indentation level. */
1849
1850 static void
1851 dump_template_types (pretty_printer *buffer, tree types, int spc)
1852 {
1853 size_t i;
1854 size_t len = TREE_VEC_LENGTH (types);
1855
1856 for (i = 0; i < len; i++)
1857 {
1858 tree elem = TREE_VEC_ELT (types, i);
1859 pp_underscore (buffer);
1860 if (!dump_generic_ada_node (buffer, elem, 0, spc, false, true))
1861 {
1862 pp_string (buffer, "unknown");
1863 pp_scalar (buffer, "%lu", (unsigned long) TREE_HASH (elem));
1864 }
1865 }
1866 }
1867
1868 /* Dump in BUFFER the contents of all class instantiations associated with
1869 a given template T. SPC is the indentation level. */
1870
1871 static int
1872 dump_ada_template (pretty_printer *buffer, tree t, int spc)
1873 {
1874 /* DECL_SIZE_UNIT is DECL_TEMPLATE_INSTANTIATIONS in this context. */
1875 tree inst = DECL_SIZE_UNIT (t);
1876 /* This emulates DECL_TEMPLATE_RESULT in this context. */
1877 struct tree_template_decl {
1878 struct tree_decl_common common;
1879 tree arguments;
1880 tree result;
1881 };
1882 tree result = ((struct tree_template_decl *) t)->result;
1883 int num_inst = 0;
1884
1885 /* Don't look at template declarations declaring something coming from
1886 another file. This can occur for template friend declarations. */
1887 if (LOCATION_FILE (decl_sloc (result, false))
1888 != LOCATION_FILE (decl_sloc (t, false)))
1889 return 0;
1890
1891 for (; inst && inst != error_mark_node; inst = TREE_CHAIN (inst))
1892 {
1893 tree types = TREE_PURPOSE (inst);
1894 tree instance = TREE_VALUE (inst);
1895
1896 if (TREE_VEC_LENGTH (types) == 0)
1897 break;
1898
1899 if (!RECORD_OR_UNION_TYPE_P (instance) || !TYPE_METHODS (instance))
1900 break;
1901
1902 /* We are interested in concrete template instantiations only: skip
1903 partially specialized nodes. */
1904 if (RECORD_OR_UNION_TYPE_P (instance)
1905 && cpp_check
1906 && cpp_check (instance, HAS_DEPENDENT_TEMPLATE_ARGS))
1907 continue;
1908
1909 num_inst++;
1910 INDENT (spc);
1911 pp_string (buffer, "package ");
1912 package_prefix = false;
1913 dump_generic_ada_node (buffer, instance, t, spc, false, true);
1914 dump_template_types (buffer, types, spc);
1915 pp_string (buffer, " is");
1916 spc += INDENT_INCR;
1917 newline_and_indent (buffer, spc);
1918
1919 TREE_VISITED (get_underlying_decl (instance)) = 1;
1920 pp_string (buffer, "type ");
1921 dump_generic_ada_node (buffer, instance, t, spc, false, true);
1922 package_prefix = true;
1923
1924 if (is_tagged_type (instance))
1925 pp_string (buffer, " is tagged limited ");
1926 else
1927 pp_string (buffer, " is limited ");
1928
1929 dump_generic_ada_node (buffer, instance, t, spc, false, false);
1930 pp_newline (buffer);
1931 spc -= INDENT_INCR;
1932 newline_and_indent (buffer, spc);
1933
1934 pp_string (buffer, "end;");
1935 newline_and_indent (buffer, spc);
1936 pp_string (buffer, "use ");
1937 package_prefix = false;
1938 dump_generic_ada_node (buffer, instance, t, spc, false, true);
1939 dump_template_types (buffer, types, spc);
1940 package_prefix = true;
1941 pp_semicolon (buffer);
1942 pp_newline (buffer);
1943 pp_newline (buffer);
1944 }
1945
1946 return num_inst > 0;
1947 }
1948
1949 /* Return true if NODE is a simple enum types, that can be mapped to an
1950 Ada enum type directly. */
1951
1952 static bool
1953 is_simple_enum (tree node)
1954 {
1955 HOST_WIDE_INT count = 0;
1956 tree value;
1957
1958 for (value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
1959 {
1960 tree int_val = TREE_VALUE (value);
1961
1962 if (TREE_CODE (int_val) != INTEGER_CST)
1963 int_val = DECL_INITIAL (int_val);
1964
1965 if (!tree_fits_shwi_p (int_val))
1966 return false;
1967 else if (tree_to_shwi (int_val) != count)
1968 return false;
1969
1970 count++;
1971 }
1972
1973 return true;
1974 }
1975
1976 static bool bitfield_used = false;
1977
1978 /* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
1979 TYPE. SPC is the indentation level. LIMITED_ACCESS indicates whether NODE
1980 can be referenced via a "limited with" clause. NAME_ONLY indicates whether
1981 we should only dump the name of NODE, instead of its full declaration. */
1982
1983 static int
1984 dump_generic_ada_node (pretty_printer *buffer, tree node, tree type, int spc,
1985 int limited_access, bool name_only)
1986 {
1987 if (node == NULL_TREE)
1988 return 0;
1989
1990 switch (TREE_CODE (node))
1991 {
1992 case ERROR_MARK:
1993 pp_string (buffer, "<<< error >>>");
1994 return 0;
1995
1996 case IDENTIFIER_NODE:
1997 pp_ada_tree_identifier (buffer, node, type, limited_access);
1998 break;
1999
2000 case TREE_LIST:
2001 pp_string (buffer, "--- unexpected node: TREE_LIST");
2002 return 0;
2003
2004 case TREE_BINFO:
2005 dump_generic_ada_node
2006 (buffer, BINFO_TYPE (node), type, spc, limited_access, name_only);
2007 return 0;
2008
2009 case TREE_VEC:
2010 pp_string (buffer, "--- unexpected node: TREE_VEC");
2011 return 0;
2012
2013 case VOID_TYPE:
2014 if (package_prefix)
2015 {
2016 append_withs ("System", false);
2017 pp_string (buffer, "System.Address");
2018 }
2019 else
2020 pp_string (buffer, "address");
2021 break;
2022
2023 case VECTOR_TYPE:
2024 pp_string (buffer, "<vector>");
2025 break;
2026
2027 case COMPLEX_TYPE:
2028 pp_string (buffer, "<complex>");
2029 break;
2030
2031 case ENUMERAL_TYPE:
2032 if (name_only)
2033 dump_generic_ada_node (buffer, TYPE_NAME (node), node, spc, 0, true);
2034 else
2035 {
2036 tree value = TYPE_VALUES (node);
2037
2038 if (is_simple_enum (node))
2039 {
2040 bool first = true;
2041 spc += INDENT_INCR;
2042 newline_and_indent (buffer, spc - 1);
2043 pp_left_paren (buffer);
2044 for (; value; value = TREE_CHAIN (value))
2045 {
2046 if (first)
2047 first = false;
2048 else
2049 {
2050 pp_comma (buffer);
2051 newline_and_indent (buffer, spc);
2052 }
2053
2054 pp_ada_tree_identifier
2055 (buffer, TREE_PURPOSE (value), node, false);
2056 }
2057 pp_string (buffer, ");");
2058 spc -= INDENT_INCR;
2059 newline_and_indent (buffer, spc);
2060 pp_string (buffer, "pragma Convention (C, ");
2061 dump_generic_ada_node
2062 (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
2063 spc, 0, true);
2064 pp_right_paren (buffer);
2065 }
2066 else
2067 {
2068 pp_string (buffer, "unsigned");
2069 for (; value; value = TREE_CHAIN (value))
2070 {
2071 pp_semicolon (buffer);
2072 newline_and_indent (buffer, spc);
2073
2074 pp_ada_tree_identifier
2075 (buffer, TREE_PURPOSE (value), node, false);
2076 pp_string (buffer, " : constant ");
2077
2078 dump_generic_ada_node
2079 (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
2080 spc, 0, true);
2081
2082 pp_string (buffer, " := ");
2083 dump_generic_ada_node
2084 (buffer,
2085 TREE_CODE (TREE_VALUE (value)) == INTEGER_CST ?
2086 TREE_VALUE (value) : DECL_INITIAL (TREE_VALUE (value)),
2087 node, spc, false, true);
2088 }
2089 }
2090 }
2091 break;
2092
2093 case INTEGER_TYPE:
2094 case REAL_TYPE:
2095 case FIXED_POINT_TYPE:
2096 case BOOLEAN_TYPE:
2097 {
2098 enum tree_code_class tclass;
2099
2100 tclass = TREE_CODE_CLASS (TREE_CODE (node));
2101
2102 if (tclass == tcc_declaration)
2103 {
2104 if (DECL_NAME (node))
2105 pp_ada_tree_identifier
2106 (buffer, DECL_NAME (node), 0, limited_access);
2107 else
2108 pp_string (buffer, "<unnamed type decl>");
2109 }
2110 else if (tclass == tcc_type)
2111 {
2112 if (TYPE_NAME (node))
2113 {
2114 if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE)
2115 pp_ada_tree_identifier (buffer, TYPE_NAME (node),
2116 node, limited_access);
2117 else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
2118 && DECL_NAME (TYPE_NAME (node)))
2119 dump_ada_decl_name (buffer, TYPE_NAME (node), limited_access);
2120 else
2121 pp_string (buffer, "<unnamed type>");
2122 }
2123 else if (TREE_CODE (node) == INTEGER_TYPE)
2124 {
2125 append_withs ("Interfaces.C.Extensions", false);
2126 bitfield_used = true;
2127
2128 if (TYPE_PRECISION (node) == 1)
2129 pp_string (buffer, "Extensions.Unsigned_1");
2130 else
2131 {
2132 pp_string (buffer, (TYPE_UNSIGNED (node)
2133 ? "Extensions.Unsigned_"
2134 : "Extensions.Signed_"));
2135 pp_decimal_int (buffer, TYPE_PRECISION (node));
2136 }
2137 }
2138 else
2139 pp_string (buffer, "<unnamed type>");
2140 }
2141 break;
2142 }
2143
2144 case POINTER_TYPE:
2145 case REFERENCE_TYPE:
2146 if (name_only && TYPE_NAME (node))
2147 dump_generic_ada_node
2148 (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2149
2150 else if (TREE_CODE (TREE_TYPE (node)) == FUNCTION_TYPE)
2151 {
2152 tree fnode = TREE_TYPE (node);
2153 bool is_function;
2154
2155 if (VOID_TYPE_P (TREE_TYPE (fnode)))
2156 {
2157 is_function = false;
2158 pp_string (buffer, "access procedure");
2159 }
2160 else
2161 {
2162 is_function = true;
2163 pp_string (buffer, "access function");
2164 }
2165
2166 dump_ada_function_declaration
2167 (buffer, node, false, false, false, spc + INDENT_INCR);
2168
2169 if (is_function)
2170 {
2171 pp_string (buffer, " return ");
2172 dump_generic_ada_node
2173 (buffer, TREE_TYPE (fnode), type, spc, 0, true);
2174 }
2175
2176 /* If we are dumping the full type, it means we are part of a
2177 type definition and need also a Convention C pragma. */
2178 if (!name_only)
2179 {
2180 pp_semicolon (buffer);
2181 newline_and_indent (buffer, spc);
2182 pp_string (buffer, "pragma Convention (C, ");
2183 dump_generic_ada_node
2184 (buffer, type, 0, spc, false, true);
2185 pp_right_paren (buffer);
2186 }
2187 }
2188 else
2189 {
2190 int is_access = false;
2191 unsigned int quals = TYPE_QUALS (TREE_TYPE (node));
2192
2193 if (VOID_TYPE_P (TREE_TYPE (node)))
2194 {
2195 if (!name_only)
2196 pp_string (buffer, "new ");
2197 if (package_prefix)
2198 {
2199 append_withs ("System", false);
2200 pp_string (buffer, "System.Address");
2201 }
2202 else
2203 pp_string (buffer, "address");
2204 }
2205 else
2206 {
2207 if (TREE_CODE (node) == POINTER_TYPE
2208 && TREE_CODE (TREE_TYPE (node)) == INTEGER_TYPE
2209 && !strcmp
2210 (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME
2211 (TREE_TYPE (node)))), "char"))
2212 {
2213 if (!name_only)
2214 pp_string (buffer, "new ");
2215
2216 if (package_prefix)
2217 {
2218 pp_string (buffer, "Interfaces.C.Strings.chars_ptr");
2219 append_withs ("Interfaces.C.Strings", false);
2220 }
2221 else
2222 pp_string (buffer, "chars_ptr");
2223 }
2224 else
2225 {
2226 tree type_name = TYPE_NAME (TREE_TYPE (node));
2227 tree decl = get_underlying_decl (TREE_TYPE (node));
2228 tree enclosing_decl = get_underlying_decl (type);
2229
2230 /* For now, handle access-to-access, access-to-empty-struct
2231 or access-to-incomplete as opaque system.address. */
2232 if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE
2233 || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
2234 && !TYPE_FIELDS (TREE_TYPE (node)))
2235 || !decl
2236 || (!enclosing_decl
2237 && !TREE_VISITED (decl)
2238 && DECL_SOURCE_FILE (decl) == source_file_base)
2239 || (enclosing_decl
2240 && !TREE_VISITED (decl)
2241 && DECL_SOURCE_FILE (decl)
2242 == DECL_SOURCE_FILE (enclosing_decl)
2243 && decl_sloc (decl, true)
2244 > decl_sloc (enclosing_decl, true)))
2245 {
2246 if (package_prefix)
2247 {
2248 append_withs ("System", false);
2249 if (!name_only)
2250 pp_string (buffer, "new ");
2251 pp_string (buffer, "System.Address");
2252 }
2253 else
2254 pp_string (buffer, "address");
2255 return spc;
2256 }
2257
2258 if (!package_prefix)
2259 pp_string (buffer, "access");
2260 else if (AGGREGATE_TYPE_P (TREE_TYPE (node)))
2261 {
2262 if (!type || TREE_CODE (type) != FUNCTION_DECL)
2263 {
2264 pp_string (buffer, "access ");
2265 is_access = true;
2266
2267 if (quals & TYPE_QUAL_CONST)
2268 pp_string (buffer, "constant ");
2269 else if (!name_only)
2270 pp_string (buffer, "all ");
2271 }
2272 else if (quals & TYPE_QUAL_CONST)
2273 pp_string (buffer, "in ");
2274 else
2275 {
2276 is_access = true;
2277 pp_string (buffer, "access ");
2278 /* ??? should be configurable: access or in out. */
2279 }
2280 }
2281 else
2282 {
2283 is_access = true;
2284 pp_string (buffer, "access ");
2285
2286 if (!name_only)
2287 pp_string (buffer, "all ");
2288 }
2289
2290 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node)) && type_name)
2291 dump_generic_ada_node (buffer, type_name, TREE_TYPE (node),
2292 spc, is_access, true);
2293 else
2294 dump_generic_ada_node (buffer, TREE_TYPE (node),
2295 TREE_TYPE (node), spc, 0, true);
2296 }
2297 }
2298 }
2299 break;
2300
2301 case ARRAY_TYPE:
2302 if (name_only)
2303 dump_generic_ada_node
2304 (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2305 else
2306 dump_ada_array_type (buffer, node, type, spc);
2307 break;
2308
2309 case RECORD_TYPE:
2310 case UNION_TYPE:
2311 if (name_only)
2312 {
2313 if (TYPE_NAME (node))
2314 dump_generic_ada_node
2315 (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2316 else
2317 {
2318 pp_string (buffer, "anon_");
2319 pp_scalar (buffer, "%d", TYPE_UID (node));
2320 }
2321 }
2322 else
2323 print_ada_struct_decl (buffer, node, type, spc, true);
2324 break;
2325
2326 case INTEGER_CST:
2327 /* We treat the upper half of the sizetype range as negative. This
2328 is consistent with the internal treatment and makes it possible
2329 to generate the (0 .. -1) range for flexible array members. */
2330 if (TREE_TYPE (node) == sizetype)
2331 node = fold_convert (ssizetype, node);
2332 if (tree_fits_shwi_p (node))
2333 pp_wide_integer (buffer, tree_to_shwi (node));
2334 else if (tree_fits_uhwi_p (node))
2335 pp_unsigned_wide_integer (buffer, tree_to_uhwi (node));
2336 else
2337 {
2338 wide_int val = node;
2339 int i;
2340 if (wi::neg_p (val))
2341 {
2342 pp_minus (buffer);
2343 val = -val;
2344 }
2345 sprintf (pp_buffer (buffer)->digit_buffer,
2346 "16#%" HOST_WIDE_INT_PRINT "x",
2347 val.elt (val.get_len () - 1));
2348 for (i = val.get_len () - 2; i >= 0; i--)
2349 sprintf (pp_buffer (buffer)->digit_buffer,
2350 HOST_WIDE_INT_PRINT_PADDED_HEX, val.elt (i));
2351 pp_string (buffer, pp_buffer (buffer)->digit_buffer);
2352 }
2353 break;
2354
2355 case REAL_CST:
2356 case FIXED_CST:
2357 case COMPLEX_CST:
2358 case STRING_CST:
2359 case VECTOR_CST:
2360 return 0;
2361
2362 case FUNCTION_DECL:
2363 case CONST_DECL:
2364 dump_ada_decl_name (buffer, node, limited_access);
2365 break;
2366
2367 case TYPE_DECL:
2368 if (DECL_IS_BUILTIN (node))
2369 {
2370 /* Don't print the declaration of built-in types. */
2371
2372 if (name_only)
2373 {
2374 /* If we're in the middle of a declaration, defaults to
2375 System.Address. */
2376 if (package_prefix)
2377 {
2378 append_withs ("System", false);
2379 pp_string (buffer, "System.Address");
2380 }
2381 else
2382 pp_string (buffer, "address");
2383 }
2384 break;
2385 }
2386
2387 if (name_only)
2388 dump_ada_decl_name (buffer, node, limited_access);
2389 else
2390 {
2391 if (is_tagged_type (TREE_TYPE (node)))
2392 {
2393 tree tmp = TYPE_FIELDS (TREE_TYPE (node));
2394 int first = 1;
2395
2396 /* Look for ancestors. */
2397 for (; tmp; tmp = TREE_CHAIN (tmp))
2398 {
2399 if (!DECL_NAME (tmp) && is_tagged_type (TREE_TYPE (tmp)))
2400 {
2401 if (first)
2402 {
2403 pp_string (buffer, "limited new ");
2404 first = 0;
2405 }
2406 else
2407 pp_string (buffer, " and ");
2408
2409 dump_ada_decl_name
2410 (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
2411 }
2412 }
2413
2414 pp_string (buffer, first ? "tagged limited " : " with ");
2415 }
2416 else if (has_nontrivial_methods (TREE_TYPE (node)))
2417 pp_string (buffer, "limited ");
2418
2419 dump_generic_ada_node
2420 (buffer, TREE_TYPE (node), type, spc, false, false);
2421 }
2422 break;
2423
2424 case VAR_DECL:
2425 case PARM_DECL:
2426 case FIELD_DECL:
2427 case NAMESPACE_DECL:
2428 dump_ada_decl_name (buffer, node, false);
2429 break;
2430
2431 default:
2432 /* Ignore other nodes (e.g. expressions). */
2433 return 0;
2434 }
2435
2436 return 1;
2437 }
2438
2439 /* Dump in BUFFER NODE's methods. SPC is the indentation level. Return 1 if
2440 methods were printed, 0 otherwise. */
2441
2442 static int
2443 print_ada_methods (pretty_printer *buffer, tree node, int spc)
2444 {
2445 tree t;
2446 int res;
2447
2448 if (!has_nontrivial_methods (node))
2449 return 0;
2450
2451 pp_semicolon (buffer);
2452
2453 res = 1;
2454 for (t = TYPE_METHODS (node); t; t = TREE_CHAIN (t))
2455 {
2456 if (res)
2457 {
2458 pp_newline (buffer);
2459 pp_newline (buffer);
2460 }
2461
2462 res = print_ada_declaration (buffer, t, node, spc);
2463 }
2464
2465 return 1;
2466 }
2467
2468 static void dump_nested_type (pretty_printer *, tree, tree, tree, int);
2469
2470 /* Dump in BUFFER anonymous types nested inside T's definition.
2471 PARENT is the parent node of T.
2472 FORWARD indicates whether a forward declaration of T should be generated.
2473 SPC is the indentation level.
2474
2475 In C anonymous nested tagged types have no name whereas in C++ they have
2476 one. In C their TYPE_DECL is at top level whereas in C++ it is nested.
2477 In both languages untagged types (pointers and arrays) have no name.
2478 In C++ the nested TYPE_DECLs can come after their associated FIELD_DECL.
2479
2480 Therefore, in order to have a common processing for both languages, we
2481 disregard anonymous TYPE_DECLs at top level and here we make a first
2482 pass on the nested TYPE_DECLs and a second pass on the unnamed types. */
2483
2484 static void
2485 dump_nested_types (pretty_printer *buffer, tree t, tree parent, bool forward,
2486 int spc)
2487 {
2488 tree type, field;
2489
2490 /* Avoid recursing over the same tree. */
2491 if (TREE_VISITED (t))
2492 return;
2493
2494 /* Find possible anonymous pointers/arrays/structs/unions recursively. */
2495 type = TREE_TYPE (t);
2496 if (type == NULL_TREE)
2497 return;
2498
2499 if (forward)
2500 {
2501 pp_string (buffer, "type ");
2502 dump_generic_ada_node (buffer, t, t, spc, false, true);
2503 pp_semicolon (buffer);
2504 newline_and_indent (buffer, spc);
2505 TREE_VISITED (t) = 1;
2506 }
2507
2508 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
2509 if (TREE_CODE (field) == TYPE_DECL
2510 && DECL_NAME (field) != DECL_NAME (t)
2511 && TYPE_NAME (TREE_TYPE (field)) != TYPE_NAME (type))
2512 dump_nested_type (buffer, field, t, parent, spc);
2513
2514 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
2515 if (!TYPE_NAME (TREE_TYPE (field)))
2516 dump_nested_type (buffer, field, t, parent, spc);
2517
2518 TREE_VISITED (t) = 1;
2519 }
2520
2521 /* Dump in BUFFER the anonymous type of FIELD inside T.
2522 PARENT is the parent node of T.
2523 FORWARD indicates whether a forward declaration of T should be generated.
2524 SPC is the indentation level. */
2525
2526 static void
2527 dump_nested_type (pretty_printer *buffer, tree field, tree t, tree parent,
2528 int spc)
2529 {
2530 tree field_type = TREE_TYPE (field);
2531 tree decl, tmp;
2532
2533 switch (TREE_CODE (field_type))
2534 {
2535 case POINTER_TYPE:
2536 tmp = TREE_TYPE (field_type);
2537
2538 if (TREE_CODE (tmp) == FUNCTION_TYPE)
2539 for (tmp = TREE_TYPE (tmp);
2540 tmp && TREE_CODE (tmp) == POINTER_TYPE;
2541 tmp = TREE_TYPE (tmp))
2542 ;
2543
2544 decl = get_underlying_decl (tmp);
2545 if (decl
2546 && !DECL_IS_BUILTIN (decl)
2547 && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl))
2548 || TYPE_FIELDS (TREE_TYPE (decl)))
2549 && !TREE_VISITED (decl)
2550 && DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t)
2551 && decl_sloc (decl, true) > decl_sloc (t, true))
2552 {
2553 /* Generate forward declaration. */
2554 pp_string (buffer, "type ");
2555 dump_generic_ada_node (buffer, decl, 0, spc, false, true);
2556 pp_semicolon (buffer);
2557 newline_and_indent (buffer, spc);
2558 TREE_VISITED (decl) = 1;
2559 }
2560 break;
2561
2562 case ARRAY_TYPE:
2563 tmp = TREE_TYPE (field_type);
2564 while (TREE_CODE (tmp) == ARRAY_TYPE)
2565 tmp = TREE_TYPE (tmp);
2566 decl = get_underlying_decl (tmp);
2567 if (decl && !DECL_NAME (decl) && !TREE_VISITED (decl))
2568 {
2569 /* Generate full declaration. */
2570 dump_nested_type (buffer, decl, t, parent, spc);
2571 TREE_VISITED (decl) = 1;
2572 }
2573
2574 /* Special case char arrays. */
2575 if (is_char_array (field))
2576 pp_string (buffer, "sub");
2577
2578 pp_string (buffer, "type ");
2579 dump_ada_double_name (buffer, parent, field);
2580 pp_string (buffer, " is ");
2581 dump_ada_array_type (buffer, field, parent, spc);
2582 pp_semicolon (buffer);
2583 newline_and_indent (buffer, spc);
2584 break;
2585
2586 case RECORD_TYPE:
2587 case UNION_TYPE:
2588 if (TYPE_NAME (TREE_TYPE (t)) && !TREE_VISITED (t))
2589 {
2590 pp_string (buffer, "type ");
2591 dump_generic_ada_node (buffer, t, parent, spc, false, true);
2592 pp_semicolon (buffer);
2593 newline_and_indent (buffer, spc);
2594 }
2595
2596 TREE_VISITED (t) = 1;
2597 dump_nested_types (buffer, field, t, false, spc);
2598
2599 pp_string (buffer, "type ");
2600
2601 if (TYPE_NAME (field_type))
2602 {
2603 dump_generic_ada_node (buffer, field_type, 0, spc, false, true);
2604 if (TREE_CODE (field_type) == UNION_TYPE)
2605 pp_string (buffer, " (discr : unsigned := 0)");
2606 pp_string (buffer, " is ");
2607 print_ada_struct_decl (buffer, field_type, t, spc, false);
2608
2609 pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2610 dump_generic_ada_node (buffer, field_type, 0, spc, false, true);
2611 pp_string (buffer, ");");
2612 newline_and_indent (buffer, spc);
2613
2614 if (TREE_CODE (field_type) == UNION_TYPE)
2615 {
2616 pp_string (buffer, "pragma Unchecked_Union (");
2617 dump_generic_ada_node (buffer, field_type, 0, spc, false, true);
2618 pp_string (buffer, ");");
2619 }
2620 }
2621 else
2622 {
2623 dump_ada_double_name (buffer, parent, field);
2624 if (TREE_CODE (field_type) == UNION_TYPE)
2625 pp_string (buffer, " (discr : unsigned := 0)");
2626 pp_string (buffer, " is ");
2627 print_ada_struct_decl (buffer, field_type, t, spc, false);
2628
2629 pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2630 dump_ada_double_name (buffer, parent, field);
2631 pp_string (buffer, ");");
2632 newline_and_indent (buffer, spc);
2633
2634 if (TREE_CODE (field_type) == UNION_TYPE)
2635 {
2636 pp_string (buffer, "pragma Unchecked_Union (");
2637 dump_ada_double_name (buffer, parent, field);
2638 pp_string (buffer, ");");
2639 }
2640 }
2641
2642 default:
2643 break;
2644 }
2645 }
2646
2647 /* Dump in BUFFER constructor spec corresponding to T. */
2648
2649 static void
2650 print_constructor (pretty_printer *buffer, tree t)
2651 {
2652 tree decl_name = DECL_NAME (DECL_ORIGIN (t));
2653
2654 pp_string (buffer, "New_");
2655 pp_ada_tree_identifier (buffer, decl_name, t, false);
2656 }
2657
2658 /* Dump in BUFFER destructor spec corresponding to T. */
2659
2660 static void
2661 print_destructor (pretty_printer *buffer, tree t)
2662 {
2663 tree decl_name = DECL_NAME (DECL_ORIGIN (t));
2664
2665 pp_string (buffer, "Delete_");
2666 pp_ada_tree_identifier (buffer, decl_name, t, false);
2667 }
2668
2669 /* Return the name of type T. */
2670
2671 static const char *
2672 type_name (tree t)
2673 {
2674 tree n = TYPE_NAME (t);
2675
2676 if (TREE_CODE (n) == IDENTIFIER_NODE)
2677 return IDENTIFIER_POINTER (n);
2678 else
2679 return IDENTIFIER_POINTER (DECL_NAME (n));
2680 }
2681
2682 /* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
2683 SPC is the indentation level. Return 1 if a declaration was printed,
2684 0 otherwise. */
2685
2686 static int
2687 print_ada_declaration (pretty_printer *buffer, tree t, tree type, int spc)
2688 {
2689 int is_var = 0, need_indent = 0;
2690 int is_class = false;
2691 tree name = TYPE_NAME (TREE_TYPE (t));
2692 tree decl_name = DECL_NAME (t);
2693 tree orig = NULL_TREE;
2694
2695 if (cpp_check && cpp_check (t, IS_TEMPLATE))
2696 return dump_ada_template (buffer, t, spc);
2697
2698 if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2699 /* Skip enumeral values: will be handled as part of the type itself. */
2700 return 0;
2701
2702 if (TREE_CODE (t) == TYPE_DECL)
2703 {
2704 orig = DECL_ORIGINAL_TYPE (t);
2705
2706 if (orig && TYPE_STUB_DECL (orig))
2707 {
2708 tree stub = TYPE_STUB_DECL (orig);
2709 tree typ = TREE_TYPE (stub);
2710
2711 if (TYPE_NAME (typ))
2712 {
2713 /* If types have same representation, and same name (ignoring
2714 casing), then ignore the second type. */
2715 if (type_name (typ) == type_name (TREE_TYPE (t))
2716 || !strcasecmp (type_name (typ), type_name (TREE_TYPE (t))))
2717 {
2718 TREE_VISITED (t) = 1;
2719 return 0;
2720 }
2721
2722 INDENT (spc);
2723
2724 if (RECORD_OR_UNION_TYPE_P (typ) && !TYPE_FIELDS (typ))
2725 {
2726 pp_string (buffer, "-- skipped empty struct ");
2727 dump_generic_ada_node (buffer, t, type, spc, false, true);
2728 }
2729 else
2730 {
2731 if (RECORD_OR_UNION_TYPE_P (typ)
2732 && DECL_SOURCE_FILE (stub) == source_file_base)
2733 dump_nested_types (buffer, stub, stub, true, spc);
2734
2735 pp_string (buffer, "subtype ");
2736 dump_generic_ada_node (buffer, t, type, spc, false, true);
2737 pp_string (buffer, " is ");
2738 dump_generic_ada_node (buffer, typ, type, spc, false, true);
2739 pp_string (buffer, "; -- ");
2740 dump_sloc (buffer, t);
2741 }
2742
2743 TREE_VISITED (t) = 1;
2744 return 1;
2745 }
2746 }
2747
2748 /* Skip unnamed or anonymous structs/unions/enum types. */
2749 if (!orig && !decl_name && !name
2750 && (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))
2751 || TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE))
2752 return 0;
2753
2754 /* Skip anonymous enum types (duplicates of real types). */
2755 if (!orig
2756 && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE
2757 && decl_name
2758 && (*IDENTIFIER_POINTER (decl_name) == '.'
2759 || *IDENTIFIER_POINTER (decl_name) == '$'))
2760 return 0;
2761
2762 INDENT (spc);
2763
2764 switch (TREE_CODE (TREE_TYPE (t)))
2765 {
2766 case RECORD_TYPE:
2767 case UNION_TYPE:
2768 /* Skip empty structs (typically forward references to real
2769 structs). */
2770 if (!TYPE_FIELDS (TREE_TYPE (t)))
2771 {
2772 pp_string (buffer, "-- skipped empty struct ");
2773 dump_generic_ada_node (buffer, t, type, spc, false, true);
2774 return 1;
2775 }
2776
2777 if (decl_name
2778 && (*IDENTIFIER_POINTER (decl_name) == '.'
2779 || *IDENTIFIER_POINTER (decl_name) == '$'))
2780 {
2781 pp_string (buffer, "-- skipped anonymous struct ");
2782 dump_generic_ada_node (buffer, t, type, spc, false, true);
2783 TREE_VISITED (t) = 1;
2784 return 1;
2785 }
2786
2787 if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2788 pp_string (buffer, "subtype ");
2789 else
2790 {
2791 dump_nested_types (buffer, t, t, false, spc);
2792
2793 if (separate_class_package (t))
2794 {
2795 is_class = true;
2796 pp_string (buffer, "package Class_");
2797 dump_generic_ada_node (buffer, t, type, spc, false, true);
2798 pp_string (buffer, " is");
2799 spc += INDENT_INCR;
2800 newline_and_indent (buffer, spc);
2801 }
2802
2803 pp_string (buffer, "type ");
2804 }
2805 break;
2806
2807 case ARRAY_TYPE:
2808 case POINTER_TYPE:
2809 case REFERENCE_TYPE:
2810 if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2811 || is_char_array (t))
2812 pp_string (buffer, "subtype ");
2813 else
2814 pp_string (buffer, "type ");
2815 break;
2816
2817 case FUNCTION_TYPE:
2818 pp_string (buffer, "-- skipped function type ");
2819 dump_generic_ada_node (buffer, t, type, spc, false, true);
2820 return 1;
2821
2822 case ENUMERAL_TYPE:
2823 if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2824 || !is_simple_enum (TREE_TYPE (t)))
2825 pp_string (buffer, "subtype ");
2826 else
2827 pp_string (buffer, "type ");
2828 break;
2829
2830 default:
2831 pp_string (buffer, "subtype ");
2832 }
2833 TREE_VISITED (t) = 1;
2834 }
2835 else
2836 {
2837 if (VAR_P (t)
2838 && decl_name
2839 && *IDENTIFIER_POINTER (decl_name) == '_')
2840 return 0;
2841
2842 need_indent = 1;
2843 }
2844
2845 /* Print the type and name. */
2846 if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
2847 {
2848 if (need_indent)
2849 INDENT (spc);
2850
2851 /* Print variable's name. */
2852 dump_generic_ada_node (buffer, t, type, spc, false, true);
2853
2854 if (TREE_CODE (t) == TYPE_DECL)
2855 {
2856 pp_string (buffer, " is ");
2857
2858 if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2859 dump_generic_ada_node
2860 (buffer, TYPE_NAME (orig), type, spc, false, true);
2861 else
2862 dump_ada_array_type (buffer, t, type, spc);
2863 }
2864 else
2865 {
2866 tree tmp = TYPE_NAME (TREE_TYPE (t));
2867
2868 if (spc == INDENT_INCR || TREE_STATIC (t))
2869 is_var = 1;
2870
2871 pp_string (buffer, " : ");
2872
2873 if (TREE_CODE (TREE_TYPE (TREE_TYPE (t))) != POINTER_TYPE)
2874 pp_string (buffer, "aliased ");
2875
2876 if (tmp)
2877 dump_generic_ada_node (buffer, tmp, type, spc, false, true);
2878 else if (type)
2879 dump_ada_double_name (buffer, type, t);
2880 else
2881 dump_ada_array_type (buffer, t, type, spc);
2882 }
2883 }
2884 else if (TREE_CODE (t) == FUNCTION_DECL)
2885 {
2886 bool is_function, is_abstract_class = false;
2887 bool is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE;
2888 tree decl_name = DECL_NAME (t);
2889 bool is_abstract = false;
2890 bool is_constructor = false;
2891 bool is_destructor = false;
2892 bool is_copy_constructor = false;
2893 bool is_move_constructor = false;
2894
2895 if (!decl_name)
2896 return 0;
2897
2898 if (cpp_check)
2899 {
2900 is_abstract = cpp_check (t, IS_ABSTRACT);
2901 is_constructor = cpp_check (t, IS_CONSTRUCTOR);
2902 is_destructor = cpp_check (t, IS_DESTRUCTOR);
2903 is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR);
2904 is_move_constructor = cpp_check (t, IS_MOVE_CONSTRUCTOR);
2905 }
2906
2907 /* Skip copy constructors and C++11 move constructors: some are internal
2908 only and those that are not cannot be called easily from Ada. */
2909 if (is_copy_constructor || is_move_constructor)
2910 return 0;
2911
2912 if (is_constructor || is_destructor)
2913 {
2914 /* ??? Skip implicit constructors/destructors for now. */
2915 if (DECL_ARTIFICIAL (t))
2916 return 0;
2917
2918 /* Only consider constructors/destructors for complete objects. */
2919 if (strncmp (IDENTIFIER_POINTER (decl_name), "__comp", 6) != 0)
2920 return 0;
2921 }
2922
2923 /* If this function has an entry in the vtable, we cannot omit it. */
2924 else if (!DECL_VINDEX (t) && *IDENTIFIER_POINTER (decl_name) == '_')
2925 {
2926 INDENT (spc);
2927 pp_string (buffer, "-- skipped func ");
2928 pp_string (buffer, IDENTIFIER_POINTER (decl_name));
2929 return 1;
2930 }
2931
2932 if (need_indent)
2933 INDENT (spc);
2934
2935 if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))) && !is_constructor)
2936 {
2937 pp_string (buffer, "procedure ");
2938 is_function = false;
2939 }
2940 else
2941 {
2942 pp_string (buffer, "function ");
2943 is_function = true;
2944 }
2945
2946 if (is_constructor)
2947 print_constructor (buffer, t);
2948 else if (is_destructor)
2949 print_destructor (buffer, t);
2950 else
2951 dump_ada_decl_name (buffer, t, false);
2952
2953 dump_ada_function_declaration
2954 (buffer, t, is_method, is_constructor, is_destructor, spc);
2955
2956 if (is_function)
2957 {
2958 pp_string (buffer, " return ");
2959 tree ret_type
2960 = is_constructor ? DECL_CONTEXT (t) : TREE_TYPE (TREE_TYPE (t));
2961 dump_generic_ada_node (buffer, ret_type, type, spc, false, true);
2962 }
2963
2964 if (is_constructor
2965 && RECORD_OR_UNION_TYPE_P (type)
2966 && TYPE_METHODS (type))
2967 {
2968 tree tmp;
2969
2970 for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp))
2971 if (cpp_check (tmp, IS_ABSTRACT))
2972 {
2973 is_abstract_class = true;
2974 break;
2975 }
2976 }
2977
2978 if (is_abstract || is_abstract_class)
2979 pp_string (buffer, " is abstract");
2980
2981 pp_semicolon (buffer);
2982 pp_string (buffer, " -- ");
2983 dump_sloc (buffer, t);
2984
2985 if (is_abstract || !DECL_ASSEMBLER_NAME (t))
2986 return 1;
2987
2988 newline_and_indent (buffer, spc);
2989
2990 if (is_constructor)
2991 {
2992 pp_string (buffer, "pragma CPP_Constructor (");
2993 print_constructor (buffer, t);
2994 pp_string (buffer, ", \"");
2995 pp_asm_name (buffer, t);
2996 pp_string (buffer, "\");");
2997 }
2998 else if (is_destructor)
2999 {
3000 pp_string (buffer, "pragma Import (CPP, ");
3001 print_destructor (buffer, t);
3002 pp_string (buffer, ", \"");
3003 pp_asm_name (buffer, t);
3004 pp_string (buffer, "\");");
3005 }
3006 else
3007 {
3008 dump_ada_import (buffer, t);
3009 }
3010
3011 return 1;
3012 }
3013 else if (TREE_CODE (t) == TYPE_DECL && !DECL_ORIGINAL_TYPE (t))
3014 {
3015 int is_interface = 0;
3016 int is_abstract_record = 0;
3017
3018 if (need_indent)
3019 INDENT (spc);
3020
3021 /* Anonymous structs/unions */
3022 dump_generic_ada_node (buffer, TREE_TYPE (t), t, spc, false, true);
3023
3024 if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE)
3025 {
3026 pp_string (buffer, " (discr : unsigned := 0)");
3027 }
3028
3029 pp_string (buffer, " is ");
3030
3031 /* Check whether we have an Ada interface compatible class. */
3032 if (cpp_check
3033 && RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))
3034 && TYPE_METHODS (TREE_TYPE (t)))
3035 {
3036 int num_fields = 0;
3037 tree tmp;
3038
3039 /* Check that there are no fields other than the virtual table. */
3040 for (tmp = TYPE_FIELDS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
3041 {
3042 if (TREE_CODE (tmp) == TYPE_DECL)
3043 continue;
3044 num_fields++;
3045 }
3046
3047 if (num_fields == 1)
3048 is_interface = 1;
3049
3050 /* Also check that there are only pure virtual methods. Since the
3051 class is empty, we can skip implicit constructors/destructors. */
3052 for (tmp = TYPE_METHODS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
3053 {
3054 if (DECL_ARTIFICIAL (tmp))
3055 continue;
3056 if (cpp_check (tmp, IS_ABSTRACT))
3057 is_abstract_record = 1;
3058 else
3059 is_interface = 0;
3060 }
3061 }
3062
3063 TREE_VISITED (t) = 1;
3064 if (is_interface)
3065 {
3066 pp_string (buffer, "limited interface; -- ");
3067 dump_sloc (buffer, t);
3068 newline_and_indent (buffer, spc);
3069 pp_string (buffer, "pragma Import (CPP, ");
3070 dump_generic_ada_node
3071 (buffer, TYPE_NAME (TREE_TYPE (t)), type, spc, false, true);
3072 pp_right_paren (buffer);
3073
3074 print_ada_methods (buffer, TREE_TYPE (t), spc);
3075 }
3076 else
3077 {
3078 if (is_abstract_record)
3079 pp_string (buffer, "abstract ");
3080 dump_generic_ada_node (buffer, t, t, spc, false, false);
3081 }
3082 }
3083 else
3084 {
3085 if (need_indent)
3086 INDENT (spc);
3087
3088 if (TREE_CODE (t) == FIELD_DECL && DECL_NAME (t))
3089 check_name (buffer, t);
3090
3091 /* Print variable/type's name. */
3092 dump_generic_ada_node (buffer, t, t, spc, false, true);
3093
3094 if (TREE_CODE (t) == TYPE_DECL)
3095 {
3096 tree orig = DECL_ORIGINAL_TYPE (t);
3097 int is_subtype = orig && TYPE_NAME (orig) && orig != TREE_TYPE (t);
3098
3099 if (!is_subtype && TREE_CODE (TREE_TYPE (t)) == UNION_TYPE)
3100 pp_string (buffer, " (discr : unsigned := 0)");
3101
3102 pp_string (buffer, " is ");
3103
3104 dump_generic_ada_node (buffer, orig, t, spc, false, is_subtype);
3105 }
3106 else
3107 {
3108 if (spc == INDENT_INCR || TREE_STATIC (t))
3109 is_var = 1;
3110
3111 pp_string (buffer, " : ");
3112
3113 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
3114 {
3115 pp_string (buffer, "aliased ");
3116
3117 if (TYPE_NAME (TREE_TYPE (t)))
3118 dump_generic_ada_node
3119 (buffer, TREE_TYPE (t), t, spc, false, true);
3120 else
3121 dump_ada_double_name (buffer, type, t);
3122 }
3123 else
3124 {
3125 if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE
3126 && (TYPE_NAME (TREE_TYPE (t))
3127 || TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE))
3128 pp_string (buffer, "aliased ");
3129
3130 dump_generic_ada_node
3131 (buffer, TREE_TYPE (t), TREE_TYPE (t), spc, false, true);
3132 }
3133 }
3134 }
3135
3136 if (is_class)
3137 {
3138 spc -= INDENT_INCR;
3139 newline_and_indent (buffer, spc);
3140 pp_string (buffer, "end;");
3141 newline_and_indent (buffer, spc);
3142 pp_string (buffer, "use Class_");
3143 dump_generic_ada_node (buffer, t, type, spc, false, true);
3144 pp_semicolon (buffer);
3145 pp_newline (buffer);
3146
3147 /* All needed indentation/newline performed already, so return 0. */
3148 return 0;
3149 }
3150 else
3151 {
3152 pp_string (buffer, "; -- ");
3153 dump_sloc (buffer, t);
3154 }
3155
3156 if (is_var)
3157 {
3158 newline_and_indent (buffer, spc);
3159 dump_ada_import (buffer, t);
3160 }
3161
3162 return 1;
3163 }
3164
3165 /* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
3166 with Ada syntax. SPC is the indentation level. If DISPLAY_CONVENTION is
3167 true, also print the pragma Convention for NODE. */
3168
3169 static void
3170 print_ada_struct_decl (pretty_printer *buffer, tree node, tree type, int spc,
3171 bool display_convention)
3172 {
3173 tree tmp;
3174 const bool is_union = (TREE_CODE (node) == UNION_TYPE);
3175 char buf[32];
3176 int field_num = 0;
3177 int field_spc = spc + INDENT_INCR;
3178 int need_semicolon;
3179
3180 bitfield_used = false;
3181
3182 if (TYPE_FIELDS (node))
3183 {
3184 /* Print the contents of the structure. */
3185 pp_string (buffer, "record");
3186
3187 if (is_union)
3188 {
3189 newline_and_indent (buffer, spc + INDENT_INCR);
3190 pp_string (buffer, "case discr is");
3191 field_spc = spc + INDENT_INCR * 3;
3192 }
3193
3194 pp_newline (buffer);
3195
3196 /* Print the non-static fields of the structure. */
3197 for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3198 {
3199 /* Add parent field if needed. */
3200 if (!DECL_NAME (tmp))
3201 {
3202 if (!is_tagged_type (TREE_TYPE (tmp)))
3203 {
3204 if (!TYPE_NAME (TREE_TYPE (tmp)))
3205 print_ada_declaration (buffer, tmp, type, field_spc);
3206 else
3207 {
3208 INDENT (field_spc);
3209
3210 if (field_num == 0)
3211 pp_string (buffer, "parent : aliased ");
3212 else
3213 {
3214 sprintf (buf, "field_%d : aliased ", field_num + 1);
3215 pp_string (buffer, buf);
3216 }
3217 dump_ada_decl_name
3218 (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
3219 pp_semicolon (buffer);
3220 }
3221 pp_newline (buffer);
3222 field_num++;
3223 }
3224 }
3225 else if (TREE_CODE (tmp) != TYPE_DECL && !TREE_STATIC (tmp))
3226 {
3227 /* Skip internal virtual table field. */
3228 if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp)), "_vptr", 5))
3229 {
3230 if (is_union)
3231 {
3232 if (TREE_CHAIN (tmp)
3233 && TREE_TYPE (TREE_CHAIN (tmp)) != node
3234 && TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL)
3235 sprintf (buf, "when %d =>", field_num);
3236 else
3237 sprintf (buf, "when others =>");
3238
3239 INDENT (spc + INDENT_INCR * 2);
3240 pp_string (buffer, buf);
3241 pp_newline (buffer);
3242 }
3243
3244 if (print_ada_declaration (buffer, tmp, type, field_spc))
3245 {
3246 pp_newline (buffer);
3247 field_num++;
3248 }
3249 }
3250 }
3251 }
3252
3253 if (is_union)
3254 {
3255 INDENT (spc + INDENT_INCR);
3256 pp_string (buffer, "end case;");
3257 pp_newline (buffer);
3258 }
3259
3260 if (field_num == 0)
3261 {
3262 INDENT (spc + INDENT_INCR);
3263 pp_string (buffer, "null;");
3264 pp_newline (buffer);
3265 }
3266
3267 INDENT (spc);
3268 pp_string (buffer, "end record;");
3269 }
3270 else
3271 pp_string (buffer, "null record;");
3272
3273 newline_and_indent (buffer, spc);
3274
3275 if (!display_convention)
3276 return;
3277
3278 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type)))
3279 {
3280 if (has_nontrivial_methods (TREE_TYPE (type)))
3281 pp_string (buffer, "pragma Import (CPP, ");
3282 else
3283 pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
3284 }
3285 else
3286 pp_string (buffer, "pragma Convention (C, ");
3287
3288 package_prefix = false;
3289 dump_generic_ada_node (buffer, TREE_TYPE (type), type, spc, false, true);
3290 package_prefix = true;
3291 pp_right_paren (buffer);
3292
3293 if (is_union)
3294 {
3295 pp_semicolon (buffer);
3296 newline_and_indent (buffer, spc);
3297 pp_string (buffer, "pragma Unchecked_Union (");
3298
3299 dump_generic_ada_node (buffer, TREE_TYPE (type), type, spc, false, true);
3300 pp_right_paren (buffer);
3301 }
3302
3303 if (bitfield_used)
3304 {
3305 pp_semicolon (buffer);
3306 newline_and_indent (buffer, spc);
3307 pp_string (buffer, "pragma Pack (");
3308 dump_generic_ada_node
3309 (buffer, TREE_TYPE (type), type, spc, false, true);
3310 pp_right_paren (buffer);
3311 bitfield_used = false;
3312 }
3313
3314 need_semicolon = !print_ada_methods (buffer, node, spc);
3315
3316 /* Print the static fields of the structure, if any. */
3317 for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3318 {
3319 if (DECL_NAME (tmp) && TREE_STATIC (tmp))
3320 {
3321 if (need_semicolon)
3322 {
3323 need_semicolon = false;
3324 pp_semicolon (buffer);
3325 }
3326 pp_newline (buffer);
3327 pp_newline (buffer);
3328 print_ada_declaration (buffer, tmp, type, spc);
3329 }
3330 }
3331 }
3332
3333 /* Dump all the declarations in SOURCE_FILE to an Ada spec.
3334 COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3335 nodes for SOURCE_FILE. CHECK is used to perform C++ queries on nodes. */
3336
3337 static void
3338 dump_ads (const char *source_file,
3339 void (*collect_all_refs)(const char *),
3340 int (*check)(tree, cpp_operation))
3341 {
3342 char *ads_name;
3343 char *pkg_name;
3344 char *s;
3345 FILE *f;
3346
3347 pkg_name = get_ada_package (source_file);
3348
3349 /* Construct the .ads filename and package name. */
3350 ads_name = xstrdup (pkg_name);
3351
3352 for (s = ads_name; *s; s++)
3353 if (*s == '.')
3354 *s = '-';
3355 else
3356 *s = TOLOWER (*s);
3357
3358 ads_name = reconcat (ads_name, ads_name, ".ads", NULL);
3359
3360 /* Write out the .ads file. */
3361 f = fopen (ads_name, "w");
3362 if (f)
3363 {
3364 pretty_printer pp;
3365
3366 pp_needs_newline (&pp) = true;
3367 pp.buffer->stream = f;
3368
3369 /* Dump all relevant macros. */
3370 dump_ada_macros (&pp, source_file);
3371
3372 /* Reset the table of withs for this file. */
3373 reset_ada_withs ();
3374
3375 (*collect_all_refs) (source_file);
3376
3377 /* Dump all references. */
3378 cpp_check = check;
3379 dump_ada_nodes (&pp, source_file);
3380
3381 /* Requires Ada 2005 syntax, so generate corresponding pragma.
3382 Also, disable style checks since this file is auto-generated. */
3383 fprintf (f, "pragma Ada_2005;\npragma Style_Checks (Off);\n\n");
3384
3385 /* Dump withs. */
3386 dump_ada_withs (f);
3387
3388 fprintf (f, "\npackage %s is\n\n", pkg_name);
3389 pp_write_text_to_stream (&pp);
3390 /* ??? need to free pp */
3391 fprintf (f, "end %s;\n", pkg_name);
3392 fclose (f);
3393 }
3394
3395 free (ads_name);
3396 free (pkg_name);
3397 }
3398
3399 static const char **source_refs = NULL;
3400 static int source_refs_used = 0;
3401 static int source_refs_allocd = 0;
3402
3403 /* Add an entry for FILENAME to the table SOURCE_REFS. */
3404
3405 void
3406 collect_source_ref (const char *filename)
3407 {
3408 int i;
3409
3410 if (!filename)
3411 return;
3412
3413 if (source_refs_allocd == 0)
3414 {
3415 source_refs_allocd = 1024;
3416 source_refs = XNEWVEC (const char *, source_refs_allocd);
3417 }
3418
3419 for (i = 0; i < source_refs_used; i++)
3420 if (filename == source_refs[i])
3421 return;
3422
3423 if (source_refs_used == source_refs_allocd)
3424 {
3425 source_refs_allocd *= 2;
3426 source_refs = XRESIZEVEC (const char *, source_refs, source_refs_allocd);
3427 }
3428
3429 source_refs[source_refs_used++] = filename;
3430 }
3431
3432 /* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
3433 using callbacks COLLECT_ALL_REFS and CHECK.
3434 COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3435 nodes for a given source file.
3436 CHECK is used to perform C++ queries on nodes, or NULL for the C
3437 front-end. */
3438
3439 void
3440 dump_ada_specs (void (*collect_all_refs)(const char *),
3441 int (*check)(tree, cpp_operation))
3442 {
3443 int i;
3444
3445 /* Iterate over the list of files to dump specs for */
3446 for (i = 0; i < source_refs_used; i++)
3447 dump_ads (source_refs[i], collect_all_refs, check);
3448
3449 /* Free files table. */
3450 free (source_refs);
3451 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org