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