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