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