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