gcc/ada/misc.c

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