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