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 "aoptions.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     case OPT_I:
 241       q = xmalloc (sizeof("-I") + strlen (arg));
 242       strcpy (q, "-I");
 243       strcat (q, arg);
 244       gnat_argv[gnat_argc] = q;
 245       gnat_argc++;
 246       break;
 247
 248     case OPT_fRTS:
 249       gnat_argv[gnat_argc] = "-fRTS";
 250       gnat_argc++;
 251       break;
 252
 253     case OPT_gant:
 254       warning ("`-gnat' misspelled as `-gant'");
 255       break;
 256
 257     case OPT_gnat:
 258       /* Recopy the switches without the 'gnat' prefix */
 259       gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2);
 260       gnat_argv[gnat_argc][0] = '-';
 261       strcpy (gnat_argv[gnat_argc] + 1, arg);
 262       gnat_argc++;
 263
 264       if (arg[0] == 'O')
 265         for (i = 1; i < save_argc - 1; i++)
 266           if (!strncmp (save_argv[i], "-gnatO", 6))
 267             if (save_argv[++i][0] != '-')
 268               {
 269                 /* Preserve output filename as GCC doesn't save it for GNAT. */
 270                 gnat_argv[gnat_argc] = save_argv[i];
 271                 gnat_argc++;
 272                 break;
 273               }
 274       break;
 275     }
 276
 277   return 1;
 278 }
 279
 280 /* Initialize for option processing.  */
 281
 282 static int
 283 gnat_init_options ()
 284 {
 285   /* Initialize gnat_argv with save_argv size */
 286   gnat_argv = (char **) xmalloc ((save_argc + 1) * sizeof (gnat_argv[0]));
 287   gnat_argv[0] = save_argv[0];     /* name of the command */
 288   gnat_argc = 1;
 289
 290   return 0;
 291 }
 292
 293 /* Here is the function to handle the compiler error processing in GCC.  */
 294
 295 static void
 296 internal_error_function (msgid, ap)
 297      const char *msgid;
 298      va_list *ap;
 299 {
 300   char buffer[1000];            /* Assume this is big enough.  */
 301   char *p;
 302   String_Template temp;
 303   Fat_Pointer fp;
 304
 305   vsprintf (buffer, msgid, *ap);
 306
 307   /* Go up to the first newline.  */
 308   for (p = buffer; *p != 0; p++)
 309     if (*p == '\n')
 310       {
 311         *p = '\0';
 312         break;
 313       }
 314
 315   temp.Low_Bound = 1, temp.High_Bound = strlen (buffer);
 316   fp.Array = buffer, fp.Bounds = &temp;
 317
 318   Current_Error_Node = error_gnat_node;
 319   Compiler_Abort (fp, -1);
 320 }
 321
 322 /* Langhook for tree_size: determine size of our 'x' and 'c' nodes.  */
 323 static size_t
 324 gnat_tree_size (enum tree_code code)
 325 {
 326   switch (code)
 327     {
 328     case GNAT_LOOP_ID:  return sizeof (struct tree_loop_id);
 329     default:
 330       abort ();
 331     }
 332   /* NOTREACHED */
 333 }
 334
 335 /* Perform all the initialization steps that are language-specific.  */
 336
 337 static bool
 338 gnat_init ()
 339 {
 340   /* Performs whatever initialization steps needed by the language-dependent
 341      lexical analyzer.
 342
 343      Define the additional tree codes here.  This isn't the best place to put
 344      it, but it's where g++ does it.  */
 345
 346   gnat_init_decl_processing ();
 347
 348   /* Add the input filename as the last argument.  */
 349   gnat_argv[gnat_argc] = (char *) main_input_filename;
 350   gnat_argc++;
 351   gnat_argv[gnat_argc] = 0;
 352
 353   global_dc->internal_error = &internal_error_function;
 354
 355   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 356   internal_reference_types ();
 357
 358   set_lang_adjust_rli (gnat_adjust_rli);
 359
 360   return true;
 361 }
 362
 363 /* If we are using the GCC mechanism for to process exception handling, we
 364    have to register the personality routine for Ada and to initialize
 365    various language dependent hooks.  */
 366
 367 void
 368 gnat_init_gcc_eh ()
 369 {
 370   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 371      though. This could for instance lead to the emission of tables with
 372      references to symbols (such as the Ada eh personality routine) within
 373      libraries we won't link against.  */
 374   if (No_Exception_Handlers_Set ())
 375     return;
 376
 377   eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality");
 378   lang_eh_type_covers = gnat_eh_type_covers;
 379   lang_eh_runtime_type = gnat_eh_runtime_type;
 380   flag_exceptions = 1;
 381
 382   init_eh ();
 383 #ifdef DWARF2_UNWIND_INFO
 384   if (dwarf2out_do_frame ())
 385     dwarf2out_frame_init ();
 386 #endif
 387 }
 388
 389 /* Hooks for print-tree.c:  */
 390
 391 static void
 392 gnat_print_decl (file, node, indent)
 393      FILE *file;
 394      tree node;
 395      int indent;
 396 {
 397   switch (TREE_CODE (node))
 398     {
 399     case CONST_DECL:
 400       print_node (file, "const_corresponding_var",
 401                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 402       break;
 403
 404     case FIELD_DECL:
 405       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 406                   indent + 4);
 407       break;
 408
 409     default:
 410       break;
 411     }
 412 }
 413
 414 static void
 415 gnat_print_type (file, node, indent)
 416      FILE *file;
 417      tree node;
 418      int indent;
 419 {
 420   switch (TREE_CODE (node))
 421     {
 422     case FUNCTION_TYPE:
 423       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 424       break;
 425
 426     case ENUMERAL_TYPE:
 427       print_node (file, "RM size", TYPE_RM_SIZE_ENUM (node), indent + 4);
 428       break;
 429
 430     case INTEGER_TYPE:
 431       if (TYPE_MODULAR_P (node))
 432         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 433       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 434         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 435                     indent + 4);
 436       else if (TYPE_VAX_FLOATING_POINT_P (node))
 437         ;
 438       else
 439         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 440
 441       print_node (file, "RM size", TYPE_RM_SIZE_INT (node), indent + 4);
 442       break;
 443
 444     case ARRAY_TYPE:
 445       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 446       break;
 447
 448     case RECORD_TYPE:
 449       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 450         print_node (file, "unconstrained array",
 451                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 452       else
 453         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 454       break;
 455
 456     case UNION_TYPE:
 457     case QUAL_UNION_TYPE:
 458       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 459       break;
 460
 461     default:
 462       break;
 463     }
 464 }
 465
 466 static const char *
 467 gnat_printable_name (decl, verbosity)
 468      tree decl;
 469      int verbosity ATTRIBUTE_UNUSED;
 470 {
 471   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 472   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 473
 474   __gnat_decode (coded_name, ada_name, 0);
 475
 476   return (const char *) ada_name;
 477 }
 478
 479 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 480    here are TRANSFORM_EXPR, ALLOCATE_EXPR, USE_EXPR and NULL_EXPR.  */
 481
 482 static rtx
 483 gnat_expand_expr (exp, target, tmode, modifier)
 484      tree exp;
 485      rtx target;
 486      enum machine_mode tmode;
 487      int modifier;  /* Actually an enum expand_modifier.  */
 488 {
 489   tree type = TREE_TYPE (exp);
 490   tree new;
 491   rtx result;
 492
 493   /* Update EXP to be the new expression to expand.  */
 494
 495   switch (TREE_CODE (exp))
 496     {
 497     case TRANSFORM_EXPR:
 498       gnat_to_code (TREE_COMPLEXITY (exp));
 499       return const0_rtx;
 500       break;
 501
 502     case NULL_EXPR:
 503       expand_expr (TREE_OPERAND (exp, 0), const0_rtx, VOIDmode, 0);
 504
 505       /* We aren't going to be doing anything with this memory, but allocate
 506          it anyway.  If it's variable size, make a bogus address.  */
 507       if (! host_integerp (TYPE_SIZE_UNIT (type), 1))
 508         result = gen_rtx_MEM (BLKmode, virtual_stack_vars_rtx);
 509       else
 510         result = assign_temp (type, 0, TREE_ADDRESSABLE (exp), 1);
 511
 512       return result;
 513
 514     case ALLOCATE_EXPR:
 515       return
 516         allocate_dynamic_stack_space
 517           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 518                         EXPAND_NORMAL),
 519            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 520
 521     case USE_EXPR:
 522       if (target != const0_rtx)
 523         gigi_abort (203);
 524
 525       /* First write a volatile ASM_INPUT to prevent anything from being
 526          moved.  */
 527       result = gen_rtx_ASM_INPUT (VOIDmode, "");
 528       MEM_VOLATILE_P (result) = 1;
 529       emit_insn (result);
 530
 531       result = expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, VOIDmode,
 532                             modifier);
 533       emit_insn (gen_rtx_USE (VOIDmode, result));
 534       return target;
 535
 536     case GNAT_NOP_EXPR:
 537       return expand_expr (build1 (NOP_EXPR, type, TREE_OPERAND (exp, 0)),
 538                           target, tmode, modifier);
 539
 540     case UNCONSTRAINED_ARRAY_REF:
 541       /* If we are evaluating just for side-effects, just evaluate our
 542          operand.  Otherwise, abort since this code should never appear
 543          in a tree to be evaluated (objects aren't unconstrained).  */
 544       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 545         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 546                             VOIDmode, modifier);
 547
 548       /* ... fall through ... */
 549
 550     default:
 551       gigi_abort (201);
 552     }
 553
 554   return expand_expr (new, target, tmode, modifier);
 555 }
 556
 557 /* Adjusts the RLI used to layout a record after all the fields have been
 558    added.  We only handle the packed case and cause it to use the alignment
 559    that will pad the record at the end.  */
 560
 561 static void
 562 gnat_adjust_rli (rli)
 563      record_layout_info rli ATTRIBUTE_UNUSED;
 564 {
 565   /* This function has no actual effect; record_align should already
 566      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 567 }
 568
 569 /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code.  */
 570
 571 tree
 572 make_transform_expr (gnat_node)
 573      Node_Id gnat_node;
 574 {
 575   tree gnu_result = build (TRANSFORM_EXPR, void_type_node);
 576
 577   TREE_SIDE_EFFECTS (gnu_result) = 1;
 578   TREE_COMPLEXITY (gnu_result) = gnat_node;
 579   return gnu_result;
 580 }
 581 \f
 582 /* Update the setjmp buffer BUF with the current stack pointer.  We assume
 583    here that a __builtin_setjmp was done to BUF.  */
 584
 585 void
 586 update_setjmp_buf (buf)
 587      tree buf;
 588 {
 589   enum machine_mode sa_mode = Pmode;
 590   rtx stack_save;
 591
 592 #ifdef HAVE_save_stack_nonlocal
 593   if (HAVE_save_stack_nonlocal)
 594     sa_mode = insn_data[(int) CODE_FOR_save_stack_nonlocal].operand[0].mode;
 595 #endif
 596 #ifdef STACK_SAVEAREA_MODE
 597   sa_mode = STACK_SAVEAREA_MODE (SAVE_NONLOCAL);
 598 #endif
 599
 600   stack_save
 601     = gen_rtx_MEM (sa_mode,
 602                    memory_address
 603                    (sa_mode,
 604                     plus_constant (expand_expr
 605                                    (build_unary_op (ADDR_EXPR, NULL_TREE, buf),
 606                                     NULL_RTX, VOIDmode, 0),
 607                                    2 * GET_MODE_SIZE (Pmode))));
 608
 609 #ifdef HAVE_setjmp
 610   if (HAVE_setjmp)
 611     emit_insn (gen_setjmp ());
 612 #endif
 613
 614   emit_stack_save (SAVE_NONLOCAL, &stack_save, NULL_RTX);
 615 }
 616 \f
 617 /* These routines are used in conjunction with GCC exception handling.  */
 618
 619 /* Map compile-time to run-time tree for GCC exception handling scheme.  */
 620
 621 static tree
 622 gnat_eh_runtime_type (type)
 623      tree type;
 624 {
 625   return type;
 626 }
 627
 628 /* Return true if type A catches type B. Callback for flow analysis from
 629    the exception handling part of the back-end.  */
 630
 631 static int
 632 gnat_eh_type_covers (a, b)
 633      tree a, b;
 634 {
 635   /* a catches b if they represent the same exception id or if a
 636      is an "others".
 637
 638      ??? integer_zero_node for "others" is hardwired in too many places
 639      currently.  */
 640   return (a == b || a == integer_zero_node);
 641 }
 642 \f
 643 /* See if DECL has an RTL that is indirect via a pseudo-register or a
 644    memory location and replace it with an indirect reference if so.
 645    This improves the debugger's ability to display the value.  */
 646
 647 void
 648 adjust_decl_rtl (decl)
 649      tree decl;
 650 {
 651   tree new_type;
 652
 653   /* If this decl is already indirect, don't do anything.  This should
 654      mean that the decl cannot be indirect, but there's no point in
 655      adding an abort to check that.  */
 656   if (TREE_CODE (decl) != CONST_DECL
 657       && ! DECL_BY_REF_P (decl)
 658       && (GET_CODE (DECL_RTL (decl)) == MEM
 659           && (GET_CODE (XEXP (DECL_RTL (decl), 0)) == MEM
 660               || (GET_CODE (XEXP (DECL_RTL (decl), 0)) == REG
 661                   && (REGNO (XEXP (DECL_RTL (decl), 0))
 662                       > LAST_VIRTUAL_REGISTER))))
 663       /* We can't do this if the reference type's mode is not the same
 664          as the current mode, which means this may not work on mixed 32/64
 665          bit systems.  */
 666       && (new_type = build_reference_type (TREE_TYPE (decl))) != 0
 667       && TYPE_MODE (new_type) == GET_MODE (XEXP (DECL_RTL (decl), 0))
 668       /* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
 669          is also an indirect and of the same mode and if the object is
 670          readonly, the latter condition because we don't want to upset the
 671          handling of CICO_LIST.  */
 672       && (TREE_CODE (decl) != PARM_DECL
 673           || (GET_CODE (DECL_INCOMING_RTL (decl)) == MEM
 674               && (TYPE_MODE (new_type)
 675                   == GET_MODE (XEXP (DECL_INCOMING_RTL (decl), 0)))
 676               && TREE_READONLY (decl))))
 677     {
 678       new_type
 679         = build_qualified_type (new_type,
 680                                 (TYPE_QUALS (new_type) | TYPE_QUAL_CONST));
 681
 682       DECL_POINTS_TO_READONLY_P (decl) = TREE_READONLY (decl);
 683       DECL_BY_REF_P (decl) = 1;
 684       SET_DECL_RTL (decl, XEXP (DECL_RTL (decl), 0));
 685       TREE_TYPE (decl) = new_type;
 686       DECL_MODE (decl) = TYPE_MODE (new_type);
 687       DECL_ALIGN (decl) = TYPE_ALIGN (new_type);
 688       DECL_SIZE (decl) = TYPE_SIZE (new_type);
 689
 690       if (TREE_CODE (decl) == PARM_DECL)
 691         DECL_INCOMING_RTL (decl) = XEXP (DECL_INCOMING_RTL (decl), 0);
 692
 693       /* If DECL_INITIAL was set, it should be updated to show that
 694          the decl is initialized to the address of that thing.
 695          Otherwise, just set it to the address of this decl.
 696          It needs to be set so that GCC does not think the decl is
 697          unused.  */
 698       DECL_INITIAL (decl)
 699         = build1 (ADDR_EXPR, new_type,
 700                   DECL_INITIAL (decl) != 0 ? DECL_INITIAL (decl) : decl);
 701     }
 702 }
 703 \f
 704 /* Record the current code position in GNAT_NODE.  */
 705
 706 void
 707 record_code_position (gnat_node)
 708      Node_Id gnat_node;
 709 {
 710   if (global_bindings_p ())
 711     {
 712       /* Make a dummy entry so multiple things at the same location don't
 713          end up in the same place.  */
 714       add_pending_elaborations (NULL_TREE, NULL_TREE);
 715       save_gnu_tree (gnat_node, get_elaboration_location (), 1);
 716     }
 717   else
 718     /* Always emit another insn in case marking the last insn
 719        addressable needs some fixups and also for above reason.  */
 720     save_gnu_tree (gnat_node,
 721                    build (RTL_EXPR, void_type_node, NULL_TREE,
 722                           (tree) emit_note (0, NOTE_INSN_DELETED)),
 723                    1);
 724 }
 725
 726 /* Insert the code for GNAT_NODE at the position saved for that node.  */
 727
 728 void
 729 insert_code_for (gnat_node)
 730      Node_Id gnat_node;
 731 {
 732   if (global_bindings_p ())
 733     {
 734       push_pending_elaborations ();
 735       gnat_to_code (gnat_node);
 736       Check_Elaboration_Code_Allowed (gnat_node);
 737       insert_elaboration_list (get_gnu_tree (gnat_node));
 738       pop_pending_elaborations ();
 739     }
 740   else
 741     {
 742       rtx insns;
 743
 744       do_pending_stack_adjust ();
 745       start_sequence ();
 746       mark_all_temps_used ();
 747       gnat_to_code (gnat_node);
 748       do_pending_stack_adjust ();
 749       insns = get_insns ();
 750       end_sequence ();
 751       emit_insn_after (insns, RTL_EXPR_RTL (get_gnu_tree (gnat_node)));
 752     }
 753 }
 754
 755 /* Get the alias set corresponding to a type or expression.  */
 756
 757 static HOST_WIDE_INT
 758 gnat_get_alias_set (type)
 759      tree type;
 760 {
 761   /* If this is a padding type, use the type of the first field.  */
 762   if (TREE_CODE (type) == RECORD_TYPE
 763       && TYPE_IS_PADDING_P (type))
 764     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 765
 766   /* If the type is an unconstrained array, use the type of the
 767      self-referential array we make.  */
 768   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 769     return
 770       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 771
 772
 773   return -1;
 774 }
 775
 776 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 777    default.  */
 778
 779 int
 780 default_pass_by_ref (gnu_type)
 781      tree gnu_type;
 782 {
 783   CUMULATIVE_ARGS cum;
 784
 785   INIT_CUMULATIVE_ARGS (cum, NULL_TREE, NULL_RTX, 0);
 786
 787   /* We pass aggregates by reference if they are sufficiently large.  The
 788      choice of constant here is somewhat arbitrary.  We also pass by
 789      reference if the target machine would either pass or return by
 790      reference.  Strictly speaking, we need only check the return if this
 791      is an In Out parameter, but it's probably best to err on the side of
 792      passing more things by reference.  */
 793   return (0
 794 #ifdef FUNCTION_ARG_PASS_BY_REFERENCE
 795           || FUNCTION_ARG_PASS_BY_REFERENCE (cum, TYPE_MODE (gnu_type),
 796                                              gnu_type, 1)
 797 #endif
 798           || RETURN_IN_MEMORY (gnu_type)
 799           || (AGGREGATE_TYPE_P (gnu_type)
 800               && (! host_integerp (TYPE_SIZE (gnu_type), 1)
 801                   || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 802                                            8 * TYPE_ALIGN (gnu_type)))));
 803 }
 804
 805 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 806    it should be passed by reference. */
 807
 808 int
 809 must_pass_by_ref (gnu_type)
 810      tree gnu_type;
 811 {
 812   /* We pass only unconstrained objects, those required by the language
 813      to be passed by reference, and objects of variable size.  The latter
 814      is more efficient, avoids problems with variable size temporaries,
 815      and does not produce compatibility problems with C, since C does
 816      not have such objects.  */
 817   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 818           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 819           || (TYPE_SIZE (gnu_type) != 0
 820               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 821 }
 822
 823 /* This function returns the version of GCC being used.  Here it's GCC 3.  */
 824
 825 int
 826 gcc_version ()
 827 {
 828   return 3;
 829 }