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 char tree_code_type[] = {
 177 #include "tree.def"
 178   'x',
 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     {
 356       flag_inline_trees = 2;
 357       flag_inline_functions = 0;
 358     }
 359
 360   return false;
 361 }
 362
 363 /* Here is the function to handle the compiler error processing in GCC.  */
 364
 365 static void
 366 internal_error_function (const char *msgid, va_list *ap)
 367 {
 368   char buffer[1000];            /* Assume this is big enough.  */
 369   char *p;
 370   String_Template temp;
 371   Fat_Pointer fp;
 372
 373   vsprintf (buffer, msgid, *ap);
 374
 375   /* Go up to the first newline.  */
 376   for (p = buffer; *p; p++)
 377     if (*p == '\n')
 378       {
 379         *p = '\0';
 380         break;
 381       }
 382
 383   temp.Low_Bound = 1, temp.High_Bound = strlen (buffer);
 384   fp.Array = buffer, fp.Bounds = &temp;
 385
 386   Current_Error_Node = error_gnat_node;
 387   Compiler_Abort (fp, -1);
 388 }
 389
 390 /* Perform all the initialization steps that are language-specific.  */
 391
 392 static bool
 393 gnat_init (void)
 394 {
 395   /* Initialize translations and the outer statement group.  */
 396   gnat_init_stmt_group ();
 397
 398   /* Performs whatever initialization steps needed by the language-dependent
 399      lexical analyzer.  */
 400   gnat_init_decl_processing ();
 401
 402   /* Add the input filename as the last argument.  */
 403   gnat_argv[gnat_argc] = (char *) main_input_filename;
 404   gnat_argc++;
 405   gnat_argv[gnat_argc] = 0;
 406
 407   global_dc->internal_error = &internal_error_function;
 408
 409   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 410   internal_reference_types ();
 411
 412   set_lang_adjust_rli (gnat_adjust_rli);
 413
 414   return true;
 415 }
 416
 417 /* This function is called indirectly from toplev.c to handle incomplete
 418    declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero.  To be precise,
 419    compile_file in toplev.c makes an indirect call through the function pointer
 420    incomplete_decl_finalize_hook which is initialized to this routine in
 421    init_decl_processing.  */
 422
 423 static void
 424 gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED)
 425 {
 426   abort ();
 427 }
 428 \f
 429 /* Compute the alignment of the largest mode that can be used for copying
 430    objects.  */
 431
 432 void
 433 gnat_compute_largest_alignment (void)
 434 {
 435   enum machine_mode mode;
 436
 437   for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode;
 438        mode = GET_MODE_WIDER_MODE (mode))
 439     if (mov_optab->handlers[(int) mode].insn_code != CODE_FOR_nothing)
 440       largest_move_alignment = MIN (BIGGEST_ALIGNMENT,
 441                                     MAX (largest_move_alignment,
 442                                          GET_MODE_ALIGNMENT (mode)));
 443 }
 444
 445 /* If we are using the GCC mechanism to process exception handling, we
 446    have to register the personality routine for Ada and to initialize
 447    various language dependent hooks.  */
 448
 449 void
 450 gnat_init_gcc_eh (void)
 451 {
 452   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 453      though. This could for instance lead to the emission of tables with
 454      references to symbols (such as the Ada eh personality routine) within
 455      libraries we won't link against.  */
 456   if (No_Exception_Handlers_Set ())
 457     return;
 458
 459   /* Tell GCC we are handling cleanup actions through exception propagation.
 460      This opens possibilities that we don't take advantage of yet, but is
 461      nonetheless necessary to ensure that fixup code gets assigned to the
 462      right exception regions.  */
 463   using_eh_for_cleanups ();
 464
 465   eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality");
 466   lang_eh_type_covers = gnat_eh_type_covers;
 467   lang_eh_runtime_type = gnat_eh_runtime_type;
 468
 469   /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
 470      the generation of the necessary exception runtime tables. The second one
 471      is useful for two reasons: 1/ we map some asynchronous signals like SEGV
 472      to exceptions, so we need to ensure that the insns which can lead to such
 473      signals are correctly attached to the exception region they pertain to,
 474      2/ Some calls to pure subprograms are handled as libcall blocks and then
 475      marked as "cannot trap" if the flag is not set (see emit_libcall_block).
 476      We should not let this be since it is possible for such calls to actually
 477      raise in Ada.  */
 478
 479   flag_exceptions = 1;
 480   flag_non_call_exceptions = 1;
 481
 482   init_eh ();
 483 #ifdef DWARF2_UNWIND_INFO
 484   if (dwarf2out_do_frame ())
 485     dwarf2out_frame_init ();
 486 #endif
 487 }
 488
 489 /* Language hooks, first one to print language-specific items in a DECL.  */
 490
 491 static void
 492 gnat_print_decl (FILE *file, tree node, int indent)
 493 {
 494   switch (TREE_CODE (node))
 495     {
 496     case CONST_DECL:
 497       print_node (file, "const_corresponding_var",
 498                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 499       break;
 500
 501     case FIELD_DECL:
 502       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 503                   indent + 4);
 504       break;
 505
 506     default:
 507       break;
 508     }
 509 }
 510
 511 static void
 512 gnat_print_type (FILE *file, tree node, int indent)
 513 {
 514   switch (TREE_CODE (node))
 515     {
 516     case FUNCTION_TYPE:
 517       print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4);
 518       break;
 519
 520     case ENUMERAL_TYPE:
 521       print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
 522       break;
 523
 524     case INTEGER_TYPE:
 525       if (TYPE_MODULAR_P (node))
 526         print_node (file, "modulus", TYPE_MODULUS (node), indent + 4);
 527       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 528         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 529                     indent + 4);
 530       else if (TYPE_VAX_FLOATING_POINT_P (node))
 531         ;
 532       else
 533         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 534
 535       print_node (file, "RM size", TYPE_RM_SIZE_NUM (node), indent + 4);
 536       break;
 537
 538     case ARRAY_TYPE:
 539       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 540       break;
 541
 542     case RECORD_TYPE:
 543       if (TYPE_IS_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 544         print_node (file, "unconstrained array",
 545                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 546       else
 547         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 548       break;
 549
 550     case UNION_TYPE:
 551     case QUAL_UNION_TYPE:
 552       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 553       break;
 554
 555     default:
 556       break;
 557     }
 558 }
 559
 560 /* We consider two types compatible if they have the same main variant,
 561    but we also consider two array types compatible if they have the same
 562    component type and bounds.
 563
 564    ??? We may also want to generalize to considering lots of integer types
 565    compatible, but we need to understand the effects of alias sets first.  */
 566
 567 static int
 568 gnat_types_compatible_p (tree x, tree y)
 569 {
 570   if (TREE_CODE (x) == ARRAY_TYPE && TREE_CODE (y) == ARRAY_TYPE
 571       && gnat_types_compatible_p (TREE_TYPE (x), TREE_TYPE (y))
 572       && operand_equal_p (TYPE_MIN_VALUE (TYPE_DOMAIN (x)),
 573                           TYPE_MIN_VALUE (TYPE_DOMAIN (y)), 0)
 574       && operand_equal_p (TYPE_MAX_VALUE (TYPE_DOMAIN (x)),
 575                           TYPE_MAX_VALUE (TYPE_DOMAIN (y)), 0))
 576     return 1;
 577   else
 578     return TYPE_MAIN_VARIANT (x) == TYPE_MAIN_VARIANT (y);
 579 }
 580
 581 static const char *
 582 gnat_printable_name (tree decl, int verbosity)
 583 {
 584   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 585   char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
 586
 587   __gnat_decode (coded_name, ada_name, 0);
 588
 589   if (verbosity == 2)
 590     {
 591       Set_Identifier_Casing (ada_name, (char *) DECL_SOURCE_FILE (decl));
 592       ada_name = Name_Buffer;
 593     }
 594
 595   return (const char *) ada_name;
 596 }
 597
 598 /* Expands GNAT-specific GCC tree nodes.  The only ones we support
 599    here are  and NULL_EXPR.  */
 600
 601 static rtx
 602 gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode,
 603                   int modifier, rtx *alt_rtl)
 604 {
 605   tree type = TREE_TYPE (exp);
 606   tree new;
 607
 608   /* If this is a statement, call the expansion routine for statements.  */
 609   if (IS_STMT (exp))
 610     {
 611       gnat_expand_stmt (exp);
 612       return const0_rtx;
 613     }
 614
 615   /* Update EXP to be the new expression to expand.  */
 616   switch (TREE_CODE (exp))
 617     {
 618 #if 0
 619     case ALLOCATE_EXPR:
 620       return
 621         allocate_dynamic_stack_space
 622           (expand_expr (TREE_OPERAND (exp, 0), NULL_RTX, TYPE_MODE (sizetype),
 623                         EXPAND_NORMAL),
 624            NULL_RTX, tree_low_cst (TREE_OPERAND (exp, 1), 1));
 625 #endif
 626
 627     case UNCONSTRAINED_ARRAY_REF:
 628       /* If we are evaluating just for side-effects, just evaluate our
 629          operand.  Otherwise, abort since this code should never appear
 630          in a tree to be evaluated (objects aren't unconstrained).  */
 631       if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE)
 632         return expand_expr (TREE_OPERAND (exp, 0), const0_rtx,
 633                             VOIDmode, modifier);
 634
 635       /* ... fall through ... */
 636
 637     default:
 638       abort ();
 639     }
 640
 641   return expand_expr_real (new, target, tmode, modifier, alt_rtl);
 642 }
 643
 644 /* Generate the RTL for the body of GNU_DECL.  */
 645
 646 static void
 647 gnat_expand_body (tree gnu_decl)
 648 {
 649   if (!DECL_INITIAL (gnu_decl) || DECL_INITIAL (gnu_decl) == error_mark_node)
 650     return;
 651
 652   tree_rest_of_compilation (gnu_decl, false);
 653 }
 654
 655 /* Adjusts the RLI used to layout a record after all the fields have been
 656    added.  We only handle the packed case and cause it to use the alignment
 657    that will pad the record at the end.  */
 658
 659 static void
 660 gnat_adjust_rli (record_layout_info rli ATTRIBUTE_UNUSED)
 661 {
 662 #if 0
 663   /* ??? This code seems to have no actual effect; record_align should already
 664      reflect the largest alignment desired by a field.  jason 2003-04-01  */
 665   unsigned int record_align = rli->unpadded_align;
 666   tree field;
 667
 668   /* If an alignment has been specified, don't use anything larger unless we
 669      have to.  */
 670   if (TYPE_ALIGN (rli->t) != 0 && TYPE_ALIGN (rli->t) < record_align)
 671     record_align = MAX (rli->record_align, TYPE_ALIGN (rli->t));
 672
 673   /* If any fields have variable size, we need to force the record to be at
 674      least as aligned as the alignment of that type.  */
 675   for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field))
 676     if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST)
 677       record_align = MAX (record_align, DECL_ALIGN (field));
 678
 679   if (TYPE_PACKED (rli->t))
 680     rli->record_align = record_align;
 681 #endif
 682 }
 683 \f
 684 /* These routines are used in conjunction with GCC exception handling.  */
 685
 686 /* Map compile-time to run-time tree for GCC exception handling scheme.  */
 687
 688 static tree
 689 gnat_eh_runtime_type (tree type)
 690 {
 691   return type;
 692 }
 693
 694 /* Return true if type A catches type B. Callback for flow analysis from
 695    the exception handling part of the back-end.  */
 696
 697 static int
 698 gnat_eh_type_covers (tree a, tree b)
 699 {
 700   /* a catches b if they represent the same exception id or if a
 701      is an "others".
 702
 703      ??? integer_zero_node for "others" is hardwired in too many places
 704      currently.  */
 705   return (a == b || a == integer_zero_node);
 706 }
 707 \f
 708 /* Get the alias set corresponding to a type or expression.  */
 709
 710 static HOST_WIDE_INT
 711 gnat_get_alias_set (tree type)
 712 {
 713   /* If this is a padding type, use the type of the first field.  */
 714   if (TREE_CODE (type) == RECORD_TYPE
 715       && TYPE_IS_PADDING_P (type))
 716     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 717
 718   /* If the type is an unconstrained array, use the type of the
 719      self-referential array we make.  */
 720   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 721     return
 722       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 723
 724
 725   return -1;
 726 }
 727
 728 /* GNU_TYPE is a type.  Return its maxium size in bytes, if known.  */
 729
 730 static tree
 731 gnat_type_max_size (gnu_type)
 732      tree gnu_type;
 733 {
 734   return max_size (TYPE_SIZE_UNIT (gnu_type), true);
 735 }
 736
 737 /* GNU_TYPE is a type. Determine if it should be passed by reference by
 738    default.  */
 739
 740 bool
 741 default_pass_by_ref (tree gnu_type)
 742 {
 743   /* We pass aggregates by reference if they are sufficiently large.  The
 744      choice of constant here is somewhat arbitrary.  We also pass by
 745      reference if the target machine would either pass or return by
 746      reference.  Strictly speaking, we need only check the return if this
 747      is an In Out parameter, but it's probably best to err on the side of
 748      passing more things by reference.  */
 749
 750   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, 1))
 751     return true;
 752
 753   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 754     return true;
 755
 756   if (AGGREGATE_TYPE_P (gnu_type)
 757       && (!host_integerp (TYPE_SIZE (gnu_type), 1)
 758           || 0 < compare_tree_int (TYPE_SIZE (gnu_type),
 759                                    8 * TYPE_ALIGN (gnu_type))))
 760     return true;
 761
 762   return false;
 763 }
 764
 765 /* GNU_TYPE is the type of a subprogram parameter.  Determine from the type if
 766    it should be passed by reference. */
 767
 768 bool
 769 must_pass_by_ref (tree gnu_type)
 770 {
 771   /* We pass only unconstrained objects, those required by the language
 772      to be passed by reference, and objects of variable size.  The latter
 773      is more efficient, avoids problems with variable size temporaries,
 774      and does not produce compatibility problems with C, since C does
 775      not have such objects.  */
 776   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 777           || (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
 778           || (TYPE_SIZE (gnu_type)
 779               && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
 780 }
 781
 782 /* This function is called by the front end to enumerate all the supported
 783    modes for the machine.  We pass a function which is called back with
 784    the following integer parameters:
 785
 786    FLOAT_P      nonzero if this represents a floating-point mode
 787    COMPLEX_P    nonzero is this represents a complex mode
 788    COUNT        count of number of items, nonzero for vector mode
 789    PRECISION    number of bits in data representation
 790    MANTISSA     number of bits in mantissa, if FP and known, else zero.
 791    SIZE         number of bits used to store data
 792    ALIGN        number of bits to which mode is aligned.  */
 793
 794 void
 795 enumerate_modes (void (*f) (int, int, int, int, int, int, unsigned int))
 796 {
 797   enum machine_mode i;
 798
 799   for (i = 0; i < NUM_MACHINE_MODES; i++)
 800     {
 801       enum machine_mode j;
 802       bool float_p = 0;
 803       bool complex_p = 0;
 804       bool vector_p = 0;
 805       bool skip_p = 0;
 806       int mantissa = 0;
 807       enum machine_mode inner_mode = i;
 808
 809       switch (GET_MODE_CLASS (i))
 810         {
 811         case MODE_INT:
 812           break;
 813         case MODE_FLOAT:
 814           float_p = 1;
 815           break;
 816         case MODE_COMPLEX_INT:
 817           complex_p = 1;
 818           inner_mode = GET_MODE_INNER (i);
 819           break;
 820         case MODE_COMPLEX_FLOAT:
 821           float_p = 1;
 822           complex_p = 1;
 823           inner_mode = GET_MODE_INNER (i);
 824           break;
 825         case MODE_VECTOR_INT:
 826           vector_p = 1;
 827           inner_mode = GET_MODE_INNER (i);
 828           break;
 829         case MODE_VECTOR_FLOAT:
 830           float_p = 1;
 831           vector_p = 1;
 832           inner_mode = GET_MODE_INNER (i);
 833           break;
 834         default:
 835           skip_p = 1;
 836         }
 837
 838       /* Skip this mode if it's one the front end doesn't need to know about
 839          (e.g., the CC modes) or if there is no add insn for that mode (or
 840          any wider mode), meaning it is not supported by the hardware.  If
 841          this a complex or vector mode, we care about the inner mode.  */
 842       for (j = inner_mode; j != VOIDmode; j = GET_MODE_WIDER_MODE (j))
 843         if (add_optab->handlers[j].insn_code != CODE_FOR_nothing)
 844           break;
 845
 846       if (float_p)
 847         {
 848           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 849
 850           mantissa = fmt->p * fmt->log2_b;
 851         }
 852
 853       if (!skip_p && j != VOIDmode)
 854         (*f) (float_p, complex_p, vector_p ? GET_MODE_NUNITS (i) : 0,
 855               GET_MODE_BITSIZE (i), mantissa,
 856               GET_MODE_SIZE (i) * BITS_PER_UNIT, GET_MODE_ALIGNMENT (i));
 857     }
 858 }
 859
 860 int
 861 fp_prec_to_size (int prec)
 862 {
 863   enum machine_mode mode;
 864
 865   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 866        mode = GET_MODE_WIDER_MODE (mode))
 867     if (GET_MODE_PRECISION (mode) == prec)
 868       return GET_MODE_BITSIZE (mode);
 869
 870   abort ();
 871 }
 872
 873 int
 874 fp_size_to_prec (int size)
 875 {
 876   enum machine_mode mode;
 877
 878   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 879        mode = GET_MODE_WIDER_MODE (mode))
 880     if (GET_MODE_BITSIZE (mode) == size)
 881       return GET_MODE_PRECISION (mode);
 882
 883   abort ();
 884 }