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