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-2014, 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 "opts.h"
  30 #include "options.h"
  31 #include "tm.h"
  32 #include "tree.h"
  33 #include "stor-layout.h"
  34 #include "print-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 "plugin.h"
  44 #include "real.h"
  45 #include "function.h"   /* For pass_by_reference.  */
  46
  47 #include "ada.h"
  48 #include "adadecode.h"
  49 #include "types.h"
  50 #include "atree.h"
  51 #include "elists.h"
  52 #include "namet.h"
  53 #include "nlists.h"
  54 #include "stringt.h"
  55 #include "uintp.h"
  56 #include "fe.h"
  57 #include "sinfo.h"
  58 #include "einfo.h"
  59 #include "ada-tree.h"
  60 #include "gigi.h"
  61
  62 /* This symbol needs to be defined for the front-end.  */
  63 void *callgraph_info_file = NULL;
  64
  65 /* Command-line argc and argv.  These variables are global since they are
  66    imported in back_end.adb.  */
  67 unsigned int save_argc;
  68 const char **save_argv;
  69
  70 /* GNAT argc and argv.  */
  71 extern int gnat_argc;
  72 extern char **gnat_argv;
  73
  74 #ifdef __cplusplus
  75 extern "C" {
  76 #endif
  77
  78 /* Declare functions we use as part of startup.  */
  79 extern void __gnat_initialize (void *);
  80 extern void __gnat_install_SEH_handler (void *);
  81 extern void adainit (void);
  82 extern void _ada_gnat1drv (void);
  83
  84 #ifdef __cplusplus
  85 }
  86 #endif
  87
  88 /* The parser for the language.  For us, we process the GNAT tree.  */
  89
  90 static void
  91 gnat_parse_file (void)
  92 {
  93   int seh[2];
  94
  95   /* Call the target specific initializations.  */
  96   __gnat_initialize (NULL);
  97
  98   /* ??? Call the SEH initialization routine.  This is to workaround
  99   a bootstrap path problem.  The call below should be removed at some
 100   point and the SEH pointer passed to __gnat_initialize() above.  */
 101   __gnat_install_SEH_handler((void *)seh);
 102
 103   /* Call the front-end elaboration procedures.  */
 104   adainit ();
 105
 106   /* Call the front end.  */
 107   _ada_gnat1drv ();
 108 }
 109
 110 /* Return language mask for option processing.  */
 111
 112 static unsigned int
 113 gnat_option_lang_mask (void)
 114 {
 115   return CL_Ada;
 116 }
 117
 118 /* Decode all the language specific options that cannot be decoded by GCC.
 119    The option decoding phase of GCC calls this routine on the flags that
 120    are marked as Ada-specific.  Return true on success or false on failure.  */
 121
 122 static bool
 123 gnat_handle_option (size_t scode, const char *arg ATTRIBUTE_UNUSED, int value,
 124                     int kind ATTRIBUTE_UNUSED, location_t loc ATTRIBUTE_UNUSED,
 125                     const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED)
 126 {
 127   enum opt_code code = (enum opt_code) scode;
 128
 129   switch (code)
 130     {
 131     case OPT_Wall:
 132       handle_generated_option (&global_options, &global_options_set,
 133                                OPT_Wunused, NULL, value,
 134                                gnat_option_lang_mask (), kind, loc,
 135                                handlers, global_dc);
 136       warn_uninitialized = value;
 137       warn_maybe_uninitialized = value;
 138       break;
 139
 140     case OPT_gant:
 141       warning (0, "%<-gnat%> misspelled as %<-gant%>");
 142
 143       /* ... fall through ... */
 144
 145     case OPT_gnat:
 146     case OPT_gnatO:
 147     case OPT_fRTS_:
 148     case OPT_I:
 149     case OPT_nostdinc:
 150     case OPT_nostdlib:
 151       /* These are handled by the front-end.  */
 152       break;
 153
 154     case OPT_fshort_enums:
 155       /* This is handled by the middle-end.  */
 156       break;
 157
 158     default:
 159       gcc_unreachable ();
 160     }
 161
 162   Ada_handle_option_auto (&global_options, &global_options_set,
 163                           scode, arg, value,
 164                           gnat_option_lang_mask (), kind,
 165                           loc, handlers, global_dc);
 166   return true;
 167 }
 168
 169 /* Initialize options structure OPTS.  */
 170
 171 static void
 172 gnat_init_options_struct (struct gcc_options *opts)
 173 {
 174   /* Uninitialized really means uninitialized in Ada.  */
 175   opts->x_flag_zero_initialized_in_bss = 0;
 176
 177   /* We can delete dead instructions that may throw exceptions in Ada.  */
 178   opts->x_flag_delete_dead_exceptions = 1;
 179 }
 180
 181 /* Initialize for option processing.  */
 182
 183 static void
 184 gnat_init_options (unsigned int decoded_options_count,
 185                    struct cl_decoded_option *decoded_options)
 186 {
 187   /* Reconstruct an argv array for use of back_end.adb.
 188
 189      ??? back_end.adb should not rely on this; instead, it should work with
 190      decoded options without such reparsing, to ensure consistency in how
 191      options are decoded.  */
 192   unsigned int i;
 193
 194   save_argv = XNEWVEC (const char *, 2 * decoded_options_count + 1);
 195   save_argc = 0;
 196   for (i = 0; i < decoded_options_count; i++)
 197     {
 198       size_t num_elements = decoded_options[i].canonical_option_num_elements;
 199
 200       if (decoded_options[i].errors
 201           || decoded_options[i].opt_index == OPT_SPECIAL_unknown
 202           || num_elements == 0)
 203         continue;
 204
 205       /* Deal with -I- specially since it must be a single switch.  */
 206       if (decoded_options[i].opt_index == OPT_I
 207           && num_elements == 2
 208           && decoded_options[i].canonical_option[1][0] == '-'
 209           && decoded_options[i].canonical_option[1][1] == '\0')
 210         save_argv[save_argc++] = "-I-";
 211       else
 212         {
 213           gcc_assert (num_elements >= 1 && num_elements <= 2);
 214           save_argv[save_argc++] = decoded_options[i].canonical_option[0];
 215           if (num_elements >= 2)
 216             save_argv[save_argc++] = decoded_options[i].canonical_option[1];
 217         }
 218     }
 219   save_argv[save_argc] = NULL;
 220
 221   gnat_argv = (char **) xmalloc (sizeof (save_argv[0]));
 222   gnat_argv[0] = xstrdup (save_argv[0]);     /* name of the command */
 223   gnat_argc = 1;
 224 }
 225
 226 /* Ada code requires variables for these settings rather than elements
 227    of the global_options structure.  */
 228 #undef optimize
 229 #undef optimize_size
 230 #undef flag_compare_debug
 231 #undef flag_short_enums
 232 #undef flag_stack_check
 233 int optimize;
 234 int optimize_size;
 235 int flag_compare_debug;
 236 int flag_short_enums;
 237 enum stack_check_type flag_stack_check = NO_STACK_CHECK;
 238
 239 /* Settings adjustments after switches processing by the back-end.
 240    Note that the front-end switches processing (Scan_Compiler_Arguments)
 241    has not been done yet at this point!  */
 242
 243 static bool
 244 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
 245 {
 246   /* Excess precision other than "fast" requires front-end support.  */
 247   if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD
 248       && TARGET_FLT_EVAL_METHOD_NON_DEFAULT)
 249     sorry ("-fexcess-precision=standard for Ada");
 250   flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
 251
 252   /* ??? The warning machinery is outsmarted by Ada.  */
 253   warn_unused_parameter = 0;
 254
 255   /* No psABI change warnings for Ada.  */
 256   warn_psabi = 0;
 257
 258   /* No caret by default for Ada.  */
 259   if (!global_options_set.x_flag_diagnostics_show_caret)
 260     global_dc->show_caret = false;
 261
 262   optimize = global_options.x_optimize;
 263   optimize_size = global_options.x_optimize_size;
 264   flag_compare_debug = global_options.x_flag_compare_debug;
 265   flag_stack_check = global_options.x_flag_stack_check;
 266   flag_short_enums = global_options.x_flag_short_enums;
 267
 268   /* Unfortunately the post_options hook is called before the value of
 269      flag_short_enums is autodetected, if need be.  Mimic the process
 270      for our private flag_short_enums.  */
 271   if (flag_short_enums == 2)
 272     flag_short_enums = targetm.default_short_enums ();
 273
 274   return false;
 275 }
 276
 277 /* Here is the function to handle the compiler error processing in GCC.  */
 278
 279 static void
 280 internal_error_function (diagnostic_context *context,
 281                          const char *msgid, va_list *ap)
 282 {
 283   text_info tinfo;
 284   char *buffer, *p, *loc;
 285   String_Template temp, temp_loc;
 286   DECLARE_STRING_POINTER (sp, sp_loc);
 287   expanded_location xloc;
 288
 289   /* Warn if plugins present.  */
 290   warn_if_plugins ();
 291
 292   /* Reset the pretty-printer.  */
 293   pp_clear_output_area (context->printer);
 294
 295   /* Format the message into the pretty-printer.  */
 296   tinfo.format_spec = msgid;
 297   tinfo.args_ptr = ap;
 298   tinfo.err_no = errno;
 299   pp_format_verbatim (context->printer, &tinfo);
 300
 301   /* Extract a (writable) pointer to the formatted text.  */
 302   buffer = xstrdup (pp_formatted_text (context->printer));
 303
 304   /* Go up to the first newline.  */
 305   for (p = buffer; *p; p++)
 306     if (*p == '\n')
 307       {
 308         *p = '\0';
 309         break;
 310       }
 311
 312   temp.Low_Bound = 1;
 313   temp.High_Bound = p - buffer;
 314   sp.Bounds = &temp;
 315   sp.Array = buffer;
 316
 317   xloc = expand_location (input_location);
 318   if (context->show_column && xloc.column != 0)
 319     asprintf (&loc, "%s:%d:%d", xloc.file, xloc.line, xloc.column);
 320   else
 321     asprintf (&loc, "%s:%d", xloc.file, xloc.line);
 322   temp_loc.Low_Bound = 1;
 323   temp_loc.High_Bound = strlen (loc);
 324   sp_loc.Bounds = &temp_loc;
 325   sp_loc.Array = loc;
 326
 327   Current_Error_Node = error_gnat_node;
 328   Compiler_Abort (sp, -1, sp_loc);
 329 }
 330
 331 /* Perform all the initialization steps that are language-specific.  */
 332
 333 static bool
 334 gnat_init (void)
 335 {
 336   /* Do little here, most of the standard declarations are set up after the
 337      front-end has been run.  Use the same `char' as C, this doesn't really
 338      matter since we'll use the explicit `unsigned char' for Character.  */
 339   build_common_tree_nodes (flag_signed_char, false);
 340
 341   /* In Ada, we use an unsigned 8-bit type for the default boolean type.  */
 342   boolean_type_node = make_unsigned_type (8);
 343   TREE_SET_CODE (boolean_type_node, BOOLEAN_TYPE);
 344   SET_TYPE_RM_MAX_VALUE (boolean_type_node,
 345                          build_int_cst (boolean_type_node, 1));
 346   SET_TYPE_RM_SIZE (boolean_type_node, bitsize_int (1));
 347   boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
 348   boolean_false_node = TYPE_MIN_VALUE (boolean_type_node);
 349
 350   sbitsize_one_node = sbitsize_int (1);
 351   sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT);
 352
 353   ptr_void_type_node = build_pointer_type (void_type_node);
 354
 355   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 356   internal_reference_types ();
 357
 358   /* Register our internal error function.  */
 359   global_dc->internal_error = &internal_error_function;
 360
 361   return true;
 362 }
 363
 364 /* Initialize the GCC support for exception handling.  */
 365
 366 void
 367 gnat_init_gcc_eh (void)
 368 {
 369   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 370      though. This could for instance lead to the emission of tables with
 371      references to symbols (such as the Ada eh personality routine) within
 372      libraries we won't link against.  */
 373   if (No_Exception_Handlers_Set ())
 374     return;
 375
 376   /* Tell GCC we are handling cleanup actions through exception propagation.
 377      This opens possibilities that we don't take advantage of yet, but is
 378      nonetheless necessary to ensure that fixup code gets assigned to the
 379      right exception regions.  */
 380   using_eh_for_cleanups ();
 381
 382   /* Turn on -fexceptions and -fnon-call-exceptions.  The first one triggers
 383      the generation of the necessary exception tables.  The second one is
 384      useful for two reasons: 1/ we map some asynchronous signals like SEGV to
 385      exceptions, so we need to ensure that the insns which can lead to such
 386      signals are correctly attached to the exception region they pertain to,
 387      2/ Some calls to pure subprograms are handled as libcall blocks and then
 388      marked as "cannot trap" if the flag is not set (see emit_libcall_block).
 389      We should not let this be since it is possible for such calls to actually
 390      raise in Ada.  */
 391   flag_exceptions = 1;
 392   flag_non_call_exceptions = 1;
 393
 394   init_eh ();
 395 }
 396
 397 /* Initialize the GCC support for floating-point operations.  */
 398
 399 void
 400 gnat_init_gcc_fp (void)
 401 {
 402   /* Disable FP optimizations that ignore the signedness of zero if
 403      S'Signed_Zeros is true, but don't override the user if not.  */
 404   if (Signed_Zeros_On_Target)
 405     flag_signed_zeros = 1;
 406   else if (!global_options_set.x_flag_signed_zeros)
 407     flag_signed_zeros = 0;
 408
 409   /* Assume that FP operations can trap if S'Machine_Overflow is true,
 410      but don't override the user if not.
 411
 412      ??? Alpha/VMS enables FP traps without declaring it.  */
 413   if (Machine_Overflows_On_Target || TARGET_ABI_OPEN_VMS)
 414     flag_trapping_math = 1;
 415   else if (!global_options_set.x_flag_trapping_math)
 416     flag_trapping_math = 0;
 417 }
 418
 419 /* Print language-specific items in declaration NODE.  */
 420
 421 static void
 422 gnat_print_decl (FILE *file, tree node, int indent)
 423 {
 424   switch (TREE_CODE (node))
 425     {
 426     case CONST_DECL:
 427       print_node (file, "corresponding var",
 428                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 429       break;
 430
 431     case FIELD_DECL:
 432       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 433                   indent + 4);
 434       break;
 435
 436     case VAR_DECL:
 437       if (DECL_LOOP_PARM_P (node))
 438         print_node (file, "induction var", DECL_INDUCTION_VAR (node),
 439                     indent + 4);
 440       else
 441         print_node (file, "renamed object", DECL_RENAMED_OBJECT (node),
 442                     indent + 4);
 443       break;
 444
 445     default:
 446       break;
 447     }
 448 }
 449
 450 /* Print language-specific items in type NODE.  */
 451
 452 static void
 453 gnat_print_type (FILE *file, tree node, int indent)
 454 {
 455   switch (TREE_CODE (node))
 456     {
 457     case FUNCTION_TYPE:
 458       print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4);
 459       break;
 460
 461     case INTEGER_TYPE:
 462       if (TYPE_MODULAR_P (node))
 463         print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
 464       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 465         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 466                     indent + 4);
 467       else if (TYPE_VAX_FLOATING_POINT_P (node))
 468         ;
 469       else
 470         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 471
 472       /* ... fall through ... */
 473
 474     case ENUMERAL_TYPE:
 475     case BOOLEAN_TYPE:
 476       print_node_brief (file, "RM size", TYPE_RM_SIZE (node), indent + 4);
 477
 478       /* ... fall through ... */
 479
 480     case REAL_TYPE:
 481       print_node_brief (file, "RM min", TYPE_RM_MIN_VALUE (node), indent + 4);
 482       print_node_brief (file, "RM max", TYPE_RM_MAX_VALUE (node), indent + 4);
 483       break;
 484
 485     case ARRAY_TYPE:
 486       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 487       break;
 488
 489     case VECTOR_TYPE:
 490       print_node (file,"representative array",
 491                   TYPE_REPRESENTATIVE_ARRAY (node), indent + 4);
 492       break;
 493
 494     case RECORD_TYPE:
 495       if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 496         print_node (file, "unconstrained array",
 497                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 498       else
 499         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 500       break;
 501
 502     case UNION_TYPE:
 503     case QUAL_UNION_TYPE:
 504       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 505       break;
 506
 507     default:
 508       break;
 509     }
 510 }
 511
 512 /* Return the name to be printed for DECL.  */
 513
 514 static const char *
 515 gnat_printable_name (tree decl, int verbosity)
 516 {
 517   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 518   char *ada_name = (char *) ggc_alloc_atomic (strlen (coded_name) * 2 + 60);
 519
 520   __gnat_decode (coded_name, ada_name, 0);
 521
 522   if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
 523     {
 524       Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl));
 525       return ggc_strdup (Name_Buffer);
 526     }
 527
 528   return ada_name;
 529 }
 530
 531 /* Return the name to be used in DWARF debug info for DECL.  */
 532
 533 static const char *
 534 gnat_dwarf_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
 535 {
 536   gcc_assert (DECL_P (decl));
 537   return (const char *) IDENTIFIER_POINTER (DECL_NAME (decl));
 538 }
 539
 540 /* Return the descriptive type associated with TYPE, if any.  */
 541
 542 static tree
 543 gnat_descriptive_type (const_tree type)
 544 {
 545   if (TYPE_STUB_DECL (type))
 546     return DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type));
 547   else
 548     return NULL_TREE;
 549 }
 550
 551 /* Return true if types T1 and T2 are identical for type hashing purposes.
 552    Called only after doing all language independent checks.  At present,
 553    this function is only called when both types are FUNCTION_TYPE.  */
 554
 555 static bool
 556 gnat_type_hash_eq (const_tree t1, const_tree t2)
 557 {
 558   gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE);
 559   return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
 560                               TYPE_RETURN_UNCONSTRAINED_P (t2),
 561                               TYPE_RETURN_BY_DIRECT_REF_P (t2),
 562                               TREE_ADDRESSABLE (t2));
 563 }
 564
 565 /* Do nothing (return the tree node passed).  */
 566
 567 static tree
 568 gnat_return_tree (tree t)
 569 {
 570   return t;
 571 }
 572
 573 /* Get the alias set corresponding to a type or expression.  */
 574
 575 static alias_set_type
 576 gnat_get_alias_set (tree type)
 577 {
 578   /* If this is a padding type, use the type of the first field.  */
 579   if (TYPE_IS_PADDING_P (type))
 580     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 581
 582   /* If the type is an unconstrained array, use the type of the
 583      self-referential array we make.  */
 584   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 585     return
 586       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 587
 588   /* If the type can alias any other types, return the alias set 0.  */
 589   else if (TYPE_P (type)
 590            && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
 591     return 0;
 592
 593   return -1;
 594 }
 595
 596 /* GNU_TYPE is a type.  Return its maximum size in bytes, if known,
 597    as a constant when possible.  */
 598
 599 static tree
 600 gnat_type_max_size (const_tree gnu_type)
 601 {
 602   /* First see what we can get from TYPE_SIZE_UNIT, which might not
 603      be constant even for simple expressions if it has already been
 604      elaborated and possibly replaced by a VAR_DECL.  */
 605   tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
 606
 607   /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
 608      which should stay untouched.  */
 609   if (!tree_fits_uhwi_p (max_unitsize)
 610       && RECORD_OR_UNION_TYPE_P (gnu_type)
 611       && !TYPE_FAT_POINTER_P (gnu_type)
 612       && TYPE_ADA_SIZE (gnu_type))
 613     {
 614       tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
 615
 616       /* If we have succeeded in finding a constant, round it up to the
 617          type's alignment and return the result in units.  */
 618       if (tree_fits_uhwi_p (max_adasize))
 619         max_unitsize
 620           = size_binop (CEIL_DIV_EXPR,
 621                         round_up (max_adasize, TYPE_ALIGN (gnu_type)),
 622                         bitsize_unit_node);
 623     }
 624
 625   return max_unitsize;
 626 }
 627
 628 /* GNU_TYPE is a subtype of an integral type.  Set LOWVAL to the low bound
 629    and HIGHVAL to the high bound, respectively.  */
 630
 631 static void
 632 gnat_get_subrange_bounds (const_tree gnu_type, tree *lowval, tree *highval)
 633 {
 634   *lowval = TYPE_MIN_VALUE (gnu_type);
 635   *highval = TYPE_MAX_VALUE (gnu_type);
 636 }
 637
 638 /* GNU_TYPE is the type of a subprogram parameter.  Determine if it should be
 639    passed by reference by default.  */
 640
 641 bool
 642 default_pass_by_ref (tree gnu_type)
 643 {
 644   /* We pass aggregates by reference if they are sufficiently large for
 645      their alignment.  The ratio is somewhat arbitrary.  We also pass by
 646      reference if the target machine would either pass or return by
 647      reference.  Strictly speaking, we need only check the return if this
 648      is an In Out parameter, but it's probably best to err on the side of
 649      passing more things by reference.  */
 650
 651   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, true))
 652     return true;
 653
 654   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 655     return true;
 656
 657   if (AGGREGATE_TYPE_P (gnu_type)
 658       && (!valid_constant_size_p (TYPE_SIZE_UNIT (gnu_type))
 659           || 0 < compare_tree_int (TYPE_SIZE_UNIT (gnu_type),
 660                                    TYPE_ALIGN (gnu_type))))
 661     return true;
 662
 663   return false;
 664 }
 665
 666 /* GNU_TYPE is the type of a subprogram parameter.  Determine if it must be
 667    passed by reference.  */
 668
 669 bool
 670 must_pass_by_ref (tree gnu_type)
 671 {
 672   /* We pass only unconstrained objects, those required by the language
 673      to be passed by reference, and objects of variable size.  The latter
 674      is more efficient, avoids problems with variable size temporaries,
 675      and does not produce compatibility problems with C, since C does
 676      not have such objects.  */
 677   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 678           || TYPE_IS_BY_REFERENCE_P (gnu_type)
 679           || (TYPE_SIZE_UNIT (gnu_type)
 680               && TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST));
 681 }
 682
 683 /* This function is called by the front-end to enumerate all the supported
 684    modes for the machine, as well as some predefined C types.  F is a function
 685    which is called back with the parameters as listed below, first a string,
 686    then seven ints.  The name is any arbitrary null-terminated string and has
 687    no particular significance, except for the case of predefined C types, where
 688    it should be the name of the C type.  For integer types, only signed types
 689    should be listed, unsigned versions are assumed.  The order of types should
 690    be in order of preference, with the smallest/cheapest types first.
 691
 692    In particular, C predefined types should be listed before other types,
 693    binary floating point types before decimal ones, and narrower/cheaper
 694    type versions before more expensive ones.  In type selection the first
 695    matching variant will be used.
 696
 697    NAME         pointer to first char of type name
 698    DIGS         number of decimal digits for floating-point modes, else 0
 699    COMPLEX_P    nonzero is this represents a complex mode
 700    COUNT        count of number of items, nonzero for vector mode
 701    FLOAT_REP    Float_Rep_Kind for FP, otherwise undefined
 702    PRECISION    number of bits used to store data
 703    SIZE         number of bits occupied by the mode
 704    ALIGN        number of bits to which mode is aligned.  */
 705
 706 void
 707 enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int))
 708 {
 709   const tree c_types[]
 710     = { float_type_node, double_type_node, long_double_type_node };
 711   const char *const c_names[]
 712     = { "float", "double", "long double" };
 713   int iloop;
 714
 715   for (iloop = 0; iloop < NUM_MACHINE_MODES; iloop++)
 716     {
 717       enum machine_mode i = (enum machine_mode) iloop;
 718       enum machine_mode inner_mode = i;
 719       bool float_p = false;
 720       bool complex_p = false;
 721       bool vector_p = false;
 722       bool skip_p = false;
 723       int digs = 0;
 724       unsigned int nameloop;
 725       Float_Rep_Kind float_rep = IEEE_Binary; /* Until proven otherwise */
 726
 727       switch (GET_MODE_CLASS (i))
 728         {
 729         case MODE_INT:
 730           break;
 731         case MODE_FLOAT:
 732           float_p = true;
 733           break;
 734         case MODE_COMPLEX_INT:
 735           complex_p = true;
 736           inner_mode = GET_MODE_INNER (i);
 737           break;
 738         case MODE_COMPLEX_FLOAT:
 739           float_p = true;
 740           complex_p = true;
 741           inner_mode = GET_MODE_INNER (i);
 742           break;
 743         case MODE_VECTOR_INT:
 744           vector_p = true;
 745           inner_mode = GET_MODE_INNER (i);
 746           break;
 747         case MODE_VECTOR_FLOAT:
 748           float_p = true;
 749           vector_p = true;
 750           inner_mode = GET_MODE_INNER (i);
 751           break;
 752         default:
 753           skip_p = true;
 754         }
 755
 756       if (float_p)
 757         {
 758           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 759
 760           /* ??? Cope with the ghost XFmode of the ARM port.  */
 761           if (!fmt)
 762             continue;
 763
 764           if (fmt->b == 2)
 765             digs = (fmt->p - 1) * 1233 / 4096; /* scale by log (2) */
 766
 767           else if (fmt->b == 10)
 768             digs = fmt->p;
 769
 770           else
 771             gcc_unreachable();
 772
 773           if (fmt == &vax_f_format
 774               || fmt == &vax_d_format
 775               || fmt == &vax_g_format)
 776             float_rep = VAX_Native;
 777         }
 778
 779       /* First register any C types for this mode that the front end
 780          may need to know about, unless the mode should be skipped.  */
 781       if (!skip_p && !vector_p)
 782         for (nameloop = 0; nameloop < ARRAY_SIZE (c_types); nameloop++)
 783           {
 784             tree type = c_types[nameloop];
 785             const char *name = c_names[nameloop];
 786
 787             if (TYPE_MODE (type) == i)
 788               {
 789                 f (name, digs, complex_p, 0, float_rep, TYPE_PRECISION (type),
 790                    TREE_INT_CST_LOW (TYPE_SIZE (type)), TYPE_ALIGN (type));
 791                 skip_p = true;
 792               }
 793           }
 794
 795       /* If no predefined C types were found, register the mode itself.  */
 796       if (!skip_p)
 797         f (GET_MODE_NAME (i), digs, complex_p,
 798            vector_p ? GET_MODE_NUNITS (i) : 0, float_rep,
 799            GET_MODE_PRECISION (i), GET_MODE_BITSIZE (i),
 800            GET_MODE_ALIGNMENT (i));
 801     }
 802 }
 803
 804 /* Return the size of the FP mode with precision PREC.  */
 805
 806 int
 807 fp_prec_to_size (int prec)
 808 {
 809   enum machine_mode mode;
 810
 811   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 812        mode = GET_MODE_WIDER_MODE (mode))
 813     if (GET_MODE_PRECISION (mode) == prec)
 814       return GET_MODE_BITSIZE (mode);
 815
 816   gcc_unreachable ();
 817 }
 818
 819 /* Return the precision of the FP mode with size SIZE.  */
 820
 821 int
 822 fp_size_to_prec (int size)
 823 {
 824   enum machine_mode mode;
 825
 826   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 827        mode = GET_MODE_WIDER_MODE (mode))
 828     if (GET_MODE_BITSIZE (mode) == size)
 829       return GET_MODE_PRECISION (mode);
 830
 831   gcc_unreachable ();
 832 }
 833
 834 static GTY(()) tree gnat_eh_personality_decl;
 835
 836 /* Return the GNAT personality function decl.  */
 837
 838 static tree
 839 gnat_eh_personality (void)
 840 {
 841   if (!gnat_eh_personality_decl)
 842     gnat_eh_personality_decl = build_personality_function ("gnat");
 843   return gnat_eh_personality_decl;
 844 }
 845
 846 /* Initialize language-specific bits of tree_contains_struct.  */
 847
 848 static void
 849 gnat_init_ts (void)
 850 {
 851   MARK_TS_COMMON (UNCONSTRAINED_ARRAY_TYPE);
 852
 853   MARK_TS_TYPED (UNCONSTRAINED_ARRAY_REF);
 854   MARK_TS_TYPED (NULL_EXPR);
 855   MARK_TS_TYPED (PLUS_NOMOD_EXPR);
 856   MARK_TS_TYPED (MINUS_NOMOD_EXPR);
 857   MARK_TS_TYPED (ATTR_ADDR_EXPR);
 858   MARK_TS_TYPED (STMT_STMT);
 859   MARK_TS_TYPED (LOOP_STMT);
 860   MARK_TS_TYPED (EXIT_STMT);
 861 }
 862
 863 /* Definitions for our language-specific hooks.  */
 864
 865 #undef  LANG_HOOKS_NAME
 866 #define LANG_HOOKS_NAME                 "GNU Ada"
 867 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 868 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 869 #undef  LANG_HOOKS_INIT
 870 #define LANG_HOOKS_INIT                 gnat_init
 871 #undef  LANG_HOOKS_OPTION_LANG_MASK
 872 #define LANG_HOOKS_OPTION_LANG_MASK     gnat_option_lang_mask
 873 #undef  LANG_HOOKS_INIT_OPTIONS_STRUCT
 874 #define LANG_HOOKS_INIT_OPTIONS_STRUCT  gnat_init_options_struct
 875 #undef  LANG_HOOKS_INIT_OPTIONS
 876 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 877 #undef  LANG_HOOKS_HANDLE_OPTION
 878 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
 879 #undef  LANG_HOOKS_POST_OPTIONS
 880 #define LANG_HOOKS_POST_OPTIONS         gnat_post_options
 881 #undef  LANG_HOOKS_PARSE_FILE
 882 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 883 #undef  LANG_HOOKS_TYPE_HASH_EQ
 884 #define LANG_HOOKS_TYPE_HASH_EQ         gnat_type_hash_eq
 885 #undef  LANG_HOOKS_GETDECLS
 886 #define LANG_HOOKS_GETDECLS             lhd_return_null_tree_v
 887 #undef  LANG_HOOKS_PUSHDECL
 888 #define LANG_HOOKS_PUSHDECL             gnat_return_tree
 889 #undef  LANG_HOOKS_WRITE_GLOBALS
 890 #define LANG_HOOKS_WRITE_GLOBALS        gnat_write_global_declarations
 891 #undef  LANG_HOOKS_GET_ALIAS_SET
 892 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 893 #undef  LANG_HOOKS_PRINT_DECL
 894 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 895 #undef  LANG_HOOKS_PRINT_TYPE
 896 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 897 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 898 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 899 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 900 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 901 #undef  LANG_HOOKS_DWARF_NAME
 902 #define LANG_HOOKS_DWARF_NAME           gnat_dwarf_name
 903 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 904 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 905 #undef  LANG_HOOKS_TYPE_FOR_MODE
 906 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 907 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 908 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 909 #undef  LANG_HOOKS_TYPES_COMPATIBLE_P
 910 #define LANG_HOOKS_TYPES_COMPATIBLE_P   gnat_types_compatible_p
 911 #undef  LANG_HOOKS_GET_SUBRANGE_BOUNDS
 912 #define LANG_HOOKS_GET_SUBRANGE_BOUNDS  gnat_get_subrange_bounds
 913 #undef  LANG_HOOKS_DESCRIPTIVE_TYPE
 914 #define LANG_HOOKS_DESCRIPTIVE_TYPE     gnat_descriptive_type
 915 #undef  LANG_HOOKS_ATTRIBUTE_TABLE
 916 #define LANG_HOOKS_ATTRIBUTE_TABLE      gnat_internal_attribute_table
 917 #undef  LANG_HOOKS_BUILTIN_FUNCTION
 918 #define LANG_HOOKS_BUILTIN_FUNCTION     gnat_builtin_function
 919 #undef  LANG_HOOKS_EH_PERSONALITY
 920 #define LANG_HOOKS_EH_PERSONALITY       gnat_eh_personality
 921 #undef  LANG_HOOKS_DEEP_UNSHARING
 922 #define LANG_HOOKS_DEEP_UNSHARING       true
 923 #undef  LANG_HOOKS_INIT_TS
 924 #define LANG_HOOKS_INIT_TS              gnat_init_ts
 925
 926 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 927
 928 #include "gt-ada-misc.h"