gcc/ada/misc.c

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