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