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