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