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