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