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