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