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