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 "fold-const.h"
31 #include "c-ada-spec.h"
34 #include "cpp-id-data.h"
36 /* Local functions, macros and variables. */
37 static int dump_generic_ada_node (pretty_printer
*, tree
, tree
, int, int,
39 static int print_ada_declaration (pretty_printer
*, tree
, tree
, int);
40 static void print_ada_struct_decl (pretty_printer
*, tree
, tree
, int, bool);
41 static void dump_sloc (pretty_printer
*buffer
, tree node
);
42 static void print_comment (pretty_printer
*, const char *);
43 static void print_generic_ada_decl (pretty_printer
*, tree
, const char *);
44 static char *get_ada_package (const char *);
45 static void dump_ada_nodes (pretty_printer
*, const char *);
46 static void reset_ada_withs (void);
47 static void dump_ada_withs (FILE *);
48 static void dump_ads (const char *, void (*)(const char *),
49 int (*)(tree
, cpp_operation
));
50 static char *to_ada_name (const char *, int *);
51 static bool separate_class_package (tree
);
53 #define INDENT(SPACE) \
54 do { int i; for (i = 0; i<SPACE; i++) pp_space (buffer); } while (0)
58 /* Global hook used to perform C++ queries on nodes. */
59 static int (*cpp_check
) (tree
, cpp_operation
) = NULL
;
62 /* Given a cpp MACRO, compute the max length BUFFER_LEN of the macro, as well
63 as max length PARAM_LEN of arguments for fun_like macros, and also set
64 SUPPORTED to 0 if the macro cannot be mapped to an Ada construct. */
67 macro_length (const cpp_macro
*macro
, int *supported
, int *buffer_len
,
80 for (i
= 0; i
< macro
->paramc
; i
++)
82 cpp_hashnode
*param
= macro
->params
[i
];
84 *param_len
+= NODE_LEN (param
);
86 if (i
+ 1 < macro
->paramc
)
88 *param_len
+= 2; /* ", " */
90 else if (macro
->variadic
)
96 *param_len
+= 2; /* ")\0" */
99 for (j
= 0; j
< macro
->count
; j
++)
101 cpp_token
*token
= ¯o
->exp
.tokens
[j
];
103 if (token
->flags
& PREV_WHITE
)
106 if (token
->flags
& STRINGIFY_ARG
|| token
->flags
& PASTE_LEFT
)
112 if (token
->type
== CPP_MACRO_ARG
)
114 NODE_LEN (macro
->params
[token
->val
.macro_arg
.arg_no
- 1]);
116 /* Include enough extra space to handle e.g. special characters. */
117 *buffer_len
+= (cpp_token_len (token
) + 1) * 8;
123 /* Dump into PP a set of MAX_ADA_MACROS MACROS (C/C++) as Ada constants when
127 print_ada_macros (pretty_printer
*pp
, cpp_hashnode
**macros
, int max_ada_macros
)
129 int j
, num_macros
= 0, prev_line
= -1;
131 for (j
= 0; j
< max_ada_macros
; j
++)
133 cpp_hashnode
*node
= macros
[j
];
134 const cpp_macro
*macro
= node
->value
.macro
;
136 int supported
= 1, prev_is_one
= 0, buffer_len
, param_len
;
137 int is_string
= 0, is_char
= 0;
139 unsigned char *s
, *params
, *buffer
, *buf_param
, *char_one
= NULL
;
141 macro_length (macro
, &supported
, &buffer_len
, ¶m_len
);
142 s
= buffer
= XALLOCAVEC (unsigned char, buffer_len
);
143 params
= buf_param
= XALLOCAVEC (unsigned char, param_len
);
150 for (i
= 0; i
< macro
->paramc
; i
++)
152 cpp_hashnode
*param
= macro
->params
[i
];
154 memcpy (buf_param
, NODE_NAME (param
), NODE_LEN (param
));
155 buf_param
+= NODE_LEN (param
);
157 if (i
+ 1 < macro
->paramc
)
162 else if (macro
->variadic
)
172 for (i
= 0; supported
&& i
< macro
->count
; i
++)
174 cpp_token
*token
= ¯o
->exp
.tokens
[i
];
177 if (token
->flags
& PREV_WHITE
)
180 if (token
->flags
& STRINGIFY_ARG
|| token
->flags
& PASTE_LEFT
)
190 cpp_hashnode
*param
=
191 macro
->params
[token
->val
.macro_arg
.arg_no
- 1];
192 memcpy (buffer
, NODE_NAME (param
), NODE_LEN (param
));
193 buffer
+= NODE_LEN (param
);
197 case CPP_EQ_EQ
: *buffer
++ = '='; break;
198 case CPP_GREATER
: *buffer
++ = '>'; break;
199 case CPP_LESS
: *buffer
++ = '<'; break;
200 case CPP_PLUS
: *buffer
++ = '+'; break;
201 case CPP_MINUS
: *buffer
++ = '-'; break;
202 case CPP_MULT
: *buffer
++ = '*'; break;
203 case CPP_DIV
: *buffer
++ = '/'; break;
204 case CPP_COMMA
: *buffer
++ = ','; break;
205 case CPP_OPEN_SQUARE
:
206 case CPP_OPEN_PAREN
: *buffer
++ = '('; break;
207 case CPP_CLOSE_SQUARE
: /* fallthrough */
208 case CPP_CLOSE_PAREN
: *buffer
++ = ')'; break;
209 case CPP_DEREF
: /* fallthrough */
210 case CPP_SCOPE
: /* fallthrough */
211 case CPP_DOT
: *buffer
++ = '.'; break;
213 case CPP_EQ
: *buffer
++ = ':'; *buffer
++ = '='; break;
214 case CPP_NOT_EQ
: *buffer
++ = '/'; *buffer
++ = '='; break;
215 case CPP_GREATER_EQ
: *buffer
++ = '>'; *buffer
++ = '='; break;
216 case CPP_LESS_EQ
: *buffer
++ = '<'; *buffer
++ = '='; break;
219 *buffer
++ = 'n'; *buffer
++ = 'o'; *buffer
++ = 't'; break;
221 *buffer
++ = 'm'; *buffer
++ = 'o'; *buffer
++ = 'd'; break;
223 *buffer
++ = 'a'; *buffer
++ = 'n'; *buffer
++ = 'd'; break;
225 *buffer
++ = 'o'; *buffer
++ = 'r'; break;
227 *buffer
++ = 'x'; *buffer
++ = 'o'; *buffer
++ = 'r'; break;
229 strcpy ((char *) buffer
, " and then ");
233 strcpy ((char *) buffer
, " or else ");
239 is_one
= prev_is_one
;
242 case CPP_COMMENT
: break;
255 if (!macro
->fun_like
)
258 buffer
= cpp_spell_token (parse_in
, token
, buffer
, false);
268 c
= cpp_interpret_charconst (parse_in
, token
,
269 &chars_seen
, &ignored
);
270 if (c
>= 32 && c
<= 126)
273 *buffer
++ = (char) c
;
279 ((char *) buffer
, "Character'Val (%d)", (int) c
);
280 buffer
+= chars_seen
;
288 /* Replace "1 << N" by "2 ** N" */
315 case CPP_CLOSE_BRACE
:
319 case CPP_MINUS_MINUS
:
323 case CPP_HEADER_NAME
:
326 case CPP_OBJC_STRING
:
328 if (!macro
->fun_like
)
331 buffer
= cpp_spell_token (parse_in
, token
, buffer
, false);
335 prev_is_one
= is_one
;
342 if (macro
->fun_like
&& supported
)
344 char *start
= (char *) s
;
347 pp_string (pp
, " -- arg-macro: ");
349 if (*start
== '(' && buffer
[-1] == ')')
354 pp_string (pp
, "function ");
358 pp_string (pp
, "procedure ");
361 pp_string (pp
, (const char *) NODE_NAME (node
));
363 pp_string (pp
, (char *) params
);
365 pp_string (pp
, " -- ");
369 pp_string (pp
, "return ");
370 pp_string (pp
, start
);
374 pp_string (pp
, start
);
380 expanded_location sloc
= expand_location (macro
->line
);
382 if (sloc
.line
!= prev_line
+ 1)
386 prev_line
= sloc
.line
;
389 ada_name
= to_ada_name ((const char *) NODE_NAME (node
), NULL
);
390 pp_string (pp
, ada_name
);
392 pp_string (pp
, " : ");
395 pp_string (pp
, "aliased constant String");
397 pp_string (pp
, "aliased constant Character");
399 pp_string (pp
, "constant");
401 pp_string (pp
, " := ");
402 pp_string (pp
, (char *) s
);
405 pp_string (pp
, " & ASCII.NUL");
407 pp_string (pp
, "; -- ");
408 pp_string (pp
, sloc
.file
);
410 pp_scalar (pp
, "%d", sloc
.line
);
415 pp_string (pp
, " -- unsupported macro: ");
416 pp_string (pp
, (const char *) cpp_macro_definition (parse_in
, node
));
425 static const char *source_file
;
426 static int max_ada_macros
;
428 /* Callback used to count the number of relevant macros from
429 cpp_forall_identifiers. PFILE and V are not used. NODE is the current macro
433 count_ada_macro (cpp_reader
*pfile ATTRIBUTE_UNUSED
, cpp_hashnode
*node
,
434 void *v ATTRIBUTE_UNUSED
)
436 const cpp_macro
*macro
= node
->value
.macro
;
438 if (node
->type
== NT_MACRO
&& !(node
->flags
& NODE_BUILTIN
)
440 && *NODE_NAME (node
) != '_'
441 && LOCATION_FILE (macro
->line
) == source_file
)
447 static int store_ada_macro_index
;
449 /* Callback used to store relevant macros from cpp_forall_identifiers.
450 PFILE is not used. NODE is the current macro to store if relevant.
451 MACROS is an array of cpp_hashnode* used to store NODE. */
454 store_ada_macro (cpp_reader
*pfile ATTRIBUTE_UNUSED
,
455 cpp_hashnode
*node
, void *macros
)
457 const cpp_macro
*macro
= node
->value
.macro
;
459 if (node
->type
== NT_MACRO
&& !(node
->flags
& NODE_BUILTIN
)
461 && *NODE_NAME (node
) != '_'
462 && LOCATION_FILE (macro
->line
) == source_file
)
463 ((cpp_hashnode
**) macros
)[store_ada_macro_index
++] = node
;
468 /* Callback used to compare (during qsort) macros. NODE1 and NODE2 are the
469 two macro nodes to compare. */
472 compare_macro (const void *node1
, const void *node2
)
474 typedef const cpp_hashnode
*const_hnode
;
476 const_hnode n1
= *(const const_hnode
*) node1
;
477 const_hnode n2
= *(const const_hnode
*) node2
;
479 return n1
->value
.macro
->line
- n2
->value
.macro
->line
;
482 /* Dump in PP all relevant macros appearing in FILE. */
485 dump_ada_macros (pretty_printer
*pp
, const char* file
)
487 cpp_hashnode
**macros
;
489 /* Initialize file-scope variables. */
491 store_ada_macro_index
= 0;
494 /* Count all potentially relevant macros, and then sort them by sloc. */
495 cpp_forall_identifiers (parse_in
, count_ada_macro
, NULL
);
496 macros
= XALLOCAVEC (cpp_hashnode
*, max_ada_macros
);
497 cpp_forall_identifiers (parse_in
, store_ada_macro
, macros
);
498 qsort (macros
, max_ada_macros
, sizeof (cpp_hashnode
*), compare_macro
);
500 print_ada_macros (pp
, macros
, max_ada_macros
);
503 /* Current source file being handled. */
505 static const char *source_file_base
;
507 /* Compare the declaration (DECL) of struct-like types based on the sloc of
508 their last field (if LAST is true), so that more nested types collate before
510 If ORIG_TYPE is true, also consider struct with a DECL_ORIGINAL_TYPE. */
513 decl_sloc_common (const_tree decl
, bool last
, bool orig_type
)
515 tree type
= TREE_TYPE (decl
);
517 if (TREE_CODE (decl
) == TYPE_DECL
518 && (orig_type
|| !DECL_ORIGINAL_TYPE (decl
))
519 && RECORD_OR_UNION_TYPE_P (type
)
520 && TYPE_FIELDS (type
))
522 tree f
= TYPE_FIELDS (type
);
525 while (TREE_CHAIN (f
))
528 return DECL_SOURCE_LOCATION (f
);
531 return DECL_SOURCE_LOCATION (decl
);
534 /* Return sloc of DECL, using sloc of last field if LAST is true. */
537 decl_sloc (const_tree decl
, bool last
)
539 return decl_sloc_common (decl
, last
, false);
542 /* Compare two locations LHS and RHS. */
545 compare_location (location_t lhs
, location_t rhs
)
547 expanded_location xlhs
= expand_location (lhs
);
548 expanded_location xrhs
= expand_location (rhs
);
550 if (xlhs
.file
!= xrhs
.file
)
551 return filename_cmp (xlhs
.file
, xrhs
.file
);
553 if (xlhs
.line
!= xrhs
.line
)
554 return xlhs
.line
- xrhs
.line
;
556 if (xlhs
.column
!= xrhs
.column
)
557 return xlhs
.column
- xrhs
.column
;
562 /* Compare two declarations (LP and RP) by their source location. */
565 compare_node (const void *lp
, const void *rp
)
567 const_tree lhs
= *((const tree
*) lp
);
568 const_tree rhs
= *((const tree
*) rp
);
570 return compare_location (decl_sloc (lhs
, true), decl_sloc (rhs
, true));
573 /* Compare two comments (LP and RP) by their source location. */
576 compare_comment (const void *lp
, const void *rp
)
578 const cpp_comment
*lhs
= (const cpp_comment
*) lp
;
579 const cpp_comment
*rhs
= (const cpp_comment
*) rp
;
581 return compare_location (lhs
->sloc
, rhs
->sloc
);
584 static tree
*to_dump
= NULL
;
585 static int to_dump_count
= 0;
587 /* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped
588 by a subsequent call to dump_ada_nodes. */
591 collect_ada_nodes (tree t
, const char *source_file
)
594 int i
= to_dump_count
;
596 /* Count the likely relevant nodes: do not dump builtins (they are irrelevant
597 in the context of bindings) and namespaces (we do not handle them properly
599 for (n
= t
; n
; n
= TREE_CHAIN (n
))
600 if (!DECL_IS_BUILTIN (n
)
601 && TREE_CODE (n
) != NAMESPACE_DECL
602 && LOCATION_FILE (decl_sloc (n
, false)) == source_file
)
605 /* Allocate sufficient storage for all nodes. */
606 to_dump
= XRESIZEVEC (tree
, to_dump
, to_dump_count
);
608 /* Store the relevant nodes. */
609 for (n
= t
; n
; n
= TREE_CHAIN (n
))
610 if (!DECL_IS_BUILTIN (n
)
611 && TREE_CODE (n
) != NAMESPACE_DECL
612 && LOCATION_FILE (decl_sloc (n
, false)) == source_file
)
616 /* Call back for walk_tree to clear the TREE_VISITED flag of TP. */
619 unmark_visited_r (tree
*tp
, int *walk_subtrees ATTRIBUTE_UNUSED
,
620 void *data ATTRIBUTE_UNUSED
)
622 if (TREE_VISITED (*tp
))
623 TREE_VISITED (*tp
) = 0;
630 /* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls
631 to collect_ada_nodes. */
634 dump_ada_nodes (pretty_printer
*pp
, const char *source_file
)
637 cpp_comment_table
*comments
;
639 /* Sort the table of declarations to dump by sloc. */
640 qsort (to_dump
, to_dump_count
, sizeof (tree
), compare_node
);
642 /* Fetch the table of comments. */
643 comments
= cpp_get_comments (parse_in
);
645 /* Sort the comments table by sloc. */
646 if (comments
->count
> 1)
647 qsort (comments
->entries
, comments
->count
, sizeof (cpp_comment
),
650 /* Interleave comments and declarations in line number order. */
654 /* Advance j until comment j is in this file. */
655 while (j
!= comments
->count
656 && LOCATION_FILE (comments
->entries
[j
].sloc
) != source_file
)
659 /* Advance j until comment j is not a duplicate. */
660 while (j
< comments
->count
- 1
661 && !compare_comment (&comments
->entries
[j
],
662 &comments
->entries
[j
+ 1]))
665 /* Write decls until decl i collates after comment j. */
666 while (i
!= to_dump_count
)
668 if (j
== comments
->count
669 || LOCATION_LINE (decl_sloc (to_dump
[i
], false))
670 < LOCATION_LINE (comments
->entries
[j
].sloc
))
671 print_generic_ada_decl (pp
, to_dump
[i
++], source_file
);
676 /* Write comment j, if there is one. */
677 if (j
!= comments
->count
)
678 print_comment (pp
, comments
->entries
[j
++].comment
);
680 } while (i
!= to_dump_count
|| j
!= comments
->count
);
682 /* Clear the TREE_VISITED flag over each subtree we've dumped. */
683 for (i
= 0; i
< to_dump_count
; i
++)
684 walk_tree (&to_dump
[i
], unmark_visited_r
, NULL
, NULL
);
686 /* Finalize the to_dump table. */
695 /* Print a COMMENT to the output stream PP. */
698 print_comment (pretty_printer
*pp
, const char *comment
)
700 int len
= strlen (comment
);
701 char *str
= XALLOCAVEC (char, len
+ 1);
703 bool extra_newline
= false;
705 memcpy (str
, comment
, len
+ 1);
707 /* Trim C/C++ comment indicators. */
708 if (str
[len
- 2] == '*' && str
[len
- 1] == '/')
715 tok
= strtok (str
, "\n");
717 pp_string (pp
, " --");
720 tok
= strtok (NULL
, "\n");
722 /* Leave a blank line after multi-line comments. */
724 extra_newline
= true;
731 /* Print declaration DECL to PP in Ada syntax. The current source file being
732 handled is SOURCE_FILE. */
735 print_generic_ada_decl (pretty_printer
*pp
, tree decl
, const char *source_file
)
737 source_file_base
= source_file
;
739 if (print_ada_declaration (pp
, decl
, 0, INDENT_INCR
))
746 /* Dump a newline and indent BUFFER by SPC chars. */
749 newline_and_indent (pretty_printer
*buffer
, int spc
)
755 struct with
{ char *s
; const char *in_file
; int limited
; };
756 static struct with
*withs
= NULL
;
757 static int withs_max
= 4096;
758 static int with_len
= 0;
760 /* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is
761 true), if not already done. */
764 append_withs (const char *s
, int limited_access
)
769 withs
= XNEWVEC (struct with
, withs_max
);
771 if (with_len
== withs_max
)
774 withs
= XRESIZEVEC (struct with
, withs
, withs_max
);
777 for (i
= 0; i
< with_len
; i
++)
778 if (!strcmp (s
, withs
[i
].s
)
779 && source_file_base
== withs
[i
].in_file
)
781 withs
[i
].limited
&= limited_access
;
785 withs
[with_len
].s
= xstrdup (s
);
786 withs
[with_len
].in_file
= source_file_base
;
787 withs
[with_len
].limited
= limited_access
;
791 /* Reset "with" clauses. */
794 reset_ada_withs (void)
801 for (i
= 0; i
< with_len
; i
++)
809 /* Dump "with" clauses in F. */
812 dump_ada_withs (FILE *f
)
816 fprintf (f
, "with Interfaces.C; use Interfaces.C;\n");
818 for (i
= 0; i
< with_len
; i
++)
820 (f
, "%swith %s;\n", withs
[i
].limited
? "limited " : "", withs
[i
].s
);
823 /* Return suitable Ada package name from FILE. */
826 get_ada_package (const char *file
)
834 s
= strstr (file
, "/include/");
838 base
= lbasename (file
);
840 if (ada_specs_parent
== NULL
)
843 plen
= strlen (ada_specs_parent
) + 1;
845 res
= XNEWVEC (char, plen
+ strlen (base
) + 1);
846 if (ada_specs_parent
!= NULL
) {
847 strcpy (res
, ada_specs_parent
);
851 for (i
= plen
; *base
; base
++, i
++)
863 res
[i
] = (i
== 0 || res
[i
- 1] == '.' || res
[i
- 1] == '_') ? 'u' : '_';
875 static const char *ada_reserved
[] = {
876 "abort", "abs", "abstract", "accept", "access", "aliased", "all", "and",
877 "array", "at", "begin", "body", "case", "constant", "declare", "delay",
878 "delta", "digits", "do", "else", "elsif", "end", "entry", "exception",
879 "exit", "for", "function", "generic", "goto", "if", "in", "interface", "is",
880 "limited", "loop", "mod", "new", "not", "null", "others", "out", "of", "or",
881 "overriding", "package", "pragma", "private", "procedure", "protected",
882 "raise", "range", "record", "rem", "renames", "requeue", "return", "reverse",
883 "select", "separate", "subtype", "synchronized", "tagged", "task",
884 "terminate", "then", "type", "until", "use", "when", "while", "with", "xor",
887 /* ??? would be nice to specify this list via a config file, so that users
888 can create their own dictionary of conflicts. */
889 static const char *c_duplicates
[] = {
890 /* system will cause troubles with System.Address. */
893 /* The following values have other definitions with same name/other
899 "rl_readline_version",
905 /* Return a declaration tree corresponding to TYPE. */
908 get_underlying_decl (tree type
)
910 tree decl
= NULL_TREE
;
912 if (type
== NULL_TREE
)
915 /* type is a declaration. */
919 /* type is a typedef. */
920 if (TYPE_P (type
) && TYPE_NAME (type
) && DECL_P (TYPE_NAME (type
)))
921 decl
= TYPE_NAME (type
);
923 /* TYPE_STUB_DECL has been set for type. */
924 if (TYPE_P (type
) && TYPE_STUB_DECL (type
) &&
925 DECL_P (TYPE_STUB_DECL (type
)))
926 decl
= TYPE_STUB_DECL (type
);
931 /* Return whether TYPE has static fields. */
934 has_static_fields (const_tree type
)
938 if (!type
|| !RECORD_OR_UNION_TYPE_P (type
))
941 for (tmp
= TYPE_FIELDS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
942 if (DECL_NAME (tmp
) && TREE_STATIC (tmp
))
948 /* Return whether TYPE corresponds to an Ada tagged type (has a dispatch
952 is_tagged_type (const_tree type
)
956 if (!type
|| !RECORD_OR_UNION_TYPE_P (type
))
959 /* TYPE_METHODS is only set on the main variant. */
960 type
= TYPE_MAIN_VARIANT (type
);
962 for (tmp
= TYPE_METHODS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
963 if (TREE_CODE (tmp
) == FUNCTION_DECL
&& DECL_VINDEX (tmp
))
969 /* Return whether TYPE has non-trivial methods, i.e. methods that do something
970 for the objects of TYPE. In C++, all classes have implicit special methods,
971 e.g. constructors and destructors, but they can be trivial if the type is
972 sufficiently simple. */
975 has_nontrivial_methods (tree type
)
979 if (!type
|| !RECORD_OR_UNION_TYPE_P (type
))
982 /* Only C++ types can have methods. */
986 /* A non-trivial type has non-trivial special methods. */
987 if (!cpp_check (type
, IS_TRIVIAL
))
990 /* TYPE_METHODS is only set on the main variant. */
991 type
= TYPE_MAIN_VARIANT (type
);
993 /* If there are user-defined methods, they are deemed non-trivial. */
994 for (tmp
= TYPE_METHODS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
995 if (!DECL_ARTIFICIAL (tmp
))
1001 /* Generate a legal Ada name from a C NAME, returning a malloc'd string.
1002 SPACE_FOUND, if not NULL, is used to indicate whether a space was found in
1006 to_ada_name (const char *name
, int *space_found
)
1009 int len
= strlen (name
);
1012 char *s
= XNEWVEC (char, len
* 2 + 5);
1016 *space_found
= false;
1018 /* Add trailing "c_" if name is an Ada reserved word. */
1019 for (names
= ada_reserved
; *names
; names
++)
1020 if (!strcasecmp (name
, *names
))
1029 /* Add trailing "c_" if name is an potential case sensitive duplicate. */
1030 for (names
= c_duplicates
; *names
; names
++)
1031 if (!strcmp (name
, *names
))
1039 for (j
= 0; name
[j
] == '_'; j
++)
1044 else if (*name
== '.' || *name
== '$')
1054 /* Replace unsuitable characters for Ada identifiers. */
1056 for (; j
< len
; j
++)
1061 *space_found
= true;
1065 /* ??? missing some C++ operators. */
1069 if (name
[j
+ 1] == '=')
1084 if (name
[j
+ 1] == '=')
1102 s
[len2
++] = name
[j
] == '&' ? 'a' : name
[j
] == '|' ? 'o' : 'x';
1104 if (name
[j
+ 1] == '=')
1117 if (s
[len2
- 1] != '_')
1120 switch (name
[j
+ 1]) {
1123 switch (name
[j
- 1]) {
1124 case '+': s
[len2
++] = 'p'; break; /* + */
1125 case '-': s
[len2
++] = 'm'; break; /* - */
1126 case '*': s
[len2
++] = 't'; break; /* * */
1127 case '/': s
[len2
++] = 'd'; break; /* / */
1133 switch (name
[j
- 1]) {
1134 case '+': s
[len2
++] = 'p'; break; /* += */
1135 case '-': s
[len2
++] = 'm'; break; /* -= */
1136 case '*': s
[len2
++] = 't'; break; /* *= */
1137 case '/': s
[len2
++] = 'd'; break; /* /= */
1171 c
= name
[j
] == '<' ? 'l' : 'g';
1174 switch (name
[j
+ 1]) {
1200 if (len2
&& s
[len2
- 1] == '_')
1205 s
[len2
++] = name
[j
];
1208 if (s
[len2
- 1] == '_')
1216 /* Return true if DECL refers to a C++ class type for which a
1217 separate enclosing package has been or should be generated. */
1220 separate_class_package (tree decl
)
1222 tree type
= TREE_TYPE (decl
);
1223 return has_nontrivial_methods (type
) || has_static_fields (type
);
1226 static bool package_prefix
= true;
1228 /* Dump in BUFFER the name of an identifier NODE of type TYPE, following Ada
1229 syntax. LIMITED_ACCESS indicates whether NODE can be accessed via a limited
1230 'with' clause rather than a regular 'with' clause. */
1233 pp_ada_tree_identifier (pretty_printer
*buffer
, tree node
, tree type
,
1236 const char *name
= IDENTIFIER_POINTER (node
);
1237 int space_found
= false;
1238 char *s
= to_ada_name (name
, &space_found
);
1241 /* If the entity is a type and comes from another file, generate "package"
1243 decl
= get_underlying_decl (type
);
1247 expanded_location xloc
= expand_location (decl_sloc (decl
, false));
1249 if (xloc
.file
&& xloc
.line
)
1251 if (xloc
.file
!= source_file_base
)
1253 switch (TREE_CODE (type
))
1258 case FIXED_POINT_TYPE
:
1260 case REFERENCE_TYPE
:
1265 case QUAL_UNION_TYPE
:
1269 char *s1
= get_ada_package (xloc
.file
);
1270 append_withs (s1
, limited_access
);
1271 pp_string (buffer
, s1
);
1280 /* Generate the additional package prefix for C++ classes. */
1281 if (separate_class_package (decl
))
1283 pp_string (buffer
, "Class_");
1284 pp_string (buffer
, s
);
1292 if (!strcmp (s
, "short_int"))
1293 pp_string (buffer
, "short");
1294 else if (!strcmp (s
, "short_unsigned_int"))
1295 pp_string (buffer
, "unsigned_short");
1296 else if (!strcmp (s
, "unsigned_int"))
1297 pp_string (buffer
, "unsigned");
1298 else if (!strcmp (s
, "long_int"))
1299 pp_string (buffer
, "long");
1300 else if (!strcmp (s
, "long_unsigned_int"))
1301 pp_string (buffer
, "unsigned_long");
1302 else if (!strcmp (s
, "long_long_int"))
1303 pp_string (buffer
, "Long_Long_Integer");
1304 else if (!strcmp (s
, "long_long_unsigned_int"))
1308 append_withs ("Interfaces.C.Extensions", false);
1309 pp_string (buffer
, "Extensions.unsigned_long_long");
1312 pp_string (buffer
, "unsigned_long_long");
1315 pp_string(buffer
, s
);
1317 if (!strcmp (s
, "bool"))
1321 append_withs ("Interfaces.C.Extensions", false);
1322 pp_string (buffer
, "Extensions.bool");
1325 pp_string (buffer
, "bool");
1328 pp_string(buffer
, s
);
1333 /* Dump in BUFFER the assembly name of T. */
1336 pp_asm_name (pretty_printer
*buffer
, tree t
)
1338 tree name
= DECL_ASSEMBLER_NAME (t
);
1339 char *ada_name
= XALLOCAVEC (char, IDENTIFIER_LENGTH (name
) + 1), *s
;
1340 const char *ident
= IDENTIFIER_POINTER (name
);
1342 for (s
= ada_name
; *ident
; ident
++)
1346 else if (*ident
!= '*')
1351 pp_string (buffer
, ada_name
);
1354 /* Dump in BUFFER the name of a DECL node if set, following Ada syntax.
1355 LIMITED_ACCESS indicates whether NODE can be accessed via a limited
1356 'with' clause rather than a regular 'with' clause. */
1359 dump_ada_decl_name (pretty_printer
*buffer
, tree decl
, int limited_access
)
1361 if (DECL_NAME (decl
))
1362 pp_ada_tree_identifier (buffer
, DECL_NAME (decl
), decl
, limited_access
);
1365 tree type_name
= TYPE_NAME (TREE_TYPE (decl
));
1369 pp_string (buffer
, "anon");
1370 if (TREE_CODE (decl
) == FIELD_DECL
)
1371 pp_scalar (buffer
, "%d", DECL_UID (decl
));
1373 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (decl
)));
1375 else if (TREE_CODE (type_name
) == IDENTIFIER_NODE
)
1376 pp_ada_tree_identifier (buffer
, type_name
, decl
, limited_access
);
1380 /* Dump in BUFFER a name based on both T1 and T2, followed by S. */
1383 dump_ada_double_name (pretty_printer
*buffer
, tree t1
, tree t2
, const char *s
)
1386 pp_ada_tree_identifier (buffer
, DECL_NAME (t1
), t1
, false);
1389 pp_string (buffer
, "anon");
1390 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (t1
)));
1393 pp_underscore (buffer
);
1396 pp_ada_tree_identifier (buffer
, DECL_NAME (t2
), t2
, false);
1399 pp_string (buffer
, "anon");
1400 pp_scalar (buffer
, "%d", TYPE_UID (TREE_TYPE (t2
)));
1403 pp_string (buffer
, s
);
1406 /* Dump in BUFFER pragma Import C/CPP on a given node T. */
1409 dump_ada_import (pretty_printer
*buffer
, tree t
)
1411 const char *name
= IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (t
));
1412 int is_stdcall
= TREE_CODE (t
) == FUNCTION_DECL
&&
1413 lookup_attribute ("stdcall", TYPE_ATTRIBUTES (TREE_TYPE (t
)));
1416 pp_string (buffer
, "pragma Import (Stdcall, ");
1417 else if (name
[0] == '_' && name
[1] == 'Z')
1418 pp_string (buffer
, "pragma Import (CPP, ");
1420 pp_string (buffer
, "pragma Import (C, ");
1422 dump_ada_decl_name (buffer
, t
, false);
1423 pp_string (buffer
, ", \"");
1426 pp_string (buffer
, IDENTIFIER_POINTER (DECL_NAME (t
)));
1428 pp_asm_name (buffer
, t
);
1430 pp_string (buffer
, "\");");
1433 /* Check whether T and its type have different names, and append "the_"
1434 otherwise in BUFFER. */
1437 check_name (pretty_printer
*buffer
, tree t
)
1440 tree tmp
= TREE_TYPE (t
);
1442 while (TREE_CODE (tmp
) == POINTER_TYPE
&& !TYPE_NAME (tmp
))
1443 tmp
= TREE_TYPE (tmp
);
1445 if (TREE_CODE (tmp
) != FUNCTION_TYPE
)
1447 if (TREE_CODE (tmp
) == IDENTIFIER_NODE
)
1448 s
= IDENTIFIER_POINTER (tmp
);
1449 else if (!TYPE_NAME (tmp
))
1451 else if (TREE_CODE (TYPE_NAME (tmp
)) == IDENTIFIER_NODE
)
1452 s
= IDENTIFIER_POINTER (TYPE_NAME (tmp
));
1454 s
= IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp
)));
1456 if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t
)), s
))
1457 pp_string (buffer
, "the_");
1461 /* Dump in BUFFER a function declaration FUNC with Ada syntax.
1462 IS_METHOD indicates whether FUNC is a C++ method.
1463 IS_CONSTRUCTOR whether FUNC is a C++ constructor.
1464 IS_DESTRUCTOR whether FUNC is a C++ destructor.
1465 SPC is the current indentation level. */
1468 dump_ada_function_declaration (pretty_printer
*buffer
, tree func
,
1469 int is_method
, int is_constructor
,
1470 int is_destructor
, int spc
)
1473 const tree node
= TREE_TYPE (func
);
1475 int num
= 0, num_args
= 0, have_args
= true, have_ellipsis
= false;
1477 /* Compute number of arguments. */
1478 arg
= TYPE_ARG_TYPES (node
);
1482 while (TREE_CHAIN (arg
) && arg
!= error_mark_node
)
1485 arg
= TREE_CHAIN (arg
);
1488 if (TREE_CODE (TREE_VALUE (arg
)) != VOID_TYPE
)
1491 have_ellipsis
= true;
1502 newline_and_indent (buffer
, spc
+ 1);
1507 pp_left_paren (buffer
);
1510 if (TREE_CODE (func
) == FUNCTION_DECL
)
1511 arg
= DECL_ARGUMENTS (func
);
1515 if (arg
== NULL_TREE
)
1518 arg
= TYPE_ARG_TYPES (node
);
1520 if (arg
&& TREE_CODE (TREE_VALUE (arg
)) == VOID_TYPE
)
1525 arg
= TREE_CHAIN (arg
);
1527 /* Print the argument names (if available) & types. */
1529 for (num
= 1; num
<= num_args
; num
++)
1533 if (DECL_NAME (arg
))
1535 check_name (buffer
, arg
);
1536 pp_ada_tree_identifier (buffer
, DECL_NAME (arg
), 0, false);
1537 pp_string (buffer
, " : ");
1541 sprintf (buf
, "arg%d : ", num
);
1542 pp_string (buffer
, buf
);
1545 dump_generic_ada_node (buffer
, TREE_TYPE (arg
), node
, spc
, 0, true);
1549 sprintf (buf
, "arg%d : ", num
);
1550 pp_string (buffer
, buf
);
1551 dump_generic_ada_node (buffer
, TREE_VALUE (arg
), node
, spc
, 0, true);
1554 if (TREE_TYPE (arg
) && TREE_TYPE (TREE_TYPE (arg
))
1555 && is_tagged_type (TREE_TYPE (TREE_TYPE (arg
))))
1558 || (num
!= 1 || (!DECL_VINDEX (func
) && !is_constructor
)))
1559 pp_string (buffer
, "'Class");
1562 arg
= TREE_CHAIN (arg
);
1566 pp_semicolon (buffer
);
1569 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
1577 pp_string (buffer
, " -- , ...");
1578 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
1582 pp_right_paren (buffer
);
1586 /* Dump in BUFFER all the domains associated with an array NODE,
1587 using Ada syntax. SPC is the current indentation level. */
1590 dump_ada_array_domains (pretty_printer
*buffer
, tree node
, int spc
)
1593 pp_left_paren (buffer
);
1595 for (; TREE_CODE (node
) == ARRAY_TYPE
; node
= TREE_TYPE (node
))
1597 tree domain
= TYPE_DOMAIN (node
);
1601 tree min
= TYPE_MIN_VALUE (domain
);
1602 tree max
= TYPE_MAX_VALUE (domain
);
1605 pp_string (buffer
, ", ");
1609 dump_generic_ada_node (buffer
, min
, NULL_TREE
, spc
, 0, true);
1610 pp_string (buffer
, " .. ");
1612 /* If the upper bound is zero, gcc may generate a NULL_TREE
1613 for TYPE_MAX_VALUE rather than an integer_cst. */
1615 dump_generic_ada_node (buffer
, max
, NULL_TREE
, spc
, 0, true);
1617 pp_string (buffer
, "0");
1620 pp_string (buffer
, "size_t");
1622 pp_right_paren (buffer
);
1625 /* Dump in BUFFER file:line information related to NODE. */
1628 dump_sloc (pretty_printer
*buffer
, tree node
)
1630 expanded_location xloc
;
1635 xloc
= expand_location (DECL_SOURCE_LOCATION (node
));
1636 else if (EXPR_HAS_LOCATION (node
))
1637 xloc
= expand_location (EXPR_LOCATION (node
));
1641 pp_string (buffer
, xloc
.file
);
1643 pp_decimal_int (buffer
, xloc
.line
);
1647 /* Return true if T designates a one dimension array of "char". */
1650 is_char_array (tree t
)
1655 /* Retrieve array's type. */
1657 while (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1660 tmp
= TREE_TYPE (tmp
);
1663 tmp
= TREE_TYPE (tmp
);
1664 return num_dim
== 1 && TREE_CODE (tmp
) == INTEGER_TYPE
1665 && !strcmp (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp
))), "char");
1668 /* Dump in BUFFER an array type T in Ada syntax. Assume that the "type"
1669 keyword and name have already been printed. SPC is the indentation
1673 dump_ada_array_type (pretty_printer
*buffer
, tree t
, int spc
)
1676 bool char_array
= is_char_array (t
);
1678 /* Special case char arrays. */
1681 pp_string (buffer
, "Interfaces.C.char_array ");
1684 pp_string (buffer
, "array ");
1686 /* Print the dimensions. */
1687 dump_ada_array_domains (buffer
, TREE_TYPE (t
), spc
);
1689 /* Retrieve array's type. */
1690 tmp
= TREE_TYPE (t
);
1691 while (TREE_CODE (TREE_TYPE (tmp
)) == ARRAY_TYPE
)
1692 tmp
= TREE_TYPE (tmp
);
1694 /* Print array's type. */
1697 pp_string (buffer
, " of ");
1699 if (TREE_CODE (TREE_TYPE (tmp
)) != POINTER_TYPE
)
1700 pp_string (buffer
, "aliased ");
1702 dump_generic_ada_node
1703 (buffer
, TREE_TYPE (tmp
), TREE_TYPE (t
), spc
, false, true);
1707 /* Dump in BUFFER type names associated with a template, each prepended with
1708 '_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS. SPC is
1709 the indentation level. */
1712 dump_template_types (pretty_printer
*buffer
, tree types
, int spc
)
1715 size_t len
= TREE_VEC_LENGTH (types
);
1717 for (i
= 0; i
< len
; i
++)
1719 tree elem
= TREE_VEC_ELT (types
, i
);
1720 pp_underscore (buffer
);
1721 if (!dump_generic_ada_node (buffer
, elem
, 0, spc
, false, true))
1723 pp_string (buffer
, "unknown");
1724 pp_scalar (buffer
, "%lu", (unsigned long) TREE_HASH (elem
));
1729 /* Dump in BUFFER the contents of all class instantiations associated with
1730 a given template T. SPC is the indentation level. */
1733 dump_ada_template (pretty_printer
*buffer
, tree t
, int spc
)
1735 /* DECL_SIZE_UNIT is DECL_TEMPLATE_INSTANTIATIONS in this context. */
1736 tree inst
= DECL_SIZE_UNIT (t
);
1737 /* This emulates DECL_TEMPLATE_RESULT in this context. */
1738 struct tree_template_decl
{
1739 struct tree_decl_common common
;
1743 tree result
= ((struct tree_template_decl
*) t
)->result
;
1746 /* Don't look at template declarations declaring something coming from
1747 another file. This can occur for template friend declarations. */
1748 if (LOCATION_FILE (decl_sloc (result
, false))
1749 != LOCATION_FILE (decl_sloc (t
, false)))
1752 for (; inst
&& inst
!= error_mark_node
; inst
= TREE_CHAIN (inst
))
1754 tree types
= TREE_PURPOSE (inst
);
1755 tree instance
= TREE_VALUE (inst
);
1757 if (TREE_VEC_LENGTH (types
) == 0)
1760 if (!RECORD_OR_UNION_TYPE_P (instance
) || !TYPE_METHODS (instance
))
1763 /* We are interested in concrete template instantiations only: skip
1764 partially specialized nodes. */
1765 if ((TREE_CODE (instance
) == RECORD_TYPE
1766 || TREE_CODE (instance
) == UNION_TYPE
)
1767 && cpp_check
&& cpp_check (instance
, HAS_DEPENDENT_TEMPLATE_ARGS
))
1772 pp_string (buffer
, "package ");
1773 package_prefix
= false;
1774 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1775 dump_template_types (buffer
, types
, spc
);
1776 pp_string (buffer
, " is");
1778 newline_and_indent (buffer
, spc
);
1780 TREE_VISITED (get_underlying_decl (instance
)) = 1;
1781 pp_string (buffer
, "type ");
1782 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1783 package_prefix
= true;
1785 if (is_tagged_type (instance
))
1786 pp_string (buffer
, " is tagged limited ");
1788 pp_string (buffer
, " is limited ");
1790 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, false);
1791 pp_newline (buffer
);
1793 newline_and_indent (buffer
, spc
);
1795 pp_string (buffer
, "end;");
1796 newline_and_indent (buffer
, spc
);
1797 pp_string (buffer
, "use ");
1798 package_prefix
= false;
1799 dump_generic_ada_node (buffer
, instance
, t
, spc
, false, true);
1800 dump_template_types (buffer
, types
, spc
);
1801 package_prefix
= true;
1802 pp_semicolon (buffer
);
1803 pp_newline (buffer
);
1804 pp_newline (buffer
);
1807 return num_inst
> 0;
1810 /* Return true if NODE is a simple enum types, that can be mapped to an
1811 Ada enum type directly. */
1814 is_simple_enum (tree node
)
1816 HOST_WIDE_INT count
= 0;
1819 for (value
= TYPE_VALUES (node
); value
; value
= TREE_CHAIN (value
))
1821 tree int_val
= TREE_VALUE (value
);
1823 if (TREE_CODE (int_val
) != INTEGER_CST
)
1824 int_val
= DECL_INITIAL (int_val
);
1826 if (!tree_fits_shwi_p (int_val
))
1828 else if (tree_to_shwi (int_val
) != count
)
1837 static bool bitfield_used
= false;
1839 /* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
1840 TYPE. SPC is the indentation level. LIMITED_ACCESS indicates whether NODE
1841 can be referenced via a "limited with" clause. NAME_ONLY indicates whether
1842 we should only dump the name of NODE, instead of its full declaration. */
1845 dump_generic_ada_node (pretty_printer
*buffer
, tree node
, tree type
, int spc
,
1846 int limited_access
, bool name_only
)
1848 if (node
== NULL_TREE
)
1851 switch (TREE_CODE (node
))
1854 pp_string (buffer
, "<<< error >>>");
1857 case IDENTIFIER_NODE
:
1858 pp_ada_tree_identifier (buffer
, node
, type
, limited_access
);
1862 pp_string (buffer
, "--- unexpected node: TREE_LIST");
1866 dump_generic_ada_node
1867 (buffer
, BINFO_TYPE (node
), type
, spc
, limited_access
, name_only
);
1870 pp_string (buffer
, "--- unexpected node: TREE_VEC");
1876 append_withs ("System", false);
1877 pp_string (buffer
, "System.Address");
1880 pp_string (buffer
, "address");
1884 pp_string (buffer
, "<vector>");
1888 pp_string (buffer
, "<complex>");
1893 dump_generic_ada_node
1894 (buffer
, TYPE_NAME (node
), node
, spc
, 0, true);
1897 tree value
= TYPE_VALUES (node
);
1899 if (is_simple_enum (node
))
1903 newline_and_indent (buffer
, spc
- 1);
1904 pp_left_paren (buffer
);
1905 for (; value
; value
= TREE_CHAIN (value
))
1912 newline_and_indent (buffer
, spc
);
1915 pp_ada_tree_identifier
1916 (buffer
, TREE_PURPOSE (value
), node
, false);
1918 pp_string (buffer
, ");");
1920 newline_and_indent (buffer
, spc
);
1921 pp_string (buffer
, "pragma Convention (C, ");
1922 dump_generic_ada_node
1923 (buffer
, DECL_NAME (type
) ? type
: TYPE_NAME (node
), type
,
1925 pp_right_paren (buffer
);
1929 pp_string (buffer
, "unsigned");
1930 for (; value
; value
= TREE_CHAIN (value
))
1932 pp_semicolon (buffer
);
1933 newline_and_indent (buffer
, spc
);
1935 pp_ada_tree_identifier
1936 (buffer
, TREE_PURPOSE (value
), node
, false);
1937 pp_string (buffer
, " : constant ");
1939 dump_generic_ada_node
1940 (buffer
, DECL_NAME (type
) ? type
: TYPE_NAME (node
), type
,
1943 pp_string (buffer
, " := ");
1944 dump_generic_ada_node
1946 TREE_CODE (TREE_VALUE (value
)) == INTEGER_CST
?
1947 TREE_VALUE (value
) : DECL_INITIAL (TREE_VALUE (value
)),
1948 node
, spc
, false, true);
1956 case FIXED_POINT_TYPE
:
1959 enum tree_code_class tclass
;
1961 tclass
= TREE_CODE_CLASS (TREE_CODE (node
));
1963 if (tclass
== tcc_declaration
)
1965 if (DECL_NAME (node
))
1966 pp_ada_tree_identifier
1967 (buffer
, DECL_NAME (node
), 0, limited_access
);
1969 pp_string (buffer
, "<unnamed type decl>");
1971 else if (tclass
== tcc_type
)
1973 if (TYPE_NAME (node
))
1975 if (TREE_CODE (TYPE_NAME (node
)) == IDENTIFIER_NODE
)
1976 pp_ada_tree_identifier (buffer
, TYPE_NAME (node
),
1977 node
, limited_access
);
1978 else if (TREE_CODE (TYPE_NAME (node
)) == TYPE_DECL
1979 && DECL_NAME (TYPE_NAME (node
)))
1980 dump_ada_decl_name (buffer
, TYPE_NAME (node
), limited_access
);
1982 pp_string (buffer
, "<unnamed type>");
1984 else if (TREE_CODE (node
) == INTEGER_TYPE
)
1986 append_withs ("Interfaces.C.Extensions", false);
1987 bitfield_used
= true;
1989 if (TYPE_PRECISION (node
) == 1)
1990 pp_string (buffer
, "Extensions.Unsigned_1");
1993 pp_string (buffer
, (TYPE_UNSIGNED (node
)
1994 ? "Extensions.Unsigned_"
1995 : "Extensions.Signed_"));
1996 pp_decimal_int (buffer
, TYPE_PRECISION (node
));
2000 pp_string (buffer
, "<unnamed type>");
2006 case REFERENCE_TYPE
:
2007 if (name_only
&& TYPE_NAME (node
))
2008 dump_generic_ada_node
2009 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2011 else if (TREE_CODE (TREE_TYPE (node
)) == FUNCTION_TYPE
)
2013 tree fnode
= TREE_TYPE (node
);
2016 if (VOID_TYPE_P (TREE_TYPE (fnode
)))
2018 is_function
= false;
2019 pp_string (buffer
, "access procedure");
2024 pp_string (buffer
, "access function");
2027 dump_ada_function_declaration
2028 (buffer
, node
, false, false, false, spc
+ INDENT_INCR
);
2032 pp_string (buffer
, " return ");
2033 dump_generic_ada_node
2034 (buffer
, TREE_TYPE (fnode
), type
, spc
, 0, true);
2037 /* If we are dumping the full type, it means we are part of a
2038 type definition and need also a Convention C pragma. */
2041 pp_semicolon (buffer
);
2042 newline_and_indent (buffer
, spc
);
2043 pp_string (buffer
, "pragma Convention (C, ");
2044 dump_generic_ada_node
2045 (buffer
, type
, 0, spc
, false, true);
2046 pp_right_paren (buffer
);
2051 int is_access
= false;
2052 unsigned int quals
= TYPE_QUALS (TREE_TYPE (node
));
2054 if (VOID_TYPE_P (TREE_TYPE (node
)))
2057 pp_string (buffer
, "new ");
2060 append_withs ("System", false);
2061 pp_string (buffer
, "System.Address");
2064 pp_string (buffer
, "address");
2068 if (TREE_CODE (node
) == POINTER_TYPE
2069 && TREE_CODE (TREE_TYPE (node
)) == INTEGER_TYPE
2071 (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME
2072 (TREE_TYPE (node
)))), "char"))
2075 pp_string (buffer
, "new ");
2079 pp_string (buffer
, "Interfaces.C.Strings.chars_ptr");
2080 append_withs ("Interfaces.C.Strings", false);
2083 pp_string (buffer
, "chars_ptr");
2087 /* For now, handle all access-to-access or
2088 access-to-unknown-structs as opaque system.address. */
2090 tree type_name
= TYPE_NAME (TREE_TYPE (node
));
2091 const_tree typ2
= !type
||
2092 DECL_P (type
) ? type
: TYPE_NAME (type
);
2093 const_tree underlying_type
=
2094 get_underlying_decl (TREE_TYPE (node
));
2096 if (TREE_CODE (TREE_TYPE (node
)) == POINTER_TYPE
2097 /* Pointer to pointer. */
2099 || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node
))
2100 && (!underlying_type
2101 || !TYPE_FIELDS (TREE_TYPE (underlying_type
))))
2102 /* Pointer to opaque structure. */
2104 || underlying_type
== NULL_TREE
2106 && !TREE_VISITED (underlying_type
)
2107 && !TREE_VISITED (type_name
)
2108 && !is_tagged_type (TREE_TYPE (node
))
2109 && DECL_SOURCE_FILE (underlying_type
)
2110 == source_file_base
)
2111 || (type_name
&& typ2
2112 && DECL_P (underlying_type
)
2114 && decl_sloc (underlying_type
, true)
2115 > decl_sloc (typ2
, true)
2116 && DECL_SOURCE_FILE (underlying_type
)
2117 == DECL_SOURCE_FILE (typ2
)))
2121 append_withs ("System", false);
2123 pp_string (buffer
, "new ");
2124 pp_string (buffer
, "System.Address");
2127 pp_string (buffer
, "address");
2131 if (!package_prefix
)
2132 pp_string (buffer
, "access");
2133 else if (AGGREGATE_TYPE_P (TREE_TYPE (node
)))
2135 if (!type
|| TREE_CODE (type
) != FUNCTION_DECL
)
2137 pp_string (buffer
, "access ");
2140 if (quals
& TYPE_QUAL_CONST
)
2141 pp_string (buffer
, "constant ");
2142 else if (!name_only
)
2143 pp_string (buffer
, "all ");
2145 else if (quals
& TYPE_QUAL_CONST
)
2146 pp_string (buffer
, "in ");
2150 pp_string (buffer
, "access ");
2151 /* ??? should be configurable: access or in out. */
2157 pp_string (buffer
, "access ");
2160 pp_string (buffer
, "all ");
2163 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node
))
2164 && type_name
!= NULL_TREE
)
2165 dump_generic_ada_node
2167 TREE_TYPE (node
), spc
, is_access
, true);
2169 dump_generic_ada_node
2170 (buffer
, TREE_TYPE (node
), TREE_TYPE (node
),
2179 dump_generic_ada_node
2180 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2182 dump_ada_array_type (buffer
, node
, spc
);
2187 case QUAL_UNION_TYPE
:
2190 if (TYPE_NAME (node
))
2191 dump_generic_ada_node
2192 (buffer
, TYPE_NAME (node
), node
, spc
, limited_access
, true);
2195 pp_string (buffer
, "anon_");
2196 pp_scalar (buffer
, "%d", TYPE_UID (node
));
2200 print_ada_struct_decl (buffer
, node
, type
, spc
, true);
2204 /* We treat the upper half of the sizetype range as negative. This
2205 is consistent with the internal treatment and makes it possible
2206 to generate the (0 .. -1) range for flexible array members. */
2207 if (TREE_TYPE (node
) == sizetype
)
2208 node
= fold_convert (ssizetype
, node
);
2209 if (tree_fits_shwi_p (node
))
2210 pp_wide_integer (buffer
, tree_to_shwi (node
));
2211 else if (tree_fits_uhwi_p (node
))
2212 pp_unsigned_wide_integer (buffer
, tree_to_uhwi (node
));
2215 wide_int val
= node
;
2217 if (wi::neg_p (val
))
2222 sprintf (pp_buffer (buffer
)->digit_buffer
,
2223 "16#%" HOST_WIDE_INT_PRINT
"x",
2224 val
.elt (val
.get_len () - 1));
2225 for (i
= val
.get_len () - 2; i
>= 0; i
--)
2226 sprintf (pp_buffer (buffer
)->digit_buffer
,
2227 HOST_WIDE_INT_PRINT_PADDED_HEX
, val
.elt (i
));
2228 pp_string (buffer
, pp_buffer (buffer
)->digit_buffer
);
2241 dump_ada_decl_name (buffer
, node
, limited_access
);
2245 if (DECL_IS_BUILTIN (node
))
2247 /* Don't print the declaration of built-in types. */
2251 /* If we're in the middle of a declaration, defaults to
2255 append_withs ("System", false);
2256 pp_string (buffer
, "System.Address");
2259 pp_string (buffer
, "address");
2265 dump_ada_decl_name (buffer
, node
, limited_access
);
2268 if (is_tagged_type (TREE_TYPE (node
)))
2270 tree tmp
= TYPE_FIELDS (TREE_TYPE (node
));
2273 /* Look for ancestors. */
2274 for (; tmp
; tmp
= TREE_CHAIN (tmp
))
2276 if (!DECL_NAME (tmp
) && is_tagged_type (TREE_TYPE (tmp
)))
2280 pp_string (buffer
, "limited new ");
2284 pp_string (buffer
, " and ");
2287 (buffer
, TYPE_NAME (TREE_TYPE (tmp
)), false);
2291 pp_string (buffer
, first
? "tagged limited " : " with ");
2293 else if (has_nontrivial_methods (TREE_TYPE (node
)))
2294 pp_string (buffer
, "limited ");
2296 dump_generic_ada_node
2297 (buffer
, TREE_TYPE (node
), type
, spc
, false, false);
2304 case NAMESPACE_DECL
:
2305 dump_ada_decl_name (buffer
, node
, false);
2309 /* Ignore other nodes (e.g. expressions). */
2316 /* Dump in BUFFER NODE's methods. SPC is the indentation level. Return 1 if
2317 methods were printed, 0 otherwise.
2319 We do it in 2 passes: first, the regular methods, i.e. non-static member
2320 functions, are output immediately within the package created for the class
2321 so that they are considered as primitive operations in Ada; second, the
2322 static member functions are output in a nested package so that they are
2323 _not_ considered as primitive operations in Ada.
2325 This approach is necessary because the formers have the implicit 'this'
2326 pointer whereas the latters don't and, on 32-bit x86/Windows, the calling
2327 conventions for the 'this' pointer are special. Therefore, the compiler
2328 needs to be able to differentiate regular methods (with 'this' pointer)
2329 from static member functions that take a pointer to the class as first
2333 print_ada_methods (pretty_printer
*buffer
, tree node
, int spc
)
2335 bool has_static_methods
= false;
2339 if (!has_nontrivial_methods (node
))
2342 pp_semicolon (buffer
);
2344 /* First pass: the regular methods. */
2346 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2348 if (TREE_CODE (TREE_TYPE (t
)) != METHOD_TYPE
)
2350 has_static_methods
= true;
2356 pp_newline (buffer
);
2357 pp_newline (buffer
);
2360 res
= print_ada_declaration (buffer
, t
, node
, spc
);
2363 if (!has_static_methods
)
2366 pp_newline (buffer
);
2367 newline_and_indent (buffer
, spc
);
2369 /* Second pass: the static member functions. */
2370 pp_string (buffer
, "package Static is");
2371 pp_newline (buffer
);
2375 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2377 if (TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
)
2382 pp_newline (buffer
);
2383 pp_newline (buffer
);
2386 res
= print_ada_declaration (buffer
, t
, node
, spc
);
2390 newline_and_indent (buffer
, spc
);
2391 pp_string (buffer
, "end;");
2393 /* In order to save the clients from adding a second use clause for the
2394 nested package, we generate renamings for the static member functions
2395 in the package created for the class. */
2396 for (t
= TYPE_METHODS (node
); t
; t
= TREE_CHAIN (t
))
2400 if (TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
)
2403 pp_newline (buffer
);
2404 newline_and_indent (buffer
, spc
);
2406 if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t
))))
2408 pp_string (buffer
, "procedure ");
2409 is_function
= false;
2413 pp_string (buffer
, "function ");
2417 dump_ada_decl_name (buffer
, t
, false);
2418 dump_ada_function_declaration (buffer
, t
, false, false, false, spc
);
2422 pp_string (buffer
, " return ");
2423 dump_generic_ada_node (buffer
, TREE_TYPE (TREE_TYPE (t
)), node
,
2427 pp_string (buffer
, " renames Static.");
2428 dump_ada_decl_name (buffer
, t
, false);
2429 pp_semicolon (buffer
);
2435 /* Dump in BUFFER anonymous types nested inside T's definition.
2436 PARENT is the parent node of T.
2437 FORWARD indicates whether a forward declaration of T should be generated.
2438 SPC is the indentation level. */
2441 dump_nested_types (pretty_printer
*buffer
, tree t
, tree parent
, bool forward
,
2444 tree field
, outer
, decl
;
2446 /* Avoid recursing over the same tree. */
2447 if (TREE_VISITED (t
))
2450 /* Find possible anonymous arrays/unions/structs recursively. */
2452 outer
= TREE_TYPE (t
);
2454 if (outer
== NULL_TREE
)
2459 pp_string (buffer
, "type ");
2460 dump_generic_ada_node (buffer
, t
, t
, spc
, false, true);
2461 pp_semicolon (buffer
);
2462 newline_and_indent (buffer
, spc
);
2463 TREE_VISITED (t
) = 1;
2466 field
= TYPE_FIELDS (outer
);
2469 if ((TREE_TYPE (field
) != outer
2470 || (TREE_CODE (TREE_TYPE (field
)) == POINTER_TYPE
2471 && TREE_TYPE (TREE_TYPE (field
)) != outer
))
2472 && (!TYPE_NAME (TREE_TYPE (field
))
2473 || (TREE_CODE (field
) == TYPE_DECL
2474 && DECL_NAME (field
) != DECL_NAME (t
)
2475 && TYPE_NAME (TREE_TYPE (field
)) != TYPE_NAME (outer
))))
2477 switch (TREE_CODE (TREE_TYPE (field
)))
2480 decl
= TREE_TYPE (TREE_TYPE (field
));
2482 if (TREE_CODE (decl
) == FUNCTION_TYPE
)
2483 for (decl
= TREE_TYPE (decl
);
2484 decl
&& TREE_CODE (decl
) == POINTER_TYPE
;
2485 decl
= TREE_TYPE (decl
))
2488 decl
= get_underlying_decl (decl
);
2492 && decl_sloc (decl
, true) > decl_sloc (t
, true)
2493 && DECL_SOURCE_FILE (decl
) == DECL_SOURCE_FILE (t
)
2494 && !TREE_VISITED (decl
)
2495 && !DECL_IS_BUILTIN (decl
)
2496 && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl
))
2497 || TYPE_FIELDS (TREE_TYPE (decl
))))
2499 /* Generate forward declaration. */
2501 pp_string (buffer
, "type ");
2502 dump_generic_ada_node (buffer
, decl
, 0, spc
, false, true);
2503 pp_semicolon (buffer
);
2504 newline_and_indent (buffer
, spc
);
2506 /* Ensure we do not generate duplicate forward
2507 declarations for this type. */
2508 TREE_VISITED (decl
) = 1;
2513 /* Special case char arrays. */
2514 if (is_char_array (field
))
2515 pp_string (buffer
, "sub");
2517 pp_string (buffer
, "type ");
2518 dump_ada_double_name (buffer
, parent
, field
, "_array is ");
2519 dump_ada_array_type (buffer
, field
, spc
);
2520 pp_semicolon (buffer
);
2521 newline_and_indent (buffer
, spc
);
2525 TREE_VISITED (t
) = 1;
2526 dump_nested_types (buffer
, field
, t
, false, spc
);
2528 pp_string (buffer
, "type ");
2530 if (TYPE_NAME (TREE_TYPE (field
)))
2532 dump_generic_ada_node
2533 (buffer
, TYPE_NAME (TREE_TYPE (field
)), 0, spc
, false,
2535 pp_string (buffer
, " (discr : unsigned := 0) is ");
2536 print_ada_struct_decl
2537 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2539 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2540 dump_generic_ada_node
2541 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2542 pp_string (buffer
, ");");
2543 newline_and_indent (buffer
, spc
);
2545 pp_string (buffer
, "pragma Unchecked_Union (");
2546 dump_generic_ada_node
2547 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2548 pp_string (buffer
, ");");
2552 dump_ada_double_name
2553 (buffer
, parent
, field
,
2554 "_union (discr : unsigned := 0) is ");
2555 print_ada_struct_decl
2556 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2557 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2558 dump_ada_double_name (buffer
, parent
, field
, "_union);");
2559 newline_and_indent (buffer
, spc
);
2561 pp_string (buffer
, "pragma Unchecked_Union (");
2562 dump_ada_double_name (buffer
, parent
, field
, "_union);");
2565 newline_and_indent (buffer
, spc
);
2569 if (TYPE_NAME (TREE_TYPE (t
)) && !TREE_VISITED (t
))
2571 pp_string (buffer
, "type ");
2572 dump_generic_ada_node
2573 (buffer
, t
, parent
, spc
, false, true);
2574 pp_semicolon (buffer
);
2575 newline_and_indent (buffer
, spc
);
2578 TREE_VISITED (t
) = 1;
2579 dump_nested_types (buffer
, field
, t
, false, spc
);
2580 pp_string (buffer
, "type ");
2582 if (TYPE_NAME (TREE_TYPE (field
)))
2584 dump_generic_ada_node
2585 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2586 pp_string (buffer
, " is ");
2587 print_ada_struct_decl
2588 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2589 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2590 dump_generic_ada_node
2591 (buffer
, TREE_TYPE (field
), 0, spc
, false, true);
2592 pp_string (buffer
, ");");
2596 dump_ada_double_name
2597 (buffer
, parent
, field
, "_struct is ");
2598 print_ada_struct_decl
2599 (buffer
, TREE_TYPE (field
), t
, spc
, false);
2600 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
2601 dump_ada_double_name (buffer
, parent
, field
, "_struct);");
2604 newline_and_indent (buffer
, spc
);
2611 field
= TREE_CHAIN (field
);
2614 TREE_VISITED (t
) = 1;
2617 /* Dump in BUFFER constructor spec corresponding to T. */
2620 print_constructor (pretty_printer
*buffer
, tree t
)
2622 tree decl_name
= DECL_NAME (DECL_ORIGIN (t
));
2624 pp_string (buffer
, "New_");
2625 pp_ada_tree_identifier (buffer
, decl_name
, t
, false);
2628 /* Dump in BUFFER destructor spec corresponding to T. */
2631 print_destructor (pretty_printer
*buffer
, tree t
)
2633 tree decl_name
= DECL_NAME (DECL_ORIGIN (t
));
2635 pp_string (buffer
, "Delete_");
2636 pp_ada_tree_identifier (buffer
, decl_name
, t
, false);
2639 /* Return the name of type T. */
2644 tree n
= TYPE_NAME (t
);
2646 if (TREE_CODE (n
) == IDENTIFIER_NODE
)
2647 return IDENTIFIER_POINTER (n
);
2649 return IDENTIFIER_POINTER (DECL_NAME (n
));
2652 /* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
2653 SPC is the indentation level. Return 1 if a declaration was printed,
2657 print_ada_declaration (pretty_printer
*buffer
, tree t
, tree type
, int spc
)
2659 int is_var
= 0, need_indent
= 0;
2660 int is_class
= false;
2661 tree name
= TYPE_NAME (TREE_TYPE (t
));
2662 tree decl_name
= DECL_NAME (t
);
2663 tree orig
= NULL_TREE
;
2665 if (cpp_check
&& cpp_check (t
, IS_TEMPLATE
))
2666 return dump_ada_template (buffer
, t
, spc
);
2668 if (TREE_CODE (t
) == CONST_DECL
&& TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
)
2669 /* Skip enumeral values: will be handled as part of the type itself. */
2672 if (TREE_CODE (t
) == TYPE_DECL
)
2674 orig
= DECL_ORIGINAL_TYPE (t
);
2676 if (orig
&& TYPE_STUB_DECL (orig
))
2678 tree stub
= TYPE_STUB_DECL (orig
);
2679 tree typ
= TREE_TYPE (stub
);
2681 if (TYPE_NAME (typ
))
2683 /* If types have same representation, and same name (ignoring
2684 casing), then ignore the second type. */
2685 if (type_name (typ
) == type_name (TREE_TYPE (t
))
2686 || !strcasecmp (type_name (typ
), type_name (TREE_TYPE (t
))))
2691 if (RECORD_OR_UNION_TYPE_P (typ
) && !TYPE_FIELDS (typ
))
2693 pp_string (buffer
, "-- skipped empty struct ");
2694 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2698 if (!TREE_VISITED (stub
)
2699 && DECL_SOURCE_FILE (stub
) == source_file_base
)
2700 dump_nested_types (buffer
, stub
, stub
, true, spc
);
2702 pp_string (buffer
, "subtype ");
2703 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2704 pp_string (buffer
, " is ");
2705 dump_generic_ada_node (buffer
, typ
, type
, spc
, false, true);
2706 pp_semicolon (buffer
);
2712 /* Skip unnamed or anonymous structs/unions/enum types. */
2713 if (!orig
&& !decl_name
&& !name
)
2718 if (cpp_check
|| TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
)
2721 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
)))
2723 /* Search next items until finding a named type decl. */
2724 sloc
= decl_sloc_common (t
, true, true);
2726 for (tmp
= TREE_CHAIN (t
); tmp
; tmp
= TREE_CHAIN (tmp
))
2728 if (TREE_CODE (tmp
) == TYPE_DECL
2729 && (DECL_NAME (tmp
) || TYPE_NAME (TREE_TYPE (tmp
))))
2731 /* If same sloc, it means we can ignore the anonymous
2733 if (decl_sloc_common (tmp
, true, true) == sloc
)
2745 && TREE_CODE (TREE_TYPE (t
)) == ENUMERAL_TYPE
2747 && (*IDENTIFIER_POINTER (decl_name
) == '.'
2748 || *IDENTIFIER_POINTER (decl_name
) == '$'))
2749 /* Skip anonymous enum types (duplicates of real types). */
2754 switch (TREE_CODE (TREE_TYPE (t
)))
2758 case QUAL_UNION_TYPE
:
2759 /* Skip empty structs (typically forward references to real
2761 if (!TYPE_FIELDS (TREE_TYPE (t
)))
2763 pp_string (buffer
, "-- skipped empty struct ");
2764 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2769 && (*IDENTIFIER_POINTER (decl_name
) == '.'
2770 || *IDENTIFIER_POINTER (decl_name
) == '$'))
2772 pp_string (buffer
, "-- skipped anonymous struct ");
2773 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2774 TREE_VISITED (t
) = 1;
2778 if (orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2779 pp_string (buffer
, "subtype ");
2782 dump_nested_types (buffer
, t
, t
, false, spc
);
2784 if (separate_class_package (t
))
2787 pp_string (buffer
, "package Class_");
2788 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2789 pp_string (buffer
, " is");
2791 newline_and_indent (buffer
, spc
);
2794 pp_string (buffer
, "type ");
2800 case REFERENCE_TYPE
:
2801 if ((orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2802 || is_char_array (t
))
2803 pp_string (buffer
, "subtype ");
2805 pp_string (buffer
, "type ");
2809 pp_string (buffer
, "-- skipped function type ");
2810 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2815 if ((orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2816 || !is_simple_enum (TREE_TYPE (t
)))
2817 pp_string (buffer
, "subtype ");
2819 pp_string (buffer
, "type ");
2823 pp_string (buffer
, "subtype ");
2825 TREE_VISITED (t
) = 1;
2831 && *IDENTIFIER_POINTER (decl_name
) == '_')
2837 /* Print the type and name. */
2838 if (TREE_CODE (TREE_TYPE (t
)) == ARRAY_TYPE
)
2843 /* Print variable's name. */
2844 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
2846 if (TREE_CODE (t
) == TYPE_DECL
)
2848 pp_string (buffer
, " is ");
2850 if (orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
))
2851 dump_generic_ada_node
2852 (buffer
, TYPE_NAME (orig
), type
, spc
, false, true);
2854 dump_ada_array_type (buffer
, t
, spc
);
2858 tree tmp
= TYPE_NAME (TREE_TYPE (t
));
2860 if (spc
== INDENT_INCR
|| TREE_STATIC (t
))
2863 pp_string (buffer
, " : ");
2867 if (TREE_CODE (TREE_TYPE (tmp
)) != POINTER_TYPE
2868 && TREE_CODE (tmp
) != INTEGER_TYPE
)
2869 pp_string (buffer
, "aliased ");
2871 dump_generic_ada_node (buffer
, tmp
, type
, spc
, false, true);
2875 pp_string (buffer
, "aliased ");
2878 dump_ada_array_type (buffer
, t
, spc
);
2880 dump_ada_double_name (buffer
, type
, t
, "_array");
2884 else if (TREE_CODE (t
) == FUNCTION_DECL
)
2886 bool is_function
, is_abstract_class
= false;
2887 bool is_method
= TREE_CODE (TREE_TYPE (t
)) == METHOD_TYPE
;
2888 tree decl_name
= DECL_NAME (t
);
2889 bool is_abstract
= false;
2890 bool is_constructor
= false;
2891 bool is_destructor
= false;
2892 bool is_copy_constructor
= false;
2893 bool is_move_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
);
2904 is_move_constructor
= cpp_check (t
, IS_MOVE_CONSTRUCTOR
);
2907 /* Skip copy constructors and C++11 move constructors: some are internal
2908 only and those that are not cannot be called easily from Ada. */
2909 if (is_copy_constructor
|| is_move_constructor
)
2912 if (is_constructor
|| is_destructor
)
2914 /* ??? Skip implicit constructors/destructors for now. */
2915 if (DECL_ARTIFICIAL (t
))
2918 /* Only consider constructors/destructors for complete objects. */
2919 if (strncmp (IDENTIFIER_POINTER (decl_name
), "__comp", 6) != 0)
2923 /* If this function has an entry in the vtable, we cannot omit it. */
2924 else if (!DECL_VINDEX (t
) && *IDENTIFIER_POINTER (decl_name
) == '_')
2927 pp_string (buffer
, "-- skipped func ");
2928 pp_string (buffer
, IDENTIFIER_POINTER (decl_name
));
2935 if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t
))) && !is_constructor
)
2937 pp_string (buffer
, "procedure ");
2938 is_function
= false;
2942 pp_string (buffer
, "function ");
2947 print_constructor (buffer
, t
);
2948 else if (is_destructor
)
2949 print_destructor (buffer
, t
);
2951 dump_ada_decl_name (buffer
, t
, false);
2953 dump_ada_function_declaration
2954 (buffer
, t
, is_method
, is_constructor
, is_destructor
, spc
);
2958 pp_string (buffer
, " return ");
2960 = is_constructor
? DECL_CONTEXT (t
) : TREE_TYPE (TREE_TYPE (t
));
2961 dump_generic_ada_node (buffer
, ret_type
, type
, spc
, false, true);
2965 && RECORD_OR_UNION_TYPE_P (type
)
2966 && TYPE_METHODS (type
))
2970 for (tmp
= TYPE_METHODS (type
); tmp
; tmp
= TREE_CHAIN (tmp
))
2971 if (cpp_check (tmp
, IS_ABSTRACT
))
2973 is_abstract_class
= true;
2978 if (is_abstract
|| is_abstract_class
)
2979 pp_string (buffer
, " is abstract");
2981 pp_semicolon (buffer
);
2982 pp_string (buffer
, " -- ");
2983 dump_sloc (buffer
, t
);
2985 if (is_abstract
|| !DECL_ASSEMBLER_NAME (t
))
2988 newline_and_indent (buffer
, spc
);
2992 pp_string (buffer
, "pragma CPP_Constructor (");
2993 print_constructor (buffer
, t
);
2994 pp_string (buffer
, ", \"");
2995 pp_asm_name (buffer
, t
);
2996 pp_string (buffer
, "\");");
2998 else if (is_destructor
)
3000 pp_string (buffer
, "pragma Import (CPP, ");
3001 print_destructor (buffer
, t
);
3002 pp_string (buffer
, ", \"");
3003 pp_asm_name (buffer
, t
);
3004 pp_string (buffer
, "\");");
3008 dump_ada_import (buffer
, t
);
3013 else if (TREE_CODE (t
) == TYPE_DECL
&& !DECL_ORIGINAL_TYPE (t
))
3015 int is_interface
= 0;
3016 int is_abstract_record
= 0;
3021 /* Anonymous structs/unions */
3022 dump_generic_ada_node (buffer
, TREE_TYPE (t
), t
, spc
, false, true);
3024 if (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3025 || TREE_CODE (TREE_TYPE (t
)) == QUAL_UNION_TYPE
)
3027 pp_string (buffer
, " (discr : unsigned := 0)");
3030 pp_string (buffer
, " is ");
3032 /* Check whether we have an Ada interface compatible class. */
3034 && RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
))
3035 && TYPE_METHODS (TREE_TYPE (t
)))
3040 /* Check that there are no fields other than the virtual table. */
3041 for (tmp
= TYPE_FIELDS (TREE_TYPE (t
)); tmp
; tmp
= TREE_CHAIN (tmp
))
3043 if (TREE_CODE (tmp
) == TYPE_DECL
)
3048 if (num_fields
== 1)
3051 /* Also check that there are only pure virtual methods. Since the
3052 class is empty, we can skip implicit constructors/destructors. */
3053 for (tmp
= TYPE_METHODS (TREE_TYPE (t
)); tmp
; tmp
= TREE_CHAIN (tmp
))
3055 if (DECL_ARTIFICIAL (tmp
))
3057 if (cpp_check (tmp
, IS_ABSTRACT
))
3058 is_abstract_record
= 1;
3064 TREE_VISITED (t
) = 1;
3067 pp_string (buffer
, "limited interface; -- ");
3068 dump_sloc (buffer
, t
);
3069 newline_and_indent (buffer
, spc
);
3070 pp_string (buffer
, "pragma Import (CPP, ");
3071 dump_generic_ada_node
3072 (buffer
, TYPE_NAME (TREE_TYPE (t
)), type
, spc
, false, true);
3073 pp_right_paren (buffer
);
3075 print_ada_methods (buffer
, TREE_TYPE (t
), spc
);
3079 if (is_abstract_record
)
3080 pp_string (buffer
, "abstract ");
3081 dump_generic_ada_node (buffer
, t
, t
, spc
, false, false);
3089 if (TREE_CODE (t
) == FIELD_DECL
&& DECL_NAME (t
))
3090 check_name (buffer
, t
);
3092 /* Print variable/type's name. */
3093 dump_generic_ada_node (buffer
, t
, t
, spc
, false, true);
3095 if (TREE_CODE (t
) == TYPE_DECL
)
3097 tree orig
= DECL_ORIGINAL_TYPE (t
);
3098 int is_subtype
= orig
&& TYPE_NAME (orig
) && orig
!= TREE_TYPE (t
);
3101 && (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3102 || TREE_CODE (TREE_TYPE (t
)) == QUAL_UNION_TYPE
))
3103 pp_string (buffer
, " (discr : unsigned := 0)");
3105 pp_string (buffer
, " is ");
3107 dump_generic_ada_node (buffer
, orig
, t
, spc
, false, is_subtype
);
3111 if (spc
== INDENT_INCR
|| TREE_STATIC (t
))
3114 pp_string (buffer
, " : ");
3116 /* Print type declaration. */
3118 if (TREE_CODE (TREE_TYPE (t
)) == UNION_TYPE
3119 && !TYPE_NAME (TREE_TYPE (t
)))
3121 dump_ada_double_name (buffer
, type
, t
, "_union");
3123 else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t
)))
3125 if (TREE_CODE (TREE_TYPE (t
)) == RECORD_TYPE
)
3126 pp_string (buffer
, "aliased ");
3128 dump_generic_ada_node
3129 (buffer
, TREE_TYPE (t
), t
, spc
, false, true);
3133 if (TREE_CODE (TREE_TYPE (t
)) != POINTER_TYPE
3134 && (TYPE_NAME (TREE_TYPE (t
))
3135 || TREE_CODE (TREE_TYPE (t
)) != INTEGER_TYPE
))
3136 pp_string (buffer
, "aliased ");
3138 dump_generic_ada_node
3139 (buffer
, TREE_TYPE (t
), TREE_TYPE (t
), spc
, false, true);
3147 newline_and_indent (buffer
, spc
);
3148 pp_string (buffer
, "end;");
3149 newline_and_indent (buffer
, spc
);
3150 pp_string (buffer
, "use Class_");
3151 dump_generic_ada_node (buffer
, t
, type
, spc
, false, true);
3152 pp_semicolon (buffer
);
3153 pp_newline (buffer
);
3155 /* All needed indentation/newline performed already, so return 0. */
3160 pp_string (buffer
, "; -- ");
3161 dump_sloc (buffer
, t
);
3166 newline_and_indent (buffer
, spc
);
3167 dump_ada_import (buffer
, t
);
3173 /* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
3174 with Ada syntax. SPC is the indentation level. If DISPLAY_CONVENTION is
3175 true, also print the pragma Convention for NODE. */
3178 print_ada_struct_decl (pretty_printer
*buffer
, tree node
, tree type
, int spc
,
3179 bool display_convention
)
3183 = TREE_CODE (node
) == UNION_TYPE
|| TREE_CODE (node
) == QUAL_UNION_TYPE
;
3186 int field_spc
= spc
+ INDENT_INCR
;
3189 bitfield_used
= false;
3191 if (!TYPE_FIELDS (node
))
3192 pp_string (buffer
, "null record;");
3195 pp_string (buffer
, "record");
3197 /* Print the contents of the structure. */
3201 newline_and_indent (buffer
, spc
+ INDENT_INCR
);
3202 pp_string (buffer
, "case discr is");
3203 field_spc
= spc
+ INDENT_INCR
* 3;
3206 pp_newline (buffer
);
3208 /* Print the non-static fields of the structure. */
3209 for (tmp
= TYPE_FIELDS (node
); tmp
; tmp
= TREE_CHAIN (tmp
))
3211 /* Add parent field if needed. */
3212 if (!DECL_NAME (tmp
))
3214 if (!is_tagged_type (TREE_TYPE (tmp
)))
3216 if (!TYPE_NAME (TREE_TYPE (tmp
)))
3217 print_ada_declaration (buffer
, tmp
, type
, field_spc
);
3223 pp_string (buffer
, "parent : aliased ");
3226 sprintf (buf
, "field_%d : aliased ", field_num
+ 1);
3227 pp_string (buffer
, buf
);
3230 (buffer
, TYPE_NAME (TREE_TYPE (tmp
)), false);
3231 pp_semicolon (buffer
);
3233 pp_newline (buffer
);
3237 /* Avoid printing the structure recursively. */
3238 else if ((TREE_TYPE (tmp
) != node
3239 || (TREE_CODE (TREE_TYPE (tmp
)) == POINTER_TYPE
3240 && TREE_TYPE (TREE_TYPE (tmp
)) != node
))
3241 && TREE_CODE (tmp
) != TYPE_DECL
3242 && !TREE_STATIC (tmp
))
3244 /* Skip internal virtual table field. */
3245 if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp
)), "_vptr", 5))
3249 if (TREE_CHAIN (tmp
)
3250 && TREE_TYPE (TREE_CHAIN (tmp
)) != node
3251 && TREE_CODE (TREE_CHAIN (tmp
)) != TYPE_DECL
)
3252 sprintf (buf
, "when %d =>", field_num
);
3254 sprintf (buf
, "when others =>");
3256 INDENT (spc
+ INDENT_INCR
* 2);
3257 pp_string (buffer
, buf
);
3258 pp_newline (buffer
);
3261 if (print_ada_declaration (buffer
, tmp
, type
, field_spc
))
3263 pp_newline (buffer
);
3272 INDENT (spc
+ INDENT_INCR
);
3273 pp_string (buffer
, "end case;");
3274 pp_newline (buffer
);
3279 INDENT (spc
+ INDENT_INCR
);
3280 pp_string (buffer
, "null;");
3281 pp_newline (buffer
);
3285 pp_string (buffer
, "end record;");
3288 newline_and_indent (buffer
, spc
);
3290 if (!display_convention
)
3293 if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type
)))
3295 if (has_nontrivial_methods (TREE_TYPE (type
)))
3296 pp_string (buffer
, "pragma Import (CPP, ");
3298 pp_string (buffer
, "pragma Convention (C_Pass_By_Copy, ");
3301 pp_string (buffer
, "pragma Convention (C, ");
3303 package_prefix
= false;
3304 dump_generic_ada_node (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3305 package_prefix
= true;
3306 pp_right_paren (buffer
);
3310 pp_semicolon (buffer
);
3311 newline_and_indent (buffer
, spc
);
3312 pp_string (buffer
, "pragma Unchecked_Union (");
3314 dump_generic_ada_node (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3315 pp_right_paren (buffer
);
3320 pp_semicolon (buffer
);
3321 newline_and_indent (buffer
, spc
);
3322 pp_string (buffer
, "pragma Pack (");
3323 dump_generic_ada_node
3324 (buffer
, TREE_TYPE (type
), type
, spc
, false, true);
3325 pp_right_paren (buffer
);
3326 bitfield_used
= false;
3329 need_semicolon
= !print_ada_methods (buffer
, node
, spc
);
3331 /* Print the static fields of the structure, if any. */
3332 for (tmp
= TYPE_FIELDS (node
); tmp
; tmp
= TREE_CHAIN (tmp
))
3334 if (DECL_NAME (tmp
) && TREE_STATIC (tmp
))
3338 need_semicolon
= false;
3339 pp_semicolon (buffer
);
3341 pp_newline (buffer
);
3342 pp_newline (buffer
);
3343 print_ada_declaration (buffer
, tmp
, type
, spc
);
3348 /* Dump all the declarations in SOURCE_FILE to an Ada spec.
3349 COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3350 nodes for SOURCE_FILE. CHECK is used to perform C++ queries on nodes. */
3353 dump_ads (const char *source_file
,
3354 void (*collect_all_refs
)(const char *),
3355 int (*check
)(tree
, cpp_operation
))
3362 pkg_name
= get_ada_package (source_file
);
3364 /* Construct the .ads filename and package name. */
3365 ads_name
= xstrdup (pkg_name
);
3367 for (s
= ads_name
; *s
; s
++)
3373 ads_name
= reconcat (ads_name
, ads_name
, ".ads", NULL
);
3375 /* Write out the .ads file. */
3376 f
= fopen (ads_name
, "w");
3381 pp_needs_newline (&pp
) = true;
3382 pp
.buffer
->stream
= f
;
3384 /* Dump all relevant macros. */
3385 dump_ada_macros (&pp
, source_file
);
3387 /* Reset the table of withs for this file. */
3390 (*collect_all_refs
) (source_file
);
3392 /* Dump all references. */
3394 dump_ada_nodes (&pp
, source_file
);
3396 /* Requires Ada 2005 syntax, so generate corresponding pragma.
3397 Also, disable style checks since this file is auto-generated. */
3398 fprintf (f
, "pragma Ada_2005;\npragma Style_Checks (Off);\n\n");
3403 fprintf (f
, "\npackage %s is\n\n", pkg_name
);
3404 pp_write_text_to_stream (&pp
);
3405 /* ??? need to free pp */
3406 fprintf (f
, "end %s;\n", pkg_name
);
3414 static const char **source_refs
= NULL
;
3415 static int source_refs_used
= 0;
3416 static int source_refs_allocd
= 0;
3418 /* Add an entry for FILENAME to the table SOURCE_REFS. */
3421 collect_source_ref (const char *filename
)
3428 if (source_refs_allocd
== 0)
3430 source_refs_allocd
= 1024;
3431 source_refs
= XNEWVEC (const char *, source_refs_allocd
);
3434 for (i
= 0; i
< source_refs_used
; i
++)
3435 if (filename
== source_refs
[i
])
3438 if (source_refs_used
== source_refs_allocd
)
3440 source_refs_allocd
*= 2;
3441 source_refs
= XRESIZEVEC (const char *, source_refs
, source_refs_allocd
);
3444 source_refs
[source_refs_used
++] = filename
;
3447 /* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
3448 using callbacks COLLECT_ALL_REFS and CHECK.
3449 COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3450 nodes for a given source file.
3451 CHECK is used to perform C++ queries on nodes, or NULL for the C
3455 dump_ada_specs (void (*collect_all_refs
)(const char *),
3456 int (*check
)(tree
, cpp_operation
))
3460 /* Iterate over the list of files to dump specs for */
3461 for (i
= 0; i
< source_refs_used
; i
++)
3462 dump_ads (source_refs
[i
], collect_all_refs
, check
);
3464 /* Free files table. */