--- /dev/null
+/* Print GENERIC declaration (functions, variables, types) trees coming from
+ the C and C++ front-ends as well as macros in Ada syntax.
+ Copyright (C) 2010 Free Software Foundation, Inc.
+ Adapted from tree-pretty-print.c by Arnaud Charlet <charlet@adacore.com>
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "output.h"
+#include "c-ada-spec.h"
+#include "real.h"
+#include "hashtab.h"
+#include "tree-flow.h"
+#include "langhooks.h"
+#include "tree-iterator.h"
+#include "tree-chrec.h"
+#include "tree-pass.h"
+#include "fixed-value.h"
+#include "value-prof.h"
+#include "predict.h"
+#include "cpplib.h"
+#include "c-pragma.h"
+#include "cpp-id-data.h"
+
+/* Local functions, macros and variables. */
+static int dump_generic_ada_node (pretty_printer *, tree, tree,
+ int (*)(tree, cpp_operation), int, int, bool);
+static int print_ada_declaration (pretty_printer *, tree, tree,
+ int (*cpp_check)(tree, cpp_operation), int);
+static void print_ada_struct_decl (pretty_printer *, tree, tree,
+ int (*cpp_check)(tree, cpp_operation), int,
+ bool);
+static void dump_sloc (pretty_printer *buffer, tree node);
+static void print_comment (pretty_printer *, const char *);
+static void print_generic_ada_decl (pretty_printer *, tree,
+ int (*)(tree, cpp_operation), const char *);
+static char *get_ada_package (const char *);
+static void dump_ada_nodes (pretty_printer *, const char *,
+ int (*)(tree, cpp_operation));
+static void reset_ada_withs (void);
+static void dump_ada_withs (FILE *);
+static void dump_ads (const char *, void (*)(const char *),
+ int (*)(tree, cpp_operation));
+static char *to_ada_name (const char *, int *);
+
+#define LOCATION_COL(LOC) ((expand_location (LOC)).column)
+
+#define INDENT(SPACE) do { \
+ int i; for (i = 0; i<SPACE; i++) pp_space (buffer); } while (0)
+
+#define INDENT_INCR 3
+
+/* Given a cpp MACRO, compute the max length BUFFER_LEN of the macro, as well
+ as max length PARAM_LEN of arguments for fun_like macros, and also set
+ SUPPORTED to 0 if the macro cannot be mapped to an Ada construct. */
+
+static void
+macro_length (const cpp_macro *macro, int *supported, int *buffer_len,
+ int *param_len)
+{
+ int i;
+ unsigned j;
+
+ *supported = 1;
+ *buffer_len = 0;
+ *param_len = 0;
+
+ if (macro->fun_like)
+ {
+ param_len++;
+ for (i = 0; i < macro->paramc; i++)
+ {
+ cpp_hashnode *param = macro->params[i];
+
+ *param_len += NODE_LEN (param);
+
+ if (i + 1 < macro->paramc)
+ {
+ *param_len += 2; /* ", " */
+ }
+ else if (macro->variadic)
+ {
+ *supported = 0;
+ return;
+ }
+ }
+ *param_len += 2; /* ")\0" */
+ }
+
+ for (j = 0; j < macro->count; j++)
+ {
+ cpp_token *token = ¯o->exp.tokens[j];
+
+ if (token->flags & PREV_WHITE)
+ (*buffer_len)++;
+
+ if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT)
+ {
+ *supported = 0;
+ return;
+ }
+
+ if (token->type == CPP_MACRO_ARG)
+ *buffer_len +=
+ NODE_LEN (macro->params[token->val.macro_arg.arg_no - 1]);
+ else
+ /* Include enough extra space to handle e.g. special characters. */
+ *buffer_len += (cpp_token_len (token) + 1) * 8;
+ }
+
+ (*buffer_len)++;
+}
+
+/* Dump into PP a set of MAX_ADA_MACROS MACROS (C/C++) as Ada constants when
+ possible. */
+
+static void
+print_ada_macros (pretty_printer *pp, cpp_hashnode **macros, int max_ada_macros)
+{
+ int j, num_macros = 0, prev_line = -1;
+
+ for (j = 0; j < max_ada_macros; j++)
+ {
+ cpp_hashnode *node = macros [j];
+ const cpp_macro *macro = node->value.macro;
+ unsigned i;
+ int supported = 1, prev_is_one = 0, buffer_len, param_len;
+ int is_string = 0, is_char = 0;
+ char *ada_name;
+ unsigned char *s, *params, *buffer, *buf_param, *char_one = NULL;
+
+ macro_length (macro, &supported, &buffer_len, ¶m_len);
+ s = buffer = XALLOCAVEC (unsigned char, buffer_len);
+ params = buf_param = XALLOCAVEC (unsigned char, param_len);
+
+ if (supported)
+ {
+ if (macro->fun_like)
+ {
+ *buf_param++ = '(';
+ for (i = 0; i < macro->paramc; i++)
+ {
+ cpp_hashnode *param = macro->params[i];
+
+ memcpy (buf_param, NODE_NAME (param), NODE_LEN (param));
+ buf_param += NODE_LEN (param);
+
+ if (i + 1 < macro->paramc)
+ {
+ *buf_param++ = ',';
+ *buf_param++ = ' ';
+ }
+ else if (macro->variadic)
+ {
+ supported = 0;
+ break;
+ }
+ }
+ *buf_param++ = ')';
+ *buf_param = '\0';
+ }
+
+ for (i = 0; supported && i < macro->count; i++)
+ {
+ cpp_token *token = ¯o->exp.tokens[i];
+ int is_one = 0;
+
+ if (token->flags & PREV_WHITE)
+ *buffer++ = ' ';
+
+ if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT)
+ {
+ supported = 0;
+ break;
+ }
+
+ switch (token->type)
+ {
+ case CPP_MACRO_ARG:
+ {
+ cpp_hashnode *param =
+ macro->params[token->val.macro_arg.arg_no - 1];
+ memcpy (buffer, NODE_NAME (param), NODE_LEN (param));
+ buffer += NODE_LEN (param);
+ }
+ break;
+
+ case CPP_EQ_EQ: *buffer++ = '='; break;
+ case CPP_GREATER: *buffer++ = '>'; break;
+ case CPP_LESS: *buffer++ = '<'; break;
+ case CPP_PLUS: *buffer++ = '+'; break;
+ case CPP_MINUS: *buffer++ = '-'; break;
+ case CPP_MULT: *buffer++ = '*'; break;
+ case CPP_DIV: *buffer++ = '/'; break;
+ case CPP_COMMA: *buffer++ = ','; break;
+ case CPP_OPEN_SQUARE:
+ case CPP_OPEN_PAREN: *buffer++ = '('; break;
+ case CPP_CLOSE_SQUARE: /* fallthrough */
+ case CPP_CLOSE_PAREN: *buffer++ = ')'; break;
+ case CPP_DEREF: /* fallthrough */
+ case CPP_SCOPE: /* fallthrough */
+ case CPP_DOT: *buffer++ = '.'; break;
+
+ case CPP_EQ: *buffer++ = ':'; *buffer++ = '='; break;
+ case CPP_NOT_EQ: *buffer++ = '/'; *buffer++ = '='; break;
+ case CPP_GREATER_EQ: *buffer++ = '>'; *buffer++ = '='; break;
+ case CPP_LESS_EQ: *buffer++ = '<'; *buffer++ = '='; break;
+
+ case CPP_NOT:
+ *buffer++ = 'n'; *buffer++ = 'o'; *buffer++ = 't'; break;
+ case CPP_MOD:
+ *buffer++ = 'm'; *buffer++ = 'o'; *buffer++ = 'd'; break;
+ case CPP_AND:
+ *buffer++ = 'a'; *buffer++ = 'n'; *buffer++ = 'd'; break;
+ case CPP_OR:
+ *buffer++ = 'o'; *buffer++ = 'r'; break;
+ case CPP_XOR:
+ *buffer++ = 'x'; *buffer++ = 'o'; *buffer++ = 'r'; break;
+ case CPP_AND_AND:
+ strcpy ((char *) buffer, " and then ");
+ buffer += 10;
+ break;
+ case CPP_OR_OR:
+ strcpy ((char *) buffer, " or else ");
+ buffer += 9;
+ break;
+
+ case CPP_PADDING:
+ *buffer++ = ' ';
+ is_one = prev_is_one;
+ break;
+
+ case CPP_COMMENT: break;
+
+ case CPP_WSTRING:
+ case CPP_STRING16:
+ case CPP_STRING32:
+ case CPP_UTF8STRING:
+ case CPP_WCHAR:
+ case CPP_CHAR16:
+ case CPP_CHAR32:
+ case CPP_NAME:
+ case CPP_STRING:
+ case CPP_NUMBER:
+ if (!macro->fun_like)
+ supported = 0;
+ else
+ buffer = cpp_spell_token (parse_in, token, buffer, false);
+ break;
+
+ case CPP_CHAR:
+ is_char = 1;
+ {
+ unsigned chars_seen;
+ int ignored;
+ cppchar_t c;
+
+ c = cpp_interpret_charconst (parse_in, token,
+ &chars_seen, &ignored);
+ if (c >= 32 && c <= 126)
+ {
+ *buffer++ = '\'';
+ *buffer++ = (char) c;
+ *buffer++ = '\'';
+ }
+ else
+ {
+ chars_seen = sprintf
+ ((char *) buffer, "Character'Val (%d)", (int) c);
+ buffer += chars_seen;
+ }
+ }
+ break;
+
+ case CPP_LSHIFT:
+ if (prev_is_one)
+ {
+ /* Replace "1 << N" by "2 ** N" */
+ *char_one = '2';
+ *buffer++ = '*';
+ *buffer++ = '*';
+ break;
+ }
+ /* fallthrough */
+
+ case CPP_RSHIFT:
+ case CPP_COMPL:
+ case CPP_QUERY:
+ case CPP_EOF:
+ case CPP_PLUS_EQ:
+ case CPP_MINUS_EQ:
+ case CPP_MULT_EQ:
+ case CPP_DIV_EQ:
+ case CPP_MOD_EQ:
+ case CPP_AND_EQ:
+ case CPP_OR_EQ:
+ case CPP_XOR_EQ:
+ case CPP_RSHIFT_EQ:
+ case CPP_LSHIFT_EQ:
+ case CPP_PRAGMA:
+ case CPP_PRAGMA_EOL:
+ case CPP_HASH:
+ case CPP_PASTE:
+ case CPP_OPEN_BRACE:
+ case CPP_CLOSE_BRACE:
+ case CPP_SEMICOLON:
+ case CPP_ELLIPSIS:
+ case CPP_PLUS_PLUS:
+ case CPP_MINUS_MINUS:
+ case CPP_DEREF_STAR:
+ case CPP_DOT_STAR:
+ case CPP_ATSIGN:
+ case CPP_HEADER_NAME:
+ case CPP_AT_NAME:
+ case CPP_OTHER:
+ case CPP_OBJC_STRING:
+ default:
+ if (!macro->fun_like)
+ supported = 0;
+ else
+ buffer = cpp_spell_token (parse_in, token, buffer, false);
+ break;
+ }
+
+ prev_is_one = is_one;
+ }
+
+ if (supported)
+ *buffer = '\0';
+ }
+
+ if (macro->fun_like && supported)
+ {
+ char *start = (char *) s;
+ int is_function = 0;
+
+ pp_string (pp, " -- arg-macro: ");
+
+ if (*start == '(' && buffer [-1] == ')')
+ {
+ start++;
+ buffer [-1] = '\0';
+ is_function = 1;
+ pp_string (pp, "function ");
+ }
+ else
+ {
+ pp_string (pp, "procedure ");
+ }
+
+ pp_string (pp, (const char *) NODE_NAME (node));
+ pp_space (pp);
+ pp_string (pp, (char *) params);
+ pp_newline (pp);
+ pp_string (pp, " -- ");
+
+ if (is_function)
+ {
+ pp_string (pp, "return ");
+ pp_string (pp, start);
+ pp_semicolon (pp);
+ }
+ else
+ pp_string (pp, start);
+
+ pp_newline (pp);
+ }
+ else if (supported)
+ {
+ expanded_location sloc = expand_location (macro->line);
+
+ if (sloc.line != prev_line + 1)
+ pp_newline (pp);
+
+ num_macros++;
+ prev_line = sloc.line;
+
+ pp_string (pp, " ");
+ ada_name = to_ada_name ((const char *) NODE_NAME (node), NULL);
+ pp_string (pp, ada_name);
+ free (ada_name);
+ pp_string (pp, " : ");
+
+ if (is_string)
+ pp_string (pp, "aliased constant String");
+ else if (is_char)
+ pp_string (pp, "aliased constant Character");
+ else
+ pp_string (pp, "constant");
+
+ pp_string (pp, " := ");
+ pp_string (pp, (char *) s);
+
+ if (is_string)
+ pp_string (pp, " & ASCII.NUL");
+
+ pp_string (pp, "; -- ");
+ pp_string (pp, sloc.file);
+ pp_character (pp, ':');
+ pp_scalar (pp, "%d", sloc.line);
+ pp_newline (pp);
+ }
+ else
+ {
+ pp_string (pp, " -- unsupported macro: ");
+ pp_string (pp, (const char *) cpp_macro_definition (parse_in, node));
+ pp_newline (pp);
+ }
+ }
+
+ if (num_macros > 0)
+ pp_newline (pp);
+}
+
+static const char *source_file;
+static int max_ada_macros;
+
+/* Callback used to count the number of relevant macros from
+ cpp_forall_identifiers. PFILE and V are not used. NODE is the current macro
+ to consider. */
+
+static int
+count_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *node,
+ void *v ATTRIBUTE_UNUSED)
+{
+ const cpp_macro *macro = node->value.macro;
+
+ if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)
+ && macro->count
+ && *NODE_NAME (node) != '_'
+ && LOCATION_FILE (macro->line) == source_file)
+ max_ada_macros++;
+
+ return 1;
+}
+
+static int store_ada_macro_index;
+
+/* Callback used to store relevant macros from cpp_forall_identifiers.
+ PFILE is not used. NODE is the current macro to store if relevant.
+ MACROS is an array of cpp_hashnode* used to store NODE. */
+
+static int
+store_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED,
+ cpp_hashnode *node, void *macros)
+{
+ const cpp_macro *macro = node->value.macro;
+
+ if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)
+ && macro->count
+ && *NODE_NAME (node) != '_'
+ && LOCATION_FILE (macro->line) == source_file)
+ ((cpp_hashnode **) macros)[store_ada_macro_index++] = node;
+
+ return 1;
+}
+
+/* Callback used to compare (during qsort) macros. NODE1 and NODE2 are the
+ two macro nodes to compare. */
+
+static int
+compare_macro (const void *node1, const void *node2)
+{
+ typedef const cpp_hashnode *const_hnode;
+
+ const_hnode n1 = *(const const_hnode *) node1;
+ const_hnode n2 = *(const const_hnode *) node2;
+
+ return n1->value.macro->line - n2->value.macro->line;
+}
+
+/* Dump in PP all relevant macros appearing in FILE. */
+
+static void
+dump_ada_macros (pretty_printer *pp, const char* file)
+{
+ cpp_hashnode **macros;
+
+ /* Initialize file-scope variables. */
+ max_ada_macros = 0;
+ store_ada_macro_index = 0;
+ source_file = file;
+
+ /* Count all potentially relevant macros, and then sort them by sloc. */
+ cpp_forall_identifiers (parse_in, count_ada_macro, NULL);
+ macros = XALLOCAVEC (cpp_hashnode *, max_ada_macros);
+ cpp_forall_identifiers (parse_in, store_ada_macro, macros);
+ qsort (macros, max_ada_macros, sizeof (cpp_hashnode *), compare_macro);
+
+ print_ada_macros (pp, macros, max_ada_macros);
+}
+
+/* Current source file being handled. */
+
+static const char *source_file_base;
+
+/* Compare the declaration (DECL) of struct-like types based on the sloc of
+ their last field (if LAST is true), so that more nested types collate before
+ less nested ones.
+ If ORIG_TYPE is true, also consider struct with a DECL_ORIGINAL_TYPE. */
+
+static location_t
+decl_sloc_common (const_tree decl, bool last, bool orig_type)
+{
+ tree type = TREE_TYPE (decl);
+
+ if (TREE_CODE (decl) == TYPE_DECL
+ && (orig_type || !DECL_ORIGINAL_TYPE (decl))
+ && RECORD_OR_UNION_TYPE_P (type)
+ && TYPE_FIELDS (type))
+ {
+ tree f = TYPE_FIELDS (type);
+
+ if (last)
+ while (TREE_CHAIN (f))
+ f = TREE_CHAIN (f);
+
+ return DECL_SOURCE_LOCATION (f);
+ }
+ else
+ return DECL_SOURCE_LOCATION (decl);
+}
+
+/* Return sloc of DECL, using sloc of last field if LAST is true. */
+
+location_t
+decl_sloc (const_tree decl, bool last)
+{
+ return decl_sloc_common (decl, last, false);
+}
+
+/* Compare two declarations (LP and RP) by their source location. */
+
+static int
+compare_node (const void *lp, const void *rp)
+{
+ const_tree lhs = *((const tree *) lp);
+ const_tree rhs = *((const tree *) rp);
+
+ return decl_sloc (lhs, true) - decl_sloc (rhs, true);
+}
+
+/* Compare two comments (LP and RP) by their source location. */
+
+static int
+compare_comment (const void *lp, const void *rp)
+{
+ const cpp_comment *lhs = (const cpp_comment *) lp;
+ const cpp_comment *rhs = (const cpp_comment *) rp;
+
+ if (LOCATION_FILE (lhs->sloc) != LOCATION_FILE (rhs->sloc))
+ return strcmp (LOCATION_FILE (lhs->sloc), LOCATION_FILE (rhs->sloc));
+
+ if (LOCATION_LINE (lhs->sloc) != LOCATION_LINE (rhs->sloc))
+ return LOCATION_LINE (lhs->sloc) - LOCATION_LINE (rhs->sloc);
+
+ if (LOCATION_COL (lhs->sloc) != LOCATION_COL (rhs->sloc))
+ return LOCATION_COL (lhs->sloc) - LOCATION_COL (rhs->sloc);
+
+ return 0;
+}
+
+static tree *to_dump = NULL;
+static int to_dump_count = 0;
+
+/* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped
+ by a subsequent call to dump_ada_nodes. */
+
+void
+collect_ada_nodes (tree t, const char *source_file)
+{
+ tree n;
+ int i = to_dump_count;
+
+ /* Count the likely relevant nodes. */
+ for (n = t; n; n = TREE_CHAIN (n))
+ if (!DECL_IS_BUILTIN (n)
+ && LOCATION_FILE (decl_sloc (n, false)) == source_file)
+ to_dump_count++;
+
+ /* Allocate sufficient storage for all nodes. */
+ to_dump = XRESIZEVEC (tree, to_dump, to_dump_count);
+
+ /* Store the relevant nodes. */
+ for (n = t; n; n = TREE_CHAIN (n))
+ if (!DECL_IS_BUILTIN (n)
+ && LOCATION_FILE (decl_sloc (n, false)) == source_file)
+ to_dump [i++] = n;
+}
+
+/* Call back for walk_tree to clear the TREE_VISITED flag of TP. */
+
+static tree
+unmark_visited_r (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ if (TREE_VISITED (*tp))
+ TREE_VISITED (*tp) = 0;
+ else
+ *walk_subtrees = 0;
+
+ return NULL_TREE;
+}
+
+/* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls
+ to collect_ada_nodes. CPP_CHECK is used to perform C++ queries on nodes. */
+
+static void
+dump_ada_nodes (pretty_printer *pp, const char *source_file,
+ int (*cpp_check)(tree, cpp_operation))
+{
+ int i, j;
+ cpp_comment_table *comments;
+
+ /* Sort the table of declarations to dump by sloc. */
+ qsort (to_dump, to_dump_count, sizeof (tree), compare_node);
+
+ /* Fetch the table of comments. */
+ comments = cpp_get_comments (parse_in);
+
+ /* Sort the comments table by sloc. */
+ qsort (comments->entries, comments->count, sizeof (cpp_comment),
+ compare_comment);
+
+ /* Interleave comments and declarations in line number order. */
+ i = j = 0;
+ do
+ {
+ /* Advance j until comment j is in this file. */
+ while (j != comments->count
+ && LOCATION_FILE (comments->entries[j].sloc) != source_file)
+ j++;
+
+ /* Advance j until comment j is not a duplicate. */
+ while (j < comments->count - 1
+ && !compare_comment (&comments->entries[j],
+ &comments->entries[j + 1]))
+ j++;
+
+ /* Write decls until decl i collates after comment j. */
+ while (i != to_dump_count)
+ {
+ if (j == comments->count
+ || LOCATION_LINE (decl_sloc (to_dump[i], false))
+ < LOCATION_LINE (comments->entries[j].sloc))
+ print_generic_ada_decl (pp, to_dump[i++], cpp_check, source_file);
+ else
+ break;
+ }
+
+ /* Write comment j, if there is one. */
+ if (j != comments->count)
+ print_comment (pp, comments->entries[j++].comment);
+
+ } while (i != to_dump_count || j != comments->count);
+
+ /* Clear the TREE_VISITED flag over each subtree we've dumped. */
+ for (i = 0; i < to_dump_count; i++)
+ walk_tree (&to_dump[i], unmark_visited_r, NULL, NULL);
+
+ /* Finalize the to_dump table. */
+ if (to_dump)
+ {
+ free (to_dump);
+ to_dump = NULL;
+ to_dump_count = 0;
+ }
+}
+
+/* Print a COMMENT to the output stream PP. */
+
+static void
+print_comment (pretty_printer *pp, const char *comment)
+{
+ int len = strlen (comment);
+ char *str = XALLOCAVEC (char, len + 1);
+ char *tok;
+ bool extra_newline = false;
+
+ memcpy (str, comment, len + 1);
+
+ /* Trim C/C++ comment indicators. */
+ if (str[len - 2] == '*' && str[len - 1] == '/')
+ {
+ str[len - 2] = ' ';
+ str[len - 1] = '\0';
+ }
+ str += 2;
+
+ tok = strtok (str, "\n");
+ while (tok) {
+ pp_string (pp, " --");
+ pp_string (pp, tok);
+ pp_newline (pp);
+ tok = strtok (NULL, "\n");
+
+ /* Leave a blank line after multi-line comments. */
+ if (tok)
+ extra_newline = true;
+ }
+
+ if (extra_newline)
+ pp_newline (pp);
+}
+
+/* Prints declaration DECL to PP in Ada syntax. The current source file being
+ handled is SOURCE_FILE, and CPP_CHECK is used to perform C++ queries on
+ nodes. */
+
+static void
+print_generic_ada_decl (pretty_printer *pp, tree decl,
+ int (*cpp_check)(tree, cpp_operation),
+ const char* source_file)
+{
+ source_file_base = source_file;
+
+ if (print_ada_declaration (pp, decl, 0, cpp_check, INDENT_INCR))
+ {
+ pp_newline (pp);
+ pp_newline (pp);
+ }
+}
+
+/* Dump a newline and indent BUFFER by SPC chars. */
+
+static void
+newline_and_indent (pretty_printer *buffer, int spc)
+{
+ pp_newline (buffer);
+ INDENT (spc);
+}
+
+struct with { char *s; const char *in_file; int limited; };
+static struct with *withs = NULL;
+static int withs_max = 4096;
+static int with_len = 0;
+
+/* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is
+ true), if not already done. */
+
+static void
+append_withs (const char *s, int limited_access)
+{
+ int i;
+
+ if (withs == NULL)
+ withs = XNEWVEC (struct with, withs_max);
+
+ if (with_len == withs_max)
+ {
+ withs_max *= 2;
+ withs = XRESIZEVEC (struct with, withs, withs_max);
+ }
+
+ for (i = 0; i < with_len; i++)
+ if (!strcmp (s, withs [i].s)
+ && source_file_base == withs [i].in_file)
+ {
+ withs [i].limited &= limited_access;
+ return;
+ }
+
+ withs [with_len].s = xstrdup (s);
+ withs [with_len].in_file = source_file_base;
+ withs [with_len].limited = limited_access;
+ with_len++;
+}
+
+/* Reset "with" clauses. */
+
+static void
+reset_ada_withs (void)
+{
+ int i;
+
+ if (!withs)
+ return;
+
+ for (i = 0; i < with_len; i++)
+ free (withs [i].s);
+ free (withs);
+ withs = NULL;
+ withs_max = 4096;
+ with_len = 0;
+}
+
+/* Dump "with" clauses in F. */
+
+static void
+dump_ada_withs (FILE *f)
+{
+ int i;
+
+ fprintf (f, "with Interfaces.C; use Interfaces.C;\n");
+
+ for (i = 0; i < with_len; i++)
+ fprintf
+ (f, "%swith %s;\n", withs [i].limited ? "limited " : "", withs [i].s);
+}
+
+/* Return suitable Ada package name from FILE. */
+
+static char *
+get_ada_package (const char *file)
+{
+ const char *base;
+ char *res;
+ const char *s;
+ int i;
+
+ s = strstr (file, "/include/");
+ if (s)
+ base = s + 9;
+ else
+ base = lbasename (file);
+ res = XNEWVEC (char, strlen (base) + 1);
+
+ for (i = 0; *base; base++, i++)
+ switch (*base)
+ {
+ case '+':
+ res [i] = 'p';
+ break;
+
+ case '.':
+ case '-':
+ case '_':
+ case '/':
+ case '\\':
+ res [i] = (i == 0 || res [i - 1] == '_') ? 'u' : '_';
+ break;
+
+ default:
+ res [i] = *base;
+ break;
+ }
+ res [i] = '\0';
+
+ return res;
+}
+
+static const char *ada_reserved[] = {
+ "abort", "abs", "abstract", "accept", "access", "aliased", "all", "and",
+ "array", "at", "begin", "body", "case", "constant", "declare", "delay",
+ "delta", "digits", "do", "else", "elsif", "end", "entry", "exception",
+ "exit", "for", "function", "generic", "goto", "if", "in", "interface", "is",
+ "limited", "loop", "mod", "new", "not", "null", "others", "out", "of", "or",
+ "overriding", "package", "pragma", "private", "procedure", "protected",
+ "raise", "range", "record", "rem", "renames", "requeue", "return", "reverse",
+ "select", "separate", "subtype", "synchronized", "tagged", "task",
+ "terminate", "then", "type", "until", "use", "when", "while", "with", "xor",
+ NULL};
+
+/* ??? would be nice to specify this list via a config file, so that users
+ can create their own dictionary of conflicts. */
+static const char *c_duplicates[] = {
+ /* system will cause troubles with System.Address. */
+ "system",
+
+ /* The following values have other definitions with same name/other
+ casing. */
+ "funmap",
+ "rl_vi_fWord",
+ "rl_vi_bWord",
+ "rl_vi_eWord",
+ "rl_readline_version",
+ "_Vx_ushort",
+ "USHORT",
+ "XLookupKeysym",
+ NULL};
+
+/* Return a declaration tree corresponding to TYPE. */
+
+static tree
+get_underlying_decl (tree type)
+{
+ tree decl = NULL_TREE;
+
+ if (type == NULL_TREE)
+ return NULL_TREE;
+
+ /* type is a declaration. */
+ if (DECL_P (type))
+ decl = type;
+
+ /* type is a typedef. */
+ if (TYPE_P (type) && TYPE_NAME (type) && DECL_P (TYPE_NAME (type)))
+ decl = TYPE_NAME (type);
+
+ /* TYPE_STUB_DECL has been set for type. */
+ if (TYPE_P (type) && TYPE_STUB_DECL (type) &&
+ DECL_P (TYPE_STUB_DECL (type)))
+ decl = TYPE_STUB_DECL (type);
+
+ return decl;
+}
+
+/* Return whether TYPE has static fields. */
+
+static int
+has_static_fields (const_tree type)
+{
+ tree tmp;
+
+ for (tmp = TYPE_FIELDS (type); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (DECL_NAME (tmp) && TREE_STATIC (tmp))
+ return true;
+ }
+ return false;
+}
+
+/* Return whether TYPE corresponds to an Ada tagged type (has a dispatch
+ table). */
+
+static int
+is_tagged_type (const_tree type)
+{
+ tree tmp;
+
+ if (!type || !RECORD_OR_UNION_TYPE_P (type))
+ return false;
+
+ for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp))
+ if (DECL_VINDEX (tmp))
+ return true;
+
+ return false;
+}
+
+/* Generate a legal Ada name from a C NAME, returning a malloc'd string.
+ SPACE_FOUND, if not NULL, is used to indicate whether a space was found in
+ NAME. */
+
+static char *
+to_ada_name (const char *name, int *space_found)
+{
+ const char **names;
+ int len = strlen (name);
+ int j, len2 = 0;
+ int found = false;
+ char *s = XNEWVEC (char, len * 2 + 5);
+ char c;
+
+ if (space_found)
+ *space_found = false;
+
+ /* Add trailing "c_" if name is an Ada reserved word. */
+ for (names = ada_reserved; *names; names++)
+ if (!strcasecmp (name, *names))
+ {
+ s [len2++] = 'c';
+ s [len2++] = '_';
+ found = true;
+ break;
+ }
+
+ if (!found)
+ /* Add trailing "c_" if name is an potential case sensitive duplicate. */
+ for (names = c_duplicates; *names; names++)
+ if (!strcmp (name, *names))
+ {
+ s [len2++] = 'c';
+ s [len2++] = '_';
+ found = true;
+ break;
+ }
+
+ for (j = 0; name [j] == '_'; j++)
+ s [len2++] = 'u';
+
+ if (j > 0)
+ s [len2++] = '_';
+ else if (*name == '.' || *name == '$')
+ {
+ s [0] = 'a';
+ s [1] = 'n';
+ s [2] = 'o';
+ s [3] = 'n';
+ len2 = 4;
+ j++;
+ }
+
+ /* Replace unsuitable characters for Ada identifiers. */
+
+ for (; j < len; j++)
+ switch (name [j])
+ {
+ case ' ':
+ if (space_found)
+ *space_found = true;
+ s [len2++] = '_';
+ break;
+
+ /* ??? missing some C++ operators. */
+ case '=':
+ s [len2++] = '_';
+
+ if (name [j + 1] == '=')
+ {
+ j++;
+ s [len2++] = 'e';
+ s [len2++] = 'q';
+ }
+ else
+ {
+ s [len2++] = 'a';
+ s [len2++] = 's';
+ }
+ break;
+
+ case '!':
+ s [len2++] = '_';
+ if (name [j + 1] == '=')
+ {
+ j++;
+ s [len2++] = 'n';
+ s [len2++] = 'e';
+ }
+ break;
+
+ case '~':
+ s [len2++] = '_';
+ s [len2++] = 't';
+ s [len2++] = 'i';
+ break;
+
+ case '&':
+ case '|':
+ case '^':
+ s [len2++] = '_';
+ s [len2++] = name [j] == '&' ? 'a' : name [j] == '|' ? 'o' : 'x';
+
+ if (name [j + 1] == '=')
+ {
+ j++;
+ s [len2++] = 'e';
+ }
+ break;
+
+ case '+':
+ case '-':
+ case '*':
+ case '/':
+ case '(':
+ case '[':
+ if (s [len2 - 1] != '_')
+ s [len2++] = '_';
+
+ switch (name [j + 1]) {
+ case '\0':
+ j++;
+ switch (name [j - 1]) {
+ case '+': s [len2++] = 'p'; break; /* + */
+ case '-': s [len2++] = 'm'; break; /* - */
+ case '*': s [len2++] = 't'; break; /* * */
+ case '/': s [len2++] = 'd'; break; /* / */
+ }
+ break;
+
+ case '=':
+ j++;
+ switch (name [j - 1]) {
+ case '+': s [len2++] = 'p'; break; /* += */
+ case '-': s [len2++] = 'm'; break; /* -= */
+ case '*': s [len2++] = 't'; break; /* *= */
+ case '/': s [len2++] = 'd'; break; /* /= */
+ }
+ s [len2++] = 'a';
+ break;
+
+ case '-': /* -- */
+ j++;
+ s [len2++] = 'm';
+ s [len2++] = 'm';
+ break;
+
+ case '+': /* ++ */
+ j++;
+ s [len2++] = 'p';
+ s [len2++] = 'p';
+ break;
+
+ case ')': /* () */
+ j++;
+ s [len2++] = 'o';
+ s [len2++] = 'p';
+ break;
+
+ case ']': /* [] */
+ j++;
+ s [len2++] = 'o';
+ s [len2++] = 'b';
+ break;
+ }
+
+ break;
+
+ case '<':
+ case '>':
+ c = name [j] == '<' ? 'l' : 'g';
+ s [len2++] = '_';
+
+ switch (name [j + 1]) {
+ case '\0':
+ s [len2++] = c;
+ s [len2++] = 't';
+ break;
+ case '=':
+ j++;
+ s [len2++] = c;
+ s [len2++] = 'e';
+ break;
+ case '>':
+ j++;
+ s [len2++] = 's';
+ s [len2++] = 'r';
+ break;
+ case '<':
+ j++;
+ s [len2++] = 's';
+ s [len2++] = 'l';
+ break;
+ default:
+ break;
+ }
+ break;
+
+ case '_':
+ if (len2 && s [len2 - 1] == '_')
+ s [len2++] = 'u';
+ /* fall through */
+
+ default:
+ s [len2++] = name [j];
+ }
+
+ if (s [len2 - 1] == '_')
+ s [len2++] = 'u';
+
+ s [len2] = '\0';
+
+ return s;
+}
+
+static bool package_prefix = true;
+
+/* Dump in BUFFER the name of an identifier NODE of type TYPE, following Ada
+ syntax. LIMITED_ACCESS indicates whether NODE can be accessed via a limited
+ 'with' clause rather than a regular 'with' clause. */
+
+static void
+pp_ada_tree_identifier (pretty_printer *buffer, tree node, tree type,
+ int limited_access)
+{
+ const char *name = IDENTIFIER_POINTER (node);
+ int space_found = false;
+ char *s = to_ada_name (name, &space_found);
+ tree decl;
+
+ /* If the entity is a type and comes from another file, generate "package"
+ prefix. */
+
+ decl = get_underlying_decl (type);
+
+ if (decl)
+ {
+ expanded_location xloc = expand_location (decl_sloc (decl, false));
+
+ if (xloc.file && xloc.line)
+ {
+ if (xloc.file != source_file_base)
+ {
+ switch (TREE_CODE (type))
+ {
+ case ENUMERAL_TYPE:
+ case INTEGER_TYPE:
+ case REAL_TYPE:
+ case FIXED_POINT_TYPE:
+ case BOOLEAN_TYPE:
+ case REFERENCE_TYPE:
+ case POINTER_TYPE:
+ case ARRAY_TYPE:
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ case QUAL_UNION_TYPE:
+ case TYPE_DECL:
+ {
+ char *s1 = get_ada_package (xloc.file);
+
+ if (package_prefix)
+ {
+ append_withs (s1, limited_access);
+ pp_string (buffer, s1);
+ pp_character (buffer, '.');
+ }
+ free (s1);
+ }
+ break;
+ default:
+ break;
+ }
+ }
+ }
+ }
+
+ if (space_found)
+ if (!strcmp (s, "short_int"))
+ pp_string (buffer, "short");
+ else if (!strcmp (s, "short_unsigned_int"))
+ pp_string (buffer, "unsigned_short");
+ else if (!strcmp (s, "unsigned_int"))
+ pp_string (buffer, "unsigned");
+ else if (!strcmp (s, "long_int"))
+ pp_string (buffer, "long");
+ else if (!strcmp (s, "long_unsigned_int"))
+ pp_string (buffer, "unsigned_long");
+ else if (!strcmp (s, "long_long_int"))
+ pp_string (buffer, "Long_Long_Integer");
+ else if (!strcmp (s, "long_long_unsigned_int"))
+ {
+ if (package_prefix)
+ {
+ append_withs ("Interfaces.C.Extensions", false);
+ pp_string (buffer, "Extensions.unsigned_long_long");
+ }
+ else
+ pp_string (buffer, "unsigned_long_long");
+ }
+ else
+ pp_string(buffer, s);
+ else
+ if (!strcmp (s, "bool"))
+ {
+ if (package_prefix)
+ {
+ append_withs ("Interfaces.C.Extensions", false);
+ pp_string (buffer, "Extensions.bool");
+ }
+ else
+ pp_string (buffer, "bool");
+ }
+ else
+ pp_string(buffer, s);
+
+ free (s);
+}
+
+/* Dump in BUFFER the assembly name of T. */
+
+static void
+pp_asm_name (pretty_printer *buffer, tree t)
+{
+ tree name = DECL_ASSEMBLER_NAME (t);
+ char *ada_name = XALLOCAVEC (char, IDENTIFIER_LENGTH (name) + 1), *s;
+ const char *ident = IDENTIFIER_POINTER (name);
+
+ for (s = ada_name; *ident; ident++)
+ {
+ if (*ident == ' ')
+ break;
+ else if (*ident != '*')
+ *s++ = *ident;
+ }
+
+ *s = '\0';
+ pp_string (buffer, ada_name);
+}
+
+/* Dump in BUFFER the name of a DECL node if set, following Ada syntax.
+ LIMITED_ACCESS indicates whether NODE can be accessed via a limited
+ 'with' clause rather than a regular 'with' clause. */
+
+static void
+dump_ada_decl_name (pretty_printer *buffer, tree decl, int limited_access)
+{
+ if (DECL_NAME (decl))
+ pp_ada_tree_identifier (buffer, DECL_NAME (decl), decl, limited_access);
+ else
+ {
+ tree type_name = TYPE_NAME (TREE_TYPE (decl));
+
+ if (!type_name)
+ {
+ pp_string (buffer, "anon");
+ if (TREE_CODE (decl) == FIELD_DECL)
+ pp_scalar (buffer, "%d", DECL_UID (decl));
+ else
+ pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (decl)));
+ }
+ else if (TREE_CODE (type_name) == IDENTIFIER_NODE)
+ pp_ada_tree_identifier (buffer, type_name, decl, limited_access);
+ }
+}
+
+/* Dump in BUFFER a name based on both T1 and T2, followed by S. */
+
+static void
+dump_ada_double_name (pretty_printer *buffer, tree t1, tree t2, const char *s)
+{
+ if (DECL_NAME (t1))
+ pp_ada_tree_identifier (buffer, DECL_NAME (t1), t1, false);
+ else
+ {
+ pp_string (buffer, "anon");
+ pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t1)));
+ }
+
+ pp_character (buffer, '_');
+
+ if (DECL_NAME (t1))
+ pp_ada_tree_identifier (buffer, DECL_NAME (t2), t2, false);
+ else
+ {
+ pp_string (buffer, "anon");
+ pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t2)));
+ }
+
+ pp_string (buffer, s);
+}
+
+/* Dump in BUFFER pragma Import C/CPP on a given node T. */
+
+static void
+dump_ada_import (pretty_printer *buffer, tree t)
+{
+ const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (t));
+ int is_stdcall = TREE_CODE (t) == FUNCTION_DECL &&
+ lookup_attribute ("stdcall", TYPE_ATTRIBUTES (TREE_TYPE (t)));
+
+ if (is_stdcall)
+ pp_string (buffer, "pragma Import (Stdcall, ");
+ else if (name [0] == '_' && name [1] == 'Z')
+ pp_string (buffer, "pragma Import (CPP, ");
+ else
+ pp_string (buffer, "pragma Import (C, ");
+
+ dump_ada_decl_name (buffer, t, false);
+ pp_string (buffer, ", \"");
+
+ if (is_stdcall)
+ pp_string (buffer, IDENTIFIER_POINTER (DECL_NAME (t)));
+ else
+ pp_asm_name (buffer, t);
+
+ pp_string (buffer, "\");");
+}
+
+/* Check whether T and its type have different names, and append "the_"
+ otherwise in BUFFER. */
+
+static void
+check_name (pretty_printer *buffer, tree t)
+{
+ const char *s;
+ tree tmp = TREE_TYPE (t);
+
+ while (TREE_CODE (tmp) == POINTER_TYPE && !TYPE_NAME (tmp))
+ tmp = TREE_TYPE (tmp);
+
+ if (TREE_CODE (tmp) != FUNCTION_TYPE)
+ {
+ if (TREE_CODE (tmp) == IDENTIFIER_NODE)
+ s = IDENTIFIER_POINTER (tmp);
+ else if (!TYPE_NAME (tmp))
+ s = "";
+ else if (TREE_CODE (TYPE_NAME (tmp)) == IDENTIFIER_NODE)
+ s = IDENTIFIER_POINTER (TYPE_NAME (tmp));
+ else
+ s = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp)));
+
+ if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t)), s))
+ pp_string (buffer, "the_");
+ }
+}
+
+/* Dump in BUFFER a function declaration FUNC with Ada syntax.
+ IS_METHOD indicates whether FUNC is a C++ method.
+ IS_CONSTRUCTOR whether FUNC is a C++ constructor.
+ IS_DESTRUCTOR whether FUNC is a C++ destructor.
+ SPC is the current indentation level. */
+
+static int
+dump_ada_function_declaration (pretty_printer *buffer, tree func,
+ int is_method, int is_constructor,
+ int is_destructor, int spc)
+{
+ tree arg;
+ const tree node = TREE_TYPE (func);
+ char buf [16];
+ int num = 0, num_args = 0, have_args = true, have_ellipsis = false;
+
+ /* Compute number of arguments. */
+ arg = TYPE_ARG_TYPES (node);
+
+ if (arg)
+ {
+ while (TREE_CHAIN (arg) && arg != error_mark_node)
+ {
+ num_args++;
+ arg = TREE_CHAIN (arg);
+ }
+
+ if (TREE_CODE (TREE_VALUE (arg)) != VOID_TYPE)
+ {
+ num_args++;
+ have_ellipsis = true;
+ }
+ }
+
+ if (is_constructor)
+ num_args--;
+
+ if (is_destructor)
+ num_args = 1;
+
+ if (num_args > 2)
+ newline_and_indent (buffer, spc + 1);
+
+ if (num_args > 0)
+ {
+ pp_space (buffer);
+ pp_character (buffer, '(');
+ }
+
+ if (TREE_CODE (func) == FUNCTION_DECL)
+ arg = DECL_ARGUMENTS (func);
+ else
+ arg = NULL_TREE;
+
+ if (arg == NULL_TREE)
+ {
+ have_args = false;
+ arg = TYPE_ARG_TYPES (node);
+
+ if (arg && TREE_CODE (TREE_VALUE (arg)) == VOID_TYPE)
+ arg = NULL_TREE;
+ }
+
+ if (is_constructor)
+ arg = TREE_CHAIN (arg);
+
+ /* Print the argument names (if available) & types. */
+
+ for (num = 1; num <= num_args; num++)
+ {
+ if (have_args)
+ {
+ if (DECL_NAME (arg))
+ {
+ check_name (buffer, arg);
+ pp_ada_tree_identifier (buffer, DECL_NAME (arg), 0, false);
+ pp_string (buffer, " : ");
+ }
+ else
+ {
+ sprintf (buf, "arg%d : ", num);
+ pp_string (buffer, buf);
+ }
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (arg), node, NULL, spc, 0, true);
+ }
+ else
+ {
+ sprintf (buf, "arg%d : ", num);
+ pp_string (buffer, buf);
+ dump_generic_ada_node
+ (buffer, TREE_VALUE (arg), node, NULL, spc, 0, true);
+ }
+
+ if (TREE_TYPE (arg) && TREE_TYPE (TREE_TYPE (arg))
+ && is_tagged_type (TREE_TYPE (TREE_TYPE (arg))))
+ {
+ if (!is_method
+ || (num != 1 || (!DECL_VINDEX (func) && !is_constructor)))
+ pp_string (buffer, "'Class");
+ }
+
+ arg = TREE_CHAIN (arg);
+
+ if (num < num_args)
+ {
+ pp_character (buffer, ';');
+
+ if (num_args > 2)
+ newline_and_indent (buffer, spc + INDENT_INCR);
+ else
+ pp_space (buffer);
+ }
+ }
+
+ if (have_ellipsis)
+ {
+ pp_string (buffer, " -- , ...");
+ newline_and_indent (buffer, spc + INDENT_INCR);
+ }
+
+ if (num_args > 0)
+ pp_character (buffer, ')');
+ return num_args;
+}
+
+/* Dump in BUFFER all the domains associated with an array NODE,
+ using Ada syntax. SPC is the current indentation level. */
+
+static void
+dump_ada_array_domains (pretty_printer *buffer, tree node, int spc)
+{
+ int first = 1;
+ pp_character (buffer, '(');
+
+ for (; TREE_CODE (node) == ARRAY_TYPE; node = TREE_TYPE (node))
+ {
+ tree domain = TYPE_DOMAIN (node);
+
+ if (domain)
+ {
+ tree min = TYPE_MIN_VALUE (domain);
+ tree max = TYPE_MAX_VALUE (domain);
+
+ if (!first)
+ pp_string (buffer, ", ");
+ first = 0;
+
+ if (min)
+ dump_generic_ada_node (buffer, min, NULL_TREE, NULL, spc, 0, true);
+ pp_string (buffer, " .. ");
+
+ /* If the upper bound is zero, gcc may generate a NULL_TREE
+ for TYPE_MAX_VALUE rather than an integer_cst. */
+ if (max)
+ dump_generic_ada_node (buffer, max, NULL_TREE, NULL, spc, 0, true);
+ else
+ pp_string (buffer, "0");
+ }
+ else
+ pp_string (buffer, "size_t");
+ }
+ pp_character (buffer, ')');
+}
+
+/* Dump in BUFFER file:line:col information related to NODE. */
+
+static void
+dump_sloc (pretty_printer *buffer, tree node)
+{
+ expanded_location xloc;
+
+ xloc.file = NULL;
+
+ if (TREE_CODE_CLASS (TREE_CODE (node)) == tcc_declaration)
+ xloc = expand_location (DECL_SOURCE_LOCATION (node));
+ else if (EXPR_HAS_LOCATION (node))
+ xloc = expand_location (EXPR_LOCATION (node));
+
+ if (xloc.file)
+ {
+ pp_string (buffer, xloc.file);
+ pp_string (buffer, ":");
+ pp_decimal_int (buffer, xloc.line);
+ pp_string (buffer, ":");
+ pp_decimal_int (buffer, xloc.column);
+ }
+}
+
+/* Return true if T designates a one dimension array of "char". */
+
+static bool
+is_char_array (tree t)
+{
+ tree tmp;
+ int num_dim = 0;
+
+ /* Retrieve array's type. */
+ tmp = t;
+ while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ {
+ num_dim++;
+ tmp = TREE_TYPE (tmp);
+ }
+
+ tmp = TREE_TYPE (tmp);
+ return num_dim == 1 && TREE_CODE (tmp) == INTEGER_TYPE
+ && !strcmp (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp))), "char");
+}
+
+/* Dump in BUFFER an array type T in Ada syntax. Assume that the "type"
+ keyword and name have already been printed. SPC is the indentation
+ level. */
+
+static void
+dump_ada_array_type (pretty_printer *buffer, tree t, int spc)
+{
+ tree tmp;
+ bool char_array = is_char_array (t);
+
+ /* Special case char arrays. */
+ if (char_array)
+ {
+ pp_string (buffer, "Interfaces.C.char_array ");
+ }
+ else
+ pp_string (buffer, "array ");
+
+ /* Print the dimensions. */
+ dump_ada_array_domains (buffer, TREE_TYPE (t), spc);
+
+ /* Retrieve array's type. */
+ tmp = TREE_TYPE (t);
+ while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ tmp = TREE_TYPE (tmp);
+
+ /* Print array's type. */
+ if (!char_array)
+ {
+ pp_string (buffer, " of ");
+
+ if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE)
+ pp_string (buffer, "aliased ");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (tmp), TREE_TYPE (t), NULL, spc, false, true);
+ }
+}
+
+/* Dump in BUFFER type names associated with a template, each prepended with
+ '_'. TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS.
+ CPP_CHECK is used to perform C++ queries on nodes.
+ SPC is the indentation level. */
+
+static void
+dump_template_types (pretty_printer *buffer, tree types,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ size_t i;
+ size_t len = TREE_VEC_LENGTH (types);
+
+ for (i = 0; i < len; i++)
+ {
+ tree elem = TREE_VEC_ELT (types, i);
+ pp_character (buffer, '_');
+ if (!dump_generic_ada_node (buffer, elem, 0, cpp_check, spc, false, true))
+ {
+ pp_string (buffer, "unknown");
+ pp_scalar (buffer, "%lu", (unsigned long) TREE_HASH (elem));
+ }
+ }
+}
+
+/* Dump in BUFFER the contents of all instantiations associated with a given
+ template T. CPP_CHECK is used to perform C++ queries on nodes.
+ SPC is the indentation level. */
+
+static int
+dump_ada_template (pretty_printer *buffer, tree t,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ tree inst = DECL_VINDEX (t);
+ /* DECL_VINDEX is DECL_TEMPLATE_INSTANTIATIONS in this context. */
+ int num_inst = 0;
+
+ while (inst && inst != error_mark_node)
+ {
+ tree types = TREE_PURPOSE (inst);
+ tree instance = TREE_VALUE (inst);
+
+ if (TREE_VEC_LENGTH (types) == 0)
+ break;
+
+ if (!TYPE_METHODS (instance))
+ break;
+
+ num_inst++;
+ INDENT (spc);
+ pp_string (buffer, "package ");
+ package_prefix = false;
+ dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true);
+ dump_template_types (buffer, types, cpp_check, spc);
+ pp_string (buffer, " is");
+ spc += INDENT_INCR;
+ newline_and_indent (buffer, spc);
+
+ pp_string (buffer, "type ");
+ dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true);
+ package_prefix = true;
+
+ if (is_tagged_type (instance))
+ pp_string (buffer, " is tagged limited ");
+ else
+ pp_string (buffer, " is limited ");
+
+ dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, false);
+ pp_newline (buffer);
+ spc -= INDENT_INCR;
+ newline_and_indent (buffer, spc);
+
+ pp_string (buffer, "end;");
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "use ");
+ package_prefix = false;
+ dump_generic_ada_node (buffer, instance, t, cpp_check, spc, false, true);
+ dump_template_types (buffer, types, cpp_check, spc);
+ package_prefix = true;
+ pp_semicolon (buffer);
+ pp_newline (buffer);
+ pp_newline (buffer);
+
+ inst = TREE_CHAIN (inst);
+ }
+
+ return num_inst > 0;
+}
+
+static bool in_function = true;
+static bool bitfield_used = false;
+
+/* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
+ TYPE. CPP_CHECK is used to perform C++ queries on nodes. SPC is the
+ indentation level. LIMITED_ACCESS indicates whether NODE can be referenced
+ via a "limited with" clause. NAME_ONLY indicates whether we should only
+ dump the name of NODE, instead of its full declaration. */
+
+static int
+dump_generic_ada_node (pretty_printer *buffer, tree node, tree type,
+ int (*cpp_check)(tree, cpp_operation), int spc,
+ int limited_access, bool name_only)
+{
+ if (node == NULL_TREE)
+ return 0;
+
+ switch (TREE_CODE (node))
+ {
+ case ERROR_MARK:
+ pp_string (buffer, "<<< error >>>");
+ return 0;
+
+ case IDENTIFIER_NODE:
+ pp_ada_tree_identifier (buffer, node, type, limited_access);
+ break;
+
+ case TREE_LIST:
+ pp_string (buffer, "--- unexpected node: TREE_LIST");
+ return 0;
+
+ case TREE_BINFO:
+ dump_generic_ada_node
+ (buffer, BINFO_TYPE (node), type, cpp_check,
+ spc, limited_access, name_only);
+
+ case TREE_VEC:
+ pp_string (buffer, "--- unexpected node: TREE_VEC");
+ return 0;
+
+ case VOID_TYPE:
+ if (package_prefix)
+ {
+ append_withs ("System", false);
+ pp_string (buffer, "System.Address");
+ }
+ else
+ pp_string (buffer, "address");
+ break;
+
+ case VECTOR_TYPE:
+ pp_string (buffer, "<vector>");
+ break;
+
+ case COMPLEX_TYPE:
+ pp_string (buffer, "<complex>");
+ break;
+
+ case ENUMERAL_TYPE:
+ if (name_only)
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (node), node, cpp_check, spc, 0, true);
+ else
+ {
+ tree value;
+
+ pp_string (buffer, "unsigned");
+
+ for (value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
+ {
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+
+ pp_ada_tree_identifier
+ (buffer, TREE_PURPOSE (value), node, false);
+ pp_string (buffer, " : constant ");
+
+ dump_generic_ada_node
+ (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
+ cpp_check, spc, 0, true);
+
+ pp_string (buffer, " := ");
+ dump_generic_ada_node
+ (buffer,
+ TREE_CODE (TREE_VALUE (value)) == INTEGER_CST ?
+ TREE_VALUE (value) : DECL_INITIAL (TREE_VALUE (value)),
+ node,
+ cpp_check, spc, false, true);
+ }
+ }
+ break;
+
+ case INTEGER_TYPE:
+ case REAL_TYPE:
+ case FIXED_POINT_TYPE:
+ case BOOLEAN_TYPE:
+ {
+ enum tree_code_class tclass;
+
+ tclass = TREE_CODE_CLASS (TREE_CODE (node));
+
+ if (tclass == tcc_declaration)
+ {
+ if (DECL_NAME (node))
+ pp_ada_tree_identifier
+ (buffer, DECL_NAME (node), 0, limited_access);
+ else
+ pp_string (buffer, "<unnamed type decl>");
+ }
+ else if (tclass == tcc_type)
+ {
+ if (TYPE_NAME (node))
+ {
+ if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE)
+ pp_ada_tree_identifier (buffer, TYPE_NAME (node),
+ node, limited_access);
+ else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (node)))
+ dump_ada_decl_name (buffer, TYPE_NAME (node), limited_access);
+ else
+ pp_string (buffer, "<unnamed type>");
+ }
+ else if (TREE_CODE (node) == INTEGER_TYPE)
+ {
+ append_withs ("Interfaces.C.Extensions", false);
+ bitfield_used = true;
+
+ if (TYPE_PRECISION (node) == 1)
+ pp_string (buffer, "Extensions.Unsigned_1");
+ else
+ {
+ pp_string (buffer, (TYPE_UNSIGNED (node)
+ ? "Extensions.Unsigned_"
+ : "Extensions.Signed_"));
+ pp_decimal_int (buffer, TYPE_PRECISION (node));
+ }
+ }
+ else
+ pp_string (buffer, "<unnamed type>");
+ }
+ break;
+ }
+
+ case POINTER_TYPE:
+ case REFERENCE_TYPE:
+ if (TREE_CODE (TREE_TYPE (node)) == FUNCTION_TYPE)
+ {
+ tree fnode = TREE_TYPE (node);
+ bool is_function;
+ bool prev_in_function = in_function;
+
+ if (VOID_TYPE_P (TREE_TYPE (fnode)))
+ {
+ is_function = false;
+ pp_string (buffer, "access procedure");
+ }
+ else
+ {
+ is_function = true;
+ pp_string (buffer, "access function");
+ }
+
+ in_function = is_function;
+ dump_ada_function_declaration
+ (buffer, node, false, false, false, spc + INDENT_INCR);
+ in_function = prev_in_function;
+
+ if (is_function)
+ {
+ pp_string (buffer, " return ");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (fnode), type, cpp_check, spc, 0, true);
+ }
+ }
+ else
+ {
+ int is_access = false;
+ unsigned int quals = TYPE_QUALS (TREE_TYPE (node));
+
+ if (name_only && TYPE_NAME (node))
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (node), node, cpp_check,
+ spc, limited_access, true);
+ else if (VOID_TYPE_P (TREE_TYPE (node)))
+ {
+ if (!name_only)
+ pp_string (buffer, "new ");
+ if (package_prefix)
+ {
+ append_withs ("System", false);
+ pp_string (buffer, "System.Address");
+ }
+ else
+ pp_string (buffer, "address");
+ }
+ else
+ {
+ if (TREE_CODE (node) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (node)) == INTEGER_TYPE
+ && !strcmp
+ (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME
+ (TREE_TYPE (node)))), "char"))
+ {
+ if (!name_only)
+ pp_string (buffer, "new ");
+
+ if (package_prefix)
+ {
+ pp_string (buffer, "Interfaces.C.Strings.chars_ptr");
+ append_withs ("Interfaces.C.Strings", false);
+ }
+ else
+ pp_string (buffer, "chars_ptr");
+ }
+ else
+ {
+ /* For now, handle all access-to-access or
+ access-to-unknown-structs as opaque system.address. */
+
+ tree typ = TYPE_NAME (TREE_TYPE (node));
+ const_tree typ2 = !type ||
+ DECL_P (type) ? type : TYPE_NAME (type);
+ const_tree underlying_type =
+ get_underlying_decl (TREE_TYPE (node));
+
+ if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE
+ /* Pointer to pointer. */
+
+ || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
+ && (!underlying_type
+ || !TYPE_FIELDS (TREE_TYPE (underlying_type))))
+ /* Pointer to opaque structure. */
+
+ || (typ && typ2
+ && DECL_P (underlying_type)
+ && DECL_P (typ2)
+ && decl_sloc (underlying_type, true)
+ > decl_sloc (typ2, true)
+ && DECL_SOURCE_FILE (underlying_type)
+ == DECL_SOURCE_FILE (typ2)))
+ {
+ if (package_prefix)
+ {
+ append_withs ("System", false);
+ if (!name_only)
+ pp_string (buffer, "new ");
+ pp_string (buffer, "System.Address");
+ }
+ else
+ pp_string (buffer, "address");
+ return spc;
+ }
+
+ if (!package_prefix)
+ pp_string (buffer, "access");
+ else if (AGGREGATE_TYPE_P (TREE_TYPE (node)))
+ {
+ if (!type || TREE_CODE (type) != FUNCTION_DECL)
+ {
+ pp_string (buffer, "access ");
+ is_access = true;
+
+ if (quals & TYPE_QUAL_CONST)
+ pp_string (buffer, "constant ");
+ else if (!name_only)
+ pp_string (buffer, "all ");
+ }
+ else if (quals & TYPE_QUAL_CONST)
+ pp_string (buffer, "in ");
+ else if (in_function)
+ {
+ is_access = true;
+ pp_string (buffer, "access ");
+ }
+ else
+ {
+ is_access = true;
+ pp_string (buffer, "access ");
+ /* ??? should be configurable: access or in out. */
+ }
+ }
+ else
+ {
+ is_access = true;
+ pp_string (buffer, "access ");
+
+ if (!name_only)
+ pp_string (buffer, "all ");
+ }
+
+ if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
+ && TYPE_NAME (TREE_TYPE (node)))
+ {
+ tree name = TYPE_NAME (TREE_TYPE (node));
+ tree tmp;
+
+ if (TREE_CODE (name) == TYPE_DECL
+ && DECL_ORIGINAL_TYPE (name)
+ && TYPE_STUB_DECL (DECL_ORIGINAL_TYPE (name)))
+ {
+ tmp = TYPE_NAME (TREE_TYPE (TYPE_STUB_DECL
+ (DECL_ORIGINAL_TYPE (name))));
+
+ if (tmp == NULL_TREE)
+ tmp = TYPE_NAME (TREE_TYPE (node));
+ }
+ else
+ tmp = TYPE_NAME (TREE_TYPE (node));
+
+ dump_generic_ada_node
+ (buffer, tmp,
+ TREE_TYPE (node), cpp_check, spc, is_access, true);
+ }
+ else
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (node), TREE_TYPE (node),
+ cpp_check, spc, 0, true);
+ }
+ }
+ }
+ break;
+
+ case ARRAY_TYPE:
+ if (name_only)
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (node), node, cpp_check,
+ spc, limited_access, true);
+ else
+ dump_ada_array_type (buffer, node, spc);
+ break;
+
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ case QUAL_UNION_TYPE:
+ if (name_only)
+ {
+ if (TYPE_NAME (node))
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (node), node, cpp_check,
+ spc, limited_access, true);
+ else
+ {
+ pp_string (buffer, "anon_");
+ pp_scalar (buffer, "%d", TYPE_UID (node));
+ }
+ }
+ else
+ print_ada_struct_decl
+ (buffer, node, type, cpp_check, spc, true);
+ break;
+
+ case INTEGER_CST:
+ if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE)
+ {
+ pp_wide_integer (buffer, TREE_INT_CST_LOW (node));
+ pp_string (buffer, "B"); /* pseudo-unit */
+ }
+ else if (! host_integerp (node, 0))
+ {
+ tree val = node;
+ unsigned HOST_WIDE_INT low = TREE_INT_CST_LOW (val);
+ HOST_WIDE_INT high = TREE_INT_CST_HIGH (val);
+
+ if (tree_int_cst_sgn (val) < 0)
+ {
+ pp_character (buffer, '-');
+ high = ~high + !low;
+ low = -low;
+ }
+ sprintf (pp_buffer (buffer)->digit_buffer,
+ HOST_WIDE_INT_PRINT_DOUBLE_HEX,
+ (unsigned HOST_WIDE_INT) high, low);
+ pp_string (buffer, pp_buffer (buffer)->digit_buffer);
+ }
+ else
+ pp_wide_integer (buffer, TREE_INT_CST_LOW (node));
+ break;
+
+ case REAL_CST:
+ case FIXED_CST:
+ case COMPLEX_CST:
+ case STRING_CST:
+ case VECTOR_CST:
+ return 0;
+
+ case FUNCTION_DECL:
+ case CONST_DECL:
+ dump_ada_decl_name (buffer, node, limited_access);
+ break;
+
+ case TYPE_DECL:
+ if (DECL_IS_BUILTIN (node))
+ {
+ /* Don't print the declaration of built-in types. */
+
+ if (name_only)
+ {
+ /* If we're in the middle of a declaration, defaults to
+ System.Address. */
+ if (package_prefix)
+ {
+ append_withs ("System", false);
+ pp_string (buffer, "System.Address");
+ }
+ else
+ pp_string (buffer, "address");
+ }
+ break;
+ }
+
+ if (name_only)
+ dump_ada_decl_name (buffer, node, limited_access);
+ else
+ {
+ if (is_tagged_type (TREE_TYPE (node)))
+ {
+ tree tmp = TYPE_FIELDS (TREE_TYPE (node));
+ int first = 1;
+
+ /* Look for ancestors. */
+ for (; tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (!DECL_NAME (tmp) && is_tagged_type (TREE_TYPE (tmp)))
+ {
+ if (first)
+ {
+ pp_string (buffer, "limited new ");
+ first = 0;
+ }
+ else
+ pp_string (buffer, " and ");
+
+ dump_ada_decl_name
+ (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
+ }
+ }
+
+ pp_string (buffer, first ? "tagged limited " : " with ");
+ }
+ else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
+ && TYPE_METHODS (TREE_TYPE (node)))
+ pp_string (buffer, "limited ");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (node), type, cpp_check, spc, false, false);
+ }
+ break;
+
+ case VAR_DECL:
+ case PARM_DECL:
+ case FIELD_DECL:
+ case NAMESPACE_DECL:
+ dump_ada_decl_name (buffer, node, false);
+ break;
+
+ default:
+ /* Ignore other nodes (e.g. expressions). */
+ return 0;
+ }
+
+ return 1;
+}
+
+/* Dump in BUFFER NODE's methods. CPP_CHECK is used to perform C++ queries on
+ nodes. SPC is the indentation level. */
+
+static void
+print_ada_methods (pretty_printer *buffer, tree node,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ tree tmp = TYPE_METHODS (node);
+ int res = 1;
+
+ if (tmp)
+ {
+ pp_semicolon (buffer);
+
+ for (; tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (res)
+ {
+ pp_newline (buffer);
+ pp_newline (buffer);
+ }
+ res = print_ada_declaration (buffer, tmp, node, cpp_check, spc);
+ }
+ }
+}
+
+/* Dump in BUFFER anonymous types nested inside T's definition.
+ PARENT is the parent node of T. CPP_CHECK is used to perform C++ queries on
+ nodes. SPC is the indentation level. */
+
+static void
+dump_nested_types (pretty_printer *buffer, tree t, tree parent,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ tree field, outer, decl;
+
+ /* Avoid recursing over the same tree. */
+ if (TREE_VISITED (t))
+ return;
+
+ /* Find possible anonymous arrays/unions/structs recursively. */
+
+ outer = TREE_TYPE (t);
+
+ if (outer == NULL_TREE)
+ return;
+
+ field = TYPE_FIELDS (outer);
+ while (field)
+ {
+ if ((TREE_TYPE (field) != outer
+ || (TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
+ && TREE_TYPE (TREE_TYPE (field)) != outer))
+ && (!TYPE_NAME (TREE_TYPE (field))
+ || (TREE_CODE (field) == TYPE_DECL
+ && DECL_NAME (field) != DECL_NAME (t)
+ && TYPE_NAME (TREE_TYPE (field)) != TYPE_NAME (outer))))
+ {
+ switch (TREE_CODE (TREE_TYPE (field)))
+ {
+ case POINTER_TYPE:
+ decl = TREE_TYPE (TREE_TYPE (field));
+
+ if (TREE_CODE (decl) == FUNCTION_TYPE)
+ for (decl = TREE_TYPE (decl);
+ decl && TREE_CODE (decl) == POINTER_TYPE;
+ decl = TREE_TYPE (decl));
+
+ decl = get_underlying_decl (decl);
+
+ if (decl
+ && DECL_P (decl)
+ && decl_sloc (decl, true) > decl_sloc (t, true)
+ && DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t)
+ && !TREE_VISITED (decl)
+ && !DECL_IS_BUILTIN (decl)
+ && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl))
+ || TYPE_FIELDS (TREE_TYPE (decl))))
+ {
+ /* Generate forward declaration. */
+
+ pp_string (buffer, "type ");
+ dump_generic_ada_node
+ (buffer, decl, 0, cpp_check, spc, false, true);
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+
+ /* Ensure we do not generate duplicate forward
+ declarations for this type. */
+ TREE_VISITED (decl) = 1;
+ }
+ break;
+
+ case ARRAY_TYPE:
+ /* Special case char arrays. */
+ if (is_char_array (field))
+ pp_string (buffer, "sub");
+
+ pp_string (buffer, "type ");
+ dump_ada_double_name (buffer, parent, field, "_array is ");
+ dump_ada_array_type (buffer, field, spc);
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+ break;
+
+ case UNION_TYPE:
+ TREE_VISITED (t) = 1;
+ dump_nested_types (buffer, field, t, cpp_check, spc);
+
+ pp_string (buffer, "type ");
+
+ if (TYPE_NAME (TREE_TYPE (field)))
+ {
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (TREE_TYPE (field)), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, " (discr : unsigned := 0) is ");
+ print_ada_struct_decl
+ (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
+
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (field), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, ");");
+ newline_and_indent (buffer, spc);
+
+ pp_string (buffer, "pragma Unchecked_Union (");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (field), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, ");");
+ }
+ else
+ {
+ dump_ada_double_name
+ (buffer, parent, field,
+ "_union (discr : unsigned := 0) is ");
+ print_ada_struct_decl
+ (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ dump_ada_double_name (buffer, parent, field, "_union);");
+ newline_and_indent (buffer, spc);
+
+ pp_string (buffer, "pragma Unchecked_Union (");
+ dump_ada_double_name (buffer, parent, field, "_union);");
+ }
+
+ newline_and_indent (buffer, spc);
+ break;
+
+ case RECORD_TYPE:
+ if (TYPE_NAME (TREE_TYPE (t)) && !TREE_VISITED (t))
+ {
+ pp_string (buffer, "type ");
+ dump_generic_ada_node
+ (buffer, t, parent, 0, spc, false, true);
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+ }
+
+ TREE_VISITED (t) = 1;
+ dump_nested_types (buffer, field, t, cpp_check, spc);
+ pp_string (buffer, "type ");
+
+ if (TYPE_NAME (TREE_TYPE (field)))
+ {
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (field), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, " is ");
+ print_ada_struct_decl
+ (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (field), 0, cpp_check,
+ spc, false, true);
+ pp_string (buffer, ");");
+ }
+ else
+ {
+ dump_ada_double_name
+ (buffer, parent, field, "_struct is ");
+ print_ada_struct_decl
+ (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ dump_ada_double_name (buffer, parent, field, "_struct);");
+ }
+
+ newline_and_indent (buffer, spc);
+ break;
+
+ default:
+ break;
+ }
+ }
+ field = TREE_CHAIN (field);
+ }
+}
+
+/* Dump in BUFFER destructor spec corresponding to T. */
+
+static void
+print_destructor (pretty_printer *buffer, tree t)
+{
+ const char *s = IDENTIFIER_POINTER (DECL_NAME (t));
+
+ if (*s == '_')
+ for (s += 2; *s != ' '; s++)
+ pp_character (buffer, *s);
+ else
+ {
+ pp_string (buffer, "Delete_");
+ pp_ada_tree_identifier (buffer, DECL_NAME (t), t, false);
+ }
+}
+
+/* Return the name of type T. */
+
+static const char *
+type_name (tree t)
+{
+ tree n = TYPE_NAME (t);
+
+ if (TREE_CODE (n) == IDENTIFIER_NODE)
+ return IDENTIFIER_POINTER (n);
+ else
+ return IDENTIFIER_POINTER (DECL_NAME (n));
+}
+
+/* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
+ CPP_CHECK is used to perform C++ queries on nodes. SPC is the indentation
+ level. Return 1 if a declaration was printed, 0 otherwise. */
+
+static int
+print_ada_declaration (pretty_printer *buffer, tree t, tree type,
+ int (*cpp_check)(tree, cpp_operation), int spc)
+{
+ int is_var = 0, need_indent = 0;
+ int is_class = false;
+ tree name = TYPE_NAME (TREE_TYPE (t));
+ tree decl_name = DECL_NAME (t);
+ bool dump_internal = get_dump_file_info (TDI_ada)->flags & TDF_RAW;
+ tree orig = NULL_TREE;
+
+ if (cpp_check && cpp_check (t, IS_TEMPLATE))
+ return dump_ada_template (buffer, t, cpp_check, spc);
+
+ if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
+ /* Skip enumeral values: will be handled as part of the type itself. */
+ return 0;
+
+ if (TREE_CODE (t) == TYPE_DECL)
+ {
+ orig = DECL_ORIGINAL_TYPE (t);
+
+ if (orig && TYPE_STUB_DECL (orig))
+ {
+ tree typ = TREE_TYPE (TYPE_STUB_DECL (orig));
+
+ if (TYPE_NAME (typ))
+ {
+ /* If types have same representation, and same name (ignoring
+ casing), then ignore the second type. */
+ if (type_name (typ) == type_name (TREE_TYPE (t))
+ || !strcasecmp (type_name (typ), type_name (TREE_TYPE (t))))
+ return 0;
+
+ INDENT (spc);
+
+ if (RECORD_OR_UNION_TYPE_P (typ) && !TYPE_FIELDS (typ))
+ {
+ pp_string (buffer, "-- skipped empty struct ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ }
+ else
+ {
+ pp_string (buffer, "subtype ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ pp_string (buffer, " is ");
+ dump_generic_ada_node
+ (buffer, typ, type, 0, spc, false, true);
+ pp_semicolon (buffer);
+ }
+ return 1;
+ }
+ }
+
+ /* Skip unnamed or anonymous structs/unions/enum types. */
+ if (!orig && !decl_name && !name)
+ {
+ tree tmp;
+ location_t sloc;
+
+ if (cpp_check || TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
+ return 0;
+
+ if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
+ {
+ /* Search next items until finding a named type decl. */
+ sloc = decl_sloc_common (t, true, true);
+
+ for (tmp = TREE_CHAIN (t); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (TREE_CODE (tmp) == TYPE_DECL
+ && (DECL_NAME (tmp) || TYPE_NAME (TREE_TYPE (tmp))))
+ {
+ /* If same sloc, it means we can ignore the anonymous
+ struct. */
+ if (decl_sloc_common (tmp, true, true) == sloc)
+ return 0;
+ else
+ break;
+ }
+ }
+ if (tmp == NULL)
+ return 0;
+ }
+ }
+
+ if (!orig
+ && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE
+ && decl_name
+ && (*IDENTIFIER_POINTER (decl_name) == '.'
+ || *IDENTIFIER_POINTER (decl_name) == '$'))
+ /* Skip anonymous enum types (duplicates of real types). */
+ return 0;
+
+ INDENT (spc);
+
+ switch (TREE_CODE (TREE_TYPE (t)))
+ {
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ case QUAL_UNION_TYPE:
+ /* Skip empty structs (typically forward references to real
+ structs). */
+ if (!TYPE_FIELDS (TREE_TYPE (t)))
+ {
+ pp_string (buffer, "-- skipped empty struct ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ return 1;
+ }
+
+ if (decl_name
+ && (*IDENTIFIER_POINTER (decl_name) == '.'
+ || *IDENTIFIER_POINTER (decl_name) == '$'))
+ {
+ pp_string (buffer, "-- skipped anonymous struct ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ return 1;
+ }
+
+ if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
+ pp_string (buffer, "subtype ");
+ else
+ {
+ dump_nested_types (buffer, t, t, cpp_check, spc);
+
+ if (TYPE_METHODS (TREE_TYPE (t))
+ || has_static_fields (TREE_TYPE (t)))
+ {
+ is_class = true;
+ pp_string (buffer, "package Class_");
+ dump_generic_ada_node
+ (buffer, t, type, 0, spc, false, true);
+ pp_string (buffer, " is");
+ spc += INDENT_INCR;
+ newline_and_indent (buffer, spc);
+ }
+
+ pp_string (buffer, "type ");
+ }
+ break;
+
+ case ARRAY_TYPE:
+ case POINTER_TYPE:
+ case REFERENCE_TYPE:
+ if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
+ || is_char_array (t))
+ pp_string (buffer, "subtype ");
+ else
+ pp_string (buffer, "type ");
+ break;
+
+ case FUNCTION_TYPE:
+ pp_string (buffer, "-- skipped function type ");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ return 1;
+ break;
+
+ default:
+ pp_string (buffer, "subtype ");
+ }
+ }
+ else
+ {
+ if (!dump_internal
+ && TREE_CODE (t) == VAR_DECL
+ && decl_name
+ && *IDENTIFIER_POINTER (decl_name) == '_')
+ return 0;
+
+ need_indent = 1;
+ }
+
+ /* Print the type and name. */
+ if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
+ {
+ if (need_indent)
+ INDENT (spc);
+
+ /* Print variable's name. */
+ dump_generic_ada_node (buffer, t, type, cpp_check, spc, false, true);
+
+ if (TREE_CODE (t) == TYPE_DECL)
+ {
+ pp_string (buffer, " is ");
+
+ if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (orig), type,
+ cpp_check, spc, false, true);
+ else
+ dump_ada_array_type (buffer, t, spc);
+ }
+ else
+ {
+ tree tmp = TYPE_NAME (TREE_TYPE (t));
+
+ if (spc == INDENT_INCR || TREE_STATIC (t))
+ is_var = 1;
+
+ pp_string (buffer, " : ");
+
+ if (tmp)
+ {
+ if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE
+ && TREE_CODE (tmp) != INTEGER_TYPE)
+ pp_string (buffer, "aliased ");
+
+ dump_generic_ada_node (buffer, tmp, type, 0, spc, false, true);
+ }
+ else
+ {
+ pp_string (buffer, "aliased ");
+
+ if (!type)
+ dump_ada_array_type (buffer, t, spc);
+ else
+ dump_ada_double_name (buffer, type, t, "_array");
+ }
+ }
+ }
+ else if (TREE_CODE (t) == FUNCTION_DECL)
+ {
+ bool is_function = true, is_method, is_abstract_class = false;
+ tree decl_name = DECL_NAME (t);
+ int prev_in_function = in_function;
+ bool is_abstract = false;
+ bool is_constructor = false;
+ bool is_destructor = false;
+ bool is_copy_constructor = false;
+
+ if (!decl_name)
+ return 0;
+
+ if (cpp_check)
+ {
+ is_abstract = cpp_check (t, IS_ABSTRACT);
+ is_constructor = cpp_check (t, IS_CONSTRUCTOR);
+ is_destructor = cpp_check (t, IS_DESTRUCTOR);
+ is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR);
+ }
+
+ /* Skip __comp_dtor destructor which is redundant with the '~class()'
+ destructor. */
+ if (is_destructor
+ && !strncmp (IDENTIFIER_POINTER (decl_name), "__comp", 6))
+ return 0;
+
+ /* Skip copy constructors: some are internal only, and those that are
+ not cannot be called easily from Ada anyway. */
+ if (is_copy_constructor)
+ return 0;
+
+ /* If this function has an entry in the dispatch table, we cannot
+ omit it. */
+ if (!dump_internal && !DECL_VINDEX (t)
+ && *IDENTIFIER_POINTER (decl_name) == '_')
+ {
+ if (IDENTIFIER_POINTER (decl_name)[1] == '_')
+ return 0;
+
+ INDENT (spc);
+ pp_string (buffer, "-- skipped func ");
+ pp_string (buffer, IDENTIFIER_POINTER (decl_name));
+ return 1;
+ }
+
+ if (need_indent)
+ INDENT (spc);
+
+ if (is_constructor)
+ pp_string (buffer, "function New_");
+ else if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))))
+ {
+ is_function = false;
+ pp_string (buffer, "procedure ");
+ }
+ else
+ pp_string (buffer, "function ");
+
+ in_function = is_function;
+ is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE;
+
+ if (is_destructor)
+ print_destructor (buffer, t);
+ else
+ dump_ada_decl_name (buffer, t, false);
+
+ dump_ada_function_declaration
+ (buffer, t, is_method, is_constructor, is_destructor, spc);
+ in_function = prev_in_function;
+
+ if (is_function)
+ {
+ pp_string (buffer, " return ");
+
+ if (is_constructor)
+ {
+ dump_ada_decl_name (buffer, t, false);
+ }
+ else
+ {
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (TREE_TYPE (t)), type, cpp_check,
+ spc, false, true);
+ }
+ }
+
+ if (is_constructor && cpp_check && type
+ && AGGREGATE_TYPE_P (type)
+ && TYPE_METHODS (type))
+ {
+ tree tmp = TYPE_METHODS (type);
+
+ for (; tmp; tmp = TREE_CHAIN (tmp))
+ if (cpp_check (tmp, IS_ABSTRACT))
+ {
+ is_abstract_class = 1;
+ break;
+ }
+ }
+
+ if (is_abstract || is_abstract_class)
+ pp_string (buffer, " is abstract");
+
+ pp_semicolon (buffer);
+ pp_string (buffer, " -- ");
+ dump_sloc (buffer, t);
+
+ if (is_abstract)
+ return 1;
+
+ newline_and_indent (buffer, spc);
+
+ if (is_constructor)
+ {
+ pp_string (buffer, "pragma CPP_Constructor (New_");
+ dump_ada_decl_name (buffer, t, false);
+ pp_string (buffer, ", \"");
+ pp_asm_name (buffer, t);
+ pp_string (buffer, "\");");
+ }
+ else if (is_destructor)
+ {
+ pp_string (buffer, "pragma Import (CPP, ");
+ print_destructor (buffer, t);
+ pp_string (buffer, ", \"");
+ pp_asm_name (buffer, t);
+ pp_string (buffer, "\");");
+ }
+ else
+ {
+ dump_ada_import (buffer, t);
+ }
+
+ return 1;
+ }
+ else if (TREE_CODE (t) == TYPE_DECL && !DECL_ORIGINAL_TYPE (t))
+ {
+ int is_interface = 0;
+ int is_abstract_record = 0;
+
+ if (need_indent)
+ INDENT (spc);
+
+ /* Anonymous structs/unions */
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true);
+
+ if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
+ || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE)
+ {
+ pp_string (buffer, " (discr : unsigned := 0)");
+ }
+
+ pp_string (buffer, " is ");
+
+ /* Check whether we have an Ada interface compatible class. */
+ if (cpp_check && AGGREGATE_TYPE_P (TREE_TYPE (t))
+ && TYPE_METHODS (TREE_TYPE (t)))
+ {
+ int num_fields = 0;
+ tree tmp = TYPE_FIELDS (TREE_TYPE (t));
+
+ /* Check that there are no fields other than the virtual table. */
+ for (; tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (TREE_CODE (tmp) == TYPE_DECL)
+ continue;
+ num_fields++;
+ }
+
+ if (num_fields == 1)
+ is_interface = 1;
+
+ /* Also check that there are only virtual methods. */
+ for (tmp = TYPE_METHODS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (cpp_check (tmp, IS_ABSTRACT))
+ is_abstract_record = 1;
+ else
+ is_interface = 0;
+ }
+ }
+
+ if (is_interface)
+ {
+ pp_string (buffer, "limited interface; -- ");
+ dump_sloc (buffer, t);
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "pragma Import (CPP, ");
+ dump_generic_ada_node
+ (buffer, TYPE_NAME (TREE_TYPE (t)), type, cpp_check,
+ spc, false, true);
+ pp_character (buffer, ')');
+
+ print_ada_methods (buffer, TREE_TYPE (t), cpp_check, spc);
+ }
+ else
+ {
+ if (is_abstract_record)
+ pp_string (buffer, "abstract ");
+ dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, false);
+ }
+ }
+ else
+ {
+ if (need_indent)
+ INDENT (spc);
+
+ if (TREE_CODE (t) == FIELD_DECL && DECL_NAME (t))
+ check_name (buffer, t);
+
+ /* Print variable/type's name. */
+ dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, true);
+
+ if (TREE_CODE (t) == TYPE_DECL)
+ {
+ tree orig = DECL_ORIGINAL_TYPE (t);
+ int is_subtype = orig && TYPE_NAME (orig) && orig != TREE_TYPE (t);
+
+ if (!is_subtype
+ && (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
+ || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE))
+ pp_string (buffer, " (discr : unsigned := 0)");
+
+ pp_string (buffer, " is ");
+
+ dump_generic_ada_node
+ (buffer, orig, t, cpp_check, spc, false, is_subtype);
+ }
+ else
+ {
+ if (spc == INDENT_INCR || TREE_STATIC (t))
+ is_var = 1;
+
+ pp_string (buffer, " : ");
+
+ /* Print type declaration. */
+
+ if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
+ && !TYPE_NAME (TREE_TYPE (t)))
+ {
+ dump_ada_double_name (buffer, type, t, "_union");
+ }
+ else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
+ {
+ if (TREE_CODE (TREE_TYPE (t)) == RECORD_TYPE)
+ pp_string (buffer, "aliased ");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true);
+ }
+ else
+ {
+ if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE
+ && (TYPE_NAME (TREE_TYPE (t))
+ || TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE))
+ pp_string (buffer, "aliased ");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (t), TREE_TYPE (t), cpp_check,
+ spc, false, true);
+ }
+ }
+ }
+
+ if (is_class)
+ {
+ spc -= 3;
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "end;");
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "use Class_");
+ dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
+ pp_semicolon (buffer);
+ pp_newline (buffer);
+
+ /* All needed indentation/newline performed already, so return 0. */
+ return 0;
+ }
+ else
+ {
+ pp_string (buffer, "; -- ");
+ dump_sloc (buffer, t);
+ }
+
+ if (is_var)
+ {
+ newline_and_indent (buffer, spc);
+ dump_ada_import (buffer, t);
+ }
+
+ return 1;
+}
+
+/* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
+ with Ada syntax. CPP_CHECK is used to perform C++ queries on nodes. SPC
+ is the indentation level. If DISPLAY_CONVENTION is true, also print the
+ pragma Convention for NODE. */
+
+static void
+print_ada_struct_decl (pretty_printer *buffer, tree node, tree type,
+ int (*cpp_check)(tree, cpp_operation), int spc,
+ bool display_convention)
+{
+ tree tmp;
+ int is_union =
+ TREE_CODE (node) == UNION_TYPE || TREE_CODE (node) == QUAL_UNION_TYPE;
+ char buf [16];
+ int field_num = 0;
+ int field_spc = spc + INDENT_INCR;
+ int need_semicolon;
+
+ bitfield_used = false;
+
+ if (!TYPE_FIELDS (node))
+ pp_string (buffer, "null record;");
+ else
+ {
+ pp_string (buffer, "record");
+
+ /* Print the contents of the structure. */
+
+ if (is_union)
+ {
+ newline_and_indent (buffer, spc + INDENT_INCR);
+ pp_string (buffer, "case discr is");
+ field_spc = spc + INDENT_INCR * 3;
+ }
+
+ pp_newline (buffer);
+
+ /* Print the non-static fields of the structure. */
+ for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ /* Add parent field if needed. */
+ if (!DECL_NAME (tmp))
+ {
+ if (!is_tagged_type (TREE_TYPE (tmp)))
+ {
+ if (!TYPE_NAME (TREE_TYPE (tmp)))
+ print_ada_declaration
+ (buffer, tmp, type, cpp_check, field_spc);
+ else
+ {
+ INDENT (field_spc);
+
+ if (field_num == 0)
+ pp_string (buffer, "parent : ");
+ else
+ {
+ sprintf (buf, "field_%d : ", field_num + 1);
+ pp_string (buffer, buf);
+ }
+ dump_ada_decl_name
+ (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
+ pp_semicolon (buffer);
+ }
+ pp_newline (buffer);
+ field_num++;
+ }
+ }
+ /* Avoid printing the structure recursively. */
+ else if ((TREE_TYPE (tmp) != node
+ || (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
+ && TREE_TYPE (TREE_TYPE (tmp)) != node))
+ && TREE_CODE (tmp) != TYPE_DECL
+ && !TREE_STATIC (tmp))
+ {
+ /* Skip internal virtual table field. */
+ if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp)), "_vptr", 5))
+ {
+ if (is_union)
+ {
+ if (TREE_CHAIN (tmp)
+ && TREE_TYPE (TREE_CHAIN (tmp)) != node
+ && TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL)
+ sprintf (buf, "when %d =>", field_num);
+ else
+ sprintf (buf, "when others =>");
+
+ INDENT (spc + INDENT_INCR * 2);
+ pp_string (buffer, buf);
+ pp_newline (buffer);
+ }
+
+ if (print_ada_declaration (buffer,
+ tmp, type, cpp_check, field_spc))
+ {
+ pp_newline (buffer);
+ field_num++;
+ }
+ }
+ }
+ }
+
+ if (is_union)
+ {
+ INDENT (spc + INDENT_INCR);
+ pp_string (buffer, "end case;");
+ pp_newline (buffer);
+ }
+
+ if (field_num == 0)
+ {
+ INDENT (spc + INDENT_INCR);
+ pp_string (buffer, "null;");
+ pp_newline (buffer);
+ }
+
+ INDENT (spc);
+ pp_string (buffer, "end record;");
+ }
+
+ newline_and_indent (buffer, spc);
+
+ if (!display_convention)
+ return;
+
+ if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type)))
+ {
+ if (TYPE_METHODS (TREE_TYPE (type)))
+ pp_string (buffer, "pragma Import (CPP, ");
+ else
+ pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
+ }
+ else
+ pp_string (buffer, "pragma Convention (C, ");
+
+ package_prefix = false;
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
+ package_prefix = true;
+ pp_character (buffer, ')');
+
+ if (is_union)
+ {
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "pragma Unchecked_Union (");
+
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
+ pp_character (buffer, ')');
+ }
+
+ if (bitfield_used)
+ {
+ pp_semicolon (buffer);
+ newline_and_indent (buffer, spc);
+ pp_string (buffer, "pragma Pack (");
+ dump_generic_ada_node
+ (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
+ pp_character (buffer, ')');
+ bitfield_used = false;
+ }
+
+ print_ada_methods (buffer, node, cpp_check, spc);
+
+ /* Print the static fields of the structure, if any. */
+ need_semicolon = TYPE_METHODS (node) == NULL_TREE;
+ for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
+ {
+ if (DECL_NAME (tmp) && TREE_STATIC (tmp))
+ {
+ if (need_semicolon)
+ {
+ need_semicolon = false;
+ pp_semicolon (buffer);
+ }
+ pp_newline (buffer);
+ pp_newline (buffer);
+ print_ada_declaration (buffer, tmp, type, cpp_check, spc);
+ }
+ }
+}
+
+/* Dump all the declarations in SOURCE_FILE to an Ada spec.
+ COLLECT_ALL_REFS is a front-end callback used to collect all relevant
+ nodes for SOURCE_FILE. CPP_CHECK is used to perform C++ queries on
+ nodes. */
+
+static void
+dump_ads (const char *source_file,
+ void (*collect_all_refs)(const char *),
+ int (*cpp_check)(tree, cpp_operation))
+{
+ char *ads_name;
+ char *pkg_name;
+ char *s;
+ FILE *f;
+
+ pkg_name = get_ada_package (source_file);
+
+ /* Construct the the .ads filename and package name. */
+ ads_name = xstrdup (pkg_name);
+
+ for (s = ads_name; *s; s++)
+ *s = TOLOWER (*s);
+
+ ads_name = reconcat (ads_name, ads_name, ".ads", NULL);
+
+ /* Write out the .ads file. */
+ f = fopen (ads_name, "w");
+ if (f)
+ {
+ pretty_printer pp;
+
+ pp_construct (&pp, NULL, 0);
+ pp_needs_newline (&pp) = true;
+ pp.buffer->stream = f;
+
+ /* Dump all relevant macros. */
+ dump_ada_macros (&pp, source_file);
+
+ /* Reset the table of withs for this file. */
+ reset_ada_withs ();
+
+ (*collect_all_refs) (source_file);
+
+ /* Dump all references. */
+ dump_ada_nodes (&pp, source_file, cpp_check);
+
+ /* Dump withs. */
+ dump_ada_withs (f);
+
+ fprintf (f, "\npackage %s is\n\n", pkg_name);
+ pp_write_text_to_stream (&pp);
+ /* ??? need to free pp */
+ fprintf (f, "end %s;\n", pkg_name);
+ fclose (f);
+ }
+
+ free (ads_name);
+ free (pkg_name);
+}
+
+static const char **source_refs = NULL;
+static int source_refs_used = 0;
+static int source_refs_allocd = 0;
+
+/* Add an entry for FILENAME to the table SOURCE_REFS. */
+
+void
+collect_source_ref (const char *filename)
+{
+ int i;
+
+ if (!filename)
+ return;
+
+ if (source_refs_allocd == 0)
+ {
+ source_refs_allocd = 1024;
+ source_refs = XNEWVEC (const char *, source_refs_allocd);
+ }
+
+ for (i = 0; i < source_refs_used; i++)
+ if (filename == source_refs [i])
+ return;
+
+ if (source_refs_used == source_refs_allocd)
+ {
+ source_refs_allocd *= 2;
+ source_refs = XRESIZEVEC (const char *, source_refs, source_refs_allocd);
+ }
+
+ source_refs [source_refs_used++] = filename;
+}
+
+/* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
+ using callbacks COLLECT_ALL_REFS and CPP_CHECK.
+ COLLECT_ALL_REFS is a front-end callback used to collect all relevant
+ nodes for a given source file.
+ CPP_CHECK is used to perform C++ queries on nodes, or NULL for the C
+ front-end. */
+
+void
+dump_ada_specs (void (*collect_all_refs)(const char *),
+ int (*cpp_check)(tree, cpp_operation))
+{
+ int i;
+
+ /* Iterate over the list of files to dump specs for */
+ for (i = 0; i < source_refs_used; i++)
+ dump_ads (source_refs [i], collect_all_refs, cpp_check);
+
+ /* Free files table. */
+ free (source_refs);
+}
projects / thirdparty / gcc.git / commitdiff
