gcc/ada/misc.c

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