gcc/ada/misc.c

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