1 /* Print GENERIC declaration (functions, variables, types) trees coming from
2 the C and C++ front-ends as well as macros in Ada syntax.
3 Copyright (C) 2010-2015 Free Software Foundation, Inc.
4 Adapted from tree-pretty-print.c by Arnaud Charlet <charlet@adacore.com>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
24 #include "coretypes.h"
29 #include "double-int.h"
37 #include "fold-const.h"
39 #include "c-ada-spec.h"
42 #include "cpp-id-data.h"
45 /* Local functions, macros and variables. */
46 static int dump_generic_ada_node (pretty_printer
*, tree
, tree
, int, int,
48 static int print_ada_declaration (pretty_printer
*, tree
, tree
, int);
49 static void print_ada_struct_decl (pretty_printer
*, tree
, tree
, int, bool);
50 static void dump_sloc (pretty_printer
*buffer
, tree node
);
51 static void print_comment (pretty_printer
*, const char *);
52 static void print_generic_ada_decl (pretty_printer
*, tree
, const char *);
53 static char *get_ada_package (const char *);
54 static void dump_ada_nodes (pretty_printer
*, const char *);
55 static void reset_ada_withs (void);
56 static void dump_ada_withs (FILE *);
57 static void dump_ads (const char *, void (*)(const char *),
58 int (*)(tree
, cpp_operation
));
59 static char *to_ada_name (const char *, int *);
60 static bool separate_class_package (tree
);
62 #define INDENT(SPACE) \
63 do { int i; for (i = 0; i<SPACE; i++) pp_space (buffer); } while (0)
67 /* Global hook used to perform C++ queries on nodes. */
68 static int (*cpp_check
) (tree
, cpp_operation
) = NULL
;
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. */
76 macro_length (const cpp_macro
*macro
, int *supported
, int *buffer_len
,
89 for (i
= 0; i
< macro
->paramc
; i
++)
91 cpp_hashnode
*param
= macro
->params
[i
];
93 *param_len
+= NODE_LEN (param
);
95 if (i
+ 1 < macro
->paramc
)
97 *param_len
+= 2; /* ", " */
99 else if (macro
->variadic
)
105 *param_len
+= 2; /* ")\0" */
108 for (j
= 0; j
< macro
->count
; j
++)
110 cpp_token
*token
= ¯o
->exp
.tokens
[j
];
112 if (token
->flags
& PREV_WHITE
)
115 if (token
->flags
& STRINGIFY_ARG
|| token
->flags
& PASTE_LEFT
)
121 if (token
->type
== CPP_MACRO_ARG
)
123 NODE_LEN (macro
->params
[token
->val
.macro_arg
.arg_no
- 1]);
125 /* Include enough extra space to handle e.g. special characters. */
126 *buffer_len
+= (cpp_token_len (token
) + 1) * 8;
132 /* Dump into PP a set of MAX_ADA_MACROS MACROS (C/C++) as Ada constants when
136 print_ada_macros (pretty_printer
*pp
, cpp_hashnode
**macros
, int max_ada_macros
)
138 int j
, num_macros
= 0, prev_line
= -1;
140 for (j
= 0; j
< max_ada_macros
; j
++)
142 cpp_hashnode
*node
= macros
[j
];
143 const cpp_macro
*macro
= node
->value
.macro
;
145 int supported
= 1, prev_is_one
= 0, buffer_len
, param_len
;
146 int is_string
= 0, is_char
= 0;
148 unsigned char *s
, *params
, *buffer
, *buf_param
, *char_one
= NULL
;
150 macro_length (macro
, &supported
, &buffer_len
, ¶m_len
);
151 s
= buffer
= XALLOCAVEC (unsigned char, buffer_len
);
152 params
= buf_param
= XALLOCAVEC (unsigned char, param_len
);
159 for (i
= 0; i
< macro
->paramc
; i
++)
161 cpp_hashnode
*param
= macro
->params
[i
];
163 memcpy (buf_param
, NODE_NAME (param
), NODE_LEN (param
));
164 buf_param
+= NODE_LEN (param
);
166 if (i
+ 1 < macro
->paramc
)
171 else if (macro
->variadic
)
181 for (i
= 0; supported
&& i
< macro
->count
; i
++)
183 cpp_token
*token
= ¯o
->exp
.tokens
[i
];
186 if (token
->flags
& PREV_WHITE
)
189 if (token
->flags
& STRINGIFY_ARG
|| token
->flags
& PASTE_LEFT
)
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
);
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;
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;
228 *buffer
++ = 'n'; *buffer
++ = 'o'; *buffer
++ = 't'; break;
230 *buffer
++ = 'm'; *buffer
++ = 'o'; *buffer
++ = 'd'; break;
232 *buffer
++ = 'a'; *buffer
++ = 'n'; *buffer
++ = 'd'; break;
234 *buffer
++ = 'o'; *buffer
++ = 'r'; break;
236 *buffer
++ = 'x'; *buffer
++ = 'o'; *buffer
++ = 'r'; break;
238 strcpy ((char *) buffer
, " and then ");
242 strcpy ((char *) buffer
, " or else ");
248 is_one
= prev_is_one
;
251 case CPP_COMMENT
: break;
263 if (!macro
->fun_like
)
266 buffer
= cpp_spell_token (parse_in
, token
, buffer
, false);
276 c
= cpp_interpret_charconst (parse_in
, token
,
277 &chars_seen
, &ignored
);
278 if (c
>= 32 && c
<= 126)
281 *buffer
++ = (char) c
;
287 ((char *) buffer
, "Character'Val (%d)", (int) c
);
288 buffer
+= chars_seen
;
296 /* Replace "1 << N" by "2 ** N" */
323 case CPP_CLOSE_BRACE
:
327 case CPP_MINUS_MINUS
:
331 case CPP_HEADER_NAME
:
334 case CPP_OBJC_STRING
:
336 if (!macro
->fun_like
)
339 buffer
= cpp_spell_token (parse_in
, token
, buffer
, false);
343 prev_is_one
= is_one
;
350 if (macro
->fun_like
&& supported
)
352 char *start
= (char *) s
;
355 pp_string (pp
, " -- arg-macro: ");
357 if (*start
== '(' && buffer
[-1] == ')')
362 pp_string (pp
, "function ");
366 pp_string (pp
, "procedure ");
369 pp_string (pp
, (const char *) NODE_NAME (node
));
371 pp_string (pp
, (char *) params
);
373 pp_string (pp
, " -- ");
377 pp_string (pp
, "return ");
378 pp_string (pp
, start
);
382 pp_string (pp
, start
);
388 expanded_location sloc
= expand_location (macro
->line
);
390 if (sloc
.line
!= prev_line
+ 1)
394 prev_line
= sloc
.line
;
397 ada_name
= to_ada_name ((const char *) NODE_NAME (node
), NULL
);
398 pp_string (pp
, ada_name
);
400 pp_string (pp
, " : ");
403 pp_string (pp
, "aliased constant String");
405 pp_string (pp
, "aliased constant Character");
407 pp_string (pp
, "constant");
409 pp_string (pp
, " := ");
410 pp_string (pp
, (char *) s
);
413 pp_string (pp
, " & ASCII.NUL");
415 pp_string (pp
, "; -- ");
416 pp_string (pp
, sloc
.file
);
418 pp_scalar (pp
, "%d", sloc
.line
);
423 pp_string (pp
, " -- unsupported macro: ");
424 pp_string (pp
, (const char *) cpp_macro_definition (parse_in
, node
));
433 static const char *source_file
;
434 static int max_ada_macros
;
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
441 count_ada_macro (cpp_reader
*pfile ATTRIBUTE_UNUSED
, cpp_hashnode
*node
,
442 void *v ATTRIBUTE_UNUSED
)
444 const cpp_macro
*macro
= node
->value
.macro
;
446 if (node
->type
== NT_MACRO
&& !(node
->flags
& NODE_BUILTIN
)
448 && *NODE_NAME (node
) != '_'
449 && LOCATION_FILE (macro
->line
) == source_file
)
455 static int store_ada_macro_index
;
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. */
462 store_ada_macro (cpp_reader
*pfile ATTRIBUTE_UNUSED
,
463 cpp_hashnode
*node
, void *macros
)
465 const cpp_macro
*macro
= node
->value
.macro
;
467 if (node
->type
== NT_MACRO
&& !(node
->flags
& NODE_BUILTIN
)
469 && *NODE_NAME (node
) != '_'
470 && LOCATION_FILE (macro
->line
) == source_file
)
471 ((cpp_hashnode
**) macros
)[store_ada_macro_index
++] = node
;
476 /* Callback used to compare (during qsort) macros. NODE1 and NODE2 are the
477 two macro nodes to compare. */
480 compare_macro (const void *node1
, const void *node2
)
482 typedef const cpp_hashnode
*const_hnode
;
484 const_hnode n1
= *(const const_hnode
*) node1
;
485 const_hnode n2
= *(const const_hnode
*) node2
;
487 return n1
->value
.macro
->line
- n2
->value
.macro
->line
;
490 /* Dump in PP all relevant macros appearing in FILE. */
493 dump_ada_macros (pretty_printer
*pp
, const char* file
)
495 cpp_hashnode
**macros
;
497 /* Initialize file-scope variables. */
499 store_ada_macro_index
= 0;
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
);
508 print_ada_macros (pp
, macros
, max_ada_macros
);
511 /* Current source file being handled. */
513 static const char *source_file_base
;
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
518 If ORIG_TYPE is true, also consider struct with a DECL_ORIGINAL_TYPE. */
521 decl_sloc_common (const_tree decl
, bool last
, bool orig_type
)
523 tree type
= TREE_TYPE (decl
);
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
))
530 tree f
= TYPE_FIELDS (type
);
533 while (TREE_CHAIN (f
))
536 return DECL_SOURCE_LOCATION (f
);
539 return DECL_SOURCE_LOCATION (decl
);
542 /* Return sloc of DECL, using sloc of last field if LAST is true. */
545 decl_sloc (const_tree decl
, bool last
)
547 return decl_sloc_common (decl
, last
, false);
550 /* Compare two locations LHS and RHS. */
553 compare_location (location_t lhs
, location_t rhs
)
555 expanded_location xlhs
= expand_location (lhs
);
556 expanded_location xrhs
= expand_location (rhs
);
558 if (xlhs
.file
!= xrhs
.file
)
559 return filename_cmp (xlhs
.file
, xrhs
.file
);
561 if (xlhs
.line
!= xrhs
.line
)
562 return xlhs
.line
- xrhs
.line
;
564 if (xlhs
.column
!= xrhs
.column
)
565 return xlhs
.column
- xrhs
.column
;
570 /* Compare two declarations (LP and RP) by their source location. */
573 compare_node (const void *lp
, const void *rp
)
575 const_tree lhs
= *((const tree
*) lp
);
576 const_tree rhs
= *((const tree
*) rp
);
578 return compare_location (decl_sloc (lhs
, true), decl_sloc (rhs
, true));
581 /* Compare two comments (LP and RP) by their source location. */
584 compare_comment (const void *lp
, const void *rp
)
586 const cpp_comment
*lhs
= (const cpp_comment
*) lp
;
587 const cpp_comment
*rhs
= (const cpp_comment
*) rp
;
589 return compare_location (lhs
->sloc
, rhs
->sloc
);
592 static tree
*to_dump
= NULL
;
593 static int to_dump_count
= 0;
595 /* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped
596 by a subsequent call to dump_ada_nodes. */
599 collect_ada_nodes (tree t
, const char *source_file
)
602 int i
= to_dump_count
;
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
)
610 /* Allocate sufficient storage for all nodes. */
611 to_dump
= XRESIZEVEC (tree
, to_dump
, to_dump_count
);
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
)
620 /* Call back for walk_tree to clear the TREE_VISITED flag of TP. */
623 unmark_visited_r (tree
*tp
, int *walk_subtrees ATTRIBUTE_UNUSED
,
624 void *data ATTRIBUTE_UNUSED
)
626 if (TREE_VISITED (*tp
))
627 TREE_VISITED (*tp
) = 0;
634 /* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls
635 to collect_ada_nodes. */
638 dump_ada_nodes (pretty_printer
*pp
, const char *source_file
)
641 cpp_comment_table
*comments
;
643 /* Sort the table of declarations to dump by sloc. */
644 qsort (to_dump
, to_dump_count
, sizeof (tree
), compare_node
);
646 /* Fetch the table of comments. */
647 comments
= cpp_get_comments (parse_in
);
649 /* Sort the comments table by sloc. */
650 if (comments
->count
> 1)
651 qsort (comments
->entries
, comments
->count
, sizeof (cpp_comment
),
654 /* Interleave comments and declarations in line number order. */
658 /* Advance j until comment j is in this file. */
659 while (j
!= comments
->count
660 && LOCATION_FILE (comments
->entries
[j
].sloc
) != source_file
)
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]))
669 /* Write decls until decl i collates after comment j. */
670 while (i
!= to_dump_count
)
672 if (j
== comments
->count
673 || LOCATION_LINE (decl_sloc (to_dump
[i
], false))
674 < LOCATION_LINE (comments
->entries
[j
].sloc
))
675 print_generic_ada_decl (pp
, to_dump
[i
++], source_file
);
680 /* Write comment j, if there is one. */
681 if (j
!= comments
->count
)
682 print_comment (pp
, comments
->entries
[j
++].comment
);
684 } while (i
!= to_dump_count
|| j
!= comments
->count
);
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
);
690 /* Finalize the to_dump table. */
699 /* Print a COMMENT to the output stream PP. */
702 print_comment (pretty_printer
*pp
, const char *comment
)
704 int len
= strlen (comment
);
705 char *str
= XALLOCAVEC (char, len
+ 1);
707 bool extra_newline
= false;
709 memcpy (str
, comment
, len
+ 1);
711 /* Trim C/C++ comment indicators. */
712 if (str
[len
- 2] == '*' && str
[len
- 1] == '/')
719 tok
= strtok (str
, "\n");
721 pp_string (pp
, " --");
724 tok
= strtok (NULL
, "\n");
726 /* Leave a blank line after multi-line comments. */
728 extra_newline
= true;
735 /* Print declaration DECL to PP in Ada syntax. The current source file being
736 handled is SOURCE_FILE. */
739 print_generic_ada_decl (pretty_printer
*pp
, tree decl
, const char *source_file
)
741 source_file_base
= source_file
;
743 if (print_ada_declaration (pp
, decl
, 0, INDENT_INCR
))
750 /* Dump a newline and indent BUFFER by SPC chars. */
753 newline_and_indent (pretty_printer
*buffer
, int spc
)
759 struct with
{ char *s
; const char *in_file
; int limited
; };
760 static struct with
*withs
= NULL
;
761 static int withs_max
= 4096;
762 static int with_len
= 0;
764 /* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is
765 true), if not already done. */
768 append_withs (const char *s
, int limited_access
)
773 withs
= XNEWVEC (struct with
, withs_max
);
775 if (with_len
== withs_max
)
778 withs
= XRESIZEVEC (struct with
, withs
, withs_max
);
781 for (i
= 0; i
< with_len
; i
++)
782 if (!strcmp (s
, withs
[i
].s
)
783 && source_file_base
== withs
[i
].in_file
)
785 withs
[i
].limited
&= limited_access
;
789 withs
[with_len
].s
= xstrdup (s
);
790 withs
[with_len
].in_file
= source_file_base
;
791 withs
[with_len
].limited
= limited_access
;
795 /* Reset "with" clauses. */
798 reset_ada_withs (void)
805 for (i
= 0; i
< with_len
; i
++)
813 /* Dump "with" clauses in F. */
816 dump_ada_withs (FILE *f
)
820 fprintf (f
, "with Interfaces.C; use Interfaces.C;\n");
822 for (i
= 0; i
< with_len
; i
++)
824 (f
, "%swith %s;\n", withs
[i
].limited
? "limited " : "", withs
[i
].s
);
827 /* Return suitable Ada package name from FILE. */
830 get_ada_package (const char *file
)
838 s
= strstr (file
, "/include/");
842 base
= lbasename (file
);
844 if (ada_specs_parent
== NULL
)
847 plen
= strlen (ada_specs_parent
) + 1;
849 res
= XNEWVEC (char, plen
+ strlen (base
) + 1);
850 if (ada_specs_parent
!= NULL
) {
851 strcpy (res
, ada_specs_parent
);
855 for (i
= plen
; *base
; base
++, i
++)
867 res
[i
] = (i
== 0 || res
[i
- 1] == '.' || res
[i
- 1] == '_') ? 'u' : '_';
879 static 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",
891 /* ??? would be nice to specify this list via a config file, so that users
892 can create their own dictionary of conflicts. */
893 static const char *c_duplicates
[] = {
894 /* system will cause troubles with System.Address. */
897 /* The following values have other definitions with same name/other
903 "rl_readline_version",
909 /* Return a declaration tree corresponding to TYPE. */
912 get_underlying_decl (tree type
)
914 tree decl
= NULL_TREE
;
916 if (type
== NULL_TREE
)
919 /* type is a declaration. */
923 /* type is a typedef. */
924 if (TYPE_P (type
) && TYPE_NAME (type
) && DECL_P (TYPE_NAME (type
)))
925 decl
= TYPE_NAME (type
);
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
);
935 /* Return whether TYPE has static fields. */
938 has_static_fields (const_tree type
)
942 if (!type
|| !RECORD_OR_UNION_TYPE_P (type
))
945 for (tmp
= TYPE_FIELDS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
946 if (DECL_NAME (tmp
) && TREE_STATIC (tmp
))
952 /* Return whether TYPE corresponds to an Ada tagged type (has a dispatch
956 is_tagged_type (const_tree type
)
960 if (!type
|| !RECORD_OR_UNION_TYPE_P (type
))
963 for (tmp
= TYPE_METHODS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
964 if (TREE_CODE (tmp
) == FUNCTION_DECL
&& DECL_VINDEX (tmp
))
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. */
976 has_nontrivial_methods (tree type
)
980 if (!type
|| !RECORD_OR_UNION_TYPE_P (type
))
983 /* Only C++ types can have methods. */
987 /* A non-trivial type has non-trivial special methods. */
988 if (!cpp_check (type
, IS_TRIVIAL
))
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
))
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
1004 to_ada_name (const char *name
, int *space_found
)
1007 int len
= strlen (name
);
1010 char *s
= XNEWVEC (char, len
* 2 + 5);
1014 *space_found
= false;
1016 /* Add trailing "c_" if name is an Ada reserved word. */
1017 for (names
= ada_reserved
; *names
; names
++)
1018 if (!strcasecmp (name
, *names
))
1027 /* Add trailing "c_" if name is an potential case sensitive duplicate. */
1028 for (names
= c_duplicates
; *names
; names
++)
1029 if (!strcmp (name
, *names
))
1037 for (j
= 0; name
[j
] == '_'; j
++)
1042 else if (*name
== '.' || *name
== '$')
1052 /* Replace unsuitable characters for Ada identifiers. */
1054 for (; j
< len
; j
++)
1059 *space_found
= true;
1063 /* ??? missing some C++ operators. */
1067 if (name
[j
+ 1] == '=')
1082 if (name
[j
+ 1] == '=')
1100 s
[len2
++] = name
[j
] == '&' ? 'a' : name
[j
] == '|' ? 'o' : 'x';
1102 if (name
[j
+ 1] == '=')
1115 if (s
[len2
- 1] != '_')
1118 switch (name
[j
+ 1]) {
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; /* / */
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; /* /= */
1169 c
= name
[j
] == '<' ? 'l' : 'g';
1172 switch (name
[j
+ 1]) {
1198 if (len2
&& s
[len2
- 1] == '_')
1203 s
[len2
++] = name
[j
];
1206 if (s
[len2
- 1] == '_')
1214 /* Return true if DECL refers to a C++ class type for which a
1215 separate enclosing package has been or should be generated. */
1218 separate_class_package (tree decl
)
1220 tree type
= TREE_TYPE (decl
);
1221 return has_nontrivial_methods (type
) || has_static_fields (type
);
1224 static bool package_prefix
= true;
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. */
1231 pp_ada_tree_identifier (pretty_printer
*buffer
, tree node
, tree type
,
1234 const char *name
= IDENTIFIER_POINTER (node
);
1235 int space_found
= false;
1236 char *s
= to_ada_name (name
, &space_found
);
1239 /* If the entity is a type and comes from another file, generate "package"
1241 decl
= get_underlying_decl (type
);
1245 expanded_location xloc
= expand_location (decl_sloc (decl
, false));
1247 if (xloc
.file
&& xloc
.line
)
1249 if (xloc
.file
!= source_file_base
)
1251 switch (TREE_CODE (type
))
1256 case FIXED_POINT_TYPE
:
1258 case REFERENCE_TYPE
:
1263 case QUAL_UNION_TYPE
:
1267 char *s1
= get_ada_package (xloc
.file
);
1268 append_withs (s1
, limited_access
);
1269 pp_string (buffer
, s1
);
1278 /* Generate the additional package prefix for C++ classes. */
1279 if (separate_class_package (decl
))
1281 pp_string (buffer
, "Class_");
1282 pp_string (buffer
, s
);
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"))
1306 append_withs ("Interfaces.C.Extensions", false);
1307 pp_string (buffer
, "Extensions.unsigned_long_long");
1310 pp_string (buffer
, "unsigned_long_long");
1313 pp_string(buffer
, s
);
1315 if (!strcmp (s
, "bool"))
1319 append_withs ("Interfaces.C.Extensions", false);
1320 pp_string (buffer
, "Extensions.bool");
1323 pp_string (buffer
, "bool");
1326 pp_string(buffer
, s
);
1331 /* Dump in BUFFER the assembly name of T. */
1334 pp_asm_name (pretty_printer
*buffer
, tree t
)
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
);
1340 for (s
= ada_name
; *ident
; ident
++)
1344 else if (*ident
!= '*')
1349 pp_string (buffer
, ada_name
);
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. */
1357 dump_ada_decl_name (pretty_printer
*buffer
, tree decl
, int limited_access
)
1359 if (DECL_NAME (decl
))
1360 pp_ada_tree_identifier (buffer
, DECL_NAME (decl
), decl
, limited_access
);
1363 tree type_name
= TYPE_NAME (TREE_TYPE (decl
));
1367 pp_string (buffer
, "anon");
1368 if (TREE_CODE (decl
) == FIELD_DECL
)
1369 pp_scalar (buffer
, "%d", DECL_UID (decl
));
1371 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (decl
)));
1373 else if (TREE_CODE (type_name
) == IDENTIFIER_NODE
)
1374 pp_ada_tree_identifier (buffer
, type_name
, decl
, limited_access
);
1378 /* Dump in BUFFER a name based on both T1 and T2, followed by S. */
1381 dump_ada_double_name (pretty_printer
*buffer
, tree t1
, tree t2
, const char *s
)
1384 pp_ada_tree_identifier (buffer
, DECL_NAME (t1
), t1
, false);
1387 pp_string (buffer
, "anon");
1388 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (t1
)));
1391 pp_underscore (buffer
);
1394 pp_ada_tree_identifier (buffer
, DECL_NAME (t2
), t2
, false);
1397 pp_string (buffer
, "anon");
1398 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (t2
)));
1401 pp_string (buffer
, s
);
1404 /* Dump in BUFFER pragma Import C/CPP on a given node T. */
1407 dump_ada_import (pretty_printer
*buffer
, tree t
)
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
)));
1414 pp_string (buffer
, "pragma Import (Stdcall, ");
1415 else if (name
[0] == '_' && name
[1] == 'Z')
1416 pp_string (buffer
, "pragma Import (CPP, ");
1418 pp_string (buffer
, "pragma Import (C, ");
1420 dump_ada_decl_name (buffer
, t
, false);
1421 pp_string (buffer
, ", \"");
1424 pp_string (buffer
, IDENTIFIER_POINTER (DECL_NAME (t
)));
1426 pp_asm_name (buffer
, t
);
1428 pp_string (buffer
, "\");");
1431 /* Check whether T and its type have different names, and append "the_"
1432 otherwise in BUFFER. */
1435 check_name (pretty_printer
*buffer
, tree t
)
1438 tree tmp
= TREE_TYPE (t
);
1440 while (TREE_CODE (tmp
) == POINTER_TYPE
&& !TYPE_NAME (tmp
))
1441 tmp
= TREE_TYPE (tmp
);
1443 if (TREE_CODE (tmp
) != FUNCTION_TYPE
)
1445 if (TREE_CODE (tmp
) == IDENTIFIER_NODE
)
1446 s
= IDENTIFIER_POINTER (tmp
);
1447 else if (!TYPE_NAME (tmp
))
1449 else if (TREE_CODE (TYPE_NAME (tmp
)) == IDENTIFIER_NODE
)
1450 s
= IDENTIFIER_POINTER (TYPE_NAME (tmp
));
1452 s
= IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp
)));
1454 if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t
)), s
))
1455 pp_string (buffer
, "the_");
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. */
1466 dump_ada_function_declaration (pretty_printer
*buffer
, tree func
,
1467 int is_method
, int is_constructor
,
1468 int is_destructor
, int spc
)
1471 const tree node
= TREE_TYPE (func
);
1473 int num
= 0, num_args
= 0, have_args
= true, have_ellipsis
= false;
1475 /* Compute number of arguments. */
1476 arg
= TYPE_ARG_TYPES (node
);
1480 while (TREE_CHAIN (arg
) && arg
!= error_mark_node
)
1483 arg
= TREE_CHAIN (arg
);
1486 if (TREE_CODE (TREE_VALUE (arg
)) != VOID_TYPE
)
1489 have_ellipsis
= true;
1500 newline_and_indent (buffer
, spc
+ 1);
1505 pp_left_paren (buffer
);
1508 if (TREE_CODE (func
) == FUNCTION_DECL
)
1509 arg
= DECL_ARGUMENTS (func
);
1513 if (arg
== NULL_TREE
)
1516 arg
= TYPE_ARG_TYPES (node
);
1518 if (arg
&& TREE_CODE (TREE_VALUE (arg
)) == VOID_TYPE
)
1523 arg
= TREE_CHAIN (arg
);
1525 /* Print the argument names (if available) & types. */
1527 for (num
= 1; num
<= num_args
; num
++)
1531 if (DECL_NAME (arg
))
1533 check_name (buffer
, arg
);
1534 pp_ada_tree_identifier (buffer
, DECL_NAME (arg
), 0, false);
1535 pp_string (buffer
, " : ");
1539 sprintf (buf
, "arg%d : ", num
);
1540 pp_string (buffer
, buf
);
1543 dump_generic_ada_node (buffer
, TREE_TYPE (arg
), node
, spc
, 0, true);
1547 sprintf (buf
, "arg%d : ", num
);
1548 pp_string (buffer
, buf
);
1549 dump_generic_ada_node (buffer
, TREE_VALUE (arg
), node
, spc
, 0, true);
1552 if (TREE_TYPE (arg
) && TREE_TYPE (TREE_TYPE (arg
))
1553 && is_tagged_type (TREE_TYPE (TREE_TYPE (arg
))))
1556 || (num
!= 1 || (!DECL_VINDEX (func
) && !is_constructor
)))
1557 pp_string (buffer
, "'Class");
1560 arg
= TREE_CHAIN (arg
);
1564 pp_semicolon (buffer
);
1567 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
1575 pp_string (buffer
, " -- , ...");
1576 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
1580 pp_right_paren (buffer
);
1584 /* Dump in BUFFER all the domains associated with an array NODE,
1585 using Ada syntax. SPC is the current indentation level. */
1588 dump_ada_array_domains (pretty_printer
*buffer
, tree node
, int spc
)
1591 pp_left_paren (buffer
);
1593 for (; TREE_CODE (node
) == ARRAY_TYPE
; node
= TREE_TYPE (node
))
1595 tree domain
= TYPE_DOMAIN (node
);
1599 tree min
= TYPE_MIN_VALUE (domain
);
1600 tree max
= TYPE_MAX_VALUE (domain
);
1603 pp_string (buffer
, ", ");
1607 dump_generic_ada_node (buffer
, min
, NULL_TREE
, spc
, 0, true);
1608 pp_string (buffer
, " .. ");
1610 /* If the upper bound is zero, gcc may generate a NULL_TREE
1611 for TYPE_MAX_VALUE rather than an integer_cst. */
1613 dump_generic_ada_node (buffer
, max
, NULL_TREE
, spc
, 0, true);
1615 pp_string (buffer
, "0");
1618 pp_string (buffer
, "size_t");
1620 pp_right_paren (buffer
);
1623 /* Dump in BUFFER file:line information related to NODE. */
1626 dump_sloc (pretty_printer
*buffer
, tree node
)
1628 expanded_location xloc
;
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
));
1639 pp_string (buffer
, xloc
.file
);
1641 pp_decimal_int (buffer
, xloc
.line
);
1645 /* Return true if T designates a one dimension array of "char". */
1648 is_char_array (tree t
)
1653 /* Retrieve array's type. */
1655 while (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1658 tmp
= TREE_TYPE (tmp
);
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");
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
1671 dump_ada_array_type (pretty_printer
*buffer
, tree t
, int spc
)
1674 bool char_array
= is_char_array (t
);
1676 /* Special case char arrays. */
1679 pp_string (buffer
, "Interfaces.C.char_array ");
1682 pp_string (buffer
, "array ");
1684 /* Print the dimensions. */
1685 dump_ada_array_domains (buffer
, TREE_TYPE (t
), spc
);
1687 /* Retrieve array's type. */
1688 tmp
= TREE_TYPE (t
);
1689 while (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1690 tmp
= TREE_TYPE (tmp
);
1692 /* Print array's type. */
1695 pp_string (buffer
, " of ");
1697 if (TREE_CODE (TREE_TYPE (tmp
)) != POINTER_TYPE
)
1698 pp_string (buffer
, "aliased ");
1700 dump_generic_ada_node
1701 (buffer
, TREE_TYPE (tmp
), TREE_TYPE (t
), spc
, false, true);
1705 /* Dump in BUFFER type names associated with a template, each prepended with
1706 '_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS. SPC is
1707 the indentation level. */
1710 dump_template_types (pretty_printer
*buffer
, tree types
, int spc
)
1713 size_t len
= TREE_VEC_LENGTH (types
);
1715 for (i
= 0; i
< len
; i
++)
1717 tree elem
= TREE_VEC_ELT (types
, i
);
1718 pp_underscore (buffer
);
1719 if (!dump_generic_ada_node (buffer
, elem
, 0, spc
, false, true))
1721 pp_string (buffer
, "unknown");
1722 pp_scalar (buffer
, "%lu", (unsigned long) TREE_HASH (elem
));
1727 /* Dump in BUFFER the contents of all class instantiations associated with
1728 a given template T. SPC is the indentation level. */
1731 dump_ada_template (pretty_printer
*buffer
, tree t
, int spc
)
1733 /* DECL_SIZE_UNIT is DECL_TEMPLATE_INSTANTIATIONS in this context. */
1734 tree inst
= DECL_SIZE_UNIT (t
);
1735 /* This emulates DECL_TEMPLATE_RESULT in this context. */
1736 struct tree_template_decl
{
1737 struct tree_decl_common common
;
1741 tree result
= ((struct tree_template_decl
*) t
)->result
;
1744 /* Don't look at template declarations declaring something coming from
1745 another file. This can occur for template friend declarations. */
1746 if (LOCATION_FILE (decl_sloc (result
, false))
1747 != LOCATION_FILE (decl_sloc (t
, false)))
1750 while (inst
&& inst
!= error_mark_node
)
1752 tree types
= TREE_PURPOSE (inst
);
1753 tree instance
= TREE_VALUE (inst
);
1755 if (TREE_VEC_LENGTH (types
) == 0)
1758 if (!RECORD_OR_UNION_TYPE_P (instance
) || !TYPE_METHODS (instance
))
1763 pp_string (buffer
, "package ");
1764 package_prefix
= false;
1765 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1766 dump_template_types (buffer
, types
, spc
);
1767 pp_string (buffer
, " is");
1769 newline_and_indent (buffer
, spc
);
1771 TREE_VISITED (get_underlying_decl (instance
)) = 1;
1772 pp_string (buffer
, "type ");
1773 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1774 package_prefix
= true;
1776 if (is_tagged_type (instance
))
1777 pp_string (buffer
, " is tagged limited ");
1779 pp_string (buffer
, " is limited ");
1781 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, false);
1782 pp_newline (buffer
);
1784 newline_and_indent (buffer
, spc
);
1786 pp_string (buffer
, "end;");
1787 newline_and_indent (buffer
, spc
);
1788 pp_string (buffer
, "use ");
1789 package_prefix
= false;
1790 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1791 dump_template_types (buffer
, types
, spc
);
1792 package_prefix
= true;
1793 pp_semicolon (buffer
);
1794 pp_newline (buffer
);
1795 pp_newline (buffer
);
1797 inst
= TREE_CHAIN (inst
);
1800 return num_inst
> 0;
1803 /* Return true if NODE is a simple enum types, that can be mapped to an
1804 Ada enum type directly. */
1807 is_simple_enum (tree node
)
1809 HOST_WIDE_INT count
= 0;
1812 for (value
= TYPE_VALUES (node
); value
; value
= TREE_CHAIN (value
))
1814 tree int_val
= TREE_VALUE (value
);
1816 if (TREE_CODE (int_val
) != INTEGER_CST
)
1817 int_val
= DECL_INITIAL (int_val
);
1819 if (!tree_fits_shwi_p (int_val
))
1821 else if (tree_to_shwi (int_val
) != count
)
1830 static bool bitfield_used
= false;
1832 /* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
1833 TYPE. SPC is the indentation level. LIMITED_ACCESS indicates whether NODE
1834 can be referenced via a "limited with" clause. NAME_ONLY indicates whether
1835 we should only dump the name of NODE, instead of its full declaration. */
1838 dump_generic_ada_node (pretty_printer
*buffer
, tree node
, tree type
, int spc
,
1839 int limited_access
, bool name_only
)
1841 if (node
== NULL_TREE
)
1844 switch (TREE_CODE (node
))
1847 pp_string (buffer
, "<<< error >>>");
1850 case IDENTIFIER_NODE
:
1851 pp_ada_tree_identifier (buffer
, node
, type
, limited_access
);
1855 pp_string (buffer
, "--- unexpected node: TREE_LIST");
1859 dump_generic_ada_node
1860 (buffer
, BINFO_TYPE (node
), type
, spc
, limited_access
, name_only
);
1863 pp_string (buffer
, "--- unexpected node: TREE_VEC");
1869 append_withs ("System", false);
1870 pp_string (buffer
, "System.Address");
1873 pp_string (buffer
, "address");
1877 pp_string (buffer
, "<vector>");
1881 pp_string (buffer
, "<complex>");
1886 dump_generic_ada_node
1887 (buffer
, TYPE_NAME (node
), node
, spc
, 0, true);
1890 tree value
= TYPE_VALUES (node
);
1892 if (is_simple_enum (node
))
1896 newline_and_indent (buffer
, spc
- 1);
1897 pp_left_paren (buffer
);
1898 for (; value
; value
= TREE_CHAIN (value
))
1905 newline_and_indent (buffer
, spc
);
1908 pp_ada_tree_identifier
1909 (buffer
, TREE_PURPOSE (value
), node
, false);
1911 pp_string (buffer
, ");");
1913 newline_and_indent (buffer
, spc
);
1914 pp_string (buffer
, "pragma Convention (C, ");
1915 dump_generic_ada_node
1916 (buffer
, DECL_NAME (type
) ? type
: TYPE_NAME (node
), type
,
1918 pp_right_paren (buffer
);
1922 pp_string (buffer
, "unsigned");
1923 for (; value
; value
= TREE_CHAIN (value
))
1925 pp_semicolon (buffer
);
1926 newline_and_indent (buffer
, spc
);
1928 pp_ada_tree_identifier
1929 (buffer
, TREE_PURPOSE (value
), node
, false);
1930 pp_string (buffer
, " : constant ");
1932 dump_generic_ada_node
1933 (buffer
, DECL_NAME (type
) ? type
: TYPE_NAME (node
), type
,
1936 pp_string (buffer
, " := ");
1937 dump_generic_ada_node
1939 TREE_CODE (TREE_VALUE (value
)) == INTEGER_CST
?
1940 TREE_VALUE (value
) : DECL_INITIAL (TREE_VALUE (value
)),
1941 node
, spc
, false, true);
1949 case FIXED_POINT_TYPE
:
1952 enum tree_code_class tclass
;
1954 tclass
= TREE_CODE_CLASS (TREE_CODE (node
));
1956 if (tclass
== tcc_declaration
)
1958 if (DECL_NAME (node
))
1959 pp_ada_tree_identifier
1960 (buffer
, DECL_NAME (node
), 0, limited_access
);
1962 pp_string (buffer
, "<unnamed type decl>");
1964 else if (tclass
== tcc_type
)
1966 if (TYPE_NAME (node
))
1968 if (TREE_CODE (TYPE_NAME (node
)) == IDENTIFIER_NODE
)
1969 pp_ada_tree_identifier (buffer
, TYPE_NAME (node
),
1970 node
, limited_access
);
1971 else if (TREE_CODE (TYPE_NAME (node
)) == TYPE_DECL
1972 && DECL_NAME (TYPE_NAME (node
)))
1973 dump_ada_decl_name (buffer
, TYPE_NAME (node
), limited_access
);
1975 pp_string (buffer
, "<unnamed type>");
1977 else if (TREE_CODE (node
) == INTEGER_TYPE
)
1979 append_withs ("Interfaces.C.Extensions", false);
1980 bitfield_used
= true;
1982 if (TYPE_PRECISION (node
) == 1)
1983 pp_string (buffer
, "Extensions.Unsigned_1");
1986 pp_string (buffer
, (TYPE_UNSIGNED (node
)
1987 ? "Extensions.Unsigned_"
1988 : "Extensions.Signed_"));
1989 pp_decimal_int (buffer
, TYPE_PRECISION (node
));
1993 pp_string (buffer
, "<unnamed type>");
1999 case REFERENCE_TYPE
:
2000 if (name_only
&& TYPE_NAME (node
))
2001 dump_generic_ada_node
2002 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2004 else if (TREE_CODE (TREE_TYPE (node
)) == FUNCTION_TYPE
)
2006 tree fnode
= TREE_TYPE (node
);
2009 if (VOID_TYPE_P (TREE_TYPE (fnode
)))
2011 is_function
= false;
2012 pp_string (buffer
, "access procedure");
2017 pp_string (buffer
, "access function");
2020 dump_ada_function_declaration
2021 (buffer
, node
, false, false, false, spc
+ INDENT_INCR
);
2025 pp_string (buffer
, " return ");
2026 dump_generic_ada_node
2027 (buffer
, TREE_TYPE (fnode
), type
, spc
, 0, true);
2030 /* If we are dumping the full type, it means we are part of a
2031 type definition and need also a Convention C pragma. */
2034 pp_semicolon (buffer
);
2035 newline_and_indent (buffer
, spc
);
2036 pp_string (buffer
, "pragma Convention (C, ");
2037 dump_generic_ada_node
2038 (buffer
, type
, 0, spc
, false, true);
2039 pp_right_paren (buffer
);
2044 int is_access
= false;
2045 unsigned int quals
= TYPE_QUALS (TREE_TYPE (node
));
2047 if (VOID_TYPE_P (TREE_TYPE (node
)))
2050 pp_string (buffer
, "new ");
2053 append_withs ("System", false);
2054 pp_string (buffer
, "System.Address");
2057 pp_string (buffer
, "address");
2061 if (TREE_CODE (node
) == POINTER_TYPE
2062 && TREE_CODE (TREE_TYPE (node
)) == INTEGER_TYPE
2064 (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME
2065 (TREE_TYPE (node
)))), "char"))
2068 pp_string (buffer
, "new ");
2072 pp_string (buffer
, "Interfaces.C.Strings.chars_ptr");
2073 append_withs ("Interfaces.C.Strings", false);
2076 pp_string (buffer
, "chars_ptr");
2080 /* For now, handle all access-to-access or
2081 access-to-unknown-structs as opaque system.address. */
2083 tree type_name
= TYPE_NAME (TREE_TYPE (node
));
2084 const_tree typ2
= !type
||
2085 DECL_P (type
) ? type
: TYPE_NAME (type
);
2086 const_tree underlying_type
=
2087 get_underlying_decl (TREE_TYPE (node
));
2089 if (TREE_CODE (TREE_TYPE (node
)) == POINTER_TYPE
2090 /* Pointer to pointer. */
2092 || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node
))
2093 && (!underlying_type
2094 || !TYPE_FIELDS (TREE_TYPE (underlying_type
))))
2095 /* Pointer to opaque structure. */
2097 || underlying_type
== NULL_TREE
2099 && !TREE_VISITED (underlying_type
)
2100 && !TREE_VISITED (type_name
)
2101 && !is_tagged_type (TREE_TYPE (node
))
2102 && DECL_SOURCE_FILE (underlying_type
)
2103 == source_file_base
)
2104 || (type_name
&& typ2
2105 && DECL_P (underlying_type
)
2107 && decl_sloc (underlying_type
, true)
2108 > decl_sloc (typ2
, true)
2109 && DECL_SOURCE_FILE (underlying_type
)
2110 == DECL_SOURCE_FILE (typ2
)))
2114 append_withs ("System", false);
2116 pp_string (buffer
, "new ");
2117 pp_string (buffer
, "System.Address");
2120 pp_string (buffer
, "address");
2124 if (!package_prefix
)
2125 pp_string (buffer
, "access");
2126 else if (AGGREGATE_TYPE_P (TREE_TYPE (node
)))
2128 if (!type
|| TREE_CODE (type
) != FUNCTION_DECL
)
2130 pp_string (buffer
, "access ");
2133 if (quals
& TYPE_QUAL_CONST
)
2134 pp_string (buffer
, "constant ");
2135 else if (!name_only
)
2136 pp_string (buffer
, "all ");
2138 else if (quals
& TYPE_QUAL_CONST
)
2139 pp_string (buffer
, "in ");
2143 pp_string (buffer
, "access ");
2144 /* ??? should be configurable: access or in out. */
2150 pp_string (buffer
, "access ");
2153 pp_string (buffer
, "all ");
2156 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node
))
2157 && type_name
!= NULL_TREE
)
2158 dump_generic_ada_node
2160 TREE_TYPE (node
), spc
, is_access
, true);
2162 dump_generic_ada_node
2163 (buffer
, TREE_TYPE (node
), TREE_TYPE (node
),
2172 dump_generic_ada_node
2173 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2175 dump_ada_array_type (buffer
, node
, spc
);
2180 case QUAL_UNION_TYPE
:
2183 if (TYPE_NAME (node
))
2184 dump_generic_ada_node
2185 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2188 pp_string (buffer
, "anon_");
2189 pp_scalar (buffer
, "%d", TYPE_UID (node
));
2193 print_ada_struct_decl (buffer
, node
, type
, spc
, true);
2197 /* We treat the upper half of the sizetype range as negative. This
2198 is consistent with the internal treatment and makes it possible
2199 to generate the (0 .. -1) range for flexible array members. */
2200 if (TREE_TYPE (node
) == sizetype
)
2201 node
= fold_convert (ssizetype
, node
);
2202 if (tree_fits_shwi_p (node
))
2203 pp_wide_integer (buffer
, tree_to_shwi (node
));
2204 else if (tree_fits_uhwi_p (node
))
2205 pp_unsigned_wide_integer (buffer
, tree_to_uhwi (node
));
2208 wide_int val
= node
;
2210 if (wi::neg_p (val
))
2215 sprintf (pp_buffer (buffer
)->digit_buffer
,
2216 "16#%" HOST_WIDE_INT_PRINT
"x",
2217 val
.elt (val
.get_len () - 1));
2218 for (i
= val
.get_len () - 2; i
>= 0; i
--)
2219 sprintf (pp_buffer (buffer
)->digit_buffer
,
2220 HOST_WIDE_INT_PRINT_PADDED_HEX
, val
.elt (i
));
2221 pp_string (buffer
, pp_buffer (buffer
)->digit_buffer
);
2234 dump_ada_decl_name (buffer
, node
, limited_access
);
2238 if (DECL_IS_BUILTIN (node
))
2240 /* Don't print the declaration of built-in types. */
2244 /* If we're in the middle of a declaration, defaults to
2248 append_withs ("System", false);
2249 pp_string (buffer
, "System.Address");
2252 pp_string (buffer
, "address");
2258 dump_ada_decl_name (buffer
, node
, limited_access
);
2261 if (is_tagged_type (TREE_TYPE (node
)))
2263 tree tmp
= TYPE_FIELDS (TREE_TYPE (node
));
2266 /* Look for ancestors. */
2267 for (; tmp
; tmp
= TREE_CHAIN (tmp
))
2269 if (!DECL_NAME (tmp
) && is_tagged_type (TREE_TYPE (tmp
)))
2273 pp_string (buffer
, "limited new ");
2277 pp_string (buffer
, " and ");
2280 (buffer
, TYPE_NAME (TREE_TYPE (tmp
)), false);
2284 pp_string (buffer
, first
? "tagged limited " : " with ");
2286 else if (has_nontrivial_methods (TREE_TYPE (node
)))
2287 pp_string (buffer
, "limited ");
2289 dump_generic_ada_node
2290 (buffer
, TREE_TYPE (node
), type
, spc
, false, false);
2297 case NAMESPACE_DECL
:
2298 dump_ada_decl_name (buffer
, node
, false);
2302 /* Ignore other nodes (e.g. expressions). */
2309 /* Dump in BUFFER NODE's methods. SPC is the indentation level. Return 1 if
2310 methods were printed, 0 otherwise.
2312 We do it in 2 passes: first, the regular methods, i.e. non-static member
2313 functions, are output immediately within the package created for the class
2314 so that they are considered as primitive operations in Ada; second, the
2315 static member functions are output in a nested package so that they are
2316 _not_ considered as primitive operations in Ada.
2318 This approach is necessary because the formers have the implicit 'this'
2319 pointer whereas the latters don't and, on 32-bit x86/Windows, the calling
2320 conventions for the 'this' pointer are special. Therefore, the compiler
2321 needs to be able to differentiate regular methods (with 'this' pointer)
2322 from static member functions that take a pointer to the class as first
2326 print_ada_methods (pretty_printer
*buffer
, tree node
, int spc
)
2328 bool has_static_methods
= false;
2332 if (!has_nontrivial_methods (node
))
2335 pp_semicolon (buffer
);
2337 /* First pass: the regular methods. */
2339 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2341 if (TREE_CODE (TREE_TYPE (t
)) != METHOD_TYPE
)
2343 has_static_methods
= true;
2349 pp_newline (buffer
);
2350 pp_newline (buffer
);
2353 res
= print_ada_declaration (buffer
, t
, node
, spc
);
2356 if (!has_static_methods
)
2359 pp_newline (buffer
);
2360 newline_and_indent (buffer
, spc
);
2362 /* Second pass: the static member functions. */
2363 pp_string (buffer
, "package Static is");
2364 pp_newline (buffer
);
2368 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2370 if (TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
)
2375 pp_newline (buffer
);
2376 pp_newline (buffer
);
2379 res
= print_ada_declaration (buffer
, t
, node
, spc
);
2383 newline_and_indent (buffer
, spc
);
2384 pp_string (buffer
, "end;");
2386 /* In order to save the clients from adding a second use clause for the
2387 nested package, we generate renamings for the static member functions
2388 in the package created for the class. */
2389 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2393 if (TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
)
2396 pp_newline (buffer
);
2397 newline_and_indent (buffer
, spc
);
2399 if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t
))))
2401 pp_string (buffer
, "procedure ");
2402 is_function
= false;
2406 pp_string (buffer
, "function ");
2410 dump_ada_decl_name (buffer
, t
, false);
2411 dump_ada_function_declaration (buffer
, t
, false, false, false, spc
);
2415 pp_string (buffer
, " return ");
2416 dump_generic_ada_node (buffer
, TREE_TYPE (TREE_TYPE (t
)), node
,
2420 pp_string (buffer
, " renames Static.");
2421 dump_ada_decl_name (buffer
, t
, false);
2422 pp_semicolon (buffer
);
2428 /* Dump in BUFFER anonymous types nested inside T's definition.
2429 PARENT is the parent node of T.
2430 FORWARD indicates whether a forward declaration of T should be generated.
2431 SPC is the indentation level. */
2434 dump_nested_types (pretty_printer
*buffer
, tree t
, tree parent
, bool forward
,
2437 tree field
, outer
, decl
;
2439 /* Avoid recursing over the same tree. */
2440 if (TREE_VISITED (t
))
2443 /* Find possible anonymous arrays/unions/structs recursively. */
2445 outer
= TREE_TYPE (t
);
2447 if (outer
== NULL_TREE
)
2452 pp_string (buffer
, "type ");
2453 dump_generic_ada_node (buffer
, t
, t
, spc
, false, true);
2454 pp_semicolon (buffer
);
2455 newline_and_indent (buffer
, spc
);
2456 TREE_VISITED (t
) = 1;
2459 field
= TYPE_FIELDS (outer
);
2462 if ((TREE_TYPE (field
) != outer
2463 || (TREE_CODE (TREE_TYPE (field
)) == POINTER_TYPE
2464 && TREE_TYPE (TREE_TYPE (field
)) != outer
))
2465 && (!TYPE_NAME (TREE_TYPE (field
))
2466 || (TREE_CODE (field
) == TYPE_DECL
2467 && DECL_NAME (field
) != DECL_NAME (t
)
2468 && TYPE_NAME (TREE_TYPE (field
)) != TYPE_NAME (outer
))))
2470 switch (TREE_CODE (TREE_TYPE (field
)))
2473 decl
= TREE_TYPE (TREE_TYPE (field
));
2475 if (TREE_CODE (decl
) == FUNCTION_TYPE
)
2476 for (decl
= TREE_TYPE (decl
);
2477 decl
&& TREE_CODE (decl
) == POINTER_TYPE
;
2478 decl
= TREE_TYPE (decl
))
2481 decl
= get_underlying_decl (decl
);
2485 && decl_sloc (decl
, true) > decl_sloc (t
, true)
2486 && DECL_SOURCE_FILE (decl
) == DECL_SOURCE_FILE (t
)
2487 && !TREE_VISITED (decl
)
2488 && !DECL_IS_BUILTIN (decl
)
2489 && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl
))
2490 || TYPE_FIELDS (TREE_TYPE (decl
))))
2492 /* Generate forward declaration. */
2494 pp_string (buffer
, "type ");
2495 dump_generic_ada_node (buffer
, decl
, 0, spc
, false, true);
2496 pp_semicolon (buffer
);
2497 newline_and_indent (buffer
, spc
);
2499 /* Ensure we do not generate duplicate forward
2500 declarations for this type. */
2501 TREE_VISITED (decl
) = 1;
2506 /* Special case char arrays. */
2507 if (is_char_array (field
))
2508 pp_string (buffer
, "sub");
2510 pp_string (buffer
, "type ");
2511 dump_ada_double_name (buffer
, parent
, field
, "_array is ");
2512 dump_ada_array_type (buffer
, field
, spc
);
2513 pp_semicolon (buffer
);
2514 newline_and_indent (buffer
, spc
);
2518 TREE_VISITED (t
) = 1;
2519 dump_nested_types (buffer
, field
, t
, false, spc
);
2521 pp_string (buffer
, "type ");
2523 if (TYPE_NAME (TREE_TYPE (field
)))
2525 dump_generic_ada_node
2526 (buffer
, TYPE_NAME (TREE_TYPE (field
)), 0, spc
, false,
2528 pp_string (buffer
, " (discr : unsigned := 0) is ");
2529 print_ada_struct_decl
2530 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2532 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2533 dump_generic_ada_node
2534 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2535 pp_string (buffer
, ");");
2536 newline_and_indent (buffer
, spc
);
2538 pp_string (buffer
, "pragma Unchecked_Union (");
2539 dump_generic_ada_node
2540 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2541 pp_string (buffer
, ");");
2545 dump_ada_double_name
2546 (buffer
, parent
, field
,
2547 "_union (discr : unsigned := 0) is ");
2548 print_ada_struct_decl
2549 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2550 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2551 dump_ada_double_name (buffer
, parent
, field
, "_union);");
2552 newline_and_indent (buffer
, spc
);
2554 pp_string (buffer
, "pragma Unchecked_Union (");
2555 dump_ada_double_name (buffer
, parent
, field
, "_union);");
2558 newline_and_indent (buffer
, spc
);
2562 if (TYPE_NAME (TREE_TYPE (t
)) && !TREE_VISITED (t
))
2564 pp_string (buffer
, "type ");
2565 dump_generic_ada_node
2566 (buffer
, t
, parent
, spc
, false, true);
2567 pp_semicolon (buffer
);
2568 newline_and_indent (buffer
, spc
);
2571 TREE_VISITED (t
) = 1;
2572 dump_nested_types (buffer
, field
, t
, false, spc
);
2573 pp_string (buffer
, "type ");
2575 if (TYPE_NAME (TREE_TYPE (field
)))
2577 dump_generic_ada_node
2578 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2579 pp_string (buffer
, " is ");
2580 print_ada_struct_decl
2581 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2582 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2583 dump_generic_ada_node
2584 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2585 pp_string (buffer
, ");");
2589 dump_ada_double_name
2590 (buffer
, parent
, field
, "_struct is ");
2591 print_ada_struct_decl
2592 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2593 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2594 dump_ada_double_name (buffer
, parent
, field
, "_struct);");
2597 newline_and_indent (buffer
, spc
);
2604 field
= TREE_CHAIN (field
);
2607 TREE_VISITED (t
) = 1;
2610 /* Dump in BUFFER constructor spec corresponding to T. */
2613 print_constructor (pretty_printer
*buffer
, tree t
)
2615 tree decl_name
= DECL_NAME (DECL_ORIGIN (t
));
2617 pp_string (buffer
, "New_");
2618 pp_ada_tree_identifier (buffer
, decl_name
, t
, false);
2621 /* Dump in BUFFER destructor spec corresponding to T. */
2624 print_destructor (pretty_printer
*buffer
, tree t
)
2626 tree decl_name
= DECL_NAME (DECL_ORIGIN (t
));
2628 pp_string (buffer
, "Delete_");
2629 pp_ada_tree_identifier (buffer
, decl_name
, t
, false);
2632 /* Return the name of type T. */
2637 tree n
= TYPE_NAME (t
);
2639 if (TREE_CODE (n
) == IDENTIFIER_NODE
)
2640 return IDENTIFIER_POINTER (n
);
2642 return IDENTIFIER_POINTER (DECL_NAME (n
));
2645 /* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
2646 SPC is the indentation level. Return 1 if a declaration was printed,
2650 print_ada_declaration (pretty_printer
*buffer
, tree t
, tree type
, int spc
)
2652 int is_var
= 0, need_indent
= 0;
2653 int is_class
= false;
2654 tree name
= TYPE_NAME (TREE_TYPE (t
));
2655 tree decl_name
= DECL_NAME (t
);
2656 tree orig
= NULL_TREE
;
2658 if (cpp_check
&& cpp_check (t
, IS_TEMPLATE
))
2659 return dump_ada_template (buffer
, t
, spc
);
2661 if (TREE_CODE (t
) == CONST_DECL
&& TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
)
2662 /* Skip enumeral values: will be handled as part of the type itself. */
2665 if (TREE_CODE (t
) == TYPE_DECL
)
2667 orig
= DECL_ORIGINAL_TYPE (t
);
2669 if (orig
&& TYPE_STUB_DECL (orig
))
2671 tree stub
= TYPE_STUB_DECL (orig
);
2672 tree typ
= TREE_TYPE (stub
);
2674 if (TYPE_NAME (typ
))
2676 /* If types have same representation, and same name (ignoring
2677 casing), then ignore the second type. */
2678 if (type_name (typ
) == type_name (TREE_TYPE (t
))
2679 || !strcasecmp (type_name (typ
), type_name (TREE_TYPE (t
))))
2684 if (RECORD_OR_UNION_TYPE_P (typ
) && !TYPE_FIELDS (typ
))
2686 pp_string (buffer
, "-- skipped empty struct ");
2687 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2691 if (!TREE_VISITED (stub
)
2692 && DECL_SOURCE_FILE (stub
) == source_file_base
)
2693 dump_nested_types (buffer
, stub
, stub
, true, spc
);
2695 pp_string (buffer
, "subtype ");
2696 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2697 pp_string (buffer
, " is ");
2698 dump_generic_ada_node (buffer
, typ
, type
, spc
, false, true);
2699 pp_semicolon (buffer
);
2705 /* Skip unnamed or anonymous structs/unions/enum types. */
2706 if (!orig
&& !decl_name
&& !name
)
2711 if (cpp_check
|| TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
)
2714 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
)))
2716 /* Search next items until finding a named type decl. */
2717 sloc
= decl_sloc_common (t
, true, true);
2719 for (tmp
= TREE_CHAIN (t
); tmp
; tmp
= TREE_CHAIN (tmp
))
2721 if (TREE_CODE (tmp
) == TYPE_DECL
2722 && (DECL_NAME (tmp
) || TYPE_NAME (TREE_TYPE (tmp
))))
2724 /* If same sloc, it means we can ignore the anonymous
2726 if (decl_sloc_common (tmp
, true, true) == sloc
)
2738 && TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
2740 && (*IDENTIFIER_POINTER (decl_name
) == '.'
2741 || *IDENTIFIER_POINTER (decl_name
) == '$'))
2742 /* Skip anonymous enum types (duplicates of real types). */
2747 switch (TREE_CODE (TREE_TYPE (t
)))
2751 case QUAL_UNION_TYPE
:
2752 /* Skip empty structs (typically forward references to real
2754 if (!TYPE_FIELDS (TREE_TYPE (t
)))
2756 pp_string (buffer
, "-- skipped empty struct ");
2757 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2762 && (*IDENTIFIER_POINTER (decl_name
) == '.'
2763 || *IDENTIFIER_POINTER (decl_name
) == '$'))
2765 pp_string (buffer
, "-- skipped anonymous struct ");
2766 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2767 TREE_VISITED (t
) = 1;
2771 if (orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2772 pp_string (buffer
, "subtype ");
2775 dump_nested_types (buffer
, t
, t
, false, spc
);
2777 if (separate_class_package (t
))
2780 pp_string (buffer
, "package Class_");
2781 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2782 pp_string (buffer
, " is");
2784 newline_and_indent (buffer
, spc
);
2787 pp_string (buffer
, "type ");
2793 case REFERENCE_TYPE
:
2794 if ((orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2795 || is_char_array (t
))
2796 pp_string (buffer
, "subtype ");
2798 pp_string (buffer
, "type ");
2802 pp_string (buffer
, "-- skipped function type ");
2803 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2808 if ((orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2809 || !is_simple_enum (TREE_TYPE (t
)))
2810 pp_string (buffer
, "subtype ");
2812 pp_string (buffer
, "type ");
2816 pp_string (buffer
, "subtype ");
2818 TREE_VISITED (t
) = 1;
2822 if (TREE_CODE (t
) == VAR_DECL
2824 && *IDENTIFIER_POINTER (decl_name
) == '_')
2830 /* Print the type and name. */
2831 if (TREE_CODE (TREE_TYPE (t
)) == ARRAY_TYPE
)
2836 /* Print variable's name. */
2837 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2839 if (TREE_CODE (t
) == TYPE_DECL
)
2841 pp_string (buffer
, " is ");
2843 if (orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2844 dump_generic_ada_node
2845 (buffer
, TYPE_NAME (orig
), type
, spc
, false, true);
2847 dump_ada_array_type (buffer
, t
, spc
);
2851 tree tmp
= TYPE_NAME (TREE_TYPE (t
));
2853 if (spc
== INDENT_INCR
|| TREE_STATIC (t
))
2856 pp_string (buffer
, " : ");
2860 if (TREE_CODE (TREE_TYPE (tmp
)) != POINTER_TYPE
2861 && TREE_CODE (tmp
) != INTEGER_TYPE
)
2862 pp_string (buffer
, "aliased ");
2864 dump_generic_ada_node (buffer
, tmp
, type
, spc
, false, true);
2868 pp_string (buffer
, "aliased ");
2871 dump_ada_array_type (buffer
, t
, spc
);
2873 dump_ada_double_name (buffer
, type
, t
, "_array");
2877 else if (TREE_CODE (t
) == FUNCTION_DECL
)
2879 bool is_function
, is_abstract_class
= false;
2880 bool is_method
= TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
;
2881 tree decl_name
= DECL_NAME (t
);
2882 bool is_abstract
= false;
2883 bool is_constructor
= false;
2884 bool is_destructor
= false;
2885 bool is_copy_constructor
= false;
2892 is_abstract
= cpp_check (t
, IS_ABSTRACT
);
2893 is_constructor
= cpp_check (t
, IS_CONSTRUCTOR
);
2894 is_destructor
= cpp_check (t
, IS_DESTRUCTOR
);
2895 is_copy_constructor
= cpp_check (t
, IS_COPY_CONSTRUCTOR
);
2898 /* Skip copy constructors: some are internal only, and those that are
2899 not cannot be called easily from Ada anyway. */
2900 if (is_copy_constructor
)
2903 if (is_constructor
|| is_destructor
)
2905 /* Only consider constructors/destructors for complete objects. */
2906 if (strncmp (IDENTIFIER_POINTER (decl_name
), "__comp", 6) != 0)
2910 /* If this function has an entry in the vtable, we cannot omit it. */
2911 else if (!DECL_VINDEX (t
) && *IDENTIFIER_POINTER (decl_name
) == '_')
2914 pp_string (buffer
, "-- skipped func ");
2915 pp_string (buffer
, IDENTIFIER_POINTER (decl_name
));
2922 if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t
))) && !is_constructor
)
2924 pp_string (buffer
, "procedure ");
2925 is_function
= false;
2929 pp_string (buffer
, "function ");
2934 print_constructor (buffer
, t
);
2935 else if (is_destructor
)
2936 print_destructor (buffer
, t
);
2938 dump_ada_decl_name (buffer
, t
, false);
2940 dump_ada_function_declaration
2941 (buffer
, t
, is_method
, is_constructor
, is_destructor
, spc
);
2945 pp_string (buffer
, " return ");
2947 = is_constructor
? DECL_CONTEXT (t
) : TREE_TYPE (TREE_TYPE (t
));
2948 dump_generic_ada_node (buffer
, ret_type
, type
, spc
, false, true);
2952 && RECORD_OR_UNION_TYPE_P (type
)
2953 && TYPE_METHODS (type
))
2957 for (tmp
= TYPE_METHODS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
2958 if (cpp_check (tmp
, IS_ABSTRACT
))
2960 is_abstract_class
= true;
2965 if (is_abstract
|| is_abstract_class
)
2966 pp_string (buffer
, " is abstract");
2968 pp_semicolon (buffer
);
2969 pp_string (buffer
, " -- ");
2970 dump_sloc (buffer
, t
);
2972 if (is_abstract
|| !DECL_ASSEMBLER_NAME (t
))
2975 newline_and_indent (buffer
, spc
);
2979 pp_string (buffer
, "pragma CPP_Constructor (");
2980 print_constructor (buffer
, t
);
2981 pp_string (buffer
, ", \"");
2982 pp_asm_name (buffer
, t
);
2983 pp_string (buffer
, "\");");
2985 else if (is_destructor
)
2987 pp_string (buffer
, "pragma Import (CPP, ");
2988 print_destructor (buffer
, t
);
2989 pp_string (buffer
, ", \"");
2990 pp_asm_name (buffer
, t
);
2991 pp_string (buffer
, "\");");
2995 dump_ada_import (buffer
, t
);
3000 else if (TREE_CODE (t
) == TYPE_DECL
&& !DECL_ORIGINAL_TYPE (t
))
3002 int is_interface
= 0;
3003 int is_abstract_record
= 0;
3008 /* Anonymous structs/unions */
3009 dump_generic_ada_node (buffer
, TREE_TYPE (t
), t
, spc
, false, true);
3011 if (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3012 || TREE_CODE (TREE_TYPE (t
)) == QUAL_UNION_TYPE
)
3014 pp_string (buffer
, " (discr : unsigned := 0)");
3017 pp_string (buffer
, " is ");
3019 /* Check whether we have an Ada interface compatible class. */
3021 && RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
))
3022 && TYPE_METHODS (TREE_TYPE (t
)))
3027 /* Check that there are no fields other than the virtual table. */
3028 for (tmp
= TYPE_FIELDS (TREE_TYPE (t
)); tmp
; tmp
= TREE_CHAIN (tmp
))
3030 if (TREE_CODE (tmp
) == TYPE_DECL
)
3035 if (num_fields
== 1)
3038 /* Also check that there are only virtual methods. */
3039 for (tmp
= TYPE_METHODS (TREE_TYPE (t
)); tmp
; tmp
= TREE_CHAIN (tmp
))
3041 if (cpp_check (tmp
, IS_ABSTRACT
))
3042 is_abstract_record
= 1;
3048 TREE_VISITED (t
) = 1;
3051 pp_string (buffer
, "limited interface; -- ");
3052 dump_sloc (buffer
, t
);
3053 newline_and_indent (buffer
, spc
);
3054 pp_string (buffer
, "pragma Import (CPP, ");
3055 dump_generic_ada_node
3056 (buffer
, TYPE_NAME (TREE_TYPE (t
)), type
, spc
, false, true);
3057 pp_right_paren (buffer
);
3059 print_ada_methods (buffer
, TREE_TYPE (t
), spc
);
3063 if (is_abstract_record
)
3064 pp_string (buffer
, "abstract ");
3065 dump_generic_ada_node (buffer
, t
, t
, spc
, false, false);
3073 if (TREE_CODE (t
) == FIELD_DECL
&& DECL_NAME (t
))
3074 check_name (buffer
, t
);
3076 /* Print variable/type's name. */
3077 dump_generic_ada_node (buffer
, t
, t
, spc
, false, true);
3079 if (TREE_CODE (t
) == TYPE_DECL
)
3081 tree orig
= DECL_ORIGINAL_TYPE (t
);
3082 int is_subtype
= orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
);
3085 && (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3086 || TREE_CODE (TREE_TYPE (t
)) == QUAL_UNION_TYPE
))
3087 pp_string (buffer
, " (discr : unsigned := 0)");
3089 pp_string (buffer
, " is ");
3091 dump_generic_ada_node (buffer
, orig
, t
, spc
, false, is_subtype
);
3095 if (spc
== INDENT_INCR
|| TREE_STATIC (t
))
3098 pp_string (buffer
, " : ");
3100 /* Print type declaration. */
3102 if (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3103 && !TYPE_NAME (TREE_TYPE (t
)))
3105 dump_ada_double_name (buffer
, type
, t
, "_union");
3107 else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
)))
3109 if (TREE_CODE (TREE_TYPE (t
)) == RECORD_TYPE
)
3110 pp_string (buffer
, "aliased ");
3112 dump_generic_ada_node
3113 (buffer
, TREE_TYPE (t
), t
, spc
, false, true);
3117 if (TREE_CODE (TREE_TYPE (t
)) != POINTER_TYPE
3118 && (TYPE_NAME (TREE_TYPE (t
))
3119 || TREE_CODE (TREE_TYPE (t
)) != INTEGER_TYPE
))
3120 pp_string (buffer
, "aliased ");
3122 dump_generic_ada_node
3123 (buffer
, TREE_TYPE (t
), TREE_TYPE (t
), spc
, false, true);
3131 newline_and_indent (buffer
, spc
);
3132 pp_string (buffer
, "end;");
3133 newline_and_indent (buffer
, spc
);
3134 pp_string (buffer
, "use Class_");
3135 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
3136 pp_semicolon (buffer
);
3137 pp_newline (buffer
);
3139 /* All needed indentation/newline performed already, so return 0. */
3144 pp_string (buffer
, "; -- ");
3145 dump_sloc (buffer
, t
);
3150 newline_and_indent (buffer
, spc
);
3151 dump_ada_import (buffer
, t
);
3157 /* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
3158 with Ada syntax. SPC is the indentation level. If DISPLAY_CONVENTION is
3159 true, also print the pragma Convention for NODE. */
3162 print_ada_struct_decl (pretty_printer
*buffer
, tree node
, tree type
, int spc
,
3163 bool display_convention
)
3167 = TREE_CODE (node
) == UNION_TYPE
|| TREE_CODE (node
) == QUAL_UNION_TYPE
;
3170 int field_spc
= spc
+ INDENT_INCR
;
3173 bitfield_used
= false;
3175 if (!TYPE_FIELDS (node
))
3176 pp_string (buffer
, "null record;");
3179 pp_string (buffer
, "record");
3181 /* Print the contents of the structure. */
3185 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
3186 pp_string (buffer
, "case discr is");
3187 field_spc
= spc
+ INDENT_INCR
* 3;
3190 pp_newline (buffer
);
3192 /* Print the non-static fields of the structure. */
3193 for (tmp
= TYPE_FIELDS (node
); tmp
; tmp
= TREE_CHAIN (tmp
))
3195 /* Add parent field if needed. */
3196 if (!DECL_NAME (tmp
))
3198 if (!is_tagged_type (TREE_TYPE (tmp
)))
3200 if (!TYPE_NAME (TREE_TYPE (tmp
)))
3201 print_ada_declaration (buffer
, tmp
, type
, field_spc
);
3207 pp_string (buffer
, "parent : aliased ");
3210 sprintf (buf
, "field_%d : aliased ", field_num
+ 1);
3211 pp_string (buffer
, buf
);
3214 (buffer
, TYPE_NAME (TREE_TYPE (tmp
)), false);
3215 pp_semicolon (buffer
);
3217 pp_newline (buffer
);
3221 /* Avoid printing the structure recursively. */
3222 else if ((TREE_TYPE (tmp
) != node
3223 || (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3224 && TREE_TYPE (TREE_TYPE (tmp
)) != node
))
3225 && TREE_CODE (tmp
) != TYPE_DECL
3226 && !TREE_STATIC (tmp
))
3228 /* Skip internal virtual table field. */
3229 if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp
)), "_vptr", 5))
3233 if (TREE_CHAIN (tmp
)
3234 && TREE_TYPE (TREE_CHAIN (tmp
)) != node
3235 && TREE_CODE (TREE_CHAIN (tmp
)) != TYPE_DECL
)
3236 sprintf (buf
, "when %d =>", field_num
);
3238 sprintf (buf
, "when others =>");
3240 INDENT (spc
+ INDENT_INCR
* 2);
3241 pp_string (buffer
, buf
);
3242 pp_newline (buffer
);
3245 if (print_ada_declaration (buffer
, tmp
, type
, field_spc
))
3247 pp_newline (buffer
);
3256 INDENT (spc
+ INDENT_INCR
);
3257 pp_string (buffer
, "end case;");
3258 pp_newline (buffer
);
3263 INDENT (spc
+ INDENT_INCR
);
3264 pp_string (buffer
, "null;");
3265 pp_newline (buffer
);
3269 pp_string (buffer
, "end record;");
3272 newline_and_indent (buffer
, spc
);
3274 if (!display_convention
)
3277 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type
)))
3279 if (has_nontrivial_methods (TREE_TYPE (type
)))
3280 pp_string (buffer
, "pragma Import (CPP, ");
3282 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
3285 pp_string (buffer
, "pragma Convention (C, ");
3287 package_prefix
= false;
3288 dump_generic_ada_node (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3289 package_prefix
= true;
3290 pp_right_paren (buffer
);
3294 pp_semicolon (buffer
);
3295 newline_and_indent (buffer
, spc
);
3296 pp_string (buffer
, "pragma Unchecked_Union (");
3298 dump_generic_ada_node (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3299 pp_right_paren (buffer
);
3304 pp_semicolon (buffer
);
3305 newline_and_indent (buffer
, spc
);
3306 pp_string (buffer
, "pragma Pack (");
3307 dump_generic_ada_node
3308 (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3309 pp_right_paren (buffer
);
3310 bitfield_used
= false;
3313 need_semicolon
= !print_ada_methods (buffer
, node
, spc
);
3315 /* Print the static fields of the structure, if any. */
3316 for (tmp
= TYPE_FIELDS (node
); tmp
; tmp
= TREE_CHAIN (tmp
))
3318 if (DECL_NAME (tmp
) && TREE_STATIC (tmp
))
3322 need_semicolon
= false;
3323 pp_semicolon (buffer
);
3325 pp_newline (buffer
);
3326 pp_newline (buffer
);
3327 print_ada_declaration (buffer
, tmp
, type
, spc
);
3332 /* Dump all the declarations in SOURCE_FILE to an Ada spec.
3333 COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3334 nodes for SOURCE_FILE. CHECK is used to perform C++ queries on nodes. */
3337 dump_ads (const char *source_file
,
3338 void (*collect_all_refs
)(const char *),
3339 int (*check
)(tree
, cpp_operation
))
3346 pkg_name
= get_ada_package (source_file
);
3348 /* Construct the .ads filename and package name. */
3349 ads_name
= xstrdup (pkg_name
);
3351 for (s
= ads_name
; *s
; s
++)
3357 ads_name
= reconcat (ads_name
, ads_name
, ".ads", NULL
);
3359 /* Write out the .ads file. */
3360 f
= fopen (ads_name
, "w");
3365 pp_needs_newline (&pp
) = true;
3366 pp
.buffer
->stream
= f
;
3368 /* Dump all relevant macros. */
3369 dump_ada_macros (&pp
, source_file
);
3371 /* Reset the table of withs for this file. */
3374 (*collect_all_refs
) (source_file
);
3376 /* Dump all references. */
3378 dump_ada_nodes (&pp
, source_file
);
3380 /* Requires Ada 2005 syntax, so generate corresponding pragma.
3381 Also, disable style checks since this file is auto-generated. */
3382 fprintf (f
, "pragma Ada_2005;\npragma Style_Checks (Off);\n\n");
3387 fprintf (f
, "\npackage %s is\n\n", pkg_name
);
3388 pp_write_text_to_stream (&pp
);
3389 /* ??? need to free pp */
3390 fprintf (f
, "end %s;\n", pkg_name
);
3398 static const char **source_refs
= NULL
;
3399 static int source_refs_used
= 0;
3400 static int source_refs_allocd
= 0;
3402 /* Add an entry for FILENAME to the table SOURCE_REFS. */
3405 collect_source_ref (const char *filename
)
3412 if (source_refs_allocd
== 0)
3414 source_refs_allocd
= 1024;
3415 source_refs
= XNEWVEC (const char *, source_refs_allocd
);
3418 for (i
= 0; i
< source_refs_used
; i
++)
3419 if (filename
== source_refs
[i
])
3422 if (source_refs_used
== source_refs_allocd
)
3424 source_refs_allocd
*= 2;
3425 source_refs
= XRESIZEVEC (const char *, source_refs
, source_refs_allocd
);
3428 source_refs
[source_refs_used
++] = filename
;
3431 /* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
3432 using callbacks COLLECT_ALL_REFS and CHECK.
3433 COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3434 nodes for a given source file.
3435 CHECK is used to perform C++ queries on nodes, or NULL for the C
3439 dump_ada_specs (void (*collect_all_refs
)(const char *),
3440 int (*check
)(tree
, cpp_operation
))
3444 /* Iterate over the list of files to dump specs for */
3445 for (i
= 0; i
< source_refs_used
; i
++)
3446 dump_ads (source_refs
[i
], collect_all_refs
, check
);
3448 /* Free files table. */