path: root/gcc/c-family/c-ada-spec.c

/* 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 "tree-pass.h"	/* For TDI_ada and friends.  */
#include "c-ada-spec.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 *);
static bool separate_class_package (tree);

#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 = &macro->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, &param_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 = &macro->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 filename_cmp (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;
}

/* Return true if DECL refers to a C++ class type for which a
   separate enclosing package has been or should be generated.  */

static bool
separate_class_package (tree decl)
{
  if (decl) 
    {
      tree type = TREE_TYPE (decl);
      return type
	&& TREE_CODE (type) == RECORD_TYPE
	&& (TYPE_METHODS (type) || has_static_fields (type));
    }
  else
    return false;
}

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 (separate_class_package (decl))
                {
                  pp_string (buffer, "Class_");
                  pp_string (buffer, s);
                  pp_string (buffer, ".");
                }

            }
	}
    }

  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 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);
    }
}

/* 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 class 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_P (instance) || !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);

      TREE_VISITED (get_underlying_decl (instance)) = 1;
      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;
}

/* Return true if NODE is a simple enum types, that can be mapped to an
   Ada enum type directly.  */

static bool
is_simple_enum (tree node)
{
  unsigned HOST_WIDE_INT count = 0;
  tree value;

  for (value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
    {
      tree int_val = TREE_VALUE (value);

      if (TREE_CODE (int_val) != INTEGER_CST)
	int_val = DECL_INITIAL (int_val);

      if (!host_integerp (int_val, 0))
	return false;
      else if (TREE_INT_CST_LOW (int_val) != count)
	return false;

      count++;
    }

  return true;
}

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 = TYPE_VALUES (node);

	  if (is_simple_enum (node))
	    {
	      bool first = true;
	      spc += INDENT_INCR;
	      newline_and_indent (buffer, spc - 1);
	      pp_string (buffer, "(");
	      for (; value; value = TREE_CHAIN (value))
		{
		  if (first)
		    first = false;
		  else
		    {
		      pp_string (buffer, ",");
		      newline_and_indent (buffer, spc);
		    }

		  pp_ada_tree_identifier
		    (buffer, TREE_PURPOSE (value), node, false);
		}
	      pp_string (buffer, ");");
	      spc -= INDENT_INCR;
	      newline_and_indent (buffer, spc);
	      pp_string (buffer, "pragma Convention (C, ");
	      dump_generic_ada_node
		(buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
		 cpp_check, spc, 0, true);
	      pp_string (buffer, ")");
	    }
	  else
	    {
	      pp_string (buffer, "unsigned");
	      for (; 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 type_name = 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.  */

		      || underlying_type == NULL_TREE
		      || (!typ2
			  && !TREE_VISITED (underlying_type)
			  && !TREE_VISITED (type_name)
			  && !is_tagged_type (TREE_TYPE (node))
			  && DECL_SOURCE_FILE (underlying_type)
			       == source_file_base)
		      || (type_name && 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 != NULL_TREE)
		    dump_generic_ada_node
		      (buffer, type_name,
		       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.
   FORWARD indicates whether a forward declaration of T should be generated.
   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, bool forward,
		   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;

  if (forward)
    {
      pp_string (buffer, "type ");
      dump_generic_ada_node
	(buffer, t, t, cpp_check, spc, false, true);
      pp_semicolon (buffer);
      newline_and_indent (buffer, spc);
      TREE_VISITED (t) = 1;
    }

  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, false, 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, false, 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);
    }

  TREE_VISITED (t) = 1;
}

/* 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 stub = TYPE_STUB_DECL (orig);
	  tree typ = TREE_TYPE (stub);

	  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
		{
		  if (!TREE_VISITED (stub)
		      && DECL_SOURCE_FILE (stub) == source_file_base)
		    dump_nested_types
		      (buffer, stub, stub, true, cpp_check, spc);

		  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);
		TREE_VISITED (t) = 1;
		return 1;
	      }

	    if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
	      pp_string (buffer, "subtype ");
	    else
	      {
		dump_nested_types (buffer, t, t, false, cpp_check, spc);

                if (separate_class_package (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;

	  case ENUMERAL_TYPE:
	    if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
		|| !is_simple_enum (TREE_TYPE (t)))
	      pp_string (buffer, "subtype ");
	    else
	      pp_string (buffer, "type ");
	    break;

	  default:
	    pp_string (buffer, "subtype ");
	}
      TREE_VISITED (t) = 1;
    }
  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;
	    }
	}

      TREE_VISITED (t) = 1; 
      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 .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);
}