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"
30 #include "fold-const.h"
32 #include "c-ada-spec.h"
35 #include "cpp-id-data.h"
37 /* Local functions, macros and variables. */
38 static int dump_generic_ada_node (pretty_printer
*, tree
, tree
, int, int,
40 static int print_ada_declaration (pretty_printer
*, tree
, tree
, int);
41 static void print_ada_struct_decl (pretty_printer
*, tree
, tree
, int, bool);
42 static void dump_sloc (pretty_printer
*buffer
, tree node
);
43 static void print_comment (pretty_printer
*, const char *);
44 static void print_generic_ada_decl (pretty_printer
*, tree
, const char *);
45 static char *get_ada_package (const char *);
46 static void dump_ada_nodes (pretty_printer
*, const char *);
47 static void reset_ada_withs (void);
48 static void dump_ada_withs (FILE *);
49 static void dump_ads (const char *, void (*)(const char *),
50 int (*)(tree
, cpp_operation
));
51 static char *to_ada_name (const char *, int *);
52 static bool separate_class_package (tree
);
54 #define INDENT(SPACE) \
55 do { int i; for (i = 0; i<SPACE; i++) pp_space (buffer); } while (0)
59 /* Global hook used to perform C++ queries on nodes. */
60 static int (*cpp_check
) (tree
, cpp_operation
) = NULL
;
63 /* Given a cpp MACRO, compute the max length BUFFER_LEN of the macro, as well
64 as max length PARAM_LEN of arguments for fun_like macros, and also set
65 SUPPORTED to 0 if the macro cannot be mapped to an Ada construct. */
68 macro_length (const cpp_macro
*macro
, int *supported
, int *buffer_len
,
81 for (i
= 0; i
< macro
->paramc
; i
++)
83 cpp_hashnode
*param
= macro
->params
[i
];
85 *param_len
+= NODE_LEN (param
);
87 if (i
+ 1 < macro
->paramc
)
89 *param_len
+= 2; /* ", " */
91 else if (macro
->variadic
)
97 *param_len
+= 2; /* ")\0" */
100 for (j
= 0; j
< macro
->count
; j
++)
102 cpp_token
*token
= ¯o
->exp
.tokens
[j
];
104 if (token
->flags
& PREV_WHITE
)
107 if (token
->flags
& STRINGIFY_ARG
|| token
->flags
& PASTE_LEFT
)
113 if (token
->type
== CPP_MACRO_ARG
)
115 NODE_LEN (macro
->params
[token
->val
.macro_arg
.arg_no
- 1]);
117 /* Include enough extra space to handle e.g. special characters. */
118 *buffer_len
+= (cpp_token_len (token
) + 1) * 8;
124 /* Dump into PP a set of MAX_ADA_MACROS MACROS (C/C++) as Ada constants when
128 print_ada_macros (pretty_printer
*pp
, cpp_hashnode
**macros
, int max_ada_macros
)
130 int j
, num_macros
= 0, prev_line
= -1;
132 for (j
= 0; j
< max_ada_macros
; j
++)
134 cpp_hashnode
*node
= macros
[j
];
135 const cpp_macro
*macro
= node
->value
.macro
;
137 int supported
= 1, prev_is_one
= 0, buffer_len
, param_len
;
138 int is_string
= 0, is_char
= 0;
140 unsigned char *s
, *params
, *buffer
, *buf_param
, *char_one
= NULL
;
142 macro_length (macro
, &supported
, &buffer_len
, ¶m_len
);
143 s
= buffer
= XALLOCAVEC (unsigned char, buffer_len
);
144 params
= buf_param
= XALLOCAVEC (unsigned char, param_len
);
151 for (i
= 0; i
< macro
->paramc
; i
++)
153 cpp_hashnode
*param
= macro
->params
[i
];
155 memcpy (buf_param
, NODE_NAME (param
), NODE_LEN (param
));
156 buf_param
+= NODE_LEN (param
);
158 if (i
+ 1 < macro
->paramc
)
163 else if (macro
->variadic
)
173 for (i
= 0; supported
&& i
< macro
->count
; i
++)
175 cpp_token
*token
= ¯o
->exp
.tokens
[i
];
178 if (token
->flags
& PREV_WHITE
)
181 if (token
->flags
& STRINGIFY_ARG
|| token
->flags
& PASTE_LEFT
)
191 cpp_hashnode
*param
=
192 macro
->params
[token
->val
.macro_arg
.arg_no
- 1];
193 memcpy (buffer
, NODE_NAME (param
), NODE_LEN (param
));
194 buffer
+= NODE_LEN (param
);
198 case CPP_EQ_EQ
: *buffer
++ = '='; break;
199 case CPP_GREATER
: *buffer
++ = '>'; break;
200 case CPP_LESS
: *buffer
++ = '<'; break;
201 case CPP_PLUS
: *buffer
++ = '+'; break;
202 case CPP_MINUS
: *buffer
++ = '-'; break;
203 case CPP_MULT
: *buffer
++ = '*'; break;
204 case CPP_DIV
: *buffer
++ = '/'; break;
205 case CPP_COMMA
: *buffer
++ = ','; break;
206 case CPP_OPEN_SQUARE
:
207 case CPP_OPEN_PAREN
: *buffer
++ = '('; break;
208 case CPP_CLOSE_SQUARE
: /* fallthrough */
209 case CPP_CLOSE_PAREN
: *buffer
++ = ')'; break;
210 case CPP_DEREF
: /* fallthrough */
211 case CPP_SCOPE
: /* fallthrough */
212 case CPP_DOT
: *buffer
++ = '.'; break;
214 case CPP_EQ
: *buffer
++ = ':'; *buffer
++ = '='; break;
215 case CPP_NOT_EQ
: *buffer
++ = '/'; *buffer
++ = '='; break;
216 case CPP_GREATER_EQ
: *buffer
++ = '>'; *buffer
++ = '='; break;
217 case CPP_LESS_EQ
: *buffer
++ = '<'; *buffer
++ = '='; break;
220 *buffer
++ = 'n'; *buffer
++ = 'o'; *buffer
++ = 't'; break;
222 *buffer
++ = 'm'; *buffer
++ = 'o'; *buffer
++ = 'd'; break;
224 *buffer
++ = 'a'; *buffer
++ = 'n'; *buffer
++ = 'd'; break;
226 *buffer
++ = 'o'; *buffer
++ = 'r'; break;
228 *buffer
++ = 'x'; *buffer
++ = 'o'; *buffer
++ = 'r'; break;
230 strcpy ((char *) buffer
, " and then ");
234 strcpy ((char *) buffer
, " or else ");
240 is_one
= prev_is_one
;
243 case CPP_COMMENT
: break;
256 if (!macro
->fun_like
)
259 buffer
= cpp_spell_token (parse_in
, token
, buffer
, false);
269 c
= cpp_interpret_charconst (parse_in
, token
,
270 &chars_seen
, &ignored
);
271 if (c
>= 32 && c
<= 126)
274 *buffer
++ = (char) c
;
280 ((char *) buffer
, "Character'Val (%d)", (int) c
);
281 buffer
+= chars_seen
;
289 /* Replace "1 << N" by "2 ** N" */
316 case CPP_CLOSE_BRACE
:
320 case CPP_MINUS_MINUS
:
324 case CPP_HEADER_NAME
:
327 case CPP_OBJC_STRING
:
329 if (!macro
->fun_like
)
332 buffer
= cpp_spell_token (parse_in
, token
, buffer
, false);
336 prev_is_one
= is_one
;
343 if (macro
->fun_like
&& supported
)
345 char *start
= (char *) s
;
348 pp_string (pp
, " -- arg-macro: ");
350 if (*start
== '(' && buffer
[-1] == ')')
355 pp_string (pp
, "function ");
359 pp_string (pp
, "procedure ");
362 pp_string (pp
, (const char *) NODE_NAME (node
));
364 pp_string (pp
, (char *) params
);
366 pp_string (pp
, " -- ");
370 pp_string (pp
, "return ");
371 pp_string (pp
, start
);
375 pp_string (pp
, start
);
381 expanded_location sloc
= expand_location (macro
->line
);
383 if (sloc
.line
!= prev_line
+ 1)
387 prev_line
= sloc
.line
;
390 ada_name
= to_ada_name ((const char *) NODE_NAME (node
), NULL
);
391 pp_string (pp
, ada_name
);
393 pp_string (pp
, " : ");
396 pp_string (pp
, "aliased constant String");
398 pp_string (pp
, "aliased constant Character");
400 pp_string (pp
, "constant");
402 pp_string (pp
, " := ");
403 pp_string (pp
, (char *) s
);
406 pp_string (pp
, " & ASCII.NUL");
408 pp_string (pp
, "; -- ");
409 pp_string (pp
, sloc
.file
);
411 pp_scalar (pp
, "%d", sloc
.line
);
416 pp_string (pp
, " -- unsupported macro: ");
417 pp_string (pp
, (const char *) cpp_macro_definition (parse_in
, node
));
426 static const char *source_file
;
427 static int max_ada_macros
;
429 /* Callback used to count the number of relevant macros from
430 cpp_forall_identifiers. PFILE and V are not used. NODE is the current macro
434 count_ada_macro (cpp_reader
*pfile ATTRIBUTE_UNUSED
, cpp_hashnode
*node
,
435 void *v ATTRIBUTE_UNUSED
)
437 const cpp_macro
*macro
= node
->value
.macro
;
439 if (node
->type
== NT_MACRO
&& !(node
->flags
& NODE_BUILTIN
)
441 && *NODE_NAME (node
) != '_'
442 && LOCATION_FILE (macro
->line
) == source_file
)
448 static int store_ada_macro_index
;
450 /* Callback used to store relevant macros from cpp_forall_identifiers.
451 PFILE is not used. NODE is the current macro to store if relevant.
452 MACROS is an array of cpp_hashnode* used to store NODE. */
455 store_ada_macro (cpp_reader
*pfile ATTRIBUTE_UNUSED
,
456 cpp_hashnode
*node
, void *macros
)
458 const cpp_macro
*macro
= node
->value
.macro
;
460 if (node
->type
== NT_MACRO
&& !(node
->flags
& NODE_BUILTIN
)
462 && *NODE_NAME (node
) != '_'
463 && LOCATION_FILE (macro
->line
) == source_file
)
464 ((cpp_hashnode
**) macros
)[store_ada_macro_index
++] = node
;
469 /* Callback used to compare (during qsort) macros. NODE1 and NODE2 are the
470 two macro nodes to compare. */
473 compare_macro (const void *node1
, const void *node2
)
475 typedef const cpp_hashnode
*const_hnode
;
477 const_hnode n1
= *(const const_hnode
*) node1
;
478 const_hnode n2
= *(const const_hnode
*) node2
;
480 return n1
->value
.macro
->line
- n2
->value
.macro
->line
;
483 /* Dump in PP all relevant macros appearing in FILE. */
486 dump_ada_macros (pretty_printer
*pp
, const char* file
)
488 cpp_hashnode
**macros
;
490 /* Initialize file-scope variables. */
492 store_ada_macro_index
= 0;
495 /* Count all potentially relevant macros, and then sort them by sloc. */
496 cpp_forall_identifiers (parse_in
, count_ada_macro
, NULL
);
497 macros
= XALLOCAVEC (cpp_hashnode
*, max_ada_macros
);
498 cpp_forall_identifiers (parse_in
, store_ada_macro
, macros
);
499 qsort (macros
, max_ada_macros
, sizeof (cpp_hashnode
*), compare_macro
);
501 print_ada_macros (pp
, macros
, max_ada_macros
);
504 /* Current source file being handled. */
506 static const char *source_file_base
;
508 /* Compare the declaration (DECL) of struct-like types based on the sloc of
509 their last field (if LAST is true), so that more nested types collate before
511 If ORIG_TYPE is true, also consider struct with a DECL_ORIGINAL_TYPE. */
514 decl_sloc_common (const_tree decl
, bool last
, bool orig_type
)
516 tree type
= TREE_TYPE (decl
);
518 if (TREE_CODE (decl
) == TYPE_DECL
519 && (orig_type
|| !DECL_ORIGINAL_TYPE (decl
))
520 && RECORD_OR_UNION_TYPE_P (type
)
521 && TYPE_FIELDS (type
))
523 tree f
= TYPE_FIELDS (type
);
526 while (TREE_CHAIN (f
))
529 return DECL_SOURCE_LOCATION (f
);
532 return DECL_SOURCE_LOCATION (decl
);
535 /* Return sloc of DECL, using sloc of last field if LAST is true. */
538 decl_sloc (const_tree decl
, bool last
)
540 return decl_sloc_common (decl
, last
, false);
543 /* Compare two locations LHS and RHS. */
546 compare_location (location_t lhs
, location_t rhs
)
548 expanded_location xlhs
= expand_location (lhs
);
549 expanded_location xrhs
= expand_location (rhs
);
551 if (xlhs
.file
!= xrhs
.file
)
552 return filename_cmp (xlhs
.file
, xrhs
.file
);
554 if (xlhs
.line
!= xrhs
.line
)
555 return xlhs
.line
- xrhs
.line
;
557 if (xlhs
.column
!= xrhs
.column
)
558 return xlhs
.column
- xrhs
.column
;
563 /* Compare two declarations (LP and RP) by their source location. */
566 compare_node (const void *lp
, const void *rp
)
568 const_tree lhs
= *((const tree
*) lp
);
569 const_tree rhs
= *((const tree
*) rp
);
571 return compare_location (decl_sloc (lhs
, true), decl_sloc (rhs
, true));
574 /* Compare two comments (LP and RP) by their source location. */
577 compare_comment (const void *lp
, const void *rp
)
579 const cpp_comment
*lhs
= (const cpp_comment
*) lp
;
580 const cpp_comment
*rhs
= (const cpp_comment
*) rp
;
582 return compare_location (lhs
->sloc
, rhs
->sloc
);
585 static tree
*to_dump
= NULL
;
586 static int to_dump_count
= 0;
588 /* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped
589 by a subsequent call to dump_ada_nodes. */
592 collect_ada_nodes (tree t
, const char *source_file
)
595 int i
= to_dump_count
;
597 /* Count the likely relevant nodes: do not dump builtins (they are irrelevant
598 in the context of bindings) and namespaces (we do not handle them properly
600 for (n
= t
; n
; n
= TREE_CHAIN (n
))
601 if (!DECL_IS_BUILTIN (n
)
602 && TREE_CODE (n
) != NAMESPACE_DECL
603 && LOCATION_FILE (decl_sloc (n
, false)) == source_file
)
606 /* Allocate sufficient storage for all nodes. */
607 to_dump
= XRESIZEVEC (tree
, to_dump
, to_dump_count
);
609 /* Store the relevant nodes. */
610 for (n
= t
; n
; n
= TREE_CHAIN (n
))
611 if (!DECL_IS_BUILTIN (n
)
612 && TREE_CODE (n
) != NAMESPACE_DECL
613 && LOCATION_FILE (decl_sloc (n
, false)) == source_file
)
617 /* Call back for walk_tree to clear the TREE_VISITED flag of TP. */
620 unmark_visited_r (tree
*tp
, int *walk_subtrees ATTRIBUTE_UNUSED
,
621 void *data ATTRIBUTE_UNUSED
)
623 if (TREE_VISITED (*tp
))
624 TREE_VISITED (*tp
) = 0;
631 /* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls
632 to collect_ada_nodes. */
635 dump_ada_nodes (pretty_printer
*pp
, const char *source_file
)
638 cpp_comment_table
*comments
;
640 /* Sort the table of declarations to dump by sloc. */
641 qsort (to_dump
, to_dump_count
, sizeof (tree
), compare_node
);
643 /* Fetch the table of comments. */
644 comments
= cpp_get_comments (parse_in
);
646 /* Sort the comments table by sloc. */
647 if (comments
->count
> 1)
648 qsort (comments
->entries
, comments
->count
, sizeof (cpp_comment
),
651 /* Interleave comments and declarations in line number order. */
655 /* Advance j until comment j is in this file. */
656 while (j
!= comments
->count
657 && LOCATION_FILE (comments
->entries
[j
].sloc
) != source_file
)
660 /* Advance j until comment j is not a duplicate. */
661 while (j
< comments
->count
- 1
662 && !compare_comment (&comments
->entries
[j
],
663 &comments
->entries
[j
+ 1]))
666 /* Write decls until decl i collates after comment j. */
667 while (i
!= to_dump_count
)
669 if (j
== comments
->count
670 || LOCATION_LINE (decl_sloc (to_dump
[i
], false))
671 < LOCATION_LINE (comments
->entries
[j
].sloc
))
672 print_generic_ada_decl (pp
, to_dump
[i
++], source_file
);
677 /* Write comment j, if there is one. */
678 if (j
!= comments
->count
)
679 print_comment (pp
, comments
->entries
[j
++].comment
);
681 } while (i
!= to_dump_count
|| j
!= comments
->count
);
683 /* Clear the TREE_VISITED flag over each subtree we've dumped. */
684 for (i
= 0; i
< to_dump_count
; i
++)
685 walk_tree (&to_dump
[i
], unmark_visited_r
, NULL
, NULL
);
687 /* Finalize the to_dump table. */
696 /* Print a COMMENT to the output stream PP. */
699 print_comment (pretty_printer
*pp
, const char *comment
)
701 int len
= strlen (comment
);
702 char *str
= XALLOCAVEC (char, len
+ 1);
704 bool extra_newline
= false;
706 memcpy (str
, comment
, len
+ 1);
708 /* Trim C/C++ comment indicators. */
709 if (str
[len
- 2] == '*' && str
[len
- 1] == '/')
716 tok
= strtok (str
, "\n");
718 pp_string (pp
, " --");
721 tok
= strtok (NULL
, "\n");
723 /* Leave a blank line after multi-line comments. */
725 extra_newline
= true;
732 /* Print declaration DECL to PP in Ada syntax. The current source file being
733 handled is SOURCE_FILE. */
736 print_generic_ada_decl (pretty_printer
*pp
, tree decl
, const char *source_file
)
738 source_file_base
= source_file
;
740 if (print_ada_declaration (pp
, decl
, 0, INDENT_INCR
))
747 /* Dump a newline and indent BUFFER by SPC chars. */
750 newline_and_indent (pretty_printer
*buffer
, int spc
)
756 struct with
{ char *s
; const char *in_file
; int limited
; };
757 static struct with
*withs
= NULL
;
758 static int withs_max
= 4096;
759 static int with_len
= 0;
761 /* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is
762 true), if not already done. */
765 append_withs (const char *s
, int limited_access
)
770 withs
= XNEWVEC (struct with
, withs_max
);
772 if (with_len
== withs_max
)
775 withs
= XRESIZEVEC (struct with
, withs
, withs_max
);
778 for (i
= 0; i
< with_len
; i
++)
779 if (!strcmp (s
, withs
[i
].s
)
780 && source_file_base
== withs
[i
].in_file
)
782 withs
[i
].limited
&= limited_access
;
786 withs
[with_len
].s
= xstrdup (s
);
787 withs
[with_len
].in_file
= source_file_base
;
788 withs
[with_len
].limited
= limited_access
;
792 /* Reset "with" clauses. */
795 reset_ada_withs (void)
802 for (i
= 0; i
< with_len
; i
++)
810 /* Dump "with" clauses in F. */
813 dump_ada_withs (FILE *f
)
817 fprintf (f
, "with Interfaces.C; use Interfaces.C;\n");
819 for (i
= 0; i
< with_len
; i
++)
821 (f
, "%swith %s;\n", withs
[i
].limited
? "limited " : "", withs
[i
].s
);
824 /* Return suitable Ada package name from FILE. */
827 get_ada_package (const char *file
)
835 s
= strstr (file
, "/include/");
839 base
= lbasename (file
);
841 if (ada_specs_parent
== NULL
)
844 plen
= strlen (ada_specs_parent
) + 1;
846 res
= XNEWVEC (char, plen
+ strlen (base
) + 1);
847 if (ada_specs_parent
!= NULL
) {
848 strcpy (res
, ada_specs_parent
);
852 for (i
= plen
; *base
; base
++, i
++)
864 res
[i
] = (i
== 0 || res
[i
- 1] == '.' || res
[i
- 1] == '_') ? 'u' : '_';
876 static const char *ada_reserved
[] = {
877 "abort", "abs", "abstract", "accept", "access", "aliased", "all", "and",
878 "array", "at", "begin", "body", "case", "constant", "declare", "delay",
879 "delta", "digits", "do", "else", "elsif", "end", "entry", "exception",
880 "exit", "for", "function", "generic", "goto", "if", "in", "interface", "is",
881 "limited", "loop", "mod", "new", "not", "null", "others", "out", "of", "or",
882 "overriding", "package", "pragma", "private", "procedure", "protected",
883 "raise", "range", "record", "rem", "renames", "requeue", "return", "reverse",
884 "select", "separate", "subtype", "synchronized", "tagged", "task",
885 "terminate", "then", "type", "until", "use", "when", "while", "with", "xor",
888 /* ??? would be nice to specify this list via a config file, so that users
889 can create their own dictionary of conflicts. */
890 static const char *c_duplicates
[] = {
891 /* system will cause troubles with System.Address. */
894 /* The following values have other definitions with same name/other
900 "rl_readline_version",
906 /* Return a declaration tree corresponding to TYPE. */
909 get_underlying_decl (tree type
)
911 tree decl
= NULL_TREE
;
913 if (type
== NULL_TREE
)
916 /* type is a declaration. */
920 /* type is a typedef. */
921 if (TYPE_P (type
) && TYPE_NAME (type
) && DECL_P (TYPE_NAME (type
)))
922 decl
= TYPE_NAME (type
);
924 /* TYPE_STUB_DECL has been set for type. */
925 if (TYPE_P (type
) && TYPE_STUB_DECL (type
) &&
926 DECL_P (TYPE_STUB_DECL (type
)))
927 decl
= TYPE_STUB_DECL (type
);
932 /* Return whether TYPE has static fields. */
935 has_static_fields (const_tree type
)
939 if (!type
|| !RECORD_OR_UNION_TYPE_P (type
))
942 for (tmp
= TYPE_FIELDS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
943 if (DECL_NAME (tmp
) && TREE_STATIC (tmp
))
949 /* Return whether TYPE corresponds to an Ada tagged type (has a dispatch
953 is_tagged_type (const_tree type
)
957 if (!type
|| !RECORD_OR_UNION_TYPE_P (type
))
960 /* TYPE_METHODS is only set on the main variant. */
961 type
= TYPE_MAIN_VARIANT (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 /* TYPE_METHODS is only set on the main variant. */
992 type
= TYPE_MAIN_VARIANT (type
);
994 /* If there are user-defined methods, they are deemed non-trivial. */
995 for (tmp
= TYPE_METHODS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
996 if (!DECL_ARTIFICIAL (tmp
))
1002 /* Generate a legal Ada name from a C NAME, returning a malloc'd string.
1003 SPACE_FOUND, if not NULL, is used to indicate whether a space was found in
1007 to_ada_name (const char *name
, int *space_found
)
1010 int len
= strlen (name
);
1013 char *s
= XNEWVEC (char, len
* 2 + 5);
1017 *space_found
= false;
1019 /* Add trailing "c_" if name is an Ada reserved word. */
1020 for (names
= ada_reserved
; *names
; names
++)
1021 if (!strcasecmp (name
, *names
))
1030 /* Add trailing "c_" if name is an potential case sensitive duplicate. */
1031 for (names
= c_duplicates
; *names
; names
++)
1032 if (!strcmp (name
, *names
))
1040 for (j
= 0; name
[j
] == '_'; j
++)
1045 else if (*name
== '.' || *name
== '$')
1055 /* Replace unsuitable characters for Ada identifiers. */
1057 for (; j
< len
; j
++)
1062 *space_found
= true;
1066 /* ??? missing some C++ operators. */
1070 if (name
[j
+ 1] == '=')
1085 if (name
[j
+ 1] == '=')
1103 s
[len2
++] = name
[j
] == '&' ? 'a' : name
[j
] == '|' ? 'o' : 'x';
1105 if (name
[j
+ 1] == '=')
1118 if (s
[len2
- 1] != '_')
1121 switch (name
[j
+ 1]) {
1124 switch (name
[j
- 1]) {
1125 case '+': s
[len2
++] = 'p'; break; /* + */
1126 case '-': s
[len2
++] = 'm'; break; /* - */
1127 case '*': s
[len2
++] = 't'; break; /* * */
1128 case '/': s
[len2
++] = 'd'; break; /* / */
1134 switch (name
[j
- 1]) {
1135 case '+': s
[len2
++] = 'p'; break; /* += */
1136 case '-': s
[len2
++] = 'm'; break; /* -= */
1137 case '*': s
[len2
++] = 't'; break; /* *= */
1138 case '/': s
[len2
++] = 'd'; break; /* /= */
1172 c
= name
[j
] == '<' ? 'l' : 'g';
1175 switch (name
[j
+ 1]) {
1201 if (len2
&& s
[len2
- 1] == '_')
1206 s
[len2
++] = name
[j
];
1209 if (s
[len2
- 1] == '_')
1217 /* Return true if DECL refers to a C++ class type for which a
1218 separate enclosing package has been or should be generated. */
1221 separate_class_package (tree decl
)
1223 tree type
= TREE_TYPE (decl
);
1224 return has_nontrivial_methods (type
) || has_static_fields (type
);
1227 static bool package_prefix
= true;
1229 /* Dump in BUFFER the name of an identifier NODE of type TYPE, following Ada
1230 syntax. LIMITED_ACCESS indicates whether NODE can be accessed via a limited
1231 'with' clause rather than a regular 'with' clause. */
1234 pp_ada_tree_identifier (pretty_printer
*buffer
, tree node
, tree type
,
1237 const char *name
= IDENTIFIER_POINTER (node
);
1238 int space_found
= false;
1239 char *s
= to_ada_name (name
, &space_found
);
1242 /* If the entity is a type and comes from another file, generate "package"
1244 decl
= get_underlying_decl (type
);
1248 expanded_location xloc
= expand_location (decl_sloc (decl
, false));
1250 if (xloc
.file
&& xloc
.line
)
1252 if (xloc
.file
!= source_file_base
)
1254 switch (TREE_CODE (type
))
1259 case FIXED_POINT_TYPE
:
1261 case REFERENCE_TYPE
:
1266 case QUAL_UNION_TYPE
:
1270 char *s1
= get_ada_package (xloc
.file
);
1271 append_withs (s1
, limited_access
);
1272 pp_string (buffer
, s1
);
1281 /* Generate the additional package prefix for C++ classes. */
1282 if (separate_class_package (decl
))
1284 pp_string (buffer
, "Class_");
1285 pp_string (buffer
, s
);
1293 if (!strcmp (s
, "short_int"))
1294 pp_string (buffer
, "short");
1295 else if (!strcmp (s
, "short_unsigned_int"))
1296 pp_string (buffer
, "unsigned_short");
1297 else if (!strcmp (s
, "unsigned_int"))
1298 pp_string (buffer
, "unsigned");
1299 else if (!strcmp (s
, "long_int"))
1300 pp_string (buffer
, "long");
1301 else if (!strcmp (s
, "long_unsigned_int"))
1302 pp_string (buffer
, "unsigned_long");
1303 else if (!strcmp (s
, "long_long_int"))
1304 pp_string (buffer
, "Long_Long_Integer");
1305 else if (!strcmp (s
, "long_long_unsigned_int"))
1309 append_withs ("Interfaces.C.Extensions", false);
1310 pp_string (buffer
, "Extensions.unsigned_long_long");
1313 pp_string (buffer
, "unsigned_long_long");
1316 pp_string(buffer
, s
);
1318 if (!strcmp (s
, "bool"))
1322 append_withs ("Interfaces.C.Extensions", false);
1323 pp_string (buffer
, "Extensions.bool");
1326 pp_string (buffer
, "bool");
1329 pp_string(buffer
, s
);
1334 /* Dump in BUFFER the assembly name of T. */
1337 pp_asm_name (pretty_printer
*buffer
, tree t
)
1339 tree name
= DECL_ASSEMBLER_NAME (t
);
1340 char *ada_name
= XALLOCAVEC (char, IDENTIFIER_LENGTH (name
) + 1), *s
;
1341 const char *ident
= IDENTIFIER_POINTER (name
);
1343 for (s
= ada_name
; *ident
; ident
++)
1347 else if (*ident
!= '*')
1352 pp_string (buffer
, ada_name
);
1355 /* Dump in BUFFER the name of a DECL node if set, following Ada syntax.
1356 LIMITED_ACCESS indicates whether NODE can be accessed via a limited
1357 'with' clause rather than a regular 'with' clause. */
1360 dump_ada_decl_name (pretty_printer
*buffer
, tree decl
, int limited_access
)
1362 if (DECL_NAME (decl
))
1363 pp_ada_tree_identifier (buffer
, DECL_NAME (decl
), decl
, limited_access
);
1366 tree type_name
= TYPE_NAME (TREE_TYPE (decl
));
1370 pp_string (buffer
, "anon");
1371 if (TREE_CODE (decl
) == FIELD_DECL
)
1372 pp_scalar (buffer
, "%d", DECL_UID (decl
));
1374 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (decl
)));
1376 else if (TREE_CODE (type_name
) == IDENTIFIER_NODE
)
1377 pp_ada_tree_identifier (buffer
, type_name
, decl
, limited_access
);
1381 /* Dump in BUFFER a name based on both T1 and T2, followed by S. */
1384 dump_ada_double_name (pretty_printer
*buffer
, tree t1
, tree t2
, const char *s
)
1387 pp_ada_tree_identifier (buffer
, DECL_NAME (t1
), t1
, false);
1390 pp_string (buffer
, "anon");
1391 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (t1
)));
1394 pp_underscore (buffer
);
1397 pp_ada_tree_identifier (buffer
, DECL_NAME (t2
), t2
, false);
1400 pp_string (buffer
, "anon");
1401 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (t2
)));
1404 pp_string (buffer
, s
);
1407 /* Dump in BUFFER pragma Import C/CPP on a given node T. */
1410 dump_ada_import (pretty_printer
*buffer
, tree t
)
1412 const char *name
= IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (t
));
1413 int is_stdcall
= TREE_CODE (t
) == FUNCTION_DECL
&&
1414 lookup_attribute ("stdcall", TYPE_ATTRIBUTES (TREE_TYPE (t
)));
1417 pp_string (buffer
, "pragma Import (Stdcall, ");
1418 else if (name
[0] == '_' && name
[1] == 'Z')
1419 pp_string (buffer
, "pragma Import (CPP, ");
1421 pp_string (buffer
, "pragma Import (C, ");
1423 dump_ada_decl_name (buffer
, t
, false);
1424 pp_string (buffer
, ", \"");
1427 pp_string (buffer
, IDENTIFIER_POINTER (DECL_NAME (t
)));
1429 pp_asm_name (buffer
, t
);
1431 pp_string (buffer
, "\");");
1434 /* Check whether T and its type have different names, and append "the_"
1435 otherwise in BUFFER. */
1438 check_name (pretty_printer
*buffer
, tree t
)
1441 tree tmp
= TREE_TYPE (t
);
1443 while (TREE_CODE (tmp
) == POINTER_TYPE
&& !TYPE_NAME (tmp
))
1444 tmp
= TREE_TYPE (tmp
);
1446 if (TREE_CODE (tmp
) != FUNCTION_TYPE
)
1448 if (TREE_CODE (tmp
) == IDENTIFIER_NODE
)
1449 s
= IDENTIFIER_POINTER (tmp
);
1450 else if (!TYPE_NAME (tmp
))
1452 else if (TREE_CODE (TYPE_NAME (tmp
)) == IDENTIFIER_NODE
)
1453 s
= IDENTIFIER_POINTER (TYPE_NAME (tmp
));
1455 s
= IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp
)));
1457 if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t
)), s
))
1458 pp_string (buffer
, "the_");
1462 /* Dump in BUFFER a function declaration FUNC with Ada syntax.
1463 IS_METHOD indicates whether FUNC is a C++ method.
1464 IS_CONSTRUCTOR whether FUNC is a C++ constructor.
1465 IS_DESTRUCTOR whether FUNC is a C++ destructor.
1466 SPC is the current indentation level. */
1469 dump_ada_function_declaration (pretty_printer
*buffer
, tree func
,
1470 int is_method
, int is_constructor
,
1471 int is_destructor
, int spc
)
1474 const tree node
= TREE_TYPE (func
);
1476 int num
= 0, num_args
= 0, have_args
= true, have_ellipsis
= false;
1478 /* Compute number of arguments. */
1479 arg
= TYPE_ARG_TYPES (node
);
1483 while (TREE_CHAIN (arg
) && arg
!= error_mark_node
)
1486 arg
= TREE_CHAIN (arg
);
1489 if (TREE_CODE (TREE_VALUE (arg
)) != VOID_TYPE
)
1492 have_ellipsis
= true;
1503 newline_and_indent (buffer
, spc
+ 1);
1508 pp_left_paren (buffer
);
1511 if (TREE_CODE (func
) == FUNCTION_DECL
)
1512 arg
= DECL_ARGUMENTS (func
);
1516 if (arg
== NULL_TREE
)
1519 arg
= TYPE_ARG_TYPES (node
);
1521 if (arg
&& TREE_CODE (TREE_VALUE (arg
)) == VOID_TYPE
)
1526 arg
= TREE_CHAIN (arg
);
1528 /* Print the argument names (if available) & types. */
1530 for (num
= 1; num
<= num_args
; num
++)
1534 if (DECL_NAME (arg
))
1536 check_name (buffer
, arg
);
1537 pp_ada_tree_identifier (buffer
, DECL_NAME (arg
), 0, false);
1538 pp_string (buffer
, " : ");
1542 sprintf (buf
, "arg%d : ", num
);
1543 pp_string (buffer
, buf
);
1546 dump_generic_ada_node (buffer
, TREE_TYPE (arg
), node
, spc
, 0, true);
1550 sprintf (buf
, "arg%d : ", num
);
1551 pp_string (buffer
, buf
);
1552 dump_generic_ada_node (buffer
, TREE_VALUE (arg
), node
, spc
, 0, true);
1555 if (TREE_TYPE (arg
) && TREE_TYPE (TREE_TYPE (arg
))
1556 && is_tagged_type (TREE_TYPE (TREE_TYPE (arg
))))
1559 || (num
!= 1 || (!DECL_VINDEX (func
) && !is_constructor
)))
1560 pp_string (buffer
, "'Class");
1563 arg
= TREE_CHAIN (arg
);
1567 pp_semicolon (buffer
);
1570 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
1578 pp_string (buffer
, " -- , ...");
1579 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
1583 pp_right_paren (buffer
);
1587 /* Dump in BUFFER all the domains associated with an array NODE,
1588 using Ada syntax. SPC is the current indentation level. */
1591 dump_ada_array_domains (pretty_printer
*buffer
, tree node
, int spc
)
1594 pp_left_paren (buffer
);
1596 for (; TREE_CODE (node
) == ARRAY_TYPE
; node
= TREE_TYPE (node
))
1598 tree domain
= TYPE_DOMAIN (node
);
1602 tree min
= TYPE_MIN_VALUE (domain
);
1603 tree max
= TYPE_MAX_VALUE (domain
);
1606 pp_string (buffer
, ", ");
1610 dump_generic_ada_node (buffer
, min
, NULL_TREE
, spc
, 0, true);
1611 pp_string (buffer
, " .. ");
1613 /* If the upper bound is zero, gcc may generate a NULL_TREE
1614 for TYPE_MAX_VALUE rather than an integer_cst. */
1616 dump_generic_ada_node (buffer
, max
, NULL_TREE
, spc
, 0, true);
1618 pp_string (buffer
, "0");
1621 pp_string (buffer
, "size_t");
1623 pp_right_paren (buffer
);
1626 /* Dump in BUFFER file:line information related to NODE. */
1629 dump_sloc (pretty_printer
*buffer
, tree node
)
1631 expanded_location xloc
;
1636 xloc
= expand_location (DECL_SOURCE_LOCATION (node
));
1637 else if (EXPR_HAS_LOCATION (node
))
1638 xloc
= expand_location (EXPR_LOCATION (node
));
1642 pp_string (buffer
, xloc
.file
);
1644 pp_decimal_int (buffer
, xloc
.line
);
1648 /* Return true if T designates a one dimension array of "char". */
1651 is_char_array (tree t
)
1656 /* Retrieve array's type. */
1658 while (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1661 tmp
= TREE_TYPE (tmp
);
1664 tmp
= TREE_TYPE (tmp
);
1665 return num_dim
== 1 && TREE_CODE (tmp
) == INTEGER_TYPE
1666 && !strcmp (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp
))), "char");
1669 /* Dump in BUFFER an array type T in Ada syntax. Assume that the "type"
1670 keyword and name have already been printed. SPC is the indentation
1674 dump_ada_array_type (pretty_printer
*buffer
, tree t
, int spc
)
1677 bool char_array
= is_char_array (t
);
1679 /* Special case char arrays. */
1682 pp_string (buffer
, "Interfaces.C.char_array ");
1685 pp_string (buffer
, "array ");
1687 /* Print the dimensions. */
1688 dump_ada_array_domains (buffer
, TREE_TYPE (t
), spc
);
1690 /* Retrieve array's type. */
1691 tmp
= TREE_TYPE (t
);
1692 while (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1693 tmp
= TREE_TYPE (tmp
);
1695 /* Print array's type. */
1698 pp_string (buffer
, " of ");
1700 if (TREE_CODE (TREE_TYPE (tmp
)) != POINTER_TYPE
)
1701 pp_string (buffer
, "aliased ");
1703 dump_generic_ada_node
1704 (buffer
, TREE_TYPE (tmp
), TREE_TYPE (t
), spc
, false, true);
1708 /* Dump in BUFFER type names associated with a template, each prepended with
1709 '_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS. SPC is
1710 the indentation level. */
1713 dump_template_types (pretty_printer
*buffer
, tree types
, int spc
)
1716 size_t len
= TREE_VEC_LENGTH (types
);
1718 for (i
= 0; i
< len
; i
++)
1720 tree elem
= TREE_VEC_ELT (types
, i
);
1721 pp_underscore (buffer
);
1722 if (!dump_generic_ada_node (buffer
, elem
, 0, spc
, false, true))
1724 pp_string (buffer
, "unknown");
1725 pp_scalar (buffer
, "%lu", (unsigned long) TREE_HASH (elem
));
1730 /* Dump in BUFFER the contents of all class instantiations associated with
1731 a given template T. SPC is the indentation level. */
1734 dump_ada_template (pretty_printer
*buffer
, tree t
, int spc
)
1736 /* DECL_SIZE_UNIT is DECL_TEMPLATE_INSTANTIATIONS in this context. */
1737 tree inst
= DECL_SIZE_UNIT (t
);
1738 /* This emulates DECL_TEMPLATE_RESULT in this context. */
1739 struct tree_template_decl
{
1740 struct tree_decl_common common
;
1744 tree result
= ((struct tree_template_decl
*) t
)->result
;
1747 /* Don't look at template declarations declaring something coming from
1748 another file. This can occur for template friend declarations. */
1749 if (LOCATION_FILE (decl_sloc (result
, false))
1750 != LOCATION_FILE (decl_sloc (t
, false)))
1753 for (; inst
&& inst
!= error_mark_node
; inst
= TREE_CHAIN (inst
))
1755 tree types
= TREE_PURPOSE (inst
);
1756 tree instance
= TREE_VALUE (inst
);
1758 if (TREE_VEC_LENGTH (types
) == 0)
1761 if (!RECORD_OR_UNION_TYPE_P (instance
) || !TYPE_METHODS (instance
))
1764 /* We are interested in concrete template instantiations only: skip
1765 partially specialized nodes. */
1766 if ((TREE_CODE (instance
) == RECORD_TYPE
1767 || TREE_CODE (instance
) == UNION_TYPE
)
1768 && cpp_check
&& cpp_check (instance
, HAS_DEPENDENT_TEMPLATE_ARGS
))
1773 pp_string (buffer
, "package ");
1774 package_prefix
= false;
1775 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1776 dump_template_types (buffer
, types
, spc
);
1777 pp_string (buffer
, " is");
1779 newline_and_indent (buffer
, spc
);
1781 TREE_VISITED (get_underlying_decl (instance
)) = 1;
1782 pp_string (buffer
, "type ");
1783 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1784 package_prefix
= true;
1786 if (is_tagged_type (instance
))
1787 pp_string (buffer
, " is tagged limited ");
1789 pp_string (buffer
, " is limited ");
1791 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, false);
1792 pp_newline (buffer
);
1794 newline_and_indent (buffer
, spc
);
1796 pp_string (buffer
, "end;");
1797 newline_and_indent (buffer
, spc
);
1798 pp_string (buffer
, "use ");
1799 package_prefix
= false;
1800 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1801 dump_template_types (buffer
, types
, spc
);
1802 package_prefix
= true;
1803 pp_semicolon (buffer
);
1804 pp_newline (buffer
);
1805 pp_newline (buffer
);
1808 return num_inst
> 0;
1811 /* Return true if NODE is a simple enum types, that can be mapped to an
1812 Ada enum type directly. */
1815 is_simple_enum (tree node
)
1817 HOST_WIDE_INT count
= 0;
1820 for (value
= TYPE_VALUES (node
); value
; value
= TREE_CHAIN (value
))
1822 tree int_val
= TREE_VALUE (value
);
1824 if (TREE_CODE (int_val
) != INTEGER_CST
)
1825 int_val
= DECL_INITIAL (int_val
);
1827 if (!tree_fits_shwi_p (int_val
))
1829 else if (tree_to_shwi (int_val
) != count
)
1838 static bool bitfield_used
= false;
1840 /* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
1841 TYPE. SPC is the indentation level. LIMITED_ACCESS indicates whether NODE
1842 can be referenced via a "limited with" clause. NAME_ONLY indicates whether
1843 we should only dump the name of NODE, instead of its full declaration. */
1846 dump_generic_ada_node (pretty_printer
*buffer
, tree node
, tree type
, int spc
,
1847 int limited_access
, bool name_only
)
1849 if (node
== NULL_TREE
)
1852 switch (TREE_CODE (node
))
1855 pp_string (buffer
, "<<< error >>>");
1858 case IDENTIFIER_NODE
:
1859 pp_ada_tree_identifier (buffer
, node
, type
, limited_access
);
1863 pp_string (buffer
, "--- unexpected node: TREE_LIST");
1867 dump_generic_ada_node
1868 (buffer
, BINFO_TYPE (node
), type
, spc
, limited_access
, name_only
);
1871 pp_string (buffer
, "--- unexpected node: TREE_VEC");
1877 append_withs ("System", false);
1878 pp_string (buffer
, "System.Address");
1881 pp_string (buffer
, "address");
1885 pp_string (buffer
, "<vector>");
1889 pp_string (buffer
, "<complex>");
1894 dump_generic_ada_node
1895 (buffer
, TYPE_NAME (node
), node
, spc
, 0, true);
1898 tree value
= TYPE_VALUES (node
);
1900 if (is_simple_enum (node
))
1904 newline_and_indent (buffer
, spc
- 1);
1905 pp_left_paren (buffer
);
1906 for (; value
; value
= TREE_CHAIN (value
))
1913 newline_and_indent (buffer
, spc
);
1916 pp_ada_tree_identifier
1917 (buffer
, TREE_PURPOSE (value
), node
, false);
1919 pp_string (buffer
, ");");
1921 newline_and_indent (buffer
, spc
);
1922 pp_string (buffer
, "pragma Convention (C, ");
1923 dump_generic_ada_node
1924 (buffer
, DECL_NAME (type
) ? type
: TYPE_NAME (node
), type
,
1926 pp_right_paren (buffer
);
1930 pp_string (buffer
, "unsigned");
1931 for (; value
; value
= TREE_CHAIN (value
))
1933 pp_semicolon (buffer
);
1934 newline_and_indent (buffer
, spc
);
1936 pp_ada_tree_identifier
1937 (buffer
, TREE_PURPOSE (value
), node
, false);
1938 pp_string (buffer
, " : constant ");
1940 dump_generic_ada_node
1941 (buffer
, DECL_NAME (type
) ? type
: TYPE_NAME (node
), type
,
1944 pp_string (buffer
, " := ");
1945 dump_generic_ada_node
1947 TREE_CODE (TREE_VALUE (value
)) == INTEGER_CST
?
1948 TREE_VALUE (value
) : DECL_INITIAL (TREE_VALUE (value
)),
1949 node
, spc
, false, true);
1957 case FIXED_POINT_TYPE
:
1960 enum tree_code_class tclass
;
1962 tclass
= TREE_CODE_CLASS (TREE_CODE (node
));
1964 if (tclass
== tcc_declaration
)
1966 if (DECL_NAME (node
))
1967 pp_ada_tree_identifier
1968 (buffer
, DECL_NAME (node
), 0, limited_access
);
1970 pp_string (buffer
, "<unnamed type decl>");
1972 else if (tclass
== tcc_type
)
1974 if (TYPE_NAME (node
))
1976 if (TREE_CODE (TYPE_NAME (node
)) == IDENTIFIER_NODE
)
1977 pp_ada_tree_identifier (buffer
, TYPE_NAME (node
),
1978 node
, limited_access
);
1979 else if (TREE_CODE (TYPE_NAME (node
)) == TYPE_DECL
1980 && DECL_NAME (TYPE_NAME (node
)))
1981 dump_ada_decl_name (buffer
, TYPE_NAME (node
), limited_access
);
1983 pp_string (buffer
, "<unnamed type>");
1985 else if (TREE_CODE (node
) == INTEGER_TYPE
)
1987 append_withs ("Interfaces.C.Extensions", false);
1988 bitfield_used
= true;
1990 if (TYPE_PRECISION (node
) == 1)
1991 pp_string (buffer
, "Extensions.Unsigned_1");
1994 pp_string (buffer
, (TYPE_UNSIGNED (node
)
1995 ? "Extensions.Unsigned_"
1996 : "Extensions.Signed_"));
1997 pp_decimal_int (buffer
, TYPE_PRECISION (node
));
2001 pp_string (buffer
, "<unnamed type>");
2007 case REFERENCE_TYPE
:
2008 if (name_only
&& TYPE_NAME (node
))
2009 dump_generic_ada_node
2010 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2012 else if (TREE_CODE (TREE_TYPE (node
)) == FUNCTION_TYPE
)
2014 tree fnode
= TREE_TYPE (node
);
2017 if (VOID_TYPE_P (TREE_TYPE (fnode
)))
2019 is_function
= false;
2020 pp_string (buffer
, "access procedure");
2025 pp_string (buffer
, "access function");
2028 dump_ada_function_declaration
2029 (buffer
, node
, false, false, false, spc
+ INDENT_INCR
);
2033 pp_string (buffer
, " return ");
2034 dump_generic_ada_node
2035 (buffer
, TREE_TYPE (fnode
), type
, spc
, 0, true);
2038 /* If we are dumping the full type, it means we are part of a
2039 type definition and need also a Convention C pragma. */
2042 pp_semicolon (buffer
);
2043 newline_and_indent (buffer
, spc
);
2044 pp_string (buffer
, "pragma Convention (C, ");
2045 dump_generic_ada_node
2046 (buffer
, type
, 0, spc
, false, true);
2047 pp_right_paren (buffer
);
2052 int is_access
= false;
2053 unsigned int quals
= TYPE_QUALS (TREE_TYPE (node
));
2055 if (VOID_TYPE_P (TREE_TYPE (node
)))
2058 pp_string (buffer
, "new ");
2061 append_withs ("System", false);
2062 pp_string (buffer
, "System.Address");
2065 pp_string (buffer
, "address");
2069 if (TREE_CODE (node
) == POINTER_TYPE
2070 && TREE_CODE (TREE_TYPE (node
)) == INTEGER_TYPE
2072 (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME
2073 (TREE_TYPE (node
)))), "char"))
2076 pp_string (buffer
, "new ");
2080 pp_string (buffer
, "Interfaces.C.Strings.chars_ptr");
2081 append_withs ("Interfaces.C.Strings", false);
2084 pp_string (buffer
, "chars_ptr");
2088 /* For now, handle all access-to-access or
2089 access-to-unknown-structs as opaque system.address. */
2091 tree type_name
= TYPE_NAME (TREE_TYPE (node
));
2092 const_tree typ2
= !type
||
2093 DECL_P (type
) ? type
: TYPE_NAME (type
);
2094 const_tree underlying_type
=
2095 get_underlying_decl (TREE_TYPE (node
));
2097 if (TREE_CODE (TREE_TYPE (node
)) == POINTER_TYPE
2098 /* Pointer to pointer. */
2100 || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node
))
2101 && (!underlying_type
2102 || !TYPE_FIELDS (TREE_TYPE (underlying_type
))))
2103 /* Pointer to opaque structure. */
2105 || underlying_type
== NULL_TREE
2107 && !TREE_VISITED (underlying_type
)
2108 && !TREE_VISITED (type_name
)
2109 && !is_tagged_type (TREE_TYPE (node
))
2110 && DECL_SOURCE_FILE (underlying_type
)
2111 == source_file_base
)
2112 || (type_name
&& typ2
2113 && DECL_P (underlying_type
)
2115 && decl_sloc (underlying_type
, true)
2116 > decl_sloc (typ2
, true)
2117 && DECL_SOURCE_FILE (underlying_type
)
2118 == DECL_SOURCE_FILE (typ2
)))
2122 append_withs ("System", false);
2124 pp_string (buffer
, "new ");
2125 pp_string (buffer
, "System.Address");
2128 pp_string (buffer
, "address");
2132 if (!package_prefix
)
2133 pp_string (buffer
, "access");
2134 else if (AGGREGATE_TYPE_P (TREE_TYPE (node
)))
2136 if (!type
|| TREE_CODE (type
) != FUNCTION_DECL
)
2138 pp_string (buffer
, "access ");
2141 if (quals
& TYPE_QUAL_CONST
)
2142 pp_string (buffer
, "constant ");
2143 else if (!name_only
)
2144 pp_string (buffer
, "all ");
2146 else if (quals
& TYPE_QUAL_CONST
)
2147 pp_string (buffer
, "in ");
2151 pp_string (buffer
, "access ");
2152 /* ??? should be configurable: access or in out. */
2158 pp_string (buffer
, "access ");
2161 pp_string (buffer
, "all ");
2164 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node
))
2165 && type_name
!= NULL_TREE
)
2166 dump_generic_ada_node
2168 TREE_TYPE (node
), spc
, is_access
, true);
2170 dump_generic_ada_node
2171 (buffer
, TREE_TYPE (node
), TREE_TYPE (node
),
2180 dump_generic_ada_node
2181 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2183 dump_ada_array_type (buffer
, node
, spc
);
2188 case QUAL_UNION_TYPE
:
2191 if (TYPE_NAME (node
))
2192 dump_generic_ada_node
2193 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2196 pp_string (buffer
, "anon_");
2197 pp_scalar (buffer
, "%d", TYPE_UID (node
));
2201 print_ada_struct_decl (buffer
, node
, type
, spc
, true);
2205 /* We treat the upper half of the sizetype range as negative. This
2206 is consistent with the internal treatment and makes it possible
2207 to generate the (0 .. -1) range for flexible array members. */
2208 if (TREE_TYPE (node
) == sizetype
)
2209 node
= fold_convert (ssizetype
, node
);
2210 if (tree_fits_shwi_p (node
))
2211 pp_wide_integer (buffer
, tree_to_shwi (node
));
2212 else if (tree_fits_uhwi_p (node
))
2213 pp_unsigned_wide_integer (buffer
, tree_to_uhwi (node
));
2216 wide_int val
= node
;
2218 if (wi::neg_p (val
))
2223 sprintf (pp_buffer (buffer
)->digit_buffer
,
2224 "16#%" HOST_WIDE_INT_PRINT
"x",
2225 val
.elt (val
.get_len () - 1));
2226 for (i
= val
.get_len () - 2; i
>= 0; i
--)
2227 sprintf (pp_buffer (buffer
)->digit_buffer
,
2228 HOST_WIDE_INT_PRINT_PADDED_HEX
, val
.elt (i
));
2229 pp_string (buffer
, pp_buffer (buffer
)->digit_buffer
);
2242 dump_ada_decl_name (buffer
, node
, limited_access
);
2246 if (DECL_IS_BUILTIN (node
))
2248 /* Don't print the declaration of built-in types. */
2252 /* If we're in the middle of a declaration, defaults to
2256 append_withs ("System", false);
2257 pp_string (buffer
, "System.Address");
2260 pp_string (buffer
, "address");
2266 dump_ada_decl_name (buffer
, node
, limited_access
);
2269 if (is_tagged_type (TREE_TYPE (node
)))
2271 tree tmp
= TYPE_FIELDS (TREE_TYPE (node
));
2274 /* Look for ancestors. */
2275 for (; tmp
; tmp
= TREE_CHAIN (tmp
))
2277 if (!DECL_NAME (tmp
) && is_tagged_type (TREE_TYPE (tmp
)))
2281 pp_string (buffer
, "limited new ");
2285 pp_string (buffer
, " and ");
2288 (buffer
, TYPE_NAME (TREE_TYPE (tmp
)), false);
2292 pp_string (buffer
, first
? "tagged limited " : " with ");
2294 else if (has_nontrivial_methods (TREE_TYPE (node
)))
2295 pp_string (buffer
, "limited ");
2297 dump_generic_ada_node
2298 (buffer
, TREE_TYPE (node
), type
, spc
, false, false);
2305 case NAMESPACE_DECL
:
2306 dump_ada_decl_name (buffer
, node
, false);
2310 /* Ignore other nodes (e.g. expressions). */
2317 /* Dump in BUFFER NODE's methods. SPC is the indentation level. Return 1 if
2318 methods were printed, 0 otherwise.
2320 We do it in 2 passes: first, the regular methods, i.e. non-static member
2321 functions, are output immediately within the package created for the class
2322 so that they are considered as primitive operations in Ada; second, the
2323 static member functions are output in a nested package so that they are
2324 _not_ considered as primitive operations in Ada.
2326 This approach is necessary because the formers have the implicit 'this'
2327 pointer whereas the latters don't and, on 32-bit x86/Windows, the calling
2328 conventions for the 'this' pointer are special. Therefore, the compiler
2329 needs to be able to differentiate regular methods (with 'this' pointer)
2330 from static member functions that take a pointer to the class as first
2334 print_ada_methods (pretty_printer
*buffer
, tree node
, int spc
)
2336 bool has_static_methods
= false;
2340 if (!has_nontrivial_methods (node
))
2343 pp_semicolon (buffer
);
2345 /* First pass: the regular methods. */
2347 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2349 if (TREE_CODE (TREE_TYPE (t
)) != METHOD_TYPE
)
2351 has_static_methods
= true;
2357 pp_newline (buffer
);
2358 pp_newline (buffer
);
2361 res
= print_ada_declaration (buffer
, t
, node
, spc
);
2364 if (!has_static_methods
)
2367 pp_newline (buffer
);
2368 newline_and_indent (buffer
, spc
);
2370 /* Second pass: the static member functions. */
2371 pp_string (buffer
, "package Static is");
2372 pp_newline (buffer
);
2376 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2378 if (TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
)
2383 pp_newline (buffer
);
2384 pp_newline (buffer
);
2387 res
= print_ada_declaration (buffer
, t
, node
, spc
);
2391 newline_and_indent (buffer
, spc
);
2392 pp_string (buffer
, "end;");
2394 /* In order to save the clients from adding a second use clause for the
2395 nested package, we generate renamings for the static member functions
2396 in the package created for the class. */
2397 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2401 if (TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
)
2404 pp_newline (buffer
);
2405 newline_and_indent (buffer
, spc
);
2407 if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t
))))
2409 pp_string (buffer
, "procedure ");
2410 is_function
= false;
2414 pp_string (buffer
, "function ");
2418 dump_ada_decl_name (buffer
, t
, false);
2419 dump_ada_function_declaration (buffer
, t
, false, false, false, spc
);
2423 pp_string (buffer
, " return ");
2424 dump_generic_ada_node (buffer
, TREE_TYPE (TREE_TYPE (t
)), node
,
2428 pp_string (buffer
, " renames Static.");
2429 dump_ada_decl_name (buffer
, t
, false);
2430 pp_semicolon (buffer
);
2436 /* Dump in BUFFER anonymous types nested inside T's definition.
2437 PARENT is the parent node of T.
2438 FORWARD indicates whether a forward declaration of T should be generated.
2439 SPC is the indentation level. */
2442 dump_nested_types (pretty_printer
*buffer
, tree t
, tree parent
, bool forward
,
2445 tree field
, outer
, decl
;
2447 /* Avoid recursing over the same tree. */
2448 if (TREE_VISITED (t
))
2451 /* Find possible anonymous arrays/unions/structs recursively. */
2453 outer
= TREE_TYPE (t
);
2455 if (outer
== NULL_TREE
)
2460 pp_string (buffer
, "type ");
2461 dump_generic_ada_node (buffer
, t
, t
, spc
, false, true);
2462 pp_semicolon (buffer
);
2463 newline_and_indent (buffer
, spc
);
2464 TREE_VISITED (t
) = 1;
2467 field
= TYPE_FIELDS (outer
);
2470 if ((TREE_TYPE (field
) != outer
2471 || (TREE_CODE (TREE_TYPE (field
)) == POINTER_TYPE
2472 && TREE_TYPE (TREE_TYPE (field
)) != outer
))
2473 && (!TYPE_NAME (TREE_TYPE (field
))
2474 || (TREE_CODE (field
) == TYPE_DECL
2475 && DECL_NAME (field
) != DECL_NAME (t
)
2476 && TYPE_NAME (TREE_TYPE (field
)) != TYPE_NAME (outer
))))
2478 switch (TREE_CODE (TREE_TYPE (field
)))
2481 decl
= TREE_TYPE (TREE_TYPE (field
));
2483 if (TREE_CODE (decl
) == FUNCTION_TYPE
)
2484 for (decl
= TREE_TYPE (decl
);
2485 decl
&& TREE_CODE (decl
) == POINTER_TYPE
;
2486 decl
= TREE_TYPE (decl
))
2489 decl
= get_underlying_decl (decl
);
2493 && decl_sloc (decl
, true) > decl_sloc (t
, true)
2494 && DECL_SOURCE_FILE (decl
) == DECL_SOURCE_FILE (t
)
2495 && !TREE_VISITED (decl
)
2496 && !DECL_IS_BUILTIN (decl
)
2497 && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl
))
2498 || TYPE_FIELDS (TREE_TYPE (decl
))))
2500 /* Generate forward declaration. */
2502 pp_string (buffer
, "type ");
2503 dump_generic_ada_node (buffer
, decl
, 0, spc
, false, true);
2504 pp_semicolon (buffer
);
2505 newline_and_indent (buffer
, spc
);
2507 /* Ensure we do not generate duplicate forward
2508 declarations for this type. */
2509 TREE_VISITED (decl
) = 1;
2514 /* Special case char arrays. */
2515 if (is_char_array (field
))
2516 pp_string (buffer
, "sub");
2518 pp_string (buffer
, "type ");
2519 dump_ada_double_name (buffer
, parent
, field
, "_array is ");
2520 dump_ada_array_type (buffer
, field
, spc
);
2521 pp_semicolon (buffer
);
2522 newline_and_indent (buffer
, spc
);
2526 TREE_VISITED (t
) = 1;
2527 dump_nested_types (buffer
, field
, t
, false, spc
);
2529 pp_string (buffer
, "type ");
2531 if (TYPE_NAME (TREE_TYPE (field
)))
2533 dump_generic_ada_node
2534 (buffer
, TYPE_NAME (TREE_TYPE (field
)), 0, spc
, false,
2536 pp_string (buffer
, " (discr : unsigned := 0) is ");
2537 print_ada_struct_decl
2538 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2540 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2541 dump_generic_ada_node
2542 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2543 pp_string (buffer
, ");");
2544 newline_and_indent (buffer
, spc
);
2546 pp_string (buffer
, "pragma Unchecked_Union (");
2547 dump_generic_ada_node
2548 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2549 pp_string (buffer
, ");");
2553 dump_ada_double_name
2554 (buffer
, parent
, field
,
2555 "_union (discr : unsigned := 0) is ");
2556 print_ada_struct_decl
2557 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2558 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2559 dump_ada_double_name (buffer
, parent
, field
, "_union);");
2560 newline_and_indent (buffer
, spc
);
2562 pp_string (buffer
, "pragma Unchecked_Union (");
2563 dump_ada_double_name (buffer
, parent
, field
, "_union);");
2566 newline_and_indent (buffer
, spc
);
2570 if (TYPE_NAME (TREE_TYPE (t
)) && !TREE_VISITED (t
))
2572 pp_string (buffer
, "type ");
2573 dump_generic_ada_node
2574 (buffer
, t
, parent
, spc
, false, true);
2575 pp_semicolon (buffer
);
2576 newline_and_indent (buffer
, spc
);
2579 TREE_VISITED (t
) = 1;
2580 dump_nested_types (buffer
, field
, t
, false, spc
);
2581 pp_string (buffer
, "type ");
2583 if (TYPE_NAME (TREE_TYPE (field
)))
2585 dump_generic_ada_node
2586 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2587 pp_string (buffer
, " is ");
2588 print_ada_struct_decl
2589 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2590 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2591 dump_generic_ada_node
2592 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2593 pp_string (buffer
, ");");
2597 dump_ada_double_name
2598 (buffer
, parent
, field
, "_struct is ");
2599 print_ada_struct_decl
2600 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2601 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2602 dump_ada_double_name (buffer
, parent
, field
, "_struct);");
2605 newline_and_indent (buffer
, spc
);
2612 field
= TREE_CHAIN (field
);
2615 TREE_VISITED (t
) = 1;
2618 /* Dump in BUFFER constructor spec corresponding to T. */
2621 print_constructor (pretty_printer
*buffer
, tree t
)
2623 tree decl_name
= DECL_NAME (DECL_ORIGIN (t
));
2625 pp_string (buffer
, "New_");
2626 pp_ada_tree_identifier (buffer
, decl_name
, t
, false);
2629 /* Dump in BUFFER destructor spec corresponding to T. */
2632 print_destructor (pretty_printer
*buffer
, tree t
)
2634 tree decl_name
= DECL_NAME (DECL_ORIGIN (t
));
2636 pp_string (buffer
, "Delete_");
2637 pp_ada_tree_identifier (buffer
, decl_name
, t
, false);
2640 /* Return the name of type T. */
2645 tree n
= TYPE_NAME (t
);
2647 if (TREE_CODE (n
) == IDENTIFIER_NODE
)
2648 return IDENTIFIER_POINTER (n
);
2650 return IDENTIFIER_POINTER (DECL_NAME (n
));
2653 /* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
2654 SPC is the indentation level. Return 1 if a declaration was printed,
2658 print_ada_declaration (pretty_printer
*buffer
, tree t
, tree type
, int spc
)
2660 int is_var
= 0, need_indent
= 0;
2661 int is_class
= false;
2662 tree name
= TYPE_NAME (TREE_TYPE (t
));
2663 tree decl_name
= DECL_NAME (t
);
2664 tree orig
= NULL_TREE
;
2666 if (cpp_check
&& cpp_check (t
, IS_TEMPLATE
))
2667 return dump_ada_template (buffer
, t
, spc
);
2669 if (TREE_CODE (t
) == CONST_DECL
&& TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
)
2670 /* Skip enumeral values: will be handled as part of the type itself. */
2673 if (TREE_CODE (t
) == TYPE_DECL
)
2675 orig
= DECL_ORIGINAL_TYPE (t
);
2677 if (orig
&& TYPE_STUB_DECL (orig
))
2679 tree stub
= TYPE_STUB_DECL (orig
);
2680 tree typ
= TREE_TYPE (stub
);
2682 if (TYPE_NAME (typ
))
2684 /* If types have same representation, and same name (ignoring
2685 casing), then ignore the second type. */
2686 if (type_name (typ
) == type_name (TREE_TYPE (t
))
2687 || !strcasecmp (type_name (typ
), type_name (TREE_TYPE (t
))))
2692 if (RECORD_OR_UNION_TYPE_P (typ
) && !TYPE_FIELDS (typ
))
2694 pp_string (buffer
, "-- skipped empty struct ");
2695 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2699 if (!TREE_VISITED (stub
)
2700 && DECL_SOURCE_FILE (stub
) == source_file_base
)
2701 dump_nested_types (buffer
, stub
, stub
, true, spc
);
2703 pp_string (buffer
, "subtype ");
2704 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2705 pp_string (buffer
, " is ");
2706 dump_generic_ada_node (buffer
, typ
, type
, spc
, false, true);
2707 pp_semicolon (buffer
);
2713 /* Skip unnamed or anonymous structs/unions/enum types. */
2714 if (!orig
&& !decl_name
&& !name
)
2719 if (cpp_check
|| TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
)
2722 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
)))
2724 /* Search next items until finding a named type decl. */
2725 sloc
= decl_sloc_common (t
, true, true);
2727 for (tmp
= TREE_CHAIN (t
); tmp
; tmp
= TREE_CHAIN (tmp
))
2729 if (TREE_CODE (tmp
) == TYPE_DECL
2730 && (DECL_NAME (tmp
) || TYPE_NAME (TREE_TYPE (tmp
))))
2732 /* If same sloc, it means we can ignore the anonymous
2734 if (decl_sloc_common (tmp
, true, true) == sloc
)
2746 && TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
2748 && (*IDENTIFIER_POINTER (decl_name
) == '.'
2749 || *IDENTIFIER_POINTER (decl_name
) == '$'))
2750 /* Skip anonymous enum types (duplicates of real types). */
2755 switch (TREE_CODE (TREE_TYPE (t
)))
2759 case QUAL_UNION_TYPE
:
2760 /* Skip empty structs (typically forward references to real
2762 if (!TYPE_FIELDS (TREE_TYPE (t
)))
2764 pp_string (buffer
, "-- skipped empty struct ");
2765 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2770 && (*IDENTIFIER_POINTER (decl_name
) == '.'
2771 || *IDENTIFIER_POINTER (decl_name
) == '$'))
2773 pp_string (buffer
, "-- skipped anonymous struct ");
2774 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2775 TREE_VISITED (t
) = 1;
2779 if (orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2780 pp_string (buffer
, "subtype ");
2783 dump_nested_types (buffer
, t
, t
, false, spc
);
2785 if (separate_class_package (t
))
2788 pp_string (buffer
, "package Class_");
2789 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2790 pp_string (buffer
, " is");
2792 newline_and_indent (buffer
, spc
);
2795 pp_string (buffer
, "type ");
2801 case REFERENCE_TYPE
:
2802 if ((orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2803 || is_char_array (t
))
2804 pp_string (buffer
, "subtype ");
2806 pp_string (buffer
, "type ");
2810 pp_string (buffer
, "-- skipped function type ");
2811 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2816 if ((orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2817 || !is_simple_enum (TREE_TYPE (t
)))
2818 pp_string (buffer
, "subtype ");
2820 pp_string (buffer
, "type ");
2824 pp_string (buffer
, "subtype ");
2826 TREE_VISITED (t
) = 1;
2832 && *IDENTIFIER_POINTER (decl_name
) == '_')
2838 /* Print the type and name. */
2839 if (TREE_CODE (TREE_TYPE (t
)) == ARRAY_TYPE
)
2844 /* Print variable's name. */
2845 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2847 if (TREE_CODE (t
) == TYPE_DECL
)
2849 pp_string (buffer
, " is ");
2851 if (orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2852 dump_generic_ada_node
2853 (buffer
, TYPE_NAME (orig
), type
, spc
, false, true);
2855 dump_ada_array_type (buffer
, t
, spc
);
2859 tree tmp
= TYPE_NAME (TREE_TYPE (t
));
2861 if (spc
== INDENT_INCR
|| TREE_STATIC (t
))
2864 pp_string (buffer
, " : ");
2868 if (TREE_CODE (TREE_TYPE (tmp
)) != POINTER_TYPE
2869 && TREE_CODE (tmp
) != INTEGER_TYPE
)
2870 pp_string (buffer
, "aliased ");
2872 dump_generic_ada_node (buffer
, tmp
, type
, spc
, false, true);
2876 pp_string (buffer
, "aliased ");
2879 dump_ada_array_type (buffer
, t
, spc
);
2881 dump_ada_double_name (buffer
, type
, t
, "_array");
2885 else if (TREE_CODE (t
) == FUNCTION_DECL
)
2887 bool is_function
, is_abstract_class
= false;
2888 bool is_method
= TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
;
2889 tree decl_name
= DECL_NAME (t
);
2890 bool is_abstract
= false;
2891 bool is_constructor
= false;
2892 bool is_destructor
= false;
2893 bool is_copy_constructor
= false;
2900 is_abstract
= cpp_check (t
, IS_ABSTRACT
);
2901 is_constructor
= cpp_check (t
, IS_CONSTRUCTOR
);
2902 is_destructor
= cpp_check (t
, IS_DESTRUCTOR
);
2903 is_copy_constructor
= cpp_check (t
, IS_COPY_CONSTRUCTOR
);
2906 /* Skip copy constructors: some are internal only, and those that are
2907 not cannot be called easily from Ada anyway. */
2908 if (is_copy_constructor
)
2911 if (is_constructor
|| is_destructor
)
2913 /* Only consider constructors/destructors for complete objects. */
2914 if (strncmp (IDENTIFIER_POINTER (decl_name
), "__comp", 6) != 0)
2918 /* If this function has an entry in the vtable, we cannot omit it. */
2919 else if (!DECL_VINDEX (t
) && *IDENTIFIER_POINTER (decl_name
) == '_')
2922 pp_string (buffer
, "-- skipped func ");
2923 pp_string (buffer
, IDENTIFIER_POINTER (decl_name
));
2930 if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t
))) && !is_constructor
)
2932 pp_string (buffer
, "procedure ");
2933 is_function
= false;
2937 pp_string (buffer
, "function ");
2942 print_constructor (buffer
, t
);
2943 else if (is_destructor
)
2944 print_destructor (buffer
, t
);
2946 dump_ada_decl_name (buffer
, t
, false);
2948 dump_ada_function_declaration
2949 (buffer
, t
, is_method
, is_constructor
, is_destructor
, spc
);
2953 pp_string (buffer
, " return ");
2955 = is_constructor
? DECL_CONTEXT (t
) : TREE_TYPE (TREE_TYPE (t
));
2956 dump_generic_ada_node (buffer
, ret_type
, type
, spc
, false, true);
2960 && RECORD_OR_UNION_TYPE_P (type
)
2961 && TYPE_METHODS (type
))
2965 for (tmp
= TYPE_METHODS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
2966 if (cpp_check (tmp
, IS_ABSTRACT
))
2968 is_abstract_class
= true;
2973 if (is_abstract
|| is_abstract_class
)
2974 pp_string (buffer
, " is abstract");
2976 pp_semicolon (buffer
);
2977 pp_string (buffer
, " -- ");
2978 dump_sloc (buffer
, t
);
2980 if (is_abstract
|| !DECL_ASSEMBLER_NAME (t
))
2983 newline_and_indent (buffer
, spc
);
2987 pp_string (buffer
, "pragma CPP_Constructor (");
2988 print_constructor (buffer
, t
);
2989 pp_string (buffer
, ", \"");
2990 pp_asm_name (buffer
, t
);
2991 pp_string (buffer
, "\");");
2993 else if (is_destructor
)
2995 pp_string (buffer
, "pragma Import (CPP, ");
2996 print_destructor (buffer
, t
);
2997 pp_string (buffer
, ", \"");
2998 pp_asm_name (buffer
, t
);
2999 pp_string (buffer
, "\");");
3003 dump_ada_import (buffer
, t
);
3008 else if (TREE_CODE (t
) == TYPE_DECL
&& !DECL_ORIGINAL_TYPE (t
))
3010 int is_interface
= 0;
3011 int is_abstract_record
= 0;
3016 /* Anonymous structs/unions */
3017 dump_generic_ada_node (buffer
, TREE_TYPE (t
), t
, spc
, false, true);
3019 if (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3020 || TREE_CODE (TREE_TYPE (t
)) == QUAL_UNION_TYPE
)
3022 pp_string (buffer
, " (discr : unsigned := 0)");
3025 pp_string (buffer
, " is ");
3027 /* Check whether we have an Ada interface compatible class. */
3029 && RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
))
3030 && TYPE_METHODS (TREE_TYPE (t
)))
3035 /* Check that there are no fields other than the virtual table. */
3036 for (tmp
= TYPE_FIELDS (TREE_TYPE (t
)); tmp
; tmp
= TREE_CHAIN (tmp
))
3038 if (TREE_CODE (tmp
) == TYPE_DECL
)
3043 if (num_fields
== 1)
3046 /* Also check that there are only virtual methods. */
3047 for (tmp
= TYPE_METHODS (TREE_TYPE (t
)); tmp
; tmp
= TREE_CHAIN (tmp
))
3049 if (cpp_check (tmp
, IS_ABSTRACT
))
3050 is_abstract_record
= 1;
3056 TREE_VISITED (t
) = 1;
3059 pp_string (buffer
, "limited interface; -- ");
3060 dump_sloc (buffer
, t
);
3061 newline_and_indent (buffer
, spc
);
3062 pp_string (buffer
, "pragma Import (CPP, ");
3063 dump_generic_ada_node
3064 (buffer
, TYPE_NAME (TREE_TYPE (t
)), type
, spc
, false, true);
3065 pp_right_paren (buffer
);
3067 print_ada_methods (buffer
, TREE_TYPE (t
), spc
);
3071 if (is_abstract_record
)
3072 pp_string (buffer
, "abstract ");
3073 dump_generic_ada_node (buffer
, t
, t
, spc
, false, false);
3081 if (TREE_CODE (t
) == FIELD_DECL
&& DECL_NAME (t
))
3082 check_name (buffer
, t
);
3084 /* Print variable/type's name. */
3085 dump_generic_ada_node (buffer
, t
, t
, spc
, false, true);
3087 if (TREE_CODE (t
) == TYPE_DECL
)
3089 tree orig
= DECL_ORIGINAL_TYPE (t
);
3090 int is_subtype
= orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
);
3093 && (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3094 || TREE_CODE (TREE_TYPE (t
)) == QUAL_UNION_TYPE
))
3095 pp_string (buffer
, " (discr : unsigned := 0)");
3097 pp_string (buffer
, " is ");
3099 dump_generic_ada_node (buffer
, orig
, t
, spc
, false, is_subtype
);
3103 if (spc
== INDENT_INCR
|| TREE_STATIC (t
))
3106 pp_string (buffer
, " : ");
3108 /* Print type declaration. */
3110 if (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3111 && !TYPE_NAME (TREE_TYPE (t
)))
3113 dump_ada_double_name (buffer
, type
, t
, "_union");
3115 else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
)))
3117 if (TREE_CODE (TREE_TYPE (t
)) == RECORD_TYPE
)
3118 pp_string (buffer
, "aliased ");
3120 dump_generic_ada_node
3121 (buffer
, TREE_TYPE (t
), t
, spc
, false, true);
3125 if (TREE_CODE (TREE_TYPE (t
)) != POINTER_TYPE
3126 && (TYPE_NAME (TREE_TYPE (t
))
3127 || TREE_CODE (TREE_TYPE (t
)) != INTEGER_TYPE
))
3128 pp_string (buffer
, "aliased ");
3130 dump_generic_ada_node
3131 (buffer
, TREE_TYPE (t
), TREE_TYPE (t
), spc
, false, true);
3139 newline_and_indent (buffer
, spc
);
3140 pp_string (buffer
, "end;");
3141 newline_and_indent (buffer
, spc
);
3142 pp_string (buffer
, "use Class_");
3143 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
3144 pp_semicolon (buffer
);
3145 pp_newline (buffer
);
3147 /* All needed indentation/newline performed already, so return 0. */
3152 pp_string (buffer
, "; -- ");
3153 dump_sloc (buffer
, t
);
3158 newline_and_indent (buffer
, spc
);
3159 dump_ada_import (buffer
, t
);
3165 /* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
3166 with Ada syntax. SPC is the indentation level. If DISPLAY_CONVENTION is
3167 true, also print the pragma Convention for NODE. */
3170 print_ada_struct_decl (pretty_printer
*buffer
, tree node
, tree type
, int spc
,
3171 bool display_convention
)
3175 = TREE_CODE (node
) == UNION_TYPE
|| TREE_CODE (node
) == QUAL_UNION_TYPE
;
3178 int field_spc
= spc
+ INDENT_INCR
;
3181 bitfield_used
= false;
3183 if (!TYPE_FIELDS (node
))
3184 pp_string (buffer
, "null record;");
3187 pp_string (buffer
, "record");
3189 /* Print the contents of the structure. */
3193 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
3194 pp_string (buffer
, "case discr is");
3195 field_spc
= spc
+ INDENT_INCR
* 3;
3198 pp_newline (buffer
);
3200 /* Print the non-static fields of the structure. */
3201 for (tmp
= TYPE_FIELDS (node
); tmp
; tmp
= TREE_CHAIN (tmp
))
3203 /* Add parent field if needed. */
3204 if (!DECL_NAME (tmp
))
3206 if (!is_tagged_type (TREE_TYPE (tmp
)))
3208 if (!TYPE_NAME (TREE_TYPE (tmp
)))
3209 print_ada_declaration (buffer
, tmp
, type
, field_spc
);
3215 pp_string (buffer
, "parent : aliased ");
3218 sprintf (buf
, "field_%d : aliased ", field_num
+ 1);
3219 pp_string (buffer
, buf
);
3222 (buffer
, TYPE_NAME (TREE_TYPE (tmp
)), false);
3223 pp_semicolon (buffer
);
3225 pp_newline (buffer
);
3229 /* Avoid printing the structure recursively. */
3230 else if ((TREE_TYPE (tmp
) != node
3231 || (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3232 && TREE_TYPE (TREE_TYPE (tmp
)) != node
))
3233 && TREE_CODE (tmp
) != TYPE_DECL
3234 && !TREE_STATIC (tmp
))
3236 /* Skip internal virtual table field. */
3237 if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp
)), "_vptr", 5))
3241 if (TREE_CHAIN (tmp
)
3242 && TREE_TYPE (TREE_CHAIN (tmp
)) != node
3243 && TREE_CODE (TREE_CHAIN (tmp
)) != TYPE_DECL
)
3244 sprintf (buf
, "when %d =>", field_num
);
3246 sprintf (buf
, "when others =>");
3248 INDENT (spc
+ INDENT_INCR
* 2);
3249 pp_string (buffer
, buf
);
3250 pp_newline (buffer
);
3253 if (print_ada_declaration (buffer
, tmp
, type
, field_spc
))
3255 pp_newline (buffer
);
3264 INDENT (spc
+ INDENT_INCR
);
3265 pp_string (buffer
, "end case;");
3266 pp_newline (buffer
);
3271 INDENT (spc
+ INDENT_INCR
);
3272 pp_string (buffer
, "null;");
3273 pp_newline (buffer
);
3277 pp_string (buffer
, "end record;");
3280 newline_and_indent (buffer
, spc
);
3282 if (!display_convention
)
3285 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type
)))
3287 if (has_nontrivial_methods (TREE_TYPE (type
)))
3288 pp_string (buffer
, "pragma Import (CPP, ");
3290 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
3293 pp_string (buffer
, "pragma Convention (C, ");
3295 package_prefix
= false;
3296 dump_generic_ada_node (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3297 package_prefix
= true;
3298 pp_right_paren (buffer
);
3302 pp_semicolon (buffer
);
3303 newline_and_indent (buffer
, spc
);
3304 pp_string (buffer
, "pragma Unchecked_Union (");
3306 dump_generic_ada_node (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3307 pp_right_paren (buffer
);
3312 pp_semicolon (buffer
);
3313 newline_and_indent (buffer
, spc
);
3314 pp_string (buffer
, "pragma Pack (");
3315 dump_generic_ada_node
3316 (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3317 pp_right_paren (buffer
);
3318 bitfield_used
= false;
3321 need_semicolon
= !print_ada_methods (buffer
, node
, spc
);
3323 /* Print the static fields of the structure, if any. */
3324 for (tmp
= TYPE_FIELDS (node
); tmp
; tmp
= TREE_CHAIN (tmp
))
3326 if (DECL_NAME (tmp
) && TREE_STATIC (tmp
))
3330 need_semicolon
= false;
3331 pp_semicolon (buffer
);
3333 pp_newline (buffer
);
3334 pp_newline (buffer
);
3335 print_ada_declaration (buffer
, tmp
, type
, spc
);
3340 /* Dump all the declarations in SOURCE_FILE to an Ada spec.
3341 COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3342 nodes for SOURCE_FILE. CHECK is used to perform C++ queries on nodes. */
3345 dump_ads (const char *source_file
,
3346 void (*collect_all_refs
)(const char *),
3347 int (*check
)(tree
, cpp_operation
))
3354 pkg_name
= get_ada_package (source_file
);
3356 /* Construct the .ads filename and package name. */
3357 ads_name
= xstrdup (pkg_name
);
3359 for (s
= ads_name
; *s
; s
++)
3365 ads_name
= reconcat (ads_name
, ads_name
, ".ads", NULL
);
3367 /* Write out the .ads file. */
3368 f
= fopen (ads_name
, "w");
3373 pp_needs_newline (&pp
) = true;
3374 pp
.buffer
->stream
= f
;
3376 /* Dump all relevant macros. */
3377 dump_ada_macros (&pp
, source_file
);
3379 /* Reset the table of withs for this file. */
3382 (*collect_all_refs
) (source_file
);
3384 /* Dump all references. */
3386 dump_ada_nodes (&pp
, source_file
);
3388 /* Requires Ada 2005 syntax, so generate corresponding pragma.
3389 Also, disable style checks since this file is auto-generated. */
3390 fprintf (f
, "pragma Ada_2005;\npragma Style_Checks (Off);\n\n");
3395 fprintf (f
, "\npackage %s is\n\n", pkg_name
);
3396 pp_write_text_to_stream (&pp
);
3397 /* ??? need to free pp */
3398 fprintf (f
, "end %s;\n", pkg_name
);
3406 static const char **source_refs
= NULL
;
3407 static int source_refs_used
= 0;
3408 static int source_refs_allocd
= 0;
3410 /* Add an entry for FILENAME to the table SOURCE_REFS. */
3413 collect_source_ref (const char *filename
)
3420 if (source_refs_allocd
== 0)
3422 source_refs_allocd
= 1024;
3423 source_refs
= XNEWVEC (const char *, source_refs_allocd
);
3426 for (i
= 0; i
< source_refs_used
; i
++)
3427 if (filename
== source_refs
[i
])
3430 if (source_refs_used
== source_refs_allocd
)
3432 source_refs_allocd
*= 2;
3433 source_refs
= XRESIZEVEC (const char *, source_refs
, source_refs_allocd
);
3436 source_refs
[source_refs_used
++] = filename
;
3439 /* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
3440 using callbacks COLLECT_ALL_REFS and CHECK.
3441 COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3442 nodes for a given source file.
3443 CHECK is used to perform C++ queries on nodes, or NULL for the C
3447 dump_ada_specs (void (*collect_all_refs
)(const char *),
3448 int (*check
)(tree
, cpp_operation
))
3452 /* Iterate over the list of files to dump specs for */
3453 for (i
= 0; i
< source_refs_used
; i
++)
3454 dump_ads (source_refs
[i
], collect_all_refs
, check
);
3456 /* Free files table. */