gcc/ada/misc.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                 M I S C                                  *
   6  *                                                                          *
   7  *                           C Implementation File                          *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2004 Free Software Foundation, Inc.          *
  10  *                                                                          *
  11  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  12  * terms of the  GNU General Public License as published  by the Free Soft- *
  13  * ware  Foundation;  either version 2,  or (at your option) any later ver- *
  14  * sion.  GNAT is distributed in the hope that it will be useful, but WITH- *
  15  * OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY *
  16  * or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License *
  17  * for  more details.  You should have  received  a copy of the GNU General *
  18  * Public License  distributed with GNAT;  see file COPYING.  If not, write *
  19  * to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, *
  20  * MA 02111-1307, USA.                                                      *
  21  *                                                                          *
  22  * As a  special  exception,  if you  link  this file  with other  files to *
  23  * produce an executable,  this file does not by itself cause the resulting *
  24  * executable to be covered by the GNU General Public License. This except- *
  25  * ion does not  however invalidate  any other reasons  why the  executable *
  26  * file might be covered by the  GNU Public License.                        *
  27  *                                                                          *
  28  * GNAT was originally developed  by the GNAT team at  New York University. *
  29  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  30  *                                                                          *
  31  ****************************************************************************/
  32
  33 /* This file contains parts of the compiler that are required for interfacing
  34    with GCC but otherwise do nothing and parts of Gigi that need to know
  35    about RTL.  */
  36
  37 #include "config.h"
  38 #include "system.h"
  39 #include "coretypes.h"
  40 #include "tm.h"
  41 #include "tree.h"
  42 #include "real.h"
  43 #include "rtl.h"
  44 #include "errors.h"
  45 #include "diagnostic.h"
  46 #include "expr.h"
  47 #include "libfuncs.h"
  48 #include "ggc.h"
  49 #include "flags.h"
  50 #include "debug.h"
  51 #include "cgraph.h"
  52 #include "tree-inline.h"
  53 #include "insn-codes.h"
  54 #include "insn-flags.h"
  55 #include "insn-config.h"
  56 #include "optabs.h"
  57 #include "recog.h"
  58 #include "toplev.h"
  59 #include "output.h"
  60 #include "except.h"
  61 #include "tm_p.h"
  62 #include "langhooks.h"
  63 #include "langhooks-def.h"
  64 #include "target.h"
  65
  66 #include "ada.h"
  67 #include "types.h"
  68 #include "atree.h"
  69 #include "elists.h"
  70 #include "namet.h"
  71 #include "nlists.h"
  72 #include "stringt.h"
  73 #include "uintp.h"
  74 #include "fe.h"
  75 #include "sinfo.h"
  76 #include "einfo.h"
  77 #include "ada-tree.h"
  78 #include "gigi.h"
  79 #include "adadecode.h"
  80 #include "opts.h"
  81 #include "options.h"
  82
  83 extern FILE *asm_out_file;
  84
  85 /* The largest alignment, in bits, that is needed for using the widest
  86    move instruction.  */
  87 unsigned int largest_move_alignment;
  88
  89 static bool gnat_init                   (void);
  90 static void gnat_finish_incomplete_decl (tree);
  91 static unsigned int gnat_init_options   (unsigned int, const char **);
  92 static int gnat_handle_option           (size_t, const char *, int);
  93 static bool gnat_post_options           (const char **);
  94 static HOST_WIDE_INT gnat_get_alias_set (tree);
  95 static void gnat_print_decl             (FILE *, tree, int);
  96 static void gnat_print_type             (FILE *, tree, int);
  97 static int gnat_types_compatible_p      (tree, tree);
  98 static const char *gnat_printable_name  (tree, int);
  99 static tree gnat_eh_runtime_type        (tree);
 100 static int gnat_eh_type_covers          (tree, tree);
 101 static void gnat_parse_file             (int);
 102 static rtx gnat_expand_expr             (tree, rtx, enum machine_mode, int,
 103                                          rtx *);
 104 static void gnat_expand_body            (tree);
 105 static void internal_error_function     (const char *, va_list *);
 106 static void gnat_adjust_rli             (record_layout_info);
 107 static tree gnat_type_max_size          (tree);
 108
 109 /* Definitions for our language-specific hooks.  */
 110
 111 #undef  LANG_HOOKS_NAME
 112 #define LANG_HOOKS_NAME                 "GNU Ada"
 113 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 114 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 115 #undef  LANG_HOOKS_INIT
 116 #define LANG_HOOKS_INIT                 gnat_init
 117 #undef  LANG_HOOKS_INIT_OPTIONS
 118 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 119 #undef  LANG_HOOKS_HANDLE_OPTION
 120 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
 121 #undef  LANG_HOOKS_POST_OPTIONS
 122 #define LANG_HOOKS_POST_OPTIONS         gnat_post_options
 123 #undef  LANG_HOOKS_PARSE_FILE
 124 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 125 #undef  LANG_HOOKS_HASH_TYPES
 126 #define LANG_HOOKS_HASH_TYPES           false
 127 #undef  LANG_HOOKS_GETDECLS
 128 #define LANG_HOOKS_GETDECLS             lhd_return_null_tree_v
 129 #undef  LANG_HOOKS_PUSHDECL
 130 #define LANG_HOOKS_PUSHDECL             lhd_return_tree
 131 #undef  LANG_HOOKS_FINISH_INCOMPLETE_DECL
 132 #define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
 133 #undef  LANG_HOOKS_GET_ALIAS_SET
 134 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 135 #undef  LANG_HOOKS_EXPAND_EXPR
 136 #define LANG_HOOKS_EXPAND_EXPR          gnat_expand_expr
 137 #undef  LANG_HOOKS_MARK_ADDRESSABLE
 138 #define LANG_HOOKS_MARK_ADDRESSABLE     gnat_mark_addressable
 139 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
 140 #define LANG_HOOKS_TRUTHVALUE_CONVERSION gnat_truthvalue_conversion
 141 #undef  LANG_HOOKS_PRINT_DECL
 142 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 143 #undef  LANG_HOOKS_PRINT_TYPE
 144 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 145 #undef  LANG_HOOKS_TYPES_COMPATIBLE_P
 146 #define LANG_HOOKS_TYPES_COMPATIBLE_P   gnat_types_compatible_p
 147 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 148 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 149 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 150 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 151 #undef  LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
 152 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gnat_expand_body
 153 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 154 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 155 #undef  LANG_HOOKS_TYPE_FOR_MODE
 156 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 157 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 158 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 159 #undef  LANG_HOOKS_SIGNED_TYPE
 160 #define LANG_HOOKS_SIGNED_TYPE          gnat_signed_type
 161 #undef  LANG_HOOKS_UNSIGNED_TYPE
 162 #define LANG_HOOKS_UNSIGNED_TYPE        gnat_unsigned_type
 163 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
 164 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gnat_signed_or_unsigned_type
 165
 166 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 167
 168 /* Tables describing GCC tree codes used only by GNAT.
 169
 170    Table indexed by tree code giving a string containing a character
 171    classifying the tree code.  Possibilities are
 172    t, d, s, c, r, <, 1 and 2.  See cp-tree.def for details.  */
 173
 174 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
 175
 176 const enum tree_code_class tree_code_type[] = {
 177 #include "tree.def"
 178   tcc_exceptional,
 179 #include "ada-tree.def"
 180 };
 181 #undef DEFTREECODE
 182
 183 /* Table indexed by tree code giving number of expression
 184    operands beyond the fixed part of the node structure.
 185    Not used for types or decls.  */
 186
 187 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
 188
 189 const unsigned char tree_code_length[] = {
 190 #include "tree.def"
 191   0,
 192 #include "ada-tree.def"
 193 };
 194 #undef DEFTREECODE
 195
 196 /* Names of tree components.
 197    Used for printing out the tree and error messages.  */
 198 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
 199
 200 const char *const tree_code_name[] = {
 201 #include "tree.def"
 202   "@@dummy",
 203 #include "ada-tree.def"
 204 };
 205 #undef DEFTREECODE
 206
 207 /* Command-line argc and argv.
 208    These variables are global, since they are imported and used in
 209    back_end.adb  */
 210
 211 unsigned int save_argc;
 212 const char **save_argv;
 213
 214 /* gnat standard argc argv */
 215
 216 extern int gnat_argc;
 217 extern char **gnat_argv;
 218
 219 \f
 220 /* Declare functions we use as part of startup.  */
 221 extern void __gnat_initialize   (void);
 222 extern void adainit             (void);
 223 extern void _ada_gnat1drv       (void);
 224
 225 /* The parser for the language.  For us, we process the GNAT tree.  */
 226
 227 static void
 228 gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
 229 {
 230   /* call the target specific initializations */
 231   __gnat_initialize();
 232
 233   /* Call the front-end elaboration procedures */
 234   adainit ();
 235
 236   /* Call the front end */
 237   _ada_gnat1drv ();
 238
 239   cgraph_finalize_compilation_unit ();
 240   cgraph_optimize ();
 241 }
 242
 243 /* Decode all the language specific options that cannot be decoded by GCC.
 244    The option decoding phase of GCC calls this routine on the flags that
 245    it cannot decode.  This routine returns the number of consecutive arguments
 246    from ARGV that it successfully decoded; 0 indicates failure.  */
 247
 248 static int
 249 gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
 250 {
 251   const struct cl_option *option = &cl_options[scode];
 252   enum opt_code code = (enum opt_code) scode;
 253   char *q;
 254   unsigned int i;
 255
 256   if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
 257     {
 258       error ("missing argument to \"-%s\"", option->opt_text);
 259       return 1;
 260     }
 261
 262   switch (code)
 263     {
 264     default:
 265       abort ();
 266
 267     case OPT_I:
 268       q = xmalloc (sizeof("-I") + strlen (arg));
 269       strcpy (q, "-I");
 270       strcat (q, arg);
 271       gnat_argv[gnat_argc] = q;
 272       gnat_argc++;
 273       break;
 274
 275       /* All front ends are expected to accept this.  */
 276     case OPT_Wall:
 277       /* These are used in the GCC Makefile.  */
 278     case OPT_Wmissing_prototypes:
 279     case OPT_Wstrict_prototypes:
 280     case OPT_Wwrite_strings:
 281     case OPT_Wlong_long:
 282       break;
 283
 284       /* This is handled by the front-end.  */
 285     case OPT_nostdinc:
 286       break;
 287
 288     case OPT_nostdlib:
 289       gnat_argv[gnat_argc] = xstrdup ("-nostdlib");
 290       gnat_argc++;
 291       break;
 292
 293     case OPT_fRTS:
 294       gnat_argv[gnat_argc] = xstrdup ("-fRTS");
 295       gnat_argc++;
 296       break;
 297
 298     case OPT_gant:
 299       warning ("%<-gnat%> misspelled as %<-gant%>");
 300
 301       /* ... fall through ... */
 302
 303     case OPT_gnat:
 304       /* Recopy the switches without the 'gnat' prefix.  */
 305       gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2);
 306       gnat_argv[gnat_argc][0] = '-';
 307       strcpy (gnat_argv[gnat_argc] + 1, arg);
 308       gnat_argc++;
 309
 310       if (arg[0] == 'O')
 311         for (i = 1; i < save_argc - 1; i++)
 312           if (!strncmp (save_argv[i], "-gnatO", 6))
 313             if (save_argv[++i][0] != '-')
 314               {
 315                 /* Preserve output filename as GCC doesn't save it for GNAT. */
 316                 gnat_argv[gnat_argc] = xstrdup (save_argv[i]);
 317                 gnat_argc++;
 318                 break;
 319               }
 320       break;
 321     }
 322
 323   return 1;
 324 }
 325
 326 /* Initialize for option processing.  */
 327
 328 static unsigned int
 329 gnat_init_options (unsigned int argc, const char **argv)
 330 {
 331   /* Initialize gnat_argv with save_argv size.  */
 332   gnat_argv = (char **) xmalloc ((argc + 1) * sizeof (argv[0]));
 333   gnat_argv[0] = xstrdup (argv[0]);     /* name of the command */
 334   gnat_argc = 1;
 335
 336   save_argc = argc;
 337   save_argv = argv;
 338
 339   /* Uninitialized really means uninitialized in Ada.  */
 340   flag_zero_initialized_in_bss = 0;
 341
 342   return CL_Ada;
 343 }
 344
 345 /* Post-switch processing.  */
 346
 347 bool
 348 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
 349 {
 350   flag_inline_trees = 1;
 351
 352   if (!flag_no_inline)
 353     flag_no_inline = 1;
 354   if (flag_inline_functions)
 355     flag_inline_trees = 2;
 356
 357   return false;
 358 }
 359
 360 /* Here is the function to handle the compiler error processing in GCC.  */
 361
 362 static void
 363 internal_error_function (const char *msgid, va_list *ap)
 364 {
 365   char buffer[1000];            /* Assume this is big enough.  */
 366   char *p;
 367   String_Template temp;
 368   Fat_Pointer fp;
 369
 370   vsprintf (buffer, msgid, *ap);
 371
 372   /* Go up to the first newline.  */
 373   for (p = buffer; *p; p++)
 374     if (*p == '\n')
 375       {
 376         *p = '\0';
 377         break;
 378       }
 379
 380   temp.Low_Bound = 1, temp.High_Bound = strlen (buffer);
 381   fp.Array = buffer, fp.Bounds = &temp;
 382
 383   Current_Error_Node = error_gnat_node;
 384   Compiler_Abort (fp, -1);
 385 }
 386
 387 /* Perform all the initialization steps that are language-specific.  */
 388
 389 static bool
 390 gnat_init (void)
 391 {
 392   /* Initialize translations and the outer statement group.  */
 393   gnat_init_stmt_group ();
 394
 395   /* Performs whatever initialization steps needed by the language-dependent
 396      lexical analyzer.  */
 397   gnat_init_decl_processing ();
 398
 399   /* Add the input filename as the last argument.  */
 400   gnat_argv[gnat_argc] = (char *) main_input_filename;
 401   gnat_argc++;
 402   gnat_argv[gnat_argc] = 0;
 403
 404   global_dc->internal_error = &internal_error_function;
 405
 406   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 407   internal_reference_types ();
 408
 409   set_lang_adjust_rli (gnat_adjust_rli);
 410
 411   return true;
 412 }
 413
 414 /* This function is called indirectly from toplev.c to handle incomplete
 415    declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero.  To be precise,
 416    compile_file in toplev.c makes an indirect call through the function pointer
 417    incomplete_decl_finalize_hook which is initialized to this routine in
 418    init_decl_processing.  */
 419
 420 static void
 421 gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED)
 422 {
 423   abort ();
 424 }
 425 \f
 426 /* Compute the alignment of the largest mode that can be used for copying
 427    objects.  */
 428
 429 void
 430 gnat_compute_largest_alignment (void)
 431 {
 432   enum machine_mode mode;
 433
 434   for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode;
 435        mode = GET_MODE_WIDER_MODE (mode))
 436     if (mov_optab->handlers[(int) mode].insn_code != CODE_FOR_nothing)
 437       largest_move_alignment = MIN (BIGGEST_ALIGNMENT,
 438                                     MAX (largest_move_alignment,
 439                                          GET_MODE_ALIGNMENT (mode)));
 440 }
 441
 442 /* If we are using the GCC mechanism to process exception handling, we
 443    have to register the personality routine for Ada and to initialize
 444    various language dependent hooks.  */
 445
 446 void
 447 gnat_init_gcc_eh (void)
 448 {
 449   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 450      though. This could for instance lead to the emission of tables with
 451      references to symbols (such as the Ada eh personality routine) within
 452      libraries we won't link against.  */
 453   if (No_Exception_Handlers_Set ())
 454     return;
 455
 456   /* Tell GCC we are handling cleanup actions through exception propagation.
 457      This opens possibilities that we don't take advantage of yet, but is
 458      nonetheless necessary to ensure that fixup code gets assigned to the
 459      right exception regions.  */
 460   using_eh_for_cleanups ();
 461
 462   eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality");
 463   lang_eh_type_covers = gnat_eh_type_covers;
 464   lang_eh_runtime_type = gnat_eh_runtime_type;
 465
 466   /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
 467      the generation of the necessary exception runtime tables. The second one
 468      is useful for two reasons: 1/ we map some asynchronous signals like SEGV
 469      to exceptions, so we need to ensure that the insns which can lead to such
 470      signals are correctly attached to the exception region they pertain to,
 471      2/ Some calls to pure subprograms are handled as libcall blocks and then
 472      marked as "cannot trap" if the flag is not set (see emit_libcall_block).
 473      We should not let this be since it is possible for such calls to actually
 474      raise in Ada.  */
 475
 476   flag_exceptions = 1;
 477   flag_non_call_exceptions = 1;
 478
 479   init_eh ();
 480 #ifdef DWARF2_UNWIND_INFO
 481   if (dwarf2out_do_frame ())
 482     dwarf2out_frame_init ();
 483 #endif
 484 }
 485
 486 /* Language hooks, first one to print language-specific items in a DECL.  */
 487
 488 static void
 489 gnat_print_decl (FILE *file, tree node, int indent)
 490 {
 491   switch (TREE_CODE (node))
 492     {
 493     case CONST_DECL:
 494       print_node (file, "const_corresponding_var",
 495                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 496       break;
 497
 498     case FIELD_DECL:
 499       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 500                   indent + 4);
 501       break;
 502
 503     default:
 504       break;
 505     }
 506 }
 507
 508 static void
 509 gnat_print_type (FILE *file, tree node, int indent)
 510 {
 511   switch (TREE_CODE (node))
 512     {
 513     case FUNCTION_TYPE:
 514       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 515       break;
 516
 517     case ENUMERAL_TYPE:
 518       print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
 519       break;
 520
 521     case INTEGER_TYPE:
 522       if (TYPE_MODULAR_P (node))
 523         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 524       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 525         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 526                     indent + 4);
 527       else if (TYPE_VAX_FLOATING_POINT_P (node))
 528         ;
 529       else
 530         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 531
 532       print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
 533       break;
 534
 535     case ARRAY_TYPE:
 536       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 537       break;
 538
 539     case RECORD_TYPE:
 540       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 541         print_node (file, "unconstrained array",
 542                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 543       else
 544         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 545       break;
 546
 547     case UNION_TYPE:
 548     case QUAL_UNION_TYPE:
 549       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 550       break;
 551
 552     default:
 553       break;
 554     }
 555 }
 556
 557 /* We consider two types compatible if they have the same main variant,
 558    but we also consider two array types compatible if they have the same
 559    component type and bounds.
 560
 561    ??? We may also want to generalize to considering lots of integer types
 562    compatible, but we need to understand the effects of alias sets first.  */
 563
 564 static int
 565 gnat_types_compatible_p (tree x, tree y)
 566 {
 567   if (TREE_CODE (x) == ARRAY_TYPE && TREE_CODE (y) == ARRAY_TYPE
 568       && gnat_types_compatible_p (TREE_TYPE (x), TREE_TYPE (y))
 569       && operand_equal_p (TYPE_MIN_VALUE (TYPE_DOMAIN (x)),
 570                           TYPE_MIN_VALUE (TYPE_DOMAIN (y)), 0)
 571       && operand_equal_p (TYPE_MAX_VALUE (TYPE_DOMAIN (x)),
 572                           TYPE_MAX_VALUE (TYPE_DOMAIN (y)), 0))
 573     return 1;
 574   else
 575     return TYPE_MAIN_VARIANT (x) == TYPE_MAIN_VARIANT (y);
 576 }
 577
 578 static const char *
 579 gnat_printable_name (tree decl, int verbosity)
 580 {
 581   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 582   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 583
 584   __gnat_decode (coded_name, ada_name, 0);
 585
 586   if (verbosity == 2)
 587     {
 588       Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
 589       ada_name = Name_Buffer;
 590     }
 591
 592   return (const char *) ada_name;
 593 }
 594
 595 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 596    here are  and NULL_EXPR.  */
 597
 598 static rtx
 599 gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode,
 600                   int modifier, rtx *alt_rtl)
 601 {
 602   tree type = TREE_TYPE (exp);
 603   tree new;
 604
 605   /* If this is a statement, call the expansion routine for statements.  */
 606   if (IS_STMT (exp))
 607     {
 608       gnat_expand_stmt (exp);
 609       return const0_rtx;
 610     }
 611
 612   /* Update EXP to be the new expression to expand.  */
 613   switch (TREE_CODE (exp))
 614     {
 615 #if 0
 616     case ALLOCATE_EXPR:
 617       return
 618         allocate_dynamic_stack_space
 619           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 620                         EXPAND_NORMAL),
 621            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 622 #endif
 623
 624     case UNCONSTRAINED_ARRAY_REF:
 625       /* If we are evaluating just for side-effects, just evaluate our
 626          operand.  Otherwise, abort since this code should never appear
 627          in a tree to be evaluated (objects aren't unconstrained).  */
 628       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 629         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 630                             VOIDmode, modifier);
 631
 632       /* ... fall through ... */
 633
 634     default:
 635       abort ();
 636     }
 637
 638   return expand_expr_real (new, target, tmode, modifier, alt_rtl);
 639 }
 640
 641 /* Generate the RTL for the body of GNU_DECL.  */
 642
 643 static void
 644 gnat_expand_body (tree gnu_decl)
 645 {
 646   if (!DECL_INITIAL (gnu_decl) || DECL_INITIAL (gnu_decl) == error_mark_node)
 647     return;
 648
 649   tree_rest_of_compilation (gnu_decl);
 650 }
 651
 652 /* Adjusts the RLI used to layout a record after all the fields have been
 653    added.  We only handle the packed case and cause it to use the alignment
 654    that will pad the record at the end.  */
 655
 656 static void
 657 gnat_adjust_rli (record_layout_info rli ATTRIBUTE_UNUSED)
 658 {
 659 #if 0
 660   /* ??? This code seems to have no actual effect; record_align should already
 661      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 662   unsigned int record_align = rli->unpadded_align;
 663   tree field;
 664
 665   /* If an alignment has been specified, don't use anything larger unless we
 666      have to.  */
 667   if (TYPE_ALIGN (rli->t) != 0 && TYPE_ALIGN (rli->t) < record_align)
 668     record_align = MAX (rli->record_align, TYPE_ALIGN (rli->t));
 669
 670   /* If any fields have variable size, we need to force the record to be at
 671      least as aligned as the alignment of that type.  */
 672   for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field))
 673     if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST)
 674       record_align = MAX (record_align, DECL_ALIGN (field));
 675
 676   if (TYPE_PACKED (rli->t))
 677     rli->record_align = record_align;
 678 #endif
 679 }
 680 \f
 681 /* These routines are used in conjunction with GCC exception handling.  */
 682
 683 /* Map compile-time to run-time tree for GCC exception handling scheme.  */
 684
 685 static tree
 686 gnat_eh_runtime_type (tree type)
 687 {
 688   return type;
 689 }
 690
 691 /* Return true if type A catches type B. Callback for flow analysis from
 692    the exception handling part of the back-end.  */
 693
 694 static int
 695 gnat_eh_type_covers (tree a, tree b)
 696 {
 697   /* a catches b if they represent the same exception id or if a
 698      is an "others".
 699
 700      ??? integer_zero_node for "others" is hardwired in too many places
 701      currently.  */
 702   return (a == b || a == integer_zero_node);
 703 }
 704 \f
 705 /* Get the alias set corresponding to a type or expression.  */
 706
 707 static HOST_WIDE_INT
 708 gnat_get_alias_set (tree type)
 709 {
 710   /* If this is a padding type, use the type of the first field.  */
 711   if (TREE_CODE (type) == RECORD_TYPE
 712       && TYPE_IS_PADDING_P (type))
 713     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 714
 715   /* If the type is an unconstrained array, use the type of the
 716      self-referential array we make.  */
 717   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 718     return
 719       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 720
 721
 722   return -1;
 723 }
 724
 725 /* GNU_TYPE is a type.  Return its maxium size in bytes, if known.  */
 726
 727 static tree
 728 gnat_type_max_size (gnu_type)
 729      tree gnu_type;
 730 {
 731   return max_size (TYPE_SIZE_UNIT (gnu_type), true);
 732 }
 733
 734 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 735    default.  */
 736
 737 bool
 738 default_pass_by_ref (tree gnu_type)
 739 {
 740   /* We pass aggregates by reference if they are sufficiently large.  The
 741      choice of constant here is somewhat arbitrary.  We also pass by
 742      reference if the target machine would either pass or return by
 743      reference.  Strictly speaking, we need only check the return if this
 744      is an In Out parameter, but it's probably best to err on the side of
 745      passing more things by reference.  */
 746
 747   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1))
 748     return true;
 749
 750   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 751     return true;
 752
 753   if (AGGREGATE_TYPE_P (gnu_type)
 754       && (!host_integerp (TYPE_SIZE (gnu_type), 1)
 755           || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 756                                    8 * TYPE_ALIGN (gnu_type))))
 757     return true;
 758
 759   return false;
 760 }
 761
 762 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 763    it should be passed by reference. */
 764
 765 bool
 766 must_pass_by_ref (tree gnu_type)
 767 {
 768   /* We pass only unconstrained objects, those required by the language
 769      to be passed by reference, and objects of variable size.  The latter
 770      is more efficient, avoids problems with variable size temporaries,
 771      and does not produce compatibility problems with C, since C does
 772      not have such objects.  */
 773   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 774           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 775           || (TYPE_SIZE (gnu_type)
 776               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 777 }
 778
 779 /* This function is called by the front end to enumerate all the supported
 780    modes for the machine.  We pass a function which is called back with
 781    the following integer parameters:
 782
 783    FLOAT_P      nonzero if this represents a floating-point mode
 784    COMPLEX_P    nonzero is this represents a complex mode
 785    COUNT        count of number of items, nonzero for vector mode
 786    PRECISION    number of bits in data representation
 787    MANTISSA     number of bits in mantissa, if FP and known, else zero.
 788    SIZE         number of bits used to store data
 789    ALIGN        number of bits to which mode is aligned.  */
 790
 791 void
 792 enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
 793 {
 794   enum machine_mode i;
 795
 796   for (i = 0; i < NUM_MACHINE_MODES; i++)
 797     {
 798       enum machine_mode j;
 799       bool float_p = 0;
 800       bool complex_p = 0;
 801       bool vector_p = 0;
 802       bool skip_p = 0;
 803       int mantissa = 0;
 804       enum machine_mode inner_mode = i;
 805
 806       switch (GET_MODE_CLASS (i))
 807         {
 808         case MODE_INT:
 809           break;
 810         case MODE_FLOAT:
 811           float_p = 1;
 812           break;
 813         case MODE_COMPLEX_INT:
 814           complex_p = 1;
 815           inner_mode = GET_MODE_INNER (i);
 816           break;
 817         case MODE_COMPLEX_FLOAT:
 818           float_p = 1;
 819           complex_p = 1;
 820           inner_mode = GET_MODE_INNER (i);
 821           break;
 822         case MODE_VECTOR_INT:
 823           vector_p = 1;
 824           inner_mode = GET_MODE_INNER (i);
 825           break;
 826         case MODE_VECTOR_FLOAT:
 827           float_p = 1;
 828           vector_p = 1;
 829           inner_mode = GET_MODE_INNER (i);
 830           break;
 831         default:
 832           skip_p = 1;
 833         }
 834
 835       /* Skip this mode if it's one the front end doesn't need to know about
 836          (e.g., the CC modes) or if there is no add insn for that mode (or
 837          any wider mode), meaning it is not supported by the hardware.  If
 838          this a complex or vector mode, we care about the inner mode.  */
 839       for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
 840         if (add_optab->handlers[j].insn_code != CODE_FOR_nothing)
 841           break;
 842
 843       if (float_p)
 844         {
 845           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 846
 847           mantissa = fmt->p * fmt->log2_b;
 848         }
 849
 850       if (!skip_p && j != VOIDmode)
 851         (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
 852               GET_MODE_BITSIZE (i), mantissa,
 853               GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
 854     }
 855 }
 856
 857 int
 858 fp_prec_to_size (int prec)
 859 {
 860   enum machine_mode mode;
 861
 862   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 863        mode = GET_MODE_WIDER_MODE (mode))
 864     if (GET_MODE_PRECISION (mode) == prec)
 865       return GET_MODE_BITSIZE (mode);
 866
 867   abort ();
 868 }
 869
 870 int
 871 fp_size_to_prec (int size)
 872 {
 873   enum machine_mode mode;
 874
 875   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 876        mode = GET_MODE_WIDER_MODE (mode))
 877     if (GET_MODE_BITSIZE (mode) == size)
 878       return GET_MODE_PRECISION (mode);
 879
 880   abort ();
 881 }