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 (TREE_CODE (tmp) == FUNCTION_DECL && 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 (t2))
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_SIZE_UNIT is DECL_TEMPLATE_INSTANTIATIONS in this context.  */
1734   tree inst = DECL_SIZE_UNIT (t);
1735   /* This emulates DECL_TEMPLATE_RESULT in this context.  */
1736   struct tree_template_decl {
1737     struct tree_decl_common common;
1738     tree arguments;
1739     tree result;
1740   };
1741   tree result = ((struct tree_template_decl *) t)->result;
1742   int num_inst = 0;
1743
1744   /* Don't look at template declarations declaring something coming from
1745      another file.  This can occur for template friend declarations.  */
1746   if (LOCATION_FILE (decl_sloc (result, false))
1747       != LOCATION_FILE (decl_sloc (t, false)))
1748     return 0;
1749
1750   while (inst && inst != error_mark_node)
1751     {
1752       tree types = TREE_PURPOSE (inst);
1753       tree instance = TREE_VALUE (inst);
1754
1755       if (TREE_VEC_LENGTH (types) == 0)
1756         break;
1757
1758       if (!RECORD_OR_UNION_TYPE_P (instance) || !TYPE_METHODS (instance))
1759         break;
1760
1761       num_inst++;
1762       INDENT (spc);
1763       pp_string (buffer, "package ");
1764       package_prefix = false;
1765       dump_generic_ada_node (buffer, instance, t, spc, false, true);
1766       dump_template_types (buffer, types, spc);
1767       pp_string (buffer, " is");
1768       spc += INDENT_INCR;
1769       newline_and_indent (buffer, spc);
1770
1771       TREE_VISITED (get_underlying_decl (instance)) = 1;
1772       pp_string (buffer, "type ");
1773       dump_generic_ada_node (buffer, instance, t, spc, false, true);
1774       package_prefix = true;
1775
1776       if (is_tagged_type (instance))
1777         pp_string (buffer, " is tagged limited ");
1778       else
1779         pp_string (buffer, " is limited ");
1780
1781       dump_generic_ada_node (buffer, instance, t, spc, false, false);
1782       pp_newline (buffer);
1783       spc -= INDENT_INCR;
1784       newline_and_indent (buffer, spc);
1785
1786       pp_string (buffer, "end;");
1787       newline_and_indent (buffer, spc);
1788       pp_string (buffer, "use ");
1789       package_prefix = false;
1790       dump_generic_ada_node (buffer, instance, t, spc, false, true);
1791       dump_template_types (buffer, types, spc);
1792       package_prefix = true;
1793       pp_semicolon (buffer);
1794       pp_newline (buffer);
1795       pp_newline (buffer);
1796
1797       inst = TREE_CHAIN (inst);
1798     }
1799
1800   return num_inst > 0;
1801 }
1802
1803 /* Return true if NODE is a simple enum types, that can be mapped to an
1804    Ada enum type directly.  */
1805
1806 static bool
1807 is_simple_enum (tree node)
1808 {
1809   HOST_WIDE_INT count = 0;
1810   tree value;
1811
1812   for (value = TYPE_VALUES (node); value; value = TREE_CHAIN (value))
1813     {
1814       tree int_val = TREE_VALUE (value);
1815
1816       if (TREE_CODE (int_val) != INTEGER_CST)
1817         int_val = DECL_INITIAL (int_val);
1818
1819       if (!tree_fits_shwi_p (int_val))
1820         return false;
1821       else if (tree_to_shwi (int_val) != count)
1822         return false;
1823
1824       count++;
1825     }
1826
1827   return true;
1828 }
1829
1830 static bool bitfield_used = false;
1831
1832 /* Recursively dump in BUFFER Ada declarations corresponding to NODE of type
1833    TYPE.  SPC is the indentation level.  LIMITED_ACCESS indicates whether NODE
1834    can be referenced via a "limited with" clause.  NAME_ONLY indicates whether
1835    we should only dump the name of NODE, instead of its full declaration.  */
1836
1837 static int
1838 dump_generic_ada_node (pretty_printer *buffer, tree node, tree type, int spc,
1839                        int limited_access, bool name_only)
1840 {
1841   if (node == NULL_TREE)
1842     return 0;
1843
1844   switch (TREE_CODE (node))
1845     {
1846     case ERROR_MARK:
1847       pp_string (buffer, "<<< error >>>");
1848       return 0;
1849
1850     case IDENTIFIER_NODE:
1851       pp_ada_tree_identifier (buffer, node, type, limited_access);
1852       break;
1853
1854     case TREE_LIST:
1855       pp_string (buffer, "--- unexpected node: TREE_LIST");
1856       return 0;
1857
1858     case TREE_BINFO:
1859       dump_generic_ada_node
1860         (buffer, BINFO_TYPE (node), type, spc, limited_access, name_only);
1861
1862     case TREE_VEC:
1863       pp_string (buffer, "--- unexpected node: TREE_VEC");
1864       return 0;
1865
1866     case VOID_TYPE:
1867       if (package_prefix)
1868         {
1869           append_withs ("System", false);
1870           pp_string (buffer, "System.Address");
1871         }
1872       else
1873         pp_string (buffer, "address");
1874       break;
1875
1876     case VECTOR_TYPE:
1877       pp_string (buffer, "<vector>");
1878       break;
1879
1880     case COMPLEX_TYPE:
1881       pp_string (buffer, "<complex>");
1882       break;
1883
1884     case ENUMERAL_TYPE:
1885       if (name_only)
1886         dump_generic_ada_node
1887           (buffer, TYPE_NAME (node), node, spc, 0, true);
1888       else
1889         {
1890           tree value = TYPE_VALUES (node);
1891
1892           if (is_simple_enum (node))
1893             {
1894               bool first = true;
1895               spc += INDENT_INCR;
1896               newline_and_indent (buffer, spc - 1);
1897               pp_left_paren (buffer);
1898               for (; value; value = TREE_CHAIN (value))
1899                 {
1900                   if (first)
1901                     first = false;
1902                   else
1903                     {
1904                       pp_comma (buffer);
1905                       newline_and_indent (buffer, spc);
1906                     }
1907
1908                   pp_ada_tree_identifier
1909                     (buffer, TREE_PURPOSE (value), node, false);
1910                 }
1911               pp_string (buffer, ");");
1912               spc -= INDENT_INCR;
1913               newline_and_indent (buffer, spc);
1914               pp_string (buffer, "pragma Convention (C, ");
1915               dump_generic_ada_node
1916                 (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
1917                  spc, 0, true);
1918               pp_right_paren (buffer);
1919             }
1920           else
1921             {
1922               pp_string (buffer, "unsigned");
1923               for (; value; value = TREE_CHAIN (value))
1924                 {
1925                   pp_semicolon (buffer);
1926                   newline_and_indent (buffer, spc);
1927
1928                   pp_ada_tree_identifier
1929                     (buffer, TREE_PURPOSE (value), node, false);
1930                   pp_string (buffer, " : constant ");
1931
1932                   dump_generic_ada_node
1933                     (buffer, DECL_NAME (type) ? type : TYPE_NAME (node), type,
1934                      spc, 0, true);
1935
1936                   pp_string (buffer, " := ");
1937                   dump_generic_ada_node
1938                     (buffer,
1939                      TREE_CODE (TREE_VALUE (value)) == INTEGER_CST ?
1940                        TREE_VALUE (value) : DECL_INITIAL (TREE_VALUE (value)),
1941                      node, spc, false, true);
1942                 }
1943             }
1944         }
1945       break;
1946
1947     case INTEGER_TYPE:
1948     case REAL_TYPE:
1949     case FIXED_POINT_TYPE:
1950     case BOOLEAN_TYPE:
1951       {
1952         enum tree_code_class tclass;
1953
1954         tclass = TREE_CODE_CLASS (TREE_CODE (node));
1955
1956         if (tclass == tcc_declaration)
1957           {
1958             if (DECL_NAME (node))
1959               pp_ada_tree_identifier
1960                 (buffer, DECL_NAME (node), 0, limited_access);
1961             else
1962               pp_string (buffer, "<unnamed type decl>");
1963           }
1964         else if (tclass == tcc_type)
1965           {
1966             if (TYPE_NAME (node))
1967               {
1968                 if (TREE_CODE (TYPE_NAME (node)) == IDENTIFIER_NODE)
1969                   pp_ada_tree_identifier (buffer, TYPE_NAME (node),
1970                                           node, limited_access);
1971                 else if (TREE_CODE (TYPE_NAME (node)) == TYPE_DECL
1972                          && DECL_NAME (TYPE_NAME (node)))
1973                   dump_ada_decl_name (buffer, TYPE_NAME (node), limited_access);
1974                 else
1975                   pp_string (buffer, "<unnamed type>");
1976               }
1977             else if (TREE_CODE (node) == INTEGER_TYPE)
1978               {
1979                 append_withs ("Interfaces.C.Extensions", false);
1980                 bitfield_used = true;
1981
1982                 if (TYPE_PRECISION (node) == 1)
1983                   pp_string (buffer, "Extensions.Unsigned_1");
1984                 else
1985                   {
1986                     pp_string (buffer, (TYPE_UNSIGNED (node)
1987                                         ? "Extensions.Unsigned_"
1988                                         : "Extensions.Signed_"));
1989                     pp_decimal_int (buffer, TYPE_PRECISION (node));
1990                   }
1991               }
1992             else
1993               pp_string (buffer, "<unnamed type>");
1994           }
1995         break;
1996       }
1997
1998     case POINTER_TYPE:
1999     case REFERENCE_TYPE:
2000       if (name_only && TYPE_NAME (node))
2001         dump_generic_ada_node
2002           (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2003
2004       else if (TREE_CODE (TREE_TYPE (node)) == FUNCTION_TYPE)
2005         {
2006           tree fnode = TREE_TYPE (node);
2007           bool is_function;
2008
2009           if (VOID_TYPE_P (TREE_TYPE (fnode)))
2010             {
2011               is_function = false;
2012               pp_string (buffer, "access procedure");
2013             }
2014           else
2015             {
2016               is_function = true;
2017               pp_string (buffer, "access function");
2018             }
2019
2020           dump_ada_function_declaration
2021             (buffer, node, false, false, false, spc + INDENT_INCR);
2022
2023           if (is_function)
2024             {
2025               pp_string (buffer, " return ");
2026               dump_generic_ada_node
2027                 (buffer, TREE_TYPE (fnode), type, spc, 0, true);
2028             }
2029
2030             /* If we are dumping the full type, it means we are part of a
2031                type definition and need also a Convention C pragma.  */
2032             if (!name_only)
2033               {
2034                 pp_semicolon (buffer);
2035                 newline_and_indent (buffer, spc);
2036                 pp_string (buffer, "pragma Convention (C, ");
2037                 dump_generic_ada_node
2038                   (buffer, type, 0, spc, false, true);
2039                 pp_right_paren (buffer);
2040               }
2041         }
2042       else
2043         {
2044           int is_access = false;
2045           unsigned int quals = TYPE_QUALS (TREE_TYPE (node));
2046
2047           if (VOID_TYPE_P (TREE_TYPE (node)))
2048             {
2049               if (!name_only)
2050                 pp_string (buffer, "new ");
2051               if (package_prefix)
2052                 {
2053                   append_withs ("System", false);
2054                   pp_string (buffer, "System.Address");
2055                 }
2056               else
2057                 pp_string (buffer, "address");
2058             }
2059           else
2060             {
2061               if (TREE_CODE (node) == POINTER_TYPE
2062                   && TREE_CODE (TREE_TYPE (node)) == INTEGER_TYPE
2063                   && !strcmp
2064                         (IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME
2065                           (TREE_TYPE (node)))), "char"))
2066                 {
2067                   if (!name_only)
2068                     pp_string (buffer, "new ");
2069
2070                   if (package_prefix)
2071                     {
2072                       pp_string (buffer, "Interfaces.C.Strings.chars_ptr");
2073                       append_withs ("Interfaces.C.Strings", false);
2074                     }
2075                   else
2076                     pp_string (buffer, "chars_ptr");
2077                 }
2078               else
2079                 {
2080                   /* For now, handle all access-to-access or
2081                      access-to-unknown-structs as opaque system.address.  */
2082
2083                   tree type_name = TYPE_NAME (TREE_TYPE (node));
2084                   const_tree typ2 = !type ||
2085                     DECL_P (type) ? type : TYPE_NAME (type);
2086                   const_tree underlying_type =
2087                     get_underlying_decl (TREE_TYPE (node));
2088
2089                   if (TREE_CODE (TREE_TYPE (node)) == POINTER_TYPE
2090                       /* Pointer to pointer.  */
2091
2092                       || (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
2093                           && (!underlying_type
2094                               || !TYPE_FIELDS (TREE_TYPE (underlying_type))))
2095                       /* Pointer to opaque structure.  */
2096
2097                       || underlying_type == NULL_TREE
2098                       || (!typ2
2099                           && !TREE_VISITED (underlying_type)
2100                           && !TREE_VISITED (type_name)
2101                           && !is_tagged_type (TREE_TYPE (node))
2102                           && DECL_SOURCE_FILE (underlying_type)
2103                                == source_file_base)
2104                       || (type_name && typ2
2105                           && DECL_P (underlying_type)
2106                           && DECL_P (typ2)
2107                           && decl_sloc (underlying_type, true)
2108                                > decl_sloc (typ2, true)
2109                           && DECL_SOURCE_FILE (underlying_type)
2110                                == DECL_SOURCE_FILE (typ2)))
2111                     {
2112                       if (package_prefix)
2113                         {
2114                           append_withs ("System", false);
2115                           if (!name_only)
2116                             pp_string (buffer, "new ");
2117                           pp_string (buffer, "System.Address");
2118                         }
2119                       else
2120                         pp_string (buffer, "address");
2121                       return spc;
2122                     }
2123
2124                   if (!package_prefix)
2125                     pp_string (buffer, "access");
2126                   else if (AGGREGATE_TYPE_P (TREE_TYPE (node)))
2127                     {
2128                       if (!type || TREE_CODE (type) != FUNCTION_DECL)
2129                         {
2130                           pp_string (buffer, "access ");
2131                           is_access = true;
2132
2133                           if (quals & TYPE_QUAL_CONST)
2134                             pp_string (buffer, "constant ");
2135                           else if (!name_only)
2136                             pp_string (buffer, "all ");
2137                         }
2138                       else if (quals & TYPE_QUAL_CONST)
2139                         pp_string (buffer, "in ");
2140                       else
2141                         {
2142                           is_access = true;
2143                           pp_string (buffer, "access ");
2144                           /* ??? should be configurable: access or in out.  */
2145                         }
2146                     }
2147                   else
2148                     {
2149                       is_access = true;
2150                       pp_string (buffer, "access ");
2151
2152                       if (!name_only)
2153                         pp_string (buffer, "all ");
2154                     }
2155
2156                   if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (node))
2157                       && type_name != NULL_TREE)
2158                     dump_generic_ada_node
2159                       (buffer, type_name,
2160                        TREE_TYPE (node), spc, is_access, true);
2161                   else
2162                     dump_generic_ada_node
2163                       (buffer, TREE_TYPE (node), TREE_TYPE (node),
2164                        spc, 0, true);
2165                 }
2166             }
2167         }
2168       break;
2169
2170     case ARRAY_TYPE:
2171       if (name_only)
2172         dump_generic_ada_node
2173           (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2174       else
2175         dump_ada_array_type (buffer, node, spc);
2176       break;
2177
2178     case RECORD_TYPE:
2179     case UNION_TYPE:
2180     case QUAL_UNION_TYPE:
2181       if (name_only)
2182         {
2183           if (TYPE_NAME (node))
2184             dump_generic_ada_node
2185               (buffer, TYPE_NAME (node), node, spc, limited_access, true);
2186           else
2187             {
2188               pp_string (buffer, "anon_");
2189               pp_scalar (buffer, "%d", TYPE_UID (node));
2190             }
2191         }
2192       else
2193         print_ada_struct_decl (buffer, node, type, spc, true);
2194       break;
2195
2196     case INTEGER_CST:
2197       /* We treat the upper half of the sizetype range as negative.  This
2198          is consistent with the internal treatment and makes it possible
2199          to generate the (0 .. -1) range for flexible array members.  */
2200       if (TREE_TYPE (node) == sizetype)
2201         node = fold_convert (ssizetype, node);
2202       if (tree_fits_shwi_p (node))
2203         pp_wide_integer (buffer, tree_to_shwi (node));
2204       else if (tree_fits_uhwi_p (node))
2205         pp_unsigned_wide_integer (buffer, tree_to_uhwi (node));
2206       else
2207         {
2208           wide_int val = node;
2209           int i;
2210           if (wi::neg_p (val))
2211             {
2212               pp_minus (buffer);
2213               val = -val;
2214             }
2215           sprintf (pp_buffer (buffer)->digit_buffer,
2216                    "16#%" HOST_WIDE_INT_PRINT "x",
2217                    val.elt (val.get_len () - 1));
2218           for (i = val.get_len () - 2; i >= 0; i--)
2219             sprintf (pp_buffer (buffer)->digit_buffer,
2220                      HOST_WIDE_INT_PRINT_PADDED_HEX, val.elt (i));
2221           pp_string (buffer, pp_buffer (buffer)->digit_buffer);
2222         }
2223       break;
2224
2225     case REAL_CST:
2226     case FIXED_CST:
2227     case COMPLEX_CST:
2228     case STRING_CST:
2229     case VECTOR_CST:
2230       return 0;
2231
2232     case FUNCTION_DECL:
2233     case CONST_DECL:
2234       dump_ada_decl_name (buffer, node, limited_access);
2235       break;
2236
2237     case TYPE_DECL:
2238       if (DECL_IS_BUILTIN (node))
2239         {
2240           /* Don't print the declaration of built-in types.  */
2241
2242           if (name_only)
2243             {
2244               /* If we're in the middle of a declaration, defaults to
2245                  System.Address.  */
2246               if (package_prefix)
2247                 {
2248                   append_withs ("System", false);
2249                   pp_string (buffer, "System.Address");
2250                 }
2251               else
2252                 pp_string (buffer, "address");
2253             }
2254           break;
2255         }
2256
2257       if (name_only)
2258         dump_ada_decl_name (buffer, node, limited_access);
2259       else
2260         {
2261           if (is_tagged_type (TREE_TYPE (node)))
2262             {
2263               tree tmp = TYPE_FIELDS (TREE_TYPE (node));
2264               int first = 1;
2265
2266               /* Look for ancestors.  */
2267               for (; tmp; tmp = TREE_CHAIN (tmp))
2268                 {
2269                   if (!DECL_NAME (tmp) && is_tagged_type (TREE_TYPE (tmp)))
2270                     {
2271                       if (first)
2272                         {
2273                           pp_string (buffer, "limited new ");
2274                           first = 0;
2275                         }
2276                       else
2277                         pp_string (buffer, " and ");
2278
2279                       dump_ada_decl_name
2280                         (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
2281                     }
2282                 }
2283
2284               pp_string (buffer, first ? "tagged limited " : " with ");
2285             }
2286           else if (has_nontrivial_methods (TREE_TYPE (node)))
2287             pp_string (buffer, "limited ");
2288
2289           dump_generic_ada_node
2290             (buffer, TREE_TYPE (node), type, spc, false, false);
2291         }
2292       break;
2293
2294     case VAR_DECL:
2295     case PARM_DECL:
2296     case FIELD_DECL:
2297     case NAMESPACE_DECL:
2298       dump_ada_decl_name (buffer, node, false);
2299       break;
2300
2301     default:
2302       /* Ignore other nodes (e.g. expressions).  */
2303       return 0;
2304     }
2305
2306   return 1;
2307 }
2308
2309 /* Dump in BUFFER NODE's methods.  SPC is the indentation level.  Return 1 if
2310    methods were printed, 0 otherwise.
2311
2312    We do it in 2 passes: first, the regular methods, i.e. non-static member
2313    functions, are output immediately within the package created for the class
2314    so that they are considered as primitive operations in Ada; second, the
2315    static member functions are output in a nested package so that they are
2316    _not_ considered as primitive operations in Ada.
2317
2318    This approach is necessary because the formers have the implicit 'this'
2319    pointer whereas the latters don't and, on 32-bit x86/Windows, the calling
2320    conventions for the 'this' pointer are special.  Therefore, the compiler
2321    needs to be able to differentiate regular methods (with 'this' pointer)
2322    from static member functions that take a pointer to the class as first
2323    parameter.  */
2324
2325 static int
2326 print_ada_methods (pretty_printer *buffer, tree node, int spc)
2327 {
2328   bool has_static_methods = false;
2329   tree t;
2330   int res;
2331
2332   if (!has_nontrivial_methods (node))
2333     return 0;
2334
2335   pp_semicolon (buffer);
2336
2337   /* First pass: the regular methods.  */
2338   res = 1;
2339   for (t = TYPE_METHODS (node); t; t = TREE_CHAIN (t))
2340     {
2341       if (TREE_CODE (TREE_TYPE (t)) != METHOD_TYPE)
2342         {
2343           has_static_methods = true;
2344           continue;
2345         }
2346
2347       if (res)
2348         {
2349           pp_newline (buffer);
2350           pp_newline (buffer);
2351         }
2352
2353       res = print_ada_declaration (buffer, t, node, spc);
2354     }
2355
2356   if (!has_static_methods)
2357     return 1;
2358
2359   pp_newline (buffer);
2360   newline_and_indent (buffer, spc);
2361
2362   /* Second pass: the static member functions.  */
2363   pp_string (buffer, "package Static is");
2364   pp_newline (buffer);
2365   spc += INDENT_INCR;
2366
2367   res = 0;
2368   for (t = TYPE_METHODS (node); t; t = TREE_CHAIN (t))
2369     {
2370       if (TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE)
2371         continue;
2372
2373       if (res)
2374         {
2375           pp_newline (buffer);
2376           pp_newline (buffer);
2377         }
2378
2379       res = print_ada_declaration (buffer, t, node, spc);
2380     }
2381
2382   spc -= INDENT_INCR;
2383   newline_and_indent (buffer, spc);
2384   pp_string (buffer, "end;");
2385
2386   /* In order to save the clients from adding a second use clause for the
2387      nested package, we generate renamings for the static member functions
2388      in the package created for the class.  */
2389   for (t = TYPE_METHODS (node); t; t = TREE_CHAIN (t))
2390     {
2391       bool is_function;
2392
2393       if (TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE)
2394         continue;
2395
2396       pp_newline (buffer);
2397       newline_and_indent (buffer, spc);
2398
2399       if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))))
2400         {
2401           pp_string (buffer, "procedure ");
2402           is_function = false;
2403         }
2404       else
2405         {
2406           pp_string (buffer, "function ");
2407           is_function = true;
2408         }
2409
2410       dump_ada_decl_name (buffer, t, false);
2411       dump_ada_function_declaration (buffer, t, false, false, false, spc);
2412
2413       if (is_function)
2414         {
2415           pp_string (buffer, " return ");
2416           dump_generic_ada_node (buffer, TREE_TYPE (TREE_TYPE (t)), node,
2417                                  spc, false, true);
2418         }
2419
2420        pp_string (buffer, " renames Static.");
2421        dump_ada_decl_name (buffer, t, false);
2422        pp_semicolon (buffer);
2423     }
2424
2425   return 1;
2426 }
2427
2428 /* Dump in BUFFER anonymous types nested inside T's definition.
2429    PARENT is the parent node of T.
2430    FORWARD indicates whether a forward declaration of T should be generated.
2431    SPC is the indentation level.  */
2432
2433 static void
2434 dump_nested_types (pretty_printer *buffer, tree t, tree parent, bool forward,
2435                    int spc)
2436 {
2437   tree field, outer, decl;
2438
2439   /* Avoid recursing over the same tree.  */
2440   if (TREE_VISITED (t))
2441     return;
2442
2443   /* Find possible anonymous arrays/unions/structs recursively.  */
2444
2445   outer = TREE_TYPE (t);
2446
2447   if (outer == NULL_TREE)
2448     return;
2449
2450   if (forward)
2451     {
2452       pp_string (buffer, "type ");
2453       dump_generic_ada_node (buffer, t, t, spc, false, true);
2454       pp_semicolon (buffer);
2455       newline_and_indent (buffer, spc);
2456       TREE_VISITED (t) = 1;
2457     }
2458
2459   field = TYPE_FIELDS (outer);
2460   while (field)
2461     {
2462       if ((TREE_TYPE (field) != outer
2463            || (TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE
2464                && TREE_TYPE (TREE_TYPE (field)) != outer))
2465            && (!TYPE_NAME (TREE_TYPE (field))
2466               || (TREE_CODE (field) == TYPE_DECL
2467                   && DECL_NAME (field) != DECL_NAME (t)
2468                   && TYPE_NAME (TREE_TYPE (field)) != TYPE_NAME (outer))))
2469         {
2470           switch (TREE_CODE (TREE_TYPE (field)))
2471             {
2472               case POINTER_TYPE:
2473                 decl = TREE_TYPE (TREE_TYPE (field));
2474
2475                 if (TREE_CODE (decl) == FUNCTION_TYPE)
2476                   for (decl = TREE_TYPE (decl);
2477                        decl && TREE_CODE (decl) == POINTER_TYPE;
2478                        decl = TREE_TYPE (decl))
2479                     ;
2480
2481                 decl = get_underlying_decl (decl);
2482
2483                 if (decl
2484                     && DECL_P (decl)
2485                     && decl_sloc (decl, true) > decl_sloc (t, true)
2486                     && DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t)
2487                     && !TREE_VISITED (decl)
2488                     && !DECL_IS_BUILTIN (decl)
2489                     && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl))
2490                         || TYPE_FIELDS (TREE_TYPE (decl))))
2491                   {
2492                     /* Generate forward declaration.  */
2493
2494                     pp_string (buffer, "type ");
2495                     dump_generic_ada_node (buffer, decl, 0, spc, false, true);
2496                     pp_semicolon (buffer);
2497                     newline_and_indent (buffer, spc);
2498
2499                     /* Ensure we do not generate duplicate forward
2500                        declarations for this type.  */
2501                     TREE_VISITED (decl) = 1;
2502                   }
2503                 break;
2504
2505               case ARRAY_TYPE:
2506                 /* Special case char arrays.  */
2507                 if (is_char_array (field))
2508                   pp_string (buffer, "sub");
2509
2510                 pp_string (buffer, "type ");
2511                 dump_ada_double_name (buffer, parent, field, "_array is ");
2512                 dump_ada_array_type (buffer, field, spc);
2513                 pp_semicolon (buffer);
2514                 newline_and_indent (buffer, spc);
2515                 break;
2516
2517               case UNION_TYPE:
2518                 TREE_VISITED (t) = 1;
2519                 dump_nested_types (buffer, field, t, false, spc);
2520
2521                 pp_string (buffer, "type ");
2522
2523                 if (TYPE_NAME (TREE_TYPE (field)))
2524                   {
2525                     dump_generic_ada_node
2526                       (buffer, TYPE_NAME (TREE_TYPE (field)), 0, spc, false,
2527                        true);
2528                     pp_string (buffer, " (discr : unsigned := 0) is ");
2529                     print_ada_struct_decl
2530                       (buffer, TREE_TYPE (field), t, spc, false);
2531
2532                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2533                     dump_generic_ada_node
2534                       (buffer, TREE_TYPE (field), 0, spc, false, true);
2535                     pp_string (buffer, ");");
2536                     newline_and_indent (buffer, spc);
2537
2538                     pp_string (buffer, "pragma Unchecked_Union (");
2539                     dump_generic_ada_node
2540                       (buffer, TREE_TYPE (field), 0, spc, false, true);
2541                     pp_string (buffer, ");");
2542                   }
2543                 else
2544                   {
2545                     dump_ada_double_name
2546                       (buffer, parent, field,
2547                         "_union (discr : unsigned := 0) is ");
2548                     print_ada_struct_decl
2549                       (buffer, TREE_TYPE (field), t, spc, false);
2550                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2551                     dump_ada_double_name (buffer, parent, field, "_union);");
2552                     newline_and_indent (buffer, spc);
2553
2554                     pp_string (buffer, "pragma Unchecked_Union (");
2555                     dump_ada_double_name (buffer, parent, field, "_union);");
2556                   }
2557
2558                 newline_and_indent (buffer, spc);
2559                 break;
2560
2561               case RECORD_TYPE:
2562                 if (TYPE_NAME (TREE_TYPE (t)) && !TREE_VISITED (t))
2563                   {
2564                     pp_string (buffer, "type ");
2565                     dump_generic_ada_node
2566                       (buffer, t, parent, spc, false, true);
2567                     pp_semicolon (buffer);
2568                     newline_and_indent (buffer, spc);
2569                   }
2570
2571                 TREE_VISITED (t) = 1;
2572                 dump_nested_types (buffer, field, t, false, spc);
2573                 pp_string (buffer, "type ");
2574
2575                 if (TYPE_NAME (TREE_TYPE (field)))
2576                   {
2577                     dump_generic_ada_node
2578                       (buffer, TREE_TYPE (field), 0, spc, false, true);
2579                     pp_string (buffer, " is ");
2580                     print_ada_struct_decl
2581                       (buffer, TREE_TYPE (field), t, spc, false);
2582                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2583                     dump_generic_ada_node
2584                       (buffer, TREE_TYPE (field), 0, spc, false, true);
2585                     pp_string (buffer, ");");
2586                   }
2587                 else
2588                   {
2589                     dump_ada_double_name
2590                       (buffer, parent, field, "_struct is ");
2591                     print_ada_struct_decl
2592                       (buffer, TREE_TYPE (field), t, spc, false);
2593                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2594                     dump_ada_double_name (buffer, parent, field, "_struct);");
2595                   }
2596
2597                 newline_and_indent (buffer, spc);
2598                 break;
2599
2600               default:
2601                 break;
2602             }
2603         }
2604       field = TREE_CHAIN (field);
2605     }
2606
2607   TREE_VISITED (t) = 1;
2608 }
2609
2610 /* Dump in BUFFER constructor spec corresponding to T.  */
2611
2612 static void
2613 print_constructor (pretty_printer *buffer, tree t)
2614 {
2615   tree decl_name = DECL_NAME (DECL_ORIGIN (t));
2616
2617   pp_string (buffer, "New_");
2618   pp_ada_tree_identifier (buffer, decl_name, t, false);
2619 }
2620
2621 /* Dump in BUFFER destructor spec corresponding to T.  */
2622
2623 static void
2624 print_destructor (pretty_printer *buffer, tree t)
2625 {
2626   tree decl_name = DECL_NAME (DECL_ORIGIN (t));
2627
2628   pp_string (buffer, "Delete_");
2629   pp_ada_tree_identifier (buffer, decl_name, t, false);
2630 }
2631
2632 /* Return the name of type T.  */
2633
2634 static const char *
2635 type_name (tree t)
2636 {
2637   tree n = TYPE_NAME (t);
2638
2639   if (TREE_CODE (n) == IDENTIFIER_NODE)
2640     return IDENTIFIER_POINTER (n);
2641   else
2642     return IDENTIFIER_POINTER (DECL_NAME (n));
2643 }
2644
2645 /* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
2646    SPC is the indentation level.  Return 1 if a declaration was printed,
2647    0 otherwise.  */
2648
2649 static int
2650 print_ada_declaration (pretty_printer *buffer, tree t, tree type, int spc)
2651 {
2652   int is_var = 0, need_indent = 0;
2653   int is_class = false;
2654   tree name = TYPE_NAME (TREE_TYPE (t));
2655   tree decl_name = DECL_NAME (t);
2656   tree orig = NULL_TREE;
2657
2658   if (cpp_check && cpp_check (t, IS_TEMPLATE))
2659     return dump_ada_template (buffer, t, spc);
2660
2661   if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2662     /* Skip enumeral values: will be handled as part of the type itself.  */
2663     return 0;
2664
2665   if (TREE_CODE (t) == TYPE_DECL)
2666     {
2667       orig = DECL_ORIGINAL_TYPE (t);
2668
2669       if (orig && TYPE_STUB_DECL (orig))
2670         {
2671           tree stub = TYPE_STUB_DECL (orig);
2672           tree typ = TREE_TYPE (stub);
2673
2674           if (TYPE_NAME (typ))
2675             {
2676               /* If types have same representation, and same name (ignoring
2677                  casing), then ignore the second type.  */
2678               if (type_name (typ) == type_name (TREE_TYPE (t))
2679                   || !strcasecmp (type_name (typ), type_name (TREE_TYPE (t))))
2680                 return 0;
2681
2682               INDENT (spc);
2683
2684               if (RECORD_OR_UNION_TYPE_P (typ) && !TYPE_FIELDS (typ))
2685                 {
2686                   pp_string (buffer, "--  skipped empty struct ");
2687                   dump_generic_ada_node (buffer, t, type, spc, false, true);
2688                 }
2689               else
2690                 {
2691                   if (!TREE_VISITED (stub)
2692                       && DECL_SOURCE_FILE (stub) == source_file_base)
2693                     dump_nested_types (buffer, stub, stub, true, spc);
2694
2695                   pp_string (buffer, "subtype ");
2696                   dump_generic_ada_node (buffer, t, type, spc, false, true);
2697                   pp_string (buffer, " is ");
2698                   dump_generic_ada_node (buffer, typ, type, spc, false, true);
2699                   pp_semicolon (buffer);
2700                 }
2701               return 1;
2702             }
2703         }
2704
2705       /* Skip unnamed or anonymous structs/unions/enum types.  */
2706       if (!orig && !decl_name && !name)
2707         {
2708           tree tmp;
2709           location_t sloc;
2710
2711           if (cpp_check || TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2712             return 0;
2713
2714           if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
2715             {
2716               /* Search next items until finding a named type decl.  */
2717               sloc = decl_sloc_common (t, true, true);
2718
2719               for (tmp = TREE_CHAIN (t); tmp; tmp = TREE_CHAIN (tmp))
2720                 {
2721                   if (TREE_CODE (tmp) == TYPE_DECL
2722                       && (DECL_NAME (tmp) || TYPE_NAME (TREE_TYPE (tmp))))
2723                     {
2724                       /* If same sloc, it means we can ignore the anonymous
2725                          struct.  */
2726                       if (decl_sloc_common (tmp, true, true) == sloc)
2727                         return 0;
2728                       else
2729                         break;
2730                     }
2731                 }
2732               if (tmp == NULL)
2733                 return 0;
2734             }
2735         }
2736
2737       if (!orig
2738           && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE
2739           && decl_name
2740           && (*IDENTIFIER_POINTER (decl_name) == '.'
2741               || *IDENTIFIER_POINTER (decl_name) == '$'))
2742         /* Skip anonymous enum types (duplicates of real types).  */
2743         return 0;
2744
2745       INDENT (spc);
2746
2747       switch (TREE_CODE (TREE_TYPE (t)))
2748         {
2749           case RECORD_TYPE:
2750           case UNION_TYPE:
2751           case QUAL_UNION_TYPE:
2752             /* Skip empty structs (typically forward references to real
2753                structs).  */
2754             if (!TYPE_FIELDS (TREE_TYPE (t)))
2755               {
2756                 pp_string (buffer, "--  skipped empty struct ");
2757                 dump_generic_ada_node (buffer, t, type, spc, false, true);
2758                 return 1;
2759               }
2760
2761             if (decl_name
2762                 && (*IDENTIFIER_POINTER (decl_name) == '.'
2763                     || *IDENTIFIER_POINTER (decl_name) == '$'))
2764               {
2765                 pp_string (buffer, "--  skipped anonymous struct ");
2766                 dump_generic_ada_node (buffer, t, type, spc, false, true);
2767                 TREE_VISITED (t) = 1;
2768                 return 1;
2769               }
2770
2771             if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2772               pp_string (buffer, "subtype ");
2773             else
2774               {
2775                 dump_nested_types (buffer, t, t, false, spc);
2776
2777                 if (separate_class_package (t))
2778                   {
2779                     is_class = true;
2780                     pp_string (buffer, "package Class_");
2781                     dump_generic_ada_node (buffer, t, type, spc, false, true);
2782                     pp_string (buffer, " is");
2783                     spc += INDENT_INCR;
2784                     newline_and_indent (buffer, spc);
2785                   }
2786
2787                 pp_string (buffer, "type ");
2788               }
2789             break;
2790
2791           case ARRAY_TYPE:
2792           case POINTER_TYPE:
2793           case REFERENCE_TYPE:
2794             if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2795                 || is_char_array (t))
2796               pp_string (buffer, "subtype ");
2797             else
2798               pp_string (buffer, "type ");
2799             break;
2800
2801           case FUNCTION_TYPE:
2802             pp_string (buffer, "--  skipped function type ");
2803             dump_generic_ada_node (buffer, t, type, spc, false, true);
2804             return 1;
2805             break;
2806
2807           case ENUMERAL_TYPE:
2808             if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2809                 || !is_simple_enum (TREE_TYPE (t)))
2810               pp_string (buffer, "subtype ");
2811             else
2812               pp_string (buffer, "type ");
2813             break;
2814
2815           default:
2816             pp_string (buffer, "subtype ");
2817         }
2818       TREE_VISITED (t) = 1;
2819     }
2820   else
2821     {
2822       if (TREE_CODE (t) == VAR_DECL
2823           && decl_name
2824           && *IDENTIFIER_POINTER (decl_name) == '_')
2825         return 0;
2826
2827       need_indent = 1;
2828     }
2829
2830   /* Print the type and name.  */
2831   if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
2832     {
2833       if (need_indent)
2834         INDENT (spc);
2835
2836       /* Print variable's name.  */
2837       dump_generic_ada_node (buffer, t, type, spc, false, true);
2838
2839       if (TREE_CODE (t) == TYPE_DECL)
2840         {
2841           pp_string (buffer, " is ");
2842
2843           if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2844             dump_generic_ada_node
2845               (buffer, TYPE_NAME (orig), type, spc, false, true);
2846           else
2847             dump_ada_array_type (buffer, t, spc);
2848         }
2849       else
2850         {
2851           tree tmp = TYPE_NAME (TREE_TYPE (t));
2852
2853           if (spc == INDENT_INCR || TREE_STATIC (t))
2854             is_var = 1;
2855
2856           pp_string (buffer, " : ");
2857
2858           if (tmp)
2859             {
2860               if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE
2861                   && TREE_CODE (tmp) != INTEGER_TYPE)
2862                 pp_string (buffer, "aliased ");
2863
2864               dump_generic_ada_node (buffer, tmp, type, spc, false, true);
2865             }
2866           else
2867             {
2868               pp_string (buffer, "aliased ");
2869
2870               if (!type)
2871                 dump_ada_array_type (buffer, t, spc);
2872               else
2873                 dump_ada_double_name (buffer, type, t, "_array");
2874             }
2875         }
2876     }
2877   else if (TREE_CODE (t) == FUNCTION_DECL)
2878     {
2879       bool is_function, is_abstract_class = false;
2880       bool is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE;
2881       tree decl_name = DECL_NAME (t);
2882       bool is_abstract = false;
2883       bool is_constructor = false;
2884       bool is_destructor = false;
2885       bool is_copy_constructor = false;
2886
2887       if (!decl_name)
2888         return 0;
2889
2890       if (cpp_check)
2891         {
2892           is_abstract = cpp_check (t, IS_ABSTRACT);
2893           is_constructor = cpp_check (t, IS_CONSTRUCTOR);
2894           is_destructor = cpp_check (t, IS_DESTRUCTOR);
2895           is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR);
2896         }
2897
2898       /* Skip copy constructors: some are internal only, and those that are
2899          not cannot be called easily from Ada anyway.  */
2900       if (is_copy_constructor)
2901         return 0;
2902
2903       if (is_constructor || is_destructor)
2904         {
2905           /* Only consider constructors/destructors for complete objects.  */
2906           if (strncmp (IDENTIFIER_POINTER (decl_name), "__comp", 6) != 0)
2907             return 0;
2908         }
2909
2910       /* If this function has an entry in the vtable, we cannot omit it.  */
2911       else if (!DECL_VINDEX (t) && *IDENTIFIER_POINTER (decl_name) == '_')
2912         {
2913           INDENT (spc);
2914           pp_string (buffer, "--  skipped func ");
2915           pp_string (buffer, IDENTIFIER_POINTER (decl_name));
2916           return 1;
2917         }
2918
2919       if (need_indent)
2920         INDENT (spc);
2921
2922       if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))) && !is_constructor)
2923         {
2924           pp_string (buffer, "procedure ");
2925           is_function = false;
2926         }
2927       else
2928         {
2929           pp_string (buffer, "function ");
2930           is_function = true;
2931         }
2932
2933       if (is_constructor)
2934         print_constructor (buffer, t);
2935       else if (is_destructor)
2936         print_destructor (buffer, t);
2937       else
2938         dump_ada_decl_name (buffer, t, false);
2939
2940       dump_ada_function_declaration
2941         (buffer, t, is_method, is_constructor, is_destructor, spc);
2942
2943       if (is_function)
2944         {
2945           pp_string (buffer, " return ");
2946           tree ret_type
2947             = is_constructor ? DECL_CONTEXT (t) : TREE_TYPE (TREE_TYPE (t));
2948           dump_generic_ada_node (buffer, ret_type, type, spc, false, true);
2949         }
2950
2951       if (is_constructor
2952           && RECORD_OR_UNION_TYPE_P (type)
2953           && TYPE_METHODS (type))
2954         {
2955           tree tmp;
2956
2957           for (tmp = TYPE_METHODS (type); tmp; tmp = TREE_CHAIN (tmp))
2958             if (cpp_check (tmp, IS_ABSTRACT))
2959               {
2960                 is_abstract_class = true;
2961                 break;
2962               }
2963         }
2964
2965       if (is_abstract || is_abstract_class)
2966         pp_string (buffer, " is abstract");
2967
2968       pp_semicolon (buffer);
2969       pp_string (buffer, "  -- ");
2970       dump_sloc (buffer, t);
2971
2972       if (is_abstract || !DECL_ASSEMBLER_NAME (t))
2973         return 1;
2974
2975       newline_and_indent (buffer, spc);
2976
2977       if (is_constructor)
2978         {
2979           pp_string (buffer, "pragma CPP_Constructor (");
2980           print_constructor (buffer, t);
2981           pp_string (buffer, ", \"");
2982           pp_asm_name (buffer, t);
2983           pp_string (buffer, "\");");
2984         }
2985       else if (is_destructor)
2986         {
2987           pp_string (buffer, "pragma Import (CPP, ");
2988           print_destructor (buffer, t);
2989           pp_string (buffer, ", \"");
2990           pp_asm_name (buffer, t);
2991           pp_string (buffer, "\");");
2992         }
2993       else
2994         {
2995           dump_ada_import (buffer, t);
2996         }
2997
2998       return 1;
2999     }
3000   else if (TREE_CODE (t) == TYPE_DECL && !DECL_ORIGINAL_TYPE (t))
3001     {
3002       int is_interface = 0;
3003       int is_abstract_record = 0;
3004
3005       if (need_indent)
3006         INDENT (spc);
3007
3008       /* Anonymous structs/unions */
3009       dump_generic_ada_node (buffer, TREE_TYPE (t), t, spc, false, true);
3010
3011       if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
3012           || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE)
3013         {
3014           pp_string (buffer, " (discr : unsigned := 0)");
3015         }
3016
3017       pp_string (buffer, " is ");
3018
3019       /* Check whether we have an Ada interface compatible class.  */
3020       if (cpp_check
3021           && RECORD_OR_UNION_TYPE_P (TREE_TYPE (t))
3022           && TYPE_METHODS (TREE_TYPE (t)))
3023         {
3024           int num_fields = 0;
3025           tree tmp;
3026
3027           /* Check that there are no fields other than the virtual table.  */
3028           for (tmp = TYPE_FIELDS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
3029             {
3030               if (TREE_CODE (tmp) == TYPE_DECL)
3031                 continue;
3032               num_fields++;
3033             }
3034
3035           if (num_fields == 1)
3036             is_interface = 1;
3037
3038           /* Also check that there are only virtual methods.  */
3039           for (tmp = TYPE_METHODS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
3040             {
3041               if (cpp_check (tmp, IS_ABSTRACT))
3042                 is_abstract_record = 1;
3043               else
3044                 is_interface = 0;
3045             }
3046         }
3047
3048       TREE_VISITED (t) = 1;
3049       if (is_interface)
3050         {
3051           pp_string (buffer, "limited interface;  -- ");
3052           dump_sloc (buffer, t);
3053           newline_and_indent (buffer, spc);
3054           pp_string (buffer, "pragma Import (CPP, ");
3055           dump_generic_ada_node
3056             (buffer, TYPE_NAME (TREE_TYPE (t)), type, spc, false, true);
3057           pp_right_paren (buffer);
3058
3059           print_ada_methods (buffer, TREE_TYPE (t), spc);
3060         }
3061       else
3062         {
3063           if (is_abstract_record)
3064             pp_string (buffer, "abstract ");
3065           dump_generic_ada_node (buffer, t, t, spc, false, false);
3066         }
3067     }
3068   else
3069     {
3070       if (need_indent)
3071         INDENT (spc);
3072
3073       if (TREE_CODE (t) == FIELD_DECL && DECL_NAME (t))
3074         check_name (buffer, t);
3075
3076       /* Print variable/type's name.  */
3077       dump_generic_ada_node (buffer, t, t, spc, false, true);
3078
3079       if (TREE_CODE (t) == TYPE_DECL)
3080         {
3081           tree orig = DECL_ORIGINAL_TYPE (t);
3082           int is_subtype = orig && TYPE_NAME (orig) && orig != TREE_TYPE (t);
3083
3084           if (!is_subtype
3085               && (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
3086                   || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE))
3087             pp_string (buffer, " (discr : unsigned := 0)");
3088
3089           pp_string (buffer, " is ");
3090
3091           dump_generic_ada_node (buffer, orig, t, spc, false, is_subtype);
3092         }
3093       else
3094         {
3095           if (spc == INDENT_INCR || TREE_STATIC (t))
3096             is_var = 1;
3097
3098           pp_string (buffer, " : ");
3099
3100           /* Print type declaration.  */
3101
3102           if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
3103               && !TYPE_NAME (TREE_TYPE (t)))
3104             {
3105               dump_ada_double_name (buffer, type, t, "_union");
3106             }
3107           else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
3108             {
3109               if (TREE_CODE (TREE_TYPE (t)) == RECORD_TYPE)
3110                 pp_string (buffer, "aliased ");
3111
3112               dump_generic_ada_node
3113                 (buffer, TREE_TYPE (t), t, spc, false, true);
3114             }
3115           else
3116             {
3117               if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE
3118                   && (TYPE_NAME (TREE_TYPE (t))
3119                       || TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE))
3120                 pp_string (buffer, "aliased ");
3121
3122               dump_generic_ada_node
3123                 (buffer, TREE_TYPE (t), TREE_TYPE (t), spc, false, true);
3124             }
3125         }
3126     }
3127
3128   if (is_class)
3129     {
3130       spc -= INDENT_INCR;
3131       newline_and_indent (buffer, spc);
3132       pp_string (buffer, "end;");
3133       newline_and_indent (buffer, spc);
3134       pp_string (buffer, "use Class_");
3135       dump_generic_ada_node (buffer, t, type, spc, false, true);
3136       pp_semicolon (buffer);
3137       pp_newline (buffer);
3138
3139       /* All needed indentation/newline performed already, so return 0.  */
3140       return 0;
3141     }
3142   else
3143     {
3144       pp_string (buffer, ";  -- ");
3145       dump_sloc (buffer, t);
3146     }
3147
3148   if (is_var)
3149     {
3150       newline_and_indent (buffer, spc);
3151       dump_ada_import (buffer, t);
3152     }
3153
3154   return 1;
3155 }
3156
3157 /* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
3158    with Ada syntax.  SPC is the indentation level.  If DISPLAY_CONVENTION is
3159    true, also print the pragma Convention for NODE.  */
3160
3161 static void
3162 print_ada_struct_decl (pretty_printer *buffer, tree node, tree type, int spc,
3163                        bool display_convention)
3164 {
3165   tree tmp;
3166   const bool is_union
3167     = TREE_CODE (node) == UNION_TYPE || TREE_CODE (node) == QUAL_UNION_TYPE;
3168   char buf[32];
3169   int field_num = 0;
3170   int field_spc = spc + INDENT_INCR;
3171   int need_semicolon;
3172
3173   bitfield_used = false;
3174
3175   if (!TYPE_FIELDS (node))
3176     pp_string (buffer, "null record;");
3177   else
3178     {
3179       pp_string (buffer, "record");
3180
3181       /* Print the contents of the structure.  */
3182
3183       if (is_union)
3184         {
3185           newline_and_indent (buffer, spc + INDENT_INCR);
3186           pp_string (buffer, "case discr is");
3187           field_spc = spc + INDENT_INCR * 3;
3188         }
3189
3190       pp_newline (buffer);
3191
3192       /* Print the non-static fields of the structure.  */
3193       for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3194         {
3195           /* Add parent field if needed.  */
3196           if (!DECL_NAME (tmp))
3197             {
3198               if (!is_tagged_type (TREE_TYPE (tmp)))
3199                 {
3200                   if (!TYPE_NAME (TREE_TYPE (tmp)))
3201                     print_ada_declaration (buffer, tmp, type, field_spc);
3202                   else
3203                     {
3204                       INDENT (field_spc);
3205
3206                       if (field_num == 0)
3207                         pp_string (buffer, "parent : aliased ");
3208                       else
3209                         {
3210                           sprintf (buf, "field_%d : aliased ", field_num + 1);
3211                           pp_string (buffer, buf);
3212                         }
3213                       dump_ada_decl_name
3214                         (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
3215                       pp_semicolon (buffer);
3216                     }
3217                   pp_newline (buffer);
3218                   field_num++;
3219                 }
3220             }
3221           /* Avoid printing the structure recursively.  */
3222           else if ((TREE_TYPE (tmp) != node
3223                    || (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3224                        && TREE_TYPE (TREE_TYPE (tmp)) != node))
3225                    && TREE_CODE (tmp) != TYPE_DECL
3226                    && !TREE_STATIC (tmp))
3227             {
3228               /* Skip internal virtual table field.  */
3229               if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp)), "_vptr", 5))
3230                 {
3231                   if (is_union)
3232                     {
3233                       if (TREE_CHAIN (tmp)
3234                           && TREE_TYPE (TREE_CHAIN (tmp)) != node
3235                           && TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL)
3236                         sprintf (buf, "when %d =>", field_num);
3237                       else
3238                         sprintf (buf, "when others =>");
3239
3240                       INDENT (spc + INDENT_INCR * 2);
3241                       pp_string (buffer, buf);
3242                       pp_newline (buffer);
3243                     }
3244
3245                   if (print_ada_declaration (buffer, tmp, type, field_spc))
3246                     {
3247                       pp_newline (buffer);
3248                       field_num++;
3249                     }
3250                 }
3251             }
3252         }
3253
3254       if (is_union)
3255         {
3256           INDENT (spc + INDENT_INCR);
3257           pp_string (buffer, "end case;");
3258           pp_newline (buffer);
3259         }
3260
3261       if (field_num == 0)
3262         {
3263           INDENT (spc + INDENT_INCR);
3264           pp_string (buffer, "null;");
3265           pp_newline (buffer);
3266         }
3267
3268       INDENT (spc);
3269       pp_string (buffer, "end record;");
3270     }
3271
3272   newline_and_indent (buffer, spc);
3273
3274   if (!display_convention)
3275     return;
3276
3277   if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type)))
3278     {
3279       if (has_nontrivial_methods (TREE_TYPE (type)))
3280         pp_string (buffer, "pragma Import (CPP, ");
3281       else
3282         pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
3283     }
3284   else
3285     pp_string (buffer, "pragma Convention (C, ");
3286
3287   package_prefix = false;
3288   dump_generic_ada_node (buffer, TREE_TYPE (type), type, spc, false, true);
3289   package_prefix = true;
3290   pp_right_paren (buffer);
3291
3292   if (is_union)
3293     {
3294       pp_semicolon (buffer);
3295       newline_and_indent (buffer, spc);
3296       pp_string (buffer, "pragma Unchecked_Union (");
3297
3298       dump_generic_ada_node (buffer, TREE_TYPE (type), type, spc, false, true);
3299       pp_right_paren (buffer);
3300     }
3301
3302   if (bitfield_used)
3303     {
3304       pp_semicolon (buffer);
3305       newline_and_indent (buffer, spc);
3306       pp_string (buffer, "pragma Pack (");
3307       dump_generic_ada_node
3308         (buffer, TREE_TYPE (type), type, spc, false, true);
3309       pp_right_paren (buffer);
3310       bitfield_used = false;
3311     }
3312
3313   need_semicolon = !print_ada_methods (buffer, node, spc);
3314
3315   /* Print the static fields of the structure, if any.  */
3316   for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3317     {
3318       if (DECL_NAME (tmp) && TREE_STATIC (tmp))
3319         {
3320           if (need_semicolon)
3321             {
3322               need_semicolon = false;
3323               pp_semicolon (buffer);
3324             }
3325           pp_newline (buffer);
3326           pp_newline (buffer);
3327           print_ada_declaration (buffer, tmp, type, spc);
3328         }
3329     }
3330 }
3331
3332 /* Dump all the declarations in SOURCE_FILE to an Ada spec.
3333    COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3334    nodes for SOURCE_FILE.  CHECK is used to perform C++ queries on nodes.  */
3335
3336 static void
3337 dump_ads (const char *source_file,
3338           void (*collect_all_refs)(const char *),
3339           int (*check)(tree, cpp_operation))
3340 {
3341   char *ads_name;
3342   char *pkg_name;
3343   char *s;
3344   FILE *f;
3345
3346   pkg_name = get_ada_package (source_file);
3347
3348   /* Construct the .ads filename and package name.  */
3349   ads_name = xstrdup (pkg_name);
3350
3351   for (s = ads_name; *s; s++)
3352     if (*s == '.')
3353       *s = '-';
3354     else
3355       *s = TOLOWER (*s);
3356
3357   ads_name = reconcat (ads_name, ads_name, ".ads", NULL);
3358
3359   /* Write out the .ads file.  */
3360   f = fopen (ads_name, "w");
3361   if (f)
3362     {
3363       pretty_printer pp;
3364
3365       pp_needs_newline (&pp) = true;
3366       pp.buffer->stream = f;
3367
3368       /* Dump all relevant macros.  */
3369       dump_ada_macros (&pp, source_file);
3370
3371       /* Reset the table of withs for this file.  */
3372       reset_ada_withs ();
3373
3374       (*collect_all_refs) (source_file);
3375
3376       /* Dump all references.  */
3377       cpp_check = check;
3378       dump_ada_nodes (&pp, source_file);
3379
3380       /* Requires Ada 2005 syntax, so generate corresponding pragma.
3381          Also, disable style checks since this file is auto-generated.  */
3382       fprintf (f, "pragma Ada_2005;\npragma Style_Checks (Off);\n\n");
3383
3384       /* Dump withs.  */
3385       dump_ada_withs (f);
3386
3387       fprintf (f, "\npackage %s is\n\n", pkg_name);
3388       pp_write_text_to_stream (&pp);
3389       /* ??? need to free pp */
3390       fprintf (f, "end %s;\n", pkg_name);
3391       fclose (f);
3392     }
3393
3394   free (ads_name);
3395   free (pkg_name);
3396 }
3397
3398 static const char **source_refs = NULL;
3399 static int source_refs_used = 0;
3400 static int source_refs_allocd = 0;
3401
3402 /* Add an entry for FILENAME to the table SOURCE_REFS.  */
3403
3404 void
3405 collect_source_ref (const char *filename)
3406 {
3407   int i;
3408
3409   if (!filename)
3410     return;
3411
3412   if (source_refs_allocd == 0)
3413     {
3414       source_refs_allocd = 1024;
3415       source_refs = XNEWVEC (const char *, source_refs_allocd);
3416     }
3417
3418   for (i = 0; i < source_refs_used; i++)
3419     if (filename == source_refs[i])
3420       return;
3421
3422   if (source_refs_used == source_refs_allocd)
3423     {
3424       source_refs_allocd *= 2;
3425       source_refs = XRESIZEVEC (const char *, source_refs, source_refs_allocd);
3426     }
3427
3428   source_refs[source_refs_used++] = filename;
3429 }
3430
3431 /* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
3432    using callbacks COLLECT_ALL_REFS and CHECK.
3433    COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3434    nodes for a given source file.
3435    CHECK is used to perform C++ queries on nodes, or NULL for the C
3436    front-end.  */
3437
3438 void
3439 dump_ada_specs (void (*collect_all_refs)(const char *),
3440                 int (*check)(tree, cpp_operation))
3441 {
3442   int i;
3443
3444   /* Iterate over the list of files to dump specs for */
3445   for (i = 0; i < source_refs_used; i++)
3446     dump_ads (source_refs[i], collect_all_refs, check);
3447
3448   /* Free files table.  */
3449   free (source_refs);
3450 }