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