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