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