1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C H 3 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Exp_Aggr; use Exp_Aggr; 32with Exp_Atag; use Exp_Atag; 33with Exp_Ch4; use Exp_Ch4; 34with Exp_Ch6; use Exp_Ch6; 35with Exp_Ch7; use Exp_Ch7; 36with Exp_Ch9; use Exp_Ch9; 37with Exp_Ch11; use Exp_Ch11; 38with Exp_Dbug; use Exp_Dbug; 39with Exp_Disp; use Exp_Disp; 40with Exp_Dist; use Exp_Dist; 41with Exp_Smem; use Exp_Smem; 42with Exp_Strm; use Exp_Strm; 43with Exp_Tss; use Exp_Tss; 44with Exp_Util; use Exp_Util; 45with Freeze; use Freeze; 46with Ghost; use Ghost; 47with Inline; use Inline; 48with Namet; use Namet; 49with Nlists; use Nlists; 50with Nmake; use Nmake; 51with Opt; use Opt; 52with Restrict; use Restrict; 53with Rident; use Rident; 54with Rtsfind; use Rtsfind; 55with Sem; use Sem; 56with Sem_Aux; use Sem_Aux; 57with Sem_Attr; use Sem_Attr; 58with Sem_Cat; use Sem_Cat; 59with Sem_Ch3; use Sem_Ch3; 60with Sem_Ch6; use Sem_Ch6; 61with Sem_Ch8; use Sem_Ch8; 62with Sem_Ch13; use Sem_Ch13; 63with Sem_Disp; use Sem_Disp; 64with Sem_Eval; use Sem_Eval; 65with Sem_Mech; use Sem_Mech; 66with Sem_Res; use Sem_Res; 67with Sem_SCIL; use Sem_SCIL; 68with Sem_Type; use Sem_Type; 69with Sem_Util; use Sem_Util; 70with Sinfo; use Sinfo; 71with Stand; use Stand; 72with Snames; use Snames; 73with Targparm; use Targparm; 74with Tbuild; use Tbuild; 75with Ttypes; use Ttypes; 76with Validsw; use Validsw; 77 78package body Exp_Ch3 is 79 80 ----------------------- 81 -- Local Subprograms -- 82 ----------------------- 83 84 procedure Adjust_Discriminants (Rtype : Entity_Id); 85 -- This is used when freezing a record type. It attempts to construct 86 -- more restrictive subtypes for discriminants so that the max size of 87 -- the record can be calculated more accurately. See the body of this 88 -- procedure for details. 89 90 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); 91 -- Build initialization procedure for given array type. Nod is a node 92 -- used for attachment of any actions required in its construction. 93 -- It also supplies the source location used for the procedure. 94 95 function Build_Array_Invariant_Proc 96 (A_Type : Entity_Id; 97 Nod : Node_Id) return Node_Id; 98 -- If the component of type of array type has invariants, build procedure 99 -- that checks invariant on all components of the array. Ada 2012 specifies 100 -- that an invariant on some type T must be applied to in-out parameters 101 -- and return values that include a part of type T. If the array type has 102 -- an otherwise specified invariant, the component check procedure is 103 -- called from within the user-specified invariant. Otherwise this becomes 104 -- the invariant procedure for the array type. 105 106 function Build_Record_Invariant_Proc 107 (R_Type : Entity_Id; 108 Nod : Node_Id) return Node_Id; 109 -- Ditto for record types. 110 111 function Build_Discriminant_Formals 112 (Rec_Id : Entity_Id; 113 Use_Dl : Boolean) return List_Id; 114 -- This function uses the discriminants of a type to build a list of 115 -- formal parameters, used in Build_Init_Procedure among other places. 116 -- If the flag Use_Dl is set, the list is built using the already 117 -- defined discriminals of the type, as is the case for concurrent 118 -- types with discriminants. Otherwise new identifiers are created, 119 -- with the source names of the discriminants. 120 121 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id; 122 -- This function builds a static aggregate that can serve as the initial 123 -- value for an array type whose bounds are static, and whose component 124 -- type is a composite type that has a static equivalent aggregate. 125 -- The equivalent array aggregate is used both for object initialization 126 -- and for component initialization, when used in the following function. 127 128 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id; 129 -- This function builds a static aggregate that can serve as the initial 130 -- value for a record type whose components are scalar and initialized 131 -- with compile-time values, or arrays with similar initialization or 132 -- defaults. When possible, initialization of an object of the type can 133 -- be achieved by using a copy of the aggregate as an initial value, thus 134 -- removing the implicit call that would otherwise constitute elaboration 135 -- code. 136 137 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id); 138 -- Build record initialization procedure. N is the type declaration 139 -- node, and Rec_Ent is the corresponding entity for the record type. 140 141 procedure Build_Slice_Assignment (Typ : Entity_Id); 142 -- Build assignment procedure for one-dimensional arrays of controlled 143 -- types. Other array and slice assignments are expanded in-line, but 144 -- the code expansion for controlled components (when control actions 145 -- are active) can lead to very large blocks that GCC3 handles poorly. 146 147 procedure Build_Untagged_Equality (Typ : Entity_Id); 148 -- AI05-0123: Equality on untagged records composes. This procedure 149 -- builds the equality routine for an untagged record that has components 150 -- of a record type that has user-defined primitive equality operations. 151 -- The resulting operation is a TSS subprogram. 152 153 procedure Build_Variant_Record_Equality (Typ : Entity_Id); 154 -- Create An Equality function for the untagged variant record Typ and 155 -- attach it to the TSS list 156 157 procedure Check_Stream_Attributes (Typ : Entity_Id); 158 -- Check that if a limited extension has a parent with user-defined stream 159 -- attributes, and does not itself have user-defined stream-attributes, 160 -- then any limited component of the extension also has the corresponding 161 -- user-defined stream attributes. 162 163 procedure Clean_Task_Names 164 (Typ : Entity_Id; 165 Proc_Id : Entity_Id); 166 -- If an initialization procedure includes calls to generate names 167 -- for task subcomponents, indicate that secondary stack cleanup is 168 -- needed after an initialization. Typ is the component type, and Proc_Id 169 -- the initialization procedure for the enclosing composite type. 170 171 procedure Expand_Freeze_Array_Type (N : Node_Id); 172 -- Freeze an array type. Deals with building the initialization procedure, 173 -- creating the packed array type for a packed array and also with the 174 -- creation of the controlling procedures for the controlled case. The 175 -- argument N is the N_Freeze_Entity node for the type. 176 177 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id); 178 -- Freeze a class-wide type. Build routine Finalize_Address for the purpose 179 -- of finalizing controlled derivations from the class-wide's root type. 180 181 procedure Expand_Freeze_Enumeration_Type (N : Node_Id); 182 -- Freeze enumeration type with non-standard representation. Builds the 183 -- array and function needed to convert between enumeration pos and 184 -- enumeration representation values. N is the N_Freeze_Entity node 185 -- for the type. 186 187 procedure Expand_Freeze_Record_Type (N : Node_Id); 188 -- Freeze record type. Builds all necessary discriminant checking 189 -- and other ancillary functions, and builds dispatch tables where 190 -- needed. The argument N is the N_Freeze_Entity node. This processing 191 -- applies only to E_Record_Type entities, not to class wide types, 192 -- record subtypes, or private types. 193 194 procedure Expand_Tagged_Root (T : Entity_Id); 195 -- Add a field _Tag at the beginning of the record. This field carries 196 -- the value of the access to the Dispatch table. This procedure is only 197 -- called on root type, the _Tag field being inherited by the descendants. 198 199 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); 200 -- Treat user-defined stream operations as renaming_as_body if the 201 -- subprogram they rename is not frozen when the type is frozen. 202 203 procedure Insert_Component_Invariant_Checks 204 (N : Node_Id; 205 Typ : Entity_Id; 206 Proc : Node_Id); 207 -- If a composite type has invariants and also has components with defined 208 -- invariants. the component invariant procedure is inserted into the user- 209 -- defined invariant procedure and added to the checks to be performed. 210 211 procedure Initialization_Warning (E : Entity_Id); 212 -- If static elaboration of the package is requested, indicate 213 -- when a type does meet the conditions for static initialization. If 214 -- E is a type, it has components that have no static initialization. 215 -- if E is an entity, its initial expression is not compile-time known. 216 217 function Init_Formals (Typ : Entity_Id) return List_Id; 218 -- This function builds the list of formals for an initialization routine. 219 -- The first formal is always _Init with the given type. For task value 220 -- record types and types containing tasks, three additional formals are 221 -- added: 222 -- 223 -- _Master : Master_Id 224 -- _Chain : in out Activation_Chain 225 -- _Task_Name : String 226 -- 227 -- The caller must append additional entries for discriminants if required. 228 229 function In_Runtime (E : Entity_Id) return Boolean; 230 -- Check if E is defined in the RTL (in a child of Ada or System). Used 231 -- to avoid to bring in the overhead of _Input, _Output for tagged types. 232 233 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean; 234 -- Returns true if Prim is a user defined equality function 235 236 function Make_Eq_Body 237 (Typ : Entity_Id; 238 Eq_Name : Name_Id) return Node_Id; 239 -- Build the body of a primitive equality operation for a tagged record 240 -- type, or in Ada 2012 for any record type that has components with a 241 -- user-defined equality. Factored out of Predefined_Primitive_Bodies. 242 243 function Make_Eq_Case 244 (E : Entity_Id; 245 CL : Node_Id; 246 Discrs : Elist_Id := New_Elmt_List) return List_Id; 247 -- Building block for variant record equality. Defined to share the code 248 -- between the tagged and untagged case. Given a Component_List node CL, 249 -- it generates an 'if' followed by a 'case' statement that compares all 250 -- components of local temporaries named X and Y (that are declared as 251 -- formals at some upper level). E provides the Sloc to be used for the 252 -- generated code. 253 -- 254 -- IF E is an unchecked_union, Discrs is the list of formals created for 255 -- the inferred discriminants of one operand. These formals are used in 256 -- the generated case statements for each variant of the unchecked union. 257 258 function Make_Eq_If 259 (E : Entity_Id; 260 L : List_Id) return Node_Id; 261 -- Building block for variant record equality. Defined to share the code 262 -- between the tagged and untagged case. Given the list of components 263 -- (or discriminants) L, it generates a return statement that compares all 264 -- components of local temporaries named X and Y (that are declared as 265 -- formals at some upper level). E provides the Sloc to be used for the 266 -- generated code. 267 268 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id; 269 -- Search for a renaming of the inequality dispatching primitive of 270 -- this tagged type. If found then build and return the corresponding 271 -- rename-as-body inequality subprogram; otherwise return Empty. 272 273 procedure Make_Predefined_Primitive_Specs 274 (Tag_Typ : Entity_Id; 275 Predef_List : out List_Id; 276 Renamed_Eq : out Entity_Id); 277 -- Create a list with the specs of the predefined primitive operations. 278 -- For tagged types that are interfaces all these primitives are defined 279 -- abstract. 280 -- 281 -- The following entries are present for all tagged types, and provide 282 -- the results of the corresponding attribute applied to the object. 283 -- Dispatching is required in general, since the result of the attribute 284 -- will vary with the actual object subtype. 285 -- 286 -- _size provides result of 'Size attribute 287 -- typSR provides result of 'Read attribute 288 -- typSW provides result of 'Write attribute 289 -- typSI provides result of 'Input attribute 290 -- typSO provides result of 'Output attribute 291 -- 292 -- The following entries are additionally present for non-limited tagged 293 -- types, and implement additional dispatching operations for predefined 294 -- operations: 295 -- 296 -- _equality implements "=" operator 297 -- _assign implements assignment operation 298 -- typDF implements deep finalization 299 -- typDA implements deep adjust 300 -- 301 -- The latter two are empty procedures unless the type contains some 302 -- controlled components that require finalization actions (the deep 303 -- in the name refers to the fact that the action applies to components). 304 -- 305 -- The list is returned in Predef_List. The Parameter Renamed_Eq either 306 -- returns the value Empty, or else the defining unit name for the 307 -- predefined equality function in the case where the type has a primitive 308 -- operation that is a renaming of predefined equality (but only if there 309 -- is also an overriding user-defined equality function). The returned 310 -- Renamed_Eq will be passed to the corresponding parameter of 311 -- Predefined_Primitive_Bodies. 312 313 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; 314 -- Returns True if there are representation clauses for type T that are not 315 -- inherited. If the result is false, the init_proc and the discriminant 316 -- checking functions of the parent can be reused by a derived type. 317 318 procedure Make_Controlling_Function_Wrappers 319 (Tag_Typ : Entity_Id; 320 Decl_List : out List_Id; 321 Body_List : out List_Id); 322 -- Ada 2005 (AI-391): Makes specs and bodies for the wrapper functions 323 -- associated with inherited functions with controlling results which 324 -- are not overridden. The body of each wrapper function consists solely 325 -- of a return statement whose expression is an extension aggregate 326 -- invoking the inherited subprogram's parent subprogram and extended 327 -- with a null association list. 328 329 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id; 330 -- Ada 2005 (AI-251): Makes specs for null procedures associated with any 331 -- null procedures inherited from an interface type that have not been 332 -- overridden. Only one null procedure will be created for a given set of 333 -- inherited null procedures with homographic profiles. 334 335 function Predef_Spec_Or_Body 336 (Loc : Source_Ptr; 337 Tag_Typ : Entity_Id; 338 Name : Name_Id; 339 Profile : List_Id; 340 Ret_Type : Entity_Id := Empty; 341 For_Body : Boolean := False) return Node_Id; 342 -- This function generates the appropriate expansion for a predefined 343 -- primitive operation specified by its name, parameter profile and 344 -- return type (Empty means this is a procedure). If For_Body is false, 345 -- then the returned node is a subprogram declaration. If For_Body is 346 -- true, then the returned node is a empty subprogram body containing 347 -- no declarations and no statements. 348 349 function Predef_Stream_Attr_Spec 350 (Loc : Source_Ptr; 351 Tag_Typ : Entity_Id; 352 Name : TSS_Name_Type; 353 For_Body : Boolean := False) return Node_Id; 354 -- Specialized version of Predef_Spec_Or_Body that apply to read, write, 355 -- input and output attribute whose specs are constructed in Exp_Strm. 356 357 function Predef_Deep_Spec 358 (Loc : Source_Ptr; 359 Tag_Typ : Entity_Id; 360 Name : TSS_Name_Type; 361 For_Body : Boolean := False) return Node_Id; 362 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust 363 -- and _deep_finalize 364 365 function Predefined_Primitive_Bodies 366 (Tag_Typ : Entity_Id; 367 Renamed_Eq : Entity_Id) return List_Id; 368 -- Create the bodies of the predefined primitives that are described in 369 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote 370 -- the defining unit name of the type's predefined equality as returned 371 -- by Make_Predefined_Primitive_Specs. 372 373 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; 374 -- Freeze entities of all predefined primitive operations. This is needed 375 -- because the bodies of these operations do not normally do any freezing. 376 377 function Stream_Operation_OK 378 (Typ : Entity_Id; 379 Operation : TSS_Name_Type) return Boolean; 380 -- Check whether the named stream operation must be emitted for a given 381 -- type. The rules for inheritance of stream attributes by type extensions 382 -- are enforced by this function. Furthermore, various restrictions prevent 383 -- the generation of these operations, as a useful optimization or for 384 -- certification purposes and to save unnecessary generated code. 385 386 -------------------------- 387 -- Adjust_Discriminants -- 388 -------------------------- 389 390 -- This procedure attempts to define subtypes for discriminants that are 391 -- more restrictive than those declared. Such a replacement is possible if 392 -- we can demonstrate that values outside the restricted range would cause 393 -- constraint errors in any case. The advantage of restricting the 394 -- discriminant types in this way is that the maximum size of the variant 395 -- record can be calculated more conservatively. 396 397 -- An example of a situation in which we can perform this type of 398 -- restriction is the following: 399 400 -- subtype B is range 1 .. 10; 401 -- type Q is array (B range <>) of Integer; 402 403 -- type V (N : Natural) is record 404 -- C : Q (1 .. N); 405 -- end record; 406 407 -- In this situation, we can restrict the upper bound of N to 10, since 408 -- any larger value would cause a constraint error in any case. 409 410 -- There are many situations in which such restriction is possible, but 411 -- for now, we just look for cases like the above, where the component 412 -- in question is a one dimensional array whose upper bound is one of 413 -- the record discriminants. Also the component must not be part of 414 -- any variant part, since then the component does not always exist. 415 416 procedure Adjust_Discriminants (Rtype : Entity_Id) is 417 Loc : constant Source_Ptr := Sloc (Rtype); 418 Comp : Entity_Id; 419 Ctyp : Entity_Id; 420 Ityp : Entity_Id; 421 Lo : Node_Id; 422 Hi : Node_Id; 423 P : Node_Id; 424 Loval : Uint; 425 Discr : Entity_Id; 426 Dtyp : Entity_Id; 427 Dhi : Node_Id; 428 Dhiv : Uint; 429 Ahi : Node_Id; 430 Ahiv : Uint; 431 Tnn : Entity_Id; 432 433 begin 434 Comp := First_Component (Rtype); 435 while Present (Comp) loop 436 437 -- If our parent is a variant, quit, we do not look at components 438 -- that are in variant parts, because they may not always exist. 439 440 P := Parent (Comp); -- component declaration 441 P := Parent (P); -- component list 442 443 exit when Nkind (Parent (P)) = N_Variant; 444 445 -- We are looking for a one dimensional array type 446 447 Ctyp := Etype (Comp); 448 449 if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then 450 goto Continue; 451 end if; 452 453 -- The lower bound must be constant, and the upper bound is a 454 -- discriminant (which is a discriminant of the current record). 455 456 Ityp := Etype (First_Index (Ctyp)); 457 Lo := Type_Low_Bound (Ityp); 458 Hi := Type_High_Bound (Ityp); 459 460 if not Compile_Time_Known_Value (Lo) 461 or else Nkind (Hi) /= N_Identifier 462 or else No (Entity (Hi)) 463 or else Ekind (Entity (Hi)) /= E_Discriminant 464 then 465 goto Continue; 466 end if; 467 468 -- We have an array with appropriate bounds 469 470 Loval := Expr_Value (Lo); 471 Discr := Entity (Hi); 472 Dtyp := Etype (Discr); 473 474 -- See if the discriminant has a known upper bound 475 476 Dhi := Type_High_Bound (Dtyp); 477 478 if not Compile_Time_Known_Value (Dhi) then 479 goto Continue; 480 end if; 481 482 Dhiv := Expr_Value (Dhi); 483 484 -- See if base type of component array has known upper bound 485 486 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); 487 488 if not Compile_Time_Known_Value (Ahi) then 489 goto Continue; 490 end if; 491 492 Ahiv := Expr_Value (Ahi); 493 494 -- The condition for doing the restriction is that the high bound 495 -- of the discriminant is greater than the low bound of the array, 496 -- and is also greater than the high bound of the base type index. 497 498 if Dhiv > Loval and then Dhiv > Ahiv then 499 500 -- We can reset the upper bound of the discriminant type to 501 -- whichever is larger, the low bound of the component, or 502 -- the high bound of the base type array index. 503 504 -- We build a subtype that is declared as 505 506 -- subtype Tnn is discr_type range discr_type'First .. max; 507 508 -- And insert this declaration into the tree. The type of the 509 -- discriminant is then reset to this more restricted subtype. 510 511 Tnn := Make_Temporary (Loc, 'T'); 512 513 Insert_Action (Declaration_Node (Rtype), 514 Make_Subtype_Declaration (Loc, 515 Defining_Identifier => Tnn, 516 Subtype_Indication => 517 Make_Subtype_Indication (Loc, 518 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), 519 Constraint => 520 Make_Range_Constraint (Loc, 521 Range_Expression => 522 Make_Range (Loc, 523 Low_Bound => 524 Make_Attribute_Reference (Loc, 525 Attribute_Name => Name_First, 526 Prefix => New_Occurrence_Of (Dtyp, Loc)), 527 High_Bound => 528 Make_Integer_Literal (Loc, 529 Intval => UI_Max (Loval, Ahiv))))))); 530 531 Set_Etype (Discr, Tnn); 532 end if; 533 534 <<Continue>> 535 Next_Component (Comp); 536 end loop; 537 end Adjust_Discriminants; 538 539 --------------------------- 540 -- Build_Array_Init_Proc -- 541 --------------------------- 542 543 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is 544 Comp_Type : constant Entity_Id := Component_Type (A_Type); 545 Body_Stmts : List_Id; 546 Has_Default_Init : Boolean; 547 Index_List : List_Id; 548 Loc : Source_Ptr; 549 Proc_Id : Entity_Id; 550 551 function Init_Component return List_Id; 552 -- Create one statement to initialize one array component, designated 553 -- by a full set of indexes. 554 555 function Init_One_Dimension (N : Int) return List_Id; 556 -- Create loop to initialize one dimension of the array. The single 557 -- statement in the loop body initializes the inner dimensions if any, 558 -- or else the single component. Note that this procedure is called 559 -- recursively, with N being the dimension to be initialized. A call 560 -- with N greater than the number of dimensions simply generates the 561 -- component initialization, terminating the recursion. 562 563 -------------------- 564 -- Init_Component -- 565 -------------------- 566 567 function Init_Component return List_Id is 568 Comp : Node_Id; 569 570 begin 571 Comp := 572 Make_Indexed_Component (Loc, 573 Prefix => Make_Identifier (Loc, Name_uInit), 574 Expressions => Index_List); 575 576 if Has_Default_Aspect (A_Type) then 577 Set_Assignment_OK (Comp); 578 return New_List ( 579 Make_Assignment_Statement (Loc, 580 Name => Comp, 581 Expression => 582 Convert_To (Comp_Type, 583 Default_Aspect_Component_Value (First_Subtype (A_Type))))); 584 585 elsif Needs_Simple_Initialization (Comp_Type) then 586 Set_Assignment_OK (Comp); 587 return New_List ( 588 Make_Assignment_Statement (Loc, 589 Name => Comp, 590 Expression => 591 Get_Simple_Init_Val 592 (Comp_Type, Nod, Component_Size (A_Type)))); 593 594 else 595 Clean_Task_Names (Comp_Type, Proc_Id); 596 return 597 Build_Initialization_Call 598 (Loc, Comp, Comp_Type, 599 In_Init_Proc => True, 600 Enclos_Type => A_Type); 601 end if; 602 end Init_Component; 603 604 ------------------------ 605 -- Init_One_Dimension -- 606 ------------------------ 607 608 function Init_One_Dimension (N : Int) return List_Id is 609 Index : Entity_Id; 610 611 begin 612 -- If the component does not need initializing, then there is nothing 613 -- to do here, so we return a null body. This occurs when generating 614 -- the dummy Init_Proc needed for Initialize_Scalars processing. 615 616 if not Has_Non_Null_Base_Init_Proc (Comp_Type) 617 and then not Needs_Simple_Initialization (Comp_Type) 618 and then not Has_Task (Comp_Type) 619 and then not Has_Default_Aspect (A_Type) 620 then 621 return New_List (Make_Null_Statement (Loc)); 622 623 -- If all dimensions dealt with, we simply initialize the component 624 625 elsif N > Number_Dimensions (A_Type) then 626 return Init_Component; 627 628 -- Here we generate the required loop 629 630 else 631 Index := 632 Make_Defining_Identifier (Loc, New_External_Name ('J', N)); 633 634 Append (New_Occurrence_Of (Index, Loc), Index_List); 635 636 return New_List ( 637 Make_Implicit_Loop_Statement (Nod, 638 Identifier => Empty, 639 Iteration_Scheme => 640 Make_Iteration_Scheme (Loc, 641 Loop_Parameter_Specification => 642 Make_Loop_Parameter_Specification (Loc, 643 Defining_Identifier => Index, 644 Discrete_Subtype_Definition => 645 Make_Attribute_Reference (Loc, 646 Prefix => 647 Make_Identifier (Loc, Name_uInit), 648 Attribute_Name => Name_Range, 649 Expressions => New_List ( 650 Make_Integer_Literal (Loc, N))))), 651 Statements => Init_One_Dimension (N + 1))); 652 end if; 653 end Init_One_Dimension; 654 655 -- Start of processing for Build_Array_Init_Proc 656 657 begin 658 -- The init proc is created when analyzing the freeze node for the type, 659 -- but it properly belongs with the array type declaration. However, if 660 -- the freeze node is for a subtype of a type declared in another unit 661 -- it seems preferable to use the freeze node as the source location of 662 -- the init proc. In any case this is preferable for gcov usage, and 663 -- the Sloc is not otherwise used by the compiler. 664 665 if In_Open_Scopes (Scope (A_Type)) then 666 Loc := Sloc (A_Type); 667 else 668 Loc := Sloc (Nod); 669 end if; 670 671 -- Nothing to generate in the following cases: 672 673 -- 1. Initialization is suppressed for the type 674 -- 2. An initialization already exists for the base type 675 676 if Initialization_Suppressed (A_Type) 677 or else Present (Base_Init_Proc (A_Type)) 678 then 679 return; 680 end if; 681 682 Index_List := New_List; 683 684 -- We need an initialization procedure if any of the following is true: 685 686 -- 1. The component type has an initialization procedure 687 -- 2. The component type needs simple initialization 688 -- 3. Tasks are present 689 -- 4. The type is marked as a public entity 690 -- 5. The array type has a Default_Component_Value aspect 691 692 -- The reason for the public entity test is to deal properly with the 693 -- Initialize_Scalars pragma. This pragma can be set in the client and 694 -- not in the declaring package, this means the client will make a call 695 -- to the initialization procedure (because one of conditions 1-3 must 696 -- apply in this case), and we must generate a procedure (even if it is 697 -- null) to satisfy the call in this case. 698 699 -- Exception: do not build an array init_proc for a type whose root 700 -- type is Standard.String or Standard.Wide_[Wide_]String, since there 701 -- is no place to put the code, and in any case we handle initialization 702 -- of such types (in the Initialize_Scalars case, that's the only time 703 -- the issue arises) in a special manner anyway which does not need an 704 -- init_proc. 705 706 Has_Default_Init := Has_Non_Null_Base_Init_Proc (Comp_Type) 707 or else Needs_Simple_Initialization (Comp_Type) 708 or else Has_Task (Comp_Type) 709 or else Has_Default_Aspect (A_Type); 710 711 if Has_Default_Init 712 or else (not Restriction_Active (No_Initialize_Scalars) 713 and then Is_Public (A_Type) 714 and then not Is_Standard_String_Type (A_Type)) 715 then 716 Proc_Id := 717 Make_Defining_Identifier (Loc, 718 Chars => Make_Init_Proc_Name (A_Type)); 719 720 -- If No_Default_Initialization restriction is active, then we don't 721 -- want to build an init_proc, but we need to mark that an init_proc 722 -- would be needed if this restriction was not active (so that we can 723 -- detect attempts to call it), so set a dummy init_proc in place. 724 -- This is only done though when actual default initialization is 725 -- needed (and not done when only Is_Public is True), since otherwise 726 -- objects such as arrays of scalars could be wrongly flagged as 727 -- violating the restriction. 728 729 if Restriction_Active (No_Default_Initialization) then 730 if Has_Default_Init then 731 Set_Init_Proc (A_Type, Proc_Id); 732 end if; 733 734 return; 735 end if; 736 737 Body_Stmts := Init_One_Dimension (1); 738 739 Discard_Node ( 740 Make_Subprogram_Body (Loc, 741 Specification => 742 Make_Procedure_Specification (Loc, 743 Defining_Unit_Name => Proc_Id, 744 Parameter_Specifications => Init_Formals (A_Type)), 745 Declarations => New_List, 746 Handled_Statement_Sequence => 747 Make_Handled_Sequence_Of_Statements (Loc, 748 Statements => Body_Stmts))); 749 750 Set_Ekind (Proc_Id, E_Procedure); 751 Set_Is_Public (Proc_Id, Is_Public (A_Type)); 752 Set_Is_Internal (Proc_Id); 753 Set_Has_Completion (Proc_Id); 754 755 if not Debug_Generated_Code then 756 Set_Debug_Info_Off (Proc_Id); 757 end if; 758 759 -- Set inlined unless tasks are around, in which case we do not 760 -- want to inline, because nested stuff may cause difficulties in 761 -- inter-unit inlining, and furthermore there is in any case no 762 -- point in inlining such complex init procs. 763 764 if not Has_Task (Proc_Id) then 765 Set_Is_Inlined (Proc_Id); 766 end if; 767 768 -- Associate Init_Proc with type, and determine if the procedure 769 -- is null (happens because of the Initialize_Scalars pragma case, 770 -- where we have to generate a null procedure in case it is called 771 -- by a client with Initialize_Scalars set). Such procedures have 772 -- to be generated, but do not have to be called, so we mark them 773 -- as null to suppress the call. 774 775 Set_Init_Proc (A_Type, Proc_Id); 776 777 if List_Length (Body_Stmts) = 1 778 779 -- We must skip SCIL nodes because they may have been added to this 780 -- list by Insert_Actions. 781 782 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement 783 then 784 Set_Is_Null_Init_Proc (Proc_Id); 785 786 else 787 -- Try to build a static aggregate to statically initialize 788 -- objects of the type. This can only be done for constrained 789 -- one-dimensional arrays with static bounds. 790 791 Set_Static_Initialization 792 (Proc_Id, 793 Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); 794 end if; 795 end if; 796 end Build_Array_Init_Proc; 797 798 -------------------------------- 799 -- Build_Array_Invariant_Proc -- 800 -------------------------------- 801 802 function Build_Array_Invariant_Proc 803 (A_Type : Entity_Id; 804 Nod : Node_Id) return Node_Id 805 is 806 Loc : constant Source_Ptr := Sloc (Nod); 807 808 Object_Name : constant Name_Id := New_Internal_Name ('I'); 809 -- Name for argument of invariant procedure 810 811 Object_Entity : constant Node_Id := 812 Make_Defining_Identifier (Loc, Object_Name); 813 -- The procedure declaration entity for the argument 814 815 Body_Stmts : List_Id; 816 Index_List : List_Id; 817 Proc_Id : Entity_Id; 818 Proc_Body : Node_Id; 819 820 function Build_Component_Invariant_Call return Node_Id; 821 -- Create one statement to verify invariant on one array component, 822 -- designated by a full set of indexes. 823 824 function Check_One_Dimension (N : Int) return List_Id; 825 -- Create loop to check on one dimension of the array. The single 826 -- statement in the loop body checks the inner dimensions if any, or 827 -- else a single component. This procedure is called recursively, with 828 -- N being the dimension to be initialized. A call with N greater than 829 -- the number of dimensions generates the component initialization 830 -- and terminates the recursion. 831 832 ------------------------------------ 833 -- Build_Component_Invariant_Call -- 834 ------------------------------------ 835 836 function Build_Component_Invariant_Call return Node_Id is 837 Comp : Node_Id; 838 begin 839 Comp := 840 Make_Indexed_Component (Loc, 841 Prefix => New_Occurrence_Of (Object_Entity, Loc), 842 Expressions => Index_List); 843 return 844 Make_Procedure_Call_Statement (Loc, 845 Name => 846 New_Occurrence_Of 847 (Invariant_Procedure (Component_Type (A_Type)), Loc), 848 Parameter_Associations => New_List (Comp)); 849 end Build_Component_Invariant_Call; 850 851 ------------------------- 852 -- Check_One_Dimension -- 853 ------------------------- 854 855 function Check_One_Dimension (N : Int) return List_Id is 856 Index : Entity_Id; 857 858 begin 859 -- If all dimensions dealt with, we simply check invariant of the 860 -- component. 861 862 if N > Number_Dimensions (A_Type) then 863 return New_List (Build_Component_Invariant_Call); 864 865 -- Else generate one loop and recurse 866 867 else 868 Index := 869 Make_Defining_Identifier (Loc, New_External_Name ('J', N)); 870 871 Append (New_Occurrence_Of (Index, Loc), Index_List); 872 873 return New_List ( 874 Make_Implicit_Loop_Statement (Nod, 875 Identifier => Empty, 876 Iteration_Scheme => 877 Make_Iteration_Scheme (Loc, 878 Loop_Parameter_Specification => 879 Make_Loop_Parameter_Specification (Loc, 880 Defining_Identifier => Index, 881 Discrete_Subtype_Definition => 882 Make_Attribute_Reference (Loc, 883 Prefix => 884 New_Occurrence_Of (Object_Entity, Loc), 885 Attribute_Name => Name_Range, 886 Expressions => New_List ( 887 Make_Integer_Literal (Loc, N))))), 888 Statements => Check_One_Dimension (N + 1))); 889 end if; 890 end Check_One_Dimension; 891 892 -- Start of processing for Build_Array_Invariant_Proc 893 894 begin 895 Index_List := New_List; 896 897 Proc_Id := 898 Make_Defining_Identifier (Loc, 899 Chars => New_External_Name (Chars (A_Type), "CInvariant")); 900 901 Body_Stmts := Check_One_Dimension (1); 902 903 Proc_Body := 904 Make_Subprogram_Body (Loc, 905 Specification => 906 Make_Procedure_Specification (Loc, 907 Defining_Unit_Name => Proc_Id, 908 Parameter_Specifications => New_List ( 909 Make_Parameter_Specification (Loc, 910 Defining_Identifier => Object_Entity, 911 Parameter_Type => New_Occurrence_Of (A_Type, Loc)))), 912 913 Declarations => Empty_List, 914 Handled_Statement_Sequence => 915 Make_Handled_Sequence_Of_Statements (Loc, 916 Statements => Body_Stmts)); 917 918 Set_Ekind (Proc_Id, E_Procedure); 919 Set_Is_Public (Proc_Id, Is_Public (A_Type)); 920 Set_Is_Internal (Proc_Id); 921 Set_Has_Completion (Proc_Id); 922 923 if not Debug_Generated_Code then 924 Set_Debug_Info_Off (Proc_Id); 925 end if; 926 927 return Proc_Body; 928 end Build_Array_Invariant_Proc; 929 930 -------------------------------- 931 -- Build_Discr_Checking_Funcs -- 932 -------------------------------- 933 934 procedure Build_Discr_Checking_Funcs (N : Node_Id) is 935 Rec_Id : Entity_Id; 936 Loc : Source_Ptr; 937 Enclosing_Func_Id : Entity_Id; 938 Sequence : Nat := 1; 939 Type_Def : Node_Id; 940 V : Node_Id; 941 942 function Build_Case_Statement 943 (Case_Id : Entity_Id; 944 Variant : Node_Id) return Node_Id; 945 -- Build a case statement containing only two alternatives. The first 946 -- alternative corresponds exactly to the discrete choices given on the 947 -- variant with contains the components that we are generating the 948 -- checks for. If the discriminant is one of these return False. The 949 -- second alternative is an OTHERS choice that will return True 950 -- indicating the discriminant did not match. 951 952 function Build_Dcheck_Function 953 (Case_Id : Entity_Id; 954 Variant : Node_Id) return Entity_Id; 955 -- Build the discriminant checking function for a given variant 956 957 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id); 958 -- Builds the discriminant checking function for each variant of the 959 -- given variant part of the record type. 960 961 -------------------------- 962 -- Build_Case_Statement -- 963 -------------------------- 964 965 function Build_Case_Statement 966 (Case_Id : Entity_Id; 967 Variant : Node_Id) return Node_Id 968 is 969 Alt_List : constant List_Id := New_List; 970 Actuals_List : List_Id; 971 Case_Node : Node_Id; 972 Case_Alt_Node : Node_Id; 973 Choice : Node_Id; 974 Choice_List : List_Id; 975 D : Entity_Id; 976 Return_Node : Node_Id; 977 978 begin 979 Case_Node := New_Node (N_Case_Statement, Loc); 980 981 -- Replace the discriminant which controls the variant with the name 982 -- of the formal of the checking function. 983 984 Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id))); 985 986 Choice := First (Discrete_Choices (Variant)); 987 988 if Nkind (Choice) = N_Others_Choice then 989 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); 990 else 991 Choice_List := New_Copy_List (Discrete_Choices (Variant)); 992 end if; 993 994 if not Is_Empty_List (Choice_List) then 995 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); 996 Set_Discrete_Choices (Case_Alt_Node, Choice_List); 997 998 -- In case this is a nested variant, we need to return the result 999 -- of the discriminant checking function for the immediately 1000 -- enclosing variant. 1001 1002 if Present (Enclosing_Func_Id) then 1003 Actuals_List := New_List; 1004 1005 D := First_Discriminant (Rec_Id); 1006 while Present (D) loop 1007 Append (Make_Identifier (Loc, Chars (D)), Actuals_List); 1008 Next_Discriminant (D); 1009 end loop; 1010 1011 Return_Node := 1012 Make_Simple_Return_Statement (Loc, 1013 Expression => 1014 Make_Function_Call (Loc, 1015 Name => 1016 New_Occurrence_Of (Enclosing_Func_Id, Loc), 1017 Parameter_Associations => 1018 Actuals_List)); 1019 1020 else 1021 Return_Node := 1022 Make_Simple_Return_Statement (Loc, 1023 Expression => 1024 New_Occurrence_Of (Standard_False, Loc)); 1025 end if; 1026 1027 Set_Statements (Case_Alt_Node, New_List (Return_Node)); 1028 Append (Case_Alt_Node, Alt_List); 1029 end if; 1030 1031 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); 1032 Choice_List := New_List (New_Node (N_Others_Choice, Loc)); 1033 Set_Discrete_Choices (Case_Alt_Node, Choice_List); 1034 1035 Return_Node := 1036 Make_Simple_Return_Statement (Loc, 1037 Expression => 1038 New_Occurrence_Of (Standard_True, Loc)); 1039 1040 Set_Statements (Case_Alt_Node, New_List (Return_Node)); 1041 Append (Case_Alt_Node, Alt_List); 1042 1043 Set_Alternatives (Case_Node, Alt_List); 1044 return Case_Node; 1045 end Build_Case_Statement; 1046 1047 --------------------------- 1048 -- Build_Dcheck_Function -- 1049 --------------------------- 1050 1051 function Build_Dcheck_Function 1052 (Case_Id : Entity_Id; 1053 Variant : Node_Id) return Entity_Id 1054 is 1055 Body_Node : Node_Id; 1056 Func_Id : Entity_Id; 1057 Parameter_List : List_Id; 1058 Spec_Node : Node_Id; 1059 1060 begin 1061 Body_Node := New_Node (N_Subprogram_Body, Loc); 1062 Sequence := Sequence + 1; 1063 1064 Func_Id := 1065 Make_Defining_Identifier (Loc, 1066 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); 1067 Set_Is_Discriminant_Check_Function (Func_Id); 1068 1069 Spec_Node := New_Node (N_Function_Specification, Loc); 1070 Set_Defining_Unit_Name (Spec_Node, Func_Id); 1071 1072 Parameter_List := Build_Discriminant_Formals (Rec_Id, False); 1073 1074 Set_Parameter_Specifications (Spec_Node, Parameter_List); 1075 Set_Result_Definition (Spec_Node, 1076 New_Occurrence_Of (Standard_Boolean, Loc)); 1077 Set_Specification (Body_Node, Spec_Node); 1078 Set_Declarations (Body_Node, New_List); 1079 1080 Set_Handled_Statement_Sequence (Body_Node, 1081 Make_Handled_Sequence_Of_Statements (Loc, 1082 Statements => New_List ( 1083 Build_Case_Statement (Case_Id, Variant)))); 1084 1085 Set_Ekind (Func_Id, E_Function); 1086 Set_Mechanism (Func_Id, Default_Mechanism); 1087 Set_Is_Inlined (Func_Id, True); 1088 Set_Is_Pure (Func_Id, True); 1089 Set_Is_Public (Func_Id, Is_Public (Rec_Id)); 1090 Set_Is_Internal (Func_Id, True); 1091 1092 if not Debug_Generated_Code then 1093 Set_Debug_Info_Off (Func_Id); 1094 end if; 1095 1096 Analyze (Body_Node); 1097 1098 Append_Freeze_Action (Rec_Id, Body_Node); 1099 Set_Dcheck_Function (Variant, Func_Id); 1100 return Func_Id; 1101 end Build_Dcheck_Function; 1102 1103 ---------------------------- 1104 -- Build_Dcheck_Functions -- 1105 ---------------------------- 1106 1107 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is 1108 Component_List_Node : Node_Id; 1109 Decl : Entity_Id; 1110 Discr_Name : Entity_Id; 1111 Func_Id : Entity_Id; 1112 Variant : Node_Id; 1113 Saved_Enclosing_Func_Id : Entity_Id; 1114 1115 begin 1116 -- Build the discriminant-checking function for each variant, and 1117 -- label all components of that variant with the function's name. 1118 -- We only Generate a discriminant-checking function when the 1119 -- variant is not empty, to prevent the creation of dead code. 1120 -- The exception to that is when Frontend_Layout_On_Target is set, 1121 -- because the variant record size function generated in package 1122 -- Layout needs to generate calls to all discriminant-checking 1123 -- functions, including those for empty variants. 1124 1125 Discr_Name := Entity (Name (Variant_Part_Node)); 1126 Variant := First_Non_Pragma (Variants (Variant_Part_Node)); 1127 1128 while Present (Variant) loop 1129 Component_List_Node := Component_List (Variant); 1130 1131 if not Null_Present (Component_List_Node) 1132 or else Frontend_Layout_On_Target 1133 then 1134 Func_Id := Build_Dcheck_Function (Discr_Name, Variant); 1135 1136 Decl := 1137 First_Non_Pragma (Component_Items (Component_List_Node)); 1138 while Present (Decl) loop 1139 Set_Discriminant_Checking_Func 1140 (Defining_Identifier (Decl), Func_Id); 1141 Next_Non_Pragma (Decl); 1142 end loop; 1143 1144 if Present (Variant_Part (Component_List_Node)) then 1145 Saved_Enclosing_Func_Id := Enclosing_Func_Id; 1146 Enclosing_Func_Id := Func_Id; 1147 Build_Dcheck_Functions (Variant_Part (Component_List_Node)); 1148 Enclosing_Func_Id := Saved_Enclosing_Func_Id; 1149 end if; 1150 end if; 1151 1152 Next_Non_Pragma (Variant); 1153 end loop; 1154 end Build_Dcheck_Functions; 1155 1156 -- Start of processing for Build_Discr_Checking_Funcs 1157 1158 begin 1159 -- Only build if not done already 1160 1161 if not Discr_Check_Funcs_Built (N) then 1162 Type_Def := Type_Definition (N); 1163 1164 if Nkind (Type_Def) = N_Record_Definition then 1165 if No (Component_List (Type_Def)) then -- null record. 1166 return; 1167 else 1168 V := Variant_Part (Component_List (Type_Def)); 1169 end if; 1170 1171 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); 1172 if No (Component_List (Record_Extension_Part (Type_Def))) then 1173 return; 1174 else 1175 V := Variant_Part 1176 (Component_List (Record_Extension_Part (Type_Def))); 1177 end if; 1178 end if; 1179 1180 Rec_Id := Defining_Identifier (N); 1181 1182 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then 1183 Loc := Sloc (N); 1184 Enclosing_Func_Id := Empty; 1185 Build_Dcheck_Functions (V); 1186 end if; 1187 1188 Set_Discr_Check_Funcs_Built (N); 1189 end if; 1190 end Build_Discr_Checking_Funcs; 1191 1192 -------------------------------- 1193 -- Build_Discriminant_Formals -- 1194 -------------------------------- 1195 1196 function Build_Discriminant_Formals 1197 (Rec_Id : Entity_Id; 1198 Use_Dl : Boolean) return List_Id 1199 is 1200 Loc : Source_Ptr := Sloc (Rec_Id); 1201 Parameter_List : constant List_Id := New_List; 1202 D : Entity_Id; 1203 Formal : Entity_Id; 1204 Formal_Type : Entity_Id; 1205 Param_Spec_Node : Node_Id; 1206 1207 begin 1208 if Has_Discriminants (Rec_Id) then 1209 D := First_Discriminant (Rec_Id); 1210 while Present (D) loop 1211 Loc := Sloc (D); 1212 1213 if Use_Dl then 1214 Formal := Discriminal (D); 1215 Formal_Type := Etype (Formal); 1216 else 1217 Formal := Make_Defining_Identifier (Loc, Chars (D)); 1218 Formal_Type := Etype (D); 1219 end if; 1220 1221 Param_Spec_Node := 1222 Make_Parameter_Specification (Loc, 1223 Defining_Identifier => Formal, 1224 Parameter_Type => 1225 New_Occurrence_Of (Formal_Type, Loc)); 1226 Append (Param_Spec_Node, Parameter_List); 1227 Next_Discriminant (D); 1228 end loop; 1229 end if; 1230 1231 return Parameter_List; 1232 end Build_Discriminant_Formals; 1233 1234 -------------------------------------- 1235 -- Build_Equivalent_Array_Aggregate -- 1236 -------------------------------------- 1237 1238 function Build_Equivalent_Array_Aggregate (T : Entity_Id) return Node_Id is 1239 Loc : constant Source_Ptr := Sloc (T); 1240 Comp_Type : constant Entity_Id := Component_Type (T); 1241 Index_Type : constant Entity_Id := Etype (First_Index (T)); 1242 Proc : constant Entity_Id := Base_Init_Proc (T); 1243 Lo, Hi : Node_Id; 1244 Aggr : Node_Id; 1245 Expr : Node_Id; 1246 1247 begin 1248 if not Is_Constrained (T) 1249 or else Number_Dimensions (T) > 1 1250 or else No (Proc) 1251 then 1252 Initialization_Warning (T); 1253 return Empty; 1254 end if; 1255 1256 Lo := Type_Low_Bound (Index_Type); 1257 Hi := Type_High_Bound (Index_Type); 1258 1259 if not Compile_Time_Known_Value (Lo) 1260 or else not Compile_Time_Known_Value (Hi) 1261 then 1262 Initialization_Warning (T); 1263 return Empty; 1264 end if; 1265 1266 if Is_Record_Type (Comp_Type) 1267 and then Present (Base_Init_Proc (Comp_Type)) 1268 then 1269 Expr := Static_Initialization (Base_Init_Proc (Comp_Type)); 1270 1271 if No (Expr) then 1272 Initialization_Warning (T); 1273 return Empty; 1274 end if; 1275 1276 else 1277 Initialization_Warning (T); 1278 return Empty; 1279 end if; 1280 1281 Aggr := Make_Aggregate (Loc, No_List, New_List); 1282 Set_Etype (Aggr, T); 1283 Set_Aggregate_Bounds (Aggr, 1284 Make_Range (Loc, 1285 Low_Bound => New_Copy (Lo), 1286 High_Bound => New_Copy (Hi))); 1287 Set_Parent (Aggr, Parent (Proc)); 1288 1289 Append_To (Component_Associations (Aggr), 1290 Make_Component_Association (Loc, 1291 Choices => 1292 New_List ( 1293 Make_Range (Loc, 1294 Low_Bound => New_Copy (Lo), 1295 High_Bound => New_Copy (Hi))), 1296 Expression => Expr)); 1297 1298 if Static_Array_Aggregate (Aggr) then 1299 return Aggr; 1300 else 1301 Initialization_Warning (T); 1302 return Empty; 1303 end if; 1304 end Build_Equivalent_Array_Aggregate; 1305 1306 --------------------------------------- 1307 -- Build_Equivalent_Record_Aggregate -- 1308 --------------------------------------- 1309 1310 function Build_Equivalent_Record_Aggregate (T : Entity_Id) return Node_Id is 1311 Agg : Node_Id; 1312 Comp : Entity_Id; 1313 Comp_Type : Entity_Id; 1314 1315 -- Start of processing for Build_Equivalent_Record_Aggregate 1316 1317 begin 1318 if not Is_Record_Type (T) 1319 or else Has_Discriminants (T) 1320 or else Is_Limited_Type (T) 1321 or else Has_Non_Standard_Rep (T) 1322 then 1323 Initialization_Warning (T); 1324 return Empty; 1325 end if; 1326 1327 Comp := First_Component (T); 1328 1329 -- A null record needs no warning 1330 1331 if No (Comp) then 1332 return Empty; 1333 end if; 1334 1335 while Present (Comp) loop 1336 1337 -- Array components are acceptable if initialized by a positional 1338 -- aggregate with static components. 1339 1340 if Is_Array_Type (Etype (Comp)) then 1341 Comp_Type := Component_Type (Etype (Comp)); 1342 1343 if Nkind (Parent (Comp)) /= N_Component_Declaration 1344 or else No (Expression (Parent (Comp))) 1345 or else Nkind (Expression (Parent (Comp))) /= N_Aggregate 1346 then 1347 Initialization_Warning (T); 1348 return Empty; 1349 1350 elsif Is_Scalar_Type (Component_Type (Etype (Comp))) 1351 and then 1352 (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) 1353 or else 1354 not Compile_Time_Known_Value (Type_High_Bound (Comp_Type))) 1355 then 1356 Initialization_Warning (T); 1357 return Empty; 1358 1359 elsif 1360 not Static_Array_Aggregate (Expression (Parent (Comp))) 1361 then 1362 Initialization_Warning (T); 1363 return Empty; 1364 end if; 1365 1366 elsif Is_Scalar_Type (Etype (Comp)) then 1367 Comp_Type := Etype (Comp); 1368 1369 if Nkind (Parent (Comp)) /= N_Component_Declaration 1370 or else No (Expression (Parent (Comp))) 1371 or else not Compile_Time_Known_Value (Expression (Parent (Comp))) 1372 or else not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type)) 1373 or else not 1374 Compile_Time_Known_Value (Type_High_Bound (Comp_Type)) 1375 then 1376 Initialization_Warning (T); 1377 return Empty; 1378 end if; 1379 1380 -- For now, other types are excluded 1381 1382 else 1383 Initialization_Warning (T); 1384 return Empty; 1385 end if; 1386 1387 Next_Component (Comp); 1388 end loop; 1389 1390 -- All components have static initialization. Build positional aggregate 1391 -- from the given expressions or defaults. 1392 1393 Agg := Make_Aggregate (Sloc (T), New_List, New_List); 1394 Set_Parent (Agg, Parent (T)); 1395 1396 Comp := First_Component (T); 1397 while Present (Comp) loop 1398 Append 1399 (New_Copy_Tree (Expression (Parent (Comp))), Expressions (Agg)); 1400 Next_Component (Comp); 1401 end loop; 1402 1403 Analyze_And_Resolve (Agg, T); 1404 return Agg; 1405 end Build_Equivalent_Record_Aggregate; 1406 1407 ------------------------------- 1408 -- Build_Initialization_Call -- 1409 ------------------------------- 1410 1411 -- References to a discriminant inside the record type declaration can 1412 -- appear either in the subtype_indication to constrain a record or an 1413 -- array, or as part of a larger expression given for the initial value 1414 -- of a component. In both of these cases N appears in the record 1415 -- initialization procedure and needs to be replaced by the formal 1416 -- parameter of the initialization procedure which corresponds to that 1417 -- discriminant. 1418 1419 -- In the example below, references to discriminants D1 and D2 in proc_1 1420 -- are replaced by references to formals with the same name 1421 -- (discriminals) 1422 1423 -- A similar replacement is done for calls to any record initialization 1424 -- procedure for any components that are themselves of a record type. 1425 1426 -- type R (D1, D2 : Integer) is record 1427 -- X : Integer := F * D1; 1428 -- Y : Integer := F * D2; 1429 -- end record; 1430 1431 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is 1432 -- begin 1433 -- Out_2.D1 := D1; 1434 -- Out_2.D2 := D2; 1435 -- Out_2.X := F * D1; 1436 -- Out_2.Y := F * D2; 1437 -- end; 1438 1439 function Build_Initialization_Call 1440 (Loc : Source_Ptr; 1441 Id_Ref : Node_Id; 1442 Typ : Entity_Id; 1443 In_Init_Proc : Boolean := False; 1444 Enclos_Type : Entity_Id := Empty; 1445 Discr_Map : Elist_Id := New_Elmt_List; 1446 With_Default_Init : Boolean := False; 1447 Constructor_Ref : Node_Id := Empty) return List_Id 1448 is 1449 Res : constant List_Id := New_List; 1450 Arg : Node_Id; 1451 Args : List_Id; 1452 Decls : List_Id; 1453 Decl : Node_Id; 1454 Discr : Entity_Id; 1455 First_Arg : Node_Id; 1456 Full_Init_Type : Entity_Id; 1457 Full_Type : Entity_Id; 1458 Init_Type : Entity_Id; 1459 Proc : Entity_Id; 1460 1461 begin 1462 pragma Assert (Constructor_Ref = Empty 1463 or else Is_CPP_Constructor_Call (Constructor_Ref)); 1464 1465 if No (Constructor_Ref) then 1466 Proc := Base_Init_Proc (Typ); 1467 else 1468 Proc := Base_Init_Proc (Typ, Entity (Name (Constructor_Ref))); 1469 end if; 1470 1471 pragma Assert (Present (Proc)); 1472 Init_Type := Etype (First_Formal (Proc)); 1473 Full_Init_Type := Underlying_Type (Init_Type); 1474 1475 -- Nothing to do if the Init_Proc is null, unless Initialize_Scalars 1476 -- is active (in which case we make the call anyway, since in the 1477 -- actual compiled client it may be non null). 1478 1479 if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then 1480 return Empty_List; 1481 end if; 1482 1483 -- Use the [underlying] full view when dealing with a private type. This 1484 -- may require several steps depending on derivations. 1485 1486 Full_Type := Typ; 1487 loop 1488 if Is_Private_Type (Full_Type) then 1489 if Present (Full_View (Full_Type)) then 1490 Full_Type := Full_View (Full_Type); 1491 1492 elsif Present (Underlying_Full_View (Full_Type)) then 1493 Full_Type := Underlying_Full_View (Full_Type); 1494 1495 -- When a private type acts as a generic actual and lacks a full 1496 -- view, use the base type. 1497 1498 elsif Is_Generic_Actual_Type (Full_Type) then 1499 Full_Type := Base_Type (Full_Type); 1500 1501 -- The loop has recovered the [underlying] full view, stop the 1502 -- traversal. 1503 1504 else 1505 exit; 1506 end if; 1507 1508 -- The type is not private, nothing to do 1509 1510 else 1511 exit; 1512 end if; 1513 end loop; 1514 1515 -- If Typ is derived, the procedure is the initialization procedure for 1516 -- the root type. Wrap the argument in an conversion to make it type 1517 -- honest. Actually it isn't quite type honest, because there can be 1518 -- conflicts of views in the private type case. That is why we set 1519 -- Conversion_OK in the conversion node. 1520 1521 if (Is_Record_Type (Typ) 1522 or else Is_Array_Type (Typ) 1523 or else Is_Private_Type (Typ)) 1524 and then Init_Type /= Base_Type (Typ) 1525 then 1526 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); 1527 Set_Etype (First_Arg, Init_Type); 1528 1529 else 1530 First_Arg := Id_Ref; 1531 end if; 1532 1533 Args := New_List (Convert_Concurrent (First_Arg, Typ)); 1534 1535 -- In the tasks case, add _Master as the value of the _Master parameter 1536 -- and _Chain as the value of the _Chain parameter. At the outer level, 1537 -- these will be variables holding the corresponding values obtained 1538 -- from GNARL. At inner levels, they will be the parameters passed down 1539 -- through the outer routines. 1540 1541 if Has_Task (Full_Type) then 1542 if Restriction_Active (No_Task_Hierarchy) then 1543 Append_To (Args, 1544 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 1545 else 1546 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 1547 end if; 1548 1549 -- Add _Chain (not done for sequential elaboration policy, see 1550 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 1551 1552 if Partition_Elaboration_Policy /= 'S' then 1553 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 1554 end if; 1555 1556 -- Ada 2005 (AI-287): In case of default initialized components 1557 -- with tasks, we generate a null string actual parameter. 1558 -- This is just a workaround that must be improved later??? 1559 1560 if With_Default_Init then 1561 Append_To (Args, 1562 Make_String_Literal (Loc, 1563 Strval => "")); 1564 1565 else 1566 Decls := 1567 Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc); 1568 Decl := Last (Decls); 1569 1570 Append_To (Args, 1571 New_Occurrence_Of (Defining_Identifier (Decl), Loc)); 1572 Append_List (Decls, Res); 1573 end if; 1574 1575 else 1576 Decls := No_List; 1577 Decl := Empty; 1578 end if; 1579 1580 -- Add discriminant values if discriminants are present 1581 1582 if Has_Discriminants (Full_Init_Type) then 1583 Discr := First_Discriminant (Full_Init_Type); 1584 while Present (Discr) loop 1585 1586 -- If this is a discriminated concurrent type, the init_proc 1587 -- for the corresponding record is being called. Use that type 1588 -- directly to find the discriminant value, to handle properly 1589 -- intervening renamed discriminants. 1590 1591 declare 1592 T : Entity_Id := Full_Type; 1593 1594 begin 1595 if Is_Protected_Type (T) then 1596 T := Corresponding_Record_Type (T); 1597 end if; 1598 1599 Arg := 1600 Get_Discriminant_Value ( 1601 Discr, 1602 T, 1603 Discriminant_Constraint (Full_Type)); 1604 end; 1605 1606 -- If the target has access discriminants, and is constrained by 1607 -- an access to the enclosing construct, i.e. a current instance, 1608 -- replace the reference to the type by a reference to the object. 1609 1610 if Nkind (Arg) = N_Attribute_Reference 1611 and then Is_Access_Type (Etype (Arg)) 1612 and then Is_Entity_Name (Prefix (Arg)) 1613 and then Is_Type (Entity (Prefix (Arg))) 1614 then 1615 Arg := 1616 Make_Attribute_Reference (Loc, 1617 Prefix => New_Copy (Prefix (Id_Ref)), 1618 Attribute_Name => Name_Unrestricted_Access); 1619 1620 elsif In_Init_Proc then 1621 1622 -- Replace any possible references to the discriminant in the 1623 -- call to the record initialization procedure with references 1624 -- to the appropriate formal parameter. 1625 1626 if Nkind (Arg) = N_Identifier 1627 and then Ekind (Entity (Arg)) = E_Discriminant 1628 then 1629 Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc); 1630 1631 -- Otherwise make a copy of the default expression. Note that 1632 -- we use the current Sloc for this, because we do not want the 1633 -- call to appear to be at the declaration point. Within the 1634 -- expression, replace discriminants with their discriminals. 1635 1636 else 1637 Arg := 1638 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); 1639 end if; 1640 1641 else 1642 if Is_Constrained (Full_Type) then 1643 Arg := Duplicate_Subexpr_No_Checks (Arg); 1644 else 1645 -- The constraints come from the discriminant default exps, 1646 -- they must be reevaluated, so we use New_Copy_Tree but we 1647 -- ensure the proper Sloc (for any embedded calls). 1648 1649 Arg := New_Copy_Tree (Arg, New_Sloc => Loc); 1650 end if; 1651 end if; 1652 1653 -- Ada 2005 (AI-287): In case of default initialized components, 1654 -- if the component is constrained with a discriminant of the 1655 -- enclosing type, we need to generate the corresponding selected 1656 -- component node to access the discriminant value. In other cases 1657 -- this is not required, either because we are inside the init 1658 -- proc and we use the corresponding formal, or else because the 1659 -- component is constrained by an expression. 1660 1661 if With_Default_Init 1662 and then Nkind (Id_Ref) = N_Selected_Component 1663 and then Nkind (Arg) = N_Identifier 1664 and then Ekind (Entity (Arg)) = E_Discriminant 1665 then 1666 Append_To (Args, 1667 Make_Selected_Component (Loc, 1668 Prefix => New_Copy_Tree (Prefix (Id_Ref)), 1669 Selector_Name => Arg)); 1670 else 1671 Append_To (Args, Arg); 1672 end if; 1673 1674 Next_Discriminant (Discr); 1675 end loop; 1676 end if; 1677 1678 -- If this is a call to initialize the parent component of a derived 1679 -- tagged type, indicate that the tag should not be set in the parent. 1680 1681 if Is_Tagged_Type (Full_Init_Type) 1682 and then not Is_CPP_Class (Full_Init_Type) 1683 and then Nkind (Id_Ref) = N_Selected_Component 1684 and then Chars (Selector_Name (Id_Ref)) = Name_uParent 1685 then 1686 Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); 1687 1688 elsif Present (Constructor_Ref) then 1689 Append_List_To (Args, 1690 New_Copy_List (Parameter_Associations (Constructor_Ref))); 1691 end if; 1692 1693 Append_To (Res, 1694 Make_Procedure_Call_Statement (Loc, 1695 Name => New_Occurrence_Of (Proc, Loc), 1696 Parameter_Associations => Args)); 1697 1698 if Needs_Finalization (Typ) 1699 and then Nkind (Id_Ref) = N_Selected_Component 1700 then 1701 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then 1702 Append_To (Res, 1703 Make_Init_Call 1704 (Obj_Ref => New_Copy_Tree (First_Arg), 1705 Typ => Typ)); 1706 end if; 1707 end if; 1708 1709 return Res; 1710 1711 exception 1712 when RE_Not_Available => 1713 return Empty_List; 1714 end Build_Initialization_Call; 1715 1716 ---------------------------- 1717 -- Build_Record_Init_Proc -- 1718 ---------------------------- 1719 1720 procedure Build_Record_Init_Proc (N : Node_Id; Rec_Ent : Entity_Id) is 1721 Decls : constant List_Id := New_List; 1722 Discr_Map : constant Elist_Id := New_Elmt_List; 1723 Loc : constant Source_Ptr := Sloc (Rec_Ent); 1724 Counter : Int := 0; 1725 Proc_Id : Entity_Id; 1726 Rec_Type : Entity_Id; 1727 Set_Tag : Entity_Id := Empty; 1728 1729 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; 1730 -- Build an assignment statement which assigns the default expression 1731 -- to its corresponding record component if defined. The left hand side 1732 -- of the assignment is marked Assignment_OK so that initialization of 1733 -- limited private records works correctly. This routine may also build 1734 -- an adjustment call if the component is controlled. 1735 1736 procedure Build_Discriminant_Assignments (Statement_List : List_Id); 1737 -- If the record has discriminants, add assignment statements to 1738 -- Statement_List to initialize the discriminant values from the 1739 -- arguments of the initialization procedure. 1740 1741 function Build_Init_Statements (Comp_List : Node_Id) return List_Id; 1742 -- Build a list representing a sequence of statements which initialize 1743 -- components of the given component list. This may involve building 1744 -- case statements for the variant parts. Append any locally declared 1745 -- objects on list Decls. 1746 1747 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; 1748 -- Given an untagged type-derivation that declares discriminants, e.g. 1749 -- 1750 -- type R (R1, R2 : Integer) is record ... end record; 1751 -- type D (D1 : Integer) is new R (1, D1); 1752 -- 1753 -- we make the _init_proc of D be 1754 -- 1755 -- procedure _init_proc (X : D; D1 : Integer) is 1756 -- begin 1757 -- _init_proc (R (X), 1, D1); 1758 -- end _init_proc; 1759 -- 1760 -- This function builds the call statement in this _init_proc. 1761 1762 procedure Build_CPP_Init_Procedure; 1763 -- Build the tree corresponding to the procedure specification and body 1764 -- of the IC procedure that initializes the C++ part of the dispatch 1765 -- table of an Ada tagged type that is a derivation of a CPP type. 1766 -- Install it as the CPP_Init TSS. 1767 1768 procedure Build_Init_Procedure; 1769 -- Build the tree corresponding to the procedure specification and body 1770 -- of the initialization procedure and install it as the _init TSS. 1771 1772 procedure Build_Offset_To_Top_Functions; 1773 -- Ada 2005 (AI-251): Build the tree corresponding to the procedure spec 1774 -- and body of Offset_To_Top, a function used in conjuction with types 1775 -- having secondary dispatch tables. 1776 1777 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); 1778 -- Add range checks to components of discriminated records. S is a 1779 -- subtype indication of a record component. Check_List is a list 1780 -- to which the check actions are appended. 1781 1782 function Component_Needs_Simple_Initialization 1783 (T : Entity_Id) return Boolean; 1784 -- Determine if a component needs simple initialization, given its type 1785 -- T. This routine is the same as Needs_Simple_Initialization except for 1786 -- components of type Tag and Interface_Tag. These two access types do 1787 -- not require initialization since they are explicitly initialized by 1788 -- other means. 1789 1790 function Parent_Subtype_Renaming_Discrims return Boolean; 1791 -- Returns True for base types N that rename discriminants, else False 1792 1793 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; 1794 -- Determine whether a record initialization procedure needs to be 1795 -- generated for the given record type. 1796 1797 ---------------------- 1798 -- Build_Assignment -- 1799 ---------------------- 1800 1801 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is 1802 N_Loc : constant Source_Ptr := Sloc (N); 1803 Typ : constant Entity_Id := Underlying_Type (Etype (Id)); 1804 Exp : Node_Id := N; 1805 Kind : Node_Kind := Nkind (N); 1806 Lhs : Node_Id; 1807 Res : List_Id; 1808 1809 begin 1810 Lhs := 1811 Make_Selected_Component (N_Loc, 1812 Prefix => Make_Identifier (Loc, Name_uInit), 1813 Selector_Name => New_Occurrence_Of (Id, N_Loc)); 1814 Set_Assignment_OK (Lhs); 1815 1816 -- Case of an access attribute applied to the current instance. 1817 -- Replace the reference to the type by a reference to the actual 1818 -- object. (Note that this handles the case of the top level of 1819 -- the expression being given by such an attribute, but does not 1820 -- cover uses nested within an initial value expression. Nested 1821 -- uses are unlikely to occur in practice, but are theoretically 1822 -- possible.) It is not clear how to handle them without fully 1823 -- traversing the expression. ??? 1824 1825 if Kind = N_Attribute_Reference 1826 and then Nam_In (Attribute_Name (N), Name_Unchecked_Access, 1827 Name_Unrestricted_Access) 1828 and then Is_Entity_Name (Prefix (N)) 1829 and then Is_Type (Entity (Prefix (N))) 1830 and then Entity (Prefix (N)) = Rec_Type 1831 then 1832 Exp := 1833 Make_Attribute_Reference (N_Loc, 1834 Prefix => 1835 Make_Identifier (N_Loc, Name_uInit), 1836 Attribute_Name => Name_Unrestricted_Access); 1837 end if; 1838 1839 -- Take a copy of Exp to ensure that later copies of this component 1840 -- declaration in derived types see the original tree, not a node 1841 -- rewritten during expansion of the init_proc. If the copy contains 1842 -- itypes, the scope of the new itypes is the init_proc being built. 1843 1844 Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id); 1845 1846 Res := New_List ( 1847 Make_Assignment_Statement (Loc, 1848 Name => Lhs, 1849 Expression => Exp)); 1850 1851 Set_No_Ctrl_Actions (First (Res)); 1852 1853 -- Adjust the tag if tagged (because of possible view conversions). 1854 -- Suppress the tag adjustment when not Tagged_Type_Expansion because 1855 -- tags are represented implicitly in objects. 1856 1857 if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then 1858 Append_To (Res, 1859 Make_Assignment_Statement (N_Loc, 1860 Name => 1861 Make_Selected_Component (N_Loc, 1862 Prefix => 1863 New_Copy_Tree (Lhs, New_Scope => Proc_Id), 1864 Selector_Name => 1865 New_Occurrence_Of (First_Tag_Component (Typ), N_Loc)), 1866 1867 Expression => 1868 Unchecked_Convert_To (RTE (RE_Tag), 1869 New_Occurrence_Of 1870 (Node 1871 (First_Elmt 1872 (Access_Disp_Table (Underlying_Type (Typ)))), 1873 N_Loc)))); 1874 end if; 1875 1876 -- Adjust the component if controlled except if it is an aggregate 1877 -- that will be expanded inline. 1878 1879 if Kind = N_Qualified_Expression then 1880 Kind := Nkind (Expression (N)); 1881 end if; 1882 1883 if Needs_Finalization (Typ) 1884 and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) 1885 and then not Is_Limited_View (Typ) 1886 then 1887 Append_To (Res, 1888 Make_Adjust_Call 1889 (Obj_Ref => New_Copy_Tree (Lhs), 1890 Typ => Etype (Id))); 1891 end if; 1892 1893 return Res; 1894 1895 exception 1896 when RE_Not_Available => 1897 return Empty_List; 1898 end Build_Assignment; 1899 1900 ------------------------------------ 1901 -- Build_Discriminant_Assignments -- 1902 ------------------------------------ 1903 1904 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is 1905 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); 1906 D : Entity_Id; 1907 D_Loc : Source_Ptr; 1908 1909 begin 1910 if Has_Discriminants (Rec_Type) 1911 and then not Is_Unchecked_Union (Rec_Type) 1912 then 1913 D := First_Discriminant (Rec_Type); 1914 while Present (D) loop 1915 1916 -- Don't generate the assignment for discriminants in derived 1917 -- tagged types if the discriminant is a renaming of some 1918 -- ancestor discriminant. This initialization will be done 1919 -- when initializing the _parent field of the derived record. 1920 1921 if Is_Tagged 1922 and then Present (Corresponding_Discriminant (D)) 1923 then 1924 null; 1925 1926 else 1927 D_Loc := Sloc (D); 1928 Append_List_To (Statement_List, 1929 Build_Assignment (D, 1930 New_Occurrence_Of (Discriminal (D), D_Loc))); 1931 end if; 1932 1933 Next_Discriminant (D); 1934 end loop; 1935 end if; 1936 end Build_Discriminant_Assignments; 1937 1938 -------------------------- 1939 -- Build_Init_Call_Thru -- 1940 -------------------------- 1941 1942 function Build_Init_Call_Thru (Parameters : List_Id) return List_Id is 1943 Parent_Proc : constant Entity_Id := 1944 Base_Init_Proc (Etype (Rec_Type)); 1945 1946 Parent_Type : constant Entity_Id := 1947 Etype (First_Formal (Parent_Proc)); 1948 1949 Uparent_Type : constant Entity_Id := 1950 Underlying_Type (Parent_Type); 1951 1952 First_Discr_Param : Node_Id; 1953 1954 Arg : Node_Id; 1955 Args : List_Id; 1956 First_Arg : Node_Id; 1957 Parent_Discr : Entity_Id; 1958 Res : List_Id; 1959 1960 begin 1961 -- First argument (_Init) is the object to be initialized. 1962 -- ??? not sure where to get a reasonable Loc for First_Arg 1963 1964 First_Arg := 1965 OK_Convert_To (Parent_Type, 1966 New_Occurrence_Of 1967 (Defining_Identifier (First (Parameters)), Loc)); 1968 1969 Set_Etype (First_Arg, Parent_Type); 1970 1971 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); 1972 1973 -- In the tasks case, 1974 -- add _Master as the value of the _Master parameter 1975 -- add _Chain as the value of the _Chain parameter. 1976 -- add _Task_Name as the value of the _Task_Name parameter. 1977 -- At the outer level, these will be variables holding the 1978 -- corresponding values obtained from GNARL or the expander. 1979 -- 1980 -- At inner levels, they will be the parameters passed down through 1981 -- the outer routines. 1982 1983 First_Discr_Param := Next (First (Parameters)); 1984 1985 if Has_Task (Rec_Type) then 1986 if Restriction_Active (No_Task_Hierarchy) then 1987 Append_To (Args, 1988 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 1989 else 1990 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 1991 end if; 1992 1993 -- Add _Chain (not done for sequential elaboration policy, see 1994 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 1995 1996 if Partition_Elaboration_Policy /= 'S' then 1997 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 1998 end if; 1999 2000 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 2001 First_Discr_Param := Next (Next (Next (First_Discr_Param))); 2002 end if; 2003 2004 -- Append discriminant values 2005 2006 if Has_Discriminants (Uparent_Type) then 2007 pragma Assert (not Is_Tagged_Type (Uparent_Type)); 2008 2009 Parent_Discr := First_Discriminant (Uparent_Type); 2010 while Present (Parent_Discr) loop 2011 2012 -- Get the initial value for this discriminant 2013 -- ??? needs to be cleaned up to use parent_Discr_Constr 2014 -- directly. 2015 2016 declare 2017 Discr : Entity_Id := 2018 First_Stored_Discriminant (Uparent_Type); 2019 2020 Discr_Value : Elmt_Id := 2021 First_Elmt (Stored_Constraint (Rec_Type)); 2022 2023 begin 2024 while Original_Record_Component (Parent_Discr) /= Discr loop 2025 Next_Stored_Discriminant (Discr); 2026 Next_Elmt (Discr_Value); 2027 end loop; 2028 2029 Arg := Node (Discr_Value); 2030 end; 2031 2032 -- Append it to the list 2033 2034 if Nkind (Arg) = N_Identifier 2035 and then Ekind (Entity (Arg)) = E_Discriminant 2036 then 2037 Append_To (Args, 2038 New_Occurrence_Of (Discriminal (Entity (Arg)), Loc)); 2039 2040 -- Case of access discriminants. We replace the reference 2041 -- to the type by a reference to the actual object. 2042 2043 -- Is above comment right??? Use of New_Copy below seems mighty 2044 -- suspicious ??? 2045 2046 else 2047 Append_To (Args, New_Copy (Arg)); 2048 end if; 2049 2050 Next_Discriminant (Parent_Discr); 2051 end loop; 2052 end if; 2053 2054 Res := 2055 New_List ( 2056 Make_Procedure_Call_Statement (Loc, 2057 Name => 2058 New_Occurrence_Of (Parent_Proc, Loc), 2059 Parameter_Associations => Args)); 2060 2061 return Res; 2062 end Build_Init_Call_Thru; 2063 2064 ----------------------------------- 2065 -- Build_Offset_To_Top_Functions -- 2066 ----------------------------------- 2067 2068 procedure Build_Offset_To_Top_Functions is 2069 2070 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id); 2071 -- Generate: 2072 -- function Fxx (O : Address) return Storage_Offset is 2073 -- type Acc is access all <Typ>; 2074 -- begin 2075 -- return Acc!(O).Iface_Comp'Position; 2076 -- end Fxx; 2077 2078 ---------------------------------- 2079 -- Build_Offset_To_Top_Function -- 2080 ---------------------------------- 2081 2082 procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id) is 2083 Body_Node : Node_Id; 2084 Func_Id : Entity_Id; 2085 Spec_Node : Node_Id; 2086 Acc_Type : Entity_Id; 2087 2088 begin 2089 Func_Id := Make_Temporary (Loc, 'F'); 2090 Set_DT_Offset_To_Top_Func (Iface_Comp, Func_Id); 2091 2092 -- Generate 2093 -- function Fxx (O : in Rec_Typ) return Storage_Offset; 2094 2095 Spec_Node := New_Node (N_Function_Specification, Loc); 2096 Set_Defining_Unit_Name (Spec_Node, Func_Id); 2097 Set_Parameter_Specifications (Spec_Node, New_List ( 2098 Make_Parameter_Specification (Loc, 2099 Defining_Identifier => 2100 Make_Defining_Identifier (Loc, Name_uO), 2101 In_Present => True, 2102 Parameter_Type => 2103 New_Occurrence_Of (RTE (RE_Address), Loc)))); 2104 Set_Result_Definition (Spec_Node, 2105 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc)); 2106 2107 -- Generate 2108 -- function Fxx (O : in Rec_Typ) return Storage_Offset is 2109 -- begin 2110 -- return O.Iface_Comp'Position; 2111 -- end Fxx; 2112 2113 Body_Node := New_Node (N_Subprogram_Body, Loc); 2114 Set_Specification (Body_Node, Spec_Node); 2115 2116 Acc_Type := Make_Temporary (Loc, 'T'); 2117 Set_Declarations (Body_Node, New_List ( 2118 Make_Full_Type_Declaration (Loc, 2119 Defining_Identifier => Acc_Type, 2120 Type_Definition => 2121 Make_Access_To_Object_Definition (Loc, 2122 All_Present => True, 2123 Null_Exclusion_Present => False, 2124 Constant_Present => False, 2125 Subtype_Indication => 2126 New_Occurrence_Of (Rec_Type, Loc))))); 2127 2128 Set_Handled_Statement_Sequence (Body_Node, 2129 Make_Handled_Sequence_Of_Statements (Loc, 2130 Statements => New_List ( 2131 Make_Simple_Return_Statement (Loc, 2132 Expression => 2133 Make_Attribute_Reference (Loc, 2134 Prefix => 2135 Make_Selected_Component (Loc, 2136 Prefix => 2137 Unchecked_Convert_To (Acc_Type, 2138 Make_Identifier (Loc, Name_uO)), 2139 Selector_Name => 2140 New_Occurrence_Of (Iface_Comp, Loc)), 2141 Attribute_Name => Name_Position))))); 2142 2143 Set_Ekind (Func_Id, E_Function); 2144 Set_Mechanism (Func_Id, Default_Mechanism); 2145 Set_Is_Internal (Func_Id, True); 2146 2147 if not Debug_Generated_Code then 2148 Set_Debug_Info_Off (Func_Id); 2149 end if; 2150 2151 Analyze (Body_Node); 2152 2153 Append_Freeze_Action (Rec_Type, Body_Node); 2154 end Build_Offset_To_Top_Function; 2155 2156 -- Local variables 2157 2158 Iface_Comp : Node_Id; 2159 Iface_Comp_Elmt : Elmt_Id; 2160 Ifaces_Comp_List : Elist_Id; 2161 2162 -- Start of processing for Build_Offset_To_Top_Functions 2163 2164 begin 2165 -- Offset_To_Top_Functions are built only for derivations of types 2166 -- with discriminants that cover interface types. 2167 -- Nothing is needed either in case of virtual targets, since 2168 -- interfaces are handled directly by the target. 2169 2170 if not Is_Tagged_Type (Rec_Type) 2171 or else Etype (Rec_Type) = Rec_Type 2172 or else not Has_Discriminants (Etype (Rec_Type)) 2173 or else not Tagged_Type_Expansion 2174 then 2175 return; 2176 end if; 2177 2178 Collect_Interface_Components (Rec_Type, Ifaces_Comp_List); 2179 2180 -- For each interface type with secondary dispatch table we generate 2181 -- the Offset_To_Top_Functions (required to displace the pointer in 2182 -- interface conversions) 2183 2184 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); 2185 while Present (Iface_Comp_Elmt) loop 2186 Iface_Comp := Node (Iface_Comp_Elmt); 2187 pragma Assert (Is_Interface (Related_Type (Iface_Comp))); 2188 2189 -- If the interface is a parent of Rec_Type it shares the primary 2190 -- dispatch table and hence there is no need to build the function 2191 2192 if not Is_Ancestor (Related_Type (Iface_Comp), Rec_Type, 2193 Use_Full_View => True) 2194 then 2195 Build_Offset_To_Top_Function (Iface_Comp); 2196 end if; 2197 2198 Next_Elmt (Iface_Comp_Elmt); 2199 end loop; 2200 end Build_Offset_To_Top_Functions; 2201 2202 ------------------------------ 2203 -- Build_CPP_Init_Procedure -- 2204 ------------------------------ 2205 2206 procedure Build_CPP_Init_Procedure is 2207 Body_Node : Node_Id; 2208 Body_Stmts : List_Id; 2209 Flag_Id : Entity_Id; 2210 Handled_Stmt_Node : Node_Id; 2211 Init_Tags_List : List_Id; 2212 Proc_Id : Entity_Id; 2213 Proc_Spec_Node : Node_Id; 2214 2215 begin 2216 -- Check cases requiring no IC routine 2217 2218 if not Is_CPP_Class (Root_Type (Rec_Type)) 2219 or else Is_CPP_Class (Rec_Type) 2220 or else CPP_Num_Prims (Rec_Type) = 0 2221 or else not Tagged_Type_Expansion 2222 or else No_Run_Time_Mode 2223 then 2224 return; 2225 end if; 2226 2227 -- Generate: 2228 2229 -- Flag : Boolean := False; 2230 -- 2231 -- procedure Typ_IC is 2232 -- begin 2233 -- if not Flag then 2234 -- Copy C++ dispatch table slots from parent 2235 -- Update C++ slots of overridden primitives 2236 -- end if; 2237 -- end; 2238 2239 Flag_Id := Make_Temporary (Loc, 'F'); 2240 2241 Append_Freeze_Action (Rec_Type, 2242 Make_Object_Declaration (Loc, 2243 Defining_Identifier => Flag_Id, 2244 Object_Definition => 2245 New_Occurrence_Of (Standard_Boolean, Loc), 2246 Expression => 2247 New_Occurrence_Of (Standard_True, Loc))); 2248 2249 Body_Stmts := New_List; 2250 Body_Node := New_Node (N_Subprogram_Body, Loc); 2251 2252 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); 2253 2254 Proc_Id := 2255 Make_Defining_Identifier (Loc, 2256 Chars => Make_TSS_Name (Rec_Type, TSS_CPP_Init_Proc)); 2257 2258 Set_Ekind (Proc_Id, E_Procedure); 2259 Set_Is_Internal (Proc_Id); 2260 2261 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); 2262 2263 Set_Parameter_Specifications (Proc_Spec_Node, New_List); 2264 Set_Specification (Body_Node, Proc_Spec_Node); 2265 Set_Declarations (Body_Node, New_List); 2266 2267 Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type); 2268 2269 Append_To (Init_Tags_List, 2270 Make_Assignment_Statement (Loc, 2271 Name => 2272 New_Occurrence_Of (Flag_Id, Loc), 2273 Expression => 2274 New_Occurrence_Of (Standard_False, Loc))); 2275 2276 Append_To (Body_Stmts, 2277 Make_If_Statement (Loc, 2278 Condition => New_Occurrence_Of (Flag_Id, Loc), 2279 Then_Statements => Init_Tags_List)); 2280 2281 Handled_Stmt_Node := 2282 New_Node (N_Handled_Sequence_Of_Statements, Loc); 2283 Set_Statements (Handled_Stmt_Node, Body_Stmts); 2284 Set_Exception_Handlers (Handled_Stmt_Node, No_List); 2285 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); 2286 2287 if not Debug_Generated_Code then 2288 Set_Debug_Info_Off (Proc_Id); 2289 end if; 2290 2291 -- Associate CPP_Init_Proc with type 2292 2293 Set_Init_Proc (Rec_Type, Proc_Id); 2294 end Build_CPP_Init_Procedure; 2295 2296 -------------------------- 2297 -- Build_Init_Procedure -- 2298 -------------------------- 2299 2300 procedure Build_Init_Procedure is 2301 Body_Stmts : List_Id; 2302 Body_Node : Node_Id; 2303 Handled_Stmt_Node : Node_Id; 2304 Init_Tags_List : List_Id; 2305 Parameters : List_Id; 2306 Proc_Spec_Node : Node_Id; 2307 Record_Extension_Node : Node_Id; 2308 2309 begin 2310 Body_Stmts := New_List; 2311 Body_Node := New_Node (N_Subprogram_Body, Loc); 2312 Set_Ekind (Proc_Id, E_Procedure); 2313 2314 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); 2315 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); 2316 2317 Parameters := Init_Formals (Rec_Type); 2318 Append_List_To (Parameters, 2319 Build_Discriminant_Formals (Rec_Type, True)); 2320 2321 -- For tagged types, we add a flag to indicate whether the routine 2322 -- is called to initialize a parent component in the init_proc of 2323 -- a type extension. If the flag is false, we do not set the tag 2324 -- because it has been set already in the extension. 2325 2326 if Is_Tagged_Type (Rec_Type) then 2327 Set_Tag := Make_Temporary (Loc, 'P'); 2328 2329 Append_To (Parameters, 2330 Make_Parameter_Specification (Loc, 2331 Defining_Identifier => Set_Tag, 2332 Parameter_Type => 2333 New_Occurrence_Of (Standard_Boolean, Loc), 2334 Expression => 2335 New_Occurrence_Of (Standard_True, Loc))); 2336 end if; 2337 2338 Set_Parameter_Specifications (Proc_Spec_Node, Parameters); 2339 Set_Specification (Body_Node, Proc_Spec_Node); 2340 Set_Declarations (Body_Node, Decls); 2341 2342 -- N is a Derived_Type_Definition that renames the parameters of the 2343 -- ancestor type. We initialize it by expanding our discriminants and 2344 -- call the ancestor _init_proc with a type-converted object. 2345 2346 if Parent_Subtype_Renaming_Discrims then 2347 Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); 2348 2349 elsif Nkind (Type_Definition (N)) = N_Record_Definition then 2350 Build_Discriminant_Assignments (Body_Stmts); 2351 2352 if not Null_Present (Type_Definition (N)) then 2353 Append_List_To (Body_Stmts, 2354 Build_Init_Statements (Component_List (Type_Definition (N)))); 2355 end if; 2356 2357 -- N is a Derived_Type_Definition with a possible non-empty 2358 -- extension. The initialization of a type extension consists in the 2359 -- initialization of the components in the extension. 2360 2361 else 2362 Build_Discriminant_Assignments (Body_Stmts); 2363 2364 Record_Extension_Node := 2365 Record_Extension_Part (Type_Definition (N)); 2366 2367 if not Null_Present (Record_Extension_Node) then 2368 declare 2369 Stmts : constant List_Id := 2370 Build_Init_Statements ( 2371 Component_List (Record_Extension_Node)); 2372 2373 begin 2374 -- The parent field must be initialized first because the 2375 -- offset of the new discriminants may depend on it. This is 2376 -- not needed if the parent is an interface type because in 2377 -- such case the initialization of the _parent field was not 2378 -- generated. 2379 2380 if not Is_Interface (Etype (Rec_Ent)) then 2381 declare 2382 Parent_IP : constant Name_Id := 2383 Make_Init_Proc_Name (Etype (Rec_Ent)); 2384 Stmt : Node_Id; 2385 IP_Call : Node_Id; 2386 IP_Stmts : List_Id; 2387 2388 begin 2389 -- Look for a call to the parent IP at the beginning 2390 -- of Stmts associated with the record extension 2391 2392 Stmt := First (Stmts); 2393 IP_Call := Empty; 2394 while Present (Stmt) loop 2395 if Nkind (Stmt) = N_Procedure_Call_Statement 2396 and then Chars (Name (Stmt)) = Parent_IP 2397 then 2398 IP_Call := Stmt; 2399 exit; 2400 end if; 2401 2402 Next (Stmt); 2403 end loop; 2404 2405 -- If found then move it to the beginning of the 2406 -- statements of this IP routine 2407 2408 if Present (IP_Call) then 2409 IP_Stmts := New_List; 2410 loop 2411 Stmt := Remove_Head (Stmts); 2412 Append_To (IP_Stmts, Stmt); 2413 exit when Stmt = IP_Call; 2414 end loop; 2415 2416 Prepend_List_To (Body_Stmts, IP_Stmts); 2417 end if; 2418 end; 2419 end if; 2420 2421 Append_List_To (Body_Stmts, Stmts); 2422 end; 2423 end if; 2424 end if; 2425 2426 -- Add here the assignment to instantiate the Tag 2427 2428 -- The assignment corresponds to the code: 2429 2430 -- _Init._Tag := Typ'Tag; 2431 2432 -- Suppress the tag assignment when not Tagged_Type_Expansion because 2433 -- tags are represented implicitly in objects. It is also suppressed 2434 -- in case of CPP_Class types because in this case the tag is 2435 -- initialized in the C++ side. 2436 2437 if Is_Tagged_Type (Rec_Type) 2438 and then Tagged_Type_Expansion 2439 and then not No_Run_Time_Mode 2440 then 2441 -- Case 1: Ada tagged types with no CPP ancestor. Set the tags of 2442 -- the actual object and invoke the IP of the parent (in this 2443 -- order). The tag must be initialized before the call to the IP 2444 -- of the parent and the assignments to other components because 2445 -- the initial value of the components may depend on the tag (eg. 2446 -- through a dispatching operation on an access to the current 2447 -- type). The tag assignment is not done when initializing the 2448 -- parent component of a type extension, because in that case the 2449 -- tag is set in the extension. 2450 2451 if not Is_CPP_Class (Root_Type (Rec_Type)) then 2452 2453 -- Initialize the primary tag component 2454 2455 Init_Tags_List := New_List ( 2456 Make_Assignment_Statement (Loc, 2457 Name => 2458 Make_Selected_Component (Loc, 2459 Prefix => Make_Identifier (Loc, Name_uInit), 2460 Selector_Name => 2461 New_Occurrence_Of 2462 (First_Tag_Component (Rec_Type), Loc)), 2463 Expression => 2464 New_Occurrence_Of 2465 (Node 2466 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); 2467 2468 -- Ada 2005 (AI-251): Initialize the secondary tags components 2469 -- located at fixed positions (tags whose position depends on 2470 -- variable size components are initialized later ---see below) 2471 2472 if Ada_Version >= Ada_2005 2473 and then not Is_Interface (Rec_Type) 2474 and then Has_Interfaces (Rec_Type) 2475 then 2476 Init_Secondary_Tags 2477 (Typ => Rec_Type, 2478 Target => Make_Identifier (Loc, Name_uInit), 2479 Stmts_List => Init_Tags_List, 2480 Fixed_Comps => True, 2481 Variable_Comps => False); 2482 end if; 2483 2484 Prepend_To (Body_Stmts, 2485 Make_If_Statement (Loc, 2486 Condition => New_Occurrence_Of (Set_Tag, Loc), 2487 Then_Statements => Init_Tags_List)); 2488 2489 -- Case 2: CPP type. The imported C++ constructor takes care of 2490 -- tags initialization. No action needed here because the IP 2491 -- is built by Set_CPP_Constructors; in this case the IP is a 2492 -- wrapper that invokes the C++ constructor and copies the C++ 2493 -- tags locally. Done to inherit the C++ slots in Ada derivations 2494 -- (see case 3). 2495 2496 elsif Is_CPP_Class (Rec_Type) then 2497 pragma Assert (False); 2498 null; 2499 2500 -- Case 3: Combined hierarchy containing C++ types and Ada tagged 2501 -- type derivations. Derivations of imported C++ classes add a 2502 -- complication, because we cannot inhibit tag setting in the 2503 -- constructor for the parent. Hence we initialize the tag after 2504 -- the call to the parent IP (that is, in reverse order compared 2505 -- with pure Ada hierarchies ---see comment on case 1). 2506 2507 else 2508 -- Initialize the primary tag 2509 2510 Init_Tags_List := New_List ( 2511 Make_Assignment_Statement (Loc, 2512 Name => 2513 Make_Selected_Component (Loc, 2514 Prefix => Make_Identifier (Loc, Name_uInit), 2515 Selector_Name => 2516 New_Occurrence_Of 2517 (First_Tag_Component (Rec_Type), Loc)), 2518 Expression => 2519 New_Occurrence_Of 2520 (Node 2521 (First_Elmt (Access_Disp_Table (Rec_Type))), Loc))); 2522 2523 -- Ada 2005 (AI-251): Initialize the secondary tags components 2524 -- located at fixed positions (tags whose position depends on 2525 -- variable size components are initialized later ---see below) 2526 2527 if Ada_Version >= Ada_2005 2528 and then not Is_Interface (Rec_Type) 2529 and then Has_Interfaces (Rec_Type) 2530 then 2531 Init_Secondary_Tags 2532 (Typ => Rec_Type, 2533 Target => Make_Identifier (Loc, Name_uInit), 2534 Stmts_List => Init_Tags_List, 2535 Fixed_Comps => True, 2536 Variable_Comps => False); 2537 end if; 2538 2539 -- Initialize the tag component after invocation of parent IP. 2540 2541 -- Generate: 2542 -- parent_IP(_init.parent); // Invokes the C++ constructor 2543 -- [ typIC; ] // Inherit C++ slots from parent 2544 -- init_tags 2545 2546 declare 2547 Ins_Nod : Node_Id; 2548 2549 begin 2550 -- Search for the call to the IP of the parent. We assume 2551 -- that the first init_proc call is for the parent. 2552 2553 Ins_Nod := First (Body_Stmts); 2554 while Present (Next (Ins_Nod)) 2555 and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement 2556 or else not Is_Init_Proc (Name (Ins_Nod))) 2557 loop 2558 Next (Ins_Nod); 2559 end loop; 2560 2561 -- The IC routine copies the inherited slots of the C+ part 2562 -- of the dispatch table from the parent and updates the 2563 -- overridden C++ slots. 2564 2565 if CPP_Num_Prims (Rec_Type) > 0 then 2566 declare 2567 Init_DT : Entity_Id; 2568 New_Nod : Node_Id; 2569 2570 begin 2571 Init_DT := CPP_Init_Proc (Rec_Type); 2572 pragma Assert (Present (Init_DT)); 2573 2574 New_Nod := 2575 Make_Procedure_Call_Statement (Loc, 2576 New_Occurrence_Of (Init_DT, Loc)); 2577 Insert_After (Ins_Nod, New_Nod); 2578 2579 -- Update location of init tag statements 2580 2581 Ins_Nod := New_Nod; 2582 end; 2583 end if; 2584 2585 Insert_List_After (Ins_Nod, Init_Tags_List); 2586 end; 2587 end if; 2588 2589 -- Ada 2005 (AI-251): Initialize the secondary tag components 2590 -- located at variable positions. We delay the generation of this 2591 -- code until here because the value of the attribute 'Position 2592 -- applied to variable size components of the parent type that 2593 -- depend on discriminants is only safely read at runtime after 2594 -- the parent components have been initialized. 2595 2596 if Ada_Version >= Ada_2005 2597 and then not Is_Interface (Rec_Type) 2598 and then Has_Interfaces (Rec_Type) 2599 and then Has_Discriminants (Etype (Rec_Type)) 2600 and then Is_Variable_Size_Record (Etype (Rec_Type)) 2601 then 2602 Init_Tags_List := New_List; 2603 2604 Init_Secondary_Tags 2605 (Typ => Rec_Type, 2606 Target => Make_Identifier (Loc, Name_uInit), 2607 Stmts_List => Init_Tags_List, 2608 Fixed_Comps => False, 2609 Variable_Comps => True); 2610 2611 if Is_Non_Empty_List (Init_Tags_List) then 2612 Append_List_To (Body_Stmts, Init_Tags_List); 2613 end if; 2614 end if; 2615 end if; 2616 2617 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); 2618 Set_Statements (Handled_Stmt_Node, Body_Stmts); 2619 2620 -- Generate: 2621 -- Deep_Finalize (_init, C1, ..., CN); 2622 -- raise; 2623 2624 if Counter > 0 2625 and then Needs_Finalization (Rec_Type) 2626 and then not Is_Abstract_Type (Rec_Type) 2627 and then not Restriction_Active (No_Exception_Propagation) 2628 then 2629 declare 2630 DF_Call : Node_Id; 2631 DF_Id : Entity_Id; 2632 2633 begin 2634 -- Create a local version of Deep_Finalize which has indication 2635 -- of partial initialization state. 2636 2637 DF_Id := Make_Temporary (Loc, 'F'); 2638 2639 Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id)); 2640 2641 DF_Call := 2642 Make_Procedure_Call_Statement (Loc, 2643 Name => New_Occurrence_Of (DF_Id, Loc), 2644 Parameter_Associations => New_List ( 2645 Make_Identifier (Loc, Name_uInit), 2646 New_Occurrence_Of (Standard_False, Loc))); 2647 2648 -- Do not emit warnings related to the elaboration order when a 2649 -- controlled object is declared before the body of Finalize is 2650 -- seen. 2651 2652 Set_No_Elaboration_Check (DF_Call); 2653 2654 Set_Exception_Handlers (Handled_Stmt_Node, New_List ( 2655 Make_Exception_Handler (Loc, 2656 Exception_Choices => New_List ( 2657 Make_Others_Choice (Loc)), 2658 Statements => New_List ( 2659 DF_Call, 2660 Make_Raise_Statement (Loc))))); 2661 end; 2662 else 2663 Set_Exception_Handlers (Handled_Stmt_Node, No_List); 2664 end if; 2665 2666 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); 2667 2668 if not Debug_Generated_Code then 2669 Set_Debug_Info_Off (Proc_Id); 2670 end if; 2671 2672 -- Associate Init_Proc with type, and determine if the procedure 2673 -- is null (happens because of the Initialize_Scalars pragma case, 2674 -- where we have to generate a null procedure in case it is called 2675 -- by a client with Initialize_Scalars set). Such procedures have 2676 -- to be generated, but do not have to be called, so we mark them 2677 -- as null to suppress the call. 2678 2679 Set_Init_Proc (Rec_Type, Proc_Id); 2680 2681 if List_Length (Body_Stmts) = 1 2682 2683 -- We must skip SCIL nodes because they may have been added to this 2684 -- list by Insert_Actions. 2685 2686 and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement 2687 then 2688 Set_Is_Null_Init_Proc (Proc_Id); 2689 end if; 2690 end Build_Init_Procedure; 2691 2692 --------------------------- 2693 -- Build_Init_Statements -- 2694 --------------------------- 2695 2696 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is 2697 Checks : constant List_Id := New_List; 2698 Actions : List_Id := No_List; 2699 Counter_Id : Entity_Id := Empty; 2700 Comp_Loc : Source_Ptr; 2701 Decl : Node_Id; 2702 Has_POC : Boolean; 2703 Id : Entity_Id; 2704 Parent_Stmts : List_Id; 2705 Stmts : List_Id; 2706 Typ : Entity_Id; 2707 2708 procedure Increment_Counter (Loc : Source_Ptr); 2709 -- Generate an "increment by one" statement for the current counter 2710 -- and append it to the list Stmts. 2711 2712 procedure Make_Counter (Loc : Source_Ptr); 2713 -- Create a new counter for the current component list. The routine 2714 -- creates a new defining Id, adds an object declaration and sets 2715 -- the Id generator for the next variant. 2716 2717 ----------------------- 2718 -- Increment_Counter -- 2719 ----------------------- 2720 2721 procedure Increment_Counter (Loc : Source_Ptr) is 2722 begin 2723 -- Generate: 2724 -- Counter := Counter + 1; 2725 2726 Append_To (Stmts, 2727 Make_Assignment_Statement (Loc, 2728 Name => New_Occurrence_Of (Counter_Id, Loc), 2729 Expression => 2730 Make_Op_Add (Loc, 2731 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), 2732 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 2733 end Increment_Counter; 2734 2735 ------------------ 2736 -- Make_Counter -- 2737 ------------------ 2738 2739 procedure Make_Counter (Loc : Source_Ptr) is 2740 begin 2741 -- Increment the Id generator 2742 2743 Counter := Counter + 1; 2744 2745 -- Create the entity and declaration 2746 2747 Counter_Id := 2748 Make_Defining_Identifier (Loc, 2749 Chars => New_External_Name ('C', Counter)); 2750 2751 -- Generate: 2752 -- Cnn : Integer := 0; 2753 2754 Append_To (Decls, 2755 Make_Object_Declaration (Loc, 2756 Defining_Identifier => Counter_Id, 2757 Object_Definition => 2758 New_Occurrence_Of (Standard_Integer, Loc), 2759 Expression => 2760 Make_Integer_Literal (Loc, 0))); 2761 end Make_Counter; 2762 2763 -- Start of processing for Build_Init_Statements 2764 2765 begin 2766 if Null_Present (Comp_List) then 2767 return New_List (Make_Null_Statement (Loc)); 2768 end if; 2769 2770 Parent_Stmts := New_List; 2771 Stmts := New_List; 2772 2773 -- Loop through visible declarations of task types and protected 2774 -- types moving any expanded code from the spec to the body of the 2775 -- init procedure. 2776 2777 if Is_Task_Record_Type (Rec_Type) 2778 or else Is_Protected_Record_Type (Rec_Type) 2779 then 2780 declare 2781 Decl : constant Node_Id := 2782 Parent (Corresponding_Concurrent_Type (Rec_Type)); 2783 Def : Node_Id; 2784 N1 : Node_Id; 2785 N2 : Node_Id; 2786 2787 begin 2788 if Is_Task_Record_Type (Rec_Type) then 2789 Def := Task_Definition (Decl); 2790 else 2791 Def := Protected_Definition (Decl); 2792 end if; 2793 2794 if Present (Def) then 2795 N1 := First (Visible_Declarations (Def)); 2796 while Present (N1) loop 2797 N2 := N1; 2798 N1 := Next (N1); 2799 2800 if Nkind (N2) in N_Statement_Other_Than_Procedure_Call 2801 or else Nkind (N2) in N_Raise_xxx_Error 2802 or else Nkind (N2) = N_Procedure_Call_Statement 2803 then 2804 Append_To (Stmts, 2805 New_Copy_Tree (N2, New_Scope => Proc_Id)); 2806 Rewrite (N2, Make_Null_Statement (Sloc (N2))); 2807 Analyze (N2); 2808 end if; 2809 end loop; 2810 end if; 2811 end; 2812 end if; 2813 2814 -- Loop through components, skipping pragmas, in 2 steps. The first 2815 -- step deals with regular components. The second step deals with 2816 -- components that have per object constraints and no explicit 2817 -- initialization. 2818 2819 Has_POC := False; 2820 2821 -- First pass : regular components 2822 2823 Decl := First_Non_Pragma (Component_Items (Comp_List)); 2824 while Present (Decl) loop 2825 Comp_Loc := Sloc (Decl); 2826 Build_Record_Checks 2827 (Subtype_Indication (Component_Definition (Decl)), Checks); 2828 2829 Id := Defining_Identifier (Decl); 2830 Typ := Etype (Id); 2831 2832 -- Leave any processing of per-object constrained component for 2833 -- the second pass. 2834 2835 if Has_Access_Constraint (Id) and then No (Expression (Decl)) then 2836 Has_POC := True; 2837 2838 -- Regular component cases 2839 2840 else 2841 -- In the context of the init proc, references to discriminants 2842 -- resolve to denote the discriminals: this is where we can 2843 -- freeze discriminant dependent component subtypes. 2844 2845 if not Is_Frozen (Typ) then 2846 Append_List_To (Stmts, Freeze_Entity (Typ, N)); 2847 end if; 2848 2849 -- Explicit initialization 2850 2851 if Present (Expression (Decl)) then 2852 if Is_CPP_Constructor_Call (Expression (Decl)) then 2853 Actions := 2854 Build_Initialization_Call 2855 (Comp_Loc, 2856 Id_Ref => 2857 Make_Selected_Component (Comp_Loc, 2858 Prefix => 2859 Make_Identifier (Comp_Loc, Name_uInit), 2860 Selector_Name => 2861 New_Occurrence_Of (Id, Comp_Loc)), 2862 Typ => Typ, 2863 In_Init_Proc => True, 2864 Enclos_Type => Rec_Type, 2865 Discr_Map => Discr_Map, 2866 Constructor_Ref => Expression (Decl)); 2867 else 2868 Actions := Build_Assignment (Id, Expression (Decl)); 2869 end if; 2870 2871 -- CPU, Dispatching_Domain, Priority and Size components are 2872 -- filled with the corresponding rep item expression of the 2873 -- concurrent type (if any). 2874 2875 elsif Ekind (Scope (Id)) = E_Record_Type 2876 and then Present (Corresponding_Concurrent_Type (Scope (Id))) 2877 and then Nam_In (Chars (Id), Name_uCPU, 2878 Name_uDispatching_Domain, 2879 Name_uPriority) 2880 then 2881 declare 2882 Exp : Node_Id; 2883 Nam : Name_Id; 2884 Ritem : Node_Id; 2885 2886 begin 2887 if Chars (Id) = Name_uCPU then 2888 Nam := Name_CPU; 2889 2890 elsif Chars (Id) = Name_uDispatching_Domain then 2891 Nam := Name_Dispatching_Domain; 2892 2893 elsif Chars (Id) = Name_uPriority then 2894 Nam := Name_Priority; 2895 end if; 2896 2897 -- Get the Rep Item (aspect specification, attribute 2898 -- definition clause or pragma) of the corresponding 2899 -- concurrent type. 2900 2901 Ritem := 2902 Get_Rep_Item 2903 (Corresponding_Concurrent_Type (Scope (Id)), 2904 Nam, 2905 Check_Parents => False); 2906 2907 if Present (Ritem) then 2908 2909 -- Pragma case 2910 2911 if Nkind (Ritem) = N_Pragma then 2912 Exp := First (Pragma_Argument_Associations (Ritem)); 2913 2914 if Nkind (Exp) = N_Pragma_Argument_Association then 2915 Exp := Expression (Exp); 2916 end if; 2917 2918 -- Conversion for Priority expression 2919 2920 if Nam = Name_Priority then 2921 if Pragma_Name (Ritem) = Name_Priority 2922 and then not GNAT_Mode 2923 then 2924 Exp := Convert_To (RTE (RE_Priority), Exp); 2925 else 2926 Exp := 2927 Convert_To (RTE (RE_Any_Priority), Exp); 2928 end if; 2929 end if; 2930 2931 -- Aspect/Attribute definition clause case 2932 2933 else 2934 Exp := Expression (Ritem); 2935 2936 -- Conversion for Priority expression 2937 2938 if Nam = Name_Priority then 2939 if Chars (Ritem) = Name_Priority 2940 and then not GNAT_Mode 2941 then 2942 Exp := Convert_To (RTE (RE_Priority), Exp); 2943 else 2944 Exp := 2945 Convert_To (RTE (RE_Any_Priority), Exp); 2946 end if; 2947 end if; 2948 end if; 2949 2950 -- Conversion for Dispatching_Domain value 2951 2952 if Nam = Name_Dispatching_Domain then 2953 Exp := 2954 Unchecked_Convert_To 2955 (RTE (RE_Dispatching_Domain_Access), Exp); 2956 end if; 2957 2958 Actions := Build_Assignment (Id, Exp); 2959 2960 -- Nothing needed if no Rep Item 2961 2962 else 2963 Actions := No_List; 2964 end if; 2965 end; 2966 2967 -- Composite component with its own Init_Proc 2968 2969 elsif not Is_Interface (Typ) 2970 and then Has_Non_Null_Base_Init_Proc (Typ) 2971 then 2972 Actions := 2973 Build_Initialization_Call 2974 (Comp_Loc, 2975 Make_Selected_Component (Comp_Loc, 2976 Prefix => 2977 Make_Identifier (Comp_Loc, Name_uInit), 2978 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)), 2979 Typ, 2980 In_Init_Proc => True, 2981 Enclos_Type => Rec_Type, 2982 Discr_Map => Discr_Map); 2983 2984 Clean_Task_Names (Typ, Proc_Id); 2985 2986 -- Simple initialization 2987 2988 elsif Component_Needs_Simple_Initialization (Typ) then 2989 Actions := 2990 Build_Assignment 2991 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id))); 2992 2993 -- Nothing needed for this case 2994 2995 else 2996 Actions := No_List; 2997 end if; 2998 2999 if Present (Checks) then 3000 if Chars (Id) = Name_uParent then 3001 Append_List_To (Parent_Stmts, Checks); 3002 else 3003 Append_List_To (Stmts, Checks); 3004 end if; 3005 end if; 3006 3007 if Present (Actions) then 3008 if Chars (Id) = Name_uParent then 3009 Append_List_To (Parent_Stmts, Actions); 3010 3011 else 3012 Append_List_To (Stmts, Actions); 3013 3014 -- Preserve initialization state in the current counter 3015 3016 if Needs_Finalization (Typ) then 3017 if No (Counter_Id) then 3018 Make_Counter (Comp_Loc); 3019 end if; 3020 3021 Increment_Counter (Comp_Loc); 3022 end if; 3023 end if; 3024 end if; 3025 end if; 3026 3027 Next_Non_Pragma (Decl); 3028 end loop; 3029 3030 -- The parent field must be initialized first because variable 3031 -- size components of the parent affect the location of all the 3032 -- new components. 3033 3034 Prepend_List_To (Stmts, Parent_Stmts); 3035 3036 -- Set up tasks and protected object support. This needs to be done 3037 -- before any component with a per-object access discriminant 3038 -- constraint, or any variant part (which may contain such 3039 -- components) is initialized, because the initialization of these 3040 -- components may reference the enclosing concurrent object. 3041 3042 -- For a task record type, add the task create call and calls to bind 3043 -- any interrupt (signal) entries. 3044 3045 if Is_Task_Record_Type (Rec_Type) then 3046 3047 -- In the case of the restricted run time the ATCB has already 3048 -- been preallocated. 3049 3050 if Restricted_Profile then 3051 Append_To (Stmts, 3052 Make_Assignment_Statement (Loc, 3053 Name => 3054 Make_Selected_Component (Loc, 3055 Prefix => Make_Identifier (Loc, Name_uInit), 3056 Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), 3057 Expression => 3058 Make_Attribute_Reference (Loc, 3059 Prefix => 3060 Make_Selected_Component (Loc, 3061 Prefix => Make_Identifier (Loc, Name_uInit), 3062 Selector_Name => Make_Identifier (Loc, Name_uATCB)), 3063 Attribute_Name => Name_Unchecked_Access))); 3064 end if; 3065 3066 Append_To (Stmts, Make_Task_Create_Call (Rec_Type)); 3067 3068 declare 3069 Task_Type : constant Entity_Id := 3070 Corresponding_Concurrent_Type (Rec_Type); 3071 Task_Decl : constant Node_Id := Parent (Task_Type); 3072 Task_Def : constant Node_Id := Task_Definition (Task_Decl); 3073 Decl_Loc : Source_Ptr; 3074 Ent : Entity_Id; 3075 Vis_Decl : Node_Id; 3076 3077 begin 3078 if Present (Task_Def) then 3079 Vis_Decl := First (Visible_Declarations (Task_Def)); 3080 while Present (Vis_Decl) loop 3081 Decl_Loc := Sloc (Vis_Decl); 3082 3083 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then 3084 if Get_Attribute_Id (Chars (Vis_Decl)) = 3085 Attribute_Address 3086 then 3087 Ent := Entity (Name (Vis_Decl)); 3088 3089 if Ekind (Ent) = E_Entry then 3090 Append_To (Stmts, 3091 Make_Procedure_Call_Statement (Decl_Loc, 3092 Name => 3093 New_Occurrence_Of (RTE ( 3094 RE_Bind_Interrupt_To_Entry), Decl_Loc), 3095 Parameter_Associations => New_List ( 3096 Make_Selected_Component (Decl_Loc, 3097 Prefix => 3098 Make_Identifier (Decl_Loc, Name_uInit), 3099 Selector_Name => 3100 Make_Identifier 3101 (Decl_Loc, Name_uTask_Id)), 3102 Entry_Index_Expression 3103 (Decl_Loc, Ent, Empty, Task_Type), 3104 Expression (Vis_Decl)))); 3105 end if; 3106 end if; 3107 end if; 3108 3109 Next (Vis_Decl); 3110 end loop; 3111 end if; 3112 end; 3113 end if; 3114 3115 -- For a protected type, add statements generated by 3116 -- Make_Initialize_Protection. 3117 3118 if Is_Protected_Record_Type (Rec_Type) then 3119 Append_List_To (Stmts, 3120 Make_Initialize_Protection (Rec_Type)); 3121 end if; 3122 3123 -- Second pass: components with per-object constraints 3124 3125 if Has_POC then 3126 Decl := First_Non_Pragma (Component_Items (Comp_List)); 3127 while Present (Decl) loop 3128 Comp_Loc := Sloc (Decl); 3129 Id := Defining_Identifier (Decl); 3130 Typ := Etype (Id); 3131 3132 if Has_Access_Constraint (Id) 3133 and then No (Expression (Decl)) 3134 then 3135 if Has_Non_Null_Base_Init_Proc (Typ) then 3136 Append_List_To (Stmts, 3137 Build_Initialization_Call (Comp_Loc, 3138 Make_Selected_Component (Comp_Loc, 3139 Prefix => 3140 Make_Identifier (Comp_Loc, Name_uInit), 3141 Selector_Name => New_Occurrence_Of (Id, Comp_Loc)), 3142 Typ, 3143 In_Init_Proc => True, 3144 Enclos_Type => Rec_Type, 3145 Discr_Map => Discr_Map)); 3146 3147 Clean_Task_Names (Typ, Proc_Id); 3148 3149 -- Preserve initialization state in the current counter 3150 3151 if Needs_Finalization (Typ) then 3152 if No (Counter_Id) then 3153 Make_Counter (Comp_Loc); 3154 end if; 3155 3156 Increment_Counter (Comp_Loc); 3157 end if; 3158 3159 elsif Component_Needs_Simple_Initialization (Typ) then 3160 Append_List_To (Stmts, 3161 Build_Assignment 3162 (Id, Get_Simple_Init_Val (Typ, N, Esize (Id)))); 3163 end if; 3164 end if; 3165 3166 Next_Non_Pragma (Decl); 3167 end loop; 3168 end if; 3169 3170 -- Process the variant part 3171 3172 if Present (Variant_Part (Comp_List)) then 3173 declare 3174 Variant_Alts : constant List_Id := New_List; 3175 Var_Loc : Source_Ptr; 3176 Variant : Node_Id; 3177 3178 begin 3179 Variant := 3180 First_Non_Pragma (Variants (Variant_Part (Comp_List))); 3181 while Present (Variant) loop 3182 Var_Loc := Sloc (Variant); 3183 Append_To (Variant_Alts, 3184 Make_Case_Statement_Alternative (Var_Loc, 3185 Discrete_Choices => 3186 New_Copy_List (Discrete_Choices (Variant)), 3187 Statements => 3188 Build_Init_Statements (Component_List (Variant)))); 3189 Next_Non_Pragma (Variant); 3190 end loop; 3191 3192 -- The expression of the case statement which is a reference 3193 -- to one of the discriminants is replaced by the appropriate 3194 -- formal parameter of the initialization procedure. 3195 3196 Append_To (Stmts, 3197 Make_Case_Statement (Var_Loc, 3198 Expression => 3199 New_Occurrence_Of (Discriminal ( 3200 Entity (Name (Variant_Part (Comp_List)))), Var_Loc), 3201 Alternatives => Variant_Alts)); 3202 end; 3203 end if; 3204 3205 -- If no initializations when generated for component declarations 3206 -- corresponding to this Stmts, append a null statement to Stmts to 3207 -- to make it a valid Ada tree. 3208 3209 if Is_Empty_List (Stmts) then 3210 Append (Make_Null_Statement (Loc), Stmts); 3211 end if; 3212 3213 return Stmts; 3214 3215 exception 3216 when RE_Not_Available => 3217 return Empty_List; 3218 end Build_Init_Statements; 3219 3220 ------------------------- 3221 -- Build_Record_Checks -- 3222 ------------------------- 3223 3224 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is 3225 Subtype_Mark_Id : Entity_Id; 3226 3227 procedure Constrain_Array 3228 (SI : Node_Id; 3229 Check_List : List_Id); 3230 -- Apply a list of index constraints to an unconstrained array type. 3231 -- The first parameter is the entity for the resulting subtype. 3232 -- Check_List is a list to which the check actions are appended. 3233 3234 --------------------- 3235 -- Constrain_Array -- 3236 --------------------- 3237 3238 procedure Constrain_Array 3239 (SI : Node_Id; 3240 Check_List : List_Id) 3241 is 3242 C : constant Node_Id := Constraint (SI); 3243 Number_Of_Constraints : Nat := 0; 3244 Index : Node_Id; 3245 S, T : Entity_Id; 3246 3247 procedure Constrain_Index 3248 (Index : Node_Id; 3249 S : Node_Id; 3250 Check_List : List_Id); 3251 -- Process an index constraint in a constrained array declaration. 3252 -- The constraint can be either a subtype name or a range with or 3253 -- without an explicit subtype mark. Index is the corresponding 3254 -- index of the unconstrained array. S is the range expression. 3255 -- Check_List is a list to which the check actions are appended. 3256 3257 --------------------- 3258 -- Constrain_Index -- 3259 --------------------- 3260 3261 procedure Constrain_Index 3262 (Index : Node_Id; 3263 S : Node_Id; 3264 Check_List : List_Id) 3265 is 3266 T : constant Entity_Id := Etype (Index); 3267 3268 begin 3269 if Nkind (S) = N_Range then 3270 Process_Range_Expr_In_Decl (S, T, Check_List => Check_List); 3271 end if; 3272 end Constrain_Index; 3273 3274 -- Start of processing for Constrain_Array 3275 3276 begin 3277 T := Entity (Subtype_Mark (SI)); 3278 3279 if Is_Access_Type (T) then 3280 T := Designated_Type (T); 3281 end if; 3282 3283 S := First (Constraints (C)); 3284 while Present (S) loop 3285 Number_Of_Constraints := Number_Of_Constraints + 1; 3286 Next (S); 3287 end loop; 3288 3289 -- In either case, the index constraint must provide a discrete 3290 -- range for each index of the array type and the type of each 3291 -- discrete range must be the same as that of the corresponding 3292 -- index. (RM 3.6.1) 3293 3294 S := First (Constraints (C)); 3295 Index := First_Index (T); 3296 Analyze (Index); 3297 3298 -- Apply constraints to each index type 3299 3300 for J in 1 .. Number_Of_Constraints loop 3301 Constrain_Index (Index, S, Check_List); 3302 Next (Index); 3303 Next (S); 3304 end loop; 3305 end Constrain_Array; 3306 3307 -- Start of processing for Build_Record_Checks 3308 3309 begin 3310 if Nkind (S) = N_Subtype_Indication then 3311 Find_Type (Subtype_Mark (S)); 3312 Subtype_Mark_Id := Entity (Subtype_Mark (S)); 3313 3314 -- Remaining processing depends on type 3315 3316 case Ekind (Subtype_Mark_Id) is 3317 3318 when Array_Kind => 3319 Constrain_Array (S, Check_List); 3320 3321 when others => 3322 null; 3323 end case; 3324 end if; 3325 end Build_Record_Checks; 3326 3327 ------------------------------------------- 3328 -- Component_Needs_Simple_Initialization -- 3329 ------------------------------------------- 3330 3331 function Component_Needs_Simple_Initialization 3332 (T : Entity_Id) return Boolean 3333 is 3334 begin 3335 return 3336 Needs_Simple_Initialization (T) 3337 and then not Is_RTE (T, RE_Tag) 3338 3339 -- Ada 2005 (AI-251): Check also the tag of abstract interfaces 3340 3341 and then not Is_RTE (T, RE_Interface_Tag); 3342 end Component_Needs_Simple_Initialization; 3343 3344 -------------------------------------- 3345 -- Parent_Subtype_Renaming_Discrims -- 3346 -------------------------------------- 3347 3348 function Parent_Subtype_Renaming_Discrims return Boolean is 3349 De : Entity_Id; 3350 Dp : Entity_Id; 3351 3352 begin 3353 if Base_Type (Rec_Ent) /= Rec_Ent then 3354 return False; 3355 end if; 3356 3357 if Etype (Rec_Ent) = Rec_Ent 3358 or else not Has_Discriminants (Rec_Ent) 3359 or else Is_Constrained (Rec_Ent) 3360 or else Is_Tagged_Type (Rec_Ent) 3361 then 3362 return False; 3363 end if; 3364 3365 -- If there are no explicit stored discriminants we have inherited 3366 -- the root type discriminants so far, so no renamings occurred. 3367 3368 if First_Discriminant (Rec_Ent) = 3369 First_Stored_Discriminant (Rec_Ent) 3370 then 3371 return False; 3372 end if; 3373 3374 -- Check if we have done some trivial renaming of the parent 3375 -- discriminants, i.e. something like 3376 -- 3377 -- type DT (X1, X2: int) is new PT (X1, X2); 3378 3379 De := First_Discriminant (Rec_Ent); 3380 Dp := First_Discriminant (Etype (Rec_Ent)); 3381 while Present (De) loop 3382 pragma Assert (Present (Dp)); 3383 3384 if Corresponding_Discriminant (De) /= Dp then 3385 return True; 3386 end if; 3387 3388 Next_Discriminant (De); 3389 Next_Discriminant (Dp); 3390 end loop; 3391 3392 return Present (Dp); 3393 end Parent_Subtype_Renaming_Discrims; 3394 3395 ------------------------ 3396 -- Requires_Init_Proc -- 3397 ------------------------ 3398 3399 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is 3400 Comp_Decl : Node_Id; 3401 Id : Entity_Id; 3402 Typ : Entity_Id; 3403 3404 begin 3405 -- Definitely do not need one if specifically suppressed 3406 3407 if Initialization_Suppressed (Rec_Id) then 3408 return False; 3409 end if; 3410 3411 -- If it is a type derived from a type with unknown discriminants, 3412 -- we cannot build an initialization procedure for it. 3413 3414 if Has_Unknown_Discriminants (Rec_Id) 3415 or else Has_Unknown_Discriminants (Etype (Rec_Id)) 3416 then 3417 return False; 3418 end if; 3419 3420 -- Otherwise we need to generate an initialization procedure if 3421 -- Is_CPP_Class is False and at least one of the following applies: 3422 3423 -- 1. Discriminants are present, since they need to be initialized 3424 -- with the appropriate discriminant constraint expressions. 3425 -- However, the discriminant of an unchecked union does not 3426 -- count, since the discriminant is not present. 3427 3428 -- 2. The type is a tagged type, since the implicit Tag component 3429 -- needs to be initialized with a pointer to the dispatch table. 3430 3431 -- 3. The type contains tasks 3432 3433 -- 4. One or more components has an initial value 3434 3435 -- 5. One or more components is for a type which itself requires 3436 -- an initialization procedure. 3437 3438 -- 6. One or more components is a type that requires simple 3439 -- initialization (see Needs_Simple_Initialization), except 3440 -- that types Tag and Interface_Tag are excluded, since fields 3441 -- of these types are initialized by other means. 3442 3443 -- 7. The type is the record type built for a task type (since at 3444 -- the very least, Create_Task must be called) 3445 3446 -- 8. The type is the record type built for a protected type (since 3447 -- at least Initialize_Protection must be called) 3448 3449 -- 9. The type is marked as a public entity. The reason we add this 3450 -- case (even if none of the above apply) is to properly handle 3451 -- Initialize_Scalars. If a package is compiled without an IS 3452 -- pragma, and the client is compiled with an IS pragma, then 3453 -- the client will think an initialization procedure is present 3454 -- and call it, when in fact no such procedure is required, but 3455 -- since the call is generated, there had better be a routine 3456 -- at the other end of the call, even if it does nothing). 3457 3458 -- Note: the reason we exclude the CPP_Class case is because in this 3459 -- case the initialization is performed by the C++ constructors, and 3460 -- the IP is built by Set_CPP_Constructors. 3461 3462 if Is_CPP_Class (Rec_Id) then 3463 return False; 3464 3465 elsif Is_Interface (Rec_Id) then 3466 return False; 3467 3468 elsif (Has_Discriminants (Rec_Id) 3469 and then not Is_Unchecked_Union (Rec_Id)) 3470 or else Is_Tagged_Type (Rec_Id) 3471 or else Is_Concurrent_Record_Type (Rec_Id) 3472 or else Has_Task (Rec_Id) 3473 then 3474 return True; 3475 end if; 3476 3477 Id := First_Component (Rec_Id); 3478 while Present (Id) loop 3479 Comp_Decl := Parent (Id); 3480 Typ := Etype (Id); 3481 3482 if Present (Expression (Comp_Decl)) 3483 or else Has_Non_Null_Base_Init_Proc (Typ) 3484 or else Component_Needs_Simple_Initialization (Typ) 3485 then 3486 return True; 3487 end if; 3488 3489 Next_Component (Id); 3490 end loop; 3491 3492 -- As explained above, a record initialization procedure is needed 3493 -- for public types in case Initialize_Scalars applies to a client. 3494 -- However, such a procedure is not needed in the case where either 3495 -- of restrictions No_Initialize_Scalars or No_Default_Initialization 3496 -- applies. No_Initialize_Scalars excludes the possibility of using 3497 -- Initialize_Scalars in any partition, and No_Default_Initialization 3498 -- implies that no initialization should ever be done for objects of 3499 -- the type, so is incompatible with Initialize_Scalars. 3500 3501 if not Restriction_Active (No_Initialize_Scalars) 3502 and then not Restriction_Active (No_Default_Initialization) 3503 and then Is_Public (Rec_Id) 3504 then 3505 return True; 3506 end if; 3507 3508 return False; 3509 end Requires_Init_Proc; 3510 3511 -- Start of processing for Build_Record_Init_Proc 3512 3513 begin 3514 Rec_Type := Defining_Identifier (N); 3515 3516 -- This may be full declaration of a private type, in which case 3517 -- the visible entity is a record, and the private entity has been 3518 -- exchanged with it in the private part of the current package. 3519 -- The initialization procedure is built for the record type, which 3520 -- is retrievable from the private entity. 3521 3522 if Is_Incomplete_Or_Private_Type (Rec_Type) then 3523 Rec_Type := Underlying_Type (Rec_Type); 3524 end if; 3525 3526 -- If we have a variant record with restriction No_Implicit_Conditionals 3527 -- in effect, then we skip building the procedure. This is safe because 3528 -- if we can see the restriction, so can any caller, calls to initialize 3529 -- such records are not allowed for variant records if this restriction 3530 -- is active. 3531 3532 if Has_Variant_Part (Rec_Type) 3533 and then Restriction_Active (No_Implicit_Conditionals) 3534 then 3535 return; 3536 end if; 3537 3538 -- If there are discriminants, build the discriminant map to replace 3539 -- discriminants by their discriminals in complex bound expressions. 3540 -- These only arise for the corresponding records of synchronized types. 3541 3542 if Is_Concurrent_Record_Type (Rec_Type) 3543 and then Has_Discriminants (Rec_Type) 3544 then 3545 declare 3546 Disc : Entity_Id; 3547 begin 3548 Disc := First_Discriminant (Rec_Type); 3549 while Present (Disc) loop 3550 Append_Elmt (Disc, Discr_Map); 3551 Append_Elmt (Discriminal (Disc), Discr_Map); 3552 Next_Discriminant (Disc); 3553 end loop; 3554 end; 3555 end if; 3556 3557 -- Derived types that have no type extension can use the initialization 3558 -- procedure of their parent and do not need a procedure of their own. 3559 -- This is only correct if there are no representation clauses for the 3560 -- type or its parent, and if the parent has in fact been frozen so 3561 -- that its initialization procedure exists. 3562 3563 if Is_Derived_Type (Rec_Type) 3564 and then not Is_Tagged_Type (Rec_Type) 3565 and then not Is_Unchecked_Union (Rec_Type) 3566 and then not Has_New_Non_Standard_Rep (Rec_Type) 3567 and then not Parent_Subtype_Renaming_Discrims 3568 and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type)) 3569 then 3570 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); 3571 3572 -- Otherwise if we need an initialization procedure, then build one, 3573 -- mark it as public and inlinable and as having a completion. 3574 3575 elsif Requires_Init_Proc (Rec_Type) 3576 or else Is_Unchecked_Union (Rec_Type) 3577 then 3578 Proc_Id := 3579 Make_Defining_Identifier (Loc, 3580 Chars => Make_Init_Proc_Name (Rec_Type)); 3581 3582 -- If No_Default_Initialization restriction is active, then we don't 3583 -- want to build an init_proc, but we need to mark that an init_proc 3584 -- would be needed if this restriction was not active (so that we can 3585 -- detect attempts to call it), so set a dummy init_proc in place. 3586 3587 if Restriction_Active (No_Default_Initialization) then 3588 Set_Init_Proc (Rec_Type, Proc_Id); 3589 return; 3590 end if; 3591 3592 Build_Offset_To_Top_Functions; 3593 Build_CPP_Init_Procedure; 3594 Build_Init_Procedure; 3595 Set_Is_Public (Proc_Id, Is_Public (Rec_Ent)); 3596 3597 -- The initialization of protected records is not worth inlining. 3598 -- In addition, when compiled for another unit for inlining purposes, 3599 -- it may make reference to entities that have not been elaborated 3600 -- yet. Similar considerations apply to task types. 3601 3602 if not Is_Concurrent_Type (Rec_Type) 3603 and then not Has_Task (Rec_Type) 3604 then 3605 Set_Is_Inlined (Proc_Id); 3606 end if; 3607 3608 Set_Is_Internal (Proc_Id); 3609 Set_Has_Completion (Proc_Id); 3610 3611 if not Debug_Generated_Code then 3612 Set_Debug_Info_Off (Proc_Id); 3613 end if; 3614 3615 -- Do not build an aggregate if Modify_Tree_For_C, this isn't 3616 -- needed and may generate early references to non frozen types 3617 -- since we expand aggregate much more systematically. 3618 3619 if Modify_Tree_For_C then 3620 return; 3621 end if; 3622 3623 declare 3624 Agg : constant Node_Id := 3625 Build_Equivalent_Record_Aggregate (Rec_Type); 3626 3627 procedure Collect_Itypes (Comp : Node_Id); 3628 -- Generate references to itypes in the aggregate, because 3629 -- the first use of the aggregate may be in a nested scope. 3630 3631 -------------------- 3632 -- Collect_Itypes -- 3633 -------------------- 3634 3635 procedure Collect_Itypes (Comp : Node_Id) is 3636 Ref : Node_Id; 3637 Sub_Aggr : Node_Id; 3638 Typ : constant Entity_Id := Etype (Comp); 3639 3640 begin 3641 if Is_Array_Type (Typ) and then Is_Itype (Typ) then 3642 Ref := Make_Itype_Reference (Loc); 3643 Set_Itype (Ref, Typ); 3644 Append_Freeze_Action (Rec_Type, Ref); 3645 3646 Ref := Make_Itype_Reference (Loc); 3647 Set_Itype (Ref, Etype (First_Index (Typ))); 3648 Append_Freeze_Action (Rec_Type, Ref); 3649 3650 -- Recurse on nested arrays 3651 3652 Sub_Aggr := First (Expressions (Comp)); 3653 while Present (Sub_Aggr) loop 3654 Collect_Itypes (Sub_Aggr); 3655 Next (Sub_Aggr); 3656 end loop; 3657 end if; 3658 end Collect_Itypes; 3659 3660 begin 3661 -- If there is a static initialization aggregate for the type, 3662 -- generate itype references for the types of its (sub)components, 3663 -- to prevent out-of-scope errors in the resulting tree. 3664 -- The aggregate may have been rewritten as a Raise node, in which 3665 -- case there are no relevant itypes. 3666 3667 if Present (Agg) and then Nkind (Agg) = N_Aggregate then 3668 Set_Static_Initialization (Proc_Id, Agg); 3669 3670 declare 3671 Comp : Node_Id; 3672 begin 3673 Comp := First (Component_Associations (Agg)); 3674 while Present (Comp) loop 3675 Collect_Itypes (Expression (Comp)); 3676 Next (Comp); 3677 end loop; 3678 end; 3679 end if; 3680 end; 3681 end if; 3682 end Build_Record_Init_Proc; 3683 3684 -------------------------------- 3685 -- Build_Record_Invariant_Proc -- 3686 -------------------------------- 3687 3688 function Build_Record_Invariant_Proc 3689 (R_Type : Entity_Id; 3690 Nod : Node_Id) return Node_Id 3691 is 3692 Loc : constant Source_Ptr := Sloc (Nod); 3693 3694 Object_Name : constant Name_Id := New_Internal_Name ('I'); 3695 -- Name for argument of invariant procedure 3696 3697 Object_Entity : constant Node_Id := 3698 Make_Defining_Identifier (Loc, Object_Name); 3699 -- The procedure declaration entity for the argument 3700 3701 Invariant_Found : Boolean; 3702 -- Set if any component needs an invariant check. 3703 3704 Proc_Id : Entity_Id; 3705 Proc_Body : Node_Id; 3706 Stmts : List_Id; 3707 Type_Def : Node_Id; 3708 3709 function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id; 3710 -- Recursive procedure that generates a list of checks for components 3711 -- that need it, and recurses through variant parts when present. 3712 3713 function Build_Component_Invariant_Call (Comp : Entity_Id) 3714 return Node_Id; 3715 -- Build call to invariant procedure for a record component. 3716 3717 ------------------------------------ 3718 -- Build_Component_Invariant_Call -- 3719 ------------------------------------ 3720 3721 function Build_Component_Invariant_Call (Comp : Entity_Id) 3722 return Node_Id 3723 is 3724 Sel_Comp : Node_Id; 3725 Typ : Entity_Id; 3726 Call : Node_Id; 3727 3728 begin 3729 Invariant_Found := True; 3730 Typ := Etype (Comp); 3731 3732 Sel_Comp := 3733 Make_Selected_Component (Loc, 3734 Prefix => New_Occurrence_Of (Object_Entity, Loc), 3735 Selector_Name => New_Occurrence_Of (Comp, Loc)); 3736 3737 if Is_Access_Type (Typ) then 3738 3739 -- If the access component designates a type with an invariant, 3740 -- the check applies to the designated object. The access type 3741 -- itself may have an invariant, in which case it applies to the 3742 -- access value directly. 3743 3744 -- Note: we are assuming that invariants will not occur on both 3745 -- the access type and the type that it designates. This is not 3746 -- really justified but it is hard to imagine that this case will 3747 -- ever cause trouble ??? 3748 3749 if not (Has_Invariants (Typ)) then 3750 Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp); 3751 Typ := Designated_Type (Typ); 3752 end if; 3753 end if; 3754 3755 -- The aspect is type-specific, so retrieve it from the base type 3756 3757 Call := 3758 Make_Procedure_Call_Statement (Loc, 3759 Name => 3760 New_Occurrence_Of (Invariant_Procedure (Base_Type (Typ)), Loc), 3761 Parameter_Associations => New_List (Sel_Comp)); 3762 3763 if Is_Access_Type (Etype (Comp)) then 3764 Call := 3765 Make_If_Statement (Loc, 3766 Condition => 3767 Make_Op_Ne (Loc, 3768 Left_Opnd => Make_Null (Loc), 3769 Right_Opnd => 3770 Make_Selected_Component (Loc, 3771 Prefix => New_Occurrence_Of (Object_Entity, Loc), 3772 Selector_Name => New_Occurrence_Of (Comp, Loc))), 3773 Then_Statements => New_List (Call)); 3774 end if; 3775 3776 return Call; 3777 end Build_Component_Invariant_Call; 3778 3779 ---------------------------- 3780 -- Build_Invariant_Checks -- 3781 ---------------------------- 3782 3783 function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id is 3784 Decl : Node_Id; 3785 Id : Entity_Id; 3786 Stmts : List_Id; 3787 3788 begin 3789 Stmts := New_List; 3790 Decl := First_Non_Pragma (Component_Items (Comp_List)); 3791 while Present (Decl) loop 3792 if Nkind (Decl) = N_Component_Declaration then 3793 Id := Defining_Identifier (Decl); 3794 3795 if Has_Invariants (Etype (Id)) 3796 and then In_Open_Scopes (Scope (R_Type)) 3797 then 3798 if Has_Unchecked_Union (R_Type) then 3799 Error_Msg_NE 3800 ("invariants cannot be checked on components of " 3801 & "unchecked_union type&?", Decl, R_Type); 3802 return Empty_List; 3803 3804 else 3805 Append_To (Stmts, Build_Component_Invariant_Call (Id)); 3806 end if; 3807 3808 elsif Is_Access_Type (Etype (Id)) 3809 and then not Is_Access_Constant (Etype (Id)) 3810 and then Has_Invariants (Designated_Type (Etype (Id))) 3811 and then In_Open_Scopes (Scope (Designated_Type (Etype (Id)))) 3812 then 3813 Append_To (Stmts, Build_Component_Invariant_Call (Id)); 3814 end if; 3815 end if; 3816 3817 Next (Decl); 3818 end loop; 3819 3820 if Present (Variant_Part (Comp_List)) then 3821 declare 3822 Variant_Alts : constant List_Id := New_List; 3823 Var_Loc : Source_Ptr; 3824 Variant : Node_Id; 3825 Variant_Stmts : List_Id; 3826 3827 begin 3828 Variant := 3829 First_Non_Pragma (Variants (Variant_Part (Comp_List))); 3830 while Present (Variant) loop 3831 Variant_Stmts := 3832 Build_Invariant_Checks (Component_List (Variant)); 3833 Var_Loc := Sloc (Variant); 3834 Append_To (Variant_Alts, 3835 Make_Case_Statement_Alternative (Var_Loc, 3836 Discrete_Choices => 3837 New_Copy_List (Discrete_Choices (Variant)), 3838 Statements => Variant_Stmts)); 3839 3840 Next_Non_Pragma (Variant); 3841 end loop; 3842 3843 -- The expression in the case statement is the reference to 3844 -- the discriminant of the target object. 3845 3846 Append_To (Stmts, 3847 Make_Case_Statement (Var_Loc, 3848 Expression => 3849 Make_Selected_Component (Var_Loc, 3850 Prefix => New_Occurrence_Of (Object_Entity, Var_Loc), 3851 Selector_Name => New_Occurrence_Of 3852 (Entity 3853 (Name (Variant_Part (Comp_List))), Var_Loc)), 3854 Alternatives => Variant_Alts)); 3855 end; 3856 end if; 3857 3858 return Stmts; 3859 end Build_Invariant_Checks; 3860 3861 -- Start of processing for Build_Record_Invariant_Proc 3862 3863 begin 3864 Invariant_Found := False; 3865 Type_Def := Type_Definition (Parent (R_Type)); 3866 3867 if Nkind (Type_Def) = N_Record_Definition 3868 and then not Null_Present (Type_Def) 3869 then 3870 Stmts := Build_Invariant_Checks (Component_List (Type_Def)); 3871 else 3872 return Empty; 3873 end if; 3874 3875 if not Invariant_Found then 3876 return Empty; 3877 end if; 3878 3879 -- The name of the invariant procedure reflects the fact that the 3880 -- checks correspond to invariants on the component types. The 3881 -- record type itself may have invariants that will create a separate 3882 -- procedure whose name carries the Invariant suffix. 3883 3884 Proc_Id := 3885 Make_Defining_Identifier (Loc, 3886 Chars => New_External_Name (Chars (R_Type), "CInvariant")); 3887 3888 Proc_Body := 3889 Make_Subprogram_Body (Loc, 3890 Specification => 3891 Make_Procedure_Specification (Loc, 3892 Defining_Unit_Name => Proc_Id, 3893 Parameter_Specifications => New_List ( 3894 Make_Parameter_Specification (Loc, 3895 Defining_Identifier => Object_Entity, 3896 Parameter_Type => New_Occurrence_Of (R_Type, Loc)))), 3897 3898 Declarations => Empty_List, 3899 Handled_Statement_Sequence => 3900 Make_Handled_Sequence_Of_Statements (Loc, 3901 Statements => Stmts)); 3902 3903 Set_Ekind (Proc_Id, E_Procedure); 3904 Set_Is_Public (Proc_Id, Is_Public (R_Type)); 3905 Set_Is_Internal (Proc_Id); 3906 Set_Has_Completion (Proc_Id); 3907 3908 return Proc_Body; 3909 -- Insert_After (Nod, Proc_Body); 3910 -- Analyze (Proc_Body); 3911 end Build_Record_Invariant_Proc; 3912 3913 ---------------------------- 3914 -- Build_Slice_Assignment -- 3915 ---------------------------- 3916 3917 -- Generates the following subprogram: 3918 3919 -- procedure Assign 3920 -- (Source, Target : Array_Type, 3921 -- Left_Lo, Left_Hi : Index; 3922 -- Right_Lo, Right_Hi : Index; 3923 -- Rev : Boolean) 3924 -- is 3925 -- Li1 : Index; 3926 -- Ri1 : Index; 3927 3928 -- begin 3929 3930 -- if Left_Hi < Left_Lo then 3931 -- return; 3932 -- end if; 3933 3934 -- if Rev then 3935 -- Li1 := Left_Hi; 3936 -- Ri1 := Right_Hi; 3937 -- else 3938 -- Li1 := Left_Lo; 3939 -- Ri1 := Right_Lo; 3940 -- end if; 3941 3942 -- loop 3943 -- Target (Li1) := Source (Ri1); 3944 3945 -- if Rev then 3946 -- exit when Li1 = Left_Lo; 3947 -- Li1 := Index'pred (Li1); 3948 -- Ri1 := Index'pred (Ri1); 3949 -- else 3950 -- exit when Li1 = Left_Hi; 3951 -- Li1 := Index'succ (Li1); 3952 -- Ri1 := Index'succ (Ri1); 3953 -- end if; 3954 -- end loop; 3955 -- end Assign; 3956 3957 procedure Build_Slice_Assignment (Typ : Entity_Id) is 3958 Loc : constant Source_Ptr := Sloc (Typ); 3959 Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); 3960 3961 Larray : constant Entity_Id := Make_Temporary (Loc, 'A'); 3962 Rarray : constant Entity_Id := Make_Temporary (Loc, 'R'); 3963 Left_Lo : constant Entity_Id := Make_Temporary (Loc, 'L'); 3964 Left_Hi : constant Entity_Id := Make_Temporary (Loc, 'L'); 3965 Right_Lo : constant Entity_Id := Make_Temporary (Loc, 'R'); 3966 Right_Hi : constant Entity_Id := Make_Temporary (Loc, 'R'); 3967 Rev : constant Entity_Id := Make_Temporary (Loc, 'D'); 3968 -- Formal parameters of procedure 3969 3970 Proc_Name : constant Entity_Id := 3971 Make_Defining_Identifier (Loc, 3972 Chars => Make_TSS_Name (Typ, TSS_Slice_Assign)); 3973 3974 Lnn : constant Entity_Id := Make_Temporary (Loc, 'L'); 3975 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R'); 3976 -- Subscripts for left and right sides 3977 3978 Decls : List_Id; 3979 Loops : Node_Id; 3980 Stats : List_Id; 3981 3982 begin 3983 -- Build declarations for indexes 3984 3985 Decls := New_List; 3986 3987 Append_To (Decls, 3988 Make_Object_Declaration (Loc, 3989 Defining_Identifier => Lnn, 3990 Object_Definition => 3991 New_Occurrence_Of (Index, Loc))); 3992 3993 Append_To (Decls, 3994 Make_Object_Declaration (Loc, 3995 Defining_Identifier => Rnn, 3996 Object_Definition => 3997 New_Occurrence_Of (Index, Loc))); 3998 3999 Stats := New_List; 4000 4001 -- Build test for empty slice case 4002 4003 Append_To (Stats, 4004 Make_If_Statement (Loc, 4005 Condition => 4006 Make_Op_Lt (Loc, 4007 Left_Opnd => New_Occurrence_Of (Left_Hi, Loc), 4008 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)), 4009 Then_Statements => New_List (Make_Simple_Return_Statement (Loc)))); 4010 4011 -- Build initializations for indexes 4012 4013 declare 4014 F_Init : constant List_Id := New_List; 4015 B_Init : constant List_Id := New_List; 4016 4017 begin 4018 Append_To (F_Init, 4019 Make_Assignment_Statement (Loc, 4020 Name => New_Occurrence_Of (Lnn, Loc), 4021 Expression => New_Occurrence_Of (Left_Lo, Loc))); 4022 4023 Append_To (F_Init, 4024 Make_Assignment_Statement (Loc, 4025 Name => New_Occurrence_Of (Rnn, Loc), 4026 Expression => New_Occurrence_Of (Right_Lo, Loc))); 4027 4028 Append_To (B_Init, 4029 Make_Assignment_Statement (Loc, 4030 Name => New_Occurrence_Of (Lnn, Loc), 4031 Expression => New_Occurrence_Of (Left_Hi, Loc))); 4032 4033 Append_To (B_Init, 4034 Make_Assignment_Statement (Loc, 4035 Name => New_Occurrence_Of (Rnn, Loc), 4036 Expression => New_Occurrence_Of (Right_Hi, Loc))); 4037 4038 Append_To (Stats, 4039 Make_If_Statement (Loc, 4040 Condition => New_Occurrence_Of (Rev, Loc), 4041 Then_Statements => B_Init, 4042 Else_Statements => F_Init)); 4043 end; 4044 4045 -- Now construct the assignment statement 4046 4047 Loops := 4048 Make_Loop_Statement (Loc, 4049 Statements => New_List ( 4050 Make_Assignment_Statement (Loc, 4051 Name => 4052 Make_Indexed_Component (Loc, 4053 Prefix => New_Occurrence_Of (Larray, Loc), 4054 Expressions => New_List (New_Occurrence_Of (Lnn, Loc))), 4055 Expression => 4056 Make_Indexed_Component (Loc, 4057 Prefix => New_Occurrence_Of (Rarray, Loc), 4058 Expressions => New_List (New_Occurrence_Of (Rnn, Loc))))), 4059 End_Label => Empty); 4060 4061 -- Build the exit condition and increment/decrement statements 4062 4063 declare 4064 F_Ass : constant List_Id := New_List; 4065 B_Ass : constant List_Id := New_List; 4066 4067 begin 4068 Append_To (F_Ass, 4069 Make_Exit_Statement (Loc, 4070 Condition => 4071 Make_Op_Eq (Loc, 4072 Left_Opnd => New_Occurrence_Of (Lnn, Loc), 4073 Right_Opnd => New_Occurrence_Of (Left_Hi, Loc)))); 4074 4075 Append_To (F_Ass, 4076 Make_Assignment_Statement (Loc, 4077 Name => New_Occurrence_Of (Lnn, Loc), 4078 Expression => 4079 Make_Attribute_Reference (Loc, 4080 Prefix => 4081 New_Occurrence_Of (Index, Loc), 4082 Attribute_Name => Name_Succ, 4083 Expressions => New_List ( 4084 New_Occurrence_Of (Lnn, Loc))))); 4085 4086 Append_To (F_Ass, 4087 Make_Assignment_Statement (Loc, 4088 Name => New_Occurrence_Of (Rnn, Loc), 4089 Expression => 4090 Make_Attribute_Reference (Loc, 4091 Prefix => 4092 New_Occurrence_Of (Index, Loc), 4093 Attribute_Name => Name_Succ, 4094 Expressions => New_List ( 4095 New_Occurrence_Of (Rnn, Loc))))); 4096 4097 Append_To (B_Ass, 4098 Make_Exit_Statement (Loc, 4099 Condition => 4100 Make_Op_Eq (Loc, 4101 Left_Opnd => New_Occurrence_Of (Lnn, Loc), 4102 Right_Opnd => New_Occurrence_Of (Left_Lo, Loc)))); 4103 4104 Append_To (B_Ass, 4105 Make_Assignment_Statement (Loc, 4106 Name => New_Occurrence_Of (Lnn, Loc), 4107 Expression => 4108 Make_Attribute_Reference (Loc, 4109 Prefix => 4110 New_Occurrence_Of (Index, Loc), 4111 Attribute_Name => Name_Pred, 4112 Expressions => New_List ( 4113 New_Occurrence_Of (Lnn, Loc))))); 4114 4115 Append_To (B_Ass, 4116 Make_Assignment_Statement (Loc, 4117 Name => New_Occurrence_Of (Rnn, Loc), 4118 Expression => 4119 Make_Attribute_Reference (Loc, 4120 Prefix => 4121 New_Occurrence_Of (Index, Loc), 4122 Attribute_Name => Name_Pred, 4123 Expressions => New_List ( 4124 New_Occurrence_Of (Rnn, Loc))))); 4125 4126 Append_To (Statements (Loops), 4127 Make_If_Statement (Loc, 4128 Condition => New_Occurrence_Of (Rev, Loc), 4129 Then_Statements => B_Ass, 4130 Else_Statements => F_Ass)); 4131 end; 4132 4133 Append_To (Stats, Loops); 4134 4135 declare 4136 Spec : Node_Id; 4137 Formals : List_Id := New_List; 4138 4139 begin 4140 Formals := New_List ( 4141 Make_Parameter_Specification (Loc, 4142 Defining_Identifier => Larray, 4143 Out_Present => True, 4144 Parameter_Type => 4145 New_Occurrence_Of (Base_Type (Typ), Loc)), 4146 4147 Make_Parameter_Specification (Loc, 4148 Defining_Identifier => Rarray, 4149 Parameter_Type => 4150 New_Occurrence_Of (Base_Type (Typ), Loc)), 4151 4152 Make_Parameter_Specification (Loc, 4153 Defining_Identifier => Left_Lo, 4154 Parameter_Type => 4155 New_Occurrence_Of (Index, Loc)), 4156 4157 Make_Parameter_Specification (Loc, 4158 Defining_Identifier => Left_Hi, 4159 Parameter_Type => 4160 New_Occurrence_Of (Index, Loc)), 4161 4162 Make_Parameter_Specification (Loc, 4163 Defining_Identifier => Right_Lo, 4164 Parameter_Type => 4165 New_Occurrence_Of (Index, Loc)), 4166 4167 Make_Parameter_Specification (Loc, 4168 Defining_Identifier => Right_Hi, 4169 Parameter_Type => 4170 New_Occurrence_Of (Index, Loc))); 4171 4172 Append_To (Formals, 4173 Make_Parameter_Specification (Loc, 4174 Defining_Identifier => Rev, 4175 Parameter_Type => 4176 New_Occurrence_Of (Standard_Boolean, Loc))); 4177 4178 Spec := 4179 Make_Procedure_Specification (Loc, 4180 Defining_Unit_Name => Proc_Name, 4181 Parameter_Specifications => Formals); 4182 4183 Discard_Node ( 4184 Make_Subprogram_Body (Loc, 4185 Specification => Spec, 4186 Declarations => Decls, 4187 Handled_Statement_Sequence => 4188 Make_Handled_Sequence_Of_Statements (Loc, 4189 Statements => Stats))); 4190 end; 4191 4192 Set_TSS (Typ, Proc_Name); 4193 Set_Is_Pure (Proc_Name); 4194 end Build_Slice_Assignment; 4195 4196 ----------------------------- 4197 -- Build_Untagged_Equality -- 4198 ----------------------------- 4199 4200 procedure Build_Untagged_Equality (Typ : Entity_Id) is 4201 Build_Eq : Boolean; 4202 Comp : Entity_Id; 4203 Decl : Node_Id; 4204 Op : Entity_Id; 4205 Prim : Elmt_Id; 4206 Eq_Op : Entity_Id; 4207 4208 function User_Defined_Eq (T : Entity_Id) return Entity_Id; 4209 -- Check whether the type T has a user-defined primitive equality. If so 4210 -- return it, else return Empty. If true for a component of Typ, we have 4211 -- to build the primitive equality for it. 4212 4213 --------------------- 4214 -- User_Defined_Eq -- 4215 --------------------- 4216 4217 function User_Defined_Eq (T : Entity_Id) return Entity_Id is 4218 Prim : Elmt_Id; 4219 Op : Entity_Id; 4220 4221 begin 4222 Op := TSS (T, TSS_Composite_Equality); 4223 4224 if Present (Op) then 4225 return Op; 4226 end if; 4227 4228 Prim := First_Elmt (Collect_Primitive_Operations (T)); 4229 while Present (Prim) loop 4230 Op := Node (Prim); 4231 4232 if Chars (Op) = Name_Op_Eq 4233 and then Etype (Op) = Standard_Boolean 4234 and then Etype (First_Formal (Op)) = T 4235 and then Etype (Next_Formal (First_Formal (Op))) = T 4236 then 4237 return Op; 4238 end if; 4239 4240 Next_Elmt (Prim); 4241 end loop; 4242 4243 return Empty; 4244 end User_Defined_Eq; 4245 4246 -- Start of processing for Build_Untagged_Equality 4247 4248 begin 4249 -- If a record component has a primitive equality operation, we must 4250 -- build the corresponding one for the current type. 4251 4252 Build_Eq := False; 4253 Comp := First_Component (Typ); 4254 while Present (Comp) loop 4255 if Is_Record_Type (Etype (Comp)) 4256 and then Present (User_Defined_Eq (Etype (Comp))) 4257 then 4258 Build_Eq := True; 4259 end if; 4260 4261 Next_Component (Comp); 4262 end loop; 4263 4264 -- If there is a user-defined equality for the type, we do not create 4265 -- the implicit one. 4266 4267 Prim := First_Elmt (Collect_Primitive_Operations (Typ)); 4268 Eq_Op := Empty; 4269 while Present (Prim) loop 4270 if Chars (Node (Prim)) = Name_Op_Eq 4271 and then Comes_From_Source (Node (Prim)) 4272 4273 -- Don't we also need to check formal types and return type as in 4274 -- User_Defined_Eq above??? 4275 4276 then 4277 Eq_Op := Node (Prim); 4278 Build_Eq := False; 4279 exit; 4280 end if; 4281 4282 Next_Elmt (Prim); 4283 end loop; 4284 4285 -- If the type is derived, inherit the operation, if present, from the 4286 -- parent type. It may have been declared after the type derivation. If 4287 -- the parent type itself is derived, it may have inherited an operation 4288 -- that has itself been overridden, so update its alias and related 4289 -- flags. Ditto for inequality. 4290 4291 if No (Eq_Op) and then Is_Derived_Type (Typ) then 4292 Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ))); 4293 while Present (Prim) loop 4294 if Chars (Node (Prim)) = Name_Op_Eq then 4295 Copy_TSS (Node (Prim), Typ); 4296 Build_Eq := False; 4297 4298 declare 4299 Op : constant Entity_Id := User_Defined_Eq (Typ); 4300 Eq_Op : constant Entity_Id := Node (Prim); 4301 NE_Op : constant Entity_Id := Next_Entity (Eq_Op); 4302 4303 begin 4304 if Present (Op) then 4305 Set_Alias (Op, Eq_Op); 4306 Set_Is_Abstract_Subprogram 4307 (Op, Is_Abstract_Subprogram (Eq_Op)); 4308 4309 if Chars (Next_Entity (Op)) = Name_Op_Ne then 4310 Set_Is_Abstract_Subprogram 4311 (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op)); 4312 end if; 4313 end if; 4314 end; 4315 4316 exit; 4317 end if; 4318 4319 Next_Elmt (Prim); 4320 end loop; 4321 end if; 4322 4323 -- If not inherited and not user-defined, build body as for a type with 4324 -- tagged components. 4325 4326 if Build_Eq then 4327 Decl := 4328 Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality)); 4329 Op := Defining_Entity (Decl); 4330 Set_TSS (Typ, Op); 4331 Set_Is_Pure (Op); 4332 4333 if Is_Library_Level_Entity (Typ) then 4334 Set_Is_Public (Op); 4335 end if; 4336 end if; 4337 end Build_Untagged_Equality; 4338 4339 ----------------------------------- 4340 -- Build_Variant_Record_Equality -- 4341 ----------------------------------- 4342 4343 -- Generates: 4344 4345 -- function _Equality (X, Y : T) return Boolean is 4346 -- begin 4347 -- -- Compare discriminants 4348 4349 -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then 4350 -- return False; 4351 -- end if; 4352 4353 -- -- Compare components 4354 4355 -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then 4356 -- return False; 4357 -- end if; 4358 4359 -- -- Compare variant part 4360 4361 -- case X.D1 is 4362 -- when V1 => 4363 -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then 4364 -- return False; 4365 -- end if; 4366 -- ... 4367 -- when Vn => 4368 -- if X.Cn /= Y.Cn or else ... then 4369 -- return False; 4370 -- end if; 4371 -- end case; 4372 4373 -- return True; 4374 -- end _Equality; 4375 4376 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is 4377 Loc : constant Source_Ptr := Sloc (Typ); 4378 4379 F : constant Entity_Id := 4380 Make_Defining_Identifier (Loc, 4381 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); 4382 4383 X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X); 4384 Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y); 4385 4386 Def : constant Node_Id := Parent (Typ); 4387 Comps : constant Node_Id := Component_List (Type_Definition (Def)); 4388 Stmts : constant List_Id := New_List; 4389 Pspecs : constant List_Id := New_List; 4390 4391 begin 4392 -- If we have a variant record with restriction No_Implicit_Conditionals 4393 -- in effect, then we skip building the procedure. This is safe because 4394 -- if we can see the restriction, so can any caller, calls to equality 4395 -- test routines are not allowed for variant records if this restriction 4396 -- is active. 4397 4398 if Restriction_Active (No_Implicit_Conditionals) then 4399 return; 4400 end if; 4401 4402 -- Derived Unchecked_Union types no longer inherit the equality function 4403 -- of their parent. 4404 4405 if Is_Derived_Type (Typ) 4406 and then not Is_Unchecked_Union (Typ) 4407 and then not Has_New_Non_Standard_Rep (Typ) 4408 then 4409 declare 4410 Parent_Eq : constant Entity_Id := 4411 TSS (Root_Type (Typ), TSS_Composite_Equality); 4412 begin 4413 if Present (Parent_Eq) then 4414 Copy_TSS (Parent_Eq, Typ); 4415 return; 4416 end if; 4417 end; 4418 end if; 4419 4420 Discard_Node ( 4421 Make_Subprogram_Body (Loc, 4422 Specification => 4423 Make_Function_Specification (Loc, 4424 Defining_Unit_Name => F, 4425 Parameter_Specifications => Pspecs, 4426 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), 4427 Declarations => New_List, 4428 Handled_Statement_Sequence => 4429 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts))); 4430 4431 Append_To (Pspecs, 4432 Make_Parameter_Specification (Loc, 4433 Defining_Identifier => X, 4434 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 4435 4436 Append_To (Pspecs, 4437 Make_Parameter_Specification (Loc, 4438 Defining_Identifier => Y, 4439 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 4440 4441 -- Unchecked_Unions require additional machinery to support equality. 4442 -- Two extra parameters (A and B) are added to the equality function 4443 -- parameter list for each discriminant of the type, in order to 4444 -- capture the inferred values of the discriminants in equality calls. 4445 -- The names of the parameters match the names of the corresponding 4446 -- discriminant, with an added suffix. 4447 4448 if Is_Unchecked_Union (Typ) then 4449 declare 4450 Discr : Entity_Id; 4451 Discr_Type : Entity_Id; 4452 A, B : Entity_Id; 4453 New_Discrs : Elist_Id; 4454 4455 begin 4456 New_Discrs := New_Elmt_List; 4457 4458 Discr := First_Discriminant (Typ); 4459 while Present (Discr) loop 4460 Discr_Type := Etype (Discr); 4461 A := Make_Defining_Identifier (Loc, 4462 Chars => New_External_Name (Chars (Discr), 'A')); 4463 4464 B := Make_Defining_Identifier (Loc, 4465 Chars => New_External_Name (Chars (Discr), 'B')); 4466 4467 -- Add new parameters to the parameter list 4468 4469 Append_To (Pspecs, 4470 Make_Parameter_Specification (Loc, 4471 Defining_Identifier => A, 4472 Parameter_Type => 4473 New_Occurrence_Of (Discr_Type, Loc))); 4474 4475 Append_To (Pspecs, 4476 Make_Parameter_Specification (Loc, 4477 Defining_Identifier => B, 4478 Parameter_Type => 4479 New_Occurrence_Of (Discr_Type, Loc))); 4480 4481 Append_Elmt (A, New_Discrs); 4482 4483 -- Generate the following code to compare each of the inferred 4484 -- discriminants: 4485 4486 -- if a /= b then 4487 -- return False; 4488 -- end if; 4489 4490 Append_To (Stmts, 4491 Make_If_Statement (Loc, 4492 Condition => 4493 Make_Op_Ne (Loc, 4494 Left_Opnd => New_Occurrence_Of (A, Loc), 4495 Right_Opnd => New_Occurrence_Of (B, Loc)), 4496 Then_Statements => New_List ( 4497 Make_Simple_Return_Statement (Loc, 4498 Expression => 4499 New_Occurrence_Of (Standard_False, Loc))))); 4500 Next_Discriminant (Discr); 4501 end loop; 4502 4503 -- Generate component-by-component comparison. Note that we must 4504 -- propagate the inferred discriminants formals to act as 4505 -- the case statement switch. Their value is added when an 4506 -- equality call on unchecked unions is expanded. 4507 4508 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs)); 4509 end; 4510 4511 -- Normal case (not unchecked union) 4512 4513 else 4514 Append_To (Stmts, 4515 Make_Eq_If (Typ, Discriminant_Specifications (Def))); 4516 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); 4517 end if; 4518 4519 Append_To (Stmts, 4520 Make_Simple_Return_Statement (Loc, 4521 Expression => New_Occurrence_Of (Standard_True, Loc))); 4522 4523 Set_TSS (Typ, F); 4524 Set_Is_Pure (F); 4525 4526 if not Debug_Generated_Code then 4527 Set_Debug_Info_Off (F); 4528 end if; 4529 end Build_Variant_Record_Equality; 4530 4531 ----------------------------- 4532 -- Check_Stream_Attributes -- 4533 ----------------------------- 4534 4535 procedure Check_Stream_Attributes (Typ : Entity_Id) is 4536 Comp : Entity_Id; 4537 Par_Read : constant Boolean := 4538 Stream_Attribute_Available (Typ, TSS_Stream_Read) 4539 and then not Has_Specified_Stream_Read (Typ); 4540 Par_Write : constant Boolean := 4541 Stream_Attribute_Available (Typ, TSS_Stream_Write) 4542 and then not Has_Specified_Stream_Write (Typ); 4543 4544 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type); 4545 -- Check that Comp has a user-specified Nam stream attribute 4546 4547 ---------------- 4548 -- Check_Attr -- 4549 ---------------- 4550 4551 procedure Check_Attr (Nam : Name_Id; TSS_Nam : TSS_Name_Type) is 4552 begin 4553 if not Stream_Attribute_Available (Etype (Comp), TSS_Nam) then 4554 Error_Msg_Name_1 := Nam; 4555 Error_Msg_N 4556 ("|component& in limited extension must have% attribute", Comp); 4557 end if; 4558 end Check_Attr; 4559 4560 -- Start of processing for Check_Stream_Attributes 4561 4562 begin 4563 if Par_Read or else Par_Write then 4564 Comp := First_Component (Typ); 4565 while Present (Comp) loop 4566 if Comes_From_Source (Comp) 4567 and then Original_Record_Component (Comp) = Comp 4568 and then Is_Limited_Type (Etype (Comp)) 4569 then 4570 if Par_Read then 4571 Check_Attr (Name_Read, TSS_Stream_Read); 4572 end if; 4573 4574 if Par_Write then 4575 Check_Attr (Name_Write, TSS_Stream_Write); 4576 end if; 4577 end if; 4578 4579 Next_Component (Comp); 4580 end loop; 4581 end if; 4582 end Check_Stream_Attributes; 4583 4584 ---------------------- 4585 -- Clean_Task_Names -- 4586 ---------------------- 4587 4588 procedure Clean_Task_Names 4589 (Typ : Entity_Id; 4590 Proc_Id : Entity_Id) 4591 is 4592 begin 4593 if Has_Task (Typ) 4594 and then not Restriction_Active (No_Implicit_Heap_Allocations) 4595 and then not Global_Discard_Names 4596 and then Tagged_Type_Expansion 4597 then 4598 Set_Uses_Sec_Stack (Proc_Id); 4599 end if; 4600 end Clean_Task_Names; 4601 4602 ------------------------------ 4603 -- Expand_Freeze_Array_Type -- 4604 ------------------------------ 4605 4606 procedure Expand_Freeze_Array_Type (N : Node_Id) is 4607 Typ : constant Entity_Id := Entity (N); 4608 Base : constant Entity_Id := Base_Type (Typ); 4609 Comp_Typ : constant Entity_Id := Component_Type (Typ); 4610 4611 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 4612 4613 Ins_Node : Node_Id; 4614 4615 begin 4616 -- Ensure that all freezing activities are properly flagged as Ghost 4617 4618 Set_Ghost_Mode_From_Entity (Typ); 4619 4620 if not Is_Bit_Packed_Array (Typ) then 4621 4622 -- If the component contains tasks, so does the array type. This may 4623 -- not be indicated in the array type because the component may have 4624 -- been a private type at the point of definition. Same if component 4625 -- type is controlled or contains protected objects. 4626 4627 Set_Has_Task (Base, Has_Task (Comp_Typ)); 4628 Set_Has_Protected (Base, Has_Protected (Comp_Typ)); 4629 Set_Has_Controlled_Component 4630 (Base, Has_Controlled_Component 4631 (Comp_Typ) 4632 or else 4633 Is_Controlled (Comp_Typ)); 4634 4635 if No (Init_Proc (Base)) then 4636 4637 -- If this is an anonymous array created for a declaration with 4638 -- an initial value, its init_proc will never be called. The 4639 -- initial value itself may have been expanded into assignments, 4640 -- in which case the object declaration is carries the 4641 -- No_Initialization flag. 4642 4643 if Is_Itype (Base) 4644 and then Nkind (Associated_Node_For_Itype (Base)) = 4645 N_Object_Declaration 4646 and then 4647 (Present (Expression (Associated_Node_For_Itype (Base))) 4648 or else No_Initialization (Associated_Node_For_Itype (Base))) 4649 then 4650 null; 4651 4652 -- We do not need an init proc for string or wide [wide] string, 4653 -- since the only time these need initialization in normalize or 4654 -- initialize scalars mode, and these types are treated specially 4655 -- and do not need initialization procedures. 4656 4657 elsif Is_Standard_String_Type (Base) then 4658 null; 4659 4660 -- Otherwise we have to build an init proc for the subtype 4661 4662 else 4663 Build_Array_Init_Proc (Base, N); 4664 end if; 4665 end if; 4666 4667 if Typ = Base then 4668 if Has_Controlled_Component (Base) then 4669 Build_Controlling_Procs (Base); 4670 4671 if not Is_Limited_Type (Comp_Typ) 4672 and then Number_Dimensions (Typ) = 1 4673 then 4674 Build_Slice_Assignment (Typ); 4675 end if; 4676 end if; 4677 4678 -- Create a finalization master to service the anonymous access 4679 -- components of the array. 4680 4681 if Ekind (Comp_Typ) = E_Anonymous_Access_Type 4682 and then Needs_Finalization (Designated_Type (Comp_Typ)) 4683 then 4684 -- The finalization master is inserted before the declaration 4685 -- of the array type. The only exception to this is when the 4686 -- array type is an itype, in which case the master appears 4687 -- before the related context. 4688 4689 if Is_Itype (Typ) then 4690 Ins_Node := Associated_Node_For_Itype (Typ); 4691 else 4692 Ins_Node := Parent (Typ); 4693 end if; 4694 4695 Build_Finalization_Master 4696 (Typ => Comp_Typ, 4697 For_Anonymous => True, 4698 Context_Scope => Scope (Typ), 4699 Insertion_Node => Ins_Node); 4700 end if; 4701 end if; 4702 4703 -- For packed case, default initialization, except if the component type 4704 -- is itself a packed structure with an initialization procedure, or 4705 -- initialize/normalize scalars active, and we have a base type, or the 4706 -- type is public, because in that case a client might specify 4707 -- Normalize_Scalars and there better be a public Init_Proc for it. 4708 4709 elsif (Present (Init_Proc (Component_Type (Base))) 4710 and then No (Base_Init_Proc (Base))) 4711 or else (Init_Or_Norm_Scalars and then Base = Typ) 4712 or else Is_Public (Typ) 4713 then 4714 Build_Array_Init_Proc (Base, N); 4715 end if; 4716 4717 if Has_Invariants (Component_Type (Base)) 4718 and then Typ = Base 4719 and then In_Open_Scopes (Scope (Component_Type (Base))) 4720 then 4721 -- Generate component invariant checking procedure. This is only 4722 -- relevant if the array type is within the scope of the component 4723 -- type. Otherwise an array object can only be built using the public 4724 -- subprograms for the component type, and calls to those will have 4725 -- invariant checks. The invariant procedure is only generated for 4726 -- a base type, not a subtype. 4727 4728 Insert_Component_Invariant_Checks 4729 (N, Base, Build_Array_Invariant_Proc (Base, N)); 4730 end if; 4731 4732 Ghost_Mode := Save_Ghost_Mode; 4733 end Expand_Freeze_Array_Type; 4734 4735 ----------------------------------- 4736 -- Expand_Freeze_Class_Wide_Type -- 4737 ----------------------------------- 4738 4739 procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is 4740 function Is_C_Derivation (Typ : Entity_Id) return Boolean; 4741 -- Given a type, determine whether it is derived from a C or C++ root 4742 4743 --------------------- 4744 -- Is_C_Derivation -- 4745 --------------------- 4746 4747 function Is_C_Derivation (Typ : Entity_Id) return Boolean is 4748 T : Entity_Id; 4749 4750 begin 4751 T := Typ; 4752 loop 4753 if Is_CPP_Class (T) 4754 or else Convention (T) = Convention_C 4755 or else Convention (T) = Convention_CPP 4756 then 4757 return True; 4758 end if; 4759 4760 exit when T = Etype (T); 4761 4762 T := Etype (T); 4763 end loop; 4764 4765 return False; 4766 end Is_C_Derivation; 4767 4768 -- Local variables 4769 4770 Typ : constant Entity_Id := Entity (N); 4771 Root : constant Entity_Id := Root_Type (Typ); 4772 4773 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 4774 4775 -- Start of processing for Expand_Freeze_Class_Wide_Type 4776 4777 begin 4778 -- Certain run-time configurations and targets do not provide support 4779 -- for controlled types. 4780 4781 if Restriction_Active (No_Finalization) then 4782 return; 4783 4784 -- Do not create TSS routine Finalize_Address when dispatching calls are 4785 -- disabled since the core of the routine is a dispatching call. 4786 4787 elsif Restriction_Active (No_Dispatching_Calls) then 4788 return; 4789 4790 -- Do not create TSS routine Finalize_Address for concurrent class-wide 4791 -- types. Ignore C, C++, CIL and Java types since it is assumed that the 4792 -- non-Ada side will handle their destruction. 4793 4794 elsif Is_Concurrent_Type (Root) 4795 or else Is_C_Derivation (Root) 4796 or else Convention (Typ) = Convention_CPP 4797 then 4798 return; 4799 4800 -- Do not create TSS routine Finalize_Address when compiling in CodePeer 4801 -- mode since the routine contains an Unchecked_Conversion. 4802 4803 elsif CodePeer_Mode then 4804 return; 4805 end if; 4806 4807 -- Ensure that all freezing activities are properly flagged as Ghost 4808 4809 Set_Ghost_Mode_From_Entity (Typ); 4810 4811 -- Create the body of TSS primitive Finalize_Address. This automatically 4812 -- sets the TSS entry for the class-wide type. 4813 4814 Make_Finalize_Address_Body (Typ); 4815 Ghost_Mode := Save_Ghost_Mode; 4816 end Expand_Freeze_Class_Wide_Type; 4817 4818 ------------------------------------ 4819 -- Expand_Freeze_Enumeration_Type -- 4820 ------------------------------------ 4821 4822 procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is 4823 Typ : constant Entity_Id := Entity (N); 4824 Loc : constant Source_Ptr := Sloc (Typ); 4825 4826 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 4827 4828 Arr : Entity_Id; 4829 Ent : Entity_Id; 4830 Fent : Entity_Id; 4831 Is_Contiguous : Boolean; 4832 Ityp : Entity_Id; 4833 Last_Repval : Uint; 4834 Lst : List_Id; 4835 Num : Nat; 4836 Pos_Expr : Node_Id; 4837 4838 Func : Entity_Id; 4839 pragma Warnings (Off, Func); 4840 4841 begin 4842 -- Ensure that all freezing activities are properly flagged as Ghost 4843 4844 Set_Ghost_Mode_From_Entity (Typ); 4845 4846 -- Various optimizations possible if given representation is contiguous 4847 4848 Is_Contiguous := True; 4849 4850 Ent := First_Literal (Typ); 4851 Last_Repval := Enumeration_Rep (Ent); 4852 4853 Next_Literal (Ent); 4854 while Present (Ent) loop 4855 if Enumeration_Rep (Ent) - Last_Repval /= 1 then 4856 Is_Contiguous := False; 4857 exit; 4858 else 4859 Last_Repval := Enumeration_Rep (Ent); 4860 end if; 4861 4862 Next_Literal (Ent); 4863 end loop; 4864 4865 if Is_Contiguous then 4866 Set_Has_Contiguous_Rep (Typ); 4867 Ent := First_Literal (Typ); 4868 Num := 1; 4869 Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent))); 4870 4871 else 4872 -- Build list of literal references 4873 4874 Lst := New_List; 4875 Num := 0; 4876 4877 Ent := First_Literal (Typ); 4878 while Present (Ent) loop 4879 Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent))); 4880 Num := Num + 1; 4881 Next_Literal (Ent); 4882 end loop; 4883 end if; 4884 4885 -- Now build an array declaration 4886 4887 -- typA : array (Natural range 0 .. num - 1) of ctype := 4888 -- (v, v, v, v, v, ....) 4889 4890 -- where ctype is the corresponding integer type. If the representation 4891 -- is contiguous, we only keep the first literal, which provides the 4892 -- offset for Pos_To_Rep computations. 4893 4894 Arr := 4895 Make_Defining_Identifier (Loc, 4896 Chars => New_External_Name (Chars (Typ), 'A')); 4897 4898 Append_Freeze_Action (Typ, 4899 Make_Object_Declaration (Loc, 4900 Defining_Identifier => Arr, 4901 Constant_Present => True, 4902 4903 Object_Definition => 4904 Make_Constrained_Array_Definition (Loc, 4905 Discrete_Subtype_Definitions => New_List ( 4906 Make_Subtype_Indication (Loc, 4907 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc), 4908 Constraint => 4909 Make_Range_Constraint (Loc, 4910 Range_Expression => 4911 Make_Range (Loc, 4912 Low_Bound => 4913 Make_Integer_Literal (Loc, 0), 4914 High_Bound => 4915 Make_Integer_Literal (Loc, Num - 1))))), 4916 4917 Component_Definition => 4918 Make_Component_Definition (Loc, 4919 Aliased_Present => False, 4920 Subtype_Indication => New_Occurrence_Of (Typ, Loc))), 4921 4922 Expression => 4923 Make_Aggregate (Loc, 4924 Expressions => Lst))); 4925 4926 Set_Enum_Pos_To_Rep (Typ, Arr); 4927 4928 -- Now we build the function that converts representation values to 4929 -- position values. This function has the form: 4930 4931 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is 4932 -- begin 4933 -- case ityp!(A) is 4934 -- when enum-lit'Enum_Rep => return posval; 4935 -- when enum-lit'Enum_Rep => return posval; 4936 -- ... 4937 -- when others => 4938 -- [raise Constraint_Error when F "invalid data"] 4939 -- return -1; 4940 -- end case; 4941 -- end; 4942 4943 -- Note: the F parameter determines whether the others case (no valid 4944 -- representation) raises Constraint_Error or returns a unique value 4945 -- of minus one. The latter case is used, e.g. in 'Valid code. 4946 4947 -- Note: the reason we use Enum_Rep values in the case here is to avoid 4948 -- the code generator making inappropriate assumptions about the range 4949 -- of the values in the case where the value is invalid. ityp is a 4950 -- signed or unsigned integer type of appropriate width. 4951 4952 -- Note: if exceptions are not supported, then we suppress the raise 4953 -- and return -1 unconditionally (this is an erroneous program in any 4954 -- case and there is no obligation to raise Constraint_Error here). We 4955 -- also do this if pragma Restrictions (No_Exceptions) is active. 4956 4957 -- Is this right??? What about No_Exception_Propagation??? 4958 4959 -- Representations are signed 4960 4961 if Enumeration_Rep (First_Literal (Typ)) < 0 then 4962 4963 -- The underlying type is signed. Reset the Is_Unsigned_Type 4964 -- explicitly, because it might have been inherited from 4965 -- parent type. 4966 4967 Set_Is_Unsigned_Type (Typ, False); 4968 4969 if Esize (Typ) <= Standard_Integer_Size then 4970 Ityp := Standard_Integer; 4971 else 4972 Ityp := Universal_Integer; 4973 end if; 4974 4975 -- Representations are unsigned 4976 4977 else 4978 if Esize (Typ) <= Standard_Integer_Size then 4979 Ityp := RTE (RE_Unsigned); 4980 else 4981 Ityp := RTE (RE_Long_Long_Unsigned); 4982 end if; 4983 end if; 4984 4985 -- The body of the function is a case statement. First collect case 4986 -- alternatives, or optimize the contiguous case. 4987 4988 Lst := New_List; 4989 4990 -- If representation is contiguous, Pos is computed by subtracting 4991 -- the representation of the first literal. 4992 4993 if Is_Contiguous then 4994 Ent := First_Literal (Typ); 4995 4996 if Enumeration_Rep (Ent) = Last_Repval then 4997 4998 -- Another special case: for a single literal, Pos is zero 4999 5000 Pos_Expr := Make_Integer_Literal (Loc, Uint_0); 5001 5002 else 5003 Pos_Expr := 5004 Convert_To (Standard_Integer, 5005 Make_Op_Subtract (Loc, 5006 Left_Opnd => 5007 Unchecked_Convert_To 5008 (Ityp, Make_Identifier (Loc, Name_uA)), 5009 Right_Opnd => 5010 Make_Integer_Literal (Loc, 5011 Intval => Enumeration_Rep (First_Literal (Typ))))); 5012 end if; 5013 5014 Append_To (Lst, 5015 Make_Case_Statement_Alternative (Loc, 5016 Discrete_Choices => New_List ( 5017 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), 5018 Low_Bound => 5019 Make_Integer_Literal (Loc, 5020 Intval => Enumeration_Rep (Ent)), 5021 High_Bound => 5022 Make_Integer_Literal (Loc, Intval => Last_Repval))), 5023 5024 Statements => New_List ( 5025 Make_Simple_Return_Statement (Loc, 5026 Expression => Pos_Expr)))); 5027 5028 else 5029 Ent := First_Literal (Typ); 5030 while Present (Ent) loop 5031 Append_To (Lst, 5032 Make_Case_Statement_Alternative (Loc, 5033 Discrete_Choices => New_List ( 5034 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), 5035 Intval => Enumeration_Rep (Ent))), 5036 5037 Statements => New_List ( 5038 Make_Simple_Return_Statement (Loc, 5039 Expression => 5040 Make_Integer_Literal (Loc, 5041 Intval => Enumeration_Pos (Ent)))))); 5042 5043 Next_Literal (Ent); 5044 end loop; 5045 end if; 5046 5047 -- In normal mode, add the others clause with the test 5048 5049 if not No_Exception_Handlers_Set then 5050 Append_To (Lst, 5051 Make_Case_Statement_Alternative (Loc, 5052 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 5053 Statements => New_List ( 5054 Make_Raise_Constraint_Error (Loc, 5055 Condition => Make_Identifier (Loc, Name_uF), 5056 Reason => CE_Invalid_Data), 5057 Make_Simple_Return_Statement (Loc, 5058 Expression => 5059 Make_Integer_Literal (Loc, -1))))); 5060 5061 -- If either of the restrictions No_Exceptions_Handlers/Propagation is 5062 -- active then return -1 (we cannot usefully raise Constraint_Error in 5063 -- this case). See description above for further details. 5064 5065 else 5066 Append_To (Lst, 5067 Make_Case_Statement_Alternative (Loc, 5068 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 5069 Statements => New_List ( 5070 Make_Simple_Return_Statement (Loc, 5071 Expression => 5072 Make_Integer_Literal (Loc, -1))))); 5073 end if; 5074 5075 -- Now we can build the function body 5076 5077 Fent := 5078 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); 5079 5080 Func := 5081 Make_Subprogram_Body (Loc, 5082 Specification => 5083 Make_Function_Specification (Loc, 5084 Defining_Unit_Name => Fent, 5085 Parameter_Specifications => New_List ( 5086 Make_Parameter_Specification (Loc, 5087 Defining_Identifier => 5088 Make_Defining_Identifier (Loc, Name_uA), 5089 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 5090 Make_Parameter_Specification (Loc, 5091 Defining_Identifier => 5092 Make_Defining_Identifier (Loc, Name_uF), 5093 Parameter_Type => 5094 New_Occurrence_Of (Standard_Boolean, Loc))), 5095 5096 Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), 5097 5098 Declarations => Empty_List, 5099 5100 Handled_Statement_Sequence => 5101 Make_Handled_Sequence_Of_Statements (Loc, 5102 Statements => New_List ( 5103 Make_Case_Statement (Loc, 5104 Expression => 5105 Unchecked_Convert_To 5106 (Ityp, Make_Identifier (Loc, Name_uA)), 5107 Alternatives => Lst)))); 5108 5109 Set_TSS (Typ, Fent); 5110 5111 -- Set Pure flag (it will be reset if the current context is not Pure). 5112 -- We also pretend there was a pragma Pure_Function so that for purposes 5113 -- of optimization and constant-folding, we will consider the function 5114 -- Pure even if we are not in a Pure context). 5115 5116 Set_Is_Pure (Fent); 5117 Set_Has_Pragma_Pure_Function (Fent); 5118 5119 -- Unless we are in -gnatD mode, where we are debugging generated code, 5120 -- this is an internal entity for which we don't need debug info. 5121 5122 if not Debug_Generated_Code then 5123 Set_Debug_Info_Off (Fent); 5124 end if; 5125 5126 Ghost_Mode := Save_Ghost_Mode; 5127 5128 exception 5129 when RE_Not_Available => 5130 Ghost_Mode := Save_Ghost_Mode; 5131 return; 5132 end Expand_Freeze_Enumeration_Type; 5133 5134 ------------------------------- 5135 -- Expand_Freeze_Record_Type -- 5136 ------------------------------- 5137 5138 procedure Expand_Freeze_Record_Type (N : Node_Id) is 5139 Typ : constant Node_Id := Entity (N); 5140 Typ_Decl : constant Node_Id := Parent (Typ); 5141 5142 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 5143 5144 Comp : Entity_Id; 5145 Comp_Typ : Entity_Id; 5146 Has_AACC : Boolean; 5147 Predef_List : List_Id; 5148 5149 Renamed_Eq : Node_Id := Empty; 5150 -- Defining unit name for the predefined equality function in the case 5151 -- where the type has a primitive operation that is a renaming of 5152 -- predefined equality (but only if there is also an overriding 5153 -- user-defined equality function). Used to pass this entity from 5154 -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. 5155 5156 Wrapper_Decl_List : List_Id := No_List; 5157 Wrapper_Body_List : List_Id := No_List; 5158 5159 -- Start of processing for Expand_Freeze_Record_Type 5160 5161 begin 5162 -- Ensure that all freezing activities are properly flagged as Ghost 5163 5164 Set_Ghost_Mode_From_Entity (Typ); 5165 5166 -- Build discriminant checking functions if not a derived type (for 5167 -- derived types that are not tagged types, always use the discriminant 5168 -- checking functions of the parent type). However, for untagged types 5169 -- the derivation may have taken place before the parent was frozen, so 5170 -- we copy explicitly the discriminant checking functions from the 5171 -- parent into the components of the derived type. 5172 5173 if not Is_Derived_Type (Typ) 5174 or else Has_New_Non_Standard_Rep (Typ) 5175 or else Is_Tagged_Type (Typ) 5176 then 5177 Build_Discr_Checking_Funcs (Typ_Decl); 5178 5179 elsif Is_Derived_Type (Typ) 5180 and then not Is_Tagged_Type (Typ) 5181 5182 -- If we have a derived Unchecked_Union, we do not inherit the 5183 -- discriminant checking functions from the parent type since the 5184 -- discriminants are non existent. 5185 5186 and then not Is_Unchecked_Union (Typ) 5187 and then Has_Discriminants (Typ) 5188 then 5189 declare 5190 Old_Comp : Entity_Id; 5191 5192 begin 5193 Old_Comp := 5194 First_Component (Base_Type (Underlying_Type (Etype (Typ)))); 5195 Comp := First_Component (Typ); 5196 while Present (Comp) loop 5197 if Ekind (Comp) = E_Component 5198 and then Chars (Comp) = Chars (Old_Comp) 5199 then 5200 Set_Discriminant_Checking_Func 5201 (Comp, Discriminant_Checking_Func (Old_Comp)); 5202 end if; 5203 5204 Next_Component (Old_Comp); 5205 Next_Component (Comp); 5206 end loop; 5207 end; 5208 end if; 5209 5210 if Is_Derived_Type (Typ) 5211 and then Is_Limited_Type (Typ) 5212 and then Is_Tagged_Type (Typ) 5213 then 5214 Check_Stream_Attributes (Typ); 5215 end if; 5216 5217 -- Update task, protected, and controlled component flags, because some 5218 -- of the component types may have been private at the point of the 5219 -- record declaration. Detect anonymous access-to-controlled components. 5220 5221 Has_AACC := False; 5222 5223 Comp := First_Component (Typ); 5224 while Present (Comp) loop 5225 Comp_Typ := Etype (Comp); 5226 5227 if Has_Task (Comp_Typ) then 5228 Set_Has_Task (Typ); 5229 end if; 5230 5231 if Has_Protected (Comp_Typ) then 5232 Set_Has_Protected (Typ); 5233 end if; 5234 5235 -- Do not set Has_Controlled_Component on a class-wide equivalent 5236 -- type. See Make_CW_Equivalent_Type. 5237 5238 if not Is_Class_Wide_Equivalent_Type (Typ) 5239 and then 5240 (Has_Controlled_Component (Comp_Typ) 5241 or else (Chars (Comp) /= Name_uParent 5242 and then (Is_Controlled_Active (Comp_Typ)))) 5243 then 5244 Set_Has_Controlled_Component (Typ); 5245 end if; 5246 5247 -- Non-self-referential anonymous access-to-controlled component 5248 5249 if Ekind (Comp_Typ) = E_Anonymous_Access_Type 5250 and then Needs_Finalization (Designated_Type (Comp_Typ)) 5251 and then Designated_Type (Comp_Typ) /= Typ 5252 then 5253 Has_AACC := True; 5254 end if; 5255 5256 Next_Component (Comp); 5257 end loop; 5258 5259 -- Handle constructors of untagged CPP_Class types 5260 5261 if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then 5262 Set_CPP_Constructors (Typ); 5263 end if; 5264 5265 -- Creation of the Dispatch Table. Note that a Dispatch Table is built 5266 -- for regular tagged types as well as for Ada types deriving from a C++ 5267 -- Class, but not for tagged types directly corresponding to C++ classes 5268 -- In the later case we assume that it is created in the C++ side and we 5269 -- just use it. 5270 5271 if Is_Tagged_Type (Typ) then 5272 5273 -- Add the _Tag component 5274 5275 if Underlying_Type (Etype (Typ)) = Typ then 5276 Expand_Tagged_Root (Typ); 5277 end if; 5278 5279 if Is_CPP_Class (Typ) then 5280 Set_All_DT_Position (Typ); 5281 5282 -- Create the tag entities with a minimum decoration 5283 5284 if Tagged_Type_Expansion then 5285 Append_Freeze_Actions (Typ, Make_Tags (Typ)); 5286 end if; 5287 5288 Set_CPP_Constructors (Typ); 5289 5290 else 5291 if not Building_Static_DT (Typ) then 5292 5293 -- Usually inherited primitives are not delayed but the first 5294 -- Ada extension of a CPP_Class is an exception since the 5295 -- address of the inherited subprogram has to be inserted in 5296 -- the new Ada Dispatch Table and this is a freezing action. 5297 5298 -- Similarly, if this is an inherited operation whose parent is 5299 -- not frozen yet, it is not in the DT of the parent, and we 5300 -- generate an explicit freeze node for the inherited operation 5301 -- so it is properly inserted in the DT of the current type. 5302 5303 declare 5304 Elmt : Elmt_Id; 5305 Subp : Entity_Id; 5306 5307 begin 5308 Elmt := First_Elmt (Primitive_Operations (Typ)); 5309 while Present (Elmt) loop 5310 Subp := Node (Elmt); 5311 5312 if Present (Alias (Subp)) then 5313 if Is_CPP_Class (Etype (Typ)) then 5314 Set_Has_Delayed_Freeze (Subp); 5315 5316 elsif Has_Delayed_Freeze (Alias (Subp)) 5317 and then not Is_Frozen (Alias (Subp)) 5318 then 5319 Set_Is_Frozen (Subp, False); 5320 Set_Has_Delayed_Freeze (Subp); 5321 end if; 5322 end if; 5323 5324 Next_Elmt (Elmt); 5325 end loop; 5326 end; 5327 end if; 5328 5329 -- Unfreeze momentarily the type to add the predefined primitives 5330 -- operations. The reason we unfreeze is so that these predefined 5331 -- operations will indeed end up as primitive operations (which 5332 -- must be before the freeze point). 5333 5334 Set_Is_Frozen (Typ, False); 5335 5336 -- Do not add the spec of predefined primitives in case of 5337 -- CPP tagged type derivations that have convention CPP. 5338 5339 if Is_CPP_Class (Root_Type (Typ)) 5340 and then Convention (Typ) = Convention_CPP 5341 then 5342 null; 5343 5344 -- Do not add the spec of the predefined primitives if we are 5345 -- compiling under restriction No_Dispatching_Calls. 5346 5347 elsif not Restriction_Active (No_Dispatching_Calls) then 5348 Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq); 5349 Insert_List_Before_And_Analyze (N, Predef_List); 5350 end if; 5351 5352 -- Ada 2005 (AI-391): For a nonabstract null extension, create 5353 -- wrapper functions for each nonoverridden inherited function 5354 -- with a controlling result of the type. The wrapper for such 5355 -- a function returns an extension aggregate that invokes the 5356 -- parent function. 5357 5358 if Ada_Version >= Ada_2005 5359 and then not Is_Abstract_Type (Typ) 5360 and then Is_Null_Extension (Typ) 5361 then 5362 Make_Controlling_Function_Wrappers 5363 (Typ, Wrapper_Decl_List, Wrapper_Body_List); 5364 Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); 5365 end if; 5366 5367 -- Ada 2005 (AI-251): For a nonabstract type extension, build 5368 -- null procedure declarations for each set of homographic null 5369 -- procedures that are inherited from interface types but not 5370 -- overridden. This is done to ensure that the dispatch table 5371 -- entry associated with such null primitives are properly filled. 5372 5373 if Ada_Version >= Ada_2005 5374 and then Etype (Typ) /= Typ 5375 and then not Is_Abstract_Type (Typ) 5376 and then Has_Interfaces (Typ) 5377 then 5378 Insert_Actions (N, Make_Null_Procedure_Specs (Typ)); 5379 end if; 5380 5381 Set_Is_Frozen (Typ); 5382 5383 if not Is_Derived_Type (Typ) 5384 or else Is_Tagged_Type (Etype (Typ)) 5385 then 5386 Set_All_DT_Position (Typ); 5387 5388 -- If this is a type derived from an untagged private type whose 5389 -- full view is tagged, the type is marked tagged for layout 5390 -- reasons, but it has no dispatch table. 5391 5392 elsif Is_Derived_Type (Typ) 5393 and then Is_Private_Type (Etype (Typ)) 5394 and then not Is_Tagged_Type (Etype (Typ)) 5395 then 5396 return; 5397 end if; 5398 5399 -- Create and decorate the tags. Suppress their creation when 5400 -- not Tagged_Type_Expansion because the dispatching mechanism is 5401 -- handled internally by the virtual target. 5402 5403 if Tagged_Type_Expansion then 5404 Append_Freeze_Actions (Typ, Make_Tags (Typ)); 5405 5406 -- Generate dispatch table of locally defined tagged type. 5407 -- Dispatch tables of library level tagged types are built 5408 -- later (see Analyze_Declarations). 5409 5410 if not Building_Static_DT (Typ) then 5411 Append_Freeze_Actions (Typ, Make_DT (Typ)); 5412 end if; 5413 end if; 5414 5415 -- If the type has unknown discriminants, propagate dispatching 5416 -- information to its underlying record view, which does not get 5417 -- its own dispatch table. 5418 5419 if Is_Derived_Type (Typ) 5420 and then Has_Unknown_Discriminants (Typ) 5421 and then Present (Underlying_Record_View (Typ)) 5422 then 5423 declare 5424 Rep : constant Entity_Id := Underlying_Record_View (Typ); 5425 begin 5426 Set_Access_Disp_Table 5427 (Rep, Access_Disp_Table (Typ)); 5428 Set_Dispatch_Table_Wrappers 5429 (Rep, Dispatch_Table_Wrappers (Typ)); 5430 Set_Direct_Primitive_Operations 5431 (Rep, Direct_Primitive_Operations (Typ)); 5432 end; 5433 end if; 5434 5435 -- Make sure that the primitives Initialize, Adjust and Finalize 5436 -- are Frozen before other TSS subprograms. We don't want them 5437 -- Frozen inside. 5438 5439 if Is_Controlled (Typ) then 5440 if not Is_Limited_Type (Typ) then 5441 Append_Freeze_Actions (Typ, 5442 Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ)); 5443 end if; 5444 5445 Append_Freeze_Actions (Typ, 5446 Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ)); 5447 5448 Append_Freeze_Actions (Typ, 5449 Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ)); 5450 end if; 5451 5452 -- Freeze rest of primitive operations. There is no need to handle 5453 -- the predefined primitives if we are compiling under restriction 5454 -- No_Dispatching_Calls. 5455 5456 if not Restriction_Active (No_Dispatching_Calls) then 5457 Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ)); 5458 end if; 5459 end if; 5460 5461 -- In the untagged case, ever since Ada 83 an equality function must 5462 -- be provided for variant records that are not unchecked unions. 5463 -- In Ada 2012 the equality function composes, and thus must be built 5464 -- explicitly just as for tagged records. 5465 5466 elsif Has_Discriminants (Typ) 5467 and then not Is_Limited_Type (Typ) 5468 then 5469 declare 5470 Comps : constant Node_Id := 5471 Component_List (Type_Definition (Typ_Decl)); 5472 begin 5473 if Present (Comps) 5474 and then Present (Variant_Part (Comps)) 5475 then 5476 Build_Variant_Record_Equality (Typ); 5477 end if; 5478 end; 5479 5480 -- Otherwise create primitive equality operation (AI05-0123) 5481 5482 -- This is done unconditionally to ensure that tools can be linked 5483 -- properly with user programs compiled with older language versions. 5484 -- In addition, this is needed because "=" composes for bounded strings 5485 -- in all language versions (see Exp_Ch4.Expand_Composite_Equality). 5486 5487 elsif Comes_From_Source (Typ) 5488 and then Convention (Typ) = Convention_Ada 5489 and then not Is_Limited_Type (Typ) 5490 then 5491 Build_Untagged_Equality (Typ); 5492 end if; 5493 5494 -- Before building the record initialization procedure, if we are 5495 -- dealing with a concurrent record value type, then we must go through 5496 -- the discriminants, exchanging discriminals between the concurrent 5497 -- type and the concurrent record value type. See the section "Handling 5498 -- of Discriminants" in the Einfo spec for details. 5499 5500 if Is_Concurrent_Record_Type (Typ) 5501 and then Has_Discriminants (Typ) 5502 then 5503 declare 5504 Ctyp : constant Entity_Id := 5505 Corresponding_Concurrent_Type (Typ); 5506 Conc_Discr : Entity_Id; 5507 Rec_Discr : Entity_Id; 5508 Temp : Entity_Id; 5509 5510 begin 5511 Conc_Discr := First_Discriminant (Ctyp); 5512 Rec_Discr := First_Discriminant (Typ); 5513 while Present (Conc_Discr) loop 5514 Temp := Discriminal (Conc_Discr); 5515 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); 5516 Set_Discriminal (Rec_Discr, Temp); 5517 5518 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); 5519 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); 5520 5521 Next_Discriminant (Conc_Discr); 5522 Next_Discriminant (Rec_Discr); 5523 end loop; 5524 end; 5525 end if; 5526 5527 if Has_Controlled_Component (Typ) then 5528 Build_Controlling_Procs (Typ); 5529 end if; 5530 5531 Adjust_Discriminants (Typ); 5532 5533 -- Do not need init for interfaces on virtual targets since they're 5534 -- abstract. 5535 5536 if Tagged_Type_Expansion or else not Is_Interface (Typ) then 5537 Build_Record_Init_Proc (Typ_Decl, Typ); 5538 end if; 5539 5540 -- For tagged type that are not interfaces, build bodies of primitive 5541 -- operations. Note: do this after building the record initialization 5542 -- procedure, since the primitive operations may need the initialization 5543 -- routine. There is no need to add predefined primitives of interfaces 5544 -- because all their predefined primitives are abstract. 5545 5546 if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then 5547 5548 -- Do not add the body of predefined primitives in case of CPP tagged 5549 -- type derivations that have convention CPP. 5550 5551 if Is_CPP_Class (Root_Type (Typ)) 5552 and then Convention (Typ) = Convention_CPP 5553 then 5554 null; 5555 5556 -- Do not add the body of the predefined primitives if we are 5557 -- compiling under restriction No_Dispatching_Calls or if we are 5558 -- compiling a CPP tagged type. 5559 5560 elsif not Restriction_Active (No_Dispatching_Calls) then 5561 5562 -- Create the body of TSS primitive Finalize_Address. This must 5563 -- be done before the bodies of all predefined primitives are 5564 -- created. If Typ is limited, Stream_Input and Stream_Read may 5565 -- produce build-in-place allocations and for those the expander 5566 -- needs Finalize_Address. 5567 5568 Make_Finalize_Address_Body (Typ); 5569 Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); 5570 Append_Freeze_Actions (Typ, Predef_List); 5571 end if; 5572 5573 -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden 5574 -- inherited functions, then add their bodies to the freeze actions. 5575 5576 if Present (Wrapper_Body_List) then 5577 Append_Freeze_Actions (Typ, Wrapper_Body_List); 5578 end if; 5579 5580 -- Create extra formals for the primitive operations of the type. 5581 -- This must be done before analyzing the body of the initialization 5582 -- procedure, because a self-referential type might call one of these 5583 -- primitives in the body of the init_proc itself. 5584 5585 declare 5586 Elmt : Elmt_Id; 5587 Subp : Entity_Id; 5588 5589 begin 5590 Elmt := First_Elmt (Primitive_Operations (Typ)); 5591 while Present (Elmt) loop 5592 Subp := Node (Elmt); 5593 if not Has_Foreign_Convention (Subp) 5594 and then not Is_Predefined_Dispatching_Operation (Subp) 5595 then 5596 Create_Extra_Formals (Subp); 5597 end if; 5598 5599 Next_Elmt (Elmt); 5600 end loop; 5601 end; 5602 end if; 5603 5604 -- Create a heterogeneous finalization master to service the anonymous 5605 -- access-to-controlled components of the record type. 5606 5607 if Has_AACC then 5608 declare 5609 Encl_Scope : constant Entity_Id := Scope (Typ); 5610 Ins_Node : constant Node_Id := Parent (Typ); 5611 Loc : constant Source_Ptr := Sloc (Typ); 5612 Fin_Mas_Id : Entity_Id; 5613 5614 Attributes_Set : Boolean := False; 5615 Master_Built : Boolean := False; 5616 -- Two flags which control the creation and initialization of a 5617 -- common heterogeneous master. 5618 5619 begin 5620 Comp := First_Component (Typ); 5621 while Present (Comp) loop 5622 Comp_Typ := Etype (Comp); 5623 5624 -- A non-self-referential anonymous access-to-controlled 5625 -- component. 5626 5627 if Ekind (Comp_Typ) = E_Anonymous_Access_Type 5628 and then Needs_Finalization (Designated_Type (Comp_Typ)) 5629 and then Designated_Type (Comp_Typ) /= Typ 5630 then 5631 -- Build a homogeneous master for the first anonymous 5632 -- access-to-controlled component. This master may be 5633 -- converted into a heterogeneous collection if more 5634 -- components are to follow. 5635 5636 if not Master_Built then 5637 Master_Built := True; 5638 5639 -- All anonymous access-to-controlled types allocate 5640 -- on the global pool. Note that the finalization 5641 -- master and the associated storage pool must be set 5642 -- on the root type (both are "root type only"). 5643 5644 Set_Associated_Storage_Pool 5645 (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); 5646 5647 Build_Finalization_Master 5648 (Typ => Root_Type (Comp_Typ), 5649 For_Anonymous => True, 5650 Context_Scope => Encl_Scope, 5651 Insertion_Node => Ins_Node); 5652 5653 Fin_Mas_Id := Finalization_Master (Comp_Typ); 5654 5655 -- Subsequent anonymous access-to-controlled components 5656 -- reuse the available master. 5657 5658 else 5659 -- All anonymous access-to-controlled types allocate 5660 -- on the global pool. Note that both the finalization 5661 -- master and the associated storage pool must be set 5662 -- on the root type (both are "root type only"). 5663 5664 Set_Associated_Storage_Pool 5665 (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); 5666 5667 -- Shared the master among multiple components 5668 5669 Set_Finalization_Master 5670 (Root_Type (Comp_Typ), Fin_Mas_Id); 5671 5672 -- Convert the master into a heterogeneous collection. 5673 -- Generate: 5674 -- Set_Is_Heterogeneous (<Fin_Mas_Id>); 5675 5676 if not Attributes_Set then 5677 Attributes_Set := True; 5678 5679 Insert_Action (Ins_Node, 5680 Make_Procedure_Call_Statement (Loc, 5681 Name => 5682 New_Occurrence_Of 5683 (RTE (RE_Set_Is_Heterogeneous), Loc), 5684 Parameter_Associations => New_List ( 5685 New_Occurrence_Of (Fin_Mas_Id, Loc)))); 5686 end if; 5687 end if; 5688 end if; 5689 5690 Next_Component (Comp); 5691 end loop; 5692 end; 5693 end if; 5694 5695 -- Check whether individual components have a defined invariant, and add 5696 -- the corresponding component invariant checks. 5697 5698 -- Do not create an invariant procedure for some internally generated 5699 -- subtypes, in particular those created for objects of a class-wide 5700 -- type. Such types may have components to which invariant apply, but 5701 -- the corresponding checks will be applied when an object of the parent 5702 -- type is constructed. 5703 5704 -- Such objects will show up in a class-wide postcondition, and the 5705 -- invariant will be checked, if necessary, upon return from the 5706 -- enclosing subprogram. 5707 5708 if not Is_Class_Wide_Equivalent_Type (Typ) then 5709 Insert_Component_Invariant_Checks 5710 (N, Typ, Build_Record_Invariant_Proc (Typ, N)); 5711 end if; 5712 5713 Ghost_Mode := Save_Ghost_Mode; 5714 end Expand_Freeze_Record_Type; 5715 5716 ------------------------------------ 5717 -- Expand_N_Full_Type_Declaration -- 5718 ------------------------------------ 5719 5720 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is 5721 procedure Build_Master (Ptr_Typ : Entity_Id); 5722 -- Create the master associated with Ptr_Typ 5723 5724 ------------------ 5725 -- Build_Master -- 5726 ------------------ 5727 5728 procedure Build_Master (Ptr_Typ : Entity_Id) is 5729 Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ); 5730 5731 begin 5732 -- If the designated type is an incomplete view coming from a 5733 -- limited-with'ed package, we need to use the nonlimited view in 5734 -- case it has tasks. 5735 5736 if Ekind (Desig_Typ) in Incomplete_Kind 5737 and then Present (Non_Limited_View (Desig_Typ)) 5738 then 5739 Desig_Typ := Non_Limited_View (Desig_Typ); 5740 end if; 5741 5742 -- Anonymous access types are created for the components of the 5743 -- record parameter for an entry declaration. No master is created 5744 -- for such a type. 5745 5746 if Comes_From_Source (N) and then Has_Task (Desig_Typ) then 5747 Build_Master_Entity (Ptr_Typ); 5748 Build_Master_Renaming (Ptr_Typ); 5749 5750 -- Create a class-wide master because a Master_Id must be generated 5751 -- for access-to-limited-class-wide types whose root may be extended 5752 -- with task components. 5753 5754 -- Note: This code covers access-to-limited-interfaces because they 5755 -- can be used to reference tasks implementing them. 5756 5757 elsif Is_Limited_Class_Wide_Type (Desig_Typ) 5758 and then Tasking_Allowed 5759 then 5760 Build_Class_Wide_Master (Ptr_Typ); 5761 end if; 5762 end Build_Master; 5763 5764 -- Local declarations 5765 5766 Def_Id : constant Entity_Id := Defining_Identifier (N); 5767 B_Id : constant Entity_Id := Base_Type (Def_Id); 5768 FN : Node_Id; 5769 Par_Id : Entity_Id; 5770 5771 -- Start of processing for Expand_N_Full_Type_Declaration 5772 5773 begin 5774 if Is_Access_Type (Def_Id) then 5775 Build_Master (Def_Id); 5776 5777 if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then 5778 Expand_Access_Protected_Subprogram_Type (N); 5779 end if; 5780 5781 -- Array of anonymous access-to-task pointers 5782 5783 elsif Ada_Version >= Ada_2005 5784 and then Is_Array_Type (Def_Id) 5785 and then Is_Access_Type (Component_Type (Def_Id)) 5786 and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type 5787 then 5788 Build_Master (Component_Type (Def_Id)); 5789 5790 elsif Has_Task (Def_Id) then 5791 Expand_Previous_Access_Type (Def_Id); 5792 5793 -- Check the components of a record type or array of records for 5794 -- anonymous access-to-task pointers. 5795 5796 elsif Ada_Version >= Ada_2005 5797 and then (Is_Record_Type (Def_Id) 5798 or else 5799 (Is_Array_Type (Def_Id) 5800 and then Is_Record_Type (Component_Type (Def_Id)))) 5801 then 5802 declare 5803 Comp : Entity_Id; 5804 First : Boolean; 5805 M_Id : Entity_Id; 5806 Typ : Entity_Id; 5807 5808 begin 5809 if Is_Array_Type (Def_Id) then 5810 Comp := First_Entity (Component_Type (Def_Id)); 5811 else 5812 Comp := First_Entity (Def_Id); 5813 end if; 5814 5815 -- Examine all components looking for anonymous access-to-task 5816 -- types. 5817 5818 First := True; 5819 while Present (Comp) loop 5820 Typ := Etype (Comp); 5821 5822 if Ekind (Typ) = E_Anonymous_Access_Type 5823 and then Has_Task (Available_View (Designated_Type (Typ))) 5824 and then No (Master_Id (Typ)) 5825 then 5826 -- Ensure that the record or array type have a _master 5827 5828 if First then 5829 Build_Master_Entity (Def_Id); 5830 Build_Master_Renaming (Typ); 5831 M_Id := Master_Id (Typ); 5832 5833 First := False; 5834 5835 -- Reuse the same master to service any additional types 5836 5837 else 5838 Set_Master_Id (Typ, M_Id); 5839 end if; 5840 end if; 5841 5842 Next_Entity (Comp); 5843 end loop; 5844 end; 5845 end if; 5846 5847 Par_Id := Etype (B_Id); 5848 5849 -- The parent type is private then we need to inherit any TSS operations 5850 -- from the full view. 5851 5852 if Ekind (Par_Id) in Private_Kind 5853 and then Present (Full_View (Par_Id)) 5854 then 5855 Par_Id := Base_Type (Full_View (Par_Id)); 5856 end if; 5857 5858 if Nkind (Type_Definition (Original_Node (N))) = 5859 N_Derived_Type_Definition 5860 and then not Is_Tagged_Type (Def_Id) 5861 and then Present (Freeze_Node (Par_Id)) 5862 and then Present (TSS_Elist (Freeze_Node (Par_Id))) 5863 then 5864 Ensure_Freeze_Node (B_Id); 5865 FN := Freeze_Node (B_Id); 5866 5867 if No (TSS_Elist (FN)) then 5868 Set_TSS_Elist (FN, New_Elmt_List); 5869 end if; 5870 5871 declare 5872 T_E : constant Elist_Id := TSS_Elist (FN); 5873 Elmt : Elmt_Id; 5874 5875 begin 5876 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); 5877 while Present (Elmt) loop 5878 if Chars (Node (Elmt)) /= Name_uInit then 5879 Append_Elmt (Node (Elmt), T_E); 5880 end if; 5881 5882 Next_Elmt (Elmt); 5883 end loop; 5884 5885 -- If the derived type itself is private with a full view, then 5886 -- associate the full view with the inherited TSS_Elist as well. 5887 5888 if Ekind (B_Id) in Private_Kind 5889 and then Present (Full_View (B_Id)) 5890 then 5891 Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); 5892 Set_TSS_Elist 5893 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); 5894 end if; 5895 end; 5896 end if; 5897 end Expand_N_Full_Type_Declaration; 5898 5899 --------------------------------- 5900 -- Expand_N_Object_Declaration -- 5901 --------------------------------- 5902 5903 procedure Expand_N_Object_Declaration (N : Node_Id) is 5904 Loc : constant Source_Ptr := Sloc (N); 5905 Def_Id : constant Entity_Id := Defining_Identifier (N); 5906 Expr : constant Node_Id := Expression (N); 5907 Obj_Def : constant Node_Id := Object_Definition (N); 5908 Typ : constant Entity_Id := Etype (Def_Id); 5909 Base_Typ : constant Entity_Id := Base_Type (Typ); 5910 Expr_Q : Node_Id; 5911 5912 function Build_Equivalent_Aggregate return Boolean; 5913 -- If the object has a constrained discriminated type and no initial 5914 -- value, it may be possible to build an equivalent aggregate instead, 5915 -- and prevent an actual call to the initialization procedure. 5916 5917 procedure Default_Initialize_Object (After : Node_Id); 5918 -- Generate all default initialization actions for object Def_Id. Any 5919 -- new code is inserted after node After. 5920 5921 function Rewrite_As_Renaming return Boolean; 5922 -- Indicate whether to rewrite a declaration with initialization into an 5923 -- object renaming declaration (see below). 5924 5925 -------------------------------- 5926 -- Build_Equivalent_Aggregate -- 5927 -------------------------------- 5928 5929 function Build_Equivalent_Aggregate return Boolean is 5930 Aggr : Node_Id; 5931 Comp : Entity_Id; 5932 Discr : Elmt_Id; 5933 Full_Type : Entity_Id; 5934 5935 begin 5936 Full_Type := Typ; 5937 5938 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 5939 Full_Type := Full_View (Typ); 5940 end if; 5941 5942 -- Only perform this transformation if Elaboration_Code is forbidden 5943 -- or undesirable, and if this is a global entity of a constrained 5944 -- record type. 5945 5946 -- If Initialize_Scalars might be active this transformation cannot 5947 -- be performed either, because it will lead to different semantics 5948 -- or because elaboration code will in fact be created. 5949 5950 if Ekind (Full_Type) /= E_Record_Subtype 5951 or else not Has_Discriminants (Full_Type) 5952 or else not Is_Constrained (Full_Type) 5953 or else Is_Controlled (Full_Type) 5954 or else Is_Limited_Type (Full_Type) 5955 or else not Restriction_Active (No_Initialize_Scalars) 5956 then 5957 return False; 5958 end if; 5959 5960 if Ekind (Current_Scope) = E_Package 5961 and then 5962 (Restriction_Active (No_Elaboration_Code) 5963 or else Is_Preelaborated (Current_Scope)) 5964 then 5965 -- Building a static aggregate is possible if the discriminants 5966 -- have static values and the other components have static 5967 -- defaults or none. 5968 5969 Discr := First_Elmt (Discriminant_Constraint (Full_Type)); 5970 while Present (Discr) loop 5971 if not Is_OK_Static_Expression (Node (Discr)) then 5972 return False; 5973 end if; 5974 5975 Next_Elmt (Discr); 5976 end loop; 5977 5978 -- Check that initialized components are OK, and that non- 5979 -- initialized components do not require a call to their own 5980 -- initialization procedure. 5981 5982 Comp := First_Component (Full_Type); 5983 while Present (Comp) loop 5984 if Ekind (Comp) = E_Component 5985 and then Present (Expression (Parent (Comp))) 5986 and then 5987 not Is_OK_Static_Expression (Expression (Parent (Comp))) 5988 then 5989 return False; 5990 5991 elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then 5992 return False; 5993 5994 end if; 5995 5996 Next_Component (Comp); 5997 end loop; 5998 5999 -- Everything is static, assemble the aggregate, discriminant 6000 -- values first. 6001 6002 Aggr := 6003 Make_Aggregate (Loc, 6004 Expressions => New_List, 6005 Component_Associations => New_List); 6006 6007 Discr := First_Elmt (Discriminant_Constraint (Full_Type)); 6008 while Present (Discr) loop 6009 Append_To (Expressions (Aggr), New_Copy (Node (Discr))); 6010 Next_Elmt (Discr); 6011 end loop; 6012 6013 -- Now collect values of initialized components 6014 6015 Comp := First_Component (Full_Type); 6016 while Present (Comp) loop 6017 if Ekind (Comp) = E_Component 6018 and then Present (Expression (Parent (Comp))) 6019 then 6020 Append_To (Component_Associations (Aggr), 6021 Make_Component_Association (Loc, 6022 Choices => New_List (New_Occurrence_Of (Comp, Loc)), 6023 Expression => New_Copy_Tree 6024 (Expression (Parent (Comp))))); 6025 end if; 6026 6027 Next_Component (Comp); 6028 end loop; 6029 6030 -- Finally, box-initialize remaining components 6031 6032 Append_To (Component_Associations (Aggr), 6033 Make_Component_Association (Loc, 6034 Choices => New_List (Make_Others_Choice (Loc)), 6035 Expression => Empty)); 6036 Set_Box_Present (Last (Component_Associations (Aggr))); 6037 Set_Expression (N, Aggr); 6038 6039 if Typ /= Full_Type then 6040 Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type))); 6041 Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr)); 6042 Analyze_And_Resolve (Aggr, Typ); 6043 else 6044 Analyze_And_Resolve (Aggr, Full_Type); 6045 end if; 6046 6047 return True; 6048 6049 else 6050 return False; 6051 end if; 6052 end Build_Equivalent_Aggregate; 6053 6054 ------------------------------- 6055 -- Default_Initialize_Object -- 6056 ------------------------------- 6057 6058 procedure Default_Initialize_Object (After : Node_Id) is 6059 function New_Object_Reference return Node_Id; 6060 -- Return a new reference to Def_Id with attributes Assignment_OK and 6061 -- Must_Not_Freeze already set. 6062 6063 -------------------------- 6064 -- New_Object_Reference -- 6065 -------------------------- 6066 6067 function New_Object_Reference return Node_Id is 6068 Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); 6069 6070 begin 6071 -- The call to the type init proc or [Deep_]Finalize must not 6072 -- freeze the related object as the call is internally generated. 6073 -- This way legal rep clauses that apply to the object will not be 6074 -- flagged. Note that the initialization call may be removed if 6075 -- pragma Import is encountered or moved to the freeze actions of 6076 -- the object because of an address clause. 6077 6078 Set_Assignment_OK (Obj_Ref); 6079 Set_Must_Not_Freeze (Obj_Ref); 6080 6081 return Obj_Ref; 6082 end New_Object_Reference; 6083 6084 -- Local variables 6085 6086 Exceptions_OK : constant Boolean := 6087 not Restriction_Active (No_Exception_Propagation); 6088 6089 Abrt_Blk : Node_Id; 6090 Abrt_Blk_Id : Entity_Id; 6091 Abrt_HSS : Node_Id; 6092 Aggr_Init : Node_Id; 6093 AUD : Entity_Id; 6094 Comp_Init : List_Id := No_List; 6095 Fin_Call : Node_Id; 6096 Init_Stmts : List_Id := No_List; 6097 Obj_Init : Node_Id := Empty; 6098 Obj_Ref : Node_Id; 6099 6100 -- Start of processing for Default_Initialize_Object 6101 6102 begin 6103 -- Default initialization is suppressed for objects that are already 6104 -- known to be imported (i.e. whose declaration specifies the Import 6105 -- aspect). Note that for objects with a pragma Import, we generate 6106 -- initialization here, and then remove it downstream when processing 6107 -- the pragma. It is also suppressed for variables for which a pragma 6108 -- Suppress_Initialization has been explicitly given 6109 6110 if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then 6111 return; 6112 end if; 6113 6114 -- The expansion performed by this routine is as follows: 6115 6116 -- begin 6117 -- Abort_Defer; 6118 -- Type_Init_Proc (Obj); 6119 6120 -- begin 6121 -- [Deep_]Initialize (Obj); 6122 6123 -- exception 6124 -- when others => 6125 -- [Deep_]Finalize (Obj, Self => False); 6126 -- raise; 6127 -- end; 6128 -- at end 6129 -- Abort_Undefer_Direct; 6130 -- end; 6131 6132 -- Initialize the components of the object 6133 6134 if Has_Non_Null_Base_Init_Proc (Typ) 6135 and then not No_Initialization (N) 6136 and then not Initialization_Suppressed (Typ) 6137 then 6138 -- Do not initialize the components if No_Default_Initialization 6139 -- applies as the actual restriction check will occur later 6140 -- when the object is frozen as it is not known yet whether the 6141 -- object is imported or not. 6142 6143 if not Restriction_Active (No_Default_Initialization) then 6144 6145 -- If the values of the components are compile-time known, use 6146 -- their prebuilt aggregate form directly. 6147 6148 Aggr_Init := Static_Initialization (Base_Init_Proc (Typ)); 6149 6150 if Present (Aggr_Init) then 6151 Set_Expression 6152 (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope)); 6153 6154 -- If type has discriminants, try to build an equivalent 6155 -- aggregate using discriminant values from the declaration. 6156 -- This is a useful optimization, in particular if restriction 6157 -- No_Elaboration_Code is active. 6158 6159 elsif Build_Equivalent_Aggregate then 6160 null; 6161 6162 -- Otherwise invoke the type init proc, generate: 6163 -- Type_Init_Proc (Obj); 6164 6165 else 6166 Obj_Ref := New_Object_Reference; 6167 6168 if Comes_From_Source (Def_Id) then 6169 Initialization_Warning (Obj_Ref); 6170 end if; 6171 6172 Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ); 6173 end if; 6174 end if; 6175 6176 -- Provide a default value if the object needs simple initialization 6177 -- and does not already have an initial value. A generated temporary 6178 -- does not require initialization because it will be assigned later. 6179 6180 elsif Needs_Simple_Initialization 6181 (Typ, Initialize_Scalars 6182 and then No (Following_Address_Clause (N))) 6183 and then not Is_Internal (Def_Id) 6184 and then not Has_Init_Expression (N) 6185 then 6186 Set_No_Initialization (N, False); 6187 Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); 6188 Analyze_And_Resolve (Expression (N), Typ); 6189 end if; 6190 6191 -- Initialize the object, generate: 6192 -- [Deep_]Initialize (Obj); 6193 6194 if Needs_Finalization (Typ) and then not No_Initialization (N) then 6195 Obj_Init := 6196 Make_Init_Call 6197 (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), 6198 Typ => Typ); 6199 end if; 6200 6201 -- Build a special finalization block when both the object and its 6202 -- controlled components are to be initialized. The block finalizes 6203 -- the components if the object initialization fails. Generate: 6204 6205 -- begin 6206 -- <Obj_Init> 6207 6208 -- exception 6209 -- when others => 6210 -- <Fin_Call> 6211 -- raise; 6212 -- end; 6213 6214 if Has_Controlled_Component (Typ) 6215 and then Present (Comp_Init) 6216 and then Present (Obj_Init) 6217 and then Exceptions_OK 6218 then 6219 Init_Stmts := Comp_Init; 6220 6221 Fin_Call := 6222 Make_Final_Call 6223 (Obj_Ref => New_Object_Reference, 6224 Typ => Typ, 6225 Skip_Self => True); 6226 6227 if Present (Fin_Call) then 6228 6229 -- Do not emit warnings related to the elaboration order when a 6230 -- controlled object is declared before the body of Finalize is 6231 -- seen. 6232 6233 Set_No_Elaboration_Check (Fin_Call); 6234 6235 Append_To (Init_Stmts, 6236 Make_Block_Statement (Loc, 6237 Declarations => No_List, 6238 6239 Handled_Statement_Sequence => 6240 Make_Handled_Sequence_Of_Statements (Loc, 6241 Statements => New_List (Obj_Init), 6242 6243 Exception_Handlers => New_List ( 6244 Make_Exception_Handler (Loc, 6245 Exception_Choices => New_List ( 6246 Make_Others_Choice (Loc)), 6247 6248 Statements => New_List ( 6249 Fin_Call, 6250 Make_Raise_Statement (Loc))))))); 6251 end if; 6252 6253 -- Otherwise finalization is not required, the initialization calls 6254 -- are passed to the abort block building circuitry, generate: 6255 6256 -- Type_Init_Proc (Obj); 6257 -- [Deep_]Initialize (Obj); 6258 6259 else 6260 if Present (Comp_Init) then 6261 Init_Stmts := Comp_Init; 6262 end if; 6263 6264 if Present (Obj_Init) then 6265 if No (Init_Stmts) then 6266 Init_Stmts := New_List; 6267 end if; 6268 6269 Append_To (Init_Stmts, Obj_Init); 6270 end if; 6271 end if; 6272 6273 -- Build an abort block to protect the initialization calls 6274 6275 if Abort_Allowed 6276 and then Present (Comp_Init) 6277 and then Present (Obj_Init) 6278 then 6279 -- Generate: 6280 -- Abort_Defer; 6281 6282 Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 6283 6284 -- When exceptions are propagated, abort deferral must take place 6285 -- in the presence of initialization or finalization exceptions. 6286 -- Generate: 6287 6288 -- begin 6289 -- Abort_Defer; 6290 -- <Init_Stmts> 6291 -- at end 6292 -- Abort_Undefer_Direct; 6293 -- end; 6294 6295 if Exceptions_OK then 6296 AUD := RTE (RE_Abort_Undefer_Direct); 6297 6298 Abrt_HSS := 6299 Make_Handled_Sequence_Of_Statements (Loc, 6300 Statements => Init_Stmts, 6301 At_End_Proc => New_Occurrence_Of (AUD, Loc)); 6302 6303 Abrt_Blk := 6304 Make_Block_Statement (Loc, 6305 Handled_Statement_Sequence => Abrt_HSS); 6306 6307 Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id); 6308 Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id); 6309 6310 -- Present the Abort_Undefer_Direct function to the backend so 6311 -- that it can inline the call to the function. 6312 6313 Add_Inlined_Body (AUD, N); 6314 6315 Init_Stmts := New_List (Abrt_Blk); 6316 6317 -- Otherwise exceptions are not propagated. Generate: 6318 6319 -- Abort_Defer; 6320 -- <Init_Stmts> 6321 -- Abort_Undefer; 6322 6323 else 6324 Append_To (Init_Stmts, 6325 Build_Runtime_Call (Loc, RE_Abort_Undefer)); 6326 end if; 6327 end if; 6328 6329 -- Insert the whole initialization sequence into the tree. If the 6330 -- object has a delayed freeze, as will be the case when it has 6331 -- aspect specifications, the initialization sequence is part of 6332 -- the freeze actions. 6333 6334 if Present (Init_Stmts) then 6335 if Has_Delayed_Freeze (Def_Id) then 6336 Append_Freeze_Actions (Def_Id, Init_Stmts); 6337 else 6338 Insert_Actions_After (After, Init_Stmts); 6339 end if; 6340 end if; 6341 end Default_Initialize_Object; 6342 6343 ------------------------- 6344 -- Rewrite_As_Renaming -- 6345 ------------------------- 6346 6347 function Rewrite_As_Renaming return Boolean is 6348 begin 6349 return not Aliased_Present (N) 6350 and then Is_Entity_Name (Expr_Q) 6351 and then Ekind (Entity (Expr_Q)) = E_Variable 6352 and then OK_To_Rename (Entity (Expr_Q)) 6353 and then Is_Entity_Name (Obj_Def); 6354 end Rewrite_As_Renaming; 6355 6356 -- Local variables 6357 6358 Next_N : constant Node_Id := Next (N); 6359 Id_Ref : Node_Id; 6360 Tag_Assign : Node_Id; 6361 6362 Init_After : Node_Id := N; 6363 -- Node after which the initialization actions are to be inserted. This 6364 -- is normally N, except for the case of a shared passive variable, in 6365 -- which case the init proc call must be inserted only after the bodies 6366 -- of the shared variable procedures have been seen. 6367 6368 -- Start of processing for Expand_N_Object_Declaration 6369 6370 begin 6371 -- Don't do anything for deferred constants. All proper actions will be 6372 -- expanded during the full declaration. 6373 6374 if No (Expr) and Constant_Present (N) then 6375 return; 6376 end if; 6377 6378 -- The type of the object cannot be abstract. This is diagnosed at the 6379 -- point the object is frozen, which happens after the declaration is 6380 -- fully expanded, so simply return now. 6381 6382 if Is_Abstract_Type (Typ) then 6383 return; 6384 end if; 6385 6386 -- First we do special processing for objects of a tagged type where 6387 -- this is the point at which the type is frozen. The creation of the 6388 -- dispatch table and the initialization procedure have to be deferred 6389 -- to this point, since we reference previously declared primitive 6390 -- subprograms. 6391 6392 -- Force construction of dispatch tables of library level tagged types 6393 6394 if Tagged_Type_Expansion 6395 and then Static_Dispatch_Tables 6396 and then Is_Library_Level_Entity (Def_Id) 6397 and then Is_Library_Level_Tagged_Type (Base_Typ) 6398 and then Ekind_In (Base_Typ, E_Record_Type, 6399 E_Protected_Type, 6400 E_Task_Type) 6401 and then not Has_Dispatch_Table (Base_Typ) 6402 then 6403 declare 6404 New_Nodes : List_Id := No_List; 6405 6406 begin 6407 if Is_Concurrent_Type (Base_Typ) then 6408 New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N); 6409 else 6410 New_Nodes := Make_DT (Base_Typ, N); 6411 end if; 6412 6413 if not Is_Empty_List (New_Nodes) then 6414 Insert_List_Before (N, New_Nodes); 6415 end if; 6416 end; 6417 end if; 6418 6419 -- Make shared memory routines for shared passive variable 6420 6421 if Is_Shared_Passive (Def_Id) then 6422 Init_After := Make_Shared_Var_Procs (N); 6423 end if; 6424 6425 -- If tasks being declared, make sure we have an activation chain 6426 -- defined for the tasks (has no effect if we already have one), and 6427 -- also that a Master variable is established and that the appropriate 6428 -- enclosing construct is established as a task master. 6429 6430 if Has_Task (Typ) then 6431 Build_Activation_Chain_Entity (N); 6432 Build_Master_Entity (Def_Id); 6433 end if; 6434 6435 -- Default initialization required, and no expression present 6436 6437 if No (Expr) then 6438 6439 -- If we have a type with a variant part, the initialization proc 6440 -- will contain implicit tests of the discriminant values, which 6441 -- counts as a violation of the restriction No_Implicit_Conditionals. 6442 6443 if Has_Variant_Part (Typ) then 6444 declare 6445 Msg : Boolean; 6446 6447 begin 6448 Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def); 6449 6450 if Msg then 6451 Error_Msg_N 6452 ("\initialization of variant record tests discriminants", 6453 Obj_Def); 6454 return; 6455 end if; 6456 end; 6457 end if; 6458 6459 -- For the default initialization case, if we have a private type 6460 -- with invariants, and invariant checks are enabled, then insert an 6461 -- invariant check after the object declaration. Note that it is OK 6462 -- to clobber the object with an invalid value since if the exception 6463 -- is raised, then the object will go out of scope. In the case where 6464 -- an array object is initialized with an aggregate, the expression 6465 -- is removed. Check flag Has_Init_Expression to avoid generating a 6466 -- junk invariant check and flag No_Initialization to avoid checking 6467 -- an uninitialized object such as a compiler temporary used for an 6468 -- aggregate. 6469 6470 if Has_Invariants (Base_Typ) 6471 and then Present (Invariant_Procedure (Base_Typ)) 6472 and then not Has_Init_Expression (N) 6473 and then not No_Initialization (N) 6474 then 6475 -- If entity has an address clause or aspect, make invariant 6476 -- call into a freeze action for the explicit freeze node for 6477 -- object. Otherwise insert invariant check after declaration. 6478 6479 if Present (Following_Address_Clause (N)) 6480 or else Has_Aspect (Def_Id, Aspect_Address) 6481 then 6482 Ensure_Freeze_Node (Def_Id); 6483 Set_Has_Delayed_Freeze (Def_Id); 6484 Set_Is_Frozen (Def_Id, False); 6485 6486 if not Partial_View_Has_Unknown_Discr (Typ) then 6487 Append_Freeze_Action (Def_Id, 6488 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); 6489 end if; 6490 6491 elsif not Partial_View_Has_Unknown_Discr (Typ) then 6492 Insert_After (N, 6493 Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); 6494 end if; 6495 end if; 6496 6497 Default_Initialize_Object (Init_After); 6498 6499 -- Generate attribute for Persistent_BSS if needed 6500 6501 if Persistent_BSS_Mode 6502 and then Comes_From_Source (N) 6503 and then Is_Potentially_Persistent_Type (Typ) 6504 and then not Has_Init_Expression (N) 6505 and then Is_Library_Level_Entity (Def_Id) 6506 then 6507 declare 6508 Prag : Node_Id; 6509 begin 6510 Prag := 6511 Make_Linker_Section_Pragma 6512 (Def_Id, Sloc (N), ".persistent.bss"); 6513 Insert_After (N, Prag); 6514 Analyze (Prag); 6515 end; 6516 end if; 6517 6518 -- If access type, then we know it is null if not initialized 6519 6520 if Is_Access_Type (Typ) then 6521 Set_Is_Known_Null (Def_Id); 6522 end if; 6523 6524 -- Explicit initialization present 6525 6526 else 6527 -- Obtain actual expression from qualified expression 6528 6529 if Nkind (Expr) = N_Qualified_Expression then 6530 Expr_Q := Expression (Expr); 6531 else 6532 Expr_Q := Expr; 6533 end if; 6534 6535 -- When we have the appropriate type of aggregate in the expression 6536 -- (it has been determined during analysis of the aggregate by 6537 -- setting the delay flag), let's perform in place assignment and 6538 -- thus avoid creating a temporary. 6539 6540 if Is_Delayed_Aggregate (Expr_Q) then 6541 Convert_Aggr_In_Object_Decl (N); 6542 6543 -- Ada 2005 (AI-318-02): If the initialization expression is a call 6544 -- to a build-in-place function, then access to the declared object 6545 -- must be passed to the function. Currently we limit such functions 6546 -- to those with constrained limited result subtypes, but eventually 6547 -- plan to expand the allowed forms of functions that are treated as 6548 -- build-in-place. 6549 6550 elsif Ada_Version >= Ada_2005 6551 and then Is_Build_In_Place_Function_Call (Expr_Q) 6552 then 6553 Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); 6554 6555 -- The previous call expands the expression initializing the 6556 -- built-in-place object into further code that will be analyzed 6557 -- later. No further expansion needed here. 6558 6559 return; 6560 6561 -- Ada 2005 (AI-251): Rewrite the expression that initializes a 6562 -- class-wide interface object to ensure that we copy the full 6563 -- object, unless we are targetting a VM where interfaces are handled 6564 -- by VM itself. Note that if the root type of Typ is an ancestor of 6565 -- Expr's type, both types share the same dispatch table and there is 6566 -- no need to displace the pointer. 6567 6568 elsif Is_Interface (Typ) 6569 6570 -- Avoid never-ending recursion because if Equivalent_Type is set 6571 -- then we've done it already and must not do it again. 6572 6573 and then not 6574 (Nkind (Obj_Def) = N_Identifier 6575 and then Present (Equivalent_Type (Entity (Obj_Def)))) 6576 then 6577 pragma Assert (Is_Class_Wide_Type (Typ)); 6578 6579 -- If the object is a return object of an inherently limited type, 6580 -- which implies build-in-place treatment, bypass the special 6581 -- treatment of class-wide interface initialization below. In this 6582 -- case, the expansion of the return statement will take care of 6583 -- creating the object (via allocator) and initializing it. 6584 6585 if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then 6586 null; 6587 6588 elsif Tagged_Type_Expansion then 6589 declare 6590 Iface : constant Entity_Id := Root_Type (Typ); 6591 Expr_N : Node_Id := Expr; 6592 Expr_Typ : Entity_Id; 6593 New_Expr : Node_Id; 6594 Obj_Id : Entity_Id; 6595 Tag_Comp : Node_Id; 6596 6597 begin 6598 -- If the original node of the expression was a conversion 6599 -- to this specific class-wide interface type then restore 6600 -- the original node because we must copy the object before 6601 -- displacing the pointer to reference the secondary tag 6602 -- component. This code must be kept synchronized with the 6603 -- expansion done by routine Expand_Interface_Conversion 6604 6605 if not Comes_From_Source (Expr_N) 6606 and then Nkind (Expr_N) = N_Explicit_Dereference 6607 and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion 6608 and then Etype (Original_Node (Expr_N)) = Typ 6609 then 6610 Rewrite (Expr_N, Original_Node (Expression (N))); 6611 end if; 6612 6613 -- Avoid expansion of redundant interface conversion 6614 6615 if Is_Interface (Etype (Expr_N)) 6616 and then Nkind (Expr_N) = N_Type_Conversion 6617 and then Etype (Expr_N) = Typ 6618 then 6619 Expr_N := Expression (Expr_N); 6620 Set_Expression (N, Expr_N); 6621 end if; 6622 6623 Obj_Id := Make_Temporary (Loc, 'D', Expr_N); 6624 Expr_Typ := Base_Type (Etype (Expr_N)); 6625 6626 if Is_Class_Wide_Type (Expr_Typ) then 6627 Expr_Typ := Root_Type (Expr_Typ); 6628 end if; 6629 6630 -- Replace 6631 -- CW : I'Class := Obj; 6632 -- by 6633 -- Tmp : T := Obj; 6634 -- type Ityp is not null access I'Class; 6635 -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all; 6636 6637 if Comes_From_Source (Expr_N) 6638 and then Nkind (Expr_N) = N_Identifier 6639 and then not Is_Interface (Expr_Typ) 6640 and then Interface_Present_In_Ancestor (Expr_Typ, Typ) 6641 and then (Expr_Typ = Etype (Expr_Typ) 6642 or else not 6643 Is_Variable_Size_Record (Etype (Expr_Typ))) 6644 then 6645 -- Copy the object 6646 6647 Insert_Action (N, 6648 Make_Object_Declaration (Loc, 6649 Defining_Identifier => Obj_Id, 6650 Object_Definition => 6651 New_Occurrence_Of (Expr_Typ, Loc), 6652 Expression => Relocate_Node (Expr_N))); 6653 6654 -- Statically reference the tag associated with the 6655 -- interface 6656 6657 Tag_Comp := 6658 Make_Selected_Component (Loc, 6659 Prefix => New_Occurrence_Of (Obj_Id, Loc), 6660 Selector_Name => 6661 New_Occurrence_Of 6662 (Find_Interface_Tag (Expr_Typ, Iface), Loc)); 6663 6664 -- Replace 6665 -- IW : I'Class := Obj; 6666 -- by 6667 -- type Equiv_Record is record ... end record; 6668 -- implicit subtype CW is <Class_Wide_Subtype>; 6669 -- Tmp : CW := CW!(Obj); 6670 -- type Ityp is not null access I'Class; 6671 -- IW : I'Class renames 6672 -- Ityp!(Displace (Temp'Address, I'Tag)).all; 6673 6674 else 6675 -- Generate the equivalent record type and update the 6676 -- subtype indication to reference it. 6677 6678 Expand_Subtype_From_Expr 6679 (N => N, 6680 Unc_Type => Typ, 6681 Subtype_Indic => Obj_Def, 6682 Exp => Expr_N); 6683 6684 if not Is_Interface (Etype (Expr_N)) then 6685 New_Expr := Relocate_Node (Expr_N); 6686 6687 -- For interface types we use 'Address which displaces 6688 -- the pointer to the base of the object (if required) 6689 6690 else 6691 New_Expr := 6692 Unchecked_Convert_To (Etype (Obj_Def), 6693 Make_Explicit_Dereference (Loc, 6694 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 6695 Make_Attribute_Reference (Loc, 6696 Prefix => Relocate_Node (Expr_N), 6697 Attribute_Name => Name_Address)))); 6698 end if; 6699 6700 -- Copy the object 6701 6702 if not Is_Limited_Record (Expr_Typ) then 6703 Insert_Action (N, 6704 Make_Object_Declaration (Loc, 6705 Defining_Identifier => Obj_Id, 6706 Object_Definition => 6707 New_Occurrence_Of (Etype (Obj_Def), Loc), 6708 Expression => New_Expr)); 6709 6710 -- Rename limited type object since they cannot be copied 6711 -- This case occurs when the initialization expression 6712 -- has been previously expanded into a temporary object. 6713 6714 else pragma Assert (not Comes_From_Source (Expr_Q)); 6715 Insert_Action (N, 6716 Make_Object_Renaming_Declaration (Loc, 6717 Defining_Identifier => Obj_Id, 6718 Subtype_Mark => 6719 New_Occurrence_Of (Etype (Obj_Def), Loc), 6720 Name => 6721 Unchecked_Convert_To 6722 (Etype (Obj_Def), New_Expr))); 6723 end if; 6724 6725 -- Dynamically reference the tag associated with the 6726 -- interface. 6727 6728 Tag_Comp := 6729 Make_Function_Call (Loc, 6730 Name => New_Occurrence_Of (RTE (RE_Displace), Loc), 6731 Parameter_Associations => New_List ( 6732 Make_Attribute_Reference (Loc, 6733 Prefix => New_Occurrence_Of (Obj_Id, Loc), 6734 Attribute_Name => Name_Address), 6735 New_Occurrence_Of 6736 (Node (First_Elmt (Access_Disp_Table (Iface))), 6737 Loc))); 6738 end if; 6739 6740 Rewrite (N, 6741 Make_Object_Renaming_Declaration (Loc, 6742 Defining_Identifier => Make_Temporary (Loc, 'D'), 6743 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 6744 Name => 6745 Convert_Tag_To_Interface (Typ, Tag_Comp))); 6746 6747 -- If the original entity comes from source, then mark the 6748 -- new entity as needing debug information, even though it's 6749 -- defined by a generated renaming that does not come from 6750 -- source, so that Materialize_Entity will be set on the 6751 -- entity when Debug_Renaming_Declaration is called during 6752 -- analysis. 6753 6754 if Comes_From_Source (Def_Id) then 6755 Set_Debug_Info_Needed (Defining_Identifier (N)); 6756 end if; 6757 6758 Analyze (N, Suppress => All_Checks); 6759 6760 -- Replace internal identifier of rewritten node by the 6761 -- identifier found in the sources. We also have to exchange 6762 -- entities containing their defining identifiers to ensure 6763 -- the correct replacement of the object declaration by this 6764 -- object renaming declaration because these identifiers 6765 -- were previously added by Enter_Name to the current scope. 6766 -- We must preserve the homonym chain of the source entity 6767 -- as well. We must also preserve the kind of the entity, 6768 -- which may be a constant. Preserve entity chain because 6769 -- itypes may have been generated already, and the full 6770 -- chain must be preserved for final freezing. Finally, 6771 -- preserve Comes_From_Source setting, so that debugging 6772 -- and cross-referencing information is properly kept, and 6773 -- preserve source location, to prevent spurious errors when 6774 -- entities are declared (they must have their own Sloc). 6775 6776 declare 6777 New_Id : constant Entity_Id := Defining_Identifier (N); 6778 Next_Temp : constant Entity_Id := Next_Entity (New_Id); 6779 S_Flag : constant Boolean := 6780 Comes_From_Source (Def_Id); 6781 6782 begin 6783 Set_Next_Entity (New_Id, Next_Entity (Def_Id)); 6784 Set_Next_Entity (Def_Id, Next_Temp); 6785 6786 Set_Chars (Defining_Identifier (N), Chars (Def_Id)); 6787 Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); 6788 Set_Ekind (Defining_Identifier (N), Ekind (Def_Id)); 6789 Set_Sloc (Defining_Identifier (N), Sloc (Def_Id)); 6790 6791 Set_Comes_From_Source (Def_Id, False); 6792 Exchange_Entities (Defining_Identifier (N), Def_Id); 6793 Set_Comes_From_Source (Def_Id, S_Flag); 6794 end; 6795 end; 6796 end if; 6797 6798 return; 6799 6800 -- Common case of explicit object initialization 6801 6802 else 6803 -- In most cases, we must check that the initial value meets any 6804 -- constraint imposed by the declared type. However, there is one 6805 -- very important exception to this rule. If the entity has an 6806 -- unconstrained nominal subtype, then it acquired its constraints 6807 -- from the expression in the first place, and not only does this 6808 -- mean that the constraint check is not needed, but an attempt to 6809 -- perform the constraint check can cause order of elaboration 6810 -- problems. 6811 6812 if not Is_Constr_Subt_For_U_Nominal (Typ) then 6813 6814 -- If this is an allocator for an aggregate that has been 6815 -- allocated in place, delay checks until assignments are 6816 -- made, because the discriminants are not initialized. 6817 6818 if Nkind (Expr) = N_Allocator and then No_Initialization (Expr) 6819 then 6820 null; 6821 6822 -- Otherwise apply a constraint check now if no prev error 6823 6824 elsif Nkind (Expr) /= N_Error then 6825 Apply_Constraint_Check (Expr, Typ); 6826 6827 -- Deal with possible range check 6828 6829 if Do_Range_Check (Expr) then 6830 6831 -- If assignment checks are suppressed, turn off flag 6832 6833 if Suppress_Assignment_Checks (N) then 6834 Set_Do_Range_Check (Expr, False); 6835 6836 -- Otherwise generate the range check 6837 6838 else 6839 Generate_Range_Check 6840 (Expr, Typ, CE_Range_Check_Failed); 6841 end if; 6842 end if; 6843 end if; 6844 end if; 6845 6846 -- If the type is controlled and not inherently limited, then 6847 -- the target is adjusted after the copy and attached to the 6848 -- finalization list. However, no adjustment is done in the case 6849 -- where the object was initialized by a call to a function whose 6850 -- result is built in place, since no copy occurred. (Eventually 6851 -- we plan to support in-place function results for some cases 6852 -- of nonlimited types. ???) Similarly, no adjustment is required 6853 -- if we are going to rewrite the object declaration into a 6854 -- renaming declaration. 6855 6856 if Needs_Finalization (Typ) 6857 and then not Is_Limited_View (Typ) 6858 and then not Rewrite_As_Renaming 6859 then 6860 Insert_Action_After (Init_After, 6861 Make_Adjust_Call ( 6862 Obj_Ref => New_Occurrence_Of (Def_Id, Loc), 6863 Typ => Base_Typ)); 6864 end if; 6865 6866 -- For tagged types, when an init value is given, the tag has to 6867 -- be re-initialized separately in order to avoid the propagation 6868 -- of a wrong tag coming from a view conversion unless the type 6869 -- is class wide (in this case the tag comes from the init value). 6870 -- Suppress the tag assignment when not Tagged_Type_Expansion 6871 -- because tags are represented implicitly in objects. Ditto for 6872 -- types that are CPP_CLASS, and for initializations that are 6873 -- aggregates, because they have to have the right tag. 6874 6875 -- The re-assignment of the tag has to be done even if the object 6876 -- is a constant. The assignment must be analyzed after the 6877 -- declaration. If an address clause follows, this is handled as 6878 -- part of the freeze actions for the object, otherwise insert 6879 -- tag assignment here. 6880 6881 Tag_Assign := Make_Tag_Assignment (N); 6882 6883 if Present (Tag_Assign) then 6884 if Present (Following_Address_Clause (N)) then 6885 Ensure_Freeze_Node (Def_Id); 6886 6887 else 6888 Insert_Action_After (Init_After, Tag_Assign); 6889 end if; 6890 6891 -- Handle C++ constructor calls. Note that we do not check that 6892 -- Typ is a tagged type since the equivalent Ada type of a C++ 6893 -- class that has no virtual methods is an untagged limited 6894 -- record type. 6895 6896 elsif Is_CPP_Constructor_Call (Expr) then 6897 6898 -- The call to the initialization procedure does NOT freeze the 6899 -- object being initialized. 6900 6901 Id_Ref := New_Occurrence_Of (Def_Id, Loc); 6902 Set_Must_Not_Freeze (Id_Ref); 6903 Set_Assignment_OK (Id_Ref); 6904 6905 Insert_Actions_After (Init_After, 6906 Build_Initialization_Call (Loc, Id_Ref, Typ, 6907 Constructor_Ref => Expr)); 6908 6909 -- We remove here the original call to the constructor 6910 -- to avoid its management in the backend 6911 6912 Set_Expression (N, Empty); 6913 return; 6914 6915 -- Handle initialization of limited tagged types 6916 6917 elsif Is_Tagged_Type (Typ) 6918 and then Is_Class_Wide_Type (Typ) 6919 and then Is_Limited_Record (Typ) 6920 and then not Is_Limited_Interface (Typ) 6921 then 6922 -- Given that the type is limited we cannot perform a copy. If 6923 -- Expr_Q is the reference to a variable we mark the variable 6924 -- as OK_To_Rename to expand this declaration into a renaming 6925 -- declaration (see bellow). 6926 6927 if Is_Entity_Name (Expr_Q) then 6928 Set_OK_To_Rename (Entity (Expr_Q)); 6929 6930 -- If we cannot convert the expression into a renaming we must 6931 -- consider it an internal error because the backend does not 6932 -- have support to handle it. 6933 6934 else 6935 pragma Assert (False); 6936 raise Program_Error; 6937 end if; 6938 6939 -- For discrete types, set the Is_Known_Valid flag if the 6940 -- initializing value is known to be valid. Only do this for 6941 -- source assignments, since otherwise we can end up turning 6942 -- on the known valid flag prematurely from inserted code. 6943 6944 elsif Comes_From_Source (N) 6945 and then Is_Discrete_Type (Typ) 6946 and then Expr_Known_Valid (Expr) 6947 then 6948 Set_Is_Known_Valid (Def_Id); 6949 6950 elsif Is_Access_Type (Typ) then 6951 6952 -- For access types set the Is_Known_Non_Null flag if the 6953 -- initializing value is known to be non-null. We can also set 6954 -- Can_Never_Be_Null if this is a constant. 6955 6956 if Known_Non_Null (Expr) then 6957 Set_Is_Known_Non_Null (Def_Id, True); 6958 6959 if Constant_Present (N) then 6960 Set_Can_Never_Be_Null (Def_Id); 6961 end if; 6962 end if; 6963 end if; 6964 6965 -- If validity checking on copies, validate initial expression. 6966 -- But skip this if declaration is for a generic type, since it 6967 -- makes no sense to validate generic types. Not clear if this 6968 -- can happen for legal programs, but it definitely can arise 6969 -- from previous instantiation errors. 6970 6971 if Validity_Checks_On 6972 and then Validity_Check_Copies 6973 and then not Is_Generic_Type (Etype (Def_Id)) 6974 then 6975 Ensure_Valid (Expr); 6976 Set_Is_Known_Valid (Def_Id); 6977 end if; 6978 end if; 6979 6980 -- Cases where the back end cannot handle the initialization directly 6981 -- In such cases, we expand an assignment that will be appropriately 6982 -- handled by Expand_N_Assignment_Statement. 6983 6984 -- The exclusion of the unconstrained case is wrong, but for now it 6985 -- is too much trouble ??? 6986 6987 if (Is_Possibly_Unaligned_Slice (Expr) 6988 or else (Is_Possibly_Unaligned_Object (Expr) 6989 and then not Represented_As_Scalar (Etype (Expr)))) 6990 and then not (Is_Array_Type (Etype (Expr)) 6991 and then not Is_Constrained (Etype (Expr))) 6992 then 6993 declare 6994 Stat : constant Node_Id := 6995 Make_Assignment_Statement (Loc, 6996 Name => New_Occurrence_Of (Def_Id, Loc), 6997 Expression => Relocate_Node (Expr)); 6998 begin 6999 Set_Expression (N, Empty); 7000 Set_No_Initialization (N); 7001 Set_Assignment_OK (Name (Stat)); 7002 Set_No_Ctrl_Actions (Stat); 7003 Insert_After_And_Analyze (Init_After, Stat); 7004 end; 7005 end if; 7006 7007 -- Final transformation, if the initializing expression is an entity 7008 -- for a variable with OK_To_Rename set, then we transform: 7009 7010 -- X : typ := expr; 7011 7012 -- into 7013 7014 -- X : typ renames expr 7015 7016 -- provided that X is not aliased. The aliased case has to be 7017 -- excluded in general because Expr will not be aliased in general. 7018 7019 if Rewrite_As_Renaming then 7020 Rewrite (N, 7021 Make_Object_Renaming_Declaration (Loc, 7022 Defining_Identifier => Defining_Identifier (N), 7023 Subtype_Mark => Obj_Def, 7024 Name => Expr_Q)); 7025 7026 -- We do not analyze this renaming declaration, because all its 7027 -- components have already been analyzed, and if we were to go 7028 -- ahead and analyze it, we would in effect be trying to generate 7029 -- another declaration of X, which won't do. 7030 7031 Set_Renamed_Object (Defining_Identifier (N), Expr_Q); 7032 Set_Analyzed (N); 7033 7034 -- We do need to deal with debug issues for this renaming 7035 7036 -- First, if entity comes from source, then mark it as needing 7037 -- debug information, even though it is defined by a generated 7038 -- renaming that does not come from source. 7039 7040 if Comes_From_Source (Defining_Identifier (N)) then 7041 Set_Debug_Info_Needed (Defining_Identifier (N)); 7042 end if; 7043 7044 -- Now call the routine to generate debug info for the renaming 7045 7046 declare 7047 Decl : constant Node_Id := Debug_Renaming_Declaration (N); 7048 begin 7049 if Present (Decl) then 7050 Insert_Action (N, Decl); 7051 end if; 7052 end; 7053 end if; 7054 end if; 7055 7056 if Nkind (N) = N_Object_Declaration 7057 and then Nkind (Obj_Def) = N_Access_Definition 7058 and then not Is_Local_Anonymous_Access (Etype (Def_Id)) 7059 then 7060 -- An Ada 2012 stand-alone object of an anonymous access type 7061 7062 declare 7063 Loc : constant Source_Ptr := Sloc (N); 7064 7065 Level : constant Entity_Id := 7066 Make_Defining_Identifier (Sloc (N), 7067 Chars => 7068 New_External_Name (Chars (Def_Id), Suffix => "L")); 7069 7070 Level_Expr : Node_Id; 7071 Level_Decl : Node_Id; 7072 7073 begin 7074 Set_Ekind (Level, Ekind (Def_Id)); 7075 Set_Etype (Level, Standard_Natural); 7076 Set_Scope (Level, Scope (Def_Id)); 7077 7078 if No (Expr) then 7079 7080 -- Set accessibility level of null 7081 7082 Level_Expr := 7083 Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); 7084 7085 else 7086 Level_Expr := Dynamic_Accessibility_Level (Expr); 7087 end if; 7088 7089 Level_Decl := 7090 Make_Object_Declaration (Loc, 7091 Defining_Identifier => Level, 7092 Object_Definition => 7093 New_Occurrence_Of (Standard_Natural, Loc), 7094 Expression => Level_Expr, 7095 Constant_Present => Constant_Present (N), 7096 Has_Init_Expression => True); 7097 7098 Insert_Action_After (Init_After, Level_Decl); 7099 7100 Set_Extra_Accessibility (Def_Id, Level); 7101 end; 7102 end if; 7103 7104 -- If the object is default initialized and its type is subject to 7105 -- pragma Default_Initial_Condition, add a runtime check to verify 7106 -- the assumption of the pragma (SPARK RM 7.3.3). Generate: 7107 7108 -- <Base_Typ>Default_Init_Cond (<Base_Typ> (Def_Id)); 7109 7110 -- Note that the check is generated for source objects only 7111 7112 if Comes_From_Source (Def_Id) 7113 and then (Has_Default_Init_Cond (Typ) 7114 or else 7115 Has_Inherited_Default_Init_Cond (Typ)) 7116 and then not Has_Init_Expression (N) 7117 then 7118 declare 7119 DIC_Call : constant Node_Id := 7120 Build_Default_Init_Cond_Call (Loc, Def_Id, Typ); 7121 begin 7122 if Present (Next_N) then 7123 Insert_Before_And_Analyze (Next_N, DIC_Call); 7124 7125 -- The object declaration is the last node in a declarative or a 7126 -- statement list. 7127 7128 else 7129 Append_To (List_Containing (N), DIC_Call); 7130 Analyze (DIC_Call); 7131 end if; 7132 end; 7133 end if; 7134 7135 -- Exception on library entity not available 7136 7137 exception 7138 when RE_Not_Available => 7139 return; 7140 end Expand_N_Object_Declaration; 7141 7142 --------------------------------- 7143 -- Expand_N_Subtype_Indication -- 7144 --------------------------------- 7145 7146 -- Add a check on the range of the subtype. The static case is partially 7147 -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need 7148 -- to check here for the static case in order to avoid generating 7149 -- extraneous expanded code. Also deal with validity checking. 7150 7151 procedure Expand_N_Subtype_Indication (N : Node_Id) is 7152 Ran : constant Node_Id := Range_Expression (Constraint (N)); 7153 Typ : constant Entity_Id := Entity (Subtype_Mark (N)); 7154 7155 begin 7156 if Nkind (Constraint (N)) = N_Range_Constraint then 7157 Validity_Check_Range (Range_Expression (Constraint (N))); 7158 end if; 7159 7160 if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then 7161 Apply_Range_Check (Ran, Typ); 7162 end if; 7163 end Expand_N_Subtype_Indication; 7164 7165 --------------------------- 7166 -- Expand_N_Variant_Part -- 7167 --------------------------- 7168 7169 -- Note: this procedure no longer has any effect. It used to be that we 7170 -- would replace the choices in the last variant by a when others, and 7171 -- also expanded static predicates in variant choices here, but both of 7172 -- those activities were being done too early, since we can't check the 7173 -- choices until the statically predicated subtypes are frozen, which can 7174 -- happen as late as the free point of the record, and we can't change the 7175 -- last choice to an others before checking the choices, which is now done 7176 -- at the freeze point of the record. 7177 7178 procedure Expand_N_Variant_Part (N : Node_Id) is 7179 begin 7180 null; 7181 end Expand_N_Variant_Part; 7182 7183 --------------------------------- 7184 -- Expand_Previous_Access_Type -- 7185 --------------------------------- 7186 7187 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is 7188 Ptr_Typ : Entity_Id; 7189 7190 begin 7191 -- Find all access types in the current scope whose designated type is 7192 -- Def_Id and build master renamings for them. 7193 7194 Ptr_Typ := First_Entity (Current_Scope); 7195 while Present (Ptr_Typ) loop 7196 if Is_Access_Type (Ptr_Typ) 7197 and then Designated_Type (Ptr_Typ) = Def_Id 7198 and then No (Master_Id (Ptr_Typ)) 7199 then 7200 -- Ensure that the designated type has a master 7201 7202 Build_Master_Entity (Def_Id); 7203 7204 -- Private and incomplete types complicate the insertion of master 7205 -- renamings because the access type may precede the full view of 7206 -- the designated type. For this reason, the master renamings are 7207 -- inserted relative to the designated type. 7208 7209 Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id)); 7210 end if; 7211 7212 Next_Entity (Ptr_Typ); 7213 end loop; 7214 end Expand_Previous_Access_Type; 7215 7216 ----------------------------- 7217 -- Expand_Record_Extension -- 7218 ----------------------------- 7219 7220 -- Add a field _parent at the beginning of the record extension. This is 7221 -- used to implement inheritance. Here are some examples of expansion: 7222 7223 -- 1. no discriminants 7224 -- type T2 is new T1 with null record; 7225 -- gives 7226 -- type T2 is new T1 with record 7227 -- _Parent : T1; 7228 -- end record; 7229 7230 -- 2. renamed discriminants 7231 -- type T2 (B, C : Int) is new T1 (A => B) with record 7232 -- _Parent : T1 (A => B); 7233 -- D : Int; 7234 -- end; 7235 7236 -- 3. inherited discriminants 7237 -- type T2 is new T1 with record -- discriminant A inherited 7238 -- _Parent : T1 (A); 7239 -- D : Int; 7240 -- end; 7241 7242 procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is 7243 Indic : constant Node_Id := Subtype_Indication (Def); 7244 Loc : constant Source_Ptr := Sloc (Def); 7245 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); 7246 Par_Subtype : Entity_Id; 7247 Comp_List : Node_Id; 7248 Comp_Decl : Node_Id; 7249 Parent_N : Node_Id; 7250 D : Entity_Id; 7251 List_Constr : constant List_Id := New_List; 7252 7253 begin 7254 -- Expand_Record_Extension is called directly from the semantics, so 7255 -- we must check to see whether expansion is active before proceeding, 7256 -- because this affects the visibility of selected components in bodies 7257 -- of instances. 7258 7259 if not Expander_Active then 7260 return; 7261 end if; 7262 7263 -- This may be a derivation of an untagged private type whose full 7264 -- view is tagged, in which case the Derived_Type_Definition has no 7265 -- extension part. Build an empty one now. 7266 7267 if No (Rec_Ext_Part) then 7268 Rec_Ext_Part := 7269 Make_Record_Definition (Loc, 7270 End_Label => Empty, 7271 Component_List => Empty, 7272 Null_Present => True); 7273 7274 Set_Record_Extension_Part (Def, Rec_Ext_Part); 7275 Mark_Rewrite_Insertion (Rec_Ext_Part); 7276 end if; 7277 7278 Comp_List := Component_List (Rec_Ext_Part); 7279 7280 Parent_N := Make_Defining_Identifier (Loc, Name_uParent); 7281 7282 -- If the derived type inherits its discriminants the type of the 7283 -- _parent field must be constrained by the inherited discriminants 7284 7285 if Has_Discriminants (T) 7286 and then Nkind (Indic) /= N_Subtype_Indication 7287 and then not Is_Constrained (Entity (Indic)) 7288 then 7289 D := First_Discriminant (T); 7290 while Present (D) loop 7291 Append_To (List_Constr, New_Occurrence_Of (D, Loc)); 7292 Next_Discriminant (D); 7293 end loop; 7294 7295 Par_Subtype := 7296 Process_Subtype ( 7297 Make_Subtype_Indication (Loc, 7298 Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc), 7299 Constraint => 7300 Make_Index_Or_Discriminant_Constraint (Loc, 7301 Constraints => List_Constr)), 7302 Def); 7303 7304 -- Otherwise the original subtype_indication is just what is needed 7305 7306 else 7307 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); 7308 end if; 7309 7310 Set_Parent_Subtype (T, Par_Subtype); 7311 7312 Comp_Decl := 7313 Make_Component_Declaration (Loc, 7314 Defining_Identifier => Parent_N, 7315 Component_Definition => 7316 Make_Component_Definition (Loc, 7317 Aliased_Present => False, 7318 Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc))); 7319 7320 if Null_Present (Rec_Ext_Part) then 7321 Set_Component_List (Rec_Ext_Part, 7322 Make_Component_List (Loc, 7323 Component_Items => New_List (Comp_Decl), 7324 Variant_Part => Empty, 7325 Null_Present => False)); 7326 Set_Null_Present (Rec_Ext_Part, False); 7327 7328 elsif Null_Present (Comp_List) 7329 or else Is_Empty_List (Component_Items (Comp_List)) 7330 then 7331 Set_Component_Items (Comp_List, New_List (Comp_Decl)); 7332 Set_Null_Present (Comp_List, False); 7333 7334 else 7335 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); 7336 end if; 7337 7338 Analyze (Comp_Decl); 7339 end Expand_Record_Extension; 7340 7341 ------------------------ 7342 -- Expand_Tagged_Root -- 7343 ------------------------ 7344 7345 procedure Expand_Tagged_Root (T : Entity_Id) is 7346 Def : constant Node_Id := Type_Definition (Parent (T)); 7347 Comp_List : Node_Id; 7348 Comp_Decl : Node_Id; 7349 Sloc_N : Source_Ptr; 7350 7351 begin 7352 if Null_Present (Def) then 7353 Set_Component_List (Def, 7354 Make_Component_List (Sloc (Def), 7355 Component_Items => Empty_List, 7356 Variant_Part => Empty, 7357 Null_Present => True)); 7358 end if; 7359 7360 Comp_List := Component_List (Def); 7361 7362 if Null_Present (Comp_List) 7363 or else Is_Empty_List (Component_Items (Comp_List)) 7364 then 7365 Sloc_N := Sloc (Comp_List); 7366 else 7367 Sloc_N := Sloc (First (Component_Items (Comp_List))); 7368 end if; 7369 7370 Comp_Decl := 7371 Make_Component_Declaration (Sloc_N, 7372 Defining_Identifier => First_Tag_Component (T), 7373 Component_Definition => 7374 Make_Component_Definition (Sloc_N, 7375 Aliased_Present => False, 7376 Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N))); 7377 7378 if Null_Present (Comp_List) 7379 or else Is_Empty_List (Component_Items (Comp_List)) 7380 then 7381 Set_Component_Items (Comp_List, New_List (Comp_Decl)); 7382 Set_Null_Present (Comp_List, False); 7383 7384 else 7385 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); 7386 end if; 7387 7388 -- We don't Analyze the whole expansion because the tag component has 7389 -- already been analyzed previously. Here we just insure that the tree 7390 -- is coherent with the semantic decoration 7391 7392 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); 7393 7394 exception 7395 when RE_Not_Available => 7396 return; 7397 end Expand_Tagged_Root; 7398 7399 ------------------------------ 7400 -- Freeze_Stream_Operations -- 7401 ------------------------------ 7402 7403 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is 7404 Names : constant array (1 .. 4) of TSS_Name_Type := 7405 (TSS_Stream_Input, 7406 TSS_Stream_Output, 7407 TSS_Stream_Read, 7408 TSS_Stream_Write); 7409 Stream_Op : Entity_Id; 7410 7411 begin 7412 -- Primitive operations of tagged types are frozen when the dispatch 7413 -- table is constructed. 7414 7415 if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then 7416 return; 7417 end if; 7418 7419 for J in Names'Range loop 7420 Stream_Op := TSS (Typ, Names (J)); 7421 7422 if Present (Stream_Op) 7423 and then Is_Subprogram (Stream_Op) 7424 and then Nkind (Unit_Declaration_Node (Stream_Op)) = 7425 N_Subprogram_Declaration 7426 and then not Is_Frozen (Stream_Op) 7427 then 7428 Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N)); 7429 end if; 7430 end loop; 7431 end Freeze_Stream_Operations; 7432 7433 ----------------- 7434 -- Freeze_Type -- 7435 ----------------- 7436 7437 -- Full type declarations are expanded at the point at which the type is 7438 -- frozen. The formal N is the Freeze_Node for the type. Any statements or 7439 -- declarations generated by the freezing (e.g. the procedure generated 7440 -- for initialization) are chained in the Actions field list of the freeze 7441 -- node using Append_Freeze_Actions. 7442 7443 function Freeze_Type (N : Node_Id) return Boolean is 7444 procedure Process_RACW_Types (Typ : Entity_Id); 7445 -- Validate and generate stubs for all RACW types associated with type 7446 -- Typ. 7447 7448 procedure Process_Pending_Access_Types (Typ : Entity_Id); 7449 -- Associate type Typ's Finalize_Address primitive with the finalization 7450 -- masters of pending access-to-Typ types. 7451 7452 ------------------------ 7453 -- Process_RACW_Types -- 7454 ------------------------ 7455 7456 procedure Process_RACW_Types (Typ : Entity_Id) is 7457 List : constant Elist_Id := Access_Types_To_Process (N); 7458 E : Elmt_Id; 7459 Seen : Boolean := False; 7460 7461 begin 7462 if Present (List) then 7463 E := First_Elmt (List); 7464 while Present (E) loop 7465 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then 7466 Validate_RACW_Primitives (Node (E)); 7467 Seen := True; 7468 end if; 7469 7470 Next_Elmt (E); 7471 end loop; 7472 end if; 7473 7474 -- If there are RACWs designating this type, make stubs now 7475 7476 if Seen then 7477 Remote_Types_Tagged_Full_View_Encountered (Typ); 7478 end if; 7479 end Process_RACW_Types; 7480 7481 ---------------------------------- 7482 -- Process_Pending_Access_Types -- 7483 ---------------------------------- 7484 7485 procedure Process_Pending_Access_Types (Typ : Entity_Id) is 7486 E : Elmt_Id; 7487 7488 begin 7489 -- Finalize_Address is not generated in CodePeer mode because the 7490 -- body contains address arithmetic. This processing is disabled. 7491 7492 if CodePeer_Mode then 7493 null; 7494 7495 -- Certain itypes are generated for contexts that cannot allocate 7496 -- objects and should not set primitive Finalize_Address. 7497 7498 elsif Is_Itype (Typ) 7499 and then Nkind (Associated_Node_For_Itype (Typ)) = 7500 N_Explicit_Dereference 7501 then 7502 null; 7503 7504 -- When an access type is declared after the incomplete view of a 7505 -- Taft-amendment type, the access type is considered pending in 7506 -- case the full view of the Taft-amendment type is controlled. If 7507 -- this is indeed the case, associate the Finalize_Address routine 7508 -- of the full view with the finalization masters of all pending 7509 -- access types. This scenario applies to anonymous access types as 7510 -- well. 7511 7512 elsif Needs_Finalization (Typ) 7513 and then Present (Pending_Access_Types (Typ)) 7514 then 7515 E := First_Elmt (Pending_Access_Types (Typ)); 7516 while Present (E) loop 7517 7518 -- Generate: 7519 -- Set_Finalize_Address 7520 -- (Ptr_Typ, <Typ>FD'Unrestricted_Access); 7521 7522 Append_Freeze_Action (Typ, 7523 Make_Set_Finalize_Address_Call 7524 (Loc => Sloc (N), 7525 Ptr_Typ => Node (E))); 7526 7527 Next_Elmt (E); 7528 end loop; 7529 end if; 7530 end Process_Pending_Access_Types; 7531 7532 -- Local variables 7533 7534 Def_Id : constant Entity_Id := Entity (N); 7535 Result : Boolean := False; 7536 7537 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 7538 7539 -- Start of processing for Freeze_Type 7540 7541 begin 7542 -- The type being frozen may be subject to pragma Ghost. Set the mode 7543 -- now to ensure that any nodes generated during freezing are properly 7544 -- marked as Ghost. 7545 7546 Set_Ghost_Mode (N, Def_Id); 7547 7548 -- Process any remote access-to-class-wide types designating the type 7549 -- being frozen. 7550 7551 Process_RACW_Types (Def_Id); 7552 7553 -- Freeze processing for record types 7554 7555 if Is_Record_Type (Def_Id) then 7556 if Ekind (Def_Id) = E_Record_Type then 7557 Expand_Freeze_Record_Type (N); 7558 elsif Is_Class_Wide_Type (Def_Id) then 7559 Expand_Freeze_Class_Wide_Type (N); 7560 end if; 7561 7562 -- Freeze processing for array types 7563 7564 elsif Is_Array_Type (Def_Id) then 7565 Expand_Freeze_Array_Type (N); 7566 7567 -- Freeze processing for access types 7568 7569 -- For pool-specific access types, find out the pool object used for 7570 -- this type, needs actual expansion of it in some cases. Here are the 7571 -- different cases : 7572 7573 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" 7574 -- ---> don't use any storage pool 7575 7576 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. 7577 -- Expand: 7578 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); 7579 7580 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" 7581 -- ---> Storage Pool is the specified one 7582 7583 -- See GNAT Pool packages in the Run-Time for more details 7584 7585 elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then 7586 declare 7587 Loc : constant Source_Ptr := Sloc (N); 7588 Desig_Type : constant Entity_Id := Designated_Type (Def_Id); 7589 Pool_Object : Entity_Id; 7590 7591 Freeze_Action_Typ : Entity_Id; 7592 7593 begin 7594 -- Case 1 7595 7596 -- Rep Clause "for Def_Id'Storage_Size use 0;" 7597 -- ---> don't use any storage pool 7598 7599 if No_Pool_Assigned (Def_Id) then 7600 null; 7601 7602 -- Case 2 7603 7604 -- Rep Clause : for Def_Id'Storage_Size use Expr. 7605 -- ---> Expand: 7606 -- Def_Id__Pool : Stack_Bounded_Pool 7607 -- (Expr, DT'Size, DT'Alignment); 7608 7609 elsif Has_Storage_Size_Clause (Def_Id) then 7610 declare 7611 DT_Size : Node_Id; 7612 DT_Align : Node_Id; 7613 7614 begin 7615 -- For unconstrained composite types we give a size of zero 7616 -- so that the pool knows that it needs a special algorithm 7617 -- for variable size object allocation. 7618 7619 if Is_Composite_Type (Desig_Type) 7620 and then not Is_Constrained (Desig_Type) 7621 then 7622 DT_Size := Make_Integer_Literal (Loc, 0); 7623 DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment); 7624 7625 else 7626 DT_Size := 7627 Make_Attribute_Reference (Loc, 7628 Prefix => New_Occurrence_Of (Desig_Type, Loc), 7629 Attribute_Name => Name_Max_Size_In_Storage_Elements); 7630 7631 DT_Align := 7632 Make_Attribute_Reference (Loc, 7633 Prefix => New_Occurrence_Of (Desig_Type, Loc), 7634 Attribute_Name => Name_Alignment); 7635 end if; 7636 7637 Pool_Object := 7638 Make_Defining_Identifier (Loc, 7639 Chars => New_External_Name (Chars (Def_Id), 'P')); 7640 7641 -- We put the code associated with the pools in the entity 7642 -- that has the later freeze node, usually the access type 7643 -- but it can also be the designated_type; because the pool 7644 -- code requires both those types to be frozen 7645 7646 if Is_Frozen (Desig_Type) 7647 and then (No (Freeze_Node (Desig_Type)) 7648 or else Analyzed (Freeze_Node (Desig_Type))) 7649 then 7650 Freeze_Action_Typ := Def_Id; 7651 7652 -- A Taft amendment type cannot get the freeze actions 7653 -- since the full view is not there. 7654 7655 elsif Is_Incomplete_Or_Private_Type (Desig_Type) 7656 and then No (Full_View (Desig_Type)) 7657 then 7658 Freeze_Action_Typ := Def_Id; 7659 7660 else 7661 Freeze_Action_Typ := Desig_Type; 7662 end if; 7663 7664 Append_Freeze_Action (Freeze_Action_Typ, 7665 Make_Object_Declaration (Loc, 7666 Defining_Identifier => Pool_Object, 7667 Object_Definition => 7668 Make_Subtype_Indication (Loc, 7669 Subtype_Mark => 7670 New_Occurrence_Of 7671 (RTE (RE_Stack_Bounded_Pool), Loc), 7672 7673 Constraint => 7674 Make_Index_Or_Discriminant_Constraint (Loc, 7675 Constraints => New_List ( 7676 7677 -- First discriminant is the Pool Size 7678 7679 New_Occurrence_Of ( 7680 Storage_Size_Variable (Def_Id), Loc), 7681 7682 -- Second discriminant is the element size 7683 7684 DT_Size, 7685 7686 -- Third discriminant is the alignment 7687 7688 DT_Align))))); 7689 end; 7690 7691 Set_Associated_Storage_Pool (Def_Id, Pool_Object); 7692 7693 -- Case 3 7694 7695 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" 7696 -- ---> Storage Pool is the specified one 7697 7698 -- When compiling in Ada 2012 mode, ensure that the accessibility 7699 -- level of the subpool access type is not deeper than that of the 7700 -- pool_with_subpools. 7701 7702 elsif Ada_Version >= Ada_2012 7703 and then Present (Associated_Storage_Pool (Def_Id)) 7704 7705 -- Omit this check for the case of a configurable run-time that 7706 -- does not provide package System.Storage_Pools.Subpools. 7707 7708 and then RTE_Available (RE_Root_Storage_Pool_With_Subpools) 7709 then 7710 declare 7711 Loc : constant Source_Ptr := Sloc (Def_Id); 7712 Pool : constant Entity_Id := 7713 Associated_Storage_Pool (Def_Id); 7714 RSPWS : constant Entity_Id := 7715 RTE (RE_Root_Storage_Pool_With_Subpools); 7716 7717 begin 7718 -- It is known that the accessibility level of the access 7719 -- type is deeper than that of the pool. 7720 7721 if Type_Access_Level (Def_Id) > Object_Access_Level (Pool) 7722 and then not Accessibility_Checks_Suppressed (Def_Id) 7723 and then not Accessibility_Checks_Suppressed (Pool) 7724 then 7725 -- Static case: the pool is known to be a descendant of 7726 -- Root_Storage_Pool_With_Subpools. 7727 7728 if Is_Ancestor (RSPWS, Etype (Pool)) then 7729 Error_Msg_N 7730 ("??subpool access type has deeper accessibility " 7731 & "level than pool", Def_Id); 7732 7733 Append_Freeze_Action (Def_Id, 7734 Make_Raise_Program_Error (Loc, 7735 Reason => PE_Accessibility_Check_Failed)); 7736 7737 -- Dynamic case: when the pool is of a class-wide type, 7738 -- it may or may not support subpools depending on the 7739 -- path of derivation. Generate: 7740 7741 -- if Def_Id in RSPWS'Class then 7742 -- raise Program_Error; 7743 -- end if; 7744 7745 elsif Is_Class_Wide_Type (Etype (Pool)) then 7746 Append_Freeze_Action (Def_Id, 7747 Make_If_Statement (Loc, 7748 Condition => 7749 Make_In (Loc, 7750 Left_Opnd => New_Occurrence_Of (Pool, Loc), 7751 Right_Opnd => 7752 New_Occurrence_Of 7753 (Class_Wide_Type (RSPWS), Loc)), 7754 7755 Then_Statements => New_List ( 7756 Make_Raise_Program_Error (Loc, 7757 Reason => PE_Accessibility_Check_Failed)))); 7758 end if; 7759 end if; 7760 end; 7761 end if; 7762 7763 -- For access-to-controlled types (including class-wide types and 7764 -- Taft-amendment types, which potentially have controlled 7765 -- components), expand the list controller object that will store 7766 -- the dynamically allocated objects. Don't do this transformation 7767 -- for expander-generated access types, but do it for types that 7768 -- are the full view of types derived from other private types. 7769 -- Also suppress the list controller in the case of a designated 7770 -- type with convention Java, since this is used when binding to 7771 -- Java API specs, where there's no equivalent of a finalization 7772 -- list and we don't want to pull in the finalization support if 7773 -- not needed. 7774 7775 if not Comes_From_Source (Def_Id) 7776 and then not Has_Private_Declaration (Def_Id) 7777 then 7778 null; 7779 7780 -- An exception is made for types defined in the run-time because 7781 -- Ada.Tags.Tag itself is such a type and cannot afford this 7782 -- unnecessary overhead that would generates a loop in the 7783 -- expansion scheme. Another exception is if Restrictions 7784 -- (No_Finalization) is active, since then we know nothing is 7785 -- controlled. 7786 7787 elsif Restriction_Active (No_Finalization) 7788 or else In_Runtime (Def_Id) 7789 then 7790 null; 7791 7792 -- Create a finalization master for an access-to-controlled type 7793 -- or an access-to-incomplete type. It is assumed that the full 7794 -- view will be controlled. 7795 7796 elsif Needs_Finalization (Desig_Type) 7797 or else (Is_Incomplete_Type (Desig_Type) 7798 and then No (Full_View (Desig_Type))) 7799 then 7800 Build_Finalization_Master (Def_Id); 7801 7802 -- Create a finalization master when the designated type contains 7803 -- a private component. It is assumed that the full view will be 7804 -- controlled. 7805 7806 elsif Has_Private_Component (Desig_Type) then 7807 Build_Finalization_Master 7808 (Typ => Def_Id, 7809 For_Private => True, 7810 Context_Scope => Scope (Def_Id), 7811 Insertion_Node => Declaration_Node (Desig_Type)); 7812 end if; 7813 end; 7814 7815 -- Freeze processing for enumeration types 7816 7817 elsif Ekind (Def_Id) = E_Enumeration_Type then 7818 7819 -- We only have something to do if we have a non-standard 7820 -- representation (i.e. at least one literal whose pos value 7821 -- is not the same as its representation) 7822 7823 if Has_Non_Standard_Rep (Def_Id) then 7824 Expand_Freeze_Enumeration_Type (N); 7825 end if; 7826 7827 -- Private types that are completed by a derivation from a private 7828 -- type have an internally generated full view, that needs to be 7829 -- frozen. This must be done explicitly because the two views share 7830 -- the freeze node, and the underlying full view is not visible when 7831 -- the freeze node is analyzed. 7832 7833 elsif Is_Private_Type (Def_Id) 7834 and then Is_Derived_Type (Def_Id) 7835 and then Present (Full_View (Def_Id)) 7836 and then Is_Itype (Full_View (Def_Id)) 7837 and then Has_Private_Declaration (Full_View (Def_Id)) 7838 and then Freeze_Node (Full_View (Def_Id)) = N 7839 then 7840 Set_Entity (N, Full_View (Def_Id)); 7841 Result := Freeze_Type (N); 7842 Set_Entity (N, Def_Id); 7843 7844 -- All other types require no expander action. There are such cases 7845 -- (e.g. task types and protected types). In such cases, the freeze 7846 -- nodes are there for use by Gigi. 7847 7848 end if; 7849 7850 -- Complete the initialization of all pending access types' finalization 7851 -- masters now that the designated type has been is frozen and primitive 7852 -- Finalize_Address generated. 7853 7854 Process_Pending_Access_Types (Def_Id); 7855 Freeze_Stream_Operations (N, Def_Id); 7856 7857 Ghost_Mode := Save_Ghost_Mode; 7858 return Result; 7859 7860 exception 7861 when RE_Not_Available => 7862 Ghost_Mode := Save_Ghost_Mode; 7863 return False; 7864 end Freeze_Type; 7865 7866 ------------------------- 7867 -- Get_Simple_Init_Val -- 7868 ------------------------- 7869 7870 function Get_Simple_Init_Val 7871 (T : Entity_Id; 7872 N : Node_Id; 7873 Size : Uint := No_Uint) return Node_Id 7874 is 7875 Loc : constant Source_Ptr := Sloc (N); 7876 Val : Node_Id; 7877 Result : Node_Id; 7878 Val_RE : RE_Id; 7879 7880 Size_To_Use : Uint; 7881 -- This is the size to be used for computation of the appropriate 7882 -- initial value for the Normalize_Scalars and Initialize_Scalars case. 7883 7884 IV_Attribute : constant Boolean := 7885 Nkind (N) = N_Attribute_Reference 7886 and then Attribute_Name (N) = Name_Invalid_Value; 7887 7888 Lo_Bound : Uint; 7889 Hi_Bound : Uint; 7890 -- These are the values computed by the procedure Check_Subtype_Bounds 7891 7892 procedure Check_Subtype_Bounds; 7893 -- This procedure examines the subtype T, and its ancestor subtypes and 7894 -- derived types to determine the best known information about the 7895 -- bounds of the subtype. After the call Lo_Bound is set either to 7896 -- No_Uint if no information can be determined, or to a value which 7897 -- represents a known low bound, i.e. a valid value of the subtype can 7898 -- not be less than this value. Hi_Bound is similarly set to a known 7899 -- high bound (valid value cannot be greater than this). 7900 7901 -------------------------- 7902 -- Check_Subtype_Bounds -- 7903 -------------------------- 7904 7905 procedure Check_Subtype_Bounds is 7906 ST1 : Entity_Id; 7907 ST2 : Entity_Id; 7908 Lo : Node_Id; 7909 Hi : Node_Id; 7910 Loval : Uint; 7911 Hival : Uint; 7912 7913 begin 7914 Lo_Bound := No_Uint; 7915 Hi_Bound := No_Uint; 7916 7917 -- Loop to climb ancestor subtypes and derived types 7918 7919 ST1 := T; 7920 loop 7921 if not Is_Discrete_Type (ST1) then 7922 return; 7923 end if; 7924 7925 Lo := Type_Low_Bound (ST1); 7926 Hi := Type_High_Bound (ST1); 7927 7928 if Compile_Time_Known_Value (Lo) then 7929 Loval := Expr_Value (Lo); 7930 7931 if Lo_Bound = No_Uint or else Lo_Bound < Loval then 7932 Lo_Bound := Loval; 7933 end if; 7934 end if; 7935 7936 if Compile_Time_Known_Value (Hi) then 7937 Hival := Expr_Value (Hi); 7938 7939 if Hi_Bound = No_Uint or else Hi_Bound > Hival then 7940 Hi_Bound := Hival; 7941 end if; 7942 end if; 7943 7944 ST2 := Ancestor_Subtype (ST1); 7945 7946 if No (ST2) then 7947 ST2 := Etype (ST1); 7948 end if; 7949 7950 exit when ST1 = ST2; 7951 ST1 := ST2; 7952 end loop; 7953 end Check_Subtype_Bounds; 7954 7955 -- Start of processing for Get_Simple_Init_Val 7956 7957 begin 7958 -- For a private type, we should always have an underlying type (because 7959 -- this was already checked in Needs_Simple_Initialization). What we do 7960 -- is to get the value for the underlying type and then do an unchecked 7961 -- conversion to the private type. 7962 7963 if Is_Private_Type (T) then 7964 Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size); 7965 7966 -- A special case, if the underlying value is null, then qualify it 7967 -- with the underlying type, so that the null is properly typed. 7968 -- Similarly, if it is an aggregate it must be qualified, because an 7969 -- unchecked conversion does not provide a context for it. 7970 7971 if Nkind_In (Val, N_Null, N_Aggregate) then 7972 Val := 7973 Make_Qualified_Expression (Loc, 7974 Subtype_Mark => 7975 New_Occurrence_Of (Underlying_Type (T), Loc), 7976 Expression => Val); 7977 end if; 7978 7979 Result := Unchecked_Convert_To (T, Val); 7980 7981 -- Don't truncate result (important for Initialize/Normalize_Scalars) 7982 7983 if Nkind (Result) = N_Unchecked_Type_Conversion 7984 and then Is_Scalar_Type (Underlying_Type (T)) 7985 then 7986 Set_No_Truncation (Result); 7987 end if; 7988 7989 return Result; 7990 7991 -- Scalars with Default_Value aspect. The first subtype may now be 7992 -- private, so retrieve value from underlying type. 7993 7994 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then 7995 if Is_Private_Type (First_Subtype (T)) then 7996 return Unchecked_Convert_To (T, 7997 Default_Aspect_Value (Full_View (First_Subtype (T)))); 7998 else 7999 return 8000 Convert_To (T, Default_Aspect_Value (First_Subtype (T))); 8001 end if; 8002 8003 -- Otherwise, for scalars, we must have normalize/initialize scalars 8004 -- case, or if the node N is an 'Invalid_Value attribute node. 8005 8006 elsif Is_Scalar_Type (T) then 8007 pragma Assert (Init_Or_Norm_Scalars or IV_Attribute); 8008 8009 -- Compute size of object. If it is given by the caller, we can use 8010 -- it directly, otherwise we use Esize (T) as an estimate. As far as 8011 -- we know this covers all cases correctly. 8012 8013 if Size = No_Uint or else Size <= Uint_0 then 8014 Size_To_Use := UI_Max (Uint_1, Esize (T)); 8015 else 8016 Size_To_Use := Size; 8017 end if; 8018 8019 -- Maximum size to use is 64 bits, since we will create values of 8020 -- type Unsigned_64 and the range must fit this type. 8021 8022 if Size_To_Use /= No_Uint and then Size_To_Use > Uint_64 then 8023 Size_To_Use := Uint_64; 8024 end if; 8025 8026 -- Check known bounds of subtype 8027 8028 Check_Subtype_Bounds; 8029 8030 -- Processing for Normalize_Scalars case 8031 8032 if Normalize_Scalars and then not IV_Attribute then 8033 8034 -- If zero is invalid, it is a convenient value to use that is 8035 -- for sure an appropriate invalid value in all situations. 8036 8037 if Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then 8038 Val := Make_Integer_Literal (Loc, 0); 8039 8040 -- Cases where all one bits is the appropriate invalid value 8041 8042 -- For modular types, all 1 bits is either invalid or valid. If 8043 -- it is valid, then there is nothing that can be done since there 8044 -- are no invalid values (we ruled out zero already). 8045 8046 -- For signed integer types that have no negative values, either 8047 -- there is room for negative values, or there is not. If there 8048 -- is, then all 1-bits may be interpreted as minus one, which is 8049 -- certainly invalid. Alternatively it is treated as the largest 8050 -- positive value, in which case the observation for modular types 8051 -- still applies. 8052 8053 -- For float types, all 1-bits is a NaN (not a number), which is 8054 -- certainly an appropriately invalid value. 8055 8056 elsif Is_Unsigned_Type (T) 8057 or else Is_Floating_Point_Type (T) 8058 or else Is_Enumeration_Type (T) 8059 then 8060 Val := Make_Integer_Literal (Loc, 2 ** Size_To_Use - 1); 8061 8062 -- Resolve as Unsigned_64, because the largest number we can 8063 -- generate is out of range of universal integer. 8064 8065 Analyze_And_Resolve (Val, RTE (RE_Unsigned_64)); 8066 8067 -- Case of signed types 8068 8069 else 8070 declare 8071 Signed_Size : constant Uint := 8072 UI_Min (Uint_63, Size_To_Use - 1); 8073 8074 begin 8075 -- Normally we like to use the most negative number. The one 8076 -- exception is when this number is in the known subtype 8077 -- range and the largest positive number is not in the known 8078 -- subtype range. 8079 8080 -- For this exceptional case, use largest positive value 8081 8082 if Lo_Bound /= No_Uint and then Hi_Bound /= No_Uint 8083 and then Lo_Bound <= (-(2 ** Signed_Size)) 8084 and then Hi_Bound < 2 ** Signed_Size 8085 then 8086 Val := Make_Integer_Literal (Loc, 2 ** Signed_Size - 1); 8087 8088 -- Normal case of largest negative value 8089 8090 else 8091 Val := Make_Integer_Literal (Loc, -(2 ** Signed_Size)); 8092 end if; 8093 end; 8094 end if; 8095 8096 -- Here for Initialize_Scalars case (or Invalid_Value attribute used) 8097 8098 else 8099 -- For float types, use float values from System.Scalar_Values 8100 8101 if Is_Floating_Point_Type (T) then 8102 if Root_Type (T) = Standard_Short_Float then 8103 Val_RE := RE_IS_Isf; 8104 elsif Root_Type (T) = Standard_Float then 8105 Val_RE := RE_IS_Ifl; 8106 elsif Root_Type (T) = Standard_Long_Float then 8107 Val_RE := RE_IS_Ilf; 8108 else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); 8109 Val_RE := RE_IS_Ill; 8110 end if; 8111 8112 -- If zero is invalid, use zero values from System.Scalar_Values 8113 8114 elsif Lo_Bound /= No_Uint and then Lo_Bound > Uint_0 then 8115 if Size_To_Use <= 8 then 8116 Val_RE := RE_IS_Iz1; 8117 elsif Size_To_Use <= 16 then 8118 Val_RE := RE_IS_Iz2; 8119 elsif Size_To_Use <= 32 then 8120 Val_RE := RE_IS_Iz4; 8121 else 8122 Val_RE := RE_IS_Iz8; 8123 end if; 8124 8125 -- For unsigned, use unsigned values from System.Scalar_Values 8126 8127 elsif Is_Unsigned_Type (T) then 8128 if Size_To_Use <= 8 then 8129 Val_RE := RE_IS_Iu1; 8130 elsif Size_To_Use <= 16 then 8131 Val_RE := RE_IS_Iu2; 8132 elsif Size_To_Use <= 32 then 8133 Val_RE := RE_IS_Iu4; 8134 else 8135 Val_RE := RE_IS_Iu8; 8136 end if; 8137 8138 -- For signed, use signed values from System.Scalar_Values 8139 8140 else 8141 if Size_To_Use <= 8 then 8142 Val_RE := RE_IS_Is1; 8143 elsif Size_To_Use <= 16 then 8144 Val_RE := RE_IS_Is2; 8145 elsif Size_To_Use <= 32 then 8146 Val_RE := RE_IS_Is4; 8147 else 8148 Val_RE := RE_IS_Is8; 8149 end if; 8150 end if; 8151 8152 Val := New_Occurrence_Of (RTE (Val_RE), Loc); 8153 end if; 8154 8155 -- The final expression is obtained by doing an unchecked conversion 8156 -- of this result to the base type of the required subtype. Use the 8157 -- base type to prevent the unchecked conversion from chopping bits, 8158 -- and then we set Kill_Range_Check to preserve the "bad" value. 8159 8160 Result := Unchecked_Convert_To (Base_Type (T), Val); 8161 8162 -- Ensure result is not truncated, since we want the "bad" bits, and 8163 -- also kill range check on result. 8164 8165 if Nkind (Result) = N_Unchecked_Type_Conversion then 8166 Set_No_Truncation (Result); 8167 Set_Kill_Range_Check (Result, True); 8168 end if; 8169 8170 return Result; 8171 8172 -- String or Wide_[Wide]_String (must have Initialize_Scalars set) 8173 8174 elsif Is_Standard_String_Type (T) then 8175 pragma Assert (Init_Or_Norm_Scalars); 8176 8177 return 8178 Make_Aggregate (Loc, 8179 Component_Associations => New_List ( 8180 Make_Component_Association (Loc, 8181 Choices => New_List ( 8182 Make_Others_Choice (Loc)), 8183 Expression => 8184 Get_Simple_Init_Val 8185 (Component_Type (T), N, Esize (Root_Type (T)))))); 8186 8187 -- Access type is initialized to null 8188 8189 elsif Is_Access_Type (T) then 8190 return Make_Null (Loc); 8191 8192 -- No other possibilities should arise, since we should only be calling 8193 -- Get_Simple_Init_Val if Needs_Simple_Initialization returned True, 8194 -- indicating one of the above cases held. 8195 8196 else 8197 raise Program_Error; 8198 end if; 8199 8200 exception 8201 when RE_Not_Available => 8202 return Empty; 8203 end Get_Simple_Init_Val; 8204 8205 ------------------------------ 8206 -- Has_New_Non_Standard_Rep -- 8207 ------------------------------ 8208 8209 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is 8210 begin 8211 if not Is_Derived_Type (T) then 8212 return Has_Non_Standard_Rep (T) 8213 or else Has_Non_Standard_Rep (Root_Type (T)); 8214 8215 -- If Has_Non_Standard_Rep is not set on the derived type, the 8216 -- representation is fully inherited. 8217 8218 elsif not Has_Non_Standard_Rep (T) then 8219 return False; 8220 8221 else 8222 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); 8223 8224 -- May need a more precise check here: the First_Rep_Item may be a 8225 -- stream attribute, which does not affect the representation of the 8226 -- type ??? 8227 8228 end if; 8229 end Has_New_Non_Standard_Rep; 8230 8231 ---------------- 8232 -- In_Runtime -- 8233 ---------------- 8234 8235 function In_Runtime (E : Entity_Id) return Boolean is 8236 S1 : Entity_Id; 8237 8238 begin 8239 S1 := Scope (E); 8240 while Scope (S1) /= Standard_Standard loop 8241 S1 := Scope (S1); 8242 end loop; 8243 8244 return Is_RTU (S1, System) or else Is_RTU (S1, Ada); 8245 end In_Runtime; 8246 8247 --------------------------------------- 8248 -- Insert_Component_Invariant_Checks -- 8249 --------------------------------------- 8250 8251 procedure Insert_Component_Invariant_Checks 8252 (N : Node_Id; 8253 Typ : Entity_Id; 8254 Proc : Node_Id) 8255 is 8256 Loc : constant Source_Ptr := Sloc (Typ); 8257 Proc_Id : Entity_Id; 8258 8259 begin 8260 if Present (Proc) then 8261 Proc_Id := Defining_Entity (Proc); 8262 8263 if not Has_Invariants (Typ) then 8264 Set_Has_Invariants (Typ); 8265 Set_Is_Invariant_Procedure (Proc_Id); 8266 Set_Invariant_Procedure (Typ, Proc_Id); 8267 Insert_After (N, Proc); 8268 Analyze (Proc); 8269 8270 else 8271 8272 -- Find already created invariant subprogram, insert body of 8273 -- component invariant proc in its body, and add call after 8274 -- other checks. 8275 8276 declare 8277 Bod : Node_Id; 8278 Inv_Id : constant Entity_Id := Invariant_Procedure (Typ); 8279 Call : constant Node_Id := 8280 Make_Procedure_Call_Statement (Sloc (N), 8281 Name => New_Occurrence_Of (Proc_Id, Loc), 8282 Parameter_Associations => 8283 New_List 8284 (New_Occurrence_Of (First_Formal (Inv_Id), Loc))); 8285 8286 begin 8287 -- The invariant body has not been analyzed yet, so we do a 8288 -- sequential search forward, and retrieve it by name. 8289 8290 Bod := Next (N); 8291 while Present (Bod) loop 8292 exit when Nkind (Bod) = N_Subprogram_Body 8293 and then Chars (Defining_Entity (Bod)) = Chars (Inv_Id); 8294 Next (Bod); 8295 end loop; 8296 8297 -- If the body is not found, it is the case of an invariant 8298 -- appearing on a full declaration in a private part, in 8299 -- which case the type has been frozen but the invariant 8300 -- procedure for the composite type not created yet. Create 8301 -- body now. 8302 8303 if No (Bod) then 8304 Build_Invariant_Procedure (Typ, Parent (Current_Scope)); 8305 Bod := Unit_Declaration_Node 8306 (Corresponding_Body (Unit_Declaration_Node (Inv_Id))); 8307 end if; 8308 8309 Append_To (Declarations (Bod), Proc); 8310 Append_To (Statements (Handled_Statement_Sequence (Bod)), Call); 8311 Analyze (Proc); 8312 Analyze (Call); 8313 end; 8314 end if; 8315 end if; 8316 end Insert_Component_Invariant_Checks; 8317 8318 ---------------------------- 8319 -- Initialization_Warning -- 8320 ---------------------------- 8321 8322 procedure Initialization_Warning (E : Entity_Id) is 8323 Warning_Needed : Boolean; 8324 8325 begin 8326 Warning_Needed := False; 8327 8328 if Ekind (Current_Scope) = E_Package 8329 and then Static_Elaboration_Desired (Current_Scope) 8330 then 8331 if Is_Type (E) then 8332 if Is_Record_Type (E) then 8333 if Has_Discriminants (E) 8334 or else Is_Limited_Type (E) 8335 or else Has_Non_Standard_Rep (E) 8336 then 8337 Warning_Needed := True; 8338 8339 else 8340 -- Verify that at least one component has an initialization 8341 -- expression. No need for a warning on a type if all its 8342 -- components have no initialization. 8343 8344 declare 8345 Comp : Entity_Id; 8346 8347 begin 8348 Comp := First_Component (E); 8349 while Present (Comp) loop 8350 if Ekind (Comp) = E_Discriminant 8351 or else 8352 (Nkind (Parent (Comp)) = N_Component_Declaration 8353 and then Present (Expression (Parent (Comp)))) 8354 then 8355 Warning_Needed := True; 8356 exit; 8357 end if; 8358 8359 Next_Component (Comp); 8360 end loop; 8361 end; 8362 end if; 8363 8364 if Warning_Needed then 8365 Error_Msg_N 8366 ("Objects of the type cannot be initialized statically " 8367 & "by default??", Parent (E)); 8368 end if; 8369 end if; 8370 8371 else 8372 Error_Msg_N ("Object cannot be initialized statically??", E); 8373 end if; 8374 end if; 8375 end Initialization_Warning; 8376 8377 ------------------ 8378 -- Init_Formals -- 8379 ------------------ 8380 8381 function Init_Formals (Typ : Entity_Id) return List_Id is 8382 Loc : constant Source_Ptr := Sloc (Typ); 8383 Formals : List_Id; 8384 8385 begin 8386 -- First parameter is always _Init : in out typ. Note that we need this 8387 -- to be in/out because in the case of the task record value, there 8388 -- are default record fields (_Priority, _Size, -Task_Info) that may 8389 -- be referenced in the generated initialization routine. 8390 8391 Formals := New_List ( 8392 Make_Parameter_Specification (Loc, 8393 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), 8394 In_Present => True, 8395 Out_Present => True, 8396 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 8397 8398 -- For task record value, or type that contains tasks, add two more 8399 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain 8400 -- We also add these parameters for the task record type case. 8401 8402 if Has_Task (Typ) 8403 or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) 8404 then 8405 Append_To (Formals, 8406 Make_Parameter_Specification (Loc, 8407 Defining_Identifier => 8408 Make_Defining_Identifier (Loc, Name_uMaster), 8409 Parameter_Type => 8410 New_Occurrence_Of (RTE (RE_Master_Id), Loc))); 8411 8412 -- Add _Chain (not done for sequential elaboration policy, see 8413 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 8414 8415 if Partition_Elaboration_Policy /= 'S' then 8416 Append_To (Formals, 8417 Make_Parameter_Specification (Loc, 8418 Defining_Identifier => 8419 Make_Defining_Identifier (Loc, Name_uChain), 8420 In_Present => True, 8421 Out_Present => True, 8422 Parameter_Type => 8423 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))); 8424 end if; 8425 8426 Append_To (Formals, 8427 Make_Parameter_Specification (Loc, 8428 Defining_Identifier => 8429 Make_Defining_Identifier (Loc, Name_uTask_Name), 8430 In_Present => True, 8431 Parameter_Type => New_Occurrence_Of (Standard_String, Loc))); 8432 end if; 8433 8434 return Formals; 8435 8436 exception 8437 when RE_Not_Available => 8438 return Empty_List; 8439 end Init_Formals; 8440 8441 ------------------------- 8442 -- Init_Secondary_Tags -- 8443 ------------------------- 8444 8445 procedure Init_Secondary_Tags 8446 (Typ : Entity_Id; 8447 Target : Node_Id; 8448 Stmts_List : List_Id; 8449 Fixed_Comps : Boolean := True; 8450 Variable_Comps : Boolean := True) 8451 is 8452 Loc : constant Source_Ptr := Sloc (Target); 8453 8454 -- Inherit the C++ tag of the secondary dispatch table of Typ associated 8455 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. 8456 8457 procedure Initialize_Tag 8458 (Typ : Entity_Id; 8459 Iface : Entity_Id; 8460 Tag_Comp : Entity_Id; 8461 Iface_Tag : Node_Id); 8462 -- Initialize the tag of the secondary dispatch table of Typ associated 8463 -- with Iface. Tag_Comp is the component of Typ that stores Iface_Tag. 8464 -- Compiling under the CPP full ABI compatibility mode, if the ancestor 8465 -- of Typ CPP tagged type we generate code to inherit the contents of 8466 -- the dispatch table directly from the ancestor. 8467 8468 -------------------- 8469 -- Initialize_Tag -- 8470 -------------------- 8471 8472 procedure Initialize_Tag 8473 (Typ : Entity_Id; 8474 Iface : Entity_Id; 8475 Tag_Comp : Entity_Id; 8476 Iface_Tag : Node_Id) 8477 is 8478 Comp_Typ : Entity_Id; 8479 Offset_To_Top_Comp : Entity_Id := Empty; 8480 8481 begin 8482 -- Initialize pointer to secondary DT associated with the interface 8483 8484 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then 8485 Append_To (Stmts_List, 8486 Make_Assignment_Statement (Loc, 8487 Name => 8488 Make_Selected_Component (Loc, 8489 Prefix => New_Copy_Tree (Target), 8490 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), 8491 Expression => 8492 New_Occurrence_Of (Iface_Tag, Loc))); 8493 end if; 8494 8495 Comp_Typ := Scope (Tag_Comp); 8496 8497 -- Initialize the entries of the table of interfaces. We generate a 8498 -- different call when the parent of the type has variable size 8499 -- components. 8500 8501 if Comp_Typ /= Etype (Comp_Typ) 8502 and then Is_Variable_Size_Record (Etype (Comp_Typ)) 8503 and then Chars (Tag_Comp) /= Name_uTag 8504 then 8505 pragma Assert (Present (DT_Offset_To_Top_Func (Tag_Comp))); 8506 8507 -- Issue error if Set_Dynamic_Offset_To_Top is not available in a 8508 -- configurable run-time environment. 8509 8510 if not RTE_Available (RE_Set_Dynamic_Offset_To_Top) then 8511 Error_Msg_CRT 8512 ("variable size record with interface types", Typ); 8513 return; 8514 end if; 8515 8516 -- Generate: 8517 -- Set_Dynamic_Offset_To_Top 8518 -- (This => Init, 8519 -- Interface_T => Iface'Tag, 8520 -- Offset_Value => n, 8521 -- Offset_Func => Fn'Address) 8522 8523 Append_To (Stmts_List, 8524 Make_Procedure_Call_Statement (Loc, 8525 Name => 8526 New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), 8527 Parameter_Associations => New_List ( 8528 Make_Attribute_Reference (Loc, 8529 Prefix => New_Copy_Tree (Target), 8530 Attribute_Name => Name_Address), 8531 8532 Unchecked_Convert_To (RTE (RE_Tag), 8533 New_Occurrence_Of 8534 (Node (First_Elmt (Access_Disp_Table (Iface))), 8535 Loc)), 8536 8537 Unchecked_Convert_To 8538 (RTE (RE_Storage_Offset), 8539 Make_Attribute_Reference (Loc, 8540 Prefix => 8541 Make_Selected_Component (Loc, 8542 Prefix => New_Copy_Tree (Target), 8543 Selector_Name => 8544 New_Occurrence_Of (Tag_Comp, Loc)), 8545 Attribute_Name => Name_Position)), 8546 8547 Unchecked_Convert_To (RTE (RE_Offset_To_Top_Function_Ptr), 8548 Make_Attribute_Reference (Loc, 8549 Prefix => New_Occurrence_Of 8550 (DT_Offset_To_Top_Func (Tag_Comp), Loc), 8551 Attribute_Name => Name_Address))))); 8552 8553 -- In this case the next component stores the value of the offset 8554 -- to the top. 8555 8556 Offset_To_Top_Comp := Next_Entity (Tag_Comp); 8557 pragma Assert (Present (Offset_To_Top_Comp)); 8558 8559 Append_To (Stmts_List, 8560 Make_Assignment_Statement (Loc, 8561 Name => 8562 Make_Selected_Component (Loc, 8563 Prefix => New_Copy_Tree (Target), 8564 Selector_Name => 8565 New_Occurrence_Of (Offset_To_Top_Comp, Loc)), 8566 8567 Expression => 8568 Make_Attribute_Reference (Loc, 8569 Prefix => 8570 Make_Selected_Component (Loc, 8571 Prefix => New_Copy_Tree (Target), 8572 Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), 8573 Attribute_Name => Name_Position))); 8574 8575 -- Normal case: No discriminants in the parent type 8576 8577 else 8578 -- Don't need to set any value if this interface shares the 8579 -- primary dispatch table. 8580 8581 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then 8582 Append_To (Stmts_List, 8583 Build_Set_Static_Offset_To_Top (Loc, 8584 Iface_Tag => New_Occurrence_Of (Iface_Tag, Loc), 8585 Offset_Value => 8586 Unchecked_Convert_To (RTE (RE_Storage_Offset), 8587 Make_Attribute_Reference (Loc, 8588 Prefix => 8589 Make_Selected_Component (Loc, 8590 Prefix => New_Copy_Tree (Target), 8591 Selector_Name => 8592 New_Occurrence_Of (Tag_Comp, Loc)), 8593 Attribute_Name => Name_Position)))); 8594 end if; 8595 8596 -- Generate: 8597 -- Register_Interface_Offset 8598 -- (This => Init, 8599 -- Interface_T => Iface'Tag, 8600 -- Is_Constant => True, 8601 -- Offset_Value => n, 8602 -- Offset_Func => null); 8603 8604 if RTE_Available (RE_Register_Interface_Offset) then 8605 Append_To (Stmts_List, 8606 Make_Procedure_Call_Statement (Loc, 8607 Name => 8608 New_Occurrence_Of 8609 (RTE (RE_Register_Interface_Offset), Loc), 8610 Parameter_Associations => New_List ( 8611 Make_Attribute_Reference (Loc, 8612 Prefix => New_Copy_Tree (Target), 8613 Attribute_Name => Name_Address), 8614 8615 Unchecked_Convert_To (RTE (RE_Tag), 8616 New_Occurrence_Of 8617 (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)), 8618 8619 New_Occurrence_Of (Standard_True, Loc), 8620 8621 Unchecked_Convert_To (RTE (RE_Storage_Offset), 8622 Make_Attribute_Reference (Loc, 8623 Prefix => 8624 Make_Selected_Component (Loc, 8625 Prefix => New_Copy_Tree (Target), 8626 Selector_Name => 8627 New_Occurrence_Of (Tag_Comp, Loc)), 8628 Attribute_Name => Name_Position)), 8629 8630 Make_Null (Loc)))); 8631 end if; 8632 end if; 8633 end Initialize_Tag; 8634 8635 -- Local variables 8636 8637 Full_Typ : Entity_Id; 8638 Ifaces_List : Elist_Id; 8639 Ifaces_Comp_List : Elist_Id; 8640 Ifaces_Tag_List : Elist_Id; 8641 Iface_Elmt : Elmt_Id; 8642 Iface_Comp_Elmt : Elmt_Id; 8643 Iface_Tag_Elmt : Elmt_Id; 8644 Tag_Comp : Node_Id; 8645 In_Variable_Pos : Boolean; 8646 8647 -- Start of processing for Init_Secondary_Tags 8648 8649 begin 8650 -- Handle private types 8651 8652 if Present (Full_View (Typ)) then 8653 Full_Typ := Full_View (Typ); 8654 else 8655 Full_Typ := Typ; 8656 end if; 8657 8658 Collect_Interfaces_Info 8659 (Full_Typ, Ifaces_List, Ifaces_Comp_List, Ifaces_Tag_List); 8660 8661 Iface_Elmt := First_Elmt (Ifaces_List); 8662 Iface_Comp_Elmt := First_Elmt (Ifaces_Comp_List); 8663 Iface_Tag_Elmt := First_Elmt (Ifaces_Tag_List); 8664 while Present (Iface_Elmt) loop 8665 Tag_Comp := Node (Iface_Comp_Elmt); 8666 8667 -- Check if parent of record type has variable size components 8668 8669 In_Variable_Pos := Scope (Tag_Comp) /= Etype (Scope (Tag_Comp)) 8670 and then Is_Variable_Size_Record (Etype (Scope (Tag_Comp))); 8671 8672 -- If we are compiling under the CPP full ABI compatibility mode and 8673 -- the ancestor is a CPP_Pragma tagged type then we generate code to 8674 -- initialize the secondary tag components from tags that reference 8675 -- secondary tables filled with copy of parent slots. 8676 8677 if Is_CPP_Class (Root_Type (Full_Typ)) then 8678 8679 -- Reject interface components located at variable offset in 8680 -- C++ derivations. This is currently unsupported. 8681 8682 if not Fixed_Comps and then In_Variable_Pos then 8683 8684 -- Locate the first dynamic component of the record. Done to 8685 -- improve the text of the warning. 8686 8687 declare 8688 Comp : Entity_Id; 8689 Comp_Typ : Entity_Id; 8690 8691 begin 8692 Comp := First_Entity (Typ); 8693 while Present (Comp) loop 8694 Comp_Typ := Etype (Comp); 8695 8696 if Ekind (Comp) /= E_Discriminant 8697 and then not Is_Tag (Comp) 8698 then 8699 exit when 8700 (Is_Record_Type (Comp_Typ) 8701 and then 8702 Is_Variable_Size_Record (Base_Type (Comp_Typ))) 8703 or else 8704 (Is_Array_Type (Comp_Typ) 8705 and then Is_Variable_Size_Array (Comp_Typ)); 8706 end if; 8707 8708 Next_Entity (Comp); 8709 end loop; 8710 8711 pragma Assert (Present (Comp)); 8712 Error_Msg_Node_2 := Comp; 8713 Error_Msg_NE 8714 ("parent type & with dynamic component & cannot be parent" 8715 & " of 'C'P'P derivation if new interfaces are present", 8716 Typ, Scope (Original_Record_Component (Comp))); 8717 8718 Error_Msg_Sloc := 8719 Sloc (Scope (Original_Record_Component (Comp))); 8720 Error_Msg_NE 8721 ("type derived from 'C'P'P type & defined #", 8722 Typ, Scope (Original_Record_Component (Comp))); 8723 8724 -- Avoid duplicated warnings 8725 8726 exit; 8727 end; 8728 8729 -- Initialize secondary tags 8730 8731 else 8732 Append_To (Stmts_List, 8733 Make_Assignment_Statement (Loc, 8734 Name => 8735 Make_Selected_Component (Loc, 8736 Prefix => New_Copy_Tree (Target), 8737 Selector_Name => 8738 New_Occurrence_Of (Node (Iface_Comp_Elmt), Loc)), 8739 Expression => 8740 New_Occurrence_Of (Node (Iface_Tag_Elmt), Loc))); 8741 end if; 8742 8743 -- Otherwise generate code to initialize the tag 8744 8745 else 8746 if (In_Variable_Pos and then Variable_Comps) 8747 or else (not In_Variable_Pos and then Fixed_Comps) 8748 then 8749 Initialize_Tag (Full_Typ, 8750 Iface => Node (Iface_Elmt), 8751 Tag_Comp => Tag_Comp, 8752 Iface_Tag => Node (Iface_Tag_Elmt)); 8753 end if; 8754 end if; 8755 8756 Next_Elmt (Iface_Elmt); 8757 Next_Elmt (Iface_Comp_Elmt); 8758 Next_Elmt (Iface_Tag_Elmt); 8759 end loop; 8760 end Init_Secondary_Tags; 8761 8762 ------------------------ 8763 -- Is_User_Defined_Eq -- 8764 ------------------------ 8765 8766 function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is 8767 begin 8768 return Chars (Prim) = Name_Op_Eq 8769 and then Etype (First_Formal (Prim)) = 8770 Etype (Next_Formal (First_Formal (Prim))) 8771 and then Base_Type (Etype (Prim)) = Standard_Boolean; 8772 end Is_User_Defined_Equality; 8773 8774 ---------------------------------------- 8775 -- Make_Controlling_Function_Wrappers -- 8776 ---------------------------------------- 8777 8778 procedure Make_Controlling_Function_Wrappers 8779 (Tag_Typ : Entity_Id; 8780 Decl_List : out List_Id; 8781 Body_List : out List_Id) 8782 is 8783 Loc : constant Source_Ptr := Sloc (Tag_Typ); 8784 Prim_Elmt : Elmt_Id; 8785 Subp : Entity_Id; 8786 Actual_List : List_Id; 8787 Formal_List : List_Id; 8788 Formal : Entity_Id; 8789 Par_Formal : Entity_Id; 8790 Formal_Node : Node_Id; 8791 Func_Body : Node_Id; 8792 Func_Decl : Node_Id; 8793 Func_Spec : Node_Id; 8794 Return_Stmt : Node_Id; 8795 8796 begin 8797 Decl_List := New_List; 8798 Body_List := New_List; 8799 8800 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 8801 while Present (Prim_Elmt) loop 8802 Subp := Node (Prim_Elmt); 8803 8804 -- If a primitive function with a controlling result of the type has 8805 -- not been overridden by the user, then we must create a wrapper 8806 -- function here that effectively overrides it and invokes the 8807 -- (non-abstract) parent function. This can only occur for a null 8808 -- extension. Note that functions with anonymous controlling access 8809 -- results don't qualify and must be overridden. We also exclude 8810 -- Input attributes, since each type will have its own version of 8811 -- Input constructed by the expander. The test for Comes_From_Source 8812 -- is needed to distinguish inherited operations from renamings 8813 -- (which also have Alias set). We exclude internal entities with 8814 -- Interface_Alias to avoid generating duplicated wrappers since 8815 -- the primitive which covers the interface is also available in 8816 -- the list of primitive operations. 8817 8818 -- The function may be abstract, or require_Overriding may be set 8819 -- for it, because tests for null extensions may already have reset 8820 -- the Is_Abstract_Subprogram_Flag. If Requires_Overriding is not 8821 -- set, functions that need wrappers are recognized by having an 8822 -- alias that returns the parent type. 8823 8824 if Comes_From_Source (Subp) 8825 or else No (Alias (Subp)) 8826 or else Present (Interface_Alias (Subp)) 8827 or else Ekind (Subp) /= E_Function 8828 or else not Has_Controlling_Result (Subp) 8829 or else Is_Access_Type (Etype (Subp)) 8830 or else Is_Abstract_Subprogram (Alias (Subp)) 8831 or else Is_TSS (Subp, TSS_Stream_Input) 8832 then 8833 goto Next_Prim; 8834 8835 elsif Is_Abstract_Subprogram (Subp) 8836 or else Requires_Overriding (Subp) 8837 or else 8838 (Is_Null_Extension (Etype (Subp)) 8839 and then Etype (Alias (Subp)) /= Etype (Subp)) 8840 then 8841 Formal_List := No_List; 8842 Formal := First_Formal (Subp); 8843 8844 if Present (Formal) then 8845 Formal_List := New_List; 8846 8847 while Present (Formal) loop 8848 Append 8849 (Make_Parameter_Specification 8850 (Loc, 8851 Defining_Identifier => 8852 Make_Defining_Identifier (Sloc (Formal), 8853 Chars => Chars (Formal)), 8854 In_Present => In_Present (Parent (Formal)), 8855 Out_Present => Out_Present (Parent (Formal)), 8856 Null_Exclusion_Present => 8857 Null_Exclusion_Present (Parent (Formal)), 8858 Parameter_Type => 8859 New_Occurrence_Of (Etype (Formal), Loc), 8860 Expression => 8861 New_Copy_Tree (Expression (Parent (Formal)))), 8862 Formal_List); 8863 8864 Next_Formal (Formal); 8865 end loop; 8866 end if; 8867 8868 Func_Spec := 8869 Make_Function_Specification (Loc, 8870 Defining_Unit_Name => 8871 Make_Defining_Identifier (Loc, 8872 Chars => Chars (Subp)), 8873 Parameter_Specifications => Formal_List, 8874 Result_Definition => 8875 New_Occurrence_Of (Etype (Subp), Loc)); 8876 8877 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); 8878 Append_To (Decl_List, Func_Decl); 8879 8880 -- Build a wrapper body that calls the parent function. The body 8881 -- contains a single return statement that returns an extension 8882 -- aggregate whose ancestor part is a call to the parent function, 8883 -- passing the formals as actuals (with any controlling arguments 8884 -- converted to the types of the corresponding formals of the 8885 -- parent function, which might be anonymous access types), and 8886 -- having a null extension. 8887 8888 Formal := First_Formal (Subp); 8889 Par_Formal := First_Formal (Alias (Subp)); 8890 Formal_Node := First (Formal_List); 8891 8892 if Present (Formal) then 8893 Actual_List := New_List; 8894 else 8895 Actual_List := No_List; 8896 end if; 8897 8898 while Present (Formal) loop 8899 if Is_Controlling_Formal (Formal) then 8900 Append_To (Actual_List, 8901 Make_Type_Conversion (Loc, 8902 Subtype_Mark => 8903 New_Occurrence_Of (Etype (Par_Formal), Loc), 8904 Expression => 8905 New_Occurrence_Of 8906 (Defining_Identifier (Formal_Node), Loc))); 8907 else 8908 Append_To 8909 (Actual_List, 8910 New_Occurrence_Of 8911 (Defining_Identifier (Formal_Node), Loc)); 8912 end if; 8913 8914 Next_Formal (Formal); 8915 Next_Formal (Par_Formal); 8916 Next (Formal_Node); 8917 end loop; 8918 8919 Return_Stmt := 8920 Make_Simple_Return_Statement (Loc, 8921 Expression => 8922 Make_Extension_Aggregate (Loc, 8923 Ancestor_Part => 8924 Make_Function_Call (Loc, 8925 Name => 8926 New_Occurrence_Of (Alias (Subp), Loc), 8927 Parameter_Associations => Actual_List), 8928 Null_Record_Present => True)); 8929 8930 Func_Body := 8931 Make_Subprogram_Body (Loc, 8932 Specification => New_Copy_Tree (Func_Spec), 8933 Declarations => Empty_List, 8934 Handled_Statement_Sequence => 8935 Make_Handled_Sequence_Of_Statements (Loc, 8936 Statements => New_List (Return_Stmt))); 8937 8938 Set_Defining_Unit_Name 8939 (Specification (Func_Body), 8940 Make_Defining_Identifier (Loc, Chars (Subp))); 8941 8942 Append_To (Body_List, Func_Body); 8943 8944 -- Replace the inherited function with the wrapper function in the 8945 -- primitive operations list. We add the minimum decoration needed 8946 -- to override interface primitives. 8947 8948 Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function); 8949 8950 Override_Dispatching_Operation 8951 (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec), 8952 Is_Wrapper => True); 8953 end if; 8954 8955 <<Next_Prim>> 8956 Next_Elmt (Prim_Elmt); 8957 end loop; 8958 end Make_Controlling_Function_Wrappers; 8959 8960 ------------------- 8961 -- Make_Eq_Body -- 8962 ------------------- 8963 8964 function Make_Eq_Body 8965 (Typ : Entity_Id; 8966 Eq_Name : Name_Id) return Node_Id 8967 is 8968 Loc : constant Source_Ptr := Sloc (Parent (Typ)); 8969 Decl : Node_Id; 8970 Def : constant Node_Id := Parent (Typ); 8971 Stmts : constant List_Id := New_List; 8972 Variant_Case : Boolean := Has_Discriminants (Typ); 8973 Comps : Node_Id := Empty; 8974 Typ_Def : Node_Id := Type_Definition (Def); 8975 8976 begin 8977 Decl := 8978 Predef_Spec_Or_Body (Loc, 8979 Tag_Typ => Typ, 8980 Name => Eq_Name, 8981 Profile => New_List ( 8982 Make_Parameter_Specification (Loc, 8983 Defining_Identifier => 8984 Make_Defining_Identifier (Loc, Name_X), 8985 Parameter_Type => New_Occurrence_Of (Typ, Loc)), 8986 8987 Make_Parameter_Specification (Loc, 8988 Defining_Identifier => 8989 Make_Defining_Identifier (Loc, Name_Y), 8990 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 8991 8992 Ret_Type => Standard_Boolean, 8993 For_Body => True); 8994 8995 if Variant_Case then 8996 if Nkind (Typ_Def) = N_Derived_Type_Definition then 8997 Typ_Def := Record_Extension_Part (Typ_Def); 8998 end if; 8999 9000 if Present (Typ_Def) then 9001 Comps := Component_List (Typ_Def); 9002 end if; 9003 9004 Variant_Case := 9005 Present (Comps) and then Present (Variant_Part (Comps)); 9006 end if; 9007 9008 if Variant_Case then 9009 Append_To (Stmts, 9010 Make_Eq_If (Typ, Discriminant_Specifications (Def))); 9011 Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); 9012 Append_To (Stmts, 9013 Make_Simple_Return_Statement (Loc, 9014 Expression => New_Occurrence_Of (Standard_True, Loc))); 9015 9016 else 9017 Append_To (Stmts, 9018 Make_Simple_Return_Statement (Loc, 9019 Expression => 9020 Expand_Record_Equality 9021 (Typ, 9022 Typ => Typ, 9023 Lhs => Make_Identifier (Loc, Name_X), 9024 Rhs => Make_Identifier (Loc, Name_Y), 9025 Bodies => Declarations (Decl)))); 9026 end if; 9027 9028 Set_Handled_Statement_Sequence 9029 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 9030 return Decl; 9031 end Make_Eq_Body; 9032 9033 ------------------ 9034 -- Make_Eq_Case -- 9035 ------------------ 9036 9037 -- <Make_Eq_If shared components> 9038 9039 -- case X.D1 is 9040 -- when V1 => <Make_Eq_Case> on subcomponents 9041 -- ... 9042 -- when Vn => <Make_Eq_Case> on subcomponents 9043 -- end case; 9044 9045 function Make_Eq_Case 9046 (E : Entity_Id; 9047 CL : Node_Id; 9048 Discrs : Elist_Id := New_Elmt_List) return List_Id 9049 is 9050 Loc : constant Source_Ptr := Sloc (E); 9051 Result : constant List_Id := New_List; 9052 Variant : Node_Id; 9053 Alt_List : List_Id; 9054 9055 function Corresponding_Formal (C : Node_Id) return Entity_Id; 9056 -- Given the discriminant that controls a given variant of an unchecked 9057 -- union, find the formal of the equality function that carries the 9058 -- inferred value of the discriminant. 9059 9060 function External_Name (E : Entity_Id) return Name_Id; 9061 -- The value of a given discriminant is conveyed in the corresponding 9062 -- formal parameter of the equality routine. The name of this formal 9063 -- parameter carries a one-character suffix which is removed here. 9064 9065 -------------------------- 9066 -- Corresponding_Formal -- 9067 -------------------------- 9068 9069 function Corresponding_Formal (C : Node_Id) return Entity_Id is 9070 Discr : constant Entity_Id := Entity (Name (Variant_Part (C))); 9071 Elm : Elmt_Id; 9072 9073 begin 9074 Elm := First_Elmt (Discrs); 9075 while Present (Elm) loop 9076 if Chars (Discr) = External_Name (Node (Elm)) then 9077 return Node (Elm); 9078 end if; 9079 9080 Next_Elmt (Elm); 9081 end loop; 9082 9083 -- A formal of the proper name must be found 9084 9085 raise Program_Error; 9086 end Corresponding_Formal; 9087 9088 ------------------- 9089 -- External_Name -- 9090 ------------------- 9091 9092 function External_Name (E : Entity_Id) return Name_Id is 9093 begin 9094 Get_Name_String (Chars (E)); 9095 Name_Len := Name_Len - 1; 9096 return Name_Find; 9097 end External_Name; 9098 9099 -- Start of processing for Make_Eq_Case 9100 9101 begin 9102 Append_To (Result, Make_Eq_If (E, Component_Items (CL))); 9103 9104 if No (Variant_Part (CL)) then 9105 return Result; 9106 end if; 9107 9108 Variant := First_Non_Pragma (Variants (Variant_Part (CL))); 9109 9110 if No (Variant) then 9111 return Result; 9112 end if; 9113 9114 Alt_List := New_List; 9115 while Present (Variant) loop 9116 Append_To (Alt_List, 9117 Make_Case_Statement_Alternative (Loc, 9118 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), 9119 Statements => 9120 Make_Eq_Case (E, Component_List (Variant), Discrs))); 9121 Next_Non_Pragma (Variant); 9122 end loop; 9123 9124 -- If we have an Unchecked_Union, use one of the parameters of the 9125 -- enclosing equality routine that captures the discriminant, to use 9126 -- as the expression in the generated case statement. 9127 9128 if Is_Unchecked_Union (E) then 9129 Append_To (Result, 9130 Make_Case_Statement (Loc, 9131 Expression => 9132 New_Occurrence_Of (Corresponding_Formal (CL), Loc), 9133 Alternatives => Alt_List)); 9134 9135 else 9136 Append_To (Result, 9137 Make_Case_Statement (Loc, 9138 Expression => 9139 Make_Selected_Component (Loc, 9140 Prefix => Make_Identifier (Loc, Name_X), 9141 Selector_Name => New_Copy (Name (Variant_Part (CL)))), 9142 Alternatives => Alt_List)); 9143 end if; 9144 9145 return Result; 9146 end Make_Eq_Case; 9147 9148 ---------------- 9149 -- Make_Eq_If -- 9150 ---------------- 9151 9152 -- Generates: 9153 9154 -- if 9155 -- X.C1 /= Y.C1 9156 -- or else 9157 -- X.C2 /= Y.C2 9158 -- ... 9159 -- then 9160 -- return False; 9161 -- end if; 9162 9163 -- or a null statement if the list L is empty 9164 9165 function Make_Eq_If 9166 (E : Entity_Id; 9167 L : List_Id) return Node_Id 9168 is 9169 Loc : constant Source_Ptr := Sloc (E); 9170 C : Node_Id; 9171 Field_Name : Name_Id; 9172 Cond : Node_Id; 9173 9174 begin 9175 if No (L) then 9176 return Make_Null_Statement (Loc); 9177 9178 else 9179 Cond := Empty; 9180 9181 C := First_Non_Pragma (L); 9182 while Present (C) loop 9183 Field_Name := Chars (Defining_Identifier (C)); 9184 9185 -- The tags must not be compared: they are not part of the value. 9186 -- Ditto for parent interfaces because their equality operator is 9187 -- abstract. 9188 9189 -- Note also that in the following, we use Make_Identifier for 9190 -- the component names. Use of New_Occurrence_Of to identify the 9191 -- components would be incorrect because the wrong entities for 9192 -- discriminants could be picked up in the private type case. 9193 9194 if Field_Name = Name_uParent 9195 and then Is_Interface (Etype (Defining_Identifier (C))) 9196 then 9197 null; 9198 9199 elsif Field_Name /= Name_uTag then 9200 Evolve_Or_Else (Cond, 9201 Make_Op_Ne (Loc, 9202 Left_Opnd => 9203 Make_Selected_Component (Loc, 9204 Prefix => Make_Identifier (Loc, Name_X), 9205 Selector_Name => Make_Identifier (Loc, Field_Name)), 9206 9207 Right_Opnd => 9208 Make_Selected_Component (Loc, 9209 Prefix => Make_Identifier (Loc, Name_Y), 9210 Selector_Name => Make_Identifier (Loc, Field_Name)))); 9211 end if; 9212 9213 Next_Non_Pragma (C); 9214 end loop; 9215 9216 if No (Cond) then 9217 return Make_Null_Statement (Loc); 9218 9219 else 9220 return 9221 Make_Implicit_If_Statement (E, 9222 Condition => Cond, 9223 Then_Statements => New_List ( 9224 Make_Simple_Return_Statement (Loc, 9225 Expression => New_Occurrence_Of (Standard_False, Loc)))); 9226 end if; 9227 end if; 9228 end Make_Eq_If; 9229 9230 ------------------- 9231 -- Make_Neq_Body -- 9232 ------------------- 9233 9234 function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is 9235 9236 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean; 9237 -- Returns true if Prim is a renaming of an unresolved predefined 9238 -- inequality operation. 9239 9240 -------------------------------- 9241 -- Is_Predefined_Neq_Renaming -- 9242 -------------------------------- 9243 9244 function Is_Predefined_Neq_Renaming (Prim : Node_Id) return Boolean is 9245 begin 9246 return Chars (Prim) /= Name_Op_Ne 9247 and then Present (Alias (Prim)) 9248 and then Comes_From_Source (Prim) 9249 and then Is_Intrinsic_Subprogram (Alias (Prim)) 9250 and then Chars (Alias (Prim)) = Name_Op_Ne; 9251 end Is_Predefined_Neq_Renaming; 9252 9253 -- Local variables 9254 9255 Loc : constant Source_Ptr := Sloc (Parent (Tag_Typ)); 9256 Stmts : constant List_Id := New_List; 9257 Decl : Node_Id; 9258 Eq_Prim : Entity_Id; 9259 Left_Op : Entity_Id; 9260 Renaming_Prim : Entity_Id; 9261 Right_Op : Entity_Id; 9262 Target : Entity_Id; 9263 9264 -- Start of processing for Make_Neq_Body 9265 9266 begin 9267 -- For a call on a renaming of a dispatching subprogram that is 9268 -- overridden, if the overriding occurred before the renaming, then 9269 -- the body executed is that of the overriding declaration, even if the 9270 -- overriding declaration is not visible at the place of the renaming; 9271 -- otherwise, the inherited or predefined subprogram is called, see 9272 -- (RM 8.5.4(8)) 9273 9274 -- Stage 1: Search for a renaming of the inequality primitive and also 9275 -- search for an overriding of the equality primitive located before the 9276 -- renaming declaration. 9277 9278 declare 9279 Elmt : Elmt_Id; 9280 Prim : Node_Id; 9281 9282 begin 9283 Eq_Prim := Empty; 9284 Renaming_Prim := Empty; 9285 9286 Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 9287 while Present (Elmt) loop 9288 Prim := Node (Elmt); 9289 9290 if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then 9291 if No (Renaming_Prim) then 9292 pragma Assert (No (Eq_Prim)); 9293 Eq_Prim := Prim; 9294 end if; 9295 9296 elsif Is_Predefined_Neq_Renaming (Prim) then 9297 Renaming_Prim := Prim; 9298 end if; 9299 9300 Next_Elmt (Elmt); 9301 end loop; 9302 end; 9303 9304 -- No further action needed if no renaming was found 9305 9306 if No (Renaming_Prim) then 9307 return Empty; 9308 end if; 9309 9310 -- Stage 2: Replace the renaming declaration by a subprogram declaration 9311 -- (required to add its body) 9312 9313 Decl := Parent (Parent (Renaming_Prim)); 9314 Rewrite (Decl, 9315 Make_Subprogram_Declaration (Loc, 9316 Specification => Specification (Decl))); 9317 Set_Analyzed (Decl); 9318 9319 -- Remove the decoration of intrinsic renaming subprogram 9320 9321 Set_Is_Intrinsic_Subprogram (Renaming_Prim, False); 9322 Set_Convention (Renaming_Prim, Convention_Ada); 9323 Set_Alias (Renaming_Prim, Empty); 9324 Set_Has_Completion (Renaming_Prim, False); 9325 9326 -- Stage 3: Build the corresponding body 9327 9328 Left_Op := First_Formal (Renaming_Prim); 9329 Right_Op := Next_Formal (Left_Op); 9330 9331 Decl := 9332 Predef_Spec_Or_Body (Loc, 9333 Tag_Typ => Tag_Typ, 9334 Name => Chars (Renaming_Prim), 9335 Profile => New_List ( 9336 Make_Parameter_Specification (Loc, 9337 Defining_Identifier => 9338 Make_Defining_Identifier (Loc, Chars (Left_Op)), 9339 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), 9340 9341 Make_Parameter_Specification (Loc, 9342 Defining_Identifier => 9343 Make_Defining_Identifier (Loc, Chars (Right_Op)), 9344 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), 9345 9346 Ret_Type => Standard_Boolean, 9347 For_Body => True); 9348 9349 -- If the overriding of the equality primitive occurred before the 9350 -- renaming, then generate: 9351 9352 -- function <Neq_Name> (X : Y : Typ) return Boolean is 9353 -- begin 9354 -- return not Oeq (X, Y); 9355 -- end; 9356 9357 if Present (Eq_Prim) then 9358 Target := Eq_Prim; 9359 9360 -- Otherwise build a nested subprogram which performs the predefined 9361 -- evaluation of the equality operator. That is, generate: 9362 9363 -- function <Neq_Name> (X : Y : Typ) return Boolean is 9364 -- function Oeq (X : Y) return Boolean is 9365 -- begin 9366 -- <<body of default implementation>> 9367 -- end; 9368 -- begin 9369 -- return not Oeq (X, Y); 9370 -- end; 9371 9372 else 9373 declare 9374 Local_Subp : Node_Id; 9375 begin 9376 Local_Subp := Make_Eq_Body (Tag_Typ, Name_Op_Eq); 9377 Set_Declarations (Decl, New_List (Local_Subp)); 9378 Target := Defining_Entity (Local_Subp); 9379 end; 9380 end if; 9381 9382 Append_To (Stmts, 9383 Make_Simple_Return_Statement (Loc, 9384 Expression => 9385 Make_Op_Not (Loc, 9386 Make_Function_Call (Loc, 9387 Name => New_Occurrence_Of (Target, Loc), 9388 Parameter_Associations => New_List ( 9389 Make_Identifier (Loc, Chars (Left_Op)), 9390 Make_Identifier (Loc, Chars (Right_Op))))))); 9391 9392 Set_Handled_Statement_Sequence 9393 (Decl, Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 9394 return Decl; 9395 end Make_Neq_Body; 9396 9397 ------------------------------- 9398 -- Make_Null_Procedure_Specs -- 9399 ------------------------------- 9400 9401 function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id is 9402 Decl_List : constant List_Id := New_List; 9403 Loc : constant Source_Ptr := Sloc (Tag_Typ); 9404 Formal : Entity_Id; 9405 Formal_List : List_Id; 9406 New_Param_Spec : Node_Id; 9407 Parent_Subp : Entity_Id; 9408 Prim_Elmt : Elmt_Id; 9409 Subp : Entity_Id; 9410 9411 begin 9412 Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 9413 while Present (Prim_Elmt) loop 9414 Subp := Node (Prim_Elmt); 9415 9416 -- If a null procedure inherited from an interface has not been 9417 -- overridden, then we build a null procedure declaration to 9418 -- override the inherited procedure. 9419 9420 Parent_Subp := Alias (Subp); 9421 9422 if Present (Parent_Subp) 9423 and then Is_Null_Interface_Primitive (Parent_Subp) 9424 then 9425 Formal_List := No_List; 9426 Formal := First_Formal (Subp); 9427 9428 if Present (Formal) then 9429 Formal_List := New_List; 9430 9431 while Present (Formal) loop 9432 9433 -- Copy the parameter spec including default expressions 9434 9435 New_Param_Spec := 9436 New_Copy_Tree (Parent (Formal), New_Sloc => Loc); 9437 9438 -- Generate a new defining identifier for the new formal. 9439 -- required because New_Copy_Tree does not duplicate 9440 -- semantic fields (except itypes). 9441 9442 Set_Defining_Identifier (New_Param_Spec, 9443 Make_Defining_Identifier (Sloc (Formal), 9444 Chars => Chars (Formal))); 9445 9446 -- For controlling arguments we must change their 9447 -- parameter type to reference the tagged type (instead 9448 -- of the interface type) 9449 9450 if Is_Controlling_Formal (Formal) then 9451 if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier 9452 then 9453 Set_Parameter_Type (New_Param_Spec, 9454 New_Occurrence_Of (Tag_Typ, Loc)); 9455 9456 else pragma Assert 9457 (Nkind (Parameter_Type (Parent (Formal))) = 9458 N_Access_Definition); 9459 Set_Subtype_Mark (Parameter_Type (New_Param_Spec), 9460 New_Occurrence_Of (Tag_Typ, Loc)); 9461 end if; 9462 end if; 9463 9464 Append (New_Param_Spec, Formal_List); 9465 9466 Next_Formal (Formal); 9467 end loop; 9468 end if; 9469 9470 Append_To (Decl_List, 9471 Make_Subprogram_Declaration (Loc, 9472 Make_Procedure_Specification (Loc, 9473 Defining_Unit_Name => 9474 Make_Defining_Identifier (Loc, Chars (Subp)), 9475 Parameter_Specifications => Formal_List, 9476 Null_Present => True))); 9477 end if; 9478 9479 Next_Elmt (Prim_Elmt); 9480 end loop; 9481 9482 return Decl_List; 9483 end Make_Null_Procedure_Specs; 9484 9485 ------------------------------------- 9486 -- Make_Predefined_Primitive_Specs -- 9487 ------------------------------------- 9488 9489 procedure Make_Predefined_Primitive_Specs 9490 (Tag_Typ : Entity_Id; 9491 Predef_List : out List_Id; 9492 Renamed_Eq : out Entity_Id) 9493 is 9494 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; 9495 -- Returns true if Prim is a renaming of an unresolved predefined 9496 -- equality operation. 9497 9498 ------------------------------- 9499 -- Is_Predefined_Eq_Renaming -- 9500 ------------------------------- 9501 9502 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is 9503 begin 9504 return Chars (Prim) /= Name_Op_Eq 9505 and then Present (Alias (Prim)) 9506 and then Comes_From_Source (Prim) 9507 and then Is_Intrinsic_Subprogram (Alias (Prim)) 9508 and then Chars (Alias (Prim)) = Name_Op_Eq; 9509 end Is_Predefined_Eq_Renaming; 9510 9511 -- Local variables 9512 9513 Loc : constant Source_Ptr := Sloc (Tag_Typ); 9514 Res : constant List_Id := New_List; 9515 Eq_Name : Name_Id := Name_Op_Eq; 9516 Eq_Needed : Boolean; 9517 Eq_Spec : Node_Id; 9518 Prim : Elmt_Id; 9519 9520 Has_Predef_Eq_Renaming : Boolean := False; 9521 -- Set to True if Tag_Typ has a primitive that renames the predefined 9522 -- equality operator. Used to implement (RM 8-5-4(8)). 9523 9524 -- Start of processing for Make_Predefined_Primitive_Specs 9525 9526 begin 9527 Renamed_Eq := Empty; 9528 9529 -- Spec of _Size 9530 9531 Append_To (Res, Predef_Spec_Or_Body (Loc, 9532 Tag_Typ => Tag_Typ, 9533 Name => Name_uSize, 9534 Profile => New_List ( 9535 Make_Parameter_Specification (Loc, 9536 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 9537 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), 9538 9539 Ret_Type => Standard_Long_Long_Integer)); 9540 9541 -- Specs for dispatching stream attributes 9542 9543 declare 9544 Stream_Op_TSS_Names : 9545 constant array (Integer range <>) of TSS_Name_Type := 9546 (TSS_Stream_Read, 9547 TSS_Stream_Write, 9548 TSS_Stream_Input, 9549 TSS_Stream_Output); 9550 9551 begin 9552 for Op in Stream_Op_TSS_Names'Range loop 9553 if Stream_Operation_OK (Tag_Typ, Stream_Op_TSS_Names (Op)) then 9554 Append_To (Res, 9555 Predef_Stream_Attr_Spec (Loc, Tag_Typ, 9556 Stream_Op_TSS_Names (Op))); 9557 end if; 9558 end loop; 9559 end; 9560 9561 -- Spec of "=" is expanded if the type is not limited and if a user 9562 -- defined "=" was not already declared for the non-full view of a 9563 -- private extension 9564 9565 if not Is_Limited_Type (Tag_Typ) then 9566 Eq_Needed := True; 9567 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 9568 while Present (Prim) loop 9569 9570 -- If a primitive is encountered that renames the predefined 9571 -- equality operator before reaching any explicit equality 9572 -- primitive, then we still need to create a predefined equality 9573 -- function, because calls to it can occur via the renaming. A 9574 -- new name is created for the equality to avoid conflicting with 9575 -- any user-defined equality. (Note that this doesn't account for 9576 -- renamings of equality nested within subpackages???) 9577 9578 if Is_Predefined_Eq_Renaming (Node (Prim)) then 9579 Has_Predef_Eq_Renaming := True; 9580 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); 9581 9582 -- User-defined equality 9583 9584 elsif Is_User_Defined_Equality (Node (Prim)) then 9585 if No (Alias (Node (Prim))) 9586 or else Nkind (Unit_Declaration_Node (Node (Prim))) = 9587 N_Subprogram_Renaming_Declaration 9588 then 9589 Eq_Needed := False; 9590 exit; 9591 9592 -- If the parent is not an interface type and has an abstract 9593 -- equality function, the inherited equality is abstract as 9594 -- well, and no body can be created for it. 9595 9596 elsif not Is_Interface (Etype (Tag_Typ)) 9597 and then Present (Alias (Node (Prim))) 9598 and then Is_Abstract_Subprogram (Alias (Node (Prim))) 9599 then 9600 Eq_Needed := False; 9601 exit; 9602 9603 -- If the type has an equality function corresponding with 9604 -- a primitive defined in an interface type, the inherited 9605 -- equality is abstract as well, and no body can be created 9606 -- for it. 9607 9608 elsif Present (Alias (Node (Prim))) 9609 and then Comes_From_Source (Ultimate_Alias (Node (Prim))) 9610 and then 9611 Is_Interface 9612 (Find_Dispatching_Type (Ultimate_Alias (Node (Prim)))) 9613 then 9614 Eq_Needed := False; 9615 exit; 9616 end if; 9617 end if; 9618 9619 Next_Elmt (Prim); 9620 end loop; 9621 9622 -- If a renaming of predefined equality was found but there was no 9623 -- user-defined equality (so Eq_Needed is still true), then set the 9624 -- name back to Name_Op_Eq. But in the case where a user-defined 9625 -- equality was located after such a renaming, then the predefined 9626 -- equality function is still needed, so Eq_Needed must be set back 9627 -- to True. 9628 9629 if Eq_Name /= Name_Op_Eq then 9630 if Eq_Needed then 9631 Eq_Name := Name_Op_Eq; 9632 else 9633 Eq_Needed := True; 9634 end if; 9635 end if; 9636 9637 if Eq_Needed then 9638 Eq_Spec := Predef_Spec_Or_Body (Loc, 9639 Tag_Typ => Tag_Typ, 9640 Name => Eq_Name, 9641 Profile => New_List ( 9642 Make_Parameter_Specification (Loc, 9643 Defining_Identifier => 9644 Make_Defining_Identifier (Loc, Name_X), 9645 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), 9646 9647 Make_Parameter_Specification (Loc, 9648 Defining_Identifier => 9649 Make_Defining_Identifier (Loc, Name_Y), 9650 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), 9651 Ret_Type => Standard_Boolean); 9652 Append_To (Res, Eq_Spec); 9653 9654 if Has_Predef_Eq_Renaming then 9655 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); 9656 9657 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 9658 while Present (Prim) loop 9659 9660 -- Any renamings of equality that appeared before an 9661 -- overriding equality must be updated to refer to the 9662 -- entity for the predefined equality, otherwise calls via 9663 -- the renaming would get incorrectly resolved to call the 9664 -- user-defined equality function. 9665 9666 if Is_Predefined_Eq_Renaming (Node (Prim)) then 9667 Set_Alias (Node (Prim), Renamed_Eq); 9668 9669 -- Exit upon encountering a user-defined equality 9670 9671 elsif Chars (Node (Prim)) = Name_Op_Eq 9672 and then No (Alias (Node (Prim))) 9673 then 9674 exit; 9675 end if; 9676 9677 Next_Elmt (Prim); 9678 end loop; 9679 end if; 9680 end if; 9681 9682 -- Spec for dispatching assignment 9683 9684 Append_To (Res, Predef_Spec_Or_Body (Loc, 9685 Tag_Typ => Tag_Typ, 9686 Name => Name_uAssign, 9687 Profile => New_List ( 9688 Make_Parameter_Specification (Loc, 9689 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 9690 Out_Present => True, 9691 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), 9692 9693 Make_Parameter_Specification (Loc, 9694 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), 9695 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))))); 9696 end if; 9697 9698 -- Ada 2005: Generate declarations for the following primitive 9699 -- operations for limited interfaces and synchronized types that 9700 -- implement a limited interface. 9701 9702 -- Disp_Asynchronous_Select 9703 -- Disp_Conditional_Select 9704 -- Disp_Get_Prim_Op_Kind 9705 -- Disp_Get_Task_Id 9706 -- Disp_Requeue 9707 -- Disp_Timed_Select 9708 9709 -- Disable the generation of these bodies if No_Dispatching_Calls, 9710 -- Ravenscar or ZFP is active. 9711 9712 if Ada_Version >= Ada_2005 9713 and then not Restriction_Active (No_Dispatching_Calls) 9714 and then not Restriction_Active (No_Select_Statements) 9715 and then RTE_Available (RE_Select_Specific_Data) 9716 then 9717 -- These primitives are defined abstract in interface types 9718 9719 if Is_Interface (Tag_Typ) 9720 and then Is_Limited_Record (Tag_Typ) 9721 then 9722 Append_To (Res, 9723 Make_Abstract_Subprogram_Declaration (Loc, 9724 Specification => 9725 Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); 9726 9727 Append_To (Res, 9728 Make_Abstract_Subprogram_Declaration (Loc, 9729 Specification => 9730 Make_Disp_Conditional_Select_Spec (Tag_Typ))); 9731 9732 Append_To (Res, 9733 Make_Abstract_Subprogram_Declaration (Loc, 9734 Specification => 9735 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); 9736 9737 Append_To (Res, 9738 Make_Abstract_Subprogram_Declaration (Loc, 9739 Specification => 9740 Make_Disp_Get_Task_Id_Spec (Tag_Typ))); 9741 9742 Append_To (Res, 9743 Make_Abstract_Subprogram_Declaration (Loc, 9744 Specification => 9745 Make_Disp_Requeue_Spec (Tag_Typ))); 9746 9747 Append_To (Res, 9748 Make_Abstract_Subprogram_Declaration (Loc, 9749 Specification => 9750 Make_Disp_Timed_Select_Spec (Tag_Typ))); 9751 9752 -- If ancestor is an interface type, declare non-abstract primitives 9753 -- to override the abstract primitives of the interface type. 9754 9755 -- In VM targets we define these primitives in all root tagged types 9756 -- that are not interface types. Done because in VM targets we don't 9757 -- have secondary dispatch tables and any derivation of Tag_Typ may 9758 -- cover limited interfaces (which always have these primitives since 9759 -- they may be ancestors of synchronized interface types). 9760 9761 elsif (not Is_Interface (Tag_Typ) 9762 and then Is_Interface (Etype (Tag_Typ)) 9763 and then Is_Limited_Record (Etype (Tag_Typ))) 9764 or else 9765 (Is_Concurrent_Record_Type (Tag_Typ) 9766 and then Has_Interfaces (Tag_Typ)) 9767 or else 9768 (not Tagged_Type_Expansion 9769 and then not Is_Interface (Tag_Typ) 9770 and then Tag_Typ = Root_Type (Tag_Typ)) 9771 then 9772 Append_To (Res, 9773 Make_Subprogram_Declaration (Loc, 9774 Specification => 9775 Make_Disp_Asynchronous_Select_Spec (Tag_Typ))); 9776 9777 Append_To (Res, 9778 Make_Subprogram_Declaration (Loc, 9779 Specification => 9780 Make_Disp_Conditional_Select_Spec (Tag_Typ))); 9781 9782 Append_To (Res, 9783 Make_Subprogram_Declaration (Loc, 9784 Specification => 9785 Make_Disp_Get_Prim_Op_Kind_Spec (Tag_Typ))); 9786 9787 Append_To (Res, 9788 Make_Subprogram_Declaration (Loc, 9789 Specification => 9790 Make_Disp_Get_Task_Id_Spec (Tag_Typ))); 9791 9792 Append_To (Res, 9793 Make_Subprogram_Declaration (Loc, 9794 Specification => 9795 Make_Disp_Requeue_Spec (Tag_Typ))); 9796 9797 Append_To (Res, 9798 Make_Subprogram_Declaration (Loc, 9799 Specification => 9800 Make_Disp_Timed_Select_Spec (Tag_Typ))); 9801 end if; 9802 end if; 9803 9804 -- All tagged types receive their own Deep_Adjust and Deep_Finalize 9805 -- regardless of whether they are controlled or may contain controlled 9806 -- components. 9807 9808 -- Do not generate the routines if finalization is disabled 9809 9810 if Restriction_Active (No_Finalization) then 9811 null; 9812 9813 else 9814 if not Is_Limited_Type (Tag_Typ) then 9815 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); 9816 end if; 9817 9818 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); 9819 end if; 9820 9821 Predef_List := Res; 9822 end Make_Predefined_Primitive_Specs; 9823 9824 ------------------------- 9825 -- Make_Tag_Assignment -- 9826 ------------------------- 9827 9828 function Make_Tag_Assignment (N : Node_Id) return Node_Id is 9829 Loc : constant Source_Ptr := Sloc (N); 9830 Def_If : constant Entity_Id := Defining_Identifier (N); 9831 Expr : constant Node_Id := Expression (N); 9832 Typ : constant Entity_Id := Etype (Def_If); 9833 Full_Typ : constant Entity_Id := Underlying_Type (Typ); 9834 New_Ref : Node_Id; 9835 9836 begin 9837 -- This expansion activity is called during analysis, but cannot 9838 -- be applied in ASIS mode when other expansion is disabled. 9839 9840 if Is_Tagged_Type (Typ) 9841 and then not Is_Class_Wide_Type (Typ) 9842 and then not Is_CPP_Class (Typ) 9843 and then Tagged_Type_Expansion 9844 and then Nkind (Expr) /= N_Aggregate 9845 and then not ASIS_Mode 9846 and then (Nkind (Expr) /= N_Qualified_Expression 9847 or else Nkind (Expression (Expr)) /= N_Aggregate) 9848 then 9849 New_Ref := 9850 Make_Selected_Component (Loc, 9851 Prefix => New_Occurrence_Of (Def_If, Loc), 9852 Selector_Name => 9853 New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc)); 9854 Set_Assignment_OK (New_Ref); 9855 9856 return 9857 Make_Assignment_Statement (Loc, 9858 Name => New_Ref, 9859 Expression => 9860 Unchecked_Convert_To (RTE (RE_Tag), 9861 New_Occurrence_Of (Node 9862 (First_Elmt (Access_Disp_Table (Full_Typ))), Loc))); 9863 else 9864 return Empty; 9865 end if; 9866 end Make_Tag_Assignment; 9867 9868 --------------------------------- 9869 -- Needs_Simple_Initialization -- 9870 --------------------------------- 9871 9872 function Needs_Simple_Initialization 9873 (T : Entity_Id; 9874 Consider_IS : Boolean := True) return Boolean 9875 is 9876 Consider_IS_NS : constant Boolean := 9877 Normalize_Scalars or (Initialize_Scalars and Consider_IS); 9878 9879 begin 9880 -- Never need initialization if it is suppressed 9881 9882 if Initialization_Suppressed (T) then 9883 return False; 9884 end if; 9885 9886 -- Check for private type, in which case test applies to the underlying 9887 -- type of the private type. 9888 9889 if Is_Private_Type (T) then 9890 declare 9891 RT : constant Entity_Id := Underlying_Type (T); 9892 begin 9893 if Present (RT) then 9894 return Needs_Simple_Initialization (RT); 9895 else 9896 return False; 9897 end if; 9898 end; 9899 9900 -- Scalar type with Default_Value aspect requires initialization 9901 9902 elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then 9903 return True; 9904 9905 -- Cases needing simple initialization are access types, and, if pragma 9906 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar 9907 -- types. 9908 9909 elsif Is_Access_Type (T) 9910 or else (Consider_IS_NS and then (Is_Scalar_Type (T))) 9911 then 9912 return True; 9913 9914 -- If Initialize/Normalize_Scalars is in effect, string objects also 9915 -- need initialization, unless they are created in the course of 9916 -- expanding an aggregate (since in the latter case they will be 9917 -- filled with appropriate initializing values before they are used). 9918 9919 elsif Consider_IS_NS 9920 and then Is_Standard_String_Type (T) 9921 and then 9922 (not Is_Itype (T) 9923 or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) 9924 then 9925 return True; 9926 9927 else 9928 return False; 9929 end if; 9930 end Needs_Simple_Initialization; 9931 9932 ---------------------- 9933 -- Predef_Deep_Spec -- 9934 ---------------------- 9935 9936 function Predef_Deep_Spec 9937 (Loc : Source_Ptr; 9938 Tag_Typ : Entity_Id; 9939 Name : TSS_Name_Type; 9940 For_Body : Boolean := False) return Node_Id 9941 is 9942 Formals : List_Id; 9943 9944 begin 9945 -- V : in out Tag_Typ 9946 9947 Formals := New_List ( 9948 Make_Parameter_Specification (Loc, 9949 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 9950 In_Present => True, 9951 Out_Present => True, 9952 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))); 9953 9954 -- F : Boolean := True 9955 9956 if Name = TSS_Deep_Adjust 9957 or else Name = TSS_Deep_Finalize 9958 then 9959 Append_To (Formals, 9960 Make_Parameter_Specification (Loc, 9961 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F), 9962 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), 9963 Expression => New_Occurrence_Of (Standard_True, Loc))); 9964 end if; 9965 9966 return 9967 Predef_Spec_Or_Body (Loc, 9968 Name => Make_TSS_Name (Tag_Typ, Name), 9969 Tag_Typ => Tag_Typ, 9970 Profile => Formals, 9971 For_Body => For_Body); 9972 9973 exception 9974 when RE_Not_Available => 9975 return Empty; 9976 end Predef_Deep_Spec; 9977 9978 ------------------------- 9979 -- Predef_Spec_Or_Body -- 9980 ------------------------- 9981 9982 function Predef_Spec_Or_Body 9983 (Loc : Source_Ptr; 9984 Tag_Typ : Entity_Id; 9985 Name : Name_Id; 9986 Profile : List_Id; 9987 Ret_Type : Entity_Id := Empty; 9988 For_Body : Boolean := False) return Node_Id 9989 is 9990 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name); 9991 Spec : Node_Id; 9992 9993 begin 9994 Set_Is_Public (Id, Is_Public (Tag_Typ)); 9995 9996 -- The internal flag is set to mark these declarations because they have 9997 -- specific properties. First, they are primitives even if they are not 9998 -- defined in the type scope (the freezing point is not necessarily in 9999 -- the same scope). Second, the predefined equality can be overridden by 10000 -- a user-defined equality, no body will be generated in this case. 10001 10002 Set_Is_Internal (Id); 10003 10004 if not Debug_Generated_Code then 10005 Set_Debug_Info_Off (Id); 10006 end if; 10007 10008 if No (Ret_Type) then 10009 Spec := 10010 Make_Procedure_Specification (Loc, 10011 Defining_Unit_Name => Id, 10012 Parameter_Specifications => Profile); 10013 else 10014 Spec := 10015 Make_Function_Specification (Loc, 10016 Defining_Unit_Name => Id, 10017 Parameter_Specifications => Profile, 10018 Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); 10019 end if; 10020 10021 if Is_Interface (Tag_Typ) then 10022 return Make_Abstract_Subprogram_Declaration (Loc, Spec); 10023 10024 -- If body case, return empty subprogram body. Note that this is ill- 10025 -- formed, because there is not even a null statement, and certainly not 10026 -- a return in the function case. The caller is expected to do surgery 10027 -- on the body to add the appropriate stuff. 10028 10029 elsif For_Body then 10030 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); 10031 10032 -- For the case of an Input attribute predefined for an abstract type, 10033 -- generate an abstract specification. This will never be called, but we 10034 -- need the slot allocated in the dispatching table so that attributes 10035 -- typ'Class'Input and typ'Class'Output will work properly. 10036 10037 elsif Is_TSS (Name, TSS_Stream_Input) 10038 and then Is_Abstract_Type (Tag_Typ) 10039 then 10040 return Make_Abstract_Subprogram_Declaration (Loc, Spec); 10041 10042 -- Normal spec case, where we return a subprogram declaration 10043 10044 else 10045 return Make_Subprogram_Declaration (Loc, Spec); 10046 end if; 10047 end Predef_Spec_Or_Body; 10048 10049 ----------------------------- 10050 -- Predef_Stream_Attr_Spec -- 10051 ----------------------------- 10052 10053 function Predef_Stream_Attr_Spec 10054 (Loc : Source_Ptr; 10055 Tag_Typ : Entity_Id; 10056 Name : TSS_Name_Type; 10057 For_Body : Boolean := False) return Node_Id 10058 is 10059 Ret_Type : Entity_Id; 10060 10061 begin 10062 if Name = TSS_Stream_Input then 10063 Ret_Type := Tag_Typ; 10064 else 10065 Ret_Type := Empty; 10066 end if; 10067 10068 return 10069 Predef_Spec_Or_Body 10070 (Loc, 10071 Name => Make_TSS_Name (Tag_Typ, Name), 10072 Tag_Typ => Tag_Typ, 10073 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), 10074 Ret_Type => Ret_Type, 10075 For_Body => For_Body); 10076 end Predef_Stream_Attr_Spec; 10077 10078 --------------------------------- 10079 -- Predefined_Primitive_Bodies -- 10080 --------------------------------- 10081 10082 function Predefined_Primitive_Bodies 10083 (Tag_Typ : Entity_Id; 10084 Renamed_Eq : Entity_Id) return List_Id 10085 is 10086 Loc : constant Source_Ptr := Sloc (Tag_Typ); 10087 Res : constant List_Id := New_List; 10088 Decl : Node_Id; 10089 Prim : Elmt_Id; 10090 Eq_Needed : Boolean; 10091 Eq_Name : Name_Id; 10092 Ent : Entity_Id; 10093 10094 pragma Warnings (Off, Ent); 10095 10096 begin 10097 pragma Assert (not Is_Interface (Tag_Typ)); 10098 10099 -- See if we have a predefined "=" operator 10100 10101 if Present (Renamed_Eq) then 10102 Eq_Needed := True; 10103 Eq_Name := Chars (Renamed_Eq); 10104 10105 -- If the parent is an interface type then it has defined all the 10106 -- predefined primitives abstract and we need to check if the type 10107 -- has some user defined "=" function which matches the profile of 10108 -- the Ada predefined equality operator to avoid generating it. 10109 10110 elsif Is_Interface (Etype (Tag_Typ)) then 10111 Eq_Needed := True; 10112 Eq_Name := Name_Op_Eq; 10113 10114 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 10115 while Present (Prim) loop 10116 if Chars (Node (Prim)) = Name_Op_Eq 10117 and then not Is_Internal (Node (Prim)) 10118 and then Present (First_Entity (Node (Prim))) 10119 10120 -- The predefined equality primitive must have exactly two 10121 -- formals whose type is this tagged type 10122 10123 and then Present (Last_Entity (Node (Prim))) 10124 and then Next_Entity (First_Entity (Node (Prim))) 10125 = Last_Entity (Node (Prim)) 10126 and then Etype (First_Entity (Node (Prim))) = Tag_Typ 10127 and then Etype (Last_Entity (Node (Prim))) = Tag_Typ 10128 then 10129 Eq_Needed := False; 10130 Eq_Name := No_Name; 10131 exit; 10132 end if; 10133 10134 Next_Elmt (Prim); 10135 end loop; 10136 10137 else 10138 Eq_Needed := False; 10139 Eq_Name := No_Name; 10140 10141 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 10142 while Present (Prim) loop 10143 if Chars (Node (Prim)) = Name_Op_Eq 10144 and then Is_Internal (Node (Prim)) 10145 then 10146 Eq_Needed := True; 10147 Eq_Name := Name_Op_Eq; 10148 exit; 10149 end if; 10150 10151 Next_Elmt (Prim); 10152 end loop; 10153 end if; 10154 10155 -- Body of _Size 10156 10157 Decl := Predef_Spec_Or_Body (Loc, 10158 Tag_Typ => Tag_Typ, 10159 Name => Name_uSize, 10160 Profile => New_List ( 10161 Make_Parameter_Specification (Loc, 10162 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 10163 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), 10164 10165 Ret_Type => Standard_Long_Long_Integer, 10166 For_Body => True); 10167 10168 Set_Handled_Statement_Sequence (Decl, 10169 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 10170 Make_Simple_Return_Statement (Loc, 10171 Expression => 10172 Make_Attribute_Reference (Loc, 10173 Prefix => Make_Identifier (Loc, Name_X), 10174 Attribute_Name => Name_Size))))); 10175 10176 Append_To (Res, Decl); 10177 10178 -- Bodies for Dispatching stream IO routines. We need these only for 10179 -- non-limited types (in the limited case there is no dispatching). 10180 -- We also skip them if dispatching or finalization are not available 10181 -- or if stream operations are prohibited by restriction No_Streams or 10182 -- from use of pragma/aspect No_Tagged_Streams. 10183 10184 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) 10185 and then No (TSS (Tag_Typ, TSS_Stream_Read)) 10186 then 10187 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); 10188 Append_To (Res, Decl); 10189 end if; 10190 10191 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Write) 10192 and then No (TSS (Tag_Typ, TSS_Stream_Write)) 10193 then 10194 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); 10195 Append_To (Res, Decl); 10196 end if; 10197 10198 -- Skip body of _Input for the abstract case, since the corresponding 10199 -- spec is abstract (see Predef_Spec_Or_Body). 10200 10201 if not Is_Abstract_Type (Tag_Typ) 10202 and then Stream_Operation_OK (Tag_Typ, TSS_Stream_Input) 10203 and then No (TSS (Tag_Typ, TSS_Stream_Input)) 10204 then 10205 Build_Record_Or_Elementary_Input_Function 10206 (Loc, Tag_Typ, Decl, Ent); 10207 Append_To (Res, Decl); 10208 end if; 10209 10210 if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) 10211 and then No (TSS (Tag_Typ, TSS_Stream_Output)) 10212 then 10213 Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent); 10214 Append_To (Res, Decl); 10215 end if; 10216 10217 -- Ada 2005: Generate bodies for the following primitive operations for 10218 -- limited interfaces and synchronized types that implement a limited 10219 -- interface. 10220 10221 -- disp_asynchronous_select 10222 -- disp_conditional_select 10223 -- disp_get_prim_op_kind 10224 -- disp_get_task_id 10225 -- disp_timed_select 10226 10227 -- The interface versions will have null bodies 10228 10229 -- Disable the generation of these bodies if No_Dispatching_Calls, 10230 -- Ravenscar or ZFP is active. 10231 10232 -- In VM targets we define these primitives in all root tagged types 10233 -- that are not interface types. Done because in VM targets we don't 10234 -- have secondary dispatch tables and any derivation of Tag_Typ may 10235 -- cover limited interfaces (which always have these primitives since 10236 -- they may be ancestors of synchronized interface types). 10237 10238 if Ada_Version >= Ada_2005 10239 and then not Is_Interface (Tag_Typ) 10240 and then 10241 ((Is_Interface (Etype (Tag_Typ)) 10242 and then Is_Limited_Record (Etype (Tag_Typ))) 10243 or else 10244 (Is_Concurrent_Record_Type (Tag_Typ) 10245 and then Has_Interfaces (Tag_Typ)) 10246 or else 10247 (not Tagged_Type_Expansion 10248 and then Tag_Typ = Root_Type (Tag_Typ))) 10249 and then not Restriction_Active (No_Dispatching_Calls) 10250 and then not Restriction_Active (No_Select_Statements) 10251 and then RTE_Available (RE_Select_Specific_Data) 10252 then 10253 Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ)); 10254 Append_To (Res, Make_Disp_Conditional_Select_Body (Tag_Typ)); 10255 Append_To (Res, Make_Disp_Get_Prim_Op_Kind_Body (Tag_Typ)); 10256 Append_To (Res, Make_Disp_Get_Task_Id_Body (Tag_Typ)); 10257 Append_To (Res, Make_Disp_Requeue_Body (Tag_Typ)); 10258 Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); 10259 end if; 10260 10261 if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then 10262 10263 -- Body for equality 10264 10265 if Eq_Needed then 10266 Decl := Make_Eq_Body (Tag_Typ, Eq_Name); 10267 Append_To (Res, Decl); 10268 end if; 10269 10270 -- Body for inequality (if required) 10271 10272 Decl := Make_Neq_Body (Tag_Typ); 10273 10274 if Present (Decl) then 10275 Append_To (Res, Decl); 10276 end if; 10277 10278 -- Body for dispatching assignment 10279 10280 Decl := 10281 Predef_Spec_Or_Body (Loc, 10282 Tag_Typ => Tag_Typ, 10283 Name => Name_uAssign, 10284 Profile => New_List ( 10285 Make_Parameter_Specification (Loc, 10286 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 10287 Out_Present => True, 10288 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), 10289 10290 Make_Parameter_Specification (Loc, 10291 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), 10292 Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), 10293 For_Body => True); 10294 10295 Set_Handled_Statement_Sequence (Decl, 10296 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 10297 Make_Assignment_Statement (Loc, 10298 Name => Make_Identifier (Loc, Name_X), 10299 Expression => Make_Identifier (Loc, Name_Y))))); 10300 10301 Append_To (Res, Decl); 10302 end if; 10303 10304 -- Generate empty bodies of routines Deep_Adjust and Deep_Finalize for 10305 -- tagged types which do not contain controlled components. 10306 10307 -- Do not generate the routines if finalization is disabled 10308 10309 if Restriction_Active (No_Finalization) then 10310 null; 10311 10312 elsif not Has_Controlled_Component (Tag_Typ) then 10313 if not Is_Limited_Type (Tag_Typ) then 10314 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); 10315 10316 if Is_Controlled (Tag_Typ) then 10317 Set_Handled_Statement_Sequence (Decl, 10318 Make_Handled_Sequence_Of_Statements (Loc, 10319 Statements => New_List ( 10320 Make_Adjust_Call ( 10321 Obj_Ref => Make_Identifier (Loc, Name_V), 10322 Typ => Tag_Typ)))); 10323 10324 else 10325 Set_Handled_Statement_Sequence (Decl, 10326 Make_Handled_Sequence_Of_Statements (Loc, 10327 Statements => New_List ( 10328 Make_Null_Statement (Loc)))); 10329 end if; 10330 10331 Append_To (Res, Decl); 10332 end if; 10333 10334 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); 10335 10336 if Is_Controlled (Tag_Typ) then 10337 Set_Handled_Statement_Sequence (Decl, 10338 Make_Handled_Sequence_Of_Statements (Loc, 10339 Statements => New_List ( 10340 Make_Final_Call 10341 (Obj_Ref => Make_Identifier (Loc, Name_V), 10342 Typ => Tag_Typ)))); 10343 10344 else 10345 Set_Handled_Statement_Sequence (Decl, 10346 Make_Handled_Sequence_Of_Statements (Loc, 10347 Statements => New_List (Make_Null_Statement (Loc)))); 10348 end if; 10349 10350 Append_To (Res, Decl); 10351 end if; 10352 10353 return Res; 10354 end Predefined_Primitive_Bodies; 10355 10356 --------------------------------- 10357 -- Predefined_Primitive_Freeze -- 10358 --------------------------------- 10359 10360 function Predefined_Primitive_Freeze 10361 (Tag_Typ : Entity_Id) return List_Id 10362 is 10363 Res : constant List_Id := New_List; 10364 Prim : Elmt_Id; 10365 Frnodes : List_Id; 10366 10367 begin 10368 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 10369 while Present (Prim) loop 10370 if Is_Predefined_Dispatching_Operation (Node (Prim)) then 10371 Frnodes := Freeze_Entity (Node (Prim), Tag_Typ); 10372 10373 if Present (Frnodes) then 10374 Append_List_To (Res, Frnodes); 10375 end if; 10376 end if; 10377 10378 Next_Elmt (Prim); 10379 end loop; 10380 10381 return Res; 10382 end Predefined_Primitive_Freeze; 10383 10384 ------------------------- 10385 -- Stream_Operation_OK -- 10386 ------------------------- 10387 10388 function Stream_Operation_OK 10389 (Typ : Entity_Id; 10390 Operation : TSS_Name_Type) return Boolean 10391 is 10392 Has_Predefined_Or_Specified_Stream_Attribute : Boolean := False; 10393 10394 begin 10395 -- Special case of a limited type extension: a default implementation 10396 -- of the stream attributes Read or Write exists if that attribute 10397 -- has been specified or is available for an ancestor type; a default 10398 -- implementation of the attribute Output (resp. Input) exists if the 10399 -- attribute has been specified or Write (resp. Read) is available for 10400 -- an ancestor type. The last condition only applies under Ada 2005. 10401 10402 if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then 10403 if Operation = TSS_Stream_Read then 10404 Has_Predefined_Or_Specified_Stream_Attribute := 10405 Has_Specified_Stream_Read (Typ); 10406 10407 elsif Operation = TSS_Stream_Write then 10408 Has_Predefined_Or_Specified_Stream_Attribute := 10409 Has_Specified_Stream_Write (Typ); 10410 10411 elsif Operation = TSS_Stream_Input then 10412 Has_Predefined_Or_Specified_Stream_Attribute := 10413 Has_Specified_Stream_Input (Typ) 10414 or else 10415 (Ada_Version >= Ada_2005 10416 and then Stream_Operation_OK (Typ, TSS_Stream_Read)); 10417 10418 elsif Operation = TSS_Stream_Output then 10419 Has_Predefined_Or_Specified_Stream_Attribute := 10420 Has_Specified_Stream_Output (Typ) 10421 or else 10422 (Ada_Version >= Ada_2005 10423 and then Stream_Operation_OK (Typ, TSS_Stream_Write)); 10424 end if; 10425 10426 -- Case of inherited TSS_Stream_Read or TSS_Stream_Write 10427 10428 if not Has_Predefined_Or_Specified_Stream_Attribute 10429 and then Is_Derived_Type (Typ) 10430 and then (Operation = TSS_Stream_Read 10431 or else Operation = TSS_Stream_Write) 10432 then 10433 Has_Predefined_Or_Specified_Stream_Attribute := 10434 Present 10435 (Find_Inherited_TSS (Base_Type (Etype (Typ)), Operation)); 10436 end if; 10437 end if; 10438 10439 -- If the type is not limited, or else is limited but the attribute is 10440 -- explicitly specified or is predefined for the type, then return True, 10441 -- unless other conditions prevail, such as restrictions prohibiting 10442 -- streams or dispatching operations. We also return True for limited 10443 -- interfaces, because they may be extended by nonlimited types and 10444 -- permit inheritance in this case (addresses cases where an abstract 10445 -- extension doesn't get 'Input declared, as per comments below, but 10446 -- 'Class'Input must still be allowed). Note that attempts to apply 10447 -- stream attributes to a limited interface or its class-wide type 10448 -- (or limited extensions thereof) will still get properly rejected 10449 -- by Check_Stream_Attribute. 10450 10451 -- We exclude the Input operation from being a predefined subprogram in 10452 -- the case where the associated type is an abstract extension, because 10453 -- the attribute is not callable in that case, per 13.13.2(49/2). Also, 10454 -- we don't want an abstract version created because types derived from 10455 -- the abstract type may not even have Input available (for example if 10456 -- derived from a private view of the abstract type that doesn't have 10457 -- a visible Input). 10458 10459 -- Do not generate stream routines for type Finalization_Master because 10460 -- a master may never appear in types and therefore cannot be read or 10461 -- written. 10462 10463 return 10464 (not Is_Limited_Type (Typ) 10465 or else Is_Interface (Typ) 10466 or else Has_Predefined_Or_Specified_Stream_Attribute) 10467 and then 10468 (Operation /= TSS_Stream_Input 10469 or else not Is_Abstract_Type (Typ) 10470 or else not Is_Derived_Type (Typ)) 10471 and then not Has_Unknown_Discriminants (Typ) 10472 and then not 10473 (Is_Interface (Typ) 10474 and then 10475 (Is_Task_Interface (Typ) 10476 or else Is_Protected_Interface (Typ) 10477 or else Is_Synchronized_Interface (Typ))) 10478 and then not Restriction_Active (No_Streams) 10479 and then not Restriction_Active (No_Dispatch) 10480 and then No (No_Tagged_Streams_Pragma (Typ)) 10481 and then not No_Run_Time_Mode 10482 and then RTE_Available (RE_Tag) 10483 and then No (Type_Without_Stream_Operation (Typ)) 10484 and then RTE_Available (RE_Root_Stream_Type) 10485 and then not Is_RTE (Typ, RE_Finalization_Master); 10486 end Stream_Operation_OK; 10487 10488end Exp_Ch3; 10489