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-2004 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 "errors.h"
  45 #include "diagnostic.h"
  46 #include "expr.h"
  47 #include "libfuncs.h"
  48 #include "ggc.h"
  49 #include "flags.h"
  50 #include "debug.h"
  51 #include "insn-codes.h"
  52 #include "insn-flags.h"
  53 #include "insn-config.h"
  54 #include "optabs.h"
  55 #include "recog.h"
  56 #include "toplev.h"
  57 #include "output.h"
  58 #include "except.h"
  59 #include "tm_p.h"
  60 #include "langhooks.h"
  61 #include "langhooks-def.h"
  62 #include "target.h"
  63
  64 #include "ada.h"
  65 #include "types.h"
  66 #include "atree.h"
  67 #include "elists.h"
  68 #include "namet.h"
  69 #include "nlists.h"
  70 #include "stringt.h"
  71 #include "uintp.h"
  72 #include "fe.h"
  73 #include "sinfo.h"
  74 #include "einfo.h"
  75 #include "ada-tree.h"
  76 #include "gigi.h"
  77 #include "adadecode.h"
  78 #include "opts.h"
  79 #include "options.h"
  80
  81 extern FILE *asm_out_file;
  82
  83 /* The largest alignment, in bits, that is needed for using the widest
  84    move instruction.  */
  85 unsigned int largest_move_alignment;
  86
  87 static size_t gnat_tree_size            (enum tree_code);
  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 HOST_WIDE_INT gnat_get_alias_set (tree);
  93 static void gnat_print_decl             (FILE *, tree, int);
  94 static void gnat_print_type             (FILE *, tree, int);
  95 static const char *gnat_printable_name  (tree, int);
  96 static tree gnat_eh_runtime_type        (tree);
  97 static int gnat_eh_type_covers          (tree, tree);
  98 static void gnat_parse_file             (int);
  99 static rtx gnat_expand_expr             (tree, rtx, enum machine_mode, int,
 100                                          rtx *);
 101 static void internal_error_function     (const char *, va_list *);
 102 static void gnat_adjust_rli             (record_layout_info);
 103
 104 /* Definitions for our language-specific hooks.  */
 105
 106 #undef  LANG_HOOKS_NAME
 107 #define LANG_HOOKS_NAME                 "GNU Ada"
 108 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 109 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 110 #undef  LANG_HOOKS_TREE_SIZE
 111 #define LANG_HOOKS_TREE_SIZE            gnat_tree_size
 112 #undef  LANG_HOOKS_INIT
 113 #define LANG_HOOKS_INIT                 gnat_init
 114 #undef  LANG_HOOKS_INIT_OPTIONS
 115 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 116 #undef  LANG_HOOKS_HANDLE_OPTION
 117 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
 118 #undef LANG_HOOKS_PARSE_FILE
 119 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 120 #undef LANG_HOOKS_HONOR_READONLY
 121 #define LANG_HOOKS_HONOR_READONLY       true
 122 #undef LANG_HOOKS_HASH_TYPES
 123 #define LANG_HOOKS_HASH_TYPES           false
 124 #undef LANG_HOOKS_FINISH_INCOMPLETE_DECL
 125 #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
 126 #undef LANG_HOOKS_GET_ALIAS_SET
 127 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 128 #undef LANG_HOOKS_EXPAND_EXPR
 129 #define LANG_HOOKS_EXPAND_EXPR          gnat_expand_expr
 130 #undef LANG_HOOKS_MARK_ADDRESSABLE
 131 #define LANG_HOOKS_MARK_ADDRESSABLE     gnat_mark_addressable
 132 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
 133 #define LANG_HOOKS_TRUTHVALUE_CONVERSION gnat_truthvalue_conversion
 134 #undef LANG_HOOKS_PRINT_DECL
 135 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 136 #undef LANG_HOOKS_PRINT_TYPE
 137 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 138 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
 139 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 140 #undef LANG_HOOKS_TYPE_FOR_MODE
 141 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 142 #undef LANG_HOOKS_TYPE_FOR_SIZE
 143 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 144 #undef LANG_HOOKS_SIGNED_TYPE
 145 #define LANG_HOOKS_SIGNED_TYPE          gnat_signed_type
 146 #undef LANG_HOOKS_UNSIGNED_TYPE
 147 #define LANG_HOOKS_UNSIGNED_TYPE        gnat_unsigned_type
 148 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 149 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gnat_signed_or_unsigned_type
 150
 151 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 152
 153 /* Tables describing GCC tree codes used only by GNAT.
 154
 155    Table indexed by tree code giving a string containing a character
 156    classifying the tree code.  Possibilities are
 157    t, d, s, c, r, <, 1 and 2.  See cp-tree.def for details.  */
 158
 159 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 160
 161 const char tree_code_type[] = {
 162 #include "tree.def"
 163   'x',
 164 #include "ada-tree.def"
 165 };
 166 #undef DEFTREECODE
 167
 168 /* Table indexed by tree code giving number of expression
 169    operands beyond the fixed part of the node structure.
 170    Not used for types or decls.  */
 171
 172 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 173
 174 const unsigned char tree_code_length[] = {
 175 #include "tree.def"
 176   0,
 177 #include "ada-tree.def"
 178 };
 179 #undef DEFTREECODE
 180
 181 /* Names of tree components.
 182    Used for printing out the tree and error messages.  */
 183 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 184
 185 const char *const tree_code_name[] = {
 186 #include "tree.def"
 187   "@@dummy",
 188 #include "ada-tree.def"
 189 };
 190 #undef DEFTREECODE
 191
 192 /* Command-line argc and argv.
 193    These variables are global, since they are imported and used in
 194    back_end.adb  */
 195
 196 unsigned int save_argc;
 197 const char **save_argv;
 198
 199 /* gnat standard argc argv */
 200
 201 extern int gnat_argc;
 202 extern char **gnat_argv;
 203
 204 \f
 205 /* Declare functions we use as part of startup.  */
 206 extern void __gnat_initialize   (void);
 207 extern void adainit             (void);
 208 extern void _ada_gnat1drv       (void);
 209
 210 /* The parser for the language.  For us, we process the GNAT tree.  */
 211
 212 static void
 213 gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 214 {
 215   /* call the target specific initializations */
 216   __gnat_initialize();
 217
 218   /* Call the front-end elaboration procedures */
 219   adainit ();
 220
 221   immediate_size_expand = 1;
 222
 223   /* Call the front end */
 224   _ada_gnat1drv ();
 225 }
 226
 227 /* Decode all the language specific options that cannot be decoded by GCC.
 228    The option decoding phase of GCC calls this routine on the flags that
 229    it cannot decode.  This routine returns the number of consecutive arguments
 230    from ARGV that it successfully decoded; 0 indicates failure.  */
 231
 232 static int
 233 gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
 234 {
 235   const struct cl_option *option = &cl_options[scode];
 236   enum opt_code code = (enum opt_code) scode;
 237   char *q;
 238   unsigned int i;
 239
 240   if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
 241     {
 242       error ("missing argument to \"-%s\"", option->opt_text);
 243       return 1;
 244     }
 245
 246   switch (code)
 247     {
 248     default:
 249       abort ();
 250
 251     case OPT_I:
 252       q = xmalloc (sizeof("-I") + strlen (arg));
 253       strcpy (q, "-I");
 254       strcat (q, arg);
 255       gnat_argv[gnat_argc] = q;
 256       gnat_argc++;
 257       break;
 258
 259       /* All front ends are expected to accept this.  */
 260     case OPT_Wall:
 261       /* These are used in the GCC Makefile.  */
 262     case OPT_Wmissing_prototypes:
 263     case OPT_Wstrict_prototypes:
 264     case OPT_Wwrite_strings:
 265     case OPT_Wlong_long:
 266       break;
 267
 268       /* This is handled by the front-end.  */
 269     case OPT_nostdinc:
 270       break;
 271
 272     case OPT_nostdlib:
 273       gnat_argv[gnat_argc] = xstrdup ("-nostdlib");
 274       gnat_argc++;
 275       break;
 276
 277     case OPT_fRTS:
 278       gnat_argv[gnat_argc] = xstrdup ("-fRTS");
 279       gnat_argc++;
 280       break;
 281
 282     case OPT_gant:
 283       warning ("`-gnat' misspelled as `-gant'");
 284
 285       /* ... fall through ... */
 286
 287     case OPT_gnat:
 288       /* Recopy the switches without the 'gnat' prefix.  */
 289       gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2);
 290       gnat_argv[gnat_argc][0] = '-';
 291       strcpy (gnat_argv[gnat_argc] + 1, arg);
 292       gnat_argc++;
 293
 294       if (arg[0] == 'O')
 295         for (i = 1; i < save_argc - 1; i++)
 296           if (!strncmp (save_argv[i], "-gnatO", 6))
 297             if (save_argv[++i][0] != '-')
 298               {
 299                 /* Preserve output filename as GCC doesn't save it for GNAT. */
 300                 gnat_argv[gnat_argc] = xstrdup (save_argv[i]);
 301                 gnat_argc++;
 302                 break;
 303               }
 304       break;
 305     }
 306
 307   return 1;
 308 }
 309
 310 /* Initialize for option processing.  */
 311
 312 static unsigned int
 313 gnat_init_options (unsigned int argc, const char **argv)
 314 {
 315   /* Initialize gnat_argv with save_argv size.  */
 316   gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
 317   gnat_argv[0] = xstrdup (argv[0]);     /* name of the command */
 318   gnat_argc = 1;
 319
 320   save_argc = argc;
 321   save_argv = argv;
 322
 323   return CL_Ada;
 324 }
 325
 326 /* Here is the function to handle the compiler error processing in GCC.  */
 327
 328 static void
 329 internal_error_function (const char *msgid, va_list *ap)
 330 {
 331   char buffer[1000];            /* Assume this is big enough.  */
 332   char *p;
 333   String_Template temp;
 334   Fat_Pointer fp;
 335
 336   vsprintf (buffer, msgid, *ap);
 337
 338   /* Go up to the first newline.  */
 339   for (p = buffer; *p != 0; p++)
 340     if (*p == '\n')
 341       {
 342         *p = '\0';
 343         break;
 344       }
 345
 346   temp.Low_Bound = 1, temp.High_Bound = strlen (buffer);
 347   fp.Array = buffer, fp.Bounds = &temp;
 348
 349   Current_Error_Node = error_gnat_node;
 350   Compiler_Abort (fp, -1);
 351 }
 352
 353 /* Langhook for tree_size: Determine size of our 'x' and 'c' nodes.  */
 354
 355 static size_t
 356 gnat_tree_size (enum tree_code code)
 357 {
 358   switch (code)
 359     {
 360     case GNAT_LOOP_ID:
 361       return sizeof (struct tree_loop_id);
 362     default:
 363       abort ();
 364     }
 365   /* NOTREACHED */
 366 }
 367
 368 /* Perform all the initialization steps that are language-specific.  */
 369
 370 static bool
 371 gnat_init (void)
 372 {
 373   /* Performs whatever initialization steps needed by the language-dependent
 374      lexical analyzer.  */
 375   gnat_init_decl_processing ();
 376
 377   /* Add the input filename as the last argument.  */
 378   gnat_argv[gnat_argc] = (char *) main_input_filename;
 379   gnat_argc++;
 380   gnat_argv[gnat_argc] = 0;
 381
 382   global_dc->internal_error = &internal_error_function;
 383
 384   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 385   internal_reference_types ();
 386
 387   set_lang_adjust_rli (gnat_adjust_rli);
 388
 389   return true;
 390 }
 391
 392 /* This function is called indirectly from toplev.c to handle incomplete
 393    declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero.  To be precise,
 394    compile_file in toplev.c makes an indirect call through the function pointer
 395    incomplete_decl_finalize_hook which is initialized to this routine in
 396    init_decl_processing.  */
 397
 398 static void
 399 gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED)
 400 {
 401   gigi_abort (202);
 402 }
 403 \f
 404 /* Compute the alignment of the largest mode that can be used for copying
 405    objects.  */
 406
 407 void
 408 gnat_compute_largest_alignment (void)
 409 {
 410   enum machine_mode mode;
 411
 412   for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode;
 413        mode = GET_MODE_WIDER_MODE (mode))
 414     if (mov_optab->handlers[(int) mode].insn_code != CODE_FOR_nothing)
 415       largest_move_alignment = MIN (BIGGEST_ALIGNMENT,
 416                                     MAX (largest_move_alignment,
 417                                          GET_MODE_ALIGNMENT (mode)));
 418 }
 419
 420 /* If we are using the GCC mechanism to process exception handling, we
 421    have to register the personality routine for Ada and to initialize
 422    various language dependent hooks.  */
 423
 424 void
 425 gnat_init_gcc_eh (void)
 426 {
 427   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 428      though. This could for instance lead to the emission of tables with
 429      references to symbols (such as the Ada eh personality routine) within
 430      libraries we won't link against.  */
 431   if (No_Exception_Handlers_Set ())
 432     return;
 433
 434   /* Tell GCC we are handling cleanup actions through exception propagation.
 435      This opens possibilities that we don't take advantage of yet, but is
 436      nonetheless necessary to ensure that fixup code gets assigned to the
 437      right exception regions.  */
 438   using_eh_for_cleanups ();
 439
 440   eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality");
 441   lang_eh_type_covers = gnat_eh_type_covers;
 442   lang_eh_runtime_type = gnat_eh_runtime_type;
 443
 444   /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
 445      the generation of the necessary exception runtime tables. The second one
 446      is useful for two reasons: 1/ we map some asynchronous signals like SEGV
 447      to exceptions, so we need to ensure that the insns which can lead to such
 448      signals are correctly attached to the exception region they pertain to,
 449      2/ Some calls to pure subprograms are handled as libcall blocks and then
 450      marked as "cannot trap" if the flag is not set (see emit_libcall_block).
 451      We should not let this be since it is possible for such calls to actually
 452      raise in Ada.  */
 453
 454   flag_exceptions = 1;
 455   flag_non_call_exceptions = 1;
 456
 457   init_eh ();
 458 #ifdef DWARF2_UNWIND_INFO
 459   if (dwarf2out_do_frame ())
 460     dwarf2out_frame_init ();
 461 #endif
 462 }
 463
 464 /* Language hooks, first one to print language-specific items in a DECL.  */
 465
 466 static void
 467 gnat_print_decl (FILE *file, tree node, int indent)
 468 {
 469   switch (TREE_CODE (node))
 470     {
 471     case CONST_DECL:
 472       print_node (file, "const_corresponding_var",
 473                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 474       break;
 475
 476     case FIELD_DECL:
 477       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 478                   indent + 4);
 479       break;
 480
 481     default:
 482       break;
 483     }
 484 }
 485
 486 static void
 487 gnat_print_type (FILE *file, tree node, int indent)
 488 {
 489   switch (TREE_CODE (node))
 490     {
 491     case FUNCTION_TYPE:
 492       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 493       break;
 494
 495     case ENUMERAL_TYPE:
 496       print_node (file, "RM size", TYPE_RM_SIZE_ENUM (node), indent + 4);
 497       break;
 498
 499     case INTEGER_TYPE:
 500       if (TYPE_MODULAR_P (node))
 501         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 502       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 503         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 504                     indent + 4);
 505       else if (TYPE_VAX_FLOATING_POINT_P (node))
 506         ;
 507       else
 508         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 509
 510       print_node (file, "RM size", TYPE_RM_SIZE_INT (node), indent + 4);
 511       break;
 512
 513     case ARRAY_TYPE:
 514       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 515       break;
 516
 517     case RECORD_TYPE:
 518       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 519         print_node (file, "unconstrained array",
 520                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 521       else
 522         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 523       break;
 524
 525     case UNION_TYPE:
 526     case QUAL_UNION_TYPE:
 527       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 528       break;
 529
 530     default:
 531       break;
 532     }
 533 }
 534
 535 static const char *
 536 gnat_printable_name (tree decl, int verbosity)
 537 {
 538   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 539   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 540
 541   __gnat_decode (coded_name, ada_name, 0);
 542
 543   if (verbosity == 2)
 544     {
 545       Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
 546       ada_name = Name_Buffer;
 547     }
 548
 549   return (const char *) ada_name;
 550 }
 551
 552 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 553    here are TRANSFORM_EXPR, ALLOCATE_EXPR, USE_EXPR and NULL_EXPR.  */
 554
 555 static rtx
 556 gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode,
 557                   int modifier, rtx *alt_rtl)
 558 {
 559   tree type = TREE_TYPE (exp);
 560   tree new;
 561   rtx result;
 562
 563   /* If this is a statement, call the expansion routine for statements.  */
 564   if (IS_STMT (exp))
 565     {
 566       gnat_expand_stmt (exp);
 567       return const0_rtx;
 568     }
 569
 570   /* Update EXP to be the new expression to expand.  */
 571   switch (TREE_CODE (exp))
 572     {
 573     case TRANSFORM_EXPR:
 574       gnat_to_code (TREE_COMPLEXITY (exp));
 575       return const0_rtx;
 576       break;
 577
 578     case NULL_EXPR:
 579       expand_expr (TREE_OPERAND (exp, 0), const0_rtx, VOIDmode, 0);
 580
 581       /* We aren't going to be doing anything with this memory, but allocate
 582          it anyway.  If it's variable size, make a bogus address.  */
 583       if (! host_integerp (TYPE_SIZE_UNIT (type), 1))
 584         result = gen_rtx_MEM (BLKmode, virtual_stack_vars_rtx);
 585       else
 586         result = assign_temp (type, 0, TREE_ADDRESSABLE (exp), 1);
 587
 588       return result;
 589
 590     case ALLOCATE_EXPR:
 591       return
 592         allocate_dynamic_stack_space
 593           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 594                         EXPAND_NORMAL),
 595            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 596
 597     case USE_EXPR:
 598       if (target != const0_rtx)
 599         gigi_abort (203);
 600
 601       /* First write a volatile ASM_INPUT to prevent anything from being
 602          moved.  */
 603       result = gen_rtx_ASM_INPUT (VOIDmode, "");
 604       MEM_VOLATILE_P (result) = 1;
 605       emit_insn (result);
 606
 607       result = expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, VOIDmode,
 608                             modifier);
 609       emit_insn (gen_rtx_USE (VOIDmode, result));
 610       return target;
 611
 612     case GNAT_NOP_EXPR:
 613       return expand_expr_real (build1 (NOP_EXPR, type, TREE_OPERAND (exp, 0)),
 614                                target, tmode, modifier, alt_rtl);
 615
 616     case UNCONSTRAINED_ARRAY_REF:
 617       /* If we are evaluating just for side-effects, just evaluate our
 618          operand.  Otherwise, abort since this code should never appear
 619          in a tree to be evaluated (objects aren't unconstrained).  */
 620       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 621         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 622                             VOIDmode, modifier);
 623
 624       /* ... fall through ... */
 625
 626     default:
 627       gigi_abort (201);
 628     }
 629
 630   return expand_expr_real (new, target, tmode, modifier, alt_rtl);
 631 }
 632
 633 /* Adjusts the RLI used to layout a record after all the fields have been
 634    added.  We only handle the packed case and cause it to use the alignment
 635    that will pad the record at the end.  */
 636
 637 static void
 638 gnat_adjust_rli (record_layout_info rli ATTRIBUTE_UNUSED)
 639 {
 640 #if 0
 641   /* ??? This code seems to have no actual effect; record_align should already
 642      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 643   unsigned int record_align = rli->unpadded_align;
 644   tree field;
 645
 646   /* If an alignment has been specified, don't use anything larger unless we
 647      have to.  */
 648   if (TYPE_ALIGN (rli->t) != 0 && TYPE_ALIGN (rli->t) < record_align)
 649     record_align = MAX (rli->record_align, TYPE_ALIGN (rli->t));
 650
 651   /* If any fields have variable size, we need to force the record to be at
 652      least as aligned as the alignment of that type.  */
 653   for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field))
 654     if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST)
 655       record_align = MAX (record_align, DECL_ALIGN (field));
 656
 657   if (TYPE_PACKED (rli->t))
 658     rli->record_align = record_align;
 659 #endif
 660 }
 661
 662 /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code.  */
 663
 664 tree
 665 make_transform_expr (Node_Id gnat_node)
 666 {
 667   tree gnu_result = build (TRANSFORM_EXPR, void_type_node);
 668
 669   TREE_SIDE_EFFECTS (gnu_result) = 1;
 670   TREE_COMPLEXITY (gnu_result) = gnat_node;
 671   return gnu_result;
 672 }
 673 \f
 674 /* These routines are used in conjunction with GCC exception handling.  */
 675
 676 /* Map compile-time to run-time tree for GCC exception handling scheme.  */
 677
 678 static tree
 679 gnat_eh_runtime_type (tree type)
 680 {
 681   return type;
 682 }
 683
 684 /* Return true if type A catches type B. Callback for flow analysis from
 685    the exception handling part of the back-end.  */
 686
 687 static int
 688 gnat_eh_type_covers (tree a, tree b)
 689 {
 690   /* a catches b if they represent the same exception id or if a
 691      is an "others".
 692
 693      ??? integer_zero_node for "others" is hardwired in too many places
 694      currently.  */
 695   return (a == b || a == integer_zero_node);
 696 }
 697 \f
 698 /* See if DECL has an RTL that is indirect via a pseudo-register or a
 699    memory location and replace it with an indirect reference if so.
 700    This improves the debugger's ability to display the value.  */
 701
 702 void
 703 adjust_decl_rtl (tree decl)
 704 {
 705   tree new_type;
 706
 707   /* If this decl is already indirect, don't do anything.  This should
 708      mean that the decl cannot be indirect, but there's no point in
 709      adding an abort to check that.  */
 710   if (TREE_CODE (decl) != CONST_DECL
 711       && ! DECL_BY_REF_P (decl)
 712       && (GET_CODE (DECL_RTL (decl)) == MEM
 713           && (GET_CODE (XEXP (DECL_RTL (decl), 0)) == MEM
 714               || (GET_CODE (XEXP (DECL_RTL (decl), 0)) == REG
 715                   && (REGNO (XEXP (DECL_RTL (decl), 0))
 716                       > LAST_VIRTUAL_REGISTER))))
 717       /* We can't do this if the reference type's mode is not the same
 718          as the current mode, which means this may not work on mixed 32/64
 719          bit systems.  */
 720       && (new_type = build_reference_type (TREE_TYPE (decl))) != 0
 721       && TYPE_MODE (new_type) == GET_MODE (XEXP (DECL_RTL (decl), 0))
 722       /* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
 723          is also an indirect and of the same mode and if the object is
 724          readonly, the latter condition because we don't want to upset the
 725          handling of CICO_LIST.  */
 726       && (TREE_CODE (decl) != PARM_DECL
 727           || (GET_CODE (DECL_INCOMING_RTL (decl)) == MEM
 728               && (TYPE_MODE (new_type)
 729                   == GET_MODE (XEXP (DECL_INCOMING_RTL (decl), 0)))
 730               && TREE_READONLY (decl))))
 731     {
 732       new_type
 733         = build_qualified_type (new_type,
 734                                 (TYPE_QUALS (new_type) | TYPE_QUAL_CONST));
 735
 736       DECL_POINTS_TO_READONLY_P (decl) = TREE_READONLY (decl);
 737       DECL_BY_REF_P (decl) = 1;
 738       SET_DECL_RTL (decl, XEXP (DECL_RTL (decl), 0));
 739       TREE_TYPE (decl) = new_type;
 740       DECL_MODE (decl) = TYPE_MODE (new_type);
 741       DECL_ALIGN (decl) = TYPE_ALIGN (new_type);
 742       DECL_SIZE (decl) = TYPE_SIZE (new_type);
 743
 744       if (TREE_CODE (decl) == PARM_DECL)
 745         set_decl_incoming_rtl (decl, XEXP (DECL_INCOMING_RTL (decl), 0));
 746
 747       /* If DECL_INITIAL was set, it should be updated to show that
 748          the decl is initialized to the address of that thing.
 749          Otherwise, just set it to the address of this decl.
 750          It needs to be set so that GCC does not think the decl is
 751          unused.  */
 752       DECL_INITIAL (decl)
 753         = build1 (ADDR_EXPR, new_type,
 754                   DECL_INITIAL (decl) != 0 ? DECL_INITIAL (decl) : decl);
 755     }
 756 }
 757 \f
 758 /* Record the current code position in GNAT_NODE.  */
 759
 760 void
 761 record_code_position (Node_Id gnat_node)
 762 {
 763   if (global_bindings_p ())
 764     {
 765       /* Make a dummy entry so multiple things at the same location don't
 766          end up in the same place.  */
 767       add_pending_elaborations (NULL_TREE, NULL_TREE);
 768       save_gnu_tree (gnat_node, get_elaboration_location (), 1);
 769     }
 770   else
 771     /* Always emit another insn in case marking the last insn
 772        addressable needs some fixups and also for above reason.  */
 773     save_gnu_tree (gnat_node,
 774                    build (RTL_EXPR, void_type_node, NULL_TREE,
 775                           (tree) emit_note (NOTE_INSN_DELETED), NULL_TREE),
 776                    1);
 777 }
 778
 779 /* Insert the code for GNAT_NODE at the position saved for that node.  */
 780
 781 void
 782 insert_code_for (Node_Id gnat_node)
 783 {
 784   if (global_bindings_p ())
 785     {
 786       push_pending_elaborations ();
 787       gnat_to_code (gnat_node);
 788       Check_Elaboration_Code_Allowed (gnat_node);
 789       insert_elaboration_list (get_gnu_tree (gnat_node));
 790       pop_pending_elaborations ();
 791     }
 792   else
 793     {
 794       rtx insns;
 795
 796       do_pending_stack_adjust ();
 797       start_sequence ();
 798       mark_all_temps_used ();
 799       gnat_to_code (gnat_node);
 800       do_pending_stack_adjust ();
 801       insns = get_insns ();
 802       end_sequence ();
 803       emit_insn_after (insns, RTL_EXPR_RTL (get_gnu_tree (gnat_node)));
 804     }
 805 }
 806
 807 /* Get the alias set corresponding to a type or expression.  */
 808
 809 static HOST_WIDE_INT
 810 gnat_get_alias_set (tree type)
 811 {
 812   /* If this is a padding type, use the type of the first field.  */
 813   if (TREE_CODE (type) == RECORD_TYPE
 814       && TYPE_IS_PADDING_P (type))
 815     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 816
 817   /* If the type is an unconstrained array, use the type of the
 818      self-referential array we make.  */
 819   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 820     return
 821       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 822
 823
 824   return -1;
 825 }
 826
 827 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 828    default.  */
 829
 830 int
 831 default_pass_by_ref (tree gnu_type)
 832 {
 833   CUMULATIVE_ARGS cum;
 834
 835   INIT_CUMULATIVE_ARGS (cum, NULL_TREE, NULL_RTX, 0, 2);
 836
 837   /* We pass aggregates by reference if they are sufficiently large.  The
 838      choice of constant here is somewhat arbitrary.  We also pass by
 839      reference if the target machine would either pass or return by
 840      reference.  Strictly speaking, we need only check the return if this
 841      is an In Out parameter, but it's probably best to err on the side of
 842      passing more things by reference.  */
 843   return (0
 844 #ifdef FUNCTION_ARG_PASS_BY_REFERENCE
 845           || FUNCTION_ARG_PASS_BY_REFERENCE (cum, TYPE_MODE (gnu_type),
 846                                              gnu_type, 1)
 847 #endif
 848           || targetm.calls.return_in_memory (gnu_type, NULL_TREE)
 849           || (AGGREGATE_TYPE_P (gnu_type)
 850               && (! host_integerp (TYPE_SIZE (gnu_type), 1)
 851                   || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 852                                            8 * TYPE_ALIGN (gnu_type)))));
 853 }
 854
 855 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 856    it should be passed by reference. */
 857
 858 int
 859 must_pass_by_ref (tree gnu_type)
 860 {
 861   /* We pass only unconstrained objects, those required by the language
 862      to be passed by reference, and objects of variable size.  The latter
 863      is more efficient, avoids problems with variable size temporaries,
 864      and does not produce compatibility problems with C, since C does
 865      not have such objects.  */
 866   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 867           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 868           || (TYPE_SIZE (gnu_type) != 0
 869               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 870 }
 871
 872 /* This function is called by the front end to enumerate all the supported
 873    modes for the machine.  We pass a function which is called back with
 874    the following integer parameters:
 875
 876    FLOAT_P      nonzero if this represents a floating-point mode
 877    COMPLEX_P    nonzero is this represents a complex mode
 878    COUNT        count of number of items, nonzero for vector mode
 879    PRECISION    number of bits in data representation
 880    MANTISSA     number of bits in mantissa, if FP and known, else zero.
 881    SIZE         number of bits used to store data
 882    ALIGN        number of bits to which mode is aligned.  */
 883
 884 void
 885 enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
 886 {
 887   enum machine_mode i;
 888
 889   for (i = 0; i < NUM_MACHINE_MODES; i++)
 890     {
 891       enum machine_mode j;
 892       bool float_p = 0;
 893       bool complex_p = 0;
 894       bool vector_p = 0;
 895       bool skip_p = 0;
 896       int mantissa = 0;
 897       enum machine_mode inner_mode = i;
 898
 899       switch (GET_MODE_CLASS (i))
 900         {
 901         case MODE_INT:
 902           break;
 903         case MODE_FLOAT:
 904           float_p = 1;
 905           break;
 906         case MODE_COMPLEX_INT:
 907           complex_p = 1;
 908           inner_mode = GET_MODE_INNER (i);
 909           break;
 910         case MODE_COMPLEX_FLOAT:
 911           float_p = 1;
 912           complex_p = 1;
 913           inner_mode = GET_MODE_INNER (i);
 914           break;
 915         case MODE_VECTOR_INT:
 916           vector_p = 1;
 917           inner_mode = GET_MODE_INNER (i);
 918           break;
 919         case MODE_VECTOR_FLOAT:
 920           float_p = 1;
 921           vector_p = 1;
 922           inner_mode = GET_MODE_INNER (i);
 923           break;
 924         default:
 925           skip_p = 1;
 926         }
 927
 928       /* Skip this mode if it's one the front end doesn't need to know about
 929          (e.g., the CC modes) or if there is no add insn for that mode (or
 930          any wider mode), meaning it is not supported by the hardware.  If
 931          this a complex or vector mode, we care about the inner mode.  */
 932       for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
 933         if (add_optab->handlers[j].insn_code != CODE_FOR_nothing)
 934           break;
 935
 936       if (float_p)
 937         {
 938           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 939
 940           mantissa = fmt->p * fmt->log2_b;
 941         }
 942
 943       if (!skip_p && j != VOIDmode)
 944         (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
 945               GET_MODE_BITSIZE (i), mantissa,
 946               GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
 947     }
 948 }
 949
 950 int
 951 fp_prec_to_size (int prec)
 952 {
 953   enum machine_mode mode;
 954
 955   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 956        mode = GET_MODE_WIDER_MODE (mode))
 957     if (GET_MODE_PRECISION (mode) == prec)
 958       return GET_MODE_BITSIZE (mode);
 959
 960   abort ();
 961 }
 962
 963 int
 964 fp_size_to_prec (int size)
 965 {
 966   enum machine_mode mode;
 967
 968   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 969        mode = GET_MODE_WIDER_MODE (mode))
 970     if (GET_MODE_BITSIZE (mode) == size)
 971       return GET_MODE_PRECISION (mode);
 972
 973   abort ();
 974 }
 975