gcc/c-family/c-ada-spec.c

   1 /* Print GENERIC declaration (functions, variables, types) trees coming from
   2    the C and C++ front-ends as well as macros in Ada syntax.
   3    Copyright (C) 2010-2013 Free Software Foundation, Inc.
   4    Adapted from tree-pretty-print.c by Arnaud Charlet  <charlet@adacore.com>
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "coretypes.h"
  25 #include "tm.h"
  26 #include "tree.h"
  27 #include "dumpfile.h"
  28 #include "c-ada-spec.h"
  29 #include "cpplib.h"
  30 #include "c-pragma.h"
  31 #include "cpp-id-data.h"
  32
  33 /* Adapted from hwint.h to use the Ada prefix.  */
  34 #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_LONG
  35 # if HOST_BITS_PER_WIDE_INT == 64
  36 #  define ADA_HOST_WIDE_INT_PRINT_DOUBLE_HEX \
  37      "16#%" HOST_LONG_FORMAT "x%016" HOST_LONG_FORMAT "x#"
  38 # else
  39 #  define ADA_HOST_WIDE_INT_PRINT_DOUBLE_HEX \
  40      "16#%" HOST_LONG_FORMAT "x%08" HOST_LONG_FORMAT "x#"
  41 # endif
  42 #else
  43   /* We can assume that 'long long' is at least 64 bits.  */
  44 # define ADA_HOST_WIDE_INT_PRINT_DOUBLE_HEX \
  45     "16#%" HOST_LONG_LONG_FORMAT "x%016" HOST_LONG_LONG_FORMAT "x#"
  46 #endif /* HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_LONG */
  47
  48 /* Local functions, macros and variables.  */
  49 static int dump_generic_ada_node (pretty_printer *, tree, tree, int, int,
  50                                   bool);
  51 static int print_ada_declaration (pretty_printer *, tree, tree, int);
  52 static void print_ada_struct_decl (pretty_printer *, tree, tree, int, bool);
  53 static void dump_sloc (pretty_printer *buffer, tree node);
  54 static void print_comment (pretty_printer *, const char *);
  55 static void print_generic_ada_decl (pretty_printer *, tree, const char *);
  56 static char *get_ada_package (const char *);
  57 static void dump_ada_nodes (pretty_printer *, const char *);
  58 static void reset_ada_withs (void);
  59 static void dump_ada_withs (FILE *);
  60 static void dump_ads (const char *, void (*)(const char *),
  61                       int (*)(const_tree, cpp_operation));
  62 static char *to_ada_name (const char *, int *);
  63 static bool separate_class_package (tree);
  64
  65 #define INDENT(SPACE) \
  66   do { int i; for (i = 0; i<SPACE; i++) pp_space (buffer); } while (0)
  67
  68 #define INDENT_INCR 3
  69
  70 /* Global hook used to perform C++ queries on nodes.  */
  71 static int (*cpp_check) (const_tree, cpp_operation) = NULL;
  72
  73
  74 /* Given a cpp MACRO, compute the max length BUFFER_LEN of the macro, as well
  75    as max length PARAM_LEN of arguments for fun_like macros, and also set
  76    SUPPORTED to 0 if the macro cannot be mapped to an Ada construct.  */
  77
  78 static void
  79 macro_length (const cpp_macro *macro, int *supported, int *buffer_len,
  80               int *param_len)
  81 {
  82   int i;
  83   unsigned j;
  84
  85   *supported = 1;
  86   *buffer_len = 0;
  87   *param_len = 0;
  88
  89   if (macro->fun_like)
  90     {
  91       param_len++;
  92       for (i = 0; i < macro->paramc; i++)
  93         {
  94           cpp_hashnode *param = macro->params[i];
  95
  96           *param_len += NODE_LEN (param);
  97
  98           if (i + 1 < macro->paramc)
  99             {
 100               *param_len += 2;  /* ", " */
 101             }
 102           else if (macro->variadic)
 103             {
 104               *supported = 0;
 105               return;
 106             }
 107         }
 108       *param_len += 2;  /* ")\0" */
 109     }
 110
 111   for (j = 0; j < macro->count; j++)
 112     {
 113       cpp_token *token = &macro->exp.tokens[j];
 114
 115       if (token->flags & PREV_WHITE)
 116         (*buffer_len)++;
 117
 118       if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT)
 119         {
 120           *supported = 0;
 121           return;
 122         }
 123
 124       if (token->type == CPP_MACRO_ARG)
 125         *buffer_len +=
 126           NODE_LEN (macro->params[token->val.macro_arg.arg_no - 1]);
 127       else
 128         /* Include enough extra space to handle e.g. special characters.  */
 129         *buffer_len += (cpp_token_len (token) + 1) * 8;
 130     }
 131
 132   (*buffer_len)++;
 133 }
 134
 135 /* Dump into PP a set of MAX_ADA_MACROS MACROS (C/C++) as Ada constants when
 136    possible.  */
 137
 138 static void
 139 print_ada_macros (pretty_printer *pp, cpp_hashnode **macros, int max_ada_macros)
 140 {
 141   int j, num_macros = 0, prev_line = -1;
 142
 143   for (j = 0; j < max_ada_macros; j++)
 144     {
 145       cpp_hashnode *node = macros[j];
 146       const cpp_macro *macro = node->value.macro;
 147       unsigned i;
 148       int supported = 1, prev_is_one = 0, buffer_len, param_len;
 149       int is_string = 0, is_char = 0;
 150       char *ada_name;
 151       unsigned char *s, *params, *buffer, *buf_param, *char_one = NULL;
 152
 153       macro_length (macro, &supported, &buffer_len, &param_len);
 154       s = buffer = XALLOCAVEC (unsigned char, buffer_len);
 155       params = buf_param = XALLOCAVEC (unsigned char, param_len);
 156
 157       if (supported)
 158         {
 159           if (macro->fun_like)
 160             {
 161               *buf_param++ = '(';
 162               for (i = 0; i < macro->paramc; i++)
 163                 {
 164                   cpp_hashnode *param = macro->params[i];
 165
 166                   memcpy (buf_param, NODE_NAME (param), NODE_LEN (param));
 167                   buf_param += NODE_LEN (param);
 168
 169                   if (i + 1 < macro->paramc)
 170                     {
 171                       *buf_param++ = ',';
 172                       *buf_param++ = ' ';
 173                     }
 174                   else if (macro->variadic)
 175                     {
 176                       supported = 0;
 177                       break;
 178                     }
 179                 }
 180               *buf_param++ = ')';
 181               *buf_param = '\0';
 182             }
 183
 184           for (i = 0; supported && i < macro->count; i++)
 185             {
 186               cpp_token *token = &macro->exp.tokens[i];
 187               int is_one = 0;
 188
 189               if (token->flags & PREV_WHITE)
 190                 *buffer++ = ' ';
 191
 192               if (token->flags & STRINGIFY_ARG || token->flags & PASTE_LEFT)
 193                 {
 194                   supported = 0;
 195                   break;
 196                 }
 197
 198               switch (token->type)
 199                 {
 200                   case CPP_MACRO_ARG:
 201                     {
 202                       cpp_hashnode *param =
 203                         macro->params[token->val.macro_arg.arg_no - 1];
 204                       memcpy (buffer, NODE_NAME (param), NODE_LEN (param));
 205                       buffer += NODE_LEN (param);
 206                     }
 207                     break;
 208
 209                   case CPP_EQ_EQ:       *buffer++ = '='; break;
 210                   case CPP_GREATER:     *buffer++ = '>'; break;
 211                   case CPP_LESS:        *buffer++ = '<'; break;
 212                   case CPP_PLUS:        *buffer++ = '+'; break;
 213                   case CPP_MINUS:       *buffer++ = '-'; break;
 214                   case CPP_MULT:        *buffer++ = '*'; break;
 215                   case CPP_DIV:         *buffer++ = '/'; break;
 216                   case CPP_COMMA:       *buffer++ = ','; break;
 217                   case CPP_OPEN_SQUARE:
 218                   case CPP_OPEN_PAREN:  *buffer++ = '('; break;
 219                   case CPP_CLOSE_SQUARE: /* fallthrough */
 220                   case CPP_CLOSE_PAREN: *buffer++ = ')'; break;
 221                   case CPP_DEREF:       /* fallthrough */
 222                   case CPP_SCOPE:       /* fallthrough */
 223                   case CPP_DOT:         *buffer++ = '.'; break;
 224
 225                   case CPP_EQ:          *buffer++ = ':'; *buffer++ = '='; break;
 226                   case CPP_NOT_EQ:      *buffer++ = '/'; *buffer++ = '='; break;
 227                   case CPP_GREATER_EQ:  *buffer++ = '>'; *buffer++ = '='; break;
 228                   case CPP_LESS_EQ:     *buffer++ = '<'; *buffer++ = '='; break;
 229
 230                   case CPP_NOT:
 231                     *buffer++ = 'n'; *buffer++ = 'o'; *buffer++ = 't'; break;
 232                   case CPP_MOD:
 233                     *buffer++ = 'm'; *buffer++ = 'o'; *buffer++ = 'd'; break;
 234                   case CPP_AND:
 235                     *buffer++ = 'a'; *buffer++ = 'n'; *buffer++ = 'd'; break;
 236                   case CPP_OR:
 237                     *buffer++ = 'o'; *buffer++ = 'r'; break;
 238                   case CPP_XOR:
 239                     *buffer++ = 'x'; *buffer++ = 'o'; *buffer++ = 'r'; break;
 240                   case CPP_AND_AND:
 241                     strcpy ((char *) buffer, " and then ");
 242                     buffer += 10;
 243                     break;
 244                   case CPP_OR_OR:
 245                     strcpy ((char *) buffer, " or else ");
 246                     buffer += 9;
 247                     break;
 248
 249                   case CPP_PADDING:
 250                     *buffer++ = ' ';
 251                     is_one = prev_is_one;
 252                     break;
 253
 254                   case CPP_COMMENT: break;
 255
 256                   case CPP_WSTRING:
 257                   case CPP_STRING16:
 258                   case CPP_STRING32:
 259                   case CPP_UTF8STRING:
 260                   case CPP_WCHAR:
 261                   case CPP_CHAR16:
 262                   case CPP_CHAR32:
 263                   case CPP_NAME:
 264                   case CPP_STRING:
 265                   case CPP_NUMBER:
 266                     if (!macro->fun_like)
 267                       supported = 0;
 268                     else
 269                       buffer = cpp_spell_token (parse_in, token, buffer, false);
 270                     break;
 271
 272                   case CPP_CHAR:
 273                     is_char = 1;
 274                     {
 275                       unsigned chars_seen;
 276                       int ignored;
 277                       cppchar_t c;
 278
 279                       c = cpp_interpret_charconst (parse_in, token,
 280                                                    &chars_seen, &ignored);
 281                       if (c >= 32 && c <= 126)
 282                         {
 283                           *buffer++ = '\'';
 284                           *buffer++ = (char) c;
 285                           *buffer++ = '\'';
 286                         }
 287                       else
 288                         {
 289                           chars_seen = sprintf
 290                             ((char *) buffer, "Character'Val (%d)", (int) c);
 291                           buffer += chars_seen;
 292                         }
 293                     }
 294                     break;
 295
 296                   case CPP_LSHIFT:
 297                     if (prev_is_one)
 298                       {
 299                         /* Replace "1 << N" by "2 ** N" */
 300                         *char_one = '2';
 301                         *buffer++ = '*';
 302                         *buffer++ = '*';
 303                         break;
 304                       }
 305                     /* fallthrough */
 306
 307                   case CPP_RSHIFT:
 308                   case CPP_COMPL:
 309                   case CPP_QUERY:
 310                   case CPP_EOF:
 311                   case CPP_PLUS_EQ:
 312                   case CPP_MINUS_EQ:
 313                   case CPP_MULT_EQ:
 314                   case CPP_DIV_EQ:
 315                   case CPP_MOD_EQ:
 316                   case CPP_AND_EQ:
 317                   case CPP_OR_EQ:
 318                   case CPP_XOR_EQ:
 319                   case CPP_RSHIFT_EQ:
 320                   case CPP_LSHIFT_EQ:
 321                   case CPP_PRAGMA:
 322                   case CPP_PRAGMA_EOL:
 323                   case CPP_HASH:
 324                   case CPP_PASTE:
 325                   case CPP_OPEN_BRACE:
 326                   case CPP_CLOSE_BRACE:
 327                   case CPP_SEMICOLON:
 328                   case CPP_ELLIPSIS:
 329                   case CPP_PLUS_PLUS:
 330                   case CPP_MINUS_MINUS:
 331                   case CPP_DEREF_STAR:
 332                   case CPP_DOT_STAR:
 333                   case CPP_ATSIGN:
 334                   case CPP_HEADER_NAME:
 335                   case CPP_AT_NAME:
 336                   case CPP_OTHER:
 337                   case CPP_OBJC_STRING:
 338                   default:
 339                     if (!macro->fun_like)
 340                       supported = 0;
 341                     else
 342                       buffer = cpp_spell_token (parse_in, token, buffer, false);
 343                     break;
 344                 }
 345
 346               prev_is_one = is_one;
 347             }
 348
 349           if (supported)
 350             *buffer = '\0';
 351         }
 352
 353       if (macro->fun_like && supported)
 354         {
 355           char *start = (char *) s;
 356           int is_function = 0;
 357
 358           pp_string (pp, "   --  arg-macro: ");
 359
 360           if (*start == '(' && buffer[-1] == ')')
 361             {
 362               start++;
 363               buffer[-1] = '\0';
 364               is_function = 1;
 365               pp_string (pp, "function ");
 366             }
 367           else
 368             {
 369               pp_string (pp, "procedure ");
 370             }
 371
 372           pp_string (pp, (const char *) NODE_NAME (node));
 373           pp_space (pp);
 374           pp_string (pp, (char *) params);
 375           pp_newline (pp);
 376           pp_string (pp, "   --    ");
 377
 378           if (is_function)
 379             {
 380               pp_string (pp, "return ");
 381               pp_string (pp, start);
 382               pp_semicolon (pp);
 383             }
 384           else
 385             pp_string (pp, start);
 386
 387           pp_newline (pp);
 388         }
 389       else if (supported)
 390         {
 391           expanded_location sloc = expand_location (macro->line);
 392
 393           if (sloc.line != prev_line + 1)
 394             pp_newline (pp);
 395
 396           num_macros++;
 397           prev_line = sloc.line;
 398
 399           pp_string (pp, "   ");
 400           ada_name = to_ada_name ((const char *) NODE_NAME (node), NULL);
 401           pp_string (pp, ada_name);
 402           free (ada_name);
 403           pp_string (pp, " : ");
 404
 405           if (is_string)
 406             pp_string (pp, "aliased constant String");
 407           else if (is_char)
 408             pp_string (pp, "aliased constant Character");
 409           else
 410             pp_string (pp, "constant");
 411
 412           pp_string (pp, " := ");
 413           pp_string (pp, (char *) s);
 414
 415           if (is_string)
 416             pp_string (pp, " & ASCII.NUL");
 417
 418           pp_string (pp, ";  --  ");
 419           pp_string (pp, sloc.file);
 420           pp_colon (pp);
 421           pp_scalar (pp, "%d", sloc.line);
 422           pp_newline (pp);
 423         }
 424       else
 425         {
 426           pp_string (pp, "   --  unsupported macro: ");
 427           pp_string (pp, (const char *) cpp_macro_definition (parse_in, node));
 428           pp_newline (pp);
 429         }
 430     }
 431
 432   if (num_macros > 0)
 433     pp_newline (pp);
 434 }
 435
 436 static const char *source_file;
 437 static int max_ada_macros;
 438
 439 /* Callback used to count the number of relevant macros from
 440    cpp_forall_identifiers. PFILE and V are not used. NODE is the current macro
 441    to consider.  */
 442
 443 static int
 444 count_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED, cpp_hashnode *node,
 445                  void *v ATTRIBUTE_UNUSED)
 446 {
 447   const cpp_macro *macro = node->value.macro;
 448
 449   if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)
 450       && macro->count
 451       && *NODE_NAME (node) != '_'
 452       && LOCATION_FILE (macro->line) == source_file)
 453     max_ada_macros++;
 454
 455   return 1;
 456 }
 457
 458 static int store_ada_macro_index;
 459
 460 /* Callback used to store relevant macros from cpp_forall_identifiers.
 461    PFILE is not used. NODE is the current macro to store if relevant.
 462    MACROS is an array of cpp_hashnode* used to store NODE.  */
 463
 464 static int
 465 store_ada_macro (cpp_reader *pfile ATTRIBUTE_UNUSED,
 466                  cpp_hashnode *node, void *macros)
 467 {
 468   const cpp_macro *macro = node->value.macro;
 469
 470   if (node->type == NT_MACRO && !(node->flags & NODE_BUILTIN)
 471       && macro->count
 472       && *NODE_NAME (node) != '_'
 473       && LOCATION_FILE (macro->line) == source_file)
 474     ((cpp_hashnode **) macros)[store_ada_macro_index++] = node;
 475
 476   return 1;
 477 }
 478
 479 /* Callback used to compare (during qsort) macros.  NODE1 and NODE2 are the
 480    two macro nodes to compare.  */
 481
 482 static int
 483 compare_macro (const void *node1, const void *node2)
 484 {
 485   typedef const cpp_hashnode *const_hnode;
 486
 487   const_hnode n1 = *(const const_hnode *) node1;
 488   const_hnode n2 = *(const const_hnode *) node2;
 489
 490   return n1->value.macro->line - n2->value.macro->line;
 491 }
 492
 493 /* Dump in PP all relevant macros appearing in FILE.  */
 494
 495 static void
 496 dump_ada_macros (pretty_printer *pp, const char* file)
 497 {
 498   cpp_hashnode **macros;
 499
 500   /* Initialize file-scope variables.  */
 501   max_ada_macros = 0;
 502   store_ada_macro_index = 0;
 503   source_file = file;
 504
 505   /* Count all potentially relevant macros, and then sort them by sloc.  */
 506   cpp_forall_identifiers (parse_in, count_ada_macro, NULL);
 507   macros = XALLOCAVEC (cpp_hashnode *, max_ada_macros);
 508   cpp_forall_identifiers (parse_in, store_ada_macro, macros);
 509   qsort (macros, max_ada_macros, sizeof (cpp_hashnode *), compare_macro);
 510
 511   print_ada_macros (pp, macros, max_ada_macros);
 512 }
 513
 514 /* Current source file being handled.  */
 515
 516 static const char *source_file_base;
 517
 518 /* Compare the declaration (DECL) of struct-like types based on the sloc of
 519    their last field (if LAST is true), so that more nested types collate before
 520    less nested ones.
 521    If ORIG_TYPE is true, also consider struct with a DECL_ORIGINAL_TYPE.  */
 522
 523 static location_t
 524 decl_sloc_common (const_tree decl, bool last, bool orig_type)
 525 {
 526   tree type = TREE_TYPE (decl);
 527
 528   if (TREE_CODE (decl) == TYPE_DECL
 529       && (orig_type || !DECL_ORIGINAL_TYPE (decl))
 530       && RECORD_OR_UNION_TYPE_P (type)
 531       && TYPE_FIELDS (type))
 532     {
 533       tree f = TYPE_FIELDS (type);
 534
 535       if (last)
 536         while (TREE_CHAIN (f))
 537           f = TREE_CHAIN (f);
 538
 539       return DECL_SOURCE_LOCATION (f);
 540     }
 541   else
 542     return DECL_SOURCE_LOCATION (decl);
 543 }
 544
 545 /* Return sloc of DECL, using sloc of last field if LAST is true.  */
 546
 547 location_t
 548 decl_sloc (const_tree decl, bool last)
 549 {
 550   return decl_sloc_common (decl, last, false);
 551 }
 552
 553 /* Compare two locations LHS and RHS.  */
 554
 555 static int
 556 compare_location (location_t lhs, location_t rhs)
 557 {
 558   expanded_location xlhs = expand_location (lhs);
 559   expanded_location xrhs = expand_location (rhs);
 560
 561   if (xlhs.file != xrhs.file)
 562     return filename_cmp (xlhs.file, xrhs.file);
 563
 564   if (xlhs.line != xrhs.line)
 565     return xlhs.line - xrhs.line;
 566
 567   if (xlhs.column != xrhs.column)
 568     return xlhs.column - xrhs.column;
 569
 570   return 0;
 571 }
 572
 573 /* Compare two declarations (LP and RP) by their source location.  */
 574
 575 static int
 576 compare_node (const void *lp, const void *rp)
 577 {
 578   const_tree lhs = *((const tree *) lp);
 579   const_tree rhs = *((const tree *) rp);
 580
 581   return compare_location (decl_sloc (lhs, true), decl_sloc (rhs, true));
 582 }
 583
 584 /* Compare two comments (LP and RP) by their source location.  */
 585
 586 static int
 587 compare_comment (const void *lp, const void *rp)
 588 {
 589   const cpp_comment *lhs = (const cpp_comment *) lp;
 590   const cpp_comment *rhs = (const cpp_comment *) rp;
 591
 592   return compare_location (lhs->sloc, rhs->sloc);
 593 }
 594
 595 static tree *to_dump = NULL;
 596 static int to_dump_count = 0;
 597
 598 /* Collect a list of declarations from T relevant to SOURCE_FILE to be dumped
 599    by a subsequent call to dump_ada_nodes.  */
 600
 601 void
 602 collect_ada_nodes (tree t, const char *source_file)
 603 {
 604   tree n;
 605   int i = to_dump_count;
 606
 607   /* Count the likely relevant nodes.  */
 608   for (n = t; n; n = TREE_CHAIN (n))
 609     if (!DECL_IS_BUILTIN (n)
 610         && LOCATION_FILE (decl_sloc (n, false)) == source_file)
 611       to_dump_count++;
 612
 613   /* Allocate sufficient storage for all nodes.  */
 614   to_dump = XRESIZEVEC (tree, to_dump, to_dump_count);
 615
 616   /* Store the relevant nodes.  */
 617   for (n = t; n; n = TREE_CHAIN (n))
 618     if (!DECL_IS_BUILTIN (n)
 619         && LOCATION_FILE (decl_sloc (n, false)) == source_file)
 620       to_dump[i++] = n;
 621 }
 622
 623 /* Call back for walk_tree to clear the TREE_VISITED flag of TP.  */
 624
 625 static tree
 626 unmark_visited_r (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED,
 627                   void *data ATTRIBUTE_UNUSED)
 628 {
 629   if (TREE_VISITED (*tp))
 630     TREE_VISITED (*tp) = 0;
 631   else
 632     *walk_subtrees = 0;
 633
 634   return NULL_TREE;
 635 }
 636
 637 /* Dump nodes into PP relevant to SOURCE_FILE, as collected by previous calls
 638    to collect_ada_nodes.  */
 639
 640 static void
 641 dump_ada_nodes (pretty_printer *pp, const char *source_file)
 642 {
 643   int i, j;
 644   cpp_comment_table *comments;
 645
 646   /* Sort the table of declarations to dump by sloc.  */
 647   qsort (to_dump, to_dump_count, sizeof (tree), compare_node);
 648
 649   /* Fetch the table of comments.  */
 650   comments = cpp_get_comments (parse_in);
 651
 652   /* Sort the comments table by sloc.  */
 653   qsort (comments->entries, comments->count, sizeof (cpp_comment),
 654          compare_comment);
 655
 656   /* Interleave comments and declarations in line number order.  */
 657   i = j = 0;
 658   do
 659     {
 660       /* Advance j until comment j is in this file.  */
 661       while (j != comments->count
 662              && LOCATION_FILE (comments->entries[j].sloc) != source_file)
 663         j++;
 664
 665       /* Advance j until comment j is not a duplicate.  */
 666       while (j < comments->count - 1
 667              && !compare_comment (&comments->entries[j],
 668                                   &comments->entries[j + 1]))
 669         j++;
 670
 671       /* Write decls until decl i collates after comment j.  */
 672       while (i != to_dump_count)
 673         {
 674           if (j == comments->count
 675               || LOCATION_LINE (decl_sloc (to_dump[i], false))
 676               <  LOCATION_LINE (comments->entries[j].sloc))
 677             print_generic_ada_decl (pp, to_dump[i++], source_file);
 678           else
 679             break;
 680         }
 681
 682       /* Write comment j, if there is one.  */
 683       if (j != comments->count)
 684         print_comment (pp, comments->entries[j++].comment);
 685
 686     } while (i != to_dump_count || j != comments->count);
 687
 688   /* Clear the TREE_VISITED flag over each subtree we've dumped.  */
 689   for (i = 0; i < to_dump_count; i++)
 690     walk_tree (&to_dump[i], unmark_visited_r, NULL, NULL);
 691
 692   /* Finalize the to_dump table.  */
 693   if (to_dump)
 694     {
 695       free (to_dump);
 696       to_dump = NULL;
 697       to_dump_count = 0;
 698     }
 699 }
 700
 701 /* Print a COMMENT to the output stream PP.  */
 702
 703 static void
 704 print_comment (pretty_printer *pp, const char *comment)
 705 {
 706   int len = strlen (comment);
 707   char *str = XALLOCAVEC (char, len + 1);
 708   char *tok;
 709   bool extra_newline = false;
 710
 711   memcpy (str, comment, len + 1);
 712
 713   /* Trim C/C++ comment indicators.  */
 714   if (str[len - 2] == '*' && str[len - 1] == '/')
 715     {
 716       str[len - 2] = ' ';
 717       str[len - 1] = '\0';
 718     }
 719   str += 2;
 720
 721   tok = strtok (str, "\n");
 722   while (tok) {
 723     pp_string (pp, "  --");
 724     pp_string (pp, tok);
 725     pp_newline (pp);
 726     tok = strtok (NULL, "\n");
 727
 728     /* Leave a blank line after multi-line comments.  */
 729     if (tok)
 730       extra_newline = true;
 731   }
 732
 733   if (extra_newline)
 734     pp_newline (pp);
 735 }
 736
 737 /* Print declaration DECL to PP in Ada syntax.  The current source file being
 738    handled is SOURCE_FILE.  */
 739
 740 static void
 741 print_generic_ada_decl (pretty_printer *pp, tree decl, const char *source_file)
 742 {
 743   source_file_base = source_file;
 744
 745   if (print_ada_declaration (pp, decl, 0, INDENT_INCR))
 746     {
 747       pp_newline (pp);
 748       pp_newline (pp);
 749     }
 750 }
 751
 752 /* Dump a newline and indent BUFFER by SPC chars.  */
 753
 754 static void
 755 newline_and_indent (pretty_printer *buffer, int spc)
 756 {
 757   pp_newline (buffer);
 758   INDENT (spc);
 759 }
 760
 761 struct with { char *s; const char *in_file; int limited; };
 762 static struct with *withs = NULL;
 763 static int withs_max = 4096;
 764 static int with_len = 0;
 765
 766 /* Record a "with" clause on package S (a limited with if LIMITED_ACCESS is
 767    true), if not already done.  */
 768
 769 static void
 770 append_withs (const char *s, int limited_access)
 771 {
 772   int i;
 773
 774   if (withs == NULL)
 775     withs = XNEWVEC (struct with, withs_max);
 776
 777   if (with_len == withs_max)
 778     {
 779       withs_max *= 2;
 780       withs = XRESIZEVEC (struct with, withs, withs_max);
 781     }
 782
 783   for (i = 0; i < with_len; i++)
 784     if (!strcmp (s, withs[i].s)
 785         && source_file_base == withs[i].in_file)
 786       {
 787         withs[i].limited &= limited_access;
 788         return;
 789       }
 790
 791   withs[with_len].s = xstrdup (s);
 792   withs[with_len].in_file = source_file_base;
 793   withs[with_len].limited = limited_access;
 794   with_len++;
 795 }
 796
 797 /* Reset "with" clauses.  */
 798
 799 static void
 800 reset_ada_withs (void)
 801 {
 802   int i;
 803
 804   if (!withs)
 805     return;
 806
 807   for (i = 0; i < with_len; i++)
 808     free (withs[i].s);
 809   free (withs);
 810   withs = NULL;
 811   withs_max = 4096;
 812   with_len = 0;
 813 }
 814
 815 /* Dump "with" clauses in F.  */
 816
 817 static void
 818 dump_ada_withs (FILE *f)
 819 {
 820   int i;
 821
 822   fprintf (f, "with Interfaces.C; use Interfaces.C;\n");
 823
 824   for (i = 0; i < with_len; i++)
 825     fprintf
 826       (f, "%swith %s;\n", withs[i].limited ? "limited " : "", withs[i].s);
 827 }
 828
 829 /* Return suitable Ada package name from FILE.  */
 830
 831 static char *
 832 get_ada_package (const char *file)
 833 {
 834   const char *base;
 835   char *res;
 836   const char *s;
 837   int i;
 838   size_t plen;
 839
 840   s = strstr (file, "/include/");
 841   if (s)
 842     base = s + 9;
 843   else
 844     base = lbasename (file);
 845
 846   if (ada_specs_parent == NULL)
 847     plen = 0;
 848   else
 849     plen = strlen (ada_specs_parent) + 1;
 850
 851   res = XNEWVEC (char, plen + strlen (base) + 1);
 852   if (ada_specs_parent != NULL) {
 853     strcpy (res, ada_specs_parent);
 854     res[plen - 1] = '.';
 855   }
 856
 857   for (i = plen; *base; base++, i++)
 858     switch (*base)
 859       {
 860         case '+':
 861           res[i] = 'p';
 862           break;
 863
 864         case '.':
 865         case '-':
 866         case '_':
 867         case '/':
 868         case '\\':
 869           res[i] = (i == 0 || res[i - 1] == '.' || res[i - 1] == '_') ? 'u' : '_';
 870           break;
 871
 872         default:
 873           res[i] = *base;
 874           break;
 875       }
 876   res[i] = '\0';
 877
 878   return res;
 879 }
 880
 881 static const char *ada_reserved[] = {
 882   "abort", "abs", "abstract", "accept", "access", "aliased", "all", "and",
 883   "array", "at", "begin", "body", "case", "constant", "declare", "delay",
 884   "delta", "digits", "do", "else", "elsif", "end", "entry", "exception",
 885   "exit", "for", "function", "generic", "goto", "if", "in", "interface", "is",
 886   "limited", "loop", "mod", "new", "not", "null", "others", "out", "of", "or",
 887   "overriding", "package", "pragma", "private", "procedure", "protected",
 888   "raise", "range", "record", "rem", "renames", "requeue", "return", "reverse",
 889   "select", "separate", "subtype", "synchronized", "tagged", "task",
 890   "terminate", "then", "type", "until", "use", "when", "while", "with", "xor",
 891   NULL};
 892
 893 /* ??? would be nice to specify this list via a config file, so that users
 894    can create their own dictionary of conflicts.  */
 895 static const char *c_duplicates[] = {
 896   /* system will cause troubles with System.Address.  */
 897   "system",
 898
 899   /* The following values have other definitions with same name/other
 900      casing.  */
 901   "funmap",
 902   "rl_vi_fWord",
 903   "rl_vi_bWord",
 904   "rl_vi_eWord",
 905   "rl_readline_version",
 906   "_Vx_ushort",
 907   "USHORT",
 908   "XLookupKeysym",
 909   NULL};
 910
 911 /* Return a declaration tree corresponding to TYPE.  */
 912
 913 static tree
 914 get_underlying_decl (tree type)
 915 {
 916   tree decl = NULL_TREE;
 917
 918   if (type == NULL_TREE)
 919     return NULL_TREE;
 920
 921   /* type is a declaration.  */
 922   if (DECL_P (type))
 923     decl = type;
 924
 925   /* type is a typedef.  */
 926   if (TYPE_P (type) && TYPE_NAME (type) && DECL_P (TYPE_NAME (type)))
 927     decl = TYPE_NAME (type);
 928
 929   /* TYPE_STUB_DECL has been set for type.  */
 930   if (TYPE_P (type) && TYPE_STUB_DECL (type) &&
 931       DECL_P (TYPE_STUB_DECL (type)))
 932     decl = TYPE_STUB_DECL (type);
 933
 934   return decl;
 935 }
 936
 937 /* Return whether TYPE has static fields.  */
 938
 939 static bool
 940 has_static_fields (const_tree type)
 941 {
 942   tree tmp;
 943
 944   if (!type || !RECORD_OR_UNION_TYPE_P (type))
 945     return false;
 946
 947   for (tmp = TYPE_FIELDS (type); tmp; tmp = TREE_CHAIN (tmp))
 948     if (DECL_NAME (tmp) && TREE_STATIC (tmp))
 949       return true;
 950
 951   return false;
 952 }
 953
 954 /* Return whether TYPE corresponds to an Ada tagged type (has a dispatch
 955    table).  */
 956
 957 static bool
 958 is_tagged_type (const_tree type)
 959 {
 960   tree tmp;
 961
 962   if (!type || !RECORD_OR_UNION_TYPE_P (type))
 963     return false;
 964
 965   for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp))
 966     if (DECL_VINDEX (tmp))
 967       return true;
 968
 969   return false;
 970 }
 971
 972 /* Return whether TYPE has non-trivial methods, i.e. methods that do something
 973    for the objects of TYPE.  In C++, all classes have implicit special methods,
 974    e.g. constructors and destructors, but they can be trivial if the type is
 975    sufficiently simple.  */
 976
 977 static bool
 978 has_nontrivial_methods (const_tree type)
 979 {
 980   tree tmp;
 981
 982   if (!type || !RECORD_OR_UNION_TYPE_P (type))
 983     return false;
 984
 985   /* Only C++ types can have methods.  */
 986   if (!cpp_check)
 987     return false;
 988
 989   /* A non-trivial type has non-trivial special methods.  */
 990   if (!cpp_check (type, IS_TRIVIAL))
 991     return true;
 992
 993   /* If there are user-defined methods, they are deemed non-trivial.  */
 994   for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp))
 995     if (!DECL_ARTIFICIAL (tmp))
 996       return true;
 997
 998   return false;
 999 }
1000
1001 /* Generate a legal Ada name from a C NAME, returning a malloc'd string.
1002    SPACE_FOUND, if not NULL, is used to indicate whether a space was found in
1003    NAME.  */
1004
1005 static char *
1006 to_ada_name (const char *name, int *space_found)
1007 {
1008   const char **names;
1009   int len = strlen (name);
1010   int j, len2 = 0;
1011   int found = false;
1012   char *s = XNEWVEC (char, len * 2 + 5);
1013   char c;
1014
1015   if (space_found)
1016     *space_found = false;
1017
1018   /* Add trailing "c_" if name is an Ada reserved word.  */
1019   for (names = ada_reserved; *names; names++)
1020     if (!strcasecmp (name, *names))
1021       {
1022         s[len2++] = 'c';
1023         s[len2++] = '_';
1024         found = true;
1025         break;
1026       }
1027
1028   if (!found)
1029     /* Add trailing "c_" if name is an potential case sensitive duplicate.  */
1030     for (names = c_duplicates; *names; names++)
1031       if (!strcmp (name, *names))
1032         {
1033           s[len2++] = 'c';
1034           s[len2++] = '_';
1035           found = true;
1036           break;
1037         }
1038
1039   for (j = 0; name[j] == '_'; j++)
1040     s[len2++] = 'u';
1041
1042   if (j > 0)
1043     s[len2++] = '_';
1044   else if (*name == '.' || *name == '$')
1045     {
1046       s[0] = 'a';
1047       s[1] = 'n';
1048       s[2] = 'o';
1049       s[3] = 'n';
1050       len2 = 4;
1051       j++;
1052     }
1053
1054   /* Replace unsuitable characters for Ada identifiers.  */
1055
1056   for (; j < len; j++)
1057     switch (name[j])
1058       {
1059         case ' ':
1060           if (space_found)
1061             *space_found = true;
1062           s[len2++] = '_';
1063           break;
1064
1065         /* ??? missing some C++ operators.  */
1066         case '=':
1067           s[len2++] = '_';
1068
1069           if (name[j + 1] == '=')
1070             {
1071               j++;
1072               s[len2++] = 'e';
1073               s[len2++] = 'q';
1074             }
1075           else
1076             {
1077               s[len2++] = 'a';
1078               s[len2++] = 's';
1079             }
1080           break;
1081
1082         case '!':
1083           s[len2++] = '_';
1084           if (name[j + 1] == '=')
1085             {
1086               j++;
1087               s[len2++] = 'n';
1088               s[len2++] = 'e';
1089             }
1090           break;
1091
1092         case '~':
1093           s[len2++] = '_';
1094           s[len2++] = 't';
1095           s[len2++] = 'i';
1096           break;
1097
1098         case '&':
1099         case '|':
1100         case '^':
1101           s[len2++] = '_';
1102           s[len2++] = name[j] == '&' ? 'a' : name[j] == '|' ? 'o' : 'x';
1103
1104           if (name[j + 1] == '=')
1105             {
1106               j++;
1107               s[len2++] = 'e';
1108             }
1109           break;
1110
1111         case '+':
1112         case '-':
1113         case '*':
1114         case '/':
1115         case '(':
1116         case '[':
1117           if (s[len2 - 1] != '_')
1118             s[len2++] = '_';
1119
1120           switch (name[j + 1]) {
1121             case '\0':
1122               j++;
1123               switch (name[j - 1]) {
1124                 case '+': s[len2++] = 'p'; break;  /* + */
1125                 case '-': s[len2++] = 'm'; break;  /* - */
1126                 case '*': s[len2++] = 't'; break;  /* * */
1127                 case '/': s[len2++] = 'd'; break;  /* / */
1128               }
1129               break;
1130
1131             case '=':
1132               j++;
1133               switch (name[j - 1]) {
1134                 case '+': s[len2++] = 'p'; break;  /* += */
1135                 case '-': s[len2++] = 'm'; break;  /* -= */
1136                 case '*': s[len2++] = 't'; break;  /* *= */
1137                 case '/': s[len2++] = 'd'; break;  /* /= */
1138               }
1139               s[len2++] = 'a';
1140               break;
1141
1142             case '-':  /* -- */
1143               j++;
1144               s[len2++] = 'm';
1145               s[len2++] = 'm';
1146               break;
1147
1148             case '+':  /* ++ */
1149               j++;
1150               s[len2++] = 'p';
1151               s[len2++] = 'p';
1152               break;
1153
1154             case ')':  /* () */
1155               j++;
1156               s[len2++] = 'o';
1157               s[len2++] = 'p';
1158               break;
1159
1160             case ']':  /* [] */
1161               j++;
1162               s[len2++] = 'o';
1163               s[len2++] = 'b';
1164               break;
1165           }
1166
1167           break;
1168
1169         case '<':
1170         case '>':
1171           c = name[j] == '<' ? 'l' : 'g';
1172           s[len2++] = '_';
1173
1174           switch (name[j + 1]) {
1175             case '\0':
1176               s[len2++] = c;
1177               s[len2++] = 't';
1178               break;
1179             case '=':
1180               j++;
1181               s[len2++] = c;
1182               s[len2++] = 'e';
1183               break;
1184             case '>':
1185               j++;
1186               s[len2++] = 's';
1187               s[len2++] = 'r';
1188               break;
1189             case '<':
1190               j++;
1191               s[len2++] = 's';
1192               s[len2++] = 'l';
1193               break;
1194             default:
1195               break;
1196           }
1197           break;
1198
1199         case '_':
1200           if (len2 && s[len2 - 1] == '_')
1201             s[len2++] = 'u';
1202           /* fall through */
1203
1204         default:
1205           s[len2++] = name[j];
1206       }
1207
1208   if (s[len2 - 1] == '_')
1209     s[len2++] = 'u';
1210
1211   s[len2] = '\0';
1212
1213   return s;
1214 }
1215
1216 /* Return true if DECL refers to a C++ class type for which a
1217    separate enclosing package has been or should be generated.  */
1218
1219 static bool
1220 separate_class_package (tree decl)
1221 {
1222   tree type = TREE_TYPE (decl);
1223   return has_nontrivial_methods (type) || has_static_fields (type);
1224 }
1225
1226 static bool package_prefix = true;
1227
1228 /* Dump in BUFFER the name of an identifier NODE of type TYPE, following Ada
1229    syntax.  LIMITED_ACCESS indicates whether NODE can be accessed via a limited
1230    'with' clause rather than a regular 'with' clause.  */
1231
1232 static void
1233 pp_ada_tree_identifier (pretty_printer *buffer, tree node, tree type,
1234                         int limited_access)
1235 {
1236   const char *name = IDENTIFIER_POINTER (node);
1237   int space_found = false;
1238   char *s = to_ada_name (name, &space_found);
1239   tree decl;
1240
1241   /* If the entity is a type and comes from another file, generate "package"
1242      prefix.  */
1243   decl = get_underlying_decl (type);
1244
1245   if (decl)
1246     {
1247       expanded_location xloc = expand_location (decl_sloc (decl, false));
1248
1249       if (xloc.file && xloc.line)
1250         {
1251           if (xloc.file != source_file_base)
1252             {
1253               switch (TREE_CODE (type))
1254                 {
1255                   case ENUMERAL_TYPE:
1256                   case INTEGER_TYPE:
1257                   case REAL_TYPE:
1258                   case FIXED_POINT_TYPE:
1259                   case BOOLEAN_TYPE:
1260                   case REFERENCE_TYPE:
1261                   case POINTER_TYPE:
1262                   case ARRAY_TYPE:
1263                   case RECORD_TYPE:
1264                   case UNION_TYPE:
1265                   case QUAL_UNION_TYPE:
1266                   case TYPE_DECL:
1267                     if (package_prefix)
1268                       {
1269                         char *s1 = get_ada_package (xloc.file);
1270                         append_withs (s1, limited_access);
1271                         pp_string (buffer, s1);
1272                         pp_dot (buffer);
1273                         free (s1);
1274                       }
1275                     break;
1276                   default:
1277                     break;
1278                 }
1279
1280               /* Generate the additional package prefix for C++ classes.  */
1281               if (separate_class_package (decl))
1282                 {
1283                   pp_string (buffer, "Class_");
1284                   pp_string (buffer, s);
1285                   pp_dot (buffer);
1286                 }
1287              }
1288         }
1289     }
1290
1291   if (space_found)
1292     if (!strcmp (s, "short_int"))
1293       pp_string (buffer, "short");
1294     else if (!strcmp (s, "short_unsigned_int"))
1295       pp_string (buffer, "unsigned_short");
1296     else if (!strcmp (s, "unsigned_int"))
1297       pp_string (buffer, "unsigned");
1298     else if (!strcmp (s, "long_int"))
1299       pp_string (buffer, "long");
1300     else if (!strcmp (s, "long_unsigned_int"))
1301       pp_string (buffer, "unsigned_long");
1302     else if (!strcmp (s, "long_long_int"))
1303       pp_string (buffer, "Long_Long_Integer");
1304     else if (!strcmp (s, "long_long_unsigned_int"))
1305       {
1306         if (package_prefix)
1307           {
1308             append_withs ("Interfaces.C.Extensions", false);
1309             pp_string (buffer, "Extensions.unsigned_long_long");
1310           }
1311         else
1312           pp_string (buffer, "unsigned_long_long");
1313       }
1314     else
1315       pp_string(buffer, s);
1316   else
1317     if (!strcmp (s, "bool"))
1318       {
1319         if (package_prefix)
1320           {
1321             append_withs ("Interfaces.C.Extensions", false);
1322             pp_string (buffer, "Extensions.bool");
1323           }
1324         else
1325           pp_string (buffer, "bool");
1326       }
1327     else
1328       pp_string(buffer, s);
1329
1330   free (s);
1331 }
1332
1333 /* Dump in BUFFER the assembly name of T.  */
1334
1335 static void
1336 pp_asm_name (pretty_printer *buffer, tree t)
1337 {
1338   tree name = DECL_ASSEMBLER_NAME (t);
1339   char *ada_name = XALLOCAVEC (char, IDENTIFIER_LENGTH (name) + 1), *s;
1340   const char *ident = IDENTIFIER_POINTER (name);
1341
1342   for (s = ada_name; *ident; ident++)
1343     {
1344       if (*ident == ' ')
1345         break;
1346       else if (*ident != '*')
1347         *s++ = *ident;
1348     }
1349
1350   *s = '\0';
1351   pp_string (buffer, ada_name);
1352 }
1353
1354 /* Dump in BUFFER the name of a DECL node if set, following Ada syntax.
1355    LIMITED_ACCESS indicates whether NODE can be accessed via a limited
1356    'with' clause rather than a regular 'with' clause.  */
1357
1358 static void
1359 dump_ada_decl_name (pretty_printer *buffer, tree decl, int limited_access)
1360 {
1361   if (DECL_NAME (decl))
1362     pp_ada_tree_identifier (buffer, DECL_NAME (decl), decl, limited_access);
1363   else
1364     {
1365       tree type_name = TYPE_NAME (TREE_TYPE (decl));
1366
1367       if (!type_name)
1368         {
1369           pp_string (buffer, "anon");
1370           if (TREE_CODE (decl) == FIELD_DECL)
1371             pp_scalar (buffer, "%d", DECL_UID (decl));
1372           else
1373             pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (decl)));
1374         }
1375       else if (TREE_CODE (type_name) == IDENTIFIER_NODE)
1376         pp_ada_tree_identifier (buffer, type_name, decl, limited_access);
1377     }
1378 }
1379
1380 /* Dump in BUFFER a name based on both T1 and T2, followed by S.  */
1381
1382 static void
1383 dump_ada_double_name (pretty_printer *buffer, tree t1, tree t2, const char *s)
1384 {
1385   if (DECL_NAME (t1))
1386     pp_ada_tree_identifier (buffer, DECL_NAME (t1), t1, false);
1387   else
1388     {
1389       pp_string (buffer, "anon");
1390       pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t1)));
1391     }
1392
1393   pp_underscore (buffer);
1394
1395   if (DECL_NAME (t1))
1396     pp_ada_tree_identifier (buffer, DECL_NAME (t2), t2, false);
1397   else
1398     {
1399       pp_string (buffer, "anon");
1400       pp_scalar (buffer, "%d", TYPE_UID (TREE_TYPE (t2)));
1401     }
1402
1403   pp_string (buffer, s);
1404 }
1405
1406 /* Dump in BUFFER pragma Import C/CPP on a given node T.  */
1407
1408 static void
1409 dump_ada_import (pretty_printer *buffer, tree t)
1410 {
1411   const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (t));
1412   int is_stdcall = TREE_CODE (t) == FUNCTION_DECL &&
1413     lookup_attribute ("stdcall", TYPE_ATTRIBUTES (TREE_TYPE (t)));
1414
1415   if (is_stdcall)
1416     pp_string (buffer, "pragma Import (Stdcall, ");
1417   else if (name[0] == '_' && name[1] == 'Z')
1418     pp_string (buffer, "pragma Import (CPP, ");
1419   else
1420     pp_string (buffer, "pragma Import (C, ");
1421
1422   dump_ada_decl_name (buffer, t, false);
1423   pp_string (buffer, ", \"");
1424
1425   if (is_stdcall)
1426     pp_string (buffer, IDENTIFIER_POINTER (DECL_NAME (t)));
1427   else
1428     pp_asm_name (buffer, t);
1429
1430   pp_string (buffer, "\");");
1431 }
1432
1433 /* Check whether T and its type have different names, and append "the_"
1434    otherwise in BUFFER.  */
1435
1436 static void
1437 check_name (pretty_printer *buffer, tree t)
1438 {
1439   const char *s;
1440   tree tmp = TREE_TYPE (t);
1441
1442   while (TREE_CODE (tmp) == POINTER_TYPE && !TYPE_NAME (tmp))
1443     tmp = TREE_TYPE (tmp);
1444
1445   if (TREE_CODE (tmp) != FUNCTION_TYPE)
1446     {
1447       if (TREE_CODE (tmp) == IDENTIFIER_NODE)
1448         s = IDENTIFIER_POINTER (tmp);
1449       else if (!TYPE_NAME (tmp))
1450         s = "";
1451       else if (TREE_CODE (TYPE_NAME (tmp)) == IDENTIFIER_NODE)
1452         s = IDENTIFIER_POINTER (TYPE_NAME (tmp));
1453       else
1454         s = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp)));
1455
1456       if (!strcasecmp (IDENTIFIER_POINTER (DECL_NAME (t)), s))
1457         pp_string (buffer, "the_");
1458     }
1459 }
1460
1461 /* Dump in BUFFER a function declaration FUNC with Ada syntax.
1462    IS_METHOD indicates whether FUNC is a C++ method.
1463    IS_CONSTRUCTOR whether FUNC is a C++ constructor.
1464    IS_DESTRUCTOR whether FUNC is a C++ destructor.
1465    SPC is the current indentation level.  */
1466
1467 static int
1468 dump_ada_function_declaration (pretty_printer *buffer, tree func,
1469                                int is_method, int is_constructor,
1470                                int is_destructor, int spc)
1471 {
1472   tree arg;
1473   const tree node = TREE_TYPE (func);
1474   char buf[16];
1475   int num = 0, num_args = 0, have_args = true, have_ellipsis = false;
1476
1477   /* Compute number of arguments.  */
1478   arg = TYPE_ARG_TYPES (node);
1479
1480   if (arg)
1481     {
1482       while (TREE_CHAIN (arg) && arg != error_mark_node)
1483         {
1484           num_args++;
1485           arg = TREE_CHAIN (arg);
1486         }
1487
1488       if (TREE_CODE (TREE_VALUE (arg)) != VOID_TYPE)
1489         {
1490           num_args++;
1491           have_ellipsis = true;
1492         }
1493     }
1494
1495   if (is_constructor)
1496     num_args--;
1497
1498   if (is_destructor)
1499     num_args = 1;
1500
1501   if (num_args > 2)
1502     newline_and_indent (buffer, spc + 1);
1503
1504   if (num_args > 0)
1505     {
1506       pp_space (buffer);
1507       pp_left_paren (buffer);
1508     }
1509
1510   if (TREE_CODE (func) == FUNCTION_DECL)
1511     arg = DECL_ARGUMENTS (func);
1512   else
1513     arg = NULL_TREE;
1514
1515   if (arg == NULL_TREE)
1516     {
1517       have_args = false;
1518       arg = TYPE_ARG_TYPES (node);
1519
1520       if (arg && TREE_CODE (TREE_VALUE (arg)) == VOID_TYPE)
1521         arg = NULL_TREE;
1522     }
1523
1524   if (is_constructor)
1525     arg = TREE_CHAIN (arg);
1526
1527   /* Print the argument names (if available) & types.  */
1528
1529   for (num = 1; num <= num_args; num++)
1530     {
1531       if (have_args)
1532         {
1533           if (DECL_NAME (arg))
1534             {
1535               check_name (buffer, arg);
1536               pp_ada_tree_identifier (buffer, DECL_NAME (arg), 0, false);
1537               pp_string (buffer, " : ");
1538             }
1539           else
1540             {
1541               sprintf (buf, "arg%d : ", num);
1542               pp_string (buffer, buf);
1543             }
1544
1545           dump_generic_ada_node (buffer, TREE_TYPE (arg), node, spc, 0, true);
1546         }
1547       else
1548         {
1549           sprintf (buf, "arg%d : ", num);
1550           pp_string (buffer, buf);
1551           dump_generic_ada_node (buffer, TREE_VALUE (arg), node, spc, 0, true);
1552         }
1553
1554       if (TREE_TYPE (arg) && TREE_TYPE (TREE_TYPE (arg))
1555           && is_tagged_type (TREE_TYPE (TREE_TYPE (arg))))
1556         {
1557           if (!is_method
1558               || (num != 1 || (!DECL_VINDEX (func) && !is_constructor)))
1559             pp_string (buffer, "'Class");
1560         }
1561
1562       arg = TREE_CHAIN (arg);
1563
1564       if (num < num_args)
1565         {
1566           pp_semicolon (buffer);
1567
1568           if (num_args > 2)
1569             newline_and_indent (buffer, spc + INDENT_INCR);
1570           else
1571             pp_space (buffer);
1572         }
1573     }
1574
1575   if (have_ellipsis)
1576     {
1577       pp_string (buffer, "  -- , ...");
1578       newline_and_indent (buffer, spc + INDENT_INCR);
1579     }
1580
1581   if (num_args > 0)
1582     pp_right_paren (buffer);
1583   return num_args;
1584 }
1585
1586 /* Dump in BUFFER all the domains associated with an array NODE,
1587    using Ada syntax.  SPC is the current indentation level.  */
1588
1589 static void
1590 dump_ada_array_domains (pretty_printer *buffer, tree node, int spc)
1591 {
1592   int first = 1;
1593   pp_left_paren (buffer);
1594
1595   for (; TREE_CODE (node) == ARRAY_TYPE; node = TREE_TYPE (node))
1596     {
1597       tree domain = TYPE_DOMAIN (node);
1598
1599       if (domain)
1600         {
1601           tree min = TYPE_MIN_VALUE (domain);
1602           tree max = TYPE_MAX_VALUE (domain);
1603
1604           if (!first)
1605             pp_string (buffer, ", ");
1606           first = 0;
1607
1608           if (min)
1609             dump_generic_ada_node (buffer, min, NULL_TREE, spc, 0, true);
1610           pp_string (buffer, " .. ");
1611
1612           /* If the upper bound is zero, gcc may generate a NULL_TREE
1613              for TYPE_MAX_VALUE rather than an integer_cst.  */
1614           if (max)
1615             dump_generic_ada_node (buffer, max, NULL_TREE, spc, 0, true);
1616           else
1617             pp_string (buffer, "0");
1618         }
1619       else
1620         pp_string (buffer, "size_t");
1621     }
1622   pp_right_paren (buffer);
1623 }
1624
1625 /* Dump in BUFFER file:line information related to NODE.  */
1626
1627 static void
1628 dump_sloc (pretty_printer *buffer, tree node)
1629 {
1630   expanded_location xloc;
1631
1632   xloc.file = NULL;
1633
1634   if (TREE_CODE_CLASS (TREE_CODE (node)) == tcc_declaration)
1635     xloc = expand_location (DECL_SOURCE_LOCATION (node));
1636   else if (EXPR_HAS_LOCATION (node))
1637     xloc = expand_location (EXPR_LOCATION (node));
1638
1639   if (xloc.file)
1640     {
1641       pp_string (buffer, xloc.file);
1642       pp_colon (buffer);
1643       pp_decimal_int (buffer, xloc.line);
1644     }
1645 }
1646
1647 /* Return true if T designates a one dimension array of "char".  */
1648
1649 static bool
1650 is_char_array (tree t)
1651 {
1652   tree tmp;
1653   int num_dim = 0;
1654
1655   /* Retrieve array's type.  */
1656   tmp = t;
1657   while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1658     {
1659       num_dim++;
1660       tmp = TREE_TYPE (tmp);
1661     }
1662
1663   tmp = TREE_TYPE (tmp);
1664   return num_dim == 1 && TREE_CODE (tmp) == INTEGER_TYPE
1665     && !strcmp (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (tmp))), "char");
1666 }
1667
1668 /* Dump in BUFFER an array type T in Ada syntax.  Assume that the "type"
1669    keyword and name have already been printed.  SPC is the indentation
1670    level.  */
1671
1672 static void
1673 dump_ada_array_type (pretty_printer *buffer, tree t, int spc)
1674 {
1675   tree tmp;
1676   bool char_array = is_char_array (t);
1677
1678   /* Special case char arrays.  */
1679   if (char_array)
1680     {
1681       pp_string (buffer, "Interfaces.C.char_array ");
1682     }
1683   else
1684     pp_string (buffer, "array ");
1685
1686   /* Print the dimensions.  */
1687   dump_ada_array_domains (buffer, TREE_TYPE (t), spc);
1688
1689   /* Retrieve array's type.  */
1690   tmp = TREE_TYPE (t);
1691   while (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1692     tmp = TREE_TYPE (tmp);
1693
1694   /* Print array's type.  */
1695   if (!char_array)
1696     {
1697       pp_string (buffer, " of ");
1698
1699       if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE)
1700         pp_string (buffer, "aliased ");
1701
1702       dump_generic_ada_node
1703         (buffer, TREE_TYPE (tmp), TREE_TYPE (t), spc, false, true);
1704     }
1705 }
1706
1707 /* Dump in BUFFER type names associated with a template, each prepended with
1708    '_'.  TYPES is the TREE_PURPOSE of a DECL_TEMPLATE_INSTANTIATIONS.  SPC is
1709    the indentation level.  */
1710
1711 static void
1712 dump_template_types (pretty_printer *buffer, tree types, int spc)
1713 {
1714   size_t i;
1715   size_t len = TREE_VEC_LENGTH (types);
1716
1717   for (i = 0; i < len; i++)
1718     {
1719       tree elem = TREE_VEC_ELT (types, i);
1720       pp_underscore (buffer);
1721       if (!dump_generic_ada_node (buffer, elem, 0, spc, false, true))
1722         {
1723           pp_string (buffer, "unknown");
1724           pp_scalar (buffer, "%lu", (unsigned long) TREE_HASH (elem));
1725         }
1726     }
1727 }
1728
1729 /* Dump in BUFFER the contents of all class instantiations associated with
1730    a given template T.  SPC is the indentation level.  */
1731
1732 static int
1733 dump_ada_template (pretty_printer *buffer, tree t, int spc)
1734 {
1735   /* DECL_VINDEX is DECL_TEMPLATE_INSTANTIATIONS in this context.  */
1736   tree inst = DECL_VINDEX (t);
1737   /* DECL_RESULT_FLD is DECL_TEMPLATE_RESULT in this context.  */
1738   tree result = DECL_RESULT_FLD (t);
1739   int num_inst = 0;
1740
1741   /* Don't look at template declarations declaring something coming from
1742      another file.  This can occur for template friend declarations.  */
1743   if (LOCATION_FILE (decl_sloc (result, false))
1744       != LOCATION_FILE (decl_sloc (t, false)))
1745     return 0;
1746
1747   while (inst && inst != error_mark_node)
1748     {
1749       tree types = TREE_PURPOSE (inst);
1750       tree instance = TREE_VALUE (inst);
1751
1752       if (TREE_VEC_LENGTH (types) == 0)
1753         break;
1754
1755       if (!TYPE_P (instance) || !TYPE_METHODS (instance))
1756         break;
1757
1758       num_inst++;
1759       INDENT (spc);
1760       pp_string (buffer, "package ");
1761       package_prefix = false;
1762       dump_generic_ada_node (buffer, instance, t, spc, false, true);
1763       dump_template_types (buffer, types, spc);
1764       pp_string (buffer, " is");
1765       spc += INDENT_INCR;
1766       newline_and_indent (buffer, spc);
1767
1768       TREE_VISITED (get_underlying_decl (instance)) = 1;
1769       pp_string (buffer, "type ");
1770       dump_generic_ada_node (buffer, instance, t, spc, false, true);
1771       package_prefix = true;
1772
1773       if (is_tagged_type (instance))
1774         pp_string (buffer, " is tagged limited ");
1775       else
1776         pp_string (buffer, " is limited ");
1777
1778       dump_generic_ada_node (buffer, instance, t, spc, false, false);
1779       pp_newline (buffer);
1780       spc -= INDENT_INCR;
1781       newline_and_indent (buffer, spc);
1782
1783       pp_string (buffer, "end;");
1784       newline_and_indent (buffer, spc);
1785       pp_string (buffer, "use ");
1786       package_prefix = false;
1787       dump_generic_ada_node (buffer, instance, t, spc, false, true);
1788       dump_template_types (buffer, types, spc);
1789       package_prefix = true;
1790       pp_semicolon (buffer);
1791       pp_newline (buffer);
1792       pp_newline (buffer);
1793
1794       inst = TREE_CHAIN (inst);
1795     }
1796
1797   return num_inst > 0;
1798 }
1799
1800 /* Return true if NODE is a simple enum types, that can be mapped to an
1801    Ada enum type directly.  */
1802
1803 static bool
1804 is_simple_enum (tree node)
1805 {
1806   HOST_WIDE_INT count = 0;
1807   tree value;
1808
1809   for (value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
1810     {
1811       tree int_val = TREE_VALUE (value);
1812
1813       if (TREE_CODE (int_val) != INTEGER_CST)
1814         int_val = DECL_INITIAL (int_val);
1815
1816       if (!tree_fits_shwi_p (int_val))
1817         return false;
1818       else if (tree_to_shwi (int_val) != count)
1819         return false;
1820
1821       count++;
1822     }
1823
1824   return true;
1825 }
1826
1827 static bool in_function = true;
1828 static bool bitfield_used = false;
1829
1830 /* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
1831    TYPE.  SPC is the indentation level.  LIMITED_ACCESS indicates whether NODE
1832    can be referenced via a "limited with" clause.  NAME_ONLY indicates whether
1833    we should only dump the name of NODE, instead of its full declaration.  */
1834
1835 static int
1836 dump_generic_ada_node (pretty_printer *buffer, tree node, tree type, int spc,
1837                        int limited_access, bool name_only)
1838 {
1839   if (node == NULL_TREE)
1840     return 0;
1841
1842   switch (TREE_CODE (node))
1843     {
1844     case ERROR_MARK:
1845       pp_string (buffer, "<<< error >>>");
1846       return 0;
1847
1848     case IDENTIFIER_NODE:
1849       pp_ada_tree_identifier (buffer, node, type, limited_access);
1850       break;
1851
1852     case TREE_LIST:
1853       pp_string (buffer, "--- unexpected node: TREE_LIST");
1854       return 0;
1855
1856     case TREE_BINFO:
1857       dump_generic_ada_node
1858         (buffer, BINFO_TYPE (node), type, spc, limited_access, name_only);
1859
1860     case TREE_VEC:
1861       pp_string (buffer, "--- unexpected node: TREE_VEC");
1862       return 0;
1863
1864     case VOID_TYPE:
1865       if (package_prefix)
1866         {
1867           append_withs ("System", false);
1868           pp_string (buffer, "System.Address");
1869         }
1870       else
1871         pp_string (buffer, "address");
1872       break;
1873
1874     case VECTOR_TYPE:
1875       pp_string (buffer, "<vector>");
1876       break;
1877
1878     case COMPLEX_TYPE:
1879       pp_string (buffer, "<complex>");
1880       break;
1881
1882     case ENUMERAL_TYPE:
1883       if (name_only)
1884         dump_generic_ada_node
1885           (buffer, TYPE_NAME (node), node, spc, 0, true);
1886       else
1887         {
1888           tree value = TYPE_VALUES (node);
1889
1890           if (is_simple_enum (node))
1891             {
1892               bool first = true;
1893               spc += INDENT_INCR;
1894               newline_and_indent (buffer, spc - 1);
1895               pp_left_paren (buffer);
1896               for (; value; value = TREE_CHAIN (value))
1897                 {
1898                   if (first)
1899                     first = false;
1900                   else
1901                     {
1902                       pp_comma (buffer);
1903                       newline_and_indent (buffer, spc);
1904                     }
1905
1906                   pp_ada_tree_identifier
1907                     (buffer, TREE_PURPOSE (value), node, false);
1908                 }
1909               pp_string (buffer, ");");
1910               spc -= INDENT_INCR;
1911               newline_and_indent (buffer, spc);
1912               pp_string (buffer, "pragma Convention (C, ");
1913               dump_generic_ada_node
1914                 (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
1915                  spc, 0, true);
1916               pp_right_paren (buffer);
1917             }
1918           else
1919             {
1920               pp_string (buffer, "unsigned");
1921               for (; value; value = TREE_CHAIN (value))
1922                 {
1923                   pp_semicolon (buffer);
1924                   newline_and_indent (buffer, spc);
1925
1926                   pp_ada_tree_identifier
1927                     (buffer, TREE_PURPOSE (value), node, false);
1928                   pp_string (buffer, " : constant ");
1929
1930                   dump_generic_ada_node
1931                     (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
1932                      spc, 0, true);
1933
1934                   pp_string (buffer, " := ");
1935                   dump_generic_ada_node
1936                     (buffer,
1937                      TREE_CODE (TREE_VALUE (value)) == INTEGER_CST ?
1938                        TREE_VALUE (value) : DECL_INITIAL (TREE_VALUE (value)),
1939                      node, spc, false, true);
1940                 }
1941             }
1942         }
1943       break;
1944
1945     case INTEGER_TYPE:
1946     case REAL_TYPE:
1947     case FIXED_POINT_TYPE:
1948     case BOOLEAN_TYPE:
1949       {
1950         enum tree_code_class tclass;
1951
1952         tclass = TREE_CODE_CLASS (TREE_CODE (node));
1953
1954         if (tclass == tcc_declaration)
1955           {
1956             if (DECL_NAME (node))
1957               pp_ada_tree_identifier
1958                 (buffer, DECL_NAME (node), 0, limited_access);
1959             else
1960               pp_string (buffer, "<unnamed type decl>");
1961           }
1962         else if (tclass == tcc_type)
1963           {
1964             if (TYPE_NAME (node))
1965               {
1966                 if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE)
1967                   pp_ada_tree_identifier (buffer, TYPE_NAME (node),
1968                                           node, limited_access);
1969                 else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
1970                          && DECL_NAME (TYPE_NAME (node)))
1971                   dump_ada_decl_name (buffer, TYPE_NAME (node), limited_access);
1972                 else
1973                   pp_string (buffer, "<unnamed type>");
1974               }
1975             else if (TREE_CODE (node) == INTEGER_TYPE)
1976               {
1977                 append_withs ("Interfaces.C.Extensions", false);
1978                 bitfield_used = true;
1979
1980                 if (TYPE_PRECISION (node) == 1)
1981                   pp_string (buffer, "Extensions.Unsigned_1");
1982                 else
1983                   {
1984                     pp_string (buffer, (TYPE_UNSIGNED (node)
1985                                         ? "Extensions.Unsigned_"
1986                                         : "Extensions.Signed_"));
1987                     pp_decimal_int (buffer, TYPE_PRECISION (node));
1988                   }
1989               }
1990             else
1991               pp_string (buffer, "<unnamed type>");
1992           }
1993         break;
1994       }
1995
1996     case POINTER_TYPE:
1997     case REFERENCE_TYPE:
1998       if (name_only && TYPE_NAME (node))
1999         dump_generic_ada_node
2000           (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2001
2002       else if (TREE_CODE (TREE_TYPE (node)) == FUNCTION_TYPE)
2003         {
2004           tree fnode = TREE_TYPE (node);
2005           bool is_function;
2006           bool prev_in_function = in_function;
2007
2008           if (VOID_TYPE_P (TREE_TYPE (fnode)))
2009             {
2010               is_function = false;
2011               pp_string (buffer, "access procedure");
2012             }
2013           else
2014             {
2015               is_function = true;
2016               pp_string (buffer, "access function");
2017             }
2018
2019           in_function = is_function;
2020           dump_ada_function_declaration
2021             (buffer, node, false, false, false, spc + INDENT_INCR);
2022           in_function = prev_in_function;
2023
2024           if (is_function)
2025             {
2026               pp_string (buffer, " return ");
2027               dump_generic_ada_node
2028                 (buffer, TREE_TYPE (fnode), type, spc, 0, true);
2029             }
2030
2031             /* If we are dumping the full type, it means we are part of a
2032                type definition and need also a Convention C pragma.  */
2033             if (!name_only)
2034               {
2035                 pp_semicolon (buffer);
2036                 newline_and_indent (buffer, spc);
2037                 pp_string (buffer, "pragma Convention (C, ");
2038                 dump_generic_ada_node
2039                   (buffer, type, 0, spc, false, true);
2040                 pp_right_paren (buffer);
2041               }
2042         }
2043       else
2044         {
2045           int is_access = false;
2046           unsigned int quals = TYPE_QUALS (TREE_TYPE (node));
2047
2048           if (VOID_TYPE_P (TREE_TYPE (node)))
2049             {
2050               if (!name_only)
2051                 pp_string (buffer, "new ");
2052               if (package_prefix)
2053                 {
2054                   append_withs ("System", false);
2055                   pp_string (buffer, "System.Address");
2056                 }
2057               else
2058                 pp_string (buffer, "address");
2059             }
2060           else
2061             {
2062               if (TREE_CODE (node) == POINTER_TYPE
2063                   && TREE_CODE (TREE_TYPE (node)) == INTEGER_TYPE
2064                   && !strcmp
2065                         (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME
2066                           (TREE_TYPE (node)))), "char"))
2067                 {
2068                   if (!name_only)
2069                     pp_string (buffer, "new ");
2070
2071                   if (package_prefix)
2072                     {
2073                       pp_string (buffer, "Interfaces.C.Strings.chars_ptr");
2074                       append_withs ("Interfaces.C.Strings", false);
2075                     }
2076                   else
2077                     pp_string (buffer, "chars_ptr");
2078                 }
2079               else
2080                 {
2081                   /* For now, handle all access-to-access or
2082                      access-to-unknown-structs as opaque system.address.  */
2083
2084                   tree type_name = TYPE_NAME (TREE_TYPE (node));
2085                   const_tree typ2 = !type ||
2086                     DECL_P (type) ? type : TYPE_NAME (type);
2087                   const_tree underlying_type =
2088                     get_underlying_decl (TREE_TYPE (node));
2089
2090                   if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE
2091                       /* Pointer to pointer.  */
2092
2093                       || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
2094                           && (!underlying_type
2095                               || !TYPE_FIELDS (TREE_TYPE (underlying_type))))
2096                       /* Pointer to opaque structure.  */
2097
2098                       || underlying_type == NULL_TREE
2099                       || (!typ2
2100                           && !TREE_VISITED (underlying_type)
2101                           && !TREE_VISITED (type_name)
2102                           && !is_tagged_type (TREE_TYPE (node))
2103                           && DECL_SOURCE_FILE (underlying_type)
2104                                == source_file_base)
2105                       || (type_name && typ2
2106                           && DECL_P (underlying_type)
2107                           && DECL_P (typ2)
2108                           && decl_sloc (underlying_type, true)
2109                                > decl_sloc (typ2, true)
2110                           && DECL_SOURCE_FILE (underlying_type)
2111                                == DECL_SOURCE_FILE (typ2)))
2112                     {
2113                       if (package_prefix)
2114                         {
2115                           append_withs ("System", false);
2116                           if (!name_only)
2117                             pp_string (buffer, "new ");
2118                           pp_string (buffer, "System.Address");
2119                         }
2120                       else
2121                         pp_string (buffer, "address");
2122                       return spc;
2123                     }
2124
2125                   if (!package_prefix)
2126                     pp_string (buffer, "access");
2127                   else if (AGGREGATE_TYPE_P (TREE_TYPE (node)))
2128                     {
2129                       if (!type || TREE_CODE (type) != FUNCTION_DECL)
2130                         {
2131                           pp_string (buffer, "access ");
2132                           is_access = true;
2133
2134                           if (quals & TYPE_QUAL_CONST)
2135                             pp_string (buffer, "constant ");
2136                           else if (!name_only)
2137                             pp_string (buffer, "all ");
2138                         }
2139                       else if (quals & TYPE_QUAL_CONST)
2140                         pp_string (buffer, "in ");
2141                       else if (in_function)
2142                         {
2143                           is_access = true;
2144                           pp_string (buffer, "access ");
2145                         }
2146                       else
2147                         {
2148                           is_access = true;
2149                           pp_string (buffer, "access ");
2150                           /* ??? should be configurable: access or in out.  */
2151                         }
2152                     }
2153                   else
2154                     {
2155                       is_access = true;
2156                       pp_string (buffer, "access ");
2157
2158                       if (!name_only)
2159                         pp_string (buffer, "all ");
2160                     }
2161
2162                   if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
2163                       && type_name != NULL_TREE)
2164                     dump_generic_ada_node
2165                       (buffer, type_name,
2166                        TREE_TYPE (node), spc, is_access, true);
2167                   else
2168                     dump_generic_ada_node
2169                       (buffer, TREE_TYPE (node), TREE_TYPE (node),
2170                        spc, 0, true);
2171                 }
2172             }
2173         }
2174       break;
2175
2176     case ARRAY_TYPE:
2177       if (name_only)
2178         dump_generic_ada_node
2179           (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2180       else
2181         dump_ada_array_type (buffer, node, spc);
2182       break;
2183
2184     case RECORD_TYPE:
2185     case UNION_TYPE:
2186     case QUAL_UNION_TYPE:
2187       if (name_only)
2188         {
2189           if (TYPE_NAME (node))
2190             dump_generic_ada_node
2191               (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2192           else
2193             {
2194               pp_string (buffer, "anon_");
2195               pp_scalar (buffer, "%d", TYPE_UID (node));
2196             }
2197         }
2198       else
2199         print_ada_struct_decl (buffer, node, type, spc, true);
2200       break;
2201
2202     case INTEGER_CST:
2203       /* We treat the upper half of the sizetype range as negative.  This
2204          is consistent with the internal treatment and makes it possible
2205          to generate the (0 .. -1) range for flexible array members.  */
2206       if (TREE_TYPE (node) == sizetype)
2207         node = fold_convert (ssizetype, node);
2208       if (tree_fits_shwi_p (node))
2209         pp_wide_integer (buffer, tree_to_shwi (node));
2210       else if (tree_fits_uhwi_p (node))
2211         pp_unsigned_wide_integer (buffer, tree_to_uhwi (node));
2212       else
2213         {
2214           tree val = node;
2215           unsigned HOST_WIDE_INT low = TREE_INT_CST_LOW (val);
2216           HOST_WIDE_INT high = TREE_INT_CST_HIGH (val);
2217
2218           if (tree_int_cst_sgn (val) < 0)
2219             {
2220               pp_minus (buffer);
2221               high = ~high + !low;
2222               low = -low;
2223             }
2224           sprintf (pp_buffer (buffer)->digit_buffer,
2225                    ADA_HOST_WIDE_INT_PRINT_DOUBLE_HEX,
2226                    (unsigned HOST_WIDE_INT) high, low);
2227           pp_string (buffer, pp_buffer (buffer)->digit_buffer);
2228         }
2229       break;
2230
2231     case REAL_CST:
2232     case FIXED_CST:
2233     case COMPLEX_CST:
2234     case STRING_CST:
2235     case VECTOR_CST:
2236       return 0;
2237
2238     case FUNCTION_DECL:
2239     case CONST_DECL:
2240       dump_ada_decl_name (buffer, node, limited_access);
2241       break;
2242
2243     case TYPE_DECL:
2244       if (DECL_IS_BUILTIN (node))
2245         {
2246           /* Don't print the declaration of built-in types.  */
2247
2248           if (name_only)
2249             {
2250               /* If we're in the middle of a declaration, defaults to
2251                  System.Address.  */
2252               if (package_prefix)
2253                 {
2254                   append_withs ("System", false);
2255                   pp_string (buffer, "System.Address");
2256                 }
2257               else
2258                 pp_string (buffer, "address");
2259             }
2260           break;
2261         }
2262
2263       if (name_only)
2264         dump_ada_decl_name (buffer, node, limited_access);
2265       else
2266         {
2267           if (is_tagged_type (TREE_TYPE (node)))
2268             {
2269               tree tmp = TYPE_FIELDS (TREE_TYPE (node));
2270               int first = 1;
2271
2272               /* Look for ancestors.  */
2273               for (; tmp; tmp = TREE_CHAIN (tmp))
2274                 {
2275                   if (!DECL_NAME (tmp) && is_tagged_type (TREE_TYPE (tmp)))
2276                     {
2277                       if (first)
2278                         {
2279                           pp_string (buffer, "limited new ");
2280                           first = 0;
2281                         }
2282                       else
2283                         pp_string (buffer, " and ");
2284
2285                       dump_ada_decl_name
2286                         (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
2287                     }
2288                 }
2289
2290               pp_string (buffer, first ? "tagged limited " : " with ");
2291             }
2292           else if (has_nontrivial_methods (TREE_TYPE (node)))
2293             pp_string (buffer, "limited ");
2294
2295           dump_generic_ada_node
2296             (buffer, TREE_TYPE (node), type, spc, false, false);
2297         }
2298       break;
2299
2300     case VAR_DECL:
2301     case PARM_DECL:
2302     case FIELD_DECL:
2303     case NAMESPACE_DECL:
2304       dump_ada_decl_name (buffer, node, false);
2305       break;
2306
2307     default:
2308       /* Ignore other nodes (e.g. expressions).  */
2309       return 0;
2310     }
2311
2312   return 1;
2313 }
2314
2315 /* Dump in BUFFER NODE's methods.  SPC is the indentation level.  Return 1 if
2316    methods were printed, 0 otherwise.  */
2317
2318 static int
2319 print_ada_methods (pretty_printer *buffer, tree node, int spc)
2320 {
2321   int res = 1;
2322   tree tmp;
2323
2324   if (!has_nontrivial_methods (node))
2325     return 0;
2326
2327   pp_semicolon (buffer);
2328
2329   for (tmp = TYPE_METHODS (node); tmp; tmp = TREE_CHAIN (tmp))
2330     {
2331       if (res)
2332         {
2333           pp_newline (buffer);
2334           pp_newline (buffer);
2335         }
2336       res = print_ada_declaration (buffer, tmp, node, spc);
2337     }
2338
2339   return 1;
2340 }
2341
2342 /* Dump in BUFFER anonymous types nested inside T's definition.
2343    PARENT is the parent node of T.
2344    FORWARD indicates whether a forward declaration of T should be generated.
2345    SPC is the indentation level.  */
2346
2347 static void
2348 dump_nested_types (pretty_printer *buffer, tree t, tree parent, bool forward,
2349                    int spc)
2350 {
2351   tree field, outer, decl;
2352
2353   /* Avoid recursing over the same tree.  */
2354   if (TREE_VISITED (t))
2355     return;
2356
2357   /* Find possible anonymous arrays/unions/structs recursively.  */
2358
2359   outer = TREE_TYPE (t);
2360
2361   if (outer == NULL_TREE)
2362     return;
2363
2364   if (forward)
2365     {
2366       pp_string (buffer, "type ");
2367       dump_generic_ada_node (buffer, t, t, spc, false, true);
2368       pp_semicolon (buffer);
2369       newline_and_indent (buffer, spc);
2370       TREE_VISITED (t) = 1;
2371     }
2372
2373   field = TYPE_FIELDS (outer);
2374   while (field)
2375     {
2376       if ((TREE_TYPE (field) != outer
2377            || (TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
2378                && TREE_TYPE (TREE_TYPE (field)) != outer))
2379            && (!TYPE_NAME (TREE_TYPE (field))
2380               || (TREE_CODE (field) == TYPE_DECL
2381                   && DECL_NAME (field) != DECL_NAME (t)
2382                   && TYPE_NAME (TREE_TYPE (field)) != TYPE_NAME (outer))))
2383         {
2384           switch (TREE_CODE (TREE_TYPE (field)))
2385             {
2386               case POINTER_TYPE:
2387                 decl = TREE_TYPE (TREE_TYPE (field));
2388
2389                 if (TREE_CODE (decl) == FUNCTION_TYPE)
2390                   for (decl = TREE_TYPE (decl);
2391                        decl && TREE_CODE (decl) == POINTER_TYPE;
2392                        decl = TREE_TYPE (decl))
2393                     ;
2394
2395                 decl = get_underlying_decl (decl);
2396
2397                 if (decl
2398                     && DECL_P (decl)
2399                     && decl_sloc (decl, true) > decl_sloc (t, true)
2400                     && DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t)
2401                     && !TREE_VISITED (decl)
2402                     && !DECL_IS_BUILTIN (decl)
2403                     && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl))
2404                         || TYPE_FIELDS (TREE_TYPE (decl))))
2405                   {
2406                     /* Generate forward declaration.  */
2407
2408                     pp_string (buffer, "type ");
2409                     dump_generic_ada_node (buffer, decl, 0, spc, false, true);
2410                     pp_semicolon (buffer);
2411                     newline_and_indent (buffer, spc);
2412
2413                     /* Ensure we do not generate duplicate forward
2414                        declarations for this type.  */
2415                     TREE_VISITED (decl) = 1;
2416                   }
2417                 break;
2418
2419               case ARRAY_TYPE:
2420                 /* Special case char arrays.  */
2421                 if (is_char_array (field))
2422                   pp_string (buffer, "sub");
2423
2424                 pp_string (buffer, "type ");
2425                 dump_ada_double_name (buffer, parent, field, "_array is ");
2426                 dump_ada_array_type (buffer, field, spc);
2427                 pp_semicolon (buffer);
2428                 newline_and_indent (buffer, spc);
2429                 break;
2430
2431               case UNION_TYPE:
2432                 TREE_VISITED (t) = 1;
2433                 dump_nested_types (buffer, field, t, false, spc);
2434
2435                 pp_string (buffer, "type ");
2436
2437                 if (TYPE_NAME (TREE_TYPE (field)))
2438                   {
2439                     dump_generic_ada_node
2440                       (buffer, TYPE_NAME (TREE_TYPE (field)), 0, spc, false,
2441                        true);
2442                     pp_string (buffer, " (discr : unsigned := 0) is ");
2443                     print_ada_struct_decl
2444                       (buffer, TREE_TYPE (field), t, spc, false);
2445
2446                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2447                     dump_generic_ada_node
2448                       (buffer, TREE_TYPE (field), 0, spc, false, true);
2449                     pp_string (buffer, ");");
2450                     newline_and_indent (buffer, spc);
2451
2452                     pp_string (buffer, "pragma Unchecked_Union (");
2453                     dump_generic_ada_node
2454                       (buffer, TREE_TYPE (field), 0, spc, false, true);
2455                     pp_string (buffer, ");");
2456                   }
2457                 else
2458                   {
2459                     dump_ada_double_name
2460                       (buffer, parent, field,
2461                         "_union (discr : unsigned := 0) is ");
2462                     print_ada_struct_decl
2463                       (buffer, TREE_TYPE (field), t, spc, false);
2464                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2465                     dump_ada_double_name (buffer, parent, field, "_union);");
2466                     newline_and_indent (buffer, spc);
2467
2468                     pp_string (buffer, "pragma Unchecked_Union (");
2469                     dump_ada_double_name (buffer, parent, field, "_union);");
2470                   }
2471
2472                 newline_and_indent (buffer, spc);
2473                 break;
2474
2475               case RECORD_TYPE:
2476                 if (TYPE_NAME (TREE_TYPE (t)) && !TREE_VISITED (t))
2477                   {
2478                     pp_string (buffer, "type ");
2479                     dump_generic_ada_node
2480                       (buffer, t, parent, spc, false, true);
2481                     pp_semicolon (buffer);
2482                     newline_and_indent (buffer, spc);
2483                   }
2484
2485                 TREE_VISITED (t) = 1;
2486                 dump_nested_types (buffer, field, t, false, spc);
2487                 pp_string (buffer, "type ");
2488
2489                 if (TYPE_NAME (TREE_TYPE (field)))
2490                   {
2491                     dump_generic_ada_node
2492                       (buffer, TREE_TYPE (field), 0, spc, false, true);
2493                     pp_string (buffer, " is ");
2494                     print_ada_struct_decl
2495                       (buffer, TREE_TYPE (field), t, spc, false);
2496                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2497                     dump_generic_ada_node
2498                       (buffer, TREE_TYPE (field), 0, spc, false, true);
2499                     pp_string (buffer, ");");
2500                   }
2501                 else
2502                   {
2503                     dump_ada_double_name
2504                       (buffer, parent, field, "_struct is ");
2505                     print_ada_struct_decl
2506                       (buffer, TREE_TYPE (field), t, spc, false);
2507                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2508                     dump_ada_double_name (buffer, parent, field, "_struct);");
2509                   }
2510
2511                 newline_and_indent (buffer, spc);
2512                 break;
2513
2514               default:
2515                 break;
2516             }
2517         }
2518       field = TREE_CHAIN (field);
2519     }
2520
2521   TREE_VISITED (t) = 1;
2522 }
2523
2524 /* Dump in BUFFER destructor spec corresponding to T.  */
2525
2526 static void
2527 print_destructor (pretty_printer *buffer, tree t)
2528 {
2529   const char *s = IDENTIFIER_POINTER (DECL_NAME (t));
2530
2531   if (*s == '_')
2532     for (s += 2; *s != ' '; s++)
2533       pp_character (buffer, *s);
2534   else
2535     {
2536       pp_string (buffer, "Delete_");
2537       pp_ada_tree_identifier (buffer, DECL_NAME (t), t, false);
2538     }
2539 }
2540
2541 /* Return the name of type T.  */
2542
2543 static const char *
2544 type_name (tree t)
2545 {
2546   tree n = TYPE_NAME (t);
2547
2548   if (TREE_CODE (n) == IDENTIFIER_NODE)
2549     return IDENTIFIER_POINTER (n);
2550   else
2551     return IDENTIFIER_POINTER (DECL_NAME (n));
2552 }
2553
2554 /* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
2555    SPC is the indentation level.  Return 1 if a declaration was printed,
2556    0 otherwise.  */
2557
2558 static int
2559 print_ada_declaration (pretty_printer *buffer, tree t, tree type, int spc)
2560 {
2561   int is_var = 0, need_indent = 0;
2562   int is_class = false;
2563   tree name = TYPE_NAME (TREE_TYPE (t));
2564   tree decl_name = DECL_NAME (t);
2565   tree orig = NULL_TREE;
2566
2567   if (cpp_check && cpp_check (t, IS_TEMPLATE))
2568     return dump_ada_template (buffer, t, spc);
2569
2570   if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2571     /* Skip enumeral values: will be handled as part of the type itself.  */
2572     return 0;
2573
2574   if (TREE_CODE (t) == TYPE_DECL)
2575     {
2576       orig = DECL_ORIGINAL_TYPE (t);
2577
2578       if (orig && TYPE_STUB_DECL (orig))
2579         {
2580           tree stub = TYPE_STUB_DECL (orig);
2581           tree typ = TREE_TYPE (stub);
2582
2583           if (TYPE_NAME (typ))
2584             {
2585               /* If types have same representation, and same name (ignoring
2586                  casing), then ignore the second type.  */
2587               if (type_name (typ) == type_name (TREE_TYPE (t))
2588                   || !strcasecmp (type_name (typ), type_name (TREE_TYPE (t))))
2589                 return 0;
2590
2591               INDENT (spc);
2592
2593               if (RECORD_OR_UNION_TYPE_P (typ) && !TYPE_FIELDS (typ))
2594                 {
2595                   pp_string (buffer, "--  skipped empty struct ");
2596                   dump_generic_ada_node (buffer, t, type, spc, false, true);
2597                 }
2598               else
2599                 {
2600                   if (!TREE_VISITED (stub)
2601                       && DECL_SOURCE_FILE (stub) == source_file_base)
2602                     dump_nested_types (buffer, stub, stub, true, spc);
2603
2604                   pp_string (buffer, "subtype ");
2605                   dump_generic_ada_node (buffer, t, type, spc, false, true);
2606                   pp_string (buffer, " is ");
2607                   dump_generic_ada_node (buffer, typ, type, spc, false, true);
2608                   pp_semicolon (buffer);
2609                 }
2610               return 1;
2611             }
2612         }
2613
2614       /* Skip unnamed or anonymous structs/unions/enum types.  */
2615       if (!orig && !decl_name && !name)
2616         {
2617           tree tmp;
2618           location_t sloc;
2619
2620           if (cpp_check || TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2621             return 0;
2622
2623           if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
2624             {
2625               /* Search next items until finding a named type decl.  */
2626               sloc = decl_sloc_common (t, true, true);
2627
2628               for (tmp = TREE_CHAIN (t); tmp; tmp = TREE_CHAIN (tmp))
2629                 {
2630                   if (TREE_CODE (tmp) == TYPE_DECL
2631                       && (DECL_NAME (tmp) || TYPE_NAME (TREE_TYPE (tmp))))
2632                     {
2633                       /* If same sloc, it means we can ignore the anonymous
2634                          struct.  */
2635                       if (decl_sloc_common (tmp, true, true) == sloc)
2636                         return 0;
2637                       else
2638                         break;
2639                     }
2640                 }
2641               if (tmp == NULL)
2642                 return 0;
2643             }
2644         }
2645
2646       if (!orig
2647           && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE
2648           && decl_name
2649           && (*IDENTIFIER_POINTER (decl_name) == '.'
2650               || *IDENTIFIER_POINTER (decl_name) == '$'))
2651         /* Skip anonymous enum types (duplicates of real types).  */
2652         return 0;
2653
2654       INDENT (spc);
2655
2656       switch (TREE_CODE (TREE_TYPE (t)))
2657         {
2658           case RECORD_TYPE:
2659           case UNION_TYPE:
2660           case QUAL_UNION_TYPE:
2661             /* Skip empty structs (typically forward references to real
2662                structs).  */
2663             if (!TYPE_FIELDS (TREE_TYPE (t)))
2664               {
2665                 pp_string (buffer, "--  skipped empty struct ");
2666                 dump_generic_ada_node (buffer, t, type, spc, false, true);
2667                 return 1;
2668               }
2669
2670             if (decl_name
2671                 && (*IDENTIFIER_POINTER (decl_name) == '.'
2672                     || *IDENTIFIER_POINTER (decl_name) == '$'))
2673               {
2674                 pp_string (buffer, "--  skipped anonymous struct ");
2675                 dump_generic_ada_node (buffer, t, type, spc, false, true);
2676                 TREE_VISITED (t) = 1;
2677                 return 1;
2678               }
2679
2680             if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2681               pp_string (buffer, "subtype ");
2682             else
2683               {
2684                 dump_nested_types (buffer, t, t, false, spc);
2685
2686                 if (separate_class_package (t))
2687                   {
2688                     is_class = true;
2689                     pp_string (buffer, "package Class_");
2690                     dump_generic_ada_node (buffer, t, type, spc, false, true);
2691                     pp_string (buffer, " is");
2692                     spc += INDENT_INCR;
2693                     newline_and_indent (buffer, spc);
2694                   }
2695
2696                 pp_string (buffer, "type ");
2697               }
2698             break;
2699
2700           case ARRAY_TYPE:
2701           case POINTER_TYPE:
2702           case REFERENCE_TYPE:
2703             if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2704                 || is_char_array (t))
2705               pp_string (buffer, "subtype ");
2706             else
2707               pp_string (buffer, "type ");
2708             break;
2709
2710           case FUNCTION_TYPE:
2711             pp_string (buffer, "--  skipped function type ");
2712             dump_generic_ada_node (buffer, t, type, spc, false, true);
2713             return 1;
2714             break;
2715
2716           case ENUMERAL_TYPE:
2717             if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2718                 || !is_simple_enum (TREE_TYPE (t)))
2719               pp_string (buffer, "subtype ");
2720             else
2721               pp_string (buffer, "type ");
2722             break;
2723
2724           default:
2725             pp_string (buffer, "subtype ");
2726         }
2727       TREE_VISITED (t) = 1;
2728     }
2729   else
2730     {
2731       if (TREE_CODE (t) == VAR_DECL
2732           && decl_name
2733           && *IDENTIFIER_POINTER (decl_name) == '_')
2734         return 0;
2735
2736       need_indent = 1;
2737     }
2738
2739   /* Print the type and name.  */
2740   if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
2741     {
2742       if (need_indent)
2743         INDENT (spc);
2744
2745       /* Print variable's name.  */
2746       dump_generic_ada_node (buffer, t, type, spc, false, true);
2747
2748       if (TREE_CODE (t) == TYPE_DECL)
2749         {
2750           pp_string (buffer, " is ");
2751
2752           if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2753             dump_generic_ada_node
2754               (buffer, TYPE_NAME (orig), type, spc, false, true);
2755           else
2756             dump_ada_array_type (buffer, t, spc);
2757         }
2758       else
2759         {
2760           tree tmp = TYPE_NAME (TREE_TYPE (t));
2761
2762           if (spc == INDENT_INCR || TREE_STATIC (t))
2763             is_var = 1;
2764
2765           pp_string (buffer, " : ");
2766
2767           if (tmp)
2768             {
2769               if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE
2770                   && TREE_CODE (tmp) != INTEGER_TYPE)
2771                 pp_string (buffer, "aliased ");
2772
2773               dump_generic_ada_node (buffer, tmp, type, spc, false, true);
2774             }
2775           else
2776             {
2777               pp_string (buffer, "aliased ");
2778
2779               if (!type)
2780                 dump_ada_array_type (buffer, t, spc);
2781               else
2782                 dump_ada_double_name (buffer, type, t, "_array");
2783             }
2784         }
2785     }
2786   else if (TREE_CODE (t) == FUNCTION_DECL)
2787     {
2788       bool is_function = true, is_abstract_class = false;
2789       bool is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE;
2790       tree decl_name = DECL_NAME (t);
2791       int prev_in_function = in_function;
2792       bool is_abstract = false;
2793       bool is_constructor = false;
2794       bool is_destructor = false;
2795       bool is_copy_constructor = false;
2796
2797       if (!decl_name)
2798         return 0;
2799
2800       if (cpp_check)
2801         {
2802           is_abstract = cpp_check (t, IS_ABSTRACT);
2803           is_constructor = cpp_check (t, IS_CONSTRUCTOR);
2804           is_destructor = cpp_check (t, IS_DESTRUCTOR);
2805           is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR);
2806         }
2807
2808       /* Skip __comp_dtor destructor which is redundant with the '~class()'
2809          destructor.  */
2810       if (is_destructor
2811           && !strncmp (IDENTIFIER_POINTER (decl_name), "__comp", 6))
2812         return 0;
2813
2814       /* Skip copy constructors: some are internal only, and those that are
2815          not cannot be called easily from Ada anyway.  */
2816       if (is_copy_constructor)
2817         return 0;
2818
2819       /* If this function has an entry in the dispatch table, we cannot
2820          omit it.  */
2821       if (!DECL_VINDEX (t) && *IDENTIFIER_POINTER (decl_name) == '_')
2822         {
2823           if (IDENTIFIER_POINTER (decl_name)[1] == '_')
2824             return 0;
2825
2826           INDENT (spc);
2827           pp_string (buffer, "--  skipped func ");
2828           pp_string (buffer, IDENTIFIER_POINTER (decl_name));
2829           return 1;
2830         }
2831
2832       if (need_indent)
2833         INDENT (spc);
2834
2835       if (is_constructor)
2836         pp_string (buffer, "function New_");
2837       else if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))))
2838         {
2839           is_function = false;
2840           pp_string (buffer, "procedure ");
2841         }
2842       else
2843         pp_string (buffer, "function ");
2844
2845       in_function = is_function;
2846
2847       if (is_destructor)
2848         print_destructor (buffer, t);
2849       else
2850         dump_ada_decl_name (buffer, t, false);
2851
2852       dump_ada_function_declaration
2853         (buffer, t, is_method, is_constructor, is_destructor, spc);
2854       in_function = prev_in_function;
2855
2856       if (is_function)
2857         {
2858           pp_string (buffer, " return ");
2859
2860           if (is_constructor)
2861             {
2862               dump_ada_decl_name (buffer, t, false);
2863             }
2864           else
2865             {
2866               dump_generic_ada_node
2867                 (buffer, TREE_TYPE (TREE_TYPE (t)), type, spc, false, true);
2868             }
2869         }
2870
2871       if (is_constructor
2872           && RECORD_OR_UNION_TYPE_P (type)
2873           && TYPE_METHODS (type))
2874         {
2875           tree tmp;
2876
2877           for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp))
2878             if (cpp_check (tmp, IS_ABSTRACT))
2879               {
2880                 is_abstract_class = 1;
2881                 break;
2882               }
2883         }
2884
2885       if (is_abstract || is_abstract_class)
2886         pp_string (buffer, " is abstract");
2887
2888       pp_semicolon (buffer);
2889       pp_string (buffer, "  -- ");
2890       dump_sloc (buffer, t);
2891
2892       if (is_abstract || !DECL_ASSEMBLER_NAME (t))
2893         return 1;
2894
2895       newline_and_indent (buffer, spc);
2896
2897       if (is_constructor)
2898         {
2899           pp_string (buffer, "pragma CPP_Constructor (New_");
2900           dump_ada_decl_name (buffer, t, false);
2901           pp_string (buffer, ", \"");
2902           pp_asm_name (buffer, t);
2903           pp_string (buffer, "\");");
2904         }
2905       else if (is_destructor)
2906         {
2907           pp_string (buffer, "pragma Import (CPP, ");
2908           print_destructor (buffer, t);
2909           pp_string (buffer, ", \"");
2910           pp_asm_name (buffer, t);
2911           pp_string (buffer, "\");");
2912         }
2913       else
2914         {
2915           dump_ada_import (buffer, t);
2916         }
2917
2918       return 1;
2919     }
2920   else if (TREE_CODE (t) == TYPE_DECL && !DECL_ORIGINAL_TYPE (t))
2921     {
2922       int is_interface = 0;
2923       int is_abstract_record = 0;
2924
2925       if (need_indent)
2926         INDENT (spc);
2927
2928       /* Anonymous structs/unions */
2929       dump_generic_ada_node (buffer, TREE_TYPE (t), t, spc, false, true);
2930
2931       if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
2932           || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE)
2933         {
2934           pp_string (buffer, " (discr : unsigned := 0)");
2935         }
2936
2937       pp_string (buffer, " is ");
2938
2939       /* Check whether we have an Ada interface compatible class.  */
2940       if (cpp_check
2941           && RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))
2942           && TYPE_METHODS (TREE_TYPE (t)))
2943         {
2944           int num_fields = 0;
2945           tree tmp;
2946
2947           /* Check that there are no fields other than the virtual table.  */
2948           for (tmp = TYPE_FIELDS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
2949             {
2950               if (TREE_CODE (tmp) == TYPE_DECL)
2951                 continue;
2952               num_fields++;
2953             }
2954
2955           if (num_fields == 1)
2956             is_interface = 1;
2957
2958           /* Also check that there are only virtual methods.  */
2959           for (tmp = TYPE_METHODS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
2960             {
2961               if (cpp_check (tmp, IS_ABSTRACT))
2962                 is_abstract_record = 1;
2963               else
2964                 is_interface = 0;
2965             }
2966         }
2967
2968       TREE_VISITED (t) = 1;
2969       if (is_interface)
2970         {
2971           pp_string (buffer, "limited interface;  -- ");
2972           dump_sloc (buffer, t);
2973           newline_and_indent (buffer, spc);
2974           pp_string (buffer, "pragma Import (CPP, ");
2975           dump_generic_ada_node
2976             (buffer, TYPE_NAME (TREE_TYPE (t)), type, spc, false, true);
2977           pp_right_paren (buffer);
2978
2979           print_ada_methods (buffer, TREE_TYPE (t), spc);
2980         }
2981       else
2982         {
2983           if (is_abstract_record)
2984             pp_string (buffer, "abstract ");
2985           dump_generic_ada_node (buffer, t, t, spc, false, false);
2986         }
2987     }
2988   else
2989     {
2990       if (need_indent)
2991         INDENT (spc);
2992
2993       if (TREE_CODE (t) == FIELD_DECL && DECL_NAME (t))
2994         check_name (buffer, t);
2995
2996       /* Print variable/type's name.  */
2997       dump_generic_ada_node (buffer, t, t, spc, false, true);
2998
2999       if (TREE_CODE (t) == TYPE_DECL)
3000         {
3001           tree orig = DECL_ORIGINAL_TYPE (t);
3002           int is_subtype = orig && TYPE_NAME (orig) && orig != TREE_TYPE (t);
3003
3004           if (!is_subtype
3005               && (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
3006                   || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE))
3007             pp_string (buffer, " (discr : unsigned := 0)");
3008
3009           pp_string (buffer, " is ");
3010
3011           dump_generic_ada_node (buffer, orig, t, spc, false, is_subtype);
3012         }
3013       else
3014         {
3015           if (spc == INDENT_INCR || TREE_STATIC (t))
3016             is_var = 1;
3017
3018           pp_string (buffer, " : ");
3019
3020           /* Print type declaration.  */
3021
3022           if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
3023               && !TYPE_NAME (TREE_TYPE (t)))
3024             {
3025               dump_ada_double_name (buffer, type, t, "_union");
3026             }
3027           else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
3028             {
3029               if (TREE_CODE (TREE_TYPE (t)) == RECORD_TYPE)
3030                 pp_string (buffer, "aliased ");
3031
3032               dump_generic_ada_node
3033                 (buffer, TREE_TYPE (t), t, spc, false, true);
3034             }
3035           else
3036             {
3037               if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE
3038                   && (TYPE_NAME (TREE_TYPE (t))
3039                       || TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE))
3040                 pp_string (buffer, "aliased ");
3041
3042               dump_generic_ada_node
3043                 (buffer, TREE_TYPE (t), TREE_TYPE (t), spc, false, true);
3044             }
3045         }
3046     }
3047
3048   if (is_class)
3049     {
3050       spc -= 3;
3051       newline_and_indent (buffer, spc);
3052       pp_string (buffer, "end;");
3053       newline_and_indent (buffer, spc);
3054       pp_string (buffer, "use Class_");
3055       dump_generic_ada_node (buffer, t, type, spc, false, true);
3056       pp_semicolon (buffer);
3057       pp_newline (buffer);
3058
3059       /* All needed indentation/newline performed already, so return 0.  */
3060       return 0;
3061     }
3062   else
3063     {
3064       pp_string (buffer, ";  -- ");
3065       dump_sloc (buffer, t);
3066     }
3067
3068   if (is_var)
3069     {
3070       newline_and_indent (buffer, spc);
3071       dump_ada_import (buffer, t);
3072     }
3073
3074   return 1;
3075 }
3076
3077 /* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
3078    with Ada syntax.  SPC is the indentation level.  If DISPLAY_CONVENTION is
3079    true, also print the pragma Convention for NODE.  */
3080
3081 static void
3082 print_ada_struct_decl (pretty_printer *buffer, tree node, tree type, int spc,
3083                        bool display_convention)
3084 {
3085   tree tmp;
3086   const bool is_union
3087     = TREE_CODE (node) == UNION_TYPE || TREE_CODE (node) == QUAL_UNION_TYPE;
3088   char buf[32];
3089   int field_num = 0;
3090   int field_spc = spc + INDENT_INCR;
3091   int need_semicolon;
3092
3093   bitfield_used = false;
3094
3095   if (!TYPE_FIELDS (node))
3096     pp_string (buffer, "null record;");
3097   else
3098     {
3099       pp_string (buffer, "record");
3100
3101       /* Print the contents of the structure.  */
3102
3103       if (is_union)
3104         {
3105           newline_and_indent (buffer, spc + INDENT_INCR);
3106           pp_string (buffer, "case discr is");
3107           field_spc = spc + INDENT_INCR * 3;
3108         }
3109
3110       pp_newline (buffer);
3111
3112       /* Print the non-static fields of the structure.  */
3113       for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3114         {
3115           /* Add parent field if needed.  */
3116           if (!DECL_NAME (tmp))
3117             {
3118               if (!is_tagged_type (TREE_TYPE (tmp)))
3119                 {
3120                   if (!TYPE_NAME (TREE_TYPE (tmp)))
3121                     print_ada_declaration (buffer, tmp, type, field_spc);
3122                   else
3123                     {
3124                       INDENT (field_spc);
3125
3126                       if (field_num == 0)
3127                         pp_string (buffer, "parent : aliased ");
3128                       else
3129                         {
3130                           sprintf (buf, "field_%d : aliased ", field_num + 1);
3131                           pp_string (buffer, buf);
3132                         }
3133                       dump_ada_decl_name
3134                         (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
3135                       pp_semicolon (buffer);
3136                     }
3137                   pp_newline (buffer);
3138                   field_num++;
3139                 }
3140             }
3141           /* Avoid printing the structure recursively.  */
3142           else if ((TREE_TYPE (tmp) != node
3143                    || (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3144                        && TREE_TYPE (TREE_TYPE (tmp)) != node))
3145                    && TREE_CODE (tmp) != TYPE_DECL
3146                    && !TREE_STATIC (tmp))
3147             {
3148               /* Skip internal virtual table field.  */
3149               if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp)), "_vptr", 5))
3150                 {
3151                   if (is_union)
3152                     {
3153                       if (TREE_CHAIN (tmp)
3154                           && TREE_TYPE (TREE_CHAIN (tmp)) != node
3155                           && TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL)
3156                         sprintf (buf, "when %d =>", field_num);
3157                       else
3158                         sprintf (buf, "when others =>");
3159
3160                       INDENT (spc + INDENT_INCR * 2);
3161                       pp_string (buffer, buf);
3162                       pp_newline (buffer);
3163                     }
3164
3165                   if (print_ada_declaration (buffer, tmp, type, field_spc))
3166                     {
3167                       pp_newline (buffer);
3168                       field_num++;
3169                     }
3170                 }
3171             }
3172         }
3173
3174       if (is_union)
3175         {
3176           INDENT (spc + INDENT_INCR);
3177           pp_string (buffer, "end case;");
3178           pp_newline (buffer);
3179         }
3180
3181       if (field_num == 0)
3182         {
3183           INDENT (spc + INDENT_INCR);
3184           pp_string (buffer, "null;");
3185           pp_newline (buffer);
3186         }
3187
3188       INDENT (spc);
3189       pp_string (buffer, "end record;");
3190     }
3191
3192   newline_and_indent (buffer, spc);
3193
3194   if (!display_convention)
3195     return;
3196
3197   if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type)))
3198     {
3199       if (has_nontrivial_methods (TREE_TYPE (type)))
3200         pp_string (buffer, "pragma Import (CPP, ");
3201       else
3202         pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
3203     }
3204   else
3205     pp_string (buffer, "pragma Convention (C, ");
3206
3207   package_prefix = false;
3208   dump_generic_ada_node (buffer, TREE_TYPE (type), type, spc, false, true);
3209   package_prefix = true;
3210   pp_right_paren (buffer);
3211
3212   if (is_union)
3213     {
3214       pp_semicolon (buffer);
3215       newline_and_indent (buffer, spc);
3216       pp_string (buffer, "pragma Unchecked_Union (");
3217
3218       dump_generic_ada_node (buffer, TREE_TYPE (type), type, spc, false, true);
3219       pp_right_paren (buffer);
3220     }
3221
3222   if (bitfield_used)
3223     {
3224       pp_semicolon (buffer);
3225       newline_and_indent (buffer, spc);
3226       pp_string (buffer, "pragma Pack (");
3227       dump_generic_ada_node
3228         (buffer, TREE_TYPE (type), type, spc, false, true);
3229       pp_right_paren (buffer);
3230       bitfield_used = false;
3231     }
3232
3233   need_semicolon = !print_ada_methods (buffer, node, spc);
3234
3235   /* Print the static fields of the structure, if any.  */
3236   for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3237     {
3238       if (DECL_NAME (tmp) && TREE_STATIC (tmp))
3239         {
3240           if (need_semicolon)
3241             {
3242               need_semicolon = false;
3243               pp_semicolon (buffer);
3244             }
3245           pp_newline (buffer);
3246           pp_newline (buffer);
3247           print_ada_declaration (buffer, tmp, type, spc);
3248         }
3249     }
3250 }
3251
3252 /* Dump all the declarations in SOURCE_FILE to an Ada spec.
3253    COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3254    nodes for SOURCE_FILE.  CHECK is used to perform C++ queries on nodes.  */
3255
3256 static void
3257 dump_ads (const char *source_file,
3258           void (*collect_all_refs)(const char *),
3259           int (*check)(const_tree, cpp_operation))
3260 {
3261   char *ads_name;
3262   char *pkg_name;
3263   char *s;
3264   FILE *f;
3265
3266   pkg_name = get_ada_package (source_file);
3267
3268   /* Construct the .ads filename and package name.  */
3269   ads_name = xstrdup (pkg_name);
3270
3271   for (s = ads_name; *s; s++)
3272     if (*s == '.')
3273       *s = '-';
3274     else
3275       *s = TOLOWER (*s);
3276
3277   ads_name = reconcat (ads_name, ads_name, ".ads", NULL);
3278
3279   /* Write out the .ads file.  */
3280   f = fopen (ads_name, "w");
3281   if (f)
3282     {
3283       pretty_printer pp;
3284
3285       pp_needs_newline (&pp) = true;
3286       pp.buffer->stream = f;
3287
3288       /* Dump all relevant macros.  */
3289       dump_ada_macros (&pp, source_file);
3290
3291       /* Reset the table of withs for this file.  */
3292       reset_ada_withs ();
3293
3294       (*collect_all_refs) (source_file);
3295
3296       /* Dump all references.  */
3297       cpp_check = check;
3298       dump_ada_nodes (&pp, source_file);
3299
3300       /* Requires Ada 2005 syntax, so generate corresponding pragma.
3301          Also, disable style checks since this file is auto-generated.  */
3302       fprintf (f, "pragma Ada_2005;\npragma Style_Checks (Off);\n\n");
3303
3304       /* Dump withs.  */
3305       dump_ada_withs (f);
3306
3307       fprintf (f, "\npackage %s is\n\n", pkg_name);
3308       pp_write_text_to_stream (&pp);
3309       /* ??? need to free pp */
3310       fprintf (f, "end %s;\n", pkg_name);
3311       fclose (f);
3312     }
3313
3314   free (ads_name);
3315   free (pkg_name);
3316 }
3317
3318 static const char **source_refs = NULL;
3319 static int source_refs_used = 0;
3320 static int source_refs_allocd = 0;
3321
3322 /* Add an entry for FILENAME to the table SOURCE_REFS.  */
3323
3324 void
3325 collect_source_ref (const char *filename)
3326 {
3327   int i;
3328
3329   if (!filename)
3330     return;
3331
3332   if (source_refs_allocd == 0)
3333     {
3334       source_refs_allocd = 1024;
3335       source_refs = XNEWVEC (const char *, source_refs_allocd);
3336     }
3337
3338   for (i = 0; i < source_refs_used; i++)
3339     if (filename == source_refs[i])
3340       return;
3341
3342   if (source_refs_used == source_refs_allocd)
3343     {
3344       source_refs_allocd *= 2;
3345       source_refs = XRESIZEVEC (const char *, source_refs, source_refs_allocd);
3346     }
3347
3348   source_refs[source_refs_used++] = filename;
3349 }
3350
3351 /* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
3352    using callbacks COLLECT_ALL_REFS and CHECK.
3353    COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3354    nodes for a given source file.
3355    CHECK is used to perform C++ queries on nodes, or NULL for the C
3356    front-end.  */
3357
3358 void
3359 dump_ada_specs (void (*collect_all_refs)(const char *),
3360                 int (*check)(const_tree, cpp_operation))
3361 {
3362   int i;
3363
3364   /* Iterate over the list of files to dump specs for */
3365   for (i = 0; i < source_refs_used; i++)
3366     dump_ads (source_refs[i], collect_all_refs, check);
3367
3368   /* Free files table.  */
3369   free (source_refs);
3370 }