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