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_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 void gnat_adjust_rli             (record_layout_info);
 105 static tree gnat_type_max_size          (const_tree);
 106
 107 /* Definitions for our language-specific hooks.  */
 108
 109 #undef  LANG_HOOKS_NAME
 110 #define LANG_HOOKS_NAME                 "GNU Ada"
 111 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 112 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 113 #undef  LANG_HOOKS_INIT
 114 #define LANG_HOOKS_INIT                 gnat_init
 115 #undef  LANG_HOOKS_INIT_OPTIONS
 116 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 117 #undef  LANG_HOOKS_HANDLE_OPTION
 118 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
 119 #undef  LANG_HOOKS_POST_OPTIONS
 120 #define LANG_HOOKS_POST_OPTIONS         gnat_post_options
 121 #undef  LANG_HOOKS_PARSE_FILE
 122 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 123 #undef  LANG_HOOKS_HASH_TYPES
 124 #define LANG_HOOKS_HASH_TYPES           false
 125 #undef  LANG_HOOKS_GETDECLS
 126 #define LANG_HOOKS_GETDECLS             lhd_return_null_tree_v
 127 #undef  LANG_HOOKS_PUSHDECL
 128 #define LANG_HOOKS_PUSHDECL             gnat_return_tree
 129 #undef  LANG_HOOKS_WRITE_GLOBALS
 130 #define LANG_HOOKS_WRITE_GLOBALS      gnat_write_global_declarations
 131 #undef  LANG_HOOKS_FINISH_INCOMPLETE_DECL
 132 #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
 133 #undef  LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS
 134 #define LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS true
 135 #undef  LANG_HOOKS_GET_ALIAS_SET
 136 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 137 #undef  LANG_HOOKS_EXPAND_EXPR
 138 #define LANG_HOOKS_EXPAND_EXPR          gnat_expand_expr
 139 #undef  LANG_HOOKS_MARK_ADDRESSABLE
 140 #define LANG_HOOKS_MARK_ADDRESSABLE     gnat_mark_addressable
 141 #undef  LANG_HOOKS_PRINT_DECL
 142 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 143 #undef  LANG_HOOKS_PRINT_TYPE
 144 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 145 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 146 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 147 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 148 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 149 #undef  LANG_HOOKS_DWARF_NAME
 150 #define LANG_HOOKS_DWARF_NAME           gnat_dwarf_name
 151 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 152 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 153 #undef  LANG_HOOKS_TYPE_FOR_MODE
 154 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 155 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 156 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 157 #undef  LANG_HOOKS_ATTRIBUTE_TABLE
 158 #define LANG_HOOKS_ATTRIBUTE_TABLE      gnat_internal_attribute_table
 159 #undef  LANG_HOOKS_BUILTIN_FUNCTION
 160 #define LANG_HOOKS_BUILTIN_FUNCTION        gnat_builtin_function
 161
 162 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 163
 164 /* Tables describing GCC tree codes used only by GNAT.
 165
 166    Table indexed by tree code giving a string containing a character
 167    classifying the tree code.  Possibilities are
 168    t, d, s, c, r, <, 1 and 2.  See cp-tree.def for details.  */
 169
 170 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 171
 172 const enum tree_code_class tree_code_type[] = {
 173 #include "tree.def"
 174   tcc_exceptional,
 175 #include "ada-tree.def"
 176 };
 177 #undef DEFTREECODE
 178
 179 /* Table indexed by tree code giving number of expression
 180    operands beyond the fixed part of the node structure.
 181    Not used for types or decls.  */
 182
 183 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 184
 185 const unsigned char tree_code_length[] = {
 186 #include "tree.def"
 187   0,
 188 #include "ada-tree.def"
 189 };
 190 #undef DEFTREECODE
 191
 192 /* Names of tree components.
 193    Used for printing out the tree and error messages.  */
 194 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 195
 196 const char *const tree_code_name[] = {
 197 #include "tree.def"
 198   "@@dummy",
 199 #include "ada-tree.def"
 200 };
 201 #undef DEFTREECODE
 202
 203 /* Command-line argc and argv.
 204    These variables are global, since they are imported and used in
 205    back_end.adb  */
 206
 207 unsigned int save_argc;
 208 const char **save_argv;
 209
 210 /* gnat standard argc argv */
 211
 212 extern int gnat_argc;
 213 extern char **gnat_argv;
 214
 215 \f
 216 /* Declare functions we use as part of startup.  */
 217 extern void __gnat_initialize           (void *);
 218 extern void __gnat_install_SEH_handler  (void *);
 219 extern void adainit                     (void);
 220 extern void _ada_gnat1drv               (void);
 221
 222 /* The parser for the language.  For us, we process the GNAT tree.  */
 223
 224 static void
 225 gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 226 {
 227   int seh[2];
 228
 229   /* Call the target specific initializations.  */
 230   __gnat_initialize (NULL);
 231
 232   /* ??? Call the SEH initialization routine.  This is to workaround
 233   a bootstrap path problem.  The call below should be removed at some
 234   point and the SEH pointer passed to __gnat_initialize() above.  */
 235   __gnat_install_SEH_handler((void *)seh);
 236
 237   /* Call the front-end elaboration procedures.  */
 238   adainit ();
 239
 240   /* Call the front end.  */
 241   _ada_gnat1drv ();
 242
 243   /* We always have a single compilation unit in Ada.  */
 244   cgraph_finalize_compilation_unit ();
 245 }
 246
 247 /* Decode all the language specific options that cannot be decoded by GCC.
 248    The option decoding phase of GCC calls this routine on the flags that
 249    it cannot decode.  This routine returns the number of consecutive arguments
 250    from ARGV that it successfully decoded; 0 indicates failure.  */
 251
 252 static int
 253 gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
 254 {
 255   const struct cl_option *option = &cl_options[scode];
 256   enum opt_code code = (enum opt_code) scode;
 257   char *q;
 258
 259   if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
 260     {
 261       error ("missing argument to \"-%s\"", option->opt_text);
 262       return 1;
 263     }
 264
 265   switch (code)
 266     {
 267     default:
 268       abort ();
 269
 270     case OPT_I:
 271       q = xmalloc (sizeof("-I") + strlen (arg));
 272       strcpy (q, "-I");
 273       strcat (q, arg);
 274       gnat_argv[gnat_argc] = q;
 275       gnat_argc++;
 276       break;
 277
 278       /* All front ends are expected to accept this.  */
 279     case OPT_Wall:
 280       /* These are used in the GCC Makefile.  */
 281     case OPT_Wmissing_prototypes:
 282     case OPT_Wstrict_prototypes:
 283     case OPT_Wwrite_strings:
 284     case OPT_Wlong_long:
 285     case OPT_Wvariadic_macros:
 286     case OPT_Wold_style_definition:
 287     case OPT_Wmissing_format_attribute:
 288     case OPT_Woverlength_strings:
 289       break;
 290
 291       /* This is handled by the front-end.  */
 292     case OPT_nostdinc:
 293       break;
 294
 295     case OPT_nostdlib:
 296       gnat_argv[gnat_argc] = xstrdup ("-nostdlib");
 297       gnat_argc++;
 298       break;
 299
 300     case OPT_feliminate_unused_debug_types:
 301       /* We arrange for post_option to be able to only set the corresponding
 302          flag to 1 when explicitely requested by the user.  We expect the
 303          default flag value to be either 0 or positive, and expose a positive
 304          -f as a negative value to post_option.  */
 305       flag_eliminate_unused_debug_types = -value;
 306       break;
 307
 308     case OPT_fRTS_:
 309       gnat_argv[gnat_argc] = xstrdup ("-fRTS");
 310       gnat_argc++;
 311       break;
 312
 313     case OPT_gant:
 314       warning (0, "%<-gnat%> misspelled as %<-gant%>");
 315
 316       /* ... fall through ... */
 317
 318     case OPT_gnat:
 319       /* Recopy the switches without the 'gnat' prefix.  */
 320       gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2);
 321       gnat_argv[gnat_argc][0] = '-';
 322       strcpy (gnat_argv[gnat_argc] + 1, arg);
 323       gnat_argc++;
 324       break;
 325
 326     case OPT_gnatO:
 327       gnat_argv[gnat_argc] = xstrdup ("-O");
 328       gnat_argc++;
 329       gnat_argv[gnat_argc] = xstrdup (arg);
 330       gnat_argc++;
 331       break;
 332     }
 333
 334   return 1;
 335 }
 336
 337 /* Initialize for option processing.  */
 338
 339 static unsigned int
 340 gnat_init_options (unsigned int argc, const char **argv)
 341 {
 342   /* Initialize gnat_argv with save_argv size.  */
 343   gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
 344   gnat_argv[0] = xstrdup (argv[0]);     /* name of the command */
 345   gnat_argc = 1;
 346
 347   save_argc = argc;
 348   save_argv = argv;
 349
 350   /* Uninitialized really means uninitialized in Ada.  */
 351   flag_zero_initialized_in_bss = 0;
 352
 353   return CL_Ada;
 354 }
 355
 356 /* Post-switch processing.  */
 357
 358 bool
 359 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
 360 {
 361   flag_inline_trees = 1;
 362
 363   if (!flag_no_inline)
 364     flag_no_inline = 1;
 365   if (flag_inline_functions)
 366     flag_inline_trees = 2;
 367
 368   /* Force eliminate_unused_debug_types to 0 unless an explicit positive
 369      -f has been passed.  This forces the default to 0 for Ada, which might
 370      differ from the common default.  */
 371   if (flag_eliminate_unused_debug_types < 0)
 372     flag_eliminate_unused_debug_types = 1;
 373   else
 374     flag_eliminate_unused_debug_types = 0;
 375
 376   return false;
 377 }
 378
 379 /* Here is the function to handle the compiler error processing in GCC.  */
 380
 381 static void
 382 internal_error_function (const char *msgid, va_list *ap)
 383 {
 384   text_info tinfo;
 385   char *buffer, *p, *loc;
 386   String_Template temp, temp_loc;
 387   Fat_Pointer fp, fp_loc;
 388   expanded_location s;
 389
 390   /* Reset the pretty-printer.  */
 391   pp_clear_output_area (global_dc->printer);
 392
 393   /* Format the message into the pretty-printer.  */
 394   tinfo.format_spec = msgid;
 395   tinfo.args_ptr = ap;
 396   tinfo.err_no = errno;
 397   pp_format_verbatim (global_dc->printer, &tinfo);
 398
 399   /* Extract a (writable) pointer to the formatted text.  */
 400   buffer = (char*) pp_formatted_text (global_dc->printer);
 401
 402   /* Go up to the first newline.  */
 403   for (p = buffer; *p; p++)
 404     if (*p == '\n')
 405       {
 406         *p = '\0';
 407         break;
 408       }
 409
 410   temp.Low_Bound = 1;
 411   temp.High_Bound = p - buffer;
 412   fp.Bounds = &temp;
 413   fp.Array = buffer;
 414
 415   s = expand_location (input_location);
 416 #ifdef USE_MAPPED_LOCATION
 417   if (flag_show_column && s.column != 0)
 418     asprintf (&loc, "%s:%d:%d", s.file, s.line, s.column);
 419   else
 420 #endif
 421     asprintf (&loc, "%s:%d", s.file, s.line);
 422   temp_loc.Low_Bound = 1;
 423   temp_loc.High_Bound = strlen (loc);
 424   fp_loc.Bounds = &temp_loc;
 425   fp_loc.Array = loc;
 426
 427   Current_Error_Node = error_gnat_node;
 428   Compiler_Abort (fp, -1, fp_loc);
 429 }
 430
 431 /* Perform all the initialization steps that are language-specific.  */
 432
 433 static bool
 434 gnat_init (void)
 435 {
 436   /* Initialize translations and the outer statement group.  */
 437   gnat_init_stmt_group ();
 438
 439   /* Performs whatever initialization steps needed by the language-dependent
 440      lexical analyzer.  */
 441   gnat_init_decl_processing ();
 442
 443   /* Add the input filename as the last argument.  */
 444   gnat_argv[gnat_argc] = (char *) main_input_filename;
 445   gnat_argc++;
 446   gnat_argv[gnat_argc] = 0;
 447
 448   global_dc->internal_error = &internal_error_function;
 449
 450   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 451   internal_reference_types ();
 452
 453   set_lang_adjust_rli (gnat_adjust_rli);
 454
 455   return true;
 456 }
 457
 458 /* This function is called indirectly from toplev.c to handle incomplete
 459    declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero.  To be precise,
 460    compile_file in toplev.c makes an indirect call through the function pointer
 461    incomplete_decl_finalize_hook which is initialized to this routine in
 462    init_decl_processing.  */
 463
 464 static void
 465 gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED)
 466 {
 467   abort ();
 468 }
 469 \f
 470 /* Compute the alignment of the largest mode that can be used for copying
 471    objects.  */
 472
 473 void
 474 gnat_compute_largest_alignment (void)
 475 {
 476   enum machine_mode mode;
 477
 478   for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode;
 479        mode = GET_MODE_WIDER_MODE (mode))
 480     if (optab_handler (mov_optab, mode)->insn_code != CODE_FOR_nothing)
 481       largest_move_alignment = MIN (BIGGEST_ALIGNMENT,
 482                                     MAX (largest_move_alignment,
 483                                          GET_MODE_ALIGNMENT (mode)));
 484 }
 485
 486 /* If we are using the GCC mechanism to process exception handling, we
 487    have to register the personality routine for Ada and to initialize
 488    various language dependent hooks.  */
 489
 490 void
 491 gnat_init_gcc_eh (void)
 492 {
 493 #ifdef DWARF2_UNWIND_INFO
 494   /* lang_dependent_init already called dwarf2out_frame_init if true.  */
 495   int dwarf2out_frame_initialized = dwarf2out_do_frame ();
 496 #endif
 497
 498   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 499      though. This could for instance lead to the emission of tables with
 500      references to symbols (such as the Ada eh personality routine) within
 501      libraries we won't link against.  */
 502   if (No_Exception_Handlers_Set ())
 503     return;
 504
 505   /* Tell GCC we are handling cleanup actions through exception propagation.
 506      This opens possibilities that we don't take advantage of yet, but is
 507      nonetheless necessary to ensure that fixup code gets assigned to the
 508      right exception regions.  */
 509   using_eh_for_cleanups ();
 510
 511   eh_personality_libfunc = init_one_libfunc (USING_SJLJ_EXCEPTIONS
 512                                              ? "__gnat_eh_personality_sj"
 513                                              : "__gnat_eh_personality");
 514   lang_eh_type_covers = gnat_eh_type_covers;
 515   lang_eh_runtime_type = gnat_return_tree;
 516   default_init_unwind_resume_libfunc ();
 517
 518   /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
 519      the generation of the necessary exception runtime tables. The second one
 520      is useful for two reasons: 1/ we map some asynchronous signals like SEGV
 521      to exceptions, so we need to ensure that the insns which can lead to such
 522      signals are correctly attached to the exception region they pertain to,
 523      2/ Some calls to pure subprograms are handled as libcall blocks and then
 524      marked as "cannot trap" if the flag is not set (see emit_libcall_block).
 525      We should not let this be since it is possible for such calls to actually
 526      raise in Ada.  */
 527
 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_printable_name (tree decl, int verbosity)
 616 {
 617   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 618   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 619
 620   __gnat_decode (coded_name, ada_name, 0);
 621
 622   if (verbosity == 2)
 623     {
 624       Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
 625       ada_name = Name_Buffer;
 626     }
 627
 628   return (const char *) ada_name;
 629 }
 630
 631 static const char *
 632 gnat_dwarf_name (tree t, int verbosity ATTRIBUTE_UNUSED)
 633 {
 634   gcc_assert (DECL_P (t));
 635
 636   return (const char *) IDENTIFIER_POINTER (DECL_NAME (t));
 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       abort ();
 673     }
 674
 675   return expand_expr_real (new, target, tmode, modifier, alt_rtl);
 676 }
 677
 678 /* Adjusts the RLI used to layout a record after all the fields have been
 679    added.  We only handle the packed case and cause it to use the alignment
 680    that will pad the record at the end.  */
 681
 682 static void
 683 gnat_adjust_rli (record_layout_info rli ATTRIBUTE_UNUSED)
 684 {
 685 #if 0
 686   /* ??? This code seems to have no actual effect; record_align should already
 687      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 688   unsigned int record_align = rli->unpadded_align;
 689   tree field;
 690
 691   /* If an alignment has been specified, don't use anything larger unless we
 692      have to.  */
 693   if (TYPE_ALIGN (rli->t) != 0 && TYPE_ALIGN (rli->t) < record_align)
 694     record_align = MAX (rli->record_align, TYPE_ALIGN (rli->t));
 695
 696   /* If any fields have variable size, we need to force the record to be at
 697      least as aligned as the alignment of that type.  */
 698   for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field))
 699     if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST)
 700       record_align = MAX (record_align, DECL_ALIGN (field));
 701
 702   if (TYPE_PACKED (rli->t))
 703     rli->record_align = record_align;
 704 #endif
 705 }
 706
 707 /* Do nothing (return the tree node passed).  */
 708
 709 static tree
 710 gnat_return_tree (tree t)
 711 {
 712   return t;
 713 }
 714
 715 /* Return true if type A catches type B. Callback for flow analysis from
 716    the exception handling part of the back-end.  */
 717
 718 static int
 719 gnat_eh_type_covers (tree a, tree b)
 720 {
 721   /* a catches b if they represent the same exception id or if a
 722      is an "others".
 723
 724      ??? integer_zero_node for "others" is hardwired in too many places
 725      currently.  */
 726   return (a == b || a == integer_zero_node);
 727 }
 728 \f
 729 /* Get the alias set corresponding to a type or expression.  */
 730
 731 static alias_set_type
 732 gnat_get_alias_set (tree type)
 733 {
 734   /* If this is a padding type, use the type of the first field.  */
 735   if (TREE_CODE (type) == RECORD_TYPE
 736       && TYPE_IS_PADDING_P (type))
 737     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 738
 739   /* If the type is an unconstrained array, use the type of the
 740      self-referential array we make.  */
 741   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 742     return
 743       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 744
 745   /* If the type can alias any other types, return the alias set 0.  */
 746   else if (TYPE_P (type)
 747            && TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (type)))
 748     return 0;
 749
 750   return -1;
 751 }
 752
 753 /* GNU_TYPE is a type.  Return its maximum size in bytes, if known,
 754    as a constant when possible.  */
 755
 756 static tree
 757 gnat_type_max_size (const_tree gnu_type)
 758 {
 759   /* First see what we can get from TYPE_SIZE_UNIT, which might not
 760      be constant even for simple expressions if it has already been
 761      elaborated and possibly replaced by a VAR_DECL.  */
 762   tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
 763
 764   /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
 765      which should stay untouched.  */
 766   if (!host_integerp (max_unitsize, 1)
 767       && (TREE_CODE (gnu_type) == RECORD_TYPE
 768           || TREE_CODE (gnu_type) == UNION_TYPE
 769           || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
 770       && TYPE_ADA_SIZE (gnu_type))
 771     {
 772       tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
 773
 774       /* If we have succeeded in finding a constant, round it up to the
 775          type's alignment and return the result in units.  */
 776       if (host_integerp (max_adasize, 1))
 777         max_unitsize
 778           = size_binop (CEIL_DIV_EXPR,
 779                         round_up (max_adasize, TYPE_ALIGN (gnu_type)),
 780                         bitsize_unit_node);
 781     }
 782
 783   return max_unitsize;
 784 }
 785
 786 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 787    default.  */
 788
 789 bool
 790 default_pass_by_ref (tree gnu_type)
 791 {
 792   /* We pass aggregates by reference if they are sufficiently large.  The
 793      choice of constant here is somewhat arbitrary.  We also pass by
 794      reference if the target machine would either pass or return by
 795      reference.  Strictly speaking, we need only check the return if this
 796      is an In Out parameter, but it's probably best to err on the side of
 797      passing more things by reference.  */
 798
 799   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1))
 800     return true;
 801
 802   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 803     return true;
 804
 805   if (AGGREGATE_TYPE_P (gnu_type)
 806       && (!host_integerp (TYPE_SIZE (gnu_type), 1)
 807           || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 808                                    8 * TYPE_ALIGN (gnu_type))))
 809     return true;
 810
 811   return false;
 812 }
 813
 814 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 815    it should be passed by reference. */
 816
 817 bool
 818 must_pass_by_ref (tree gnu_type)
 819 {
 820   /* We pass only unconstrained objects, those required by the language
 821      to be passed by reference, and objects of variable size.  The latter
 822      is more efficient, avoids problems with variable size temporaries,
 823      and does not produce compatibility problems with C, since C does
 824      not have such objects.  */
 825   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 826           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 827           || (TYPE_SIZE (gnu_type)
 828               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 829 }
 830
 831 /* This function is called by the front end to enumerate all the supported
 832    modes for the machine.  We pass a function which is called back with
 833    the following integer parameters:
 834
 835    FLOAT_P      nonzero if this represents a floating-point mode
 836    COMPLEX_P    nonzero is this represents a complex mode
 837    COUNT        count of number of items, nonzero for vector mode
 838    PRECISION    number of bits in data representation
 839    MANTISSA     number of bits in mantissa, if FP and known, else zero.
 840    SIZE         number of bits used to store data
 841    ALIGN        number of bits to which mode is aligned.  */
 842
 843 void
 844 enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
 845 {
 846   enum machine_mode i;
 847
 848   for (i = 0; i < NUM_MACHINE_MODES; i++)
 849     {
 850       enum machine_mode j;
 851       bool float_p = 0;
 852       bool complex_p = 0;
 853       bool vector_p = 0;
 854       bool skip_p = 0;
 855       int mantissa = 0;
 856       enum machine_mode inner_mode = i;
 857
 858       switch (GET_MODE_CLASS (i))
 859         {
 860         case MODE_INT:
 861           break;
 862         case MODE_FLOAT:
 863           float_p = 1;
 864           break;
 865         case MODE_COMPLEX_INT:
 866           complex_p = 1;
 867           inner_mode = GET_MODE_INNER (i);
 868           break;
 869         case MODE_COMPLEX_FLOAT:
 870           float_p = 1;
 871           complex_p = 1;
 872           inner_mode = GET_MODE_INNER (i);
 873           break;
 874         case MODE_VECTOR_INT:
 875           vector_p = 1;
 876           inner_mode = GET_MODE_INNER (i);
 877           break;
 878         case MODE_VECTOR_FLOAT:
 879           float_p = 1;
 880           vector_p = 1;
 881           inner_mode = GET_MODE_INNER (i);
 882           break;
 883         default:
 884           skip_p = 1;
 885         }
 886
 887       /* Skip this mode if it's one the front end doesn't need to know about
 888          (e.g., the CC modes) or if there is no add insn for that mode (or
 889          any wider mode), meaning it is not supported by the hardware.  If
 890          this a complex or vector mode, we care about the inner mode.  */
 891       for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
 892         if (optab_handler (add_optab, j)->insn_code != CODE_FOR_nothing)
 893           break;
 894
 895       if (float_p)
 896         {
 897           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 898
 899           mantissa = fmt->p;
 900         }
 901
 902       if (!skip_p && j != VOIDmode)
 903         (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
 904               GET_MODE_BITSIZE (i), mantissa,
 905               GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
 906     }
 907 }
 908
 909 int
 910 fp_prec_to_size (int prec)
 911 {
 912   enum machine_mode mode;
 913
 914   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 915        mode = GET_MODE_WIDER_MODE (mode))
 916     if (GET_MODE_PRECISION (mode) == prec)
 917       return GET_MODE_BITSIZE (mode);
 918
 919   abort ();
 920 }
 921
 922 int
 923 fp_size_to_prec (int size)
 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_BITSIZE (mode) == size)
 930       return GET_MODE_PRECISION (mode);
 931
 932   abort ();
 933 }