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-2006, 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 HOST_WIDE_INT 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 tree gnat_eh_runtime_type        (tree);
  98 static int gnat_eh_type_covers          (tree, tree);
  99 static void gnat_parse_file             (int);
 100 static rtx gnat_expand_expr             (tree, rtx, enum machine_mode, int,
 101                                          rtx *);
 102 static void gnat_expand_body            (tree);
 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          (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             lhd_return_tree
 129 #undef  LANG_HOOKS_FINISH_INCOMPLETE_DECL
 130 #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
 131 #undef  LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS
 132 #define LANG_HOOKS_REDUCE_BIT_FIELD_OPERATIONS true
 133 #undef  LANG_HOOKS_GET_ALIAS_SET
 134 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 135 #undef  LANG_HOOKS_EXPAND_EXPR
 136 #define LANG_HOOKS_EXPAND_EXPR          gnat_expand_expr
 137 #undef  LANG_HOOKS_MARK_ADDRESSABLE
 138 #define LANG_HOOKS_MARK_ADDRESSABLE     gnat_mark_addressable
 139 #undef  LANG_HOOKS_PRINT_DECL
 140 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 141 #undef  LANG_HOOKS_PRINT_TYPE
 142 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 143 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 144 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 145 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 146 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 147 #undef  LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
 148 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gnat_expand_body
 149 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 150 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 151 #undef  LANG_HOOKS_TYPE_FOR_MODE
 152 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 153 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 154 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 155 #undef  LANG_HOOKS_SIGNED_TYPE
 156 #define LANG_HOOKS_SIGNED_TYPE          gnat_signed_type
 157 #undef  LANG_HOOKS_UNSIGNED_TYPE
 158 #define LANG_HOOKS_UNSIGNED_TYPE        gnat_unsigned_type
 159 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 160 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gnat_signed_or_unsigned_type
 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 a
 233   bootstrap path problem. The call below should be removed at some point and
 234   the seh pointer passed to __gnat_initialize() above.  */
 235
 236   __gnat_install_SEH_handler((void *)seh);
 237
 238   /* Call the front-end elaboration procedures */
 239   adainit ();
 240
 241   /* Call the front end */
 242   _ada_gnat1drv ();
 243
 244   cgraph_finalize_compilation_unit ();
 245   cgraph_optimize ();
 246 }
 247
 248 /* Decode all the language specific options that cannot be decoded by GCC.
 249    The option decoding phase of GCC calls this routine on the flags that
 250    it cannot decode.  This routine returns the number of consecutive arguments
 251    from ARGV that it successfully decoded; 0 indicates failure.  */
 252
 253 static int
 254 gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
 255 {
 256   const struct cl_option *option = &cl_options[scode];
 257   enum opt_code code = (enum opt_code) scode;
 258   char *q;
 259
 260   if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
 261     {
 262       error ("missing argument to \"-%s\"", option->opt_text);
 263       return 1;
 264     }
 265
 266   switch (code)
 267     {
 268     default:
 269       abort ();
 270
 271     case OPT_I:
 272       q = xmalloc (sizeof("-I") + strlen (arg));
 273       strcpy (q, "-I");
 274       strcat (q, arg);
 275       gnat_argv[gnat_argc] = q;
 276       gnat_argc++;
 277       break;
 278
 279       /* All front ends are expected to accept this.  */
 280     case OPT_Wall:
 281       /* These are used in the GCC Makefile.  */
 282     case OPT_Wmissing_prototypes:
 283     case OPT_Wstrict_prototypes:
 284     case OPT_Wwrite_strings:
 285     case OPT_Wlong_long:
 286     case OPT_Wvariadic_macros:
 287     case OPT_Wold_style_definition:
 288     case OPT_Wmissing_format_attribute:
 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_fRTS_:
 301       gnat_argv[gnat_argc] = xstrdup ("-fRTS");
 302       gnat_argc++;
 303       break;
 304
 305     case OPT_gant:
 306       warning (0, "%<-gnat%> misspelled as %<-gant%>");
 307
 308       /* ... fall through ... */
 309
 310     case OPT_gnat:
 311       /* Recopy the switches without the 'gnat' prefix.  */
 312       gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2);
 313       gnat_argv[gnat_argc][0] = '-';
 314       strcpy (gnat_argv[gnat_argc] + 1, arg);
 315       gnat_argc++;
 316       break;
 317
 318     case OPT_gnatO:
 319       gnat_argv[gnat_argc] = xstrdup ("-O");
 320       gnat_argc++;
 321       gnat_argv[gnat_argc] = xstrdup (arg);
 322       gnat_argc++;
 323       break;
 324     }
 325
 326   return 1;
 327 }
 328
 329 /* Initialize for option processing.  */
 330
 331 static unsigned int
 332 gnat_init_options (unsigned int argc, const char **argv)
 333 {
 334   /* Initialize gnat_argv with save_argv size.  */
 335   gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
 336   gnat_argv[0] = xstrdup (argv[0]);     /* name of the command */
 337   gnat_argc = 1;
 338
 339   save_argc = argc;
 340   save_argv = argv;
 341
 342   /* Uninitialized really means uninitialized in Ada.  */
 343   flag_zero_initialized_in_bss = 0;
 344
 345   return CL_Ada;
 346 }
 347
 348 /* Post-switch processing.  */
 349
 350 bool
 351 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
 352 {
 353   flag_inline_trees = 1;
 354
 355   if (!flag_no_inline)
 356     flag_no_inline = 1;
 357   if (flag_inline_functions)
 358     flag_inline_trees = 2;
 359
 360   flag_tree_salias = 0;
 361
 362   return false;
 363 }
 364
 365 /* Here is the function to handle the compiler error processing in GCC.  */
 366
 367 static void
 368 internal_error_function (const char *msgid, va_list *ap)
 369 {
 370   text_info tinfo;
 371   char *buffer;
 372   char *p;
 373   String_Template temp;
 374   Fat_Pointer fp;
 375
 376   /* Reset the pretty-printer.  */
 377   pp_clear_output_area (global_dc->printer);
 378
 379   /* Format the message into the pretty-printer.  */
 380   tinfo.format_spec = msgid;
 381   tinfo.args_ptr = ap;
 382   tinfo.err_no = errno;
 383   pp_format_verbatim (global_dc->printer, &tinfo);
 384
 385   /* Extract a (writable) pointer to the formatted text.  */
 386   buffer = (char*) pp_formatted_text (global_dc->printer);
 387
 388   /* Go up to the first newline.  */
 389   for (p = buffer; *p; p++)
 390     if (*p == '\n')
 391       {
 392         *p = '\0';
 393         break;
 394       }
 395
 396   temp.Low_Bound = 1;
 397   temp.High_Bound = p - buffer;
 398   fp.Bounds = &temp;
 399   fp.Array = buffer;
 400
 401   Current_Error_Node = error_gnat_node;
 402   Compiler_Abort (fp, -1);
 403 }
 404
 405 /* Perform all the initialization steps that are language-specific.  */
 406
 407 static bool
 408 gnat_init (void)
 409 {
 410   /* Initialize translations and the outer statement group.  */
 411   gnat_init_stmt_group ();
 412
 413   /* Performs whatever initialization steps needed by the language-dependent
 414      lexical analyzer.  */
 415   gnat_init_decl_processing ();
 416
 417   /* Add the input filename as the last argument.  */
 418   gnat_argv[gnat_argc] = (char *) main_input_filename;
 419   gnat_argc++;
 420   gnat_argv[gnat_argc] = 0;
 421
 422   global_dc->internal_error = &internal_error_function;
 423
 424   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 425   internal_reference_types ();
 426
 427   set_lang_adjust_rli (gnat_adjust_rli);
 428
 429   return true;
 430 }
 431
 432 /* This function is called indirectly from toplev.c to handle incomplete
 433    declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero.  To be precise,
 434    compile_file in toplev.c makes an indirect call through the function pointer
 435    incomplete_decl_finalize_hook which is initialized to this routine in
 436    init_decl_processing.  */
 437
 438 static void
 439 gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED)
 440 {
 441   abort ();
 442 }
 443 \f
 444 /* Compute the alignment of the largest mode that can be used for copying
 445    objects.  */
 446
 447 void
 448 gnat_compute_largest_alignment (void)
 449 {
 450   enum machine_mode mode;
 451
 452   for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode;
 453        mode = GET_MODE_WIDER_MODE (mode))
 454     if (mov_optab->handlers[(int) mode].insn_code != CODE_FOR_nothing)
 455       largest_move_alignment = MIN (BIGGEST_ALIGNMENT,
 456                                     MAX (largest_move_alignment,
 457                                          GET_MODE_ALIGNMENT (mode)));
 458 }
 459
 460 /* If we are using the GCC mechanism to process exception handling, we
 461    have to register the personality routine for Ada and to initialize
 462    various language dependent hooks.  */
 463
 464 void
 465 gnat_init_gcc_eh (void)
 466 {
 467   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 468      though. This could for instance lead to the emission of tables with
 469      references to symbols (such as the Ada eh personality routine) within
 470      libraries we won't link against.  */
 471   if (No_Exception_Handlers_Set ())
 472     return;
 473
 474   /* Tell GCC we are handling cleanup actions through exception propagation.
 475      This opens possibilities that we don't take advantage of yet, but is
 476      nonetheless necessary to ensure that fixup code gets assigned to the
 477      right exception regions.  */
 478   using_eh_for_cleanups ();
 479
 480   eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality");
 481   lang_eh_type_covers = gnat_eh_type_covers;
 482   lang_eh_runtime_type = gnat_eh_runtime_type;
 483   default_init_unwind_resume_libfunc ();
 484
 485   /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
 486      the generation of the necessary exception runtime tables. The second one
 487      is useful for two reasons: 1/ we map some asynchronous signals like SEGV
 488      to exceptions, so we need to ensure that the insns which can lead to such
 489      signals are correctly attached to the exception region they pertain to,
 490      2/ Some calls to pure subprograms are handled as libcall blocks and then
 491      marked as "cannot trap" if the flag is not set (see emit_libcall_block).
 492      We should not let this be since it is possible for such calls to actually
 493      raise in Ada.  */
 494
 495   flag_exceptions = 1;
 496   flag_non_call_exceptions = 1;
 497
 498   init_eh ();
 499 #ifdef DWARF2_UNWIND_INFO
 500   if (dwarf2out_do_frame ())
 501     dwarf2out_frame_init ();
 502 #endif
 503 }
 504
 505 /* Language hooks, first one to print language-specific items in a DECL.  */
 506
 507 static void
 508 gnat_print_decl (FILE *file, tree node, int indent)
 509 {
 510   switch (TREE_CODE (node))
 511     {
 512     case CONST_DECL:
 513       print_node (file, "const_corresponding_var",
 514                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 515       break;
 516
 517     case FIELD_DECL:
 518       print_node (file, "original_field", DECL_ORIGINAL_FIELD (node),
 519                   indent + 4);
 520       break;
 521
 522     case VAR_DECL:
 523       print_node (file, "renamed_object", DECL_RENAMED_OBJECT (node),
 524                   indent + 4);
 525       break;
 526
 527     default:
 528       break;
 529     }
 530 }
 531
 532 static void
 533 gnat_print_type (FILE *file, tree node, int indent)
 534 {
 535   switch (TREE_CODE (node))
 536     {
 537     case FUNCTION_TYPE:
 538       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 539       break;
 540
 541     case ENUMERAL_TYPE:
 542       print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
 543       break;
 544
 545     case INTEGER_TYPE:
 546       if (TYPE_MODULAR_P (node))
 547         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 548       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 549         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 550                     indent + 4);
 551       else if (TYPE_VAX_FLOATING_POINT_P (node))
 552         ;
 553       else
 554         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 555
 556       print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
 557       break;
 558
 559     case ARRAY_TYPE:
 560       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 561       break;
 562
 563     case RECORD_TYPE:
 564       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 565         print_node (file, "unconstrained array",
 566                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 567       else
 568         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 569       break;
 570
 571     case UNION_TYPE:
 572     case QUAL_UNION_TYPE:
 573       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 574       break;
 575
 576     default:
 577       break;
 578     }
 579 }
 580
 581 static const char *
 582 gnat_printable_name (tree decl, int verbosity)
 583 {
 584   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 585   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 586
 587   __gnat_decode (coded_name, ada_name, 0);
 588
 589   if (verbosity == 2)
 590     {
 591       Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
 592       ada_name = Name_Buffer;
 593     }
 594
 595   return (const char *) ada_name;
 596 }
 597
 598 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 599    here are  and NULL_EXPR.  */
 600
 601 static rtx
 602 gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode,
 603                   int modifier, rtx *alt_rtl)
 604 {
 605   tree type = TREE_TYPE (exp);
 606   tree new;
 607
 608   /* If this is a statement, call the expansion routine for statements.  */
 609   if (IS_STMT (exp))
 610     {
 611       gnat_expand_stmt (exp);
 612       return const0_rtx;
 613     }
 614
 615   /* Update EXP to be the new expression to expand.  */
 616   switch (TREE_CODE (exp))
 617     {
 618 #if 0
 619     case ALLOCATE_EXPR:
 620       return
 621         allocate_dynamic_stack_space
 622           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 623                         EXPAND_NORMAL),
 624            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 625 #endif
 626
 627     case UNCONSTRAINED_ARRAY_REF:
 628       /* If we are evaluating just for side-effects, just evaluate our
 629          operand.  Otherwise, abort since this code should never appear
 630          in a tree to be evaluated (objects aren't unconstrained).  */
 631       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 632         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 633                             VOIDmode, modifier);
 634
 635       /* ... fall through ... */
 636
 637     default:
 638       abort ();
 639     }
 640
 641   return expand_expr_real (new, target, tmode, modifier, alt_rtl);
 642 }
 643
 644 /* Generate the RTL for the body of GNU_DECL.  */
 645
 646 static void
 647 gnat_expand_body (tree gnu_decl)
 648 {
 649   if (!DECL_INITIAL (gnu_decl) || DECL_INITIAL (gnu_decl) == error_mark_node)
 650     return;
 651
 652   tree_rest_of_compilation (gnu_decl);
 653
 654   if (DECL_STATIC_CONSTRUCTOR (gnu_decl) && targetm.have_ctors_dtors)
 655     targetm.asm_out.constructor (XEXP (DECL_RTL (gnu_decl), 0),
 656                                  DEFAULT_INIT_PRIORITY);
 657
 658   if (DECL_STATIC_DESTRUCTOR (gnu_decl) && targetm.have_ctors_dtors)
 659     targetm.asm_out.destructor (XEXP (DECL_RTL (gnu_decl), 0),
 660                                 DEFAULT_INIT_PRIORITY);
 661 }
 662
 663 /* Adjusts the RLI used to layout a record after all the fields have been
 664    added.  We only handle the packed case and cause it to use the alignment
 665    that will pad the record at the end.  */
 666
 667 static void
 668 gnat_adjust_rli (record_layout_info rli ATTRIBUTE_UNUSED)
 669 {
 670 #if 0
 671   /* ??? This code seems to have no actual effect; record_align should already
 672      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 673   unsigned int record_align = rli->unpadded_align;
 674   tree field;
 675
 676   /* If an alignment has been specified, don't use anything larger unless we
 677      have to.  */
 678   if (TYPE_ALIGN (rli->t) != 0 && TYPE_ALIGN (rli->t) < record_align)
 679     record_align = MAX (rli->record_align, TYPE_ALIGN (rli->t));
 680
 681   /* If any fields have variable size, we need to force the record to be at
 682      least as aligned as the alignment of that type.  */
 683   for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field))
 684     if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST)
 685       record_align = MAX (record_align, DECL_ALIGN (field));
 686
 687   if (TYPE_PACKED (rli->t))
 688     rli->record_align = record_align;
 689 #endif
 690 }
 691 \f
 692 /* These routines are used in conjunction with GCC exception handling.  */
 693
 694 /* Map compile-time to run-time tree for GCC exception handling scheme.  */
 695
 696 static tree
 697 gnat_eh_runtime_type (tree type)
 698 {
 699   return type;
 700 }
 701
 702 /* Return true if type A catches type B. Callback for flow analysis from
 703    the exception handling part of the back-end.  */
 704
 705 static int
 706 gnat_eh_type_covers (tree a, tree b)
 707 {
 708   /* a catches b if they represent the same exception id or if a
 709      is an "others".
 710
 711      ??? integer_zero_node for "others" is hardwired in too many places
 712      currently.  */
 713   return (a == b || a == integer_zero_node);
 714 }
 715 \f
 716 /* Get the alias set corresponding to a type or expression.  */
 717
 718 static HOST_WIDE_INT
 719 gnat_get_alias_set (tree type)
 720 {
 721   /* If this is a padding type, use the type of the first field.  */
 722   if (TREE_CODE (type) == RECORD_TYPE
 723       && TYPE_IS_PADDING_P (type))
 724     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 725
 726   /* If the type is an unconstrained array, use the type of the
 727      self-referential array we make.  */
 728   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 729     return
 730       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 731
 732
 733   return -1;
 734 }
 735
 736 /* GNU_TYPE is a type.  Return its maxium size in bytes, if known.  */
 737
 738 static tree
 739 gnat_type_max_size (gnu_type)
 740      tree gnu_type;
 741 {
 742   return max_size (TYPE_SIZE_UNIT (gnu_type), true);
 743 }
 744
 745 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 746    default.  */
 747
 748 bool
 749 default_pass_by_ref (tree gnu_type)
 750 {
 751   /* We pass aggregates by reference if they are sufficiently large.  The
 752      choice of constant here is somewhat arbitrary.  We also pass by
 753      reference if the target machine would either pass or return by
 754      reference.  Strictly speaking, we need only check the return if this
 755      is an In Out parameter, but it's probably best to err on the side of
 756      passing more things by reference.  */
 757
 758   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1))
 759     return true;
 760
 761   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 762     return true;
 763
 764   if (AGGREGATE_TYPE_P (gnu_type)
 765       && (!host_integerp (TYPE_SIZE (gnu_type), 1)
 766           || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 767                                    8 * TYPE_ALIGN (gnu_type))))
 768     return true;
 769
 770   return false;
 771 }
 772
 773 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 774    it should be passed by reference. */
 775
 776 bool
 777 must_pass_by_ref (tree gnu_type)
 778 {
 779   /* We pass only unconstrained objects, those required by the language
 780      to be passed by reference, and objects of variable size.  The latter
 781      is more efficient, avoids problems with variable size temporaries,
 782      and does not produce compatibility problems with C, since C does
 783      not have such objects.  */
 784   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 785           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 786           || (TYPE_SIZE (gnu_type)
 787               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 788 }
 789
 790 /* This function is called by the front end to enumerate all the supported
 791    modes for the machine.  We pass a function which is called back with
 792    the following integer parameters:
 793
 794    FLOAT_P      nonzero if this represents a floating-point mode
 795    COMPLEX_P    nonzero is this represents a complex mode
 796    COUNT        count of number of items, nonzero for vector mode
 797    PRECISION    number of bits in data representation
 798    MANTISSA     number of bits in mantissa, if FP and known, else zero.
 799    SIZE         number of bits used to store data
 800    ALIGN        number of bits to which mode is aligned.  */
 801
 802 void
 803 enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
 804 {
 805   enum machine_mode i;
 806
 807   for (i = 0; i < NUM_MACHINE_MODES; i++)
 808     {
 809       enum machine_mode j;
 810       bool float_p = 0;
 811       bool complex_p = 0;
 812       bool vector_p = 0;
 813       bool skip_p = 0;
 814       int mantissa = 0;
 815       enum machine_mode inner_mode = i;
 816
 817       switch (GET_MODE_CLASS (i))
 818         {
 819         case MODE_INT:
 820           break;
 821         case MODE_FLOAT:
 822           float_p = 1;
 823           break;
 824         case MODE_COMPLEX_INT:
 825           complex_p = 1;
 826           inner_mode = GET_MODE_INNER (i);
 827           break;
 828         case MODE_COMPLEX_FLOAT:
 829           float_p = 1;
 830           complex_p = 1;
 831           inner_mode = GET_MODE_INNER (i);
 832           break;
 833         case MODE_VECTOR_INT:
 834           vector_p = 1;
 835           inner_mode = GET_MODE_INNER (i);
 836           break;
 837         case MODE_VECTOR_FLOAT:
 838           float_p = 1;
 839           vector_p = 1;
 840           inner_mode = GET_MODE_INNER (i);
 841           break;
 842         default:
 843           skip_p = 1;
 844         }
 845
 846       /* Skip this mode if it's one the front end doesn't need to know about
 847          (e.g., the CC modes) or if there is no add insn for that mode (or
 848          any wider mode), meaning it is not supported by the hardware.  If
 849          this a complex or vector mode, we care about the inner mode.  */
 850       for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
 851         if (add_optab->handlers[j].insn_code != CODE_FOR_nothing)
 852           break;
 853
 854       if (float_p)
 855         {
 856           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 857
 858           mantissa = fmt->p * fmt->log2_b;
 859         }
 860
 861       if (!skip_p && j != VOIDmode)
 862         (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
 863               GET_MODE_BITSIZE (i), mantissa,
 864               GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
 865     }
 866 }
 867
 868 int
 869 fp_prec_to_size (int prec)
 870 {
 871   enum machine_mode mode;
 872
 873   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 874        mode = GET_MODE_WIDER_MODE (mode))
 875     if (GET_MODE_PRECISION (mode) == prec)
 876       return GET_MODE_BITSIZE (mode);
 877
 878   abort ();
 879 }
 880
 881 int
 882 fp_size_to_prec (int size)
 883 {
 884   enum machine_mode mode;
 885
 886   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 887        mode = GET_MODE_WIDER_MODE (mode))
 888     if (GET_MODE_BITSIZE (mode) == size)
 889       return GET_MODE_PRECISION (mode);
 890
 891   abort ();
 892 }