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