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