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-2004 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Aggr; use Exp_Aggr; 33with Exp_Ch4; use Exp_Ch4; 34with Exp_Ch7; use Exp_Ch7; 35with Exp_Ch9; use Exp_Ch9; 36with Exp_Ch11; use Exp_Ch11; 37with Exp_Disp; use Exp_Disp; 38with Exp_Dist; use Exp_Dist; 39with Exp_Smem; use Exp_Smem; 40with Exp_Strm; use Exp_Strm; 41with Exp_Tss; use Exp_Tss; 42with Exp_Util; use Exp_Util; 43with Freeze; use Freeze; 44with Hostparm; use Hostparm; 45with Nlists; use Nlists; 46with Nmake; use Nmake; 47with Opt; use Opt; 48with Restrict; use Restrict; 49with Rtsfind; use Rtsfind; 50with Sem; use Sem; 51with Sem_Ch3; use Sem_Ch3; 52with Sem_Ch8; use Sem_Ch8; 53with Sem_Eval; use Sem_Eval; 54with Sem_Mech; use Sem_Mech; 55with Sem_Res; use Sem_Res; 56with Sem_Util; use Sem_Util; 57with Sinfo; use Sinfo; 58with Stand; use Stand; 59with Stringt; use Stringt; 60with Snames; use Snames; 61with Tbuild; use Tbuild; 62with Ttypes; use Ttypes; 63with Uintp; use Uintp; 64with Validsw; use Validsw; 65 66package body Exp_Ch3 is 67 68 ----------------------- 69 -- Local Subprograms -- 70 ----------------------- 71 72 procedure Adjust_Discriminants (Rtype : Entity_Id); 73 -- This is used when freezing a record type. It attempts to construct 74 -- more restrictive subtypes for discriminants so that the max size of 75 -- the record can be calculated more accurately. See the body of this 76 -- procedure for details. 77 78 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id); 79 -- Build initialization procedure for given array type. Nod is a node 80 -- used for attachment of any actions required in its construction. 81 -- It also supplies the source location used for the procedure. 82 83 procedure Build_Class_Wide_Master (T : Entity_Id); 84 -- for access to class-wide limited types we must build a task master 85 -- because some subsequent extension may add a task component. To avoid 86 -- bringing in the tasking run-time whenever an access-to-class-wide 87 -- limited type is used, we use the soft-link mechanism and add a level 88 -- of indirection to calls to routines that manipulate Master_Ids. 89 90 function Build_Discriminant_Formals 91 (Rec_Id : Entity_Id; 92 Use_Dl : Boolean) 93 return List_Id; 94 -- This function uses the discriminants of a type to build a list of 95 -- formal parameters, used in the following function. If the flag Use_Dl 96 -- is set, the list is built using the already defined discriminals 97 -- of the type. Otherwise new identifiers are created, with the source 98 -- names of the discriminants. 99 100 procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id); 101 -- If the designated type of an access type is a task type or contains 102 -- tasks, we make sure that a _Master variable is declared in the current 103 -- scope, and then declare a renaming for it: 104 -- 105 -- atypeM : Master_Id renames _Master; 106 -- 107 -- where atyp is the name of the access type. This declaration is 108 -- used when an allocator for the access type is expanded. The node N 109 -- is the full declaration of the designated type that contains tasks. 110 -- The renaming declaration is inserted before N, and after the Master 111 -- declaration. 112 113 procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id); 114 -- Build record initialization procedure. N is the type declaration 115 -- node, and Pe is the corresponding entity for the record type. 116 117 procedure Build_Variant_Record_Equality (Typ : Entity_Id); 118 -- Create An Equality function for the non-tagged variant record 'Typ' 119 -- and attach it to the TSS list 120 121 procedure Check_Stream_Attributes (Typ : Entity_Id); 122 -- Check that if a limited extension has a parent with user-defined 123 -- stream attributes, any limited component of the extension also has 124 -- the corresponding user-defined stream attributes. 125 126 procedure Expand_Tagged_Root (T : Entity_Id); 127 -- Add a field _Tag at the beginning of the record. This field carries 128 -- the value of the access to the Dispatch table. This procedure is only 129 -- called on root (non CPP_Class) types, the _Tag field being inherited 130 -- by the descendants. 131 132 procedure Expand_Record_Controller (T : Entity_Id); 133 -- T must be a record type that Has_Controlled_Component. Add a field 134 -- _controller of type Record_Controller or Limited_Record_Controller 135 -- in the record T. 136 137 procedure Freeze_Array_Type (N : Node_Id); 138 -- Freeze an array type. Deals with building the initialization procedure, 139 -- creating the packed array type for a packed array and also with the 140 -- creation of the controlling procedures for the controlled case. The 141 -- argument N is the N_Freeze_Entity node for the type. 142 143 procedure Freeze_Enumeration_Type (N : Node_Id); 144 -- Freeze enumeration type with non-standard representation. Builds the 145 -- array and function needed to convert between enumeration pos and 146 -- enumeration representation values. N is the N_Freeze_Entity node 147 -- for the type. 148 149 procedure Freeze_Record_Type (N : Node_Id); 150 -- Freeze record type. Builds all necessary discriminant checking 151 -- and other ancillary functions, and builds dispatch tables where 152 -- needed. The argument N is the N_Freeze_Entity node. This processing 153 -- applies only to E_Record_Type entities, not to class wide types, 154 -- record subtypes, or private types. 155 156 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); 157 -- Treat user-defined stream operations as renaming_as_body if the 158 -- subprogram they rename is not frozen when the type is frozen. 159 160 function Init_Formals (Typ : Entity_Id) return List_Id; 161 -- This function builds the list of formals for an initialization routine. 162 -- The first formal is always _Init with the given type. For task value 163 -- record types and types containing tasks, three additional formals are 164 -- added: 165 -- 166 -- _Master : Master_Id 167 -- _Chain : in out Activation_Chain 168 -- _Task_Name : String 169 -- 170 -- The caller must append additional entries for discriminants if required. 171 172 function In_Runtime (E : Entity_Id) return Boolean; 173 -- Check if E is defined in the RTL (in a child of Ada or System). Used 174 -- to avoid to bring in the overhead of _Input, _Output for tagged types. 175 176 function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id; 177 -- Building block for variant record equality. Defined to share the 178 -- code between the tagged and non-tagged case. Given a Component_List 179 -- node CL, it generates an 'if' followed by a 'case' statement that 180 -- compares all components of local temporaries named X and Y (that 181 -- are declared as formals at some upper level). Node provides the 182 -- Sloc to be used for the generated code. 183 184 function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id; 185 -- Building block for variant record equality. Defined to share the 186 -- code between the tagged and non-tagged case. Given the list of 187 -- components (or discriminants) L, it generates a return statement 188 -- that compares all components of local temporaries named X and Y 189 -- (that are declared as formals at some upper level). Node provides 190 -- the Sloc to be used for the generated code. 191 192 procedure Make_Predefined_Primitive_Specs 193 (Tag_Typ : Entity_Id; 194 Predef_List : out List_Id; 195 Renamed_Eq : out Node_Id); 196 -- Create a list with the specs of the predefined primitive operations. 197 -- The following entries are present for all tagged types, and provide 198 -- the results of the corresponding attribute applied to the object. 199 -- Dispatching is required in general, since the result of the attribute 200 -- will vary with the actual object subtype. 201 -- 202 -- _alignment provides result of 'Alignment attribute 203 -- _size provides result of 'Size attribute 204 -- typSR provides result of 'Read attribute 205 -- typSW provides result of 'Write attribute 206 -- typSI provides result of 'Input attribute 207 -- typSO provides result of 'Output attribute 208 -- 209 -- The following entries are additionally present for non-limited 210 -- tagged types, and implement additional dispatching operations 211 -- for predefined operations: 212 -- 213 -- _equality implements "=" operator 214 -- _assign implements assignment operation 215 -- typDF implements deep finalization 216 -- typDA implements deep adust 217 -- 218 -- The latter two are empty procedures unless the type contains some 219 -- controlled components that require finalization actions (the deep 220 -- in the name refers to the fact that the action applies to components). 221 -- 222 -- The list is returned in Predef_List. The Parameter Renamed_Eq 223 -- either returns the value Empty, or else the defining unit name 224 -- for the predefined equality function in the case where the type 225 -- has a primitive operation that is a renaming of predefined equality 226 -- (but only if there is also an overriding user-defined equality 227 -- function). The returned Renamed_Eq will be passed to the 228 -- corresponding parameter of Predefined_Primitive_Bodies. 229 230 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean; 231 -- returns True if there are representation clauses for type T that 232 -- are not inherited. If the result is false, the init_proc and the 233 -- discriminant_checking functions of the parent can be reused by 234 -- a derived type. 235 236 function Predef_Spec_Or_Body 237 (Loc : Source_Ptr; 238 Tag_Typ : Entity_Id; 239 Name : Name_Id; 240 Profile : List_Id; 241 Ret_Type : Entity_Id := Empty; 242 For_Body : Boolean := False) 243 return Node_Id; 244 -- This function generates the appropriate expansion for a predefined 245 -- primitive operation specified by its name, parameter profile and 246 -- return type (Empty means this is a procedure). If For_Body is false, 247 -- then the returned node is a subprogram declaration. If For_Body is 248 -- true, then the returned node is a empty subprogram body containing 249 -- no declarations and no statements. 250 251 function Predef_Stream_Attr_Spec 252 (Loc : Source_Ptr; 253 Tag_Typ : Entity_Id; 254 Name : TSS_Name_Type; 255 For_Body : Boolean := False) 256 return Node_Id; 257 -- Specialized version of Predef_Spec_Or_Body that apply to read, write, 258 -- input and output attribute whose specs are constructed in Exp_Strm. 259 260 function Predef_Deep_Spec 261 (Loc : Source_Ptr; 262 Tag_Typ : Entity_Id; 263 Name : TSS_Name_Type; 264 For_Body : Boolean := False) 265 return Node_Id; 266 -- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust 267 -- and _deep_finalize 268 269 function Predefined_Primitive_Bodies 270 (Tag_Typ : Entity_Id; 271 Renamed_Eq : Node_Id) 272 return List_Id; 273 -- Create the bodies of the predefined primitives that are described in 274 -- Predefined_Primitive_Specs. When not empty, Renamed_Eq must denote 275 -- the defining unit name of the type's predefined equality as returned 276 -- by Make_Predefined_Primitive_Specs. 277 278 function Predefined_Primitive_Freeze (Tag_Typ : Entity_Id) return List_Id; 279 -- Freeze entities of all predefined primitive operations. This is needed 280 -- because the bodies of these operations do not normally do any freezeing. 281 282 -------------------------- 283 -- Adjust_Discriminants -- 284 -------------------------- 285 286 -- This procedure attempts to define subtypes for discriminants that 287 -- are more restrictive than those declared. Such a replacement is 288 -- possible if we can demonstrate that values outside the restricted 289 -- range would cause constraint errors in any case. The advantage of 290 -- restricting the discriminant types in this way is tha the maximum 291 -- size of the variant record can be calculated more conservatively. 292 293 -- An example of a situation in which we can perform this type of 294 -- restriction is the following: 295 296 -- subtype B is range 1 .. 10; 297 -- type Q is array (B range <>) of Integer; 298 299 -- type V (N : Natural) is record 300 -- C : Q (1 .. N); 301 -- end record; 302 303 -- In this situation, we can restrict the upper bound of N to 10, since 304 -- any larger value would cause a constraint error in any case. 305 306 -- There are many situations in which such restriction is possible, but 307 -- for now, we just look for cases like the above, where the component 308 -- in question is a one dimensional array whose upper bound is one of 309 -- the record discriminants. Also the component must not be part of 310 -- any variant part, since then the component does not always exist. 311 312 procedure Adjust_Discriminants (Rtype : Entity_Id) is 313 Loc : constant Source_Ptr := Sloc (Rtype); 314 Comp : Entity_Id; 315 Ctyp : Entity_Id; 316 Ityp : Entity_Id; 317 Lo : Node_Id; 318 Hi : Node_Id; 319 P : Node_Id; 320 Loval : Uint; 321 Discr : Entity_Id; 322 Dtyp : Entity_Id; 323 Dhi : Node_Id; 324 Dhiv : Uint; 325 Ahi : Node_Id; 326 Ahiv : Uint; 327 Tnn : Entity_Id; 328 329 begin 330 Comp := First_Component (Rtype); 331 while Present (Comp) loop 332 333 -- If our parent is a variant, quit, we do not look at components 334 -- that are in variant parts, because they may not always exist. 335 336 P := Parent (Comp); -- component declaration 337 P := Parent (P); -- component list 338 339 exit when Nkind (Parent (P)) = N_Variant; 340 341 -- We are looking for a one dimensional array type 342 343 Ctyp := Etype (Comp); 344 345 if not Is_Array_Type (Ctyp) 346 or else Number_Dimensions (Ctyp) > 1 347 then 348 goto Continue; 349 end if; 350 351 -- The lower bound must be constant, and the upper bound is a 352 -- discriminant (which is a discriminant of the current record). 353 354 Ityp := Etype (First_Index (Ctyp)); 355 Lo := Type_Low_Bound (Ityp); 356 Hi := Type_High_Bound (Ityp); 357 358 if not Compile_Time_Known_Value (Lo) 359 or else Nkind (Hi) /= N_Identifier 360 or else No (Entity (Hi)) 361 or else Ekind (Entity (Hi)) /= E_Discriminant 362 then 363 goto Continue; 364 end if; 365 366 -- We have an array with appropriate bounds 367 368 Loval := Expr_Value (Lo); 369 Discr := Entity (Hi); 370 Dtyp := Etype (Discr); 371 372 -- See if the discriminant has a known upper bound 373 374 Dhi := Type_High_Bound (Dtyp); 375 376 if not Compile_Time_Known_Value (Dhi) then 377 goto Continue; 378 end if; 379 380 Dhiv := Expr_Value (Dhi); 381 382 -- See if base type of component array has known upper bound 383 384 Ahi := Type_High_Bound (Etype (First_Index (Base_Type (Ctyp)))); 385 386 if not Compile_Time_Known_Value (Ahi) then 387 goto Continue; 388 end if; 389 390 Ahiv := Expr_Value (Ahi); 391 392 -- The condition for doing the restriction is that the high bound 393 -- of the discriminant is greater than the low bound of the array, 394 -- and is also greater than the high bound of the base type index. 395 396 if Dhiv > Loval and then Dhiv > Ahiv then 397 398 -- We can reset the upper bound of the discriminant type to 399 -- whichever is larger, the low bound of the component, or 400 -- the high bound of the base type array index. 401 402 -- We build a subtype that is declared as 403 404 -- subtype Tnn is discr_type range discr_type'First .. max; 405 406 -- And insert this declaration into the tree. The type of the 407 -- discriminant is then reset to this more restricted subtype. 408 409 Tnn := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); 410 411 Insert_Action (Declaration_Node (Rtype), 412 Make_Subtype_Declaration (Loc, 413 Defining_Identifier => Tnn, 414 Subtype_Indication => 415 Make_Subtype_Indication (Loc, 416 Subtype_Mark => New_Occurrence_Of (Dtyp, Loc), 417 Constraint => 418 Make_Range_Constraint (Loc, 419 Range_Expression => 420 Make_Range (Loc, 421 Low_Bound => 422 Make_Attribute_Reference (Loc, 423 Attribute_Name => Name_First, 424 Prefix => New_Occurrence_Of (Dtyp, Loc)), 425 High_Bound => 426 Make_Integer_Literal (Loc, 427 Intval => UI_Max (Loval, Ahiv))))))); 428 429 Set_Etype (Discr, Tnn); 430 end if; 431 432 <<Continue>> 433 Next_Component (Comp); 434 end loop; 435 end Adjust_Discriminants; 436 437 --------------------------- 438 -- Build_Array_Init_Proc -- 439 --------------------------- 440 441 procedure Build_Array_Init_Proc (A_Type : Entity_Id; Nod : Node_Id) is 442 Loc : constant Source_Ptr := Sloc (Nod); 443 Comp_Type : constant Entity_Id := Component_Type (A_Type); 444 Index_List : List_Id; 445 Proc_Id : Entity_Id; 446 Body_Stmts : List_Id; 447 448 function Init_Component return List_Id; 449 -- Create one statement to initialize one array component, designated 450 -- by a full set of indices. 451 452 function Init_One_Dimension (N : Int) return List_Id; 453 -- Create loop to initialize one dimension of the array. The single 454 -- statement in the loop body initializes the inner dimensions if any, 455 -- or else the single component. Note that this procedure is called 456 -- recursively, with N being the dimension to be initialized. A call 457 -- with N greater than the number of dimensions simply generates the 458 -- component initialization, terminating the recursion. 459 460 -------------------- 461 -- Init_Component -- 462 -------------------- 463 464 function Init_Component return List_Id is 465 Comp : Node_Id; 466 467 begin 468 Comp := 469 Make_Indexed_Component (Loc, 470 Prefix => Make_Identifier (Loc, Name_uInit), 471 Expressions => Index_List); 472 473 if Needs_Simple_Initialization (Comp_Type) then 474 Set_Assignment_OK (Comp); 475 return New_List ( 476 Make_Assignment_Statement (Loc, 477 Name => Comp, 478 Expression => Get_Simple_Init_Val (Comp_Type, Loc))); 479 480 else 481 return 482 Build_Initialization_Call (Loc, Comp, Comp_Type, True, A_Type); 483 end if; 484 end Init_Component; 485 486 ------------------------ 487 -- Init_One_Dimension -- 488 ------------------------ 489 490 function Init_One_Dimension (N : Int) return List_Id is 491 Index : Entity_Id; 492 493 begin 494 -- If the component does not need initializing, then there is nothing 495 -- to do here, so we return a null body. This occurs when generating 496 -- the dummy Init_Proc needed for Initialize_Scalars processing. 497 498 if not Has_Non_Null_Base_Init_Proc (Comp_Type) 499 and then not Needs_Simple_Initialization (Comp_Type) 500 and then not Has_Task (Comp_Type) 501 then 502 return New_List (Make_Null_Statement (Loc)); 503 504 -- If all dimensions dealt with, we simply initialize the component 505 506 elsif N > Number_Dimensions (A_Type) then 507 return Init_Component; 508 509 -- Here we generate the required loop 510 511 else 512 Index := 513 Make_Defining_Identifier (Loc, New_External_Name ('J', N)); 514 515 Append (New_Reference_To (Index, Loc), Index_List); 516 517 return New_List ( 518 Make_Implicit_Loop_Statement (Nod, 519 Identifier => Empty, 520 Iteration_Scheme => 521 Make_Iteration_Scheme (Loc, 522 Loop_Parameter_Specification => 523 Make_Loop_Parameter_Specification (Loc, 524 Defining_Identifier => Index, 525 Discrete_Subtype_Definition => 526 Make_Attribute_Reference (Loc, 527 Prefix => Make_Identifier (Loc, Name_uInit), 528 Attribute_Name => Name_Range, 529 Expressions => New_List ( 530 Make_Integer_Literal (Loc, N))))), 531 Statements => Init_One_Dimension (N + 1))); 532 end if; 533 end Init_One_Dimension; 534 535 -- Start of processing for Build_Array_Init_Proc 536 537 begin 538 if Suppress_Init_Proc (A_Type) then 539 return; 540 end if; 541 542 Index_List := New_List; 543 544 -- We need an initialization procedure if any of the following is true: 545 546 -- 1. The component type has an initialization procedure 547 -- 2. The component type needs simple initialization 548 -- 3. Tasks are present 549 -- 4. The type is marked as a publc entity 550 551 -- The reason for the public entity test is to deal properly with the 552 -- Initialize_Scalars pragma. This pragma can be set in the client and 553 -- not in the declaring package, this means the client will make a call 554 -- to the initialization procedure (because one of conditions 1-3 must 555 -- apply in this case), and we must generate a procedure (even if it is 556 -- null) to satisfy the call in this case. 557 558 -- Exception: do not build an array init_proc for a type whose root type 559 -- is Standard.String or Standard.Wide_String, since there is no place 560 -- to put the code, and in any case we handle initialization of such 561 -- types (in the Initialize_Scalars case, that's the only time the issue 562 -- arises) in a special manner anyway which does not need an init_proc. 563 564 if Has_Non_Null_Base_Init_Proc (Comp_Type) 565 or else Needs_Simple_Initialization (Comp_Type) 566 or else Has_Task (Comp_Type) 567 or else (not Restrictions (No_Initialize_Scalars) 568 and then Is_Public (A_Type) 569 and then Root_Type (A_Type) /= Standard_String 570 and then Root_Type (A_Type) /= Standard_Wide_String) 571 then 572 Proc_Id := 573 Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type)); 574 575 Body_Stmts := Init_One_Dimension (1); 576 577 Discard_Node ( 578 Make_Subprogram_Body (Loc, 579 Specification => 580 Make_Procedure_Specification (Loc, 581 Defining_Unit_Name => Proc_Id, 582 Parameter_Specifications => Init_Formals (A_Type)), 583 Declarations => New_List, 584 Handled_Statement_Sequence => 585 Make_Handled_Sequence_Of_Statements (Loc, 586 Statements => Body_Stmts))); 587 588 Set_Ekind (Proc_Id, E_Procedure); 589 Set_Is_Public (Proc_Id, Is_Public (A_Type)); 590 Set_Is_Internal (Proc_Id); 591 Set_Has_Completion (Proc_Id); 592 593 if not Debug_Generated_Code then 594 Set_Debug_Info_Off (Proc_Id); 595 end if; 596 597 -- Set inlined unless controlled stuff or tasks around, in which 598 -- case we do not want to inline, because nested stuff may cause 599 -- difficulties in interunit inlining, and furthermore there is 600 -- in any case no point in inlining such complex init procs. 601 602 if not Has_Task (Proc_Id) 603 and then not Controlled_Type (Proc_Id) 604 then 605 Set_Is_Inlined (Proc_Id); 606 end if; 607 608 -- Associate Init_Proc with type, and determine if the procedure 609 -- is null (happens because of the Initialize_Scalars pragma case, 610 -- where we have to generate a null procedure in case it is called 611 -- by a client with Initialize_Scalars set). Such procedures have 612 -- to be generated, but do not have to be called, so we mark them 613 -- as null to suppress the call. 614 615 Set_Init_Proc (A_Type, Proc_Id); 616 617 if List_Length (Body_Stmts) = 1 618 and then Nkind (First (Body_Stmts)) = N_Null_Statement 619 then 620 Set_Is_Null_Init_Proc (Proc_Id); 621 end if; 622 end if; 623 end Build_Array_Init_Proc; 624 625 ----------------------------- 626 -- Build_Class_Wide_Master -- 627 ----------------------------- 628 629 procedure Build_Class_Wide_Master (T : Entity_Id) is 630 Loc : constant Source_Ptr := Sloc (T); 631 M_Id : Entity_Id; 632 Decl : Node_Id; 633 P : Node_Id; 634 635 begin 636 -- Nothing to do if there is no task hierarchy. 637 638 if Restrictions (No_Task_Hierarchy) then 639 return; 640 end if; 641 642 -- Nothing to do if we already built a master entity for this scope 643 644 if not Has_Master_Entity (Scope (T)) then 645 -- first build the master entity 646 -- _Master : constant Master_Id := Current_Master.all; 647 -- and insert it just before the current declaration 648 649 Decl := 650 Make_Object_Declaration (Loc, 651 Defining_Identifier => 652 Make_Defining_Identifier (Loc, Name_uMaster), 653 Constant_Present => True, 654 Object_Definition => New_Reference_To (Standard_Integer, Loc), 655 Expression => 656 Make_Explicit_Dereference (Loc, 657 New_Reference_To (RTE (RE_Current_Master), Loc))); 658 659 P := Parent (T); 660 Insert_Before (P, Decl); 661 Analyze (Decl); 662 Set_Has_Master_Entity (Scope (T)); 663 664 -- Now mark the containing scope as a task master 665 666 while Nkind (P) /= N_Compilation_Unit loop 667 P := Parent (P); 668 669 -- If we fall off the top, we are at the outer level, and the 670 -- environment task is our effective master, so nothing to mark. 671 672 if Nkind (P) = N_Task_Body 673 or else Nkind (P) = N_Block_Statement 674 or else Nkind (P) = N_Subprogram_Body 675 then 676 Set_Is_Task_Master (P, True); 677 exit; 678 end if; 679 end loop; 680 end if; 681 682 -- Now define the renaming of the master_id. 683 684 M_Id := 685 Make_Defining_Identifier (Loc, 686 New_External_Name (Chars (T), 'M')); 687 688 Decl := 689 Make_Object_Renaming_Declaration (Loc, 690 Defining_Identifier => M_Id, 691 Subtype_Mark => New_Reference_To (Standard_Integer, Loc), 692 Name => Make_Identifier (Loc, Name_uMaster)); 693 Insert_Before (Parent (T), Decl); 694 Analyze (Decl); 695 696 Set_Master_Id (T, M_Id); 697 698 exception 699 when RE_Not_Available => 700 return; 701 end Build_Class_Wide_Master; 702 703 -------------------------------- 704 -- Build_Discr_Checking_Funcs -- 705 -------------------------------- 706 707 procedure Build_Discr_Checking_Funcs (N : Node_Id) is 708 Rec_Id : Entity_Id; 709 Loc : Source_Ptr; 710 Enclosing_Func_Id : Entity_Id; 711 Sequence : Nat := 1; 712 Type_Def : Node_Id; 713 V : Node_Id; 714 715 function Build_Case_Statement 716 (Case_Id : Entity_Id; 717 Variant : Node_Id) 718 return Node_Id; 719 -- Build a case statement containing only two alternatives. The 720 -- first alternative corresponds exactly to the discrete choices 721 -- given on the variant with contains the components that we are 722 -- generating the checks for. If the discriminant is one of these 723 -- return False. The second alternative is an OTHERS choice that 724 -- will return True indicating the discriminant did not match. 725 726 function Build_Dcheck_Function 727 (Case_Id : Entity_Id; 728 Variant : Node_Id) 729 return Entity_Id; 730 -- Build the discriminant checking function for a given variant 731 732 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id); 733 -- Builds the discriminant checking function for each variant of the 734 -- given variant part of the record type. 735 736 -------------------------- 737 -- Build_Case_Statement -- 738 -------------------------- 739 740 function Build_Case_Statement 741 (Case_Id : Entity_Id; 742 Variant : Node_Id) 743 return Node_Id 744 is 745 Alt_List : constant List_Id := New_List; 746 Actuals_List : List_Id; 747 Case_Node : Node_Id; 748 Case_Alt_Node : Node_Id; 749 Choice : Node_Id; 750 Choice_List : List_Id; 751 D : Entity_Id; 752 Return_Node : Node_Id; 753 754 begin 755 Case_Node := New_Node (N_Case_Statement, Loc); 756 757 -- Replace the discriminant which controls the variant, with the 758 -- name of the formal of the checking function. 759 760 Set_Expression (Case_Node, 761 Make_Identifier (Loc, Chars (Case_Id))); 762 763 Choice := First (Discrete_Choices (Variant)); 764 765 if Nkind (Choice) = N_Others_Choice then 766 Choice_List := New_Copy_List (Others_Discrete_Choices (Choice)); 767 else 768 Choice_List := New_Copy_List (Discrete_Choices (Variant)); 769 end if; 770 771 if not Is_Empty_List (Choice_List) then 772 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); 773 Set_Discrete_Choices (Case_Alt_Node, Choice_List); 774 775 -- In case this is a nested variant, we need to return the result 776 -- of the discriminant checking function for the immediately 777 -- enclosing variant. 778 779 if Present (Enclosing_Func_Id) then 780 Actuals_List := New_List; 781 782 D := First_Discriminant (Rec_Id); 783 while Present (D) loop 784 Append (Make_Identifier (Loc, Chars (D)), Actuals_List); 785 Next_Discriminant (D); 786 end loop; 787 788 Return_Node := 789 Make_Return_Statement (Loc, 790 Expression => 791 Make_Function_Call (Loc, 792 Name => 793 New_Reference_To (Enclosing_Func_Id, Loc), 794 Parameter_Associations => 795 Actuals_List)); 796 797 else 798 Return_Node := 799 Make_Return_Statement (Loc, 800 Expression => 801 New_Reference_To (Standard_False, Loc)); 802 end if; 803 804 Set_Statements (Case_Alt_Node, New_List (Return_Node)); 805 Append (Case_Alt_Node, Alt_List); 806 end if; 807 808 Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); 809 Choice_List := New_List (New_Node (N_Others_Choice, Loc)); 810 Set_Discrete_Choices (Case_Alt_Node, Choice_List); 811 812 Return_Node := 813 Make_Return_Statement (Loc, 814 Expression => 815 New_Reference_To (Standard_True, Loc)); 816 817 Set_Statements (Case_Alt_Node, New_List (Return_Node)); 818 Append (Case_Alt_Node, Alt_List); 819 820 Set_Alternatives (Case_Node, Alt_List); 821 return Case_Node; 822 end Build_Case_Statement; 823 824 --------------------------- 825 -- Build_Dcheck_Function -- 826 --------------------------- 827 828 function Build_Dcheck_Function 829 (Case_Id : Entity_Id; 830 Variant : Node_Id) 831 return Entity_Id 832 is 833 Body_Node : Node_Id; 834 Func_Id : Entity_Id; 835 Parameter_List : List_Id; 836 Spec_Node : Node_Id; 837 838 begin 839 Body_Node := New_Node (N_Subprogram_Body, Loc); 840 Sequence := Sequence + 1; 841 842 Func_Id := 843 Make_Defining_Identifier (Loc, 844 Chars => New_External_Name (Chars (Rec_Id), 'D', Sequence)); 845 846 Spec_Node := New_Node (N_Function_Specification, Loc); 847 Set_Defining_Unit_Name (Spec_Node, Func_Id); 848 849 Parameter_List := Build_Discriminant_Formals (Rec_Id, False); 850 851 Set_Parameter_Specifications (Spec_Node, Parameter_List); 852 Set_Subtype_Mark (Spec_Node, 853 New_Reference_To (Standard_Boolean, Loc)); 854 Set_Specification (Body_Node, Spec_Node); 855 Set_Declarations (Body_Node, New_List); 856 857 Set_Handled_Statement_Sequence (Body_Node, 858 Make_Handled_Sequence_Of_Statements (Loc, 859 Statements => New_List ( 860 Build_Case_Statement (Case_Id, Variant)))); 861 862 Set_Ekind (Func_Id, E_Function); 863 Set_Mechanism (Func_Id, Default_Mechanism); 864 Set_Is_Inlined (Func_Id, True); 865 Set_Is_Pure (Func_Id, True); 866 Set_Is_Public (Func_Id, Is_Public (Rec_Id)); 867 Set_Is_Internal (Func_Id, True); 868 869 if not Debug_Generated_Code then 870 Set_Debug_Info_Off (Func_Id); 871 end if; 872 873 Analyze (Body_Node); 874 875 Append_Freeze_Action (Rec_Id, Body_Node); 876 Set_Dcheck_Function (Variant, Func_Id); 877 return Func_Id; 878 end Build_Dcheck_Function; 879 880 ---------------------------- 881 -- Build_Dcheck_Functions -- 882 ---------------------------- 883 884 procedure Build_Dcheck_Functions (Variant_Part_Node : Node_Id) is 885 Component_List_Node : Node_Id; 886 Decl : Entity_Id; 887 Discr_Name : Entity_Id; 888 Func_Id : Entity_Id; 889 Variant : Node_Id; 890 Saved_Enclosing_Func_Id : Entity_Id; 891 892 begin 893 -- Build the discriminant checking function for each variant, label 894 -- all components of that variant with the function's name. 895 896 Discr_Name := Entity (Name (Variant_Part_Node)); 897 Variant := First_Non_Pragma (Variants (Variant_Part_Node)); 898 899 while Present (Variant) loop 900 Func_Id := Build_Dcheck_Function (Discr_Name, Variant); 901 Component_List_Node := Component_List (Variant); 902 903 if not Null_Present (Component_List_Node) then 904 Decl := 905 First_Non_Pragma (Component_Items (Component_List_Node)); 906 907 while Present (Decl) loop 908 Set_Discriminant_Checking_Func 909 (Defining_Identifier (Decl), Func_Id); 910 911 Next_Non_Pragma (Decl); 912 end loop; 913 914 if Present (Variant_Part (Component_List_Node)) then 915 Saved_Enclosing_Func_Id := Enclosing_Func_Id; 916 Enclosing_Func_Id := Func_Id; 917 Build_Dcheck_Functions (Variant_Part (Component_List_Node)); 918 Enclosing_Func_Id := Saved_Enclosing_Func_Id; 919 end if; 920 end if; 921 922 Next_Non_Pragma (Variant); 923 end loop; 924 end Build_Dcheck_Functions; 925 926 -- Start of processing for Build_Discr_Checking_Funcs 927 928 begin 929 -- Only build if not done already 930 931 if not Discr_Check_Funcs_Built (N) then 932 Type_Def := Type_Definition (N); 933 934 if Nkind (Type_Def) = N_Record_Definition then 935 if No (Component_List (Type_Def)) then -- null record. 936 return; 937 else 938 V := Variant_Part (Component_List (Type_Def)); 939 end if; 940 941 else pragma Assert (Nkind (Type_Def) = N_Derived_Type_Definition); 942 if No (Component_List (Record_Extension_Part (Type_Def))) then 943 return; 944 else 945 V := Variant_Part 946 (Component_List (Record_Extension_Part (Type_Def))); 947 end if; 948 end if; 949 950 Rec_Id := Defining_Identifier (N); 951 952 if Present (V) and then not Is_Unchecked_Union (Rec_Id) then 953 Loc := Sloc (N); 954 Enclosing_Func_Id := Empty; 955 Build_Dcheck_Functions (V); 956 end if; 957 958 Set_Discr_Check_Funcs_Built (N); 959 end if; 960 end Build_Discr_Checking_Funcs; 961 962 -------------------------------- 963 -- Build_Discriminant_Formals -- 964 -------------------------------- 965 966 function Build_Discriminant_Formals 967 (Rec_Id : Entity_Id; 968 Use_Dl : Boolean) 969 return List_Id 970 is 971 Loc : Source_Ptr := Sloc (Rec_Id); 972 Parameter_List : constant List_Id := New_List; 973 D : Entity_Id; 974 Formal : Entity_Id; 975 Param_Spec_Node : Node_Id; 976 977 begin 978 if Has_Discriminants (Rec_Id) then 979 D := First_Discriminant (Rec_Id); 980 while Present (D) loop 981 Loc := Sloc (D); 982 983 if Use_Dl then 984 Formal := Discriminal (D); 985 else 986 Formal := Make_Defining_Identifier (Loc, Chars (D)); 987 end if; 988 989 Param_Spec_Node := 990 Make_Parameter_Specification (Loc, 991 Defining_Identifier => Formal, 992 Parameter_Type => 993 New_Reference_To (Etype (D), Loc)); 994 Append (Param_Spec_Node, Parameter_List); 995 Next_Discriminant (D); 996 end loop; 997 end if; 998 999 return Parameter_List; 1000 end Build_Discriminant_Formals; 1001 1002 ------------------------------- 1003 -- Build_Initialization_Call -- 1004 ------------------------------- 1005 1006 -- References to a discriminant inside the record type declaration 1007 -- can appear either in the subtype_indication to constrain a 1008 -- record or an array, or as part of a larger expression given for 1009 -- the initial value of a component. In both of these cases N appears 1010 -- in the record initialization procedure and needs to be replaced by 1011 -- the formal parameter of the initialization procedure which 1012 -- corresponds to that discriminant. 1013 1014 -- In the example below, references to discriminants D1 and D2 in proc_1 1015 -- are replaced by references to formals with the same name 1016 -- (discriminals) 1017 1018 -- A similar replacement is done for calls to any record 1019 -- initialization procedure for any components that are themselves 1020 -- of a record type. 1021 1022 -- type R (D1, D2 : Integer) is record 1023 -- X : Integer := F * D1; 1024 -- Y : Integer := F * D2; 1025 -- end record; 1026 1027 -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is 1028 -- begin 1029 -- Out_2.D1 := D1; 1030 -- Out_2.D2 := D2; 1031 -- Out_2.X := F * D1; 1032 -- Out_2.Y := F * D2; 1033 -- end; 1034 1035 function Build_Initialization_Call 1036 (Loc : Source_Ptr; 1037 Id_Ref : Node_Id; 1038 Typ : Entity_Id; 1039 In_Init_Proc : Boolean := False; 1040 Enclos_Type : Entity_Id := Empty; 1041 Discr_Map : Elist_Id := New_Elmt_List; 1042 With_Default_Init : Boolean := False) 1043 return List_Id 1044 is 1045 First_Arg : Node_Id; 1046 Args : List_Id; 1047 Decls : List_Id; 1048 Decl : Node_Id; 1049 Discr : Entity_Id; 1050 Arg : Node_Id; 1051 Proc : constant Entity_Id := Base_Init_Proc (Typ); 1052 Init_Type : constant Entity_Id := Etype (First_Formal (Proc)); 1053 Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type); 1054 Res : constant List_Id := New_List; 1055 Full_Type : Entity_Id := Typ; 1056 Controller_Typ : Entity_Id; 1057 1058 begin 1059 -- Nothing to do if the Init_Proc is null, unless Initialize_Sclalars 1060 -- is active (in which case we make the call anyway, since in the 1061 -- actual compiled client it may be non null). 1062 1063 if Is_Null_Init_Proc (Proc) and then not Init_Or_Norm_Scalars then 1064 return Empty_List; 1065 end if; 1066 1067 -- Go to full view if private type. In the case of successive 1068 -- private derivations, this can require more than one step. 1069 1070 while Is_Private_Type (Full_Type) 1071 and then Present (Full_View (Full_Type)) 1072 loop 1073 Full_Type := Full_View (Full_Type); 1074 end loop; 1075 1076 -- If Typ is derived, the procedure is the initialization procedure for 1077 -- the root type. Wrap the argument in an conversion to make it type 1078 -- honest. Actually it isn't quite type honest, because there can be 1079 -- conflicts of views in the private type case. That is why we set 1080 -- Conversion_OK in the conversion node. 1081 if (Is_Record_Type (Typ) 1082 or else Is_Array_Type (Typ) 1083 or else Is_Private_Type (Typ)) 1084 and then Init_Type /= Base_Type (Typ) 1085 then 1086 First_Arg := OK_Convert_To (Etype (Init_Type), Id_Ref); 1087 Set_Etype (First_Arg, Init_Type); 1088 1089 else 1090 First_Arg := Id_Ref; 1091 end if; 1092 1093 Args := New_List (Convert_Concurrent (First_Arg, Typ)); 1094 1095 -- In the tasks case, add _Master as the value of the _Master parameter 1096 -- and _Chain as the value of the _Chain parameter. At the outer level, 1097 -- these will be variables holding the corresponding values obtained 1098 -- from GNARL. At inner levels, they will be the parameters passed down 1099 -- through the outer routines. 1100 1101 if Has_Task (Full_Type) then 1102 if Restrictions (No_Task_Hierarchy) then 1103 1104 -- See comments in System.Tasking.Initialization.Init_RTS 1105 -- for the value 3 (should be rtsfindable constant ???) 1106 1107 Append_To (Args, Make_Integer_Literal (Loc, 3)); 1108 else 1109 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 1110 end if; 1111 1112 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 1113 1114 -- Ada0Y (AI-287): In case of default initialized components 1115 -- with tasks, we generate a null string actual parameter. 1116 -- This is just a workaround that must be improved later??? 1117 1118 if With_Default_Init then 1119 declare 1120 S : String_Id; 1121 Null_String : Node_Id; 1122 begin 1123 Start_String; 1124 S := End_String; 1125 Null_String := Make_String_Literal (Loc, Strval => S); 1126 Append_To (Args, Null_String); 1127 end; 1128 else 1129 Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type); 1130 Decl := Last (Decls); 1131 1132 Append_To (Args, 1133 New_Occurrence_Of (Defining_Identifier (Decl), Loc)); 1134 Append_List (Decls, Res); 1135 end if; 1136 1137 else 1138 Decls := No_List; 1139 Decl := Empty; 1140 end if; 1141 1142 -- Add discriminant values if discriminants are present 1143 1144 if Has_Discriminants (Full_Init_Type) then 1145 Discr := First_Discriminant (Full_Init_Type); 1146 1147 while Present (Discr) loop 1148 1149 -- If this is a discriminated concurrent type, the init_proc 1150 -- for the corresponding record is being called. Use that 1151 -- type directly to find the discriminant value, to handle 1152 -- properly intervening renamed discriminants. 1153 1154 declare 1155 T : Entity_Id := Full_Type; 1156 1157 begin 1158 if Is_Protected_Type (T) then 1159 T := Corresponding_Record_Type (T); 1160 1161 elsif Is_Private_Type (T) 1162 and then Present (Underlying_Full_View (T)) 1163 and then Is_Protected_Type (Underlying_Full_View (T)) 1164 then 1165 T := Corresponding_Record_Type (Underlying_Full_View (T)); 1166 end if; 1167 1168 Arg := 1169 Get_Discriminant_Value ( 1170 Discr, 1171 T, 1172 Discriminant_Constraint (Full_Type)); 1173 end; 1174 1175 if In_Init_Proc then 1176 1177 -- Replace any possible references to the discriminant in the 1178 -- call to the record initialization procedure with references 1179 -- to the appropriate formal parameter. 1180 1181 if Nkind (Arg) = N_Identifier 1182 and then Ekind (Entity (Arg)) = E_Discriminant 1183 then 1184 Arg := New_Reference_To (Discriminal (Entity (Arg)), Loc); 1185 1186 -- Case of access discriminants. We replace the reference 1187 -- to the type by a reference to the actual object 1188 1189 elsif Nkind (Arg) = N_Attribute_Reference 1190 and then Is_Access_Type (Etype (Arg)) 1191 and then Is_Entity_Name (Prefix (Arg)) 1192 and then Is_Type (Entity (Prefix (Arg))) 1193 then 1194 Arg := 1195 Make_Attribute_Reference (Loc, 1196 Prefix => New_Copy (Prefix (Id_Ref)), 1197 Attribute_Name => Name_Unrestricted_Access); 1198 1199 -- Otherwise make a copy of the default expression. Note 1200 -- that we use the current Sloc for this, because we do not 1201 -- want the call to appear to be at the declaration point. 1202 -- Within the expression, replace discriminants with their 1203 -- discriminals. 1204 1205 else 1206 Arg := 1207 New_Copy_Tree (Arg, Map => Discr_Map, New_Sloc => Loc); 1208 end if; 1209 1210 else 1211 if Is_Constrained (Full_Type) then 1212 Arg := Duplicate_Subexpr_No_Checks (Arg); 1213 else 1214 -- The constraints come from the discriminant default 1215 -- exps, they must be reevaluated, so we use New_Copy_Tree 1216 -- but we ensure the proper Sloc (for any embedded calls). 1217 1218 Arg := New_Copy_Tree (Arg, New_Sloc => Loc); 1219 end if; 1220 end if; 1221 1222 -- Ada0Y (AI-287) In case of default initialized components, we 1223 -- need to generate the corresponding selected component node 1224 -- to access the discriminant value. In other cases this is not 1225 -- required because we are inside the init proc and we use the 1226 -- corresponding formal. 1227 1228 if With_Default_Init 1229 and then Nkind (Id_Ref) = N_Selected_Component 1230 then 1231 Append_To (Args, 1232 Make_Selected_Component (Loc, 1233 Prefix => New_Copy_Tree (Prefix (Id_Ref)), 1234 Selector_Name => Arg)); 1235 else 1236 Append_To (Args, Arg); 1237 end if; 1238 1239 Next_Discriminant (Discr); 1240 end loop; 1241 end if; 1242 1243 -- If this is a call to initialize the parent component of a derived 1244 -- tagged type, indicate that the tag should not be set in the parent. 1245 1246 if Is_Tagged_Type (Full_Init_Type) 1247 and then not Is_CPP_Class (Full_Init_Type) 1248 and then Nkind (Id_Ref) = N_Selected_Component 1249 and then Chars (Selector_Name (Id_Ref)) = Name_uParent 1250 then 1251 Append_To (Args, New_Occurrence_Of (Standard_False, Loc)); 1252 end if; 1253 1254 Append_To (Res, 1255 Make_Procedure_Call_Statement (Loc, 1256 Name => New_Occurrence_Of (Proc, Loc), 1257 Parameter_Associations => Args)); 1258 1259 if Controlled_Type (Typ) 1260 and then Nkind (Id_Ref) = N_Selected_Component 1261 then 1262 if Chars (Selector_Name (Id_Ref)) /= Name_uParent then 1263 Append_List_To (Res, 1264 Make_Init_Call ( 1265 Ref => New_Copy_Tree (First_Arg), 1266 Typ => Typ, 1267 Flist_Ref => 1268 Find_Final_List (Typ, New_Copy_Tree (First_Arg)), 1269 With_Attach => Make_Integer_Literal (Loc, 1))); 1270 1271 -- If the enclosing type is an extension with new controlled 1272 -- components, it has his own record controller. If the parent 1273 -- also had a record controller, attach it to the new one. 1274 -- Build_Init_Statements relies on the fact that in this specific 1275 -- case the last statement of the result is the attach call to 1276 -- the controller. If this is changed, it must be synchronized. 1277 1278 elsif Present (Enclos_Type) 1279 and then Has_New_Controlled_Component (Enclos_Type) 1280 and then Has_Controlled_Component (Typ) 1281 then 1282 if Is_Return_By_Reference_Type (Typ) then 1283 Controller_Typ := RTE (RE_Limited_Record_Controller); 1284 else 1285 Controller_Typ := RTE (RE_Record_Controller); 1286 end if; 1287 1288 Append_List_To (Res, 1289 Make_Init_Call ( 1290 Ref => 1291 Make_Selected_Component (Loc, 1292 Prefix => New_Copy_Tree (First_Arg), 1293 Selector_Name => Make_Identifier (Loc, Name_uController)), 1294 Typ => Controller_Typ, 1295 Flist_Ref => Find_Final_List (Typ, New_Copy_Tree (First_Arg)), 1296 With_Attach => Make_Integer_Literal (Loc, 1))); 1297 end if; 1298 end if; 1299 1300 return Res; 1301 1302 exception 1303 when RE_Not_Available => 1304 return Empty_List; 1305 end Build_Initialization_Call; 1306 1307 --------------------------- 1308 -- Build_Master_Renaming -- 1309 --------------------------- 1310 1311 procedure Build_Master_Renaming (N : Node_Id; T : Entity_Id) is 1312 Loc : constant Source_Ptr := Sloc (N); 1313 M_Id : Entity_Id; 1314 Decl : Node_Id; 1315 1316 begin 1317 -- Nothing to do if there is no task hierarchy. 1318 1319 if Restrictions (No_Task_Hierarchy) then 1320 return; 1321 end if; 1322 1323 M_Id := 1324 Make_Defining_Identifier (Loc, 1325 New_External_Name (Chars (T), 'M')); 1326 1327 Decl := 1328 Make_Object_Renaming_Declaration (Loc, 1329 Defining_Identifier => M_Id, 1330 Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), 1331 Name => Make_Identifier (Loc, Name_uMaster)); 1332 Insert_Before (N, Decl); 1333 Analyze (Decl); 1334 1335 Set_Master_Id (T, M_Id); 1336 1337 exception 1338 when RE_Not_Available => 1339 return; 1340 end Build_Master_Renaming; 1341 1342 ---------------------------- 1343 -- Build_Record_Init_Proc -- 1344 ---------------------------- 1345 1346 procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is 1347 Loc : Source_Ptr := Sloc (N); 1348 Discr_Map : constant Elist_Id := New_Elmt_List; 1349 Proc_Id : Entity_Id; 1350 Rec_Type : Entity_Id; 1351 Set_Tag : Entity_Id := Empty; 1352 1353 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id; 1354 -- Build a assignment statement node which assigns to record 1355 -- component its default expression if defined. The left hand side 1356 -- of the assignment is marked Assignment_OK so that initialization 1357 -- of limited private records works correctly, Return also the 1358 -- adjustment call for controlled objects 1359 1360 procedure Build_Discriminant_Assignments (Statement_List : List_Id); 1361 -- If the record has discriminants, adds assignment statements to 1362 -- statement list to initialize the discriminant values from the 1363 -- arguments of the initialization procedure. 1364 1365 function Build_Init_Statements (Comp_List : Node_Id) return List_Id; 1366 -- Build a list representing a sequence of statements which initialize 1367 -- components of the given component list. This may involve building 1368 -- case statements for the variant parts. 1369 1370 function Build_Init_Call_Thru 1371 (Parameters : List_Id) 1372 return List_Id; 1373 -- Given a non-tagged type-derivation that declares discriminants, 1374 -- such as 1375 -- 1376 -- type R (R1, R2 : Integer) is record ... end record; 1377 -- 1378 -- type D (D1 : Integer) is new R (1, D1); 1379 -- 1380 -- we make the _init_proc of D be 1381 -- 1382 -- procedure _init_proc(X : D; D1 : Integer) is 1383 -- begin 1384 -- _init_proc( R(X), 1, D1); 1385 -- end _init_proc; 1386 -- 1387 -- This function builds the call statement in this _init_proc. 1388 1389 procedure Build_Init_Procedure; 1390 -- Build the tree corresponding to the procedure specification and body 1391 -- of the initialization procedure (by calling all the preceding 1392 -- auxiliary routines), and install it as the _init TSS. 1393 1394 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id); 1395 -- Add range checks to components of disciminated records. S is a 1396 -- subtype indication of a record component. Check_List is a list 1397 -- to which the check actions are appended. 1398 1399 function Component_Needs_Simple_Initialization 1400 (T : Entity_Id) 1401 return Boolean; 1402 -- Determines if a component needs simple initialization, given its 1403 -- type T. This is the same as Needs_Simple_Initialization except 1404 -- for the following differences. The types Tag and Vtable_Ptr, 1405 -- which are access types which would normally require simple 1406 -- initialization to null, do not require initialization as 1407 -- components, since they are explicitly initialized by other 1408 -- means. The other relaxation is for packed bit arrays that are 1409 -- associated with a modular type, which in some cases require 1410 -- zero initialization to properly support comparisons, except 1411 -- that comparison of such components always involves an explicit 1412 -- selection of only the component's specific bits (whether or not 1413 -- there are adjacent components or gaps), so zero initialization 1414 -- is never needed for components. 1415 1416 procedure Constrain_Array 1417 (SI : Node_Id; 1418 Check_List : List_Id); 1419 -- Called from Build_Record_Checks. 1420 -- Apply a list of index constraints to an unconstrained array type. 1421 -- The first parameter is the entity for the resulting subtype. 1422 -- Check_List is a list to which the check actions are appended. 1423 1424 procedure Constrain_Index 1425 (Index : Node_Id; 1426 S : Node_Id; 1427 Check_List : List_Id); 1428 -- Called from Build_Record_Checks. 1429 -- Process an index constraint in a constrained array declaration. 1430 -- The constraint can be a subtype name, or a range with or without 1431 -- an explicit subtype mark. The index is the corresponding index of the 1432 -- unconstrained array. S is the range expression. Check_List is a list 1433 -- to which the check actions are appended. 1434 1435 function Parent_Subtype_Renaming_Discrims return Boolean; 1436 -- Returns True for base types N that rename discriminants, else False 1437 1438 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; 1439 -- Determines whether a record initialization procedure needs to be 1440 -- generated for the given record type. 1441 1442 ---------------------- 1443 -- Build_Assignment -- 1444 ---------------------- 1445 1446 function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is 1447 Exp : Node_Id := N; 1448 Lhs : Node_Id; 1449 Typ : constant Entity_Id := Underlying_Type (Etype (Id)); 1450 Kind : Node_Kind := Nkind (N); 1451 Res : List_Id; 1452 1453 begin 1454 Loc := Sloc (N); 1455 Lhs := 1456 Make_Selected_Component (Loc, 1457 Prefix => Make_Identifier (Loc, Name_uInit), 1458 Selector_Name => New_Occurrence_Of (Id, Loc)); 1459 Set_Assignment_OK (Lhs); 1460 1461 -- Case of an access attribute applied to the current 1462 -- instance. Replace the reference to the type by a 1463 -- reference to the actual object. (Note that this 1464 -- handles the case of the top level of the expression 1465 -- being given by such an attribute, but doesn't cover 1466 -- uses nested within an initial value expression. 1467 -- Nested uses are unlikely to occur in practice, 1468 -- but theoretically possible. It's not clear how 1469 -- to handle them without fully traversing the 1470 -- expression. ???) 1471 1472 if Kind = N_Attribute_Reference 1473 and then (Attribute_Name (N) = Name_Unchecked_Access 1474 or else 1475 Attribute_Name (N) = Name_Unrestricted_Access) 1476 and then Is_Entity_Name (Prefix (N)) 1477 and then Is_Type (Entity (Prefix (N))) 1478 and then Entity (Prefix (N)) = Rec_Type 1479 then 1480 Exp := 1481 Make_Attribute_Reference (Loc, 1482 Prefix => Make_Identifier (Loc, Name_uInit), 1483 Attribute_Name => Name_Unrestricted_Access); 1484 end if; 1485 1486 -- For a derived type the default value is copied from the component 1487 -- declaration of the parent. In the analysis of the init_proc for 1488 -- the parent the default value may have been expanded into a local 1489 -- variable, which is of course not usable here. We must copy the 1490 -- original expression and reanalyze. 1491 1492 if Nkind (Exp) = N_Identifier 1493 and then not Comes_From_Source (Exp) 1494 and then Analyzed (Exp) 1495 and then not In_Open_Scopes (Scope (Entity (Exp))) 1496 and then Nkind (Original_Node (Exp)) = N_Aggregate 1497 then 1498 Exp := New_Copy_Tree (Original_Node (Exp)); 1499 end if; 1500 1501 Res := New_List ( 1502 Make_Assignment_Statement (Loc, 1503 Name => Lhs, 1504 Expression => Exp)); 1505 1506 Set_No_Ctrl_Actions (First (Res)); 1507 1508 -- Adjust the tag if tagged (because of possible view conversions). 1509 -- Suppress the tag adjustment when Java_VM because JVM tags are 1510 -- represented implicitly in objects. 1511 1512 if Is_Tagged_Type (Typ) and then not Java_VM then 1513 Append_To (Res, 1514 Make_Assignment_Statement (Loc, 1515 Name => 1516 Make_Selected_Component (Loc, 1517 Prefix => New_Copy_Tree (Lhs), 1518 Selector_Name => 1519 New_Reference_To (Tag_Component (Typ), Loc)), 1520 1521 Expression => 1522 Unchecked_Convert_To (RTE (RE_Tag), 1523 New_Reference_To (Access_Disp_Table (Typ), Loc)))); 1524 end if; 1525 1526 -- Adjust the component if controlled except if it is an 1527 -- aggregate that will be expanded inline 1528 1529 if Kind = N_Qualified_Expression then 1530 Kind := Nkind (Expression (N)); 1531 end if; 1532 1533 if Controlled_Type (Typ) 1534 and then not (Kind = N_Aggregate or else Kind = N_Extension_Aggregate) 1535 then 1536 Append_List_To (Res, 1537 Make_Adjust_Call ( 1538 Ref => New_Copy_Tree (Lhs), 1539 Typ => Etype (Id), 1540 Flist_Ref => 1541 Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)), 1542 With_Attach => Make_Integer_Literal (Loc, 1))); 1543 end if; 1544 1545 return Res; 1546 1547 exception 1548 when RE_Not_Available => 1549 return Empty_List; 1550 end Build_Assignment; 1551 1552 ------------------------------------ 1553 -- Build_Discriminant_Assignments -- 1554 ------------------------------------ 1555 1556 procedure Build_Discriminant_Assignments (Statement_List : List_Id) is 1557 D : Entity_Id; 1558 Is_Tagged : constant Boolean := Is_Tagged_Type (Rec_Type); 1559 1560 begin 1561 if Has_Discriminants (Rec_Type) 1562 and then not Is_Unchecked_Union (Rec_Type) 1563 then 1564 D := First_Discriminant (Rec_Type); 1565 1566 while Present (D) loop 1567 -- Don't generate the assignment for discriminants in derived 1568 -- tagged types if the discriminant is a renaming of some 1569 -- ancestor discriminant. This initialization will be done 1570 -- when initializing the _parent field of the derived record. 1571 1572 if Is_Tagged and then 1573 Present (Corresponding_Discriminant (D)) 1574 then 1575 null; 1576 1577 else 1578 Loc := Sloc (D); 1579 Append_List_To (Statement_List, 1580 Build_Assignment (D, 1581 New_Reference_To (Discriminal (D), Loc))); 1582 end if; 1583 1584 Next_Discriminant (D); 1585 end loop; 1586 end if; 1587 end Build_Discriminant_Assignments; 1588 1589 -------------------------- 1590 -- Build_Init_Call_Thru -- 1591 -------------------------- 1592 1593 function Build_Init_Call_Thru 1594 (Parameters : List_Id) 1595 return List_Id 1596 is 1597 Parent_Proc : constant Entity_Id := 1598 Base_Init_Proc (Etype (Rec_Type)); 1599 1600 Parent_Type : constant Entity_Id := 1601 Etype (First_Formal (Parent_Proc)); 1602 1603 Uparent_Type : constant Entity_Id := 1604 Underlying_Type (Parent_Type); 1605 1606 First_Discr_Param : Node_Id; 1607 1608 Parent_Discr : Entity_Id; 1609 First_Arg : Node_Id; 1610 Args : List_Id; 1611 Arg : Node_Id; 1612 Res : List_Id; 1613 1614 begin 1615 -- First argument (_Init) is the object to be initialized. 1616 -- ??? not sure where to get a reasonable Loc for First_Arg 1617 1618 First_Arg := 1619 OK_Convert_To (Parent_Type, 1620 New_Reference_To (Defining_Identifier (First (Parameters)), Loc)); 1621 1622 Set_Etype (First_Arg, Parent_Type); 1623 1624 Args := New_List (Convert_Concurrent (First_Arg, Rec_Type)); 1625 1626 -- In the tasks case, 1627 -- add _Master as the value of the _Master parameter 1628 -- add _Chain as the value of the _Chain parameter. 1629 -- add _Task_Name as the value of the _Task_Name parameter. 1630 -- At the outer level, these will be variables holding the 1631 -- corresponding values obtained from GNARL or the expander. 1632 -- 1633 -- At inner levels, they will be the parameters passed down through 1634 -- the outer routines. 1635 1636 First_Discr_Param := Next (First (Parameters)); 1637 1638 if Has_Task (Rec_Type) then 1639 if Restrictions (No_Task_Hierarchy) then 1640 1641 -- See comments in System.Tasking.Initialization.Init_RTS 1642 -- for the value 3. 1643 1644 Append_To (Args, Make_Integer_Literal (Loc, 3)); 1645 else 1646 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 1647 end if; 1648 1649 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 1650 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 1651 First_Discr_Param := Next (Next (Next (First_Discr_Param))); 1652 end if; 1653 1654 -- Append discriminant values 1655 1656 if Has_Discriminants (Uparent_Type) then 1657 pragma Assert (not Is_Tagged_Type (Uparent_Type)); 1658 1659 Parent_Discr := First_Discriminant (Uparent_Type); 1660 while Present (Parent_Discr) loop 1661 1662 -- Get the initial value for this discriminant 1663 -- ??? needs to be cleaned up to use parent_Discr_Constr 1664 -- directly. 1665 1666 declare 1667 Discr_Value : Elmt_Id := 1668 First_Elmt 1669 (Stored_Constraint (Rec_Type)); 1670 1671 Discr : Entity_Id := 1672 First_Stored_Discriminant (Uparent_Type); 1673 begin 1674 while Original_Record_Component (Parent_Discr) /= Discr loop 1675 Next_Stored_Discriminant (Discr); 1676 Next_Elmt (Discr_Value); 1677 end loop; 1678 1679 Arg := Node (Discr_Value); 1680 end; 1681 1682 -- Append it to the list 1683 1684 if Nkind (Arg) = N_Identifier 1685 and then Ekind (Entity (Arg)) = E_Discriminant 1686 then 1687 Append_To (Args, 1688 New_Reference_To (Discriminal (Entity (Arg)), Loc)); 1689 1690 -- Case of access discriminants. We replace the reference 1691 -- to the type by a reference to the actual object 1692 1693-- ??? why is this code deleted without comment 1694 1695-- elsif Nkind (Arg) = N_Attribute_Reference 1696-- and then Is_Entity_Name (Prefix (Arg)) 1697-- and then Is_Type (Entity (Prefix (Arg))) 1698-- then 1699-- Append_To (Args, 1700-- Make_Attribute_Reference (Loc, 1701-- Prefix => New_Copy (Prefix (Id_Ref)), 1702-- Attribute_Name => Name_Unrestricted_Access)); 1703 1704 else 1705 Append_To (Args, New_Copy (Arg)); 1706 end if; 1707 1708 Next_Discriminant (Parent_Discr); 1709 end loop; 1710 end if; 1711 1712 Res := 1713 New_List ( 1714 Make_Procedure_Call_Statement (Loc, 1715 Name => New_Occurrence_Of (Parent_Proc, Loc), 1716 Parameter_Associations => Args)); 1717 1718 return Res; 1719 end Build_Init_Call_Thru; 1720 1721 -------------------------- 1722 -- Build_Init_Procedure -- 1723 -------------------------- 1724 1725 procedure Build_Init_Procedure is 1726 Body_Node : Node_Id; 1727 Handled_Stmt_Node : Node_Id; 1728 Parameters : List_Id; 1729 Proc_Spec_Node : Node_Id; 1730 Body_Stmts : List_Id; 1731 Record_Extension_Node : Node_Id; 1732 Init_Tag : Node_Id; 1733 1734 begin 1735 Body_Stmts := New_List; 1736 Body_Node := New_Node (N_Subprogram_Body, Loc); 1737 1738 Proc_Id := 1739 Make_Defining_Identifier (Loc, 1740 Chars => Make_Init_Proc_Name (Rec_Type)); 1741 Set_Ekind (Proc_Id, E_Procedure); 1742 1743 Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); 1744 Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); 1745 1746 Parameters := Init_Formals (Rec_Type); 1747 Append_List_To (Parameters, 1748 Build_Discriminant_Formals (Rec_Type, True)); 1749 1750 -- For tagged types, we add a flag to indicate whether the routine 1751 -- is called to initialize a parent component in the init_proc of 1752 -- a type extension. If the flag is false, we do not set the tag 1753 -- because it has been set already in the extension. 1754 1755 if Is_Tagged_Type (Rec_Type) 1756 and then not Is_CPP_Class (Rec_Type) 1757 then 1758 Set_Tag := 1759 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 1760 1761 Append_To (Parameters, 1762 Make_Parameter_Specification (Loc, 1763 Defining_Identifier => Set_Tag, 1764 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc), 1765 Expression => New_Occurrence_Of (Standard_True, Loc))); 1766 end if; 1767 1768 Set_Parameter_Specifications (Proc_Spec_Node, Parameters); 1769 Set_Specification (Body_Node, Proc_Spec_Node); 1770 Set_Declarations (Body_Node, New_List); 1771 1772 if Parent_Subtype_Renaming_Discrims then 1773 1774 -- N is a Derived_Type_Definition that renames the parameters 1775 -- of the ancestor type. We init it by expanding our discrims 1776 -- and call the ancestor _init_proc with a type-converted object 1777 1778 Append_List_To (Body_Stmts, 1779 Build_Init_Call_Thru (Parameters)); 1780 1781 elsif Nkind (Type_Definition (N)) = N_Record_Definition then 1782 Build_Discriminant_Assignments (Body_Stmts); 1783 1784 if not Null_Present (Type_Definition (N)) then 1785 Append_List_To (Body_Stmts, 1786 Build_Init_Statements ( 1787 Component_List (Type_Definition (N)))); 1788 end if; 1789 1790 else 1791 -- N is a Derived_Type_Definition with a possible non-empty 1792 -- extension. The initialization of a type extension consists 1793 -- in the initialization of the components in the extension. 1794 1795 Build_Discriminant_Assignments (Body_Stmts); 1796 1797 Record_Extension_Node := 1798 Record_Extension_Part (Type_Definition (N)); 1799 1800 if not Null_Present (Record_Extension_Node) then 1801 declare 1802 Stmts : constant List_Id := 1803 Build_Init_Statements ( 1804 Component_List (Record_Extension_Node)); 1805 1806 begin 1807 -- The parent field must be initialized first because 1808 -- the offset of the new discriminants may depend on it 1809 1810 Prepend_To (Body_Stmts, Remove_Head (Stmts)); 1811 Append_List_To (Body_Stmts, Stmts); 1812 end; 1813 end if; 1814 end if; 1815 1816 -- Add here the assignment to instantiate the Tag 1817 1818 -- The assignement corresponds to the code: 1819 1820 -- _Init._Tag := Typ'Tag; 1821 1822 -- Suppress the tag assignment when Java_VM because JVM tags are 1823 -- represented implicitly in objects. 1824 1825 if Is_Tagged_Type (Rec_Type) 1826 and then not Is_CPP_Class (Rec_Type) 1827 and then not Java_VM 1828 then 1829 Init_Tag := 1830 Make_Assignment_Statement (Loc, 1831 Name => 1832 Make_Selected_Component (Loc, 1833 Prefix => Make_Identifier (Loc, Name_uInit), 1834 Selector_Name => 1835 New_Reference_To (Tag_Component (Rec_Type), Loc)), 1836 1837 Expression => 1838 New_Reference_To (Access_Disp_Table (Rec_Type), Loc)); 1839 1840 -- The tag must be inserted before the assignments to other 1841 -- components, because the initial value of the component may 1842 -- depend ot the tag (eg. through a dispatching operation on 1843 -- an access to the current type). The tag assignment is not done 1844 -- when initializing the parent component of a type extension, 1845 -- because in that case the tag is set in the extension. 1846 -- Extensions of imported C++ classes add a final complication, 1847 -- because we cannot inhibit tag setting in the constructor for 1848 -- the parent. In that case we insert the tag initialization 1849 -- after the calls to initialize the parent. 1850 1851 Init_Tag := 1852 Make_If_Statement (Loc, 1853 Condition => New_Occurrence_Of (Set_Tag, Loc), 1854 Then_Statements => New_List (Init_Tag)); 1855 1856 if not Is_CPP_Class (Etype (Rec_Type)) then 1857 Prepend_To (Body_Stmts, Init_Tag); 1858 1859 else 1860 declare 1861 Nod : Node_Id := First (Body_Stmts); 1862 1863 begin 1864 -- We assume the first init_proc call is for the parent 1865 1866 while Present (Next (Nod)) 1867 and then (Nkind (Nod) /= N_Procedure_Call_Statement 1868 or else not Is_Init_Proc (Name (Nod))) 1869 loop 1870 Nod := Next (Nod); 1871 end loop; 1872 1873 Insert_After (Nod, Init_Tag); 1874 end; 1875 end if; 1876 end if; 1877 1878 Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); 1879 Set_Statements (Handled_Stmt_Node, Body_Stmts); 1880 Set_Exception_Handlers (Handled_Stmt_Node, No_List); 1881 Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); 1882 1883 if not Debug_Generated_Code then 1884 Set_Debug_Info_Off (Proc_Id); 1885 end if; 1886 1887 -- Associate Init_Proc with type, and determine if the procedure 1888 -- is null (happens because of the Initialize_Scalars pragma case, 1889 -- where we have to generate a null procedure in case it is called 1890 -- by a client with Initialize_Scalars set). Such procedures have 1891 -- to be generated, but do not have to be called, so we mark them 1892 -- as null to suppress the call. 1893 1894 Set_Init_Proc (Rec_Type, Proc_Id); 1895 1896 if List_Length (Body_Stmts) = 1 1897 and then Nkind (First (Body_Stmts)) = N_Null_Statement 1898 then 1899 Set_Is_Null_Init_Proc (Proc_Id); 1900 end if; 1901 end Build_Init_Procedure; 1902 1903 --------------------------- 1904 -- Build_Init_Statements -- 1905 --------------------------- 1906 1907 function Build_Init_Statements (Comp_List : Node_Id) return List_Id is 1908 Check_List : constant List_Id := New_List; 1909 Alt_List : List_Id; 1910 Statement_List : List_Id; 1911 Stmts : List_Id; 1912 1913 Per_Object_Constraint_Components : Boolean; 1914 1915 Decl : Node_Id; 1916 Variant : Node_Id; 1917 1918 Id : Entity_Id; 1919 Typ : Entity_Id; 1920 1921 begin 1922 if Null_Present (Comp_List) then 1923 return New_List (Make_Null_Statement (Loc)); 1924 end if; 1925 1926 Statement_List := New_List; 1927 1928 -- Loop through components, skipping pragmas, in 2 steps. The first 1929 -- step deals with regular components. The second step deals with 1930 -- components have per object constraints, and no explicit initia- 1931 -- lization. 1932 1933 Per_Object_Constraint_Components := False; 1934 1935 -- First step : regular components. 1936 1937 Decl := First_Non_Pragma (Component_Items (Comp_List)); 1938 while Present (Decl) loop 1939 Loc := Sloc (Decl); 1940 Build_Record_Checks 1941 (Subtype_Indication (Component_Definition (Decl)), Check_List); 1942 1943 Id := Defining_Identifier (Decl); 1944 Typ := Etype (Id); 1945 1946 if Has_Per_Object_Constraint (Id) 1947 and then No (Expression (Decl)) 1948 then 1949 -- Skip processing for now and ask for a second pass 1950 1951 Per_Object_Constraint_Components := True; 1952 1953 else 1954 -- Case of explicit initialization 1955 1956 if Present (Expression (Decl)) then 1957 Stmts := Build_Assignment (Id, Expression (Decl)); 1958 1959 -- Case of composite component with its own Init_Proc 1960 1961 elsif Has_Non_Null_Base_Init_Proc (Typ) then 1962 Stmts := 1963 Build_Initialization_Call 1964 (Loc, 1965 Make_Selected_Component (Loc, 1966 Prefix => Make_Identifier (Loc, Name_uInit), 1967 Selector_Name => New_Occurrence_Of (Id, Loc)), 1968 Typ, 1969 True, 1970 Rec_Type, 1971 Discr_Map => Discr_Map); 1972 1973 -- Case of component needing simple initialization 1974 1975 elsif Component_Needs_Simple_Initialization (Typ) then 1976 Stmts := 1977 Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc)); 1978 1979 -- Nothing needed for this case 1980 1981 else 1982 Stmts := No_List; 1983 end if; 1984 1985 if Present (Check_List) then 1986 Append_List_To (Statement_List, Check_List); 1987 end if; 1988 1989 if Present (Stmts) then 1990 1991 -- Add the initialization of the record controller before 1992 -- the _Parent field is attached to it when the attachment 1993 -- can occur. It does not work to simply initialize the 1994 -- controller first: it must be initialized after the parent 1995 -- if the parent holds discriminants that can be used 1996 -- to compute the offset of the controller. We assume here 1997 -- that the last statement of the initialization call is the 1998 -- attachement of the parent (see Build_Initialization_Call) 1999 2000 if Chars (Id) = Name_uController 2001 and then Rec_Type /= Etype (Rec_Type) 2002 and then Has_Controlled_Component (Etype (Rec_Type)) 2003 and then Has_New_Controlled_Component (Rec_Type) 2004 then 2005 Insert_List_Before (Last (Statement_List), Stmts); 2006 else 2007 Append_List_To (Statement_List, Stmts); 2008 end if; 2009 end if; 2010 end if; 2011 2012 Next_Non_Pragma (Decl); 2013 end loop; 2014 2015 if Per_Object_Constraint_Components then 2016 2017 -- Second pass: components with per-object constraints 2018 2019 Decl := First_Non_Pragma (Component_Items (Comp_List)); 2020 2021 while Present (Decl) loop 2022 Loc := Sloc (Decl); 2023 Id := Defining_Identifier (Decl); 2024 Typ := Etype (Id); 2025 2026 if Has_Per_Object_Constraint (Id) 2027 and then No (Expression (Decl)) 2028 then 2029 if Has_Non_Null_Base_Init_Proc (Typ) then 2030 Append_List_To (Statement_List, 2031 Build_Initialization_Call (Loc, 2032 Make_Selected_Component (Loc, 2033 Prefix => Make_Identifier (Loc, Name_uInit), 2034 Selector_Name => New_Occurrence_Of (Id, Loc)), 2035 Typ, True, Rec_Type, Discr_Map => Discr_Map)); 2036 2037 elsif Component_Needs_Simple_Initialization (Typ) then 2038 Append_List_To (Statement_List, 2039 Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc))); 2040 end if; 2041 end if; 2042 2043 Next_Non_Pragma (Decl); 2044 end loop; 2045 end if; 2046 2047 -- Process the variant part 2048 2049 if Present (Variant_Part (Comp_List)) then 2050 Alt_List := New_List; 2051 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List))); 2052 2053 while Present (Variant) loop 2054 Loc := Sloc (Variant); 2055 Append_To (Alt_List, 2056 Make_Case_Statement_Alternative (Loc, 2057 Discrete_Choices => 2058 New_Copy_List (Discrete_Choices (Variant)), 2059 Statements => 2060 Build_Init_Statements (Component_List (Variant)))); 2061 2062 Next_Non_Pragma (Variant); 2063 end loop; 2064 2065 -- The expression of the case statement which is a reference 2066 -- to one of the discriminants is replaced by the appropriate 2067 -- formal parameter of the initialization procedure. 2068 2069 Append_To (Statement_List, 2070 Make_Case_Statement (Loc, 2071 Expression => 2072 New_Reference_To (Discriminal ( 2073 Entity (Name (Variant_Part (Comp_List)))), Loc), 2074 Alternatives => Alt_List)); 2075 end if; 2076 2077 -- For a task record type, add the task create call and calls 2078 -- to bind any interrupt (signal) entries. 2079 2080 if Is_Task_Record_Type (Rec_Type) then 2081 Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); 2082 2083 declare 2084 Task_Type : constant Entity_Id := 2085 Corresponding_Concurrent_Type (Rec_Type); 2086 Task_Decl : constant Node_Id := Parent (Task_Type); 2087 Task_Def : constant Node_Id := Task_Definition (Task_Decl); 2088 Vis_Decl : Node_Id; 2089 Ent : Entity_Id; 2090 2091 begin 2092 if Present (Task_Def) then 2093 Vis_Decl := First (Visible_Declarations (Task_Def)); 2094 while Present (Vis_Decl) loop 2095 Loc := Sloc (Vis_Decl); 2096 2097 if Nkind (Vis_Decl) = N_Attribute_Definition_Clause then 2098 if Get_Attribute_Id (Chars (Vis_Decl)) = 2099 Attribute_Address 2100 then 2101 Ent := Entity (Name (Vis_Decl)); 2102 2103 if Ekind (Ent) = E_Entry then 2104 Append_To (Statement_List, 2105 Make_Procedure_Call_Statement (Loc, 2106 Name => New_Reference_To ( 2107 RTE (RE_Bind_Interrupt_To_Entry), Loc), 2108 Parameter_Associations => New_List ( 2109 Make_Selected_Component (Loc, 2110 Prefix => 2111 Make_Identifier (Loc, Name_uInit), 2112 Selector_Name => 2113 Make_Identifier (Loc, Name_uTask_Id)), 2114 Entry_Index_Expression ( 2115 Loc, Ent, Empty, Task_Type), 2116 Expression (Vis_Decl)))); 2117 end if; 2118 end if; 2119 end if; 2120 2121 Next (Vis_Decl); 2122 end loop; 2123 end if; 2124 end; 2125 end if; 2126 2127 -- For a protected type, add statements generated by 2128 -- Make_Initialize_Protection. 2129 2130 if Is_Protected_Record_Type (Rec_Type) then 2131 Append_List_To (Statement_List, 2132 Make_Initialize_Protection (Rec_Type)); 2133 end if; 2134 2135 -- If no initializations when generated for component declarations 2136 -- corresponding to this Statement_List, append a null statement 2137 -- to the Statement_List to make it a valid Ada tree. 2138 2139 if Is_Empty_List (Statement_List) then 2140 Append (New_Node (N_Null_Statement, Loc), Statement_List); 2141 end if; 2142 2143 return Statement_List; 2144 2145 exception 2146 when RE_Not_Available => 2147 return Empty_List; 2148 end Build_Init_Statements; 2149 2150 ------------------------- 2151 -- Build_Record_Checks -- 2152 ------------------------- 2153 2154 procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is 2155 Subtype_Mark_Id : Entity_Id; 2156 2157 begin 2158 if Nkind (S) = N_Subtype_Indication then 2159 Find_Type (Subtype_Mark (S)); 2160 Subtype_Mark_Id := Entity (Subtype_Mark (S)); 2161 2162 -- Remaining processing depends on type 2163 2164 case Ekind (Subtype_Mark_Id) is 2165 2166 when Array_Kind => 2167 Constrain_Array (S, Check_List); 2168 2169 when others => 2170 null; 2171 end case; 2172 end if; 2173 end Build_Record_Checks; 2174 2175 ------------------------------------------- 2176 -- Component_Needs_Simple_Initialization -- 2177 ------------------------------------------- 2178 2179 function Component_Needs_Simple_Initialization 2180 (T : Entity_Id) 2181 return Boolean 2182 is 2183 begin 2184 return 2185 Needs_Simple_Initialization (T) 2186 and then not Is_RTE (T, RE_Tag) 2187 and then not Is_RTE (T, RE_Vtable_Ptr) 2188 and then not Is_Bit_Packed_Array (T); 2189 end Component_Needs_Simple_Initialization; 2190 2191 --------------------- 2192 -- Constrain_Array -- 2193 --------------------- 2194 2195 procedure Constrain_Array 2196 (SI : Node_Id; 2197 Check_List : List_Id) 2198 is 2199 C : constant Node_Id := Constraint (SI); 2200 Number_Of_Constraints : Nat := 0; 2201 Index : Node_Id; 2202 S, T : Entity_Id; 2203 2204 begin 2205 T := Entity (Subtype_Mark (SI)); 2206 2207 if Ekind (T) in Access_Kind then 2208 T := Designated_Type (T); 2209 end if; 2210 2211 S := First (Constraints (C)); 2212 2213 while Present (S) loop 2214 Number_Of_Constraints := Number_Of_Constraints + 1; 2215 Next (S); 2216 end loop; 2217 2218 -- In either case, the index constraint must provide a discrete 2219 -- range for each index of the array type and the type of each 2220 -- discrete range must be the same as that of the corresponding 2221 -- index. (RM 3.6.1) 2222 2223 S := First (Constraints (C)); 2224 Index := First_Index (T); 2225 Analyze (Index); 2226 2227 -- Apply constraints to each index type 2228 2229 for J in 1 .. Number_Of_Constraints loop 2230 Constrain_Index (Index, S, Check_List); 2231 Next (Index); 2232 Next (S); 2233 end loop; 2234 2235 end Constrain_Array; 2236 2237 --------------------- 2238 -- Constrain_Index -- 2239 --------------------- 2240 2241 procedure Constrain_Index 2242 (Index : Node_Id; 2243 S : Node_Id; 2244 Check_List : List_Id) 2245 is 2246 T : constant Entity_Id := Etype (Index); 2247 2248 begin 2249 if Nkind (S) = N_Range then 2250 Process_Range_Expr_In_Decl (S, T, Check_List); 2251 end if; 2252 end Constrain_Index; 2253 2254 -------------------------------------- 2255 -- Parent_Subtype_Renaming_Discrims -- 2256 -------------------------------------- 2257 2258 function Parent_Subtype_Renaming_Discrims return Boolean is 2259 De : Entity_Id; 2260 Dp : Entity_Id; 2261 2262 begin 2263 if Base_Type (Pe) /= Pe then 2264 return False; 2265 end if; 2266 2267 if Etype (Pe) = Pe 2268 or else not Has_Discriminants (Pe) 2269 or else Is_Constrained (Pe) 2270 or else Is_Tagged_Type (Pe) 2271 then 2272 return False; 2273 end if; 2274 2275 -- If there are no explicit stored discriminants we have inherited 2276 -- the root type discriminants so far, so no renamings occurred. 2277 2278 if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then 2279 return False; 2280 end if; 2281 2282 -- Check if we have done some trivial renaming of the parent 2283 -- discriminants, i.e. someting like 2284 -- 2285 -- type DT (X1,X2: int) is new PT (X1,X2); 2286 2287 De := First_Discriminant (Pe); 2288 Dp := First_Discriminant (Etype (Pe)); 2289 2290 while Present (De) loop 2291 pragma Assert (Present (Dp)); 2292 2293 if Corresponding_Discriminant (De) /= Dp then 2294 return True; 2295 end if; 2296 2297 Next_Discriminant (De); 2298 Next_Discriminant (Dp); 2299 end loop; 2300 2301 return Present (Dp); 2302 end Parent_Subtype_Renaming_Discrims; 2303 2304 ------------------------ 2305 -- Requires_Init_Proc -- 2306 ------------------------ 2307 2308 function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is 2309 Comp_Decl : Node_Id; 2310 Id : Entity_Id; 2311 Typ : Entity_Id; 2312 2313 begin 2314 -- Definitely do not need one if specifically suppressed 2315 2316 if Suppress_Init_Proc (Rec_Id) then 2317 return False; 2318 end if; 2319 2320 -- Otherwise we need to generate an initialization procedure if 2321 -- Is_CPP_Class is False and at least one of the following applies: 2322 2323 -- 1. Discriminants are present, since they need to be initialized 2324 -- with the appropriate discriminant constraint expressions. 2325 -- However, the discriminant of an unchecked union does not 2326 -- count, since the discriminant is not present. 2327 2328 -- 2. The type is a tagged type, since the implicit Tag component 2329 -- needs to be initialized with a pointer to the dispatch table. 2330 2331 -- 3. The type contains tasks 2332 2333 -- 4. One or more components has an initial value 2334 2335 -- 5. One or more components is for a type which itself requires 2336 -- an initialization procedure. 2337 2338 -- 6. One or more components is a type that requires simple 2339 -- initialization (see Needs_Simple_Initialization), except 2340 -- that types Tag and Vtable_Ptr are excluded, since fields 2341 -- of these types are initialized by other means. 2342 2343 -- 7. The type is the record type built for a task type (since at 2344 -- the very least, Create_Task must be called) 2345 2346 -- 8. The type is the record type built for a protected type (since 2347 -- at least Initialize_Protection must be called) 2348 2349 -- 9. The type is marked as a public entity. The reason we add this 2350 -- case (even if none of the above apply) is to properly handle 2351 -- Initialize_Scalars. If a package is compiled without an IS 2352 -- pragma, and the client is compiled with an IS pragma, then 2353 -- the client will think an initialization procedure is present 2354 -- and call it, when in fact no such procedure is required, but 2355 -- since the call is generated, there had better be a routine 2356 -- at the other end of the call, even if it does nothing!) 2357 2358 -- Note: the reason we exclude the CPP_Class case is ??? 2359 2360 if Is_CPP_Class (Rec_Id) then 2361 return False; 2362 2363 elsif not Restrictions (No_Initialize_Scalars) 2364 and then Is_Public (Rec_Id) 2365 then 2366 return True; 2367 2368 elsif (Has_Discriminants (Rec_Id) 2369 and then not Is_Unchecked_Union (Rec_Id)) 2370 or else Is_Tagged_Type (Rec_Id) 2371 or else Is_Concurrent_Record_Type (Rec_Id) 2372 or else Has_Task (Rec_Id) 2373 then 2374 return True; 2375 end if; 2376 2377 Id := First_Component (Rec_Id); 2378 2379 while Present (Id) loop 2380 Comp_Decl := Parent (Id); 2381 Typ := Etype (Id); 2382 2383 if Present (Expression (Comp_Decl)) 2384 or else Has_Non_Null_Base_Init_Proc (Typ) 2385 or else Component_Needs_Simple_Initialization (Typ) 2386 then 2387 return True; 2388 end if; 2389 2390 Next_Component (Id); 2391 end loop; 2392 2393 return False; 2394 end Requires_Init_Proc; 2395 2396 -- Start of processing for Build_Record_Init_Proc 2397 2398 begin 2399 Rec_Type := Defining_Identifier (N); 2400 2401 -- This may be full declaration of a private type, in which case 2402 -- the visible entity is a record, and the private entity has been 2403 -- exchanged with it in the private part of the current package. 2404 -- The initialization procedure is built for the record type, which 2405 -- is retrievable from the private entity. 2406 2407 if Is_Incomplete_Or_Private_Type (Rec_Type) then 2408 Rec_Type := Underlying_Type (Rec_Type); 2409 end if; 2410 2411 -- If there are discriminants, build the discriminant map to replace 2412 -- discriminants by their discriminals in complex bound expressions. 2413 -- These only arise for the corresponding records of protected types. 2414 2415 if Is_Concurrent_Record_Type (Rec_Type) 2416 and then Has_Discriminants (Rec_Type) 2417 then 2418 declare 2419 Disc : Entity_Id; 2420 2421 begin 2422 Disc := First_Discriminant (Rec_Type); 2423 2424 while Present (Disc) loop 2425 Append_Elmt (Disc, Discr_Map); 2426 Append_Elmt (Discriminal (Disc), Discr_Map); 2427 Next_Discriminant (Disc); 2428 end loop; 2429 end; 2430 end if; 2431 2432 -- Derived types that have no type extension can use the initialization 2433 -- procedure of their parent and do not need a procedure of their own. 2434 -- This is only correct if there are no representation clauses for the 2435 -- type or its parent, and if the parent has in fact been frozen so 2436 -- that its initialization procedure exists. 2437 2438 if Is_Derived_Type (Rec_Type) 2439 and then not Is_Tagged_Type (Rec_Type) 2440 and then not Has_New_Non_Standard_Rep (Rec_Type) 2441 and then not Parent_Subtype_Renaming_Discrims 2442 and then Has_Non_Null_Base_Init_Proc (Etype (Rec_Type)) 2443 then 2444 Copy_TSS (Base_Init_Proc (Etype (Rec_Type)), Rec_Type); 2445 2446 -- Otherwise if we need an initialization procedure, then build one, 2447 -- mark it as public and inlinable and as having a completion. 2448 2449 elsif Requires_Init_Proc (Rec_Type) then 2450 Build_Init_Procedure; 2451 Set_Is_Public (Proc_Id, Is_Public (Pe)); 2452 2453 -- The initialization of protected records is not worth inlining. 2454 -- In addition, when compiled for another unit for inlining purposes, 2455 -- it may make reference to entities that have not been elaborated 2456 -- yet. The initialization of controlled records contains a nested 2457 -- clean-up procedure that makes it impractical to inline as well, 2458 -- and leads to undefined symbols if inlined in a different unit. 2459 -- Similar considerations apply to task types. 2460 2461 if not Is_Concurrent_Type (Rec_Type) 2462 and then not Has_Task (Rec_Type) 2463 and then not Controlled_Type (Rec_Type) 2464 then 2465 Set_Is_Inlined (Proc_Id); 2466 end if; 2467 2468 Set_Is_Internal (Proc_Id); 2469 Set_Has_Completion (Proc_Id); 2470 2471 if not Debug_Generated_Code then 2472 Set_Debug_Info_Off (Proc_Id); 2473 end if; 2474 end if; 2475 end Build_Record_Init_Proc; 2476 2477 ------------------------------------ 2478 -- Build_Variant_Record_Equality -- 2479 ------------------------------------ 2480 2481 -- Generates: 2482 -- 2483 -- function _Equality (X, Y : T) return Boolean is 2484 -- begin 2485 -- -- Compare discriminants 2486 2487 -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then 2488 -- return False; 2489 -- end if; 2490 2491 -- -- Compare components 2492 2493 -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then 2494 -- return False; 2495 -- end if; 2496 2497 -- -- Compare variant part 2498 2499 -- case X.D1 is 2500 -- when V1 => 2501 -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then 2502 -- return False; 2503 -- end if; 2504 -- ... 2505 -- when Vn => 2506 -- if False or else X.Cn /= Y.Cn then 2507 -- return False; 2508 -- end if; 2509 -- end case; 2510 -- return True; 2511 -- end _Equality; 2512 2513 procedure Build_Variant_Record_Equality (Typ : Entity_Id) is 2514 Loc : constant Source_Ptr := Sloc (Typ); 2515 2516 F : constant Entity_Id := 2517 Make_Defining_Identifier (Loc, 2518 Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); 2519 2520 X : constant Entity_Id := 2521 Make_Defining_Identifier (Loc, 2522 Chars => Name_X); 2523 2524 Y : constant Entity_Id := 2525 Make_Defining_Identifier (Loc, 2526 Chars => Name_Y); 2527 2528 Def : constant Node_Id := Parent (Typ); 2529 Comps : constant Node_Id := Component_List (Type_Definition (Def)); 2530 Stmts : constant List_Id := New_List; 2531 2532 begin 2533 if Is_Derived_Type (Typ) 2534 and then not Has_New_Non_Standard_Rep (Typ) 2535 then 2536 declare 2537 Parent_Eq : constant Entity_Id := 2538 TSS (Root_Type (Typ), TSS_Composite_Equality); 2539 2540 begin 2541 if Present (Parent_Eq) then 2542 Copy_TSS (Parent_Eq, Typ); 2543 return; 2544 end if; 2545 end; 2546 end if; 2547 2548 Discard_Node ( 2549 Make_Subprogram_Body (Loc, 2550 Specification => 2551 Make_Function_Specification (Loc, 2552 Defining_Unit_Name => F, 2553 Parameter_Specifications => New_List ( 2554 Make_Parameter_Specification (Loc, 2555 Defining_Identifier => X, 2556 Parameter_Type => New_Reference_To (Typ, Loc)), 2557 2558 Make_Parameter_Specification (Loc, 2559 Defining_Identifier => Y, 2560 Parameter_Type => New_Reference_To (Typ, Loc))), 2561 2562 Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), 2563 2564 Declarations => New_List, 2565 Handled_Statement_Sequence => 2566 Make_Handled_Sequence_Of_Statements (Loc, 2567 Statements => Stmts))); 2568 2569 -- For unchecked union case, raise program error. This will only 2570 -- happen in the case of dynamic dispatching for a tagged type, 2571 -- since in the static cases it is a compile time error. 2572 2573 if Has_Unchecked_Union (Typ) then 2574 Append_To (Stmts, 2575 Make_Raise_Program_Error (Loc, 2576 Reason => PE_Unchecked_Union_Restriction)); 2577 else 2578 Append_To (Stmts, 2579 Make_Eq_If (Typ, 2580 Discriminant_Specifications (Def))); 2581 Append_List_To (Stmts, 2582 Make_Eq_Case (Typ, Comps)); 2583 end if; 2584 2585 Append_To (Stmts, 2586 Make_Return_Statement (Loc, 2587 Expression => New_Reference_To (Standard_True, Loc))); 2588 2589 Set_TSS (Typ, F); 2590 Set_Is_Pure (F); 2591 2592 if not Debug_Generated_Code then 2593 Set_Debug_Info_Off (F); 2594 end if; 2595 end Build_Variant_Record_Equality; 2596 2597 ----------------------------- 2598 -- Check_Stream_Attributes -- 2599 ----------------------------- 2600 2601 procedure Check_Stream_Attributes (Typ : Entity_Id) is 2602 Comp : Entity_Id; 2603 Par : constant Entity_Id := Root_Type (Base_Type (Typ)); 2604 Par_Read : constant Boolean := Present (TSS (Par, TSS_Stream_Read)); 2605 Par_Write : constant Boolean := Present (TSS (Par, TSS_Stream_Write)); 2606 2607 begin 2608 if Par_Read or else Par_Write then 2609 Comp := First_Component (Typ); 2610 while Present (Comp) loop 2611 if Comes_From_Source (Comp) 2612 and then Original_Record_Component (Comp) = Comp 2613 and then Is_Limited_Type (Etype (Comp)) 2614 then 2615 if (Par_Read and then 2616 No (TSS (Base_Type (Etype (Comp)), TSS_Stream_Read))) 2617 or else 2618 (Par_Write and then 2619 No (TSS (Base_Type (Etype (Comp)), TSS_Stream_Write))) 2620 then 2621 Error_Msg_N 2622 ("|component must have Stream attribute", 2623 Parent (Comp)); 2624 end if; 2625 end if; 2626 2627 Next_Component (Comp); 2628 end loop; 2629 end if; 2630 end Check_Stream_Attributes; 2631 2632 --------------------------- 2633 -- Expand_Derived_Record -- 2634 --------------------------- 2635 2636 -- Add a field _parent at the beginning of the record extension. This is 2637 -- used to implement inheritance. Here are some examples of expansion: 2638 2639 -- 1. no discriminants 2640 -- type T2 is new T1 with null record; 2641 -- gives 2642 -- type T2 is new T1 with record 2643 -- _Parent : T1; 2644 -- end record; 2645 2646 -- 2. renamed discriminants 2647 -- type T2 (B, C : Int) is new T1 (A => B) with record 2648 -- _Parent : T1 (A => B); 2649 -- D : Int; 2650 -- end; 2651 2652 -- 3. inherited discriminants 2653 -- type T2 is new T1 with record -- discriminant A inherited 2654 -- _Parent : T1 (A); 2655 -- D : Int; 2656 -- end; 2657 2658 procedure Expand_Derived_Record (T : Entity_Id; Def : Node_Id) is 2659 Indic : constant Node_Id := Subtype_Indication (Def); 2660 Loc : constant Source_Ptr := Sloc (Def); 2661 Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); 2662 Par_Subtype : Entity_Id; 2663 Comp_List : Node_Id; 2664 Comp_Decl : Node_Id; 2665 Parent_N : Node_Id; 2666 D : Entity_Id; 2667 List_Constr : constant List_Id := New_List; 2668 2669 begin 2670 -- Expand_Tagged_Extension is called directly from the semantics, so 2671 -- we must check to see whether expansion is active before proceeding 2672 2673 if not Expander_Active then 2674 return; 2675 end if; 2676 2677 -- This may be a derivation of an untagged private type whose full 2678 -- view is tagged, in which case the Derived_Type_Definition has no 2679 -- extension part. Build an empty one now. 2680 2681 if No (Rec_Ext_Part) then 2682 Rec_Ext_Part := 2683 Make_Record_Definition (Loc, 2684 End_Label => Empty, 2685 Component_List => Empty, 2686 Null_Present => True); 2687 2688 Set_Record_Extension_Part (Def, Rec_Ext_Part); 2689 Mark_Rewrite_Insertion (Rec_Ext_Part); 2690 end if; 2691 2692 Comp_List := Component_List (Rec_Ext_Part); 2693 2694 Parent_N := Make_Defining_Identifier (Loc, Name_uParent); 2695 2696 -- If the derived type inherits its discriminants the type of the 2697 -- _parent field must be constrained by the inherited discriminants 2698 2699 if Has_Discriminants (T) 2700 and then Nkind (Indic) /= N_Subtype_Indication 2701 and then not Is_Constrained (Entity (Indic)) 2702 then 2703 D := First_Discriminant (T); 2704 while Present (D) loop 2705 Append_To (List_Constr, New_Occurrence_Of (D, Loc)); 2706 Next_Discriminant (D); 2707 end loop; 2708 2709 Par_Subtype := 2710 Process_Subtype ( 2711 Make_Subtype_Indication (Loc, 2712 Subtype_Mark => New_Reference_To (Entity (Indic), Loc), 2713 Constraint => 2714 Make_Index_Or_Discriminant_Constraint (Loc, 2715 Constraints => List_Constr)), 2716 Def); 2717 2718 -- Otherwise the original subtype_indication is just what is needed 2719 2720 else 2721 Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); 2722 end if; 2723 2724 Set_Parent_Subtype (T, Par_Subtype); 2725 2726 Comp_Decl := 2727 Make_Component_Declaration (Loc, 2728 Defining_Identifier => Parent_N, 2729 Component_Definition => 2730 Make_Component_Definition (Loc, 2731 Aliased_Present => False, 2732 Subtype_Indication => New_Reference_To (Par_Subtype, Loc))); 2733 2734 if Null_Present (Rec_Ext_Part) then 2735 Set_Component_List (Rec_Ext_Part, 2736 Make_Component_List (Loc, 2737 Component_Items => New_List (Comp_Decl), 2738 Variant_Part => Empty, 2739 Null_Present => False)); 2740 Set_Null_Present (Rec_Ext_Part, False); 2741 2742 elsif Null_Present (Comp_List) 2743 or else Is_Empty_List (Component_Items (Comp_List)) 2744 then 2745 Set_Component_Items (Comp_List, New_List (Comp_Decl)); 2746 Set_Null_Present (Comp_List, False); 2747 2748 else 2749 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); 2750 end if; 2751 2752 Analyze (Comp_Decl); 2753 end Expand_Derived_Record; 2754 2755 ------------------------------------ 2756 -- Expand_N_Full_Type_Declaration -- 2757 ------------------------------------ 2758 2759 procedure Expand_N_Full_Type_Declaration (N : Node_Id) is 2760 Def_Id : constant Entity_Id := Defining_Identifier (N); 2761 B_Id : constant Entity_Id := Base_Type (Def_Id); 2762 Par_Id : Entity_Id; 2763 FN : Node_Id; 2764 2765 begin 2766 if Is_Access_Type (Def_Id) then 2767 2768 -- Anonymous access types are created for the components of the 2769 -- record parameter for an entry declaration. No master is created 2770 -- for such a type. 2771 2772 if Has_Task (Designated_Type (Def_Id)) 2773 and then Comes_From_Source (N) 2774 then 2775 Build_Master_Entity (Def_Id); 2776 Build_Master_Renaming (Parent (Def_Id), Def_Id); 2777 2778 -- Create a class-wide master because a Master_Id must be generated 2779 -- for access-to-limited-class-wide types, whose root may be extended 2780 -- with task components. 2781 2782 elsif Is_Class_Wide_Type (Designated_Type (Def_Id)) 2783 and then Is_Limited_Type (Designated_Type (Def_Id)) 2784 and then Tasking_Allowed 2785 2786 -- Don't create a class-wide master for types whose convention is 2787 -- Java since these types cannot embed Ada tasks anyway. Note that 2788 -- the following test cannot catch the following case: 2789 -- 2790 -- package java.lang.Object is 2791 -- type Typ is tagged limited private; 2792 -- type Ref is access all Typ'Class; 2793 -- private 2794 -- type Typ is tagged limited ...; 2795 -- pragma Convention (Typ, Java) 2796 -- end; 2797 -- 2798 -- Because the convention appears after we have done the 2799 -- processing for type Ref. 2800 2801 and then Convention (Designated_Type (Def_Id)) /= Convention_Java 2802 then 2803 Build_Class_Wide_Master (Def_Id); 2804 2805 elsif Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then 2806 Expand_Access_Protected_Subprogram_Type (N); 2807 end if; 2808 2809 elsif Has_Task (Def_Id) then 2810 Expand_Previous_Access_Type (Def_Id); 2811 end if; 2812 2813 Par_Id := Etype (B_Id); 2814 2815 -- The parent type is private then we need to inherit 2816 -- any TSS operations from the full view. 2817 2818 if Ekind (Par_Id) in Private_Kind 2819 and then Present (Full_View (Par_Id)) 2820 then 2821 Par_Id := Base_Type (Full_View (Par_Id)); 2822 end if; 2823 2824 if Nkind (Type_Definition (Original_Node (N))) 2825 = N_Derived_Type_Definition 2826 and then not Is_Tagged_Type (Def_Id) 2827 and then Present (Freeze_Node (Par_Id)) 2828 and then Present (TSS_Elist (Freeze_Node (Par_Id))) 2829 then 2830 Ensure_Freeze_Node (B_Id); 2831 FN := Freeze_Node (B_Id); 2832 2833 if No (TSS_Elist (FN)) then 2834 Set_TSS_Elist (FN, New_Elmt_List); 2835 end if; 2836 2837 declare 2838 T_E : constant Elist_Id := TSS_Elist (FN); 2839 Elmt : Elmt_Id; 2840 2841 begin 2842 Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); 2843 2844 while Present (Elmt) loop 2845 if Chars (Node (Elmt)) /= Name_uInit then 2846 Append_Elmt (Node (Elmt), T_E); 2847 end if; 2848 2849 Next_Elmt (Elmt); 2850 end loop; 2851 2852 -- If the derived type itself is private with a full view, 2853 -- then associate the full view with the inherited TSS_Elist 2854 -- as well. 2855 2856 if Ekind (B_Id) in Private_Kind 2857 and then Present (Full_View (B_Id)) 2858 then 2859 Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); 2860 Set_TSS_Elist 2861 (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); 2862 end if; 2863 end; 2864 end if; 2865 end Expand_N_Full_Type_Declaration; 2866 2867 --------------------------------- 2868 -- Expand_N_Object_Declaration -- 2869 --------------------------------- 2870 2871 -- First we do special processing for objects of a tagged type where this 2872 -- is the point at which the type is frozen. The creation of the dispatch 2873 -- table and the initialization procedure have to be deferred to this 2874 -- point, since we reference previously declared primitive subprograms. 2875 2876 -- For all types, we call an initialization procedure if there is one 2877 2878 procedure Expand_N_Object_Declaration (N : Node_Id) is 2879 Def_Id : constant Entity_Id := Defining_Identifier (N); 2880 Typ : constant Entity_Id := Etype (Def_Id); 2881 Loc : constant Source_Ptr := Sloc (N); 2882 Expr : constant Node_Id := Expression (N); 2883 New_Ref : Node_Id; 2884 Id_Ref : Node_Id; 2885 Expr_Q : Node_Id; 2886 2887 begin 2888 -- Don't do anything for deferred constants. All proper actions will 2889 -- be expanded during the full declaration. 2890 2891 if No (Expr) and Constant_Present (N) then 2892 return; 2893 end if; 2894 2895 -- Make shared memory routines for shared passive variable 2896 2897 if Is_Shared_Passive (Def_Id) then 2898 Make_Shared_Var_Procs (N); 2899 end if; 2900 2901 -- If tasks being declared, make sure we have an activation chain 2902 -- defined for the tasks (has no effect if we already have one), and 2903 -- also that a Master variable is established and that the appropriate 2904 -- enclosing construct is established as a task master. 2905 2906 if Has_Task (Typ) then 2907 Build_Activation_Chain_Entity (N); 2908 Build_Master_Entity (Def_Id); 2909 end if; 2910 2911 -- Default initialization required, and no expression present 2912 2913 if No (Expr) then 2914 2915 -- Expand Initialize call for controlled objects. One may wonder why 2916 -- the Initialize Call is not done in the regular Init procedure 2917 -- attached to the record type. That's because the init procedure is 2918 -- recursively called on each component, including _Parent, thus the 2919 -- Init call for a controlled object would generate not only one 2920 -- Initialize call as it is required but one for each ancestor of 2921 -- its type. This processing is suppressed if No_Initialization set. 2922 2923 if not Controlled_Type (Typ) 2924 or else No_Initialization (N) 2925 then 2926 null; 2927 2928 elsif not Abort_Allowed 2929 or else not Comes_From_Source (N) 2930 then 2931 Insert_Actions_After (N, 2932 Make_Init_Call ( 2933 Ref => New_Occurrence_Of (Def_Id, Loc), 2934 Typ => Base_Type (Typ), 2935 Flist_Ref => Find_Final_List (Def_Id), 2936 With_Attach => Make_Integer_Literal (Loc, 1))); 2937 2938 -- Abort allowed 2939 2940 else 2941 -- We need to protect the initialize call 2942 2943 -- begin 2944 -- Defer_Abort.all; 2945 -- Initialize (...); 2946 -- at end 2947 -- Undefer_Abort.all; 2948 -- end; 2949 2950 -- ??? this won't protect the initialize call for controlled 2951 -- components which are part of the init proc, so this block 2952 -- should probably also contain the call to _init_proc but this 2953 -- requires some code reorganization... 2954 2955 declare 2956 L : constant List_Id := 2957 Make_Init_Call ( 2958 Ref => New_Occurrence_Of (Def_Id, Loc), 2959 Typ => Base_Type (Typ), 2960 Flist_Ref => Find_Final_List (Def_Id), 2961 With_Attach => Make_Integer_Literal (Loc, 1)); 2962 2963 Blk : constant Node_Id := 2964 Make_Block_Statement (Loc, 2965 Handled_Statement_Sequence => 2966 Make_Handled_Sequence_Of_Statements (Loc, L)); 2967 2968 begin 2969 Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer)); 2970 Set_At_End_Proc (Handled_Statement_Sequence (Blk), 2971 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); 2972 Insert_Actions_After (N, New_List (Blk)); 2973 Expand_At_End_Handler 2974 (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); 2975 end; 2976 end if; 2977 2978 -- Call type initialization procedure if there is one. We build the 2979 -- call and put it immediately after the object declaration, so that 2980 -- it will be expanded in the usual manner. Note that this will 2981 -- result in proper handling of defaulted discriminants. The call 2982 -- to the Init_Proc is suppressed if No_Initialization is set. 2983 2984 if Has_Non_Null_Base_Init_Proc (Typ) 2985 and then not No_Initialization (N) 2986 then 2987 -- The call to the initialization procedure does NOT freeze 2988 -- the object being initialized. This is because the call is 2989 -- not a source level call. This works fine, because the only 2990 -- possible statements depending on freeze status that can 2991 -- appear after the _Init call are rep clauses which can 2992 -- safely appear after actual references to the object. 2993 2994 Id_Ref := New_Reference_To (Def_Id, Loc); 2995 Set_Must_Not_Freeze (Id_Ref); 2996 Set_Assignment_OK (Id_Ref); 2997 2998 Insert_Actions_After (N, 2999 Build_Initialization_Call (Loc, Id_Ref, Typ)); 3000 3001 -- If simple initialization is required, then set an appropriate 3002 -- simple initialization expression in place. This special 3003 -- initialization is required even though No_Init_Flag is present. 3004 3005 elsif Needs_Simple_Initialization (Typ) then 3006 Set_No_Initialization (N, False); 3007 Set_Expression (N, Get_Simple_Init_Val (Typ, Loc)); 3008 Analyze_And_Resolve (Expression (N), Typ); 3009 end if; 3010 3011 -- Explicit initialization present 3012 3013 else 3014 -- Obtain actual expression from qualified expression 3015 3016 if Nkind (Expr) = N_Qualified_Expression then 3017 Expr_Q := Expression (Expr); 3018 else 3019 Expr_Q := Expr; 3020 end if; 3021 3022 -- When we have the appropriate type of aggregate in the 3023 -- expression (it has been determined during analysis of the 3024 -- aggregate by setting the delay flag), let's perform in 3025 -- place assignment and thus avoid creating a temporary. 3026 3027 if Is_Delayed_Aggregate (Expr_Q) then 3028 Convert_Aggr_In_Object_Decl (N); 3029 3030 else 3031 -- In most cases, we must check that the initial value meets 3032 -- any constraint imposed by the declared type. However, there 3033 -- is one very important exception to this rule. If the entity 3034 -- has an unconstrained nominal subtype, then it acquired its 3035 -- constraints from the expression in the first place, and not 3036 -- only does this mean that the constraint check is not needed, 3037 -- but an attempt to perform the constraint check can 3038 -- cause order of elaboration problems. 3039 3040 if not Is_Constr_Subt_For_U_Nominal (Typ) then 3041 3042 -- If this is an allocator for an aggregate that has been 3043 -- allocated in place, delay checks until assignments are 3044 -- made, because the discriminants are not initialized. 3045 3046 if Nkind (Expr) = N_Allocator 3047 and then No_Initialization (Expr) 3048 then 3049 null; 3050 else 3051 Apply_Constraint_Check (Expr, Typ); 3052 end if; 3053 end if; 3054 3055 -- If the type is controlled we attach the object to the final 3056 -- list and adjust the target after the copy. This 3057 3058 if Controlled_Type (Typ) then 3059 declare 3060 Flist : Node_Id; 3061 F : Entity_Id; 3062 3063 begin 3064 -- Attach the result to a dummy final list which will never 3065 -- be finalized if Delay_Finalize_Attachis set. It is 3066 -- important to attach to a dummy final list rather than 3067 -- not attaching at all in order to reset the pointers 3068 -- coming from the initial value. Equivalent code exists 3069 -- in the sec-stack case in Exp_Ch4.Expand_N_Allocator. 3070 3071 if Delay_Finalize_Attach (N) then 3072 F := 3073 Make_Defining_Identifier (Loc, New_Internal_Name ('F')); 3074 Insert_Action (N, 3075 Make_Object_Declaration (Loc, 3076 Defining_Identifier => F, 3077 Object_Definition => 3078 New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); 3079 3080 Flist := New_Reference_To (F, Loc); 3081 3082 else 3083 Flist := Find_Final_List (Def_Id); 3084 end if; 3085 3086 Insert_Actions_After (N, 3087 Make_Adjust_Call ( 3088 Ref => New_Reference_To (Def_Id, Loc), 3089 Typ => Base_Type (Typ), 3090 Flist_Ref => Flist, 3091 With_Attach => Make_Integer_Literal (Loc, 1))); 3092 end; 3093 end if; 3094 3095 -- For tagged types, when an init value is given, the tag has 3096 -- to be re-initialized separately in order to avoid the 3097 -- propagation of a wrong tag coming from a view conversion 3098 -- unless the type is class wide (in this case the tag comes 3099 -- from the init value). Suppress the tag assignment when 3100 -- Java_VM because JVM tags are represented implicitly 3101 -- in objects. Ditto for types that are CPP_CLASS. 3102 3103 if Is_Tagged_Type (Typ) 3104 and then not Is_Class_Wide_Type (Typ) 3105 and then not Is_CPP_Class (Typ) 3106 and then not Java_VM 3107 then 3108 -- The re-assignment of the tag has to be done even if 3109 -- the object is a constant 3110 3111 New_Ref := 3112 Make_Selected_Component (Loc, 3113 Prefix => New_Reference_To (Def_Id, Loc), 3114 Selector_Name => 3115 New_Reference_To (Tag_Component (Typ), Loc)); 3116 3117 Set_Assignment_OK (New_Ref); 3118 3119 Insert_After (N, 3120 Make_Assignment_Statement (Loc, 3121 Name => New_Ref, 3122 Expression => 3123 Unchecked_Convert_To (RTE (RE_Tag), 3124 New_Reference_To 3125 (Access_Disp_Table (Base_Type (Typ)), Loc)))); 3126 3127 -- For discrete types, set the Is_Known_Valid flag if the 3128 -- initializing value is known to be valid. 3129 3130 elsif Is_Discrete_Type (Typ) 3131 and then Expr_Known_Valid (Expr) 3132 then 3133 Set_Is_Known_Valid (Def_Id); 3134 3135 -- For access types set the Is_Known_Non_Null flag if the 3136 -- initializing value is known to be non-null. We can also 3137 -- set Can_Never_Be_Null if this is a constant. 3138 3139 elsif Is_Access_Type (Typ) 3140 and then Known_Non_Null (Expr) 3141 then 3142 Set_Is_Known_Non_Null (Def_Id); 3143 3144 if Constant_Present (N) then 3145 Set_Can_Never_Be_Null (Def_Id); 3146 end if; 3147 end if; 3148 3149 -- If validity checking on copies, validate initial expression 3150 3151 if Validity_Checks_On 3152 and then Validity_Check_Copies 3153 then 3154 Ensure_Valid (Expr); 3155 Set_Is_Known_Valid (Def_Id); 3156 end if; 3157 end if; 3158 3159 if Is_Possibly_Unaligned_Slice (Expr) then 3160 3161 -- Make a separate assignment that will be expanded into a 3162 -- loop, to bypass back-end problems with misaligned arrays. 3163 3164 declare 3165 Stat : constant Node_Id := 3166 Make_Assignment_Statement (Loc, 3167 Name => New_Reference_To (Def_Id, Loc), 3168 Expression => Relocate_Node (Expr)); 3169 3170 begin 3171 Set_Expression (N, Empty); 3172 Set_No_Initialization (N); 3173 Set_Assignment_OK (Name (Stat)); 3174 Insert_After (N, Stat); 3175 Analyze (Stat); 3176 end; 3177 end if; 3178 end if; 3179 3180 -- For array type, check for size too large 3181 -- We really need this for record types too??? 3182 3183 if Is_Array_Type (Typ) then 3184 Apply_Array_Size_Check (N, Typ); 3185 end if; 3186 3187 exception 3188 when RE_Not_Available => 3189 return; 3190 end Expand_N_Object_Declaration; 3191 3192 --------------------------------- 3193 -- Expand_N_Subtype_Indication -- 3194 --------------------------------- 3195 3196 -- Add a check on the range of the subtype. The static case is 3197 -- partially duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, 3198 -- but we still need to check here for the static case in order to 3199 -- avoid generating extraneous expanded code. 3200 3201 procedure Expand_N_Subtype_Indication (N : Node_Id) is 3202 Ran : constant Node_Id := Range_Expression (Constraint (N)); 3203 Typ : constant Entity_Id := Entity (Subtype_Mark (N)); 3204 3205 begin 3206 if Nkind (Parent (N)) = N_Constrained_Array_Definition or else 3207 Nkind (Parent (N)) = N_Slice 3208 then 3209 Resolve (Ran, Typ); 3210 Apply_Range_Check (Ran, Typ); 3211 end if; 3212 end Expand_N_Subtype_Indication; 3213 3214 --------------------------- 3215 -- Expand_N_Variant_Part -- 3216 --------------------------- 3217 3218 -- If the last variant does not contain the Others choice, replace 3219 -- it with an N_Others_Choice node since Gigi always wants an Others. 3220 -- Note that we do not bother to call Analyze on the modified variant 3221 -- part, since it's only effect would be to compute the contents of 3222 -- the Others_Discrete_Choices node laboriously, and of course we 3223 -- already know the list of choices that corresponds to the others 3224 -- choice (it's the list we are replacing!) 3225 3226 procedure Expand_N_Variant_Part (N : Node_Id) is 3227 Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N)); 3228 Others_Node : Node_Id; 3229 3230 begin 3231 if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then 3232 Others_Node := Make_Others_Choice (Sloc (Last_Var)); 3233 Set_Others_Discrete_Choices 3234 (Others_Node, Discrete_Choices (Last_Var)); 3235 Set_Discrete_Choices (Last_Var, New_List (Others_Node)); 3236 end if; 3237 end Expand_N_Variant_Part; 3238 3239 --------------------------------- 3240 -- Expand_Previous_Access_Type -- 3241 --------------------------------- 3242 3243 procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is 3244 T : Entity_Id := First_Entity (Current_Scope); 3245 3246 begin 3247 -- Find all access types declared in the current scope, whose 3248 -- designated type is Def_Id. 3249 3250 while Present (T) loop 3251 if Is_Access_Type (T) 3252 and then Designated_Type (T) = Def_Id 3253 then 3254 Build_Master_Entity (Def_Id); 3255 Build_Master_Renaming (Parent (Def_Id), T); 3256 end if; 3257 3258 Next_Entity (T); 3259 end loop; 3260 end Expand_Previous_Access_Type; 3261 3262 ------------------------------ 3263 -- Expand_Record_Controller -- 3264 ------------------------------ 3265 3266 procedure Expand_Record_Controller (T : Entity_Id) is 3267 Def : Node_Id := Type_Definition (Parent (T)); 3268 Comp_List : Node_Id; 3269 Comp_Decl : Node_Id; 3270 Loc : Source_Ptr; 3271 First_Comp : Node_Id; 3272 Controller_Type : Entity_Id; 3273 Ent : Entity_Id; 3274 3275 begin 3276 if Nkind (Def) = N_Derived_Type_Definition then 3277 Def := Record_Extension_Part (Def); 3278 end if; 3279 3280 if Null_Present (Def) then 3281 Set_Component_List (Def, 3282 Make_Component_List (Sloc (Def), 3283 Component_Items => Empty_List, 3284 Variant_Part => Empty, 3285 Null_Present => True)); 3286 end if; 3287 3288 Comp_List := Component_List (Def); 3289 3290 if Null_Present (Comp_List) 3291 or else Is_Empty_List (Component_Items (Comp_List)) 3292 then 3293 Loc := Sloc (Comp_List); 3294 else 3295 Loc := Sloc (First (Component_Items (Comp_List))); 3296 end if; 3297 3298 if Is_Return_By_Reference_Type (T) then 3299 Controller_Type := RTE (RE_Limited_Record_Controller); 3300 else 3301 Controller_Type := RTE (RE_Record_Controller); 3302 end if; 3303 3304 Ent := Make_Defining_Identifier (Loc, Name_uController); 3305 3306 Comp_Decl := 3307 Make_Component_Declaration (Loc, 3308 Defining_Identifier => Ent, 3309 Component_Definition => 3310 Make_Component_Definition (Loc, 3311 Aliased_Present => False, 3312 Subtype_Indication => New_Reference_To (Controller_Type, Loc))); 3313 3314 if Null_Present (Comp_List) 3315 or else Is_Empty_List (Component_Items (Comp_List)) 3316 then 3317 Set_Component_Items (Comp_List, New_List (Comp_Decl)); 3318 Set_Null_Present (Comp_List, False); 3319 3320 else 3321 -- The controller cannot be placed before the _Parent field 3322 -- since gigi lays out field in order and _parent must be 3323 -- first to preserve the polymorphism of tagged types. 3324 3325 First_Comp := First (Component_Items (Comp_List)); 3326 3327 if Chars (Defining_Identifier (First_Comp)) /= Name_uParent 3328 and then Chars (Defining_Identifier (First_Comp)) /= Name_uTag 3329 then 3330 Insert_Before (First_Comp, Comp_Decl); 3331 else 3332 Insert_After (First_Comp, Comp_Decl); 3333 end if; 3334 end if; 3335 3336 New_Scope (T); 3337 Analyze (Comp_Decl); 3338 Set_Ekind (Ent, E_Component); 3339 Init_Component_Location (Ent); 3340 3341 -- Move the _controller entity ahead in the list of internal 3342 -- entities of the enclosing record so that it is selected 3343 -- instead of a potentially inherited one. 3344 3345 declare 3346 E : constant Entity_Id := Last_Entity (T); 3347 Comp : Entity_Id; 3348 3349 begin 3350 pragma Assert (Chars (E) = Name_uController); 3351 3352 Set_Next_Entity (E, First_Entity (T)); 3353 Set_First_Entity (T, E); 3354 3355 Comp := Next_Entity (E); 3356 while Next_Entity (Comp) /= E loop 3357 Next_Entity (Comp); 3358 end loop; 3359 3360 Set_Next_Entity (Comp, Empty); 3361 Set_Last_Entity (T, Comp); 3362 end; 3363 3364 End_Scope; 3365 3366 exception 3367 when RE_Not_Available => 3368 return; 3369 end Expand_Record_Controller; 3370 3371 ------------------------ 3372 -- Expand_Tagged_Root -- 3373 ------------------------ 3374 3375 procedure Expand_Tagged_Root (T : Entity_Id) is 3376 Def : constant Node_Id := Type_Definition (Parent (T)); 3377 Comp_List : Node_Id; 3378 Comp_Decl : Node_Id; 3379 Sloc_N : Source_Ptr; 3380 3381 begin 3382 if Null_Present (Def) then 3383 Set_Component_List (Def, 3384 Make_Component_List (Sloc (Def), 3385 Component_Items => Empty_List, 3386 Variant_Part => Empty, 3387 Null_Present => True)); 3388 end if; 3389 3390 Comp_List := Component_List (Def); 3391 3392 if Null_Present (Comp_List) 3393 or else Is_Empty_List (Component_Items (Comp_List)) 3394 then 3395 Sloc_N := Sloc (Comp_List); 3396 else 3397 Sloc_N := Sloc (First (Component_Items (Comp_List))); 3398 end if; 3399 3400 Comp_Decl := 3401 Make_Component_Declaration (Sloc_N, 3402 Defining_Identifier => Tag_Component (T), 3403 Component_Definition => 3404 Make_Component_Definition (Sloc_N, 3405 Aliased_Present => False, 3406 Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N))); 3407 3408 if Null_Present (Comp_List) 3409 or else Is_Empty_List (Component_Items (Comp_List)) 3410 then 3411 Set_Component_Items (Comp_List, New_List (Comp_Decl)); 3412 Set_Null_Present (Comp_List, False); 3413 3414 else 3415 Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); 3416 end if; 3417 3418 -- We don't Analyze the whole expansion because the tag component has 3419 -- already been analyzed previously. Here we just insure that the 3420 -- tree is coherent with the semantic decoration 3421 3422 Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); 3423 3424 exception 3425 when RE_Not_Available => 3426 return; 3427 end Expand_Tagged_Root; 3428 3429 ----------------------- 3430 -- Freeze_Array_Type -- 3431 ----------------------- 3432 3433 procedure Freeze_Array_Type (N : Node_Id) is 3434 Typ : constant Entity_Id := Entity (N); 3435 Base : constant Entity_Id := Base_Type (Typ); 3436 3437 begin 3438 if not Is_Bit_Packed_Array (Typ) then 3439 3440 -- If the component contains tasks, so does the array type. 3441 -- This may not be indicated in the array type because the 3442 -- component may have been a private type at the point of 3443 -- definition. Same if component type is controlled. 3444 3445 Set_Has_Task (Base, Has_Task (Component_Type (Typ))); 3446 Set_Has_Controlled_Component (Base, 3447 Has_Controlled_Component (Component_Type (Typ)) 3448 or else Is_Controlled (Component_Type (Typ))); 3449 3450 if No (Init_Proc (Base)) then 3451 3452 -- If this is an anonymous array created for a declaration 3453 -- with an initial value, its init_proc will never be called. 3454 -- The initial value itself may have been expanded into assign- 3455 -- ments, in which case the object declaration is carries the 3456 -- No_Initialization flag. 3457 3458 if Is_Itype (Base) 3459 and then Nkind (Associated_Node_For_Itype (Base)) = 3460 N_Object_Declaration 3461 and then (Present (Expression (Associated_Node_For_Itype (Base))) 3462 or else 3463 No_Initialization (Associated_Node_For_Itype (Base))) 3464 then 3465 null; 3466 3467 -- We do not need an init proc for string or wide string, since 3468 -- the only time these need initialization in normalize or 3469 -- initialize scalars mode, and these types are treated specially 3470 -- and do not need initialization procedures. 3471 3472 elsif Root_Type (Base) = Standard_String 3473 or else Root_Type (Base) = Standard_Wide_String 3474 then 3475 null; 3476 3477 -- Otherwise we have to build an init proc for the subtype 3478 3479 else 3480 Build_Array_Init_Proc (Base, N); 3481 end if; 3482 end if; 3483 3484 if Typ = Base and then Has_Controlled_Component (Base) then 3485 Build_Controlling_Procs (Base); 3486 end if; 3487 3488 -- For packed case, there is a default initialization, except 3489 -- if the component type is itself a packed structure with an 3490 -- initialization procedure. 3491 3492 elsif Present (Init_Proc (Component_Type (Base))) 3493 and then No (Base_Init_Proc (Base)) 3494 then 3495 Build_Array_Init_Proc (Base, N); 3496 end if; 3497 end Freeze_Array_Type; 3498 3499 ----------------------------- 3500 -- Freeze_Enumeration_Type -- 3501 ----------------------------- 3502 3503 procedure Freeze_Enumeration_Type (N : Node_Id) is 3504 Typ : constant Entity_Id := Entity (N); 3505 Loc : constant Source_Ptr := Sloc (Typ); 3506 Ent : Entity_Id; 3507 Lst : List_Id; 3508 Num : Nat; 3509 Arr : Entity_Id; 3510 Fent : Entity_Id; 3511 Ityp : Entity_Id; 3512 Is_Contiguous : Boolean; 3513 Pos_Expr : Node_Id; 3514 Last_Repval : Uint; 3515 3516 Func : Entity_Id; 3517 pragma Warnings (Off, Func); 3518 3519 begin 3520 -- Various optimization are possible if the given representation 3521 -- is contiguous. 3522 3523 Is_Contiguous := True; 3524 Ent := First_Literal (Typ); 3525 Last_Repval := Enumeration_Rep (Ent); 3526 Next_Literal (Ent); 3527 3528 while Present (Ent) loop 3529 if Enumeration_Rep (Ent) - Last_Repval /= 1 then 3530 Is_Contiguous := False; 3531 exit; 3532 else 3533 Last_Repval := Enumeration_Rep (Ent); 3534 end if; 3535 3536 Next_Literal (Ent); 3537 end loop; 3538 3539 if Is_Contiguous then 3540 Set_Has_Contiguous_Rep (Typ); 3541 Ent := First_Literal (Typ); 3542 Num := 1; 3543 Lst := New_List (New_Reference_To (Ent, Sloc (Ent))); 3544 3545 else 3546 -- Build list of literal references 3547 3548 Lst := New_List; 3549 Num := 0; 3550 3551 Ent := First_Literal (Typ); 3552 while Present (Ent) loop 3553 Append_To (Lst, New_Reference_To (Ent, Sloc (Ent))); 3554 Num := Num + 1; 3555 Next_Literal (Ent); 3556 end loop; 3557 end if; 3558 3559 -- Now build an array declaration. 3560 3561 -- typA : array (Natural range 0 .. num - 1) of ctype := 3562 -- (v, v, v, v, v, ....) 3563 3564 -- where ctype is the corresponding integer type. If the 3565 -- representation is contiguous, we only keep the first literal, 3566 -- which provides the offset for Pos_To_Rep computations. 3567 3568 Arr := 3569 Make_Defining_Identifier (Loc, 3570 Chars => New_External_Name (Chars (Typ), 'A')); 3571 3572 Append_Freeze_Action (Typ, 3573 Make_Object_Declaration (Loc, 3574 Defining_Identifier => Arr, 3575 Constant_Present => True, 3576 3577 Object_Definition => 3578 Make_Constrained_Array_Definition (Loc, 3579 Discrete_Subtype_Definitions => New_List ( 3580 Make_Subtype_Indication (Loc, 3581 Subtype_Mark => New_Reference_To (Standard_Natural, Loc), 3582 Constraint => 3583 Make_Range_Constraint (Loc, 3584 Range_Expression => 3585 Make_Range (Loc, 3586 Low_Bound => 3587 Make_Integer_Literal (Loc, 0), 3588 High_Bound => 3589 Make_Integer_Literal (Loc, Num - 1))))), 3590 3591 Component_Definition => 3592 Make_Component_Definition (Loc, 3593 Aliased_Present => False, 3594 Subtype_Indication => New_Reference_To (Typ, Loc))), 3595 3596 Expression => 3597 Make_Aggregate (Loc, 3598 Expressions => Lst))); 3599 3600 Set_Enum_Pos_To_Rep (Typ, Arr); 3601 3602 -- Now we build the function that converts representation values to 3603 -- position values. This function has the form: 3604 3605 -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is 3606 -- begin 3607 -- case ityp!(A) is 3608 -- when enum-lit'Enum_Rep => return posval; 3609 -- when enum-lit'Enum_Rep => return posval; 3610 -- ... 3611 -- when others => 3612 -- [raise Constraint_Error when F "invalid data"] 3613 -- return -1; 3614 -- end case; 3615 -- end; 3616 3617 -- Note: the F parameter determines whether the others case (no valid 3618 -- representation) raises Constraint_Error or returns a unique value 3619 -- of minus one. The latter case is used, e.g. in 'Valid code. 3620 3621 -- Note: the reason we use Enum_Rep values in the case here is to 3622 -- avoid the code generator making inappropriate assumptions about 3623 -- the range of the values in the case where the value is invalid. 3624 -- ityp is a signed or unsigned integer type of appropriate width. 3625 3626 -- Note: if exceptions are not supported, then we suppress the raise 3627 -- and return -1 unconditionally (this is an erroneous program in any 3628 -- case and there is no obligation to raise Constraint_Error here!) 3629 -- We also do this if pragma Restrictions (No_Exceptions) is active. 3630 3631 -- Representations are signed 3632 3633 if Enumeration_Rep (First_Literal (Typ)) < 0 then 3634 3635 -- The underlying type is signed. Reset the Is_Unsigned_Type 3636 -- explicitly, because it might have been inherited from a 3637 -- parent type. 3638 3639 Set_Is_Unsigned_Type (Typ, False); 3640 3641 if Esize (Typ) <= Standard_Integer_Size then 3642 Ityp := Standard_Integer; 3643 else 3644 Ityp := Universal_Integer; 3645 end if; 3646 3647 -- Representations are unsigned 3648 3649 else 3650 if Esize (Typ) <= Standard_Integer_Size then 3651 Ityp := RTE (RE_Unsigned); 3652 else 3653 Ityp := RTE (RE_Long_Long_Unsigned); 3654 end if; 3655 end if; 3656 3657 -- The body of the function is a case statement. First collect 3658 -- case alternatives, or optimize the contiguous case. 3659 3660 Lst := New_List; 3661 3662 -- If representation is contiguous, Pos is computed by subtracting 3663 -- the representation of the first literal. 3664 3665 if Is_Contiguous then 3666 Ent := First_Literal (Typ); 3667 3668 if Enumeration_Rep (Ent) = Last_Repval then 3669 3670 -- Another special case: for a single literal, Pos is zero. 3671 3672 Pos_Expr := Make_Integer_Literal (Loc, Uint_0); 3673 3674 else 3675 Pos_Expr := 3676 Convert_To (Standard_Integer, 3677 Make_Op_Subtract (Loc, 3678 Left_Opnd => 3679 Unchecked_Convert_To (Ityp, 3680 Make_Identifier (Loc, Name_uA)), 3681 Right_Opnd => 3682 Make_Integer_Literal (Loc, 3683 Intval => 3684 Enumeration_Rep (First_Literal (Typ))))); 3685 end if; 3686 3687 Append_To (Lst, 3688 Make_Case_Statement_Alternative (Loc, 3689 Discrete_Choices => New_List ( 3690 Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), 3691 Low_Bound => 3692 Make_Integer_Literal (Loc, 3693 Intval => Enumeration_Rep (Ent)), 3694 High_Bound => 3695 Make_Integer_Literal (Loc, Intval => Last_Repval))), 3696 3697 Statements => New_List ( 3698 Make_Return_Statement (Loc, 3699 Expression => Pos_Expr)))); 3700 3701 else 3702 Ent := First_Literal (Typ); 3703 3704 while Present (Ent) loop 3705 Append_To (Lst, 3706 Make_Case_Statement_Alternative (Loc, 3707 Discrete_Choices => New_List ( 3708 Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), 3709 Intval => Enumeration_Rep (Ent))), 3710 3711 Statements => New_List ( 3712 Make_Return_Statement (Loc, 3713 Expression => 3714 Make_Integer_Literal (Loc, 3715 Intval => Enumeration_Pos (Ent)))))); 3716 3717 Next_Literal (Ent); 3718 end loop; 3719 end if; 3720 3721 -- In normal mode, add the others clause with the test 3722 3723 if not Restrictions (No_Exception_Handlers) then 3724 Append_To (Lst, 3725 Make_Case_Statement_Alternative (Loc, 3726 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 3727 Statements => New_List ( 3728 Make_Raise_Constraint_Error (Loc, 3729 Condition => Make_Identifier (Loc, Name_uF), 3730 Reason => CE_Invalid_Data), 3731 Make_Return_Statement (Loc, 3732 Expression => 3733 Make_Integer_Literal (Loc, -1))))); 3734 3735 -- If Restriction (No_Exceptions_Handlers) is active then we always 3736 -- return -1 (since we cannot usefully raise Constraint_Error in 3737 -- this case). See description above for further details. 3738 3739 else 3740 Append_To (Lst, 3741 Make_Case_Statement_Alternative (Loc, 3742 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 3743 Statements => New_List ( 3744 Make_Return_Statement (Loc, 3745 Expression => 3746 Make_Integer_Literal (Loc, -1))))); 3747 end if; 3748 3749 -- Now we can build the function body 3750 3751 Fent := 3752 Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); 3753 3754 Func := 3755 Make_Subprogram_Body (Loc, 3756 Specification => 3757 Make_Function_Specification (Loc, 3758 Defining_Unit_Name => Fent, 3759 Parameter_Specifications => New_List ( 3760 Make_Parameter_Specification (Loc, 3761 Defining_Identifier => 3762 Make_Defining_Identifier (Loc, Name_uA), 3763 Parameter_Type => New_Reference_To (Typ, Loc)), 3764 Make_Parameter_Specification (Loc, 3765 Defining_Identifier => 3766 Make_Defining_Identifier (Loc, Name_uF), 3767 Parameter_Type => New_Reference_To (Standard_Boolean, Loc))), 3768 3769 Subtype_Mark => New_Reference_To (Standard_Integer, Loc)), 3770 3771 Declarations => Empty_List, 3772 3773 Handled_Statement_Sequence => 3774 Make_Handled_Sequence_Of_Statements (Loc, 3775 Statements => New_List ( 3776 Make_Case_Statement (Loc, 3777 Expression => 3778 Unchecked_Convert_To (Ityp, 3779 Make_Identifier (Loc, Name_uA)), 3780 Alternatives => Lst)))); 3781 3782 Set_TSS (Typ, Fent); 3783 Set_Is_Pure (Fent); 3784 3785 if not Debug_Generated_Code then 3786 Set_Debug_Info_Off (Fent); 3787 end if; 3788 3789 exception 3790 when RE_Not_Available => 3791 return; 3792 end Freeze_Enumeration_Type; 3793 3794 ------------------------ 3795 -- Freeze_Record_Type -- 3796 ------------------------ 3797 3798 procedure Freeze_Record_Type (N : Node_Id) is 3799 Def_Id : constant Node_Id := Entity (N); 3800 Comp : Entity_Id; 3801 Type_Decl : constant Node_Id := Parent (Def_Id); 3802 Predef_List : List_Id; 3803 3804 Renamed_Eq : Node_Id := Empty; 3805 -- Could use some comments ??? 3806 3807 begin 3808 -- Build discriminant checking functions if not a derived type (for 3809 -- derived types that are not tagged types, we always use the 3810 -- discriminant checking functions of the parent type). However, for 3811 -- untagged types the derivation may have taken place before the 3812 -- parent was frozen, so we copy explicitly the discriminant checking 3813 -- functions from the parent into the components of the derived type. 3814 3815 if not Is_Derived_Type (Def_Id) 3816 or else Has_New_Non_Standard_Rep (Def_Id) 3817 or else Is_Tagged_Type (Def_Id) 3818 then 3819 Build_Discr_Checking_Funcs (Type_Decl); 3820 3821 elsif Is_Derived_Type (Def_Id) 3822 and then not Is_Tagged_Type (Def_Id) 3823 and then Has_Discriminants (Def_Id) 3824 then 3825 declare 3826 Old_Comp : Entity_Id; 3827 3828 begin 3829 Old_Comp := 3830 First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); 3831 Comp := First_Component (Def_Id); 3832 while Present (Comp) loop 3833 if Ekind (Comp) = E_Component 3834 and then Chars (Comp) = Chars (Old_Comp) 3835 then 3836 Set_Discriminant_Checking_Func (Comp, 3837 Discriminant_Checking_Func (Old_Comp)); 3838 end if; 3839 3840 Next_Component (Old_Comp); 3841 Next_Component (Comp); 3842 end loop; 3843 end; 3844 end if; 3845 3846 if Is_Derived_Type (Def_Id) 3847 and then Is_Limited_Type (Def_Id) 3848 and then Is_Tagged_Type (Def_Id) 3849 then 3850 Check_Stream_Attributes (Def_Id); 3851 end if; 3852 3853 -- Update task and controlled component flags, because some of the 3854 -- component types may have been private at the point of the record 3855 -- declaration. 3856 3857 Comp := First_Component (Def_Id); 3858 3859 while Present (Comp) loop 3860 if Has_Task (Etype (Comp)) then 3861 Set_Has_Task (Def_Id); 3862 3863 elsif Has_Controlled_Component (Etype (Comp)) 3864 or else (Chars (Comp) /= Name_uParent 3865 and then Is_Controlled (Etype (Comp))) 3866 then 3867 Set_Has_Controlled_Component (Def_Id); 3868 end if; 3869 3870 Next_Component (Comp); 3871 end loop; 3872 3873 -- Creation of the Dispatch Table. Note that a Dispatch Table is 3874 -- created for regular tagged types as well as for Ada types 3875 -- deriving from a C++ Class, but not for tagged types directly 3876 -- corresponding to the C++ classes. In the later case we assume 3877 -- that the Vtable is created in the C++ side and we just use it. 3878 3879 if Is_Tagged_Type (Def_Id) then 3880 if Is_CPP_Class (Def_Id) then 3881 Set_All_DT_Position (Def_Id); 3882 Set_Default_Constructor (Def_Id); 3883 3884 else 3885 -- Usually inherited primitives are not delayed but the first 3886 -- Ada extension of a CPP_Class is an exception since the 3887 -- address of the inherited subprogram has to be inserted in 3888 -- the new Ada Dispatch Table and this is a freezing action 3889 -- (usually the inherited primitive address is inserted in the 3890 -- DT by Inherit_DT) 3891 3892 if Is_CPP_Class (Etype (Def_Id)) then 3893 declare 3894 Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Def_Id)); 3895 Subp : Entity_Id; 3896 3897 begin 3898 while Present (Elmt) loop 3899 Subp := Node (Elmt); 3900 3901 if Present (Alias (Subp)) then 3902 Set_Has_Delayed_Freeze (Subp); 3903 end if; 3904 3905 Next_Elmt (Elmt); 3906 end loop; 3907 end; 3908 end if; 3909 3910 if Underlying_Type (Etype (Def_Id)) = Def_Id then 3911 Expand_Tagged_Root (Def_Id); 3912 end if; 3913 3914 -- Unfreeze momentarily the type to add the predefined 3915 -- primitives operations. The reason we unfreeze is so 3916 -- that these predefined operations will indeed end up 3917 -- as primitive operations (which must be before the 3918 -- freeze point). 3919 3920 Set_Is_Frozen (Def_Id, False); 3921 Make_Predefined_Primitive_Specs 3922 (Def_Id, Predef_List, Renamed_Eq); 3923 Insert_List_Before_And_Analyze (N, Predef_List); 3924 Set_Is_Frozen (Def_Id, True); 3925 Set_All_DT_Position (Def_Id); 3926 3927 -- Add the controlled component before the freezing actions 3928 -- it is referenced in those actions. 3929 3930 if Has_New_Controlled_Component (Def_Id) then 3931 Expand_Record_Controller (Def_Id); 3932 end if; 3933 3934 -- Suppress creation of a dispatch table when Java_VM because 3935 -- the dispatching mechanism is handled internally by the JVM. 3936 3937 if not Java_VM then 3938 Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); 3939 end if; 3940 3941 -- Make sure that the primitives Initialize, Adjust and 3942 -- Finalize are Frozen before other TSS subprograms. We 3943 -- don't want them Frozen inside. 3944 3945 if Is_Controlled (Def_Id) then 3946 if not Is_Limited_Type (Def_Id) then 3947 Append_Freeze_Actions (Def_Id, 3948 Freeze_Entity 3949 (Find_Prim_Op (Def_Id, Name_Adjust), Sloc (Def_Id))); 3950 end if; 3951 3952 Append_Freeze_Actions (Def_Id, 3953 Freeze_Entity 3954 (Find_Prim_Op (Def_Id, Name_Initialize), Sloc (Def_Id))); 3955 3956 Append_Freeze_Actions (Def_Id, 3957 Freeze_Entity 3958 (Find_Prim_Op (Def_Id, Name_Finalize), Sloc (Def_Id))); 3959 end if; 3960 3961 -- Freeze rest of primitive operations 3962 3963 Append_Freeze_Actions 3964 (Def_Id, Predefined_Primitive_Freeze (Def_Id)); 3965 end if; 3966 3967 -- In the non-tagged case, an equality function is provided only 3968 -- for variant records (that are not unchecked unions). 3969 3970 elsif Has_Discriminants (Def_Id) 3971 and then not Is_Limited_Type (Def_Id) 3972 then 3973 declare 3974 Comps : constant Node_Id := 3975 Component_List (Type_Definition (Type_Decl)); 3976 3977 begin 3978 if Present (Comps) 3979 and then Present (Variant_Part (Comps)) 3980 and then not Is_Unchecked_Union (Def_Id) 3981 then 3982 Build_Variant_Record_Equality (Def_Id); 3983 end if; 3984 end; 3985 end if; 3986 3987 -- Before building the record initialization procedure, if we are 3988 -- dealing with a concurrent record value type, then we must go 3989 -- through the discriminants, exchanging discriminals between the 3990 -- concurrent type and the concurrent record value type. See the 3991 -- section "Handling of Discriminants" in the Einfo spec for details. 3992 3993 if Is_Concurrent_Record_Type (Def_Id) 3994 and then Has_Discriminants (Def_Id) 3995 then 3996 declare 3997 Ctyp : constant Entity_Id := 3998 Corresponding_Concurrent_Type (Def_Id); 3999 Conc_Discr : Entity_Id; 4000 Rec_Discr : Entity_Id; 4001 Temp : Entity_Id; 4002 4003 begin 4004 Conc_Discr := First_Discriminant (Ctyp); 4005 Rec_Discr := First_Discriminant (Def_Id); 4006 4007 while Present (Conc_Discr) loop 4008 Temp := Discriminal (Conc_Discr); 4009 Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); 4010 Set_Discriminal (Rec_Discr, Temp); 4011 4012 Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); 4013 Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); 4014 4015 Next_Discriminant (Conc_Discr); 4016 Next_Discriminant (Rec_Discr); 4017 end loop; 4018 end; 4019 end if; 4020 4021 if Has_Controlled_Component (Def_Id) then 4022 if No (Controller_Component (Def_Id)) then 4023 Expand_Record_Controller (Def_Id); 4024 end if; 4025 4026 Build_Controlling_Procs (Def_Id); 4027 end if; 4028 4029 Adjust_Discriminants (Def_Id); 4030 Build_Record_Init_Proc (Type_Decl, Def_Id); 4031 4032 -- For tagged type, build bodies of primitive operations. Note 4033 -- that we do this after building the record initialization 4034 -- experiment, since the primitive operations may need the 4035 -- initialization routine 4036 4037 if Is_Tagged_Type (Def_Id) then 4038 Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); 4039 Append_Freeze_Actions (Def_Id, Predef_List); 4040 end if; 4041 4042 end Freeze_Record_Type; 4043 4044 ------------------------------ 4045 -- Freeze_Stream_Operations -- 4046 ------------------------------ 4047 4048 procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is 4049 Names : constant array (1 .. 4) of TSS_Name_Type := 4050 (TSS_Stream_Input, 4051 TSS_Stream_Output, 4052 TSS_Stream_Read, 4053 TSS_Stream_Write); 4054 Stream_Op : Entity_Id; 4055 4056 begin 4057 -- Primitive operations of tagged types are frozen when the dispatch 4058 -- table is constructed. 4059 4060 if not Comes_From_Source (Typ) 4061 or else Is_Tagged_Type (Typ) 4062 then 4063 return; 4064 end if; 4065 4066 for J in Names'Range loop 4067 Stream_Op := TSS (Typ, Names (J)); 4068 4069 if Present (Stream_Op) 4070 and then Is_Subprogram (Stream_Op) 4071 and then Nkind (Unit_Declaration_Node (Stream_Op)) = 4072 N_Subprogram_Declaration 4073 and then not Is_Frozen (Stream_Op) 4074 then 4075 Append_Freeze_Actions 4076 (Typ, Freeze_Entity (Stream_Op, Sloc (N))); 4077 end if; 4078 end loop; 4079 end Freeze_Stream_Operations; 4080 4081 ----------------- 4082 -- Freeze_Type -- 4083 ----------------- 4084 4085 -- Full type declarations are expanded at the point at which the type 4086 -- is frozen. The formal N is the Freeze_Node for the type. Any statements 4087 -- or declarations generated by the freezing (e.g. the procedure generated 4088 -- for initialization) are chained in the Acions field list of the freeze 4089 -- node using Append_Freeze_Actions. 4090 4091 procedure Freeze_Type (N : Node_Id) is 4092 Def_Id : constant Entity_Id := Entity (N); 4093 RACW_Seen : Boolean := False; 4094 4095 begin 4096 -- Process associated access types needing special processing 4097 4098 if Present (Access_Types_To_Process (N)) then 4099 declare 4100 E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); 4101 begin 4102 while Present (E) loop 4103 4104 if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then 4105 RACW_Seen := True; 4106 end if; 4107 4108 E := Next_Elmt (E); 4109 end loop; 4110 end; 4111 4112 if RACW_Seen then 4113 4114 -- If there are RACWs designating this type, make stubs now. 4115 4116 Remote_Types_Tagged_Full_View_Encountered (Def_Id); 4117 end if; 4118 end if; 4119 4120 -- Freeze processing for record types 4121 4122 if Is_Record_Type (Def_Id) then 4123 if Ekind (Def_Id) = E_Record_Type then 4124 Freeze_Record_Type (N); 4125 4126 -- The subtype may have been declared before the type was frozen. 4127 -- If the type has controlled components it is necessary to create 4128 -- the entity for the controller explicitly because it did not 4129 -- exist at the point of the subtype declaration. Only the entity is 4130 -- needed, the back-end will obtain the layout from the type. 4131 -- This is only necessary if this is constrained subtype whose 4132 -- component list is not shared with the base type. 4133 4134 elsif Ekind (Def_Id) = E_Record_Subtype 4135 and then Has_Discriminants (Def_Id) 4136 and then Last_Entity (Def_Id) /= Last_Entity (Base_Type (Def_Id)) 4137 and then Present (Controller_Component (Def_Id)) 4138 then 4139 declare 4140 Old_C : constant Entity_Id := Controller_Component (Def_Id); 4141 New_C : Entity_Id; 4142 4143 begin 4144 if Scope (Old_C) = Base_Type (Def_Id) then 4145 4146 -- The entity is the one in the parent. Create new one. 4147 4148 New_C := New_Copy (Old_C); 4149 Set_Parent (New_C, Parent (Old_C)); 4150 New_Scope (Def_Id); 4151 Enter_Name (New_C); 4152 End_Scope; 4153 end if; 4154 end; 4155 4156 -- Similar process if the controller of the subtype is not 4157 -- present but the parent has it. This can happen with constrained 4158 -- record components where the subtype is an itype. 4159 4160 elsif Ekind (Def_Id) = E_Record_Subtype 4161 and then Is_Itype (Def_Id) 4162 and then No (Controller_Component (Def_Id)) 4163 and then Present (Controller_Component (Etype (Def_Id))) 4164 then 4165 declare 4166 Old_C : constant Entity_Id := 4167 Controller_Component (Etype (Def_Id)); 4168 New_C : constant Entity_Id := New_Copy (Old_C); 4169 4170 begin 4171 Set_Next_Entity (New_C, First_Entity (Def_Id)); 4172 Set_First_Entity (Def_Id, New_C); 4173 4174 -- The freeze node is only used to introduce the controller, 4175 -- the back-end has no use for it for a discriminated 4176 -- component. 4177 4178 Set_Freeze_Node (Def_Id, Empty); 4179 Set_Has_Delayed_Freeze (Def_Id, False); 4180 Remove (N); 4181 end; 4182 end if; 4183 4184 -- Freeze processing for array types 4185 4186 elsif Is_Array_Type (Def_Id) then 4187 Freeze_Array_Type (N); 4188 4189 -- Freeze processing for access types 4190 4191 -- For pool-specific access types, find out the pool object used for 4192 -- this type, needs actual expansion of it in some cases. Here are the 4193 -- different cases : 4194 4195 -- 1. Rep Clause "for Def_Id'Storage_Size use 0;" 4196 -- ---> don't use any storage pool 4197 4198 -- 2. Rep Clause : for Def_Id'Storage_Size use Expr. 4199 -- Expand: 4200 -- Def_Id__Pool : Stack_Bounded_Pool (Expr, DT'Size, DT'Alignment); 4201 4202 -- 3. Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" 4203 -- ---> Storage Pool is the specified one 4204 4205 -- See GNAT Pool packages in the Run-Time for more details 4206 4207 elsif Ekind (Def_Id) = E_Access_Type 4208 or else Ekind (Def_Id) = E_General_Access_Type 4209 then 4210 declare 4211 Loc : constant Source_Ptr := Sloc (N); 4212 Desig_Type : constant Entity_Id := Designated_Type (Def_Id); 4213 Pool_Object : Entity_Id; 4214 Siz_Exp : Node_Id; 4215 4216 Freeze_Action_Typ : Entity_Id; 4217 4218 begin 4219 if Has_Storage_Size_Clause (Def_Id) then 4220 Siz_Exp := Expression (Parent (Storage_Size_Variable (Def_Id))); 4221 else 4222 Siz_Exp := Empty; 4223 end if; 4224 4225 -- Case 1 4226 4227 -- Rep Clause "for Def_Id'Storage_Size use 0;" 4228 -- ---> don't use any storage pool 4229 4230 if Has_Storage_Size_Clause (Def_Id) 4231 and then Compile_Time_Known_Value (Siz_Exp) 4232 and then Expr_Value (Siz_Exp) = 0 4233 then 4234 null; 4235 4236 -- Case 2 4237 4238 -- Rep Clause : for Def_Id'Storage_Size use Expr. 4239 -- ---> Expand: 4240 -- Def_Id__Pool : Stack_Bounded_Pool 4241 -- (Expr, DT'Size, DT'Alignment); 4242 4243 elsif Has_Storage_Size_Clause (Def_Id) then 4244 declare 4245 DT_Size : Node_Id; 4246 DT_Align : Node_Id; 4247 4248 begin 4249 -- For unconstrained composite types we give a size of 4250 -- zero so that the pool knows that it needs a special 4251 -- algorithm for variable size object allocation. 4252 4253 if Is_Composite_Type (Desig_Type) 4254 and then not Is_Constrained (Desig_Type) 4255 then 4256 DT_Size := 4257 Make_Integer_Literal (Loc, 0); 4258 4259 DT_Align := 4260 Make_Integer_Literal (Loc, Maximum_Alignment); 4261 4262 else 4263 DT_Size := 4264 Make_Attribute_Reference (Loc, 4265 Prefix => New_Reference_To (Desig_Type, Loc), 4266 Attribute_Name => Name_Max_Size_In_Storage_Elements); 4267 4268 DT_Align := 4269 Make_Attribute_Reference (Loc, 4270 Prefix => New_Reference_To (Desig_Type, Loc), 4271 Attribute_Name => Name_Alignment); 4272 end if; 4273 4274 Pool_Object := 4275 Make_Defining_Identifier (Loc, 4276 Chars => New_External_Name (Chars (Def_Id), 'P')); 4277 4278 -- We put the code associated with the pools in the 4279 -- entity that has the later freeze node, usually the 4280 -- acces type but it can also be the designated_type; 4281 -- because the pool code requires both those types to be 4282 -- frozen 4283 4284 if Is_Frozen (Desig_Type) 4285 and then (not Present (Freeze_Node (Desig_Type)) 4286 or else Analyzed (Freeze_Node (Desig_Type))) 4287 then 4288 Freeze_Action_Typ := Def_Id; 4289 4290 -- A Taft amendment type cannot get the freeze actions 4291 -- since the full view is not there. 4292 4293 elsif Is_Incomplete_Or_Private_Type (Desig_Type) 4294 and then No (Full_View (Desig_Type)) 4295 then 4296 Freeze_Action_Typ := Def_Id; 4297 4298 else 4299 Freeze_Action_Typ := Desig_Type; 4300 end if; 4301 4302 Append_Freeze_Action (Freeze_Action_Typ, 4303 Make_Object_Declaration (Loc, 4304 Defining_Identifier => Pool_Object, 4305 Object_Definition => 4306 Make_Subtype_Indication (Loc, 4307 Subtype_Mark => 4308 New_Reference_To 4309 (RTE (RE_Stack_Bounded_Pool), Loc), 4310 4311 Constraint => 4312 Make_Index_Or_Discriminant_Constraint (Loc, 4313 Constraints => New_List ( 4314 4315 -- First discriminant is the Pool Size 4316 4317 New_Reference_To ( 4318 Storage_Size_Variable (Def_Id), Loc), 4319 4320 -- Second discriminant is the element size 4321 4322 DT_Size, 4323 4324 -- Third discriminant is the alignment 4325 4326 DT_Align))))); 4327 end; 4328 4329 Set_Associated_Storage_Pool (Def_Id, Pool_Object); 4330 4331 -- Case 3 4332 4333 -- Rep Clause "for Def_Id'Storage_Pool use a_Pool_Object" 4334 -- ---> Storage Pool is the specified one 4335 4336 elsif Present (Associated_Storage_Pool (Def_Id)) then 4337 4338 -- Nothing to do the associated storage pool has been attached 4339 -- when analyzing the rep. clause 4340 4341 null; 4342 end if; 4343 4344 -- For access-to-controlled types (including class-wide types 4345 -- and Taft-amendment types which potentially have controlled 4346 -- components), expand the list controller object that will 4347 -- store the dynamically allocated objects. Do not do this 4348 -- transformation for expander-generated access types, but do it 4349 -- for types that are the full view of types derived from other 4350 -- private types. Also suppress the list controller in the case 4351 -- of a designated type with convention Java, since this is used 4352 -- when binding to Java API specs, where there's no equivalent 4353 -- of a finalization list and we don't want to pull in the 4354 -- finalization support if not needed. 4355 4356 if not Comes_From_Source (Def_Id) 4357 and then not Has_Private_Declaration (Def_Id) 4358 then 4359 null; 4360 4361 elsif (Controlled_Type (Desig_Type) 4362 and then Convention (Desig_Type) /= Convention_Java) 4363 or else 4364 (Is_Incomplete_Or_Private_Type (Desig_Type) 4365 and then No (Full_View (Desig_Type)) 4366 4367 -- An exception is made for types defined in the run-time 4368 -- because Ada.Tags.Tag itself is such a type and cannot 4369 -- afford this unnecessary overhead that would generates a 4370 -- loop in the expansion scheme... 4371 4372 and then not In_Runtime (Def_Id) 4373 4374 -- Another exception is if Restrictions (No_Finalization) 4375 -- is active, since then we know nothing is controlled. 4376 4377 and then not Restrictions (No_Finalization)) 4378 4379 -- If the designated type is not frozen yet, its controlled 4380 -- status must be retrieved explicitly. 4381 4382 or else (Is_Array_Type (Desig_Type) 4383 and then not Is_Frozen (Desig_Type) 4384 and then Controlled_Type (Component_Type (Desig_Type))) 4385 then 4386 Set_Associated_Final_Chain (Def_Id, 4387 Make_Defining_Identifier (Loc, 4388 New_External_Name (Chars (Def_Id), 'L'))); 4389 4390 Append_Freeze_Action (Def_Id, 4391 Make_Object_Declaration (Loc, 4392 Defining_Identifier => Associated_Final_Chain (Def_Id), 4393 Object_Definition => 4394 New_Reference_To (RTE (RE_List_Controller), Loc))); 4395 end if; 4396 end; 4397 4398 -- Freeze processing for enumeration types 4399 4400 elsif Ekind (Def_Id) = E_Enumeration_Type then 4401 4402 -- We only have something to do if we have a non-standard 4403 -- representation (i.e. at least one literal whose pos value 4404 -- is not the same as its representation) 4405 4406 if Has_Non_Standard_Rep (Def_Id) then 4407 Freeze_Enumeration_Type (N); 4408 end if; 4409 4410 -- Private types that are completed by a derivation from a private 4411 -- type have an internally generated full view, that needs to be 4412 -- frozen. This must be done explicitly because the two views share 4413 -- the freeze node, and the underlying full view is not visible when 4414 -- the freeze node is analyzed. 4415 4416 elsif Is_Private_Type (Def_Id) 4417 and then Is_Derived_Type (Def_Id) 4418 and then Present (Full_View (Def_Id)) 4419 and then Is_Itype (Full_View (Def_Id)) 4420 and then Has_Private_Declaration (Full_View (Def_Id)) 4421 and then Freeze_Node (Full_View (Def_Id)) = N 4422 then 4423 Set_Entity (N, Full_View (Def_Id)); 4424 Freeze_Type (N); 4425 Set_Entity (N, Def_Id); 4426 4427 -- All other types require no expander action. There are such 4428 -- cases (e.g. task types and protected types). In such cases, 4429 -- the freeze nodes are there for use by Gigi. 4430 4431 end if; 4432 4433 Freeze_Stream_Operations (N, Def_Id); 4434 4435 exception 4436 when RE_Not_Available => 4437 return; 4438 end Freeze_Type; 4439 4440 ------------------------- 4441 -- Get_Simple_Init_Val -- 4442 ------------------------- 4443 4444 function Get_Simple_Init_Val 4445 (T : Entity_Id; 4446 Loc : Source_Ptr) 4447 return Node_Id 4448 is 4449 Val : Node_Id; 4450 Typ : Node_Id; 4451 Result : Node_Id; 4452 Val_RE : RE_Id; 4453 4454 begin 4455 -- For a private type, we should always have an underlying type 4456 -- (because this was already checked in Needs_Simple_Initialization). 4457 -- What we do is to get the value for the underlying type and then 4458 -- do an Unchecked_Convert to the private type. 4459 4460 if Is_Private_Type (T) then 4461 Val := Get_Simple_Init_Val (Underlying_Type (T), Loc); 4462 4463 -- A special case, if the underlying value is null, then qualify 4464 -- it with the underlying type, so that the null is properly typed 4465 -- Similarly, if it is an aggregate it must be qualified, because 4466 -- an unchecked conversion does not provide a context for it. 4467 4468 if Nkind (Val) = N_Null 4469 or else Nkind (Val) = N_Aggregate 4470 then 4471 Val := 4472 Make_Qualified_Expression (Loc, 4473 Subtype_Mark => 4474 New_Occurrence_Of (Underlying_Type (T), Loc), 4475 Expression => Val); 4476 end if; 4477 4478 Result := Unchecked_Convert_To (T, Val); 4479 4480 -- Don't truncate result (important for Initialize/Normalize_Scalars) 4481 4482 if Nkind (Result) = N_Unchecked_Type_Conversion 4483 and then Is_Scalar_Type (Underlying_Type (T)) 4484 then 4485 Set_No_Truncation (Result); 4486 end if; 4487 4488 return Result; 4489 4490 -- For scalars, we must have normalize/initialize scalars case 4491 4492 elsif Is_Scalar_Type (T) then 4493 pragma Assert (Init_Or_Norm_Scalars); 4494 4495 -- Processing for Normalize_Scalars case 4496 4497 if Normalize_Scalars then 4498 4499 -- First prepare a value (out of subtype range if possible) 4500 4501 if Is_Real_Type (T) or else Is_Integer_Type (T) then 4502 Val := 4503 Make_Attribute_Reference (Loc, 4504 Prefix => New_Occurrence_Of (Base_Type (T), Loc), 4505 Attribute_Name => Name_First); 4506 4507 elsif Is_Modular_Integer_Type (T) then 4508 Val := 4509 Make_Attribute_Reference (Loc, 4510 Prefix => New_Occurrence_Of (Base_Type (T), Loc), 4511 Attribute_Name => Name_Last); 4512 4513 else 4514 pragma Assert (Is_Enumeration_Type (T)); 4515 4516 if Esize (T) <= 8 then 4517 Typ := RTE (RE_Unsigned_8); 4518 elsif Esize (T) <= 16 then 4519 Typ := RTE (RE_Unsigned_16); 4520 elsif Esize (T) <= 32 then 4521 Typ := RTE (RE_Unsigned_32); 4522 else 4523 Typ := RTE (RE_Unsigned_64); 4524 end if; 4525 4526 Val := 4527 Make_Attribute_Reference (Loc, 4528 Prefix => New_Occurrence_Of (Typ, Loc), 4529 Attribute_Name => Name_Last); 4530 end if; 4531 4532 -- Here for Initialize_Scalars case 4533 4534 else 4535 if Is_Floating_Point_Type (T) then 4536 if Root_Type (T) = Standard_Short_Float then 4537 Val_RE := RE_IS_Isf; 4538 elsif Root_Type (T) = Standard_Float then 4539 Val_RE := RE_IS_Ifl; 4540 elsif Root_Type (T) = Standard_Long_Float then 4541 Val_RE := RE_IS_Ilf; 4542 else pragma Assert (Root_Type (T) = Standard_Long_Long_Float); 4543 Val_RE := RE_IS_Ill; 4544 end if; 4545 4546 elsif Is_Unsigned_Type (Base_Type (T)) then 4547 if Esize (T) = 8 then 4548 Val_RE := RE_IS_Iu1; 4549 elsif Esize (T) = 16 then 4550 Val_RE := RE_IS_Iu2; 4551 elsif Esize (T) = 32 then 4552 Val_RE := RE_IS_Iu4; 4553 else pragma Assert (Esize (T) = 64); 4554 Val_RE := RE_IS_Iu8; 4555 end if; 4556 4557 else -- signed type 4558 if Esize (T) = 8 then 4559 Val_RE := RE_IS_Is1; 4560 elsif Esize (T) = 16 then 4561 Val_RE := RE_IS_Is2; 4562 elsif Esize (T) = 32 then 4563 Val_RE := RE_IS_Is4; 4564 else pragma Assert (Esize (T) = 64); 4565 Val_RE := RE_IS_Is8; 4566 end if; 4567 end if; 4568 4569 Val := New_Occurrence_Of (RTE (Val_RE), Loc); 4570 end if; 4571 4572 -- The final expression is obtained by doing an unchecked 4573 -- conversion of this result to the base type of the 4574 -- required subtype. We use the base type to avoid the 4575 -- unchecked conversion from chopping bits, and then we 4576 -- set Kill_Range_Check to preserve the "bad" value. 4577 4578 Result := Unchecked_Convert_To (Base_Type (T), Val); 4579 4580 -- Ensure result is not truncated, since we want the "bad" bits 4581 -- and also kill range check on result. 4582 4583 if Nkind (Result) = N_Unchecked_Type_Conversion then 4584 Set_No_Truncation (Result); 4585 Set_Kill_Range_Check (Result, True); 4586 end if; 4587 4588 return Result; 4589 4590 -- String or Wide_String (must have Initialize_Scalars set) 4591 4592 elsif Root_Type (T) = Standard_String 4593 or else 4594 Root_Type (T) = Standard_Wide_String 4595 then 4596 pragma Assert (Init_Or_Norm_Scalars); 4597 4598 return 4599 Make_Aggregate (Loc, 4600 Component_Associations => New_List ( 4601 Make_Component_Association (Loc, 4602 Choices => New_List ( 4603 Make_Others_Choice (Loc)), 4604 Expression => 4605 Get_Simple_Init_Val (Component_Type (T), Loc)))); 4606 4607 -- Access type is initialized to null 4608 4609 elsif Is_Access_Type (T) then 4610 return 4611 Make_Null (Loc); 4612 4613 -- We initialize modular packed bit arrays to zero, to make sure that 4614 -- unused bits are zero, as required (see spec of Exp_Pakd). Also note 4615 -- that this improves gigi code, since the value tracing knows that 4616 -- all bits of the variable start out at zero. The value of zero has 4617 -- to be unchecked converted to the proper array type. 4618 4619 elsif Is_Bit_Packed_Array (T) then 4620 declare 4621 PAT : constant Entity_Id := Packed_Array_Type (T); 4622 Nod : Node_Id; 4623 4624 begin 4625 pragma Assert (Is_Modular_Integer_Type (PAT)); 4626 4627 Nod := 4628 Make_Unchecked_Type_Conversion (Loc, 4629 Subtype_Mark => New_Occurrence_Of (T, Loc), 4630 Expression => Make_Integer_Literal (Loc, 0)); 4631 4632 Set_Etype (Expression (Nod), PAT); 4633 return Nod; 4634 end; 4635 4636 -- No other possibilities should arise, since we should only be 4637 -- calling Get_Simple_Init_Val if Needs_Simple_Initialization 4638 -- returned True, indicating one of the above cases held. 4639 4640 else 4641 raise Program_Error; 4642 end if; 4643 4644 exception 4645 when RE_Not_Available => 4646 return Empty; 4647 end Get_Simple_Init_Val; 4648 4649 ------------------------------ 4650 -- Has_New_Non_Standard_Rep -- 4651 ------------------------------ 4652 4653 function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean is 4654 begin 4655 if not Is_Derived_Type (T) then 4656 return Has_Non_Standard_Rep (T) 4657 or else Has_Non_Standard_Rep (Root_Type (T)); 4658 4659 -- If Has_Non_Standard_Rep is not set on the derived type, the 4660 -- representation is fully inherited. 4661 4662 elsif not Has_Non_Standard_Rep (T) then 4663 return False; 4664 4665 else 4666 return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T)); 4667 4668 -- May need a more precise check here: the First_Rep_Item may 4669 -- be a stream attribute, which does not affect the representation 4670 -- of the type ??? 4671 end if; 4672 end Has_New_Non_Standard_Rep; 4673 4674 ---------------- 4675 -- In_Runtime -- 4676 ---------------- 4677 4678 function In_Runtime (E : Entity_Id) return Boolean is 4679 S1 : Entity_Id := Scope (E); 4680 4681 begin 4682 while Scope (S1) /= Standard_Standard loop 4683 S1 := Scope (S1); 4684 end loop; 4685 4686 return Chars (S1) = Name_System or else Chars (S1) = Name_Ada; 4687 end In_Runtime; 4688 4689 ------------------ 4690 -- Init_Formals -- 4691 ------------------ 4692 4693 function Init_Formals (Typ : Entity_Id) return List_Id is 4694 Loc : constant Source_Ptr := Sloc (Typ); 4695 Formals : List_Id; 4696 4697 begin 4698 -- First parameter is always _Init : in out typ. Note that we need 4699 -- this to be in/out because in the case of the task record value, 4700 -- there are default record fields (_Priority, _Size, -Task_Info) 4701 -- that may be referenced in the generated initialization routine. 4702 4703 Formals := New_List ( 4704 Make_Parameter_Specification (Loc, 4705 Defining_Identifier => 4706 Make_Defining_Identifier (Loc, Name_uInit), 4707 In_Present => True, 4708 Out_Present => True, 4709 Parameter_Type => New_Reference_To (Typ, Loc))); 4710 4711 -- For task record value, or type that contains tasks, add two more 4712 -- formals, _Master : Master_Id and _Chain : in out Activation_Chain 4713 -- We also add these parameters for the task record type case. 4714 4715 if Has_Task (Typ) 4716 or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) 4717 then 4718 Append_To (Formals, 4719 Make_Parameter_Specification (Loc, 4720 Defining_Identifier => 4721 Make_Defining_Identifier (Loc, Name_uMaster), 4722 Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); 4723 4724 Append_To (Formals, 4725 Make_Parameter_Specification (Loc, 4726 Defining_Identifier => 4727 Make_Defining_Identifier (Loc, Name_uChain), 4728 In_Present => True, 4729 Out_Present => True, 4730 Parameter_Type => 4731 New_Reference_To (RTE (RE_Activation_Chain), Loc))); 4732 4733 Append_To (Formals, 4734 Make_Parameter_Specification (Loc, 4735 Defining_Identifier => 4736 Make_Defining_Identifier (Loc, Name_uTask_Name), 4737 In_Present => True, 4738 Parameter_Type => 4739 New_Reference_To (Standard_String, Loc))); 4740 end if; 4741 4742 return Formals; 4743 4744 exception 4745 when RE_Not_Available => 4746 return Empty_List; 4747 end Init_Formals; 4748 4749 ------------------ 4750 -- Make_Eq_Case -- 4751 ------------------ 4752 4753 -- <Make_Eq_if shared components> 4754 -- case X.D1 is 4755 -- when V1 => <Make_Eq_Case> on subcomponents 4756 -- ... 4757 -- when Vn => <Make_Eq_Case> on subcomponents 4758 -- end case; 4759 4760 function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id is 4761 Loc : constant Source_Ptr := Sloc (Node); 4762 Result : constant List_Id := New_List; 4763 Variant : Node_Id; 4764 Alt_List : List_Id; 4765 4766 begin 4767 Append_To (Result, Make_Eq_If (Node, Component_Items (CL))); 4768 4769 if No (Variant_Part (CL)) then 4770 return Result; 4771 end if; 4772 4773 Variant := First_Non_Pragma (Variants (Variant_Part (CL))); 4774 4775 if No (Variant) then 4776 return Result; 4777 end if; 4778 4779 Alt_List := New_List; 4780 4781 while Present (Variant) loop 4782 Append_To (Alt_List, 4783 Make_Case_Statement_Alternative (Loc, 4784 Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), 4785 Statements => Make_Eq_Case (Node, Component_List (Variant)))); 4786 4787 Next_Non_Pragma (Variant); 4788 end loop; 4789 4790 Append_To (Result, 4791 Make_Case_Statement (Loc, 4792 Expression => 4793 Make_Selected_Component (Loc, 4794 Prefix => Make_Identifier (Loc, Name_X), 4795 Selector_Name => New_Copy (Name (Variant_Part (CL)))), 4796 Alternatives => Alt_List)); 4797 4798 return Result; 4799 end Make_Eq_Case; 4800 4801 ---------------- 4802 -- Make_Eq_If -- 4803 ---------------- 4804 4805 -- Generates: 4806 4807 -- if 4808 -- X.C1 /= Y.C1 4809 -- or else 4810 -- X.C2 /= Y.C2 4811 -- ... 4812 -- then 4813 -- return False; 4814 -- end if; 4815 4816 -- or a null statement if the list L is empty 4817 4818 function Make_Eq_If (Node : Node_Id; L : List_Id) return Node_Id is 4819 Loc : constant Source_Ptr := Sloc (Node); 4820 C : Node_Id; 4821 Field_Name : Name_Id; 4822 Cond : Node_Id; 4823 4824 begin 4825 if No (L) then 4826 return Make_Null_Statement (Loc); 4827 4828 else 4829 Cond := Empty; 4830 4831 C := First_Non_Pragma (L); 4832 while Present (C) loop 4833 Field_Name := Chars (Defining_Identifier (C)); 4834 4835 -- The tags must not be compared they are not part of the value. 4836 -- Note also that in the following, we use Make_Identifier for 4837 -- the component names. Use of New_Reference_To to identify the 4838 -- components would be incorrect because the wrong entities for 4839 -- discriminants could be picked up in the private type case. 4840 4841 if Field_Name /= Name_uTag then 4842 Evolve_Or_Else (Cond, 4843 Make_Op_Ne (Loc, 4844 Left_Opnd => 4845 Make_Selected_Component (Loc, 4846 Prefix => Make_Identifier (Loc, Name_X), 4847 Selector_Name => 4848 Make_Identifier (Loc, Field_Name)), 4849 4850 Right_Opnd => 4851 Make_Selected_Component (Loc, 4852 Prefix => Make_Identifier (Loc, Name_Y), 4853 Selector_Name => 4854 Make_Identifier (Loc, Field_Name)))); 4855 end if; 4856 4857 Next_Non_Pragma (C); 4858 end loop; 4859 4860 if No (Cond) then 4861 return Make_Null_Statement (Loc); 4862 4863 else 4864 return 4865 Make_Implicit_If_Statement (Node, 4866 Condition => Cond, 4867 Then_Statements => New_List ( 4868 Make_Return_Statement (Loc, 4869 Expression => New_Occurrence_Of (Standard_False, Loc)))); 4870 end if; 4871 end if; 4872 end Make_Eq_If; 4873 4874 ------------------------------------- 4875 -- Make_Predefined_Primitive_Specs -- 4876 ------------------------------------- 4877 4878 procedure Make_Predefined_Primitive_Specs 4879 (Tag_Typ : Entity_Id; 4880 Predef_List : out List_Id; 4881 Renamed_Eq : out Node_Id) 4882 is 4883 Loc : constant Source_Ptr := Sloc (Tag_Typ); 4884 Res : constant List_Id := New_List; 4885 Prim : Elmt_Id; 4886 Eq_Needed : Boolean; 4887 Eq_Spec : Node_Id; 4888 Eq_Name : Name_Id := Name_Op_Eq; 4889 4890 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean; 4891 -- Returns true if Prim is a renaming of an unresolved predefined 4892 -- equality operation. 4893 4894 ------------------------------- 4895 -- Is_Predefined_Eq_Renaming -- 4896 ------------------------------- 4897 4898 function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is 4899 begin 4900 return Chars (Prim) /= Name_Op_Eq 4901 and then Present (Alias (Prim)) 4902 and then Comes_From_Source (Prim) 4903 and then Is_Intrinsic_Subprogram (Alias (Prim)) 4904 and then Chars (Alias (Prim)) = Name_Op_Eq; 4905 end Is_Predefined_Eq_Renaming; 4906 4907 -- Start of processing for Make_Predefined_Primitive_Specs 4908 4909 begin 4910 Renamed_Eq := Empty; 4911 4912 -- Spec of _Alignment 4913 4914 Append_To (Res, Predef_Spec_Or_Body (Loc, 4915 Tag_Typ => Tag_Typ, 4916 Name => Name_uAlignment, 4917 Profile => New_List ( 4918 Make_Parameter_Specification (Loc, 4919 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 4920 Parameter_Type => New_Reference_To (Tag_Typ, Loc))), 4921 4922 Ret_Type => Standard_Integer)); 4923 4924 -- Spec of _Size 4925 4926 Append_To (Res, Predef_Spec_Or_Body (Loc, 4927 Tag_Typ => Tag_Typ, 4928 Name => Name_uSize, 4929 Profile => New_List ( 4930 Make_Parameter_Specification (Loc, 4931 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 4932 Parameter_Type => New_Reference_To (Tag_Typ, Loc))), 4933 4934 Ret_Type => Standard_Long_Long_Integer)); 4935 4936 -- Specs for dispatching stream attributes. We skip these for limited 4937 -- types, since there is no question of dispatching in the limited case. 4938 4939 -- We also skip these operations if dispatching is not available 4940 -- or if streams are not available (since what's the point?) 4941 4942 if not Is_Limited_Type (Tag_Typ) 4943 and then RTE_Available (RE_Tag) 4944 and then RTE_Available (RE_Root_Stream_Type) 4945 then 4946 Append_To (Res, 4947 Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Read)); 4948 Append_To (Res, 4949 Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Write)); 4950 Append_To (Res, 4951 Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Input)); 4952 Append_To (Res, 4953 Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Output)); 4954 end if; 4955 4956 -- Spec of "=" if expanded if the type is not limited and if a 4957 -- user defined "=" was not already declared for the non-full 4958 -- view of a private extension 4959 4960 if not Is_Limited_Type (Tag_Typ) then 4961 Eq_Needed := True; 4962 4963 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 4964 while Present (Prim) loop 4965 4966 -- If a primitive is encountered that renames the predefined 4967 -- equality operator before reaching any explicit equality 4968 -- primitive, then we still need to create a predefined 4969 -- equality function, because calls to it can occur via 4970 -- the renaming. A new name is created for the equality 4971 -- to avoid conflicting with any user-defined equality. 4972 -- (Note that this doesn't account for renamings of 4973 -- equality nested within subpackages???) 4974 4975 if Is_Predefined_Eq_Renaming (Node (Prim)) then 4976 Eq_Name := New_External_Name (Chars (Node (Prim)), 'E'); 4977 4978 elsif Chars (Node (Prim)) = Name_Op_Eq 4979 and then (No (Alias (Node (Prim))) 4980 or else Nkind (Unit_Declaration_Node (Node (Prim))) = 4981 N_Subprogram_Renaming_Declaration) 4982 and then Etype (First_Formal (Node (Prim))) = 4983 Etype (Next_Formal (First_Formal (Node (Prim)))) 4984 4985 then 4986 Eq_Needed := False; 4987 exit; 4988 4989 -- If the parent equality is abstract, the inherited equality is 4990 -- abstract as well, and no body can be created for for it. 4991 4992 elsif Chars (Node (Prim)) = Name_Op_Eq 4993 and then Present (Alias (Node (Prim))) 4994 and then Is_Abstract (Alias (Node (Prim))) 4995 then 4996 Eq_Needed := False; 4997 exit; 4998 end if; 4999 5000 Next_Elmt (Prim); 5001 end loop; 5002 5003 -- If a renaming of predefined equality was found 5004 -- but there was no user-defined equality (so Eq_Needed 5005 -- is still true), then set the name back to Name_Op_Eq. 5006 -- But in the case where a user-defined equality was 5007 -- located after such a renaming, then the predefined 5008 -- equality function is still needed, so Eq_Needed must 5009 -- be set back to True. 5010 5011 if Eq_Name /= Name_Op_Eq then 5012 if Eq_Needed then 5013 Eq_Name := Name_Op_Eq; 5014 else 5015 Eq_Needed := True; 5016 end if; 5017 end if; 5018 5019 if Eq_Needed then 5020 Eq_Spec := Predef_Spec_Or_Body (Loc, 5021 Tag_Typ => Tag_Typ, 5022 Name => Eq_Name, 5023 Profile => New_List ( 5024 Make_Parameter_Specification (Loc, 5025 Defining_Identifier => 5026 Make_Defining_Identifier (Loc, Name_X), 5027 Parameter_Type => New_Reference_To (Tag_Typ, Loc)), 5028 Make_Parameter_Specification (Loc, 5029 Defining_Identifier => 5030 Make_Defining_Identifier (Loc, Name_Y), 5031 Parameter_Type => New_Reference_To (Tag_Typ, Loc))), 5032 Ret_Type => Standard_Boolean); 5033 Append_To (Res, Eq_Spec); 5034 5035 if Eq_Name /= Name_Op_Eq then 5036 Renamed_Eq := Defining_Unit_Name (Specification (Eq_Spec)); 5037 5038 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 5039 while Present (Prim) loop 5040 5041 -- Any renamings of equality that appeared before an 5042 -- overriding equality must be updated to refer to 5043 -- the entity for the predefined equality, otherwise 5044 -- calls via the renaming would get incorrectly 5045 -- resolved to call the user-defined equality function. 5046 5047 if Is_Predefined_Eq_Renaming (Node (Prim)) then 5048 Set_Alias (Node (Prim), Renamed_Eq); 5049 5050 -- Exit upon encountering a user-defined equality 5051 5052 elsif Chars (Node (Prim)) = Name_Op_Eq 5053 and then No (Alias (Node (Prim))) 5054 then 5055 exit; 5056 end if; 5057 5058 Next_Elmt (Prim); 5059 end loop; 5060 end if; 5061 end if; 5062 5063 -- Spec for dispatching assignment 5064 5065 Append_To (Res, Predef_Spec_Or_Body (Loc, 5066 Tag_Typ => Tag_Typ, 5067 Name => Name_uAssign, 5068 Profile => New_List ( 5069 Make_Parameter_Specification (Loc, 5070 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 5071 Out_Present => True, 5072 Parameter_Type => New_Reference_To (Tag_Typ, Loc)), 5073 5074 Make_Parameter_Specification (Loc, 5075 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), 5076 Parameter_Type => New_Reference_To (Tag_Typ, Loc))))); 5077 end if; 5078 5079 -- Specs for finalization actions that may be required in case a 5080 -- future extension contain a controlled element. We generate those 5081 -- only for root tagged types where they will get dummy bodies or 5082 -- when the type has controlled components and their body must be 5083 -- generated. It is also impossible to provide those for tagged 5084 -- types defined within s-finimp since it would involve circularity 5085 -- problems 5086 5087 if In_Finalization_Root (Tag_Typ) then 5088 null; 5089 5090 -- We also skip these if finalization is not available 5091 5092 elsif Restrictions (No_Finalization) then 5093 null; 5094 5095 elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then 5096 if not Is_Limited_Type (Tag_Typ) then 5097 Append_To (Res, 5098 Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust)); 5099 end if; 5100 5101 Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize)); 5102 end if; 5103 5104 Predef_List := Res; 5105 end Make_Predefined_Primitive_Specs; 5106 5107 --------------------------------- 5108 -- Needs_Simple_Initialization -- 5109 --------------------------------- 5110 5111 function Needs_Simple_Initialization (T : Entity_Id) return Boolean is 5112 begin 5113 -- Check for private type, in which case test applies to the 5114 -- underlying type of the private type. 5115 5116 if Is_Private_Type (T) then 5117 declare 5118 RT : constant Entity_Id := Underlying_Type (T); 5119 5120 begin 5121 if Present (RT) then 5122 return Needs_Simple_Initialization (RT); 5123 else 5124 return False; 5125 end if; 5126 end; 5127 5128 -- Cases needing simple initialization are access types, and, if pragma 5129 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar 5130 -- types. 5131 5132 elsif Is_Access_Type (T) 5133 or else (Init_Or_Norm_Scalars and then (Is_Scalar_Type (T))) 5134 5135 or else (Is_Bit_Packed_Array (T) 5136 and then Is_Modular_Integer_Type (Packed_Array_Type (T))) 5137 then 5138 return True; 5139 5140 -- If Initialize/Normalize_Scalars is in effect, string objects also 5141 -- need initialization, unless they are created in the course of 5142 -- expanding an aggregate (since in the latter case they will be 5143 -- filled with appropriate initializing values before they are used). 5144 5145 elsif Init_Or_Norm_Scalars 5146 and then 5147 (Root_Type (T) = Standard_String 5148 or else Root_Type (T) = Standard_Wide_String) 5149 and then 5150 (not Is_Itype (T) 5151 or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) 5152 then 5153 return True; 5154 5155 else 5156 return False; 5157 end if; 5158 end Needs_Simple_Initialization; 5159 5160 ---------------------- 5161 -- Predef_Deep_Spec -- 5162 ---------------------- 5163 5164 function Predef_Deep_Spec 5165 (Loc : Source_Ptr; 5166 Tag_Typ : Entity_Id; 5167 Name : TSS_Name_Type; 5168 For_Body : Boolean := False) 5169 return Node_Id 5170 is 5171 Prof : List_Id; 5172 Type_B : Entity_Id; 5173 5174 begin 5175 if Name = TSS_Deep_Finalize then 5176 Prof := New_List; 5177 Type_B := Standard_Boolean; 5178 5179 else 5180 Prof := New_List ( 5181 Make_Parameter_Specification (Loc, 5182 Defining_Identifier => Make_Defining_Identifier (Loc, Name_L), 5183 In_Present => True, 5184 Out_Present => True, 5185 Parameter_Type => 5186 New_Reference_To (RTE (RE_Finalizable_Ptr), Loc))); 5187 Type_B := Standard_Short_Short_Integer; 5188 end if; 5189 5190 Append_To (Prof, 5191 Make_Parameter_Specification (Loc, 5192 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 5193 In_Present => True, 5194 Out_Present => True, 5195 Parameter_Type => New_Reference_To (Tag_Typ, Loc))); 5196 5197 Append_To (Prof, 5198 Make_Parameter_Specification (Loc, 5199 Defining_Identifier => Make_Defining_Identifier (Loc, Name_B), 5200 Parameter_Type => New_Reference_To (Type_B, Loc))); 5201 5202 return Predef_Spec_Or_Body (Loc, 5203 Name => Make_TSS_Name (Tag_Typ, Name), 5204 Tag_Typ => Tag_Typ, 5205 Profile => Prof, 5206 For_Body => For_Body); 5207 5208 exception 5209 when RE_Not_Available => 5210 return Empty; 5211 end Predef_Deep_Spec; 5212 5213 ------------------------- 5214 -- Predef_Spec_Or_Body -- 5215 ------------------------- 5216 5217 function Predef_Spec_Or_Body 5218 (Loc : Source_Ptr; 5219 Tag_Typ : Entity_Id; 5220 Name : Name_Id; 5221 Profile : List_Id; 5222 Ret_Type : Entity_Id := Empty; 5223 For_Body : Boolean := False) 5224 return Node_Id 5225 is 5226 Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name); 5227 Spec : Node_Id; 5228 5229 begin 5230 Set_Is_Public (Id, Is_Public (Tag_Typ)); 5231 5232 -- The internal flag is set to mark these declarations because 5233 -- they have specific properties. First they are primitives even 5234 -- if they are not defined in the type scope (the freezing point 5235 -- is not necessarily in the same scope), furthermore the 5236 -- predefined equality can be overridden by a user-defined 5237 -- equality, no body will be generated in this case. 5238 5239 Set_Is_Internal (Id); 5240 5241 if not Debug_Generated_Code then 5242 Set_Debug_Info_Off (Id); 5243 end if; 5244 5245 if No (Ret_Type) then 5246 Spec := 5247 Make_Procedure_Specification (Loc, 5248 Defining_Unit_Name => Id, 5249 Parameter_Specifications => Profile); 5250 else 5251 Spec := 5252 Make_Function_Specification (Loc, 5253 Defining_Unit_Name => Id, 5254 Parameter_Specifications => Profile, 5255 Subtype_Mark => 5256 New_Reference_To (Ret_Type, Loc)); 5257 end if; 5258 5259 -- If body case, return empty subprogram body. Note that this is 5260 -- ill-formed, because there is not even a null statement, and 5261 -- certainly not a return in the function case. The caller is 5262 -- expected to do surgery on the body to add the appropriate stuff. 5263 5264 if For_Body then 5265 return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty); 5266 5267 -- For the case of Input/Output attributes applied to an abstract type, 5268 -- generate abstract specifications. These will never be called, 5269 -- but we need the slots allocated in the dispatching table so 5270 -- that typ'Class'Input and typ'Class'Output will work properly. 5271 5272 elsif (Is_TSS (Name, TSS_Stream_Input) 5273 or else 5274 Is_TSS (Name, TSS_Stream_Output)) 5275 and then Is_Abstract (Tag_Typ) 5276 then 5277 return Make_Abstract_Subprogram_Declaration (Loc, Spec); 5278 5279 -- Normal spec case, where we return a subprogram declaration 5280 5281 else 5282 return Make_Subprogram_Declaration (Loc, Spec); 5283 end if; 5284 end Predef_Spec_Or_Body; 5285 5286 ----------------------------- 5287 -- Predef_Stream_Attr_Spec -- 5288 ----------------------------- 5289 5290 function Predef_Stream_Attr_Spec 5291 (Loc : Source_Ptr; 5292 Tag_Typ : Entity_Id; 5293 Name : TSS_Name_Type; 5294 For_Body : Boolean := False) 5295 return Node_Id 5296 is 5297 Ret_Type : Entity_Id; 5298 5299 begin 5300 if Name = TSS_Stream_Input then 5301 Ret_Type := Tag_Typ; 5302 else 5303 Ret_Type := Empty; 5304 end if; 5305 5306 return Predef_Spec_Or_Body (Loc, 5307 Name => Make_TSS_Name (Tag_Typ, Name), 5308 Tag_Typ => Tag_Typ, 5309 Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), 5310 Ret_Type => Ret_Type, 5311 For_Body => For_Body); 5312 end Predef_Stream_Attr_Spec; 5313 5314 --------------------------------- 5315 -- Predefined_Primitive_Bodies -- 5316 --------------------------------- 5317 5318 function Predefined_Primitive_Bodies 5319 (Tag_Typ : Entity_Id; 5320 Renamed_Eq : Node_Id) 5321 return List_Id 5322 is 5323 Loc : constant Source_Ptr := Sloc (Tag_Typ); 5324 Res : constant List_Id := New_List; 5325 Decl : Node_Id; 5326 Prim : Elmt_Id; 5327 Eq_Needed : Boolean; 5328 Eq_Name : Name_Id; 5329 Ent : Entity_Id; 5330 5331 begin 5332 -- See if we have a predefined "=" operator 5333 5334 if Present (Renamed_Eq) then 5335 Eq_Needed := True; 5336 Eq_Name := Chars (Renamed_Eq); 5337 5338 else 5339 Eq_Needed := False; 5340 Eq_Name := No_Name; 5341 5342 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 5343 while Present (Prim) loop 5344 if Chars (Node (Prim)) = Name_Op_Eq 5345 and then Is_Internal (Node (Prim)) 5346 then 5347 Eq_Needed := True; 5348 Eq_Name := Name_Op_Eq; 5349 end if; 5350 5351 Next_Elmt (Prim); 5352 end loop; 5353 end if; 5354 5355 -- Body of _Alignment 5356 5357 Decl := Predef_Spec_Or_Body (Loc, 5358 Tag_Typ => Tag_Typ, 5359 Name => Name_uAlignment, 5360 Profile => New_List ( 5361 Make_Parameter_Specification (Loc, 5362 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 5363 Parameter_Type => New_Reference_To (Tag_Typ, Loc))), 5364 5365 Ret_Type => Standard_Integer, 5366 For_Body => True); 5367 5368 Set_Handled_Statement_Sequence (Decl, 5369 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 5370 Make_Return_Statement (Loc, 5371 Expression => 5372 Make_Attribute_Reference (Loc, 5373 Prefix => Make_Identifier (Loc, Name_X), 5374 Attribute_Name => Name_Alignment))))); 5375 5376 Append_To (Res, Decl); 5377 5378 -- Body of _Size 5379 5380 Decl := Predef_Spec_Or_Body (Loc, 5381 Tag_Typ => Tag_Typ, 5382 Name => Name_uSize, 5383 Profile => New_List ( 5384 Make_Parameter_Specification (Loc, 5385 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 5386 Parameter_Type => New_Reference_To (Tag_Typ, Loc))), 5387 5388 Ret_Type => Standard_Long_Long_Integer, 5389 For_Body => True); 5390 5391 Set_Handled_Statement_Sequence (Decl, 5392 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 5393 Make_Return_Statement (Loc, 5394 Expression => 5395 Make_Attribute_Reference (Loc, 5396 Prefix => Make_Identifier (Loc, Name_X), 5397 Attribute_Name => Name_Size))))); 5398 5399 Append_To (Res, Decl); 5400 5401 -- Bodies for Dispatching stream IO routines. We need these only for 5402 -- non-limited types (in the limited case there is no dispatching). 5403 -- We also skip them if dispatching is not available. 5404 5405 if not Is_Limited_Type (Tag_Typ) 5406 and then not Restrictions (No_Finalization) 5407 then 5408 if No (TSS (Tag_Typ, TSS_Stream_Read)) then 5409 Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent); 5410 Append_To (Res, Decl); 5411 end if; 5412 5413 if No (TSS (Tag_Typ, TSS_Stream_Write)) then 5414 Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent); 5415 Append_To (Res, Decl); 5416 end if; 5417 5418 -- Skip bodies of _Input and _Output for the abstract case, since 5419 -- the corresponding specs are abstract (see Predef_Spec_Or_Body) 5420 5421 if not Is_Abstract (Tag_Typ) then 5422 if No (TSS (Tag_Typ, TSS_Stream_Input)) then 5423 Build_Record_Or_Elementary_Input_Function 5424 (Loc, Tag_Typ, Decl, Ent); 5425 Append_To (Res, Decl); 5426 end if; 5427 5428 if No (TSS (Tag_Typ, TSS_Stream_Output)) then 5429 Build_Record_Or_Elementary_Output_Procedure 5430 (Loc, Tag_Typ, Decl, Ent); 5431 Append_To (Res, Decl); 5432 end if; 5433 end if; 5434 end if; 5435 5436 if not Is_Limited_Type (Tag_Typ) then 5437 5438 -- Body for equality 5439 5440 if Eq_Needed then 5441 5442 Decl := Predef_Spec_Or_Body (Loc, 5443 Tag_Typ => Tag_Typ, 5444 Name => Eq_Name, 5445 Profile => New_List ( 5446 Make_Parameter_Specification (Loc, 5447 Defining_Identifier => 5448 Make_Defining_Identifier (Loc, Name_X), 5449 Parameter_Type => New_Reference_To (Tag_Typ, Loc)), 5450 5451 Make_Parameter_Specification (Loc, 5452 Defining_Identifier => 5453 Make_Defining_Identifier (Loc, Name_Y), 5454 Parameter_Type => New_Reference_To (Tag_Typ, Loc))), 5455 5456 Ret_Type => Standard_Boolean, 5457 For_Body => True); 5458 5459 declare 5460 Def : constant Node_Id := Parent (Tag_Typ); 5461 Stmts : constant List_Id := New_List; 5462 Variant_Case : Boolean := Has_Discriminants (Tag_Typ); 5463 Comps : Node_Id := Empty; 5464 Typ_Def : Node_Id := Type_Definition (Def); 5465 5466 begin 5467 if Variant_Case then 5468 if Nkind (Typ_Def) = N_Derived_Type_Definition then 5469 Typ_Def := Record_Extension_Part (Typ_Def); 5470 end if; 5471 5472 if Present (Typ_Def) then 5473 Comps := Component_List (Typ_Def); 5474 end if; 5475 5476 Variant_Case := Present (Comps) 5477 and then Present (Variant_Part (Comps)); 5478 end if; 5479 5480 if Variant_Case then 5481 Append_To (Stmts, 5482 Make_Eq_If (Tag_Typ, Discriminant_Specifications (Def))); 5483 Append_List_To (Stmts, Make_Eq_Case (Tag_Typ, Comps)); 5484 Append_To (Stmts, 5485 Make_Return_Statement (Loc, 5486 Expression => New_Reference_To (Standard_True, Loc))); 5487 5488 else 5489 Append_To (Stmts, 5490 Make_Return_Statement (Loc, 5491 Expression => 5492 Expand_Record_Equality (Tag_Typ, 5493 Typ => Tag_Typ, 5494 Lhs => Make_Identifier (Loc, Name_X), 5495 Rhs => Make_Identifier (Loc, Name_Y), 5496 Bodies => Declarations (Decl)))); 5497 end if; 5498 5499 Set_Handled_Statement_Sequence (Decl, 5500 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 5501 end; 5502 Append_To (Res, Decl); 5503 end if; 5504 5505 -- Body for dispatching assignment 5506 5507 Decl := Predef_Spec_Or_Body (Loc, 5508 Tag_Typ => Tag_Typ, 5509 Name => Name_uAssign, 5510 Profile => New_List ( 5511 Make_Parameter_Specification (Loc, 5512 Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), 5513 Out_Present => True, 5514 Parameter_Type => New_Reference_To (Tag_Typ, Loc)), 5515 5516 Make_Parameter_Specification (Loc, 5517 Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), 5518 Parameter_Type => New_Reference_To (Tag_Typ, Loc))), 5519 For_Body => True); 5520 5521 Set_Handled_Statement_Sequence (Decl, 5522 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 5523 Make_Assignment_Statement (Loc, 5524 Name => Make_Identifier (Loc, Name_X), 5525 Expression => Make_Identifier (Loc, Name_Y))))); 5526 5527 Append_To (Res, Decl); 5528 end if; 5529 5530 -- Generate dummy bodies for finalization actions of types that have 5531 -- no controlled components. 5532 5533 -- Skip this processing if we are in the finalization routine in the 5534 -- runtime itself, otherwise we get hopelessly circularly confused! 5535 5536 if In_Finalization_Root (Tag_Typ) then 5537 null; 5538 5539 -- Skip this if finalization is not available 5540 5541 elsif Restrictions (No_Finalization) then 5542 null; 5543 5544 elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ)) 5545 and then not Has_Controlled_Component (Tag_Typ) 5546 then 5547 if not Is_Limited_Type (Tag_Typ) then 5548 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); 5549 5550 if Is_Controlled (Tag_Typ) then 5551 Set_Handled_Statement_Sequence (Decl, 5552 Make_Handled_Sequence_Of_Statements (Loc, 5553 Make_Adjust_Call ( 5554 Ref => Make_Identifier (Loc, Name_V), 5555 Typ => Tag_Typ, 5556 Flist_Ref => Make_Identifier (Loc, Name_L), 5557 With_Attach => Make_Identifier (Loc, Name_B)))); 5558 5559 else 5560 Set_Handled_Statement_Sequence (Decl, 5561 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 5562 Make_Null_Statement (Loc)))); 5563 end if; 5564 5565 Append_To (Res, Decl); 5566 end if; 5567 5568 Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); 5569 5570 if Is_Controlled (Tag_Typ) then 5571 Set_Handled_Statement_Sequence (Decl, 5572 Make_Handled_Sequence_Of_Statements (Loc, 5573 Make_Final_Call ( 5574 Ref => Make_Identifier (Loc, Name_V), 5575 Typ => Tag_Typ, 5576 With_Detach => Make_Identifier (Loc, Name_B)))); 5577 5578 else 5579 Set_Handled_Statement_Sequence (Decl, 5580 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 5581 Make_Null_Statement (Loc)))); 5582 end if; 5583 5584 Append_To (Res, Decl); 5585 end if; 5586 5587 return Res; 5588 end Predefined_Primitive_Bodies; 5589 5590 --------------------------------- 5591 -- Predefined_Primitive_Freeze -- 5592 --------------------------------- 5593 5594 function Predefined_Primitive_Freeze 5595 (Tag_Typ : Entity_Id) return List_Id 5596 is 5597 Loc : constant Source_Ptr := Sloc (Tag_Typ); 5598 Res : constant List_Id := New_List; 5599 Prim : Elmt_Id; 5600 Frnodes : List_Id; 5601 5602 begin 5603 Prim := First_Elmt (Primitive_Operations (Tag_Typ)); 5604 while Present (Prim) loop 5605 if Is_Internal (Node (Prim)) then 5606 Frnodes := Freeze_Entity (Node (Prim), Loc); 5607 5608 if Present (Frnodes) then 5609 Append_List_To (Res, Frnodes); 5610 end if; 5611 end if; 5612 5613 Next_Elmt (Prim); 5614 end loop; 5615 5616 return Res; 5617 end Predefined_Primitive_Freeze; 5618end Exp_Ch3; 5619