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