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