gcc/ada/gcc-interface/misc.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                 M I S C                                  *
   6  *                                                                          *
   7  *                           C Implementation File                          *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2015, 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 3,  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  COPYING3.  If not see *
  19  * <http://www.gnu.org/licenses/>.                                          *
  20  *                                                                          *
  21  * GNAT was originally developed  by the GNAT team at  New York University. *
  22  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  23  *                                                                          *
  24  ****************************************************************************/
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "opts.h"
  30 #include "options.h"
  31 #include "tm.h"
  32 #include "hash-set.h"
  33 #include "machmode.h"
  34 #include "vec.h"
  35 #include "double-int.h"
  36 #include "input.h"
  37 #include "alias.h"
  38 #include "symtab.h"
  39 #include "wide-int.h"
  40 #include "inchash.h"
  41 #include "tree.h"
  42 #include "fold-const.h"
  43 #include "stor-layout.h"
  44 #include "print-tree.h"
  45 #include "diagnostic.h"
  46 #include "target.h"
  47 #include "ggc.h"
  48 #include "flags.h"
  49 #include "debug.h"
  50 #include "toplev.h"
  51 #include "langhooks.h"
  52 #include "langhooks-def.h"
  53 #include "plugin.h"
  54 #include "real.h"
  55 #include "hashtab.h"
  56 #include "hash-set.h"
  57 #include "vec.h"
  58 #include "machmode.h"
  59 #include "hard-reg-set.h"
  60 #include "input.h"
  61 #include "function.h"   /* For pass_by_reference.  */
  62 #include "dwarf2out.h"
  63
  64 #include "ada.h"
  65 #include "adadecode.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
  79 /* This symbol needs to be defined for the front-end.  */
  80 void *callgraph_info_file = NULL;
  81
  82 /* Command-line argc and argv.  These variables are global since they are
  83    imported in back_end.adb.  */
  84 unsigned int save_argc;
  85 const char **save_argv;
  86
  87 /* GNAT argc and argv.  */
  88 extern int gnat_argc;
  89 extern char **gnat_argv;
  90
  91 #ifdef __cplusplus
  92 extern "C" {
  93 #endif
  94
  95 /* Declare functions we use as part of startup.  */
  96 extern void __gnat_initialize (void *);
  97 extern void __gnat_install_SEH_handler (void *);
  98 extern void adainit (void);
  99 extern void _ada_gnat1drv (void);
 100
 101 #ifdef __cplusplus
 102 }
 103 #endif
 104
 105 /* The parser for the language.  For us, we process the GNAT tree.  */
 106
 107 static void
 108 gnat_parse_file (void)
 109 {
 110   int seh[2];
 111
 112   /* Call the target specific initializations.  */
 113   __gnat_initialize (NULL);
 114
 115   /* ??? Call the SEH initialization routine.  This is to workaround
 116   a bootstrap path problem.  The call below should be removed at some
 117   point and the SEH pointer passed to __gnat_initialize() above.  */
 118   __gnat_install_SEH_handler((void *)seh);
 119
 120   /* Call the front-end elaboration procedures.  */
 121   adainit ();
 122
 123   /* Call the front end.  */
 124   _ada_gnat1drv ();
 125 }
 126
 127 /* Return language mask for option processing.  */
 128
 129 static unsigned int
 130 gnat_option_lang_mask (void)
 131 {
 132   return CL_Ada;
 133 }
 134
 135 /* Decode all the language specific options that cannot be decoded by GCC.
 136    The option decoding phase of GCC calls this routine on the flags that
 137    are marked as Ada-specific.  Return true on success or false on failure.  */
 138
 139 static bool
 140 gnat_handle_option (size_t scode, const char *arg ATTRIBUTE_UNUSED, int value,
 141                     int kind ATTRIBUTE_UNUSED, location_t loc ATTRIBUTE_UNUSED,
 142                     const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED)
 143 {
 144   enum opt_code code = (enum opt_code) scode;
 145
 146   switch (code)
 147     {
 148     case OPT_Wall:
 149       handle_generated_option (&global_options, &global_options_set,
 150                                OPT_Wunused, NULL, value,
 151                                gnat_option_lang_mask (), kind, loc,
 152                                handlers, global_dc);
 153       warn_uninitialized = value;
 154       warn_maybe_uninitialized = value;
 155       break;
 156
 157     case OPT_gant:
 158       warning (0, "%<-gnat%> misspelled as %<-gant%>");
 159
 160       /* ... fall through ... */
 161
 162     case OPT_gnat:
 163     case OPT_gnatO:
 164     case OPT_fRTS_:
 165     case OPT_I:
 166     case OPT_nostdinc:
 167     case OPT_nostdlib:
 168       /* These are handled by the front-end.  */
 169       break;
 170
 171     case OPT_fshort_enums:
 172       /* This is handled by the middle-end.  */
 173       break;
 174
 175     default:
 176       gcc_unreachable ();
 177     }
 178
 179   Ada_handle_option_auto (&global_options, &global_options_set,
 180                           scode, arg, value,
 181                           gnat_option_lang_mask (), kind,
 182                           loc, handlers, global_dc);
 183   return true;
 184 }
 185
 186 /* Initialize options structure OPTS.  */
 187
 188 static void
 189 gnat_init_options_struct (struct gcc_options *opts)
 190 {
 191   /* Uninitialized really means uninitialized in Ada.  */
 192   opts->x_flag_zero_initialized_in_bss = 0;
 193
 194   /* We don't care about errno in Ada and it causes __builtin_sqrt to
 195      call the libm function rather than do it inline.  */
 196   opts->x_flag_errno_math = 0;
 197   opts->frontend_set_flag_errno_math = true;
 198 }
 199
 200 /* Initialize for option processing.  */
 201
 202 static void
 203 gnat_init_options (unsigned int decoded_options_count,
 204                    struct cl_decoded_option *decoded_options)
 205 {
 206   /* Reconstruct an argv array for use of back_end.adb.
 207
 208      ??? back_end.adb should not rely on this; instead, it should work with
 209      decoded options without such reparsing, to ensure consistency in how
 210      options are decoded.  */
 211   unsigned int i;
 212
 213   save_argv = XNEWVEC (const char *, 2 * decoded_options_count + 1);
 214   save_argc = 0;
 215   for (i = 0; i < decoded_options_count; i++)
 216     {
 217       size_t num_elements = decoded_options[i].canonical_option_num_elements;
 218
 219       if (decoded_options[i].errors
 220           || decoded_options[i].opt_index == OPT_SPECIAL_unknown
 221           || num_elements == 0)
 222         continue;
 223
 224       /* Deal with -I- specially since it must be a single switch.  */
 225       if (decoded_options[i].opt_index == OPT_I
 226           && num_elements == 2
 227           && decoded_options[i].canonical_option[1][0] == '-'
 228           && decoded_options[i].canonical_option[1][1] == '\0')
 229         save_argv[save_argc++] = "-I-";
 230       else
 231         {
 232           gcc_assert (num_elements >= 1 && num_elements <= 2);
 233           save_argv[save_argc++] = decoded_options[i].canonical_option[0];
 234           if (num_elements >= 2)
 235             save_argv[save_argc++] = decoded_options[i].canonical_option[1];
 236         }
 237     }
 238   save_argv[save_argc] = NULL;
 239
 240   gnat_argv = (char **) xmalloc (sizeof (save_argv[0]));
 241   gnat_argv[0] = xstrdup (save_argv[0]);     /* name of the command */
 242   gnat_argc = 1;
 243 }
 244
 245 /* Ada code requires variables for these settings rather than elements
 246    of the global_options structure.  */
 247 #undef optimize
 248 #undef optimize_size
 249 #undef flag_compare_debug
 250 #undef flag_short_enums
 251 #undef flag_stack_check
 252 int gnat_encodings = 0;
 253 int optimize;
 254 int optimize_size;
 255 int flag_compare_debug;
 256 int flag_short_enums;
 257 enum stack_check_type flag_stack_check = NO_STACK_CHECK;
 258
 259 /* Settings adjustments after switches processing by the back-end.
 260    Note that the front-end switches processing (Scan_Compiler_Arguments)
 261    has not been done yet at this point!  */
 262
 263 static bool
 264 gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
 265 {
 266   /* Excess precision other than "fast" requires front-end support.  */
 267   if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD
 268       && TARGET_FLT_EVAL_METHOD_NON_DEFAULT)
 269     sorry ("-fexcess-precision=standard for Ada");
 270   flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
 271
 272   /* ??? The warning machinery is outsmarted by Ada.  */
 273   warn_unused_parameter = 0;
 274
 275   /* No psABI change warnings for Ada.  */
 276   warn_psabi = 0;
 277
 278   /* No caret by default for Ada.  */
 279   if (!global_options_set.x_flag_diagnostics_show_caret)
 280     global_dc->show_caret = false;
 281
 282   optimize = global_options.x_optimize;
 283   optimize_size = global_options.x_optimize_size;
 284   flag_compare_debug = global_options.x_flag_compare_debug;
 285   flag_stack_check = global_options.x_flag_stack_check;
 286   flag_short_enums = global_options.x_flag_short_enums;
 287
 288   /* Unfortunately the post_options hook is called before the value of
 289      flag_short_enums is autodetected, if need be.  Mimic the process
 290      for our private flag_short_enums.  */
 291   if (flag_short_enums == 2)
 292     flag_short_enums = targetm.default_short_enums ();
 293
 294   return false;
 295 }
 296
 297 /* Here is the function to handle the compiler error processing in GCC.  */
 298
 299 static void
 300 internal_error_function (diagnostic_context *context,
 301                          const char *msgid, va_list *ap)
 302 {
 303   text_info tinfo;
 304   char *buffer, *p, *loc;
 305   String_Template temp, temp_loc;
 306   String_Pointer sp, sp_loc;
 307   expanded_location xloc;
 308
 309   /* Warn if plugins present.  */
 310   warn_if_plugins ();
 311
 312   /* Reset the pretty-printer.  */
 313   pp_clear_output_area (context->printer);
 314
 315   /* Format the message into the pretty-printer.  */
 316   tinfo.format_spec = msgid;
 317   tinfo.args_ptr = ap;
 318   tinfo.err_no = errno;
 319   pp_format_verbatim (context->printer, &tinfo);
 320
 321   /* Extract a (writable) pointer to the formatted text.  */
 322   buffer = xstrdup (pp_formatted_text (context->printer));
 323
 324   /* Go up to the first newline.  */
 325   for (p = buffer; *p; p++)
 326     if (*p == '\n')
 327       {
 328         *p = '\0';
 329         break;
 330       }
 331
 332   temp.Low_Bound = 1;
 333   temp.High_Bound = p - buffer;
 334   sp.Bounds = &temp;
 335   sp.Array = buffer;
 336
 337   xloc = expand_location (input_location);
 338   if (context->show_column && xloc.column != 0)
 339     loc = xasprintf ("%s:%d:%d", xloc.file, xloc.line, xloc.column);
 340   else
 341     loc = xasprintf ("%s:%d", xloc.file, xloc.line);
 342   temp_loc.Low_Bound = 1;
 343   temp_loc.High_Bound = strlen (loc);
 344   sp_loc.Bounds = &temp_loc;
 345   sp_loc.Array = loc;
 346
 347   Current_Error_Node = error_gnat_node;
 348   Compiler_Abort (sp, sp_loc, true);
 349 }
 350
 351 /* Perform all the initialization steps that are language-specific.  */
 352
 353 static bool
 354 gnat_init (void)
 355 {
 356   /* Do little here, most of the standard declarations are set up after the
 357      front-end has been run.  Use the same `char' as C, this doesn't really
 358      matter since we'll use the explicit `unsigned char' for Character.  */
 359   build_common_tree_nodes (flag_signed_char, false);
 360
 361   /* In Ada, we use an unsigned 8-bit type for the default boolean type.  */
 362   boolean_type_node = make_unsigned_type (8);
 363   TREE_SET_CODE (boolean_type_node, BOOLEAN_TYPE);
 364   SET_TYPE_RM_MAX_VALUE (boolean_type_node,
 365                          build_int_cst (boolean_type_node, 1));
 366   SET_TYPE_RM_SIZE (boolean_type_node, bitsize_int (1));
 367   boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
 368   boolean_false_node = TYPE_MIN_VALUE (boolean_type_node);
 369
 370   sbitsize_one_node = sbitsize_int (1);
 371   sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT);
 372
 373   /* Show that REFERENCE_TYPEs are internal and should be Pmode.  */
 374   internal_reference_types ();
 375
 376   /* Register our internal error function.  */
 377   global_dc->internal_error = &internal_error_function;
 378
 379   return true;
 380 }
 381
 382 /* Initialize the GCC support for exception handling.  */
 383
 384 void
 385 gnat_init_gcc_eh (void)
 386 {
 387   /* We shouldn't do anything if the No_Exceptions_Handler pragma is set,
 388      though. This could for instance lead to the emission of tables with
 389      references to symbols (such as the Ada eh personality routine) within
 390      libraries we won't link against.  */
 391   if (No_Exception_Handlers_Set ())
 392     return;
 393
 394   /* Tell GCC we are handling cleanup actions through exception propagation.
 395      This opens possibilities that we don't take advantage of yet, but is
 396      nonetheless necessary to ensure that fixup code gets assigned to the
 397      right exception regions.  */
 398   using_eh_for_cleanups ();
 399
 400   /* Turn on -fexceptions, -fnon-call-exceptions and -fdelete-dead-exceptions.
 401      The first one triggers the generation of the necessary exception tables.
 402      The second one is useful for two reasons: 1/ we map some asynchronous
 403      signals like SEGV to exceptions, so we need to ensure that the insns
 404      which can lead to such signals are correctly attached to the exception
 405      region they pertain to, 2/ some calls to pure subprograms are handled as
 406      libcall blocks and then marked as "cannot trap" if the flag is not set
 407      (see emit_libcall_block).  We should not let this be since it is possible
 408      for such calls to actually raise in Ada.
 409      The third one is an optimization that makes it possible to delete dead
 410      instructions that may throw exceptions, most notably loads and stores,
 411      as permitted in Ada.  */
 412   flag_exceptions = 1;
 413   flag_non_call_exceptions = 1;
 414   flag_delete_dead_exceptions = 1;
 415
 416   init_eh ();
 417 }
 418
 419 /* Initialize the GCC support for floating-point operations.  */
 420
 421 void
 422 gnat_init_gcc_fp (void)
 423 {
 424   /* Disable FP optimizations that ignore the signedness of zero if
 425      S'Signed_Zeros is true, but don't override the user if not.  */
 426   if (Signed_Zeros_On_Target)
 427     flag_signed_zeros = 1;
 428   else if (!global_options_set.x_flag_signed_zeros)
 429     flag_signed_zeros = 0;
 430
 431   /* Assume that FP operations can trap if S'Machine_Overflow is true,
 432      but don't override the user if not.  */
 433   if (Machine_Overflows_On_Target)
 434     flag_trapping_math = 1;
 435   else if (!global_options_set.x_flag_trapping_math)
 436     flag_trapping_math = 0;
 437 }
 438
 439 /* Print language-specific items in declaration NODE.  */
 440
 441 static void
 442 gnat_print_decl (FILE *file, tree node, int indent)
 443 {
 444   switch (TREE_CODE (node))
 445     {
 446     case CONST_DECL:
 447       print_node (file, "corresponding var",
 448                   DECL_CONST_CORRESPONDING_VAR (node), indent + 4);
 449       break;
 450
 451     case FIELD_DECL:
 452       print_node (file, "original field", DECL_ORIGINAL_FIELD (node),
 453                   indent + 4);
 454       break;
 455
 456     case VAR_DECL:
 457       if (DECL_LOOP_PARM_P (node))
 458         print_node (file, "induction var", DECL_INDUCTION_VAR (node),
 459                     indent + 4);
 460       else
 461         print_node (file, "renamed object", DECL_RENAMED_OBJECT (node),
 462                     indent + 4);
 463       break;
 464
 465     default:
 466       break;
 467     }
 468 }
 469
 470 /* Print language-specific items in type NODE.  */
 471
 472 static void
 473 gnat_print_type (FILE *file, tree node, int indent)
 474 {
 475   switch (TREE_CODE (node))
 476     {
 477     case FUNCTION_TYPE:
 478       print_node (file, "ci/co list", TYPE_CI_CO_LIST (node), indent + 4);
 479       break;
 480
 481     case INTEGER_TYPE:
 482       if (TYPE_MODULAR_P (node))
 483         print_node_brief (file, "modulus", TYPE_MODULUS (node), indent + 4);
 484       else if (TYPE_HAS_ACTUAL_BOUNDS_P (node))
 485         print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node),
 486                     indent + 4);
 487       else
 488         print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4);
 489
 490       /* ... fall through ... */
 491
 492     case ENUMERAL_TYPE:
 493     case BOOLEAN_TYPE:
 494       print_node_brief (file, "RM size", TYPE_RM_SIZE (node), indent + 4);
 495
 496       /* ... fall through ... */
 497
 498     case REAL_TYPE:
 499       print_node_brief (file, "RM min", TYPE_RM_MIN_VALUE (node), indent + 4);
 500       print_node_brief (file, "RM max", TYPE_RM_MAX_VALUE (node), indent + 4);
 501       break;
 502
 503     case ARRAY_TYPE:
 504       print_node (file,"actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4);
 505       break;
 506
 507     case VECTOR_TYPE:
 508       print_node (file,"representative array",
 509                   TYPE_REPRESENTATIVE_ARRAY (node), indent + 4);
 510       break;
 511
 512     case RECORD_TYPE:
 513       if (TYPE_FAT_POINTER_P (node) || TYPE_CONTAINS_TEMPLATE_P (node))
 514         print_node (file, "unconstrained array",
 515                     TYPE_UNCONSTRAINED_ARRAY (node), indent + 4);
 516       else
 517         print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 518       break;
 519
 520     case UNION_TYPE:
 521     case QUAL_UNION_TYPE:
 522       print_node (file, "Ada size", TYPE_ADA_SIZE (node), indent + 4);
 523       break;
 524
 525     default:
 526       break;
 527     }
 528 }
 529
 530 /* Return the name to be printed for DECL.  */
 531
 532 static const char *
 533 gnat_printable_name (tree decl, int verbosity)
 534 {
 535   const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
 536   char *ada_name = (char *) ggc_alloc_atomic (strlen (coded_name) * 2 + 60);
 537
 538   __gnat_decode (coded_name, ada_name, 0);
 539
 540   if (verbosity == 2 && !DECL_IS_BUILTIN (decl))
 541     {
 542       Set_Identifier_Casing (ada_name, DECL_SOURCE_FILE (decl));
 543       return ggc_strdup (Name_Buffer);
 544     }
 545
 546   return ada_name;
 547 }
 548
 549 /* Return the name to be used in DWARF debug info for DECL.  */
 550
 551 static const char *
 552 gnat_dwarf_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
 553 {
 554   gcc_assert (DECL_P (decl));
 555   return (const char *) IDENTIFIER_POINTER (DECL_NAME (decl));
 556 }
 557
 558 /* Return the descriptive type associated with TYPE, if any.  */
 559
 560 static tree
 561 gnat_descriptive_type (const_tree type)
 562 {
 563   if (TYPE_STUB_DECL (type))
 564     return DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type));
 565   else
 566     return NULL_TREE;
 567 }
 568
 569 /* Return true if types T1 and T2 are identical for type hashing purposes.
 570    Called only after doing all language independent checks.  At present,
 571    this function is only called when both types are FUNCTION_TYPE.  */
 572
 573 static bool
 574 gnat_type_hash_eq (const_tree t1, const_tree t2)
 575 {
 576   gcc_assert (TREE_CODE (t1) == FUNCTION_TYPE);
 577   return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
 578                               TYPE_RETURN_UNCONSTRAINED_P (t2),
 579                               TYPE_RETURN_BY_DIRECT_REF_P (t2),
 580                               TREE_ADDRESSABLE (t2));
 581 }
 582
 583 /* Do nothing (return the tree node passed).  */
 584
 585 static tree
 586 gnat_return_tree (tree t)
 587 {
 588   return t;
 589 }
 590
 591 /* Get the alias set corresponding to a type or expression.  */
 592
 593 static alias_set_type
 594 gnat_get_alias_set (tree type)
 595 {
 596   /* If this is a padding type, use the type of the first field.  */
 597   if (TYPE_IS_PADDING_P (type))
 598     return get_alias_set (TREE_TYPE (TYPE_FIELDS (type)));
 599
 600   /* If the type is an unconstrained array, use the type of the
 601      self-referential array we make.  */
 602   else if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
 603     return
 604       get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
 605
 606   /* If the type can alias any other types, return the alias set 0.  */
 607   else if (TYPE_P (type) && TYPE_UNIVERSAL_ALIASING_P (type))
 608     return 0;
 609
 610   return -1;
 611 }
 612
 613 /* GNU_TYPE is a type.  Return its maximum size in bytes, if known,
 614    as a constant when possible.  */
 615
 616 static tree
 617 gnat_type_max_size (const_tree gnu_type)
 618 {
 619   /* First see what we can get from TYPE_SIZE_UNIT, which might not
 620      be constant even for simple expressions if it has already been
 621      elaborated and possibly replaced by a VAR_DECL.  */
 622   tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
 623
 624   /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
 625      which should stay untouched.  */
 626   if (!tree_fits_uhwi_p (max_unitsize)
 627       && RECORD_OR_UNION_TYPE_P (gnu_type)
 628       && !TYPE_FAT_POINTER_P (gnu_type)
 629       && TYPE_ADA_SIZE (gnu_type))
 630     {
 631       tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
 632
 633       /* If we have succeeded in finding a constant, round it up to the
 634          type's alignment and return the result in units.  */
 635       if (tree_fits_uhwi_p (max_adasize))
 636         max_unitsize
 637           = size_binop (CEIL_DIV_EXPR,
 638                         round_up (max_adasize, TYPE_ALIGN (gnu_type)),
 639                         bitsize_unit_node);
 640     }
 641
 642   return max_unitsize;
 643 }
 644
 645 /* Provide information in INFO for debug output about the TYPE array type.
 646    Return whether TYPE is handled.  */
 647
 648 static bool
 649 gnat_get_array_descr_info (const_tree type, struct array_descr_info *info)
 650 {
 651   bool convention_fortran_p;
 652   tree index_type;
 653
 654   const_tree dimen = NULL_TREE;
 655   const_tree last_dimen = NULL_TREE;
 656   int i;
 657
 658   if (TREE_CODE (type) != ARRAY_TYPE
 659       || !TYPE_DOMAIN (type)
 660       || !TYPE_INDEX_TYPE (TYPE_DOMAIN (type)))
 661     return false;
 662
 663   /* Count how many dimentions this array has.  */
 664   for (i = 0, dimen = type; ; ++i, dimen = TREE_TYPE (dimen))
 665     if (i > 0
 666         && (TREE_CODE (dimen) != ARRAY_TYPE
 667             || !TYPE_MULTI_ARRAY_P (dimen)))
 668       break;
 669   info->ndimensions = i;
 670   convention_fortran_p = TYPE_CONVENTION_FORTRAN_P (type);
 671
 672   /* TODO: For row major ordering, we probably want to emit nothing and
 673      instead specify it as the default in Dw_TAG_compile_unit.  */
 674   info->ordering = (convention_fortran_p
 675                     ? array_descr_ordering_column_major
 676                     : array_descr_ordering_row_major);
 677   info->base_decl = NULL_TREE;
 678   info->data_location = NULL_TREE;
 679   info->allocated = NULL_TREE;
 680   info->associated = NULL_TREE;
 681
 682   for (i = (convention_fortran_p ? info->ndimensions - 1 : 0),
 683        dimen = type;
 684
 685        0 <= i && i < info->ndimensions;
 686
 687        i += (convention_fortran_p ? -1 : 1),
 688        dimen = TREE_TYPE (dimen))
 689     {
 690       /* We are interested in the stored bounds for the debug info.  */
 691       index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (dimen));
 692
 693       info->dimen[i].bounds_type = index_type;
 694       info->dimen[i].lower_bound = TYPE_MIN_VALUE (index_type);
 695       info->dimen[i].upper_bound = TYPE_MAX_VALUE (index_type);
 696       last_dimen = dimen;
 697     }
 698
 699   info->element_type = TREE_TYPE (last_dimen);
 700
 701   return true;
 702 }
 703
 704 /* GNU_TYPE is a subtype of an integral type.  Set LOWVAL to the low bound
 705    and HIGHVAL to the high bound, respectively.  */
 706
 707 static void
 708 gnat_get_subrange_bounds (const_tree gnu_type, tree *lowval, tree *highval)
 709 {
 710   *lowval = TYPE_MIN_VALUE (gnu_type);
 711   *highval = TYPE_MAX_VALUE (gnu_type);
 712 }
 713
 714 /* GNU_TYPE is the type of a subprogram parameter.  Determine if it should be
 715    passed by reference by default.  */
 716
 717 bool
 718 default_pass_by_ref (tree gnu_type)
 719 {
 720   /* We pass aggregates by reference if they are sufficiently large for
 721      their alignment.  The ratio is somewhat arbitrary.  We also pass by
 722      reference if the target machine would either pass or return by
 723      reference.  Strictly speaking, we need only check the return if this
 724      is an In Out parameter, but it's probably best to err on the side of
 725      passing more things by reference.  */
 726
 727   if (pass_by_reference (NULL, TYPE_MODE (gnu_type), gnu_type, true))
 728     return true;
 729
 730   if (targetm.calls.return_in_memory (gnu_type, NULL_TREE))
 731     return true;
 732
 733   if (AGGREGATE_TYPE_P (gnu_type)
 734       && (!valid_constant_size_p (TYPE_SIZE_UNIT (gnu_type))
 735           || 0 < compare_tree_int (TYPE_SIZE_UNIT (gnu_type),
 736                                    TYPE_ALIGN (gnu_type))))
 737     return true;
 738
 739   return false;
 740 }
 741
 742 /* GNU_TYPE is the type of a subprogram parameter.  Determine if it must be
 743    passed by reference.  */
 744
 745 bool
 746 must_pass_by_ref (tree gnu_type)
 747 {
 748   /* We pass only unconstrained objects, those required by the language
 749      to be passed by reference, and objects of variable size.  The latter
 750      is more efficient, avoids problems with variable size temporaries,
 751      and does not produce compatibility problems with C, since C does
 752      not have such objects.  */
 753   return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
 754           || TYPE_IS_BY_REFERENCE_P (gnu_type)
 755           || (TYPE_SIZE_UNIT (gnu_type)
 756               && TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST));
 757 }
 758
 759 /* This function is called by the front-end to enumerate all the supported
 760    modes for the machine, as well as some predefined C types.  F is a function
 761    which is called back with the parameters as listed below, first a string,
 762    then seven ints.  The name is any arbitrary null-terminated string and has
 763    no particular significance, except for the case of predefined C types, where
 764    it should be the name of the C type.  For integer types, only signed types
 765    should be listed, unsigned versions are assumed.  The order of types should
 766    be in order of preference, with the smallest/cheapest types first.
 767
 768    In particular, C predefined types should be listed before other types,
 769    binary floating point types before decimal ones, and narrower/cheaper
 770    type versions before more expensive ones.  In type selection the first
 771    matching variant will be used.
 772
 773    NAME         pointer to first char of type name
 774    DIGS         number of decimal digits for floating-point modes, else 0
 775    COMPLEX_P    nonzero is this represents a complex mode
 776    COUNT        count of number of items, nonzero for vector mode
 777    FLOAT_REP    Float_Rep_Kind for FP, otherwise undefined
 778    PRECISION    number of bits used to store data
 779    SIZE         number of bits occupied by the mode
 780    ALIGN        number of bits to which mode is aligned.  */
 781
 782 void
 783 enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int))
 784 {
 785   const tree c_types[]
 786     = { float_type_node, double_type_node, long_double_type_node };
 787   const char *const c_names[]
 788     = { "float", "double", "long double" };
 789   int iloop;
 790
 791   /* We are going to compute it below.  */
 792   fp_arith_may_widen = false;
 793
 794   for (iloop = 0; iloop < NUM_MACHINE_MODES; iloop++)
 795     {
 796       machine_mode i = (machine_mode) iloop;
 797       machine_mode inner_mode = i;
 798       bool float_p = false;
 799       bool complex_p = false;
 800       bool vector_p = false;
 801       bool skip_p = false;
 802       int digs = 0;
 803       unsigned int nameloop;
 804       Float_Rep_Kind float_rep = IEEE_Binary; /* Until proven otherwise */
 805
 806       switch (GET_MODE_CLASS (i))
 807         {
 808         case MODE_INT:
 809           break;
 810         case MODE_FLOAT:
 811           float_p = true;
 812           break;
 813         case MODE_COMPLEX_INT:
 814           complex_p = true;
 815           inner_mode = GET_MODE_INNER (i);
 816           break;
 817         case MODE_COMPLEX_FLOAT:
 818           float_p = true;
 819           complex_p = true;
 820           inner_mode = GET_MODE_INNER (i);
 821           break;
 822         case MODE_VECTOR_INT:
 823           vector_p = true;
 824           inner_mode = GET_MODE_INNER (i);
 825           break;
 826         case MODE_VECTOR_FLOAT:
 827           float_p = true;
 828           vector_p = true;
 829           inner_mode = GET_MODE_INNER (i);
 830           break;
 831         default:
 832           skip_p = true;
 833         }
 834
 835       if (float_p)
 836         {
 837           const struct real_format *fmt = REAL_MODE_FORMAT (inner_mode);
 838
 839           /* ??? Cope with the ghost XFmode of the ARM port.  */
 840           if (!fmt)
 841             continue;
 842
 843           /* Be conservative and consider that floating-point arithmetics may
 844              use wider intermediate results as soon as there is an extended
 845              Motorola or Intel mode supported by the machine.  */
 846           if (fmt == &ieee_extended_motorola_format
 847               || fmt == &ieee_extended_intel_96_format
 848               || fmt == &ieee_extended_intel_96_round_53_format
 849               || fmt == &ieee_extended_intel_128_format)
 850             {
 851 #ifdef TARGET_FPMATH_DEFAULT
 852               if (TARGET_FPMATH_DEFAULT == FPMATH_387)
 853 #endif
 854                 fp_arith_may_widen = true;
 855             }
 856
 857           if (fmt->b == 2)
 858             digs = (fmt->p - 1) * 1233 / 4096; /* scale by log (2) */
 859
 860           else if (fmt->b == 10)
 861             digs = fmt->p;
 862
 863           else
 864             gcc_unreachable();
 865         }
 866
 867       /* First register any C types for this mode that the front end
 868          may need to know about, unless the mode should be skipped.  */
 869       if (!skip_p && !vector_p)
 870         for (nameloop = 0; nameloop < ARRAY_SIZE (c_types); nameloop++)
 871           {
 872             tree type = c_types[nameloop];
 873             const char *name = c_names[nameloop];
 874
 875             if (TYPE_MODE (type) == i)
 876               {
 877                 f (name, digs, complex_p, 0, float_rep, TYPE_PRECISION (type),
 878                    TREE_INT_CST_LOW (TYPE_SIZE (type)), TYPE_ALIGN (type));
 879                 skip_p = true;
 880               }
 881           }
 882
 883       /* If no predefined C types were found, register the mode itself.  */
 884       if (!skip_p)
 885         f (GET_MODE_NAME (i), digs, complex_p,
 886            vector_p ? GET_MODE_NUNITS (i) : 0, float_rep,
 887            GET_MODE_PRECISION (i), GET_MODE_BITSIZE (i),
 888            GET_MODE_ALIGNMENT (i));
 889     }
 890 }
 891
 892 /* Return the size of the FP mode with precision PREC.  */
 893
 894 int
 895 fp_prec_to_size (int prec)
 896 {
 897   machine_mode mode;
 898
 899   for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT); mode != VOIDmode;
 900        mode = GET_MODE_WIDER_MODE (mode))
 901     if (GET_MODE_PRECISION (mode) == prec)
 902       return GET_MODE_BITSIZE (mode);
 903
 904   gcc_unreachable ();
 905 }
 906
 907 /* Return the precision of the FP mode with size SIZE.  */
 908
 909 int
 910 fp_size_to_prec (int size)
 911 {
 912   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_BITSIZE (mode) == size)
 917       return GET_MODE_PRECISION (mode);
 918
 919   gcc_unreachable ();
 920 }
 921
 922 static GTY(()) tree gnat_eh_personality_decl;
 923
 924 /* Return the GNAT personality function decl.  */
 925
 926 static tree
 927 gnat_eh_personality (void)
 928 {
 929   if (!gnat_eh_personality_decl)
 930     gnat_eh_personality_decl = build_personality_function ("gnat");
 931   return gnat_eh_personality_decl;
 932 }
 933
 934 /* Initialize language-specific bits of tree_contains_struct.  */
 935
 936 static void
 937 gnat_init_ts (void)
 938 {
 939   MARK_TS_COMMON (UNCONSTRAINED_ARRAY_TYPE);
 940
 941   MARK_TS_TYPED (UNCONSTRAINED_ARRAY_REF);
 942   MARK_TS_TYPED (NULL_EXPR);
 943   MARK_TS_TYPED (PLUS_NOMOD_EXPR);
 944   MARK_TS_TYPED (MINUS_NOMOD_EXPR);
 945   MARK_TS_TYPED (ATTR_ADDR_EXPR);
 946   MARK_TS_TYPED (STMT_STMT);
 947   MARK_TS_TYPED (LOOP_STMT);
 948   MARK_TS_TYPED (EXIT_STMT);
 949 }
 950
 951 /* Definitions for our language-specific hooks.  */
 952
 953 #undef  LANG_HOOKS_NAME
 954 #define LANG_HOOKS_NAME                 "GNU Ada"
 955 #undef  LANG_HOOKS_IDENTIFIER_SIZE
 956 #define LANG_HOOKS_IDENTIFIER_SIZE      sizeof (struct tree_identifier)
 957 #undef  LANG_HOOKS_INIT
 958 #define LANG_HOOKS_INIT                 gnat_init
 959 #undef  LANG_HOOKS_OPTION_LANG_MASK
 960 #define LANG_HOOKS_OPTION_LANG_MASK     gnat_option_lang_mask
 961 #undef  LANG_HOOKS_INIT_OPTIONS_STRUCT
 962 #define LANG_HOOKS_INIT_OPTIONS_STRUCT  gnat_init_options_struct
 963 #undef  LANG_HOOKS_INIT_OPTIONS
 964 #define LANG_HOOKS_INIT_OPTIONS         gnat_init_options
 965 #undef  LANG_HOOKS_HANDLE_OPTION
 966 #define LANG_HOOKS_HANDLE_OPTION        gnat_handle_option
 967 #undef  LANG_HOOKS_POST_OPTIONS
 968 #define LANG_HOOKS_POST_OPTIONS         gnat_post_options
 969 #undef  LANG_HOOKS_PARSE_FILE
 970 #define LANG_HOOKS_PARSE_FILE           gnat_parse_file
 971 #undef  LANG_HOOKS_TYPE_HASH_EQ
 972 #define LANG_HOOKS_TYPE_HASH_EQ         gnat_type_hash_eq
 973 #undef  LANG_HOOKS_GETDECLS
 974 #define LANG_HOOKS_GETDECLS             lhd_return_null_tree_v
 975 #undef  LANG_HOOKS_PUSHDECL
 976 #define LANG_HOOKS_PUSHDECL             gnat_return_tree
 977 #undef  LANG_HOOKS_WRITE_GLOBALS
 978 #define LANG_HOOKS_WRITE_GLOBALS        gnat_write_global_declarations
 979 #undef  LANG_HOOKS_GET_ALIAS_SET
 980 #define LANG_HOOKS_GET_ALIAS_SET        gnat_get_alias_set
 981 #undef  LANG_HOOKS_PRINT_DECL
 982 #define LANG_HOOKS_PRINT_DECL           gnat_print_decl
 983 #undef  LANG_HOOKS_PRINT_TYPE
 984 #define LANG_HOOKS_PRINT_TYPE           gnat_print_type
 985 #undef  LANG_HOOKS_TYPE_MAX_SIZE
 986 #define LANG_HOOKS_TYPE_MAX_SIZE        gnat_type_max_size
 987 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
 988 #define LANG_HOOKS_DECL_PRINTABLE_NAME  gnat_printable_name
 989 #undef  LANG_HOOKS_DWARF_NAME
 990 #define LANG_HOOKS_DWARF_NAME           gnat_dwarf_name
 991 #undef  LANG_HOOKS_GIMPLIFY_EXPR
 992 #define LANG_HOOKS_GIMPLIFY_EXPR        gnat_gimplify_expr
 993 #undef  LANG_HOOKS_TYPE_FOR_MODE
 994 #define LANG_HOOKS_TYPE_FOR_MODE        gnat_type_for_mode
 995 #undef  LANG_HOOKS_TYPE_FOR_SIZE
 996 #define LANG_HOOKS_TYPE_FOR_SIZE        gnat_type_for_size
 997 #undef  LANG_HOOKS_TYPES_COMPATIBLE_P
 998 #define LANG_HOOKS_TYPES_COMPATIBLE_P   gnat_types_compatible_p
 999 #undef  LANG_HOOKS_GET_ARRAY_DESCR_INFO
1000 #define LANG_HOOKS_GET_ARRAY_DESCR_INFO gnat_get_array_descr_info
1001 #undef  LANG_HOOKS_GET_SUBRANGE_BOUNDS
1002 #define LANG_HOOKS_GET_SUBRANGE_BOUNDS  gnat_get_subrange_bounds
1003 #undef  LANG_HOOKS_DESCRIPTIVE_TYPE
1004 #define LANG_HOOKS_DESCRIPTIVE_TYPE     gnat_descriptive_type
1005 #undef  LANG_HOOKS_ATTRIBUTE_TABLE
1006 #define LANG_HOOKS_ATTRIBUTE_TABLE      gnat_internal_attribute_table
1007 #undef  LANG_HOOKS_BUILTIN_FUNCTION
1008 #define LANG_HOOKS_BUILTIN_FUNCTION     gnat_builtin_function
1009 #undef  LANG_HOOKS_EH_PERSONALITY
1010 #define LANG_HOOKS_EH_PERSONALITY       gnat_eh_personality
1011 #undef  LANG_HOOKS_DEEP_UNSHARING
1012 #define LANG_HOOKS_DEEP_UNSHARING       true
1013 #undef  LANG_HOOKS_INIT_TS
1014 #define LANG_HOOKS_INIT_TS              gnat_init_ts
1015
1016 struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
1017
1018 #include "gt-ada-misc.h"