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