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