1 /**************************************************************************** 2 * * 3 * GNAT COMPILER COMPONENTS * 4 * * 5 * D E C L * 6 * * 7 * C Implementation File * 8 * * 9 * Copyright (C) 1992-2004, Free Software Foundation, Inc. * 10 * * 11 * GNAT is free software; you can redistribute it and/or modify it under * 12 * terms of the GNU General Public License as published by the Free Soft- * 13 * ware Foundation; either version 2, or (at your option) any later ver- * 14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- * 15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * 16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * 17 * for more details. You should have received a copy of the GNU General * 18 * Public License distributed with GNAT; see file COPYING. If not, write * 19 * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, * 20 * MA 02111-1307, USA. * 21 * * 22 * GNAT was originally developed by the GNAT team at New York University. * 23 * Extensive contributions were provided by Ada Core Technologies Inc. * 24 * * 25 ****************************************************************************/ 26 27 #include "config.h" 28 #include "system.h" 29 #include "coretypes.h" 30 #include "tm.h" 31 #include "tree.h" 32 #include "flags.h" 33 #include "toplev.h" 34 #include "convert.h" 35 #include "ggc.h" 36 #include "obstack.h" 37 38 #include "ada.h" 39 #include "types.h" 40 #include "atree.h" 41 #include "elists.h" 42 #include "namet.h" 43 #include "nlists.h" 44 #include "repinfo.h" 45 #include "snames.h" 46 #include "stringt.h" 47 #include "uintp.h" 48 #include "fe.h" 49 #include "sinfo.h" 50 #include "einfo.h" 51 #include "ada-tree.h" 52 #include "gigi.h" 53 54 /* Setting this to 1 suppresses hashing of types. */ 55 extern int debug_no_type_hash; 56 57 /* Provide default values for the macros controlling stack checking. 58 This is copied from GCC's expr.h. */ 59 60 #ifndef STACK_CHECK_BUILTIN 61 #define STACK_CHECK_BUILTIN 0 62 #endif 63 #ifndef STACK_CHECK_PROBE_INTERVAL 64 #define STACK_CHECK_PROBE_INTERVAL 4096 65 #endif 66 #ifndef STACK_CHECK_MAX_FRAME_SIZE 67 #define STACK_CHECK_MAX_FRAME_SIZE \ 68 (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD) 69 #endif 70 #ifndef STACK_CHECK_MAX_VAR_SIZE 71 #define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100) 72 #endif 73 74 /* These two variables are used to defer recursively expanding incomplete 75 types while we are processing a record or subprogram type. */ 76 77 static int defer_incomplete_level = 0; 78 static struct incomplete 79 { 80 struct incomplete *next; 81 tree old_type; 82 Entity_Id full_type; 83 } *defer_incomplete_list = 0; 84 85 static tree substitution_list (Entity_Id, Entity_Id, tree, int); 86 static int allocatable_size_p (tree, int); 87 static struct attrib *build_attr_list (Entity_Id); 88 static tree elaborate_expression (Node_Id, Entity_Id, tree, int, int, int); 89 static int is_variable_size (tree); 90 static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree, int, int); 91 static tree make_packable_type (tree); 92 static tree maybe_pad_type (tree, tree, unsigned int, Entity_Id, const char *, 93 int, int, int); 94 static tree gnat_to_gnu_field (Entity_Id, tree, int, int); 95 static void components_to_record (tree, Node_Id, tree, int, int, tree *, 96 int, int); 97 static int compare_field_bitpos (const PTR, const PTR); 98 static Uint annotate_value (tree); 99 static void annotate_rep (Entity_Id, tree); 100 static tree compute_field_positions (tree, tree, tree, tree, unsigned int); 101 static tree validate_size (Uint, tree, Entity_Id, enum tree_code, int, int); 102 static void set_rm_size (Uint, tree, Entity_Id); 103 static tree make_type_from_size (tree, tree, int); 104 static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); 105 static void check_ok_for_atomic (tree, Entity_Id, int); 106 107 /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a 108 GCC type corresponding to that entity. GNAT_ENTITY is assumed to 109 refer to an Ada type. */ 110 111 tree 112 gnat_to_gnu_type (Entity_Id gnat_entity) 113 { 114 tree gnu_decl; 115 116 /* Convert the ada entity type into a GCC TYPE_DECL node. */ 117 gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); 118 if (TREE_CODE (gnu_decl) != TYPE_DECL) 119 gigi_abort (101); 120 121 return TREE_TYPE (gnu_decl); 122 } 123 124 /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada 125 entity, this routine returns the equivalent GCC tree for that entity 126 (an ..._DECL node) and associates the ..._DECL node with the input GNAT 127 defining identifier. 128 129 If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its 130 initial value (in GCC tree form). This is optional for variables. 131 For renamed entities, GNU_EXPR gives the object being renamed. 132 133 DEFINITION is nonzero if this call is intended for a definition. This is 134 used for separate compilation where it necessary to know whether an 135 external declaration or a definition should be created if the GCC equivalent 136 was not created previously. The value of 1 is normally used for a non-zero 137 DEFINITION, but a value of 2 is used in special circumstances, defined in 138 the code. */ 139 140 tree 141 gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) 142 { 143 tree gnu_entity_id; 144 tree gnu_type = 0; 145 /* Contains the gnu XXXX_DECL tree node which is equivalent to the input 146 GNAT tree. This node will be associated with the GNAT node by calling 147 the save_gnu_tree routine at the end of the `switch' statement. */ 148 tree gnu_decl = 0; 149 /* Nonzero if we have already saved gnu_decl as a gnat association. */ 150 int saved = 0; 151 /* Nonzero if we incremented defer_incomplete_level. */ 152 int this_deferred = 0; 153 /* Nonzero if we incremented force_global. */ 154 int this_global = 0; 155 /* Nonzero if we should check to see if elaborated during processing. */ 156 int maybe_present = 0; 157 /* Nonzero if we made GNU_DECL and its type here. */ 158 int this_made_decl = 0; 159 struct attrib *attr_list = 0; 160 int debug_info_p = (Needs_Debug_Info (gnat_entity) 161 || debug_info_level == DINFO_LEVEL_VERBOSE); 162 Entity_Kind kind = Ekind (gnat_entity); 163 Entity_Id gnat_temp; 164 unsigned int esize 165 = ((Known_Esize (gnat_entity) 166 && UI_Is_In_Int_Range (Esize (gnat_entity))) 167 ? MIN (UI_To_Int (Esize (gnat_entity)), 168 IN (kind, Float_Kind) 169 ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE) 170 : IN (kind, Access_Kind) ? POINTER_SIZE * 2 171 : LONG_LONG_TYPE_SIZE) 172 : LONG_LONG_TYPE_SIZE); 173 tree gnu_size = 0; 174 int imported_p 175 = ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity))) 176 || From_With_Type (gnat_entity)); 177 unsigned int align = 0; 178 179 /* Since a use of an Itype is a definition, process it as such if it 180 is not in a with'ed unit. */ 181 182 if (! definition && Is_Itype (gnat_entity) 183 && ! present_gnu_tree (gnat_entity) 184 && In_Extended_Main_Code_Unit (gnat_entity)) 185 { 186 /* Ensure that we are in a subprogram mentioned in the Scope 187 chain of this entity, our current scope is global, 188 or that we encountered a task or entry (where we can't currently 189 accurately check scoping). */ 190 if (current_function_decl == 0 191 || DECL_ELABORATION_PROC_P (current_function_decl)) 192 { 193 process_type (gnat_entity); 194 return get_gnu_tree (gnat_entity); 195 } 196 197 for (gnat_temp = Scope (gnat_entity); 198 Present (gnat_temp); gnat_temp = Scope (gnat_temp)) 199 { 200 if (Is_Type (gnat_temp)) 201 gnat_temp = Underlying_Type (gnat_temp); 202 203 if (Ekind (gnat_temp) == E_Subprogram_Body) 204 gnat_temp 205 = Corresponding_Spec (Parent (Declaration_Node (gnat_temp))); 206 207 if (IN (Ekind (gnat_temp), Subprogram_Kind) 208 && Present (Protected_Body_Subprogram (gnat_temp))) 209 gnat_temp = Protected_Body_Subprogram (gnat_temp); 210 211 if (Ekind (gnat_temp) == E_Entry 212 || Ekind (gnat_temp) == E_Entry_Family 213 || Ekind (gnat_temp) == E_Task_Type 214 || (IN (Ekind (gnat_temp), Subprogram_Kind) 215 && present_gnu_tree (gnat_temp) 216 && (current_function_decl 217 == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0)))) 218 { 219 process_type (gnat_entity); 220 return get_gnu_tree (gnat_entity); 221 } 222 } 223 224 /* gigi abort 122 means that the entity "gnat_entity" has an incorrect 225 scope, i.e. that its scope does not correspond to the subprogram 226 in which it is declared */ 227 gigi_abort (122); 228 } 229 230 /* If this is entity 0, something went badly wrong. */ 231 if (gnat_entity == 0) 232 gigi_abort (102); 233 234 /* If we've already processed this entity, return what we got last time. 235 If we are defining the node, we should not have already processed it. 236 In that case, we will abort below when we try to save a new GCC tree for 237 this object. We also need to handle the case of getting a dummy type 238 when a Full_View exists. */ 239 240 if (present_gnu_tree (gnat_entity) 241 && (! definition 242 || (Is_Type (gnat_entity) && imported_p))) 243 { 244 gnu_decl = get_gnu_tree (gnat_entity); 245 246 if (TREE_CODE (gnu_decl) == TYPE_DECL 247 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)) 248 && IN (kind, Incomplete_Or_Private_Kind) 249 && Present (Full_View (gnat_entity))) 250 { 251 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), 252 NULL_TREE, 0); 253 254 save_gnu_tree (gnat_entity, NULL_TREE, 0); 255 save_gnu_tree (gnat_entity, gnu_decl, 0); 256 } 257 258 return gnu_decl; 259 } 260 261 /* If this is a numeric or enumeral type, or an access type, a nonzero 262 Esize must be specified unless it was specified by the programmer. */ 263 if ((IN (kind, Numeric_Kind) || IN (kind, Enumeration_Kind) 264 || (IN (kind, Access_Kind) 265 && kind != E_Access_Protected_Subprogram_Type 266 && kind != E_Access_Subtype)) 267 && Unknown_Esize (gnat_entity) 268 && ! Has_Size_Clause (gnat_entity)) 269 gigi_abort (109); 270 271 /* Likewise, RM_Size must be specified for all discrete and fixed-point 272 types. */ 273 if (IN (kind, Discrete_Or_Fixed_Point_Kind) 274 && Unknown_RM_Size (gnat_entity)) 275 gigi_abort (123); 276 277 /* Get the name of the entity and set up the line number and filename of 278 the original definition for use in any decl we make. */ 279 280 gnu_entity_id = get_entity_name (gnat_entity); 281 set_lineno (gnat_entity, 0); 282 283 /* If we get here, it means we have not yet done anything with this 284 entity. If we are not defining it here, it must be external, 285 otherwise we should have defined it already. */ 286 if (! definition && ! Is_Public (gnat_entity) 287 && ! type_annotate_only 288 && kind != E_Discriminant && kind != E_Component 289 && kind != E_Label 290 && ! (kind == E_Constant && Present (Full_View (gnat_entity))) 291 #if 1 292 && !IN (kind, Type_Kind) 293 #endif 294 ) 295 gigi_abort (116); 296 297 /* For cases when we are not defining (i.e., we are referencing from 298 another compilation unit) Public entities, show we are at global level 299 for the purpose of computing sizes. Don't do this for components or 300 discriminants since the relevant test is whether or not the record is 301 being defined. */ 302 if (! definition && Is_Public (gnat_entity) 303 && ! Is_Statically_Allocated (gnat_entity) 304 && kind != E_Discriminant && kind != E_Component) 305 force_global++, this_global = 1; 306 307 /* Handle any attributes. */ 308 if (Has_Gigi_Rep_Item (gnat_entity)) 309 attr_list = build_attr_list (gnat_entity); 310 311 switch (kind) 312 { 313 case E_Constant: 314 /* If this is a use of a deferred constant, get its full 315 declaration. */ 316 if (! definition && Present (Full_View (gnat_entity))) 317 { 318 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), 319 gnu_expr, definition); 320 saved = 1; 321 break; 322 } 323 324 /* If we have an external constant that we are not defining, 325 get the expression that is was defined to represent. We 326 may throw that expression away later if it is not a 327 constant. 328 Do not retrieve the expression if it is an aggregate, because 329 in complex instantiation contexts it may not be expanded */ 330 331 if (! definition 332 && Present (Expression (Declaration_Node (gnat_entity))) 333 && ! No_Initialization (Declaration_Node (gnat_entity)) 334 && Nkind (Expression (Declaration_Node (gnat_entity))) 335 != N_Aggregate) 336 gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); 337 338 /* Ignore deferred constant definitions; they are processed fully in the 339 front-end. For deferred constant references, get the full 340 definition. On the other hand, constants that are renamings are 341 handled like variable renamings. If No_Initialization is set, this is 342 not a deferred constant but a constant whose value is built 343 manually. */ 344 345 if (definition && gnu_expr == 0 346 && ! No_Initialization (Declaration_Node (gnat_entity)) 347 && No (Renamed_Object (gnat_entity))) 348 { 349 gnu_decl = error_mark_node; 350 saved = 1; 351 break; 352 } 353 else if (! definition && IN (kind, Incomplete_Or_Private_Kind) 354 && Present (Full_View (gnat_entity))) 355 { 356 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), 357 NULL_TREE, 0); 358 saved = 1; 359 break; 360 } 361 362 goto object; 363 364 case E_Exception: 365 /* If this is not a VMS exception, treat it as a normal object. 366 Otherwise, make an object at the specific address of character 367 type, point to it, and convert it to integer, and mask off 368 the lower 3 bits. */ 369 if (! Is_VMS_Exception (gnat_entity)) 370 goto object; 371 372 /* Allocate the global object that we use to get the value of the 373 exception. */ 374 gnu_decl = create_var_decl (gnu_entity_id, 375 (Present (Interface_Name (gnat_entity)) 376 ? create_concat_name (gnat_entity, 0) 377 : NULL_TREE), 378 char_type_node, NULL_TREE, 0, 0, 1, 1, 379 0); 380 381 /* Now return the expression giving the desired value. */ 382 gnu_decl 383 = build_binary_op (BIT_AND_EXPR, integer_type_node, 384 convert (integer_type_node, 385 build_unary_op (ADDR_EXPR, NULL_TREE, 386 gnu_decl)), 387 build_unary_op (NEGATE_EXPR, integer_type_node, 388 build_int_2 (7, 0))); 389 390 save_gnu_tree (gnat_entity, gnu_decl, 1); 391 saved = 1; 392 break; 393 394 case E_Discriminant: 395 case E_Component: 396 { 397 /* The GNAT record where the component was defined. */ 398 Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity)); 399 400 /* If the variable is an inherited record component (in the case of 401 extended record types), just return the inherited entity, which 402 must be a FIELD_DECL. Likewise for discriminants. 403 For discriminants of untagged records which have explicit 404 stored discriminants, return the entity for the corresponding 405 stored discriminant. Also use Original_Record_Component 406 if the record has a private extension. */ 407 408 if ((Base_Type (gnat_record) == gnat_record 409 || Ekind (Scope (gnat_entity)) == E_Private_Subtype 410 || Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private 411 || Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private) 412 && Present (Original_Record_Component (gnat_entity)) 413 && Original_Record_Component (gnat_entity) != gnat_entity) 414 { 415 gnu_decl 416 = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), 417 gnu_expr, definition); 418 saved = 1; 419 break; 420 } 421 422 /* If the enclosing record has explicit stored discriminants, 423 then it is an untagged record. If the Corresponding_Discriminant 424 is not empty then this must be a renamed discriminant and its 425 Original_Record_Component must point to the corresponding explicit 426 stored discriminant (i.e., we should have taken the previous 427 branch). */ 428 429 else if (Present (Corresponding_Discriminant (gnat_entity)) 430 && Is_Tagged_Type (gnat_record)) 431 { 432 /* A tagged record has no explicit stored discriminants. */ 433 434 if (First_Discriminant (gnat_record) 435 != First_Stored_Discriminant (gnat_record)) 436 gigi_abort (119); 437 438 gnu_decl 439 = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), 440 gnu_expr, definition); 441 saved = 1; 442 break; 443 } 444 445 /* If the enclosing record has explicit stored discriminants, 446 then it is an untagged record. If the Corresponding_Discriminant 447 is not empty then this must be a renamed discriminant and its 448 Original_Record_Component must point to the corresponding explicit 449 stored discriminant (i.e., we should have taken the first 450 branch). */ 451 452 else if (Present (Corresponding_Discriminant (gnat_entity)) 453 && (First_Discriminant (gnat_record) 454 != First_Stored_Discriminant (gnat_record))) 455 gigi_abort (120); 456 457 /* Otherwise, if we are not defining this and we have no GCC type 458 for the containing record, make one for it. Then we should 459 have made our own equivalent. */ 460 else if (! definition && ! present_gnu_tree (gnat_record)) 461 { 462 /* ??? If this is in a record whose scope is a protected 463 type and we have an Original_Record_Component, use it. 464 This is a workaround for major problems in protected type 465 handling. */ 466 467 Entity_Id Scop = Scope (Scope (gnat_entity)); 468 if ((Is_Protected_Type (Scop) 469 || (Is_Private_Type (Scop) 470 && Present (Full_View (Scop)) 471 && Is_Protected_Type (Full_View (Scop)))) 472 && Present (Original_Record_Component (gnat_entity))) 473 { 474 gnu_decl 475 = gnat_to_gnu_entity (Original_Record_Component 476 (gnat_entity), 477 gnu_expr, definition); 478 saved = 1; 479 break; 480 } 481 482 gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0); 483 gnu_decl = get_gnu_tree (gnat_entity); 484 saved = 1; 485 break; 486 } 487 488 /* Here we have no GCC type and this is a reference rather than a 489 definition. This should never happen. Most likely the cause is a 490 reference before declaration in the gnat tree for gnat_entity. */ 491 else 492 gigi_abort (103); 493 } 494 495 case E_Loop_Parameter: 496 case E_Out_Parameter: 497 case E_Variable: 498 499 /* Simple variables, loop variables, OUT parameters, and exceptions. */ 500 object: 501 { 502 int used_by_ref = 0; 503 int const_flag 504 = ((kind == E_Constant || kind == E_Variable) 505 && ! Is_Statically_Allocated (gnat_entity) 506 && Is_True_Constant (gnat_entity) 507 && (((Nkind (Declaration_Node (gnat_entity)) 508 == N_Object_Declaration) 509 && Present (Expression (Declaration_Node (gnat_entity)))) 510 || Present (Renamed_Object (gnat_entity)))); 511 int inner_const_flag = const_flag; 512 int static_p = Is_Statically_Allocated (gnat_entity); 513 tree gnu_ext_name = NULL_TREE; 514 515 if (Present (Renamed_Object (gnat_entity)) && ! definition) 516 { 517 if (kind == E_Exception) 518 gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity), 519 NULL_TREE, 0); 520 else 521 gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity)); 522 } 523 524 /* Get the type after elaborating the renamed object. */ 525 gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); 526 527 /* If this is a loop variable, its type should be the base type. 528 This is because the code for processing a loop determines whether 529 a normal loop end test can be done by comparing the bounds of the 530 loop against those of the base type, which is presumed to be the 531 size used for computation. But this is not correct when the size 532 of the subtype is smaller than the type. */ 533 if (kind == E_Loop_Parameter) 534 gnu_type = get_base_type (gnu_type); 535 536 /* Reject non-renamed objects whose types are unconstrained arrays or 537 any object whose type is a dummy type or VOID_TYPE. */ 538 539 if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE 540 && No (Renamed_Object (gnat_entity))) 541 || TYPE_IS_DUMMY_P (gnu_type) 542 || TREE_CODE (gnu_type) == VOID_TYPE) 543 { 544 if (type_annotate_only) 545 return error_mark_node; 546 else 547 gigi_abort (104); 548 } 549 550 /* If we are defining the object, see if it has a Size value and 551 validate it if so. If we are not defining the object and a Size 552 clause applies, simply retrieve the value. We don't want to ignore 553 the clause and it is expected to have been validated already. Then 554 get the new type, if any. */ 555 if (definition) 556 gnu_size = validate_size (Esize (gnat_entity), gnu_type, 557 gnat_entity, VAR_DECL, 0, 558 Has_Size_Clause (gnat_entity)); 559 else if (Has_Size_Clause (gnat_entity)) 560 gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype); 561 562 if (gnu_size != 0) 563 { 564 gnu_type 565 = make_type_from_size (gnu_type, gnu_size, 566 Has_Biased_Representation (gnat_entity)); 567 568 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)) 569 gnu_size = 0; 570 } 571 572 /* If this object has self-referential size, it must be a record with 573 a default value. We are supposed to allocate an object of the 574 maximum size in this case unless it is a constant with an 575 initializing expression, in which case we can get the size from 576 that. Note that the resulting size may still be a variable, so 577 this may end up with an indirect allocation. */ 578 579 if (No (Renamed_Object (gnat_entity)) 580 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) 581 { 582 if (gnu_expr != 0 && kind == E_Constant) 583 { 584 gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr)); 585 if (CONTAINS_PLACEHOLDER_P (gnu_size)) 586 gnu_size = build (WITH_RECORD_EXPR, bitsizetype, 587 gnu_size, gnu_expr); 588 } 589 590 /* We may have no GNU_EXPR because No_Initialization is 591 set even though there's an Expression. */ 592 else if (kind == E_Constant 593 && (Nkind (Declaration_Node (gnat_entity)) 594 == N_Object_Declaration) 595 && Present (Expression (Declaration_Node (gnat_entity)))) 596 gnu_size 597 = TYPE_SIZE (gnat_to_gnu_type 598 (Etype 599 (Expression (Declaration_Node (gnat_entity))))); 600 else 601 gnu_size = max_size (TYPE_SIZE (gnu_type), 1); 602 } 603 604 /* If the size is zero bytes, make it one byte since some linkers have 605 trouble with zero-sized objects. If the object will have a 606 template, that will make it nonzero so don't bother. Also avoid 607 doing that for an object renaming or an object with an address 608 clause, as we would lose useful information on the view size 609 (e.g. for null array slices) and we are not allocating the object 610 here anyway. */ 611 if (((gnu_size != 0 && integer_zerop (gnu_size)) 612 || (TYPE_SIZE (gnu_type) != 0 613 && integer_zerop (TYPE_SIZE (gnu_type)))) 614 && (! Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) 615 || ! Is_Array_Type (Etype (gnat_entity))) 616 && ! Present (Renamed_Object (gnat_entity)) 617 && ! Present (Address_Clause (gnat_entity))) 618 gnu_size = bitsize_unit_node; 619 620 /* If an alignment is specified, use it if valid. Note that 621 exceptions are objects but don't have alignments. */ 622 if (kind != E_Exception && Known_Alignment (gnat_entity)) 623 { 624 if (No (Alignment (gnat_entity))) 625 gigi_abort (125); 626 627 align 628 = validate_alignment (Alignment (gnat_entity), gnat_entity, 629 TYPE_ALIGN (gnu_type)); 630 } 631 632 /* If this is an atomic object with no specified size and alignment, 633 but where the size of the type is a constant, set the alignment to 634 the lowest power of two greater than the size, or to the 635 biggest meaningful alignment, whichever is smaller. */ 636 637 if (Is_Atomic (gnat_entity) && gnu_size == 0 && align == 0 638 && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST) 639 { 640 if (! host_integerp (TYPE_SIZE (gnu_type), 1) 641 || 0 <= compare_tree_int (TYPE_SIZE (gnu_type), 642 BIGGEST_ALIGNMENT)) 643 align = BIGGEST_ALIGNMENT; 644 else 645 align = ((unsigned int) 1 646 << (floor_log2 (tree_low_cst 647 (TYPE_SIZE (gnu_type), 1) - 1) 648 + 1)); 649 } 650 651 /* If the object is set to have atomic components, find the component 652 type and validate it. 653 654 ??? Note that we ignore Has_Volatile_Components on objects; it's 655 not at all clear what to do in that case. */ 656 657 if (Has_Atomic_Components (gnat_entity)) 658 { 659 tree gnu_inner 660 = (TREE_CODE (gnu_type) == ARRAY_TYPE 661 ? TREE_TYPE (gnu_type) : gnu_type); 662 663 while (TREE_CODE (gnu_inner) == ARRAY_TYPE 664 && TYPE_MULTI_ARRAY_P (gnu_inner)) 665 gnu_inner = TREE_TYPE (gnu_inner); 666 667 check_ok_for_atomic (gnu_inner, gnat_entity, 1); 668 } 669 670 /* Now check if the type of the object allows atomic access. Note 671 that we must test the type, even if this object has size and 672 alignment to allow such access, because we will be going 673 inside the padded record to assign to the object. We could fix 674 this by always copying via an intermediate value, but it's not 675 clear it's worth the effort. */ 676 if (Is_Atomic (gnat_entity)) 677 check_ok_for_atomic (gnu_type, gnat_entity, 0); 678 679 /* If this is an aliased object with an unconstrained nominal subtype, 680 make a type that includes the template. */ 681 if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) 682 && Is_Array_Type (Etype (gnat_entity)) 683 && ! type_annotate_only) 684 { 685 tree gnu_fat 686 = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity)))); 687 tree gnu_temp_type 688 = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat)))); 689 690 gnu_type 691 = build_unc_object_type (gnu_temp_type, gnu_type, 692 concat_id_with_name (gnu_entity_id, 693 "UNC")); 694 } 695 696 #ifdef MINIMUM_ATOMIC_ALIGNMENT 697 /* If the size is a constant and no alignment is specified, force 698 the alignment to be the minimum valid atomic alignment. The 699 restriction on constant size avoids problems with variable-size 700 temporaries; if the size is variable, there's no issue with 701 atomic access. Also don't do this for a constant, since it isn't 702 necessary and can interfere with constant replacement. Finally, 703 do not do it for Out parameters since that creates an 704 size inconsistency with In parameters. */ 705 if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) 706 && ! FLOAT_TYPE_P (gnu_type) 707 && ! const_flag && No (Renamed_Object (gnat_entity)) 708 && ! imported_p && No (Address_Clause (gnat_entity)) 709 && kind != E_Out_Parameter 710 && (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST 711 : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)) 712 align = MINIMUM_ATOMIC_ALIGNMENT; 713 #endif 714 715 /* Make a new type with the desired size and alignment, if needed. */ 716 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, 717 gnat_entity, "PAD", 0, definition, 1); 718 719 /* Make a volatile version of this object's type if we are to 720 make the object volatile. Note that 13.3(19) says that we 721 should treat other types of objects as volatile as well. */ 722 if ((Treat_As_Volatile (gnat_entity) 723 || Is_Exported (gnat_entity) 724 || Is_Imported (gnat_entity) 725 || Present (Address_Clause (gnat_entity))) 726 && ! TYPE_VOLATILE (gnu_type)) 727 gnu_type = build_qualified_type (gnu_type, 728 (TYPE_QUALS (gnu_type) 729 | TYPE_QUAL_VOLATILE)); 730 731 /* Convert the expression to the type of the object except in the 732 case where the object's type is unconstrained or the object's type 733 is a padded record whose field is of self-referential size. In 734 the former case, converting will generate unnecessary evaluations 735 of the CONSTRUCTOR to compute the size and in the latter case, we 736 want to only copy the actual data. */ 737 if (gnu_expr != 0 738 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE 739 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) 740 && ! (TREE_CODE (gnu_type) == RECORD_TYPE 741 && TYPE_IS_PADDING_P (gnu_type) 742 && (CONTAINS_PLACEHOLDER_P 743 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) 744 gnu_expr = convert (gnu_type, gnu_expr); 745 746 /* See if this is a renaming. If this is a constant renaming, 747 treat it as a normal variable whose initial value is what 748 is being renamed. We cannot do this if the type is 749 unconstrained or class-wide. 750 751 Otherwise, if what we are renaming is a reference, we can simply 752 return a stabilized version of that reference, after forcing 753 any SAVE_EXPRs to be evaluated. But, if this is at global level, 754 we can only do this if we know no SAVE_EXPRs will be made. 755 Otherwise, make this into a constant pointer to the object we are 756 to rename. */ 757 758 if (Present (Renamed_Object (gnat_entity))) 759 { 760 /* If the renamed object had padding, strip off the reference 761 to the inner object and reset our type. */ 762 if (TREE_CODE (gnu_expr) == COMPONENT_REF 763 && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) 764 == RECORD_TYPE) 765 && (TYPE_IS_PADDING_P 766 (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))) 767 { 768 gnu_expr = TREE_OPERAND (gnu_expr, 0); 769 gnu_type = TREE_TYPE (gnu_expr); 770 } 771 772 if (const_flag 773 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE 774 && TYPE_MODE (gnu_type) != BLKmode 775 && Ekind (Etype (gnat_entity)) != E_Class_Wide_Type 776 && !Is_Array_Type (Etype (gnat_entity))) 777 ; 778 779 /* If this is a declaration or reference, we can just use that 780 declaration or reference as this entity. */ 781 else if ((DECL_P (gnu_expr) 782 || TREE_CODE_CLASS (TREE_CODE (gnu_expr)) == 'r') 783 && ! Materialize_Entity (gnat_entity) 784 && (! global_bindings_p () 785 || (staticp (gnu_expr) 786 && ! TREE_SIDE_EFFECTS (gnu_expr)))) 787 { 788 set_lineno (gnat_entity, ! global_bindings_p ()); 789 gnu_decl = gnat_stabilize_reference (gnu_expr, 1); 790 save_gnu_tree (gnat_entity, gnu_decl, 1); 791 saved = 1; 792 793 if (! global_bindings_p ()) 794 expand_expr_stmt (build1 (CONVERT_EXPR, void_type_node, 795 gnu_decl)); 796 break; 797 } 798 else 799 { 800 inner_const_flag = TREE_READONLY (gnu_expr); 801 const_flag = 1; 802 gnu_type = build_reference_type (gnu_type); 803 gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr); 804 gnu_size = 0; 805 used_by_ref = 1; 806 } 807 } 808 809 /* If this is an aliased object whose nominal subtype is unconstrained, 810 the object is a record that contains both the template and 811 the object. If there is an initializer, it will have already 812 been converted to the right type, but we need to create the 813 template if there is no initializer. */ 814 else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE 815 && (TYPE_CONTAINS_TEMPLATE_P (gnu_type) 816 /* Beware that padding might have been introduced 817 via maybe_pad_type above. */ 818 || (TYPE_IS_PADDING_P (gnu_type) 819 && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) 820 == RECORD_TYPE 821 && TYPE_CONTAINS_TEMPLATE_P 822 (TREE_TYPE (TYPE_FIELDS (gnu_type))))) 823 && gnu_expr == 0) 824 { 825 tree template_field 826 = TYPE_IS_PADDING_P (gnu_type) 827 ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type))) 828 : TYPE_FIELDS (gnu_type); 829 830 gnu_expr 831 = gnat_build_constructor 832 (gnu_type, 833 tree_cons 834 (template_field, 835 build_template (TREE_TYPE (template_field), 836 TREE_TYPE (TREE_CHAIN (template_field)), 837 NULL_TREE), 838 NULL_TREE)); 839 } 840 841 /* If this is a pointer and it does not have an initializing 842 expression, initialize it to NULL, unless the obect is 843 imported. */ 844 if (definition 845 && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type)) 846 && !Is_Imported (gnat_entity) 847 && gnu_expr == 0) 848 gnu_expr = integer_zero_node; 849 850 /* If we are defining the object and it has an Address clause we must 851 get the address expression from the saved GCC tree for the 852 object if the object has a Freeze_Node. Otherwise, we elaborate 853 the address expression here since the front-end has guaranteed 854 in that case that the elaboration has no effects. Note that 855 only the latter mechanism is currently in use. */ 856 if (definition && Present (Address_Clause (gnat_entity))) 857 { 858 tree gnu_address 859 = (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) 860 : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); 861 862 save_gnu_tree (gnat_entity, NULL_TREE, 0); 863 864 /* Ignore the size. It's either meaningless or was handled 865 above. */ 866 gnu_size = 0; 867 gnu_type = build_reference_type (gnu_type); 868 gnu_address = convert (gnu_type, gnu_address); 869 used_by_ref = 1; 870 const_flag = ! Is_Public (gnat_entity); 871 872 /* If we don't have an initializing expression for the underlying 873 variable, the initializing expression for the pointer is the 874 specified address. Otherwise, we have to make a COMPOUND_EXPR 875 to assign both the address and the initial value. */ 876 if (gnu_expr == 0) 877 gnu_expr = gnu_address; 878 else 879 gnu_expr 880 = build (COMPOUND_EXPR, gnu_type, 881 build_binary_op 882 (MODIFY_EXPR, NULL_TREE, 883 build_unary_op (INDIRECT_REF, NULL_TREE, 884 gnu_address), 885 gnu_expr), 886 gnu_address); 887 } 888 889 /* If it has an address clause and we are not defining it, mark it 890 as an indirect object. Likewise for Stdcall objects that are 891 imported. */ 892 if ((! definition && Present (Address_Clause (gnat_entity))) 893 || (Is_Imported (gnat_entity) 894 && Convention (gnat_entity) == Convention_Stdcall)) 895 { 896 gnu_type = build_reference_type (gnu_type); 897 gnu_size = 0; 898 used_by_ref = 1; 899 } 900 901 /* If we are at top level and this object is of variable size, 902 make the actual type a hidden pointer to the real type and 903 make the initializer be a memory allocation and initialization. 904 Likewise for objects we aren't defining (presumed to be 905 external references from other packages), but there we do 906 not set up an initialization. 907 908 If the object's size overflows, make an allocator too, so that 909 Storage_Error gets raised. Note that we will never free 910 such memory, so we presume it never will get allocated. */ 911 912 if (! allocatable_size_p (TYPE_SIZE_UNIT (gnu_type), 913 global_bindings_p () || ! definition 914 || static_p) 915 || (gnu_size != 0 916 && ! allocatable_size_p (gnu_size, 917 global_bindings_p () || ! definition 918 || static_p))) 919 { 920 gnu_type = build_reference_type (gnu_type); 921 gnu_size = 0; 922 used_by_ref = 1; 923 const_flag = 1; 924 925 /* Get the data part of GNU_EXPR in case this was a 926 aliased object whose nominal subtype is unconstrained. 927 In that case the pointer above will be a thin pointer and 928 build_allocator will automatically make the template and 929 constructor already made above. */ 930 931 if (definition) 932 { 933 tree gnu_alloc_type = TREE_TYPE (gnu_type); 934 935 if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE 936 && TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type)) 937 { 938 gnu_alloc_type 939 = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type))); 940 gnu_expr 941 = build_component_ref 942 (gnu_expr, NULL_TREE, 943 TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), 0); 944 } 945 946 if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST 947 && TREE_CONSTANT_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)) 948 && ! Is_Imported (gnat_entity)) 949 post_error ("Storage_Error will be raised at run-time?", 950 gnat_entity); 951 952 gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, 953 gnu_type, 0, 0, gnat_entity); 954 } 955 else 956 { 957 gnu_expr = 0; 958 const_flag = 0; 959 } 960 } 961 962 /* If this object would go into the stack and has an alignment 963 larger than the default largest alignment, make a variable 964 to hold the "aligning type" with a modified initial value, 965 if any, then point to it and make that the value of this 966 variable, which is now indirect. */ 967 968 if (! global_bindings_p () && ! static_p && definition 969 && ! imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT) 970 { 971 tree gnu_new_type 972 = make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type), 973 TYPE_SIZE_UNIT (gnu_type)); 974 tree gnu_new_var; 975 976 set_lineno (gnat_entity, 1); 977 gnu_new_var 978 = create_var_decl (create_concat_name (gnat_entity, "ALIGN"), 979 NULL_TREE, gnu_new_type, gnu_expr, 980 0, 0, 0, 0, 0); 981 982 if (gnu_expr != 0) 983 expand_expr_stmt 984 (build_binary_op 985 (MODIFY_EXPR, NULL_TREE, 986 build_component_ref (gnu_new_var, NULL_TREE, 987 TYPE_FIELDS (gnu_new_type), 0), 988 gnu_expr)); 989 990 gnu_type = build_reference_type (gnu_type); 991 gnu_expr 992 = build_unary_op 993 (ADDR_EXPR, gnu_type, 994 build_component_ref (gnu_new_var, NULL_TREE, 995 TYPE_FIELDS (gnu_new_type), 0)); 996 997 gnu_size = 0; 998 used_by_ref = 1; 999 const_flag = 1; 1000 } 1001 1002 /* Convert the expression to the type of the object except in the 1003 case where the object's type is unconstrained or the object's type 1004 is a padded record whose field is of self-referential size. In 1005 the former case, converting will generate unnecessary evaluations 1006 of the CONSTRUCTOR to compute the size and in the latter case, we 1007 want to only copy the actual data. */ 1008 if (gnu_expr != 0 1009 && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE 1010 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) 1011 && ! (TREE_CODE (gnu_type) == RECORD_TYPE 1012 && TYPE_IS_PADDING_P (gnu_type) 1013 && (CONTAINS_PLACEHOLDER_P 1014 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))) 1015 gnu_expr = convert (gnu_type, gnu_expr); 1016 1017 /* This name is external or there was a name specified, use it. 1018 Don't use the Interface_Name if there is an address clause. 1019 (see CD30005). */ 1020 if ((Present (Interface_Name (gnat_entity)) 1021 && No (Address_Clause (gnat_entity))) 1022 || (Is_Public (gnat_entity) 1023 && (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))) 1024 gnu_ext_name = create_concat_name (gnat_entity, 0); 1025 1026 if (const_flag) 1027 gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type) 1028 | TYPE_QUAL_CONST)); 1029 1030 /* If this is constant initialized to a static constant and the 1031 object has an aggregrate type, force it to be statically 1032 allocated. */ 1033 if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr) 1034 && host_integerp (TYPE_SIZE_UNIT (gnu_type), 1) 1035 && (AGGREGATE_TYPE_P (gnu_type) 1036 && ! (TREE_CODE (gnu_type) == RECORD_TYPE 1037 && TYPE_IS_PADDING_P (gnu_type)))) 1038 static_p = 1; 1039 1040 set_lineno (gnat_entity, ! global_bindings_p ()); 1041 gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, 1042 gnu_expr, const_flag, 1043 Is_Public (gnat_entity), 1044 imported_p || !definition, 1045 static_p, attr_list); 1046 1047 DECL_BY_REF_P (gnu_decl) = used_by_ref; 1048 DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; 1049 1050 if (definition && DECL_SIZE (gnu_decl) != 0 1051 && gnu_block_stack != 0 1052 && TREE_VALUE (gnu_block_stack) != 0 1053 && (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST 1054 || (flag_stack_check && ! STACK_CHECK_BUILTIN 1055 && 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl), 1056 STACK_CHECK_MAX_VAR_SIZE)))) 1057 update_setjmp_buf (TREE_VALUE (gnu_block_stack)); 1058 1059 /* If this is a public constant or we're not optimizing and we're not 1060 making a VAR_DECL for it, make one just for export or debugger 1061 use. Likewise if the address is taken or if the object or type is 1062 aliased. */ 1063 if (definition && TREE_CODE (gnu_decl) == CONST_DECL 1064 && (Is_Public (gnat_entity) 1065 || optimize == 0 1066 || Address_Taken (gnat_entity) 1067 || Is_Aliased (gnat_entity) 1068 || Is_Aliased (Etype (gnat_entity)))) 1069 SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, 1070 create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, 1071 gnu_expr, 0, Is_Public (gnat_entity), 0, 1072 static_p, 0)); 1073 1074 /* If this is declared in a block that contains an block with an 1075 exception handler, we must force this variable in memory to 1076 suppress an invalid optimization. */ 1077 if (Has_Nested_Block_With_Handler (Scope (gnat_entity)) 1078 && Exception_Mechanism != GCC_ZCX) 1079 { 1080 gnat_mark_addressable (gnu_decl); 1081 flush_addressof (gnu_decl); 1082 } 1083 1084 /* Back-annotate the Alignment of the object if not already in the 1085 tree. Likewise for Esize if the object is of a constant size. 1086 But if the "object" is actually a pointer to an object, the 1087 alignment and size are the same as teh type, so don't back-annotate 1088 the values for the pointer. */ 1089 if (! used_by_ref && Unknown_Alignment (gnat_entity)) 1090 Set_Alignment (gnat_entity, 1091 UI_From_Int (DECL_ALIGN (gnu_decl) / BITS_PER_UNIT)); 1092 1093 if (! used_by_ref && Unknown_Esize (gnat_entity) 1094 && DECL_SIZE (gnu_decl) != 0) 1095 { 1096 tree gnu_back_size = DECL_SIZE (gnu_decl); 1097 1098 if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE 1099 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl))) 1100 gnu_back_size 1101 = TYPE_SIZE (TREE_TYPE (TREE_CHAIN 1102 (TYPE_FIELDS (TREE_TYPE (gnu_decl))))); 1103 1104 Set_Esize (gnat_entity, annotate_value (gnu_back_size)); 1105 } 1106 } 1107 break; 1108 1109 case E_Void: 1110 /* Return a TYPE_DECL for "void" that we previously made. */ 1111 gnu_decl = void_type_decl_node; 1112 break; 1113 1114 case E_Enumeration_Type: 1115 /* A special case, for the types Character and Wide_Character in 1116 Standard, we do not list all the literals. So if the literals 1117 are not specified, make this an unsigned type. */ 1118 if (No (First_Literal (gnat_entity))) 1119 { 1120 gnu_type = make_unsigned_type (esize); 1121 break; 1122 } 1123 1124 /* Normal case of non-character type, or non-Standard character type */ 1125 { 1126 /* Here we have a list of enumeral constants in First_Literal. 1127 We make a CONST_DECL for each and build into GNU_LITERAL_LIST 1128 the list to be places into TYPE_FIELDS. Each node in the list 1129 is a TREE_LIST node whose TREE_VALUE is the literal name 1130 and whose TREE_PURPOSE is the value of the literal. 1131 1132 Esize contains the number of bits needed to represent the enumeral 1133 type, Type_Low_Bound also points to the first literal and 1134 Type_High_Bound points to the last literal. */ 1135 1136 Entity_Id gnat_literal; 1137 tree gnu_literal_list = NULL_TREE; 1138 1139 if (Is_Unsigned_Type (gnat_entity)) 1140 gnu_type = make_unsigned_type (esize); 1141 else 1142 gnu_type = make_signed_type (esize); 1143 1144 TREE_SET_CODE (gnu_type, ENUMERAL_TYPE); 1145 1146 for (gnat_literal = First_Literal (gnat_entity); 1147 Present (gnat_literal); 1148 gnat_literal = Next_Literal (gnat_literal)) 1149 { 1150 tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal), 1151 gnu_type); 1152 tree gnu_literal 1153 = create_var_decl (get_entity_name (gnat_literal), 1154 0, gnu_type, gnu_value, 1, 0, 0, 0, 0); 1155 1156 save_gnu_tree (gnat_literal, gnu_literal, 0); 1157 gnu_literal_list = tree_cons (DECL_NAME (gnu_literal), 1158 gnu_value, gnu_literal_list); 1159 } 1160 1161 TYPE_FIELDS (gnu_type) = nreverse (gnu_literal_list); 1162 1163 /* Note that the bounds are updated at the end of this function 1164 because to avoid an infinite recursion when we get the bounds of 1165 this type, since those bounds are objects of this type. */ 1166 } 1167 break; 1168 1169 case E_Signed_Integer_Type: 1170 case E_Ordinary_Fixed_Point_Type: 1171 case E_Decimal_Fixed_Point_Type: 1172 /* For integer types, just make a signed type the appropriate number 1173 of bits. */ 1174 gnu_type = make_signed_type (esize); 1175 break; 1176 1177 case E_Modular_Integer_Type: 1178 /* For modular types, make the unsigned type of the proper number of 1179 bits and then set up the modulus, if required. */ 1180 { 1181 enum machine_mode mode; 1182 tree gnu_modulus; 1183 tree gnu_high = 0; 1184 1185 if (Is_Packed_Array_Type (gnat_entity)) 1186 esize = UI_To_Int (RM_Size (gnat_entity)); 1187 1188 /* Find the smallest mode at least ESIZE bits wide and make a class 1189 using that mode. */ 1190 1191 for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); 1192 GET_MODE_BITSIZE (mode) < esize; 1193 mode = GET_MODE_WIDER_MODE (mode)) 1194 ; 1195 1196 gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode)); 1197 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) 1198 = Is_Packed_Array_Type (gnat_entity); 1199 1200 /* Get the modulus in this type. If it overflows, assume it is because 1201 it is equal to 2**Esize. Note that there is no overflow checking 1202 done on unsigned type, so we detect the overflow by looking for 1203 a modulus of zero, which is otherwise invalid. */ 1204 gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type); 1205 1206 if (! integer_zerop (gnu_modulus)) 1207 { 1208 TYPE_MODULAR_P (gnu_type) = 1; 1209 SET_TYPE_MODULUS (gnu_type, gnu_modulus); 1210 gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus, 1211 convert (gnu_type, integer_one_node))); 1212 } 1213 1214 /* If we have to set TYPE_PRECISION different from its natural value, 1215 make a subtype to do do. Likewise if there is a modulus and 1216 it is not one greater than TYPE_MAX_VALUE. */ 1217 if (TYPE_PRECISION (gnu_type) != esize 1218 || (TYPE_MODULAR_P (gnu_type) 1219 && ! tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high))) 1220 { 1221 tree gnu_subtype = make_node (INTEGER_TYPE); 1222 1223 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT"); 1224 TREE_TYPE (gnu_subtype) = gnu_type; 1225 TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type); 1226 TYPE_MAX_VALUE (gnu_subtype) 1227 = TYPE_MODULAR_P (gnu_type) 1228 ? gnu_high : TYPE_MAX_VALUE (gnu_type); 1229 TYPE_PRECISION (gnu_subtype) = esize; 1230 TREE_UNSIGNED (gnu_subtype) = 1; 1231 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; 1232 TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype) 1233 = Is_Packed_Array_Type (gnat_entity); 1234 layout_type (gnu_subtype); 1235 1236 gnu_type = gnu_subtype; 1237 } 1238 } 1239 break; 1240 1241 case E_Signed_Integer_Subtype: 1242 case E_Enumeration_Subtype: 1243 case E_Modular_Integer_Subtype: 1244 case E_Ordinary_Fixed_Point_Subtype: 1245 case E_Decimal_Fixed_Point_Subtype: 1246 1247 /* For integral subtypes, we make a new INTEGER_TYPE. Note 1248 that we do not want to call build_range_type since we would 1249 like each subtype node to be distinct. This will be important 1250 when memory aliasing is implemented. 1251 1252 The TREE_TYPE field of the INTEGER_TYPE we make points to the 1253 parent type; this fact is used by the arithmetic conversion 1254 functions. 1255 1256 We elaborate the Ancestor_Subtype if it is not in the current 1257 unit and one of our bounds is non-static. We do this to ensure 1258 consistent naming in the case where several subtypes share the same 1259 bounds by always elaborating the first such subtype first, thus 1260 using its name. */ 1261 1262 if (definition == 0 1263 && Present (Ancestor_Subtype (gnat_entity)) 1264 && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) 1265 && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) 1266 || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) 1267 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), 1268 gnu_expr, definition); 1269 1270 gnu_type = make_node (INTEGER_TYPE); 1271 if (Is_Packed_Array_Type (gnat_entity)) 1272 { 1273 esize = UI_To_Int (RM_Size (gnat_entity)); 1274 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1; 1275 } 1276 1277 TYPE_PRECISION (gnu_type) = esize; 1278 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); 1279 1280 TYPE_MIN_VALUE (gnu_type) 1281 = convert (TREE_TYPE (gnu_type), 1282 elaborate_expression (Type_Low_Bound (gnat_entity), 1283 gnat_entity, 1284 get_identifier ("L"), definition, 1, 1285 Needs_Debug_Info (gnat_entity))); 1286 1287 TYPE_MAX_VALUE (gnu_type) 1288 = convert (TREE_TYPE (gnu_type), 1289 elaborate_expression (Type_High_Bound (gnat_entity), 1290 gnat_entity, 1291 get_identifier ("U"), definition, 1, 1292 Needs_Debug_Info (gnat_entity))); 1293 1294 /* One of the above calls might have caused us to be elaborated, 1295 so don't blow up if so. */ 1296 if (present_gnu_tree (gnat_entity)) 1297 { 1298 maybe_present = 1; 1299 break; 1300 } 1301 1302 TYPE_BIASED_REPRESENTATION_P (gnu_type) 1303 = Has_Biased_Representation (gnat_entity); 1304 1305 /* This should be an unsigned type if the lower bound is constant 1306 and non-negative or if the base type is unsigned; a signed type 1307 otherwise. */ 1308 TREE_UNSIGNED (gnu_type) 1309 = (TREE_UNSIGNED (TREE_TYPE (gnu_type)) 1310 || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST 1311 && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0) 1312 || TYPE_BIASED_REPRESENTATION_P (gnu_type) 1313 || Is_Unsigned_Type (gnat_entity)); 1314 1315 layout_type (gnu_type); 1316 1317 if (Is_Packed_Array_Type (gnat_entity) && BYTES_BIG_ENDIAN) 1318 { 1319 tree gnu_field_type = gnu_type; 1320 tree gnu_field; 1321 1322 TYPE_RM_SIZE_INT (gnu_field_type) 1323 = UI_To_gnu (RM_Size (gnat_entity), bitsizetype); 1324 gnu_type = make_node (RECORD_TYPE); 1325 TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "LJM"); 1326 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type); 1327 TYPE_PACKED (gnu_type) = 1; 1328 gnu_field = create_field_decl (get_identifier ("OBJECT"), 1329 gnu_field_type, gnu_type, 1, 0, 0, 1), 1330 finish_record_type (gnu_type, gnu_field, 0, 0); 1331 TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1; 1332 SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize)); 1333 } 1334 1335 break; 1336 1337 case E_Floating_Point_Type: 1338 /* If this is a VAX floating-point type, use an integer of the proper 1339 size. All the operations will be handled with ASM statements. */ 1340 if (Vax_Float (gnat_entity)) 1341 { 1342 gnu_type = make_signed_type (esize); 1343 TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; 1344 SET_TYPE_DIGITS_VALUE (gnu_type, 1345 UI_To_gnu (Digits_Value (gnat_entity), 1346 sizetype)); 1347 break; 1348 } 1349 1350 /* The type of the Low and High bounds can be our type if this is 1351 a type from Standard, so set them at the end of the function. */ 1352 gnu_type = make_node (REAL_TYPE); 1353 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); 1354 layout_type (gnu_type); 1355 break; 1356 1357 case E_Floating_Point_Subtype: 1358 if (Vax_Float (gnat_entity)) 1359 { 1360 gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); 1361 break; 1362 } 1363 1364 { 1365 if (definition == 0 1366 && Present (Ancestor_Subtype (gnat_entity)) 1367 && ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity)) 1368 && (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity)) 1369 || ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity)))) 1370 gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), 1371 gnu_expr, definition); 1372 1373 gnu_type = make_node (REAL_TYPE); 1374 TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); 1375 TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize); 1376 1377 TYPE_MIN_VALUE (gnu_type) 1378 = convert (TREE_TYPE (gnu_type), 1379 elaborate_expression (Type_Low_Bound (gnat_entity), 1380 gnat_entity, get_identifier ("L"), 1381 definition, 1, 1382 Needs_Debug_Info (gnat_entity))); 1383 1384 TYPE_MAX_VALUE (gnu_type) 1385 = convert (TREE_TYPE (gnu_type), 1386 elaborate_expression (Type_High_Bound (gnat_entity), 1387 gnat_entity, get_identifier ("U"), 1388 definition, 1, 1389 Needs_Debug_Info (gnat_entity))); 1390 1391 /* One of the above calls might have caused us to be elaborated, 1392 so don't blow up if so. */ 1393 if (present_gnu_tree (gnat_entity)) 1394 { 1395 maybe_present = 1; 1396 break; 1397 } 1398 1399 layout_type (gnu_type); 1400 } 1401 break; 1402 1403 /* Array and String Types and Subtypes 1404 1405 Unconstrained array types are represented by E_Array_Type and 1406 constrained array types are represented by E_Array_Subtype. There 1407 are no actual objects of an unconstrained array type; all we have 1408 are pointers to that type. 1409 1410 The following fields are defined on array types and subtypes: 1411 1412 Component_Type Component type of the array. 1413 Number_Dimensions Number of dimensions (an int). 1414 First_Index Type of first index. */ 1415 1416 case E_String_Type: 1417 case E_Array_Type: 1418 { 1419 tree gnu_template_fields = NULL_TREE; 1420 tree gnu_template_type = make_node (RECORD_TYPE); 1421 tree gnu_ptr_template = build_pointer_type (gnu_template_type); 1422 tree gnu_fat_type = make_node (RECORD_TYPE); 1423 int ndim = Number_Dimensions (gnat_entity); 1424 int firstdim 1425 = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0; 1426 int nextdim 1427 = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1; 1428 tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *)); 1429 tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *)); 1430 tree gnu_comp_size = 0; 1431 tree gnu_max_size = size_one_node; 1432 tree gnu_max_size_unit; 1433 int index; 1434 Entity_Id gnat_ind_subtype; 1435 Entity_Id gnat_ind_base_subtype; 1436 tree gnu_template_reference; 1437 tree tem; 1438 1439 TYPE_NAME (gnu_template_type) 1440 = create_concat_name (gnat_entity, "XUB"); 1441 TYPE_NAME (gnu_fat_type) = create_concat_name (gnat_entity, "XUP"); 1442 TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1; 1443 TREE_READONLY (gnu_template_type) = 1; 1444 1445 /* Make a node for the array. If we are not defining the array 1446 suppress expanding incomplete types and save the node as the type 1447 for GNAT_ENTITY. */ 1448 gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE); 1449 if (! definition) 1450 { 1451 defer_incomplete_level++; 1452 this_deferred = this_made_decl = 1; 1453 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, 1454 ! Comes_From_Source (gnat_entity), 1455 debug_info_p); 1456 save_gnu_tree (gnat_entity, gnu_decl, 0); 1457 saved = 1; 1458 } 1459 1460 /* Build the fat pointer type. Use a "void *" object instead of 1461 a pointer to the array type since we don't have the array type 1462 yet (it will reference the fat pointer via the bounds). */ 1463 tem = chainon (chainon (NULL_TREE, 1464 create_field_decl (get_identifier ("P_ARRAY"), 1465 ptr_void_type_node, 1466 gnu_fat_type, 0, 0, 0, 0)), 1467 create_field_decl (get_identifier ("P_BOUNDS"), 1468 gnu_ptr_template, 1469 gnu_fat_type, 0, 0, 0, 0)); 1470 1471 /* Make sure we can put this into a register. */ 1472 TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); 1473 finish_record_type (gnu_fat_type, tem, 0, 1); 1474 1475 /* Build a reference to the template from a PLACEHOLDER_EXPR that 1476 is the fat pointer. This will be used to access the individual 1477 fields once we build them. */ 1478 tem = build (COMPONENT_REF, gnu_ptr_template, 1479 build (PLACEHOLDER_EXPR, gnu_fat_type), 1480 TREE_CHAIN (TYPE_FIELDS (gnu_fat_type))); 1481 gnu_template_reference 1482 = build_unary_op (INDIRECT_REF, gnu_template_type, tem); 1483 TREE_READONLY (gnu_template_reference) = 1; 1484 1485 /* Now create the GCC type for each index and add the fields for 1486 that index to the template. */ 1487 for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity), 1488 gnat_ind_base_subtype 1489 = First_Index (Implementation_Base_Type (gnat_entity)); 1490 index < ndim && index >= 0; 1491 index += nextdim, 1492 gnat_ind_subtype = Next_Index (gnat_ind_subtype), 1493 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) 1494 { 1495 char field_name[10]; 1496 tree gnu_ind_subtype 1497 = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype))); 1498 tree gnu_base_subtype 1499 = get_unpadded_type (Etype (gnat_ind_base_subtype)); 1500 tree gnu_base_min 1501 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); 1502 tree gnu_base_max 1503 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); 1504 tree gnu_min_field, gnu_max_field, gnu_min, gnu_max; 1505 1506 /* Make the FIELD_DECLs for the minimum and maximum of this 1507 type and then make extractions of that field from the 1508 template. */ 1509 set_lineno (gnat_entity, 0); 1510 sprintf (field_name, "LB%d", index); 1511 gnu_min_field = create_field_decl (get_identifier (field_name), 1512 gnu_ind_subtype, 1513 gnu_template_type, 0, 0, 0, 0); 1514 field_name[0] = 'U'; 1515 gnu_max_field = create_field_decl (get_identifier (field_name), 1516 gnu_ind_subtype, 1517 gnu_template_type, 0, 0, 0, 0); 1518 1519 gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field); 1520 1521 /* We can't use build_component_ref here since the template 1522 type isn't complete yet. */ 1523 gnu_min = build (COMPONENT_REF, gnu_ind_subtype, 1524 gnu_template_reference, gnu_min_field); 1525 gnu_max = build (COMPONENT_REF, gnu_ind_subtype, 1526 gnu_template_reference, gnu_max_field); 1527 TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1; 1528 1529 /* Make a range type with the new ranges, but using 1530 the Ada subtype. Then we convert to sizetype. */ 1531 gnu_index_types[index] 1532 = create_index_type (convert (sizetype, gnu_min), 1533 convert (sizetype, gnu_max), 1534 build_range_type (gnu_ind_subtype, 1535 gnu_min, gnu_max)); 1536 /* Update the maximum size of the array, in elements. */ 1537 gnu_max_size 1538 = size_binop (MULT_EXPR, gnu_max_size, 1539 size_binop (PLUS_EXPR, size_one_node, 1540 size_binop (MINUS_EXPR, gnu_base_max, 1541 gnu_base_min))); 1542 1543 TYPE_NAME (gnu_index_types[index]) 1544 = create_concat_name (gnat_entity, field_name); 1545 } 1546 1547 for (index = 0; index < ndim; index++) 1548 gnu_template_fields 1549 = chainon (gnu_template_fields, gnu_temp_fields[index]); 1550 1551 /* Install all the fields into the template. */ 1552 finish_record_type (gnu_template_type, gnu_template_fields, 0, 0); 1553 TREE_READONLY (gnu_template_type) = 1; 1554 1555 /* Now make the array of arrays and update the pointer to the array 1556 in the fat pointer. Note that it is the first field. */ 1557 1558 tem = gnat_to_gnu_type (Component_Type (gnat_entity)); 1559 1560 /* Get and validate any specified Component_Size, but if Packed, 1561 ignore it since the front end will have taken care of it. */ 1562 gnu_comp_size 1563 = validate_size (Component_Size (gnat_entity), tem, 1564 gnat_entity, 1565 (Is_Bit_Packed_Array (gnat_entity) 1566 ? TYPE_DECL : VAR_DECL), 1, 1567 Has_Component_Size_Clause (gnat_entity)); 1568 1569 if (Has_Atomic_Components (gnat_entity)) 1570 check_ok_for_atomic (tem, gnat_entity, 1); 1571 1572 /* If the component type is a RECORD_TYPE that has a self-referential 1573 size, use the maxium size. */ 1574 if (gnu_comp_size == 0 && TREE_CODE (tem) == RECORD_TYPE 1575 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem))) 1576 gnu_comp_size = max_size (TYPE_SIZE (tem), 1); 1577 1578 if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0) 1579 { 1580 tem = make_type_from_size (tem, gnu_comp_size, 0); 1581 tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity, 1582 "C_PAD", 0, definition, 1); 1583 } 1584 1585 if (Has_Volatile_Components (gnat_entity)) 1586 tem = build_qualified_type (tem, 1587 TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE); 1588 1589 /* If Component_Size is not already specified, annotate it with the 1590 size of the component. */ 1591 if (Unknown_Component_Size (gnat_entity)) 1592 Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem))); 1593 1594 gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node, 1595 size_binop (MULT_EXPR, gnu_max_size, 1596 TYPE_SIZE_UNIT (tem))); 1597 gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node, 1598 size_binop (MULT_EXPR, 1599 convert (bitsizetype, 1600 gnu_max_size), 1601 TYPE_SIZE (tem))); 1602 1603 for (index = ndim - 1; index >= 0; index--) 1604 { 1605 tem = build_array_type (tem, gnu_index_types[index]); 1606 TYPE_MULTI_ARRAY_P (tem) = (index > 0); 1607 1608 /* ??? For now, we say that any component of aggregate type is 1609 addressable because the front end may take 'Reference of it. 1610 But we have to make it addressable if it must be passed by 1611 reference or it that is the default. */ 1612 TYPE_NONALIASED_COMPONENT (tem) 1613 = (! Has_Aliased_Components (gnat_entity) 1614 && ! AGGREGATE_TYPE_P (TREE_TYPE (tem))); 1615 } 1616 1617 /* If an alignment is specified, use it if valid. But ignore it for 1618 types that represent the unpacked base type for packed arrays. */ 1619 if (No (Packed_Array_Type (gnat_entity)) 1620 && Known_Alignment (gnat_entity)) 1621 { 1622 if (No (Alignment (gnat_entity))) 1623 gigi_abort (124); 1624 1625 TYPE_ALIGN (tem) 1626 = validate_alignment (Alignment (gnat_entity), gnat_entity, 1627 TYPE_ALIGN (tem)); 1628 } 1629 1630 TYPE_CONVENTION_FORTRAN_P (tem) 1631 = (Convention (gnat_entity) == Convention_Fortran); 1632 TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); 1633 1634 /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the 1635 corresponding fat pointer. */ 1636 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) 1637 = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type; 1638 TYPE_MODE (gnu_type) = BLKmode; 1639 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem); 1640 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type); 1641 1642 /* If the maximum size doesn't overflow, use it. */ 1643 if (TREE_CODE (gnu_max_size) == INTEGER_CST 1644 && ! TREE_OVERFLOW (gnu_max_size)) 1645 TYPE_SIZE (tem) 1646 = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem)); 1647 if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST 1648 && ! TREE_OVERFLOW (gnu_max_size_unit)) 1649 TYPE_SIZE_UNIT (tem) 1650 = size_binop (MIN_EXPR, gnu_max_size_unit, 1651 TYPE_SIZE_UNIT (tem)); 1652 1653 create_type_decl (create_concat_name (gnat_entity, "XUA"), 1654 tem, 0, ! Comes_From_Source (gnat_entity), 1655 debug_info_p); 1656 rest_of_type_compilation (gnu_fat_type, global_bindings_p ()); 1657 1658 /* Create a record type for the object and its template and 1659 set the template at a negative offset. */ 1660 tem = build_unc_object_type (gnu_template_type, tem, 1661 create_concat_name (gnat_entity, "XUT")); 1662 DECL_FIELD_OFFSET (TYPE_FIELDS (tem)) 1663 = size_binop (MINUS_EXPR, size_zero_node, 1664 byte_position (TREE_CHAIN (TYPE_FIELDS (tem)))); 1665 DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node; 1666 DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) 1667 = bitsize_zero_node; 1668 SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type); 1669 TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem; 1670 1671 /* Give the thin pointer type a name. */ 1672 create_type_decl (create_concat_name (gnat_entity, "XUX"), 1673 build_pointer_type (tem), 0, 1674 ! Comes_From_Source (gnat_entity), debug_info_p); 1675 } 1676 break; 1677 1678 case E_String_Subtype: 1679 case E_Array_Subtype: 1680 1681 /* This is the actual data type for array variables. Multidimensional 1682 arrays are implemented in the gnu tree as arrays of arrays. Note 1683 that for the moment arrays which have sparse enumeration subtypes as 1684 index components create sparse arrays, which is obviously space 1685 inefficient but so much easier to code for now. 1686 1687 Also note that the subtype never refers to the unconstrained 1688 array type, which is somewhat at variance with Ada semantics. 1689 1690 First check to see if this is simply a renaming of the array 1691 type. If so, the result is the array type. */ 1692 1693 gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); 1694 if (! Is_Constrained (gnat_entity)) 1695 break; 1696 else 1697 { 1698 int index; 1699 int array_dim = Number_Dimensions (gnat_entity); 1700 int first_dim 1701 = ((Convention (gnat_entity) == Convention_Fortran) 1702 ? array_dim - 1 : 0); 1703 int next_dim 1704 = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1; 1705 Entity_Id gnat_ind_subtype; 1706 Entity_Id gnat_ind_base_subtype; 1707 tree gnu_base_type = gnu_type; 1708 tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *)); 1709 tree gnu_comp_size = 0; 1710 tree gnu_max_size = size_one_node; 1711 tree gnu_max_size_unit; 1712 int need_index_type_struct = 0; 1713 int max_overflow = 0; 1714 1715 /* First create the gnu types for each index. Create types for 1716 debugging information to point to the index types if the 1717 are not integer types, have variable bounds, or are 1718 wider than sizetype. */ 1719 1720 for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity), 1721 gnat_ind_base_subtype 1722 = First_Index (Implementation_Base_Type (gnat_entity)); 1723 index < array_dim && index >= 0; 1724 index += next_dim, 1725 gnat_ind_subtype = Next_Index (gnat_ind_subtype), 1726 gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype)) 1727 { 1728 tree gnu_index_subtype 1729 = get_unpadded_type (Etype (gnat_ind_subtype)); 1730 tree gnu_min 1731 = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype)); 1732 tree gnu_max 1733 = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype)); 1734 tree gnu_base_subtype 1735 = get_unpadded_type (Etype (gnat_ind_base_subtype)); 1736 tree gnu_base_min 1737 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype)); 1738 tree gnu_base_max 1739 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype)); 1740 tree gnu_base_type = get_base_type (gnu_base_subtype); 1741 tree gnu_base_base_min 1742 = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type)); 1743 tree gnu_base_base_max 1744 = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type)); 1745 tree gnu_high; 1746 tree gnu_this_max; 1747 1748 /* If the minimum and maximum values both overflow in 1749 SIZETYPE, but the difference in the original type 1750 does not overflow in SIZETYPE, ignore the overflow 1751 indications. */ 1752 if ((TYPE_PRECISION (gnu_index_subtype) 1753 > TYPE_PRECISION (sizetype)) 1754 && TREE_CODE (gnu_min) == INTEGER_CST 1755 && TREE_CODE (gnu_max) == INTEGER_CST 1756 && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max) 1757 && (! TREE_OVERFLOW 1758 (fold (build (MINUS_EXPR, gnu_index_subtype, 1759 TYPE_MAX_VALUE (gnu_index_subtype), 1760 TYPE_MIN_VALUE (gnu_index_subtype)))))) 1761 TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max) 1762 = TREE_CONSTANT_OVERFLOW (gnu_min) 1763 = TREE_CONSTANT_OVERFLOW (gnu_max) = 0; 1764 1765 /* Similarly, if the range is null, use bounds of 1..0 for 1766 the sizetype bounds. */ 1767 else if ((TYPE_PRECISION (gnu_index_subtype) 1768 > TYPE_PRECISION (sizetype)) 1769 && TREE_CODE (gnu_min) == INTEGER_CST 1770 && TREE_CODE (gnu_max) == INTEGER_CST 1771 && (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max)) 1772 && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype), 1773 TYPE_MIN_VALUE (gnu_index_subtype))) 1774 gnu_min = size_one_node, gnu_max = size_zero_node; 1775 1776 /* Now compute the size of this bound. We need to provide 1777 GCC with an upper bound to use but have to deal with the 1778 "superflat" case. There are three ways to do this. If we 1779 can prove that the array can never be superflat, we can 1780 just use the high bound of the index subtype. If we can 1781 prove that the low bound minus one can't overflow, we 1782 can do this as MAX (hb, lb - 1). Otherwise, we have to use 1783 the expression hb >= lb ? hb : lb - 1. */ 1784 gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node); 1785 1786 /* See if the base array type is already flat. If it is, we 1787 are probably compiling an ACVC test, but it will cause the 1788 code below to malfunction if we don't handle it specially. */ 1789 if (TREE_CODE (gnu_base_min) == INTEGER_CST 1790 && TREE_CODE (gnu_base_max) == INTEGER_CST 1791 && ! TREE_CONSTANT_OVERFLOW (gnu_base_min) 1792 && ! TREE_CONSTANT_OVERFLOW (gnu_base_max) 1793 && tree_int_cst_lt (gnu_base_max, gnu_base_min)) 1794 gnu_high = size_zero_node, gnu_min = size_one_node; 1795 1796 /* If gnu_high is now an integer which overflowed, the array 1797 cannot be superflat. */ 1798 else if (TREE_CODE (gnu_high) == INTEGER_CST 1799 && TREE_OVERFLOW (gnu_high)) 1800 gnu_high = gnu_max; 1801 else if (TREE_UNSIGNED (gnu_base_subtype) 1802 || TREE_CODE (gnu_high) == INTEGER_CST) 1803 gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high); 1804 else 1805 gnu_high 1806 = build_cond_expr 1807 (sizetype, build_binary_op (GE_EXPR, integer_type_node, 1808 gnu_max, gnu_min), 1809 gnu_max, gnu_high); 1810 1811 gnu_index_type[index] 1812 = create_index_type (gnu_min, gnu_high, gnu_index_subtype); 1813 1814 /* Also compute the maximum size of the array. Here we 1815 see if any constraint on the index type of the base type 1816 can be used in the case of self-referential bound on 1817 the index type of the subtype. We look for a non-"infinite" 1818 and non-self-referential bound from any type involved and 1819 handle each bound separately. */ 1820 1821 if ((TREE_CODE (gnu_min) == INTEGER_CST 1822 && ! TREE_OVERFLOW (gnu_min) 1823 && ! operand_equal_p (gnu_min, gnu_base_base_min, 0)) 1824 || ! CONTAINS_PLACEHOLDER_P (gnu_min)) 1825 gnu_base_min = gnu_min; 1826 1827 if ((TREE_CODE (gnu_max) == INTEGER_CST 1828 && ! TREE_OVERFLOW (gnu_max) 1829 && ! operand_equal_p (gnu_max, gnu_base_base_max, 0)) 1830 || ! CONTAINS_PLACEHOLDER_P (gnu_max)) 1831 gnu_base_max = gnu_max; 1832 1833 if ((TREE_CODE (gnu_base_min) == INTEGER_CST 1834 && TREE_CONSTANT_OVERFLOW (gnu_base_min)) 1835 || operand_equal_p (gnu_base_min, gnu_base_base_min, 0) 1836 || (TREE_CODE (gnu_base_max) == INTEGER_CST 1837 && TREE_CONSTANT_OVERFLOW (gnu_base_max)) 1838 || operand_equal_p (gnu_base_max, gnu_base_base_max, 0)) 1839 max_overflow = 1; 1840 1841 gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min); 1842 gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max); 1843 1844 gnu_this_max 1845 = size_binop (MAX_EXPR, 1846 size_binop (PLUS_EXPR, size_one_node, 1847 size_binop (MINUS_EXPR, gnu_base_max, 1848 gnu_base_min)), 1849 size_zero_node); 1850 1851 if (TREE_CODE (gnu_this_max) == INTEGER_CST 1852 && TREE_CONSTANT_OVERFLOW (gnu_this_max)) 1853 max_overflow = 1; 1854 1855 gnu_max_size 1856 = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max); 1857 1858 if (! integer_onep (TYPE_MIN_VALUE (gnu_index_subtype)) 1859 || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype)) 1860 != INTEGER_CST) 1861 || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE 1862 || (TREE_TYPE (gnu_index_subtype) != 0 1863 && (TREE_CODE (TREE_TYPE (gnu_index_subtype)) 1864 != INTEGER_TYPE)) 1865 || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype) 1866 || (TYPE_PRECISION (gnu_index_subtype) 1867 > TYPE_PRECISION (sizetype))) 1868 need_index_type_struct = 1; 1869 } 1870 1871 /* Then flatten: create the array of arrays. */ 1872 1873 gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity)); 1874 1875 /* One of the above calls might have caused us to be elaborated, 1876 so don't blow up if so. */ 1877 if (present_gnu_tree (gnat_entity)) 1878 { 1879 maybe_present = 1; 1880 break; 1881 } 1882 1883 /* Get and validate any specified Component_Size, but if Packed, 1884 ignore it since the front end will have taken care of it. */ 1885 gnu_comp_size 1886 = validate_size (Component_Size (gnat_entity), gnu_type, 1887 gnat_entity, 1888 (Is_Bit_Packed_Array (gnat_entity) 1889 ? TYPE_DECL : VAR_DECL), 1890 1, Has_Component_Size_Clause (gnat_entity)); 1891 1892 /* If the component type is a RECORD_TYPE that has a self-referential 1893 size, use the maxium size. */ 1894 if (gnu_comp_size == 0 && TREE_CODE (gnu_type) == RECORD_TYPE 1895 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) 1896 gnu_comp_size = max_size (TYPE_SIZE (gnu_type), 1); 1897 1898 if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0) 1899 { 1900 gnu_type = make_type_from_size (gnu_type, gnu_comp_size, 0); 1901 gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, 1902 gnat_entity, "C_PAD", 0, 1903 definition, 1); 1904 } 1905 1906 if (Has_Volatile_Components (Base_Type (gnat_entity))) 1907 gnu_type = build_qualified_type (gnu_type, 1908 (TYPE_QUALS (gnu_type) 1909 | TYPE_QUAL_VOLATILE)); 1910 1911 gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size, 1912 TYPE_SIZE_UNIT (gnu_type)); 1913 gnu_max_size = size_binop (MULT_EXPR, 1914 convert (bitsizetype, gnu_max_size), 1915 TYPE_SIZE (gnu_type)); 1916 1917 /* We don't want any array types shared for two reasons: first, 1918 we want to keep differently-named types distinct; second, 1919 setting TYPE_MULTI_ARRAY_TYPE of one type can clobber 1920 another. */ 1921 debug_no_type_hash = 1; 1922 for (index = array_dim - 1; index >= 0; index --) 1923 { 1924 gnu_type = build_array_type (gnu_type, gnu_index_type[index]); 1925 TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0); 1926 /* ??? For now, we say that any component of aggregate type is 1927 addressable because the front end may take 'Reference. 1928 But we have to make it addressable if it must be passed by 1929 reference or it that is the default. */ 1930 TYPE_NONALIASED_COMPONENT (gnu_type) 1931 = (! Has_Aliased_Components (gnat_entity) 1932 && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_type))); 1933 } 1934 1935 /* If we are at file level and this is a multi-dimensional array, we 1936 need to make a variable corresponding to the stride of the 1937 inner dimensions. */ 1938 if (global_bindings_p () && array_dim > 1) 1939 { 1940 tree gnu_str_name = get_identifier ("ST"); 1941 tree gnu_arr_type; 1942 1943 for (gnu_arr_type = TREE_TYPE (gnu_type); 1944 TREE_CODE (gnu_arr_type) == ARRAY_TYPE; 1945 gnu_arr_type = TREE_TYPE (gnu_arr_type), 1946 gnu_str_name = concat_id_with_name (gnu_str_name, "ST")) 1947 { 1948 TYPE_SIZE (gnu_arr_type) 1949 = elaborate_expression_1 (gnat_entity, gnat_entity, 1950 TYPE_SIZE (gnu_arr_type), 1951 gnu_str_name, definition, 0); 1952 TYPE_SIZE_UNIT (gnu_arr_type) 1953 = elaborate_expression_1 1954 (gnat_entity, gnat_entity, TYPE_SIZE_UNIT (gnu_arr_type), 1955 concat_id_with_name (gnu_str_name, "U"), definition, 0); 1956 } 1957 } 1958 1959 /* If we need to write out a record type giving the names of 1960 the bounds, do it now. */ 1961 if (need_index_type_struct && debug_info_p) 1962 { 1963 tree gnu_bound_rec_type = make_node (RECORD_TYPE); 1964 tree gnu_field_list = 0; 1965 tree gnu_field; 1966 1967 TYPE_NAME (gnu_bound_rec_type) 1968 = create_concat_name (gnat_entity, "XA"); 1969 1970 for (index = array_dim - 1; index >= 0; index--) 1971 { 1972 tree gnu_type_name 1973 = TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index])); 1974 1975 if (TREE_CODE (gnu_type_name) == TYPE_DECL) 1976 gnu_type_name = DECL_NAME (gnu_type_name); 1977 1978 gnu_field = create_field_decl (gnu_type_name, 1979 integer_type_node, 1980 gnu_bound_rec_type, 1981 0, NULL_TREE, NULL_TREE, 0); 1982 TREE_CHAIN (gnu_field) = gnu_field_list; 1983 gnu_field_list = gnu_field; 1984 } 1985 1986 finish_record_type (gnu_bound_rec_type, gnu_field_list, 0, 0); 1987 } 1988 1989 debug_no_type_hash = 0; 1990 TYPE_CONVENTION_FORTRAN_P (gnu_type) 1991 = (Convention (gnat_entity) == Convention_Fortran); 1992 TYPE_PACKED_ARRAY_TYPE_P (gnu_type) 1993 = Is_Packed_Array_Type (gnat_entity); 1994 1995 /* If our size depends on a placeholder and the maximum size doesn't 1996 overflow, use it. */ 1997 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) 1998 && ! (TREE_CODE (gnu_max_size) == INTEGER_CST 1999 && TREE_OVERFLOW (gnu_max_size)) 2000 && ! (TREE_CODE (gnu_max_size_unit) == INTEGER_CST 2001 && TREE_OVERFLOW (gnu_max_size_unit)) 2002 && ! max_overflow) 2003 { 2004 TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size, 2005 TYPE_SIZE (gnu_type)); 2006 TYPE_SIZE_UNIT (gnu_type) 2007 = size_binop (MIN_EXPR, gnu_max_size_unit, 2008 TYPE_SIZE_UNIT (gnu_type)); 2009 } 2010 2011 /* Set our alias set to that of our base type. This gives all 2012 array subtypes the same alias set. */ 2013 TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type); 2014 record_component_aliases (gnu_type); 2015 } 2016 2017 /* If this is a packed type, make this type the same as the packed 2018 array type, but do some adjusting in the type first. */ 2019 2020 if (Present (Packed_Array_Type (gnat_entity))) 2021 { 2022 Entity_Id gnat_index; 2023 tree gnu_inner_type; 2024 2025 /* First finish the type we had been making so that we output 2026 debugging information for it */ 2027 gnu_type = build_qualified_type (gnu_type, 2028 (TYPE_QUALS (gnu_type) 2029 | (TYPE_QUAL_VOLATILE 2030 * Treat_As_Volatile (gnat_entity)))); 2031 set_lineno (gnat_entity, 0); 2032 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, 2033 ! Comes_From_Source (gnat_entity), 2034 debug_info_p); 2035 if (! Comes_From_Source (gnat_entity)) 2036 DECL_ARTIFICIAL (gnu_decl) = 1; 2037 2038 /* Save it as our equivalent in case the call below elaborates 2039 this type again. */ 2040 save_gnu_tree (gnat_entity, gnu_decl, 0); 2041 2042 gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity), 2043 NULL_TREE, 0); 2044 this_made_decl = 1; 2045 gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl); 2046 save_gnu_tree (gnat_entity, NULL_TREE, 0); 2047 2048 while (TREE_CODE (gnu_inner_type) == RECORD_TYPE 2049 && (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type) 2050 || TYPE_IS_PADDING_P (gnu_inner_type))) 2051 gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type)); 2052 2053 /* We need to point the type we just made to our index type so 2054 the actual bounds can be put into a template. */ 2055 2056 if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE 2057 && TYPE_ACTUAL_BOUNDS (gnu_inner_type) == 0) 2058 || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE 2059 && ! TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type))) 2060 { 2061 if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE) 2062 { 2063 /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus. 2064 If it is, we need to make another type. */ 2065 if (TYPE_MODULAR_P (gnu_inner_type)) 2066 { 2067 tree gnu_subtype; 2068 2069 gnu_subtype = make_node (INTEGER_TYPE); 2070 2071 TREE_TYPE (gnu_subtype) = gnu_inner_type; 2072 TYPE_MIN_VALUE (gnu_subtype) 2073 = TYPE_MIN_VALUE (gnu_inner_type); 2074 TYPE_MAX_VALUE (gnu_subtype) 2075 = TYPE_MAX_VALUE (gnu_inner_type); 2076 TYPE_PRECISION (gnu_subtype) 2077 = TYPE_PRECISION (gnu_inner_type); 2078 TREE_UNSIGNED (gnu_subtype) 2079 = TREE_UNSIGNED (gnu_inner_type); 2080 TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1; 2081 layout_type (gnu_subtype); 2082 2083 gnu_inner_type = gnu_subtype; 2084 } 2085 2086 TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1; 2087 } 2088 2089 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE); 2090 2091 for (gnat_index = First_Index (gnat_entity); 2092 Present (gnat_index); gnat_index = Next_Index (gnat_index)) 2093 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, 2094 tree_cons (NULL_TREE, 2095 get_unpadded_type (Etype (gnat_index)), 2096 TYPE_ACTUAL_BOUNDS (gnu_inner_type))); 2097 2098 if (Convention (gnat_entity) != Convention_Fortran) 2099 SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, 2100 nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type))); 2101 2102 if (TREE_CODE (gnu_type) == RECORD_TYPE 2103 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type)) 2104 TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type; 2105 } 2106 } 2107 2108 /* Abort if packed array with no packed array type field set. */ 2109 else if (Is_Packed (gnat_entity)) 2110 gigi_abort (107); 2111 2112 break; 2113 2114 case E_String_Literal_Subtype: 2115 /* Create the type for a string literal. */ 2116 { 2117 Entity_Id gnat_full_type 2118 = (IN (Ekind (Etype (gnat_entity)), Private_Kind) 2119 && Present (Full_View (Etype (gnat_entity))) 2120 ? Full_View (Etype (gnat_entity)) : Etype (gnat_entity)); 2121 tree gnu_string_type = get_unpadded_type (gnat_full_type); 2122 tree gnu_string_array_type 2123 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type)))); 2124 tree gnu_string_index_type 2125 = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE 2126 (TYPE_DOMAIN (gnu_string_array_type)))); 2127 tree gnu_lower_bound 2128 = convert (gnu_string_index_type, 2129 gnat_to_gnu (String_Literal_Low_Bound (gnat_entity))); 2130 int length = UI_To_Int (String_Literal_Length (gnat_entity)); 2131 tree gnu_length = ssize_int (length - 1); 2132 tree gnu_upper_bound 2133 = build_binary_op (PLUS_EXPR, gnu_string_index_type, 2134 gnu_lower_bound, 2135 convert (gnu_string_index_type, gnu_length)); 2136 tree gnu_range_type 2137 = build_range_type (gnu_string_index_type, 2138 gnu_lower_bound, gnu_upper_bound); 2139 tree gnu_index_type 2140 = create_index_type (convert (sizetype, 2141 TYPE_MIN_VALUE (gnu_range_type)), 2142 convert (sizetype, 2143 TYPE_MAX_VALUE (gnu_range_type)), 2144 gnu_range_type); 2145 2146 gnu_type 2147 = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)), 2148 gnu_index_type); 2149 } 2150 break; 2151 2152 /* Record Types and Subtypes 2153 2154 The following fields are defined on record types: 2155 2156 Has_Discriminants True if the record has discriminants 2157 First_Discriminant Points to head of list of discriminants 2158 First_Entity Points to head of list of fields 2159 Is_Tagged_Type True if the record is tagged 2160 2161 Implementation of Ada records and discriminated records: 2162 2163 A record type definition is transformed into the equivalent of a C 2164 struct definition. The fields that are the discriminants which are 2165 found in the Full_Type_Declaration node and the elements of the 2166 Component_List found in the Record_Type_Definition node. The 2167 Component_List can be a recursive structure since each Variant of 2168 the Variant_Part of the Component_List has a Component_List. 2169 2170 Processing of a record type definition comprises starting the list of 2171 field declarations here from the discriminants and the calling the 2172 function components_to_record to add the rest of the fields from the 2173 component list and return the gnu type node. The function 2174 components_to_record will call itself recursively as it traverses 2175 the tree. */ 2176 2177 case E_Record_Type: 2178 if (Has_Complex_Representation (gnat_entity)) 2179 { 2180 gnu_type 2181 = build_complex_type 2182 (get_unpadded_type 2183 (Etype (Defining_Entity 2184 (First (Component_Items 2185 (Component_List 2186 (Type_Definition 2187 (Declaration_Node (gnat_entity))))))))); 2188 2189 break; 2190 } 2191 2192 { 2193 Node_Id full_definition = Declaration_Node (gnat_entity); 2194 Node_Id record_definition = Type_Definition (full_definition); 2195 Entity_Id gnat_field; 2196 tree gnu_field; 2197 tree gnu_field_list = NULL_TREE; 2198 tree gnu_get_parent; 2199 int packed = (Is_Packed (gnat_entity) ? 1 2200 : (Component_Alignment (gnat_entity) 2201 == Calign_Storage_Unit) ? -1 2202 : 0); 2203 int has_rep = Has_Specified_Layout (gnat_entity); 2204 int all_rep = has_rep; 2205 int is_extension 2206 = (Is_Tagged_Type (gnat_entity) 2207 && Nkind (record_definition) == N_Derived_Type_Definition); 2208 2209 /* See if all fields have a rep clause. Stop when we find one 2210 that doesn't. */ 2211 for (gnat_field = First_Entity (gnat_entity); 2212 Present (gnat_field) && all_rep; 2213 gnat_field = Next_Entity (gnat_field)) 2214 if ((Ekind (gnat_field) == E_Component 2215 || Ekind (gnat_field) == E_Discriminant) 2216 && No (Component_Clause (gnat_field))) 2217 all_rep = 0; 2218 2219 /* If this is a record extension, go a level further to find the 2220 record definition. Also, verify we have a Parent_Subtype. */ 2221 if (is_extension) 2222 { 2223 if (! type_annotate_only 2224 || Present (Record_Extension_Part (record_definition))) 2225 record_definition = Record_Extension_Part (record_definition); 2226 2227 if (! type_annotate_only && No (Parent_Subtype (gnat_entity))) 2228 gigi_abort (121); 2229 } 2230 2231 /* Make a node for the record. If we are not defining the record, 2232 suppress expanding incomplete types and save the node as the type 2233 for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type 2234 and reset TYPE_DUMMY_P to show it's no longer a dummy. 2235 2236 It is very tempting to delay resetting this bit until we are done 2237 with completing the type, e.g. to let possible intermediate 2238 elaboration of access types designating the record know it is not 2239 complete and arrange for update_pointer_to to fix things up later. 2240 2241 It would be wrong, however, because dummy types are expected only 2242 to be created for Ada incomplete or private types, which is not 2243 what we have here. Doing so would make other parts of gigi think 2244 we are dealing with a really incomplete or private type, and have 2245 nasty side effects, typically on the generation of the associated 2246 debugging information. */ 2247 gnu_type = make_dummy_type (gnat_entity); 2248 TYPE_DUMMY_P (gnu_type) = 0; 2249 2250 if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p) 2251 DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0; 2252 2253 TYPE_ALIGN (gnu_type) = 0; 2254 TYPE_PACKED (gnu_type) = packed != 0 || has_rep; 2255 2256 if (! definition) 2257 { 2258 defer_incomplete_level++; 2259 this_deferred = 1; 2260 set_lineno (gnat_entity, 0); 2261 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, 2262 ! Comes_From_Source (gnat_entity), 2263 debug_info_p); 2264 save_gnu_tree (gnat_entity, gnu_decl, 0); 2265 this_made_decl = saved = 1; 2266 } 2267 2268 /* If both a size and rep clause was specified, put the size in 2269 the record type now so that it can get the proper mode. */ 2270 if (has_rep && Known_Esize (gnat_entity)) 2271 TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype); 2272 2273 /* Always set the alignment here so that it can be used to 2274 set the mode, if it is making the alignment stricter. If 2275 it is invalid, it will be checked again below. If this is to 2276 be Atomic, choose a default alignment of a word unless we know 2277 the size and it's smaller. */ 2278 if (Known_Alignment (gnat_entity)) 2279 TYPE_ALIGN (gnu_type) 2280 = validate_alignment (Alignment (gnat_entity), gnat_entity, 0); 2281 else if (Is_Atomic (gnat_entity)) 2282 TYPE_ALIGN (gnu_type) 2283 = (esize >= BITS_PER_WORD ? BITS_PER_WORD 2284 : 1 << ((floor_log2 (esize) - 1) + 1)); 2285 2286 /* If we have a Parent_Subtype, make a field for the parent. If 2287 this record has rep clauses, force the position to zero. */ 2288 if (Present (Parent_Subtype (gnat_entity))) 2289 { 2290 tree gnu_parent; 2291 2292 /* A major complexity here is that the parent subtype will 2293 reference our discriminants. But those must reference 2294 the parent component of this record. So here we will 2295 initialize each of those components to a COMPONENT_REF. 2296 The first operand of that COMPONENT_REF is another 2297 COMPONENT_REF which will be filled in below, once 2298 the parent type can be safely built. */ 2299 2300 gnu_get_parent = build (COMPONENT_REF, void_type_node, 2301 build (PLACEHOLDER_EXPR, gnu_type), 2302 build_decl (FIELD_DECL, NULL_TREE, 2303 NULL_TREE)); 2304 2305 if (Has_Discriminants (gnat_entity)) 2306 for (gnat_field = First_Stored_Discriminant (gnat_entity); 2307 Present (gnat_field); 2308 gnat_field = Next_Stored_Discriminant (gnat_field)) 2309 if (Present (Corresponding_Discriminant (gnat_field))) 2310 save_gnu_tree 2311 (gnat_field, 2312 build (COMPONENT_REF, 2313 get_unpadded_type (Etype (gnat_field)), 2314 gnu_get_parent, 2315 gnat_to_gnu_entity (Corresponding_Discriminant 2316 (gnat_field), 2317 NULL_TREE, 0)), 2318 1); 2319 2320 gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity)); 2321 2322 gnu_field_list 2323 = create_field_decl (get_identifier 2324 (Get_Name_String (Name_uParent)), 2325 gnu_parent, gnu_type, 0, 2326 has_rep ? TYPE_SIZE (gnu_parent) : 0, 2327 has_rep ? bitsize_zero_node : 0, 1); 2328 DECL_INTERNAL_P (gnu_field_list) = 1; 2329 2330 TREE_TYPE (gnu_get_parent) = gnu_parent; 2331 TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list; 2332 } 2333 2334 /* Add the fields for the discriminants into the record. */ 2335 if (! Is_Unchecked_Union (gnat_entity) 2336 && Has_Discriminants (gnat_entity)) 2337 for (gnat_field = First_Stored_Discriminant (gnat_entity); 2338 Present (gnat_field); 2339 gnat_field = Next_Stored_Discriminant (gnat_field)) 2340 { 2341 /* If this is a record extension and this discriminant 2342 is the renaming of another discriminant, we've already 2343 handled the discriminant above. */ 2344 if (Present (Parent_Subtype (gnat_entity)) 2345 && Present (Corresponding_Discriminant (gnat_field))) 2346 continue; 2347 2348 gnu_field 2349 = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition); 2350 2351 /* Make an expression using a PLACEHOLDER_EXPR from the 2352 FIELD_DECL node just created and link that with the 2353 corresponding GNAT defining identifier. Then add to the 2354 list of fields. */ 2355 save_gnu_tree (gnat_field, 2356 build (COMPONENT_REF, TREE_TYPE (gnu_field), 2357 build (PLACEHOLDER_EXPR, 2358 DECL_CONTEXT (gnu_field)), 2359 gnu_field), 2360 1); 2361 2362 TREE_CHAIN (gnu_field) = gnu_field_list; 2363 gnu_field_list = gnu_field; 2364 } 2365 2366 /* Put the discriminants into the record (backwards), so we can 2367 know the appropriate discriminant to use for the names of the 2368 variants. */ 2369 TYPE_FIELDS (gnu_type) = gnu_field_list; 2370 2371 /* Add the listed fields into the record and finish up. */ 2372 components_to_record (gnu_type, Component_List (record_definition), 2373 gnu_field_list, packed, definition, 0, 2374 0, all_rep); 2375 2376 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); 2377 TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity); 2378 2379 /* If this is an extension type, reset the tree for any 2380 inherited discriminants. Also remove the PLACEHOLDER_EXPR 2381 for non-inherited discriminants. */ 2382 if (! Is_Unchecked_Union (gnat_entity) 2383 && Has_Discriminants (gnat_entity)) 2384 for (gnat_field = First_Stored_Discriminant (gnat_entity); 2385 Present (gnat_field); 2386 gnat_field = Next_Stored_Discriminant (gnat_field)) 2387 { 2388 if (Present (Parent_Subtype (gnat_entity)) 2389 && Present (Corresponding_Discriminant (gnat_field))) 2390 save_gnu_tree (gnat_field, NULL_TREE, 0); 2391 else 2392 { 2393 gnu_field = get_gnu_tree (gnat_field); 2394 save_gnu_tree (gnat_field, NULL_TREE, 0); 2395 save_gnu_tree (gnat_field, TREE_OPERAND (gnu_field, 1), 0); 2396 } 2397 } 2398 2399 /* If it is a tagged record force the type to BLKmode to insure 2400 that these objects will always be placed in memory. Do the 2401 same thing for limited record types. */ 2402 if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity)) 2403 TYPE_MODE (gnu_type) = BLKmode; 2404 2405 /* If this is a derived type, we must make the alias set of this type 2406 the same as that of the type we are derived from. We assume here 2407 that the other type is already frozen. */ 2408 if (Etype (gnat_entity) != gnat_entity 2409 && ! (Is_Private_Type (Etype (gnat_entity)) 2410 && Full_View (Etype (gnat_entity)) == gnat_entity)) 2411 { 2412 TYPE_ALIAS_SET (gnu_type) 2413 = get_alias_set (gnat_to_gnu_type (Etype (gnat_entity))); 2414 record_component_aliases (gnu_type); 2415 } 2416 2417 /* Fill in locations of fields. */ 2418 annotate_rep (gnat_entity, gnu_type); 2419 2420 /* If there are any entities in the chain corresponding to 2421 components that we did not elaborate, ensure we elaborate their 2422 types if they are Itypes. */ 2423 for (gnat_temp = First_Entity (gnat_entity); 2424 Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp)) 2425 if ((Ekind (gnat_temp) == E_Component 2426 || Ekind (gnat_temp) == E_Discriminant) 2427 && Is_Itype (Etype (gnat_temp)) 2428 && ! present_gnu_tree (gnat_temp)) 2429 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); 2430 } 2431 break; 2432 2433 case E_Class_Wide_Subtype: 2434 /* If an equivalent type is present, that is what we should use. 2435 Otherwise, fall through to handle this like a record subtype 2436 since it may have constraints. */ 2437 2438 if (Present (Equivalent_Type (gnat_entity))) 2439 { 2440 gnu_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity), 2441 NULL_TREE, 0); 2442 maybe_present = 1; 2443 break; 2444 } 2445 2446 /* ... fall through ... */ 2447 2448 case E_Record_Subtype: 2449 2450 /* If Cloned_Subtype is Present it means this record subtype has 2451 identical layout to that type or subtype and we should use 2452 that GCC type for this one. The front end guarantees that 2453 the component list is shared. */ 2454 if (Present (Cloned_Subtype (gnat_entity))) 2455 { 2456 gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity), 2457 NULL_TREE, 0); 2458 maybe_present = 1; 2459 } 2460 2461 /* Otherwise, first ensure the base type is elaborated. Then, if we are 2462 changing the type, make a new type with each field having the 2463 type of the field in the new subtype but having the position 2464 computed by transforming every discriminant reference according 2465 to the constraints. We don't see any difference between 2466 private and nonprivate type here since derivations from types should 2467 have been deferred until the completion of the private type. */ 2468 else 2469 { 2470 Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity); 2471 tree gnu_base_type; 2472 tree gnu_orig_type; 2473 2474 if (! definition) 2475 defer_incomplete_level++, this_deferred = 1; 2476 2477 /* Get the base type initially for its alignment and sizes. But 2478 if it is a padded type, we do all the other work with the 2479 unpadded type. */ 2480 gnu_type = gnu_orig_type = gnu_base_type 2481 = gnat_to_gnu_type (gnat_base_type); 2482 2483 if (TREE_CODE (gnu_type) == RECORD_TYPE 2484 && TYPE_IS_PADDING_P (gnu_type)) 2485 gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); 2486 2487 if (present_gnu_tree (gnat_entity)) 2488 { 2489 maybe_present = 1; 2490 break; 2491 } 2492 2493 /* When the type has discriminants, and these discriminants 2494 affect the shape of what it built, factor them in. 2495 2496 If we are making a subtype of an Unchecked_Union (must be an 2497 Itype), just return the type. 2498 2499 We can't just use Is_Constrained because private subtypes without 2500 discriminants of full types with discriminants with default 2501 expressions are Is_Constrained but aren't constrained! */ 2502 2503 if (IN (Ekind (gnat_base_type), Record_Kind) 2504 && ! Is_For_Access_Subtype (gnat_entity) 2505 && ! Is_Unchecked_Union (gnat_base_type) 2506 && Is_Constrained (gnat_entity) 2507 && Stored_Constraint (gnat_entity) != No_Elist 2508 && Present (Discriminant_Constraint (gnat_entity))) 2509 { 2510 Entity_Id gnat_field; 2511 Entity_Id gnat_root_type; 2512 tree gnu_field_list = 0; 2513 tree gnu_pos_list 2514 = compute_field_positions (gnu_orig_type, NULL_TREE, 2515 size_zero_node, bitsize_zero_node, 2516 BIGGEST_ALIGNMENT); 2517 tree gnu_subst_list 2518 = substitution_list (gnat_entity, gnat_base_type, NULL_TREE, 2519 definition); 2520 tree gnu_temp; 2521 2522 /* If this is a derived type, we may be seeing fields from any 2523 original records, so add those positions and discriminant 2524 substitutions to our lists. */ 2525 for (gnat_root_type = gnat_base_type; 2526 Underlying_Type (Etype (gnat_root_type)) != gnat_root_type; 2527 gnat_root_type = Underlying_Type (Etype (gnat_root_type))) 2528 { 2529 gnu_pos_list 2530 = compute_field_positions 2531 (gnat_to_gnu_type (Etype (gnat_root_type)), 2532 gnu_pos_list, size_zero_node, bitsize_zero_node, 2533 BIGGEST_ALIGNMENT); 2534 2535 if (Present (Parent_Subtype (gnat_root_type))) 2536 gnu_subst_list 2537 = substitution_list (Parent_Subtype (gnat_root_type), 2538 Empty, gnu_subst_list, definition); 2539 } 2540 2541 gnu_type = make_node (RECORD_TYPE); 2542 TYPE_NAME (gnu_type) = gnu_entity_id; 2543 TYPE_STUB_DECL (gnu_type) 2544 = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type)); 2545 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); 2546 2547 for (gnat_field = First_Entity (gnat_entity); 2548 Present (gnat_field); gnat_field = Next_Entity (gnat_field)) 2549 if (Ekind (gnat_field) == E_Component 2550 || Ekind (gnat_field) == E_Discriminant) 2551 { 2552 tree gnu_old_field 2553 = gnat_to_gnu_entity 2554 (Original_Record_Component (gnat_field), NULL_TREE, 0); 2555 tree gnu_offset 2556 = TREE_VALUE (purpose_member (gnu_old_field, 2557 gnu_pos_list)); 2558 tree gnu_pos = TREE_PURPOSE (gnu_offset); 2559 tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset)); 2560 tree gnu_field_type 2561 = gnat_to_gnu_type (Etype (gnat_field)); 2562 tree gnu_size = TYPE_SIZE (gnu_field_type); 2563 tree gnu_new_pos = 0; 2564 unsigned int offset_align 2565 = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)), 2566 1); 2567 tree gnu_field; 2568 2569 /* If there was a component clause, the field types must be 2570 the same for the type and subtype, so copy the data from 2571 the old field to avoid recomputation here. */ 2572 if (Present (Component_Clause 2573 (Original_Record_Component (gnat_field)))) 2574 { 2575 gnu_size = DECL_SIZE (gnu_old_field); 2576 gnu_field_type = TREE_TYPE (gnu_old_field); 2577 } 2578 2579 /* If this was a bitfield, get the size from the old field. 2580 Also ensure the type can be placed into a bitfield. */ 2581 else if (DECL_BIT_FIELD (gnu_old_field)) 2582 { 2583 gnu_size = DECL_SIZE (gnu_old_field); 2584 if (TYPE_MODE (gnu_field_type) == BLKmode 2585 && TREE_CODE (gnu_field_type) == RECORD_TYPE 2586 && host_integerp (TYPE_SIZE (gnu_field_type), 1)) 2587 gnu_field_type = make_packable_type (gnu_field_type); 2588 } 2589 2590 if (CONTAINS_PLACEHOLDER_P (gnu_pos)) 2591 for (gnu_temp = gnu_subst_list; 2592 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) 2593 gnu_pos = substitute_in_expr (gnu_pos, 2594 TREE_PURPOSE (gnu_temp), 2595 TREE_VALUE (gnu_temp)); 2596 2597 /* If the size is now a constant, we can set it as the 2598 size of the field when we make it. Otherwise, we need 2599 to deal with it specially. */ 2600 if (TREE_CONSTANT (gnu_pos)) 2601 gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos); 2602 2603 gnu_field 2604 = create_field_decl 2605 (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type, 2606 0, gnu_size, gnu_new_pos, 2607 ! DECL_NONADDRESSABLE_P (gnu_old_field)); 2608 2609 if (! TREE_CONSTANT (gnu_pos)) 2610 { 2611 normalize_offset (&gnu_pos, &gnu_bitpos, offset_align); 2612 DECL_FIELD_OFFSET (gnu_field) = gnu_pos; 2613 DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos; 2614 SET_DECL_OFFSET_ALIGN (gnu_field, offset_align); 2615 DECL_SIZE (gnu_field) = gnu_size; 2616 DECL_SIZE_UNIT (gnu_field) 2617 = convert (sizetype, 2618 size_binop (CEIL_DIV_EXPR, gnu_size, 2619 bitsize_unit_node)); 2620 layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field)); 2621 } 2622 2623 DECL_INTERNAL_P (gnu_field) 2624 = DECL_INTERNAL_P (gnu_old_field); 2625 SET_DECL_ORIGINAL_FIELD (gnu_field, 2626 (DECL_ORIGINAL_FIELD (gnu_old_field) != 0 2627 ? DECL_ORIGINAL_FIELD (gnu_old_field) 2628 : gnu_old_field)); 2629 DECL_DISCRIMINANT_NUMBER (gnu_field) 2630 = DECL_DISCRIMINANT_NUMBER (gnu_old_field); 2631 TREE_THIS_VOLATILE (gnu_field) 2632 = TREE_THIS_VOLATILE (gnu_old_field); 2633 TREE_CHAIN (gnu_field) = gnu_field_list; 2634 gnu_field_list = gnu_field; 2635 save_gnu_tree (gnat_field, gnu_field, 0); 2636 } 2637 2638 finish_record_type (gnu_type, nreverse (gnu_field_list), 1, 0); 2639 2640 /* Now set the size, alignment and alias set of the new type to 2641 match that of the old one, doing any substitutions, as 2642 above. */ 2643 TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type); 2644 TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type); 2645 TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type); 2646 SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type)); 2647 TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type); 2648 record_component_aliases (gnu_type); 2649 2650 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) 2651 for (gnu_temp = gnu_subst_list; 2652 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) 2653 TYPE_SIZE (gnu_type) 2654 = substitute_in_expr (TYPE_SIZE (gnu_type), 2655 TREE_PURPOSE (gnu_temp), 2656 TREE_VALUE (gnu_temp)); 2657 2658 if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type))) 2659 for (gnu_temp = gnu_subst_list; 2660 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) 2661 TYPE_SIZE_UNIT (gnu_type) 2662 = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type), 2663 TREE_PURPOSE (gnu_temp), 2664 TREE_VALUE (gnu_temp)); 2665 2666 if (TYPE_ADA_SIZE (gnu_type) != 0 2667 && CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type))) 2668 for (gnu_temp = gnu_subst_list; 2669 gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp)) 2670 SET_TYPE_ADA_SIZE (gnu_type, 2671 substitute_in_expr (TYPE_ADA_SIZE (gnu_type), 2672 TREE_PURPOSE (gnu_temp), 2673 TREE_VALUE (gnu_temp))); 2674 2675 /* Recompute the mode of this record type now that we know its 2676 actual size. */ 2677 compute_record_mode (gnu_type); 2678 2679 /* Fill in locations of fields. */ 2680 annotate_rep (gnat_entity, gnu_type); 2681 } 2682 2683 /* If we've made a new type, record it and make an XVS type to show 2684 what this is a subtype of. Some debuggers require the XVS 2685 type to be output first, so do it in that order. */ 2686 if (gnu_type != gnu_orig_type) 2687 { 2688 if (debug_info_p) 2689 { 2690 tree gnu_subtype_marker = make_node (RECORD_TYPE); 2691 tree gnu_orig_name = TYPE_NAME (gnu_orig_type); 2692 2693 if (TREE_CODE (gnu_orig_name) == TYPE_DECL) 2694 gnu_orig_name = DECL_NAME (gnu_orig_name); 2695 2696 TYPE_NAME (gnu_subtype_marker) 2697 = create_concat_name (gnat_entity, "XVS"); 2698 finish_record_type (gnu_subtype_marker, 2699 create_field_decl (gnu_orig_name, 2700 integer_type_node, 2701 gnu_subtype_marker, 2702 0, NULL_TREE, 2703 NULL_TREE, 0), 2704 0, 0); 2705 } 2706 2707 TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); 2708 TYPE_NAME (gnu_type) = gnu_entity_id; 2709 TYPE_STUB_DECL (gnu_type) 2710 = pushdecl (build_decl (TYPE_DECL, TYPE_NAME (gnu_type), 2711 gnu_type)); 2712 DECL_ARTIFICIAL (TYPE_STUB_DECL (gnu_type)) = 1; 2713 DECL_IGNORED_P (TYPE_STUB_DECL (gnu_type)) = ! debug_info_p; 2714 rest_of_type_compilation (gnu_type, global_bindings_p ()); 2715 } 2716 2717 /* Otherwise, go down all the components in the new type and 2718 make them equivalent to those in the base type. */ 2719 else 2720 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); 2721 gnat_temp = Next_Entity (gnat_temp)) 2722 if ((Ekind (gnat_temp) == E_Discriminant 2723 && ! Is_Unchecked_Union (gnat_base_type)) 2724 || Ekind (gnat_temp) == E_Component) 2725 save_gnu_tree (gnat_temp, 2726 get_gnu_tree 2727 (Original_Record_Component (gnat_temp)), 0); 2728 } 2729 break; 2730 2731 case E_Access_Subprogram_Type: 2732 /* If we are not defining this entity, and we have incomplete 2733 entities being processed above us, make a dummy type and 2734 fill it in later. */ 2735 if (! definition && defer_incomplete_level != 0) 2736 { 2737 struct incomplete *p 2738 = (struct incomplete *) xmalloc (sizeof (struct incomplete)); 2739 2740 gnu_type 2741 = build_pointer_type 2742 (make_dummy_type (Directly_Designated_Type (gnat_entity))); 2743 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, 2744 ! Comes_From_Source (gnat_entity), 2745 debug_info_p); 2746 save_gnu_tree (gnat_entity, gnu_decl, 0); 2747 this_made_decl = saved = 1; 2748 2749 p->old_type = TREE_TYPE (gnu_type); 2750 p->full_type = Directly_Designated_Type (gnat_entity); 2751 p->next = defer_incomplete_list; 2752 defer_incomplete_list = p; 2753 break; 2754 } 2755 2756 /* ... fall through ... */ 2757 2758 case E_Allocator_Type: 2759 case E_Access_Type: 2760 case E_Access_Attribute_Type: 2761 case E_Anonymous_Access_Type: 2762 case E_General_Access_Type: 2763 { 2764 Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity); 2765 Entity_Id gnat_desig_full 2766 = ((IN (Ekind (Etype (gnat_desig_type)), 2767 Incomplete_Or_Private_Kind)) 2768 ? Full_View (gnat_desig_type) : 0); 2769 /* We want to know if we'll be seeing the freeze node for any 2770 incomplete type we may be pointing to. */ 2771 int in_main_unit 2772 = (Present (gnat_desig_full) 2773 ? In_Extended_Main_Code_Unit (gnat_desig_full) 2774 : In_Extended_Main_Code_Unit (gnat_desig_type)); 2775 int got_fat_p = 0; 2776 int made_dummy = 0; 2777 tree gnu_desig_type = 0; 2778 2779 if (No (gnat_desig_full) 2780 && (Ekind (gnat_desig_type) == E_Class_Wide_Type 2781 || (Ekind (gnat_desig_type) == E_Class_Wide_Subtype 2782 && Present (Equivalent_Type (gnat_desig_type))))) 2783 { 2784 if (Present (Equivalent_Type (gnat_desig_type))) 2785 { 2786 gnat_desig_full = Equivalent_Type (gnat_desig_type); 2787 if (IN (Ekind (gnat_desig_full), Incomplete_Or_Private_Kind)) 2788 gnat_desig_full = Full_View (gnat_desig_full); 2789 } 2790 else if (IN (Ekind (Root_Type (gnat_desig_type)), 2791 Incomplete_Or_Private_Kind)) 2792 gnat_desig_full = Full_View (Root_Type (gnat_desig_type)); 2793 } 2794 2795 if (Present (gnat_desig_full) && Is_Concurrent_Type (gnat_desig_full)) 2796 gnat_desig_full = Corresponding_Record_Type (gnat_desig_full); 2797 2798 /* If either the designated type or its full view is an 2799 unconstrained array subtype, replace it with the type it's a 2800 subtype of. This avoids problems with multiple copies of 2801 unconstrained array types. */ 2802 if (Ekind (gnat_desig_type) == E_Array_Subtype 2803 && ! Is_Constrained (gnat_desig_type)) 2804 gnat_desig_type = Etype (gnat_desig_type); 2805 if (Present (gnat_desig_full) 2806 && Ekind (gnat_desig_full) == E_Array_Subtype 2807 && ! Is_Constrained (gnat_desig_full)) 2808 gnat_desig_full = Etype (gnat_desig_full); 2809 2810 /* If the designated type is a subtype of an incomplete record type, 2811 use the parent type to avoid order of elaboration issues. This 2812 can lose some code efficiency, but there is no alternative. */ 2813 if (Present (gnat_desig_full) 2814 && Ekind (gnat_desig_full) == E_Record_Subtype 2815 && Ekind (Etype (gnat_desig_full)) == E_Record_Type) 2816 gnat_desig_full = Etype (gnat_desig_full); 2817 2818 /* If we are pointing to an incomplete type whose completion is an 2819 unconstrained array, make a fat pointer type instead of a pointer 2820 to VOID. The two types in our fields will be pointers to VOID and 2821 will be replaced in update_pointer_to. Similiarly, if the type 2822 itself is a dummy type or an unconstrained array. Also make 2823 a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin 2824 pointers to it. */ 2825 2826 if ((Present (gnat_desig_full) 2827 && Is_Array_Type (gnat_desig_full) 2828 && ! Is_Constrained (gnat_desig_full)) 2829 || (present_gnu_tree (gnat_desig_type) 2830 && TYPE_IS_DUMMY_P (TREE_TYPE 2831 (get_gnu_tree (gnat_desig_type))) 2832 && Is_Array_Type (gnat_desig_type) 2833 && ! Is_Constrained (gnat_desig_type)) 2834 || (present_gnu_tree (gnat_desig_type) 2835 && (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type))) 2836 == UNCONSTRAINED_ARRAY_TYPE) 2837 && (TYPE_POINTER_TO (TREE_TYPE 2838 (get_gnu_tree (gnat_desig_type))) 2839 == 0)) 2840 || (No (gnat_desig_full) && ! in_main_unit 2841 && defer_incomplete_level != 0 2842 && ! present_gnu_tree (gnat_desig_type) 2843 && Is_Array_Type (gnat_desig_type) 2844 && ! Is_Constrained (gnat_desig_type))) 2845 { 2846 tree gnu_old 2847 = (present_gnu_tree (gnat_desig_type) 2848 ? gnat_to_gnu_type (gnat_desig_type) 2849 : make_dummy_type (gnat_desig_type)); 2850 tree fields; 2851 2852 /* Show the dummy we get will be a fat pointer. */ 2853 got_fat_p = made_dummy = 1; 2854 2855 /* If the call above got something that has a pointer, that 2856 pointer is our type. This could have happened either 2857 because the type was elaborated or because somebody 2858 else executed the code below. */ 2859 gnu_type = TYPE_POINTER_TO (gnu_old); 2860 if (gnu_type == 0) 2861 { 2862 gnu_type = make_node (RECORD_TYPE); 2863 SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old); 2864 TYPE_POINTER_TO (gnu_old) = gnu_type; 2865 2866 set_lineno (gnat_entity, 0); 2867 fields 2868 = chainon (chainon (NULL_TREE, 2869 create_field_decl 2870 (get_identifier ("P_ARRAY"), 2871 ptr_void_type_node, gnu_type, 2872 0, 0, 0, 0)), 2873 create_field_decl (get_identifier ("P_BOUNDS"), 2874 ptr_void_type_node, 2875 gnu_type, 0, 0, 0, 0)); 2876 2877 /* Make sure we can place this into a register. */ 2878 TYPE_ALIGN (gnu_type) 2879 = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE); 2880 TYPE_IS_FAT_POINTER_P (gnu_type) = 1; 2881 finish_record_type (gnu_type, fields, 0, 1); 2882 2883 TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE); 2884 TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old)) 2885 = concat_id_with_name (get_entity_name (gnat_desig_type), 2886 "XUT"); 2887 TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1; 2888 } 2889 } 2890 2891 /* If we already know what the full type is, use it. */ 2892 else if (Present (gnat_desig_full) 2893 && present_gnu_tree (gnat_desig_full)) 2894 gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full)); 2895 2896 /* Get the type of the thing we are to point to and build a pointer 2897 to it. If it is a reference to an incomplete or private type with a 2898 full view that is a record, make a dummy type node and get the 2899 actual type later when we have verified it is safe. */ 2900 else if (! in_main_unit 2901 && ! present_gnu_tree (gnat_desig_type) 2902 && Present (gnat_desig_full) 2903 && ! present_gnu_tree (gnat_desig_full) 2904 && Is_Record_Type (gnat_desig_full)) 2905 { 2906 gnu_desig_type = make_dummy_type (gnat_desig_type); 2907 made_dummy = 1; 2908 } 2909 2910 /* Likewise if we are pointing to a record or array and we are to defer 2911 elaborating incomplete types. We do this since this access type 2912 may be the full view of some private type. Note that the 2913 unconstrained array case is handled above. */ 2914 else if ((! in_main_unit || imported_p) && defer_incomplete_level != 0 2915 && ! present_gnu_tree (gnat_desig_type) 2916 && ((Is_Record_Type (gnat_desig_type) 2917 || Is_Array_Type (gnat_desig_type)) 2918 || (Present (gnat_desig_full) 2919 && (Is_Record_Type (gnat_desig_full) 2920 || Is_Array_Type (gnat_desig_full))))) 2921 { 2922 gnu_desig_type = make_dummy_type (gnat_desig_type); 2923 made_dummy = 1; 2924 } 2925 else if (gnat_desig_type == gnat_entity) 2926 { 2927 gnu_type = build_pointer_type (make_node (VOID_TYPE)); 2928 TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type; 2929 } 2930 else 2931 gnu_desig_type = gnat_to_gnu_type (gnat_desig_type); 2932 2933 /* It is possible that the above call to gnat_to_gnu_type resolved our 2934 type. If so, just return it. */ 2935 if (present_gnu_tree (gnat_entity)) 2936 { 2937 maybe_present = 1; 2938 break; 2939 } 2940 2941 /* If we have a GCC type for the designated type, possibly modify it 2942 if we are pointing only to constant objects and then make a pointer 2943 to it. Don't do this for unconstrained arrays. */ 2944 if (gnu_type == 0 && gnu_desig_type != 0) 2945 { 2946 if (Is_Access_Constant (gnat_entity) 2947 && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE) 2948 { 2949 gnu_desig_type 2950 = build_qualified_type 2951 (gnu_desig_type, 2952 TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST); 2953 2954 /* Some extra processing is required if we are building a 2955 pointer to an incomplete type (in the GCC sense). We might 2956 have such a type if we just made a dummy, or directly out 2957 of the call to gnat_to_gnu_type above if we are processing 2958 an access type for a record component designating the 2959 record type itself. */ 2960 if (! COMPLETE_TYPE_P (gnu_desig_type)) 2961 { 2962 /* We must ensure that the pointer to variant we make will 2963 be processed by update_pointer_to when the initial type 2964 is completed. Pretend we made a dummy and let further 2965 processing act as usual. */ 2966 made_dummy = 1; 2967 2968 /* We must ensure that update_pointer_to will not retrieve 2969 the dummy variant when building a properly qualified 2970 version of the complete type. We take advantage of the 2971 fact that get_qualified_type is requiring TYPE_NAMEs to 2972 match to influence build_qualified_type and then also 2973 update_pointer_to here. */ 2974 TYPE_NAME (gnu_desig_type) 2975 = create_concat_name (gnat_desig_type, "INCOMPLETE_CST"); 2976 } 2977 } 2978 2979 gnu_type = build_pointer_type (gnu_desig_type); 2980 } 2981 2982 /* If we are not defining this object and we made a dummy pointer, 2983 save our current definition, evaluate the actual type, and replace 2984 the tentative type we made with the actual one. If we are to defer 2985 actually looking up the actual type, make an entry in the 2986 deferred list. */ 2987 2988 if (! in_main_unit && made_dummy) 2989 { 2990 tree gnu_old_type 2991 = TYPE_FAT_POINTER_P (gnu_type) 2992 ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type); 2993 2994 if (esize == POINTER_SIZE 2995 && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type))) 2996 gnu_type 2997 = build_pointer_type 2998 (TYPE_OBJECT_RECORD_TYPE 2999 (TYPE_UNCONSTRAINED_ARRAY (gnu_type))); 3000 3001 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, 3002 ! Comes_From_Source (gnat_entity), 3003 debug_info_p); 3004 save_gnu_tree (gnat_entity, gnu_decl, 0); 3005 this_made_decl = saved = 1; 3006 3007 if (defer_incomplete_level == 0) 3008 { 3009 update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type), 3010 gnat_to_gnu_type (gnat_desig_type)); 3011 /* Note that the call to gnat_to_gnu_type here might have 3012 updated gnu_old_type directly, in which case it is not a 3013 dummy type any more when we get into update_pointer_to. 3014 3015 This may happen for instance when the designated type is a 3016 record type, because their elaboration starts with an 3017 initial node from make_dummy_type, which may yield the same 3018 node as the one we got. 3019 3020 Besides, variants of this non-dummy type might have been 3021 created along the way. update_pointer_to is expected to 3022 properly take care of those situations. */ 3023 } 3024 else 3025 { 3026 struct incomplete *p 3027 = (struct incomplete *) xmalloc (sizeof (struct incomplete)); 3028 3029 p->old_type = gnu_old_type; 3030 p->full_type = gnat_desig_type; 3031 p->next = defer_incomplete_list; 3032 defer_incomplete_list = p; 3033 } 3034 } 3035 } 3036 break; 3037 3038 case E_Access_Protected_Subprogram_Type: 3039 if (type_annotate_only && No (Equivalent_Type (gnat_entity))) 3040 gnu_type = build_pointer_type (void_type_node); 3041 else 3042 /* The runtime representation is the equivalent type. */ 3043 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity)); 3044 3045 if (Is_Itype (Directly_Designated_Type (gnat_entity)) 3046 && ! present_gnu_tree (Directly_Designated_Type (gnat_entity)) 3047 && No (Freeze_Node (Directly_Designated_Type (gnat_entity))) 3048 && ! Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity)))) 3049 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), 3050 NULL_TREE, 0); 3051 3052 break; 3053 3054 case E_Access_Subtype: 3055 3056 /* We treat this as identical to its base type; any constraint is 3057 meaningful only to the front end. 3058 3059 The designated type must be elaborated as well, if it does 3060 not have its own freeze node. Designated (sub)types created 3061 for constrained components of records with discriminants are 3062 not frozen by the front end and thus not elaborated by gigi, 3063 because their use may appear before the base type is frozen, 3064 and because it is not clear that they are needed anywhere in 3065 Gigi. With the current model, there is no correct place where 3066 they could be elaborated. */ 3067 3068 gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); 3069 if (Is_Itype (Directly_Designated_Type (gnat_entity)) 3070 && ! present_gnu_tree (Directly_Designated_Type (gnat_entity)) 3071 && Is_Frozen (Directly_Designated_Type (gnat_entity)) 3072 && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))) 3073 { 3074 /* If we are not defining this entity, and we have incomplete 3075 entities being processed above us, make a dummy type and 3076 elaborate it later. */ 3077 if (! definition && defer_incomplete_level != 0) 3078 { 3079 struct incomplete *p 3080 = (struct incomplete *) xmalloc (sizeof (struct incomplete)); 3081 tree gnu_ptr_type 3082 = build_pointer_type 3083 (make_dummy_type (Directly_Designated_Type (gnat_entity))); 3084 3085 p->old_type = TREE_TYPE (gnu_ptr_type); 3086 p->full_type = Directly_Designated_Type (gnat_entity); 3087 p->next = defer_incomplete_list; 3088 defer_incomplete_list = p; 3089 } 3090 else if 3091 (IN (Ekind (Base_Type (Directly_Designated_Type (gnat_entity))), 3092 Incomplete_Or_Private_Kind)) 3093 { ;} 3094 else 3095 gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity), 3096 NULL_TREE, 0); 3097 } 3098 3099 maybe_present = 1; 3100 break; 3101 3102 /* Subprogram Entities 3103 3104 The following access functions are defined for subprograms (functions 3105 or procedures): 3106 3107 First_Formal The first formal parameter. 3108 Is_Imported Indicates that the subprogram has appeared in 3109 an INTERFACE or IMPORT pragma. For now we 3110 assume that the external language is C. 3111 Is_Inlined True if the subprogram is to be inlined. 3112 3113 In addition for function subprograms we have: 3114 3115 Etype Return type of the function. 3116 3117 Each parameter is first checked by calling must_pass_by_ref on its 3118 type to determine if it is passed by reference. For parameters which 3119 are copied in, if they are Ada IN OUT or OUT parameters, their return 3120 value becomes part of a record which becomes the return type of the 3121 function (C function - note that this applies only to Ada procedures 3122 so there is no Ada return type). Additional code to store back the 3123 parameters will be generated on the caller side. This transformation 3124 is done here, not in the front-end. 3125 3126 The intended result of the transformation can be seen from the 3127 equivalent source rewritings that follow: 3128 3129 struct temp {int a,b}; 3130 procedure P (A,B: IN OUT ...) is temp P (int A,B) { 3131 .. .. 3132 end P; return {A,B}; 3133 } 3134 procedure call 3135 3136 { 3137 temp t; 3138 P(X,Y); t = P(X,Y); 3139 X = t.a , Y = t.b; 3140 } 3141 3142 For subprogram types we need to perform mainly the same conversions to 3143 GCC form that are needed for procedures and function declarations. The 3144 only difference is that at the end, we make a type declaration instead 3145 of a function declaration. */ 3146 3147 case E_Subprogram_Type: 3148 case E_Function: 3149 case E_Procedure: 3150 { 3151 /* The first GCC parameter declaration (a PARM_DECL node). The 3152 PARM_DECL nodes are chained through the TREE_CHAIN field, so this 3153 actually is the head of this parameter list. */ 3154 tree gnu_param_list = NULL_TREE; 3155 /* The type returned by a function. If the subprogram is a procedure 3156 this type should be void_type_node. */ 3157 tree gnu_return_type = void_type_node; 3158 /* List of fields in return type of procedure with copy in copy out 3159 parameters. */ 3160 tree gnu_field_list = NULL_TREE; 3161 /* Non-null for subprograms containing parameters passed by copy in 3162 copy out (Ada IN OUT or OUT parameters not passed by reference), 3163 in which case it is the list of nodes used to specify the values of 3164 the in out/out parameters that are returned as a record upon 3165 procedure return. The TREE_PURPOSE of an element of this list is 3166 a field of the record and the TREE_VALUE is the PARM_DECL 3167 corresponding to that field. This list will be saved in the 3168 TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */ 3169 tree gnu_return_list = NULL_TREE; 3170 Entity_Id gnat_param; 3171 int inline_flag = Is_Inlined (gnat_entity); 3172 int public_flag = Is_Public (gnat_entity); 3173 int extern_flag 3174 = (Is_Public (gnat_entity) && !definition) || imported_p; 3175 int pure_flag = Is_Pure (gnat_entity); 3176 int volatile_flag = No_Return (gnat_entity); 3177 int returns_by_ref = 0; 3178 int returns_unconstrained = 0; 3179 tree gnu_ext_name = create_concat_name (gnat_entity, 0); 3180 int has_copy_in_out = 0; 3181 int parmnum; 3182 3183 if (kind == E_Subprogram_Type && ! definition) 3184 /* A parameter may refer to this type, so defer completion 3185 of any incomplete types. */ 3186 defer_incomplete_level++, this_deferred = 1; 3187 3188 /* If the subprogram has an alias, it is probably inherited, so 3189 we can use the original one. If the original "subprogram" 3190 is actually an enumeration literal, it may be the first use 3191 of its type, so we must elaborate that type now. */ 3192 if (Present (Alias (gnat_entity))) 3193 { 3194 if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal) 3195 gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0); 3196 3197 gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), 3198 gnu_expr, 0); 3199 3200 /* Elaborate any Itypes in the parameters of this entity. */ 3201 for (gnat_temp = First_Formal (gnat_entity); 3202 Present (gnat_temp); 3203 gnat_temp = Next_Formal_With_Extras (gnat_temp)) 3204 if (Is_Itype (Etype (gnat_temp))) 3205 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); 3206 3207 break; 3208 } 3209 3210 if (kind == E_Function || kind == E_Subprogram_Type) 3211 gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity)); 3212 3213 /* If this function returns by reference, make the actual 3214 return type of this function the pointer and mark the decl. */ 3215 if (Returns_By_Ref (gnat_entity)) 3216 { 3217 returns_by_ref = 1; 3218 gnu_return_type = build_pointer_type (gnu_return_type); 3219 } 3220 3221 /* If the Mechanism is By_Reference, ensure the return type uses 3222 the machine's by-reference mechanism, which may not the same 3223 as above (e.g., it might be by passing a fake parameter). */ 3224 else if (kind == E_Function 3225 && Mechanism (gnat_entity) == By_Reference) 3226 { 3227 gnu_return_type = copy_type (gnu_return_type); 3228 TREE_ADDRESSABLE (gnu_return_type) = 1; 3229 } 3230 3231 /* If we are supposed to return an unconstrained array, 3232 actually return a fat pointer and make a note of that. Return 3233 a pointer to an unconstrained record of variable size. */ 3234 else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE) 3235 { 3236 gnu_return_type = TREE_TYPE (gnu_return_type); 3237 returns_unconstrained = 1; 3238 } 3239 3240 /* If the type requires a transient scope, the result is allocated 3241 on the secondary stack, so the result type of the function is 3242 just a pointer. */ 3243 else if (Requires_Transient_Scope (Etype (gnat_entity))) 3244 { 3245 gnu_return_type = build_pointer_type (gnu_return_type); 3246 returns_unconstrained = 1; 3247 } 3248 3249 /* If the type is a padded type and the underlying type would not 3250 be passed by reference or this function has a foreign convention, 3251 return the underlying type. */ 3252 else if (TREE_CODE (gnu_return_type) == RECORD_TYPE 3253 && TYPE_IS_PADDING_P (gnu_return_type) 3254 && (! default_pass_by_ref (TREE_TYPE 3255 (TYPE_FIELDS (gnu_return_type))) 3256 || Has_Foreign_Convention (gnat_entity))) 3257 gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type)); 3258 3259 /* Look at all our parameters and get the type of 3260 each. While doing this, build a copy-out structure if 3261 we need one. */ 3262 3263 /* If the return type has a size that overflows, we cannot have 3264 a function that returns that type. This usage doesn't make 3265 sense anyway, so give an error here. */ 3266 if (TYPE_SIZE_UNIT (gnu_return_type) 3267 && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type))) 3268 { 3269 post_error ("cannot return type whose size overflows", 3270 gnat_entity); 3271 gnu_return_type = copy_node (gnu_return_type); 3272 TYPE_SIZE (gnu_return_type) = bitsize_zero_node; 3273 TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node; 3274 TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type; 3275 TYPE_NEXT_VARIANT (gnu_return_type) = 0; 3276 } 3277 3278 for (gnat_param = First_Formal (gnat_entity), parmnum = 0; 3279 Present (gnat_param); 3280 gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++) 3281 { 3282 tree gnu_param_name = get_entity_name (gnat_param); 3283 tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); 3284 tree gnu_param, gnu_field; 3285 int by_ref_p = 0; 3286 int by_descr_p = 0; 3287 int by_component_ptr_p = 0; 3288 int copy_in_copy_out_flag = 0; 3289 int req_by_copy = 0, req_by_ref = 0; 3290 3291 /* See if a Mechanism was supplied that forced this 3292 parameter to be passed one way or another. */ 3293 if (Is_Valued_Procedure (gnat_entity) && parmnum == 0) 3294 req_by_copy = 1; 3295 else if (Mechanism (gnat_param) == Default) 3296 ; 3297 else if (Mechanism (gnat_param) == By_Copy) 3298 req_by_copy = 1; 3299 else if (Mechanism (gnat_param) == By_Reference) 3300 req_by_ref = 1; 3301 else if (Mechanism (gnat_param) <= By_Descriptor) 3302 by_descr_p = 1; 3303 else if (Mechanism (gnat_param) > 0) 3304 { 3305 if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE 3306 || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST 3307 || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type), 3308 Mechanism (gnat_param))) 3309 req_by_ref = 1; 3310 else 3311 req_by_copy = 1; 3312 } 3313 else 3314 post_error ("unsupported mechanism for&", gnat_param); 3315 3316 /* If this is either a foreign function or if the 3317 underlying type won't be passed by refererence, strip off 3318 possible padding type. */ 3319 if (TREE_CODE (gnu_param_type) == RECORD_TYPE 3320 && TYPE_IS_PADDING_P (gnu_param_type) 3321 && (req_by_ref || Has_Foreign_Convention (gnat_entity) 3322 || ! must_pass_by_ref (TREE_TYPE (TYPE_FIELDS 3323 (gnu_param_type))))) 3324 gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); 3325 3326 /* If this is an IN parameter it is read-only, so make a variant 3327 of the type that is read-only. 3328 3329 ??? However, if this is an unconstrained array, that type can 3330 be very complex. So skip it for now. Likewise for any other 3331 self-referential type. */ 3332 if (Ekind (gnat_param) == E_In_Parameter 3333 && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE 3334 && ! (TYPE_SIZE (gnu_param_type) != 0 3335 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))) 3336 gnu_param_type 3337 = build_qualified_type (gnu_param_type, 3338 (TYPE_QUALS (gnu_param_type) 3339 | TYPE_QUAL_CONST)); 3340 3341 /* For foreign conventions, pass arrays as a pointer to the 3342 underlying type. First check for unconstrained array and get 3343 the underlying array. Then get the component type and build 3344 a pointer to it. */ 3345 if (Has_Foreign_Convention (gnat_entity) 3346 && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE) 3347 gnu_param_type 3348 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS 3349 (TREE_TYPE (gnu_param_type)))); 3350 3351 if (by_descr_p) 3352 gnu_param_type 3353 = build_pointer_type 3354 (build_vms_descriptor (gnu_param_type, 3355 Mechanism (gnat_param), 3356 gnat_entity)); 3357 3358 else if (Has_Foreign_Convention (gnat_entity) 3359 && ! req_by_copy 3360 && TREE_CODE (gnu_param_type) == ARRAY_TYPE) 3361 { 3362 /* Strip off any multi-dimensional entries, then strip 3363 off the last array to get the component type. */ 3364 while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE 3365 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type))) 3366 gnu_param_type = TREE_TYPE (gnu_param_type); 3367 3368 by_component_ptr_p = 1; 3369 gnu_param_type = TREE_TYPE (gnu_param_type); 3370 3371 if (Ekind (gnat_param) == E_In_Parameter) 3372 gnu_param_type 3373 = build_qualified_type (gnu_param_type, 3374 (TYPE_QUALS (gnu_param_type) 3375 | TYPE_QUAL_CONST)); 3376 3377 gnu_param_type = build_pointer_type (gnu_param_type); 3378 } 3379 3380 /* Fat pointers are passed as thin pointers for foreign 3381 conventions. */ 3382 else if (Has_Foreign_Convention (gnat_entity) 3383 && TYPE_FAT_POINTER_P (gnu_param_type)) 3384 gnu_param_type 3385 = make_type_from_size (gnu_param_type, 3386 size_int (POINTER_SIZE), 0); 3387 3388 /* If we must pass or were requested to pass by reference, do so. 3389 If we were requested to pass by copy, do so. 3390 Otherwise, for foreign conventions, pass all in out parameters 3391 or aggregates by reference. For COBOL and Fortran, pass 3392 all integer and FP types that way too. For Convention Ada, 3393 use the standard Ada default. */ 3394 else if (must_pass_by_ref (gnu_param_type) || req_by_ref 3395 || (! req_by_copy 3396 && ((Has_Foreign_Convention (gnat_entity) 3397 && (Ekind (gnat_param) != E_In_Parameter 3398 || AGGREGATE_TYPE_P (gnu_param_type))) 3399 || (((Convention (gnat_entity) 3400 == Convention_Fortran) 3401 || (Convention (gnat_entity) 3402 == Convention_COBOL)) 3403 && (INTEGRAL_TYPE_P (gnu_param_type) 3404 || FLOAT_TYPE_P (gnu_param_type))) 3405 /* For convention Ada, see if we pass by reference 3406 by default. */ 3407 || (! Has_Foreign_Convention (gnat_entity) 3408 && default_pass_by_ref (gnu_param_type))))) 3409 { 3410 gnu_param_type = build_reference_type (gnu_param_type); 3411 by_ref_p = 1; 3412 } 3413 3414 else if (Ekind (gnat_param) != E_In_Parameter) 3415 copy_in_copy_out_flag = 1; 3416 3417 if (req_by_copy && (by_ref_p || by_component_ptr_p)) 3418 post_error ("?cannot pass & by copy", gnat_param); 3419 3420 /* If this is an OUT parameter that isn't passed by reference 3421 and isn't a pointer or aggregate, we don't make a PARM_DECL 3422 for it. Instead, it will be a VAR_DECL created when we process 3423 the procedure. For the special parameter of Valued_Procedure, 3424 never pass it in. 3425 3426 An exception is made to cover the RM-6.4.1 rule requiring "by 3427 copy" out parameters with discriminants or implicit initial 3428 values to be handled like in out parameters. These type are 3429 normally built as aggregates, and hence passed by reference, 3430 except for some packed arrays which end up encoded in special 3431 integer types. 3432 3433 The exception we need to make is then for packed arrays of 3434 records with discriminants or implicit initial values. We have 3435 no light/easy way to check for the latter case, so we merely 3436 check for packed arrays of records. This may lead to useless 3437 copy-in operations, but in very rare cases only, as these would 3438 be exceptions in a set of already exceptional situations. */ 3439 if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p 3440 && ((Is_Valued_Procedure (gnat_entity) && parmnum == 0) 3441 || (! by_descr_p 3442 && ! POINTER_TYPE_P (gnu_param_type) 3443 && ! AGGREGATE_TYPE_P (gnu_param_type))) 3444 && ! (Is_Array_Type (Etype (gnat_param)) 3445 && Is_Packed (Etype (gnat_param)) 3446 && Is_Composite_Type (Component_Type 3447 (Etype (gnat_param))))) 3448 gnu_param = 0; 3449 else 3450 { 3451 set_lineno (gnat_param, 0); 3452 gnu_param 3453 = create_param_decl 3454 (gnu_param_name, gnu_param_type, 3455 by_ref_p || by_component_ptr_p 3456 || Ekind (gnat_param) == E_In_Parameter); 3457 3458 DECL_BY_REF_P (gnu_param) = by_ref_p; 3459 DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr_p; 3460 DECL_BY_DESCRIPTOR_P (gnu_param) = by_descr_p; 3461 DECL_POINTS_TO_READONLY_P (gnu_param) 3462 = (Ekind (gnat_param) == E_In_Parameter 3463 && (by_ref_p || by_component_ptr_p)); 3464 save_gnu_tree (gnat_param, gnu_param, 0); 3465 gnu_param_list = chainon (gnu_param, gnu_param_list); 3466 3467 /* If a parameter is a pointer, this function may modify 3468 memory through it and thus shouldn't be considered 3469 a pure function. Also, the memory may be modified 3470 between two calls, so they can't be CSE'ed. The latter 3471 case also handles by-ref parameters. */ 3472 if (POINTER_TYPE_P (gnu_param_type) 3473 || TYPE_FAT_POINTER_P (gnu_param_type)) 3474 pure_flag = 0; 3475 } 3476 3477 if (copy_in_copy_out_flag) 3478 { 3479 if (! has_copy_in_out) 3480 { 3481 if (TREE_CODE (gnu_return_type) != VOID_TYPE) 3482 gigi_abort (111); 3483 3484 gnu_return_type = make_node (RECORD_TYPE); 3485 TYPE_NAME (gnu_return_type) = get_identifier ("RETURN"); 3486 has_copy_in_out = 1; 3487 } 3488 3489 set_lineno (gnat_param, 0); 3490 gnu_field = create_field_decl (gnu_param_name, gnu_param_type, 3491 gnu_return_type, 0, 0, 0, 0); 3492 TREE_CHAIN (gnu_field) = gnu_field_list; 3493 gnu_field_list = gnu_field; 3494 gnu_return_list = tree_cons (gnu_field, gnu_param, 3495 gnu_return_list); 3496 } 3497 } 3498 3499 /* Do not compute record for out parameters if subprogram is 3500 stubbed since structures are incomplete for the back-end. */ 3501 if (gnu_field_list != 0 3502 && Convention (gnat_entity) != Convention_Stubbed) 3503 finish_record_type (gnu_return_type, nreverse (gnu_field_list), 3504 0, 0); 3505 3506 /* If we have a CICO list but it has only one entry, we convert 3507 this function into a function that simply returns that one 3508 object. */ 3509 if (list_length (gnu_return_list) == 1) 3510 gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list)); 3511 3512 #ifdef _WIN32 3513 if (Convention (gnat_entity) == Convention_Stdcall) 3514 { 3515 struct attrib *attr 3516 = (struct attrib *) xmalloc (sizeof (struct attrib)); 3517 3518 attr->next = attr_list; 3519 attr->type = ATTR_MACHINE_ATTRIBUTE; 3520 attr->name = get_identifier ("stdcall"); 3521 attr->arg = NULL_TREE; 3522 attr->error_point = gnat_entity; 3523 attr_list = attr; 3524 } 3525 #endif 3526 3527 /* Both lists ware built in reverse. */ 3528 gnu_param_list = nreverse (gnu_param_list); 3529 gnu_return_list = nreverse (gnu_return_list); 3530 3531 gnu_type 3532 = create_subprog_type (gnu_return_type, gnu_param_list, 3533 gnu_return_list, returns_unconstrained, 3534 returns_by_ref, 3535 Function_Returns_With_DSP (gnat_entity)); 3536 3537 /* ??? For now, don't consider nested functions pure. */ 3538 if (! global_bindings_p ()) 3539 pure_flag = 0; 3540 3541 /* A subprogram (something that doesn't return anything) shouldn't 3542 be considered Pure since there would be no reason for such a 3543 subprogram. Note that procedures with Out (or In Out) parameters 3544 have already been converted into a function with a return type. */ 3545 if (TREE_CODE (gnu_return_type) == VOID_TYPE) 3546 pure_flag = 0; 3547 3548 gnu_type 3549 = build_qualified_type (gnu_type, 3550 (TYPE_QUALS (gnu_type) 3551 | (TYPE_QUAL_CONST * pure_flag) 3552 | (TYPE_QUAL_VOLATILE * volatile_flag))); 3553 3554 set_lineno (gnat_entity, 0); 3555 3556 /* If there was no specified Interface_Name and the external and 3557 internal names of the subprogram are the same, only use the 3558 internal name to allow disambiguation of nested subprograms. */ 3559 if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id) 3560 gnu_ext_name = 0; 3561 3562 /* If we are defining the subprogram and it has an Address clause 3563 we must get the address expression from the saved GCC tree for the 3564 subprogram if it has a Freeze_Node. Otherwise, we elaborate 3565 the address expression here since the front-end has guaranteed 3566 in that case that the elaboration has no effects. If there is 3567 an Address clause and we are not defining the object, just 3568 make it a constant. */ 3569 if (Present (Address_Clause (gnat_entity))) 3570 { 3571 tree gnu_address = 0; 3572 3573 if (definition) 3574 gnu_address 3575 = (present_gnu_tree (gnat_entity) 3576 ? get_gnu_tree (gnat_entity) 3577 : gnat_to_gnu (Expression (Address_Clause (gnat_entity)))); 3578 3579 save_gnu_tree (gnat_entity, NULL_TREE, 0); 3580 3581 gnu_type = build_reference_type (gnu_type); 3582 if (gnu_address != 0) 3583 gnu_address = convert (gnu_type, gnu_address); 3584 3585 gnu_decl 3586 = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type, 3587 gnu_address, 0, Is_Public (gnat_entity), 3588 extern_flag, 0, 0); 3589 DECL_BY_REF_P (gnu_decl) = 1; 3590 } 3591 3592 else if (kind == E_Subprogram_Type) 3593 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, 3594 ! Comes_From_Source (gnat_entity), 3595 debug_info_p); 3596 else 3597 { 3598 gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name, 3599 gnu_type, gnu_param_list, 3600 inline_flag, public_flag, 3601 extern_flag, attr_list); 3602 DECL_STUBBED_P (gnu_decl) 3603 = Convention (gnat_entity) == Convention_Stubbed; 3604 } 3605 } 3606 break; 3607 3608 case E_Incomplete_Type: 3609 case E_Private_Type: 3610 case E_Limited_Private_Type: 3611 case E_Record_Type_With_Private: 3612 case E_Private_Subtype: 3613 case E_Limited_Private_Subtype: 3614 case E_Record_Subtype_With_Private: 3615 3616 /* If this type does not have a full view in the unit we are 3617 compiling, then just get the type from its Etype. */ 3618 if (No (Full_View (gnat_entity))) 3619 { 3620 /* If this is an incomplete type with no full view, it must 3621 be a Taft Amendement type, so just return a dummy type. */ 3622 if (kind == E_Incomplete_Type) 3623 gnu_type = make_dummy_type (gnat_entity); 3624 3625 else if (Present (Underlying_Full_View (gnat_entity))) 3626 gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity), 3627 NULL_TREE, 0); 3628 else 3629 { 3630 gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), 3631 NULL_TREE, 0); 3632 maybe_present = 1; 3633 } 3634 3635 break; 3636 } 3637 3638 /* Otherwise, if we are not defining the type now, get the 3639 type from the full view. But always get the type from the full 3640 view for define on use types, since otherwise we won't see them! */ 3641 3642 else if (! definition 3643 || (Is_Itype (Full_View (gnat_entity)) 3644 && No (Freeze_Node (gnat_entity))) 3645 || (Is_Itype (gnat_entity) 3646 && No (Freeze_Node (Full_View (gnat_entity))))) 3647 { 3648 gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity), 3649 NULL_TREE, 0); 3650 maybe_present = 1; 3651 break; 3652 } 3653 3654 /* For incomplete types, make a dummy type entry which will be 3655 replaced later. */ 3656 gnu_type = make_dummy_type (gnat_entity); 3657 3658 /* Save this type as the full declaration's type so we can do any needed 3659 updates when we see it. */ 3660 set_lineno (gnat_entity, 0); 3661 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, 3662 ! Comes_From_Source (gnat_entity), 3663 debug_info_p); 3664 save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0); 3665 break; 3666 3667 /* Simple class_wide types are always viewed as their root_type 3668 by Gigi unless an Equivalent_Type is specified. */ 3669 case E_Class_Wide_Type: 3670 if (Present (Equivalent_Type (gnat_entity))) 3671 gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity)); 3672 else 3673 gnu_type = gnat_to_gnu_type (Root_Type (gnat_entity)); 3674 3675 maybe_present = 1; 3676 break; 3677 3678 case E_Task_Type: 3679 case E_Task_Subtype: 3680 case E_Protected_Type: 3681 case E_Protected_Subtype: 3682 if (type_annotate_only && No (Corresponding_Record_Type (gnat_entity))) 3683 gnu_type = void_type_node; 3684 else 3685 gnu_type = gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity)); 3686 3687 maybe_present = 1; 3688 break; 3689 3690 case E_Label: 3691 gnu_decl = create_label_decl (gnu_entity_id); 3692 break; 3693 3694 case E_Block: 3695 case E_Loop: 3696 /* Nothing at all to do here, so just return an ERROR_MARK and claim 3697 we've already saved it, so we don't try to. */ 3698 gnu_decl = error_mark_node; 3699 saved = 1; 3700 break; 3701 3702 default: 3703 gigi_abort (113); 3704 } 3705 3706 /* If we had a case where we evaluated another type and it might have 3707 defined this one, handle it here. */ 3708 if (maybe_present && present_gnu_tree (gnat_entity)) 3709 { 3710 gnu_decl = get_gnu_tree (gnat_entity); 3711 saved = 1; 3712 } 3713 3714 /* If we are processing a type and there is either no decl for it or 3715 we just made one, do some common processing for the type, such as 3716 handling alignment and possible padding. */ 3717 3718 if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind)) 3719 { 3720 if (Is_Tagged_Type (gnat_entity) 3721 || Is_Class_Wide_Equivalent_Type (gnat_entity)) 3722 TYPE_ALIGN_OK (gnu_type) = 1; 3723 3724 if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity)) 3725 TYPE_BY_REFERENCE_P (gnu_type) = 1; 3726 3727 /* ??? Don't set the size for a String_Literal since it is either 3728 confirming or we don't handle it properly (if the low bound is 3729 non-constant). */ 3730 if (gnu_size == 0 && kind != E_String_Literal_Subtype) 3731 gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity, 3732 TYPE_DECL, 0, Has_Size_Clause (gnat_entity)); 3733 3734 /* If a size was specified, see if we can make a new type of that size 3735 by rearranging the type, for example from a fat to a thin pointer. */ 3736 if (gnu_size != 0) 3737 { 3738 gnu_type 3739 = make_type_from_size (gnu_type, gnu_size, 3740 Has_Biased_Representation (gnat_entity)); 3741 3742 if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0) 3743 && operand_equal_p (rm_size (gnu_type), gnu_size, 0)) 3744 gnu_size = 0; 3745 } 3746 3747 /* If the alignment hasn't already been processed and this is 3748 not an unconstrained array, see if an alignment is specified. 3749 If not, we pick a default alignment for atomic objects. */ 3750 if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) 3751 ; 3752 else if (Known_Alignment (gnat_entity)) 3753 align = validate_alignment (Alignment (gnat_entity), gnat_entity, 3754 TYPE_ALIGN (gnu_type)); 3755 else if (Is_Atomic (gnat_entity) && gnu_size == 0 3756 && host_integerp (TYPE_SIZE (gnu_type), 1) 3757 && integer_pow2p (TYPE_SIZE (gnu_type))) 3758 align = MIN (BIGGEST_ALIGNMENT, 3759 tree_low_cst (TYPE_SIZE (gnu_type), 1)); 3760 else if (Is_Atomic (gnat_entity) && gnu_size != 0 3761 && host_integerp (gnu_size, 1) 3762 && integer_pow2p (gnu_size)) 3763 align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1)); 3764 3765 /* See if we need to pad the type. If we did, and made a record, 3766 the name of the new type may be changed. So get it back for 3767 us when we make the new TYPE_DECL below. */ 3768 gnu_type = maybe_pad_type (gnu_type, gnu_size, align, 3769 gnat_entity, "PAD", 1, definition, 0); 3770 if (TREE_CODE (gnu_type) == RECORD_TYPE 3771 && TYPE_IS_PADDING_P (gnu_type)) 3772 { 3773 gnu_entity_id = TYPE_NAME (gnu_type); 3774 if (TREE_CODE (gnu_entity_id) == TYPE_DECL) 3775 gnu_entity_id = DECL_NAME (gnu_entity_id); 3776 } 3777 3778 set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity); 3779 3780 /* If we are at global level, GCC will have applied variable_size to 3781 the type, but that won't have done anything. So, if it's not 3782 a constant or self-referential, call elaborate_expression_1 to 3783 make a variable for the size rather than calculating it each time. 3784 Handle both the RM size and the actual size. */ 3785 if (global_bindings_p () 3786 && TYPE_SIZE (gnu_type) != 0 3787 && ! TREE_CONSTANT (TYPE_SIZE (gnu_type)) 3788 && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) 3789 { 3790 if (TREE_CODE (gnu_type) == RECORD_TYPE 3791 && operand_equal_p (TYPE_ADA_SIZE (gnu_type), 3792 TYPE_SIZE (gnu_type), 0)) 3793 { 3794 TYPE_SIZE (gnu_type) 3795 = elaborate_expression_1 (gnat_entity, gnat_entity, 3796 TYPE_SIZE (gnu_type), 3797 get_identifier ("SIZE"), 3798 definition, 0); 3799 SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type)); 3800 } 3801 else 3802 { 3803 TYPE_SIZE (gnu_type) 3804 = elaborate_expression_1 (gnat_entity, gnat_entity, 3805 TYPE_SIZE (gnu_type), 3806 get_identifier ("SIZE"), 3807 definition, 0); 3808 3809 /* ??? For now, store the size as a multiple of the alignment 3810 in bytes so that we can see the alignment from the tree. */ 3811 TYPE_SIZE_UNIT (gnu_type) 3812 = build_binary_op 3813 (MULT_EXPR, sizetype, 3814 elaborate_expression_1 3815 (gnat_entity, gnat_entity, 3816 build_binary_op (EXACT_DIV_EXPR, sizetype, 3817 TYPE_SIZE_UNIT (gnu_type), 3818 size_int (TYPE_ALIGN (gnu_type) 3819 / BITS_PER_UNIT)), 3820 get_identifier ("SIZE_A_UNIT"), 3821 definition, 0), 3822 size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); 3823 3824 if (TREE_CODE (gnu_type) == RECORD_TYPE) 3825 SET_TYPE_ADA_SIZE (gnu_type, 3826 elaborate_expression_1 (gnat_entity, gnat_entity, 3827 TYPE_ADA_SIZE (gnu_type), 3828 get_identifier ("RM_SIZE"), 3829 definition, 0)); 3830 } 3831 } 3832 3833 /* If this is a record type or subtype, call elaborate_expression_1 on 3834 any field position. Do this for both global and local types. 3835 Skip any fields that we haven't made trees for to avoid problems with 3836 class wide types. */ 3837 if (IN (kind, Record_Kind)) 3838 for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); 3839 gnat_temp = Next_Entity (gnat_temp)) 3840 if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp)) 3841 { 3842 tree gnu_field = get_gnu_tree (gnat_temp); 3843 3844 /* ??? Unfortunately, GCC needs to be able to prove the 3845 alignment of this offset and if it's a variable, it can't. 3846 In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but 3847 right now, we have to put in an explicit multiply and 3848 divide by that value. */ 3849 if (! CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field))) 3850 DECL_FIELD_OFFSET (gnu_field) 3851 = build_binary_op 3852 (MULT_EXPR, sizetype, 3853 elaborate_expression_1 3854 (gnat_temp, gnat_temp, 3855 build_binary_op (EXACT_DIV_EXPR, sizetype, 3856 DECL_FIELD_OFFSET (gnu_field), 3857 size_int (DECL_OFFSET_ALIGN (gnu_field) 3858 / BITS_PER_UNIT)), 3859 get_identifier ("OFFSET"), 3860 definition, 0), 3861 size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT)); 3862 } 3863 3864 gnu_type = build_qualified_type (gnu_type, 3865 (TYPE_QUALS (gnu_type) 3866 | (TYPE_QUAL_VOLATILE 3867 * Treat_As_Volatile (gnat_entity)))); 3868 3869 if (Is_Atomic (gnat_entity)) 3870 check_ok_for_atomic (gnu_type, gnat_entity, 0); 3871 3872 if (Known_Alignment (gnat_entity)) 3873 TYPE_USER_ALIGN (gnu_type) = 1; 3874 3875 if (gnu_decl == 0) 3876 { 3877 set_lineno (gnat_entity, 0); 3878 gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list, 3879 ! Comes_From_Source (gnat_entity), 3880 debug_info_p); 3881 } 3882 else 3883 TREE_TYPE (gnu_decl) = gnu_type; 3884 } 3885 3886 if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))) 3887 { 3888 gnu_type = TREE_TYPE (gnu_decl); 3889 3890 /* Back-annotate the Alignment of the type if not already in the 3891 tree. Likewise for sizes. */ 3892 if (Unknown_Alignment (gnat_entity)) 3893 Set_Alignment (gnat_entity, 3894 UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT)); 3895 3896 if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type) != 0) 3897 { 3898 /* If the size is self-referential, we annotate the maximum 3899 value of that size. */ 3900 tree gnu_size = TYPE_SIZE (gnu_type); 3901 3902 if (CONTAINS_PLACEHOLDER_P (gnu_size)) 3903 gnu_size = max_size (gnu_size, 1); 3904 3905 Set_Esize (gnat_entity, annotate_value (gnu_size)); 3906 3907 if (type_annotate_only && Is_Tagged_Type (gnat_entity)) 3908 { 3909 /* In this mode the tag and the parent components are not 3910 generated by the front-end, so the sizes must be adjusted 3911 explicitly now. */ 3912 3913 int size_offset; 3914 int new_size; 3915 3916 if (Is_Derived_Type (gnat_entity)) 3917 { 3918 size_offset 3919 = UI_To_Int (Esize (Etype (Base_Type (gnat_entity)))); 3920 Set_Alignment (gnat_entity, 3921 Alignment (Etype (Base_Type (gnat_entity)))); 3922 } 3923 else 3924 size_offset = POINTER_SIZE; 3925 3926 new_size = UI_To_Int (Esize (gnat_entity)) + size_offset; 3927 Set_Esize (gnat_entity, 3928 UI_From_Int (((new_size + (POINTER_SIZE - 1)) 3929 / POINTER_SIZE) * POINTER_SIZE)); 3930 Set_RM_Size (gnat_entity, Esize (gnat_entity)); 3931 } 3932 } 3933 3934 if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type) != 0) 3935 Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); 3936 } 3937 3938 if (! Comes_From_Source (gnat_entity) && DECL_P (gnu_decl)) 3939 DECL_ARTIFICIAL (gnu_decl) = 1; 3940 3941 if (! debug_info_p && DECL_P (gnu_decl) 3942 && TREE_CODE (gnu_decl) != FUNCTION_DECL) 3943 DECL_IGNORED_P (gnu_decl) = 1; 3944 3945 /* If this decl is really indirect, adjust it. */ 3946 if (TREE_CODE (gnu_decl) == VAR_DECL) 3947 adjust_decl_rtl (gnu_decl); 3948 3949 /* If we haven't already, associate the ..._DECL node that we just made with 3950 the input GNAT entity node. */ 3951 if (! saved) 3952 save_gnu_tree (gnat_entity, gnu_decl, 0); 3953 3954 /* If this is an enumeral or floating-point type, we were not able to set 3955 the bounds since they refer to the type. These bounds are always static. 3956 3957 For enumeration types, also write debugging information and declare the 3958 enumeration literal table, if needed. */ 3959 3960 if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity))) 3961 || (kind == E_Floating_Point_Type && ! Vax_Float (gnat_entity))) 3962 { 3963 tree gnu_scalar_type = gnu_type; 3964 3965 /* If this is a padded type, we need to use the underlying type. */ 3966 if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE 3967 && TYPE_IS_PADDING_P (gnu_scalar_type)) 3968 gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type)); 3969 3970 /* If this is a floating point type and we haven't set a floating 3971 point type yet, use this in the evaluation of the bounds. */ 3972 if (longest_float_type_node == 0 && kind == E_Floating_Point_Type) 3973 longest_float_type_node = gnu_type; 3974 3975 TYPE_MIN_VALUE (gnu_scalar_type) 3976 = gnat_to_gnu (Type_Low_Bound (gnat_entity)); 3977 TYPE_MAX_VALUE (gnu_scalar_type) 3978 = gnat_to_gnu (Type_High_Bound (gnat_entity)); 3979 3980 if (kind == E_Enumeration_Type) 3981 { 3982 TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl; 3983 3984 /* Since this has both a typedef and a tag, avoid outputting 3985 the name twice. */ 3986 DECL_ARTIFICIAL (gnu_decl) = 1; 3987 rest_of_type_compilation (gnu_scalar_type, global_bindings_p ()); 3988 } 3989 } 3990 3991 /* If we deferred processing of incomplete types, re-enable it. If there 3992 were no other disables and we have some to process, do so. */ 3993 if (this_deferred && --defer_incomplete_level == 0 3994 && defer_incomplete_list != 0) 3995 { 3996 struct incomplete *incp = defer_incomplete_list; 3997 struct incomplete *next; 3998 3999 defer_incomplete_list = 0; 4000 for (; incp; incp = next) 4001 { 4002 next = incp->next; 4003 4004 if (incp->old_type != 0) 4005 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), 4006 gnat_to_gnu_type (incp->full_type)); 4007 free (incp); 4008 } 4009 } 4010 4011 /* If we are not defining this type, see if it's in the incomplete list. 4012 If so, handle that list entry now. */ 4013 else if (! definition) 4014 { 4015 struct incomplete *incp; 4016 4017 for (incp = defer_incomplete_list; incp; incp = incp->next) 4018 if (incp->old_type != 0 && incp->full_type == gnat_entity) 4019 { 4020 update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type), 4021 TREE_TYPE (gnu_decl)); 4022 incp->old_type = 0; 4023 } 4024 } 4025 4026 if (this_global) 4027 force_global--; 4028 4029 if (Is_Packed_Array_Type (gnat_entity) 4030 && Is_Itype (Associated_Node_For_Itype (gnat_entity)) 4031 && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity))) 4032 && ! present_gnu_tree (Associated_Node_For_Itype (gnat_entity))) 4033 gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0); 4034 4035 return gnu_decl; 4036 } 4037 4038 /* Given GNAT_ENTITY, elaborate all expressions that are required to 4039 be elaborated at the point of its definition, but do nothing else. */ 4040 4041 void 4042 elaborate_entity (Entity_Id gnat_entity) 4043 { 4044 switch (Ekind (gnat_entity)) 4045 { 4046 case E_Signed_Integer_Subtype: 4047 case E_Modular_Integer_Subtype: 4048 case E_Enumeration_Subtype: 4049 case E_Ordinary_Fixed_Point_Subtype: 4050 case E_Decimal_Fixed_Point_Subtype: 4051 case E_Floating_Point_Subtype: 4052 { 4053 Node_Id gnat_lb = Type_Low_Bound (gnat_entity); 4054 Node_Id gnat_hb = Type_High_Bound (gnat_entity); 4055 4056 /* ??? Tests for avoiding static constaint error expression 4057 is needed until the front stops generating bogus conversions 4058 on bounds of real types. */ 4059 4060 if (! Raises_Constraint_Error (gnat_lb)) 4061 elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"), 4062 1, 0, Needs_Debug_Info (gnat_entity)); 4063 if (! Raises_Constraint_Error (gnat_hb)) 4064 elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"), 4065 1, 0, Needs_Debug_Info (gnat_entity)); 4066 break; 4067 } 4068 4069 case E_Record_Type: 4070 { 4071 Node_Id full_definition = Declaration_Node (gnat_entity); 4072 Node_Id record_definition = Type_Definition (full_definition); 4073 4074 /* If this is a record extension, go a level further to find the 4075 record definition. */ 4076 if (Nkind (record_definition) == N_Derived_Type_Definition) 4077 record_definition = Record_Extension_Part (record_definition); 4078 } 4079 break; 4080 4081 case E_Record_Subtype: 4082 case E_Private_Subtype: 4083 case E_Limited_Private_Subtype: 4084 case E_Record_Subtype_With_Private: 4085 if (Is_Constrained (gnat_entity) 4086 && Has_Discriminants (Base_Type (gnat_entity)) 4087 && Present (Discriminant_Constraint (gnat_entity))) 4088 { 4089 Node_Id gnat_discriminant_expr; 4090 Entity_Id gnat_field; 4091 4092 for (gnat_field = First_Discriminant (Base_Type (gnat_entity)), 4093 gnat_discriminant_expr 4094 = First_Elmt (Discriminant_Constraint (gnat_entity)); 4095 Present (gnat_field); 4096 gnat_field = Next_Discriminant (gnat_field), 4097 gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) 4098 /* ??? For now, ignore access discriminants. */ 4099 if (! Is_Access_Type (Etype (Node (gnat_discriminant_expr)))) 4100 elaborate_expression (Node (gnat_discriminant_expr), 4101 gnat_entity, 4102 get_entity_name (gnat_field), 1, 0, 0); 4103 } 4104 break; 4105 4106 } 4107 } 4108 4109 /* Mark GNAT_ENTITY as going out of scope at this point. Recursively mark 4110 any entities on its entity chain similarly. */ 4111 4112 void 4113 mark_out_of_scope (Entity_Id gnat_entity) 4114 { 4115 Entity_Id gnat_sub_entity; 4116 unsigned int kind = Ekind (gnat_entity); 4117 4118 /* If this has an entity list, process all in the list. */ 4119 if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind) 4120 || IN (kind, Private_Kind) 4121 || kind == E_Block || kind == E_Entry || kind == E_Entry_Family 4122 || kind == E_Function || kind == E_Generic_Function 4123 || kind == E_Generic_Package || kind == E_Generic_Procedure 4124 || kind == E_Loop || kind == E_Operator || kind == E_Package 4125 || kind == E_Package_Body || kind == E_Procedure 4126 || kind == E_Record_Type || kind == E_Record_Subtype 4127 || kind == E_Subprogram_Body || kind == E_Subprogram_Type) 4128 for (gnat_sub_entity = First_Entity (gnat_entity); 4129 Present (gnat_sub_entity); 4130 gnat_sub_entity = Next_Entity (gnat_sub_entity)) 4131 if (Scope (gnat_sub_entity) == gnat_entity 4132 && gnat_sub_entity != gnat_entity) 4133 mark_out_of_scope (gnat_sub_entity); 4134 4135 /* Now clear this if it has been defined, but only do so if it isn't 4136 a subprogram or parameter. We could refine this, but it isn't 4137 worth it. If this is statically allocated, it is supposed to 4138 hang around out of cope. */ 4139 if (present_gnu_tree (gnat_entity) && ! Is_Statically_Allocated (gnat_entity) 4140 && kind != E_Procedure && kind != E_Function && ! IN (kind, Formal_Kind)) 4141 { 4142 save_gnu_tree (gnat_entity, NULL_TREE, 1); 4143 save_gnu_tree (gnat_entity, error_mark_node, 1); 4144 } 4145 } 4146 4147 /* Return a TREE_LIST describing the substitutions needed to reflect 4148 discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add 4149 them to GNU_LIST. If GNAT_TYPE is not specified, use the base type 4150 of GNAT_SUBTYPE. The substitions can be in any order. TREE_PURPOSE 4151 gives the tree for the discriminant and TREE_VALUES is the replacement 4152 value. They are in the form of operands to substitute_in_expr. 4153 DEFINITION is as in gnat_to_gnu_entity. */ 4154 4155 static tree 4156 substitution_list (Entity_Id gnat_subtype, 4157 Entity_Id gnat_type, 4158 tree gnu_list, 4159 int definition) 4160 { 4161 Entity_Id gnat_discrim; 4162 Node_Id gnat_value; 4163 4164 if (No (gnat_type)) 4165 gnat_type = Implementation_Base_Type (gnat_subtype); 4166 4167 if (Has_Discriminants (gnat_type)) 4168 for (gnat_discrim = First_Stored_Discriminant (gnat_type), 4169 gnat_value = First_Elmt (Stored_Constraint (gnat_subtype)); 4170 Present (gnat_discrim); 4171 gnat_discrim = Next_Stored_Discriminant (gnat_discrim), 4172 gnat_value = Next_Elmt (gnat_value)) 4173 /* Ignore access discriminants. */ 4174 if (! Is_Access_Type (Etype (Node (gnat_value)))) 4175 gnu_list = tree_cons (gnat_to_gnu_entity (gnat_discrim, NULL_TREE, 0), 4176 elaborate_expression 4177 (Node (gnat_value), gnat_subtype, 4178 get_entity_name (gnat_discrim), definition, 4179 1, 0), 4180 gnu_list); 4181 4182 return gnu_list; 4183 } 4184 4185 /* For the following two functions: for each GNAT entity, the GCC 4186 tree node used as a dummy for that entity, if any. */ 4187 4188 static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table; 4189 4190 /* Initialize the above table. */ 4191 4192 void 4193 init_dummy_type (void) 4194 { 4195 Node_Id gnat_node; 4196 4197 dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree)); 4198 4199 for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++) 4200 dummy_node_table[gnat_node] = NULL_TREE; 4201 4202 dummy_node_table -= First_Node_Id; 4203 } 4204 4205 /* Make a dummy type corresponding to GNAT_TYPE. */ 4206 4207 tree 4208 make_dummy_type (Entity_Id gnat_type) 4209 { 4210 Entity_Id gnat_underlying; 4211 tree gnu_type; 4212 4213 /* Find a full type for GNAT_TYPE, taking into account any class wide 4214 types. */ 4215 if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type))) 4216 gnat_type = Equivalent_Type (gnat_type); 4217 else if (Ekind (gnat_type) == E_Class_Wide_Type) 4218 gnat_type = Root_Type (gnat_type); 4219 4220 for (gnat_underlying = gnat_type; 4221 (IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind) 4222 && Present (Full_View (gnat_underlying))); 4223 gnat_underlying = Full_View (gnat_underlying)) 4224 ; 4225 4226 /* If it there already a dummy type, use that one. Else make one. */ 4227 if (dummy_node_table[gnat_underlying]) 4228 return dummy_node_table[gnat_underlying]; 4229 4230 /* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make 4231 it a VOID_TYPE. */ 4232 if (Is_Record_Type (gnat_underlying)) 4233 gnu_type = make_node (Is_Unchecked_Union (gnat_underlying) 4234 ? UNION_TYPE : RECORD_TYPE); 4235 else 4236 gnu_type = make_node (ENUMERAL_TYPE); 4237 4238 TYPE_NAME (gnu_type) = get_entity_name (gnat_type); 4239 if (AGGREGATE_TYPE_P (gnu_type)) 4240 TYPE_STUB_DECL (gnu_type) 4241 = pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type)); 4242 4243 TYPE_DUMMY_P (gnu_type) = 1; 4244 dummy_node_table[gnat_underlying] = gnu_type; 4245 4246 return gnu_type; 4247 } 4248 4249 /* Return 1 if the size represented by GNU_SIZE can be handled by an 4250 allocation. If STATIC_P is non-zero, consider only what can be 4251 done with a static allocation. */ 4252 4253 static int 4254 allocatable_size_p (tree gnu_size, int static_p) 4255 { 4256 HOST_WIDE_INT our_size; 4257 4258 /* If this is not a static allocation, the only case we want to forbid 4259 is an overflowing size. That will be converted into a raise a 4260 Storage_Error. */ 4261 if (! static_p) 4262 return ! (TREE_CODE (gnu_size) == INTEGER_CST 4263 && TREE_CONSTANT_OVERFLOW (gnu_size)); 4264 4265 /* Otherwise, we need to deal with both variable sizes and constant 4266 sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT 4267 since assemblers may not like very large sizes. */ 4268 if (!host_integerp (gnu_size, 1)) 4269 return 0; 4270 4271 our_size = tree_low_cst (gnu_size, 1); 4272 return (int) our_size == our_size; 4273 } 4274 4275 /* Return a list of attributes for GNAT_ENTITY, if any. */ 4276 4277 static struct attrib * 4278 build_attr_list (Entity_Id gnat_entity) 4279 { 4280 struct attrib *attr_list = 0; 4281 Node_Id gnat_temp; 4282 4283 for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp); 4284 gnat_temp = Next_Rep_Item (gnat_temp)) 4285 if (Nkind (gnat_temp) == N_Pragma) 4286 { 4287 struct attrib *attr; 4288 tree gnu_arg0 = 0, gnu_arg1 = 0; 4289 Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp); 4290 enum attr_type etype; 4291 4292 if (Present (gnat_assoc) && Present (First (gnat_assoc)) 4293 && Present (Next (First (gnat_assoc))) 4294 && (Nkind (Expression (Next (First (gnat_assoc)))) 4295 == N_String_Literal)) 4296 { 4297 gnu_arg0 = get_identifier (TREE_STRING_POINTER 4298 (gnat_to_gnu 4299 (Expression (Next 4300 (First (gnat_assoc)))))); 4301 if (Present (Next (Next (First (gnat_assoc)))) 4302 && (Nkind (Expression (Next (Next (First (gnat_assoc))))) 4303 == N_String_Literal)) 4304 gnu_arg1 = get_identifier (TREE_STRING_POINTER 4305 (gnat_to_gnu 4306 (Expression 4307 (Next (Next 4308 (First (gnat_assoc))))))); 4309 } 4310 4311 switch (Get_Pragma_Id (Chars (gnat_temp))) 4312 { 4313 case Pragma_Machine_Attribute: 4314 etype = ATTR_MACHINE_ATTRIBUTE; 4315 break; 4316 4317 case Pragma_Linker_Alias: 4318 etype = ATTR_LINK_ALIAS; 4319 break; 4320 4321 case Pragma_Linker_Section: 4322 etype = ATTR_LINK_SECTION; 4323 break; 4324 4325 case Pragma_Weak_External: 4326 etype = ATTR_WEAK_EXTERNAL; 4327 break; 4328 4329 default: 4330 continue; 4331 } 4332 4333 attr = (struct attrib *) xmalloc (sizeof (struct attrib)); 4334 attr->next = attr_list; 4335 attr->type = etype; 4336 attr->name = gnu_arg0; 4337 attr->arg = gnu_arg1; 4338 attr->error_point 4339 = Present (Next (First (gnat_assoc))) 4340 ? Expression (Next (First (gnat_assoc))) : gnat_temp; 4341 attr_list = attr; 4342 } 4343 4344 return attr_list; 4345 } 4346 4347 /* Get the unpadded version of a GNAT type. */ 4348 4349 tree 4350 get_unpadded_type (Entity_Id gnat_entity) 4351 { 4352 tree type = gnat_to_gnu_type (gnat_entity); 4353 4354 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) 4355 type = TREE_TYPE (TYPE_FIELDS (type)); 4356 4357 return type; 4358 } 4359 4360 /* Called when we need to protect a variable object using a save_expr. */ 4361 4362 tree 4363 maybe_variable (tree gnu_operand, Node_Id gnat_node) 4364 { 4365 if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand) 4366 || TREE_CODE (gnu_operand) == SAVE_EXPR 4367 || TREE_CODE (gnu_operand) == NULL_EXPR) 4368 return gnu_operand; 4369 4370 /* If we will be generating code, make sure we are at the proper 4371 line number. */ 4372 if (! global_bindings_p () && ! CONTAINS_PLACEHOLDER_P (gnu_operand)) 4373 set_lineno (gnat_node, 1); 4374 4375 if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF) 4376 return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand), 4377 variable_size (TREE_OPERAND (gnu_operand, 0))); 4378 else 4379 return variable_size (gnu_operand); 4380 } 4381 4382 /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a 4383 type definition (either a bound or a discriminant value) for GNAT_ENTITY, 4384 return the GCC tree to use for that expression. GNU_NAME is the 4385 qualification to use if an external name is appropriate and DEFINITION is 4386 nonzero if this is a definition of GNAT_ENTITY. If NEED_VALUE is nonzero, 4387 we need a result. Otherwise, we are just elaborating this for 4388 side-effects. If NEED_DEBUG is nonzero we need the symbol for debugging 4389 purposes even if it isn't needed for code generation. */ 4390 4391 static tree 4392 elaborate_expression (Node_Id gnat_expr, 4393 Entity_Id gnat_entity, 4394 tree gnu_name, 4395 int definition, 4396 int need_value, 4397 int need_debug) 4398 { 4399 tree gnu_expr; 4400 4401 /* If we already elaborated this expression (e.g., it was involved 4402 in the definition of a private type), use the old value. */ 4403 if (present_gnu_tree (gnat_expr)) 4404 return get_gnu_tree (gnat_expr); 4405 4406 /* If we don't need a value and this is static or a discriment, we 4407 don't need to do anything. */ 4408 else if (! need_value 4409 && (Is_OK_Static_Expression (gnat_expr) 4410 || (Nkind (gnat_expr) == N_Identifier 4411 && Ekind (Entity (gnat_expr)) == E_Discriminant))) 4412 return 0; 4413 4414 /* Otherwise, convert this tree to its GCC equivalant. */ 4415 gnu_expr 4416 = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr), 4417 gnu_name, definition, need_debug); 4418 4419 /* Save the expression in case we try to elaborate this entity again. 4420 Since this is not a DECL, don't check it. If this is a constant, 4421 don't save it since GNAT_EXPR might be used more than once. Also, 4422 don't save if it's a discriminant. */ 4423 if (! CONTAINS_PLACEHOLDER_P (gnu_expr)) 4424 save_gnu_tree (gnat_expr, gnu_expr, 1); 4425 4426 return need_value ? gnu_expr : error_mark_node; 4427 } 4428 4429 /* Similar, but take a GNU expression. */ 4430 4431 static tree 4432 elaborate_expression_1 (Node_Id gnat_expr, 4433 Entity_Id gnat_entity, 4434 tree gnu_expr, 4435 tree gnu_name, 4436 int definition, 4437 int need_debug) 4438 { 4439 tree gnu_decl = 0; 4440 /* Strip any conversions to see if the expression is a readonly variable. 4441 ??? This really should remain readonly, but we have to think about 4442 the typing of the tree here. */ 4443 tree gnu_inner_expr = remove_conversions (gnu_expr, 1); 4444 int expr_global = Is_Public (gnat_entity) || global_bindings_p (); 4445 int expr_variable; 4446 4447 /* In most cases, we won't see a naked FIELD_DECL here because a 4448 discriminant reference will have been replaced with a COMPONENT_REF 4449 when the type is being elaborated. However, there are some cases 4450 involving child types where we will. So convert it to a COMPONENT_REF 4451 here. We have to hope it will be at the highest level of the 4452 expression in these cases. */ 4453 if (TREE_CODE (gnu_expr) == FIELD_DECL) 4454 gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr), 4455 build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), 4456 gnu_expr); 4457 4458 /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable 4459 that is a constant, make a variable that is initialized to contain the 4460 bound when the package containing the definition is elaborated. If 4461 this entity is defined at top level and a bound or discriminant value 4462 isn't a constant or a reference to a discriminant, replace the bound 4463 by the variable; otherwise use a SAVE_EXPR if needed. Note that we 4464 rely here on the fact that an expression cannot contain both the 4465 discriminant and some other variable. */ 4466 4467 expr_variable = (TREE_CODE_CLASS (TREE_CODE (gnu_expr)) != 'c' 4468 && ! (TREE_CODE (gnu_inner_expr) == VAR_DECL 4469 && TREE_READONLY (gnu_inner_expr)) 4470 && ! CONTAINS_PLACEHOLDER_P (gnu_expr)); 4471 4472 /* If this is a static expression or contains a discriminant, we don't 4473 need the variable for debugging (and can't elaborate anyway if a 4474 discriminant). */ 4475 if (need_debug 4476 && (Is_OK_Static_Expression (gnat_expr) 4477 || CONTAINS_PLACEHOLDER_P (gnu_expr))) 4478 need_debug = 0; 4479 4480 /* Now create the variable if we need it. */ 4481 if (need_debug || (expr_variable && expr_global)) 4482 { 4483 set_lineno (gnat_entity, ! global_bindings_p ()); 4484 gnu_decl 4485 = create_var_decl (create_concat_name (gnat_entity, 4486 IDENTIFIER_POINTER (gnu_name)), 4487 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1, 4488 Is_Public (gnat_entity), ! definition, 0, 0); 4489 } 4490 4491 /* We only need to use this variable if we are in global context since GCC 4492 can do the right thing in the local case. */ 4493 if (expr_global && expr_variable) 4494 return gnu_decl; 4495 else if (! expr_variable) 4496 return gnu_expr; 4497 else 4498 return maybe_variable (gnu_expr, gnat_expr); 4499 } 4500 4501 /* Create a record type that contains a field of TYPE with a starting bit 4502 position so that it is aligned to ALIGN bits and is SIZE bytes long. */ 4503 4504 tree 4505 make_aligning_type (tree type, int align, tree size) 4506 { 4507 tree record_type = make_node (RECORD_TYPE); 4508 tree place = build (PLACEHOLDER_EXPR, record_type); 4509 tree size_addr_place = convert (sizetype, 4510 build_unary_op (ADDR_EXPR, NULL_TREE, 4511 place)); 4512 tree name = TYPE_NAME (type); 4513 tree pos, field; 4514 4515 if (TREE_CODE (name) == TYPE_DECL) 4516 name = DECL_NAME (name); 4517 4518 TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN"); 4519 4520 /* The bit position is obtained by "and"ing the alignment minus 1 4521 with the two's complement of the address and multiplying 4522 by the number of bits per unit. Do all this in sizetype. */ 4523 4524 pos = size_binop (MULT_EXPR, 4525 convert (bitsizetype, 4526 size_binop (BIT_AND_EXPR, 4527 size_diffop (size_zero_node, 4528 size_addr_place), 4529 ssize_int ((align / BITS_PER_UNIT) 4530 - 1))), 4531 bitsize_unit_node); 4532 4533 field = create_field_decl (get_identifier ("F"), type, record_type, 4534 1, size, pos, 1); 4535 DECL_BIT_FIELD (field) = 0; 4536 4537 finish_record_type (record_type, field, 1, 0); 4538 TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT; 4539 TYPE_SIZE (record_type) 4540 = size_binop (PLUS_EXPR, 4541 size_binop (MULT_EXPR, convert (bitsizetype, size), 4542 bitsize_unit_node), 4543 bitsize_int (align)); 4544 TYPE_SIZE_UNIT (record_type) 4545 = size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT)); 4546 TYPE_ALIAS_SET (record_type) = get_alias_set (type); 4547 return record_type; 4548 } 4549 4550 /* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's 4551 being used as the field type of a packed record. See if we can rewrite it 4552 as a record that has a non-BLKmode type, which we can pack tighter. If so, 4553 return the new type. If not, return the original type. */ 4554 4555 static tree 4556 make_packable_type (tree type) 4557 { 4558 tree new_type = make_node (TREE_CODE (type)); 4559 tree field_list = NULL_TREE; 4560 tree old_field; 4561 4562 /* Copy the name and flags from the old type to that of the new and set 4563 the alignment to try for an integral type. For QUAL_UNION_TYPE, 4564 also copy the size. */ 4565 TYPE_NAME (new_type) = TYPE_NAME (type); 4566 TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type) 4567 = TYPE_LEFT_JUSTIFIED_MODULAR_P (type); 4568 TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type); 4569 TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type); 4570 if (TREE_CODE (type) == QUAL_UNION_TYPE) 4571 { 4572 TYPE_SIZE (new_type) = TYPE_SIZE (type); 4573 TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type); 4574 } 4575 4576 TYPE_ALIGN (new_type) 4577 = ((HOST_WIDE_INT) 1 4578 << (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1)); 4579 4580 /* Now copy the fields, keeping the position and size. */ 4581 for (old_field = TYPE_FIELDS (type); old_field != 0; 4582 old_field = TREE_CHAIN (old_field)) 4583 { 4584 tree new_field_type = TREE_TYPE (old_field); 4585 tree new_field; 4586 4587 if (TYPE_MODE (new_field_type) == BLKmode 4588 && (TREE_CODE (new_field_type) == RECORD_TYPE 4589 || TREE_CODE (new_field_type) == UNION_TYPE 4590 || TREE_CODE (new_field_type) == QUAL_UNION_TYPE) 4591 && host_integerp (TYPE_SIZE (new_field_type), 1)) 4592 new_field_type = make_packable_type (new_field_type); 4593 4594 new_field = create_field_decl (DECL_NAME (old_field), new_field_type, 4595 new_type, TYPE_PACKED (type), 4596 DECL_SIZE (old_field), 4597 bit_position (old_field), 4598 ! DECL_NONADDRESSABLE_P (old_field)); 4599 4600 DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field); 4601 SET_DECL_ORIGINAL_FIELD (new_field, 4602 (DECL_ORIGINAL_FIELD (old_field) != 0 4603 ? DECL_ORIGINAL_FIELD (old_field) : old_field)); 4604 4605 if (TREE_CODE (new_type) == QUAL_UNION_TYPE) 4606 DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field); 4607 4608 TREE_CHAIN (new_field) = field_list; 4609 field_list = new_field; 4610 } 4611 4612 finish_record_type (new_type, nreverse (field_list), 1, 1); 4613 TYPE_ALIAS_SET (new_type) = get_alias_set (type); 4614 return TYPE_MODE (new_type) == BLKmode ? type : new_type; 4615 } 4616 4617 /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type 4618 if needed. We have already verified that SIZE and TYPE are large enough. 4619 4620 GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and 4621 to issue a warning. 4622 4623 IS_USER_TYPE is nonzero if we must be sure we complete the original type. 4624 4625 DEFINITION is nonzero if this type is being defined. 4626 4627 SAME_RM_SIZE is nonzero if the RM_Size of the resulting type is to be 4628 set to its TYPE_SIZE; otherwise, it's set to the RM_Size of the original 4629 type. */ 4630 4631 static tree 4632 maybe_pad_type (tree type, 4633 tree size, 4634 unsigned int align, 4635 Entity_Id gnat_entity, 4636 const char *name_trailer, 4637 int is_user_type, 4638 int definition, 4639 int same_rm_size) 4640 { 4641 tree orig_size = TYPE_SIZE (type); 4642 tree record; 4643 tree field; 4644 4645 /* If TYPE is a padded type, see if it agrees with any size and alignment 4646 we were given. If so, return the original type. Otherwise, strip 4647 off the padding, since we will either be returning the inner type 4648 or repadding it. If no size or alignment is specified, use that of 4649 the original padded type. */ 4650 4651 if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)) 4652 { 4653 if ((size == 0 4654 || operand_equal_p (round_up (size, 4655 MAX (align, TYPE_ALIGN (type))), 4656 round_up (TYPE_SIZE (type), 4657 MAX (align, TYPE_ALIGN (type))), 4658 0)) 4659 && (align == 0 || align == TYPE_ALIGN (type))) 4660 return type; 4661 4662 if (size == 0) 4663 size = TYPE_SIZE (type); 4664 if (align == 0) 4665 align = TYPE_ALIGN (type); 4666 4667 type = TREE_TYPE (TYPE_FIELDS (type)); 4668 orig_size = TYPE_SIZE (type); 4669 } 4670 4671 /* If the size is either not being changed or is being made smaller (which 4672 is not done here (and is only valid for bitfields anyway), show the size 4673 isn't changing. Likewise, clear the alignment if it isn't being 4674 changed. Then return if we aren't doing anything. */ 4675 4676 if (size != 0 4677 && (operand_equal_p (size, orig_size, 0) 4678 || (TREE_CODE (orig_size) == INTEGER_CST 4679 && tree_int_cst_lt (size, orig_size)))) 4680 size = 0; 4681 4682 if (align == TYPE_ALIGN (type)) 4683 align = 0; 4684 4685 if (align == 0 && size == 0) 4686 return type; 4687 4688 /* We used to modify the record in place in some cases, but that could 4689 generate incorrect debugging information. So make a new record 4690 type and name. */ 4691 record = make_node (RECORD_TYPE); 4692 4693 if (Present (gnat_entity)) 4694 TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer); 4695 4696 /* If we were making a type, complete the original type and give it a 4697 name. */ 4698 if (is_user_type) 4699 create_type_decl (get_entity_name (gnat_entity), type, 4700 0, ! Comes_From_Source (gnat_entity), 4701 ! (TYPE_NAME (type) != 0 4702 && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL 4703 && DECL_IGNORED_P (TYPE_NAME (type)))); 4704 4705 /* If we are changing the alignment and the input type is a record with 4706 BLKmode and a small constant size, try to make a form that has an 4707 integral mode. That might allow this record to have an integral mode, 4708 which will be much more efficient. There is no point in doing this if a 4709 size is specified unless it is also smaller than the biggest alignment 4710 and it is incorrect to do this if the size of the original type is not a 4711 multiple of the alignment. */ 4712 if (align != 0 4713 && TREE_CODE (type) == RECORD_TYPE 4714 && TYPE_MODE (type) == BLKmode 4715 && host_integerp (orig_size, 1) 4716 && compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0 4717 && (size == 0 4718 || (TREE_CODE (size) == INTEGER_CST 4719 && compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0)) 4720 && tree_low_cst (orig_size, 1) % align == 0) 4721 type = make_packable_type (type); 4722 4723 field = create_field_decl (get_identifier ("F"), type, record, 0, 4724 NULL_TREE, bitsize_zero_node, 1); 4725 4726 DECL_INTERNAL_P (field) = 1; 4727 TYPE_SIZE (record) = size != 0 ? size : orig_size; 4728 TYPE_SIZE_UNIT (record) 4729 = convert (sizetype, 4730 size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record), 4731 bitsize_unit_node)); 4732 TYPE_ALIGN (record) = align; 4733 TYPE_IS_PADDING_P (record) = 1; 4734 TYPE_VOLATILE (record) 4735 = Present (gnat_entity) && Treat_As_Volatile (gnat_entity); 4736 finish_record_type (record, field, 1, 0); 4737 4738 /* Keep the RM_Size of the padded record as that of the old record 4739 if requested. */ 4740 SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type)); 4741 4742 /* Unless debugging information isn't being written for the input type, 4743 write a record that shows what we are a subtype of and also make a 4744 variable that indicates our size, if variable. */ 4745 if (TYPE_NAME (record) != 0 4746 && AGGREGATE_TYPE_P (type) 4747 && (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL 4748 || ! DECL_IGNORED_P (TYPE_NAME (type)))) 4749 { 4750 tree marker = make_node (RECORD_TYPE); 4751 tree name = DECL_NAME (TYPE_NAME (record)); 4752 tree orig_name = TYPE_NAME (type); 4753 4754 if (TREE_CODE (orig_name) == TYPE_DECL) 4755 orig_name = DECL_NAME (orig_name); 4756 4757 TYPE_NAME (marker) = concat_id_with_name (name, "XVS"); 4758 finish_record_type (marker, 4759 create_field_decl (orig_name, integer_type_node, 4760 marker, 0, NULL_TREE, NULL_TREE, 4761 0), 4762 0, 0); 4763 4764 if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition) 4765 create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE, 4766 sizetype, TYPE_SIZE (record), 0, 0, 0, 0, 4767 0); 4768 } 4769 4770 type = record; 4771 4772 if (CONTAINS_PLACEHOLDER_P (orig_size)) 4773 orig_size = max_size (orig_size, 1); 4774 4775 /* If the size was widened explicitly, maybe give a warning. */ 4776 if (size != 0 && Present (gnat_entity) 4777 && ! operand_equal_p (size, orig_size, 0) 4778 && ! (TREE_CODE (size) == INTEGER_CST 4779 && TREE_CODE (orig_size) == INTEGER_CST 4780 && tree_int_cst_lt (size, orig_size))) 4781 { 4782 Node_Id gnat_error_node = Empty; 4783 4784 if (Is_Packed_Array_Type (gnat_entity)) 4785 gnat_entity = Associated_Node_For_Itype (gnat_entity); 4786 4787 if ((Ekind (gnat_entity) == E_Component 4788 || Ekind (gnat_entity) == E_Discriminant) 4789 && Present (Component_Clause (gnat_entity))) 4790 gnat_error_node = Last_Bit (Component_Clause (gnat_entity)); 4791 else if (Present (Size_Clause (gnat_entity))) 4792 gnat_error_node = Expression (Size_Clause (gnat_entity)); 4793 4794 /* Generate message only for entities that come from source, since 4795 if we have an entity created by expansion, the message will be 4796 generated for some other corresponding source entity. */ 4797 if (Comes_From_Source (gnat_entity) && Present (gnat_error_node)) 4798 post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node, 4799 gnat_entity, 4800 size_diffop (size, orig_size)); 4801 4802 else if (*name_trailer == 'C' && ! Is_Internal (gnat_entity)) 4803 post_error_ne_tree ("component of& padded{ by ^ bits}?", 4804 gnat_entity, gnat_entity, 4805 size_diffop (size, orig_size)); 4806 } 4807 4808 return type; 4809 } 4810 4811 /* Given a GNU tree and a GNAT list of choices, generate an expression to test 4812 the value passed against the list of choices. */ 4813 4814 tree 4815 choices_to_gnu (tree operand, Node_Id choices) 4816 { 4817 Node_Id choice; 4818 Node_Id gnat_temp; 4819 tree result = integer_zero_node; 4820 tree this_test, low = 0, high = 0, single = 0; 4821 4822 for (choice = First (choices); Present (choice); choice = Next (choice)) 4823 { 4824 switch (Nkind (choice)) 4825 { 4826 case N_Range: 4827 low = gnat_to_gnu (Low_Bound (choice)); 4828 high = gnat_to_gnu (High_Bound (choice)); 4829 4830 /* There's no good type to use here, so we might as well use 4831 integer_type_node. */ 4832 this_test 4833 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, 4834 build_binary_op (GE_EXPR, integer_type_node, 4835 operand, low), 4836 build_binary_op (LE_EXPR, integer_type_node, 4837 operand, high)); 4838 4839 break; 4840 4841 case N_Subtype_Indication: 4842 gnat_temp = Range_Expression (Constraint (choice)); 4843 low = gnat_to_gnu (Low_Bound (gnat_temp)); 4844 high = gnat_to_gnu (High_Bound (gnat_temp)); 4845 4846 this_test 4847 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, 4848 build_binary_op (GE_EXPR, integer_type_node, 4849 operand, low), 4850 build_binary_op (LE_EXPR, integer_type_node, 4851 operand, high)); 4852 break; 4853 4854 case N_Identifier: 4855 case N_Expanded_Name: 4856 /* This represents either a subtype range, an enumeration 4857 literal, or a constant Ekind says which. If an enumeration 4858 literal or constant, fall through to the next case. */ 4859 if (Ekind (Entity (choice)) != E_Enumeration_Literal 4860 && Ekind (Entity (choice)) != E_Constant) 4861 { 4862 tree type = gnat_to_gnu_type (Entity (choice)); 4863 4864 low = TYPE_MIN_VALUE (type); 4865 high = TYPE_MAX_VALUE (type); 4866 4867 this_test 4868 = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, 4869 build_binary_op (GE_EXPR, integer_type_node, 4870 operand, low), 4871 build_binary_op (LE_EXPR, integer_type_node, 4872 operand, high)); 4873 break; 4874 } 4875 /* ... fall through ... */ 4876 case N_Character_Literal: 4877 case N_Integer_Literal: 4878 single = gnat_to_gnu (choice); 4879 this_test = build_binary_op (EQ_EXPR, integer_type_node, operand, 4880 single); 4881 break; 4882 4883 case N_Others_Choice: 4884 this_test = integer_one_node; 4885 break; 4886 4887 default: 4888 gigi_abort (114); 4889 } 4890 4891 result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, 4892 result, this_test); 4893 } 4894 4895 return result; 4896 } 4897 4898 /* Return a GCC tree for a field corresponding to GNAT_FIELD to be 4899 placed in GNU_RECORD_TYPE. 4900 4901 PACKED is 1 if the enclosing record is packed and -1 if the enclosing 4902 record has a Component_Alignment of Storage_Unit. 4903 4904 DEFINITION is nonzero if this field is for a record being defined. */ 4905 4906 static tree 4907 gnat_to_gnu_field (Entity_Id gnat_field, 4908 tree gnu_record_type, 4909 int packed, 4910 int definition) 4911 { 4912 tree gnu_field_id = get_entity_name (gnat_field); 4913 tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); 4914 tree gnu_orig_field_type = gnu_field_type; 4915 tree gnu_pos = 0; 4916 tree gnu_size = 0; 4917 tree gnu_field; 4918 int needs_strict_alignment 4919 = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field)) 4920 || Treat_As_Volatile (gnat_field)); 4921 4922 /* If this field requires strict alignment or contains an item of 4923 variable sized, pretend it isn't packed. */ 4924 if (needs_strict_alignment || is_variable_size (gnu_field_type)) 4925 packed = 0; 4926 4927 /* For packed records, this is one of the few occasions on which we use 4928 the official RM size for discrete or fixed-point components, instead 4929 of the normal GNAT size stored in Esize. See description in Einfo: 4930 "Handling of Type'Size Values" for further details. */ 4931 4932 if (packed == 1) 4933 gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type, 4934 gnat_field, FIELD_DECL, 0, 1); 4935 4936 if (Known_Static_Esize (gnat_field)) 4937 gnu_size = validate_size (Esize (gnat_field), gnu_field_type, 4938 gnat_field, FIELD_DECL, 0, 1); 4939 4940 /* If the field's type is left-justified modular, the wrapper can prevent 4941 packing so we make the field the type of the inner object unless the 4942 situation forbids it. We may not do that when the field is addressable_p, 4943 typically because in that case this field may later be passed by-ref for 4944 a formal argument expecting the left justification. The condition below 4945 is then matching the addressable_p code for COMPONENT_REF. */ 4946 if (! Is_Aliased (gnat_field) && flag_strict_aliasing 4947 && TREE_CODE (gnu_field_type) == RECORD_TYPE 4948 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type)) 4949 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); 4950 4951 /* If we are packing this record or we have a specified size that's 4952 smaller than that of the field type and the field type is also a record 4953 that's BLKmode and with a small constant size, see if we can get a 4954 better form of the type that allows more packing. If we can, show 4955 a size was specified for it if there wasn't one so we know to 4956 make this a bitfield and avoid making things wider. */ 4957 if (TREE_CODE (gnu_field_type) == RECORD_TYPE 4958 && TYPE_MODE (gnu_field_type) == BLKmode 4959 && host_integerp (TYPE_SIZE (gnu_field_type), 1) 4960 && compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0 4961 && (packed 4962 || (gnu_size != 0 && tree_int_cst_lt (gnu_size, 4963 TYPE_SIZE (gnu_field_type))))) 4964 { 4965 gnu_field_type = make_packable_type (gnu_field_type); 4966 4967 if (gnu_field_type != gnu_orig_field_type && gnu_size == 0) 4968 gnu_size = rm_size (gnu_field_type); 4969 } 4970 4971 /* If we are packing the record and the field is BLKmode, round the 4972 size up to a byte boundary. */ 4973 if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size != 0) 4974 gnu_size = round_up (gnu_size, BITS_PER_UNIT); 4975 4976 if (Present (Component_Clause (gnat_field))) 4977 { 4978 gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype); 4979 gnu_size = validate_size (Esize (gnat_field), gnu_field_type, 4980 gnat_field, FIELD_DECL, 0, 1); 4981 4982 /* Ensure the position does not overlap with the parent subtype, 4983 if there is one. */ 4984 if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field))))) 4985 { 4986 tree gnu_parent 4987 = gnat_to_gnu_type (Parent_Subtype 4988 (Underlying_Type (Scope (gnat_field)))); 4989 4990 if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST 4991 && tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent))) 4992 { 4993 post_error_ne_tree 4994 ("offset of& must be beyond parent{, minimum allowed is ^}", 4995 First_Bit (Component_Clause (gnat_field)), gnat_field, 4996 TYPE_SIZE_UNIT (gnu_parent)); 4997 } 4998 } 4999 5000 /* If this field needs strict alignment, ensure the record is 5001 sufficiently aligned and that that position and size are 5002 consistent with the alignment. */ 5003 if (needs_strict_alignment) 5004 { 5005 tree gnu_min_size = round_up (rm_size (gnu_field_type), 5006 TYPE_ALIGN (gnu_field_type)); 5007 5008 TYPE_ALIGN (gnu_record_type) 5009 = MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type)); 5010 5011 /* If Atomic, the size must match exactly and if aliased, the size 5012 must not be less than the rounded size. */ 5013 if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field))) 5014 && ! operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0)) 5015 { 5016 post_error_ne_tree 5017 ("atomic field& must be natural size of type{ (^)}", 5018 Last_Bit (Component_Clause (gnat_field)), gnat_field, 5019 TYPE_SIZE (gnu_field_type)); 5020 5021 gnu_size = 0; 5022 } 5023 5024 else if (Is_Aliased (gnat_field) 5025 && gnu_size != 0 5026 && tree_int_cst_lt (gnu_size, gnu_min_size)) 5027 { 5028 post_error_ne_tree 5029 ("size of aliased field& too small{, minimum required is ^}", 5030 Last_Bit (Component_Clause (gnat_field)), gnat_field, 5031 gnu_min_size); 5032 gnu_size = 0; 5033 } 5034 5035 if (! integer_zerop (size_binop 5036 (TRUNC_MOD_EXPR, gnu_pos, 5037 bitsize_int (TYPE_ALIGN (gnu_field_type))))) 5038 { 5039 if (Is_Aliased (gnat_field)) 5040 post_error_ne_num 5041 ("position of aliased field& must be multiple of ^ bits", 5042 First_Bit (Component_Clause (gnat_field)), gnat_field, 5043 TYPE_ALIGN (gnu_field_type)); 5044 5045 else if (Treat_As_Volatile (gnat_field)) 5046 post_error_ne_num 5047 ("position of volatile field& must be multiple of ^ bits", 5048 First_Bit (Component_Clause (gnat_field)), gnat_field, 5049 TYPE_ALIGN (gnu_field_type)); 5050 5051 else if (Strict_Alignment (Etype (gnat_field))) 5052 post_error_ne_num 5053 ("position of & with aliased or tagged components not multiple of ^ bits", 5054 First_Bit (Component_Clause (gnat_field)), gnat_field, 5055 TYPE_ALIGN (gnu_field_type)); 5056 else 5057 gigi_abort (124); 5058 5059 gnu_pos = 0; 5060 } 5061 5062 /* If an error set the size to zero, show we have no position 5063 either. */ 5064 if (gnu_size == 0) 5065 gnu_pos = 0; 5066 } 5067 5068 if (Is_Atomic (gnat_field)) 5069 check_ok_for_atomic (gnu_field_type, gnat_field, 0); 5070 } 5071 5072 /* If the record has rep clauses and this is the tag field, make a rep 5073 clause for it as well. */ 5074 else if (Has_Specified_Layout (Scope (gnat_field)) 5075 && Chars (gnat_field) == Name_uTag) 5076 { 5077 gnu_pos = bitsize_zero_node; 5078 gnu_size = TYPE_SIZE (gnu_field_type); 5079 } 5080 5081 /* We need to make the size the maximum for the type if it is 5082 self-referential and an unconstrained type. In that case, we can't 5083 pack the field since we can't make a copy to align it. */ 5084 if (TREE_CODE (gnu_field_type) == RECORD_TYPE 5085 && gnu_size == 0 5086 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type)) 5087 && ! Is_Constrained (Underlying_Type (Etype (gnat_field)))) 5088 { 5089 gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1); 5090 packed = 0; 5091 } 5092 5093 /* If no size is specified (or if there was an error), don't specify a 5094 position. */ 5095 if (gnu_size == 0) 5096 gnu_pos = 0; 5097 else 5098 { 5099 /* Unless this field is aliased, we can remove any left-justified 5100 modular type since it's only needed in the unchecked conversion 5101 case, which doesn't apply here. */ 5102 if (! needs_strict_alignment 5103 && TREE_CODE (gnu_field_type) == RECORD_TYPE 5104 && TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type)) 5105 gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type)); 5106 5107 gnu_field_type 5108 = make_type_from_size (gnu_field_type, gnu_size, 5109 Has_Biased_Representation (gnat_field)); 5110 gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, 5111 gnat_field, "PAD", 0, definition, 1); 5112 } 5113 5114 if (TREE_CODE (gnu_field_type) == RECORD_TYPE 5115 && TYPE_CONTAINS_TEMPLATE_P (gnu_field_type)) 5116 gigi_abort (118); 5117 5118 /* Now create the decl for the field. */ 5119 set_lineno (gnat_field, 0); 5120 gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type, 5121 packed, gnu_size, gnu_pos, 5122 Is_Aliased (gnat_field)); 5123 5124 TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field); 5125 5126 if (Ekind (gnat_field) == E_Discriminant) 5127 DECL_DISCRIMINANT_NUMBER (gnu_field) 5128 = UI_To_gnu (Discriminant_Number (gnat_field), sizetype); 5129 5130 return gnu_field; 5131 } 5132 5133 /* Return 1 if TYPE is a type with variable size, a padding type with a field 5134 of variable size or is a record that has a field such a field. */ 5135 5136 static int 5137 is_variable_size (tree type) 5138 { 5139 tree field; 5140 5141 /* We need not be concerned about this at all if we don't have 5142 strict alignment. */ 5143 if (! STRICT_ALIGNMENT) 5144 return 0; 5145 else if (! TREE_CONSTANT (TYPE_SIZE (type))) 5146 return 1; 5147 else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type) 5148 && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type)))) 5149 return 1; 5150 else if (TREE_CODE (type) != RECORD_TYPE 5151 && TREE_CODE (type) != UNION_TYPE 5152 && TREE_CODE (type) != QUAL_UNION_TYPE) 5153 return 0; 5154 5155 for (field = TYPE_FIELDS (type); field != 0; field = TREE_CHAIN (field)) 5156 if (is_variable_size (TREE_TYPE (field))) 5157 return 1; 5158 5159 return 0; 5160 } 5161 5162 /* Return a GCC tree for a record type given a GNAT Component_List and a chain 5163 of GCC trees for fields that are in the record and have already been 5164 processed. When called from gnat_to_gnu_entity during the processing of a 5165 record type definition, the GCC nodes for the discriminants will be on 5166 the chain. The other calls to this function are recursive calls from 5167 itself for the Component_List of a variant and the chain is empty. 5168 5169 PACKED is 1 if this is for a record with "pragma pack" and -1 is this is 5170 for a record type with "pragma component_alignment (storage_unit)". 5171 5172 FINISH_RECORD is nonzero if this call will supply all of the remaining 5173 fields of the record. 5174 5175 P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field 5176 with a rep clause is to be added. If it is nonzero, that is all that 5177 should be done with such fields. 5178 5179 CANCEL_ALIGNMENT, if nonzero, means the alignment should be zeroed 5180 before laying out the record. This means the alignment only serves 5181 to force fields to be bitfields, but not require the record to be 5182 that aligned. This is used for variants. 5183 5184 ALL_REP, if nonzero, means that a rep clause was found for all the 5185 fields. This simplifies the logic since we know we're not in the mixed 5186 case. 5187 5188 The processing of the component list fills in the chain with all of the 5189 fields of the record and then the record type is finished. */ 5190 5191 static void 5192 components_to_record (tree gnu_record_type, 5193 Node_Id component_list, 5194 tree gnu_field_list, 5195 int packed, 5196 int definition, 5197 tree *p_gnu_rep_list, 5198 int cancel_alignment, 5199 int all_rep) 5200 { 5201 Node_Id component_decl; 5202 Entity_Id gnat_field; 5203 Node_Id variant_part; 5204 Node_Id variant; 5205 tree gnu_our_rep_list = NULL_TREE; 5206 tree gnu_field, gnu_last; 5207 int layout_with_rep = 0; 5208 int all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type) != 0; 5209 5210 /* For each variable within each component declaration create a GCC field 5211 and add it to the list, skipping any pragmas in the list. */ 5212 5213 if (Present (Component_Items (component_list))) 5214 for (component_decl = First_Non_Pragma (Component_Items (component_list)); 5215 Present (component_decl); 5216 component_decl = Next_Non_Pragma (component_decl)) 5217 { 5218 gnat_field = Defining_Entity (component_decl); 5219 5220 if (Chars (gnat_field) == Name_uParent) 5221 gnu_field = tree_last (TYPE_FIELDS (gnu_record_type)); 5222 else 5223 { 5224 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, 5225 packed, definition); 5226 5227 /* If this is the _Tag field, put it before any discriminants, 5228 instead of after them as is the case for all other fields. 5229 Ignore field of void type if only annotating. */ 5230 if (Chars (gnat_field) == Name_uTag) 5231 gnu_field_list = chainon (gnu_field_list, gnu_field); 5232 else 5233 { 5234 TREE_CHAIN (gnu_field) = gnu_field_list; 5235 gnu_field_list = gnu_field; 5236 } 5237 } 5238 5239 save_gnu_tree (gnat_field, gnu_field, 0); 5240 } 5241 5242 /* At the end of the component list there may be a variant part. */ 5243 variant_part = Variant_Part (component_list); 5244 5245 /* If this is an unchecked union, each variant must have exactly one 5246 component, each of which becomes one component of this union. */ 5247 if (TREE_CODE (gnu_record_type) == UNION_TYPE && Present (variant_part)) 5248 for (variant = First_Non_Pragma (Variants (variant_part)); 5249 Present (variant); 5250 variant = Next_Non_Pragma (variant)) 5251 { 5252 component_decl 5253 = First_Non_Pragma (Component_Items (Component_List (variant))); 5254 gnat_field = Defining_Entity (component_decl); 5255 gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed, 5256 definition); 5257 TREE_CHAIN (gnu_field) = gnu_field_list; 5258 gnu_field_list = gnu_field; 5259 save_gnu_tree (gnat_field, gnu_field, 0); 5260 } 5261 5262 /* We create a QUAL_UNION_TYPE for the variant part since the variants are 5263 mutually exclusive and should go in the same memory. To do this we need 5264 to treat each variant as a record whose elements are created from the 5265 component list for the variant. So here we create the records from the 5266 lists for the variants and put them all into the QUAL_UNION_TYPE. */ 5267 else if (Present (variant_part)) 5268 { 5269 tree gnu_discriminant = gnat_to_gnu (Name (variant_part)); 5270 Node_Id variant; 5271 tree gnu_union_type = make_node (QUAL_UNION_TYPE); 5272 tree gnu_union_field; 5273 tree gnu_variant_list = NULL_TREE; 5274 tree gnu_name = TYPE_NAME (gnu_record_type); 5275 tree gnu_var_name 5276 = concat_id_with_name 5277 (get_identifier (Get_Name_String (Chars (Name (variant_part)))), 5278 "XVN"); 5279 5280 if (TREE_CODE (gnu_name) == TYPE_DECL) 5281 gnu_name = DECL_NAME (gnu_name); 5282 5283 TYPE_NAME (gnu_union_type) 5284 = concat_id_with_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name)); 5285 TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type); 5286 5287 for (variant = First_Non_Pragma (Variants (variant_part)); 5288 Present (variant); 5289 variant = Next_Non_Pragma (variant)) 5290 { 5291 tree gnu_variant_type = make_node (RECORD_TYPE); 5292 tree gnu_inner_name; 5293 tree gnu_qual; 5294 5295 Get_Variant_Encoding (variant); 5296 gnu_inner_name = get_identifier (Name_Buffer); 5297 TYPE_NAME (gnu_variant_type) 5298 = concat_id_with_name (TYPE_NAME (gnu_union_type), 5299 IDENTIFIER_POINTER (gnu_inner_name)); 5300 5301 /* Set the alignment of the inner type in case we need to make 5302 inner objects into bitfields, but then clear it out 5303 so the record actually gets only the alignment required. */ 5304 TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type); 5305 TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type); 5306 5307 /* Similarly, if the outer record has a size specified and all fields 5308 have record rep clauses, we can propagate the size into the 5309 variant part. */ 5310 if (all_rep_and_size) 5311 { 5312 TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type); 5313 TYPE_SIZE_UNIT (gnu_variant_type) 5314 = TYPE_SIZE_UNIT (gnu_record_type); 5315 } 5316 5317 components_to_record (gnu_variant_type, Component_List (variant), 5318 NULL_TREE, packed, definition, 5319 &gnu_our_rep_list, !all_rep_and_size, all_rep); 5320 5321 gnu_qual = choices_to_gnu (gnu_discriminant, 5322 Discrete_Choices (variant)); 5323 5324 Set_Present_Expr (variant, annotate_value (gnu_qual)); 5325 gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type, 5326 gnu_union_type, 0, 5327 (all_rep_and_size 5328 ? TYPE_SIZE (gnu_record_type) : 0), 5329 (all_rep_and_size 5330 ? bitsize_zero_node : 0), 5331 1); 5332 5333 DECL_INTERNAL_P (gnu_field) = 1; 5334 DECL_QUALIFIER (gnu_field) = gnu_qual; 5335 TREE_CHAIN (gnu_field) = gnu_variant_list; 5336 gnu_variant_list = gnu_field; 5337 } 5338 5339 /* We use to delete the empty variants from the end. However, 5340 we no longer do that because we need them to generate complete 5341 debugging information for the variant record. Otherwise, 5342 the union type definition will be missing the fields associated 5343 to these empty variants. */ 5344 5345 /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */ 5346 if (gnu_variant_list != 0) 5347 { 5348 if (all_rep_and_size) 5349 { 5350 TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type); 5351 TYPE_SIZE_UNIT (gnu_union_type) 5352 = TYPE_SIZE_UNIT (gnu_record_type); 5353 } 5354 5355 finish_record_type (gnu_union_type, nreverse (gnu_variant_list), 5356 all_rep_and_size, 0); 5357 5358 gnu_union_field 5359 = create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type, 5360 packed, 5361 all_rep ? TYPE_SIZE (gnu_union_type) : 0, 5362 all_rep ? bitsize_zero_node : 0, 1); 5363 5364 DECL_INTERNAL_P (gnu_union_field) = 1; 5365 TREE_CHAIN (gnu_union_field) = gnu_field_list; 5366 gnu_field_list = gnu_union_field; 5367 } 5368 } 5369 5370 /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they 5371 do, pull them out and put them into GNU_OUR_REP_LIST. We have to do this 5372 in a separate pass since we want to handle the discriminants but can't 5373 play with them until we've used them in debugging data above. 5374 5375 ??? Note: if we then reorder them, debugging information will be wrong, 5376 but there's nothing that can be done about this at the moment. */ 5377 5378 for (gnu_field = gnu_field_list, gnu_last = 0; gnu_field; ) 5379 { 5380 if (DECL_FIELD_OFFSET (gnu_field) != 0) 5381 { 5382 tree gnu_next = TREE_CHAIN (gnu_field); 5383 5384 if (gnu_last == 0) 5385 gnu_field_list = gnu_next; 5386 else 5387 TREE_CHAIN (gnu_last) = gnu_next; 5388 5389 TREE_CHAIN (gnu_field) = gnu_our_rep_list; 5390 gnu_our_rep_list = gnu_field; 5391 gnu_field = gnu_next; 5392 } 5393 else 5394 { 5395 gnu_last = gnu_field; 5396 gnu_field = TREE_CHAIN (gnu_field); 5397 } 5398 } 5399 5400 /* If we have any items in our rep'ed field list, it is not the case that all 5401 the fields in the record have rep clauses, and P_REP_LIST is nonzero, 5402 set it and ignore the items. Otherwise, sort the fields by bit position 5403 and put them into their own record if we have any fields without 5404 rep clauses. */ 5405 if (gnu_our_rep_list != 0 && p_gnu_rep_list != 0 && ! all_rep) 5406 *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list); 5407 else if (gnu_our_rep_list != 0) 5408 { 5409 tree gnu_rep_type 5410 = gnu_field_list == 0 ? gnu_record_type : make_node (RECORD_TYPE); 5411 int len = list_length (gnu_our_rep_list); 5412 tree *gnu_arr = (tree *) alloca (sizeof (tree) * len); 5413 int i; 5414 5415 /* Set DECL_SECTION_NAME to increasing integers so we have a 5416 stable sort. */ 5417 for (i = 0, gnu_field = gnu_our_rep_list; gnu_field; 5418 gnu_field = TREE_CHAIN (gnu_field), i++) 5419 { 5420 gnu_arr[i] = gnu_field; 5421 DECL_SECTION_NAME (gnu_field) = size_int (i); 5422 } 5423 5424 qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos); 5425 5426 /* Put the fields in the list in order of increasing position, which 5427 means we start from the end. */ 5428 gnu_our_rep_list = NULL_TREE; 5429 for (i = len - 1; i >= 0; i--) 5430 { 5431 TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list; 5432 gnu_our_rep_list = gnu_arr[i]; 5433 DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type; 5434 DECL_SECTION_NAME (gnu_arr[i]) = 0; 5435 } 5436 5437 if (gnu_field_list != 0) 5438 { 5439 finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, 0); 5440 gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type, 5441 gnu_record_type, 0, 0, 0, 1); 5442 DECL_INTERNAL_P (gnu_field) = 1; 5443 gnu_field_list = chainon (gnu_field_list, gnu_field); 5444 } 5445 else 5446 { 5447 layout_with_rep = 1; 5448 gnu_field_list = nreverse (gnu_our_rep_list); 5449 } 5450 } 5451 5452 if (cancel_alignment) 5453 TYPE_ALIGN (gnu_record_type) = 0; 5454 5455 finish_record_type (gnu_record_type, nreverse (gnu_field_list), 5456 layout_with_rep, 0); 5457 } 5458 5459 /* Called via qsort from the above. Returns -1, 1, depending on the 5460 bit positions and ordinals of the two fields. */ 5461 5462 static int 5463 compare_field_bitpos (const PTR rt1, const PTR rt2) 5464 { 5465 tree *t1 = (tree *) rt1; 5466 tree *t2 = (tree *) rt2; 5467 5468 if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2))) 5469 return 5470 (tree_int_cst_lt (DECL_SECTION_NAME (*t1), DECL_SECTION_NAME (*t2)) 5471 ? -1 : 1); 5472 else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2))) 5473 return -1; 5474 else 5475 return 1; 5476 } 5477 5478 /* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be 5479 placed into an Esize, Component_Bit_Offset, or Component_Size value 5480 in the GNAT tree. */ 5481 5482 static Uint 5483 annotate_value (tree gnu_size) 5484 { 5485 int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size)); 5486 TCode tcode; 5487 Node_Ref_Or_Val ops[3], ret; 5488 int i; 5489 int size; 5490 5491 /* If back annotation is suppressed by the front end, return No_Uint */ 5492 if (!Back_Annotate_Rep_Info) 5493 return No_Uint; 5494 5495 /* See if we've already saved the value for this node. */ 5496 if (IS_EXPR_CODE_CLASS (TREE_CODE_CLASS (TREE_CODE (gnu_size))) 5497 && TREE_COMPLEXITY (gnu_size) != 0) 5498 return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_size); 5499 5500 /* If we do not return inside this switch, TCODE will be set to the 5501 code to use for a Create_Node operand and LEN (set above) will be 5502 the number of recursive calls for us to make. */ 5503 5504 switch (TREE_CODE (gnu_size)) 5505 { 5506 case INTEGER_CST: 5507 if (TREE_OVERFLOW (gnu_size)) 5508 return No_Uint; 5509 5510 /* This may have come from a conversion from some smaller type, 5511 so ensure this is in bitsizetype. */ 5512 gnu_size = convert (bitsizetype, gnu_size); 5513 5514 /* For negative values, use NEGATE_EXPR of the supplied value. */ 5515 if (tree_int_cst_sgn (gnu_size) < 0) 5516 { 5517 /* The rediculous code below is to handle the case of the largest 5518 negative integer. */ 5519 tree negative_size = size_diffop (bitsize_zero_node, gnu_size); 5520 int adjust = 0; 5521 tree temp; 5522 5523 if (TREE_CONSTANT_OVERFLOW (negative_size)) 5524 { 5525 negative_size 5526 = size_binop (MINUS_EXPR, bitsize_zero_node, 5527 size_binop (PLUS_EXPR, gnu_size, 5528 bitsize_one_node)); 5529 adjust = 1; 5530 } 5531 5532 temp = build1 (NEGATE_EXPR, bitsizetype, negative_size); 5533 if (adjust) 5534 temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node); 5535 5536 return annotate_value (temp); 5537 } 5538 5539 if (! host_integerp (gnu_size, 1)) 5540 return No_Uint; 5541 5542 size = tree_low_cst (gnu_size, 1); 5543 5544 /* This peculiar test is to make sure that the size fits in an int 5545 on machines where HOST_WIDE_INT is not "int". */ 5546 if (tree_low_cst (gnu_size, 1) == size) 5547 return UI_From_Int (size); 5548 else 5549 return No_Uint; 5550 5551 case COMPONENT_REF: 5552 /* The only case we handle here is a simple discriminant reference. */ 5553 if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR 5554 && TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL 5555 && DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)) != 0) 5556 return Create_Node (Discrim_Val, 5557 annotate_value (DECL_DISCRIMINANT_NUMBER 5558 (TREE_OPERAND (gnu_size, 1))), 5559 No_Uint, No_Uint); 5560 else 5561 return No_Uint; 5562 5563 case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR: 5564 return annotate_value (TREE_OPERAND (gnu_size, 0)); 5565 5566 /* Now just list the operations we handle. */ 5567 case COND_EXPR: tcode = Cond_Expr; break; 5568 case PLUS_EXPR: tcode = Plus_Expr; break; 5569 case MINUS_EXPR: tcode = Minus_Expr; break; 5570 case MULT_EXPR: tcode = Mult_Expr; break; 5571 case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break; 5572 case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break; 5573 case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break; 5574 case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break; 5575 case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break; 5576 case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break; 5577 case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break; 5578 case NEGATE_EXPR: tcode = Negate_Expr; break; 5579 case MIN_EXPR: tcode = Min_Expr; break; 5580 case MAX_EXPR: tcode = Max_Expr; break; 5581 case ABS_EXPR: tcode = Abs_Expr; break; 5582 case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break; 5583 case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break; 5584 case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break; 5585 case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break; 5586 case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break; 5587 case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break; 5588 case LT_EXPR: tcode = Lt_Expr; break; 5589 case LE_EXPR: tcode = Le_Expr; break; 5590 case GT_EXPR: tcode = Gt_Expr; break; 5591 case GE_EXPR: tcode = Ge_Expr; break; 5592 case EQ_EXPR: tcode = Eq_Expr; break; 5593 case NE_EXPR: tcode = Ne_Expr; break; 5594 5595 default: 5596 return No_Uint; 5597 } 5598 5599 /* Now get each of the operands that's relevant for this code. If any 5600 cannot be expressed as a repinfo node, say we can't. */ 5601 for (i = 0; i < 3; i++) 5602 ops[i] = No_Uint; 5603 5604 for (i = 0; i < len; i++) 5605 { 5606 ops[i] = annotate_value (TREE_OPERAND (gnu_size, i)); 5607 if (ops[i] == No_Uint) 5608 return No_Uint; 5609 } 5610 5611 ret = Create_Node (tcode, ops[0], ops[1], ops[2]); 5612 TREE_COMPLEXITY (gnu_size) = ret; 5613 return ret; 5614 } 5615 5616 /* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding 5617 GCC type, set Component_Bit_Offset and Esize to the position and size 5618 used by Gigi. */ 5619 5620 static void 5621 annotate_rep (Entity_Id gnat_entity, tree gnu_type) 5622 { 5623 tree gnu_list; 5624 tree gnu_entry; 5625 Entity_Id gnat_field; 5626 5627 /* We operate by first making a list of all field and their positions 5628 (we can get the sizes easily at any time) by a recursive call 5629 and then update all the sizes into the tree. */ 5630 gnu_list = compute_field_positions (gnu_type, NULL_TREE, 5631 size_zero_node, bitsize_zero_node, 5632 BIGGEST_ALIGNMENT); 5633 5634 for (gnat_field = First_Entity (gnat_entity); Present (gnat_field); 5635 gnat_field = Next_Entity (gnat_field)) 5636 if ((Ekind (gnat_field) == E_Component 5637 || (Ekind (gnat_field) == E_Discriminant 5638 && ! Is_Unchecked_Union (Scope (gnat_field))))) 5639 { 5640 tree parent_offset = bitsize_zero_node; 5641 5642 gnu_entry 5643 = purpose_member (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0), 5644 gnu_list); 5645 5646 if (gnu_entry) 5647 { 5648 if (type_annotate_only && Is_Tagged_Type (gnat_entity)) 5649 { 5650 /* In this mode the tag and parent components have not been 5651 generated, so we add the appropriate offset to each 5652 component. For a component appearing in the current 5653 extension, the offset is the size of the parent. */ 5654 if (Is_Derived_Type (gnat_entity) 5655 && Original_Record_Component (gnat_field) == gnat_field) 5656 parent_offset 5657 = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))), 5658 bitsizetype); 5659 else 5660 parent_offset = bitsize_int (POINTER_SIZE); 5661 } 5662 5663 Set_Component_Bit_Offset 5664 (gnat_field, 5665 annotate_value 5666 (size_binop (PLUS_EXPR, 5667 bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)), 5668 TREE_VALUE (TREE_VALUE 5669 (TREE_VALUE (gnu_entry)))), 5670 parent_offset))); 5671 5672 Set_Esize (gnat_field, 5673 annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry)))); 5674 } 5675 else if (type_annotate_only 5676 && Is_Tagged_Type (gnat_entity) 5677 && Is_Derived_Type (gnat_entity)) 5678 { 5679 /* If there is no gnu_entry, this is an inherited component whose 5680 position is the same as in the parent type. */ 5681 Set_Component_Bit_Offset 5682 (gnat_field, 5683 Component_Bit_Offset (Original_Record_Component (gnat_field))); 5684 Set_Esize (gnat_field, 5685 Esize (Original_Record_Component (gnat_field))); 5686 } 5687 } 5688 } 5689 5690 /* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the 5691 FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte 5692 position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be 5693 placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is 5694 to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is 5695 the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries 5696 so far. */ 5697 5698 static tree 5699 compute_field_positions (tree gnu_type, 5700 tree gnu_list, 5701 tree gnu_pos, 5702 tree gnu_bitpos, 5703 unsigned int offset_align) 5704 { 5705 tree gnu_field; 5706 tree gnu_result = gnu_list; 5707 5708 for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field; 5709 gnu_field = TREE_CHAIN (gnu_field)) 5710 { 5711 tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos, 5712 DECL_FIELD_BIT_OFFSET (gnu_field)); 5713 tree gnu_our_offset = size_binop (PLUS_EXPR, gnu_pos, 5714 DECL_FIELD_OFFSET (gnu_field)); 5715 unsigned int our_offset_align 5716 = MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field)); 5717 5718 gnu_result 5719 = tree_cons (gnu_field, 5720 tree_cons (gnu_our_offset, 5721 tree_cons (size_int (our_offset_align), 5722 gnu_our_bitpos, NULL_TREE), 5723 NULL_TREE), 5724 gnu_result); 5725 5726 if (DECL_INTERNAL_P (gnu_field)) 5727 gnu_result 5728 = compute_field_positions (TREE_TYPE (gnu_field), gnu_result, 5729 gnu_our_offset, gnu_our_bitpos, 5730 our_offset_align); 5731 } 5732 5733 return gnu_result; 5734 } 5735 5736 /* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE 5737 corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding 5738 to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying 5739 the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL 5740 for the size of a field. COMPONENT_P is true if we are being called 5741 to process the Component_Size of GNAT_OBJECT. This is used for error 5742 message handling and to indicate to use the object size of GNU_TYPE. 5743 ZERO_OK is nonzero if a size of zero is permitted; if ZERO_OK is zero, 5744 it means that a size of zero should be treated as an unspecified size. */ 5745 5746 static tree 5747 validate_size (Uint uint_size, 5748 tree gnu_type, 5749 Entity_Id gnat_object, 5750 enum tree_code kind, 5751 int component_p, 5752 int zero_ok) 5753 { 5754 Node_Id gnat_error_node; 5755 tree type_size 5756 = kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type); 5757 tree size; 5758 5759 /* Find the node to use for errors. */ 5760 if ((Ekind (gnat_object) == E_Component 5761 || Ekind (gnat_object) == E_Discriminant) 5762 && Present (Component_Clause (gnat_object))) 5763 gnat_error_node = Last_Bit (Component_Clause (gnat_object)); 5764 else if (Present (Size_Clause (gnat_object))) 5765 gnat_error_node = Expression (Size_Clause (gnat_object)); 5766 else 5767 gnat_error_node = gnat_object; 5768 5769 /* Return 0 if no size was specified, either because Esize was not Present or 5770 the specified size was zero. */ 5771 if (No (uint_size) || uint_size == No_Uint) 5772 return 0; 5773 5774 /* Get the size as a tree. Give an error if a size was specified, but cannot 5775 be represented as in sizetype. */ 5776 size = UI_To_gnu (uint_size, bitsizetype); 5777 if (TREE_OVERFLOW (size)) 5778 { 5779 post_error_ne (component_p ? "component size of & is too large" 5780 : "size of & is too large", 5781 gnat_error_node, gnat_object); 5782 return 0; 5783 } 5784 /* Ignore a negative size since that corresponds to our back-annotation. 5785 Also ignore a zero size unless a size clause exists. */ 5786 else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && ! zero_ok)) 5787 return 0; 5788 5789 /* The size of objects is always a multiple of a byte. */ 5790 if (kind == VAR_DECL 5791 && ! integer_zerop (size_binop (TRUNC_MOD_EXPR, size, 5792 bitsize_unit_node))) 5793 { 5794 if (component_p) 5795 post_error_ne ("component size for& is not a multiple of Storage_Unit", 5796 gnat_error_node, gnat_object); 5797 else 5798 post_error_ne ("size for& is not a multiple of Storage_Unit", 5799 gnat_error_node, gnat_object); 5800 return 0; 5801 } 5802 5803 /* If this is an integral type or a packed array type, the front-end has 5804 verified the size, so we need not do it here (which would entail 5805 checking against the bounds). However, if this is an aliased object, it 5806 may not be smaller than the type of the object. */ 5807 if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type)) 5808 && ! (kind == VAR_DECL && Is_Aliased (gnat_object))) 5809 return size; 5810 5811 /* If the object is a record that contains a template, add the size of 5812 the template to the specified size. */ 5813 if (TREE_CODE (gnu_type) == RECORD_TYPE 5814 && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) 5815 size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size); 5816 5817 /* Modify the size of the type to be that of the maximum size if it has a 5818 discriminant or the size of a thin pointer if this is a fat pointer. */ 5819 if (type_size != 0 && CONTAINS_PLACEHOLDER_P (type_size)) 5820 type_size = max_size (type_size, 1); 5821 else if (TYPE_FAT_POINTER_P (gnu_type)) 5822 type_size = bitsize_int (POINTER_SIZE); 5823 5824 /* If the size of the object is a constant, the new size must not be 5825 smaller. */ 5826 if (TREE_CODE (type_size) != INTEGER_CST 5827 || TREE_OVERFLOW (type_size) 5828 || tree_int_cst_lt (size, type_size)) 5829 { 5830 if (component_p) 5831 post_error_ne_tree 5832 ("component size for& too small{, minimum allowed is ^}", 5833 gnat_error_node, gnat_object, type_size); 5834 else 5835 post_error_ne_tree ("size for& too small{, minimum allowed is ^}", 5836 gnat_error_node, gnat_object, type_size); 5837 5838 if (kind == VAR_DECL && ! component_p 5839 && TREE_CODE (rm_size (gnu_type)) == INTEGER_CST 5840 && ! tree_int_cst_lt (size, rm_size (gnu_type))) 5841 post_error_ne_tree_2 5842 ("\\size of ^ is not a multiple of alignment (^ bits)", 5843 gnat_error_node, gnat_object, rm_size (gnu_type), 5844 TYPE_ALIGN (gnu_type)); 5845 5846 else if (INTEGRAL_TYPE_P (gnu_type)) 5847 post_error_ne ("\\size would be legal if & were not aliased!", 5848 gnat_error_node, gnat_object); 5849 5850 return 0; 5851 } 5852 5853 return size; 5854 } 5855 5856 /* Similarly, but both validate and process a value of RM_Size. This 5857 routine is only called for types. */ 5858 5859 static void 5860 set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity) 5861 { 5862 /* Only give an error if a Value_Size clause was explicitly given. 5863 Otherwise, we'd be duplicating an error on the Size clause. */ 5864 Node_Id gnat_attr_node 5865 = Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size); 5866 tree old_size = rm_size (gnu_type); 5867 tree size; 5868 5869 /* Get the size as a tree. Do nothing if none was specified, either 5870 because RM_Size was not Present or if the specified size was zero. 5871 Give an error if a size was specified, but cannot be represented as 5872 in sizetype. */ 5873 if (No (uint_size) || uint_size == No_Uint) 5874 return; 5875 5876 size = UI_To_gnu (uint_size, bitsizetype); 5877 if (TREE_OVERFLOW (size)) 5878 { 5879 if (Present (gnat_attr_node)) 5880 post_error_ne ("Value_Size of & is too large", gnat_attr_node, 5881 gnat_entity); 5882 5883 return; 5884 } 5885 5886 /* Ignore a negative size since that corresponds to our back-annotation. 5887 Also ignore a zero size unless a size clause exists, a Value_Size 5888 clause exists, or this is an integer type, in which case the 5889 front end will have always set it. */ 5890 else if (tree_int_cst_sgn (size) < 0 5891 || (integer_zerop (size) && No (gnat_attr_node) 5892 && ! Has_Size_Clause (gnat_entity) 5893 && ! Is_Discrete_Or_Fixed_Point_Type (gnat_entity))) 5894 return; 5895 5896 /* If the old size is self-referential, get the maximum size. */ 5897 if (CONTAINS_PLACEHOLDER_P (old_size)) 5898 old_size = max_size (old_size, 1); 5899 5900 /* If the size of the object is a constant, the new size must not be 5901 smaller (the front end checks this for scalar types). */ 5902 if (TREE_CODE (old_size) != INTEGER_CST 5903 || TREE_OVERFLOW (old_size) 5904 || (AGGREGATE_TYPE_P (gnu_type) 5905 && tree_int_cst_lt (size, old_size))) 5906 { 5907 if (Present (gnat_attr_node)) 5908 post_error_ne_tree 5909 ("Value_Size for& too small{, minimum allowed is ^}", 5910 gnat_attr_node, gnat_entity, old_size); 5911 5912 return; 5913 } 5914 5915 /* Otherwise, set the RM_Size. */ 5916 if (TREE_CODE (gnu_type) == INTEGER_TYPE 5917 && Is_Discrete_Or_Fixed_Point_Type (gnat_entity)) 5918 TYPE_RM_SIZE_INT (gnu_type) = size; 5919 else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE) 5920 SET_TYPE_RM_SIZE_ENUM (gnu_type, size); 5921 else if ((TREE_CODE (gnu_type) == RECORD_TYPE 5922 || TREE_CODE (gnu_type) == UNION_TYPE 5923 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) 5924 && ! TYPE_IS_FAT_POINTER_P (gnu_type)) 5925 SET_TYPE_ADA_SIZE (gnu_type, size); 5926 } 5927 5928 /* Given a type TYPE, return a new type whose size is appropriate for SIZE. 5929 If TYPE is the best type, return it. Otherwise, make a new type. We 5930 only support new integral and pointer types. BIASED_P is nonzero if 5931 we are making a biased type. */ 5932 5933 static tree 5934 make_type_from_size (tree type, tree size_tree, int biased_p) 5935 { 5936 tree new_type; 5937 unsigned HOST_WIDE_INT size; 5938 5939 /* If size indicates an error, just return TYPE to avoid propagating the 5940 error. Likewise if it's too large to represent. */ 5941 if (size_tree == 0 || ! host_integerp (size_tree, 1)) 5942 return type; 5943 5944 size = tree_low_cst (size_tree, 1); 5945 switch (TREE_CODE (type)) 5946 { 5947 case INTEGER_TYPE: 5948 case ENUMERAL_TYPE: 5949 /* Only do something if the type is not already the proper size and is 5950 not a packed array type. */ 5951 if (TYPE_PACKED_ARRAY_TYPE_P (type) 5952 || (TYPE_PRECISION (type) == size 5953 && biased_p == (TREE_CODE (type) == INTEGER_CST 5954 && TYPE_BIASED_REPRESENTATION_P (type)))) 5955 break; 5956 5957 size = MIN (size, LONG_LONG_TYPE_SIZE); 5958 new_type = make_signed_type (size); 5959 TREE_TYPE (new_type) 5960 = TREE_TYPE (type) != 0 ? TREE_TYPE (type) : type; 5961 TYPE_MIN_VALUE (new_type) 5962 = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type)); 5963 TYPE_MAX_VALUE (new_type) 5964 = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type)); 5965 TYPE_BIASED_REPRESENTATION_P (new_type) 5966 = ((TREE_CODE (type) == INTEGER_TYPE 5967 && TYPE_BIASED_REPRESENTATION_P (type)) 5968 || biased_p); 5969 TREE_UNSIGNED (new_type) 5970 = TREE_UNSIGNED (type) | TYPE_BIASED_REPRESENTATION_P (new_type); 5971 TYPE_RM_SIZE_INT (new_type) = bitsize_int (size); 5972 return new_type; 5973 5974 case RECORD_TYPE: 5975 /* Do something if this is a fat pointer, in which case we 5976 may need to return the thin pointer. */ 5977 if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2) 5978 return 5979 build_pointer_type 5980 (TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type))); 5981 break; 5982 5983 case POINTER_TYPE: 5984 /* Only do something if this is a thin pointer, in which case we 5985 may need to return the fat pointer. */ 5986 if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2) 5987 return 5988 build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))); 5989 5990 break; 5991 5992 default: 5993 break; 5994 } 5995 5996 return type; 5997 } 5998 5999 /* ALIGNMENT is a Uint giving the alignment specified for GNAT_ENTITY, 6000 a type or object whose present alignment is ALIGN. If this alignment is 6001 valid, return it. Otherwise, give an error and return ALIGN. */ 6002 6003 static unsigned int 6004 validate_alignment (Uint alignment, Entity_Id gnat_entity, unsigned int align) 6005 { 6006 Node_Id gnat_error_node = gnat_entity; 6007 unsigned int new_align; 6008 6009 #ifndef MAX_OFILE_ALIGNMENT 6010 #define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT 6011 #endif 6012 6013 if (Present (Alignment_Clause (gnat_entity))) 6014 gnat_error_node = Expression (Alignment_Clause (gnat_entity)); 6015 6016 /* Don't worry about checking alignment if alignment was not specified 6017 by the source program and we already posted an error for this entity. */ 6018 6019 if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity)) 6020 return align; 6021 6022 /* Within GCC, an alignment is an integer, so we must make sure a 6023 value is specified that fits in that range. Also, alignments of 6024 more than MAX_OFILE_ALIGNMENT can't be supported. */ 6025 6026 if (! UI_Is_In_Int_Range (alignment) 6027 || ((new_align = UI_To_Int (alignment)) 6028 > MAX_OFILE_ALIGNMENT / BITS_PER_UNIT)) 6029 post_error_ne_num ("largest supported alignment for& is ^", 6030 gnat_error_node, gnat_entity, 6031 MAX_OFILE_ALIGNMENT / BITS_PER_UNIT); 6032 else if (! (Present (Alignment_Clause (gnat_entity)) 6033 && From_At_Mod (Alignment_Clause (gnat_entity))) 6034 && new_align * BITS_PER_UNIT < align) 6035 post_error_ne_num ("alignment for& must be at least ^", 6036 gnat_error_node, gnat_entity, 6037 align / BITS_PER_UNIT); 6038 else 6039 align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT); 6040 6041 return align; 6042 } 6043 6044 /* Verify that OBJECT, a type or decl, is something we can implement 6045 atomically. If not, give an error for GNAT_ENTITY. COMP_P is nonzero 6046 if we require atomic components. */ 6047 6048 static void 6049 check_ok_for_atomic (tree object, Entity_Id gnat_entity, int comp_p) 6050 { 6051 Node_Id gnat_error_point = gnat_entity; 6052 Node_Id gnat_node; 6053 enum machine_mode mode; 6054 unsigned int align; 6055 tree size; 6056 6057 /* There are three case of what OBJECT can be. It can be a type, in which 6058 case we take the size, alignment and mode from the type. It can be a 6059 declaration that was indirect, in which case the relevant values are 6060 that of the type being pointed to, or it can be a normal declaration, 6061 in which case the values are of the decl. The code below assumes that 6062 OBJECT is either a type or a decl. */ 6063 if (TYPE_P (object)) 6064 { 6065 mode = TYPE_MODE (object); 6066 align = TYPE_ALIGN (object); 6067 size = TYPE_SIZE (object); 6068 } 6069 else if (DECL_BY_REF_P (object)) 6070 { 6071 mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object))); 6072 align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object))); 6073 size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object))); 6074 } 6075 else 6076 { 6077 mode = DECL_MODE (object); 6078 align = DECL_ALIGN (object); 6079 size = DECL_SIZE (object); 6080 } 6081 6082 /* Consider all floating-point types atomic and any types that that are 6083 represented by integers no wider than a machine word. */ 6084 if (GET_MODE_CLASS (mode) == MODE_FLOAT 6085 || ((GET_MODE_CLASS (mode) == MODE_INT 6086 || GET_MODE_CLASS (mode) == MODE_PARTIAL_INT) 6087 && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD)) 6088 return; 6089 6090 /* For the moment, also allow anything that has an alignment equal 6091 to its size and which is smaller than a word. */ 6092 if (size != 0 && TREE_CODE (size) == INTEGER_CST 6093 && compare_tree_int (size, align) == 0 6094 && align <= BITS_PER_WORD) 6095 return; 6096 6097 for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node); 6098 gnat_node = Next_Rep_Item (gnat_node)) 6099 { 6100 if (! comp_p && Nkind (gnat_node) == N_Pragma 6101 && Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic) 6102 gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); 6103 else if (comp_p && Nkind (gnat_node) == N_Pragma 6104 && (Get_Pragma_Id (Chars (gnat_node)) 6105 == Pragma_Atomic_Components)) 6106 gnat_error_point = First (Pragma_Argument_Associations (gnat_node)); 6107 } 6108 6109 if (comp_p) 6110 post_error_ne ("atomic access to component of & cannot be guaranteed", 6111 gnat_error_point, gnat_entity); 6112 else 6113 post_error_ne ("atomic access to & cannot be guaranteed", 6114 gnat_error_point, gnat_entity); 6115 } 6116 6117 /* Given a type T, a FIELD_DECL F, and a replacement value R, 6118 return a new type with all size expressions that contain F 6119 updated by replacing F with R. This is identical to GCC's 6120 substitute_in_type except that it knows about TYPE_INDEX_TYPE. 6121 If F is NULL_TREE, always make a new RECORD_TYPE, even if nothing has 6122 changed. */ 6123 6124 tree 6125 gnat_substitute_in_type (tree t, tree f, tree r) 6126 { 6127 tree new = t; 6128 tree tem; 6129 6130 switch (TREE_CODE (t)) 6131 { 6132 case INTEGER_TYPE: 6133 case ENUMERAL_TYPE: 6134 case BOOLEAN_TYPE: 6135 case CHAR_TYPE: 6136 if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)) 6137 || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))) 6138 { 6139 tree low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r); 6140 tree high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r); 6141 6142 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) 6143 return t; 6144 6145 new = build_range_type (TREE_TYPE (t), low, high); 6146 if (TYPE_INDEX_TYPE (t)) 6147 SET_TYPE_INDEX_TYPE (new, 6148 gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r)); 6149 return new; 6150 } 6151 6152 return t; 6153 6154 case REAL_TYPE: 6155 if ((TYPE_MIN_VALUE (t) != 0 6156 && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))) 6157 || (TYPE_MAX_VALUE (t) != 0 6158 && CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))) 6159 { 6160 tree low = 0, high = 0; 6161 6162 if (TYPE_MIN_VALUE (t)) 6163 low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r); 6164 if (TYPE_MAX_VALUE (t)) 6165 high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r); 6166 6167 if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t)) 6168 return t; 6169 6170 t = copy_type (t); 6171 TYPE_MIN_VALUE (t) = low; 6172 TYPE_MAX_VALUE (t) = high; 6173 } 6174 return t; 6175 6176 case COMPLEX_TYPE: 6177 tem = gnat_substitute_in_type (TREE_TYPE (t), f, r); 6178 if (tem == TREE_TYPE (t)) 6179 return t; 6180 6181 return build_complex_type (tem); 6182 6183 case OFFSET_TYPE: 6184 case METHOD_TYPE: 6185 case FILE_TYPE: 6186 case SET_TYPE: 6187 case FUNCTION_TYPE: 6188 case LANG_TYPE: 6189 /* Don't know how to do these yet. */ 6190 abort (); 6191 6192 case ARRAY_TYPE: 6193 { 6194 tree component = gnat_substitute_in_type (TREE_TYPE (t), f, r); 6195 tree domain = gnat_substitute_in_type (TYPE_DOMAIN (t), f, r); 6196 6197 if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t)) 6198 return t; 6199 6200 new = build_array_type (component, domain); 6201 TYPE_SIZE (new) = 0; 6202 TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t); 6203 TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t); 6204 layout_type (new); 6205 TYPE_ALIGN (new) = TYPE_ALIGN (t); 6206 return new; 6207 } 6208 6209 case RECORD_TYPE: 6210 case UNION_TYPE: 6211 case QUAL_UNION_TYPE: 6212 { 6213 tree field; 6214 int changed_field 6215 = (f == NULL_TREE && ! TREE_CONSTANT (TYPE_SIZE (t))); 6216 int field_has_rep = 0; 6217 tree last_field = 0; 6218 6219 tree new = copy_type (t); 6220 6221 /* Start out with no fields, make new fields, and chain them 6222 in. If we haven't actually changed the type of any field, 6223 discard everything we've done and return the old type. */ 6224 6225 TYPE_FIELDS (new) = 0; 6226 TYPE_SIZE (new) = 0; 6227 6228 for (field = TYPE_FIELDS (t); field; 6229 field = TREE_CHAIN (field)) 6230 { 6231 tree new_field = copy_node (field); 6232 6233 TREE_TYPE (new_field) 6234 = gnat_substitute_in_type (TREE_TYPE (new_field), f, r); 6235 6236 if (DECL_HAS_REP_P (field) && ! DECL_INTERNAL_P (field)) 6237 field_has_rep = 1; 6238 else if (TREE_TYPE (new_field) != TREE_TYPE (field)) 6239 changed_field = 1; 6240 6241 /* If this is an internal field and the type of this field is 6242 a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If 6243 the type just has one element, treat that as the field. 6244 But don't do this if we are processing a QUAL_UNION_TYPE. */ 6245 if (TREE_CODE (t) != QUAL_UNION_TYPE 6246 && DECL_INTERNAL_P (new_field) 6247 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE 6248 || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE)) 6249 { 6250 if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0) 6251 continue; 6252 6253 if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0) 6254 { 6255 tree next_new_field 6256 = copy_node (TYPE_FIELDS (TREE_TYPE (new_field))); 6257 6258 /* Make sure omitting the union doesn't change 6259 the layout. */ 6260 DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field); 6261 new_field = next_new_field; 6262 } 6263 } 6264 6265 DECL_CONTEXT (new_field) = new; 6266 SET_DECL_ORIGINAL_FIELD (new_field, 6267 (DECL_ORIGINAL_FIELD (field) != 0 6268 ? DECL_ORIGINAL_FIELD (field) : field)); 6269 6270 /* If the size of the old field was set at a constant, 6271 propagate the size in case the type's size was variable. 6272 (This occurs in the case of a variant or discriminated 6273 record with a default size used as a field of another 6274 record.) */ 6275 DECL_SIZE (new_field) 6276 = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST 6277 ? DECL_SIZE (field) : 0; 6278 DECL_SIZE_UNIT (new_field) 6279 = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST 6280 ? DECL_SIZE_UNIT (field) : 0; 6281 6282 if (TREE_CODE (t) == QUAL_UNION_TYPE) 6283 { 6284 tree new_q = substitute_in_expr (DECL_QUALIFIER (field), f, r); 6285 6286 if (new_q != DECL_QUALIFIER (new_field)) 6287 changed_field = 1; 6288 6289 /* Do the substitution inside the qualifier and if we find 6290 that this field will not be present, omit it. */ 6291 DECL_QUALIFIER (new_field) = new_q; 6292 6293 if (integer_zerop (DECL_QUALIFIER (new_field))) 6294 continue; 6295 } 6296 6297 if (last_field == 0) 6298 TYPE_FIELDS (new) = new_field; 6299 else 6300 TREE_CHAIN (last_field) = new_field; 6301 6302 last_field = new_field; 6303 6304 /* If this is a qualified type and this field will always be 6305 present, we are done. */ 6306 if (TREE_CODE (t) == QUAL_UNION_TYPE 6307 && integer_onep (DECL_QUALIFIER (new_field))) 6308 break; 6309 } 6310 6311 /* If this used to be a qualified union type, but we now know what 6312 field will be present, make this a normal union. */ 6313 if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE 6314 && (TYPE_FIELDS (new) == 0 6315 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new))))) 6316 TREE_SET_CODE (new, UNION_TYPE); 6317 else if (! changed_field) 6318 return t; 6319 6320 if (field_has_rep) 6321 gigi_abort (117); 6322 6323 layout_type (new); 6324 6325 /* If the size was originally a constant use it. */ 6326 if (TYPE_SIZE (t) != 0 && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST 6327 && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST) 6328 { 6329 TYPE_SIZE (new) = TYPE_SIZE (t); 6330 TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t); 6331 SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t)); 6332 } 6333 6334 return new; 6335 } 6336 6337 default: 6338 return t; 6339 } 6340 } 6341 6342 /* Return the "RM size" of GNU_TYPE. This is the actual number of bits 6343 needed to represent the object. */ 6344 6345 tree 6346 rm_size (tree gnu_type) 6347 { 6348 /* For integer types, this is the precision. For record types, we store 6349 the size explicitly. For other types, this is just the size. */ 6350 6351 if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type) != 0) 6352 return TYPE_RM_SIZE (gnu_type); 6353 else if (TREE_CODE (gnu_type) == RECORD_TYPE 6354 && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) 6355 /* Return the rm_size of the actual data plus the size of the template. */ 6356 return 6357 size_binop (PLUS_EXPR, 6358 rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))), 6359 DECL_SIZE (TYPE_FIELDS (gnu_type))); 6360 else if ((TREE_CODE (gnu_type) == RECORD_TYPE 6361 || TREE_CODE (gnu_type) == UNION_TYPE 6362 || TREE_CODE (gnu_type) == QUAL_UNION_TYPE) 6363 && ! TYPE_IS_FAT_POINTER_P (gnu_type) 6364 && TYPE_ADA_SIZE (gnu_type) != 0) 6365 return TYPE_ADA_SIZE (gnu_type); 6366 else 6367 return TYPE_SIZE (gnu_type); 6368 } 6369 6370 /* Return an identifier representing the external name to be used for 6371 GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___" 6372 and the specified suffix. */ 6373 6374 tree 6375 create_concat_name (Entity_Id gnat_entity, const char *suffix) 6376 { 6377 const char *str = (suffix == 0 ? "" : suffix); 6378 String_Template temp = {1, strlen (str)}; 6379 Fat_Pointer fp = {str, &temp}; 6380 6381 Get_External_Name_With_Suffix (gnat_entity, fp); 6382 6383 #ifdef _WIN32 6384 /* A variable using the Stdcall convention (meaning we are running 6385 on a Windows box) live in a DLL. Here we adjust its name to use 6386 the jump-table, the _imp__NAME contains the address for the NAME 6387 variable. */ 6388 6389 { 6390 Entity_Kind kind = Ekind (gnat_entity); 6391 const char *prefix = "_imp__"; 6392 int plen = strlen (prefix); 6393 6394 if ((kind == E_Variable || kind == E_Constant) 6395 && Convention (gnat_entity) == Convention_Stdcall) 6396 { 6397 int k; 6398 for (k = 0; k <= Name_Len; k++) 6399 Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k]; 6400 strncpy (Name_Buffer, prefix, plen); 6401 } 6402 } 6403 #endif 6404 6405 return get_identifier (Name_Buffer); 6406 } 6407 6408 /* Return the name to be used for GNAT_ENTITY. If a type, create a 6409 fully-qualified name, possibly with type information encoding. 6410 Otherwise, return the name. */ 6411 6412 tree 6413 get_entity_name (Entity_Id gnat_entity) 6414 { 6415 Get_Encoded_Name (gnat_entity); 6416 return get_identifier (Name_Buffer); 6417 } 6418 6419 /* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a 6420 string, return a new IDENTIFIER_NODE that is the concatenation of 6421 the name in GNU_ID and SUFFIX. */ 6422 6423 tree 6424 concat_id_with_name (tree gnu_id, const char *suffix) 6425 { 6426 int len = IDENTIFIER_LENGTH (gnu_id); 6427 6428 strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), 6429 IDENTIFIER_LENGTH (gnu_id)); 6430 strncpy (Name_Buffer + len, "___", 3); 6431 len += 3; 6432 strcpy (Name_Buffer + len, suffix); 6433 return get_identifier (Name_Buffer); 6434 } 6435 6436 #include "gt-ada-decl.h" 6437