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-2009, 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 /* This file contains parts of the compiler that are required for interfacing
  27    with GCC but otherwise do nothing and parts of Gigi that need to know
  28    about RTL.  */
  29
  30 #include "config.h"
  31 #include "system.h"
  32 #include "coretypes.h"
  33 #include "tm.h"
  34 #include "tree.h"
  35 #include "diagnostic.h"
  36 #include "target.h"
  37 #include "expr.h"
  38 #include "libfuncs.h"
  39 #include "ggc.h"
  40 #include "flags.h"
  41 #include "debug.h"
  42 #include "cgraph.h"
  43 #include "optabs.h"
  44 #include "toplev.h"
  45 #include "except.h"
  46 #include "langhooks.h"
  47 #include "langhooks-def.h"
  48 #include "opts.h"
  49 #include "options.h"
  50 #include "tree-inline.h"
  51
  52 #include "ada.h"
  53 #include "adadecode.h"
  54 #include "types.h"
  55 #include "atree.h"
  56 #include "elists.h"
  57 #include "namet.h"
  58 #include "nlists.h"
  59 #include "stringt.h"
  60 #include "uintp.h"
  61 #include "fe.h"
  62 #include "sinfo.h"
  63 #include "einfo.h"
  64 #include "ada-tree.h"
  65 #include "gigi.h"
  66
  67 static bool gnat_init                   (void);
  68 static unsigned int gnat_init_options   (unsigned int, const char **);
  69 static int gnat_handle_option           (size_t, const char *, int);
  70 static bool gnat_post_options           (const char **);
  71 static alias_set_type gnat_get_alias_set (tree);
  72 static void gnat_print_decl             (FILE *, tree, int);
  73 static void gnat_print_type             (FILE *, tree, int);
  74 static const char *gnat_printable_name  (tree, int);
  75 static const char *gnat_dwarf_name      (tree, int);
  76 static tree gnat_return_tree            (tree);
  77 static int gnat_eh_type_covers          (tree, tree);
  78 static void gnat_parse_file             (int);
  79 static void internal_error_function     (const char *, va_list *);
  80 static tree gnat_type_max_size          (const_tree);
  81 static void gnat_get_subrange_bounds    (const_tree, tree *, tree *);
  82
  83 /* Definitions for our language-specific hooks.  */
  84
  85 #undef  LANG_HOOKS_NAME
  86 #define LANG_HOOKS_NAME                 "GNU Ada"
  87 #undef  LANG_HOOKS_IDENTIFIER_SIZE
  88 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
  89 #undef  LANG_HOOKS_INIT
  90 #define LANG_HOOKS_INIT                 gnat_init
  91 #undef  LANG_HOOKS_INIT_OPTIONS
  92 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
  93 #undef  LANG_HOOKS_HANDLE_OPTION
  94 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
  95 #undef  LANG_HOOKS_POST_OPTIONS
  96 #define LANG_HOOKS_POST_OPTIONS         gnat_post_options
  97 #undef  LANG_HOOKS_PARSE_FILE
  98 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
  99 #undef  LANG_HOOKS_HASH_TYPES
 100 #define LANG_HOOKS_HASH_TYPES           false
 101 #undef  LANG_HOOKS_GETDECLS
 102 #define LANG_HOOKS_GETDECLS             lhd_return_null_tree_v
 103 #undef  LANG_HOOKS_PUSHDECL
 104 #define LANG_HOOKS_PUSHDECL             gnat_return_tree
 105 #undef  LANG_HOOKS_WRITE_GLOBALS
 106 #define LANG_HOOKS_WRITE_GLOBALS        gnat_write_global_declarations
 107 #undef  LANG_HOOKS_GET_ALIAS_SET
 108 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 109 #undef  LANG_HOOKS_MARK_ADDRESSABLE
 110 #define LANG_HOOKS_MARK_ADDRESSABLE     gnat_mark_addressable
 111 #undef  LANG_HOOKS_PRINT_DECL
 112 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 113 #undef  LANG_HOOKS_PRINT_TYPE
 114 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 115 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 116 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 117 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 118 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 119 #undef  LANG_HOOKS_DWARF_NAME
 120 #define LANG_HOOKS_DWARF_NAME           gnat_dwarf_name
 121 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 122 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 123 #undef  LANG_HOOKS_TYPE_FOR_MODE
 124 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 125 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 126 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 127 #undef  LANG_HOOKS_TYPES_COMPATIBLE_P
 128 #define LANG_HOOKS_TYPES_COMPATIBLE_P   gnat_types_compatible_p
 129 #undef  LANG_HOOKS_GET_SUBRANGE_BOUNDS
 130 #define LANG_HOOKS_GET_SUBRANGE_BOUNDS  gnat_get_subrange_bounds
 131 #undef  LANG_HOOKS_ATTRIBUTE_TABLE
 132 #define LANG_HOOKS_ATTRIBUTE_TABLE      gnat_internal_attribute_table
 133 #undef  LANG_HOOKS_BUILTIN_FUNCTION
 134 #define LANG_HOOKS_BUILTIN_FUNCTION        gnat_builtin_function
 135
 136 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 137
 138 /* How much we want of our DWARF extensions.  Some of our dwarf+ extensions
 139    are incompatible with regular GDB versions, so we must make sure to only
 140    produce them on explicit request.  This is eventually reflected into the
 141    use_gnu_debug_info_extensions common flag for later processing.  */
 142 static int gnat_dwarf_extensions = 0;
 143
 144 /* Command-line argc and argv.  These variables are global
 145    since they are imported in back_end.adb.  */
 146 unsigned int save_argc;
 147 const char **save_argv;
 148
 149 /* GNAT argc and argv.  */
 150 extern int gnat_argc;
 151 extern char **gnat_argv;
 152
 153 /* Declare functions we use as part of startup.  */
 154 extern void __gnat_initialize           (void *);
 155 extern void __gnat_install_SEH_handler  (void *);
 156 extern void adainit                     (void);
 157 extern void _ada_gnat1drv               (void);
 158
 159 /* The parser for the language.  For us, we process the GNAT tree.  */
 160
 161 static void
 162 gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 163 {
 164   int seh[2];
 165
 166   /* Call the target specific initializations.  */
 167   __gnat_initialize (NULL);
 168
 169   /* ??? Call the SEH initialization routine.  This is to workaround
 170   a bootstrap path problem.  The call below should be removed at some
 171   point and the SEH pointer passed to __gnat_initialize() above.  */
 172   __gnat_install_SEH_handler((void *)seh);
 173
 174   /* Call the front-end elaboration procedures.  */
 175   adainit ();
 176
 177   /* Call the front end.  */
 178   _ada_gnat1drv ();
 179
 180   /* We always have a single compilation unit in Ada.  */
 181   cgraph_finalize_compilation_unit ();
 182 }
 183
 184 /* Decode all the language specific options that cannot be decoded by GCC.
 185    The option decoding phase of GCC calls this routine on the flags that
 186    it cannot decode.  Return the number of consecutive arguments from ARGV
 187    that have been successfully decoded or 0 on failure.  */
 188
 189 static int
 190 gnat_handle_option (size_t scode, const char *arg, int value)
 191 {
 192   const struct cl_option *option = &cl_options[scode];
 193   enum opt_code code = (enum opt_code) scode;
 194   char *q;
 195
 196   if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
 197     {
 198       error ("missing argument to \"-%s\"", option->opt_text);
 199       return 1;
 200     }
 201
 202   switch (code)
 203     {
 204     case OPT_I:
 205       q = XNEWVEC (char, sizeof("-I") + strlen (arg));
 206       strcpy (q, "-I");
 207       strcat (q, arg);
 208       gnat_argv[gnat_argc] = q;
 209       gnat_argc++;
 210       break;
 211
 212     case OPT_Wall:
 213       warn_unused = value;
 214
 215       /* We save the value of warn_uninitialized, since if they put
 216          -Wuninitialized on the command line, we need to generate a
 217          warning about not using it without also specifying -O.  */
 218       if (warn_uninitialized != 1)
 219         warn_uninitialized = (value ? 2 : 0);
 220       break;
 221
 222       /* These are used in the GCC Makefile.  */
 223     case OPT_Wmissing_prototypes:
 224     case OPT_Wstrict_prototypes:
 225     case OPT_Wwrite_strings:
 226     case OPT_Wlong_long:
 227     case OPT_Wvariadic_macros:
 228     case OPT_Wold_style_definition:
 229     case OPT_Wmissing_format_attribute:
 230     case OPT_Woverlength_strings:
 231       break;
 232
 233       /* This is handled by the front-end.  */
 234     case OPT_nostdinc:
 235       break;
 236
 237     case OPT_nostdlib:
 238       gnat_argv[gnat_argc] = xstrdup ("-nostdlib");
 239       gnat_argc++;
 240       break;
 241
 242     case OPT_feliminate_unused_debug_types:
 243       /* We arrange for post_option to be able to only set the corresponding
 244          flag to 1 when explicitly requested by the user.  We expect the
 245          default flag value to be either 0 or positive, and expose a positive
 246          -f as a negative value to post_option.  */
 247       flag_eliminate_unused_debug_types = -value;
 248       break;
 249
 250     case OPT_fRTS_:
 251       gnat_argv[gnat_argc] = xstrdup ("-fRTS");
 252       gnat_argc++;
 253       break;
 254
 255     case OPT_gant:
 256       warning (0, "%<-gnat%> misspelled as %<-gant%>");
 257
 258       /* ... fall through ... */
 259
 260     case OPT_gnat:
 261       /* Recopy the switches without the 'gnat' prefix.  */
 262       gnat_argv[gnat_argc] = XNEWVEC (char, strlen (arg) + 2);
 263       gnat_argv[gnat_argc][0] = '-';
 264       strcpy (gnat_argv[gnat_argc] + 1, arg);
 265       gnat_argc++;
 266       break;
 267
 268     case OPT_gnatO:
 269       gnat_argv[gnat_argc] = xstrdup ("-O");
 270       gnat_argc++;
 271       gnat_argv[gnat_argc] = xstrdup (arg);
 272       gnat_argc++;
 273       break;
 274
 275     case OPT_gdwarfplus:
 276       gnat_dwarf_extensions = 1;
 277       break;
 278
 279     default:
 280       gcc_unreachable ();
 281     }
 282
 283   return 1;
 284 }
 285
 286 /* Initialize for option processing.  */
 287
 288 static unsigned int
 289 gnat_init_options (unsigned int argc, const char **argv)
 290 {
 291   /* Initialize gnat_argv with save_argv size.  */
 292   gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
 293   gnat_argv[0] = xstrdup (argv[0]);     /* name of the command */
 294   gnat_argc = 1;
 295
 296   save_argc = argc;
 297   save_argv = argv;
 298
 299   /* Uninitialized really means uninitialized in Ada.  */
 300   flag_zero_initialized_in_bss = 0;
 301
 302   return CL_Ada;
 303 }
 304
 305 /* Post-switch processing.  */
 306
 307 bool
 308 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
 309 {
 310   /* Excess precision other than "fast" requires front-end
 311      support.  */
 312   if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD
 313       && TARGET_FLT_EVAL_METHOD_NON_DEFAULT)
 314     sorry ("-fexcess-precision=standard for Ada");
 315   flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
 316
 317   /* ??? The warning machinery is outsmarted by Ada.  */
 318   warn_unused_parameter = 0;
 319
 320   /* No psABI change warnings for Ada.  */
 321   warn_psabi = 0;
 322
 323   /* Force eliminate_unused_debug_types to 0 unless an explicit positive
 324      -f has been passed.  This forces the default to 0 for Ada, which might
 325      differ from the common default.  */
 326   if (flag_eliminate_unused_debug_types < 0)
 327     flag_eliminate_unused_debug_types = 1;
 328   else
 329     flag_eliminate_unused_debug_types = 0;
 330
 331   /* Reflect the explicit request of DWARF extensions into the common
 332      flag for use by later passes.  */
 333   if (write_symbols == DWARF2_DEBUG)
 334     use_gnu_debug_info_extensions = gnat_dwarf_extensions > 0;
 335
 336   return false;
 337 }
 338
 339 /* Here is the function to handle the compiler error processing in GCC.  */
 340
 341 static void
 342 internal_error_function (const char *msgid, va_list *ap)
 343 {
 344   text_info tinfo;
 345   char *buffer, *p, *loc;
 346   String_Template temp, temp_loc;
 347   Fat_Pointer fp, fp_loc;
 348   expanded_location s;
 349
 350   /* Reset the pretty-printer.  */
 351   pp_clear_output_area (global_dc->printer);
 352
 353   /* Format the message into the pretty-printer.  */
 354   tinfo.format_spec = msgid;
 355   tinfo.args_ptr = ap;
 356   tinfo.err_no = errno;
 357   pp_format_verbatim (global_dc->printer, &tinfo);
 358
 359   /* Extract a (writable) pointer to the formatted text.  */
 360   buffer = xstrdup (pp_formatted_text (global_dc->printer));
 361
 362   /* Go up to the first newline.  */
 363   for (p = buffer; *p; p++)
 364     if (*p == '\n')
 365       {
 366         *p = '\0';
 367         break;
 368       }
 369
 370   temp.Low_Bound = 1;
 371   temp.High_Bound = p - buffer;
 372   fp.Bounds = &temp;
 373   fp.Array = buffer;
 374
 375   s = expand_location (input_location);
 376   if (flag_show_column && s.column != 0)
 377     asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column);
 378   else
 379     asprintf (&loc, "%s:%d", s.file, s.line);
 380   temp_loc.Low_Bound = 1;
 381   temp_loc.High_Bound = strlen (loc);
 382   fp_loc.Bounds = &temp_loc;
 383   fp_loc.Array = loc;
 384
 385   Current_Error_Node = error_gnat_node;
 386   Compiler_Abort (fp, -1, fp_loc);
 387 }
 388
 389 /* Perform all the initialization steps that are language-specific.  */
 390
 391 static bool
 392 gnat_init (void)
 393 {
 394   /* Performs whatever initialization steps needed by the language-dependent
 395      lexical analyzer.  */
 396   gnat_init_decl_processing ();
 397
 398   /* Add the input filename as the last argument.  */
 399   if (main_input_filename)
 400     {
 401       gnat_argv[gnat_argc] = xstrdup (main_input_filename);
 402       gnat_argc++;
 403       gnat_argv[gnat_argc] = NULL;
 404     }
 405
 406   global_dc->internal_error = &internal_error_function;
 407
 408   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 409   internal_reference_types ();
 410
 411   return true;
 412 }
 413
 414 /* If we are using the GCC mechanism to process exception handling, we
 415    have to register the personality routine for Ada and to initialize
 416    various language dependent hooks.  */
 417
 418 void
 419 gnat_init_gcc_eh (void)
 420 {
 421 #ifdef DWARF2_UNWIND_INFO
 422   /* lang_dependent_init already called dwarf2out_frame_init if true.  */
 423   int dwarf2out_frame_initialized = dwarf2out_do_frame ();
 424 #endif
 425
 426   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 427      though. This could for instance lead to the emission of tables with
 428      references to symbols (such as the Ada eh personality routine) within
 429      libraries we won't link against.  */
 430   if (No_Exception_Handlers_Set ())
 431     return;
 432
 433   /* Tell GCC we are handling cleanup actions through exception propagation.
 434      This opens possibilities that we don't take advantage of yet, but is
 435      nonetheless necessary to ensure that fixup code gets assigned to the
 436      right exception regions.  */
 437   using_eh_for_cleanups ();
 438
 439   eh_personality_libfunc = init_one_libfunc (USING_SJLJ_EXCEPTIONS
 440                                              ? "__gnat_eh_personality_sj"
 441                                              : "__gnat_eh_personality");
 442   lang_eh_type_covers = gnat_eh_type_covers;
 443   lang_eh_runtime_type = gnat_return_tree;
 444   default_init_unwind_resume_libfunc ();
 445
 446   /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
 447      the generation of the necessary exception runtime tables. The second one
 448      is useful for two reasons: 1/ we map some asynchronous signals like SEGV
 449      to exceptions, so we need to ensure that the insns which can lead to such
 450      signals are correctly attached to the exception region they pertain to,
 451      2/ Some calls to pure subprograms are handled as libcall blocks and then
 452      marked as "cannot trap" if the flag is not set (see emit_libcall_block).
 453      We should not let this be since it is possible for such calls to actually
 454      raise in Ada.  */
 455   flag_exceptions = 1;
 456   flag_non_call_exceptions = 1;
 457
 458   init_eh ();
 459 #ifdef DWARF2_UNWIND_INFO
 460   if (!dwarf2out_frame_initialized && dwarf2out_do_frame ())
 461     dwarf2out_frame_init ();
 462 #endif
 463 }
 464
 465 /* Print language-specific items in declaration NODE.  */
 466
 467 static void
 468 gnat_print_decl (FILE *file, tree node, int indent)
 469 {
 470   switch (TREE_CODE (node))
 471     {
 472     case CONST_DECL:
 473       print_node (file, "corresponding var",
 474                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 475       break;
 476
 477     case FIELD_DECL:
 478       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 479                   indent + 4);
 480       break;
 481
 482     case VAR_DECL:
 483       print_node (file, "renamed object", DECL_RENAMED_OBJECT (node),
 484                   indent + 4);
 485       break;
 486
 487     default:
 488       break;
 489     }
 490 }
 491
 492 /* Print language-specific items in type NODE.  */
 493
 494 static void
 495 gnat_print_type (FILE *file, tree node, int indent)
 496 {
 497   switch (TREE_CODE (node))
 498     {
 499     case FUNCTION_TYPE:
 500       print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4);
 501       break;
 502
 503     case INTEGER_TYPE:
 504       if (TYPE_MODULAR_P (node))
 505         print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
 506       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 507         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 508                     indent + 4);
 509       else if (TYPE_VAX_FLOATING_POINT_P (node))
 510         ;
 511       else
 512         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 513
 514       /* ... fall through ... */
 515
 516     case ENUMERAL_TYPE:
 517     case BOOLEAN_TYPE:
 518       print_node_brief (file, "RM size", TYPE_RM_SIZE (node), indent + 4);
 519
 520       /* ... fall through ... */
 521
 522     case REAL_TYPE:
 523       print_node_brief (file, "RM min", TYPE_RM_MIN_VALUE (node), indent + 4);
 524       print_node_brief (file, "RM max", TYPE_RM_MAX_VALUE (node), indent + 4);
 525       break;
 526
 527     case ARRAY_TYPE:
 528       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 529       break;
 530
 531     case RECORD_TYPE:
 532       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 533         print_node (file, "unconstrained array",
 534                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 535       else
 536         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 537       break;
 538
 539     case UNION_TYPE:
 540     case QUAL_UNION_TYPE:
 541       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 542       break;
 543
 544     default:
 545       break;
 546     }
 547 }
 548
 549 /* Return the name to be printed for DECL.  */
 550
 551 static const char *
 552 gnat_printable_name (tree decl, int verbosity)
 553 {
 554   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 555   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 556
 557   __gnat_decode (coded_name, ada_name, 0);
 558
 559   if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
 560     {
 561       Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl));
 562       return ggc_strdup (Name_Buffer);
 563     }
 564
 565   return ada_name;
 566 }
 567
 568 /* Return the name to be used in DWARF debug info for DECL.  */
 569
 570 static const char *
 571 gnat_dwarf_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
 572 {
 573   gcc_assert (DECL_P (decl));
 574   return (const char *) IDENTIFIER_POINTER (DECL_NAME (decl));
 575 }
 576
 577 /* Do nothing (return the tree node passed).  */
 578
 579 static tree
 580 gnat_return_tree (tree t)
 581 {
 582   return t;
 583 }
 584
 585 /* Return true if type A catches type B. Callback for flow analysis from
 586    the exception handling part of the back-end.  */
 587
 588 static int
 589 gnat_eh_type_covers (tree a, tree b)
 590 {
 591   /* a catches b if they represent the same exception id or if a
 592      is an "others".
 593
 594      ??? integer_zero_node for "others" is hardwired in too many places
 595      currently.  */
 596   return (a == b || a == integer_zero_node);
 597 }
 598 \f
 599 /* Get the alias set corresponding to a type or expression.  */
 600
 601 static alias_set_type
 602 gnat_get_alias_set (tree type)
 603 {
 604   /* If this is a padding type, use the type of the first field.  */
 605   if (TREE_CODE (type) == RECORD_TYPE
 606       && TYPE_IS_PADDING_P (type))
 607     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 608
 609   /* If the type is an unconstrained array, use the type of the
 610      self-referential array we make.  */
 611   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 612     return
 613       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 614
 615   /* If the type can alias any other types, return the alias set 0.  */
 616   else if (TYPE_P (type)
 617            && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
 618     return 0;
 619
 620   return -1;
 621 }
 622
 623 /* GNU_TYPE is a type.  Return its maximum size in bytes, if known,
 624    as a constant when possible.  */
 625
 626 static tree
 627 gnat_type_max_size (const_tree gnu_type)
 628 {
 629   /* First see what we can get from TYPE_SIZE_UNIT, which might not
 630      be constant even for simple expressions if it has already been
 631      elaborated and possibly replaced by a VAR_DECL.  */
 632   tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
 633
 634   /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
 635      which should stay untouched.  */
 636   if (!host_integerp (max_unitsize, 1)
 637       && (TREE_CODE (gnu_type) == RECORD_TYPE
 638           || TREE_CODE (gnu_type) == UNION_TYPE
 639           || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
 640       && TYPE_ADA_SIZE (gnu_type))
 641     {
 642       tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
 643
 644       /* If we have succeeded in finding a constant, round it up to the
 645          type's alignment and return the result in units.  */
 646       if (host_integerp (max_adasize, 1))
 647         max_unitsize
 648           = size_binop (CEIL_DIV_EXPR,
 649                         round_up (max_adasize, TYPE_ALIGN (gnu_type)),
 650                         bitsize_unit_node);
 651     }
 652
 653   return max_unitsize;
 654 }
 655
 656 /* GNU_TYPE is a subtype of an integral type.  Set LOWVAL to the low bound
 657    and HIGHVAL to the high bound, respectively.  */
 658
 659 static void
 660 gnat_get_subrange_bounds (const_tree gnu_type, tree *lowval, tree *highval)
 661 {
 662   tree min = TYPE_MIN_VALUE (gnu_type);
 663   tree max = TYPE_MAX_VALUE (gnu_type);
 664   /* If the bounds aren't constant, use non-representable constant values
 665      to get the same effect on debug info without tree sharing issues.  */
 666   *lowval
 667     = TREE_CONSTANT (min) ? min : build_int_cstu (integer_type_node, -1);
 668   *highval
 669     = TREE_CONSTANT (max) ? max : build_int_cstu (integer_type_node, -1);
 670 }
 671
 672 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 673    default.  */
 674
 675 bool
 676 default_pass_by_ref (tree gnu_type)
 677 {
 678   /* We pass aggregates by reference if they are sufficiently large.  The
 679      choice of constant here is somewhat arbitrary.  We also pass by
 680      reference if the target machine would either pass or return by
 681      reference.  Strictly speaking, we need only check the return if this
 682      is an In Out parameter, but it's probably best to err on the side of
 683      passing more things by reference.  */
 684
 685   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1))
 686     return true;
 687
 688   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 689     return true;
 690
 691   if (AGGREGATE_TYPE_P (gnu_type)
 692       && (!host_integerp (TYPE_SIZE (gnu_type), 1)
 693           || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 694                                    8 * TYPE_ALIGN (gnu_type))))
 695     return true;
 696
 697   return false;
 698 }
 699
 700 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 701    it should be passed by reference. */
 702
 703 bool
 704 must_pass_by_ref (tree gnu_type)
 705 {
 706   /* We pass only unconstrained objects, those required by the language
 707      to be passed by reference, and objects of variable size.  The latter
 708      is more efficient, avoids problems with variable size temporaries,
 709      and does not produce compatibility problems with C, since C does
 710      not have such objects.  */
 711   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 712           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 713           || (TYPE_SIZE (gnu_type)
 714               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 715 }
 716
 717 /* This function is called by the front end to enumerate all the supported
 718    modes for the machine.  We pass a function which is called back with
 719    the following integer parameters:
 720
 721    FLOAT_P      nonzero if this represents a floating-point mode
 722    COMPLEX_P    nonzero is this represents a complex mode
 723    COUNT        count of number of items, nonzero for vector mode
 724    PRECISION    number of bits in data representation
 725    MANTISSA     number of bits in mantissa, if FP and known, else zero.
 726    SIZE         number of bits used to store data
 727    ALIGN        number of bits to which mode is aligned.  */
 728
 729 void
 730 enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
 731 {
 732   int iloop;
 733
 734   for (iloop = 0; iloop < NUM_MACHINE_MODES; iloop++)
 735     {
 736       enum machine_mode i = (enum machine_mode) iloop;
 737       enum machine_mode j;
 738       bool float_p = 0;
 739       bool complex_p = 0;
 740       bool vector_p = 0;
 741       bool skip_p = 0;
 742       int mantissa = 0;
 743       enum machine_mode inner_mode = i;
 744
 745       switch (GET_MODE_CLASS (i))
 746         {
 747         case MODE_INT:
 748           break;
 749         case MODE_FLOAT:
 750           float_p = 1;
 751           break;
 752         case MODE_COMPLEX_INT:
 753           complex_p = 1;
 754           inner_mode = GET_MODE_INNER (i);
 755           break;
 756         case MODE_COMPLEX_FLOAT:
 757           float_p = 1;
 758           complex_p = 1;
 759           inner_mode = GET_MODE_INNER (i);
 760           break;
 761         case MODE_VECTOR_INT:
 762           vector_p = 1;
 763           inner_mode = GET_MODE_INNER (i);
 764           break;
 765         case MODE_VECTOR_FLOAT:
 766           float_p = 1;
 767           vector_p = 1;
 768           inner_mode = GET_MODE_INNER (i);
 769           break;
 770         default:
 771           skip_p = 1;
 772         }
 773
 774       /* Skip this mode if it's one the front end doesn't need to know about
 775          (e.g., the CC modes) or if there is no add insn for that mode (or
 776          any wider mode), meaning it is not supported by the hardware.  If
 777          this a complex or vector mode, we care about the inner mode.  */
 778       for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
 779         if (optab_handler (add_optab, j)->insn_code != CODE_FOR_nothing)
 780           break;
 781
 782       if (float_p)
 783         {
 784           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 785
 786           mantissa = fmt->p;
 787         }
 788
 789       if (!skip_p && j != VOIDmode)
 790         (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
 791               GET_MODE_BITSIZE (i), mantissa,
 792               GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
 793     }
 794 }
 795
 796 /* Return the size of the FP mode with precision PREC.  */
 797
 798 int
 799 fp_prec_to_size (int prec)
 800 {
 801   enum machine_mode mode;
 802
 803   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 804        mode = GET_MODE_WIDER_MODE (mode))
 805     if (GET_MODE_PRECISION (mode) == prec)
 806       return GET_MODE_BITSIZE (mode);
 807
 808   gcc_unreachable ();
 809 }
 810
 811 /* Return the precision of the FP mode with size SIZE.  */
 812
 813 int
 814 fp_size_to_prec (int size)
 815 {
 816   enum machine_mode mode;
 817
 818   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 819        mode = GET_MODE_WIDER_MODE (mode))
 820     if (GET_MODE_BITSIZE (mode) == size)
 821       return GET_MODE_PRECISION (mode);
 822
 823   gcc_unreachable ();
 824 }