gcc/ada/misc.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                 M I S C                                  *
   6  *                                                                          *
   7  *                           C Implementation File                          *
   8  *                                                                          *
   9  *                                                                          *
  10  *          Copyright (C) 1992-2002 Free Software Foundation, Inc.          *
  11  *                                                                          *
  12  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  13  * terms of the  GNU General Public License as published  by the Free Soft- *
  14  * ware  Foundation;  either version 2,  or (at your option) any later ver- *
  15  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  16  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  17  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  18  * for  more details.  You should have  received  a copy of the GNU General *
  19  * Public License  distributed with GNAT;  see file COPYING.  If not, write *
  20  * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
  21  * MA 02111-1307, USA.                                                      *
  22  *                                                                          *
  23  * As a  special  exception,  if you  link  this file  with other  files to *
  24  * produce an executable,  this file does not by itself cause the resulting *
  25  * executable to be covered by the GNU General Public License. This except- *
  26  * ion does not  however invalidate  any other reasons  why the  executable *
  27  * file might be covered by the  GNU Public License.                        *
  28  *                                                                          *
  29  * GNAT was originally developed  by the GNAT team at  New York University. *
  30  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  31  *                                                                          *
  32  ****************************************************************************/
  33
  34 /* This file contains parts of the compiler that are required for interfacing
  35    with GCC but otherwise do nothing and parts of Gigi that need to know
  36    about RTL.  */
  37
  38 #include "config.h"
  39 #include "system.h"
  40 #include "coretypes.h"
  41 #include "tm.h"
  42 #include "tree.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
  63 #include "ada.h"
  64 #include "types.h"
  65 #include "atree.h"
  66 #include "elists.h"
  67 #include "namet.h"
  68 #include "nlists.h"
  69 #include "stringt.h"
  70 #include "uintp.h"
  71 #include "fe.h"
  72 #include "sinfo.h"
  73 #include "einfo.h"
  74 #include "ada-tree.h"
  75 #include "gigi.h"
  76 #include "adadecode.h"
  77 #include "opts.h"
  78 #include "options.h"
  79
  80 extern FILE *asm_out_file;
  81 extern int save_argc;
  82 extern char **save_argv;
  83
  84 static size_t gnat_tree_size            PARAMS ((enum tree_code));
  85 static bool gnat_init                   PARAMS ((void));
  86 static int gnat_init_options            PARAMS ((void));
  87 static int gnat_handle_option (size_t scode, const char *arg, int value);
  88 static HOST_WIDE_INT gnat_get_alias_set PARAMS ((tree));
  89 static void gnat_print_decl             PARAMS ((FILE *, tree, int));
  90 static void gnat_print_type             PARAMS ((FILE *, tree, int));
  91 static const char *gnat_printable_name  PARAMS  ((tree, int));
  92 static tree gnat_eh_runtime_type        PARAMS ((tree));
  93 static int gnat_eh_type_covers          PARAMS ((tree, tree));
  94 static void gnat_parse_file             PARAMS ((int));
  95 static rtx gnat_expand_expr             PARAMS ((tree, rtx, enum machine_mode,
  96                                                  int));
  97
  98 /* Structure giving our language-specific hooks.  */
  99
 100 #undef  LANG_HOOKS_NAME
 101 #define LANG_HOOKS_NAME                 "GNU Ada"
 102 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 103 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 104 #undef  LANG_HOOKS_TREE_SIZE
 105 #define LANG_HOOKS_TREE_SIZE            gnat_tree_size
 106 #undef  LANG_HOOKS_INIT
 107 #define LANG_HOOKS_INIT                 gnat_init
 108 #undef  LANG_HOOKS_INIT_OPTIONS
 109 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 110 #undef  LANG_HOOKS_HANDLE_OPTION
 111 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
 112 #undef LANG_HOOKS_PARSE_FILE
 113 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 114 #undef LANG_HOOKS_HONOR_READONLY
 115 #define LANG_HOOKS_HONOR_READONLY       1
 116 #undef LANG_HOOKS_FINISH_INCOMPLETE_DECL
 117 #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
 118 #undef LANG_HOOKS_GET_ALIAS_SET
 119 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 120 #undef LANG_HOOKS_EXPAND_EXPR
 121 #define LANG_HOOKS_EXPAND_EXPR          gnat_expand_expr
 122 #undef LANG_HOOKS_MARK_ADDRESSABLE
 123 #define LANG_HOOKS_MARK_ADDRESSABLE     gnat_mark_addressable
 124 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
 125 #define LANG_HOOKS_TRUTHVALUE_CONVERSION gnat_truthvalue_conversion
 126 #undef LANG_HOOKS_PRINT_DECL
 127 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 128 #undef LANG_HOOKS_PRINT_TYPE
 129 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 130 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
 131 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 132 #undef LANG_HOOKS_TYPE_FOR_MODE
 133 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 134 #undef LANG_HOOKS_TYPE_FOR_SIZE
 135 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 136 #undef LANG_HOOKS_SIGNED_TYPE
 137 #define LANG_HOOKS_SIGNED_TYPE          gnat_signed_type
 138 #undef LANG_HOOKS_UNSIGNED_TYPE
 139 #define LANG_HOOKS_UNSIGNED_TYPE        gnat_unsigned_type
 140 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 141 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gnat_signed_or_unsigned_type
 142
 143 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 144
 145 /* Tables describing GCC tree codes used only by GNAT.
 146
 147    Table indexed by tree code giving a string containing a character
 148    classifying the tree code.  Possibilities are
 149    t, d, s, c, r, <, 1 and 2.  See cp-tree.def for details.  */
 150
 151 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 152
 153 const char tree_code_type[] = {
 154 #include "tree.def"
 155   'x',
 156 #include "ada-tree.def"
 157 };
 158 #undef DEFTREECODE
 159
 160 /* Table indexed by tree code giving number of expression
 161    operands beyond the fixed part of the node structure.
 162    Not used for types or decls.  */
 163
 164 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 165
 166 const unsigned char tree_code_length[] = {
 167 #include "tree.def"
 168   0,
 169 #include "ada-tree.def"
 170 };
 171 #undef DEFTREECODE
 172
 173 /* Names of tree components.
 174    Used for printing out the tree and error messages.  */
 175 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 176
 177 const char *const tree_code_name[] = {
 178 #include "tree.def"
 179   "@@dummy",
 180 #include "ada-tree.def"
 181 };
 182 #undef DEFTREECODE
 183
 184 /* gnat standard argc argv */
 185
 186 extern int gnat_argc;
 187 extern char **gnat_argv;
 188
 189 static void internal_error_function     PARAMS ((const char *, va_list *));
 190 static void gnat_adjust_rli             PARAMS ((record_layout_info));
 191 \f
 192 /* Declare functions we use as part of startup.  */
 193 extern void __gnat_initialize   PARAMS((void));
 194 extern void adainit             PARAMS((void));
 195 extern void _ada_gnat1drv       PARAMS((void));
 196
 197 /* The parser for the language.  For us, we process the GNAT tree.  */
 198
 199 static void
 200 gnat_parse_file (set_yydebug)
 201      int set_yydebug ATTRIBUTE_UNUSED;
 202 {
 203   /* call the target specific initializations */
 204   __gnat_initialize();
 205
 206   /* Call the front-end elaboration procedures */
 207   adainit ();
 208
 209   immediate_size_expand = 1;
 210
 211   /* Call the front end */
 212   _ada_gnat1drv ();
 213 }
 214
 215 /* Decode all the language specific options that cannot be decoded by GCC.
 216    The option decoding phase of GCC calls this routine on the flags that
 217    it cannot decode.  This routine returns the number of consecutive arguments
 218    from ARGV that it successfully decoded; 0 indicates failure.  */
 219
 220 static int
 221 gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
 222 {
 223   const struct cl_option *option = &cl_options[scode];
 224   enum opt_code code = (enum opt_code) scode;
 225   char *q;
 226   int i;
 227
 228   /* Ignore file names.  */
 229   if (code == N_OPTS)
 230       return 1;
 231
 232   if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
 233     {
 234       error ("missing argument to \"-%s\"", option->opt_text);
 235       return 1;
 236     }
 237
 238   switch (code)
 239     {
 240     default:
 241       abort();
 242
 243     case OPT_I:
 244       q = xmalloc (sizeof("-I") + strlen (arg));
 245       strcpy (q, "-I");
 246       strcat (q, arg);
 247       gnat_argv[gnat_argc] = q;
 248       gnat_argc++;
 249       break;
 250
 251     case OPT_Wall:
 252       /* All front ends are expected to accept this.  */
 253       break;
 254
 255     case OPT_fRTS:
 256       gnat_argv[gnat_argc] = xstrdup ("-fRTS");
 257       gnat_argc++;
 258       break;
 259
 260     case OPT_gant:
 261       warning ("`-gnat' misspelled as `-gant'");
 262       break;
 263
 264     case OPT_gnat:
 265       /* Recopy the switches without the 'gnat' prefix */
 266       gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2);
 267       gnat_argv[gnat_argc][0] = '-';
 268       strcpy (gnat_argv[gnat_argc] + 1, arg);
 269       gnat_argc++;
 270
 271       if (arg[0] == 'O')
 272         for (i = 1; i < save_argc - 1; i++)
 273           if (!strncmp (save_argv[i], "-gnatO", 6))
 274             if (save_argv[++i][0] != '-')
 275               {
 276                 /* Preserve output filename as GCC doesn't save it for GNAT. */
 277                 gnat_argv[gnat_argc] = save_argv[i];
 278                 gnat_argc++;
 279                 break;
 280               }
 281       break;
 282     }
 283
 284   return 1;
 285 }
 286
 287 /* Initialize for option processing.  */
 288
 289 static int
 290 gnat_init_options ()
 291 {
 292   /* Initialize gnat_argv with save_argv size */
 293   gnat_argv = (char **) xmalloc ((save_argc + 1) * sizeof (gnat_argv[0]));
 294   gnat_argv[0] = save_argv[0];     /* name of the command */
 295   gnat_argc = 1;
 296
 297   return CL_ADA;
 298 }
 299
 300 /* Here is the function to handle the compiler error processing in GCC.  */
 301
 302 static void
 303 internal_error_function (msgid, ap)
 304      const char *msgid;
 305      va_list *ap;
 306 {
 307   char buffer[1000];            /* Assume this is big enough.  */
 308   char *p;
 309   String_Template temp;
 310   Fat_Pointer fp;
 311
 312   vsprintf (buffer, msgid, *ap);
 313
 314   /* Go up to the first newline.  */
 315   for (p = buffer; *p != 0; p++)
 316     if (*p == '\n')
 317       {
 318         *p = '\0';
 319         break;
 320       }
 321
 322   temp.Low_Bound = 1, temp.High_Bound = strlen (buffer);
 323   fp.Array = buffer, fp.Bounds = &temp;
 324
 325   Current_Error_Node = error_gnat_node;
 326   Compiler_Abort (fp, -1);
 327 }
 328
 329 /* Langhook for tree_size: determine size of our 'x' and 'c' nodes.  */
 330 static size_t
 331 gnat_tree_size (enum tree_code code)
 332 {
 333   switch (code)
 334     {
 335     case GNAT_LOOP_ID:  return sizeof (struct tree_loop_id);
 336     default:
 337       abort ();
 338     }
 339   /* NOTREACHED */
 340 }
 341
 342 /* Perform all the initialization steps that are language-specific.  */
 343
 344 static bool
 345 gnat_init ()
 346 {
 347   /* Performs whatever initialization steps needed by the language-dependent
 348      lexical analyzer.
 349
 350      Define the additional tree codes here.  This isn't the best place to put
 351      it, but it's where g++ does it.  */
 352
 353   gnat_init_decl_processing ();
 354
 355   /* Add the input filename as the last argument.  */
 356   gnat_argv[gnat_argc] = (char *) main_input_filename;
 357   gnat_argc++;
 358   gnat_argv[gnat_argc] = 0;
 359
 360   global_dc->internal_error = &internal_error_function;
 361
 362   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 363   internal_reference_types ();
 364
 365   set_lang_adjust_rli (gnat_adjust_rli);
 366
 367   return true;
 368 }
 369
 370 /* If we are using the GCC mechanism for to process exception handling, we
 371    have to register the personality routine for Ada and to initialize
 372    various language dependent hooks.  */
 373
 374 void
 375 gnat_init_gcc_eh ()
 376 {
 377   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 378      though. This could for instance lead to the emission of tables with
 379      references to symbols (such as the Ada eh personality routine) within
 380      libraries we won't link against.  */
 381   if (No_Exception_Handlers_Set ())
 382     return;
 383
 384   eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality");
 385   lang_eh_type_covers = gnat_eh_type_covers;
 386   lang_eh_runtime_type = gnat_eh_runtime_type;
 387   flag_exceptions = 1;
 388
 389   init_eh ();
 390 #ifdef DWARF2_UNWIND_INFO
 391   if (dwarf2out_do_frame ())
 392     dwarf2out_frame_init ();
 393 #endif
 394 }
 395
 396 /* Hooks for print-tree.c:  */
 397
 398 static void
 399 gnat_print_decl (file, node, indent)
 400      FILE *file;
 401      tree node;
 402      int indent;
 403 {
 404   switch (TREE_CODE (node))
 405     {
 406     case CONST_DECL:
 407       print_node (file, "const_corresponding_var",
 408                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 409       break;
 410
 411     case FIELD_DECL:
 412       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 413                   indent + 4);
 414       break;
 415
 416     default:
 417       break;
 418     }
 419 }
 420
 421 static void
 422 gnat_print_type (file, node, indent)
 423      FILE *file;
 424      tree node;
 425      int indent;
 426 {
 427   switch (TREE_CODE (node))
 428     {
 429     case FUNCTION_TYPE:
 430       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 431       break;
 432
 433     case ENUMERAL_TYPE:
 434       print_node (file, "RM size", TYPE_RM_SIZE_ENUM (node), indent + 4);
 435       break;
 436
 437     case INTEGER_TYPE:
 438       if (TYPE_MODULAR_P (node))
 439         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 440       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 441         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 442                     indent + 4);
 443       else if (TYPE_VAX_FLOATING_POINT_P (node))
 444         ;
 445       else
 446         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 447
 448       print_node (file, "RM size", TYPE_RM_SIZE_INT (node), indent + 4);
 449       break;
 450
 451     case ARRAY_TYPE:
 452       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 453       break;
 454
 455     case RECORD_TYPE:
 456       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 457         print_node (file, "unconstrained array",
 458                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 459       else
 460         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 461       break;
 462
 463     case UNION_TYPE:
 464     case QUAL_UNION_TYPE:
 465       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 466       break;
 467
 468     default:
 469       break;
 470     }
 471 }
 472
 473 static const char *
 474 gnat_printable_name (decl, verbosity)
 475      tree decl;
 476      int verbosity ATTRIBUTE_UNUSED;
 477 {
 478   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 479   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 480
 481   __gnat_decode (coded_name, ada_name, 0);
 482
 483   return (const char *) ada_name;
 484 }
 485
 486 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 487    here are TRANSFORM_EXPR, ALLOCATE_EXPR, USE_EXPR and NULL_EXPR.  */
 488
 489 static rtx
 490 gnat_expand_expr (exp, target, tmode, modifier)
 491      tree exp;
 492      rtx target;
 493      enum machine_mode tmode;
 494      int modifier;  /* Actually an enum expand_modifier.  */
 495 {
 496   tree type = TREE_TYPE (exp);
 497   tree new;
 498   rtx result;
 499
 500   /* Update EXP to be the new expression to expand.  */
 501
 502   switch (TREE_CODE (exp))
 503     {
 504     case TRANSFORM_EXPR:
 505       gnat_to_code (TREE_COMPLEXITY (exp));
 506       return const0_rtx;
 507       break;
 508
 509     case NULL_EXPR:
 510       expand_expr (TREE_OPERAND (exp, 0), const0_rtx, VOIDmode, 0);
 511
 512       /* We aren't going to be doing anything with this memory, but allocate
 513          it anyway.  If it's variable size, make a bogus address.  */
 514       if (! host_integerp (TYPE_SIZE_UNIT (type), 1))
 515         result = gen_rtx_MEM (BLKmode, virtual_stack_vars_rtx);
 516       else
 517         result = assign_temp (type, 0, TREE_ADDRESSABLE (exp), 1);
 518
 519       return result;
 520
 521     case ALLOCATE_EXPR:
 522       return
 523         allocate_dynamic_stack_space
 524           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 525                         EXPAND_NORMAL),
 526            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 527
 528     case USE_EXPR:
 529       if (target != const0_rtx)
 530         gigi_abort (203);
 531
 532       /* First write a volatile ASM_INPUT to prevent anything from being
 533          moved.  */
 534       result = gen_rtx_ASM_INPUT (VOIDmode, "");
 535       MEM_VOLATILE_P (result) = 1;
 536       emit_insn (result);
 537
 538       result = expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, VOIDmode,
 539                             modifier);
 540       emit_insn (gen_rtx_USE (VOIDmode, result));
 541       return target;
 542
 543     case GNAT_NOP_EXPR:
 544       return expand_expr (build1 (NOP_EXPR, type, TREE_OPERAND (exp, 0)),
 545                           target, tmode, modifier);
 546
 547     case UNCONSTRAINED_ARRAY_REF:
 548       /* If we are evaluating just for side-effects, just evaluate our
 549          operand.  Otherwise, abort since this code should never appear
 550          in a tree to be evaluated (objects aren't unconstrained).  */
 551       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 552         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 553                             VOIDmode, modifier);
 554
 555       /* ... fall through ... */
 556
 557     default:
 558       gigi_abort (201);
 559     }
 560
 561   return expand_expr (new, target, tmode, modifier);
 562 }
 563
 564 /* Adjusts the RLI used to layout a record after all the fields have been
 565    added.  We only handle the packed case and cause it to use the alignment
 566    that will pad the record at the end.  */
 567
 568 static void
 569 gnat_adjust_rli (rli)
 570      record_layout_info rli ATTRIBUTE_UNUSED;
 571 {
 572   /* This function has no actual effect; record_align should already
 573      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 574 }
 575
 576 /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code.  */
 577
 578 tree
 579 make_transform_expr (gnat_node)
 580      Node_Id gnat_node;
 581 {
 582   tree gnu_result = build (TRANSFORM_EXPR, void_type_node);
 583
 584   TREE_SIDE_EFFECTS (gnu_result) = 1;
 585   TREE_COMPLEXITY (gnu_result) = gnat_node;
 586   return gnu_result;
 587 }
 588 \f
 589 /* Update the setjmp buffer BUF with the current stack pointer.  We assume
 590    here that a __builtin_setjmp was done to BUF.  */
 591
 592 void
 593 update_setjmp_buf (buf)
 594      tree buf;
 595 {
 596   enum machine_mode sa_mode = Pmode;
 597   rtx stack_save;
 598
 599 #ifdef HAVE_save_stack_nonlocal
 600   if (HAVE_save_stack_nonlocal)
 601     sa_mode = insn_data[(int) CODE_FOR_save_stack_nonlocal].operand[0].mode;
 602 #endif
 603 #ifdef STACK_SAVEAREA_MODE
 604   sa_mode = STACK_SAVEAREA_MODE (SAVE_NONLOCAL);
 605 #endif
 606
 607   stack_save
 608     = gen_rtx_MEM (sa_mode,
 609                    memory_address
 610                    (sa_mode,
 611                     plus_constant (expand_expr
 612                                    (build_unary_op (ADDR_EXPR, NULL_TREE, buf),
 613                                     NULL_RTX, VOIDmode, 0),
 614                                    2 * GET_MODE_SIZE (Pmode))));
 615
 616 #ifdef HAVE_setjmp
 617   if (HAVE_setjmp)
 618     emit_insn (gen_setjmp ());
 619 #endif
 620
 621   emit_stack_save (SAVE_NONLOCAL, &stack_save, NULL_RTX);
 622 }
 623 \f
 624 /* These routines are used in conjunction with GCC exception handling.  */
 625
 626 /* Map compile-time to run-time tree for GCC exception handling scheme.  */
 627
 628 static tree
 629 gnat_eh_runtime_type (type)
 630      tree type;
 631 {
 632   return type;
 633 }
 634
 635 /* Return true if type A catches type B. Callback for flow analysis from
 636    the exception handling part of the back-end.  */
 637
 638 static int
 639 gnat_eh_type_covers (a, b)
 640      tree a, b;
 641 {
 642   /* a catches b if they represent the same exception id or if a
 643      is an "others".
 644
 645      ??? integer_zero_node for "others" is hardwired in too many places
 646      currently.  */
 647   return (a == b || a == integer_zero_node);
 648 }
 649 \f
 650 /* See if DECL has an RTL that is indirect via a pseudo-register or a
 651    memory location and replace it with an indirect reference if so.
 652    This improves the debugger's ability to display the value.  */
 653
 654 void
 655 adjust_decl_rtl (decl)
 656      tree decl;
 657 {
 658   tree new_type;
 659
 660   /* If this decl is already indirect, don't do anything.  This should
 661      mean that the decl cannot be indirect, but there's no point in
 662      adding an abort to check that.  */
 663   if (TREE_CODE (decl) != CONST_DECL
 664       && ! DECL_BY_REF_P (decl)
 665       && (GET_CODE (DECL_RTL (decl)) == MEM
 666           && (GET_CODE (XEXP (DECL_RTL (decl), 0)) == MEM
 667               || (GET_CODE (XEXP (DECL_RTL (decl), 0)) == REG
 668                   && (REGNO (XEXP (DECL_RTL (decl), 0))
 669                       > LAST_VIRTUAL_REGISTER))))
 670       /* We can't do this if the reference type's mode is not the same
 671          as the current mode, which means this may not work on mixed 32/64
 672          bit systems.  */
 673       && (new_type = build_reference_type (TREE_TYPE (decl))) != 0
 674       && TYPE_MODE (new_type) == GET_MODE (XEXP (DECL_RTL (decl), 0))
 675       /* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
 676          is also an indirect and of the same mode and if the object is
 677          readonly, the latter condition because we don't want to upset the
 678          handling of CICO_LIST.  */
 679       && (TREE_CODE (decl) != PARM_DECL
 680           || (GET_CODE (DECL_INCOMING_RTL (decl)) == MEM
 681               && (TYPE_MODE (new_type)
 682                   == GET_MODE (XEXP (DECL_INCOMING_RTL (decl), 0)))
 683               && TREE_READONLY (decl))))
 684     {
 685       new_type
 686         = build_qualified_type (new_type,
 687                                 (TYPE_QUALS (new_type) | TYPE_QUAL_CONST));
 688
 689       DECL_POINTS_TO_READONLY_P (decl) = TREE_READONLY (decl);
 690       DECL_BY_REF_P (decl) = 1;
 691       SET_DECL_RTL (decl, XEXP (DECL_RTL (decl), 0));
 692       TREE_TYPE (decl) = new_type;
 693       DECL_MODE (decl) = TYPE_MODE (new_type);
 694       DECL_ALIGN (decl) = TYPE_ALIGN (new_type);
 695       DECL_SIZE (decl) = TYPE_SIZE (new_type);
 696
 697       if (TREE_CODE (decl) == PARM_DECL)
 698         DECL_INCOMING_RTL (decl) = XEXP (DECL_INCOMING_RTL (decl), 0);
 699
 700       /* If DECL_INITIAL was set, it should be updated to show that
 701          the decl is initialized to the address of that thing.
 702          Otherwise, just set it to the address of this decl.
 703          It needs to be set so that GCC does not think the decl is
 704          unused.  */
 705       DECL_INITIAL (decl)
 706         = build1 (ADDR_EXPR, new_type,
 707                   DECL_INITIAL (decl) != 0 ? DECL_INITIAL (decl) : decl);
 708     }
 709 }
 710 \f
 711 /* Record the current code position in GNAT_NODE.  */
 712
 713 void
 714 record_code_position (gnat_node)
 715      Node_Id gnat_node;
 716 {
 717   if (global_bindings_p ())
 718     {
 719       /* Make a dummy entry so multiple things at the same location don't
 720          end up in the same place.  */
 721       add_pending_elaborations (NULL_TREE, NULL_TREE);
 722       save_gnu_tree (gnat_node, get_elaboration_location (), 1);
 723     }
 724   else
 725     /* Always emit another insn in case marking the last insn
 726        addressable needs some fixups and also for above reason.  */
 727     save_gnu_tree (gnat_node,
 728                    build (RTL_EXPR, void_type_node, NULL_TREE,
 729                           (tree) emit_note (0, NOTE_INSN_DELETED)),
 730                    1);
 731 }
 732
 733 /* Insert the code for GNAT_NODE at the position saved for that node.  */
 734
 735 void
 736 insert_code_for (gnat_node)
 737      Node_Id gnat_node;
 738 {
 739   if (global_bindings_p ())
 740     {
 741       push_pending_elaborations ();
 742       gnat_to_code (gnat_node);
 743       Check_Elaboration_Code_Allowed (gnat_node);
 744       insert_elaboration_list (get_gnu_tree (gnat_node));
 745       pop_pending_elaborations ();
 746     }
 747   else
 748     {
 749       rtx insns;
 750
 751       do_pending_stack_adjust ();
 752       start_sequence ();
 753       mark_all_temps_used ();
 754       gnat_to_code (gnat_node);
 755       do_pending_stack_adjust ();
 756       insns = get_insns ();
 757       end_sequence ();
 758       emit_insn_after (insns, RTL_EXPR_RTL (get_gnu_tree (gnat_node)));
 759     }
 760 }
 761
 762 /* Get the alias set corresponding to a type or expression.  */
 763
 764 static HOST_WIDE_INT
 765 gnat_get_alias_set (type)
 766      tree type;
 767 {
 768   /* If this is a padding type, use the type of the first field.  */
 769   if (TREE_CODE (type) == RECORD_TYPE
 770       && TYPE_IS_PADDING_P (type))
 771     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 772
 773   /* If the type is an unconstrained array, use the type of the
 774      self-referential array we make.  */
 775   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 776     return
 777       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 778
 779
 780   return -1;
 781 }
 782
 783 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 784    default.  */
 785
 786 int
 787 default_pass_by_ref (gnu_type)
 788      tree gnu_type;
 789 {
 790   CUMULATIVE_ARGS cum;
 791
 792   INIT_CUMULATIVE_ARGS (cum, NULL_TREE, NULL_RTX, 0);
 793
 794   /* We pass aggregates by reference if they are sufficiently large.  The
 795      choice of constant here is somewhat arbitrary.  We also pass by
 796      reference if the target machine would either pass or return by
 797      reference.  Strictly speaking, we need only check the return if this
 798      is an In Out parameter, but it's probably best to err on the side of
 799      passing more things by reference.  */
 800   return (0
 801 #ifdef FUNCTION_ARG_PASS_BY_REFERENCE
 802           || FUNCTION_ARG_PASS_BY_REFERENCE (cum, TYPE_MODE (gnu_type),
 803                                              gnu_type, 1)
 804 #endif
 805           || RETURN_IN_MEMORY (gnu_type)
 806           || (AGGREGATE_TYPE_P (gnu_type)
 807               && (! host_integerp (TYPE_SIZE (gnu_type), 1)
 808                   || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 809                                            8 * TYPE_ALIGN (gnu_type)))));
 810 }
 811
 812 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 813    it should be passed by reference. */
 814
 815 int
 816 must_pass_by_ref (gnu_type)
 817      tree gnu_type;
 818 {
 819   /* We pass only unconstrained objects, those required by the language
 820      to be passed by reference, and objects of variable size.  The latter
 821      is more efficient, avoids problems with variable size temporaries,
 822      and does not produce compatibility problems with C, since C does
 823      not have such objects.  */
 824   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 825           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 826           || (TYPE_SIZE (gnu_type) != 0
 827               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 828 }
 829
 830 /* This function returns the version of GCC being used.  Here it's GCC 3.  */
 831
 832 int
 833 gcc_version ()
 834 {
 835   return 3;
 836 }