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