gcc/ada/gcc-interface/misc.c

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