gcc/ada/gcc-interface/misc.c

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