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