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       if (DECL_LOOP_PARM_P (node))
 398         print_node (file, "induction var", DECL_INDUCTION_VAR (node),
 399                     indent + 4);
 400       else
 401         print_node (file, "renamed object", DECL_RENAMED_OBJECT (node),
 402                     indent + 4);
 403       break;
 404
 405     default:
 406       break;
 407     }
 408 }
 409
 410 /* Print language-specific items in type NODE.  */
 411
 412 static void
 413 gnat_print_type (FILE *file, tree node, int indent)
 414 {
 415   switch (TREE_CODE (node))
 416     {
 417     case FUNCTION_TYPE:
 418       print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4);
 419       break;
 420
 421     case INTEGER_TYPE:
 422       if (TYPE_MODULAR_P (node))
 423         print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
 424       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 425         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 426                     indent + 4);
 427       else if (TYPE_VAX_FLOATING_POINT_P (node))
 428         ;
 429       else
 430         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 431
 432       /* ... fall through ... */
 433
 434     case ENUMERAL_TYPE:
 435     case BOOLEAN_TYPE:
 436       print_node_brief (file, "RM size", TYPE_RM_SIZE (node), indent + 4);
 437
 438       /* ... fall through ... */
 439
 440     case REAL_TYPE:
 441       print_node_brief (file, "RM min", TYPE_RM_MIN_VALUE (node), indent + 4);
 442       print_node_brief (file, "RM max", TYPE_RM_MAX_VALUE (node), indent + 4);
 443       break;
 444
 445     case ARRAY_TYPE:
 446       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 447       break;
 448
 449     case VECTOR_TYPE:
 450       print_node (file,"representative array",
 451                   TYPE_REPRESENTATIVE_ARRAY (node), indent + 4);
 452       break;
 453
 454     case RECORD_TYPE:
 455       if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 456         print_node (file, "unconstrained array",
 457                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 458       else
 459         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 460       break;
 461
 462     case UNION_TYPE:
 463     case QUAL_UNION_TYPE:
 464       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 465       break;
 466
 467     default:
 468       break;
 469     }
 470 }
 471
 472 /* Return the name to be printed for DECL.  */
 473
 474 static const char *
 475 gnat_printable_name (tree decl, int verbosity)
 476 {
 477   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 478   char *ada_name = (char *) ggc_alloc_atomic (strlen (coded_name) * 2 + 60);
 479
 480   __gnat_decode (coded_name, ada_name, 0);
 481
 482   if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
 483     {
 484       Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl));
 485       return ggc_strdup (Name_Buffer);
 486     }
 487
 488   return ada_name;
 489 }
 490
 491 /* Return the name to be used in DWARF debug info for DECL.  */
 492
 493 static const char *
 494 gnat_dwarf_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
 495 {
 496   gcc_assert (DECL_P (decl));
 497   return (const char *) IDENTIFIER_POINTER (DECL_NAME (decl));
 498 }
 499
 500 /* Return the descriptive type associated with TYPE, if any.  */
 501
 502 static tree
 503 gnat_descriptive_type (const_tree type)
 504 {
 505   if (TYPE_STUB_DECL (type))
 506     return DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type));
 507   else
 508     return NULL_TREE;
 509 }
 510
 511 /* Return true if types T1 and T2 are identical for type hashing purposes.
 512    Called only after doing all language independent checks.  At present,
 513    this function is only called when both types are FUNCTION_TYPE.  */
 514
 515 static bool
 516 gnat_type_hash_eq (const_tree t1, const_tree t2)
 517 {
 518   gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE);
 519   return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
 520                               TYPE_RETURN_UNCONSTRAINED_P (t2),
 521                               TYPE_RETURN_BY_DIRECT_REF_P (t2),
 522                               TREE_ADDRESSABLE (t2));
 523 }
 524
 525 /* Do nothing (return the tree node passed).  */
 526
 527 static tree
 528 gnat_return_tree (tree t)
 529 {
 530   return t;
 531 }
 532
 533 /* Get the alias set corresponding to a type or expression.  */
 534
 535 static alias_set_type
 536 gnat_get_alias_set (tree type)
 537 {
 538   /* If this is a padding type, use the type of the first field.  */
 539   if (TYPE_IS_PADDING_P (type))
 540     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 541
 542   /* If the type is an unconstrained array, use the type of the
 543      self-referential array we make.  */
 544   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 545     return
 546       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 547
 548   /* If the type can alias any other types, return the alias set 0.  */
 549   else if (TYPE_P (type)
 550            && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
 551     return 0;
 552
 553   return -1;
 554 }
 555
 556 /* GNU_TYPE is a type.  Return its maximum size in bytes, if known,
 557    as a constant when possible.  */
 558
 559 static tree
 560 gnat_type_max_size (const_tree gnu_type)
 561 {
 562   /* First see what we can get from TYPE_SIZE_UNIT, which might not
 563      be constant even for simple expressions if it has already been
 564      elaborated and possibly replaced by a VAR_DECL.  */
 565   tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
 566
 567   /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
 568      which should stay untouched.  */
 569   if (!host_integerp (max_unitsize, 1)
 570       && (TREE_CODE (gnu_type) == RECORD_TYPE
 571           || TREE_CODE (gnu_type) == UNION_TYPE
 572           || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
 573       && TYPE_ADA_SIZE (gnu_type))
 574     {
 575       tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
 576
 577       /* If we have succeeded in finding a constant, round it up to the
 578          type's alignment and return the result in units.  */
 579       if (host_integerp (max_adasize, 1))
 580         max_unitsize
 581           = size_binop (CEIL_DIV_EXPR,
 582                         round_up (max_adasize, TYPE_ALIGN (gnu_type)),
 583                         bitsize_unit_node);
 584     }
 585
 586   return max_unitsize;
 587 }
 588
 589 /* GNU_TYPE is a subtype of an integral type.  Set LOWVAL to the low bound
 590    and HIGHVAL to the high bound, respectively.  */
 591
 592 static void
 593 gnat_get_subrange_bounds (const_tree gnu_type, tree *lowval, tree *highval)
 594 {
 595   *lowval = TYPE_MIN_VALUE (gnu_type);
 596   *highval = TYPE_MAX_VALUE (gnu_type);
 597 }
 598
 599 /* GNU_TYPE is the type of a subprogram parameter.  Determine if it should be
 600    passed by reference by default.  */
 601
 602 bool
 603 default_pass_by_ref (tree gnu_type)
 604 {
 605   /* We pass aggregates by reference if they are sufficiently large.  The
 606      choice of constant here is somewhat arbitrary.  We also pass by
 607      reference if the target machine would either pass or return by
 608      reference.  Strictly speaking, we need only check the return if this
 609      is an In Out parameter, but it's probably best to err on the side of
 610      passing more things by reference.  */
 611
 612   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, true))
 613     return true;
 614
 615   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 616     return true;
 617
 618   if (AGGREGATE_TYPE_P (gnu_type)
 619       && (!host_integerp (TYPE_SIZE (gnu_type), 1)
 620           || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 621                                    8 * TYPE_ALIGN (gnu_type))))
 622     return true;
 623
 624   return false;
 625 }
 626
 627 /* GNU_TYPE is the type of a subprogram parameter.  Determine if it must be
 628    passed by reference.  */
 629
 630 bool
 631 must_pass_by_ref (tree gnu_type)
 632 {
 633   /* We pass only unconstrained objects, those required by the language
 634      to be passed by reference, and objects of variable size.  The latter
 635      is more efficient, avoids problems with variable size temporaries,
 636      and does not produce compatibility problems with C, since C does
 637      not have such objects.  */
 638   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 639           || TREE_ADDRESSABLE (gnu_type)
 640           || (TYPE_SIZE (gnu_type)
 641               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 642 }
 643
 644 /* This function is called by the front-end to enumerate all the supported
 645    modes for the machine, as well as some predefined C types.  F is a function
 646    which is called back with the parameters as listed below, first a string,
 647    then six ints.  The name is any arbitrary null-terminated string and has
 648    no particular significance, except for the case of predefined C types, where
 649    it should be the name of the C type.  For integer types, only signed types
 650    should be listed, unsigned versions are assumed.  The order of types should
 651    be in order of preference, with the smallest/cheapest types first.
 652
 653    In particular, C predefined types should be listed before other types,
 654    binary floating point types before decimal ones, and narrower/cheaper
 655    type versions before more expensive ones.  In type selection the first
 656    matching variant will be used.
 657
 658    NAME         pointer to first char of type name
 659    DIGS         number of decimal digits for floating-point modes, else 0
 660    COMPLEX_P    nonzero is this represents a complex mode
 661    COUNT        count of number of items, nonzero for vector mode
 662    FLOAT_REP    Float_Rep_Kind for FP, otherwise undefined
 663    SIZE         number of bits used to store data
 664    ALIGN        number of bits to which mode is aligned.  */
 665
 666 void
 667 enumerate_modes (void (*f) (const char *, int, int, int, int, int, int))
 668 {
 669   const tree c_types[]
 670     = { float_type_node, double_type_node, long_double_type_node };
 671   const char *const c_names[]
 672     = { "float", "double", "long double" };
 673   int iloop;
 674
 675   for (iloop = 0; iloop < NUM_MACHINE_MODES; iloop++)
 676     {
 677       enum machine_mode i = (enum machine_mode) iloop;
 678       enum machine_mode inner_mode = i;
 679       bool float_p = false;
 680       bool complex_p = false;
 681       bool vector_p = false;
 682       bool skip_p = false;
 683       int digs = 0;
 684       unsigned int nameloop;
 685       Float_Rep_Kind float_rep = IEEE_Binary; /* Until proven otherwise */
 686
 687       switch (GET_MODE_CLASS (i))
 688         {
 689         case MODE_INT:
 690           break;
 691         case MODE_FLOAT:
 692           float_p = true;
 693           break;
 694         case MODE_COMPLEX_INT:
 695           complex_p = true;
 696           inner_mode = GET_MODE_INNER (i);
 697           break;
 698         case MODE_COMPLEX_FLOAT:
 699           float_p = true;
 700           complex_p = true;
 701           inner_mode = GET_MODE_INNER (i);
 702           break;
 703         case MODE_VECTOR_INT:
 704           vector_p = true;
 705           inner_mode = GET_MODE_INNER (i);
 706           break;
 707         case MODE_VECTOR_FLOAT:
 708           float_p = true;
 709           vector_p = true;
 710           inner_mode = GET_MODE_INNER (i);
 711           break;
 712         default:
 713           skip_p = true;
 714         }
 715
 716       if (float_p)
 717         {
 718           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 719
 720           /* ??? Cope with the ghost XFmode of the ARM port.  */
 721           if (!fmt)
 722             continue;
 723
 724           if (fmt->b == 2)
 725             digs = (fmt->p - 1) * 1233 / 4096; /* scale by log (2) */
 726
 727           else if (fmt->b == 10)
 728             digs = fmt->p;
 729
 730           else
 731             gcc_unreachable();
 732
 733           if (fmt == &vax_f_format
 734               || fmt == &vax_d_format
 735               || fmt == &vax_g_format)
 736             float_rep = VAX_Native;
 737         }
 738
 739       /* First register any C types for this mode that the front end
 740          may need to know about, unless the mode should be skipped.  */
 741
 742       if (!skip_p)
 743         for (nameloop = 0; nameloop < ARRAY_SIZE (c_types); nameloop++)
 744           {
 745             tree typ = c_types[nameloop];
 746             const char *nam = c_names[nameloop];
 747
 748             if (TYPE_MODE (typ) == i)
 749               {
 750                 f (nam, digs, complex_p,
 751                    vector_p ? GET_MODE_NUNITS (i) : 0, float_rep,
 752                    TYPE_PRECISION (typ), TYPE_ALIGN (typ));
 753                 skip_p = true;
 754               }
 755           }
 756
 757       /* If no predefined C types were found, register the mode itself.  */
 758
 759       if (!skip_p)
 760         f (GET_MODE_NAME (i), digs, complex_p,
 761            vector_p ? GET_MODE_NUNITS (i) : 0, float_rep,
 762            GET_MODE_PRECISION (i), GET_MODE_ALIGNMENT (i));
 763     }
 764 }
 765
 766 /* Return the size of the FP mode with precision PREC.  */
 767
 768 int
 769 fp_prec_to_size (int prec)
 770 {
 771   enum machine_mode mode;
 772
 773   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 774        mode = GET_MODE_WIDER_MODE (mode))
 775     if (GET_MODE_PRECISION (mode) == prec)
 776       return GET_MODE_BITSIZE (mode);
 777
 778   gcc_unreachable ();
 779 }
 780
 781 /* Return the precision of the FP mode with size SIZE.  */
 782
 783 int
 784 fp_size_to_prec (int size)
 785 {
 786   enum machine_mode mode;
 787
 788   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 789        mode = GET_MODE_WIDER_MODE (mode))
 790     if (GET_MODE_BITSIZE (mode) == size)
 791       return GET_MODE_PRECISION (mode);
 792
 793   gcc_unreachable ();
 794 }
 795
 796 static GTY(()) tree gnat_eh_personality_decl;
 797
 798 /* Return the GNAT personality function decl.  */
 799
 800 static tree
 801 gnat_eh_personality (void)
 802 {
 803   if (!gnat_eh_personality_decl)
 804     gnat_eh_personality_decl = build_personality_function ("gnat");
 805   return gnat_eh_personality_decl;
 806 }
 807
 808 /* Initialize language-specific bits of tree_contains_struct.  */
 809
 810 static void
 811 gnat_init_ts (void)
 812 {
 813   MARK_TS_COMMON (UNCONSTRAINED_ARRAY_TYPE);
 814
 815   MARK_TS_TYPED (UNCONSTRAINED_ARRAY_REF);
 816   MARK_TS_TYPED (NULL_EXPR);
 817   MARK_TS_TYPED (PLUS_NOMOD_EXPR);
 818   MARK_TS_TYPED (MINUS_NOMOD_EXPR);
 819   MARK_TS_TYPED (ATTR_ADDR_EXPR);
 820   MARK_TS_TYPED (STMT_STMT);
 821   MARK_TS_TYPED (LOOP_STMT);
 822   MARK_TS_TYPED (EXIT_STMT);
 823 }
 824
 825 /* Definitions for our language-specific hooks.  */
 826
 827 #undef  LANG_HOOKS_NAME
 828 #define LANG_HOOKS_NAME                 "GNU Ada"
 829 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 830 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 831 #undef  LANG_HOOKS_INIT
 832 #define LANG_HOOKS_INIT                 gnat_init
 833 #undef  LANG_HOOKS_OPTION_LANG_MASK
 834 #define LANG_HOOKS_OPTION_LANG_MASK     gnat_option_lang_mask
 835 #undef  LANG_HOOKS_INIT_OPTIONS_STRUCT
 836 #define LANG_HOOKS_INIT_OPTIONS_STRUCT  gnat_init_options_struct
 837 #undef  LANG_HOOKS_INIT_OPTIONS
 838 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 839 #undef  LANG_HOOKS_HANDLE_OPTION
 840 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
 841 #undef  LANG_HOOKS_POST_OPTIONS
 842 #define LANG_HOOKS_POST_OPTIONS         gnat_post_options
 843 #undef  LANG_HOOKS_PARSE_FILE
 844 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 845 #undef  LANG_HOOKS_TYPE_HASH_EQ
 846 #define LANG_HOOKS_TYPE_HASH_EQ         gnat_type_hash_eq
 847 #undef  LANG_HOOKS_GETDECLS
 848 #define LANG_HOOKS_GETDECLS             lhd_return_null_tree_v
 849 #undef  LANG_HOOKS_PUSHDECL
 850 #define LANG_HOOKS_PUSHDECL             gnat_return_tree
 851 #undef  LANG_HOOKS_WRITE_GLOBALS
 852 #define LANG_HOOKS_WRITE_GLOBALS        gnat_write_global_declarations
 853 #undef  LANG_HOOKS_GET_ALIAS_SET
 854 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 855 #undef  LANG_HOOKS_PRINT_DECL
 856 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 857 #undef  LANG_HOOKS_PRINT_TYPE
 858 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 859 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 860 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 861 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 862 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 863 #undef  LANG_HOOKS_DWARF_NAME
 864 #define LANG_HOOKS_DWARF_NAME           gnat_dwarf_name
 865 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 866 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 867 #undef  LANG_HOOKS_TYPE_FOR_MODE
 868 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 869 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 870 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 871 #undef  LANG_HOOKS_TYPES_COMPATIBLE_P
 872 #define LANG_HOOKS_TYPES_COMPATIBLE_P   gnat_types_compatible_p
 873 #undef  LANG_HOOKS_GET_SUBRANGE_BOUNDS
 874 #define LANG_HOOKS_GET_SUBRANGE_BOUNDS  gnat_get_subrange_bounds
 875 #undef  LANG_HOOKS_DESCRIPTIVE_TYPE
 876 #define LANG_HOOKS_DESCRIPTIVE_TYPE     gnat_descriptive_type
 877 #undef  LANG_HOOKS_ATTRIBUTE_TABLE
 878 #define LANG_HOOKS_ATTRIBUTE_TABLE      gnat_internal_attribute_table
 879 #undef  LANG_HOOKS_BUILTIN_FUNCTION
 880 #define LANG_HOOKS_BUILTIN_FUNCTION     gnat_builtin_function
 881 #undef  LANG_HOOKS_EH_PERSONALITY
 882 #define LANG_HOOKS_EH_PERSONALITY       gnat_eh_personality
 883 #undef  LANG_HOOKS_DEEP_UNSHARING
 884 #define LANG_HOOKS_DEEP_UNSHARING       true
 885 #undef  LANG_HOOKS_INIT_TS
 886 #define LANG_HOOKS_INIT_TS              gnat_init_ts
 887
 888 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 889
 890 #include "gt-ada-misc.h"