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