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