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