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  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  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 "coretypes.h"
  41 #include "tm.h"
  42 #include "tree.h"
  43 #include "rtl.h"
  44 #include "errors.h"
  45 #include "diagnostic.h"
  46 #include "expr.h"
  47 #include "libfuncs.h"
  48 #include "ggc.h"
  49 #include "flags.h"
  50 #include "debug.h"
  51 #include "insn-codes.h"
  52 #include "insn-flags.h"
  53 #include "insn-config.h"
  54 #include "optabs.h"
  55 #include "recog.h"
  56 #include "toplev.h"
  57 #include "output.h"
  58 #include "except.h"
  59 #include "tm_p.h"
  60 #include "langhooks.h"
  61 #include "langhooks-def.h"
  62
  63 #include "ada.h"
  64 #include "types.h"
  65 #include "atree.h"
  66 #include "elists.h"
  67 #include "namet.h"
  68 #include "nlists.h"
  69 #include "stringt.h"
  70 #include "uintp.h"
  71 #include "fe.h"
  72 #include "sinfo.h"
  73 #include "einfo.h"
  74 #include "ada-tree.h"
  75 #include "gigi.h"
  76 #include "adadecode.h"
  77
  78 extern FILE *asm_out_file;
  79 extern int save_argc;
  80 extern char **save_argv;
  81
  82 static size_t gnat_tree_size            PARAMS ((enum tree_code));
  83 static bool gnat_init                   PARAMS ((void));
  84 static void gnat_init_options           PARAMS ((void));
  85 static int gnat_decode_option           PARAMS ((int, char **));
  86 static HOST_WIDE_INT gnat_get_alias_set PARAMS ((tree));
  87 static void gnat_print_decl             PARAMS ((FILE *, tree, int));
  88 static void gnat_print_type             PARAMS ((FILE *, tree, int));
  89 static const char *gnat_printable_name  PARAMS  ((tree, int));
  90 static tree gnat_eh_runtime_type        PARAMS ((tree));
  91 static int gnat_eh_type_covers          PARAMS ((tree, tree));
  92 static void gnat_parse_file             PARAMS ((int));
  93 static rtx gnat_expand_expr             PARAMS ((tree, rtx, enum machine_mode,
  94                                                  int));
  95
  96 /* Structure giving our language-specific hooks.  */
  97
  98 #undef  LANG_HOOKS_NAME
  99 #define LANG_HOOKS_NAME                 "GNU Ada"
 100 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 101 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 102 #undef  LANG_HOOKS_TREE_SIZE
 103 #define LANG_HOOKS_TREE_SIZE            gnat_tree_size
 104 #undef  LANG_HOOKS_INIT
 105 #define LANG_HOOKS_INIT                 gnat_init
 106 #undef  LANG_HOOKS_INIT_OPTIONS
 107 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 108 #undef  LANG_HOOKS_DECODE_OPTION
 109 #define LANG_HOOKS_DECODE_OPTION        gnat_decode_option
 110 #undef LANG_HOOKS_PARSE_FILE
 111 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 112 #undef LANG_HOOKS_HONOR_READONLY
 113 #define LANG_HOOKS_HONOR_READONLY       1
 114 #undef LANG_HOOKS_FINISH_INCOMPLETE_DECL
 115 #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
 116 #undef LANG_HOOKS_GET_ALIAS_SET
 117 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 118 #undef LANG_HOOKS_EXPAND_EXPR
 119 #define LANG_HOOKS_EXPAND_EXPR          gnat_expand_expr
 120 #undef LANG_HOOKS_MARK_ADDRESSABLE
 121 #define LANG_HOOKS_MARK_ADDRESSABLE     gnat_mark_addressable
 122 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
 123 #define LANG_HOOKS_TRUTHVALUE_CONVERSION gnat_truthvalue_conversion
 124 #undef LANG_HOOKS_PRINT_DECL
 125 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 126 #undef LANG_HOOKS_PRINT_TYPE
 127 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 128 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
 129 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 130 #undef LANG_HOOKS_TYPE_FOR_MODE
 131 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 132 #undef LANG_HOOKS_TYPE_FOR_SIZE
 133 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 134 #undef LANG_HOOKS_SIGNED_TYPE
 135 #define LANG_HOOKS_SIGNED_TYPE          gnat_signed_type
 136 #undef LANG_HOOKS_UNSIGNED_TYPE
 137 #define LANG_HOOKS_UNSIGNED_TYPE        gnat_unsigned_type
 138 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 139 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gnat_signed_or_unsigned_type
 140
 141 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 142
 143 /* Tables describing GCC tree codes used only by GNAT.
 144
 145    Table indexed by tree code giving a string containing a character
 146    classifying the tree code.  Possibilities are
 147    t, d, s, c, r, <, 1 and 2.  See cp-tree.def for details.  */
 148
 149 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 150
 151 const char tree_code_type[] = {
 152 #include "tree.def"
 153   'x',
 154 #include "ada-tree.def"
 155 };
 156 #undef DEFTREECODE
 157
 158 /* Table indexed by tree code giving number of expression
 159    operands beyond the fixed part of the node structure.
 160    Not used for types or decls.  */
 161
 162 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 163
 164 const unsigned char tree_code_length[] = {
 165 #include "tree.def"
 166   0,
 167 #include "ada-tree.def"
 168 };
 169 #undef DEFTREECODE
 170
 171 /* Names of tree components.
 172    Used for printing out the tree and error messages.  */
 173 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 174
 175 const char *const tree_code_name[] = {
 176 #include "tree.def"
 177   "@@dummy",
 178 #include "ada-tree.def"
 179 };
 180 #undef DEFTREECODE
 181
 182 /* gnat standard argc argv */
 183
 184 extern int gnat_argc;
 185 extern char **gnat_argv;
 186
 187 static void internal_error_function     PARAMS ((const char *, va_list *));
 188 static void gnat_adjust_rli             PARAMS ((record_layout_info));
 189 \f
 190 /* Declare functions we use as part of startup.  */
 191 extern void __gnat_initialize   PARAMS((void));
 192 extern void adainit             PARAMS((void));
 193 extern void _ada_gnat1drv       PARAMS((void));
 194
 195 /* The parser for the language.  For us, we process the GNAT tree.  */
 196
 197 static void
 198 gnat_parse_file (set_yydebug)
 199      int set_yydebug ATTRIBUTE_UNUSED;
 200 {
 201   /* call the target specific initializations */
 202   __gnat_initialize();
 203
 204   /* Call the front-end elaboration procedures */
 205   adainit ();
 206
 207   immediate_size_expand = 1;
 208
 209   /* Call the front end */
 210   _ada_gnat1drv ();
 211 }
 212
 213 /* Decode all the language specific options that cannot be decoded by GCC.
 214    The option decoding phase of GCC calls this routine on the flags that
 215    it cannot decode.  This routine returns the number of consecutive arguments
 216    from ARGV that it successfully decoded; 0 indicates failure.  */
 217
 218 static int
 219 gnat_decode_option (argc, argv)
 220      int argc ATTRIBUTE_UNUSED;
 221      char **argv;
 222 {
 223   char *p = argv[0];
 224   int i;
 225
 226   if (!strncmp (p, "-I", 2))
 227     {
 228       /* We might get -I foo or -Ifoo.  Canonicalize to the latter.  */
 229       if (p[2] == '\0')
 230         {
 231           char *q;
 232
 233           if (argv[1] == 0)
 234             return 0;
 235
 236           q = xmalloc (sizeof("-I") + strlen (argv[1]));
 237           strcpy (q, "-I");
 238           strcat (q, argv[1]);
 239
 240           gnat_argv[gnat_argc] = q;
 241           gnat_argc ++;
 242           return 2;  /* consumed argument */
 243         }
 244       else
 245         {
 246           gnat_argv[gnat_argc] = p;
 247           gnat_argc ++;
 248           return 1;
 249         }
 250     }
 251
 252   else if (!strncmp (p, "-gant", 5))
 253     {
 254       char *q = xstrdup (p);
 255
 256       warning ("`-gnat' misspelled as `-gant'");
 257       q[2] = 'n', q[3] = 'a';
 258       p = q;
 259       return 1;
 260     }
 261
 262   else if (!strncmp (p, "-gnat", 5))
 263     {
 264       /* Recopy the switches without the 'gnat' prefix */
 265
 266       gnat_argv[gnat_argc] =  (char *) xmalloc (strlen (p) - 3);
 267       gnat_argv[gnat_argc][0] = '-';
 268       strcpy (gnat_argv[gnat_argc] + 1, p + 5);
 269       gnat_argc ++;
 270       if (p[5] == 'O')
 271         for (i = 1; i < save_argc - 1; i++)
 272           if (!strncmp (save_argv[i], "-gnatO", 6))
 273             if (save_argv[++i][0] != '-')
 274               {
 275                 /* Preserve output filename as GCC doesn't save it for GNAT. */
 276                 gnat_argv[gnat_argc] = save_argv[i];
 277                 gnat_argc++;
 278                 break;
 279               }
 280
 281       return 1;
 282     }
 283
 284   /* Handle the --RTS switch.  The real option we get is -fRTS. This
 285      modification is done by the driver program.  */
 286   if (!strncmp (p, "-fRTS", 5))
 287     {
 288       gnat_argv[gnat_argc] = p;
 289       gnat_argc ++;
 290       return 1;
 291     }
 292
 293   /* Ignore -W flags since people may want to use the same flags for all
 294      languages.  */
 295   else if (p[0] == '-' && p[1] == 'W' && p[2] != 0)
 296     return 1;
 297
 298   return 0;
 299 }
 300
 301 /* Initialize for option processing.  */
 302
 303 static void
 304 gnat_init_options ()
 305 {
 306   /* Initialize gnat_argv with save_argv size */
 307   gnat_argv = (char **) xmalloc ((save_argc + 1) * sizeof (gnat_argv[0]));
 308   gnat_argv[0] = save_argv[0];     /* name of the command */
 309   gnat_argc = 1;
 310 }
 311
 312 /* Here is the function to handle the compiler error processing in GCC.  */
 313
 314 static void
 315 internal_error_function (msgid, ap)
 316      const char *msgid;
 317      va_list *ap;
 318 {
 319   char buffer[1000];            /* Assume this is big enough.  */
 320   char *p;
 321   String_Template temp;
 322   Fat_Pointer fp;
 323
 324   vsprintf (buffer, msgid, *ap);
 325
 326   /* Go up to the first newline.  */
 327   for (p = buffer; *p != 0; p++)
 328     if (*p == '\n')
 329       {
 330         *p = '\0';
 331         break;
 332       }
 333
 334   temp.Low_Bound = 1, temp.High_Bound = strlen (buffer);
 335   fp.Array = buffer, fp.Bounds = &temp;
 336
 337   Current_Error_Node = error_gnat_node;
 338   Compiler_Abort (fp, -1);
 339 }
 340
 341 /* Langhook for tree_size: determine size of our 'x' and 'c' nodes.  */
 342 static size_t
 343 gnat_tree_size (enum tree_code code)
 344 {
 345   switch (code)
 346     {
 347     case GNAT_LOOP_ID:  return sizeof (struct tree_loop_id);
 348     default:
 349       abort ();
 350     }
 351   /* NOTREACHED */
 352 }
 353
 354 /* Perform all the initialization steps that are language-specific.  */
 355
 356 static bool
 357 gnat_init ()
 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   gnat_init_decl_processing ();
 366
 367   /* Add the input filename as the last argument.  */
 368   gnat_argv[gnat_argc] = (char *) main_input_filename;
 369   gnat_argc++;
 370   gnat_argv[gnat_argc] = 0;
 371
 372   global_dc->internal_error = &internal_error_function;
 373
 374   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 375   internal_reference_types ();
 376
 377   set_lang_adjust_rli (gnat_adjust_rli);
 378
 379   return true;
 380 }
 381
 382 /* If we are using the GCC mechanism for to process exception handling, we
 383    have to register the personality routine for Ada and to initialize
 384    various language dependent hooks.  */
 385
 386 void
 387 gnat_init_gcc_eh ()
 388 {
 389   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 390      though. This could for instance lead to the emission of tables with
 391      references to symbols (such as the Ada eh personality routine) within
 392      libraries we won't link against.  */
 393   if (No_Exception_Handlers_Set ())
 394     return;
 395
 396   eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality");
 397   lang_eh_type_covers = gnat_eh_type_covers;
 398   lang_eh_runtime_type = gnat_eh_runtime_type;
 399   flag_exceptions = 1;
 400
 401   init_eh ();
 402 #ifdef DWARF2_UNWIND_INFO
 403   if (dwarf2out_do_frame ())
 404     dwarf2out_frame_init ();
 405 #endif
 406 }
 407
 408 /* Hooks for print-tree.c:  */
 409
 410 static void
 411 gnat_print_decl (file, node, indent)
 412      FILE *file;
 413      tree node;
 414      int indent;
 415 {
 416   switch (TREE_CODE (node))
 417     {
 418     case CONST_DECL:
 419       print_node (file, "const_corresponding_var",
 420                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 421       break;
 422
 423     case FIELD_DECL:
 424       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 425                   indent + 4);
 426       break;
 427
 428     default:
 429       break;
 430     }
 431 }
 432
 433 static void
 434 gnat_print_type (file, node, indent)
 435      FILE *file;
 436      tree node;
 437      int indent;
 438 {
 439   switch (TREE_CODE (node))
 440     {
 441     case FUNCTION_TYPE:
 442       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 443       break;
 444
 445     case ENUMERAL_TYPE:
 446       print_node (file, "RM size", TYPE_RM_SIZE_ENUM (node), indent + 4);
 447       break;
 448
 449     case INTEGER_TYPE:
 450       if (TYPE_MODULAR_P (node))
 451         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 452       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 453         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 454                     indent + 4);
 455       else if (TYPE_VAX_FLOATING_POINT_P (node))
 456         ;
 457       else
 458         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 459
 460       print_node (file, "RM size", TYPE_RM_SIZE_INT (node), indent + 4);
 461       break;
 462
 463     case ARRAY_TYPE:
 464       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 465       break;
 466
 467     case RECORD_TYPE:
 468       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 469         print_node (file, "unconstrained array",
 470                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 471       else
 472         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 473       break;
 474
 475     case UNION_TYPE:
 476     case QUAL_UNION_TYPE:
 477       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 478       break;
 479
 480     default:
 481       break;
 482     }
 483 }
 484
 485 static const char *
 486 gnat_printable_name (decl, verbosity)
 487      tree decl;
 488      int verbosity ATTRIBUTE_UNUSED;
 489 {
 490   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 491   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 492
 493   __gnat_decode (coded_name, ada_name, 0);
 494
 495   return (const char *) ada_name;
 496 }
 497
 498 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 499    here are TRANSFORM_EXPR, ALLOCATE_EXPR, USE_EXPR and NULL_EXPR.  */
 500
 501 static rtx
 502 gnat_expand_expr (exp, target, tmode, modifier)
 503      tree exp;
 504      rtx target;
 505      enum machine_mode tmode;
 506      int modifier;  /* Actually an enum expand_modifier.  */
 507 {
 508   tree type = TREE_TYPE (exp);
 509   tree new;
 510   rtx result;
 511
 512   /* Update EXP to be the new expression to expand.  */
 513
 514   switch (TREE_CODE (exp))
 515     {
 516     case TRANSFORM_EXPR:
 517       gnat_to_code (TREE_COMPLEXITY (exp));
 518       return const0_rtx;
 519       break;
 520
 521     case NULL_EXPR:
 522       expand_expr (TREE_OPERAND (exp, 0), const0_rtx, VOIDmode, 0);
 523
 524       /* We aren't going to be doing anything with this memory, but allocate
 525          it anyway.  If it's variable size, make a bogus address.  */
 526       if (! host_integerp (TYPE_SIZE_UNIT (type), 1))
 527         result = gen_rtx_MEM (BLKmode, virtual_stack_vars_rtx);
 528       else
 529         result = assign_temp (type, 0, TREE_ADDRESSABLE (exp), 1);
 530
 531       return result;
 532
 533     case ALLOCATE_EXPR:
 534       return
 535         allocate_dynamic_stack_space
 536           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 537                         EXPAND_NORMAL),
 538            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 539
 540     case USE_EXPR:
 541       if (target != const0_rtx)
 542         gigi_abort (203);
 543
 544       /* First write a volatile ASM_INPUT to prevent anything from being
 545          moved.  */
 546       result = gen_rtx_ASM_INPUT (VOIDmode, "");
 547       MEM_VOLATILE_P (result) = 1;
 548       emit_insn (result);
 549
 550       result = expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, VOIDmode,
 551                             modifier);
 552       emit_insn (gen_rtx_USE (VOIDmode, result));
 553       return target;
 554
 555     case GNAT_NOP_EXPR:
 556       return expand_expr (build1 (NOP_EXPR, type, TREE_OPERAND (exp, 0)),
 557                           target, tmode, modifier);
 558
 559     case UNCONSTRAINED_ARRAY_REF:
 560       /* If we are evaluating just for side-effects, just evaluate our
 561          operand.  Otherwise, abort since this code should never appear
 562          in a tree to be evaluated (objects aren't unconstrained).  */
 563       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 564         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 565                             VOIDmode, modifier);
 566
 567       /* ... fall through ... */
 568
 569     default:
 570       gigi_abort (201);
 571     }
 572
 573   return expand_expr (new, target, tmode, modifier);
 574 }
 575
 576 /* Adjusts the RLI used to layout a record after all the fields have been
 577    added.  We only handle the packed case and cause it to use the alignment
 578    that will pad the record at the end.  */
 579
 580 static void
 581 gnat_adjust_rli (rli)
 582      record_layout_info rli ATTRIBUTE_UNUSED;
 583 {
 584 #if 0
 585   /* This code seems to have no actual effect; record_align should already
 586      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 587   unsigned int record_align = rli->unpadded_align;
 588   tree field;
 589
 590   /* If any fields have variable size, we need to force the record to be at
 591      least as aligned as the alignment of that type.  */
 592   for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field))
 593     if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST)
 594       record_align = MAX (record_align, DECL_ALIGN (field));
 595
 596   if (TYPE_PACKED (rli->t))
 597     rli->record_align = record_align;
 598 #endif
 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_insn_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 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 809    default.  */
 810
 811 int
 812 default_pass_by_ref (gnu_type)
 813      tree gnu_type;
 814 {
 815   CUMULATIVE_ARGS cum;
 816
 817   INIT_CUMULATIVE_ARGS (cum, NULL_TREE, NULL_RTX, 0);
 818
 819   /* We pass aggregates by reference if they are sufficiently large.  The
 820      choice of constant here is somewhat arbitrary.  We also pass by
 821      reference if the target machine would either pass or return by
 822      reference.  Strictly speaking, we need only check the return if this
 823      is an In Out parameter, but it's probably best to err on the side of
 824      passing more things by reference.  */
 825   return (0
 826 #ifdef FUNCTION_ARG_PASS_BY_REFERENCE
 827           || FUNCTION_ARG_PASS_BY_REFERENCE (cum, TYPE_MODE (gnu_type),
 828                                              gnu_type, 1)
 829 #endif
 830           || RETURN_IN_MEMORY (gnu_type)
 831           || (AGGREGATE_TYPE_P (gnu_type)
 832               && (! host_integerp (TYPE_SIZE (gnu_type), 1)
 833                   || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 834                                            8 * TYPE_ALIGN (gnu_type)))));
 835 }
 836
 837 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 838    it should be passed by reference. */
 839
 840 int
 841 must_pass_by_ref (gnu_type)
 842      tree gnu_type;
 843 {
 844   /* We pass only unconstrained objects, those required by the language
 845      to be passed by reference, and objects of variable size.  The latter
 846      is more efficient, avoids problems with variable size temporaries,
 847      and does not produce compatibility problems with C, since C does
 848      not have such objects.  */
 849   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 850           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 851           || (TYPE_SIZE (gnu_type) != 0
 852               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 853 }
 854
 855 /* This function returns the version of GCC being used.  Here it's GCC 3.  */
 856
 857 int
 858 gcc_version ()
 859 {
 860   return 3;
 861 }