contrib/gcc-4.7/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
2339                 decl = get_underlying_decl (decl);
2340
2341                 if (decl
2342                     && DECL_P (decl)
2343                     && decl_sloc (decl, true) > decl_sloc (t, true)
2344                     && DECL_SOURCE_FILE (decl) == DECL_SOURCE_FILE (t)
2345                     && !TREE_VISITED (decl)
2346                     && !DECL_IS_BUILTIN (decl)
2347                     && (!RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl))
2348                         || TYPE_FIELDS (TREE_TYPE (decl))))
2349                   {
2350                     /* Generate forward declaration.  */
2351
2352                     pp_string (buffer, "type ");
2353                     dump_generic_ada_node
2354                       (buffer, decl, 0, cpp_check, spc, false, true);
2355                     pp_semicolon (buffer);
2356                     newline_and_indent (buffer, spc);
2357
2358                     /* Ensure we do not generate duplicate forward
2359                        declarations for this type.  */
2360                     TREE_VISITED (decl) = 1;
2361                   }
2362                 break;
2363
2364               case ARRAY_TYPE:
2365                 /* Special case char arrays.  */
2366                 if (is_char_array (field))
2367                   pp_string (buffer, "sub");
2368
2369                 pp_string (buffer, "type ");
2370                 dump_ada_double_name (buffer, parent, field, "_array is ");
2371                 dump_ada_array_type (buffer, field, spc);
2372                 pp_semicolon (buffer);
2373                 newline_and_indent (buffer, spc);
2374                 break;
2375
2376               case UNION_TYPE:
2377                 TREE_VISITED (t) = 1;
2378                 dump_nested_types (buffer, field, t, false, cpp_check, spc);
2379
2380                 pp_string (buffer, "type ");
2381
2382                 if (TYPE_NAME (TREE_TYPE (field)))
2383                   {
2384                     dump_generic_ada_node
2385                       (buffer, TYPE_NAME (TREE_TYPE (field)), 0, cpp_check,
2386                        spc, false, true);
2387                     pp_string (buffer, " (discr : unsigned := 0) is ");
2388                     print_ada_struct_decl
2389                       (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
2390
2391                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2392                     dump_generic_ada_node
2393                       (buffer, TREE_TYPE (field), 0, cpp_check,
2394                        spc, false, true);
2395                     pp_string (buffer, ");");
2396                     newline_and_indent (buffer, spc);
2397
2398                     pp_string (buffer, "pragma Unchecked_Union (");
2399                     dump_generic_ada_node
2400                       (buffer, TREE_TYPE (field), 0, cpp_check,
2401                        spc, false, true);
2402                     pp_string (buffer, ");");
2403                   }
2404                 else
2405                   {
2406                     dump_ada_double_name
2407                       (buffer, parent, field,
2408                         "_union (discr : unsigned := 0) is ");
2409                     print_ada_struct_decl
2410                       (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
2411                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2412                     dump_ada_double_name (buffer, parent, field, "_union);");
2413                     newline_and_indent (buffer, spc);
2414
2415                     pp_string (buffer, "pragma Unchecked_Union (");
2416                     dump_ada_double_name (buffer, parent, field, "_union);");
2417                   }
2418
2419                 newline_and_indent (buffer, spc);
2420                 break;
2421
2422               case RECORD_TYPE:
2423                 if (TYPE_NAME (TREE_TYPE (t)) && !TREE_VISITED (t))
2424                   {
2425                     pp_string (buffer, "type ");
2426                     dump_generic_ada_node
2427                       (buffer, t, parent, 0, spc, false, true);
2428                     pp_semicolon (buffer);
2429                     newline_and_indent (buffer, spc);
2430                   }
2431
2432                 TREE_VISITED (t) = 1;
2433                 dump_nested_types (buffer, field, t, false, cpp_check, spc);
2434                 pp_string (buffer, "type ");
2435
2436                 if (TYPE_NAME (TREE_TYPE (field)))
2437                   {
2438                     dump_generic_ada_node
2439                       (buffer, TREE_TYPE (field), 0, cpp_check,
2440                        spc, false, true);
2441                     pp_string (buffer, " is ");
2442                     print_ada_struct_decl
2443                       (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
2444                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2445                     dump_generic_ada_node
2446                       (buffer, TREE_TYPE (field), 0, cpp_check,
2447                        spc, false, true);
2448                     pp_string (buffer, ");");
2449                   }
2450                 else
2451                   {
2452                     dump_ada_double_name
2453                       (buffer, parent, field, "_struct is ");
2454                     print_ada_struct_decl
2455                       (buffer, TREE_TYPE (field), t, cpp_check, spc, false);
2456                     pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
2457                     dump_ada_double_name (buffer, parent, field, "_struct);");
2458                   }
2459
2460                 newline_and_indent (buffer, spc);
2461                 break;
2462
2463               default:
2464                 break;
2465             }
2466         }
2467       field = TREE_CHAIN (field);
2468     }
2469
2470   TREE_VISITED (t) = 1;
2471 }
2472
2473 /* Dump in BUFFER destructor spec corresponding to T.  */
2474
2475 static void
2476 print_destructor (pretty_printer *buffer, tree t)
2477 {
2478   const char *s = IDENTIFIER_POINTER (DECL_NAME (t));
2479
2480   if (*s == '_')
2481     for (s += 2; *s != ' '; s++)
2482       pp_character (buffer, *s);
2483   else
2484     {
2485       pp_string (buffer, "Delete_");
2486       pp_ada_tree_identifier (buffer, DECL_NAME (t), t, false);
2487     }
2488 }
2489
2490 /* Return the name of type T.  */
2491
2492 static const char *
2493 type_name (tree t)
2494 {
2495   tree n = TYPE_NAME (t);
2496
2497   if (TREE_CODE (n) == IDENTIFIER_NODE)
2498     return IDENTIFIER_POINTER (n);
2499   else
2500     return IDENTIFIER_POINTER (DECL_NAME (n));
2501 }
2502
2503 /* Print in BUFFER the declaration of a variable T of type TYPE in Ada syntax.
2504    CPP_CHECK is used to perform C++ queries on nodes.  SPC is the indentation
2505    level.  Return 1 if a declaration was printed, 0 otherwise.  */
2506
2507 static int
2508 print_ada_declaration (pretty_printer *buffer, tree t, tree type,
2509                        int (*cpp_check)(tree, cpp_operation), int spc)
2510 {
2511   int is_var = 0, need_indent = 0;
2512   int is_class = false;
2513   tree name = TYPE_NAME (TREE_TYPE (t));
2514   tree decl_name = DECL_NAME (t);
2515   bool dump_internal = get_dump_file_info (TDI_ada)->flags & TDF_RAW;
2516   tree orig = NULL_TREE;
2517
2518   if (cpp_check && cpp_check (t, IS_TEMPLATE))
2519     return dump_ada_template (buffer, t, cpp_check, spc);
2520
2521   if (TREE_CODE (t) == CONST_DECL && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2522     /* Skip enumeral values: will be handled as part of the type itself.  */
2523     return 0;
2524
2525   if (TREE_CODE (t) == TYPE_DECL)
2526     {
2527       orig = DECL_ORIGINAL_TYPE (t);
2528
2529       if (orig && TYPE_STUB_DECL (orig))
2530         {
2531           tree stub = TYPE_STUB_DECL (orig);
2532           tree typ = TREE_TYPE (stub);
2533
2534           if (TYPE_NAME (typ))
2535             {
2536               /* If types have same representation, and same name (ignoring
2537                  casing), then ignore the second type.  */
2538               if (type_name (typ) == type_name (TREE_TYPE (t))
2539                   || !strcasecmp (type_name (typ), type_name (TREE_TYPE (t))))
2540                 return 0;
2541
2542               INDENT (spc);
2543
2544               if (RECORD_OR_UNION_TYPE_P (typ) && !TYPE_FIELDS (typ))
2545                 {
2546                   pp_string (buffer, "--  skipped empty struct ");
2547                   dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
2548                 }
2549               else
2550                 {
2551                   if (!TREE_VISITED (stub)
2552                       && DECL_SOURCE_FILE (stub) == source_file_base)
2553                     dump_nested_types
2554                       (buffer, stub, stub, true, cpp_check, spc);
2555
2556                   pp_string (buffer, "subtype ");
2557                   dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
2558                   pp_string (buffer, " is ");
2559                   dump_generic_ada_node
2560                     (buffer, typ, type, 0, spc, false, true);
2561                   pp_semicolon (buffer);
2562                 }
2563               return 1;
2564             }
2565         }
2566
2567       /* Skip unnamed or anonymous structs/unions/enum types.  */
2568       if (!orig && !decl_name && !name)
2569         {
2570           tree tmp;
2571           location_t sloc;
2572
2573           if (cpp_check || TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE)
2574             return 0;
2575
2576           if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
2577             {
2578               /* Search next items until finding a named type decl.  */
2579               sloc = decl_sloc_common (t, true, true);
2580
2581               for (tmp = TREE_CHAIN (t); tmp; tmp = TREE_CHAIN (tmp))
2582                 {
2583                   if (TREE_CODE (tmp) == TYPE_DECL
2584                       && (DECL_NAME (tmp) || TYPE_NAME (TREE_TYPE (tmp))))
2585                     {
2586                       /* If same sloc, it means we can ignore the anonymous
2587                          struct.  */
2588                       if (decl_sloc_common (tmp, true, true) == sloc)
2589                         return 0;
2590                       else
2591                         break;
2592                     }
2593                 }
2594               if (tmp == NULL)
2595                 return 0;
2596             }
2597         }
2598
2599       if (!orig
2600           && TREE_CODE (TREE_TYPE (t)) == ENUMERAL_TYPE
2601           && decl_name
2602           && (*IDENTIFIER_POINTER (decl_name) == '.'
2603               || *IDENTIFIER_POINTER (decl_name) == '$'))
2604         /* Skip anonymous enum types (duplicates of real types).  */
2605         return 0;
2606
2607       INDENT (spc);
2608
2609       switch (TREE_CODE (TREE_TYPE (t)))
2610         {
2611           case RECORD_TYPE:
2612           case UNION_TYPE:
2613           case QUAL_UNION_TYPE:
2614             /* Skip empty structs (typically forward references to real
2615                structs).  */
2616             if (!TYPE_FIELDS (TREE_TYPE (t)))
2617               {
2618                 pp_string (buffer, "--  skipped empty struct ");
2619                 dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
2620                 return 1;
2621               }
2622
2623             if (decl_name
2624                 && (*IDENTIFIER_POINTER (decl_name) == '.'
2625                     || *IDENTIFIER_POINTER (decl_name) == '$'))
2626               {
2627                 pp_string (buffer, "--  skipped anonymous struct ");
2628                 dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
2629                 TREE_VISITED (t) = 1;
2630                 return 1;
2631               }
2632
2633             if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2634               pp_string (buffer, "subtype ");
2635             else
2636               {
2637                 dump_nested_types (buffer, t, t, false, cpp_check, spc);
2638
2639                 if (separate_class_package (t))
2640                   {
2641                     is_class = true;
2642                     pp_string (buffer, "package Class_");
2643                     dump_generic_ada_node
2644                       (buffer, t, type, 0, spc, false, true);
2645                     pp_string (buffer, " is");
2646                     spc += INDENT_INCR;
2647                     newline_and_indent (buffer, spc);
2648                   }
2649
2650                 pp_string (buffer, "type ");
2651               }
2652             break;
2653
2654           case ARRAY_TYPE:
2655           case POINTER_TYPE:
2656           case REFERENCE_TYPE:
2657             if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2658                 || is_char_array (t))
2659               pp_string (buffer, "subtype ");
2660             else
2661               pp_string (buffer, "type ");
2662             break;
2663
2664           case FUNCTION_TYPE:
2665             pp_string (buffer, "--  skipped function type ");
2666             dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
2667             return 1;
2668             break;
2669
2670           case ENUMERAL_TYPE:
2671             if ((orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2672                 || !is_simple_enum (TREE_TYPE (t)))
2673               pp_string (buffer, "subtype ");
2674             else
2675               pp_string (buffer, "type ");
2676             break;
2677
2678           default:
2679             pp_string (buffer, "subtype ");
2680         }
2681       TREE_VISITED (t) = 1;
2682     }
2683   else
2684     {
2685       if (!dump_internal
2686           && TREE_CODE (t) == VAR_DECL
2687           && decl_name
2688           && *IDENTIFIER_POINTER (decl_name) == '_')
2689         return 0;
2690
2691       need_indent = 1;
2692     }
2693
2694   /* Print the type and name.  */
2695   if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
2696     {
2697       if (need_indent)
2698         INDENT (spc);
2699
2700       /* Print variable's name.  */
2701       dump_generic_ada_node (buffer, t, type, cpp_check, spc, false, true);
2702
2703       if (TREE_CODE (t) == TYPE_DECL)
2704         {
2705           pp_string (buffer, " is ");
2706
2707           if (orig && TYPE_NAME (orig) && orig != TREE_TYPE (t))
2708             dump_generic_ada_node
2709               (buffer, TYPE_NAME (orig), type,
2710                cpp_check, spc, false, true);
2711           else
2712             dump_ada_array_type (buffer, t, spc);
2713         }
2714       else
2715         {
2716           tree tmp = TYPE_NAME (TREE_TYPE (t));
2717
2718           if (spc == INDENT_INCR || TREE_STATIC (t))
2719             is_var = 1;
2720
2721           pp_string (buffer, " : ");
2722
2723           if (tmp)
2724             {
2725               if (TREE_CODE (TREE_TYPE (tmp)) != POINTER_TYPE
2726                   && TREE_CODE (tmp) != INTEGER_TYPE)
2727                 pp_string (buffer, "aliased ");
2728
2729               dump_generic_ada_node (buffer, tmp, type, 0, spc, false, true);
2730             }
2731           else
2732             {
2733               pp_string (buffer, "aliased ");
2734
2735               if (!type)
2736                 dump_ada_array_type (buffer, t, spc);
2737               else
2738                 dump_ada_double_name (buffer, type, t, "_array");
2739             }
2740         }
2741     }
2742   else if (TREE_CODE (t) == FUNCTION_DECL)
2743     {
2744       bool is_function = true, is_method, is_abstract_class = false;
2745       tree decl_name = DECL_NAME (t);
2746       int prev_in_function = in_function;
2747       bool is_abstract = false;
2748       bool is_constructor = false;
2749       bool is_destructor = false;
2750       bool is_copy_constructor = false;
2751
2752       if (!decl_name)
2753         return 0;
2754
2755       if (cpp_check)
2756         {
2757           is_abstract = cpp_check (t, IS_ABSTRACT);
2758           is_constructor = cpp_check (t, IS_CONSTRUCTOR);
2759           is_destructor = cpp_check (t, IS_DESTRUCTOR);
2760           is_copy_constructor = cpp_check (t, IS_COPY_CONSTRUCTOR);
2761         }
2762
2763       /* Skip __comp_dtor destructor which is redundant with the '~class()'
2764          destructor.  */
2765       if (is_destructor
2766           && !strncmp (IDENTIFIER_POINTER (decl_name), "__comp", 6))
2767         return 0;
2768
2769       /* Skip copy constructors: some are internal only, and those that are
2770          not cannot be called easily from Ada anyway.  */
2771       if (is_copy_constructor)
2772         return 0;
2773
2774       /* If this function has an entry in the dispatch table, we cannot
2775          omit it.  */
2776       if (!dump_internal && !DECL_VINDEX (t)
2777           && *IDENTIFIER_POINTER (decl_name) == '_')
2778         {
2779           if (IDENTIFIER_POINTER (decl_name)[1] == '_')
2780             return 0;
2781
2782           INDENT (spc);
2783           pp_string (buffer, "--  skipped func ");
2784           pp_string (buffer, IDENTIFIER_POINTER (decl_name));
2785           return 1;
2786         }
2787
2788       if (need_indent)
2789         INDENT (spc);
2790
2791       if (is_constructor)
2792         pp_string (buffer, "function New_");
2793       else if (VOID_TYPE_P (TREE_TYPE (TREE_TYPE (t))))
2794         {
2795           is_function = false;
2796           pp_string (buffer, "procedure ");
2797         }
2798       else
2799         pp_string (buffer, "function ");
2800
2801       in_function = is_function;
2802       is_method = TREE_CODE (TREE_TYPE (t)) == METHOD_TYPE;
2803
2804       if (is_destructor)
2805         print_destructor (buffer, t);
2806       else
2807         dump_ada_decl_name (buffer, t, false);
2808
2809       dump_ada_function_declaration
2810         (buffer, t, is_method, is_constructor, is_destructor, spc);
2811       in_function = prev_in_function;
2812
2813       if (is_function)
2814         {
2815           pp_string (buffer, " return ");
2816
2817           if (is_constructor)
2818             {
2819               dump_ada_decl_name (buffer, t, false);
2820             }
2821           else
2822             {
2823               dump_generic_ada_node
2824                 (buffer, TREE_TYPE (TREE_TYPE (t)), type, cpp_check,
2825                  spc, false, true);
2826             }
2827         }
2828
2829       if (is_constructor && cpp_check && type
2830           && AGGREGATE_TYPE_P (type)
2831           && TYPE_METHODS (type))
2832         {
2833           tree tmp = TYPE_METHODS (type);
2834
2835           for (; tmp; tmp = TREE_CHAIN (tmp))
2836             if (cpp_check (tmp, IS_ABSTRACT))
2837               {
2838                 is_abstract_class = 1;
2839                 break;
2840               }
2841         }
2842
2843       if (is_abstract || is_abstract_class)
2844         pp_string (buffer, " is abstract");
2845
2846       pp_semicolon (buffer);
2847       pp_string (buffer, "  -- ");
2848       dump_sloc (buffer, t);
2849
2850       if (is_abstract)
2851         return 1;
2852
2853       newline_and_indent (buffer, spc);
2854
2855       if (is_constructor)
2856         {
2857           pp_string (buffer, "pragma CPP_Constructor (New_");
2858           dump_ada_decl_name (buffer, t, false);
2859           pp_string (buffer, ", \"");
2860           pp_asm_name (buffer, t);
2861           pp_string (buffer, "\");");
2862         }
2863       else if (is_destructor)
2864         {
2865           pp_string (buffer, "pragma Import (CPP, ");
2866           print_destructor (buffer, t);
2867           pp_string (buffer, ", \"");
2868           pp_asm_name (buffer, t);
2869           pp_string (buffer, "\");");
2870         }
2871       else
2872         {
2873           dump_ada_import (buffer, t);
2874         }
2875
2876       return 1;
2877     }
2878   else if (TREE_CODE (t) == TYPE_DECL && !DECL_ORIGINAL_TYPE (t))
2879     {
2880       int is_interface = 0;
2881       int is_abstract_record = 0;
2882
2883       if (need_indent)
2884         INDENT (spc);
2885
2886       /* Anonymous structs/unions */
2887       dump_generic_ada_node
2888         (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true);
2889
2890       if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
2891           || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE)
2892         {
2893           pp_string (buffer, " (discr : unsigned := 0)");
2894         }
2895
2896       pp_string (buffer, " is ");
2897
2898       /* Check whether we have an Ada interface compatible class.  */
2899       if (cpp_check && AGGREGATE_TYPE_P (TREE_TYPE (t))
2900           && TYPE_METHODS (TREE_TYPE (t)))
2901         {
2902           int num_fields = 0;
2903           tree tmp = TYPE_FIELDS (TREE_TYPE (t));
2904
2905           /* Check that there are no fields other than the virtual table.  */
2906           for (; tmp; tmp = TREE_CHAIN (tmp))
2907             {
2908               if (TREE_CODE (tmp) == TYPE_DECL)
2909                 continue;
2910               num_fields++;
2911             }
2912
2913           if (num_fields == 1)
2914             is_interface = 1;
2915
2916           /* Also check that there are only virtual methods.  */
2917           for (tmp = TYPE_METHODS (TREE_TYPE (t)); tmp; tmp = TREE_CHAIN (tmp))
2918             {
2919               if (cpp_check (tmp, IS_ABSTRACT))
2920                 is_abstract_record = 1;
2921               else
2922                 is_interface = 0;
2923             }
2924         }
2925
2926       TREE_VISITED (t) = 1;
2927       if (is_interface)
2928         {
2929           pp_string (buffer, "limited interface;  -- ");
2930           dump_sloc (buffer, t);
2931           newline_and_indent (buffer, spc);
2932           pp_string (buffer, "pragma Import (CPP, ");
2933           dump_generic_ada_node
2934             (buffer, TYPE_NAME (TREE_TYPE (t)), type, cpp_check,
2935              spc, false, true);
2936           pp_character (buffer, ')');
2937
2938           print_ada_methods (buffer, TREE_TYPE (t), cpp_check, spc);
2939         }
2940       else
2941         {
2942           if (is_abstract_record)
2943             pp_string (buffer, "abstract ");
2944           dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, false);
2945         }
2946     }
2947   else
2948     {
2949       if (need_indent)
2950         INDENT (spc);
2951
2952       if (TREE_CODE (t) == FIELD_DECL && DECL_NAME (t))
2953         check_name (buffer, t);
2954
2955       /* Print variable/type's name.  */
2956       dump_generic_ada_node (buffer, t, t, cpp_check, spc, false, true);
2957
2958       if (TREE_CODE (t) == TYPE_DECL)
2959         {
2960           tree orig = DECL_ORIGINAL_TYPE (t);
2961           int is_subtype = orig && TYPE_NAME (orig) && orig != TREE_TYPE (t);
2962
2963           if (!is_subtype
2964               && (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
2965                   || TREE_CODE (TREE_TYPE (t)) == QUAL_UNION_TYPE))
2966             pp_string (buffer, " (discr : unsigned := 0)");
2967
2968           pp_string (buffer, " is ");
2969
2970           dump_generic_ada_node
2971             (buffer, orig, t, cpp_check, spc, false, is_subtype);
2972         }
2973       else
2974         {
2975           if (spc == INDENT_INCR || TREE_STATIC (t))
2976             is_var = 1;
2977
2978           pp_string (buffer, " : ");
2979
2980           /* Print type declaration.  */
2981
2982           if (TREE_CODE (TREE_TYPE (t)) == UNION_TYPE
2983               && !TYPE_NAME (TREE_TYPE (t)))
2984             {
2985               dump_ada_double_name (buffer, type, t, "_union");
2986             }
2987           else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (t)))
2988             {
2989               if (TREE_CODE (TREE_TYPE (t)) == RECORD_TYPE)
2990                 pp_string (buffer, "aliased ");
2991
2992               dump_generic_ada_node
2993                 (buffer, TREE_TYPE (t), t, cpp_check, spc, false, true);
2994             }
2995           else
2996             {
2997               if (TREE_CODE (TREE_TYPE (t)) != POINTER_TYPE
2998                   && (TYPE_NAME (TREE_TYPE (t))
2999                       || TREE_CODE (TREE_TYPE (t)) != INTEGER_TYPE))
3000                 pp_string (buffer, "aliased ");
3001
3002               dump_generic_ada_node
3003                 (buffer, TREE_TYPE (t), TREE_TYPE (t), cpp_check,
3004                  spc, false, true);
3005             }
3006         }
3007     }
3008
3009   if (is_class)
3010     {
3011       spc -= 3;
3012       newline_and_indent (buffer, spc);
3013       pp_string (buffer, "end;");
3014       newline_and_indent (buffer, spc);
3015       pp_string (buffer, "use Class_");
3016       dump_generic_ada_node (buffer, t, type, 0, spc, false, true);
3017       pp_semicolon (buffer);
3018       pp_newline (buffer);
3019
3020       /* All needed indentation/newline performed already, so return 0.  */
3021       return 0;
3022     }
3023   else
3024     {
3025       pp_string (buffer, ";  -- ");
3026       dump_sloc (buffer, t);
3027     }
3028
3029   if (is_var)
3030     {
3031       newline_and_indent (buffer, spc);
3032       dump_ada_import (buffer, t);
3033     }
3034
3035   return 1;
3036 }
3037
3038 /* Prints in BUFFER a structure NODE of type TYPE: name, fields, and methods
3039    with Ada syntax.  CPP_CHECK is used to perform C++ queries on nodes.  SPC
3040    is the indentation level.  If DISPLAY_CONVENTION is true, also print the
3041    pragma Convention for NODE.  */
3042
3043 static void
3044 print_ada_struct_decl (pretty_printer *buffer, tree node, tree type,
3045                        int (*cpp_check)(tree, cpp_operation), int spc,
3046                        bool display_convention)
3047 {
3048   tree tmp;
3049   int is_union =
3050     TREE_CODE (node) == UNION_TYPE || TREE_CODE (node) == QUAL_UNION_TYPE;
3051   char buf [16];
3052   int field_num = 0;
3053   int field_spc = spc + INDENT_INCR;
3054   int need_semicolon;
3055
3056   bitfield_used = false;
3057
3058   if (!TYPE_FIELDS (node))
3059     pp_string (buffer, "null record;");
3060   else
3061     {
3062       pp_string (buffer, "record");
3063
3064       /* Print the contents of the structure.  */
3065
3066       if (is_union)
3067         {
3068           newline_and_indent (buffer, spc + INDENT_INCR);
3069           pp_string (buffer, "case discr is");
3070           field_spc = spc + INDENT_INCR * 3;
3071         }
3072
3073       pp_newline (buffer);
3074
3075       /* Print the non-static fields of the structure.  */
3076       for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3077         {
3078           /* Add parent field if needed.  */
3079           if (!DECL_NAME (tmp))
3080             {
3081               if (!is_tagged_type (TREE_TYPE (tmp)))
3082                 {
3083                   if (!TYPE_NAME (TREE_TYPE (tmp)))
3084                     print_ada_declaration
3085                       (buffer, tmp, type, cpp_check, field_spc);
3086                   else
3087                     {
3088                       INDENT (field_spc);
3089
3090                       if (field_num == 0)
3091                         pp_string (buffer, "parent : ");
3092                       else
3093                         {
3094                           sprintf (buf, "field_%d : ", field_num + 1);
3095                           pp_string (buffer, buf);
3096                         }
3097                       dump_ada_decl_name
3098                         (buffer, TYPE_NAME (TREE_TYPE (tmp)), false);
3099                       pp_semicolon (buffer);
3100                     }
3101                   pp_newline (buffer);
3102                   field_num++;
3103                 }
3104             }
3105           /* Avoid printing the structure recursively.  */
3106           else if ((TREE_TYPE (tmp) != node
3107                    || (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
3108                        && TREE_TYPE (TREE_TYPE (tmp)) != node))
3109                    && TREE_CODE (tmp) != TYPE_DECL
3110                    && !TREE_STATIC (tmp))
3111             {
3112               /* Skip internal virtual table field.  */
3113               if (strncmp (IDENTIFIER_POINTER (DECL_NAME (tmp)), "_vptr", 5))
3114                 {
3115                   if (is_union)
3116                     {
3117                       if (TREE_CHAIN (tmp)
3118                           && TREE_TYPE (TREE_CHAIN (tmp)) != node
3119                           && TREE_CODE (TREE_CHAIN (tmp)) != TYPE_DECL)
3120                         sprintf (buf, "when %d =>", field_num);
3121                       else
3122                         sprintf (buf, "when others =>");
3123
3124                       INDENT (spc + INDENT_INCR * 2);
3125                       pp_string (buffer, buf);
3126                       pp_newline (buffer);
3127                     }
3128
3129                   if (print_ada_declaration (buffer,
3130                                              tmp, type, cpp_check, field_spc))
3131                     {
3132                       pp_newline (buffer);
3133                       field_num++;
3134                     }
3135                 }
3136             }
3137         }
3138
3139       if (is_union)
3140         {
3141           INDENT (spc + INDENT_INCR);
3142           pp_string (buffer, "end case;");
3143           pp_newline (buffer);
3144         }
3145
3146       if (field_num == 0)
3147         {
3148           INDENT (spc + INDENT_INCR);
3149           pp_string (buffer, "null;");
3150           pp_newline (buffer);
3151         }
3152
3153       INDENT (spc);
3154       pp_string (buffer, "end record;");
3155     }
3156
3157   newline_and_indent (buffer, spc);
3158
3159   if (!display_convention)
3160     return;
3161
3162   if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type)))
3163     {
3164       if (TYPE_METHODS (TREE_TYPE (type)))
3165         pp_string (buffer, "pragma Import (CPP, ");
3166       else
3167         pp_string (buffer, "pragma Convention (C_Pass_By_Copy, ");
3168     }
3169   else
3170     pp_string (buffer, "pragma Convention (C, ");
3171
3172   package_prefix = false;
3173   dump_generic_ada_node
3174     (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
3175   package_prefix = true;
3176   pp_character (buffer, ')');
3177
3178   if (is_union)
3179     {
3180       pp_semicolon (buffer);
3181       newline_and_indent (buffer, spc);
3182       pp_string (buffer, "pragma Unchecked_Union (");
3183
3184       dump_generic_ada_node
3185         (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
3186       pp_character (buffer, ')');
3187     }
3188
3189   if (bitfield_used)
3190     {
3191       pp_semicolon (buffer);
3192       newline_and_indent (buffer, spc);
3193       pp_string (buffer, "pragma Pack (");
3194       dump_generic_ada_node
3195         (buffer, TREE_TYPE (type), type, cpp_check, spc, false, true);
3196       pp_character (buffer, ')');
3197       bitfield_used = false;
3198     }
3199
3200   print_ada_methods (buffer, node, cpp_check, spc);
3201
3202   /* Print the static fields of the structure, if any.  */
3203   need_semicolon = TYPE_METHODS (node) == NULL_TREE;
3204   for (tmp = TYPE_FIELDS (node); tmp; tmp = TREE_CHAIN (tmp))
3205     {
3206       if (DECL_NAME (tmp) && TREE_STATIC (tmp))
3207         {
3208           if (need_semicolon)
3209             {
3210               need_semicolon = false;
3211               pp_semicolon (buffer);
3212             }
3213           pp_newline (buffer);
3214           pp_newline (buffer);
3215           print_ada_declaration (buffer, tmp, type, cpp_check, spc);
3216         }
3217     }
3218 }
3219
3220 /* Dump all the declarations in SOURCE_FILE to an Ada spec.
3221    COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3222    nodes for SOURCE_FILE.  CPP_CHECK is used to perform C++ queries on
3223    nodes.  */
3224
3225 static void
3226 dump_ads (const char *source_file,
3227           void (*collect_all_refs)(const char *),
3228           int (*cpp_check)(tree, cpp_operation))
3229 {
3230   char *ads_name;
3231   char *pkg_name;
3232   char *s;
3233   FILE *f;
3234
3235   pkg_name = get_ada_package (source_file);
3236
3237   /* Construct the .ads filename and package name.  */
3238   ads_name = xstrdup (pkg_name);
3239
3240   for (s = ads_name; *s; s++)
3241     *s = TOLOWER (*s);
3242
3243   ads_name = reconcat (ads_name, ads_name, ".ads", NULL);
3244
3245   /* Write out the .ads file.  */
3246   f = fopen (ads_name, "w");
3247   if (f)
3248     {
3249       pretty_printer pp;
3250
3251       pp_construct (&pp, NULL, 0);
3252       pp_needs_newline (&pp) = true;
3253       pp.buffer->stream = f;
3254
3255       /* Dump all relevant macros.  */
3256       dump_ada_macros (&pp, source_file);
3257
3258       /* Reset the table of withs for this file.  */
3259       reset_ada_withs ();
3260
3261       (*collect_all_refs) (source_file);
3262
3263       /* Dump all references.  */
3264       dump_ada_nodes (&pp, source_file, cpp_check);
3265
3266       /* Dump withs.  */
3267       dump_ada_withs (f);
3268
3269       fprintf (f, "\npackage %s is\n\n", pkg_name);
3270       pp_write_text_to_stream (&pp);
3271       /* ??? need to free pp */
3272       fprintf (f, "end %s;\n", pkg_name);
3273       fclose (f);
3274     }
3275
3276   free (ads_name);
3277   free (pkg_name);
3278 }
3279
3280 static const char **source_refs = NULL;
3281 static int source_refs_used = 0;
3282 static int source_refs_allocd = 0;
3283
3284 /* Add an entry for FILENAME to the table SOURCE_REFS.  */
3285
3286 void
3287 collect_source_ref (const char *filename)
3288 {
3289   int i;
3290
3291   if (!filename)
3292     return;
3293
3294   if (source_refs_allocd == 0)
3295     {
3296       source_refs_allocd = 1024;
3297       source_refs = XNEWVEC (const char *, source_refs_allocd);
3298     }
3299
3300   for (i = 0; i < source_refs_used; i++)
3301     if (filename == source_refs [i])
3302       return;
3303
3304   if (source_refs_used == source_refs_allocd)
3305     {
3306       source_refs_allocd *= 2;
3307       source_refs = XRESIZEVEC (const char *, source_refs, source_refs_allocd);
3308     }
3309
3310   source_refs [source_refs_used++] = filename;
3311 }
3312
3313 /* Main entry point: dump all Ada specs corresponding to SOURCE_REFS
3314    using callbacks COLLECT_ALL_REFS and CPP_CHECK.
3315    COLLECT_ALL_REFS is a front-end callback used to collect all relevant
3316    nodes for a given source file.
3317    CPP_CHECK is used to perform C++ queries on nodes, or NULL for the C
3318    front-end.  */
3319
3320 void
3321 dump_ada_specs (void (*collect_all_refs)(const char *),
3322                 int (*cpp_check)(tree, cpp_operation))
3323 {
3324   int i;
3325
3326   /* Iterate over the list of files to dump specs for */
3327   for (i = 0; i < source_refs_used; i++)
3328     dump_ads (source_refs [i], collect_all_refs, cpp_check);
3329
3330   /* Free files table.  */
3331   free (source_refs);
3332 }