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