gcc/ada/gcc-interface/misc.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                 M I S C                                  *
   6  *                                                                          *
   7  *                           C Implementation File                          *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2010, Free Software Foundation, Inc.         *
  10  *                                                                          *
  11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  12  * terms of the  GNU General Public License as published  by the Free Soft- *
  13  * ware  Foundation;  either version 3,  or (at your option) any later ver- *
  14  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  15  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  16  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  17  * for  more details.  You should have  received  a copy of the GNU General *
  18  * Public License  distributed  with GNAT;  see file  COPYING3.  If not see *
  19  * <http://www.gnu.org/licenses/>.                                          *
  20  *                                                                          *
  21  * GNAT was originally developed  by the GNAT team at  New York University. *
  22  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  23  *                                                                          *
  24  ****************************************************************************/
  25
  26 /* This file contains parts of the compiler that are required for interfacing
  27    with GCC but otherwise do nothing and parts of Gigi that need to know
  28    about GIMPLE.  */
  29
  30 #include "config.h"
  31 #include "system.h"
  32 #include "coretypes.h"
  33 #include "tm.h"
  34 #include "tree.h"
  35 #include "diagnostic.h"
  36 #include "target.h"
  37 #include "ggc.h"
  38 #include "flags.h"
  39 #include "debug.h"
  40 #include "toplev.h"
  41 #include "langhooks.h"
  42 #include "langhooks-def.h"
  43 #include "opts.h"
  44 #include "options.h"
  45 #include "plugin.h"
  46 #include "function.h"   /* For pass_by_reference.  */
  47
  48 #include "ada.h"
  49 #include "adadecode.h"
  50 #include "types.h"
  51 #include "atree.h"
  52 #include "elists.h"
  53 #include "namet.h"
  54 #include "nlists.h"
  55 #include "stringt.h"
  56 #include "uintp.h"
  57 #include "fe.h"
  58 #include "sinfo.h"
  59 #include "einfo.h"
  60 #include "ada-tree.h"
  61 #include "gigi.h"
  62
  63 static bool gnat_init                   (void);
  64 static unsigned int gnat_option_lang_mask (void);
  65 static void gnat_init_options           (unsigned int,
  66                                          struct cl_decoded_option *);
  67 static bool gnat_handle_option          (size_t, const char *, int, int,
  68                                          const struct cl_option_handlers *);
  69 static bool gnat_post_options           (const char **);
  70 static alias_set_type gnat_get_alias_set (tree);
  71 static void gnat_print_decl             (FILE *, tree, int);
  72 static void gnat_print_type             (FILE *, tree, int);
  73 static const char *gnat_printable_name  (tree, int);
  74 static const char *gnat_dwarf_name      (tree, int);
  75 static bool gnat_type_hash_eq           (const_tree, const_tree);
  76 static tree gnat_return_tree            (tree);
  77 static void gnat_parse_file             (int);
  78 static void internal_error_function     (diagnostic_context *,
  79                                          const char *, va_list *);
  80 static tree gnat_type_max_size          (const_tree);
  81 static void gnat_get_subrange_bounds    (const_tree, tree *, tree *);
  82 static tree gnat_eh_personality         (void);
  83
  84 /* Definitions for our language-specific hooks.  */
  85
  86 #undef  LANG_HOOKS_NAME
  87 #define LANG_HOOKS_NAME                 "GNU Ada"
  88 #undef  LANG_HOOKS_IDENTIFIER_SIZE
  89 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
  90 #undef  LANG_HOOKS_INIT
  91 #define LANG_HOOKS_INIT                 gnat_init
  92 #undef  LANG_HOOKS_OPTION_LANG_MASK
  93 #define LANG_HOOKS_OPTION_LANG_MASK     gnat_option_lang_mask
  94 #undef  LANG_HOOKS_INIT_OPTIONS
  95 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
  96 #undef  LANG_HOOKS_HANDLE_OPTION
  97 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
  98 #undef  LANG_HOOKS_POST_OPTIONS
  99 #define LANG_HOOKS_POST_OPTIONS         gnat_post_options
 100 #undef  LANG_HOOKS_PARSE_FILE
 101 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 102 #undef  LANG_HOOKS_TYPE_HASH_EQ
 103 #define LANG_HOOKS_TYPE_HASH_EQ         gnat_type_hash_eq
 104 #undef  LANG_HOOKS_GETDECLS
 105 #define LANG_HOOKS_GETDECLS             lhd_return_null_tree_v
 106 #undef  LANG_HOOKS_PUSHDECL
 107 #define LANG_HOOKS_PUSHDECL             gnat_return_tree
 108 #undef  LANG_HOOKS_WRITE_GLOBALS
 109 #define LANG_HOOKS_WRITE_GLOBALS        gnat_write_global_declarations
 110 #undef  LANG_HOOKS_GET_ALIAS_SET
 111 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 112 #undef  LANG_HOOKS_PRINT_DECL
 113 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 114 #undef  LANG_HOOKS_PRINT_TYPE
 115 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 116 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 117 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 118 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 119 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 120 #undef  LANG_HOOKS_DWARF_NAME
 121 #define LANG_HOOKS_DWARF_NAME           gnat_dwarf_name
 122 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 123 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 124 #undef  LANG_HOOKS_TYPE_FOR_MODE
 125 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 126 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 127 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 128 #undef  LANG_HOOKS_TYPES_COMPATIBLE_P
 129 #define LANG_HOOKS_TYPES_COMPATIBLE_P   gnat_types_compatible_p
 130 #undef  LANG_HOOKS_GET_SUBRANGE_BOUNDS
 131 #define LANG_HOOKS_GET_SUBRANGE_BOUNDS  gnat_get_subrange_bounds
 132 #undef  LANG_HOOKS_ATTRIBUTE_TABLE
 133 #define LANG_HOOKS_ATTRIBUTE_TABLE      gnat_internal_attribute_table
 134 #undef  LANG_HOOKS_BUILTIN_FUNCTION
 135 #define LANG_HOOKS_BUILTIN_FUNCTION     gnat_builtin_function
 136 #undef  LANG_HOOKS_EH_PERSONALITY
 137 #define LANG_HOOKS_EH_PERSONALITY       gnat_eh_personality
 138 #undef  LANG_HOOKS_DEEP_UNSHARING
 139 #define LANG_HOOKS_DEEP_UNSHARING       true
 140
 141 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 142
 143 /* This symbol needs to be defined for the front-end.  */
 144 void *callgraph_info_file = NULL;
 145
 146 /* How much we want of our DWARF extensions.  Some of our dwarf+ extensions
 147    are incompatible with regular GDB versions, so we must make sure to only
 148    produce them on explicit request.  This is eventually reflected into the
 149    use_gnu_debug_info_extensions common flag for later processing.  */
 150 static int gnat_dwarf_extensions = 0;
 151
 152 /* Command-line argc and argv.  These variables are global
 153    since they are imported in back_end.adb.  */
 154 unsigned int save_argc;
 155 const char **save_argv;
 156
 157 /* GNAT argc and argv.  */
 158 extern int gnat_argc;
 159 extern char **gnat_argv;
 160
 161 /* Declare functions we use as part of startup.  */
 162 extern void __gnat_initialize           (void *);
 163 extern void __gnat_install_SEH_handler  (void *);
 164 extern void adainit                     (void);
 165 extern void _ada_gnat1drv               (void);
 166
 167 /* The parser for the language.  For us, we process the GNAT tree.  */
 168
 169 static void
 170 gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 171 {
 172   int seh[2];
 173
 174   /* Call the target specific initializations.  */
 175   __gnat_initialize (NULL);
 176
 177   /* ??? Call the SEH initialization routine.  This is to workaround
 178   a bootstrap path problem.  The call below should be removed at some
 179   point and the SEH pointer passed to __gnat_initialize() above.  */
 180   __gnat_install_SEH_handler((void *)seh);
 181
 182   /* Call the front-end elaboration procedures.  */
 183   adainit ();
 184
 185   /* Call the front end.  */
 186   _ada_gnat1drv ();
 187 }
 188
 189 /* Decode all the language specific options that cannot be decoded by GCC.
 190    The option decoding phase of GCC calls this routine on the flags that
 191    are marked as Ada-specific.  Return true on success or false on failure.  */
 192
 193 static bool
 194 gnat_handle_option (size_t scode, const char *arg ATTRIBUTE_UNUSED, int value,
 195                     int kind ATTRIBUTE_UNUSED,
 196                     const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED)
 197 {
 198   enum opt_code code = (enum opt_code) scode;
 199
 200   switch (code)
 201     {
 202     case OPT_Wall:
 203       warn_unused = value;
 204       warn_uninitialized = value;
 205       break;
 206
 207     case OPT_Wmissing_prototypes:
 208     case OPT_Wstrict_prototypes:
 209     case OPT_Wwrite_strings:
 210     case OPT_Wlong_long:
 211     case OPT_Wvariadic_macros:
 212     case OPT_Wold_style_definition:
 213     case OPT_Wmissing_format_attribute:
 214     case OPT_Woverlength_strings:
 215       /* These are used in the GCC Makefile.  */
 216       break;
 217
 218     case OPT_feliminate_unused_debug_types:
 219       /* We arrange for post_option to be able to only set the corresponding
 220          flag to 1 when explicitly requested by the user.  We expect the
 221          default flag value to be either 0 or positive, and expose a positive
 222          -f as a negative value to post_option.  */
 223       flag_eliminate_unused_debug_types = -value;
 224       break;
 225
 226     case OPT_gdwarfplus:
 227       gnat_dwarf_extensions = 1;
 228       break;
 229
 230     case OPT_gant:
 231       warning (0, "%<-gnat%> misspelled as %<-gant%>");
 232
 233       /* ... fall through ... */
 234
 235     case OPT_gnat:
 236     case OPT_gnatO:
 237     case OPT_fRTS_:
 238     case OPT_I:
 239     case OPT_nostdinc:
 240     case OPT_nostdlib:
 241       /* These are handled by the front-end.  */
 242       break;
 243
 244     default:
 245       gcc_unreachable ();
 246     }
 247
 248   return true;
 249 }
 250
 251 /* Return language mask for option processing.  */
 252
 253 static unsigned int
 254 gnat_option_lang_mask (void)
 255 {
 256   return CL_Ada;
 257 }
 258
 259 /* Initialize for option processing.  */
 260
 261 static void
 262 gnat_init_options (unsigned int decoded_options_count,
 263                    struct cl_decoded_option *decoded_options)
 264 {
 265   /* Reconstruct an argv array for use of back_end.adb.
 266
 267      ??? back_end.adb should not rely on this; instead, it should work
 268      with decoded options without such reparsing, to ensure
 269      consistency in how options are decoded.  */
 270   unsigned int i;
 271
 272   save_argv = XNEWVEC (const char *, 2 * decoded_options_count + 1);
 273   save_argc = 0;
 274   for (i = 0; i < decoded_options_count; i++)
 275     {
 276       if (decoded_options[i].errors
 277           || decoded_options[i].opt_index == OPT_SPECIAL_unknown
 278           || decoded_options[i].canonical_option_num_elements == 0)
 279         continue;
 280       if (decoded_options[i].opt_index == OPT_I)
 281         {
 282           gcc_assert (decoded_options[i].canonical_option_num_elements == 2);
 283           save_argv[save_argc++]
 284             = concat (decoded_options[i].canonical_option[0],
 285                       decoded_options[i].canonical_option[1], NULL);
 286         }
 287       else
 288         {
 289           gcc_assert (decoded_options[i].canonical_option_num_elements >= 1
 290                       && decoded_options[i].canonical_option_num_elements <= 2);
 291           save_argv[save_argc++] = decoded_options[i].canonical_option[0];
 292           if (decoded_options[i].canonical_option_num_elements >= 2)
 293             save_argv[save_argc++] = decoded_options[i].canonical_option[1];
 294         }
 295     }
 296   save_argv[save_argc] = NULL;
 297
 298   gnat_argv = (char **) xmalloc (sizeof (save_argv[0]));
 299   gnat_argv[0] = xstrdup (save_argv[0]);     /* name of the command */
 300   gnat_argc = 1;
 301
 302   /* Uninitialized really means uninitialized in Ada.  */
 303   flag_zero_initialized_in_bss = 0;
 304 }
 305
 306 /* Post-switch processing.  */
 307
 308 static bool
 309 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
 310 {
 311   /* Excess precision other than "fast" requires front-end
 312      support.  */
 313   if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD
 314       && TARGET_FLT_EVAL_METHOD_NON_DEFAULT)
 315     sorry ("-fexcess-precision=standard for Ada");
 316   flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
 317
 318   /* ??? The warning machinery is outsmarted by Ada.  */
 319   warn_unused_parameter = 0;
 320
 321   /* No psABI change warnings for Ada.  */
 322   warn_psabi = 0;
 323
 324   /* Force eliminate_unused_debug_types to 0 unless an explicit positive
 325      -f has been passed.  This forces the default to 0 for Ada, which might
 326      differ from the common default.  */
 327   if (flag_eliminate_unused_debug_types < 0)
 328     flag_eliminate_unused_debug_types = 1;
 329   else
 330     flag_eliminate_unused_debug_types = 0;
 331
 332   /* Reflect the explicit request of DWARF extensions into the common
 333      flag for use by later passes.  */
 334   if (write_symbols == DWARF2_DEBUG)
 335     use_gnu_debug_info_extensions = gnat_dwarf_extensions > 0;
 336
 337   return false;
 338 }
 339
 340 /* Here is the function to handle the compiler error processing in GCC.  */
 341
 342 static void
 343 internal_error_function (diagnostic_context *context,
 344                          const char *msgid, va_list *ap)
 345 {
 346   text_info tinfo;
 347   char *buffer, *p, *loc;
 348   String_Template temp, temp_loc;
 349   Fat_Pointer fp, fp_loc;
 350   expanded_location s;
 351
 352   /* Warn if plugins present.  */
 353   warn_if_plugins ();
 354
 355   /* Reset the pretty-printer.  */
 356   pp_clear_output_area (context->printer);
 357
 358   /* Format the message into the pretty-printer.  */
 359   tinfo.format_spec = msgid;
 360   tinfo.args_ptr = ap;
 361   tinfo.err_no = errno;
 362   pp_format_verbatim (context->printer, &tinfo);
 363
 364   /* Extract a (writable) pointer to the formatted text.  */
 365   buffer = xstrdup (pp_formatted_text (context->printer));
 366
 367   /* Go up to the first newline.  */
 368   for (p = buffer; *p; p++)
 369     if (*p == '\n')
 370       {
 371         *p = '\0';
 372         break;
 373       }
 374
 375   temp.Low_Bound = 1;
 376   temp.High_Bound = p - buffer;
 377   fp.Bounds = &temp;
 378   fp.Array = buffer;
 379
 380   s = expand_location (input_location);
 381   if (context->show_column && s.column != 0)
 382     asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column);
 383   else
 384     asprintf (&loc, "%s:%d", s.file, s.line);
 385   temp_loc.Low_Bound = 1;
 386   temp_loc.High_Bound = strlen (loc);
 387   fp_loc.Bounds = &temp_loc;
 388   fp_loc.Array = loc;
 389
 390   Current_Error_Node = error_gnat_node;
 391   Compiler_Abort (fp, -1, fp_loc);
 392 }
 393
 394 /* Perform all the initialization steps that are language-specific.  */
 395
 396 static bool
 397 gnat_init (void)
 398 {
 399   /* Do little here, most of the standard declarations are set up after the
 400      front-end has been run.  Use the same `char' as C, this doesn't really
 401      matter since we'll use the explicit `unsigned char' for Character.  */
 402   build_common_tree_nodes (flag_signed_char);
 403
 404   /* In Ada, we use the unsigned type corresponding to the width of Pmode as
 405      SIZETYPE.  In most cases when ptr_mode and Pmode differ, C will use the
 406      width of ptr_mode for SIZETYPE, but we get better code using the width
 407      of Pmode.  Note that, although we manipulate negative offsets for some
 408      internal constructs and rely on compile time overflow detection in size
 409      computations, using unsigned types for SIZETYPEs is fine since they are
 410      treated specially by the middle-end, in particular sign-extended.  */
 411   size_type_node = gnat_type_for_mode (Pmode, 1);
 412   set_sizetype (size_type_node);
 413   TYPE_NAME (sizetype) = get_identifier ("size_type");
 414
 415   /* In Ada, we use an unsigned 8-bit type for the default boolean type.  */
 416   boolean_type_node = make_unsigned_type (8);
 417   TREE_SET_CODE (boolean_type_node, BOOLEAN_TYPE);
 418   SET_TYPE_RM_MAX_VALUE (boolean_type_node,
 419                          build_int_cst (boolean_type_node, 1));
 420   SET_TYPE_RM_SIZE (boolean_type_node, bitsize_int (1));
 421
 422   build_common_tree_nodes_2 (0);
 423   sbitsize_one_node = sbitsize_int (1);
 424   sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT);
 425   boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
 426
 427   ptr_void_type_node = build_pointer_type (void_type_node);
 428
 429   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 430   internal_reference_types ();
 431
 432   /* Register our internal error function.  */
 433   global_dc->internal_error = &internal_error_function;
 434
 435   return true;
 436 }
 437
 438 /* If we are using the GCC mechanism to process exception handling, we
 439    have to register the personality routine for Ada and to initialize
 440    various language dependent hooks.  */
 441
 442 void
 443 gnat_init_gcc_eh (void)
 444 {
 445 #ifdef DWARF2_UNWIND_INFO
 446   /* lang_dependent_init already called dwarf2out_frame_init if true.  */
 447   int dwarf2out_frame_initialized = dwarf2out_do_frame ();
 448 #endif
 449
 450   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 451      though. This could for instance lead to the emission of tables with
 452      references to symbols (such as the Ada eh personality routine) within
 453      libraries we won't link against.  */
 454   if (No_Exception_Handlers_Set ())
 455     return;
 456
 457   /* Tell GCC we are handling cleanup actions through exception propagation.
 458      This opens possibilities that we don't take advantage of yet, but is
 459      nonetheless necessary to ensure that fixup code gets assigned to the
 460      right exception regions.  */
 461   using_eh_for_cleanups ();
 462
 463   /* Turn on -fexceptions and -fnon-call-exceptions.  The first one triggers
 464      the generation of the necessary exception tables.  The second one is
 465      useful for two reasons: 1/ we map some asynchronous signals like SEGV to
 466      exceptions, so we need to ensure that the insns which can lead to such
 467      signals are correctly attached to the exception region they pertain to,
 468      2/ Some calls to pure subprograms are handled as libcall blocks and then
 469      marked as "cannot trap" if the flag is not set (see emit_libcall_block).
 470      We should not let this be since it is possible for such calls to actually
 471      raise in Ada.  */
 472   flag_exceptions = 1;
 473   flag_non_call_exceptions = 1;
 474
 475   init_eh ();
 476 #ifdef DWARF2_UNWIND_INFO
 477   if (!dwarf2out_frame_initialized && dwarf2out_do_frame ())
 478     dwarf2out_frame_init ();
 479 #endif
 480 }
 481
 482 /* Print language-specific items in declaration NODE.  */
 483
 484 static void
 485 gnat_print_decl (FILE *file, tree node, int indent)
 486 {
 487   switch (TREE_CODE (node))
 488     {
 489     case CONST_DECL:
 490       print_node (file, "corresponding var",
 491                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 492       break;
 493
 494     case FIELD_DECL:
 495       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 496                   indent + 4);
 497       break;
 498
 499     case VAR_DECL:
 500       print_node (file, "renamed object", DECL_RENAMED_OBJECT (node),
 501                   indent + 4);
 502       break;
 503
 504     default:
 505       break;
 506     }
 507 }
 508
 509 /* Print language-specific items in type NODE.  */
 510
 511 static void
 512 gnat_print_type (FILE *file, tree node, int indent)
 513 {
 514   switch (TREE_CODE (node))
 515     {
 516     case FUNCTION_TYPE:
 517       print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4);
 518       break;
 519
 520     case INTEGER_TYPE:
 521       if (TYPE_MODULAR_P (node))
 522         print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
 523       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 524         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 525                     indent + 4);
 526       else if (TYPE_VAX_FLOATING_POINT_P (node))
 527         ;
 528       else
 529         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 530
 531       /* ... fall through ... */
 532
 533     case ENUMERAL_TYPE:
 534     case BOOLEAN_TYPE:
 535       print_node_brief (file, "RM size", TYPE_RM_SIZE (node), indent + 4);
 536
 537       /* ... fall through ... */
 538
 539     case REAL_TYPE:
 540       print_node_brief (file, "RM min", TYPE_RM_MIN_VALUE (node), indent + 4);
 541       print_node_brief (file, "RM max", TYPE_RM_MAX_VALUE (node), indent + 4);
 542       break;
 543
 544     case ARRAY_TYPE:
 545       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 546       break;
 547
 548     case VECTOR_TYPE:
 549       print_node (file,"representative array",
 550                   TYPE_REPRESENTATIVE_ARRAY (node), indent + 4);
 551       break;
 552
 553     case RECORD_TYPE:
 554       if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 555         print_node (file, "unconstrained array",
 556                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 557       else
 558         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 559       break;
 560
 561     case UNION_TYPE:
 562     case QUAL_UNION_TYPE:
 563       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 564       break;
 565
 566     default:
 567       break;
 568     }
 569 }
 570
 571 /* Return the name to be printed for DECL.  */
 572
 573 static const char *
 574 gnat_printable_name (tree decl, int verbosity)
 575 {
 576   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 577   char *ada_name = (char *) ggc_alloc_atomic (strlen (coded_name) * 2 + 60);
 578
 579   __gnat_decode (coded_name, ada_name, 0);
 580
 581   if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
 582     {
 583       Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl));
 584       return ggc_strdup (Name_Buffer);
 585     }
 586
 587   return ada_name;
 588 }
 589
 590 /* Return the name to be used in DWARF debug info for DECL.  */
 591
 592 static const char *
 593 gnat_dwarf_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
 594 {
 595   gcc_assert (DECL_P (decl));
 596   return (const char *) IDENTIFIER_POINTER (DECL_NAME (decl));
 597 }
 598
 599 /* Return true if types T1 and T2 are identical for type hashing purposes.
 600    Called only after doing all language independent checks.  At present,
 601    this function is only called when both types are FUNCTION_TYPE.  */
 602
 603 static bool
 604 gnat_type_hash_eq (const_tree t1, const_tree t2)
 605 {
 606   gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE);
 607   return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
 608                               TYPE_RETURN_UNCONSTRAINED_P (t2),
 609                               TYPE_RETURN_BY_DIRECT_REF_P (t2),
 610                               TREE_ADDRESSABLE (t2));
 611 }
 612
 613 /* Do nothing (return the tree node passed).  */
 614
 615 static tree
 616 gnat_return_tree (tree t)
 617 {
 618   return t;
 619 }
 620
 621 /* Get the alias set corresponding to a type or expression.  */
 622
 623 static alias_set_type
 624 gnat_get_alias_set (tree type)
 625 {
 626   /* If this is a padding type, use the type of the first field.  */
 627   if (TYPE_IS_PADDING_P (type))
 628     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 629
 630   /* If the type is an unconstrained array, use the type of the
 631      self-referential array we make.  */
 632   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 633     return
 634       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 635
 636   /* If the type can alias any other types, return the alias set 0.  */
 637   else if (TYPE_P (type)
 638            && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
 639     return 0;
 640
 641   return -1;
 642 }
 643
 644 /* GNU_TYPE is a type.  Return its maximum size in bytes, if known,
 645    as a constant when possible.  */
 646
 647 static tree
 648 gnat_type_max_size (const_tree gnu_type)
 649 {
 650   /* First see what we can get from TYPE_SIZE_UNIT, which might not
 651      be constant even for simple expressions if it has already been
 652      elaborated and possibly replaced by a VAR_DECL.  */
 653   tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
 654
 655   /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
 656      which should stay untouched.  */
 657   if (!host_integerp (max_unitsize, 1)
 658       && (TREE_CODE (gnu_type) == RECORD_TYPE
 659           || TREE_CODE (gnu_type) == UNION_TYPE
 660           || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
 661       && TYPE_ADA_SIZE (gnu_type))
 662     {
 663       tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
 664
 665       /* If we have succeeded in finding a constant, round it up to the
 666          type's alignment and return the result in units.  */
 667       if (host_integerp (max_adasize, 1))
 668         max_unitsize
 669           = size_binop (CEIL_DIV_EXPR,
 670                         round_up (max_adasize, TYPE_ALIGN (gnu_type)),
 671                         bitsize_unit_node);
 672     }
 673
 674   return max_unitsize;
 675 }
 676
 677 /* GNU_TYPE is a subtype of an integral type.  Set LOWVAL to the low bound
 678    and HIGHVAL to the high bound, respectively.  */
 679
 680 static void
 681 gnat_get_subrange_bounds (const_tree gnu_type, tree *lowval, tree *highval)
 682 {
 683   *lowval = TYPE_MIN_VALUE (gnu_type);
 684   *highval = TYPE_MAX_VALUE (gnu_type);
 685 }
 686
 687 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 688    default.  */
 689
 690 bool
 691 default_pass_by_ref (tree gnu_type)
 692 {
 693   /* We pass aggregates by reference if they are sufficiently large.  The
 694      choice of constant here is somewhat arbitrary.  We also pass by
 695      reference if the target machine would either pass or return by
 696      reference.  Strictly speaking, we need only check the return if this
 697      is an In Out parameter, but it's probably best to err on the side of
 698      passing more things by reference.  */
 699
 700   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1))
 701     return true;
 702
 703   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 704     return true;
 705
 706   if (AGGREGATE_TYPE_P (gnu_type)
 707       && (!host_integerp (TYPE_SIZE (gnu_type), 1)
 708           || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 709                                    8 * TYPE_ALIGN (gnu_type))))
 710     return true;
 711
 712   return false;
 713 }
 714
 715 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 716    it should be passed by reference. */
 717
 718 bool
 719 must_pass_by_ref (tree gnu_type)
 720 {
 721   /* We pass only unconstrained objects, those required by the language
 722      to be passed by reference, and objects of variable size.  The latter
 723      is more efficient, avoids problems with variable size temporaries,
 724      and does not produce compatibility problems with C, since C does
 725      not have such objects.  */
 726   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 727           || TREE_ADDRESSABLE (gnu_type)
 728           || (TYPE_SIZE (gnu_type)
 729               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 730 }
 731
 732 /* Return the size of the FP mode with precision PREC.  */
 733
 734 int
 735 fp_prec_to_size (int prec)
 736 {
 737   enum machine_mode mode;
 738
 739   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 740        mode = GET_MODE_WIDER_MODE (mode))
 741     if (GET_MODE_PRECISION (mode) == prec)
 742       return GET_MODE_BITSIZE (mode);
 743
 744   gcc_unreachable ();
 745 }
 746
 747 /* Return the precision of the FP mode with size SIZE.  */
 748
 749 int
 750 fp_size_to_prec (int size)
 751 {
 752   enum machine_mode mode;
 753
 754   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 755        mode = GET_MODE_WIDER_MODE (mode))
 756     if (GET_MODE_BITSIZE (mode) == size)
 757       return GET_MODE_PRECISION (mode);
 758
 759   gcc_unreachable ();
 760 }
 761
 762 static GTY(()) tree gnat_eh_personality_decl;
 763
 764 static tree
 765 gnat_eh_personality (void)
 766 {
 767   if (!gnat_eh_personality_decl)
 768     gnat_eh_personality_decl
 769       = build_personality_function (targetm.except_unwind_info () == UI_SJLJ
 770                                     ? "__gnat_eh_personality_sj"
 771                                     : "__gnat_eh_personality");
 772
 773   return gnat_eh_personality_decl;
 774 }
 775
 776 #include "gt-ada-misc.h"