gcc/ada/misc.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                 M I S C                                  *
   6  *                                                                          *
   7  *                           C Implementation File                          *
   8  *                                                                          *
   9  *                             $Revision: 1.5 $
  10  *                                                                          *
  11  *          Copyright (C) 1992-2001 Free Software Foundation, Inc.          *
  12  *                                                                          *
  13  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  14  * terms of the  GNU General Public License as published  by the Free Soft- *
  15  * ware  Foundation;  either version 2,  or (at your option) any later ver- *
  16  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  17  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  18  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  19  * for  more details.  You should have  received  a copy of the GNU General *
  20  * Public License  distributed with GNAT;  see file COPYING.  If not, write *
  21  * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
  22  * MA 02111-1307, USA.                                                      *
  23  *                                                                          *
  24  * As a  special  exception,  if you  link  this file  with other  files to *
  25  * produce an executable,  this file does not by itself cause the resulting *
  26  * executable to be covered by the GNU General Public License. This except- *
  27  * ion does not  however invalidate  any other reasons  why the  executable *
  28  * file might be covered by the  GNU Public License.                        *
  29  *                                                                          *
  30  * GNAT was originally developed  by the GNAT team at  New York University. *
  31  * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
  32  *                                                                          *
  33  ****************************************************************************/
  34
  35 /* This file contains parts of the compiler that are required for interfacing
  36    with GCC but otherwise do nothing and parts of Gigi that need to know
  37    about RTL.  */
  38
  39 #include "config.h"
  40 #include "system.h"
  41 #include "tree.h"
  42 #include "rtl.h"
  43 #include "errors.h"
  44 #include "diagnostic.h"
  45 #include "expr.h"
  46 #include "ggc.h"
  47 #include "flags.h"
  48 #include "insn-flags.h"
  49 #include "insn-config.h"
  50 #include "recog.h"
  51 #include "toplev.h"
  52 #include "output.h"
  53 #include "except.h"
  54 #include "tm_p.h"
  55 #include "langhooks.h"
  56
  57 #include "ada.h"
  58 #include "types.h"
  59 #include "atree.h"
  60 #include "elists.h"
  61 #include "namet.h"
  62 #include "nlists.h"
  63 #include "stringt.h"
  64 #include "uintp.h"
  65 #include "fe.h"
  66 #include "sinfo.h"
  67 #include "einfo.h"
  68 #include "ada-tree.h"
  69 #include "gigi.h"
  70
  71 extern FILE *asm_out_file;
  72 extern int save_argc;
  73 extern char **save_argv;
  74
  75 /* Tables describing GCC tree codes used only by GNAT.
  76
  77    Table indexed by tree code giving a string containing a character
  78    classifying the tree code.  Possibilities are
  79    t, d, s, c, r, <, 1 and 2.  See cp-tree.def for details.  */
  80
  81 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
  82
  83 char gnat_tree_code_type[] = {
  84   'x',
  85 #include "ada-tree.def"
  86 };
  87 #undef DEFTREECODE
  88
  89 /* Table indexed by tree code giving number of expression
  90    operands beyond the fixed part of the node structure.
  91    Not used for types or decls.  */
  92
  93 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
  94
  95 int gnat_tree_code_length[] = {
  96   0,
  97 #include "ada-tree.def"
  98 };
  99 #undef DEFTREECODE
 100
 101 /* Names of tree components.
 102    Used for printing out the tree and error messages.  */
 103 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 104
 105 const char *gnat_tree_code_name[] = {
 106   "@@dummy",
 107 #include "ada-tree.def"
 108 };
 109 #undef DEFTREECODE
 110
 111 static void gnat_init                   PARAMS ((void));
 112 static void gnat_init_options           PARAMS ((void));
 113 static int gnat_decode_option           PARAMS ((int, char **));
 114 static HOST_WIDE_INT gnat_get_alias_set PARAMS ((tree));
 115
 116 /* Structure giving our language-specific hooks.  */
 117
 118 #undef  LANG_HOOKS_INIT
 119 #define LANG_HOOKS_INIT                 gnat_init
 120 #undef  LANG_HOOKS_INIT_OPTIONS
 121 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 122 #undef  LANG_HOOKS_DECODE_OPTION
 123 #define LANG_HOOKS_DECODE_OPTION        gnat_decode_option
 124 #undef LANG_HOOKS_HONOR_READONLY
 125 #define LANG_HOOKS_HONOR_READONLY       1
 126 #undef LANG_HOOKS_GET_ALIAS_SET
 127 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 128
 129 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 130
 131 /* gnat standard argc argv */
 132
 133 extern int gnat_argc;
 134 extern char **gnat_argv;
 135
 136 /* Global Variables Expected by gcc: */
 137
 138 const char * const language_string = "GNU Ada";
 139 int flag_traditional;           /* Used by dwarfout.c.  */
 140 int ggc_p = 1;
 141
 142 static void internal_error_function     PARAMS ((const char *, va_list *));
 143 static rtx gnat_expand_expr             PARAMS ((tree, rtx, enum machine_mode,
 144                                                  enum expand_modifier));
 145 static tree gnat_expand_constant        PARAMS ((tree));
 146 static void gnat_adjust_rli             PARAMS ((record_layout_info));
 147
 148 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
 149 static char *convert_ada_name_to_qualified_name PARAMS ((char *));
 150 #endif
 151 \f
 152 /* Routines Expected by gcc:  */
 153
 154 /* For most front-ends, this is the parser for the language.  For us, we
 155    process the GNAT tree.  */
 156
 157 #define Set_Jmpbuf_Address system__soft_links__set_jmpbuf_address_soft
 158 extern void Set_Jmpbuf_Address (void *);
 159
 160 /* Declare functions we use as part of startup.  */
 161 extern void __gnat_initialize   PARAMS((void));
 162 extern void adainit             PARAMS((void));
 163 extern void _ada_gnat1drv       PARAMS((void));
 164
 165 int
 166 yyparse ()
 167 {
 168   /* Make up what Gigi uses as a jmpbuf.  */
 169   size_t jmpbuf[10];
 170
 171   /* call the target specific initializations */
 172   __gnat_initialize();
 173
 174   /* Call the front-end elaboration procedures */
 175   adainit ();
 176
 177   /* Set up to catch unhandled exceptions.  */
 178   if (__builtin_setjmp (jmpbuf))
 179     {
 180       Set_Jmpbuf_Address (0);
 181       abort ();
 182     }
 183
 184   /* This is only really needed in longjmp/setjmp mode exceptions
 185      but we don't know any easy way to tell what mode the host is
 186      compiled in, and it is harmless to do it unconditionally */
 187
 188   Set_Jmpbuf_Address (jmpbuf);
 189
 190   immediate_size_expand = 1;
 191
 192   /* Call the front end */
 193   _ada_gnat1drv ();
 194
 195   Set_Jmpbuf_Address (0);
 196   return 0;
 197 }
 198
 199 /* Decode all the language specific options that cannot be decoded by GCC.
 200    The option decoding phase of GCC calls this routine on the flags that
 201    it cannot decode. This routine returns 1 if it is successful, otherwise
 202    it returns 0. */
 203
 204 int
 205 gnat_decode_option (argc, argv)
 206      int argc ATTRIBUTE_UNUSED;
 207      char **argv;
 208 {
 209   char *p = argv[0];
 210   int i;
 211
 212   if (!strncmp (p, "-I", 2))
 213     {
 214       /* Pass the -I switches as-is. */
 215       gnat_argv[gnat_argc] = p;
 216       gnat_argc ++;
 217       return 1;
 218     }
 219
 220   else if (!strncmp (p, "-gant", 5))
 221     {
 222       char *q = (char *) xmalloc (strlen (p) + 1);
 223
 224       warning ("`-gnat' misspelled as `-gant'");
 225       strcpy (q, p);
 226       q[2] = 'n', q[3] = 'a';
 227       p = q;
 228       return 1;
 229     }
 230
 231   else if (!strncmp (p, "-gnat", 5))
 232     {
 233       /* Recopy the switches without the 'gnat' prefix */
 234
 235       gnat_argv[gnat_argc] =  (char *) xmalloc (strlen (p) - 3);
 236       gnat_argv[gnat_argc][0] = '-';
 237       strcpy (gnat_argv[gnat_argc] + 1, p + 5);
 238       gnat_argc ++;
 239       if (p[5] == 'O')
 240         for (i = 1; i < save_argc - 1; i++)
 241           if (!strncmp (save_argv[i], "-gnatO", 6))
 242             if (save_argv[++i][0] != '-')
 243               {
 244                 /* Preserve output filename as GCC doesn't save it for GNAT. */
 245                 gnat_argv[gnat_argc] = save_argv[i];
 246                 gnat_argc++;
 247                 break;
 248               }
 249
 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 we have the function to handle the compiler error processing in GCC.
 320    Do this only if VPRINTF is available.  */
 321
 322 #if defined(HAVE_VPRINTF)
 323 #define DO_INTERNAL_ERROR_FUNCTION
 324
 325 static void
 326 internal_error_function (msgid, ap)
 327      const char *msgid;
 328      va_list *ap;
 329 {
 330   char buffer[1000];            /* Assume this is big enough.  */
 331   char *p;
 332   String_Template temp;
 333   Fat_Pointer fp;
 334
 335   vsprintf (buffer, msgid, *ap);
 336
 337   /* Go up to the first newline.  */
 338   for (p = buffer; *p != 0; p++)
 339     if (*p == '\n')
 340       {
 341         *p = '\0';
 342         break;
 343       }
 344
 345   temp.Low_Bound = 1, temp.High_Bound = strlen (buffer);
 346   fp.Array = buffer, fp.Bounds = &temp;
 347
 348   Current_Error_Node = error_gnat_node;
 349   Compiler_Abort (fp, -1);
 350 }
 351 #endif
 352
 353 /* Perform all the initialization steps that are language-specific.  */
 354
 355 void
 356 gnat_init ()
 357 {
 358   /* Add the input filename as the last argument.  */
 359   gnat_argv [gnat_argc] = (char *) input_filename;
 360   gnat_argc++;
 361   gnat_argv [gnat_argc] = 0;
 362
 363 #ifdef DO_INTERNAL_ERROR_FUNCTION
 364   set_internal_error_function (internal_error_function);
 365 #endif
 366
 367   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 368   internal_reference_types ();
 369
 370   /* Show we don't use the common language attributes.  */
 371   lang_attribute_common = 0;
 372
 373   set_lang_adjust_rli (gnat_adjust_rli);
 374
 375 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
 376   dwarf2out_set_demangle_name_func (convert_ada_name_to_qualified_name);
 377 #endif
 378 }
 379
 380 /* Return a short string identifying this language to the debugger.  */
 381
 382 const char *
 383 lang_identify ()
 384 {
 385   return "ada";
 386 }
 387
 388 /* If DECL has a cleanup, build and return that cleanup here.
 389    This is a callback called by expand_expr.  */
 390
 391 tree
 392 maybe_build_cleanup (decl)
 393      tree decl ATTRIBUTE_UNUSED;
 394 {
 395   /* There are no cleanups in C.  */
 396   return NULL_TREE;
 397 }
 398
 399 /* Print any language-specific compilation statistics.  */
 400
 401 void
 402 print_lang_statistics ()
 403 {}
 404
 405 void
 406 lang_print_xnode (file, node, indent)
 407      FILE *file ATTRIBUTE_UNUSED;
 408      tree node ATTRIBUTE_UNUSED;
 409      int indent ATTRIBUTE_UNUSED;
 410 {
 411 }
 412
 413 /* integrate_decl_tree calls this function, but since we don't use the
 414    DECL_LANG_SPECIFIC field, this is a no-op.  */
 415
 416 void
 417 copy_lang_decl (node)
 418      tree node ATTRIBUTE_UNUSED;
 419 {
 420 }
 421
 422 /* Hooks for print-tree.c:  */
 423
 424 void
 425 print_lang_decl (file, node, indent)
 426      FILE *file;
 427      tree node;
 428      int indent;
 429 {
 430   switch (TREE_CODE (node))
 431     {
 432     case CONST_DECL:
 433       print_node (file, "const_corresponding_var",
 434                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 435       break;
 436
 437     case FIELD_DECL:
 438       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 439                   indent + 4);
 440       break;
 441
 442     default:
 443       break;
 444     }
 445 }
 446
 447 void
 448 print_lang_type (file, node, indent)
 449      FILE *file;
 450      tree node;
 451      int indent;
 452 {
 453   switch (TREE_CODE (node))
 454     {
 455     case FUNCTION_TYPE:
 456       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 457       break;
 458
 459     case ENUMERAL_TYPE:
 460       print_node (file, "RM size", TYPE_RM_SIZE_ENUM (node), indent + 4);
 461       break;
 462
 463     case INTEGER_TYPE:
 464       if (TYPE_MODULAR_P (node))
 465         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 466       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 467         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 468                     indent + 4);
 469       else if (TYPE_VAX_FLOATING_POINT_P (node))
 470         ;
 471       else
 472         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 473
 474       print_node (file, "RM size", TYPE_RM_SIZE_INT (node), indent + 4);
 475       break;
 476
 477     case ARRAY_TYPE:
 478       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 479       break;
 480
 481     case RECORD_TYPE:
 482       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 483         print_node (file, "unconstrained array",
 484                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 485       else
 486         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 487       break;
 488
 489     case UNION_TYPE:
 490     case QUAL_UNION_TYPE:
 491       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 492       break;
 493
 494     default:
 495       break;
 496     }
 497 }
 498
 499 void
 500 print_lang_identifier (file, node, indent)
 501      FILE *file ATTRIBUTE_UNUSED;
 502      tree node ATTRIBUTE_UNUSED;
 503      int indent ATTRIBUTE_UNUSED;
 504 {}
 505
 506 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 507    here are TRANSFORM_EXPR, UNCHECKED_CONVERT_EXPR, ALLOCATE_EXPR,
 508    USE_EXPR and NULL_EXPR.  */
 509
 510 static rtx
 511 gnat_expand_expr (exp, target, tmode, modifier)
 512      tree exp;
 513      rtx target;
 514      enum machine_mode tmode;
 515      enum expand_modifier modifier;
 516 {
 517   tree type = TREE_TYPE (exp);
 518   tree inner_type;
 519   tree new;
 520   rtx result;
 521   int align_ok;
 522
 523   /* Update EXP to be the new expression to expand.  */
 524
 525   switch (TREE_CODE (exp))
 526     {
 527     case TRANSFORM_EXPR:
 528       gnat_to_code (TREE_COMPLEXITY (exp));
 529       return const0_rtx;
 530       break;
 531
 532     case UNCHECKED_CONVERT_EXPR:
 533       inner_type = TREE_TYPE (TREE_OPERAND (exp, 0));
 534
 535       /* The alignment is OK if the flag saying it is OK is set in either
 536          type, if the inner type is already maximally aligned, if the
 537          new type is no more strictly aligned than the old type, or
 538          if byte accesses are not slow.  */
 539       align_ok = (! SLOW_BYTE_ACCESS
 540                   || TYPE_ALIGN_OK_P (type) || TYPE_ALIGN_OK_P (inner_type)
 541                   || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
 542                   || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type));
 543
 544       /* If we're converting between an aggregate and non-aggregate type
 545          and we have a MEM TARGET, we can't use it, since MEM_IN_STRUCT_P
 546          would be set incorrectly.  */
 547       if (target != 0 && GET_CODE (target) == MEM
 548           && (MEM_IN_STRUCT_P (target) != AGGREGATE_TYPE_P (inner_type)))
 549         target = 0;
 550
 551       /* If the input and output are both the same mode (usually BLKmode),
 552          just return the expanded input since we want just the bits.  But
 553          we can't do this if the output is more strictly aligned than
 554          the input or if the type is BLKmode and the sizes differ.  */
 555       if (TYPE_MODE (type) == TYPE_MODE (inner_type)
 556           && align_ok
 557           && ! (TYPE_MODE (type) == BLKmode
 558                 && ! operand_equal_p (TYPE_SIZE (type),
 559                                       TYPE_SIZE (inner_type), 0)))
 560         {
 561           new = TREE_OPERAND (exp, 0);
 562
 563           /* If the new type is less strictly aligned than the inner type,
 564              make a new type with the less strict alignment just for
 565              code generation purposes of this node.  If it is a decl,
 566              we can't change the type, so make a NOP_EXPR.  */
 567           if (TYPE_ALIGN (type) != TYPE_ALIGN (inner_type))
 568             {
 569               tree copy_type = copy_node (inner_type);
 570
 571               TYPE_ALIGN (copy_type) = TYPE_ALIGN (type);
 572               if (DECL_P (new))
 573                 new = build1 (NOP_EXPR, copy_type, new);
 574               else
 575                 {
 576                   /* If NEW is a constant, it might be coming from a CONST_DECL
 577                      and hence shared.  */
 578                   if (TREE_CONSTANT (new))
 579                     new = copy_node (new);
 580
 581                   TREE_TYPE (new) = copy_type;
 582                 }
 583             }
 584         }
 585
 586       /* If either mode is BLKmode, memory will be involved, so do this
 587          via pointer punning.  Likewise, this doesn't work if there
 588          is an alignment issue.  But we must do it for types that are known
 589          to be aligned properly.  */
 590       else if ((TYPE_MODE (type) == BLKmode
 591                 || TYPE_MODE (inner_type) == BLKmode)
 592                && align_ok)
 593         new = build_unary_op (INDIRECT_REF, NULL_TREE,
 594                               convert
 595                               (build_pointer_type (type),
 596                                build_unary_op (ADDR_EXPR, NULL_TREE,
 597                                                TREE_OPERAND (exp, 0))));
 598
 599       /* Otherwise make a union of the two types, convert to the union, and
 600          extract the other value.  */
 601       else
 602         {
 603           tree union_type, in_field, out_field;
 604
 605           /* If this is inside the LHS of an assignment, this would generate
 606              bad code, so abort.  */
 607           if (TREE_ADDRESSABLE (exp))
 608             gigi_abort (202);
 609
 610           union_type = make_node (UNION_TYPE);
 611           in_field = create_field_decl (get_identifier ("in"),
 612                                         inner_type, union_type, 0, 0, 0, 0);
 613           out_field = create_field_decl (get_identifier ("out"),
 614                                          type, union_type, 0, 0, 0, 0);
 615
 616           TYPE_FIELDS (union_type) = chainon (in_field, out_field);
 617           layout_type (union_type);
 618
 619           /* Though this is a "union", we can treat its size as that of
 620              the output type in case the size of the input type is variable.
 621              If the output size is a variable, use the input size.  */
 622           TYPE_SIZE (union_type) = TYPE_SIZE (type);
 623           TYPE_SIZE_UNIT (union_type) = TYPE_SIZE (type);
 624           if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST
 625               && TREE_CODE (TYPE_SIZE (inner_type)) == INTEGER_CST)
 626             {
 627               TYPE_SIZE (union_type) = TYPE_SIZE (inner_type);
 628               TYPE_SIZE_UNIT (union_type) = TYPE_SIZE_UNIT (inner_type);
 629             }
 630
 631           new = build (COMPONENT_REF, type,
 632                        build1 (CONVERT_EXPR, union_type,
 633                                TREE_OPERAND (exp, 0)),
 634                        out_field);
 635         }
 636
 637       result = expand_expr (new, target, tmode, modifier);
 638
 639       if (GET_CODE (result) == MEM)
 640         {
 641           /* Update so it looks like this is of the proper type.  */
 642           set_mem_alias_set (result, 0);
 643           set_mem_attributes (result, exp, 0);
 644         }
 645       return result;
 646
 647     case NULL_EXPR:
 648       expand_expr (TREE_OPERAND (exp, 0), const0_rtx, VOIDmode, 0);
 649
 650       /* We aren't going to be doing anything with this memory, but allocate
 651          it anyway.  If it's variable size, make a bogus address.  */
 652       if (! host_integerp (TYPE_SIZE_UNIT (type), 1))
 653         result = gen_rtx_MEM (BLKmode, virtual_stack_vars_rtx);
 654       else
 655         result = assign_temp (type, 0, TREE_ADDRESSABLE (exp), 1);
 656
 657       set_mem_attributes (result, exp, 1);
 658       return result;
 659
 660     case ALLOCATE_EXPR:
 661       return
 662         allocate_dynamic_stack_space
 663           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 664                         EXPAND_NORMAL),
 665            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 666
 667     case USE_EXPR:
 668       if (target != const0_rtx)
 669         gigi_abort (203);
 670
 671       /* First write a volatile ASM_INPUT to prevent anything from being
 672          moved.  */
 673       result = gen_rtx_ASM_INPUT (VOIDmode, "");
 674       MEM_VOLATILE_P (result) = 1;
 675       emit_insn (result);
 676
 677       result = expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, VOIDmode,
 678                             modifier);
 679       emit_insn (gen_rtx_USE (VOIDmode, result));
 680       return target;
 681
 682     case GNAT_NOP_EXPR:
 683       return expand_expr (build1 (NOP_EXPR, type, TREE_OPERAND (exp, 0)),
 684                           target, tmode, modifier);
 685
 686     case UNCONSTRAINED_ARRAY_REF:
 687       /* If we are evaluating just for side-effects, just evaluate our
 688          operand.  Otherwise, abort since this code should never appear
 689          in a tree to be evaluated (objects aren't unconstrained).  */
 690       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 691         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 692                             VOIDmode, modifier);
 693
 694       /* ... fall through ... */
 695
 696     default:
 697       gigi_abort (201);
 698     }
 699
 700   return expand_expr (new, target, tmode, modifier);
 701 }
 702
 703 /* Transform a constant into a form that the language-independent code
 704    can handle.  */
 705
 706 static tree
 707 gnat_expand_constant (exp)
 708      tree exp;
 709 {
 710   /* If this is an unchecked conversion that does not change the size of the
 711      object, return the operand since the underlying constant is still
 712      the same.  Otherwise, return our operand.  */
 713   if (TREE_CODE (exp) == UNCHECKED_CONVERT_EXPR
 714       && operand_equal_p (TYPE_SIZE_UNIT (TREE_TYPE (exp)),
 715                           TYPE_SIZE_UNIT (TREE_TYPE (TREE_OPERAND (exp, 0))),
 716                           1))
 717     return TREE_OPERAND (exp, 0);
 718
 719   return exp;
 720 }
 721
 722 /* Adjusts the RLI used to layout a record after all the fields have been
 723    added.  We only handle the packed case and cause it to use the alignment
 724    that will pad the record at the end.  */
 725
 726 static void
 727 gnat_adjust_rli (rli)
 728      record_layout_info rli;
 729 {
 730   if (TYPE_PACKED (rli->t))
 731     rli->record_align = rli->unpadded_align;
 732 }
 733
 734 /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code.  */
 735
 736 tree
 737 make_transform_expr (gnat_node)
 738      Node_Id gnat_node;
 739 {
 740   tree gnu_result = build (TRANSFORM_EXPR, void_type_node);
 741
 742   TREE_SIDE_EFFECTS (gnu_result) = 1;
 743   TREE_COMPLEXITY (gnu_result) = gnat_node;
 744   return gnu_result;
 745 }
 746 \f
 747 /* Update the setjmp buffer BUF with the current stack pointer.  We assume
 748    here that a __builtin_setjmp was done to BUF.  */
 749
 750 void
 751 update_setjmp_buf (buf)
 752      tree buf;
 753 {
 754   enum machine_mode sa_mode = Pmode;
 755   rtx stack_save;
 756
 757 #ifdef HAVE_save_stack_nonlocal
 758   if (HAVE_save_stack_nonlocal)
 759     sa_mode = insn_operand_mode[(int) CODE_FOR_save_stack_nonlocal][0];
 760 #endif
 761 #ifdef STACK_SAVEAREA_MODE
 762   sa_mode = STACK_SAVEAREA_MODE (SAVE_NONLOCAL);
 763 #endif
 764
 765   stack_save
 766     = gen_rtx_MEM (sa_mode,
 767                    memory_address
 768                    (sa_mode,
 769                     plus_constant (expand_expr
 770                                    (build_unary_op (ADDR_EXPR, NULL_TREE, buf),
 771                                     NULL_RTX, VOIDmode, 0),
 772                                    2 * GET_MODE_SIZE (Pmode))));
 773
 774 #ifdef HAVE_setjmp
 775   if (HAVE_setjmp)
 776     emit_insn (gen_setjmp ());
 777 #endif
 778
 779   emit_stack_save (SAVE_NONLOCAL, &stack_save, NULL_RTX);
 780 }
 781 \f
 782 /* See if DECL has an RTL that is indirect via a pseudo-register or a
 783    memory location and replace it with an indirect reference if so.
 784    This improves the debugger's ability to display the value.  */
 785
 786 void
 787 adjust_decl_rtl (decl)
 788      tree decl;
 789 {
 790   tree new_type;
 791
 792   /* If this decl is already indirect, don't do anything.  This should
 793      mean that the decl cannot be indirect, but there's no point in
 794      adding an abort to check that.  */
 795   if (TREE_CODE (decl) != CONST_DECL
 796       && ! DECL_BY_REF_P (decl)
 797       && (GET_CODE (DECL_RTL (decl)) == MEM
 798           && (GET_CODE (XEXP (DECL_RTL (decl), 0)) == MEM
 799               || (GET_CODE (XEXP (DECL_RTL (decl), 0)) == REG
 800                   && (REGNO (XEXP (DECL_RTL (decl), 0))
 801                       > LAST_VIRTUAL_REGISTER))))
 802       /* We can't do this if the reference type's mode is not the same
 803          as the current mode, which means this may not work on mixed 32/64
 804          bit systems.  */
 805       && (new_type = build_reference_type (TREE_TYPE (decl))) != 0
 806       && TYPE_MODE (new_type) == GET_MODE (XEXP (DECL_RTL (decl), 0))
 807       /* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
 808          is also an indirect and of the same mode and if the object is
 809          readonly, the latter condition because we don't want to upset the
 810          handling of CICO_LIST.  */
 811       && (TREE_CODE (decl) != PARM_DECL
 812           || (GET_CODE (DECL_INCOMING_RTL (decl)) == MEM
 813               && (TYPE_MODE (new_type)
 814                   == GET_MODE (XEXP (DECL_INCOMING_RTL (decl), 0)))
 815               && TREE_READONLY (decl))))
 816     {
 817       new_type
 818         = build_qualified_type (new_type,
 819                                 (TYPE_QUALS (new_type) | TYPE_QUAL_CONST));
 820
 821       DECL_POINTS_TO_READONLY_P (decl) = TREE_READONLY (decl);
 822       DECL_BY_REF_P (decl) = 1;
 823       SET_DECL_RTL (decl, XEXP (DECL_RTL (decl), 0));
 824       TREE_TYPE (decl) = new_type;
 825       DECL_MODE (decl) = TYPE_MODE (new_type);
 826       DECL_ALIGN (decl) = TYPE_ALIGN (new_type);
 827       DECL_SIZE (decl) = TYPE_SIZE (new_type);
 828
 829       if (TREE_CODE (decl) == PARM_DECL)
 830         DECL_INCOMING_RTL (decl) = XEXP (DECL_INCOMING_RTL (decl), 0);
 831
 832       /* If DECL_INITIAL was set, it should be updated to show that
 833          the decl is initialized to the address of that thing.
 834          Otherwise, just set it to the address of this decl.
 835          It needs to be set so that GCC does not think the decl is
 836          unused.  */
 837       DECL_INITIAL (decl)
 838         = build1 (ADDR_EXPR, new_type,
 839                   DECL_INITIAL (decl) != 0 ? DECL_INITIAL (decl) : decl);
 840     }
 841 }
 842 \f
 843 /* Record the current code position in GNAT_NODE.  */
 844
 845 void
 846 record_code_position (gnat_node)
 847      Node_Id gnat_node;
 848 {
 849   if (global_bindings_p ())
 850     {
 851       /* Make a dummy entry so multiple things at the same location don't
 852          end up in the same place.  */
 853       add_pending_elaborations (NULL_TREE, NULL_TREE);
 854       save_gnu_tree (gnat_node, get_elaboration_location (), 1);
 855     }
 856   else
 857     /* Always emit another insn in case marking the last insn
 858        addressable needs some fixups and also for above reason.  */
 859     save_gnu_tree (gnat_node,
 860                    build (RTL_EXPR, void_type_node, NULL_TREE,
 861                           (tree) emit_note (0, NOTE_INSN_DELETED)),
 862                    1);
 863 }
 864
 865 /* Insert the code for GNAT_NODE at the position saved for that node.  */
 866
 867 void
 868 insert_code_for (gnat_node)
 869      Node_Id gnat_node;
 870 {
 871   if (global_bindings_p ())
 872     {
 873       push_pending_elaborations ();
 874       gnat_to_code (gnat_node);
 875       Check_Elaboration_Code_Allowed (gnat_node);
 876       insert_elaboration_list (get_gnu_tree (gnat_node));
 877       pop_pending_elaborations ();
 878     }
 879   else
 880     {
 881       rtx insns;
 882
 883       start_sequence ();
 884       mark_all_temps_used ();
 885       gnat_to_code (gnat_node);
 886       insns = get_insns ();
 887       end_sequence ();
 888       emit_insns_after (insns, RTL_EXPR_RTL (get_gnu_tree (gnat_node)));
 889     }
 890 }
 891
 892 /* Performs whatever initialization steps needed by the language-dependent
 893    lexical analyzer.
 894
 895    Define the additional tree codes here.  This isn't the best place to put
 896    it, but it's where g++ does it.  */
 897
 898 const char *
 899 init_parse (filename)
 900      const char *filename;
 901 {
 902   lang_expand_expr = gnat_expand_expr;
 903   lang_expand_constant = gnat_expand_constant;
 904
 905   memcpy ((char *) (tree_code_type + (int) LAST_AND_UNUSED_TREE_CODE),
 906           (char *) gnat_tree_code_type,
 907           ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
 908            * sizeof (char *)));
 909
 910   memcpy ((char *) (tree_code_length + (int) LAST_AND_UNUSED_TREE_CODE),
 911           (char *) gnat_tree_code_length,
 912           ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
 913            * sizeof (int)));
 914
 915   memcpy ((char *) (tree_code_name + (int) LAST_AND_UNUSED_TREE_CODE),
 916           (char *) gnat_tree_code_name,
 917           ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
 918            * sizeof (char *)));
 919
 920   return filename;
 921 }
 922
 923 void
 924 finish_parse ()
 925 {
 926 }
 927
 928 /* Sets some debug flags for the parsed. It does nothing here.  */
 929
 930 void
 931 set_yydebug (value)
 932      int value ATTRIBUTE_UNUSED;
 933 {
 934 }
 935
 936 #if 0
 937
 938 /* Return the alignment for GNAT_TYPE.  */
 939
 940 unsigned int
 941 get_type_alignment (gnat_type)
 942      Entity_Id gnat_type;
 943 {
 944   return TYPE_ALIGN (gnat_to_gnu_type (gnat_type)) / BITS_PER_UNIT;
 945 }
 946 #endif
 947
 948 /* Get the alias set corresponding to a type or expression.  */
 949
 950 static HOST_WIDE_INT
 951 gnat_get_alias_set (type)
 952      tree type;
 953 {
 954   /* If this is a padding type, use the type of the first field.  */
 955   if (TREE_CODE (type) == RECORD_TYPE
 956       && TYPE_IS_PADDING_P (type))
 957     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 958
 959   return -1;
 960 }
 961
 962 /* Set default attributes for functions.  We do nothing.  */
 963
 964 void
 965 insert_default_attributes (decl)
 966      tree decl ATTRIBUTE_UNUSED;
 967 {
 968 }
 969
 970 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 971    default.  */
 972
 973 int
 974 default_pass_by_ref (gnu_type)
 975      tree gnu_type;
 976 {
 977   CUMULATIVE_ARGS cum;
 978
 979   INIT_CUMULATIVE_ARGS (cum, NULL_TREE, NULL_RTX, 0);
 980
 981   /* We pass aggregates by reference if they are sufficiently large.  The
 982      choice of constant here is somewhat arbitrary.  We also pass by
 983      reference if the target machine would either pass or return by
 984      reference.  Strictly speaking, we need only check the return if this
 985      is an In Out parameter, but it's probably best to err on the side of
 986      passing more things by reference.  */
 987   return (0
 988 #ifdef FUNCTION_ARG_PASS_BY_REFERENCE
 989           || FUNCTION_ARG_PASS_BY_REFERENCE (cum, TYPE_MODE (gnu_type),
 990                                              gnu_type, 1)
 991 #endif
 992           || RETURN_IN_MEMORY (gnu_type)
 993           || (AGGREGATE_TYPE_P (gnu_type)
 994               && (! host_integerp (TYPE_SIZE (gnu_type), 1)
 995                   || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 996                                            8 * TYPE_ALIGN (gnu_type)))));
 997 }
 998
 999 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
1000    it should be passed by reference. */
1001
1002 int
1003 must_pass_by_ref (gnu_type)
1004      tree gnu_type;
1005 {
1006   /* We pass only unconstrained objects, those required by the language
1007      to be passed by reference, and objects of variable size.  The latter
1008      is more efficient, avoids problems with variable size temporaries,
1009      and does not produce compatibility problems with C, since C does
1010      not have such objects.  */
1011   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
1012           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
1013           || (TYPE_SIZE (gnu_type) != 0
1014               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
1015 }
1016 \f
1017 #if defined(MIPS_DEBUGGING_INFO) && defined(DWARF2_DEBUGGING_INFO)
1018
1019 /* Convert NAME, which is possibly an Ada name, back to standard Ada
1020    notation for SGI Workshop.  */
1021
1022 static char *
1023 convert_ada_name_to_qualified_name (name)
1024      char *name;
1025 {
1026   int len = strlen (name);
1027   char *new_name = xstrdup (name);
1028   char *buf;
1029   int i, start;
1030   char *qual_name_suffix = 0;
1031   char *p;
1032
1033   if (len <= 3 || use_gnu_debug_info_extensions)
1034     {
1035       free (new_name);
1036       return name;
1037     }
1038
1039   /* Find the position of the first "__" after the first character of
1040      NAME.  This is the same as calling strstr except that we can't assume
1041      the host has that function. We start after the first character so
1042      we don't eliminate leading "__": these are emitted only by C
1043      programs and are not qualified names */
1044   for (p = (char *) index (&name[1], '_'); p != 0;
1045        p = (char *) index (p+1, '_'))
1046     if (p[1] == '_')
1047       {
1048         qual_name_suffix = p;
1049         break;
1050       }
1051
1052   if (qual_name_suffix == 0)
1053     {
1054       free (new_name);
1055       return name;
1056     }
1057
1058   start = qual_name_suffix - name;
1059   buf = new_name + start;
1060
1061   for (i = start; i < len; i++)
1062     {
1063       if (name[i] == '_' && name[i + 1] == '_')
1064         {
1065           if (islower (name[i + 2]))
1066             {
1067               *buf++ = '.';
1068               *buf++ = name[i + 2];
1069               i += 2;
1070             }
1071           else if (name[i + 2] == '_' && islower (name[i + 3]))
1072             {
1073               /* convert foo___c___XVN to foo.c___XVN */
1074               *buf++ = '.';
1075               *buf++ = name[i + 3];
1076               i += 3;
1077             }
1078           else if (name[i + 2] == 'T')
1079             {
1080               /* convert foo__TtypeS to foo.__TTypeS */
1081               *buf++ = '.';
1082               *buf++ = '_';
1083               *buf++ = '_';
1084               *buf++ = 'T';
1085               i += 3;
1086             }
1087           else
1088             *buf++ = name[i];
1089         }
1090       else
1091         *buf++ = name[i];
1092     }
1093
1094   *buf = 0;
1095   return new_name;
1096 }
1097 #endif
1098
1099 /* Emit a label UNITNAME_LABEL and specify that it is part of source
1100    file FILENAME.  If this is being written for SGI's Workshop
1101    debugger, and we are writing Dwarf2 debugging information, add
1102    additional debug info.  */
1103
1104 void
1105 emit_unit_label (unitname_label, filename)
1106      char *unitname_label;
1107      char *filename ATTRIBUTE_UNUSED;
1108 {
1109   ASM_GLOBALIZE_LABEL (asm_out_file, unitname_label);
1110   ASM_OUTPUT_LABEL (asm_out_file, unitname_label);
1111 }