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-2007, 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_eh_runtime_type        (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 gnat_expand_body            (tree);
 104 static void internal_error_function     (const char *, va_list *);
 105 static void gnat_adjust_rli             (record_layout_info);
 106 static tree gnat_type_max_size          (tree);
 107
 108 /* Definitions for our language-specific hooks.  */
 109
 110 #undef  LANG_HOOKS_NAME
 111 #define LANG_HOOKS_NAME                 "GNU Ada"
 112 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 113 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 114 #undef  LANG_HOOKS_INIT
 115 #define LANG_HOOKS_INIT                 gnat_init
 116 #undef  LANG_HOOKS_INIT_OPTIONS
 117 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 118 #undef  LANG_HOOKS_HANDLE_OPTION
 119 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
 120 #undef  LANG_HOOKS_POST_OPTIONS
 121 #define LANG_HOOKS_POST_OPTIONS         gnat_post_options
 122 #undef  LANG_HOOKS_PARSE_FILE
 123 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 124 #undef  LANG_HOOKS_HASH_TYPES
 125 #define LANG_HOOKS_HASH_TYPES           false
 126 #undef  LANG_HOOKS_GETDECLS
 127 #define LANG_HOOKS_GETDECLS             lhd_return_null_tree_v
 128 #undef  LANG_HOOKS_PUSHDECL
 129 #define LANG_HOOKS_PUSHDECL             lhd_return_tree
 130 #undef  LANG_HOOKS_WRITE_GLOBALS
 131 #define LANG_HOOKS_WRITE_GLOBALS      gnat_write_global_declarations
 132 #undef  LANG_HOOKS_FINISH_INCOMPLETE_DECL
 133 #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
 134 #undef  LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS
 135 #define LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS true
 136 #undef  LANG_HOOKS_GET_ALIAS_SET
 137 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 138 #undef  LANG_HOOKS_EXPAND_EXPR
 139 #define LANG_HOOKS_EXPAND_EXPR          gnat_expand_expr
 140 #undef  LANG_HOOKS_MARK_ADDRESSABLE
 141 #define LANG_HOOKS_MARK_ADDRESSABLE     gnat_mark_addressable
 142 #undef  LANG_HOOKS_PRINT_DECL
 143 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 144 #undef  LANG_HOOKS_PRINT_TYPE
 145 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 146 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 147 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 148 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 149 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 150 #undef  LANG_HOOKS_DWARF_NAME
 151 #define LANG_HOOKS_DWARF_NAME           gnat_dwarf_name
 152 #undef  LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
 153 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gnat_expand_body
 154 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 155 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 156 #undef  LANG_HOOKS_TYPE_FOR_MODE
 157 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 158 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 159 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 160 #undef  LANG_HOOKS_ATTRIBUTE_TABLE
 161 #define LANG_HOOKS_ATTRIBUTE_TABLE      gnat_internal_attribute_table
 162 #undef  LANG_HOOKS_BUILTIN_FUNCTION
 163 #define LANG_HOOKS_BUILTIN_FUNCTION        gnat_builtin_function
 164
 165 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 166
 167 /* Tables describing GCC tree codes used only by GNAT.
 168
 169    Table indexed by tree code giving a string containing a character
 170    classifying the tree code.  Possibilities are
 171    t, d, s, c, r, <, 1 and 2.  See cp-tree.def for details.  */
 172
 173 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 174
 175 const enum tree_code_class tree_code_type[] = {
 176 #include "tree.def"
 177   tcc_exceptional,
 178 #include "ada-tree.def"
 179 };
 180 #undef DEFTREECODE
 181
 182 /* Table indexed by tree code giving number of expression
 183    operands beyond the fixed part of the node structure.
 184    Not used for types or decls.  */
 185
 186 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 187
 188 const unsigned char tree_code_length[] = {
 189 #include "tree.def"
 190   0,
 191 #include "ada-tree.def"
 192 };
 193 #undef DEFTREECODE
 194
 195 /* Names of tree components.
 196    Used for printing out the tree and error messages.  */
 197 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 198
 199 const char *const tree_code_name[] = {
 200 #include "tree.def"
 201   "@@dummy",
 202 #include "ada-tree.def"
 203 };
 204 #undef DEFTREECODE
 205
 206 /* Command-line argc and argv.
 207    These variables are global, since they are imported and used in
 208    back_end.adb  */
 209
 210 unsigned int save_argc;
 211 const char **save_argv;
 212
 213 /* gnat standard argc argv */
 214
 215 extern int gnat_argc;
 216 extern char **gnat_argv;
 217
 218 \f
 219 /* Declare functions we use as part of startup.  */
 220 extern void __gnat_initialize           (void *);
 221 extern void __gnat_install_SEH_handler  (void *);
 222 extern void adainit                     (void);
 223 extern void _ada_gnat1drv               (void);
 224
 225 /* The parser for the language.  For us, we process the GNAT tree.  */
 226
 227 static void
 228 gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 229 {
 230   int seh[2];
 231
 232   /* Call the target specific initializations.  */
 233   __gnat_initialize (NULL);
 234
 235   /* ??? Call the SEH initialization routine.  This is to workaround
 236   a bootstrap path problem.  The call below should be removed at some
 237   point and the SEH pointer passed to __gnat_initialize() above.  */
 238   __gnat_install_SEH_handler((void *)seh);
 239
 240   /* Call the front-end elaboration procedures.  */
 241   adainit ();
 242
 243   /* Call the front end.  */
 244   _ada_gnat1drv ();
 245
 246   /* We always have a single compilation unit in Ada.  */
 247   cgraph_finalize_compilation_unit ();
 248 }
 249
 250 /* Decode all the language specific options that cannot be decoded by GCC.
 251    The option decoding phase of GCC calls this routine on the flags that
 252    it cannot decode.  This routine returns the number of consecutive arguments
 253    from ARGV that it successfully decoded; 0 indicates failure.  */
 254
 255 static int
 256 gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
 257 {
 258   const struct cl_option *option = &cl_options[scode];
 259   enum opt_code code = (enum opt_code) scode;
 260   char *q;
 261
 262   if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
 263     {
 264       error ("missing argument to \"-%s\"", option->opt_text);
 265       return 1;
 266     }
 267
 268   switch (code)
 269     {
 270     default:
 271       abort ();
 272
 273     case OPT_I:
 274       q = xmalloc (sizeof("-I") + strlen (arg));
 275       strcpy (q, "-I");
 276       strcat (q, arg);
 277       gnat_argv[gnat_argc] = q;
 278       gnat_argc++;
 279       break;
 280
 281       /* All front ends are expected to accept this.  */
 282     case OPT_Wall:
 283       /* These are used in the GCC Makefile.  */
 284     case OPT_Wmissing_prototypes:
 285     case OPT_Wstrict_prototypes:
 286     case OPT_Wwrite_strings:
 287     case OPT_Wlong_long:
 288     case OPT_Wvariadic_macros:
 289     case OPT_Wold_style_definition:
 290     case OPT_Wmissing_format_attribute:
 291     case OPT_Woverlength_strings:
 292       break;
 293
 294       /* This is handled by the front-end.  */
 295     case OPT_nostdinc:
 296       break;
 297
 298     case OPT_nostdlib:
 299       gnat_argv[gnat_argc] = xstrdup ("-nostdlib");
 300       gnat_argc++;
 301       break;
 302
 303     case OPT_feliminate_unused_debug_types:
 304       /* We arrange for post_option to be able to only set the corresponding
 305          flag to 1 when explicitely requested by the user.  We expect the
 306          default flag value to be either 0 or positive, and expose a positive
 307          -f as a negative value to post_option.  */
 308       flag_eliminate_unused_debug_types = -value;
 309       break;
 310
 311     case OPT_fRTS_:
 312       gnat_argv[gnat_argc] = xstrdup ("-fRTS");
 313       gnat_argc++;
 314       break;
 315
 316     case OPT_gant:
 317       warning (0, "%<-gnat%> misspelled as %<-gant%>");
 318
 319       /* ... fall through ... */
 320
 321     case OPT_gnat:
 322       /* Recopy the switches without the 'gnat' prefix.  */
 323       gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2);
 324       gnat_argv[gnat_argc][0] = '-';
 325       strcpy (gnat_argv[gnat_argc] + 1, arg);
 326       gnat_argc++;
 327       break;
 328
 329     case OPT_gnatO:
 330       gnat_argv[gnat_argc] = xstrdup ("-O");
 331       gnat_argc++;
 332       gnat_argv[gnat_argc] = xstrdup (arg);
 333       gnat_argc++;
 334       break;
 335     }
 336
 337   return 1;
 338 }
 339
 340 /* Initialize for option processing.  */
 341
 342 static unsigned int
 343 gnat_init_options (unsigned int argc, const char **argv)
 344 {
 345   /* Initialize gnat_argv with save_argv size.  */
 346   gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
 347   gnat_argv[0] = xstrdup (argv[0]);     /* name of the command */
 348   gnat_argc = 1;
 349
 350   save_argc = argc;
 351   save_argv = argv;
 352
 353   /* Uninitialized really means uninitialized in Ada.  */
 354   flag_zero_initialized_in_bss = 0;
 355
 356   return CL_Ada;
 357 }
 358
 359 /* Post-switch processing.  */
 360
 361 bool
 362 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
 363 {
 364   flag_inline_trees = 1;
 365
 366   if (!flag_no_inline)
 367     flag_no_inline = 1;
 368   if (flag_inline_functions)
 369     flag_inline_trees = 2;
 370
 371   /* Force eliminate_unused_debug_types to 0 unless an explicit positive
 372      -f has been passed.  This forces the default to 0 for Ada, which might
 373      differ from the common default.  */
 374   if (flag_eliminate_unused_debug_types < 0)
 375     flag_eliminate_unused_debug_types = 1;
 376   else
 377     flag_eliminate_unused_debug_types = 0;
 378
 379   return false;
 380 }
 381
 382 /* Here is the function to handle the compiler error processing in GCC.  */
 383
 384 static void
 385 internal_error_function (const char *msgid, va_list *ap)
 386 {
 387   text_info tinfo;
 388   char *buffer, *p, *loc;
 389   String_Template temp, temp_loc;
 390   Fat_Pointer fp, fp_loc;
 391   expanded_location s;
 392
 393   /* Reset the pretty-printer.  */
 394   pp_clear_output_area (global_dc->printer);
 395
 396   /* Format the message into the pretty-printer.  */
 397   tinfo.format_spec = msgid;
 398   tinfo.args_ptr = ap;
 399   tinfo.err_no = errno;
 400   pp_format_verbatim (global_dc->printer, &tinfo);
 401
 402   /* Extract a (writable) pointer to the formatted text.  */
 403   buffer = (char*) pp_formatted_text (global_dc->printer);
 404
 405   /* Go up to the first newline.  */
 406   for (p = buffer; *p; p++)
 407     if (*p == '\n')
 408       {
 409         *p = '\0';
 410         break;
 411       }
 412
 413   temp.Low_Bound = 1;
 414   temp.High_Bound = p - buffer;
 415   fp.Bounds = &temp;
 416   fp.Array = buffer;
 417
 418   s = expand_location (input_location);
 419 #ifdef USE_MAPPED_LOCATION
 420   if (flag_show_column && s.column != 0)
 421     asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column);
 422   else
 423 #endif
 424     asprintf (&loc, "%s:%d", s.file, s.line);
 425   temp_loc.Low_Bound = 1;
 426   temp_loc.High_Bound = strlen (loc);
 427   fp_loc.Bounds = &temp_loc;
 428   fp_loc.Array = loc;
 429
 430   Current_Error_Node = error_gnat_node;
 431   Compiler_Abort (fp, -1, fp_loc);
 432 }
 433
 434 /* Perform all the initialization steps that are language-specific.  */
 435
 436 static bool
 437 gnat_init (void)
 438 {
 439   /* Initialize translations and the outer statement group.  */
 440   gnat_init_stmt_group ();
 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   set_lang_adjust_rli (gnat_adjust_rli);
 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   abort ();
 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_eh_runtime_type;
 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
 531   flag_exceptions = 1;
 532   flag_non_call_exceptions = 1;
 533
 534   init_eh ();
 535 #ifdef DWARF2_UNWIND_INFO
 536   if (!dwarf2out_frame_initialized && dwarf2out_do_frame ())
 537     dwarf2out_frame_init ();
 538 #endif
 539 }
 540
 541 /* Language hooks, first one to print language-specific items in a DECL.  */
 542
 543 static void
 544 gnat_print_decl (FILE *file, tree node, int indent)
 545 {
 546   switch (TREE_CODE (node))
 547     {
 548     case CONST_DECL:
 549       print_node (file, "const_corresponding_var",
 550                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 551       break;
 552
 553     case FIELD_DECL:
 554       print_node (file, "original_field", DECL_ORIGINAL_FIELD (node),
 555                   indent + 4);
 556       break;
 557
 558     case VAR_DECL:
 559       print_node (file, "renamed_object", DECL_RENAMED_OBJECT (node),
 560                   indent + 4);
 561       break;
 562
 563     default:
 564       break;
 565     }
 566 }
 567
 568 static void
 569 gnat_print_type (FILE *file, tree node, int indent)
 570 {
 571   switch (TREE_CODE (node))
 572     {
 573     case FUNCTION_TYPE:
 574       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 575       break;
 576
 577     case ENUMERAL_TYPE:
 578       print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
 579       break;
 580
 581     case INTEGER_TYPE:
 582       if (TYPE_MODULAR_P (node))
 583         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 584       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 585         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 586                     indent + 4);
 587       else if (TYPE_VAX_FLOATING_POINT_P (node))
 588         ;
 589       else
 590         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 591
 592       print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
 593       break;
 594
 595     case ARRAY_TYPE:
 596       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 597       break;
 598
 599     case RECORD_TYPE:
 600       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 601         print_node (file, "unconstrained array",
 602                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 603       else
 604         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 605       break;
 606
 607     case UNION_TYPE:
 608     case QUAL_UNION_TYPE:
 609       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 610       break;
 611
 612     default:
 613       break;
 614     }
 615 }
 616
 617 static const char *
 618 gnat_printable_name (tree decl, int verbosity)
 619 {
 620   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 621   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 622
 623   __gnat_decode (coded_name, ada_name, 0);
 624
 625   if (verbosity == 2)
 626     {
 627       Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
 628       ada_name = Name_Buffer;
 629     }
 630
 631   return (const char *) ada_name;
 632 }
 633
 634 static const char *
 635 gnat_dwarf_name (tree t, int verbosity ATTRIBUTE_UNUSED)
 636 {
 637   gcc_assert (DECL_P (t));
 638
 639   return (const char *) IDENTIFIER_POINTER (DECL_NAME (t));
 640 }
 641
 642 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 643    here are  and NULL_EXPR.  */
 644
 645 static rtx
 646 gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode,
 647                   int modifier, rtx *alt_rtl)
 648 {
 649   tree type = TREE_TYPE (exp);
 650   tree new;
 651
 652   /* Update EXP to be the new expression to expand.  */
 653   switch (TREE_CODE (exp))
 654     {
 655 #if 0
 656     case ALLOCATE_EXPR:
 657       return
 658         allocate_dynamic_stack_space
 659           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 660                         EXPAND_NORMAL),
 661            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 662 #endif
 663
 664     case UNCONSTRAINED_ARRAY_REF:
 665       /* If we are evaluating just for side-effects, just evaluate our
 666          operand.  Otherwise, abort since this code should never appear
 667          in a tree to be evaluated (objects aren't unconstrained).  */
 668       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 669         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 670                             VOIDmode, modifier);
 671
 672       /* ... fall through ... */
 673
 674     default:
 675       abort ();
 676     }
 677
 678   return expand_expr_real (new, target, tmode, modifier, alt_rtl);
 679 }
 680
 681 /* Generate the RTL for the body of GNU_DECL.  */
 682
 683 static void
 684 gnat_expand_body (tree gnu_decl)
 685 {
 686   tree_rest_of_compilation (gnu_decl);
 687 }
 688
 689 /* Adjusts the RLI used to layout a record after all the fields have been
 690    added.  We only handle the packed case and cause it to use the alignment
 691    that will pad the record at the end.  */
 692
 693 static void
 694 gnat_adjust_rli (record_layout_info rli ATTRIBUTE_UNUSED)
 695 {
 696 #if 0
 697   /* ??? This code seems to have no actual effect; record_align should already
 698      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 699   unsigned int record_align = rli->unpadded_align;
 700   tree field;
 701
 702   /* If an alignment has been specified, don't use anything larger unless we
 703      have to.  */
 704   if (TYPE_ALIGN (rli->t) != 0 && TYPE_ALIGN (rli->t) < record_align)
 705     record_align = MAX (rli->record_align, TYPE_ALIGN (rli->t));
 706
 707   /* If any fields have variable size, we need to force the record to be at
 708      least as aligned as the alignment of that type.  */
 709   for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field))
 710     if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST)
 711       record_align = MAX (record_align, DECL_ALIGN (field));
 712
 713   if (TYPE_PACKED (rli->t))
 714     rli->record_align = record_align;
 715 #endif
 716 }
 717 \f
 718 /* These routines are used in conjunction with GCC exception handling.  */
 719
 720 /* Map compile-time to run-time tree for GCC exception handling scheme.  */
 721
 722 static tree
 723 gnat_eh_runtime_type (tree type)
 724 {
 725   return type;
 726 }
 727
 728 /* Return true if type A catches type B. Callback for flow analysis from
 729    the exception handling part of the back-end.  */
 730
 731 static int
 732 gnat_eh_type_covers (tree a, tree b)
 733 {
 734   /* a catches b if they represent the same exception id or if a
 735      is an "others".
 736
 737      ??? integer_zero_node for "others" is hardwired in too many places
 738      currently.  */
 739   return (a == b || a == integer_zero_node);
 740 }
 741 \f
 742 /* Get the alias set corresponding to a type or expression.  */
 743
 744 static alias_set_type
 745 gnat_get_alias_set (tree type)
 746 {
 747   /* If this is a padding type, use the type of the first field.  */
 748   if (TREE_CODE (type) == RECORD_TYPE
 749       && TYPE_IS_PADDING_P (type))
 750     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 751
 752   /* If the type is an unconstrained array, use the type of the
 753      self-referential array we make.  */
 754   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 755     return
 756       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 757
 758   /* If the type can alias any other types, return the alias set 0.  */
 759   else if (TYPE_P (type)
 760            && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
 761     return 0;
 762
 763   return -1;
 764 }
 765
 766 /* GNU_TYPE is a type.  Return its maximum size in bytes, if known,
 767    as a constant when possible.  */
 768
 769 static tree
 770 gnat_type_max_size (tree gnu_type)
 771 {
 772   /* First see what we can get from TYPE_SIZE_UNIT, which might not
 773      be constant even for simple expressions if it has already been
 774      elaborated and possibly replaced by a VAR_DECL.  */
 775   tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
 776
 777   /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
 778      which should stay untouched.  */
 779   if (!host_integerp (max_unitsize, 1)
 780       && (TREE_CODE (gnu_type) == RECORD_TYPE
 781           || TREE_CODE (gnu_type) == UNION_TYPE
 782           || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
 783       && TYPE_ADA_SIZE (gnu_type))
 784     {
 785       tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
 786
 787       /* If we have succeeded in finding a constant, round it up to the
 788          type's alignment and return the result in units.  */
 789       if (host_integerp (max_adasize, 1))
 790         max_unitsize
 791           = size_binop (CEIL_DIV_EXPR,
 792                         round_up (max_adasize, TYPE_ALIGN (gnu_type)),
 793                         bitsize_unit_node);
 794     }
 795
 796   return max_unitsize;
 797 }
 798
 799 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 800    default.  */
 801
 802 bool
 803 default_pass_by_ref (tree gnu_type)
 804 {
 805   /* We pass aggregates by reference if they are sufficiently large.  The
 806      choice of constant here is somewhat arbitrary.  We also pass by
 807      reference if the target machine would either pass or return by
 808      reference.  Strictly speaking, we need only check the return if this
 809      is an In Out parameter, but it's probably best to err on the side of
 810      passing more things by reference.  */
 811
 812   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1))
 813     return true;
 814
 815   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 816     return true;
 817
 818   if (AGGREGATE_TYPE_P (gnu_type)
 819       && (!host_integerp (TYPE_SIZE (gnu_type), 1)
 820           || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 821                                    8 * TYPE_ALIGN (gnu_type))))
 822     return true;
 823
 824   return false;
 825 }
 826
 827 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 828    it should be passed by reference. */
 829
 830 bool
 831 must_pass_by_ref (tree gnu_type)
 832 {
 833   /* We pass only unconstrained objects, those required by the language
 834      to be passed by reference, and objects of variable size.  The latter
 835      is more efficient, avoids problems with variable size temporaries,
 836      and does not produce compatibility problems with C, since C does
 837      not have such objects.  */
 838   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 839           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 840           || (TYPE_SIZE (gnu_type)
 841               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 842 }
 843
 844 /* This function is called by the front end to enumerate all the supported
 845    modes for the machine.  We pass a function which is called back with
 846    the following integer parameters:
 847
 848    FLOAT_P      nonzero if this represents a floating-point mode
 849    COMPLEX_P    nonzero is this represents a complex mode
 850    COUNT        count of number of items, nonzero for vector mode
 851    PRECISION    number of bits in data representation
 852    MANTISSA     number of bits in mantissa, if FP and known, else zero.
 853    SIZE         number of bits used to store data
 854    ALIGN        number of bits to which mode is aligned.  */
 855
 856 void
 857 enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
 858 {
 859   enum machine_mode i;
 860
 861   for (i = 0; i < NUM_MACHINE_MODES; i++)
 862     {
 863       enum machine_mode j;
 864       bool float_p = 0;
 865       bool complex_p = 0;
 866       bool vector_p = 0;
 867       bool skip_p = 0;
 868       int mantissa = 0;
 869       enum machine_mode inner_mode = i;
 870
 871       switch (GET_MODE_CLASS (i))
 872         {
 873         case MODE_INT:
 874           break;
 875         case MODE_FLOAT:
 876           float_p = 1;
 877           break;
 878         case MODE_COMPLEX_INT:
 879           complex_p = 1;
 880           inner_mode = GET_MODE_INNER (i);
 881           break;
 882         case MODE_COMPLEX_FLOAT:
 883           float_p = 1;
 884           complex_p = 1;
 885           inner_mode = GET_MODE_INNER (i);
 886           break;
 887         case MODE_VECTOR_INT:
 888           vector_p = 1;
 889           inner_mode = GET_MODE_INNER (i);
 890           break;
 891         case MODE_VECTOR_FLOAT:
 892           float_p = 1;
 893           vector_p = 1;
 894           inner_mode = GET_MODE_INNER (i);
 895           break;
 896         default:
 897           skip_p = 1;
 898         }
 899
 900       /* Skip this mode if it's one the front end doesn't need to know about
 901          (e.g., the CC modes) or if there is no add insn for that mode (or
 902          any wider mode), meaning it is not supported by the hardware.  If
 903          this a complex or vector mode, we care about the inner mode.  */
 904       for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
 905         if (optab_handler (add_optab, j)->insn_code != CODE_FOR_nothing)
 906           break;
 907
 908       if (float_p)
 909         {
 910           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 911
 912           mantissa = fmt->p;
 913         }
 914
 915       if (!skip_p && j != VOIDmode)
 916         (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
 917               GET_MODE_BITSIZE (i), mantissa,
 918               GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
 919     }
 920 }
 921
 922 int
 923 fp_prec_to_size (int prec)
 924 {
 925   enum machine_mode mode;
 926
 927   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 928        mode = GET_MODE_WIDER_MODE (mode))
 929     if (GET_MODE_PRECISION (mode) == prec)
 930       return GET_MODE_BITSIZE (mode);
 931
 932   abort ();
 933 }
 934
 935 int
 936 fp_size_to_prec (int size)
 937 {
 938   enum machine_mode mode;
 939
 940   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 941        mode = GET_MODE_WIDER_MODE (mode))
 942     if (GET_MODE_BITSIZE (mode) == size)
 943       return GET_MODE_PRECISION (mode);
 944
 945   abort ();
 946 }