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