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