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