1/**************************************************************************** 2 * * 3 * GNAT COMPILER COMPONENTS * 4 * * 5 * U T I L S * 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 along with GCC; see the 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 "tm.h" 30#include "hash-set.h" 31#include "machmode.h" 32#include "vec.h" 33#include "double-int.h" 34#include "input.h" 35#include "alias.h" 36#include "symtab.h" 37#include "wide-int.h" 38#include "inchash.h" 39#include "tree.h" 40#include "fold-const.h" 41#include "stringpool.h" 42#include "stor-layout.h" 43#include "attribs.h" 44#include "varasm.h" 45#include "flags.h" 46#include "toplev.h" 47#include "diagnostic-core.h" 48#include "output.h" 49#include "ggc.h" 50#include "debug.h" 51#include "convert.h" 52#include "target.h" 53#include "common/common-target.h" 54#include "langhooks.h" 55#include "hash-map.h" 56#include "is-a.h" 57#include "plugin-api.h" 58#include "hard-reg-set.h" 59#include "input.h" 60#include "function.h" 61#include "ipa-ref.h" 62#include "cgraph.h" 63#include "diagnostic.h" 64#include "timevar.h" 65#include "tree-dump.h" 66#include "tree-inline.h" 67#include "tree-iterator.h" 68 69#include "ada.h" 70#include "types.h" 71#include "atree.h" 72#include "elists.h" 73#include "namet.h" 74#include "nlists.h" 75#include "stringt.h" 76#include "uintp.h" 77#include "fe.h" 78#include "sinfo.h" 79#include "einfo.h" 80#include "ada-tree.h" 81#include "gigi.h" 82 83/* If nonzero, pretend we are allocating at global level. */ 84int force_global; 85 86/* The default alignment of "double" floating-point types, i.e. floating 87 point types whose size is equal to 64 bits, or 0 if this alignment is 88 not specifically capped. */ 89int double_float_alignment; 90 91/* The default alignment of "double" or larger scalar types, i.e. scalar 92 types whose size is greater or equal to 64 bits, or 0 if this alignment 93 is not specifically capped. */ 94int double_scalar_alignment; 95 96/* True if floating-point arithmetics may use wider intermediate results. */ 97bool fp_arith_may_widen = true; 98 99/* Tree nodes for the various types and decls we create. */ 100tree gnat_std_decls[(int) ADT_LAST]; 101 102/* Functions to call for each of the possible raise reasons. */ 103tree gnat_raise_decls[(int) LAST_REASON_CODE + 1]; 104 105/* Likewise, but with extra info for each of the possible raise reasons. */ 106tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1]; 107 108/* Forward declarations for handlers of attributes. */ 109static tree handle_const_attribute (tree *, tree, tree, int, bool *); 110static tree handle_nothrow_attribute (tree *, tree, tree, int, bool *); 111static tree handle_pure_attribute (tree *, tree, tree, int, bool *); 112static tree handle_novops_attribute (tree *, tree, tree, int, bool *); 113static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *); 114static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *); 115static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *); 116static tree handle_leaf_attribute (tree *, tree, tree, int, bool *); 117static tree handle_always_inline_attribute (tree *, tree, tree, int, bool *); 118static tree handle_malloc_attribute (tree *, tree, tree, int, bool *); 119static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *); 120static tree handle_vector_size_attribute (tree *, tree, tree, int, bool *); 121static tree handle_vector_type_attribute (tree *, tree, tree, int, bool *); 122 123/* Fake handler for attributes we don't properly support, typically because 124 they'd require dragging a lot of the common-c front-end circuitry. */ 125static tree fake_attribute_handler (tree *, tree, tree, int, bool *); 126 127/* Table of machine-independent internal attributes for Ada. We support 128 this minimal set of attributes to accommodate the needs of builtins. */ 129const struct attribute_spec gnat_internal_attribute_table[] = 130{ 131 /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler, 132 affects_type_identity } */ 133 { "const", 0, 0, true, false, false, handle_const_attribute, 134 false }, 135 { "nothrow", 0, 0, true, false, false, handle_nothrow_attribute, 136 false }, 137 { "pure", 0, 0, true, false, false, handle_pure_attribute, 138 false }, 139 { "no vops", 0, 0, true, false, false, handle_novops_attribute, 140 false }, 141 { "nonnull", 0, -1, false, true, true, handle_nonnull_attribute, 142 false }, 143 { "sentinel", 0, 1, false, true, true, handle_sentinel_attribute, 144 false }, 145 { "noreturn", 0, 0, true, false, false, handle_noreturn_attribute, 146 false }, 147 { "leaf", 0, 0, true, false, false, handle_leaf_attribute, 148 false }, 149 { "always_inline",0, 0, true, false, false, handle_always_inline_attribute, 150 false }, 151 { "malloc", 0, 0, true, false, false, handle_malloc_attribute, 152 false }, 153 { "type generic", 0, 0, false, true, true, handle_type_generic_attribute, 154 false }, 155 156 { "vector_size", 1, 1, false, true, false, handle_vector_size_attribute, 157 false }, 158 { "vector_type", 0, 0, false, true, false, handle_vector_type_attribute, 159 false }, 160 { "may_alias", 0, 0, false, true, false, NULL, false }, 161 162 /* ??? format and format_arg are heavy and not supported, which actually 163 prevents support for stdio builtins, which we however declare as part 164 of the common builtins.def contents. */ 165 { "format", 3, 3, false, true, true, fake_attribute_handler, false }, 166 { "format_arg", 1, 1, false, true, true, fake_attribute_handler, false }, 167 168 { NULL, 0, 0, false, false, false, NULL, false } 169}; 170 171/* Associates a GNAT tree node to a GCC tree node. It is used in 172 `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation 173 of `save_gnu_tree' for more info. */ 174static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu; 175 176#define GET_GNU_TREE(GNAT_ENTITY) \ 177 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] 178 179#define SET_GNU_TREE(GNAT_ENTITY,VAL) \ 180 associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] = (VAL) 181 182#define PRESENT_GNU_TREE(GNAT_ENTITY) \ 183 (associate_gnat_to_gnu[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE) 184 185/* Associates a GNAT entity to a GCC tree node used as a dummy, if any. */ 186static GTY((length ("max_gnat_nodes"))) tree *dummy_node_table; 187 188#define GET_DUMMY_NODE(GNAT_ENTITY) \ 189 dummy_node_table[(GNAT_ENTITY) - First_Node_Id] 190 191#define SET_DUMMY_NODE(GNAT_ENTITY,VAL) \ 192 dummy_node_table[(GNAT_ENTITY) - First_Node_Id] = (VAL) 193 194#define PRESENT_DUMMY_NODE(GNAT_ENTITY) \ 195 (dummy_node_table[(GNAT_ENTITY) - First_Node_Id] != NULL_TREE) 196 197/* This variable keeps a table for types for each precision so that we only 198 allocate each of them once. Signed and unsigned types are kept separate. 199 200 Note that these types are only used when fold-const requests something 201 special. Perhaps we should NOT share these types; we'll see how it 202 goes later. */ 203static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2]; 204 205/* Likewise for float types, but record these by mode. */ 206static GTY(()) tree float_types[NUM_MACHINE_MODES]; 207 208/* For each binding contour we allocate a binding_level structure to indicate 209 the binding depth. */ 210 211struct GTY((chain_next ("%h.chain"))) gnat_binding_level { 212 /* The binding level containing this one (the enclosing binding level). */ 213 struct gnat_binding_level *chain; 214 /* The BLOCK node for this level. */ 215 tree block; 216 /* If nonzero, the setjmp buffer that needs to be updated for any 217 variable-sized definition within this context. */ 218 tree jmpbuf_decl; 219}; 220 221/* The binding level currently in effect. */ 222static GTY(()) struct gnat_binding_level *current_binding_level; 223 224/* A chain of gnat_binding_level structures awaiting reuse. */ 225static GTY((deletable)) struct gnat_binding_level *free_binding_level; 226 227/* The context to be used for global declarations. */ 228static GTY(()) tree global_context; 229 230/* An array of global declarations. */ 231static GTY(()) vec<tree, va_gc> *global_decls; 232 233/* An array of builtin function declarations. */ 234static GTY(()) vec<tree, va_gc> *builtin_decls; 235 236/* An array of global renaming pointers. */ 237static GTY(()) vec<tree, va_gc> *global_renaming_pointers; 238 239/* A chain of unused BLOCK nodes. */ 240static GTY((deletable)) tree free_block_chain; 241 242/* A hash table of padded types. It is modelled on the generic type 243 hash table in tree.c, which must thus be used as a reference. */ 244 245struct GTY((for_user)) pad_type_hash { 246 unsigned long hash; 247 tree type; 248}; 249 250struct pad_type_hasher : ggc_cache_hasher<pad_type_hash *> 251{ 252 static inline hashval_t hash (pad_type_hash *t) { return t->hash; } 253 static bool equal (pad_type_hash *a, pad_type_hash *b); 254 static void handle_cache_entry (pad_type_hash *&); 255}; 256 257static GTY ((cache)) 258 hash_table<pad_type_hasher> *pad_type_hash_table; 259 260static tree merge_sizes (tree, tree, tree, bool, bool); 261static tree compute_related_constant (tree, tree); 262static tree split_plus (tree, tree *); 263static tree float_type_for_precision (int, machine_mode); 264static tree convert_to_fat_pointer (tree, tree); 265static unsigned int scale_by_factor_of (tree, unsigned int); 266static bool potential_alignment_gap (tree, tree, tree); 267 268/* A linked list used as a queue to defer the initialization of the 269 DECL_CONTEXT attribute of ..._DECL nodes and of the TYPE_CONTEXT attribute 270 of ..._TYPE nodes. */ 271struct deferred_decl_context_node 272{ 273 tree decl; /* The ..._DECL node to work on. */ 274 Entity_Id gnat_scope; /* The corresponding entity's Scope attribute. */ 275 int force_global; /* force_global value when pushing DECL. */ 276 vec<tree, va_heap, vl_ptr> types; /* A list of ..._TYPE nodes to propagate the 277 context to. */ 278 struct deferred_decl_context_node *next; /* The next queue item. */ 279}; 280 281static struct deferred_decl_context_node *deferred_decl_context_queue = NULL; 282 283/* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to 284 feed it with the elaboration of GNAT_SCOPE. */ 285static struct deferred_decl_context_node * 286add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global); 287 288/* Defer the initialization of TYPE's TYPE_CONTEXT attribute, scheduling to 289 feed it with the DECL_CONTEXT computed as part of N as soon as it is 290 computed. */ 291static void add_deferred_type_context (struct deferred_decl_context_node *n, 292 tree type); 293 294/* Initialize data structures of the utils.c module. */ 295 296void 297init_gnat_utils (void) 298{ 299 /* Initialize the association of GNAT nodes to GCC trees. */ 300 associate_gnat_to_gnu = ggc_cleared_vec_alloc<tree> (max_gnat_nodes); 301 302 /* Initialize the association of GNAT nodes to GCC trees as dummies. */ 303 dummy_node_table = ggc_cleared_vec_alloc<tree> (max_gnat_nodes); 304 305 /* Initialize the hash table of padded types. */ 306 pad_type_hash_table = hash_table<pad_type_hasher>::create_ggc (512); 307} 308 309/* Destroy data structures of the utils.c module. */ 310 311void 312destroy_gnat_utils (void) 313{ 314 /* Destroy the association of GNAT nodes to GCC trees. */ 315 ggc_free (associate_gnat_to_gnu); 316 associate_gnat_to_gnu = NULL; 317 318 /* Destroy the association of GNAT nodes to GCC trees as dummies. */ 319 ggc_free (dummy_node_table); 320 dummy_node_table = NULL; 321 322 /* Destroy the hash table of padded types. */ 323 pad_type_hash_table->empty (); 324 pad_type_hash_table = NULL; 325 326 /* Invalidate the global renaming pointers. */ 327 invalidate_global_renaming_pointers (); 328} 329 330/* GNAT_ENTITY is a GNAT tree node for an entity. Associate GNU_DECL, a GCC 331 tree node, with GNAT_ENTITY. If GNU_DECL is not a ..._DECL node, abort. 332 If NO_CHECK is true, the latter check is suppressed. 333 334 If GNU_DECL is zero, reset a previous association. */ 335 336void 337save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check) 338{ 339 /* Check that GNAT_ENTITY is not already defined and that it is being set 340 to something which is a decl. If that is not the case, this usually 341 means GNAT_ENTITY is defined twice, but occasionally is due to some 342 Gigi problem. */ 343 gcc_assert (!(gnu_decl 344 && (PRESENT_GNU_TREE (gnat_entity) 345 || (!no_check && !DECL_P (gnu_decl))))); 346 347 SET_GNU_TREE (gnat_entity, gnu_decl); 348} 349 350/* GNAT_ENTITY is a GNAT tree node for an entity. Return the GCC tree node 351 that was associated with it. If there is no such tree node, abort. 352 353 In some cases, such as delayed elaboration or expressions that need to 354 be elaborated only once, GNAT_ENTITY is really not an entity. */ 355 356tree 357get_gnu_tree (Entity_Id gnat_entity) 358{ 359 gcc_assert (PRESENT_GNU_TREE (gnat_entity)); 360 return GET_GNU_TREE (gnat_entity); 361} 362 363/* Return nonzero if a GCC tree has been associated with GNAT_ENTITY. */ 364 365bool 366present_gnu_tree (Entity_Id gnat_entity) 367{ 368 return PRESENT_GNU_TREE (gnat_entity); 369} 370 371/* Make a dummy type corresponding to GNAT_TYPE. */ 372 373tree 374make_dummy_type (Entity_Id gnat_type) 375{ 376 Entity_Id gnat_equiv = Gigi_Equivalent_Type (Underlying_Type (gnat_type)); 377 tree gnu_type; 378 379 /* If there was no equivalent type (can only happen when just annotating 380 types) or underlying type, go back to the original type. */ 381 if (No (gnat_equiv)) 382 gnat_equiv = gnat_type; 383 384 /* If it there already a dummy type, use that one. Else make one. */ 385 if (PRESENT_DUMMY_NODE (gnat_equiv)) 386 return GET_DUMMY_NODE (gnat_equiv); 387 388 /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make 389 an ENUMERAL_TYPE. */ 390 gnu_type = make_node (Is_Record_Type (gnat_equiv) 391 ? tree_code_for_record_type (gnat_equiv) 392 : ENUMERAL_TYPE); 393 TYPE_NAME (gnu_type) = get_entity_name (gnat_type); 394 TYPE_DUMMY_P (gnu_type) = 1; 395 TYPE_STUB_DECL (gnu_type) 396 = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type); 397 if (Is_By_Reference_Type (gnat_equiv)) 398 TYPE_BY_REFERENCE_P (gnu_type) = 1; 399 400 SET_DUMMY_NODE (gnat_equiv, gnu_type); 401 402 return gnu_type; 403} 404 405/* Return the dummy type that was made for GNAT_TYPE, if any. */ 406 407tree 408get_dummy_type (Entity_Id gnat_type) 409{ 410 return GET_DUMMY_NODE (gnat_type); 411} 412 413/* Build dummy fat and thin pointer types whose designated type is specified 414 by GNAT_DESIG_TYPE/GNU_DESIG_TYPE and attach them to the latter. */ 415 416void 417build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type) 418{ 419 tree gnu_template_type, gnu_ptr_template, gnu_array_type, gnu_ptr_array; 420 tree gnu_fat_type, fields, gnu_object_type; 421 422 gnu_template_type = make_node (RECORD_TYPE); 423 TYPE_NAME (gnu_template_type) = create_concat_name (gnat_desig_type, "XUB"); 424 TYPE_DUMMY_P (gnu_template_type) = 1; 425 gnu_ptr_template = build_pointer_type (gnu_template_type); 426 427 gnu_array_type = make_node (ENUMERAL_TYPE); 428 TYPE_NAME (gnu_array_type) = create_concat_name (gnat_desig_type, "XUA"); 429 TYPE_DUMMY_P (gnu_array_type) = 1; 430 gnu_ptr_array = build_pointer_type (gnu_array_type); 431 432 gnu_fat_type = make_node (RECORD_TYPE); 433 /* Build a stub DECL to trigger the special processing for fat pointer types 434 in gnat_pushdecl. */ 435 TYPE_NAME (gnu_fat_type) 436 = create_type_stub_decl (create_concat_name (gnat_desig_type, "XUP"), 437 gnu_fat_type); 438 fields = create_field_decl (get_identifier ("P_ARRAY"), gnu_ptr_array, 439 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0); 440 DECL_CHAIN (fields) 441 = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template, 442 gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0); 443 finish_fat_pointer_type (gnu_fat_type, fields); 444 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_desig_type); 445 /* Suppress debug info until after the type is completed. */ 446 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 1; 447 448 gnu_object_type = make_node (RECORD_TYPE); 449 TYPE_NAME (gnu_object_type) = create_concat_name (gnat_desig_type, "XUT"); 450 TYPE_DUMMY_P (gnu_object_type) = 1; 451 452 TYPE_POINTER_TO (gnu_desig_type) = gnu_fat_type; 453 TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type; 454} 455 456/* Return true if we are in the global binding level. */ 457 458bool 459global_bindings_p (void) 460{ 461 return force_global || current_function_decl == NULL_TREE; 462} 463 464/* Enter a new binding level. */ 465 466void 467gnat_pushlevel (void) 468{ 469 struct gnat_binding_level *newlevel = NULL; 470 471 /* Reuse a struct for this binding level, if there is one. */ 472 if (free_binding_level) 473 { 474 newlevel = free_binding_level; 475 free_binding_level = free_binding_level->chain; 476 } 477 else 478 newlevel = ggc_alloc<gnat_binding_level> (); 479 480 /* Use a free BLOCK, if any; otherwise, allocate one. */ 481 if (free_block_chain) 482 { 483 newlevel->block = free_block_chain; 484 free_block_chain = BLOCK_CHAIN (free_block_chain); 485 BLOCK_CHAIN (newlevel->block) = NULL_TREE; 486 } 487 else 488 newlevel->block = make_node (BLOCK); 489 490 /* Point the BLOCK we just made to its parent. */ 491 if (current_binding_level) 492 BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block; 493 494 BLOCK_VARS (newlevel->block) = NULL_TREE; 495 BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE; 496 TREE_USED (newlevel->block) = 1; 497 498 /* Add this level to the front of the chain (stack) of active levels. */ 499 newlevel->chain = current_binding_level; 500 newlevel->jmpbuf_decl = NULL_TREE; 501 current_binding_level = newlevel; 502} 503 504/* Set SUPERCONTEXT of the BLOCK for the current binding level to FNDECL 505 and point FNDECL to this BLOCK. */ 506 507void 508set_current_block_context (tree fndecl) 509{ 510 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl; 511 DECL_INITIAL (fndecl) = current_binding_level->block; 512 set_block_for_group (current_binding_level->block); 513} 514 515/* Set the jmpbuf_decl for the current binding level to DECL. */ 516 517void 518set_block_jmpbuf_decl (tree decl) 519{ 520 current_binding_level->jmpbuf_decl = decl; 521} 522 523/* Get the jmpbuf_decl, if any, for the current binding level. */ 524 525tree 526get_block_jmpbuf_decl (void) 527{ 528 return current_binding_level->jmpbuf_decl; 529} 530 531/* Exit a binding level. Set any BLOCK into the current code group. */ 532 533void 534gnat_poplevel (void) 535{ 536 struct gnat_binding_level *level = current_binding_level; 537 tree block = level->block; 538 539 BLOCK_VARS (block) = nreverse (BLOCK_VARS (block)); 540 BLOCK_SUBBLOCKS (block) = blocks_nreverse (BLOCK_SUBBLOCKS (block)); 541 542 /* If this is a function-level BLOCK don't do anything. Otherwise, if there 543 are no variables free the block and merge its subblocks into those of its 544 parent block. Otherwise, add it to the list of its parent. */ 545 if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL) 546 ; 547 else if (BLOCK_VARS (block) == NULL_TREE) 548 { 549 BLOCK_SUBBLOCKS (level->chain->block) 550 = block_chainon (BLOCK_SUBBLOCKS (block), 551 BLOCK_SUBBLOCKS (level->chain->block)); 552 BLOCK_CHAIN (block) = free_block_chain; 553 free_block_chain = block; 554 } 555 else 556 { 557 BLOCK_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block); 558 BLOCK_SUBBLOCKS (level->chain->block) = block; 559 TREE_USED (block) = 1; 560 set_block_for_group (block); 561 } 562 563 /* Free this binding structure. */ 564 current_binding_level = level->chain; 565 level->chain = free_binding_level; 566 free_binding_level = level; 567} 568 569/* Exit a binding level and discard the associated BLOCK. */ 570 571void 572gnat_zaplevel (void) 573{ 574 struct gnat_binding_level *level = current_binding_level; 575 tree block = level->block; 576 577 BLOCK_CHAIN (block) = free_block_chain; 578 free_block_chain = block; 579 580 /* Free this binding structure. */ 581 current_binding_level = level->chain; 582 level->chain = free_binding_level; 583 free_binding_level = level; 584} 585 586/* Set the context of TYPE and its parallel types (if any) to CONTEXT. */ 587 588static void 589gnat_set_type_context (tree type, tree context) 590{ 591 tree decl = TYPE_STUB_DECL (type); 592 593 TYPE_CONTEXT (type) = context; 594 595 while (decl && DECL_PARALLEL_TYPE (decl)) 596 { 597 tree parallel_type = DECL_PARALLEL_TYPE (decl); 598 599 /* Give a context to the parallel types and their stub decl, if any. 600 Some parallel types seems to be present in multiple parallel type 601 chains, so don't mess with their context if they already have one. */ 602 if (TYPE_CONTEXT (parallel_type) == NULL_TREE) 603 { 604 if (TYPE_STUB_DECL (parallel_type) != NULL_TREE) 605 DECL_CONTEXT (TYPE_STUB_DECL (parallel_type)) = context; 606 TYPE_CONTEXT (parallel_type) = context; 607 } 608 609 decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl)); 610 } 611} 612 613/* Return the innermost scope, starting at GNAT_NODE, we are be interested in 614 the debug info, or Empty if there is no such scope. If not NULL, set 615 IS_SUBPROGRAM to whether the returned entity is a subprogram. */ 616 617static Entity_Id 618get_debug_scope (Node_Id gnat_node, bool *is_subprogram) 619{ 620 Entity_Id gnat_entity; 621 622 if (is_subprogram) 623 *is_subprogram = false; 624 625 if (Nkind (gnat_node) == N_Defining_Identifier) 626 gnat_entity = Scope (gnat_node); 627 else 628 return Empty; 629 630 while (Present (gnat_entity)) 631 { 632 switch (Ekind (gnat_entity)) 633 { 634 case E_Function: 635 case E_Procedure: 636 if (Present (Protected_Body_Subprogram (gnat_entity))) 637 gnat_entity = Protected_Body_Subprogram (gnat_entity); 638 639 /* If the scope is a subprogram, then just rely on 640 current_function_decl, so that we don't have to defer 641 anything. This is needed because other places rely on the 642 validity of the DECL_CONTEXT attribute of FUNCTION_DECL nodes. */ 643 if (is_subprogram) 644 *is_subprogram = true; 645 return gnat_entity; 646 647 case E_Record_Type: 648 case E_Record_Subtype: 649 return gnat_entity; 650 651 default: 652 /* By default, we are not interested in this particular scope: go to 653 the outer one. */ 654 break; 655 } 656 gnat_entity = Scope (gnat_entity); 657 } 658 return Empty; 659} 660 661/* If N is NULL, set TYPE's context to CONTEXT. Defer this to the processing of 662 N otherwise. */ 663 664static void 665defer_or_set_type_context (tree type, 666 tree context, 667 struct deferred_decl_context_node *n) 668{ 669 if (n) 670 add_deferred_type_context (n, type); 671 else 672 gnat_set_type_context (type, context); 673} 674 675/* Return global_context. Create it if needed, first. */ 676 677static tree 678get_global_context (void) 679{ 680 if (!global_context) 681 { 682 global_context = build_translation_unit_decl (NULL_TREE); 683 debug_hooks->register_main_translation_unit (global_context); 684 } 685 return global_context; 686} 687 688/* Record DECL as belonging to the current lexical scope and use GNAT_NODE 689 for location information and flag propagation. */ 690 691void 692gnat_pushdecl (tree decl, Node_Id gnat_node) 693{ 694 tree context = NULL_TREE; 695 struct deferred_decl_context_node *deferred_decl_context = NULL; 696 697 /* If explicitely asked to make DECL global or if it's an imported nested 698 object, short-circuit the regular Scope-based context computation. */ 699 if (!((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || force_global == 1)) 700 { 701 /* Rely on the GNAT scope, or fallback to the current_function_decl if 702 the GNAT scope reached the global scope, if it reached a subprogram 703 or the declaration is a subprogram or a variable (for them we skip 704 intermediate context types because the subprogram body elaboration 705 machinery and the inliner both expect a subprogram context). 706 707 Falling back to current_function_decl is necessary for implicit 708 subprograms created by gigi, such as the elaboration subprograms. */ 709 bool context_is_subprogram = false; 710 const Entity_Id gnat_scope 711 = get_debug_scope (gnat_node, &context_is_subprogram); 712 713 if (Present (gnat_scope) 714 && !context_is_subprogram 715 && TREE_CODE (decl) != FUNCTION_DECL 716 && TREE_CODE (decl) != VAR_DECL) 717 /* Always assume the scope has not been elaborated, thus defer the 718 context propagation to the time its elaboration will be 719 available. */ 720 deferred_decl_context 721 = add_deferred_decl_context (decl, gnat_scope, force_global); 722 723 /* External declarations (when force_global > 0) may not be in a 724 local context. */ 725 else if (current_function_decl != NULL_TREE && force_global == 0) 726 context = current_function_decl; 727 } 728 729 /* If either we are forced to be in global mode or if both the GNAT scope and 730 the current_function_decl did not help determining the context, use the 731 global scope. */ 732 if (!deferred_decl_context && context == NULL_TREE) 733 context = get_global_context (); 734 735 /* Functions imported in another function are not really nested. 736 For really nested functions mark them initially as needing 737 a static chain for uses of that flag before unnesting; 738 lower_nested_functions will then recompute it. */ 739 if (TREE_CODE (decl) == FUNCTION_DECL 740 && !TREE_PUBLIC (decl) 741 && context != NULL_TREE 742 && (TREE_CODE (context) == FUNCTION_DECL 743 || decl_function_context (context) != NULL_TREE)) 744 DECL_STATIC_CHAIN (decl) = 1; 745 746 if (!deferred_decl_context) 747 DECL_CONTEXT (decl) = context; 748 749 TREE_NO_WARNING (decl) = (No (gnat_node) || Warnings_Off (gnat_node)); 750 751 /* Set the location of DECL and emit a declaration for it. */ 752 if (Present (gnat_node) && !renaming_from_generic_instantiation_p (gnat_node)) 753 Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl)); 754 755 add_decl_expr (decl, gnat_node); 756 757 /* Put the declaration on the list. The list of declarations is in reverse 758 order. The list will be reversed later. Put global declarations in the 759 globals list and local ones in the current block. But skip TYPE_DECLs 760 for UNCONSTRAINED_ARRAY_TYPE in both cases, as they will cause trouble 761 with the debugger and aren't needed anyway. */ 762 if (!(TREE_CODE (decl) == TYPE_DECL 763 && TREE_CODE (TREE_TYPE (decl)) == UNCONSTRAINED_ARRAY_TYPE)) 764 { 765 if (DECL_EXTERNAL (decl)) 766 { 767 if (TREE_CODE (decl) == FUNCTION_DECL && DECL_BUILT_IN (decl)) 768 vec_safe_push (builtin_decls, decl); 769 } 770 else if (global_bindings_p ()) 771 vec_safe_push (global_decls, decl); 772 else 773 { 774 DECL_CHAIN (decl) = BLOCK_VARS (current_binding_level->block); 775 BLOCK_VARS (current_binding_level->block) = decl; 776 } 777 } 778 779 /* For the declaration of a type, set its name either if it isn't already 780 set or if the previous type name was not derived from a source name. 781 We'd rather have the type named with a real name and all the pointer 782 types to the same object have the same node, except when the names are 783 both derived from source names. */ 784 if (TREE_CODE (decl) == TYPE_DECL && DECL_NAME (decl)) 785 { 786 tree t = TREE_TYPE (decl); 787 788 if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL) 789 && (TREE_CODE (t) != POINTER_TYPE || DECL_ARTIFICIAL (decl))) 790 { 791 /* Array types aren't "tagged" types so we force the type to be 792 associated with its typedef in the DWARF back-end, in order to 793 make sure that the latter is always preserved, by creating an 794 on-side copy for DECL_ORIGINAL_TYPE. We used to do the same 795 for pointer types, but to have consistent DWARF output we now 796 create a copy for the type itself and use the original type 797 for DECL_ORIGINAL_TYPE like the C front-end. */ 798 if (!DECL_ARTIFICIAL (decl) && TREE_CODE (t) == ARRAY_TYPE) 799 { 800 tree tt = build_distinct_type_copy (t); 801 /* Array types need to have a name so that they can be related 802 to their GNAT encodings. */ 803 TYPE_NAME (tt) = DECL_NAME (decl); 804 defer_or_set_type_context (tt, 805 DECL_CONTEXT (decl), 806 deferred_decl_context); 807 TYPE_STUB_DECL (tt) = TYPE_STUB_DECL (t); 808 DECL_ORIGINAL_TYPE (decl) = tt; 809 } 810 } 811 else if (!DECL_ARTIFICIAL (decl) 812 && (TREE_CODE (t) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (t))) 813 { 814 tree tt; 815 /* ??? Copy and original type are not supposed to be variant but we 816 really need a variant for the placeholder machinery to work. */ 817 if (TYPE_IS_FAT_POINTER_P (t)) 818 tt = build_variant_type_copy (t); 819 else 820 { 821 /* TYPE_NEXT_PTR_TO is a chain of main variants. */ 822 tt = build_distinct_type_copy (TYPE_MAIN_VARIANT (t)); 823 TYPE_NEXT_PTR_TO (TYPE_MAIN_VARIANT (t)) = tt; 824 tt = build_qualified_type (tt, TYPE_QUALS (t)); 825 } 826 TYPE_NAME (tt) = decl; 827 defer_or_set_type_context (tt, 828 DECL_CONTEXT (decl), 829 deferred_decl_context); 830 TREE_USED (tt) = TREE_USED (t); 831 TREE_TYPE (decl) = tt; 832 if (TYPE_NAME (t) != NULL_TREE 833 && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL 834 && DECL_ORIGINAL_TYPE (TYPE_NAME (t))) 835 DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t)); 836 else 837 DECL_ORIGINAL_TYPE (decl) = t; 838 t = NULL_TREE; 839 } 840 else if (TYPE_NAME (t) != NULL_TREE 841 && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL 842 && DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl)) 843 ; 844 else 845 t = NULL_TREE; 846 847 /* Propagate the name to all the anonymous variants. This is needed 848 for the type qualifiers machinery to work properly (see 849 check_qualified_type). Also propagate the context to them. Note that 850 the context will be propagated to all parallel types too thanks to 851 gnat_set_type_context. */ 852 if (t) 853 for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) 854 if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)) 855 { 856 TYPE_NAME (t) = decl; 857 defer_or_set_type_context (t, 858 DECL_CONTEXT (decl), 859 deferred_decl_context); 860 } 861 } 862} 863 864/* Create a record type that contains a SIZE bytes long field of TYPE with a 865 starting bit position so that it is aligned to ALIGN bits, and leaving at 866 least ROOM bytes free before the field. BASE_ALIGN is the alignment the 867 record is guaranteed to get. GNAT_NODE is used for the position of the 868 associated TYPE_DECL. */ 869 870tree 871make_aligning_type (tree type, unsigned int align, tree size, 872 unsigned int base_align, int room, Node_Id gnat_node) 873{ 874 /* We will be crafting a record type with one field at a position set to be 875 the next multiple of ALIGN past record'address + room bytes. We use a 876 record placeholder to express record'address. */ 877 tree record_type = make_node (RECORD_TYPE); 878 tree record = build0 (PLACEHOLDER_EXPR, record_type); 879 880 tree record_addr_st 881 = convert (sizetype, build_unary_op (ADDR_EXPR, NULL_TREE, record)); 882 883 /* The diagram below summarizes the shape of what we manipulate: 884 885 <--------- pos ----------> 886 { +------------+-------------+-----------------+ 887 record =>{ |############| ... | field (type) | 888 { +------------+-------------+-----------------+ 889 |<-- room -->|<- voffset ->|<---- size ----->| 890 o o 891 | | 892 record_addr vblock_addr 893 894 Every length is in sizetype bytes there, except "pos" which has to be 895 set as a bit position in the GCC tree for the record. */ 896 tree room_st = size_int (room); 897 tree vblock_addr_st = size_binop (PLUS_EXPR, record_addr_st, room_st); 898 tree voffset_st, pos, field; 899 900 tree name = TYPE_IDENTIFIER (type); 901 902 name = concat_name (name, "ALIGN"); 903 TYPE_NAME (record_type) = name; 904 905 /* Compute VOFFSET and then POS. The next byte position multiple of some 906 alignment after some address is obtained by "and"ing the alignment minus 907 1 with the two's complement of the address. */ 908 voffset_st = size_binop (BIT_AND_EXPR, 909 fold_build1 (NEGATE_EXPR, sizetype, vblock_addr_st), 910 size_int ((align / BITS_PER_UNIT) - 1)); 911 912 /* POS = (ROOM + VOFFSET) * BIT_PER_UNIT, in bitsizetype. */ 913 pos = size_binop (MULT_EXPR, 914 convert (bitsizetype, 915 size_binop (PLUS_EXPR, room_st, voffset_st)), 916 bitsize_unit_node); 917 918 /* Craft the GCC record representation. We exceptionally do everything 919 manually here because 1) our generic circuitry is not quite ready to 920 handle the complex position/size expressions we are setting up, 2) we 921 have a strong simplifying factor at hand: we know the maximum possible 922 value of voffset, and 3) we have to set/reset at least the sizes in 923 accordance with this maximum value anyway, as we need them to convey 924 what should be "alloc"ated for this type. 925 926 Use -1 as the 'addressable' indication for the field to prevent the 927 creation of a bitfield. We don't need one, it would have damaging 928 consequences on the alignment computation, and create_field_decl would 929 make one without this special argument, for instance because of the 930 complex position expression. */ 931 field = create_field_decl (get_identifier ("F"), type, record_type, size, 932 pos, 1, -1); 933 TYPE_FIELDS (record_type) = field; 934 935 TYPE_ALIGN (record_type) = base_align; 936 TYPE_USER_ALIGN (record_type) = 1; 937 938 TYPE_SIZE (record_type) 939 = size_binop (PLUS_EXPR, 940 size_binop (MULT_EXPR, convert (bitsizetype, size), 941 bitsize_unit_node), 942 bitsize_int (align + room * BITS_PER_UNIT)); 943 TYPE_SIZE_UNIT (record_type) 944 = size_binop (PLUS_EXPR, size, 945 size_int (room + align / BITS_PER_UNIT)); 946 947 SET_TYPE_MODE (record_type, BLKmode); 948 relate_alias_sets (record_type, type, ALIAS_SET_COPY); 949 950 /* Declare it now since it will never be declared otherwise. This is 951 necessary to ensure that its subtrees are properly marked. */ 952 create_type_decl (name, record_type, true, false, gnat_node); 953 954 return record_type; 955} 956 957/* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used 958 as the field type of a packed record if IN_RECORD is true, or as the 959 component type of a packed array if IN_RECORD is false. See if we can 960 rewrite it either as a type that has a non-BLKmode, which we can pack 961 tighter in the packed record case, or as a smaller type. If so, return 962 the new type. If not, return the original type. */ 963 964tree 965make_packable_type (tree type, bool in_record) 966{ 967 unsigned HOST_WIDE_INT size = tree_to_uhwi (TYPE_SIZE (type)); 968 unsigned HOST_WIDE_INT new_size; 969 tree new_type, old_field, field_list = NULL_TREE; 970 unsigned int align; 971 972 /* No point in doing anything if the size is zero. */ 973 if (size == 0) 974 return type; 975 976 new_type = make_node (TREE_CODE (type)); 977 978 /* Copy the name and flags from the old type to that of the new. 979 Note that we rely on the pointer equality created here for 980 TYPE_NAME to look through conversions in various places. */ 981 TYPE_NAME (new_type) = TYPE_NAME (type); 982 TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type); 983 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); 984 if (TREE_CODE (type) == RECORD_TYPE) 985 TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type); 986 987 /* If we are in a record and have a small size, set the alignment to 988 try for an integral mode. Otherwise set it to try for a smaller 989 type with BLKmode. */ 990 if (in_record && size <= MAX_FIXED_MODE_SIZE) 991 { 992 align = ceil_pow2 (size); 993 TYPE_ALIGN (new_type) = align; 994 new_size = (size + align - 1) & -align; 995 } 996 else 997 { 998 unsigned HOST_WIDE_INT align; 999 1000 /* Do not try to shrink the size if the RM size is not constant. */ 1001 if (TYPE_CONTAINS_TEMPLATE_P (type) 1002 || !tree_fits_uhwi_p (TYPE_ADA_SIZE (type))) 1003 return type; 1004 1005 /* Round the RM size up to a unit boundary to get the minimal size 1006 for a BLKmode record. Give up if it's already the size. */ 1007 new_size = tree_to_uhwi (TYPE_ADA_SIZE (type)); 1008 new_size = (new_size + BITS_PER_UNIT - 1) & -BITS_PER_UNIT; 1009 if (new_size == size) 1010 return type; 1011 1012 align = new_size & -new_size; 1013 TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align); 1014 } 1015 1016 TYPE_USER_ALIGN (new_type) = 1; 1017 1018 /* Now copy the fields, keeping the position and size as we don't want 1019 to change the layout by propagating the packedness downwards. */ 1020 for (old_field = TYPE_FIELDS (type); old_field; 1021 old_field = DECL_CHAIN (old_field)) 1022 { 1023 tree new_field_type = TREE_TYPE (old_field); 1024 tree new_field, new_size; 1025 1026 if (RECORD_OR_UNION_TYPE_P (new_field_type) 1027 && !TYPE_FAT_POINTER_P (new_field_type) 1028 && tree_fits_uhwi_p (TYPE_SIZE (new_field_type))) 1029 new_field_type = make_packable_type (new_field_type, true); 1030 1031 /* However, for the last field in a not already packed record type 1032 that is of an aggregate type, we need to use the RM size in the 1033 packable version of the record type, see finish_record_type. */ 1034 if (!DECL_CHAIN (old_field) 1035 && !TYPE_PACKED (type) 1036 && RECORD_OR_UNION_TYPE_P (new_field_type) 1037 && !TYPE_FAT_POINTER_P (new_field_type) 1038 && !TYPE_CONTAINS_TEMPLATE_P (new_field_type) 1039 && TYPE_ADA_SIZE (new_field_type)) 1040 new_size = TYPE_ADA_SIZE (new_field_type); 1041 else 1042 new_size = DECL_SIZE (old_field); 1043 1044 new_field 1045 = create_field_decl (DECL_NAME (old_field), new_field_type, new_type, 1046 new_size, bit_position (old_field), 1047 TYPE_PACKED (type), 1048 !DECL_NONADDRESSABLE_P (old_field)); 1049 1050 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); 1051 SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field); 1052 if (TREE_CODE (new_type) == QUAL_UNION_TYPE) 1053 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field); 1054 1055 DECL_CHAIN (new_field) = field_list; 1056 field_list = new_field; 1057 } 1058 1059 finish_record_type (new_type, nreverse (field_list), 2, false); 1060 relate_alias_sets (new_type, type, ALIAS_SET_COPY); 1061 if (TYPE_STUB_DECL (type)) 1062 SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type), 1063 DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type))); 1064 1065 /* If this is a padding record, we never want to make the size smaller 1066 than what was specified. For QUAL_UNION_TYPE, also copy the size. */ 1067 if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE) 1068 { 1069 TYPE_SIZE (new_type) = TYPE_SIZE (type); 1070 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type); 1071 new_size = size; 1072 } 1073 else 1074 { 1075 TYPE_SIZE (new_type) = bitsize_int (new_size); 1076 TYPE_SIZE_UNIT (new_type) 1077 = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT); 1078 } 1079 1080 if (!TYPE_CONTAINS_TEMPLATE_P (type)) 1081 SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (type)); 1082 1083 compute_record_mode (new_type); 1084 1085 /* Try harder to get a packable type if necessary, for example 1086 in case the record itself contains a BLKmode field. */ 1087 if (in_record && TYPE_MODE (new_type) == BLKmode) 1088 SET_TYPE_MODE (new_type, 1089 mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1)); 1090 1091 /* If neither the mode nor the size has shrunk, return the old type. */ 1092 if (TYPE_MODE (new_type) == BLKmode && new_size >= size) 1093 return type; 1094 1095 return new_type; 1096} 1097 1098/* Given a type TYPE, return a new type whose size is appropriate for SIZE. 1099 If TYPE is the best type, return it. Otherwise, make a new type. We 1100 only support new integral and pointer types. FOR_BIASED is true if 1101 we are making a biased type. */ 1102 1103tree 1104make_type_from_size (tree type, tree size_tree, bool for_biased) 1105{ 1106 unsigned HOST_WIDE_INT size; 1107 bool biased_p; 1108 tree new_type; 1109 1110 /* If size indicates an error, just return TYPE to avoid propagating 1111 the error. Likewise if it's too large to represent. */ 1112 if (!size_tree || !tree_fits_uhwi_p (size_tree)) 1113 return type; 1114 1115 size = tree_to_uhwi (size_tree); 1116 1117 switch (TREE_CODE (type)) 1118 { 1119 case INTEGER_TYPE: 1120 case ENUMERAL_TYPE: 1121 case BOOLEAN_TYPE: 1122 biased_p = (TREE_CODE (type) == INTEGER_TYPE 1123 && TYPE_BIASED_REPRESENTATION_P (type)); 1124 1125 /* Integer types with precision 0 are forbidden. */ 1126 if (size == 0) 1127 size = 1; 1128 1129 /* Only do something if the type isn't a packed array type and doesn't 1130 already have the proper size and the size isn't too large. */ 1131 if (TYPE_IS_PACKED_ARRAY_TYPE_P (type) 1132 || (TYPE_PRECISION (type) == size && biased_p == for_biased) 1133 || size > LONG_LONG_TYPE_SIZE) 1134 break; 1135 1136 biased_p |= for_biased; 1137 if (TYPE_UNSIGNED (type) || biased_p) 1138 new_type = make_unsigned_type (size); 1139 else 1140 new_type = make_signed_type (size); 1141 TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type; 1142 SET_TYPE_RM_MIN_VALUE (new_type, TYPE_MIN_VALUE (type)); 1143 SET_TYPE_RM_MAX_VALUE (new_type, TYPE_MAX_VALUE (type)); 1144 /* Copy the name to show that it's essentially the same type and 1145 not a subrange type. */ 1146 TYPE_NAME (new_type) = TYPE_NAME (type); 1147 TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p; 1148 SET_TYPE_RM_SIZE (new_type, bitsize_int (size)); 1149 return new_type; 1150 1151 case RECORD_TYPE: 1152 /* Do something if this is a fat pointer, in which case we 1153 may need to return the thin pointer. */ 1154 if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) 1155 { 1156 machine_mode p_mode = mode_for_size (size, MODE_INT, 0); 1157 if (!targetm.valid_pointer_mode (p_mode)) 1158 p_mode = ptr_mode; 1159 return 1160 build_pointer_type_for_mode 1161 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)), 1162 p_mode, 0); 1163 } 1164 break; 1165 1166 case POINTER_TYPE: 1167 /* Only do something if this is a thin pointer, in which case we 1168 may need to return the fat pointer. */ 1169 if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) 1170 return 1171 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))); 1172 break; 1173 1174 default: 1175 break; 1176 } 1177 1178 return type; 1179} 1180 1181/* See if the data pointed to by the hash table slot is marked. */ 1182 1183void 1184pad_type_hasher::handle_cache_entry (pad_type_hash *&t) 1185{ 1186 extern void gt_ggc_mx (pad_type_hash *&); 1187 if (t == HTAB_EMPTY_ENTRY || t == HTAB_DELETED_ENTRY) 1188 return; 1189 else if (ggc_marked_p (t->type)) 1190 gt_ggc_mx (t); 1191 else 1192 t = static_cast<pad_type_hash *> (HTAB_DELETED_ENTRY); 1193} 1194 1195/* Return true iff the padded types are equivalent. */ 1196 1197bool 1198pad_type_hasher::equal (pad_type_hash *t1, pad_type_hash *t2) 1199{ 1200 tree type1, type2; 1201 1202 if (t1->hash != t2->hash) 1203 return 0; 1204 1205 type1 = t1->type; 1206 type2 = t2->type; 1207 1208 /* We consider that the padded types are equivalent if they pad the same 1209 type and have the same size, alignment and RM size. Taking the mode 1210 into account is redundant since it is determined by the others. */ 1211 return 1212 TREE_TYPE (TYPE_FIELDS (type1)) == TREE_TYPE (TYPE_FIELDS (type2)) 1213 && TYPE_SIZE (type1) == TYPE_SIZE (type2) 1214 && TYPE_ALIGN (type1) == TYPE_ALIGN (type2) 1215 && TYPE_ADA_SIZE (type1) == TYPE_ADA_SIZE (type2); 1216} 1217 1218/* Look up the padded TYPE in the hash table and return its canonical version 1219 if it exists; otherwise, insert it into the hash table. */ 1220 1221static tree 1222lookup_and_insert_pad_type (tree type) 1223{ 1224 hashval_t hashcode; 1225 struct pad_type_hash in, *h; 1226 1227 hashcode 1228 = iterative_hash_object (TYPE_HASH (TREE_TYPE (TYPE_FIELDS (type))), 0); 1229 hashcode = iterative_hash_expr (TYPE_SIZE (type), hashcode); 1230 hashcode = iterative_hash_hashval_t (TYPE_ALIGN (type), hashcode); 1231 hashcode = iterative_hash_expr (TYPE_ADA_SIZE (type), hashcode); 1232 1233 in.hash = hashcode; 1234 in.type = type; 1235 h = pad_type_hash_table->find_with_hash (&in, hashcode); 1236 if (h) 1237 return h->type; 1238 1239 h = ggc_alloc<pad_type_hash> (); 1240 h->hash = hashcode; 1241 h->type = type; 1242 *pad_type_hash_table->find_slot_with_hash (h, hashcode, INSERT) = h; 1243 return NULL_TREE; 1244} 1245 1246/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type 1247 if needed. We have already verified that SIZE and ALIGN are large enough. 1248 GNAT_ENTITY is used to name the resulting record and to issue a warning. 1249 IS_COMPONENT_TYPE is true if this is being done for the component type of 1250 an array. IS_USER_TYPE is true if the original type needs to be completed. 1251 DEFINITION is true if this type is being defined. SET_RM_SIZE is true if 1252 the RM size of the resulting type is to be set to SIZE too. */ 1253 1254tree 1255maybe_pad_type (tree type, tree size, unsigned int align, 1256 Entity_Id gnat_entity, bool is_component_type, 1257 bool is_user_type, bool definition, bool set_rm_size) 1258{ 1259 tree orig_size = TYPE_SIZE (type); 1260 unsigned int orig_align = TYPE_ALIGN (type); 1261 tree record, field; 1262 1263 /* If TYPE is a padded type, see if it agrees with any size and alignment 1264 we were given. If so, return the original type. Otherwise, strip 1265 off the padding, since we will either be returning the inner type 1266 or repadding it. If no size or alignment is specified, use that of 1267 the original padded type. */ 1268 if (TYPE_IS_PADDING_P (type)) 1269 { 1270 if ((!size 1271 || operand_equal_p (round_up (size, orig_align), orig_size, 0)) 1272 && (align == 0 || align == orig_align)) 1273 return type; 1274 1275 if (!size) 1276 size = orig_size; 1277 if (align == 0) 1278 align = orig_align; 1279 1280 type = TREE_TYPE (TYPE_FIELDS (type)); 1281 orig_size = TYPE_SIZE (type); 1282 orig_align = TYPE_ALIGN (type); 1283 } 1284 1285 /* If the size is either not being changed or is being made smaller (which 1286 is not done here and is only valid for bitfields anyway), show the size 1287 isn't changing. Likewise, clear the alignment if it isn't being 1288 changed. Then return if we aren't doing anything. */ 1289 if (size 1290 && (operand_equal_p (size, orig_size, 0) 1291 || (TREE_CODE (orig_size) == INTEGER_CST 1292 && tree_int_cst_lt (size, orig_size)))) 1293 size = NULL_TREE; 1294 1295 if (align == orig_align) 1296 align = 0; 1297 1298 if (align == 0 && !size) 1299 return type; 1300 1301 /* If requested, complete the original type and give it a name. */ 1302 if (is_user_type) 1303 create_type_decl (get_entity_name (gnat_entity), type, 1304 !Comes_From_Source (gnat_entity), 1305 !(TYPE_NAME (type) 1306 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL 1307 && DECL_IGNORED_P (TYPE_NAME (type))), 1308 gnat_entity); 1309 1310 /* We used to modify the record in place in some cases, but that could 1311 generate incorrect debugging information. So make a new record 1312 type and name. */ 1313 record = make_node (RECORD_TYPE); 1314 TYPE_PADDING_P (record) = 1; 1315 1316 if (Present (gnat_entity)) 1317 TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD"); 1318 1319 TYPE_ALIGN (record) = align ? align : orig_align; 1320 TYPE_SIZE (record) = size ? size : orig_size; 1321 TYPE_SIZE_UNIT (record) 1322 = convert (sizetype, 1323 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record), 1324 bitsize_unit_node)); 1325 1326 /* If we are changing the alignment and the input type is a record with 1327 BLKmode and a small constant size, try to make a form that has an 1328 integral mode. This might allow the padding record to also have an 1329 integral mode, which will be much more efficient. There is no point 1330 in doing so if a size is specified unless it is also a small constant 1331 size and it is incorrect to do so if we cannot guarantee that the mode 1332 will be naturally aligned since the field must always be addressable. 1333 1334 ??? This might not always be a win when done for a stand-alone object: 1335 since the nominal and the effective type of the object will now have 1336 different modes, a VIEW_CONVERT_EXPR will be required for converting 1337 between them and it might be hard to overcome afterwards, including 1338 at the RTL level when the stand-alone object is accessed as a whole. */ 1339 if (align != 0 1340 && RECORD_OR_UNION_TYPE_P (type) 1341 && TYPE_MODE (type) == BLKmode 1342 && !TYPE_BY_REFERENCE_P (type) 1343 && TREE_CODE (orig_size) == INTEGER_CST 1344 && !TREE_OVERFLOW (orig_size) 1345 && compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0 1346 && (!size 1347 || (TREE_CODE (size) == INTEGER_CST 1348 && compare_tree_int (size, MAX_FIXED_MODE_SIZE) <= 0))) 1349 { 1350 tree packable_type = make_packable_type (type, true); 1351 if (TYPE_MODE (packable_type) != BLKmode 1352 && align >= TYPE_ALIGN (packable_type)) 1353 type = packable_type; 1354 } 1355 1356 /* Now create the field with the original size. */ 1357 field = create_field_decl (get_identifier ("F"), type, record, orig_size, 1358 bitsize_zero_node, 0, 1); 1359 DECL_INTERNAL_P (field) = 1; 1360 1361 /* Do not emit debug info until after the auxiliary record is built. */ 1362 finish_record_type (record, field, 1, false); 1363 1364 /* Set the RM size if requested. */ 1365 if (set_rm_size) 1366 { 1367 tree canonical_pad_type; 1368 1369 SET_TYPE_ADA_SIZE (record, size ? size : orig_size); 1370 1371 /* If the padded type is complete and has constant size, we canonicalize 1372 it by means of the hash table. This is consistent with the language 1373 semantics and ensures that gigi and the middle-end have a common view 1374 of these padded types. */ 1375 if (TREE_CONSTANT (TYPE_SIZE (record)) 1376 && (canonical_pad_type = lookup_and_insert_pad_type (record))) 1377 { 1378 record = canonical_pad_type; 1379 goto built; 1380 } 1381 } 1382 1383 /* Unless debugging information isn't being written for the input type, 1384 write a record that shows what we are a subtype of and also make a 1385 variable that indicates our size, if still variable. */ 1386 if (TREE_CODE (orig_size) != INTEGER_CST 1387 && TYPE_NAME (record) 1388 && TYPE_NAME (type) 1389 && !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL 1390 && DECL_IGNORED_P (TYPE_NAME (type)))) 1391 { 1392 tree marker = make_node (RECORD_TYPE); 1393 tree name = TYPE_IDENTIFIER (record); 1394 tree orig_name = TYPE_IDENTIFIER (type); 1395 1396 TYPE_NAME (marker) = concat_name (name, "XVS"); 1397 finish_record_type (marker, 1398 create_field_decl (orig_name, 1399 build_reference_type (type), 1400 marker, NULL_TREE, NULL_TREE, 1401 0, 0), 1402 0, true); 1403 1404 add_parallel_type (record, marker); 1405 1406 if (definition && size && TREE_CODE (size) != INTEGER_CST) 1407 TYPE_SIZE_UNIT (marker) 1408 = create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype, 1409 TYPE_SIZE_UNIT (record), false, false, false, 1410 false, NULL, gnat_entity); 1411 } 1412 1413 rest_of_record_type_compilation (record); 1414 1415built: 1416 /* If the size was widened explicitly, maybe give a warning. Take the 1417 original size as the maximum size of the input if there was an 1418 unconstrained record involved and round it up to the specified alignment, 1419 if one was specified. But don't do it if we are just annotating types 1420 and the type is tagged, since tagged types aren't fully laid out in this 1421 mode. */ 1422 if (!size 1423 || TREE_CODE (size) == COND_EXPR 1424 || TREE_CODE (size) == MAX_EXPR 1425 || No (gnat_entity) 1426 || (type_annotate_only && Is_Tagged_Type (Etype (gnat_entity)))) 1427 return record; 1428 1429 if (CONTAINS_PLACEHOLDER_P (orig_size)) 1430 orig_size = max_size (orig_size, true); 1431 1432 if (align) 1433 orig_size = round_up (orig_size, align); 1434 1435 if (!operand_equal_p (size, orig_size, 0) 1436 && !(TREE_CODE (size) == INTEGER_CST 1437 && TREE_CODE (orig_size) == INTEGER_CST 1438 && (TREE_OVERFLOW (size) 1439 || TREE_OVERFLOW (orig_size) 1440 || tree_int_cst_lt (size, orig_size)))) 1441 { 1442 Node_Id gnat_error_node = Empty; 1443 1444 /* For a packed array, post the message on the original array type. */ 1445 if (Is_Packed_Array_Impl_Type (gnat_entity)) 1446 gnat_entity = Original_Array_Type (gnat_entity); 1447 1448 if ((Ekind (gnat_entity) == E_Component 1449 || Ekind (gnat_entity) == E_Discriminant) 1450 && Present (Component_Clause (gnat_entity))) 1451 gnat_error_node = Last_Bit (Component_Clause (gnat_entity)); 1452 else if (Present (Size_Clause (gnat_entity))) 1453 gnat_error_node = Expression (Size_Clause (gnat_entity)); 1454 1455 /* Generate message only for entities that come from source, since 1456 if we have an entity created by expansion, the message will be 1457 generated for some other corresponding source entity. */ 1458 if (Comes_From_Source (gnat_entity)) 1459 { 1460 if (Present (gnat_error_node)) 1461 post_error_ne_tree ("{^ }bits of & unused?", 1462 gnat_error_node, gnat_entity, 1463 size_diffop (size, orig_size)); 1464 else if (is_component_type) 1465 post_error_ne_tree ("component of& padded{ by ^ bits}?", 1466 gnat_entity, gnat_entity, 1467 size_diffop (size, orig_size)); 1468 } 1469 } 1470 1471 return record; 1472} 1473 1474/* Relate the alias sets of GNU_NEW_TYPE and GNU_OLD_TYPE according to OP. 1475 If this is a multi-dimensional array type, do this recursively. 1476 1477 OP may be 1478 - ALIAS_SET_COPY: the new set is made a copy of the old one. 1479 - ALIAS_SET_SUPERSET: the new set is made a superset of the old one. 1480 - ALIAS_SET_SUBSET: the new set is made a subset of the old one. */ 1481 1482void 1483relate_alias_sets (tree gnu_new_type, tree gnu_old_type, enum alias_set_op op) 1484{ 1485 /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case 1486 of a one-dimensional array, since the padding has the same alias set 1487 as the field type, but if it's a multi-dimensional array, we need to 1488 see the inner types. */ 1489 while (TREE_CODE (gnu_old_type) == RECORD_TYPE 1490 && (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type) 1491 || TYPE_PADDING_P (gnu_old_type))) 1492 gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type)); 1493 1494 /* Unconstrained array types are deemed incomplete and would thus be given 1495 alias set 0. Retrieve the underlying array type. */ 1496 if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE) 1497 gnu_old_type 1498 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type)))); 1499 if (TREE_CODE (gnu_new_type) == UNCONSTRAINED_ARRAY_TYPE) 1500 gnu_new_type 1501 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_new_type)))); 1502 1503 if (TREE_CODE (gnu_new_type) == ARRAY_TYPE 1504 && TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE 1505 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type))) 1506 relate_alias_sets (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type), op); 1507 1508 switch (op) 1509 { 1510 case ALIAS_SET_COPY: 1511 /* The alias set shouldn't be copied between array types with different 1512 aliasing settings because this can break the aliasing relationship 1513 between the array type and its element type. */ 1514#ifndef ENABLE_CHECKING 1515 if (flag_strict_aliasing) 1516#endif 1517 gcc_assert (!(TREE_CODE (gnu_new_type) == ARRAY_TYPE 1518 && TREE_CODE (gnu_old_type) == ARRAY_TYPE 1519 && TYPE_NONALIASED_COMPONENT (gnu_new_type) 1520 != TYPE_NONALIASED_COMPONENT (gnu_old_type))); 1521 1522 TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type); 1523 break; 1524 1525 case ALIAS_SET_SUBSET: 1526 case ALIAS_SET_SUPERSET: 1527 { 1528 alias_set_type old_set = get_alias_set (gnu_old_type); 1529 alias_set_type new_set = get_alias_set (gnu_new_type); 1530 1531 /* Do nothing if the alias sets conflict. This ensures that we 1532 never call record_alias_subset several times for the same pair 1533 or at all for alias set 0. */ 1534 if (!alias_sets_conflict_p (old_set, new_set)) 1535 { 1536 if (op == ALIAS_SET_SUBSET) 1537 record_alias_subset (old_set, new_set); 1538 else 1539 record_alias_subset (new_set, old_set); 1540 } 1541 } 1542 break; 1543 1544 default: 1545 gcc_unreachable (); 1546 } 1547 1548 record_component_aliases (gnu_new_type); 1549} 1550 1551/* Record TYPE as a builtin type for Ada. NAME is the name of the type. 1552 ARTIFICIAL_P is true if it's a type that was generated by the compiler. */ 1553 1554void 1555record_builtin_type (const char *name, tree type, bool artificial_p) 1556{ 1557 tree type_decl = build_decl (input_location, 1558 TYPE_DECL, get_identifier (name), type); 1559 DECL_ARTIFICIAL (type_decl) = artificial_p; 1560 TYPE_ARTIFICIAL (type) = artificial_p; 1561 gnat_pushdecl (type_decl, Empty); 1562 1563 if (debug_hooks->type_decl) 1564 debug_hooks->type_decl (type_decl, false); 1565} 1566 1567/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST, 1568 finish constructing the record type as a fat pointer type. */ 1569 1570void 1571finish_fat_pointer_type (tree record_type, tree field_list) 1572{ 1573 /* Make sure we can put it into a register. */ 1574 if (STRICT_ALIGNMENT) 1575 TYPE_ALIGN (record_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); 1576 1577 /* Show what it really is. */ 1578 TYPE_FAT_POINTER_P (record_type) = 1; 1579 1580 /* Do not emit debug info for it since the types of its fields may still be 1581 incomplete at this point. */ 1582 finish_record_type (record_type, field_list, 0, false); 1583 1584 /* Force type_contains_placeholder_p to return true on it. Although the 1585 PLACEHOLDER_EXPRs are referenced only indirectly, this isn't a pointer 1586 type but the representation of the unconstrained array. */ 1587 TYPE_CONTAINS_PLACEHOLDER_INTERNAL (record_type) = 2; 1588} 1589 1590/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST, 1591 finish constructing the record or union type. If REP_LEVEL is zero, this 1592 record has no representation clause and so will be entirely laid out here. 1593 If REP_LEVEL is one, this record has a representation clause and has been 1594 laid out already; only set the sizes and alignment. If REP_LEVEL is two, 1595 this record is derived from a parent record and thus inherits its layout; 1596 only make a pass on the fields to finalize them. DEBUG_INFO_P is true if 1597 we need to write debug information about this type. */ 1598 1599void 1600finish_record_type (tree record_type, tree field_list, int rep_level, 1601 bool debug_info_p) 1602{ 1603 enum tree_code code = TREE_CODE (record_type); 1604 tree name = TYPE_IDENTIFIER (record_type); 1605 tree ada_size = bitsize_zero_node; 1606 tree size = bitsize_zero_node; 1607 bool had_size = TYPE_SIZE (record_type) != 0; 1608 bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0; 1609 bool had_align = TYPE_ALIGN (record_type) != 0; 1610 tree field; 1611 1612 TYPE_FIELDS (record_type) = field_list; 1613 1614 /* Always attach the TYPE_STUB_DECL for a record type. It is required to 1615 generate debug info and have a parallel type. */ 1616 TYPE_STUB_DECL (record_type) = create_type_stub_decl (name, record_type); 1617 1618 /* Globally initialize the record first. If this is a rep'ed record, 1619 that just means some initializations; otherwise, layout the record. */ 1620 if (rep_level > 0) 1621 { 1622 TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type)); 1623 1624 if (!had_size_unit) 1625 TYPE_SIZE_UNIT (record_type) = size_zero_node; 1626 1627 if (!had_size) 1628 TYPE_SIZE (record_type) = bitsize_zero_node; 1629 1630 /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE 1631 out just like a UNION_TYPE, since the size will be fixed. */ 1632 else if (code == QUAL_UNION_TYPE) 1633 code = UNION_TYPE; 1634 } 1635 else 1636 { 1637 /* Ensure there isn't a size already set. There can be in an error 1638 case where there is a rep clause but all fields have errors and 1639 no longer have a position. */ 1640 TYPE_SIZE (record_type) = 0; 1641 1642 /* Ensure we use the traditional GCC layout for bitfields when we need 1643 to pack the record type or have a representation clause. The other 1644 possible layout (Microsoft C compiler), if available, would prevent 1645 efficient packing in almost all cases. */ 1646#ifdef TARGET_MS_BITFIELD_LAYOUT 1647 if (TARGET_MS_BITFIELD_LAYOUT && TYPE_PACKED (record_type)) 1648 decl_attributes (&record_type, 1649 tree_cons (get_identifier ("gcc_struct"), 1650 NULL_TREE, NULL_TREE), 1651 ATTR_FLAG_TYPE_IN_PLACE); 1652#endif 1653 1654 layout_type (record_type); 1655 } 1656 1657 /* At this point, the position and size of each field is known. It was 1658 either set before entry by a rep clause, or by laying out the type above. 1659 1660 We now run a pass over the fields (in reverse order for QUAL_UNION_TYPEs) 1661 to compute the Ada size; the GCC size and alignment (for rep'ed records 1662 that are not padding types); and the mode (for rep'ed records). We also 1663 clear the DECL_BIT_FIELD indication for the cases we know have not been 1664 handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */ 1665 1666 if (code == QUAL_UNION_TYPE) 1667 field_list = nreverse (field_list); 1668 1669 for (field = field_list; field; field = DECL_CHAIN (field)) 1670 { 1671 tree type = TREE_TYPE (field); 1672 tree pos = bit_position (field); 1673 tree this_size = DECL_SIZE (field); 1674 tree this_ada_size; 1675 1676 if (RECORD_OR_UNION_TYPE_P (type) 1677 && !TYPE_FAT_POINTER_P (type) 1678 && !TYPE_CONTAINS_TEMPLATE_P (type) 1679 && TYPE_ADA_SIZE (type)) 1680 this_ada_size = TYPE_ADA_SIZE (type); 1681 else 1682 this_ada_size = this_size; 1683 1684 /* Clear DECL_BIT_FIELD for the cases layout_decl does not handle. */ 1685 if (DECL_BIT_FIELD (field) 1686 && operand_equal_p (this_size, TYPE_SIZE (type), 0)) 1687 { 1688 unsigned int align = TYPE_ALIGN (type); 1689 1690 /* In the general case, type alignment is required. */ 1691 if (value_factor_p (pos, align)) 1692 { 1693 /* The enclosing record type must be sufficiently aligned. 1694 Otherwise, if no alignment was specified for it and it 1695 has been laid out already, bump its alignment to the 1696 desired one if this is compatible with its size. */ 1697 if (TYPE_ALIGN (record_type) >= align) 1698 { 1699 DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align); 1700 DECL_BIT_FIELD (field) = 0; 1701 } 1702 else if (!had_align 1703 && rep_level == 0 1704 && value_factor_p (TYPE_SIZE (record_type), align)) 1705 { 1706 TYPE_ALIGN (record_type) = align; 1707 DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align); 1708 DECL_BIT_FIELD (field) = 0; 1709 } 1710 } 1711 1712 /* In the non-strict alignment case, only byte alignment is. */ 1713 if (!STRICT_ALIGNMENT 1714 && DECL_BIT_FIELD (field) 1715 && value_factor_p (pos, BITS_PER_UNIT)) 1716 DECL_BIT_FIELD (field) = 0; 1717 } 1718 1719 /* If we still have DECL_BIT_FIELD set at this point, we know that the 1720 field is technically not addressable. Except that it can actually 1721 be addressed if it is BLKmode and happens to be properly aligned. */ 1722 if (DECL_BIT_FIELD (field) 1723 && !(DECL_MODE (field) == BLKmode 1724 && value_factor_p (pos, BITS_PER_UNIT))) 1725 DECL_NONADDRESSABLE_P (field) = 1; 1726 1727 /* A type must be as aligned as its most aligned field that is not 1728 a bit-field. But this is already enforced by layout_type. */ 1729 if (rep_level > 0 && !DECL_BIT_FIELD (field)) 1730 TYPE_ALIGN (record_type) 1731 = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field)); 1732 1733 switch (code) 1734 { 1735 case UNION_TYPE: 1736 ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size); 1737 size = size_binop (MAX_EXPR, size, this_size); 1738 break; 1739 1740 case QUAL_UNION_TYPE: 1741 ada_size 1742 = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), 1743 this_ada_size, ada_size); 1744 size = fold_build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field), 1745 this_size, size); 1746 break; 1747 1748 case RECORD_TYPE: 1749 /* Since we know here that all fields are sorted in order of 1750 increasing bit position, the size of the record is one 1751 higher than the ending bit of the last field processed 1752 unless we have a rep clause, since in that case we might 1753 have a field outside a QUAL_UNION_TYPE that has a higher ending 1754 position. So use a MAX in that case. Also, if this field is a 1755 QUAL_UNION_TYPE, we need to take into account the previous size in 1756 the case of empty variants. */ 1757 ada_size 1758 = merge_sizes (ada_size, pos, this_ada_size, 1759 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); 1760 size 1761 = merge_sizes (size, pos, this_size, 1762 TREE_CODE (type) == QUAL_UNION_TYPE, rep_level > 0); 1763 break; 1764 1765 default: 1766 gcc_unreachable (); 1767 } 1768 } 1769 1770 if (code == QUAL_UNION_TYPE) 1771 nreverse (field_list); 1772 1773 if (rep_level < 2) 1774 { 1775 /* If this is a padding record, we never want to make the size smaller 1776 than what was specified in it, if any. */ 1777 if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type)) 1778 size = TYPE_SIZE (record_type); 1779 1780 /* Now set any of the values we've just computed that apply. */ 1781 if (!TYPE_FAT_POINTER_P (record_type) 1782 && !TYPE_CONTAINS_TEMPLATE_P (record_type)) 1783 SET_TYPE_ADA_SIZE (record_type, ada_size); 1784 1785 if (rep_level > 0) 1786 { 1787 tree size_unit = had_size_unit 1788 ? TYPE_SIZE_UNIT (record_type) 1789 : convert (sizetype, 1790 size_binop (CEIL_DIV_EXPR, size, 1791 bitsize_unit_node)); 1792 unsigned int align = TYPE_ALIGN (record_type); 1793 1794 TYPE_SIZE (record_type) = variable_size (round_up (size, align)); 1795 TYPE_SIZE_UNIT (record_type) 1796 = variable_size (round_up (size_unit, align / BITS_PER_UNIT)); 1797 1798 compute_record_mode (record_type); 1799 } 1800 } 1801 1802 if (debug_info_p) 1803 rest_of_record_type_compilation (record_type); 1804} 1805 1806/* Append PARALLEL_TYPE on the chain of parallel types of TYPE. If 1807 PARRALEL_TYPE has no context and its computation is not deferred yet, also 1808 propagate TYPE's context to PARALLEL_TYPE's or defer its propagation to the 1809 moment TYPE will get a context. */ 1810 1811void 1812add_parallel_type (tree type, tree parallel_type) 1813{ 1814 tree decl = TYPE_STUB_DECL (type); 1815 1816 while (DECL_PARALLEL_TYPE (decl)) 1817 decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl)); 1818 1819 SET_DECL_PARALLEL_TYPE (decl, parallel_type); 1820 1821 /* If PARALLEL_TYPE already has a context, we are done. */ 1822 if (TYPE_CONTEXT (parallel_type) != NULL_TREE) 1823 return; 1824 1825 /* Otherwise, try to get one from TYPE's context. */ 1826 if (TYPE_CONTEXT (type) != NULL_TREE) 1827 /* TYPE already has a context, so simply propagate it to PARALLEL_TYPE. */ 1828 gnat_set_type_context (parallel_type, TYPE_CONTEXT (type)); 1829 1830 /* ... otherwise TYPE has not context yet. We know it will thanks to 1831 gnat_pushdecl, and then its context will be propagated to PARALLEL_TYPE. 1832 So we have nothing to do in this case. */ 1833} 1834 1835/* Return true if TYPE has a parallel type. */ 1836 1837static bool 1838has_parallel_type (tree type) 1839{ 1840 tree decl = TYPE_STUB_DECL (type); 1841 1842 return DECL_PARALLEL_TYPE (decl) != NULL_TREE; 1843} 1844 1845/* Wrap up compilation of RECORD_TYPE, i.e. output all the debug information 1846 associated with it. It need not be invoked directly in most cases since 1847 finish_record_type takes care of doing so, but this can be necessary if 1848 a parallel type is to be attached to the record type. */ 1849 1850void 1851rest_of_record_type_compilation (tree record_type) 1852{ 1853 bool var_size = false; 1854 tree field; 1855 1856 /* If this is a padded type, the bulk of the debug info has already been 1857 generated for the field's type. */ 1858 if (TYPE_IS_PADDING_P (record_type)) 1859 return; 1860 1861 /* If the type already has a parallel type (XVS type), then we're done. */ 1862 if (has_parallel_type (record_type)) 1863 return; 1864 1865 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field)) 1866 { 1867 /* We need to make an XVE/XVU record if any field has variable size, 1868 whether or not the record does. For example, if we have a union, 1869 it may be that all fields, rounded up to the alignment, have the 1870 same size, in which case we'll use that size. But the debug 1871 output routines (except Dwarf2) won't be able to output the fields, 1872 so we need to make the special record. */ 1873 if (TREE_CODE (DECL_SIZE (field)) != INTEGER_CST 1874 /* If a field has a non-constant qualifier, the record will have 1875 variable size too. */ 1876 || (TREE_CODE (record_type) == QUAL_UNION_TYPE 1877 && TREE_CODE (DECL_QUALIFIER (field)) != INTEGER_CST)) 1878 { 1879 var_size = true; 1880 break; 1881 } 1882 } 1883 1884 /* If this record type is of variable size, make a parallel record type that 1885 will tell the debugger how the former is laid out (see exp_dbug.ads). */ 1886 if (var_size) 1887 { 1888 tree new_record_type 1889 = make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE 1890 ? UNION_TYPE : TREE_CODE (record_type)); 1891 tree orig_name = TYPE_IDENTIFIER (record_type), new_name; 1892 tree last_pos = bitsize_zero_node; 1893 tree old_field, prev_old_field = NULL_TREE; 1894 1895 new_name 1896 = concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE 1897 ? "XVU" : "XVE"); 1898 TYPE_NAME (new_record_type) = new_name; 1899 TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT; 1900 TYPE_STUB_DECL (new_record_type) 1901 = create_type_stub_decl (new_name, new_record_type); 1902 DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type)) 1903 = DECL_IGNORED_P (TYPE_STUB_DECL (record_type)); 1904 TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type)); 1905 TYPE_SIZE_UNIT (new_record_type) 1906 = size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT); 1907 1908 /* Now scan all the fields, replacing each field with a new field 1909 corresponding to the new encoding. */ 1910 for (old_field = TYPE_FIELDS (record_type); old_field; 1911 old_field = DECL_CHAIN (old_field)) 1912 { 1913 tree field_type = TREE_TYPE (old_field); 1914 tree field_name = DECL_NAME (old_field); 1915 tree curpos = bit_position (old_field); 1916 tree pos, new_field; 1917 bool var = false; 1918 unsigned int align = 0; 1919 1920 /* We're going to do some pattern matching below so remove as many 1921 conversions as possible. */ 1922 curpos = remove_conversions (curpos, true); 1923 1924 /* See how the position was modified from the last position. 1925 1926 There are two basic cases we support: a value was added 1927 to the last position or the last position was rounded to 1928 a boundary and they something was added. Check for the 1929 first case first. If not, see if there is any evidence 1930 of rounding. If so, round the last position and retry. 1931 1932 If this is a union, the position can be taken as zero. */ 1933 if (TREE_CODE (new_record_type) == UNION_TYPE) 1934 pos = bitsize_zero_node; 1935 else 1936 pos = compute_related_constant (curpos, last_pos); 1937 1938 if (!pos 1939 && TREE_CODE (curpos) == MULT_EXPR 1940 && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1))) 1941 { 1942 tree offset = TREE_OPERAND (curpos, 0); 1943 align = tree_to_uhwi (TREE_OPERAND (curpos, 1)); 1944 align = scale_by_factor_of (offset, align); 1945 last_pos = round_up (last_pos, align); 1946 pos = compute_related_constant (curpos, last_pos); 1947 } 1948 else if (!pos 1949 && TREE_CODE (curpos) == PLUS_EXPR 1950 && tree_fits_uhwi_p (TREE_OPERAND (curpos, 1)) 1951 && TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR 1952 && tree_fits_uhwi_p 1953 (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1))) 1954 { 1955 tree offset = TREE_OPERAND (TREE_OPERAND (curpos, 0), 0); 1956 unsigned HOST_WIDE_INT addend 1957 = tree_to_uhwi (TREE_OPERAND (curpos, 1)); 1958 align 1959 = tree_to_uhwi (TREE_OPERAND (TREE_OPERAND (curpos, 0), 1)); 1960 align = scale_by_factor_of (offset, align); 1961 align = MIN (align, addend & -addend); 1962 last_pos = round_up (last_pos, align); 1963 pos = compute_related_constant (curpos, last_pos); 1964 } 1965 else if (potential_alignment_gap (prev_old_field, old_field, pos)) 1966 { 1967 align = TYPE_ALIGN (field_type); 1968 last_pos = round_up (last_pos, align); 1969 pos = compute_related_constant (curpos, last_pos); 1970 } 1971 1972 /* If we can't compute a position, set it to zero. 1973 1974 ??? We really should abort here, but it's too much work 1975 to get this correct for all cases. */ 1976 if (!pos) 1977 pos = bitsize_zero_node; 1978 1979 /* See if this type is variable-sized and make a pointer type 1980 and indicate the indirection if so. Beware that the debug 1981 back-end may adjust the position computed above according 1982 to the alignment of the field type, i.e. the pointer type 1983 in this case, if we don't preventively counter that. */ 1984 if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST) 1985 { 1986 field_type = build_pointer_type (field_type); 1987 if (align != 0 && TYPE_ALIGN (field_type) > align) 1988 { 1989 field_type = copy_node (field_type); 1990 TYPE_ALIGN (field_type) = align; 1991 } 1992 var = true; 1993 } 1994 1995 /* Make a new field name, if necessary. */ 1996 if (var || align != 0) 1997 { 1998 char suffix[16]; 1999 2000 if (align != 0) 2001 sprintf (suffix, "XV%c%u", var ? 'L' : 'A', 2002 align / BITS_PER_UNIT); 2003 else 2004 strcpy (suffix, "XVL"); 2005 2006 field_name = concat_name (field_name, suffix); 2007 } 2008 2009 new_field 2010 = create_field_decl (field_name, field_type, new_record_type, 2011 DECL_SIZE (old_field), pos, 0, 0); 2012 DECL_CHAIN (new_field) = TYPE_FIELDS (new_record_type); 2013 TYPE_FIELDS (new_record_type) = new_field; 2014 2015 /* If old_field is a QUAL_UNION_TYPE, take its size as being 2016 zero. The only time it's not the last field of the record 2017 is when there are other components at fixed positions after 2018 it (meaning there was a rep clause for every field) and we 2019 want to be able to encode them. */ 2020 last_pos = size_binop (PLUS_EXPR, bit_position (old_field), 2021 (TREE_CODE (TREE_TYPE (old_field)) 2022 == QUAL_UNION_TYPE) 2023 ? bitsize_zero_node 2024 : DECL_SIZE (old_field)); 2025 prev_old_field = old_field; 2026 } 2027 2028 TYPE_FIELDS (new_record_type) = nreverse (TYPE_FIELDS (new_record_type)); 2029 2030 add_parallel_type (record_type, new_record_type); 2031 } 2032} 2033 2034/* Utility function of above to merge LAST_SIZE, the previous size of a record 2035 with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this 2036 represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and 2037 replace a value of zero with the old size. If HAS_REP is true, we take the 2038 MAX of the end position of this field with LAST_SIZE. In all other cases, 2039 we use FIRST_BIT plus SIZE. Return an expression for the size. */ 2040 2041static tree 2042merge_sizes (tree last_size, tree first_bit, tree size, bool special, 2043 bool has_rep) 2044{ 2045 tree type = TREE_TYPE (last_size); 2046 tree new_size; 2047 2048 if (!special || TREE_CODE (size) != COND_EXPR) 2049 { 2050 new_size = size_binop (PLUS_EXPR, first_bit, size); 2051 if (has_rep) 2052 new_size = size_binop (MAX_EXPR, last_size, new_size); 2053 } 2054 2055 else 2056 new_size = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0), 2057 integer_zerop (TREE_OPERAND (size, 1)) 2058 ? last_size : merge_sizes (last_size, first_bit, 2059 TREE_OPERAND (size, 1), 2060 1, has_rep), 2061 integer_zerop (TREE_OPERAND (size, 2)) 2062 ? last_size : merge_sizes (last_size, first_bit, 2063 TREE_OPERAND (size, 2), 2064 1, has_rep)); 2065 2066 /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially 2067 when fed through substitute_in_expr) into thinking that a constant 2068 size is not constant. */ 2069 while (TREE_CODE (new_size) == NON_LVALUE_EXPR) 2070 new_size = TREE_OPERAND (new_size, 0); 2071 2072 return new_size; 2073} 2074 2075/* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are 2076 related by the addition of a constant. Return that constant if so. */ 2077 2078static tree 2079compute_related_constant (tree op0, tree op1) 2080{ 2081 tree op0_var, op1_var; 2082 tree op0_con = split_plus (op0, &op0_var); 2083 tree op1_con = split_plus (op1, &op1_var); 2084 tree result = size_binop (MINUS_EXPR, op0_con, op1_con); 2085 2086 if (operand_equal_p (op0_var, op1_var, 0)) 2087 return result; 2088 else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0)) 2089 return result; 2090 else 2091 return 0; 2092} 2093 2094/* Utility function of above to split a tree OP which may be a sum, into a 2095 constant part, which is returned, and a variable part, which is stored 2096 in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of 2097 bitsizetype. */ 2098 2099static tree 2100split_plus (tree in, tree *pvar) 2101{ 2102 /* Strip conversions in order to ease the tree traversal and maximize the 2103 potential for constant or plus/minus discovery. We need to be careful 2104 to always return and set *pvar to bitsizetype trees, but it's worth 2105 the effort. */ 2106 in = remove_conversions (in, false); 2107 2108 *pvar = convert (bitsizetype, in); 2109 2110 if (TREE_CODE (in) == INTEGER_CST) 2111 { 2112 *pvar = bitsize_zero_node; 2113 return convert (bitsizetype, in); 2114 } 2115 else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR) 2116 { 2117 tree lhs_var, rhs_var; 2118 tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var); 2119 tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var); 2120 2121 if (lhs_var == TREE_OPERAND (in, 0) 2122 && rhs_var == TREE_OPERAND (in, 1)) 2123 return bitsize_zero_node; 2124 2125 *pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var); 2126 return size_binop (TREE_CODE (in), lhs_con, rhs_con); 2127 } 2128 else 2129 return bitsize_zero_node; 2130} 2131 2132/* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the 2133 subprogram. If it is VOID_TYPE, then we are dealing with a procedure, 2134 otherwise we are dealing with a function. PARAM_DECL_LIST is a list of 2135 PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the 2136 copy-in/copy-out list to be stored into the TYPE_CICO_LIST field. 2137 RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained 2138 object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct 2139 reference. RETURN_BY_INVISI_REF_P is true if the function returns by 2140 invisible reference. */ 2141 2142tree 2143create_subprog_type (tree return_type, tree param_decl_list, tree cico_list, 2144 bool return_unconstrained_p, bool return_by_direct_ref_p, 2145 bool return_by_invisi_ref_p) 2146{ 2147 /* A list of the data type nodes of the subprogram formal parameters. 2148 This list is generated by traversing the input list of PARM_DECL 2149 nodes. */ 2150 vec<tree, va_gc> *param_type_list = NULL; 2151 tree t, type; 2152 2153 for (t = param_decl_list; t; t = DECL_CHAIN (t)) 2154 vec_safe_push (param_type_list, TREE_TYPE (t)); 2155 2156 type = build_function_type_vec (return_type, param_type_list); 2157 2158 /* TYPE may have been shared since GCC hashes types. If it has a different 2159 CICO_LIST, make a copy. Likewise for the various flags. */ 2160 if (!fntype_same_flags_p (type, cico_list, return_unconstrained_p, 2161 return_by_direct_ref_p, return_by_invisi_ref_p)) 2162 { 2163 type = copy_type (type); 2164 TYPE_CI_CO_LIST (type) = cico_list; 2165 TYPE_RETURN_UNCONSTRAINED_P (type) = return_unconstrained_p; 2166 TYPE_RETURN_BY_DIRECT_REF_P (type) = return_by_direct_ref_p; 2167 TREE_ADDRESSABLE (type) = return_by_invisi_ref_p; 2168 } 2169 2170 return type; 2171} 2172 2173/* Return a copy of TYPE but safe to modify in any way. */ 2174 2175tree 2176copy_type (tree type) 2177{ 2178 tree new_type = copy_node (type); 2179 2180 /* Unshare the language-specific data. */ 2181 if (TYPE_LANG_SPECIFIC (type)) 2182 { 2183 TYPE_LANG_SPECIFIC (new_type) = NULL; 2184 SET_TYPE_LANG_SPECIFIC (new_type, GET_TYPE_LANG_SPECIFIC (type)); 2185 } 2186 2187 /* And the contents of the language-specific slot if needed. */ 2188 if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE) 2189 && TYPE_RM_VALUES (type)) 2190 { 2191 TYPE_RM_VALUES (new_type) = NULL_TREE; 2192 SET_TYPE_RM_SIZE (new_type, TYPE_RM_SIZE (type)); 2193 SET_TYPE_RM_MIN_VALUE (new_type, TYPE_RM_MIN_VALUE (type)); 2194 SET_TYPE_RM_MAX_VALUE (new_type, TYPE_RM_MAX_VALUE (type)); 2195 } 2196 2197 /* copy_node clears this field instead of copying it, because it is 2198 aliased with TREE_CHAIN. */ 2199 TYPE_STUB_DECL (new_type) = TYPE_STUB_DECL (type); 2200 2201 TYPE_POINTER_TO (new_type) = 0; 2202 TYPE_REFERENCE_TO (new_type) = 0; 2203 TYPE_MAIN_VARIANT (new_type) = new_type; 2204 TYPE_NEXT_VARIANT (new_type) = 0; 2205 2206 return new_type; 2207} 2208 2209/* Return a subtype of sizetype with range MIN to MAX and whose 2210 TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position 2211 of the associated TYPE_DECL. */ 2212 2213tree 2214create_index_type (tree min, tree max, tree index, Node_Id gnat_node) 2215{ 2216 /* First build a type for the desired range. */ 2217 tree type = build_nonshared_range_type (sizetype, min, max); 2218 2219 /* Then set the index type. */ 2220 SET_TYPE_INDEX_TYPE (type, index); 2221 create_type_decl (NULL_TREE, type, true, false, gnat_node); 2222 2223 return type; 2224} 2225 2226/* Return a subtype of TYPE with range MIN to MAX. If TYPE is NULL, 2227 sizetype is used. */ 2228 2229tree 2230create_range_type (tree type, tree min, tree max) 2231{ 2232 tree range_type; 2233 2234 if (type == NULL_TREE) 2235 type = sizetype; 2236 2237 /* First build a type with the base range. */ 2238 range_type = build_nonshared_range_type (type, TYPE_MIN_VALUE (type), 2239 TYPE_MAX_VALUE (type)); 2240 2241 /* Then set the actual range. */ 2242 SET_TYPE_RM_MIN_VALUE (range_type, min); 2243 SET_TYPE_RM_MAX_VALUE (range_type, max); 2244 2245 return range_type; 2246} 2247 2248/* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of a type. 2249 TYPE_NAME gives the name of the type and TYPE is a ..._TYPE node giving 2250 its data type. */ 2251 2252tree 2253create_type_stub_decl (tree type_name, tree type) 2254{ 2255 /* Using a named TYPE_DECL ensures that a type name marker is emitted in 2256 STABS while setting DECL_ARTIFICIAL ensures that no DW_TAG_typedef is 2257 emitted in DWARF. */ 2258 tree type_decl = build_decl (input_location, TYPE_DECL, type_name, type); 2259 DECL_ARTIFICIAL (type_decl) = 1; 2260 TYPE_ARTIFICIAL (type) = 1; 2261 return type_decl; 2262} 2263 2264/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type and TYPE 2265 is a ..._TYPE node giving its data type. ARTIFICIAL_P is true if this 2266 is a declaration that was generated by the compiler. DEBUG_INFO_P is 2267 true if we need to write debug information about this type. GNAT_NODE 2268 is used for the position of the decl. */ 2269 2270tree 2271create_type_decl (tree type_name, tree type, bool artificial_p, 2272 bool debug_info_p, Node_Id gnat_node) 2273{ 2274 enum tree_code code = TREE_CODE (type); 2275 bool named = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL; 2276 tree type_decl; 2277 2278 /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */ 2279 gcc_assert (!TYPE_IS_DUMMY_P (type)); 2280 2281 /* If the type hasn't been named yet, we're naming it; preserve an existing 2282 TYPE_STUB_DECL that has been attached to it for some purpose. */ 2283 if (!named && TYPE_STUB_DECL (type)) 2284 { 2285 type_decl = TYPE_STUB_DECL (type); 2286 DECL_NAME (type_decl) = type_name; 2287 } 2288 else 2289 type_decl = build_decl (input_location, TYPE_DECL, type_name, type); 2290 2291 DECL_ARTIFICIAL (type_decl) = artificial_p; 2292 TYPE_ARTIFICIAL (type) = artificial_p; 2293 2294 /* Add this decl to the current binding level. */ 2295 gnat_pushdecl (type_decl, gnat_node); 2296 2297 /* If we're naming the type, equate the TYPE_STUB_DECL to the name. This 2298 causes the name to be also viewed as a "tag" by the debug back-end, with 2299 the advantage that no DW_TAG_typedef is emitted for artificial "tagged" 2300 types in DWARF. 2301 2302 Note that if "type" is used as a DECL_ORIGINAL_TYPE, it may be referenced 2303 from multiple contexts, and "type_decl" references a copy of it: in such a 2304 case, do not mess TYPE_STUB_DECL: we do not want to re-use the TYPE_DECL 2305 with the mechanism above. */ 2306 if (!named && type != DECL_ORIGINAL_TYPE (type_decl)) 2307 TYPE_STUB_DECL (type) = type_decl; 2308 2309 /* Do not generate debug info for UNCONSTRAINED_ARRAY_TYPE that the 2310 back-end doesn't support, and for others if we don't need to. */ 2311 if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p) 2312 DECL_IGNORED_P (type_decl) = 1; 2313 2314 return type_decl; 2315} 2316 2317/* Return a VAR_DECL or CONST_DECL node. 2318 2319 VAR_NAME gives the name of the variable. ASM_NAME is its assembler name 2320 (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is 2321 the GCC tree for an optional initial expression; NULL_TREE if none. 2322 2323 CONST_FLAG is true if this variable is constant, in which case we might 2324 return a CONST_DECL node unless CONST_DECL_ALLOWED_P is false. 2325 2326 PUBLIC_FLAG is true if this is for a reference to a public entity or for a 2327 definition to be made visible outside of the current compilation unit, for 2328 instance variable definitions in a package specification. 2329 2330 EXTERN_FLAG is true when processing an external variable declaration (as 2331 opposed to a definition: no storage is to be allocated for the variable). 2332 2333 STATIC_FLAG is only relevant when not at top level. In that case 2334 it indicates whether to always allocate storage to the variable. 2335 2336 GNAT_NODE is used for the position of the decl. */ 2337 2338tree 2339create_var_decl_1 (tree var_name, tree asm_name, tree type, tree var_init, 2340 bool const_flag, bool public_flag, bool extern_flag, 2341 bool static_flag, bool const_decl_allowed_p, 2342 struct attrib *attr_list, Node_Id gnat_node) 2343{ 2344 /* Whether the object has static storage duration, either explicitly or by 2345 virtue of being declared at the global level. */ 2346 const bool static_storage = static_flag || global_bindings_p (); 2347 2348 /* Whether the initializer is constant: for an external object or an object 2349 with static storage duration, we check that the initializer is a valid 2350 constant expression for initializing a static variable; otherwise, we 2351 only check that it is constant. */ 2352 const bool init_const 2353 = (var_init 2354 && gnat_types_compatible_p (type, TREE_TYPE (var_init)) 2355 && (extern_flag || static_storage 2356 ? initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) 2357 != NULL_TREE 2358 : TREE_CONSTANT (var_init))); 2359 2360 /* Whether we will make TREE_CONSTANT the DECL we produce here, in which 2361 case the initializer may be used in lieu of the DECL node (as done in 2362 Identifier_to_gnu). This is useful to prevent the need of elaboration 2363 code when an identifier for which such a DECL is made is in turn used 2364 as an initializer. We used to rely on CONST_DECL vs VAR_DECL for this, 2365 but extra constraints apply to this choice (see below) and they are not 2366 relevant to the distinction we wish to make. */ 2367 const bool constant_p = const_flag && init_const; 2368 2369 /* The actual DECL node. CONST_DECL was initially intended for enumerals 2370 and may be used for scalars in general but not for aggregates. */ 2371 tree var_decl 2372 = build_decl (input_location, 2373 (constant_p && const_decl_allowed_p 2374 && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL, 2375 var_name, type); 2376 2377 /* If this is external, throw away any initializations (they will be done 2378 elsewhere) unless this is a constant for which we would like to remain 2379 able to get the initializer. If we are defining a global here, leave a 2380 constant initialization and save any variable elaborations for the 2381 elaboration routine. If we are just annotating types, throw away the 2382 initialization if it isn't a constant. */ 2383 if ((extern_flag && !constant_p) 2384 || (type_annotate_only && var_init && !TREE_CONSTANT (var_init))) 2385 var_init = NULL_TREE; 2386 2387 /* At the global level, a non-constant initializer generates elaboration 2388 statements. Check that such statements are allowed, that is to say, 2389 not violating a No_Elaboration_Code restriction. */ 2390 if (var_init && !init_const && global_bindings_p ()) 2391 Check_Elaboration_Code_Allowed (gnat_node); 2392 2393 DECL_INITIAL (var_decl) = var_init; 2394 TREE_READONLY (var_decl) = const_flag; 2395 DECL_EXTERNAL (var_decl) = extern_flag; 2396 TREE_CONSTANT (var_decl) = constant_p; 2397 2398 /* We need to allocate static storage for an object with static storage 2399 duration if it isn't external. */ 2400 TREE_STATIC (var_decl) = !extern_flag && static_storage; 2401 2402 /* The object is public if it is external or if it is declared public 2403 and has static storage duration. */ 2404 TREE_PUBLIC (var_decl) = extern_flag || (public_flag && static_storage); 2405 2406 /* Ada doesn't feature Fortran-like COMMON variables so we shouldn't 2407 try to fiddle with DECL_COMMON. However, on platforms that don't 2408 support global BSS sections, uninitialized global variables would 2409 go in DATA instead, thus increasing the size of the executable. */ 2410 if (!flag_no_common 2411 && TREE_CODE (var_decl) == VAR_DECL 2412 && TREE_PUBLIC (var_decl) 2413 && !have_global_bss_p ()) 2414 DECL_COMMON (var_decl) = 1; 2415 2416 /* For an external constant whose initializer is not absolute, do not emit 2417 debug info. In DWARF this would mean a global relocation in a read-only 2418 section which runs afoul of the PE-COFF run-time relocation mechanism. */ 2419 if (extern_flag 2420 && constant_p 2421 && var_init 2422 && initializer_constant_valid_p (var_init, TREE_TYPE (var_init)) 2423 != null_pointer_node) 2424 DECL_IGNORED_P (var_decl) = 1; 2425 2426 if (TYPE_VOLATILE (type)) 2427 TREE_SIDE_EFFECTS (var_decl) = TREE_THIS_VOLATILE (var_decl) = 1; 2428 2429 if (TREE_SIDE_EFFECTS (var_decl)) 2430 TREE_ADDRESSABLE (var_decl) = 1; 2431 2432 /* ??? Some attributes cannot be applied to CONST_DECLs. */ 2433 if (TREE_CODE (var_decl) == VAR_DECL) 2434 process_attributes (&var_decl, &attr_list, true, gnat_node); 2435 2436 /* Add this decl to the current binding level. */ 2437 gnat_pushdecl (var_decl, gnat_node); 2438 2439 if (TREE_CODE (var_decl) == VAR_DECL) 2440 { 2441 if (asm_name) 2442 SET_DECL_ASSEMBLER_NAME (var_decl, asm_name); 2443 2444 if (global_bindings_p ()) 2445 rest_of_decl_compilation (var_decl, true, 0); 2446 } 2447 2448 return var_decl; 2449} 2450 2451/* Return true if TYPE, an aggregate type, contains (or is) an array. */ 2452 2453static bool 2454aggregate_type_contains_array_p (tree type) 2455{ 2456 switch (TREE_CODE (type)) 2457 { 2458 case RECORD_TYPE: 2459 case UNION_TYPE: 2460 case QUAL_UNION_TYPE: 2461 { 2462 tree field; 2463 for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) 2464 if (AGGREGATE_TYPE_P (TREE_TYPE (field)) 2465 && aggregate_type_contains_array_p (TREE_TYPE (field))) 2466 return true; 2467 return false; 2468 } 2469 2470 case ARRAY_TYPE: 2471 return true; 2472 2473 default: 2474 gcc_unreachable (); 2475 } 2476} 2477 2478/* Return a FIELD_DECL node. FIELD_NAME is the field's name, FIELD_TYPE is 2479 its type and RECORD_TYPE is the type of the enclosing record. If SIZE is 2480 nonzero, it is the specified size of the field. If POS is nonzero, it is 2481 the bit position. PACKED is 1 if the enclosing record is packed, -1 if it 2482 has Component_Alignment of Storage_Unit. If ADDRESSABLE is nonzero, it 2483 means we are allowed to take the address of the field; if it is negative, 2484 we should not make a bitfield, which is used by make_aligning_type. */ 2485 2486tree 2487create_field_decl (tree field_name, tree field_type, tree record_type, 2488 tree size, tree pos, int packed, int addressable) 2489{ 2490 tree field_decl = build_decl (input_location, 2491 FIELD_DECL, field_name, field_type); 2492 2493 DECL_CONTEXT (field_decl) = record_type; 2494 TREE_READONLY (field_decl) = TYPE_READONLY (field_type); 2495 2496 /* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a 2497 byte boundary since GCC cannot handle less-aligned BLKmode bitfields. 2498 Likewise for an aggregate without specified position that contains an 2499 array, because in this case slices of variable length of this array 2500 must be handled by GCC and variable-sized objects need to be aligned 2501 to at least a byte boundary. */ 2502 if (packed && (TYPE_MODE (field_type) == BLKmode 2503 || (!pos 2504 && AGGREGATE_TYPE_P (field_type) 2505 && aggregate_type_contains_array_p (field_type)))) 2506 DECL_ALIGN (field_decl) = BITS_PER_UNIT; 2507 2508 /* If a size is specified, use it. Otherwise, if the record type is packed 2509 compute a size to use, which may differ from the object's natural size. 2510 We always set a size in this case to trigger the checks for bitfield 2511 creation below, which is typically required when no position has been 2512 specified. */ 2513 if (size) 2514 size = convert (bitsizetype, size); 2515 else if (packed == 1) 2516 { 2517 size = rm_size (field_type); 2518 if (TYPE_MODE (field_type) == BLKmode) 2519 size = round_up (size, BITS_PER_UNIT); 2520 } 2521 2522 /* If we may, according to ADDRESSABLE, make a bitfield if a size is 2523 specified for two reasons: first if the size differs from the natural 2524 size. Second, if the alignment is insufficient. There are a number of 2525 ways the latter can be true. 2526 2527 We never make a bitfield if the type of the field has a nonconstant size, 2528 because no such entity requiring bitfield operations should reach here. 2529 2530 We do *preventively* make a bitfield when there might be the need for it 2531 but we don't have all the necessary information to decide, as is the case 2532 of a field with no specified position in a packed record. 2533 2534 We also don't look at STRICT_ALIGNMENT here, and rely on later processing 2535 in layout_decl or finish_record_type to clear the bit_field indication if 2536 it is in fact not needed. */ 2537 if (addressable >= 0 2538 && size 2539 && TREE_CODE (size) == INTEGER_CST 2540 && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST 2541 && (!tree_int_cst_equal (size, TYPE_SIZE (field_type)) 2542 || (pos && !value_factor_p (pos, TYPE_ALIGN (field_type))) 2543 || packed 2544 || (TYPE_ALIGN (record_type) != 0 2545 && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type)))) 2546 { 2547 DECL_BIT_FIELD (field_decl) = 1; 2548 DECL_SIZE (field_decl) = size; 2549 if (!packed && !pos) 2550 { 2551 if (TYPE_ALIGN (record_type) != 0 2552 && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type)) 2553 DECL_ALIGN (field_decl) = TYPE_ALIGN (record_type); 2554 else 2555 DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type); 2556 } 2557 } 2558 2559 DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed; 2560 2561 /* Bump the alignment if need be, either for bitfield/packing purposes or 2562 to satisfy the type requirements if no such consideration applies. When 2563 we get the alignment from the type, indicate if this is from an explicit 2564 user request, which prevents stor-layout from lowering it later on. */ 2565 { 2566 unsigned int bit_align 2567 = (DECL_BIT_FIELD (field_decl) ? 1 2568 : packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0); 2569 2570 if (bit_align > DECL_ALIGN (field_decl)) 2571 DECL_ALIGN (field_decl) = bit_align; 2572 else if (!bit_align && TYPE_ALIGN (field_type) > DECL_ALIGN (field_decl)) 2573 { 2574 DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type); 2575 DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (field_type); 2576 } 2577 } 2578 2579 if (pos) 2580 { 2581 /* We need to pass in the alignment the DECL is known to have. 2582 This is the lowest-order bit set in POS, but no more than 2583 the alignment of the record, if one is specified. Note 2584 that an alignment of 0 is taken as infinite. */ 2585 unsigned int known_align; 2586 2587 if (tree_fits_uhwi_p (pos)) 2588 known_align = tree_to_uhwi (pos) & - tree_to_uhwi (pos); 2589 else 2590 known_align = BITS_PER_UNIT; 2591 2592 if (TYPE_ALIGN (record_type) 2593 && (known_align == 0 || known_align > TYPE_ALIGN (record_type))) 2594 known_align = TYPE_ALIGN (record_type); 2595 2596 layout_decl (field_decl, known_align); 2597 SET_DECL_OFFSET_ALIGN (field_decl, 2598 tree_fits_uhwi_p (pos) ? BIGGEST_ALIGNMENT 2599 : BITS_PER_UNIT); 2600 pos_from_bit (&DECL_FIELD_OFFSET (field_decl), 2601 &DECL_FIELD_BIT_OFFSET (field_decl), 2602 DECL_OFFSET_ALIGN (field_decl), pos); 2603 } 2604 2605 /* In addition to what our caller says, claim the field is addressable if we 2606 know that its type is not suitable. 2607 2608 The field may also be "technically" nonaddressable, meaning that even if 2609 we attempt to take the field's address we will actually get the address 2610 of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD 2611 value we have at this point is not accurate enough, so we don't account 2612 for this here and let finish_record_type decide. */ 2613 if (!addressable && !type_for_nonaliased_component_p (field_type)) 2614 addressable = 1; 2615 2616 DECL_NONADDRESSABLE_P (field_decl) = !addressable; 2617 2618 return field_decl; 2619} 2620 2621/* Return a PARM_DECL node. PARAM_NAME is the name of the parameter and 2622 PARAM_TYPE is its type. READONLY is true if the parameter is readonly 2623 (either an In parameter or an address of a pass-by-ref parameter). */ 2624 2625tree 2626create_param_decl (tree param_name, tree param_type, bool readonly) 2627{ 2628 tree param_decl = build_decl (input_location, 2629 PARM_DECL, param_name, param_type); 2630 2631 /* Honor TARGET_PROMOTE_PROTOTYPES like the C compiler, as not doing so 2632 can lead to various ABI violations. */ 2633 if (targetm.calls.promote_prototypes (NULL_TREE) 2634 && INTEGRAL_TYPE_P (param_type) 2635 && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node)) 2636 { 2637 /* We have to be careful about biased types here. Make a subtype 2638 of integer_type_node with the proper biasing. */ 2639 if (TREE_CODE (param_type) == INTEGER_TYPE 2640 && TYPE_BIASED_REPRESENTATION_P (param_type)) 2641 { 2642 tree subtype 2643 = make_unsigned_type (TYPE_PRECISION (integer_type_node)); 2644 TREE_TYPE (subtype) = integer_type_node; 2645 TYPE_BIASED_REPRESENTATION_P (subtype) = 1; 2646 SET_TYPE_RM_MIN_VALUE (subtype, TYPE_MIN_VALUE (param_type)); 2647 SET_TYPE_RM_MAX_VALUE (subtype, TYPE_MAX_VALUE (param_type)); 2648 param_type = subtype; 2649 } 2650 else 2651 param_type = integer_type_node; 2652 } 2653 2654 DECL_ARG_TYPE (param_decl) = param_type; 2655 TREE_READONLY (param_decl) = readonly; 2656 return param_decl; 2657} 2658 2659/* Process the attributes in ATTR_LIST for NODE, which is either a DECL or 2660 a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be 2661 changed. GNAT_NODE is used for the position of error messages. */ 2662 2663void 2664process_attributes (tree *node, struct attrib **attr_list, bool in_place, 2665 Node_Id gnat_node) 2666{ 2667 struct attrib *attr; 2668 2669 for (attr = *attr_list; attr; attr = attr->next) 2670 switch (attr->type) 2671 { 2672 case ATTR_MACHINE_ATTRIBUTE: 2673 Sloc_to_locus (Sloc (gnat_node), &input_location); 2674 decl_attributes (node, tree_cons (attr->name, attr->args, NULL_TREE), 2675 in_place ? ATTR_FLAG_TYPE_IN_PLACE : 0); 2676 break; 2677 2678 case ATTR_LINK_ALIAS: 2679 if (!DECL_EXTERNAL (*node)) 2680 { 2681 TREE_STATIC (*node) = 1; 2682 assemble_alias (*node, attr->name); 2683 } 2684 break; 2685 2686 case ATTR_WEAK_EXTERNAL: 2687 if (SUPPORTS_WEAK) 2688 declare_weak (*node); 2689 else 2690 post_error ("?weak declarations not supported on this target", 2691 attr->error_point); 2692 break; 2693 2694 case ATTR_LINK_SECTION: 2695 if (targetm_common.have_named_sections) 2696 { 2697 set_decl_section_name (*node, IDENTIFIER_POINTER (attr->name)); 2698 DECL_COMMON (*node) = 0; 2699 } 2700 else 2701 post_error ("?section attributes are not supported for this target", 2702 attr->error_point); 2703 break; 2704 2705 case ATTR_LINK_CONSTRUCTOR: 2706 DECL_STATIC_CONSTRUCTOR (*node) = 1; 2707 TREE_USED (*node) = 1; 2708 break; 2709 2710 case ATTR_LINK_DESTRUCTOR: 2711 DECL_STATIC_DESTRUCTOR (*node) = 1; 2712 TREE_USED (*node) = 1; 2713 break; 2714 2715 case ATTR_THREAD_LOCAL_STORAGE: 2716 set_decl_tls_model (*node, decl_default_tls_model (*node)); 2717 DECL_COMMON (*node) = 0; 2718 break; 2719 } 2720 2721 *attr_list = NULL; 2722} 2723 2724/* Record DECL as a global renaming pointer. */ 2725 2726void 2727record_global_renaming_pointer (tree decl) 2728{ 2729 gcc_assert (!DECL_LOOP_PARM_P (decl) && DECL_RENAMED_OBJECT (decl)); 2730 vec_safe_push (global_renaming_pointers, decl); 2731} 2732 2733/* Invalidate the global renaming pointers that are not constant, lest their 2734 renamed object contains SAVE_EXPRs tied to an elaboration routine. Note 2735 that we should not blindly invalidate everything here because of the need 2736 to propagate constant values through renaming. */ 2737 2738void 2739invalidate_global_renaming_pointers (void) 2740{ 2741 unsigned int i; 2742 tree iter; 2743 2744 if (global_renaming_pointers == NULL) 2745 return; 2746 2747 FOR_EACH_VEC_ELT (*global_renaming_pointers, i, iter) 2748 if (!TREE_CONSTANT (DECL_RENAMED_OBJECT (iter))) 2749 SET_DECL_RENAMED_OBJECT (iter, NULL_TREE); 2750 2751 vec_free (global_renaming_pointers); 2752} 2753 2754/* Return true if VALUE is a known to be a multiple of FACTOR, which must be 2755 a power of 2. */ 2756 2757bool 2758value_factor_p (tree value, HOST_WIDE_INT factor) 2759{ 2760 if (tree_fits_uhwi_p (value)) 2761 return tree_to_uhwi (value) % factor == 0; 2762 2763 if (TREE_CODE (value) == MULT_EXPR) 2764 return (value_factor_p (TREE_OPERAND (value, 0), factor) 2765 || value_factor_p (TREE_OPERAND (value, 1), factor)); 2766 2767 return false; 2768} 2769 2770/* Return whether GNAT_NODE is a defining identifier for a renaming that comes 2771 from the parameter association for the instantiation of a generic. We do 2772 not want to emit source location for them: the code generated for their 2773 initialization is likely to disturb debugging. */ 2774 2775bool 2776renaming_from_generic_instantiation_p (Node_Id gnat_node) 2777{ 2778 if (Nkind (gnat_node) != N_Defining_Identifier 2779 || !IN (Ekind (gnat_node), Object_Kind) 2780 || Comes_From_Source (gnat_node) 2781 || !Present (Renamed_Object (gnat_node))) 2782 return false; 2783 2784 /* Get the object declaration of the renamed object, if any and if the 2785 renamed object is a mere identifier. */ 2786 gnat_node = Renamed_Object (gnat_node); 2787 if (Nkind (gnat_node) != N_Identifier) 2788 return false; 2789 2790 gnat_node = Entity (gnat_node); 2791 if (!Present (Parent (gnat_node))) 2792 return false; 2793 2794 gnat_node = Parent (gnat_node); 2795 return 2796 (Present (gnat_node) 2797 && Nkind (gnat_node) == N_Object_Declaration 2798 && Present (Corresponding_Generic_Association (gnat_node))); 2799} 2800 2801/* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to 2802 feed it with the elaboration of GNAT_SCOPE. */ 2803 2804static struct deferred_decl_context_node * 2805add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global) 2806{ 2807 struct deferred_decl_context_node *new_node; 2808 2809 new_node 2810 = (struct deferred_decl_context_node * ) xmalloc (sizeof (*new_node)); 2811 new_node->decl = decl; 2812 new_node->gnat_scope = gnat_scope; 2813 new_node->force_global = force_global; 2814 new_node->types.create (1); 2815 new_node->next = deferred_decl_context_queue; 2816 deferred_decl_context_queue = new_node; 2817 return new_node; 2818} 2819 2820/* Defer the initialization of TYPE's TYPE_CONTEXT attribute, scheduling to 2821 feed it with the DECL_CONTEXT computed as part of N as soon as it is 2822 computed. */ 2823 2824static void 2825add_deferred_type_context (struct deferred_decl_context_node *n, tree type) 2826{ 2827 n->types.safe_push (type); 2828} 2829 2830/* Get the GENERIC node corresponding to GNAT_SCOPE, if available. Return 2831 NULL_TREE if it is not available. */ 2832 2833static tree 2834compute_deferred_decl_context (Entity_Id gnat_scope) 2835{ 2836 tree context; 2837 2838 if (present_gnu_tree (gnat_scope)) 2839 context = get_gnu_tree (gnat_scope); 2840 else 2841 return NULL_TREE; 2842 2843 if (TREE_CODE (context) == TYPE_DECL) 2844 { 2845 const tree context_type = TREE_TYPE (context); 2846 2847 /* Skip dummy types: only the final ones can appear in the context 2848 chain. */ 2849 if (TYPE_DUMMY_P (context_type)) 2850 return NULL_TREE; 2851 2852 /* ..._TYPE nodes are more useful than TYPE_DECL nodes in the context 2853 chain. */ 2854 else 2855 context = context_type; 2856 } 2857 2858 return context; 2859} 2860 2861/* Try to process all deferred nodes in the queue. Keep in the queue the ones 2862 that cannot be processed yet, remove the other ones. If FORCE is true, 2863 force the processing for all nodes, use the global context when nodes don't 2864 have a GNU translation. */ 2865 2866void 2867process_deferred_decl_context (bool force) 2868{ 2869 struct deferred_decl_context_node **it = &deferred_decl_context_queue; 2870 struct deferred_decl_context_node *node; 2871 2872 while (*it != NULL) 2873 { 2874 bool processed = false; 2875 tree context = NULL_TREE; 2876 Entity_Id gnat_scope; 2877 2878 node = *it; 2879 2880 /* If FORCE, get the innermost elaborated scope. Otherwise, just try to 2881 get the first scope. */ 2882 gnat_scope = node->gnat_scope; 2883 while (Present (gnat_scope)) 2884 { 2885 context = compute_deferred_decl_context (gnat_scope); 2886 if (!force || context != NULL_TREE) 2887 break; 2888 gnat_scope = get_debug_scope (gnat_scope, NULL); 2889 } 2890 2891 /* Imported declarations must not be in a local context (i.e. not inside 2892 a function). */ 2893 if (context != NULL_TREE && node->force_global > 0) 2894 { 2895 tree ctx = context; 2896 2897 while (ctx != NULL_TREE) 2898 { 2899 gcc_assert (TREE_CODE (ctx) != FUNCTION_DECL); 2900 ctx = (DECL_P (ctx)) 2901 ? DECL_CONTEXT (ctx) 2902 : TYPE_CONTEXT (ctx); 2903 } 2904 } 2905 2906 /* If FORCE, we want to get rid of all nodes in the queue: in case there 2907 was no elaborated scope, use the global context. */ 2908 if (force && context == NULL_TREE) 2909 context = get_global_context (); 2910 2911 if (context != NULL_TREE) 2912 { 2913 tree t; 2914 int i; 2915 2916 DECL_CONTEXT (node->decl) = context; 2917 2918 /* Propagate it to the TYPE_CONTEXT attributes of the requested 2919 ..._TYPE nodes. */ 2920 FOR_EACH_VEC_ELT (node->types, i, t) 2921 { 2922 gnat_set_type_context (t, context); 2923 } 2924 processed = true; 2925 } 2926 2927 /* If this node has been successfuly processed, remove it from the 2928 queue. Then move to the next node. */ 2929 if (processed) 2930 { 2931 *it = node->next; 2932 node->types.release (); 2933 free (node); 2934 } 2935 else 2936 it = &node->next; 2937 } 2938} 2939 2940 2941/* Return VALUE scaled by the biggest power-of-2 factor of EXPR. */ 2942 2943static unsigned int 2944scale_by_factor_of (tree expr, unsigned int value) 2945{ 2946 expr = remove_conversions (expr, true); 2947 2948 /* An expression which is a bitwise AND with a mask has a power-of-2 factor 2949 corresponding to the number of trailing zeros of the mask. */ 2950 if (TREE_CODE (expr) == BIT_AND_EXPR 2951 && TREE_CODE (TREE_OPERAND (expr, 1)) == INTEGER_CST) 2952 { 2953 unsigned HOST_WIDE_INT mask = TREE_INT_CST_LOW (TREE_OPERAND (expr, 1)); 2954 unsigned int i = 0; 2955 2956 while ((mask & 1) == 0 && i < HOST_BITS_PER_WIDE_INT) 2957 { 2958 mask >>= 1; 2959 value *= 2; 2960 i++; 2961 } 2962 } 2963 2964 return value; 2965} 2966 2967/* Given two consecutive field decls PREV_FIELD and CURR_FIELD, return true 2968 unless we can prove these 2 fields are laid out in such a way that no gap 2969 exist between the end of PREV_FIELD and the beginning of CURR_FIELD. OFFSET 2970 is the distance in bits between the end of PREV_FIELD and the starting 2971 position of CURR_FIELD. It is ignored if null. */ 2972 2973static bool 2974potential_alignment_gap (tree prev_field, tree curr_field, tree offset) 2975{ 2976 /* If this is the first field of the record, there cannot be any gap */ 2977 if (!prev_field) 2978 return false; 2979 2980 /* If the previous field is a union type, then return false: The only 2981 time when such a field is not the last field of the record is when 2982 there are other components at fixed positions after it (meaning there 2983 was a rep clause for every field), in which case we don't want the 2984 alignment constraint to override them. */ 2985 if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE) 2986 return false; 2987 2988 /* If the distance between the end of prev_field and the beginning of 2989 curr_field is constant, then there is a gap if the value of this 2990 constant is not null. */ 2991 if (offset && tree_fits_uhwi_p (offset)) 2992 return !integer_zerop (offset); 2993 2994 /* If the size and position of the previous field are constant, 2995 then check the sum of this size and position. There will be a gap 2996 iff it is not multiple of the current field alignment. */ 2997 if (tree_fits_uhwi_p (DECL_SIZE (prev_field)) 2998 && tree_fits_uhwi_p (bit_position (prev_field))) 2999 return ((tree_to_uhwi (bit_position (prev_field)) 3000 + tree_to_uhwi (DECL_SIZE (prev_field))) 3001 % DECL_ALIGN (curr_field) != 0); 3002 3003 /* If both the position and size of the previous field are multiples 3004 of the current field alignment, there cannot be any gap. */ 3005 if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field)) 3006 && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field))) 3007 return false; 3008 3009 /* Fallback, return that there may be a potential gap */ 3010 return true; 3011} 3012 3013/* Return a LABEL_DECL with LABEL_NAME. GNAT_NODE is used for the position 3014 of the decl. */ 3015 3016tree 3017create_label_decl (tree label_name, Node_Id gnat_node) 3018{ 3019 tree label_decl 3020 = build_decl (input_location, LABEL_DECL, label_name, void_type_node); 3021 3022 DECL_MODE (label_decl) = VOIDmode; 3023 3024 /* Add this decl to the current binding level. */ 3025 gnat_pushdecl (label_decl, gnat_node); 3026 3027 return label_decl; 3028} 3029 3030/* Return a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, 3031 ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE 3032 node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of 3033 PARM_DECL nodes chained through the DECL_CHAIN field). 3034 3035 INLINE_STATUS, PUBLIC_FLAG, EXTERN_FLAG, ARTIFICIAL_FLAG and ATTR_LIST are 3036 used to set the appropriate fields in the FUNCTION_DECL. GNAT_NODE is 3037 used for the position of the decl. */ 3038 3039tree 3040create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type, 3041 tree param_decl_list, enum inline_status_t inline_status, 3042 bool public_flag, bool extern_flag, bool artificial_flag, 3043 struct attrib *attr_list, Node_Id gnat_node) 3044{ 3045 tree subprog_decl = build_decl (input_location, FUNCTION_DECL, subprog_name, 3046 subprog_type); 3047 tree result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE, 3048 TREE_TYPE (subprog_type)); 3049 DECL_ARGUMENTS (subprog_decl) = param_decl_list; 3050 3051 DECL_ARTIFICIAL (subprog_decl) = artificial_flag; 3052 DECL_EXTERNAL (subprog_decl) = extern_flag; 3053 3054 switch (inline_status) 3055 { 3056 case is_suppressed: 3057 DECL_UNINLINABLE (subprog_decl) = 1; 3058 break; 3059 3060 case is_disabled: 3061 break; 3062 3063 case is_required: 3064 if (Back_End_Inlining) 3065 decl_attributes (&subprog_decl, 3066 tree_cons (get_identifier ("always_inline"), 3067 NULL_TREE, NULL_TREE), 3068 ATTR_FLAG_TYPE_IN_PLACE); 3069 3070 /* ... fall through ... */ 3071 3072 case is_enabled: 3073 DECL_DECLARED_INLINE_P (subprog_decl) = 1; 3074 DECL_NO_INLINE_WARNING_P (subprog_decl) = artificial_flag; 3075 break; 3076 3077 default: 3078 gcc_unreachable (); 3079 } 3080 3081 TREE_PUBLIC (subprog_decl) = public_flag; 3082 TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type); 3083 TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type); 3084 TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type); 3085 3086 DECL_ARTIFICIAL (result_decl) = 1; 3087 DECL_IGNORED_P (result_decl) = 1; 3088 DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (subprog_type); 3089 DECL_RESULT (subprog_decl) = result_decl; 3090 3091 if (asm_name) 3092 { 3093 SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name); 3094 3095 /* The expand_main_function circuitry expects "main_identifier_node" to 3096 designate the DECL_NAME of the 'main' entry point, in turn expected 3097 to be declared as the "main" function literally by default. Ada 3098 program entry points are typically declared with a different name 3099 within the binder generated file, exported as 'main' to satisfy the 3100 system expectations. Force main_identifier_node in this case. */ 3101 if (asm_name == main_identifier_node) 3102 DECL_NAME (subprog_decl) = main_identifier_node; 3103 } 3104 3105 process_attributes (&subprog_decl, &attr_list, true, gnat_node); 3106 3107 /* Add this decl to the current binding level. */ 3108 gnat_pushdecl (subprog_decl, gnat_node); 3109 3110 /* Output the assembler code and/or RTL for the declaration. */ 3111 rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0); 3112 3113 return subprog_decl; 3114} 3115 3116/* Set up the framework for generating code for SUBPROG_DECL, a subprogram 3117 body. This routine needs to be invoked before processing the declarations 3118 appearing in the subprogram. */ 3119 3120void 3121begin_subprog_body (tree subprog_decl) 3122{ 3123 tree param_decl; 3124 3125 announce_function (subprog_decl); 3126 3127 /* This function is being defined. */ 3128 TREE_STATIC (subprog_decl) = 1; 3129 3130 /* The failure of this assertion will likely come from a wrong context for 3131 the subprogram body, e.g. another procedure for a procedure declared at 3132 library level. */ 3133 gcc_assert (current_function_decl == decl_function_context (subprog_decl)); 3134 3135 current_function_decl = subprog_decl; 3136 3137 /* Enter a new binding level and show that all the parameters belong to 3138 this function. */ 3139 gnat_pushlevel (); 3140 3141 for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl; 3142 param_decl = DECL_CHAIN (param_decl)) 3143 DECL_CONTEXT (param_decl) = subprog_decl; 3144 3145 make_decl_rtl (subprog_decl); 3146} 3147 3148/* Finish translating the current subprogram and set its BODY. */ 3149 3150void 3151end_subprog_body (tree body) 3152{ 3153 tree fndecl = current_function_decl; 3154 3155 /* Attach the BLOCK for this level to the function and pop the level. */ 3156 BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl; 3157 DECL_INITIAL (fndecl) = current_binding_level->block; 3158 gnat_poplevel (); 3159 3160 /* Mark the RESULT_DECL as being in this subprogram. */ 3161 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; 3162 3163 /* The body should be a BIND_EXPR whose BLOCK is the top-level one. */ 3164 if (TREE_CODE (body) == BIND_EXPR) 3165 { 3166 BLOCK_SUPERCONTEXT (BIND_EXPR_BLOCK (body)) = fndecl; 3167 DECL_INITIAL (fndecl) = BIND_EXPR_BLOCK (body); 3168 } 3169 3170 DECL_SAVED_TREE (fndecl) = body; 3171 3172 current_function_decl = decl_function_context (fndecl); 3173} 3174 3175/* Wrap up compilation of SUBPROG_DECL, a subprogram body. */ 3176 3177void 3178rest_of_subprog_body_compilation (tree subprog_decl) 3179{ 3180 /* We cannot track the location of errors past this point. */ 3181 error_gnat_node = Empty; 3182 3183 /* If we're only annotating types, don't actually compile this function. */ 3184 if (type_annotate_only) 3185 return; 3186 3187 /* Dump functions before gimplification. */ 3188 dump_function (TDI_original, subprog_decl); 3189 3190 if (!decl_function_context (subprog_decl)) 3191 cgraph_node::finalize_function (subprog_decl, false); 3192 else 3193 /* Register this function with cgraph just far enough to get it 3194 added to our parent's nested function list. */ 3195 (void) cgraph_node::get_create (subprog_decl); 3196} 3197 3198tree 3199gnat_builtin_function (tree decl) 3200{ 3201 gnat_pushdecl (decl, Empty); 3202 return decl; 3203} 3204 3205/* Return an integer type with the number of bits of precision given by 3206 PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise 3207 it is a signed type. */ 3208 3209tree 3210gnat_type_for_size (unsigned precision, int unsignedp) 3211{ 3212 tree t; 3213 char type_name[20]; 3214 3215 if (precision <= 2 * MAX_BITS_PER_WORD 3216 && signed_and_unsigned_types[precision][unsignedp]) 3217 return signed_and_unsigned_types[precision][unsignedp]; 3218 3219 if (unsignedp) 3220 t = make_unsigned_type (precision); 3221 else 3222 t = make_signed_type (precision); 3223 3224 if (precision <= 2 * MAX_BITS_PER_WORD) 3225 signed_and_unsigned_types[precision][unsignedp] = t; 3226 3227 if (!TYPE_NAME (t)) 3228 { 3229 sprintf (type_name, "%sSIGNED_%u", unsignedp ? "UN" : "", precision); 3230 TYPE_NAME (t) = get_identifier (type_name); 3231 } 3232 3233 return t; 3234} 3235 3236/* Likewise for floating-point types. */ 3237 3238static tree 3239float_type_for_precision (int precision, machine_mode mode) 3240{ 3241 tree t; 3242 char type_name[20]; 3243 3244 if (float_types[(int) mode]) 3245 return float_types[(int) mode]; 3246 3247 float_types[(int) mode] = t = make_node (REAL_TYPE); 3248 TYPE_PRECISION (t) = precision; 3249 layout_type (t); 3250 3251 gcc_assert (TYPE_MODE (t) == mode); 3252 if (!TYPE_NAME (t)) 3253 { 3254 sprintf (type_name, "FLOAT_%d", precision); 3255 TYPE_NAME (t) = get_identifier (type_name); 3256 } 3257 3258 return t; 3259} 3260 3261/* Return a data type that has machine mode MODE. UNSIGNEDP selects 3262 an unsigned type; otherwise a signed type is returned. */ 3263 3264tree 3265gnat_type_for_mode (machine_mode mode, int unsignedp) 3266{ 3267 if (mode == BLKmode) 3268 return NULL_TREE; 3269 3270 if (mode == VOIDmode) 3271 return void_type_node; 3272 3273 if (COMPLEX_MODE_P (mode)) 3274 return NULL_TREE; 3275 3276 if (SCALAR_FLOAT_MODE_P (mode)) 3277 return float_type_for_precision (GET_MODE_PRECISION (mode), mode); 3278 3279 if (SCALAR_INT_MODE_P (mode)) 3280 return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp); 3281 3282 if (VECTOR_MODE_P (mode)) 3283 { 3284 machine_mode inner_mode = GET_MODE_INNER (mode); 3285 tree inner_type = gnat_type_for_mode (inner_mode, unsignedp); 3286 if (inner_type) 3287 return build_vector_type_for_mode (inner_type, mode); 3288 } 3289 3290 return NULL_TREE; 3291} 3292 3293/* Return the unsigned version of a TYPE_NODE, a scalar type. */ 3294 3295tree 3296gnat_unsigned_type (tree type_node) 3297{ 3298 tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1); 3299 3300 if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node)) 3301 { 3302 type = copy_node (type); 3303 TREE_TYPE (type) = type_node; 3304 } 3305 else if (TREE_TYPE (type_node) 3306 && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE 3307 && TYPE_MODULAR_P (TREE_TYPE (type_node))) 3308 { 3309 type = copy_node (type); 3310 TREE_TYPE (type) = TREE_TYPE (type_node); 3311 } 3312 3313 return type; 3314} 3315 3316/* Return the signed version of a TYPE_NODE, a scalar type. */ 3317 3318tree 3319gnat_signed_type (tree type_node) 3320{ 3321 tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0); 3322 3323 if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node)) 3324 { 3325 type = copy_node (type); 3326 TREE_TYPE (type) = type_node; 3327 } 3328 else if (TREE_TYPE (type_node) 3329 && TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE 3330 && TYPE_MODULAR_P (TREE_TYPE (type_node))) 3331 { 3332 type = copy_node (type); 3333 TREE_TYPE (type) = TREE_TYPE (type_node); 3334 } 3335 3336 return type; 3337} 3338 3339/* Return 1 if the types T1 and T2 are compatible, i.e. if they can be 3340 transparently converted to each other. */ 3341 3342int 3343gnat_types_compatible_p (tree t1, tree t2) 3344{ 3345 enum tree_code code; 3346 3347 /* This is the default criterion. */ 3348 if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2)) 3349 return 1; 3350 3351 /* We only check structural equivalence here. */ 3352 if ((code = TREE_CODE (t1)) != TREE_CODE (t2)) 3353 return 0; 3354 3355 /* Vector types are also compatible if they have the same number of subparts 3356 and the same form of (scalar) element type. */ 3357 if (code == VECTOR_TYPE 3358 && TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2) 3359 && TREE_CODE (TREE_TYPE (t1)) == TREE_CODE (TREE_TYPE (t2)) 3360 && TYPE_PRECISION (TREE_TYPE (t1)) == TYPE_PRECISION (TREE_TYPE (t2))) 3361 return 1; 3362 3363 /* Array types are also compatible if they are constrained and have the same 3364 domain(s) and the same component type. */ 3365 if (code == ARRAY_TYPE 3366 && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2) 3367 || (TYPE_DOMAIN (t1) 3368 && TYPE_DOMAIN (t2) 3369 && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)), 3370 TYPE_MIN_VALUE (TYPE_DOMAIN (t2))) 3371 && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)), 3372 TYPE_MAX_VALUE (TYPE_DOMAIN (t2))))) 3373 && (TREE_TYPE (t1) == TREE_TYPE (t2) 3374 || (TREE_CODE (TREE_TYPE (t1)) == ARRAY_TYPE 3375 && gnat_types_compatible_p (TREE_TYPE (t1), TREE_TYPE (t2))))) 3376 return 1; 3377 3378 return 0; 3379} 3380 3381/* Return true if EXPR is a useless type conversion. */ 3382 3383bool 3384gnat_useless_type_conversion (tree expr) 3385{ 3386 if (CONVERT_EXPR_P (expr) 3387 || TREE_CODE (expr) == VIEW_CONVERT_EXPR 3388 || TREE_CODE (expr) == NON_LVALUE_EXPR) 3389 return gnat_types_compatible_p (TREE_TYPE (expr), 3390 TREE_TYPE (TREE_OPERAND (expr, 0))); 3391 3392 return false; 3393} 3394 3395/* Return true if T, a FUNCTION_TYPE, has the specified list of flags. */ 3396 3397bool 3398fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p, 3399 bool return_by_direct_ref_p, bool return_by_invisi_ref_p) 3400{ 3401 return TYPE_CI_CO_LIST (t) == cico_list 3402 && TYPE_RETURN_UNCONSTRAINED_P (t) == return_unconstrained_p 3403 && TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p 3404 && TREE_ADDRESSABLE (t) == return_by_invisi_ref_p; 3405} 3406 3407/* EXP is an expression for the size of an object. If this size contains 3408 discriminant references, replace them with the maximum (if MAX_P) or 3409 minimum (if !MAX_P) possible value of the discriminant. */ 3410 3411tree 3412max_size (tree exp, bool max_p) 3413{ 3414 enum tree_code code = TREE_CODE (exp); 3415 tree type = TREE_TYPE (exp); 3416 3417 switch (TREE_CODE_CLASS (code)) 3418 { 3419 case tcc_declaration: 3420 case tcc_constant: 3421 return exp; 3422 3423 case tcc_vl_exp: 3424 if (code == CALL_EXPR) 3425 { 3426 tree t, *argarray; 3427 int n, i; 3428 3429 t = maybe_inline_call_in_expr (exp); 3430 if (t) 3431 return max_size (t, max_p); 3432 3433 n = call_expr_nargs (exp); 3434 gcc_assert (n > 0); 3435 argarray = XALLOCAVEC (tree, n); 3436 for (i = 0; i < n; i++) 3437 argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p); 3438 return build_call_array (type, CALL_EXPR_FN (exp), n, argarray); 3439 } 3440 break; 3441 3442 case tcc_reference: 3443 /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to 3444 modify. Otherwise, we treat it like a variable. */ 3445 if (CONTAINS_PLACEHOLDER_P (exp)) 3446 { 3447 tree val_type = TREE_TYPE (TREE_OPERAND (exp, 1)); 3448 tree val = (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type)); 3449 return max_size (convert (get_base_type (val_type), val), true); 3450 } 3451 3452 return exp; 3453 3454 case tcc_comparison: 3455 return max_p ? size_one_node : size_zero_node; 3456 3457 case tcc_unary: 3458 if (code == NON_LVALUE_EXPR) 3459 return max_size (TREE_OPERAND (exp, 0), max_p); 3460 3461 return fold_build1 (code, type, 3462 max_size (TREE_OPERAND (exp, 0), 3463 code == NEGATE_EXPR ? !max_p : max_p)); 3464 3465 case tcc_binary: 3466 { 3467 tree lhs = max_size (TREE_OPERAND (exp, 0), max_p); 3468 tree rhs = max_size (TREE_OPERAND (exp, 1), 3469 code == MINUS_EXPR ? !max_p : max_p); 3470 3471 /* Special-case wanting the maximum value of a MIN_EXPR. 3472 In that case, if one side overflows, return the other. */ 3473 if (max_p && code == MIN_EXPR) 3474 { 3475 if (TREE_CODE (rhs) == INTEGER_CST && TREE_OVERFLOW (rhs)) 3476 return lhs; 3477 3478 if (TREE_CODE (lhs) == INTEGER_CST && TREE_OVERFLOW (lhs)) 3479 return rhs; 3480 } 3481 3482 /* Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS 3483 overflowing and the RHS a variable. */ 3484 if ((code == MINUS_EXPR || code == PLUS_EXPR) 3485 && TREE_CODE (lhs) == INTEGER_CST 3486 && TREE_OVERFLOW (lhs) 3487 && !TREE_CONSTANT (rhs)) 3488 return lhs; 3489 3490 return size_binop (code, lhs, rhs); 3491 } 3492 3493 case tcc_expression: 3494 switch (TREE_CODE_LENGTH (code)) 3495 { 3496 case 1: 3497 if (code == SAVE_EXPR) 3498 return exp; 3499 3500 return fold_build1 (code, type, 3501 max_size (TREE_OPERAND (exp, 0), max_p)); 3502 3503 case 2: 3504 if (code == COMPOUND_EXPR) 3505 return max_size (TREE_OPERAND (exp, 1), max_p); 3506 3507 return fold_build2 (code, type, 3508 max_size (TREE_OPERAND (exp, 0), max_p), 3509 max_size (TREE_OPERAND (exp, 1), max_p)); 3510 3511 case 3: 3512 if (code == COND_EXPR) 3513 return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type, 3514 max_size (TREE_OPERAND (exp, 1), max_p), 3515 max_size (TREE_OPERAND (exp, 2), max_p)); 3516 3517 default: 3518 break; 3519 } 3520 3521 /* Other tree classes cannot happen. */ 3522 default: 3523 break; 3524 } 3525 3526 gcc_unreachable (); 3527} 3528 3529/* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE. 3530 EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs. 3531 Return a constructor for the template. */ 3532 3533tree 3534build_template (tree template_type, tree array_type, tree expr) 3535{ 3536 vec<constructor_elt, va_gc> *template_elts = NULL; 3537 tree bound_list = NULL_TREE; 3538 tree field; 3539 3540 while (TREE_CODE (array_type) == RECORD_TYPE 3541 && (TYPE_PADDING_P (array_type) 3542 || TYPE_JUSTIFIED_MODULAR_P (array_type))) 3543 array_type = TREE_TYPE (TYPE_FIELDS (array_type)); 3544 3545 if (TREE_CODE (array_type) == ARRAY_TYPE 3546 || (TREE_CODE (array_type) == INTEGER_TYPE 3547 && TYPE_HAS_ACTUAL_BOUNDS_P (array_type))) 3548 bound_list = TYPE_ACTUAL_BOUNDS (array_type); 3549 3550 /* First make the list for a CONSTRUCTOR for the template. Go down the 3551 field list of the template instead of the type chain because this 3552 array might be an Ada array of arrays and we can't tell where the 3553 nested arrays stop being the underlying object. */ 3554 3555 for (field = TYPE_FIELDS (template_type); field; 3556 (bound_list 3557 ? (bound_list = TREE_CHAIN (bound_list)) 3558 : (array_type = TREE_TYPE (array_type))), 3559 field = DECL_CHAIN (DECL_CHAIN (field))) 3560 { 3561 tree bounds, min, max; 3562 3563 /* If we have a bound list, get the bounds from there. Likewise 3564 for an ARRAY_TYPE. Otherwise, if expr is a PARM_DECL with 3565 DECL_BY_COMPONENT_PTR_P, use the bounds of the field in the template. 3566 This will give us a maximum range. */ 3567 if (bound_list) 3568 bounds = TREE_VALUE (bound_list); 3569 else if (TREE_CODE (array_type) == ARRAY_TYPE) 3570 bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type)); 3571 else if (expr && TREE_CODE (expr) == PARM_DECL 3572 && DECL_BY_COMPONENT_PTR_P (expr)) 3573 bounds = TREE_TYPE (field); 3574 else 3575 gcc_unreachable (); 3576 3577 min = convert (TREE_TYPE (field), TYPE_MIN_VALUE (bounds)); 3578 max = convert (TREE_TYPE (DECL_CHAIN (field)), TYPE_MAX_VALUE (bounds)); 3579 3580 /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must 3581 substitute it from OBJECT. */ 3582 min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr); 3583 max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr); 3584 3585 CONSTRUCTOR_APPEND_ELT (template_elts, field, min); 3586 CONSTRUCTOR_APPEND_ELT (template_elts, DECL_CHAIN (field), max); 3587 } 3588 3589 return gnat_build_constructor (template_type, template_elts); 3590} 3591 3592/* Return true if TYPE is suitable for the element type of a vector. */ 3593 3594static bool 3595type_for_vector_element_p (tree type) 3596{ 3597 machine_mode mode; 3598 3599 if (!INTEGRAL_TYPE_P (type) 3600 && !SCALAR_FLOAT_TYPE_P (type) 3601 && !FIXED_POINT_TYPE_P (type)) 3602 return false; 3603 3604 mode = TYPE_MODE (type); 3605 if (GET_MODE_CLASS (mode) != MODE_INT 3606 && !SCALAR_FLOAT_MODE_P (mode) 3607 && !ALL_SCALAR_FIXED_POINT_MODE_P (mode)) 3608 return false; 3609 3610 return true; 3611} 3612 3613/* Return a vector type given the SIZE and the INNER_TYPE, or NULL_TREE if 3614 this is not possible. If ATTRIBUTE is non-zero, we are processing the 3615 attribute declaration and want to issue error messages on failure. */ 3616 3617static tree 3618build_vector_type_for_size (tree inner_type, tree size, tree attribute) 3619{ 3620 unsigned HOST_WIDE_INT size_int, inner_size_int; 3621 int nunits; 3622 3623 /* Silently punt on variable sizes. We can't make vector types for them, 3624 need to ignore them on front-end generated subtypes of unconstrained 3625 base types, and this attribute is for binding implementors, not end 3626 users, so we should never get there from legitimate explicit uses. */ 3627 if (!tree_fits_uhwi_p (size)) 3628 return NULL_TREE; 3629 size_int = tree_to_uhwi (size); 3630 3631 if (!type_for_vector_element_p (inner_type)) 3632 { 3633 if (attribute) 3634 error ("invalid element type for attribute %qs", 3635 IDENTIFIER_POINTER (attribute)); 3636 return NULL_TREE; 3637 } 3638 inner_size_int = tree_to_uhwi (TYPE_SIZE_UNIT (inner_type)); 3639 3640 if (size_int % inner_size_int) 3641 { 3642 if (attribute) 3643 error ("vector size not an integral multiple of component size"); 3644 return NULL_TREE; 3645 } 3646 3647 if (size_int == 0) 3648 { 3649 if (attribute) 3650 error ("zero vector size"); 3651 return NULL_TREE; 3652 } 3653 3654 nunits = size_int / inner_size_int; 3655 if (nunits & (nunits - 1)) 3656 { 3657 if (attribute) 3658 error ("number of components of vector not a power of two"); 3659 return NULL_TREE; 3660 } 3661 3662 return build_vector_type (inner_type, nunits); 3663} 3664 3665/* Return a vector type whose representative array type is ARRAY_TYPE, or 3666 NULL_TREE if this is not possible. If ATTRIBUTE is non-zero, we are 3667 processing the attribute and want to issue error messages on failure. */ 3668 3669static tree 3670build_vector_type_for_array (tree array_type, tree attribute) 3671{ 3672 tree vector_type = build_vector_type_for_size (TREE_TYPE (array_type), 3673 TYPE_SIZE_UNIT (array_type), 3674 attribute); 3675 if (!vector_type) 3676 return NULL_TREE; 3677 3678 TYPE_REPRESENTATIVE_ARRAY (vector_type) = array_type; 3679 return vector_type; 3680} 3681 3682/* Build a type to be used to represent an aliased object whose nominal type 3683 is an unconstrained array. This consists of a RECORD_TYPE containing a 3684 field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE. 3685 If ARRAY_TYPE is that of an unconstrained array, this is used to represent 3686 an arbitrary unconstrained object. Use NAME as the name of the record. 3687 DEBUG_INFO_P is true if we need to write debug information for the type. */ 3688 3689tree 3690build_unc_object_type (tree template_type, tree object_type, tree name, 3691 bool debug_info_p) 3692{ 3693 tree decl; 3694 tree type = make_node (RECORD_TYPE); 3695 tree template_field 3696 = create_field_decl (get_identifier ("BOUNDS"), template_type, type, 3697 NULL_TREE, NULL_TREE, 0, 1); 3698 tree array_field 3699 = create_field_decl (get_identifier ("ARRAY"), object_type, type, 3700 NULL_TREE, NULL_TREE, 0, 1); 3701 3702 TYPE_NAME (type) = name; 3703 TYPE_CONTAINS_TEMPLATE_P (type) = 1; 3704 DECL_CHAIN (template_field) = array_field; 3705 finish_record_type (type, template_field, 0, true); 3706 3707 /* Declare it now since it will never be declared otherwise. This is 3708 necessary to ensure that its subtrees are properly marked. */ 3709 decl = create_type_decl (name, type, true, debug_info_p, Empty); 3710 3711 /* template_type will not be used elsewhere than here, so to keep the debug 3712 info clean and in order to avoid scoping issues, make decl its 3713 context. */ 3714 gnat_set_type_context (template_type, decl); 3715 3716 return type; 3717} 3718 3719/* Same, taking a thin or fat pointer type instead of a template type. */ 3720 3721tree 3722build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, 3723 tree name, bool debug_info_p) 3724{ 3725 tree template_type; 3726 3727 gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type)); 3728 3729 template_type 3730 = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type) 3731 ? TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (thin_fat_ptr_type)))) 3732 : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type)))); 3733 3734 return 3735 build_unc_object_type (template_type, object_type, name, debug_info_p); 3736} 3737 3738/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. 3739 In the normal case this is just two adjustments, but we have more to 3740 do if NEW_TYPE is an UNCONSTRAINED_ARRAY_TYPE. */ 3741 3742void 3743update_pointer_to (tree old_type, tree new_type) 3744{ 3745 tree ptr = TYPE_POINTER_TO (old_type); 3746 tree ref = TYPE_REFERENCE_TO (old_type); 3747 tree t; 3748 3749 /* If this is the main variant, process all the other variants first. */ 3750 if (TYPE_MAIN_VARIANT (old_type) == old_type) 3751 for (t = TYPE_NEXT_VARIANT (old_type); t; t = TYPE_NEXT_VARIANT (t)) 3752 update_pointer_to (t, new_type); 3753 3754 /* If no pointers and no references, we are done. */ 3755 if (!ptr && !ref) 3756 return; 3757 3758 /* Merge the old type qualifiers in the new type. 3759 3760 Each old variant has qualifiers for specific reasons, and the new 3761 designated type as well. Each set of qualifiers represents useful 3762 information grabbed at some point, and merging the two simply unifies 3763 these inputs into the final type description. 3764 3765 Consider for instance a volatile type frozen after an access to constant 3766 type designating it; after the designated type's freeze, we get here with 3767 a volatile NEW_TYPE and a dummy OLD_TYPE with a readonly variant, created 3768 when the access type was processed. We will make a volatile and readonly 3769 designated type, because that's what it really is. 3770 3771 We might also get here for a non-dummy OLD_TYPE variant with different 3772 qualifiers than those of NEW_TYPE, for instance in some cases of pointers 3773 to private record type elaboration (see the comments around the call to 3774 this routine in gnat_to_gnu_entity <E_Access_Type>). We have to merge 3775 the qualifiers in those cases too, to avoid accidentally discarding the 3776 initial set, and will often end up with OLD_TYPE == NEW_TYPE then. */ 3777 new_type 3778 = build_qualified_type (new_type, 3779 TYPE_QUALS (old_type) | TYPE_QUALS (new_type)); 3780 3781 /* If old type and new type are identical, there is nothing to do. */ 3782 if (old_type == new_type) 3783 return; 3784 3785 /* Otherwise, first handle the simple case. */ 3786 if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE) 3787 { 3788 tree new_ptr, new_ref; 3789 3790 /* If pointer or reference already points to new type, nothing to do. 3791 This can happen as update_pointer_to can be invoked multiple times 3792 on the same couple of types because of the type variants. */ 3793 if ((ptr && TREE_TYPE (ptr) == new_type) 3794 || (ref && TREE_TYPE (ref) == new_type)) 3795 return; 3796 3797 /* Chain PTR and its variants at the end. */ 3798 new_ptr = TYPE_POINTER_TO (new_type); 3799 if (new_ptr) 3800 { 3801 while (TYPE_NEXT_PTR_TO (new_ptr)) 3802 new_ptr = TYPE_NEXT_PTR_TO (new_ptr); 3803 TYPE_NEXT_PTR_TO (new_ptr) = ptr; 3804 } 3805 else 3806 TYPE_POINTER_TO (new_type) = ptr; 3807 3808 /* Now adjust them. */ 3809 for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr)) 3810 for (t = TYPE_MAIN_VARIANT (ptr); t; t = TYPE_NEXT_VARIANT (t)) 3811 { 3812 TREE_TYPE (t) = new_type; 3813 if (TYPE_NULL_BOUNDS (t)) 3814 TREE_TYPE (TREE_OPERAND (TYPE_NULL_BOUNDS (t), 0)) = new_type; 3815 } 3816 3817 /* Chain REF and its variants at the end. */ 3818 new_ref = TYPE_REFERENCE_TO (new_type); 3819 if (new_ref) 3820 { 3821 while (TYPE_NEXT_REF_TO (new_ref)) 3822 new_ref = TYPE_NEXT_REF_TO (new_ref); 3823 TYPE_NEXT_REF_TO (new_ref) = ref; 3824 } 3825 else 3826 TYPE_REFERENCE_TO (new_type) = ref; 3827 3828 /* Now adjust them. */ 3829 for (; ref; ref = TYPE_NEXT_REF_TO (ref)) 3830 for (t = TYPE_MAIN_VARIANT (ref); t; t = TYPE_NEXT_VARIANT (t)) 3831 TREE_TYPE (t) = new_type; 3832 3833 TYPE_POINTER_TO (old_type) = NULL_TREE; 3834 TYPE_REFERENCE_TO (old_type) = NULL_TREE; 3835 } 3836 3837 /* Now deal with the unconstrained array case. In this case the pointer 3838 is actually a record where both fields are pointers to dummy nodes. 3839 Turn them into pointers to the correct types using update_pointer_to. 3840 Likewise for the pointer to the object record (thin pointer). */ 3841 else 3842 { 3843 tree new_ptr = TYPE_POINTER_TO (new_type); 3844 3845 gcc_assert (TYPE_IS_FAT_POINTER_P (ptr)); 3846 3847 /* If PTR already points to NEW_TYPE, nothing to do. This can happen 3848 since update_pointer_to can be invoked multiple times on the same 3849 couple of types because of the type variants. */ 3850 if (TYPE_UNCONSTRAINED_ARRAY (ptr) == new_type) 3851 return; 3852 3853 update_pointer_to 3854 (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))), 3855 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr)))); 3856 3857 update_pointer_to 3858 (TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (ptr)))), 3859 TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (new_ptr))))); 3860 3861 update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), 3862 TYPE_OBJECT_RECORD_TYPE (new_type)); 3863 3864 TYPE_POINTER_TO (old_type) = NULL_TREE; 3865 } 3866} 3867 3868/* Convert EXPR, a pointer to a constrained array, into a pointer to an 3869 unconstrained one. This involves making or finding a template. */ 3870 3871static tree 3872convert_to_fat_pointer (tree type, tree expr) 3873{ 3874 tree template_type = TREE_TYPE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type)))); 3875 tree p_array_type = TREE_TYPE (TYPE_FIELDS (type)); 3876 tree etype = TREE_TYPE (expr); 3877 tree template_addr; 3878 vec<constructor_elt, va_gc> *v; 3879 vec_alloc (v, 2); 3880 3881 /* If EXPR is null, make a fat pointer that contains a null pointer to the 3882 array (compare_fat_pointers ensures that this is the full discriminant) 3883 and a valid pointer to the bounds. This latter property is necessary 3884 since the compiler can hoist the load of the bounds done through it. */ 3885 if (integer_zerop (expr)) 3886 { 3887 tree ptr_template_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))); 3888 tree null_bounds, t; 3889 3890 if (TYPE_NULL_BOUNDS (ptr_template_type)) 3891 null_bounds = TYPE_NULL_BOUNDS (ptr_template_type); 3892 else 3893 { 3894 /* The template type can still be dummy at this point so we build an 3895 empty constructor. The middle-end will fill it in with zeros. */ 3896 t = build_constructor (template_type, NULL); 3897 TREE_CONSTANT (t) = TREE_STATIC (t) = 1; 3898 null_bounds = build_unary_op (ADDR_EXPR, NULL_TREE, t); 3899 SET_TYPE_NULL_BOUNDS (ptr_template_type, null_bounds); 3900 } 3901 3902 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), 3903 fold_convert (p_array_type, null_pointer_node)); 3904 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), null_bounds); 3905 t = build_constructor (type, v); 3906 /* Do not set TREE_CONSTANT so as to force T to static memory. */ 3907 TREE_CONSTANT (t) = 0; 3908 TREE_STATIC (t) = 1; 3909 3910 return t; 3911 } 3912 3913 /* If EXPR is a thin pointer, make template and data from the record. */ 3914 if (TYPE_IS_THIN_POINTER_P (etype)) 3915 { 3916 tree field = TYPE_FIELDS (TREE_TYPE (etype)); 3917 3918 expr = gnat_protect_expr (expr); 3919 3920 /* If we have a TYPE_UNCONSTRAINED_ARRAY attached to the RECORD_TYPE, 3921 the thin pointer value has been shifted so we shift it back to get 3922 the template address. */ 3923 if (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (etype))) 3924 { 3925 template_addr 3926 = build_binary_op (POINTER_PLUS_EXPR, etype, expr, 3927 fold_build1 (NEGATE_EXPR, sizetype, 3928 byte_position 3929 (DECL_CHAIN (field)))); 3930 template_addr 3931 = fold_convert (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))), 3932 template_addr); 3933 } 3934 3935 /* Otherwise we explicitly take the address of the fields. */ 3936 else 3937 { 3938 expr = build_unary_op (INDIRECT_REF, NULL_TREE, expr); 3939 template_addr 3940 = build_unary_op (ADDR_EXPR, NULL_TREE, 3941 build_component_ref (expr, NULL_TREE, field, 3942 false)); 3943 expr = build_unary_op (ADDR_EXPR, NULL_TREE, 3944 build_component_ref (expr, NULL_TREE, 3945 DECL_CHAIN (field), 3946 false)); 3947 } 3948 } 3949 3950 /* Otherwise, build the constructor for the template. */ 3951 else 3952 template_addr 3953 = build_unary_op (ADDR_EXPR, NULL_TREE, 3954 build_template (template_type, TREE_TYPE (etype), 3955 expr)); 3956 3957 /* The final result is a constructor for the fat pointer. 3958 3959 If EXPR is an argument of a foreign convention subprogram, the type it 3960 points to is directly the component type. In this case, the expression 3961 type may not match the corresponding FIELD_DECL type at this point, so we 3962 call "convert" here to fix that up if necessary. This type consistency is 3963 required, for instance because it ensures that possible later folding of 3964 COMPONENT_REFs against this constructor always yields something of the 3965 same type as the initial reference. 3966 3967 Note that the call to "build_template" above is still fine because it 3968 will only refer to the provided TEMPLATE_TYPE in this case. */ 3969 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), convert (p_array_type, expr)); 3970 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), template_addr); 3971 return gnat_build_constructor (type, v); 3972} 3973 3974/* Create an expression whose value is that of EXPR, 3975 converted to type TYPE. The TREE_TYPE of the value 3976 is always TYPE. This function implements all reasonable 3977 conversions; callers should filter out those that are 3978 not permitted by the language being compiled. */ 3979 3980tree 3981convert (tree type, tree expr) 3982{ 3983 tree etype = TREE_TYPE (expr); 3984 enum tree_code ecode = TREE_CODE (etype); 3985 enum tree_code code = TREE_CODE (type); 3986 3987 /* If the expression is already of the right type, we are done. */ 3988 if (etype == type) 3989 return expr; 3990 3991 /* If both input and output have padding and are of variable size, do this 3992 as an unchecked conversion. Likewise if one is a mere variant of the 3993 other, so we avoid a pointless unpad/repad sequence. */ 3994 else if (code == RECORD_TYPE && ecode == RECORD_TYPE 3995 && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype) 3996 && (!TREE_CONSTANT (TYPE_SIZE (type)) 3997 || !TREE_CONSTANT (TYPE_SIZE (etype)) 3998 || TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype) 3999 || TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))) 4000 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype))))) 4001 ; 4002 4003 /* If the output type has padding, convert to the inner type and make a 4004 constructor to build the record, unless a variable size is involved. */ 4005 else if (code == RECORD_TYPE && TYPE_PADDING_P (type)) 4006 { 4007 vec<constructor_elt, va_gc> *v; 4008 4009 /* If we previously converted from another type and our type is 4010 of variable size, remove the conversion to avoid the need for 4011 variable-sized temporaries. Likewise for a conversion between 4012 original and packable version. */ 4013 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR 4014 && (!TREE_CONSTANT (TYPE_SIZE (type)) 4015 || (ecode == RECORD_TYPE 4016 && TYPE_NAME (etype) 4017 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (expr, 0)))))) 4018 expr = TREE_OPERAND (expr, 0); 4019 4020 /* If we are just removing the padding from expr, convert the original 4021 object if we have variable size in order to avoid the need for some 4022 variable-sized temporaries. Likewise if the padding is a variant 4023 of the other, so we avoid a pointless unpad/repad sequence. */ 4024 if (TREE_CODE (expr) == COMPONENT_REF 4025 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0))) 4026 && (!TREE_CONSTANT (TYPE_SIZE (type)) 4027 || TYPE_MAIN_VARIANT (type) 4028 == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (expr, 0))) 4029 || (ecode == RECORD_TYPE 4030 && TYPE_NAME (etype) 4031 == TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type)))))) 4032 return convert (type, TREE_OPERAND (expr, 0)); 4033 4034 /* If the inner type is of self-referential size and the expression type 4035 is a record, do this as an unchecked conversion. But first pad the 4036 expression if possible to have the same size on both sides. */ 4037 if (ecode == RECORD_TYPE 4038 && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type)))) 4039 { 4040 if (TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST) 4041 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty, 4042 false, false, false, true), 4043 expr); 4044 return unchecked_convert (type, expr, false); 4045 } 4046 4047 /* If we are converting between array types with variable size, do the 4048 final conversion as an unchecked conversion, again to avoid the need 4049 for some variable-sized temporaries. If valid, this conversion is 4050 very likely purely technical and without real effects. */ 4051 if (ecode == ARRAY_TYPE 4052 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == ARRAY_TYPE 4053 && !TREE_CONSTANT (TYPE_SIZE (etype)) 4054 && !TREE_CONSTANT (TYPE_SIZE (type))) 4055 return unchecked_convert (type, 4056 convert (TREE_TYPE (TYPE_FIELDS (type)), 4057 expr), 4058 false); 4059 4060 vec_alloc (v, 1); 4061 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), 4062 convert (TREE_TYPE (TYPE_FIELDS (type)), expr)); 4063 return gnat_build_constructor (type, v); 4064 } 4065 4066 /* If the input type has padding, remove it and convert to the output type. 4067 The conditions ordering is arranged to ensure that the output type is not 4068 a padding type here, as it is not clear whether the conversion would 4069 always be correct if this was to happen. */ 4070 else if (ecode == RECORD_TYPE && TYPE_PADDING_P (etype)) 4071 { 4072 tree unpadded; 4073 4074 /* If we have just converted to this padded type, just get the 4075 inner expression. */ 4076 if (TREE_CODE (expr) == CONSTRUCTOR 4077 && !vec_safe_is_empty (CONSTRUCTOR_ELTS (expr)) 4078 && (*CONSTRUCTOR_ELTS (expr))[0].index == TYPE_FIELDS (etype)) 4079 unpadded = (*CONSTRUCTOR_ELTS (expr))[0].value; 4080 4081 /* Otherwise, build an explicit component reference. */ 4082 else 4083 unpadded 4084 = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false); 4085 4086 return convert (type, unpadded); 4087 } 4088 4089 /* If the input is a biased type, adjust first. */ 4090 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype)) 4091 return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype), 4092 fold_convert (TREE_TYPE (etype), expr), 4093 fold_convert (TREE_TYPE (etype), 4094 TYPE_MIN_VALUE (etype)))); 4095 4096 /* If the input is a justified modular type, we need to extract the actual 4097 object before converting it to any other type with the exceptions of an 4098 unconstrained array or of a mere type variant. It is useful to avoid the 4099 extraction and conversion in the type variant case because it could end 4100 up replacing a VAR_DECL expr by a constructor and we might be about the 4101 take the address of the result. */ 4102 if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype) 4103 && code != UNCONSTRAINED_ARRAY_TYPE 4104 && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype)) 4105 return convert (type, build_component_ref (expr, NULL_TREE, 4106 TYPE_FIELDS (etype), false)); 4107 4108 /* If converting to a type that contains a template, convert to the data 4109 type and then build the template. */ 4110 if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)) 4111 { 4112 tree obj_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (type))); 4113 vec<constructor_elt, va_gc> *v; 4114 vec_alloc (v, 2); 4115 4116 /* If the source already has a template, get a reference to the 4117 associated array only, as we are going to rebuild a template 4118 for the target type anyway. */ 4119 expr = maybe_unconstrained_array (expr); 4120 4121 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), 4122 build_template (TREE_TYPE (TYPE_FIELDS (type)), 4123 obj_type, NULL_TREE)); 4124 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (type)), 4125 convert (obj_type, expr)); 4126 return gnat_build_constructor (type, v); 4127 } 4128 4129 /* There are some cases of expressions that we process specially. */ 4130 switch (TREE_CODE (expr)) 4131 { 4132 case ERROR_MARK: 4133 return expr; 4134 4135 case NULL_EXPR: 4136 /* Just set its type here. For TRANSFORM_EXPR, we will do the actual 4137 conversion in gnat_expand_expr. NULL_EXPR does not represent 4138 and actual value, so no conversion is needed. */ 4139 expr = copy_node (expr); 4140 TREE_TYPE (expr) = type; 4141 return expr; 4142 4143 case STRING_CST: 4144 /* If we are converting a STRING_CST to another constrained array type, 4145 just make a new one in the proper type. */ 4146 if (code == ecode && AGGREGATE_TYPE_P (etype) 4147 && !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST 4148 && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)) 4149 { 4150 expr = copy_node (expr); 4151 TREE_TYPE (expr) = type; 4152 return expr; 4153 } 4154 break; 4155 4156 case VECTOR_CST: 4157 /* If we are converting a VECTOR_CST to a mere type variant, just make 4158 a new one in the proper type. */ 4159 if (code == ecode && gnat_types_compatible_p (type, etype)) 4160 { 4161 expr = copy_node (expr); 4162 TREE_TYPE (expr) = type; 4163 return expr; 4164 } 4165 4166 case CONSTRUCTOR: 4167 /* If we are converting a CONSTRUCTOR to a mere type variant, or to 4168 another padding type around the same type, just make a new one in 4169 the proper type. */ 4170 if (code == ecode 4171 && (gnat_types_compatible_p (type, etype) 4172 || (code == RECORD_TYPE 4173 && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype) 4174 && TREE_TYPE (TYPE_FIELDS (type)) 4175 == TREE_TYPE (TYPE_FIELDS (etype))))) 4176 { 4177 expr = copy_node (expr); 4178 TREE_TYPE (expr) = type; 4179 CONSTRUCTOR_ELTS (expr) = vec_safe_copy (CONSTRUCTOR_ELTS (expr)); 4180 return expr; 4181 } 4182 4183 /* Likewise for a conversion between original and packable version, or 4184 conversion between types of the same size and with the same list of 4185 fields, but we have to work harder to preserve type consistency. */ 4186 if (code == ecode 4187 && code == RECORD_TYPE 4188 && (TYPE_NAME (type) == TYPE_NAME (etype) 4189 || tree_int_cst_equal (TYPE_SIZE (type), TYPE_SIZE (etype)))) 4190 4191 { 4192 vec<constructor_elt, va_gc> *e = CONSTRUCTOR_ELTS (expr); 4193 unsigned HOST_WIDE_INT len = vec_safe_length (e); 4194 vec<constructor_elt, va_gc> *v; 4195 vec_alloc (v, len); 4196 tree efield = TYPE_FIELDS (etype), field = TYPE_FIELDS (type); 4197 unsigned HOST_WIDE_INT idx; 4198 tree index, value; 4199 4200 /* Whether we need to clear TREE_CONSTANT et al. on the output 4201 constructor when we convert in place. */ 4202 bool clear_constant = false; 4203 4204 FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value) 4205 { 4206 /* Skip the missing fields in the CONSTRUCTOR. */ 4207 while (efield && field && !SAME_FIELD_P (efield, index)) 4208 { 4209 efield = DECL_CHAIN (efield); 4210 field = DECL_CHAIN (field); 4211 } 4212 /* The field must be the same. */ 4213 if (!(efield && field && SAME_FIELD_P (efield, field))) 4214 break; 4215 constructor_elt elt 4216 = {field, convert (TREE_TYPE (field), value)}; 4217 v->quick_push (elt); 4218 4219 /* If packing has made this field a bitfield and the input 4220 value couldn't be emitted statically any more, we need to 4221 clear TREE_CONSTANT on our output. */ 4222 if (!clear_constant 4223 && TREE_CONSTANT (expr) 4224 && !CONSTRUCTOR_BITFIELD_P (efield) 4225 && CONSTRUCTOR_BITFIELD_P (field) 4226 && !initializer_constant_valid_for_bitfield_p (value)) 4227 clear_constant = true; 4228 4229 efield = DECL_CHAIN (efield); 4230 field = DECL_CHAIN (field); 4231 } 4232 4233 /* If we have been able to match and convert all the input fields 4234 to their output type, convert in place now. We'll fallback to a 4235 view conversion downstream otherwise. */ 4236 if (idx == len) 4237 { 4238 expr = copy_node (expr); 4239 TREE_TYPE (expr) = type; 4240 CONSTRUCTOR_ELTS (expr) = v; 4241 if (clear_constant) 4242 TREE_CONSTANT (expr) = TREE_STATIC (expr) = 0; 4243 return expr; 4244 } 4245 } 4246 4247 /* Likewise for a conversion between array type and vector type with a 4248 compatible representative array. */ 4249 else if (code == VECTOR_TYPE 4250 && ecode == ARRAY_TYPE 4251 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type), 4252 etype)) 4253 { 4254 vec<constructor_elt, va_gc> *e = CONSTRUCTOR_ELTS (expr); 4255 unsigned HOST_WIDE_INT len = vec_safe_length (e); 4256 vec<constructor_elt, va_gc> *v; 4257 unsigned HOST_WIDE_INT ix; 4258 tree value; 4259 4260 /* Build a VECTOR_CST from a *constant* array constructor. */ 4261 if (TREE_CONSTANT (expr)) 4262 { 4263 bool constant_p = true; 4264 4265 /* Iterate through elements and check if all constructor 4266 elements are *_CSTs. */ 4267 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value) 4268 if (!CONSTANT_CLASS_P (value)) 4269 { 4270 constant_p = false; 4271 break; 4272 } 4273 4274 if (constant_p) 4275 return build_vector_from_ctor (type, 4276 CONSTRUCTOR_ELTS (expr)); 4277 } 4278 4279 /* Otherwise, build a regular vector constructor. */ 4280 vec_alloc (v, len); 4281 FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value) 4282 { 4283 constructor_elt elt = {NULL_TREE, value}; 4284 v->quick_push (elt); 4285 } 4286 expr = copy_node (expr); 4287 TREE_TYPE (expr) = type; 4288 CONSTRUCTOR_ELTS (expr) = v; 4289 return expr; 4290 } 4291 break; 4292 4293 case UNCONSTRAINED_ARRAY_REF: 4294 /* First retrieve the underlying array. */ 4295 expr = maybe_unconstrained_array (expr); 4296 etype = TREE_TYPE (expr); 4297 ecode = TREE_CODE (etype); 4298 break; 4299 4300 case VIEW_CONVERT_EXPR: 4301 { 4302 /* GCC 4.x is very sensitive to type consistency overall, and view 4303 conversions thus are very frequent. Even though just "convert"ing 4304 the inner operand to the output type is fine in most cases, it 4305 might expose unexpected input/output type mismatches in special 4306 circumstances so we avoid such recursive calls when we can. */ 4307 tree op0 = TREE_OPERAND (expr, 0); 4308 4309 /* If we are converting back to the original type, we can just 4310 lift the input conversion. This is a common occurrence with 4311 switches back-and-forth amongst type variants. */ 4312 if (type == TREE_TYPE (op0)) 4313 return op0; 4314 4315 /* Otherwise, if we're converting between two aggregate or vector 4316 types, we might be allowed to substitute the VIEW_CONVERT_EXPR 4317 target type in place or to just convert the inner expression. */ 4318 if ((AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)) 4319 || (VECTOR_TYPE_P (type) && VECTOR_TYPE_P (etype))) 4320 { 4321 /* If we are converting between mere variants, we can just 4322 substitute the VIEW_CONVERT_EXPR in place. */ 4323 if (gnat_types_compatible_p (type, etype)) 4324 return build1 (VIEW_CONVERT_EXPR, type, op0); 4325 4326 /* Otherwise, we may just bypass the input view conversion unless 4327 one of the types is a fat pointer, which is handled by 4328 specialized code below which relies on exact type matching. */ 4329 else if (!TYPE_IS_FAT_POINTER_P (type) 4330 && !TYPE_IS_FAT_POINTER_P (etype)) 4331 return convert (type, op0); 4332 } 4333 4334 break; 4335 } 4336 4337 default: 4338 break; 4339 } 4340 4341 /* Check for converting to a pointer to an unconstrained array. */ 4342 if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype)) 4343 return convert_to_fat_pointer (type, expr); 4344 4345 /* If we are converting between two aggregate or vector types that are mere 4346 variants, just make a VIEW_CONVERT_EXPR. Likewise when we are converting 4347 to a vector type from its representative array type. */ 4348 else if ((code == ecode 4349 && (AGGREGATE_TYPE_P (type) || VECTOR_TYPE_P (type)) 4350 && gnat_types_compatible_p (type, etype)) 4351 || (code == VECTOR_TYPE 4352 && ecode == ARRAY_TYPE 4353 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type), 4354 etype))) 4355 return build1 (VIEW_CONVERT_EXPR, type, expr); 4356 4357 /* If we are converting between tagged types, try to upcast properly. */ 4358 else if (ecode == RECORD_TYPE && code == RECORD_TYPE 4359 && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type)) 4360 { 4361 tree child_etype = etype; 4362 do { 4363 tree field = TYPE_FIELDS (child_etype); 4364 if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type) 4365 return build_component_ref (expr, NULL_TREE, field, false); 4366 child_etype = TREE_TYPE (field); 4367 } while (TREE_CODE (child_etype) == RECORD_TYPE); 4368 } 4369 4370 /* If we are converting from a smaller form of record type back to it, just 4371 make a VIEW_CONVERT_EXPR. But first pad the expression to have the same 4372 size on both sides. */ 4373 else if (ecode == RECORD_TYPE && code == RECORD_TYPE 4374 && smaller_form_type_p (etype, type)) 4375 { 4376 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty, 4377 false, false, false, true), 4378 expr); 4379 return build1 (VIEW_CONVERT_EXPR, type, expr); 4380 } 4381 4382 /* In all other cases of related types, make a NOP_EXPR. */ 4383 else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)) 4384 return fold_convert (type, expr); 4385 4386 switch (code) 4387 { 4388 case VOID_TYPE: 4389 return fold_build1 (CONVERT_EXPR, type, expr); 4390 4391 case INTEGER_TYPE: 4392 if (TYPE_HAS_ACTUAL_BOUNDS_P (type) 4393 && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE 4394 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)))) 4395 return unchecked_convert (type, expr, false); 4396 else if (TYPE_BIASED_REPRESENTATION_P (type)) 4397 return fold_convert (type, 4398 fold_build2 (MINUS_EXPR, TREE_TYPE (type), 4399 convert (TREE_TYPE (type), expr), 4400 convert (TREE_TYPE (type), 4401 TYPE_MIN_VALUE (type)))); 4402 4403 /* ... fall through ... */ 4404 4405 case ENUMERAL_TYPE: 4406 case BOOLEAN_TYPE: 4407 /* If we are converting an additive expression to an integer type 4408 with lower precision, be wary of the optimization that can be 4409 applied by convert_to_integer. There are 2 problematic cases: 4410 - if the first operand was originally of a biased type, 4411 because we could be recursively called to convert it 4412 to an intermediate type and thus rematerialize the 4413 additive operator endlessly, 4414 - if the expression contains a placeholder, because an 4415 intermediate conversion that changes the sign could 4416 be inserted and thus introduce an artificial overflow 4417 at compile time when the placeholder is substituted. */ 4418 if (code == INTEGER_TYPE 4419 && ecode == INTEGER_TYPE 4420 && TYPE_PRECISION (type) < TYPE_PRECISION (etype) 4421 && (TREE_CODE (expr) == PLUS_EXPR || TREE_CODE (expr) == MINUS_EXPR)) 4422 { 4423 tree op0 = get_unwidened (TREE_OPERAND (expr, 0), type); 4424 4425 if ((TREE_CODE (TREE_TYPE (op0)) == INTEGER_TYPE 4426 && TYPE_BIASED_REPRESENTATION_P (TREE_TYPE (op0))) 4427 || CONTAINS_PLACEHOLDER_P (expr)) 4428 return build1 (NOP_EXPR, type, expr); 4429 } 4430 4431 return fold (convert_to_integer (type, expr)); 4432 4433 case POINTER_TYPE: 4434 case REFERENCE_TYPE: 4435 /* If converting between two thin pointers, adjust if needed to account 4436 for differing offsets from the base pointer, depending on whether 4437 there is a TYPE_UNCONSTRAINED_ARRAY attached to the record type. */ 4438 if (TYPE_IS_THIN_POINTER_P (etype) && TYPE_IS_THIN_POINTER_P (type)) 4439 { 4440 tree etype_pos 4441 = TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (etype)) != NULL_TREE 4442 ? byte_position (DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (etype)))) 4443 : size_zero_node; 4444 tree type_pos 4445 = TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)) != NULL_TREE 4446 ? byte_position (DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (type)))) 4447 : size_zero_node; 4448 tree byte_diff = size_diffop (type_pos, etype_pos); 4449 4450 expr = build1 (NOP_EXPR, type, expr); 4451 if (integer_zerop (byte_diff)) 4452 return expr; 4453 4454 return build_binary_op (POINTER_PLUS_EXPR, type, expr, 4455 fold_convert (sizetype, byte_diff)); 4456 } 4457 4458 /* If converting fat pointer to normal or thin pointer, get the pointer 4459 to the array and then convert it. */ 4460 if (TYPE_IS_FAT_POINTER_P (etype)) 4461 expr 4462 = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false); 4463 4464 return fold (convert_to_pointer (type, expr)); 4465 4466 case REAL_TYPE: 4467 return fold (convert_to_real (type, expr)); 4468 4469 case RECORD_TYPE: 4470 if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype)) 4471 { 4472 vec<constructor_elt, va_gc> *v; 4473 vec_alloc (v, 1); 4474 4475 CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (type), 4476 convert (TREE_TYPE (TYPE_FIELDS (type)), 4477 expr)); 4478 return gnat_build_constructor (type, v); 4479 } 4480 4481 /* ... fall through ... */ 4482 4483 case ARRAY_TYPE: 4484 /* In these cases, assume the front-end has validated the conversion. 4485 If the conversion is valid, it will be a bit-wise conversion, so 4486 it can be viewed as an unchecked conversion. */ 4487 return unchecked_convert (type, expr, false); 4488 4489 case UNION_TYPE: 4490 /* This is a either a conversion between a tagged type and some 4491 subtype, which we have to mark as a UNION_TYPE because of 4492 overlapping fields or a conversion of an Unchecked_Union. */ 4493 return unchecked_convert (type, expr, false); 4494 4495 case UNCONSTRAINED_ARRAY_TYPE: 4496 /* If the input is a VECTOR_TYPE, convert to the representative 4497 array type first. */ 4498 if (ecode == VECTOR_TYPE) 4499 { 4500 expr = convert (TYPE_REPRESENTATIVE_ARRAY (etype), expr); 4501 etype = TREE_TYPE (expr); 4502 ecode = TREE_CODE (etype); 4503 } 4504 4505 /* If EXPR is a constrained array, take its address, convert it to a 4506 fat pointer, and then dereference it. Likewise if EXPR is a 4507 record containing both a template and a constrained array. 4508 Note that a record representing a justified modular type 4509 always represents a packed constrained array. */ 4510 if (ecode == ARRAY_TYPE 4511 || (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype)) 4512 || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)) 4513 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))) 4514 return 4515 build_unary_op 4516 (INDIRECT_REF, NULL_TREE, 4517 convert_to_fat_pointer (TREE_TYPE (type), 4518 build_unary_op (ADDR_EXPR, 4519 NULL_TREE, expr))); 4520 4521 /* Do something very similar for converting one unconstrained 4522 array to another. */ 4523 else if (ecode == UNCONSTRAINED_ARRAY_TYPE) 4524 return 4525 build_unary_op (INDIRECT_REF, NULL_TREE, 4526 convert (TREE_TYPE (type), 4527 build_unary_op (ADDR_EXPR, 4528 NULL_TREE, expr))); 4529 else 4530 gcc_unreachable (); 4531 4532 case COMPLEX_TYPE: 4533 return fold (convert_to_complex (type, expr)); 4534 4535 default: 4536 gcc_unreachable (); 4537 } 4538} 4539 4540/* Create an expression whose value is that of EXPR converted to the common 4541 index type, which is sizetype. EXPR is supposed to be in the base type 4542 of the GNAT index type. Calling it is equivalent to doing 4543 4544 convert (sizetype, expr) 4545 4546 but we try to distribute the type conversion with the knowledge that EXPR 4547 cannot overflow in its type. This is a best-effort approach and we fall 4548 back to the above expression as soon as difficulties are encountered. 4549 4550 This is necessary to overcome issues that arise when the GNAT base index 4551 type and the GCC common index type (sizetype) don't have the same size, 4552 which is quite frequent on 64-bit architectures. In this case, and if 4553 the GNAT base index type is signed but the iteration type of the loop has 4554 been forced to unsigned, the loop scalar evolution engine cannot compute 4555 a simple evolution for the general induction variables associated with the 4556 array indices, because it will preserve the wrap-around semantics in the 4557 unsigned type of their "inner" part. As a result, many loop optimizations 4558 are blocked. 4559 4560 The solution is to use a special (basic) induction variable that is at 4561 least as large as sizetype, and to express the aforementioned general 4562 induction variables in terms of this induction variable, eliminating 4563 the problematic intermediate truncation to the GNAT base index type. 4564 This is possible as long as the original expression doesn't overflow 4565 and if the middle-end hasn't introduced artificial overflows in the 4566 course of the various simplification it can make to the expression. */ 4567 4568tree 4569convert_to_index_type (tree expr) 4570{ 4571 enum tree_code code = TREE_CODE (expr); 4572 tree type = TREE_TYPE (expr); 4573 4574 /* If the type is unsigned, overflow is allowed so we cannot be sure that 4575 EXPR doesn't overflow. Keep it simple if optimization is disabled. */ 4576 if (TYPE_UNSIGNED (type) || !optimize) 4577 return convert (sizetype, expr); 4578 4579 switch (code) 4580 { 4581 case VAR_DECL: 4582 /* The main effect of the function: replace a loop parameter with its 4583 associated special induction variable. */ 4584 if (DECL_LOOP_PARM_P (expr) && DECL_INDUCTION_VAR (expr)) 4585 expr = DECL_INDUCTION_VAR (expr); 4586 break; 4587 4588 CASE_CONVERT: 4589 { 4590 tree otype = TREE_TYPE (TREE_OPERAND (expr, 0)); 4591 /* Bail out as soon as we suspect some sort of type frobbing. */ 4592 if (TYPE_PRECISION (type) != TYPE_PRECISION (otype) 4593 || TYPE_UNSIGNED (type) != TYPE_UNSIGNED (otype)) 4594 break; 4595 } 4596 4597 /* ... fall through ... */ 4598 4599 case NON_LVALUE_EXPR: 4600 return fold_build1 (code, sizetype, 4601 convert_to_index_type (TREE_OPERAND (expr, 0))); 4602 4603 case PLUS_EXPR: 4604 case MINUS_EXPR: 4605 case MULT_EXPR: 4606 return fold_build2 (code, sizetype, 4607 convert_to_index_type (TREE_OPERAND (expr, 0)), 4608 convert_to_index_type (TREE_OPERAND (expr, 1))); 4609 4610 case COMPOUND_EXPR: 4611 return fold_build2 (code, sizetype, TREE_OPERAND (expr, 0), 4612 convert_to_index_type (TREE_OPERAND (expr, 1))); 4613 4614 case COND_EXPR: 4615 return fold_build3 (code, sizetype, TREE_OPERAND (expr, 0), 4616 convert_to_index_type (TREE_OPERAND (expr, 1)), 4617 convert_to_index_type (TREE_OPERAND (expr, 2))); 4618 4619 default: 4620 break; 4621 } 4622 4623 return convert (sizetype, expr); 4624} 4625 4626/* Remove all conversions that are done in EXP. This includes converting 4627 from a padded type or to a justified modular type. If TRUE_ADDRESS 4628 is true, always return the address of the containing object even if 4629 the address is not bit-aligned. */ 4630 4631tree 4632remove_conversions (tree exp, bool true_address) 4633{ 4634 switch (TREE_CODE (exp)) 4635 { 4636 case CONSTRUCTOR: 4637 if (true_address 4638 && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE 4639 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp))) 4640 return 4641 remove_conversions ((*CONSTRUCTOR_ELTS (exp))[0].value, true); 4642 break; 4643 4644 case COMPONENT_REF: 4645 if (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0)))) 4646 return remove_conversions (TREE_OPERAND (exp, 0), true_address); 4647 break; 4648 4649 CASE_CONVERT: 4650 case VIEW_CONVERT_EXPR: 4651 case NON_LVALUE_EXPR: 4652 return remove_conversions (TREE_OPERAND (exp, 0), true_address); 4653 4654 default: 4655 break; 4656 } 4657 4658 return exp; 4659} 4660 4661/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that 4662 refers to the underlying array. If it has TYPE_CONTAINS_TEMPLATE_P, 4663 likewise return an expression pointing to the underlying array. */ 4664 4665tree 4666maybe_unconstrained_array (tree exp) 4667{ 4668 enum tree_code code = TREE_CODE (exp); 4669 tree type = TREE_TYPE (exp); 4670 4671 switch (TREE_CODE (type)) 4672 { 4673 case UNCONSTRAINED_ARRAY_TYPE: 4674 if (code == UNCONSTRAINED_ARRAY_REF) 4675 { 4676 const bool read_only = TREE_READONLY (exp); 4677 const bool no_trap = TREE_THIS_NOTRAP (exp); 4678 4679 exp = TREE_OPERAND (exp, 0); 4680 type = TREE_TYPE (exp); 4681 4682 if (TREE_CODE (exp) == COND_EXPR) 4683 { 4684 tree op1 4685 = build_unary_op (INDIRECT_REF, NULL_TREE, 4686 build_component_ref (TREE_OPERAND (exp, 1), 4687 NULL_TREE, 4688 TYPE_FIELDS (type), 4689 false)); 4690 tree op2 4691 = build_unary_op (INDIRECT_REF, NULL_TREE, 4692 build_component_ref (TREE_OPERAND (exp, 2), 4693 NULL_TREE, 4694 TYPE_FIELDS (type), 4695 false)); 4696 4697 exp = build3 (COND_EXPR, 4698 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (type))), 4699 TREE_OPERAND (exp, 0), op1, op2); 4700 } 4701 else 4702 { 4703 exp = build_unary_op (INDIRECT_REF, NULL_TREE, 4704 build_component_ref (exp, NULL_TREE, 4705 TYPE_FIELDS (type), 4706 false)); 4707 TREE_READONLY (exp) = read_only; 4708 TREE_THIS_NOTRAP (exp) = no_trap; 4709 } 4710 } 4711 4712 else if (code == NULL_EXPR) 4713 exp = build1 (NULL_EXPR, 4714 TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))), 4715 TREE_OPERAND (exp, 0)); 4716 break; 4717 4718 case RECORD_TYPE: 4719 /* If this is a padded type and it contains a template, convert to the 4720 unpadded type first. */ 4721 if (TYPE_PADDING_P (type) 4722 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE 4723 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type)))) 4724 { 4725 exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp); 4726 type = TREE_TYPE (exp); 4727 } 4728 4729 if (TYPE_CONTAINS_TEMPLATE_P (type)) 4730 { 4731 exp = build_component_ref (exp, NULL_TREE, 4732 DECL_CHAIN (TYPE_FIELDS (type)), 4733 false); 4734 type = TREE_TYPE (exp); 4735 4736 /* If the array type is padded, convert to the unpadded type. */ 4737 if (TYPE_IS_PADDING_P (type)) 4738 exp = convert (TREE_TYPE (TYPE_FIELDS (type)), exp); 4739 } 4740 break; 4741 4742 default: 4743 break; 4744 } 4745 4746 return exp; 4747} 4748 4749/* Return true if EXPR is an expression that can be folded as an operand 4750 of a VIEW_CONVERT_EXPR. See ada-tree.h for a complete rationale. */ 4751 4752static bool 4753can_fold_for_view_convert_p (tree expr) 4754{ 4755 tree t1, t2; 4756 4757 /* The folder will fold NOP_EXPRs between integral types with the same 4758 precision (in the middle-end's sense). We cannot allow it if the 4759 types don't have the same precision in the Ada sense as well. */ 4760 if (TREE_CODE (expr) != NOP_EXPR) 4761 return true; 4762 4763 t1 = TREE_TYPE (expr); 4764 t2 = TREE_TYPE (TREE_OPERAND (expr, 0)); 4765 4766 /* Defer to the folder for non-integral conversions. */ 4767 if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2))) 4768 return true; 4769 4770 /* Only fold conversions that preserve both precisions. */ 4771 if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2) 4772 && operand_equal_p (rm_size (t1), rm_size (t2), 0)) 4773 return true; 4774 4775 return false; 4776} 4777 4778/* Return an expression that does an unchecked conversion of EXPR to TYPE. 4779 If NOTRUNC_P is true, truncation operations should be suppressed. 4780 4781 Special care is required with (source or target) integral types whose 4782 precision is not equal to their size, to make sure we fetch or assign 4783 the value bits whose location might depend on the endianness, e.g. 4784 4785 Rmsize : constant := 8; 4786 subtype Int is Integer range 0 .. 2 ** Rmsize - 1; 4787 4788 type Bit_Array is array (1 .. Rmsize) of Boolean; 4789 pragma Pack (Bit_Array); 4790 4791 function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array); 4792 4793 Value : Int := 2#1000_0001#; 4794 Vbits : Bit_Array := To_Bit_Array (Value); 4795 4796 we expect the 8 bits at Vbits'Address to always contain Value, while 4797 their original location depends on the endianness, at Value'Address 4798 on a little-endian architecture but not on a big-endian one. */ 4799 4800tree 4801unchecked_convert (tree type, tree expr, bool notrunc_p) 4802{ 4803 tree etype = TREE_TYPE (expr); 4804 enum tree_code ecode = TREE_CODE (etype); 4805 enum tree_code code = TREE_CODE (type); 4806 tree tem; 4807 int c; 4808 4809 /* If the expression is already of the right type, we are done. */ 4810 if (etype == type) 4811 return expr; 4812 4813 /* If both types types are integral just do a normal conversion. 4814 Likewise for a conversion to an unconstrained array. */ 4815 if (((INTEGRAL_TYPE_P (type) 4816 || (POINTER_TYPE_P (type) && !TYPE_IS_THIN_POINTER_P (type)) 4817 || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type))) 4818 && (INTEGRAL_TYPE_P (etype) 4819 || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype)) 4820 || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))) 4821 || code == UNCONSTRAINED_ARRAY_TYPE) 4822 { 4823 if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype)) 4824 { 4825 tree ntype = copy_type (etype); 4826 TYPE_BIASED_REPRESENTATION_P (ntype) = 0; 4827 TYPE_MAIN_VARIANT (ntype) = ntype; 4828 expr = build1 (NOP_EXPR, ntype, expr); 4829 } 4830 4831 if (code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type)) 4832 { 4833 tree rtype = copy_type (type); 4834 TYPE_BIASED_REPRESENTATION_P (rtype) = 0; 4835 TYPE_MAIN_VARIANT (rtype) = rtype; 4836 expr = convert (rtype, expr); 4837 expr = build1 (NOP_EXPR, type, expr); 4838 } 4839 else 4840 expr = convert (type, expr); 4841 } 4842 4843 /* If we are converting to an integral type whose precision is not equal 4844 to its size, first unchecked convert to a record type that contains an 4845 field of the given precision. Then extract the field. */ 4846 else if (INTEGRAL_TYPE_P (type) 4847 && TYPE_RM_SIZE (type) 4848 && 0 != compare_tree_int (TYPE_RM_SIZE (type), 4849 GET_MODE_BITSIZE (TYPE_MODE (type)))) 4850 { 4851 tree rec_type = make_node (RECORD_TYPE); 4852 unsigned HOST_WIDE_INT prec = TREE_INT_CST_LOW (TYPE_RM_SIZE (type)); 4853 tree field_type, field; 4854 4855 if (TYPE_UNSIGNED (type)) 4856 field_type = make_unsigned_type (prec); 4857 else 4858 field_type = make_signed_type (prec); 4859 SET_TYPE_RM_SIZE (field_type, TYPE_RM_SIZE (type)); 4860 4861 field = create_field_decl (get_identifier ("OBJ"), field_type, rec_type, 4862 NULL_TREE, bitsize_zero_node, 1, 0); 4863 4864 finish_record_type (rec_type, field, 1, false); 4865 4866 expr = unchecked_convert (rec_type, expr, notrunc_p); 4867 expr = build_component_ref (expr, NULL_TREE, field, false); 4868 expr = fold_build1 (NOP_EXPR, type, expr); 4869 } 4870 4871 /* Similarly if we are converting from an integral type whose precision is 4872 not equal to its size, first copy into a field of the given precision 4873 and unchecked convert the record type. */ 4874 else if (INTEGRAL_TYPE_P (etype) 4875 && TYPE_RM_SIZE (etype) 4876 && 0 != compare_tree_int (TYPE_RM_SIZE (etype), 4877 GET_MODE_BITSIZE (TYPE_MODE (etype)))) 4878 { 4879 tree rec_type = make_node (RECORD_TYPE); 4880 unsigned HOST_WIDE_INT prec = TREE_INT_CST_LOW (TYPE_RM_SIZE (etype)); 4881 vec<constructor_elt, va_gc> *v; 4882 vec_alloc (v, 1); 4883 tree field_type, field; 4884 4885 if (TYPE_UNSIGNED (etype)) 4886 field_type = make_unsigned_type (prec); 4887 else 4888 field_type = make_signed_type (prec); 4889 SET_TYPE_RM_SIZE (field_type, TYPE_RM_SIZE (etype)); 4890 4891 field = create_field_decl (get_identifier ("OBJ"), field_type, rec_type, 4892 NULL_TREE, bitsize_zero_node, 1, 0); 4893 4894 finish_record_type (rec_type, field, 1, false); 4895 4896 expr = fold_build1 (NOP_EXPR, field_type, expr); 4897 CONSTRUCTOR_APPEND_ELT (v, field, expr); 4898 expr = gnat_build_constructor (rec_type, v); 4899 expr = unchecked_convert (type, expr, notrunc_p); 4900 } 4901 4902 /* If we are converting from a scalar type to a type with a different size, 4903 we need to pad to have the same size on both sides. 4904 4905 ??? We cannot do it unconditionally because unchecked conversions are 4906 used liberally by the front-end to implement polymorphism, e.g. in: 4907 4908 S191s : constant ada__tags__addr_ptr := ada__tags__addr_ptr!(S190s); 4909 return p___size__4 (p__object!(S191s.all)); 4910 4911 so we skip all expressions that are references. */ 4912 else if (!REFERENCE_CLASS_P (expr) 4913 && !AGGREGATE_TYPE_P (etype) 4914 && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST 4915 && (c = tree_int_cst_compare (TYPE_SIZE (etype), TYPE_SIZE (type)))) 4916 { 4917 if (c < 0) 4918 { 4919 expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty, 4920 false, false, false, true), 4921 expr); 4922 expr = unchecked_convert (type, expr, notrunc_p); 4923 } 4924 else 4925 { 4926 tree rec_type = maybe_pad_type (type, TYPE_SIZE (etype), 0, Empty, 4927 false, false, false, true); 4928 expr = unchecked_convert (rec_type, expr, notrunc_p); 4929 expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (rec_type), 4930 false); 4931 } 4932 } 4933 4934 /* We have a special case when we are converting between two unconstrained 4935 array types. In that case, take the address, convert the fat pointer 4936 types, and dereference. */ 4937 else if (ecode == code && code == UNCONSTRAINED_ARRAY_TYPE) 4938 expr = build_unary_op (INDIRECT_REF, NULL_TREE, 4939 build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type), 4940 build_unary_op (ADDR_EXPR, NULL_TREE, 4941 expr))); 4942 4943 /* Another special case is when we are converting to a vector type from its 4944 representative array type; this a regular conversion. */ 4945 else if (code == VECTOR_TYPE 4946 && ecode == ARRAY_TYPE 4947 && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type), 4948 etype)) 4949 expr = convert (type, expr); 4950 4951 /* And, if the array type is not the representative, we try to build an 4952 intermediate vector type of which the array type is the representative 4953 and to do the unchecked conversion between the vector types, in order 4954 to enable further simplifications in the middle-end. */ 4955 else if (code == VECTOR_TYPE 4956 && ecode == ARRAY_TYPE 4957 && (tem = build_vector_type_for_array (etype, NULL_TREE))) 4958 { 4959 expr = convert (tem, expr); 4960 return unchecked_convert (type, expr, notrunc_p); 4961 } 4962 4963 /* If we are converting a CONSTRUCTOR to a more aligned RECORD_TYPE, bump 4964 the alignment of the CONSTRUCTOR to speed up the copy operation. */ 4965 else if (TREE_CODE (expr) == CONSTRUCTOR 4966 && code == RECORD_TYPE 4967 && TYPE_ALIGN (etype) < TYPE_ALIGN (type)) 4968 { 4969 expr = convert (maybe_pad_type (etype, NULL_TREE, TYPE_ALIGN (type), 4970 Empty, false, false, false, true), 4971 expr); 4972 return unchecked_convert (type, expr, notrunc_p); 4973 } 4974 4975 /* Otherwise, just build a VIEW_CONVERT_EXPR of the expression. */ 4976 else 4977 { 4978 expr = maybe_unconstrained_array (expr); 4979 etype = TREE_TYPE (expr); 4980 ecode = TREE_CODE (etype); 4981 if (can_fold_for_view_convert_p (expr)) 4982 expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr); 4983 else 4984 expr = build1 (VIEW_CONVERT_EXPR, type, expr); 4985 } 4986 4987 /* If the result is an integral type whose precision is not equal to its 4988 size, sign- or zero-extend the result. We need not do this if the input 4989 is an integral type of the same precision and signedness or if the output 4990 is a biased type or if both the input and output are unsigned. */ 4991 if (!notrunc_p 4992 && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) 4993 && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type)) 4994 && 0 != compare_tree_int (TYPE_RM_SIZE (type), 4995 GET_MODE_BITSIZE (TYPE_MODE (type))) 4996 && !(INTEGRAL_TYPE_P (etype) 4997 && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype) 4998 && operand_equal_p (TYPE_RM_SIZE (type), 4999 (TYPE_RM_SIZE (etype) != 0 5000 ? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)), 5001 0)) 5002 && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype))) 5003 { 5004 tree base_type 5005 = gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type)); 5006 tree shift_expr 5007 = convert (base_type, 5008 size_binop (MINUS_EXPR, 5009 bitsize_int 5010 (GET_MODE_BITSIZE (TYPE_MODE (type))), 5011 TYPE_RM_SIZE (type))); 5012 expr 5013 = convert (type, 5014 build_binary_op (RSHIFT_EXPR, base_type, 5015 build_binary_op (LSHIFT_EXPR, base_type, 5016 convert (base_type, expr), 5017 shift_expr), 5018 shift_expr)); 5019 } 5020 5021 /* An unchecked conversion should never raise Constraint_Error. The code 5022 below assumes that GCC's conversion routines overflow the same way that 5023 the underlying hardware does. This is probably true. In the rare case 5024 when it is false, we can rely on the fact that such conversions are 5025 erroneous anyway. */ 5026 if (TREE_CODE (expr) == INTEGER_CST) 5027 TREE_OVERFLOW (expr) = 0; 5028 5029 /* If the sizes of the types differ and this is an VIEW_CONVERT_EXPR, 5030 show no longer constant. */ 5031 if (TREE_CODE (expr) == VIEW_CONVERT_EXPR 5032 && !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype), 5033 OEP_ONLY_CONST)) 5034 TREE_CONSTANT (expr) = 0; 5035 5036 return expr; 5037} 5038 5039/* Return the appropriate GCC tree code for the specified GNAT_TYPE, 5040 the latter being a record type as predicated by Is_Record_Type. */ 5041 5042enum tree_code 5043tree_code_for_record_type (Entity_Id gnat_type) 5044{ 5045 Node_Id component_list, component; 5046 5047 /* Return UNION_TYPE if it's an Unchecked_Union whose non-discriminant 5048 fields are all in the variant part. Otherwise, return RECORD_TYPE. */ 5049 if (!Is_Unchecked_Union (gnat_type)) 5050 return RECORD_TYPE; 5051 5052 gnat_type = Implementation_Base_Type (gnat_type); 5053 component_list 5054 = Component_List (Type_Definition (Declaration_Node (gnat_type))); 5055 5056 for (component = First_Non_Pragma (Component_Items (component_list)); 5057 Present (component); 5058 component = Next_Non_Pragma (component)) 5059 if (Ekind (Defining_Entity (component)) == E_Component) 5060 return RECORD_TYPE; 5061 5062 return UNION_TYPE; 5063} 5064 5065/* Return true if GNAT_TYPE is a "double" floating-point type, i.e. whose 5066 size is equal to 64 bits, or an array of such a type. Set ALIGN_CLAUSE 5067 according to the presence of an alignment clause on the type or, if it 5068 is an array, on the component type. */ 5069 5070bool 5071is_double_float_or_array (Entity_Id gnat_type, bool *align_clause) 5072{ 5073 gnat_type = Underlying_Type (gnat_type); 5074 5075 *align_clause = Present (Alignment_Clause (gnat_type)); 5076 5077 if (Is_Array_Type (gnat_type)) 5078 { 5079 gnat_type = Underlying_Type (Component_Type (gnat_type)); 5080 if (Present (Alignment_Clause (gnat_type))) 5081 *align_clause = true; 5082 } 5083 5084 if (!Is_Floating_Point_Type (gnat_type)) 5085 return false; 5086 5087 if (UI_To_Int (Esize (gnat_type)) != 64) 5088 return false; 5089 5090 return true; 5091} 5092 5093/* Return true if GNAT_TYPE is a "double" or larger scalar type, i.e. whose 5094 size is greater or equal to 64 bits, or an array of such a type. Set 5095 ALIGN_CLAUSE according to the presence of an alignment clause on the 5096 type or, if it is an array, on the component type. */ 5097 5098bool 5099is_double_scalar_or_array (Entity_Id gnat_type, bool *align_clause) 5100{ 5101 gnat_type = Underlying_Type (gnat_type); 5102 5103 *align_clause = Present (Alignment_Clause (gnat_type)); 5104 5105 if (Is_Array_Type (gnat_type)) 5106 { 5107 gnat_type = Underlying_Type (Component_Type (gnat_type)); 5108 if (Present (Alignment_Clause (gnat_type))) 5109 *align_clause = true; 5110 } 5111 5112 if (!Is_Scalar_Type (gnat_type)) 5113 return false; 5114 5115 if (UI_To_Int (Esize (gnat_type)) < 64) 5116 return false; 5117 5118 return true; 5119} 5120 5121/* Return true if GNU_TYPE is suitable as the type of a non-aliased 5122 component of an aggregate type. */ 5123 5124bool 5125type_for_nonaliased_component_p (tree gnu_type) 5126{ 5127 /* If the type is passed by reference, we may have pointers to the 5128 component so it cannot be made non-aliased. */ 5129 if (must_pass_by_ref (gnu_type) || default_pass_by_ref (gnu_type)) 5130 return false; 5131 5132 /* We used to say that any component of aggregate type is aliased 5133 because the front-end may take 'Reference of it. The front-end 5134 has been enhanced in the meantime so as to use a renaming instead 5135 in most cases, but the back-end can probably take the address of 5136 such a component too so we go for the conservative stance. 5137 5138 For instance, we might need the address of any array type, even 5139 if normally passed by copy, to construct a fat pointer if the 5140 component is used as an actual for an unconstrained formal. 5141 5142 Likewise for record types: even if a specific record subtype is 5143 passed by copy, the parent type might be passed by ref (e.g. if 5144 it's of variable size) and we might take the address of a child 5145 component to pass to a parent formal. We have no way to check 5146 for such conditions here. */ 5147 if (AGGREGATE_TYPE_P (gnu_type)) 5148 return false; 5149 5150 return true; 5151} 5152 5153/* Return true if TYPE is a smaller form of ORIG_TYPE. */ 5154 5155bool 5156smaller_form_type_p (tree type, tree orig_type) 5157{ 5158 tree size, osize; 5159 5160 /* We're not interested in variants here. */ 5161 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (orig_type)) 5162 return false; 5163 5164 /* Like a variant, a packable version keeps the original TYPE_NAME. */ 5165 if (TYPE_NAME (type) != TYPE_NAME (orig_type)) 5166 return false; 5167 5168 size = TYPE_SIZE (type); 5169 osize = TYPE_SIZE (orig_type); 5170 5171 if (!(TREE_CODE (size) == INTEGER_CST && TREE_CODE (osize) == INTEGER_CST)) 5172 return false; 5173 5174 return tree_int_cst_lt (size, osize) != 0; 5175} 5176 5177/* Perform final processing on global variables. */ 5178 5179static GTY (()) tree dummy_global; 5180 5181void 5182gnat_write_global_declarations (void) 5183{ 5184 unsigned int i; 5185 tree iter; 5186 5187 /* If we have declared types as used at the global level, insert them in 5188 the global hash table. We use a dummy variable for this purpose. */ 5189 if (types_used_by_cur_var_decl && !types_used_by_cur_var_decl->is_empty ()) 5190 { 5191 struct varpool_node *node; 5192 char *label; 5193 5194 ASM_FORMAT_PRIVATE_NAME (label, first_global_object_name, 0); 5195 dummy_global 5196 = build_decl (BUILTINS_LOCATION, VAR_DECL, get_identifier (label), 5197 void_type_node); 5198 DECL_HARD_REGISTER (dummy_global) = 1; 5199 TREE_STATIC (dummy_global) = 1; 5200 node = varpool_node::get_create (dummy_global); 5201 node->definition = 1; 5202 node->force_output = 1; 5203 5204 while (!types_used_by_cur_var_decl->is_empty ()) 5205 { 5206 tree t = types_used_by_cur_var_decl->pop (); 5207 types_used_by_var_decl_insert (t, dummy_global); 5208 } 5209 } 5210 5211 /* Output debug information for all global type declarations first. This 5212 ensures that global types whose compilation hasn't been finalized yet, 5213 for example pointers to Taft amendment types, have their compilation 5214 finalized in the right context. */ 5215 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) 5216 if (TREE_CODE (iter) == TYPE_DECL && !DECL_IGNORED_P (iter)) 5217 debug_hooks->global_decl (iter); 5218 5219 /* Proceed to optimize and emit assembly. */ 5220 symtab->finalize_compilation_unit (); 5221 5222 /* After cgraph has had a chance to emit everything that's going to 5223 be emitted, output debug information for the rest of globals. */ 5224 if (!seen_error ()) 5225 { 5226 timevar_push (TV_SYMOUT); 5227 FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) 5228 if (TREE_CODE (iter) != TYPE_DECL && !DECL_IGNORED_P (iter)) 5229 debug_hooks->global_decl (iter); 5230 timevar_pop (TV_SYMOUT); 5231 } 5232} 5233 5234/* ************************************************************************ 5235 * * GCC builtins support * 5236 * ************************************************************************ */ 5237 5238/* The general scheme is fairly simple: 5239 5240 For each builtin function/type to be declared, gnat_install_builtins calls 5241 internal facilities which eventually get to gnat_pushdecl, which in turn 5242 tracks the so declared builtin function decls in the 'builtin_decls' global 5243 datastructure. When an Intrinsic subprogram declaration is processed, we 5244 search this global datastructure to retrieve the associated BUILT_IN DECL 5245 node. */ 5246 5247/* Search the chain of currently available builtin declarations for a node 5248 corresponding to function NAME (an IDENTIFIER_NODE). Return the first node 5249 found, if any, or NULL_TREE otherwise. */ 5250tree 5251builtin_decl_for (tree name) 5252{ 5253 unsigned i; 5254 tree decl; 5255 5256 FOR_EACH_VEC_SAFE_ELT (builtin_decls, i, decl) 5257 if (DECL_NAME (decl) == name) 5258 return decl; 5259 5260 return NULL_TREE; 5261} 5262 5263/* The code below eventually exposes gnat_install_builtins, which declares 5264 the builtin types and functions we might need, either internally or as 5265 user accessible facilities. 5266 5267 ??? This is a first implementation shot, still in rough shape. It is 5268 heavily inspired from the "C" family implementation, with chunks copied 5269 verbatim from there. 5270 5271 Two obvious TODO candidates are 5272 o Use a more efficient name/decl mapping scheme 5273 o Devise a middle-end infrastructure to avoid having to copy 5274 pieces between front-ends. */ 5275 5276/* ----------------------------------------------------------------------- * 5277 * BUILTIN ELEMENTARY TYPES * 5278 * ----------------------------------------------------------------------- */ 5279 5280/* Standard data types to be used in builtin argument declarations. */ 5281 5282enum c_tree_index 5283{ 5284 CTI_SIGNED_SIZE_TYPE, /* For format checking only. */ 5285 CTI_STRING_TYPE, 5286 CTI_CONST_STRING_TYPE, 5287 5288 CTI_MAX 5289}; 5290 5291static tree c_global_trees[CTI_MAX]; 5292 5293#define signed_size_type_node c_global_trees[CTI_SIGNED_SIZE_TYPE] 5294#define string_type_node c_global_trees[CTI_STRING_TYPE] 5295#define const_string_type_node c_global_trees[CTI_CONST_STRING_TYPE] 5296 5297/* ??? In addition some attribute handlers, we currently don't support a 5298 (small) number of builtin-types, which in turns inhibits support for a 5299 number of builtin functions. */ 5300#define wint_type_node void_type_node 5301#define intmax_type_node void_type_node 5302#define uintmax_type_node void_type_node 5303 5304/* Build the void_list_node (void_type_node having been created). */ 5305 5306static tree 5307build_void_list_node (void) 5308{ 5309 tree t = build_tree_list (NULL_TREE, void_type_node); 5310 return t; 5311} 5312 5313/* Used to help initialize the builtin-types.def table. When a type of 5314 the correct size doesn't exist, use error_mark_node instead of NULL. 5315 The later results in segfaults even when a decl using the type doesn't 5316 get invoked. */ 5317 5318static tree 5319builtin_type_for_size (int size, bool unsignedp) 5320{ 5321 tree type = gnat_type_for_size (size, unsignedp); 5322 return type ? type : error_mark_node; 5323} 5324 5325/* Build/push the elementary type decls that builtin functions/types 5326 will need. */ 5327 5328static void 5329install_builtin_elementary_types (void) 5330{ 5331 signed_size_type_node = gnat_signed_type (size_type_node); 5332 pid_type_node = integer_type_node; 5333 void_list_node = build_void_list_node (); 5334 5335 string_type_node = build_pointer_type (char_type_node); 5336 const_string_type_node 5337 = build_pointer_type (build_qualified_type 5338 (char_type_node, TYPE_QUAL_CONST)); 5339} 5340 5341/* ----------------------------------------------------------------------- * 5342 * BUILTIN FUNCTION TYPES * 5343 * ----------------------------------------------------------------------- */ 5344 5345/* Now, builtin function types per se. */ 5346 5347enum c_builtin_type 5348{ 5349#define DEF_PRIMITIVE_TYPE(NAME, VALUE) NAME, 5350#define DEF_FUNCTION_TYPE_0(NAME, RETURN) NAME, 5351#define DEF_FUNCTION_TYPE_1(NAME, RETURN, ARG1) NAME, 5352#define DEF_FUNCTION_TYPE_2(NAME, RETURN, ARG1, ARG2) NAME, 5353#define DEF_FUNCTION_TYPE_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, 5354#define DEF_FUNCTION_TYPE_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, 5355#define DEF_FUNCTION_TYPE_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) NAME, 5356#define DEF_FUNCTION_TYPE_6(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5357 ARG6) NAME, 5358#define DEF_FUNCTION_TYPE_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5359 ARG6, ARG7) NAME, 5360#define DEF_FUNCTION_TYPE_8(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5361 ARG6, ARG7, ARG8) NAME, 5362#define DEF_FUNCTION_TYPE_VAR_0(NAME, RETURN) NAME, 5363#define DEF_FUNCTION_TYPE_VAR_1(NAME, RETURN, ARG1) NAME, 5364#define DEF_FUNCTION_TYPE_VAR_2(NAME, RETURN, ARG1, ARG2) NAME, 5365#define DEF_FUNCTION_TYPE_VAR_3(NAME, RETURN, ARG1, ARG2, ARG3) NAME, 5366#define DEF_FUNCTION_TYPE_VAR_4(NAME, RETURN, ARG1, ARG2, ARG3, ARG4) NAME, 5367#define DEF_FUNCTION_TYPE_VAR_5(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ 5368 NAME, 5369#define DEF_FUNCTION_TYPE_VAR_7(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5370 ARG6, ARG7) NAME, 5371#define DEF_FUNCTION_TYPE_VAR_11(NAME, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5372 ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) NAME, 5373#define DEF_POINTER_TYPE(NAME, TYPE) NAME, 5374#include "builtin-types.def" 5375#undef DEF_PRIMITIVE_TYPE 5376#undef DEF_FUNCTION_TYPE_0 5377#undef DEF_FUNCTION_TYPE_1 5378#undef DEF_FUNCTION_TYPE_2 5379#undef DEF_FUNCTION_TYPE_3 5380#undef DEF_FUNCTION_TYPE_4 5381#undef DEF_FUNCTION_TYPE_5 5382#undef DEF_FUNCTION_TYPE_6 5383#undef DEF_FUNCTION_TYPE_7 5384#undef DEF_FUNCTION_TYPE_8 5385#undef DEF_FUNCTION_TYPE_VAR_0 5386#undef DEF_FUNCTION_TYPE_VAR_1 5387#undef DEF_FUNCTION_TYPE_VAR_2 5388#undef DEF_FUNCTION_TYPE_VAR_3 5389#undef DEF_FUNCTION_TYPE_VAR_4 5390#undef DEF_FUNCTION_TYPE_VAR_5 5391#undef DEF_FUNCTION_TYPE_VAR_7 5392#undef DEF_FUNCTION_TYPE_VAR_11 5393#undef DEF_POINTER_TYPE 5394 BT_LAST 5395}; 5396 5397typedef enum c_builtin_type builtin_type; 5398 5399/* A temporary array used in communication with def_fn_type. */ 5400static GTY(()) tree builtin_types[(int) BT_LAST + 1]; 5401 5402/* A helper function for install_builtin_types. Build function type 5403 for DEF with return type RET and N arguments. If VAR is true, then the 5404 function should be variadic after those N arguments. 5405 5406 Takes special care not to ICE if any of the types involved are 5407 error_mark_node, which indicates that said type is not in fact available 5408 (see builtin_type_for_size). In which case the function type as a whole 5409 should be error_mark_node. */ 5410 5411static void 5412def_fn_type (builtin_type def, builtin_type ret, bool var, int n, ...) 5413{ 5414 tree t; 5415 tree *args = XALLOCAVEC (tree, n); 5416 va_list list; 5417 int i; 5418 5419 va_start (list, n); 5420 for (i = 0; i < n; ++i) 5421 { 5422 builtin_type a = (builtin_type) va_arg (list, int); 5423 t = builtin_types[a]; 5424 if (t == error_mark_node) 5425 goto egress; 5426 args[i] = t; 5427 } 5428 5429 t = builtin_types[ret]; 5430 if (t == error_mark_node) 5431 goto egress; 5432 if (var) 5433 t = build_varargs_function_type_array (t, n, args); 5434 else 5435 t = build_function_type_array (t, n, args); 5436 5437 egress: 5438 builtin_types[def] = t; 5439 va_end (list); 5440} 5441 5442/* Build the builtin function types and install them in the builtin_types 5443 array for later use in builtin function decls. */ 5444 5445static void 5446install_builtin_function_types (void) 5447{ 5448 tree va_list_ref_type_node; 5449 tree va_list_arg_type_node; 5450 5451 if (TREE_CODE (va_list_type_node) == ARRAY_TYPE) 5452 { 5453 va_list_arg_type_node = va_list_ref_type_node = 5454 build_pointer_type (TREE_TYPE (va_list_type_node)); 5455 } 5456 else 5457 { 5458 va_list_arg_type_node = va_list_type_node; 5459 va_list_ref_type_node = build_reference_type (va_list_type_node); 5460 } 5461 5462#define DEF_PRIMITIVE_TYPE(ENUM, VALUE) \ 5463 builtin_types[ENUM] = VALUE; 5464#define DEF_FUNCTION_TYPE_0(ENUM, RETURN) \ 5465 def_fn_type (ENUM, RETURN, 0, 0); 5466#define DEF_FUNCTION_TYPE_1(ENUM, RETURN, ARG1) \ 5467 def_fn_type (ENUM, RETURN, 0, 1, ARG1); 5468#define DEF_FUNCTION_TYPE_2(ENUM, RETURN, ARG1, ARG2) \ 5469 def_fn_type (ENUM, RETURN, 0, 2, ARG1, ARG2); 5470#define DEF_FUNCTION_TYPE_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ 5471 def_fn_type (ENUM, RETURN, 0, 3, ARG1, ARG2, ARG3); 5472#define DEF_FUNCTION_TYPE_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ 5473 def_fn_type (ENUM, RETURN, 0, 4, ARG1, ARG2, ARG3, ARG4); 5474#define DEF_FUNCTION_TYPE_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ 5475 def_fn_type (ENUM, RETURN, 0, 5, ARG1, ARG2, ARG3, ARG4, ARG5); 5476#define DEF_FUNCTION_TYPE_6(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5477 ARG6) \ 5478 def_fn_type (ENUM, RETURN, 0, 6, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6); 5479#define DEF_FUNCTION_TYPE_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5480 ARG6, ARG7) \ 5481 def_fn_type (ENUM, RETURN, 0, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7); 5482#define DEF_FUNCTION_TYPE_8(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5483 ARG6, ARG7, ARG8) \ 5484 def_fn_type (ENUM, RETURN, 0, 8, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \ 5485 ARG7, ARG8); 5486#define DEF_FUNCTION_TYPE_VAR_0(ENUM, RETURN) \ 5487 def_fn_type (ENUM, RETURN, 1, 0); 5488#define DEF_FUNCTION_TYPE_VAR_1(ENUM, RETURN, ARG1) \ 5489 def_fn_type (ENUM, RETURN, 1, 1, ARG1); 5490#define DEF_FUNCTION_TYPE_VAR_2(ENUM, RETURN, ARG1, ARG2) \ 5491 def_fn_type (ENUM, RETURN, 1, 2, ARG1, ARG2); 5492#define DEF_FUNCTION_TYPE_VAR_3(ENUM, RETURN, ARG1, ARG2, ARG3) \ 5493 def_fn_type (ENUM, RETURN, 1, 3, ARG1, ARG2, ARG3); 5494#define DEF_FUNCTION_TYPE_VAR_4(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4) \ 5495 def_fn_type (ENUM, RETURN, 1, 4, ARG1, ARG2, ARG3, ARG4); 5496#define DEF_FUNCTION_TYPE_VAR_5(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5) \ 5497 def_fn_type (ENUM, RETURN, 1, 5, ARG1, ARG2, ARG3, ARG4, ARG5); 5498#define DEF_FUNCTION_TYPE_VAR_7(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5499 ARG6, ARG7) \ 5500 def_fn_type (ENUM, RETURN, 1, 7, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, ARG7); 5501#define DEF_FUNCTION_TYPE_VAR_11(ENUM, RETURN, ARG1, ARG2, ARG3, ARG4, ARG5, \ 5502 ARG6, ARG7, ARG8, ARG9, ARG10, ARG11) \ 5503 def_fn_type (ENUM, RETURN, 1, 11, ARG1, ARG2, ARG3, ARG4, ARG5, ARG6, \ 5504 ARG7, ARG8, ARG9, ARG10, ARG11); 5505#define DEF_POINTER_TYPE(ENUM, TYPE) \ 5506 builtin_types[(int) ENUM] = build_pointer_type (builtin_types[(int) TYPE]); 5507 5508#include "builtin-types.def" 5509 5510#undef DEF_PRIMITIVE_TYPE 5511#undef DEF_FUNCTION_TYPE_0 5512#undef DEF_FUNCTION_TYPE_1 5513#undef DEF_FUNCTION_TYPE_2 5514#undef DEF_FUNCTION_TYPE_3 5515#undef DEF_FUNCTION_TYPE_4 5516#undef DEF_FUNCTION_TYPE_5 5517#undef DEF_FUNCTION_TYPE_6 5518#undef DEF_FUNCTION_TYPE_7 5519#undef DEF_FUNCTION_TYPE_8 5520#undef DEF_FUNCTION_TYPE_VAR_0 5521#undef DEF_FUNCTION_TYPE_VAR_1 5522#undef DEF_FUNCTION_TYPE_VAR_2 5523#undef DEF_FUNCTION_TYPE_VAR_3 5524#undef DEF_FUNCTION_TYPE_VAR_4 5525#undef DEF_FUNCTION_TYPE_VAR_5 5526#undef DEF_FUNCTION_TYPE_VAR_7 5527#undef DEF_FUNCTION_TYPE_VAR_11 5528#undef DEF_POINTER_TYPE 5529 builtin_types[(int) BT_LAST] = NULL_TREE; 5530} 5531 5532/* ----------------------------------------------------------------------- * 5533 * BUILTIN ATTRIBUTES * 5534 * ----------------------------------------------------------------------- */ 5535 5536enum built_in_attribute 5537{ 5538#define DEF_ATTR_NULL_TREE(ENUM) ENUM, 5539#define DEF_ATTR_INT(ENUM, VALUE) ENUM, 5540#define DEF_ATTR_STRING(ENUM, VALUE) ENUM, 5541#define DEF_ATTR_IDENT(ENUM, STRING) ENUM, 5542#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) ENUM, 5543#include "builtin-attrs.def" 5544#undef DEF_ATTR_NULL_TREE 5545#undef DEF_ATTR_INT 5546#undef DEF_ATTR_STRING 5547#undef DEF_ATTR_IDENT 5548#undef DEF_ATTR_TREE_LIST 5549 ATTR_LAST 5550}; 5551 5552static GTY(()) tree built_in_attributes[(int) ATTR_LAST]; 5553 5554static void 5555install_builtin_attributes (void) 5556{ 5557 /* Fill in the built_in_attributes array. */ 5558#define DEF_ATTR_NULL_TREE(ENUM) \ 5559 built_in_attributes[(int) ENUM] = NULL_TREE; 5560#define DEF_ATTR_INT(ENUM, VALUE) \ 5561 built_in_attributes[(int) ENUM] = build_int_cst (NULL_TREE, VALUE); 5562#define DEF_ATTR_STRING(ENUM, VALUE) \ 5563 built_in_attributes[(int) ENUM] = build_string (strlen (VALUE), VALUE); 5564#define DEF_ATTR_IDENT(ENUM, STRING) \ 5565 built_in_attributes[(int) ENUM] = get_identifier (STRING); 5566#define DEF_ATTR_TREE_LIST(ENUM, PURPOSE, VALUE, CHAIN) \ 5567 built_in_attributes[(int) ENUM] \ 5568 = tree_cons (built_in_attributes[(int) PURPOSE], \ 5569 built_in_attributes[(int) VALUE], \ 5570 built_in_attributes[(int) CHAIN]); 5571#include "builtin-attrs.def" 5572#undef DEF_ATTR_NULL_TREE 5573#undef DEF_ATTR_INT 5574#undef DEF_ATTR_STRING 5575#undef DEF_ATTR_IDENT 5576#undef DEF_ATTR_TREE_LIST 5577} 5578 5579/* Handle a "const" attribute; arguments as in 5580 struct attribute_spec.handler. */ 5581 5582static tree 5583handle_const_attribute (tree *node, tree ARG_UNUSED (name), 5584 tree ARG_UNUSED (args), int ARG_UNUSED (flags), 5585 bool *no_add_attrs) 5586{ 5587 if (TREE_CODE (*node) == FUNCTION_DECL) 5588 TREE_READONLY (*node) = 1; 5589 else 5590 *no_add_attrs = true; 5591 5592 return NULL_TREE; 5593} 5594 5595/* Handle a "nothrow" attribute; arguments as in 5596 struct attribute_spec.handler. */ 5597 5598static tree 5599handle_nothrow_attribute (tree *node, tree ARG_UNUSED (name), 5600 tree ARG_UNUSED (args), int ARG_UNUSED (flags), 5601 bool *no_add_attrs) 5602{ 5603 if (TREE_CODE (*node) == FUNCTION_DECL) 5604 TREE_NOTHROW (*node) = 1; 5605 else 5606 *no_add_attrs = true; 5607 5608 return NULL_TREE; 5609} 5610 5611/* Handle a "pure" attribute; arguments as in 5612 struct attribute_spec.handler. */ 5613 5614static tree 5615handle_pure_attribute (tree *node, tree name, tree ARG_UNUSED (args), 5616 int ARG_UNUSED (flags), bool *no_add_attrs) 5617{ 5618 if (TREE_CODE (*node) == FUNCTION_DECL) 5619 DECL_PURE_P (*node) = 1; 5620 /* ??? TODO: Support types. */ 5621 else 5622 { 5623 warning (OPT_Wattributes, "%qs attribute ignored", 5624 IDENTIFIER_POINTER (name)); 5625 *no_add_attrs = true; 5626 } 5627 5628 return NULL_TREE; 5629} 5630 5631/* Handle a "no vops" attribute; arguments as in 5632 struct attribute_spec.handler. */ 5633 5634static tree 5635handle_novops_attribute (tree *node, tree ARG_UNUSED (name), 5636 tree ARG_UNUSED (args), int ARG_UNUSED (flags), 5637 bool *ARG_UNUSED (no_add_attrs)) 5638{ 5639 gcc_assert (TREE_CODE (*node) == FUNCTION_DECL); 5640 DECL_IS_NOVOPS (*node) = 1; 5641 return NULL_TREE; 5642} 5643 5644/* Helper for nonnull attribute handling; fetch the operand number 5645 from the attribute argument list. */ 5646 5647static bool 5648get_nonnull_operand (tree arg_num_expr, unsigned HOST_WIDE_INT *valp) 5649{ 5650 /* Verify the arg number is a constant. */ 5651 if (!tree_fits_uhwi_p (arg_num_expr)) 5652 return false; 5653 5654 *valp = TREE_INT_CST_LOW (arg_num_expr); 5655 return true; 5656} 5657 5658/* Handle the "nonnull" attribute. */ 5659static tree 5660handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name), 5661 tree args, int ARG_UNUSED (flags), 5662 bool *no_add_attrs) 5663{ 5664 tree type = *node; 5665 unsigned HOST_WIDE_INT attr_arg_num; 5666 5667 /* If no arguments are specified, all pointer arguments should be 5668 non-null. Verify a full prototype is given so that the arguments 5669 will have the correct types when we actually check them later. */ 5670 if (!args) 5671 { 5672 if (!prototype_p (type)) 5673 { 5674 error ("nonnull attribute without arguments on a non-prototype"); 5675 *no_add_attrs = true; 5676 } 5677 return NULL_TREE; 5678 } 5679 5680 /* Argument list specified. Verify that each argument number references 5681 a pointer argument. */ 5682 for (attr_arg_num = 1; args; args = TREE_CHAIN (args)) 5683 { 5684 unsigned HOST_WIDE_INT arg_num = 0, ck_num; 5685 5686 if (!get_nonnull_operand (TREE_VALUE (args), &arg_num)) 5687 { 5688 error ("nonnull argument has invalid operand number (argument %lu)", 5689 (unsigned long) attr_arg_num); 5690 *no_add_attrs = true; 5691 return NULL_TREE; 5692 } 5693 5694 if (prototype_p (type)) 5695 { 5696 function_args_iterator iter; 5697 tree argument; 5698 5699 function_args_iter_init (&iter, type); 5700 for (ck_num = 1; ; ck_num++, function_args_iter_next (&iter)) 5701 { 5702 argument = function_args_iter_cond (&iter); 5703 if (!argument || ck_num == arg_num) 5704 break; 5705 } 5706 5707 if (!argument 5708 || TREE_CODE (argument) == VOID_TYPE) 5709 { 5710 error ("nonnull argument with out-of-range operand number " 5711 "(argument %lu, operand %lu)", 5712 (unsigned long) attr_arg_num, (unsigned long) arg_num); 5713 *no_add_attrs = true; 5714 return NULL_TREE; 5715 } 5716 5717 if (TREE_CODE (argument) != POINTER_TYPE) 5718 { 5719 error ("nonnull argument references non-pointer operand " 5720 "(argument %lu, operand %lu)", 5721 (unsigned long) attr_arg_num, (unsigned long) arg_num); 5722 *no_add_attrs = true; 5723 return NULL_TREE; 5724 } 5725 } 5726 } 5727 5728 return NULL_TREE; 5729} 5730 5731/* Handle a "sentinel" attribute. */ 5732 5733static tree 5734handle_sentinel_attribute (tree *node, tree name, tree args, 5735 int ARG_UNUSED (flags), bool *no_add_attrs) 5736{ 5737 if (!prototype_p (*node)) 5738 { 5739 warning (OPT_Wattributes, 5740 "%qs attribute requires prototypes with named arguments", 5741 IDENTIFIER_POINTER (name)); 5742 *no_add_attrs = true; 5743 } 5744 else 5745 { 5746 if (!stdarg_p (*node)) 5747 { 5748 warning (OPT_Wattributes, 5749 "%qs attribute only applies to variadic functions", 5750 IDENTIFIER_POINTER (name)); 5751 *no_add_attrs = true; 5752 } 5753 } 5754 5755 if (args) 5756 { 5757 tree position = TREE_VALUE (args); 5758 5759 if (TREE_CODE (position) != INTEGER_CST) 5760 { 5761 warning (0, "requested position is not an integer constant"); 5762 *no_add_attrs = true; 5763 } 5764 else 5765 { 5766 if (tree_int_cst_lt (position, integer_zero_node)) 5767 { 5768 warning (0, "requested position is less than zero"); 5769 *no_add_attrs = true; 5770 } 5771 } 5772 } 5773 5774 return NULL_TREE; 5775} 5776 5777/* Handle a "noreturn" attribute; arguments as in 5778 struct attribute_spec.handler. */ 5779 5780static tree 5781handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args), 5782 int ARG_UNUSED (flags), bool *no_add_attrs) 5783{ 5784 tree type = TREE_TYPE (*node); 5785 5786 /* See FIXME comment in c_common_attribute_table. */ 5787 if (TREE_CODE (*node) == FUNCTION_DECL) 5788 TREE_THIS_VOLATILE (*node) = 1; 5789 else if (TREE_CODE (type) == POINTER_TYPE 5790 && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) 5791 TREE_TYPE (*node) 5792 = build_pointer_type 5793 (build_type_variant (TREE_TYPE (type), 5794 TYPE_READONLY (TREE_TYPE (type)), 1)); 5795 else 5796 { 5797 warning (OPT_Wattributes, "%qs attribute ignored", 5798 IDENTIFIER_POINTER (name)); 5799 *no_add_attrs = true; 5800 } 5801 5802 return NULL_TREE; 5803} 5804 5805/* Handle a "leaf" attribute; arguments as in 5806 struct attribute_spec.handler. */ 5807 5808static tree 5809handle_leaf_attribute (tree *node, tree name, tree ARG_UNUSED (args), 5810 int ARG_UNUSED (flags), bool *no_add_attrs) 5811{ 5812 if (TREE_CODE (*node) != FUNCTION_DECL) 5813 { 5814 warning (OPT_Wattributes, "%qE attribute ignored", name); 5815 *no_add_attrs = true; 5816 } 5817 if (!TREE_PUBLIC (*node)) 5818 { 5819 warning (OPT_Wattributes, "%qE attribute has no effect", name); 5820 *no_add_attrs = true; 5821 } 5822 5823 return NULL_TREE; 5824} 5825 5826/* Handle a "always_inline" attribute; arguments as in 5827 struct attribute_spec.handler. */ 5828 5829static tree 5830handle_always_inline_attribute (tree *node, tree name, tree ARG_UNUSED (args), 5831 int ARG_UNUSED (flags), bool *no_add_attrs) 5832{ 5833 if (TREE_CODE (*node) == FUNCTION_DECL) 5834 { 5835 /* Set the attribute and mark it for disregarding inline limits. */ 5836 DECL_DISREGARD_INLINE_LIMITS (*node) = 1; 5837 } 5838 else 5839 { 5840 warning (OPT_Wattributes, "%qE attribute ignored", name); 5841 *no_add_attrs = true; 5842 } 5843 5844 return NULL_TREE; 5845} 5846 5847/* Handle a "malloc" attribute; arguments as in 5848 struct attribute_spec.handler. */ 5849 5850static tree 5851handle_malloc_attribute (tree *node, tree name, tree ARG_UNUSED (args), 5852 int ARG_UNUSED (flags), bool *no_add_attrs) 5853{ 5854 if (TREE_CODE (*node) == FUNCTION_DECL 5855 && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (*node)))) 5856 DECL_IS_MALLOC (*node) = 1; 5857 else 5858 { 5859 warning (OPT_Wattributes, "%qs attribute ignored", 5860 IDENTIFIER_POINTER (name)); 5861 *no_add_attrs = true; 5862 } 5863 5864 return NULL_TREE; 5865} 5866 5867/* Fake handler for attributes we don't properly support. */ 5868 5869tree 5870fake_attribute_handler (tree * ARG_UNUSED (node), 5871 tree ARG_UNUSED (name), 5872 tree ARG_UNUSED (args), 5873 int ARG_UNUSED (flags), 5874 bool * ARG_UNUSED (no_add_attrs)) 5875{ 5876 return NULL_TREE; 5877} 5878 5879/* Handle a "type_generic" attribute. */ 5880 5881static tree 5882handle_type_generic_attribute (tree *node, tree ARG_UNUSED (name), 5883 tree ARG_UNUSED (args), int ARG_UNUSED (flags), 5884 bool * ARG_UNUSED (no_add_attrs)) 5885{ 5886 /* Ensure we have a function type. */ 5887 gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE); 5888 5889 /* Ensure we have a variadic function. */ 5890 gcc_assert (!prototype_p (*node) || stdarg_p (*node)); 5891 5892 return NULL_TREE; 5893} 5894 5895/* Handle a "vector_size" attribute; arguments as in 5896 struct attribute_spec.handler. */ 5897 5898static tree 5899handle_vector_size_attribute (tree *node, tree name, tree args, 5900 int ARG_UNUSED (flags), bool *no_add_attrs) 5901{ 5902 tree type = *node; 5903 tree vector_type; 5904 5905 *no_add_attrs = true; 5906 5907 /* We need to provide for vector pointers, vector arrays, and 5908 functions returning vectors. For example: 5909 5910 __attribute__((vector_size(16))) short *foo; 5911 5912 In this case, the mode is SI, but the type being modified is 5913 HI, so we need to look further. */ 5914 while (POINTER_TYPE_P (type) 5915 || TREE_CODE (type) == FUNCTION_TYPE 5916 || TREE_CODE (type) == ARRAY_TYPE) 5917 type = TREE_TYPE (type); 5918 5919 vector_type = build_vector_type_for_size (type, TREE_VALUE (args), name); 5920 if (!vector_type) 5921 return NULL_TREE; 5922 5923 /* Build back pointers if needed. */ 5924 *node = reconstruct_complex_type (*node, vector_type); 5925 5926 return NULL_TREE; 5927} 5928 5929/* Handle a "vector_type" attribute; arguments as in 5930 struct attribute_spec.handler. */ 5931 5932static tree 5933handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args), 5934 int ARG_UNUSED (flags), bool *no_add_attrs) 5935{ 5936 tree type = *node; 5937 tree vector_type; 5938 5939 *no_add_attrs = true; 5940 5941 if (TREE_CODE (type) != ARRAY_TYPE) 5942 { 5943 error ("attribute %qs applies to array types only", 5944 IDENTIFIER_POINTER (name)); 5945 return NULL_TREE; 5946 } 5947 5948 vector_type = build_vector_type_for_array (type, name); 5949 if (!vector_type) 5950 return NULL_TREE; 5951 5952 TYPE_REPRESENTATIVE_ARRAY (vector_type) = type; 5953 *node = vector_type; 5954 5955 return NULL_TREE; 5956} 5957 5958/* ----------------------------------------------------------------------- * 5959 * BUILTIN FUNCTIONS * 5960 * ----------------------------------------------------------------------- */ 5961 5962/* Worker for DEF_BUILTIN. Possibly define a builtin function with one or two 5963 names. Does not declare a non-__builtin_ function if flag_no_builtin, or 5964 if nonansi_p and flag_no_nonansi_builtin. */ 5965 5966static void 5967def_builtin_1 (enum built_in_function fncode, 5968 const char *name, 5969 enum built_in_class fnclass, 5970 tree fntype, tree libtype, 5971 bool both_p, bool fallback_p, 5972 bool nonansi_p ATTRIBUTE_UNUSED, 5973 tree fnattrs, bool implicit_p) 5974{ 5975 tree decl; 5976 const char *libname; 5977 5978 /* Preserve an already installed decl. It most likely was setup in advance 5979 (e.g. as part of the internal builtins) for specific reasons. */ 5980 if (builtin_decl_explicit (fncode) != NULL_TREE) 5981 return; 5982 5983 gcc_assert ((!both_p && !fallback_p) 5984 || !strncmp (name, "__builtin_", 5985 strlen ("__builtin_"))); 5986 5987 libname = name + strlen ("__builtin_"); 5988 decl = add_builtin_function (name, fntype, fncode, fnclass, 5989 (fallback_p ? libname : NULL), 5990 fnattrs); 5991 if (both_p) 5992 /* ??? This is normally further controlled by command-line options 5993 like -fno-builtin, but we don't have them for Ada. */ 5994 add_builtin_function (libname, libtype, fncode, fnclass, 5995 NULL, fnattrs); 5996 5997 set_builtin_decl (fncode, decl, implicit_p); 5998} 5999 6000static int flag_isoc94 = 0; 6001static int flag_isoc99 = 0; 6002static int flag_isoc11 = 0; 6003 6004/* Install what the common builtins.def offers. */ 6005 6006static void 6007install_builtin_functions (void) 6008{ 6009#define DEF_BUILTIN(ENUM, NAME, CLASS, TYPE, LIBTYPE, BOTH_P, FALLBACK_P, \ 6010 NONANSI_P, ATTRS, IMPLICIT, COND) \ 6011 if (NAME && COND) \ 6012 def_builtin_1 (ENUM, NAME, CLASS, \ 6013 builtin_types[(int) TYPE], \ 6014 builtin_types[(int) LIBTYPE], \ 6015 BOTH_P, FALLBACK_P, NONANSI_P, \ 6016 built_in_attributes[(int) ATTRS], IMPLICIT); 6017#include "builtins.def" 6018#undef DEF_BUILTIN 6019} 6020 6021/* ----------------------------------------------------------------------- * 6022 * BUILTIN FUNCTIONS * 6023 * ----------------------------------------------------------------------- */ 6024 6025/* Install the builtin functions we might need. */ 6026 6027void 6028gnat_install_builtins (void) 6029{ 6030 install_builtin_elementary_types (); 6031 install_builtin_function_types (); 6032 install_builtin_attributes (); 6033 6034 /* Install builtins used by generic middle-end pieces first. Some of these 6035 know about internal specificities and control attributes accordingly, for 6036 instance __builtin_alloca vs no-throw and -fstack-check. We will ignore 6037 the generic definition from builtins.def. */ 6038 build_common_builtin_nodes (); 6039 6040 /* Now, install the target specific builtins, such as the AltiVec family on 6041 ppc, and the common set as exposed by builtins.def. */ 6042 targetm.init_builtins (); 6043 install_builtin_functions (); 6044} 6045 6046#include "gt-ada-utils.h" 6047#include "gtype-ada.h" 6048