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