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